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