X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fproclaim.lisp;h=1c154ca7552ef77f8c57c1b89681551bcf5ae397;hb=8fa3b333d2b37f45c3702f478f784b8c6f491080;hp=4b3519103a5ac36a7dd339e6dfc107d05a6ddf70;hpb=e27303999070c06c788a0e1359ee4b0900186aa1;p=sbcl.git diff --git a/src/compiler/proclaim.lisp b/src/compiler/proclaim.lisp index 4b35191..1c154ca 100644 --- a/src/compiler/proclaim.lisp +++ b/src/compiler/proclaim.lisp @@ -19,42 +19,7 @@ (defvar *undefined-warnings*) (declaim (list *undefined-warnings*)) -;;; Check that NAME is a valid function name, returning the name if -;;; OK, and doing an error if not. In addition to checking for basic -;;; well-formedness, we also check that symbol names are not NIL or -;;; the name of a special form. -(defun check-function-name (name) - (typecase name - (list - (unless (and (consp name) (consp (cdr name)) - (null (cddr name)) (eq (car name) 'setf) - (symbolp (cadr name))) - (compiler-error "illegal function name: ~S" name)) - name) - (symbol - (when (eq (info :function :kind name) :special-form) - (compiler-error "Special form is an illegal function name: ~S" name)) - name) - (t - (compiler-error "illegal function name: ~S" name)))) - -;;; This is called to do something about SETF functions that overlap -;;; with SETF macros. Perhaps we should interact with the user to see -;;; whether the macro should be blown away, but for now just give a -;;; warning. Due to the weak semantics of the (SETF FUNCTION) name, we -;;; can't assume that they aren't just naming a function (SETF FOO) -;;; for the heck of it. NAME is already known to be well-formed. -(defun note-if-setf-function-and-macro (name) - (when (consp name) - (when (or (info :setf :inverse name) - (info :setf :expander name)) - (compiler-style-warning - "defining as a SETF function a name that already has a SETF macro:~ - ~% ~S" - name))) - (values)) - -;;; Look up some symbols in *FREE-VARIABLES*, returning the var +;;; Look up some symbols in *FREE-VARS*, returning the var ;;; structures for any which exist. If any of the names aren't ;;; symbols, we complain. (declaim (ftype (function (list) list) get-old-vars)) @@ -63,7 +28,7 @@ (dolist (name names (vars)) (unless (symbolp name) (compiler-error "The name ~S is not a symbol." name)) - (let ((old (gethash name *free-variables*))) + (let ((old (gethash name *free-vars*))) (when old (vars old)))))) ;;; Return a new POLICY containing the policy information represented @@ -80,12 +45,12 @@ (destructuring-bind (quality raw-value) q-and-v-or-just-q (values quality raw-value))) (cond ((not (policy-quality-name-p quality)) - (compiler-warning "ignoring unknown optimization quality ~ - ~S in ~S" - quality spec)) + (compiler-warn "ignoring unknown optimization quality ~ + ~S in ~S" + quality spec)) ((not (and (typep raw-value 'real) (<= 0 raw-value 3))) - (compiler-warning "ignoring bad optimization value ~S in ~S" - raw-value spec)) + (compiler-warn "ignoring bad optimization value ~S in ~S" + raw-value spec)) (t (push (cons quality (rational raw-value)) result))))) @@ -116,6 +81,8 @@ decl-spec))))) (defun sb!xc:proclaim (raw-form) + #+sb-xc (/show0 "entering PROCLAIM, RAW-FORM=..") + #+sb-xc (/hexstr raw-form) (let* ((form (canonized-decl-spec raw-form)) (kind (first form)) (args (rest form))) @@ -156,57 +123,46 @@ ;; when we have to ignore a PROCLAIM because the type system is ;; uninitialized. (when *type-system-initialized* - (let ((type (specifier-type (first args)))) - (unless (csubtypep type (specifier-type 'function)) + (let ((ctype (specifier-type (first args)))) + (unless (csubtypep ctype (specifier-type 'function)) (error "not a function type: ~S" (first args))) (dolist (name (rest args)) - (cond ((info :function :accessor-for name) - ;; FIXME: This used to be a WARNING, which was - ;; clearly wrong, since it would cause warnings to - ;; be issued for conforming code, which is really - ;; annoying for people who use Lisp code to build - ;; Lisp systems (and check the return values from - ;; COMPILE and COMPILE-FILE). Changing it to a - ;; compiler note is somewhat better, since it's - ;; after all news about a limitation of the - ;; compiler, not a problem in the code. But even - ;; better would be to handle FTYPE proclamations - ;; for slot accessors, and since in the long run - ;; slot accessors should become more like other - ;; functions, this should eventually become - ;; straightforward. - (maybe-compiler-note - "~@" - name)) - (t - ;; 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 - #+nil - (when (eq (info :function :where-from name) :declared) - (let ((old-type (info :function :type name))) - (when (type/= type old-type) - (style-warn - "new FTYPE proclamation~@ - ~S~@ - for ~S does not match old FTYPE proclamation~@ - ~S" - (list type name old-type))))) + ;; 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))))) + |# + + ;; 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) - (proclaim-as-function-name name) - (note-name-defined name :function) - (setf (info :function :type name) type - (info :function :where-from name) :declared))))))) + ;; the actual type declaration + (setf (info :function :type name) ctype + (info :function :where-from name) :declared))))) (freeze-type (dolist (type args) (let ((class (specifier-type type))) @@ -221,9 +177,7 @@ (setq *policy* (process-optimize-decl form *policy*))) ((inline notinline maybe-inline) (dolist (name args) - ;; (CMU CL did (PROCLAIM-AS-FUNCTION-NAME NAME) here, but that - ;; seems more likely to surprise the user than to help him, so - ;; we don't do it.) + (proclaim-as-fun-name name) ; since implicitly it is a function (setf (info :function :inlinep name) (ecase kind (inline :inline) @@ -238,5 +192,6 @@ (setf (info :declaration :recognized decl) t))) (t (unless (info :declaration :recognized kind) - (compiler-warning "unrecognized declaration ~S" raw-form))))) + (compiler-warn "unrecognized declaration ~S" raw-form))))) + #+sb-xc (/show0 "returning from PROCLAIM") (values))