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