X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Finfo-functions.lisp;h=b63a4a58ec9c187ba0f5cd1c0ae911af94713fe5;hb=d2561c6826f9e590d9174007f9642237d79a46df;hp=b9dfd7137a4d1932bd1bc4ff7f4a2cc623255fea;hpb=b0b168c08b31a748150f404398af754f26fd4813;p=sbcl.git diff --git a/src/compiler/info-functions.lisp b/src/compiler/info-functions.lisp index b9dfd71..b63a4a5 100644 --- a/src/compiler/info-functions.lisp +++ b/src/compiler/info-functions.lisp @@ -26,9 +26,7 @@ (defun check-fun-name (name) (typecase name (list - (unless (and (consp name) (consp (cdr name)) - (null (cddr name)) (eq (car name) 'setf) - (symbolp (cadr name))) + (unless (legal-fun-name-p name) (compiler-error "illegal function name: ~S" name))) (symbol (when (eq (info :function :kind name) :special-form) @@ -127,24 +125,26 @@ #!+sb-doc "True of any Lisp object that has a constant value: types that eval to themselves, keywords, constants, and list whose car is QUOTE." - ;; FIXME: Should STRUCTURE-OBJECT and/or STANDARD-OBJECT be here? - ;; They eval to themselves.. - ;; ;; FIXME: Someday it would be nice to make the code recognize foldable ;; functions and call itself recursively on their arguments, so that ;; more of the examples in the ANSI CL definition are recognized. ;; (e.g. (+ 3 2), (SQRT PI), and (LENGTH '(A B C))) (declare (ignore environment)) (typecase object - (number t) - (character t) - (array t) ;; (Note that the following test on INFO catches KEYWORDs as well as ;; explicitly DEFCONSTANT symbols.) (symbol (eq (info :variable :kind object) :constant)) - (list (eq (car object) 'quote)))) + (list (and (eq (car object) 'quote) + (consp (cdr object)))) + (t t))) + +(defun constant-form-value (form) + (typecase form + (symbol (info :variable :constant-value form)) + ((cons (eql quote) cons) + (second form)) + (t form))) -(declaim (ftype (function (symbol &optional (or null sb!c::lexenv))) sb!xc:macro-function)) (defun sb!xc:macro-function (symbol &optional env) #!+sb-doc "If SYMBOL names a macro in ENV, returns the expansion function, @@ -154,7 +154,7 @@ (let* ((fenv (when env (sb!c::lexenv-funs env))) (local-def (cdr (assoc symbol fenv)))) (cond (local-def - (if (and (consp local-def) (eq (car local-def) 'MACRO)) + (if (and (consp local-def) (eq (car local-def) 'macro)) (cdr local-def) nil)) ((eq (info :function :kind symbol) :macro) @@ -162,14 +162,16 @@ (t nil)))) -;;; Note: Technically there could be an ENV optional argument to SETF -;;; MACRO-FUNCTION, but since ANSI says that the consequences of -;;; supplying that optional argument are undefined, we don't allow it. -;;; (Thus our implementation of this unspecified behavior is to -;;; complain that the wrong number of arguments was supplied. Since -;;; the behavior is unspecified, this is conforming.:-) -(defun (setf sb!xc:macro-function) (function symbol) +(defun (setf sb!xc:macro-function) (function symbol &optional environment) (declare (symbol symbol) (type function function)) + (when environment + ;; Note: Technically there could be an ENV optional argument to SETF + ;; MACRO-FUNCTION, but since ANSI says that the consequences of + ;; supplying a non-nil one are undefined, we don't allow it. + ;; (Thus our implementation of this unspecified behavior is to + ;; complain. SInce the behavior is unspecified, this is conforming.:-) + (error "Non-NIL environment argument in SETF of MACRO-FUNCTION ~S: ~S" + symbol environment)) (when (eq (info :function :kind symbol) :special-form) (error "~S names a special form." symbol)) (setf (info :function :kind symbol) :macro) @@ -189,27 +191,30 @@ (defun sb!xc:compiler-macro-function (name &optional env) #!+sb-doc - "If NAME names a compiler-macro, returns the expansion function, - else returns NIL. Note: if the name is shadowed in ENV by a local - definition, or declared NOTINLINE, NIL is returned. Can be - set with SETF." - (let ((found (and env - (cdr (assoc name (sb!c::lexenv-funs env) - :test #'equal))))) - (unless (eq (cond ((sb!c::defined-fun-p found) - (sb!c::defined-fun-inlinep found)) - (found :notinline) - (t - (info :function :inlinep name))) - :notinline) - (values (info :function :compiler-macro-function name))))) -(defun (setf sb!xc:compiler-macro-function) (function name) + "If NAME names a compiler-macro in ENV, return the expansion function, else + return NIL. Can be set with SETF when ENV is NIL." + (declare (ignore env)) + (legal-fun-name-or-type-error name) + ;; Note: CMU CL used to return NIL here when a NOTINLINE declaration + ;; was in force. That's fairly logical, given the specified effect + ;; of NOTINLINE declarations on compiler-macro expansion. However, + ;; (1) it doesn't seem to be consistent with the ANSI spec for + ;; COMPILER-MACRO-FUNCTION, and (2) it would give surprising + ;; behavior for (SETF (COMPILER-MACRO-FUNCTION FOO) ...) in the + ;; presence of a (PROCLAIM '(NOTINLINE FOO)). So we don't do it. + (values (info :function :compiler-macro-function name))) +(defun (setf sb!xc:compiler-macro-function) (function name &optional env) (declare (type (or symbol list) name) (type (or function null) function)) + (when env + ;; ANSI says this operation is undefined. + (error "can't SETF COMPILER-MACRO-FUNCTION when ENV is non-NIL")) (when (eq (info :function :kind name) :special-form) (error "~S names a special form." name)) - (setf (info :function :compiler-macro-function name) function) - function) + (with-single-package-locked-error + (:symbol name "setting the compiler-macro-function of ~A") + (setf (info :function :compiler-macro-function name) function) + function)) ;;;; a subset of DOCUMENTATION functionality for bootstrapping @@ -256,7 +261,7 @@ (typecase x (structure-class (values (info :type :documentation (class-name x)))) (t (and (typep x 'symbol) (values (info :type :documentation x)))))) - (setf (info :setf :documentation x)) + (setf (values (info :setf :documentation x))) ((t) (typecase x (function (%fun-doc x))