diff --git a/src/CHANGELOG b/src/CHANGELOG index ba5a4a95a..bf1a0c78e 100644 --- a/src/CHANGELOG +++ b/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 diff --git a/src/clos/fixup.lsp b/src/clos/fixup.lsp index 39d25de0c..e52462edd 100644 --- a/src/clos/fixup.lsp +++ b/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) diff --git a/src/cmp/cmpenv.lsp b/src/cmp/cmpenv.lsp index e23119c9a..3c7ce4945 100644 --- a/src/cmp/cmpenv.lsp +++ b/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) ) diff --git a/src/cmp/cmpmac.lsp b/src/cmp/cmpmac.lsp index b5af7f350..e7493b6d7 100644 --- a/src/cmp/cmpmac.lsp +++ b/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)))) diff --git a/src/cmp/cmptype.lsp b/src/cmp/cmptype.lsp index b8fc33f94..1cbe09551 100644 --- a/src/cmp/cmptype.lsp +++ b/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 '*)) diff --git a/src/cmp/cmputil.lsp b/src/cmp/cmputil.lsp index 8bcaf7a75..95a77f505 100644 --- a/src/cmp/cmputil.lsp +++ b/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)))) diff --git a/src/lsp/format.lsp b/src/lsp/format.lsp index e009833a0..c4466f508 100644 --- a/src/lsp/format.lsp +++ b/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))))) -) \ No newline at end of file +)