src/compiler/info-functions.lisp

   1 ;;;; miscellaneous functions which use INFO
   2 ;;;;
   3 ;;;; (In CMU CL, these were in globaldb.lisp. They've been moved here
   4 ;;;; because references to INFO can't be compiled correctly until
   5 ;;;; globaldb initialization is complete, and the SBCL technique for
   6 ;;;; initializing the global database in the cross-compiler isn't
   7 ;;;; completed until load time.)
   8
   9 ;;;; This software is part of the SBCL system. See the README file for
  10 ;;;; more information.
  11 ;;;;
  12 ;;;; This software is derived from the CMU CL system, which was
  13 ;;;; written at Carnegie Mellon University and released into the
  14 ;;;; public domain. The software is in the public domain and is
  15 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  16 ;;;; files for more information.
  17
  18 (in-package "SB!C")
  19 \f
  20 ;;; Check the legality of a function name that is being introduced.
  21 ;;; -- If it names a macro, then give a warning and blast the macro
  22 ;;;    information.
  23 ;;; -- If it is a structure slot accessor, give a warning and blast
  24 ;;;    the structure.
  25 ;;; -- Check for conflicting setf macros.
  26 (declaim (ftype (function ((or symbol cons)) t) proclaim-as-function-name))
  27 (defun proclaim-as-function-name (name)
  28   (check-function-name name)
  29   (ecase (info :function :kind name)
  30     (:function
  31      (let ((accessor-for (info :function :accessor-for name)))
  32        (when accessor-for
  33          (compiler-warning
  34           "Undefining structure type:~%  ~S~@
  35            so that this slot accessor can be redefined:~%  ~S"
  36           (sb!xc:class-name accessor-for) name)
  37          ;; FIXME: This is such weird, unfriendly behavior.. (What if
  38          ;; the user didn't want his structure blasted?) It probably
  39          ;; violates ANSI, too. (Check this.) Perhaps instead of
  40          ;; undefining the structure, we should attach the lost
  41          ;; accessor function to SB-EXT:LOST-STRUCTURE-ACCESSORS on
  42          ;; the property list of the symbol which names the structure?
  43          (undefine-structure accessor-for)
  44          (setf (info :function :kind name) :function))))
  45     (:macro
  46      (compiler-style-warning "~S previously defined as a macro." name)
  47      (setf (info :function :kind name) :function)
  48      (setf (info :function :where-from name) :assumed)
  49      (clear-info :function :macro-function name))
  50     ((nil)
  51      (setf (info :function :kind name) :function)))
  52   (note-if-setf-function-and-macro name)
  53   name)
  54
  55 ;;; Make NAME no longer be a function name: clear everything back to the
  56 ;;; default.
  57 (defun undefine-function-name (name)
  58   (when name
  59     (macrolet ((frob (type &optional val)
  60                  `(unless (eq (info :function ,type name) ,val)
  61                     (setf (info :function ,type name) ,val))))
  62       (frob :info)
  63       (frob :type (specifier-type 'function))
  64       (frob :where-from :assumed)
  65       (frob :inlinep)
  66       (frob :kind)
  67       (frob :accessor-for)
  68       (frob :inline-expansion)
  69       (frob :source-transform)
  70       (frob :assumed-type)))
  71   (values))
  72
  73 ;;; part of what happens with DEFUN, also with some PCL stuff:
  74 ;;; Make NAME known to be a function definition.
  75 (defun become-defined-function-name (name)
  76   (proclaim-as-function-name name)
  77   (when (eq (info :function :where-from name) :assumed)
  78     (setf (info :function :where-from name) :defined)
  79     (if (info :function :assumed-type name)
  80         (setf (info :function :assumed-type name) nil))))
  81 \f
  82 ;;;; ANSI Common Lisp functions which are defined in terms of the info
  83 ;;;; database
  84
  85 (defun sb!xc:constantp (object &optional environment)
  86   #!+sb-doc
  87   "True of any Lisp object that has a constant value: types that eval to
  88   themselves, keywords, constants, and list whose car is QUOTE."
  89   ;; FIXME: Should STRUCTURE-OBJECT and/or STANDARD-OBJECT be here?
  90   ;; They eval to themselves..
  91   ;;
  92   ;; KLUDGE: Someday it might be nice to make the code recognize foldable
  93   ;; functions and call itself recursively on their arguments, so that
  94   ;; more of the examples in the ANSI CL definition are recognized.
  95   ;; (e.g. (+ 3 2), (SQRT PI), and (LENGTH '(A B C)))
  96   (declare (ignore environment))
  97   (typecase object
  98     (number t)
  99     (character t)
 100     (array t)
 101     ;; (Note that the following test on INFO catches KEYWORDs as well as
 102     ;; explicitly DEFCONSTANT symbols.)
 103     (symbol (eq (info :variable :kind object) :constant))
 104     (list (eq (car object) 'quote))))
 105
 106 (declaim (ftype (function (symbol &optional (or null sb!c::lexenv))) sb!xc:macro-function))
 107 (defun sb!xc:macro-function (symbol &optional env)
 108   #!+sb-doc
 109   "If SYMBOL names a macro in ENV, returns the expansion function,
 110    else returns NIL. If ENV is unspecified or NIL, use the global
 111    environment only."
 112   (declare (symbol symbol))
 113   (let* ((fenv (when env (sb!c::lexenv-functions env)))
 114          (local-def (cdr (assoc symbol fenv))))
 115     (cond (local-def
 116            (if (and (consp local-def) (eq (car local-def) 'MACRO))
 117                (cdr local-def)
 118                nil))
 119           ((eq (info :function :kind symbol) :macro)
 120            (values (info :function :macro-function symbol)))
 121           (t
 122            nil))))
 123
 124 ;;; Note: Technically there could be an ENV optional argument to SETF
 125 ;;; MACRO-FUNCTION, but since ANSI says that the consequences of
 126 ;;; supplying that optional argument are undefined, we don't allow it.
 127 ;;; (Thus our implementation of this unspecified behavior is to
 128 ;;; complain that the wrong number of arguments was supplied. Since
 129 ;;; the behavior is unspecified, this is conforming.:-)
 130 (defun (setf sb!xc:macro-function) (function symbol)
 131   (declare (symbol symbol) (type function function))
 132   (when (eq (info :function :kind symbol) :special-form)
 133     (error "~S names a special form." symbol))
 134   (setf (info :function :kind symbol) :macro)
 135   (setf (info :function :macro-function symbol) function)
 136   ;; This is a nice thing to have in the target SBCL, but in the
 137   ;; cross-compilation host it's not nice to mess with
 138   ;; (SYMBOL-FUNCTION FOO) where FOO might be a symbol in the
 139   ;; cross-compilation host's COMMON-LISP package.
 140   #-sb-xc-host
 141   (setf (symbol-function symbol)
 142         (lambda (&rest args)
 143           (declare (ignore args))
 144           ;; (ANSI specification of FUNCALL says that this should be
 145           ;; an error of type UNDEFINED-FUNCTION, not just SIMPLE-ERROR.)
 146           (error 'undefined-function :name symbol)))
 147   function)
 148
 149 (defun sb!xc:compiler-macro-function (name &optional env)
 150   #!+sb-doc
 151   "If NAME names a compiler-macro, returns the expansion function,
 152    else returns NIL. Note: if the name is shadowed in ENV by a local
 153    definition, or declared NOTINLINE, NIL is returned. Can be
 154    set with SETF."
 155   (let ((found (and env
 156                     (cdr (assoc name (sb!c::lexenv-functions env)
 157                                 :test #'equal)))))
 158     (unless (eq (cond ((sb!c::defined-function-p found)
 159                        (sb!c::defined-function-inlinep found))
 160                       (found :notinline)
 161                       (t
 162                        (info :function :inlinep name)))
 163                 :notinline)
 164       (values (info :function :compiler-macro-function name)))))
 165 (defun (setf sb!xc:compiler-macro-function) (function name)
 166   (declare (type (or symbol list) name)
 167            (type (or function null) function))
 168   (when (eq (info :function :kind name) :special-form)
 169     (error "~S names a special form." name))
 170   (setf (info :function :compiler-macro-function name) function)
 171   function)
 172 \f
 173 ;;;; a subset of DOCUMENTATION functionality for bootstrapping
 174
 175 ;;; FDOCUMENTATION is like DOCUMENTATION, but with less functionality,
 176 ;;; and implemented with DEFUN instead of DEFGENERIC so that it can
 177 ;;; run before CLOS is set up. Supported DOC-TYPE values are
 178 ;;;   FUNCTION
 179 ;;;   SETF
 180 ;;;   STRUCTURE
 181 ;;;   T
 182 ;;;   TYPE
 183 ;;;   VARIABLE
 184 ;;; FIXME: Other types end up in INFO :RANDOM-DOCUMENTATION :STUFF. I
 185 ;;; should add some code to monitor this and make sure that nothing is
 186 ;;; unintentionally being sent to never never land this way.
 187 ;;; FIXME: Rename FDOCUMENTATION to BDOCUMENTATION, by analogy with
 188 ;;; DEF!STRUCT and DEF!MACRO and so forth. And consider simply saving
 189 ;;; all the BDOCUMENTATION entries in a *BDOCUMENTATION* hash table
 190 ;;; and slamming them into PCL once PCL gets going.
 191 (defun fdocumentation (x doc-type)
 192   (flet ((try-cmucl-random-doc (x doc-type)
 193            (declare (symbol doc-type))
 194            (cdr (assoc doc-type
 195                        (values (info :random-documentation :stuff x))))))
 196     (case doc-type
 197       (variable
 198        (typecase x
 199          (symbol (values (info :variable :documentation x)))))
 200       (function
 201        (cond ((functionp x)
 202               (function-doc x))
 203              ((legal-function-name-p x)
 204               ;; FIXME: Is it really right to make
 205               ;; (DOCUMENTATION '(SETF FOO) 'FUNCTION) equivalent to
 206               ;; (DOCUMENTATION 'FOO 'FUNCTION)? That's what CMU CL
 207               ;; did, so we do it, but I'm not sure it's what ANSI wants.
 208               (values (info :function :documentation
 209                             (function-name-block-name x))))))
 210       (structure
 211        (typecase x
 212          (symbol (when (eq (info :type :kind x) :instance)
 213                    (values (info :type :documentation x))))))
 214       (type
 215        (typecase x
 216          (structure-class (values (info :type :documentation (class-name x))))
 217          (t (and (typep x 'symbol) (values (info :type :documentation x))))))
 218       (setf (info :setf :documentation x))
 219       ((t)
 220        (typecase x
 221          (function (function-doc x))
 222          (package (package-doc-string x))
 223          (structure-class (values (info :type :documentation (class-name x))))
 224          (symbol (try-cmucl-random-doc x doc-type))))
 225       (t
 226        (typecase x
 227          ;; FIXME: This code comes from CMU CL, but
 228          ;; TRY-CMUCL-RANDOM-DOC doesn't seem to be defined anywhere
 229          ;; in CMU CL. Perhaps it could be defined by analogy with the
 230          ;; corresponding SETF FDOCUMENTATION code.
 231          (symbol (try-cmucl-random-doc x doc-type)))))))
 232 (defun (setf fdocumentation) (string name doc-type)
 233   ;; FIXME: I think it should be possible to set documentation for
 234   ;; things (e.g. compiler macros) named (SETF FOO). fndb.lisp
 235   ;; declares DOC-TYPE to be a SYMBOL, which contradicts that. What
 236   ;; should be done?
 237   (case doc-type
 238     (variable (setf (info :variable :documentation name) string))
 239     (function (setf (info :function :documentation name) string))
 240     (structure (if (eq (info :type :kind name) :instance)
 241                    (setf (info :type :documentation name) string)
 242                    (error "~S is not the name of a structure type." name)))
 243     (type (setf (info :type :documentation name) string))
 244     (setf (setf (info :setf :documentation name) string))
 245     (t
 246      (let ((pair (assoc doc-type (info :random-documentation :stuff name))))
 247        (if pair
 248            (setf (cdr pair) string)
 249            (push (cons doc-type string)
 250                  (info :random-documentation :stuff name))))))
 251   string)