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

Diff of /src/pcl/fin.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.9.1.1 by ram, Tue Jul 20 19:04:51 1993 UTC revision 1.23 by rtoy, Fri Mar 19 15:19:03 2010 UTC
# Line 23  Line 23 
23  ;;;  ;;;
24  ;;; Suggestions, comments and requests for improvements are also welcome.  ;;; Suggestions, comments and requests for improvements are also welcome.
25  ;;; *************************************************************************  ;;; *************************************************************************
26    
27    (file-comment
28      "$Header$")
29  ;;;  ;;;
30    
31    ;;    ;;
# Line 67  explicitly marked saying who wrote it. Line 70  explicitly marked saying who wrote it.
70  |#  |#
71    
72  (in-package :pcl)  (in-package :pcl)
73    (intl:textdomain "cmucl")
74    
75  ;;;  ;;;
76  ;;; The first part of the file contains the implementation dependent code to  ;;; The first part of the file contains the implementation dependent code to
# Line 106  explicitly marked saying who wrote it. Line 110  explicitly marked saying who wrote it.
110  ;;;       This must be SETF'able.  ;;;       This must be SETF'able.
111  ;;;  ;;;
112    
113  (eval-when (compile load eval)  (declaim (notinline called-fin-without-function))
 (defconstant funcallable-instance-data  
              '(wrapper slots)  
   "These are the 'data-slots' which funcallable instances have so that  
    the meta-class funcallable-standard-class can store class, and static  
    slots in them.")  
 )  
   
 (defmacro funcallable-instance-data-position (data)  
   (if (and (consp data)  
            (eq (car data) 'quote))  
       (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)))  
   
 (proclaim '(notinline called-fin-without-function))  
114  (defun called-fin-without-function (&rest args)  (defun called-fin-without-function (&rest args)
115    (declare (ignore args))    (declare (ignore args))
116    (error "Attempt to funcall a funcallable-instance without first~%~    (error _"~@<Attempt to funcall a funcallable instance without first ~
117            setting its funcallable-instance-function."))            setting its function.~@:>"))
   
   
 ;;;  
 ;;; 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.  
 ;;;  
 ;;; This code was largely written by JonL@Lucid.com.  Problems with it should  
 ;;; be referred to him.  
 ;;;  
 #+Lucid  
 (progn  
   
 (defconstant procedure-is-funcallable-instance-bit-position 10)  
   
 (defconstant fin-trampoline-fun-index lucid::procedure-literals)  
   
 (defconstant fin-size (+ fin-trampoline-fun-index  
                          (length funcallable-instance-data)  
                          1))  
   
 ;;;  
 ;;; The inner closure of this function will have its code vector replaced  
 ;;;  by a hand-coded fast jump to the function that is stored in the  
 ;;;  captured-lexical variable.  In effect, that code is a hand-  
 ;;;  optimized version of the code for this inner closure function.  
 ;;;  
 (defun make-trampoline (function)  
   (declare (optimize (speed 3) (safety 0)))  
   #'(lambda (&rest args)  
       (apply function args)))  
   
 (eval-when (eval)  
   (compile 'make-trampoline)  
   )  
   
   
 (defun binary-assemble (codes)  
   (let* ((ncodes (length codes))  
          (code-vec #-LCL3.0 (lucid::new-code ncodes)  
                    #+LCL3.0 (lucid::with-current-area  
                                 lucid::*READONLY-NON-POINTER-AREA*  
                               (lucid::new-code ncodes))))  
     (declare (fixnum ncodes))  
     (do ((l codes (cdr l))  
          (i 0 (1+ i)))  
         ((null l) nil)  
       (declare (fixnum i))  
       (setf (lucid::code-ref code-vec i) (car l)))  
     code-vec))  
   
 ;;;  
 ;;; Egad! Binary patching!  
 ;;; See comment following definition of MAKE-TRAMPOLINE -- this is just  
 ;;;  the "hand-optimized" machine instructions to make it work.  
 ;;;  
 (defvar *mattress-pad-code*  
         (binary-assemble  
                 #+MC68000  
                 '(#x2A6D #x11 #x246D #x1 #x4EEA #x5)  
                 #+SPARC  
                 (ecase (lucid::procedure-length #'lucid::false)  
                   (5  
                    '(#xFA07 #x6012 #xDE07 #x7FFE #x81C3 #xFFFE #x100 #x0))  
                   (8  
                    `(#xFA07 #x601E #xDE07 #x7FFE #x81C3 #xFFFE #x100 #x0)))  
                 #+(and BSP (not LCL3.0 ))  
                 '(#xCD33 #x11 #xCDA3 #x1 #xC19A #x5 #xE889)  
                 #+(and BSP LCL3.0)  
                 '(#x7733 #x7153 #xC155 #x5 #xE885)  
                 #+I386  
                 '(#x87 #xD2 #x8B #x76 #xE #xFF #x66 #xFE)  
                 #+VAX  
                 '(#xD0 #xAC #x11 #x5C #xD0 #xAC #x1 #x57 #x17 #xA7 #x5)  
                 #+PA  
                 '(#x4891 #x3C #xE461 #x6530 #x48BF #x3FF9)  
                 #+MIPS  
                 '(#x8FD4 #x1E #x2785 #x2EEF #xA0 #x8 #x14 #xF000)  
                 #-(or MC68000 SPARC BSP I386 VAX PA MIPS)  
                 '(0 0 0 0)))  
   
   
 (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))))  
   
 (lucid::defsubst set-funcallable-instance-p (x)  
   (if (not (lucid::procedurep x))  
       (error "Can't make a non-procedure a fin.")  
       (setf (lucid::procedure-ref x lucid::procedure-flags)  
             (logior (expt 2 procedure-is-funcallable-instance-bit-position)  
                     (the fixnum  
                          (lucid::procedure-ref x lucid::procedure-flags))))))  
   
   
 (defun allocate-funcallable-instance-1 ()  
   #+Prime  
   (declare (notinline lucid::new-procedure))    ;fixes a bug in Prime 1.0 in  
                                                 ;which new-procedure expands  
                                                 ;incorrectly  
   (let ((new-fin (lucid::new-procedure fin-size))  
         (fin-index fin-size))  
     (declare (fixnum fin-index)  
              (type lucid::procedure new-fin))  
     (dotimes (i (length funcallable-instance-data))  
       ;; Initialize the new funcallable-instance.  As part of our contract,  
       ;; we have to make sure the initial value of all the funcallable  
       ;; instance data slots is NIL.  
       (decf fin-index)  
       (setf (lucid::procedure-ref new-fin fin-index) nil))  
     ;;  
     ;; "Assemble" the initial function by installing a fast "trampoline" code;  
     ;;  
     (setf (lucid::procedure-ref new-fin lucid::procedure-code)  
           *mattress-pad-code*)  
     ;; Disable argcount checking in the "mattress-pad" code for  
     ;;  ports that go through standardized trampolines  
     #+PA (setf (sys:procedure-ref new-fin lucid::procedure-arg-count) -1)  
     #+MIPS (progn  
              (setf (sys:procedure-ref new-fin lucid::procedure-min-args) 0)  
              (setf (sys:procedure-ref new-fin lucid::procedure-max-args)  
                    call-arguments-limit))  
     ;; but start out with the function to be run as an error call.  
     (setf (lucid::procedure-ref new-fin fin-trampoline-fun-index)  
           #'called-fin-without-function)  
     ;; Then mark it as a "fin"  
     (set-funcallable-instance-p new-fin)  
     new-fin))  
   
 (defun set-funcallable-instance-function (fin new-value)  
   (unless (funcallable-instance-p fin)  
     (error "~S is not a funcallable-instance" fin))  
   (if (lucid::procedurep new-value)  
       (progn  
         (setf (lucid::procedure-ref fin fin-trampoline-fun-index) new-value)  
         fin)  
       (progn  
         (unless (functionp new-value)  
           (error "~S is not a function." 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)))))  
   
 (defmacro funcallable-instance-data-1 (instance data)  
   `(lucid::procedure-ref  
            ,instance  
            (the fixnum  
                 (- (- fin-size 1)  
                    (the fixnum (funcallable-instance-data-position ,data))))))  
   
 );end of #+Lucid  
   
   
 ;;;  
 ;;; In Symbolics Common Lisp, a lexical closure is a pair of an environment  
 ;;; and an ordinary compiled function.  The environment is represented as  
 ;;; a CDR-coded list.  I know of no 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.  
 ;;;  
 ;;;  The new structure of a fin is:  
 ;;;     (lex-env lex-fun *marker* fin-data0 fin-data1)  
 ;;;  The value returned by allocate is a lexical-closure pointing to the start  
 ;;;  of the fin list.  Benefits are: no longer ever have to copy environments,  
 ;;;  fins can be much smaller (5 words instead of 18), old environments never  
 ;;;  get destroyed (so running dcodes dont have the lex env change from under  
 ;;;  them any longer).  
 ;;;  
 ;;;  Most of the fin operations speed up a little (by as much as 30% on a  
 ;;;  3650), at least one nasty bug is fixed, and so far at least I've not  
 ;;;  seen any problems at all with this code.   - mike thome (mthome@bbn.com)  
 ;;;  
 #+(and Genera (not Genera-Release-8))  
 (progn  
   
 (defvar *funcallable-instance-marker* (list "Funcallable Instance Marker"))  
   
 (defun allocate-funcallable-instance-1 ()  
   (let* ((whole-fin (make-list (+ 3 (length funcallable-instance-data))))  
          (new-fin (sys:%make-pointer-offset sys:dtp-lexical-closure  
                                             whole-fin  
                                             0)))  
     ;;  
     ;; note that we DO NOT turn the real lex-closure part of the fin into  
     ;; a dotted pair, because (1) the machine doesn't care and (2) if we  
     ;; did the garbage collector would reclaim everything after the lexical  
     ;; function.  
     ;;  
     (setf (sys:%p-contents-offset new-fin 2) *funcallable-instance-marker*)  
     (setf (si:lexical-closure-function new-fin)  
           #'(lambda (ignore &rest ignore-them-too)  
               (declare (ignore ignore ignore-them-too))  
               (called-fin-without-function)))  
     #+ignore  
     (setf (si:lexical-closure-environment new-fin) nil)  
     new-fin))  
   
 (scl:defsubst funcallable-instance-p (x)  
   (declare (inline si:lexical-closure-p))  
   (and (si:lexical-closure-p x)  
        (= (sys:%p-cdr-code (sys:%make-pointer-offset sys:dtp-compiled-function x 1))  
           sys:cdr-next)  
        (eq (sys:%p-contents-offset x 2) *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 (or (functionp new-value)  
                   (and (consp new-value)  
                        (eq (car new-value) 'si:digested-lambda))))  
          (error "~S is not a function." new-value))  
         ((and (si:lexical-closure-p new-value)  
               (compiled-function-p (si:lexical-closure-function new-value)))  
          (let ((env (si:lexical-closure-environment new-value))  
                (fn  (si:lexical-closure-function new-value)))  
            ;; we only have to copy the pointers!!  
            (setf (si:lexical-closure-environment fin) env  
                  (si:lexical-closure-function fin)    fn)  
 ;          (dbg:set-env->fin env fin)  
            ))  
         (t  
          (set-funcallable-instance-function fin  
                                             (make-trampoline new-value)))))  
   
 (defun make-trampoline (function)  
   (declare (optimize (speed 3) (safety 0)))  
   #'(lambda (&rest args)  
       #+Genera (declare (dbg:invisible-frame :pcl-internals))  
       (apply function args)))  
   
 (defmacro funcallable-instance-data-1 (fin data)  
   `(sys:%p-contents-offset ,fin  
                            (+ 3 (funcallable-instance-data-position ,data))))  
   
 (defsetf funcallable-instance-data-1 (fin data) (new-value)  
   `(setf (sys:%p-contents-offset ,fin  
                                  (+ 3 (funcallable-instance-data-position ,data)))  
          ,new-value))  
   
 ;;;  
 ;;; Make funcallable instances print out properly.  
 ;;;  
 (defvar *print-lexical-closure* nil)  
   
 (defun pcl-print-lexical-closure (exp stream slashify-p &optional (depth 0))  
   (declare (ignore depth))  
   (declare (special *boot-state*))  
   (if (or (eq *print-lexical-closure* exp)  
           (neq *boot-state* 'complete)  
           (eq (class-of exp) *the-class-t*))  
       (let ((*print-lexical-closure* nil))  
         (funcall (original-definition 'si:print-lexical-closure)  
                  exp stream slashify-p))  
       (let ((*print-escape* slashify-p)  
             (*print-lexical-closure* exp))  
         (print-object exp stream))))  
   
 (unless (boundp '*boot-state*)  
   (setq *boot-state* nil))  
   
 (redefine-function 'si:print-lexical-closure 'pcl-print-lexical-closure)  
   
 (defvar *function-name-level* 0)  
   
 (defun pcl-function-name (function &rest other-args)  
   (if (and (eq *boot-state* 'complete)  
            (funcallable-instance-p function)  
            (generic-function-p function)  
            (<= *function-name-level* 2))  
       (let ((*function-name-level* (1+ *function-name-level*)))  
         (generic-function-name function))  
       (apply (original-definition 'si:function-name) function other-args)))  
   
 (redefine-function 'si:function-name 'pcl-function-name)  
   
 (defun pcl-arglist (function &rest other-args)  
   (let ((defn nil))  
     (cond ((and (funcallable-instance-p function)  
                 (generic-function-p function))  
            (generic-function-pretty-arglist function))  
           ((and (sys:validate-function-spec function)  
                 (sys:fdefinedp function)  
                 (setq defn (sys:fdefinition function))  
                 (funcallable-instance-p defn)  
                 (generic-function-p defn))  
            (generic-function-pretty-arglist defn))  
           (t (apply (original-definition 'zl:arglist) function other-args)))))  
   
 (redefine-function 'zl:arglist 'pcl-arglist)  
   
   
 ;;;  
 ;;; This code is adapted from frame-lexical-environment and frame-function.  
 ;;;  
 #||  
 dbg:  
 (progn  
   
 (defvar *old-frame-function*)  
   
 (defvar *inside-new-frame-function* nil)  
   
 (defun new-frame-function (frame)  
   (let* ((fn (funcall *old-frame-function* frame))  
          (location (%pointer-plus frame #+imach (defstorage-size stack-frame) #-imach 0))  
          (env? #+3600 (location-contents location)  
                #+imach (%memory-read location :cycle-type %memory-scavenge)))  
     (or (when (cl:consp env?)  
           (let ((l2 (last2 env?)))  
             (when (eq (car l2) '.this-is-a-dfun.)  
               (cadr l2))))  
         fn)))  
   
 (defun pcl::doctor-dfun-for-the-debugger (gf dfun)  
   (when (sys:lexical-closure-p dfun)  
     (let* ((env (si:lexical-closure-environment dfun))  
            (l2 (last2 env)))  
       (unless (eq (car l2) '.this-is-a-dfun.)  
         (setf (si:lexical-closure-environment dfun)  
               (nconc env (list '.this-is-a-dfun. gf))))))  
   dfun)  
   
 (defun last2 (l)  
   (labels ((scan (2ago tail)  
              (if (null tail)  
                  2ago  
                  (if (cl:consp tail)  
                      (scan (cdr 2ago) (cdr tail))  
                      nil))))  
     (and (cl:consp l)  
          (cl:consp (cdr l))  
          (scan l (cddr l)))))  
   
 (eval-when (load)  
   (unless (boundp '*old-frame-function*)  
     (setq *old-frame-function* #'frame-function)  
     (setf (cl:symbol-function 'frame-function) 'new-frame-function)))  
   
 )  
 ||#  
   
 );end of #+Genera  
   
   
   
 ;;;  
 ;;; In Genera 8.0, we use a real funcallable instance (from Genera CLOS) for this.  
 ;;; This minimizes the subprimitive mucking around.  
 ;;;  
 #+(and Genera Genera-Release-8)  
 (progn  
   
 (clos-internals::ensure-class  
   'pcl-funcallable-instance  
   :direct-superclasses '(clos-internals:funcallable-instance)  
   :slots `((:name function  
             :initform #'(lambda (ignore &rest ignore-them-too)  
                           (declare (ignore ignore ignore-them-too))  
                           (called-fin-without-function))  
             :initfunction ,#'(lambda nil  
                                #'(lambda (ignore &rest ignore-them-too)  
                                    (declare (ignore ignore ignore-them-too))  
                                    (called-fin-without-function))))  
            ,@(mapcar #'(lambda (slot) `(:name ,slot)) funcallable-instance-data))  
   :metaclass 'clos:funcallable-standard-class)  
   
 (defun pcl-funcallable-instance-trampoline (extra-arg &rest args)  
   (apply (sys:%instance-ref (clos-internals::%dispatch-instance-from-extra-argument extra-arg)  
                             3)  
          args))  
   
 (defun allocate-funcallable-instance-1 ()  
   (let ((fin (clos:make-instance 'pcl-funcallable-instance)))  
     (setf (clos-internals::%funcallable-instance-function fin)  
           #'pcl-funcallable-instance-trampoline)  
     (setf (clos-internals::%funcallable-instance-extra-argument fin)  
           (sys:%make-pointer sys:dtp-instance  
                              (clos-internals::%funcallable-instance-extra-argument fin)))  
     (setf (clos:slot-value fin 'clos-internals::funcallable-instance) fin)  
     fin))  
   
 (scl:defsubst funcallable-instance-p (x)  
   (and (sys:funcallable-instance-p x)  
        (eq (clos-internals::%funcallable-instance-function x)  
            #'pcl-funcallable-instance-trampoline)))  
   
 (defun set-funcallable-instance-function (fin new-value)  
   (setf (clos:slot-value fin 'function) new-value))  
   
 (defmacro funcallable-instance-data-1 (fin data)  
   `(clos-internals:%funcallable-instance-ref  
      ,fin (+ 4 (funcallable-instance-data-position ,data))))  
   
 (defsetf funcallable-instance-data-1 (fin data) (new-value)  
   `(setf (clos-internals:%funcallable-instance-ref  
            ,fin (+ 4 (funcallable-instance-data-position ,data)))  
          ,new-value))  
   
 (clos:defmethod clos:print-object ((fin pcl-funcallable-instance) stream)  
   (print-object fin stream))  
   
 (clos:defmethod clos-internals:debugging-information-function ((fin pcl-funcallable-instance))  
   nil)  
   
 (clos:defmethod clos-internals:function-name-object ((fin pcl-funcallable-instance))  
   (declare (special *boot-state*))  
   (if (and (eq *boot-state* 'complete)  
            (generic-function-p fin))  
       (generic-function-name fin)  
       fin))  
   
 (clos:defmethod clos-internals:arglist-object ((fin pcl-funcallable-instance))  
   (declare (special *boot-state*))  
   (if (and (eq *boot-state* 'complete)  
            (generic-function-p fin))  
       (generic-function-pretty-arglist fin)  
       '(&rest args)))  
   
 );end of #+Genera  
   
   
   
 #+Cloe-Runtime  
 (progn  
   
 (defconstant funcallable-instance-closure-slots 5)  
 (defconstant funcallable-instance-closure-size  
              (+ funcallable-instance-closure-slots (length funcallable-instance-data) 1))  
   
 #-CLOE-Release-2 (progn  
   
 (defun allocate-funcallable-instance-1 ()  
   (let ((data (system::make-funcallable-structure 'funcallable-instance  
                                                   funcallable-instance-closure-size)))  
     (setf (system::%trampoline-ref data funcallable-instance-closure-slots)  
           'funcallable-instance)  
     (set-funcallable-instance-function  
       data  
       #'(lambda (&rest ignore-them-too)  
           (declare (ignore ignore-them-too))  
           (called-fin-without-function)))  
     data))  
   
 (proclaim '(inline funcallable-instance-p))  
 (defun funcallable-instance-p (x)  
   (and (typep x 'system::trampoline)  
        (= (system::%trampoline-data-length x) funcallable-instance-closure-size)  
        (eq (system::%trampoline-ref x funcallable-instance-closure-slots)  
            'funcallable-instance)))  
   
 (defun set-funcallable-instance-function (fin new-value)  
   (when (not (funcallable-instance-p fin))  
     (error "~S is not a funcallable-instance" fin))  
   (etypecase new-value  
     (system::trampoline  
       (let ((length (system::%trampoline-data-length new-value)))  
         (cond ((> length funcallable-instance-closure-slots)  
                (set-funcallable-instance-function  
                  fin  
                  #'(lambda (&rest args)  
                      (declare (sys:downward-rest-argument))  
                      (apply new-value args))))  
               (t  
                (setf (system::%trampoline-function fin)  
                      (system::%trampoline-function new-value))  
                (dotimes (i length)  
                  (setf (system::%trampoline-ref fin i)  
                        (system::%trampoline-ref new-value i)))))))  
     (compiled-function  
       (setf (system::%trampoline-function fin) new-value))  
     (function  
       (set-funcallable-instance-function  
         fin  
         #'(lambda (&rest args)  
             (declare (sys:downward-rest-argument))  
             (apply new-value args))))))  
   
 (defmacro funcallable-instance-data-1 (fin data)  
   `(system::%trampoline-ref ,fin (+ funcallable-instance-closure-slots  
                                     1 (funcallable-instance-data-position ,data))))  
   
 (defsetf funcallable-instance-data-1 (fin data) (new-value)  
   `(setf (system::%trampoline-ref ,fin (+ funcallable-instance-closure-slots  
                                           1 (funcallable-instance-data-position ,data)))  
          ,new-value))  
   
 )  
   
 #+CLOE-Release-2 (progn  
   
 (defun allocate-funcallable-instance-1 ()  
   (let ((data (si::cons-closure funcallable-instance-closure-size)))  
     (setf (si::closure-ref data funcallable-instance-closure-slots) 'funcallable-instance)  
     (set-funcallable-instance-function  
       data  
       #'(lambda (&rest ignore-them-too)  
           (declare (ignore ignore-them-too))  
           (error "Called a FIN without first setting its function.")))  
     data))  
   
 (proclaim '(inline funcallable-instance-p))  
 (defun funcallable-instance-p (x)  
   (and (si::closurep x)  
        (= (si::closure-length x) funcallable-instance-closure-size)  
        (eq (si::closure-ref x funcallable-instance-closure-slots) 'funcallable-instance)))  
   
 (defun set-funcallable-instance-function (fin new-value)  
   (when (not (funcallable-instance-p fin))  
     (error "~S is not a funcallable-instance" fin))  
   (etypecase new-value  
     (si::closure  
       (let ((length (si::closure-length new-value)))  
         (cond ((> length funcallable-instance-closure-slots)  
                (set-funcallable-instance-function  
                  fin  
                  #'(lambda (&rest args)  
                      (declare (sys:downward-rest-argument))  
                      (apply new-value args))))  
               (t  
                (setf (si::closure-function fin) (si::closure-function new-value))  
                (dotimes (i length)  
                  (si::object-set fin (+ i 3) (si::object-ref new-value (+ i 3))))))))  
     (compiled-function  
       (setf (si::closure-function fin) new-value))  
     (function  
       (set-funcallable-instance-function  
         fin  
         #'(lambda (&rest args)  
             (declare (sys:downward-rest-argument))  
             (apply new-value args))))))  
   
 (defmacro funcallable-instance-data-1 (fin data)  
   `(si::closure-ref ,fin (+ funcallable-instance-closure-slots  
                             1 (funcallable-instance-data-position ,data))))  
   
 (defsetf funcallable-instance-data-1 (fin data) (new-value)  
   `(setf (si::closure-ref ,fin (+ funcallable-instance-closure-slots  
                                   1 (funcallable-instance-data-position ,data)))  
          ,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.  
 ;;;  
 ;;; To help the debugger figure out when it has found a FIN on the stack, we  
 ;;; reserve the last element of the closure environment to use to point back  
 ;;; to the actual fin.  
 ;;;  
 ;;; Note that there is code in xerox-low which lets us access the fields of  
 ;;; compiled-closures and which defines the closure-overlay record.  That  
 ;;; code is there because there are some clients of it in that file.  
 ;;;  
 #+Xerox  
 (progn  
   
 ;; Don't be fooled.  We actually allocate one bigger than this to have a place  
 ;; to store the backpointer to the fin.  -smL  
 (defconstant funcallable-instance-closure-size 15)  
   
 ;; This is only used in the file PCL-ENV.  
 (defvar *fin-env-type*  
   (type-of (il:\\allocblock (1+ funcallable-instance-closure-size) t)))  
   
 ;; Well, Gregor may be too proud to hack xpointers, but bvm and I aren't. -smL  
   
 (defstruct fin-env-pointer  
   (pointer nil :type il:fullxpointer))  
   
 (defun fin-env-fin (fin-env)  
   (fin-env-pointer-pointer  
    (il:\\getbaseptr fin-env (* funcallable-instance-closure-size 2))))  
   
 (defun |set fin-env-fin| (fin-env new-value)  
   (il:\\rplptr fin-env (* funcallable-instance-closure-size 2)  
                (make-fin-env-pointer :pointer new-value))  
   new-value)  
   
 (defsetf fin-env-fin |set fin-env-fin|)  
   
 ;; The finalization function that will clean up the backpointer from the  
 ;; fin-env to the fin.  This needs to be careful to not cons at all.  This  
 ;; depends on there being no other finalization function on compiled-closures,  
 ;; since there is only one finalization function per datatype.  Too bad.  -smL  
 (defun finalize-fin (fin)  
   ;; This could use the fn funcallable-instance-p, but if we get here we know  
   ;; that this is a closure, so we can skip that test.  
   (when (il:fetch (closure-overlay funcallable-instance-p) il:of fin)  
     (let ((env (il:fetch (il:compiled-closure il:environment) il:of fin)))  
       (when env  
         (setq env  
               (il:\\getbaseptr env (* funcallable-instance-closure-size 2)))  
         (when (il:typep env 'fin-env-pointer)  
           (setf (fin-env-pointer-pointer env) nil)))))  
   nil)                                  ;Return NIL so GC can proceed  
   
 (eval-when (load)  
   ;; Install the above finalization function.  
   (when (fboundp 'finalize-fin)  
     (il:\\set.finalization.function 'il:compiled-closure 'finalize-fin)))  
   
 (defun allocate-funcallable-instance-1 ()  
   (let* ((env (il:\\allocblock (1+ funcallable-instance-closure-size) t))  
          (fin (il:make-compiled-closure nil env)))  
     (setf (fin-env-fin env) fin)  
     (il:replace (closure-overlay funcallable-instance-p) il:of fin il:with 't)  
     (set-funcallable-instance-function fin  
       #'(lambda (&rest ignore)  
           (declare (ignore ignore))  
           (called-fin-without-function)))  
     fin))  
   
 (xcl:definline funcallable-instance-p (x)  
   (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 (if new-env (il:\\#blockdatacells new-env) 0))  
                 (fin-env-size (- funcallable-instance-closure-size  
                                  (length funcallable-instance-data))))  
            (cond ((and new-env  
                        (<= new-env-size fin-env-size))  
                   (dotimes (i fin-env-size)  
                     (il:\\rplptr fin-env  
                                  (* i 2)  
                                  (if (< i new-env-size)  
                                      (il:\\getbaseptr new-env (* i 2))  
                                      nil)))  
                   (setf (compiled-closure-fnheader fin)  
                         (compiled-closure-fnheader 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)  
   `(il:\\getbaseptr (il:fetch (il:compiled-closure il:environment) il:of ,fin)  
                     (* (- funcallable-instance-closure-size  
                           (funcallable-instance-data-position ,data)  
                           1)                    ;Reserve last element to  
                                                 ;point back to actual FIN!  
                        2)))  
   
 (defsetf funcallable-instance-data-1 (fin data) (new-value)  
   `(il:\\rplptr (il:fetch (il:compiled-closure il:environment) il:of ,fin)  
                 (* (- funcallable-instance-closure-size  
                       (funcallable-instance-data-position ,data)  
                       1)  
                    2)  
                 ,new-value))  
   
 );end of #+Xerox  
   
   
 ;;;  
 ;;; In Franz Common Lisp ExCL  
 ;;; This code was originally written by:  
 ;;;   jkf%franz.uucp@berkeley.edu  
 ;;; and hacked by:  
 ;;;   smh%franz.uucp@berkeley.edu  
   
 #+ExCL  
 (progn  
   
 (defconstant funcallable-instance-flag-bit #x1)  
   
 (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 make-trampoline (function)  
   #'(lambda (&rest args)  
       (apply function args)))  
   
 ;; We initialize a fin's procedure function to this because  
 ;; someone might try to funcall it before it has been set up.  
 (defun init-fin-fun (&rest ignore)  
   (declare (ignore ignore))  
   (called-fin-without-function))  
   
   
 (eval-when (eval)  
   (compile 'make-trampoline)  
   (compile 'init-fin-fun))  
   
   
 ;; new style  
 #+(and gsgc (not sun4) (not cray) (not mips))  
 (progn  
 ;; set-funcallable-instance-function must work by overwriting the fin itself  
 ;; because the fin must maintain EQ identity.  
 ;; Because the gsgc time needs several of the fields in the function object  
 ;; at gc time in order to walk the stack frame, it is important never to bash  
 ;; a function object that is active in a frame on the stack.  Besides, changing  
 ;; the functions closure vector, not to mention overwriting its constant  
 ;; vector, would scramble it's execution when that stack frame continues.  
 ;; Therefore we represent a fin as a funny compiled-function object.  
 ;; The code vector of this object has some hand-coded instructions which  
 ;; do a very fast jump into the real fin handler function.  The function  
 ;; which is the fin object *never* creates a frame on the stack.  
   
   
 (defun allocate-funcallable-instance-1 ()  
   (let ((fin (compiler::.primcall 'sys::new-function))  
         (init #'init-fin-fun)  
         (mattress-fun #'funcallable-instance-mattress-pad))  
     (setf (excl::fn_symdef fin) 'anonymous-fin)  
     (setf (excl::fn_constant fin) init)  
     (setf (excl::fn_code fin)           ; this must be before fn_start  
           (excl::fn_code mattress-fun))  
     (setf (excl::fn_start fin) (excl::fn_start mattress-fun))  
     (setf (excl::fn_flags fin) (logior (excl::fn_flags init)  
                                        funcallable-instance-flag-bit))  
     (setf (excl::fn_closure fin)  
       (make-array (length funcallable-instance-data)))  
   
     fin))  
   
 ;; This function gets its code vector modified with a hand-coded fast jump  
 ;; to the function that is stored in place of its constant vector.  
 ;; This function is never linked in and never appears on the stack.  
   
 (defun funcallable-instance-mattress-pad ()  
   (declare (optimize (speed 3) (safety 0)))  
   'nil)  
   
 (eval-when (eval)  
   (compile 'funcallable-instance-mattress-pad))  
   
   
 #+(and excl (target-class s))  
 (eval-when (load eval)  
   (let ((codevec (excl::fn_code  
                   (symbol-function 'funcallable-instance-mattress-pad))))  
     ;; The entire code vector wants to be:  
     ;;   move.l  7(a2),a2     ;#x246a0007  
     ;;   jmp     1(a2)        ;#x4eea0001  
     (setf (aref codevec 0) #x246a  
           (aref codevec 1) #x0007  
           (aref codevec 2) #x4eea  
           (aref codevec 3) #x0001))  
 )  
   
 #+(and excl (target-class a))  
 (eval-when (load eval)  
   (let ((codevec (excl::fn_code  
                   (symbol-function 'funcallable-instance-mattress-pad))))  
     ;; The entire code vector wants to be:  
     ;;   l       r5,15(r5)    ;#x5850500f  
     ;;   l       r15,11(r5)   ;#x58f0500b  
     ;;   br      r15          ;#x07ff  
     (setf (aref codevec 0) #x5850  
           (aref codevec 1) #x500f  
           (aref codevec 2) #x58f0  
           (aref codevec 3) #x500b  
           (aref codevec 4) #x07ff  
           (aref codevec 5) #x0000))  
   )  
   
 #+(and excl (target-class i))  
 (eval-when (load eval)  
   (let ((codevec (excl::fn_code  
                   (symbol-function 'funcallable-instance-mattress-pad))))  
     ;; The entire code vector wants to be:  
     ;;   movl  7(edx),edx     ;#x07528b  
     ;;   jmp   *3(edx)        ;#x0362ff  
     (setf (aref codevec 0) #x8b  
           (aref codevec 1) #x52  
           (aref codevec 2) #x07  
           (aref codevec 3) #xff  
           (aref codevec 4) #x62  
           (aref codevec 5) #x03))  
 )  
   
 (defun funcallable-instance-data-1 (instance data)  
   (let ((constant (excl::fn_closure instance)))  
     (svref constant (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_closure instance)))  
     (setf (svref constant (funcallable-instance-data-position data))  
           new-value)))  
   
 (defun set-funcallable-instance-function (fin new-function)  
   (unless (funcallable-instance-p fin)  
     (error "~S is not a funcallable-instance" fin))  
   (unless (functionp new-function)  
     (error "~S is not a function." new-function))  
   (setf (excl::fn_constant fin)  
         (if (excl::function-object-p new-function)  
             new-function  
             ;; The new-function is an interpreted function.  
             ;; Install a trampoline to call the interpreted function.  
             (make-trampoline new-function))))  
   
   
 )  ;; end sun3  
   
   
 #+(and gsgc (or sun4 mips))  
 (progn  
   
 (eval-when (compile load eval)  
   (defconstant funcallable-instance-constant-count 15)  
   )  
   
 (defun allocate-funcallable-instance-1 ()  
   (let ((new-fin (compiler::.primcall  
                    'sys::new-function  
                    funcallable-instance-constant-count)))  
     ;; 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 #'init-fin-fun)  
     new-fin))  
   
 (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)))  
         ((> (+ (excl::function-constant-count new-value)  
                (length funcallable-instance-data))  
             funcallable-instance-constant-count)  
          ; can't fit, must trampoline  
          (set-funcallable-instance-function fin (make-trampoline new-value)))  
         (t  
          ;; tack the instance variables at the end of the constant vector  
   
          (setf (excl::fn_code fin)      ; this must be before fn_start  
                (excl::fn_code new-value))  
          (setf (excl::fn_start fin) (excl::fn_start new-value))  
   
          (setf (excl::fn_closure fin) (excl::fn_closure new-value))  
          ; only replace the symdef slot if the new value is an  
          ; interned symbol or some other object (like a function spec)  
          (let ((newsym (excl::fn_symdef new-value)))  
            (excl:if* (and newsym (or (not (symbolp newsym))  
                                 (symbol-package newsym)))  
               then (setf (excl::fn_symdef fin) newsym)))  
          (setf (excl::fn_formals fin) (excl::fn_formals new-value))  
          (setf (excl::fn_cframe-size fin) (excl::fn_cframe-size new-value))  
          (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))  
   
          ;; on a sun4 we copy over the constants  
          (dotimes (i (excl::function-constant-count new-value))  
            (setf (excl::function-constant fin i)  
                  (excl::function-constant new-value i)))  
          ;(format t "all done copy from ~s to ~s" new-value fin)  
          )))  
   
 (defmacro funcallable-instance-data-1 (instance data)  
   `(excl::function-constant ,instance  
                            (- funcallable-instance-constant-count  
                               (funcallable-instance-data-position ,data)  
                               1)))  
   
 ) ;; end sun4 or mips  
   
 #+(and gsgc cray)  
 (progn  
   
 ;; The cray is like the sun4 in that the constant vector is included in the  
 ;; function object itself.  But a mattress pad must be used anyway, because  
 ;; the function start address is copied in the symbol object, and cannot be  
 ;; updated when the fin is changed.  
 ;; We place the funcallable-instance-function into the first constant slot,  
 ;; and leave enough constant slots after that for the instance data.  
   
 (eval-when (compile load eval)  
   (defconstant fin-fun-slot 0)  
   (defconstant fin-instance-data-slot 1)  
   )  
   
   
 ;; We initialize a fin's procedure function to this because  
 ;; someone might try to funcall it before it has been set up.  
 (defun init-fin-fun (&rest ignore)  
   (declare (ignore ignore))  
   (called-fin-without-function))  
   
 (defun allocate-funcallable-instance-1 ()  
   (let ((fin (compiler::.primcall 'sys::new-function  
                         (1+ (length funcallable-instance-data))  
                         "funcallable-instance"))  
         (init #'init-fin-fun)  
         (mattress-fun #'funcallable-instance-mattress-pad))  
     (setf (excl::fn_symdef fin) 'anonymous-fin)  
     (setf (excl::function-constant fin fin-fun-slot) init)  
     (setf (excl::fn_code fin)           ; this must be before fn_start  
       (excl::fn_code mattress-fun))  
     (setf (excl::fn_start fin) (excl::fn_start mattress-fun))  
     (setf (excl::fn_flags fin) (logior (excl::fn_flags init)  
                                        funcallable-instance-flag-bit))  
   
     fin))  
   
 ;; This function gets its code vector modified with a hand-coded fast jump  
 ;; to the function that is stored in place of its constant vector.  
 ;; This function is never linked in and never appears on the stack.  
   
 (defun funcallable-instance-mattress-pad ()  
   (declare (optimize (speed 3) (safety 0)))  
   'nil)  
   
 (eval-when (eval)  
   (compile 'funcallable-instance-mattress-pad)  
   (compile 'init-fin-fun))  
   
 (eval-when (load eval)  
   (let ((codevec (excl::fn_code  
                   (symbol-function 'funcallable-instance-mattress-pad))))  
     ;; The entire code vector wants to be:  
     ;;   a1  b77  
     ;;   a2  12,a1  
     ;;   a1 1,a2  
     ;;   b77 a2  
     ;;   b76 a1  
     ;;   j   b76  
     (setf (aref codevec 0) #o024177  
           (aref codevec 1) #o101200 (aref codevec 2) 12  
           (aref codevec 3) #o102100 (aref codevec 4) 1  
           (aref codevec 5) #o025277  
           (aref codevec 6) #o025176  
           (aref codevec 7) #o005076  
           ))  
 )  
   
 (defmacro funcallable-instance-data-1 (instance data)  
   `(excl::function-constant ,instance  
                             (+ (funcallable-instance-data-position ,data)  
                                fin-instance-dtat-slot)))  
   
   
 (defun set-funcallable-instance-function (fin new-function)  
   (unless (funcallable-instance-p fin)  
     (error "~S is not a funcallable-instance" fin))  
   (unless (functionp new-function)  
     (error "~S is not a function." new-function))  
   (setf (excl::function-constant fin fin-fun-slot)  
     (if (excl::function-object-p new-function)  
         new-function  
         ;; The new-function is an interpreted function.  
         ;; Install a trampoline to call the interpreted function.  
         (make-trampoline new-function))))  
   
 ) ;; end cray  
   
 #-gsgc  
 (progn  
   
 (defun allocate-funcallable-instance-1 ()  
   (let ((new-fin (compiler::.primcall 'sys::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 #'init-fin-fn)  
     new-fin))  
   
 (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))  
          ;; In versions prior to 2.0. comment the next line and any other  
          ;; references to fn_symdef or fn_locals.  
          (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))  
          (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 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)))  
   
 );end #-gsgc  
   
 );end of #+ExCL  
   
   
 ;;;  
 ;;; In Vaxlisp  
 ;;; This code was originally written by:  
 ;;;    vanroggen%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 allocate-funcallable-instance-1 ()  
   (list 'system::%compiled-closure%  
         ()  
         #'(lambda (&rest args)  
             (declare (ignore args))  
             (called-fin-without-function))  
         (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)))  
   
 );end of Vaxlisp (and dec vax common)  
118    
119    
120  ;;;; Implementation of funcallable instances for CMU Common Lisp:  ;;;; Implementation of funcallable instances for CMU Common Lisp:
# Line 1261  dbg: Line 133  dbg:
133    (pcl-funcallable-instance-slots nil)    (pcl-funcallable-instance-slots nil)
134    ;;    ;;
135    ;; The debug-name for this function.    ;; The debug-name for this function.
136    (funcallable-instance-name nil))    (funcallable-instance-name nil)
137      ;;
138      ;; Hash code.
139      (hash-code (get-instance-hash-code) :type fixnum))
140    
 #+CMU  
141  ;;; Note: returns true for non-pcl funcallable structures.  ;;; Note: returns true for non-pcl funcallable structures.
142  (import 'kernel:funcallable-instance-p)  (import 'kernel:funcallable-instance-p)
143    
144  #+CMU  
 (progn  
145  ;;; SET-FUNCALLABLE-INSTANCE-FUNCTION  --  Interface  ;;; SET-FUNCALLABLE-INSTANCE-FUNCTION  --  Interface
146  ;;;  ;;;
147  ;;;    Set the function that is called when FIN is called.  ;;;    Set the function that is called when FIN is called.
# Line 1278  dbg: Line 151  dbg:
151    (assert (funcallable-instance-p fin))    (assert (funcallable-instance-p fin))
152    (setf (kernel:funcallable-instance-function fin) new-value))    (setf (kernel:funcallable-instance-function fin) new-value))
153    
   
 ;;; FUNCALLABLE-INSTANCE-DATA-1  --  Interface  
 ;;;  
 ;;;    This "works" on non-PCL FINs, which allows us to weaken  
 ;;; FUNCALLABLE-INSTANCE-P to return trure for all FINs.  This is also  
 ;;; necessary for bootstrapping to work, since the layouts for early GFs are  
 ;;; not initially initialized.  
 ;;;  
 (defmacro funcallable-instance-data-1 (fin slot)  
   (ecase (eval slot)  
     (wrapper `(kernel:%funcallable-instance-layout ,fin))  
     (slots `(kernel:%funcallable-instance-info ,fin 0))))  
   
 (defmacro pcl-funcallable-instance-wrapper (x)  
   `(kernel:%funcallable-instance-layout ,x))  
   
 ); End of #+cmu progn  
   
   
 ;;;  
 ;;; Kyoto Common Lisp (KCL)  
 ;;;  
 ;;; 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!  
 ;;; The C code we call and the lisp interface to it is in the file kcl-low.  
 ;;; The lisp interface to this code implements accessors to compiled closures  
 ;;; and compiled functions of about the same level of abstraction as that  
 ;;; which is used by the other implementation dependent versions of FINs in  
 ;;; this file.  
 ;;;  
   
 #+(and KCL (not IBCL))  
 (progn  
   
 (defvar *funcallable-instance-marker* (list "Funcallable Instance Marker"))  
   
 (defconstant funcallable-instance-closure-size 15)  
   
 (defconstant funcallable-instance-closure-size1  
   (1- funcallable-instance-closure-size))  
   
 (defconstant funcallable-instance-available-size  
   (- funcallable-instance-closure-size1  
      (length funcallable-instance-data)))  
   
 (defmacro funcallable-instance-marker (x)  
   `(car (cclosure-env-nthcdr funcallable-instance-closure-size1 ,x)))  
   
 (defun allocate-funcallable-instance-1 ()  
   (let ((fin (allocate-funcallable-instance-2))  
         (env (make-list funcallable-instance-closure-size :initial-element nil)))  
     (setf (%cclosure-env fin) env)  
     #+:turbo-closure (si:turbo-closure fin)  
     (setf (funcallable-instance-marker fin) *funcallable-instance-marker*)  
     fin))  
   
 (defun allocate-funcallable-instance-2 ()  
   (let ((what-a-dumb-closure-variable ()))  
     #'(lambda (&rest args)  
         (declare (ignore args))  
         (called-fin-without-function)  
         (setq what-a-dumb-closure-variable  
               (dummy-function what-a-dumb-closure-variable)))))  
   
 (defun funcallable-instance-p (x)  
   (eq *funcallable-instance-marker* (funcallable-instance-marker x)))  
   
 (si:define-compiler-macro funcallable-instance-p (x)  
   `(eq *funcallable-instance-marker* (funcallable-instance-marker ,x)))  
   
 (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))  
         ((and (cclosurep new-value)  
               (<= (length (%cclosure-env new-value))  
                   funcallable-instance-available-size))  
          (%set-cclosure fin new-value funcallable-instance-available-size))  
         (t  
          (set-funcallable-instance-function  
            fin (make-trampoline new-value))))  
   fin)  
   
 (defmacro funcallable-instance-data-1 (fin data &environment env)  
   ;; The compiler won't expand macros before deciding on optimizations,  
   ;; so we must do it here.  
   (let* ((pos-form (macroexpand `(funcallable-instance-data-position ,data)  
                                 env))  
          (index-form (if (constantp pos-form)  
                          (- funcallable-instance-closure-size  
                             (eval pos-form)  
                             2)  
                          `(- funcallable-instance-closure-size  
                              (funcallable-instance-data-position ,data)  
                              2))))  
     `(car (%cclosure-env-nthcdr ,index-form ,fin))))  
   
   
 #+turbo-closure (clines "#define TURBO_CLOSURE")  
   
 (clines "  
 static make_trampoline_internal();  
 static make_turbo_trampoline_internal();  
   
 static object  
 make_trampoline(function)  
      object function;  
 {  
   vs_push(MMcons(function,Cnil));  
 #ifdef TURBO_CLOSURE  
   if(type_of(function)==t_cclosure)  
     {if(function->cc.cc_turbo==NULL)turbo_closure(function);  
      vs_head=make_cclosure(make_turbo_trampoline_internal,Cnil,vs_head,Cnil,NULL,0);  
      return vs_pop;}  
 #endif  
   vs_head=make_cclosure(make_trampoline_internal,Cnil,vs_head,Cnil,NULL,0);  
   return vs_pop;  
 }  
   
 static  
 make_trampoline_internal(base0)  
      object *base0;  
 {super_funcall_no_event(base0[0]->c.c_car);}  
   
 static  
 make_turbo_trampoline_internal(base0)  
      object *base0;  
 { object function=base0[0]->c.c_car;  
   (*function->cc.cc_self)(function->cc.cc_turbo);  
 }  
   
 ")  
   
 (defentry make-trampoline (object) (object make_trampoline))  
 )  
   
 #+IBCL  
 (progn ; From Rainy Day PCL.  
   
 (defvar *funcallable-instance-marker* (list "Funcallable Instance Marker"))  
   
 (defconstant funcallable-instance-closure-size 15)  
   
 (defun allocate-funcallable-instance-1 ()  
   (let ((fin (allocate-funcallable-instance-2))  
         (env  
           (make-list funcallable-instance-closure-size :initial-element nil)))  
     (set-cclosure-env fin env)  
     #+:turbo-closure (si:turbo-closure fin)  
     (dotimes (i (1- funcallable-instance-closure-size)) (pop env))  
     (setf (car env) *funcallable-instance-marker*)  
     fin))  
   
 (defun allocate-funcallable-instance-2 ()  
   (let ((what-a-dumb-closure-variable ()))  
     #'(lambda (&rest args)  
         (declare (ignore args))  
         (called-fin-without-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)  
                                  1)))  
            (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)  
                           1))  
              (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)))  
   
 ;; this replaces funcallable-instance-data-1, set-funcallable-instance-data-1  
 ;; and the defsetf  
 (defmacro funcallable-instance-data-1 (fin data &environment env)  
   ;; The compiler won't expand macros before deciding on optimizations,  
   ;; so we must do it here.  
   (let* ((pos-form (macroexpand `(funcallable-instance-data-position ,data)  
                                 env))  
          (index-form (if (constantp pos-form)  
                          (- funcallable-instance-closure-size  
                             (eval pos-form)  
                             2)  
                          `(- funcallable-instance-closure-size  
                              (funcallable-instance-data-position ,data)  
                              2))))  
     #+:turbo-closure `(car (tc-cclosure-env-nthcdr ,index-form ,fin))  
     #-:turbo-closure `(nth ,index-form (cclosure-env ,fin))))  
   
 )  
   
   
 ;;;  
 ;;; In H.P. Common Lisp  
 ;;; This code was originally written by:  
 ;;;    kempf@hplabs.hp.com     (James Kempf)  
 ;;;    dsouza@hplabs.hp.com    (Roy D'Souza)  
 ;;;  
 #+HP-HPLabs  
 (progn  
   
 (defmacro fin-closure-size ()`(prim::@* 6 prim::bytes-per-word))  
   
 (defmacro fin-set-mem-hword ()  
   `(prim::@set-mem-hword  
      (prim::@+ fin (prim::@<< 2 1))  
      (prim::@+ (prim::@<< 2 8)  
                (prim::@fundef-info-parms (prim::@fundef-info fundef)))))  
   
 (defun allocate-funcallable-instance-1()  
   (let* ((fundef  
            #'(lambda (&rest ignore)  
                (declare (ignore ignore))  
                (called-fin-without-function)))  
          (static-link (vector 'lisp::*undefined* NIL NIL NIL NIL NIL))  
          (fin (prim::@make-fundef (fin-closure-size))))  
     (fin-set-mem-hword)  
     (prim::@set-svref fin 2 fundef)  
     (prim::@set-svref fin 3 static-link)  
     (prim::@set-svref fin 4 0)  
     (impl::PlantclosureHook fin)  
     fin))  
   
 (defmacro funcallable-instance-p (possible-fin)  
   `(= (fin-closure-size) (prim::@header-inf ,possible-fin)))  
   
 (defun set-funcallable-instance-function (fin new-function)  
   (cond ((not (funcallable-instance-p fin))  
          (error "~S is not a funcallable instance.~%" fin))  
         ((not (functionp new-function))  
          (error "~S is not a function." new-function))  
         (T  
          (prim::@set-svref fin 2 new-function))))  
   
 (defmacro funcallable-instance-data-1 (fin data)  
   `(prim::@svref (prim::@closure-static-link ,fin)  
                  (+ 2 (funcallable-instance-data-position ,data))))  
   
 (defsetf funcallable-instance-data-1 (fin data) (new-value)  
   `(prim::@set-svref (prim::@closure-static-link ,fin)  
                      (+ (funcallable-instance-data-position ,data) 2)  
                      ,new-value))  
   
 (defun funcallable-instance-name (fin)  
   (prim::@svref (prim::@closure-static-link fin) 1))  
   
 (defsetf funcallable-instance-name set-funcallable-instance-name)  
   
 (defun set-funcallable-instance-name (fin new-name)  
   (prim::@set-svref (prim::@closure-static-link fin) 1 new-name))  
   
 );end #+HP  
   
   
   
 ;;;  
 ;;; In Golden Common Lisp.  
 ;;; This code was originally written by:  
 ;;;    dan%acorn@Live-Oak.LCS.MIT.edu     (Dan Jacobs)  
 ;;;  
 ;;; GCLISP supports named structures that are specially marked as funcallable.  
 ;;; This allows FUNCALLABLE-INSTANCE-P to be a normal structure predicate,  
 ;;; and allows ALLOCATE-FUNCALLABLE-INSTANCE-1 to be a normal boa-constructor.  
 ;;;  
 #+GCLISP  
 (progn  
   
 (defstruct (%funcallable-instance  
              (:predicate funcallable-instance-p)  
              (:copier nil)  
              (:constructor allocate-funcallable-instance-1 ())  
              (:print-function  
               (lambda (struct stream depth)  
                 (declare (ignore depth))  
                 (print-object struct stream))))  
   (function     #'(lambda (ignore-this &rest ignore-these-too)  
                     (declare (ignore ignore-this ignore-these-too))  
                     (called-fin-without-function))  
                 :type function)  
   (%hidden%     'gclisp::funcallable :read-only t)  
   (data         (vector nil nil) :type simple-vector :read-only t))  
   
 (proclaim '(inline set-funcallable-instance-function))  
 (defun set-funcallable-instance-function (fin new-value)  
   (setf (%funcallable-instance-function fin) new-value))  
   
 (defmacro funcallable-instance-data-1 (fin data)  
   `(svref (%funcallable-instance-data ,fin)  
           (funcallable-instance-data-position ,data)))  
   
 )  
   
   
 ;;;  
 ;;; Explorer Common Lisp  
 ;;; This code was originally written by:  
 ;;;    Dussud%Jenner@csl.ti.com  
 ;;;  
 #+ti  
 (progn  
   
 #+(or :ti-release-3 (and :ti-release-2 elroy))  
 (defmacro lexical-closure-environment (l)  
   `(cdr (si:%make-pointer si:dtp-list  
                           (cdr (si:%make-pointer si:dtp-list ,l)))))  
   
 #-(or :ti-release-3 elroy)  
 (defmacro lexical-closure-environment (l)  
   `(caar (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)))  
   
   
 (defvar *funcallable-instance-marker* (list "Funcallable Instance Marker"))  
   
 (defconstant funcallable-instance-closure-size 15) ; NOTE: In order to avoid  
                                                    ; hassles with the reader,  
 (defmacro allocate-funcallable-instance-2 ()       ; these two 15's are the  
   (let ((l ()))                                    ; same.  Be sure to keep  
     (dotimes (i 15)                                ; them consistent.  
       (push (list (gensym) nil) l))  
     `(let ,l  
        #'(lambda (ignore &rest ignore-them-too)  
            (declare (ignore ignore ignore-them-too))  
            (called-fin-without-function)  
            (values . ,(mapcar #'car l))))))  
   
 (defun allocate-funcallable-instance-1 ()  
   (let* ((new-fin (allocate-funcallable-instance-2)))  
     (setf (car (nthcdr (1- funcallable-instance-closure-size)  
                        (lexical-closure-environment new-fin)))  
           *funcallable-instance-marker*)  
     new-fin))  
   
 (eval-when (eval) (compile 'allocate-funcallable-instance-1))  
   
 (proclaim '(inline funcallable-instance-p))  
 (defun funcallable-instance-p (x)  
   (and (typep x #+:ti-release-2 'closure  
                 #+:ti-release-3 'si: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)  
                                  1)))  
            (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 (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))))  
   
 (eval-when (eval) (compile 'make-trampoline))  
   
 (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)))  
   
 );end of code for TI  
   
   
 ;;; Implemented by Bein@pyramid -- Tue Aug 25 19:05:17 1987  
 ;;;  
 ;;; A FIN is a distinct type of object which FUNCALL,EVAL, and APPLY  
 ;;; recognize as functions. Both Compiled-Function-P and functionp  
 ;;; recognize FINs as first class functions.  
 ;;;  
 ;;; This does not work with PyrLisp versions earlier than 1.1..  
   
 #+pyramid  
 (progn  
   
 (defun make-trampoline (function)  
     #'(lambda (&rest args) (apply function args)))  
   
 (defun un-initialized-fin (&rest trash)  
     (declare (ignore trash))  
     (called-fin-without-function))  
   
 (eval-when (eval)  
     (compile 'make-trampoline)  
     (compile 'un-initialized-fin))  
   
 (defun allocate-funcallable-instance-1 ()  
     (let ((fin (system::alloc-funcallable-instance)))  
       (system::set-fin-function fin #'un-initialized-fin)  
       fin))  
   
 (defun funcallable-instance-p (object)  
   (typep object 'lisp::funcallable-instance))  
   
 (clc::deftransform funcallable-instance-p trans-fin-p (object)  
     `(typep ,object 'lisp::funcallable-instance))  
   
 (defun set-funcallable-instance-function (fin new-value)  
     (or (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 (lisp::compiled-function-p new-value))  
            (set-funcallable-instance-function fin  
                                               (make-trampoline new-value)))  
           (t  
            (system::set-fin-function fin new-value))))  
   
 (defun funcallable-instance-data-1 (fin data-name)  
   (system::get-fin-data fin  
                         (funcallable-instance-data-position data-name)))  
   
 (defun set-funcallable-instance-data-1 (fin data-name value)  
   (system::set-fin-data fin  
                         (funcallable-instance-data-position data-name)  
                         value))  
   
 (defsetf funcallable-instance-data-1 set-funcallable-instance-data-1)  
   
 ); End of #+pyramid  
   
   
 ;;;  
 ;;; For Coral Lisp  
 ;;;  
 #+:coral  
 (progn  
   
 (defconstant ccl::$v_istruct 22)  
 (defvar ccl::initial-fin-slots (make-list (length funcallable-instance-data)))  
 (defconstant ccl::fin-function 1)  
 (defconstant ccl::fin-data (+ ccl::FIN-function 1))  
   
 (defun allocate-funcallable-instance-1 ()  
   (apply #'ccl::%gvector  
          ccl::$v_istruct  
          'ccl::funcallable-instance  
          #'(lambda (&rest ignore)  
              (declare (ignore ignore))  
              (called-fin-without-function))  
          ccl::initial-fin-slots))  
   
 #+:ccl-1.3  
 (eval-when (eval compile load)  
   
 ;;; Make uvector-based objects (like funcallable instances) print better.  
 (defun print-uvector-object (obj stream &optional print-level)  
   (declare (ignore print-level))  
   (print-object obj stream))  
   
 ;;; Inform the print system about funcallable instance uvectors.  
 (pushnew (cons 'ccl::funcallable-instance #'print-uvector-object)  
          ccl:*write-uvector-alist*  
          :test #'equal)  
   
 )  
   
 (defun funcallable-instance-p (x)  
   (and (eq (ccl::%type-of x) 'ccl::internal-structure)  
        (eq (ccl::%uvref x 0) 'ccl::funcallable-instance)))  
   
 (defun set-funcallable-instance-function (fin new-value)  
   (unless (funcallable-instance-p fin)  
     (error "~S is not a funcallable-instance." fin))  
   (unless (functionp new-value)  
     (error "~S is not a function." new-value))  
   (ccl::%uvset fin ccl::FIN-function new-value))  
   
 (defmacro funcallable-instance-data-1 (fin data-name)  
   `(ccl::%uvref ,fin  
                 (+ (funcallable-instance-data-position ,data-name)  
                    ccl::FIN-data)))  
   
 (defsetf funcallable-instance-data-1 (fin data) (new-value)  
   `(ccl::%uvset ,fin  
                 (+ (funcallable-instance-data-position ,data) ccl::FIN-data)  
                 ,new-value))  
   
 ); End of #+:coral  
   
   
   
 ;;;; Slightly Higher-Level stuff built on the implementation-dependent stuff.  
 ;;;  
 ;;;  
   
 (defmacro fsc-instance-p (fin)  
   `(funcallable-instance-p ,fin))  
   
 (defmacro fsc-instance-class (fin)  
   `(wrapper-class (funcallable-instance-data-1 ,fin 'wrapper)))  
   
 (defmacro fsc-instance-wrapper (fin)  
   `(funcallable-instance-data-1 ,fin 'wrapper))  
   
 (defmacro fsc-instance-slots (fin)  
   `(funcallable-instance-data-1 ,fin 'slots))  

Legend:
Removed from v.1.9.1.1  
changed lines
  Added in v.1.23

  ViewVC Help
Powered by ViewVC 1.1.5