Working for Medley 3.5

clos/3.5/README.MD

@@ -0,0 +1,3 @@
+This is based on the '91 PCL. In order to load this into Medley 3.5, load t
+the file DEFSYS.DFASL, and then execute (CLOS::LOAD-CLOS).  After this all
+the CLOS functionality is in the package CLOS. 

clos/3.5/braid.lisp

@@ -0,0 +1,503 @@
+;;;-*-Mode:LISP; Package:(CLOS (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1991 Venue
+;;; All rights reserved.
+;;; *************************************************************************
+;;;
+;;; Bootstrapping the meta-braid.
+;;;
+;;; The code in this file takes the early definitions that have been saved
+;;; up and actually builds those class objects.  This work is largely driven
+;;; off of those class definitions, but the fact that STANDARD-CLASS is the
+;;; class of all metaclasses in the braid is built into this code pretty
+;;; deeply.
+;;;
+;;; 
+
+(in-package 'clos)
+
+(defun early-class-definition (class-name)
+  (or (find class-name *early-class-definitions* :key #'ecd-class-name)
+      (error "~S is not a class in *early-class-definitions*." class-name)))
+
+(defun canonical-slot-name (canonical-slot)
+  (getf canonical-slot :name))
+
+(defun early-collect-inheritance (class-name)
+  (declare (values slots cpl default-initargs direct-subclasses))
+  (let ((cpl (early-collect-cpl class-name)))
+    (values (early-collect-slots cpl)
+	    cpl
+	    (early-collect-default-initargs cpl)
+	    (gathering1 (collecting)
+	      (dolist (definition *early-class-definitions*)
+		(when (memq class-name (ecd-superclass-names definition))
+		  (gather1 (ecd-class-name definition))))))))
+
+(defun early-collect-cpl (class-name)
+  (labels ((walk (c)
+	     (let* ((definition (early-class-definition c))
+		    (supers (ecd-superclass-names definition)))
+	       (cons c
+		     (apply #'append (mapcar #'early-collect-cpl supers))))))
+    (remove-duplicates (walk class-name) :from-end nil :test #'eq)))
+
+(defun early-collect-slots (cpl)
+  (let* ((definitions (mapcar #'early-class-definition cpl))
+	 (super-slots (mapcar #'ecd-canonical-slots definitions))
+	 (slots (apply #'append (reverse super-slots))))
+    (dolist (s1 slots)
+      (let ((name1 (canonical-slot-name s1)))
+	(dolist (s2 (cdr (memq s1 slots)))
+	  (when (eq name1 (canonical-slot-name s2))
+	    (error "More than one early class defines a slot with the~%~
+                    name ~S.  This can't work because the bootstrap~%~
+                    object system doesn't know how to compute effective~%~
+                    slots."
+		   name1)))))
+    slots))
+
+(defun early-collect-default-initargs (cpl)
+  (let ((default-initargs ()))
+    (dolist (class-name cpl)
+      (let ((definition (early-class-definition class-name)))
+	(dolist (option (ecd-other-initargs definition))
+	  (unless (eq (car option) :default-initargs)
+	    (error "The defclass option ~S is not supported by the bootstrap~%~
+                    object system."
+		   (car option)))
+	  (setq default-initargs
+		(nconc default-initargs (reverse (cdr option)))))))
+    (reverse default-initargs)))
+
+
+;;;
+;;; bootstrap-get-slot and bootstrap-set-slot are used to access and change
+;;; the values of slots during bootstrapping.  During bootstrapping, there
+;;; are only two kinds of objects whose slots we need to access, CLASSes
+;;; and SLOTDs.  The first argument to these functions tells whether the
+;;; object is a CLASS or a SLOTD.
+;;;
+;;; Note that the way this works it stores the slot in the same place in
+;;; memory that the full object system will expect to find it later.  This
+;;; is critical to the bootstrapping process, the whole changeover to the
+;;; full object system is predicated on this.
+;;;
+;;; One important point is that the layout of standard classes and standard
+;;; slots must be computed the same way in this file as it is by the full
+;;; object system later.
+;;; 
+(defun bootstrap-get-slot (type object slot-name)
+  (let ((index (bootstrap-slot-index type slot-name)))
+    (svref (std-instance-slots object) index)))
+
+(defun bootstrap-set-slot (type object slot-name new-value)
+  (let ((index (bootstrap-slot-index type slot-name)))
+    (setf (svref (std-instance-slots object) index) new-value)))
+
+(defvar *std-class-slots*
+	(mapcar #'canonical-slot-name
+		(early-collect-inheritance 'standard-class)))
+
+(defvar *bin-class-slots*
+	(mapcar #'canonical-slot-name
+		(early-collect-inheritance 'built-in-class)))
+
+(defvar *std-slotd-slots*
+	(mapcar #'canonical-slot-name
+		(early-collect-inheritance 'standard-slot-definition)))
+
+(defun bootstrap-slot-index (type slot-name)
+  (or (position slot-name (ecase type
+			    (std-class *std-class-slots*)
+			    (bin-class *bin-class-slots*)
+			    (std-slotd *std-slotd-slots*)))
+      (error "~S not found" slot-name)))
+
+
+;;;
+;;; bootstrap-meta-braid
+;;;
+;;; This function builds the base metabraid from the early class definitions.
+;;;   
+(defun bootstrap-meta-braid ()
+  (let* ((std-class-size (length *std-class-slots*))
+         (std-class (%allocate-instance--class std-class-size))
+         (std-class-wrapper (make-wrapper std-class))
+	 (built-in-class (%allocate-instance--class std-class-size))
+	 (built-in-class-wrapper (make-wrapper built-in-class))
+	 (direct-slotd    (%allocate-instance--class std-class-size))
+	 (effective-slotd (%allocate-instance--class std-class-size))
+	 (direct-slotd-wrapper    (make-wrapper direct-slotd))
+	 (effective-slotd-wrapper (make-wrapper effective-slotd)))
+    ;;
+    ;; First, make a class metaobject for each of the early classes.  For
+    ;; each metaobject we also set its wrapper.  Except for the class T,
+    ;; the wrapper is always that of STANDARD-CLASS.
+    ;; 
+    (dolist (definition *early-class-definitions*)
+      (let* ((name (ecd-class-name definition))
+	     (meta (ecd-metaclass definition))
+             (class (case name
+                      (standard-class                     std-class)
+                      (standard-direct-slot-definition    direct-slotd)
+		      (standard-effective-slot-definition effective-slotd)
+		      (built-in-class                     built-in-class)
+                      (otherwise
+			(%allocate-instance--class std-class-size)))))
+	(unless (eq name t)
+	  (inform-type-system-about-class class name))
+	(setf (std-instance-wrapper class)
+	      (ecase meta
+		(standard-class std-class-wrapper)
+		(built-in-class built-in-class-wrapper)))
+        (setf (find-class name) class)))
+    ;;
+    ;;
+    ;;
+    (dolist (definition *early-class-definitions*)
+      (let ((name (ecd-class-name definition))
+	    (source (ecd-source definition))
+	    (direct-supers (ecd-superclass-names definition))
+	    (direct-slots  (ecd-canonical-slots definition))
+	    (other-initargs (ecd-other-initargs definition)))
+	(let ((direct-default-initargs
+		(getf other-initargs :default-initargs)))
+	  (multiple-value-bind (slots cpl default-initargs direct-subclasses)
+	      (early-collect-inheritance name)
+	    (let* ((class (find-class name))
+		   (wrapper
+		     (cond
+		       ((eq class std-class)       std-class-wrapper)
+		       ((eq class direct-slotd)    direct-slotd-wrapper)
+		       ((eq class effective-slotd) effective-slotd-wrapper)
+		       ((eq class built-in-class)  built-in-class-wrapper)
+		       (t (make-wrapper class))))
+		   (proto nil))
+	      (cond ((eq name 't)
+		     (setq *the-wrapper-of-t* wrapper
+			   *the-class-t* class))
+		    ((memq name '(standard-object 
+				  standard-class
+				  standard-effective-slot-definition))
+		     (set (intern (format nil "*THE-CLASS-~A*" (symbol-name name))
+				  *the-clos-package*)
+			  class)))
+	      (dolist (slot slots)
+		(unless (eq (getf slot :allocation :instance) :instance)
+		  (error "Slot allocation ~S not supported in bootstrap.")))
+	      
+	      (setf (wrapper-instance-slots-layout wrapper)
+		    (mapcar #'canonical-slot-name slots))
+	      (setf (wrapper-class-slots wrapper)
+		    ())
+	      
+	      (setq proto (%allocate-instance--class (length slots)))
+	      (setf (std-instance-wrapper proto) wrapper)
+	    
+	      (setq direct-slots
+		    (bootstrap-make-slot-definitions name direct-slots
+						     direct-slotd-wrapper nil))
+	      (setq slots
+		    (bootstrap-make-slot-definitions name slots
+						     effective-slotd-wrapper t))
+	      
+	      (bootstrap-initialize-std-class
+		class name source
+		direct-supers direct-subclasses cpl wrapper
+		direct-slots slots direct-default-initargs default-initargs
+		proto)
+	      
+	      (dolist (slotd direct-slots)
+		(bootstrap-accessor-definitions
+		  name
+		  (bootstrap-get-slot 'std-slotd slotd 'name)
+		  (bootstrap-get-slot 'std-slotd slotd 'readers)
+		  (bootstrap-get-slot 'std-slotd slotd 'writers))))))))))
+
+(defun bootstrap-accessor-definitions (class-name slot-name readers writers)
+  (flet ((do-reader-definition (reader)
+	   (add-method
+	     (ensure-generic-function reader)
+	     (make-a-method
+	       'standard-reader-method
+	       ()
+	       (list class-name)
+	       (list class-name)
+	       (make-std-reader-method-function slot-name)
+	       "automatically generated reader method"
+	       slot-name)))
+	 (do-writer-definition (writer)
+	   (add-method
+	     (ensure-generic-function writer)
+	     (make-a-method
+	       'standard-writer-method
+	       ()
+	       (list 'new-value class-name)
+	       (list 't class-name)
+	       (make-std-writer-method-function slot-name)
+	       "automatically generated writer method"
+	       slot-name))))
+    (dolist (reader readers) (do-reader-definition reader))
+    (dolist (writer writers) (do-writer-definition writer))))
+
+;;;
+;;; Initialize a standard class metaobject.
+;;;
+(defun bootstrap-initialize-std-class
+       (class
+	name definition-source direct-supers direct-subclasses cpl wrapper
+	direct-slots slots direct-default-initargs default-initargs proto)
+  (flet ((classes (names) (mapcar #'find-class names))
+	 (set-slot (slot-name value)
+	   (bootstrap-set-slot 'std-class class slot-name value)))
+    
+    (set-slot 'name name)
+    (set-slot 'source definition-source)
+    (set-slot 'class-precedence-list (classes cpl))
+    (set-slot 'direct-superclasses (classes direct-supers))
+    (set-slot 'direct-slots direct-slots)
+    (set-slot 'direct-subclasses (classes direct-subclasses))
+    (set-slot 'direct-methods (cons nil nil))
+    (set-slot 'no-of-instance-slots (length slots))
+    (set-slot 'slots slots)
+    (set-slot 'wrapper wrapper)
+    (set-slot 'prototype proto)
+    (set-slot 'plist
+	      `(,@(and direct-default-initargs
+		       `(direct-default-initargs ,direct-default-initargs))
+		,@(and default-initargs
+		       `(default-initargs ,default-initargs))))
+    ))
+
+;;;
+;;; Initialize a built-in-class metaobject.
+;;;
+(defun bootstrap-initialize-bin-class
+       (class
+	name definition-source direct-supers direct-subclasses cpl wrapper)
+  (flet ((classes (names) (mapcar #'find-class names))
+	 (set-slot (slot-name value)
+	   (bootstrap-set-slot 'bin-class class slot-name value)))
+    
+    (set-slot 'name name)
+    (set-slot 'source definition-source)
+    (set-slot 'direct-superclasses (classes direct-supers))
+    (set-slot 'direct-subclasses (classes direct-subclasses))
+    (set-slot 'direct-methods (cons nil nil))
+    (set-slot 'class-precedence-list (classes cpl))
+    (set-slot 'wrapper wrapper)))
+
+(defun bootstrap-make-slot-definitions (name slots wrapper e-p)
+  (mapcar #'(lambda (slot) (bootstrap-make-slot-definition name slot wrapper e-p))
+          slots))
+
+(defun bootstrap-make-slot-definition (name slot wrapper e-p)  
+  (let ((slotd (%allocate-instance--class (length *std-slotd-slots*))))
+    (setf (std-instance-wrapper slotd) wrapper)
+    (flet ((get-val (name) (getf slot name))
+	   (set-val (name val) (bootstrap-set-slot 'std-slotd slotd name val)))
+      (set-val 'name         (get-val :name))
+      (set-val 'initform     (get-val :initform))
+      (set-val 'initfunction (get-val :initfunction))      
+      (set-val 'initargs     (get-val :initargs))
+      (set-val 'readers      (get-val :readers))
+      (set-val 'writers      (get-val :writers))
+      (set-val 'allocation   :instance)
+      (set-val 'type         (get-val :type))
+      (set-val 'class        nil)
+      (set-val 'instance-index nil)
+      (when (and (eq name 'standard-class) (eq (get-val :name) 'slots) e-p)
+	(setq *the-eslotd-standard-class-slots* slotd))
+      slotd)))
+
+(defun bootstrap-built-in-classes ()
+  ;;
+  ;; First make sure that all the supers listed in *built-in-class-lattice*
+  ;; are themselves defined by *built-in-class-lattice*.  This is just to
+  ;; check for typos and other sorts of brainos.
+  ;; 
+  (dolist (e *built-in-classes*)
+    (dolist (super (cadr e))
+      (unless (or (eq super 't)
+		  (assq super *built-in-classes*))
+	(error "In *built-in-classes*: ~S has ~S as a super,~%~
+                but ~S is not itself a class in *built-in-classes*."
+	       (car e) super super))))
+
+  ;;
+  ;; In the first pass, we create a skeletal object to be bound to the
+  ;; class name.
+  ;;
+  (let* ((built-in-class (find-class 'built-in-class))
+	 (built-in-class-wrapper (class-wrapper built-in-class))
+	 (bin-class-size (length *bin-class-slots*)))
+    (dolist (e *built-in-classes*)
+      (let ((class (%allocate-instance--class bin-class-size)))
+	(setf (std-instance-wrapper class) built-in-class-wrapper)
+	(setf (find-class (car e)) class))))
+
+  ;;
+  ;; In the second pass, we initialize the class objects.
+  ;;
+  (dolist (e *built-in-classes*)
+    (destructuring-bind (name supers subs cpl) e
+      (let* ((class (find-class name))
+	     (wrapper (make-wrapper class)))
+	(set (get-built-in-class-symbol name) class)
+	(set (get-built-in-wrapper-symbol name) wrapper)
+
+	(setf (wrapper-instance-slots-layout wrapper) ()
+	      (wrapper-class-slots wrapper) ())
+
+	(bootstrap-initialize-bin-class class
+					name nil
+					supers subs
+					(cons name cpl) wrapper)
+	))))
+
+
+;;;
+;;;
+;;;
+
+(defun class-of (x) (wrapper-class (wrapper-of x)))
+
+(defun wrapper-of (x) 
+  (or (and (std-instance-p x)
+	   (std-instance-wrapper x))
+      (and (fsc-instance-p x)
+	   (fsc-instance-wrapper x))
+      (built-in-wrapper-of x)
+      (error "Can't determine wrapper of ~S" x)))
+
+
+(eval-when (compile eval)
+
+(defun make-built-in-class-subs ()
+  (mapcar #'(lambda (e)
+	      (let ((class (car e))
+		    (class-subs ()))
+		(dolist (s *built-in-classes*)
+		  (when (memq class (cadr s)) (pushnew (car s) class-subs)))
+		(cons class class-subs)))
+	  (cons '(t) *built-in-classes*)))
+
+(defun make-built-in-class-tree ()
+  (let ((subs (make-built-in-class-subs)))
+    (labels ((descend (class)
+	       (cons class (mapcar #'descend (cdr (assq class subs))))))
+      (descend 't))))
+
+(defun make-built-in-wrapper-of-body ()
+  (make-built-in-wrapper-of-body-1 (make-built-in-class-tree)
+				   'x
+				   #'get-built-in-wrapper-symbol))
+
+(defun make-built-in-wrapper-of-body-1 (tree var get-symbol)
+  (let ((*specials* ()))
+    (declare (special *specials*))
+    (let ((inner (make-built-in-wrapper-of-body-2 tree var get-symbol)))
+      `(locally (declare (special .,*specials*)) ,inner))))
+
+(defun make-built-in-wrapper-of-body-2 (tree var get-symbol)
+  (declare (special *specials*))
+  (let ((symbol (funcall get-symbol (car tree))))
+    (push symbol *specials*)
+    (let ((sub-tests
+	    (mapcar #'(lambda (x)
+			(make-built-in-wrapper-of-body-2 x var get-symbol))
+		    (cdr tree))))
+      `(and (typep ,var ',(car tree))
+	    ,(if sub-tests
+		 `(or ,.sub-tests ,symbol)
+		 symbol)))))
+)
+
+(defun built-in-wrapper-of (x)
+  #.(make-built-in-wrapper-of-body))
+
+
+
+
+(eval-when (load eval)
+  (clrhash *find-class*)
+  (bootstrap-meta-braid)
+  (bootstrap-built-in-classes)
+  (setq *boot-state* 'braid)
+  (setf (symbol-function 'load-defclass) #'real-load-defclass)
+  )
+
+
+;;;
+;;; All of these method definitions must appear here because the bootstrap
+;;; only allows one method per generic function until the braid is fully
+;;; built.
+;;;
+(defmethod print-object (instance stream)
+  (printing-random-thing (instance stream)
+    (let ((name (class-name (class-of instance))))
+      (if name
+	  (format stream "~S" name)
+	  (format stream "Instance")))))
+
+(defmethod print-object ((class class) stream)
+  (named-object-print-function class stream))
+
+(defmethod print-object ((slotd standard-slot-definition) stream)
+  (named-object-print-function slotd stream))
+
+(defun named-object-print-function (instance stream
+				    &optional (extra nil extra-p))
+  (printing-random-thing (instance stream)
+    (if extra-p					
+	(format stream "~A ~S ~:S"
+		(capitalize-words (class-name (class-of instance)))
+		(slot-value-or-default instance 'name)
+		extra)
+	(format stream "~A ~S"
+		(capitalize-words (class-name (class-of instance)))
+		(slot-value-or-default instance 'name)))))
+
+
+;;;
+;;;
+;;;
+;(defmethod shared-initialize :after ((class class) slot-names &key name)
+;  (declare (ignore slot-names))
+;  (setf (slot-value class 'name) name))
+;
+;
+;(defmethod shared-initialize :after ((class std-class)
+;				     slot-names
+;				     &key direct-superclasses
+;					  direct-slots)
+; (declare (ignore slot-names))
+; (setf (slot-value class 'direct-superclasses) direct-superclasses
+;	(slot-value class 'direct-slots) direct-slots))
+
+;;;
+;;;
+;;;
+(defmethod shared-initialize :after ((slotd standard-slot-definition)
+				     slot-names
+				     &key class
+					  name
+					  initform
+					  initfunction
+					  initargs 
+					  (allocation :instance)
+					  (type t)
+					  readers
+					  writers)
+  (declare (ignore slot-names))
+  (setf (slot-value slotd 'name) name
+	(slot-value slotd 'initform) initform
+	(slot-value slotd 'initfunction) initfunction
+	(slot-value slotd 'initargs) initargs 
+	(slot-value slotd 'allocation) (if (eq allocation :class) class allocation)
+	(slot-value slotd 'type) type
+	(slot-value slotd 'readers) readers
+	(slot-value slotd 'writers) writers))
+

clos/3.5/clos-env-internal.lisp

@@ -0,0 +1,260 @@
+(DEFINE-FILE-INFO PACKAGE "XCL" READTABLE "XCL")
+(il:filecreated "28-Aug-87 18:42:36" il:{phylum}<clos>clos-env-internal.\;1 8356   
+
+      il:|changes| il:|to:|  (il:vars il:clos-env-internalcoms)
+                             (il:props (il:clos-env-internal il:makefile-environment))
+                             (il:functions stack-eql stack-pointer-frame stack-frame-valid-p 
+                                    stack-frame-fn-header stack-frame-pc fnheader-debugging-info 
+                                    stack-frame-name compiled-closure-fnheader compiled-closure-env)
+)
+
+
+; Copyright (c) 1987 by Xerox Corporation.  All rights reserved.
+
+(il:prettycomprint il:clos-env-internalcoms)
+
+(il:rpaqq il:clos-env-internalcoms (
+
+(il:* il:|;;;| "***************************************")
+
+                                   
+
+(il:* il:|;;;| " Copyright (c) 1987 Xerox Corporation.  All rights reserved.")
+
+                                   
+
+(il:* il:|;;;| "")
+
+                                   
+
+(il:* il:|;;;| "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.")
+
+                                   
+
+(il:* il:|;;;| " ")
+
+                                   
+
+(il:* il:|;;;| "This software is made available AS IS, and Xerox Corporation makes no  warranty about the software, its performance or its conformity to any  specification.")
+
+                                   
+
+(il:* il:|;;;| " ")
+
+                                   
+
+(il:* il:|;;;| "Any person obtaining a copy of this software is requested to send their name and post office or electronic mail address to:")
+
+                                   
+
+(il:* il:|;;;| "   CommonLoops Coordinator")
+
+                                   
+
+(il:* il:|;;;| "   Xerox Artifical Intelligence Systems")
+
+                                   
+
+(il:* il:|;;;| "   2400 Hanover St.")
+
+                                   
+
+(il:* il:|;;;| "   Palo Alto, CA 94303")
+
+                                   
+
+(il:* il:|;;;| "(or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)")
+
+                                   
+
+(il:* il:|;;;| "")
+
+                                   
+
+(il:* il:|;;;| " Suggestions, comments and requests for improvements are also welcome.")
+
+                                   
+
+(il:* il:|;;;| " *************************************************************************")
+
+                                   
+
+(il:* il:|;;;| "")
+
+                                   (il:declare\: il:dontcopy (il:prop il:makefile-environment 
+                                                                    il:clos-env-internal))
+                                                             (il:* il:\; 
+                                                             "We're off to hack the system...")
+
+                                   (il:declare\: il:eval@compile il:dontcopy (il:files clos::abc)
+                                          
+          
+          (il:* il:|;;| "The Deltas and The East and The Freeze")
+)
+                                   (il:functions stack-eql stack-pointer-frame stack-frame-valid-p 
+                                          stack-frame-fn-header stack-frame-pc 
+                                          fnheader-debugging-info stack-frame-name 
+                                          compiled-closure-fnheader compiled-closure-env)))
+
+
+
+(il:* il:|;;;| "***************************************")
+
+
+
+
+(il:* il:|;;;| " Copyright (c) 1987 Xerox Corporation.  All rights reserved.")
+
+
+
+
+(il:* il:|;;;| "")
+
+
+
+
+(il:* il:|;;;| 
+"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."
+)
+
+
+
+
+(il:* il:|;;;| " ")
+
+
+
+
+(il:* il:|;;;| 
+"This software is made available AS IS, and Xerox Corporation makes no  warranty about the software, its performance or its conformity to any  specification."
+)
+
+
+
+
+(il:* il:|;;;| " ")
+
+
+
+
+(il:* il:|;;;| 
+"Any person obtaining a copy of this software is requested to send their name and post office or electronic mail address to:"
+)
+
+
+
+
+(il:* il:|;;;| "   CommonLoops Coordinator")
+
+
+
+
+(il:* il:|;;;| "   Xerox Artifical Intelligence Systems")
+
+
+
+
+(il:* il:|;;;| "   2400 Hanover St.")
+
+
+
+
+(il:* il:|;;;| "   Palo Alto, CA 94303")
+
+
+
+
+(il:* il:|;;;| "(or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)")
+
+
+
+
+(il:* il:|;;;| "")
+
+
+
+
+(il:* il:|;;;| " Suggestions, comments and requests for improvements are also welcome.")
+
+
+
+
+(il:* il:|;;;| " *************************************************************************")
+
+
+
+
+(il:* il:|;;;| "")
+
+(il:declare\: il:dontcopy 
+
+(il:putprops il:clos-env-internal il:makefile-environment (:package "XCL" :readtable "XCL"))
+)
+
+
+
+(il:* il:\; "We're off to hack the system...")
+
+(il:declare\: il:eval@compile il:dontcopy 
+(il:filesload clos::abc)
+)
+
+(defun stack-eql (x y) "Test two stack pointers for equality" (and (il:stackp x)
+                                                                   (il:stackp y)
+                                                                   (eql (il:fetch (il:stackp il:edfxp
+                                                                                         )
+                                                                           il:of x)
+                                                                        (il:fetch (il:stackp il:edfxp
+                                                                                         )
+                                                                           il:of y))))
+
+
+(defun stack-pointer-frame (stack-pointer) (il:|fetch| (il:stackp il:edfxp) il:|of| stack-pointer))
+
+
+(defun stack-frame-valid-p (frame) (not (il:|fetch| (il:fx il:invalidp) il:|of| frame)))
+
+
+(defun stack-frame-fn-header (frame) (il:|fetch| (il:fx il:fnheader) il:|of| frame))
+
+
+(defun stack-frame-pc (frame) (il:|fetch| (il:fx il:pc) il:|of| frame))
+
+
+(defun fnheader-debugging-info (fnheader) (let* ((start-pc (il:fetch (il:fnheader il:startpc)
+                                                              il:of fnheader))
+                                                 (name-table-words
+                                                  (let ((size (il:fetch (il:fnheader il:ntsize)
+                                                                 il:of fnheader)))
+                                                       (if (zerop size)
+                                                           il:wordsperquad
+                                                           (* size 2))))
+                                                 (past-name-table-in-words (+ (il:fetch (il:fnheader
+                                                                                         
+                                                                                     il:overheadwords
+                                                                                         )
+                                                                                 il:of fnheader)
+                                                                              name-table-words)))
+                                                (and (= (- start-pc (* il:bytesperword 
+                                                                       past-name-table-in-words))
+                                                        il:bytespercell)
+          
+          (il:* il:|;;| "It's got a debugging-info list.")
+
+                                                     (il:\\getbaseptr fnheader 
+                                                            past-name-table-in-words))))
+
+
+(defun stack-frame-name (frame) (il:|fetch| (il:fx il:framename) il:|of| frame))
+
+
+(defun compiled-closure-fnheader (closure) (il:|fetch| (il:compiled-closure il:fnheader) il:|of|
+                                                                                         closure))
+
+
+(defun compiled-closure-env (closure) (il:fetch (il:compiled-closure il:environment) il:of closure))
+
+(il:putprops il:clos-env-internal il:copyright ("Xerox Corporation" 1987))
+(il:declare\: il:dontcopy
+  (il:filemap (nil)))
+il:stop

clos/3.5/combin.lisp

@@ -0,0 +1,254 @@
+;;;-*-Mode:LISP; Package: CLOS; Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1991 Venue
+;;; All rights reserved.
+;;; *************************************************************************
+;;;
+
+(in-package 'clos)
+
+(defun make-effective-method-function (generic-function form)
+  (flet ((name-function (fn) (set-function-name fn 'a-combined-method) fn))
+    (if (and (listp form)
+	     (eq (car form) 'call-method)
+	     (method-p (cadr form))
+	     (every #'method-p (caddr form)))
+	;;
+	;; The effective method is just a call to call-method.  This opens up
+	;; the possibility of just using the method function of the method as
+	;; as the effective method function.
+	;;
+	;; But we have to be careful.  If that method function will ask for
+	;; the next methods we have to provide them.  We do not look to see
+	;; if there are next methods, we look at whether the method function
+	;; asks about them.  If it does, we must tell it whether there are
+	;; or aren't to prevent the leaky next methods bug.
+	;; 
+	(let* ((method-function (method-function (cadr form)))
+	       (arg-info (gf-arg-info generic-function))
+	       (metatypes (arg-info-metatypes arg-info))
+	       (applyp (arg-info-applyp arg-info)))
+	  (if (not (method-function-needs-next-methods-p method-function))
+	      method-function
+	      (let ((next-method-functions (mapcar #'method-function (caddr form))))
+		(name-function
+		  (get-function `(lambda ,(make-dfun-lambda-list metatypes applyp)
+				   (let ((*next-methods* .next-method-functions.))
+				     ,(make-dfun-call metatypes applyp '.method-function.)))
+		    #'default-test-converter	;This could be optimized by making
+						;the interface from here to the
+						;walker more clear so that the
+						;form wouldn't get walked at all.
+		    #'(lambda (form)
+			(if (memq form '(.next-method-functions. .method-function.))
+			    (values form (list form))
+			    form))
+		    #'(lambda (form)
+			(cond ((eq form '.next-method-functions.)
+			       (list next-method-functions))
+			      ((eq form '.method-function.)
+			       (list method-function)))))))))
+	;;
+	;; We have some sort of `real' effective method.  Go off and get a
+	;; compiled function for it.  Most of the real hair here is done by
+	;; the GET-FUNCTION mechanism.
+	;; 
+	(name-function (make-effective-method-function-internal generic-function form)))))
+
+(defvar *global-effective-method-gensyms* ())
+(defvar *rebound-effective-method-gensyms*)
+
+(defun get-effective-method-gensym ()
+  (or (pop *rebound-effective-method-gensyms*)
+      (let ((new (make-symbol "EFFECTIVE-METHOD-GENSYM-")))
+	(push new *global-effective-method-gensyms*)
+	new)))
+
+(eval-when (load)
+  (let ((*rebound-effective-method-gensyms* ()))
+    (dotimes (i 10) (get-effective-method-gensym))))
+
+(defun make-effective-method-function-internal (generic-function effective-method)
+  (let* ((*rebound-effective-method-gensyms* *global-effective-method-gensyms*)
+	 (arg-info (gf-arg-info generic-function))
+	 (metatypes (arg-info-metatypes arg-info))
+	 (applyp (arg-info-applyp arg-info)))
+    (labels ((test-converter (form)
+	       (if (and (consp form) (eq (car form) 'call-method))
+		   '.call-method.
+		   (default-test-converter form)))
+	     (code-converter (form)
+	       (if (and (consp form) (eq (car form) 'call-method))
+		   ;;
+		   ;; We have a `call' to CALL-METHOD.  There may or may not be next methods
+		   ;; and the two cases are a little different.  It controls how many gensyms
+		   ;; we will generate.
+		   ;;
+		   (let ((gensyms
+			   (if (cddr form)
+			       (list (get-effective-method-gensym)
+				     (get-effective-method-gensym))
+			       (list (get-effective-method-gensym)
+				     ()))))
+		     (values `(let ((*next-methods* ,(cadr gensyms)))
+				,(make-dfun-call metatypes applyp (car gensyms)))
+			     gensyms))
+		   (default-code-converter form)))
+	     (constant-converter (form)
+	       (if (and (consp form) (eq (car form) 'call-method))
+		   (if (cddr form)
+		       (list (check-for-make-method (cadr form))
+			     (mapcar #'check-for-make-method (caddr form)))
+		       (list (check-for-make-method (cadr form))
+			     ()))
+		   (default-constant-converter form)))
+	     (check-for-make-method (effective-method)
+	       (cond ((method-p effective-method)
+		      (method-function effective-method))
+		     ((and (listp effective-method)
+			   (eq (car effective-method) 'make-method))
+		      (make-effective-method-function generic-function
+						      (make-progn (cadr effective-method))))
+		     (t
+		      (error "Effective-method form is malformed.")))))
+      (get-function `(lambda ,(make-dfun-lambda-list metatypes applyp) ,effective-method)
+		  #'test-converter
+		  #'code-converter
+		  #'constant-converter))))
+
+
+
+(defvar *invalid-method-error*
+	#'(lambda (&rest args)
+	    (declare (ignore args))
+	    (error
+	      "INVALID-METHOD-ERROR was called outside the dynamic scope~%~
+               of a method combination function (inside the body of~%~
+               DEFINE-METHOD-COMBINATION or a method on the generic~%~
+               function COMPUTE-EFFECTIVE-METHOD).")))
+
+(defvar *method-combination-error*
+	#'(lambda (&rest args)
+	    (declare (ignore args))
+	    (error
+	      "METHOD-COMBINATION-ERROR was called outside the dynamic scope~%~
+               of a method combination function (inside the body of~%~
+               DEFINE-METHOD-COMBINATION or a method on the generic~%~
+               function COMPUTE-EFFECTIVE-METHOD).")))
+
+;(defmethod compute-effective-method :around        ;issue with magic
+;	   ((generic-function generic-function)     ;generic functions
+;	    (method-combination method-combination)
+;	    applicable-methods)
+;  (declare (ignore applicable-methods))
+;  (flet ((real-invalid-method-error (method format-string &rest args)
+;	   (declare (ignore method))
+;	   (apply #'error format-string args))
+;	 (real-method-combination-error (format-string &rest args)
+;	   (apply #'error format-string args)))
+;    (let ((*invalid-method-error* #'real-invalid-method-error)
+;	  (*method-combination-error* #'real-method-combination-error))
+;      (call-next-method))))
+
+(defun invalid-method-error (&rest args)
+  (declare (arglist method format-string &rest format-arguments))
+  (apply *invalid-method-error* args))
+
+(defun method-combination-error (&rest args)
+  (declare (arglist format-string &rest format-arguments))
+  (apply *method-combination-error* args))
+
+
+
+;;;
+;;; The STANDARD method combination type.  This is coded by hand (rather than
+;;; with define-method-combination) for bootstrapping and efficiency reasons.
+;;; Note that the definition of the find-method-combination-method appears in
+;;; the file defcombin.lisp, this is because EQL methods can't appear in the
+;;; bootstrap.
+;;;
+;;; The defclass for the METHOD-COMBINATION and STANDARD-METHOD-COMBINATION
+;;; classes has to appear here for this reason.  This code must conform to
+;;; the code in the file defcombin, look there for more details.
+;;;
+
+(defclass method-combination () ())
+
+(define-gf-predicate method-combination-p method-combination)
+
+(defclass standard-method-combination
+	  (definition-source-mixin method-combination)
+     ((type          :reader method-combination-type
+	             :initarg :type)
+      (documentation :reader method-combination-documentation
+		     :initarg :documentation)
+      (options       :reader method-combination-options
+	             :initarg :options)))
+
+(defmethod print-object ((mc method-combination) stream)
+  (printing-random-thing (mc stream)
+    (format stream
+	    "Method-Combination ~S ~S"
+	    (method-combination-type mc)
+	    (method-combination-options mc))))
+
+(eval-when (load eval)
+  (setq *standard-method-combination*
+	(make-instance 'standard-method-combination
+		       :type 'standard
+		       :documentation "The standard method combination."
+		       :options ())))
+
+;This definition appears in defcombin.lisp.
+;
+;(defmethod find-method-combination ((generic-function generic-function)
+;				     (type (eql 'standard))
+;				     options)
+;  (when options
+;    (method-combination-error
+;      "The method combination type STANDARD accepts no options."))
+;  *standard-method-combination*)
+
+(defun make-call-methods (methods)
+  (mapcar #'(lambda (method) `(call-method ,method ())) methods))
+
+(defmethod compute-effective-method ((generic-function generic-function)
+				     (combin standard-method-combination)
+				     applicable-methods)
+  (let ((before ())
+	(primary ())
+	(after ())
+	(around ()))
+    (dolist (m applicable-methods)
+      (let ((qualifiers (method-qualifiers m)))
+	(cond ((member ':before qualifiers)  (push m before))
+	      ((member ':after  qualifiers)  (push m after))
+	      ((member ':around  qualifiers) (push m around))
+	      (t
+	       (push m primary)))))
+    (setq before  (reverse before)
+	  after   (reverse after)
+	  primary (reverse primary)
+	  around  (reverse around))
+    (cond ((null primary)
+	   `(error "No primary method for the generic function ~S." ',generic-function))
+	  ((and (null before) (null after) (null around))
+	   ;;
+	   ;; By returning a single call-method `form' here we enable an important
+	   ;; implementation-specific optimization.
+	   ;; 
+	   `(call-method ,(first primary) ,(rest primary)))
+	  (t
+	   (let ((main-effective-method
+		   (if (or before after (rest primary))
+		       `(multiple-value-prog1
+			  (progn ,@(make-call-methods before)
+				 (call-method ,(first primary) ,(rest primary)))
+			  ,@(make-call-methods (reverse after)))
+		       `(call-method ,(first primary) ()))))
+	     (if around
+		 `(call-method ,(first around)
+			       (,@(rest around) (make-method ,main-effective-method)))
+		 main-effective-method))))))
+

clos/3.5/compat.lisp

@@ -0,0 +1,11 @@
+;;;-*-Mode:LISP; Package: CLOS; Base:10; Syntax:Common-lisp; -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1991 Venue
+;;; All rights reserved.
+;;; *************************************************************************
+;;;
+
+(in-package 'clos)
+
+()

clos/3.5/cpl.lisp

@@ -0,0 +1,271 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+;;;. Copyright (c) 1991 by Venue
+
+
+(in-package "CLOS")
+
+
+;;; compute-class-precedence-list Knuth section 2.2.3 has some interesting notes on this. What
+;;; appears here is basically the algorithm presented there. The key idea is that we use
+;;; class-precedence-description (CPD) structures to store the precedence information as we proceed.
+;;; The CPD structure for a class stores two critical pieces of information: - a count of the number
+;;; of "reasons" why the class can't go into the class precedence list yet. - a list of the
+;;; "reasons" this class prevents others from going in until after it 
+
+
+
+;; 
+
+
+
+;;; A "reason" is essentially a single local precedence constraint.  If a constraint between two
+;;; classes arises more than once it generates more than one reason.  This makes things simpler,
+;;; linear, and isn't a problem as long as we make sure to keep track of each instance of a
+;;; "reason". This code is divided into three phases. - the first phase simply generates the CPD's
+;;; for each of the class and its superclasses.  The remainder of the code will manipulate these
+;;; CPDs rather than the class objects themselves.  At the end of this pass, the CPD-SUPERS field of
+;;; a CPD is a list of the CPDs of the direct superclasses of the class. - the second phase folds
+;;; all the local constraints into the CPD structure.  The CPD-COUNT of each CPD is built up, and
+;;; the CPD-AFTER fields are augmented to include precedence constraints from the CPD-SUPERS field
+;;; and from the order of classes in other CPD-SUPERS fields. After this phase, the CPD-AFTER field
+;;; of a class includes all the direct superclasses of the class plus any class that immediately
+;;; follows the class in the direct superclasses of another.  There can be duplicates in this list. 
+;;; The CPD-COUNT field is equal to the number of times this class appears in the CPD-AFTER field of
+;;; all the other CPDs. - In the third phase, classes are put into the precedence list one at a
+;;; time, with only those classes with a CPD-COUNT of 0 being candidates for insertion.  When a
+;;; class is inserted , every CPD in its CPD-AFTER field has its count decremented. In the usual
+;;; case, there is only one candidate for insertion at any point.  If there is more than one, the
+;;; specified tiebreaker rule is used to choose among them. 
+
+
+(defmethod compute-class-precedence-list ((root std-class)
+                                          direct-superclasses)
+       (compute-std-cpl root direct-superclasses))
+
+(defstruct (class-precedence-description (:conc-name nil)
+                  (:print-function (lambda (obj str depth)
+                                          (declare (ignore depth))
+                                          (format str "#<CPD ~S ~D>" (class-name (cpd-class obj))
+                                                 (cpd-count obj))))
+                  (:constructor make-cpd nil))
+       (cpd-class nil)
+       (cpd-supers nil)
+       (cpd-after nil)
+       (cpd-count 0))
+
+(defun compute-std-cpl (class supers)
+       (cond ((null supers)
+                                                             ; First two branches of COND
+              (list class))
+                                                             ; are implementing the single
+             ((null (cdr supers))
+                                                             ; inheritance optimization.
+              (cons class (compute-std-cpl (car supers)
+                                 (class-direct-superclasses (car supers)))))
+             (t (multiple-value-bind (all-cpds nclasses)
+                    (compute-std-cpl-phase-1 class supers)
+                  (compute-std-cpl-phase-2 all-cpds)
+                  (compute-std-cpl-phase-3 class all-cpds nclasses)))))
+
+(defvar *compute-std-cpl-class->entry-table-size* 60)
+
+(defun compute-std-cpl-phase-1 (class supers)
+       (let ((nclasses 0)
+             (all-cpds nil)
+             (table (make-hash-table :size *compute-std-cpl-class->entry-table-size* :test
+                           #'eq)))
+            (labels ((get-cpd (c)
+                            (or (gethash c table)
+                                (setf (gethash c table)
+                                      (make-cpd))))
+                     (walk (c supers)
+                           (if (forward-referenced-class-p c)
+                               (cpl-forward-referenced-class-error class c)
+                               (let ((cpd (get-cpd c)))
+                                    (unless (cpd-class cpd)
+                                                             ; If we have already done this class
+                                                             ; before, we can quit. 
+                                        (setf (cpd-class cpd)
+                                              c)
+                                        (incf nclasses)
+                                        (push cpd all-cpds)
+                                        (setf (cpd-supers cpd)
+                                              (mapcar #'get-cpd supers))
+                                        (dolist (super supers)
+                                            (walk super (class-direct-superclasses super))))))))
+                   (walk class supers)
+                   (values all-cpds nclasses))))
+
+(defun compute-std-cpl-phase-2 (all-cpds)
+       (dolist (cpd all-cpds)
+           (let ((supers (cpd-supers cpd)))
+                (when supers
+                    (setf (cpd-after cpd)
+                          (nconc (cpd-after cpd)
+                                 supers))
+                    (incf (cpd-count (car supers))
+                          1)
+                    (do* ((t1 supers t2)
+                          (t2 (cdr t1)
+                              (cdr t1)))
+                         ((null t2))
+                       (incf (cpd-count (car t2))
+                             2)
+                       (push (car t2)
+                             (cpd-after (car t1))))))))
+
+(defun
+ compute-std-cpl-phase-3
+ (class all-cpds nclasses)
+ (let ((candidates nil)
+       (next-cpd nil)
+       (rcpl nil))
+      
+      ;; We have to bootstrap the collection of those CPD's that have a zero count.  Once we get
+      ;; going, we will maintain this list incrementally. 
+      (dolist (cpd all-cpds)
+          (when (zerop (cpd-count cpd))
+                (push cpd candidates)))
+      (loop (when (null candidates)
+                
+                ;; If there are no candidates, and enough classes have been put into the precedence
+                ;; list, then we are all done.  Otherwise it means there is a consistency problem. 
+                (if (zerop nclasses)
+                    (return (reverse rcpl))
+                    (cpl-inconsistent-error class all-cpds)))
+            
+            ;; Try to find the next class to put in from among the candidates. If there is only one,
+            ;; its easy, otherwise we have to use the famous RPG tiebreaker rule.  There is some
+            ;; hair here to avoid having to call DELETE on the list of candidates.  I dunno if its
+            ;; worth it but what the hell. 
+            (setq next-cpd
+                  (if (null (cdr candidates))
+                      (prog1 (car candidates)
+                             (setq candidates nil))
+                      (block tie-breaker
+                          (dolist (c rcpl)
+                              (let ((supers (class-direct-superclasses c)))
+                                   (if (memq (cpd-class (car candidates))
+                                             supers)
+                                       (return-from tie-breaker (pop candidates))
+                                       (do ((loc candidates (cdr loc)))
+                                           ((null (cdr loc)))
+                                         (let ((cpd (cadr loc)))
+                                              (when (memq (cpd-class cpd)
+                                                          supers)
+                                                  (setf (cdr loc)
+                                                        (cddr loc))
+                                                  (return-from tie-breaker cpd))))))))))
+            (decf nclasses)
+            (push (cpd-class next-cpd)
+                  rcpl)
+            (dolist (after (cpd-after next-cpd))
+                (when (zerop (decf (cpd-count after)))
+                      (push after candidates))))))
+
+
+;;; Support code for signalling nice error messages. 
+
+
+(defun cpl-error (class format-string &rest format-args)
+       (error "While computing the class precedence list of the class ~A.~%~A"
+              (if (class-name class)
+                  (format nil "named ~S" (class-name class))
+                  class)
+              (apply #'format nil format-string format-args)))
+
+(defun cpl-forward-referenced-class-error (class forward-class)
+       (flet ((class-or-name (class)
+                     (if (class-name class)
+                         (format nil "named ~S" (class-name class))
+                         class)))
+             (let ((names (mapcar #'class-or-name (cdr (find-superclass-chain class forward-class))))
+                   )
+                  (cpl-error class 
+                "The class ~A is a forward referenced class.~@
+                  The class ~A is ~A." (class-or-name forward-class)
+                         (class-or-name forward-class)
+                         (if (null (cdr names))
+                             (format nil "a direct superclass of the class ~A" (class-or-name class))
+                             (format nil "reached from the class ~A by following~@
+                              the direct superclass chain through: ~A~
+                              ~%  ending at the class ~A" (class-or-name class)
+                                    (format nil "~{~%  the class ~A,~}" (butlast names))
+                                    (car (last names))))))))
+
+(defun find-superclass-chain (bottom top)
+       (labels ((walk (c chain)
+                      (if (eq c top)
+                          (return-from find-superclass-chain (nreverse chain))
+                          (dolist (super (class-direct-superclasses c))
+                              (walk super (cons super chain))))))
+              (walk bottom (list bottom))))
+
+(defun cpl-inconsistent-error (class all-cpds)
+       (let ((reasons (find-cycle-reasons all-cpds)))
+            (cpl-error class "It is not possible to compute the class precedence list because~@
+       there ~A in the local precedence relations.~@
+       ~A because:~{~%  ~A~}." (if (cdr reasons)
+                                   "are circularities"
+                                   "is a circularity")
+                   (if (cdr reasons)
+                       "These arise"
+                       "This arises")
+                   (format-cycle-reasons (apply #'append reasons)))))
+
+(defun format-cycle-reasons (reasons)
+       (flet ((class-or-name (cpd)
+                     (let ((class (cpd-class cpd)))
+                          (if (class-name class)
+                              (format nil "named ~S" (class-name class))
+                              class))))
+             (mapcar #'(lambda (reason)
+                              (ecase (caddr reason)
+                                  (:super (format nil 
+                                                 "the class ~A appears in the supers of the class ~A"
+                                                 (class-or-name (cadr reason))
+                                                 (class-or-name (car reason))))
+                                  (:in-supers (format nil 
+                                    "the class ~A follows the class ~A in the supers of the class ~A"
+                                                     (class-or-name (cadr reason))
+                                                     (class-or-name (car reason))
+                                                     (class-or-name (cadddr reason))))))
+                    reasons)))
+
+(defun find-cycle-reasons (all-cpds)
+       (let ((been-here nil)
+                                                             ; List of classes we have visited.
+             (cycle-reasons nil))
+            (labels ((chase (path)
+                            (if (memq (car path)
+                                      (cdr path))
+                                (record-cycle (memq (car path)
+                                                    (nreverse path)))
+                                (unless (memq (car path)
+                                              been-here)
+                                    (push (car path)
+                                          been-here)
+                                    (dolist (after (cpd-after (car path)))
+                                        (chase (cons after path))))))
+                     (record-cycle
+                      (cycle)
+                      (let ((reasons nil))
+                           (do* ((t1 cycle t2)
+                                 (t2 (cdr t1)
+                                     (cdr t1)))
+                                ((null t2))
+                              (let ((c1 (car t1))
+                                    (c2 (car t2)))
+                                   (if (memq c2 (cpd-supers c1))
+                                       (push (list c1 c2 :super)
+                                             reasons)
+                                       (dolist (cpd all-cpds)
+                                           (when (memq c2 (memq c1 (cpd-supers cpd)))
+                                               (return (push (list c1 c2 :in-supers cpd)
+                                                             reasons)))))))
+                           (push (nreverse reasons)
+                                 cycle-reasons))))
+                   (dolist (cpd all-cpds)
+                       (unless (zerop (cpd-count cpd))
+                           (chase (list cpd))))
+                   cycle-reasons)))

clos/3.5/ctypes.lisp

@@ -0,0 +1,25 @@
+;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1991 Venue
+;;; All rights reserved.
+;;; *************************************************************************
+;;;
+
+(in-package 'clos)
+
+;;;
+;;; The built-in method combination types as taken from page 1-31 of 88-002R.
+;;; Note that the STANDARD method combination type is defined by hand in the
+;;; file combin.lisp.
+;;;
+
+(define-method-combination +      :identity-with-one-argument t)
+(define-method-combination and    :identity-with-one-argument t)
+(define-method-combination append :identity-with-one-argument nil)
+(define-method-combination list   :identity-with-one-argument nil)
+(define-method-combination max    :identity-with-one-argument t)
+(define-method-combination min    :identity-with-one-argument t)
+(define-method-combination nconc  :identity-with-one-argument t)
+(define-method-combination or     :identity-with-one-argument t)
+(define-method-combination progn  :identity-with-one-argument t)

clos/3.5/defclass.lisp

@@ -0,0 +1,230 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+;;;. Copyright (c) 1991 by Venue
+(in-package "CLOS")
+
+;;; ************************************************************************* 
+
+
+
+;;; MAKE-TOP-LEVEL-FORM is used by all PCL macros that appear `at top-level'. The original
+;;; motiviation for this function was to deal with the bug in the Genera compiler that prevents
+;;; lambda expressions in top-level forms other than DEFUN from being compiled. Now this function is
+;;; used to grab other functionality as well.  This includes: - Preventing the grouping of top-level
+;;; forms.  For example, a DEFCLASS followed by a DEFMETHOD may not want to be grouped into the same
+;;; top-level form. - Telling the programming environment what the pretty version of the name of
+;;; this form is.  This is used by WARN. 
+
+
+(defun make-top-level-form (name times form)
+       (flet ((definition-name nil (if (and (listp name)
+                                            (memq (car name)
+                                                  '(defmethod defclass class method 
+                                                          method-combination)))
+                                       (format nil "~A~{ ~S~}" (capitalize-words (car name)
+                                                                      nil)
+                                              (cdr name))
+                                       (format nil "~S" name))))
+             (definition-name)
+             (make-progn `',name `(eval-when ,times ,form))))
+
+(defun make-progn (&rest forms)
+       (let ((progn-form nil))
+            (labels ((collect-forms (forms)
+                            (unless (null forms)
+                                (collect-forms (cdr forms))
+                                (if (and (listp (car forms))
+                                         (eq (caar forms)
+                                             'progn))
+                                    (collect-forms (cdar forms))
+                                    (push (car forms)
+                                          progn-form)))))
+                   (collect-forms forms)
+                   (cons 'progn progn-form))))
+
+
+;;; Like the DEFMETHOD macro, the expansion of the DEFCLASS macro is fixed. DEFCLASS always expands
+;;; into a call to LOAD-DEFCLASS.  Until the meta- braid is set up, LOAD-DEFCLASS has a special
+;;; definition which simply collects all class definitions up, when the metabraid is initialized it
+;;; is done from those class definitions. After the metabraid has been setup, and the protocol for
+;;; defining classes has been defined, the real definition of LOAD-DEFCLASS is installed by the file
+;;; defclass.lisp 
+
+
+(defmacro defclass (name direct-superclasses direct-slots &rest options)
+       (declare (indentation 2 4 3 1))
+       (expand-defclass name direct-superclasses direct-slots options))
+
+(defun expand-defclass (name supers slots options)
+       (setq supers (copy-tree supers)
+             slots
+             (copy-tree slots)
+             options
+             (copy-tree options))
+       (let ((metaclass 'standard-class))
+            (dolist (option options)
+                (if (not (listp option))
+                    (error "~S is not a legal defclass option." option)
+                    (when (eq (car option)
+                              ':metaclass)
+                        (unless (legal-class-name-p (cadr option))
+                            (error 
+        "The value of the :metaclass option (~S) is not a~%~
+                      legal class name." (cadr option)))
+                        (setq metaclass (cadr option))
+                        (setf options (remove option options))
+                        (return t))))
+            (let ((*initfunctions* nil)
+                  (*accessors* nil))
+                                                             ; Truly a crock, but we got to have it
+                                                             ; to live nicely. 
+                 (declare (special *initfunctions* *accessors*))
+                 (let ((canonical-slots (mapcar #'(lambda (spec)
+                                                         (canonicalize-slot-specification name spec))
+                                               slots))
+                       (other-initargs (mapcar #'(lambda (option)
+                                                        (canonicalize-defclass-option name option))
+                                              options)))
+                      (do-standard-defsetfs-for-defclass *accessors*)
+;		      (load-defclass name metaclass supers
+;				     canonical-slots (apply #'append
+;							    other-initargs) *accessors*)))))
+                      (make-top-level-form `(defclass ,name nil nil)
+                             *defclass-times*
+                             `(let ,(mapcar #'cdr *initfunctions*)
+                                   (load-defclass ',name ',metaclass ',supers (list 
+                                                                                    ,@canonical-slots
+                                                                                    )
+                                          (list ,@(apply #'append other-initargs))
+                                          ',*accessors*)))))))
+
+(defun make-initfunction (initform)
+       (declare (special *initfunctions*))
+       (cond ((or (eq initform 't)
+                  (equal initform ''t))
+              '#'true)
+             ((or (eq initform 'nil)
+                  (equal initform ''nil))
+              '#'false)
+             ((or (eql initform '0)
+                  (equal initform ''0))
+              '#'zero)
+             (t (let ((entry (assoc initform *initfunctions* :test #'equal)))
+                     (unless entry
+                         (setq entry (list initform (gensym)
+                                           `#'(lambda nil ,initform)))
+                         (push entry *initfunctions*))
+                     (cadr entry)))))
+
+(defun canonicalize-slot-specification (class-name spec)
+       (declare (special *accessors*))
+       (cond ((and (symbolp spec)
+                   (not (keywordp spec))
+                   (not (memq spec '(t nil))))
+              `'(:name ,spec))
+             ((not (consp spec))
+              (error "~S is not a legal slot specification." spec))
+             ((null (cdr spec))
+              `'(:name ,(car spec)))
+             ((null (cddr spec))
+              (error 
+        "In DEFCLASS ~S, the slot specification ~S is obsolete.~%~
+                 Convert it to ~S" class-name spec (list (car spec)
+                                                         :initform
+                                                         (cadr spec))))
+             (t (let* ((name (pop spec))
+                       (readers nil)
+                       (writers nil)
+                       (initargs nil)
+                       (unsupplied (list nil))
+                       (initform (getf spec :initform unsupplied)))
+                      (doplist (key val)
+                             spec
+                             (case key
+                                 (:accessor 
+                                    (push val *accessors*)
+                                    (push val readers)
+                                    (push `(setf ,val)
+                                          writers))
+                                 (:reader (push val readers))
+                                 (:writer (push val writers))
+                                 (:initarg (push val initargs))))
+                      (loop (unless (remf spec :accessor)
+                                   (return)))
+                      (loop (unless (remf spec :reader)
+                                   (return)))
+                      (loop (unless (remf spec :writer)
+                                   (return)))
+                      (loop (unless (remf spec :initarg)
+                                   (return)))
+                      (setq spec `(:name ',name :readers ',readers
+				   :writers ',writers :initargs
+                                         ',initargs
+                                         ',spec))
+                      (if (eq initform unsupplied)
+                          `(list* ,@spec)
+                          `(list* :initfunction ,(make-initfunction initform)
+                                  ,@spec))))))
+
+(defun canonicalize-defclass-option (class-name option)
+       (declare (ignore class-name))
+       (case (car option)
+           (:default-initargs (let ((canonical nil))
+                                   (let (key val (tail (cdr option)))
+                                        (loop (when (null tail)
+                                                    (return nil))
+                                              (setq key (pop tail)
+                                                    val
+                                                    (pop tail))
+                                              (push ``(,',key ,,(make-initfunction val)
+                                                             ,',val)
+                                                    canonical))
+                                        `(':direct-default-initargs (list ,@(nreverse canonical))))))
+           (otherwise `(',(car option)
+                        ',(cdr option)))))
+
+
+;;; This is the early definition of load-defclass.  It just collects up all the class definitions in
+;;; a list.  Later, in the file braid1.lisp, these are actually defined. Each entry in
+;;; *early-class-definitions* is an early-class-definition. 
+
+
+(defparameter *early-class-definitions* nil)
+
+(defun make-early-class-definition (name source metaclass superclass-names canonical-slots 
+                                         other-initargs)
+       (list 'early-class-definition name source metaclass superclass-names canonical-slots 
+             other-initargs))
+
+(defun ecd-class-name (ecd)
+       (nth 1 ecd))
+
+(defun ecd-source (ecd)
+       (nth 2 ecd))
+
+(defun ecd-metaclass (ecd)
+       (nth 3 ecd))
+
+(defun ecd-superclass-names (ecd)
+       (nth 4 ecd))
+
+(defun ecd-canonical-slots (ecd)
+       (nth 5 ecd))
+
+(defun ecd-other-initargs (ecd)
+       (nth 6 ecd))
+
+(proclaim '(notinline load-defclass))
+
+(defun load-defclass (name metaclass supers canonical-slots canonical-options accessor-names)
+       (setq supers (copy-tree supers)
+             canonical-slots
+             (copy-tree canonical-slots)
+             canonical-options
+             (copy-tree canonical-options))
+       (do-standard-defsetfs-for-defclass accessor-names)
+       (let ((ecd (make-early-class-definition name (load-truename)
+                         metaclass supers canonical-slots (apply #'append canonical-options)))
+             (existing (find name *early-class-definitions* :key #'ecd-class-name)))
+            (setq *early-class-definitions* (cons ecd (remove existing *early-class-definitions*)))
+            ecd))

clos/3.5/defcombin.lisp

@@ -0,0 +1,410 @@
+;;;-*-Mode:LISP; Package: CLOS; Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1991 Venue
+;;; All rights reserved.
+;;; *************************************************************************
+;;;
+
+(in-package 'clos)
+
+;;;
+;;; DEFINE-METHOD-COMBINATION
+;;;
+
+(defmacro define-method-combination (&whole form &rest args)
+  (declare (ignore args))
+  (if (and (cddr form)
+	   (listp (caddr form)))
+      (expand-long-defcombin form)
+      (expand-short-defcombin form)))
+
+
+;;;
+;;; STANDARD method combination
+;;;
+;;; The STANDARD method combination type is implemented directly by the class
+;;; STANDARD-METHOD-COMBINATION.  The method on COMPUTE-EFFECTIVE-METHOD does
+;;; standard method combination directly and is defined by hand in the file
+;;; combin.lisp.  The method for FIND-METHOD-COMBINATION must appear in this
+;;; file for bootstrapping reasons.
+;;;
+;;; A commented out copy of this definition appears in combin.lisp.
+;;; If you change this definition here, be sure to change it there
+;;; also.
+;;;
+(defmethod find-method-combination ((generic-function generic-function)
+				    (type (eql 'standard))
+				    options)
+  (when options
+    (method-combination-error
+      "The method combination type STANDARD accepts no options."))
+  *standard-method-combination*)
+
+
+
+;;;
+;;; short method combinations
+;;;
+;;; Short method combinations all follow the same rule for computing the
+;;; effective method.  So, we just implement that rule once.  Each short
+;;; method combination object just reads the parameters out of the object
+;;; and runs the same rule.
+;;;
+;;;
+(defclass short-method-combination (standard-method-combination)
+     ((operator
+	:reader short-combination-operator
+	:initarg :operator)
+      (identity-with-one-argument
+	:reader short-combination-identity-with-one-argument
+	:initarg :identity-with-one-argument)))
+
+(define-gf-predicate short-method-combination-p short-method-combination)
+
+(defun expand-short-defcombin (whole)
+  (let* ((type (cadr whole))
+	 (documentation
+	   (getf (cddr whole) :documentation ""))
+	 (identity-with-one-arg
+	   (getf (cddr whole) :identity-with-one-argument nil))
+	 (operator 
+	   (getf (cddr whole) :operator type)))
+    (make-top-level-form `(define-method-combination ,type)
+			 '(load eval)
+      `(load-short-defcombin
+	 ',type ',operator ',identity-with-one-arg ',documentation))))
+
+(defun load-short-defcombin (type operator ioa doc)
+  (let* ((truename (load-truename))
+	 (specializers
+	   (list (find-class 'generic-function)
+		 (make-instance 'eql-specializer :object type)
+		 *the-class-t*))
+	 (old-method
+	   (get-method #'find-method-combination () specializers nil))
+	 (new-method nil))
+    (setq new-method
+	  (make-instance 'standard-method
+	    :qualifiers ()
+	    :specializers specializers
+	    :lambda-list '(generic-function type options)
+	    :function #'(lambda (gf type options)
+			  (declare (ignore gf))
+			  (do-short-method-combination
+			    type options operator ioa new-method doc))
+	    :definition-source `((define-method-combination ,type) ,truename)))
+    (when old-method
+      (remove-method #'find-method-combination old-method))
+    (add-method #'find-method-combination new-method)))
+
+(defun do-short-method-combination (type options operator ioa method doc)
+  (cond ((null options) (setq options '(:most-specific-first)))
+	((equal options '(:most-specific-first)))
+	((equal options '(:most-specific-last)))
+	(t
+	 (method-combination-error
+	   "Illegal options to a short method combination type.~%~
+            The method combination type ~S accepts one option which~%~
+            must be either :MOST-SPECIFIC-FIRST or :MOST-SPECIFIC-LAST."
+	   type)))
+  (make-instance 'short-method-combination
+		 :type type
+		 :options options
+		 :operator operator
+		 :identity-with-one-argument ioa
+		 :definition-source method
+		 :documentation doc))
+
+(defmethod compute-effective-method ((generic-function generic-function)
+				     (combin short-method-combination)
+				     applicable-methods)
+  (let ((type (method-combination-type combin))
+	(operator (short-combination-operator combin))
+	(ioa (short-combination-identity-with-one-argument combin))
+	(around ())
+	(primary ()))
+    (dolist (m applicable-methods)
+      (let ((qualifiers (method-qualifiers m)))
+	(flet ((lose (method why)
+		 (invalid-method-error
+		   method
+		   "The method ~S ~A.~%~
+                    The method combination type ~S was defined with the~%~
+                    short form of DEFINE-METHOD-COMBINATION and so requires~%~
+                    all methods have either the single qualifier ~S or the~%~
+                    single qualifier :AROUND."
+		   method why type type)))
+	  (cond ((null qualifiers)
+		 (lose m "has no qualifiers"))
+		((cdr qualifiers)
+		 (lose m "has more than one qualifier"))
+		((eq (car qualifiers) :around)
+		 (push m around))
+		((eq (car qualifiers) type)
+		 (push m primary))
+		(t
+		 (lose m "has an illegal qualifier"))))))
+    (setq around (nreverse around)
+	  primary (nreverse primary))
+    (let ((main-method
+	    (if (and (null (cdr primary))
+		     (not (null ioa)))
+		`(call-method ,(car primary) ())
+		`(,operator ,@(mapcar #'(lambda (m) `(call-method ,m ()))
+				      primary)))))
+      (cond ((null primary)
+	     `(error "No ~S methods for the generic function ~S."
+		     ',type ',generic-function))
+	    ((null around) main-method)
+	    (t
+	     `(call-method ,(car around)
+			   (,@(cdr around) (make-method ,main-method))))))))
+
+
+;;;
+;;; long method combinations
+;;;
+;;;
+
+(defclass long-method-combination (standard-method-combination)
+     ((function :initarg :function
+		:reader long-method-combination-function)))
+
+(defun expand-long-defcombin (form)
+  (let ((type (cadr form))
+	(lambda-list (caddr form))
+	(method-group-specifiers (cadddr form))
+	(body (cddddr form))
+	(arguments-option ())
+	(gf-var nil))
+    (when (and (consp (car body)) (eq (caar body) :arguments))
+      (setq arguments-option (cdr (pop body))))
+    (when (and (consp (car body)) (eq (caar body) :generic-function))
+      (setq gf-var (cadr (pop body))))
+    (multiple-value-bind (documentation function)
+	(make-long-method-combination-function
+	  type lambda-list method-group-specifiers arguments-option gf-var
+	  body)
+      (make-top-level-form `(define-method-combination ,type)
+			   '(load eval)
+	`(load-long-defcombin ',type ',documentation #',function)))))
+
+(defvar *long-method-combination-functions* (make-hash-table :test #'eq))
+
+(defun load-long-defcombin (type doc function)
+  (let* ((specializers
+	   (list (find-class 'generic-function)
+		 (make-instance 'eql-specializer :object type)
+		 *the-class-t*))
+	 (old-method
+	   (get-method #'find-method-combination () specializers nil))
+	 (new-method
+	   (make-instance 'standard-method
+	     :qualifiers ()
+	     :specializers specializers
+	     :lambda-list '(generic-function type options)
+	     :function #'(lambda (generic-function type options)
+			   (declare (ignore generic-function))
+			   (make-instance 'long-method-combination
+			     :type type
+			     :documentation doc
+			     :options options))
+	     :definition-source `((define-method-combination ,type)
+				  ,(load-truename)))))
+    (setf (gethash type *long-method-combination-functions*) function)
+    (when old-method (remove-method #'find-method-combination old-method))
+    (add-method #'find-method-combination new-method)))
+
+(defmethod compute-effective-method ((generic-function generic-function)
+				     (combin long-method-combination)
+				     applicable-methods)
+  (funcall (gethash (method-combination-type combin)
+		    *long-method-combination-functions*)
+	   generic-function
+	   combin
+	   applicable-methods))
+
+;;;
+;;;
+;;;
+(defun make-long-method-combination-function
+       (type ll method-group-specifiers arguments-option gf-var body)
+  (declare (ignore type) (values documentation function))
+  (multiple-value-bind (documentation declarations real-body)
+      (extract-declarations body)
+
+    (let ((wrapped-body
+	    (wrap-method-group-specifier-bindings method-group-specifiers
+						  declarations
+						  real-body)))
+      (when gf-var
+	(push `(,gf-var .generic-function.) (cadr wrapped-body)))
+      
+      (when arguments-option
+	(setq wrapped-body (deal-with-arguments-option wrapped-body
+						       arguments-option)))
+
+      (when ll
+	(setq wrapped-body
+	      `(apply #'(lambda ,ll ,wrapped-body)
+		      (method-combination-options .method-combination.))))
+
+      (values
+	documentation
+	`(lambda (.generic-function. .method-combination. .applicable-methods.)
+	   (progn .generic-function. .method-combination. .applicable-methods.)
+	   (block .long-method-combination-function. ,wrapped-body))))))
+;;
+;; parse-method-group-specifiers parse the method-group-specifiers
+;;
+
+(defun wrap-method-group-specifier-bindings
+       (method-group-specifiers declarations real-body)
+  (with-gathering ((names (collecting))
+		   (specializer-caches (collecting))
+		   (cond-clauses (collecting))
+		   (required-checks (collecting))
+		   (order-cleanups (collecting)))
+      (dolist (method-group-specifier method-group-specifiers)
+	(multiple-value-bind (name tests description order required)
+	    (parse-method-group-specifier method-group-specifier)
+	  (declare (ignore description))
+	  (let ((specializer-cache (gensym)))
+	    (gather name names)
+	    (gather specializer-cache specializer-caches)
+	    (gather `((or ,@tests)
+		      (if  (equal ,specializer-cache .specializers.)
+			   (return-from .long-method-combination-function.
+			     '(error "More than one method of type ~S ~
+                                      with the same specializers."
+				     ',name))
+			   (setq ,specializer-cache .specializers.))
+		      (push .method. ,name))
+		    cond-clauses)
+	    (when required
+	      (gather `(when (null ,name)
+			 (return-from .long-method-combination-function.
+			   '(error "No ~S methods." ',name)))
+		      required-checks))
+	    (loop (unless (and (constantp order)
+			       (neq order (setq order (eval order))))
+		    (return t)))
+	    (gather (cond ((eq order :most-specific-first)
+			   `(setq ,name (nreverse ,name)))
+			  ((eq order :most-specific-last) ())
+			  (t
+			   `(ecase ,order
+			      (:most-specific-first
+				(setq ,name (nreverse ,name)))
+			      (:most-specific-last))))
+		    order-cleanups))))
+   `(let (,@names ,@specializer-caches)
+      ,@declarations
+      (dolist (.method. .applicable-methods.)
+	(let ((.qualifiers. (method-qualifiers .method.))
+	      (.specializers. (method-specializers .method.)))
+	  (progn .qualifiers. .specializers.)
+	  (cond ,@cond-clauses)))
+      ,@required-checks
+      ,@order-cleanups
+      ,@real-body)))
+   
+(defun parse-method-group-specifier (method-group-specifier)
+  (declare (values name tests description order required))
+  (let* ((name (pop method-group-specifier))
+	 (patterns ())
+	 (tests 
+	   (gathering1 (collecting)
+	     (block collect-tests
+	       (loop
+		 (if (or (null method-group-specifier)
+			 (memq (car method-group-specifier)
+			       '(:description :order :required)))
+		     (return-from collect-tests t)
+		     (let ((pattern (pop method-group-specifier)))
+		       (push pattern patterns)
+		       (gather1 (parse-qualifier-pattern name pattern)))))))))
+    (values name
+	    tests
+	    (getf method-group-specifier :description
+		  (make-default-method-group-description patterns))
+	    (getf method-group-specifier :order :most-specific-first)
+	    (getf method-group-specifier :required nil))))
+
+(defun parse-qualifier-pattern (name pattern)
+  (cond ((eq pattern '()) `(null .qualifiers.))
+	((eq pattern '*) 't)
+	((symbolp pattern) `(,pattern .qualifiers.))
+	((listp pattern) `(qualifier-check-runtime ',pattern .qualifiers.))
+	(t (error "In the method group specifier ~S,~%~
+                   ~S isn't a valid qualifier pattern."
+		  name pattern))))
+
+(defun qualifier-check-runtime (pattern qualifiers)
+  (loop (cond ((and (null pattern) (null qualifiers))
+	       (return t))
+	      ((eq pattern '*) (return t))
+	      ((and pattern qualifiers (eq (car pattern) (car qualifiers)))
+	       (pop pattern)
+	       (pop qualifiers))	      
+	      (t (return nil)))))
+
+(defun make-default-method-group-description (patterns)
+  (if (cdr patterns)
+      (format nil
+	      "methods matching one of the patterns: ~{~S, ~} ~S"
+	      (butlast patterns) (car (last patterns)))
+      (format nil
+	      "methods matching the pattern: ~S"
+	      (car patterns))))
+
+
+
+;;;
+;;; This baby is a complete mess.  I can't believe we put it in this
+;;; way.  No doubt this is a large part of what drives MLY crazy.
+;;;
+;;; At runtime (when the effective-method is run), we bind an intercept
+;;; lambda-list to the arguments to the generic function.
+;;; 
+;;; At compute-effective-method time, the symbols in the :arguments
+;;; option are bound to the symbols in the intercept lambda list.
+;;;
+(defun deal-with-arguments-option (wrapped-body arguments-option)
+  (let* ((intercept-lambda-list
+	   (gathering1 (collecting)
+	     (dolist (arg arguments-option)
+	       (if (memq arg lambda-list-keywords)
+		   (gather1 arg)
+		   (gather1 (gensym))))))
+	 (intercept-rebindings
+	   (gathering1 (collecting)
+	     (iterate ((arg (list-elements arguments-option))
+		       (int (list-elements intercept-lambda-list)))
+	       (unless (memq arg lambda-list-keywords)
+		 (gather1 `(,arg ',int)))))))
+    ;;
+    ;;
+    (setf (cadr wrapped-body)
+	  (append intercept-rebindings (cadr wrapped-body)))
+    ;;
+    ;; Be sure to fill out the intercept lambda list so that it can
+    ;; be too short if it wants to.
+    ;; 
+    (cond ((memq '&rest intercept-lambda-list))
+	  ((memq '&allow-other-keys intercept-lambda-list))
+	  ((memq '&key intercept-lambda-list)
+	   (setq intercept-lambda-list
+		 (append intercept-lambda-list '(&allow-other-keys))))
+	  (t
+	   (setq intercept-lambda-list
+		 (append intercept-lambda-list '(&rest .ignore.)))))
+
+    `(let ((inner-result. ,wrapped-body))
+       `(apply #'(lambda ,',intercept-lambda-list
+		   ,,(when (memq '.ignore. intercept-lambda-list)
+		       ''(declare (ignore .ignore.)))
+		   ,inner-result.)
+	       .combined-method-args.))))
+

clos/3.5/defs.lisp

@@ -0,0 +1,570 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+;;;. Copyright (c) 1991 by Venue
+
+
+(in-package "CLOS")
+
+(eval-when (compile load eval)
+       (defvar *defclass-times* '(load eval compile))	;Probably have to change this
+						;if you use defconstructor.
+(defvar *defmethod-times*  '(load eval compile))
+(defvar *defgeneric-times* '(load eval compile))
+)
+
+
+;;; Convert a function name to its standard setf function name.  We have to do this hack because not
+;;; all Common Lisps have yet converted to having setf function specs. In a port that does have setf
+;;; function specs you can use those just by making the obvious simple changes to these functions. 
+;;; The rest of CLOS believes that there are function names like (SETF <foo>), this is the only place
+;;; that knows about this hack. 
+
+
+(eval-when (compile load eval)
+       (defvar *setf-function-names* (make-hash-table :size 200 :test #'eq))
+(defun get-setf-function-name (name)
+  (or (gethash name *setf-function-names*)
+      (setf (gethash name *setf-function-names*)
+	    (intern (format nil
+			    "SETF ~A ~A"
+			    (package-name (symbol-package name))
+			    (symbol-name name))
+		    *the-clos-package*))))
+
+;;;
+;;; Call this to define a setf macro for a function with the same behavior as
+;;; specified by the SETF function cleanup proposal.  Specifically, this will
+;;; cause: (SETF (FOO a b) x) to expand to (|SETF FOO| x a b).
+;;;
+;;; do-standard-defsetf                  A macro interface for use at top level
+;;;                                      in files.  Unfortunately, users may
+;;;                                      have to use this for a while.
+;;;                                      
+;;; do-standard-defsetfs-for-defclass    A special version called by defclass.
+;;; 
+;;; do-standard-defsetf-1                A functional interface called by the
+;;;                                      above, defmethod and defgeneric.
+;;;                                      Since this is all a crock anyways,
+;;;                                      users are free to call this as well.
+;;;
+(defmacro do-standard-defsetf (&rest function-names)
+  `(eval-when (compile load eval)
+     (dolist (fn-name ',function-names) (do-standard-defsetf-1 fn-name))))
+
+(defun do-standard-defsetfs-for-defclass (accessors)
+  (dolist (name accessors) (do-standard-defsetf-1 name)))
+
+(defun do-standard-defsetf-1 (function-name)
+  (unless (setfboundp function-name)
+    (let* ((setf-function-name (get-setf-function-name function-name)))
+    
+  (flet ((setf-expander (body env)
+	       (declare (ignore env))
+	       (let ((temps
+		       (mapcar #'(lambda (x) (declare (ignore x)) (gensym))
+			       (cdr body)))
+		     (forms (cdr body))
+		     (vars (list (gensym))))
+		 (values temps
+			 forms
+			 vars
+			 `(,setf-function-name ,@vars ,@temps)
+			 `(,function-name ,@temps)))))
+	(let ((setf-method-expander (intern (concatenate 'string
+						         (symbol-name function-name)
+						         "-setf-expander")
+				     (symbol-package function-name))))
+	  (setf (get function-name :setf-method-expander) setf-method-expander
+		(symbol-function setf-method-expander) #'setf-expander)))
+
+     )))
+(defun setfboundp (symbol)
+(or (get symbol :setf-inverse)
+	       (get symbol 'il:setf-inverse)
+	       (get symbol 'il:setfn)
+	       (get symbol :shared-setf-inverse)
+	       (get symbol :setf-method-expander)
+	       (get symbol 'il:setf-method-expander)))
+)
+
+                                                             ; eval-when
+
+
+
+;;; CLOS, like user code, must endure the fact that we don't have a properly working setf.  Many
+;;; things work because they get mentioned by a defclass or defmethod before they are used, but
+;;; others have to be done by hand. 
+
+
+(do-standard-defsetf 
+	class-wrapper                           ; ***
+     generic-function-name 
+	method-function-plist 
+	method-function-get 
+	gdefinition 
+     slot-value-using-class)
+
+(defsetf slot-value set-slot-value)
+
+
+;;; This is like fdefinition on the Lispm.  If Common Lisp had something like function specs I
+;;; wouldn't need this.  On the other hand, I don't like the way this really works so maybe function
+;;; specs aren't really right either? I also don't understand the real implications of a Lisp-1 on
+;;; this sort of thing.  Certainly some of the lossage in all of this is because these SPECs name
+;;; global definitions. Note that this implementation is set up so that an implementation which has
+;;; a 'real' function spec mechanism can use that instead and in that way get rid of setf generic
+;;; function names. 
+
+
+(defmacro parse-gspec (spec (non-setf-var . non-setf-case)
+                            (setf-var . setf-case))
+              (once-only (spec)
+              `(cond ((symbolp ,spec)
+                      (let ((,non-setf-var ,spec))
+                           ,@non-setf-case))
+                     ((and (listp ,spec)
+                           (eq (car ,spec)
+                               'setf)
+                           (symbolp (cadr ,spec)))
+                      (let ((,setf-var (cadr ,spec)))
+                           ,@setf-case))
+                     (t (error "Can't understand ~S as a generic function specifier.~%~
+               It must be either a symbol which can name a function or~%~
+               a list like ~S, where the car is the symbol ~S and the cadr~%~
+               is a symbol which can name a generic function." ,spec '(setf <foo>)
+                               'setf)))))
+
+
+;;; If symbol names a function which is traced or advised, return the unadvised, traced etc.
+;;; definition.  This lets me get at the generic function object even when it is traced. 
+
+
+(defun unencapsulated-fdefinition (symbol)
+       (il:virginfn symbol))
+
+
+;;; If symbol names a function which is traced or advised, redefine the `real' definition without
+;;; affecting the advise. 
+
+
+(defun fdefine-carefully (symbol new-definition)
+       (let ((advisedp (member symbol il:advisedfns :test #'eq))
+             (brokenp (member symbol il:brokenfns :test #'eq)))
+            
+            ;; In XeroxLisp (late of envos) tracing is implemented as a special case of "breaking". 
+            ;; Advising, however, is treated specially. 
+            (xcl:unadvise-function symbol :no-error t)
+            (xcl:unbreak-function symbol :no-error t)
+            (setf (symbol-function symbol)
+                  new-definition)
+            (when brokenp (xcl:rebreak-function symbol))
+            (when advisedp (xcl:readvise-function symbol)))
+       new-definition)
+
+(defun gboundp (spec)
+       (parse-gspec spec (name (fboundp name))
+              (name (fboundp (get-setf-function-name name)))))
+
+(defun gmakunbound (spec)
+       (parse-gspec spec (name (fmakunbound name))
+              (name (fmakunbound (get-setf-function-name name)))))
+
+(defun gdefinition (spec)
+       (parse-gspec spec (name (or (macro-function name)
+                                                             ; ??
+                                   (unencapsulated-fdefinition name)))
+              (name (unencapsulated-fdefinition (get-setf-function-name name)))))
+
+(defun SETF\ CLOS\ GDEFINITION (new-value spec)
+       (parse-gspec spec (name (fdefine-carefully name new-value))
+              (name (fdefine-carefully (get-setf-function-name name)
+                           new-value))))
+
+
+;;; 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)))))
+
+(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)))))
+
+(defun do-satisfies-deftype (name predicate)
+       (let* ((specifier `(satisfies ,predicate))
+              (expand-fn #'(lambda (&rest ignore)
+                                  (declare (ignore ignore))
+                                  specifier)))
+             
+             ;; Specific ports can insert their own way of doing this.  Many ports may find the
+             ;; expand-fn defined above useful. 
+             (or 
+                 ;; This is the default for ports for which we don't know any better.  Note that for
+                 ;; most ports, providing this definition should just speed up class definition.  It
+                 ;; shouldn't have an effect on performance of most user code. 
+                 (eval `(deftype ,name nil '(satisfies ,predicate))))))
+
+(defun make-type-predicate-name (name)
+       (intern (format nil "TYPE-PREDICATE ~A ~A" (package-name (symbol-package name))
+                      (symbol-name name))
+              *the-clos-package*))
+
+(proclaim '(special *the-class-t* *the-class-vector* *the-class-symbol* *the-class-string* 
+                  *the-class-sequence* *the-class-rational* *the-class-ratio* *the-class-number* 
+                  *the-class-null* *the-class-list* *the-class-integer* *the-class-float* 
+                  *the-class-cons* *the-class-complex* *the-class-character* *the-class-bit-vector* 
+                  *the-class-array* *the-class-standard-object* *the-class-class* *the-class-method*
+                  *the-class-generic-function* *the-class-standard-class* *the-class-standard-method*
+                  *the-class-standard-generic-function* 
+                  *the-class-standard-effective-slot-definition* *the-eslotd-standard-class-slots*))
+
+(proclaim '(special *the-wrapper-of-t* *the-wrapper-of-vector* *the-wrapper-of-symbol* 
+                  *the-wrapper-of-string* *the-wrapper-of-sequence* *the-wrapper-of-rational* 
+                  *the-wrapper-of-ratio* *the-wrapper-of-number* *the-wrapper-of-null* 
+                  *the-wrapper-of-list* *the-wrapper-of-integer* *the-wrapper-of-float* 
+                  *the-wrapper-of-cons* *the-wrapper-of-complex* *the-wrapper-of-character* 
+                  *the-wrapper-of-bit-vector* *the-wrapper-of-array*))
+
+(defvar *built-in-class-symbols* nil)
+
+(defvar *built-in-wrapper-symbols* nil)
+
+(defun get-built-in-class-symbol (class-name)
+       (or (cadr (assq class-name *built-in-class-symbols*))
+           (let ((symbol (intern (format nil "*THE-CLASS-~A*" (symbol-name class-name))
+                                *the-clos-package*)))
+                (push (list class-name symbol)
+                      *built-in-class-symbols*)
+                symbol)))
+
+(defun get-built-in-wrapper-symbol (class-name)
+       (or (cadr (assq class-name *built-in-wrapper-symbols*))
+           (let ((symbol (intern (format nil "*THE-WRAPPER-OF-~A*" (symbol-name class-name))
+                                *the-clos-package*)))
+                (push (list class-name symbol)
+                      *built-in-wrapper-symbols*)
+                symbol)))
+
+(pushnew 'class *variable-declarations*)
+
+(pushnew 'variable-rebinding *variable-declarations*)
+
+(defun variable-class (var env)
+       (caddr (variable-declaration 'class var env)))
+
+(defvar *boot-state* nil)
+                                                             ; NIL EARLY BRAID COMPLETE 
+
+
+(eval-when (load eval)
+       (when (eq *boot-state* 'complete)
+             (error "Trying to load (or compile) CLOS in an environment in which it~%~
+            has already been loaded.  This doesn't work, you will have to~%~
+            get a fresh lisp (reboot) and then load CLOS."))
+       (when *boot-state* (cerror "Try loading (or compiling) CLOS anyways." "Trying to load (or compile) CLOS in an environment in which it~%~
+             has already been partially loaded.  This may not work, you may~%~
+             need to get a fresh lisp (reboot) and then load CLOS.")))
+
+
+;;; This is used by combined methods to communicate the next methods to the methods they call.  This
+;;; variable is captured by a lexical variable of the methods to give it the proper lexical scope. 
+
+
+(defvar *next-methods* nil)
+
+(defvar *not-an-eql-specializer* '(not-an-eql-specializer))
+
+(defvar *umi-gfs*)
+
+(defvar *umi-complete-classes*)
+
+(defvar *umi-reorder*)
+
+(defvar *invalidate-discriminating-function-force-p* nil)
+
+(defvar *invalid-dfuns-on-stack* nil)
+
+(defvar *standard-method-combination*)
+
+(defvar *slotd-unsupplied* (list '*slotd-unsupplied*))
+
+                                                             ; ***
+
+
+(defmacro define-gf-predicate (predicate &rest classes)
+       `(progn (defmethod ,predicate ((x t))
+                      nil)
+               ,@(mapcar #'(lambda (c)
+                                  `(defmethod ,predicate ((x ,c))
+                                          t))
+                        classes)))
+
+(defmacro plist-value (object name)
+       `(with-slots (plist)
+               ,object
+               (getf plist ,name)))
+
+(defsetf plist-value (object name)
+       (new-value)
+       (once-only (new-value)
+              `(with-slots (plist)
+                      ,object
+                      (if ,new-value
+                          (setf (getf plist ,name)
+                                ,new-value)
+                          (progn (remf plist ,name)
+                                 nil)))))
+
+(defvar *built-in-classes* 
+
+       ;; name       supers     subs                     cdr of cpl 
+       '((number (t) (complex float rational)
+                (t))
+         (complex (number)
+                nil
+                (number t))
+         (float (number)
+                nil
+                (number t))
+         (rational (number)
+                (integer ratio)
+                (number t))
+         (integer (rational)
+                nil
+                (rational number t))
+         (ratio (rational)
+                nil
+                (rational number t))
+         (sequence (t)
+                (list vector)
+                (t))
+         (list (sequence)
+               (cons null)
+               (sequence t))
+         (cons (list)
+               nil
+               (list sequence t))
+         (array (t)
+                (vector)
+                (t))
+         (vector (array sequence)
+                (string bit-vector)
+                (array sequence t))
+         (string (vector)
+                nil
+                (vector array sequence t))
+         (bit-vector (vector)
+                nil
+                (vector array sequence t))
+         (character (t)
+                nil
+                (t))
+         (symbol (t)
+                (null)
+                (t))
+         (null (symbol)
+               nil
+               (symbol list sequence t))))
+
+
+;;; The classes that define the kernel of the metabraid. 
+
+
+(defclass t nil nil (:metaclass built-in-class))
+
+(defclass standard-object (t)
+       nil)
+
+(defclass metaobject (standard-object)
+       nil)
+
+(defclass specializer (metaobject)
+       nil)
+
+(defclass definition-source-mixin (standard-object)
+       ((source :initform (load-truename)
+               :reader definition-source :initarg :definition-source)))
+
+(defclass plist-mixin (standard-object)
+       ((plist :initform nil)))
+
+(defclass documentation-mixin (plist-mixin)
+       nil)
+
+(defclass dependent-update-mixin (plist-mixin)
+       nil)
+
+
+;;; The class CLASS is a specified basic class.  It is the common superclass of any kind of class. 
+;;; That is any class that can be a metaclass must have the class CLASS in its class precedence
+;;; list. 
+
+
+(defclass class (documentation-mixin dependent-update-mixin definition-source-mixin specializer)
+       ((name :initform nil :initarg :name :accessor class-name)
+        (direct-superclasses :initform nil :reader class-direct-superclasses)
+        (direct-subclasses :initform nil :reader class-direct-subclasses)
+        (direct-methods :initform (cons nil nil))))
+
+
+;;; The class CLOS-CLASS is an implementation-specific common superclass of all specified subclasses
+;;; of the class CLASS. 
+
+
+(defclass clos-class (class)
+       ((class-precedence-list :initform nil)
+        (wrapper :initform nil)))
+
+
+;;; The class STD-CLASS is an implementation-specific common superclass of the classes
+;;; STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS. 
+
+
+(defclass std-class (clos-class)
+       ((direct-slots :initform nil :accessor class-direct-slots)
+        (slots :initform nil :accessor class-slots)
+        (no-of-instance-slots                                ; *** MOVE TO WRAPPER ***
+               :initform 0 :accessor class-no-of-instance-slots)
+        (prototype :initform nil)))
+
+(defclass standard-class (std-class)
+       nil)
+
+(defclass funcallable-standard-class (std-class)
+       nil)
+
+(defclass forward-referenced-class (clos-class)
+       nil)
+
+(defclass built-in-class (clos-class)
+       nil)
+
+
+;;; Slot definitions. Note that throughout CLOS, "SLOT-DEFINITION" is abbreviated as "SLOTD". 
+
+
+(defclass slot-definition (metaobject)
+       nil)
+
+(defclass direct-slot-definition (slot-definition)
+       nil)
+
+(defclass effective-slot-definition (slot-definition)
+       nil)
+;
+(defclass standard-slot-definition (slot-definition)
+       ((name :initform nil :accessor slotd-name)
+        (initform :initform *slotd-unsupplied* :accessor slotd-initform)
+        (initfunction :initform *slotd-unsupplied* :accessor slotd-initfunction)
+        (readers :initform nil :accessor slotd-readers)
+        (writers :initform nil :accessor slotd-writers)
+        (initargs :initform nil :accessor slotd-initargs)
+        (allocation :initform nil :accessor slotd-allocation)
+        (type :initform nil :accessor slotd-type)
+        (documentation :initform "" :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)
+       nil)
+
+                                                             ; Adding slots here may involve extra
+                                                             ; work to the code in braid.lisp 
+
+
+(defclass standard-effective-slot-definition (standard-slot-definition effective-slot-definition)
+       nil)
+
+                                                             ; Adding slots here may involve extra
+                                                             ; work to the code in braid.lisp 
+
+
+(defclass eql-specializer (specializer)
+       ((object :initarg :object :reader eql-specializer-object)))
+
+
+;;; 
+
+
+(defmacro dolist-carefully ((var list improper-list-handler)
+                            &body body)
+       `(let ((,var nil)
+              (.dolist-carefully. ,list))
+             (loop (when (null .dolist-carefully.)
+                         (return nil))
+                   (if (consp .dolist-carefully.)
+                       (progn (setq ,var (pop .dolist-carefully.))
+                              ,@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 nil (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 nil (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"))

clos/3.5/defsys.lisp

@@ -0,0 +1,761 @@
+;;;-*-Mode:LISP; Package:(CLOS LISP 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1991 Venue
+;;; All rights reserved.
+;;; *************************************************************************
+;;;
+;;; Some support stuff for compiling and loading CLOS.  It would be nice if
+;;; there was some portable make-system we could all agree to share for a
+;;; while.  At least until people really get databases and stuff.
+;;;
+;;; ***                                                               ***
+;;; ***        DIRECTIONS FOR INSTALLING CLOS AT YOUR SITE             ***
+;;; ***                                                               ***
+;;;
+;;; To get CLOS working at your site you should:
+;;; 
+;;;  - Get all the CLOS source files from Xerox.  The complete list of source
+;;;    file names can be found in the defsystem for CLOS which appears towards
+;;;    the end of this file.
+;;; 
+;;;  - Edit the variable *clos-directory* below to specify the directory at
+;;;    your site where the clos sources and binaries will be.  This variable
+;;;    can be found by searching from this point for the string "***" in
+;;;    this file.
+;;; 
+;;;  - Use the function (clos::compile-clos) to compile CLOS for your site.
+;;; 
+;;;  - Once CLOS has been compiled it can be loaded with (clos::load-clos).
+;;;    Note that CLOS cannot be loaded on top of itself, nor can it be
+;;;    loaded into the same world it was compiled in.
+;;;
+
+(in-package "CLOS" :use (list (or (find-package :walker)
+				 (make-package :walker :use '(:lisp)))
+			     (or (find-package :iterate)
+				 (make-package :iterate
+					       :use '(:lisp :walker)))
+			     (find-package :lisp)))
+
+(export (intern (symbol-name :iterate)		;Have to do this here,
+		(find-package :iterate))	;because in the defsystem
+	(find-package :iterate))		;(later in this file)
+						;we use the symbol iterate
+						;to name the file
+
+;;;
+;;; Sure, its weird for this to be here, but in order to follow the rules
+;;; about order of export and all that stuff, we can't put it in PKG before
+;;; we want to use it.
+;;; 
+(defvar *the-clos-package* (find-package :clos))
+
+(defvar *clos-system-date* "5/10/91 Interim CLOS release")
+
+
+;;;
+;;; 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 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*))))
+      ((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"))
+      (pushnew :CMU *features*)))
+  
+  #+TI
+  (if (eq (si:local-binary-file-type) :xld)
+      (pushnew ':ti-release-3 *features*)
+      (pushnew ':ti-release-2 *features*))
+
+  #+Lucid
+  (when (search "IBM RT PC" (machine-type))
+    (pushnew :ibm-rt-pc *features*))
+
+  #+ExCL
+  (cond ((search "sun3" (lisp-implementation-version))
+	 (push :sun3 *features*))
+	((search "sun4" (lisp-implementation-version))
+	 (push :sun4 *features*)))
+
+  #+(and HP Lucid)
+  (push :HP-Lucid *features*)
+  #+(and HP (not Lucid))
+  (push :HP-HPLabs *features*)
+
+  #+Xerox
+  (case il:makesysname
+    (:lyric (push :Xerox-Lyric *features*))
+    (otherwise (pushnew :Xerox-Medley *features*)))
+;;;
+;;; For KCL and IBCL, push the symbol :turbo-closure on the list *features*
+;;; if you have installed turbo-closure patch.  See the file kcl-mods.text
+;;; for details.
+;;;
+;;; The xkcl version of KCL has this fixed already.
+;;; 
+
+  #+xkcl(pushnew :turbo-closure *features*)
+
+  )
+
+
+
+;;; Yet Another Sort Of General System Facility and friends.
+;;;
+;;; The entry points are defsystem and operate-on-system.  defsystem is used
+;;; to define a new system and the files with their load/compile constraints.
+;;; Operate-on-system is used to operate on a system defined that has been
+;;; defined by defsystem.  For example:
+#||
+
+(defsystem my-very-own-system
+	   "/usr/myname/lisp/"
+  ((classes   (precom)           ()                ())
+   (methods   (precom classes)   (classes)         ())
+   (precom    ()                 (classes methods) (classes methods))))
+
+This defsystem should be read as follows:
+
+* Define a system named MY-VERY-OWN-SYSTEM, the sources and binaries
+  should be in the directory "/usr/me/lisp/".  There are three files
+  in the system, there are named classes, methods and precom.  (The
+  extension the filenames have depends on the lisp you are running in.)
+  
+* For the first file, classes, the (precom) in the line means that
+  the file precom should be loaded before this file is loaded.  The
+  first () means that no other files need to be loaded before this
+  file is compiled.  The second () means that changes in other files
+  don't force this file to be recompiled.
+
+* For the second file, methods, the (precom classes) means that both
+  of the files precom and classes must be loaded before this file
+  can be loaded.  The (classes) means that the file classes must be
+  loaded before this file can be compiled.  The () means that changes
+  in other files don't force this file to be recompiled.
+
+* For the third file, precom, the first () means that no other files
+  need to be loaded before this file is loaded.  The first use of
+  (classes methods)  means that both classes and methods must be
+  loaded before this file can be compiled.  The second use of (classes
+  methods) mean that whenever either classes or methods changes precom
+  must be recompiled.
+
+Then you can compile your system with:
+
+ (operate-on-system 'my-very-own-system :compile)
+
+and load your system with:
+
+ (operate-on-system 'my-very-own-system :load)
+
+||#
+
+;;; 
+(defvar *system-directory*)
+
+;;;
+;;; *port* is a list of symbols (in the CLOS package) which represent the
+;;; Common Lisp in which we are now running.  Many of the facilities in
+;;; defsys use the value of *port* rather than #+ and #- to conditionalize
+;;; the way they work.
+;;; 
+(defvar *port*
+        '(#+Genera               Genera
+;         #+Genera-Release-6     Rel-6
+;         #+Genera-Release-7-1   Rel-7
+          #+Genera-Release-7-2   Rel-7
+	  #+Genera-Release-7-3   Rel-7
+          #+Genera-Release-7-1   Rel-7-1
+          #+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
+	  #+Xerox-Medley         Xerox-Medley
+          #+TI                   TI
+          #+(and dec vax common) Vaxlisp
+          #+KCL                  KCL
+          #+IBCL                 IBCL
+          #+excl                 excl
+	  #+(and excl sun4)      excl-sun4
+          #+:CMU                 CMU
+          #+HP-HPLabs            HP-HPLabs
+          #+:gclisp              gclisp
+          #+pyramid              pyramid
+          #+:coral               coral))
+
+;;;
+;;; When you get a copy of CLOS (by tape or by FTP), the sources files will
+;;; have extensions of ".lisp" in particular, this file will be defsys.lisp.
+;;; The preferred way to install clos is to rename these files to have the
+;;; extension which your lisp likes to use for its files.  Alternately, it
+;;; is possible not to rename the files.  If the files are not renamed to
+;;; the proper convention, the second line of the following defvar should
+;;; be changed to:
+;;;     (let ((files-renamed-p nil)
+;;;
+;;; Note: Something people installing CLOS on a machine running Unix
+;;;       might find useful.  If you want to change the extensions
+;;;       of the source files from ".lisp" to ".lsp", *all* you have
+;;;       to do is the following:
+;;;
+;;;       % foreach i (*.lisp)
+;;;       ? mv $i $i:r.lsp
+;;;       ? end
+;;;       %
+;;;
+;;;       I am sure that a lot of people already know that, and some
+;;;       Unix hackers may say, "jeez who doesn't know that".  Those
+;;;       same Unix hackers are invited to fix mv so that I can type
+;;;       "mv *.lisp *.lsp".
+;;;
+(defvar *pathname-extensions*
+  (let ((files-renamed-p t)
+        (proper-extensions
+          (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")
+             #+IBCL                              ("lsp"   . "o")
+             #+Xerox                             ("lisp"  . "dfasl")
+             #+(and Lucid MC68000)               ("lisp"  . "lbin")
+             #+(and Lucid VAX)                   ("lisp"  . "vbin")
+             #+(and Lucid Prime)                 ("lisp"  . "pbin")
+	     #+(and Lucid SUNRise)               ("lisp"  . "sbin")
+	     #+(and Lucid SPARC)                 ("lisp"  . "sbin")
+             #+(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                              ("slisp" . "sfasl")
+             #+HP                                ("l"     . "b")
+             #+TI ("lisp" . #.(string (si::local-binary-file-type)))
+             #+:gclisp                           ("LSP"   . "F2S")
+             #+pyramid                           ("clisp" . "o")
+             #+:coral                            ("lisp"  . "fasl")
+             ))))
+    (cond ((null proper-extensions) '("l" . "lbin"))
+          ((null files-renamed-p) (cons "lisp" (cdr proper-extensions)))
+          (t proper-extensions))))
+
+(eval-when (compile load eval)
+
+(defun get-system (name)
+  (get name 'system-definition))
+
+(defun set-system (name new-value)
+  (setf (get name 'system-definition) new-value))
+
+(defmacro defsystem (name directory files)
+  `(set-system ',name (list #'(lambda () ,directory)
+			    (make-modules ',files)
+			    ',(mapcar #'car files))))
+
+)
+
+
+;;;
+;;; The internal datastructure used when operating on a system.
+;;; 
+(defstruct (module (:constructor make-module (name))
+                   (:print-function
+                     (lambda (m s d)
+                       (declare (ignore d))
+                       (format s "#<Module ~A>" (module-name m)))))
+  name
+  load-env
+  comp-env
+  recomp-reasons)
+
+(defun make-modules (system-description)
+  (let ((modules ()))
+    (labels ((get-module (name)
+               (or (find name modules :key #'module-name)
+                   (progn (setq modules (cons (make-module name) modules))
+                          (car modules))))
+             (parse-spec (spec)
+               (if (eq spec 't)
+                   (reverse (cdr modules))
+		   (case (car spec)
+		     (+ (append (reverse (cdr modules)) (mapcar #'get-module (cdr spec))))
+		     (- (let ((rem (mapcar #'get-module (cdr spec))))
+			  (remove-if #'(lambda (m) (member m rem)) (reverse (cdr modules)))))
+		     (otherwise (mapcar #'get-module spec))))))
+      (dolist (file system-description)
+        (let* ((name (car file))
+               (port (car (cddddr file)))
+               (module nil))
+          (when (or (null port)
+                    (member port *port*))
+            (setq module (get-module name))
+            (setf (module-load-env module) (parse-spec (cadr file))
+                  (module-comp-env module) (parse-spec (caddr file))
+                  (module-recomp-reasons module) (parse-spec
+                                                   (cadddr file))))))
+      (let ((filenames (mapcar #'car system-description)))
+	(sort modules #'(lambda (name1 name2)
+			  (member name2 (member name1 filenames)))
+	      :key #'module-name)))))
+
+
+(defun make-transformations (modules filter make-transform)
+  (let ((transforms (list nil)))
+    (dolist (m modules)
+      (when (funcall filter m transforms) (funcall make-transform m transforms)))
+    (reverse (cdr transforms))))
+
+(defun make-compile-transformation (module transforms)
+  (unless (dolist (trans transforms)
+	    (and (eq (car trans) ':compile)
+		 (eq (cadr trans) module)
+		 (return t)))
+    (dolist (c (module-comp-env module)) (make-load-transformation c transforms))
+    (setf (cdr transforms)
+	  (remove-if #'(lambda (trans) (and (eq (car trans) :load) (eq (cadr trans) module)))
+		     (cdr transforms)))
+    (push `(:compile ,module) (cdr transforms))))
+
+(defvar *being-loaded* ())
+
+(defun make-load-transformation (module transforms)
+  (if (assoc module *being-loaded*)
+      (throw module (setf (cdr transforms) (cdr (assoc module *being-loaded*))))
+      (let ((*being-loaded* (cons (cons module (cdr transforms)) *being-loaded*)))
+	(catch module
+	  (unless (dolist (trans transforms)
+		    (when (and (eq (car trans) ':load)
+			       (eq (cadr trans) module))
+		      (return t)))
+	    (dolist (l (module-load-env module)) (make-load-transformation l transforms))
+	    (push `(:load ,module) (cdr transforms)))))))
+
+(defun make-load-without-dependencies-transformation (module transforms)
+  (unless (dolist (trans transforms)
+            (and (eq (car trans) ':load)
+                 (eq (cadr trans) module)
+                 (return trans)))
+    (push `(:load ,module) (cdr transforms))))
+
+(defun compile-filter (module transforms)
+  (or (dolist (r (module-recomp-reasons module))
+        (when (dolist (transform transforms)
+                (when (and (eq (car transform) ':compile)
+                           (eq (cadr transform) r))
+                  (return t)))
+          (return t)))
+      (null (probe-file (make-binary-pathname (module-name module))))
+      (> (file-write-date (make-source-pathname (module-name module)))
+         (file-write-date (make-binary-pathname (module-name module))))))
+
+(defun operate-on-system (name mode &optional arg print-only)
+  (let ((system (get-system name)))
+    (unless system (error "Can't find system with name ~S." name))
+    (let ((*system-directory* (funcall (car system)))
+	  (modules (cadr system))
+	  (transformations ()))
+      (labels ((load-source (name pathname)
+		 (format t "~&Loading source of ~A..." name)
+		 (or print-only (load pathname)))
+	       (load-binary (name pathname)
+		 (format t "~&Loading binary of ~A..." name)
+		 (or print-only (load pathname)))	       
+	       (load-module (m)
+		 (let* ((name (module-name m))
+			(*load-verbose* nil)
+			(binary (make-binary-pathname name)))
+		   (load-binary name binary)))
+	       (compile-module (m)
+		 (format t "~&Compiling ~A..." (module-name m))
+		 (unless print-only
+		   (let  ((name (module-name m)))
+		     (compile-file (make-source-pathname name)
+				   :output-file
+				   (make-pathname :defaults
+						  (make-binary-pathname name)
+						  :version :newest)))))
+	       (xcl:true (&rest ignore) (declare (ignore ignore)) 't))
+	
+	(setq transformations
+	      (ecase mode
+		(:compile
+		  ;; Compile any files that have changed and any other files
+		  ;; that require recompilation when another file has been
+		  ;; recompiled.
+		  (make-transformations
+		    modules
+		    #'compile-filter
+		    #'make-compile-transformation))
+		(:recompile
+		  ;; Force recompilation of all files.
+		  (make-transformations
+		    modules
+		    #'xcl:true
+		    #'make-compile-transformation))
+		(:recompile-some
+		  ;; Force recompilation of some files.  Also compile the
+		  ;; files that require recompilation when another file has
+		  ;; been recompiled.
+		  (make-transformations
+		    modules
+		    #'(lambda (m transforms)
+			(or (member (module-name m) arg)
+			    (compile-filter m transforms)))
+		    #'make-compile-transformation))
+		(:query-compile
+		  ;; Ask the user which files to compile.  Compile those
+		  ;; and any other files which must be recompiled when
+		  ;; another file has been recompiled.
+		  (make-transformations
+		    modules
+		    #'(lambda (m transforms)
+			(or (compile-filter m transforms)
+			    (y-or-n-p "Compile ~A?"
+				      (module-name m))))
+		    #'make-compile-transformation))
+		(:confirm-compile
+		  ;; Offer the user a chance to prevent a file from being
+		  ;; recompiled.
+		  (make-transformations
+		    modules
+		    #'(lambda (m transforms)
+			(and (compile-filter m transforms)
+			     (y-or-n-p "Go ahead and compile ~A?"
+				       (module-name m))))
+		    #'make-compile-transformation))
+		(:load
+		  ;; Load the whole system.
+		  (make-transformations
+		    modules
+		    #'xcl:true
+		    #'make-load-transformation))
+		(:query-load
+		  ;; Load only those files the user says to load.
+		  (make-transformations
+		    modules
+		    #'(lambda (m transforms)
+			(declare (ignore transforms))
+			(y-or-n-p "Load ~A?" (module-name m)))
+		    #'make-load-without-dependencies-transformation))))
+	
+	(#+Genera
+	 compiler:compiler-warnings-context-bind
+	 #+TI
+	 COMPILER:COMPILER-WARNINGS-CONTEXT-BIND
+	 #+:LCL3.0
+	 lucid-common-lisp:with-deferred-warnings
+	 #-(or Genera TI :LCL3.0)
+	 progn
+	 (loop (when (null transformations) (return t))
+	       (let ((transform (pop transformations)))
+		 (ecase (car transform)
+		   (:compile (compile-module (cadr transform)))
+		   (:load (load-module (cadr transform)))))))))))
+
+
+(defun make-source-pathname (name) (make-pathname-internal name :source))
+(defun make-binary-pathname (name) (make-pathname-internal name :binary))
+
+(defun make-pathname-internal (name type)
+  (let* ((extension (ecase type
+                      (:source (car *pathname-extensions*))
+                      (:binary (cdr *pathname-extensions*))))
+         (directory (pathname
+		      (etypecase *system-directory*
+			(string *system-directory*)
+			(pathname *system-directory*)
+			(cons (ecase type
+				(:source (car *system-directory*))
+				(:binary (cdr *system-directory*)))))))
+         (pathname
+           (make-pathname
+             :name (string-downcase (string name))
+             :type extension
+             :defaults directory :version :newest)))
+
+    #+Genera
+    (setq pathname (zl:send pathname :new-raw-name (pathname-name pathname))
+          pathname (zl:send pathname :new-raw-type (pathname-type pathname)))
+
+    pathname))
+
+
+
+;;; ***                SITE SPECIFIC CLOS DIRECTORY                        ***
+;;;
+;;; *clos-directory* is a variable which specifies the directory clos is stored
+;;; in at your site.  If the value of the variable is a single pathname, the
+;;; sources and binaries should be stored in that directory.  If the value of
+;;; that directory is a cons, the CAR should be the source directory and the
+;;; CDR should be the binary directory.
+;;;
+;;; By default, the value of *clos-directory* is set to the directory that
+;;; this file is loaded from.  This makes it simple to keep multiple copies
+;;; of CLOS in different places, just load defsys from the same directory as
+;;; the copy of CLOS you want to use.
+;;;
+;;; Note that the value of *CLOS-DIRECTORY* is set using a DEFVAR.  This is
+;;; done to make it possible for users to set it in their init file and then
+;;; load this file.  The value set in the init file will override the value
+;;; here.
+;;;
+;;; ***                                                                   ***
+
+(defun load-truename (&optional (errorp nil))
+  (flet ((bad-time ()
+	   (when errorp
+	     (error "LOAD-TRUENAME called but a file isn't being loaded."))))
+    #+Lispm  (or sys:fdefine-file-pathname (bad-time))
+    #+excl   excl::*source-pathname*
+    #+Xerox  (pathname (or (il:fullname *standard-input*) (bad-time)))
+    #+(and dec vax common) (truename (sys::source-file #'load-truename))
+    ;;
+    ;; The following use of  `lucid::' is a kludge for 2.1 and 3.0
+    ;; 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))
+    #-(or Lispm excl Xerox (and dec vax common) LUCID) nil))
+
+#-Symbolics
+(defvar *clos-directory*
+	(or (load-truename t)
+	    (error "Because load-truename is not implemented in this port~%~
+                    of CLOS, you must manually edit the definition of the~%~
+                    variable *clos-directory* in the file defsys.lisp.")))
+
+#+Genera
+(defvar *clos-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 *clos-directory* (pathname "/usr3/hornig/clos/"))
+
+(defsystem clos	   
+           *clos-directory*
+  ;;
+  ;; file         load           compile      files which       port
+  ;;              environment    environment  force the of
+  ;;                                          recompilation
+  ;;                                          of this file
+  ;;                                          
+  (
+   (patch           t            t            ()                xerox)
+   (pkg             t            t            ())
+   (walk            (pkg)        (pkg)        ())
+   (iterate         t            t            ())
+   (macros          t            t            ())
+   (low             (pkg macros) t            (macros))
+   (low2          (low)         (low)        (low)            Xerox)
+   (fin         t                                   t (low))
+   (defclass    t                                   t (low))
+   (defs        t                                   t (defclass macros iterate))
+   (fngen       t                                   t (low))
+   (lap         t                                   t (low))
+   (plap        t                                   t (low))
+   (cache       t                                   t (low defs))
+   (dlap        t                                   t (defs low fin cache lap))
+   (boot        t                                   t (defs fin))
+   (vector      t                                   t (boot defs cache fin))
+   (slots       t                                   t (vector boot defs low cache fin))
+   (init        t                                   t (vector boot defs low cache fin))
+   (std-class   t                                   t (vector boot defs low cache fin slots))
+   (cpl         t                                   t (vector boot defs low cache fin slots))
+   (braid       t                                   t (boot defs low fin cache))
+   (fsc         t                                   t (defclass boot defs low fin cache))
+   (methods     t                                   t (defclass boot defs low fin cache))
+   (combin      t                                   t (defclass boot defs low fin cache))
+   (dfun        t                                   t (dlap))
+   (fixup       (+ precom1 precom2 precom4)         t (boot defs low fin))
+   (defcombin   t                                   t (defclass boot defs low fin))
+   (ctypes      t                                   t (defclass defcombin))
+   (construct   t                                   t (defclass boot defs low))
+   (env         t                                   t (defclass boot defs low fin))
+   (compat      t                                   t ())
+   (precom1     (dlap)                              t (defs low cache fin dfun))
+   (precom2     (dlap)                              t (defs low cache fin dfun))
+   (precom4     (dlap)                              t (defs low cache fin dfun))
+
+   (clos-env    t                                   t ()   Xerox)
+   (web-editor  t                                   t ()   Xerox)
+   (new-clos-browser t                              t ()   Xerox)
+   ))
+
+(defun compile-clos (&optional m)
+  (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 'clos :compile))
+	  ((eq m :print)   (operate-on-system 'clos :compile () t))
+	  ((eq m :query)   (operate-on-system 'clos :query-compile))
+	  ((eq m :confirm) (operate-on-system 'clos :confirm-compile))
+	  ((eq m 't)       (operate-on-system 'clos :recompile))        
+	  ((listp m)       (operate-on-system 'clos :compile-from m))
+	  ((symbolp m)     (operate-on-system 'clos :recompile-some `(,m))))))
+
+(defun load-clos (&optional m)
+  (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 'clos :load))
+	  ((eq m :query) (operate-on-system 'clos :query-load)))
+    (pushnew :clos *features*)))
+
+#+Genera
+;;; Make sure Genera bug mail contains the CLOS 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 clos-private-patch-info ((description)) ())
+  (scl:defmethod (sct::private-patch-info-description clos-private-patch-info) ()
+    (or description
+	(setf description (string-append "CLOS version: " *clos-system-date*))))
+  (scl:defmethod (sct::private-patch-info-pathname clos-private-patch-info) ()
+    *clos-directory*)
+  (unless (find-if #'(lambda (x) (typep x 'clos-private-patch-info))
+		   sct::*private-patch-info*)
+    (push (scl:make-instance 'clos-private-patch-info)
+	  sct::*private-patch-info*)))
+
+(defun bug-report-info (&optional (stream *standard-output*))
+  (format stream "~&CLOS system date: ~A~
+                  ~&Lisp Implementation type: ~A~
+                  ~&Lisp Implementation version: ~A~
+                  ~&*features*: ~S"
+	  *clos-system-date*
+	  (lisp-implementation-type)
+	  (lisp-implementation-version)
+	  *features*))
+
+
+
+;;;;
+;;;
+;;; This stuff is not intended for external use.
+;;; 
+(defun rename-clos ()
+  (dolist (f (cadr (get-system 'clos)))
+    (let ((old nil)
+          (new nil))
+      (let ((*system-directory* *default-pathname-defaults*))
+        (setq old (make-source-pathname (car f))))
+      (setq new  (make-source-pathname (car f)))
+      (rename-file old new))))
+
+#+Genera
+(defun edit-clos ()
+  (dolist (f (cadr (get-system 'clos)))
+    (let ((*system-directory* *clos-directory*))
+      (zwei:find-file (make-source-pathname (car f))))))
+
+#+Genera
+(defun hardcopy-clos (&optional query-p)
+  (let ((files (mapcar #'(lambda (f)
+                           (setq f (car f))
+                           (and (or (not query-p)
+                                    (y-or-n-p "~A? " f))
+                                f))
+		       (cadr (get-system 'clos))))
+        (b zwei:*interval*))
+    (unwind-protect
+        (dolist (f files)
+          (when f
+            (multiple-value-bind (ignore b)
+                (zwei:find-file (make-source-pathname f))
+              (zwei:hardcopy-buffer b))))
+      (zwei:make-buffer-current b))))
+
+
+;;;
+;;; unido!ztivax!dae@seismo.css.gov
+;;; z30083%tansei.cc.u-tokyo.junet@utokyo-relay.csnet
+;;; Victor@carmen.uu.se
+;;; mcvax!harlqn.co.uk!chris@uunet.UU.NET
+;;; 
+#+Genera
+(defun mail-clos (to)
+  (let* ((original-buffer zwei:*interval*)
+	 (*system-directory* (pathname "vaxc:/user/ftp/pub/clos/")
+			    ;(funcall (car (get-system 'clos)))
+			     )
+         (files (list* 'defsys
+			'test
+			(caddr (get-system 'clos))))
+         (total-number (length files))
+         (file nil)
+	 (number-of-lines 0)
+         (i 0)
+         (mail-buffer nil))
+    (unwind-protect
+        (loop
+           (when (null files) (return nil))
+           (setq file (pop files))
+           (incf i)
+           (multiple-value-bind (ignore b)
+               (zwei:find-file (make-source-pathname file))
+	     (setq number-of-lines (zwei:count-lines b))
+             (zwei:com-mail-internal t
+                                     :initial-to to
+                                     :initial-body b
+				     :initial-subject
+                                     (format nil
+				       "CLOS file   ~A   (~A of ~A) ~D lines"
+				       file i total-number number-of-lines))
+             (setq mail-buffer zwei:*interval*)
+             (zwei:com-exit-com-mail)
+             (format t "~&Just sent ~A  (~A of ~A)." b i total-number)
+             (zwei:kill-buffer mail-buffer)))
+      (zwei:make-buffer-current original-buffer))))
+
+

clos/3.5/dfun.lisp

@@ -0,0 +1,606 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+;;;. Copyright (c) 1991 by Venue
+
+(in-package "CLOS")
+
+                                                             
+                                                             ; ************************************************************************
+                                                             ; temporary for data gathering         
+                                                             ; temporary for data gathering
+                                                             ; ************************************************************************
+
+
+(defvar *dfun-states* (make-hash-table :test #'eq))
+
+(defun notice-dfun-state (generic-function state &optional nkeys valuep)
+       (setf (gethash generic-function *dfun-states*)
+             (cons state (when nkeys (list nkeys valuep)))))
+
+                                                             
+                                                             ; ************************************************************************
+                                                             ; temporary for data gathering         
+                                                             ; temporary for data gathering
+                                                             ; ************************************************************************
+
+
+(defvar *dfun-constructors* nil)
+
+                                                             ; An alist in which each entry is of
+                                                             ; the form (<generator> . (<subentry>
+                                                             ; ...)) Each subentry is of the form:
+                                                             ; (<args> <constructor> <system>) 
+
+
+(defvar *enable-dfun-constructor-caching* t)
+
+                                                             ; If this is NIL, then the whole
+                                                             ; mechanism for caching dfun
+                                                             ; constructors is turned off.  The only
+                                                             ; time that makes sense is when
+                                                             ; debugging LAP code. 
+
+
+(defun show-dfun-constructors nil (format t "~&DFUN constructor caching is ~A." (if 
+                                                                    *enable-dfun-constructor-caching*
+                                                                                    "enabled"
+                                                                                    "disabled"))
+       (dolist (generator-entry *dfun-constructors*)
+           (dolist (args-entry (cdr generator-entry))
+               (format t "~&~S ~S" (cons (car generator-entry)
+                                         (caar args-entry))
+                      (caddr args-entry)))))
+
+(defun get-dfun-constructor (generator &rest args)
+       (let* ((generator-entry (assq generator *dfun-constructors*))
+              (args-entry (assoc args (cdr generator-entry)
+                                 :test
+                                 #'equal)))
+             (if (null *enable-dfun-constructor-caching*)
+                 (apply (symbol-function generator)
+                        args)
+                 (or (cadr args-entry)
+                     (let ((new (apply (symbol-function generator)
+                                       args)))
+                          (if generator-entry
+                              (push (list (copy-list args)
+                                          new nil)
+                                    (cdr generator-entry))
+                              (push (list generator (list (copy-list args)
+                                                          new nil))
+                                    *dfun-constructors*))
+                          new)))))
+
+(defun load-precompiled-dfun-constructor (generator args system constructor)
+       (let* ((generator-entry (assq generator *dfun-constructors*))
+              (args-entry (assoc args (cdr generator-entry)
+                                 :test
+                                 #'equal)))
+             (unless args-entry
+                 (if generator-entry
+                     (push (list args constructor system)
+                           (cdr generator-entry))
+                     (push (list generator (list args constructor system))
+                           *dfun-constructors*)))))
+
+(defmacro
+ precompile-dfun-constructors
+ (&optional system)
+ (let
+  ((*precompiling-lap* t))
+  `(progn
+    ,@(gathering1 (collecting)
+             (dolist (generator-entry *dfun-constructors*)
+                 (dolist (args-entry (cdr generator-entry))
+                     (when (or (null (caddr args-entry))
+                               (eq (caddr args-entry)
+                                   system))
+                         (multiple-value-bind (closure-variables arguments iregs vregs tregs lap)
+                             (apply (symbol-function (car generator-entry))
+                                    (car args-entry))
+                           (gather1 (make-top-level-form `(precompile-dfun-constructor
+                                                           ,(car generator-entry))
+                                           '(load)
+                                           `(load-precompiled-dfun-constructor
+                                             ',(car generator-entry)
+                                             ',(car args-entry)
+                                             ',system
+                                             (precompile-lap-closure-generator ,closure-variables
+                                                    ,arguments
+                                                    ,iregs
+                                                    ,vregs
+                                                    ,tregs
+                                                    ,lap))))))))))))
+
+(defun make-initial-dfun (generic-function)
+       #'(lambda (&rest args)
+                (initial-dfun args generic-function)))
+
+
+;;; When all the methods of a generic function are automatically generated reader or writer methods
+;;; a number of special optimizations are possible. These are important because of the large number
+;;; of generic functions of this type. There are a number of cases: ONE-CLASS-ACCESSOR In this case,
+;;; the accessor generic function has only been called with one class of argument.  There is no
+;;; cache vector, the wrapper of the one class, and the slot index are stored directly as closure
+;;; variables of the discriminating function.  This case can convert to either of the next kind.
+;;; TWO-CLASS-ACCESSOR Like above, but two classes.  This is common enough to do specially. There is
+;;; no cache vector.  The two classes are stored a separate closure variables. ONE-INDEX-ACCESSOR In
+;;; this case, the accessor generic function has seen more than one class of argument, but the index
+;;; of the slot is the same for all the classes that have been seen.  A cache vector is used to
+;;; store the wrappers that have been seen, the slot index is stored directly as a closure variable
+;;; of the discriminating function.  This case can convert to the next kind. N-N-ACCESSOR This is
+;;; the most general case.  In this case, the accessor generic function has seen more than one class
+;;; of argument and more than one slot index.  A cache vector stores the wrappers and corresponding
+;;; slot indexes.  Because each cache line is more than one element long, a cache lock count is
+;;; used. ONE-CLASS-ACCESSOR 
+
+
+(defun update-to-one-class-readers-dfun (generic-function wrapper index)
+       (let ((constructor (get-dfun-constructor 'emit-one-class-reader (consp index))))
+            (notice-dfun-state generic-function `(one-class readers ,(consp index)))
+                                                             ; ***
+            (update-dfun generic-function (funcall constructor wrapper index
+                                                 #'(lambda (arg)
+                                                          (declare (clos-fast-call))
+                                                          (one-class-readers-miss arg 
+                                                                 generic-function index wrapper))))))
+
+(defun update-to-one-class-writers-dfun (generic-function wrapper index)
+       (let ((constructor (get-dfun-constructor 'emit-one-class-writer (consp index))))
+            (notice-dfun-state generic-function `(one-class writers ,(consp index)))
+                                                             ; ***
+            (update-dfun generic-function (funcall constructor wrapper index
+                                                 #'(lambda (new-value arg)
+                                                          (declare (clos-fast-call))
+                                                          (one-class-writers-miss new-value arg 
+                                                                 generic-function index wrapper))))))
+
+(defun one-class-readers-miss (arg generic-function index wrapper)
+       (accessor-miss generic-function 'one-class 'reader nil arg index wrapper nil nil nil))
+
+(defun one-class-writers-miss (new arg generic-function index wrapper)
+       (accessor-miss generic-function 'one-class 'writer new arg index wrapper nil nil nil))
+
+
+;;; TWO-CLASS-ACCESSOR 
+
+
+(defun update-to-two-class-readers-dfun (generic-function wrapper-0 wrapper-1 index)
+       (let ((constructor (get-dfun-constructor 'emit-two-class-reader (consp index))))
+            (notice-dfun-state generic-function `(two-class readers ,(consp index)))
+                                                             ; ***
+            (update-dfun generic-function (funcall constructor wrapper-0 wrapper-1 index
+                                                 #'(lambda (arg)
+                                                          (declare (clos-fast-call))
+                                                          (two-class-readers-miss arg 
+                                                                 generic-function index wrapper-0 
+                                                                 wrapper-1))))))
+
+(defun update-to-two-class-writers-dfun (generic-function wrapper-0 wrapper-1 index)
+       (let ((constructor (get-dfun-constructor 'emit-two-class-writer (consp index))))
+            (notice-dfun-state generic-function `(two-class writers ,(consp index)))
+                                                             ; ***
+            (update-dfun generic-function (funcall constructor wrapper-0 wrapper-1 index
+                                                 #'(lambda (new-value arg)
+                                                          (declare (clos-fast-call))
+                                                          (two-class-writers-miss new-value arg 
+                                                                 generic-function index wrapper-0 
+                                                                 wrapper-1))))))
+
+(defun two-class-readers-miss (arg generic-function index w0 w1)
+       (accessor-miss generic-function 'two-class 'reader nil arg index w0 w1 nil nil))
+
+(defun two-class-writers-miss (new arg generic-function index w0 w1)
+       (accessor-miss generic-function 'two-class 'writer new arg index w0 w1 nil nil))
+
+
+;;; std accessors same index dfun 
+
+
+(defun update-to-one-index-readers-dfun (generic-function index &optional field cache)
+       (unless field
+           (setq field (wrapper-field 'number)))
+       (let ((constructor (get-dfun-constructor 'emit-one-index-readers (consp index))))
+            (multiple-value-bind (mask size)
+                (compute-cache-parameters 1 nil (or cache 4))
+              (unless cache
+                  (setq cache (get-cache size)))
+              (notice-dfun-state generic-function `(one-index readers ,(consp index)))
+                                                             ; ***
+              (update-dfun generic-function (funcall constructor field cache mask size index
+                                                   #'(lambda (arg)
+                                                            (declare (clos-fast-call))
+                                                            (one-index-readers-miss arg 
+                                                                   generic-function index field cache
+                                                                   )))
+                     cache))))
+
+(defun update-to-one-index-writers-dfun (generic-function index &optional field cache)
+       (unless field
+           (setq field (wrapper-field 'number)))
+       (let ((constructor (get-dfun-constructor 'emit-one-index-writers (consp index))))
+            (multiple-value-bind (mask size)
+                (compute-cache-parameters 1 nil (or cache 4))
+              (unless cache
+                  (setq cache (get-cache size)))
+              (notice-dfun-state generic-function `(one-index writers ,(consp index)))
+                                                             ; ***
+              (update-dfun generic-function (funcall constructor field cache mask size index
+                                                   #'(lambda (new-value arg)
+                                                            (declare (clos-fast-call))
+                                                            (one-index-writers-miss new-value arg 
+                                                                   generic-function index field cache
+                                                                   )))
+                     cache))))
+
+(defun one-index-readers-miss (arg gf index field cache)
+       (accessor-miss gf 'one-index 'reader nil arg index nil nil field cache))
+
+(defun one-index-writers-miss (new arg gf index field cache)
+       (accessor-miss gf 'one-index 'writer new arg index nil nil field cache))
+
+(defun one-index-limit-fn (nlines)
+       (default-limit-fn nlines))
+
+(defun update-to-n-n-readers-dfun (generic-function &optional field cache)
+       (unless field
+           (setq field (wrapper-field 'number)))
+       (let ((constructor (get-dfun-constructor 'emit-n-n-readers)))
+            (multiple-value-bind (mask size)
+                (compute-cache-parameters 1 t (or cache 2))
+              (unless cache
+                  (setq cache (get-cache size)))
+              (notice-dfun-state generic-function `(n-n readers))
+                                                             ; ***
+              (update-dfun generic-function (funcall constructor field cache mask size
+                                                   #'(lambda (arg)
+                                                            (declare (clos-fast-call))
+                                                            (n-n-readers-miss arg generic-function 
+                                                                   field cache)))
+                     cache))))
+
+(defun update-to-n-n-writers-dfun (generic-function &optional field cache)
+       (unless field
+           (setq field (wrapper-field 'number)))
+       (let ((constructor (get-dfun-constructor 'emit-n-n-writers)))
+            (multiple-value-bind (mask size)
+                (compute-cache-parameters 1 t (or cache 2))
+              (unless cache
+                  (setq cache (get-cache size)))
+              (notice-dfun-state generic-function `(n-n writers))
+                                                             ; ***
+              (update-dfun generic-function (funcall constructor field cache mask size
+                                                   #'(lambda (new arg)
+                                                            (declare (clos-fast-call))
+                                                            (n-n-writers-miss new arg 
+                                                                   generic-function field cache)))
+                     cache))))
+
+(defun n-n-readers-miss (arg gf field cache)
+       (accessor-miss gf 'n-n 'reader nil arg nil nil nil field cache))
+
+(defun n-n-writers-miss (new arg gf field cache)
+       (accessor-miss gf 'n-n 'writer new arg nil nil nil field cache))
+
+(defun n-n-accessors-limit-fn (nlines)
+       (default-limit-fn nlines))
+
+
+;;; 
+
+
+(defun update-to-checking-dfun (generic-function function &optional field cache)
+       (unless field
+           (setq field (wrapper-field 'number)))
+       (let* ((arg-info (gf-arg-info generic-function))
+              (metatypes (arg-info-metatypes arg-info))
+              (applyp (arg-info-applyp arg-info))
+              (nkeys (arg-info-nkeys arg-info)))
+             (if (every #'(lambda (mt)
+                                 (eq mt 't))
+                        metatypes)
+                 (progn (notice-dfun-state generic-function `(default-method-only))
+                                                             ; ***
+                        (update-dfun generic-function function))
+                 (multiple-value-bind (mask size)
+                     (compute-cache-parameters nkeys nil (or cache 2))
+                   (unless cache
+                       (setq cache (get-cache size)))
+                   (let ((constructor (get-dfun-constructor 'emit-checking metatypes applyp)))
+                        (notice-dfun-state generic-function '(checking)
+                               nkeys nil)
+                                                             ; ****
+                        (update-dfun generic-function
+                               (funcall constructor field cache mask size function
+                                      #'(lambda (&rest args)
+                                               (declare (clos-fast-call))
+                                               (checking-miss generic-function args function field 
+                                                      cache)))
+                               cache))))))
+
+(defun checking-limit-fn (nlines)
+       (default-limit-fn nlines))
+
+
+;;; 
+
+
+(defun update-to-caching-dfun (generic-function &optional field cache)
+       (unless field
+           (setq field (wrapper-field 'number)))
+       (let* ((arg-info (gf-arg-info generic-function))
+              (metatypes (arg-info-metatypes arg-info))
+              (applyp (arg-info-applyp arg-info))
+              (nkeys (arg-info-nkeys arg-info))
+              (constructor (get-dfun-constructor 'emit-caching metatypes applyp)))
+             (multiple-value-bind (mask size)
+                 (compute-cache-parameters nkeys t (or cache 2))
+               (unless cache
+                   (setq cache (get-cache size)))
+               (notice-dfun-state generic-function '(caching)
+                      nkeys t)
+                                                             ; ****
+               (update-dfun generic-function (funcall constructor field cache mask size
+                                                    #'(lambda (&rest args)
+                                                             (declare (clos-fast-call))
+                                                             (caching-miss generic-function args 
+                                                                    field cache)))
+                      cache))))
+
+(defun caching-limit-fn (nlines)
+       (default-limit-fn nlines))
+
+
+;;; The dynamically adaptive method lookup algorithm is implemented is implemented as a kind of
+;;; state machine.  The kinds of discriminating function is the state, the various kinds of reasons
+;;; for a cache miss are the state transitions. The code which implements the transitions is all in
+;;; the miss handlers for each kind of dfun.  Those appear here. Note that within the states that
+;;; cache, there are dfun updates which simply select a new cache or cache field.  Those are not
+;;; considered as state transitions. 
+
+
+(defun initial-dfun (args generic-function)
+       (protect-cache-miss-code generic-function args
+              (multiple-value-bind (wrappers invalidp nfunction applicable)
+                  (cache-miss-values generic-function args)
+                (multiple-value-bind (ntype nindex)
+                    (accessor-miss-values generic-function applicable args)
+                  (cond ((null applicable)
+                         (apply #'no-applicable-method generic-function args))
+                        (invalidp (apply nfunction args))
+                        ((and ntype nindex)
+                         (ecase ntype
+                             (reader (update-to-one-class-readers-dfun generic-function wrappers 
+                                            nindex))
+                             (writer (update-to-one-class-writers-dfun generic-function wrappers 
+                                            nindex)))
+                         (apply nfunction args))
+                        (ntype (apply nfunction args))
+                        (t (update-to-checking-dfun generic-function nfunction)
+                           (apply nfunction args)))))))
+
+(defun
+ accessor-miss
+ (gf ostate otype new object oindex ow0 ow1 field cache)
+ (declare (ignore ow1))
+ (let ((args (ecase otype                                    ; The congruence rules assure
+                 (reader (list object))                      ; us that this is safe despite
+                 (writer (list new object)))))
+                                                             ; not knowing the new type yet.
+      (protect-cache-miss-code
+       gf args
+       (multiple-value-bind (wrappers invalidp nfunction applicable)
+           (cache-miss-values gf args)
+         (multiple-value-bind (ntype nindex)
+             (accessor-miss-values gf applicable args)
+           
+           ;; The following lexical functions change the state of the dfun to that which is their
+           ;; name.  They accept arguments which are the parameters of the new state, and get other
+           ;; information from the lexical variables bound above. 
+           (flet ((two-class (index w0 w1)
+                         (when (zerop (random 2))
+                               (psetf w0 w1 w1 w0))
+                         (ecase ntype
+                             (reader (update-to-two-class-readers-dfun gf w0 w1 index))
+                             (writer (update-to-two-class-writers-dfun gf w0 w1 index))))
+                  (one-index (index &optional field cache)
+                         (ecase ntype
+                             (reader (update-to-one-index-readers-dfun gf index field cache))
+                             (writer (update-to-one-index-writers-dfun gf index field cache))))
+                  (n-n (&optional field cache)
+                       (ecase ntype
+                           (reader (update-to-n-n-readers-dfun gf field cache))
+                           (writer (update-to-n-n-writers-dfun gf field cache))))
+                  (checking nil (update-to-checking-dfun gf nfunction))
+                  
+                  ;; 
+                  (do-fill (valuep limit-fn update-fn)
+                         (multiple-value-bind (nfield ncache)
+                             (fill-cache field cache 1 valuep limit-fn wrappers nindex)
+                           (unless (and (= nfield field)
+                                        (eq ncache cache))
+                                  (funcall update-fn nfield ncache)))))
+                 (cond ((null nfunction)
+                        (apply #'no-applicable-method gf args))
+                       ((null ntype)
+                        (checking)
+                        (apply nfunction args))
+                       ((or invalidp (null nindex))
+                        (apply nfunction args))
+                       ((not (or (std-instance-p object)
+                                 (fsc-instance-p object)))
+                        (checking)
+                        (apply nfunction args))
+                       ((neq ntype otype)
+                        (checking)
+                        (apply nfunction args))
+                       (t (ecase ostate
+                              (one-class (if (eql nindex oindex)
+                                             (two-class nindex ow0 wrappers)
+                                             (n-n)))
+                              (two-class (if (eql nindex oindex)
+                                             (one-index nindex)
+                                             (n-n)))
+                              (one-index (if (eql nindex oindex)
+                                             (do-fill nil #'one-index-limit-fn
+                                                    #'(lambda (nfield ncache)
+                                                             (one-index nindex nfield ncache)))
+                                             (n-n)))
+                              (n-n (unless (consp nindex)
+                                       (do-fill t #'n-n-accessors-limit-fn #'n-n))))
+                          (apply nfunction args)))))))))
+
+(defun checking-miss (generic-function args ofunction field cache)
+       (protect-cache-miss-code generic-function args
+              (let* ((arg-info (gf-arg-info generic-function))
+                     (nkeys (arg-info-nkeys arg-info)))
+                    (multiple-value-bind (wrappers invalidp nfunction)
+                        (cache-miss-values generic-function args)
+                      (cond (invalidp (apply nfunction args))
+                            ((null nfunction)
+                             (apply #'no-applicable-method generic-function args))
+                            ((eq ofunction nfunction)
+                             (multiple-value-bind (nfield ncache)
+                                 (fill-cache field cache nkeys nil #'checking-limit-fn wrappers nil)
+                               (unless (and (= nfield field)
+                                            (eq ncache cache))
+                                      (update-to-checking-dfun generic-function nfunction nfield 
+                                             ncache)))
+                             (apply nfunction args))
+                            (t (update-to-caching-dfun generic-function)
+                               (apply nfunction args)))))))
+
+(defun caching-miss (generic-function args ofield ocache)
+       (protect-cache-miss-code generic-function args
+              (let* ((arg-info (gf-arg-info generic-function))
+                     (nkeys (arg-info-nkeys arg-info)))
+                    (multiple-value-bind (wrappers invalidp function)
+                        (cache-miss-values generic-function args)
+                      (cond (invalidp (apply function args))
+                            ((null function)
+                             (apply #'no-applicable-method generic-function args))
+                            (t (multiple-value-bind (nfield ncache)
+                                   (fill-cache ofield ocache nkeys t #'caching-limit-fn wrappers 
+                                          function)
+                                 (unless (and (= nfield ofield)
+                                              (eq ncache ocache))
+                                        (update-to-caching-dfun generic-function nfield ncache)))
+                               (apply function args)))))))
+
+
+;;; Some useful support functions which are shared by the implementations of the different kinds of
+;;; dfuns. Given a generic function and a set of arguments to that generic function, returns a mess
+;;; of values. <wrappers>   Is a single wrapper if the generic function has only one key, that is
+;;; arg-info-nkeys of the arg-info is 1. Otherwise a list of the wrappers of the specialized
+;;; arguments to the generic function. Note that all these wrappers are valid.  This function does
+;;; invalid wrapper traps when it finds an invalid wrapper and then returns the new, valid wrapper.
+;;; <invalidp>   True if any of the specialized arguments had an invalid wrapper, false otherwise.
+;;; <function>   The compiled effective method function for this set of arguments.  Gotten from
+;;; get-secondary-dispatch-function so effective-method-function caching is in effect, and that is
+;;; important since it is what keeps us in checking dfun state when possible. <type>       READER or
+;;; WRITER when the only method that would be run is a standard reader or writer method.  To be
+;;; specific, the value is READER when the method combination is eq to
+;;; *standard-method-combination*; there are no applicable :before, :after or :around methods; and
+;;; the most specific primary method is a standard reader method. <index>      If <type> is READER
+;;; or WRITER, and the slot accessed is an :instance slot, this is the index number of that slot in
+;;; the object argument. <applicable> Sorted list of applicable methods. 
+
+
+(defun cache-miss-values (generic-function args)
+       (declare (values wrappers invalidp function applicable))
+       (multiple-value-bind (function appl arg-info)
+           (get-secondary-dispatch-function generic-function args)
+         (multiple-value-bind (wrappers invalidp)
+             (get-wrappers generic-function args arg-info)
+           (values wrappers invalidp (cache-miss-values-function generic-function function)
+                  appl))))
+
+(defun get-wrappers (generic-function args &optional arg-info)
+       (let* ((invalidp nil)
+              (wrappers nil)
+              (arg-info (or arg-info (gf-arg-info generic-function)))
+              (metatypes (arg-info-metatypes arg-info))
+              (nkeys (arg-info-nkeys arg-info)))
+             (flet ((get-valid-wrapper (x)
+                           (let ((wrapper (wrapper-of x)))
+                                (cond ((invalid-wrapper-p wrapper)
+                                       (setq invalidp t)
+                                       (check-wrapper-validity x))
+                                      (t wrapper)))))
+                   (setq wrappers (block collect-wrappers
+                                      (gathering1 (collecting)
+                                             (iterate ((arg (list-elements args))
+                                                       (metatype (list-elements metatypes)))
+                                                    (when (neq metatype 't)
+                                                        (if (= nkeys 1)
+                                                            (return-from collect-wrappers
+                                                                   (get-valid-wrapper arg))
+                                                            (gather1 (get-valid-wrapper arg))))))))
+                   (values wrappers invalidp))))
+
+(defun cache-miss-values-function (generic-function function)
+       (if (eq *generate-random-code-segments* generic-function)
+           (progn (setq *generate-random-code-segments* nil)
+                  #'(lambda (&rest args)
+                           (declare (ignore args))
+                           nil))
+           function))
+
+(defun generate-random-code-segments (generic-function)
+       (dolist (arglist (generate-arglists generic-function))
+           (let ((*generate-random-code-segments* generic-function))
+                (apply generic-function arglist))))
+
+(defun generate-arglists (generic-function)
+       
+       ;; Generate arglists using class-prototypes and eql-specializer-objects to get all the
+       ;; "different" values that could be returned by get-secondary-dispatch-function for this
+       ;; generic-function. 
+       (let ((methods (generic-function-methods generic-function)))
+            (mapcar #'(lambda (class-list)
+                             (mapcar #'(lambda (specializer)
+                                              (if (eql-specializer-p specializer)
+                                                  (eql-specializer-object specializer)
+                                                  (class-prototype specializer)))
+                                    (method-specializers (find class-list methods :test
+                                                               #'(lambda (class-list method)
+                                                                        (every 
+                                                                               #'
+                                                                 specializer-applicable-using-class-p
+                                                                               (method-specializers
+                                                                                method)
+                                                                               class-list))))))
+                   (generate-arglist-classes generic-function))))
+
+(defun generate-arglist-classes (generic-function)
+       (let ((methods (generic-function-methods generic-function)))
+            (declare (ignore methods))
+            
+            ;; Finish this sometime.
+            nil))
+
+(defun accessor-miss-values (generic-function applicable args)
+       (declare (values type index))
+       (let ((type (and (eq (generic-function-method-combination generic-function)
+                            *standard-method-combination*)
+                        (every #'(lambda (m)
+                                        (null (method-qualifiers m)))
+                               applicable)
+                        (let ((method (car applicable)))
+                             (cond ((standard-reader-method-p method)
+                                    (and (optimize-slot-value-by-class-p (class-of (car args))
+                                                (accessor-method-slot-name method)
+                                                nil)
+                                         'reader))
+                                   ((standard-writer-method-p method)
+                                    (and (optimize-slot-value-by-class-p (class-of (cadr args))
+                                                (accessor-method-slot-name method)
+                                                t)
+                                         'writer))
+                                   (t nil))))))
+            (values type (and type (let ((wrapper (wrapper-of (case type
+                                                                  (reader (car args))
+                                                                  (writer (cadr args)))))
+                                         (slot-name (accessor-method-slot-name (car applicable))))
+                                        (or (instance-slot-index wrapper slot-name)
+                                            (assq slot-name (wrapper-class-slots wrapper))))))))

clos/3.5/dlap.lisp

@@ -0,0 +1,492 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+;;; Copyright (c) 1991 by Venue
+
+(in-package "CLOS")
+
+;;;
+
+(defun emit-one-class-reader (class-slot-p)
+       (emit-reader/writer :reader 1 class-slot-p))
+
+(defun emit-one-class-writer (class-slot-p)
+       (emit-reader/writer :writer 1 class-slot-p))
+
+(defun emit-two-class-reader (class-slot-p)
+       (emit-reader/writer :reader 2 class-slot-p))
+
+(defun emit-two-class-writer (class-slot-p)
+       (emit-reader/writer :writer 2 class-slot-p))
+
+(defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p)
+       (let ((instance nil)
+             (arglist nil)
+             (closure-variables nil)
+             (field (wrapper-field 'number)))
+                                                             ; we need some field to do the fast
+                                                             ; obsolete check 
+            (ecase reader/writer
+                (:reader (setq instance (dfun-arg-symbol 0)
+                               arglist
+                               (list instance)))
+                (:writer (setq instance (dfun-arg-symbol 1)
+                               arglist
+                               (list (dfun-arg-symbol 0)
+                                     instance))))
+            (ecase 1-or-2-class
+                (1 (setq closure-variables '(wrapper-0 index miss-fn)))
+                (2 (setq closure-variables '(wrapper-0 wrapper-1 index miss-fn))))
+            (generating-lap
+             closure-variables arglist
+             (with-lap-registers ((inst t)
+                                                             ; reg for the instance
+                                  (wrapper vector)
+                                                             ; reg for the wrapper
+                                  (cache-no index))
+                                                             ; reg for the cache no
+                    (let ((index cache-no)
+                                                             ; This register is used for different
+                                                             ; values at different times. 
+                          (slots (and (null class-slot-p)
+                                      (allocate-register 'vector)))
+                          (csv (and class-slot-p (allocate-register t))))
+                         (prog1 (flatten-lap (opcode :move (operand :arg instance)
+                                                    inst)
+                                                             ; get the instance
+                                       (opcode :std-instance-p inst 'std-instance)
+                                                             ; if not either std-inst
+                                       (opcode :fsc-instance-p inst 'fsc-instance)
+                                                             ; or fsc-instance then
+                                       (opcode :go 'trap)
+                                                             ; we lose
+                                       (opcode :label 'fsc-instance)
+                                       (opcode :move (operand :fsc-wrapper inst)
+                                              wrapper)
+                                       (and slots (opcode :move (operand :fsc-slots inst)
+                                                         slots))
+                                       (opcode :go 'have-wrapper)
+                                       (opcode :label 'std-instance)
+                                       (opcode :move (operand :std-wrapper inst)
+                                              wrapper)
+                                       (and slots (opcode :move (operand :std-slots inst)
+                                                         slots))
+                                       (opcode :label 'have-wrapper)
+                                       (opcode :move (operand :cref wrapper field)
+                                              cache-no)
+                                       (opcode :izerop cache-no 'trap)
+                                                             ; obsolete wrapper?
+                                       (ecase 1-or-2-class
+                                           (1 (emit-check-1-class-wrapper wrapper 'wrapper-0
+                                                     'trap))
+                                           (2 (emit-check-2-class-wrapper wrapper 'wrapper-0
+                                                     'wrapper-1
+                                                     'trap)))
+                                       (if class-slot-p
+                                           (flatten-lap (opcode :move (operand :cvar 'index)
+                                                               csv)
+                                                  (ecase reader/writer
+                                                      (:reader (emit-get-class-slot csv 'trap inst))
+                                                      (:writer (emit-set-class-slot csv (car arglist)
+                                                                      inst))))
+                                           (flatten-lap (opcode :move (operand :cvar 'index)
+                                                               index)
+                                                  (ecase reader/writer
+                                                      (:reader (emit-get-slot slots index
+                                                                      'trap inst))
+                                                      (:writer (emit-set-slot slots index
+                                                                      (car arglist)
+                                                                      inst)))))
+                                       (opcode :label 'trap)
+                                       (emit-miss 'miss-fn))
+                             (when slots (deallocate-register slots))
+                             (when csv (deallocate-register csv))))))))
+
+(defun emit-one-index-readers (class-slot-p)
+       (let ((arglist (list (dfun-arg-symbol 0))))
+            (generating-lap '(field cache mask size index miss-fn)
+                   arglist
+                   (with-lap-registers ((slots vector))
+                          (emit-dlap arglist '(standard-instance)
+                                 'trap
+                                 (with-lap-registers ((index index))
+                                        (flatten-lap (opcode :move (operand :cvar 'index)
+                                                            index)
+                                               (if class-slot-p
+                                                   (emit-get-class-slot index 'trap slots)
+                                                   (emit-get-slot slots index 'trap))))
+                                 (flatten-lap (opcode :label 'trap)
+                                        (emit-miss 'miss-fn))
+                                 nil
+                                 (and (null class-slot-p)
+                                      (list slots)))))))
+
+(defun emit-one-index-writers (class-slot-p)
+       (let ((arglist (list (dfun-arg-symbol 0)
+                            (dfun-arg-symbol 1))))
+            (generating-lap '(field cache mask size index miss-fn)
+                   arglist
+                   (with-lap-registers ((slots vector))
+                          (emit-dlap arglist '(t standard-instance)
+                                 'trap
+                                 (with-lap-registers ((index index))
+                                        (flatten-lap (opcode :move (operand :cvar 'index)
+                                                            index)
+                                               (if class-slot-p
+                                                   (emit-set-class-slot index (dfun-arg-symbol 0)
+                                                          slots)
+                                                   (emit-set-slot slots index (dfun-arg-symbol 0)))))
+                                 (flatten-lap (opcode :label 'trap)
+                                        (emit-miss 'miss-fn))
+                                 nil
+                                 (and (null class-slot-p)
+                                      (list nil slots)))))))
+
+(defun emit-n-n-readers nil (let ((arglist (list (dfun-arg-symbol 0))))
+                                 (generating-lap '(field cache mask size miss-fn)
+                                        arglist
+                                        (with-lap-registers ((slots vector)
+                                                             (index index))
+                                               (emit-dlap arglist '(standard-instance)
+                                                      'trap
+                                                      (emit-get-slot slots index 'trap)
+                                                      (flatten-lap (opcode :label 'trap)
+                                                             (emit-miss 'miss-fn))
+                                                      index
+                                                      (list slots))))))
+
+(defun emit-n-n-writers nil (let ((arglist (list (dfun-arg-symbol 0)
+                                                 (dfun-arg-symbol 1))))
+                                 (generating-lap '(field cache mask size miss-fn)
+                                        arglist
+                                        (with-lap-registers ((slots vector)
+                                                             (index index))
+                                               (flatten-lap (emit-dlap arglist '(t standard-instance)
+                                                                   'trap
+                                                                   (emit-set-slot slots index
+                                                                          (dfun-arg-symbol 0))
+                                                                   (flatten-lap (opcode :label
+                                                                                       'trap)
+                                                                          (emit-miss 'miss-fn))
+                                                                   index
+                                                                   (list nil slots)))))))
+
+(defun emit-checking (metatypes applyp)
+       (let ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp)))
+            (generating-lap '(field cache mask size function miss-fn)
+                   dlap-lambda-list
+                   (emit-dlap (remove '&rest dlap-lambda-list)
+                          metatypes
+                          'trap
+                          (with-lap-registers (#'t)
+                                 (flatten-lap (opcode :move (operand :cvar 'function)
+                                                     function)
+                                        (opcode :jmp function)))
+                          (with-lap-registers ((miss-function t))
+                                 (flatten-lap (opcode :label 'trap)
+                                        (opcode :move (operand :cvar 'miss-fn)
+                                               miss-function)
+                                        (opcode :jmp miss-function)))
+                          nil))))
+
+(defun emit-caching (metatypes applyp)
+       (let ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp)))
+            (generating-lap '(field cache mask size miss-fn)
+                   dlap-lambda-list
+                   (with-lap-registers (#'t)
+                          (emit-dlap (remove '&rest dlap-lambda-list)
+                                 metatypes
+                                 'trap
+                                 (flatten-lap (opcode :jmp function))
+                                 (with-lap-registers ((miss-function t))
+                                        (flatten-lap (opcode :label 'trap)
+                                               (opcode :move (operand :cvar 'miss-fn)
+                                                      miss-function)
+                                               (opcode :jmp miss-function)))
+                                 function)))))
+
+(defun emit-check-1-class-wrapper (wrapper cwrapper-0 miss-label)
+       (with-lap-registers ((cwrapper vector))
+              (flatten-lap (opcode :move (operand :cvar cwrapper-0)
+                                  cwrapper)
+                     (opcode :neq wrapper cwrapper miss-label))))
+
+                                                             ; wrappers not eq, trap
+
+
+(defun emit-check-2-class-wrapper (wrapper cwrapper-0 cwrapper-1 miss-label)
+       (with-lap-registers ((cwrapper vector))
+              (flatten-lap (opcode :move (operand :cvar cwrapper-0)
+                                  cwrapper)
+                                                             ; This is an OR.  Isn't
+                     (opcode :eq wrapper cwrapper 'hit-internal)
+                                                             ; assembly code fun
+                     (opcode :move (operand :cvar cwrapper-1)
+                            cwrapper)
+                                                             ; 
+                     (opcode :neq wrapper cwrapper miss-label)
+                                                             ; 
+                     (opcode :label 'hit-internal))))
+
+(defun emit-get-slot (slots index trap-label &optional temp)
+       (let ((slot-unbound (operand :constant *slot-unbound*)))
+            (with-lap-registers ((val t :reuse temp))
+                   (flatten-lap (opcode :move (operand :iref slots index)
+                                       val)
+                                                             ; get slot value
+                          (opcode :eq val slot-unbound trap-label)
+                                                             ; is the slot unbound?
+                          (opcode :return val)))))
+
+                                                             ; return the slot value
+
+
+(defun emit-set-slot (slots index new-value-arg &optional temp)
+       (with-lap-registers ((new-val t :reuse temp))
+              (flatten-lap (opcode :move (operand :arg new-value-arg)
+                                  new-val)
+                                                             ; get new value into a reg
+                     (opcode :move new-val (operand :iref slots index))
+                                                             ; set slot value
+                     (opcode :return new-val))))
+
+(defun emit-get-class-slot (index trap-label &optional temp)
+       (let ((slot-unbound (operand :constant *slot-unbound*)))
+            (with-lap-registers ((val t :reuse temp))
+                   (flatten-lap (opcode :move (operand :cdr index)
+                                       val)
+                          (opcode :eq val slot-unbound trap-label)
+                          (opcode :return val)))))
+
+(defun emit-set-class-slot (index new-value-arg &optional temp)
+       (with-lap-registers ((new-val t :reuse temp))
+              (flatten-lap (opcode :move (operand :arg new-value-arg)
+                                  new-val)
+                     (opcode :move new-val (operand :cdr index))
+                     (opcode :return new-val))))
+
+(defun emit-miss (miss-fn)
+       (with-lap-registers ((miss-fn-reg t))
+              (flatten-lap (opcode :move (operand :cvar miss-fn)
+                                  miss-fn-reg)
+                                                             ; get the miss function
+                     (opcode :jmp miss-fn-reg))))
+
+                                                             ; and call it
+
+
+(defun dlap-wrappers (metatypes)
+       (mapcar #'(lambda (x)
+                        (and (neq x 't)
+                             (allocate-register 'vector)))
+              metatypes))
+
+(defun dlap-wrapper-moves (wrappers args metatypes miss-label slot-regs)
+       (gathering1 (collecting)
+              (iterate ((mt (list-elements metatypes))
+                        (arg (list-elements args))
+                        (wrapper (list-elements wrappers))
+                        (i (interval :from 0)))
+                     (when wrapper
+                         (gather1 (emit-fetch-wrapper mt arg wrapper miss-label (nth i slot-regs)))))
+              ))
+
+(defun emit-dlap (args metatypes miss-label hit miss value-reg &optional slot-regs)
+       (let* ((wrappers (dlap-wrappers metatypes))
+              (nwrappers (remove nil wrappers))
+              (wrapper-moves (dlap-wrapper-moves wrappers args metatypes miss-label slot-regs)))
+             (prog1 (emit-dlap-internal nwrappers wrapper-moves hit miss miss-label value-reg)
+                 (mapc #'deallocate-register nwrappers))))
+
+(defun emit-dlap-internal (wrapper-regs wrapper-moves hit miss miss-label value-reg)
+       (cond ((cdr wrapper-regs)
+              (emit-greater-than-1-dlap wrapper-regs wrapper-moves hit miss miss-label value-reg))
+             ((null value-reg)
+              (emit-1-nil-dlap (car wrapper-regs)
+                     (car wrapper-moves)
+                     hit miss miss-label))
+             (t (emit-1-t-dlap (car wrapper-regs)
+                       (car wrapper-moves)
+                       hit miss miss-label value-reg))))
+
+(defun emit-1-nil-dlap (wrapper wrapper-move hit miss miss-label)
+       (with-lap-registers ((location index)
+                            (primary index)
+                            (cache vector))
+              (flatten-lap wrapper-move (opcode :move (operand :cvar 'cache)
+                                               cache)
+                     (with-lap-registers ((wrapper-cache-no index))
+                            (flatten-lap (emit-1-wrapper-compute-primary-cache-location wrapper 
+                                                primary wrapper-cache-no)
+                                   (opcode :move primary location)
+                                   (emit-check-1-wrapper-in-cache cache location wrapper hit)
+                                                             ; inline hit code
+                                   (opcode :izerop wrapper-cache-no miss-label)))
+                     (with-lap-registers ((size index))
+                            (flatten-lap (opcode :move (operand :cvar 'size)
+                                                size)
+                                   (opcode :label 'loop)
+                                   (opcode :move (operand :i1+ location)
+                                          location)
+                                   (opcode :fix= location primary miss-label)
+                                   (opcode :fix= location size 'set-location-to-min)
+                                   (opcode :label 'continue)
+                                   (emit-check-1-wrapper-in-cache cache location wrapper hit)
+                                   (opcode :go 'loop)
+                                   (opcode :label 'set-location-to-min)
+                                   (opcode :izerop primary miss-label)
+                                   (opcode :move (operand :constant (index-value->index 0))
+                                          location)
+                                   (opcode :go 'continue)))
+                     miss)))
+
+
+;;; The function below implements CACHE-LOCK-COUNT as the first entry in a cache (svref cache 0). 
+;;; This should probably be abstracted. 
+
+
+(defun emit-1-t-dlap (wrapper wrapper-move hit miss miss-label value)
+       (with-lap-registers ((location index)
+                            (primary index)
+                            (cache vector)
+                            (initial-lock-count t))
+              (flatten-lap wrapper-move (opcode :move (operand :cvar 'cache)
+                                               cache)
+                     (with-lap-registers ((wrapper-cache-no index))
+                            (flatten-lap (emit-1-wrapper-compute-primary-cache-location wrapper 
+                                                primary wrapper-cache-no)
+                                   (opcode :move primary location)
+                                   (opcode :move (operand :cref cache 0)
+                                          initial-lock-count)
+                                                             ; get lock-count
+                                   (emit-check-cache-entry cache location wrapper 'hit-internal)
+                                   (opcode :izerop wrapper-cache-no miss-label)))
+                                                             ; check for obsolescence
+                     (with-lap-registers ((size index))
+                            (flatten-lap (opcode :move (operand :cvar 'size)
+                                                size)
+                                   (opcode :label 'loop)
+                                   (opcode :move (operand :i1+ location)
+                                          location)
+                                   (opcode :move (operand :i1+ location)
+                                          location)
+                                   (opcode :label 'continue)
+                                   (opcode :fix= location primary miss-label)
+                                   (opcode :fix= location size 'set-location-to-min)
+                                   (emit-check-cache-entry cache location wrapper 'hit-internal)
+                                   (opcode :go 'loop)
+                                   (opcode :label 'set-location-to-min)
+                                   (opcode :izerop primary miss-label)
+                                   (opcode :move (operand :constant (index-value->index 2))
+                                          location)
+                                   (opcode :go 'continue)))
+                     (opcode :label 'hit-internal)
+                     (opcode :move (operand :i1+ location)
+                            location)
+                                                             ; position for getting value
+                     (opcode :move (emit-cache-ref cache location)
+                            value)
+                     (emit-lock-count-test initial-lock-count cache 'hit)
+                     miss
+                     (opcode :label 'hit)
+                     hit)))
+
+(defun emit-greater-than-1-dlap (wrappers wrapper-moves hit miss miss-label value)
+       (let ((cache-line-size (compute-line-size (+ (length wrappers)
+                                                    (if value
+                                                        1
+                                                        0)))))
+            (with-lap-registers ((location index)
+                                 (primary index)
+                                 (cache vector)
+                                 (initial-lock-count t)
+                                 (next-location index)
+                                 (line-size index))
+                                                             ; Line size holds a constant that can
+                                                             ; be folded in if there was a way to
+                                                             ; add a constant to an index register 
+                   (flatten-lap (apply #'flatten-lap wrapper-moves)
+                          (opcode :move (operand :constant cache-line-size)
+                                 line-size)
+                          (opcode :move (operand :cvar 'cache)
+                                 cache)
+                          (emit-n-wrapper-compute-primary-cache-location wrappers primary miss-label)
+                          (opcode :move primary location)
+                          (opcode :move location next-location)
+                          (opcode :move (operand :cref cache 0)
+                                 initial-lock-count)
+                                                             ; get the lock-count
+                          (with-lap-registers ((size index))
+                                 (flatten-lap (opcode :move (operand :cvar 'size)
+                                                     size)
+                                        (opcode :label 'continue)
+                                        (opcode :move (operand :i+ location line-size)
+                                               next-location)
+                                        (emit-check-cache-line cache location wrappers 'hit)
+                                        (emit-adjust-location location next-location primary size
+                                               'continue miss-label)
+                                        (opcode :label 'hit)
+                                        (and value (opcode :move (emit-cache-ref cache location)
+                                                          value))
+                                        (emit-lock-count-test initial-lock-count cache 'hit-internal)
+                                        miss
+                                        (opcode :label 'hit-internal)
+                                        hit))))))
+
+
+;;; Cache related lap code 
+
+
+(defun emit-check-1-wrapper-in-cache (cache location wrapper hit-code)
+       (let ((exit-emit-check-1-wrapper-in-cache (make-symbol "exit-emit-check-1-wrapper-in-cache")))
+            (with-lap-registers ((cwrapper vector))
+                   (flatten-lap (opcode :move (emit-cache-ref cache location)
+                                       cwrapper)
+                          (opcode :neq cwrapper wrapper exit-emit-check-1-wrapper-in-cache)
+                          hit-code
+                          (opcode :label exit-emit-check-1-wrapper-in-cache)))))
+
+(defun emit-check-cache-entry (cache location wrapper hit-label)
+       (with-lap-registers ((cwrapper vector))
+              (flatten-lap (opcode :move (emit-cache-ref cache location)
+                                  cwrapper)
+                     (opcode :eq cwrapper wrapper hit-label))))
+
+(defun emit-check-cache-line (cache location wrappers hit-label)
+       (let ((checks (flatten-lap (gathering1 (flattening-lap)
+                                         (iterate ((wrapper (list-elements wrappers)))
+                                                (with-lap-registers ((cwrapper vector))
+                                                       (gather1 (flatten-lap (opcode :move
+                                                                                    (emit-cache-ref
+                                                                                     cache location)
+                                                                                    cwrapper)
+                                                                       (opcode :neq cwrapper wrapper
+                                                                              
+                                                                              '
+                                                                           exit-emit-check-cache-line
+                                                                              )
+                                                                       (opcode :move (operand :i1+ 
+                                                                                            location)
+                                                                              location)))))))))
+            (flatten-lap checks (opcode :go hit-label)
+                   (opcode :label 'exit-emit-check-cache-line))))
+
+(defun emit-lock-count-test (initial-lock-count cache hit-label)
+       
+       ;; jumps to hit-label if cache-lock-count consistent, otherwise, continues 
+       (with-lap-registers ((new-lock-count t))
+              (flatten-lap (opcode :move (operand :cref cache 0)
+                                  new-lock-count)
+                                                             ; get new cache-lock-count
+                     (opcode :fix= new-lock-count initial-lock-count hit-label))))
+
+(defun emit-adjust-location (location next-location primary size cont-label miss-label)
+       (flatten-lap (opcode :move next-location location)
+              (opcode :fix= location size 'at-end-of-cache)
+              (opcode :fix= location primary miss-label)
+              (opcode :go cont-label)
+              (opcode :label 'at-end-of-cache)
+              (opcode :fix= primary (operand :constant (index-value->index 1))
+                     miss-label)
+              (opcode :move (operand :constant (index-value->index 1))
+                     location)
+              (opcode :go cont-label)))

clos/3.5/env.lisp

@@ -0,0 +1,200 @@
+;;;-*-Mode:LISP; Package:(CLOS (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1991 Venue
+;;; All rights reserved.
+;;; *************************************************************************
+;;;
+;;; Basic environmental stuff.
+;;;
+
+(in-package 'clos)
+
+
+
+;;;
+;;;
+;;;
+
+(defgeneric describe-object (object stream))
+
+
+(defmethod describe-object ((object standard-object) stream)
+  (let* ((class (class-of object))
+	 (slotds (slots-to-inspect class object))
+	 (max-slot-name-length 0)
+	 (instance-slotds ())
+	 (class-slotds ())
+	 (other-slotds ()))
+    (flet ((adjust-slot-name-length (name)
+	     (setq max-slot-name-length
+		   (max max-slot-name-length
+			(length (the string (symbol-name name))))))
+	   (describe-slot (name value &optional (allocation () alloc-p))
+	     (if alloc-p
+		 (format stream
+			 "~% ~A ~S ~VT  ~S"
+			 name allocation (+ max-slot-name-length 7) value)
+		 (format stream
+			 "~% ~A~VT  ~S"
+			 name max-slot-name-length value))))
+      ;; Figure out a good width for the slot-name column.
+      (dolist (slotd slotds)
+	(adjust-slot-name-length (slotd-name slotd))
+	(case (slotd-allocation slotd)
+	  (:instance (push slotd instance-slotds))
+	  (:class  (push slotd class-slotds))
+	  (otherwise (push slotd other-slotds))))
+      (setq max-slot-name-length  (min (+ max-slot-name-length 3) 30))
+      (format stream "~%~S is an instance of class ~S:" object class)
+
+      (when instance-slotds
+	(format stream "~% The following slots have :INSTANCE allocation:")
+	(dolist (slotd (nreverse instance-slotds))
+	  (describe-slot (slotd-name slotd)
+			 (slot-value-or-default object (slotd-name slotd)))))
+
+      (when class-slotds
+	(format stream "~% The following slots have :CLASS allocation:")
+	(dolist (slotd (nreverse class-slotds))
+	  (describe-slot (slotd-name slotd)
+			 (slot-value-or-default object (slotd-name slotd)))))
+
+      (when other-slotds 
+	(format stream "~% The following slots have allocation as shown:")
+	(dolist (slotd (nreverse other-slotds))
+	  (describe-slot (slotd-name slotd)
+			 (slot-value-or-default object (slotd-name slotd))
+			 (slotd-allocation slotd))))
+      (values))))
+
+(defmethod slots-to-inspect ((class std-class) (object standard-object))
+  (class-slots class))
+
+;;;
+;;;
+;;;
+(defmethod describe-object ((class class) stream)
+  (flet ((pretty-class (c) (or (class-name c) c)))
+    (macrolet ((ft (string &rest args) `(format stream ,string ,@args)))
+      (ft "~&~S is a class, it is an instance of ~S.~%"
+	  class (pretty-class (class-of class)))
+      (let ((name (class-name class)))
+	(if name
+	    (if (eq class (find-class name nil))
+		(ft "Its proper name is ~S.~%" name)
+		(ft "Its name is ~S, but this is not a proper name.~%" name))
+	    (ft "It has no name (the name is NIL).~%")))
+      (ft "The direct superclasses are: ~:S, and the direct~%~
+           subclasses are: ~:S.  The class precedence list is:~%~S~%~
+           There are ~D methods specialized for this class."
+	  (mapcar #'pretty-class (class-direct-superclasses class))
+	  (mapcar #'pretty-class (class-direct-subclasses class))
+	  (mapcar #'pretty-class (class-precedence-list class))
+	  (length (specializer-methods class))))))
+
+
+
+;;;
+;;; trace-method and untrace-method accept method specs as arguments.  A
+;;; method-spec should be a list like:
+;;;   (<generic-function-spec> qualifiers* (specializers*))
+;;; where <generic-function-spec> should be either a symbol or a list
+;;; of (SETF <symbol>).
+;;;
+;;;   For example, to trace the method defined by:
+;;;
+;;;     (defmethod foo ((x spaceship)) 'ss)
+;;;
+;;;   You should say:
+;;;
+;;;     (trace-method '(foo (spaceship)))
+;;;
+;;;   You can also provide a method object in the place of the method
+;;;   spec, in which case that method object will be traced.
+;;;
+;;; For untrace-method, if an argument is given, that method is untraced.
+;;; If no argument is given, all traced methods are untraced.
+;;;
+(defclass traced-method (method)
+     ((method :initarg :method)
+      (function :initarg :function
+		:reader method-function)
+      (generic-function :initform nil
+			:accessor method-generic-function)))
+
+(defmethod method-lambda-list ((m traced-method))
+  (with-slots (method) m (method-lambda-list method)))
+
+(defmethod method-specializers ((m traced-method))
+  (with-slots (method) m (method-specializers method)))
+
+(defmethod method-qualifiers ((m traced-method))
+  (with-slots (method) m (method-qualifiers method)))
+
+(defmethod method-qualifiers ((m traced-method))
+  (with-slots (method) m (method-qualifiers method)))
+
+(defmethod accessor-method-slot-name ((m traced-method))
+  (with-slots (method) m (accessor-method-slot-name method)))
+
+(defvar *traced-methods* ())
+
+(defun trace-method (spec &rest options)
+  (multiple-value-bind (gf omethod name)
+      (parse-method-or-spec spec)
+    (let* ((tfunction (trace-method-internal (method-function omethod)
+					     name
+					     options))
+	   (tmethod (make-instance 'traced-method
+				   :method omethod
+				   :function tfunction)))
+      (remove-method gf omethod)
+      (add-method gf tmethod)
+      (pushnew tmethod *traced-methods*)
+      tmethod)))
+
+(defun untrace-method (&optional spec)  
+  (flet ((untrace-1 (m)
+	   (let ((gf (method-generic-function m)))
+	     (when gf
+	       (remove-method gf m)
+	       (add-method gf (slot-value m 'method))
+	       (setq *traced-methods* (remove m *traced-methods*))))))
+    (if (not (null spec))
+	(multiple-value-bind (gf method)	    
+	    (parse-method-or-spec spec)
+	  (declare (ignore gf))
+	  (if (memq method *traced-methods*)
+	      (untrace-1 method)
+	      (error "~S is not a traced method?" method)))
+	(dolist (m *traced-methods*) (untrace-1 m)))))
+
+(defun trace-method-internal (ofunction name options)
+  (eval `(untrace ,name))
+  (setf (symbol-function name) ofunction)
+  (eval `(trace ,name ,@options))
+  (symbol-function name))
+
+
+
+
+;(defun compile-method (spec)
+;  (multiple-value-bind (gf method name)
+;      (parse-method-or-spec spec)
+;    (declare (ignore gf))
+;    (compile name (method-function method))
+;    (setf (method-function method) (symbol-function name))))
+
+(defmacro undefmethod (&rest args)
+  #+(or (not :lucid) :lcl3.0)
+  (declare (arglist name {method-qualifier}* specializers))
+  `(undefmethod-1 ',args))
+
+(defun undefmethod-1 (args)
+  (multiple-value-bind (gf method)
+      (parse-method-or-spec args)
+    (when (and gf method)
+      (remove-method gf method)
+      method)))
+

clos/3.5/fin.lisp

@@ -0,0 +1,235 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+
+;;; File converted on 26-Mar-91 10:33:34 from source fin
+;;;. Original source {dsk}<usr>local>users>welch>lisp>clos>rev4>il-format>fin.;3 created 19-Feb-91 16:21:49
+
+;;;. Copyright (c) 1991 by Venue
+
+
+
+
+(in-package "CLOS")
+
+;;; Shadow, Export, Require, Use-package, and Import forms should follow here
+
+
+
+
+
+
+;; 
+
+
+
+;;; FUNCALLABLE INSTANCES
+
+
+
+;; 
+
+
+
+;;; 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 slots)
+       "These are the 'data-slots' which funcallable instances have so that
+   the meta-class funcallable-standard-class can store class, and static
+   slots in them.")
+
+(defmacro funcallable-instance-data-position (data)
+       (if (and (consp data)
+                (eq (car data)
+                    'quote)
+                (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)))
+
+(defun called-fin-without-function nil (error "Attempt to funcall a funcallable-instance without first~%~
+          setting its funcallable-instance-function."))
+
+
+;;; In Xerox Common Lisp, a lexical closure is a pair of an environment and CCODEP.  The environment
+;;; is represented as a block.  There is space in the top 8 bits of the pointers to the CCODE and
+;;; the environment to use to mark the closure as being a FIN. To help the debugger figure out when
+;;; it has found a FIN on the stack, we reserve the last element of the closure environment to use
+;;; to point back to the actual fin. Note that there is code in xerox-low which lets us access the
+;;; fields of compiled-closures and which defines the closure-overlay record.  That code is there
+;;; because there are some clients of it in that file. 
+
+
+
+;; Don't be fooled.  We actually allocate one bigger than this to have a place to store the
+;; backpointer to the fin.  -smL 
+
+
+(defconstant funcallable-instance-closure-size 15)
+
+(defvar *fin-env-type* (type-of (il:\\allocblock (1+ funcallable-instance-closure-size)
+                                       t)))
+
+
+;; Well, Gregor may be too proud to hack xpointers, but bvm and I aren't. -smL
+
+
+(defstruct fin-env-pointer (pointer nil :type il:fullxpointer))
+
+(defun fin-env-fin (fin-env)
+       (fin-env-pointer-pointer (il:\\getbaseptr fin-env (* funcallable-instance-closure-size 2))))
+
+(defun |set fin-env-fin| (fin-env new-value)
+       (il:\\rplptr fin-env (* funcallable-instance-closure-size 2)
+              (make-fin-env-pointer :pointer new-value))
+       new-value)
+
+(defsetf fin-env-fin |set fin-env-fin|)
+
+
+;; The finalization function that will clean up the backpointer from the fin-env to the fin.  This
+;; needs to be careful to not cons at all.  This depends on there being no other finalization
+;; function on compiled-closures, since there is only one finalization function per datatype.  Too
+;; bad.  -smL 
+
+
+(defun finalize-fin (fin)
+       
+       ;; This could use the fn funcallable-instance-p, but if we get here we know that this is a
+       ;; closure, so we can skip that test. 
+       (when (il:fetch (closure-overlay funcallable-instance-p)
+                    il:of fin)
+           (let ((env (il:fetch (il:compiled-closure il:environment)
+                             il:of fin)))
+                (when env
+                    (setq env (il:\\getbaseptr env (* funcallable-instance-closure-size 2)))
+                    (when (typep env 'fin-env-pointer)
+                        (setf (fin-env-pointer-pointer env)
+                              nil)))))
+       nil)
+
+(eval-when (load)
+       
+       ;; Install the above finalization function.
+       (when (fboundp 'finalize-fin)
+           (il:\\set.finalization.function 'il:compiled-closure 'finalize-fin)))
+
+(defun allocate-funcallable-instance-1 nil (let* ((env (il:\\allocblock (1+ 
+                                                                    funcallable-instance-closure-size
+                                                                            )
+                                                              t))
+                                                  (fin (il:make-compiled-closure nil env)))
+                                                 (setf (fin-env-fin env)
+                                                       fin)
+                                                 (il:replace (closure-overlay funcallable-instance-p)
+                                                        il:of fin il:with 't)
+                                                 (set-funcallable-instance-function
+                                                  fin
+                                                  #'(lambda (&rest ignore)
+                                                           (declare (ignore ignore))
+                                                           (called-fin-without-function)))
+                                                 fin))
+
+(xcl:definline funcallable-instance-p (x)
+       (and (typep x 'il:compiled-closure)
+            (il:fetch (closure-overlay funcallable-instance-p)
+                   il:of x)))
+
+(defun set-funcallable-instance-function (fin new)
+       (cond ((not (funcallable-instance-p fin))
+              (error "~S is not a funcallable-instance" fin))
+             ((not (functionp new))
+              (error "~S is not a function." new))
+             ((typep new 'il:compiled-closure)
+              (let* ((fin-env (il:fetch (il:compiled-closure il:environment)
+                                     il:of fin))
+                     (new-env (il:fetch (il:compiled-closure il:environment)
+                                     il:of new))
+                     (new-env-size (if new-env
+                                       (il:\\#blockdatacells new-env)
+                                       0))
+                     (fin-env-size (- funcallable-instance-closure-size (length 
+                                                                            funcallable-instance-data
+                                                                               ))))
+                    (cond ((and new-env (<= new-env-size fin-env-size))
+                           (dotimes (i fin-env-size)
+                               (il:\\rplptr fin-env (* i 2)
+                                      (if (< i new-env-size)
+                                          (il:\\getbaseptr new-env (* i 2))
+                                          nil)))
+                           (setf (compiled-closure-fnheader fin)
+                                 (compiled-closure-fnheader new)))
+                          (t (set-funcallable-instance-function fin (make-trampoline new))))))
+             (t (set-funcallable-instance-function fin (make-trampoline new)))))
+
+(defun make-trampoline (function)
+       #'(lambda (&rest args)
+                (apply function args)))
+
+(defmacro funcallable-instance-data-1 (fin data)
+       `(il:\\getbaseptr (il:fetch (il:compiled-closure il:environment)
+                                il:of
+                                ,fin)
+               (* (- funcallable-instance-closure-size (funcallable-instance-data-position
+                                                        ,data)
+                     1)
+                                                             ; Reserve last element to point back to
+                                                             ; actual FIN! 
+                  2)))
+
+(defsetf funcallable-instance-data-1 (fin data)
+       (new-value)
+       `(il:\\rplptr (il:fetch (il:compiled-closure il:environment)
+                            il:of
+                            ,fin)
+               (* (- funcallable-instance-closure-size (funcallable-instance-data-position
+                                                        ,data)
+                     1)
+                  2)
+               ,new-value))
+
+                                                             ; end of #+Xerox
+
+
+
+;;; 
+
+
+(defmacro fsc-instance-p (fin)
+       `(funcallable-instance-p ,fin))
+
+(defmacro fsc-instance-class (fin)
+       `(wrapper-class (funcallable-instance-data-1 ,fin 'wrapper)))
+
+(defmacro fsc-instance-wrapper (fin)
+       `(funcallable-instance-data-1 ,fin 'wrapper))
+
+(defmacro fsc-instance-slots (fin)
+       `(funcallable-instance-data-1 ,fin 'slots))
+
+(defun allocate-funcallable-instance (wrapper number-of-static-slots)
+       (let ((fin (allocate-funcallable-instance-1))
+             (slots (%allocate-static-slot-storage--class number-of-static-slots)))
+            (setf (fsc-instance-wrapper fin)
+                  wrapper
+                  (fsc-instance-slots fin)
+                  slots)
+            fin))

clos/3.5/fixup.lisp

@@ -0,0 +1,15 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+
+;;;. Copyright (c) 1991 by Venue
+
+(in-package "CLOS")
+
+
+(eval-when (compile load eval)
+       (fix-early-generic-functions)
+       (setq *boot-state* 'complete))
+
+(defun print-std-instance (instance stream depth)
+       (declare (ignore depth))
+       (print-object instance stream))

clos/3.5/fngen.lisp

@@ -0,0 +1,172 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+;;;. Copyright (c) 1991 by Venue
+
+(in-package "CLOS")
+
+
+
+;;; GET-FUNCTION is the main user interface to this code.  If it is called with a lambda expression
+;;; only, it will return a corresponding function. The optional constant-converter argument, can be
+;;; a function which will be called to convert each constant appearing in the lambda to whatever
+;;; value should appear in the function. Whether the returned function is actually compiled depends
+;;; on whether the compiler is present (see COMPILE-LAMBDA) and whether this shape of code was
+;;; precompiled. 
+
+
+(defun get-function (lambda &optional (test-converter #'default-test-converter)
+                           (code-converter #'default-code-converter)
+                           (constant-converter #'default-constant-converter))
+       (apply (get-function-generator lambda test-converter code-converter)
+              (compute-constants lambda constant-converter)))
+
+(defun default-test-converter (form)
+       (if (not (constantp form))
+           form
+           '.constant.))
+
+(defun default-code-converter (form)
+       (if (not (constantp form))
+           form
+           (let ((gensym (gensym)))
+                (values gensym (list gensym)))))
+
+(defun default-constant-converter (form)
+       (and (constantp form)
+            (list (if (and (consp form)
+                           (eq (car form)
+                               'quote))
+                                                             ; This had better
+                      (cadr form)
+                                                             ; do the same as
+                      form))))
+
+                                                             ; EVAL would have.
+
+
+
+;;; *fgens* is a list of all the function generators we have so far.  Each element is a FGEN
+;;; structure as implemented below.  Don't ever touch this list by hand, use STORE-FGEN. 
+
+
+(defvar *fgens* nil)
+
+(defun store-fgen (fgen)
+       (setq *fgens* (nconc *fgens* (list fgen))))
+
+(defun lookup-fgen (test)
+       (find test (the list *fgens*)
+             :key
+             #'fgen-test :test #'equal))
+
+(defun make-fgen (test gensyms generator generator-lambda system)
+       (let ((new (make-array 6)))
+            (setf (svref new 0)
+                  test
+                  (svref new 1)
+                  gensyms
+                  (svref new 2)
+                  generator
+                  (svref new 3)
+                  generator-lambda
+                  (svref new 4)
+                  system)
+            new))
+
+(defun fgen-test (fgen)
+       (svref fgen 0))
+
+(defun fgen-gensyms (fgen)
+       (svref fgen 1))
+
+(defun fgen-generator (fgen)
+       (svref fgen 2))
+
+(defun fgen-generator-lambda (fgen)
+       (svref fgen 3))
+
+(defun fgen-system (fgen)
+       (svref fgen 4))
+
+(defun get-function-generator (lambda test-converter code-converter)
+       (let* ((test (compute-test lambda test-converter))
+              (fgen (lookup-fgen test)))
+             (if fgen
+                 (fgen-generator fgen)
+                 (get-new-function-generator lambda test code-converter))))
+
+(defun get-new-function-generator (lambda test code-converter)
+       (multiple-value-bind (gensyms generator-lambda)
+              (get-new-function-generator-internal lambda code-converter)
+              (let* ((generator (compile-lambda generator-lambda))
+                     (fgen (make-fgen test gensyms generator generator-lambda nil)))
+                    (store-fgen fgen)
+                    generator)))
+
+(defun get-new-function-generator-internal (lambda code-converter)
+       (multiple-value-bind (code gensyms)
+              (compute-code lambda code-converter)
+              (values gensyms `(lambda ,gensyms #',code))))
+
+(defun compute-test (lambda test-converter)
+       (walk-form lambda nil #'(lambda (f c e)
+                                      (declare (ignore e))
+                                      (if (neq c :eval)
+                                          f
+                                          (let ((converted (funcall test-converter f)))
+                                               (values converted (neq converted f)))))))
+
+(defun compute-code (lambda code-converter)
+       (let ((gensyms nil))
+            (values (walk-form lambda nil #'(lambda (f c e)
+                                                   (declare (ignore e))
+                                                   (if (neq c :eval)
+                                                       f
+                                                       (multiple-value-bind
+                                                        (converted gens)
+                                                        (funcall code-converter f)
+                                                        (when gens
+                                                            (setq gensyms (append gensyms gens)))
+                                                        (values converted (neq converted f))))))
+                   gensyms)))
+
+(defun compute-constants (lambda constant-converter)
+       (macrolet ((appending nil `(let ((result nil))
+                                       (values #'(lambda (value)
+                                                        (setq result (append result value)))
+                                              #'(lambda nil result)))))
+              (gathering1 (appending)
+                     (walk-form lambda nil #'(lambda (f c e)
+                                                    (declare (ignore e))
+                                                    (if (neq c :eval)
+                                                        f
+                                                        (let ((consts (funcall constant-converter f))
+                                                              )
+                                                             (if consts
+                                                                 (progn (gather1 consts)
+                                                                        (values f t))
+                                                                 f))))))))
+
+
+;;; 
+
+
+(defmacro
+ precompile-function-generators
+ (&optional system)
+ (make-top-level-form
+  `(precompile-function-generators ,system)
+  '(load)
+  `(progn ,@(gathering1 (collecting)
+                   (dolist (fgen *fgens*)
+                       (when (or (null (fgen-system fgen))
+                                 (eq (fgen-system fgen)
+                                     system))
+                           (gather1 `(load-function-generator ',(fgen-test fgen)
+                                            ',(fgen-gensyms fgen)
+                                            #',(fgen-generator-lambda fgen)
+                                            ',(fgen-generator-lambda fgen)
+                                            ',system))))))))
+
+(defun load-function-generator (test gensyms generator generator-lambda system)
+       (store-fgen (make-fgen test gensyms generator generator-lambda system)))

clos/3.5/fsc.lisp

@@ -0,0 +1,72 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+;;;. Copyright (c) 1991 by Venue
+
+
+(in-package "CLOS")
+
+
+;;; This file contains the
+;;; definition of the FUNCALLABLE-STANDARD-CLASS metaclass.  Much of the implementation of this
+;;; metaclass is actually defined on the class STD-CLASS.  What appears in this file is a modest
+;;; number of simple methods related to the low-level differences in the implementation of standard
+;;; and funcallable-standard instances. As it happens, none of these differences are the ones
+;;; reflected in the MOP specification; STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS share all
+;;; their specified methods at STD-CLASS. workings of this metaclass and the standard-class
+;;; metaclass. 
+
+
+(defmethod wrapper-fetcher ((class funcallable-standard-class))
+       'fsc-instance-wrapper)
+
+(defmethod slots-fetcher ((class funcallable-standard-class))
+       'fsc-instance-slots)
+
+(defmethod raw-instance-allocator ((class funcallable-standard-class))
+       'allocate-funcallable-instance-1)
+
+
+;;; 
+
+
+(defmethod check-super-metaclass-compatibility ((fsc funcallable-standard-class)
+                                                (class standard-class))
+       (null (wrapper-instance-slots-layout (class-wrapper class))))
+
+(defmethod allocate-instance ((class funcallable-standard-class)
+                              &rest initargs)
+       (declare (ignore initargs))
+       (unless (class-finalized-p class)
+              (finalize-inheritance class))
+       (let ((class-wrapper (class-wrapper class)))
+            (allocate-funcallable-instance class-wrapper (class-no-of-instance-slots class))))
+
+(defmethod make-reader-method-function ((class funcallable-standard-class)
+                                        slot-name)
+       (make-std-reader-method-function slot-name))
+
+(defmethod make-writer-method-function ((class funcallable-standard-class)
+                                        slot-name)
+       (make-std-writer-method-function slot-name))
+
+                                                             ; See the comment about
+                                                             ; reader-function--std and
+                                                             ; writer-function--sdt.
+                                                             ; (define-function-template
+                                                             ; reader-function--fsc () '(slot-name)
+                                                             ; `(function (lambda (instance)
+                                                             ; (slot-value-using-class
+                                                             ; (wrapper-class (get-wrapper
+                                                             ; instance)) instance slot-name))))
+                                                             ; (define-function-template
+                                                             ; writer-function--fsc () '(slot-name)
+                                                             ; `(function (lambda (nv instance)
+                                                             ; (setf (slot-value-using-class
+                                                             ; (wrapper-class (get-wrapper
+                                                             ; instance)) instance slot-name) nv))))
+                                                             ; (eval-when (load)
+                                                             ; (pre-make-templated-function-constructor
+                                                             ; reader-function--fsc)
+                                                             ; (pre-make-templated-function-constructor
+                                                             ; writer-function--fsc)) 
+

clos/3.5/init.lisp

@@ -0,0 +1,183 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+;;;. Copyright (c) 1991 by Venue
+
+(in-package "CLOS")
+
+;;; this file defines the
+;;; initialization and related protocols. 
+
+
+(defmethod make-instance ((class std-class)
+                          &rest initargs)
+       (unless (class-finalized-p class)
+              (finalize-inheritance class))
+       (setq initargs (default-initargs class initargs))
+       (when initargs
+           (when (and (eq *boot-state* 'complete)
+                      (let ((tail initargs))
+                           (loop (unless tail (return t))
+                                 (when (eq (car tail)
+                                           ':allow-other-keys)
+                                       (return nil))
+                                 (setq tail (cddr tail)))))
+               (check-initargs-1 class initargs (append (compute-applicable-methods 
+                                                               #'allocate-instance (list class))
+                                                       (compute-applicable-methods
+                                                        #'initialize-instance
+                                                        (list (class-prototype class)))
+                                                       (compute-applicable-methods
+                                                        #'shared-initialize
+                                                        (list (class-prototype class)
+                                                              t))))))
+       (let ((instance (apply #'allocate-instance class initargs)))
+            (apply #'initialize-instance instance initargs)
+            instance))
+
+(defmethod make-instance ((class-name symbol)
+                          &rest initargs)
+       (apply #'make-instance (find-class class-name)
+              initargs))
+
+(defvar *default-initargs-flag* (list nil))
+
+(defmethod default-initargs ((class std-class)
+                             supplied-initargs)
+       
+       ;; This implementation of default initargs is critically dependent on all-default-initargs
+       ;; not having any duplicate initargs in it. 
+       (let ((all-default (class-default-initargs class))
+             (miss *default-initargs-flag*))
+            (flet ((getf* (plist key)
+                          (do nil
+                              ((null plist)
+                               miss)
+                            (if (eq (car plist)
+                                    key)
+                                (return (cadr plist))
+                                (setq plist (cddr plist))))))
+                  (labels ((default-1 (tail)
+                                  (if (null tail)
+                                      nil
+                                      (if (eq (getf* supplied-initargs (caar tail))
+                                              miss)
+                                          (list* (caar tail)
+                                                 (funcall (cadar tail))
+                                                 (default-1 (cdr tail)))
+                                          (default-1 (cdr tail))))))
+                         (append supplied-initargs (default-1 all-default))))))
+
+(defmethod initialize-instance ((instance standard-object)
+                                &rest initargs)
+       (apply #'shared-initialize instance t initargs))
+
+(defmethod reinitialize-instance ((instance standard-object)
+                                  &rest initargs)
+       (when initargs
+           (when (eq *boot-state* 'complete)
+               (check-initargs-1 (class-of instance)
+                      initargs
+                      (append (compute-applicable-methods #'reinitialize-instance (list instance))
+                             (compute-applicable-methods #'shared-initialize (list instance t))))))
+       (apply #'shared-initialize instance nil initargs)
+       instance)
+
+(defmethod update-instance-for-different-class ((previous standard-object)
+                                                (current standard-object)
+                                                &rest initargs)
+       (when initargs
+           (check-initargs-1 (class-of current)
+                  initargs
+                  (append (compute-applicable-methods #'update-instance-for-different-class
+                                 (list previous current))
+                         (compute-applicable-methods #'shared-initialize (list current t)))))
+       
+       ;; First we must compute the newly added slots.  The spec defines newly added slots as "those
+       ;; local slots for which no slot of the same name exists in the previous class." 
+       (let ((added-slots 'nil)
+             (current-slotds (class-slots (class-of current)))
+             (previous-slot-names (mapcar #'slotd-name (class-slots (class-of previous)))))
+            (dolist (slotd current-slotds)
+                (if (and (not (memq (slotd-name slotd)
+                                    previous-slot-names))
+                         (eq (slotd-allocation slotd)
+                             ':instance))
+                    (push (slotd-name slotd)
+                          added-slots)))
+            (apply #'shared-initialize current added-slots initargs)))
+
+(defmethod update-instance-for-redefined-class ((instance standard-object)
+                                                added-slots discarded-slots property-list &rest 
+                                                initargs)
+       (declare (ignore discarded-slots property-list))
+       (when initargs
+           (check-initargs-1 (class-of instance)
+                  initargs
+                  (append (compute-applicable-methods #'update-instance-for-redefined-class
+                                 (list instance))
+                         (compute-applicable-methods #'shared-initialize (list instance nil)))))
+       (apply #'shared-initialize instance added-slots initargs))
+
+(defmethod shared-initialize ((instance standard-object)
+                              slot-names &rest initargs)
+       
+       ;; initialize the instance's slots in a two step process 1) A slot for which one of the
+       ;; initargs in initargs can set the slot, should be set by that initarg.  If more than one
+       ;; initarg in initargs can set the slot, the leftmost one should set it. 2) Any slot not set
+       ;; by step 1, may be set from its initform by step 2.  Only those slots specified by the
+       ;; slot-names argument are set.  If slot-names is: T any slot not set in step 1 is set from
+       ;; its initform <list of slot names> any slot in the list, and not set in step 1 is set from
+       ;; its initform () no slots are set from initforms 
+       (let* ((class (class-of instance))
+              (slotds (class-slots class)))
+             (dolist (slotd slotds)
+                 (let ((slot-name (slotd-name slotd))
+                       (slot-initargs (slotd-initargs slotd)))
+                      (flet ((from-initargs nil 
+
+                                    ;; Try to initialize the slot from one of the initargs. If we
+                                    ;; succeed return T, otherwise return nil. 
+                                    (doplist (initarg val)
+                                           initargs
+                                           (when (memq initarg slot-initargs)
+                                               (setf (slot-value instance slot-name)
+                                                     val)
+                                               (return 't))))
+                             (from-initforms nil 
+
+                                    ;; Try to initialize the slot from its initform.  This returns
+                                    ;; no meaningful value. 
+                                    (if (and slot-names (or (eq slot-names 't)
+                                                            (memq slot-name slot-names))
+                                             (not (slot-boundp instance slot-name)))
+                                        (let ((initfunction (slotd-initfunction slotd)))
+                                             (when initfunction
+                                                 (setf (slot-value instance slot-name)
+                                                       (funcall initfunction)))))))
+                            (or (from-initargs)
+                                (from-initforms))))))
+       instance)
+
+
+;;; if initargs are valid return nil, otherwise signal an error 
+
+
+(defun check-initargs-1 (class initargs methods)
+       (let ((legal (apply #'append (mapcar #'slotd-initargs (class-slots class)))))
+            (unless (getf initargs :allow-other-keys)
+                
+                ;; Add to the set of slot-filling initargs the set of initargs that are accepted by
+                ;; the methods.  If at any point we come across &allow-other-keys, we can just quit.
+                (dolist (method methods)
+                    (multiple-value-bind (keys allow-other-keys)
+                        (function-keywords method)
+                      (when allow-other-keys (return-from check-initargs-1 nil))
+                      (setq legal (append keys legal))))
+                
+                ;; Now check the supplied-initarg-names and the default initargs against the total
+                ;; set that we know are legal. 
+                (doplist (key val)
+                       initargs
+                       (unless (memq key legal)
+                           (error "Invalid initialization argument ~S for class ~S" key (class-name
+                                                                                         class)))))))

clos/3.5/lap.lisp

@@ -0,0 +1,364 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+
+;;;. Copyright (c) 1991 by Venue
+
+(in-package "CLOS")
+
+;;; This file defines CLOS's interface to the LAP mechanism. The file is divided into two parts.  The
+;;; first part defines the interface used by CLOS to create abstract LAP code vectors.  CLOS never
+;;; creates lists that represent LAP code directly, it always calls this mechanism to do so. This
+;;; provides a layer of error checking on the LAP code before it gets to the implementation-specific
+;;; assembler.  Note that this error checking is syntactic only, but even so is useful to have. 
+;;; Because of it, no specific LAP assembler should worry itself with checking the syntax of the LAP
+;;; code. The second part of the file defines the LAP assemblers for each CLOS port. These are
+;;; included together in the same file to make it easier to change them all should some random
+;;; change be made in the LAP mechanism. 
+
+
+(defvar *make-lap-closure-generator*)
+
+(defvar *precompile-lap-closure-generator*)
+
+(defvar *lap-in-lisp*)
+
+(defun make-lap-closure-generator (closure-variables arguments iregs vregs tregs lap-code)
+       (funcall *make-lap-closure-generator* closure-variables arguments iregs vregs tregs lap-code))
+
+(defmacro precompile-lap-closure-generator (cvars args i-regs v-regs t-regs lap)
+       (funcall *precompile-lap-closure-generator* cvars args i-regs v-regs t-regs lap))
+
+(defmacro lap-in-lisp (cvars args iregs vregs tregs lap)
+       (declare (ignore cvars args))
+       `(locally (declare (optimize (safety 0)
+                                 (speed 3)))
+               ,(make-lap-prog iregs vregs tregs (flatten-lap lap (opcode :label 'exit-lap-in-lisp)))
+               ))
+
+
+;;; The following functions and macros are used by CLOS when generating LAP code: GENERATING-LAP
+;;; WITH-LAP-REGISTERS ALLOCATE-REGISTER DEALLOCATE-REGISTER LAP-FLATTEN OPCODE OPERAND 
+
+
+(proclaim '(special *generating-lap*))
+
+                                                             ; CAR   - alist of free registers CADR 
+                                                             ; - alist of allocated registers CADDR
+                                                             ; - max reg number allocated in each
+                                                             ; alist, the entries have the form: 
+                                                             ; (type . (:REG <n>)) 
+
+
+
+;;; This goes around the generation of any lap code.  <body> should return a lap code sequence, this
+;;; macro will take care of converting that to a lap closure generator. 
+
+
+(defmacro generating-lap (closure-variables arguments &body body)
+       `(let* ((*generating-lap* (list nil nil -1)))
+              (finalize-lap-generation nil ,closure-variables ,arguments (progn ,@body))))
+
+(defmacro generating-lap-in-lisp (closure-variables arguments &body body)
+       `(let* ((*generating-lap* (list nil nil -1)))
+              (finalize-lap-generation t ,closure-variables ,arguments (progn ,@body))))
+
+
+;;; Each register specification looks like: (<var> <type> &key :reuse <other-reg>) 
+
+
+(defmacro with-lap-registers (register-specifications &body body)
+       
+       ;; Given that, for now, there is only one keyword argument and that, for now, we do no error
+       ;; checking, we can be pretty sleazy about how this works. 
+       (flet ((make-allocations
+               nil
+               (gathering1 (collecting)
+                      (dolist (spec register-specifications)
+                          (gather1 `(,(car spec)
+                                     (or ,(cadddr spec)
+                                         (allocate-register ',(cadr spec))))))))
+              (make-deallocations nil (gathering1
+                                       (collecting)
+                                       (dolist (spec register-specifications)
+                                           (gather1 `(unless ,(cadddr spec)
+                                                         (deallocate-register ,(car spec))))))))
+             `(let ,(make-allocations)
+                   (multiple-value-prog1 (progn ,@body)
+                          ,@(make-deallocations)))))
+
+(defun allocate-register (type)
+       (destructuring-bind (free allocated)
+              *generating-lap*
+              (let ((entry (assoc type free)))
+                   (cond (entry (setf (car *generating-lap*)
+                                      (delete entry free)
+                                      (cadr *generating-lap*)
+                                      (cons entry allocated))
+                                (cdr entry))
+                         (t (let ((new `(,type :reg ,(incf (caddr *generating-lap*)))))
+                                 (setf (cadr *generating-lap*)
+                                       (cons new allocated))
+                                 (cdr new)))))))
+
+(defun deallocate-register (reg)
+       (let ((entry (rassoc reg (cadr *generating-lap*))))
+            (unless entry (error "Attempt to free an unallocated register."))
+            (push entry (car *generating-lap*))
+            (setf (cadr *generating-lap*)
+                  (delete entry (cadr *generating-lap*)))))
+
+(defvar *precompiling-lap* nil)
+
+(defun finalize-lap-generation (in-lisp-p closure-variables arguments lap-code)
+       (when (cadr *generating-lap*)
+             (error "Registers still allocated when lap being finalized."))
+       (let ((iregs nil)
+             (vregs nil)
+             (tregs nil))
+            (dolist (entry (car *generating-lap*))
+                (ecase (car entry)
+                    (index (push (caddr entry)
+                                 iregs))
+                    (vector (push (caddr entry)
+                                  vregs))
+                    ((t) (push (caddr entry)
+                               tregs))))
+            (cond (in-lisp-p (macroexpand `(lap-in-lisp ,closure-variables ,arguments ,iregs
+                                                  ,vregs
+                                                  ,tregs
+                                                  ,lap-code)))
+                  (*precompiling-lap* (values closure-variables arguments iregs vregs tregs lap-code)
+                         )
+                  (t (make-lap-closure-generator closure-variables arguments iregs vregs tregs 
+                            lap-code)))))
+
+(defun flatten-lap (&rest opcodes-or-sequences)
+       (let ((result nil))
+            (dolist (opcode-or-sequence opcodes-or-sequences result)
+                (cond ((null opcode-or-sequence))
+                      ((not (consp (car opcode-or-sequence)))
+                                                             ; its an opcode
+                       (setf result (append result (list opcode-or-sequence))))
+                      (t (setf result (append result opcode-or-sequence)))))))
+
+(defmacro flattening-lap nil '(let ((result nil))
+                                   (values #'(lambda (value)
+                                                    (push value result))
+                                          #'(lambda nil (apply #'flatten-lap (reverse result))))))
+
+
+;;; This code deals with the syntax of the individual opcodes and operands. The first two of these
+;;; variables are documented to all ports.  They are lists of the symbols which name the lap opcodes
+;;; and operands.  They can be useful to determine whether a port has implemented all the required
+;;; opcodes and operands. The third of these variables is for use of the emitter only. 
+
+
+(defvar *lap-operands* nil)
+
+(defvar *lap-opcodes* nil)
+
+(defvar *lap-emitters* (make-hash-table :test #'eq :size 30))
+
+(defun opcode (name &rest args)
+       (let ((emitter (gethash name *lap-emitters*)))
+            (if emitter
+                (apply emitter args)
+                (error "No opcode named ~S." name))))
+
+(defun operand (name &rest args)
+       (let ((emitter (gethash name *lap-emitters*)))
+            (if emitter
+                (apply emitter args)
+                (error "No operand named ~S." name))))
+
+(defmacro defopcode (name types)
+       (let ((fn-name (symbol-append "LAP Opcode " name *the-clos-package*))
+             (lambda-list (mapcar #'(lambda (x)
+                                           (declare (ignore x))
+                                           (gensym))
+                                 types)))
+            `(progn (eval-when (load eval)
+                           (load-defopcode ',name ',fn-name))
+                    (defun ,fn-name ,lambda-list (defopcode-1 ',name ',types ,@lambda-list)))))
+
+(defmacro defoperand (name types)
+       (let ((fn-name (symbol-append "LAP Operand " name *the-clos-package*))
+             (lambda-list (mapcar #'(lambda (x)
+                                           (declare (ignore x))
+                                           (gensym))
+                                 types)))
+            `(progn (eval-when (load eval)
+                           (load-defoperand ',name ',fn-name))
+                    (defun ,fn-name ,lambda-list (defoperand-1 ',name ',types ,@lambda-list)))))
+
+(defun load-defopcode (name fn-name)
+       (if* (memq name *lap-operands*)
+            (error "LAP opcodes and operands must have disjoint names.")
+            (setf (gethash name *lap-emitters*)
+                  fn-name)
+            (pushnew name *lap-opcodes*)))
+
+(defun load-defoperand (name fn-name)
+       (if* (memq name *lap-opcodes*)
+            (error "LAP opcodes and operands must have disjoint names.")
+            (setf (gethash name *lap-emitters*)
+                  fn-name)
+            (pushnew name *lap-operands*)))
+
+(defun defopcode-1 (name operand-types &rest args)
+       (iterate ((arg (list-elements args))
+                 (type (list-elements operand-types)))
+              (check-opcode-arg name arg type))
+       (cons name (copy-list args)))
+
+(defun defoperand-1 (name operand-types &rest args)
+       (iterate ((arg (list-elements args))
+                 (type (list-elements operand-types)))
+              (check-operand-arg name arg type))
+       (cons name (copy-list args)))
+
+(defun check-opcode-arg (name arg type)
+       (labels ((usual (x)
+                       (and (consp arg)
+                            (eq (car arg)
+                                x)))
+                (check (x)
+                       (ecase x
+                           ((:reg :cdr :constant :iref :cvar :arg :lisp :lisp-variable) (usual x))
+                           (:label (symbolp arg))
+                           (:operand (and (consp arg)
+                                          (memq (car arg)
+                                                *lap-operands*))))))
+              (unless (if (consp type)
+                          (if (eq (car type)
+                                  'or)
+                              (some #'check (cdr type))
+                              (error "What type is this?"))
+                          (check type))
+                     (error "The argument ~S to the opcode ~A is not of type ~S." arg name type))))
+
+(defun check-operand-arg (name arg type)
+       (flet ((check (x)
+                     (ecase x
+                         (:symbol (symbolp arg))
+                         (:register-number (and (integerp arg)
+                                                (>= x 0)))
+                         (:t t)
+                         (:reg (and (consp arg)
+                                    (eq (car arg)
+                                        :reg)))
+                         (:fixnum (typep arg 'fixnum)))))
+             (unless (if (consp type)
+                         (if (eq (car type)
+                                 'or)
+                             (some #'check (cdr type))
+                             (error "What type is this?"))
+                         (check type))
+                    (error "The argument ~S to the operand ~A is not of type ~S." arg name type))))
+
+
+;;; The actual opcodes. 
+
+
+(defopcode :break nil)
+
+                                                             ; For debugging only.  Not
+
+
+(defopcode :beep nil)
+
+                                                             ; all ports are required to
+
+
+(defopcode :print (:reg))
+
+                                                             ; implement this.
+
+
+(defopcode :move (:operand (or :reg :iref :cdr :lisp-variable)))
+
+(defopcode :eq ((or :reg :constant)
+                (or :reg :constant)
+                :label))
+
+(defopcode :neq ((or :reg :constant)
+                 (or :reg :constant)
+                 :label))
+
+(defopcode :fix= ((or :reg :constant)
+                  (or :reg :constant)
+                  :label))
+
+(defopcode :izerop (:reg :label))
+
+(defopcode :std-instance-p (:reg :label))
+
+(defopcode :fsc-instance-p (:reg :label))
+
+(defopcode :built-in-instance-p (:reg :label))
+
+(defopcode :structure-instance-p (:reg :label))
+
+(defopcode :jmp ((or :reg :constant)))
+
+(defopcode :label (:label))
+
+(defopcode :go (:label))
+
+(defopcode :return ((or :reg :constant)))
+
+(defopcode :exit-lap-in-lisp nil)
+
+
+;;; The actual operands. 
+
+
+(defoperand :reg (:register-number))
+
+(defoperand :cvar (:symbol))
+
+(defoperand :arg (:symbol))
+
+(defoperand :cdr (:reg))
+
+(defoperand :constant (:t))
+
+(defoperand :std-wrapper (:reg))
+
+(defoperand :fsc-wrapper (:reg))
+
+(defoperand :built-in-wrapper (:reg))
+
+(defoperand :structure-wrapper (:reg))
+
+(defoperand :other-wrapper (:reg))
+
+(defoperand :std-slots (:reg))
+
+(defoperand :fsc-slots (:reg))
+
+(defoperand :cref (:reg :fixnum))
+
+(defoperand :iref (:reg :reg))
+
+(defoperand :iset (:reg :reg :reg))
+
+(defoperand :i1+ (:reg))
+
+(defoperand :i+ (:reg :reg))
+
+(defoperand :i- (:reg :reg))
+
+(defoperand :ilogand (:reg :reg))
+
+(defoperand :ilogxor (:reg :reg))
+
+(defoperand :ishift (:reg :fixnum))
+
+(defoperand :lisp (:t))
+
+(defoperand :lisp-variable (:symbol))
+
+
+;;; LAP tests (there need to be a lot more of these) 
+

clos/3.5/low.lisp

@@ -0,0 +1,194 @@
+
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+
+;;; File converted on 26-Mar-91 10:29:45 from source low
+;;;. Original source {dsk}<usr>local>users>welch>lisp>clos>rev4>il-format>low.;4 created 27-Feb-91 17:16:47
+
+;;;. Copyright (c) 1991 by Venue
+
+
+
+(in-package "CLOS")
+
+;;; Shadow, Export, Require, Use-package, and Import forms should follow here
+
+
+
+;;;
+;;;*************************************************************************
+;;;Copyright (c) 1991 Venue
+;;; This file contains portable versions of low-level functions and macros which are ripe for
+;;; implementation specific customization.  None of the code in this file *has* to be customized for
+;;; a particular Common Lisp implementation. Moreover, in some implementations it may not make any
+;;; sense to customize some of this code. ks. 
+
+
+(defmacro %svref (vector index)
+       `(locally (declare (optimize (speed 3)
+                                 (safety 0))
+                        (inline svref))
+               (svref (the simple-vector ,vector)
+                      (the fixnum ,index))))
+
+(defsetf %svref (vector index)
+       (new-value)
+       `(locally (declare (optimize (speed 3)
+                                 (safety 0))
+                        (inline svref))
+               (setf (svref (the simple-vector ,vector)
+                            (the fixnum ,index))
+                     ,new-value)))
+
+
+;;; without-interrupts OK, Common Lisp doesn't have this and for good reason.  But For all of the
+;;; Common Lisp's that CLOS runs on today, there is a meaningful way to implement this.  WHAT I MEAN
+;;; IS: I want the body to be evaluated in such a way that no other code that is running CLOS can be
+;;; run during that evaluation.  I agree that the body won't take *long* to evaluate.  That is to
+;;; say that I will only use without interrupts around relatively small computations. INTERRUPTS-ON
+;;; should turn interrupts back on if they were on. INTERRUPTS-OFF should turn interrupts back off.
+;;; These are only valid inside the body of WITHOUT-INTERRUPTS. OK? 
+
+
+
+;;; AKW: IT'S CALLED, BUT NEVER REALLY USED, SO I'VE REPLACED IT WITH THE PROGN. IF WE REALLY NEED
+;;; IT, CAN BE TRIVIALLY DONE WITH IL:MONITORS
+
+
+(defmacro without-interrupts (&body body)
+       `(progn ,.body))
+
+
+;;; Very Low-Level representation of instances with meta-class standard-class. 
+
+
+(defmacro std-instance-wrapper (x)
+       `(%std-instance-wrapper ,x))
+
+(defmacro std-instance-slots (x)
+       `(%std-instance-slots ,x))
+
+(defun print-std-instance (instance stream depth)
+                                                             ; A temporary definition used
+       (declare (ignore depth))
+                                                             ; for debugging the bootstrap
+       (printing-random-thing (instance stream)
+                                                             ; code of CLOS (See high.lisp).
+              (format stream "#<std-instance>")))
+
+(defmacro %allocate-instance--class (no-of-slots)
+       `(let ((instance (%%allocate-instance--class)))
+             (%allocate-instance--class-1 ,no-of-slots instance)
+             instance))
+
+(defmacro %allocate-instance--class-1 (no-of-slots instance)
+       (once-only (instance)
+              `(progn (setf (std-instance-slots ,instance)
+                            (%allocate-static-slot-storage--class ,no-of-slots)))))
+
+
+;;; This is the value that we stick into a slot to tell us that it is unbound. It may seem gross,
+;;; but for performance reasons, we make this an interned symbol.  That means that the fast check to
+;;; see if a slot is unbound is to say (EQ <val> '..SLOT-UNBOUND..).  That is considerably faster
+;;; than looking at the value of a special variable.  Be careful, there are places in the code which
+;;; actually use ..slot-unbound.. rather than this variable.  So much for modularity 
+
+
+(defvar *slot-unbound* '..slot-unbound..)
+
+(defmacro %allocate-static-slot-storage--class (no-of-slots)
+       `(make-array ,no-of-slots :initial-element *slot-unbound*))
+
+(defmacro std-instance-class (instance)
+       `(wrapper-class (std-instance-wrapper ,instance)))
+
+
+;; 
+
+
+
+;;; FUNCTION-ARGLIST
+
+
+
+;; 
+
+
+
+;;; [COMMENTED OUT AKW. NEVER CALLED] Given something which is functionp, function-arglist should
+;;; return the argument list for it.  CLOS does not count on having this available, but
+;;; MAKE-SPECIALIZABLE works much better if it is available.  Versions of function-arglist for each
+;;; specific port of clos should be put in the appropriate xxx-low file. This is what it should look
+;;; like: 
+
+
+                                                             ; (defun function-arglist (function)
+                                                             ; (<system-dependent-arglist-function>
+                                                             ; function)) 
+
+
+
+;; (FUNCTIONS CLOS::FUNCTION-PRETTY-ARGLIST) (SETFS CLOS::FUNCTION-PRETTY-ARGLIST) (FUNCTIONS
+;; CLOS::SET-FUNCTION-PRETTY-ARGLIST)
+
+
+
+;;; set-function-name When given a function should give this function the name <new-name>. Note that
+;;; <new-name> is sometimes a list.  Some lisps get the upset in the tummy when they start thinking
+;;; about functions which have lists as names.  To deal with that there is set-function-name-intern
+;;; which takes a list spec for a function name and turns it into a symbol if need be. When given a
+;;; funcallable instance, set-function-name MUST side-effect that FIN to give it the name.  When
+;;; given any other kind of function set-function-name is allowed to return new function which is
+;;; the 'same' except that it has the name. In all cases, set-function-name must return the new (or
+;;; same) function. 
+
+
+(defun set-function-name #'new-name (declare (notinline set-function-name-1 intern-function-name))
+       (set-function-name-1 function (intern-function-name new-name)
+              new-name))
+
+(defun set-function-name-1 (fn new-name uninterned-name)
+       (cond ((typep fn 'il:compiled-closure)
+              (il:\\rplptr (compiled-closure-fnheader fn)
+                     4 new-name)
+              (when (and (consp uninterned-name)
+                         (eq (car uninterned-name)
+                             'method))
+                  (let ((debug (si::compiled-function-debugging-info fn)))
+                       (when debug
+                           (setf (cdr debug)
+                                 uninterned-name)))))
+             (t nil))
+       fn)
+
+(defun intern-function-name (name)
+       (cond ((symbolp name)
+              name)
+             ((listp name)
+              (intern (let ((*package* *the-clos-package*)
+                            (*print-case* :upcase)
+                            (*print-gensym* 't))
+                           (format nil "~S" name))
+                     *the-clos-package*))))
+
+
+;;; COMPILE-LAMBDA This is like the Common Lisp function COMPILE.  In fact, that is what it ends up
+;;; calling.   
+
+
+(defun compile-lambda (lambda &rest desirability)
+       (declare (ignore desirability))
+       (compile nil lambda))
+
+(defmacro precompile-random-code-segments (&optional system)
+  `(progn
+     (precompile-function-generators ,system)
+     (precompile-dfun-constructors ,system)))
+
+
+
+(defun record-definition (type spec &rest args)
+  (declare (ignore type spec args))
+  ())
+
+(defun doctor-dfun-for-the-debugger (gf dfun) (declare (ignore gf)) dfun)

clos/3.5/low2.lisp

@@ -0,0 +1,144 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+
+;;; File converted on 26-Mar-91 10:30:44 from source xerox-low
+;;;. Original source {dsk}<usr>local>users>welch>lisp>clos>rev4>il-format>xerox-low.;3 created 27-Feb-91 16:37:43
+
+;;;. Copyright (c) 1991 by Venue
+
+
+
+(in-package "CLOS")
+
+;;; Shadow, Export, Require, Use-package, and Import forms should follow here
+
+
+
+;;; ************************************************************************* This is the 1100
+;;; (Xerox version) of the file portable-low. 
+
+
+(defmacro load-time-eval (form)
+       `(il:loadtimeconstant ,form))
+
+
+;;; make the pointer from an instance to its class wrapper be an xpointer. this prevents instance
+;;; creation from spending a lot of time incrementing the large refcount of the class-wrapper.  This
+;;; is safe because there will always be some other pointer to the wrapper to keep it around. 
+
+
+(defstruct (std-instance (:predicate std-instance-p)
+                  (:conc-name %std-instance-)
+                  (:constructor %%allocate-instance--class nil)
+                  (:fast-accessors t)
+                  (:print-function %print-std-instance))
+       (wrapper nil :type il:fullxpointer)
+       (slots nil))
+
+(defun %print-std-instance (instance &optional stream depth)
+       
+       ;; See the IRM, section 25.3.3.  Unfortunatly, that documentation is not correct.  In
+       ;; particular, it makes no mention of the third argument. 
+       (cond ((streamp stream)
+              
+              ;; Use the standard CLOS printing method, then return T to tell the printer that we
+              ;; have done the printing ourselves. 
+              (print-std-instance instance stream depth)
+              t)
+             (t 
+                ;; Internal printing (again, see the IRM section 25.3.3). Return a list containing
+                ;; the string of characters that would be printed, if the object were being printed
+                ;; for real. 
+                (list (with-output-to-string (stream)
+                             (print-std-instance instance stream depth))))))
+
+
+;; 
+
+
+
+;;; FUNCTION-ARGLIST
+
+
+
+;; 
+
+
+(defun function-arglist (x)
+       
+       ;; Xerox lisp has the bad habit of returning a symbol to mean &rest, and strings instead of
+       ;; symbols.  How silly. 
+       (let ((arglist (il:arglist x)))
+            (when (symbolp arglist)
+                
+                ;; This could be due to trying to extract the arglist of an interpreted function
+                ;; (though why that should be hard is beyond me).  On the other hand, if the
+                ;; function is compiled, it helps to ask for the "smart" arglist. 
+                (setq arglist (if (consp (symbol-function x))
+                                  (second (symbol-function x))
+                                  (il:arglist x t))))
+            (if (symbolp arglist)
+                
+                ;; Probably never get here, but just in case
+                (list '&rest 'rest)
+                
+                ;; Make sure there are no strings where there should be symbols
+                (if (some #'stringp arglist)
+                    (mapcar #'(lambda (a)
+                                     (if (symbolp a)
+                                         a
+                                         (intern a)))
+                           arglist)
+                    arglist))))
+
+(defun printing-random-thing-internal (thing stream)
+       (let ((*print-base* 8))
+            (princ (il:\\hiloc thing)
+                   stream)
+            (princ "," stream)
+            (princ (il:\\loloc thing)
+                   stream)))
+
+(defun record-definition (name type &optional parent-name parent-type)
+       (declare (ignore type parent-name))
+       nil)
+
+
+;;; FIN uses this too! 
+
+
+(eval-when (compile load eval)
+       (il:datatype il:compiled-closure (il:fnheader il:environment))
+       (il:blockrecord closure-overlay ((funcallable-instance-p il:flag))))
+
+(defun compiled-closure-fnheader (compiled-closure)
+       (il:fetch (il:compiled-closure il:fnheader)
+              il:of compiled-closure))
+
+(defun set-compiled-closure-fnheader (compiled-closure nv)
+       (il:replace (il:compiled-closure il:fnheader)
+              il:of compiled-closure nv))
+
+(defsetf compiled-closure-fnheader set-compiled-closure-fnheader)
+
+
+;;; In Lyric, and until the format of FNHEADER changes, getting the name from a compiled closure
+;;; looks like this: (fetchfield '(nil 4 pointer) (fetch (compiled-closure fnheader) closure)) Of
+;;; course this is completely non-robust, but it will work for now.  This is not the place to go
+;;; into a long tyrade about what is wrong with having record package definitions go away when you
+;;; ship the sysout; there isn't enough diskspace. 
+
+
+(defun set-function-name-1 (fn new-name uninterned-name)
+       (cond ((typep fn 'il:compiled-closure)
+              (il:\\rplptr (compiled-closure-fnheader fn)
+                     4 new-name)
+              (when (and (consp uninterned-name)
+                         (eq (car uninterned-name)
+                             'method))
+                  (let ((debug (si::compiled-function-debugging-info fn)))
+                       (when debug
+                           (setf (cdr debug)
+                                 uninterned-name)))))
+             (t nil))
+       fn)

clos/3.5/macros.lisp

@@ -0,0 +1,355 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+
+;;; File converted on 26-Mar-91 10:27:21 from source macros
+;;;. Original source {dsk}<usr>local>users>welch>lisp>clos>rev4>il-format>macros.;3 created 19-Feb-91 13:51:21
+
+;;;. Copyright (c) 1991 Venue
+
+
+
+(in-package "CLOS")
+
+
+;;;Macros global variable
+;;; definitions, and other random support stuff used by the rest of the system. For simplicity (not
+;;; having to use eval-when a lot), this file must be loaded before it can be compiled. 
+
+
+(in-package 'clos)
+
+(proclaim '(declaration values arglist indentation class variable-rebinding clos-fast-call))
+
+
+;;; Age old functions which CommonLisp cleaned-up away.  They probably exist in other packages in
+;;; all CommonLisp implementations, but I will leave it to the compiler to optimize into calls to
+;;; them. Common Lisp BUG: Some Common Lisps define these in the Lisp package which causes all sorts
+;;; of lossage.  Common Lisp should explictly specify which symbols appear in the Lisp package. 
+
+
+(eval-when (compile load eval)
+       (defmacro memq (item list)
+              `(member ,item ,list :test #'eq))
+       (defmacro assq (item list)
+              `(assoc ,item ,list :test #'eq))
+       (defmacro rassq (item list)
+              `(rassoc ,item ,list :test #'eq))
+       (defmacro delq (item list)
+              `(delete ,item ,list :test #'eq))
+       (defmacro posq (item list)
+              `(position ,item ,list :test #'eq))
+       (defmacro neq (x y)
+              `(not (eq ,x ,y)))
+       (defun make-caxr (n form)
+              (if (< n 4)
+                  `(,(nth n '(car cadr caddr cadddr))
+                    ,form)
+                  (make-caxr (- n 4)
+                         `(cddddr ,form))))
+       (defun make-cdxr (n form)
+              (cond ((zerop n)
+                     form)
+                    ((< n 5)
+                     `(,(nth n '(identity cdr cddr cdddr cddddr))
+                       ,form))
+                    (t (make-cdxr (- n 4)
+                              `(cddddr ,form))))))
+
+(defun zero (&rest ignore)
+       (declare (ignore ignore))
+       0)
+
+(defun make-plist (keys vals)
+       (if (null vals)
+           nil
+           (list* (car keys)
+                  (car vals)
+                  (make-plist (cdr keys)
+                         (cdr vals)))))
+
+(defun remtail (list tail)
+       (if (eq list tail)
+           nil
+           (cons (car list)
+                 (remtail (cdr list)
+                        tail))))
+
+
+;;; ONCE-ONLY does the same thing as it does in zetalisp.  I should have just lifted it from there
+;;; but I am honest.  Not only that but this one is written in Common Lisp.  I feel a lot like
+;;; bootstrapping, or maybe more like rebuilding Rome. 
+
+
+(defmacro once-only (vars &body body)
+       (let ((gensym-var (gensym))
+             (run-time-vars (gensym))
+             (run-time-vals (gensym))
+             (expand-time-val-forms nil))
+            (dolist (var vars)
+                (push `(if (or (symbolp ,var)
+                               (numberp ,var)
+                               (and (listp ,var)
+                                    (member (car ,var)
+                                           ''function)))
+                           ,var
+                           (let ((,gensym-var (gensym)))
+                                (push ,gensym-var ,run-time-vars)
+                                (push ,var ,run-time-vals)
+                                ,gensym-var))
+                      expand-time-val-forms))
+            `(let* (,run-time-vars ,run-time-vals (wrapped-body (let ,(mapcar #'list vars
+                                                                             (reverse 
+                                                                                expand-time-val-forms
+                                                                                    ))
+                                                                     ,@body)))
+                   `(let ,(mapcar #'list (reverse ,run-time-vars)
+                                 (reverse ,run-time-vals))
+                         ,wrapped-body))))
+
+(eval-when
+ (compile load eval)
+ (defun extract-declarations (body &optional environment)
+        (declare (values documentation declarations body))
+        (let (documentation declarations form)
+             (when (and (stringp (car body))
+                        (cdr body))
+                 (setq documentation (pop body)))
+             (block outer
+                 (loop (when (null body)
+                             (return-from outer nil))
+                       (setq form (car body))
+                       (when (block inner
+                                 (loop (cond ((not (listp form))
+                                              (return-from outer nil))
+                                             ((eq (car form)
+                                                  'declare)
+                                              (return-from inner 't))
+                                             (t (multiple-value-bind
+                                                 (newform macrop)
+                                                 (macroexpand-1 form environment)
+                                                 (if (or (not (eq newform form))
+                                                         macrop)
+                                                     (setq form newform)
+                                                     (return-from outer nil)))))))
+                           (pop body)
+                           (dolist (declaration (cdr form))
+                               (push declaration declarations)))))
+             (values documentation (and declarations `((declare ,.(nreverse declarations))))
+                    body))))
+
+(defvar *keyword-package* (find-package 'keyword))
+
+(defun make-keyword (symbol)
+       (intern (symbol-name symbol)
+              *keyword-package*))
+
+(eval-when (compile load eval)
+       (defun string-append (&rest strings)
+              (setq strings (copy-list strings))
+                                                             ; The explorer can't even rplaca an
+                                                             ; &rest arg? 
+              (do ((string-loc strings (cdr string-loc)))
+                  ((null string-loc)
+                   (apply #'concatenate 'string strings))
+                (rplaca string-loc (string (car string-loc))))))
+
+(defun symbol-append (sym1 sym2 &optional (package *package*))
+       (intern (string-append sym1 sym2)
+              package))
+
+(defmacro check-member (place list &key (test #'eql)
+                              (pretty-name place))
+       (once-only (place list)
+              `(or (member ,place ,list :test ,test)
+                   (error "The value of ~A, ~S is not one of ~S." ',pretty-name ,place ,list))))
+
+(defmacro alist-entry (alist key make-entry-fn)
+       (once-only (alist key)
+              `(or (assq ,key ,alist)
+                   (progn (setf ,alist (cons (,make-entry-fn ,key)
+                                             ,alist))
+                          (car ,alist)))))
+
+(defmacro collecting-once (&key initial-value)
+       `(let* ((head ,initial-value)
+               (tail ,(and initial-value `(last head))))
+              (values #'(lambda (value)
+                               (if (null head)
+                                   (setq head (setq tail (list value)))
+                                   (unless (memq value head)
+                                       (setq tail (cdr (rplacd tail (list value)))))))
+                     #'(lambda nil head))))
+
+(defmacro doplist ((key val)
+                   plist &body body &environment env)
+       (multiple-value-bind (doc decls bod)
+              (extract-declarations body env)
+              (declare (ignore doc))
+              `(let ((.plist-tail. ,plist)
+                     ,key
+                     ,val)
+                    ,@decls
+                    (loop (when (null .plist-tail.)
+                                (return nil))
+                          (setq ,key (pop .plist-tail.))
+                          (when (null .plist-tail.)
+                                (error "Malformed plist in doplist, odd number of elements."))
+                          (setq ,val (pop .plist-tail.))
+                          (progn ,@bod)))))
+
+(defmacro if* (condition true &rest false)
+       `(if ,condition
+            ,true
+            (progn ,@false)))
+
+
+;; 
+
+
+
+;;; printing-random-thing
+
+
+
+;; 
+
+
+
+;;; Similar to printing-random-object in the lisp machine but much simpler and machine independent. 
+
+
+(defmacro printing-random-thing ((thing stream)
+                                 &body body)
+       (once-only (stream)
+              `(progn (format ,stream "#<")
+                      ,@body
+                      (format ,stream " ")
+                      (printing-random-thing-internal ,thing ,stream)
+                      (format ,stream ">"))))
+
+(defun printing-random-thing-internal (thing stream)
+       (let ((*print-base* 8))
+            (princ (il:\\hiloc thing)
+                   stream)
+            (princ "," stream)
+            (princ (il:\\loloc thing)
+                   stream)))
+
+
+;; 
+
+
+
+;;; 
+
+
+
+;; 
+
+
+(defun capitalize-words (string &optional (dashes-p t))
+       (let ((string (copy-seq (string string))))
+            (declare (string string))
+            (do* ((flag t flag)
+                  (length (length string)
+                         length)
+                  (char nil char)
+                  (i 0 (+ i 1)))
+                 ((= i length)
+                  string)
+               (setq char (elt string i))
+               (cond ((both-case-p char)
+                      (if flag
+                          (and (setq flag (lower-case-p char))
+                               (setf (elt string i)
+                                     (char-upcase char)))
+                          (and (not flag)
+                               (setf (elt string i)
+                                     (char-downcase char))))
+                      (setq flag nil))
+                     ((char-equal char #\-)
+                      (setq flag t)
+                      (unless dashes-p
+                          (setf (elt string i)
+                                #\Space)))
+                     (t (setq flag nil))))))
+
+
+;;; FIND-CLASS This is documented in the CLOS specification. 
+
+
+(defvar *find-class* (make-hash-table :test #'eq))
+
+(defun legal-class-name-p (x)
+       (and (symbolp x)
+            (not (keywordp x))))
+
+(defun find-class (symbol &optional (errorp t)
+                         environment)
+       (declare (ignore environment))
+       (or (gethash symbol *find-class*)
+           (cond ((null errorp)
+                  nil)
+                 ((legal-class-name-p symbol)
+                  (error "No class named: ~S." symbol))
+                 (t (error "~S is not a legal class name." symbol)))))
+
+(defsetf find-class (symbol &optional (errorp t)
+                           environment)
+       (new-value)
+       (declare (ignore errorp environment))
+       `(|SETF CLOS FIND-CLASS| ,new-value ,symbol))
+
+(defun |SETF CLOS FIND-CLASS| (new-value symbol)
+       (if (legal-class-name-p symbol)
+           (setf (gethash symbol *find-class*)
+                 new-value)
+           (error "~S is not a legal class name." symbol)))
+
+(defun find-wrapper (symbol)
+       (class-wrapper (find-class symbol)))
+
+(defmacro gathering1 (gatherer &body body)
+  `(gathering ((.gathering1. ,gatherer))
+               (macrolet ((gather1 (x)
+                                 `(gather ,x .gathering1.)))
+                      ,@body)))
+
+
+;;; 
+
+
+(defmacro vectorizing (&key (size 0))
+       `(let* ((limit ,size)
+               (result (make-array limit))
+               (index 0))
+              (values #'(lambda (value)
+                               (if (= index limit)
+                                   (error "vectorizing more elements than promised.")
+                                   (progn (setf (svref result index)
+                                                value)
+                                          (incf index)
+                                          value)))
+                     #'(lambda nil result))))
+
+
+;;; These are augmented definitions of list-elements and list-tails from iterate.lisp.  These
+;;; versions provide the extra :by keyword which can be used to specify the step function through
+;;; the list. 
+
+
+(defmacro *list-elements (list &key (by #'cdr))
+       `(let ((tail ,list))
+             #'(lambda (finish)
+                      (if (endp tail)
+                          (funcall finish)
+                          (prog1 (car tail)
+                              (setq tail (funcall ,by tail)))))))
+
+(defmacro *list-tails (list &key (by #'cdr))
+       `(let ((tail ,list))
+             #'(lambda (finish)
+                      (prog1 (if (endp tail)
+                                 (funcall finish)
+                                 tail)
+                          (setq tail (funcall ,by tail))))))

clos/3.5/patch.lisp

@@ -0,0 +1,143 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (CLIN-PACKAGE "XCL-USER") BASE 10)
+
(IL:FILECREATED "19-Feb-91 14:09:19" 
+IL:|{DSK}<usr>local>users>welch>lisp>clos>rev4>il-format>XEROX-PATCHES.;2|
 9876   
+
+      IL:|changes| IL:|to:|  (IL:VARS IL:XEROX-PATCHESCOMS)
+
+      IL:|previous| IL:|date:| " 6-Feb-91 10:55:16" 
+IL:|{DSK}<usr>local>users>welch>lisp>clos>rev4>il-format>XEROX-PATCHES.;1|)
+
+
+; Copyright (c) 1991 by Venue.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:XEROX-PATCHESCOMS)
+
+(IL:RPAQQ IL:XEROX-PATCHESCOMS
 (
+
+
+                                    (IL:FUNCTIONS OPTIMIZE-LOGICAL-OP-1-ARG)
+                                    (OPTIMIZERS (LOGIOR :OPTIMIZED-BY OPTIMIZE-LOGICAL-OP-1-ARG)
+                                           (LOGXOR :OPTIMIZED-BY OPTIMIZE-LOGICAL-OP-1-ARG)
+                                           (LOGAND :OPTIMIZED-BY OPTIMIZE-LOGICAL-OP-1-ARG)
+                                           (LOGEQV :OPTIMIZED-BY OPTIMIZE-LOGICAL-OP-1-ARG))
+                                    
+                                    (IL:* IL:|;;| "A bug compiling LABELS")

+
+                                    (IL:FUNCTIONS COMPILER::META-CALL-LABELS)
+                                    (FILE-ENVIRONMENTS "XEROX-PATCHES")))
+
+
+
+
+
+
+(IL:* IL:|;;;| 
+"Declare side-effects (actually, lack of side-effects) info for some internal arithmetic functions.  These are needed because the compiler runs the optimizers before checking the side-effects, so side-effect declarations on the \"real\" functions are oft times ignored. Fix a nit in the compiler While no person would generate code like (logor x), macro can (and do). "
+)

+
+
+(DEFUN OPTIMIZE-LOGICAL-OP-1-ARG
 (FORM ENV CTXT)
+   (DECLARE
 (IGNORE ENV CTXT))
+   (IF (= 2 (LENGTH FORM))
+       (SECOND FORM)
+       'COMPILER:PASS))
+
+(DEFOPTIMIZER LOGIOR
 OPTIMIZE-LOGICAL-OP-1-ARG)
+
+(DEFOPTIMIZER LOGXOR
 OPTIMIZE-LOGICAL-OP-1-ARG)
+
+(DEFOPTIMIZER LOGAND
 OPTIMIZE-LOGICAL-OP-1-ARG)
+
+(DEFOPTIMIZER LOGEQV
 OPTIMIZE-LOGICAL-OP-1-ARG)
+
+
+
+(IL:* IL:|;;| "A bug compiling LABELS")

+
+
+(DEFUN COMPILER::META-CALL-LABELS
 (COMPILER::NODE COMPILER:CONTEXT)
+
+   (IL:* IL:|;;| "This is similar to META-CALL-LAMBDA, but we have some extra information. There are only required arguments, and we have the correct number of them. ")

+
+   (LET ((COMPILER::*MADE-CHANGES* NIL))
+
+        (IL:* IL:|;;| "First, substitute the functions wherever possible.")

+
+        (DOLIST (COMPILER::FN-PAIR (COMPILER::LABELS-FUNS COMPILER::NODE)
+                       (WHEN (NULL (COMPILER::NODE-META-P (COMPILER::LABELS-BODY COMPILER::NODE)))
+                           (SETF (COMPILER::NODE-META-P COMPILER::NODE)
+                                 NIL)
+                           (SETQ COMPILER::*MADE-CHANGES* T)))
+            (WHEN (COMPILER::SUBSTITUTABLE-P (CDR COMPILER::FN-PAIR)
+                         (CAR COMPILER::FN-PAIR))
+                (LET ((COMPILER::*SUBST-OCCURRED* NIL))
+
+                     (IL:* IL:|;;| "First try substituting into the body.")

+
+                     (SETF (COMPILER::LABELS-BODY COMPILER::NODE)
+                           (COMPILER::META-SUBSTITUTE (CDR COMPILER::FN-PAIR)
+                                  (CAR COMPILER::FN-PAIR)
+                                  (COMPILER::LABELS-BODY COMPILER::NODE)))
+                     (WHEN (NOT COMPILER::*SUBST-OCCURRED*)
+
+                         (IL:* IL:|;;| "Wasn't in the body - try the other functions.")

+
+                         (DOLIST (COMPILER::TARGET-PAIR (COMPILER::LABELS-FUNS COMPILER::NODE))
+                             (UNLESS (EQ COMPILER::TARGET-PAIR COMPILER::FN-PAIR)
+                                 (SETF (CDR COMPILER::TARGET-PAIR)
+                                       (COMPILER::META-SUBSTITUTE (CDR COMPILER::FN-PAIR)
+                                              (CAR COMPILER::FN-PAIR)
+                                              (CDR COMPILER::TARGET-PAIR)))
+                                 (WHEN COMPILER::*SUBST-OCCURRED*
+                                                             (IL:* IL:\; 
+
                                                           "Found it, we can stop now.")

+                                     (SETF (COMPILER::NODE-META-P COMPILER::NODE)
+                                           NIL)
+                                     (SETQ COMPILER::*MADE-CHANGES* T)
+                                     (RETURN)))))
+
+                     (IL:* IL:|;;| "May need to reanalyze the node, since things might have changed. Note that reanalyzing the parts of the node this way means the the state in the enclosing loop is not lost. ")

+
+                     (DOLIST (COMPILER::FNS (COMPILER::LABELS-FUNS COMPILER::NODE))
+                         (COMPILER::MEVAL (CDR COMPILER::FNS)
+                                :ARGUMENT))
+                     (COMPILER::MEVAL (COMPILER::LABELS-BODY COMPILER::NODE)
+                            :RETURN))))
+
+        (IL:* IL:|;;| "Now remove any functions that aren't referenced.")

+
+        (DOLIST (COMPILER::FN-PAIR (PROG1 (COMPILER::LABELS-FUNS COMPILER::NODE)
+                                       (SETF (COMPILER::LABELS-FUNS COMPILER::NODE)
+                                             NIL)))
+            (COND
+               ((NULL (COMPILER::VARIABLE-READ-REFS (CAR COMPILER::FN-PAIR)))
+                (COMPILER::RELEASE-TREE (CDR COMPILER::FN-PAIR))
+                (SETQ COMPILER::*MADE-CHANGES* T))
+               (T (PUSH COMPILER::FN-PAIR (COMPILER::LABELS-FUNS COMPILER::NODE)))))
+
+        (IL:* IL:|;;| "If there aren't any functions left, replace the node with its body.")

+
+        (WHEN (NULL (COMPILER::LABELS-FUNS COMPILER::NODE))
+            (LET ((COMPILER::BODY (COMPILER::LABELS-BODY COMPILER::NODE)))
+                 (SETF (COMPILER::LABELS-BODY COMPILER::NODE)
+                       NIL)
+                 (COMPILER::RELEASE-TREE COMPILER::NODE)
+                 (SETQ COMPILER::NODE COMPILER::BODY COMPILER::*MADE-CHANGES* T)))
+
+        (IL:* IL:|;;| "Finally, set the meta-p flag if everythings OK.")

+
+        (IF (NULL COMPILER::*MADE-CHANGES*)
+            (SETF (COMPILER::NODE-META-P COMPILER::NODE)
+                  COMPILER:CONTEXT)
+            (SETF (COMPILER::NODE-META-P COMPILER::NODE)
+                  NIL)))
+   COMPILER::NODE)
+
+(DEFINE-FILE-ENVIRONMENT "XEROX-PATCHES"
 :PACKAGE (IN-PACKAGE "XCL-USER")
+   :READTABLE "XCL"
+   :BASE 10
+   :COMPILER :COMPILE-FILE)
+(IL:PUTPROPS IL:XEROX-PATCHES IL:COPYRIGHT ("Venue" 1991))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP

clos/3.5/pkg.lisp

@@ -0,0 +1,81 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+
+;;; File converted on 26-Mar-91 10:23:29 from source pkg
+;;;. Original source {dsk}<usr>local>users>welch>lisp>clos>rev4>il-format>pkg.;4 created  1-Mar-91 10:10:26
+
+;;;. Copyright (c) 1991 by Venue
+
+
+(in-package "CLOS")
+
+
+
+;;; Some CommonLisps have more symbols in the Lisp package than the ones that are explicitly
+;;; specified in CLtL.  This causes trouble. Any Lisp that has extra symbols in the Lisp package
+;;; should shadow those symbols in the CLOS package. 
+
+
+(shadow 'cl:documentation)
+
+
+;;; These come from the index pages of 88-002R. 
+
+(eval-when (compile load eval)
+(defvar *exports*
+       '(add-method built-in-class call-method call-next-method change-class class-name class-of 
+               compute-applicable-methods defclass defgeneric define-method-combination defmethod 
+               ensure-generic-function find-class find-method function-keywords generic-flet 
+               generic-labels initialize-instance invalid-method-error make-instance 
+               make-instances-obsolete method-combination-error method-qualifiers next-method-p 
+               no-applicable-method no-next-method print-object reinitialize-instance remove-method 
+               shared-initialize slot-boundp slot-exists-p slot-makunbound slot-missing slot-unbound
+               slot-value standard standard-class standard-generic-function standard-method 
+               standard-object structure-class symbol-macrolet update-instance-for-different-class 
+               update-instance-for-redefined-class with-accessors with-added-methods with-slots))
+
+(import '(xcl:false xcl:destructuring-bind xcl:true) *the-clos-package*)
+
+(export *exports* *the-clos-package*)
+
+(import *exports* (find-package :lisp))
+
+(export *exports* (find-package :lisp)))
+
+                                                             ; (defvar *chapter-3-exports* '(
+                                                             ; get-setf-function
+                                                             ; get-setf-function-name
+                                                             ; class-prototype class object 
+
+
+
+;; essential-class
+
+
+                                                             ; class-name class-precedence-list
+                                                             ; class-local-supers class-local-slots
+                                                             ; class-direct-subclasses
+                                                             ; class-direct-methods class-slots
+                                                             ; method-arglist
+                                                             ; method-argument-specifiers
+                                                             ; method-function method-equal
+                                                             ; slotd-name slot-missing 
+
+
+
+;; define-meta-class %allocate-instance %instance-ref %instancep %instance-meta-class 
+
+
+                                                             ; allocate-instance optimize-slot-value
+                                                             ; optimize-setf-of-slot-value
+                                                             ; add-named-class
+                                                             ; class-for-redefinition add-class
+                                                             ; supers-changed slots-changed
+                                                             ; check-super-metaclass-compatibility
+                                                             ; make-slotd
+                                                             ; compute-class-precedence-list
+                                                             ; walk-method-body
+                                                             ; walk-method-body-form
+                                                             ; add-named-method remove-named-method
+                                                             ; )) 
+

clos/3.5/plap.lisp

@@ -0,0 +1,309 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+
+;;;. Copyright (c) 1991 by Venue
+
+(in-package "CLOS")
+
+
+;;; The portable implementation of the LAP assembler. The portable implementation of the LAP
+;;; assembler works by translating LAP code back into Lisp code and then compiling that Lisp code. 
+;;; Note that this implementation is actually going to get a lot of use.  Some implementations (KCL)
+;;; won't implement a native LAP assembler at all. Other implementations may not implement native
+;;; LAP assemblers for all of their ports.  All of this implies that this portable LAP assembler
+;;; needs to generate the best code it possibly can. 
+
+
+(defmacro
+ lap-case
+ (operand &body cases)
+ (once-only
+  (operand)
+  `(ecase (car ,operand)
+       ,@(mapcar #'(lambda (case)
+                          `(,(car case)
+                            (apply #'(lambda ,(cadr case)
+                                            ,@(cddr case))
+                                   (cdr ,operand))))
+                cases))))
+
+(defvar *lap-args*)
+
+(defvar *lap-rest-p*)
+
+(defvar *lap-i-regs*)
+
+(defvar *lap-v-regs*)
+
+(defvar *lap-t-regs*)
+
+(defvar *lap-optimize-declaration* '((speed 3)
+                                     (safety 0)
+                                     (compilation-speed 0)))
+
+(eval-when (load eval)
+       (setq *make-lap-closure-generator* #'(lambda (closure-var-names arg-names index-regs 
+                                                           vector-regs t-regs lap-code)
+                                                   (compile-lambda (make-lap-closure-generator-lambda
+                                                                    closure-var-names arg-names 
+                                                                    index-regs vector-regs t-regs 
+                                                                    lap-code)))
+             *precompile-lap-closure-generator*
+             #'(lambda (cvars args i-regs v-regs t-regs lap)
+                      `#',(make-lap-closure-generator-lambda cvars args i-regs v-regs t-regs lap))
+             *lap-in-lisp*
+             #'(lambda (cvars args iregs vregs tregs lap)
+                      (declare (ignore cvars args))
+                      (make-lap-prog iregs vregs tregs (flatten-lap lap 
+                                                             ; (opcode :label 'exit-lap-in-lisp)
+                                                              )))))
+
+(defun make-lap-closure-generator-lambda (cvars args i-regs v-regs t-regs lap)
+       (let* ((rest (memq '&rest args))
+              (ldiff (and rest (ldiff args rest))))
+             (when rest
+                 (setq args (append ldiff '(&rest .lap-rest-arg.))))
+             (let* ((*lap-args* (if rest
+                                    ldiff
+                                    args))
+                    (*lap-rest-p* (not (null rest))))
+                   `(lambda ,cvars #'(lambda ,args (declare (optimize . ,*lap-optimize-declaration*))
+                                            ,(make-lap-prog-internal i-regs v-regs t-regs lap))))))
+
+(defun make-lap-prog (i-regs v-regs t-regs lap)
+       (let* ((*lap-args* 'lap-in-lisp)
+              (*lap-rest-p* 'lap-in-lisp))
+             (make-lap-prog-internal i-regs v-regs t-regs lap)))
+
+(defun make-lap-prog-internal (i-regs v-regs t-regs lap)
+       (let* ((*lap-i-regs* i-regs)
+              (*lap-v-regs* v-regs)
+              (*lap-t-regs* t-regs)
+              (code (mapcar #'lap-opcode lap)))
+             `(prog ,(mapcar #'(lambda (reg)
+                                      `(,(lap-reg reg)
+                                        ,(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*))
+                           (optimize . ,*lap-optimize-declaration*))
+                    ,.code)))
+
+(defconstant *empty-vector* '#())
+
+(defun lap-reg-initial-value-form (reg)
+       (cond ((member reg *lap-i-regs*)
+              0)
+             ((member reg *lap-v-regs*)
+              '*empty-vector*)
+             ((member reg *lap-t-regs*)
+              nil)
+             (t (error "What kind of register is ~S?" reg))))
+
+(defun lap-opcode (opcode)
+       (lap-case opcode (:move (from to)
+                               `(setf ,(lap-operand to)
+                                      ,(lap-operand from)))
+              ((:eq :neq :fix=)
+               (arg1 arg2 label)
+               `(when ,(lap-operands (ecase (car opcode)
+                                         (:eq 'eq)
+                                         (:neq 'neq)
+                                         (:fix= 'runtime\ fix=))
+                              arg1 arg2)
+                    (go ,label)))
+              ((:izerop)
+               (arg label)
+               `(when ,(lap-operands 'runtime\ izerop arg)
+                    (go ,label)))
+              (:std-instance-p (from label)
+                     `(when ,(lap-operands 'runtime\ std-instance-p from)
+                          (go ,label)))
+              (:fsc-instance-p (from label)
+                     `(when ,(lap-operands 'runtime\ fsc-instance-p from)
+                          (go ,label)))
+              (:built-in-instance-p (from label)
+                     (declare (ignore from))
+                     `(when ,t
+                          (go ,label)))
+                                                             ; ***
+              (:structure-instance-p (from label)
+                     `(when ,(lap-operands 'runtime\ ??? from)
+                          (go ,label)))
+                                                             ; ***
+              (:jmp (fn)
+                    (if (eq *lap-args* 'lap-in-lisp)
+                        (error "Can't do a :JMP in LAP-IN-LISP.")
+                        `(return ,(if *lap-rest-p*
+                                      `(runtime\ apply ,(lap-operand fn)
+                                              ,@*lap-args* .lap-rest-arg.)
+                                      `(runtime\ funcall ,(lap-operand fn)
+                                              ,@*lap-args*)))))
+              (:return (value)
+                     `(return ,(lap-operand value)))
+              (:label (label)
+                     label)
+              (:go (label)
+                   `(go ,label))
+              (:exit-lap-in-lisp nil `(go exit-lap-in-lisp))
+              (:break nil `(break))
+              (:beep nil)
+              (:print (val)
+                     (lap-operands 'print val))))
+
+(defun lap-operand (operand)
+       (lap-case operand (:reg (n)
+                               (lap-reg n))
+              (:cdr (reg)
+                    (lap-operands 'cdr reg))
+              ((:cvar :arg)
+               (name)
+               name)
+              (:constant (c)
+                     `',c)
+              ((:std-wrapper :fsc-wrapper :built-in-wrapper :structure-wrapper :std-slots :fsc-slots)
+               (x)
+               (lap-operands (ecase (car operand)
+                                 (:std-wrapper 'runtime\ std-wrapper)
+                                 (:fsc-wrapper 'runtime\ fsc-wrapper)
+                                 (:built-in-wrapper 'runtime\ built-in-wrapper)
+                                 (:structure-wrapper 'runtime\ structure-wrapper)
+                                 (:std-slots 'runtime\ std-slots)
+                                 (:fsc-slots 'runtime\ fsc-slots))
+                      x))
+              (:i1+ (index)
+                    (lap-operands 'runtime\ i1+ index))
+              (:i+ (index1 index2)
+                   (lap-operands 'runtime\ i+ index1 index2))
+              (:i- (index1 index2)
+                   (lap-operands 'runtime\ i- index1 index2))
+              (:ilogand (index1 index2)
+                     (lap-operands 'runtime\ ilogand index1 index2))
+              (:ilogxor (index1 index2)
+                     (lap-operands 'runtime\ ilogxor index1 index2))
+              (:iref (vector index)
+                     (lap-operands 'runtime\ iref vector index))
+              (:iset (vector index value)
+                     (lap-operands 'runtime\ iset vector index value))
+              (:cref (vector i)
+                     `(runtime\ svref ,(lap-operand vector)
+                             ,i))
+              (:lisp-variable (symbol)
+                     symbol)
+              (:lisp (form)
+                     form)))
+
+(defun lap-operands (fn &rest regs)
+       (cons fn (mapcar #'lap-operand regs)))
+
+(defun lap-reg (n)
+       (intern (format nil "REG~D" n)
+              *the-clos-package*))
+
+
+;;; Runtime Implementations of the operands and opcodes. In those ports of CLOS which choose not to
+;;; completely re-implement the LAP code generator, it may still be provident to consider
+;;; reimplementing one or more of these to get the compiler to produce better code.  That is why
+;;; they are split out. 
+
+
+(proclaim '(declaration clos-fast-call))
+
+(defmacro runtime\ funcall (fn &rest args)
+       `(funcall ,fn ,.args))
+
+(defmacro runtime\ apply (fn &rest args)
+       `(apply ,fn ,.args))
+
+(defmacro runtime\ std-wrapper (x)
+       `(std-instance-wrapper ,x))
+
+(defmacro runtime\ fsc-wrapper (x)
+       `(fsc-instance-wrapper ,x))
+
+(defmacro runtime\ built-in-wrapper (x)
+       `(built-in-wrapper-of ,x))
+
+(defmacro runtime\ structure-wrapper (x)
+       `(??? ,x))
+
+(defmacro runtime\ std-slots (x)
+       `(std-instance-slots (the std-instance ,x)))
+
+(defmacro runtime\ fsc-slots (x)
+       `(fsc-instance-slots ,x))
+
+(defmacro runtime\ std-instance-p (x)
+       `(std-instance-p ,x))
+
+(defmacro runtime\ fsc-instance-p (x)
+       `(fsc-instance-p ,x))
+
+(defmacro runtime\ izerop (x)
+       `(zerop (the fixnum ,x)))
+
+(defmacro runtime\ fix= (x y)
+       `(= (the fixnum ,x)
+           (the fixnum ,y)))
+
+
+;;; These are the implementations of the index operands.  The portable assembler generates Lisp code
+;;; that uses these macros.  Even though the variables holding the arguments and results have type
+;;; declarations on them, we put type declarations in here. Some compilers are so stupid... 
+
+
+(defmacro runtime\ iref (vector index)
+       `(svref (the simple-vector ,vector)
+               (the fixnum ,index)))
+
+(defmacro runtime\ iset (vector index value)
+       `(setf (svref (the simple-vector ,vector)
+                     (the fixnum ,index))
+              ,value))
+
+(defmacro runtime\ svref (vector fixnum)
+       `(svref (the simple-vector ,vector)
+               (the fixnum ,fixnum)))
+
+(defmacro runtime\ i+ (index1 index2)
+       `(the fixnum (+ (the fixnum ,index1)
+                       (the fixnum ,index2))))
+
+(defmacro runtime\ i- (index1 index2)
+       `(the fixnum (- (the fixnum ,index1)
+                       (the fixnum ,index2))))
+
+(defmacro runtime\ i1+ (index)
+       `(the fixnum (1+ (the fixnum ,index))))
+
+(defmacro runtime\ ilogand (index1 index2)
+       `(the fixnum (logand (the fixnum ,index1)
+                           (the fixnum ,index2))))
+
+(defmacro runtime\ ilogxor (index1 index2)
+       `(the fixnum (logxor (the fixnum ,index1)
+                           (the fixnum ,index2))))
+
+
+;;; In the portable implementation, indexes are just fixnums. 
+
+
+(defconstant index-value-limit most-positive-fixnum)
+
+(defun index-value->index (index-value)
+       index-value)
+
+(defun index->index-value (index)
+       index)
+
+(defun make-index-mask (cache-size line-size)
+       (let ((cache-size-in-bits (floor (log cache-size 2)))
+             (line-size-in-bits (floor (log line-size 2)))
+             (mask 0))
+            (dotimes (i cache-size-in-bits)
+                (setq mask (dpb 1 (byte 1 i)
+                                mask)))
+            (dotimes (i line-size-in-bits)
+                (setq mask (dpb 0 (byte 1 i)
+                                mask)))
+            mask))

clos/3.5/precom1.lisp

@@ -0,0 +1,31 @@
+;;;-*-Mode:LISP; Package:(CLOS LISP 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1991 Venue
+;;; All rights reserved.
+;;; *************************************************************************
+;;;
+
+(in-package 'clos)
+
+;;;
+;;; pre-allocate generic function caches.  The hope is that this will put
+;;; them nicely together in memory, and that that may be a win.  Of course
+;;; the first gc copy will probably blow that out, this really wants to be
+;;; wrapped in something that declares the area static.
+;;;
+;;; This preallocation only creates about 25% more caches than CLOS itself
+;;; uses need.  Some ports may want to preallocate some more of these.
+;;; 
+(eval-when (load)
+  (flet ((allocate (n size)
+	   (mapcar #'free-cache
+		   (mapcar #'get-cache
+			   (make-list n :initial-element size)))))
+    (allocate 128 4)
+    (allocate 64 8)
+    (allocate 64 9)
+    (allocate 32 16)
+    (allocate 16 17)
+    (allocate 16 32)
+    (allocate 1  64)))

clos/3.5/precom2.lisp

@@ -0,0 +1,12 @@
+;;;-*-Mode:LISP; Package:(CLOS LISP 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1991 Venue
+;;; All rights reserved.
+;;; *************************************************************************
+;;;
+
+(in-package 'clos)
+
+(precompile-dfun-constructors clos)		;this is half of a call to
+						;precompile-random-code-segments

clos/3.5/precom4.lisp

@@ -0,0 +1,12 @@
+;;;-*-Mode:LISP; Package:(CLOS LISP 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1991 Venue
+;;; All rights reserved.
+;;; *************************************************************************
+;;;
+
+(in-package 'clos)
+
+(precompile-function-generators clos)		;this is half of a call to
+						;precompile-random-code-segments

clos/3.5/slots.lisp

@@ -0,0 +1,261 @@
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+
+;;;. Copyright (c) 1991 by Venue
+
+(in-package "CLOS")
+
+;;; These four functions work on std-instances and fsc-instances.  These are instances for which it
+;;; is possible to change the wrapper and the slots. For these kinds of instances, most specified
+;;; methods from the instance structure protocol are promoted to the implementation-specific class
+;;; std-class.  Many of these methods call these four functions. 
+
+
+(defun get-wrapper (inst)
+       (cond ((std-instance-p inst)
+              (std-instance-wrapper inst))
+             ((fsc-instance-p inst)
+              (fsc-instance-wrapper inst))
+             (t (error "What kind of instance is this?"))))
+
+(defun get-slots (inst)
+       (cond ((std-instance-p inst)
+              (std-instance-slots inst))
+             ((fsc-instance-p inst)
+              (fsc-instance-slots inst))
+             (t (error "What kind of instance is this?"))))
+
+(defun set-wrapper (inst new)
+       (cond ((std-instance-p inst)
+              (setf (std-instance-wrapper inst)
+                    new))
+             ((fsc-instance-p inst)
+              (setf (fsc-instance-wrapper inst)
+                    new))
+             (t (error "What kind of instance is this?"))))
+
+(defun set-slots (inst new)
+       (cond ((std-instance-p inst)
+              (setf (std-instance-slots inst)
+                    new))
+             ((fsc-instance-p inst)
+              (setf (fsc-instance-slots inst)
+                    new))
+             (t (error "What kind of instance is this?"))))
+
+(defmacro get-slot-value-2 (instance wrapper slot-name slots index)
+       `(let ((val (%svref ,slots ,index)))
+             (if (eq val ',*slot-unbound*)
+                 (slot-unbound (wrapper-class ,wrapper)
+                        ,instance
+                        ,slot-name)
+                 val)))
+
+(defmacro set-slot-value-2 (nv instance wrapper slot-name slots index)
+       (declare (ignore instance wrapper slot-name))
+       `(setf (%svref ,slots ,index)
+              ,nv))
+
+(defun get-class-slot-value-1 (object wrapper slot-name)
+       (let ((entry (assq slot-name (wrapper-class-slots wrapper))))
+            (if (null entry)
+                (slot-missing (wrapper-class wrapper)
+                       object slot-name 'slot-value)
+                (if (eq (cdr entry)
+                        *slot-unbound*)
+                    (slot-unbound (wrapper-class wrapper)
+                           object slot-name)
+                    (cdr entry)))))
+
+(defun set-class-slot-value-1 (new-value object wrapper slot-name)
+       (let ((entry (assq slot-name (wrapper-class-slots wrapper))))
+            (if (null entry)
+                (slot-missing (wrapper-class wrapper)
+                       object slot-name 'setf new-value)
+                (setf (cdr entry)
+                      new-value))))
+
+(defmethod class-slot-value ((class std-class)
+                             slot-name)
+       (let ((wrapper (class-wrapper class))
+             (prototype (class-prototype class)))
+            (get-class-slot-value-1 prototype wrapper slot-name)))
+
+(defmethod (setf class-slot-value)
+       (nv (class std-class)
+           slot-name)
+       (let ((wrapper (class-wrapper class))
+             (prototype (class-prototype class)))
+            (set-class-slot-value-1 nv prototype wrapper slot-name)))
+
+(defmethod find-slot-definition ((class std-class)
+                                 slot-name)
+       (if (and (eq class *the-class-standard-class*)
+                (eq slot-name 'slots))
+           *the-eslotd-standard-class-slots*
+           (progn (unless (class-finalized-p class)
+                         (finalize-inheritance class))
+                  (dolist (eslotd (class-slots class))
+                      (when (eq (slotd-name eslotd)
+                                slot-name)
+                            (return eslotd))))))
+
+(defun slot-value (object slot-name)
+       (let ((class (class-of object)))
+            (if (eq class *the-class-standard-effective-slot-definition*)
+                (let* ((wrapper (check-wrapper-validity object))
+                       (slots (get-slots object))
+                       (index (instance-slot-index wrapper slot-name)))
+                      (if index
+                          (get-slot-value-2 object wrapper slot-name slots index)
+                          (get-class-slot-value-1 object wrapper slot-name)))
+                (let ((slot-definition (find-slot-definition class slot-name)))
+                     (if (null slot-definition)
+                         (slot-missing class object slot-name 'slot-value)
+                         (slot-value-using-class class object slot-definition))))))
+
+(defun set-slot-value (object slot-name new-value)
+       (let ((class (class-of object)))
+            (if (eq class *the-class-standard-effective-slot-definition*)
+                (let* ((wrapper (check-wrapper-validity object))
+                       (slots (get-slots object))
+                       (index (instance-slot-index wrapper slot-name)))
+                      (if index
+                          (set-slot-value-2 new-value object wrapper slot-name slots index)
+                          (set-class-slot-value-1 new-value object wrapper slot-name)))
+                (let ((slot-definition (find-slot-definition class slot-name)))
+                     (if (null slot-definition)
+                         (slot-missing class object slot-name 'setf)
+                         (setf (slot-value-using-class class object slot-definition)
+                               new-value))))))
+
+(defun slot-boundp (object slot-name)
+       (let* ((class (class-of object))
+              (slot-definition (find-slot-definition class slot-name)))
+             (if (null slot-definition)
+                 (slot-missing class object slot-name 'slot-boundp)
+                 (slot-boundp-using-class class object slot-definition))))
+
+(defun slot-makunbound (object slot-name)
+       (let* ((class (class-of object))
+              (slot-definition (find-slot-definition class slot-name)))
+             (if (null slot-definition)
+                 (slot-missing class object slot-name 'slot-makunbound)
+                 (slot-makunbound-using-class class object slot-definition))))
+
+(defun slot-exists-p (object slot-name)
+       (let* ((class (class-of object))
+              (slot-definition (find-slot-definition class slot-name)))
+             (and slot-definition (slot-exists-p-using-class class object slot-definition))))
+
+
+;;; This isn't documented, but is used within CLOS in a number of print object methods (see
+;;; named-object-print-function). 
+
+
+(defun slot-value-or-default (object slot-name &optional (default "unbound"))
+       (if (slot-boundp object slot-name)
+           (slot-value object slot-name)
+           default))
+
+
+;;; 
+
+
+(defmethod slot-value-using-class ((class std-class)
+                                   (object standard-object)
+                                   (slotd standard-effective-slot-definition))
+       (let* ((wrapper (check-wrapper-validity object))
+                                                             ; trap if need be
+              (slots (get-slots object))
+              (slot-name (slotd-name slotd))
+              (index (or (slotd-instance-index slotd)
+                         (setf (slotd-instance-index slotd)
+                               (instance-slot-index wrapper slot-name)))))
+             (if index
+                 (get-slot-value-2 object wrapper slot-name slots index)
+                 (get-class-slot-value-1 object wrapper slot-name))))
+
+(defmethod (setf slot-value-using-class)
+       (new-value (class std-class)
+              (object standard-object)
+              (slotd standard-effective-slot-definition))
+       (let* ((wrapper (check-wrapper-validity object))
+                                                             ; trap if need be
+              (slots (get-slots object))
+              (slot-name (slotd-name slotd))
+              (index (or (slotd-instance-index slotd)
+                         (setf (slotd-instance-index slotd)
+                               (instance-slot-index wrapper slot-name)))))
+             (if index
+                 (set-slot-value-2 new-value object wrapper slot-name slots index)
+                 (set-class-slot-value-1 new-value object wrapper slot-name))))
+
+(defmethod slot-boundp-using-class ((class std-class)
+                                    (object standard-object)
+                                    (slotd standard-effective-slot-definition))
+       (let* ((wrapper (check-wrapper-validity object))
+                                                             ; trap if need be
+              (slots (get-slots object))
+              (slot-name (slotd-name slotd))
+              (index (or (slotd-instance-index slotd)
+                         (setf (slotd-instance-index slotd)
+                               (instance-slot-index wrapper slot-name)))))
+             (if index
+                 (neq (svref slots index)
+                      *slot-unbound*)
+                 (let ((entry (assq slot-name (wrapper-class-slots wrapper))))
+                      (if (null entry)
+                          (slot-missing class object slot-name 'slot-boundp)
+                          (neq (cdr entry)
+                               *slot-unbound*))))))
+
+(defmethod slot-makunbound-using-class ((class std-class)
+                                        (object standard-object)
+                                        (slotd standard-effective-slot-definition))
+       (let* ((wrapper (check-wrapper-validity object))
+                                                             ; trap if need be
+              (slots (get-slots object))
+              (slot-name (slotd-name slotd))
+              (index (or (slotd-instance-index slotd)
+                         (setf (slotd-instance-index slotd)
+                               (instance-slot-index wrapper slot-name)))))
+             (cond (index (setf (%svref slots index)
+                                *slot-unbound*)
+                          object)
+                   (t (let ((entry (assq slot-name (wrapper-class-slots wrapper))))
+                           (if* (null entry)
+                                (slot-missing class object slot-name 'slot-makunbound)
+                                (setf (cdr entry)
+                                      *slot-unbound*)
+                                object))))))
+
+(defmethod slot-exists-p-using-class ((class std-class)
+                                      (object standard-object)
+                                      (slotd standard-effective-slot-definition))
+       t)
+
+(defmethod slot-missing ((class t)
+                         instance slot-name operation &optional new-value)
+       (error "When attempting to ~A,~%the slot ~S is missing from the object ~S."
+              (ecase operation
+                  (slot-value "read the slot's value (slot-value)")
+                  (setf (format nil "set the slot's value to ~S (setf of slot-value)" new-value))
+                  (slot-boundp "test to see if slot is bound (slot-boundp)")
+                  (slot-makunbound "make the slot unbound (slot-makunbound)"))
+              slot-name instance))
+
+(defmethod slot-unbound ((class t)
+                         instance slot-name)
+       (error "The slot ~S is unbound in the object ~S." slot-name instance))
+
+(defmethod allocate-instance ((class standard-class)
+                              &rest initargs)
+       (declare (ignore initargs))
+       (unless (class-finalized-p class)
+              (finalize-inheritance class))
+       (let* ((class-wrapper (class-wrapper class))
+              (instance (%allocate-instance--class (class-no-of-instance-slots class))))
+             (setf (std-instance-wrapper instance)
+                   class-wrapper)
+             instance))

clos/3.5/std-class.lisp

@@ -0,0 +1,997 @@
+
+;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
+
+
+;;; File converted on 10-Apr-91 22:24:19 from source std-class
+;;;. Original source {dsk}<usr>local>users>welch>lisp>clos>rev4>il-format>std-class.;4 created 20-Feb-91 13:07:14
+
+;;;. Copyright (c) 1991 by Venue
+
+
+(in-package "CLOS")
+
+
+
+(define-gf-predicate classp class)
+
+(define-gf-predicate standard-class-p standard-class)
+
+(define-gf-predicate forward-referenced-class-p forward-referenced-class)
+
+(defmethod shared-initialize :after ((object documentation-mixin)
+                                     slot-names &key documentation)
+       (declare (ignore slot-names))
+       (setf (plist-value object 'documentation)
+             documentation))
+
+(defmethod documentation (object &optional doc-type)
+       (cl:documentation object doc-type))
+
+(defmethod (setf documentation)
+       (new-value object &optional doc-type)
+       (declare (ignore new-value doc-type))
+       (error "Can't change the documentation of ~S." object))
+
+(defmethod documentation ((object documentation-mixin)
+                          &optional doc-type)
+  (declare (ignore doc-type))
+  (car (plist-value object 'documentation)))
+
+(defmethod (setf documentation)
+       (new-value (object documentation-mixin)
+              &optional doc-type)
+       (declare (ignore doc-type))
+       (setf (plist-value object 'documentation)
+             new-value))
+
+(defmethod documentation ((slotd standard-slot-definition)
+                          &optional doc-type)
+       (declare (ignore doc-type))
+       (slot-value slotd 'documentation))
+
+(defmethod (setf documentation)
+       (new-value (slotd standard-slot-definition)
+              &optional doc-type)
+       (declare (ignore doc-type))
+       (setf (slot-value slotd 'documentation)
+             new-value))
+
+(defmethod documentation ((method standard-method) &optional doc-type)
+  (declare (ignore doc-type))
+  (plist-value method 'documentation))
+
+(defmethod (setf documentation)
+	   (new-value (method standard-method)
+		      &optional doc-type)
+  (declare (ignore doc-type))
+  (setf (plist-value method 'documentation) new-value))
+
+;;; Various class accessors that are a little more complicated than can be done with automatically
+;;; generated reader methods. 
+
+
+(defmethod class-wrapper ((class clos-class))
+       (with-slots (wrapper)
+           class
+         (let ((w? wrapper))
+              (if (consp w?)
+                  (let ((new (make-wrapper class)))
+                       (setf (wrapper-instance-slots-layout new)
+                             (car w?)
+                             (wrapper-class-slots new)
+                             (cdr w?))
+                       (setq wrapper new))
+                  w?))))
+
+(defmethod class-precedence-list ((class clos-class))
+       (unless (class-finalized-p class)
+              (finalize-inheritance class))
+       (with-slots (class-precedence-list)
+           class
+         class-precedence-list))
+
+(defmethod class-finalized-p ((class clos-class))
+       (with-slots (wrapper)
+           class
+         (not (null wrapper))))
+
+(defmethod class-prototype ((class std-class))
+       (with-slots (prototype)
+           class
+         (or prototype (setq prototype (allocate-instance class)))))
+
+(defmethod class-direct-default-initargs ((class std-class))
+       (plist-value class 'direct-default-initargs))
+
+(defmethod class-default-initargs ((class std-class))
+       (plist-value class 'default-initargs))
+
+(defmethod class-constructors ((class std-class))
+       (plist-value class 'constructors))
+
+(defmethod class-slot-cells ((class std-class))
+       (plist-value class 'class-slot-cells))
+
+
+;;; Class accessors that are even a little bit more complicated than those above.  These have a
+;;; protocol for updating them, we must implement that protocol. Maintaining the direct subclasses
+;;; backpointers.  The update methods are here, the values are read by an automatically generated
+;;; reader method. 
+
+
+(defmethod add-direct-subclass ((class class)
+                                (subclass class))
+       (with-slots (direct-subclasses)
+           class
+         (pushnew subclass direct-subclasses)
+         subclass))
+
+(defmethod remove-direct-subclass ((class class)
+                                   (subclass class))
+       (with-slots (direct-subclasses)
+           class
+         (setq direct-subclasses (remove subclass direct-subclasses))
+         subclass))
+
+
+;;; Maintaining the direct-methods and direct-generic-functions backpointers. There are four generic
+;;; functions involved, each has one method for the class case and another method for the damned EQL
+;;; specializers. All of these are specified methods and appear in their specified place in the
+;;; class graph. ADD-METHOD-ON-SPECIALIZER REMOVE-METHOD-ON-SPECIALIZER SPECIALIZER-METHODS
+;;; SPECIALIZER-GENERIC-FUNCTIONS In each case, we maintain one value which is a cons.  The car is
+;;; the list methods.  The cdr is a list of the generic functions.  The cdr is always computed
+;;; lazily. 
+
+
+(defmethod add-method-on-specializer ((method method)
+                                      (specializer class))
+       (with-slots (direct-methods)
+           specializer
+         (setf (car direct-methods)
+               (adjoin method (car direct-methods))
+               (cdr direct-methods)
+               nil))
+       method)
+
+(defmethod remove-method-on-specializer ((method method)
+                                         (specializer class))
+       (with-slots (direct-methods)
+           specializer
+         (setf (car direct-methods)
+               (remove method (car direct-methods))
+               (cdr direct-methods)
+               nil))
+       method)
+
+(defmethod specializer-methods ((specializer class))
+       (with-slots (direct-methods)
+           specializer
+         (car direct-methods)))
+
+(defmethod specializer-generic-functions ((specializer class))
+       (with-slots (direct-methods)
+           specializer
+         (or (cdr direct-methods)
+             (setf (cdr direct-methods)
+                   (gathering1 (collecting-once)
+                          (dolist (m (car direct-methods))
+                              (gather1 (method-generic-function m))))))))
+
+
+;;; This hash table is used to store the direct methods and direct generic functions of EQL
+;;; specializers.  Each value in the table is the cons. 
+
+
+(defvar *eql-specializer-methods* (make-hash-table :test #'eql))
+
+(defmethod add-method-on-specializer ((method method)
+                                      (specializer eql-specializer))
+       (let* ((object (eql-specializer-object specializer))
+              (entry (gethash object *eql-specializer-methods*)))
+             (unless entry
+                 (setq entry (setf (gethash object *eql-specializer-methods*)
+                                   (cons nil nil))))
+             (setf (car entry)
+                   (adjoin method (car entry))
+                   (cdr entry)
+                   nil)
+             method))
+
+(defmethod remove-method-on-specializer ((method method)
+                                         (specializer eql-specializer))
+       (let* ((object (eql-specializer-object specializer))
+              (entry (gethash object *eql-specializer-methods*)))
+             (when entry
+                 (setf (car entry)
+                       (remove method (car entry))
+                       (cdr entry)
+                       nil))
+             method))
+
+(defmethod specializer-methods ((specializer eql-specializer))
+       (car (gethash (eql-specializer-object specializer)
+                   *eql-specializer-methods*)))
+
+(defmethod specializer-generic-functions ((specializer eql-specializer))
+       (let* ((object (eql-specializer-object specializer))
+              (entry (gethash object *eql-specializer-methods*)))
+             (when entry
+                 (or (cdr entry)
+                     (setf (cdr entry)
+                           (gathering1 (collecting-once)
+                                  (dolist (m (car entry))
+                                      (gather1 (method-generic-function m)))))))))
+
+(defun real-load-defclass (name metaclass-name supers slots other accessors)
+       (do-standard-defsetfs-for-defclass accessors)
+                                                             ; ***
+       (apply #'ensure-class name :metaclass metaclass-name :direct-superclasses supers :direct-slots
+              slots :definition-source `((defclass ,name ()
+                                             ())
+                                         ,(load-truename))
+              other))
+
+(defun ensure-class (name &rest all)
+       (apply #'ensure-class-using-class name (find-class name nil)
+              all))
+
+(defmethod ensure-class-using-class (name (class null)
+                                          &rest args &key)
+       (multiple-value-bind (meta initargs)
+           (ensure-class-values class args)
+         (setf class (apply #'make-instance meta :name name initargs)
+               (find-class name)
+               class)
+	 (inform-type-system-about-class class name)
+                                                             ; ***
+         class))
+
+(defmethod ensure-class-using-class (name (class clos-class)
+                                          &rest args &key)
+       (multiple-value-bind (meta initargs)
+           (ensure-class-values class args)
+         (unless (eq (class-of class)
+                     meta)
+                (change-class class meta))
+         (apply #'reinitialize-instance class initargs)
+         (inform-type-system-about-class class name)
+                                                             ; ***
+         class))
+
+(defun ensure-class-values (class args)
+       (let* ((initargs (copy-list args))
+              (unsupplied (list 1))
+              (supplied-meta (getf initargs :metaclass unsupplied))
+              (supplied-supers (getf initargs :direct-superclasses unsupplied))
+              (supplied-slots (getf initargs :direct-slots unsupplied))
+              (meta (cond ((neq supplied-meta unsupplied)
+                           (find-class supplied-meta))
+                          ((or (null class)
+                               (forward-referenced-class-p class))
+                           *the-class-standard-class*)
+                          (t (class-of class))))
+              (proto (class-prototype meta)))
+             (flet ((fix-super (s)
+                           (cond ((classp s)
+                                  s)
+                                 ((not (legal-class-name-p s))
+                                  (error "~S is not a class or a legal class name." s))
+                                 (t (or (find-class s nil)
+                                        (setf (find-class s)
+                                              (make-instance 'forward-referenced-class :name s)))))))
+                   (loop (unless (remf initargs :metaclass)
+                                (return)))
+                   (loop (unless (remf initargs :direct-superclasses)
+                                (return)))
+                   (loop (unless (remf initargs :direct-slots)
+                                (return)))
+                   (values meta (list* :direct-superclasses (and (neq supplied-supers unsupplied)
+                                                                 (mapcar #'fix-super supplied-supers)
+                                                                 )
+                                       :direct-slots
+                                       (and (neq supplied-slots unsupplied)
+                                            supplied-slots)
+                                       initargs)))))
+
+
+;;; 
+
+
+(defmethod shared-initialize :before ((class std-class)
+                                      slot-names &key direct-superclasses)
+       (declare (ignore slot-names))
+       
+       ;; *** error checking
+       )
+
+(defmethod shared-initialize :after ((class std-class)
+                                     slot-names 
+				     &key (direct-superclasses 
+					   nil direct-superclasses-p)
+                                     (direct-slots nil direct-slots-p)
+                                     (direct-default-initargs 
+				      nil direct-default-initargs-p))
+  (declare (ignore slot-names))
+  (setq direct-superclasses (if direct-superclasses-p
+				(setf (slot-value class 'direct-superclasses)
+				      (or direct-superclasses 
+					  (list *the-class-standard-object*)
+					  ))
+				(slot-value class 'direct-superclasses)))
+  (setq direct-slots (if direct-slots-p
+			 (setf (slot-value class 'direct-slots)
+			       (mapcar #'(lambda (pl)
+					   (make-direct-slotd class pl))
+				       direct-slots))
+			 (slot-value class 'direct-slots)))
+  (if direct-default-initargs-p
+      (setf (plist-value class 'direct-default-initargs)
+	    direct-default-initargs)
+      (setq direct-default-initargs
+	    (plist-value class 'direct-default-initargs)))
+  (setf (plist-value class 'class-slot-cells)
+	(gathering1 (collecting)
+                    (dolist (dslotd direct-slots)
+		      (when (eq (slotd-allocation dslotd)
+				class)
+			(let ((initfunction (slotd-initfunction dslotd)))
+			  (gather1 (cons (slotd-name dslotd)
+					 (if initfunction
+					     (funcall initfunction)
+					     *slot-unbound*))))))))
+  (add-direct-subclasses class direct-superclasses)
+  (add-slot-accessors class direct-slots))
+
+(defmethod reinitialize-instance :before ((class std-class)
+                                          &key direct-superclasses direct-slots 
+                                          direct-default-initargs)
+       (declare (ignore direct-default-initargs))
+       (remove-direct-subclasses class (class-direct-superclasses class))
+       (remove-slot-accessors class (class-direct-slots class)))
+
+(defmethod reinitialize-instance :after ((class std-class)
+                                         &rest initargs &key)
+       (update-class class nil)
+       (map-dependents class #'(lambda (dependent)
+                                      (apply #'update-dependent class dependent initargs))))
+
+(defun add-slot-accessors (class dslotds)
+       (fix-slot-accessors class dslotds 'add))
+
+(defun remove-slot-accessors (class dslotds)
+       (fix-slot-accessors class dslotds 'remove))
+
+(defun fix-slot-accessors (class dslotds add/remove)
+       (flet ((fix (gfspec name r/w)
+                   (let ((gf (ensure-generic-function gfspec)))
+                        (case r/w
+                            (r (if (eq add/remove 'add)
+                                   (add-reader-method class gf name)
+                                   (remove-reader-method class gf)))
+                            (w (if (eq add/remove 'add)
+                                   (add-writer-method class gf name)
+                                   (remove-writer-method class gf)))))))
+             (dolist (dslotd dslotds)
+                 (let ((slot-name (slotd-name dslotd)))
+                      (dolist (r (slotd-readers dslotd))
+                          (fix r slot-name 'r))
+                      (dolist (w (slotd-writers dslotd))
+                          (fix w slot-name 'w))))))
+
+(defun add-direct-subclasses (class new)
+       (dolist (n new)
+           (unless (memq class (class-direct-subclasses class))
+                  (add-direct-subclass n class))))
+
+(defun remove-direct-subclasses (class new)
+       (let ((old (class-direct-superclasses class)))
+            (dolist (o (set-difference old new))
+                (remove-direct-subclass o class))))
+
+
+;;; 
+
+
+(defmethod finalize-inheritance ((class std-class))
+       (update-class class t))
+
+
+;;; Called by :after reinitialize instance whenever a class is reinitialized. The class may or may
+;;; not be finalized. 
+
+
+(defun update-class (class finalizep)
+       (when (or finalizep (class-finalized-p class))
+           (let* ((dsupers (class-direct-superclasses class))
+                  (dslotds (class-direct-slots class))
+                  (dinits (class-direct-default-initargs class))
+                  (cpl (compute-class-precedence-list class dsupers))
+                  (eslotds (compute-slots class cpl dslotds))
+                  (inits (compute-default-initargs class cpl dinits)))
+                 (update-cpl class cpl)
+                 (update-slots class cpl eslotds)
+		 (update-dinits class dinits)
+                 (update-inits class inits)
+                 (update-constructors class)))
+       (unless finalizep
+           (dolist (sub (class-direct-subclasses class))
+               (update-class sub nil))))
+
+(defun update-cpl (class cpl)
+       (when (class-finalized-p class)
+           (unless (equal (class-precedence-list class)
+                          cpl)
+                  (force-cache-flushes class)))
+       (setf (slot-value class 'class-precedence-list)
+             cpl))
+
+(defun update-slots (class cpl eslotds)
+       (multiple-value-bind (nlayout nwrapper-class-slots)
+           (compute-storage-info cpl eslotds)
+         
+         ;; If there is a change in the shape of the instances then the old class is now obsolete. 
+         (let* ((owrapper (class-wrapper class))
+                (olayout (and owrapper (wrapper-instance-slots-layout owrapper)))
+                (owrapper-class-slots (and owrapper (wrapper-class-slots owrapper)))
+                (nwrapper (cond ((null owrapper)
+                                 (make-wrapper class))
+                                ((and (equal nlayout olayout)
+                                      (not (iterate ((o (list-elements owrapper-class-slots))
+                                                     (n (list-elements nwrapper-class-slots)))
+                                                  (unless (eq (car o)
+                                                              (car n))
+                                                         (return t)))))
+                                 owrapper)
+                                (t 
+
+                                 ;; This will initialize the new wrapper to have the same state as
+                                 ;; the old wrapper.  We will then have to change that.  This may
+                                 ;; seem like wasted work (it is), but the spec requires that we
+                                 ;; call make-instances-obsolete. 
+                                   (make-instances-obsolete class)
+                                   (class-wrapper class)))))
+               (with-slots (wrapper no-of-instance-slots slots)
+                   class
+                 (setf no-of-instance-slots (length nlayout)
+                       slots eslotds (wrapper-instance-slots-layout nwrapper)
+                       nlayout
+                       (wrapper-class-slots nwrapper)
+                       nwrapper-class-slots wrapper nwrapper))
+               (dolist (eslotd eslotds)
+                   (setf (slotd-class eslotd)
+                         class)
+                   (setf (slotd-instance-index eslotd)
+                         (instance-slot-index nwrapper (slotd-name eslotd)))))))
+
+(defun compute-storage-info (cpl eslotds)
+       (let ((instance nil)
+             (class nil))
+            (dolist (eslotd eslotds)
+                (let ((alloc (slotd-allocation eslotd)))
+                     (cond ((eq alloc :instance)
+                            (push eslotd instance))
+                           ((classp alloc)
+                            (push eslotd class)))))
+            (values (compute-layout cpl instance)
+                   (compute-class-slots class))))
+
+(defun compute-layout (cpl instance-eslotds)
+       (let* ((names (gathering1 (collecting)
+                            (dolist (eslotd instance-eslotds)
+                                (when (eq (slotd-allocation eslotd)
+                                          :instance)
+                                    (gather1 (slotd-name eslotd))))))
+              (order nil))
+             (labels ((rwalk (tail)
+                             (when tail
+                                 (rwalk (cdr tail))
+                                 (dolist (ss (class-slots (car tail)))
+                                     (let ((n (slotd-name ss)))
+                                          (when (memq n names)
+                                              (setq order (cons n order)
+                                                    names
+                                                    (remove n names))))))))
+                    (rwalk cpl)
+                    (reverse (append names order)))))
+
+(defun compute-class-slots (eslotds)
+       (gathering1 (collecting)
+              (dolist (eslotd eslotds)
+                  (gather1 (assoc (slotd-name eslotd)
+                                  (class-slot-cells (slotd-allocation eslotd)))))))
+(defun update-dinits (class dinits)
+  (setf (plist-value class 'direct-default-initargs) 
+	(remove-invalid dinits (class-slots class))))
+
+(defun update-inits (class inits)
+       (setf (plist-value class 'default-initargs) 
+	     (remove-invalid inits (class-slots class))))
+
+;; bug: :default-initargs aren't updated with slots are removed, so
+;; update-inits removes initargs that don't have corresponding slots.
+
+(defun remove-invalid (inits slotds &aux (return nil))
+  (dolist (element inits)
+    (dolist (slotd slotds)
+      (if (member (car element) (slot-value slotd 'initargs))
+	  (pushnew element return))))
+  return)
+
+
+
+(defmethod compute-default-initargs ((class std-class)
+                                     cpl direct)
+       (labels ((walk (tail)
+                      (if (null tail)
+                          nil
+                          (let ((c (pop tail)))
+                               (append (if (eq c class)
+                                           direct
+                                           (class-direct-default-initargs c))
+                                      (walk tail))))))
+              (let ((initargs (walk cpl)))
+		(delete-duplicates initargs 
+				   :test #'eq :key #'car :from-end t))))
+
+
+;;; Protocols for constructing direct and effective slot definitions. 
+
+
+(defmethod direct-slot-definition-class ((class std-class)
+                                         initargs)
+       (declare (ignore initargs))
+       (find-class 'standard-direct-slot-definition))
+
+(defun make-direct-slotd (class initargs)
+       (let ((initargs (list* :class class initargs)))
+            (apply #'make-instance (direct-slot-definition-class class initargs)
+                   initargs)))
+
+
+;;; 
+
+
+(defmethod compute-slots ((class std-class)
+                          cpl class-direct-slots)
+       
+       ;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once for each different slot
+       ;; name we find in our superclasses.  Each call receives the class and a list of the dslotds
+       ;; with that name. The list is in most-specific-first order. 
+       (let ((name-dslotds-alist nil))
+            (labels ((collect-one-class (dslotds)
+                            (dolist (d dslotds)
+                                (let* ((name (slotd-name d))
+                                       (entry (assq name name-dslotds-alist)))
+                                      (if entry
+                                          (push d (cdr entry))
+                                          (push (list name d)
+                                                name-dslotds-alist))))))
+                   (collect-one-class class-direct-slots)
+                   (dolist (c (cdr cpl))
+                       (collect-one-class (class-direct-slots c)))
+                   (mapcar #'(lambda (direct)
+                                    (compute-effective-slot-definition class (nreverse (cdr direct)))
+                                    )
+                          name-dslotds-alist))))
+
+(defmethod compute-effective-slot-definition ((class std-class)
+                                              dslotds)
+       (let* ((initargs (compute-effective-slot-definition-initargs class dslotds))
+              (class (effective-slot-definition-class class initargs)))
+             (apply #'make-instance class initargs)))
+
+(defmethod effective-slot-definition-class ((class std-class)
+                                            initargs)
+       (declare (ignore initargs))
+       (find-class 'standard-effective-slot-definition))
+
+(defmethod compute-effective-slot-definition-initargs ((class std-class)
+                                                       direct-slotds)
+       (let* ((name nil)
+              (initfunction nil)
+              (initform nil)
+              (initargs nil)
+              (allocation nil)
+              (type t)
+              (namep nil)
+              (initp nil)
+              (allocp nil))
+             (dolist (slotd direct-slotds)
+                 (when slotd
+                     (unless namep
+                         (setq name (slotd-name slotd)
+                               namep t))
+                     (unless initp
+                         (when (slotd-initfunction slotd)
+                             (setq initform (slotd-initform slotd)
+                                   initfunction
+                                   (slotd-initfunction slotd)
+                                   initp t)))
+                     (unless allocp
+                         (setq allocation (slotd-allocation slotd)
+                               allocp t))
+                     (setq initargs (append (slotd-initargs slotd)
+                                           initargs))
+                     (let ((slotd-type (slotd-type slotd)))
+                          (setq type (cond ((null type)
+                                            slotd-type)
+                                           ((subtypep type slotd-type)
+                                            type)
+                                           (t `(and ,type ,slotd-type)))))))
+             (list :name name :initform initform :initfunction initfunction :initargs initargs 
+                   :allocation allocation :type type)))
+
+
+;;; NOTE: For bootstrapping considerations, these can't use make-instance to make the method object.
+;;; They have to use make-a-method which is a specially bootstrapped mechanism for making standard
+;;; methods. 
+
+
+(defmethod add-reader-method ((class std-class)
+                              generic-function slot-name)
+       (let* ((name (class-name class))
+              (method (make-a-method 'standard-reader-method nil (list (or name 'standard-object))
+                             (list class)
+                             (make-reader-method-function class slot-name)
+                             "automatically generated reader method" slot-name)))
+             (add-method generic-function method)))
+
+(defmethod add-writer-method ((class std-class)
+                              generic-function slot-name)
+       (let* ((name (class-name class))
+              (method (make-a-method 'standard-writer-method nil (list 'new-value (or name
+                                                                                      
+                                                                                      '
+                                                                                      standard-object
+                                                                                      ))
+                             (list *the-class-t* class)
+                             (make-writer-method-function class slot-name)
+                             "automatically generated writer method" slot-name)))
+             (add-method generic-function method)))
+
+(defmethod remove-reader-method ((class std-class)
+                                 generic-function)
+       (let ((method (get-method generic-function nil (list class)
+                            nil)))
+            (when method (remove-method generic-function method))))
+
+(defmethod remove-writer-method ((class std-class)
+                                 generic-function)
+       (let ((method (get-method generic-function nil (list *the-class-t* class)
+                            nil)))
+            (when method (remove-method generic-function method))))
+
+
+;;; make-reader-method-function and make-write-method function are NOT part of the standard
+;;; protocol.  They are however useful, CLOS makes uses makes use of them internally and documents
+;;; them for CLOS users. *** This needs work to make type testing by the writer functions which ***
+;;; do type testing faster.  The idea would be to have one constructor *** for each possible type
+;;; test.  In order to do this it would be nice *** to have help from inform-type-system-about-class
+;;; and friends. *** There is a subtle bug here which is going to have to be fixed. *** Namely, the
+;;; simplistic use of the template has to be fixed.  We *** have to give the optimize-slot-value
+;;; method the user might have *** defined for this metclass a chance to run. 
+
+
+(defmethod make-reader-method-function ((class standard-class)
+                                        slot-name)
+       (make-std-reader-method-function slot-name))
+
+(defmethod make-writer-method-function ((class standard-class)
+                                        slot-name)
+       (make-std-writer-method-function slot-name))
+
+(defun make-std-reader-method-function (slot-name)
+       #'(lambda (instance)
+                (slot-value instance slot-name)))
+
+(defun make-std-writer-method-function (slot-name)
+       #'(lambda (nv instance)
+                (setf (slot-value instance slot-name)
+                      nv)))
+
+                                                             ; inform-type-system-about-class
+                                                             ; make-type-predicate 
+
+
+
+;;; These are NOT part of the standard protocol.  They are internal mechanism which CLOS uses to
+;;; *try* and tell the type system about class definitions. In a more fully integrated
+;;; implementation of CLOS, the type system would know about class objects and class names in a more
+;;; fundamental way and the mechanism used to inform the type system about new classes would be
+;;; different. 
+
+
+(defmethod inform-type-system-about-class ((class std-class)
+                                           name)
+       (let ((predicate-name (make-type-predicate-name name)))
+            (setf (symbol-function predicate-name)
+                  (make-type-predicate name))
+            (do-satisfies-deftype name predicate-name)
+	    (setf (gethash name lisp::*typep-hash-table*)
+		  predicate-name))) ;makes typep significantly faster...
+
+(defun make-type-predicate (name)
+       #'(lambda (x)
+                (not (null (memq (find-class name)
+                                 (cond ((std-instance-p x)
+                                        (class-precedence-list (std-instance-class x)))
+                                       ((fsc-instance-p x)
+                                        (class-precedence-list (fsc-instance-class x)))))))))
+
+
+;;; These 4 definitions appear here for bootstrapping reasons.  Logically, they should be in the
+;;; construct file.  For documentation purposes, a copy of these definitions appears in the
+;;; construct file.  If you change one of the definitions here, be sure to change the copy there. 
+
+
+(defvar *initialization-generic-functions* (list #'make-instance #'default-initargs 
+                                                 #'allocate-instance #'initialize-instance
+                                                 #'shared-initialize))
+
+(defmethod maybe-update-constructors ((generic-function generic-function)
+                                      (method method))
+       (when (memq generic-function *initialization-generic-functions*)
+           (labels ((recurse (class)
+                           (update-constructors class)
+                           (dolist (subclass (class-direct-subclasses class))
+                               (recurse subclass))))
+                  (when (classp (car (method-specializers method)))
+                      (recurse (car (method-specializers method)))))))
+
+(defmethod update-constructors ((class std-class))
+       (dolist (cons (class-constructors class))
+           (install-lazy-constructor-installer cons)))
+
+(defmethod update-constructors ((class class))
+       nil)
+
+(defmethod compatible-meta-class-change-p (class proto-new-class)
+       (eq (class-of class)
+           (class-of proto-new-class)))
+
+(defmethod check-super-metaclass-compatibility ((class t)
+                                                (new-super t))
+       (unless (eq (class-of class)
+                   (class-of new-super))
+           (error "The class ~S was specified as a~%super-class of the class ~S;~%~
+            but the meta-classes ~S and~%~S are incompatible." new-super class (class-of new-super)
+                  (class-of class))))
+
+
+;;; 
+
+
+(defun force-cache-flushes (class)
+       (let* ((owrapper (class-wrapper class))
+              (state (wrapper-state owrapper)))
+             
+             ;; We only need to do something if the state is still T.  If the state isn't T, it will
+             ;; be FLUSH or OBSOLETE, and both of those will already be doing what we want.  In
+             ;; particular, we must be sure we never change an OBSOLETE into a FLUSH since OBSOLETE
+             ;; means do what FLUSH does and then some. 
+             (when (eq state 't)
+                 (let ((nwrapper (make-wrapper class)))
+                      (setf (wrapper-instance-slots-layout nwrapper)
+                            (wrapper-instance-slots-layout owrapper))
+                      (setf (wrapper-class-slots nwrapper)
+                            (wrapper-class-slots owrapper))
+                      (without-interrupts (setf (slot-value class 'wrapper)
+                                                nwrapper)
+                             (invalidate-wrapper owrapper 'flush nwrapper))
+                      (update-constructors class)))))
+
+                                                             ; ??? ***
+
+
+(defun flush-cache-trap (owrapper nwrapper instance)
+       (declare (ignore owrapper))
+       (set-wrapper instance nwrapper))
+
+
+;;; make-instances-obsolete can be called by user code.  It will cause the next access to the
+;;; instance (as defined in 88-002R) to trap through the update-instance-for-redefined-class
+;;; mechanism. 
+
+
+(defmethod make-instances-obsolete ((class std-class))
+       (let ((owrapper (class-wrapper class))
+             (nwrapper (make-wrapper class)))
+            (setf (wrapper-instance-slots-layout nwrapper)
+                  (wrapper-instance-slots-layout owrapper))
+            (setf (wrapper-class-slots nwrapper)
+                  (wrapper-class-slots owrapper))
+            (without-interrupts (setf (slot-value class 'wrapper)
+                                      nwrapper)
+                   (invalidate-wrapper owrapper 'obsolete nwrapper)
+                   class)))
+
+(defmethod make-instances-obsolete ((class symbol))
+       (make-instances-obsolete (find-class class)))
+
+
+;;; obsolete-instance-trap is the internal trap that is called when we see an obsolete instance. 
+;;; The times when it is called are: - when the instance is involved in method lookup - when
+;;; attempting to access a slot of an instance It is not called by class-of, wrapper-of, or any of
+;;; the low-level instance access macros. Of course these times when it is called are an internal
+;;; implementation detail of CLOS and are not part of the documented description of when the obsolete
+;;; instance update happens.  The documented description is as it appears in 88-002R. This has to
+;;; return the new wrapper, so it counts on all the methods on obsolete-instance-trap-internal to
+;;; return the new wrapper.  It also does a little internal error checking to make sure that the
+;;; traps are only happening when they should, and that the trap methods are computing apropriate
+;;; new wrappers. 
+
+
+(defun obsolete-instance-trap (owrapper nwrapper instance)
+       
+       ;; local  --> local        transfer local  --> shared       discard local  -->  --         
+       ;; discard shared --> local        transfer shared --> shared       discard shared -->  --   
+       ;; discard --    --> local        add --    --> shared        -- 
+       (let* ((class (wrapper-class nwrapper))
+              (guts (allocate-instance class))
+                                                             ; ??? allocate-instance ???
+              (olayout (wrapper-instance-slots-layout owrapper))
+              (nlayout (wrapper-instance-slots-layout nwrapper))
+              (oslots (get-slots instance))
+              (nslots (get-slots guts))
+              (oclass-slots (wrapper-class-slots owrapper))
+              (added nil)
+              (discarded nil)
+              (plist nil))
+             
+             ;; Go through all the old local slots. 
+             (iterate ((name (list-elements olayout))
+                       (opos (interval :from 0)))
+                    (let ((npos (posq name nlayout)))
+                         (if npos
+                             (setf (svref nslots npos)
+                                   (svref oslots opos))
+                             (progn (push name discarded)
+                                    (unless (eq (svref oslots opos)
+                                                *slot-unbound*)
+                                        (setf (getf plist name)
+                                              (svref oslots opos)))))))
+             
+             ;; Go through all the old shared slots. 
+             (iterate ((oclass-slot-and-val (list-elements oclass-slots)))
+                    (let ((name (car oclass-slot-and-val))
+                          (val (cdr oclass-slot-and-val)))
+                         (let ((npos (posq name nlayout)))
+                              (if npos
+                                  (setf (svref nslots npos)
+                                        (cdr oclass-slot-and-val))
+                                  (progn (push name discarded)
+                                         (unless (eq val *slot-unbound*)
+                                             (setf (getf plist name)
+                                                   val)))))))
+             
+             ;; Go through all the new local slots to compute the added slots. 
+             (dolist (nlocal nlayout)
+                 (unless (or (memq nlocal olayout)
+                             (assq nlocal oclass-slots))
+                        (push nlocal added)))
+             (without-interrupts (set-wrapper instance nwrapper)
+                    (set-slots instance nslots))
+             (update-instance-for-redefined-class instance added discarded plist)
+             nwrapper))
+
+
+;;; 
+
+
+(defmacro change-class-internal (wrapper-fetcher slots-fetcher alloc)
+       `(let* ((old-class (class-of instance))
+               (copy (,alloc old-class))
+               (guts (,alloc new-class))
+               (new-wrapper (,wrapper-fetcher guts))
+               (old-wrapper (class-wrapper old-class))
+               (old-layout (wrapper-instance-slots-layout old-wrapper))
+               (new-layout (wrapper-instance-slots-layout new-wrapper))
+               (old-slots (,slots-fetcher instance))
+               (new-slots (,slots-fetcher guts))
+               (old-class-slots (wrapper-class-slots old-wrapper)))
+              
+              ;; "The values of local slots specified by both the class Cto and Cfrom are retained. 
+              ;; If such a local slot was unbound, it remains unbound." 
+              (iterate ((new-slot (list-elements new-layout))
+                        (new-position (interval :from 0)))
+                     (let ((old-position (position new-slot old-layout :test #'eq)))
+                          (when old-position
+                              (setf (svref new-slots new-position)
+                                    (svref old-slots old-position)))))
+              
+              ;; "The values of slots specified as shared in the class Cfrom and as local in the
+              ;; class Cto are retained." 
+              (iterate ((slot-and-val (list-elements old-class-slots)))
+                     (let ((position (position (car slot-and-val)
+                                            new-layout :test #'eq)))
+                          (when position
+                              (setf (svref new-slots position)
+                                    (cdr slot-and-val)))))
+              
+              ;; Make the copy point to the old instance's storage, and make the old instance point
+              ;; to the new storage. 
+              (without-interrupts (setf (,slots-fetcher copy)
+                                        old-slots)
+                     (setf (,wrapper-fetcher instance)
+                           new-wrapper)
+                     (setf (,slots-fetcher instance)
+                           new-slots))
+              (update-instance-for-different-class copy instance)
+              instance))
+
+(defmethod change-class ((instance standard-object)
+                         (new-class standard-class))
+       (unless (std-instance-p instance)
+           (error "Can't change the class of ~S to ~S~@
+            because it isn't already an instance with metaclass~%~S." instance new-class 
+                  'standard-class))
+       (change-class-internal std-instance-wrapper std-instance-slots allocate-instance))
+
+(defmethod change-class ((instance standard-object)
+                         (new-class funcallable-standard-class))
+       (unless (fsc-instance-p instance)
+           (error "Can't change the class of ~S to ~S~@
+            because it isn't already an instance with metaclass~%~S." instance new-class 
+                  'funcallable-standard-class))
+       (change-class-internal fsc-instance-wrapper fsc-instance-slots allocate-instance))
+
+(defmethod change-class ((instance t)
+                         (new-class-name symbol))
+       (change-class instance (find-class new-class-name)))
+
+
+;;; The metaclass BUILT-IN-CLASS This metaclass is something of a weird creature.  By this point,
+;;; all instances of it which will exist have been created, and no instance is ever created by
+;;; calling MAKE-INSTANCE. But, there are other parts of the protcol we must follow and those
+;;; definitions appear here. 
+
+
+(defmethod shared-initialize :before ((class built-in-class)
+                                      slot-names &rest initargs)
+       (declare (ignore slot-names))
+       (error "Attempt to initialize or reinitialize a built in class."))
+
+(defmethod class-direct-slots ((class built-in-class))
+       nil)
+
+(defmethod class-slots ((class built-in-class))
+       nil)
+
+(defmethod class-direct-default-initargs ((class built-in-class))
+       nil)
+
+(defmethod class-default-initargs ((class built-in-class))
+       nil)
+
+(defmethod check-super-metaclass-compatibility ((c class)
+                                                (s built-in-class))
+       (or (eq s *the-class-t*)
+           (error "~S cannot have ~S as a super.~%~
+              The class ~S is the only built in class that can be a~%~
+              superclass of a standard class." c s *the-class-t*)))
+
+
+;;; 
+
+
+(defmethod check-super-metaclass-compatibility ((c std-class)
+                                                (f forward-referenced-class))
+       't)
+
+
+;;; 
+
+
+(defmethod add-dependent ((metaobject dependent-update-mixin)
+                          dependent)
+       (pushnew dependent (plist-value metaobject 'dependents)))
+
+(defmethod remove-dependent ((metaobject dependent-update-mixin)
+                             dependent)
+       (setf (plist-value metaobject 'dependents)
+             (delete dependent (plist-value metaobject 'dependents))))
+
+(defmethod map-dependents ((metaobject dependent-update-mixin)
+                           function)
+       (dolist (dependent (plist-value metaobject 'dependents))
+           (funcall function dependent)))

clos/3.5/vector.lisp

@@ -0,0 +1,368 @@
+;;;-*-Mode:LISP; Package:(CLOS LISP 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1991 Venue
+;;; All rights reserved.
+;;; *************************************************************************
+;;;
+;;; Permutation vectors.
+;;;
+
+(in-package 'clos)
+
+(defmacro instance-slot-index (wrapper slot-name)
+  `(let ((pos 0))
+     (block loop
+       (dolist (sn (wrapper-instance-slots-layout ,wrapper))
+	 (when (eq ,slot-name sn) (return-from loop pos))
+	 (incf pos)))))
+
+
+;;;
+;;;
+;;;
+(defmacro %isl-cache           (isl) `(%svref ,isl 1))
+(defmacro %isl-field           (isl) `(%svref ,isl 2))
+(defmacro %isl-mask            (isl) `(%svref ,isl 3))
+(defmacro %isl-size            (isl) `(%svref ,isl 4))
+(defmacro %isl-slot-name-lists (isl) `(%svref ,isl 5))
+
+(defun make-isl (slot-name-lists)
+  (multiple-value-bind (mask size)
+      (compute-primary-pv-cache-size slot-name-lists)
+    (make-isl-internal (wrapper-field 'number)
+		       (get-cache size)
+		       mask
+		       size
+		       slot-name-lists)))
+
+(defun make-isl-internal (field cache mask size slot-name-lists)  
+  (let ((isl (make-array 6)))
+    (setf (svref isl 0)               'isl
+	  (%isl-cache isl)            cache
+	  (%isl-field isl)            field
+	  (%isl-mask  isl)            mask
+	  (%isl-size  isl)            size
+	  (%isl-slot-name-lists isl)  slot-name-lists)
+    isl))
+
+(defun make-isl-type-declaration (var)
+  `(type simple-vector ,var))
+
+(defun islp (x)
+  (and (simple-vector-p x)
+       (= (array-dimension x 0) 5)
+       (eq (svref x 0) 'isl)))
+
+(defvar *slot-name-lists-inner* (make-hash-table :test #'equal))
+(defvar *slot-name-lists-outer* (make-hash-table :test #'equal))
+
+(defun intern-slot-name-lists (slot-name-lists)
+  (flet ((inner (x) 
+	   (or (gethash x *slot-name-lists-inner*)
+	       (setf (gethash x *slot-name-lists-inner*) (copy-list x))))
+	 (outer (x) 
+	   (or (gethash x *slot-name-lists-outer*)
+	       (setf (gethash x *slot-name-lists-outer*) (make-isl (copy-list x))))))
+    (outer (mapcar #'inner slot-name-lists))))
+
+
+
+(defvar *pvs* (make-hash-table :test #'equal))
+
+(defvar default-svuc-method nil)
+(defvar default-setf-svuc-method nil)
+
+(defun optimize-slot-value-by-class-p (class slot-name setf-p)
+  (or (not (eq *boot-state* 'complete))
+      (let* ((slot-definition (find-slot-definition class slot-name))
+	     (gfun-name (if setf-p
+			    '(setf slot-value-using-class) 'slot-value-using-class))
+	     (gfun (gdefinition gfun-name))
+	     (csym (if setf-p 'default-setf-svuc-method 'default-svuc-method))
+	     (app-methods nil))
+	(dolist (method (generic-function-methods gfun))
+	  (let* ((mspecs (method-specializers method))
+		 (specs (if setf-p (cdr mspecs) mspecs)))
+	    (when (and (specializer-applicable-p (first specs) class)
+		       (specializer-applicable-using-class-p (second specs) class)
+		       (specializer-applicable-p (third specs) slot-definition))
+	      (push method app-methods))))
+	(and app-methods (null (cdr app-methods))
+	     (eq (car app-methods)
+		 (or (symbol-value csym)
+		     (let* ((specs (if setf-p
+				       '(t
+					 std-class 
+					 standard-object
+					 standard-effective-slot-definition)
+				       '(std-class 
+					 standard-object
+					 standard-effective-slot-definition)))
+			    (slist (mapcar #'find-class specs)))
+		       (set csym (get-method gfun nil slist)))))))))
+
+(defun lookup-pv (isl args)
+  (let* ((class-slot-p nil)
+	 (elements
+	  (gathering1 (collecting)
+	    (iterate ((slot-names (list-elements (%isl-slot-name-lists isl)))
+		      (arg (list-elements args)))
+	      (when slot-names
+		(let* ((wrapper     (check-wrapper-validity arg))
+		       (class       (wrapper-class wrapper))
+		       (class-slots (wrapper-class-slots wrapper)))
+		  (dolist (slot-name slot-names)
+		    (if (and (optimize-slot-value-by-class-p
+			      class slot-name nil)
+			     (optimize-slot-value-by-class-p
+			      class slot-name t))
+			(let ((index (instance-slot-index wrapper slot-name)))
+			  (if index
+			      (gather1 index)
+			      (let ((cell (assq slot-name class-slots)))
+				(if cell
+				    (progn (setq class-slot-p t) (gather1 cell))
+				    (gather1 nil)))))
+			(gather1 nil)))))))))
+    (if class-slot-p				;Sure is a shame Common Lisp doesn't
+	(make-permutation-vector elements)	;give me the right kind of hash table.
+	(or (gethash elements *pvs*)
+	    (setf (gethash elements *pvs*) (make-permutation-vector elements))))))
+
+(defun make-permutation-vector (indexes)
+  (make-array (length indexes) :initial-contents indexes))
+
+(defun make-pv-type-declaration (var)
+  `(type simple-vector ,var))
+
+(defmacro pvref (pv index)
+  `(svref ,pv ,index))
+
+
+
+(defun can-optimize-access (var required-parameters env)
+  (let ((rebound? (caddr (variable-declaration 'variable-rebinding var env))))
+    (if rebound?
+	(car (memq rebound? required-parameters))
+	(car (memq var required-parameters)))))
+
+(defun optimize-slot-value (slots parameter form)
+  (destructuring-bind (ignore ignore slot-name)
+		      form
+    (optimize-instance-access slots :read parameter (eval slot-name) nil)))
+
+(defun optimize-set-slot-value (slots parameter form)
+  (destructuring-bind (ignore ignore slot-name new-value)
+		      form
+    (optimize-instance-access slots :write parameter (eval slot-name) new-value)))
+
+;;;
+;;; The <slots> argument is an alist, the CAR of each entry is the name of
+;;; a required parameter to the function.  The alist is in order, so the
+;;; position of an entry in the alist corresponds to the argument's position
+;;; in the lambda list.
+;;; 
+(defun optimize-instance-access (slots read/write parameter slot-name new-value)
+  (let* ((parameter-entry (assq parameter slots))
+	 (slot-entry      (assq slot-name (cdr parameter-entry)))
+	 (position (position parameter-entry slots)))
+    (unless parameter-entry
+      (error "Internal error in slot optimization."))
+    (unless slot-entry
+      (setq slot-entry (list slot-name))
+      (push slot-entry (cdr parameter-entry)))
+    (ecase read/write
+      (:read
+	(let ((form (list 'instance-read ''.PV-OFFSET. parameter position 
+			  `',slot-name)))
+	  (push form (cdr slot-entry))
+	  form))
+      (:write
+	(let ((form (list 'instance-write ''.PV-OFFSET. parameter position 
+			  `',slot-name '.new-value.)))
+	  (push form (cdr slot-entry))
+	  `(let ((.new-value. ,new-value)) ,form))))))
+
+(define-walker-template instance-read)
+(define-walker-template instance-write)
+
+
+(defmacro instance-read (pv-offset parameter position slot-name)
+  `(locally
+     (declare (optimize (speed 3) (safety 0) (compilation-speed 0)))
+     (let ((.INDEX. (pvref .PV. ,pv-offset)))
+       (if (and (typep .INDEX. 'fixnum)
+		(neq (setq .INDEX. (%svref ,(slot-vector-symbol position) .INDEX.))
+		     ',*slot-unbound*))
+	   .INDEX.
+	   (pv-access-trap ,parameter .PV. ,pv-offset ,slot-name)))))
+
+(defmacro instance-write (pv-offset parameter position slot-name new-value)
+  `(locally
+     (declare (optimize (speed 3) (safety 0) (compilation-speed 0)))
+     (let ((.INDEX. (pvref .PV. ,pv-offset)))
+       (if (typep .INDEX. 'fixnum)
+	   (setf (%svref ,(slot-vector-symbol position) .INDEX.) ,new-value)
+	   (pv-access-trap ,parameter .PV. ,pv-offset ,slot-name ,new-value)))))
+
+(defun pv-access-trap (instance pv offset slot-name &optional (new-value nil nvp))
+  ;;
+  ;; First thing we do is a quick check to see if this is a class variable.
+  ;; This could be done inline by moving it to INSTANCE-READ/WRITE.  I did
+  ;; not do that because I don't know whether its worth it.
+  ;;
+  (let ((cell (pvref pv offset)))
+    (if (consp cell)
+	(if nvp (setf (cdr cell) new-value) (cdr cell))
+	;;
+	;; Well, now do a slow trap.
+	;; 
+	(if nvp
+	    (setf (slot-value instance slot-name) new-value)
+	    (slot-value instance slot-name)))))
+
+;;;
+;;; This magic function has quite a job to do indeed.
+;;;
+;;; The careful reader will recall that <slots> contains all of the optimized
+;;; slot access forms produced by OPTIMIZE-INSTANCE-ACCESS.  Each of these is
+;;; a call to either INSTANCE-READ or INSTANCE-WRITE.
+;;;
+;;; At the time these calls were produced, the first argument was specified as
+;;; the symbol .PV-OFFSET.; what we have to do now is convert those pv-offset
+;;; arguments into the actual number that is the correct offset into the pv.
+;;;
+;;; But first, oh but first, we sort <slots> a bit so that for each argument
+;;; we have the slots in alphabetical order.  This canonicalizes the ISL's a
+;;; bit and will hopefully lead to having fewer PV's floating around.  Even
+;;; if the gain is only modest, it costs nothing.
+;;;  
+(defun slot-name-lists-from-slots (slots)
+  (mapcar #'(lambda (parameter-entry) (mapcar #'car (cdr parameter-entry)))
+	  (mutate-slots slots)))
+
+(defun mutate-slots (slots)
+  (let ((sorted (sort-slots slots))
+	(pv-offset -1))
+    (dolist (parameter-entry sorted)
+      (dolist (slot-entry (cdr parameter-entry))
+	(incf pv-offset)	
+	(dolist (form (cdr slot-entry))
+	  (setf (cadr form) pv-offset))))
+    sorted))
+
+(defun sort-slots (slots)
+  (mapcar #'(lambda (parameter-entry)
+	      (cons (car parameter-entry)
+		    (sort (cdr parameter-entry)	;slot entries
+			  #'(lambda (a b)
+			      (string-lessp (symbol-name (car a))
+					    (symbol-name (car b)))))))
+	  slots))
+
+
+;;;
+;;; This needs to work in terms of metatypes and also needs to work for
+;;; automatically generated reader and writer functions.
+;;;   
+(defun add-pv-binding (method-body plist required-parameters)
+  (let* ((isl (getf plist :isl))
+	 (isl-cache-symbol (make-symbol "isl-cache")))
+    (nconc plist (list :isl-cache-symbol isl-cache-symbol))
+    (with-gathering ((slot-variables (collecting))
+		     (metatypes (collecting)))
+	  (iterate ((slots (list-elements isl))
+		    (i (interval :from 0)))
+	    (cond (slots
+		   (gather (slot-vector-symbol i) slot-variables)
+		   (gather 'standard-instance     metatypes))
+		  (t
+		   (gather nil slot-variables)
+		   (gather t   metatypes))))
+      `((let ((.ISL. (locally (declare (special ,isl-cache-symbol)) ,isl-cache-symbol))
+	      (.PV. *empty-vector*)
+	      ,@(remove nil slot-variables))
+	  (declare ,(make-isl-type-declaration '.ISL.)
+		   ,(make-pv-type-declaration '.PV.))
+	
+	  (let* ((cache (%isl-cache .ISL.))
+		 (size  (%isl-size  .ISL.))
+		 (mask  (%isl-mask  .ISL.))
+		 (field (%isl-field .ISL.)))
+	    ,(generating-lap-in-lisp '(cache size mask field)
+				     required-parameters
+	       (flatten-lap
+		 (emit-pv-dlap required-parameters metatypes slot-variables))))
+
+	  ,@method-body)))))
+
+(defun emit-pv-dlap (required-parameters metatypes slot-variables)
+  (let* ((slot-regs (mapcar #'(lambda (sv) (and sv (operand :lisp-variable sv)))
+			    slot-variables))
+	 (wrappers (dlap-wrappers metatypes))
+	 (nwrappers (remove nil wrappers)))
+    (flet ((wrapper-moves (miss-label)
+	     (dlap-wrapper-moves wrappers required-parameters metatypes miss-label slot-regs)))
+      (prog1 (emit-dlap-internal
+	       nwrappers                   ;wrapper-regs
+	       (wrapper-moves 'pv-miss)    ;wrapper-moves
+	       (opcode :exit-lap-in-lisp)  ;hit
+	       (flatten-lap		   ;miss
+		 (opcode :label 'pv-miss)
+		 (opcode :move
+			 (operand :lisp `(primary-pv-cache-miss
+					  .ISL. ,@required-parameters))
+			 (operand :lisp-variable '.PV.))
+		 (apply #'flatten-lap (wrapper-moves 'pv-wrapper-miss)) ; -- Maybe the wrappers have changed.
+		 (opcode :label 'pv-wrapper-miss)
+		 (opcode :exit-lap-in-lisp))                               
+	       'pv-miss			    ;miss-label
+	       (operand :lisp-variable '.PV.)) ;value-reg
+	   (mapc #'deallocate-register nwrappers)))))
+
+(defun compute-primary-pv-cache-size (slot-name-lists)
+  (compute-cache-parameters (- (length slot-name-lists) (count nil slot-name-lists))
+			    t
+			    2))
+
+(defun pv-cache-limit-fn (nlines)
+  (default-limit-fn nlines))
+
+(defun primary-pv-cache-miss (isl &rest args)
+  (let* ((wrappers
+	   (gathering1 (collecting) 
+	     (iterate ((slot-names (list-elements (%isl-slot-name-lists isl)))
+		       (arg        (list-elements args)))
+	       (when slot-names (gather1 (check-wrapper-validity arg))))))
+	 (pv (lookup-pv isl args))
+	 (field (%isl-field isl))
+	 (cache (%isl-cache isl))
+	 (nkeys (length wrappers)))
+    (multiple-value-bind (new-field new-cache new-mask new-size)
+	(fill-cache field cache nkeys t #'pv-cache-limit-fn
+		    (if (= nkeys 1) (car wrappers) wrappers)
+		    pv)
+      (when (or (not (= new-field field))
+		(not (eq new-cache cache)))
+	(without-interrupts			;NOTE:
+	  (setf (%isl-field isl) new-field	; There is no mechanism to
+		(%isl-cache isl) new-cache	; synchronize the reading of
+		(%isl-size  isl) new-size	; these values.  But, this is
+		(%isl-mask  isl) new-mask))	; a safe order to write them
+						; in.  Stricly speaking, the
+						; use of without-interrupts
+						; is superfluous.
+	(when (neq new-cache cache) (free-cache cache))))
+    pv))
+
+
+
+(defmethod wrapper-fetcher ((class standard-class))
+  'std-instance-wrapper)
+
+(defmethod slots-fetcher ((class standard-class))
+  'std-instance-slots)
+
+(defmethod raw-instance-allocator ((class standard-class))
+  '%%allocate-instance--class)