X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Finfo-functions.lisp;h=e67f1a2b083cb3526307c0dd7ca883564d345e58;hb=49e8403800426f37a54d9b87353a31af36e7af40;hp=e47f2879df16427c474d0fb1b12a47a783e1b02a;hpb=444d2072bc52e60a41af62ee22e343e76109212f;p=sbcl.git diff --git a/src/compiler/info-functions.lisp b/src/compiler/info-functions.lisp index e47f287..e67f1a2 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)) @@ -124,10 +125,10 @@ (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)) @@ -165,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)) @@ -211,63 +222,70 @@ ;;; all the BDOCUMENTATION entries in a *BDOCUMENTATION* hash table ;;; and slamming them into PCL once PCL gets going. (defun fdocumentation (x doc-type) - (flet ((try-cmucl-random-doc (x doc-type) - (declare (symbol doc-type)) - (cdr (assoc doc-type - (values (info :random-documentation :stuff x)))))) - (case doc-type - (variable - (typecase x - (symbol (values (info :variable :documentation x))))) - (function - (cond ((functionp x) - (%fun-doc x)) - ((legal-fun-name-p x) - ;; FIXME: Is it really right to make - ;; (DOCUMENTATION '(SETF FOO) 'FUNCTION) equivalent to - ;; (DOCUMENTATION 'FOO 'FUNCTION)? That's what CMU CL - ;; did, so we do it, but I'm not sure it's what ANSI wants. - (values (info :function :documentation - (fun-name-block-name x)))))) - (structure - (typecase x - (symbol (when (eq (info :type :kind x) :instance) - (values (info :type :documentation x)))))) - (type - (typecase x - (structure-class (values (info :type :documentation (class-name x)))) - (t (and (typep x 'symbol) (values (info :type :documentation x)))))) - (setf (values (info :setf :documentation x))) - ((t) - (typecase 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)))) - (t - (typecase x - ;; FIXME: This code comes from CMU CL, but - ;; TRY-CMUCL-RANDOM-DOC doesn't seem to be defined anywhere - ;; in CMU CL. Perhaps it could be defined by analogy with the - ;; corresponding SETF FDOCUMENTATION code. - (symbol (try-cmucl-random-doc x doc-type))))))) + (case doc-type + (variable + (typecase x + (symbol (values (info :variable :documentation x))))) + ;; FUNCTION is not used at the momemnt, just here for symmetry. + (function + (cond ((functionp x) + (%fun-doc x)) + ((and (legal-fun-name-p x) (fboundp x)) + (%fun-doc (or (and (symbolp x) (macro-function x)) + (fdefinition x)))))) + (structure + (typecase 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)))) + (t (and (typep x 'symbol) (values (info :type :documentation x)))))) + (setf (values (info :setf :documentation x))) + ((t) + (typecase x + (function (%fun-doc x)) + (package (package-doc-string x)) + (structure-class (values (info :type :documentation (class-name x)))) + ((or symbol cons) + (random-documentation x doc-type)))) + (t + (when (typep x '(or symbol cons)) + (random-documentation x doc-type))))) + (defun (setf fdocumentation) (string name doc-type) - ;; FIXME: I think it should be possible to set documentation for - ;; things (e.g. compiler macros) named (SETF FOO). fndb.lisp - ;; declares DOC-TYPE to be a SYMBOL, which contradicts that. What - ;; should be done? + (declare (type (or null string) string)) (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))) + (function + ;; KLUDGE: FDEFINITION isn't ready early enough during cold-init, so + ;; special case for symbols. + (if (symbolp name) + (setf (%fun-doc (symbol-function name)) string) + (when (legal-fun-name-p name) + (setf (%fun-doc (fdefinition name)) string)))) + (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)))) (type (setf (info :type :documentation name) string)) (setf (setf (info :setf :documentation name) string)) (t - (let ((pair (assoc doc-type (info :random-documentation :stuff name)))) - (if pair - (setf (cdr pair) string) - (push (cons doc-type string) - (info :random-documentation :stuff name)))))) + (when (typep name '(or symbol cons)) + (setf (random-documentation name doc-type) string)))) string) + +(defun random-documentation (name type) + (cdr (assoc type (info :random-documentation :stuff name)))) + +(defun (setf random-documentation) (new-value name type) + (let ((pair (assoc type (info :random-documentation :stuff name)))) + (if pair + (setf (cdr pair) new-value) + (push (cons type new-value) + (info :random-documentation :stuff name)))) + new-value)