;;;-*-Mode:LISP; Package:(PCL Lisp 1000); Base:10; Syntax:Common-lisp -*-
;;;
;;; *************************************************************************
;;; Copyright (c) 1985, 1986, 1987 Xerox 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 for
short).  They behave something like lexical closures in that they have data
associated with them (which is used to store the slots) and are funcallable.
When a funcallable instance is funcalled, the function that is invoked is
called the funcallable-instance-function.  The funcallable-instance-function
of 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.  A
simple implementation which uses lexical closures as the instances and a
hash table to record that the lexical closures are funcallable instances
is easy to write.  Unfortunately, this implementation adds significant
overhead:

   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 garbage
collected.  In short, the pure Common Lisp implementation really isn't
practical.

Instead, PCL uses a specially tailored implementation for each Common Lisp and
makes no attempt to provide a purely portable implementation.  The specially
tailored implementations are based on the lexical closure's provided by that
implementation and are fairly short and easy to write.

Some of the implementation dependent code in this file was originally written
by someone in the employ of the vendor of that Common Lisp.  That code is
explicitly marked saying who wrote it.

|#

(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:
;;; 
;;;    ALLOCATE-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 allocate-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 allocate-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 make
               ;; sure to update the procedure-flags of the fin to keep it
	       ;; a fin.
	       ;; Note that we don't copy the name of the new procedure into
	       ;; the old procedure.  We let the old procedure keep its old
	       ;; name.
               (progn 
                 (dotimes (i max-procedure-size)
		   (unless (= i lucid::procedure-symbol)
		     (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)))
  
);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.  We do one trick by
;;; making the closure pair be the tail of the environment list.
;;;      
#+Symbolics
(progn

(defvar *funcallable-instance-marker* (list "Funcallable Instance Marker"))

(defconstant funcallable-instance-closure-size 15)

(defun allocate-funcallable-instance-1 ()
  (let* ((env (make-list (+ funcallable-instance-closure-size 3)))
	 (new-fin (sys:%make-pointer-offset
		    sys:dtp-lexical-closure
		    env
		    (1+ funcallable-instance-closure-size))))
    (setf (sys:%p-contents-offset new-fin -1) *funcallable-instance-marker*)
    (sys:%change-list-to-cons new-fin)
    (setf (si:lexical-closure-function new-fin)
	  #'(lambda (ignore &rest ignore-them-too)
	      (declare (ignore ignore ignore-them-too))
	      (error "Called a FIN without first setting its function.")))
    (setf (si:lexical-closure-environment new-fin) env)
    new-fin))

(scl:defsubst funcallable-instance-p (x)
  (declare (inline si:lexical-closure-p))
  (and (si:lexical-closure-p x)
       (= (sys:%pointer-difference x (si:lexical-closure-environment x))
	  (1+ funcallable-instance-closure-size))
       (eq (sys:%p-contents-offset x -1) *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))
        ((and (si:lexical-closure-p new-value)
	      (compiled-function-p (si:lexical-closure-function 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)
		  (dotimes (i fin-env-size)
		    (setf (sys:%p-contents-offset fin-env i)
			  (and (< i new-env-size)
			       (sys:%p-contents-offset new-env i))))
                  (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)
  `(sys:%p-contents-offset ,fin
			   (- -2
			      (funcallable-instance-data-position ,data))))

(defsetf funcallable-instance-data-1 (fin data) (new-value)
  `(setf (sys:%p-contents-offset
	   ,fin
	   (- -2 (funcallable-instance-data-position ,data)))
	 ,new-value))

);end of #+Symbolics



;;;
;;; 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.
;;;    *** This should probably be made to use XPOINTERs, but I ***
;;;    *** refuse to implement that sort of lossage myself.     ***
;;;
;;; 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

(defconstant funcallable-instance-closure-size 15)

(defvar *fin-env-type*
	(type-of (il:\\allocblock funcallable-instance-closure-size t)))

(defun fin-env-fin (fin-env)
  (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) new-value))

(defsetf fin-env-fin |set fin-env-fin|)

(defun allocate-funcallable-instance-1 ()
  (let* ((env (il:\\allocblock 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))
          (error "Attempt to funcall a funcallable-instance without first~%~
                  setting its funcallable-instance-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 (il:\\#blockdatacells new-env))
                (fin-env-size (- funcallable-instance-closure-size
                                 (length funcallable-instance-data))))
           (cond ((<= 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:
;;;   franz!ficl!jkf@ucbarpa.berkeley.edu
;;; 
#+ExCL
(progn

(defconstant funcallable-instance-flag-bit #x1)

(defun allocate-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))
	 #-VAX (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)))

);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))
            (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)))

);end of Vaxlisp (and dec vax common)


;;; Implementation of funcallable instances for CMU Common Lisp.
;;;
;;; Similiar to the code for VAXLISP implementation.
#+:CMU
(progn

(defun allocate-funcallable-instance-1 ()
  `(lisp::%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) 'lisp::%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) 'lisp::%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 :CMU



;;;
;;; 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.
;;;
#+KCL
(progn

(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)
    (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))
	(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)

)


;;;
;;; 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
(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))
	       (error "Attempt to call a funcallable-instance without first~%~
                       setting its funcallable-instance-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 struct depth))
		(format stream "<Funcallable Instance Object>"))))
  (function	#'(lambda (ignore-this &rest ignore-these-too)
		    (declare (ignore ignore-this ignore-these-too))
		    (error "Called a FIN without first setting its function"))
		:type function)
  (%hidden%	'gclisp::funcallable
		:read-only t)
  (data		(vector nil 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))
	   (error "Called a FIN without first setting its 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))))
	   (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))
    (error "Called a funcallable-instance which is not initialized."))

(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


;;;; 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 allocate-funcallable-instance (wrapper number-of-static-slots)
  (let ((fin (allocate-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))