/[cmucl]/src/pcl/fin.lisp
ViewVC logotype

Contents of /src/pcl/fin.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (hide annotations)
Sun Aug 12 03:46:38 1990 UTC (23 years, 8 months ago) by wlott
Branch: MAIN
Initial revision
1 wlott 1.1 ;;;-*-Mode:LISP; Package:(PCL Lisp 1000); Base:10; Syntax:Common-lisp -*-
2     ;;;
3     ;;; *************************************************************************
4     ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
5     ;;; All rights reserved.
6     ;;;
7     ;;; Use and copying of this software and preparation of derivative works
8     ;;; based upon this software are permitted. Any distribution of this
9     ;;; software or derivative works must comply with all applicable United
10     ;;; States export control laws.
11     ;;;
12     ;;; This software is made available AS IS, and Xerox Corporation makes no
13     ;;; warranty about the software, its performance or its conformity to any
14     ;;; specification.
15     ;;;
16     ;;; Any person obtaining a copy of this software is requested to send their
17     ;;; name and post office or electronic mail address to:
18     ;;; CommonLoops Coordinator
19     ;;; Xerox PARC
20     ;;; 3333 Coyote Hill Rd.
21     ;;; Palo Alto, CA 94304
22     ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
23     ;;;
24     ;;; Suggestions, comments and requests for improvements are also welcome.
25     ;;; *************************************************************************
26     ;;;
27    
28     ;;
29     ;;;;;; FUNCALLABLE INSTANCES
30     ;;
31    
32     #|
33    
34     Generic functions are instances with meta class funcallable-standard-class.
35     Instances with this meta class are called funcallable-instances (FINs for
36     short). They behave something like lexical closures in that they have data
37     associated with them (which is used to store the slots) and are funcallable.
38     When a funcallable instance is funcalled, the function that is invoked is
39     called the funcallable-instance-function. The funcallable-instance-function
40     of a funcallable instance can be changed.
41    
42     This file implements low level code for manipulating funcallable instances.
43    
44     It is possible to implement funcallable instances in pure Common Lisp. A
45     simple implementation which uses lexical closures as the instances and a
46     hash table to record that the lexical closures are funcallable instances
47     is easy to write. Unfortunately, this implementation adds significant
48     overhead:
49    
50     to generic-function-invocation (1 function call)
51     to slot-access (1 function call or one hash table lookup)
52     to class-of a generic-function (1 hash-table lookup)
53    
54     In addition, it would prevent the funcallable instances from being garbage
55     collected. In short, the pure Common Lisp implementation really isn't
56     practical.
57    
58     Instead, PCL uses a specially tailored implementation for each Common Lisp and
59     makes no attempt to provide a purely portable implementation. The specially
60     tailored implementations are based on the lexical closure's provided by that
61     implementation and are fairly short and easy to write.
62    
63     Some of the implementation dependent code in this file was originally written
64     by someone in the employ of the vendor of that Common Lisp. That code is
65     explicitly marked saying who wrote it.
66    
67     |#
68    
69     (in-package 'pcl)
70    
71     ;;;
72     ;;; The first part of the file contains the implementation dependent code to
73     ;;; implement funcallable instances. Each implementation must provide the
74     ;;; following functions and macros:
75     ;;;
76     ;;; ALLOCATE-FUNCALLABLE-INSTANCE-1 ()
77     ;;; should create and return a new funcallable instance. The
78     ;;; funcallable-instance-data slots must be initialized to NIL.
79     ;;; This is called by allocate-funcallable-instance and by the
80     ;;; bootstrapping code.
81     ;;;
82     ;;; FUNCALLABLE-INSTANCE-P (x)
83     ;;; the obvious predicate. This should be an INLINE function.
84     ;;; it must be funcallable, but it would be nice if it compiled
85     ;;; open.
86     ;;;
87     ;;; SET-FUNCALLABLE-INSTANCE-FUNCTION (fin new-value)
88     ;;; change the fin so that when it is funcalled, the new-value
89     ;;; function is called. Note that it is legal for new-value
90     ;;; to be copied before it is installed in the fin, specifically
91     ;;; there is no accessor for a FIN's function so this function
92     ;;; does not have to preserve the actual new value. The new-value
93     ;;; argument can be any funcallable thing, a closure, lambda
94     ;;; compiled code etc. This function must coerce those values
95     ;;; if necessary.
96     ;;; NOTE: new-value is almost always a compiled closure. This
97     ;;; is the important case to optimize.
98     ;;;
99     ;;; FUNCALLABLE-INSTANCE-DATA-1 (fin data-name)
100     ;;; should return the value of the data named data-name in the fin.
101     ;;; data-name is one of the symbols in the list which is the value
102     ;;; of funcallable-instance-data. Since data-name is almost always
103     ;;; a quoted symbol and funcallable-instance-data is a constant, it
104     ;;; is possible (and worthwhile) to optimize the computation of
105     ;;; data-name's offset in the data part of the fin.
106     ;;; This must be SETF'able.
107     ;;;
108    
109     (defconstant funcallable-instance-data
110     '(wrapper slots)
111     "These are the 'data-slots' which funcallable instances have so that
112     the meta-class funcallable-standard-class can store class, and static
113     slots in them.")
114    
115     (defmacro funcallable-instance-data-position (data)
116     (if (and (consp data)
117     (eq (car data) 'quote)
118     (boundp 'funcallable-instance-data))
119     (or (position (cadr data) funcallable-instance-data :test #'eq)
120     (progn
121     (warn "Unknown funcallable-instance data: ~S." (cadr data))
122     `(error "Unknown funcallable-instance data: ~S." ',(cadr data))))
123     `(position ,data funcallable-instance-data :test #'eq)))
124    
125     (defun called-fin-without-function ()
126     (error "Attempt to funcall a funcallable-instance without first~%~
127     setting its funcallable-instance-function."))
128    
129    
130    
131    
132     ;;;
133     ;;; In Lucid Lisp, compiled functions and compiled closures have the same
134     ;;; representation. They are called procedures. A procedure is a basically
135     ;;; just a constants vector, with one slot which points to the CODE. This
136     ;;; means that constants and closure variables are intermixed in the procedure
137     ;;; vector.
138     ;;;
139     ;;; This code was largely written by JonL@Lucid.com. Problems with it should
140     ;;; be referred to him.
141     ;;;
142     #+Lucid
143     (progn
144    
145     (defconstant procedure-is-funcallable-instance-bit-position 10)
146    
147     (defconstant fin-trampoline-fun-index lucid::procedure-literals)
148    
149     (defconstant fin-size (+ fin-trampoline-fun-index
150     (length funcallable-instance-data)
151     1))
152    
153     ;;;
154     ;;; The inner closure of this function will have its code vector replaced
155     ;;; by a hand-coded fast jump to the function that is stored in the
156     ;;; captured-lexical variable. In effect, that code is a hand-
157     ;;; optimized version of the code for this inner closure function.
158     ;;;
159     (defun make-trampoline (function)
160     (declare (optimize (speed 3) (safety 0)))
161     #'(lambda (&rest args)
162     (apply function args)))
163    
164     (eval-when (eval)
165     (compile 'make-trampoline)
166     )
167    
168    
169     (defun binary-assemble (codes)
170     (let* ((ncodes (length codes))
171     (code-vec #-LCL3.0 (lucid::new-code ncodes)
172     #+LCL3.0 (lucid::with-current-area
173     lucid::*READONLY-NON-POINTER-AREA*
174     (lucid::new-code ncodes))))
175     (declare (fixnum ncodes))
176     (do ((l codes (cdr l))
177     (i 0 (1+ i)))
178     ((null l) nil)
179     (declare (fixnum i))
180     (setf (lucid::code-ref code-vec i) (car l)))
181     code-vec))
182    
183     ;;;
184     ;;; Egad! Binary patching!
185     ;;; See comment following definition of MAKE-TRAMPOLINE -- this is just
186     ;;; the "hand-optimized" machine instructions to make it work.
187     ;;;
188     (defvar *mattress-pad-code*
189     (binary-assemble
190     #+MC68000
191     '(#x2A6D #x11 #x246D #x1 #x4EEA #x5)
192     #+SPARC
193     (ecase (lucid::procedure-length #'lucid::false)
194     (5
195     '(#xFA07 #x6012 #xDE07 #x7FFE #x81C3 #xFFFE #x100 #x0))
196     (8
197     `(#xFA07 #x601E #xDE07 #x7FFE #x81C3 #xFFFE #x100 #x0)))
198     #+(and BSP (not LCL3.0 ))
199     '(#xCD33 #x11 #xCDA3 #x1 #xC19A #x5 #xE889)
200     #+(and BSP LCL3.0)
201     '(#x7733 #x7153 #xC155 #x5 #xE885)
202     #+I386
203     '(#x87 #xD2 #x8B #x76 #xE #xFF #x66 #xFE)
204     #+VAX
205     '(#xD0 #xAC #x11 #x5C #xD0 #xAC #x1 #x57 #x17 #xA7 #x5)
206     #+PA
207     '(#x4891 #x3C #xE461 #x6530 #x48BF #x3FF9)
208     #-(or MC68000 SPARC BSP I386 VAX PA)
209     '(0 0 0 0)))
210    
211    
212     (lucid::defsubst funcallable-instance-p (x)
213     (and (lucid::procedurep x)
214     (lucid::logbitp& procedure-is-funcallable-instance-bit-position
215     (lucid::procedure-ref x lucid::procedure-flags))))
216    
217     (lucid::defsubst set-funcallable-instance-p (x)
218     (if (not (lucid::procedurep x))
219     (error "Can't make a non-procedure a fin.")
220     (setf (lucid::procedure-ref x lucid::procedure-flags)
221     (logior (expt 2 procedure-is-funcallable-instance-bit-position)
222     (the fixnum
223     (lucid::procedure-ref x lucid::procedure-flags))))))
224    
225    
226     (defun allocate-funcallable-instance-1 ()
227     #+Prime
228     (declare (notinline lucid::new-procedure)) ;fixes a bug in Prime 1.0 in
229     ;which new-procedure expands
230     ;incorrectly
231     (let ((new-fin (lucid::new-procedure fin-size))
232     (fin-index fin-size))
233     (declare (fixnum fin-index)
234     (type lucid::procedure new-fin))
235     (dotimes (i (length funcallable-instance-data))
236     ;; Initialize the new funcallable-instance. As part of our contract,
237     ;; we have to make sure the initial value of all the funcallable
238     ;; instance data slots is NIL.
239     (decf fin-index)
240     (setf (lucid::procedure-ref new-fin fin-index) nil))
241     ;;
242     ;; "Assemble" the initial function by installing a fast "trampoline" code;
243     ;;
244     (setf (lucid::procedure-ref new-fin lucid::procedure-code)
245     *mattress-pad-code*)
246     ;; Disable argcount checking in the "mattress-pad" code for
247     ;; ports that go through standardized trampolines
248     #+PA (setf (sys:procedure-ref new-fin lucid::procedure-arg-count) -1)
249     #+MIPS (progn
250     (setf (sys:procedure-ref new-fin lucid::procedure-min-args) 0)
251     (setf (sys:procedure-ref new-fin lucid::procedure-max-args)
252     call-arguments-limit))
253     ;; but start out with the function to be run as an error call.
254     (setf (lucid::procedure-ref new-fin fin-trampoline-fun-index)
255     #'called-fin-without-function)
256     ;; Then mark it as a "fin"
257     (set-funcallable-instance-p new-fin)
258     new-fin))
259    
260     (defun set-funcallable-instance-function (fin new-value)
261     (unless (funcallable-instance-p fin)
262     (error "~S is not a funcallable-instance" fin))
263     (if (lucid::procedurep new-value)
264     (progn
265     (setf (lucid::procedure-ref fin fin-trampoline-fun-index) new-value)
266     fin)
267     (progn
268     (unless (functionp new-value)
269     (error "~S is not a function." new-value))
270     ;; 'new-value' is an interpreted function. Install a
271     ;; trampoline to call the interpreted function.
272     (set-funcallable-instance-function fin
273     (make-trampoline new-value)))))
274    
275     (defmacro funcallable-instance-data-1 (instance data)
276     `(lucid::procedure-ref
277     ,instance
278     (the fixnum
279     (- (- fin-size 1)
280     (the fixnum (funcallable-instance-data-position ,data))))))
281    
282     );end of #+Lucid
283    
284    
285     ;;;
286     ;;; In Symbolics Common Lisp, a lexical closure is a pair of an environment
287     ;;; and an ordinary compiled function. The environment is represented as
288     ;;; a CDR-coded list. I know of no way to add a special bit to say that the
289     ;;; closure is a FIN, so for now, closures are marked as FINS by storing a
290     ;;; special marker in the last cell of the environment.
291     ;;;
292     ;;; The new structure of a fin is:
293     ;;; (lex-env lex-fun *marker* fin-data0 fin-data1)
294     ;;; The value returned by allocate is a lexical-closure pointing to the start
295     ;;; of the fin list. Benefits are: no longer ever have to copy environments,
296     ;;; fins can be much smaller (5 words instead of 18), old environments never
297     ;;; get destroyed (so running dcodes dont have the lex env change from under
298     ;;; them any longer).
299     ;;;
300     ;;; Most of the fin operations speed up a little (by as much as 30% on a
301     ;;; 3650), at least one nasty bug is fixed, and so far at least I've not
302     ;;; seen any problems at all with this code. - mike thome (mthome@bbn.com)
303     ;;;
304     #+Genera
305     (progn
306    
307     (defvar *funcallable-instance-marker* (list "Funcallable Instance Marker"))
308    
309     (defun allocate-funcallable-instance-1 ()
310     (let* ((whole-fin (make-list (+ 3 (length funcallable-instance-data))))
311     (new-fin (sys:%make-pointer-offset sys:dtp-lexical-closure
312     whole-fin
313     0)))
314     ;;
315     ;; note that we DO NOT turn the real lex-closure part of the fin into
316     ;; a dotted pair, because (1) the machine doesn't care and (2) if we
317     ;; did the garbage collector would reclaim everything after the lexical
318     ;; function.
319     ;;
320     (setf (sys:%p-contents-offset new-fin 2) *funcallable-instance-marker*)
321     (setf (si:lexical-closure-function new-fin)
322     #'(lambda (ignore &rest ignore-them-too)
323     (declare (ignore ignore ignore-them-too))
324     (called-fin-without-function)))
325     #+ignore
326     (setf (si:lexical-closure-environment new-fin) nil)
327     new-fin))
328    
329     (scl:defsubst funcallable-instance-p (x)
330     (declare (inline si:lexical-closure-p))
331     (and (si:lexical-closure-p x)
332     (= (sys:%p-cdr-code (sys:%make-pointer-offset sys:dtp-compiled-function x 1))
333     sys:cdr-next)
334     (eq (sys:%p-contents-offset x 2) *funcallable-instance-marker*)))
335    
336     (defun set-funcallable-instance-function (fin new-value)
337     (cond ((not (funcallable-instance-p fin))
338     (error "~S is not a funcallable-instance" fin))
339     ((not (or (functionp new-value)
340     (and (consp new-value)
341     (eq (car new-value) 'si:digested-lambda))))
342     (error "~S is not a function." new-value))
343     ((and (si:lexical-closure-p new-value)
344     (compiled-function-p (si:lexical-closure-function new-value)))
345     (let ((env (si:lexical-closure-environment new-value))
346     (fn (si:lexical-closure-function new-value)))
347     ;; we only have to copy the pointers!!
348     (setf (si:lexical-closure-environment fin) env
349     (si:lexical-closure-function fin) fn)
350     ; (dbg:set-env->fin env fin)
351     ))
352     (t
353     (set-funcallable-instance-function fin
354     (make-trampoline new-value)))))
355    
356     (defun make-trampoline (function)
357     #'(lambda (&rest args)
358     (apply function args)))
359    
360     (defmacro funcallable-instance-data-1 (fin data)
361     `(sys:%p-contents-offset ,fin
362     (+ 3 (funcallable-instance-data-position ,data))))
363    
364     (defsetf funcallable-instance-data-1 (fin data) (new-value)
365     `(setf (sys:%p-contents-offset ,fin
366     (+ 3 (funcallable-instance-data-position ,data)))
367     ,new-value))
368    
369     ;;;
370     ;;; Make funcallable instances print out properly.
371     ;;;
372     (defvar *old-print-lexical-closure*)
373    
374     (defvar *print-lexical-closure* nil)
375    
376     (defun pcl-print-lexical-closure (exp stream slashify-p &optional (depth 0))
377     (declare (ignore depth))
378     (if (or (eq *print-lexical-closure* exp)
379     (neq *boot-state* 'complete)
380     (eq (class-of exp) *the-class-t*))
381     (let ((*print-lexical-closure* nil))
382     (funcall *old-print-lexical-closure* exp stream slashify-p))
383     (let ((*print-escape* slashify-p)
384     (*print-lexical-closure* exp))
385     (print-object exp stream))))
386    
387     (eval-when (load eval)
388     (unless (boundp '*old-print-lexical-closure*)
389     (setq *old-print-lexical-closure* #'si:print-lexical-closure)
390     (setf (symbol-function 'si:print-lexical-closure)
391     'pcl-print-lexical-closure)))
392    
393    
394     );end of #+Genera
395    
396    
397    
398     ;;;
399     ;;;
400     ;;; In Xerox Common Lisp, a lexical closure is a pair of an environment and
401     ;;; CCODEP. The environment is represented as a block. There is space in
402     ;;; the top 8 bits of the pointers to the CCODE and the environment to use
403     ;;; to mark the closure as being a FIN.
404     ;;;
405     ;;; To help the debugger figure out when it has found a FIN on the stack, we
406     ;;; reserve the last element of the closure environment to use to point back
407     ;;; to the actual fin.
408     ;;;
409     ;;; Note that there is code in xerox-low which lets us access the fields of
410     ;;; compiled-closures and which defines the closure-overlay record. That
411     ;;; code is there because there are some clients of it in that file.
412     ;;;
413     #+Xerox
414     (progn
415    
416     ;; Don't be fooled. We actually allocate one bigger than this to have a place
417     ;; to store the backpointer to the fin. -smL
418     (defconstant funcallable-instance-closure-size 15)
419    
420     ;; This is only used in the file PCL-ENV.
421     (defvar *fin-env-type*
422     (type-of (il:\\allocblock (1+ funcallable-instance-closure-size) t)))
423    
424     ;; Well, Gregor may be too proud to hack xpointers, but bvm and I aren't. -smL
425    
426     (defstruct fin-env-pointer
427     (pointer nil :type il:fullxpointer))
428    
429     (defun fin-env-fin (fin-env)
430     (fin-env-pointer-pointer
431     (il:\\getbaseptr fin-env (* funcallable-instance-closure-size 2))))
432    
433     (defun |set fin-env-fin| (fin-env new-value)
434     (il:\\rplptr fin-env (* funcallable-instance-closure-size 2)
435     (make-fin-env-pointer :pointer new-value))
436     new-value)
437    
438     (defsetf fin-env-fin |set fin-env-fin|)
439    
440     ;; The finalization function that will clean up the backpointer from the
441     ;; fin-env to the fin. This needs to be careful to not cons at all. This
442     ;; depends on there being no other finalization function on compiled-closures,
443     ;; since there is only one finalization function per datatype. Too bad. -smL
444     (defun finalize-fin (fin)
445     ;; This could use the fn funcallable-instance-p, but if we get here we know
446     ;; that this is a closure, so we can skip that test.
447     (when (il:fetch (closure-overlay funcallable-instance-p) il:of fin)
448     (let ((env (il:fetch (il:compiled-closure il:environment) il:of fin)))
449     (when env
450     (setq env
451     (il:\\getbaseptr env (* funcallable-instance-closure-size 2)))
452     (when (il:typep env 'fin-env-pointer)
453     (setf (fin-env-pointer-pointer env) nil)))))
454     nil) ;Return NIL so GC can proceed
455    
456     (eval-when (load)
457     ;; Install the above finalization function.
458     (when (fboundp 'finalize-fin)
459     (il:\\set.finalization.function 'il:compiled-closure 'finalize-fin)))
460    
461     (defun allocate-funcallable-instance-1 ()
462     (let* ((env (il:\\allocblock (1+ funcallable-instance-closure-size) t))
463     (fin (il:make-compiled-closure nil env)))
464     (setf (fin-env-fin env) fin)
465     (il:replace (closure-overlay funcallable-instance-p) il:of fin il:with 't)
466     (set-funcallable-instance-function fin
467     #'(lambda (&rest ignore)
468     (declare (ignore ignore))
469     (called-fin-without-function)))
470     fin))
471    
472     (xcl:definline funcallable-instance-p (x)
473     (and (typep x 'il:compiled-closure)
474     (il:fetch (closure-overlay funcallable-instance-p) il:of x)))
475    
476     (defun set-funcallable-instance-function (fin new)
477     (cond ((not (funcallable-instance-p fin))
478     (error "~S is not a funcallable-instance" fin))
479     ((not (functionp new))
480     (error "~S is not a function." new))
481     ((typep new 'il:compiled-closure)
482     (let* ((fin-env
483     (il:fetch (il:compiled-closure il:environment) il:of fin))
484     (new-env
485     (il:fetch (il:compiled-closure il:environment) il:of new))
486     (new-env-size (if new-env (il:\\#blockdatacells new-env) 0))
487     (fin-env-size (- funcallable-instance-closure-size
488     (length funcallable-instance-data))))
489     (cond ((and new-env
490     (<= new-env-size fin-env-size))
491     (dotimes (i fin-env-size)
492     (il:\\rplptr fin-env
493     (* i 2)
494     (if (< i new-env-size)
495     (il:\\getbaseptr new-env (* i 2))
496     nil)))
497     (setf (compiled-closure-fnheader fin)
498     (compiled-closure-fnheader new)))
499     (t
500     (set-funcallable-instance-function
501     fin
502     (make-trampoline new))))))
503     (t
504     (set-funcallable-instance-function fin
505     (make-trampoline new)))))
506    
507     (defun make-trampoline (function)
508     #'(lambda (&rest args)
509     (apply function args)))
510    
511    
512     (defmacro funcallable-instance-data-1 (fin data)
513     `(il:\\getbaseptr (il:fetch (il:compiled-closure il:environment) il:of ,fin)
514     (* (- funcallable-instance-closure-size
515     (funcallable-instance-data-position ,data)
516     1) ;Reserve last element to
517     ;point back to actual FIN!
518     2)))
519    
520     (defsetf funcallable-instance-data-1 (fin data) (new-value)
521     `(il:\\rplptr (il:fetch (il:compiled-closure il:environment) il:of ,fin)
522     (* (- funcallable-instance-closure-size
523     (funcallable-instance-data-position ,data)
524     1)
525     2)
526     ,new-value))
527    
528     );end of #+Xerox
529    
530    
531     ;;;
532     ;;; In Franz Common Lisp ExCL
533     ;;; This code was originally written by:
534     ;;; jkf%franz.uucp@berkeley.edu
535     ;;; and hacked by:
536     ;;; smh%franz.uucp@berkeley.edu
537    
538     #+ExCL
539     (progn
540    
541     (defconstant funcallable-instance-flag-bit #x1)
542    
543     (defun funcallable-instance-p (x)
544     (and (excl::function-object-p x)
545     (eq funcallable-instance-flag-bit
546     (logand (excl::fn_flags x)
547     funcallable-instance-flag-bit))))
548    
549     (defun make-trampoline (function)
550     #'(lambda (&rest args)
551     (apply function args)))
552    
553     ;; We initialize a fin's procedure function to this because
554     ;; someone might try to funcall it before it has been set up.
555     (defun init-fin-fun (&rest ignore)
556     (declare (ignore ignore))
557     (called-fin-without-function))
558    
559    
560     (eval-when (eval)
561     (compile 'make-trampoline)
562     (compile 'init-fin-fun))
563    
564    
565     ;; new style
566     #+(and gsgc (not sun4) (not cray) (not mips))
567     (progn
568     ;; set-funcallable-instance-function must work by overwriting the fin itself
569     ;; because the fin must maintain EQ identity.
570     ;; Because the gsgc time needs several of the fields in the function object
571     ;; at gc time in order to walk the stack frame, it is important never to bash
572     ;; a function object that is active in a frame on the stack. Besides, changing
573     ;; the functions closure vector, not to mention overwriting its constant
574     ;; vector, would scramble it's execution when that stack frame continues.
575     ;; Therefore we represent a fin as a funny compiled-function object.
576     ;; The code vector of this object has some hand-coded instructions which
577     ;; do a very fast jump into the real fin handler function. The function
578     ;; which is the fin object *never* creates a frame on the stack.
579    
580    
581     (defun allocate-funcallable-instance-1 ()
582     (let ((fin (compiler::.primcall 'sys::new-function))
583     (init #'init-fin-fun)
584     (mattress-fun #'funcallable-instance-mattress-pad))
585     (setf (excl::fn_symdef fin) 'anonymous-fin)
586     (setf (excl::fn_constant fin) init)
587     (setf (excl::fn_code fin) ; this must be before fn_start
588     (excl::fn_code mattress-fun))
589     (setf (excl::fn_start fin) (excl::fn_start mattress-fun))
590     (setf (excl::fn_flags fin) (logior (excl::fn_flags init)
591     funcallable-instance-flag-bit))
592     (setf (excl::fn_closure fin)
593     (make-array (length funcallable-instance-data)))
594    
595     fin))
596    
597     ;; This function gets its code vector modified with a hand-coded fast jump
598     ;; to the function that is stored in place of its constant vector.
599     ;; This function is never linked in and never appears on the stack.
600    
601     (defun funcallable-instance-mattress-pad ()
602     (declare (optimize (speed 3) (safety 0)))
603     'nil)
604    
605     (eval-when (eval)
606     (compile 'funcallable-instance-mattress-pad))
607    
608    
609     #+(and excl (target-class s))
610     (eval-when (load eval)
611     (let ((codevec (excl::fn_code
612     (symbol-function 'funcallable-instance-mattress-pad))))
613     ;; The entire code vector wants to be:
614     ;; move.l 7(a2),a2 ;#x246a0007
615     ;; jmp 1(a2) ;#x4eea0001
616     (setf (aref codevec 0) #x246a
617     (aref codevec 1) #x0007
618     (aref codevec 2) #x4eea
619     (aref codevec 3) #x0001))
620     )
621    
622     #+(and excl (target-class a))
623     (eval-when (load eval)
624     (let ((codevec (excl::fn_code
625     (symbol-function 'funcallable-instance-mattress-pad))))
626     ;; The entire code vector wants to be:
627     ;; l r5,15(r5) ;#x5850500f
628     ;; l r15,11(r5) ;#x58f0500b
629     ;; br r15 ;#x07ff
630     (setf (aref codevec 0) #x5850
631     (aref codevec 1) #x500f
632     (aref codevec 2) #x58f0
633     (aref codevec 3) #x500b
634     (aref codevec 4) #x07ff
635     (aref codevec 5) #x0000))
636     )
637    
638     #+(and excl (target-class i))
639     (eval-when (load eval)
640     (let ((codevec (excl::fn_code
641     (symbol-function 'funcallable-instance-mattress-pad))))
642     ;; The entire code vector wants to be:
643     ;; movl 7(edx),edx ;#x07528b
644     ;; jmp *3(edx) ;#x0362ff
645     (setf (aref codevec 0) #x8b
646     (aref codevec 1) #x52
647     (aref codevec 2) #x07
648     (aref codevec 3) #xff
649     (aref codevec 4) #x62
650     (aref codevec 5) #x03))
651     )
652    
653     (defun funcallable-instance-data-1 (instance data)
654     (let ((constant (excl::fn_closure instance)))
655     (svref constant (funcallable-instance-data-position data))))
656    
657     (defsetf funcallable-instance-data-1 set-funcallable-instance-data-1)
658    
659     (defun set-funcallable-instance-data-1 (instance data new-value)
660     (let ((constant (excl::fn_closure instance)))
661     (setf (svref constant (funcallable-instance-data-position data))
662     new-value)))
663    
664     (defun set-funcallable-instance-function (fin new-function)
665     (unless (funcallable-instance-p fin)
666     (error "~S is not a funcallable-instance" fin))
667     (unless (functionp new-function)
668     (error "~S is not a function." new-function))
669     (setf (excl::fn_constant fin)
670     (if (excl::function-object-p new-function)
671     new-function
672     ;; The new-function is an interpreted function.
673     ;; Install a trampoline to call the interpreted function.
674     (make-trampoline new-function))))
675    
676    
677     ) ;; end sun3
678    
679    
680     #+(and gsgc (or sun4 mips))
681     (progn
682    
683     (eval-when (compile load eval)
684     (defconstant funcallable-instance-constant-count 15)
685     )
686    
687     (defun allocate-funcallable-instance-1 ()
688     (let ((new-fin (compiler::.primcall
689     'sys::new-function
690     funcallable-instance-constant-count)))
691     ;; Have to set the procedure function to something for two reasons.
692     ;; 1. someone might try to funcall it.
693     ;; 2. the flag bit that says the procedure is a funcallable
694     ;; instance is set by set-funcallable-instance-function.
695     (set-funcallable-instance-function new-fin #'init-fin-fun)
696     new-fin))
697    
698     (defun set-funcallable-instance-function (fin new-value)
699     ;; we actually only check for a function object since
700     ;; this is called before the funcallable instance flag is set
701     (unless (excl::function-object-p fin)
702     (error "~S is not a funcallable-instance" fin))
703    
704     (cond ((not (functionp new-value))
705     (error "~S is not a function." new-value))
706     ((not (excl::function-object-p new-value))
707     ;; new-value is an interpreted function. Install a
708     ;; trampoline to call the interpreted function.
709     (set-funcallable-instance-function fin (make-trampoline new-value)))
710     ((> (+ (excl::function-constant-count new-value)
711     (length funcallable-instance-data))
712     funcallable-instance-constant-count)
713     ; can't fit, must trampoline
714     (set-funcallable-instance-function fin (make-trampoline new-value)))
715     (t
716     ;; tack the instance variables at the end of the constant vector
717    
718     (setf (excl::fn_code fin) ; this must be before fn_start
719     (excl::fn_code new-value))
720     (setf (excl::fn_start fin) (excl::fn_start new-value))
721    
722     (setf (excl::fn_closure fin) (excl::fn_closure new-value))
723     ; only replace the symdef slot if the new value is an
724     ; interned symbol or some other object (like a function spec)
725     (let ((newsym (excl::fn_symdef new-value)))
726     (excl:if* (and newsym (or (not (symbolp newsym))
727     (symbol-package newsym)))
728     then (setf (excl::fn_symdef fin) newsym)))
729     (setf (excl::fn_formals fin) (excl::fn_formals new-value))
730     (setf (excl::fn_cframe-size fin) (excl::fn_cframe-size new-value))
731     (setf (excl::fn_locals fin) (excl::fn_locals new-value))
732     (setf (excl::fn_flags fin) (logior (excl::fn_flags new-value)
733     funcallable-instance-flag-bit))
734    
735     ;; on a sun4 we copy over the constants
736     (dotimes (i (excl::function-constant-count new-value))
737     (setf (excl::function-constant fin i)
738     (excl::function-constant new-value i)))
739     ;(format t "all done copy from ~s to ~s" new-value fin)
740     )))
741    
742     (defmacro funcallable-instance-data-1 (instance data)
743     `(excl::function-constant ,instance
744     (- funcallable-instance-constant-count
745     (funcallable-instance-data-position ,data)
746     1)))
747    
748     ) ;; end sun4 or mips
749    
750     #+(and gsgc cray)
751     (progn
752    
753     ;; The cray is like the sun4 in that the constant vector is included in the
754     ;; function object itself. But a mattress pad must be used anyway, because
755     ;; the function start address is copied in the symbol object, and cannot be
756     ;; updated when the fin is changed.
757     ;; We place the funcallable-instance-function into the first constant slot,
758     ;; and leave enough constant slots after that for the instance data.
759    
760     (eval-when (compile load eval)
761     (defconstant fin-fun-slot 0)
762     (defconstant fin-instance-data-slot 1)
763     )
764    
765    
766     ;; We initialize a fin's procedure function to this because
767     ;; someone might try to funcall it before it has been set up.
768     (defun init-fin-fun (&rest ignore)
769     (declare (ignore ignore))
770     (called-fin-without-function))
771    
772     (defun allocate-funcallable-instance-1 ()
773     (let ((fin (compiler::.primcall 'sys::new-function
774     (1+ (length funcallable-instance-data))
775     "funcallable-instance"))
776     (init #'init-fin-fun)
777     (mattress-fun #'funcallable-instance-mattress-pad))
778     (setf (excl::fn_symdef fin) 'anonymous-fin)
779     (setf (excl::function-constant fin fin-fun-slot) init)
780     (setf (excl::fn_code fin) ; this must be before fn_start
781     (excl::fn_code mattress-fun))
782     (setf (excl::fn_start fin) (excl::fn_start mattress-fun))
783     (setf (excl::fn_flags fin) (logior (excl::fn_flags init)
784     funcallable-instance-flag-bit))
785    
786     fin))
787    
788     ;; This function gets its code vector modified with a hand-coded fast jump
789     ;; to the function that is stored in place of its constant vector.
790     ;; This function is never linked in and never appears on the stack.
791    
792     (defun funcallable-instance-mattress-pad ()
793     (declare (optimize (speed 3) (safety 0)))
794     'nil)
795    
796     (eval-when (eval)
797     (compile 'funcallable-instance-mattress-pad)
798     (compile 'init-fin-fun))
799    
800     (eval-when (load eval)
801     (let ((codevec (excl::fn_code
802     (symbol-function 'funcallable-instance-mattress-pad))))
803     ;; The entire code vector wants to be:
804     ;; a1 b77
805     ;; a2 12,a1
806     ;; a1 1,a2
807     ;; b77 a2
808     ;; b76 a1
809     ;; j b76
810     (setf (aref codevec 0) #o024177
811     (aref codevec 1) #o101200 (aref codevec 2) 12
812     (aref codevec 3) #o102100 (aref codevec 4) 1
813     (aref codevec 5) #o025277
814     (aref codevec 6) #o025176
815     (aref codevec 7) #o005076
816     ))
817     )
818    
819     (defmacro funcallable-instance-data-1 (instance data)
820     `(excl::function-constant ,instance
821     (+ (funcallable-instance-data-position ,data)
822     fin-instance-dtat-slot)))
823    
824    
825     (defun set-funcallable-instance-function (fin new-function)
826     (unless (funcallable-instance-p fin)
827     (error "~S is not a funcallable-instance" fin))
828     (unless (functionp new-function)
829     (error "~S is not a function." new-function))
830     (setf (excl::function-constant fin fin-fun-slot)
831     (if (excl::function-object-p new-function)
832     new-function
833     ;; The new-function is an interpreted function.
834     ;; Install a trampoline to call the interpreted function.
835     (make-trampoline new-function))))
836    
837     ) ;; end cray
838    
839     #-gsgc
840     (progn
841    
842     (defun allocate-funcallable-instance-1 ()
843     (let ((new-fin (compiler::.primcall 'sys::new-function)))
844     ;; Have to set the procedure function to something for two reasons.
845     ;; 1. someone might try to funcall it.
846     ;; 2. the flag bit that says the procedure is a funcallable
847     ;; instance is set by set-funcallable-instance-function.
848     (set-funcallable-instance-function new-fin #'init-fin-fn)
849     new-fin))
850    
851     (defun set-funcallable-instance-function (fin new-value)
852     ;; we actually only check for a function object since
853     ;; this is called before the funcallable instance flag is set
854     (unless (excl::function-object-p fin)
855     (error "~S is not a funcallable-instance" fin))
856     (cond ((not (functionp new-value))
857     (error "~S is not a function." new-value))
858     ((not (excl::function-object-p new-value))
859     ;; new-value is an interpreted function. Install a
860     ;; trampoline to call the interpreted function.
861     (set-funcallable-instance-function fin (make-trampoline new-value)))
862     (t
863     ;; tack the instance variables at the end of the constant vector
864     (setf (excl::fn_start fin) (excl::fn_start new-value))
865     (setf (excl::fn_constant fin) (add-instance-vars
866     (excl::fn_constant new-value)
867     (excl::fn_constant fin)))
868     (setf (excl::fn_closure fin) (excl::fn_closure new-value))
869     ;; In versions prior to 2.0. comment the next line and any other
870     ;; references to fn_symdef or fn_locals.
871     (setf (excl::fn_symdef fin) (excl::fn_symdef new-value))
872     (setf (excl::fn_code fin) (excl::fn_code new-value))
873     (setf (excl::fn_formals fin) (excl::fn_formals new-value))
874     (setf (excl::fn_cframe-size fin) (excl::fn_cframe-size new-value))
875     (setf (excl::fn_locals fin) (excl::fn_locals new-value))
876     (setf (excl::fn_flags fin) (logior (excl::fn_flags new-value)
877     funcallable-instance-flag-bit)))))
878    
879     (defun add-instance-vars (cvec old-cvec)
880     ;; create a constant vector containing everything in the given constant
881     ;; vector plus space for the instance variables
882     (let* ((nconstants (cond (cvec (length cvec)) (t 0)))
883     (ndata (length funcallable-instance-data))
884     (old-cvec-length (if old-cvec (length old-cvec) 0))
885     (new-cvec nil))
886     (cond ((<= (+ nconstants ndata) old-cvec-length)
887     (setq new-cvec old-cvec))
888     (t
889     (setq new-cvec (make-array (+ nconstants ndata)))
890     (when old-cvec
891     (dotimes (i ndata)
892     (setf (svref new-cvec (- (+ nconstants ndata) i 1))
893     (svref old-cvec (- old-cvec-length i 1)))))))
894    
895     (dotimes (i nconstants) (setf (svref new-cvec i) (svref cvec i)))
896    
897     new-cvec))
898    
899     (defun funcallable-instance-data-1 (instance data)
900     (let ((constant (excl::fn_constant instance)))
901     (svref constant (- (length constant)
902     (1+ (funcallable-instance-data-position data))))))
903    
904     (defsetf funcallable-instance-data-1 set-funcallable-instance-data-1)
905    
906     (defun set-funcallable-instance-data-1 (instance data new-value)
907     (let ((constant (excl::fn_constant instance)))
908     (setf (svref constant (- (length constant)
909     (1+ (funcallable-instance-data-position data))))
910     new-value)))
911    
912     );end #-gsgc
913    
914     );end of #+ExCL
915    
916    
917     ;;;
918     ;;; In Vaxlisp
919     ;;; This code was originally written by:
920     ;;; vanroggen%bach.DEC@DECWRL.DEC.COM
921     ;;;
922     #+(and dec vax common)
923     (progn
924    
925     ;;; The following works only in Version 2 of VAXLISP, and will have to
926     ;;; be replaced for later versions.
927    
928     (defun allocate-funcallable-instance-1 ()
929     (list 'system::%compiled-closure%
930     ()
931     #'(lambda (&rest args)
932     (declare (ignore args))
933     (called-fin-without-function))
934     (make-array (length funcallable-instance-data))))
935    
936     (proclaim '(inline funcallable-instance-p))
937     (defun funcallable-instance-p (x)
938     (and (consp x)
939     (eq (car x) 'system::%compiled-closure%)
940     (not (null (cdddr x)))))
941    
942     (defun set-funcallable-instance-function (fin func)
943     (cond ((not (funcallable-instance-p fin))
944     (error "~S is not a funcallable-instance" fin))
945     ((not (functionp func))
946     (error "~S is not a function" func))
947     ((and (consp func) (eq (car func) 'system::%compiled-closure%))
948     (setf (cadr fin) (cadr func)
949     (caddr fin) (caddr func)))
950     (t (set-funcallable-instance-function fin
951     (make-trampoline func)))))
952    
953     (defun make-trampoline (function)
954     #'(lambda (&rest args)
955     (apply function args)))
956    
957     (eval-when (eval) (compile 'make-trampoline))
958    
959     (defmacro funcallable-instance-data-1 (instance data)
960     `(svref (cadddr ,instance)
961     (funcallable-instance-data-position ,data)))
962    
963     );end of Vaxlisp (and dec vax common)
964    
965    
966     ;;; Implementation of funcallable instances for CMU Common Lisp.
967     ;;;
968     ;;; Similiar to the code for VAXLISP implementation.
969     #+:CMU
970     (progn
971    
972     (defun allocate-funcallable-instance-1 ()
973     `(lisp::%compiled-closure%
974     ()
975     ,#'(lambda (&rest args)
976     (declare (ignore args))
977     (called-fin-without-function))
978     ,(make-array (length funcallable-instance-data))))
979    
980     (proclaim '(inline funcallable-instance-p))
981     (defun funcallable-instance-p (x)
982     (and (consp x)
983     (eq (car x) 'lisp::%compiled-closure%)
984     (not (null (cdddr x)))))
985    
986     (defun set-funcallable-instance-function (fin func)
987     (cond ((not (funcallable-instance-p fin))
988     (error "~S is not a funcallable-instance" fin))
989     ((not (functionp func))
990     (error "~S is not a function" func))
991     ((and (consp func) (eq (car func) 'lisp::%compiled-closure%))
992     (setf (cadr fin) (cadr func)
993     (caddr fin) (caddr func)))
994     (t (set-funcallable-instance-function fin
995     (make-trampoline func)))))
996    
997     (defun make-trampoline (function)
998     #'(lambda (&rest args)
999     (apply function args)))
1000    
1001     (eval-when (eval) (compile 'make-trampoline))
1002    
1003     (defmacro funcallable-instance-data-1 (instance data)
1004     `(svref (cadddr ,instance)
1005     (funcallable-instance-data-position ,data)))
1006    
1007     ); End of :CMU
1008    
1009    
1010    
1011     ;;;
1012     ;;; Kyoto Common Lisp (KCL)
1013     ;;;
1014     ;;; In KCL, compiled functions and compiled closures are defined as c structs.
1015     ;;; This means that in order to access their fields, we have to use C code!
1016     ;;; The C code we call and the lisp interface to it is in the file kcl-low.
1017     ;;; The lisp interface to this code implements accessors to compiled closures
1018     ;;; and compiled functions of about the same level of abstraction as that
1019     ;;; which is used by the other implementation dependent versions of FINs in
1020     ;;; this file.
1021     ;;;
1022    
1023     #+(or KCL IBCL)
1024     (progn
1025    
1026     (defvar *funcallable-instance-marker* (list "Funcallable Instance Marker"))
1027    
1028     (defconstant funcallable-instance-closure-size 15)
1029    
1030     (defconstant funcallable-instance-closure-size1
1031     (1- funcallable-instance-closure-size))
1032    
1033     (defconstant funcallable-instance-available-size
1034     (- funcallable-instance-closure-size1
1035     (length funcallable-instance-data)))
1036    
1037     (defmacro funcallable-instance-marker (x)
1038     `(car (cclosure-env-nthcdr funcallable-instance-closure-size1 ,x)))
1039    
1040     (defun allocate-funcallable-instance-1 ()
1041     (let ((fin (allocate-funcallable-instance-2))
1042     (env (make-list funcallable-instance-closure-size :initial-element nil)))
1043     (setf (%cclosure-env fin) env)
1044     #+:turbo-closure (si:turbo-closure fin)
1045     (setf (funcallable-instance-marker fin) *funcallable-instance-marker*)
1046     fin))
1047    
1048     (defun allocate-funcallable-instance-2 ()
1049     (let ((what-a-dumb-closure-variable ()))
1050     #'(lambda (&rest args)
1051     (declare (ignore args))
1052     (called-fin-without-function)
1053     (setq what-a-dumb-closure-variable
1054     (dummy-function what-a-dumb-closure-variable)))))
1055    
1056     (defun funcallable-instance-p (x)
1057     (eq *funcallable-instance-marker* (funcallable-instance-marker x)))
1058    
1059     (si:define-compiler-macro funcallable-instance-p (x)
1060     `(eq *funcallable-instance-marker* (funcallable-instance-marker ,x)))
1061    
1062     (defun set-funcallable-instance-function (fin new-value)
1063     (cond ((not (funcallable-instance-p fin))
1064     (error "~S is not a funcallable-instance" fin))
1065     ((not (functionp new-value))
1066     (error "~S is not a function." new-value))
1067     ((and (cclosurep new-value)
1068     (<= (length (%cclosure-env new-value))
1069     funcallable-instance-available-size))
1070     (%set-cclosure fin new-value funcallable-instance-available-size))
1071     (t
1072     (set-funcallable-instance-function
1073     fin (make-trampoline new-value))))
1074     fin)
1075    
1076     (defmacro funcallable-instance-data-1 (fin data &environment env)
1077     ;; The compiler won't expand macros before deciding on optimizations,
1078     ;; so we must do it here.
1079     (let* ((pos-form (macroexpand `(funcallable-instance-data-position ,data)
1080     env))
1081     (index-form (if (constantp pos-form)
1082     (- funcallable-instance-closure-size
1083     (eval pos-form)
1084     2)
1085     `(- funcallable-instance-closure-size
1086     (funcallable-instance-data-position ,data)
1087     2))))
1088     `(car (%cclosure-env-nthcdr ,index-form ,fin))))
1089    
1090    
1091     #+turbo-closure (clines "#define TURBO_CLOSURE")
1092    
1093     (clines "
1094     static make_trampoline_internal();
1095     static make_turbo_trampoline_internal();
1096    
1097     static object
1098     make_trampoline(function)
1099     object function;
1100     {
1101     vs_push(MMcons(function,Cnil));
1102     #ifdef TURBO_CLOSURE
1103     if(type_of(function)==t_cclosure)
1104     {if(function->cc.cc_turbo==NULL)turbo_closure(function);
1105     vs_head=make_cclosure(make_turbo_trampoline_internal,Cnil,vs_head,Cnil,NULL,0);
1106     return vs_pop;}
1107     #endif
1108     vs_head=make_cclosure(make_trampoline_internal,Cnil,vs_head,Cnil,NULL,0);
1109     return vs_pop;
1110     }
1111    
1112     static
1113     make_trampoline_internal(base0)
1114     object *base0;
1115     {super_funcall_no_event(base0[0]->c.c_car);}
1116    
1117     static
1118     make_turbo_trampoline_internal(base0)
1119     object *base0;
1120     { object function=base0[0]->c.c_car;
1121     (*function->cc.cc_self)(function->cc.cc_turbo);
1122     }
1123    
1124     ")
1125    
1126     (defentry make-trampoline (object) (object make_trampoline))
1127     )
1128    
1129    
1130     ;;;
1131     ;;; In H.P. Common Lisp
1132     ;;; This code was originally written by:
1133     ;;; kempf@hplabs.hp.com (James Kempf)
1134     ;;; dsouza@hplabs.hp.com (Roy D'Souza)
1135     ;;;
1136     #+HP-HPLabs
1137     (progn
1138    
1139     (defmacro fin-closure-size ()`(prim::@* 6 prim::bytes-per-word))
1140    
1141     (defmacro fin-set-mem-hword ()
1142     `(prim::@set-mem-hword
1143     (prim::@+ fin (prim::@<< 2 1))
1144     (prim::@+ (prim::@<< 2 8)
1145     (prim::@fundef-info-parms (prim::@fundef-info fundef)))))
1146    
1147     (defun allocate-funcallable-instance-1()
1148     (let* ((fundef
1149     #'(lambda (&rest ignore)
1150     (declare (ignore ignore))
1151     (called-fin-without-function)))
1152     (static-link (vector 'lisp::*undefined* NIL NIL NIL NIL NIL))
1153     (fin (prim::@make-fundef (fin-closure-size))))
1154     (fin-set-mem-hword)
1155     (prim::@set-svref fin 2 fundef)
1156     (prim::@set-svref fin 3 static-link)
1157     (prim::@set-svref fin 4 0)
1158     (impl::PlantclosureHook fin)
1159     fin))
1160    
1161     (defmacro funcallable-instance-p (possible-fin)
1162     `(= (fin-closure-size) (prim::@header-inf ,possible-fin)))
1163    
1164     (defun set-funcallable-instance-function (fin new-function)
1165     (cond ((not (funcallable-instance-p fin))
1166     (error "~S is not a funcallable instance.~%" fin))
1167     ((not (functionp new-function))
1168     (error "~S is not a function." new-function))
1169     (T
1170     (prim::@set-svref fin 2 new-function))))
1171    
1172     (defmacro funcallable-instance-data-1 (fin data)
1173     `(prim::@svref (prim::@closure-static-link ,fin)
1174     (+ 2 (funcallable-instance-data-position ,data))))
1175    
1176     (defsetf funcallable-instance-data-1 (fin data) (new-value)
1177     `(prim::@set-svref (prim::@closure-static-link ,fin)
1178     (+ (funcallable-instance-data-position ,data) 2)
1179     ,new-value))
1180    
1181     (defun funcallable-instance-name (fin)
1182     (prim::@svref (prim::@closure-static-link fin) 1))
1183    
1184     (defsetf funcallable-instance-name set-funcallable-instance-name)
1185    
1186     (defun set-funcallable-instance-name (fin new-name)
1187     (prim::@set-svref (prim::@closure-static-link fin) 1 new-name))
1188    
1189     );end #+HP
1190    
1191    
1192    
1193     ;;;
1194     ;;; In Golden Common Lisp.
1195     ;;; This code was originally written by:
1196     ;;; dan%acorn@Live-Oak.LCS.MIT.edu (Dan Jacobs)
1197     ;;;
1198     ;;; GCLISP supports named structures that are specially marked as funcallable.
1199     ;;; This allows FUNCALLABLE-INSTANCE-P to be a normal structure predicate,
1200     ;;; and allows ALLOCATE-FUNCALLABLE-INSTANCE-1 to be a normal boa-constructor.
1201     ;;;
1202     #+GCLISP
1203     (progn
1204    
1205     (defstruct (%funcallable-instance
1206     (:predicate funcallable-instance-p)
1207     (:copier nil)
1208     (:constructor allocate-funcallable-instance-1 ())
1209     (:print-function
1210     (lambda (struct stream depth)
1211     (declare (ignore depth))
1212     (print-object struct stream))))
1213     (function #'(lambda (ignore-this &rest ignore-these-too)
1214     (declare (ignore ignore-this ignore-these-too))
1215     (called-fin-without-function))
1216     :type function)
1217     (%hidden% 'gclisp::funcallable :read-only t)
1218     (data (vector nil nil) :type simple-vector :read-only t))
1219    
1220     (proclaim '(inline set-funcallable-instance-function))
1221     (defun set-funcallable-instance-function (fin new-value)
1222     (setf (%funcallable-instance-function fin) new-value))
1223    
1224     (defmacro funcallable-instance-data-1 (fin data)
1225     `(svref (%funcallable-instance-data ,fin)
1226     (funcallable-instance-data-position ,data)))
1227    
1228     )
1229    
1230    
1231     ;;;
1232     ;;; Explorer Common Lisp
1233     ;;; This code was originally written by:
1234     ;;; Dussud%Jenner@csl.ti.com
1235     ;;;
1236     #+ti
1237     (progn
1238    
1239     #+(or :ti-release-3 (and :ti-release-2 elroy))
1240     (defmacro lexical-closure-environment (l)
1241     `(cdr (si:%make-pointer si:dtp-list
1242     (cdr (si:%make-pointer si:dtp-list ,l)))))
1243    
1244     #-(or :ti-release-3 elroy)
1245     (defmacro lexical-closure-environment (l)
1246     `(caar (si:%make-pointer si:dtp-list
1247     (cdr (si:%make-pointer si:dtp-list ,l)))))
1248    
1249     (defmacro lexical-closure-function (l)
1250     `(car (si:%make-pointer si:dtp-list ,l)))
1251    
1252    
1253     (defvar *funcallable-instance-marker* (list "Funcallable Instance Marker"))
1254    
1255     (defconstant funcallable-instance-closure-size 15) ; NOTE: In order to avoid
1256     ; hassles with the reader,
1257     (defmacro allocate-funcallable-instance-2 () ; these two 15's are the
1258     (let ((l ())) ; same. Be sure to keep
1259     (dotimes (i 15) ; them consistent.
1260     (push (list (gensym) nil) l))
1261     `(let ,l
1262     #'(lambda (ignore &rest ignore-them-too)
1263     (declare (ignore ignore ignore-them-too))
1264     (called-fin-without-function)
1265     (values . ,(mapcar #'car l))))))
1266    
1267     (defun allocate-funcallable-instance-1 ()
1268     (let* ((new-fin (allocate-funcallable-instance-2)))
1269     (setf (car (nthcdr (1- funcallable-instance-closure-size)
1270     (lexical-closure-environment new-fin)))
1271     *funcallable-instance-marker*)
1272     new-fin))
1273    
1274     (eval-when (eval) (compile 'allocate-funcallable-instance-1))
1275    
1276     (proclaim '(inline funcallable-instance-p))
1277     (defun funcallable-instance-p (x)
1278     (and (typep x #+:ti-release-2 'closure
1279     #+:ti-release-3 'si:lexical-closure)
1280     (let ((env (lexical-closure-environment x)))
1281     (eq (nth (1- funcallable-instance-closure-size) env)
1282     *funcallable-instance-marker*))))
1283    
1284     (defun set-funcallable-instance-function (fin new-value)
1285     (cond ((not (funcallable-instance-p fin))
1286     (error "~S is not a funcallable-instance"))
1287     ((not (functionp new-value))
1288     (error "~S is not a function."))
1289     ((typep new-value 'si:lexical-closure)
1290     (let* ((fin-env (lexical-closure-environment fin))
1291     (new-env (lexical-closure-environment new-value))
1292     (new-env-size (length new-env))
1293     (fin-env-size (- funcallable-instance-closure-size
1294     (length funcallable-instance-data)
1295     1)))
1296     (cond ((<= new-env-size fin-env-size)
1297     (do ((i 0 (+ i 1))
1298     (new-env-tail new-env (cdr new-env-tail))
1299     (fin-env-tail fin-env (cdr fin-env-tail)))
1300     ((= i fin-env-size))
1301     (setf (car fin-env-tail)
1302     (if (< i new-env-size)
1303     (car new-env-tail)
1304     nil)))
1305     (setf (lexical-closure-function fin)
1306     (lexical-closure-function new-value)))
1307     (t
1308     (set-funcallable-instance-function
1309     fin
1310     (make-trampoline new-value))))))
1311     (t
1312     (set-funcallable-instance-function fin
1313     (make-trampoline new-value)))))
1314    
1315     (defun make-trampoline (function)
1316     (let ((tmp))
1317     #'(lambda (&rest args) tmp
1318     (apply function args))))
1319    
1320     (eval-when (eval) (compile 'make-trampoline))
1321    
1322     (defmacro funcallable-instance-data-1 (fin data)
1323     `(let ((env (lexical-closure-environment ,fin)))
1324     (nth (- funcallable-instance-closure-size
1325     (funcallable-instance-data-position ,data)
1326     2)
1327     env)))
1328    
1329    
1330     (defsetf funcallable-instance-data-1 (fin data) (new-value)
1331     `(let ((env (lexical-closure-environment ,fin)))
1332     (setf (car (nthcdr (- funcallable-instance-closure-size
1333     (funcallable-instance-data-position ,data)
1334     2)
1335     env))
1336     ,new-value)))
1337    
1338     );end of code for TI
1339    
1340    
1341     ;;; Implemented by Bein@pyramid -- Tue Aug 25 19:05:17 1987
1342     ;;;
1343     ;;; A FIN is a distinct type of object which FUNCALL,EVAL, and APPLY
1344     ;;; recognize as functions. Both Compiled-Function-P and functionp
1345     ;;; recognize FINs as first class functions.
1346     ;;;
1347     ;;; This does not work with PyrLisp versions earlier than 1.1..
1348    
1349     #+pyramid
1350     (progn
1351    
1352     (defun make-trampoline (function)
1353     #'(lambda (&rest args) (apply function args)))
1354    
1355     (defun un-initialized-fin (&rest trash)
1356     (declare (ignore trash))
1357     (called-fin-without-function))
1358    
1359     (eval-when (eval)
1360     (compile 'make-trampoline)
1361     (compile 'un-initialized-fin))
1362    
1363     (defun allocate-funcallable-instance-1 ()
1364     (let ((fin (system::alloc-funcallable-instance)))
1365     (system::set-fin-function fin #'un-initialized-fin)
1366     fin))
1367    
1368     (defun funcallable-instance-p (object)
1369     (typep object 'lisp::funcallable-instance))
1370    
1371     (clc::deftransform funcallable-instance-p trans-fin-p (object)
1372     `(typep ,object 'lisp::funcallable-instance))
1373    
1374     (defun set-funcallable-instance-function (fin new-value)
1375     (or (funcallable-instance-p fin)
1376     (error "~S is not a funcallable-instance." fin))
1377     (cond ((not (functionp new-value))
1378     (error "~S is not a function." new-value))
1379     ((not (lisp::compiled-function-p new-value))
1380     (set-funcallable-instance-function fin
1381     (make-trampoline new-value)))
1382     (t
1383     (system::set-fin-function fin new-value))))
1384    
1385     (defun funcallable-instance-data-1 (fin data-name)
1386     (system::get-fin-data fin
1387     (funcallable-instance-data-position data-name)))
1388    
1389     (defun set-funcallable-instance-data-1 (fin data-name value)
1390     (system::set-fin-data fin
1391     (funcallable-instance-data-position data-name)
1392     value))
1393    
1394     (defsetf funcallable-instance-data-1 set-funcallable-instance-data-1)
1395    
1396     ); End of #+pyramid
1397    
1398    
1399     ;;;
1400     ;;; For Coral Lisp
1401     ;;;
1402     #+:coral
1403     (progn
1404    
1405     (defconstant ccl::$v_istruct 22)
1406     (defvar ccl::initial-fin-slots (make-list (length funcallable-instance-data)))
1407     (defconstant ccl::fin-function 1)
1408     (defconstant ccl::fin-data (+ ccl::FIN-function 1))
1409    
1410     (defun allocate-funcallable-instance-1 ()
1411     (apply #'ccl::%gvector
1412     ccl::$v_istruct
1413     'ccl::funcallable-instance
1414     #'(lambda (&rest ignore)
1415     (declare (ignore ignore))
1416     (called-fin-without-function))
1417     ccl::initial-fin-slots))
1418    
1419     ;;; Make uvector-based objects (like funcallable instances) print better.
1420     #+:ccl-1.3
1421     (defun print-uvector-object (obj stream &optional print-level)
1422     (declare (ignore print-level))
1423     (print-object obj stream))
1424    
1425     ;;; Inform the print system about funcallable instance uvectors.
1426     #+:ccl-1.3
1427     (eval-when (eval compile load)
1428     (pushnew (cons 'ccl::funcallable-instance #'print-uvector-object)
1429     ccl:*write-uvector-alist*
1430     :test #'equal))
1431    
1432     (defun funcallable-instance-p (x)
1433     (and (eq (ccl::%type-of x) 'ccl::internal-structure)
1434     (eq (ccl::%uvref x 0) 'ccl::funcallable-instance)))
1435    
1436     (defun set-funcallable-instance-function (fin new-value)
1437     (unless (funcallable-instance-p fin)
1438     (error "~S is not a funcallable-instance." fin))
1439     (unless (functionp new-value)
1440     (error "~S is not a function." new-value))
1441     (ccl::%uvset fin ccl::FIN-function new-value))
1442    
1443     (defmacro funcallable-instance-data-1 (fin data-name)
1444     `(ccl::%uvref ,fin
1445     (+ (funcallable-instance-data-position ,data-name)
1446     ccl::FIN-data)))
1447    
1448     (defsetf funcallable-instance-data-1 (fin data) (new-value)
1449     `(ccl::%uvset ,fin
1450     (+ (funcallable-instance-data-position ,data) ccl::FIN-data)
1451     ,new-value))
1452    
1453     ); End of #+:coral
1454    
1455    
1456    
1457     ;;;; Slightly Higher-Level stuff built on the implementation-dependent stuff.
1458     ;;;
1459     ;;;
1460    
1461     (defmacro fsc-instance-p (fin)
1462     `(funcallable-instance-p ,fin))
1463    
1464     (defmacro fsc-instance-class (fin)
1465     `(wrapper-class (funcallable-instance-data-1 ,fin 'wrapper)))
1466    
1467     (defmacro fsc-instance-wrapper (fin)
1468     `(funcallable-instance-data-1 ,fin 'wrapper))
1469    
1470     (defmacro fsc-instance-slots (fin)
1471     `(funcallable-instance-data-1 ,fin 'slots))
1472    
1473     (defun allocate-funcallable-instance (wrapper number-of-static-slots)
1474     (let ((fin (allocate-funcallable-instance-1))
1475     (slots
1476     (%allocate-static-slot-storage--class number-of-static-slots)))
1477     (setf (fsc-instance-wrapper fin) wrapper
1478     (fsc-instance-slots fin) slots)
1479     fin))

  ViewVC Help
Powered by ViewVC 1.1.5