X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fproclaim.lisp;h=755467a6f618189d8d0da7f7a93191630ad067ce;hb=7f1e94ae961a198e00daf281eb1dc858e5b2dcc7;hp=2f36e287c07ca38b397c7ef6b5067b74a78c7496;hpb=6bdf018a77fd4bbc25c783f330415d444ffaeab2;p=sbcl.git diff --git a/src/compiler/proclaim.lisp b/src/compiler/proclaim.lisp index 2f36e28..755467a 100644 --- a/src/compiler/proclaim.lisp +++ b/src/compiler/proclaim.lisp @@ -45,11 +45,10 @@ (destructuring-bind (quality raw-value) q-and-v-or-just-q (values quality raw-value))) (cond ((not (policy-quality-name-p quality)) - (let ((deprecation-warning (policy-quality-deprecation-warning quality spec))) - (if deprecation-warning - (compiler-warn deprecation-warning) - (compiler-warn "~@" - quality spec)))) + (or (policy-quality-deprecation-warning quality) + (compiler-warn + "~@" + quality spec))) ((not (typep raw-value 'policy-quality)) (compiler-warn "~@" raw-value spec)) @@ -67,7 +66,7 @@ (unless (assq (car old-entry) result) (push old-entry result))) ;; Voila. - result)) + (sort-policy result))) (declaim (ftype (function (list list) list) process-handle-conditions-decl)) @@ -170,14 +169,35 @@ (kind (first form)) (args (rest form))) (case kind - (special + ((special global) + (flet ((make-special (name old) + (unless (member old '(:special :unknown)) + (error "Cannot proclaim a ~(~A~) variable special: ~S" old name)) + (with-single-package-locked-error + (:symbol name "globally declaring ~A special") + (setf (info :variable :kind name) :special))) + (make-global (name old) + (unless (member old '(:global :unknown)) + (error "Cannot proclaim a ~(~A~) variable global: ~S" old name)) + (with-single-package-locked-error + (:symbol name "globally declaring ~A global") + (setf (info :variable :kind name) :global)))) + (let ((fun (if (eq 'special kind) #'make-special #'make-global))) + (dolist (name args) + (unless (symbolp name) + (error "Can't declare a non-symbol as ~S: ~S" kind name)) + (funcall fun name (info :variable :kind name)))))) + (always-bound (dolist (name args) (unless (symbolp name) - (error "can't declare a non-symbol as SPECIAL: ~S" name)) + (error "Can't proclaim a non-symbol as ~S: ~S" kind name)) + (unless (boundp name) + (error "Can't proclaim an unbound symbol as ~S: ~S" kind name)) + (when (eq :constant (info :variable :kind name)) + (error "Can't proclaim a constant variable as ~S: ~S" kind name)) (with-single-package-locked-error - (:symbol name "globally declaring ~A special") - (about-to-modify-symbol-value name "proclaim ~S as SPECIAL") - (setf (info :variable :kind name) :special)))) + (:symbol name "globally declaring ~A always bound") + (setf (info :variable :always-bound name) t)))) (type (if *type-system-initialized* (let ((type (specifier-type (first args)))) @@ -191,10 +211,10 @@ (when (type/= type old-type) ;; FIXME: changing to TYPE-PROCLAMATION-MISMATCH ;; broke late-proclaim.lisp. - (style-warn "The new TYPE proclamation~% ~S~@ - for ~S does not match the old TYPE~@ - proclamation ~S" - type name old-type)))) + (style-warn + "~@" + name (type-specifier type) (type-specifier old-type))))) (setf (info :variable :type name) type) (setf (info :variable :where-from name) :declared))) (push raw-form *queued-proclaims*))) @@ -205,31 +225,36 @@ (error "not a function type: ~S" (first args))) (dolist (name (rest args)) (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) - ;; FIXME: changing to FTYPE-PROCLAMATION-MISMATCH - ;; broke late-proclaim.lisp. - (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. - ;; - ;; Other consequences of we-know-you're-a-function-now - ;; are appropriate too, e.g. any MACRO-FUNCTION goes away. - (proclaim-as-fun-name name) - (note-name-defined name :function) + (: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) + ;; FIXME: changing to FTYPE-PROCLAMATION-MISMATCH + ;; broke late-proclaim.lisp. + (if (info :function :info name) + ;; Allow for tightening of known function types + (unless (csubtypep ctype old-type) + (cerror "Continue" + "~@" + name (type-specifier ctype) (type-specifier old-type))) + (#+sb-xc-host warn + #-sb-xc-host style-warn + "~@" + name (type-specifier ctype) (type-specifier 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. + ;; + ;; Other consequences of we-know-you're-a-function-now + ;; are appropriate too, e.g. any MACRO-FUNCTION goes away. + (proclaim-as-fun-name name) + (note-name-defined name :function) - ;; the actual type declaration - (setf (info :function :type name) ctype - (info :function :where-from name) :declared))) + ;; the actual type declaration + (setf (info :function :type name) ctype + (info :function :where-from name) :declared)))) (push raw-form *queued-proclaims*))) (freeze-type (dolist (type args) @@ -254,7 +279,8 @@ (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 + ; since implicitly it is a function, also scrubs *FREE-FUNS* + (proclaim-as-fun-name name) (setf (info :function :inlinep name) (ecase kind (inline :inline)