X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Finfo-functions.lisp;h=ebbfcac71673ec3489c12b9c3d9f3d7534046a6b;hb=906ecd4ef2d10aca23e1081f03c13fe2f932ed89;hp=b4f3c2e17386581f59c901266ec0e76949e11be0;hpb=e511ed14d4a20cb9de2523f052b0f23a1dde1115;p=sbcl.git

diff --git a/src/compiler/info-functions.lisp b/src/compiler/info-functions.lisp
index b4f3c2e..ebbfcac 100644
--- a/src/compiler/info-functions.lisp
+++ b/src/compiler/info-functions.lisp
@@ -76,7 +76,7 @@
 (defun note-if-setf-fun-and-macro (name)
   (when (consp name)
     (when (or (info :setf :inverse name)
-	      (info :setf :expander name))
+              (info :setf :expander name))
       (compiler-style-warn
        "defining as a SETF function a name that already has a SETF macro:~
        ~%  ~S"
@@ -88,8 +88,8 @@
 (defun undefine-fun-name (name)
   (when name
     (macrolet ((frob (type &optional val)
-		 `(unless (eq (info :function ,type name) ,val)
-		    (setf (info :function ,type name) ,val))))
+                 `(unless (eq (info :function ,type name) ,val)
+                    (setf (info :function ,type name) ,val))))
       (frob :info)
       (frob :type (specifier-type 'function))
       (frob :where-from :assumed)
@@ -107,7 +107,7 @@
   (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))))
+        (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.
@@ -115,62 +115,39 @@
 (defun fun-name-inline-expansion (fun-name)
   (let ((info (info :function :inline-expansion-designator fun-name)))
     (if (functionp info)
-	(funcall info)
-	info)))
+        (funcall info)
+        info)))
 
 ;;;; 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)))
-
-(declaim (ftype (function (symbol &optional (or null sb!c::lexenv))) sb!xc:macro-function))
 (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)))
-	 (local-def (cdr (assoc symbol fenv))))
+  (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))
-	       (cdr local-def)
-	       nil))
-	  ((eq (info :function :kind symbol) :macro)
-	   (values (info :function :macro-function symbol)))
-	  (t
-	   nil))))
+           (if (and (consp local-def) (eq (car local-def) 'macro))
+               (cdr local-def)
+               nil))
+          ((eq (info :function :kind symbol) :macro)
+           (values (info :function :macro-function symbol)))
+          (t
+           nil))))
 
-;;; Note: Technically there could be an ENV optional argument to SETF
-;;; MACRO-FUNCTION, but since ANSI says that the consequences of
-;;; supplying that optional argument are undefined, we don't allow it.
-;;; (Thus our implementation of this unspecified behavior is to
-;;; complain that the wrong number of arguments was supplied. Since
-;;; the behavior is unspecified, this is conforming.:-)
-(defun (setf sb!xc:macro-function) (function symbol)
+(defun (setf sb!xc:macro-function) (function symbol &optional environment)
   (declare (symbol symbol) (type function function))
+  (when environment
+    ;; Note: Technically there could be an ENV optional argument to SETF
+    ;; MACRO-FUNCTION, but since ANSI says that the consequences of
+    ;; supplying a non-nil one are undefined, we don't allow it.
+    ;; (Thus our implementation of this unspecified behavior is to
+    ;; complain. SInce the behavior is unspecified, this is conforming.:-)
+    (error "Non-NIL environment argument in SETF of MACRO-FUNCTION ~S: ~S"
+           symbol environment))
   (when (eq (info :function :kind symbol) :special-form)
     (error "~S names a special form." symbol))
   (setf (info :function :kind symbol) :macro)
@@ -181,37 +158,49 @@
   ;; cross-compilation host's COMMON-LISP package.
   #-sb-xc-host
   (setf (symbol-function symbol)
-	(lambda (&rest args)
-	  (declare (ignore args))
-	  ;; (ANSI specification of FUNCALL says that this should be
-	  ;; an error of type UNDEFINED-FUNCTION, not just SIMPLE-ERROR.)
-	  (error 'undefined-function :name symbol)))
+        (lambda (&rest args)
+          (declare (ignore args))
+          ;; (ANSI specification of FUNCALL says that this should be
+          ;; an error of type UNDEFINED-FUNCTION, not just SIMPLE-ERROR.)
+          (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))
+           (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)
-  function)
+  (with-single-package-locked-error
+      (:symbol name "setting the compiler-macro-function of ~A")
+    (setf (info :function :compiler-macro-function name) function)
+    function))
 
 ;;;; a subset of DOCUMENTATION functionality for bootstrapping
 
@@ -233,45 +222,48 @@
 ;;; 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))))))
+           (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)))))
+         (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))))))
+              (%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))))))
+         (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))))))
+         (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))))
+         (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)))))))
+         ;; 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)))))))
 (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
@@ -280,15 +272,19 @@
   (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
      (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))))))
+           (setf (cdr pair) string)
+           (push (cons doc-type string)
+                 (info :random-documentation :stuff name))))))
   string)