0.7.8.41:

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

diff --git a/src/compiler/info-functions.lisp b/src/compiler/info-functions.lisp
index cd5327f..07ffdd6 100644 (file)
--- a/src/compiler/info-functions.lisp
+++ b/src/compiler/info-functions.lisp
@@ -49,22 +49,23 @@
       (:function) ; happy case
       ((nil)) ; another happy case
       (:macro ; maybe-not-so-good case
       (: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
   ;;
        (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)
 
   ;; 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))
 
 
   (values))
 

@@ -74,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.
 ;;; 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)))

@@ -150,7 +151,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))

@@ -188,23 +189,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-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))
   (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)

@@ -239,7 +241,7 @@
         (symbol (values (info :variable :documentation x)))))
       (function
        (cond ((functionp x)
         (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
             ((legal-fun-name-p x)
              ;; FIXME: Is it really right to make
              ;; (DOCUMENTATION '(SETF FOO) 'FUNCTION) equivalent to

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