X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Finfo-functions.lisp;h=5188227ce8c2421834ccc5f37db2da0752740def;hb=ff92598854bf7cae8d57fe49cef4d9a98e1ab345;hp=b74f6372b0fa35f6319f5cefb5f84bacae887862;hpb=edaebea5b5e6682b36f4067e3b187bd9fb4a5c25;p=sbcl.git diff --git a/src/compiler/info-functions.lisp b/src/compiler/info-functions.lisp index b74f637..5188227 100644 --- a/src/compiler/info-functions.lisp +++ b/src/compiler/info-functions.lisp @@ -17,6 +17,8 @@ (in-package "SB!C") +;;;; internal utilities defined in terms of INFO + ;;; Check that NAME is a valid function name, returning the name if ;;; OK, and signalling an error if not. In addition to checking for ;;; basic well-formedness, we also check that symbol names are not NIL @@ -24,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) @@ -47,22 +47,23 @@ (:function) ; happy case ((nil)) ; another happy case (:macro ; maybe-not-so-good case - (compiler-style-warning "~S was previously defined as a macro." name) + (compiler-style-warn "~S was previously defined as a macro." name) (setf (info :function :where-from name) :assumed) (clear-info :function :macro-function name)))) ;; scrubbing old data II: dangling forward references ;; - ;; (This could happen if someone does PROCLAIM FTYPE in macroexpansion, - ;; which is bad style, or at compile time, e.g. in EVAL-WHEN (:COMPILE) - ;; inside something like DEFSTRUCT, in which case it's reasonable style. - ;; Either way, it's no longer a free function.) - (when (boundp '*free-functions*) ; when compiling - (remhash name *free-functions*)) + ;; (This could happen if someone executes PROCLAIM FTYPE at + ;; macroexpansion time, which is bad style, or at compile time, e.g. + ;; in EVAL-WHEN (:COMPILE) inside something like DEFSTRUCT, in which + ;; case it's reasonable style. Either way, NAME is no longer a free + ;; function.) + (when (boundp '*free-funs*) ; when compiling + (remhash name *free-funs*)) ;; recording the ordinary case (setf (info :function :kind name) :function) - (note-if-setf-function-and-macro name) + (note-if-setf-fun-and-macro name) (values)) @@ -72,11 +73,11 @@ ;;; 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) +(defun note-if-setf-fun-and-macro (name) (when (consp name) (when (or (info :setf :inverse name) (info :setf :expander name)) - (compiler-style-warning + (compiler-style-warn "defining as a SETF function a name that already has a SETF macro:~ ~% ~S" name))) @@ -107,6 +108,15 @@ (setf (info :function :where-from name) :defined) (if (info :function :assumed-type name) (setf (info :function :assumed-type name) nil)))) + +;;; Decode any raw (INFO :FUNCTION :INLINE-EXPANSION-DESIGNATOR FUN-NAME) +;;; value into a lambda expression, or return NIL if there is none. +(declaim (ftype (function ((or symbol cons)) list) fun-name-inline-expansion)) +(defun fun-name-inline-expansion (fun-name) + (let ((info (info :function :inline-expansion-designator fun-name))) + (if (functionp info) + (funcall info) + info))) ;;;; ANSI Common Lisp functions which are defined in terms of the info ;;;; database @@ -115,31 +125,33 @@ #!+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, else returns NIL. If ENV is unspecified or NIL, use the global environment only." (declare (symbol symbol)) - (let* ((fenv (when env (sb!c::lexenv-functions env))) + (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)) @@ -177,27 +189,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-functions 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 @@ -228,7 +243,7 @@ (symbol (values (info :variable :documentation x))))) (function (cond ((functionp x) - (function-doc x)) + (%fun-doc x)) ((legal-fun-name-p x) ;; FIXME: Is it really right to make ;; (DOCUMENTATION '(SETF FOO) 'FUNCTION) equivalent to @@ -244,10 +259,10 @@ (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 (function-doc x)) + (function (%fun-doc x)) (package (package-doc-string x)) (structure-class (values (info :type :documentation (class-name x)))) (symbol (try-cmucl-random-doc x doc-type))))