? darwin-headers
? fi.diff
? old
? save
Index: level-1/l1-clos-boot.lisp
===================================================================
RCS file: /usr/local/tmpcvs/ccl-0.14/ccl/level-1/l1-clos-boot.lisp,v
retrieving revision 1.8
diff -d -u -r1.8 l1-clos-boot.lisp
--- level-1/l1-clos-boot.lisp	4 May 2004 08:19:20 -0000	1.8
+++ level-1/l1-clos-boot.lisp	28 Aug 2004 22:04:54 -0000
@@ -31,7 +31,9 @@
   (let* ((typecode (typecode instance)))
     (cond ((eql typecode target::subtag-instance) (instance.slots instance))
 	  ((eql typecode target::subtag-macptr) (foreign-slots-vector instance))
-	  ((typep instance 'standard-generic-function) (gf.slots instance))
+	  ((or (typep instance 'standard-generic-function)
+	       (typep instance 'funcallable-standard-object))
+	   (gf.slots instance))
 	  (t  (error "Don't know how to find slots of ~s" instance)))))
 
 (defun %class-name (class)
Index: level-1/l1-clos.lisp
===================================================================
RCS file: /usr/local/tmpcvs/ccl-0.14/ccl/level-1/l1-clos.lisp,v
retrieving revision 1.11
diff -d -u -r1.11 l1-clos.lisp
--- level-1/l1-clos.lisp	11 Aug 2004 00:19:52 -0000	1.11
+++ level-1/l1-clos.lisp	28 Aug 2004 22:05:02 -0000
@@ -577,7 +577,7 @@
 (defmethod reinitialize-instance :before ((class std-class)  &key direct-superclasses)
   (remove-accessor-methods class (%class-direct-slots class))
   (remove-direct-subclasses class (%class-direct-superclasses class) direct-superclasses))
-   
+
 (defmethod shared-initialize :after
   ((class slots-class)
    slot-names &key
@@ -589,8 +589,11 @@
   (declare (ignore slot-names))
   (if direct-superclasses-p
     (progn
-      (setq direct-superclasses (or direct-superclasses
-                                    (list *standard-object-class*)))
+      (setq direct-superclasses
+	    (or direct-superclasses
+		(list (if (typep class 'funcallable-standard-class)
+			  *funcallable-standard-object-class*
+			  *standard-object-class*))))
       (dolist (superclass direct-superclasses)
         (unless (validate-superclass class superclass)
           (error "The class ~S was specified as a~%super-class of the class ~S;~%~
@@ -1530,4 +1533,27 @@
   (reinitialize-instance class :name new)
   new)
 
+;;; Support for objects with metaclass funcallable-instance-class that are not
+;;; standard-generic-function. The objects still look a lot like generic
+;;; functions, complete with vestigial dispatch
+;;; tables. set-funcallable-instance-function will work on generic functions,
+;;; though after that it won't be much of a generic function.
+
+(defppclapfunction funcallable-trampoline ()
+  (svref nfn gf.dcode nfn)
+  (lwz temp0 ppc32::misc-data-offset nfn)
+  (mtctr temp0)
+  (bctr))
+
+(defvar *fi-trampoline-code* (uvref #'funcallable-trampoline 0))
+
+(defmethod instance-class-wrapper ((instance funcallable-standard-object))
+  (gf.instance.class-wrapper  instance))
 
+(defun set-funcallable-instance-function (funcallable-instance function)
+  (unless (typep funcallable-instance 'funcallable-standard-object)
+    (error "~S is not a funcallable instance" funcallable-instance))
+  (unless (functionp function)
+    (error "~S is not a function" function))
+  (setf (uvref funcallable-instance gf.code-vector) *fi-trampoline-code*)
+  (setf (uvref funcallable-instance gf.dcode) function))
Index: lib/macros.lisp
===================================================================
RCS file: /usr/local/tmpcvs/ccl-0.14/ccl/lib/macros.lisp,v
retrieving revision 1.9
diff -d -u -r1.9 macros.lisp
--- lib/macros.lisp	4 May 2004 08:23:45 -0000	1.9
+++ lib/macros.lisp	28 Aug 2004 22:05:21 -0000
@@ -1672,7 +1672,7 @@
 		   ,@(when documentation `(:documentation ,documentation))
                    ,@(mapcan #'(lambda (opt)
                                  `(',(car opt) ',(cdr opt))) other-options)))))
-	(let* ((direct-superclasses (or superclasses '(standard-object)))
+	(let* ((direct-superclasses superclasses)
 	       (direct-slot-specs (mapcar #'canonicalize-slot-spec slots))
 	       (other-options (apply #'append (mapcar #'canonicalize-defclass-option class-options ))))
 	  `(progn