src/code/fdefinition.lisp

   1 ;;;; This file contains functions that hack on the global function
   2 ;;;; namespace (primarily concerned with SETF functions here). Also,
   3 ;;;; function encapsulation and routines that set and return
   4 ;;;; definitions disregarding whether they might be encapsulated.
   5
   6 ;;;; This software is part of the SBCL system. See the README file for
   7 ;;;; more information.
   8 ;;;;
   9 ;;;; This software is derived from the CMU CL system, which was
  10 ;;;; written at Carnegie Mellon University and released into the
  11 ;;;; public domain. The software is in the public domain and is
  12 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  13 ;;;; files for more information.
  14
  15 (in-package "SB!IMPL")
  16
  17 (sb!int::/show0 "fdefinition.lisp 22")
  18 \f
  19 ;;;; fdefinition (fdefn) objects
  20
  21 (defun make-fdefn (name)
  22   (make-fdefn name))
  23
  24 (defun fdefn-name (fdefn)
  25   (declare (type fdefn fdefn))
  26   (fdefn-name fdefn))
  27
  28 (defun fdefn-fun (fdefn)
  29   (declare (type fdefn fdefn)
  30            (values (or function null)))
  31   (fdefn-fun fdefn))
  32
  33 (defun (setf fdefn-fun) (fun fdefn)
  34   (declare (type function fun)
  35            (type fdefn fdefn)
  36            (values function))
  37   (setf (fdefn-fun fdefn) fun))
  38
  39 (defun fdefn-makunbound (fdefn)
  40   (declare (type fdefn fdefn))
  41   (fdefn-makunbound fdefn))
  42
  43 ;;; This function is called by !COLD-INIT after the globaldb has been
  44 ;;; initialized, but before anything else. We need to install these
  45 ;;; fdefn objects into the globaldb before any top level forms run, or
  46 ;;; we will end up with two different fdefn objects being used for the
  47 ;;; same function name. *!INITIAL-FDEFN-OBJECTS* is set up by GENESIS.
  48 (defvar *!initial-fdefn-objects*)
  49 (defun !fdefn-cold-init ()
  50   (dolist (fdefn *!initial-fdefn-objects*)
  51     (setf (info :function :definition (fdefn-name fdefn)) fdefn)))
  52
  53 ;;; Return the fdefn object for NAME. If it doesn't already exist and
  54 ;;; CREATE is non-NIL, create a new (unbound) one.
  55 (defun fdefinition-object (name create)
  56   (declare (values (or fdefn null)))
  57   (legal-fun-name-or-type-error name)
  58   (let ((fdefn (info :function :definition name)))
  59     (if (and (null fdefn) create)
  60         (setf (info :function :definition name) (make-fdefn name))
  61         fdefn)))
  62
  63 (defun maybe-clobber-ftype (name)
  64   (unless (eq :declared (info :function :where-from name))
  65     (clear-info :function :type name)))
  66
  67 ;;; Return the fdefinition of NAME, including any encapsulations.
  68 ;;; The compiler emits calls to this when someone tries to FUNCALL
  69 ;;; something. SETFable.
  70 #!-sb-fluid (declaim (inline %coerce-name-to-fun))
  71 (defun %coerce-name-to-fun (name)
  72   (let ((fdefn (fdefinition-object name nil)))
  73     (or (and fdefn (fdefn-fun fdefn))
  74         (error 'undefined-function :name name))))
  75 (defun (setf %coerce-name-to-fun) (function name)
  76   (maybe-clobber-ftype name)
  77   (let ((fdefn (fdefinition-object name t)))
  78     (setf (fdefn-fun fdefn) function)))
  79
  80 (defun %coerce-callable-to-fun (callable)
  81   (if (functionp callable)
  82       callable
  83       (%coerce-name-to-fun callable)))
  84 \f
  85 ;;;; definition encapsulation
  86
  87 (defstruct (encapsulation-info (:constructor make-encapsulation-info
  88                                              (type definition))
  89                                (:copier nil))
  90   ;; This is definition's encapsulation type. The encapsulated
  91   ;; definition is in the previous ENCAPSULATION-INFO element or
  92   ;; installed as the global definition of some function name.
  93   type
  94   ;; the previous, encapsulated definition. This used to be installed
  95   ;; as a global definition for some function name, but it was
  96   ;; replaced by an encapsulation of type TYPE.
  97   (definition nil :type function))
  98
  99 ;;; Replace the definition of NAME with a function that binds NAME's
 100 ;;; arguments to a variable named ARG-LIST, binds name's definition
 101 ;;; to a variable named BASIC-DEFINITION, and evaluates BODY in that
 102 ;;; context. TYPE is whatever you would like to associate with this
 103 ;;; encapsulation for identification in case you need multiple
 104 ;;; encapsulations of the same name.
 105 (defun encapsulate (name type body)
 106   (let ((fdefn (fdefinition-object name nil)))
 107     (unless (and fdefn (fdefn-fun fdefn))
 108       (error 'undefined-function :name name))
 109     (when (typep (fdefn-fun fdefn) 'generic-function)
 110       (return-from encapsulate
 111         (encapsulate-generic-function (fdefn-fun fdefn) type body)))
 112     ;; We must bind and close over INFO. Consider the case where we
 113     ;; encapsulate (the second) an encapsulated (the first)
 114     ;; definition, and later someone unencapsulates the encapsulated
 115     ;; (first) definition. We don't want our encapsulation (second) to
 116     ;; bind basic-definition to the encapsulated (first) definition
 117     ;; when it no longer exists. When unencapsulating, we make sure to
 118     ;; clobber the appropriate INFO structure to allow
 119     ;; basic-definition to be bound to the next definition instead of
 120     ;; an encapsulation that no longer exists.
 121     (let ((info (make-encapsulation-info type (fdefn-fun fdefn))))
 122       (setf (fdefn-fun fdefn)
 123             (named-lambda encapsulation (&rest arg-list)
 124               (declare (special arg-list))
 125               (let ((basic-definition (encapsulation-info-definition info)))
 126                 (declare (special basic-definition))
 127                 (eval body)))))))
 128
 129 ;;; This is like FIND-IF, except that we do it on a compiled closure's
 130 ;;; environment.
 131 (defun find-if-in-closure (test closure)
 132   (declare (closure closure))
 133   (do-closure-values (value closure)
 134     (when (funcall test value)
 135       (return value))))
 136
 137 ;;; Find the encapsulation info that has been closed over.
 138 (defun encapsulation-info (fun)
 139   (when (closurep fun)
 140     (find-if-in-closure #'encapsulation-info-p fun)))
 141
 142 ;;; When removing an encapsulation, we must remember that
 143 ;;; encapsulating definitions close over a reference to the
 144 ;;; ENCAPSULATION-INFO that describes the encapsulating definition.
 145 ;;; When you find an info with the target type, the previous info in
 146 ;;; the chain has the ensulating definition of that type. We take the
 147 ;;; encapsulated definition from the info with the target type, and we
 148 ;;; store it in the previous info structure whose encapsulating
 149 ;;; definition it describes looks to this previous info structure for
 150 ;;; a definition to bind (see ENCAPSULATE). When removing the first
 151 ;;; info structure, we do something conceptually equal, but
 152 ;;; mechanically it is different.
 153 (defun unencapsulate (name type)
 154   #!+sb-doc
 155   "Removes NAME's most recent encapsulation of the specified TYPE."
 156   (let* ((fdefn (fdefinition-object name nil))
 157          (encap-info (encapsulation-info (fdefn-fun fdefn))))
 158     (declare (type (or encapsulation-info null) encap-info))
 159     (when (and fdefn (typep (fdefn-fun fdefn) 'generic-function))
 160       (return-from unencapsulate
 161         (unencapsulate-generic-function (fdefn-fun fdefn) type)))
 162     (cond ((not encap-info)
 163            ;; It disappeared on us, so don't worry about it.
 164            )
 165           ((eq (encapsulation-info-type encap-info) type)
 166            ;; It's the first one, so change the fdefn object.
 167            (setf (fdefn-fun fdefn)
 168                  (encapsulation-info-definition encap-info)))
 169           (t
 170            ;; It must be an interior one, so find it.
 171            (loop
 172              (let ((next-info (encapsulation-info
 173                                (encapsulation-info-definition encap-info))))
 174                (unless next-info
 175                  ;; Not there, so don't worry about it.
 176                  (return))
 177                (when (eq (encapsulation-info-type next-info) type)
 178                  ;; This is it, so unlink us.
 179                  (setf (encapsulation-info-definition encap-info)
 180                        (encapsulation-info-definition next-info))
 181                  (return))
 182                (setf encap-info next-info))))))
 183   t)
 184
 185 ;;; Does NAME have an encapsulation of the given TYPE?
 186 (defun encapsulated-p (name type)
 187   (let ((fdefn (fdefinition-object name nil)))
 188     (when (and fdefn (typep (fdefn-fun fdefn) 'generic-function))
 189       (return-from encapsulated-p
 190         (encapsulated-generic-function-p (fdefn-fun fdefn) type)))
 191     (do ((encap-info (encapsulation-info (fdefn-fun fdefn))
 192                      (encapsulation-info
 193                       (encapsulation-info-definition encap-info))))
 194         ((null encap-info) nil)
 195       (declare (type (or encapsulation-info null) encap-info))
 196       (when (eq (encapsulation-info-type encap-info) type)
 197         (return t)))))
 198 \f
 199 ;;;; FDEFINITION
 200
 201 ;;; KLUDGE: Er, it looks as though this means that
 202 ;;;    (FUNCALL (FDEFINITION 'FOO))
 203 ;;; doesn't do the same thing as
 204 ;;;    (FUNCALL 'FOO),
 205 ;;; and (SYMBOL-FUNCTION 'FOO) isn't in general the same thing
 206 ;;; as (FDEFINITION 'FOO). That doesn't look like ANSI behavior to me.
 207 ;;; Look e.g. at the ANSI definition of TRACE: "Whenever a traced
 208 ;;; function is invoked, information about the call, ..". Try this:
 209 ;;;   (DEFUN FOO () (PRINT "foo"))
 210 ;;;   (TRACE FOO)
 211 ;;;   (FUNCALL 'FOO)
 212 ;;;   (FUNCALL (FDEFINITION 'FOO))
 213 ;;; What to do? ANSI says TRACE "Might change the definitions of the
 214 ;;; functions named by function-names." Might it be OK to just get
 215 ;;; punt all this encapsulation stuff and go back to a simple but
 216 ;;; correct implementation of TRACE? We'd lose the ability to redefine
 217 ;;; a TRACEd function and keep the trace in place, but that seems
 218 ;;; tolerable to me. (Is the wrapper stuff needed for anything else
 219 ;;; besides TRACE?)
 220 ;;;
 221 ;;; The only problem I can see with not having a wrapper: If tracing
 222 ;;; EQ, EQL, EQUAL, or EQUALP causes its function address to change,
 223 ;;; it will mess up the MAKE-HASH-TABLE logic which uses EQ tests
 224 ;;; on those function values. But given the ANSI statement about
 225 ;;; TRACE causing things to change, that doesn't seem too unreasonable;
 226 ;;; and we might even be able to forbid tracing these functions.
 227 ;;; -- WHN 2001-11-02
 228 (defun fdefinition (name)
 229   #!+sb-doc
 230   "Return name's global function definition taking care to respect any
 231    encapsulations and to return the innermost encapsulated definition.
 232    This is SETF'able."
 233   (let ((fun (%coerce-name-to-fun name)))
 234     (loop
 235      (let ((encap-info (encapsulation-info fun)))
 236        (if encap-info
 237            (setf fun (encapsulation-info-definition encap-info))
 238            (return fun))))))
 239
 240 (defvar *setf-fdefinition-hook* nil
 241   #!+sb-doc
 242   "A list of functions that (SETF FDEFINITION) invokes before storing the
 243    new value. The functions take the function name and the new value.")
 244
 245 (defun %set-fdefinition (name new-value)
 246   #!+sb-doc
 247   "Set NAME's global function definition."
 248   (declare (type function new-value) (optimize (safety 1)))
 249   (with-single-package-locked-error (:symbol name "setting fdefinition of ~A")
 250     (maybe-clobber-ftype name)
 251
 252     ;; Check for hash-table stuff. Woe onto him that mixes encapsulation
 253     ;; with this.
 254     (when (and (symbolp name) (fboundp name)
 255                (boundp '*user-hash-table-tests*))
 256       (let ((old (symbol-function name)))
 257         (declare (special *user-hash-table-tests*))
 258         (dolist (spec *user-hash-table-tests*)
 259           (cond ((eq old (second spec))
 260                  ;; test-function
 261                  (setf (second spec) new-value))
 262                 ((eq old (third spec))
 263                  ;; hash-function
 264                  (setf (third spec) new-value))))))
 265
 266     ;; FIXME: This is a good hook to have, but we should probably
 267     ;; reserve it for users.
 268     (let ((fdefn (fdefinition-object name t)))
 269       ;; *SETF-FDEFINITION-HOOK* won't be bound when initially running
 270       ;; top level forms in the kernel core startup.
 271       (when (boundp '*setf-fdefinition-hook*)
 272         (dolist (f *setf-fdefinition-hook*)
 273           (declare (type function f))
 274           (funcall f name new-value)))
 275
 276       (let ((encap-info (encapsulation-info (fdefn-fun fdefn))))
 277         (cond (encap-info
 278                (loop
 279                 (let ((more-info
 280                        (encapsulation-info
 281                         (encapsulation-info-definition encap-info))))
 282                   (if more-info
 283                       (setf encap-info more-info)
 284                       (return
 285                         (setf (encapsulation-info-definition encap-info)
 286                               new-value))))))
 287               (t
 288                (setf (fdefn-fun fdefn) new-value)))))))
 289 \f
 290 ;;;; FBOUNDP and FMAKUNBOUND
 291
 292 (defun fboundp (name)
 293   #!+sb-doc
 294   "Return true if name has a global function definition."
 295   (let ((fdefn (fdefinition-object name nil)))
 296     (and fdefn (fdefn-fun fdefn) t)))
 297
 298 (defun fmakunbound (name)
 299   #!+sb-doc
 300   "Make NAME have no global function definition."
 301   (with-single-package-locked-error
 302       (:symbol name "removing the function or macro definition of ~A")
 303     (let ((fdefn (fdefinition-object name nil)))
 304       (when fdefn
 305         (fdefn-makunbound fdefn)))
 306     (sb!kernel:undefine-fun-name name)
 307     name))