X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fproclaim.lisp;h=4c86f5f19cf5d661447b6e8743e503365697ed29;hb=1513b29bfbe948e7b431b5f67f1ff10769c192cf;hp=d835f987afb928e30253c93a69b083edbebf7826;hpb=82e0a78df47685519b12683f495d7ae19e07d3cf;p=sbcl.git diff --git a/src/compiler/proclaim.lisp b/src/compiler/proclaim.lisp index d835f98..4c86f5f 100644 --- a/src/compiler/proclaim.lisp +++ b/src/compiler/proclaim.lisp @@ -19,41 +19,6 @@ (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 ;;; structures for any which exist. If any of the names aren't ;;; symbols, we complain. @@ -69,16 +34,17 @@ ;;; Return a new POLICY containing the policy information represented ;;; by the optimize declaration SPEC. Any parameters not specified are ;;; defaulted from the POLICY argument. -(declaim (ftype (function (list policy) policy) process-optimize-declaration)) -(defun process-optimize-declaration (spec policy) - (let ((result policy)) ; may have new entries pushed on it below +(declaim (ftype (function (list policy) policy) process-optimize-decl)) +(defun process-optimize-decl (spec policy) + (let ((result nil)) + ;; Add new entries from SPEC. (dolist (q-and-v-or-just-q (cdr spec)) (multiple-value-bind (quality raw-value) (if (atom q-and-v-or-just-q) (values q-and-v-or-just-q 3) (destructuring-bind (quality raw-value) q-and-v-or-just-q (values quality raw-value))) - (cond ((not (policy-quality-p quality)) + (cond ((not (policy-quality-name-p quality)) (compiler-warning "ignoring unknown optimization quality ~ ~S in ~S" quality spec)) @@ -88,13 +54,36 @@ (t (push (cons quality (rational raw-value)) result))))) + ;; Add any nonredundant entries from old POLICY. + (dolist (old-entry policy) + (unless (assq (car old-entry) result) + (push old-entry result))) + ;; Voila. result)) -(defun sb!xc:proclaim (form) - (unless (consp form) - (error "malformed PROCLAIM spec: ~S" form)) - (let ((kind (first form)) - (args (rest form))) +;;; 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). +(defun canonized-decl-spec (decl-spec) + (let ((id (first decl-spec))) + (unless (symbolp id) + (error "The declaration identifier is not a symbol: ~S" id)) + (let ((id-is-type (info :type :kind id)) + (id-is-declared-decl (info :declaration :recognized id))) + (cond ((and id-is-type id-is-declared-decl) + (compiler-error + "ambiguous declaration ~S:~% ~ + ~S was declared as a DECLARATION, but is also a type name." + decl-spec id)) + (id-is-type + (cons 'type decl-spec)) + (t + decl-spec))))) + +(defun sb!xc:proclaim (raw-form) + (let* ((form (canonized-decl-spec raw-form)) + (kind (first form)) + (args (rest form))) (case kind (special (dolist (name args) @@ -172,11 +161,12 @@ (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))))) + (style-warn + "new FTYPE proclamation~@ + ~S~@ + for ~S does not match old FTYPE proclamation~@ + ~S" + (list type name old-type))))) (proclaim-as-function-name name) (note-name-defined name :function) @@ -185,7 +175,7 @@ (freeze-type (dolist (type args) (let ((class (specifier-type type))) - (when (typep class 'class) + (when (typep class 'sb!xc:class) (setf (class-state class) :sealed) (let ((subclasses (class-subclasses class))) (when subclasses @@ -193,34 +183,25 @@ (declare (ignore layout)) (setf (class-state subclass) :sealed)))))))) (optimize - (setq *default-policy* - (process-optimize-declaration form *default-policy*))) - (optimize-interface - (setq *default-interface-policy* - (process-optimize-declaration form *default-interface-policy*))) + (setq *policy* (process-optimize-decl form *policy*))) ((inline notinline maybe-inline) (dolist (name args) - (proclaim-as-function-name name) + ;; (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.) (setf (info :function :inlinep name) - (case kind + (ecase kind (inline :inline) (notinline :notinline) (maybe-inline :maybe-inline))))) - (constant-function - (let ((info (make-function-info - :attributes (ir1-attributes movable foldable flushable - unsafe)))) - (dolist (name args) - (proclaim-as-function-name name) - (setf (info :function :info name) info)))) (declaration (dolist (decl args) (unless (symbolp decl) - (error "The declaration to be recognized is not a symbol: ~S" decl)) + (error "In~% ~S~%the declaration to be recognized is not a ~ + symbol:~% ~S" + form decl)) (setf (info :declaration :recognized decl) t))) (t - (cond ((member kind *standard-type-names*) - (sb!xc:proclaim `(type ,@form))) ; FIXME: ,@ instead of . , - ((not (info :declaration :recognized kind)) - (warn "unrecognized proclamation: ~S" form)))))) + (unless (info :declaration :recognized kind) + (compiler-warning "unrecognized declaration ~S" raw-form))))) (values))