src/pcl/fin.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3
   4 ;;;; This software is derived from software originally released by Xerox
   5 ;;;; Corporation. Copyright and release statements follow. Later modifications
   6 ;;;; to the software are in the public domain and are provided with
   7 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
   8 ;;;; information.
   9
  10 ;;;; copyright information from original PCL sources:
  11 ;;;;
  12 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  13 ;;;; All rights reserved.
  14 ;;;;
  15 ;;;; Use and copying of this software and preparation of derivative works based
  16 ;;;; upon this software are permitted. Any distribution of this software or
  17 ;;;; derivative works must comply with all applicable United States export
  18 ;;;; control laws.
  19 ;;;;
  20 ;;;; This software is made available AS IS, and Xerox Corporation makes no
  21 ;;;; warranty about the software, its performance or its conformity to any
  22 ;;;; specification.
  23
  24 (in-package "SB-PCL")
  25
  26 (sb-int:file-comment
  27   "$Header$")
  28 \f
  29 ;;; Each implementation must provide the following functions and macros:
  30 ;;;
  31 ;;;    ALLOCATE-FUNCALLABLE-INSTANCE-1 ()
  32 ;;;       should create and return a new funcallable instance. The
  33 ;;;       funcallable-instance-data slots must be initialized to NIL.
  34 ;;;       This is called by allocate-funcallable-instance and by the
  35 ;;;       bootstrapping code.
  36 ;;;
  37 ;;;    FUNCALLABLE-INSTANCE-P (x)
  38 ;;;       the obvious predicate. This should be an INLINE function. It
  39 ;;;       must be funcallable, but it would be nice if it compiled open.
  40 ;;;
  41 ;;;    SET-FUNCALLABLE-INSTANCE-FUNCTION (fin new-value)
  42 ;;;       change the fin so that when it is funcalled, the new-value
  43 ;;;       function is called. Note that it is legal for new-value
  44 ;;;       to be copied before it is installed in the fin, specifically
  45 ;;;       there is no accessor for a FIN's function so this function
  46 ;;;       does not have to preserve the actual new value. The new-value
  47 ;;;       argument can be any funcallable thing, a closure, lambda
  48 ;;;       compiled code etc. This function must coerce those values
  49 ;;;       if necessary.
  50 ;;;       NOTE: new-value is almost always a compiled closure. This
  51 ;;;          is the important case to optimize.
  52 ;;;
  53 ;;;    FUNCALLABLE-INSTANCE-DATA-1 (fin data-name)
  54 ;;;       should return the value of the data named data-name in the fin.
  55 ;;;       data-name is one of the symbols in the list which is the value
  56 ;;;       of funcallable-instance-data. Since data-name is almost always
  57 ;;;       a quoted symbol and funcallable-instance-data is a constant, it
  58 ;;;       is possible (and worthwhile) to optimize the computation of
  59 ;;;       data-name's offset in the data part of the fin.
  60 ;;;       This must be SETF'able.
  61 \f
  62 ;;;; implementation of funcallable instances for CMU Common Lisp
  63
  64 (defstruct (pcl-funcallable-instance
  65             (:alternate-metaclass sb-kernel:funcallable-instance
  66                                   sb-kernel:random-pcl-class
  67                                   sb-kernel:make-random-pcl-class)
  68             (:type sb-kernel:funcallable-structure)
  69             (:constructor allocate-funcallable-instance-1 ())
  70             (:copier nil)
  71             (:conc-name nil))
  72   ;; Note: The PCL wrapper is in the layout slot.
  73
  74   ;; PCL data vector.
  75   (pcl-funcallable-instance-slots nil)
  76   ;; The debug-name for this function.
  77   (funcallable-instance-name nil))
  78
  79 (import 'sb-kernel:funcallable-instance-p)
  80
  81 ;;; Set the function that is called when FIN is called.
  82 (defun set-funcallable-instance-function (fin new-value)
  83   (declare (type function new-value))
  84   (assert (funcallable-instance-p fin))
  85   (setf (sb-kernel:funcallable-instance-function fin) new-value))
  86
  87 ;;; This "works" on non-PCL FINs, which allows us to weaken
  88 ;;; FUNCALLABLE-INSTANCE-P to return true for all FINs. This is also
  89 ;;; necessary for bootstrapping to work, since the layouts for early GFs are
  90 ;;; not initially initialized.
  91 (defmacro funcallable-instance-data-1 (fin slot)
  92   (ecase (eval slot)
  93     (wrapper `(sb-kernel:%funcallable-instance-layout ,fin))
  94     (slots `(sb-kernel:%funcallable-instance-info ,fin 0))))
  95 \f
  96 ;;;; slightly higher-level stuff built on the implementation-dependent stuff
  97
  98 (defmacro fsc-instance-p (fin)
  99   `(funcallable-instance-p ,fin))
 100
 101 (defmacro fsc-instance-class (fin)
 102   `(wrapper-class (funcallable-instance-data-1 ,fin 'wrapper)))
 103
 104 (defmacro fsc-instance-wrapper (fin)
 105   `(funcallable-instance-data-1 ,fin 'wrapper))
 106
 107 (defmacro fsc-instance-slots (fin)
 108   `(funcallable-instance-data-1 ,fin 'slots))