X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Finfo-functions.lisp;h=685d3b78d5f9cb121b7232ba1b1694e344d87901;hb=9b1fade83db8453b75b8c7380eb12ce41b5b889c;hp=c835264a1ef62004bf23faa84fdac62d5eda7542;hpb=d604a358d8e5eb5587989e0a4f1d31dbe6ac5ffe;p=sbcl.git diff --git a/src/compiler/info-functions.lisp b/src/compiler/info-functions.lisp index c835264..685d3b7 100644 --- a/src/compiler/info-functions.lisp +++ b/src/compiler/info-functions.lisp @@ -97,6 +97,7 @@ (frob :kind) (frob :inline-expansion-designator) (frob :source-transform) + (frob :structure-accessor) (frob :assumed-type))) (values)) @@ -121,37 +122,13 @@ ;;;; ANSI Common Lisp functions which are defined in terms of the info ;;;; database -(defun sb!xc:constantp (object &optional environment) - #!+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: 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 - ;; (Note that the following test on INFO catches KEYWORDs as well as - ;; explicitly DEFCONSTANT symbols.) - (symbol (eq (info :variable :kind object) :constant)) - (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))) - (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." +else returns NIL. If ENV is unspecified or NIL, use the global environment +only." (declare (symbol symbol)) - (let* ((fenv (when env (sb!c::lexenv-funs env))) + (let* ((fenv (when env (lexenv-funs env))) (local-def (cdr (assoc symbol fenv)))) (cond (local-def (if (and (consp local-def) (eq (car local-def) 'macro)) @@ -189,20 +166,30 @@ (error 'undefined-function :name symbol))) function) +(defun fun-locally-defined-p (name env) + (and env + (let ((fun (cdr (assoc name (lexenv-funs env) :test #'equal)))) + (and fun (not (global-var-p fun)))))) + (defun sb!xc:compiler-macro-function (name &optional env) #!+sb-doc "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)) +return NIL. Can be set with SETF when ENV is NIL." (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))) + ;; CLHS 3.2.2.1: Creating a lexical binding for the function name + ;; not only creates a new local function or macro definition, but + ;; also shadows[2] the compiler macro. + (unless (fun-locally-defined-p name env) + ;; 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)) @@ -255,8 +242,11 @@ (fun-name-block-name x)))))) (structure (typecase x - (symbol (when (eq (info :type :kind x) :instance) - (values (info :type :documentation x)))))) + (symbol (cond + ((eq (info :type :kind x) :instance) + (values (info :type :documentation x))) + ((info :typed-structure :info x) + (values (info :typed-structure :documentation x))))))) (type (typecase x (structure-class (values (info :type :documentation (class-name x)))) @@ -283,9 +273,13 @@ (case doc-type (variable (setf (info :variable :documentation name) string)) (function (setf (info :function :documentation name) string)) - (structure (if (eq (info :type :kind name) :instance) - (setf (info :type :documentation name) string) - (error "~S is not the name of a structure type." name))) + (structure (cond + ((eq (info :type :kind name) :instance) + (setf (info :type :documentation name) string)) + ((info :typed-structure :info name) + (setf (info :typed-structure :documentation name) string)) + (t + (error "~S is not a structure name." name)))) (type (setf (info :type :documentation name) string)) (setf (setf (info :setf :documentation name) string)) (t