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 \f
  26 ;;; Each implementation must provide the following functions and macros:
  27 ;;;
  28 ;;;    ALLOCATE-FUNCALLABLE-INSTANCE-1 ()
  29 ;;;       should create and return a new funcallable instance. The
  30 ;;;       funcallable-instance-data slots must be initialized to NIL.
  31 ;;;       This is called by allocate-funcallable-instance and by the
  32 ;;;       bootstrapping code.
  33 ;;;
  34 ;;;    FUNCALLABLE-INSTANCE-P (x)
  35 ;;;       the obvious predicate. This should be an INLINE function. It
  36 ;;;       must be funcallable, but it would be nice if it compiled open.
  37 ;;;
  38 ;;;    SET-FUNCALLABLE-INSTANCE-FUNCTION (fin new-value)
  39 ;;;       change the fin so that when it is funcalled, the new-value
  40 ;;;       function is called. Note that it is legal for new-value
  41 ;;;       to be copied before it is installed in the fin, specifically
  42 ;;;       there is no accessor for a FIN's function so this function
  43 ;;;       does not have to preserve the actual new value. The new-value
  44 ;;;       argument can be any funcallable thing, a closure, lambda
  45 ;;;       compiled code etc. This function must coerce those values
  46 ;;;       if necessary.
  47 ;;;       NOTE: new-value is almost always a compiled closure. This
  48 ;;;          is the important case to optimize.
  49 ;;;
  50 ;;;    FUNCALLABLE-INSTANCE-DATA-1 (fin data-name)
  51 ;;;       should return the value of the data named data-name in the fin.
  52 ;;;       data-name is one of the symbols in the list which is the value
  53 ;;;       of funcallable-instance-data. Since data-name is almost always
  54 ;;;       a quoted symbol and funcallable-instance-data is a constant, it
  55 ;;;       is possible (and worthwhile) to optimize the computation of
  56 ;;;       data-name's offset in the data part of the fin.
  57 ;;;       This must be SETF'able.
  58 \f
  59 ;;;; implementation of funcallable instances for CMU Common Lisp
  60
  61 (defstruct (pcl-funcallable-instance
  62             (:alternate-metaclass sb-kernel:funcallable-instance
  63                                   sb-kernel:random-pcl-class
  64                                   sb-kernel:make-random-pcl-class)
  65             (:type sb-kernel:funcallable-structure)
  66             (:constructor allocate-funcallable-instance-1 ())
  67             (:copier nil)
  68             (:conc-name nil))
  69   ;; Note: The PCL wrapper is in the layout slot.
  70
  71   ;; PCL data vector.
  72   (pcl-funcallable-instance-slots nil)
  73   ;; The debug-name for this function.
  74   (funcallable-instance-name nil))
  75
  76 (import 'sb-kernel:funcallable-instance-p)
  77
  78 ;;; Set the function that is called when FIN is called.
  79 (defun set-funcallable-instance-function (fin new-value)
  80   (declare (type function new-value))
  81   (assert (funcallable-instance-p fin))
  82   (setf (sb-kernel:funcallable-instance-function fin) new-value))
  83
  84 ;;; This "works" on non-PCL FINs, which allows us to weaken
  85 ;;; FUNCALLABLE-INSTANCE-P to return true for all FINs. This is also
  86 ;;; necessary for bootstrapping to work, since the layouts for early GFs are
  87 ;;; not initially initialized.
  88 (defmacro funcallable-instance-data-1 (fin slot)
  89   (ecase (eval slot)
  90     (wrapper `(sb-kernel:%funcallable-instance-layout ,fin))
  91     (slots `(sb-kernel:%funcallable-instance-info ,fin 0))))
  92 \f
  93 ;;;; slightly higher-level stuff built on the implementation-dependent stuff
  94
  95 (defmacro fsc-instance-p (fin)
  96   `(funcallable-instance-p ,fin))
  97
  98 (defmacro fsc-instance-class (fin)
  99   `(wrapper-class (funcallable-instance-data-1 ,fin 'wrapper)))
 100
 101 (defmacro fsc-instance-wrapper (fin)
 102   `(funcallable-instance-data-1 ,fin 'wrapper))
 103
 104 (defmacro fsc-instance-slots (fin)
 105   `(funcallable-instance-data-1 ,fin 'slots))