X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fproclaim.lisp;h=985816bb094ab98de362736fd315ce67e61e4c0b;hb=7118efc35a64ece0d37d801f9f59e886402b0d22;hp=89af8fba01017c6687bcc6c5ae1ac0799234cf35;hpb=c5df202d52732a0dea8dc3558954a729073b7970;p=sbcl.git diff --git a/src/compiler/proclaim.lisp b/src/compiler/proclaim.lisp index 89af8fb..985816b 100644 --- a/src/compiler/proclaim.lisp +++ b/src/compiler/proclaim.lisp @@ -52,6 +52,12 @@ (compiler-warn "ignoring bad optimization value ~S in ~S" raw-value spec)) (t + ;; we can't do this yet, because CLOS macros expand + ;; into code containing INHIBIT-WARNINGS. + #+nil + (when (eql quality 'sb!ext:inhibit-warnings) + (compiler-style-warn "~S is deprecated: use ~S instead" + quality 'sb!ext:muffle-conditions)) (push (cons quality raw-value) result))))) ;; Add any nonredundant entries from old POLICY. @@ -61,6 +67,69 @@ ;; Voila. result)) +(declaim (ftype (function (list list) list) + process-handle-conditions-decl)) +(defun process-handle-conditions-decl (spec list) + (let ((new (copy-alist list))) + (dolist (clause (cdr spec)) + (destructuring-bind (typespec restart-name) clause + (let ((ospec (rassoc restart-name new :test #'eq))) + (if ospec + (setf (car ospec) + (type-specifier + (type-union (specifier-type (car ospec)) + (specifier-type typespec)))) + (push (cons (type-specifier (specifier-type typespec)) + restart-name) + new))))) + new)) +(declaim (ftype (function (list list) list) + process-muffle-conditions-decl)) +(defun process-muffle-conditions-decl (spec list) + (process-handle-conditions-decl + (cons 'handle-conditions + (mapcar (lambda (x) (list x 'muffle-warning)) (cdr spec))) + list)) + +(declaim (ftype (function (list list) list) + process-unhandle-conditions-decl)) +(defun process-unhandle-conditions-decl (spec list) + (let ((new (copy-alist list))) + (dolist (clause (cdr spec)) + (destructuring-bind (typespec restart-name) clause + (let ((ospec (rassoc restart-name new :test #'eq))) + (if ospec + (let ((type-specifier + (type-specifier + (type-intersection + (specifier-type (car ospec)) + (specifier-type `(not ,typespec)))))) + (if type-specifier + (setf (car ospec) type-specifier) + (setq new + (delete restart-name new :test #'eq :key #'cdr)))) + ;; do nothing? + nil)))) + new)) +(declaim (ftype (function (list list) list) + process-unmuffle-conditions-decl)) +(defun process-unmuffle-conditions-decl (spec list) + (process-unhandle-conditions-decl + (cons 'unhandle-conditions + (mapcar (lambda (x) (list x 'muffle-warning)) (cdr spec))) + list)) + +(declaim (ftype (function (list list) list) + process-package-lock-decl)) +(defun process-package-lock-decl (spec old) + (let ((decl (car spec)) + (list (cdr spec))) + (ecase decl + (disable-package-locks + (union old list :test #'equal)) + (enable-package-locks + (set-difference old list :test #'equal))))) + ;;; ANSI defines the declaration (FOO X Y) to be equivalent to ;;; (TYPE FOO X Y) when FOO is a type specifier. This function ;;; implements that by converting (FOO X Y) to (TYPE FOO X Y). @@ -80,8 +149,10 @@ (t decl-spec))))) +(defvar *queued-proclaims*) ; initialized in !COLD-INIT-FORMS + (!begin-collecting-cold-init-forms) -(!cold-init-forms (defvar *queued-proclaims* nil)) +(!cold-init-forms (setf *queued-proclaims* nil)) (!defun-from-collected-cold-init-forms !early-proclaim-cold-init) (defun sb!xc:proclaim (raw-form) @@ -97,6 +168,8 @@ (error "can't declare a non-symbol as SPECIAL: ~S" name)) (when (constantp name) (error "can't declare a constant as SPECIAL: ~S" name)) + (with-single-package-locked-error + (:symbol name "globally declaring ~A special")) (clear-info :variable :constant-value name) (setf (info :variable :kind name) :special))) (type @@ -105,6 +178,8 @@ (dolist (name (rest args)) (unless (symbolp name) (error "can't declare TYPE of a non-symbol: ~S" name)) + (with-single-package-locked-error + (:symbol name "globally declaring the type of ~A")) (when (eq (info :variable :where-from name) :declared) (let ((old-type (info :variable :type name))) (when (type/= type old-type) @@ -121,33 +196,21 @@ (unless (csubtypep ctype (specifier-type 'function)) (error "not a function type: ~S" (first args))) (dolist (name (rest args)) - - ;; KLUDGE: Something like the commented-out TYPE/= - ;; check here would be nice, but it has been - ;; commented out because TYPE/= doesn't support - ;; function types. It could probably be made to do - ;; so, but it might take some time, since function - ;; types involve values types, which aren't - ;; supported, and since the SUBTYPEP operator for - ;; FUNCTION types is rather broken, e.g. - ;; (SUBTYPEP '(FUNCTION (T BOOLEAN) NIL) - ;; '(FUNCTION (FIXNUM FIXNUM) NIL)) => T, T - ;; -- WHN 20000229 - #| - (when (eq (info :function :where-from name) :declared) - (let ((old-type (info :function :type name))) - (when (type/= ctype old-type) - (style-warn - "new FTYPE proclamation~@ - ~S~@ - for ~S does not match old FTYPE proclamation~@ - ~S" - (list ctype name old-type))))) - |# + (with-single-package-locked-error + (:symbol name "globally declaring the ftype of ~A")) + (when (eq (info :function :where-from name) :declared) + (let ((old-type (info :function :type name))) + (when (type/= ctype old-type) + (style-warn + "new FTYPE proclamation~@ + ~S~@ + for ~S does not match old FTYPE proclamation~@ + ~S" + ctype name old-type)))) ;; Now references to this function shouldn't be warned ;; about as undefined, since even if we haven't seen a - ;; definition yet, we know one is planned. + ;; definition yet, we know one is planned. ;; ;; Other consequences of we-know-you're-a-function-now ;; are appropriate too, e.g. any MACRO-FUNCTION goes away. @@ -170,6 +233,15 @@ (setf (classoid-state subclass) :sealed)))))))) (optimize (setq *policy* (process-optimize-decl form *policy*))) + (muffle-conditions + (setq *handled-conditions* + (process-muffle-conditions-decl form *handled-conditions*))) + (unmuffle-conditions + (setq *handled-conditions* + (process-unmuffle-conditions-decl form *handled-conditions*))) + ((disable-package-locks enable-package-locks) + (setq *disabled-package-locks* + (process-package-lock-decl form *disabled-package-locks*))) ((inline notinline maybe-inline) (dolist (name args) (proclaim-as-fun-name name) ; since implicitly it is a function @@ -184,6 +256,8 @@ (error "In~% ~S~%the declaration to be recognized is not a ~ symbol:~% ~S" form decl)) + (with-single-package-locked-error + (:symbol decl "globally declaring ~A as a declaration proclamation")) (setf (info :declaration :recognized decl) t))) (t (unless (info :declaration :recognized kind)