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 closure)
 124   (declare (closure closure))
 125   (do-closure-values (value closure)
 126     (when (funcall test value)
 127       (return value))))
 128
 129 ;;; Find the encapsulation info that has been closed over.
 130 (defun encapsulation-info (fun)
 131   (when (closurep fun)
 132     (find-if-in-closure #'encapsulation-info-p fun)))
 133
 134 ;;; When removing an encapsulation, we must remember that
 135 ;;; encapsulating definitions close over a reference to the
 136 ;;; ENCAPSULATION-INFO that describes the encapsulating definition.
 137 ;;; When you find an info with the target type, the previous info in
 138 ;;; the chain has the ensulating definition of that type. We take the
 139 ;;; encapsulated definition from the info with the target type, and we
 140 ;;; store it in the previous info structure whose encapsulating
 141 ;;; definition it describes looks to this previous info structure for
 142 ;;; a definition to bind (see ENCAPSULATE). When removing the first
 143 ;;; info structure, we do something conceptually equal, but
 144 ;;; mechanically it is different.
 145 (defun unencapsulate (name type)
 146   #!+sb-doc
 147   "Removes NAME's most recent encapsulation of the specified TYPE."
 148   (let* ((fdefn (fdefinition-object name nil))
 149          (encap-info (encapsulation-info (fdefn-fun fdefn))))
 150     (declare (type (or encapsulation-info null) encap-info))
 151     (cond ((not encap-info)
 152            ;; It disappeared on us, so don't worry about it.
 153            )
 154           ((eq (encapsulation-info-type encap-info) type)
 155            ;; It's the first one, so change the fdefn object.
 156            (setf (fdefn-fun fdefn)
 157                  (encapsulation-info-definition encap-info)))
 158           (t
 159            ;; It must be an interior one, so find it.
 160            (loop
 161              (let ((next-info (encapsulation-info
 162                                (encapsulation-info-definition encap-info))))
 163                (unless next-info
 164                  ;; Not there, so don't worry about it.
 165                  (return))
 166                (when (eq (encapsulation-info-type next-info) type)
 167                  ;; This is it, so unlink us.
 168                  (setf (encapsulation-info-definition encap-info)
 169                        (encapsulation-info-definition next-info))
 170                  (return))
 171                (setf encap-info next-info))))))
 172   t)
 173
 174 ;;; Does NAME have an encapsulation of the given TYPE?
 175 (defun encapsulated-p (name type)
 176   (let ((fdefn (fdefinition-object name nil)))
 177     (do ((encap-info (encapsulation-info (fdefn-fun fdefn))
 178                      (encapsulation-info
 179                       (encapsulation-info-definition encap-info))))
 180         ((null encap-info) nil)
 181       (declare (type (or encapsulation-info null) encap-info))
 182       (when (eq (encapsulation-info-type encap-info) type)
 183         (return t)))))
 184 \f
 185 ;;;; FDEFINITION
 186
 187 ;;; KLUDGE: Er, it looks as though this means that
 188 ;;;    (FUNCALL (FDEFINITION 'FOO))
 189 ;;; doesn't do the same thing as
 190 ;;;    (FUNCALL 'FOO),
 191 ;;; and (SYMBOL-FUNCTION 'FOO) isn't in general the same thing
 192 ;;; as (FDEFINITION 'FOO). That doesn't look like ANSI behavior to me.
 193 ;;; Look e.g. at the ANSI definition of TRACE: "Whenever a traced
 194 ;;; function is invoked, information about the call, ..". Try this:
 195 ;;;   (DEFUN FOO () (PRINT "foo"))
 196 ;;;   (TRACE FOO)
 197 ;;;   (FUNCALL 'FOO)
 198 ;;;   (FUNCALL (FDEFINITION 'FOO))
 199 ;;; What to do? ANSI says TRACE "Might change the definitions of the
 200 ;;; functions named by function-names." Might it be OK to just get
 201 ;;; punt all this encapsulation stuff and go back to a simple but
 202 ;;; correct implementation of TRACE? We'd lose the ability to redefine
 203 ;;; a TRACEd function and keep the trace in place, but that seems
 204 ;;; tolerable to me. (Is the wrapper stuff needed for anything else
 205 ;;; besides TRACE?)
 206 ;;;
 207 ;;; The only problem I can see with not having a wrapper: If tracing
 208 ;;; EQ, EQL, EQUAL, or EQUALP causes its function address to change,
 209 ;;; it will mess up the MAKE-HASH-TABLE logic which uses EQ tests
 210 ;;; on those function values. But given the ANSI statement about
 211 ;;; TRACE causing things to change, that doesn't seem too unreasonable;
 212 ;;; and we might even be able to forbid tracing these functions.
 213 ;;; -- WHN 2001-11-02
 214 (defun fdefinition (name)
 215   #!+sb-doc
 216   "Return name's global function definition taking care to respect any
 217    encapsulations and to return the innermost encapsulated definition.
 218    This is SETF'able."
 219   (let ((fun (%coerce-name-to-fun name)))
 220     (loop
 221      (let ((encap-info (encapsulation-info fun)))
 222        (if encap-info
 223            (setf fun (encapsulation-info-definition encap-info))
 224            (return fun))))))
 225
 226 (defvar *setf-fdefinition-hook* nil
 227   #!+sb-doc
 228   "A list of functions that (SETF FDEFINITION) invokes before storing the
 229    new value. The functions take the function name and the new value.")
 230
 231 (defun %set-fdefinition (name new-value)
 232   #!+sb-doc
 233   "Set NAME's global function definition."
 234   (declare (type function new-value) (optimize (safety 1)))
 235   (with-single-package-locked-error (:symbol name "setting fdefinition of ~A")
 236
 237     ;; Check for hash-table stuff. Woe onto him that mixes encapsulation
 238     ;; with this.
 239     (when (and (symbolp name) (fboundp name)
 240                (boundp '*user-hash-table-tests*))
 241       (let ((old (symbol-function name)))
 242         (declare (special *user-hash-table-tests*))
 243         (dolist (spec *user-hash-table-tests*)
 244           (cond ((eq old (second spec))
 245                  ;; test-function
 246                  (setf (second spec) new-value))
 247                 ((eq old (third spec))
 248                  ;; hash-function
 249                  (setf (third spec) new-value))))))
 250
 251     ;; FIXME: This is a good hook to have, but we should probably
 252     ;; reserve it for users.
 253     (let ((fdefn (fdefinition-object name t)))
 254       ;; *SETF-FDEFINITION-HOOK* won't be bound when initially running
 255       ;; top level forms in the kernel core startup.
 256       (when (boundp '*setf-fdefinition-hook*)
 257         (dolist (f *setf-fdefinition-hook*)
 258           (declare (type function f))
 259           (funcall f name new-value)))
 260
 261       (let ((encap-info (encapsulation-info (fdefn-fun fdefn))))
 262         (cond (encap-info
 263                (loop
 264                 (let ((more-info
 265                        (encapsulation-info
 266                         (encapsulation-info-definition encap-info))))
 267                   (if more-info
 268                       (setf encap-info more-info)
 269                       (return
 270                         (setf (encapsulation-info-definition encap-info)
 271                               new-value))))))
 272               (t
 273                (setf (fdefn-fun fdefn) new-value)))))))
 274 \f
 275 ;;;; FBOUNDP and FMAKUNBOUND
 276
 277 (defun fboundp (name)
 278   #!+sb-doc
 279   "Return true if name has a global function definition."
 280   (let ((fdefn (fdefinition-object name nil)))
 281     (and fdefn (fdefn-fun fdefn) t)))
 282
 283 (defun fmakunbound (name)
 284   #!+sb-doc
 285   "Make NAME have no global function definition."
 286   (with-single-package-locked-error
 287       (:symbol name "removing the function or macro definition of ~A")
 288     (let ((fdefn (fdefinition-object name nil)))
 289       (when fdefn
 290         (fdefn-makunbound fdefn)))
 291     (sb!kernel:undefine-fun-name name)
 292     name))