Improved identification of wrong declarations. Simplified code for that.

src/CHANGELOG

@@ -92,6 +92,8 @@ ECL 0.9i
  - New SOCKET-SEND function, compatible with the SBCL one (contributed by
    Dmitri Hrapof).
 
+ - ECL's compiler will complain sooner about unknown declarations.
+
 * MOP compatibility:
 
  - SLOT-VALUE, SLOT-BOUNDP, etc, together with MOP SLOT*-USING-CLASS generic

src/clos/fixup.lsp

@@ -103,7 +103,7 @@
 		 :allow-other-keys t))
 
 (defun all-keywords (l)
-  (declare (si::cl-local))
+  (declare (si::c-local))
   (let ((all-keys '()))
     (do ((l (rest l) (cddddr l)))
 	((null l)

src/cmp/cmpenv.lsp

@@ -290,58 +290,54 @@
      ((and (consp form) (eq (car form) 'DECLARE))
       (push form all-declarations)
       (dolist (decl (cdr form))
-        (cmpck (or (not (consp decl)) (not (symbolp (car decl))))
-               "Syntax error in declaration ~s" (cons form decl))
-        (case (car decl)
-          (SPECIAL
-           (dolist (var (cdr decl))
-             (cmpck (not (symbolp var))
-                    "Syntax error in declaration ~s" decl)
-             (push var ss)))
-          (IGNORE
-           (dolist (var (cdr decl))
-             (cmpck (not (symbolp var))
-                    "Syntax error in declaration ~s" decl)
-             (push var is)))
-          (TYPE
-           (cmpck (endp (cdr decl))
-                  "Syntax error in declaration ~s" decl)
-           (let ((type (type-filter (second decl))))
-                (when type
-                      (dolist (var (cddr decl))
-                        (cmpck (not (symbolp var))
-			       "Syntax error in declaration ~s" decl)
-                        (push (cons var type) ts)))))
-          (OBJECT
-           (dolist (var (cdr decl))
-             (cmpck (not (symbolp var))
-                    "Syntax error in declaration ~s" decl)
-             (push (cons var 'OBJECT) ts)))
-	  ;; read-only variable treatment. Beppe
-	  (:READ-ONLY
-#| obsolete
-           (dolist (var (cdr decl))
-	      (cmpck (not (symbolp var))
-		     "In the :read-only declaration ~s, ~s is not a symbol."
-		     decl var)
-	      (push (cons var 'READ-ONLY) ts))
-|#
-	      )
-          ((FIXNUM BASE-CHAR EXTENDED-CHAR CHARACTER DOUBLE-FLOAT SHORT-FLOAT ARRAY ATOM BIGNUM BIT
-            BIT-VECTOR COMPILED-FUNCTION COMPLEX CONS FLOAT HASH-TABLE
-            INTEGER KEYWORD LIST LONG-FLOAT NIL NULL NUMBER PACKAGE PATHNAME
-            RANDOM-STATE RATIO RATIONAL READTABLE SEQUENCE SIMPLE-ARRAY
-            SIMPLE-BIT-VECTOR SIMPLE-STRING SIMPLE-VECTOR SINGLE-FLOAT
-            STANDARD-CHAR STREAM STRING SYMBOL T VECTOR
-            SIGNED-BYTE UNSIGNED-BYTE FUNCTION)
-           (let ((type (type-filter (car decl))))
-                (when type
-                      (dolist (var (cdr decl))
-                        (cmpck (not (symbolp var))
-			       "Syntax error in declaration ~s" decl)
-                        (push (cons var type) ts)))))
-          (otherwise (push decl others))
-          )))
+        (cmpassert (and (proper-list-p decl) (symbolp (first decl)))
+		   "Syntax error in declaration ~s" form)
+	(let* ((decl-name (first decl))
+	       (decl-args (rest decl)))
+	  (flet ((declare-variables (type var-list)
+		   (cmpassert (proper-list-p var-list #'symbolp)
+			      "Syntax error in declaration ~s" decl)
+		   (when type
+		     (dolist (var var-list)
+		       (push (cons var type) ts)))))
+	    (case decl-name
+	      (SPECIAL
+	       (cmpassert (proper-list-p decl-args #'symbolp)
+			  "Syntax error in declaration ~s" decl)
+	       (setf ss (append decl-args ss)))
+	      (IGNORE
+	       (cmpassert (proper-list-p decl-args #'symbolp)
+			  "Syntax error in declaration ~s" decl)
+	       (setf is (append decl-args is)))
+	      (TYPE
+	       (cmpassert decl-args "Syntax error in declaration ~s" decl)
+	       (declare-variables (type-filter (first decl-args))
+				  (rest decl-args)))
+	      (OBJECT
+	       (declare-variables 'OBJECT decl-args))
+	      ;; read-only variable treatment. obsolete!
+	      (:READ-ONLY)
+	      ((OPTIMIZE FTYPE INLINE NOTINLINE DECLARATION SI::C-LOCAL SI::C-GLOBAL
+		DYNAMIC-EXTENT IGNORABLE VALUES)
+	       (push decl others))
+	      ((FIXNUM BASE-CHAR EXTENDED-CHAR CHARACTER DOUBLE-FLOAT SHORT-FLOAT ARRAY ATOM BIGNUM BIT
+		BIT-VECTOR COMPILED-FUNCTION COMPLEX CONS FLOAT HASH-TABLE
+		INTEGER KEYWORD LIST LONG-FLOAT NIL NULL NUMBER PACKAGE PATHNAME
+		RANDOM-STATE RATIO RATIONAL READTABLE SEQUENCE SIMPLE-ARRAY
+		SIMPLE-BIT-VECTOR SIMPLE-STRING SIMPLE-VECTOR SINGLE-FLOAT
+		STANDARD-CHAR STREAM STRING SYMBOL T VECTOR
+		SIGNED-BYTE UNSIGNED-BYTE FUNCTION)
+	       (declare-variables (type-filter decl-name) decl-args))
+	      (otherwise
+	       #+nil
+	       (push decl others)
+	       (if (member decl-name si::*alien-declarations*)
+		 (push decl others)
+		 (multiple-value-bind (ok type)
+		     (valid-type-specifier decl-name)
+		   (cmpassert ok "The declaration specifier ~s is unknown." decl-name)
+		   (declare-variables type decl-args))))
+	      )))))
      (t (return)))
     (pop body)
     )

src/cmp/cmpmac.lsp

@@ -30,6 +30,9 @@
 (defmacro cmpck (condition string &rest args)
   `(if ,condition (cmperr ,string ,@args)))
 
+(defmacro cmpassert (condition string &rest args)
+  `(unless ,condition (error ,string ,@args)))
+
 ;;; from cmpwt.lsp
 (defmacro wt (&rest forms &aux (fl nil))
   (dolist (form forms (cons 'progn (nreverse (cons nil fl))))

src/cmp/cmptype.lsp

@@ -108,6 +108,13 @@
 		       (get-sysprop (car type-args) 'TYPE-FILTER)))
 		 (t t))))))
 
+(defun valid-type-specifier (type)
+  (handler-case
+     (if (subtypep type 'T)
+	 (values t (type-filter type))
+         (values nil nil))
+    (error (c) (values nil nil))))
+
 (defun type-and (t1 t2)
   ;; FIXME! Should we allow "*" as type name???
   (when (or (eq t1 t2) (eq t2 '*))

src/cmp/cmputil.lsp

@@ -216,3 +216,8 @@
                           (<= #.(char-code #\0) cc #.(char-code #\9)))
                       c #\_)))
             (string-downcase (prin1-to-string obj)))))
+
+(defun proper-list-p (x &optional test)
+  (and (listp x)
+       (handler-case (list-length x) (type-error (c) nil))
+       (or (null test) (every test x))))

src/lsp/format.lsp

@@ -2460,7 +2460,7 @@
 	    "~:T" "~:@T")))
 
 (defun check-output-layout-mode (mode)
-  (declare (si::cl-local))
+  (declare (si::c-local))
   (when (and *output-layout-mode*
 	     (not (eql *output-layout-mode* mode)))
     (error 'format-error
@@ -2959,4 +2959,4 @@
 	(values (if (zerop posn) 1 0) most-positive-fixnum remaining)
 	(let ((nreq (if (zerop posn) 2 1)))
 	  (values nreq nreq remaining)))))
-)
+)