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 ;;;; internal utilities defined in terms of INFO
  21
  22 ;;; Check that NAME is a valid function name, returning the name if
  23 ;;; OK, and signalling an error if not. In addition to checking for
  24 ;;; basic well-formedness, we also check that symbol names are not NIL
  25 ;;; or the name of a special form.
  26 (defun check-fun-name (name)
  27   (typecase name
  28     (list
  29      (unless (legal-fun-name-p name)
  30        (compiler-error "illegal function name: ~S" name)))
  31     (symbol
  32      (when (eq (info :function :kind name) :special-form)
  33        (compiler-error "Special form is an illegal function name: ~S" name)))
  34     (t
  35      (compiler-error "illegal function name: ~S" name)))
  36   (values))
  37
  38 ;;; Record a new function definition, and check its legality.
  39 (defun proclaim-as-fun-name (name)
  40
  41   ;; legal name?
  42   (check-fun-name name)
  43
  44   ;; scrubbing old data I: possible collision with old definition
  45   (when (fboundp name)
  46     (ecase (info :function :kind name)
  47       (:function) ; happy case
  48       ((nil)) ; another happy case
  49       (:macro ; maybe-not-so-good case
  50        (compiler-style-warn "~S was previously defined as a macro." name)
  51        (setf (info :function :where-from name) :assumed)
  52        (clear-info :function :macro-function name))))
  53
  54   ;; scrubbing old data II: dangling forward references
  55   ;;
  56   ;; (This could happen if someone executes PROCLAIM FTYPE at
  57   ;; macroexpansion time, which is bad style, or at compile time, e.g.
  58   ;; in EVAL-WHEN (:COMPILE) inside something like DEFSTRUCT, in which
  59   ;; case it's reasonable style. Either way, NAME is no longer a free
  60   ;; function.)
  61   (when (boundp '*free-funs*) ; when compiling
  62     (remhash name *free-funs*))
  63
  64   ;; recording the ordinary case
  65   (setf (info :function :kind name) :function)
  66   (note-if-setf-fun-and-macro name)
  67
  68   (values))
  69
  70 ;;; This is called to do something about SETF functions that overlap
  71 ;;; with SETF macros. Perhaps we should interact with the user to see
  72 ;;; whether the macro should be blown away, but for now just give a
  73 ;;; warning. Due to the weak semantics of the (SETF FUNCTION) name, we
  74 ;;; can't assume that they aren't just naming a function (SETF FOO)
  75 ;;; for the heck of it. NAME is already known to be well-formed.
  76 (defun note-if-setf-fun-and-macro (name)
  77   (when (consp name)
  78     (when (or (info :setf :inverse name)
  79               (info :setf :expander name))
  80       (compiler-style-warn
  81        "defining as a SETF function a name that already has a SETF macro:~
  82        ~%  ~S"
  83        name)))
  84   (values))
  85
  86 ;;; Make NAME no longer be a function name: clear everything back to
  87 ;;; the default.
  88 (defun undefine-fun-name (name)
  89   (when name
  90     (macrolet ((frob (type &optional val)
  91                  `(unless (eq (info :function ,type name) ,val)
  92                     (setf (info :function ,type name) ,val))))
  93       (frob :info)
  94       (frob :type (specifier-type 'function))
  95       (frob :where-from :assumed)
  96       (frob :inlinep)
  97       (frob :kind)
  98       (frob :inline-expansion-designator)
  99       (frob :source-transform)
 100       (frob :assumed-type)))
 101   (values))
 102
 103 ;;; part of what happens with DEFUN, also with some PCL stuff: Make
 104 ;;; NAME known to be a function definition.
 105 (defun become-defined-fun-name (name)
 106   (proclaim-as-fun-name name)
 107   (when (eq (info :function :where-from name) :assumed)
 108     (setf (info :function :where-from name) :defined)
 109     (if (info :function :assumed-type name)
 110         (setf (info :function :assumed-type name) nil))))
 111
 112 ;;; Decode any raw (INFO :FUNCTION :INLINE-EXPANSION-DESIGNATOR FUN-NAME)
 113 ;;; value into a lambda expression, or return NIL if there is none.
 114 (declaim (ftype (function ((or symbol cons)) list) fun-name-inline-expansion))
 115 (defun fun-name-inline-expansion (fun-name)
 116   (let ((info (info :function :inline-expansion-designator fun-name)))
 117     (if (functionp info)
 118         (funcall info)
 119         info)))
 120 \f
 121 ;;;; ANSI Common Lisp functions which are defined in terms of the info
 122 ;;;; database
 123
 124 (defun sb!xc:macro-function (symbol &optional env)
 125   #!+sb-doc
 126   "If SYMBOL names a macro in ENV, returns the expansion function,
 127    else returns NIL. If ENV is unspecified or NIL, use the global
 128    environment only."
 129   (declare (symbol symbol))
 130   (let* ((fenv (when env (sb!c::lexenv-funs env)))
 131          (local-def (cdr (assoc symbol fenv))))
 132     (cond (local-def
 133            (if (and (consp local-def) (eq (car local-def) 'macro))
 134                (cdr local-def)
 135                nil))
 136           ((eq (info :function :kind symbol) :macro)
 137            (values (info :function :macro-function symbol)))
 138           (t
 139            nil))))
 140
 141 (defun (setf sb!xc:macro-function) (function symbol &optional environment)
 142   (declare (symbol symbol) (type function function))
 143   (when environment
 144     ;; Note: Technically there could be an ENV optional argument to SETF
 145     ;; MACRO-FUNCTION, but since ANSI says that the consequences of
 146     ;; supplying a non-nil one are undefined, we don't allow it.
 147     ;; (Thus our implementation of this unspecified behavior is to
 148     ;; complain. SInce the behavior is unspecified, this is conforming.:-)
 149     (error "Non-NIL environment argument in SETF of MACRO-FUNCTION ~S: ~S"
 150            symbol environment))
 151   (when (eq (info :function :kind symbol) :special-form)
 152     (error "~S names a special form." symbol))
 153   (setf (info :function :kind symbol) :macro)
 154   (setf (info :function :macro-function symbol) function)
 155   ;; This is a nice thing to have in the target SBCL, but in the
 156   ;; cross-compilation host it's not nice to mess with
 157   ;; (SYMBOL-FUNCTION FOO) where FOO might be a symbol in the
 158   ;; cross-compilation host's COMMON-LISP package.
 159   #-sb-xc-host
 160   (setf (symbol-function symbol)
 161         (lambda (&rest args)
 162           (declare (ignore args))
 163           ;; (ANSI specification of FUNCALL says that this should be
 164           ;; an error of type UNDEFINED-FUNCTION, not just SIMPLE-ERROR.)
 165           (error 'undefined-function :name symbol)))
 166   function)
 167
 168 (defun sb!xc:compiler-macro-function (name &optional env)
 169   #!+sb-doc
 170   "If NAME names a compiler-macro in ENV, return the expansion function, else
 171    return NIL. Can be set with SETF when ENV is NIL."
 172   (declare (ignore env))
 173   (legal-fun-name-or-type-error name)
 174   ;; Note: CMU CL used to return NIL here when a NOTINLINE declaration
 175   ;; was in force. That's fairly logical, given the specified effect
 176   ;; of NOTINLINE declarations on compiler-macro expansion. However,
 177   ;; (1) it doesn't seem to be consistent with the ANSI spec for
 178   ;; COMPILER-MACRO-FUNCTION, and (2) it would give surprising
 179   ;; behavior for (SETF (COMPILER-MACRO-FUNCTION FOO) ...) in the
 180   ;; presence of a (PROCLAIM '(NOTINLINE FOO)). So we don't do it.
 181   (values (info :function :compiler-macro-function name)))
 182 (defun (setf sb!xc:compiler-macro-function) (function name &optional env)
 183   (declare (type (or symbol list) name)
 184            (type (or function null) function))
 185   (when env
 186     ;; ANSI says this operation is undefined.
 187     (error "can't SETF COMPILER-MACRO-FUNCTION when ENV is non-NIL"))
 188   (when (eq (info :function :kind name) :special-form)
 189     (error "~S names a special form." name))
 190   (with-single-package-locked-error
 191       (:symbol name "setting the compiler-macro-function of ~A")
 192     (setf (info :function :compiler-macro-function name) function)
 193     function))
 194 \f
 195 ;;;; a subset of DOCUMENTATION functionality for bootstrapping
 196
 197 ;;; FDOCUMENTATION is like DOCUMENTATION, but with less functionality,
 198 ;;; and implemented with DEFUN instead of DEFGENERIC so that it can
 199 ;;; run before CLOS is set up. Supported DOC-TYPE values are
 200 ;;;   FUNCTION
 201 ;;;   SETF
 202 ;;;   STRUCTURE
 203 ;;;   T
 204 ;;;   TYPE
 205 ;;;   VARIABLE
 206 ;;; FIXME: Other types end up in INFO :RANDOM-DOCUMENTATION :STUFF. I
 207 ;;; should add some code to monitor this and make sure that nothing is
 208 ;;; unintentionally being sent to never never land this way.
 209 ;;; FIXME: Rename FDOCUMENTATION to BDOCUMENTATION, by analogy with
 210 ;;; DEF!STRUCT and DEF!MACRO and so forth. And consider simply saving
 211 ;;; all the BDOCUMENTATION entries in a *BDOCUMENTATION* hash table
 212 ;;; and slamming them into PCL once PCL gets going.
 213 (defun fdocumentation (x doc-type)
 214   (flet ((try-cmucl-random-doc (x doc-type)
 215            (declare (symbol doc-type))
 216            (cdr (assoc doc-type
 217                        (values (info :random-documentation :stuff x))))))
 218     (case doc-type
 219       (variable
 220        (typecase x
 221          (symbol (values (info :variable :documentation x)))))
 222       (function
 223        (cond ((functionp x)
 224               (%fun-doc x))
 225              ((legal-fun-name-p x)
 226               ;; FIXME: Is it really right to make
 227               ;; (DOCUMENTATION '(SETF FOO) 'FUNCTION) equivalent to
 228               ;; (DOCUMENTATION 'FOO 'FUNCTION)? That's what CMU CL
 229               ;; did, so we do it, but I'm not sure it's what ANSI wants.
 230               (values (info :function :documentation
 231                             (fun-name-block-name x))))))
 232       (structure
 233        (typecase x
 234          (symbol (when (eq (info :type :kind x) :instance)
 235                    (values (info :type :documentation x))))))
 236       (type
 237        (typecase x
 238          (structure-class (values (info :type :documentation (class-name x))))
 239          (t (and (typep x 'symbol) (values (info :type :documentation x))))))
 240       (setf (values (info :setf :documentation x)))
 241       ((t)
 242        (typecase x
 243          (function (%fun-doc x))
 244          (package (package-doc-string x))
 245          (structure-class (values (info :type :documentation (class-name x))))
 246          (symbol (try-cmucl-random-doc x doc-type))))
 247       (t
 248        (typecase x
 249          ;; FIXME: This code comes from CMU CL, but
 250          ;; TRY-CMUCL-RANDOM-DOC doesn't seem to be defined anywhere
 251          ;; in CMU CL. Perhaps it could be defined by analogy with the
 252          ;; corresponding SETF FDOCUMENTATION code.
 253          (symbol (try-cmucl-random-doc x doc-type)))))))
 254 (defun (setf fdocumentation) (string name doc-type)
 255   ;; FIXME: I think it should be possible to set documentation for
 256   ;; things (e.g. compiler macros) named (SETF FOO). fndb.lisp
 257   ;; declares DOC-TYPE to be a SYMBOL, which contradicts that. What
 258   ;; should be done?
 259   (case doc-type
 260     (variable (setf (info :variable :documentation name) string))
 261     (function (setf (info :function :documentation name) string))
 262     (structure (if (eq (info :type :kind name) :instance)
 263                    (setf (info :type :documentation name) string)
 264                    (error "~S is not the name of a structure type." name)))
 265     (type (setf (info :type :documentation name) string))
 266     (setf (setf (info :setf :documentation name) string))
 267     (t
 268      (let ((pair (assoc doc-type (info :random-documentation :stuff name))))
 269        (if pair
 270            (setf (cdr pair) string)
 271            (push (cons doc-type string)
 272                  (info :random-documentation :stuff name))))))
 273   string)