0.8.1.35:

[sbcl.git] / src / compiler / info-functions.lisp

diff --git a/src/compiler/info-functions.lisp b/src/compiler/info-functions.lisp
index f6f51dd..b4f3c2e 100644 (file)
--- a/src/compiler/info-functions.lisp
+++ b/src/compiler/info-functions.lisp
@@ -17,49 +17,55 @@
 
 (in-package "SB!C")
 \f
 
 (in-package "SB!C")
 \f

+;;;; 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.
 ;;; 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
   (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)
        (compiler-error "Special form is an illegal function name: ~S" name)))
     (t
      (compiler-error "illegal function name: ~S" name)))
        (compiler-error "illegal function name: ~S" name)))
     (symbol
      (when (eq (info :function :kind name) :special-form)
        (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.
 
 ;;; 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)
   (when (fboundp name)
     (ecase (info :function :kind name)

-      (:function
-       (let ((accessor-for (info :function :accessor-for name)))
-        (when accessor-for
-          (compiler-style-warning
-           "~@<The function ~
-           ~2I~_~S ~
-           ~I~_was previously defined as a slot accessor for ~
-           ~2I~_~S.~:>"
-           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)
        (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)
   (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
 
 ;;; 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 +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.
 ;;; 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))
   (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)))
        "defining as a SETF function a name that already has a SETF macro:~
        ~%  ~S"
        name)))

@@ -79,7 +85,7 @@
 
 ;;; Make NAME no longer be a function name: clear everything back to
 ;;; the default.
 
 ;;; 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)
   (when name
     (macrolet ((frob (type &optional val)
                 `(unless (eq (info :function ,type name) ,val)

@@ -89,20 +95,28 @@
       (frob :where-from :assumed)
       (frob :inlinep)
       (frob :kind)
       (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.
       (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))))
   (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)))

 \f
 ;;;; ANSI Common Lisp functions which are defined in terms of the info
 ;;;; database
 \f
 ;;;; ANSI Common Lisp functions which are defined in terms of the info
 ;;;; database

@@ -111,22 +125,25 @@
   #!+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."
   #!+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
   ;; 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))
     ;; (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)
 
 (declaim (ftype (function (symbol &optional (or null sb!c::lexenv))) sb!xc:macro-function))
 (defun sb!xc:macro-function (symbol &optional env)

@@ -135,7 +152,7 @@
    else returns NIL. If ENV is unspecified or NIL, use the global
    environment only."
   (declare (symbol symbol))
    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))
         (local-def (cdr (assoc symbol fenv))))
     (cond (local-def
           (if (and (consp local-def) (eq (car local-def) 'MACRO))

@@ -173,23 +190,24 @@
 
 (defun sb!xc:compiler-macro-function (name &optional env)
   #!+sb-doc
 
 (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-function-p found)
-                      (sb!c::defined-function-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))
   (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)
   (when (eq (info :function :kind name) :special-form)
     (error "~S names a special form." name))
   (setf (info :function :compiler-macro-function name) function)

@@ -224,14 +242,14 @@
         (symbol (values (info :variable :documentation x)))))
       (function
        (cond ((functionp x)
         (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
              ;; 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)
       (structure
        (typecase x
         (symbol (when (eq (info :type :kind x) :instance)

@@ -240,10 +258,10 @@
        (typecase x
         (structure-class (values (info :type :documentation (class-name x))))
         (t (and (typep x 'symbol) (values (info :type :documentation x))))))
        (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
       ((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))))
         (package (package-doc-string x))
         (structure-class (values (info :type :documentation (class-name x))))
         (symbol (try-cmucl-random-doc x doc-type))))