LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760032832. :SYSTEM-TYPE :LOGICAL :VERSION 9. :TYPE "LISP" :NAME "FSC-LOW" :DIRECTORY ("REL3-PUBLIC" "PUBLIC" "PCL") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-PUBLIC\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2756388126. :AUTHOR "REL3" :LENGTH-IN-BYTES 35232. :LENGTH-IN-BLOCKS 35. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                          ;;;-*-Mode:LISP; Package:(PCL Lisp 1000); Base:10; Syntax:Common-lisp -*-;;;;;; *************************************************************************;;; Copyright (c) 1985, 1986, 1987 Xerx Corporation.  All rights reserved.;;;;;; Use and copying of this software and preparation of derivative works;;; based upon this software are permitted.  Any distribution of this;;; software or derivative works must comply with all applicable United;;; States export control laws.;;; ;;; This software is made available AS IS, and Xerox Corporation makes no;;; warranty about the software, its performance or its conformity to any;;; specification.;;; ;;; Any person obtaining a copy of this software is requested to send their;;; name and post office or electronic mail address to:;;;   CommonLoops Coordinator;;;   Xerox Artifical Intelligence Systems;;;   2400 Hanover St.;;;   Palo Alto, CA 94303;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa);;;;;; Suggestions, comments and requests for improvements are also welcome.;;; *************************************************************************;;;  ;;   ;;;;;; FUNCALLABLE INSTANCES  ;;#|Generic functions are instances with meta class funcallable-standard-class.Instances with this meta class are called funcallable-instances (FINs forshort).  They behave something like lexical closures in that they have dataassociated with them (which is used to store the slots) and are funcallable.When a funcallable instance is funcalled, the function that is invoked iscalled the funcallable-instance-function.  The funcallable-instance-functionof a funcallable instance can be changed.This file implements low level code for manipulating funcallable instances.It is possible to implement funcallable instances in pure Common Lisp.  Asimple implementation which uses lexical closures as the instances and ahash table to record that the lexical closures are funcallable instancesis easy to write.  Unfortunately, this implementation adds significantoverhead:   to generic-function-invocation (1 function call)   to slot-access (1 function call or one hash table lookup)   to class-of a generic-function (1 hash-table lookup)In addition, it would prevent the funcallable instances from being garbagecollected.  In short, the pure Common Lisp implementation really isn'tpractical.Instead, PCL uses a specially tailored implementation for each Common Lisp andmakes no attempt to provide a purely portable implementation.  The speciallytailored implementations are based on the lexical closure's provided by thatimplementation and are fairly short and easy to write.|#(in-package 'pcl);;;;;; The first part of the file contains the implementation dependent code to;;; implement funcallable instances.  Each implementation must provide the;;; following functions and macros:;;; ;;;    MAKE-FUNCALLABLE-INSTANCE-1 ();;;       should create and return a new funcallable instance.  The;;;       funcallable-instance-data slots must be initialized to NIL.;;;       This is called by make-funcallable-instance and by the;;;       bootstrapping code.;;;;;;    FUNCALLABLE-INSTANCE-P (x);;;       the obvious predicate.  This should be an INLINE function.;;;       it must be funcallable, but it would be nice if it compiled;;;       open.;;;;;;    SET-FUNCALLABLE-INSTANCE-FUNCTION (fin new-value);;;       change the fin so that when it is funcalled, the new-value;;;       function is called.  Note that it is legal for new-value;;;       to be copied before it is installed in the fin, specifically;;;       there is no accessor for a FIN's function so this function;;;       does not have to preserve the actual new value.  The new-value;;;       argument can be any funcallable thing, a closure, lambda;;;       compiled code etc.  This function must coerce those values;;;       if necessary.;;;       NOTE: new-value is almost always a compiled closure.  This;;;             is the important case to optimize.;;;;;;    FUNCALLABLE-INSTANCE-DATA-1 (fin data-name);;;       should return the value of the data named data-name in the fin.;;;       data-name is one of the symbols in the list which is the value;;;       of funcallable-instance-data.  Since data-name is almost always;;;       a quoted symbol and funcallable-instance-data is a constant, it;;;       is possible (and worthwhile) to optimize the computation of;;;       data-name's offset in the data part of the fin.;;;       This must be SETF'able.;;;       (defconstant funcallable-instance-data             '(wrapper static-slots dynamic-slots)  "These are the 'data-slots' which funcallable instances have so that   the meta-class funcallable-standard-class can store class, and static   and dynamic slots in them.")(defmacro funcallable-instance-data-position (data)  (if (and (consp data)           (eq (car data) 'quote)           (boundp 'funcallable-instance-data))      (or (position (cadr data) funcallable-instance-data :test #'eq)          (progn            (warn "Unknown funcallable-instance data: ~S." (cadr data))            `(error "Unknown funcallable-instance data: ~S." ',(cadr data))))      `(position ,data funcallable-instance-data :test #'eq)));;;;;; In Lucid Lisp, compiled functions and compiled closures have the same;;; representation.  They are called procedures.  A procedure is a basically;;; just a constants vector, with one slot which points to the CODE.  This;;; means that constants and closure variables are intermixed in the procedure;;; vector.;;; #+Lucid(progn(defconstant funcallable-instance-procedure-size 30)(defconstant procedure-is-funcallable-instance-bit-position 10)(defvar *funcallable-instance-trampolines* ()  "This is a list of all the procedure sizes which were too big to be stored   directly in a funcallable instance.  For each of these procedures, a   trampoline procedure had to be used.  This is for metering information   only.")(defun make-funcallable-instance-1 ()  (declare (notinline lucid::new-procedure))    ;fixes a bug in Prime 1.0 in                                                ;which new-procedure expands                                                ;incorrectly  (let ((new-fin (lucid::new-procedure funcallable-instance-procedure-size)))    ;; Initialize the new funcallable-instance.  As part of out contract,    ;; we have to make sure the initial value of all the funcallable    ;; instance data slots is NIL.  To help set-funcallable-instance-function    ;; we also set the procedure-code to NIL.    (dotimes (i (length funcallable-instance-data))      (setf (lucid::procedure-ref new-fin                                  (- funcallable-instance-procedure-size i 1))            nil))    (setf (lucid::procedure-ref new-fin lucid::procedure-code) nil)    ;; Have to set the procedure function to something for two reasons.    ;;   1. someone might try to funcall it.    ;;   2. the flag bit that says the procedure is a funcallable    ;;      instance is set by set-funcallable-instance-function.    (set-funcallable-instance-function      new-fin      #'(lambda (&rest ignore)          (declare (ignore ignore))          (error "Attempt to funcall a funcallable-instance without first~%~                  setting its funcallable-instance-function.")))    new-fin))(lucid::defsubst funcallable-instance-p (x)  (and (lucid::procedurep x)       (lucid::logbitp& procedure-is-funcallable-instance-bit-position                        (lucid::procedure-ref x lucid::procedure-flags))))(defun set-funcallable-instance-function (fin new-value)  (unless (or (funcallable-instance-p fin)              (and (lucid::procedurep fin)                   (null (lucid::procedure-ref fin lucid::procedure-code))))    (error "~S is not a funcallable-instance" fin))  (cond ((not (functionp new-value))         (error "~S is not a function." new-value))        ((not (lucid::procedurep new-value))         ;; new-value is an interpreted function.  Install a         ;; trampoline to call the interpreted function.         (set-funcallable-instance-function fin                                            (make-trampoline new-value)))        (t         (let ((new-procedure-size (lucid::procedure-length new-value))               (max-procedure-size (- funcallable-instance-procedure-size                                      (length funcallable-instance-data))))           (if (< new-procedure-size max-procedure-size)               ;; The new procedure fits in the funcallable-instance.               ;; Just copy the new procedure into the fin procedure,               ;; also be sure to update the procedure-flags of the               ;; fin to keep it a fin.               (progn                  (dotimes (i max-procedure-size)                   (setf (lucid::procedure-ref fin i)                                             (if (< i new-procedure-size)                             (lucid::procedure-ref new-value i)                             nil)))                 (setf (lucid::procedure-ref fin lucid::procedure-flags)                       (logior                         (expt 2                               procedure-is-funcallable-instance-bit-position)                         (lucid::procedure-ref fin lucid::procedure-flags)))                 new-value)               ;; The new procedure doesn't fit in the funcallable instance               ;; Instead, install a trampoline procedure which will call               ;; the new procecdure.  First make note of the fact that we               ;; had to trampoline so that we can see if its worth upping               ;; the value of funcallable-instance-procedure-size.               (progn                 (push new-procedure-size *funcallable-instance-trampolines*)                 (set-funcallable-instance-function                   fin                   (make-trampoline new-value))))))))(defun make-trampoline (function)  #'(lambda (&rest args)      (apply function args)))(eval-when (eval) (compile 'make-trampoline))(defmacro funcallable-instance-data-1 (instance data)  `(lucid::procedure-ref ,instance                         (- funcallable-instance-procedure-size                            (funcallable-instance-data-position ,data)                            1)))  );dicuL+#;;;;;; In Symbolics Common Lisp, a lexical closure is a pair of an environment;;; and an ordinary compiled function.  The environment is represented as;;; a list.  I know of know way to add a special bit to say that the closure;;; is a FIN, so for now, closures are marked as FINS by storing a special;;; marker in the last cell of the environment.  This is a drag since it;;; means that funcallable-instance-p has to CDR down the environment list.;;;      #+Symbolics(progn(defvar *funcallable-instance-marker* (list "Funcallable Instance Marker"))(defconstant funcallable-instance-closure-size 15)(defun make-funcallable-instance-1 ()  (let* ((env (make-list funcallable-instance-closure-size))         (fn #'(lambda (ignore &rest ignore-them-too)                 (declare (ignore ignore ignore-them-too))                 (error "Called a FIN without first setting its function.")))         (new-fin (sys:make-lexical-closure env fn)))    (dotimes (i (1- funcallable-instance-closure-size)) (pop env))    (setf (car env) *funcallable-instance-marker*)    new-fin))(scl:defsubst funcallable-instance-p (x)  (and (si:lexical-closure-p x)       (let ((env (si:lexical-closure-environment x))) (when (listp env)   (dotimes (i (1- funcallable-instance-closure-size)) (pop env))   (eq (car env) *funcallable-instance-marker*)))))(defun set-funcallable-instance-function (fin new-value)  (cond ((not (funcallable-instance-p fin))         (error "~S is not a funcallable-instance" fin))        ((not (functionp new-value))         (error "~S is not a function." new-value))        ((si:lexical-closure-p new-value)         (let* ((fin-env (si:lexical-closure-environment fin))                (new-env (si:lexical-closure-environment new-value))                (new-env-size (length new-env))                (fin-env-size (- funcallable-instance-closure-size                                 (length funcallable-instance-data))))           (cond ((<= new-env-size fin-env-size)  (do ((i 0 (+ i 1))       (new-env-tail new-env (cdr new-env-tail))       (fin-env-tail fin-env (cdr fin-env-tail)))      ((= i fin-env-size))    (setf (car fin-env-tail)  (if (< i new-env-size)      (car new-env-tail)      nil)))                  (setf (si:lexical-closure-function fin)                        (si:lexical-closure-function new-value)))                 (t                                   (set-funcallable-instance-function                    fin                    (make-trampoline new-value))))))        (t         (set-funcallable-instance-function fin                                            (make-trampoline new-value)))))(defun make-trampoline (function)  #'(lambda (&rest args)      (apply function args)))        (defmacro funcallable-instance-data-1 (fin data)  `(let ((env (si:lexical-closure-environment ,fin)))     (dotimes (i (- funcallable-instance-closure-size                    (funcallable-instance-data-position ,data)                    2))       (pop env))     (car env)))(defsetf funcallable-instance-data-1 (fin data) (new-value)  `(let ((env (si:lexical-closure-environment ,fin)))     (dotimes (i (- funcallable-instance-closure-size                    (funcallable-instance-data-position ,data)                    2))       (pop env))     (setf (car env) ,new-value))));#+ti(defconstant funcallable-instance-closure-size 15)#+ti(progn(defvar *funcallable-instance-marker* (list "Funcallable Instance Marker"))(defmacro pcl-make-lexical-closure (size &aux (l (iterate(( i from 0 below size)) (collect (list (gensym) nil)))))  `(let ,l     #'(lambda (ignore &rest ignore-them-too) ignore ignore-them-too (error "Called a FIN without first setting its function.")  (values . ,(mapcar #'car l)))))(defmacro lexical-closure-environment (l)  `(cdr (si:%make-pointer si:dtp-list (cdr (si:%make-pointer si:dtp-list ,l)))))(defmacro lexical-closure-function (l)  `(car (si:%make-pointer si:dtp-list ,l)))(defun make-funcallable-instance-1 ()  (let* ((new-fin (pcl-make-lexical-closure #.funcallable-instance-closure-size )))    (setf (car (nthcdr (1- funcallable-instance-closure-size) (lexical-closure-environment new-fin)))  *funcallable-instance-marker*)     new-fin))(proclaim '(inline funcallable-instance-p ))(defun funcallable-instance-p (x)  (and (typep x 'ticl:lexical-closure)       (let ((env (lexical-closure-environment x))) (eq (nth (1- funcallable-instance-closure-size) env)     *funcallable-instance-marker*))))(defun set-funcallable-instance-function (fin new-value)  (cond ((not (funcallable-instance-p fin)) (error "~S is not a funcallable-instance"))((not (functionp new-value)) (error "~S is not a function."))((typep new-value 'si:lexical-closure) (let* ((fin-env (lexical-closure-environment fin))(new-env (lexical-closure-environment new-value))(new-env-size (length new-env))(fin-env-size (- funcallable-instance-closure-size (length funcallable-instance-data))))   (cond ((<= new-env-size fin-env-size)  (iterate ((i from 0 below new-env-size)    (new on new-env)    (fin on fin-env))    (setf (car fin) (car new)))  (setf (lexical-closure-function fin)(lexical-closure-function new-value))) (t      (set-funcallable-instance-function    fin    (make-trampoline new-value))))))(t (set-funcallable-instance-function fin    (make-trampoline new-value)))))(defun make-trampoline (function)  (let ((tmp))  #'(lambda (&rest args) tmp      (apply function args))))(defmacro funcallable-instance-data-1 (fin data)  `(let ((env (lexical-closure-environment ,fin)))     (nth (- funcallable-instance-closure-size    (funcallable-instance-data-position ,data)    2) env)))(defsetf funcallable-instance-data-1 (fin data) (new-value)  `(let ((env (lexical-closure-environment ,fin)))     (setf (car (nthcdr (- funcallable-instance-closure-size    (funcallable-instance-data-position ,data)    2) env))  ,new-value))));;;;;; In Xerox Common Lisp, a lexical closure is a pair of an environment and;;; CCODEP.  The environment is represented as a block.  There is space in;;; the top 8 bits of the pointers to the CCODE and the environment to use;;; to mark the closure as being a FIN.;;;      #+Xerox(progn(eval-when (compile eval)                        ;Check out the weird hair in  (il:loadcomp "{erinyes}<lyric>sources>LLCode"));funcallable-instance-data-1                                                 ;to why not load.(eval-when (compile load eval)  (il:blockrecord closure-overlay                  ((funcallable-instance-p il:flag))));(defvar *foo-table* (make-hash-table ))(defconstant funcallable-instance-closure-size 15)(defun make-funcallable-instance-1 ()  (let* ((env (il:\\allocblock funcallable-instance-closure-size t))         (fin (il:make-compiled-closure nil env)))   ;(setf (gethash fin *foo-table*) 't)    (il:replace (closure-overlay funcallable-instance-p) il:of fin il:with 't)    (set-funcallable-instance-function fin      #'(lambda (&rest ignore)          (declare (ignore ignore))          (error "Attempt to funcall a funcallable-instance without first~%~                  setting its funcallable-instance-function.")))    fin))(xcl:definline funcallable-instance-p (x) ;(gethash x *foo-table*)  (and (typep x 'il:compiled-closure)       (il:fetch (closure-overlay funcallable-instance-p) il:of x)))(defun set-funcallable-instance-function (fin new)  (cond ((not (funcallable-instance-p fin))         (error "~S is not a funcallable-instance" fin))        ((not (functionp new))         (error "~S is not a function." new))        ((typep new 'il:compiled-closure)         (let* ((fin-env                  (il:fetch (il:compiled-closure il:environment) il:of fin))                (new-env                  (il:fetch (il:compiled-closure il:environment) il:of new))                (new-env-size (il:\\#blockdatacells new-env))                (fin-env-size (- funcallable-instance-closure-size                                 (length funcallable-instance-data))))           (cond ((<= new-env-size fin-env-size)                  (iterate ((i from 0 below (* new-env-size 2) by 2))                    (il:\\rplptr fin-env                                 i                                 (il:\\getbaseptr new-env i)))                  (il:replace (il:compiled-closure il:fnheader)                              il:of fin                              (il:fetch (il:compiled-closure il:fnheader)                                        il:of new)))                 (t                  (set-funcallable-instance-function                    fin                    (make-trampoline new))))))           (t         (set-funcallable-instance-function fin                                            (make-trampoline new)))))(defun make-trampoline (function)  #'(lambda (&rest args)      (apply function args)))        (defmacro funcallable-instance-data-1 (fin data)  ;; This weird use of let and macroexpand here makes it possible not  ;; to have to load LLCode when compiling a file that contains a call  ;; to this macro.  `(let* ((fin ,fin)          (env ,(macroexpand '(il:fetch (il:compiled-closure il:environment)                                        il:of fin))))     (il:\\getbaseptr env                      (* (- funcallable-instance-closure-size                            (funcallable-instance-data-position ,data)                            1)                         2))))(defsetf funcallable-instance-data-1 (fin data) (new-value)  ;; This weird use of let and macroexpand here makes it possible not  ;; to have to load LLCode when compiling a file that contains a call  ;; to this macro.  `(let* ((fin ,fin)          (env ,(macroexpand '(il:fetch (il:compiled-closure il:environment)                                        il:of fin))))     (il:\\rplptr env                  (* (- funcallable-instance-closure-size                        (funcallable-instance-data-position ,data)                        1)                     2)                  ,new-value))));;;;;;; In Franz Common Lisp ExCL;;;;;; #+ExCL(progn(defconstant funcallable-instance-flag-bit #x1)(defun make-funcallable-instance-1 ()  (let ((new-fin (compiler::.primcall 'new-function)))    ;; Have to set the procedure function to something for two reasons.    ;;   1. someone might try to funcall it.    ;;   2. the flag bit that says the procedure is a funcallable    ;;      instance is set by set-funcallable-instance-function.    (set-funcallable-instance-function      new-fin      #'(lambda (&rest ignore)          (declare (ignore ignore))          (error "Attempt to funcall a funcallable-instance without first~%~                  setting its funcallable-instance-function.")))    new-fin))(defun funcallable-instance-p (x)   (and (excl::function-object-p x)        (eq funcallable-instance-flag-bit            (logand (excl::fn_flags x)                    funcallable-instance-flag-bit))))(defun set-funcallable-instance-function (fin new-value)   ;; we actually only check for a function object since   ;; this is called before the funcallable instance flag is set   (unless (excl::function-object-p fin)     (error "~S is not a funcallable-instance" fin))  (cond ((not (functionp new-value))         (error "~S is not a function." new-value))        ((not (excl::function-object-p new-value))         ;; new-value is an interpreted function.  Install a         ;; trampoline to call the interpreted function.         (set-funcallable-instance-function fin                                            (make-trampoline new-value)))        (t         ;; tack the instance variables at the end of the constant         ;; vector         (setf (excl::fn_start fin) (excl::fn_start new-value))         (setf (excl::fn_constant fin) (add-instance-vars                                        (excl::fn_constant new-value)                                        (excl::fn_constant fin)))         (setf (excl::fn_closure fin) (excl::fn_closure new-value))         (setf (excl::fn_symdef fin) (excl::fn_symdef new-value))         (setf (excl::fn_code fin) (excl::fn_code new-value))         (setf (excl::fn_formals fin) (excl::fn_formals new-value))         (setf (excl::fn_cframe-size fin) (excl::fn_cframe-size new-value))         (when (fboundp 'excl::fn_locals)           (setf (excl::fn_locals fin) (excl::fn_locals new-value)))         (setf (excl::fn_flags fin) (logior (excl::fn_flags new-value)                                            funcallable-instance-flag-bit)))))(defun make-trampoline (function)  #'(lambda (&rest args)      (apply function args)))(eval-when (eval) (compile 'make-trampoline))(defun add-instance-vars (cvec old-cvec)  ;; create a constant vector containing everything in the given constant  ;; vector plus space for the instance variables  (let* ((nconstants (cond (cvec (length cvec)) (t 0)))         (ndata (length funcallable-instance-data))         (old-cvec-length (if old-cvec (length old-cvec) 0))         (new-cvec nil))    (cond ((<= (+ nconstants ndata)  old-cvec-length)           (setq new-cvec old-cvec))          (t           (setq new-cvec (make-array (+ nconstants ndata)))           (when old-cvec             (dotimes (i ndata)               (setf (svref new-cvec (- (+ nconstants ndata) i 1))                     (svref old-cvec (- old-cvec-length i 1)))))))        (dotimes (i nconstants) (setf (svref new-cvec i) (svref cvec i)))        new-cvec))(defun funcallable-instance-data-1 (instance data)  (let ((constant (excl::fn_constant instance)))    (svref constant (- (length constant)                       (1+ (funcallable-instance-data-position data))))))(defsetf funcallable-instance-data-1 set-funcallable-instance-data-1)(defun set-funcallable-instance-data-1 (instance data new-value)  (let ((constant (excl::fn_constant instance)))    (setf (svref constant (- (length constant)                              (1+ (funcallable-instance-data-position data))))          new-value))));;;;;; In Vaxlisp;;; vanroggen%bach.DEC@DECWRL.DEC.COM;;; nelson%bach.DEC@DECWRL.DEC.COM;;; #+(and dec vax common)(progn;;; The following works only in Version 2 of VAXLISP, and will have to;;; be replaced for later versions.(defun make-funcallable-instance-1 ()  (list 'system::%compiled-closure%        ()        #'(lambda (&rest args)            (declare (ignore args))            (error "Calling uninitialized funcallable instance"))        (make-array (length funcallable-instance-data))))(proclaim '(inline funcallable-instance-p))(defun funcallable-instance-p (x)  (and (consp x)       (eq (car x) 'system::%compiled-closure%)       (not (null (cdddr x)))))(defun set-funcallable-instance-function (fin func)  (cond ((not (funcallable-instance-p fin))         (error "~S is not a funcallable-instance" fin))        ((not (functionp func))         (error "~S is not a function" func))        ((and (consp func) (eq (car func) 'system::%compiled-closure%))         (setf (cadr fin) (cadr func)               (caddr fin) (caddr func)))        (t (set-funcallable-instance-function fin                                              (make-trampoline func)))))(defun make-trampoline (function)  #'(lambda (&rest args)      (apply function args)))(eval-when (eval) (compile 'make-trampoline))(defmacro funcallable-instance-data-1 (instance data)  `(svref (cadddr ,instance)          (funcallable-instance-data-position ,data))));;; Implementation of funcallable instances for CMU Common Lisp.;;;;;; This code is based on the Lucid implementation.;;#+system:cmu;(progn;;(defconstant funcallable-instance-function-size 50);(defparameter *funcallable-instance-trampolines* NIL);;(defun make-funcallable-instance-1 ();  (let ((fin (system:%primitive alloc-function;                               funcallable-instance-function-size)));    (system:%primitive set-vector-subtype;                      fin;                      system:%function-funcallable-instance-subtype);    (set-funcallable-instance-function;      fin;      #'(lambda (&rest ignore);         (declare (ignore ignore));         (error "Attempt to call a funcallable-instance without first~%~;                  settings its funcallable-instance-function.")));    fin));;(defun funcallable-instance-p (x);  (and (lisp::compiled-function-p x);       (= (the fixnum (system:%primitive get-vector-subtype x));         system:%function-funcallable-instance-subtype)));;(defun set-funcallable-instance-function (fin new-value);  (unless (funcallable-instance-p fin);    (error "~S is not a funcallable-instance." fin));  (cond ((not (functionp new-value));        (error "~S is not a function." new-value));       ((not (compiled-function-p new-value));        (set-funcallable-instance-function fin (make-trampoline new-value)));       (t;        (let ((nps (system:%primitive header-length new-value));              (mps (the fixnum (- funcallable-instance-function-size;                                  (length funcallable-instance-data)))));          (declare (fixnum nps mps));          (cond ((< nps mps);                 (do ((i 0 (the fixnum (1+ i))));                     ((>= i nps));                   (declare (fixnum i));                   (system:%primitive header-set;                                      fin;                                      i;                                      (system:%primitive header-ref;                                                         new-value;                                                         i))));                (T;                 (push nps *funcallable-instance-trampolines*);                 (set-funcallable-instance-function;                   fin (make-trampoline new-value))))))));;;;; The following function is used to call non-compiled functions;;;; from a funcallable instance.  It makes some strong assumptions;;;; about the internal representation of CMU Common Lisp on the RT.;;;; Note that CMU Common Lisp uses a list to represent compiled;;;; closures so we can't do something simple and return a closure.;;(defun make-trampoline (function);  (let* ((of #'(lambda (&rest args) (apply 'x args)));        (ln (system:%primitive header-length of));        (nf (system:%primitive alloc-function ln)));    (do ((i 0 (the fixnum (1+ i))));       ((>= i ln));      (declare (fixnum i));      (system:%primitive header-set nf i (system:%primitive header-ref of i)));    (system:%primitive header-set nf (the fixnum (1- ln)) function);    nf));;(defmacro funcallable-instance-data-1 (fin data);  `(system:%primitive header-ref;                     ,fin;                     (- funcallable-instance-function-size;                        (funcallable-insance-data-position ,data);                        1)));;(defsetf funcallable-instance-data-1 (fin data) (new-value);  `(system:%primitive header-set;                     ,fin;                     (- funcallable-instance-function-size;                        (funcallable-insance-data-position ,data);                        1);                     ,new-value)););system:CMU;;;;;; Kyoto Common Lisp (KCL);;; yuasa%kurims.kurims.kyoto-u.junet@utokyo-relay.csnet;;; hagiya%kurims.kurims.kyoto-u.junet@utokyo-relay.csnet;;;;;; ibuki!rww@labraya.stanford.edu;;; ibuki!weaver@labraya.stanford.edu;;;;;; In KCL, compiled functions and compiled closures are defined as c structs.;;; This means that in order to access their fields, we have to use C code!;;; In the file kcl-low.lisp, there is some code which defines lisp functions;;; to access and change the values of the fields of compiled functions and;;; closures.  This code uses those functions.;;;#+KCL(progn(defvar *funcallable-instance-marker* (list "Funcallable Instance Marker"))(defconstant funcallable-instance-closure-size 15)(defun make-funcallable-instance-1 ()  (let ((fin (make-funcallable-instance-2))(env  (make-list funcallable-instance-closure-size :initial-element nil)))    (set-cclosure-env fin env)    (dotimes (i (1- funcallable-instance-closure-size)) (pop env))    (setf (car env) *funcallable-instance-marker*)    fin))(defun make-funcallable-instance-2 ()  (let ((what-a-dumb-closure-variable ()))    #'(lambda (&rest args)(declare (ignore args))(error "calling a funcallable instance without setting its function?")(setq what-a-dumb-closure-variable      (dummy-function what-a-dumb-closure-variable)))))(defun funcallable-instance-p (x)  (and (cclosurep x)       (let ((env (cclosure-env x))) (when (listp env)   (dotimes (i (1- funcallable-instance-closure-size)) (pop env))   (eq (car env) *funcallable-instance-marker*)))))(defun set-funcallable-instance-function (fin new-value)  (cond ((not (funcallable-instance-p fin))         (error "~S is not a funcallable-instance" fin))        ((not (functionp new-value))         (error "~S is not a function." new-value))        ((cclosurep new-value)         (let* ((fin-env (cclosure-env fin))                (new-env (cclosure-env new-value))                (new-env-size (length new-env))                (fin-env-size (- funcallable-instance-closure-size                                 (length funcallable-instance-data))))           (cond ((<= new-env-size fin-env-size)  (do ((i 0 (+ i 1))       (new-env-tail new-env (cdr new-env-tail))       (fin-env-tail fin-env (cdr fin-env-tail)))      ((= i fin-env-size))    (setf (car fin-env-tail)  (if (< i new-env-size)      (car new-env-tail)      nil)))    (set-cclosure-self fin (cclosure-self new-value))  (set-cclosure-data fin (cclosure-data new-value))  (set-cclosure-start fin (cclosure-start new-value))  (set-cclosure-size fin (cclosure-size new-value)))                 (t                                   (set-funcallable-instance-function                    fin                    (make-trampoline new-value))))))((typep new-value 'compiled-function) ;; Write NILs into the part of the cclosure environment that is ;; not being used to store the funcallable-instance-data.  Then ;; copy over the parts of the compiled function that need to be ;; copied over. (let ((env (cclosure-env fin)))   (dotimes (i (- funcallable-instance-closure-size  (length funcallable-instance-data)))     (setf (car env) nil)     (pop env))) (set-cclosure-self fin (cfun-self new-value)) (set-cclosure-data fin (cfun-data new-value)) (set-cclosure-start fin (cfun-start new-value)) (set-cclosure-size fin (cfun-size new-value)))         (t         (set-funcallable-instance-function fin                                            (make-trampoline new-value))))  fin)(defun make-trampoline (function)  #'(lambda (&rest args)      (apply function args)))(defun funcallable-instance-data-1 (fin data)  (let ((env (cclosure-env fin)))     (dotimes (i (- funcallable-instance-closure-size                    (funcallable-instance-data-position data)                    2))       (pop env))     (car env)))(defun set-funcallable-instance-data-1 (fin data new-value)  (let ((env (cclosure-env fin)))    (dotimes (i (- funcallable-instance-closure-size   (funcallable-instance-data-position data)   2))      (pop env))    (setf (car env) new-value)))(defsetf funcallable-instance-data-1 set-funcallable-instance-data-1));;;; Slightly Higher-Level stuff built on the implementation-dependent stuff.;;;;;;(defmacro funcallable-instance-class (fin)  `(class-wrapper-class (funcallable-instance-data-1 ,fin 'wrapper)))(defmacro funcallable-instance-wrapper (fin)  `(funcallable-instance-data-1 ,fin 'wrapper))(defmacro funcallable-instance-static-slots (fin)  `(funcallable-instance-data-1 ,fin 'static-slots))(defmacro funcallable-instance-dynamic-slots (fin)  `(funcallable-instance-data-1 ,fin 'dynamic-slots))(defun make-funcallable-instance (wrapper number-of-static-slots)  (let ((fin (make-funcallable-instance-1))        (static-slots          (%allocate-static-slot-storage--class number-of-static-slots))        (dynamic-slots              (%allocate-dynamic-slot-storage--class)))    (setf (funcallable-instance-wrapper fin) wrapper          (funcallable-instance-static-slots fin) static-slots          (funcallable-instance-dynamic-slots fin) dynamic-slots)    fin))gc gc)   (type rect-seq rectangles)   (type boolean fill-p)))(defun draw-arc (drawable gc x y width height angle1 angle2 &key fill-p)  ; Should be clever about appending to existing buffered protocol request.  (declare (type drawable drawable)   (type gc gc)   (type integer x y width height angle1 angle2)   (type boolean fill-p)))(defun draw-arcs (drawable gc arcs &key fill-p)  (declare (type drawable drawable)   (type gc gc)   (type arc-seq arcs)   (type boolean fill-p))); The following image routines are bare minimum.  It may be useful to define; some form of "image" object