home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / fdefinition.lisp < prev    next >
Encoding:
Text File  |  1992-12-09  |  10.3 KB  |  277 lines
  1. ;;; -*- Package: Lisp; Log: code.log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: fdefinition.lisp,v 1.11.1.1 92/12/08 23:13:44 ram Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; Functions that hack on the global function namespace (primarily
  15. ;;; concerned with SETF functions here).  Also, function encapsulation
  16. ;;; and routines that set and return definitions disregarding whether
  17. ;;; they might be encapsulated.
  18. ;;;
  19. ;;; Written by Rob MacLachlan
  20. ;;; Modified by Bill Chiles (wrote encapsulation stuff) 
  21. ;;;
  22.  
  23. (in-package "EXTENSIONS")
  24.  
  25. (export '(encapsulate unencapsulate encapsulated-p encapsulated-definition
  26.       argument-list basic-definition *setf-fdefinition-hook*))
  27.  
  28.  
  29. (in-package "LISP")
  30.  
  31. (export '(fdefinition fboundp fmakunbound))
  32.  
  33.  
  34.  
  35. ;;; Introduction:
  36. ;;;
  37. ;;; Definitions for symbol names are stored and accessed with SYMBOL-FUNCTION.
  38. ;;; Definitions for (SETF FOO) style names are stored and accessed in
  39. ;;; *setf-functions*.  ENCAPSULATED-DEFINITION gets the stored definition of
  40. ;;; any name, and it is SETF'able.
  41. ;;;
  42. ;;; FDEFINITION retrieves the original definition of a name before any
  43. ;;; encapsulations were installed.  When you SETF this form, you change the
  44. ;;; original definition leaving all encapsulations untouched.
  45. ;;;
  46.  
  47. (defvar *setf-functions* (make-hash-table :test #'equal))
  48.  
  49. (eval-when (compile eval)
  50. (defmacro function-name-dispatch (name symbol-form setf-form)
  51.   `(typecase ,name
  52.      (symbol ,symbol-form)
  53.      (cons
  54.       (unless (and (eq (car ,name) 'setf)
  55.            (consp (cdr ,name))
  56.            (symbolp (cadr ,name)))
  57.     (error "Malformed function name: ~S." ,name))
  58.       ,setf-form)
  59.      (t
  60.       (error "Malformed function name: ~S." ,name))))
  61.  
  62. ) ;EVAL-WHEN
  63.  
  64. ;;; CHECKING-SYMBOL-FUNCTION  --  Internal
  65. ;;;
  66. ;;;    Do a safe SYMBOL-FUNCTION.  The guts of functions in this file are
  67. ;;; normally compiled unsafe.
  68. ;;;
  69. (declaim (inline checking-symbol-function))
  70. (defun checking-symbol-function (x)
  71.   (declare (optimize (safety 1)))
  72.   (symbol-function x))
  73.  
  74.  
  75. ;;;; Definition Encapsulation.
  76.  
  77. ;;; ENCAPSULATED-DEFINITION -- Public.
  78. ;;;
  79. (defun encapsulated-definition (name)
  80.   "Returns whatever definition is stored for name, regardless of whether it is
  81.    encapsulated.  This is SETF'able."
  82.   (function-name-dispatch name
  83.     (checking-symbol-function name)
  84.     (gethash (cadr name) *setf-functions*)))
  85. ;;;
  86. (defun %set-encapsulated-definition (name value)
  87.   (check-type value function)
  88.   (function-name-dispatch name
  89.     (setf (symbol-function name) value)
  90.     (setf (gethash (cadr name) *setf-functions*) value)))
  91. ;;;
  92. (defsetf encapsulated-definition %set-encapsulated-definition)
  93.  
  94.  
  95. (defstruct (encapsulation-info (:print-function print-encapsulation-info)
  96.                    (:constructor make-encapsulation-info
  97.                          (type definition next)))
  98.   ;; This is definition's encapsulation type.  The encapsulated definition is
  99.   ;; in the previous encapsulation-info element or installed as the global
  100.   ;; definition of some function name.
  101.   type
  102.   ;; Previous definition.  This used to be installed as a global definition
  103.   ;; for some function name, but it was replaced by an encapsulation of type
  104.   ;; type.
  105.   (definition nil :type function)
  106.   ;; If definition is an encapsulation, then this points to the information
  107.   ;; about it (what's its type and what definition was encapsulated).
  108.   (next nil :type (or null encapsulation-info)))
  109. ;;;
  110. (defun print-encapsulation-info (obj str n)
  111.   (declare (ignore n))
  112.   (format str "#<Encapsulation-Info  Definition: ~S  Type: ~S>"
  113.       (%function-header-name (encapsulation-info-definition obj))
  114.       (encapsulation-info-type obj)))
  115.  
  116. ;;; This maps function names to encapsulation-infos.
  117. ;;;
  118. (defvar *encapsulation-info* (make-hash-table :test #'equal))
  119.  
  120. ;;; ENCAPSULATE -- Public.
  121. ;;;
  122. ;;; We must bind and close over info.  Consider the case where we encapsulate
  123. ;;; (the second) an encapsulated (the first) definition, and later someone
  124. ;;; unencapsulates the encapsulated (first) definition.  We don't want our
  125. ;;; encapsulation (second) to bind basic-definition to the encapsulated (first)
  126. ;;; definition when it no longer exists.  When unencapsulating, we make sure to
  127. ;;; clobber the appropriate info structure to allow basic-definition to be
  128. ;;; bound to the next definition instead of an encapsulation that no longer
  129. ;;; exists.
  130. ;;;
  131. (defun encapsulate (name type body)
  132.   "Replaces the definition of name with a function that binds name's arguments
  133.    a variable named argument-list, binds name's definition to a variable named
  134.    basic-definition, and EVAL's body in that context.  Type is whatever you
  135.    would like to associate with this encapsulation for identification in case
  136.    you need multiple encapsuations of the same name."
  137.   (unless (fboundp name)
  138.     (error "~S has no function definition." name))
  139.   (let ((info (make-encapsulation-info type (encapsulated-definition name)
  140.                        (gethash name *encapsulation-info*))))
  141.     (setf (gethash name *encapsulation-info*) info)
  142.     (setf (encapsulated-definition name)
  143.       #'(lambda (&rest argument-list)
  144.           (declare (special argument-list))
  145.           (let ((basic-definition (encapsulation-info-definition info)))
  146.         (declare (special basic-definition))
  147.         (eval body)))))
  148.   name)
  149.  
  150. ;;; UNENCAPSULATE -- Public.
  151. ;;;
  152. ;;; When removing an encapsulation, we must remember that encapsulating
  153. ;;; definitions close over a reference to the encapsulation-info that describes
  154. ;;; the encapsulating definition.  When you find an info with the target type,
  155. ;;; the previous info in the chain has the ensulating definition of that type.
  156. ;;; We take the encapsulated definition from the info with the target type, and
  157. ;;; we store it in the previous info structure whose encapsulating definition
  158. ;;; it describes looks to this previous info structure for a definition to
  159. ;;; bind (see ENCAPSULATE).  Then we store the next pointer from the info with
  160. ;;; the target type into the next slot of the previous info structure.  When
  161. ;;; removing the first info structure, we do something conceptually equal, but
  162. ;;; mechanically it is different.
  163. ;;;
  164. (defun unencapsulate (name type)
  165.   "Removes name's most recent encapsulation of the specified type."
  166.   (let ((encap-info (gethash name *encapsulation-info*)))
  167.     (declare (type (or encapsulation-info null) encap-info))
  168.     (cond ((not encap-info))
  169.       ;; Is it the first one?
  170.       ((eq (encapsulation-info-type encap-info) type)
  171.        (setf (encapsulated-definition name)
  172.          (encapsulation-info-definition encap-info))
  173.        (setf (gethash name *encapsulation-info*)
  174.          (encapsulation-info-next encap-info)))
  175.       (t
  176.        (let ((prev encap-info))
  177.          (setf encap-info (encapsulation-info-next encap-info))  
  178.          (loop
  179.            (unless encap-info (return))
  180.            (when (eq (encapsulation-info-type encap-info) type)
  181.          (setf (encapsulation-info-definition prev)
  182.                (encapsulation-info-definition encap-info))
  183.          (setf (encapsulation-info-next prev)
  184.                (encapsulation-info-next encap-info))
  185.          (return))
  186.            (setf prev encap-info)
  187.            (setf encap-info (encapsulation-info-next encap-info)))))))
  188.   t)
  189.  
  190. ;;; ENCAPSULATED-P -- Public.
  191. ;;;
  192. (defun encapsulated-p (name type)
  193.   "Returns t if name has an encapsulation of the given type, otherwise nil."
  194.   (let ((encap-info (gethash name *encapsulation-info*)))
  195.     (if encap-info
  196.     (loop
  197.       (when (not (encapsulation-info-next encap-info))
  198.         (return nil))
  199.       (when (eq (encapsulation-info-type encap-info) type)
  200.         (return t))
  201.       (setf encap-info (encapsulation-info-next encap-info))))))
  202.  
  203.  
  204.  
  205. ;;;; FDEFINITION.
  206.  
  207. (defun fdefinition (name)
  208.   "Return name's global function definition taking care to regard any
  209.    encapsulations and to return the innermost encapsulated definition.
  210.    This is SETF'able."
  211.   (macrolet ((basic-def (name fetch)
  212.            `(let ((encap-info (gethash ,name *encapsulation-info*)))
  213.           (if encap-info
  214.               (loop
  215.             (when (not (encapsulation-info-next encap-info))
  216.               (return (encapsulation-info-definition encap-info)))
  217.             (setf encap-info (encapsulation-info-next encap-info)))
  218.               ,fetch))))
  219.     (function-name-dispatch name
  220.       (basic-def name (checking-symbol-function name))
  221.       (basic-def name (or (gethash (cadr name) *setf-functions*)
  222.               (error "Undefined function: ~S." name))))))
  223.  
  224. (defvar *setf-fdefinition-hook* nil
  225.   "This holds functions that (SETF FDEFINITION) invokes before storing the
  226.    new value.  These functions take the function name and the new value.")
  227.  
  228. (defun %set-fdefinition (name new-value)
  229.   "Set name's global function definition."
  230.   (declare (type function new-value) (optimize (safety 1)))
  231.   (macrolet ((set-basic-def (name new-value form)
  232.            ;; *encapsulation-info* won't be bound when initially running
  233.            ;; top-level forms in the kernel core startup.
  234.            `(let ((encap-info (if (boundp '*encapsulation-info*)
  235.                       (gethash ,name *encapsulation-info*))))
  236.           (cond (encap-info
  237.              (loop
  238.                (when (not (encapsulation-info-next encap-info))
  239.                  (return
  240.                   (setf (encapsulation-info-definition encap-info)
  241.                     ,new-value)))
  242.                (setf encap-info
  243.                  (encapsulation-info-next encap-info))))
  244.             (t
  245.              (setf ,form ,new-value))))))
  246.  
  247.     ;; *setf-fdefinition-hook* won't be bound when initially running top-level
  248.     ;; forms in the kernel core startup.
  249.     (when (boundp '*setf-fdefinition-hook*)
  250.       (dolist (f *setf-fdefinition-hook*)
  251.     (funcall f name new-value)))
  252.  
  253.     (function-name-dispatch name
  254.       (set-basic-def name new-value (symbol-function name))
  255.       ;; We make sure no SETF definitions exist before the DEFVAR for
  256.       ;; *setf-functions* runs in the kernel core.
  257.       (set-basic-def name new-value (gethash (cadr name) *setf-functions*)))))
  258. ;;;
  259. (defsetf fdefinition %set-fdefinition)
  260.  
  261.  
  262.  
  263. ;;;; FBOUNDP and FMAKUNBOUND.
  264.  
  265. (defun fboundp (name)
  266.   "Return true if name has a global function definition."
  267.   (function-name-dispatch name
  268.     (fboundp (the symbol name))
  269.     (functionp (gethash (cadr name) *setf-functions*))))
  270.  
  271. (defun fmakunbound (name)
  272.   "Make Name have no global function definition."
  273.   (function-name-dispatch name
  274.     (fmakunbound (the symbol name))
  275.     (remhash (cadr name) *setf-functions*))
  276.   name)
  277.