X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Finfo-functions.lisp;h=b9dfd7137a4d1932bd1bc4ff7f4a2cc623255fea;hb=d75b4eb603f1e9e366997c8e378fe0ae0d79b5d9;hp=f6f51ddc7ab4e9c4ef7e18d3467f3339b27c1455;hpb=1513b29bfbe948e7b431b5f67f1ff10769c192cf;p=sbcl.git diff --git a/src/compiler/info-functions.lisp b/src/compiler/info-functions.lisp index f6f51dd..b9dfd71 100644 --- a/src/compiler/info-functions.lisp +++ b/src/compiler/info-functions.lisp @@ -17,11 +17,13 @@ (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 ;;; or the name of a special form. -(defun check-function-name (name) +(defun check-fun-name (name) (typecase name (list (unless (and (consp name) (consp (cdr name)) @@ -33,33 +35,39 @@ (compiler-error "Special form is an illegal function name: ~S" name))) (t (compiler-error "illegal function name: ~S" name))) - name) + (values)) ;;; Record a new function definition, and check its legality. -(declaim (ftype (function ((or symbol cons)) t) proclaim-as-function-name)) -(defun proclaim-as-function-name (name) - (check-function-name name) +(defun proclaim-as-fun-name (name) + + ;; legal name? + (check-fun-name name) + + ;; scrubbing old data I: possible collision with old definition (when (fboundp name) (ecase (info :function :kind name) - (:function - (let ((accessor-for (info :function :accessor-for name))) - (when accessor-for - (compiler-style-warning - "~@" - name - accessor-for) - (clear-info :function :accessor-for name)))) - (:macro - (compiler-style-warning "~S was previously defined as a macro." name) + (:function) ; happy case + ((nil)) ; another happy case + (:macro ; maybe-not-so-good case + (compiler-style-warn "~S was previously defined as a macro." name) (setf (info :function :where-from name) :assumed) - (clear-info :function :macro-function name)) - ((nil)))) + (clear-info :function :macro-function name)))) + + ;; scrubbing old data II: dangling forward references + ;; + ;; (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) - name) + (note-if-setf-fun-and-macro name) + + (values)) ;;; This is called to do something about SETF functions that overlap ;;; with SETF macros. Perhaps we should interact with the user to see @@ -67,11 +75,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))) @@ -79,7 +87,7 @@ ;;; Make NAME no longer be a function name: clear everything back to ;;; the default. -(defun undefine-function-name (name) +(defun undefine-fun-name (name) (when name (macrolet ((frob (type &optional val) `(unless (eq (info :function ,type name) ,val) @@ -89,20 +97,28 @@ (frob :where-from :assumed) (frob :inlinep) (frob :kind) - (frob :accessor-for) - (frob :inline-expansion) + (frob :inline-expansion-designator) (frob :source-transform) (frob :assumed-type))) (values)) ;;; part of what happens with DEFUN, also with some PCL stuff: Make ;;; NAME known to be a function definition. -(defun become-defined-function-name (name) - (proclaim-as-function-name name) +(defun become-defined-fun-name (name) + (proclaim-as-fun-name name) (when (eq (info :function :where-from name) :assumed) (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 @@ -135,7 +151,7 @@ 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)) @@ -178,10 +194,10 @@ definition, or declared NOTINLINE, NIL is returned. Can be set with SETF." (let ((found (and env - (cdr (assoc name (sb!c::lexenv-functions env) + (cdr (assoc name (sb!c::lexenv-funs env) :test #'equal))))) - (unless (eq (cond ((sb!c::defined-function-p found) - (sb!c::defined-function-inlinep found)) + (unless (eq (cond ((sb!c::defined-fun-p found) + (sb!c::defined-fun-inlinep found)) (found :notinline) (t (info :function :inlinep name))) @@ -224,14 +240,14 @@ (symbol (values (info :variable :documentation x))))) (function (cond ((functionp x) - (function-doc x)) - ((legal-function-name-p 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 - (function-name-block-name x)))))) + (fun-name-block-name x)))))) (structure (typecase x (symbol (when (eq (info :type :kind x) :instance) @@ -243,7 +259,7 @@ (setf (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))))