From b9a934f729af34bd81b53e4bc0873078baf1a650 Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Sat, 19 Oct 1991 17:23:46 +0000
Subject: [PATCH] Merged with latest PCL version.

---
 pcl/boot.lisp      | 245 +++++++++++++++-----------
 pcl/construct.lisp |  20 ++-
 pcl/defclass.lisp  |  43 ++++-
 pcl/defs.lisp      | 166 +++++++++--------
 pcl/defsys.lisp    |  79 +++++++--
 pcl/env.lisp       |  42 +----
 pcl/fin.lisp       | 431 +++++++++++++++++++++++++++++++++++++++++++--
 pcl/lap.lisp       |   1 +
 pcl/pkg.lisp       |   1 +
 pcl/plap.lisp      |   4 +-
 pcl/quadlap.lisp   |   2 +-
 pcl/walk.lisp      |  73 ++++++--
 12 files changed, 837 insertions(+), 270 deletions(-)

diff --git a/pcl/boot.lisp b/pcl/boot.lisp
index df16e51e8..eb38a60a8 100644
--- a/pcl/boot.lisp
+++ b/pcl/boot.lisp
@@ -268,9 +268,8 @@ work during bootstrapping.
 	  ',name
 	  ',qualifiers
 	  (list ,@(mapcar #'(lambda (specializer)
-			      (if (and (consp specializer)
-				       (eq (car specializer) 'eql))
-				  ``(eql ,,(cadr specializer))
+			      (if (consp specializer)
+				  ``(,',(car specializer) ,,(cadr specializer))
 				  `',specializer))
 			  specializers))
 	  ',(specialized-lambda-list-lambda-list lambda-list)
@@ -287,16 +286,32 @@ work during bootstrapping.
   (when (listp name) (do-standard-defsetf-1 (cadr name)))
   (multiple-value-bind (fn-form specializers doc plist)
       (expand-defmethod-internal name qualifiers lambda-list body env)
-    (declare (ignore doc plist))
     (let ((fn-args (cadadr fn-form))
-	  (fn-body (cddadr fn-form)))
-      `(defun (method ,name ,@qualifiers ,specializers) ,fn-args
-	 (declare ,@(when proto-method
-		      `((pcl-method-class
-			  ,(class-name (class-of proto-method)))))
-		  (pcl-lambda-list
-		    ,(specialized-lambda-list-lambda-list lambda-list)))
-	 ,@fn-body))))
+	  (fn-body (cddadr fn-form))
+	  (method-name `(method ,name ,@qualifiers ,specializers)))
+      `(progn
+	 (proclaim '(function ,name))
+	 (defun ,method-name ,fn-args
+	   ,@fn-body)
+	 (load-defmethod
+	   ',(if proto-method
+		 (class-name (class-of proto-method))
+		 'standard-method)
+	   ',name
+	   ',qualifiers
+	   (list ,@(mapcar #'(lambda (specializer)
+			       (if (consp specializer)
+				   ``(,',(car specializer) ,,(cadr specializer))
+				   `',specializer))
+			   specializers))
+	   ',(specialized-lambda-list-lambda-list lambda-list)
+	   ',doc
+	   ',(getf plist :isl-cache-symbol)	;Paper over a bug in KCL by
+						;passing the cache-symbol
+						;here in addition to in the
+						;plist.
+	   ',plist
+	   #',method-name)))))
 
 (defun expand-defmethod-internal
        (generic-function-name qualifiers specialized-lambda-list body env)
@@ -348,6 +363,8 @@ work during bootstrapping.
 
 	     (call-next-method-p nil)   ;flag indicating that call-next-method
 	                                ;should be in the method definition
+	     (closurep nil)		;flag indicating that #'call-next-method
+					;was seen in the body of a method
 	     (next-method-p-p nil)      ;flag indicating that next-method-p
                                         ;should be in the method definition
 	     (save-original-args nil)   ;flag indicating whether or not the
@@ -380,7 +397,8 @@ work during bootstrapping.
 		       ((not (listp form)) form)
 		       ((eq (car form) 'call-next-method)
 			(setq call-next-method-p 't)
-			(setq save-original-args (not (cdr form)))
+			(unless (cdr form)
+			  (setq save-original-args t))
 			form)
 		       ((eq (car form) 'next-method-p)
 			(setq next-method-p-p 't)
@@ -389,13 +407,16 @@ work during bootstrapping.
 			     (cond ((eq (cadr form) 'call-next-method)
 				    (setq call-next-method-p 't)
 				    (setq save-original-args 't)
+				    (setq closurep t)
 				    form)
 				   ((eq (cadr form) 'next-method-p)
 				    (setq next-method-p-p 't)
+				    (setq closurep t)
 				    form)
 				   (t nil))))
 		       ((and (or (eq (car form) 'slot-value)
-				 (eq (car form) 'set-slot-value))
+				 (eq (car form) 'set-slot-value)
+				 (eq (car form) 'slot-boundp))
 			     (symbolp (cadr form))
 			     (constantp (caddr form)))
 			(let ((parameter
@@ -406,7 +427,9 @@ work during bootstrapping.
 				(slot-value
 				  (optimize-slot-value     slots parameter form))
 				(set-slot-value
-				  (optimize-set-slot-value slots parameter form))))))
+				  (optimize-set-slot-value slots parameter form))
+				(slot-boundp
+				  (optimize-slot-boundp    slots parameter form))))))
 		       (t form))))
 	  
 	  (setq walked-lambda (walk-form method-lambda env #'walk-function))
@@ -476,16 +499,11 @@ work during bootstrapping.
 				applyp
 				aux-bindings
 				call-next-method-p
-				next-method-p-p)
+				next-method-p-p
+				closurep)
 			      `(lambda ,lambda-list
 				 ,@walked-declarations
 				 ,.walked-lambda-body))))
-	      #+Genera
-	      (setq fn-body `(lambda ,(cadr fn-body)
-			       (declare (pcl-documentation ,documentation)
-					(pcl-plist ,plist))
-			       ,@(cddr fn-body)))
-
 	      (values
 		`(function ,fn-body)
 		specializers
@@ -501,8 +519,46 @@ work during bootstrapping.
 					       applyp
 					       aux-bindings
 					       call-next-method-p
-					       next-method-p-p)
-  (cond ((and (null save-original-args)
+					       next-method-p-p
+					       closurep)
+  (cond ((and (null closurep)
+	      (null applyp)
+	      (null save-original-args))
+	 ;; OK to use MACROLET, CALL-NEXT-METHOD is always passed some args, and
+	 ;; all args are mandatory (else APPLYP would be true).
+	 `(lambda ,lambda-list
+	    ,@walked-declarations
+	    (let ((.next-method. (car *next-methods*))
+		  (.next-methods. (cdr *next-methods*)))
+	      (macrolet ((call-next-method ,lambda-list
+			   '(if .next-method.
+				(let ((*next-methods* .next-methods.))
+				  (funcall .next-method. ,@lambda-list))
+				(error "No next method.")))
+			 (next-method-p () `(not (null .next-method.))))
+		,@walked-lambda-body))))
+	((and (null closurep)
+	      (null applyp)
+	      save-original-args)
+	 ;; OK to use MACROLET.  CALL-NEXT-METHOD is sometimes called in the
+	 ;; body with zero args, so we have to save the original args.
+	 (if save-original-args
+	     ;; CALL-NEXT-METHOD is sometimes called with no args
+	     `(lambda ,original-args
+		(let ((.next-method. (car *next-methods*))
+		      (.next-methods. (cdr *next-methods*)))
+		  (macrolet ((call-next-method (&rest cnm-args)
+			       `(if .next-method.
+				    (let ((*next-methods* .next-methods.))
+				      (funcall .next-method.
+					       ,@(if cnm-args cnm-args ',original-args)))
+				    (error "No next method.")))
+			     (next-method-p () `(not (null .next-method.))))
+		    (let* (,@(mapcar #'list lambda-list original-args)
+			     ,@aux-bindings)
+		      ,@walked-declarations
+		      ,@walked-lambda-body))))))
+	((and (null save-original-args)
 	      (null applyp))
 	 ;;
 	 ;; We don't have to save the original arguments.  In addition,
@@ -719,7 +775,7 @@ work during bootstrapping.
   :initable-instance-variables)
 
 #+Lispm
-(zl:defmethod #+symbolics (dbg:report generic-clobbers-function)
+(zl:defmethod #+Genera (dbg:report generic-clobbers-function)
 	      #+ti (generic-clobbers-function :report)
 	      (stream)
  (format stream
@@ -727,7 +783,7 @@ work during bootstrapping.
 	 name
 	 (if (and (symbolp name) (macro-function name)) "macro" "function")))
 
-#+Symbolics
+#+Genera
 (zl:defmethod (sys:proceed generic-clobbers-function :specialize-it) ()
   "Make it specializable anyway?"
   (make-specializable name))
@@ -860,9 +916,7 @@ work during bootstrapping.
 (defun real-make-a-method
        (class qualifiers lambda-list specializers function doc
 	&optional slot-name)
-  ;; Hmm what is this use of when buying me??
-  (when (some #'(lambda (x) (and (neq x 't) (symbolp x))) specializers)
-    (setq specializers (parse-specializers specializers)))
+  (setq specializers (parse-specializers specializers))
   (make-instance class :qualifiers qualifiers
 		       :lambda-list lambda-list
 		       :specializers specializers
@@ -1053,7 +1107,9 @@ work during bootstrapping.
 			  #'do-main-combined-method)))
 	    (apply (caar around) args))))))
 
-(defun fix-early-generic-functions (&optional noisyp)
+(defvar *fegf-debug-p* nil)
+
+(defun fix-early-generic-functions (&optional (noisyp *fegf-debug-p*))
   (allocate-instance (find-class 'standard-generic-function));Be sure this
 						             ;class has an
 						             ;instance.
@@ -1166,33 +1222,22 @@ work during bootstrapping.
 
 (defun parse-specializers (specializers)
   (flet ((parse (spec)
-	   (cond ((symbolp spec)
-		  (or (find-class spec nil)
-		      (error
-			"~S used as a specializer,~%~
-                         but is not the name of a class."
-			spec)))
-		 ((and (listp spec)
-		       (eq (car spec) 'eql)
-		       (null (cddr spec)))
-		  (make-instance 'eql-specializer :object (cadr spec))	;*EQL*
-;		  spec
-		  )
-		 (t (error "~S is not a legal specializer." spec)))))
+	   (let ((result (specializer-from-type spec)))
+	     (if (specializerp result)
+		 result
+		 (if (symbolp spec)
+		     (error "~S used as a specializer,~%~
+                             but is not the name of a class."
+			    spec)
+		     (error "~S is not a legal specializer." spec))))))
     (mapcar #'parse specializers)))
 
 (defun unparse-specializers (specializers-or-method)
   (if (listp specializers-or-method)
       (flet ((unparse (spec)
-	       (cond ((classp spec)
-		      (or (class-name spec) spec))
-		     ((eql-specializer-p spec)	   ;*EQL*
-		      (eql-specializer-object spec)
-;		      (and (listp spec) (eq (car spec) 'eql))
-;		      spec
-		      )
-		     (t
-		      (error "~S is not a legal specializer." spec)))))
+	       (if (specializerp spec)
+		   (type-from-specializer spec)
+		   (error "~S is not a legal specializer." spec))))
 	(mapcar #'unparse specializers-or-method))
       (unparse-specializers (method-specializers specializers-or-method))))
 
@@ -1303,59 +1348,56 @@ work during bootstrapping.
 
 
 
-(defmacro with-slots
-	  (slots instance &body body &environment env)
-  (let ((gensym (gensym))
-	(specs (mapcar #'(lambda (ss)
-			   (if (consp ss)
-			       (list (car ss)
-				     (variable-lexical-p (car ss) env)
-				     (cadr ss))
-			       (list ss (variable-lexical-p ss env) ss)))
-		       slots)))
-    (expand-with-slots specs
-		       body
-		       env
-		       gensym
-		       instance
-		       #'(lambda (s) `(slot-value ,gensym ',s)))))
-
-(defmacro with-accessors
-	  (slot-accessor-pairs instance &body body &environment env)
-  (let ((gensym (gensym))
-	(specs (mapcar #'(lambda (ss)
-			   (list (car ss)
-				 (variable-lexical-p (car ss) env)
-				 (cadr ss)))
-		       slot-accessor-pairs)))    
-    (expand-with-slots specs
-		       body
-		       env
-		       gensym
-		       instance
-		       #'(lambda (a) `(,a ,gensym)))))
-
-(defun expand-with-slots (specs body env gensym instance translate-fn)
-  `(let ((,gensym ,instance))
-     ,@(and (symbolp instance)
-	    `((declare (variable-rebinding ,gensym ,instance))))
-     ,gensym
-     ,@(cdr (walk-form `(progn ,@body)
-		       env
-		       #'(lambda (f c e)
-			   (expand-with-slots-internal specs
-						       f
-						       c
-						       translate-fn
-						       e))))))
-
-(defun expand-with-slots-internal (specs form context translate-fn env)
+(defmacro symbol-macrolet (bindings &body body &environment env)
+  (let ((specs (mapcar #'(lambda (binding)
+			   (list (car binding)
+				 (variable-lexical-p (car binding) env)
+				 (cadr binding)))
+		       bindings)))
+    (walk-form `(progn ,@body)
+	       env
+	       #'(lambda (f c e)
+		   (expand-symbol-macrolet-internal specs f c e)))))
+
+(defmacro with-slots (slots instance &body body)
+  (let ((in (gensym)))
+    `(let ((,in ,instance))
+       ,@(and (symbolp instance)
+	      `((declare (variable-rebinding ,in ,instance))
+       (symbol-macrolet ,(mapcar #'(lambda (slot-entry)
+				   (let ((variable-name 
+					  (if (symbolp slot-entry)
+					      slot-entry
+					      (car slot-entry)))
+					 (slot-name
+					  (if (symbolp slot-entry)
+					      slot-entry
+					      (cadr slot-entry))))
+				     `(,variable-name
+				        (slot-value ,in ',slot-name))))
+			       slots)
+          ,@body))))))
+
+(defmacro with-accessors (slots instance &body body)
+  (let ((in (gensym)))
+    `(let ((,in ,instance))
+       ,@(and (symbolp instance)
+	      `((declare (variable-rebinding ,in ,instance))
+       (symbol-macrolet ,(mapcar #'(lambda (slot-entry)
+				   (let ((variable-name (car slot-entry))
+					 (accessor-name (cadr slot-entry)))
+				     `(,variable-name
+				        (,accessor-name ,in))))
+			       slots)
+          ,@body))))))
+
+(defun expand-symbol-macrolet-internal (specs form context env)
   (let ((entry nil))
     (cond ((not (eq context :eval)) form)
 	  ((symbolp form)
 	   (if (and (setq entry (assoc form specs))
 		    (eq (cadr entry) (variable-lexical-p form env)))
-	       (funcall translate-fn (caddr entry))
+	       (caddr entry)
 	       form))
 	  ((not (listp form)) form)
 	  ((member (car form) '(setq setf))
@@ -1374,7 +1416,7 @@ work during bootstrapping.
 					   (variable-lexical-p (car tail)
 							       env)))
 				  (progn (setq kind 'setf)
-					 (funcall translate-fn (caddr entry)))
+					 (caddr entry))
 				  (car tail))
 			      (cadr tail)
 			      (scan-setf (cddr tail))))))
@@ -1392,3 +1434,4 @@ work during bootstrapping.
 				   gensyms)))))
 	  (t form))))
 
+
diff --git a/pcl/construct.lisp b/pcl/construct.lisp
index 8b4c84d63..ae63eda4d 100644
--- a/pcl/construct.lisp
+++ b/pcl/construct.lisp
@@ -580,9 +580,11 @@
 	 (constants ()))
     (dolist (slotd (class-slots class))
       (let ((name (slotd-name slotd))
-	    (initform (slotd-initform slotd)))
+	    (initform (slotd-initform slotd))
+	    (initfn (slotd-initfunction slotd)))
 	(cond ((null (memq name layout)))
-	      ((eq initform *slotd-unsupplied*)
+	      ((or (eq initform *slotd-unsupplied*)
+		   (null initfn))
 	       (push (cons name *slot-unbound*) constants))
 	      ((constantp initform)
 	       (push (cons name (eval initform)) constants)
@@ -815,7 +817,9 @@
 	       (initfn (slotd-initfunction slotd))
 	       (position (position name layout)))
 	  (cond ((neq alloc :instance)
-		 (unless (eq form *slotd-unsupplied*) (bail-out)))
+		 (unless (or (eq form *slotd-unsupplied*)
+			     (null initfn))
+		   (bail-out)))
 		((member position used-positions))
 		((or (constantp form)
 		     (eq form *slotd-unsupplied*)))
@@ -960,7 +964,9 @@
 	       (initfn (slotd-initfunction slotd))
 	       (position (position name layout)))
 	  (cond ((neq alloc :instance)
-		 (unless (eq form *slotd-unsupplied*) (bail-out)))
+		 (unless (or (eq form *slotd-unsupplied*) 
+			     (null initfn))
+		   (bail-out)))
 		((member position used-positions))
 		((or (constantp form)
 		     (eq form *slotd-unsupplied*)))
@@ -1086,9 +1092,12 @@
 	(let* ((alloc (slotd-allocation slotd))
 	       (name (slotd-name slotd))
 	       (form (slotd-initform slotd))
+	       (initfn (slotd-initfunction slotd))
 	       (position (position name layout)))
 	  (cond ((neq alloc :instance)
-		 (unless (eq form *slotd-unsupplied*) (bail-out)))
+		 (unless (or (eq form *slotd-unsupplied*)
+			     (null initfn))
+		   (bail-out)))
 		((member position used-positions))
 		((or (constantp form)
 		     (eq form *slotd-unsupplied*)))
@@ -1096,3 +1105,4 @@
 		 (bail-out)))))
       
       (values constants (nreverse supplied-initarg-positions)))))
+
diff --git a/pcl/defclass.lisp b/pcl/defclass.lisp
index 9c417c068..1f534f0c9 100644
--- a/pcl/defclass.lisp
+++ b/pcl/defclass.lisp
@@ -45,16 +45,48 @@
 (defun make-top-level-form (name times form)
   (flet ((definition-name ()
 	   (if (and (listp name)
-		    (memq (car name) '(class method method-combination)))
+		    (memq (car name) '(defmethod defclass class method method-combination)))
 	       (format nil "~A~{ ~S~}"
 		       (capitalize-words (car name) ()) (cdr name))
 	       (format nil "~S" name))))
     (definition-name)
     #+Genera
-    (let ((thunk-name (make-symbol "TOP-LEVEL-FORM")))
-      `(eval-when ,times
-	 (defun ,thunk-name () (declare (sys:function-parent ,@name)) ,form)
-	 (,thunk-name)))
+    (progn
+      #-Genera-Release-8
+      (let ((thunk-name (gensym "TOP-LEVEL-FORM")))
+	`(eval-when ,times
+	   (defun ,thunk-name ()
+	     (declare (sys:function-parent
+			,(cond ((listp name)
+				(case (first name)
+				  (defmethod `(method ,@(rest name)))
+				  (otherwise (second name))))
+			       (t name))
+			,(cond ((listp name)
+				(case (first name)
+				  ((defmethod defgeneric) 'defun)
+				  ((defclass) 'defclass)
+				  (otherwise (first name))))
+			       (t 'defun))))
+	     ,form)
+	   (,thunk-name)))
+      #+Genera-Release-8
+      `(compiler-let ((compiler:default-warning-function ',name))
+	 (eval-when ,times
+	   (funcall #'(lambda ()
+			(declare ,(cond ((listp name)
+					 (case (first name)
+					   ((defclass)
+					    `(sys:function-parent ,(second name) defclass))
+					   ((defmethod)
+					    `(sys:function-name (method ,@(rest name))))
+					   ((defgeneric)
+					    `(sys:function-name ,(second name)))
+					   (otherwise
+					     `(sys:function-name ,name))))
+					(t
+					 `(sys:function-name ,name))))
+			,form)))))
     #+LCL3.0
     `(compiler-let ((lucid::*compiler-message-string*
 		      (or lucid::*compiler-message-string*
@@ -269,3 +301,4 @@
     (setq *early-class-definitions*
 	  (cons ecd (remove existing *early-class-definitions*)))
     ecd))
+
diff --git a/pcl/defs.lisp b/pcl/defs.lisp
index 0a39bf3b5..fa74bdb13 100644
--- a/pcl/defs.lisp
+++ b/pcl/defs.lisp
@@ -152,7 +152,9 @@
 
 #-cmu
 (defun setfboundp (symbol)
-  #+Genera nil
+  #+Genera (not (null (get-properties (symbol-plist symbol)
+				      'lt::(derived-setf-function trivial-setf-method
+					    setf-equivalence setf-method))))
   #+Lucid  (locally
 	     (declare (special lucid::*setf-inverse-table*
 			       lucid::*simple-setf-method-table*
@@ -305,29 +307,87 @@
     (name (fdefine-carefully (get-setf-function-name name) new-value))))
 
 
+(defun type-class (type)
+  (if (consp type)
+      (case (car type)
+	(class-eq (cadr type))
+	(eql (class-of (cadr type)))
+	(t (and (null (cdr type)) (find-class (car type) nil))))
+      (if (symbolp type)
+	  (find-class type nil)
+	  (and (class-specializer-p type)
+	       (specializer-class type)))))
+
+(defun class-type-p (type)
+  (if (consp type)
+      (and (null (cdr type)) (find-class (car type) nil))
+      (if (symbolp type)
+	  (find-class type nil)
+	  (and (classp type) type))))
+;;;;;;
+(defun exact-class-type-p (type)
+  (if (consp type)
+      (or (eq (car type) 'class-eq) (eq (car type) 'eql))
+      (exact-class-specializer-p type)))
+
+(defun make-class-eq-predicate (class)
+  (when (symbolp class) (setq class (find-class class)))
+  #'(lambda (object) (eq class (class-of object))))
+
+(deftype class-eq (class)
+  `(satisfies ,(make-class-eq-predicate class)))
+
+(defun class-eq-type-p (type)
+  (if (consp type)
+      (eq (car type) 'class-eq)
+      (class-eq-specializer-p type)))
+;;;;;;
+(defun make-eql-predicate (eql-object)
+  #'(lambda (object) (eql eql-object object)))
+
+(deftype eql (type-object)
+  `(satisfies ,(make-eql-predicate type-object)))
+
+(defun eql-type-p (type)
+  (if (consp type)
+      (eq (car type) 'eql)
+      (eql-specializer-p type)))
+
+(defun type-object (type)
+  (if (consp type)
+      (cadr type)
+      (specializer-object type)))
+
+;;;;;;
+(defun not-type-p (type)
+  (and (consp type) (eq (car type) 'not)))
+
+(defun not-type (type)
+  (cadr type))
+
 ;;;
 ;;; These functions are a pale imitiation of their namesake.  They accept
 ;;; class objects or types where they should.
 ;;; 
 (defun *typep (object type)
-  (if (classp type)
-      (let ((class (class-of object)))
-	(if class
-	    (memq type (class-precedence-list class))
-	    nil))
-      (let ((class (find-class type nil)))
-	(if class
-	    (*typep object class)
-	    (typep object type)))))
+  (let ((specializer (or (class-type-p type) 
+			 (and (specializerp type) type))))
+    (cond (specializer
+	    (specializer-type-p object specializer))
+	  ((not-type-p type)
+	   (not (*typep object (not-type type))))
+	  (t
+	   (typep object type)))))
 
 (defun *subtypep (type1 type2)
-  (let ((c1 (if (classp type1) type1 (find-class type1 nil)))
-	(c2 (if (classp type2) type2 (find-class type2 nil))))
-    (if (and c1 c2)
-	(memq c2 (class-precedence-list c1))
-	(if (or c1 c2)
-	    nil					;This isn't quite right, but...
-	    (subtypep type1 type2)))))
+  (let ((c1 (class-type-p type1))
+	(c2 (class-type-p type2)))
+    (cond ((and c1 c2)
+	   (values (memq c2 (class-precedence-list c1)) t))
+	  ((setq c1 (or c1 (specializerp type1)))
+	   (specializer-applicable-using-type-p c1 type2))
+	  ((or (null c2) (classp c2))
+	   (subtypep type1 (if c2 (class-name c2) type2))))))
 
 (defun do-satisfies-deftype (name predicate)
 #|
@@ -377,8 +437,13 @@
 		    *the-class-method*
 		    *the-class-generic-function*
 		    *the-class-standard-class*
+	            *the-class-funcallable-standard-class*
 		    *the-class-standard-method*
-		    *the-class-standard-generic-function*))
+		    *the-class-standard-generic-function*
+	            *the-class-standard-effective-slot-definition*
+
+	            *the-eslotd-standard-class-slots*
+	            *the-eslotd-funcallable-standard-class-slots*))
 
 (proclaim '(special *the-wrapper-of-t*
 		    *the-wrapper-of-vector* *the-wrapper-of-symbol*
@@ -518,6 +583,8 @@
 
 (defclass specializer (metaobject) ())
 
+(defclass class-specializer (specializer) ())
+
 (defclass definition-source-mixin (standard-object)
      ((source
 	:initform (load-truename)
@@ -540,7 +607,7 @@
 ;;; have the class CLASS in its class precedence list.
 ;;; 
 (defclass class (documentation-mixin dependent-update-mixin definition-source-mixin
-				     specializer)
+				     class-specializer)
      ((name
 	:initform nil
 	:initarg  :name
@@ -629,7 +696,13 @@
 	:accessor slotd-type)
       (documentation
 	:initform ""
-	:initarg :documentation)))
+	:initarg :documentation)
+      (class
+        :initform nil
+	:accessor slotd-class)
+      (instance-index
+        :initform nil
+	:accessor slotd-instance-index)))
 
 (defclass standard-direct-slot-definition (standard-slot-definition
 					   direct-slot-definition)
@@ -646,7 +719,7 @@
 
 
 (defclass eql-specializer (specializer)
-     ((object :initarg :object :reader eql-specializer-object)))
+     ((object :initarg :object :reader specializer-object)))
 
 
 
@@ -663,53 +736,4 @@
 		 ,@body)
 	       (,improper-list-handler)))))
 
-(defun legal-std-documentation-p (x)
-  (if (or (null x) (stringp x))
-      t
-      "a string or NULL"))
-
-(defun legal-std-lambda-list-p (x)
-  (declare (ignore x))
-  t)
-
-(defun legal-std-method-function-p (x)
-  (if (functionp x)
-      t
-      "a function"))
-
-(defun legal-std-qualifiers-p (x)
-  (flet ((improper-list ()
-	   (return-from legal-std-qualifiers-p "Is not a proper list.")))
-    (dolist-carefully (q x improper-list)
-      (let ((ok (legal-std-qualifier-p q)))
-	(unless (eq ok t)
-	  (return-from legal-std-qualifiers-p
-	    (format nil "Contains ~S which ~A" q ok)))))
-    t))
-
-(defun legal-std-qualifier-p (x)
-  (if (and x (atom x))
-      t
-      "is not a non-null atom"))
-
-(defun legal-std-slot-name-p (x)
-  (cond ((not (symbolp x)) "is not a symbol and so cannot be bound")
-	((keywordp x)      "is a keyword and so cannot be bound")
-	((memq x '(t nil)) "cannot be bound")
-	(t t)))
-
-(defun legal-std-specializers-p (x)
-  (flet ((improper-list ()
-	   (return-from legal-std-specializers-p "Is not a proper list.")))
-    (dolist-carefully (s x improper-list)
-      (let ((ok (legal-std-specializer-p s)))
-	(unless (eq ok t)
-	  (return-from legal-std-specializers-p
-	    (format nil "Contains ~S which ~A" s ok)))))
-    t))
-
-(defun legal-std-specializer-p (x)
-  (if (or (classp x)
-	  (eql-specializer-p x))
-      t
-      "is neither a class object nor an eql specializer"))
+
diff --git a/pcl/defsys.lisp b/pcl/defsys.lisp
index e3ccaa9d4..eb1e020f3 100644
--- a/pcl/defsys.lisp
+++ b/pcl/defsys.lisp
@@ -70,32 +70,40 @@
 ;;; 
 (defvar *the-pcl-package* (find-package :pcl))
 
-(defvar *pcl-system-date* "5/1/90  May Day PCL (REV 2)")
+(defvar *pcl-system-date* "5/1/90  May Day PCL (REV 4b)")
 
 
 ;;;
 ;;; Various hacks to get people's *features* into better shape.
 ;;; 
 (eval-when (compile load eval)
-
   #+(and Symbolics Lispm)
   (multiple-value-bind (major minor) (sct:get-release-version)
+    (etypecase minor
+      (integer)
+      (string (setf minor (parse-integer minor :junk-allowed t))))
     (pushnew :genera *features*)
     (ecase major
       ((6)
        (pushnew :genera-release-6 *features*))
       ((7)
        (pushnew :genera-release-7 *features*)
-       (ecase (etypecase minor
-		(integer minor)
-		(string (digit-char-p (char minor 0))))
+       (ecase minor
 	 ((0 1) (pushnew :genera-release-7-1 *features*))
 	 ((2)   (pushnew :genera-release-7-2  *features*))
 	 ((3)   (pushnew :genera-release-7-3  *features*))
-	 ((4)   (pushnew :genera-release-7-4  *features*))
-	 ((5)   (pushnew :genera-release-7-5  *features*))))))
-
+	 ((4)   (pushnew :genera-release-7-4  *features*))))
+      ((8)
+       (pushnew :genera-release-8 *features*)
+       (ecase minor
+	 ((0) (pushnew :genera-release-8-0 *features*))
+	 ((1) (pushnew :genera-release-8-1 *features*))))))
   
+  #+CLOE-Runtime
+  (let ((version (lisp-implementation-version)))
+    (when (string-equal version "2.0" :end1 (min 3 (length version)))
+      (pushnew :cloe-release-2 *features*)))
+
   (dolist (feature *features*)
     (when (and (symbolp feature)                ;3600!!
                (equal (symbol-name feature) "CMU"))
@@ -118,7 +126,7 @@
 
   #+(and HP Lucid)
   (push :HP-Lucid *features*)
-  #+(and HP (not Lucid))
+  #+(and HP (not Lucid) (not excl))
   (push :HP-HPLabs *features*)
 
   #+Xerox
@@ -208,7 +216,9 @@ and load your system with:
           #+Genera-Release-7-2   Rel-7-2
 	  #+Genera-Release-7-3   Rel-7-2	;OK for now
 	  #+Genera-Release-7-4   Rel-7-2	;OK for now
+	  #+Genera-Release-8	 Rel-8
 	  #+imach                Ivory
+	  #+Cloe-Runtime	 Cloe
           #+Lucid                Lucid
           #+Xerox                Xerox
 	  #+Xerox-Lyric          Xerox-Lyric
@@ -218,6 +228,7 @@ and load your system with:
           #+KCL                  KCL
           #+IBCL                 IBCL
           #+excl                 excl
+	  #+(and excl sun4)      excl-sun4
           #+:CMU                 CMU
           #+HP-HPLabs            HP-HPLabs
           #+:gclisp              gclisp
@@ -255,6 +266,7 @@ and load your system with:
           (car
            '(#+(and Genera (not imach))          ("lisp"  . "bin")
 	     #+(and Genera imach)                ("lisp"  . "ibin")
+	     #+Cloe-Runtime			 ("l"	  . "fasl")
              #+(and dec common vax (not ultrix)) ("LSP"   . "FAS")
              #+(and dec common vax ultrix)       ("lsp"   . "fas")
              #+KCL                               ("lsp"   . "o")
@@ -268,6 +280,7 @@ and load your system with:
              #+(and Lucid IBM-RT-PC)             ("lisp"  . "bbin")
              #+(and Lucid MIPS)                  ("lisp"  . "mbin")
              #+(and Lucid PRISM)                 ("lisp"  . "abin")
+             #+(and Lucid PA)                    ("lisp"  . "hbin")
 	     #+excl                              ("cl"    . "fasl")
 	     #+cmu ("lisp" . #.(c:backend-fasl-file-type c:*backend*))
              #+HP                                ("l"     . "b")
@@ -556,13 +569,31 @@ and load your system with:
     ;; compatibility.  In 2.1 it was in the SYSTEM package, and i
     ;; 3.0 it's in the LUCID-COMMON-LISP package.
     ;;
-    #+LUCID (or lucid::*source-pathname* (bad-time))))
+    #+LUCID (or lucid::*source-pathname* (bad-time))
+    #-(or Lispm excl Xerox (and dec vax common) LUCID) nil))
 
 (defvar *pcl-directory* (pathname "pcl:"))
 
+#+Genera
+(defvar *pcl-directory*
+	(let ((source (load-truename t)))
+	  (flet ((subdir (name)
+		   (scl:send source :new-pathname :raw-directory
+			     (append (scl:send source :raw-directory)
+				     (list name)))))
+	    (cons source
+		  #+genera-release-7-2       (subdir "rel-7-2")
+		  #+genera-release-7-3       (subdir "rel-7-3") 
+		  #+genera-release-7-4       (subdir "rel-7-4")
+		  #+genera-release-8-0       (subdir "rel-8-0")
+		  #+genera-release-8-1       (subdir "rel-8-1")
+		  ))))
+
+#+Cloe-Runtime
+(defvar *pcl-directory* (pathname "/usr3/hornig/pcl/"))
 
 (defsystem pcl	   
-	   *pcl-directory*
+           *pcl-directory*
   ;;
   ;; file         load           compile      files which       port
   ;;              environment    environment  force the of
@@ -573,6 +604,7 @@ and load your system with:
 ;  (rel-6-patches   t            t            ()                rel-6)
 ;  (rel-7-1-patches t            t            ()                rel-7-1)
    (rel-7-2-patches t            t            ()                rel-7-2)
+   (rel-8-patches   t            t            ()                rel-8)
    (ti-patches      t            t            ()                ti)
    (pyr-patches     t          t              ()                pyramid)
    (xerox-patches   t            t            ()                xerox)
@@ -588,6 +620,7 @@ and load your system with:
    
    
    (genera-low     (low)         (low)        (low)            Genera)
+   (cloe-low	   (low)	 (low)	      (low)            Cloe)
    (lucid-low      (low)         (low)        (low)            Lucid)
    (Xerox-low      (low)         (low)        (low)            Xerox)
    (ti-low         (low)         (low)        (low)            TI)
@@ -607,8 +640,8 @@ and load your system with:
    (fngen       t                                   t (low))
    (lap         t                                   t (low))
    (plap        t                                   t (low))
-   (cpatch      t                                   t (low)    excl)	;***
-   (quadlap     t                                   t (low)    excl)	;***
+   (cpatch      t                                   t (low)    excl-sun4)
+   (quadlap     t                                   t (low)    excl-sun4)
    (cache       t                                   t (low defs))
    (dlap        t                                   t (defs low fin cache lap))
    (boot        t                                   t (defs fin))
@@ -637,6 +670,7 @@ and load your system with:
   (let (#+:coral(ccl::*warn-if-redefine-kernel* nil)
 	#+Lucid (lcl:*redefinition-action* nil)
 	#+excl  (excl::*redefinition-warnings* nil)
+	#+Genera (sys:inhibit-fdefine-warnings t)
 	)
     (cond ((null m)        (operate-on-system 'pcl :compile))
 	  ((eq m :print)   (operate-on-system 'pcl :compile () t))
@@ -650,12 +684,30 @@ and load your system with:
   (let (#+:coral(ccl::*warn-if-redefine-kernel* nil)
 	#+Lucid (lcl:*redefinition-action* nil)
 	#+excl  (excl::*redefinition-warnings* nil)
+	#+Genera (sys:inhibit-fdefine-warnings t)
 	)
     (cond ((null m)      (operate-on-system 'pcl :load))
 	  ((eq m :query) (operate-on-system 'pcl :query-load)))
     (pushnew :pcl *features*)
     (pushnew :portable-commonloops *features*)))
 
+#+Genera
+;;; Make sure Genera bug mail contains the PCL bug data.  A little
+;;; kludgy, but what the heck.  If they didn't mean for people to do
+;;; this, they wouldn't have made private patch notes be flavored
+;;; objects, right?  Right.
+(progn
+  (scl:defflavor pcl-private-patch-info ((description)) ())
+  (scl:defmethod (sct::private-patch-info-description pcl-private-patch-info) ()
+    (or description
+	(setf description (string-append "PCL version: " *pcl-system-date*))))
+  (scl:defmethod (sct::private-patch-info-pathname pcl-private-patch-info) ()
+    *pcl-directory*)
+  (unless (find-if #'(lambda (x) (typep x 'pcl-private-patch-info))
+		   sct::*private-patch-info*)
+    (push (scl:make-instance 'pcl-private-patch-info)
+	  sct::*private-patch-info*)))
+
 (defun bug-report-info (&optional (stream *standard-output*))
   (format stream "~&PCL system date: ~A~
                   ~&Lisp Implementation type: ~A~
@@ -747,3 +799,4 @@ and load your system with:
       (zwei:make-buffer-current original-buffer))))
 
 
+
diff --git a/pcl/env.lisp b/pcl/env.lisp
index 861d72c25..01f7159dd 100644
--- a/pcl/env.lisp
+++ b/pcl/env.lisp
@@ -29,45 +29,6 @@
 
 (in-package 'pcl)
 
-#+Genera
-(progn
-
-(defvar *old-arglist*)
-
-(defun pcl-arglist (function &rest other-args)
-  (let ((defn nil))
-    (cond ((and (fsc-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))
-		(fsc-instance-p defn)
-		(generic-function-p defn))
-	   (generic-function-pretty-arglist defn))
-	  (t (apply *old-arglist* function other-args)))))
-
-(eval-when (eval load)
-  (unless (boundp '*old-arglist*)
-    (setq *old-arglist* (symbol-function 'zl:arglist))
-    (setf (symbol-function 'zl:arglist) #'pcl-arglist)))
-
-
-(defvar *old-function-name*)
-
-(defun pcl-function-name (function &rest other-args)
-  (if (and (fsc-instance-p function)
-	   (generic-function-p function))
-      (generic-function-name function)
-      (apply *old-function-name* function other-args)))
-
-(eval-when (eval load)
-  (unless (boundp '*old-function-name*)
-    (setq *old-function-name* (symbol-function 'si:function-name))
-    (setf (symbol-function 'si:function-name) #'pcl-function-name)))
-
-)
-
 #+Lucid
 (progn
 
@@ -100,6 +61,8 @@
 
 (defgeneric describe-object (object stream))
 
+#-Genera (progn
+
 #-cmu
 (defvar *old-describe* ())
 
@@ -317,3 +280,4 @@
       (remove-method gf method)
       method)))
 
+); #-genera progn
diff --git a/pcl/fin.lisp b/pcl/fin.lisp
index b3060d4ec..28d32b2b3 100644
--- a/pcl/fin.lisp
+++ b/pcl/fin.lisp
@@ -305,7 +305,7 @@ explicitly marked saying who wrote it.
 ;;;  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)
 ;;;      
-#+Genera
+#+(and Genera (not Genera-Release-8))
 (progn
 
 (defvar *funcallable-instance-marker* (list "Funcallable Instance Marker"))
@@ -358,7 +358,9 @@ explicitly marked saying who wrote it.
                                             (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)
@@ -373,30 +375,321 @@ explicitly marked saying who wrote it.
 ;;;
 ;;; Make funcallable instances print out properly.
 ;;; 
-(defvar *old-print-lexical-closure*)
-
 (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 *old-print-lexical-closure* exp stream slashify-p))
+	(funcall (get 'si:print-lexical-closure ':definition-before-pcl)
+		 exp stream slashify-p))
       (let ((*print-escape* slashify-p)
 	    (*print-lexical-closure* exp))
 	(print-object exp stream))))
 
 (eval-when (load eval)
-  (unless (boundp '*old-print-lexical-closure*)
-    (setq *old-print-lexical-closure* #'si:print-lexical-closure)
-    (setf (symbol-function 'si:print-lexical-closure)
-	  'pcl-print-lexical-closure)))
+  (unless (boundp '*boot-state*)
+    (setq *boot-state* nil))
+  (unless (get 'si:print-lexical-closure ':definition-before-pcl)
+    (setf (get 'si:print-lexical-closure ':definition-before-pcl)
+	  (symbol-function 'si:print-lexical-closure)))
+  (setf (symbol-function 'si:print-lexical-closure)
+	(symbol-function '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 (get 'si:function-name ':definition-before-pcl) function other-args)))
+
+(eval-when (eval load)
+  (unless (get 'si:function-name ':definition-before-pcl)
+    (setf (get 'si:function-name ':definition-before-pcl) 
+	  (symbol-function 'si:function-name)))
+  (setf (symbol-function 'si:function-name) 
+	(symbol-function '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 (get 'zl:arglist ':definition-before-pcl) function other-args)))))
+
+(eval-when (eval load)
+  (unless (get 'zl:arglist ':definition-before-pcl)
+    (setf (get 'zl:arglist ':definition-before-pcl)
+	  (symbol-function 'zl:arglist)))
+  (setf (symbol-function 'zl:arglist)
+	(symbol-function '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))
+
+)
+
+)
 
 
 ;;;
@@ -1119,7 +1412,7 @@ explicitly marked saying who wrote it.
 ;;; this file.
 ;;;
 
-#+(or KCL IBCL)
+#+(and KCL (not IBCL))
 (progn
 
 (defvar *funcallable-instance-marker* (list "Funcallable Instance Marker"))
@@ -1225,6 +1518,111 @@ make_turbo_trampoline_internal(base0)
 (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
@@ -1515,18 +1913,20 @@ make_turbo_trampoline_internal(base0)
 	     (called-fin-without-function))
          ccl::initial-fin-slots))
 
-;;; Make uvector-based objects (like funcallable instances) print better.
 #+: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.
-#+:ccl-1.3
-(eval-when (eval compile load)
-  (pushnew (cons 'ccl::funcallable-instance #'print-uvector-object)
-           ccl:*write-uvector-alist*
-           :test #'equal))
+(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)
@@ -1576,3 +1976,4 @@ make_turbo_trampoline_internal(base0)
     (setf (fsc-instance-wrapper fin) wrapper
           (fsc-instance-slots fin) slots)
     fin))
+
diff --git a/pcl/lap.lisp b/pcl/lap.lisp
index 4972d33a6..9877a96f7 100644
--- a/pcl/lap.lisp
+++ b/pcl/lap.lisp
@@ -479,3 +479,4 @@
       (error "LAP TEST 5 failed."))))
 
 |#
+
diff --git a/pcl/pkg.lisp b/pcl/pkg.lisp
index 8593c4979..57c35a76b 100644
--- a/pcl/pkg.lisp
+++ b/pcl/pkg.lisp
@@ -180,3 +180,4 @@
 ;
 ;
 ;			  ))
+
diff --git a/pcl/plap.lisp b/pcl/plap.lisp
index 6e40319e8..0cf0a33c8 100644
--- a/pcl/plap.lisp
+++ b/pcl/plap.lisp
@@ -110,7 +110,8 @@
 			  ,(lap-reg-initial-value-form reg)))
 		    (append i-regs v-regs t-regs))
 	   (declare (type fixnum ,@(mapcar #'lap-reg *lap-i-regs*))
-		    (type simple-vector ,@(mapcar #'lap-reg *lap-v-regs*)))
+		    (type simple-vector ,@(mapcar #'lap-reg *lap-v-regs*))
+	            (optimize . ,*lap-optimize-declaration*))
 	   ,.code)))
 
 (defconstant *empty-vector* '#())
@@ -310,3 +311,4 @@
     (dotimes (i line-size-in-bits)  (setq mask (dpb 0 (byte 1 i) mask)))
     mask))
 
+
diff --git a/pcl/quadlap.lisp b/pcl/quadlap.lisp
index ff1b9b319..0b6fba974 100644
--- a/pcl/quadlap.lisp
+++ b/pcl/quadlap.lisp
@@ -1,6 +1,6 @@
 ;;				-[Thu Mar  1 10:54:27 1990 by jkf]-
 ;; pcl to quad translation
-;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/quadlap.lisp,v 1.1.1.1 1991/10/19 16:45:45 ram Exp $
+;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/quadlap.lisp,v 1.2 1991/10/19 17:23:26 ram Exp $
 ;;
 ;; copyright (c) 1990 Franz Inc.
 ;;
diff --git a/pcl/walk.lisp b/pcl/walk.lisp
index 1003ea606..c63c46254 100644
--- a/pcl/walk.lisp
+++ b/pcl/walk.lisp
@@ -475,6 +475,32 @@
 
 );#+Genera
 
+#+Cloe-Runtime
+(progn
+
+(defmacro with-augmented-environment
+	  ((new-env old-env &key functions macros) &body body)
+  `(let ((,new-env (with-augmented-environment-internal ,old-env ,functions ,macros)))
+     ,@body))
+
+(defun with-augmented-environment-internal (env functions macros)
+  functions
+  (dolist (m macros)
+    (setf env `(,(first m) (compiler::macro . ,(second m)) ,@env)))
+  env)
+
+(defun environment-function (env fn)
+  nil)
+
+(defun environment-macro (env macro)
+  (let ((entry (getf env macro)))
+    (if (and (consp entry)
+	     (eq (car entry) 'compiler::macro))
+	(values (cdr entry) t)
+	(values nil nil))))
+
+);#+Cloe-Runtime
+
 
 ;;;
 ;;; In Xerox Lisp, the compiler and interpreter use different structures for
@@ -986,12 +1012,13 @@
 ;;; Common Lisp nit:
 ;;;   variable-globally-special-p should be defined in Common Lisp.
 ;;;
-#-(or Genera Lucid Xerox Excl KCL IBCL (and dec vax common) :CMU HP-HPLabs
+#-(or Genera Cloe-Runtime Lucid Xerox Excl KCL IBCL (and dec vax common) :CMU HP-HPLabs
       GCLisp TI pyramid)
 (defvar *globally-special-variables* ())
 
 (defun variable-globally-special-p (symbol)
   #+Genera                      (si:special-variable-p symbol)
+  #+Cloe-Runtime		(compiler::specialp symbol)
   #+Lucid                       (lucid::proclaimed-special-p symbol)
   #+TI                          (get symbol 'special)
   #+Xerox                       (il:variable-globally-special-p symbol)
@@ -1007,7 +1034,7 @@
 				    (get symbol
 					 'clc::globally-special-in-compiler))
   #+:CORAL                      (ccl::proclaimed-special-p symbol)
-  #-(or Genera Lucid Xerox Excl KCL IBCL (and dec vax common) :CMU HP-HPLabs
+  #-(or Genera Cloe-Runtime Lucid Xerox Excl KCL IBCL (and dec vax common) :CMU HP-HPLabs
 	GCLisp TI pyramid :CORAL)
   (or (not (null (member symbol *globally-special-variables* :test #'eq)))
       (when (eval `(flet ((ref () ,symbol))
@@ -1534,23 +1561,30 @@
 
 (defun walk-prog/prog* (form context old-env sequentialp)
   (walker-environment-bind (new-env old-env)
-    (let* ((let/let* (car form))
-	   (bindings (cadr form))
-	   (body (cddr form))
-	   (walked-bindings 
-	     (walk-bindings-1 bindings
-			      old-env
-			      new-env
-			      context
-			      sequentialp))
-	   (walked-body
-	     (walk-declarations 
-	       body
-	       #'(lambda (real-body real-env)
-		   (walk-tagbody-1 real-body context real-env))
-	       new-env)))
-      (relist*
-	form let/let* walked-bindings walked-body))))
+    (let* ((possible-block-name (second form))
+	   (blocked-prog (and (symbolp possible-block-name)
+			      (not (eq possible-block-name 'nil)))))
+      (multiple-value-bind (let/let* block-name bindings body)
+	  (if blocked-prog
+	      (values (car form) (cadr form) (caddr form) (cdddr form))
+	      (values (car form) nil	     (cadr  form) (cddr  form)))
+	(let* ((walked-bindings 
+		 (walk-bindings-1 bindings
+				  old-env
+				  new-env
+				  context
+				  sequentialp))
+	       (walked-body
+		 (walk-declarations 
+		   body
+		   #'(lambda (real-body real-env)
+		       (walk-tagbody-1 real-body context real-env))
+		   new-env)))
+	  (if block-name
+	      (relist*
+		form let/let* block-name walked-bindings walked-body)
+	      (relist*
+		form let/let* walked-bindings walked-body)))))))
 
 (defun walk-do/do* (form context old-env sequentialp)
   (walker-environment-bind (new-env old-env)
@@ -2042,3 +2076,4 @@
 |#
 
 ()
+
-- 
GitLab