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
  45   ;; KLUDGE: This can happen when eg. compiling a NAMED-LAMBDA, and isn't
  46   ;; guarded against elsewhere -- so we want to assert package locks here. The
  47   ;; reason we do it only when stomping on existing stuff is because we want
  48   ;; to keep
  49   ;;   (WITHOUT-PACKAGE-LOCKS (DEFUN LOCKED:FOO ...))
  50   ;; viable, which requires no compile-time violations in the harmless cases.
  51   (with-single-package-locked-error ()
  52     (flet ((assert-it ()
  53              (assert-symbol-home-package-unlocked name "proclaiming ~S as a function")))
  54
  55       (let ((kind (info :function :kind name)))
  56         ;; scrubbing old data I: possible collision with a macro
  57         (when (and (fboundp name) (eq :macro kind))
  58           (assert-it)
  59           (compiler-style-warn "~S was previously defined as a macro." name)
  60           (setf (info :function :where-from name) :assumed)
  61           (clear-info :function :macro-function name))
  62
  63         (unless (eq :function kind)
  64           (assert-it)
  65           (setf (info :function :kind name) :function)))))
  66
  67   ;; scrubbing old data II: dangling forward references
  68   ;;
  69   ;; (This could happen if someone executes PROCLAIM FTYPE at
  70   ;; macroexpansion time, which is bad style, or at compile time, e.g.
  71   ;; in EVAL-WHEN (:COMPILE) inside something like DEFSTRUCT, in which
  72   ;; case it's reasonable style. Either way, NAME is no longer a free
  73   ;; function.)
  74   (when (boundp '*free-funs*)       ; when compiling
  75     (remhash name *free-funs*))
  76
  77   (note-if-setf-fun-and-macro name)
  78
  79   (values))
  80
  81 ;;; This is called to do something about SETF functions that overlap
  82 ;;; with SETF macros. Perhaps we should interact with the user to see
  83 ;;; whether the macro should be blown away, but for now just give a
  84 ;;; warning. Due to the weak semantics of the (SETF FUNCTION) name, we
  85 ;;; can't assume that they aren't just naming a function (SETF FOO)
  86 ;;; for the heck of it. NAME is already known to be well-formed.
  87 (defun note-if-setf-fun-and-macro (name)
  88   (when (and (consp name)
  89              (eq (car name) 'setf))
  90     (when (or (info :setf :inverse (second name))
  91               (info :setf :expander (second name)))
  92       (compiler-style-warn
  93        "defining as a SETF function a name that already has a SETF macro:~
  94        ~%  ~S"
  95        name)))
  96   (values))
  97
  98 ;;; Make NAME no longer be a function name: clear everything back to
  99 ;;; the default.
 100 (defun undefine-fun-name (name)
 101   (when name
 102     (macrolet ((frob (type &optional val)
 103                  `(unless (eq (info :function ,type name) ,val)
 104                     (setf (info :function ,type name) ,val))))
 105       (frob :info)
 106       (frob :type (specifier-type 'function))
 107       (frob :where-from :assumed)
 108       (frob :inlinep)
 109       (frob :kind)
 110       (frob :macro-function)
 111       (frob :inline-expansion-designator)
 112       (frob :source-transform)
 113       (frob :structure-accessor)
 114       (frob :assumed-type)))
 115   (values))
 116
 117 ;;; part of what happens with DEFUN, also with some PCL stuff: Make
 118 ;;; NAME known to be a function definition.
 119 (defun become-defined-fun-name (name)
 120   (proclaim-as-fun-name name)
 121   (when (eq (info :function :where-from name) :assumed)
 122     (setf (info :function :where-from name) :defined)
 123     (if (info :function :assumed-type name)
 124         (setf (info :function :assumed-type name) nil))))
 125
 126 ;;; Decode any raw (INFO :FUNCTION :INLINE-EXPANSION-DESIGNATOR FUN-NAME)
 127 ;;; value into a lambda expression, or return NIL if there is none.
 128 (declaim (ftype (function ((or symbol cons)) list) fun-name-inline-expansion))
 129 (defun fun-name-inline-expansion (fun-name)
 130   (let ((info (info :function :inline-expansion-designator fun-name)))
 131     (if (functionp info)
 132         (funcall info)
 133         info)))
 134 \f
 135 ;;;; ANSI Common Lisp functions which are defined in terms of the info
 136 ;;;; database
 137
 138 (defun sb!xc:macro-function (symbol &optional env)
 139   #!+sb-doc
 140   "If SYMBOL names a macro in ENV, returns the expansion function,
 141 else returns NIL. If ENV is unspecified or NIL, use the global environment
 142 only."
 143   (declare (symbol symbol))
 144   (let* ((fenv (when env (lexenv-funs env)))
 145          (local-def (cdr (assoc symbol fenv))))
 146     (if local-def
 147         (if (and (consp local-def) (eq (car local-def) 'macro))
 148             (cdr local-def)
 149             nil)
 150         (values (info :function :macro-function symbol)))))
 151
 152 (defun (setf sb!xc:macro-function) (function symbol &optional environment)
 153   (declare (symbol symbol) (type function function))
 154   (when environment
 155     ;; Note: Technically there could be an ENV optional argument to SETF
 156     ;; MACRO-FUNCTION, but since ANSI says that the consequences of
 157     ;; supplying a non-nil one are undefined, we don't allow it.
 158     ;; (Thus our implementation of this unspecified behavior is to
 159     ;; complain. SInce the behavior is unspecified, this is conforming.:-)
 160     (error "Non-NIL environment argument in SETF of MACRO-FUNCTION ~S: ~S"
 161            symbol environment))
 162   (when (eq (info :function :kind symbol) :special-form)
 163     (error "~S names a special form." symbol))
 164   (with-single-package-locked-error (:symbol symbol "setting the macro-function of ~S")
 165     (setf (info :function :kind symbol) :macro)
 166     (setf (info :function :macro-function symbol) function)
 167     ;; This is a nice thing to have in the target SBCL, but in the
 168     ;; cross-compilation host it's not nice to mess with
 169     ;; (SYMBOL-FUNCTION FOO) where FOO might be a symbol in the
 170     ;; cross-compilation host's COMMON-LISP package.
 171     #-sb-xc-host
 172     (setf (symbol-function symbol)
 173           (lambda (&rest args)
 174             (declare (ignore args))
 175             ;; (ANSI specification of FUNCALL says that this should be
 176             ;; an error of type UNDEFINED-FUNCTION, not just SIMPLE-ERROR.)
 177             (error 'undefined-function :name symbol))))
 178   function)
 179
 180 (defun fun-locally-defined-p (name env)
 181   (and env
 182        (let ((fun (cdr (assoc name (lexenv-funs env) :test #'equal))))
 183          (and fun (not (global-var-p fun))))))
 184
 185 (defun sb!xc:compiler-macro-function (name &optional env)
 186   #!+sb-doc
 187   "If NAME names a compiler-macro in ENV, return the expansion function, else
 188 return NIL. Can be set with SETF when ENV is NIL."
 189   (legal-fun-name-or-type-error name)
 190   ;; CLHS 3.2.2.1: Creating a lexical binding for the function name
 191   ;; not only creates a new local function or macro definition, but
 192   ;; also shadows[2] the compiler macro.
 193   (unless (fun-locally-defined-p name env)
 194     ;; Note: CMU CL used to return NIL here when a NOTINLINE
 195     ;; declaration was in force. That's fairly logical, given the
 196     ;; specified effect of NOTINLINE declarations on compiler-macro
 197     ;; expansion. However, (1) it doesn't seem to be consistent with
 198     ;; the ANSI spec for COMPILER-MACRO-FUNCTION, and (2) it would
 199     ;; give surprising behavior for (SETF (COMPILER-MACRO-FUNCTION
 200     ;; FOO) ...) in the presence of a (PROCLAIM '(NOTINLINE FOO)). So
 201     ;; we don't do it.
 202     (values (info :function :compiler-macro-function name))))
 203
 204 (defun (setf sb!xc:compiler-macro-function) (function name &optional env)
 205   (declare (type (or symbol list) name)
 206            (type (or function null) function))
 207   (when env
 208     ;; ANSI says this operation is undefined.
 209     (error "can't SETF COMPILER-MACRO-FUNCTION when ENV is non-NIL"))
 210   (when (eq (info :function :kind name) :special-form)
 211     (error "~S names a special form." name))
 212   (with-single-package-locked-error
 213       (:symbol name "setting the compiler-macro-function of ~A")
 214     (setf (info :function :compiler-macro-function name) function)
 215     function))
 216 \f
 217 ;;;; a subset of DOCUMENTATION functionality for bootstrapping
 218
 219 ;;; FDOCUMENTATION is like DOCUMENTATION, but with less functionality,
 220 ;;; and implemented with DEFUN instead of DEFGENERIC so that it can
 221 ;;; run before CLOS is set up. Supported DOC-TYPE values are
 222 ;;;   FUNCTION
 223 ;;;   SETF
 224 ;;;   STRUCTURE
 225 ;;;   T
 226 ;;;   TYPE
 227 ;;;   VARIABLE
 228 ;;; FIXME: Other types end up in INFO :RANDOM-DOCUMENTATION :STUFF. I
 229 ;;; should add some code to monitor this and make sure that nothing is
 230 ;;; unintentionally being sent to never never land this way.
 231 ;;; FIXME: Rename FDOCUMENTATION to BDOCUMENTATION, by analogy with
 232 ;;; DEF!STRUCT and DEF!MACRO and so forth. And consider simply saving
 233 ;;; all the BDOCUMENTATION entries in a *BDOCUMENTATION* hash table
 234 ;;; and slamming them into PCL once PCL gets going.
 235 (defun fdocumentation (x doc-type)
 236   (case doc-type
 237     (variable
 238      (typecase x
 239        (symbol (values (info :variable :documentation x)))))
 240     ;; FUNCTION is not used at the momemnt, just here for symmetry.
 241     (function
 242      (cond ((functionp x)
 243             (%fun-doc x))
 244            ((and (legal-fun-name-p x) (fboundp x))
 245             (%fun-doc (or (and (symbolp x) (macro-function x))
 246                           (fdefinition x))))))
 247     (structure
 248      (typecase x
 249        (symbol (cond
 250                  ((eq (info :type :kind x) :instance)
 251                   (values (info :type :documentation x)))
 252                  ((info :typed-structure :info x)
 253                   (values (info :typed-structure :documentation x)))))))
 254     (type
 255      (typecase x
 256        (structure-class (values (info :type :documentation (class-name x))))
 257        (t (and (typep x 'symbol) (values (info :type :documentation x))))))
 258     (setf (values (info :setf :documentation x)))
 259     ((t)
 260      (typecase x
 261        (function (%fun-doc x))
 262        (package (package-doc-string x))
 263        (structure-class (values (info :type :documentation (class-name x))))
 264        ((or symbol cons)
 265         (random-documentation x doc-type))))
 266     (t
 267      (when (typep x '(or symbol cons))
 268        (random-documentation x doc-type)))))
 269
 270 (defun (setf fdocumentation) (string name doc-type)
 271   (declare (type (or null string) string))
 272   (case doc-type
 273     (variable (setf (info :variable :documentation name) string))
 274     (function
 275      ;; KLUDGE: FDEFINITION isn't ready early enough during cold-init, so
 276      ;; special case for symbols.
 277      (if (symbolp name)
 278          (setf (%fun-doc (symbol-function name)) string)
 279          (when (legal-fun-name-p name)
 280            (setf (%fun-doc (fdefinition name)) string))))
 281     (structure (cond
 282                  ((eq (info :type :kind name) :instance)
 283                   (setf (info :type :documentation name) string))
 284                  ((info :typed-structure :info name)
 285                   (setf (info :typed-structure :documentation name) string))))
 286     (type (setf (info :type :documentation name) string))
 287     (setf (setf (info :setf :documentation name) string))
 288     (t
 289      (when (typep name '(or symbol cons))
 290        (setf (random-documentation name doc-type) string))))
 291   string)
 292
 293 (defun random-documentation (name type)
 294   (cdr (assoc type (info :random-documentation :stuff name))))
 295
 296 (defun (setf random-documentation) (new-value name type)
 297   (let ((pair (assoc type (info :random-documentation :stuff name))))
 298     (if pair
 299         (setf (cdr pair) new-value)
 300         (push (cons type new-value)
 301               (info :random-documentation :stuff name))))
 302   new-value)