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 ;;; Return the fdefinition of NAME, including any encapsulations.
  64 ;;; The compiler emits calls to this when someone tries to FUNCALL
  65 ;;; something. SETFable.
  66 #!-sb-fluid (declaim (inline %coerce-name-to-fun))
  67 (defun %coerce-name-to-fun (name)
  68   (let ((fdefn (fdefinition-object name nil)))
  69     (or (and fdefn (fdefn-fun fdefn))
  70         (error 'undefined-function :name name))))
  71 (defun (setf %coerce-name-to-fun) (function name)
  72   (let ((fdefn (fdefinition-object name t)))
  73     (setf (fdefn-fun fdefn) function)))
  74
  75 (defun %coerce-callable-to-fun (callable)
  76   (if (functionp callable)
  77       callable
  78       (%coerce-name-to-fun callable)))
  79 \f
  80 ;;;; definition encapsulation
  81
  82 (defstruct (encapsulation-info (:constructor make-encapsulation-info
  83                                              (type definition))
  84                                (:copier nil))
  85   ;; This is definition's encapsulation type. The encapsulated
  86   ;; definition is in the previous ENCAPSULATION-INFO element or
  87   ;; installed as the global definition of some function name.
  88   type
  89   ;; the previous, encapsulated definition. This used to be installed
  90   ;; as a global definition for some function name, but it was
  91   ;; replaced by an encapsulation of type TYPE.
  92   (definition nil :type function))
  93
  94 ;;; Replace the definition of NAME with a function that binds NAME's
  95 ;;; arguments to a variable named ARG-LIST, binds name's definition
  96 ;;; to a variable named BASIC-DEFINITION, and evaluates BODY in that
  97 ;;; context. TYPE is whatever you would like to associate with this
  98 ;;; encapsulation for identification in case you need multiple
  99 ;;; encapsulations of the same name.
 100 (defun encapsulate (name type body)
 101   (let ((fdefn (fdefinition-object name nil)))
 102     (unless (and fdefn (fdefn-fun fdefn))
 103       (error 'undefined-function :name name))
 104     ;; We must bind and close over INFO. Consider the case where we
 105     ;; encapsulate (the second) an encapsulated (the first)
 106     ;; definition, and later someone unencapsulates the encapsulated
 107     ;; (first) definition. We don't want our encapsulation (second) to
 108     ;; bind basic-definition to the encapsulated (first) definition
 109     ;; when it no longer exists. When unencapsulating, we make sure to
 110     ;; clobber the appropriate INFO structure to allow
 111     ;; basic-definition to be bound to the next definition instead of
 112     ;; an encapsulation that no longer exists.
 113     (let ((info (make-encapsulation-info type (fdefn-fun fdefn))))
 114       (setf (fdefn-fun fdefn)
 115             (named-lambda encapsulation (&rest arg-list)
 116               (declare (special arg-list))
 117               (let ((basic-definition (encapsulation-info-definition info)))
 118                 (declare (special basic-definition))
 119                 (eval body)))))))
 120
 121 ;;; This is like FIND-IF, except that we do it on a compiled closure's
 122 ;;; environment.
 123 (defun find-if-in-closure (test fun)
 124   (declare (type function test))
 125   (dotimes (index (1- (get-closure-length fun)))
 126     (let ((elt (%closure-index-ref fun index)))
 127       (when (funcall test elt)
 128         (return elt)))))
 129
 130 ;;; Find the encapsulation info that has been closed over.
 131 (defun encapsulation-info (fun)
 132   (and (functionp fun)
 133        (= (widetag-of fun) sb!vm:closure-header-widetag)
 134        (find-if-in-closure #'encapsulation-info-p fun)))
 135
 136 ;;; When removing an encapsulation, we must remember that
 137 ;;; encapsulating definitions close over a reference to the
 138 ;;; ENCAPSULATION-INFO that describes the encapsulating definition.
 139 ;;; When you find an info with the target type, the previous info in
 140 ;;; the chain has the ensulating definition of that type. We take the
 141 ;;; encapsulated definition from the info with the target type, and we
 142 ;;; store it in the previous info structure whose encapsulating
 143 ;;; definition it describes looks to this previous info structure for
 144 ;;; a definition to bind (see ENCAPSULATE). When removing the first
 145 ;;; info structure, we do something conceptually equal, but
 146 ;;; mechanically it is different.
 147 (defun unencapsulate (name type)
 148   #!+sb-doc
 149   "Removes NAME's most recent encapsulation of the specified TYPE."
 150   (let* ((fdefn (fdefinition-object name nil))
 151          (encap-info (encapsulation-info (fdefn-fun fdefn))))
 152     (declare (type (or encapsulation-info null) encap-info))
 153     (cond ((not encap-info)
 154            ;; It disappeared on us, so don't worry about it.
 155            )
 156           ((eq (encapsulation-info-type encap-info) type)
 157            ;; It's the first one, so change the fdefn object.
 158            (setf (fdefn-fun fdefn)
 159                  (encapsulation-info-definition encap-info)))
 160           (t
 161            ;; It must be an interior one, so find it.
 162            (loop
 163              (let ((next-info (encapsulation-info
 164                                (encapsulation-info-definition encap-info))))
 165                (unless next-info
 166                  ;; Not there, so don't worry about it.
 167                  (return))
 168                (when (eq (encapsulation-info-type next-info) type)
 169                  ;; This is it, so unlink us.
 170                  (setf (encapsulation-info-definition encap-info)
 171                        (encapsulation-info-definition next-info))
 172                  (return))
 173                (setf encap-info next-info))))))
 174   t)
 175
 176 ;;; Does NAME have an encapsulation of the given TYPE?
 177 (defun encapsulated-p (name type)
 178   (let ((fdefn (fdefinition-object name nil)))
 179     (do ((encap-info (encapsulation-info (fdefn-fun fdefn))
 180                      (encapsulation-info
 181                       (encapsulation-info-definition encap-info))))
 182         ((null encap-info) nil)
 183       (declare (type (or encapsulation-info null) encap-info))
 184       (when (eq (encapsulation-info-type encap-info) type)
 185         (return t)))))
 186 \f
 187 ;;;; FDEFINITION
 188
 189 ;;; KLUDGE: Er, it looks as though this means that
 190 ;;;    (FUNCALL (FDEFINITION 'FOO))
 191 ;;; doesn't do the same thing as
 192 ;;;    (FUNCALL 'FOO),
 193 ;;; and (SYMBOL-FUNCTION 'FOO) isn't in general the same thing
 194 ;;; as (FDEFINITION 'FOO). That doesn't look like ANSI behavior to me.
 195 ;;; Look e.g. at the ANSI definition of TRACE: "Whenever a traced
 196 ;;; function is invoked, information about the call, ..". Try this:
 197 ;;;   (DEFUN FOO () (PRINT "foo"))
 198 ;;;   (TRACE FOO)
 199 ;;;   (FUNCALL 'FOO)
 200 ;;;   (FUNCALL (FDEFINITION 'FOO))
 201 ;;; What to do? ANSI says TRACE "Might change the definitions of the
 202 ;;; functions named by function-names." Might it be OK to just get
 203 ;;; punt all this encapsulation stuff and go back to a simple but
 204 ;;; correct implementation of TRACE? We'd lose the ability to redefine
 205 ;;; a TRACEd function and keep the trace in place, but that seems
 206 ;;; tolerable to me. (Is the wrapper stuff needed for anything else
 207 ;;; besides TRACE?)
 208 ;;;
 209 ;;; The only problem I can see with not having a wrapper: If tracing
 210 ;;; EQ, EQL, EQUAL, or EQUALP causes its function address to change,
 211 ;;; it will mess up the MAKE-HASH-TABLE logic which uses EQ tests
 212 ;;; on those function values. But given the ANSI statement about
 213 ;;; TRACE causing things to change, that doesn't seem too unreasonable;
 214 ;;; and we might even be able to forbid tracing these functions.
 215 ;;; -- WHN 2001-11-02
 216 (defun fdefinition (name)
 217   #!+sb-doc
 218   "Return name's global function definition taking care to respect any
 219    encapsulations and to return the innermost encapsulated definition.
 220    This is SETF'able."
 221   (let ((fun (%coerce-name-to-fun name)))
 222     (loop
 223      (let ((encap-info (encapsulation-info fun)))
 224        (if encap-info
 225            (setf fun (encapsulation-info-definition encap-info))
 226            (return fun))))))
 227
 228 (defvar *setf-fdefinition-hook* nil
 229   #!+sb-doc
 230   "A list of functions that (SETF FDEFINITION) invokes before storing the
 231    new value. The functions take the function name and the new value.")
 232
 233 (defun %set-fdefinition (name new-value)
 234   #!+sb-doc
 235   "Set NAME's global function definition."
 236   (declare (type function new-value) (optimize (safety 1)))
 237   (with-single-package-locked-error (:symbol name "setting fdefinition of ~A")
 238
 239     ;; Check for hash-table stuff. Woe onto him that mixes encapsulation
 240     ;; with this.
 241     (when (and (symbolp name) (fboundp name)
 242                (boundp '*user-hash-table-tests*))
 243       (let ((old (symbol-function name)))
 244         (declare (special *user-hash-table-tests*))
 245         (dolist (spec *user-hash-table-tests*)
 246           (cond ((eq old (second spec))
 247                  ;; test-function
 248                  (setf (second spec) new-value))
 249                 ((eq old (third spec))
 250                  ;; hash-function
 251                  (setf (third spec) new-value))))))
 252
 253     ;; FIXME: This is a good hook to have, but we should probably
 254     ;; reserve it for users.
 255     (let ((fdefn (fdefinition-object name t)))
 256       ;; *SETF-FDEFINITION-HOOK* won't be bound when initially running
 257       ;; top level forms in the kernel core startup.
 258       (when (boundp '*setf-fdefinition-hook*)
 259         (dolist (f *setf-fdefinition-hook*)
 260           (declare (type function f))
 261           (funcall f name new-value)))
 262
 263       (let ((encap-info (encapsulation-info (fdefn-fun fdefn))))
 264         (cond (encap-info
 265                (loop
 266                 (let ((more-info
 267                        (encapsulation-info
 268                         (encapsulation-info-definition encap-info))))
 269                   (if more-info
 270                       (setf encap-info more-info)
 271                       (return
 272                         (setf (encapsulation-info-definition encap-info)
 273                               new-value))))))
 274               (t
 275                (setf (fdefn-fun fdefn) new-value)))))))
 276 \f
 277 ;;;; FBOUNDP and FMAKUNBOUND
 278
 279 (defun fboundp (name)
 280   #!+sb-doc
 281   "Return true if name has a global function definition."
 282   (let ((fdefn (fdefinition-object name nil)))
 283     (and fdefn (fdefn-fun fdefn) t)))
 284
 285 (defun fmakunbound (name)
 286   #!+sb-doc
 287   "Make NAME have no global function definition."
 288   (with-single-package-locked-error
 289       (:symbol name "removing the function or macro definition of ~A")
 290     (let ((fdefn (fdefinition-object name nil)))
 291       (when fdefn
 292         (fdefn-makunbound fdefn)))
 293     (sb!kernel:undefine-fun-name name)
 294     name))