0.6.11.16:
[sbcl.git] / 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))