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