diff --git a/pcl/boot.lisp b/pcl/boot.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..b090315c7ce35a53b4dbb6cd422f4cdc9304cdef
--- /dev/null
+++ b/pcl/boot.lisp
@@ -0,0 +1,1389 @@
+;;;-*-Mode: LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+
+(in-package 'pcl)
+
+#|
+
+The CommonLoops evaluator is meta-circular.  
+
+Most of the code in PCL is methods on generic functions, including most of
+the code that actually implements generic functions and method lookup.
+
+So, we have a classic bootstrapping problem.   The solution to this is to
+first get a cheap implementation of generic functions running, these are
+called early generic functions.  These early generic functions and the
+corresponding early methods and early method lookup are used to get enough
+of the system running that it is possible to create real generic functions
+and methods and implement real method lookup.  At that point (done in the
+file FIXUP) the function fix-early-generic-functions is called to convert
+all the early generic functions to real generic functions.
+
+The cheap generic functions are built using the same funcallable-instance
+objects real generic-functions are made out of.  This means that as PCL
+is being bootstrapped, the cheap generic function objects which are being
+created are the same objects which will later be real generic functions.
+This is good because:
+  - we don't cons garbage structure
+  - we can keep pointers to the cheap generic function objects
+    during booting because those pointers will still point to
+    the right object after the generic functions are all fixed
+    up
+
+
+
+This file defines the defmethod macro and the mechanism used to expand it.
+This includes the mechanism for processing the body of a method.  defmethod
+basically expands into a call to load-defmethod, which basically calls
+add-method to add the method to the generic-function.  These expansions can
+be loaded either during bootstrapping or when PCL is fully up and running.
+
+An important effect of this structure is it means we can compile files with
+defmethod forms in them in a completely running PCL, but then load those files
+back in during bootstrapping.  This makes development easier.  It also means
+there is only one set of code for processing defmethod.  Bootstrapping works
+by being sure to have load-method be careful to call only primitives which
+work during bootstrapping.
+
+|#
+
+(proclaim '(notinline make-a-method
+		      add-named-method		      
+		      ensure-generic-function-using-class
+
+		      add-method
+		      remove-method
+		      ))
+
+(defvar *early-functions*
+	'((make-a-method early-make-a-method
+			 real-make-a-method)
+	  (add-named-method early-add-named-method
+			    real-add-named-method)
+	  ))
+
+;;;
+;;; For each of the early functions, arrange to have it point to its early
+;;; definition.  Do this in a way that makes sure that if we redefine one
+;;; of the early definitions the redefinition will take effect.  This makes
+;;; development easier.
+;;;
+;;; The function which generates the redirection closure is pulled out into
+;;; a separate piece of code because of a bug in ExCL which causes this not
+;;; to work if it is inlined.
+;;;
+(eval-when (load eval)
+
+  (defun redirect-early-function-internal (to)
+    #'(lambda (&rest args) (apply (symbol-function to) args)))
+  
+  (dolist (fns *early-functions*)
+    (let ((name (car fns))
+	  (early-name (cadr fns)))
+      (setf (symbol-function name)
+	    (redirect-early-function-internal early-name))))
+
+  )
+
+
+;;;
+;;; *generic-function-fixups* is used by fix-early-generic-functions to
+;;; convert the few functions in the bootstrap which are supposed to be
+;;; generic functions but can't be early on.
+;;; 
+(defvar *generic-function-fixups*
+    '((add-method
+	((generic-function method)		        ;lambda-list
+	 (standard-generic-function method)	        ;specializers
+	 real-add-method))			        ;method-function
+      (remove-method
+	((generic-function method)
+	 (standard-generic-function method)
+	 real-remove-method))
+      (get-method
+        ((generic-function qualifiers specializers &optional (errorp t))
+	 (standard-generic-function t t)
+	 real-get-method))
+      (ensure-generic-function-using-class
+	((generic-function function-specifier
+			   &key generic-function-class environment
+			   &allow-other-keys)
+	 (generic-function t)
+	 real-ensure-gf-using-class--generic-function)
+	((generic-function function-specifier
+			   &key generic-function-class environment
+			   &allow-other-keys)
+	 (null t)
+	 real-ensure-gf-using-class--null))
+      ))
+
+
+;;;
+;;;
+;;;
+(defmacro defgeneric (function-specifier lambda-list &body options)
+  (expand-defgeneric function-specifier lambda-list options))
+
+(defun expand-defgeneric (function-specifier lambda-list options)
+  (when (listp function-specifier) (do-standard-defsetf-1 (cadr function-specifier)))
+  (let ((initargs ()))
+    (flet ((duplicate-option (name)
+	     (error "The option ~S appears more than once." name)))
+      ;;
+      ;; INITARG takes this screwy new argument to get around a bad
+      ;; interaction between lexical macros and setf in the Lucid
+      ;; compiler.
+      ;; 
+      (macrolet ((initarg (key &optional new)
+		   (if new
+		       `(setf (getf initargs ,key) ,new)
+		       `(getf initargs ,key))))
+	(dolist (option options)
+	  (ecase (car option)
+	    (:argument-precedence-order
+	      (if (initarg :argument-precedence-order)
+		  (duplicate-option :argument-precedence-order)
+		  (initarg :argument-precedence-order `',(cdr option))))
+	    (declare
+	      (initarg :declarations
+		       (append (cdr option) (initarg :declarations))))
+	    (:documentation
+	      (if (initarg :documentation)
+		  (duplicate-option :documentation)
+		  (initarg :documentation `',(cadr option))))
+	    (:method-combination
+	      (if (initarg :method-combination)
+		  (duplicate-option :method-combination)
+		  (initarg :method-combination `',(cdr option))))
+	    (:generic-function-class
+	      (if (initarg :generic-function-class)
+		  (duplicate-option :generic-function-class)
+		  (initarg :generic-function-class `',(cadr option))))
+	    (:method-class
+	      (if (initarg :method-class)
+		  (duplicate-option :method-class)
+		  (initarg :method-class `',(cadr option))))
+	    (:method
+	      (error
+		"DEFGENERIC doesn't support the :METHOD option yet."))))
+
+	(let ((declarations (initarg :declarations)))
+	  (when declarations (initarg :declarations `',declarations)))))
+
+    (make-top-level-form `(defgeneric ,function-specifier)
+			 *defgeneric-times*
+      `(load-defgeneric ',function-specifier ',lambda-list ,@initargs))))
+
+(defun load-defgeneric (function-specifier lambda-list &rest initargs)
+  (when (listp function-specifier) (do-standard-defsetf-1 (cadr function-specifier)))
+  (apply #'ensure-generic-function
+	 function-specifier
+	 :lambda-list lambda-list
+	 :definition-source `((defgeneric ,function-specifier)
+			      ,(load-truename))
+	 initargs))
+
+
+;;;
+;;;
+;;;
+(defmacro DEFMETHOD (&rest args &environment env)
+  #+(or (not :lucid) :lcl3.0)	
+  (declare (arglist name
+		    {method-qualifier}*
+		    specialized-lambda-list
+		    &body body))
+  (multiple-value-bind (name qualifiers lambda-list body)
+      (parse-defmethod args)
+    (let ((proto-method (method-prototype-for-gf name)))
+      (expand-defmethod
+	proto-method name qualifiers lambda-list body env))))
+
+;;;
+;;; takes a name which is either a generic function name or a list specifying
+;;; a setf generic function (like: (SETF <generic-function-name>)).  Returns
+;;; the prototype instance of the method-class for that generic function.
+;;;
+;;; If there is no generic function by that name, this returns the default
+;;; value, the prototype instance of the class STANDARD-METHOD.  This default
+;;; value is also returned if the spec names an ordinary function or even a
+;;; macro.  In effect, this leaves the signalling of the appropriate error
+;;; until load time.
+;;;
+;;; NOTE that during bootstrapping, this function is allowed to return NIL.
+;;; 
+(defun method-prototype-for-gf (name)      
+  (let ((gf? (and (gboundp name)
+		  (gdefinition name))))
+    (cond ((neq *boot-state* 'complete) nil)
+	  ((or (null gf?)
+	       (not (generic-function-p gf?)))	        ;Someone else MIGHT
+						        ;error at load time.
+	   (class-prototype (find-class 'standard-method)))
+	  (t
+	    (class-prototype (or (generic-function-method-class gf?)
+				 (find-class 'standard-method)))))))
+
+
+#-Genera
+(defun expand-defmethod (proto-method name qualifiers lambda-list body env)
+  (when (listp name) (do-standard-defsetf-1 (cadr name)))
+  (multiple-value-bind (fn-form specializers doc plist)
+      (expand-defmethod-internal name qualifiers lambda-list body env)
+    (make-top-level-form `(defmethod ,name ,@qualifiers ,specializers)
+			 *defmethod-times*
+      `(load-defmethod
+	 ',(if proto-method
+	       (class-name (class-of proto-method))
+	       'standard-method)
+	 ',name
+	 ',qualifiers
+	 (list ,@(mapcar #'(lambda (specializer)
+			     (if (and (consp specializer)
+				      (eq (car specializer) 'eql))
+				 ``(eql ,,(cadr specializer))
+				 `',specializer))
+			 specializers))
+	 ',(specialized-lambda-list-lambda-list lambda-list)
+	 ',doc
+	 ',(getf plist :isl-cache-symbol)	;Paper over a bug in KCL by
+						;passing the cache-symbol
+						;here in addition to in the
+						;plist.
+	 ',plist
+	 ,fn-form))))
+
+#+Genera
+(defun expand-defmethod (proto-method name qualifiers lambda-list body env)
+  (when (listp name) (do-standard-defsetf-1 (cadr name)))
+  (multiple-value-bind (fn-form specializers doc plist)
+      (expand-defmethod-internal name qualifiers lambda-list body env)
+    (declare (ignore doc plist))
+    (let ((fn-args (cadadr fn-form))
+	  (fn-body (cddadr fn-form)))
+      `(defun (method ,name ,@qualifiers ,specializers) ,fn-args
+	 (declare ,@(when proto-method
+		      `((pcl-method-class
+			  ,(class-name (class-of proto-method)))))
+		  (pcl-lambda-list
+		    ,(specialized-lambda-list-lambda-list lambda-list)))
+	 ,@fn-body))))
+
+(defun expand-defmethod-internal
+       (generic-function-name qualifiers specialized-lambda-list body env)
+  (declare (values fn-form specializers doc)
+	   (ignore qualifiers))
+  (when (listp generic-function-name)
+    (do-standard-defsetf-1 (cadr generic-function-name)))
+  (multiple-value-bind (documentation declarations real-body)
+      (extract-declarations body)
+    (multiple-value-bind (parameters lambda-list specializers)
+	(parse-specialized-lambda-list specialized-lambda-list)
+
+      
+      (let* ((required-parameters
+	       (mapcar #'(lambda (r s) (declare (ignore s)) r)
+		       parameters
+		       specializers))
+	     (parameters-to-reference
+	       (make-parameter-references specialized-lambda-list
+					  required-parameters
+					  declarations
+					  generic-function-name
+					  specializers))
+	     (class-declarations 
+	       `(declare
+		  ,@(remove nil
+			    (mapcar #'(lambda (a s) (and (symbolp s)
+							 (neq s 't)
+							 `(class ,a ,s)))
+				    parameters
+				    specializers))))
+	     (method-lambda 
+	       ;; Remove the documentation string and insert the
+	       ;; appropriate class declarations.  The documentation
+	       ;; string is removed to make it easy for us to insert
+	       ;; new declarations later, they will just go after the
+	       ;; cadr of the method lambda.  The class declarations
+	       ;; are inserted to communicate the class of the method's
+	       ;; arguments to the code walk.
+	       (let ()
+		 `(lambda ,lambda-list
+		    ,class-declarations
+		    ,@declarations
+		    (progn ,@parameters-to-reference)
+		    (block ,(if (listp generic-function-name)
+				(cadr generic-function-name)
+				generic-function-name)
+		      ,@real-body))))
+
+	     (call-next-method-p nil)   ;flag indicating that call-next-method
+	                                ;should be in the method definition
+	     (next-method-p-p nil)      ;flag indicating that next-method-p
+                                        ;should be in the method definition
+	     (save-original-args nil)   ;flag indicating whether or not the
+				        ;original arguments to the method
+					;must be preserved.  This happens
+					;for two reasons:
+	                                ; - the method takes &mumble args,
+					;   so one of the lexical functions
+					;   might be used in a default value
+	                                ;   form
+					; - call-next-method is used without
+					;   arguments at least once in the
+					;   body of the method
+	     (original-args ())
+	     (applyp nil)		;flag indicating whether or not the
+					;method takes &mumble arguments. If
+					;it does, it means call-next-method
+					;without arguments must be APPLY'd
+					;to original-args.  If this gets set
+					;true, save-original-args is set so
+					;as well
+	     (aux-bindings ())		;Suffice to say that &aux is one of
+					;damndest things to have put in a
+					;language.
+	     (slots (mapcar #'list required-parameters))
+	     (plist ())
+	     (walked-lambda nil))
+	(flet ((walk-function (form context env)
+		 (cond ((not (eq context ':eval)) form)
+		       ((not (listp form)) form)
+		       ((eq (car form) 'call-next-method)
+			(setq call-next-method-p 't)
+			(setq save-original-args (not (cdr form)))
+			form)
+		       ((eq (car form) 'next-method-p)
+			(setq next-method-p-p 't)
+			form)
+		       ((and (eq (car form) 'function)
+			     (cond ((eq (cadr form) 'call-next-method)
+				    (setq call-next-method-p 't)
+				    (setq save-original-args 't)
+				    form)
+				   ((eq (cadr form) 'next-method-p)
+				    (setq next-method-p-p 't)
+				    form)
+				   (t nil))))
+		       ((and (or (eq (car form) 'slot-value)
+				 (eq (car form) 'set-slot-value))
+			     (symbolp (cadr form))
+			     (constantp (caddr form)))
+			(let ((parameter
+				(can-optimize-access (cadr form) required-parameters env)))
+			  (if (null parameter)
+			      form
+			      (ecase (car form)
+				(slot-value
+				  (optimize-slot-value     slots parameter form))
+				(set-slot-value
+				  (optimize-set-slot-value slots parameter form))))))
+		       (t form))))
+	  
+	  (setq walked-lambda (walk-form method-lambda env #'walk-function))
+
+	  ;;
+	  ;; Add &allow-other-keys to the lambda list as an interim
+	  ;; way of implementing lambda list congruence rules.
+	  ;;
+	  (when (and (memq '&key lambda-list)
+		     (not (memq '&allow-other-keys lambda-list)))
+	    (let* ((rll (reverse lambda-list))
+		   (aux (memq '&aux rll)))
+	      (setq lambda-list
+		    (if aux
+			(progn (setf (cdr aux)
+				     (cons '&allow-other-keys (cdr aux)))
+			       (nreverse rll))
+		        (nconc (nreverse rll) (list '&allow-other-keys))))))
+	  ;; Scan the lambda list to determine whether this method
+	  ;; takes &mumble arguments.  If it does, we set applyp and
+	  ;; save-original-args true.
+	  ;; 
+	  ;; This is also the place where we construct the original
+	  ;; arguments lambda list if there has to be one.
+	  (dolist (p lambda-list)
+	    (if (memq p lambda-list-keywords)
+		(if (eq p '&aux)
+		    (progn
+		      (setq aux-bindings (cdr (memq '&aux lambda-list)))
+		      (return nil))
+		    (progn
+		      (setq applyp t
+			    save-original-args t)
+		      (push '&rest original-args)
+		      (push (make-symbol "AMPERSAND-ARGS") original-args)
+		      (return nil)))
+		(push (make-symbol (symbol-name p)) original-args)))
+	  (setq original-args (if save-original-args
+				  (nreverse original-args)
+				  ()))
+	  
+	  (multiple-value-bind (ignore walked-declarations walked-lambda-body)
+	      (extract-declarations (cddr walked-lambda))
+	    (declare (ignore ignore))
+
+	    
+	    (when (some #'cdr slots)
+	      (setq slots (slot-name-lists-from-slots slots))
+	      (setq plist (list* :isl slots plist))
+	      (setq walked-lambda-body (add-pv-binding walked-lambda-body
+						       plist
+						       required-parameters)))
+	    (when (or next-method-p-p call-next-method-p)
+	      (setq plist (list* :needs-next-methods-p 't plist)))
+
+	    ;;; changes are here... (mt)
+	    (let ((fn-body (if (or call-next-method-p next-method-p-p)
+			      (add-lexical-functions-to-method-lambda
+				walked-declarations
+				walked-lambda-body
+				`(lambda ,lambda-list
+				   ,@walked-declarations
+				   ,.walked-lambda-body)
+				original-args
+				lambda-list
+				save-original-args
+				applyp
+				aux-bindings
+				call-next-method-p
+				next-method-p-p)
+			      `(lambda ,lambda-list
+				 ,@walked-declarations
+				 ,.walked-lambda-body))))
+	      #+Genera
+	      (setq fn-body `(lambda ,(cadr fn-body)
+			       (declare (pcl-documentation ,documentation)
+					(pcl-plist ,plist))
+			       ,@(cddr fn-body)))
+
+	      (values
+		`(function ,fn-body)
+		specializers
+		documentation
+		plist))))))))
+
+(defun add-lexical-functions-to-method-lambda (walked-declarations
+					       walked-lambda-body
+					       walked-lambda
+					       original-args
+					       lambda-list
+					       save-original-args
+					       applyp
+					       aux-bindings
+					       call-next-method-p
+					       next-method-p-p)
+  (cond ((and (null save-original-args)
+	      (null applyp))
+	 ;;
+	 ;; We don't have to save the original arguments.  In addition,
+	 ;; this method doesn't take any &mumble arguments (this means
+	 ;; that there is no way the lexical functions can be used inside
+	 ;; of the default value form for an &mumble argument).
+	 ;;
+	 ;; We can expand this into a simple lambda expression with an
+	 ;; FLET to define the lexical functions.
+	 ;; 
+	 `(lambda ,lambda-list
+	    ,@walked-declarations
+	    (let ((.next-method. (car *next-methods*))
+		  (.next-methods. (cdr *next-methods*)))
+	      (flet (,@(and call-next-method-p
+			    '((call-next-method (&rest cnm-args)
+				#+Genera
+				(declare (dbg:invisible-frame :clos-internal))
+				(if .next-method.
+				    (let ((*next-methods* .next-methods.))
+				      (apply .next-method. cnm-args))
+				    (error "No next method.")))))
+		     ,@(and next-method-p-p
+			    '((next-method-p ()
+				(not (null .next-method.))))))
+		,@walked-lambda-body))))
+	((null applyp)
+	 ;;
+	 ;; This method doesn't accept any &mumble arguments.  But we
+	 ;; do have to save the original arguments (this is because
+	 ;; call-next-method is being called with no arguments).
+	 ;; Have to be careful though, there may be multiple calls to
+	 ;; call-next-method, all we know is that at least one of them
+	 ;; is with no arguments.
+	 ;; 
+	 `(lambda ,original-args
+	    (let ((.next-method. (car *next-methods*))
+		  (.next-methods. (cdr *next-methods*)))
+	      (flet (,@(and call-next-method-p
+                            `((call-next-method (&rest cnm-args)
+				(if .next-method.
+				    (let ((*next-methods* .next-methods.))
+				      (if cnm-args
+					  (apply .next-method. cnm-args)
+					  (funcall .next-method.
+						   ,@original-args)))
+				    (error "No next method.")))))
+		     ,@(and next-method-p-p
+			    '((next-method-p ()
+				(not (null .next-method.))))))
+		(let* (,@(mapcar #'list
+				 (remtail lambda-list (memq '&aux lambda-list))
+				 original-args)
+		       ,@aux-bindings)
+		  ,@walked-declarations
+		  ,@walked-lambda-body)))))
+	(t
+	 ;;
+	 ;; This is the fully general case.
+	 ;; We must allow for the lexical functions being used inside
+	 ;; the default value forms of &mumble arguments, and if must
+	 ;; allow for call-next-method being called with no arguments.
+	 ;; 
+	 `(lambda ,original-args
+	    (let ((.next-method. (car *next-methods*))
+		  (.next-methods. (cdr *next-methods*)))
+	      (flet (,@(and call-next-method-p
+			    `((call-next-method (&rest cnm-args)
+				(if .next-method.
+				    (let ((*next-methods* .next-methods.))
+				      (if cnm-args
+					  (apply .next-method. cnm-args)
+					  (apply .next-method. 
+						 ,@(remove '&rest
+							   original-args))))
+				    (error "No next method.")))))
+		     ,@(and next-method-p-p
+			    '((next-method-p ()
+				(not (null .next-method.))))))
+		(apply (function ,walked-lambda)
+		       ,@(remove '&rest original-args))))))))
+
+
+(defun make-parameter-references (specialized-lambda-list
+				  required-parameters
+				  declarations
+				  generic-function-name
+				  specializers)
+  (flet ((ignoredp (symbol)
+	   (dolist (decl (cdar declarations))
+	     (when (and (eq (car decl) 'ignore)
+			(memq symbol (cdr decl)))
+	       (return t)))))	   
+    (gathering ((references (collecting)))
+      (iterate ((s (list-elements specialized-lambda-list))
+		(p (list-elements required-parameters)))
+	(progn p)
+	(cond ((not (listp s)))
+	      ((ignoredp (car s))
+	       (warn "In defmethod ~S ~S, there is a~%~
+                      redundant ignore declaration for the parameter ~S."
+		     generic-function-name
+		     specializers
+		     (car s)))
+	      (t
+	       (gather (car s) references)))))))
+
+
+(defvar *method-function-plist* (make-hash-table :test #'eq))
+
+(defun method-function-plist (method-function)
+  (gethash method-function *method-function-plist*))
+
+(defun SETF\ PCL\ METHOD-FUNCTION-PLIST (val method-function)
+  (setf (gethash method-function *method-function-plist*) val))
+
+(defun method-function-get (method-function key)
+  (getf (method-function-plist method-function) key))
+
+(defun SETF\ PCL\ METHOD-FUNCTION-GET (val method-function key)
+  (setf (getf  (method-function-plist method-function) key) val))
+
+
+(defun method-function-isl (method-function)
+  (method-function-get method-function :isl))
+
+(defun method-function-needs-next-methods-p (method-function)
+  (method-function-get method-function :needs-next-methods-p))
+
+
+
+
+(defun load-defmethod
+       (class name quals specls ll doc isl-cache-symbol plist fn)
+  (when (listp name) (do-standard-defsetf-1 (cadr name)))
+  (let ((method-spec (make-method-spec name quals specls)))
+    (record-definition 'method method-spec)
+    (setq fn (set-function-name fn method-spec))
+    (load-defmethod-internal
+      name quals specls ll doc isl-cache-symbol plist fn class)))
+
+(defun load-defmethod-internal
+       (gf-spec qualifiers specializers
+	lambda-list doc isl-cache-symbol plist fn method-class)
+  (when (listp gf-spec) (do-standard-defsetf-1 (cadr gf-spec)))
+  (when plist
+    (setq plist (copy-list plist))	     ;Do this to keep from affecting
+					     ;the plist that is about to be
+					     ;dumped when we are compiling.
+    (let ((uisl (getf plist :isl))
+	  (isl nil))
+      (when uisl
+	(setq isl (intern-slot-name-lists uisl))
+	(setf (getf plist :isl) isl))
+      (when isl-cache-symbol
+	(setf (getf plist :isl-cache-symbol) isl-cache-symbol)
+	(set isl-cache-symbol isl)))
+    
+    (setf (method-function-plist fn) plist))
+  (let ((method (add-named-method
+		  gf-spec qualifiers specializers lambda-list fn
+		  :documentation doc
+		  :definition-source `((defmethod ,gf-spec
+						  ,@qualifiers
+						  ,specializers)
+				       ,(load-truename)))))
+    (unless (or (eq method-class 'standard-method)
+		(eq (find-class method-class nil) (class-of method)))
+      (format *error-output*
+	      "At the time the method with qualifiers ~:~S and~%~
+               specializers ~:S on the generic function ~S~%~
+               was compiled, the method-class for that generic function was~%~
+               ~S.  But, the method class is now ~S, this~%~
+               may mean that this method was compiled improperly."
+	      qualifiers specializers gf-spec
+	      method-class (class-name (class-of method))))
+    method))
+
+
+(defun make-method-spec (gf-spec qualifiers unparsed-specializers)
+  `(method ,gf-spec ,@qualifiers ,unparsed-specializers))
+
+
+
+;;;; Early generic-function support
+;;;
+;;;
+(defvar *early-generic-functions* ())
+
+(defun ensure-generic-function (function-specifier
+				&rest all-keys
+				&key environment
+				&allow-other-keys)
+  (declare (ignore environment))
+  (let ((existing (and (gboundp function-specifier)		       
+		       (gdefinition function-specifier))))
+    (if (and existing
+	     (eq *boot-state* 'complete)
+	     (null (generic-function-p existing)))
+	(generic-clobbers-function function-specifier)
+	(apply #'ensure-generic-function-using-class existing function-specifier all-keys))))
+
+(defun generic-clobbers-function (function-specifier)
+  #+Lispm (zl:signal 'generic-clobbers-function :name function-specifier)
+  #-Lispm (error "~S already names an ordinary function or a macro,~%~
+                  you may want to replace it with a generic function, but doing so~%~
+                  will require that you decide what to do with the existing function~%~
+                  definition.~%~
+                  The PCL-specific function MAKE-SPECIALIZABLE may be useful to you."
+		 function-specifier))
+
+#+Lispm
+(zl:defflavor generic-clobbers-function (name) (si:error)
+  :initable-instance-variables)
+
+#+Lispm
+(zl:defmethod #+symbolics (dbg:report generic-clobbers-function)
+	      #+ti (generic-clobbers-function :report)
+	      (stream)
+ (format stream
+	 "~S aready names a ~a"
+	 name
+	 (if (and (symbolp name) (macro-function name)) "macro" "function")))
+
+#+Symbolics
+(zl:defmethod (sys:proceed generic-clobbers-function :specialize-it) ()
+  "Make it specializable anyway?"
+  (make-specializable name))
+
+#+ti
+(zl:defmethod
+     (generic-clobbers-function :case :proceed-asking-user :specialize-it)
+     (continuation ignore)
+  "Make it specializable anyway?"
+  (make-specializable name)
+  (funcall continuation :specialize-it))
+
+;;;
+;;; This is the early definition of ensure-generic-function-using-class.
+;;; 
+;;; The static-slots field of the funcallable instances used as early generic
+;;; functions is used to store the early methods and early discriminator code
+;;; for the early generic function.  The static slots field of the fins
+;;; contains a list whose:
+;;;    CAR    -   a list of the early methods on this early gf
+;;;    CADR   -   the early discriminator code for this method
+;;;    
+(defun ensure-generic-function-using-class (existing spec &rest keys)
+  (declare (ignore keys))
+  (if* existing
+       existing
+       (pushnew spec *early-generic-functions* :test #'equal)
+       (let ((fin (allocate-funcallable-instance-1)))
+	 (setf (gdefinition spec) fin)
+	 (setf (fsc-instance-slots fin) (list nil nil))
+	 fin)))
+
+(defun early-gf-p (x)
+  (and (fsc-instance-p x)
+       (listp (fsc-instance-slots x))))
+
+(defmacro early-gf-methods (early-gf)		;These are macros so that
+  `(car (fsc-instance-slots ,early-gf)))	;they can be setf'd.
+						;
+(defmacro early-gf-discriminator-code (early-gf);
+  `(cadr (fsc-instance-slots ,early-gf)))	;
+
+
+(defmacro real-ensure-gf-internal (gf-class all-keys env)
+  `(progn
+     (cond ((symbolp ,gf-class)
+	    (setq ,gf-class (find-class ,gf-class t ,env)))
+	   ((classp ,gf-class))
+	   (t
+	    (error "The :GENERIC-FUNCTION-CLASS argument (~S) was neither a~%~
+                    class nor a symbol that names a class."
+		   ,gf-class)))
+     (remf ,all-keys :generic-function-class)
+     (remf ,all-keys :environment)
+     (let ((combin (getf ,all-keys :method-combination '.shes-not-there.)))
+       (unless (eq combin '.shes-not-there.)
+	 (setf (getf ,all-keys :method-combination)
+	       (find-method-combination (class-prototype ,gf-class)
+					(car combin)
+					(cdr combin)))))
+     ))
+     
+(defun real-ensure-gf-using-class--generic-function
+       (existing
+	function-specifier
+	&rest all-keys
+	&key environment
+	     (generic-function-class 'standard-generic-function gf-class-p)
+	&allow-other-keys)
+  (declare (ignore function-specifier))
+  (real-ensure-gf-internal generic-function-class all-keys environment)
+  (unless (or (null gf-class-p)
+	      (eq (class-of existing) generic-function-class))
+    (change-class existing generic-function-class))
+  (apply #'reinitialize-instance existing all-keys))
+
+(defun real-ensure-gf-using-class--null
+       (existing
+	function-specifier
+	&rest all-keys
+	&key environment
+	     (generic-function-class 'standard-generic-function)
+	&allow-other-keys)
+  (declare (ignore existing))
+  (real-ensure-gf-internal generic-function-class all-keys environment)
+  (setf (gdefinition function-specifier)
+	(apply #'make-instance generic-function-class :name function-specifier all-keys)))
+
+
+
+(defun early-make-a-method (class qualifiers arglist specializers function doc
+			    &optional slot-name)
+  (let ((parsed ())
+	(unparsed ()))
+    ;; Figure out whether we got class objects or class names as the
+    ;; specializers and set parsed and unparsed appropriately.  If we
+    ;; got class objects, then we can compute unparsed, but if we got
+    ;; class names we don't try to compute parsed.
+    ;; 
+    ;; Note that the use of not symbolp in this call to every should be
+    ;; read as 'classp' we can't use classp itself because it doesn't
+    ;; exist yet.
+    (if (every #'(lambda (s) (not (symbolp s))) specializers)
+	(setq parsed specializers
+	      unparsed (mapcar #'(lambda (s)
+				   (if (eq s 't) 't (class-name s)))
+			       specializers))
+	(setq unparsed specializers
+	      parsed ()))
+    (list :early-method		  ;This is an early method dammit!
+	  
+	  function                ;Function is here for the benefit
+				  ;of early-lookup-method.
+	  
+	  parsed                  ;The parsed specializers.  This is used
+				  ;by early-method-specializers to cache
+				  ;the parse.  Note that this only comes
+				  ;into play when there is more than one
+				  ;early method on an early gf.
+	  
+	  (list class             ;A list to which real-make-a-method
+		qualifiers        ;can be applied to make a real method
+		arglist           ;corresponding to this early one.
+		unparsed
+		function
+		doc
+		slot-name)
+	  )))
+
+(defun real-make-a-method
+       (class qualifiers lambda-list specializers function doc
+	&optional slot-name)
+  ;; Hmm what is this use of when buying me??
+  (when (some #'(lambda (x) (and (neq x 't) (symbolp x))) specializers)
+    (setq specializers (parse-specializers specializers)))
+  (make-instance class :qualifiers qualifiers
+		       :lambda-list lambda-list
+		       :specializers specializers
+		       :function function
+		       :documentation doc
+		       :slot-name slot-name
+		       :allow-other-keys t))
+
+(defun early-method-function (early-method)
+  (cadr early-method))
+
+;;;
+;;; Fetch the specializers of an early method.  This is basically just a
+;;; simple accessor except that when the second argument is t, this converts
+;;; the specializers from symbols into class objects.  The class objects
+;;; are cached in the early method, this makes bootstrapping faster because
+;;; the class objects only have to be computed once.
+;;; NOTE:
+;;;  the second argument should only be passed as T by early-lookup-method.
+;;;  this is to implement the rule that only when there is more than one
+;;;  early method on a generic function is the conversion from class names
+;;;  to class objects done.
+;;;  the corresponds to the fact that we are only allowed to have one method
+;;;  on any generic function up until the time classes exist.
+;;;  
+(defun early-method-specializers (early-method &optional objectsp)
+  (if (and (listp early-method)
+	   (eq (car early-method) :early-method))
+      (cond ((eq objectsp 't)
+	     (or (caddr early-method)
+		 (setf (caddr early-method)
+		       (mapcar #'find-class (cadddr (cadddr early-method))))))
+	    (t
+	     (cadddr (cadddr early-method))))
+      (error "~S is not an early-method." early-method)))
+
+(defun early-method-qualifiers (early-method)
+  (cadr (cadddr early-method)))
+
+(defun early-add-named-method (generic-function-name
+			       qualifiers
+			       specializers
+			       arglist
+			       function
+			       &rest options)
+  (declare (ignore options))
+  (let* ((gf (ensure-generic-function generic-function-name))
+	 (existing
+	   (dolist (m (early-gf-methods gf))
+	     (when (and (equal (early-method-specializers m) specializers)
+			(equal (early-method-qualifiers m) qualifiers))
+	       (return m))))
+	 (new (make-a-method 'standard-method
+			     qualifiers
+			     arglist
+			     specializers
+			     function
+			     ())))
+    (when existing (remove-method gf existing))
+    (add-method gf new)))
+
+;;;
+;;; This is the early version of add-method.  Later this will become a
+;;; generic function.  See fix-early-generic-functions which has special
+;;; knowledge about add-method.
+;;;
+(defun add-method (generic-function method)
+  (when (not (fsc-instance-p generic-function))
+    (error "Early add-method didn't get a funcallable instance."))
+  (when (not (and (listp method) (eq (car method) :early-method)))
+    (error "Early add-method didn't get an early method."))
+  (push method (early-gf-methods generic-function))
+  (early-update-discriminator-code generic-function))
+
+;;;
+;;; This is the early version of remove method.
+;;;
+(defun remove-method (generic-function method)
+  (when (not (fsc-instance-p generic-function))
+    (error "Early remove-method didn't get a funcallable instance."))
+  (when (not (and (listp method) (eq (car method) :early-method)))
+    (error "Early remove-method didn't get an early method."))
+  (setf (early-gf-methods generic-function)
+	(remove method (early-gf-methods generic-function)))
+  (early-update-discriminator-code generic-function))
+
+;;;
+;;; And the early version of get-method.
+;;;
+(defun get-method (generic-function qualifiers specializers
+				    &optional (errorp t))
+  (if (early-gf-p generic-function)
+      (or (dolist (m (early-gf-methods generic-function))
+	    (when (and (or (equal (early-method-specializers m nil)
+				  specializers)
+			   (equal (early-method-specializers m 't)
+				  specializers))
+		       (equal (early-method-qualifiers m) qualifiers))
+	      (return m)))
+	  (if errorp
+	      (error "Can't get early method.")
+	      nil))
+      (real-get-method generic-function qualifiers specializers errorp)))
+
+(defun early-update-discriminator-code (generic-function)
+  (let* ((methods (early-gf-methods generic-function))
+	 (early-dfun
+	   (cond ((null methods)
+		  #'(lambda (&rest ignore)
+		      (declare (ignore ignore))
+		      (error "Called an early generic-function that ~
+                              has no methods?")))
+		 ((null (cdr methods))
+		  ;; If there is only one method, just use that method's
+		  ;; function.  This corresponds to the important fact
+		  ;; that early generic-functions with only one method
+		  ;; always call that method when they are called.  If
+		  ;; there is more than one method, we have to install
+		  ;; a simple little discriminator-code for this generic
+		  ;; function.
+		  (cadr (car methods)))
+		 (t
+		  #'(lambda (&rest args) (early-dfun methods args))))))
+    (set-funcallable-instance-function generic-function early-dfun)
+    (setf (early-gf-discriminator-code generic-function) early-dfun)))
+
+(defun early-get-cpl (object)
+  (bootstrap-get-slot 'std-class		;HMMM? should be PCL-CLASS
+		      (class-of object)
+		      'class-precedence-list))
+
+(defun early-sort-methods (list args)
+  (if (null (cdr list))
+      list
+      (sort list
+	    #'(lambda (specls-1 specls-2)
+		(iterate ((s1 (list-elements specls-1))
+			  (s2 (list-elements specls-2))
+			  (a (list-elements args)))
+		  (cond ((eq s1 s2))
+			((eq s2 *the-class-t*) (return t))
+			((eq s1 *the-class-t*) (return nil))
+			(t (return (memq s2 (memq s1 (early-get-cpl a))))))))
+	    :key #'(lambda (em) (early-method-specializers em t)))))
+
+(defun early-dfun (methods args)
+  (let ((primary ())
+	(before ())
+	(after ())
+	(around ()))
+    (dolist (method methods)
+      (let* ((specializers (early-method-specializers method t))
+	     (qualifiers (early-method-qualifiers method))
+	     (args args)
+	     (specs specializers))
+	(when (loop
+		(when (or (null args)
+			  (null specs))
+		  ;; If we are out of specs, then we must be in the optional,
+		  ;; rest or keywords arguments.  This method is applicable
+		  ;; to these arguments.  Return T.
+		  (return t))
+		(let ((arg (pop args))
+		      (spec (pop specs)))
+		  (unless (or (eq spec *the-class-t*)
+			      (memq spec (early-get-cpl arg)))
+		    (return nil))))
+	  (cond ((null qualifiers) (push method primary))
+		((equal qualifiers '(:before)) (push method before))
+		((equal qualifiers '(:after))  (push method after))
+		((equal qualifiers '(:around)) (push method around))
+		(t
+		 (error "Unrecognized qualifer in early method."))))))
+    (setq primary (early-sort-methods primary args)
+	  before  (early-sort-methods before  args)
+	  after   (early-sort-methods after   args)
+	  around  (early-sort-methods around  args))
+    (flet ((do-main-combined-method (arguments)
+	     (dolist (m before) (apply (cadr m) arguments))
+	     (multiple-value-prog1
+	       (let ((*next-methods* (mapcar #'car (cdr primary))))
+		 (apply (cadar primary) arguments))
+	       (dolist (m after) (apply (cadr m) arguments)))))
+      (if (null around)
+	  (do-main-combined-method args)
+	  (let ((*next-methods*
+		  (append (mapcar #'cadr (cdr around))
+			  #'do-main-combined-method)))
+	    (apply (caar around) args))))))
+
+(defun fix-early-generic-functions (&optional noisyp)
+  (allocate-instance (find-class 'standard-generic-function));Be sure this
+						             ;class has an
+						             ;instance.
+  (let* ((class (find-class 'standard-generic-function))
+	 (wrapper (class-wrapper class))
+	 (n-static-slots (class-no-of-instance-slots class))
+	 (default-initargs (default-initargs class ()))
+	 #+Lucid
+	 (lucid::*redefinition-action* nil)
+	 (*invalidate-discriminating-function-force-p* t))
+    (flet ((fix-structure (gf)
+	     (let ((static-slots
+		     (%allocate-static-slot-storage--class n-static-slots)))
+	       (setf (fsc-instance-wrapper gf) wrapper
+		     (fsc-instance-slots gf) static-slots))))
+
+      (dolist (early-gf-spec *early-generic-functions*)
+	(when noisyp (format t "~&~S..." early-gf-spec))
+	(let* ((early-gf (gdefinition early-gf-spec))
+	       (early-static-slots
+		 (fsc-instance-slots early-gf))
+	       (early-discriminator-code nil)
+	       (early-methods nil)
+	       (methods ())
+	       (aborted t))
+	  (flet ((trampoline (&rest args)
+		   (apply early-discriminator-code args)))
+	    (if (not (listp early-static-slots))
+		(when noisyp (format t "already fixed?"))
+		(unwind-protect
+		    (progn
+		      (setq early-discriminator-code
+			    (early-gf-discriminator-code early-gf))
+		      (setq early-methods
+			    (early-gf-methods early-gf))
+		      (setf (gdefinition early-gf-spec) #'trampoline)
+		      (when noisyp (format t "trampoline..."))
+		      (fix-structure early-gf)
+		      (when noisyp (format t "fixed..."))
+		      (apply #'initialize-instance early-gf
+			     :name early-gf-spec default-initargs)
+		      (dolist (early-method early-methods)
+			(destructuring-bind
+			     (class quals lambda-list specs fn doc slot-name)
+			     (cadddr early-method)
+			  (setq specs
+				(early-method-specializers early-method t))
+			  (let ((method (real-make-a-method class
+							    quals
+							    lambda-list
+							    specs
+							    fn
+							    doc
+							    slot-name)))
+			    (real-add-method early-gf method)
+			    (push method methods)
+			    (when noisyp (format t "m")))))
+		      (setf (slot-value early-gf 'name) early-gf-spec)
+		      (fixup-magic-generic-function early-gf-spec
+						    early-methods
+						    early-gf
+						    (reverse methods))
+		      (setq aborted nil))
+		  (setf (gdefinition early-gf-spec) early-gf)
+		  (when noisyp (format t "."))
+		  (when aborted
+		    (setf (fsc-instance-slots early-gf)
+			  early-static-slots)))))))
+	  
+      (dolist (fns *early-functions*)
+	(setf (symbol-function (car fns)) (symbol-function (caddr fns))))
+      
+      (dolist (fixup *generic-function-fixups*)
+	(let ((fspec (car fixup))
+	      (methods (cdr fixup))
+	      (gf (make-instance 'standard-generic-function)))
+	  (set-function-name gf fspec)
+	  (setf (generic-function-name gf) fspec)
+	  (dolist (method methods)
+	    (destructuring-bind (lambda-list specializers method-fn-name)
+				method
+	      (let* ((fn (if method-fn-name
+			     (symbol-function method-fn-name)
+			     (symbol-function fspec)))
+		     (method (make-a-method 'standard-method
+					    ()
+					    lambda-list
+					    specializers
+					    fn
+					    nil)))
+		(real-add-method gf method))))
+	  (setf (gdefinition fspec) gf))))))
+
+
+;;;
+;;; parse-defmethod is used by defmethod to parse the &rest argument into
+;;; the 'real' arguments.  This is where the syntax of defmethod is really
+;;; implemented.
+;;; 
+(defun parse-defmethod (cdr-of-form)
+  (declare (values name qualifiers specialized-lambda-list body))
+  (let ((name (pop cdr-of-form))
+	(qualifiers ())
+	(spec-ll ()))
+    (loop (if (and (car cdr-of-form) (atom (car cdr-of-form)))
+	      (push (pop cdr-of-form) qualifiers)
+	      (return (setq qualifiers (nreverse qualifiers)))))
+    (setq spec-ll (pop cdr-of-form))
+    (values name qualifiers spec-ll cdr-of-form)))
+
+(defun parse-specializers (specializers)
+  (flet ((parse (spec)
+	   (cond ((symbolp spec)
+		  (or (find-class spec nil)
+		      (error
+			"~S used as a specializer,~%~
+                         but is not the name of a class."
+			spec)))
+		 ((and (listp spec)
+		       (eq (car spec) 'eql)
+		       (null (cddr spec)))
+		  (make-instance 'eql-specializer :object (cadr spec))	;*EQL*
+;		  spec
+		  )
+		 (t (error "~S is not a legal specializer." spec)))))
+    (mapcar #'parse specializers)))
+
+(defun unparse-specializers (specializers-or-method)
+  (if (listp specializers-or-method)
+      (flet ((unparse (spec)
+	       (cond ((classp spec)
+		      (or (class-name spec) spec))
+		     ((eql-specializer-p spec)	   ;*EQL*
+		      (eql-specializer-object spec)
+;		      (and (listp spec) (eq (car spec) 'eql))
+;		      spec
+		      )
+		     (t
+		      (error "~S is not a legal specializer." spec)))))
+	(mapcar #'unparse specializers-or-method))
+      (unparse-specializers (method-specializers specializers-or-method))))
+
+
+
+(defun parse-method-or-spec (spec &optional (errorp t))
+  (declare (values generic-function method method-name))
+  (let (gf method name temp)
+    (if (method-p spec)	
+	(setq method spec
+	      gf (method-generic-function method)
+	      temp (and gf (generic-function-name gf))
+	      name (if temp
+		       (intern-function-name
+			 (make-method-spec temp
+					   (method-qualifiers method)
+					   (unparse-specializers
+					     (method-specializers method))))
+		       (make-symbol (format nil "~S" method))))
+	(multiple-value-bind (gf-spec quals specls)
+	    (parse-defmethod spec)
+	  (and (setq gf (and (or errorp (gboundp gf-spec))
+			     (gdefinition gf-spec)))
+	       (let ((nreq (compute-discriminating-function-arglist-info gf)))
+		 (setq specls (append (parse-specializers specls)
+				      (make-list (- nreq (length specls))
+						 :initial-element
+						 *the-class-t*)))
+		 (and 
+		   (setq method (get-method gf quals specls errorp))
+		   (setq name
+			 (intern-function-name (make-method-spec gf-spec
+								 quals
+								 specls))))))))
+    (values gf method name)))
+
+
+
+(defun specialized-lambda-list-parameters (specialized-lambda-list)
+  (multiple-value-bind (parameters ignore1 ignore2)
+      (parse-specialized-lambda-list specialized-lambda-list)
+    (declare (ignore ignore1 ignore2))
+    parameters))
+
+(defun specialized-lambda-list-lambda-list (specialized-lambda-list)
+  (multiple-value-bind (ignore1 lambda-list ignore2)
+      (parse-specialized-lambda-list specialized-lambda-list)
+    (declare (ignore ignore1 ignore2))
+    lambda-list))
+
+(defun specialized-lambda-list-specializers (specialized-lambda-list)
+  (multiple-value-bind (ignore1 ignore2 specializers)
+      (parse-specialized-lambda-list specialized-lambda-list)
+    (declare (ignore ignore1 ignore2))
+    specializers))
+
+(defun specialized-lambda-list-required-parameters (specialized-lambda-list)
+  (multiple-value-bind (ignore1 ignore2 ignore3 required-parameters)
+      (parse-specialized-lambda-list specialized-lambda-list)
+    (declare (ignore ignore1 ignore2 ignore3))
+    required-parameters))
+
+(defun parse-specialized-lambda-list (arglist &optional post-keyword)
+  (declare (values parameters lambda-list specializers required-parameters))
+  (let ((arg (car arglist)))
+    (cond ((null arglist) (values nil nil nil nil))
+	  ((eq arg '&aux)
+	   (values nil arglist nil))
+	  ((memq arg lambda-list-keywords)
+	   (unless (memq arg '(&optional &rest &key &allow-other-keys &aux))
+	     ;; Warn about non-standard lambda-list-keywords, but then
+	     ;; go on to treat them like a standard lambda-list-keyword
+	     ;; what with the warning its probably ok.
+	     (warn "Unrecognized lambda-list keyword ~S in arglist.~%~
+                    Assuming that the symbols following it are parameters,~%~
+                    and not allowing any parameter specializers to follow~%~
+                    to follow it."
+		   arg))
+	   ;; When we are at a lambda-list-keyword, the parameters don't
+	   ;; include the lambda-list-keyword; the lambda-list does include
+	   ;; the lambda-list-keyword; and no specializers are allowed to
+	   ;; follow the lambda-list-keywords (at least for now).
+	   (multiple-value-bind (parameters lambda-list)
+	       (parse-specialized-lambda-list (cdr arglist) t)
+	     (values parameters
+		     (cons arg lambda-list)
+		     ()
+		     ())))
+	  (post-keyword
+	   ;; After a lambda-list-keyword there can be no specializers.
+	   (multiple-value-bind (parameters lambda-list)
+	       (parse-specialized-lambda-list (cdr arglist) t)	       
+	     (values (cons (if (listp arg) (car arg) arg) parameters)
+		     (cons arg lambda-list)
+		     ()
+		     ())))
+	  (t
+	   (multiple-value-bind (parameters lambda-list specializers required)
+	       (parse-specialized-lambda-list (cdr arglist))
+	     (values (cons (if (listp arg) (car arg) arg) parameters)
+		     (cons (if (listp arg) (car arg) arg) lambda-list)
+		     (cons (if (listp arg) (cadr arg) 't) specializers)
+		     (cons (if (listp arg) (car arg) arg) required)))))))
+
+
+(eval-when (load eval)
+  (setq *boot-state* 'early))
+
+
+
+(defmacro with-slots
+	  (slots instance &body body &environment env)
+  (let ((gensym (gensym))
+	(specs (mapcar #'(lambda (ss)
+			   (if (consp ss)
+			       (list (car ss)
+				     (variable-lexical-p (car ss) env)
+				     (cadr ss))
+			       (list ss (variable-lexical-p ss env) ss)))
+		       slots)))
+    (expand-with-slots specs
+		       body
+		       env
+		       gensym
+		       instance
+		       #'(lambda (s) `(slot-value ,gensym ',s)))))
+
+(defmacro with-accessors
+	  (slot-accessor-pairs instance &body body &environment env)
+  (let ((gensym (gensym))
+	(specs (mapcar #'(lambda (ss)
+			   (list (car ss)
+				 (variable-lexical-p (car ss) env)
+				 (cadr ss)))
+		       slot-accessor-pairs)))    
+    (expand-with-slots specs
+		       body
+		       env
+		       gensym
+		       instance
+		       #'(lambda (a) `(,a ,gensym)))))
+
+(defun expand-with-slots (specs body env gensym instance translate-fn)
+  `(let ((,gensym ,instance))
+     ,@(and (symbolp instance)
+	    `((declare (variable-rebinding ,gensym ,instance))))
+     ,gensym
+     ,@(cdr (walk-form `(progn ,@body)
+		       env
+		       #'(lambda (f c e)
+			   (expand-with-slots-internal specs
+						       f
+						       c
+						       translate-fn
+						       e))))))
+
+(defun expand-with-slots-internal (specs form context translate-fn env)
+  (let ((entry nil))
+    (cond ((not (eq context :eval)) form)
+	  ((symbolp form)
+	   (if (and (setq entry (assoc form specs))
+		    (eq (cadr entry) (variable-lexical-p form env)))
+	       (funcall translate-fn (caddr entry))
+	       form))
+	  ((not (listp form)) form)
+	  ((member (car form) '(setq setf))
+	   ;; Have to be careful.  We must only convert the form to a SETF
+	   ;; form when we convert one of the 'logical' variables to a form
+	   ;; Otherwise we will get looping in implementations where setf
+	   ;; is a macro which expands into setq.
+	   (let ((kind (car form)))
+	     (labels ((scan-setf (tail)
+			(if (null tail)
+			    nil
+			    (walker::relist*
+			      tail
+			      (if (and (setq entry (assoc (car tail) specs))
+				       (eq (cadr entry)
+					   (variable-lexical-p (car tail)
+							       env)))
+				  (progn (setq kind 'setf)
+					 (funcall translate-fn (caddr entry)))
+				  (car tail))
+			      (cadr tail)
+			      (scan-setf (cddr tail))))))
+	       (let (new-tail)
+		 (setq new-tail (scan-setf (cdr form)))
+		 (walker::recons form kind new-tail)))))
+	  ((eq (car form) 'multiple-value-setq)
+	   (let* ((vars (cadr form))
+		  (gensyms (mapcar #'(lambda (i) (declare (ignore i)) (gensym))
+				   vars)))
+	     `(multiple-value-bind ,gensyms 
+		  ,(caddr form)
+		.,(reverse (mapcar #'(lambda (v g) `(setf ,v ,g))
+				   vars
+				   gensyms)))))
+	  (t form))))
+
diff --git a/pcl/braid.lisp b/pcl/braid.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..39f94bb48ecbb1ded15af40c4071e7de1a3df9c8
--- /dev/null
+++ b/pcl/braid.lisp
@@ -0,0 +1,516 @@
+;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+;;; 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 'pcl)
+
+(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))
+		     (set (intern (format nil "*THE-CLASS-~A*" (symbol-name name))
+				  *the-pcl-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 direct-slots
+						     direct-slotd-wrapper))
+	      (setq slots
+		    (bootstrap-make-slot-definitions slots
+						     effective-slotd-wrapper))
+	      
+	      (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 (slots wrapper)
+  (mapcar #'(lambda (slot) (bootstrap-make-slot-definition slot wrapper))
+          slots))
+
+(defun bootstrap-make-slot-definition (slot wrapper)  
+  (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))
+      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))
+
diff --git a/pcl/cache.lisp b/pcl/cache.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..053c365d7b51e96009032795770b03c5b332032a
--- /dev/null
+++ b/pcl/cache.lisp
@@ -0,0 +1,1080 @@
+;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+;;; The basics of the PCL wrapper cache mechanism.
+;;;
+
+(in-package 'pcl)
+;;;
+;;; The caching algorithm implemented:
+;;;
+;;; << put a paper here >>
+;;;
+;;; For now, understand that as far as most of this code goes, a cache has
+;;; two important properties.  The first is the number of wrappers used as
+;;; keys in each cache line.  Throughout this code, this value is always
+;;; called NKEYS.  The second is whether or not the cache lines of a cache
+;;; store a value.  Throughout this code, this always called VALUEP.
+;;;
+;;; Depending on these values, there are three kinds of caches.
+;;;
+;;; NKEYS = 1, VALUEP = NIL
+;;;
+;;; In this kind of cache, each line is 1 word long.  No cache locking is
+;;; needed since all read's in the cache are a single value.  Nevertheless
+;;; line 0 (location 0) is reserved, to ensure that invalid wrappers will
+;;; not get a first probe hit.
+;;;
+;;; To keep the code simpler, a cache lock count does appear in location 0
+;;; of these caches, that count is incremented whenever data is written to
+;;; the cache.  But, the actual lookup code (see make-dlap) doesn't need to
+;;; do locking when reading the cache.
+;;; 
+;;;
+;;; NKEYS = 1, VALUEP = T
+;;;
+;;; In this kind of cache, each line is 2 words long.  Cache locking must
+;;; be done to ensure the synchronization of cache reads.  Line 0 of the
+;;; cache (location 0) is reserved for the cache lock count.  Location 1
+;;; of the cache is unused (in effect wasted).
+;;; 
+;;; NKEYS > 1
+;;;
+;;; In this kind of cache, the 0 word of the cache holds the lock count.
+;;; The 1 word of the cache is line 0.  Line 0 of these caches is not
+;;; reserved.
+;;;
+;;; This is done because in this sort of cache, the overhead of doing the
+;;; cache probe is high enough that the 1+ required to offset the location
+;;; is not a significant cost.  In addition, because of the larger line
+;;; sizes, the space that would be wasted by reserving line 0 to hold the
+;;; lock count is more significant.
+;;;
+
+
+;;;
+;;; Caches
+;;;
+;;; A cache is essentially just a vector.  The use of the individual `words'
+;;; in the vector depends on particular properties of the cache as described
+;;; above.
+;;;
+;;; This defines an abstraction for caches in terms of their most obvious
+;;; implementation as simple vectors.  But, please notice that part of the
+;;; implementation of this abstraction, is the function lap-out-cache-ref.
+;;; This means that most port-specific modifications to the implementation
+;;; of caches will require corresponding port-specific modifications to the
+;;; lap code assembler.
+;;;
+(defmacro cache-ref (cache location)
+  `(svref (the simple-vector ,cache) (the fixnum ,location)))
+
+(defun emit-cache-ref (cache-operand location-operand)
+  (operand :iref cache-operand location-operand))
+
+
+(defun cache-size (cache)
+  (array-dimension (the simple-vector cache) 0))
+
+(defun allocate-cache (size)
+  (make-array size :adjustable nil))
+
+(defmacro cache-lock-count (cache)
+  `(cache-ref ,cache 0))
+
+(defun flush-cache-internal (cache)
+  (without-interrupts  
+    (fill (the simple-vector cache) nil)
+    (setf (cache-lock-count cache) 0))
+  cache)
+
+(defmacro modify-cache (cache &body body)
+  `(without-interrupts
+     (multiple-value-prog1
+       (progn ,@body)
+       (let ((old-count (cache-lock-count ,cache)))
+	 (setf (cache-lock-count ,cache)
+	       (if (= old-count most-positive-fixnum) 1 (1+ old-count)))))))
+
+
+
+;;;
+;;; Some facilities for allocation and freeing caches as they are needed.
+;;; This is done on the assumption that a better port of PCL will arrange
+;;; to cons these all the same static area.  Given that, the fact that
+;;; PCL tries to reuse them should be a win.
+;;; 
+(defvar *free-caches* (make-hash-table :size 16))
+
+;;;
+;;; Return a cache that has had flush-cache-internal called on it.  This
+;;; returns a cache of exactly the size requested, it won't ever return a
+;;; larger cache.
+;;; 
+(defun get-cache (size)
+  (let ((entry (gethash size *free-caches*)))
+    (without-interrupts
+      (cond ((null entry)
+	     (setf (gethash size *free-caches*) (cons 0 nil))
+	     (get-cache size))
+	    ((null (cdr entry))
+	     (incf (car entry))
+	     (flush-cache-internal (allocate-cache size)))
+	    (t
+	     (let ((cache (cdr entry)))
+	       (setf (cdr entry) (cache-ref cache 0))
+	       (flush-cache-internal cache)))))))
+
+(defun free-cache (cache)
+  (let ((entry (gethash (cache-size cache) *free-caches*)))
+    (without-interrupts
+      (if (null entry)
+	  (error "Attempt to free a cache not allocated by GET-CACHE.")
+	  (let ((thread (cdr entry)))
+	    (loop (unless thread (return))
+		  (when (eq thread cache) (error "Freeing a cache twice."))
+		  (setq thread (cache-ref thread 0)))	  
+	    (flush-cache-internal cache)		;Help the GC
+	    (setf (cache-ref cache 0) (cdr entry))
+	    (setf (cdr entry) cache)
+	    nil)))))
+
+;;;
+;;; This is just for debugging and analysis.  It shows the state of the free
+;;; cache resource.
+;;; 
+(defun show-free-caches ()
+  (let ((elements ()))
+    (maphash #'(lambda (s e) (push (list s e) elements)) *free-caches*)
+    (setq elements (sort elements #'< :key #'car))
+    (dolist (e elements)
+      (let* ((size (car e))
+	     (entry (cadr e))
+	     (allocated (car entry))
+	     (head (cdr entry))
+	     (free 0))
+	(loop (when (null head) (return t))
+	      (setq head (cache-ref head 0))
+	      (incf free))
+	(format t
+		"~&There  ~4D are caches of size ~4D. (~D free  ~3D%)"
+		allocated
+		size
+		free
+		(floor (* 100 (/ free (float allocated)))))))))
+
+
+;;;
+;;; Wrapper cache numbers
+;;; 
+
+;;;
+;;; The constant WRAPPER-CACHE-NUMBER-ADDS-OK controls the number of non-zero
+;;; bits wrapper cache numbers will have.
+;;;
+;;; The value of this constant is the number of wrapper cache numbers which
+;;; can be added and still be certain the result will be a fixnum.  This is
+;;; used by all the code that computes primary cache locations from multiple
+;;; wrappers.
+;;;
+;;; The value of this constant is used to derive the next two which are the
+;;; forms of this constant which it is more convenient for the runtime code
+;;; to use.
+;;; 
+(eval-when (compile load eval)
+
+(defconstant wrapper-cache-number-adds-ok 4)
+
+(defconstant wrapper-cache-number-length
+	     (- (integer-length most-positive-fixnum)
+		wrapper-cache-number-adds-ok))
+
+(defconstant wrapper-cache-number-mask
+	     (1- (expt 2 wrapper-cache-number-length)))
+
+
+(defvar *get-wrapper-cache-number* (make-random-state))
+
+(defun get-wrapper-cache-number ()
+  (let ((n 0))
+    (loop
+      (setq n
+	    (logand wrapper-cache-number-mask
+		    (random most-positive-fixnum *get-wrapper-cache-number*)))
+      (unless (zerop n) (return n)))))
+
+
+(unless (> wrapper-cache-number-length 8)
+  (error "In this implementation of Common Lisp, fixnums are so small that~@
+          wrapper cache numbers end up being only ~D bits long.  This does~@
+          not actually keep PCL from running, but it may degrade cache~@
+          performance.~@
+          You may want to consider changing the value of the constant~@
+          WRAPPER-CACHE-NUMBER-ADDS-OK.")))
+
+
+;;;
+;;; wrappers themselves
+;;;
+;;; This caching algorithm requires that wrappers have more than one wrapper
+;;; cache number.  You should think of these multiple numbers as being in
+;;; columns.  That is, for a given cache, the same column of wrapper cache
+;;; numbers will be used.
+;;;
+;;; If at some point the cache distribution of a cache gets bad, the cache
+;;; can be rehashed by switching to a different column.
+;;;
+;;; The columns are referred to by field number which is that number which,
+;;; when used as a second argument to wrapper-ref, will return that column
+;;; of wrapper cache number.
+;;;
+;;; This code is written to allow flexibility as to how many wrapper cache
+;;; numbers will be in each wrapper, and where they will be located.  It is
+;;; also set up to allow port specific modifications to `pack' the wrapper
+;;; cache numbers on machines where the addressing modes make that a good
+;;; idea.
+;;; 
+(eval-when (compile load eval)
+
+(defconstant wrapper-layout
+	     '(number
+	       number
+	       number
+	       number
+	       number
+	       number
+	       number
+	       number
+	       state
+	       instance-slots-layout
+	       class-slots
+	       class))
+
+(defun wrapper-field (type)
+  (position type wrapper-layout))
+
+(defun next-wrapper-field (field-number)
+  (position (nth field-number wrapper-layout)
+	    wrapper-layout
+	    :start (1+ field-number)))
+
+);eval-when
+
+(defmacro wrapper-ref (wrapper n)
+  `(svref ,wrapper ,n))
+
+(defun emit-wrapper-ref (wrapper-operand field-operand)
+  (operand :iref wrapper-operand field-operand))
+
+	      
+(defmacro wrapper-state (wrapper)
+  `(wrapper-ref ,wrapper ,(wrapper-field 'state)))
+
+(defmacro wrapper-instance-slots-layout (wrapper)
+  `(wrapper-ref ,wrapper ,(wrapper-field 'instance-slots-layout)))
+
+(defmacro wrapper-class-slots (wrapper)
+  `(wrapper-ref ,wrapper ,(wrapper-field 'class-slots)))
+
+(defmacro wrapper-class (wrapper)
+  `(wrapper-ref ,wrapper ,(wrapper-field 'class)))
+
+
+(defmacro make-wrapper-internal ()
+  `(let ((wrapper (make-array ,(length wrapper-layout) :adjustable nil)))
+     ,@(gathering1 (collecting)
+	 (iterate ((i (interval :from 0))
+		   (desc (list-elements wrapper-layout)))
+	   (ecase desc
+	     (number
+	      (gather1 `(setf (wrapper-ref wrapper ,i)
+			      (get-wrapper-cache-number))))
+	     ((state instance-slots-layout class-slots class)))))
+     (setf (wrapper-state wrapper) 't)     
+     wrapper))
+
+(defun make-wrapper (class)
+  (let ((wrapper (make-wrapper-internal)))
+    (setf (wrapper-class wrapper) class)
+    wrapper))
+
+;;;
+;;; The wrapper cache machinery provides general mechanism for trapping on
+;;; the next access to any instance of a given class.  This mechanism is
+;;; used to implement the updating of instances when the class is redefined
+;;; (make-instances-obsolete).  The same mechanism is also used to update
+;;; generic function caches when there is a change to the supers of a class.
+;;;
+;;; Basically, a given wrapper can be valid or invalid.  If it is invalid,
+;;; it means that any attempt to do a wrapper cache lookup using the wrapper
+;;; should trap.  Also, methods on slot-value-using-class check the wrapper
+;;; validity as well.  This is done by calling check-wrapper-validity.
+;;; 
+
+(defun invalid-wrapper-p (wrapper)
+  (neq (wrapper-state wrapper) 't))
+
+(defvar *previous-nwrappers* (make-hash-table))
+
+(defun invalidate-wrapper (owrapper state nwrapper)
+  (ecase state
+    ((flush obsolete)
+     (let ((new-previous ()))
+       ;;
+       ;; First off, a previous call to invalidate-wrapper may have recorded
+       ;; owrapper as an nwrapper to update to.  Since owrapper is about to
+       ;; be invalid, it no longer makes sense to update to it.
+       ;;
+       ;; We go back and change the previously invalidated wrappers so that
+       ;; they will now update directly to nwrapper.  This corresponds to a
+       ;; kind of transitivity of wrapper updates.
+       ;; 
+       (dolist (previous (gethash owrapper *previous-nwrappers*))
+	 (setf (cadr previous) nwrapper)
+	 (push previous new-previous))
+       
+       (iterate ((type (list-elements wrapper-layout))
+		 (i (interval :from 0)))
+	 (when (eq type 'number) (setf (wrapper-ref owrapper i) 0)))
+       (push (setf (wrapper-state owrapper) (list state nwrapper))
+	     new-previous)
+       
+       (setf (gethash owrapper *previous-nwrappers*) ()
+	     (gethash nwrapper *previous-nwrappers*) new-previous)))))
+
+(defun check-wrapper-validity (instance)
+  (let* ((owrapper (wrapper-of instance))
+	 (state (wrapper-state owrapper)))
+    (if (eq state  't)
+	owrapper
+	(let ((nwrapper
+		(ecase (car state)
+		  (flush
+		    (flush-cache-trap owrapper (cadr state) instance))
+		  (obsolete
+		    (obsolete-instance-trap owrapper (cadr state) instance)))))
+	  ;;
+	  ;; This little bit of error checking is superfluous.  It only
+	  ;; checks to see whether the person who implemented the trap
+	  ;; handling screwed up.  Since that person is hacking internal
+	  ;; PCL code, and is not a user, this should be needless.  Also,
+	  ;; since this directly slows down instance update and generic
+	  ;; function cache refilling, feel free to take it out sometime
+	  ;; soon.
+	  ;; 
+	  (cond ((neq nwrapper (wrapper-of instance))
+		 (error "Wrapper returned from trap not wrapper of instance."))
+		((invalid-wrapper-p nwrapper)
+		 (error "Wrapper returned from trap invalid.")))
+	  nwrapper))))
+
+
+
+(defun compute-line-size (nelements) (expt 2 (ceiling (log nelements 2))))
+
+(defun compute-cache-parameters (nkeys valuep nlines-or-cache)
+  (declare (values cache-mask actual-size line-size nlines))
+  (flet ((compute-mask (cache-size line-size)
+	   (logxor (1- cache-size) (1- line-size))))
+    (if (= nkeys 1)
+	(let* ((line-size (if valuep 2 1))
+	       (cache-size (if (numberp nlines-or-cache)
+			       (* line-size
+				  (expt 2 (ceiling (log nlines-or-cache 2))))
+			       (cache-size nlines-or-cache))))
+	  (values (compute-mask cache-size line-size)
+		  cache-size
+		  line-size
+		  (/ cache-size line-size)))
+	(let* ((line-size (compute-line-size (+ nkeys (if valuep 1 0))))
+	       (cache-size (if (numberp nlines-or-cache)
+			       (* line-size 
+				  (expt 2 (ceiling (log nlines-or-cache 2))))
+			       (1- (cache-size nlines-or-cache)))))
+	  (values (compute-mask cache-size line-size)
+		  (1+ cache-size)
+		  line-size
+		  (/ cache-size line-size))))))
+
+
+
+;;;
+;;; The various implementations of computing a primary cache location from
+;;; wrappers.  Because some implementations of this must run fast there are
+;;; several implementations of the same algorithm.
+;;;
+;;; The algorithm is:
+;;;
+;;;  SUM       over the wrapper cache numbers,
+;;;  ENSURING  that the result is a fixnum
+;;;  MASK      the result against the mask argument.
+;;;
+;;;
+
+;;;
+;;; COMPUTE-PRIMARY-CACHE-LOCATION
+;;; 
+;;; The basic functional version.  This is used by the cache miss code to
+;;; compute the primary location of an entry.  
+;;;
+(defun compute-primary-cache-location (field mask wrappers)
+  (if (not (consp wrappers))
+      (logand mask (wrapper-ref wrappers field))
+      (let ((location 0))
+	(iterate ((wrapper (list-elements wrappers))
+		  (i (interval :from 0)))
+	  ;;
+	  ;; First add the cache number of this wrapper to location.
+	  ;; 
+	  (let ((wrapper-cache-number (wrapper-ref wrapper field)))
+	    (if (zerop wrapper-cache-number)
+		(return-from compute-primary-cache-location 0)
+		(setq location (+ location wrapper-cache-number))))
+	  ;;
+	  ;; Then, if we are working with lots of wrappers, deal with
+	  ;; the wrapper-cache-number-mask stuff.
+	  ;; 
+	  (when (and (not (zerop i))
+		     (zerop (mod i wrapper-cache-number-adds-ok)))
+	    (setq location
+		  (logand location wrapper-cache-number-mask))))
+	(1+ (logand mask location)))))
+
+;;;
+;;; COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION
+;;;
+;;; This version is called on a cache line.  It fetches the wrappers from
+;;; the cache line and determines the primary location.  Various parts of
+;;; the cache filling code call this to determine whether it is appropriate
+;;; to displace a given cache entry.
+;;; 
+;;; If this comes across a wrapper whose cache-no is 0, it returns the symbol
+;;; invalid to suggest to its caller that it would be provident to blow away
+;;; the cache line in question.
+;;;
+(defun compute-primary-cache-location-from-location (field cache location mask nkeys)
+  (let ((result 0))
+    (dotimes (i nkeys)
+      (let* ((wrapper (cache-ref cache (+ i location)))
+	     (wcn (wrapper-ref wrapper field)))
+	(setq result (+ result wcn)))
+      (when (and (not (zerop i))
+		 (zerop (mod i wrapper-cache-number-adds-ok)))
+	(setq result (logand result wrapper-cache-number-mask)))
+      )    
+    (if (= nkeys 1)
+	(logand mask result)
+	(1+ (logand mask result)))))
+
+(defun emit-1-wrapper-compute-primary-cache-location (wrapper primary wrapper-cache-no)
+  (with-lap-registers ((mask index))
+    (let ((field wrapper-cache-no))
+      (flatten-lap
+        (opcode :move (operand :cvar 'mask) mask)
+        (opcode :move (operand :cvar 'field) field)
+        (opcode :move (emit-wrapper-ref wrapper field) wrapper-cache-no)
+        (opcode :move (operand :ilogand wrapper-cache-no mask) primary)))))
+
+(defun emit-n-wrapper-compute-primary-cache-location (wrappers primary miss-label)
+  (with-lap-registers ((field index)
+		       (mask index))
+    (let ((add-wrapper-cache-numbers
+	   (flatten-lap
+	    (gathering1 (flattening-lap)
+	       (iterate ((wrapper (list-elements wrappers))
+			 (i (interval :from 1)))
+		 (gather1
+		  (with-lap-registers ((wrapper-cache-no index))
+		    (flatten-lap
+		     (opcode :move (emit-wrapper-ref wrapper field) wrapper-cache-no)
+		     (opcode :izerop wrapper-cache-no miss-label)
+		     (opcode :move (operand :i+ primary wrapper-cache-no) primary)
+		     (when (zerop (mod i wrapper-cache-number-adds-ok))
+		       (opcode :move (operand :ilogand primary mask) primary))))))))))
+      (flatten-lap
+       (opcode :move (operand :constant 0) primary)
+       (opcode :move (operand :cvar 'field) field)
+       (opcode :move (operand :cvar 'mask) mask)
+       add-wrapper-cache-numbers
+       (opcode :move (operand :ilogand primary mask) primary)
+       (opcode :move (operand :i1+ primary) primary)))))
+
+
+
+;;;
+;;;  NIL              means nothing so far, no actual arg info has NILs
+;;;                   in the metatype
+;;;  CLASS            seen all sorts of metaclasses
+;;;                   (specifically, more than one of the next 4 values)
+;;;  T                means everything so far is the class T
+;;;  STANDARD-CLASS   seen only standard classes
+;;;  BUILT-IN-CLASS   seen only built in classes
+;;;  STRUCTURE-CLASS  seen only structure classes
+;;;  
+(defun raise-metatype (metatype new-specializer)
+  (let ((standard  (find-class 'standard-class))
+	(fsc       (find-class 'funcallable-standard-class))
+;	(structure (find-class 'structure-class))
+	(built-in  (find-class 'built-in-class)))
+    (flet ((specializer->metatype (x)
+	     (let ((meta-specializer 
+		     (if (and (eq *boot-state* 'complete)
+			      (eql-specializer-p x))
+			 (class-of (class-of (eql-specializer-object x)))
+			 (class-of x))))
+	       (cond ((eq x *the-class-t*) t)
+		     ((*subtypep meta-specializer standard)  'standard-instance)
+		     ((*subtypep meta-specializer fsc)       'standard-instance)
+;                    ((*subtypep meta-specializer structure) 'structure-instance)
+		     ((*subtypep meta-specializer built-in)  'built-in-instance)
+		     (t (error "PCL can not handle the specializer ~S (meta-specializer ~S)."
+			       new-specializer meta-specializer))))))
+      ;;
+      ;; We implement the following table.  The notation is
+      ;; that X and Y are distinct meta specializer names.
+      ;; 
+      ;;   NIL    <anything>    ===>  <anything>
+      ;;    X      X            ===>      X
+      ;;    X      Y            ===>    CLASS
+      ;;    
+      (let ((new-metatype (specializer->metatype new-specializer)))
+	(cond ((null metatype) new-metatype)
+	      ((eq metatype new-metatype) new-metatype)
+	      (t 'class))))))
+
+
+(defun emit-fetch-wrapper (metatype argument dest miss-label &optional slot)
+  (let ((exit-emit-fetch-wrapper (make-symbol "exit-emit-fetch-wrapper")))
+    (with-lap-registers ((arg t))
+      (ecase metatype
+	(standard-instance
+	  (let ((get-std-inst-wrapper (make-symbol "get-std-inst-wrapper"))
+		(get-fsc-inst-wrapper (make-symbol "get-fsc-inst-wrapper")))
+	    (flatten-lap
+	      (opcode :move (operand :arg argument) arg)
+	      (opcode :std-instance-p arg get-std-inst-wrapper)	   ;is it a std wrapper?
+	      (opcode :fsc-instance-p arg get-fsc-inst-wrapper)	   ;is it a fsc wrapper?
+	      (opcode :go miss-label)
+	      (opcode :label get-fsc-inst-wrapper)
+	      (opcode :move (operand :fsc-wrapper arg) dest)	   ;get fsc wrapper
+	      (and slot
+		   (opcode :move (operand :fsc-slots arg) slot))
+	      (opcode :go exit-emit-fetch-wrapper)
+	      (opcode :label get-std-inst-wrapper)
+	      (opcode :move (operand :std-wrapper arg) dest)	   ;get std wrapper
+	      (and slot
+		   (opcode :move (operand :std-slots arg) slot))
+	      (opcode :label exit-emit-fetch-wrapper))))
+
+	(class
+	  (when slot (error "Can't do a slot reg for this metatype."))
+	  (let ((get-std-inst-wrapper (make-symbol "get-std-inst-wrapper"))
+		(get-fsc-inst-wrapper (make-symbol "get-fsc-inst-wrapper"))
+		(get-built-in-wrapper (make-symbol "get-built-in-wrapper")))
+	    (flatten-lap
+	      (opcode :move (operand :arg argument) arg)
+	      (opcode :std-instance-p arg get-std-inst-wrapper)
+	      (opcode :fsc-instance-p arg get-fsc-inst-wrapper)
+	      (opcode :built-in-instance-p arg get-built-in-wrapper)
+	      ;; If the code falls through the checks above, there is a serious problem
+	      (opcode :label get-fsc-inst-wrapper)
+	      (opcode :move (operand :fsc-wrapper arg) dest)
+	      (opcode :go exit-emit-fetch-wrapper)
+	      (opcode :label get-built-in-wrapper)
+	      (opcode :move (operand :built-in-wrapper arg) dest)
+	      (opcode :go exit-emit-fetch-wrapper)
+	      (opcode :label get-std-inst-wrapper)
+	      (opcode :move (operand :std-wrapper arg) dest)
+	      (opcode :label exit-emit-fetch-wrapper))))
+	(structure-instance 
+	  (when slot (error "Can't do a slot reg for this metatype."))
+	  (error "Not yet implemented"))
+	(built-in-instance
+	  (when slot (error "Can't do a slot reg for this metatype."))
+	  (let ((get-built-in-wrapper (make-symbol "get-built-in-wrapper")))
+	    (flatten-lap
+	      (opcode :move (operand :arg argument) arg)
+	      (opcode :built-in-instance-p arg get-built-in-wrapper)
+	      (opcode :go miss-label)
+	      (opcode :label get-built-in-wrapper)
+	      (opcode :move (operand :built-in-wrapper arg) dest))))))))
+
+
+;;;
+;;; Some support stuff for getting a hold of symbols that we need when
+;;; building the discriminator codes.  Its ok for these to be interned
+;;; symbols because we don't capture any user code in the scope in which
+;;; these symbols are bound.
+;;; 
+
+(defvar *dfun-arg-symbols* '(.ARG0. .ARG1. .ARG2. .ARG3.))
+
+(defun dfun-arg-symbol (arg-number)
+  (or (nth arg-number (the list *dfun-arg-symbols*))
+      (intern (format nil ".ARG~A." arg-number) *the-pcl-package*)))
+
+(defvar *slot-vector-symbols* '(.SLOTS0. .SLOTS1. .SLOTS2. .SLOTS3.))
+
+(defun slot-vector-symbol (arg-number)
+  (or (nth arg-number (the list *slot-vector-symbols*))
+      (intern (format nil ".SLOTS~A." arg-number) *the-pcl-package*)))
+
+(defun make-dfun-lambda-list (metatypes applyp)
+  (gathering1 (collecting)
+    (iterate ((i (interval :from 0))
+	      (s (list-elements metatypes)))
+      (progn s)
+      (gather1 (dfun-arg-symbol i)))
+    (when applyp
+      (gather1 '&rest)
+      (gather1 '.dfun-rest-arg.))))
+
+(defun make-dlap-lambda-list (metatypes applyp)
+  (gathering1 (collecting)
+    (iterate ((i (interval :from 0))
+	      (s (list-elements metatypes)))
+      (progn s)
+      (gather1 (dfun-arg-symbol i)))
+    (when applyp
+      (gather1 '&rest))))
+
+(defun make-dfun-call (metatypes applyp fn-variable)
+  (let ((required
+	  (gathering1 (collecting)
+	    (iterate ((i (interval :from 0))
+		      (s (list-elements metatypes)))
+	      (progn s)
+	      (gather1 (dfun-arg-symbol i))))))
+    (if applyp
+	`(apply   ,fn-variable ,@required .dfun-rest-arg.)
+	`(funcall ,fn-variable ,@required))))
+
+
+;;;
+;;; Here is where we actually fill, recache and expand caches.
+;;;
+;;; The function FILL-CACHE is the ONLY external entrypoint into this code.
+;;; It returns 4 values:
+;;;   a wrapper field number
+;;;   a cache
+;;;   a mask
+;;;   an absolute cache size (the size of the actual vector)
+;;;
+;;;
+(defun fill-cache (field cache nkeys valuep limit-fn wrappers value)
+  (declare (values field cache mask size))
+  (fill-cache-internal field cache nkeys valuep limit-fn wrappers value))
+
+(defun default-limit-fn (nlines)
+  (case nlines
+    ((1 2 4) 1)
+    ((8 16)  4)
+    (otherwise 6)))
+
+
+;;;
+;;; Its too bad Common Lisp compilers freak out when you have a defun with
+;;; a lot of LABELS in it.  If I could do that I could make this code much
+;;; easier to read and work with.
+;;;
+;;; Ahh Scheme...
+;;; 
+;;; In the absence of that, the following little macro makes the code that
+;;; follows a little bit more reasonable.  I would like to add that having
+;;; to practically write my own compiler in order to get just this simple
+;;; thing is something of a drag.
+;;;
+(eval-when (compile load eval)
+
+(proclaim '(special *nkeys* *valuep* *limit-fn*))
+
+(defvar *local-cache-functions*
+	`((cache     () .cache.)
+	  (nkeys     () *nkeys*)
+	  (valuep    () *valuep*)
+	  (limit-fn  () *limit-fn*)
+	  (line-size () .line-size.)
+	  (mask      () .mask.)
+	  (size      () .size.)
+	  (nlines    () .nlines.)
+	  ;;
+	  ;; Return T IFF this cache location is reserved.  The only time
+	  ;; this is true is for line number 0 of an nkeys=1 cache.  
+	  ;;
+	  (line-reserved-p (line)
+	    (and (= (nkeys) 1)
+		 (= line 0)))
+	  ;;
+	  ;; Given a line number, return the cache location.  This is the
+	  ;; value that is the second argument to cache-ref.  Basically,
+	  ;; this deals with the offset of nkeys>1 caches and multiplies
+	  ;; by line size.  This returns nil if the line is reserved.
+	  ;; 	  
+	  (line-location (line)
+	    (and (null (line-reserved-p line))
+		 (if (= (nkeys) 1)
+		     (* line (line-size))
+		     (1+ (* line (line-size))))))
+	  ;;
+	  ;; Given a cache location, return the line.  This is the inverse
+	  ;; of LINE-LOCATION.
+	  ;; 	  
+	  (location-line (location)
+	    (if (= (nkeys) 1)
+		(/ location (line-size))
+		(/ (1- location) (line-size))))
+	  ;;
+	  ;; Given a line number, return the wrappers stored at that line.
+	  ;; As usual, if nkeys=1, this returns a single value.  Only when
+	  ;; nkeys>1 does it return a list.  An error is signalled if the
+	  ;; line is reserved.
+	  ;;
+	  (line-wrappers (line)
+	    (when (line-reserved-p line) (error "Line is reserved."))
+	    (let ((location (line-location line)))
+	      (if (= (nkeys) 1)
+		  (cache-ref (cache) location)
+		  (gathering1 (collecting)
+		    (dotimes (i (nkeys))
+		      (gather1 (cache-ref (cache) (+ location i))))))))
+	  ;;
+	  ;; Given a line number, return the value stored at that line.
+	  ;; If valuep is NIL, this returns NIL.  As with line-wrappers,
+	  ;; an error is signalled if the line is reserved.
+	  ;; 
+	  (line-value (line)
+	    (when (line-reserved-p line) (error "Line is reserved."))
+	    (and (valuep)
+		 (cache-ref (cache) (+ (line-location line) (nkeys)))))
+	  ;;
+	  ;; Given a line number, return true IFF that line has data in
+	  ;; it.  The state of the wrappers stored in the line is not
+	  ;; checked.  An error is signalled if line is reserved.
+	  (line-full-p (line)
+	    (when (line-reserved-p line) (error "Line is reserved."))
+	    (not (null (cache-ref (cache) (line-location line)))))
+	  ;;
+	  ;; Given a line number, return true IFF the line is full and
+	  ;; there are no invalid wrappers in the line.  An error is
+	  ;; signalled if the line is reserved.
+	  ;;
+	  (line-valid-p (line)
+	    (when (line-reserved-p line) (error "Line is reserved."))
+	    (let ((loc (line-location line)))
+	      (dotimes (i (nkeys) t)
+		(let ((wrapper (cache-ref (cache) (+ loc i))))
+		  (when (or (null wrapper)
+;***			    (numberp wrapper)	          ;Think of this as an optimized:
+						          ; (and (zerop i)
+						          ;      (= (nkeys) 1)
+						          ;      (null (valuep))
+						          ;      (numberp wrapper))
+			    (invalid-wrapper-p wrapper))
+		    (return nil))))))
+	  ;;
+	  ;; How many unreserved lines separate line-1 and line-2.
+	  ;;
+	  (line-separation (line-1 line-2)
+	    (let ((diff (- line-2 line-1)))
+	      (cond ((zerop diff) diff)
+		    ((plusp diff) diff)
+		    (t
+		     (if (line-reserved-p 0)
+			 (1- (+ (- (nlines) line-1) line-2))
+			 (+ (- (nlines) line-1) line-2))))))
+	  ;;
+	  ;; Given a cache line, get the next cache line.  This will not
+	  ;; return a reserved line.
+	  ;; 
+	  (next-line (line)
+	    (if (= line (1- (nlines)))
+		(if (line-reserved-p 0) 1 0)
+		(1+ line)))
+	  ;;
+	  ;; Given a line which has a valid entry in it, this will return
+	  ;; the primary cache line of the wrappers in that line.  We just
+	  ;; call COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION, this is an
+	  ;; easier packaging up of the call to it.
+	  ;; 
+	  (line-primary (field line)
+	    (location-line
+	      (compute-primary-cache-location-from-location
+		field (cache) (line-location line) (mask) (nkeys))))
+	  ;;
+	  ;;
+	  (fill-line (line wrappers value)
+	    (when (line-reserved-p line)
+	      (error "Attempt to fill a reserved line."))
+	    (let ((loc (line-location line)))
+	      (cond ((= (nkeys) 1)
+		     (setf (cache-ref (cache) loc) wrappers)
+		     (when (valuep) (setf (cache-ref (cache) (1+ loc)) value)))
+		    (t
+		     (iterate ((i (interval :from 0))
+			       (w (list-elements wrappers)))
+		       (setf (cache-ref (cache) (+ loc i)) w))
+		     (when (valuep) (setf (cache-ref (cache) (+ loc (nkeys))) value))))))
+	  ;;
+	  ;; Blindly copy the contents of one cache line to another.  The
+	  ;; contents of the <to> line are overwritten, so whatever was in
+	  ;; there should already have been moved out.
+	  ;;
+	  ;; For convenience in debugging, this also clears out the from
+	  ;; location after it has been copied.
+	  ;;
+	  (copy-line (from to)
+	    (if (line-reserved-p to)
+		(error "Copying something into a reserved cache line.")
+		(let ((from-loc (line-location from))
+		      (to-loc (line-location to)))
+		  (modify-cache (cache)
+		    (dotimes (i (line-size))
+		      (setf (cache-ref (cache) (+ to-loc i))
+			    (cache-ref (cache) (+ from-loc i)))
+		      (setf (cache-ref (cache) (+ from-loc i))
+			    nil))))))
+	  ;;
+	  ;;
+	  ;;
+	  (transfer-line (from-cache from-line to-cache to-line)
+	    (if (line-reserved-p to-line)
+		(error "transfering something into a reserved cache line.")
+		(let ((from-loc (line-location from-line))
+		      (to-loc (line-location to-line)))
+		  (modify-cache to-cache
+		    (dotimes (i (line-size))
+		      (setf (cache-ref to-cache (+ to-loc i))
+			    (cache-ref from-cache (+ from-loc i))))))))
+	  ))
+
+(defmacro with-local-cache-functions ((cache) &body body &environment env)
+  `(let ((.cache. ,cache))
+     (declare (type simple-vector .cache.))
+     (multiple-value-bind (.mask. .size. .line-size. .nlines.)
+	 (compute-cache-parameters *nkeys* *valuep* .cache.)
+       (declare (type fixnum .mask. .size. .line-size. .nlines.))
+       (progn .mask. .size. .line-size. .nlines.)
+       (labels ,(mapcar #'(lambda (fn) (assq fn *local-cache-functions*))
+			(pickup-local-cache-functions body env))
+	 ,@body))))
+
+(defun pickup-local-cache-functions (body env)
+  (let ((functions ())
+	(possible-functions (mapcar #'car *local-cache-functions*)))
+    (labels ((walk-function (form context env)
+	       (declare (ignore env))
+	       (when (and (eq context :eval)
+			  (consp form)
+			  (symbolp (car form)))
+		 (let ((name (car form)))
+		   (when (and (not (memq name functions))
+			      (memq name possible-functions))
+		     (pushnew name functions)
+		     (walk (cddr (assq name *local-cache-functions*))))))
+	       form)
+	     (walk (body)
+	       (walk-form `(progn . ,body) env #'walk-function)))
+      (walk body)
+      functions)))
+
+)
+
+
+;;;
+;;; returns 4 values, <field> <cache> <mask> <size>
+;;; It tries to re-adjust the cache every time it makes a new fill.  The
+;;; intuition here is that we want uniformity in the number of probes needed to
+;;; find an entry.  Furthermore, adjusting has the nice property of throwing out
+;;; any entries that are invalid.
+;;;
+(defun fill-cache-internal (field cache nkeys valuep limit-fn wrappers value)
+  (let ((*nkeys* nkeys)
+	(*valuep* valuep)
+	(*limit-fn* limit-fn))
+    (with-local-cache-functions (cache)
+;     (when (entry-in-cache-p field cache wrappers value)
+;	(cerror "But, you can keep going (report that this happened)."
+;		"Bad shit."))
+      (flet ((4-values-please (f c)
+	       (multiple-value-bind (mask size)
+		   (compute-cache-parameters *nkeys* *valuep* c)
+		 (values f c mask size))))
+	(let ((easy-fill-p (fill-cache-p nil field cache wrappers value)))
+	  (if easy-fill-p
+	      (4-values-please field cache)
+	      (multiple-value-bind (adj-field adj-cache)
+		  (adjust-cache field cache wrappers value)
+		(if adj-field
+		    (4-values-please adj-field adj-cache)
+		    (multiple-value-bind (exp-field exp-cache)
+			(expand-cache field cache wrappers value)
+		      (4-values-please exp-field exp-cache))))))))))
+
+;;;
+;;; returns T or NIL
+;;;
+(defun fill-cache-p (forcep field cache wrappers value)
+  (with-local-cache-functions (cache)
+;   (when (entry-in-cache-p field cache wrappers value)
+;     (cerror "But, you can keep going (report that this happened)."
+;	      "Really bad shit."))
+    (let* ((primary (location-line (compute-primary-cache-location field (mask) wrappers))))
+      (multiple-value-bind (free emptyp)
+	  (find-free-cache-line primary field cache)
+	(when (or forcep emptyp) (fill-line free wrappers value) t)))))
+
+(defun fill-cache-from-cache-p (forcep field cache from-cache from-line)
+  (with-local-cache-functions (from-cache)
+    (let ((primary (line-primary field from-line)))
+      (multiple-value-bind (free emptyp)
+	  (find-free-cache-line primary field cache)
+	(when (or forcep emptyp)
+	  (transfer-line from-cache from-line cache free)
+	  t)))))
+
+(defun entry-in-cache-p (field cache wrappers value)
+  (declare (ignore field value))
+  (with-local-cache-functions (cache)
+    (dotimes (i (nlines))
+      (unless (line-reserved-p i)
+	(when (equal (line-wrappers i) wrappers) (return t))))))
+
+;;;
+;;; Returns NIL or (values <field> <cache>)
+;;; 
+;;; This is only called when it isn't possible to put the entry in the cache
+;;; the easy way.  That is, this function assumes that FILL-CACHE-P has been
+;;; called as returned NIL.
+;;;
+;;; If this returns NIL, it means that it wasn't possible to find a wrapper
+;;; field for which all of the entries could be put in the cache (within the
+;;; limit).  
+;;;
+(defun adjust-cache (field cache wrappers value)
+  (with-local-cache-functions (cache)
+    (let ((ncache (get-cache (size))))
+      (do ((nfield field (next-wrapper-field nfield)))
+	  ((null nfield) (free-cache ncache) nil)
+	(labels ((try-one-fill-from-line (line)
+		   (fill-cache-from-cache-p nil nfield ncache cache line))
+		 (try-one-fill (wrappers value)
+		   (fill-cache-p nil nfield ncache wrappers value)))
+	  (if (and (dotimes (i (nlines) t)
+		     (when (and (null (line-reserved-p i))
+				(line-valid-p i))
+		       (unless (try-one-fill-from-line i) (return nil))))
+		   (try-one-fill wrappers value))
+	      (return (values nfield ncache))
+	      (flush-cache-internal ncache)))))))
+
+		       
+;;;
+;;; returns: (values <field> <cache>)
+;;;
+(defun expand-cache (field cache wrappers value)
+  (declare (values field cache) (ignore field))
+  (with-local-cache-functions (cache)
+    (multiple-value-bind (ignore size)
+	(compute-cache-parameters (nkeys) (valuep) (* (nlines) 2))
+      (let* ((ncache (get-cache size))
+	     (nfield (wrapper-field 'number)))
+	(labels ((do-one-fill-from-line (line)
+		   (unless (fill-cache-from-cache-p nil nfield ncache cache line)
+		     (do-one-fill (line-wrappers line) (line-value line))))
+		 (do-one-fill (wrappers value)
+		   (multiple-value-bind (adj-field adj-cache)
+		       (adjust-cache nfield ncache wrappers value)
+		     (if adj-field
+			 (setq nfield adj-field ncache adj-cache)
+			 (fill-cache-p t nfield ncache wrappers value))))
+		 (try-one-fill (wrappers value)
+		   (fill-cache-p nil nfield ncache wrappers value)))
+	  (dotimes (i (nlines))
+	    (when (and (null (line-reserved-p i))
+		       (line-valid-p i))
+	      (do-one-fill-from-line i)))
+	  (unless (try-one-fill wrappers value)
+	    (do-one-fill wrappers value))
+	  (values nfield ncache))))))
+
+
+;;;
+;;; This is the heart of the cache filling mechanism.  It implements the decisions
+;;; about where entries are placed.
+;;; 
+;;; Find a line in the cache at which a new entry can be inserted.
+;;;
+;;;   <line>
+;;;   <empty?>           is <line> in fact empty?
+;;;
+(defun find-free-cache-line (primary field cache)
+  (declare (values line empty?))
+  (with-local-cache-functions (cache)
+    (let ((limit (funcall (limit-fn) (nlines)))
+	  (wrappedp nil))
+      (when (line-reserved-p primary) (setq primary (next-line primary)))
+      (labels (;;
+	       ;; Try to find a free line starting at <start>.  <primary>
+	       ;; is the primary line of the entry we are finding a free
+	       ;; line for, it is used to compute the seperations.
+	       ;;
+	       (find-free (p s)
+		 (do* ((line s (next-line line))
+		       (nsep (line-separation p s) (1+ nsep)))
+		      (())
+		   (if (null (line-valid-p line))	;If this line is empty or
+		       (return (values line t))	        ;invalid, just use it.
+
+		       (let ((osep (line-separation (line-primary field line) line)))
+			 (if (and wrappedp (>= line primary))
+			     ;;
+			     ;; have gone all the way around the cache, time to quit
+			     ;; 
+			     (return (values line nil))
+			     
+			     (when (cond ((or (= nsep limit)) t)
+					 ((= nsep osep) (zerop (random 2)))
+					 ((> nsep osep) t)
+					 (t nil))
+			       ;;
+			       ;; Try to displace what is in this line so that we
+			       ;; can use the line.
+			       ;;
+			       (return (values line (displace line)))))))
+		   
+		   (if (= line (1- (nlines))) (setq wrappedp t))))
+	       ;;
+	       ;; Given a line, attempt to free up that line by moving its
+	       ;; contents elsewhere. Returns nil when it wasn't possible to
+	       ;; move the contents of the line without dumping something on
+	       ;; the floor.  
+	       ;; 
+	       (displace (line)
+		 (if (= line (1- (nlines))) (setq wrappedp t))
+		 (multiple-value-bind (dline dempty?)
+		     (find-free (line-primary field line) (next-line line))
+		   (when dempty? (copy-line line dline) t))))
+	
diff --git a/pcl/cmu-low.lisp b/pcl/cmu-low.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..e529dbc193e192715f4762152da20b1cd7a135bb
--- /dev/null
+++ b/pcl/cmu-low.lisp
@@ -0,0 +1,59 @@
+;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;; 
+;;; This is the CMU Lisp version of the file low.
+;;; 
+
+(in-package 'pcl)
+
+  ;;   
+;;;;;; Cache No's
+  ;;  
+
+;;; Abuse the type declaration, but it generates great code.
+
+;(defun symbol-cache-no (symbol mask)
+;  (logand (the fixnum (system:%primitive lisp::make-immediate-type
+;					 symbol
+;					 system::%+-fixnum-type))
+;	  (the fixnum mask)))
+;
+;(clc::deftransform symbol-cache-no symbol-cache-no-transform (symbol mask)
+;  `(logand (the fixnum (system:%primitive lisp::make-immediate-type
+;					  ,symbol
+;					  system::%+-fixnum-type))
+;	   (the fixnum ,mask)))
+
+(defun object-cache-no (symbol mask)
+  (logand (the fixnum (system:%primitive lisp::make-immediate-type
+					 symbol
+					 system::%+-fixnum-type))
+	  (the fixnum mask)))
+
+(clc::deftransform object-cache-no object-cache-no-transform (symbol mask)
+  `(logand (the fixnum (system:%primitive lisp::make-immediate-type
+					  ,symbol
+					  system::%+-fixnum-type))
diff --git a/pcl/combin.lisp b/pcl/combin.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..d9fa167533e97a4c4530eeb1fa3d7ff703b25a32
--- /dev/null
+++ b/pcl/combin.lisp
@@ -0,0 +1,273 @@
+;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+
+(in-package 'pcl)
+
+(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))))))
+
diff --git a/pcl/compat.lisp b/pcl/compat.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..5d1b994964d070095c5885f7613bd206b0f59ef1
--- /dev/null
+++ b/pcl/compat.lisp
@@ -0,0 +1,30 @@
+;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp; -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+
+(in-package 'pcl)
+
+()
diff --git a/pcl/construct.lisp b/pcl/construct.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..9ee73d7ecb275e19aa5a21cb208bc719199089fd
--- /dev/null
+++ b/pcl/construct.lisp
@@ -0,0 +1,1100 @@
+;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+;;;
+;;; This file defines the defconstructor and other make-instance optimization
+;;; mechanisms.
+;;; 
+
+(in-package 'pcl)
+
+;;;
+;;; defconstructor is used to define special purpose functions which just
+;;; call make-instance with a symbol as the first argument.  The semantics
+;;; of defconstructor is that it is equivalent to defining a function which
+;;; just calls make-instance. The purpose of defconstructor is to provide
+;;; PCL with a way of noticing these calls to make-instance so that it can
+;;; optimize them.  Specific ports of PCL could just have their compiler
+;;; spot these calls to make-instance and then call this code.  Having the
+;;; special defconstructor facility is the best we can do portably.
+;;; 
+;;;
+;;; A call to defconstructor like:
+;;;
+;;;  (defconstructor make-foo foo (a b &rest r) a a :mumble b baz r)
+;;;
+;;; Is equivalent to a defun like:
+;;;
+;;;  (defun make-foo (a b &rest r)
+;;;    (make-instance 'foo 'a a ':mumble b 'baz r))
+;;;
+;;; Calls like the following are also legal:
+;;;
+;;;  (defconstructor make-foo foo ())
+;;;  (defconstructor make-bar bar () :x *x* :y *y*)
+;;;  (defconstructor make-baz baz (a b c) a-b (list a b) b-c (list b c))
+;;;
+;;;
+;;; The general idea of this implementation is that the expansion of the
+;;; defconstructor form includes the creation of closure generators which
+;;; can be called to create constructor code for the class.  The ways that
+;;; a constructor can be optimized depends not only on the defconstructor
+;;; form, but also on the state of the class and the generic functions in
+;;; the initialization protocol.  Because of this, the determination of the
+;;; form of constructor code to be used is a two part process.
+;;;
+;;; At compile time, make-constructor-code-generators looks at the actual
+;;; defconstructor form and makes a list of appropriate constructor code
+;;; generators.  All that is really taken into account here is whether
+;;; any initargs are supplied in the call to make-instance, and whether
+;;; any of those are constant.
+;;;
+;;; At constructor code generation time (see note about lazy evaluation)
+;;; compute-constructor-code calls each of the constructor code generators
+;;; to try to get code for this constructor.  Each generator looks at the
+;;; state of the class and initialization protocol generic functions and
+;;; decides whether its type of code is appropriate.  This depends on things
+;;; like whether there are any applicable methods on initialize-instance,
+;;; whether class slots are affected by initialization etc.
+;;; 
+;;;
+;;; Constructor objects are funcallable instances, the protocol followed to
+;;; to compute the constructor code for them is quite similar to the protocol
+;;; followed to compute the discriminator code for a generic function.  When
+;;; the constructor is first loaded, we install as its code a function which
+;;; will compute the actual constructor code the first time it is called.
+;;; 
+;;; If there is an update to the class structure which might invalidate the
+;;; optimized constructor, the special lazy constructor installer is put back
+;;; so that it can compute the appropriate constructor when it is called.
+;;; This is the same kind of lazy evaluation update strategy used elswhere
+;;; in PCL.
+;;;
+;;; To allow for flexibility in the PCL implementation and to allow PCL users
+;;; to specialize this constructor facility for their own metaclasses, there
+;;; is an internal protocol followed by the code which loads and installs
+;;; the constructors.  This is documented in the comments in the code.
+;;;
+;;; This code is also designed so that one of its levels, can be used to
+;;; implement optimization of calls to make-instance which can't go through
+;;; the defconstructor facility.  This has not been implemented yet, but the
+;;; hooks are there.
+;;;
+;;;
+
+(defmacro defconstructor
+	  (name class lambda-list &rest initialization-arguments)
+  (expand-defconstructor class
+			 name
+			 lambda-list
+			 (copy-list initialization-arguments)))
+
+(defun expand-defconstructor (class-name name lambda-list supplied-initargs)
+  (let ((class (find-class class-name nil))
+	(supplied-initarg-names
+	  (gathering1 (collecting)
+	    (iterate ((name (*list-elements supplied-initargs :by #'cddr)))
+	      (gather1 name)))))
+    (when (null class)
+      (error "defconstructor form being compiled (or evaluated) before~@
+              class ~S is defined."
+	     class-name))
+    `(progn
+       ;; In order to avoid undefined function warnings, we want to tell
+       ;; the compile time environment that a function with this name and
+       ;; this argument list has been defined.  The portable way to do this
+       ;; is with defun.
+       (proclaim '(notinline ,name))
+       (defun ,name ,lambda-list
+	 (declare (ignore ,@(specialized-lambda-list-parameters lambda-list)))
+	 (error "Constructor ~S not loaded." ',name))
+
+       ,(make-top-level-form `(defconstructor ,name)
+			     '(load eval)
+	  `(load-constructor
+	     ',class-name
+	     ',(class-name (class-of class))
+	     ',name
+	     ',supplied-initarg-names
+	     ;; make-constructor-code-generators is called to return a list
+	     ;; of constructor code generators.  The actual interpretation
+	     ;; of this list is left to compute-constructor-code, but the
+	     ;; general idea is that it should be an plist where the keys
+	     ;; name a kind of constructor code and the values are generator
+	     ;; functions which return the actual constructor code.  The
+	     ;; constructor code is usually a closures over the arguments
+	     ;; to the generator.
+	     ,(make-constructor-code-generators class
+						name
+						lambda-list
+						supplied-initarg-names
+						supplied-initargs))))))
+
+(defun load-constructor (class-name metaclass-name constructor-name
+			 supplied-initarg-names code-generators)
+  (let ((class (find-class class-name nil)))
+    (cond ((null class)
+	   (error "defconstructor form being loaded (or evaluated) before~@
+                   class ~S is defined."
+		  class-name))
+	  ((neq (class-name (class-of class)) metaclass-name)
+	   (error "When defconstructor ~S was compiled, the metaclass of the~@
+                   class ~S was ~S.  The metaclass is now ~S.~@
+                   The constructor must be recompiled."
+		  constructor-name
+		  class-name
+		  metaclass-name
+		  (class-name (class-of class))))
+	  (t
+	   (load-constructor-internal class
+				      constructor-name
+				      supplied-initarg-names
+				      code-generators)
+	   constructor-name))))
+
+;;;
+;;; The actual constructor objects.
+;;; 
+(defclass constructor ()			   
+     ((class					;The class with which this
+	:initarg :class				;constructor is associated.
+	:reader constructor-class)		;The actual class object,
+						;not the class name.
+						;      
+      (name					;The name of this constructor.
+	:initform nil				;This is the symbol in whose
+	:initarg :name				;function cell the constructor
+	:reader constructor-name)		;usually sits.  Of course, this
+						;is optional.  defconstructor
+						;makes named constructors, but
+						;it is possible to manipulate
+						;anonymous constructors also.
+						;
+      (code-type				;The type of code currently in
+	:initform nil				;use by this constructor.  This
+	:accessor constructor-code-type)	;is mostly for debugging and
+						;analysis purposes.
+						;The lazy installer sets this
+						;to LAZY.  The most basic and
+						;least optimized type of code
+						;is called FALLBACK.
+						;
+      (supplied-initarg-names			;The names of the initargs this
+	:initarg :supplied-initarg-names	;constructor supplies when it
+	:reader					;"calls" make-instance.
+	   constructor-supplied-initarg-names)	;
+						;
+      (code-generators				;Generators for the different
+	:initarg :code-generators		;types of code this constructor
+	:reader constructor-code-generators))	;could use.
+  (:metaclass funcallable-standard-class))
+
+
+;;;
+;;; Because the value in the code-type slot should always correspond to the
+;;; funcallable-instance-function of the constructor, this function should
+;;; always be used to set the both at the same time.
+;;;
+(defun set-constructor-code (constructor code type)
+  (set-funcallable-instance-function constructor code)
+  (set-function-name constructor (constructor-name constructor))
+  (setf (constructor-code-type constructor) type))
+
+
+(defmethod print-object ((constructor constructor) stream)
+  (printing-random-thing (constructor stream)
+    (format stream
+	    "~S ~S (~S)"
+	    (or (class-name (class-of constructor)) "Constructor")
+	    (or (constructor-name constructor) "Anonymous")
+	    (constructor-code-type constructor))))
+
+(defmethod describe-object ((constructor constructor) stream)
+  (format stream
+	  "~S is a constructor for the class ~S.~%~
+            The current code type is ~S.~%~
+            Other possible code types are ~S."
+	  constructor (constructor-class constructor)
+	  (constructor-code-type constructor)
+	  (gathering1 (collecting)
+	    (doplist (key val) (constructor-code-generators constructor)
+	      (gather1 key)))))
+
+;;;
+;;; I am not in a hairy enough mood to make this implementation be metacircular
+;;; enough that it can support a defconstructor for constructor objects.
+;;; 
+(defun make-constructor (class name supplied-initarg-names code-generators)
+  (make-instance 'constructor
+		 :class class
+		 :name name
+		 :supplied-initarg-names supplied-initarg-names
+		 :code-generators code-generators))
+
+; This definition actually appears in std-class.lisp.
+;(defmethod class-constructors ((class std-class))
+;  (with-slots (plist) class (getf plist 'constructors)))
+
+(defmethod add-constructor ((class std-class)
+			    (constructor constructor))
+  (with-slots (plist) class
+    (pushnew constructor (getf plist 'constructors))))
+
+(defmethod remove-constructor ((class std-class)
+			       (constructor constructor))
+  (with-slots (plist) class
+    (setf (getf plist 'constructors)
+	  (delete constructor (getf plist 'constructors)))))
+
+(defmethod get-constructor ((class std-class) name &optional (error-p t))
+  (or (dolist (c (class-constructors class))
+	(when (eq (constructor-name c) name) (return c)))
+      (if error-p
+	  (error "Couldn't find a constructor with name ~S for class ~S."
+		 name class)
+	  ())))
+
+;;;
+;;; This is called to actually load a defconstructor constructor.  It must
+;;; install the lazy installer in the function cell of the constructor name,
+;;; and also add this constructor to the list of constructors the class has.
+;;; 
+(defmethod load-constructor-internal
+	   ((class std-class) name initargs generators)
+  (let ((constructor (make-constructor class name initargs generators))
+	(old (get-constructor class name nil)))
+    (when old (remove-constructor class old))
+    (install-lazy-constructor-installer constructor)
+    (add-constructor class constructor)
+    (setf (symbol-function name) constructor)))
+
+(defmethod install-lazy-constructor-installer ((constructor constructor))
+  (let ((class (constructor-class constructor)))
+    (set-constructor-code constructor
+			  #'(lambda (&rest args)
+			      (multiple-value-bind (code type)
+				  (compute-constructor-code class constructor)
+				(prog1 (apply code args)
+				       (set-constructor-code constructor
+							     code
+							     type))))
+			  'lazy)))
+
+;;;
+;;; The interface to keeping the constructors updated.
+;;;
+;;; add-method and remove-method (for standard-generic-function and -method),
+;;; promise to call maybe-update-constructors on the generic function and
+;;; the method.
+;;; 
+;;; The class update code promises to call update-constructors whenever the
+;;; class is changed.  That is, whenever the supers, slots or options change.
+;;; If user defined classes of constructor needs to be updated in more than
+;;; these circumstances, they should use the dependent updating mechanism to
+;;; make sure update-constructors is called.
+;;;
+;;; Bootstrapping concerns force the definitions of maybe-update-constructors
+;;; and update-constructors to be in the file std-class.  For clarity, they
+;;; also appear below.  Be sure to keep the definition here and there in sync.
+;;; 
+;(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))
+;  ())
+
+
+
+;;;
+;;; Here is the actual smarts for making the code generators and then trying
+;;; each generator to get constructor code. This extensible mechanism allows
+;;; new kinds of constructor code types to be added. A programmer defining a
+;;; specialization of the constructor class can either use this mechanism to
+;;; define new code types, or can override this mechanism by overriding the
+;;; methods on make-constructor-code-generators and compute-constructor-code.
+;;;
+;;; The function defined by define-constructor-code-type will receive the
+;;; class object, and the 4 original arguments to defconstructor. It can
+;;; return a constructor code generator, or return nil if this type of code
+;;; is determined to not be appropriate after looking at the defconstructor
+;;; arguments.
+;;;
+;;; When compute-constructor-code is called, it first performs basic checks
+;;; to make sure that the basic assumptions common to all the code types are
+;;; valid.  (For details see method definition).  If any of the tests fail,
+;;; the fallback constructor code type is used.  If none of the tests fail,
+;;; the constructor code generators are called in order.  They receive 5
+;;; arguments:
+;;;
+;;;   CLASS        the class the constructor is making instances of
+;;;   WRAPPER      that class's wrapper
+;;;   DEFAULTS     the result of calling class-default-initargs on class
+;;;   INITIALIZE   the applicable methods on initialize-instance
+;;;   SHARED       the applicable methosd on shared-initialize
+;;;
+;;; The first code generator to return code is used.  The code generators are
+;;; called in reverse order of definition, so define-constructor-code-type
+;;; forms which define better code should appear after ones that define less
+;;; good code.  The fallback code type appears first.  Note that redefining a
+;;; code type does not change its position in the list.  To do that,  define
+;;; a new type at the end with the behavior.
+;;; 
+
+(defvar *constructor-code-types* ())
+
+(defmacro define-constructor-code-type (type arglist &body body)
+  (let ((fn-name (intern (format nil
+				 "CONSTRUCTOR-CODE-GENERATOR ~A ~A"
+				 (package-name (symbol-package type))
+				 (symbol-name type))
+			 *the-pcl-package*)))
+    `(progn
+       (defun ,fn-name ,arglist .,body)
+       (load-define-constructor-code-type ',type ',fn-name))))
+
+(defun load-define-constructor-code-type (type generator)
+  (let ((old-entry (assq type *constructor-code-types*)))
+    (if old-entry 
+	(setf (cadr old-entry) generator)
+	(push (list type generator) *constructor-code-types*))
+    type))
+
+(defmethod make-constructor-code-generators
+	   ((class std-class)
+	    name lambda-list supplied-initarg-names supplied-initargs)
+  (cons 'list
+	(gathering1 (collecting)
+	  (dolist (entry *constructor-code-types*)
+	    (let ((generator
+		    (funcall (cadr entry) class name lambda-list 
+					  supplied-initarg-names
+					  supplied-initargs)))
+	      (when generator
+		(gather1 `',(car entry))
+		(gather1 generator)))))))
+
+(defmethod compute-constructor-code ((class std-class)
+				     (constructor constructor))
+  (let* ((proto (class-prototype class))
+	 (wrapper (class-wrapper class))
+	 (defaults (class-default-initargs class))
+         (make
+           (compute-applicable-methods #'make-instance (list class)))
+	 (supplied-initarg-names
+	   (constructor-supplied-initarg-names constructor))
+         (default
+	   (compute-applicable-methods #'default-initargs
+				       (list class supplied-initarg-names))) ;?
+         (allocate
+           (compute-applicable-methods #'allocate-instance (list class)))
+         (initialize
+           (compute-applicable-methods #'initialize-instance (list proto)))
+         (shared
+           (compute-applicable-methods #'shared-initialize (list proto t)))
+         (code-generators
+           (constructor-code-generators constructor))
+	 (code-generators
+	   (constructor-code-generators constructor)))
+    (flet ((call-code-generator (generator)
+	     (when (null generator)
+	       (unless (setq generator (getf code-generators 'fallback))
+		 (error "No FALLBACK generator?")))
+	     (funcall generator class wrapper defaults initialize shared)))
+      (if (or (cdr make)
+	      (cdr default)
+	      (cdr allocate)
+	      (check-initargs class
+			      supplied-initarg-names
+			      defaults
+			      (append initialize shared)))
+	  ;; These are basic shared assumptions, if one of the
+	  ;; has been violated, we have to resort to the fallback
+	  ;; case.  Any of these assumptions could be moved out
+	  ;; of here and into the individual code types if there
+	  ;; was a need to do so.
+	  (values (call-code-generator nil) 'fallback)
+	  ;; Otherwise try all the generators until one produces
+	  ;; code for us.
+	  (doplist (type generator) code-generators
+	    (let ((code (call-code-generator generator)))
+	      (when code (return (values code type)))))))))
+
+;;;
+;;; The facilities are useful for debugging, and to measure the performance
+;;; boost from constructors.
+;;; 
+
+(defun map-constructors (fn)
+  (let ((nclasses 0)
+	(nconstructors 0))
+    (labels ((recurse (class)
+	       (incf nclasses)
+	       (dolist (constructor (class-constructors class))
+		 (incf nconstructors)
+		 (funcall fn constructor))
+	       (dolist (subclass (class-direct-subclasses class))
+		 (recurse subclass))))
+      (recurse (find-class 't))
+      (values nclasses nconstructors))))
+
+(defun reset-constructors ()
+  (multiple-value-bind (nclass ncons)
+      (map-constructors #'install-lazy-constructor-installer )
+    (format t "~&~D classes, ~D constructors." nclass ncons)))
+
+(defun disable-constructors ()
+  (multiple-value-bind (nclass ncons)
+      (map-constructors
+	#'(lambda (c)
+	    (let ((gen (getf (constructor-code-generators c) 'fallback)))
+	      (if (null gen)
+		  (error "No fallback constructor for ~S." c)
+		  (set-constructor-code c
+					(funcall gen
+						 (constructor-class c)
+						 () () () ())
+					'fallback)))))
+    (format t "~&~D classes, ~D constructors." nclass ncons)))
+
+(defun enable-constructors ()
+  (reset-constructors))
+
+
+;;;
+;;; Helper functions and utilities that are shared by all of the code types
+;;; and by the main compute-constructor-code method as well.
+;;; 
+
+(defvar *standard-initialize-instance-method*
+        (get-method #'initialize-instance
+		    ()
+		    (list *the-class-standard-object*)))
+
+(defvar *standard-shared-initialize-method*
+        (get-method #'shared-initialize
+		    ()
+		    (list *the-class-standard-object* *the-class-t*)))
+
+(defun non-pcl-initialize-instance-methods-p (methods)
+  (notevery #'(lambda (m) (eq m *standard-initialize-instance-method*))
+	    methods))
+
+(defun non-pcl-shared-initialize-methods-p (methods)
+  (notevery #'(lambda (m) (eq m *standard-shared-initialize-method*))
+	    methods))
+
+(defun non-pcl-or-after-initialize-instance-methods-p (methods)
+  (notevery #'(lambda (m) (or (eq m *standard-initialize-instance-method*)
+			      (equal '(:after) (method-qualifiers m))))
+	    methods))
+
+(defun non-pcl-or-after-shared-initialize-methods-p (methods)
+  (notevery #'(lambda (m) (or (eq m *standard-shared-initialize-method*)
+			      (equal '(:after) (method-qualifiers m))))
+	    methods))
+
+
+;;; 
+;;; if initargs are valid return nil, otherwise return t.
+;;;
+(defun check-initargs (class supplied-initarg-names defaults methods)
+  (let ((legal (apply #'append
+		      (mapcar #'slotd-initargs (class-slots class)))))
+    ;; 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 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.
+    (dolist (key supplied-initarg-names)
+      (unless (memq key legal)
+	(return-from check-initargs t)))
+    (dolist (default defaults)
+      (unless (memq (car default) legal)
+	(return-from check-initargs t)))))
+
+
+;;;
+;;; This returns two values.  The first is a vector which can be used as the
+;;; initial value of the slots vector for the instance. The first is a symbol
+;;; describing the initforms this class has.  
+;;;
+;;;  If the first value is:
+;;;
+;;;    :unsupplied    no slot has an initform
+;;;    :constants     all slots have either a constant initform
+;;;                   or no initform at all
+;;;    t              there is at least one non-constant initform
+;;; 
+(defun compute-constant-vector (class)
+  (declare (values constants flag))
+  (let* ((wrapper (class-wrapper class))
+	 (layout (wrapper-instance-slots-layout wrapper))
+	 (flag :unsupplied)
+	 (constants ()))
+    (dolist (slotd (class-slots class))
+      (let ((name (slotd-name slotd))
+	    (initform (slotd-initform slotd)))
+	(cond ((null (memq name layout)))
+	      ((eq initform *slotd-unsupplied*)
+	       (push (cons name *slot-unbound*) constants))
+	      ((constantp initform)
+	       (push (cons name (eval initform)) constants)
+	       (when (eq flag ':unsupplied) (setq flag ':constants)))
+	      (t
+	       (push (cons name *slot-unbound*) constants)
+	       (setq flag 't)))))
+    (values
+      (apply #'vector
+	     (mapcar #'cdr
+		     (sort constants #'(lambda (x y)
+					 (memq (car y)
+					       (memq (car x) layout))))))
+      flag)))
+
+(defmacro copy-constant-vector (constants)
+  `(copy-seq (the simple-vector ,constants)))
+
+
+;;;
+;;; This takes a class and a list of initarg-names, and returns an alist
+;;; indicating the positions of the slots those initargs may fill.  The
+;;; order of the initarg-names argument is important of course, since we
+;;; have to respect the rules about the leftmost initarg that fills a slot
+;;; having precedence.  This function allows initarg names to appear twice
+;;; in the list, it only considers the first appearance.
+;;;
+(defun compute-initarg-positions (class initarg-names)
+  (let* ((layout (wrapper-instance-slots-layout (class-wrapper class)))
+	 (positions
+	   (gathering1 (collecting)
+	     (iterate ((slot-name (list-elements layout))
+		       (position (interval :from 0)))
+	       (gather1 (cons slot-name position)))))
+	 (slot-initargs
+	   (mapcar #'(lambda (slotd)
+		       (list (slotd-initargs slotd)
+			     (or (cdr (assq (slotd-name slotd) positions))
+				 ':class)))
+		   (class-slots class))))
+    ;; Go through each of the initargs, and figure out what position
+    ;; it fills by replacing the entries in slot-initargs it fills.
+    (dolist (initarg initarg-names)
+      (dolist (slot-entry slot-initargs)
+	(let ((slot-initargs (car slot-entry)))
+	  (when (and (listp slot-initargs)
+		     (not (null slot-initargs))
+		     (memq initarg slot-initargs))
+	    (setf (car slot-entry) initarg)))))
+    (gathering1 (collecting)
+      (dolist (initarg initarg-names)
+	(let ((positions (gathering1 (collecting)
+			   (dolist (slot-entry slot-initargs)
+			     (when (eq (car slot-entry) initarg)
+			       (gather1 (cadr slot-entry)))))))
+	  (when positions
+	    (gather1 (cons initarg positions))))))))
+
+
+;;;
+;;; The FALLBACK case allows anything.  This always works, and always appears
+;;; as the last of the generators for a constructor.  It does a full call to
+;;; make-instance.
+;;;
+
+(define-constructor-code-type fallback
+        (class name arglist supplied-initarg-names supplied-initargs)
+  (declare (ignore name supplied-initarg-names))
+  `(function
+     (lambda (&rest ignore)
+       (declare (ignore ignore))
+       (function
+	 (lambda ,arglist
+	   (make-instance
+	     ',(class-name class)
+	     ,@(gathering1 (collecting)
+		 (iterate ((tail (*list-tails supplied-initargs :by #'cddr)))
+		   (gather1 `',(car tail))
+		   (gather1 (cadr tail))))))))))
+
+;;;
+;;; The GENERAL case allows:
+;;;   constant, unsupplied or non-constant initforms
+;;;   constant or non-constant default initargs
+;;;   supplied initargs
+;;;   slot-filling initargs
+;;;   :after methods on shared-initialize and initialize-instance
+;;;   
+(define-constructor-code-type general
+        (class name arglist supplied-initarg-names supplied-initargs)
+  (declare (ignore name))
+  (let ((raw-allocator (raw-instance-allocator class))
+	(slots-fetcher (slots-fetcher class))
+	(wrapper-fetcher (wrapper-fetcher class)))
+    `(function
+       (lambda (class .wrapper. defaults init shared)
+	 (multiple-value-bind (.constants.
+			       .constant-initargs.
+			       .initfns-initargs-and-positions.
+			       .supplied-initarg-positions.
+			       .shared-initfns.
+			       .initfns.)
+	     (general-generator-internal class
+					 defaults
+					 init
+					 shared
+					 ',supplied-initarg-names
+					 ',supplied-initargs)
+	   .supplied-initarg-positions.
+	   (when (and .constants.
+		      (null (non-pcl-or-after-initialize-instance-methods-p
+			      init))
+		      (null (non-pcl-or-after-shared-initialize-methods-p
+			      shared)))
+	     (function
+	       (lambda ,arglist
+		 (declare (optimize (speed 3) (safety 0)))
+		 (let ((.instance. (,raw-allocator))
+		       (.slots. (copy-constant-vector .constants.))
+		       (.positions. .supplied-initarg-positions.)
+		       (.initargs. .constant-initargs.))		   
+		   .positions.
+		   
+		   (setf (,slots-fetcher .instance.) .slots.)	     
+		   (setf (,wrapper-fetcher .instance.) .wrapper.)
+
+		   (dolist (entry .initfns-initargs-and-positions.)
+		     (let ((val (funcall (car entry)))
+			   (initarg (cadr entry)))
+		       (when initarg
+			 (push val .initargs.)
+			 (push initarg .initargs.))
+		       (dolist (pos (cddr entry))
+			 (setf (%svref .slots. pos) val))))
+
+		   ,@(gathering1 (collecting)
+		       (doplist (initarg value) supplied-initargs
+			 (unless (constantp value)
+			   (gather1 `(let ((.value. ,value))
+				       (push .value. .initargs.)
+				       (push ',initarg .initargs.)
+				       (dolist (.p. (pop .positions.))
+					 (setf (%svref .slots. .p.)
+					       .value.)))))))
+
+		   (dolist (fn .shared-initfns.)
+		     (apply fn .instance. t .initargs.))
+		   (dolist (fn .initfns.)
+		     (apply fn .instance. .initargs.))
+		     
+		   .instance.)))))))))
+
+(defun general-generator-internal
+       (class defaults init shared supplied-initarg-names supplied-initargs)
+  (flet ((bail-out () (return-from general-generator-internal nil)))
+    (let* ((constants (compute-constant-vector class))
+	   (layout (wrapper-instance-slots-layout (class-wrapper class)))
+	   (initarg-positions
+	     (compute-initarg-positions class
+					(append supplied-initarg-names
+						(mapcar #'car defaults))))
+	   (initfns-initargs-and-positions ())
+	   (supplied-initarg-positions ())
+	   (constant-initargs ())
+	   (used-positions ()))
+					       
+      ;;
+      ;; Go through each of the supplied initargs for three reasons.
+      ;;
+      ;;   - If it fills a class slot, bail out.
+      ;;   - If its a constant form, fill the constant vector.
+      ;;   - Otherwise remember the positions no two initargs
+      ;;     will try to fill the same position, since compute
+      ;;     initarg positions already took care of that, but
+      ;;     we do need to know what initforms will and won't
+      ;;     be needed.
+      ;;   
+      (doplist (initarg val) supplied-initargs
+	(let ((positions (cdr (assq initarg initarg-positions))))
+	  (cond ((memq :class positions) (bail-out))
+		((constantp val)
+		 (setq val (eval val))
+		 (push val constant-initargs)
+		 (push initarg constant-initargs)
+		 (dolist (pos positions) (setf (svref constants pos) val)))
+		(t
+		 (push positions supplied-initarg-positions)))
+	  (setq used-positions (append positions used-positions))))
+      ;;
+      ;; Go through each of the default initargs, for three reasons.
+      ;;
+      ;;   - If it fills a class slot, bail out.
+      ;;   - If it is a constant, and it does fill a slot, put that
+      ;;     into the constant vector.
+      ;;   - If it isn't a constant, record its initfn and position.
+      ;;   
+      (dolist (default defaults)
+	(let* ((name (car default))
+	       (initfn (cadr default))
+	       (form (caddr default))
+	       (value ())
+	       (positions (cdr (assq name initarg-positions))))
+	  (unless (memq name supplied-initarg-names)
+	    (cond ((memq :class positions) (bail-out))
+		  ((constantp form)
+		   (setq value (eval form))
+		   (push value constant-initargs)
+		   (push name constant-initargs)
+		   (dolist (pos positions)
+		     (setf (svref constants pos) value)))
+		  (t
+		   (push (list* initfn name positions)
+			 initfns-initargs-and-positions)))
+	    (setq used-positions (append positions used-positions)))))
+      ;;
+      ;; Go through each of the slot initforms:
+      ;;
+      ;;    - If its position has already been filled, do nothing.
+      ;;      The initfn won't need to be called, and the slot won't
+      ;;      need to be touched.
+      ;;    - If it is a class slot, and has an initform, bail out.
+      ;;    - If its a constant or unsupplied, ignore it, it is
+      ;;      already in the constant vector.
+      ;;    - Otherwise, record its initfn and position
+      ;;
+      (dolist (slotd (class-slots class))
+	(let* ((alloc (slotd-allocation slotd))
+	       (name (slotd-name slotd))
+	       (form (slotd-initform slotd))
+	       (initfn (slotd-initfunction slotd))
+	       (position (position name layout)))
+	  (cond ((neq alloc :instance)
+		 (unless (eq form *slotd-unsupplied*) (bail-out)))
+		((member position used-positions))
+		((or (constantp form)
+		     (eq form *slotd-unsupplied*)))
+		(t
+		 (push (list initfn nil position)
+		       initfns-initargs-and-positions)))))
+
+      (values constants
+	      constant-initargs
+	      (nreverse initfns-initargs-and-positions)
+	      (nreverse supplied-initarg-positions)
+	      (mapcar #'method-function
+		      (remove *standard-shared-initialize-method* shared))
+	      (mapcar #'method-function
+		      (remove *standard-initialize-instance-method* init))))))
+
+
+;;;
+;;; The NO-METHODS case allows:
+;;;   constant, unsupplied or non-constant initforms
+;;;   constant or non-constant default initargs
+;;;   supplied initargs that are arguments to constructor, or constants
+;;;   slot-filling initargs
+;;;
+
+(define-constructor-code-type no-methods
+        (class name arglist supplied-initarg-names supplied-initargs)
+  (declare (ignore name))
+  (let ((raw-allocator (raw-instance-allocator class))
+	(slots-fetcher (slots-fetcher class))
+	(wrapper-fetcher (wrapper-fetcher class)))
+    `(function
+       (lambda (class .wrapper. defaults init shared)
+	 (multiple-value-bind (.constants.
+			       .initfns-and-positions.
+			       .supplied-initarg-positions.)
+	     (no-methods-generator-internal class
+					    defaults
+					    ',supplied-initarg-names
+					    ',supplied-initargs)
+	   .initfns-and-positions.
+	   .supplied-initarg-positions.
+	   (when (and .constants.
+		      (null (non-pcl-initialize-instance-methods-p init))
+		      (null (non-pcl-shared-initialize-methods-p shared)))
+	     #'(lambda ,arglist
+		 (declare (optimize (speed 3) (safety 0)))
+		 (let ((.instance. (,raw-allocator))
+		       (.slots. (copy-constant-vector .constants.))
+		       (.positions. .supplied-initarg-positions.))
+		   .positions.
+		   (setf (,slots-fetcher .instance.) .slots.)
+		   (setf (,wrapper-fetcher .instance.) .wrapper.)
+
+		   (dolist (entry .initfns-and-positions.)
+		     (let ((val (funcall (car entry))))
+		       (dolist (pos (cdr entry))
+			 (setf (%svref .slots. pos) val))))
+		 
+		   ,@(gathering1 (collecting)
+		       (doplist (initarg value) supplied-initargs
+			 (unless (constantp value)
+			   (gather1
+			     `(let ((.value. ,value))
+				(dolist (.p. (pop .positions.))
+				  (setf (%svref .slots. .p.) .value.)))))))
+		     
+		   .instance.))))))))
+
+(defun no-methods-generator-internal
+       (class defaults supplied-initarg-names supplied-initargs)
+  (flet ((bail-out () (return-from no-methods-generator-internal nil)))
+    (let* ((constants	(compute-constant-vector class))
+	   (layout (wrapper-instance-slots-layout (class-wrapper class)))
+	   (initarg-positions
+	     (compute-initarg-positions class
+					(append supplied-initarg-names
+						(mapcar #'car defaults))))
+	   (initfns-and-positions ())
+	   (supplied-initarg-positions ())
+	   (used-positions ()))
+      ;;
+      ;; Go through each of the supplied initargs for three reasons.
+      ;;
+      ;;   - If it fills a class slot, bail out.
+      ;;   - If its a constant form, fill the constant vector.
+      ;;   - Otherwise remember the positions, no two initargs
+      ;;     will try to fill the same position, since compute
+      ;;     initarg positions already took care of that, but
+      ;;     we do need to know what initforms will and won't
+      ;;     be needed.
+      ;;   
+      (doplist (initarg val) supplied-initargs
+	(let ((positions (cdr (assq initarg initarg-positions))))
+	  (cond ((memq :class positions) (bail-out))
+		((constantp val)
+		 (setq val (eval val))
+		 (dolist (pos positions)
+		   (setf (svref constants pos) val)))
+		(t
+		 (push positions supplied-initarg-positions)))
+	  (setq used-positions (append positions used-positions))))
+      ;;
+      ;; Go through each of the default initargs, for three reasons.
+      ;;
+      ;;   - If it fills a class slot, bail out.
+      ;;   - If it is a constant, and it does fill a slot, put that
+      ;;     into the constant vector.
+      ;;   - If it isn't a constant, record its initfn and position.
+      ;;   
+      (dolist (default defaults)
+	(let* ((name (car default))
+	       (initfn (cadr default))
+	       (form (caddr default))
+	       (value ())
+	       (positions (cdr (assq name initarg-positions))))
+	  (unless (memq name supplied-initarg-names)
+	    (cond ((memq :class positions) (bail-out))
+		  ((constantp form)
+		   (setq value (eval form))
+		   (dolist (pos positions)
+		     (setf (svref constants pos) value)))
+		  (t
+		   (push (cons initfn positions)
+			 initfns-and-positions)))
+	    (setq used-positions (append positions used-positions)))))
+      ;;
+      ;; Go through each of the slot initforms:
+      ;;
+      ;;    - If its position has already been filled, do nothing.
+      ;;      The initfn won't need to be called, and the slot won't
+      ;;      need to be touched.
+      ;;    - If it is a class slot, and has an initform, bail out.
+      ;;    - If its a constant or unsupplied, do nothing, we know
+      ;;      that it is already in the constant vector.
+      ;;    - Otherwise, record its initfn and position
+      ;;
+      (dolist (slotd (class-slots class))
+	(let* ((alloc (slotd-allocation slotd))
+	       (name (slotd-name slotd))
+	       (form (slotd-initform slotd))
+	       (initfn (slotd-initfunction slotd))
+	       (position (position name layout)))
+	  (cond ((neq alloc :instance)
+		 (unless (eq form *slotd-unsupplied*) (bail-out)))
+		((member position used-positions))
+		((or (constantp form)
+		     (eq form *slotd-unsupplied*)))
+		(t
+		 (push (list initfn position) initfns-and-positions)))))
+
+      (values constants
+	      (nreverse initfns-and-positions)
+	      (nreverse supplied-initarg-positions)))))
+
+
+;;;
+;;; The SIMPLE-SLOTS case allows:
+;;;   constant or unsupplied initforms
+;;;   constant default initargs
+;;;   supplied initargs
+;;;   slot filling initargs
+;;;
+
+(define-constructor-code-type simple-slots
+        (class name arglist supplied-initarg-names supplied-initargs)
+  (declare (ignore name))
+  (let ((raw-allocator (raw-instance-allocator class))
+	(slots-fetcher (slots-fetcher class))
+	(wrapper-fetcher (wrapper-fetcher class)))
+    `(function
+       (lambda (class .wrapper. defaults init shared)
+	 (when (and (null (non-pcl-initialize-instance-methods-p init))
+		    (null (non-pcl-shared-initialize-methods-p shared)))
+	   (multiple-value-bind (.constants. .supplied-initarg-positions.)
+	       (simple-slots-generator-internal class
+						defaults
+						',supplied-initarg-names
+						',supplied-initargs)
+	     (when .constants.
+	       (function
+		 (lambda ,arglist
+		   (declare (optimize (speed 3) (safety 0)))
+		   (let ((.instance. (,raw-allocator))
+			 (.slots. (copy-constant-vector .constants.))
+			 (.positions. .supplied-initarg-positions.))
+		     
+		     .positions.
+		     (setf (,slots-fetcher .instance.) .slots.)	     
+		     (setf (,wrapper-fetcher .instance.) .wrapper.)
+		 
+		     ,@(gathering1 (collecting)
+			 (doplist (initarg value) supplied-initargs
+			   (unless (constantp value)
+			     (gather1
+			       `(let ((.value. ,value))
+				  (dolist (.p. (pop .positions.))
+				    (setf (%svref .slots. .p.) .value.)))))))
+		     
+		     .instance.))))))))))
+
+(defun simple-slots-generator-internal
+       (class defaults supplied-initarg-names supplied-initargs)
+  (flet ((bail-out () (return-from simple-slots-generator-internal nil)))
+    (let* ((constants (compute-constant-vector class))
+	   (layout (wrapper-instance-slots-layout (class-wrapper class)))
+	   (initarg-positions
+	     (compute-initarg-positions class
+					(append supplied-initarg-names
+						(mapcar #'car defaults))))
+	   (supplied-initarg-positions ())
+	   (used-positions ()))
+      ;;
+      ;; Go through each of the supplied initargs for three reasons.
+      ;;
+      ;;   - If it fills a class slot, bail out.
+      ;;   - If its a constant form, fill the constant vector.
+      ;;   - Otherwise remember the positions, no two initargs
+      ;;     will try to fill the same position, since compute
+      ;;     initarg positions already took care of that, but
+      ;;     we do need to know what initforms will and won't
+      ;;     be needed.
+      ;;   
+      (doplist (initarg val) supplied-initargs
+	(let ((positions (cdr (assq initarg initarg-positions))))
+	  (cond ((memq :class positions) (bail-out))
+		((constantp val)
+		 (setq val (eval val))
+		 (dolist (pos positions)
+		   (setf (svref constants pos) val)))
+		(t
+		 (push positions supplied-initarg-positions)))
+	  (setq used-positions (append used-positions positions))))
+      ;;
+      ;; Go through each of the default initargs for three reasons.
+      ;; 
+      ;;   - If it isn't a constant form, bail out.
+      ;;   - If it fills a class slot, bail out.
+      ;;   - If it is a constant, and it does fill a slot, put that
+      ;;     into the constant vector.
+      ;;   
+      (dolist (default defaults)
+	(let* ((name (car default))
+	       (form (caddr default))
+	       (value ())
+	       (positions (cdr (assq name initarg-positions))))
+	  (unless (memq name supplied-initarg-names)
+	    (cond ((memq :class positions) (bail-out))
+		  ((not (constantp form))
+		   (bail-out))
+		  (t
+		   (setq value (eval form))
+		   (dolist (pos positions)
+		     (setf (svref constants pos) value)))))))
+      ;;
+      ;; Go through each of the slot initforms:
+      ;;
+      ;;    - If its position has already been filled, do nothing.
+      ;;      The initfn won't need to be called, and the slot won't
+      ;;      need to be touched, we are OK.
+      ;;    - If it has a non-constant initform, bail-out.  This
+      ;;      case doesn't handle those.
+      ;;    - If it has a constant or unsupplied initform we don't
+      ;;      really need to do anything, the value is in the
+      ;;      constants vector.
+      ;;
+      (dolist (slotd (class-slots class))
+	(let* ((alloc (slotd-allocation slotd))
+	       (name (slotd-name slotd))
+	       (form (slotd-initform slotd))
+	       (position (position name layout)))
+	  (cond ((neq alloc :instance)
+		 (unless (eq form *slotd-unsupplied*) (bail-out)))
+		((member position used-positions))
+		((or (constantp form)
+		     (eq form *slotd-unsupplied*)))
+		(t
+		 (bail-out)))))
+      
+      (values constants (nreverse supplied-initarg-positions)))))
diff --git a/pcl/coral-low.lisp b/pcl/coral-low.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..58ed3105070aa6ff438b03060546f9cab68cca84
--- /dev/null
+++ b/pcl/coral-low.lisp
@@ -0,0 +1,61 @@
+;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+
+(in-package 'pcl)
+
+#-:ccl-1.3
+(ccl::add-transform 'std-instance-p 
+                     :inline 
+                     #'(lambda (call)
+                         (ccl::verify-arg-count call 1 1)
+                         (let ((arg (cadr call)))
+                           `(and (eq (ccl::%type-of ,arg) 'structure)
+                                 (eq (%svref ,arg 0) 'std-instance)))))
+
+(eval-when (eval compile load)
+  (proclaim '(inline std-instance-p)))
+
+(defun printing-random-thing-internal (thing stream)
+  (prin1 (ccl::%ptr-to-int thing) stream))
+
+(defun set-function-name-1 (function new-name uninterned-name)
+  (declare (ignore uninterned-name))
+  (cond ((ccl::lfunp function)
+         (ccl::lfun-name function new-name)))
+  function)
+
+
+(defun doctor-dfun-for-the-debugger (gf dfun)
+  #+:ccl-1.3
+  (let* ((gfspec (and (symbolp (generic-function-name gf))
+		      (generic-function-name gf)))
+	 (arglist (generic-function-pretty-arglist gf)))
+    (when gfspec
+      (setf (get gfspec 'ccl::%lambda-list)
+	    (if (and arglist (listp arglist))
+		(format nil "~{~A~^ ~}" arglist)
+		(format nil "~:A" arglist)))))
diff --git a/pcl/cpatch.lisp b/pcl/cpatch.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..7cd013beaf53085a893dfb9cb207f9b2a4c74dc3
--- /dev/null
+++ b/pcl/cpatch.lisp
@@ -0,0 +1,31 @@
+;;				-[Thu Feb 22 08:38:07 1990 by jkf]-
+;; cpatch.cl
+;;  compiler patch for the fast clos
+;;  
+;; copyright (c) 1990 Franz Inc.
+;;
+
+(in-package :comp)
+
+(def-quad-op tail-funcall qp-end-block
+  ;; u = (argcount function-object)
+  ;;
+  ;; does a tail call to the function-object given
+  ;; never returns
+  )
+
+(defun-in-runtime sys::copy-function (func))
+
+(in-package :hyperion)
+
+(def-quad-hyp r-tail-funcall comp::tail-funcall (u d quad)
+  ;; u = (argcount function)
+  ;;
+  (r-move-single-to-loc (treg-loc (car u)) *count-reg*)
+  (r-move-single-to-loc (treg-loc (cadr u)) *fcnin-reg*)
+  (re restore *zero-reg* *zero-reg*)
+  (re move.l `(d #.r-function-start-adj #.*fcnout-reg*) '#.*ctr2-reg*)
+  (re jmpl '(d 0 #.*ctr2-reg*) *zero-reg*)
+  (re nop))
+  
+  
diff --git a/pcl/cpl.lisp b/pcl/cpl.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..ea0313380ad21a77880c105f2fd3e0afe0c2670c
--- /dev/null
+++ b/pcl/cpl.lisp
@@ -0,0 +1,310 @@
+;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+
+(in-package 'pcl)
+
+;;;
+;;; 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 ()))
+  (cpd-class  nil)
+  (cpd-supers ())
+  (cpd-after  ())
+  (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 ())
+	(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 ())
+	(next-cpd nil)
+	(rcpl ()))
+    ;;
+    ;; 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 ()))
+		(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 ())           ;List of classes we have visited.
+	(cycle-reasons ()))
+    
+    (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 ()))
+		 (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))))
+
diff --git a/pcl/ctypes.lisp b/pcl/ctypes.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..fbe7119e877d696768f4fed646b056ebae79d8f6
--- /dev/null
+++ b/pcl/ctypes.lisp
@@ -0,0 +1,44 @@
+;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+
+(in-package 'pcl)
+
+;;;
+;;; 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)
diff --git a/pcl/defclass.lisp b/pcl/defclass.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..a920059da4b2808c3457f8c705f485556750434c
--- /dev/null
+++ b/pcl/defclass.lisp
@@ -0,0 +1,257 @@
+;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+
+(in-package 'pcl)
+
+;;;
+;;; 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 ()
+	   (if (and (listp name)
+		    (memq (car name) '(class method method-combination)))
+	       (format nil "~A~{ ~S~}"
+		       (capitalize-words (car name) ()) (cdr name))
+	       (format nil "~S" name))))
+    (definition-name)
+    #+Genera
+    (let ((thunk-name (make-symbol "TOP-LEVEL-FORM")))
+      `(eval-when ,times
+	 (defun ,thunk-name () (declare (sys:function-parent ,@name)) ,form)
+	 (,thunk-name)))
+    #+LCL3.0
+    `(compiler-let ((lucid::*compiler-message-string*
+		      (or lucid::*compiler-message-string*
+			  ,(definition-name))))
+       (eval-when ,times ,form))
+    #-(or Genera LCL3.0)
+    (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* ())
+	  (*accessors* ()))			;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*)
+	(make-top-level-form `(defclass ,name)
+			     *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))
+	 '(function true))
+	((or (eq initform 'nil)
+	     (equal initform ''nil))
+	 '(function false))
+	((or (eql initform '0)
+	     (equal initform ''0))
+	 '(function zero))
+	(t
+	 (let ((entry (assoc initform *initfunctions* :test #'equal)))
+	   (unless entry
+	     (setq entry (list initform
+			       (gensym)
+			       `(function (lambda () ,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 ())
+		(writers ())
+		(initargs ())
+		(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 ()))
+	(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* ())
+
+(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))
diff --git a/pcl/defcombin.lisp b/pcl/defcombin.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..a342056ebf7107847ae4b257a9140d5a2518c175
--- /dev/null
+++ b/pcl/defcombin.lisp
@@ -0,0 +1,429 @@
+;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+
+(in-package 'pcl)
+
+;;;
+;;; 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.))))
+
diff --git a/pcl/defs.lisp b/pcl/defs.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..6dedbeafd69a907c8356fb5ac368713644f74fcf
--- /dev/null
+++ b/pcl/defs.lisp
@@ -0,0 +1,689 @@
+;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+
+(in-package 'pcl)
+
+(eval-when (compile load eval)
+  
+(defvar *defclass-times*   '(load eval))	;Probably have to change this
+						;if you use defconstructor.
+(defvar *defmethod-times*  '(load eval))
+(defvar *defgeneric-times* '(load eval))
+
+)
+
+
+;;;
+;;; 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 PCL
+;;; 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-pcl-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)))
+    
+      #+Genera
+      (let ((fn #'(lambda (form)
+		    (lt::help-defsetf
+		      '(&rest accessor-args) '(new-value) function-name 'nil
+		      `(`(,',setf-function-name ,new-value .,accessor-args))
+		      form))))
+	(setf (get function-name 'lt::setf-method) fn
+	      (get function-name 'lt::setf-method-internal) fn))
+
+      #+Lucid
+      (lucid::set-simple-setf-method 
+	function-name
+	#'(lambda (form new-value)
+	    (let* ((bindings (mapcar #'(lambda (x) `(,(gensym) ,x))
+				     (cdr form)))
+		   (vars (mapcar #'car bindings)))
+	      ;; This may wrap spurious LET bindings around some form,
+	      ;;   but the PQC compiler will unwrap then.
+	      `(LET (,.bindings)
+		 (,setf-function-name ,new-value . ,vars)))))
+      
+      #+kcl
+      (let ((helper (gensym)))
+	(setf (macro-function helper)
+	      #'(lambda (form env)
+		  (declare (ignore env))
+		  (let* ((loc-args (butlast (cdr form)))
+			 (bindings (mapcar #'(lambda (x) `(,(gensym) ,x)) loc-args))
+			 (vars (mapcar #'car bindings)))
+		    `(let ,bindings
+		       (,setf-function-name ,(car (last form)) ,@vars)))))
+	(eval `(defsetf ,function-name ,helper)))
+      #+Xerox
+      (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)))
+      
+      #-(or Genera Lucid kcl Xerox)
+      (eval `(defsetf ,function-name (&rest accessor-args) (new-value)
+	       `(,',setf-function-name ,new-value ,@accessor-args)))
+      
+      )))
+
+(defun setfboundp (symbol)
+  #+Genera nil
+  #+Lucid  (locally
+	     (declare (special lucid::*setf-inverse-table*
+			       lucid::*simple-setf-method-table*
+			       lucid::*setf-method-expander-table*))
+	     (or (gethash symbol lucid::*setf-inverse-table*)
+		 (gethash symbol lucid::*simple-setf-method-table*)
+		 (gethash symbol lucid::*setf-method-expander-table*)))
+  #+kcl    (or (get symbol 'si::setf-method)
+	       (get symbol 'si::setf-update-fn)
+	       (get symbol 'si::setf-lambda))
+  #+Xerox  (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))
+
+  #+:coral (or (get symbol 'ccl::setf-inverse)
+	       (get symbol 'ccl::setf-method-expander))
+  
+  #-(or Genera Lucid KCL Xerox :coral) nil)
+
+);eval-when
+
+
+;;;
+;;; PCL, 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))
+  (declare (indentation 1 1))
+  (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)
+  #+Lispm (si:fdefinition (si:unencapsulate-function-spec symbol))
+  #+Lucid (lucid::get-unadvised-procedure (symbol-function symbol))
+  #+excl  (or (excl::encapsulated-basic-definition symbol)
+	      (symbol-function symbol))
+  #+xerox (il:virginfn symbol)
+  
+  #-(or Lispm Lucid excl Xerox) (symbol-function 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)
+  #+Lispm (si:fdefine symbol new-definition t t)
+  #+Lucid (let ((lucid::*redefinition-action* nil))
+	    (setf (symbol-function symbol) new-definition))
+  #+excl  (setf (symbol-function symbol) new-definition)
+  #+xerox (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)))
+
+  #-(or Lispm Lucid excl Xerox)
+  (setf (symbol-function symbol) new-definition)
+  
+  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\ PCL\ 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 #+:Genera
+	(setf (get name 'deftype) expand-fn)
+	#+(and :Lucid (not :Prime))
+	(system::define-macro `(deftype ,name) expand-fn nil)
+	#+ExCL
+	(setf (get name 'excl::deftype-expander) expand-fn)
+	#+:coral
+	(setf (get name 'ccl::deftype-expander) expand-fn)
+
+	;; 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 () '(satisfies ,predicate))))))
+
+(defun make-type-predicate-name (name)
+  (intern (format nil
+		  "TYPE-PREDICATE ~A ~A"
+		  (package-name (symbol-package name))
+		  (symbol-name name))
+	  *the-pcl-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*))
+
+(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* ())
+(defvar *built-in-wrapper-symbols* ())
+
+(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-pcl-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-pcl-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
+						;EARLY
+						;BRAID
+						;COMPLETE
+
+(eval-when (load eval)
+  (when (eq *boot-state* 'complete)
+    (error "Trying to load (or compile) PCL 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 PCL."))
+  (when *boot-state*
+    (cerror "Try loading (or compiling) PCL anyways."
+	    "Trying to load (or compile) PCL 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 PCL."))
+  )
+
+;;;
+;;; 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* ())
+(defvar *invalid-dfuns-on-stack* ())
+
+
+(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)   ()                       (number t))
+    (float      (number)   ()                       (number t))
+    (rational   (number)   (integer ratio)          (number t))
+    (integer    (rational) ()                       (rational number t))
+    (ratio      (rational) ()                       (rational number t))
+
+    (sequence   (t)        (list vector)            (t))
+    (list       (sequence) (cons null)              (sequence t))
+    (cons       (list)     ()                       (list sequence t))
+    
+
+    (array      (t)        (vector)                 (t))
+    (vector     (array
+		 sequence) (string bit-vector)      (array sequence t))
+    (string     (vector)   ()                       (vector array sequence t))
+    (bit-vector (vector)   ()                       (vector array sequence t))
+    (character  (t)        ()                       (t))
+   
+    (symbol     (t)        (null)                   (t))
+    (null       (symbol)   ()                       (symbol list sequence t))))
+
+
+;;;
+;;; The classes that define the kernel of the metabraid.
+;;;
+(defclass t () ()
+  (:metaclass built-in-class))
+
+(defclass standard-object (t) ())
+
+(defclass metaobject (standard-object) ())
+
+(defclass specializer (metaobject) ())
+
+(defclass definition-source-mixin (standard-object)
+     ((source
+	:initform (load-truename)
+	:reader definition-source
+	:initarg :definition-source)))
+
+(defclass plist-mixin (standard-object)
+     ((plist
+	:initform ())))
+
+(defclass documentation-mixin (plist-mixin)
+     ())
+
+(defclass dependent-update-mixin (plist-mixin)
+    ())
+
+;;;
+;;; 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 ()
+	:reader class-direct-superclasses)
+      (direct-subclasses
+	:initform ()
+	:reader class-direct-subclasses)
+      (direct-methods
+	:initform (cons nil nil))))
+
+;;;
+;;; The class PCL-CLASS is an implementation-specific common superclass of
+;;; all specified subclasses of the class CLASS.
+;;; 
+(defclass pcl-class (class)
+     ((class-precedence-list
+	:initform ())
+      (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 (pcl-class)
+     ((direct-slots
+	:initform ()
+	:accessor class-direct-slots)
+      (slots
+	:initform ()
+	: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)
+     ())
+
+(defclass funcallable-standard-class (std-class)
+     ())
+    
+(defclass forward-referenced-class (pcl-class) ())
+
+(defclass built-in-class (pcl-class) ())
+
+
+;;;
+;;; Slot definitions.
+;;;
+;;; Note that throughout PCL, "SLOT-DEFINITION" is abbreviated as "SLOTD".
+;;;
+(defclass slot-definition (metaobject) ())
+
+(defclass direct-slot-definition    (slot-definition) ())
+(defclass effective-slot-definition (slot-definition) ())
+
+(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)))
+
+(defclass standard-direct-slot-definition (standard-slot-definition
+					   direct-slot-definition)
+     ())					;Adding slots here may
+						;involve extra work to
+						;the code in braid.lisp
+
+(defclass standard-effective-slot-definition (standard-slot-definition
+					      effective-slot-definition)
+     ())					;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 ()
+	   (return-from legal-std-qualifiers-p "Is not a proper list.")))
+    (dolist-carefully (q x improper-list)
+      (let ((ok (legal-std-qualifier-p q)))
+	(unless (eq ok t)
+	  (return-from legal-std-qualifiers-p
+	    (format nil "Contains ~S which ~A" q ok)))))
+    t))
+
+(defun legal-std-qualifier-p (x)
+  (if (and x (atom x))
+      t
+      "is not a non-null atom"))
+
+(defun legal-std-slot-name-p (x)
+  (cond ((not (symbolp x)) "is not a symbol and so cannot be bound")
+	((keywordp x)      "is a keyword and so cannot be bound")
+	((memq x '(t nil)) "cannot be bound")
+	(t t)))
+
+(defun legal-std-specializers-p (x)
+  (flet ((improper-list ()
+	   (return-from legal-std-specializers-p "Is not a proper list.")))
+    (dolist-carefully (s x improper-list)
+      (let ((ok (legal-std-specializer-p s)))
+	(unless (eq ok t)
+	  (return-from legal-std-specializers-p
+	    (format nil "Contains ~S which ~A" s ok)))))
+    t))
+
+(defun legal-std-specializer-p (x)
+  (if (or (classp x)
+	  (eql-specializer-p x))
+      t
diff --git a/pcl/defsys.lisp b/pcl/defsys.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..7606fdd94bf8e816844c04dfbfb8ac5cfee4226c
--- /dev/null
+++ b/pcl/defsys.lisp
@@ -0,0 +1,752 @@
+;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+;;; Some support stuff for compiling and loading PCL.  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 PCL AT YOUR SITE             ***
+;;; ***                                                               ***
+;;;
+;;; To get PCL working at your site you should:
+;;; 
+;;;  - Get all the PCL source files from Xerox.  The complete list of source
+;;;    file names can be found in the defsystem for PCL which appears towards
+;;;    the end of this file.
+;;; 
+;;;  - Edit the variable *pcl-directory* below to specify the directory at
+;;;    your site where the pcl sources and binaries will be.  This variable
+;;;    can be found by searching from this point for the string "***" in
+;;;    this file.
+;;; 
+;;;  - Use the function (pcl::compile-pcl) to compile PCL for your site.
+;;; 
+;;;  - Once PCL has been compiled it can be loaded with (pcl::load-pcl).
+;;;    Note that PCL cannot be loaded on top of itself, nor can it be
+;;;    loaded into the same world it was compiled in.
+;;;
+
+(in-package "PCL" :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-pcl-package* (find-package :pcl))
+
+(defvar *pcl-system-date* "5/1/90  May Day PCL (REV 2)")
+
+
+;;;
+;;; 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)
+    (pushnew :genera *features*)
+    (ecase major
+      ((6)
+       (pushnew :genera-release-6 *features*))
+      ((7)
+       (pushnew :genera-release-7 *features*)
+       (ecase (etypecase minor
+		(integer minor)
+		(string (digit-char-p (char minor 0))))
+	 ((0 1) (pushnew :genera-release-7-1 *features*))
+	 ((2)   (pushnew :genera-release-7-2  *features*))
+	 ((3)   (pushnew :genera-release-7-3  *features*))
+	 ((4)   (pushnew :genera-release-7-4  *features*))
+	 ((5)   (pushnew :genera-release-7-5  *features*))))))
+
+  
+  (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 (push :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 PCL 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
+	  #+imach                Ivory
+          #+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
+          #+:CMU                 CMU
+          #+HP-HPLabs            HP-HPLabs
+          #+:gclisp              gclisp
+          #+pyramid              pyramid
+          #+:coral               coral))
+
+;;;
+;;; When you get a copy of PCL (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 pcl 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 PCL 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")
+             #+(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")
+	     #+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)))))
+	       (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
+		    #'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
+		    #'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)))
+
+    #+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 PCL DIRECTORY                        ***
+;;;
+;;; *pcl-directory* is a variable which specifies the directory pcl 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 *pcl-directory* is set to the directory that
+;;; this file is loaded from.  This makes it simple to keep multiple copies
+;;; of PCL in different places, just load defsys from the same directory as
+;;; the copy of PCL you want to use.
+;;;
+;;; Note that the value of *PCL-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))))
+
+(defvar *pcl-directory*
+	(or (load-truename t)
+	    (error "Because load-truename is not implemented in this port~%~
+                    of PCL, you must manually edit the definition of the~%~
+                    variable *pcl-directory* in the file defsys.lisp.")))
+
+
+(defsystem pcl	   
+	   *pcl-directory*
+  ;;
+  ;; file         load           compile      files which       port
+  ;;              environment    environment  force the of
+  ;;                                          recompilation
+  ;;                                          of this file
+  ;;                                          
+  (
+;  (rel-6-patches   t            t            ()                rel-6)
+;  (rel-7-1-patches t            t            ()                rel-7-1)
+   (rel-7-2-patches t            t            ()                rel-7-2)
+   (ti-patches      t            t            ()                ti)
+   (pyr-patches     t          t              ()                pyramid)
+   (xerox-patches   t            t            ()                xerox)
+   (kcl-patches     t            t            ()                kcl)
+   (ibcl-patches    t            t            ()                ibcl)
+   (gcl-patches     t            t            ()                gclisp)
+   
+   (pkg             t            t            ())
+   (walk            (pkg)        (pkg)        ())
+   (iterate         t            t            ())
+   (macros          t            t            ())
+   (low             (pkg macros) t            (macros))
+   
+   
+   (genera-low     (low)         (low)        (low)            Genera)
+   (lucid-low      (low)         (low)        (low)            Lucid)
+   (Xerox-low      (low)         (low)        (low)            Xerox)
+   (ti-low         (low)         (low)        (low)            TI)
+   (vaxl-low       (low)         (low)        (low)            vaxlisp)
+   (kcl-low        (low)         (low)        (low)            KCL)
+   (ibcl-low       (low)         (low)        (low)            IBCL)
+   (excl-low       (low)         (low)        (low)            excl)
+   (cmu-low        (low)         (low)        (low)            CMU)
+   (hp-low         (low)         (low)        (low)            HP-HPLabs)
+   (gold-low       (low)         (low)        (low)            gclisp) 
+   (pyr-low        (low)         (low)        (low)            pyramid) 
+   (coral-low      (low)         (low)        (low)            coral)
+   
+   (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))
+   (cpatch      t                                   t (low)    excl)	;***
+   (quadlap     t                                   t (low)    excl)	;***
+   (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))
+   ))
+
+(defun compile-pcl (&optional m)
+  (let (#+:coral(ccl::*warn-if-redefine-kernel* nil)
+	#+Lucid (lcl:*redefinition-action* nil)
+	#+excl  (excl::*redefinition-warnings* nil)
+	)
+    (cond ((null m)        (operate-on-system 'pcl :compile))
+	  ((eq m :print)   (operate-on-system 'pcl :compile () t))
+	  ((eq m :query)   (operate-on-system 'pcl :query-compile))
+	  ((eq m :confirm) (operate-on-system 'pcl :confirm-compile))
+	  ((eq m 't)       (operate-on-system 'pcl :recompile))        
+	  ((listp m)       (operate-on-system 'pcl :compile-from m))
+	  ((symbolp m)     (operate-on-system 'pcl :recompile-some `(,m))))))
+
+(defun load-pcl (&optional m)
+  (let (#+:coral(ccl::*warn-if-redefine-kernel* nil)
+	#+Lucid (lcl:*redefinition-action* nil)
+	#+excl  (excl::*redefinition-warnings* nil)
+	)
+    (cond ((null m)      (operate-on-system 'pcl :load))
+	  ((eq m :query) (operate-on-system 'pcl :query-load)))
+    (pushnew :pcl *features*)
+    (pushnew :portable-commonloops *features*)))
+
+(defun bug-report-info (&optional (stream *standard-output*))
+  (format stream "~&PCL system date: ~A~
+                  ~&Lisp Implementation type: ~A~
+                  ~&Lisp Implementation version: ~A~
+                  ~&*features*: ~S"
+	  *pcl-system-date*
+	  (lisp-implementation-type)
+	  (lisp-implementation-version)
+	  *features*))
+
+
+
+;;;;
+;;;
+;;; This stuff is not intended for external use.
+;;; 
+(defun rename-pcl ()
+  (dolist (f (cadr (get-system 'pcl)))
+    (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-pcl ()
+  (dolist (f (cadr (get-system 'pcl)))
+    (let ((*system-directory* *pcl-directory*))
+      (zwei:find-file (make-source-pathname (car f))))))
+
+#+Genera
+(defun hardcopy-pcl (&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 'pcl))))
+        (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-pcl (to)
+  (let* ((original-buffer zwei:*interval*)
+	 (*system-directory* (pathname "vaxc:/user/ftp/pub/pcl/")
+			    ;(funcall (car (get-system 'pcl)))
+			     )
+         (files (list* 'defsys
+			'test
+			(caddr (get-system 'pcl))))
+         (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
+				       "PCL 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))))
+
+
diff --git a/pcl/dfun.lisp b/pcl/dfun.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..aea813f65f9654b6d623ff1ad3c781e42b927d6c
--- /dev/null
+++ b/pcl/dfun.lisp
@@ -0,0 +1,705 @@
+;;; -*- Mode:LISP; Package:PCL; Base:10; Syntax:Common-Lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+
+(in-package 'pcl)
+
+#|
+
+This implementation of method lookup was redone in early August of 89.
+
+It has the following properties:
+
+ - It's modularity makes it easy to modify the actual caching algorithm.
+   The caching algorithm is almost completely separated into the files
+   cache.lisp and dlap.lisp.  This file just contains the various uses
+   of it. There will be more tuning as we get more results from Luis'
+   measurements of caching behavior.
+
+ - The metacircularity issues have been dealt with properly.  All of
+   PCL now grounds out properly.  Moreover, it is now possible to have
+   metaobject classes which are themselves not instances of standard
+   metaobject classes.
+
+** Modularity of the code **
+
+The actual caching algorithm is isolated in a modest number of functions.
+The code which generates cache lookup code is all found in cache.lisp and
+dlap.lisp.  Certain non-wrapper-caching special cases are in this file.
+
+
+** Handling the metacircularity **
+
+In CLOS, method lookup is the potential source of infinite metacircular
+regress.  The metaobject protocol specification gives us wide flexibility
+in how to address this problem.  PCL uses a technique which handles the
+problem not only for the metacircular language described in Chapter 3, but
+also for the PCL protocol which includes additional generic functions
+which control more aspects of the CLOS implementation.
+
+The source of the metacircular regress can be seen in a number of ways.
+One is that the specified method lookup protocol must, as part of doing
+the method lookup (or at least the cache miss case), itself call generic
+functions.  It is easy to see that if the method lookup for a generic
+function ends up calling that same generic function there can be trouble.
+
+Fortunately, there is an easy solution at hand.  The solution is based on 
+the restriction that portable code cannot change the class of a specified
+metaobject.  This restriction implies that for specified generic functions,
+the method lookup protocol they follow is fixed.  
+
+More precisely, for such specified generic functions, most generic functions
+that are called during their own method lookup will not run portable methods. 
+This allows the implementation to usurp the actual generic function call in
+this case.  In short, method lookup of a standard generic function, in the
+case where the only applicable methods are themselves standard doesn't
+have to do any method lookup to implement itself.
+
+And so, we are saved.
+
+|#
+
+
+;************************************************************************
+;   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* ())			;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 ()
+  (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)
+  #+excl ()
+  #-excl
+  (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 (pcl-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 (pcl-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 (pcl-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 (pcl-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 (pcl-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 (pcl-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 (pcl-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 (pcl-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 (pcl-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 (pcl-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)
+	       (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 ()
+		   (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)
+                   (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)
+	       (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)
+	       (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))
+  (let* ((invalidp nil)
+	 (wrappers ())
+	 (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))))))))
+      (multiple-value-bind (function appl)
+	  (get-secondary-dispatch-function generic-function args)
+	(values wrappers invalidp function appl)))))
+
+(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)
+	       (cond ((standard-reader-method-p (car applicable)) 'reader)
+		     ((standard-writer-method-p (car applicable)) '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))))))))
diff --git a/pcl/dlap.lisp b/pcl/dlap.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..9bf71da4c4fe2294e4e3d1e4bedffb2ba9fc0916
--- /dev/null
+++ b/pcl/dlap.lisp
@@ -0,0 +1,477 @@
+;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+
+(in-package 'pcl)
+
+
+
+(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  ())
+	(closure-variables ())
+	(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 ()
+  (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 ()
+  (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 ((function 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 ((function 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 emit-dlap (args metatypes miss-label hit miss value-reg &optional slot-regs)
+  (let* ((wrappers
+	   (mapcar #'(lambda (x) (and (neq x 't) (allocate-register 'vector))) metatypes))
+	 (wrapper-moves
+	   (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))))))))
+    (prog1 (emit-dlap-internal (remove nil wrappers)
+			       wrapper-moves
+			       hit
+			       miss
+			       miss-label
+			       value-reg)
+	   (mapcar #'(lambda (x) (deallocate-register x)) (remove nil wrappers)))))
+
+(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)))
+     
+
+
diff --git a/pcl/env.lisp b/pcl/env.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..8538ff9e7712523ab606814a5ed4c51ca24ba297
--- /dev/null
+++ b/pcl/env.lisp
@@ -0,0 +1,301 @@
+;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+;;; Basic environmental stuff.
+;;;
+
+(in-package 'pcl)
+
+#+Genera
+(progn
+
+(defvar *old-arglist*)
+
+(defun pcl-arglist (function &rest other-args)
+  (let ((defn nil))
+    (cond ((and (fsc-instance-p function)
+		(generic-function-p function))
+	   (generic-function-pretty-arglist function))
+	  ((and (sys:validate-function-spec function)
+		(sys:fdefinedp function)
+		(setq defn (sys:fdefinition function))
+		(fsc-instance-p defn)
+		(generic-function-p defn))
+	   (generic-function-pretty-arglist defn))
+	  (t (apply *old-arglist* function other-args)))))
+
+(eval-when (eval load)
+  (unless (boundp '*old-arglist*)
+    (setq *old-arglist* (symbol-function 'zl:arglist))
+    (setf (symbol-function 'zl:arglist) #'pcl-arglist)))
+
+
+(defvar *old-function-name*)
+
+(defun pcl-function-name (function &rest other-args)
+  (if (and (fsc-instance-p function)
+	   (generic-function-p function))
+      (generic-function-name function)
+      (apply *old-function-name* function other-args)))
+
+(eval-when (eval load)
+  (unless (boundp '*old-function-name*)
+    (setq *old-function-name* (symbol-function 'si:function-name))
+    (setf (symbol-function 'si:function-name) #'pcl-function-name)))
+
+)
+
+#+Lucid
+(progn
+
+(defvar *old-arglist*)
+
+(defun pcl-arglist (function &rest other-args)
+  (let ((defn nil))
+    (cond ((and (fsc-instance-p function)
+		(generic-function-p function))
+	   (generic-function-pretty-arglist function))
+	  ((and (symbolp function)
+		(fboundp function)
+		(setq defn (symbol-function function))
+		(fsc-instance-p defn)
+		(generic-function-p defn))
+	   (generic-function-pretty-arglist defn))
+	  (t (apply *old-arglist* function other-args)))))
+
+(eval-when (eval load)
+  (unless (boundp '*old-arglist*)
+    (setq *old-arglist* (symbol-function 'sys::arglist))
+    (setf (symbol-function 'sys::arglist) #'pcl-arglist)))
+
+)
+
+
+;;;
+;;;
+;;;
+
+(defgeneric describe-object (object stream))
+
+(defvar *old-describe* ())
+
+(eval-when (load)
+  (unless *old-describe* (setq *old-describe* (symbol-function 'describe)))
+  (setf (symbol-function 'describe)
+	#+Lispm
+	#'(lambda (object &optional no-complaints)
+	    (let ((*describe-no-complaints* no-complaints))
+	      (declare (special *describe-no-complaints*))
+	      (describe-object object *standard-output*)
+	      (values)))
+	#-Lispm
+	#'(lambda (object)
+	    (describe-object object *standard-output*)
+	    (values))))
+
+(defmethod describe-object (object stream)
+  (let ((*standard-output* stream))
+    (funcall *old-describe* object)))
+
+(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)))
+
diff --git a/pcl/excl-low.lisp b/pcl/excl-low.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..a84f571efa7977cb726e8d766250c300c2114e79
--- /dev/null
+++ b/pcl/excl-low.lisp
@@ -0,0 +1,144 @@
+;;; -*- Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;; 
+;;; This is the EXCL (Franz) lisp version of the file portable-low.
+;;; 
+;;; This is for version 1.1.2.  Many of the special symbols now in the lisp
+;;; package (e.g. lisp::pointer-to-fixnum) will be in some other package in
+;;; a later release so this will need to be changed.
+;;; 
+
+(in-package 'pcl)
+
+(defmacro without-interrupts (&body body)
+  `(let ((outer-interrupts excl::*without-interrupts*)
+	 (excl::*without-interrupts* 0))
+     (macrolet ((interrupts-on  ()
+		  '(unless outer-interrupts
+		     (setq excl::*without-interrupts* nil)))
+		(interrupts-off ()
+		  '(setq excl::*without-interrupts* 0)))
+       ,.body)))
+
+(eval-when (compile load eval)
+  (unless (fboundp 'excl::sy_hash)
+    (setf (symbol-function 'excl::sy_hash)
+	  (symbol-function 'excl::_sy_hash-value)))
+  )
+
+(defmacro memq (item list)
+  (let ((list-var (gensym))
+	(item-var (gensym)))
+    `(prog ((,list-var ,list)
+	    (,item-var ,item))
+	start
+	   (cond ((null ,list-var)
+		  (return nil))
+		 ((eq (car ,list-var) ,item-var)
+		  (return ,list-var))
+		 (t
+		  (pop ,list-var)
+		  (go start))))))
+
+(defun std-instance-p (x)
+  (and (excl::structurep x)
+       (locally
+	 (declare (optimize (speed 3) (safety 0)))
+	 (eq (svref x 0) 'std-instance))))
+
+(excl::defcmacro std-instance-p (x)
+  (once-only (x)
+    `(and (excl::structurep ,x)
+	  (locally
+	    (declare (optimize (speed 3) (safety 0)))
+	    (eq (svref ,x 0) 'std-instance)))))
+
+(defmacro %std-instance-wrapper (x)
+  `(svref ,x 1))
+
+(defmacro %std-instance-slots (x)
+  `(svref ,x 2))
+
+(defun printing-random-thing-internal (thing stream)
+  (format stream "~O" (excl::pointer-to-fixnum thing)))
+
+#-vax
+(defun set-function-name-1 (fn new-name ignore)
+  (declare (ignore ignore))
+  (cond ((excl::function-object-p fn)
+	 (setf (excl::fn_symdef fn) new-name))
+	(t nil))
+  fn)
+
+(defun function-arglist (f)
+  (excl::arglist f))
+
+(defun symbol-append (sym1 sym2 &optional (package *package*))
+   ;; This is a version of symbol-append from macros.cl
+   ;; It insures that all created symbols are of one case and that
+   ;; case is the current prefered case.
+   ;; This special version of symbol-append is not necessary if all you
+   ;; want to do is compile and run pcl in a case-insensitive-upper 
+   ;; version of cl.  
+   ;;
+   (let ((string (string-append sym1 sym2)))
+      (case excl::*current-case-mode*
+	 ((:case-insensitive-lower :case-sensitive-lower)
+	  (setq string (string-downcase string)))
+	 ((:case-insensitive-upper :case-sensitive-upper)
+	  (setq string (string-upcase string))))
+      (intern string package)))
+
+;;; Define inspector hooks for PCL object instances.
+
+;;; Due to metacircularity certain slots of metaclasses do not have normal
+;;; accessors, and for now we just make them uninspectable.  They could be
+;;; special cased some day.
+
+(defun (:property pcl::std-instance :inspector-function) (object)
+  (do* ((class (class-of object))
+	(components (class-precedence-list class))
+	(desc (list (inspect::make-field-def "class" #'class-of :lisp)))
+	(slots (slots-to-inspect class object) (cdr slots)))
+       ((null slots) (nreverse desc))
+    (let ((name (slotd-name (car slots)))
+	  res)
+      (push (inspect::make-field-def
+	     (string name)
+	     (or (block foo
+		   (dolist (comp components)
+		     (dolist (slot (class-direct-slots comp))
+		       (and (eq (slotd-name slot) name)
+			    (setq res (first (slotd-readers slot)))
+			    (return-from foo res)))))
+		 #'(lambda (x) 
+		     (declare (ignore x))
+		     :|Uninspectable Metaclass Slot|))
+	     :lisp)
+	    desc))))
+
+(defun (:property pcl::std-instance :inspector-type-function) (x)
+  (class-name (class-of x)))
diff --git a/pcl/fin.lisp b/pcl/fin.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..46995d65c4fb35a3c812b06e2a15e2daa37cd26e
--- /dev/null
+++ b/pcl/fin.lisp
@@ -0,0 +1,1479 @@
+;;;-*-Mode:LISP; Package:(PCL Lisp 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+
+  ;;   
+;;;;;; FUNCALLABLE INSTANCES
+  ;;
+
+#|
+
+Generic functions are instances with meta class funcallable-standard-class.
+Instances with this meta class are called funcallable-instances (FINs for
+short).  They behave something like lexical closures in that they have data
+associated with them (which is used to store the slots) and are funcallable.
+When a funcallable instance is funcalled, the function that is invoked is
+called the funcallable-instance-function.  The funcallable-instance-function
+of a funcallable instance can be changed.
+
+This file implements low level code for manipulating funcallable instances.
+
+It is possible to implement funcallable instances in pure Common Lisp.  A
+simple implementation which uses lexical closures as the instances and a
+hash table to record that the lexical closures are funcallable instances
+is easy to write.  Unfortunately, this implementation adds significant
+overhead:
+
+   to generic-function-invocation (1 function call)
+   to slot-access (1 function call or one hash table lookup)
+   to class-of a generic-function (1 hash-table lookup)
+
+In addition, it would prevent the funcallable instances from being garbage
+collected.  In short, the pure Common Lisp implementation really isn't
+practical.
+
+Instead, PCL uses a specially tailored implementation for each Common Lisp and
+makes no attempt to provide a purely portable implementation.  The specially
+tailored implementations are based on the lexical closure's provided by that
+implementation and are fairly short and easy to write.
+
+Some of the implementation dependent code in this file was originally written
+by someone in the employ of the vendor of that Common Lisp.  That code is
+explicitly marked saying who wrote it.
+
+|#
+
+(in-package 'pcl)
+
+;;;
+;;; The first part of the file contains the implementation dependent code to
+;;; implement funcallable instances.  Each implementation must provide the
+;;; following functions and macros:
+;;; 
+;;;    ALLOCATE-FUNCALLABLE-INSTANCE-1 ()
+;;;       should create and return a new funcallable instance.  The
+;;;       funcallable-instance-data slots must be initialized to NIL.
+;;;       This is called by allocate-funcallable-instance and by the
+;;;       bootstrapping code.
+;;;
+;;;    FUNCALLABLE-INSTANCE-P (x)
+;;;       the obvious predicate.  This should be an INLINE function.
+;;;       it must be funcallable, but it would be nice if it compiled
+;;;       open.
+;;;
+;;;    SET-FUNCALLABLE-INSTANCE-FUNCTION (fin new-value)
+;;;       change the fin so that when it is funcalled, the new-value
+;;;       function is called.  Note that it is legal for new-value
+;;;       to be copied before it is installed in the fin, specifically
+;;;       there is no accessor for a FIN's function so this function
+;;;       does not have to preserve the actual new value.  The new-value
+;;;       argument can be any funcallable thing, a closure, lambda
+;;;       compiled code etc.  This function must coerce those values
+;;;       if necessary.
+;;;       NOTE: new-value is almost always a compiled closure.  This
+;;;             is the important case to optimize.
+;;;
+;;;    FUNCALLABLE-INSTANCE-DATA-1 (fin data-name)
+;;;       should return the value of the data named data-name in the fin.
+;;;       data-name is one of the symbols in the list which is the value
+;;;       of funcallable-instance-data.  Since data-name is almost always
+;;;       a quoted symbol and funcallable-instance-data is a constant, it
+;;;       is possible (and worthwhile) to optimize the computation of
+;;;       data-name's offset in the data part of the fin.
+;;;       This must be SETF'able.
+;;;       
+
+(defconstant funcallable-instance-data
+             '(wrapper 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 ()
+  (error "Attempt to funcall a funcallable-instance without first~%~
+          setting its funcallable-instance-function."))
+
+
+
+
+;;;
+;;; In Lucid Lisp, compiled functions and compiled closures have the same
+;;; representation.  They are called procedures.  A procedure is a basically
+;;; just a constants vector, with one slot which points to the CODE.  This
+;;; means that constants and closure variables are intermixed in the procedure
+;;; vector.
+;;;
+;;; This code was largely written by JonL@Lucid.com.  Problems with it should
+;;; be referred to him.
+;;; 
+#+Lucid
+(progn
+
+(defconstant procedure-is-funcallable-instance-bit-position 10)
+
+(defconstant fin-trampoline-fun-index lucid::procedure-literals)
+
+(defconstant fin-size (+ fin-trampoline-fun-index
+			 (length funcallable-instance-data)
+			 1))
+
+;;;
+;;; The inner closure of this function will have its code vector replaced
+;;;  by a hand-coded fast jump to the function that is stored in the 
+;;;  captured-lexical variable.  In effect, that code is a hand-
+;;;  optimized version of the code for this inner closure function.
+;;;
+(defun make-trampoline (function)
+  (declare (optimize (speed 3) (safety 0)))
+  #'(lambda (&rest args)
+      (apply function args)))
+
+(eval-when (eval) 
+  (compile 'make-trampoline)
+  )
+
+
+(defun binary-assemble (codes)
+  (let* ((ncodes (length codes))
+	 (code-vec #-LCL3.0 (lucid::new-code ncodes)
+		   #+LCL3.0 (lucid::with-current-area 
+				lucid::*READONLY-NON-POINTER-AREA*
+			      (lucid::new-code ncodes))))
+    (declare (fixnum ncodes))
+    (do ((l codes (cdr l))
+	 (i 0 (1+ i)))
+	((null l) nil)
+      (declare (fixnum i))
+      (setf (lucid::code-ref code-vec i) (car l)))
+    code-vec))
+
+;;;
+;;; Egad! Binary patching!
+;;; See comment following definition of MAKE-TRAMPOLINE -- this is just
+;;;  the "hand-optimized" machine instructions to make it work.
+;;;
+(defvar *mattress-pad-code* 
+	(binary-assemble
+		#+MC68000
+		'(#x2A6D #x11 #x246D #x1 #x4EEA #x5)
+		#+SPARC
+		(ecase (lucid::procedure-length #'lucid::false)
+		  (5
+		   '(#xFA07 #x6012 #xDE07 #x7FFE #x81C3 #xFFFE #x100 #x0))
+		  (8
+		   `(#xFA07 #x601E #xDE07 #x7FFE #x81C3 #xFFFE #x100 #x0)))
+		#+(and BSP (not LCL3.0 ))
+		'(#xCD33 #x11 #xCDA3 #x1 #xC19A #x5 #xE889)
+		#+(and BSP LCL3.0)
+		'(#x7733 #x7153 #xC155 #x5 #xE885)
+		#+I386
+		'(#x87 #xD2 #x8B #x76 #xE #xFF #x66 #xFE)
+		#+VAX
+		'(#xD0 #xAC #x11 #x5C #xD0 #xAC #x1 #x57 #x17 #xA7 #x5)
+		#+PA
+		'(#x4891 #x3C #xE461 #x6530 #x48BF #x3FF9)
+		#-(or MC68000 SPARC BSP I386 VAX PA)
+		'(0 0 0 0)))
+
+
+(lucid::defsubst funcallable-instance-p (x)
+  (and (lucid::procedurep x)
+       (lucid::logbitp& procedure-is-funcallable-instance-bit-position
+                        (lucid::procedure-ref x lucid::procedure-flags))))
+
+(lucid::defsubst set-funcallable-instance-p (x)
+  (if (not (lucid::procedurep x))
+      (error "Can't make a non-procedure a fin.")
+      (setf (lucid::procedure-ref x lucid::procedure-flags)
+	    (logior (expt 2 procedure-is-funcallable-instance-bit-position)
+		    (the fixnum
+			 (lucid::procedure-ref x lucid::procedure-flags))))))
+
+
+(defun allocate-funcallable-instance-1 ()
+  #+Prime
+  (declare (notinline lucid::new-procedure))    ;fixes a bug in Prime 1.0 in
+                                                ;which new-procedure expands
+                                                ;incorrectly
+  (let ((new-fin (lucid::new-procedure fin-size))
+	(fin-index fin-size))
+    (declare (fixnum fin-index)
+	     (type lucid::procedure new-fin))
+    (dotimes (i (length funcallable-instance-data)) 
+      ;; Initialize the new funcallable-instance.  As part of our contract,
+      ;; we have to make sure the initial value of all the funcallable
+      ;; instance data slots is NIL.
+      (decf fin-index)
+      (setf (lucid::procedure-ref new-fin fin-index) nil))
+    ;;
+    ;; "Assemble" the initial function by installing a fast "trampoline" code;
+    ;; 
+    (setf (lucid::procedure-ref new-fin lucid::procedure-code)
+	  *mattress-pad-code*)
+    ;; Disable argcount checking in the "mattress-pad" code for
+    ;;  ports that go through standardized trampolines
+    #+PA (setf (sys:procedure-ref new-fin lucid::procedure-arg-count) -1)
+    #+MIPS (progn
+	     (setf (sys:procedure-ref new-fin lucid::procedure-min-args) 0)
+	     (setf (sys:procedure-ref new-fin lucid::procedure-max-args) 
+		   call-arguments-limit))
+    ;; but start out with the function to be run as an error call.
+    (setf (lucid::procedure-ref new-fin fin-trampoline-fun-index)
+	  #'called-fin-without-function)
+    ;; Then mark it as a "fin"
+    (set-funcallable-instance-p new-fin)
+    new-fin))
+
+(defun set-funcallable-instance-function (fin new-value)
+  (unless (funcallable-instance-p fin)
+    (error "~S is not a funcallable-instance" fin))
+  (if (lucid::procedurep new-value)
+      (progn
+	(setf (lucid::procedure-ref fin fin-trampoline-fun-index) new-value)
+	fin)
+      (progn 
+	(unless (functionp new-value)
+	  (error "~S is not a function." new-value))
+	;; 'new-value' is an interpreted function.  Install a
+	;; trampoline to call the interpreted function.
+	(set-funcallable-instance-function fin
+					   (make-trampoline new-value)))))
+
+(defmacro funcallable-instance-data-1 (instance data)
+  `(lucid::procedure-ref 
+	   ,instance
+	   (the fixnum
+		(- (- fin-size 1)
+		   (the fixnum (funcallable-instance-data-position ,data))))))
+  
+);end of #+Lucid
+
+
+;;;
+;;; In Symbolics Common Lisp, a lexical closure is a pair of an environment
+;;; and an ordinary compiled function.  The environment is represented as
+;;; a CDR-coded list.  I know of no way to add a special bit to say that the
+;;; closure is a FIN, so for now, closures are marked as FINS by storing a
+;;; special marker in the last cell of the environment.
+;;; 
+;;;  The new structure of a fin is:
+;;;     (lex-env lex-fun *marker* fin-data0 fin-data1)
+;;;  The value returned by allocate is a lexical-closure pointing to the start
+;;;  of the fin list.  Benefits are: no longer ever have to copy environments,
+;;;  fins can be much smaller (5 words instead of 18), old environments never
+;;;  get destroyed (so running dcodes dont have the lex env change from under
+;;;  them any longer).
+;;;
+;;;  Most of the fin operations speed up a little (by as much as 30% on a
+;;;  3650), at least one nasty bug is fixed, and so far at least I've not
+;;;  seen any problems at all with this code.   - mike thome (mthome@bbn.com)
+;;;      
+#+Genera
+(progn
+
+(defvar *funcallable-instance-marker* (list "Funcallable Instance Marker"))
+
+(defun allocate-funcallable-instance-1 ()
+  (let* ((whole-fin (make-list (+ 3 (length funcallable-instance-data))))
+	 (new-fin (sys:%make-pointer-offset sys:dtp-lexical-closure
+					    whole-fin
+					    0)))
+    ;;
+    ;; note that we DO NOT turn the real lex-closure part of the fin into
+    ;; a dotted pair, because (1) the machine doesn't care and (2) if we
+    ;; did the garbage collector would reclaim everything after the lexical
+    ;; function.
+    ;; 
+    (setf (sys:%p-contents-offset new-fin 2) *funcallable-instance-marker*)
+    (setf (si:lexical-closure-function new-fin)
+	  #'(lambda (ignore &rest ignore-them-too)
+	      (declare (ignore ignore ignore-them-too))
+	      (called-fin-without-function)))
+    #+ignore
+    (setf (si:lexical-closure-environment new-fin) nil)
+    new-fin))
+
+(scl:defsubst funcallable-instance-p (x)
+  (declare (inline si:lexical-closure-p))
+  (and (si:lexical-closure-p x)
+       (= (sys:%p-cdr-code (sys:%make-pointer-offset sys:dtp-compiled-function x 1))
+	  sys:cdr-next)
+       (eq (sys:%p-contents-offset x 2) *funcallable-instance-marker*)))
+
+(defun set-funcallable-instance-function (fin new-value)
+  (cond ((not (funcallable-instance-p fin))
+         (error "~S is not a funcallable-instance" fin))
+        ((not (or (functionp new-value)
+		  (and (consp new-value)
+		       (eq (car new-value) 'si:digested-lambda))))
+         (error "~S is not a function." new-value))
+        ((and (si:lexical-closure-p new-value)
+	      (compiled-function-p (si:lexical-closure-function new-value)))
+	 (let ((env (si:lexical-closure-environment new-value))
+	       (fn  (si:lexical-closure-function new-value)))
+	   ;; we only have to copy the pointers!!
+	   (setf (si:lexical-closure-environment fin) env
+		 (si:lexical-closure-function fin)    fn)
+;	   (dbg:set-env->fin env fin)
+	   ))
+        (t
+         (set-funcallable-instance-function fin
+                                            (make-trampoline new-value)))))
+
+(defun make-trampoline (function)
+  #'(lambda (&rest args)
+      (apply function args)))
+
+(defmacro funcallable-instance-data-1 (fin data)
+  `(sys:%p-contents-offset ,fin
+			   (+ 3 (funcallable-instance-data-position ,data))))
+
+(defsetf funcallable-instance-data-1 (fin data) (new-value)
+  `(setf (sys:%p-contents-offset ,fin
+				 (+ 3 (funcallable-instance-data-position ,data)))
+	 ,new-value))
+
+;;;
+;;; Make funcallable instances print out properly.
+;;; 
+(defvar *old-print-lexical-closure*)
+
+(defvar *print-lexical-closure* nil)
+
+(defun pcl-print-lexical-closure (exp stream slashify-p &optional (depth 0))
+  (declare (ignore depth))
+  (if (or (eq *print-lexical-closure* exp)
+	  (neq *boot-state* 'complete)
+	  (eq (class-of exp) *the-class-t*))
+      (let ((*print-lexical-closure* nil))
+	(funcall *old-print-lexical-closure* exp stream slashify-p))
+      (let ((*print-escape* slashify-p)
+	    (*print-lexical-closure* exp))
+	(print-object exp stream))))
+
+(eval-when (load eval)
+  (unless (boundp '*old-print-lexical-closure*)
+    (setq *old-print-lexical-closure* #'si:print-lexical-closure)
+    (setf (symbol-function 'si:print-lexical-closure)
+	  'pcl-print-lexical-closure)))
+
+
+);end of #+Genera
+
+
+
+;;;
+;;;
+;;; In Xerox Common Lisp, a lexical closure is a pair of an environment and
+;;; CCODEP.  The environment is represented as a block.  There is space in
+;;; the top 8 bits of the pointers to the CCODE and the environment to use
+;;; to mark the closure as being a FIN.
+;;;
+;;; To help the debugger figure out when it has found a FIN on the stack, we
+;;; reserve the last element of the closure environment to use to point back
+;;; to the actual fin.
+;;;
+;;; Note that there is code in xerox-low which lets us access the fields of
+;;; compiled-closures and which defines the closure-overlay record.  That
+;;; code is there because there are some clients of it in that file.
+;;;      
+#+Xerox
+(progn
+
+;; Don't be fooled.  We actually allocate one bigger than this to have a place
+;; to store the backpointer to the fin.  -smL
+(defconstant funcallable-instance-closure-size 15)
+
+;; This is only used in the file PCL-ENV.
+(defvar *fin-env-type*
+  (type-of (il:\\allocblock (1+ funcallable-instance-closure-size) t)))
+
+;; Well, Gregor may be too proud to hack xpointers, but bvm and I aren't. -smL
+
+(defstruct fin-env-pointer
+  (pointer nil :type il:fullxpointer))
+
+(defun fin-env-fin (fin-env)
+  (fin-env-pointer-pointer
+   (il:\\getbaseptr fin-env (* funcallable-instance-closure-size 2))))
+
+(defun |set fin-env-fin| (fin-env new-value)
+  (il:\\rplptr fin-env (* funcallable-instance-closure-size 2)
+	       (make-fin-env-pointer :pointer new-value))
+  new-value)
+
+(defsetf fin-env-fin |set fin-env-fin|)
+
+;; The finalization function that will clean up the backpointer from the
+;; fin-env to the fin.  This needs to be careful to not cons at all.  This
+;; depends on there being no other finalization function on compiled-closures,
+;; since there is only one finalization function per datatype.  Too bad.  -smL
+(defun finalize-fin (fin)
+  ;; This could use the fn funcallable-instance-p, but if we get here we know
+  ;; that this is a closure, so we can skip that test.
+  (when (il:fetch (closure-overlay funcallable-instance-p) il:of fin)
+    (let ((env (il:fetch (il:compiled-closure il:environment) il:of fin)))
+      (when env
+	(setq env
+	      (il:\\getbaseptr env (* funcallable-instance-closure-size 2)))
+	(when (il:typep env 'fin-env-pointer) 
+	  (setf (fin-env-pointer-pointer env) nil)))))
+  nil)					;Return NIL so GC can proceed
+
+(eval-when (load)
+  ;; Install the above finalization function.
+  (when (fboundp 'finalize-fin)
+    (il:\\set.finalization.function 'il:compiled-closure 'finalize-fin)))
+
+(defun allocate-funcallable-instance-1 ()
+  (let* ((env (il:\\allocblock (1+ funcallable-instance-closure-size) t))
+         (fin (il:make-compiled-closure nil env)))
+    (setf (fin-env-fin env) fin)
+    (il:replace (closure-overlay funcallable-instance-p) il:of fin il:with 't)
+    (set-funcallable-instance-function fin
+      #'(lambda (&rest ignore)
+          (declare (ignore ignore))
+	  (called-fin-without-function)))
+    fin))
+
+(xcl:definline funcallable-instance-p (x)
+  (and (typep x 'il:compiled-closure)
+       (il:fetch (closure-overlay funcallable-instance-p) il:of x)))
+
+(defun set-funcallable-instance-function (fin new)
+  (cond ((not (funcallable-instance-p fin))
+         (error "~S is not a funcallable-instance" fin))
+        ((not (functionp new))
+         (error "~S is not a function." new))
+        ((typep new 'il:compiled-closure)
+         (let* ((fin-env
+                  (il:fetch (il:compiled-closure il:environment) il:of fin))
+                (new-env
+                  (il:fetch (il:compiled-closure il:environment) il:of new))
+                (new-env-size (if new-env (il:\\#blockdatacells new-env) 0))
+                (fin-env-size (- funcallable-instance-closure-size
+                                 (length funcallable-instance-data))))
+           (cond ((and new-env
+		       (<= new-env-size fin-env-size))
+		  (dotimes (i fin-env-size)
+		    (il:\\rplptr fin-env
+				 (* i 2)
+				 (if (< i new-env-size)
+				     (il:\\getbaseptr new-env (* i 2))
+				     nil)))
+		  (setf (compiled-closure-fnheader fin)
+			(compiled-closure-fnheader new)))
+                 (t
+                  (set-funcallable-instance-function
+                    fin
+                    (make-trampoline new))))))
+        (t
+         (set-funcallable-instance-function fin
+                                            (make-trampoline new)))))
+
+(defun make-trampoline (function)
+  #'(lambda (&rest args)
+      (apply function args)))
+
+        
+(defmacro funcallable-instance-data-1 (fin data)
+  `(il:\\getbaseptr (il:fetch (il:compiled-closure il:environment) il:of ,fin)
+		    (* (- funcallable-instance-closure-size
+			  (funcallable-instance-data-position ,data)
+			  1)			;Reserve last element to
+						;point back to actual FIN!
+		       2)))
+
+(defsetf funcallable-instance-data-1 (fin data) (new-value)
+  `(il:\\rplptr (il:fetch (il:compiled-closure il:environment) il:of ,fin)
+		(* (- funcallable-instance-closure-size
+		      (funcallable-instance-data-position ,data)
+		      1)
+		   2)
+		,new-value))
+
+);end of #+Xerox
+
+
+;;;
+;;; In Franz Common Lisp ExCL
+;;; This code was originally written by:
+;;;   jkf%franz.uucp@berkeley.edu
+;;; and hacked by:
+;;;   smh%franz.uucp@berkeley.edu
+
+#+ExCL
+(progn
+
+(defconstant funcallable-instance-flag-bit #x1)
+
+(defun funcallable-instance-p (x)
+   (and (excl::function-object-p x)
+        (eq funcallable-instance-flag-bit
+            (logand (excl::fn_flags x)
+                    funcallable-instance-flag-bit))))
+
+(defun make-trampoline (function)
+  #'(lambda (&rest args)
+      (apply function args)))
+
+;; We initialize a fin's procedure function to this because
+;; someone might try to funcall it before it has been set up.
+(defun init-fin-fun (&rest ignore)
+  (declare (ignore ignore))
+  (called-fin-without-function))
+
+
+(eval-when (eval) 
+  (compile 'make-trampoline)
+  (compile 'init-fin-fun))
+
+
+;; new style
+#+(and gsgc (not sun4) (not cray) (not mips))
+(progn
+;; set-funcallable-instance-function must work by overwriting the fin itself
+;; because the fin must maintain EQ identity.
+;; Because the gsgc time needs several of the fields in the function object
+;; at gc time in order to walk the stack frame, it is important never to bash
+;; a function object that is active in a frame on the stack.  Besides, changing
+;; the functions closure vector, not to mention overwriting its constant
+;; vector, would scramble it's execution when that stack frame continues.
+;; Therefore we represent a fin as a funny compiled-function object.
+;; The code vector of this object has some hand-coded instructions which
+;; do a very fast jump into the real fin handler function.  The function
+;; which is the fin object *never* creates a frame on the stack.
+  
+
+(defun allocate-funcallable-instance-1 ()
+  (let ((fin (compiler::.primcall 'sys::new-function))
+	(init #'init-fin-fun)
+	(mattress-fun #'funcallable-instance-mattress-pad))
+    (setf (excl::fn_symdef fin) 'anonymous-fin)
+    (setf (excl::fn_constant fin) init)
+    (setf (excl::fn_code fin)		; this must be before fn_start
+	  (excl::fn_code mattress-fun))
+    (setf (excl::fn_start fin) (excl::fn_start mattress-fun))
+    (setf (excl::fn_flags fin) (logior (excl::fn_flags init)
+				       funcallable-instance-flag-bit))
+    (setf (excl::fn_closure fin)
+      (make-array (length funcallable-instance-data)))
+
+    fin))
+
+;; This function gets its code vector modified with a hand-coded fast jump
+;; to the function that is stored in place of its constant vector.
+;; This function is never linked in and never appears on the stack.
+
+(defun funcallable-instance-mattress-pad ()
+  (declare (optimize (speed 3) (safety 0)))
+  'nil)
+
+(eval-when (eval)
+  (compile 'funcallable-instance-mattress-pad))
+
+
+#+(and excl (target-class s))
+(eval-when (load eval)
+  (let ((codevec (excl::fn_code
+		  (symbol-function 'funcallable-instance-mattress-pad))))
+    ;; The entire code vector wants to be:
+    ;;   move.l  7(a2),a2     ;#x246a0007
+    ;;   jmp     1(a2)        ;#x4eea0001
+    (setf (aref codevec 0) #x246a
+	  (aref codevec 1) #x0007
+	  (aref codevec 2) #x4eea
+	  (aref codevec 3) #x0001))
+)
+
+#+(and excl (target-class a))
+(eval-when (load eval)
+  (let ((codevec (excl::fn_code
+		  (symbol-function 'funcallable-instance-mattress-pad))))
+    ;; The entire code vector wants to be:
+    ;;   l       r5,15(r5)    ;#x5850500f
+    ;;   l       r15,11(r5)   ;#x58f0500b
+    ;;   br      r15          ;#x07ff
+    (setf (aref codevec 0) #x5850
+	  (aref codevec 1) #x500f
+	  (aref codevec 2) #x58f0
+	  (aref codevec 3) #x500b
+	  (aref codevec 4) #x07ff
+	  (aref codevec 5) #x0000))
+  )
+
+#+(and excl (target-class i))
+(eval-when (load eval)
+  (let ((codevec (excl::fn_code
+		  (symbol-function 'funcallable-instance-mattress-pad))))
+    ;; The entire code vector wants to be:
+    ;;   movl  7(edx),edx     ;#x07528b
+    ;;   jmp   *3(edx)        ;#x0362ff
+    (setf (aref codevec 0) #x8b
+	  (aref codevec 1) #x52
+	  (aref codevec 2) #x07
+	  (aref codevec 3) #xff
+	  (aref codevec 4) #x62
+	  (aref codevec 5) #x03))
+)
+
+(defun funcallable-instance-data-1 (instance data)
+  (let ((constant (excl::fn_closure instance)))
+    (svref constant (funcallable-instance-data-position data))))
+
+(defsetf funcallable-instance-data-1 set-funcallable-instance-data-1)
+
+(defun set-funcallable-instance-data-1 (instance data new-value)
+  (let ((constant (excl::fn_closure instance)))
+    (setf (svref constant (funcallable-instance-data-position data))
+          new-value)))
+
+(defun set-funcallable-instance-function (fin new-function)
+  (unless (funcallable-instance-p fin)
+    (error "~S is not a funcallable-instance" fin))
+  (unless (functionp new-function)
+    (error "~S is not a function." new-function))
+  (setf (excl::fn_constant fin)
+	(if (excl::function-object-p new-function)
+	    new-function
+	    ;; The new-function is an interpreted function.
+	    ;; Install a trampoline to call the interpreted function.
+	    (make-trampoline new-function))))
+
+
+)  ;; end sun3
+
+
+#+(and gsgc (or sun4 mips))
+(progn
+
+(eval-when (compile load eval)
+  (defconstant funcallable-instance-constant-count 15)
+  )
+
+(defun allocate-funcallable-instance-1 ()
+  (let ((new-fin (compiler::.primcall 
+		   'sys::new-function
+		   funcallable-instance-constant-count)))
+    ;; Have to set the procedure function to something for two reasons.
+    ;;   1. someone might try to funcall it.
+    ;;   2. the flag bit that says the procedure is a funcallable
+    ;;      instance is set by set-funcallable-instance-function.
+    (set-funcallable-instance-function new-fin #'init-fin-fun)
+    new-fin))
+
+(defun set-funcallable-instance-function (fin new-value)
+  ;; we actually only check for a function object since
+  ;; this is called before the funcallable instance flag is set
+  (unless (excl::function-object-p fin)
+    (error "~S is not a funcallable-instance" fin))
+
+  (cond ((not (functionp new-value))
+         (error "~S is not a function." new-value))
+        ((not (excl::function-object-p new-value))
+         ;; new-value is an interpreted function.  Install a
+         ;; trampoline to call the interpreted function.
+         (set-funcallable-instance-function fin (make-trampoline new-value)))
+	((> (+ (excl::function-constant-count new-value)
+	       (length funcallable-instance-data))
+	    funcallable-instance-constant-count)
+	 ; can't fit, must trampoline
+	 (set-funcallable-instance-function fin (make-trampoline new-value)))
+        (t
+         ;; tack the instance variables at the end of the constant vector
+	 
+         (setf (excl::fn_code fin)	; this must be before fn_start
+	       (excl::fn_code new-value))
+         (setf (excl::fn_start fin) (excl::fn_start new-value))
+         
+         (setf (excl::fn_closure fin) (excl::fn_closure new-value))
+	 ; only replace the symdef slot if the new value is an 
+	 ; interned symbol or some other object (like a function spec)
+	 (let ((newsym (excl::fn_symdef new-value)))
+	   (excl:if* (and newsym (or (not (symbolp newsym))
+				(symbol-package newsym)))
+	      then (setf (excl::fn_symdef fin) newsym)))
+         (setf (excl::fn_formals fin) (excl::fn_formals new-value))
+         (setf (excl::fn_cframe-size fin) (excl::fn_cframe-size new-value))
+	 (setf (excl::fn_locals fin) (excl::fn_locals new-value))
+         (setf (excl::fn_flags fin) (logior (excl::fn_flags new-value)
+                                            funcallable-instance-flag-bit))
+	 
+	 ;; on a sun4 we copy over the constants
+	 (dotimes (i (excl::function-constant-count new-value))
+	   (setf (excl::function-constant fin i) 
+		 (excl::function-constant new-value i)))
+	 ;(format t "all done copy from ~s to ~s" new-value fin)
+	 )))
+
+(defmacro funcallable-instance-data-1 (instance data)
+  `(excl::function-constant ,instance 
+			   (- funcallable-instance-constant-count
+			      (funcallable-instance-data-position ,data)
+			      1)))
+
+) ;; end sun4 or mips
+
+#+(and gsgc cray)
+(progn
+
+;; The cray is like the sun4 in that the constant vector is included in the  
+;; function object itself.  But a mattress pad must be used anyway, because
+;; the function start address is copied in the symbol object, and cannot be
+;; updated when the fin is changed.  
+;; We place the funcallable-instance-function into the first constant slot,  
+;; and leave enough constant slots after that for the instance data.
+
+(eval-when (compile load eval)
+  (defconstant fin-fun-slot 0)
+  (defconstant fin-instance-data-slot 1)
+  )
+
+
+;; We initialize a fin's procedure function to this because
+;; someone might try to funcall it before it has been set up.
+(defun init-fin-fun (&rest ignore)
+  (declare (ignore ignore))
+  (called-fin-without-function))
+
+(defun allocate-funcallable-instance-1 ()
+  (let ((fin (compiler::.primcall 'sys::new-function
+			(1+ (length funcallable-instance-data))
+			"funcallable-instance"))
+	(init #'init-fin-fun)
+	(mattress-fun #'funcallable-instance-mattress-pad))
+    (setf (excl::fn_symdef fin) 'anonymous-fin)
+    (setf (excl::function-constant fin fin-fun-slot) init)
+    (setf (excl::fn_code fin)		; this must be before fn_start
+      (excl::fn_code mattress-fun))
+    (setf (excl::fn_start fin) (excl::fn_start mattress-fun))
+    (setf (excl::fn_flags fin) (logior (excl::fn_flags init)
+				       funcallable-instance-flag-bit))
+    
+    fin))
+
+;; This function gets its code vector modified with a hand-coded fast jump
+;; to the function that is stored in place of its constant vector.
+;; This function is never linked in and never appears on the stack.
+
+(defun funcallable-instance-mattress-pad ()
+  (declare (optimize (speed 3) (safety 0)))
+  'nil)
+
+(eval-when (eval)
+  (compile 'funcallable-instance-mattress-pad)
+  (compile 'init-fin-fun))
+
+(eval-when (load eval)
+  (let ((codevec (excl::fn_code
+		  (symbol-function 'funcallable-instance-mattress-pad))))
+    ;; The entire code vector wants to be:
+    ;;   a1  b77
+    ;;   a2  12,a1
+    ;;   a1 1,a2
+    ;;   b77 a2
+    ;;   b76 a1
+    ;;   j   b76
+    (setf (aref codevec 0) #o024177
+	  (aref codevec 1) #o101200 (aref codevec 2) 12
+	  (aref codevec 3) #o102100 (aref codevec 4) 1
+	  (aref codevec 5) #o025277
+	  (aref codevec 6) #o025176
+	  (aref codevec 7) #o005076
+	  ))
+)
+
+(defmacro funcallable-instance-data-1 (instance data)
+  `(excl::function-constant ,instance 
+			    (+ (funcallable-instance-data-position ,data)
+			       fin-instance-dtat-slot)))
+
+
+(defun set-funcallable-instance-function (fin new-function)
+  (unless (funcallable-instance-p fin)
+    (error "~S is not a funcallable-instance" fin))
+  (unless (functionp new-function)
+    (error "~S is not a function." new-function))
+  (setf (excl::function-constant fin fin-fun-slot)
+    (if (excl::function-object-p new-function)
+	new-function
+	;; The new-function is an interpreted function.
+	;; Install a trampoline to call the interpreted function.
+	(make-trampoline new-function))))
+
+) ;; end cray
+
+#-gsgc
+(progn
+
+(defun allocate-funcallable-instance-1 ()
+  (let ((new-fin (compiler::.primcall 'sys::new-function)))
+    ;; Have to set the procedure function to something for two reasons.
+    ;;   1. someone might try to funcall it.
+    ;;   2. the flag bit that says the procedure is a funcallable
+    ;;      instance is set by set-funcallable-instance-function.
+    (set-funcallable-instance-function new-fin #'init-fin-fn)
+    new-fin))
+
+(defun set-funcallable-instance-function (fin new-value)
+  ;; we actually only check for a function object since
+  ;; this is called before the funcallable instance flag is set
+  (unless (excl::function-object-p fin)
+    (error "~S is not a funcallable-instance" fin))
+  (cond ((not (functionp new-value))
+         (error "~S is not a function." new-value))
+        ((not (excl::function-object-p new-value))
+         ;; new-value is an interpreted function.  Install a
+         ;; trampoline to call the interpreted function.
+         (set-funcallable-instance-function fin (make-trampoline new-value)))
+        (t
+         ;; tack the instance variables at the end of the constant vector
+         (setf (excl::fn_start fin) (excl::fn_start new-value))
+         (setf (excl::fn_constant fin) (add-instance-vars
+                                        (excl::fn_constant new-value)
+                                        (excl::fn_constant fin)))
+         (setf (excl::fn_closure fin) (excl::fn_closure new-value))
+	 ;; In versions prior to 2.0. comment the next line and any other
+	 ;; references to fn_symdef or fn_locals.
+	 (setf (excl::fn_symdef fin) (excl::fn_symdef new-value))
+         (setf (excl::fn_code fin) (excl::fn_code new-value))
+         (setf (excl::fn_formals fin) (excl::fn_formals new-value))
+         (setf (excl::fn_cframe-size fin) (excl::fn_cframe-size new-value))
+	 (setf (excl::fn_locals fin) (excl::fn_locals new-value))
+         (setf (excl::fn_flags fin) (logior (excl::fn_flags new-value)
+                                            funcallable-instance-flag-bit)))))
+
+(defun add-instance-vars (cvec old-cvec)
+  ;; create a constant vector containing everything in the given constant
+  ;; vector plus space for the instance variables
+  (let* ((nconstants (cond (cvec (length cvec)) (t 0)))
+         (ndata (length funcallable-instance-data))
+         (old-cvec-length (if old-cvec (length old-cvec) 0))
+         (new-cvec nil))
+    (cond ((<= (+ nconstants ndata)  old-cvec-length)
+           (setq new-cvec old-cvec))
+          (t
+           (setq new-cvec (make-array (+ nconstants ndata)))
+           (when old-cvec
+             (dotimes (i ndata)
+               (setf (svref new-cvec (- (+ nconstants ndata) i 1))
+                     (svref old-cvec (- old-cvec-length i 1)))))))
+    
+    (dotimes (i nconstants) (setf (svref new-cvec i) (svref cvec i)))
+    
+    new-cvec))
+
+(defun funcallable-instance-data-1 (instance data)
+  (let ((constant (excl::fn_constant instance)))
+    (svref constant (- (length constant)
+                       (1+ (funcallable-instance-data-position data))))))
+
+(defsetf funcallable-instance-data-1 set-funcallable-instance-data-1)
+
+(defun set-funcallable-instance-data-1 (instance data new-value)
+  (let ((constant (excl::fn_constant instance)))
+    (setf (svref constant (- (length constant) 
+                             (1+ (funcallable-instance-data-position data))))
+          new-value)))
+
+);end #-gsgc
+
+);end of #+ExCL
+
+
+;;;
+;;; In Vaxlisp
+;;; This code was originally written by:
+;;;    vanroggen%bach.DEC@DECWRL.DEC.COM
+;;; 
+#+(and dec vax common)
+(progn
+
+;;; The following works only in Version 2 of VAXLISP, and will have to
+;;; be replaced for later versions.
+
+(defun allocate-funcallable-instance-1 ()
+  (list 'system::%compiled-closure%
+        ()
+        #'(lambda (&rest args)
+            (declare (ignore args))
+	    (called-fin-without-function))
+        (make-array (length funcallable-instance-data))))
+
+(proclaim '(inline funcallable-instance-p))
+(defun funcallable-instance-p (x)
+  (and (consp x)
+       (eq (car x) 'system::%compiled-closure%)
+       (not (null (cdddr x)))))
+
+(defun set-funcallable-instance-function (fin func)
+  (cond ((not (funcallable-instance-p fin))
+         (error "~S is not a funcallable-instance" fin))
+        ((not (functionp func))
+         (error "~S is not a function" func))
+        ((and (consp func) (eq (car func) 'system::%compiled-closure%))
+         (setf (cadr fin) (cadr func)
+               (caddr fin) (caddr func)))
+        (t (set-funcallable-instance-function fin
+                                              (make-trampoline func)))))
+
+(defun make-trampoline (function)
+  #'(lambda (&rest args)
+      (apply function args)))
+
+(eval-when (eval) (compile 'make-trampoline))
+
+(defmacro funcallable-instance-data-1 (instance data)
+  `(svref (cadddr ,instance)
+          (funcallable-instance-data-position ,data)))
+
+);end of Vaxlisp (and dec vax common)
+
+
+;;; Implementation of funcallable instances for CMU Common Lisp.
+;;;
+;;; Similiar to the code for VAXLISP implementation.
+#+:CMU
+(progn
+
+(defun allocate-funcallable-instance-1 ()
+  `(lisp::%compiled-closure%
+     ()
+     ,#'(lambda (&rest args)
+	  (declare (ignore args))
+	  (called-fin-without-function))
+     ,(make-array (length funcallable-instance-data))))
+
+(proclaim '(inline funcallable-instance-p))
+(defun funcallable-instance-p (x)
+  (and (consp x)
+       (eq (car x) 'lisp::%compiled-closure%)
+       (not (null (cdddr x)))))
+
+(defun set-funcallable-instance-function (fin func)
+  (cond ((not (funcallable-instance-p fin))
+	 (error "~S is not a funcallable-instance" fin))
+	((not (functionp func))
+	 (error "~S is not a function" func))
+	((and (consp func) (eq (car func) 'lisp::%compiled-closure%))
+	 (setf (cadr fin) (cadr func)
+	       (caddr fin) (caddr func)))
+	(t (set-funcallable-instance-function fin
+					      (make-trampoline func)))))
+
+(defun make-trampoline (function)
+  #'(lambda (&rest args)
+      (apply function args)))
+
+(eval-when (eval) (compile 'make-trampoline))
+
+(defmacro funcallable-instance-data-1 (instance data)
+  `(svref (cadddr ,instance)
+	  (funcallable-instance-data-position ,data)))
+
+); End of :CMU
+
+
+
+;;;
+;;; Kyoto Common Lisp (KCL)
+;;;
+;;; In KCL, compiled functions and compiled closures are defined as c structs.
+;;; This means that in order to access their fields, we have to use C code!
+;;; The C code we call and the lisp interface to it is in the file kcl-low.
+;;; The lisp interface to this code implements accessors to compiled closures
+;;; and compiled functions of about the same level of abstraction as that
+;;; which is used by the other implementation dependent versions of FINs in
+;;; this file.
+;;;
+
+#+(or KCL IBCL)
+(progn
+
+(defvar *funcallable-instance-marker* (list "Funcallable Instance Marker"))
+
+(defconstant funcallable-instance-closure-size 15)
+
+(defconstant funcallable-instance-closure-size1
+  (1- funcallable-instance-closure-size))
+
+(defconstant funcallable-instance-available-size
+  (- funcallable-instance-closure-size1
+     (length funcallable-instance-data)))
+
+(defmacro funcallable-instance-marker (x)
+  `(car (cclosure-env-nthcdr funcallable-instance-closure-size1 ,x)))
+
+(defun allocate-funcallable-instance-1 ()
+  (let ((fin (allocate-funcallable-instance-2))
+        (env (make-list funcallable-instance-closure-size :initial-element nil)))
+    (setf (%cclosure-env fin) env)
+    #+:turbo-closure (si:turbo-closure fin)
+    (setf (funcallable-instance-marker fin) *funcallable-instance-marker*)
+    fin))
+
+(defun allocate-funcallable-instance-2 ()
+  (let ((what-a-dumb-closure-variable ()))
+    #'(lambda (&rest args)
+        (declare (ignore args))
+        (called-fin-without-function)
+        (setq what-a-dumb-closure-variable
+              (dummy-function what-a-dumb-closure-variable)))))
+
+(defun funcallable-instance-p (x)
+  (eq *funcallable-instance-marker* (funcallable-instance-marker x)))
+
+(si:define-compiler-macro funcallable-instance-p (x)
+  `(eq *funcallable-instance-marker* (funcallable-instance-marker ,x)))
+
+(defun set-funcallable-instance-function (fin new-value)
+  (cond ((not (funcallable-instance-p fin))
+         (error "~S is not a funcallable-instance" fin))
+        ((not (functionp new-value))
+         (error "~S is not a function." new-value))
+        ((and (cclosurep new-value)
+              (<= (length (%cclosure-env new-value))
+                  funcallable-instance-available-size))
+         (%set-cclosure fin new-value funcallable-instance-available-size))
+        (t
+         (set-funcallable-instance-function
+           fin (make-trampoline new-value))))
+  fin)
+
+(defmacro funcallable-instance-data-1 (fin data &environment env)
+  ;; The compiler won't expand macros before deciding on optimizations,
+  ;; so we must do it here.
+  (let* ((pos-form (macroexpand `(funcallable-instance-data-position ,data)
+                                env))
+         (index-form (if (constantp pos-form)
+                         (- funcallable-instance-closure-size
+                            (eval pos-form)
+                            2)
+                         `(- funcallable-instance-closure-size
+                             (funcallable-instance-data-position ,data)
+                             2))))
+    `(car (%cclosure-env-nthcdr ,index-form ,fin))))
+
+
+#+turbo-closure (clines "#define TURBO_CLOSURE")
+
+(clines "
+static make_trampoline_internal();
+static make_turbo_trampoline_internal();
+
+static object
+make_trampoline(function)
+     object function;
+{
+  vs_push(MMcons(function,Cnil));
+#ifdef TURBO_CLOSURE
+  if(type_of(function)==t_cclosure)
+    {if(function->cc.cc_turbo==NULL)turbo_closure(function);
+     vs_head=make_cclosure(make_turbo_trampoline_internal,Cnil,vs_head,Cnil,NULL,0);
+     return vs_pop;}
+#endif
+  vs_head=make_cclosure(make_trampoline_internal,Cnil,vs_head,Cnil,NULL,0);
+  return vs_pop;
+}
+
+static
+make_trampoline_internal(base0)
+     object *base0;
+{super_funcall_no_event(base0[0]->c.c_car);}
+
+static
+make_turbo_trampoline_internal(base0)
+     object *base0;
+{ object function=base0[0]->c.c_car;
+  (*function->cc.cc_self)(function->cc.cc_turbo);
+}
+
+")
+
+(defentry make-trampoline (object) (object make_trampoline))
+)
+
+
+;;;
+;;; In H.P. Common Lisp
+;;; This code was originally written by:
+;;;    kempf@hplabs.hp.com     (James Kempf)
+;;;    dsouza@hplabs.hp.com    (Roy D'Souza)
+;;;
+#+HP-HPLabs
+(progn
+
+(defmacro fin-closure-size ()`(prim::@* 6 prim::bytes-per-word))
+
+(defmacro fin-set-mem-hword ()
+  `(prim::@set-mem-hword
+     (prim::@+ fin (prim::@<< 2 1))
+     (prim::@+ (prim::@<< 2 8)
+	       (prim::@fundef-info-parms (prim::@fundef-info fundef)))))
+
+(defun allocate-funcallable-instance-1()
+  (let* ((fundef
+	   #'(lambda (&rest ignore)
+	       (declare (ignore ignore))
+	       (called-fin-without-function)))
+	 (static-link (vector 'lisp::*undefined* NIL NIL NIL NIL NIL))
+	 (fin (prim::@make-fundef (fin-closure-size))))
+    (fin-set-mem-hword)
+    (prim::@set-svref fin 2 fundef)
+    (prim::@set-svref fin 3 static-link)
+    (prim::@set-svref fin 4 0) 
+    (impl::PlantclosureHook fin)
+    fin))
+
+(defmacro funcallable-instance-p (possible-fin)
+  `(= (fin-closure-size) (prim::@header-inf ,possible-fin)))
+
+(defun set-funcallable-instance-function (fin new-function)
+  (cond ((not (funcallable-instance-p fin))
+	 (error "~S is not a funcallable instance.~%" fin))
+	((not (functionp new-function))
+	 (error "~S is not a function." new-function))
+	(T
+	 (prim::@set-svref fin 2 new-function))))
+
+(defmacro funcallable-instance-data-1 (fin data)
+  `(prim::@svref (prim::@closure-static-link ,fin)
+		 (+ 2 (funcallable-instance-data-position ,data))))
+
+(defsetf funcallable-instance-data-1 (fin data) (new-value)
+  `(prim::@set-svref (prim::@closure-static-link ,fin)
+		     (+ (funcallable-instance-data-position ,data) 2)
+		     ,new-value))
+
+(defun funcallable-instance-name (fin)
+  (prim::@svref (prim::@closure-static-link fin) 1))
+
+(defsetf funcallable-instance-name set-funcallable-instance-name)
+
+(defun set-funcallable-instance-name (fin new-name)
+  (prim::@set-svref (prim::@closure-static-link fin) 1 new-name))
+
+);end #+HP
+
+
+
+;;;
+;;; In Golden Common Lisp.
+;;; This code was originally written by:
+;;;    dan%acorn@Live-Oak.LCS.MIT.edu     (Dan Jacobs)
+;;;
+;;; GCLISP supports named structures that are specially marked as funcallable.
+;;; This allows FUNCALLABLE-INSTANCE-P to be a normal structure predicate,
+;;; and allows ALLOCATE-FUNCALLABLE-INSTANCE-1 to be a normal boa-constructor.
+;;; 
+#+GCLISP
+(progn
+
+(defstruct (%funcallable-instance
+	     (:predicate funcallable-instance-p)
+	     (:copier nil)
+	     (:constructor allocate-funcallable-instance-1 ())
+	     (:print-function
+	      (lambda (struct stream depth)
+		(declare (ignore depth))
+		(print-object struct stream))))
+  (function	#'(lambda (ignore-this &rest ignore-these-too)
+		    (declare (ignore ignore-this ignore-these-too))
+		    (called-fin-without-function))
+		:type function)
+  (%hidden%	'gclisp::funcallable :read-only t)
+  (data		(vector nil nil) :type simple-vector :read-only t))
+
+(proclaim '(inline set-funcallable-instance-function))
+(defun set-funcallable-instance-function (fin new-value)
+  (setf (%funcallable-instance-function fin) new-value))
+
+(defmacro funcallable-instance-data-1 (fin data)
+  `(svref (%funcallable-instance-data ,fin)
+	  (funcallable-instance-data-position ,data)))
+
+)
+
+
+;;;
+;;; Explorer Common Lisp
+;;; This code was originally written by:
+;;;    Dussud%Jenner@csl.ti.com
+;;;    
+#+ti
+(progn
+
+#+(or :ti-release-3 (and :ti-release-2 elroy))
+(defmacro lexical-closure-environment (l)
+  `(cdr (si:%make-pointer si:dtp-list
+			  (cdr (si:%make-pointer si:dtp-list ,l)))))
+
+#-(or :ti-release-3 elroy)
+(defmacro lexical-closure-environment (l)
+  `(caar (si:%make-pointer si:dtp-list
+			   (cdr (si:%make-pointer si:dtp-list ,l)))))
+
+(defmacro lexical-closure-function (l)
+  `(car (si:%make-pointer si:dtp-list ,l)))
+
+
+(defvar *funcallable-instance-marker* (list "Funcallable Instance Marker"))
+
+(defconstant funcallable-instance-closure-size 15) ; NOTE: In order to avoid
+						   ; hassles with the reader,
+(defmacro allocate-funcallable-instance-2 ()       ; these two 15's are the
+  (let ((l ()))					   ; same.  Be sure to keep
+    (dotimes (i 15)				   ; them consistent.
+      (push (list (gensym) nil) l))
+    `(let ,l
+       #'(lambda (ignore &rest ignore-them-too)
+	   (declare (ignore ignore ignore-them-too))
+	   (called-fin-without-function)
+	   (values . ,(mapcar #'car l))))))
+
+(defun allocate-funcallable-instance-1 ()
+  (let* ((new-fin (allocate-funcallable-instance-2)))
+    (setf (car (nthcdr (1- funcallable-instance-closure-size)
+		       (lexical-closure-environment new-fin)))
+	  *funcallable-instance-marker*) 
+    new-fin))
+
+(eval-when (eval) (compile 'allocate-funcallable-instance-1))
+
+(proclaim '(inline funcallable-instance-p))
+(defun funcallable-instance-p (x)
+  (and (typep x #+:ti-release-2 'closure
+	        #+:ti-release-3 'si:lexical-closure)
+       (let ((env (lexical-closure-environment x)))
+	 (eq (nth (1- funcallable-instance-closure-size) env)
+	     *funcallable-instance-marker*))))
+
+(defun set-funcallable-instance-function (fin new-value)
+  (cond ((not (funcallable-instance-p fin))
+	 (error "~S is not a funcallable-instance"))
+	((not (functionp new-value))
+	 (error "~S is not a function."))
+	((typep new-value 'si:lexical-closure)
+	 (let* ((fin-env (lexical-closure-environment fin))
+		(new-env (lexical-closure-environment new-value))
+		(new-env-size (length new-env))
+		(fin-env-size (- funcallable-instance-closure-size
+				 (length funcallable-instance-data)
+				 1)))
+	   (cond ((<= new-env-size fin-env-size)
+		  (do ((i 0 (+ i 1))
+		       (new-env-tail new-env (cdr new-env-tail))
+		       (fin-env-tail fin-env (cdr fin-env-tail)))
+		      ((= i fin-env-size))
+		    (setf (car fin-env-tail)
+			  (if (< i new-env-size)
+			      (car new-env-tail)
+			      nil)))		  
+		  (setf (lexical-closure-function fin)
+			(lexical-closure-function new-value)))
+		 (t
+		  (set-funcallable-instance-function
+		    fin
+		    (make-trampoline new-value))))))
+	(t
+	 (set-funcallable-instance-function fin
+					    (make-trampoline new-value)))))
+
+(defun make-trampoline (function)
+  (let ((tmp))
+    #'(lambda (&rest args) tmp
+	(apply function args))))
+
+(eval-when (eval) (compile 'make-trampoline))
+	
+(defmacro funcallable-instance-data-1 (fin data)
+  `(let ((env (lexical-closure-environment ,fin)))
+     (nth (- funcallable-instance-closure-size
+	     (funcallable-instance-data-position ,data)
+	     2)
+	  env)))
+
+
+(defsetf funcallable-instance-data-1 (fin data) (new-value)
+  `(let ((env (lexical-closure-environment ,fin)))
+     (setf (car (nthcdr (- funcallable-instance-closure-size
+			   (funcallable-instance-data-position ,data)
+			   2)
+			env))
+	   ,new-value)))
+
+);end of code for TI
+
+
+;;; Implemented by Bein@pyramid -- Tue Aug 25 19:05:17 1987
+;;;
+;;; A FIN is a distinct type of object which FUNCALL,EVAL, and APPLY
+;;; recognize as functions. Both Compiled-Function-P and functionp
+;;; recognize FINs as first class functions.
+;;;
+;;; This does not work with PyrLisp versions earlier than 1.1..
+
+#+pyramid
+(progn
+
+(defun make-trampoline (function)
+    #'(lambda (&rest args) (apply function args)))
+
+(defun un-initialized-fin (&rest trash)
+    (declare (ignore trash))
+    (called-fin-without-function))
+
+(eval-when (eval)
+    (compile 'make-trampoline)
+    (compile 'un-initialized-fin))
+
+(defun allocate-funcallable-instance-1 ()
+    (let ((fin (system::alloc-funcallable-instance)))
+      (system::set-fin-function fin #'un-initialized-fin)
+      fin))
+	     
+(defun funcallable-instance-p (object)
+  (typep object 'lisp::funcallable-instance))
+
+(clc::deftransform funcallable-instance-p trans-fin-p (object)
+    `(typep ,object 'lisp::funcallable-instance))
+
+(defun set-funcallable-instance-function (fin new-value)
+    (or (funcallable-instance-p fin)
+	(error "~S is not a funcallable-instance." fin))
+    (cond ((not (functionp new-value))
+	   (error "~S is not a function." new-value))
+	  ((not (lisp::compiled-function-p new-value))
+	   (set-funcallable-instance-function fin
+					      (make-trampoline new-value)))
+	  (t
+	   (system::set-fin-function fin new-value))))
+
+(defun funcallable-instance-data-1 (fin data-name)
+  (system::get-fin-data fin
+			(funcallable-instance-data-position data-name)))
+
+(defun set-funcallable-instance-data-1 (fin data-name value)
+  (system::set-fin-data fin
+			(funcallable-instance-data-position data-name)
+			value))
+
+(defsetf funcallable-instance-data-1 set-funcallable-instance-data-1)
+
+); End of #+pyramid
+
+
+;;;
+;;; For Coral Lisp
+;;;
+#+:coral
+(progn
+  
+(defconstant ccl::$v_istruct 22)
+(defvar ccl::initial-fin-slots (make-list (length funcallable-instance-data)))
+(defconstant ccl::fin-function 1)
+(defconstant ccl::fin-data (+ ccl::FIN-function 1))
+
+(defun allocate-funcallable-instance-1 ()
+  (apply #'ccl::%gvector 
+         ccl::$v_istruct
+         'ccl::funcallable-instance
+         #'(lambda (&rest ignore)
+             (declare (ignore ignore))
+	     (called-fin-without-function))
+         ccl::initial-fin-slots))
+
+;;; Make uvector-based objects (like funcallable instances) print better.
+#+:ccl-1.3
+(defun print-uvector-object (obj stream &optional print-level)
+  (declare (ignore print-level))
+  (print-object obj stream))
+
+;;; Inform the print system about funcallable instance uvectors.
+#+:ccl-1.3
+(eval-when (eval compile load)
+  (pushnew (cons 'ccl::funcallable-instance #'print-uvector-object)
+           ccl:*write-uvector-alist*
+           :test #'equal))
+
+(defun funcallable-instance-p (x)
+  (and (eq (ccl::%type-of x) 'ccl::internal-structure)
+       (eq (ccl::%uvref x 0) 'ccl::funcallable-instance)))
+
+(defun set-funcallable-instance-function (fin new-value)
+  (unless (funcallable-instance-p fin)
+    (error "~S is not a funcallable-instance." fin))
+  (unless (functionp new-value)
+    (error "~S is not a function." new-value))
+  (ccl::%uvset fin ccl::FIN-function new-value))
+
+(defmacro funcallable-instance-data-1 (fin data-name)
+  `(ccl::%uvref ,fin 
+                (+ (funcallable-instance-data-position ,data-name)
+		   ccl::FIN-data)))
+
+(defsetf funcallable-instance-data-1 (fin data) (new-value)
+  `(ccl::%uvset ,fin 
+                (+ (funcallable-instance-data-position ,data) ccl::FIN-data)
+                ,new-value))
+
+); End of #+:coral
+
+
+  
+;;;; Slightly Higher-Level stuff built on the implementation-dependent stuff.
+;;;
+;;;
+
+(defmacro fsc-instance-p (fin)
+  `(funcallable-instance-p ,fin))
+
+(defmacro fsc-instance-class (fin)
+  `(wrapper-class (funcallable-instance-data-1 ,fin 'wrapper)))
+
+(defmacro fsc-instance-wrapper (fin)
+  `(funcallable-instance-data-1 ,fin 'wrapper))
+
+(defmacro fsc-instance-slots (fin)
+  `(funcallable-instance-data-1 ,fin 'slots))
+
+(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))
diff --git a/pcl/fixup.lisp b/pcl/fixup.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..e068109c7733212144a4d84528a1f700157dcfb8
--- /dev/null
+++ b/pcl/fixup.lisp
@@ -0,0 +1,42 @@
+;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+
+(in-package 'pcl)
+
+(eval-when (compile load eval)
+  (fix-early-generic-functions)
+  (setq *boot-state* 'complete))
+
+#+Lispm
+(eval-when (load eval)
+  (si:record-source-file-name 'print-std-instance 'defun 't))
+
+(defun print-std-instance (instance stream depth)
+  (declare (ignore depth))
+  (print-object instance stream))
+
+
diff --git a/pcl/fngen.lisp b/pcl/fngen.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..a29dd0fe3601c2b794e232397d229fca5e1b4ce8
--- /dev/null
+++ b/pcl/fngen.lisp
@@ -0,0 +1,175 @@
+;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+
+(in-package 'pcl)
+
+;;;
+;;; 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* ())
+
+(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 (function ,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 ()))
+    (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 ()
+	       `(let ((result ()))
+ 		  (values #'(lambda (value) (setq result (append result value)))
+ 			  #'(lambda ()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)
+		       (function ,(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)))
diff --git a/pcl/fsc.lisp b/pcl/fsc.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..8308c12dc8cb708dcca721131eaf764584a74e6f
--- /dev/null
+++ b/pcl/fsc.lisp
@@ -0,0 +1,101 @@
+;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+;;; 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.
+;;; 
+
+(in-package 'pcl)
+
+(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))
+
+
diff --git a/pcl/gcl-patches.lisp b/pcl/gcl-patches.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..fcc0164a39415280a4c685f3b7305d400f51459e
--- /dev/null
+++ b/pcl/gcl-patches.lisp
@@ -0,0 +1,166 @@
+;;; -*- Mode:Lisp; Package:USER; Base:10; Syntax:Common-lisp -*-
+
+(in-package 'user)
+
+(setq c::optimize-speed 3)
+(setq c::optimize-safety 0)
+(setq c::optimize-space 0)
+
+(remprop 'macroexpand 'c::fdesc)
+(remprop 'macroexpand-1 'c::fdesc)
+
+
+;;; this is here to fix the printer so it will find the print
+;;; functions on structures that have 'em.
+
+(in-package 'lisp)
+
+(defun %write-structure (struct output-stream print-vars level)
+  (let* ((name (svref struct 0))
+	 (pfun (or (let ((temp (get name 'structure-descriptor)))
+	 	     (and temp (dd-print-function temp)))
+	 	   (get name :print-function))))
+    (declare (symbol name))
+    (cond
+      (pfun
+	(funcall pfun struct output-stream level))
+      ((and (pv-level print-vars) (>= level (pv-level print-vars)))
+       (write-char #\# output-stream))
+      ((and (pv-circle print-vars)
+            (%write-circle struct output-stream (pv-circle print-vars))))
+      (t
+       (let ((pv-length (pv-length print-vars))
+	     (pv-pretty (pv-pretty print-vars)))
+	 (when pv-pretty
+	   (pp-push-level pv-pretty))
+	 (incf level)
+	 (write-string "#s(" output-stream)
+	 (cond
+	  ((and pv-length (>= 0 pv-length))
+	   (write-string "..."))
+	  (t
+	   (%write-symbol name output-stream print-vars)
+	   (do ((i 0 (1+ i))
+		(n 0)
+		(slots (dd-slots (get name 'structure-descriptor))
+		       (rest slots)))
+	       ((endp slots))
+	     (declare (fixnum i n) (list slots))
+	     (when pv-pretty
+	       (pp-insert-break pv-pretty *structure-keyword-slot-spec* t))
+	     (write-char #\space output-stream)
+	     (when (and pv-length (>= (incf n) pv-length))
+	       (write-string "..." output-stream)
+	       (return))
+	     (write-char #\: output-stream)
+	     (%write-symbol-name
+	      (symbol-name (dsd-name (first slots))) output-stream print-vars)
+	     (when pv-pretty
+	       (pp-insert-break pv-pretty *structure-data-slot-spec* nil))
+	     (write-char #\space output-stream)
+	     (when (and pv-length (>= (incf n) pv-length))
+	       (write-string "..." output-stream)
+	       (return))
+	     (%write-object
+	      (svref struct (dsd-index (first slots)))
+	      output-stream print-vars level))))
+	 (write-char #\) output-stream)
+	 (when pv-pretty
+	   (pp-pop-level pv-pretty)))))))
+
+(eval-when (eval) (compile '%write-structure))
+
+;;;
+;;; Apparently, whoever implemented the TIME macro didn't consider that
+;;; someone might want to use it in a non-null lexical environment.  Of
+;;; course this fix is a loser since it binds a whole mess of variables
+;;; around the evaluation of form, but it will do for now.
+;;;
+(in-package 'lisp)
+
+(DEFmacro TIME (FORM)
+  `(LET (IGNORE START FINISH S-HSEC F-HSEC S-SEC F-SEC S-MIN F-MIN VALS)
+     (FORMAT *trace-output* "~&Evaluating: ~A" ,form)
+     ;; read the start time.
+     (MULTIPLE-VALUE-SETQ (IGNORE IGNORE IGNORE S-MIN START)
+       (SYS::%SYSINT #X21 #X2C00 0 0 0))
+     ;; Eval the form.
+     (SETQ VALS (MULTIPLE-VALUE-LIST (progn ,form)))
+     ;; Read the end time.
+     (MULTIPLE-VALUE-SETQ (IGNORE IGNORE IGNORE F-MIN FINISH)
+       (SYS::%SYSINT #X21 #X2C00 0 0 0))
+     ;; Unpack start and end times.
+     (SETQ S-HSEC (LOGAND START #X0FF)
+	   F-HSEC (LOGAND FINISH #X0FF)
+	   S-SEC (LSH START -8)
+           F-SEC (LSH FINISH -8)
+	   S-MIN (LOGAND #X0FF S-MIN)
+	   F-MIN (LOGAND #X0FF F-MIN))
+     (SETQ F-HSEC (- F-HSEC S-HSEC))			; calc hundreths
+     (IF (MINUSP F-HSEC)
+         (SETQ F-HSEC (+ F-HSEC 100)
+	       F-SEC (1- F-SEC)))
+     (SETQ F-SEC (- F-SEC S-SEC))			; calc seconds
+     (IF (MINUSP F-SEC)
+         (SETQ F-SEC (+ F-SEC 60)
+	       F-MIN (1- F-MIN)))
+     (SETQ F-MIN (- F-MIN S-MIN))			; calc minutes
+     (IF (MINUSP F-MIN) (INCF F-MIN 60))
+     (FORMAT *trace-output* "~&Elapsed time: ~D:~:[~D~;0~D~].~:[~D~;0~D~]~%"
+       F-MIN (< F-SEC 10.) F-SEC (< F-HSEC 10) F-HSEC)
+     (VALUES-LIST VALS)))
+
+;;;
+;;; Patch to PROGV
+;;; 
+(in-package sys::*compiler-package-load*)
+
+;;; This is a fully portable (though not very efficient)
+;;; implementation of PROGV as a macro.  It does its own special
+;;; binding (shallow binding) by saving the original values in a
+;;; list, and marking things that were originally unbound.
+
+(defun PORTABLE-PROGV-BIND (symbol old-vals place-holder)
+  (let ((val-to-save '#:value-to-save))
+    `(let ((,val-to-save (if (boundp ,symbol)
+			     (symbol-value ,symbol)
+			     ,place-holder)))
+       (if ,old-vals
+	   (rplacd (last ,old-vals) (ncons ,val-to-save))
+	   (setq ,old-vals (ncons ,val-to-save))))))
+
+(defun PORTABLE-PROGV-UNBIND (symbol old-vals place-holder)
+  (let ((val-to-restore '#:value-to-restore))
+    `(let ((,val-to-restore (pop ,old-vals)))
+       (if (eq ,val-to-restore ,place-holder)
+	   (makunbound ,symbol)
+	   (setf (symbol-value ,symbol) ,val-to-restore)))))
+  
+
+(deftransform PROGV PORTABLE-PROGV-TRANSFORM
+	      (symbols-form values-form &rest body)
+  (let ((symbols-lst '#:symbols-list)
+	(values-lst '#:values-list)
+	(syms '#:symbols)
+	(vals '#:values)
+	(sym '#:symbol)
+	(old-vals '#:old-values)
+	(unbound-holder ''#:unbound-holder))
+    `(let ((,symbols-lst ,symbols-form)
+	   (,values-lst ,values-form)
+	   (,old-vals nil))
+       (unless (and (listp ,symbols-lst) (listp ,values-lst))
+	 (error "PROGV: Both symbols and values must be lists"))
+       (unwind-protect
+	   (do ((,syms ,symbols-lst (cdr ,syms))
+		(,vals ,values-lst (cdr ,vals))
+		(,sym nil))
+	       ((null ,syms) (progn ,@body))
+	     (setq ,sym (car ,syms))
+	     (if (symbolp ,sym)
+		 ,(PORTABLE-PROGV-BIND sym old-vals unbound-holder)
+		 (error "PROGV: Object to be bound not a symbol: ~S" ,sym))
+	     (if ,vals
+		 (setf (symbol-value ,sym) (first ,vals))
+		 (makunbound ,sym)))
+	 (dolist (,sym ,symbols-lst)
diff --git a/pcl/genera-low.lisp b/pcl/genera-low.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..1350b3d6ca2aba5d9c64188fc9c87c0d72148614
--- /dev/null
+++ b/pcl/genera-low.lisp
@@ -0,0 +1,615 @@
+;;; -*- Mode:LISP; Package:(PCL Lisp 1000); Base:10.; Syntax:Common-lisp; Patch-File: Yes -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+;;; This is the 3600 version of the file portable-low.
+;;;
+
+(in-package 'pcl)
+
+#+IMach						;On the I-Machine these are
+(eval-when (compile load eval)			;faster than the versions
+						;that use :test #'eq.  
+(defmacro memq (item list) `(member ,item ,list))
+(defmacro assq (item list) `(assoc ,item ,list))
+(defmacro rassq (item list) `(rassoc ,item ,list))
+(defmacro delq (item list) `(delete ,item ,list))
+(defmacro posq (item list) `(position ,item ,list))
+
+)
+
+compiler::
+(defoptimizer (cl:the the-just-gets-in-the-way-of-optimizers) (form)
+  (matchp form
+    (('cl:the type subform)
+     (ignore type)
+     subform)
+    (* form)))
+
+(defmacro %ash (x count)
+  (if (and (constantp count) (zerop (eval count)))
+      x
+      `(the fixnum (ash (the fixnum ,x ) ,count))))
+
+;;;
+;;;
+;;;
+
+(defmacro without-interrupts (&body body)
+  `(let ((outer-scheduling-state si:inhibit-scheduling-flag)
+	 (si:inhibit-scheduling-flag t))
+     (macrolet ((interrupts-on  ()
+		  '(when (null outer-scheduling-state)
+		     (setq si:inhibit-scheduling-flag nil)))
+		(interrupts-off ()
+		  '(setq si:inhibit-scheduling-flag t)))
+       (progn outer-scheduling-state)
+       ,.body)))
+
+;;;
+;;; It would appear that #, does not work properly in Genera.  At least I can't get it
+;;; to work when I use it inside of std-instance-p (defined later in this file).  So,
+;;; all of this is just to support that.
+;;;
+;;;     WHEN                       EXPANDS-TO
+;;;   compile to a file          (#:EVAL-AT-LOAD-TIME-MARKER . <form>)
+;;;   compile to core            '<result of evaluating form>
+;;;   not in compiler at all     (progn <form>)
+;;;
+;;; Believe me when I tell you that I don't know why it is I need both a
+;;; transformer and an optimizer to get this to work.  Believe me when I
+;;; tell you that I don't really care why either.
+;;;
+(defmacro load-time-eval (form)
+  ;; The interpreted definition of load-time-eval.  This definition
+  ;; never gets compiled.
+  (let ((value (gensym)))
+    `(multiple-value-bind (,value)
+	 (progn ,form)
+       ,value)))
+
+(compiler:deftransformer (load-time-eval optimize-load-time-eval) (form)
+  (compiler-is-a-loser-internal form))
+
+(compiler:defoptimizer (load-time-eval transform-load-time-eval) (form)
+  (compiler-is-a-loser-internal form))
+
+(defun compiler-is-a-loser-internal (form)  
+  ;; When compiling a call to load-time-eval the compiler will call
+  ;; this optimizer before the macro expansion.
+  (if zl:compiler:(and (boundp '*compile-function*)	;Probably don't need
+						        ;this boundp check
+						        ;but it can't hurt.
+		       (funcall *compile-function* :to-core-p))
+      ;; Compiling to core.
+      ;; Evaluate the form now, and expand into a constant
+      ;; (the result of evaluating the form).
+      `',(eval (cadr form))
+      ;; Compiling to a file.
+      ;; Generate the magic which causes the dumper compiler and loader
+      ;; to do magic and evaluate the form at load time.
+      `',(cons compiler:eval-at-load-time-marker (cadr form))))
+
+;;   
+;;;;;; Memory Block primitives.                ***
+  ;;   
+
+
+(defmacro make-memory-block (size &optional area)
+  `(make-array ,size :area ,area))
+
+(defmacro memory-block-ref (block offset)	;Don't want to go faster yet.
+  `(aref ,block ,offset))
+
+(defvar class-wrapper-area)
+(eval-when (load eval)
+  (si:make-area :name 'class-wrapper-area
+		:room t
+		:gc :static))
+
+(eval-when (compile load eval)
+  (remprop '%%allocate-instance--class 'inline))
+
+(eval-when (compile load eval)
+  
+(scl:defflavor std-instance
+	((wrapper nil)
+	 (slots   nil))
+	()
+  (:constructor %%allocate-instance--class())
+  :ordered-instance-variables)
+
+(defvar *std-instance-flavor* (flavor:find-flavor 'std-instance))
+
+)
+
+#-imach
+(scl:defsubst pcl-%instance-flavor (instance)
+  (declare (compiler:do-not-record-macroexpansions))
+  (sys::%make-pointer sys:dtp-array
+		      (sys:%p-contents-as-locative
+			(sys:follow-structure-forwarding instance))))
+
+#+imach
+(scl:defsubst pcl-%instance-flavor (instance)
+  (sys:%instance-flavor instance))
+
+(scl::defsubst std-instance-p (x)
+  (and (sys:instancep x)
+       (eq (pcl-%instance-flavor x) (load-time-eval *std-instance-flavor*))))
+
+(scl:defmethod (:print-self std-instance) (stream depth slashify)
+  (declare (ignore slashify))
+  (print-std-instance scl:self stream depth))
+
+(defmacro %std-instance-wrapper (std-instance)
+  `(sys:%instance-ref ,std-instance 1))
+
+(defmacro %std-instance-slots (std-instance)
+  `(sys:%instance-ref ,std-instance 2))
+
+(scl:compile-flavor-methods std-instance)
+
+
+(defun printing-random-thing-internal (thing stream)
+  (format stream "~O" (si:%pointer thing)))
+
+;;;
+;;; This is hard, I am sweating.
+;;; 
+(defun function-arglist (function) (zl:arglist function t))
+
+(defun function-pretty-arglist (function) (zl:arglist function))
+
+
+;;;
+;;; This code is adapted from frame-lexical-environment and frame-function.
+;;;
+(defvar *old-function-name*)
+(defvar *boot-state* ())			;Copied from defs.lisp
+
+(defun new-function-name (function)
+  (or (and (eq *boot-state* 'complete)
+	   (generic-function-p function)
+	   (generic-function-name function))
+      (funcall *old-function-name* function)))
+
+(eval-when (load)
+  (unless (boundp '*old-function-name*)
+    (setq *old-function-name* #'si:function-name)
+    (setf (symbol-function 'si:function-name) 'new-function-name)))
+;
+;dbg:
+;(progn
+;
+;(defvar *old-frame-function*)
+;
+;(defvar *envs->fins* (make-hash-table))
+;
+;(defun set-env->fin (env fin)
+;  (setf (gethash env *envs->fins*) fin))
+;
+;(defun new-frame-function (frame)
+;  (let* ((fn (funcall *old-frame-function* frame))
+;	 (location (%pointer-plus frame #+imach (defstorage-size stack-frame) #-imach 0))
+;	 (env? #+3600 (location-contents location)
+;	       #+imach (%memory-read location :cycle-type %memory-scavenge)))
+;    (or (when (and (cl:consp env?)
+;		   (not (null (assq :lexical-variable-instructions (debugging-info fn)))))
+;	  (gethash env? *envs->fins*))
+;	fn)))
+;
+;(defun pcl::doctor-dfun-for-the-debugger (gf dfun)
+;  (when (sys:lexical-closure-p dfun)
+;    (let* ((env (si:lexical-closure-environment dfun))
+;	   (l2 (last2 env)))
+;      (unless (eq (car l2) '.this-is-a-dfun.)
+;	(setf (si:lexical-closure-environment dfun)
+;	      (nconc env (list '.this-is-a-dfun. gf))))))
+;  dfun)
+;
+;(defun last2 (l)
+;  (labels ((scan (2ago tail)
+;	     (if (null tail)
+;		 2ago
+;		 (if (cl:consp tail)
+;		     (scan (cdr 2ago) (cdr tail))
+;		     nil))))
+;    (and (cl:consp l)
+;	 (cl:consp (cdr l))
+;	 (scan l (cddr l)))))
+;
+;(eval-when (load)
+;  (unless (boundp '*old-frame-function*)
+;    (setq *old-frame-function* #'frame-function)
+;    (setf (cl:symbol-function 'frame-function) 'new-frame-function)))
+;
+;)
+
+
+
+;; New (& complete) fspec handler.
+;;   1. uses a single #'equal htable where stored elements are (fn . plist)
+;;       (maybe we should store the method object instead)
+;;   2. also implements the fspec-plist operators here.
+;;   3. fdefine not only stores the method, but actually does the loading here!
+;;
+
+;;;
+;;;  genera-low.lisp (replaces old method-function-spec-handler)
+;;;
+
+;; New (& complete) fspec handler.
+;;   1. uses a single #'equal htable where stored elements are (fn . plist)
+;;       (maybe we should store the method object instead)
+;;   2. also implements the fspec-plist operators here.
+;;   3. fdefine not only stores the method, but actually does the loading here!
+;;
+
+(defvar *method-htable* (make-hash-table :test #'equal :size 500))
+(si:define-function-spec-handler method (op spec &optional arg1 arg2)
+  (if (eq op 'sys:validate-function-spec)
+      (and (let ((gspec (cadr spec)))
+	     (or (symbolp gspec)
+		 (and (listp gspec)
+		      (eq (car gspec) 'setf)
+		      (symbolp (cadr gspec))
+		      (null (cddr gspec)))))
+	   (let ((tail (cddr spec)))
+	     (loop (cond ((null tail) (return nil))
+			 ((listp (car tail)) (return t))
+			 ((atom (pop tail)))			 
+			 (t (return nil))))))
+      (let ((table *method-htable*)
+	    (key spec))
+	(case op
+	  ((si:fdefinedp si:fdefinition)
+	   (car (gethash key table nil)))
+	  (si:fundefine
+	    (remhash key table))
+	  (si:fdefine
+	    (let ((old (gethash key table nil))
+		  (gspec (cadr spec))
+		  (quals nil)
+		  (specs nil)
+		  (ptr (cddr spec)))
+	      (setq specs
+		    (loop (cond ((null ptr) (return nil))
+				((listp (car ptr)) (return (car ptr)))
+				(t (push (pop ptr) quals)))))
+	      (pcl-fdefine-helper gspec (nreverse quals) specs arg1)
+	      (setf (gethash key table) (cons arg1 (cdr old)))))
+	  (si:get
+	    (let ((old (gethash key table nil)))
+	      (getf (cdr old) arg1)))
+	  (si:plist
+	    (let ((old (gethash key table nil)))
+	      (cdr old)))
+	  (si:putprop
+	    (let ((old (gethash key table nil)))
+	      (unless old
+		(setf old (cons nil nil))
+		(setf (gethash key table) old))
+	      (setf (getf (cdr old) arg2) arg1)))
+	  (si:remprop
+	    (let ((old (gethash key table nil)))
+	      (when old
+		(remf (cdr old) arg1))))
+	  (otherwise
+	    (si:function-spec-default-handler op spec arg1 arg2))))))
+
+;; this guy is just a stub to make the fspec handler simpler (and so I could trace it
+;; easier).
+(defun pcl-fdefine-helper (gspec qualifiers specializers fn)
+  (let* ((dlist (scl:debugging-info fn))
+	 (class (cadr (assoc 'pcl-method-class dlist)))
+	 (doc (cadr (assoc 'pcl-documentation dlist)))
+	 (plist (cadr (assoc 'pcl-plist dlist))))
+    (load-defmethod (or class 'standard-method)
+		    gspec
+		    qualifiers
+		    specializers
+		    (arglist fn)
+		    doc
+		    (getf plist :isl-cache-symbol)
+		    plist
+		    fn)))
+
+
+;; define a few special declarations to get pushed onto the function's debug-info
+;; list... note that we do not need to do a (proclaim (declarations ...)) here.
+;;
+(eval-when (compile load eval)
+  (setf (get 'pcl-plist 'si:debug-info) t)
+  (setf (get 'pcl-documentation 'si:debug-info) t)
+  (setf (get 'pcl-method-class 'si:debug-info) t)
+  (setf (get 'pcl-lambda-list 'si:debug-info) t)
+)
+
+(eval-when (load eval)
+  (setf
+    (get 'defmethod      'zwei:definition-function-spec-type) 'defun
+    (get 'defmethod-setf 'zwei:definition-function-spec-type) 'defun
+    (get 'method 'si:definition-type-name) "method"
+    (get 'method 'si:definition-type-name) "method"
+
+    (get 'declass 'zwei:definition-function-spec-type) 'defclass
+    (get 'defclass 'si:definition-type-name) "Class"
+    (get 'defclass 'zwei:definition-function-spec-finder-template) '(0 1))
+  )
+
+;;;
+;;; The variable zwei::*sectionize-line-lookahead* controls how many lines the parser
+;;;  is willing to look ahead while trying to parse a definition.  Even 2 lines is enough
+;;;  for just about all cases, but there isn't much overhead, and 10 should be enough
+;;;  to satisfy pretty much everyone... but feel free to change it.
+;;;        - MT 880921
+;;;
+zwei:
+(defvar *sectionize-line-lookahead* 3)
+
+zwei:
+(DEFMETHOD (:SECTIONIZE-BUFFER MAJOR-MODE :DEFAULT)
+	   (FIRST-BP LAST-BP BUFFER STREAM INT-STREAM ADDED-COMPLETIONS)
+  ADDED-COMPLETIONS ;ignored, obsolete
+  (WHEN STREAM
+    (SEND-IF-HANDLES STREAM :SET-RETURN-DIAGRAMS-AS-LINES T))
+  (INCF *SECTIONIZE-BUFFER*)
+  (LET ((BUFFER-TICK (OR (SEND-IF-HANDLES BUFFER :SAVE-TICK) *TICK*))
+	OLD-CHANGED-SECTIONS)
+    (TICK)
+    ;; Flush old section nodes.  Also collect the names of those that are modified, they are
+    ;; the ones that will be modified again after a revert buffer.
+    (DOLIST (NODE (NODE-INFERIORS BUFFER))
+      (AND (> (NODE-TICK NODE) BUFFER-TICK)
+	   (PUSH (LIST (SECTION-NODE-FUNCTION-SPEC NODE)
+		       (SECTION-NODE-DEFINITION-TYPE NODE))
+		 OLD-CHANGED-SECTIONS))
+      (FLUSH-BP (INTERVAL-FIRST-BP NODE))
+      (FLUSH-BP (INTERVAL-LAST-BP NODE)))
+    (DO ((LINE (BP-LINE FIRST-BP) (LINE-NEXT INT-LINE))
+	 (LIMIT (BP-LINE LAST-BP))
+	 (EOFFLG)
+	 (ABNORMAL T)
+	 (DEFINITION-LIST NIL)
+	 (BP (COPY-BP FIRST-BP))
+	 (FUNCTION-SPEC)
+	 (DEFINITION-TYPE)
+	 (STR)
+	 (INT-LINE)
+	 (first-time t)
+	 (future-line)				; we actually read into future line
+	 (future-int-line)
+	 (PREV-NODE-START-BP FIRST-BP)
+	 (PREV-NODE-DEFINITION-LINE NIL)
+	 (PREV-NODE-FUNCTION-SPEC NIL)
+	 (PREV-NODE-TYPE 'HEADER)
+	 (PREVIOUS-NODE NIL)
+	 (NODE-LIST NIL)
+	 (STATE (SEND SELF :INITIAL-SECTIONIZATION-STATE)))
+	(NIL)
+      ;; If we have a stream, read another line.
+      (when (AND STREAM (NOT EOFFLG))
+	(let ((lookahead (if future-line 1 *sectionize-line-lookahead*)))
+	  (dotimes (i lookahead)		; startup lookahead
+	    (MULTIPLE-VALUE (future-LINE EOFFLG)
+	      (LET ((DEFAULT-CONS-AREA *LINE-AREA*))
+		(SEND STREAM ':LINE-IN LINE-LEADER-SIZE)))
+	    (IF future-LINE (SETQ future-INT-LINE (FUNCALL INT-STREAM ':LINE-OUT future-LINE)))
+	    (when first-time
+	      (setq first-time nil)
+	      (setq line future-line)
+	      (setq int-line future-int-line))
+	    (when eofflg
+	      (return)))))
+
+      (SETQ INT-LINE LINE)
+
+      (when int-line
+	(MOVE-BP BP INT-LINE 0))		;Record as potentially start-bp for a section
+
+      ;; See if the line is the start of a defun.
+      (WHEN (AND LINE
+		 (LET (ERR)
+		   (MULTIPLE-VALUE (FUNCTION-SPEC DEFINITION-TYPE STR ERR STATE)
+		     (SEND SELF ':SECTION-NAME INT-LINE BP STATE))
+		   (NOT ERR)))
+	(PUSH (LIST FUNCTION-SPEC DEFINITION-TYPE) DEFINITION-LIST)
+	(SECTION-COMPLETION FUNCTION-SPEC STR NIL)
+	;; List methods under both names for user ease.
+	(LET ((OTHER-COMPLETION (SEND SELF ':OTHER-SECTION-NAME-COMPLETION
+				      FUNCTION-SPEC INT-LINE)))
+	  (WHEN OTHER-COMPLETION
+	    (SECTION-COMPLETION FUNCTION-SPEC OTHER-COMPLETION NIL)))
+	(LET ((PREV-NODE-END-BP (BACKWARD-OVER-COMMENT-LINES BP ':FORM-AS-BLANK)))
+	  ;; Don't make a section node if it's completely empty.  This avoids making
+	  ;; a useless Buffer Header section node. Just set all the PREV variables
+	  ;; so that the next definition provokes the *right thing*
+	  (UNLESS (BP-= PREV-NODE-END-BP PREV-NODE-START-BP)
+	    (SETQ PREVIOUS-NODE
+		  (ADD-SECTION-NODE PREV-NODE-START-BP
+				    (SETQ PREV-NODE-START-BP PREV-NODE-END-BP)
+				    PREV-NODE-FUNCTION-SPEC PREV-NODE-TYPE
+				    PREV-NODE-DEFINITION-LINE BUFFER PREVIOUS-NODE
+				    (IF (LOOP FOR (FSPEC TYPE) IN OLD-CHANGED-SECTIONS
+					      THEREIS (AND (EQ PREV-NODE-FUNCTION-SPEC FSPEC)
+							   (EQ PREV-NODE-TYPE TYPE)))
+					*TICK* BUFFER-TICK)
+				    BUFFER-TICK))
+	    (PUSH PREVIOUS-NODE NODE-LIST)))
+	(SETQ PREV-NODE-FUNCTION-SPEC FUNCTION-SPEC
+	      PREV-NODE-TYPE DEFINITION-TYPE
+	      PREV-NODE-DEFINITION-LINE INT-LINE))
+      ;; After processing the last line, exit.
+      (WHEN (OR #+ignore EOFFLG (null line) (AND (NULL STREAM) (EQ LINE LIMIT)))
+	;; If reading a stream, we should not have inserted a CR
+	;; after the eof line.
+	(WHEN STREAM
+	  (DELETE-INTERVAL (FORWARD-CHAR LAST-BP -1 T) LAST-BP T))
+	;; The rest of the buffer is part of the last node
+	(UNLESS (SEND SELF ':SECTION-NAME-TRIVIAL-P)
+	  ;; ---oh dear, what sort of section will this be? A non-empty HEADER
+	  ;; ---node.  Well, ok for now.
+	  (PUSH (ADD-SECTION-NODE PREV-NODE-START-BP LAST-BP
+				  PREV-NODE-FUNCTION-SPEC PREV-NODE-TYPE
+				  PREV-NODE-DEFINITION-LINE BUFFER PREVIOUS-NODE
+				  (IF (LOOP FOR (FSPEC TYPE) IN OLD-CHANGED-SECTIONS
+					    THEREIS (AND (EQ PREV-NODE-FUNCTION-SPEC FSPEC)
+							 (EQ PREV-NODE-TYPE TYPE)))
+				      *TICK* BUFFER-TICK)
+				  BUFFER-TICK)
+		NODE-LIST)
+	  (SETF (LINE-NODE (BP-LINE LAST-BP)) (CAR NODE-LIST)))
+	(SETF (NODE-INFERIORS BUFFER) (NREVERSE NODE-LIST))
+	(SETF (NAMED-BUFFER-WITH-SECTIONS-FIRST-SECTION BUFFER) (CAR (NODE-INFERIORS BUFFER)))
+	(SETQ ABNORMAL NIL)			;timing windows here
+	;; Speed up completion if enabled.
+	(WHEN SI:*ENABLE-AARRAY-SORTING-AFTER-LOADS*
+	  (SI:SORT-AARRAY *ZMACS-COMPLETION-AARRAY*))
+	(SETQ *ZMACS-COMPLETION-AARRAY*
+	      (FOLLOW-STRUCTURE-FORWARDING *ZMACS-COMPLETION-AARRAY*))
+	(RETURN
+	  (VALUES 
+	    (CL:SETF (ZMACS-SECTION-LIST BUFFER)
+		     (NREVERSE DEFINITION-LIST))
+	    ABNORMAL))))))
+
+(defun (:property defmethod zwei::definition-function-spec-parser) (bp)
+  (zwei:parse-pcl-defmethod-for-zwei bp nil))
+
+;;;
+;;; Previously, if a source file in a PCL-based package contained what looks
+;;; like flavor defmethod forms (i.e. an (IN-PACKAGE 'non-pcl-package) form
+;;; appears at top level, and then a flavor-style defmethod form) appear, the
+;;; parser would break.
+;;;
+;;; Now, if we can't parse the defmethod form, we send it to the flavor
+;;; defmethod parser instead.
+;;; 
+;;; Also now supports multi-line arglist sectionizing.
+;;;
+zwei:
+(defun parse-pcl-defmethod-for-zwei (bp-after-defmethod setfp)
+  (block parser
+    (flet ((barf (&optional (error t))
+	     (return-from parser
+	       (cond ((eq error :flavor)
+		      (funcall (get 'flavor:defmethod
+				    'zwei::definition-function-spec-parser)
+			       bp-after-defmethod))
+		     (t
+		      (values nil nil nil error))))))
+      (let ((bp-after-generic (forward-sexp bp-after-defmethod))
+	    (qualifiers ())
+	    (specializers ())
+	    (spec nil)
+	    (ignore1 nil)
+	    (ignore2 nil))
+	(when bp-after-generic
+	  (multiple-value-bind (generic error-p)
+	      (read-fspec-item-from-interval bp-after-defmethod
+					     bp-after-generic)
+	    (if error-p
+		(barf)				; error here is really bad.... BARF!
+		(progn
+		  (when (listp generic)
+		    (if (and (symbolp (car generic))
+			     (string-equal (cl:symbol-name (car generic)) "SETF"))
+			(setq generic (second generic)	; is a (setf xxx) form
+			      setfp t)
+			(barf :flavor)))	; make a last-ditch-effort with flavor parser
+		  (let* ((bp1 bp-after-generic)
+			 (bp2 (forward-sexp bp1)))
+		      (cl:loop
+			 (if (null bp2)
+			     (barf :more)	; item not closed - need another line!
+			     (multiple-value-bind (item error-p)
+				 (read-fspec-item-from-interval bp1 bp2)
+			       (cond (error-p (barf))	;
+				     ((listp item)
+				      (setq qualifiers (nreverse qualifiers))
+				      (cl:multiple-value-setq (ignore1
+								ignore2
+								specializers)
+					(pcl::parse-specialized-lambda-list item))
+				      (setq spec (pcl::make-method-spec 
+						   (if setfp
+						       `(cl:setf ,generic)
+						       generic)
+						   qualifiers
+						   specializers))
+				      (return (values spec
+						      'defun
+						      (string-interval
+							bp-after-defmethod
+							bp2))))
+				     (t (push item qualifiers)
+					(setq bp1 bp2
+					      bp2 (forward-sexp bp2))))))))))))))))
+
+zwei:
+(progn
+  (defun indent-clos-defmethod (ignore bp defmethod-paren &rest ignore)
+    (let ((here
+	    (forward-over *whitespace-chars* (forward-word defmethod-paren))))
+      (loop until (char-equal (bp-char here) #\()
+	    do (setf here
+		     (forward-over *whitespace-chars* (forward-sexp here))))
+      (if (bp-< here bp)
+	  (values defmethod-paren nil 2)
+	  (values defmethod-paren nil 4))))
+  
+  (defindentation (pcl::defmethod . indent-clos-defmethod)))
+
+;;;
+;;; Teach zwei that when it gets the name of a generic function as an argument
+;;; it should edit all the methods of that generic function.  This works for
+;;; ED as well as meta-point.
+;;;
+(zl:advise (flavor:method :SETUP-FUNCTION-SPECS-TO-EDIT zwei:ZMACS-EDITOR)
+	   :around
+	   setup-function-specs-to-edit-advice
+	   ()
+  (let ((old-definitions (cadddr arglist))
+	(new-definitions ())
+	(new nil))
+    (dolist (old old-definitions)
+      (setq new (setup-function-specs-to-edit-advice-1 old))
+      (push (or new (list old)) new-definitions))
+    (setf (cadddr arglist) (apply #'append (reverse new-definitions)))
+    :do-it))
+
+(defun setup-function-specs-to-edit-advice-1 (spec)
+  (and (or (symbolp spec)
+	   (and (listp spec) (eq (car spec) 'setf)))
+       (gboundp spec)
+       (generic-function-p (gdefinition spec))
+       (mapcar #'(lambda (m)
+		   (make-method-spec spec
+				     (method-qualifiers m)
+				     (unparse-specializers
+				       (method-specializers m))))
+	       (generic-function-methods (gdefinition spec)))))
+
diff --git a/pcl/get-pcl.text b/pcl/get-pcl.text
new file mode 100644
index 0000000000000000000000000000000000000000..7cab9dcd357a124a820734c9efcb802c08d1eab0
--- /dev/null
+++ b/pcl/get-pcl.text
@@ -0,0 +1,179 @@
+Here is the standard information about PCL.  I have also added you to
+the CommonLoops@Xerox.com mailing list.
+
+Portable CommonLoops (PCL) started out as an implementation of
+CommonLoops written entirely in CommonLisp.  It is in the process of
+being converted to an implementation of CLOS.  Currently it implements a
+only a subset of the CLOS specification.  Unfortunately, there is no
+detailed description of the differences between PCL and the CLOS
+specification, the source code is often the best documentation.
+
+  Currently, PCL runs in the following implementations of
+  Common Lisp:
+
+   EnvOS Medley
+   Symbolics (Release 7.2)
+   Lucid (3.0)
+   ExCL (Franz Allegro 3.0.1)
+   KCL (June 3, 1987)
+   AKCL (1.86, June 30, 1987)
+   Ibuki Common Lisp (01/01, October 15, 1987)
+   TI (Release 4.1)
+   Coral Common Lisp (Allegro 1.2)
+   Golden Common Lisp (3.1)
+   CMU
+   VAXLisp (2.0)
+   HP Common Lisp
+   Pyramid Lisp
+
+There are several ways of obtaining a copy of PCL.
+
+*** Arpanet Access to PCL ***
+
+The primary way of getting PCL is by Arpanet FTP.
+
+The files are stored on arisia.xerox.com.  You can copy them using
+anonymous FTP (username "anonymous", password "anonymous"). There are
+several directories which are of interest:
+
+/pcl
+
+This directory contains the PCL sources as well as some rudimentary
+documentation (including this file).  All of these files are combined
+into a single Unix TAR file.  The name of this file is "tarfile".
+
+Extract the individual files from this tarfile by saying:
+
+tar -xf tarfile *
+
+where `tarfile' is the name you have given the tarfile in your
+directory.  Once you have done this, the following files are of special
+interest:
+
+readme.text   READ IT
+
+notes.text    contains notes about the current state of PCL, and some
+              instructions for installing PCL at your site.  You should
+              read this file whenever you get a new version of PCL.
+
+get-pcl.text  contains the latest draft of this message
+
+
+/pcl/doc
+
+This directory contains TeX source files for the most recent draft of
+the CLOS specification.  There are TeX source files for two documents
+called concep.tex and functi.tex.  These correspond to chapter 1 and 2
+of the CLOS specification.
+
+
+/pcl/archive
+
+This directory contains the joint archives of two important mailings
+lists:
+
+  CommonLoops@Xerox.com
+
+    is the mailing list for all PCL users.  It carries announcements
+    of new releases of PCL, bug reports and fixes, and general advice
+    about how to use PCL and CLOS.
+
+  Common-Lisp-Object-System@Sail.Stanford.edu
+
+    is a small mailing list used by the designers of CLOS.
+
+The file cloops.text is always the newest of the archive files.
+
+The file cloops1.text is the oldest of the archive files.  Higher
+numbered versions are more recent versions of the files.
+
+*** Getting PCL on Macintosh floppies *** 
+
+PCL is listed in APDAlog.  It is distributed on Macintosh floppies.
+This makes it possible for people who don't have FTP access to arisia
+(but who do have a Macintosh) to get PCL.
+
+For $40 you receive a version of PCL and a copy of the CLOS spec (X3J13
+document number 88-002R).  The APDAlog catalog number is T0259LL/A and
+you can order by calling:
+
+  From the U.S.   (800)282-2732
+  From Canada     (800)637-0029
+  International   (408)562-3910
+  FAX             (408)562-3971
+
+
+NOTE:  Whenever there is a new release of PCL you want, you should
+probably wait a couple of months before ordering it from APDAlog.  We
+want to let new PCL's stabilize a bit before sending it to them, and it
+will take them some time to integrate the new disks into their
+distribution.
+
+*** Using the BITFTP server at Princeton ***
+
+For people who can't FTP from Internet (Arpanet) hosts, but who have
+mail access to the BITNET, there exists a way to get the PCL files using
+the BITFTP service provided by Princeton Univerity.  If you know exactly
+where to find the files that interest you, this is quite easy.  In
+particular, you have to know:
+
+ * the Internet host name of the host that maintains the files (such
+   as `arisia.Xerox.COM')
+ * the directory where to find the files, relative to the root of the
+   FTP tree (i.E. `pub')
+ * whether the files are binary or ASCII text.
+ * the names of the files (say `pcl90.tar.Z' and `pcl90.README')
+
+To do this, send a message to BITFTP@PUCC (or BITFTP@PUCC.BITNET if you
+aren't on BITNET itself).  The subject line of the message will be
+ignored.  The text (body) of the message should be:
+
+        FTP arisia.xerox.com UUENCODE
+        CD pcl
+        BINARY
+        GET tarfile
+        QUIT
+
+Then you wait (probably for about a day when you are in Europe) and
+eventually you will receive E-Mail messages from BITFTP@PUCC (or
+BITFTP2%PUCC...) with subject lines like `uudecoded file tarfile part
+13'.  Then you have to carefully concatenate the contents of ALL of
+these files in the correct order.
+
+  Note: The following works on our Suns and should work on any
+  Berkeley UNIX machine.  If you don't have the `compress' or `zcat'
+  program, you can get a free version (with MIT's X Window System
+  distribution, for example).
+
+The resulting file can be `uudecode'd like this:
+
+        dagobert% uudecode name-of-the-assembled-file
+
+This will give you a file tarfile.Z (it may actually have a different
+name; then you may want to rename it in the first place).  The `.Z' at
+the end means that the file you now have is compressed.  You can
+uncompress it with `uncompress tarfile.  You can untar the uncompressed
+file with `tar -xvf tarfile'.
+
+This will write all files in the tarfile to the current directory.
+
+If you want to know more about the BITFTP service, send a letter to
+`BITFTP@PUCC' that contains the single line `HELP'.
+
+*** Xerox Internet Access to PCL ***
+
+Xerox XNS users can get PCL from {NB:PARC:XEROX}<PCL>
+
+
+
+Send any comments, bug-reports or suggestions for improvements to:
+
+   CommonLoops.pa@Xerox.com
+
+Send mailing list requests or other administrative stuff to:
+
+  CommonLoops-Request@Xerox.com
+
+
+Thanks for your interest in PCL.
+----------
diff --git a/pcl/gold-low.lisp b/pcl/gold-low.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..bc20f0a0f5696b8ced1963cc885d83230e44300e
--- /dev/null
+++ b/pcl/gold-low.lisp
@@ -0,0 +1,49 @@
+;;;-*-Mode:LISP; Package:(PCL Lisp 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+;;;
+;;; 
+
+(in-package 'pcl)
+
+;;; fix a bug in gcl macro-expander (or->cond->or->cond->...)
+(setf (get 'cond 'lisp::macro-expander) nil)
+
+;;; fix another bug in gcl3_0 case macro-expander
+(defun lisp::eqv (a b) (eql a b))
+
+(defun printing-random-thing-internal (thing stream)
+  (multiple-value-bind (offaddr baseaddr)
+      (sys:%pointer thing)
+    (princ baseaddr stream)
+    (princ ", " stream)
+    (princ offaddr stream)))
+
+;;;
+;;; This allows the compiler to compile a file with many "DEFMETHODS"
+;;; in succession.
+;;;
+(dolist (x '(defmethod defgeneric defclass precompile-random-code-segments))
diff --git a/pcl/hp-low.lisp b/pcl/hp-low.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..5e8dd76af48f16d03973c95b4df52b17833cb510
--- /dev/null
+++ b/pcl/hp-low.lisp
@@ -0,0 +1,36 @@
+;;; -*- Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;; 
+;;; This is the HP Common Lisp version of the file low.
+;;;
+;;; 
+
+(in-package 'pcl)
+
+(defun printing-random-thing-internal (thing stream)
+  (format stream "~O" (prim:@inf thing)))
+
+
diff --git a/pcl/ibcl-low.lisp b/pcl/ibcl-low.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..ed7b21b11e2fc228050c704d4df74a39e072d8dc
--- /dev/null
+++ b/pcl/ibcl-low.lisp
@@ -0,0 +1,326 @@
+;;;-*-Mode:LISP; Package:(PCL Lisp 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+;;; The version of low for Kyoto Common Lisp (KCL)
+(in-package 'pcl)
+
+;;;
+;;; The reason these are here is because the KCL compiler does not allow
+;;; LET to return FIXNUM values as values of (c) type int, hence the use
+;;; of LOCALLY (which expands into (LET () (DECLARE ...) ...)) forces
+;;; conversion of ints to objects.
+;;; 
+(defmacro %logand (&rest args)
+  (reduce-variadic-to-binary 'logand args 0 t 'fixnum))
+
+;(defmacro %logxor (&rest args)
+;  (reduce-variadic-to-binary 'logxor args 0 t 'fixnum))
+
+(defmacro %+ (&rest args)
+  (reduce-variadic-to-binary '+ args 0 t 'fixnum))
+
+;(defmacro %- (x y)
+;  `(the fixnum (- (the fixnum ,x) (the fixnum ,y))))
+
+(defmacro %* (&rest args)
+  (reduce-variadic-to-binary '* args 1 t 'fixnum))
+
+(defmacro %/ (x y)
+  `(the fixnum (/ (the fixnum ,x) (the fixnum ,y))))
+
+(defmacro %1+ (x)
+  `(the fixnum (1+ (the fixnum ,x))))
+
+(defmacro %1- (x)
+  `(the fixnum (1- (the fixnum ,x))))
+
+(defmacro %svref (vector index)
+  `(svref (the simple-vector ,vector) (the fixnum ,index)))
+
+(defsetf %svref (vector index) (new-value)
+  `(setf (svref (the simple-vector ,vector) (the fixnum ,index))
+         ,new-value))
+
+
+;;;
+;;; std-instance-p
+;;;
+(si:define-compiler-macro std-instance-p (x)
+  (once-only (x)
+    `(and (si:structurep ,x)
+	  (eq (si:structure-name ,x) 'std-instance))))
+
+(dolist (inline '((si:structurep
+		    ((t) compiler::boolean nil nil "type_of(#0)==t_structure")
+		    compiler::inline-always)
+		  (si:structure-name
+		    ((t) t nil nil "(#0)->str.str_name")
+		    compiler::inline-unsafe)))
+  (setf (get (first inline) (third inline)) (list (second inline))))
+
+(setf (get 'cclosure-env 'compiler::inline-always)
+      (list '((t) t nil nil "(#0)->cc.cc_env")))
+
+;;;
+;;; turbo-closure patch.  See the file kcl-mods.text for details.
+;;;
+#+:turbo-closure
+(progn
+(CLines
+  "object tc_cc_env_nthcdr (n,tc)"
+  "object n,tc;                        "
+  "{return (type_of(tc)==t_cclosure&&  "
+  "         tc->cc.cc_turbo!=NULL&&    "
+  "         type_of(n)==t_fixnum)?     "
+  "         tc->cc.cc_turbo[fix(n)]:   " ; assume that n is in bounds
+  "         Cnil;                      "
+  "}                                   "
+  )
+
+(defentry tc-cclosure-env-nthcdr (object object) (object tc_cc_env_nthcdr))
+
+(setf (get 'tc-cclosure-env-nthcdr 'compiler::inline-unsafe)
+      '(((fixnum t) t nil nil "(#1)->cc.cc_turbo[#0]")))
+)
+
+
+;;;; low level stuff to hack compiled functions and compiled closures.
+;;;
+;;; The primary client for this is fsc-low, but since we make some use of
+;;; it here (e.g. to implement set-function-name-1) it all appears here.
+;;;
+
+(eval-when (compile eval)
+
+(defmacro define-cstruct-accessor (accessor structure-type field value-type
+					    field-type tag-name)
+  (let ((setf (intern (concatenate 'string "SET-" (string accessor))))
+	(caccessor (format nil "pcl_get_~A_~A" structure-type field))
+	(csetf     (format nil "pcl_set_~A_~A" structure-type field))
+	(vtype (intern (string-upcase value-type))))
+    `(progn
+       (CLines ,(format nil "~A ~A(~A)                ~%~
+                             object ~A;               ~%~
+                             { return ((~A) ~A->~A.~A); }       ~%~
+                                                      ~%~
+                             ~A ~A(~A, new)           ~%~
+                             object ~A;               ~%~
+                             ~A new;                  ~%~
+                             { return ((~A)(~A->~A.~A = ~Anew)); } ~%~
+                            "
+			value-type caccessor structure-type 
+			structure-type
+			value-type structure-type tag-name field
+			value-type csetf structure-type
+			structure-type 
+			value-type 
+			value-type structure-type tag-name field field-type
+			))
+
+       (defentry ,accessor (object) (,vtype ,caccessor))
+       (defentry ,setf (object ,vtype) (,vtype ,csetf))
+
+
+       (defsetf ,accessor ,setf)
+
+       )))
+)
+;;; 
+;;; struct cfun {                   /*  compiled function header  */
+;;;         short   t, m;
+;;;         object  cf_name;        /*  compiled function name  */
+;;;         int     (*cf_self)();   /*  entry address  */
+;;;         object  cf_data;        /*  data the function uses  */
+;;;                                 /*  for GBC  */
+;;;         char    *cf_start;      /*  start address of the code  */
+;;;         int     cf_size;        /*  code size  */
+;;; };
+;;; add field-type tag-name
+(define-cstruct-accessor cfun-name  "cfun" "cf_name"  "object" "(object)" "cf")
+(define-cstruct-accessor cfun-self  "cfun" "cf_self"  "int" "(int (*)())" 
+                         "cf")
+(define-cstruct-accessor cfun-data  "cfun" "cf_data"  "object" "(object)" "cf")
+(define-cstruct-accessor cfun-start "cfun" "cf_start" "int" "(char *)" "cf")
+(define-cstruct-accessor cfun-size  "cfun" "cf_size"  "int" "(int)" "cf")
+
+(CLines
+  "object pcl_cfunp (x)              "
+  "object x;                         "
+  "{if(x->c.t == (int) t_cfun)       "
+  "  return (Ct);                    "
+  "  else                            "
+  "    return (Cnil);                "
+  "  }                               "
+  )
+
+(defentry cfunp (object) (object pcl_cfunp))
+
+;;; 
+;;; struct cclosure {               /*  compiled closure header  */
+;;;         short   t, m;
+;;;         object  cc_name;        /*  compiled closure name  */
+;;;         int     (*cc_self)();   /*  entry address  */
+;;;         object  cc_env;         /*  environment  */
+;;;         object  cc_data;        /*  data the closure uses  */
+;;;                                 /*  for GBC  */
+;;;         char    *cc_start;      /*  start address of the code  */
+;;;         int     cc_size;        /*  code size  */
+;;; };
+;;; 
+(define-cstruct-accessor cclosure-name "cclosure"  "cc_name"  "object"
+                         "(object)" "cc")          
+(define-cstruct-accessor cclosure-self "cclosure"  "cc_self"  "int" 
+                         "(int (*)())" "cc")
+(define-cstruct-accessor cclosure-data "cclosure"  "cc_data"  "object"
+                          "(object)" "cc")
+(define-cstruct-accessor cclosure-start "cclosure" "cc_start" "int" 
+                         "(char *)" "cc")
+(define-cstruct-accessor cclosure-size "cclosure"  "cc_size"  "int"
+			 "(int)" "cc")
+(define-cstruct-accessor cclosure-env "cclosure"   "cc_env"   "object"
+                         "(object)" "cc")
+
+
+(CLines
+  "object pcl_cclosurep (x)          "
+  "object x;                         "
+  "{if(x->c.t == (int) t_cclosure)   "
+  "  return (Ct);                    "
+  "  else                            "
+  "   return (Cnil);                 "
+  "  }                               "
+  )
+
+(defentry cclosurep (object) (object pcl_cclosurep))
+
+  ;;   
+;;;;;; Load Time Eval
+  ;;
+;;; 
+
+;;; This doesn't work because it looks at a global variable to see if it is
+;;; in the compiler rather than looking at the macroexpansion environment.
+;;; 
+;;; The result is that if in the process of compiling a file, we evaluate a
+;;; form that has a call to load-time-eval, we will get faked into thinking
+;;; that we are compiling that form.
+;;;
+;;; THIS NEEDS TO BE DONE RIGHT!!!
+;;; 
+;(defmacro load-time-eval (form)
+;  ;; In KCL there is no compile-to-core case.  For things that we are 
+;  ;; "compiling to core" we just expand the same way as if were are
+;  ;; compiling a file since the form will be evaluated in just a little
+;  ;; bit when gazonk.o is loaded.
+;  (if (and (boundp 'compiler::*compiler-input*)  ;Hack to see of we are
+;	   compiler::*compiler-input*)		  ;in the compiler!
+;      `'(si:|#,| . ,form)
+;      `(progn ,form)))
+
+(defmacro load-time-eval (form)
+  (read-from-string (format nil "'#,~S" form)))
+
+(defmacro memory-block-ref (block offset)
+  `(svref (the simple-vector ,block) (the fixnum ,offset)))
+
+  ;;   
+;;;;;; Generating CACHE numbers
+  ;;
+;;; This needs more work to be sure it is going as fast as possible.
+;;;   -  The calls to si:address should be open-coded.
+;;;   -  The logand should be open coded.
+;;;   
+
+;(defmacro symbol-cache-no (symbol mask)
+;  (if (and (constantp symbol)
+;	   (constantp mask))
+;      `(load-time-eval (logand (ash (si:address ,symbol) -2) ,mask))
+;      `(logand (ash (the fixnum (si:address ,symbol)) -2) ,mask)))
+
+(defmacro object-cache-no (object mask)
+  `(logand (the fixnum (si:address ,object)) ,mask))
+
+  ;;   
+;;;;;; printing-random-thing-internal
+  ;;
+(defun printing-random-thing-internal (thing stream)
+  (format stream "~O" (si:address thing)))
+
+
+(defun set-function-name-1 (fn new-name ignore)
+  (cond ((cclosurep fn)
+	 (setf (cclosure-name fn) new-name))
+	((cfunp fn)
+	 (setf (cfun-name fn) new-name))
+	((and (listp fn)
+	      (eq (car fn) 'lambda-block))
+	 (setf (cadr fn) new-name))
+	((and (listp fn)
+	      (eq (car fn) 'lambda))
+	 (setf (car fn) 'lambda-block
+	       (cdr fn) (cons new-name (cdr fn)))))
+  fn)
+
+
+
+
+#|
+(defconstant most-positive-small-fixnum 1024)  /* should be supplied */
+(defconstant most-negative-small-fixnum -1024) /* by ibuki */
+
+(defmacro symbol-cache-no (symbol mask)
+  (if (constantp mask)
+      (if (and (> mask 0)
+	       (< mask most-positive-small-fixnum))
+	  (if (constantp symbol)
+	      `(load-time-eval (coffset ,symbol ,mask 2))
+	    `(coffset ,symbol ,mask 2))
+	(if (constantp symbol)
+	    `(load-time-eval 
+	       (logand (ash (the fixnum (si:address ,symbol)) -2) ,mask))
+	  `(logand (ash (the fixnum (si:address ,symbol)) -2) ,mask)))
+    `(logand (ash (the fixnum (si:address ,symbol)) -2) ,mask)))
+
+
+(defmacro object-cache-no (object mask)
+  (if (and (constantp mask)
+	   (> mask 0)
+	   (< mask most-positive-small-fixnum))
+      `(coffset ,object ,mask 4)
+    `(logand (ash (the fixnum (si:address ,object)) -4) ,mask)))
+
+(CLines
+  "object pcl_coffset (sym,mask,lshift)"
+  "object sym,mask,lshift;"
+  "{"
+  "	return(small_fixnum(((int)sym >> fix(lshift)) & fix(mask)));"
+  "}"
+  )
+
+(defentry coffset (object object object) (object pcl_coffset))
+
+
+|#
diff --git a/pcl/ibcl-patches.lisp b/pcl/ibcl-patches.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..a1d0eaa0f1bf8a31876b09a44e49b5c3bc5b0de5
--- /dev/null
+++ b/pcl/ibcl-patches.lisp
@@ -0,0 +1,128 @@
+;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+
+(in-package 'system)
+
+;;;   This makes DEFMACRO take &WHOLE and &ENVIRONMENT args anywhere
+;;;   in the lambda-list.  The former allows deviation from the CL spec,
+;;;   but what the heck.
+
+(eval-when (compile) (proclaim '(optimize (safety 2) (space 3))))
+
+(defvar *old-defmacro*)
+
+(defun new-defmacro (whole env)
+  (flet ((call-old-definition (new-whole)
+	   (funcall *old-defmacro* new-whole env)))
+    (if (not (and (consp whole)
+		  (consp (cdr whole))
+		  (consp (cddr whole))
+		  (consp (cdddr whole))))
+	(call-old-definition whole)
+	(let* ((ll (caddr whole))
+	       (env-tail (do ((tail ll (cdr tail)))
+			     ((not (consp tail)) nil)
+			   (when (eq '&environment (car tail))
+			     (return tail)))))
+	  (if env-tail
+	      (call-old-definition (list* (car whole)
+					  (cadr whole)
+					  (append (list '&environment
+							(cadr env-tail))
+						  (ldiff ll env-tail)
+						  (cddr env-tail))
+					  (cdddr whole)))
+	      (call-old-definition whole))))))
+
+(eval-when (load eval)
+  (unless (boundp '*old-defmacro*)
+    (setq *old-defmacro* (macro-function 'defmacro))
+    (setf (macro-function 'defmacro) #'new-defmacro)))
+
+;;;
+;;; setf patches
+;;;
+
+(in-package 'system)
+
+(defun get-setf-method (form)
+  (multiple-value-bind (vars vals stores store-form access-form)
+      (get-setf-method-multiple-value form)
+    (unless (listp vars)
+	    (error 
+ "The temporary variables component, ~s, 
+  of the setf-method for ~s is not a list."
+             vars form))
+    (unless (listp vals)
+	    (error 
+ "The values forms component, ~s, 
+  of the setf-method for ~s is not a list."
+             vals form))
+    (unless (listp stores)
+	    (error 
+ "The store variables component, ~s,  
+  of the setf-method for ~s is not a list."
+             stores form))
+    (unless (= (list-length stores) 1)
+	    (error "Multiple store-variables are not allowed."))
+    (values vars vals stores store-form access-form)))
+
+(defun get-setf-method-multiple-value (form)
+  (cond ((symbolp form)
+	 (let ((store (gensym)))
+	   (values nil nil (list store) `(setq ,form ,store) form)))
+	((or (not (consp form)) (not (symbolp (car form))))
+	 (error "Cannot get the setf-method of ~S." form))
+	((get (car form) 'setf-method)
+	 (apply (get (car form) 'setf-method) (cdr form)))
+	((get (car form) 'setf-update-fn)
+	 (let ((vars (mapcar #'(lambda (x)
+	                         (declare (ignore x))
+	                         (gensym))
+	                     (cdr form)))
+	       (store (gensym)))
+	   (values vars (cdr form) (list store)
+	           `(,(get (car form) 'setf-update-fn)
+		     ,@vars ,store)
+		   (cons (car form) vars))))
+	((get (car form) 'setf-lambda)
+	 (let* ((vars (mapcar #'(lambda (x)
+	                          (declare (ignore x))
+	                          (gensym))
+	                      (cdr form)))
+		(store (gensym))
+		(l (get (car form) 'setf-lambda))
+		(f `(lambda ,(car l) 
+		      (funcall #'(lambda ,(cadr l) ,@(cddr l))
+			       ',store))))
+	   (values vars (cdr form) (list store)
+		   (apply f vars)
+		   (cons (car form) vars))))
+	((macro-function (car form))
+	 (get-setf-method-multiple-value (macroexpand-1 form)))
+	(t
+	 (error "Cannot expand the SETF form ~S." form))))
diff --git a/pcl/init.lisp b/pcl/init.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..ab52f805f40d0ed7c7c04cc199e33fa795bc13db
--- /dev/null
+++ b/pcl/init.lisp
@@ -0,0 +1,206 @@
+;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+;;;
+;;; This file defines the initialization and related protocols.
+;;; 
+
+(in-package 'pcl)
+
+(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 (eq *boot-state* 'complete)
+      (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 ()
+		 ((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 '())
+	(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 ())))))
+  (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 ()
+		 ;; 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 ()
+		 ;; 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)))))))
diff --git a/pcl/iterate.lisp b/pcl/iterate.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..ee60756e1d51695e0ef34bdbb1e3b5a8b5a713bc
--- /dev/null
+++ b/pcl/iterate.lisp
@@ -0,0 +1,1266 @@
+;;;-*- Package: ITERATE; Syntax: Common-Lisp; Base: 10 -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;; 
+;;; Original source {pooh/n}<pooh>vanmelle>lisp>iterate;4 created 27-Sep-88 12:35:33
+
+(in-package :iterate :use '(:lisp :walker))
+   
+
+(export '(iterate iterate* gathering gather with-gathering interval elements 
+                list-elements list-tails plist-elements eachtime while until 
+                collecting joining maximizing minimizing summing 
+                *iterate-warnings*))
+
+(defvar *iterate-warnings* :any "Controls whether warnings are issued for iterate/gather forms that aren't optimized.
+NIL => never; :USER => those resulting from user code; T => always, even if it's the iteration macro that's suboptimal."
+       )
+
+;;; ITERATE macro
+
+
+(defmacro iterate (clauses &body body &environment env)
+       (optimize-iterate-form clauses body env))
+
+(defun
+ simple-expand-iterate-form
+ (clauses body)
+ 
+ ;; Expand ITERATE.  This is the "formal semantics" expansion, which we never
+ ;; use.
+ (let*
+  ((block-name (gensym))
+   (bound-var-lists (mapcar #'(lambda (clause)
+                                     (let ((names (first clause)))
+                                          (if (listp names)
+                                              names
+                                              (list names))))
+                           clauses))
+   (generator-vars (mapcar #'(lambda (clause)
+                                    (declare (ignore clause))
+                                    (gensym))
+                          clauses)))
+  `(block ,block-name
+       (let*
+        ,(mapcan #'(lambda (gvar clause var-list)
+                                               ; For each clause, bind a
+                                               ; generator temp to the clause,
+                                               ; then bind the specified
+                                               ; var(s)
+                          (cons (list gvar (second clause))
+                                (copy-list var-list)))
+                generator-vars clauses bound-var-lists)
+        
+        ;; Note bug in formal semantics: there can be declarations in the head
+        ;; of BODY; they go here, rather than inside loop
+        (loop
+         ,@(mapcar
+            #'(lambda (var-list gen-var)
+                                               ; Set each bound variable (or
+                                               ; set of vars) to the result of
+                                               ; calling the corresponding
+                                               ; generator
+                     `(multiple-value-setq
+                       ,var-list
+                       (funcall ,gen-var #'(lambda nil (return-from
+                                                        ,block-name)))))
+            bound-var-lists generator-vars)
+         ,@body)))))
+
+(defparameter *iterate-temp-vars-list*
+       '(iterate-temp-1 iterate-temp-2 iterate-temp-3 iterate-temp-4 
+               iterate-temp-5 iterate-temp-6 iterate-temp-7 iterate-temp-8)
+       "Temp var names used by ITERATE expansions.")
+
+(defun
+ optimize-iterate-form
+ (clauses body iterate-env)
+ (let*
+  ((temp-vars *iterate-temp-vars-list*)
+   (block-name (gensym))
+   (finish-form `(return-from ,block-name))
+   (bound-vars (mapcan #'(lambda (clause)
+                                (let ((names (first clause)))
+                                     (if (listp names)
+                                         (copy-list names)
+                                         (list names))))
+                      clauses))
+   iterate-decls generator-decls update-forms bindings leftover-body)
+  (do ((tail bound-vars (cdr tail)))
+      ((null tail))
+                                               ; Check for duplicates
+    (when (member (car tail)
+                 (cdr tail))
+        (warn "Variable appears more than once in ITERATE: ~S" (car tail))))
+  (flet
+   ((get-iterate-temp nil 
+
+           ;; Make temporary var.  Note that it is ok to re-use these symbols
+           ;; in each iterate, because they are not used within BODY.
+           (or (pop temp-vars)
+               (gensym))))
+   (dolist (clause clauses)
+       (cond
+        ((or (not (consp clause))
+             (not (consp (cdr clause))))
+         (warn "Bad syntax in ITERATE: clause not of form (var iterator): ~S" 
+               clause))
+        (t
+         (unless (null (cddr clause))
+                (warn 
+       "Probable parenthesis error in ITERATE clause--more than 2 elements: ~S"
+                      clause))
+         (multiple-value-bind
+          (let-body binding-type let-bindings localdecls otherdecls extra-body)
+          (expand-into-let (second clause)
+                 'iterate iterate-env)
+          
+          ;; We have expanded the generator clause and parsed it into its LET
+          ;; pieces.
+          (prog*
+           ((vars (first clause))
+            gen-args renamed-vars)
+           (setq vars (if (listp vars)
+                          (copy-list vars)
+                          (list vars)))
+                                               ; VARS is now a (fresh) list of
+                                               ; all iteration vars bound in
+                                               ; this clause
+           (cond
+            ((eq let-body :abort)
+                                               ; Already issued a warning
+                                               ; about malformedness
+             )
+            ((null (setq let-body (function-lambda-p let-body 1)))
+                                               ; Not of the expected form
+             (let ((generator (second clause)))
+                  (cond ((and (consp generator)
+                              (fboundp (car generator)))
+                                               ; It looks ok--a macro or
+                                               ; function here--so the guy who
+                                               ; wrote it just didn't do it in
+                                               ; an optimizable way
+                         (maybe-warn :definition "Could not optimize iterate clause ~S because generator not of form (LET[*] ... (FUNCTION (LAMBDA (finish) ...)))"
+                                generator))
+                        (t                     ; Perhaps it's just a
+                                               ; misspelling?  Probably user
+                                               ; error
+                           (maybe-warn :user 
+                                "Iterate operator in clause ~S is not fboundp."
+                                  generator)))
+                  (setq let-body :abort)))
+            (t
+             
+             ;; We have something of the form #'(LAMBDA (finisharg) ...),
+             ;; possibly with some LET bindings around it.  LET-BODY =
+             ;; ((finisharg) ...).
+             (setq let-body (cdr let-body))
+             (setq gen-args (pop let-body))
+             (when let-bindings
+                 
+                 ;; The first transformation we want to perform is
+                 ;; "LET-eversion": turn (let* ((generator (let (..bindings..)
+                 ;; #'(lambda ...)))) ..body..) into (let* (..bindings..
+                 ;; (generator #'(lambda ...))) ..body..).  This
+                 ;; transformation is valid if nothing in body refers to any
+                 ;; of the bindings, something we can assure by
+                 ;; alpha-converting the inner let (substituting new names for
+                 ;; each var).  Of course, none of those vars can be special,
+                 ;; but we already checked for that above.
+                 (multiple-value-setq (let-bindings renamed-vars)
+                        (rename-let-bindings let-bindings binding-type 
+                               iterate-env leftover-body #'get-iterate-temp))
+                 (setq leftover-body nil)
+                                               ; If there was any leftover
+                                               ; from previous, it is now
+                                               ; consumed
+                 )
+             
+             ;; The second transformation is substituting the body of the
+             ;; generator (LAMBDA (finish-arg) . gen-body) for its appearance
+             ;; in the update form (funcall generator #'(lambda ()
+             ;; finish-form)), then simplifying that form.  The requirement
+             ;; for this part is that the generator body not refer to any
+             ;; variables that are bound between the generator binding and the
+             ;; appearance in the loop body.  The only variables bound in that
+             ;; interval are generator temporaries, which have unique names so
+             ;; are no problem, and the iteration variables remaining for
+             ;; subsequent clauses.  We'll discover the story as we walk the
+             ;; body.
+             (multiple-value-bind
+              (finishdecl other rest)
+              (parse-declarations let-body gen-args)
+              (declare (ignore finishdecl))
+                                               ; Pull out declares, if any,
+                                               ; separating out the one(s)
+                                               ; referring to the finish arg,
+                                               ; which we will throw away
+              (when other
+                                               ; Combine remaining decls with
+                                               ; decls extracted from the LET,
+                                               ; if any
+                  (setq otherdecls (nconc otherdecls other)))
+              (setq let-body (cond
+                              (otherdecls
+                                               ; There are interesting
+                                               ; declarations, so have to keep
+                                               ; it wrapped.
+                               `(let nil (declare ,@otherdecls)
+                                     ,@rest))
+                              ((null (cdr rest))
+                                               ; Only one form left
+                               (first rest))
+                              (t `(progn ,@rest)))))
+             (unless (eq (setq let-body (iterate-transform-body let-body 
+                                               iterate-env renamed-vars
+                                               (first gen-args)
+                                               finish-form bound-vars clause))
+                         :abort)
+                 
+                 ;; Skip the rest if transformation failed.  Warning has
+                 ;; already been issued.
+                 
+                 ;; Note possible further optimization: if LET-BODY expanded
+                 ;; into (prog1 oldvalue prepare-for-next-iteration), as so
+                 ;; many do, then we could in most cases split the PROG1 into
+                 ;; two pieces: do the (setq var oldvalue) here, and do the
+                 ;; prepare-for-next-iteration at the bottom of the loop. 
+                 ;; This does a slight optimization of the PROG1 and also
+                 ;; rearranges the code in a way that a reasonably clever
+                 ;; compiler might detect how to get rid of redundant
+                 ;; variables altogether (such as happens with INTERVAL and
+                 ;; LIST-TAILS); that would make the whole thing closer to
+                 ;; what you might have coded by hand.  However, to do this
+                 ;; optimization, we need to assure that (a) the
+                 ;; prepare-for-next-iteration refers freely to no vars other
+                 ;; than the internal vars we have extracted from the LET, and
+                 ;; (b) that the code has no side effects.  These are both
+                 ;; true for all the iterators defined by this module, but how
+                 ;; shall we represent side-effect info and/or tap into the
+                 ;; compiler's knowledge of same?
+                 (when localdecls
+                                               ; There were declarations for
+                                               ; the generator locals--have to
+                                               ; keep them for later, and
+                                               ; rename the vars mentioned
+                     (setq
+                      generator-decls
+                      (nconc
+                       generator-decls
+                       (mapcar
+                        #'(lambda
+                           (decl)
+                           (let ((head (car decl)))
+                                (cons head (if (eq head 'type)
+                                               (cons (second decl)
+                                                     (sublis renamed-vars
+                                                            (cddr decl)))
+                                               (sublis renamed-vars
+                                                      (cdr decl))))))
+                        localdecls)))))))
+           
+           ;; Finished analyzing clause now.  LET-BODY is the form which, when
+           ;; evaluated, returns updated values for the iteration variable(s)
+           ;; VARS.
+           (when (eq let-body :abort)
+               
+               ;; Some punt case: go with the formal semantics: bind a var to
+               ;; the generator, then call it in the update section
+               (let
+                ((gvar (get-iterate-temp))
+                 (generator (second clause)))
+                (setq
+                 let-bindings
+                 (list (list gvar
+                             (cond
+                              (leftover-body
+                                               ; Have to use this up
+                               `(progn ,@(prog1 leftover-body (setq 
+                                                                  leftover-body
+                                                                    nil))
+                                       generator))
+                              (t generator)))))
+                (setq let-body `(funcall ,gvar #'(lambda nil ,finish-form)))))
+           (push (mv-setq (copy-list vars)
+                        let-body)
+                 update-forms)
+           (dolist (v vars)
+               (declare (ignore v))
+                                               ; Pop off the vars we have now
+                                               ; bound from the list of vars
+                                               ; to watch out for--we'll bind
+                                               ; them right now
+               (pop bound-vars))
+           (setq bindings
+                 (nconc bindings let-bindings
+                        (cond (extra-body
+                                               ; There was some computation to
+                                               ; do after the bindings--here's
+                                               ; our chance
+                               (cons (list (first vars)
+                                           `(progn ,@extra-body nil))
+                                     (rest vars)))
+                              (t vars))))))))))
+  (do ((tail body (cdr tail)))
+      ((not (and (consp tail)
+                 (consp (car tail))
+                 (eq (caar tail)
+                     'declare)))
+       
+       ;; TAIL now points at first non-declaration.  If there were
+       ;; declarations, pop them off so they appear in the right place
+       (unless (eq tail body)
+           (setq iterate-decls (ldiff body tail))
+           (setq body tail))))
+  `(block ,block-name
+       (let* ,bindings ,@(and generator-decls
+                              `((declare ,@generator-decls)))
+             ,@iterate-decls
+             ,@leftover-body
+             (loop ,@(nreverse update-forms)
+                   ,@body)))))
+
+(defun expand-into-let (clause parent-name env)
+       
+       ;; Return values: Body, LET[*], bindings, localdecls, otherdecls, extra
+       ;; body, where BODY is a single form.  If multiple forms in a LET, the
+       ;; preceding forms are returned as extra body.  Returns :ABORT if it
+       ;; issued a punt warning.
+       (prog ((expansion clause)
+              expandedp binding-type let-bindings let-body)
+             expand
+             (multiple-value-setq (expansion expandedp)
+                    (macroexpand-1 expansion env))
+             (cond ((not (consp expansion))
+                                               ; Shouldn't happen
+                    )
+                   ((symbolp (setq binding-type (first expansion)))
+                    (case binding-type
+                        ((let let*) 
+                           (setq let-bindings (second expansion))
+                                               ; List of variable bindings
+                           (setq let-body (cddr expansion))
+                           (go handle-let))))
+                   ((and (consp binding-type)
+                         (eq (car binding-type)
+                             'lambda)
+                         (not (find-if #'(lambda (x)
+                                                (member x lambda-list-keywords)
+                                                )
+                                     (setq let-bindings (second binding-type)))
+                              )
+                         (eql (length (second expansion))
+                              (length let-bindings))
+                         (null (cddr expansion)))
+                                               ; A simple LAMBDA form can be
+                                               ; treated as LET
+                    (setq let-body (cddr binding-type))
+                    (setq let-bindings (mapcar #'list let-bindings (second
+                                                                    expansion))
+                          )
+                    (setq binding-type 'let)
+                    (go handle-let)))
+             
+             ;; Fall thru if not a LET 
+             (cond (expandedp                  ; try expanding again
+                          (go expand))
+                   (t                          ; Boring--return form as the
+                                               ; body
+                      (return expansion)))
+             handle-let
+             (return (let ((locals (variables-from-let let-bindings))
+                           extra-body specials)
+                          (multiple-value-bind
+                           (localdecls otherdecls let-body)
+                           (parse-declarations let-body locals)
+                           (cond ((setq specials (extract-special-bindings
+                                                  locals localdecls))
+                                  (maybe-warn (cond ((find-if #'variable-globally-special-p
+                                                            specials)
+                                               ; This could be the fault of a
+                                               ; user proclamation
+                                                     :user)
+                                                    (t :definition))
+                                         
+          "Couldn't optimize ~S because expansion of ~S binds specials ~(~S ~)"
+                                         parent-name clause specials)
+                                  :abort)
+                                 (t (values (cond ((not (consp let-body))
+                                                   
+                                               ; Null body of LET?  unlikely,
+                                               ; but someone else will likely
+                                               ; complain
+                                                   nil)
+                                                  ((null (cdr let-body))
+                                                   
+                                               ; A single expression, which we
+                                               ; hope is (function
+                                               ; (lambda...))
+                                                   (first let-body))
+                                                  (t 
+
+                          ;; More than one expression.  These are forms to
+                          ;; evaluate after the bindings but before the
+                          ;; generator form is returned.  Save them to
+                          ;; evaluate in the next convenient place.  Note that
+                          ;; this is ok, as there is no construct that can
+                          ;; cause a LET to return prematurely (without
+                          ;; returning also from some surrounding construct).
+                                                     (setq extra-body
+                                                           (butlast let-body))
+                                                     (car (last let-body))))
+                                           binding-type let-bindings localdecls
+                                           otherdecls extra-body))))))))
+
+(defun variables-from-let (bindings)
+       
+       ;; Return a list of the variables bound in the first argument to LET[*].
+       (mapcar #'(lambda (binding)
+                        (if (consp binding)
+                            (first binding)
+                            binding))
+              bindings))
+
+(defun iterate-transform-body (let-body iterate-env renamed-vars finish-arg 
+                                     finish-form bound-vars clause)
+       
+
+;;; This is the second major transformation for a single iterate clause. 
+;;; LET-BODY is the body of the iterator after we have extracted its local
+;;; variables and declarations.  We have two main tasks: (1) Substitute
+;;; internal temporaries for occurrences of the LET variables; the alist
+;;; RENAMED-VARS specifies this transformation.  (2) Substitute evaluation of
+;;; FINISH-FORM for any occurrence of (funcall FINISH-ARG).  Along the way, we
+;;; check for forms that would invalidate these transformations: occurrence of
+;;; FINISH-ARG outside of a funcall, and free reference to any element of
+;;; BOUND-VARS.  CLAUSE & TYPE are the original ITERATE clause and its type
+;;; (ITERATE or ITERATE*), for purpose of error messages.  On success, we
+;;; return the transformed body; on failure, :ABORT.
+
+       (walk-form let-body iterate-env
+              #'(lambda (form context env)
+                       (declare (ignore context))
+                       
+                       ;; Need to substitute RENAMED-VARS, as well as turn
+                       ;; (FUNCALL finish-arg) into the finish form
+                       (cond ((symbolp form)
+                              (let (renaming)
+                                   (cond ((and (eq form finish-arg)
+                                               (variable-same-p form env 
+                                                      iterate-env))
+                                               ; An occurrence of the finish
+                                               ; arg outside of FUNCALL
+                                               ; context--I can't handle this
+                                          (maybe-warn :definition "Couldn't optimize iterate form because generator ~S does something with its FINISH arg besides FUNCALL it."
+                                                 (second clause))
+                                          (return-from iterate-transform-body 
+                                                 :abort))
+                                         ((and (setq renaming (assoc form 
+                                                                   renamed-vars
+                                                                     ))
+                                               (variable-same-p form env 
+                                                      iterate-env))
+                                               ; Reference to one of the vars
+                                               ; we're renaming
+                                          (cdr renaming))
+                                         ((and (member form bound-vars)
+                                               (variable-same-p form env 
+                                                      iterate-env))
+                                               ; FORM is a var that is bound
+                                               ; in this same ITERATE, or
+                                               ; bound later in this ITERATE*.
+                                               ; This is a conflict.
+                                          (maybe-warn :user "Couldn't optimize iterate form because generator ~S is closed over ~S, in conflict with a subsequent iteration variable."
+                                                 (second clause)
+                                                 form)
+                                          (return-from iterate-transform-body 
+                                                 :abort))
+                                         (t form))))
+                             ((and (consp form)
+                                   (eq (first form)
+                                       'funcall)
+                                   (eq (second form)
+                                       finish-arg)
+                                   (variable-same-p (second form)
+                                          env iterate-env))
+                                               ; (FUNCALL finish-arg) =>
+                                               ; finish-form
+                              (unless (null (cddr form))
+                                  (maybe-warn :definition 
+        "Generator for ~S applied its finish arg to > 0 arguments ~S--ignored."
+                                         (second clause)
+                                         (cddr form)))
+                              finish-form)
+                             (t form)))))
+
+(defun
+ parse-declarations
+ (tail locals)
+ 
+ ;; Extract the declarations from the head of TAIL and divide them into 2
+ ;; classes: declares about variables in the list LOCALS, and all other
+ ;; declarations.  Returns 3 values: those 2 lists plus the remainder of TAIL.
+ (let
+  (localdecls otherdecls form)
+  (loop
+   (unless (and tail (consp (setq form (car tail)))
+                (eq (car form)
+                    'declare))
+       (return (values localdecls otherdecls tail)))
+   (mapc
+    #'(lambda
+       (decl)
+       (case (first decl)
+           ((inline notinline optimize) 
+                                               ; These don't talk about vars
+              (push decl otherdecls))
+           (t                                  ; Assume all other kinds are
+                                               ; for vars
+              (let* ((vars (if (eq (first decl)
+                                   'type)
+                               (cddr decl)
+                               (cdr decl)))
+                     (l (intersection locals vars))
+                     other)
+                    (cond
+                     ((null l)
+                                               ; None talk about LOCALS
+                      (push decl otherdecls))
+                     ((null (setq other (set-difference vars l)))
+                                               ; All talk about LOCALS
+                      (push decl localdecls))
+                     (t                        ; Some of each
+                        (let ((head (cons 'type (and (eq (first decl)
+                                                         'type)
+                                                     (list (second decl))))))
+                             (push (append head other)
+                                   otherdecls)
+                             (push (append head l)
+                                   localdecls))))))))
+    (cdr form))
+   (pop tail))))
+
+(defun extract-special-bindings (vars decls)
+       
+       ;; Return the subset of VARS that are special, either globally or
+       ;; because of a declaration in DECLS
+       (let ((specials (remove-if-not #'variable-globally-special-p vars)))
+            (dolist (d decls)
+                (when (eq (car d)
+                          'special)
+                    (setq specials (union specials (intersection vars
+                                                          (cdr d))))))
+            specials))
+
+(defun function-lambda-p (form &optional nargs)
+       
+       ;; If FORM is #'(LAMBDA bindings . body) and bindings is of length
+       ;; NARGS, return the lambda expression
+       (let (args body)
+            (and (consp form)
+                 (eq (car form)
+                     'function)
+                 (consp (setq form (cdr form)))
+                 (null (cdr form))
+                 (consp (setq form (car form)))
+                 (eq (car form)
+                     'lambda)
+                 (consp (setq body (cdr form)))
+                 (listp (setq args (car body)))
+                 (or (null nargs)
+                     (eql (length args)
+                          nargs))
+                 form)))
+
+(defun
+ rename-let-bindings
+ (let-bindings binding-type env leftover-body &optional tempvarfn)
+ 
+ ;; Perform the alpha conversion required for "LET eversion" of (LET[*]
+ ;; LET-BINDINGS . body)--rename each of the variables to an internal name. 
+ ;; Returns 2 values: a new set of LET bindings and the alist of old var names
+ ;; to new (so caller can walk the body doing the rest of the renaming). 
+ ;; BINDING-TYPE is one of LET or LET*.  LEFTOVER-BODY is optional list of
+ ;; forms that must be eval'ed before the first binding happens.  ENV is the
+ ;; macro expansion environment, in case we have to walk a LET*.  TEMPVARFN is
+ ;; a function of no args to return a temporary var; if omitted, we use
+ ;; GENSYM.
+ (let
+  (renamed-vars)
+  (values (mapcar #'(lambda (binding)
+                           (let ((valueform (cond ((not (consp binding))
+                                                   
+                                               ; No initial value
+                                                   nil)
+                                                  ((or (eq binding-type
+                                                           'let)
+                                                       (null renamed-vars))
+                                                   
+                                               ; All bindings are in parallel,
+                                               ; so none can refer to others
+                                                   (second binding))
+                                                  (t 
+                                               ; In a LET*, have to substitute
+                                               ; vars in the 2nd and
+                                               ; subsequent initialization
+                                               ; forms
+                                                     (rename-variables
+                                                      (second binding)
+                                                      renamed-vars env))))
+                                 (newvar (if tempvarfn
+                                             (funcall tempvarfn)
+                                             (gensym))))
+                                (push (cons (if (consp binding)
+                                                (first binding)
+                                                binding)
+                                            newvar)
+                                      renamed-vars)
+                                               ; Add new variable to the list
+                                               ; AFTER we have walked the
+                                               ; initial value form
+                                (when leftover-body
+                                    
+
+                          ;; Previous clause had some computation to do after
+                          ;; its bindings.  Here is the first opportunity to
+                          ;; do it
+                                    (setq valueform `(progn ,@leftover-body
+                                                            ,valueform))
+                                    (setq leftover-body nil))
+                                (list newvar valueform)))
+                 let-bindings)
+         renamed-vars)))
+
+(defun rename-variables (form alist env)
+       
+       ;; Walks FORM, renaming occurrences of the key variables in ALIST with
+       ;; their corresponding values.  ENV is FORM's environment, so we can
+       ;; make sure we are talking about the same variables.
+       (walk-form form env
+              #'(lambda (form context subenv)
+                       (declare (ignore context))
+                       (let (pair)
+                            (cond ((and (symbolp form)
+                                        (setq pair (assoc form alist))
+                                        (variable-same-p form subenv env))
+                                   (cdr pair))
+                                  (t form))))))
+
+(defun
+ mv-setq
+ (vars expr)
+ 
+ ;; Produces (MULTIPLE-VALUE-SETQ vars expr), except that I'll optimize some
+ ;; of the simple cases for benefit of compilers that don't, and I don't care
+ ;; what the value is, and I know that the variables need not be set in
+ ;; parallel, since they can't be used free in EXPR
+ (cond
+  ((null vars)
+                                               ; EXPR is a side-effect
+   expr)
+  ((not (consp vars))
+                                               ; This is an error, but I'll
+                                               ; let MULTIPLE-VALUE-SETQ
+                                               ; report it
+   `(multiple-value-setq ,vars ,expr))
+  ((and (listp expr)
+        (eq (car expr)
+            'values))
+   
+   ;; (mv-setq (a b c) (values x y z)) can be reduced to a parallel setq
+   ;; (psetq returns nil, but I don't care about returned value).  Do this
+   ;; even for the single variable case so that we catch (mv-setq (a) (values
+   ;; x y))
+   (pop expr)
+                                               ; VALUES
+   `(setq ,@(mapcon #'(lambda (tail)
+                             (list (car tail)
+                                   (cond ((or (cdr tail)
+                                              (null (cdr expr)))
+                                               ; One result expression for
+                                               ; this var
+                                          (pop expr))
+                                         (t    ; More expressions than vars,
+                                               ; so arrange to evaluate all
+                                               ; the rest now.
+                                            (cons 'prog1 expr)))))
+                   vars)))
+  ((null (cdr vars))
+                                               ; Simple one variable case
+   `(setq ,(car vars)
+          ,expr))
+  (t                                           ; General case--I know nothing
+     `(multiple-value-setq ,vars ,expr))))
+
+(defun variable-same-p (var env1 env2)
+       (eq (variable-lexical-p var env1)
+           (variable-lexical-p var env2)))
+
+(defun maybe-warn (type &rest warn-args)
+       
+       ;; Issue a warning about not being able to optimize this thing.  TYPE
+       ;; is one of :DEFINITION, meaning the definition is at fault, and
+       ;; :USER, meaning the user's code is at fault.
+       (when (case *iterate-warnings*
+                 ((nil) nil)
+                 ((:user) (eq type :user))
+                 (t t))
+           (apply #'warn warn-args)))
+
+
+;; Sample iterators
+
+
+(defmacro
+ interval
+ (&whole whole &key from downfrom to downto above below by type)
+ (cond
+  ((and from downfrom)
+   (error "Can't use both FROM and DOWNFROM in ~S" whole))
+  ((cdr (remove nil (list to downto above below)))
+   (error "Can't use more than one limit keyword in ~S" whole))
+  (t
+   (let*
+    ((down (or downfrom downto above))
+     (limit (or to downto above below))
+     (inc (cond ((null by)
+                 1)
+                ((constantp by)
+                                               ; Can inline this increment
+                 by))))
+    `(let
+      ((from ,(or from downfrom 0))
+       ,@(and limit `((to ,limit)))
+       ,@(and (null inc)
+              `((by ,by))))
+      ,@(and type `((declare (type ,type from ,@(and limit '(to))
+                                   ,@(and (null inc)
+                                          `(by))))))
+      #'(lambda
+         (finish)
+         ,@(cond ((null limit)
+                                               ; We won't use the FINISH arg
+                  '((declare (ignore finish)))))
+         (prog1 ,(cond (limit                  ; Test the limit.  If ok,
+                                               ; return current value and
+                                               ; increment, else quit
+                              `(if (,(cond (above '>)
+                                           (below '<)
+                                           (down '>=)
+                                           (t '<=))
+                                    from to)
+                                   from
+                                   (funcall finish)))
+                       (t                      ; No test
+                          'from))
+             (setq from (,(if down
+                              '-
+                              '+)
+                         from
+                         ,(or inc 'by))))))))))
+
+(defmacro list-elements (list &key (by '#'cdr))
+       `(let ((tail ,list))
+             #'(lambda (finish)
+                      (prog1 (if (endp tail)
+                                 (funcall finish)
+                                 (first 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))))))
+
+(defmacro
+ elements
+ (sequence)
+ "Generates successive elements of SEQUENCE, with second value being the index.  Use (ELEMENTS (THE type arg)) if you care about the type."
+ (let*
+  ((type (and (consp sequence)
+              (eq (first sequence)
+                  'the)
+              (second sequence)))
+   (accessor (if type
+                 (sequence-accessor type)
+                 'elt))
+   (listp (eq type 'list)))
+  
+  ;; If type is given via THE, we may be able to generate a good accessor here
+  ;; for the benefit of implementations that aren't smart about (ELT (THE
+  ;; STRING FOO)).  I'm not bothering to keep the THE inside the body,
+  ;; however, since I assume any compiler that would understand (AREF (THE
+  ;; SIMPLE-ARRAY S)) would also understand that (AREF S) is the same when I
+  ;; bound S to (THE SIMPLE-ARRAY foo) and never modified it.
+  
+  ;; If sequence is declared to be a list, it's better to cdr down it, so we
+  ;; have some extra cases here.  Normally folks would write LIST-ELEMENTS,
+  ;; but maybe they wanted to get the index for free...
+  `(let* ((index 0)
+          (s ,sequence)
+          ,@(and (not listp)
+                 '((size (length s)))))
+         #'(lambda (finish)
+                  (values (cond ,(if listp
+                                     '((not (endp s))
+                                       (pop s))
+                                     `((< index size)
+                                       (,accessor s index)))
+                                (t (funcall finish)))
+                         (prog1 index
+                             (setq index (1+ index))))))))
+
+(defmacro
+ plist-elements
+ (plist)
+ "Generates each time 2 items, the indicator and the value."
+ `(let ((tail ,plist))
+       #'(lambda (finish)
+                (values (if (endp tail)
+                            (funcall finish)
+                            (first tail))
+                       (prog1 (if (endp (setq tail (cdr tail)))
+                                  (funcall finish)
+                                  (first tail))
+                           (setq tail (cdr tail)))))))
+
+(defun sequence-accessor (type)
+       
+       ;; returns the function with which most efficiently to make accesses to
+       ;; a sequence of type TYPE.
+       (case (if (consp type)
+                                               ; e.g., (VECTOR FLOAT *)
+                 (car type)
+                 type)
+           ((array simple-array vector) 'aref)
+           (simple-vector 'svref)
+           (string 'char)
+           (simple-string 'schar)
+           (bit-vector 'bit)
+           (simple-bit-vector 'sbit)
+           (t 'elt)))
+
+
+;; These "iterators" may be withdrawn
+
+
+(defmacro eachtime (expr)
+       `#'(lambda (finish)
+                 (declare (ignore finish))
+                 ,expr))
+
+(defmacro while (expr)
+       `#'(lambda (finish)
+                 (unless ,expr (funcall finish))))
+
+(defmacro until (expr)
+       `#'(lambda (finish)
+                 (when ,expr (funcall finish))))
+
+                                               ; GATHERING macro
+
+
+(defmacro gathering (clauses &body body &environment env)
+       (or (optimize-gathering-form clauses body env)
+           (simple-expand-gathering-form clauses body env)))
+
+(defmacro with-gathering (clauses gather-body &body use-body)
+       "Binds the variables specified in CLAUSES to the result of (GATHERING clauses gather-body) and evaluates the forms in USE-BODY inside that contour."
+       
+       ;; We may optimize this a little better later for those compilers that
+       ;; don't do a good job on (m-v-bind vars (... (values ...)) ...).
+       `(multiple-value-bind ,(mapcar #'car clauses)
+               (gathering ,clauses ,gather-body)
+               ,@use-body))
+
+(defun
+ simple-expand-gathering-form
+ (clauses body env)
+ (declare (ignore env))
+ 
+ ;; The "formal semantics" of GATHERING.  We use this only in cases that can't
+ ;; be optimized.
+ (let
+  ((acc-names (mapcar #'first (if (symbolp clauses)
+                                               ; Shorthand using anonymous
+                                               ; gathering site
+                                  (setq clauses `((*anonymous-gathering-site*
+                                                   (,clauses))))
+                                  clauses)))
+   (realizer-names (mapcar #'(lambda (binding)
+                                    (declare (ignore binding))
+                                    (gensym))
+                          clauses)))
+  `(multiple-value-call
+    #'(lambda
+       ,(mapcan #'list acc-names realizer-names)
+       (flet ((gather (value &optional (accumulator *anonymous-gathering-site*)
+                             )
+                     (funcall accumulator value)))
+             ,@body
+             (values ,@(mapcar #'(lambda (rname)
+                                        `(funcall ,rname))
+                              realizer-names))))
+    ,@(mapcar #'second clauses))))
+
+(defvar *active-gatherers* nil 
+       "List of GATHERING bindings currently active during macro expansion)")
+
+(defvar *anonymous-gathering-site* nil "Variable used in formal expansion of an abbreviated GATHERING form (one with anonymous gathering site)."
+       )
+
+(defun
+ optimize-gathering-form
+ (clauses body gathering-env)
+ (let*
+  (acc-info leftover-body top-bindings finish-forms top-decls)
+  (dolist (clause (if (symbolp clauses)
+                                               ; A shorthand
+                      `((*anonymous-gathering-site* (,clauses)))
+                      clauses))
+      (multiple-value-bind
+       (let-body binding-type let-bindings localdecls otherdecls extra-body)
+       (expand-into-let (second clause)
+              'gathering gathering-env)
+       (prog*
+        ((acc-var (first clause))
+         renamed-vars accumulator realizer)
+        (when (and (consp let-body)
+                   (eq (car let-body)
+                       'values)
+                   (consp (setq let-body (cdr let-body)))
+                   (setq accumulator (function-lambda-p (car let-body)))
+                   (consp (setq let-body (cdr let-body)))
+                   (setq realizer (function-lambda-p (car let-body)
+                                         0))
+                   (null (cdr let-body)))
+            
+            ;; Macro returned something of the form (VALUES #'(lambda (value)
+            ;; ...) #'(lambda () ...)), a function to accumulate values and a
+            ;; function to realize the result.
+            (when binding-type
+                
+                ;; Gatherer expanded into a LET
+                (cond (otherdecls (maybe-warn :definition "Couldn't optimize GATHERING clause ~S because its expansion carries declarations about more than the bound variables: ~S"
+                                         (second clause)
+                                         `(declare ,@otherdecls))
+                             (go punt)))
+                (when let-bindings
+                    
+                    ;; The first transformation we want to perform is a
+                    ;; variant of "LET-eversion": turn (mv-bind (acc real)
+                    ;; (let (..bindings..) (values #'(lambda ...) #'(lambda
+                    ;; ...))) ..body..) into (let* (..bindings.. (acc
+                    ;; #'(lambda ...)) (real #'(lambda ...))) ..body..).  This
+                    ;; transformation is valid if nothing in body refers to
+                    ;; any of the bindings, something we can assure by
+                    ;; alpha-converting the inner let (substituting new names
+                    ;; for each var).  Of course, none of those vars can be
+                    ;; special, but we already checked for that above.
+                    (multiple-value-setq (let-bindings renamed-vars)
+                           (rename-let-bindings let-bindings binding-type 
+                                  gathering-env leftover-body))
+                    (setq top-bindings (nconc top-bindings let-bindings))
+                    (setq leftover-body nil)
+                                               ; If there was any leftover
+                                               ; from previous, it is now
+                                               ; consumed
+                    ))
+            (setq leftover-body (nconc leftover-body extra-body))
+                                               ; Computation to do after these
+                                               ; bindings
+            (push (cons acc-var (rename-and-capture-variables accumulator 
+                                       renamed-vars gathering-env))
+                  acc-info)
+            (setq realizer (rename-variables realizer renamed-vars 
+                                  gathering-env))
+            (push (cond ((null (cdddr realizer))
+                                               ; Simple (LAMBDA () expr) =>
+                                               ; expr
+                         (third realizer))
+                        (t                     ; There could be declarations
+                                               ; or something, so leave as a
+                                               ; LET
+                           (cons 'let (cdr realizer))))
+                  finish-forms)
+            (unless (null localdecls)
+                                               ; Declarations about the LET
+                                               ; variables also has to
+                                               ; percolate up
+                (setq top-decls (nconc top-decls (sublis renamed-vars 
+                                                        localdecls))))
+            (return))
+        (maybe-warn :definition "Couldn't optimize GATHERING clause ~S because its expansion is not of the form (VALUES #'(LAMBDA ...) #'(LAMBDA () ...))"
+               (second clause))
+        punt
+        (let
+         ((gs (gensym))
+          (expansion `(multiple-value-list ,(second clause))))
+                                               ; Slow way--bind gensym to the
+                                               ; macro expansion, and we will
+                                               ; funcall it in the body
+         (push (list acc-var gs)
+               acc-info)
+         (push `(funcall (cadr ,gs))
+               finish-forms)
+         (setq
+          top-bindings
+          (nconc
+           top-bindings
+           (list (list gs (cond (leftover-body
+                                 `(progn ,@(prog1 leftover-body
+                                                  (setq leftover-body nil))
+                                         ,expansion))
+                                (t expansion))))))))))
+  (setq body (walk-gathering-body body gathering-env acc-info))
+  (cond ((eq body :abort)
+                                               ; Couldn't finish expansion
+         nil)
+        (t `(let* ,top-bindings
+                  ,@(and top-decls `((declare ,@top-decls)))
+                  ,body
+                  ,(cond ((null (cdr finish-forms))
+                                               ; just a single value
+                          (car finish-forms))
+                         (t `(values ,@(reverse finish-forms)))))))))
+
+(defun rename-and-capture-variables (form alist env)
+       
+       ;; Walks FORM, renaming occurrences of the key variables in ALIST with
+       ;; their corresponding values, and capturing any other free variables. 
+       ;; Returns a list of the new form and the list of other closed-over
+       ;; vars.  ENV is FORM's environment, so we can make sure we are talking
+       ;; about the same variables.
+       (let (closed)
+            (list (walk-form
+                   form env
+                   #'(lambda (form context subenv)
+                            (declare (ignore context))
+                            (let (pair)
+                                 (cond ((or (not (symbolp form))
+                                            (not (variable-same-p form subenv 
+                                                        env)))
+                                               ; non-variable or one that has
+                                               ; been rebound
+                                        form)
+                                       ((setq pair (assoc form alist))
+                                               ; One to rename
+                                        (cdr pair))
+                                       (t      ; var is free
+                                          (pushnew form closed)
+                                          form)))))
+                  closed)))
+
+(defun
+ walk-gathering-body
+ (body gathering-env acc-info)
+ 
+ ;; Walk the body of (GATHERING (...) . BODY) in environment GATHERING-ENV. 
+ ;; ACC-INFO is a list of information about each of the gathering "bindings"
+ ;; in the form, in the form (var gatheringfn freevars env)
+ (let
+  ((*active-gatherers* (nconc (mapcar #'car acc-info)
+                              *active-gatherers*)))
+  
+  ;; *ACTIVE-GATHERERS* tells us what vars are currently legal as GATHER
+  ;; targets.  This is so that when we encounter a GATHER not belonging to us
+  ;; we can know whether to warn about it.
+  (walk-form
+   (cons 'progn body)
+   gathering-env
+   #'(lambda
+      (form context env)
+      (declare (ignore context))
+      (let (info site)
+           (cond ((consp form)
+                  (cond
+                   ((not (eq (car form)
+                             'gather))
+                                               ; We only care about GATHER
+                    (when (and (eq (car form)
+                                   'function)
+                               (eq (cadr form)
+                                   'gather))
+                                               ; Passed as functional--can't
+                                               ; macroexpand
+                        (maybe-warn :user 
+                   "Can't optimize GATHERING because of reference to #'GATHER."
+                               )
+                        (return-from walk-gathering-body :abort))
+                    form)
+                   ((setq info (assoc (setq site (if (null (cddr form))
+                                                     
+                                                     '
+                                                     *anonymous-gathering-site*
+                                                     (third form)))
+                                      acc-info))
+                                               ; One of ours--expand (GATHER
+                                               ; value var).  INFO = (var
+                                               ; gatheringfn freevars env)
+                    (unless (null (cdddr form))
+                           (warn "Extra arguments (> 2) in ~S discarded." form)
+                           )
+                    (let ((fn (second info)))
+                         (cond ((symbolp fn)
+                                               ; Unoptimized case--just call
+                                               ; the gatherer.  FN is the
+                                               ; gensym that we bound to the
+                                               ; list of two values returned
+                                               ; from the gatherer.
+                                `(funcall (car ,fn)
+                                        ,(second form)))
+                               (t              ; FN = (lambda (value) ...)
+                                  (dolist (s (third info))
+                                      (unless (or (variable-same-p s env 
+                                                         gathering-env)
+                                                  (and (variable-special-p
+                                                        s env)
+                                                       (variable-special-p
+                                                        s gathering-env)))
+                                          
+
+                          ;; Some var used free in the LAMBDA form has been
+                          ;; rebound between here and the parent GATHERING
+                          ;; form, so can't substitute the lambda.  Ok if it's
+                          ;; a special reference both here and in the LAMBDA,
+                          ;; because then it's not closed over.
+                                          (maybe-warn :user "Can't optimize GATHERING because the expansion closes over the variable ~S, which is rebound around a GATHER for it."
+                                                 s)
+                                          (return-from walk-gathering-body 
+                                                 :abort)))
+                                  
+
+                          ;; Return ((lambda (value) ...) actual-value).  In
+                          ;; many cases we could simplify this further by
+                          ;; substitution, but we'd have to be careful (for
+                          ;; example, we would need to alpha-convert any LET
+                          ;; we found inside).  Any decent compiler will do it
+                          ;; for us.
+                                  (list fn (second form))))))
+                   ((and (setq info (member site *active-gatherers*))
+                         (or (eq site '*anonymous-gathering-site*)
+                             (variable-same-p site env (fourth info))))
+                                               ; Some other GATHERING will
+                                               ; take care of this form, so
+                                               ; pass it up for now. 
+                                               ; Environment check is to make
+                                               ; sure nobody shadowed it
+                                               ; between here and there
+                    form)
+                   (t                          ; Nobody's going to handle it
+                      (if (eq site '*anonymous-gathering-site*)
+                                               ; More likely that she forgot
+                                               ; to mention the site than
+                                               ; forget to write an anonymous
+                                               ; gathering.
+                          (warn "There is no gathering site specified in ~S." 
+                                form)
+                          (warn 
+             "The site ~S in ~S is not defined in an enclosing GATHERING form."
+                                site form))
+                                               ; Turn it into something else
+                                               ; so we don't warn twice in the
+                                               ; nested case
+                      `(%orphaned-gather ,@(cdr form)))))
+                 ((and (symbolp form)
+                       (setq info (assoc form acc-info))
+                       (variable-same-p form env gathering-env))
+                                               ; A variable reference to a
+                                               ; gather binding from
+                                               ; environment TEM
+                  (maybe-warn :user "Can't optimize GATHERING because site variable ~S is used outside of a GATHER form."
+                         form)
+                  (return-from walk-gathering-body :abort))
+                 (t form)))))))
+
+
+;; Sample gatherers
+
+
+(defmacro
+ collecting
+ (&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)))
+                             (setq tail (cdr (rplacd tail (list value))))))
+               #'(lambda nil head))))
+
+(defmacro joining (&key initial-value)
+       `(let ((result ,initial-value))
+             (values #'(lambda (value)
+                              (setq result (nconc result value)))
+                    #'(lambda nil result))))
+
+(defmacro
+ maximizing
+ (&key initial-value)
+ `(let ((result ,initial-value))
+       (values
+        #'(lambda (value)
+                 (when ,(cond ((and (constantp initial-value)
+                                    (not (null (eval initial-value))))
+                                               ; Initial value is given and we
+                                               ; know it's not NIL, so leave
+                                               ; out the null check
+                               '(> value result))
+                              (t '(or (null result)
+                                      (> value result))))
+                       (setq result value)))
+        #'(lambda nil result))))
+
+(defmacro
+ minimizing
+ (&key initial-value)
+ `(let ((result ,initial-value))
+       (values
+        #'(lambda (value)
+                 (when ,(cond ((and (constantp initial-value)
+                                    (not (null (eval initial-value))))
+                                               ; Initial value is given and we
+                                               ; know it's not NIL, so leave
+                                               ; out the null check
+                               '(< value result))
+                              (t '(or (null result)
+                                      (< value result))))
+                       (setq result value)))
+        #'(lambda nil result))))
+
+(defmacro summing (&key (initial-value 0))
+       `(let ((sum ,initial-value))
+             (values #'(lambda (value)
+                              (setq sum (+ sum value)))
+                    #'(lambda nil sum))))
+
+                                               ; Easier to read expanded code
+                                               ; if PROG1 gets left alone
+
+
+(define-walker-template prog1 (nil return walker::repeat (eval)))
diff --git a/pcl/kcl-low.lisp b/pcl/kcl-low.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..966cb3cfcc9d082eccf280b4fb1846bf4540ec25
--- /dev/null
+++ b/pcl/kcl-low.lisp
@@ -0,0 +1,175 @@
+;;;-*-Mode:LISP; Package:(PCL Lisp 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+;;; The version of low for Kyoto Common Lisp (KCL)
+(in-package "SI")
+(export '(%structure-name
+          %compiled-function-name
+          %set-compiled-function-name))
+(in-package 'pcl)
+
+(defun printing-random-thing-internal (thing stream)
+  (format stream "~O" (si:address thing)))
+
+#+akcl
+(eval-when (load compile eval)
+ (if (fboundp 'si::allocate-growth) (pushnew :turbo-closure *features*)))
+
+(defmacro %svref (vector index)
+  `(svref (the simple-vector ,vector) (the fixnum ,index)))
+
+(defsetf %svref (vector index) (new-value)
+  `(setf (svref (the simple-vector ,vector) (the fixnum ,index))
+         ,new-value))
+
+
+;;;
+;;; std-instance-p
+;;;
+(si:define-compiler-macro std-instance-p (x)
+  (once-only (x)
+    `(and (si:structurep ,x)
+          (eq (si:%structure-name ,x) 'std-instance))))
+
+;;;
+;;; turbo-closure patch.  See the file kcl-mods.text for details.
+;;;
+#-turbo-closure-env-size
+(clines "
+object cclosure_env_nthcdr (n,cc)
+int n; object cc;
+{  object env;
+   if(n<0)return Cnil;
+   if(type_of(cc)!=t_cclosure)return Cnil;
+   env=cc->cc_env;
+   while(n-->0)
+     {if(type_of(env)!=t_cons)return Cnil;
+      env=env->c.c_cdr;}
+   return env;
+}")
+
+#+turbo-closure-env-size
+(clines "
+object cclosure_env_nthcdr (n,cc)
+int n; object cc;
+{  object env,*turbo;
+   if(n<0)return Cnil;
+   if(type_of(cc)!=t_cclosure)return Cnil;
+   if((turbo=cc->cc.cc_turbo)==NULL)
+     {env=cc->cc_env;
+      while(n-->0)
+        {if(type_of(env)!=t_cons)return Cnil;
+         env=env->c.c_cdr;}
+      return env;}
+   else
+     {if(n>=fix(*(turbo-1)))return Cnil;
+      return turbo[n];}
+}")
+
+;; This is the completely safe version.
+(defentry cclosure-env-nthcdr (int object) (object cclosure_env_nthcdr))
+;; This is the unsafe but fast version.
+(defentry %cclosure-env-nthcdr (int object) (object cclosure_env_nthcdr))
+
+;;; #+akcl means this is an AKCL newer than 5/11/89 (structures changed)
+(eval-when (compile load eval)
+
+;;((name args-type result-type side-effect-p new-object-p c-expression) ...)
+(defparameter *kcl-function-inlines*
+  '(#-akcl (si:structurep (t) compiler::boolean nil nil "type_of(#0)==t_structure")
+    #-akcl (si:%structure-name (t) t nil nil "(#0)->str.str_name")
+    #+akcl (si:%structure-name (t) t nil nil "(#0)->str.str_def->str.str_self[0]")
+    (si:%compiled-function-name (t) t nil nil "(#0)->cf.cf_name")
+    (si:%set-compiled-function-name (t t) t t nil "((#0)->cf.cf_name)=(#1)")
+    (cclosurep (t) compiler::boolean nil nil "type_of(#0)==t_cclosure")
+    (%cclosure-env (t) t nil nil "(#0)->cc.cc_env")
+    (%set-cclosure-env (t t) t t nil "((#0)->cc.cc_env)=(#1)")
+    #+turbo-closure
+    (%cclosure-env-nthcdr (fixnum t) t nil nil "(#1)->cc.cc_turbo[#0]")))
+
+(defun make-function-inline (inline)
+  (setf (get (car inline) 'compiler::inline-always) (list (cdr inline))))
+
+(defmacro define-inlines ()
+  `(progn
+    ,@(mapcan #'(lambda (inline)
+                  (let ((name (intern (format nil "~S inline" (car inline))))
+                        (vars (mapcar #'(lambda (type)
+                                          (declare (ignore type))
+                                          (gensym))
+                                      (cadr inline))))
+                    `((make-function-inline ',(cons name (cdr inline)))
+                      (defun ,(car inline) ,vars
+                        ,@(mapcan #'(lambda (var var-type)
+                                      (unless (eq var-type 't)
+                                        `((declare (type ,var-type ,var)))))
+                                  vars (cadr inline))
+                        (,name ,@vars))
+                      (make-function-inline ',inline))))
+              *kcl-function-inlines*)))
+
+(define-inlines)
+)
+
+(defsetf si:%compiled-function-name si:%set-compiled-function-name)
+(defsetf %cclosure-env %set-cclosure-env)
+
+(defun set-function-name-1 (fn new-name ignore)
+  (declare (ignore ignore))
+  (cond ((compiled-function-p fn)
+         (setf (si:%compiled-function-name fn) new-name))
+        ((and (listp fn)
+              (eq (car fn) 'lambda-block))
+         (setf (cadr fn) new-name))
+        ((and (listp fn)
+              (eq (car fn) 'lambda))
+         (setf (car fn) 'lambda-block
+               (cdr fn) (cons new-name (cdr fn)))))
+  fn)
+
+#+akcl (clines "#define AKCL206")
+
+(clines "
+object set_cclosure (result_cc,value_cc,available_size)
+object result_cc,value_cc; int available_size;
+{
+  object result_env_tail,value_env_tail; int i;
+
+  result_env_tail=result_cc->cc.cc_env;
+  value_env_tail=value_cc->cc.cc_env;
+  for(i=available_size;
+      result_env_tail!=Cnil && i>0;
+      result_env_tail=CMPcdr(result_env_tail), value_env_tail=CMPcdr(value_env_tail))
+    CMPcar(result_env_tail)=CMPcar(value_env_tail), i--;
+  result_cc->cc.cc_self=value_cc->cc.cc_self;
+  result_cc->cc.cc_data=value_cc->cc.cc_data;
+#ifndef AKCL206
+  result_cc->cc.cc_start=value_cc->cc.cc_start;
+  result_cc->cc.cc_size=value_cc->cc.cc_size;
+#endif
+  return result_cc;
+}")
+
diff --git a/pcl/kcl-mods.text b/pcl/kcl-mods.text
new file mode 100644
index 0000000000000000000000000000000000000000..deb2b0ca2ebf166c5d873a01ea2510b0c95da07b
--- /dev/null
+++ b/pcl/kcl-mods.text
@@ -0,0 +1,220 @@
+
+(1) Turbo closure patch
+
+To make the turbo closure stuff work, make the following changes to KCL.
+These changes can also work for an IBCL.
+
+The three patches in this file add two features (reflected in the
+value of *features*) to your KCL or IBCL:
+  a feature named :TURBO-CLOSURE which increases the speed of the
+     code generated by FUNCALLABLE-INSTANCE-DATA-1
+     (previous versions of the file kcl-mods.text had this feature only), 
+and
+  a feature named :TURBO-CLOSURE-ENV-SIZE which increases the speed
+     of the function FUNCALLABLE-INSTANCE-P.
+
+(This file comprises two features rather than just one to allow the
+PCL system to be work in KCL systems that do not have this patch,
+or that have the old version of this patch.)
+
+
+The first of these patches changes the turbo_closure function to
+store the size of the environment in the turbo structure.
+
+The second of patch fixes a garbage-collector bug in which
+the turbo structure was sometimes ignored, AND also adapts
+the garbage-collector to conform to the change made in the
+first patch.  The bug has been fixed in newer versions of
+AKCL, but it is still necessary to apply this patch, if the
+first and third patches are applied.
+
+The third change pushes :turbo-closure and :turbo-closure-env-size
+on the *features* list so that PCL will know that turbo closures 
+are enabled.
+
+
+Note that these changes have to be made before PCL is compiled, and a
+PCL which is compiled in a KCL/IBCL with these changes can only be run
+in a KCL/IBCL with these changes.
+
+(1-1) edit the function turbo_closure in the file kcl/c/cfun.c,
+change the lines
+----------
+turbo_closure(fun)
+object fun;
+{
+        object l;
+        int n;
+
+        for (n = 0, l = fun->cc.cc_env;  !endp(l);  n++, l = l->c.c_cdr)
+                ;
+        fun->cc.cc_turbo = (object *)alloc_contblock(n*sizeof(object));
+        for (n = 0, l = fun->cc.cc_env;  !endp(l);  n++, l = l->c.c_cdr)
+                fun->cc.cc_turbo[n] = l;
+}
+----------
+to
+----------
+turbo_closure(fun)
+object fun;
+{
+  object l,*block;
+  int n;
+
+  if(fun->cc.cc_turbo==NULL)
+    {for (n = 0, l = fun->cc.cc_env;  !endp(l);  n++, l = l->c.c_cdr);
+     block=(object *)alloc_contblock((1+n)*sizeof(object));
+     *block=make_fixnum(n);
+     fun->cc.cc_turbo = block+1; /* equivalent to &block[1] */
+     for (n = 0, l = fun->cc.cc_env;  !endp(l);  n++, l = l->c.c_cdr)
+       fun->cc.cc_turbo[n] = l;}
+}
+----------
+
+
+(1-2) edit the function mark_object in the file kcl/c/gbc.c,
+Find the lines following case t_cclosure: in mark_object.
+If they look like the ones between the lines marked (KCL),
+make the first change, but if the look like the lines marked
+(AKCL), apply the second change instead, and if the file
+sgbc.c exists, apply the third change to it.
+(1-2-1) Change:
+(KCL)----------
+        case t_cclosure:
+                mark_object(x->cc.cc_name);
+                mark_object(x->cc.cc_env);
+                mark_object(x->cc.cc_data);
+                if (x->cc.cc_start == NULL)
+                        break;
+                if (what_to_collect == t_contiguous) {
+                        if (get_mark_bit((int *)(x->cc.cc_start)))
+                                break;
+                        mark_contblock(x->cc.cc_start, x->cc.cc_size);
+                        if (x->cc.cc_turbo != NULL) {
+                                for (i = 0, y = x->cc.cc_env;
+                                     type_of(y) == t_cons;
+                                     i++, y = y->c.c_cdr);
+                                mark_contblock((char *)(x->cc.cc_turbo),
+                                               i*sizeof(object));
+                        }
+                }
+                break;
+(KCL)----------
+to
+(KCL new)----------
+        case t_cclosure:
+                mark_object(x->cc.cc_name);
+                mark_object(x->cc.cc_env);
+                mark_object(x->cc.cc_data);
+                if (what_to_collect == t_contiguous)
+                        if (x->cc.cc_turbo != NULL) {
+                                mark_contblock((char *)(x->cc.cc_turbo-1),
+                                               (1+fix(*(x->cc.cc_turbo-1)))*sizeof(object));
+                        }
+                if (x->cc.cc_start == NULL)
+                        break;
+                if (what_to_collect == t_contiguous) {
+                        if (get_mark_bit((int *)(x->cc.cc_start)))
+                                break;
+                        mark_contblock(x->cc.cc_start, x->cc.cc_size);
+                }
+                break;
+(KCL new)----------
+(1-2-2) Or, Change:
+(AKCL)----------
+        case t_cclosure:
+                mark_object(x->cc.cc_name);
+                mark_object(x->cc.cc_env);
+                mark_object(x->cc.cc_data);
+                if (what_to_collect == t_contiguous) {
+                  if (x->cc.cc_turbo != NULL) {
+                    for (i = 0, y = x->cc.cc_env;
+                         type_of(y) == t_cons;
+                         i++, y = y->c.c_cdr);
+                    mark_contblock((char *)(x->cc.cc_turbo),
+                                               i*sizeof(object));
+                        }
+                }
+                break;
+(AKCL)----------
+To:
+(AKCL new)----------
+        case t_cclosure:
+                mark_object(x->cc.cc_name);
+                mark_object(x->cc.cc_env);
+                mark_object(x->cc.cc_data);
+                if (what_to_collect == t_contiguous) {
+                  if (x->cc.cc_turbo != NULL)
+                    mark_contblock((char *)(x->cc.cc_turbo-1),
+                                   (1+fix(*(x->cc.cc_turbo-1)))*sizeof(object));
+                }
+                break;
+(AKCL new)----------
+(1-2-3) In sgbc.c (if it exists), Change:
+(AKCL)----------
+        case t_cclosure:
+                sgc_mark_object(x->cc.cc_name);
+                sgc_mark_object(x->cc.cc_env);
+                sgc_mark_object(x->cc.cc_data);
+                if (what_to_collect == t_contiguous) {
+                  if (x->cc.cc_turbo != NULL) {
+                    for (i = 0, y = x->cc.cc_env;
+                         type_of(y) == t_cons;
+                         i++, y = y->c.c_cdr);
+                    mark_contblock((char *)(x->cc.cc_turbo),
+                                               i*sizeof(object));
+                        }
+                }
+                break;
+(AKCL)----------
+To:
+(AKCL new)----------
+        case t_cclosure:
+                sgc_mark_object(x->cc.cc_name);
+                sgc_mark_object(x->cc.cc_env);
+                sgc_mark_object(x->cc.cc_data);
+                if (what_to_collect == t_contiguous) {
+                  if (x->cc.cc_turbo != NULL)
+                    mark_contblock((char *)(x->cc.cc_turbo-1),
+                                   (1+fix(*(x->cc.cc_turbo-1)))*sizeof(object));
+                }
+                break;
+(AKCL new)----------
+
+
+(1-3) edit the function init_main in the file kcl/c/main.c,
+change the lines where setting the value of *features* to add a :turbo-closure
+and a :turbo-closure-env-size into the list in your KCL/IBCL.
+
+For example, in Sun4(SunOS) version of IBCL
+changing the lines:
+----------
+        make_special("*FEATURES*",
+                     make_cons(make_ordinary("SUN4"),
+                     make_cons(make_ordinary("SPARC"),
+                     make_cons(make_ordinary("IEEE-FLOATING-POINT"),
+                     make_cons(make_ordinary("UNIX"),
+                     make_cons(make_ordinary("BSD"),
+                     make_cons(make_ordinary("COMMON"),
+                     make_cons(make_ordinary("IBCL"), Cnil))))))));
+----------
+to
+----------
+        make_special("*FEATURES*",
+                     make_cons(make_ordinary("SUN4"),
+                     make_cons(make_ordinary("SPARC"),
+                     make_cons(make_ordinary("IEEE-FLOATING-POINT"),
+                     make_cons(make_ordinary("UNIX"),
+                     make_cons(make_ordinary("BSD"),
+                     make_cons(make_ordinary("COMMON"),
+                     make_cons(make_ordinary("IBCL"),
+                     make_cons(make_keyword("TURBO-CLOSURE"),
+                     make_cons(make_keyword("TURBO-CLOSURE-ENV-SIZE"),
+                     Cnil))))))))));
+----------
+But, if the C macro ADD_FEATURE is defined at the end of main.c,
+use it instead.
+Insert the lines:
+        ADD_FEATURE("TURBO-CLOSURE");
+        ADD_FEATURE("TURBO-CLOSURE-ENV-SIZE");
+After the line:
diff --git a/pcl/kcl-patches.lisp b/pcl/kcl-patches.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..656501bce48b7c5581e75bc6419591770cfaf432
--- /dev/null
+++ b/pcl/kcl-patches.lisp
@@ -0,0 +1,131 @@
+;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+
+(in-package 'system)
+
+()
+
+#|
+
+;;;   This makes DEFMACRO take &WHOLE and &ENVIRONMENT args anywhere
+;;;   in the lambda-list.  The former allows deviation from the CL spec,
+;;;   but what the heck.
+
+(eval-when (compile) (proclaim '(optimize (safety 2) (space 3))))
+
+(defvar *old-defmacro*)
+
+(defun new-defmacro (whole env)
+  (flet ((call-old-definition (new-whole)
+	   (funcall *old-defmacro* new-whole env)))
+    (if (not (and (consp whole)
+		  (consp (cdr whole))
+		  (consp (cddr whole))
+		  (consp (cdddr whole))))
+	(call-old-definition whole)
+	(let* ((ll (caddr whole))
+	       (env-tail (do ((tail ll (cdr tail)))
+			     ((not (consp tail)) nil)
+			   (when (eq '&environment (car tail))
+			     (return tail)))))
+	  (if env-tail
+	      (call-old-definition (list* (car whole)
+					  (cadr whole)
+					  (append (list '&environment
+							(cadr env-tail))
+						  (ldiff ll env-tail)
+						  (cddr env-tail))
+					  (cdddr whole)))
+	      (call-old-definition whole))))))
+
+(eval-when (load eval)
+  (unless (boundp '*old-defmacro*)
+    (setq *old-defmacro* (macro-function 'defmacro))
+    (setf (macro-function 'defmacro) #'new-defmacro)))
+
+;;;
+;;; setf patches
+;;;
+
+(defun get-setf-method (form)
+  (multiple-value-bind (vars vals stores store-form access-form)
+      (get-setf-method-multiple-value form)
+    (unless (listp vars)
+	    (error 
+ "The temporary variables component, ~s, 
+  of the setf-method for ~s is not a list."
+             vars form))
+    (unless (listp vals)
+	    (error 
+ "The values forms component, ~s, 
+  of the setf-method for ~s is not a list."
+             vals form))
+    (unless (listp stores)
+	    (error 
+ "The store variables component, ~s,  
+  of the setf-method for ~s is not a list."
+             stores form))
+    (unless (= (list-length stores) 1)
+	    (error "Multiple store-variables are not allowed."))
+    (values vars vals stores store-form access-form)))
+
+(defun get-setf-method-multiple-value (form)
+  (cond ((symbolp form)
+	 (let ((store (gensym)))
+	   (values nil nil (list store) `(setq ,form ,store) form)))
+	((or (not (consp form)) (not (symbolp (car form))))
+	 (error "Cannot get the setf-method of ~S." form))
+	((get (car form) 'setf-method)
+	 (apply (get (car form) 'setf-method) (cdr form)))
+	((get (car form) 'setf-update-fn)
+	 (let ((vars (mapcar #'(lambda (x)
+	                         (declare (ignore x))
+	                         (gensym))
+	                     (cdr form)))
+	       (store (gensym)))
+	   (values vars (cdr form) (list store)
+	           `(,(get (car form) 'setf-update-fn)
+		     ,@vars ,store)
+		   (cons (car form) vars))))
+	((get (car form) 'setf-lambda)
+	 (let* ((vars (mapcar #'(lambda (x)
+	                          (declare (ignore x))
+	                          (gensym))
+	                      (cdr form)))
+		(store (gensym))
+		(l (get (car form) 'setf-lambda))
+		(f `(lambda ,(car l) 
+		      (funcall #'(lambda ,(cadr l) ,@(cddr l))
+			       ',store))))
+	   (values vars (cdr form) (list store)
+		   (apply f vars)
+		   (cons (car form) vars))))
+	((macro-function (car form))
+	 (get-setf-method-multiple-value (macroexpand-1 form)))
+	(t
+	 (error "Cannot expand the SETF form ~S." form))))
+
diff --git a/pcl/lap.lisp b/pcl/lap.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..3b4ba0b92471bba4d2e9ce135f471aa06c1eaa27
--- /dev/null
+++ b/pcl/lap.lisp
@@ -0,0 +1,480 @@
+;;;-*-Mode: LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+
+(in-package 'pcl)
+
+;;;
+;;; This file defines PCL's interface to the LAP mechanism.
+;;;
+;;; The file is divided into two parts.  The first part defines the interface
+;;; used by PCL to create abstract LAP code vectors.  PCL 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 PCL 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 PCL 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 () () -1)))
+     (finalize-lap-generation nil ,closure-variables ,arguments (progn ,@body))))
+
+(defmacro generating-lap-in-lisp (closure-variables arguments &body body)
+  `(let* ((*generating-lap* (list () () -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 ()
+	   (gathering1 (collecting)
+	     (dolist (spec register-specifications)
+	       (gather1
+		 `(,(car spec) (or ,(cadddr spec) (allocate-register ',(cadr spec))))))))
+	 (make-deallocations ()
+	   (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 ())
+	(vregs ())
+	(tregs ()))
+    (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
+	   `(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 ()))
+    (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 ()
+  '(let ((result ()))
+    (values #'(lambda (value) (push value result))
+     #'(lambda () (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* ())
+(defvar *lap-opcodes*  ())
+(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-pcl-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
+	 #+Genera (declare (sys:function-parent ,name defopcode))
+	 (defopcode-1 ',name ',types ,@lambda-list)))))
+
+(defmacro defoperand (name types)
+  (let ((fn-name (symbol-append "LAP Operand " name *the-pcl-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
+	 #+Genera (declare (sys:function-parent ,name defoperand))
+	 (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 ())				;For debugging only.  Not
+(defopcode :beep  ())				;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 ())
+
+;;;
+;;; 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)
+;;;
+#|
+(defun make-lap-test-closure-1 (result)
+  #'(lambda (arg1)
+      (declare (pcl-fast-call))
+      (declare (ignore arg1))
+      result))
+
+(defun make-lap-test-closure-2 (result)
+  #'(lambda (arg1 arg2)
+      (declare (pcl-fast-call))
+      (declare (ignore arg1 arg2))
+      result))
+
+(eval-when (eval)
+  (compile 'make-lap-test-closure-1)
+  (compile 'make-lap-test-closure-2))
+
+(proclaim '(special lap-win lap-lose))
+(eval-when (load eval)
+  (setq lap-win (make-lap-test-closure-1 'win)
+	lap-lose (make-lap-test-closure-1 'lose)))
+
+(defun lap-test-1 ()
+  (let* ((cg (generating-lap '(cache)
+			     '(arg)
+	       (with-lap-registers ((i0 index)
+				    (v0 vector)
+				    (t0 t))
+		 (flatten-lap 
+		   (opcode :move (operand :cvar 'cache) v0)
+		   (opcode :move (operand :arg 'arg) i0)
+		   (opcode :move (operand :iref v0 i0) t0)
+		   (opcode :jmp t0)))))
+	 
+	 (cache (make-array 32))
+	 (closure (funcall cg cache))
+	 (fn0 (make-lap-test-closure-1 'fn0))
+	 (fn1 (make-lap-test-closure-1 'fn1))
+	 (fn2 (make-lap-test-closure-1 'fn2))
+	 (in0 (index-value->index 2))
+	 (in1 (index-value->index 10))
+	 (in2 (index-value->index 27)))
+    
+    (setf (svref cache (index->index-value in0)) fn0
+	  (svref cache (index->index-value in1)) fn1
+	  (svref cache (index->index-value in2)) fn2)
+    
+    (unless (and (eq (funcall closure in0) 'fn0)
+		 (eq (funcall closure in1) 'fn1)
+		 (eq (funcall closure in2) 'fn2))
+      (error "LAP TEST 1 failed."))))
+
+(defun lap-test-2 ()            
+  (let* ((cg (generating-lap '(cache mask) 
+			     '(arg)
+	       (with-lap-registers ((i0 index)
+				    (i1 index)
+				    (i2 index)
+				    (v0 vector)
+				    (t0 t))
+
+		 (flatten-lap		  
+		   (opcode :move (operand :cvar 'cache) v0)
+		   (opcode :move (operand :arg 'arg) i0)
+		   (opcode :move (operand :cvar 'mask) i1)
+		   (opcode :move (operand :ilogand i0 i1) i2)
+		   (opcode :move (operand :iref v0 i2) t0)
+		   (opcode :jmp t0)))))
+	 (cache (make-array 32))
+	 (mask #b00110)
+	 (closure (funcall cg cache mask))
+	 (in0 (index-value->index #b00010))
+	 (in1 (index-value->index #b01010))
+	 (in2 (index-value->index #b10011)))
+    (fill cache lap-lose)
+    (setf (svref cache (index->index-value in0)) lap-win)
+    
+    (unless (and (eq (funcall closure in0) 'win)
+		 (eq (funcall closure in1) 'win)
+		 (eq (funcall closure in2) 'win))
+      (error "LAP TEST 2 failed."))))
+
+(defun lap-test-3 ()            
+  (let* ((cg (generating-lap '(addend) '(arg)
+	       (with-lap-registers
+		 ((i0 index)
+		  (i1 index)
+		  (i2 index))
+
+		 (flatten-lap		  
+		   (opcode :move (operand :cvar 'addend) i0)
+		   (opcode :move (operand :arg 'arg) i1)
+		   (opcode :move (operand :i+ i0 i1) i2)
+		   (opcode :return i2)))))
+	 (closure (funcall cg (index-value->index 5))))
+    
+    (unless (= (index->index-value (funcall closure (index-value->index 2))) 7)
+      (error "LAP TEST 3 failed."))))
+
+(defun lap-test-4 ()            
+  (let* ((cg (generating-lap '(winner loser) '(arg)
+	       (with-lap-registers ((t0 t))
+		 (flatten-lap
+		   (opcode :move (operand :arg 'arg) t0)
+		   (opcode :eq t0 (operand :constant 'foo) 'win)
+		   (opcode :move (operand :cvar 'loser) t0)
+		   (opcode :jmp t0)
+		   (opcode :label 'win)
+		   (opcode :move (operand :cvar 'winner) t0)
+		   (opcode :jmp t0)))))
+	 (closure (funcall cg #'true #'false)))
+    (unless (and (eq (funcall closure 'foo) 't)
+		 (eq (funcall closure 'bar) 'nil))
+      (error "LAP TEST 4 failed."))))
+
+(defun lap-test-5 ()            
+  (let* ((cg (generating-lap '(array) '(arg)
+	       (with-lap-registers ((r0 vector)
+				    (r1 t)
+				    (r2 index))
+		 (flatten-lap
+		   (opcode :move (operand :cvar 'array) r0)
+		   (opcode :move (operand :arg 'arg) r1)
+		   (opcode :move (operand :constant (index-value->index 0)) r2)
+		   (opcode :move r1 (operand :iref r0 r2))
+		   (opcode :return r1)))))
+	 (array (make-array 1))
+	 (closure (funcall cg array)))
+    (unless (and (=  (funcall closure 1)    (svref array 0))
+		 (eq (funcall closure 'foo) (svref array 0)))
+      (error "LAP TEST 5 failed."))))
+
diff --git a/pcl/lap.text b/pcl/lap.text
new file mode 100644
index 0000000000000000000000000000000000000000..07ef0ca094b925042d9e0ba80e1700877b3bf419
--- /dev/null
+++ b/pcl/lap.text
@@ -0,0 +1,653 @@
+-*- Mode: Text -*-
+
+Copyright (c) 1985, 1986, 1987, 1988, 1989 Xerox Corporation.
+All rights reserved.
+
+Use and copying of this document is permitted.  Any distribution of this
+document must comply with all applicable United States export control
+laws.
+
+Last updated: 6/3/89 by Gregor
+              10/26/89 by Gregor -- added :RETURN, removed :ISHIFT
+
+This file contains documentation of the PCL abstract LAP code.  Any port
+of PCL is required to implement the abstract LAP code interface.  There
+is a portable, relatively good performance implementation in the file
+lap.lisp, port-specific implementations are in that file as well.
+
+The PCL abstract LAP code mechanism exists to provide PCL with a way to
+create high-performance method lookup functions.  Using this mechanism,
+PCL can produce "LAP closures" which do the method lookup.  By allowing
+PCL to specify these closures using abstract LAP code rather that Lisp
+code we hope to achieve the following:
+
+  * Better runtime performance.  By using abstract LAP code, we
+    will get better machine instruction sequences than we would
+    from compiling Lisp code. 
+
+  * Better load and update time performance.  Because it should
+    be possible to "assemble" the LAP code more quickly than
+    compiling Lisp code, PCL will spend less time building the
+    method lookup code.
+
+  * Ability to use PCL without a compiler.  The LAP assembler will
+    still be required but this should be much smaller than the full
+    lisp compiler.
+
+Of course, not all implementations of the LAP code mechanism will
+satisfy all of these goals.  The first is the most important.
+
+In particular, many PCL ports will use the portable LAP implementation.
+KCL will use the portable implementation in all of its ports.  Other
+Lisps may have custom LAP implementations for some ports and use the
+portable implementation for other ports.
+
+Some Lisps will have a custom LAP implementation but will nonetheless
+require the compiler to be loaded to generate LAP closure constructors.
+
+An important point is why we have chosen to take this route rather than
+have each implementation implement the method lookup codes itself.  This
+was done because we are, at PARC, just beginning to study cache behavior
+for CLOS programs.  As we learn more about this we will want to modify
+the caching strategy PCL uses.  This architecture, because it leaves
+PCL to implement caching behavior makes it possible to do this.  Once
+this study is complete, implementations may want to do their own, ultra
+high performance implementations of caching strategies.
+
+
+
+Production of LAP closures is a two step process.  In the first step, a
+port-specific function is called to take abstract LAP code and produce a
+a "lap closure generator".  Lap closure generators are functions which
+are called with a set of closure variable values and return a LAP
+closure.
+
+The intermediary of the lap closure generators provides an important
+optimization.  Because it is assumed that producing the LAP closure
+generator can take much longer than producing a LAP closure from the
+generator, PCL attempts to make only one closure generator for each
+sequence of LAP code.  Because of the way PCL generates the LAP code
+sequences, this is quite easy for it to do.
+
+The rest of this document is divided into six parts.  
+
+  * the metatypes std-instance and fsc-instance
+
+  * an abstraction for simple vector indices
+
+  * important optimizations
+
+  * the port specific function for making lap closure generators
+
+  * the actual abstract LAP code
+
+  * examples
+
+*** The metatypes STD-INSTANCE and FSC-INSTANCE ***
+
+In PCL, instances with metaclass STANDARD-CLASS are represented using
+the metatype STD-INSTANCE.  (Note that in Cinco de Mayo PCL, this
+metatype is called IWMC-CLASS.)  Each port must implement this metatype.
+The metatype could be implemented by the following DEFSTRUCT.
+
+   (defstruct (std-instance 
+                (:predicate std-instance-p)
+                (:conc-name %std-instance-)
+                (:constructor %allocate-std-instance (wrapper slots))
+                (:constructor %allocate-std-instance-1 ())
+                (:print-function print-std-instance))
+     (wrapper nil)
+     (slots nil))
+
+ PCL itself will guarantee correct access to this structure and the
+ accessors and constructors.  With this in mind, the following are
+ important.
+
+ * Being able to type test this structure quickly is critical. See 
+   the :STD-INSTANCE-P opcode.
+
+ * The allocation functions should compile inline, do no argument
+   checking and be as fast as possible.
+
+ * The accessor functions should compile inline, do no checking of their
+   arguments and be as fast as possible.  SETF of the accessors should
+   do the same.
+
+The port is also required to implement the metatype FSC-INSTANCE (called
+FUNCALLABLE-INSTANCE, or FIN for short, in Cinco de Mayo PCL).  Objects
+with this metatype are used, among other things, to implement generic
+functions.  These objects have field structure associated with them and
+are also functions that can be applied to arguments.  The fields are the
+same as those for STD-INSTANCE, the FSC-INSTANCE metatype has
+predicates, print-functions, constructors and accessors as follows:
+
+  fsc-instance-p
+  print-fsc-instance
+  %fsc-instance-wrapper
+  %fsc-instance-slots
+  %allocate-fsc-instance (wrapper slots)
+  %allocate-fsc-instance-1 ()
+
+In addition, objects of metatype FSC-INSTANCE have a property called the
+funcallable instance function.  When an FSC-INSTANCE is applied to
+arguments, the funcallable instance function is what is actually called.
+The funcallable instance function of an FSC-INSTANCE can be changed
+using the function SET-FUNCALLABLE-INSTANCE-FUNCTION.  There is no
+mechanism for obtaining the funcallable instance function of an
+FSC-INSTANCE.
+
+It is possible to implement the FSC-INSTANCE metatype in pure Common
+Lisp. A simple implementation which uses lexical closures as the
+instances and a hash table to record that the lexical closures are of
+metatype FSC-INSTANCE is easy to write.  Unfortunately, this
+implementation adds significant overhead:
+
+   to generic-function-invocation (1 function call)
+   to slot-access (1 function call or one hash table lookup)
+   to class-of a generic-function (1 hash-table lookup)
+
+In addition, it would prevent the FSC-INSTANCEs from being garbage
+collected.  In short, the pure Common Lisp implementation really isn't
+practical.
+
+Note that previous implementations of FINS were always based on the
+lexical closure metatype.  In some ports, that provides poor
+performance.  Those ports may want to consider reimplementing to use the
+compiled code metatype.  In that implementation strategy, LAP closure
+variables would become constants of the compiled code object.
+
+The following note from JonL is of interest when working on a FIN
+implementation:
+
+  Date: Tue, 16 May 89 05:45:56 PDT
+  From: Jon L White <jonl@lucid.com>
+  
+  This isn't a bug in Lucid's compiler -- it's a lurking bug in PCL
+  that will "bite" most implementations where different settings of
+  the compiler optimization switches will produce morphologically
+  different (but of course functionally equivalent) function objects.
+  
+  The difficulty is in how discriminator codes service cache misses.  
+  They  "call out" to (potentially) random functions that will in some 
+  cases "smash" the function object that was actually running as the 
+  discriminator code.  This is all right providing you don't return to 
+  that function frame, but alas ...
+   
+  I know this is a more extensive problem because the code in the
+  port-independent function 'notice-methods-change' goes out of
+  its way to do a tail-recursive call to the function that is going
+  to smash the possibly-executing discriminator code.  Here is the
+  commentary from that code (sic):
+  
+  ;; In order to prevent this we take a simple measure:  we just
+  ;; make sure that it doesn't try to reference our its own closure
+  ;; variables after it makes the dcode change.  This is done by
+  ;; having notice-methods-change-2 do the work of making the change
+  ;; AND calling the actual generic function (a closure variable)
+  ;; over.  This means that at the time the dcode change is made,
+  ;; there is a pointer to the generic function on the stack where
+  ;; it won't be affected by the change to the closure variables.
+  
+  
+  A similar thing should be done in the construction of standard-accessor, 
+  checking, and  caching dcodes.  In an experimental version here at Lucid, 
+  I rewrote  dcode.lisp to do that, and there is no problem with it.  
+  Although that code is somewhat Lucid-specific, it could be of help to 
+  someone who wanted to rewrite the generic dcode.lisp (no pun intended). 
+  Contact me privately if you are interested.
+  
+  Doing a tail-recursive call out of dcodes when there is a cache miss
+  is a good thing, regardless of other problems.  I think one might as
+  well do it.  However, I should point out that in the presence of 
+  multiprocessing, there is another more serious problem that cannot be
+  solved so simply.  Think about what happens when one process decides
+  to update a dcode while another process is still using it; no such
+  stack-maintenance discipline will fix this case.  A tail-recursive
+  exit from the dcode will *immensely* reduce the likelihood that
+  another process can sneak in during the interval in which the dcode
+  requires consistency in its function; but it can't reduce that
+  likelihood to zero.
+  
+  The more desirable thing to do is to put the whole "dcode" down one 
+  more level of indirection through the symbol-function cell of the 
+  generic function.  This is effectively what PCL's 'make-trampoline' 
+  function does, but unfortunately that is not a very efficient approach 
+  when you consider how most compilers will compile it.  Something akin 
+  to the "mattress-pads" in Steve Haflich's code (in the fin.lisp file) 
+  could probably be done for many other implementations as well.
+
+
+*** Index Operations ***
+
+Indexes are an abstraction for indexes into a simple vector.  This
+abstraction is used to make it possible to generate more efficient
+code to access simple vectors.  The idea being that this may make it
+possible to use alternate addressing modes to address these.
+
+The "index value" of an index is defined to be the fixnum of which that
+index is an alternate form.  So, using the Lisp function SVREF with the
+index value of an index accesses the same element as using the index
+with the appropriate access function or operand.
+
+The format of an index is unspecified, but is assumed to be something
+like a fixnum with certain bits ignored.  Accessing a vector using an
+index must be done using the appropriate special accessor function or
+opcode.
+
+Conversion from index values to indices and vice-versa can be done with
+the following functions:
+
+INDEX-VALUE->INDEX (index-value)
+INDEX->INDEX-VALUE (index)
+
+
+The following constant indicates the maximum index value an index can
+have in a given port.  This must be at least 2^16.
+
+INDEX-VALUE-LIMIT  - a fixnum, must be at least 2^16.
+
+
+MAKE-INDEX-MASK (<cache-size> <line-size>)
+
+This function is used to make index masks.  Because I am lazy, I show an
+implementation of it in the common case where indexes are just fixnums:
+
+  (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))
+
+*** Optimizations ***
+
+This section discusses two important optimizations related to LAP
+closures.  The first relates to calling LAP closures themselves, the
+second relates to calling other functions from LAP closures.
+
+The important point about calling LAP closures is that almost all of the
+time, LAP closures will be used as the funcallable-instance-function of
+funcallable instances.  It is required that LAP closures be funcallable
+themselves, but usually they will be stored in a FIN and the fin will
+then be funcalled.  This brings up several optimizations, including ones
+having to do with access to the closure variables of a LAP closure.
+
+When a LAP closure is used to do method lookup, the function the LAP
+closure ends up calling has the same number of required arguments as the
+LAP closure itself.  Since the LAP closure must check its required
+arguments to do the lookup, it is redundant for the function called to
+do so as well.  Since LAP closures do all calls in a tail recursive way,
+it should even be possible to optimize out certain parts of the normal
+stack frame initialization.
+
+A similar situation occurs between effective method functions and the
+individual method functions; the difference is that in effective method
+functions, the calls are not necessarily tail recursive.
+
+Consequently, it would be nice to have a way to call certain functions
+and inhibit the checking of required arguments.  This is made possible
+by use of the PCL-FAST-APPLY and PCL-FAST-FUNCALL macros together with
+the PCL-FAST-CALL compiler declaration.
+
+The PCL-FAST-CALL compiler declaration declares that a function may be
+fast called.  Not all callers of the function will necessarily fast call
+it, but most probably will.  The :JMP opcode can only be used to call a
+function compiled with the PCL-FAST-CALL declaration.
+
+The PCL-FAST-APPLY and PCL-FAST-FUNCALL macros are used to fast call a
+function.  The function argument must be a compiled function that has
+the PCL-FAST-CALL compiler declaration in its lambda declarations.
+
+The basic idea is that the PCL-FAST-CALL compiler declaration causes the
+compiler to set up an additional entrypoint to the function.  This
+entrypoint comes after checking of required arguments but before
+processing of other arguments.
+
+Note:  When FAST-APPLY is used, the required arguments will be given as
+separate arguments and all other arguments will appear as a single
+spread argument.  For example:
+
+(let ((fn (compile () '(lambda (a b &optional (c 'z))
+                         (declare (pcl-fast-call))
+                         (list a b c)))))
+
+  (pcl-fast-apply fn 'x 'y ())          ;legal
+  (pcl-fast-apply fn 'x 'y '(foo))      ;legal
+  (pcl-fast-apply fn '(a b c))          ;illegal
+  )
+
+*** Producing LAP Closure Generators ***
+
+Each implementation of the LAP code mechanism must provide a port
+specific function making lap closure generators.  In the portable
+implementation, this function is called PLAP-CLOSURE-GENERATOR.  In
+ExCL it should be called EXCL-LAP-CLOSURE-GENERATOR etc.
+
+At any time, the value of the variable *make-lap-closure-generator* is a
+symbol which names the function currently being used to make lap closure
+generators.
+
+The port specific function must accept arguments as follows:
+
+PLAP-CLOSURE-GENERATOR (<closure-vars>
+                        <args>
+                        <index-registers>
+                        <simple-vector-registers>
+                        <lap-code>)
+
+This returns a lap-closure generator.  A lap-closure generator is a
+function which is called with a number of arguments equal to the length
+of <closure-vars>.  These arguments are the values of the closure
+variables for the lap closure.  These values cannot be changed once the
+LAP closure is created.   PCL takes care of keeping track of
+lap-closure-generators it already has on hand and reusing them.  The
+function RESET-LAP-CLOSURE-GENERATORS can be called to force PCL to
+forget all the lap closure generators it has remembered.
+
+  <args> 
+
+A list of symbols.  This provides a way to name particular arguments to
+the LAP closure. Arguments which will not be referenced by name are
+given as NIL. All required arguments to the LAP closure are explicitly
+included (perhaps as NIL).  If &REST appears at the end of arguments it
+means that non-required arguments are allowed, these will be processed
+by the methods.  If &REST does not appear at the end of arguments, the
+lap closure should signal an error if more than the indicated number of
+arguments are supplied.
+
+Examples:
+
+ -  (obj-0 obj-1)
+
+    Specifies a two argument lap closure.  If more or less than
+    two arguments are supplied an error is signalled.  Within
+    the actual lap code, both arguments can be referenced by
+    name (see the :ARG operand).
+
+ -  (obj-0 nil &rest)
+
+    Specifies a two or more argument lap closure.  If less than
+    two arguments are supplied an error is signalled.  Within
+    the actual lap code, the first argument can be referenced by
+    name (see the :ARG operand).
+
+
+  <closure-vars>
+
+A list of symbols.  The closure will have these as closure variables.
+Within the lap code these can be accessed using the :CVAR operand.  The
+lap code cannot change these values.  SET-FUNCALLABLE-INSTANCE-FUNCTION
+is permitted to have the special knowledge that there are at most ?? of
+these and to be prepared to do something special when the funcallable
+instance function of a funcallable instance is set to a lap closure.
+
+  <index-registers>
+
+A list of register numbers.  These registers will be used only to hold
+indexes.  Other registers may be used to hold indexes as well, but the
+only values put into these registers will be indexes.
+
+  <simple-vector-registers>
+
+A list of register numbers.  These registers will be used only to hold
+simple-vectors.  Other registers may be used to hold simple-vectors as
+well, but the only values put into these registers will be
+simple-vectors.
+
+
+  <lap-code>
+
+The actual lap code for this closure.  This is a list of LAP code
+opcodes.  See the section "Abstract LAP Code" for more details.
+
+Each implementation must also supply a function named PRE-MAKE-xxx where
+xxx is the same as the name of its make-lap-closure-generator function.
+The macro doesn't evaluate its arguments, and when it appears in a file
+it should try to do some of the work at load time.  It might appear in a
+file like this:
+
+(eval-when (load)
+  (setq 1-arg-std-lap 
+        (pre-make-plap-closure-generator ...)))
+
+*** Abstract LAP Code ***
+
+Each lap code operand has the form: (opcode operand1 ... operandn).
+
+In some cases, the distinction between an operand and an opcode is
+somewhat arbitrary.  In general, opcodes have a significant "action"
+component to their behavior.  Operands select a piece of data to operate
+on.  Some operands select their data in a more complex way, but they are
+operands anyways.
+
+All data must be in a register before it can be operated on.   This
+requirement means that the only place a non-register operand can appear
+is as the first argument to the :move opcode.  (Actually, there is one
+other exception, a :iref operand can be the target of a move as well.)
+Moreover, only register operands can appear as the second argument to
+the :move opcode and this register must not appear in the <from>
+operand.
+
+>> The operands are:
+ 
+ (:reg <n>)
+   
+A pseudo register.  <n> is an integer in the range [0 , 31].
+
+A particular implementation can map this to a real register, a memory
+location or the stack.  The abstract LAP code itself does not include
+the notion of a stack.
+
+PCL will attempt to optimize register use in two ways.  PCL itself will
+attempt to re-use registers whenever possible.  That is, the port should
+not have to worry with doing live register analysis for the registers.
+In addition, PCL will consider lower numbered registers to be "faster"
+than higher numbered ones.
+
+
+ (:cvar <name>)
+
+A closure variable of the lap-closure.  <name> is a symbol.
+
+
+ (:arg <name>)
+
+An argument to the LAP closure.  <name> is a symbol.
+
+ (:std-wrapper <from>)
+ (:fsc-wrapper <from>)
+ (:built-in-wrapper <from>)
+ (:structure-wrapper <from>)
+ (:other-wrapper <from>)
+
+Get the class wrapper of <from>.  For std-instances and fsc-instances
+this just fetches the wrapper field.  The specific port is required to
+implement fast access to the wrappers of built-in, structure and other
+metatypes.  A callback mechanism allows the port to ask PCL to generate
+a class and wrapper for objects for which no class and wrapper exists
+yet.  This mechanism is <<to be spec'd out>>.
+
+
+ (:std-slots <operand>)
+ (:fsc-slots <operand>)
+
+Fetch the slots field of a std-instance or a fsc-instance.
+
+ (:constant <constant>)
+
+This just allows inline constants. <constant> can be any Lisp object.
+
+The following operands operate on indexes.  Each is patterned after a
+Lisp function which would have a corresponding effect on the index value
+of the index.
+
+ (:i1+ <index>)
+ (:i+ <index-1> <index-2>)
+ (:i- <index-1> <index-2>)
+ (:ilogand <index-1> <index-2>)
+ (:ilogxor <index-1> <index-2>)
+
+Like the corresponding Lisp functions.  
+
+
+ (:iref <vector> <index>)
+
+Like the SVREF function.  <vector> must be a simple vector.
+
+ (:cref <vector> <constant>)
+
+The :cref operand is for constant vector references.  <constant> must be
+a fixnum.
+
+>> The opcodes are:
+
+ (:move <from> <to>)
+
+A full word move operation.  
+
+
+ (:eq <from1> <from2> <label>)
+ (:neq <from1> <from2> <label>)
+
+EQ and NOT EQ conditional branches.  If the value contained in <from1>
+is EQ (or not) to the value contained in <from2>, jump to <label>.
+Otherwise continue execution at the next opcode.  <label> is a symbol.
+
+ (:fix= <from1> <from2> <label>)
+
+A fixnum = conditional branch.
+
+ (:izerop <from> <label>)
+
+Jump to label if and only if the index <from> is 0.
+
+ (:std-instance-p <from> <destination-label>)
+ (:fsc-instance-p <from> <destination-label>)
+ (:built-in-instance-p <from> <destination-label>)
+ (:structure-instance-p <from> <destination-label>)
+
+Test the metatype of <from> and dispatch.  If the metatype of from is of
+the specified type execution jumps to <destination-label>.  Otherwise,
+execution proceeds normally at the next opcode.  See the :xxx-wrapper
+operands.
+
+ (:jmp <function>)
+
+fcn contains a function to call.  This must be a compiled function,
+which had the PCL-FAST-CALL declaration in it.  The call should be "tail
+recursive" in that whatever values it returns should be returned
+immediately from the LAP closure itself.
+
+Method lookup is implemented by finding a function in the cache and then
+using :JMP to call it.  The various kinds of traps are implemented by
+using :JMP to call a trap function that was stored in one of the closure
+variables.
+
+ (:return <value>)
+
+Return immediately from the LAP closure.  <value> is the single value to
+return.
+
+In certain cases of method lookup when all the methods are accessor methods, 
+there is an important optimization which implements the slot access in the 
+discriminating function itself.  This opcode is used in that case.
+
+ (:label <label>)
+
+Identifies a point in the lap code.  <label> is a symbol.  This can be
+the target of any of the control transfer opcodes (:GO, :EQ, :NEQ,
+:FIX=, :STD-INSTANCE-P, :FSC-INSTANCE-P, :STRUCTURE-INSTANCE-P,
+:BUILT-IN-INSTANCE-P)
+
+ (:go <label>)
+
+Jump to the label <label>.  <label> is a symbol.
+
+*** Examples ***
+
+Here is an example of the use of the abstract LAP mechanism.  It doesn't
+use all operands or opcodes, but it is representative of the LAP
+sequences PCL will use.
+
+Several things are worth noting:
+  * This is, I believe, just about the simplest such sequence.  There
+    are some others of comparable simplicity, but none much simpler.
+
+  * A total of only 5 registers are used.  I haven't checked, but I
+    am pretty sure most all such code sequences will get by with 16
+    or less and many will stay under 8.
+
+(defun make-1-arg-std-dfun ()
+  (let ((cg
+	  (making-lap-closure-generator
+	    (initialize-lap-cvars '(cache mask reflect trap))	
+	    (initialize-lap-args '(a0))
+	    (initialize-lap-registers 4 4 3)
+	    (let ((cache (allocate-lap-register 'simple-vector))
+		  (count (allocate-lap-register))
+		  (wrapper (allocate-lap-register))
+		  (index (allocate-lap-register 'index))
+		  (t1 (allocate-lap-register))
+		  (t2 (allocate-lap-register))
+		  (i1 (allocate-lap-register 'index))
+		  (i2 (allocate-lap-register 'index)))
+
+	      (opcode :move (operand :cvar 'cache) cache)
+	      (opcode :move (operand :arg 'a0) t1)	      
+	      (opcode :std-instance-p t1 'std-instance)
+	      (opcode :go 'trap)
+	      (opcode :label 'std-instance)
+	      ;;
+	      ;; The stable register pattern for the rest of the code is:
+	      ;;   cache    Cache
+	      ;;   count    Cache count
+	      ;;   wrapper  Wrapper
+	      ;;   index    index under consideration
+	      ;;
+	      ;; Whenever we jump to HIT, this pattern must be in force.
+	      ;;
+	      (opcode :move (operand :std-wrapper t1) wrapper);
+	      (opcode :move (operand :cref cache 0) count)    ;
+	      (opcode :move (operand :cref wrapper 0) i2)     ;wrapper-no -> i2
+	      (opcode :move (operand :cvar 'mask) i1)	      ;mask       -> i1
+	      (opcode :move (operand :ilogand i1 i2) index)   ;
+						              ;
+	      (opcode :move (operand :iref cache index) t1)   ;key        -> t1
+	      (opcode :eq t1 wrapper 'hit)                    ;
+	      (opcode :move (operand :cvar 'reflect) i1)      ;reflect    -> i1
+	      (opcode :move index i2)		              ;index      -> i2
+	      (opcode :move (operand :i- i1 i2) index)	      ;
+	      (opcode :move (operand :iref cache index) t1)   ;key        -> t1
+	      (opcode :eq t1 wrapper 'hit)                    ;
+	      (opcode :go 'trap)
+	      
+	      ;;
+	      ;; To do the hit, we use registers as follows:
+	      ;;   0   cache comes in here
+	      ;;   1   cache count comes in here
+	      ;;   2   use this for the function
+	      ;;   3   index comes in here
+	      ;;   4   1+ index, then new count
+	      ;;   
+	      (opcode :label 'hit)
+	      (opcode :move (operand :i1+ index) i1)
+	      (opcode :move (operand :iref cache i1) t1)
+
+	      (opcode :move (operand :cref cache 0) t2)
+	      (opcode :fix= count t2 'call)
+	      (opcode :go 'trap)
+
+	      (opcode :label 'call)
+	      (opcode :jmp t1)
+
+	      (opcode :label 'trap)
+	      (opcode :move (operand :cvar 'trap) t1)
+	      (opcode :jmp t1)))))
+
+    (funcall cg
+	     (make-array 16)
+	     (make-index-mask 16 2)
+	     (- 16 2)
+	     #'(lambda (a)
+		 (declare (pcl-fast-call) (ignore a))
diff --git a/pcl/low.lisp b/pcl/low.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..512be99bda04cefcb9317a052ccd0f2080ff2c34
--- /dev/null
+++ b/pcl/low.lisp
@@ -0,0 +1,290 @@
+;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+;;; 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.
+;;;
+;;; But, experience suggests that MOST Common Lisp implementors will want
+;;; to customize some of the code in this file to make PCL run better in
+;;; their implementation.  The code in this file has been separated and
+;;; heavily commented to make that easier.
+;;;
+;;; Implementation-specific version of this file already exist for:
+;;; 
+;;;    Symbolics Genera family     genera-low.lisp
+;;;    Lucid Lisp                  lucid-low.lisp
+;;;    Xerox 1100 family           xerox-low.lisp
+;;;    ExCL (Franz)                excl-low.lisp
+;;;    Kyoto Common Lisp           kcl-low.lisp
+;;;    Vaxlisp                     vaxl-low.lisp
+;;;    CMU Lisp                    cmu-low.lisp
+;;;    H.P. Common Lisp            hp-low.lisp
+;;;    Golden Common Lisp          gold-low.lisp
+;;;    Ti Explorer                 ti-low.lisp
+;;;    
+;;;
+;;; These implementation-specific files are loaded after this file.  Because
+;;; none of the macros defined by this file are used in functions defined by
+;;; this file the implementation-specific files can just contain the parts of
+;;; this file they want to change.  They don't have to copy this whole file
+;;; and then change the parts they want.
+;;;
+;;; If you make changes or improvements to these files, or if you need some
+;;; low-level part of PCL re-modularized to make it more portable to your
+;;; system please send mail to CommonLoops.pa@Xerox.com.
+;;;
+;;; Thanks.
+;;; 
+
+(in-package 'pcl)
+
+(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 PCL 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 PCL 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?
+;;;
+(defmacro without-interrupts (&body body)
+  `(macrolet ((interrupts-on () ())
+	      (interrupts-off () ()))
+     (progn ,.body)))
+
+
+;;;
+;;;  Very Low-Level representation of instances with meta-class standard-class.
+;;;
+(defstruct (std-instance (:predicate std-instance-p)
+			 (:conc-name %std-instance-)
+			 (:constructor %%allocate-instance--class ())
+			 (:print-function print-std-instance))
+  (wrapper nil)
+  (slots nil))
+
+(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 PCL (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
+  ;;
+;;; Given something which is functionp, function-arglist should return the
+;;; argument list for it.  PCL 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 pcl 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))
+
+(defun function-pretty-arglist (function)
+  (declare (ignore function))
+  ())
+
+(defsetf function-pretty-arglist set-function-pretty-arglist)
+
+(defun set-function-pretty-arglist (function new-value)
+  (declare (ignore function))
+  new-value)
+
+;;;
+;;; 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 (function 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 (function new-name uninterned-name)
+  (declare (ignore new-name uninterned-name))
+  function)
+
+(defun intern-function-name (name)
+  (cond ((symbolp name) name)
+	((listp name)
+	 (intern (let ((*package* *the-pcl-package*)
+		       (*print-case* :upcase)
+		       (*print-gensym* 't))
+		   (format nil "~S" name))
+		 *the-pcl-package*))))
+
+
+;;;
+;;; COMPILE-LAMBDA
+;;;
+;;; This is like the Common Lisp function COMPILE.  In fact, that is what
+;;; it ends up calling.  The difference is that it deals with things like
+;;; watching out for recursive calls to the compiler or not calling the
+;;; compiler in certain cases or allowing the compiler not to be present.
+;;;
+;;; This starts out with several variables and support functions which 
+;;; should be conditionalized for any new port of PCL.  Note that these
+;;; default to reasonable values, many new ports won't need to look at
+;;; these values at all.
+;;;
+;;; *COMPILER-PRESENT-P*        NIL means the compiler is not loaded
+;;;
+;;; *COMPILER-SPEED*            one of :FAST :MEDIUM or :SLOW
+;;;
+;;; *COMPILER-REENTRANT-P*      T   ==> OK to call compiler recursively
+;;;                             NIL ==> not OK
+;;;
+;;; function IN-THE-COMPILER-P  returns T if in the compiler, NIL otherwise
+;;;                             This is not called if *compiler-reentrant-p*
+;;;                             is T, so it only needs to be implemented for
+;;;                             ports which have non-reentrant compilers.
+;;;
+;;;
+(defvar *compiler-present-p* t)
+
+(defvar *compiler-speed*
+	#+(or KCL IBCL GCLisp) :slow
+	#-(or KCL IBCL GCLisp) :fast)
+
+(defvar *compiler-reentrant-p*
+	#+(and (not XKCL) (or KCL IBCL)) nil
+	#-(and (not XKCL) (or KCL IBCL)) t)
+
+(defun in-the-compiler-p ()
+  #+(and (not xkcl) (or KCL IBCL))compiler::*compiler-in-use*
+  #+gclisp (typep (eval '(function (lambda ()))) 'lexical-closure)
+  )
+
+(defun compile-lambda (lambda &optional (desirability :fast))
+  (cond ((null *compiler-present-p*)
+	 (compile-lambda-uncompiled lambda))
+	((and (null *compiler-reentrant-p*)
+	      (in-the-compiler-p))
+	 (compile-lambda-deferred lambda))
+	((eq desirability :fast)
+	 (compile nil lambda))
+	((and (eq desirability :medium)
+	      (member *compiler-speed* '(:fast :medium)))
+	 (compile nil lambda))
+	((and (eq desirability :slow)
+	      (eq *compiler-speed* ':fast))
+	 (compile nil lambda))
+	(t
+	  (compile-lambda-uncompiled lambda))))
+
+(defun compile-lambda-uncompiled (uncompiled)
+  #'(lambda (&rest args) (apply uncompiled args)))
+
+(defun compile-lambda-deferred (uncompiled)
+  (let ((compiled nil))
+    #'(lambda (&rest args)
+	(if compiled
+	    (apply compiled args)
+	    (if (in-the-compiler-p)
+		(apply uncompiled args)
+		(progn (setq compiled (compile nil uncompiled))
+		       (apply compiled args)))))))
+
+(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))
+  ())
+
diff --git a/pcl/lucid-low.lisp b/pcl/lucid-low.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..eab1bb832692ec627e7210a0dc3152fd9452b6a2
--- /dev/null
+++ b/pcl/lucid-low.lisp
@@ -0,0 +1,277 @@
+;;; -*- Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;; 
+;;; This is the Lucid lisp version of the file portable-low.
+;;;
+;;; Lucid:               (415)329-8400
+;;; 
+
+(in-package 'pcl)
+
+;;; First, import some necessary "internal" or Lucid-specific symbols
+
+(eval-when (eval compile load)
+
+(let ((importer
+        #+LCL3.0 #'sys:import-from-lucid-pkg
+	#-LCL3.0 (let ((x (find-symbol "IMPORT-FROM-LUCID-PKG" "LUCID")))
+		   (if (and x (fboundp x))
+		       (symbol-function x)
+		       ;; Only the #'(lambda (x) ...) below is really needed, 
+		       ;;  but when available, the "internal" function 
+		       ;;  'import-from-lucid-pkg' provides better checking.
+		       #'(lambda (name)
+			   (import (intern name "LUCID")))))))
+  ;;
+  ;; We need the following "internal", undocumented Lucid goodies:
+  (mapc importer '("%POINTER" "DEFSTRUCT-SIMPLE-PREDICATE"
+		   #-LCL3.0 "LOGAND&" "%LOGAND&" #+VAX "LOGAND&-VARIABLE"))
+
+  ;;
+  ;; For without-interrupts.
+  ;; 
+  #+LCL3.0
+  (mapc importer '("*SCHEDULER-WAKEUP*" "MAYBE-CALL-SCHEDULER"))
+
+  ;;
+  ;; We import the following symbols, because in 2.1 Lisps they have to be
+  ;;  accessed as SYS:<foo>, whereas in 3.0 lisps, they are homed in the
+  ;;  LUCID-COMMON-LISP package.
+  (mapc importer '("ARGLIST" "NAMED-LAMBDA" "*PRINT-STRUCTURE*"))
+  ;;
+  ;; We import the following symbols, because in 2.1 Lisps they have to be
+  ;;  accessed as LUCID::<foo>, whereas in 3.0 lisps, they have to be
+  ;;  accessed as SYS:<foo>
+  (mapc importer '(
+		   "NEW-STRUCTURE"   	"STRUCTURE-REF"
+		   "PROCEDUREP"     	"PROCEDURE-SYMBOL"
+		   "PROCEDURE-REF" 	"SET-PROCEDURE-REF" 
+		   ))
+; ;;
+; ;;  The following is for the "patch" to the general defstruct printer.
+; (mapc importer '(
+; 	           "OUTPUT-STRUCTURE" 	  "DEFSTRUCT-INFO"
+;		   "OUTPUT-TERSE-OBJECT"  "DEFAULT-STRUCTURE-PRINT" 
+;		   "STRUCTURE-TYPE" 	  "*PRINT-OUTPUT*"
+;		   ))
+  ;;
+  ;; The following is for a "patch" affecting compilation of %logand&.
+  ;; On APOLLO, Domain/CommonLISP 2.10 does not include %logand& whereas
+  ;; Domain/CommonLISP 2.20 does; Domain/CommonLISP 2.20 includes :DOMAIN/OS
+  ;; on *FEATURES*, so this conditionalizes correctly for APOLLO.
+  #-(or (and APOLLO DOMAIN/OS) LCL3.0 VAX) 
+  (mapc importer '("COPY-STRUCTURE"  "GET-FDESC"  "SET-FDESC"))
+  
+  nil)
+
+;; end of eval-when
+
+)
+	
+
+;;;
+;;; Patch up for the fact that the PCL package creation in defsys.lisp
+;;;  will probably have an explicit :use list ??
+;;;
+;;;  #+LCL3.0 (use-package *default-make-package-use-list*)
+
+
+
+
+(defmacro %logand (x y)
+  #-VAX `(%logand& ,x ,y)
+  #+VAX `(logand&-variable ,x ,y))
+
+;;; Fix for VAX LCL
+#+VAX
+(defun logand&-variable (x y)
+  (logand&-variable x y))
+
+;;; Fix for other LCLs
+#-(or (and APOLLO DOMAIN/OS) LCL3.0 VAX)
+(eval-when (compile load eval)
+
+(let* ((logand&-fdesc (get-fdesc 'logand&))
+       (%logand&-fdesc (copy-structure logand&-fdesc)))
+  (setf (structure-ref %logand&-fdesc 0 t) '%logand&)
+  (setf (structure-ref %logand&-fdesc 7 t) nil)
+  (setf (structure-ref %logand&-fdesc 8 t) nil)
+  (set-fdesc '%logand& %logand&-fdesc))
+
+(eval-when (load)
+  (defun %logand& (x y) (%logand& x y)))
+
+(eval-when (eval)
+  (compile '%logand& '(lambda (x y) (%logand& x y))))
+
+);#-(or LCL3.0 (and APOLLO DOMAIN/OS) VAX)
+
+;;;
+;;; From: JonL
+;;; Date: November 28th, 1988
+;;; 
+;;;  Here's a better attempt to do the without-interrupts macro for LCL3.0.
+;;;  For the 2.1  release, maybe you should just ignore it (i.e, turn it 
+;;;  into a PROGN and "take your chances") since there isn't a uniform way
+;;;  to do inhibition.  2.1 has interrupts, but no multiprocessing.
+;;;
+;;;  The best bet for protecting the cache is merely to inhibit the
+;;;  scheduler, since asynchronous interrupts are only run when "scheduled".
+;;;  Of course, there may be other interrupts, which can cons and which 
+;;;  could cause a GC; but at least they wouldn't be running PCL type code.
+;;;
+;;;  Note that INTERRUPTS-ON shouldn't arbitrarily enable scheduling again,
+;;;  but rather simply restore it to the state outside the scope of the call
+;;;  to WITHOUT-INTERRUPTS.  Note also that an explicit call to 
+;;;  MAYBE-CALL-SHEDULER must be done when "turning interrupts back on", if
+;;;  there are any interrupts/schedulings pending; at least the test to see
+;;;  if any are pending is very fast.
+
+#+LCL3.0
+(defmacro without-interrupts (&body body)
+  `(macrolet ((interrupts-on  ()
+		`(when (null outer-scheduling-state)
+		   (setq lcl:*inhibit-scheduling* nil)
+		   (when *scheduler-wakeup* (maybe-call-scheduler))))
+	      (interrupts-off () 
+		'(setq lcl:*inhibit-scheduling* t)))
+     (let ((outer-scheduling-state lcl:*inhibit-scheduling*))
+       (prog1 (let ((lcl:*inhibit-scheduling* t)) . ,body)
+	      (when (and (null outer-scheduling-state) *scheduler-wakeup*)
+		(maybe-call-scheduler))))))
+
+
+;;; The following should override the definitions provided by lucid-low.
+;;;
+#+(or LCL3.0 (and APOLLO DOMAIN/OS))
+(defstruct-simple-predicate  std-instance std-instance-p)
+
+
+(defun set-function-name-1 (fn new-name ignore)
+  (declare (ignore ignore))
+  (if (not (procedurep fn))
+      (error "~S is not a procedure." fn)
+      (if (compiled-function-p fn)
+	  ;; This is one of:
+	  ;;   compiled-function, funcallable-instance, compiled-closure
+	  ;;   or a macro.
+	  ;; So just go ahead and set its name.
+	  (set-procedure-ref fn procedure-symbol new-name)
+	  ;; This is an interpreted function.
+	  ;; Seems like any number of different things can happen depending
+	  ;; vaguely on what release you are running.  Try to do something
+	  ;; reasonable.
+	  (let ((symbol (procedure-ref fn procedure-symbol)))
+	    (cond ((symbolp symbol)
+		   ;; In fact, this is the name of the procedure.
+		   ;; Just set it.
+		   (set-procedure-ref fn procedure-symbol new-name))
+		  ((and (listp symbol)
+			(eq (car symbol) 'lambda))
+		   (setf (car symbol) 'named-lambda
+			 (cdr symbol) (cons new-name (cdr symbol))))
+		  ((eq (car symbol) 'named-lambda)
+		   (setf (cadr symbol) new-name))))))		  
+  fn)
+
+(defun function-arglist (fn)
+  (arglist fn))
+
+  ;;   
+;;;;;; printing-random-thing-internal
+  ;;
+(defun printing-random-thing-internal (thing stream)
+  (format stream "~O" (%pointer thing)))
+
+
+;;;
+;;; 16-Feb-90 Jon L White
+;;;
+;;; A Patch provide specifically for the benefit of PCL, in the Lucid 3.0
+;;;  release environment.  This adds type optimizers for FUNCALL so that
+;;;  forms such as:
+;;;
+;;;     (FUNCALL (THE PROCEDURE F) ...)
+;;;
+;;;  and:
+;;;
+;;;     (LET ((F (Frobulate)))
+;;;       (DECLARE (TYPE COMPILED-FUNCTION F))
+;;;       (FUNCALL F ...))
+;;;
+;;;  will just jump directly to the procedure code, rather than waste time
+;;;  trying to coerce the functional argument into a procedure.
+;;;
+
+
+(in-package "LUCID")
+
+
+;;; (DECLARE-MACHINE-CLASS COMMON)
+(set-up-compiler-target 'common)
+
+
+(set-function-descriptor 'FUNCALL
+  :TYPE  'LISP
+  :PREDS 'NIL
+  :EFFECTS 'T
+  :OPTIMIZER  #'(lambda (form &optional environment) 
+		  (declare (ignore form environment))
+		  (let* ((fun (second form))
+			 (lambdap (and (consp fun) 
+				       (eq (car fun) 'function)
+				       (consp (second fun))
+				       (memq (car (second fun))
+					     '(lambda internal-lambda)))))
+		    (if (not lambdap) 
+			form
+			(alphatize 
+			  (cons (second fun) (cddr form)) environment))))
+  :FUNCTIONTYPE '(function (function &rest t) (values &rest t))
+  :TYPE-DISPATCH `(((PROCEDURE &REST T) (VALUES &REST T)
+		    ,#'(lambda (anode fun &rest args) 
+			 (declare (ignore anode fun args))
+			 `(FAST-FUNCALL ,fun ,@args)))
+		   ((COMPILED-FUNCTION &REST T)  (VALUES &REST T)
+		    ,#'(lambda (anode fun &rest args) 
+			 (declare (ignore anode fun args))
+			 `(FAST-FUNCALL ,fun ,@args))))
+  :LAMBDALIST '(FN &REST ARGUMENTS)
+  :ARGS '(1 NIL)
+  :VALUES '(0 NIL)
+  )
+
+(def-compiler-macro fast-funcall (&rest args &environment env)
+  (if (COMPILER-OPTION-SET-P :READ-SAFETY ENV)
+      `(FUNCALL-SUBR . ,args)
+      `(&FUNCALL . ,args)))
+
+
+
+(setf (symbol-function 'funcall-subr) #'funcall)
+
+
+;;; (UNDECLARE-MACHINE-CLASS)
diff --git a/pcl/macros.lisp b/pcl/macros.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..791eafc4eb804492c406ccb77295cc789f972ea4
--- /dev/null
+++ b/pcl/macros.lisp
@@ -0,0 +1,434 @@
+;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+;;; 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 'pcl)
+
+(proclaim '(declaration
+	     #-Genera values          ;I use this so that Zwei can remind
+				      ;me what values a function returns.
+	     
+	     #-Genera arglist	      ;Tells me what the pretty arglist
+				      ;of something (which probably takes
+				      ;&rest args) is.
+
+	     #-Genera indentation     ;Tells ZWEI how to indent things
+			              ;like defclass.
+	     class
+	     variable-rebinding
+	     pcl-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 true (&rest ignore) (declare (ignore ignore)) t)
+(defun false (&rest ignore) (declare (ignore ignore)) nil)
+(defun zero (&rest ignore) (declare (ignore ignore)) 0)
+
+(defun make-plist (keys vals)
+  (if (null vals)
+      ()
+      (list* (car keys)
+	     (car vals)
+	     (make-plist (cdr keys) (cdr vals)))))
+
+(defun remtail (list tail)
+  (if (eq list tail) () (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 ()))
+    (dolist (var vars)
+      (push `(if (or (symbolp ,var)
+                     (numberp ,var)
+                     (and (listp ,var)
+			  (member (car ,var) '(quote 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)))
+)
+
+#+Lucid
+(eval-when (compile load eval)
+  (eval `(defstruct ,(intern "FASLESCAPE" (find-package 'lucid)))))
+
+(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)))))
+
+;;; A simple version of destructuring-bind.
+
+;;; This does no more error checking than CAR and CDR themselves do.  Some
+;;; attempt is made to be smart about preserving intermediate values.  It
+;;; could be better, although the only remaining case should be easy for
+;;; the compiler to spot since it compiles to PUSH POP.
+;;;
+;;; Common Lisp BUG:
+;;;    Common Lisp should have destructuring-bind.
+;;;    
+(defmacro destructuring-bind (pattern form &body body)
+  (multiple-value-bind (ignore declares body)
+      (extract-declarations body)
+    (declare (ignore ignore))
+    (multiple-value-bind (setqs binds)
+	(destructure pattern form)
+      `(let ,binds
+	 ,@declares
+	 ,@setqs
+	 (progn .destructure-form.)
+	 . ,body))))
+
+(eval-when (compile load eval)
+(defun destructure (pattern form)
+  (declare (values setqs binds))
+  (let ((*destructure-vars* ())
+	(setqs ()))
+    (declare (special *destructure-vars*))
+    (setq *destructure-vars* '(.destructure-form.)
+	  setqs (list `(setq .destructure-form. ,form))
+	  form '.destructure-form.)
+    (values (nconc setqs (nreverse (destructure-internal pattern form)))
+	    (delete nil *destructure-vars*))))
+
+(defun destructure-internal (pattern form)
+  ;; When we are called, pattern must be a list.  Form should be a symbol
+  ;; which we are free to setq containing the value to be destructured.
+  ;; Optimizations are performed for the last element of pattern cases.
+  ;; we assume that the compiler is smart about gensyms which are bound
+  ;; but only for a short period of time.
+  (declare (special *destructure-vars*))
+  (let ((gensym (gensym))
+	(pending-pops 0)
+	(var nil)
+	(setqs ()))
+    (labels
+        ((make-pop (var form pop-into)
+	   (prog1 
+	     (cond ((zerop pending-pops)
+		    `(progn ,(and var `(setq ,var (car ,form)))
+			    ,(and pop-into `(setq ,pop-into (cdr ,form)))))
+		   ((null pop-into)
+		    (and var `(setq ,var ,(make-caxr pending-pops form))))
+		   (t
+		    `(progn (setq ,pop-into ,(make-cdxr pending-pops form))
+			    ,(and var `(setq ,var (pop ,pop-into))))))
+	     (setq pending-pops 0))))
+      (do ((pat pattern (cdr pat)))
+	  ((null pat) ())
+	(if (symbolp (setq var (car pat)))
+	    (progn
+	      #-:coral (unless (memq var '(nil ignore))
+			 (push var *destructure-vars*))
+	      #+:coral (push var *destructure-vars*)	      
+	      (cond ((null (cdr pat))
+		     (push (make-pop var form ()) setqs))
+		    ((symbolp (cdr pat))
+		     (push (make-pop var form (cdr pat)) setqs)
+		     (push (cdr pat) *destructure-vars*)
+		     (return ()))
+		    #-:coral
+		    ((memq var '(nil ignore)) (incf pending-pops))
+		    #-:coral
+		    ((memq (cadr pat) '(nil ignore))
+		     (push (make-pop var form ()) setqs)
+		     (incf pending-pops 1))
+		    (t
+		     (push (make-pop var form form) setqs))))
+	    (progn
+	      (push `(let ((,gensym ()))
+		       ,(make-pop gensym
+				  form
+				  (if (symbolp (cdr pat)) (cdr pat) form))
+		       ,@(nreverse
+			   (destructure-internal
+			     (if (consp pat) (car pat) pat)
+			     gensym)))
+		    setqs)
+	      (when (symbolp (cdr pat))
+		(push (cdr pat) *destructure-vars*)
+		(return)))))
+      setqs)))
+)
+
+
+(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)
+  (declare (ignore thing stream))
+  nil)
+
+  ;;   
+;;;;;; 
+  ;;
+
+(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\ PCL\ FIND-CLASS ,new-value ,symbol))
+
+(defun SETF\ PCL\ 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)))
+
+(defun reduce-constant (old)
+  (let ((new (eval old)))
+    (if (eq new old)
+	new
+	(if (constantp new)
+	    (reduce-constant new)
+	    new))))
+
+(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 () 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))))))
diff --git a/pcl/methods.lisp b/pcl/methods.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..50a210db359be6ab0b981debcdb52a1151e74702
--- /dev/null
+++ b/pcl/methods.lisp
@@ -0,0 +1,1347 @@
+;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+
+(in-package 'pcl)
+
+;;;
+;;; METHODS
+;;;
+;;; Methods themselves are simple inanimate objects.  Most properties of
+;;; methods are immutable, methods cannot be reinitialized.  The following
+;;; properties of methods can be changed:
+;;;   METHOD-GENERIC-FUNCTION
+;;;   METHOD-FUNCTION            ??
+;;;   
+;;;
+
+(defclass method (metaobject) ())
+
+(defclass standard-method (definition-source-mixin plist-mixin method)
+     ((generic-function
+	:initform nil	
+	:accessor method-generic-function)
+;     (qualifiers
+;	:initform ()
+;	:initarg  :qualifiers
+;	:reader method-qualifiers)
+      (specializers
+	:initform ()
+	:initarg  :specializers
+	:reader method-specializers)
+      (lambda-list
+	:initform ()
+	:initarg  :lambda-list
+	:reader method-lambda-list)
+      (function
+	:initform nil
+	:initarg :function
+	:initarg :function
+	:reader method-function)		;writer defined by hand
+;     (documentation
+;	:initform nil
+;	:initarg  :documentation
+;	:reader method-documentation)
+      ))
+
+(defclass standard-accessor-method (standard-method)
+     ((slot-name :initform nil
+		 :initarg :slot-name)))
+
+;;;
+;;; This method has to be defined by hand!  Don't try to define it using
+;;; :accessor or :reader.  It can't be an automatically generated reader
+;;; method because that would break the way the special discriminator
+;;; code which uses this feature works.  -- Probably false now 8/21
+;;; 
+(defmethod accessor-method-slot-name ((m standard-accessor-method))
+  (slot-value m 'slot-name))
+
+(defclass standard-reader-method (standard-accessor-method) ())
+(defclass standard-writer-method (standard-accessor-method) ())
+
+
+(defmethod print-object ((method standard-method) stream)
+  (printing-random-thing (method stream)
+    (let ((generic-function (method-generic-function method))
+	  (class-name (capitalize-words (class-name (class-of method)))))
+      (format stream "~A ~S ~{~S ~}~:S"
+	      class-name
+	      (and generic-function (generic-function-name generic-function))
+	      (method-qualifiers method)
+	      (unparse-specializers method)))))
+
+(defmethod print-object ((method standard-accessor-method) stream)
+  (printing-random-thing (method stream)
+    (let ((generic-function (method-generic-function method))
+	  (class-name (capitalize-words (class-name (class-of method)))))
+      (format stream "~A ~S, slot:~S, ~:S"
+	      class-name
+	      (and generic-function (generic-function-name generic-function))
+	      (accessor-method-slot-name method)
+	      (unparse-specializers method)))))
+
+;;;
+;;; INITIALIZATION
+;;;
+;;; Error checking is done in before methods.  Because of the simplicity of
+;;; standard method objects the standard primary method can fill the slots.
+;;;
+;;; Methods are not reinitializable.
+;;; 
+
+(defmethod reinitialize-instance ((method standard-method) &rest initargs)
+  (declare (ignore initargs))
+  (error "Attempt to reinitialize the method ~S.~%~
+          Method objects cannot be reinitialized."
+	 method))
+
+(defmethod shared-initialize :before ((method standard-method)
+				      slot-names
+				      &key qualifiers
+					   lambda-list
+					   specializers
+					   function
+					   documentation)
+  (declare (ignore slot-names))
+  (flet ((lose (initarg value string)
+	   (error "When initializing the method ~S:~%~
+                   The ~S initialization argument was: ~S.~%~
+                   which ~A."
+		  method initarg value string)))
+    (let ((check-qualifiers    (legal-std-qualifiers-p qualifiers))
+	  (check-lambda-list   (legal-std-lambda-list-p lambda-list))
+	  (check-specializers  (legal-std-specializers-p specializers))
+	  (check-function      (legal-std-method-function-p function))
+	  (check-documentation (legal-std-documentation-p documentation)))
+      (unless (eq check-qualifiers t)
+	(lose :qualifiers qualifiers check-qualifiers))
+      (unless (eq check-lambda-list t)
+	(lose :lambda-list lambda-list check-lambda-list))
+      (unless (eq check-specializers t)
+	(lose :specializers specializers check-specializers))
+      (unless (eq check-function t)
+	(lose :function function check-function))
+      (unless (eq check-documentation t)
+	(lose :documentation documentation check-documentation)))))
+
+(defmethod shared-initialize :before ((method standard-accessor-method)
+				      slot-names
+				      &key slot-name)
+  (declare (ignore slot-names))
+  (let ((legalp (legal-std-slot-name-p slot-name)))
+    (unless (eq legalp t)
+      (error "The value of the :SLOT-NAME initarg ~A." legalp))))
+
+(defmethod shared-initialize :after ((method standard-method) slot-names &key qualifiers)
+  (setf (plist-value method 'qualifiers) qualifiers))
+
+(defmethod method-qualifiers ((method standard-method))
+  (plist-value method 'qualifiers))
+
+
+
+(defclass generic-function (dependent-update-mixin
+			    definition-source-mixin
+			    metaobject)
+     ()
+  (:metaclass funcallable-standard-class))
+    
+(defclass standard-generic-function (generic-function)
+     ((name
+	:initform nil
+	:initarg :name
+	:accessor generic-function-name)
+      (methods
+	:initform ()
+	:accessor generic-function-methods)
+      (method-class
+	:initarg :method-class
+	:accessor generic-function-method-class)
+      (method-combination
+	:initarg :method-combination
+	:accessor generic-function-method-combination)
+
+;     (permutation
+;	:accessor gf-permutation)
+      (arg-info
+	:initform ()
+	:accessor gf-arg-info)
+      (dfun-state
+	:initform ()
+	:accessor gf-dfun-state)
+      (effective-method-functions		;((methods . fn) ..)
+	:initform ()
+	:accessor gf-effective-method-functions)
+      (valid-p
+	:initform nil
+	:accessor gf-valid-p)
+      (pretty-arglist
+	:initform ()
+	:accessor gf-pretty-arglist)
+      )
+  (:metaclass funcallable-standard-class)
+  (:default-initargs :method-class *the-class-standard-method*
+		     :method-combination *standard-method-combination*))
+
+(define-gf-predicate generic-function-p         generic-function)
+(define-gf-predicate method-p                   method)
+(define-gf-predicate standard-accessor-method-p standard-accessor-method)
+(define-gf-predicate standard-reader-method-p   standard-reader-method)
+(define-gf-predicate standard-writer-method-p   standard-writer-method)
+
+(defvar *the-class-method*                    (find-class 'method))
+(defvar *the-class-standard-method*           (find-class 'standard-method))
+(defvar *the-class-generic-function*          (find-class 'generic-function))
+(defvar *the-class-standard-generic-function* (find-class 'standard-generic-function))
+
+
+
+(defmethod print-object ((generic-function generic-function) stream)
+  (named-object-print-function
+    generic-function
+    stream
+    (list (length (generic-function-methods generic-function)))))
+
+
+(defmethod shared-initialize :before
+	   ((generic-function standard-generic-function)
+	    slot-names
+	    &key (name nil namep)
+		 (lambda-list () lambda-list-p)
+		 argument-precedence-order
+		 declarations
+		 documentation
+		 (method-class nil method-class-supplied-p)
+		 (method-combination nil method-combination-supplied-p))
+  (declare (ignore slot-names
+		   declarations argument-precedence-order
+		   lambda-list lambda-list-p name))
+
+  (when namep
+    (set-function-name generic-function name))
+		   
+  (flet ((initarg-error (initarg value string)
+	   (error "When initializing the generic-function ~S:~%~
+                   The ~S initialization argument was: ~A.~%~
+                   It must be ~A."
+		  generic-function initarg value string)))
+    (cond (method-class-supplied-p
+	   (when (symbolp method-class)
+	     (setq method-class (find-class method-class)))
+	   (unless (and (classp method-class)
+			(*subtypep method-class *the-class-method*))
+	     (initarg-error :method-class
+			    method-class
+			    "a subclass of the class METHOD"))
+	   (setf (slot-value generic-function 'method-class) method-class))
+	  ((slot-boundp generic-function 'method-class))
+	  (t
+	   (initarg-error :method-class
+			  "not supplied"
+			  "a subclass of the class METHOD")))
+    (cond (method-combination-supplied-p
+	   (unless (method-combination-p method-combination)
+	     (initarg-error :method-combination
+			    method-combination
+			    "a method combination object")))
+	  ((slot-boundp generic-function 'method-combination))
+	  (t
+	   (initarg-error :method-combination
+			  "not supplied"
+			  "a method combination object")))))
+
+(defmethod initialize-instance :after ((gf standard-generic-function)
+				       &key lambda-list argument-precedence-order)
+  (declare (ignore slot-names))
+  (when lambda-list
+    (setf (gf-arg-info gf)
+	  (new-arg-info-from-generic-function lambda-list argument-precedence-order))))
+
+(defmethod reinitialize-instance ((generic-function standard-generic-function)
+				  &rest initargs
+				  &key name
+				       lambda-list
+				       argument-precedence-order
+				       declarations
+				       documentation
+				       method-class
+				       method-combination)
+  (declare (ignore documentation declarations argument-precedence-order
+		   lambda-list name method-class method-combination))
+  (macrolet ((add-initarg (check name slot-name)
+	       `(unless ,check
+		  (push (slot-value generic-function ,slot-name) initargs)
+		  (push ,name initargs))))
+;   (add-initarg name :name 'name)
+;   (add-initarg lambda-list :lambda-list 'lambda-list)
+;   (add-initarg argument-precedence-order
+;		 :argument-precedence-order
+;		 'argument-precedence-order)
+;   (add-initarg declarations :declarations 'declarations)
+;   (add-initarg documentation :documentation 'documentation)
+;   (add-initarg method-class :method-class 'method-class)
+;   (add-initarg method-combination :method-combination 'method-combination)
+    (apply #'call-next-method generic-function initargs)))
+
+
+;;;
+;;; These three are scheduled for demolition.
+;;; 
+(defmethod remove-named-method (generic-function-name argument-specifiers
+						      &optional extra)
+  (let ((generic-function ())
+	(method ()))
+    (cond ((or (null (fboundp generic-function-name))
+	       (not (generic-function-p
+		      (setq generic-function
+			    (symbol-function generic-function-name)))))
+	   (error "~S does not name a generic-function."
+		  generic-function-name))
+	  ((null (setq method (get-method generic-function
+					  extra
+					  (parse-specializers
+					    argument-specifiers)
+					  nil)))
+	   (error "There is no method for the generic-function ~S~%~
+                   which matches the argument-specifiers ~S."
+		  generic-function
+		  argument-specifiers))
+	  (t
+	   (remove-method generic-function method)))))
+
+(defun real-add-named-method (generic-function-name
+			      qualifiers
+			      specializers
+			      lambda-list
+			      function
+			      &rest other-initargs)
+  ;; What about changing the class of the generic-function if there is
+  ;; one.  Whose job is that anyways.  Do we need something kind of
+  ;; like class-for-redefinition?
+  (let* ((generic-function
+	   (ensure-generic-function generic-function-name
+				    :lambda-list (method-ll->generic-function-ll lambda-list)))
+	 (specs (parse-specializers specializers))
+;	 (existing (get-method generic-function qualifiers specs nil))
+	 (proto (method-prototype-for-gf generic-function-name))
+	 (new (apply #'make-instance (class-of proto)
+				     :qualifiers qualifiers
+				     :specializers specs
+				     :lambda-list lambda-list
+				     :function function
+				     other-initargs)))
+;   (when existing (remove-method generic-function existing))
+    (add-method generic-function new)))
+
+	
+(defun make-specializable (function-name &key (arglist nil arglistp))
+  (cond ((not (null arglistp)))
+	((not (fboundp function-name)))
+	((fboundp 'function-arglist)
+	 ;; function-arglist exists, get the arglist from it.
+	 (setq arglist (function-arglist function-name)))
+	(t
+	 (error
+	   "The :arglist argument to make-specializable was not supplied~%~
+            and there is no version of FUNCTION-ARGLIST defined for this~%~
+            port of Portable CommonLoops.~%~
+            You must either define a version of FUNCTION-ARGLIST (which~%~
+            should be easy), and send it off to the Portable CommonLoops~%~
+            people or you should call make-specializable again with the~%~
+            :arglist keyword to specify the arglist.")))
+  (let ((original (and (fboundp function-name)
+		       (symbol-function function-name)))
+	(generic-function (make-instance 'standard-generic-function
+					 :name function-name))
+	(nrequireds 0))
+    (if (generic-function-p original)
+	original
+	(progn
+	  (dolist (arg arglist)
+	    (if (memq arg lambda-list-keywords)
+		(return)
+		(incf nrequireds)))
+	  (setf (symbol-function function-name) generic-function)
+	  (set-function-name generic-function function-name)
+	  (when arglistp
+	    (setf (gf-pretty-arglist generic-function) arglist))
+	  (when original
+	    (add-named-method function-name
+			      ()
+			      (make-list nrequireds :initial-element 't)
+			      arglist
+			      original))
+	  generic-function))))
+
+
+
+(defun real-get-method (generic-function qualifiers specializers
+					 &optional (errorp t))
+  (let ((hit
+	  (dolist (method (generic-function-methods generic-function))
+	    (when (and (equal qualifiers (method-qualifiers method))
+		       (every #'same-specializer-p specializers (method-specializers method)))
+	      (return method)))))
+    (cond (hit hit)
+	  ((null errorp) nil)
+	  (t
+	   (error "No method on ~S with qualifiers ~:S and specializers ~:S."
+		  generic-function qualifiers specializers)))))
+
+
+;;;
+;;; Compute various information about a generic-function's arglist by looking
+;;; at the argument lists of the methods.  The hair for trying not to use
+;;; &rest arguments lives here.
+;;;  The values returned are:
+;;;    number-of-required-arguments
+;;;       the number of required arguments to this generic-function's
+;;;       discriminating function
+;;;    &rest-argument-p
+;;;       whether or not this generic-function's discriminating
+;;;       function takes an &rest argument.
+;;;    specialized-argument-positions
+;;;       a list of the positions of the arguments this generic-function
+;;;       specializes (e.g. for a classical generic-function this is the
+;;;       list: (1)).
+;;;
+(defmethod compute-discriminating-function-arglist-info
+	   ((generic-function standard-generic-function))
+  (declare (values number-of-required-arguments
+                   &rest-argument-p
+                   specialized-argument-postions))
+  (let ((number-required nil)
+        (restp nil)
+        (specialized-positions ())
+	(methods (generic-function-methods generic-function)))
+    (dolist (method methods)
+      (multiple-value-setq (number-required restp specialized-positions)
+        (compute-discriminating-function-arglist-info-internal
+	  generic-function method number-required restp specialized-positions)))
+    (values number-required restp (sort specialized-positions #'<))))
+
+(defun compute-discriminating-function-arglist-info-internal
+       (generic-function method number-of-requireds restp
+	specialized-argument-positions)
+  (declare (ignore generic-function))
+  (let ((requireds 0))
+    ;; Go through this methods arguments seeing how many are required,
+    ;; and whether there is an &rest argument.
+    (dolist (arg (method-lambda-list method))
+      (cond ((eq arg '&aux) (return))
+            ((memq arg '(&optional &rest &key))
+             (return (setq restp t)))
+	    ((memq arg lambda-list-keywords))
+            (t (incf requireds))))
+    ;; Now go through this method's type specifiers to see which
+    ;; argument positions are type specified.  Treat T specially
+    ;; in the usual sort of way.  For efficiency don't bother to
+    ;; keep specialized-argument-positions sorted, rather depend
+    ;; on our caller to do that.
+    (iterate ((type-spec (list-elements (method-specializers method)))
+              (pos (interval :from 0)))
+      (unless (eq type-spec *the-class-t*)
+	(pushnew pos specialized-argument-positions)))
+    ;; Finally merge the values for this method into the values
+    ;; for the exisiting methods and return them.  Note that if
+    ;; num-of-requireds is NIL it means this is the first method
+    ;; and we depend on that.
+    (values (min (or number-of-requireds requireds) requireds)
+            (or restp
+		(and number-of-requireds (/= number-of-requireds requireds)))
+            specialized-argument-positions)))
+
+(defun make-discriminating-function-arglist (number-required-arguments restp)
+  (nconc (gathering ((args (collecting)))
+           (iterate ((i (interval :from 0 :below number-required-arguments)))
+             (gather (intern (format nil "Discriminating Function Arg ~D" i))
+		     args)))
+         (when restp
+               `(&rest ,(intern "Discriminating Function &rest Arg")))))
+
+
+;;;
+;;;
+;;;
+(defun make-arg-info (precedence metatypes number-optional key/rest-p keywords)
+  (let ((new (make-array 6 :adjustable nil)))
+    (setf (svref new 0) 'arg-info
+	  (svref new 1) precedence
+	  (svref new 2) metatypes 
+	  (svref new 3) number-optional
+	  (svref new 4) key/rest-p
+	  (svref new 5) keywords)		;nil         no keyword or rest allowed
+						;
+						;(k1 k2 ..)  each method must accept these
+						;            keyword arguments
+						;
+						;T           must have &key or &rest
+    new))
+
+(defun check-arg-info (x)
+  (or (and (simple-vector-p x)
+	   (= (array-dimension x 0) 6)
+	   (eq (svref x 0) 'arg-info))
+      (error "~S is not an ARG-INFO." x)))
+
+
+(defun arg-info-precedence (arg-info)
+  (check-arg-info arg-info)
+  (svref arg-info 1))
+
+(defun arg-info-metatypes (arg-info)
+  (check-arg-info arg-info)
+  (svref arg-info 2))
+
+(defun arg-info-number-optional (arg-info)
+  (check-arg-info arg-info)
+  (svref arg-info 3))
+
+(defun arg-info-key/rest-p (arg-info)
+  (check-arg-info arg-info)
+  (svref arg-info 4))
+
+(defun arg-info-keywords (arg-info)
+  (check-arg-info arg-info)
+  (svref arg-info 5))
+
+(defun arg-info-applyp (arg-info)
+  (check-arg-info arg-info)
+  (or (plusp (arg-info-number-optional arg-info))
+      (arg-info-key/rest-p arg-info)))
+
+(defun arg-info-number-required (arg-info)
+  (check-arg-info arg-info)
+  (length (arg-info-metatypes arg-info)))
+
+(defun arg-info-nkeys (arg-info)
+  (count-if #'(lambda (x) (neq x 't)) (arg-info-metatypes arg-info)))
+
+
+(defun new-arg-info-from-generic-function (lambda-list argument-precedence-order)
+  (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
+      (analyze-lambda-list lambda-list)
+    (declare (ignore allow-other-keys-p))
+    (let ((metatypes (make-list nreq))
+	  (precedence (compute-precedence lambda-list nreq argument-precedence-order)))
+      (make-arg-info precedence
+		     metatypes
+		     nopt
+		     (or keysp restp)
+		     keywords))))
+
+(defun new-arg-info-from-method (method)
+  (multiple-value-bind (nreq nopt keysp restp)
+      (analyze-lambda-list (method-lambda-list method))
+    (make-arg-info (compute-precedence (method-lambda-list method) nreq ())
+		   (mapcar #'raise-metatype (make-list nreq) (method-specializers method))
+		   nopt
+		   (or keysp restp)
+		   ())))
+
+(defun add-arg-info (generic-function method arg-info)
+  (flet ((lose (string &rest args)
+	   (error "Attempt to add the method ~S to the generic function ~S.~%~
+                   But ~A"
+		  method
+		  generic-function
+		  (apply #'format nil string args)))
+	 (compare (x y)
+	   (if (> x y) "more" "fewer")))
+    (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
+	(analyze-lambda-list (method-lambda-list method))
+      (let ((gf-nreq (arg-info-number-required arg-info))
+	    (gf-nopt (arg-info-number-optional arg-info))
+	    (gf-key/rest-p (arg-info-key/rest-p arg-info))
+	    (gf-keywords (arg-info-keywords arg-info)))
+
+	(unless (= nreq gf-nreq)
+	  (lose "the method has ~A required arguments than the generic function."
+		(compare nreq gf-nreq)))
+	(unless (= nopt gf-nopt)
+	  (lose "the method has ~S optional arguments than the generic function."
+		(compare nopt gf-nopt)))
+	(unless (eq (or keysp restp) gf-key/rest-p)
+	  (error "the method and generic function differ in whether they accept~%~
+                  rest or keyword arguments."))
+	(when gf-keywords
+	  (unless (or (and restp (not keysp))
+		      allow-other-keys-p
+		      (every #'(lambda (k) (memq k keywords)) gf-keywords))
+	    (error
+	      "the generic function requires each method to accept the keyword arguments~%~
+               ~S.  The method does not all of accept these."
+	      gf-keywords)))
+	(make-arg-info (arg-info-precedence arg-info)
+		       (mapcar #'raise-metatype (arg-info-metatypes arg-info)
+						(method-specializers method))
+		       gf-nopt
+		       gf-key/rest-p
+		       gf-keywords)))))
+
+(defun remove-arg-info (generic-function method arg-info)
+  (declare (ignore generic-function method))
+  arg-info)
+
+;;;
+;;;
+;;;
+(defun compute-precedence (lambda-list nreq argument-precedence-order)
+  (let ((nreq (analyze-lambda-list lambda-list)))
+    (if (null argument-precedence-order)
+	(let ((c -1)) (gathering1 (collecting) (dotimes (i nreq) (gather1 (incf c)))))
+	(mapcar #'(lambda (x) (position x lambda-list)) argument-precedence-order))))
+
+
+
+
+
+
+(defmethod no-applicable-method (generic-function &rest args)
+  (error "No matching method for the generic-function ~S,~@
+          when called with arguments ~S."
+	 generic-function args))
+
+
+
+
+(defun real-add-method (generic-function method)
+  (if (method-generic-function method)
+      (error "The method ~S is already part of the generic~@
+              function ~S.  It can't be added to another generic~@
+              function until it is removed from the first one."
+	     method (method-generic-function method))
+
+      (let* ((qualifiers   (method-qualifiers method))
+	     (lambda-list  (method-lambda-list method))
+	     (specializers (method-specializers method))
+	     (existing (get-method generic-function qualifiers specializers nil)))
+	;;
+	;; If there is already a method like this one then we must
+	;; get rid of it before proceeding.  Note that we call the
+	;; generic function remove-method to remove it rather than
+	;; doing it in some internal way.
+	;; 
+	(when existing (remove-method generic-function existing))
+	;;
+	(let ((arg-info (gf-arg-info generic-function)))
+	  (setf (gf-arg-info generic-function)
+		(if (null arg-info)
+		    (new-arg-info-from-method method)
+		    (add-arg-info generic-function method arg-info)))
+	  (setf (method-generic-function method) generic-function)
+	  (pushnew method (generic-function-methods generic-function))
+	  (dolist (specializer specializers)
+	    (add-method-on-specializer method specializer))
+	  (invalidate-discriminating-function generic-function)    
+	  (maybe-update-constructors generic-function method)
+	  method))))
+  
+(defun real-remove-method (generic-function method)
+  (if  (neq generic-function (method-generic-function method))
+       (error "The method ~S is attached to the generic function~@
+               ~S.  It can't be removed from the generic function~@
+               to which it is not attached."
+	      method (method-generic-function method))
+       (let* ((methods      (generic-function-methods generic-function))
+	      (new-methods  (remove method methods))
+	      (new-arg-info (remove-arg-info generic-function
+					     method
+					     (gf-arg-info generic-function))))
+	      
+	 (setf (method-generic-function method) nil)
+	 (setf (generic-function-methods generic-function) new-methods)
+	 (dolist (specializer (method-specializers method))
+	   (remove-method-on-specializer method specializer))
+	 (setf (gf-arg-info generic-function) new-arg-info)
+	 (invalidate-discriminating-function generic-function)
+	 (maybe-update-constructors generic-function method)
+	 generic-function)))
+
+
+
+;;;
+;;;
+;;;
+;;; This is it.  You have reached the special place where everything comes
+;;; together.  This is where we ensure that the metacircularity will bottom
+;;; out properly.
+;;;
+;;; Remember once again that the source of the problem is that the specified
+;;; behavior clearly calls for the process of method lookup to itself call
+;;; generic functions.  This implies that for a given generic function in
+;;; the method lookup protocol (compute-applicable-methods for example), we
+;;; can end up in the unfortunate situation of having to call that generic
+;;; function in order to call it!
+;;;
+;;; So, we must arrange to snap this infinite regress.
+;;;
+;;; The strategy taken here is to identify a particular subset of calls to
+;;; method lookup protocol generic functions and snap the recursion there.
+;;; This subset of generic function calls has the following properties:
+;;;
+;;;   - Any generic function call in the world will, eventually
+;;;     reach one of these generic function calls.  That is we
+;;;     are sure that if we can arrange for these calls not to
+;;;     recurse we know we are all set.
+;;;
+;;;   - These calls themselves don't recurse.  We arrange, by
+;;;     magic, for the method lookup and application involved
+;;;     in these calls not to call any other generic functions.
+;;;
+;;; 
+;;;
+(defvar *magic-generic-functions*
+	'((compute-discriminating-function ((standard-generic-function)
+					    (standard-generic-function)))
+	  (compute-applicable-methods               ((standard-generic-function t)
+						     (generic-function t)))
+	  (compute-applicable-methods-using-classes ((standard-generic-function t)
+						     (generic-function t)))
+;	  (same-specializer-p       ((standard-class standard-class) (t t)))
+;	  (specializer-applicable-p ((standard-class t) (class t)))
+	  (specializer-applicable-using-class-p ((standard-class t) (class t))
+						((built-in-class t) (class t)))
+	  (order-specializers-using-class ((standard-class standard-class t) (class class t)))
+	  
+	  (compute-effective-method
+	    ((standard-generic-function (eql *standard-method-combination*) t)
+	     (generic-function          standard-method-combination t)))
+	  
+	  (method-p
+	    ((standard-method)        (method))
+	    ((standard-reader-method) (method))
+	    ((standard-writer-method) (method)))
+	  (standard-accessor-method-p
+	    ((standard-method)        (t))
+	    ((standard-reader-method) (standard-accessor-method))
+	    ((standard-writer-method) (standard-accessor-method)))
+	  (standard-reader-method-p
+	    ((standard-method)        (t))
+	    ((standard-reader-method) (standard-reader-method))
+	    ((standard-writer-method) (t)))
+	  (standard-writer-method-p
+	    ((standard-method)        (t))
+	    ((standard-reader-method) (t))
+	    ((standard-writer-method) (standard-writer-method)))
+	  
+	  (method-qualifiers   ((standard-method)        (standard-method))
+			       ((standard-reader-method) (standard-method)))
+	  (method-specializers ((standard-method)        (standard-method))
+			       ((standard-reader-method) (standard-method)))
+	  (method-lambda-list  ((standard-method)        (standard-method))
+			       ((standard-reader-method) (standard-method)))
+	  (method-function     ((standard-method)        (standard-method))
+			       ((standard-reader-method) (standard-method)))
+	  (accessor-method-slot-name
+	    ((standard-reader-method) (standard-accessor-method))
+	    ((standard-writer-method) (standard-accessor-method)))
+
+	  (classp                ((standard-class) (class))
+				 ((built-in-class) (class)))
+	  (class-precedence-list ((standard-class) (pcl-class)))
+	  (class-finalized-p     ((standard-class) (pcl-class)))
+
+	  (generic-function-methods             ((standard-generic-function)
+						 (standard-generic-function)))
+	  (generic-function-method-combination  ((standard-generic-function)
+						 (standard-generic-function)))
+
+	  (gf-arg-info                          ((standard-generic-function)
+						 (standard-generic-function)))
+	  (gf-dfun-state                        ((standard-generic-function)
+						 (standard-generic-function)))
+	  (gf-effective-method-functions        ((standard-generic-function)
+						 (standard-generic-function)))
+	  ((setf gf-effective-method-functions) ((t standard-generic-function)
+						 (t standard-generic-function)))
+;	  (gf-permutation                       ((standard-generic-function)
+;						 (standard-generic-function)))
+
+	  (slot-value-using-class  ((standard-class t t)
+				    (std-class standard-object t))
+				   ((funcallable-standard-class t t)
+				    (std-class standard-object t)))
+	  ((setf slot-value-using-class)  ((t standard-class t t)
+					   (t std-class standard-object t))
+					  ((t funcallable-standard-class t t)
+					   (t std-class standard-object t)))
+	  ))
+
+(defvar *magic-generic-functions-1* nil)
+
+(defun fixup-magic-generic-function (gfspec early-methods gf methods)
+  (flet ((get-specls (names convert-t-p)
+	   (mapcar #'(lambda (s)
+		       (cond ((consp s)
+			      `(eql ,(eval (cadr s))))
+			     ((eq s t)
+			      (if convert-t-p (find-class t) t))
+			     (t
+			      (find-class s))))
+		   names)))
+    (let ((e (assoc gfspec *magic-generic-functions* :test #'equal)))
+      (when e
+	(push (cons gf 
+		    (gathering1 (collecting)
+		      (dolist (pair (cdr e))
+			(iterate ((em (list-elements early-methods))
+				  (m  (list-elements methods)))
+			  (when (equal (early-method-specializers em t)
+				       (get-specls (cadr pair) t))
+			    (gather1 (list (get-specls (car pair) nil)
+					   (list m)
+					   (early-method-function em)))
+			    (return t))))))
+	      *magic-generic-functions-1*)))))
+
+(defun get-secondary-dispatch-function (generic-function args)
+  (declare (values compiled-secondary-dispatch-function methods))
+  (multiple-value-bind (fn methods)
+      (get-magic-secondary-dispatch-function generic-function args)
+    (if fn
+	(values fn methods)
+	(get-normal-secondary-dispatch-function generic-function args))))
+
+(defun get-magic-secondary-dispatch-function (generic-function args)
+  (let ((e (assq generic-function *magic-generic-functions-1*)))
+    (when e
+      (dolist (entry (cdr e))
+	(destructuring-bind (specls appl function)
+			    entry
+	  (unless (iterate ((arg   (list-elements args))
+			    (specl (list-elements specls)))
+		    (let ((class (class-of arg)))
+		      (unless (if (consp specl)
+				  (eql (cadr specl) arg)
+				  (or (eq specl t)
+				      (eq specl class)))
+			(return t))))
+	    (return (values function appl))))))))
+
+(defmacro protect-cache-miss-code (gf args &body body)
+  (let ((function (gensym)) (appl (gensym)))
+    (once-only (gf args)
+      `(if (memq ,gf *invalid-dfuns-on-stack*)
+	   (multiple-value-bind (,function ,appl)
+	       (get-secondary-dispatch-function ,gf ,args)
+	     (if (null ,appl)
+		 (no-applicable-method ,gf ,args)
+		 (apply ,function ,args)))
+	   (let ((*invalid-dfuns-on-stack* (cons ,gf *invalid-dfuns-on-stack*)))
+	     ,@body)))))
+
+
+(defmethod same-specializer-p (specl1 specl2) (eq specl1 specl2))
+
+(defmethod specializer-applicable-p ((specializer class) object)
+  (memq specializer (class-precedence-list (class-of object))))
+
+(defmethod specializer-applicable-using-class-p ((specializer class) class)
+  (*subtypep class specializer))
+
+(defmethod order-specializers-using-class ((specl1 class) (specl2 class) class)
+  (cond ((eq specl1 specl2) nil)
+	((memq specl2 (memq specl1 (class-precedence-list class))) specl1)
+	(t specl2)))
+
+(defmethod compute-applicable-methods
+	   ((generic-function generic-function) arguments)
+  (labels ((filter (method)
+	     (let ((arguments-tail arguments))
+	       (dolist (m-spec (method-specializers method) t)
+		 (unless arguments-tail
+		   (error "The function ~S requires at least ~D arguments"
+			  (generic-function-name generic-function)
+			  (arg-info-number-required (gf-arg-info generic-function))))
+		 (unless (specializer-applicable-p m-spec (pop arguments-tail))
+		   (return nil)))))
+           (sorter (method-1 method-2)
+	     (dolist (index (arg-info-precedence (gf-arg-info generic-function)))
+	       (let* ((specl1 (nth index (method-specializers method-1)))
+		      (specl2 (nth index (method-specializers method-2)))
+		      (class (class-of (nth index arguments)))
+		      (order (order-specializers-using-class specl1 specl2 class)))
+		 (when order
+		   (return-from sorter (eq order specl1)))))))
+    (let ((methods (generic-function-methods generic-function)))
+      (stable-sort (copy-list (remove-if-not #'filter methods)) #'sorter))))
+
+(defmethod compute-applicable-methods-using-classes
+	   ((generic-function generic-function) classes)
+  (labels ((filter (method)
+	     (let ((classes-tail classes))
+	       (dolist (m-spec (method-specializers method) t)
+		 (unless classes-tail
+		   (error "The function ~S requires at least ~D arguments"
+			  (generic-function-name generic-function)
+			  (arg-info-number-required (gf-arg-info generic-function))))
+		 (unless (specializer-applicable-using-class-p
+			   m-spec (pop classes-tail))
+		   (return nil)))))
+           (sorter (method-1 method-2)
+	     (dolist (index (arg-info-precedence (gf-arg-info generic-function)))
+	       (let* ((specl1 (nth index (method-specializers method-1)))
+		      (specl2 (nth index (method-specializers method-2)))
+		      (class (nth index classes))
+		      (order (order-specializers-using-class specl1 specl2 class)))
+		 (when order
+		   (return-from sorter (eq order specl1)))))))
+    (let ((methods (generic-function-methods generic-function)))
+      (stable-sort (copy-list (remove-if-not #'filter methods)) #'sorter))))
+
+
+
+(defun get-normal-secondary-dispatch-function (generic-function args)
+  (let* ((classes (mapcar #'(lambda (arg mt) (declare (ignore mt)) (class-of arg))
+			  args
+			  (arg-info-metatypes (gf-arg-info generic-function))))
+	 (methods (compute-applicable-methods-using-classes generic-function classes))
+	 (net (generate-discrimination-net generic-function methods))
+	 (arg-info (gf-arg-info generic-function))
+	 (metatypes (arg-info-metatypes arg-info))
+	 (applyp (arg-info-applyp arg-info)))
+    (flet ((net-test-converter (form)
+	      (if (and (consp form) (eq (car form) 'methods))
+		  '.methods.
+		  (default-test-converter form)))
+	   (net-code-converter (form)
+	      (if (and (consp form) (eq (car form) 'methods))
+		  (let ((gensym (gensym)))
+		    (values (make-dfun-call metatypes applyp gensym) (list gensym)))
+		  (default-code-converter form)))
+	   (net-constant-converter (form)
+	     (if (and (consp form) (eq (car form) 'methods))
+		 (list (get-effective-method-function generic-function (cdr form)))
+		 (default-constant-converter form))))
+      (if (eq (car net) 'methods)
+	  (and (cdr net)
+	       (values (get-effective-method-function generic-function (cdr net))
+		       methods))
+	  (values (get-function `(lambda ,(make-dfun-lambda-list metatypes applyp) ,net)
+				#'net-test-converter
+				#'net-code-converter
+				#'net-constant-converter)
+		  methods)))))
+
+(defun get-effective-method-function (generic-function methods)
+  (let ((combin (generic-function-method-combination generic-function))
+	(precomputed (gf-effective-method-functions generic-function)))
+    ;;
+    ;; NOTE: We are assuming a restriction on user code that the method
+    ;;       combination must not change once it is connected to the
+    ;;       generic function.
+    ;;
+    ;;       This has to be legal, because otherwise any kind of method
+    ;;       lookup caching couldn't work.  See this by saying that this
+    ;;       cache, is just a backing cache for the fast cache.  If that
+    ;;       cache is legal, this one must be too.
+    ;;
+    ;;       Should altering the set of methods flush this cache?
+    ;;       
+    (let ((entry (assoc methods precomputed :test #'equal)))
+      (if entry
+	  (values (cdr entry) (car entry))
+	  (let* ((effective (compute-effective-method generic-function combin methods))
+		 (fn (make-effective-method-function generic-function effective)))
+	    (setf (gf-effective-method-functions generic-function)
+		  (cons (cons methods fn) precomputed))
+	    (values fn methods))))))
+
+(defun generate-discrimination-net (generic-function methods)
+  (let* ((arg-info (gf-arg-info generic-function))
+	 (nreq (arg-info-number-required arg-info))
+	 (metatypes (arg-info-metatypes arg-info)))
+    (labels ((do-column (position contenders)
+	       (if (< position nreq)
+		   (if (eq (nth position metatypes) 't)
+		       (do-column (1+ position) contenders)
+		       (do-methods position contenders () ()))
+		   `(methods ,@contenders)))
+	     (do-methods (position contenders known-outcomes winners)
+	       ;;
+               ;; <contenders>
+	       ;;   is a (sorted) list of methods that must be discriminated
+               ;; <known-outcomes>
+	       ;;   is a list of outcomes from tests already made on this argument
+	       ;;   each outcome looks like (<specializer> [t | nil])
+               ;; <winners>
+	       ;;   is a (sorted) list of methods that are potentially applicable
+	       ;;   after the discrimination has been made.
+	       ;;   
+               (if (null contenders)
+                   (do-column (1+ position) winners)
+                   (let* ((method (car contenders))
+                          (specl (nth position (method-specializers method))))
+                     (flet ((determined-to-be (truth-value)
+                              (if (classp specl)
+                                  truth-value
+                                  (some #'(lambda (outcome)
+                                            (outcome-implies-p generic-function
+                                                               (car outcome)
+                                                               (cadr outcome)
+                                                               specl
+                                                               truth-value))
+                                        known-outcomes)))
+                            (if-true () 
+                              (do-methods position
+					  (cdr contenders)
+					  (if (not (classp specl))
+					      (cons `(,specl t) known-outcomes)
+					      known-outcomes)
+					  (append winners `(,method))))
+                            (if-false ()
+                              (do-methods position
+					  (cdr contenders)
+					  (if (not (classp specl))
+					      (cons `(,specl nil) known-outcomes)
+					      known-outcomes)
+					  winners)))
+                       (cond ((determined-to-be nil) (if-false))
+                             ((determined-to-be t)   (if-true))
+                             (t
+			      `(if ,(compute-argument-test-form generic-function
+								(dfun-arg-symbol position)
+								specl)
+				   ,(if-true)
+				   ,(if-false)))))))))
+
+      (do-column 0 methods))))
+
+
+
+
+(define-gf-predicate eql-specializer-p eql-specializer)
+
+(defmethod same-specializer-p ((specl1 eql-specializer)
+			       (specl2 eql-specializer))
+  (eql (eql-specializer-object specl1)
+       (eql-specializer-object specl2)))
+
+(defmethod specializer-applicable-p ((specializer eql-specializer) object)
+  (eql (eql-specializer-object specializer) object))
+
+(defmethod specializer-applicable-using-class-p ((specializer eql-specializer) class)
+  (eq class (class-of (eql-specializer-object specializer))))	;It would be most egregious
+						                ;to use *subtypep here.
+
+
+(defmethod order-specializers-using-class ((specl1 eql-specializer)
+					   (specl2 eql-specializer)
+					   argument-class)
+  (declare (ignore argument-class))
+  nil)
+
+(defmethod order-specializers-using-class ((specl1 class)
+					   (specl2 eql-specializer)
+					   argument-class)
+  (declare (ignore argument-class))
+  specl2)
+
+(defmethod order-specializers-using-class ((specl1 eql-specializer)
+					   (specl2 class)
+					   argument-class)
+  (declare (ignore argument-class))
+  specl1)
+
+;;;
+;;; Does a given pair of values for {<specializer1> <truth1>} imply a given pair of
+;;; values for {<specializer2> <truth2>}.
+;;; 
+(defmethod outcome-implies-p ((generic-function generic-function)
+			      (specl1 eql-specializer) value1
+			      (specl2 eql-specializer) value2)
+  (flet ((same-truth-value (x y)
+           (or (and x y) (and (not x) (not y)))))
+    (let ((obj1 (eql-specializer-object specl1))
+	  (obj2 (eql-specializer-object specl2)))
+      (or (and (eql obj1 obj2)
+	       (same-truth-value value1 value2))
+	  (and (not (eql obj1 obj2))
+	       value1 (not value2))))))
+
+;;;
+;;; Return a form which tests a given argument against a given specializer.
+;;; 
+(defmethod compute-argument-test-form
+	   ((generic-function generic-function) argument-form (specializer eql-specializer))
+  `(eql ,argument-form ',(eql-specializer-object specializer)))
+
+
+;;;
+;;; The value returned by compute-discriminating-function is a function
+;;; object.  It is called a discriminating function because it is called
+;;; when the generic function is called and its role is to discriminate
+;;; on the arguments to the generic function and then call appropriate
+;;; method functions.
+;;; 
+;;; A discriminating function can only be called when it is installed as
+;;; the funcallable instance function of the generic function for which
+;;; it was computed.
+;;;
+;;; More precisely, if compute-discriminating-function is called with an
+;;; argument <gf1>, and returns a result <df1>, that result must not be
+;;; passed to apply or funcall directly.  Rather, <df1> must be stored as
+;;; the funcallable instance function of the same generic function <gf1>
+;;; (using set-funcallable-instance-function).  Then the generic function
+;;; can be passed to funcall or apply.
+;;;
+;;; An important exception is that methods on this generic function are
+;;; permitted to return a function which itself ends up calling the value
+;;; returned by a more specific method.  This kind of `encapsulation' of
+;;; discriminating function is critical to many uses of the MOP.
+;;; 
+;;; As an example, the following canonical case is legal:
+;;;
+;;;   (defmethod compute-discriminating-function ((gf my-generic-function))
+;;;     (let ((std (call-next-method)))
+;;;       #'(lambda (arg)
+;;;            (print (list 'call-to-gf gf arg))
+;;;            (funcall std arg))))
+;;;
+;;; Because many discriminating functions would like to use a dynamic
+;;; strategy in which the precise discriminating function changes with
+;;; time it is important to specify how a discriminating function is
+;;; permitted itself to change the funcallable instance function of the
+;;; generic function.
+;;;
+;;; Discriminating functions are may set the funcallable instance function
+;;; of the generic function, but the new value must be generated by making
+;;; a call to COMPUTE-DISCRIMINATING-FUNCTION.  This is to ensure that any
+;;; more specific methods which may have encapsulated the discriminating
+;;; function will get a chance to encapsulate the new, inner discriminating
+;;; function.
+;;;
+;;; This implies that if a discriminating function wants to modify itself
+;;; it should first store some information in the generic function proper,
+;;; and then call compute-discriminating-function.  The appropriate method
+;;; on compute-discriminating-function will see the information stored in
+;;; the generic function and generate a discriminating function accordingly.
+;;;
+;;; The following is an example of a discriminating function which modifies
+;;; itself in accordance with this protocol:
+;;;
+;;;   (defmethod compute-discriminating-function ((gf my-generic-function))
+;;;     #'(lambda (arg)
+;;;         (cond (<some condition>
+;;;                <store some info in the generic function>
+;;;                (set-funcallable-instance-function
+;;;                  gf
+;;;                  (compute-discriminating-function gf))
+;;;                (funcall gf arg))
+;;;               (t
+;;;                <call-a-method-of-gf>))))
+;;;
+;;; Whereas this code would not be legal:
+;;;
+;;;   (defmethod compute-discriminating-function ((gf my-generic-function))
+;;;     #'(lambda (arg)
+;;;         (cond (<some condition>
+;;;                (set-funcallable-instance-function
+;;;                  gf
+;;;                  #'(lambda (a) ..))
+;;;                (funcall gf arg))
+;;;               (t
+;;;                <call-a-method-of-gf>))))
+;;;
+;;; NOTE:  All the examples above assume that all instances of the class
+;;;        my generic function accept only one argument.
+;;;
+;;;
+;;;
+;;;
+(defmethod compute-discriminating-function ((gf standard-generic-function))
+  (let* ((state (gf-dfun-state gf))
+	 (dfun (typecase state
+		 (null (make-initial-dfun gf))
+		 (function state)
+		 (cons (car state)))))
+    (doctor-dfun-for-the-debugger gf dfun)))
+
+(defun update-dfun (generic-function dfun &optional cache)
+  (let ((ostate (gf-dfun-state generic-function)))
+    (unless (typep ostate '(or null function)) (free-cache (cdr ostate)))
+    (setf (gf-dfun-state generic-function) (if cache (cons dfun cache) dfun))
+    (invalidate-dfun-internal generic-function)))
+
+(defun invalidate-discriminating-function (generic-function)
+  (let ((ostate (gf-dfun-state generic-function)))
+    (unless (typep ostate '(or null function)) (free-cache (cdr ostate)))
+    (setf (gf-dfun-state generic-function) nil)
+    (setf (gf-effective-method-functions generic-function) nil)    
+    (invalidate-dfun-internal generic-function)))
+
+(defun invalidate-dfun-internal (generic-function)
+  ;;
+  ;; Set the funcallable instance function to something that just calls
+  ;; invalid-dfun, that is, arrange to use lazy evaluation to update the
+  ;; dfun later.
+  ;; 
+  (set-funcallable-instance-function
+    generic-function
+    #'(lambda (&rest args)
+	(invalid-dfun generic-function args)))
+  ;;
+  ;; Except that during bootstrapping, we would like to update the dfun
+  ;; right away, and this arranges for that.
+  ;;
+  (when *invalidate-discriminating-function-force-p*    
+    (let ((*invalid-dfuns-on-stack*
+	    (cons generic-function *invalid-dfuns-on-stack*)))
+      (set-funcallable-instance-function
+	generic-function
+	(compute-discriminating-function generic-function)))))
+
+(defun invalid-dfun (gf args)
+  (protect-cache-miss-code gf args
+    (let ((new-dfun (compute-discriminating-function gf)))
+      (set-funcallable-instance-function gf new-dfun)
+      (apply gf args))))
+
+
+;;;
+;;;
+;;;
+(defmethod function-keywords ((method standard-method))
+  (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
+      (analyze-lambda-list (method-lambda-list method))
+    (declare (ignore nreq nopt keysp restp))
+    (values keywords allow-other-keys-p)))
+
+(defun analyze-lambda-list (lambda-list)
+  (declare (values nrequired
+		   noptional
+		   keysp
+		   restp
+		   allow-other-keys-p
+		   keywords
+		   keyword-parameters))
+  (flet ((parse-keyword-argument (arg)
+	   (if (listp arg)
+	       (if (listp (car arg))
+		   (cadar arg)
+		   (make-keyword (car arg)))
+	       (make-keyword arg))))
+    (let ((nrequired 0)
+	  (noptional 0)
+	  (keysp nil)
+	  (restp nil)
+	  (allow-other-keys-p nil)
+	  (keywords ())
+	  (keyword-parameters ())
+	  (state 'required))
+      (dolist (x lambda-list)
+	(if (memq x lambda-list-keywords)
+	    (case x
+	      (&optional         (setq state 'optional))
+	      (&key              (setq keysp 't
+				       state 'key))
+	      (&allow-other-keys (setq allow-other-keys-p 't))
+	      (&rest             (setq restp 't
+				       state 'rest))
+	      (&aux              (return t))
+	      (otherwise
+		(error "Encountered the non-standard lambda list keyword ~S." x)))
+	    (ecase state
+	      (required  (incf nrequired))
+	      (optional  (incf noptional))
+	      (key       (push (parse-keyword-argument x) keywords)
+			 (push x keyword-parameters))
+	      (rest      ()))))
+      (values nrequired noptional keysp restp allow-other-keys-p
+	      (reverse keywords)
+	      (reverse keyword-parameters)))))
+
+(defun method-ll->generic-function-ll (ll)
+  (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords keyword-parameters)
+      (analyze-lambda-list ll)
+    (declare (ignore nreq nopt keysp restp allow-other-keys-p keywords))
+    (remove-if #'(lambda (s)
+		   (or (memq s keyword-parameters)
+		       (eq s '&allow-other-keys)))
+	       ll)))
+
+
+;;;
+;;; This is based on the rules of method lambda list congruency defined in
+;;; the spec.  The lambda list it constructs is the pretty union of the
+;;; lambda lists of all the methods.  It doesn't take method applicability
+;;; into account at all yet.
+;;; 
+(defmethod generic-function-pretty-arglist
+	   ((generic-function standard-generic-function))
+  (let ((methods (generic-function-methods generic-function))
+	(arglist ()))      
+    (when methods
+      (multiple-value-bind (required optional rest key allow-other-keys)
+	  (method-pretty-arglist (car methods))
+	(dolist (m (cdr methods))
+	  (multiple-value-bind (method-key-keywords
+				method-allow-other-keys
+				method-key)
+	      (function-keywords m)
+	    ;; we've modified function-keywords to return what we want as
+	    ;;  the third value, no other change here.
+	    (declare (ignore method-key-keywords))
+	    (setq key (union key method-key))
+	    (setq allow-other-keys (or allow-other-keys
+				       method-allow-other-keys))))
+	(when allow-other-keys
+	  (setq arglist '(&allow-other-keys)))
+	(when key
+	  (setq arglist (nconc (list '&key) key arglist)))
+	(when rest
+	  (setq arglist (nconc (list '&rest rest) arglist)))
+	(when optional
+	  (setq arglist (nconc (list '&optional) optional arglist)))
+	(nconc required arglist)))))
+  
+
+(defmethod method-pretty-arglist ((method standard-method))
+  (let ((required ())
+	(optional ())
+	(rest nil)
+	(key ())
+	(allow-other-keys nil)
+	(state 'required)
+	(arglist (method-lambda-list method)))
+    (dolist (arg arglist)
+      (cond ((eq arg '&optional)         (setq state 'optional))
+	    ((eq arg '&rest)             (setq state 'rest))
+	    ((eq arg '&key)              (setq state 'key))
+	    ((eq arg '&allow-other-keys) (setq allow-other-keys 't))
+	    ((memq arg lambda-list-keywords))
+	    (t
+	     (ecase state
+	       (required (push arg required))
+	       (optional (push arg optional))
+	       (key      (push arg key))
+	       (rest     (setq rest arg))))))
+    (values (nreverse required)
+	    (nreverse optional)
+	    rest
+	    (nreverse key)
diff --git a/pcl/pcl-env-internal.lisp b/pcl/pcl-env-internal.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..bd994f1ad21a6effb122d497aa343c47dad6a93c
--- /dev/null
+++ b/pcl/pcl-env-internal.lisp
@@ -0,0 +1,260 @@
+(DEFINE-FILE-INFO PACKAGE "XCL" READTABLE "XCL")
+(il:filecreated "28-Aug-87 18:42:36" il:{phylum}<pcl>pcl-env-internal.\;1 8356   
+
+      il:|changes| il:|to:|  (il:vars il:pcl-env-internalcoms)
+                             (il:props (il:pcl-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:pcl-env-internalcoms)
+
+(il:rpaqq il:pcl-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:pcl-env-internal))
+                                                             (il:* il:\; 
+                                                             "We're off to hack the system...")
+
+                                   (il:declare\: il:eval@compile il:dontcopy (il:files pcl::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:pcl-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 pcl::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:pcl-env-internal il:copyright ("Xerox Corporation" 1987))
+(il:declare\: il:dontcopy
+  (il:filemap (nil)))
+il:stop
diff --git a/pcl/pcl-env.lisp b/pcl/pcl-env.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..c88ceb1f83bfda627a2c3ad05f9d9c8537de4be3
--- /dev/null
+++ b/pcl/pcl-env.lisp
@@ -0,0 +1,1628 @@
+;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.com)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+;;; Xerox-Lisp specific environment hacking for PCL
+
+(in-package "PCL")
+
+;; 
+;; Protect the Corporation
+;; 
+(eval-when (eval load)
+  (format *terminal-io*
+    "~&;PCL-ENV Copyright (c) 1987, 1988, 1989, by ~
+        Xerox Corporation.  All rights reserved.~%"))
+
+
+;;; Make funcallable instances (FINs) print by calling print-object.
+
+(eval-when (eval load)
+  (il:defprint 'il:compiled-closure 'il:print-closure))
+
+(defun il:print-closure (x &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 ((not (funcallable-instance-p x))
+	 ;; IL:\CCLOSURE.DEFPRINT is the orginal system function for
+	 ;; printing closures
+	 (il:\\cclosure.defprint x stream))
+	((streamp stream)
+	 ;; Use the standard PCL printing method, then return T to tell
+	 ;; the printer that we have done the printing ourselves.
+	 (print-object x stream)
+	 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.
+	 (with-output-to-string (stream)
+	   (list (print-object x stream))))))
+
+
+;;; Naming methods
+
+(defun gf-named (gf-name)
+  (let ((spec (cond ((symbolp gf-name) gf-name)
+		    ((and (consp gf-name)
+			  (eq (first gf-name) 'setf)
+			  (symbolp (second gf-name))
+			  (null (cddr gf-name)))
+		     (get-setf-function-name (second gf-name)))
+		    (t nil))))
+    (if (and (fboundp spec)
+	     (generic-function-p (symbol-function spec)))
+	(symbol-function spec)
+	nil)))
+
+(defun generic-function-method-names (gf-name hasdefp)
+  (if hasdefp
+      (let ((names nil))
+        (maphash #'(lambda (key value)
+                     (declare (ignore value))
+                     (when (and (consp key) (eql (car key) gf-name))
+                       (pushnew key names)))
+                 (gethash 'methods xcl:*definition-hash-table*))
+        names)
+      (let ((gf (gf-named gf-name)))
+        (when gf
+          (mapcar #'full-method-name (generic-function-methods gf))))))
+
+(defun full-method-name (method)
+  "Return the full name of the method"
+  (let ((specializers (mapcar #'(lambda (x)
+		                  (cond ((eq x 't) t)
+		                        ((and (consp x) (eq (car x) 'eql)) x)
+		                        (t (class-name x))))
+		       (method-type-specifiers method))))
+    ;; Now go through some hair to make sure that specializer is
+    ;; really right.  Once PCL returns the right value for
+    ;; specializers this can be taken out.
+    (let* ((arglist (method-arglist method))
+	   (number-required (or (position-if
+				  #'(lambda (x) (member x lambda-list-keywords))
+				  arglist)
+				(length arglist)))
+	   (diff (- number-required (length specializers))))
+      (when (> diff 0)
+	(setq specializers (nconc (copy-list specializers)
+				  (make-list diff :initial-element 't)))))
+    (make-full-method-name (generic-function-name
+			       (method-generic-function method))
+			   (method-qualifiers method)
+			   specializers)))
+
+(defun make-full-method-name (generic-function-name qualifiers arg-types)
+  "Return the full name of a method, given the generic-function name, the method
+qualifiers, and the arg-types"
+  ;; The name of the method is:
+  ;;      (<generic-function-name> <qualifier-1> .. 
+  ;;         (<arg-specializer-1>..))
+  (labels ((remove-trailing-ts (l)
+	     (if (null l)
+		 nil
+		 (let ((tail (remove-trailing-ts (cdr l))))
+		   (if (null tail)
+		       (if (eq (car l) 't)
+			   nil
+			   (list (car l)))
+		       (if (eq l tail)
+			   l
+			   (cons (car l) tail)))))))
+    `(,generic-function-name ,@qualifiers
+      ,(remove-trailing-ts arg-types))))
+
+(defun parse-full-method-name (method-name)
+  "Parse the method name, returning the gf-name, the qualifiers, and the
+arg-types."
+  (values (first method-name)
+	  (butlast (rest method-name))
+	  (car (last method-name))))
+
+(defun prompt-for-full-method-name (gf-name &optional has-def-p)
+  "Prompt the user for the full name of a method on the given generic function name"
+  (let ((method-names (generic-function-method-names gf-name has-def-p)))
+    (cond ((null method-names)
+	   nil)
+	  ((null (cdr method-names))
+	   (car method-names))
+	  (t (il:menu
+	      (il:create
+	       il:menu il:items il:_	;If HAS-DEF-P, include only
+					; those methods that have a
+					; symbolic def'n that we can
+					; find
+	       (remove-if #'null
+			  (mapcar #'(lambda (m)
+				      (if (or (not has-def-p)
+					      (il:hasdef m 'methods))
+					  `(,(with-output-to-string (s)
+					       (dolist (x m)
+						 (format s "~A " x))
+					       s)
+					    ',m)
+					  nil))
+				  method-names))
+	       il:title il:_ "Which method?"))))))
+
+
+;;; Converting generic defining macros into DEFDEFINER macros
+
+(defmacro make-defdefiner (definer-name definer-type type-description &body 
+					definer-options)
+  "Make the DEFINER-NAME use DEFDEFINER, defining items of type DEFINER-TYPE"
+  (let ((old-definer-macro-name (intern (string-append definer-name
+						       " old definition")
+					(symbol-package definer-name)))
+	(old-definer-macro-expander (intern (string-append definer-name 
+							   " old expander")
+					    (symbol-package definer-name))))
+    `(progn 
+      ;; First, move the current defining function off to some safe
+      ;; place
+      (unmake-defdefiner ',definer-name)
+      (cond ((not (fboundp ',definer-name))
+	     (error "~A has no definition!" ',definer-name))
+	    ((fboundp ',old-definer-macro-name))
+	    ((macro-function ',definer-name)
+					; We have to move the macro
+					; expansion function as well,
+					; so it won't get clobbered
+					; when the original macro is
+					; redefined.  See AR 7410.
+	     (let* ((expansion-function (macro-function ',definer-name)))
+	       (setf (symbol-function ',old-definer-macro-expander)
+		     (loop (if (symbolp expansion-function)
+			       (setq expansion-function
+				     (symbol-function expansion-function))
+			       (return expansion-function))))
+	       (setf (macro-function ',old-definer-macro-name)
+		     ',old-definer-macro-expander)
+	       (setf (get ',definer-name 'make-defdefiner) expansion-function)))
+	    (t (error "~A does not name a macro." ',definer-name)))
+      ;; Make sure the type is defined
+      (xcl:def-define-type ,definer-type ,type-description)
+      ;; Now redefine the definer, using DEFEDFINER and the original def'n
+      (xcl:defdefiner ,(if definer-options
+			   (cons definer-name definer-options)
+			   definer-name)
+	  ,definer-type	(&body b) `(,',old-definer-macro-name ,@,'b)))))
+
+(defun unmake-defdefiner (definer-name)
+  (let ((old-expander (get definer-name 'make-defdefiner)))
+    (when old-expander
+      (setf (macro-function definer-name old-expander))
+      (remprop definer-name 'make-defdefiner))))
+
+
+;;; For tricking ED into being able to use just the generic-function-name
+;;; instead of the full method name
+
+(defun source-manager-method-edit-fn (name type source editcoms options)
+  "Edit a method of the given name"
+  (let ((full-name (if (gf-named name)
+					;If given the name of a
+					; generic-function, try to get
+					; the full method name
+		       (prompt-for-full-method-name name t)
+					; Otherwise it should name the
+					; method
+		       name)))
+    (when (not (null full-name))
+      (il:default.editdef full-name type source editcoms options))
+    (or full-name name)))		;Return the name
+
+(defun source-manager-method-hasdef-fn (name type &optional source)
+  "Is there a method defined with the given name?"
+  (cond ((not (eq type 'methods)) nil)
+	((or (symbolp name)
+	     (and (consp name)
+		  (eq (first name) 'setf)
+		  (symbolp (second name))
+		  (null (cddr name))))
+	 ;; If passed in the name of a generic-function, pretend that
+	 ;; there is a method by that name if there is a generic function
+	 ;; by that name, and there is a method whose source we can find.
+	 (if (and (not (null (gf-named name)))
+		  (find-if #'(lambda (m)
+			       (il:hasdef m type source))
+			   (generic-function-method-names name t)))
+	     name
+	     nil))
+	((and (consp name) (>= (length name) 2))
+	 ;; Standard methods are named (gf-name {qualifiers}* ({specializers}*))
+	 (when (il:getdef name type source '(il:nocopy il:noerror))
+	   name))
+	(t
+	 ;; Nothing else can name a method
+	 nil)))
+
+;;; Initialize the PCL env
+
+(defun initialize-pcl-env nil
+  "Initialize the Xerox PCL environment" 
+  ;; Set up SourceManager DEFDEFINERS for classes and methods.
+  ;;
+  ;; Make sure to define methods before classes, so that (IL:FILES?) will build
+  ;; filecoms that have classes before methods. 
+  (unless (il:hasdef 'methods 'il:filepkgtype)
+    (make-defdefiner defmethod methods "methods"
+		     (:name (lambda (form)
+			      (multiple-value-bind (name qualifiers arglist)
+				  (parse-defmethod (cdr form))
+				(make-full-method-name name qualifiers
+				    (specialized-lambda-list-specializers
+					arglist)))))
+		     (:undefiner
+		      (lambda (method-name)
+			(multiple-value-bind
+			      (name qualifiers arg-types)
+			    (parse-full-method-name method-name)
+			  (let* ((gf (gf-named name))
+				 (method (when gf
+					   (get-method gf qualifiers
+						       (mapcar #'find-class 
+							       arg-types)))))
+			    (when method (remove-method gf method))))))))
+  ;; Include support for DEFGENERIC, if that is defined
+  (unless (or (not (fboundp 'defgeneric))
+	      (il:hasdef 'generic-functions 'il:filepkgtype))
+    (make-defdefiner defgeneric generic-functions "generic-function definitions"))
+  ;; DEFCLASS FileManager stuff
+  (unless (il:hasdef 'classes 'il:filepkgtype)
+    (make-defdefiner defclass classes "class definitions"
+		     (:undefiner (lambda (name)
+				   (when (find-class name t)
+				     (setf (find-class name) nil)))))
+    ;; CLASSES "include" TYPES.
+    (il:filepkgcom 'classes 'il:contents
+		   #'(lambda (com name type &optional reason)
+		       (declare (ignore name reason))
+		       (if (member type '(il:types classes) :test #'eq)
+			   (cdr com)
+			   nil))))
+  ;; Set up the hooks so that ED can be handed the name of a generic function,
+  ;; and end up editing a method instead
+  (il:filepkgtype 'methods 'il:editdef 'source-manager-method-edit-fn
+		  'il:hasdef 'source-manager-method-hasdef-fn)
+  ;; Set up the inspect macro.  The right way to do this is to
+  ;; (ENSURE-GENERIC-FUNCTION 'IL:INSPECT...), but for now...
+  (push '((il:function pcl-object-p) . \\internal-inspect-object)
+	il:inspectmacros)
+  ;; Unmark any SourceManager changes caused by this loadup
+  (dolist (com (il:filepkgchanges))
+    (dolist (name (cdr com))
+      (when (and (symbolp name)
+		 (eq (symbol-package name) (find-package "PCL")))
+	(il:unmarkaschanged name (car com))))))
+
+(eval-when (eval load)
+  (initialize-pcl-env))
+
+
+;;; Inspecting PCL objects
+
+(defun pcl-object-p (x)
+  "Is the datum a PCL object?"
+  (or (std-instance-p x)
+      (fsc-instance-p x)))
+
+(defun \\internal-inspect-object (x type where)
+  (inspect-object x type where))
+
+(defun \\internal-inspect-slot-names (x)
+  (inspect-slot-names x))
+
+(defun \\internal-inspect-slot-value (x slot-name)
+  (inspect-slot-value x slot-name))
+
+(defun \\internal-inspect-setf-slot-value (x slot-name value)
+  (inspect-setf-slot-value x slot-name value))
+
+(defun \\internal-inspect-slot-name-command (slot-name x window)
+  (inspect-slot-name-command slot-name x window))
+
+(defun \\internal-inspect-title (x y)
+  (inspect-title x y))
+
+(defmethod inspect-object (x type where)
+  "Open an insect window on the object x"
+  (il:inspectw.create x '\\internal-inspect-slot-names
+              '\\internal-inspect-slot-value
+              '\\internal-inspect-setf-slot-value
+              '\\internal-inspect-slot-name-command nil nil 
+              '\\internal-inspect-title nil where
+              #'(lambda (n v)		;Same effect as NIL, but avoids bug in
+		  (declare (ignore v))	; INSPECTW.CREATE
+		  n)))
+
+(defmethod inspect-slot-names (x)
+  "Return a list of names of slots of the object that should be shown in the
+inspector"
+  (mapcar #'(lambda (slotd) (slot-value slotd 'name))
+	  (slots-to-inspect (class-of x) x)))
+
+(defmethod inspect-slot-value (x slot-name)
+  (cond ((not (slot-exists-p x slot-name)) "** no such slot **")
+	((not (slot-boundp x slot-name)) "** slot not bound **")
+	(t (slot-value x slot-name))))
+
+(defmethod inspect-setf-slot-value (x slot-name value)
+  "Used by the inspector to set the value fo a slot"
+  ;; Make this UNDO-able
+  (il:undosave `(inspect-setf-slot-value ,x ,slot-name
+		 ,(slot-value x slot-name)))
+  ;; Then change the value
+  (setf (slot-value x slot-name) value))
+
+(defmethod inspect-slot-name-command (slot-name x window)
+  "Allows the user to select a menu item to change a slot value in an inspect
+window"
+  ;; This code is a very slightly hacked version of the system function
+  ;; DEFAULT.INSPECTW.PROPCOMMANDFN.  We have to do this because the
+  ;; standard version makes some nasty assumptions about
+  ;; structure-objects that are not true for PCL objects.
+  (declare (special il:|SetPropertyMenu|))
+  (case (il:menu (cond ((typep il:|SetPropertyMenu| 'il:menu)
+			il:|SetPropertyMenu|)
+		       (t (il:setq il:|SetPropertyMenu|
+				   (il:|create| il:menu il:items il:_
+				       '((set 'set 
+					  "Allows a new value to be entered"
+					  )))))))
+    (set 
+     ;; The user want to set the value
+     (il:ersetq (prog ((il:oldvalueitem (il:itemofpropertyvalue slot-name 
+								window))
+		       il:newvalue il:pwindow)
+		   (il:ttydisplaystream (il:setq il:pwindow
+						 (il:getpromptwindow window 3)))
+		   (il:clearbuf t t)
+		   (il:resetlst
+		    (il:resetsave (il:\\itemw.flipitem il:oldvalueitem window)
+				  (list 'il:\\itemw.flipitem 
+					il:oldvalueitem window))
+		    (il:resetsave (il:tty.process (il:this.process)))
+		    (il:resetsave (il:printlevel 4 3))
+		    (il:|printout| t "Enter the new " 
+			slot-name " for " x t 
+			"The expression read will be EVALuated."
+			t "> ")
+		    (il:setq il:newvalue (il:lispx (il:lispxread t t)
+						   '>))
+					; clear tty buffer because it
+					; sometimes has stuff left.
+		    (il:clearbuf t t))
+		   (il:closew il:pwindow)
+		   (return (il:inspectw.replace window slot-name il:newvalue)))))))
+
+(defmethod inspect-title (x window)
+  "Return the title to use in an inspect window viewing x"
+  (format nil "Inspecting a ~A" (class-name (class-of x))))
+
+(defmethod inspect-title ((x standard-class) window)
+  (format nil "Inspecting the class ~A" (class-name x)))
+
+
+;;;  Debugger support for PCL
+
+
+(il:filesload pcl-env-internal)
+
+;; Non-PCL specific changes to the debugger
+
+;; Redefining the standard INTERESTING-FRAME-P function.  Now functions can be
+;; declared uninteresting to BT by giving them an XCL::UNINTERESTINGP
+;; property.
+
+(dolist (fn '(si::*unwind-protect* il:*env*
+	      evalhook xcl::nohook xcl::undohook
+	      xcl::execa0001 xcl::execa0001a0002
+	      xcl::|interpret-UNDOABLY|
+	      cl::|interpret-IF| cl::|interpret-FLET|
+	      cl::|interpret-LET| cl::|interpret-LETA0001|
+	      cl::|interpret-BLOCK| cl::|interpret-BLOCKA0001|
+	      il:do-event il:eval-input
+	      apply t))
+  (setf (get fn 'xcl::uninterestingp) t))
+
+(defun xcl::interesting-frame-p (xcl::pos &optional xcl::interpflg)
+  "Return TRUE iff the frame should be visible for a short backtrace."
+  (declare (special il:openfns))
+  (let ((xcl::name (if (il:stackp xcl::pos) (il:stkname xcl::pos) xcl::pos)))
+    (typecase xcl::name
+      (symbol (case xcl::name
+		(il:*env*
+		 ;; *ENV* is used by ENVEVAL etc.
+		 nil)
+		(il:errorset
+		 (or (<= (il:stknargs xcl::pos) 1)
+		     (not (eq (il:stkarg 2 xcl::pos nil)
+			      'il:internal))))
+		(il:eval
+		 (or (<= (il:stknargs xcl::pos) 1)
+		     (not (eq (il:stkarg 2 xcl::pos nil)
+			      'xcl::internal))))
+		(il:apply
+		 (or (<= (il:stknargs xcl::pos) 2)
+		     (not (il:stkarg 3 xcl::pos nil))))
+		(otherwise
+		 (cond ((get xcl::name 'xcl::uninterestingp)
+			;; Explicitly declared uninteresting.
+			nil)
+		       ((eq (il:chcon1 xcl::name) (char-code #\\))
+			;; Implicitly declared uninteresting by starting the
+			;; name with a "\".
+			nil)
+		       ((or (member xcl::name il:openfns :test #'eq)
+			    (eq xcl::name 'funcall))
+			;;The function won't be seen when compiled, so only show
+			;;it if INTERPFLG it true
+			xcl::interpflg)
+		       (t 
+			;; Interesting by default.
+			t)))))
+       (cons (case (car xcl::name)
+	       (:broken t)
+	       (otherwise nil)))
+       (otherwise nil))))
+
+(setq il:*short-backtrace-filter* 'xcl::interesting-frame-p)
+
+
+(eval-when (eval compile)
+  (il:record il:bkmenuitem (il:label (il:bkmenuinfo il:frame-name))))
+
+
+;;  Change the frame inspector to open up lexical environments
+
+  ;; Since the DEFSTRUCT is going to build the accessors in the package that is
+  ;; current at read-time, and we want the accessors to reside in the IL
+  ;; package, we have got to make sure that the defstruct happens when the
+  ;; package is IL.
+
+(in-package "IL")
+
+(cl:defstruct (frame-prop-name (:type cl:list))
+  (label-fn 'nill)
+  (value-fn
+   (function
+    (lambda (prop-name framespec)
+     (frame-prop-name-data prop-name))))
+  (setf-fn 'nill)
+  (inspect-fn
+   (function
+    (lambda (value prop-name framespec window)
+     (default.inspectw.valuecommandfn value prop-name (car framespec) window))))
+  (data nil))
+
+(cl:in-package "PCL")
+
+(defun il:debugger-stack-frame-prop-names (il:framespec) 
+  ;; Frame prop-names are structures of the form
+  ;; (LABEL-FN VALUE-FN SETF-FN EDIT-FN DATA)
+  (let ((il:pos (car il:framespec))
+	(il:backtrace-item (cadr il:framespec)))
+    (il:if (eq 'eval (il:stkname il:pos))
+     il:then
+     (let ((il:expression (il:stkarg 1 il:pos))
+	   (il:environment (il:stkarg 2 il:pos)))
+       `(,(il:make-frame-prop-name :inspect-fn
+	   (il:function
+	    (il:lambda (il:value il:prop-name il:framespec il:window)
+	      (il:inspect/as/function il:value (car il:framespec) il:window)))
+	   :data il:expression)
+	 ,(il:make-frame-prop-name :data "ENVIRONMENT")
+	 ,@(il:for il:aspect il:in
+	    `((,(and il:environment (il:environment-vars il:environment))
+	       "vars")
+	      (,(and il:environment (il:environment-functions il:environment))
+	       "functions")
+	      (,(and il:environment (il:environment-blocks il:environment))
+	       "blocks")
+	      (,(and il:environment (il:environment-tagbodies il:environment))
+	       "tag bodies"))
+	    il:bind il:group-name il:p-list
+	    il:eachtime (il:setq il:group-name (cadr il:aspect))
+	                (il:setq il:p-list (car il:aspect))
+	    il:when (not (null il:p-list))
+	    il:join
+	    `(,(il:make-frame-prop-name :data il:group-name)
+	      ,@(il:for il:p il:on il:p-list il:by cddr il:collect
+		 (il:make-frame-prop-name :label-fn
+		  (il:function (il:lambda (il:prop-name il:framespec)
+				 (car (il:frame-prop-name-data il:prop-name))))
+		  :value-fn
+		  (il:function (il:lambda (il:prop-name il:framespec)
+				 (cadr (il:frame-prop-name-data il:prop-name))))
+		  :setf-fn
+		  (il:function (il:lambda (il:prop-name il:framespec il:new-value)
+				 (il:change (cadr (il:frame-prop-name-data
+						   il:prop-name))
+					    il:new-value)))
+		  :data il:p))))))
+     il:else
+     (flet ((il:build-name (&key il:arg-name il:arg-number)
+	      (il:make-frame-prop-name :label-fn
+		  (il:function (il:lambda (il:prop-name il:framespec)
+				 (car (il:frame-prop-name-data il:prop-name))))
+		  :value-fn
+		  (il:function (il:lambda (il:prop-name il:framespec)
+				 (il:stkarg (cadr (il:frame-prop-name-data
+						   il:prop-name))
+					    (car il:framespec))))
+		  :setf-fn
+		  (il:function (il:lambda (il:prop-name il:framespec il:new-value)
+				 (il:setstkarg (cadr (il:frame-prop-name-data
+						      il:prop-name))
+					       (car il:framespec)
+					       il:new-value)))
+		  :data
+		  (list il:arg-name il:arg-number))))
+       (let ((il:nargs (il:stknargs il:pos t))
+	     (il:nargs1 (il:stknargs il:pos))
+	     (il:fnname (il:stkname il:pos))
+	     il:argname
+	     (il:arglist))
+	 (and (il:litatom il:fnname)
+	      (il:ccodep il:fnname)
+	      (il:setq il:arglist (il:listp (il:smartarglist il:fnname))))
+	 `(,(il:make-frame-prop-name :inspect-fn
+	     (il:function (il:lambda (il:value il:prop-name il:framespec
+					       il:window)
+			    (il:inspect/as/function il:value
+						    (car il:framespec)
+						    il:window)))
+	     :data
+	     (il:fetch (il:bkmenuitem il:frame-name) il:of il:backtrace-item))
+	   ,@(il:bind il:mode il:for il:i il:from 1 il:to il:nargs1 il:collect
+	      (progn (il:while (il:fmemb (il:setq il:argname (il:pop il:arglist))
+					 lambda-list-keywords)
+			       il:do
+			       (il:setq il:mode il:argname))
+		     (il:build-name :arg-name
+				    (or (il:stkargname il:i il:pos)
+					; special
+					(if (case il:mode
+					      ((nil &optional) il:argname)
+					      (t nil))
+					    (string il:argname)
+					    (il:concat "arg " (- il:i 1))))
+				    :arg-number il:i)))
+	   ,@(let* ((il:novalue "No value")
+		    (il:slots (il:for il:pvar il:from 0 il:as il:i il:from
+				      (il:add1 il:nargs1)
+				      il:to il:nargs il:by 1 il:when
+				      (and (il:neq il:novalue (il:stkarg il:i il:pos
+									 il:novalue))
+					   (or (il:setq il:argname (il:stkargname
+								    il:i il:pos))
+					       (il:setq il:argname (il:concat 
+								    "local " 
+								    il:pvar)))
+					   )
+				      il:collect
+				      (il:build-name :arg-name il:argname 
+						     :arg-number il:i))))
+               (and il:slots (cons (il:make-frame-prop-name :data "locals")
+                                   il:slots)))))))))
+
+(defun il:debugger-stack-frame-fetchfn (il:framespec il:prop-name)
+  (il:apply* (il:frame-prop-name-value-fn il:prop-name)
+	     il:prop-name il:framespec))
+
+(defun il:debugger-stack-frame-storefn (il:framespec il:prop-name il:newvalue)
+  (il:apply* (il:frame-prop-name-setf-fn il:prop-name)
+	     il:prop-name il:framespec il:newvalue))
+
+(defun il:debugger-stack-frame-value-command (il:datum il:prop-name 
+						       il:framespec il:window)
+  (il:apply* (il:frame-prop-name-inspect-fn il:prop-name)
+	     il:datum il:prop-name il:framespec il:window))
+
+(defun il:debugger-stack-frame-title (il:framespec &optional il:window)
+  (declare (ignore il:window))
+  (il:concat (il:stkname (car il:framespec)) "  Frame"))
+
+(defun il:debugger-stack-frame-property (il:prop-name il:framespec)
+  (il:apply* (il:frame-prop-name-label-fn il:prop-name)
+	     il:prop-name il:framespec))
+
+;; Teaching the debugger that there are other file-manager types that can
+;; appear on the stack
+
+(defvar xcl::*function-types* '(il:fns il:functions)
+  "Manager types that can appear on the stack")
+
+;; Redefine a couple of system functions to use the above stuff
+
+#+Xerox-Lyric
+(progn
+
+(defun il:attach-backtrace-menu (&optional (il:ttywindow
+					    (il:wfromds (il:ttydisplaystream)))
+					   il:skip)
+  (let ((il:bkmenu (il:|create| il:menu
+		       il:items il:_
+		       (il:collect-backtrace-items il:ttywindow il:skip)
+		       il:whenselectedfn il:_
+		       (il:function il:backtrace-item-selected)
+		       il:whenheldfn il:_
+		       #'(il:lambda (il:item il:menu il:button)
+			   (declare (ignore il:item il:menu))
+			   (case il:button
+			     (il:left (il:promptprint 
+				       "Open a frame inspector on this stack frame"
+				       ))
+			     (il:middle (il:promptprint 
+					 "Inspect/Edit this function"))
+			     ))
+		       il:menuoutlinesize il:_ 0
+		       il:menufont il:_ il:backtracefont
+		       il:menucolumns il:_ 1))
+	(il:ttyregion (il:windowprop il:ttywindow 'il:region))
+	il:btw)
+    (cond
+      ((il:setq il:btw (il:|for| il:atw il:|in| (il:attachedwindows il:ttywindow)
+			   il:|when| (and (il:setq il:btw (il:windowprop il:atw 'il:menu))
+					  (eql (il:|fetch| (il:menu il:whenselectedfn)
+						   il:|of| (car il:btw))
+					       (il:function il:backtrace-item-selected)))
+			   il:|do|                       
+			   (return il:atw)))       
+       (il:deletemenu (car (il:windowprop il:btw 'il:menu))
+		      nil il:btw)
+       (il:windowprop il:btw 'il:extent nil)
+       (il:clearw il:btw))
+      ((il:setq il:btw (il:createw (il:region-next-to (il:windowprop il:ttywindow 'il:region)
+						      (il:widthifwindow (il:imin (il:|fetch| (il:menu 
+											      il:imagewidth
+											      )
+										     il:|of| il:bkmenu)
+										 il:|MaxBkMenuWidth|))
+						      (il:|fetch| (il:region il:height) il:|of| il:ttyregion
+							  )
+						      'il:left)))   
+       (il:attachwindow il:btw il:ttywindow (cond
+					      ((il:igreaterp (il:|fetch| (il:region il:left)
+								 il:|of| (il:windowprop
+									  il:btw
+									  'il:region))
+							     (il:|fetch| (il:region il:left)
+								 il:|of| il:ttyregion))
+					       'il:right)
+					      (t 'il:left))
+			nil
+			'il:localclose)
+       (il:windowprop il:btw 'il:process (il:windowprop il:ttywindow 'il:process))
+
+       ))
+    (il:addmenu il:bkmenu il:btw (il:|create| il:_ il:position
+				     il:xcoord il:_ 0
+				     il:ycoord il:_ (il:idifference (il:windowprop
+								     il:btw
+								     'il:height)
+								    (il:|fetch| (il:menu il:imageheight
+											 ) il:|of| 
+											   il:bkmenu
+											   ))))))
+
+(defun il:backtrace-item-selected (il:item il:menu il:button)
+  (il:resetlst
+   (prog (il:olditem il:ttywindow il:bkpos il:pos il:positions il:framewindow
+		     (il:framespecn (il:|fetch| (il:bkmenuitem il:bkmenuinfo) il:|of| il:item)
+
+				    ))
+      (cond
+	((il:setq il:olditem (il:|fetch| (il:menu il:menuuserdata) il:|of| il:menu))
+	 (il:menudeselect il:olditem il:menu)        
+	 ))
+      (il:setq il:ttywindow (il:windowprop (il:wfrommenu il:menu)
+					   'il:mainwindow))
+      (il:setq il:bkpos (il:windowprop il:ttywindow 'il:stack-position))
+      (il:setq il:pos (il:stknth (- il:framespecn)
+				 il:bkpos))
+      (let ((il:lp (il:windowprop il:ttywindow 'il:lastpos)))
+	(and il:lp (il:stknth 0 il:pos il:lp)))
+      (il:menuselect il:item il:menu)                
+      (if (eq il:button 'il:middle)
+	  (progn 
+
+
+	    (il:resetsave nil (list 'il:relstk il:pos))
+	    (il:inspect/as/function (il:|fetch| (il:bkmenuitem il:frame-name)
+					il:|of| il:item)
+				    il:pos il:ttywindow))
+	  (progn 
+
+
+	    (il:setq il:framewindow
+		     (xcl:with-profile (il:process.eval
+						  (il:windowprop il:ttywindow 'il:process)
+						  '(let ((il:profile (xcl:copy-profile (xcl:find-profile
+											"READ-PRINT"))))
+						    (setf (xcl::profile-entry-value '
+							   xcl:*eval-function* il:profile)
+						     xcl:*eval-function*)
+						    (xcl:save-profile il:profile))
+						  t)
+		       (il:inspectw.create (list il:pos il:item)
+				   'il:debugger-stack-frame-prop-names
+				   'il:debugger-stack-frame-fetchfn
+				   'il:debugger-stack-frame-storefn nil '
+				   il:debugger-stack-frame-value-command nil '
+				   il:debugger-stack-frame-title nil (
+								      il:make-frame-inspect-window
+								      il:ttywindow)
+				   'il:debugger-stack-frame-property)))
+	    (cond
+	      ((not (il:windowprop il:framewindow 'il:mainwindow))
+	       (il:attachwindow il:framewindow il:ttywindow
+				(cond
+				  ((il:igreaterp (il:|fetch| (il:region il:bottom)
+						     il:|of| (il:windowprop il:framewindow
+									    'il:region))
+						 (il:|fetch| (il:region il:bottom)
+						     il:|of| (il:windowprop il:ttywindow 'il:region)))
+				   'il:top)
+				  (t 'il:bottom))
+				nil
+				'il:localclose)
+	       (il:windowaddprop il:framewindow 'il:closefn (il:function il:detachwindow
+									 ))))))
+      (return))))
+
+(defun il:collect-backtrace-items (xcl::tty-window xcl::skip)
+   (let* ((xcl::items (cons nil nil))
+          (xcl::items-tail xcl::items))
+         (macrolet ((xcl::collect-item (xcl::new-item)
+                           `(progn (setf (rest xcl::items-tail)
+                                         (cons ,xcl::new-item nil))
+                                   (pop xcl::items-tail))))
+                (let* ((xcl::filter-fn (cond
+                                          ((null xcl::skip)
+                                           #'xcl:true)
+                                          ((eq xcl::skip t)
+                                           il:*short-backtrace-filter*)
+                                          (t xcl::skip)))
+                       (xcl::top-frame (il:stknth 0 (il:getwindowprop xcl::tty-window '
+                                                           il:stack-position)))
+                       (xcl::next-frame xcl::top-frame)
+                       (xcl::frame-number 0)
+                       xcl::interesting-p xcl::last-frame-consumed xcl::use-frame xcl::label)
+                      (loop (when (null xcl::next-frame)
+                                  (return))
+                            (multiple-value-setq (xcl::interesting-p xcl::last-frame-consumed 
+                                                        xcl::use-frame xcl::label)
+                                   (funcall xcl::filter-fn xcl::next-frame))
+                            (when (null xcl::last-frame-consumed)
+                                                            
+                                (setf xcl::last-frame-consumed xcl::next-frame))
+                            (when xcl::interesting-p        
+                                (when (null xcl::use-frame)
+                                      (setf xcl::use-frame xcl::last-frame-consumed))
+                                                             
+                                (when (null xcl::label)
+                                    (setf xcl::label (il:stkname xcl::use-frame))
+                                    (if (member xcl::label '(eval il:eval il:apply apply)
+                                               :test
+                                               'eq)
+                                        (setf xcl::label (il:stkarg 1 xcl::use-frame))))
+                                                            
+                                (loop (cond
+                                         ((not (typep xcl::next-frame 'il:stackp))
+                                          (error "~%Use-frame ~S not found" xcl::use-frame))
+                                         ((xcl::stack-eql xcl::next-frame xcl::use-frame)
+                                          (return))
+                                         (t (incf xcl::frame-number)
+                                            (setf xcl::next-frame (il:stknth -1 xcl::next-frame 
+                                                                         xcl::next-frame)))))
+                                                             
+                                (xcl::collect-item (il:|create| il:bkmenuitem
+                                                          il:label il:_ (let ((*print-level* 2)
+                                                                              (*print-length* 3)
+                                                                              (*print-escape* t)
+                                                                              (*print-gensym* t)
+                                                                              (*print-pretty* nil)
+                                                                              (*print-circle* nil)
+                                                                              (*print-radix* 10)
+                                                                              (*print-array* nil)
+                                                                              (il:*print-structure*
+                                                                               nil))
+                                                                             (prin1-to-string 
+                                                                                    xcl::label))
+                                                          il:bkmenuinfo il:_ xcl::frame-number
+                                                          il:frame-name il:_ xcl::label)))
+                                                             
+                            (loop (cond
+                                     ((not (typep xcl::next-frame 'il:stackp))
+                                      (error "~%Last-frame-consumed ~S not found" 
+                                             xcl::last-frame-consumed))
+                                     ((prog1 (xcl::stack-eql xcl::next-frame xcl::last-frame-consumed
+                                                    )
+                                          (incf xcl::frame-number)
+                                          (setf xcl::next-frame (il:stknth -1 xcl::next-frame 
+                                                             
+                                                                       xcl::next-frame)))
+                                      (return)))))))
+         (rest xcl::items)))
+
+)
+#+Xerox-Medley
+(progn
+
+(defun dbg::attach-backtrace-menu (&optional tty-window skip)
+  (declare (special il:\\term.ofd il:backtracefont))
+  (or tty-window (il:setq tty-window (il:wfromds (il:ttydisplaystream))))
+  (prog (btw bkmenu
+	     (tty-region (il:windowprop tty-window 'il:region))
+	     ;; And, for the FORMAT below...
+	     (*print-level* 2)
+	     (*print-length* 3)
+	     (*print-escape* t)
+	     (*print-gensym* t)
+	     (*print-pretty* nil)
+	     (*print-circle* nil)
+	     (*print-radix* 10)
+	     (*print-array* nil)
+	     (il:*print-structure* nil))
+     (setq bkmenu
+	   (il:|create| il:menu
+	       il:items il:_ (dbg::collect-backtrace-items tty-window skip)
+	       il:whenselectedfn il:_ 'dbg::backtrace-item-selected
+	       il:menuoutlinesize il:_ 0
+	       il:menufont il:_ il:backtracefont 
+	       il:menucolumns il:_ 1
+	       il:whenheldfn il:_
+	       #'(il:lambda (item menu button)
+		   (declare (ignore item menu))
+		   (case button
+		     (il:left
+		      (il:promptprint
+		       "Open a frame inspector on this stack frame"))
+		     (il:middle
+		      (il:promptprint "Inspect/Edit this function"))))))
+     (cond ((setq btw
+		  (dolist (atw  (il:attachedwindows tty-window))
+		    ;; Test for an attached window that has a backtrace menu in
+		    ;; it.
+		    (when (and (setq btw (il:windowprop atw 'il:menu))
+			   (eq (il:|fetch| (il:menu il:whenselectedfn)
+				   il:|of| (car btw))
+			       'dbg::backtrace-item-selected))
+		      (return atw))))
+	    ;; If there is alread a backtrace window, delete the old menu from
+	    ;; it.
+	    (il:deletemenu (car (il:windowprop btw 'il:menu)) nil btw)
+	    (il:windowprop btw 'il:extent nil)
+	    (il:clearw btw))
+	   ((setq btw
+		  (il:createw (dbg::region-next-to
+			       (il:windowprop tty-window 'il:region)
+			       (il:widthifwindow
+				(il:imin (il:|fetch| (il:menu il:imagewidth)
+					     il:|of| bkmenu)
+					 il:|MaxBkMenuWidth|))
+			       (il:|fetch| (il:region il:height)
+				   il:|of| tty-region)
+			       :left)))
+					; put bt window at left of TTY
+					; window unless ttywindow is
+					; near left edge.
+	    (il:attachwindow btw tty-window
+			     (if (il:igreaterp (il:|fetch| (il:region il:left)
+						   il:|of|
+						   (il:windowprop btw
+								  'il:region))
+					       (il:|fetch| (il:region il:left)
+						   il:|of| tty-region))
+				 'il:right
+				 'il:left)
+			     nil
+			     'il:localclose)
+	    ;; So that button clicks will switch the TTY
+	    (il:windowprop btw 'il:process
+			   (il:windowprop tty-window 'il:process))))
+     (il:addmenu bkmenu btw (il:|create| il:position
+				il:xcoord il:_ 0 
+				il:ycoord il:_ (- (il:windowprop btw 'il:height)
+						  (il:|fetch| (il:menu 
+							       il:imageheight)
+						      il:|of| bkmenu))))
+     ;; IL:ADDMENU sets up buttoneventfn for window that we don't
+     ;; want.  We want to catch middle button events before the menu
+     ;; handler, so that we can pop up edit/inspect menu for the frame
+     ;; currently selected.  So replace the buttoneventfn, and can
+     ;; nuke the cursorin and cursormoved guys, cause don't need them.
+     (il:windowprop btw 'il:buttoneventfn 'dbg::backtrace-menu-buttoneventfn)
+     (il:windowprop btw 'il:cursorinfn nil)
+     (il:windowprop btw 'il:cursormovedfn nil)))
+
+(defun dbg::collect-backtrace-items (tty-window skip)
+  (xcl:with-collection
+      ;;
+      ;; There are a number of possibilities for the values returned by the
+      ;; filter-fn.
+      ;;
+      ;; (1) INTERESTING-P is false, and the other values are all NIL.  This
+      ;; is the simple case where the stack frame NEXT-POS should be ignored
+      ;; completly, and processing should continue with the next frame.
+      ;;
+      ;; (2) INTERESTING-P is true, and the other values are all NIL.  This
+      ;; is the simple case where the stack frame NEXT-POS should appear in
+      ;; the backtrace as is, and processing should continue with the next
+      ;; frame.
+      ;;
+      ;; [Note that these two cases take care of old values of the
+      ;; filter-fn.]
+      ;;
+      ;; (3) INTERESTING-P is false, and LAST-FRAME-CONSUMED is a stack
+      ;; frame.  In that case, ignore all stack frames from NEXT-POS to
+      ;; LAST-FRAME-CONSUMED, inclusive.
+      ;;
+      ;; (4) INTERESTING-P is true, and LAST-FRAME-CONSUMED is a stack
+      ;; frame.  In this case, the backtrace should include a single entry
+      ;; coresponding to the frame USE-FRAME (which defaults to
+      ;; LAST-FRAME-CONSUMED), and processing should continue with the next
+      ;; frame after LAST-FRAME-CONSUMED.  If LABEL is non-NIL, it will be
+      ;; the label that appears in the backtrace menu; otherwise the name of
+      ;; USE-FRAME will be used (or the form being EVALed if the frame is an
+      ;; EVAL frame).
+      ;;
+      (let* ((filter (cond ((null skip) #'xcl:true)
+			   ((eq skip t) il:*short-backtrace-filter*)
+			   (t skip)))
+	     (top-frame (il:stknth 0 (il:getwindowprop tty-window
+					      'dbg::stack-position)))
+	     (next-frame top-frame)
+	     (frame-number 0)
+	     interestingp last-frame-consumed frame-to-use label-to-use)
+	(loop (when (null next-frame) (return))
+	      ;; Get the values of INTERSTINGP, LAST-FRAME-CONSUMED,
+	      ;; FRAME-TO-USE, and LABEL-TO-USE
+	      (multiple-value-setq (interestingp last-frame-consumed 
+						 frame-to-use label-to-use)
+		(funcall filter next-frame))
+	      (when (null last-frame-consumed)
+		(setf last-frame-consumed next-frame))
+	      (when interestingp
+		(when (null frame-to-use)
+		  (setf frame-to-use last-frame-consumed))
+		(when (null label-to-use)
+		  (setf label-to-use (il:stkname frame-to-use))
+		  (if (member label-to-use '(eval il:eval il:apply apply)
+			      :test 'eq)
+		      (setf label-to-use (il:stkarg 1 frame-to-use))))
+
+		;; Walk the stack until we find the frame to use
+		(loop (cond ((not (typep next-frame 'il:stackp))
+			     (error "~%Use-frame ~S not found" frame-to-use))
+			    ((xcl::stack-eql next-frame frame-to-use)
+			     (return))
+			    (t (incf frame-number)
+			       (setf next-frame
+				     (il:stknth -1 next-frame next-frame)))))
+
+		;; Add the menu item to the list under construction
+		(xcl:collect (il:|create| il:bkmenuitem
+				 il:label il:_ (let ((*print-level* 2)
+						     (*print-length* 3)
+						     (*print-escape* t)
+						     (*print-gensym* t)
+						     (*print-pretty* nil)
+						     (*print-circle* nil)
+						     (*print-radix* 10)
+						     (*print-array* nil)
+						     (il:*print-structure* nil))
+						 (prin1-to-string label-to-use))
+				 il:bkmenuinfo il:_ frame-number
+				 il:frame-name il:_ label-to-use)))
+
+	      ;; Update NEXT-POS
+	      (loop (cond ((not (typep next-frame 'il:stackp))
+			   (error "~%Last-frame-consumed ~S not found" 
+				  last-frame-consumed))
+			  ((prog1
+			       (xcl::stack-eql next-frame last-frame-consumed)
+			     (incf frame-number)
+			     (setf next-frame (il:stknth -1 next-frame
+							 next-frame)))
+			   (return))))))))
+
+(defun dbg::backtrace-menu-buttoneventfn (window &aux menu)
+  (setq menu (car (il:listp (il:windowprop window 'il:menu))))
+  (unless (or (il:lastmousestate il:up) (null menu))
+    (il:totopw window)
+    (cond ((il:lastmousestate il:middle)
+	   ;; look for a selected frame in this menu, and then pop up
+	   ;; the editor invoke menu for that frame.  don't change the
+	   ;; selection, just present the edit menu.
+	   (let* ((selection (il:menu.handler menu
+					  (il:windowprop window 'il:dsp)))
+		  (tty-window (il:windowprop window 'il:mainwindow))
+		  (last-pos (il:windowprop tty-window 'dbg::lastpos)))
+                        
+	     ;; don't have to worry about releasing POS because we
+	     ;; only look at it here (nobody here hangs on to it)
+	     ;; and we will be around for less time than LASTPOS. 
+	     ;; The debugger is responsible for releasing LASTPOS.
+	     (il:inspect/as/function (cond
+				       ((and selection
+					     (il:|fetch| (il:bkmenuitem il:frame-name)
+						 il:|of| (car selection))))
+				       ((and (symbolp (il:stkname last-pos))
+					     (il:getd (il:stkname last-pos)))
+					(il:stkname last-pos))
+				       (t 'il:nill))
+				     last-pos tty-window)))
+	  (t (let ((selection (il:menu.handler menu
+					   (il:windowprop window 'il:dsp))))
+	       (when selection
+		 (il:doselecteditem menu (car selection) (cdr selection))))))))
+
+;; This function isn't really redefined, but it needs to be recomiled since we
+;; changed the def'n of the BKMENUITEM record.
+
+(defun dbg::backtrace-item-selected (item menu button)
+  ;;When a frame name is selected in the backtrace menu, this is the function
+  ;;that gets called.
+  (declare (special il:brkenv) (ignore button))
+  (let* ((frame-spec (il:|fetch| (il:bkmenuitem il:bkmenuinfo) il:|of| item))
+	 (tty-window (il:windowprop (il:wfrommenu menu) 'il:mainwindow))
+	 (bkpos (il:windowprop tty-window 'dbg::stack-position))
+	 (pos (il:stknth (- frame-spec) bkpos)))
+    (let ((lp (il:windowprop tty-window 'dbg::lastpos)))
+      (and lp (il:stknth 0 pos lp)))
+    ;; change the item selected from OLDITEM to ITEM.  Only do this on left
+    ;; buttons now.  Middle just pops up the edit menu, doesn't select. -woz
+    (let ((old-item (il:|fetch| (il:menu il:menuuserdata) il:|of| menu)))
+      (when old-item (il:menudeselect old-item menu))
+      (il:menuselect item menu))
+    ;; Change the lexical environment so it is the one in effect as of this
+    ;; frame.
+    (il:process.eval (il:windowprop tty-window (quote dbg::process))
+	       `(setq il:brkenv ',(il:find-lexical-environment pos))
+	       t)
+    (let ((frame-window (xcl:with-profile
+			    (il:process.eval (il:windowprop tty-window
+							    'il:process)
+				       `(let ((profile (xcl:copy-profile
+							(xcl:find-profile
+							 "READ-PRINT"))))
+					 (setf
+					  (xcl::profile-entry-value
+					   'xcl:*eval-function* profile)
+					  xcl:*eval-function*)
+					 (xcl:save-profile profile))
+				       t)
+			  (il:inspectw.create pos
+				      #'(lambda (pos)
+					  (dbg::stack-frame-properties pos t))
+				      'dbg::stack-frame-fetchfn
+				      'dbg::stack-frame-storefn
+				      nil
+				      'dbg::stack-frame-value-command
+				      nil
+				      (format nil "~S  Frame" (il:stkname pos))
+				      nil (dbg::make-frame-inspect-window
+					   tty-window)
+				      'dbg::stack-frame-property))))
+      (when (not (il:windowprop frame-window 'il:mainwindow))
+	(il:attachwindow frame-window tty-window
+			 (if (> (il:|fetch| (il:region il:bottom) il:|of|
+				    (il:windowprop frame-window 'il:region))
+				(il:|fetch| (il:region il:bottom) il:|of|
+				    (il:windowprop tty-window 'il:region)))
+			     'il:top 'il:bottom)
+			 nil 'il:localclose)
+	(il:windowaddprop frame-window 'il:closefn 'il:detachwindow)))))
+
+)					;end of Xerox-Medley
+
+(defun il:select.fns.editor (&optional function)
+    ;; gives the user a menu choice of editors.
+    (il:menu (il:|create| il:menu
+		 il:items il:_ (cond ((il:ccodep function)
+				      '((il:|InspectCode| 'il:inspectcode 
+					 "Shows the compiled code.")
+					(il:|DisplayEdit| 'ed 
+					 "Edit it with the display editor")
+					(il:|TtyEdit| 'il:ef 
+					 "Edit it with the standard editor")))
+				     ((il:closure-p function)
+				      '((il:|Inspect| 'inspect 
+					 "Inspect this object")))
+				     (t '((il:|DisplayEdit| 'ed 
+					   "Edit it with the display editor")
+					  (il:|TtyEdit| 'il:ef 
+					   "Edit it with the standard editor"))))
+		 il:centerflg il:_ t)))
+
+;; 
+
+
+;; PCL specific extensions to the debugger
+
+
+;; There are some new things that act as functions, and that we want to be
+;; able to edit from a backtrace window
+
+(pushnew 'methods xcl::*function-types*)
+
+(eval-when (eval compile load)
+  (unless (generic-function-p (symbol-function 'il:inspect/as/function))
+    (make-specializable 'il:inspect/as/function)))
+
+(defmethod il:inspect/as/function (name stack-pointer debugger-window)
+  ;; Calls an editor on function NAME.  STKP and WINDOW are the stack pointer
+  ;; and window of the break in which this inspect command was called.
+  (declare (ignore debugger-window))
+  (let ((editor (il:select.fns.editor name)))
+    (case editor
+      ((nil) 
+       ;; No editor chosen, so don't do anything
+       nil)
+      (il:inspectcode 
+       ;; Inspect the compiled code
+       (let ((frame (xcl::stack-pointer-frame stack-pointer)))
+	 (if (and (il:stackp stack-pointer)
+		  (xcl::stack-frame-valid-p frame))
+	     (il:inspectcode (let ((code-base (xcl::stack-frame-fn-header frame)))
+			       (cond ((eq (il:\\get-compiled-code-base name)
+					  code-base)
+				      name)
+				     (t 
+				      ;; Function executing in this frame is not
+				      ;; the one in the definition cell of its
+				      ;; name, so fetch the real code.  Have to
+				      ;; pass a CCODEP
+				      (il:make-compiled-closure code-base))))
+                             nil nil nil (xcl::stack-frame-pc frame))
+	     (il:inspectcode name))))
+      (ed 
+       ;; Use the standard editor.
+       ;; This used to take care to apply the editor in the debugger
+       ;; process, so forms evaluated in the editor happen in the
+       ;; context of the break.  But that doesn't count for much any
+       ;; more, now that lexical variables are the way to go.  Better to
+       ;; use the LEX debugger command (thank you, Herbie) and
+       ;; shift-select pieces of code from the editor into the debugger
+       ;; window. 
+       (ed name `(,@xcl::*function-types* :display)))
+      (otherwise (funcall editor name)))))
+
+(defmethod il:inspect/as/function ((name standard-object) stkp window)
+  (when (il:menu (il:|create| il:menu
+		     il:items il:_ '(("Inspect" t "Inspect this object"))))
+    (inspect name)))
+
+(defmethod il:inspect/as/function ((x standard-method) stkp window)
+  (let* ((generic-function-name (slot-value (slot-value x 'generic-function)
+					    'name))
+	 (method-name (full-method-name x))
+	 (editor (il:select.fns.editor method-name)))
+    (il:allow.button.events)
+    (case editor
+      (ed (ed method-name '(:display methods)))
+      (il:inspectcode (il:inspectcode (slot-value x 'function)))
+      ((nil) nil)
+      (otherwise (funcall editor method-name)))))
+
+;; A replacement for the vanilla IL:INTERESTING-FRAME-P so we can see methods
+;; and generic-functions on the stack.
+
+(defun interesting-frame-p (stack-pos &optional interp-flag)
+  ;; Return up to four values:  INTERESTING-P LAST-FRAME-CONSUMED USE-FRAME and
+  ;; LABEL.  See the function IL:COLLECT-BACKTRACE-ITEMS for a full description
+  ;; of how these values are used.
+  (labels
+      ((function-matches-frame-p (function frame)
+	   "Is the function being called in this frame?"
+	   (let* ((frame-name (il:stkname frame))
+		  (code-being-run (cond
+				    ((typep frame-name 'il:closure)
+				     frame-name)
+				    ((and (consp frame-name)
+					  (eq 'il:\\interpreter
+					      (xcl::stack-frame-name
+					       (il:\\stackargptr frame))))
+				     frame-name)
+				    (t (xcl::stack-frame-fn-header
+					(il:\\stackargptr frame))))))
+	     (or (eq function code-being-run)
+		 (and (typep function 'il:compiled-closure)
+		      (eq (xcl::compiled-closure-fnheader function)
+			  code-being-run)))))
+       (generic-function-from-frame (frame)
+	 "If this the frame of a generic function return the gf, otherwise
+          return NIL."
+	 ;; Generic functions are implemented as compiled closures.  On the
+	 ;; stack, we only see the fnheader for the the closure.  This could
+	 ;; be a discriminator code, or in the default method only case it
+	 ;; will be the actual method function.  To tell if this is a generic
+	 ;; function frame, we have to check very carefully to see if the
+	 ;; right stuff is on the stack.  Specifically, the closure's ccode,
+	 ;; and the first local variable has to be a ptrhunk big enough to be
+	 ;; a FIN environment, and fin-env-fin of that ptrhunk has to point
+	 ;; to a generic function whose ccode and environment match. 
+	 (let ((n-args (il:stknargs frame))
+	       (env nil)
+	       (gf nil))
+	   (if (and ;; is there at least one local?
+		(> (il:stknargs frame t) n-args)
+		;; and does the local contain something that might be
+		;; the closure environment of a funcallable instance?
+		(setf env (il:stkarg (1+ n-args) frame))
+		;; and does the local contain something that might be
+		;; the closure environment of a funcallable instance?
+		(typep env *fin-env-type*)
+		(setf gf (fin-env-fin env))
+		;; whose fin-env-fin points to a generic function?
+		(generic-function-p gf)
+		;; whose environment is the same as env?
+		(eq (xcl::compiled-closure-env gf) env)
+		;; and whose code is the same as the code for this
+		;; frame? 
+		(function-matches-frame-p gf frame))
+	       gf
+	       nil))))
+    (let ((frame-name (il:stkname stack-pos)))
+      ;; See if there is a generic-function on the stack at this
+      ;; location.
+      (let ((gf (generic-function-from-frame stack-pos)))
+	(when gf
+	  (return-from interesting-frame-p (values t stack-pos stack-pos gf))))
+      ;; See if this is an interpreted method.  The method body is
+      ;; wrapped in a (BLOCK <function-name> ...).  We look for an
+      ;; interpreted call to BLOCK whose block-name is the name of
+      ;; generic-function.
+      (when (and (eq frame-name 'eval)
+		 (consp (il:stkarg 1 stack-pos))
+		 (eq (first (il:stkarg 1 stack-pos)) 'block)
+		 (symbolp (second (il:stkarg 1 stack-pos)))
+		 (fboundp (second (il:stkarg 1 stack-pos)))
+		 (generic-function-p
+		     (symbol-function (second (il:stkarg 1 stack-pos)))))
+	(let* ((form (il:stkarg 1 stack-pos))
+	       (block-name (second form))
+	       (generic-function (symbol-function block-name))
+	       (methods (generic-function-methods (symbol-function block-name))))
+	  ;; If this is really a method being called from a
+	  ;; generic-function, the g-f should be no more than a
+	  ;; few(?) frames up the stack.  Check for the method call
+	  ;; by looking for a call to APPLY, where the function
+	  ;; being applied is the code in one of the methods.
+	  (do ((i 100 (1- i))
+	       (previous-pos stack-pos current-pos)
+	       (current-pos (il:stknth -1 stack-pos) (il:stknth -1 current-pos))
+	       (found-method nil)
+	       (method-pos))
+	      ((or (null current-pos) (<= i 0)) nil)
+	    (cond ((equalp generic-function
+			   (generic-function-from-frame current-pos))
+		   (if found-method
+		       (return-from interesting-frame-p
+			 (values t previous-pos method-pos found-method))
+		       (return)))
+		  (found-method nil)
+		  ((eq (il:stkname current-pos) 'apply)
+		   (dolist (method methods)
+		     (when (eq (method-function method)
+			       (il:stkarg 1 current-pos))
+		       (setq method-pos current-pos)
+		       (setq found-method method)
+		       (return))))))))
+      ;; Try to handle compiled methods
+      (when (and (symbolp frame-name)
+		 (not (fboundp frame-name))
+		 (eq (il:chcon1 frame-name)
+		     (il:charcode il:\())
+		 (or (string-equal "(method " (symbol-name frame-name)
+			      :start2 0 :end2 13)
+		     (string-equal "(method " (symbol-name frame-name)
+			      :start2 0 :end2 12)
+		     (string-equal "(method " (symbol-name frame-name)
+			      :start2 0 :end2 8)))
+	;; Looks like a name that PCL consed up.  See if there is a
+	;; GF nearby up the stack.  If there is, use it to help
+	;; determine which method we have.
+	(do ((i 30 (1- i))
+	     (current-pos (il:stknth -1 stack-pos)
+			  (il:stknth -1 current-pos))
+	     (gf))
+	    ((or (null current-pos)
+		 (<= i 0))
+	     nil)
+	  (setq gf (generic-function-from-frame current-pos))
+	  (when gf
+	    (dolist (method (generic-function-methods gf))
+	      (when (function-matches-frame-p (method-function method)
+					      stack-pos)
+		(return-from interesting-frame-p
+		  (values t stack-pos stack-pos method))))
+	    (return))))
+      ;; If we haven't already returned, use the default method.
+      (xcl::interesting-frame-p stack-pos interp-flag))))
+
+
+(setq il:*short-backtrace-filter* 'interesting-frame-p)
+
+;;; Support for undo
+
+ (defun undoable-setf-slot-value (object slot-name new-value)
+    (if (slot-boundp object slot-name)
+      (il:undosave (list 'undoable-setf-slot-value
+                         object slot-name (slot-value object slot-name)))
+      (il:undosave (list 'slot-makunbound object slot-name)))
+    (setf (slot-value object slot-name) new-value))
+
+  (setf (get 'slot-value :undoable-setf-inverse) 'undoable-setf-slot-value)
+
+
+;;; Support for ?= and friends
+
+;; The arglists for generic-functions are built using gensyms, and don't reflect
+;; any keywords (they are all included in an &REST arg).  Rather then use the
+;; arglist in the code, we use the one that PCL kindly keeps in the generic-function.
+
+(xcl:advise-function 'il:smartarglist
+  '(if (and il:explainflg
+	(symbolp il:fn)
+	(fboundp il:fn)
+	(generic-function-p (symbol-function il:fn)))
+    (generic-function-pretty-arglist (symbol-function il:fn))
+    (xcl:inner))
+  :when :around :priority :last)
+
+(setf (get 'defclass 'il:argnames)
+      '(nil (class-name (#\{ superclass-name #\} #\*)
+	     (#\{ slot-specifier #\} #\*)
+	     #\{ slot-option #\} #\*)))
+
+(setf (get 'defmethod 'il:argnames)
+      '(nil (#\{ name #\| (setf name) #\} #\{ method-qualifier #\} #\*
+	     specialized-lambda-list #\{ declaration #\| doc-string #\} #\*
+	     #\{ form #\} #\*)))
+
+;;; Prettyprinting support, the result of Harley Davis.
+
+;; Support the standard Prettyprinter.  This is really minimal right now.  If
+;; anybody wants to fix this, I'd be happy to include their code.  In fact,
+;; there is almost no support for Commonlisp in the standard Prettyprinter, so
+;; the field is wide open to hackers with time on their hands.
+
+
+(setf (get 'defmethod :definition-print-template) ;Not quite right, since it
+      '(:name :arglist :body))		          ; doesn't handle qualifiers,
+		          		          ; but it will have to do.
+
+(defun defclass-prettyprint (form)
+  (let ((left (il:dspxposition))
+	(char-width (il:charwidth (il:charcode x) *standard-output*)))
+    (xcl:destructuring-bind (defclass name supers slots . options) form
+      (princ "(")
+      (prin1 defclass)
+      (princ " ")
+      (prin1 name)
+      (princ " ")
+      (if (null supers)
+	  (princ "()")			;Print "()" instead of "nil"
+	  (il:sequential.prettyprint (list supers) (il:dspxposition)))
+      (if (null slots)
+	  (progn (il:prinendline (+ left (* 4 char-width)) *standard-output*)
+		 (princ "()"))
+	  (il:sequential.prettyprint (list slots) (+ left (* 4 char-width))))
+      (when options
+	(il:sequential.prettyprint options (+ left (* 2 char-width))))
+      (princ ")")
+      nil)))
+
+(let ((pprint-macro (assoc 'defclass il:prettyprintmacros)))
+  (if (null pprint-macro)
+      (push (cons 'defclass 'defclass-prettyprint)
+	    il:prettyprintmacros)
+      (setf (cdr pprint-macro) 'defclass-prettyprint)))
+
+(defun binder-prettyprint (form)
+  ;; Prettyprints expressions like MULTIPLE-VALUE-BIND and WITH-SLOTS
+  ;; that are of the form (fn (var ...) form &rest body).
+  ;; This code is far from correct, but it's better than nothing.
+  (if (and (consp form)
+	   (not (null (cdddr form))))
+      ;; I have no idea what I'm doing here.  Seems I can copy and edit somebody
+      ;; elses code without understanding it.
+      (let ((body-indent (+ (il:dspxposition)
+			    (* 2 (il:charwidth (il:charcode x)
+					       *standard-output*))))
+	    (form-indent (+ (il:dspxposition)
+			    (* 4 (il:charwidth (il:charcode x)
+					       *standard-output*)))))
+	(princ "(")
+	(prin1 (first form))
+	(princ " ")
+	(il:superprint (second form) form nil *standard-output*)
+	(il:sequential.prettyprint (list (third form)) form-indent)
+	(il:sequential.prettyprint (cdddr form) body-indent)
+	(princ ")")
+	nil)				;Return NIL to indicate that we did
+					; the printing
+      t))				;Return true to use default printing
+
+
+(dolist (fn '(multiple-value-bind with-accessors with-slots))
+  (let ((pprint-macro (assoc fn 'il:prettyprintmacros)))
+    (if (null pprint-macro)
+	(push (cons fn 'binder-prettyprint)
+	      il:prettyprintmacros)
+	(setf (cdr pprint-macro) 'binder-prettyprint))))
+
+
+
+;; SEdit has its own prettyprinter, so we need to support that too.  This is due
+;; to Harley Davis.  Really.
+
+(push (cons :slot-spec
+	    '(((sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1)
+		break sedit::from-indent . 0)
+	       (sedit::set-indent . 1)
+	       (sedit::next-inline? 1 break sedit::from-indent . 1)
+	       (sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1)
+		break sedit::from-indent . 0))
+	      ((sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1)
+		break sedit::from-indent . 0)
+	       (sedit::set-indent . 1)
+	       (sedit::next-inline? 1 break sedit::from-indent . 1)
+	       (sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1)
+		break sedit::from-indent . 0))))
+    sedit:*indent-alist*)
+
+(setf (sedit:get-format :slot-spec)
+      '(:indent :slot-spec :inline t))
+
+(setf (sedit:get-format :slot-spec-list)
+      '(:indent :binding-list :args (:slot-spec) :inline nil))
+
+(setf (sedit:get-format 'defclass)
+      '(:indent ((2) 1)
+	:args (:keyword nil nil :slot-spec-list nil)
+	:sublists (4)))
+
+(setf (sedit:get-format 'defmethod)
+      '(:indent ((2))
+	:args (:keyword nil :lambda-list nil)
+	:sublists (3)))
+
+(setf (sedit:get-format 'defgeneric) 'defun)
+
+(setf (sedit:get-format 'generic-flet) 'flet)
+
+(setf (sedit:get-format 'generic-labels) 'flet)
+
+(setf (sedit:get-format 'call-next-method)
+      '(:indent (1) :args (:keyword nil)))
+
+(setf (sedit:get-format 'symbol-macrolet) 'let)
+
+(setf (sedit:get-format 'with-accessors)
+      '(:indent ((1) 1)
+	:args (:keyword :binding-list nil)
+	:sublists (2)
+	:miser :never))
+
+(setf (sedit:get-format 'with-slots) 'with-accessors)
+
+(setf (sedit:get-format 'make-instance)
+      '(:indent ((1))
+	:args (:keyword nil :slot-spec-list)))
+
+(setf (sedit:get-format '*make-instance) 'make-instance)
+
+;;; PrettyFileIndex stuff, the product of Harley Davis.
+
+(defvar *pfi-class-type* '(class defclass pfi-class-namer))
+
+(defvar *pfi-method-type* '(method defmethod pfi-method-namer)
+  "Handles method for prettyfileindex")
+
+(defvar *pfi-index-accessors* nil
+  "t -> each slot accessor gets a listing in the index.")
+
+(defvar *pfi-method-index* :group
+  ":group, :separate, :both, or nil")
+
+(defun pfi-add-class-type ()
+  (pushnew *pfi-class-type* il:*pfi-types*))
+
+(defun pfi-add-method-type ()
+  (pushnew *pfi-method-type* il:*pfi-types*))
+
+(defun pfi-class-namer (expression entry)
+  (let ((class-name (second expression)))
+    ;; Following adds all slot readers/writers/accessors as separate entries in
+    ;; the index.  Probably a mistake.
+    (if *pfi-index-accessors*
+	(let ((slot-list (fourth expression))
+	      (accessor-names nil))
+	  (labels ((add-accessor (method-index name-index)
+		     (push (case *pfi-method-index*
+			     (:group method-index)
+			     (:separate name-index)
+			     ((t :both) (list method-index name-index))
+			     ((nil) nil)
+			     (otherwise (error "Illegal value for *pfi-method-index*: ~S"
+					       *pfi-method-index*)))
+			   accessor-names))
+		   (add-reader (reader-name)
+		     (add-accessor `(method (,reader-name (,class-name)))
+				   `(,reader-name (,class-name))))
+		   (add-writer (writer-name)
+		     (add-accessor `(method ((setf ,writer-name) (t ,class-name)))
+				   `((setf ,writer-name) (t ,class-name)))))
+	    (dolist (slot-def slot-list)
+	      (do* ((rest-slot-args (cdr slot-def) (cddr rest-slot-args))
+		    (slot-arg (first  rest-slot-args)  (first rest-slot-args)))
+		   ((null rest-slot-args))
+ 		(case slot-arg
+		  (:reader (add-reader (second rest-slot-args)))
+		  (:writer (add-writer (second rest-slot-args)))
+		  (:accessor (add-reader (second rest-slot-args))
+			     (add-writer (second rest-slot-args)))
+		  (otherwise nil))))
+	    (cons `(class (,class-name)) accessor-names)))
+	class-name)))
+
+(defun pfi-method-namer (expression entry)
+  (let ((method-name (second expression))
+	(specializers nil)
+	(qualifiers nil)
+	lambda-list)
+    (do* ((rest-qualifiers (cddr expression) (cdr rest-qualifiers))
+	  (qualifier (first rest-qualifiers) (first rest-qualifiers)))
+	 ((listp qualifier) (setq lambda-list qualifier)
+	                    (setq qualifiers (reverse qualifiers)) qualifiers)
+      (push qualifier qualifiers))
+    (do* ((rest-lambda-list lambda-list (cdr rest-lambda-list))
+	  (arg (first rest-lambda-list) (first rest-lambda-list)))
+	 ((or (member arg lambda-list-keywords) (null rest-lambda-list))
+	  (setq specializers (reverse specializers)))
+      (push (if (listp arg) (second arg) t) specializers))
+    (let ((method-index `(method (,method-name ,@qualifiers ,specializers)))
+	  (name-index `(,method-name ,@qualifiers ,specializers)))
+      (case *pfi-method-index*
+	(:group method-index)
+	(:separate name-index)
+	((t :both) (list method-index name-index))
+	((nil) nil)
+	(otherwise (error "Illegal value for *pfi-method-index*: ~S" *pfi-method-index*))))))
+
+(defun pfi-install-pcl ()
+  (pfi-add-method-type)
+  (pfi-add-class-type))
+
+(eval-when (eval load)
+  (when (boundp (quote il:*pfi-types*))
+    (pfi-install-pcl))
+  )
diff --git a/pcl/pcl-env.text b/pcl/pcl-env.text
new file mode 100644
index 0000000000000000000000000000000000000000..9565290219650c5e51a1c06be17a4019e2be5ed7
--- /dev/null
+++ b/pcl/pcl-env.text
@@ -0,0 +1,104 @@
+A (very) few words about PCL-ENV.  If you require more information, consult the
+source code.  While it is not particularly well documented, it is the final
+arbiter of truth regarding its own functionality.
+
+The file PCL-ENV.LISP defines some low-level facilities to integrate PCL into
+the XeroxLisp environment.  The first order of business is teaching the
+FileManager (nee FilePackage) about CLOS defineing forms.  This in turn brings
+us to the issue of names.
+
+
+o  Names and the FileManager
+
+For the FileManager to keep track of defining forms, it needs to know how to
+extract a (unique) name and FileManager type from the form.  PCL-ENV includes
+FileManager support for the definers DEFCLASS, DEFGENERIC, and DEFMETHOD.
+
+DEFCLASS
+The name of a DEFCLASS form is the name of the class defined by the form.  The
+FileManager type is PCL::CLASSES.  There is a FileManager "undefiner" provided
+for DEFCLASS.
+
+DEFGENERIC
+The name of a DEFGENERIC form is the name of the generic-function defined by the
+form.  The FileManager type is PCL::GENERIC-FUNCTIONS.
+
+DEFMETHOD
+The name of a DEFMETHOD form is a list of the form
+(<gf-name> {<qualifier>}* ({<specializer>*})).  The FileManager type is
+PCL::METHODS.  There is a FileManager "undefiner" provided for DEFMETHOD.
+However, note that if a generic-function was created as a side-effect of the
+DEFMETHOD, the undefiner will leave the generic-function defined (albet with no
+methods).
+
+When editing, it would be onerous to require the programmer to type in the full name of a
+method.  PCL-ENV arranges it so that (ED <gf-name>) will ask the programmer
+which method on that generic-function should be edited.  (If there is only one
+method, it is assumed that that is the method to be edited.)  As of the
+Victoria-Day release, EQL specialized methods are handled correctly.
+
+
+o  Inspecting CLOS objects (and metaobjects)
+
+PCL-ENV defines a protocol that is used to inspect objects, and arranges that
+the standard INSPECT function uses this protocol.  Programmers can use this
+protocol by defining additional methods on the following generic-functions.
+
+INSPECT-SLOT-NAMES object
+Returns a list of "slots" to include in the inspector.  The default method
+returns a list of all slots on the object.
+
+INSPECT-SLOT-VALUE object slot-name
+Returns the value to associated with the slot-name in the inspector.  Slot-name
+is one of the items returned by INSPECT-SLOT-NAMES.  The default method returns
+(SLOT-VALUE object slot-name).
+
+INSPECT-SETF-SLOT-VALUE object slot-name new-value
+Sets the value associated with the slot-name in the inspector.  Slot-name is one
+of the items returned by INSPECT-SLOT-NAMES.  The default method executes
+(SETF (SLOT-VALUE object slot-name) new-value).
+
+INSPECT-TITLE object inspect-window
+Returns the title to use in the inspect-window when inspecting object.  The
+default returns the string "Inspecting the class <class-name>" when the object
+is a class, or "Inspecting a <class-name>" otherwise.
+
+
+o  Debugging and the Stack
+
+Debugging in PCL is complicated by generic-functions and methods appear on the
+stack not as single objects, but as collections of functions that the programmer
+did not directly call.  PCL-ENV redefines a number of internal debugger
+functions to simplify the presentation of the stack, and allow the programmer to
+access to the original defining forms from the stack.  These changes only affect
+the "short" display backtrace (brought up by BT in a break window); the full
+backtrace (brought up by BT!) is unaffected.
+
+
+o  Misc
+
+Prettyprinting
+
+The support for standard Prettyprinting is pretty minimal.  Only DEFMETHOD,
+DEFCLASS, WITH-ACCESSORS, and WITH-SLOTS are supported, and they aren't really
+done right.  Thanks to Harley Davis, PCL-ENV defines SEdit pretty-print specs
+for the forms DEFCLASS, DEFMETHOD, DEFGENERIC, GENERIC-FLET, GENERIC-LABELS,
+CALL-NEXT-METHOD, SYMBOL-MACROLET, WITH-ACCESSORS, WITH-SLOTS, and
+MAKE-INSTANCE.
+
+?=
+
+The function SMARTARGLIST is changed to return appropriate values for the
+arglists of generic-functions.  The macros DEFCLASS and DEFMETHOD have "pretty"
+arglists defined.
+
+PrettyFileIndex
+
+Again thanks to Harley Davis, PCL-ENV teaches PRETTY-FILE-INDEX about classes,
+methods, and accessors.  The variables PCL::*PFI-INDEX-ACCESSORS* and
+PCL::*PFI-METHOD-INDEX* may be changed by the user to tailor the computation of
+the file index.  Note that the file PRETTY-FILE-INDEX must be loaded before
+PCL-ENV for this to take effect.
+
+
+--- smL								25-May-89
diff --git a/pcl/pkg.lisp b/pcl/pkg.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..aece6d9da7b84d0854792c753ffbd35b252e0b41
--- /dev/null
+++ b/pcl/pkg.lisp
@@ -0,0 +1,178 @@
+;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+
+(in-package 'pcl)
+
+;;;
+;;; 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 PCL
+;;; package.
+;;;
+#+TI
+(shadow '(string-append once-only destructuring-bind
+	  memq assq delq neq true false
+	  without-interrupts
+	  defmethod)
+	*the-pcl-package*)
+
+#+GCLisp
+(shadow '(string-append memq assq delq neq make-instance)
+	*the-pcl-package*)
+
+#+Genera
+(shadowing-import '(zl:arglist zwei:indentation) *the-pcl-package*)
+
+#+Lucid 
+(import #-LCL3.0 'system:arglist
+	#+LCL3.0 'lcl:arglist
+	*the-pcl-package*)
+
+
+
+(shadow '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
+		    ))
+
+);eval-when 
+
+#-(or KCL IBCL)
+(export *exports* *the-pcl-package*)
+
+#+(or KCL IBCL)
+(mapc 'export (list *exports*) (list *the-pcl-package*))
+
+
+
+;(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
+;
+;
+;			  ))
diff --git a/pcl/plap.lisp b/pcl/plap.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..41c8d7bf74640781e87b72a8c24c9e102b48918e
--- /dev/null
+++ b/pcl/plap.lisp
@@ -0,0 +1,302 @@
+;;;-*-Mode: LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+
+(in-package 'pcl)
+
+;;;
+;;; 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)
+	    `(function
+	       ,(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*)))
+	   ,.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 () `(go exit-lap-in-lisp))
+    
+    (:break ()      `(break))
+    (:beep  ()      #+Genera`(zl:beep))
+    (: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-pcl-package*))
+
+
+;;;
+;;; Runtime Implementations of the operands and opcodes.
+;;;
+;;; In those ports of PCL 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 pcl-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)
+  #-Lucid `(the fixnum (logand (the fixnum ,index1) (the fixnum ,index2)))
+  #+Lucid `(%logand ,index1 ,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))
+
diff --git a/pcl/precom1.lisp b/pcl/precom1.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..858a657fffecc1c24403eb23de0ac0fc74cb5261
--- /dev/null
+++ b/pcl/precom1.lisp
@@ -0,0 +1,49 @@
+;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+
+(in-package 'pcl)
+
+;;;
+;;; 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 PCL 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)
diff --git a/pcl/precom2.lisp b/pcl/precom2.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..6e0c9f9c8311800daeba153311781058589815d4
--- /dev/null
+++ b/pcl/precom2.lisp
@@ -0,0 +1,30 @@
+;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+
+(in-package 'pcl)
+
+(precompile-dfun-constructors pcl)		;this is half of a call to
diff --git a/pcl/precom4.lisp b/pcl/precom4.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..21fa1b2b4176130d128a6e25edd79cae4e7ad525
--- /dev/null
+++ b/pcl/precom4.lisp
@@ -0,0 +1,31 @@
+;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+
+(in-package 'pcl)
+
+(precompile-function-generators pcl)		;this is half of a call to
+						;precompile-random-code-segments
diff --git a/pcl/pyr-low.lisp b/pcl/pyr-low.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..97ee85cc14aaf16685db2593ed16848147fe7d52
--- /dev/null
+++ b/pcl/pyr-low.lisp
@@ -0,0 +1,49 @@
+;;; -*- Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;; 
+;;; This is the Pyramid version of low.lisp -- it runs with versions 1.1
+;;; and newer -- Created by David Bein Mon May  4 11:22:30 1987
+;;;
+(in-package 'pcl)
+
+  ;;   
+;;;;;; Cache No's
+  ;;  
+
+;;; The purpose behind the shift is that the bottom 2 bits are always 0
+;;; We use the same scheme for symbols and objects although a good
+;;; case may be made for shifting objects more since they will
+;;; be aligned differently...
+
+;(defmacro symbol-cache-no (symbol mask)
+;  `(logand (the fixnum (ash (lisp::%sp-make-fixnum ,symbol) -2))
+;	  (the fixnum ,mask)))
+
+(defmacro object-cache-no (symbol mask)
+  `(logand (the fixnum (ash (lisp::%sp-make-fixnum ,symbol) -2))
+	  (the fixnum ,mask)))
+
+
diff --git a/pcl/pyr-patches.lisp b/pcl/pyr-patches.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..619d68774e486613700293eda302a925445abbca
--- /dev/null
+++ b/pcl/pyr-patches.lisp
@@ -0,0 +1,8 @@
+(in-package 'pcl)
+
+;;; This next kludge disables macro memoization (the default) since somewhere
+;;; in PCL, the memoization is getting in the way.
+
+(eval-when (load eval)
+    (format t "~&;;; Resetting *MACROEXPAND-HOOK* to #'FUNCALL~%")
+    (setq lisp::*macroexpand-hook* #'funcall))
diff --git a/pcl/quadlap.lisp b/pcl/quadlap.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..0aef18578f90b9640a717821d60f5c8838304c49
--- /dev/null
+++ b/pcl/quadlap.lisp
@@ -0,0 +1,617 @@
+;;				-[Thu Mar  1 10:54:27 1990 by jkf]-
+;; pcl to quad translation
+;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/quadlap.lisp,v 1.1 1990/08/12 03:48:14 wlott Exp $
+;;
+;; copyright (c) 1990 Franz Inc.
+;;
+(in-package :compiler)
+
+
+
+
+(defvar *arg-to-treg* nil)
+(defvar *cvar-to-index* nil)
+(defvar *reg-array* nil)
+(defvar *closure-treg* nil)
+(defvar *nargs-treg* nil)
+
+(defvar *debug-sparc* nil)
+
+(defmacro pcl-make-lambda (&key required)
+  `(list 'lambda nil :unknown-type 0 compiler::.function-level. 
+	,required nil nil nil nil nil nil nil nil nil 
+	nil 'compiler::none nil nil nil 
+	nil nil nil nil nil nil 0 nil))
+
+(defmacro pcl-make-varrec (&key name loc contour-level)
+  `(list ,name nil 0 nil ,loc nil t compiler::.function-level. nil nil :unknown-type nil nil ,contour-level))
+
+(defmacro pcl-make-lap (&key lap constants cframe-size locals)
+  `(list nil ,constants ,lap nil nil ,cframe-size ,locals nil nil nil))
+
+
+(defstruct preg 
+  ;; pseudo reg descritpor
+  treg		; associated treg
+  index 	; :index if this is an index type reg
+  		; :vector if this is a vector type reg
+  )
+
+
+(defun pcl::excl-lap-closure-generator (closure-vars-names
+				   arg-names
+				   index-regs
+				   vector-regs
+				   t-regs
+				   lap-code)
+  (let ((function (pcl::excl-lap-closure-gen closure-vars-names
+				   arg-names
+				   index-regs
+				   vector-regs
+				   t-regs
+				   lap-code)))
+    #'(lambda (&rest closure-vals)
+	(insert-closure-vals function closure-vals))))
+
+
+(defun pcl::excl-lap-closure-gen
+    (closure-vars-names arg-names index-regs vector-regs t-regs lap-code)
+  (let ((*quads* nil)
+	(*treg-num* 0)
+	(*all-tregs* nil)
+	(*bb-count* 0)
+	*treg-bv-size*
+	*treg-vector*
+	(*next-catch-frame* 0)
+	(*max-catch-frame* -1)
+	*catch-labels*
+	*top-label*
+	*mv-treg*
+	*mv-treg-target*
+	*zero-treg*
+	*nil-treg*
+	*bbs* *bb* lap
+	;; bbs
+	*cross-block-regs*
+	*const-tregs* *move-tregs*
+	*actuals*
+	*ignore-argcount*
+	*binds-specs*
+	*bvl-current-bv* ; for bitvector cacher
+	*bvl-used-bvs*
+	*bvl-index*
+	(*inhibit-call-count* t)
+	
+	; this fcn
+	*arg-to-treg*
+	*cvar-to-index* 
+	*reg-array*
+	minargs
+	maxargs
+	*closure-treg*
+
+	node
+	otherargregs
+	
+	*nargs-treg*
+	)
+
+    (if* *debug-sparc* 
+       then (format t ">>** << Generating sparc lap code~%"))
+    
+    (setq *nil-treg* 
+      #+allegro-v4.0 (new-reg :global t)
+      #-allegro-v4.0 (new-reg)
+      *mv-treg* (new-reg)
+      *mv-treg-target* (list *mv-treg*)
+      *zero-treg* (comp::new-reg))
+    
+    ; examine given args
+    
+    (setq minargs 0  maxargs 0)
+    (let (requireds)
+      (dolist (arg arg-names)
+	(if* (eq '&rest arg)
+	   then (setq maxargs nil)
+	   else (if* (null arg)
+		   then ; we want a name even though we won't use it
+			(setq arg (gensym)))
+		(incf minargs)
+		(incf maxargs)
+		(push (cons arg (new-reg)) *arg-to-treg*)
+		(push (pcl-make-varrec :name arg 
+				   :loc (cdr (car *arg-to-treg*))
+				   :contour-level 0)
+		      requireds)
+		))
+      (setq node (pcl-make-lambda :required  (nreverse requireds))))
+    (setq *arg-to-treg* (nreverse *arg-to-treg*))
+    
+    ; build closure vector list
+    (let ((index -1))
+      (dolist (cvar closure-vars-names)
+	(push (cons cvar (incf index)) *cvar-to-index*)))
+    
+    (let ((maxreg (max (apply #'max (cons -1 index-regs))
+		       (apply #'max (cons -1 vector-regs))
+		       (apply #'max (cons -1 t-regs)))))
+      (setq *reg-array* (make-array (1+ maxreg))))
+    
+    (dolist (index index-regs)
+      (setf (svref *reg-array* index)
+	(make-preg :treg (new-reg)
+		   :index :index)))
+    
+    (dolist (vector vector-regs)
+      (setf (svref *reg-array* vector) 
+	(make-preg :treg (new-reg)
+		   :index :vector)))
+    
+    (dolist (tr t-regs)
+      (setf (svref *reg-array* tr) (make-preg :treg (new-reg))))
+    
+
+    (if* closure-vars-names
+       then (setq *closure-treg* (new-reg)))
+    (setq *nargs-treg* (new-reg))
+        
+    ;; (md-allocate-global-tregs)
+    
+    ; function entry
+    (qe nop :arg :first-block)
+    (qe entry)
+    (qe argcount :arg (list minargs maxargs))
+    (qe lambda :d (mapcar #'cdr *arg-to-treg*))
+    (qe register :arg :nargs :d (list *nargs-treg*))
+
+    (if* *closure-treg*
+       then ; put the first closure vector in *closure-treg*
+	    (qe extract-closure-vec :d (list *closure-treg*))
+	    (let ((offsetreg (new-reg)))
+	      (qe const :arg (mdparam 'md-cons-car-adj) :d (list offsetreg))
+	      (qe ref :u (list *closure-treg* offsetreg) 
+		  :d (list *closure-treg*)
+		  :arg :long))
+	    )
+
+    (excl-gen-quads lap-code)
+
+    (if* *debug-sparc*
+       then (do-quad-list (quad next *quads*)
+	      (format t "~a~%" quad))
+
+	    (format t "basic blocks~%"))
+    
+    (setq *bbs* (qc-compute-basic-blocks *quads*))
+    
+    (excl::target-class-case
+     ((:r :m) (setq *actuals* (qc-compute-actuals *bbs*))))
+    
+    (qc-live-variable-analysis *bbs*)
+    
+    (setq *treg-bv-size* (* 16 (truncate (+ *treg-num* 15) 16)))
+      
+    (qc-build-treg-vector)
+    
+
+    (let ((*dump-bbs* nil)
+	  (r::*local-regs*
+	   ; use the in registers that aren't in use
+	   (append r::*local-regs*
+		   (if* maxargs
+		      then (nthcdr maxargs r::*in-regs* )))))
+      (unwind-protect
+	  (progn
+	    ; machine specific code generation
+	    (multiple-value-bind (lap-code literals size-struct locals)
+		#+(target-class r m e)
+		(progn
+		  #+allegro-v4.0 
+		  (md-codegen node *bbs*
+			      nil otherargregs)
+		  #-allegro-v4.0 
+		  (md-codegen node *bbs*
+			      *nil-treg* *mv-treg* *zero-treg*
+			      nil otherargregs))
+		  
+		#-(target-class r m e) (md-codegen node *bbs*)
+		(setq lap
+		  (pcl-make-lap :lap lap-code
+			    :constants literals
+			    :cframe-size size-struct
+			    :locals  locals)))
+
+	     
+	    lap)
+	(giveback-bvs)))
+    
+    #+ignore 
+    (progn (format t "sparc code pre optimization~%")
+	   (dolist (instr (lap-lap lap))
+	     (format t "> ~a~%" instr)))
+    (md-optimize lap) ; peephole optimize
+    (if* *debug-sparc*
+       then (format t "sparc code post optimization~%")
+	    (dolist (instr (lap-lap lap))
+	      (format t "> ~a~%" instr)))
+    (md-assemble lap)
+    (setq last-lap lap)
+ 
+    (nl-runtime-make-a-fcnobj lap)))
+
+(defun qe-slot-access (operand offset dest)
+  ;; access a slot in a structure
+  (let ((temp (new-reg)))
+    (qe const :arg offset :d (list temp))
+    (qe ref :u (list (get-treg-of operand) temp) 
+	:d (list (get-treg-of dest))
+	:arg :long)))
+
+
+(defun get-treg-of (operand &optional res-operand)
+  ;; get the appropriate treg for the operand
+  (let ((prefer-treg (and res-operand (simple-get-treg-of res-operand))))
+    (if* (numberp operand)
+       then (let ((treg (new-reg)))
+	      (qe const :arg operand :d (list treg))
+	      treg)
+     elseif (consp operand)
+       then (ecase (car operand)
+	      (:reg 
+	       (preg-treg (svref *reg-array* (cadr operand))))
+	      (:arg 
+	       (let ((x (cdr (assoc (cadr operand) *arg-to-treg* :test #'eq))))
+		 (if* (null x)
+		    then (error "where is arg ~s" operand)
+		    else x)))
+	      (:cvar
+	       (let ((res-treg (or prefer-treg (new-reg)))
+		     (temp-treg (new-reg)))
+		 (qe const :arg (+ (mdparam 'md-svector-data0-adj)
+				   (* 4 (cdr (assoc (cadr operand)
+						    *cvar-to-index*
+						    :test #'eq))))
+		     :d (list temp-treg))
+		 (qe ref :u (list *closure-treg* temp-treg)
+		     :d (list res-treg)
+		     :arg :long)
+		 res-treg))
+	      (:constant
+	       (let ((treg (or prefer-treg (new-reg))))
+		 (qe const :arg (if* (fixnump (cadr operand))
+				   then (* 8 (cadr operand)) ; md!!
+				   else (cadr operand))
+		     :d (list treg))
+		 treg))
+	      (:index-constant
+	       ; operand invented by jkf to denote an index type constant
+	       (let ((treg (or prefer-treg (new-reg))))
+		 (qe const :arg (if* (fixnump (cadr operand))
+				   then (* 4 (cadr operand)) ; md!!
+				   else (cadr operand))
+		     :d (list treg))
+		 treg)))
+       else (error "bad operand: ~s" operand))))
+
+(defun simple-get-treg-of (operand)
+  ;; get the treg if it is so simple that we don't have to 
+  ;; emit any instructions to access it.
+  ;; return nil if we can't do it.
+  (if* (numberp operand)
+     then nil
+   elseif (consp operand)
+     then (case (car operand)
+	    (:reg 
+	     (preg-treg (svref *reg-array* (cadr operand))))
+	    (:arg 
+	     (let ((x (cdr (assoc (cadr operand) *arg-to-treg* :test #'eq))))
+	       (if* (null x)
+		  then nil
+		  else x))))
+	      
+     else nil))
+
+(defun index-p (operand)
+  ;; determine if the result of this operand is an index value
+  ;* it would be better if conversion between lisp values and
+  ;  index values were made explicit in the lap code
+  (and (consp operand)
+       (or (and (eq :reg (car operand))
+		(eq :index (preg-index (svref *reg-array* (cadr operand)))))
+	   (member (car operand)
+		   '(:i+ :i- :ilogand :ilogxor :i1+)
+		   :test #'eq))
+       t))
+
+(defun gen-index-treg (operand)
+  ;; return the non-index type operand in a index treg
+  (if* (and (consp operand)
+	    (eq ':constant (car operand)))
+     then (get-treg-of `(:index-constant ,(cadr operand)))
+     else (let ((treg (get-treg-of operand))
+		(new-reg (new-reg))
+		(shift-reg (new-reg)))
+	    (qe const :arg 1 :d (list shift-reg))
+	    (qe lsr :u (list treg shift-reg) :d (list new-reg))
+	    new-reg)))
+
+		
+	    
+  
+  
+(defun vector-preg-p (operand)
+  (and (consp operand)
+       (eq :reg (car operand))
+       (eq :vector (preg-index (svref *reg-array* (cadr operand))))))
+       
+	    
+	  
+(defun excl-gen-quads (laps)
+  ;; generate quads from the lap
+  (dolist (lap laps)
+    (if* *debug-sparc* then (format t ">> ~a~%" lap))
+    (block again
+      (let ((opcode (car lap))
+	    (op1    (cadr lap))
+	    (op2    (caddr lap)))
+	(case opcode
+	  (:move
+	   ; can be either simple (both args registers)
+	   ; or one arg can be complex and the other simple
+	   (case (car op2)
+	     (:iref
+	      ;; assume that this is a lisp store
+	      (warn "assuming lisp store in ~s" lap)
+	      (let (op1-treg)
+		(if* (not (vector-preg-p (cadr op2)))
+		   then ; must offset before store
+			(error "must use vector register in ~s" lap)
+		   else (setq op1-treg (get-treg-of (cadr op2))))
+				       
+				      
+		
+		(qe set :u (list op1-treg
+				 (get-treg-of (caddr op2))
+				 (get-treg-of op1))
+		    :arg :lisp)
+		(return-from again)))
+	     (:cdr
+	      ;; it certainly is a lisp stoer
+	      (let (op1-treg const-reg)
+		(setq op1-treg (get-treg-of (cadr op2)))
+	        (setq const-reg (new-reg))
+		(qe const :arg (mdparam 'md-cons-cdr-adj) 
+		    :d (list const-reg))
+				       
+				      
+		
+		(qe set :u (list op1-treg
+				 const-reg
+				 (get-treg-of op1))
+		    :arg :lisp)
+		(return-from again))))
+	 
+	   ; the 'to'address is simple, the from address may not be
+	 
+	   (let ((index1 (index-p op1))
+		 (index2 (index-p op2))
+		 (vector1 (vector-preg-p op1))
+		 (vector2 (vector-preg-p op2)))
+	     (ecase (car op1)
+	       ((:reg :cvar :arg :constant :lisp-symbol)
+		(qe move 
+		    :u (list (get-treg-of op1 op2))
+		    :d (list (get-treg-of op2))))
+	       (:std-wrapper
+		(qe-slot-access (cadr op1) 
+				(+ (* 1 4)
+				   (comp::mdparam 'md-svector-data0-adj))
+				op2))
+	       (:std-slots
+		(qe-slot-access (cadr op1) 
+				(+ (* 2 4)
+				   (comp::mdparam 'md-svector-data0-adj))
+				op2))
+	       (:fsc-wrapper
+		(qe-slot-access (cadr op1) 
+				(+ (* (- 15 1) 4)
+				   (comp::mdparam 'md-function-const0-adj))
+				op2))
+	       (:fsc-slots
+		(qe-slot-access (cadr op1) 
+				(+ (* (- 15 2) 4)
+				   (comp::mdparam 'md-function-const0-adj))
+				op2))
+	       (:built-in-wrapper
+		(qe call :arg 'pcl::built-in-wrapper-of
+		    :u (list (get-treg-of (cadr op1)))
+		    :d (list (get-treg-of op2))))
+	       (:structure-wrapper
+		(warn "do structure-wrapper"))
+	       (:other-wrapper
+		(warn "do other-wrapper"))
+	       ((:i+ :i- :ilogand :ilogxor)
+		(qe arith :arg (cdr (assoc (car op1) 
+					   '((:i+ . :+)
+					     (:i- . :-)
+					     (:ilogand . :logand)
+					     (:ilogxor . :logxor))
+					   :test #'eq))
+		    :u (list (get-treg-of (cadr op1))
+			     (get-treg-of (caddr op1)))
+		    :d (list (get-treg-of op2))))
+	       (:i1+
+		(let ((const-reg (new-reg)))
+		  (qe const :arg 4 ; an index value of 1
+		      :d (list const-reg))
+		  (qe arith :arg :+
+		      :u (list const-reg
+			       (get-treg-of (cadr op1)))
+		      :d (list (get-treg-of op2)))))
+		      
+	       ((:iref :cref)
+		(let (op1-treg)
+		  (if* (not (vector-preg-p (cadr op1)))
+		     then ; must offset before store
+			  (error "must use vector register in ~s" lap)
+		     else (setq op1-treg (get-treg-of (cadr op1))))
+				       
+		  (qe ref :u (list op1-treg
+				   (get-treg-of (caddr op1) op2))
+		      :d (list (get-treg-of op2))
+		      :arg :long)))
+	       (:cdr
+		(let ((const-reg (new-reg)))
+		  (qe const :arg (mdparam 'md-cons-cdr-adj)
+		      :d (list const-reg))
+		  (qe ref :arg :long
+		      :u (list (get-treg-of (cadr op1))
+			       const-reg)
+		      :d (list (get-treg-of op2))))))
+	     (if* (not (eq index1 index2))
+		then (let ((shiftamt (new-reg)))
+		       (qe const :arg 1 :d (list shiftamt))
+		       (if* (and index1 (not index2))
+			  then ; converting from index to non-index
+			       (qe lsl :u (list (get-treg-of op2) shiftamt)
+				   :d (list (get-treg-of op2)))
+			elseif (and (not index1) index2)
+			       ; converting to an index
+			  then (qe lsr :u (list (get-treg-of op2) shiftamt)
+				   :d (list (get-treg-of op2)))))
+	      elseif (and vector2 (not vector1))
+		then ; add vector offset
+		     (let ((tempreg (new-reg))
+			   (vreg (get-treg-of op2)))
+		       (qe const :arg (mdparam 'md-svector-data0-adj)
+			   :d (list tempreg))
+		       (qe arith :arg :+ :u (list vreg tempreg)
+			   :d (list vreg))))))
+	  (:fix=
+	   (let (tr1 tr2)
+	     (if* (index-p op1)
+		then (setq tr1 (get-treg-of op1))
+		     (if* (not (index-p op2))
+			then (setq tr2 (gen-index-treg op2))
+			else (setq tr2 (get-treg-of op2)))
+	      elseif (index-p op2)
+		then ; assert: op1 isn't an index treg
+		     (setq tr1 (gen-index-treg op1))
+		     (setq tr2 (get-treg-of op2))
+		else (setq tr1 (get-treg-of op1)
+			   tr2 (get-treg-of op2)))
+	   
+		   
+		   
+	     (qe bcc :u (list tr1 tr2)
+		 :arg (cadddr lap)
+		 :arg2 :eq )))
+	  ((:eq :neq :fix=)
+	   (if* (not (eq (index-p op1) (index-p op2)))
+	      then (error "non matching operands indexwise in: ~s" lap))
+	   (qe bcc :u (list (get-treg-of op1)
+			    (get-treg-of op2))
+	       :arg (cadddr lap)
+	       :arg2 (cdr (assoc opcode '((:eq . :eq)
+					  (:neq . :ne))
+				 :test #'eq))))
+	  (:izerop 
+	   (qe bcc :u (list (get-treg-of op1)
+			    *zero-treg*)
+	       :arg (caddr lap)
+	       :arg2 :eq))
+	  (:std-instance-p
+	   (let ((treg (get-treg-of op1))
+		 (tempreg (new-reg))
+		 (temp2reg (new-reg))
+		 (offsetreg (new-reg))
+		 (nope (pc-genlab)))
+	     (qe typecheck :u (list treg)
+		 :arg nope
+		 :arg2 '(not structure))
+	     (qe const :arg 'pcl::std-instance :d (list tempreg))
+	     (qe const :arg (mdparam 'md-svector-data0-adj) 
+		 :d (list offsetreg))
+	     (qe ref :u (list treg offsetreg) 
+		 :d (list temp2reg)
+		 :arg :long)
+	     (qe bcc :arg2 :eq :u (list tempreg temp2reg)
+		 :arg (caddr lap))
+	     (qe label :arg nope)))
+	  
+	  (:fsc-instance-p
+	   (let ((treg (get-treg-of op1))
+		 (nope (pc-genlab))
+		 (offsetreg (new-reg))
+		 (tempreg (new-reg))
+		 (checkreg (new-reg)))
+	     (qe typecheck :u (list treg)
+		 :arg nope
+		 :arg2 '(not compiled-function))
+	     (qe const :arg (mdparam 'md-function-flags-adj)
+		 :d (list offsetreg))
+	     (qe ref :u (list treg offsetreg) :d (list tempreg)
+		 :arg :ubyte)
+	     (qe const :arg pcl::funcallable-instance-flag-bit
+		 :d (list checkreg))
+	     (qe bcc :u (list checkreg tempreg)
+		 :arg (caddr lap)
+		 :arg2 :bit-and)
+	     (qe label :arg nope)))
+	  (:built-in-instance-p
+	   ; always true
+	   (qe bra :arg (caddr lap)))
+	  (:jmp
+	   (qe tail-funcall :u (list *nargs-treg* (get-treg-of op1))))
+	  ((:structure-instance-p)
+	   (warn "didn't do ~s" lap))
+	  
+	  (:return
+	    (let (op-treg)
+	      (if* (index-p op1)
+		 then ; convert to lisp before returning
+		      (let ((shiftamt (new-reg)))
+			(setq op-treg (new-reg))
+			(qe const :arg 1 :d (list shiftamt))
+			(qe lsl :u (list (get-treg-of op1) shiftamt)
+			    :d (list op-treg)))
+		 else (setq op-treg (get-treg-of op1)))
+			
+	      (qe return :u (list op-treg))))
+
+	  (:go
+	   (qe bra :arg (cadr lap)))
+	   
+	  (:label 
+	   (qe label :arg (cadr lap)))
+	     
+	   
+	   
+	  (t (warn "ignoring ~s" lap)))))))
+
+
+(defun insert-closure-vals (function closure-vals)
+  ;;  build a fucntion from the lap and insert 
+  (let ((newfun (sys::copy-function function)))
+    (setf (excl::fn_closure newfun) (list (apply 'vector closure-vals)))
+    newfun))
+
+  
+	     
+; test case:
+; (pcl::defclass foo () (a b c))
+; (pcl::defmethod barx ((a foo) b c)  a )
+; (apply 'pcl::excl-lap-closure-generator pcl::*tcase*)
+;
+; to turn it on
+
+(if* (not (and (boundp 'user::noquad)
+	       (symbol-value 'user::noquad)))
+   then (setq pcl::*make-lap-closure-generator* 
+	  'pcl::excl-lap-closure-generator))
+
+
+
+
+
+  
diff --git a/pcl/readme.text b/pcl/readme.text
new file mode 100644
index 0000000000000000000000000000000000000000..f029b24a45bec48997661c7e4f475320a8d4c546
--- /dev/null
+++ b/pcl/readme.text
@@ -0,0 +1,9 @@
+Please read the file get-pcl.text carefully, it contains the most up to
+date version of the message you received when you first asked about PCL.
+You should read it when you get each new release because it will contain
+any new information about PCL distribution or documentation.
+
+Also whenever there is a new release, you should read the notes.text
+file carefully.
+
+To install PCL at your site, follow the instructions in the defsys.lisp
diff --git a/pcl/rel-7-2-patches.lisp b/pcl/rel-7-2-patches.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..ca43e4dda52a6df1759fd0d946cc0388ed828214
--- /dev/null
+++ b/pcl/rel-7-2-patches.lisp
@@ -0,0 +1,249 @@
+;;; -*- Mode: LISP; Syntax: Common-lisp; Package: ZL-USER; Base: 10; Patch-File: T -*-
+
+;=====================================
+(SYSTEM-INTERNALS:BEGIN-PATCH-SECTION)
+(SYSTEM-INTERNALS:PATCH-SECTION-SOURCE-FILE "SYS:l-COMPILER;OPTIMIZE.LISP.179")
+(SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES
+  "-*- Mode: Lisp; Package: Compiler; Lowercase: T; Base: 8 -*-")
+
+;;; Does simple constant folding.  This works for everything that doesn't have
+;;; side-effects.
+;;; ALL operands must be constant.
+;;; Note that commutative-constant-folder can hack this case perfectly well
+;;; by himself for the functions he handles.
+(defun constant-fold-optimizer (form)
+  (let ((eval-when-load-p nil))
+    (flet ((constant-form-p (x)
+	     (when (constant-form-p x)
+	       (cond ((and (listp x)
+			   (eq (car x) 'quote)
+			   (listp (cadr x))
+			   (eq (caadr x) eval-at-load-time-marker))
+		      (setq eval-when-load-p t)
+		      (cdadr x))
+		     (t x)))))
+      (if (every (cdr form) #'constant-form-p)
+	  (if eval-when-load-p
+	      (list 'quote
+		    (list* eval-at-load-time-marker
+			   (car form)
+			   (mapcar #'constant-form-p (cdr form))))
+	      (condition-case (error-object)
+		   (multiple-value-call #'(lambda (&rest values)
+					    (if (= (length values) 1)
+						`',(first values)
+						`(values ,@(mapcar #'(lambda (x) `',x)
+								   values))))
+					(eval form))
+		 (error
+		   (phase-1-warning "Constant form left unoptimized: ~S~%because: ~~A~"
+				    form error-object)
+		   form)))
+	  form))))
+
+
+;=====================================
+(SYSTEM-INTERNALS:BEGIN-PATCH-SECTION)
+(SYSTEM-INTERNALS:PATCH-SECTION-SOURCE-FILE "SYS:L-COMPILER;COMFILE.LISP.85")
+(SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES
+  "-*- Mode: Lisp; Package: Compiler; Lowercase: T; Base: 8 -*-")
+
+;;;
+;;; The damn compiler doesn't compile random forms that appear at top level.
+;;; Its difficult to do because you have to get an associated function spec
+;;; to go with those forms.  This handles that by defining a special form,
+;;; top-level-form that compiles its body.  It takes a list of eval-when
+;;; times just like eval when does.  It also takes a name which it uses
+;;; to construct a function spec for the top-level-form function it has
+;;; to create.
+;;; 
+;
+;si::
+;(defvar *top-level-form-fdefinitions* (cl:make-hash-table :test #'equal))
+;
+;si::
+;(define-function-spec-handler pcl::top-level-form
+;			      (operation fspec &optional arg1 arg2)
+;  (let ((name (cadr fspec)))
+;    (selectq operation
+;      (validate-function-spec (and (= (length fspec) 2)
+;				   (or (symbolp name)
+;				       (listp name))))
+;      (fdefine
+;       (setf (gethash name *top-level-form-fdefinitions*) arg1))
+;      ((fdefinition fdefinedp)
+;       (gethash name *top-level-form-fdefinitions*)) 
+;      (fdefinition-location 
+;       (ferror "It is not possible to get the fdefinition-location of ~s."
+;	       fspec))
+;      (fundefine (remhash name *top-level-form-fdefinitions*))
+;      (otherwise (function-spec-default-handler operation fspec arg1 arg2)))))
+;
+;;;
+;;; This is basically stolen from PROGN (surprised?)
+;;; 
+;(si:define-special-form pcl::top-level-form (name times
+;						  &body body
+;						  &environment env)
+;  (declare lt:(arg-template . body) (ignore name))
+;  (si:check-eval-when-times times)
+;  (when (member 'eval times) (si:eval-body body env)))
+;
+;(defun (:property pcl::top-level-form lt:mapforms) (original-form form usage)
+;  (lt::mapforms-list original-form form (cddr form) 'eval usage))
+
+;;; This is the normal function for looking at each form read from the file and calling
+;;; *COMPILE-FORM-FUNCTION* on the sub-forms of it.
+;;; COMPILE-TIME-TOO means override the normal cases that eval at compile time.  It is
+;;; used for recursive calls under (EVAL-WHEN (COMPILE LOAD) ...).
+;(DEFUN COMPILE-FROM-STREAM-1 (FORM &OPTIONAL (COMPILE-TIME-TOO NIL))
+;  (CATCH-ERROR-RESTART
+;     (SYS:ERROR "Skip compiling form ~2,2\COMPILER:SHORT-S-FORMAT\" FORM)
+;    (LET ((DEFAULT-CONS-AREA (FUNCALL *COMPILE-FUNCTION* ':CONS-AREA)))
+;      (LET ((ERROR-MESSAGE-HOOK
+;	      #'(LAMBDA ()
+;		  (DECLARE (SYS:DOWNWARD-FUNCTION))
+;		  (FORMAT T "~&While processing ~V,V\COMPILER:SHORT-S-FORMAT\"
+;			  DBG:*ERROR-MESSAGE-PRINLEVEL*
+;			  DBG:*ERROR-MESSAGE-PRINLENGTH*
+;			  FORM))))
+;	(SETQ FORM (FUNCALL *COMPILE-FUNCTION* ':MACRO-EXPAND FORM)))
+;      (WHEN (LISTP FORM)			;Ignore atoms at top-level
+;	(LET ((FUNCTION (FIRST FORM)))
+;	  (SELECTQ FUNCTION
+;	    ((QUOTE))				;and quoted constants e.g. 'COMPILE
+;	    ((PROGN)
+;	     (DOLIST (FORM (CDR FORM))
+;	       (COMPILE-FROM-STREAM-1 FORM COMPILE-TIME-TOO)))
+;	    ((EVAL-WHEN)
+;	     (SI:CHECK-EVAL-WHEN-TIMES (CADR FORM))
+;	     (LET ((COMPILE-P (OR (MEMQ 'COMPILE (CADR FORM))
+;				  (AND COMPILE-TIME-TOO (MEMQ 'EVAL (CADR FORM)))))
+;		   (LOAD-P (OR (MEMQ 'LOAD (CADR FORM)) (MEMQ 'CL:LOAD (CADR FORM))))
+;		   (FORMS (CDDR FORM)))
+;	       (COND (LOAD-P
+;		      (DOLIST (FORM FORMS)
+;			(COMPILE-FROM-STREAM-1 FORM (AND COMPILE-P ':FORCE))))
+;		     (COMPILE-P
+;		      (DOLIST (FORM FORMS)
+;			(FUNCALL *COMPILE-FORM-FUNCTION* FORM ':FORCE NIL))))))
+;	    ((DEFUN)
+;	     (LET ((TEM (DEFUN-COMPATIBILITY (CDR FORM) :WARN-IF-OBSOLETE T)))
+;	       (IF (EQ (CDR TEM) (CDR FORM))
+;		   (FUNCALL *COMPILE-FORM-FUNCTION* FORM COMPILE-TIME-TOO T)
+;		   (COMPILE-FROM-STREAM-1 TEM COMPILE-TIME-TOO))))
+;	    ((MACRO)
+;	     (FUNCALL *COMPILE-FORM-FUNCTION* FORM (OR COMPILE-TIME-TOO T) T))
+;	    ((DECLARE)
+;	     (DOLIST (FORM (CDR FORM))
+;	       (FUNCALL *COMPILE-FORM-FUNCTION* FORM (OR COMPILE-TIME-TOO T)
+;			;; (DECLARE (SPECIAL ... has load-time action as well.
+;			;; All other DECLARE's do not.
+;			(MEMQ (CAR FORM) '(SPECIAL ZL:UNSPECIAL)))))
+;	    ((COMPILER-LET)
+;	     (COMPILER-LET-INTERNAL (CADR FORM) (CDDR FORM)
+;				    #'COMPILE-FROM-STREAM-1 COMPILE-TIME-TOO))
+;	    ((SI:DEFINE-SPECIAL-FORM)
+;	     (FUNCALL *COMPILE-FORM-FUNCTION* FORM COMPILE-TIME-TOO T))
+;	    ((MULTIPLE-DEFINITION)
+;	     (DESTRUCTURING-BIND (NAME TYPE . BODY) (CDR FORM)
+;	       (LET ((NAME-VALID (AND (NOT (NULL NAME))
+;				      (OR (SYMBOLP NAME)
+;					  (AND (LISTP NAME) (NEQ (CAR NAME) 'QUOTE)))))
+;		     (TYPE-VALID (AND (NOT (NULL TYPE)) (SYMBOLP TYPE))))
+;		 (UNLESS (AND NAME-VALID TYPE-VALID)
+;		   (WARN "(~S ~S ~S ...) is invalid because~@
+;			  ~:[~S is not valid as a definition name~;~*~]~
+;			  ~:[~&~S is not valid as a definition type~;~*~]"
+;			 'MULTIPLE-DEFINITION NAME TYPE NAME-VALID NAME TYPE-VALID TYPE)))
+;	       (LET* ((COMPILED-BODY NIL)
+;		      (COMPILE-FUNCTION *COMPILE-FUNCTION*)
+;		      (*COMPILE-FUNCTION*
+;			(LAMBDA (OPERATION &REST ARGS)
+;			  (DECLARE (SYS:DOWNWARD-FUNCTION))
+;			  (SELECTQ OPERATION
+;			    (:DUMP-FORM
+;			     (PUSH (FUNCALL COMPILE-FUNCTION :OPTIMIZE-TOP-LEVEL-FORM
+;					    (FIRST ARGS))
+;				   COMPILED-BODY))
+;			    (:INSTALL-DEFINITION
+;			     (PUSH (FORM-FOR-DEFINE *COMPILER* (FIRST ARGS) (SECOND ARGS))
+;				   COMPILED-BODY))
+;			    (OTHERWISE (CL:APPLY COMPILE-FUNCTION OPERATION ARGS)))))
+;		      (LOCAL-DECLARATIONS `((FUNCTION-PARENT ,NAME ,TYPE)
+;					    ,@LOCAL-DECLARATIONS)))
+;		 (DOLIST (FORM BODY)
+;		   (COMPILE-FROM-STREAM-1 FORM COMPILE-TIME-TOO))
+;		 (FUNCALL COMPILE-FUNCTION :DUMP-FORM
+;			  `(LOAD-MULTIPLE-DEFINITION
+;			     ',NAME ',TYPE ',(NREVERSE COMPILED-BODY) NIL)))))
+;	    ((pcl::top-level-form)
+;	     (destructuring-bind (name times . body)
+;				 (cdr form)
+;	       (si:check-eval-when-times times)
+;	       (let ((compile-p (or (memq 'compile times)
+;				    (and compile-time-too (memq 'eval times))))
+;		     (load-p (or (memq 'load times)
+;				 (memq 'cl:load times)))
+;		     (fspec `(pcl::top-level-form ,name)))
+;		 (cond (load-p
+;			(compile-from-stream-1
+;			  `(progn (defun ,fspec () . ,body)
+;				  (funcall (function ,fspec)))
+;			  (and compile-p ':force)))
+;		       (compile-p
+;			(dolist (b body)
+;			  (funcall *compile-form-function* form ':force nil)))))))
+;	    (OTHERWISE
+;	     (LET ((TEM (AND (SYMBOLP FUNCTION) (GET FUNCTION 'TOP-LEVEL-FORM))))
+;	       (IF TEM
+;		   (FUNCALL *COMPILE-FORM-FUNCTION* (FUNCALL TEM FORM) COMPILE-TIME-TOO T)
+;		   (FUNCALL *COMPILE-FORM-FUNCTION* FORM COMPILE-TIME-TOO T))))))))))
+;
+;
+
+
+dw::
+(defun symbol-flavor-or-cl-type (symbol)
+  (declare (values flavor defstruct-p deftype-fun typep-fun atomic-subtype-parent
+		   non-atomic-deftype))
+  (multiple-value-bind (result foundp)
+      (gethash symbol *flavor-or-cl-type-cache*)
+    (let ((frob
+	    (if foundp result
+	      (setf (gethash symbol *flavor-or-cl-type-cache*)
+		    (or (get symbol 'flavor:flavor)
+			(not (null (defstruct-type-p symbol)))
+			(let* ((deftype (get symbol 'deftype))
+			       (descriptor (symbol-presentation-type-descriptor symbol))
+			       (typep
+				 (unless (and descriptor
+					      (presentation-type-explicit-type-function
+						descriptor))
+				   ;; Don't override the one defined in the presentation-type.
+				   (get symbol 'typep)))
+			       (atomic-subtype-parent (find-atomic-subtype-parent symbol))
+			       (non-atomic-deftype
+				 (when (and (not descriptor) deftype)
+				   (not (member (first (type-arglist symbol))
+						'(&rest &key &optional))))))
+			  (if (or typep (not (atom deftype))
+				  non-atomic-deftype
+				  ;; deftype overrides atomic-subtype-parent.
+				  (and (not deftype) atomic-subtype-parent))
+			      (list-in-area *handler-dynamic-area*
+					    deftype typep atomic-subtype-parent
+					    non-atomic-deftype)
+			    deftype)))))))
+      (locally (declare (inline compiled-function-p))
+        (etypecase frob
+	  (array (values frob))
+	  (null (values nil))
+	  ((member t) (values nil t))
+	  (compiled-function (values nil nil frob))
+	  (lexical-closure (values nil nil frob))
+	  (list (destructuring-bind (deftype typep atomic-subtype-parent non-atomic-deftype)
+		    frob
+		  (values nil nil deftype typep atomic-subtype-parent non-atomic-deftype)))
+	  (symbol (values nil nil nil nil frob)))))))
+
diff --git a/pcl/slots.lisp b/pcl/slots.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..9a37d2a876df60afbb0cd8a40eade175dfa391fe
--- /dev/null
+++ b/pcl/slots.lisp
@@ -0,0 +1,215 @@
+;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+
+(in-package 'pcl)
+
+;;;
+;;; 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)))
+
+
+
+(defun slot-value (object slot-name)
+  (slot-value-using-class (class-of object) object slot-name))
+
+(defun set-slot-value (object slot-name new-value)
+  (setf (slot-value-using-class (class-of object) object slot-name) new-value))
+
+(defun slot-boundp (object slot-name)
+  (slot-boundp-using-class (class-of object) object slot-name))
+
+(defun slot-makunbound (object slot-name)
+  (slot-makunbound-using-class (class-of object) object slot-name))
+
+(defun slot-exists-p (object slot-name)
+  (slot-exists-p-using-class (class-of object) object slot-name))
+
+;;;
+;;; This isn't documented, but is used within PCL 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) slot-name)
+  (let* ((wrapper (check-wrapper-validity object))	;trap if need be
+	 (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))))
+
+(defmethod (setf slot-value-using-class)
+	   (new-value (class std-class) (object standard-object) slot-name)
+  (let* ((wrapper (check-wrapper-validity object))	;trap if need be
+	 (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))))
+
+(defmethod slot-boundp-using-class
+	   ((class std-class) (object standard-object) slot-name)
+  (let* ((wrapper (check-wrapper-validity object))	;trap if need be
+	 (slots   (get-slots object))
+	 (index   (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) slot-name)
+  (let* ((wrapper (check-wrapper-validity object))	;trap if need be
+	 (slots   (get-slots object))
+	 (index   (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) slot-name)
+  (not (null (find-slot-definition class slot-name))))
+
+
+
+(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))
diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..0546225611a56b7210e94c4f7f0155e6c0ca767a
--- /dev/null
+++ b/pcl/std-class.lisp
@@ -0,0 +1,974 @@
+;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+
+(in-package 'pcl)
+
+(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)
+  (lisp: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))
+  (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))
+
+
+;;;
+;;; Various class accessors that are a little more complicated than can be
+;;; done with automatically generated reader methods.
+;;;
+(defmethod class-wrapper ((class pcl-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 pcl-class))
+  (unless (class-finalized-p class) (finalize-inheritance class))
+  (with-slots (class-precedence-list) class class-precedence-list))
+
+(defmethod class-finalized-p ((class pcl-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))
+
+(defmethod find-slot-definition ((class std-class) slot-name)
+  (dolist (eslotd (class-slots class))
+    (when (eq (slotd-name eslotd) slot-name) (return eslotd))))
+
+
+;;;
+;;; 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))	;PUSH
+	  (cdr direct-methods) ()))
+  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) ()))
+  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) ())
+    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) ()))
+    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 pcl-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
+		 direct-slots
+		 direct-default-initargs)
+  (declare (ignore slot-names))
+  (when (null direct-superclasses)
+    (setq direct-superclasses  (list *the-class-standard-object*)))
+  (setq direct-slots 
+	(mapcar #'(lambda (pl) (make-direct-slotd class pl)) direct-slots))
+  (setf (slot-value class 'direct-superclasses) direct-superclasses
+	(slot-value class 'direct-slots) direct-slots)
+  (setf (plist-value class 'direct-default-initargs) 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 direct-superclasses)
+  (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-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)))))
+
+(defun compute-storage-info (cpl eslotds)
+  (let ((instance ())
+	(class    ()))
+    (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 ()))
+    (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-inits (class inits)
+  (setf (plist-value class 'default-initargs) inits))
+
+
+;;;
+;;;
+;;;
+(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 ()))
+    (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
+				()
+				(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
+				()
+				(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 () (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 () (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, PCL makes uses makes use
+;;; of them internally and documents them for PCL 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-using-class (wrapper-class (get-wrapper instance))
+			      instance
+			      slot-name)))
+
+(defun make-std-writer-method-function (slot-name)
+  #'(lambda (nv instance)
+      (setf (slot-value-using-class (wrapper-class (get-wrapper instance))
+				    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 PCL 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)))
+
+(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))
+  ())
+
+
+
+(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 PCL 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 ())
+	 (discarded ())
+	 (plist ()))
+    ;;
+    ;; 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)) ())
+(defmethod class-slots                   ((class built-in-class)) ())
+(defmethod class-direct-default-initargs ((class built-in-class)) ())
+(defmethod class-default-initargs        ((class built-in-class)) ())
+
+(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))
diff --git a/pcl/ti-low.lisp b/pcl/ti-low.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..0701809e01de86c091ade0775025c9ab6b65ed65
--- /dev/null
+++ b/pcl/ti-low.lisp
@@ -0,0 +1,82 @@
+;;; -*- Mode:LISP; Package:(PCL (Lisp WALKER)); Base:10.; Syntax:Common-lisp; Patch-File: Yes -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+;;; This is the 3600 version of the file portable-low.
+;;;
+
+(in-package 'pcl)
+
+(defmacro without-interrupts (&body body)
+  `(let ((outer-scheduling-state si:inhibit-scheduling-flag)
+	 (si:inhibit-scheduling-flag t))
+     (macrolet ((interrupts-on  ()
+		  '(when (null outer-scheduling-state)
+		     (setq si:inhibit-scheduling-flag nil)))
+		(interrupts-off ()
+		  '(setq si:inhibit-scheduling-flag t)))
+       ,.body)))
+
+(si:defsubst std-instance-p (x)
+  (si:typep-structure-or-flavor x 'std-instance))
+
+  ;;   
+;;;;;; printing-random-thing-internal
+  ;;
+(defun printing-random-thing-internal (thing stream)
+  (format stream "~O" (si:%pointer thing)))
+
+(eval-when (compile load eval)             ;There seems to be some bug with
+  (setq si::inhibit-displacing-flag t))	   ;macrolet'd macros or something.
+					   ;This gets around it but its not
+					   ;really the right fix.
+
+(defun function-arglist (f)
+  (sys::arglist f t))
+
+(defun record-definition (type spec &rest ignore)
+  (if (eql type 'method)
+      (sys:record-source-file-name spec 'defun :no-query)
+      (sys:record-source-file-name spec type :no-query)))
+
+(ticl:defprop method method-function-spec-handler sys:function-spec-handler)
+(defun method-function-spec-handler
+       (function function-spec &optional arg1 arg2)
+  (let ((symbol (second function-spec)))
+    (case function
+      (sys:validate-function-spec t)
+      (otherwise
+	(sys:function-spec-default-handler
+	  function function-spec arg1 arg2)))))
+
+;;;Edited by Reed Hastings         13 Aug 87  16:59
+;;;Edited by Reed Hastings         2 Nov 87  22:58
+(defun set-function-name (function new-name)
+  (when (si:get-debug-info-struct function)
+    (setf (si:get-debug-info-field (si:get-debug-info-struct function) :name)
+	  new-name))
+  function)
+
+
diff --git a/pcl/ti-patches.lisp b/pcl/ti-patches.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..11809d92f501179616c44f2e42da3dfda0cd2bdf
--- /dev/null
+++ b/pcl/ti-patches.lisp
@@ -0,0 +1,104 @@
+;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+
+(in-package 'pcl)
+
+;;;
+;;; This little bit of magic keeps the dumper from dumping the lexical
+;;; definition of call-next-method when it dumps method functions that
+;;; come from defmethod forms.
+;;; 
+(proclaim '(notinline nil))
+
+(eval-when (load)
+  (setf (get 'function 'si:type-predicate) 'functionp))
+
+;; fix defsetf to deal with do-standard-defsetf
+
+#!C
+; From file SETF.LISP#> KERNEL; VIRGO:
+#8R SYSTEM#:
+(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "SYSTEM"))
+                          (SI:*LISP-MODE* :COMMON-LISP)
+                          (*READTABLE* COMMON-LISP-READTABLE)
+                          (SI:*READER-SYMBOL-SUBSTITUTIONS* *COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
+  (COMPILER#:PATCH-SOURCE-FILE "SYS: KERNEL; SETF.#"
+
+
+(defmacro defsetf (access-function arg1 &optional arg2  &environment env &body body)
+  "Define a SETF expander for ACCESS-FUNCTION.
+DEFSETF has two forms:
+
+The simple form  (DEFSETF access-function update-function [doc-string])
+can be used as follows: After (DEFSETF GETFROB PUTFROB),
+\(SETF (GETFROB A 3) FOO) ==> (PUTFROB A 3 FOO).
+
+The complex form is like DEFMACRO:
+
+\(DEFSETF access-function access-lambda-list newvalue-lambda-list body...)
+
+except there are TWO lambda-lists.
+The first one represents the argument forms to the ACCESS-FUNCTION.
+Only &OPTIONAL and &REST are allowed here.
+The second has only one argument, representing the value to be stored.
+The body of the DEFSETF definition must then compute a
+replacement for the SETF form, just as for any other macro.
+When the body is executed, the args in the lambda-lists will not
+really contain the value-expression or parts of the form to be set;
+they will contain gensymmed variables which SETF may or may not
+eliminate by substitution."
+  ;; REF and VAL are arguments to the expansion function
+  (if (null body)
+      `(defdecl ,access-function setf-method ,arg1)
+      (multiple-value-bind (body decls doc-string)
+	  (parse-body body env t)
+	(let* ((access-ll arg1)
+	       (value-names arg2)
+	       (expansion
+		 (let (all-arg-names)
+		   (dolist (x access-ll)
+		     (cond ((symbolp x)
+			    (if (not (member x lambda-list-keywords :test #'eq))
+				(push x all-arg-names)
+				(when (eq x '&rest) (return))))  ;;9/20/88 clm
+			   (t			; it's a list after &optional
+			    (push (car x) all-arg-names))))
+		   (setq all-arg-names (reverse all-arg-names))
+		   `(let ((tempvars (mapcar #'(lambda (ignore) (gensym)) ',all-arg-names))
+			  (storevar (gensym)))
+		      (values tempvars (list . ,all-arg-names) (list storevar)
+			      (let ((,(car value-names) storevar)
+				    . ,(loop for arg in all-arg-names
+					     for i = 0 then (1+ i)
+					     collect `(,arg (nth ,i tempvars))))
+				 ,@decls . ,body)
+			      `(,',access-function . ,tempvars))))))
+	  `(define-setf-method ,access-function ,arg1
+	    ,@doc-string ,expansion)
+	  ))))
+))
+
diff --git a/pcl/vaxl-low.lisp b/pcl/vaxl-low.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..a763568f60cab7495a86d681871c2099cc783ad3
--- /dev/null
+++ b/pcl/vaxl-low.lisp
@@ -0,0 +1,79 @@
+;;;-*-Mode:LISP; Package:(PCL Lisp 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+;;; The version of low for VAXLisp
+;;; 
+(in-package 'pcl)
+
+(defmacro without-interrupts (&body body)
+  `(macrolet ((interrupts-on  ()
+	       `(when (null outer-scheduling-state)
+		  (setq system::*critical-section-p* nil)
+		  (when (system::%sp-interrupt-queued-p)
+		    (system::interrupt-dequeuer t))))
+	      (interrupts-off ()
+	       `(setq system::*critical-section-p* t)))
+     (let ((outer-scheduling-state system::*critical-section-p*))
+       (prog1 (let ((system::*critical-section-p* t)) ,@body)
+	      (when (and (null outer-scheduling-state)
+			 (system::%sp-interrupt-queued-p))
+		(system::interrupt-dequeuer t))))))
+
+
+  ;;   
+;;;;;; Load Time Eval
+  ;;
+(defmacro load-time-eval (form)
+  `(progn ,form))
+
+  ;;   
+;;;;;; Generating CACHE numbers
+  ;;
+;;; How are symbols in VAXLisp actually arranged in memory?
+;;; Should we be shifting the address?
+;;; Are they relocated?
+;;; etc.
+
+;(defmacro symbol-cache-no (symbol mask)
+;  `(logand (the fixnum (system::%sp-pointer->fixnum ,symbol)) ,mask))
+
+(defmacro object-cache-no (object mask)
+  `(logand (the fixnum (system::%sp-pointer->fixnum ,object)) ,mask))
+
+  ;;   
+;;;;;; printing-random-thing-internal
+  ;;
+(defun printing-random-thing-internal (thing stream)
+  (format stream "~O" (system::%sp-pointer->fixnum thing)))
+
+
+(defun function-arglist (fn)
+  (system::function-lambda-vars (symbol-function fn)))
+
+(defun set-function-name-1 (fn name ignore)
+  (cond ((system::slisp-compiled-function-p fn)
+	 (system::%sp-b-store fn 3 name)))
+  fn)
diff --git a/pcl/vector.lisp b/pcl/vector.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..abbfd84fa86ce2d19d69a479965d0a9539d329a6
--- /dev/null
+++ b/pcl/vector.lisp
@@ -0,0 +1,343 @@
+;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+;;; Permutation vectors.
+;;;
+
+(in-package 'pcl)
+
+(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))
+
+(defun lookup-pv (isl &rest 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-slots (wrapper-class-slots wrapper)))
+		   (dolist (slot-name slot-names)
+		     (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))))))))))))
+    (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 (reduce-constant 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 (reduce-constant 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)))
+	  (push form (cdr slot-entry))
+	  form))
+      (:write
+	(let ((form (list 'instance-write ''.PV-OFFSET. parameter position '.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)
+  `(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 .ISL.)))))
+
+(defmacro instance-write (pv-offset parameter position 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 .ISL. ,new-value)))))
+
+(defun pv-access-trap (instance pv offset isl &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.
+	;; 
+	(let* ((i 0)
+	       (slot-name
+		 (block lookup-slot-name
+		   (dolist (slot-name-list (%isl-slot-name-lists isl))
+		     (dolist (name slot-name-list)
+		       (if (= i offset)
+			   (return-from lookup-slot-name name)
+			   (incf i)))))))    
+	  (if nvp
+	      (setf (slot-value-using-class (class-of instance) instance slot-name) new-value)
+	      (slot-value-using-class (class-of instance) 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-dlap required-parameters
+			    metatypes
+			    'pv-miss
+			    (opcode :exit-lap-in-lisp)
+			    (flatten-lap
+			      (opcode :label 'pv-miss)
+			      (opcode :move
+				      (operand :lisp `(primary-pv-cache-miss
+							.ISL. ,@required-parameters))
+				      (operand :lisp-variable '.PV.))
+			      (opcode :exit-lap-in-lisp))
+			    (operand :lisp-variable '.PV.)
+			    (mapcar #'(lambda (sv) (and sv (operand :lisp-variable sv)))
+				    slot-variables)))))
+	
+	  ,@method-body)))))
+
+(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 (apply #'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))
diff --git a/pcl/walk.lisp b/pcl/walk.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..9e7edbbfe338481b2727135c5d4e6830d1d12403
--- /dev/null
+++ b/pcl/walk.lisp
@@ -0,0 +1,1990 @@
+;;;-*- Mode:LISP; Package:(WALKER LISP 1000); Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;; 
+;;; A simple code walker, based IN PART on: (roll the credits)
+;;;   Larry Masinter's Masterscope
+;;;   Moon's Common Lisp code walker
+;;;   Gary Drescher's code walker
+;;;   Larry Masinter's simple code walker
+;;;   .
+;;;   .
+;;;   boy, thats fair (I hope).
+;;;
+;;; For now at least, this code walker really only does what PCL needs it to
+;;; do.  Maybe it will grow up someday.
+;;;
+
+;;;
+;;; This code walker used to be completely portable.  Now it is just "Real
+;;; easy to port".  This change had to happen because the hack that made it
+;;; completely portable kept breaking in different releases of different
+;;; Common Lisps, and in addition it never worked entirely anyways.  So,
+;;; its now easy to port.  To port this walker, all you have to write is one
+;;; simple macro and two simple functions.  These macros and functions are
+;;; used by the walker to manipluate the macroexpansion environments of
+;;; the Common Lisp it is running in.
+;;;
+;;; The code which implements the macroexpansion environment manipulation
+;;; mechanisms is in the first part of the file, the real walker follows it.
+;;; 
+
+(in-package 'walker)
+
+;;;
+;;; The user entry points are walk-form and nested-walked-form.  In addition,
+;;; it is legal for user code to call the variable information functions:
+;;; variable-lexical-p, variable-special-p and variable-class.  Some users
+;;; will need to call define-walker-template, they will have to figure that
+;;; out for themselves.
+;;; 
+(export '(define-walker-template
+	  walk-form
+	  nested-walk-form
+	  variable-lexical-p
+	  variable-special-p
+	  variable-globally-special-p
+	  *variable-declarations*
+	  variable-declaration
+	  ))
+
+
+
+;;;
+;;; On the following pages are implementations of the implementation specific
+;;; environment hacking functions for each of the implementations this walker
+;;; has been ported to.  If you add a new one, so this walker can run in a new
+;;; implementation of Common Lisp, please send the changes back to us so that
+;;; others can also use this walker in that implementation of Common Lisp.
+;;;
+;;; This code just hacks 'macroexpansion environments'.  That is, it is only
+;;; concerned with the function binding of symbols in the environment.  The
+;;; walker needs to be able to tell if the symbol names a lexical macro or
+;;; function, and it needs to be able to build environments which contain
+;;; lexical macro or function bindings.  It must be able, when walking a
+;;; macrolet, flet or labels form to construct an environment which reflects
+;;; the bindings created by that form.  Note that the environment created
+;;; does NOT have to be sufficient to evaluate the body, merely to walk its
+;;; body.  This means that definitions do not have to be supplied for lexical
+;;; functions, only the fact that that function is bound is important.  For
+;;; macros, the macroexpansion function must be supplied.
+;;;
+;;; This code is organized in a way that lets it work in implementations that
+;;; stack cons their environments.  That is reflected in the fact that the
+;;; only operation that lets a user build a new environment is a with-body
+;;; macro which executes its body with the specified symbol bound to the new
+;;; environment.  No code in this walker or in PCL will hold a pointer to
+;;; these environments after the body returns.  Other user code is free to do
+;;; so in implementations where it works, but that code is not considered
+;;; portable.
+;;;
+;;; There are 3 environment hacking tools.  One macro which is used for
+;;; creating new environments, and two functions which are used to access the
+;;; bindings of existing environments.
+;;;
+;;; WITH-AUGMENTED-ENVIRONMENT
+;;;
+;;; ENVIRONMENT-FUNCTION
+;;;
+;;; ENVIRONMENT-MACRO
+;;; 
+
+(defun unbound-lexical-function (&rest args)
+  (declare (ignore args))
+  (error "The evaluator was called to evaluate a form in a macroexpansion~%~
+          environment constructed by the PCL portable code walker.  These~%~
+          environments are only useful for macroexpansion, they cannot be~%~
+          used for evaluation.~%~
+          This error should never occur when using PCL.~%~
+          This most likely source of this error is a program which tries to~%~
+          to use the PCL portable code walker to build its own evaluator."))
+
+
+;;;
+;;; In Coral Common Lisp, the macroexpansion environment is just a list
+;;; of environment entries.  The cadr of each element specifies the type
+;;; of the element.  The only types that interest us are CCL::MACRO and
+;;; FUNCTION.  In these cases the element is interpreted as follows.
+;;;
+;;;   (<function-name> CCL::MACRO . macroexpansion-function)
+;;;   
+;;;   (<function-name> FUNCTION . <fn>)
+;;;   
+;;;   When in the compiler, <fn> is a gensym which will be
+;;;   a variable which bound at run-time to the function.
+;;;   When in the interpreter, <fn> is the actual function.
+;;;   
+;;;
+#+:Coral
+(progn
+
+(defmacro with-augmented-environment
+	  ((new-env old-env &key functions macros) &body body)
+  `(let ((,new-env (with-augmented-environment-internal ,old-env
+							,functions
+							,macros)))
+     ,@body))
+
+(defun with-augmented-environment-internal (env functions macros)
+  (dolist (f functions)
+    (push (list* f 'function (gensym)) env))
+  (dolist (m macros)
+    (push (list* (car m) 'ccl::macro (cadr m)) env))
+  env)
+
+(defun environment-function (env fn)
+  (let ((entry (assoc fn env :test #'equal)))
+    (and entry
+	 (eq (cadr entry) 'function)
+	 (cddr entry))))
+
+(defun environment-macro (env macro)
+  (let ((entry (assoc macro env :test #'equal)))
+    (and entry
+	 (eq (cadr entry) 'ccl::macro)
+	 (cddr entry))))
+
+);#+:Coral
+
+
+;;;
+;;; Franz Common Lisp is a lot like Coral Lisp.  The macroexpansion
+;;; environment is just a list of entries.  The cadr of each element
+;;; specifies the type of the element.  The types that interest us
+;;; are FUNCTION, EXCL::MACRO, and COMPILER::FUNCTION-VALUE.  These
+;;; are interpreted as follows:
+;;;
+;;;   (<function-name> FUNCTION . <a lexical closure>)
+;;;
+;;;      This happens in the interpreter with lexically
+;;;      bound functions.
+;;;
+;;;   (<function-name> COMPILER::FUNCTION-VALUE . <gensym>)
+;;;
+;;;      This happens in the compiler.  The gensym represents
+;;;      a variable which will be bound at run time to the
+;;;      function object.
+;;;
+;;;   (<function-name> EXCL::MACRO . <a lambda>)
+;;;
+;;;      In both interpreter and compiler, this is the
+;;;      representation used for macro definitions.
+;;;   
+;;;
+#+:ExCL
+(progn
+
+(defmacro with-augmented-environment
+	  ((new-env old-env &key functions macros) &body body)
+  `(let ((,new-env (with-augmented-environment-internal ,old-env
+							,functions
+							,macros)))
+     ,@body))
+
+(defun with-augmented-environment-internal (env functions macros)
+  (dolist (f functions)
+    (push (list* f 'function #'unbound-lexical-function) env))
+  (dolist (m macros)
+    (push (list* (car m) 'excl::macro (cadr m)) env))
+  env)
+
+(defun environment-function (env fn)
+  (let ((entry (assoc fn env :test #'equal)))
+    (and entry
+	 (or (eq (cadr entry) 'function)
+	     (eq (cadr entry) 'compiler::function-value))
+	 (cddr entry))))
+
+(defun environment-macro (env macro)
+  (let ((entry (assoc macro env :test #'equal)))
+    (and entry
+	 (eq (cadr entry) 'excl::macro)
+	 (cddr entry))))
+
+);#+:ExCL
+
+
+#+Lucid
+(progn
+  
+(proclaim '(inline
+	    %alphalex-p
+	    add-contour-to-env-shape
+	    make-function-variable
+	    make-sfc-contour
+	    sfc-contour-type
+	    sfc-contour-elements
+	    add-sfc-contour
+	    add-function-contour
+	    add-macrolet-contour
+	    find-variable-in-contour
+	    find-alist-element-in-contour
+	    find-macrolet-in-contour))
+
+(defun %alphalex-p (object)
+  #-Prime
+  (eq (cadddr (cddddr object)) 'lucid::%alphalex)
+  #+Prime
+  (eq (caddr (cddddr object)) 'lucid::%alphalex))
+
+#+Prime 
+(defun lucid::augment-lexenv-fvars-dummy (lexical vars)
+  (lucid::augment-lexenv-fvars-aux lexical vars '() '() 'flet '()))
+
+(defconstant function-contour 1)
+(defconstant macrolet-contour 5)
+
+(defstruct lucid::contour
+  type
+  elements)
+
+(defun add-contour-to-env-shape (contour-type elements env-shape)
+  (cons (make-contour :type contour-type
+		      :elements elements)
+	env-shape))
+
+(defstruct (variable (:constructor make-variable (name source-type)))
+  name
+  (identifier nil)
+  source-type)
+
+(defconstant function-sfc-contour 1)
+(defconstant macrolet-sfc-contour 8)
+(defconstant function-variable-type 1)
+
+(defun make-function-variable (name)
+  (make-variable name function-variable-type))
+
+(defun make-sfc-contour (type elements)
+  (cons type elements))
+
+(defun sfc-contour-type (sfc-contour)
+  (car sfc-contour))
+
+(defun sfc-contour-elements (sfc-contour)
+  (cdr sfc-contour))
+
+(defun add-sfc-contour (element-list environment type)
+  (cons (make-sfc-contour type element-list) environment))
+
+(defun add-function-contour (variable-list environment)
+  (add-sfc-contour variable-list environment function-sfc-contour))
+
+(defun add-macrolet-contour (alist environment)
+  (add-sfc-contour alist environment macrolet-sfc-contour))
+
+(defun find-variable-in-contour (name contour)
+  (dolist (element (sfc-contour-elements contour) nil)
+    (when (eq (variable-name element) name)
+      (return element))))
+
+(defun find-alist-element-in-contour (name contour)
+  (cdr (assoc name (sfc-contour-elements contour))))
+
+(defun find-macrolet-in-contour (name contour)
+  (find-alist-element-in-contour name contour))
+
+(defmacro do-sfc-contours ((contour-var environment &optional result)
+			   &body body)
+  `(dolist (,contour-var ,environment ,result) ,@body))
+
+
+(defmacro with-augmented-environment
+	  ((new-env old-env &key functions macros) &body body)     
+  `(let* ((,new-env (with-augmented-environment-internal ,old-env
+							 ,functions
+							 ,macros)))
+     ,@body))
+
+;;;
+;;; with-augmented-environment-internal is where the real work of augmenting
+;;; the environment happens.
+;;; 
+(defun with-augmented-environment-internal (env functions macros)
+  (let ((function-names (mapcar #'first functions))
+	(macro-names (mapcar #'first macros))
+	(macro-functions (mapcar #'second macros)))
+    (cond ((or (null env)
+	       (contour-p (first env)))
+	   (when function-names
+	     (setq env (add-contour-to-env-shape function-contour
+						 function-names
+						 env)))
+	   (when macro-names
+	     (setq env (add-contour-to-env-shape macrolet-contour
+						 (pairlis macro-names
+							  macro-functions)
+						 env))))
+	  ((%alphalex-p env)
+	   (when function-names
+	     (setq env (lucid::augment-lexenv-fvars-dummy env function-names)))
+	   (when macro-names
+	     (setq env (lucid::augment-lexenv-mvars env
+						    macro-names
+						    macro-functions))))
+	  (t
+	   (when function-names
+	     (setq env (add-function-contour
+			 (mapcar #'make-function-variable function-names)
+			 env)))
+	   (when macro-names
+	     (setq env (add-macrolet-contour
+			 (pairlis macro-names macro-functions)
+			 env)))))
+    env))
+	 
+
+(defun environment-function (env fn)
+  (cond ((null env) nil)
+	((contour-p (first env))
+	 (if (lucid::find-lexical-function fn env)
+	     t
+	     nil))
+	((%alphalex-p env)
+	 (if (lucid::lexenv-fvar fn env)
+	     t
+	     nil))
+	(t (do-sfc-contours (contour env nil)
+	     (let ((type (sfc-contour-type contour)))
+	       (cond ((eql type function-sfc-contour)
+		      (when (find-variable-in-contour fn contour)
+			(return t)))
+		     ((eql type macrolet-sfc-contour)
+		      (when (find-macrolet-in-contour fn contour)
+			(return nil)))))))))
+		      
+(defun environment-macro (env macro)
+  (cond ((null env) nil)
+	((contour-p (first env))
+	 (lucid::find-lexical-macro macro env))
+	((%alphalex-p env)
+	 (lucid::lexenv-mvar macro env))
+	(t (do-sfc-contours (contour env nil)
+	     (let ((type (sfc-contour-type contour)))
+	       (cond ((eql type function-sfc-contour)
+		      (when (find-variable-in-contour macro contour)
+			(return nil)))
+		     ((eql type macrolet-sfc-contour)
+		      (let ((fn (find-macrolet-in-contour macro contour)))
+			(when fn
+			  (return fn))))))))))
+  
+
+);#+Lucid
+
+
+
+;;;
+;;; On the 3600, the documentation for how the environments are represented
+;;; is in sys:sys;eval.lisp.  That total information is not repeated here.
+;;; The important points are that:
+;;;    si:env-variables returns a list of which each element is:
+;;;
+;;;		(symbol value)
+;;;	     or (symbol . locative)
+;;;
+;;;	The first form is for lexical variables, the second for
+;;;	special and instance variables.  In either case CADR of
+;;;	the entry is the value and SETF of CADR is used to change
+;;;	the value.  Variables are looked up with ASSQ.
+;;;
+;;;    si:env-functions returns a list of which each element is:
+;;;     
+;;;		(symbol definition)
+;;;
+;;;	where definition is anything that could go in a function cell.
+;;;	This is used for both local functions and local macros.
+;;;
+;;; The 3600 stack conses its environments (at least in the interpreter).
+;;; This means that code written using this walker and running on the 3600
+;;; must not hold on to the environment after the walk-function returns.
+;;; No code in this walker or in PCL does that.
+;;;
+#+Genera
+(progn
+
+(defmacro with-augmented-environment
+	  ((new-env old-env &key functions macros) &body body)
+  (let ((funs (make-symbol "FNS"))
+	(macs (make-symbol "MACROS"))
+	(new  (make-symbol "NEW")))
+    `(let ((,funs ,functions)
+	   (,macs ,macros)
+	   (,new ()))
+       (dolist (f ,funs)
+	 (push `(,(car f) ,#'unbound-lexical-function) ,new))
+       (dolist (m ,macs)
+	 (push `(,(car m) (special ,(cadr m))) ,new))
+       (let* ((.old-env. ,old-env)
+	      (.old-vars. (pop .old-env.))
+	      (.old-funs. (pop .old-env.))
+	      (.old-blks. (pop .old-env.))
+	      (.old-tags. (pop .old-env.))
+	      (.old-dcls. (pop .old-env.)))
+	 (si:with-interpreter-environment (,new-env
+					   .old-env.
+					   .old-vars.
+					   (append ,new .old-funs.)
+					   .old-blks.
+					   .old-tags.
+					   .old-dcls.)
+	   ,@body)))))
+  
+
+(defun environment-function (env fn)
+  (if (null env)
+      (values nil nil)
+      (let ((entry (assoc fn (si:env-functions env) :test #'equal)))
+	(if (and entry
+		 (or (not (listp (cadr entry)))
+		     (not (eq (caadr entry) 'special))))
+	    (values (cadr entry) t)
+	    (environment-function (si:env-parent env) fn)))))
+
+(defun environment-macro (env macro)
+  (if (null env)
+      (values nil nil)
+      (let ((entry (assoc macro (si:env-functions env) :test #'equal)))
+	(if (and entry
+		 (listp (cadr entry))
+		 (eq (caadr entry) 'special))
+	    (values (cadadr entry) t)
+	    (environment-macro (si:env-parent env) macro)))))
+
+);#+Genera
+
+
+;;;
+;;; In Xerox Lisp, the compiler and interpreter use different structures for
+;;; the environment.  This doesn't cause a serious problem, the parts of the
+;;; environments we are concerned with are fairly similar.
+;;; 
+#+:Xerox
+(progn
+
+(defmacro with-augmented-environment
+	  ((new-env old-env &key functions macros) &body body)     
+  `(let* ((,new-env (with-augmented-environment-internal ,old-env
+							 ,functions
+							 ,macros)))
+     ,@body))
+
+;;;
+;;; with-augmented-environment-internal is where the real work of augmenting
+;;; the environment happens.  Before it gets there, env had better not be NIL
+;;; anymore because we have to know what kind of environment we are supposed
+;;; to be building up.  This is probably never a real concern in practice.
+;;; It better not be because we don't do anything about it.
+;;; 
+(defun with-augmented-environment-internal (env functions macros)
+  (cond
+     ((compiler::env-p env)
+	(dolist (f functions)
+	   (setq env (compiler::copy-env-with-function
+		       env f :function)))
+	(dolist (m macros)
+	   (setq env (compiler::copy-env-with-function
+	 	  env (car m) :macro (cadr m)))))
+     (t (setq env (if (il:environment-p env)
+		    (il:\\copy-environment env)
+		    (il:\\make-environment)))
+	;; The functions field of the environment is a plist of function names
+	;; and conses like (:function . fn) or (:macro . expansion-fn).
+	;; Note that we can't smash existing entries in this plist since these
+	;; are likely shared with older environments.
+	(dolist (f functions)
+	  (setf (il:environment-functions env)
+		(list* f (cons :function #'unbound-lexical-function)
+		       (il:environment-functions env))))
+	(dolist (m macros)
+	  (setf (il:environment-functions env)
+		(list* (car m) (cons :macro (cadr m))
+		       (il:environment-functions env))))))
+  env)
+
+(defun environment-function (env fn)
+  (cond ((compiler::env-p env) (eq (compiler:env-fboundp env fn) :function))
+	((il:environment-p env) (eq (getf (il:environment-functions env) fn)
+				    :function))
+	(t nil)))
+
+(defun environment-macro (env macro) 
+  (cond ((compiler::env-p env)
+	 (multiple-value-bind (type def)
+	     (compiler:env-fboundp env macro)
+	   (when (eq type :macro) def)))
+	((il:environment-p env)
+	 (xcl:destructuring-bind (type . def)
+	     (getf (il:environment-functions env) macro)
+	   (when (eq type :macro) def)))
+	(t nil)))
+
+);#+:Xerox
+
+
+;;;
+;;; In IBUKI Common Lisp, the macroexpansion environment is a three element
+;;; list.  The second element describes lexical functions and macros.  The 
+;;; function entries in this list have the form 
+;;;     (<name> . (FUNCTION . (<function-value> . nil))
+;;; The macro entries have the form 
+;;;     (<name> . (MACRO . (<macro-value> . nil)).
+;;;
+;;;
+#+(or KCL IBCL)
+(progn
+
+(defmacro with-augmented-environment
+	  ((new-env old-env &key functions macros) &body body)
+	  `(let ((,new-env (with-augmented-environment-internal ,old-env
+								,functions
+								,macros)))
+	     ,@body))
+
+(defun with-augmented-environment-internal (env functions macros)
+  (let ((first (first env))
+	(lexicals (second env))
+	(third (third env)))
+    (dolist (f functions)
+      (push `(,(car f) .  (function  . (,#'unbound-lexical-function . nil)))
+	    lexicals))
+    (dolist (m macros)
+      (push `(,(car m)  .  (macro . ( ,(cadr m) . nil))) 
+	    lexicals))
+    (list first lexicals third)))
+
+(defun environment-function (env fn)
+  (when env
+	(let ((entry (assoc fn (second env))))
+	  (and entry
+	       (eq (cadr entry) 'function)
+	       (caddr entry)))))
+
+(defun environment-macro (env macro)
+  (when env
+	(let ((entry (assoc macro (second env))))
+	  (and entry
+	       (eq (cadr entry) 'macro)
+	       (caddr entry)))))
+);#+(or KCL IBCL)
+
+
+;;;   --- TI Explorer --
+
+;;; An environment is a two element list, whose car we can ignore and
+;;; whose cadr is list of the local-definitions-frames. Each
+;;; local-definitions-frame holds either macros or functions, but not
+;;; both.  Each frame is a plist of <name> <def> <name> <def> ...  where
+;;; <name> is a locative to the function cell of the symbol that names
+;;; the function or macro, and <def> is the new def or NIL if this is function
+;;; redefinition or (cons 'ticl:macro <macro-expansion-function>) if this is a macro
+;;; redefinition.
+;;;
+;;; Here's an example.  For the form:
+;;; (defun foo ()
+;;;   (macrolet ((bar (a b) (list a b))
+;;;	         (bar2 (a b) (list a b)))
+;;;     (flet ((some-local-fn (c d) (print (list c d)))
+;;;	       (another (c d) (print (list c d))))
+;;;       (bar (some-local-fn 1 2) 3))))
+
+;;; the environment arg to macroexpand-1 when called on
+;;; (bar (some-local-fn 1 2) 3)
+;;;is 
+;;;(NIL ((#<DTP-LOCATIVE 4710602> NIL
+;;;       #<DTP-LOCATIVE 4710671> NIL)
+;;;      (#<DTP-LOCATIVE 7346562>
+;;;       (TICL:MACRO TICL:NAMED-LAMBDA (BAR (:DESCRIPTIVE-ARGLIST (A B)))
+;;;		   (SYS::*MACROARG* &OPTIONAL SYS::*MACROENVIRONMENT*)
+;;;		   (BLOCK BAR ....))
+;;;       #<DTP-LOCATIVE 4710664>
+;;;       (TICL:MACRO TICL:NAMED-LAMBDA (BAR2 (:DESCRIPTIVE-ARGLIST (A B)))
+;;;		   (SYS::*MACROARG* &OPTIONAL SYS::*MACROENVIRONMENT*)
+;;;		   (BLOCK BAR2 ....))))
+#+TI
+(progn 
+
+;;; from sys:site;macros.lisp
+(eval-when (compile load eval)
+  
+(DEFMACRO MACRO-DEF? (thing)
+  `(AND (CONSP ,thing) (EQ (CAR ,thing) 'TICL::MACRO)))
+
+;; the following macro generates code to check the 'local' environment
+;; for a macro definition for THE SYMBOL <name>. Such a definition would
+;; be set up only by a MACROLET. If a macro definition for <name> is
+;; found, its expander function is returned.
+
+(DEFMACRO FIND-LOCAL-DEFINITION (name local-function-environment)
+  `(IF ,local-function-environment
+       (LET ((vcell (ticl::LOCF (SYMBOL-FUNCTION ,name))))
+	 (DOLIST (frame  ,local-function-environment)
+	   ;; <value> is nil or a locative
+	   (LET ((value (sys::GET-LOCATION-OR-NIL (ticl::LOCF frame)
+						  vcell))) 
+	     (When value (RETURN (CAR value))))))
+       nil)))
+
+ 
+;;;Edited by Reed Hastings         13 Jan 88  16:29
+(defun environment-macro (env macro)
+  "returns what macro-function would, ie. the expansion function"
+  ;;some code picked off macroexpand-1
+  (let* ((local-definitions (cadr env))
+	 (local-def (find-local-definition macro local-definitions)))
+    (if (macro-def? local-def)
+	(cdr local-def))))
+
+;;;Edited by Reed Hastings         13 Jan 88  16:29
+;;;Edited by Reed Hastings         7 Mar 88  19:07
+(defun environment-function (env fn)
+  (let* ((local-definitions (cadr env)))
+    (dolist (frame local-definitions)
+      (let ((val (getf frame
+		       (ticl::locf (symbol-function fn))
+		       :not-found-marker)))
+	(cond ((eq val :not-found-marker))
+	      ((functionp val) (return t))
+	      ((and (listp val)
+		    (eq (car val) 'ticl::macro))
+	       (return nil))
+	      (t
+	       (error "we are confused")))))))
+	     
+
+;;;Edited by Reed Hastings         13 Jan 88  16:29
+;;;Edited by Reed Hastings         7 Mar 88  19:07
+(defun with-augmented-environment-internal (env functions macros)
+  (let ((local-definitions (cadr env))
+	(new-local-fns-frame
+	  (mapcan #'(lambda (fn)
+		      (list (ticl:locf (symbol-function (car fn)))
+			    #'unbound-lexical-function))
+		  functions))
+	 (new-local-macros-frame
+	   (mapcan #'(lambda (m)
+		       (list (ticl:locf (symbol-function (car m))) (cons 'ticl::macro (cadr m))))
+		   macros)))
+    (when new-local-fns-frame 
+      (push new-local-fns-frame local-definitions))
+    (when new-local-macros-frame
+      (push new-local-macros-frame local-definitions))   
+    `(,(car env) ,local-definitions)))
+
+
+;;;Edited by Reed Hastings         7 Mar 88  19:07
+(defmacro with-augmented-environment
+	  ((new-env old-env &key functions macros) &body body)
+  `(let ((,new-env (with-augmented-environment-internal ,old-env
+							,functions
+							,macros)))
+     ,@body))
+
+);#+TI
+
+
+#+(and dec vax common)
+(progn
+
+(defmacro with-augmented-environment
+	  ((new-env old-env &key functions macros) &body body)
+  `(let ((,new-env (with-augmented-environment-internal ,old-env
+							,functions
+							,macros)))
+     ,@body))
+
+(defun with-augmented-environment-internal (env functions macros)
+  #'(lambda (op &optional (arg nil arg-p))
+      (cond ((eq op :macro-function) 
+	     (unless arg-p (error "Invalid environment use."))
+	     (lookup-macro-function arg env functions macros))
+            (arg-p
+	     (error "Invalid environment operation: ~S ~S" op arg))
+            (t
+	     (lookup-macro-function op env functions macros)))))
+
+(defun lookup-macro-function (name env fns macros)
+  (let ((m (assoc name macros)))
+    (cond (m                (cadr m))
+          ((assoc name fns) :function)
+          (env              (funcall env name))
+          (t                nil))))
+
+(defun environment-macro (env macro)
+  (let ((m (and env (funcall env macro))))
+    (and (not (eq m :function)) 
+         m)))
+
+;;; Nobody calls environment-function.  What would it return, anyway?
+);#+(and dec vax common)
+
+
+;;;
+;;; In Golden Common Lisp, the macroexpansion environment is just a list
+;;; of environment entries.  Unless the car of the list is :compiler-menv 
+;;; it is an interpreted environment.  The cadr of each element specifies 
+;;; the type of the element.  The only types that interest us are GCL:MACRO
+;;; and FUNCTION.  In these cases the element is interpreted as follows.
+;;;
+;;; Compiled:
+;;;   (<function-name> <gensym> macroexpansion-function)
+;;;   (<function-name> <fn>)
+;;;   
+;;; Interpreted:
+;;;   (<function-name> GCL:MACRO macroexpansion-function)
+;;;   (<function-name> <fn>)
+;;;   
+;;;   When in the compiler, <fn> is a gensym which will be
+;;;   a variable which bound at run-time to the function.
+;;;   When in the interpreter, <fn> is the actual function.
+;;;   
+;;;
+#+gclisp
+(progn
+
+(defmacro with-augmented-environment
+	  ((new-env old-env &key functions macros) &body body)
+  `(let ((,new-env (with-augmented-environment-internal ,old-env
+							,functions
+							,macros)))
+     ,@body))
+
+(defun with-augmented-environment-internal (env functions macros)
+  (let ((new-entries nil))
+    (dolist (f functions)
+      (push (cons (car f) nil) new-entries))
+    (dolist (m macros)
+      (push (cons (car m)
+		  (if (eq :compiler-menv (car env))
+		      (if (eq (caadr m) 'lisp::lambda)
+			  `(,(gensym) ,(cadr m))
+			`(,(gensym) ,@(cadr m)))
+		    `(gclisp:MACRO ,@(cadr m))))
+	      new-entries))
+    (if (eq :compiler-menv (car env))
+	`(:compiler-menv ,@new-entries ,@(cdr env))
+      (append new-entries env))))
+
+(defun environment-function (env fn)
+  (let ((entry (lisp::lexical-function fn env)))
+    (and entry 
+	 (eq entry 'lisp::lexical-function)
+	 fn)))
+
+(defun environment-macro (env macro)
+  (let ((entry (assoc macro (if (eq :compiler-menv (first env))
+				 (rest env)
+			       env))))
+    (and entry
+	 (consp entry)
+	 (symbolp (car entry))			;name
+	 (symbolp (cadr entry))			;gcl:macro or gensym
+	 (nthcdr 2 entry))))
+
+);#+gclisp
+
+
+
+(defmacro with-new-definition-in-environment
+	  ((new-env old-env macrolet/flet/labels-form) &body body)
+  (let ((functions (make-symbol "Functions"))
+	(macros (make-symbol "Macros")))
+    `(let ((,functions ())
+	   (,macros ()))
+       (ecase (car ,macrolet/flet/labels-form)
+	 ((flet labels)
+	  (dolist (fn (cadr ,macrolet/flet/labels-form))
+	    (push fn ,functions)))
+	 ((macrolet)
+	  (dolist (mac (cadr ,macrolet/flet/labels-form))
+	    (push (list (car mac)
+			(convert-macro-to-lambda (cadr mac)
+						 (cddr mac)
+						 (string (car mac))))
+		  ,macros))))
+       (with-augmented-environment
+	      (,new-env ,old-env :functions ,functions :macros ,macros)
+	 ,@body))))
+
+#-Genera
+(defun convert-macro-to-lambda (llist body &optional (name "Dummy Macro"))
+  (let ((gensym (make-symbol name)))
+    (eval `(defmacro ,gensym ,llist ,@body))
+    (macro-function gensym)))
+
+#+Genera
+(defun convert-macro-to-lambda (llist body &optional (name "Dummy Macro"))
+  (si:defmacro-1
+    'sys:named-lambda 'sys:special (make-symbol name) llist body))
+
+
+
+
+
+;;;
+;;; Now comes the real walker.
+;;;
+;;; As the walker walks over the code, it communicates information to itself
+;;; about the walk.  This information includes the walk function, variable
+;;; bindings, declarations in effect etc.  This information is inherently
+;;; lexical, so the walker passes it around in the actual environment the
+;;; walker passes to macroexpansion functions.  This is what makes the
+;;; nested-walk-form facility work properly.
+;;;
+(defmacro walker-environment-bind ((var env &rest key-args)
+				      &body body)
+  `(with-augmented-environment
+     (,var ,env :macros (walker-environment-bind-1 ,env ,.key-args))
+     .,body))
+
+(defvar *key-to-walker-environment* (gensym))
+
+(defun env-lock (env)
+  (environment-macro env *key-to-walker-environment*))
+
+(defun walker-environment-bind-1 (env &key (walk-function nil wfnp)
+					   (walk-form nil wfop)
+					   (declarations nil decp)
+					   (lexical-variables nil lexp))
+  (let ((lock (environment-macro env *key-to-walker-environment*)))
+    (list
+      (list *key-to-walker-environment*
+	    (list (if wfnp walk-function     (car lock))
+		  (if wfop walk-form         (cadr lock))
+		  (if decp declarations      (caddr lock))
+		  (if lexp lexical-variables (cadddr lock)))))))
+		  
+(defun env-walk-function (env)
+  (car (env-lock env)))
+
+(defun env-walk-form (env)
+  (cadr (env-lock env)))
+
+(defun env-declarations (env)
+  (caddr (env-lock env)))
+
+(defun env-lexical-variables (env)
+  (cadddr (env-lock env)))
+
+
+(defun note-declaration (declaration env)
+  (let ((lock (env-lock env)))
+    (setf (caddr lock)
+	  (cons declaration (caddr lock)))))
+
+(defun note-lexical-binding (thing env)
+  (let ((lock (env-lock env)))
+    (setf (cadddr lock)
+	  (cons thing (cadddr lock)))))
+
+
+(defun VARIABLE-LEXICAL-P (var env)
+  (member var (env-lexical-variables env)))
+
+(defvar *VARIABLE-DECLARATIONS* '(special))
+
+(defun VARIABLE-DECLARATION (declaration var env)
+  (if (not (member declaration *variable-declarations*))
+      (error "~S is not a reckognized variable declaration." declaration)
+      (let ((id (or (member var (env-lexical-variables env)) var)))
+	(dolist (decl (env-declarations env))
+	  (when (and (eq (car decl) declaration)
+		     (eq (cadr decl) id))
+	    (return decl))))))
+
+(defun VARIABLE-SPECIAL-P (var env)
+  (or (not (null (variable-declaration 'special var env)))
+      (variable-globally-special-p var)))
+
+;;;
+;;; VARIABLE-GLOBALLY-SPECIAL-P is used to ask if a variable has been
+;;; declared globally special.  Any particular CommonLisp implementation
+;;; should customize this function accordingly and send their customization
+;;; back.
+;;;
+;;; The default version of variable-globally-special-p is probably pretty
+;;; slow, so it uses *globally-special-variables* as a cache to remember
+;;; variables that it has already figured out are globally special.
+;;;
+;;; This would need to be reworked if an unspecial declaration got added to
+;;; Common Lisp.
+;;;
+;;; Common Lisp nit:
+;;;   variable-globally-special-p should be defined in Common Lisp.
+;;;
+#-(or Genera Lucid Xerox Excl KCL IBCL (and dec vax common) :CMU HP-HPLabs
+      GCLisp TI pyramid)
+(defvar *globally-special-variables* ())
+
+(defun variable-globally-special-p (symbol)
+  #+Genera                      (si:special-variable-p symbol)
+  #+Lucid                       (lucid::proclaimed-special-p symbol)
+  #+TI                          (get symbol 'special)
+  #+Xerox                       (il:variable-globally-special-p symbol)
+  #+(and dec vax common)        (get symbol 'system::globally-special)
+  #+(or KCL IBCL)               (si:specialp symbol)
+  #+excl                        (get symbol 'excl::.globally-special.)
+  #+:CMU			(or (get symbol 'lisp::globally-special)
+				    (get symbol
+					 'clc::globally-special-in-compiler))
+  #+HP-HPLabs                   (member (get symbol 'impl:vartype)
+					'(impl:fluid impl:global)
+					:test #'eq)
+  #+:GCLISP                     (gclisp::special-p symbol)
+  #+pyramid			(or (get symbol 'lisp::globally-special)
+				    (get symbol
+					 'clc::globally-special-in-compiler))
+  #+:CORAL                      (ccl::proclaimed-special-p symbol)
+  #-(or Genera Lucid Xerox Excl KCL IBCL (and dec vax common) :CMU HP-HPLabs
+	GCLisp TI pyramid :CORAL)
+  (or (not (null (member symbol *globally-special-variables* :test #'eq)))
+      (when (eval `(flet ((ref () ,symbol))
+		     (let ((,symbol '#,(list nil)))
+		       (and (boundp ',symbol) (eq ,symbol (ref))))))
+	(push symbol *globally-special-variables*)
+	t)))
+
+
+  ;;   
+;;;;;; Handling of special forms (the infamous 24).
+  ;;
+;;;
+;;; and I quote...
+;;; 
+;;;     The set of special forms is purposely kept very small because
+;;;     any program analyzing program (read code walker) must have
+;;;     special knowledge about every type of special form. Such a
+;;;     program needs no special knowledge about macros...
+;;;
+;;; So all we have to do here is a define a way to store and retrieve
+;;; templates which describe how to walk the 24 special forms and we are all
+;;; set...
+;;;
+;;; Well, its a nice concept, and I have to admit to being naive enough that
+;;; I believed it for a while, but not everyone takes having only 24 special
+;;; forms as seriously as might be nice.  There are (at least) 3 ways to
+;;; lose:
+;;
+;;;   1 - Implementation x implements a Common Lisp special form as a macro
+;;;       which expands into a special form which:
+;;;         - Is a common lisp special form (not likely)
+;;;         - Is not a common lisp special form (on the 3600 IF --> COND).
+;;;
+;;;     * We can safe ourselves from this case (second subcase really) by
+;;;       checking to see if there is a template defined for something
+;;;       before we check to see if we we can macroexpand it.
+;;;
+;;;   2 - Implementation x implements a Common Lisp macro as a special form.
+;;;
+;;;     * This is a screw, but not so bad, we save ourselves from it by
+;;;       defining extra templates for the macros which are *likely* to
+;;;       be implemented as special forms.  (DO, DO* ...)
+;;;
+;;;   3 - Implementation x has a special form which is not on the list of
+;;;       Common Lisp special forms.
+;;;
+;;;     * This is a bad sort of a screw and happens more than I would like
+;;;       to think, especially in the implementations which provide more
+;;;       than just Common Lisp (3600, Xerox etc.).
+;;;       The fix is not terribly staisfactory, but will have to do for
+;;;       now.  There is a hook in get walker-template which can get a
+;;;       template from the implementation's own walker.  That template
+;;;       has to be converted, and so it may be that the right way to do
+;;;       this would actually be for that implementation to provide an
+;;;       interface to its walker which looks like the interface to this
+;;;       walker.
+;;;
+
+(eval-when (compile load eval)
+
+(defmacro get-walker-template-internal (x) ;Has to be inside eval-when because
+  `(get ,x 'walker-template))		   ;Golden Common Lisp doesn't hack
+					   ;compile time definition of macros
+					   ;right for setf.
+
+(defmacro define-walker-template
+	  (name &optional (template '(nil repeat (eval))))
+  `(eval-when (load eval)
+     (setf (get-walker-template-internal ',name) ',template)))
+)
+
+(defun get-walker-template (x)
+  (cond ((symbolp x)
+	 (or (get-walker-template-internal x)
+	     (get-implementation-dependent-walker-template x)))
+	((and (listp x) (eq (car x) 'lambda))
+	 '(lambda repeat (eval)))
+	(t
+	 (error "Can't get template for ~S" x))))
+
+(defun get-implementation-dependent-walker-template (x)
+  (declare (ignore x))
+  ())
+
+
+  ;;   
+;;;;;; The actual templates
+  ;;   
+
+(define-walker-template BLOCK                (NIL NIL REPEAT (EVAL)))
+(define-walker-template CATCH                (NIL EVAL REPEAT (EVAL)))
+(define-walker-template COMPILER-LET         walk-compiler-let)
+(define-walker-template DECLARE              walk-unexpected-declare)
+(define-walker-template EVAL-WHEN            (NIL QUOTE REPEAT (EVAL)))
+(define-walker-template FLET                 walk-flet)
+(define-walker-template FUNCTION             (NIL CALL))
+(define-walker-template GO                   (NIL QUOTE))
+(define-walker-template IF                   walk-if)
+(define-walker-template LABELS               walk-labels)
+(define-walker-template LAMBDA               walk-lambda)
+(define-walker-template LET                  walk-let)
+(define-walker-template LET*                 walk-let*)
+(define-walker-template MACROLET             walk-macrolet)
+(define-walker-template MULTIPLE-VALUE-CALL  (NIL EVAL REPEAT (EVAL)))
+(define-walker-template MULTIPLE-VALUE-PROG1 (NIL RETURN REPEAT (EVAL)))
+(define-walker-template MULTIPLE-VALUE-SETQ  (NIL (REPEAT (SET)) EVAL))
+(define-walker-template MULTIPLE-VALUE-BIND  walk-multiple-value-bind)
+(define-walker-template PROGN                (NIL REPEAT (EVAL)))
+(define-walker-template PROGV                (NIL EVAL EVAL REPEAT (EVAL)))
+(define-walker-template QUOTE                (NIL QUOTE))
+(define-walker-template RETURN-FROM          (NIL QUOTE REPEAT (RETURN)))
+(define-walker-template SETQ                 (NIL REPEAT (SET EVAL)))
+(define-walker-template TAGBODY              walk-tagbody)
+(define-walker-template THE                  (NIL QUOTE EVAL))
+(define-walker-template THROW                (NIL EVAL EVAL))
+(define-walker-template UNWIND-PROTECT       (NIL RETURN REPEAT (EVAL)))
+
+;;; The new special form.
+;(define-walker-template pcl::LOAD-TIME-EVAL       (NIL EVAL))
+
+;;;
+;;; And the extra templates...
+;;;
+(define-walker-template DO      walk-do)
+(define-walker-template DO*     walk-do*)
+(define-walker-template PROG    walk-prog)
+(define-walker-template PROG*   walk-prog*)
+(define-walker-template COND    (NIL REPEAT ((TEST REPEAT (EVAL)))))
+
+#+Genera
+(progn
+  (define-walker-template zl::named-lambda walk-named-lambda)
+  (define-walker-template SCL:LETF walk-let)
+  (define-walker-template SCL:LETF* walk-let*)
+  )
+
+#+Lucid
+(progn
+  (define-walker-template #+LCL3.0 lucid-common-lisp:named-lambda
+			  #-LCL3.0 sys:named-lambda walk-named-lambda)
+  )
+
+#+(or KCL IBCL)
+(progn
+  (define-walker-template lambda-block walk-named-lambda);Not really right,
+							 ;we don't hack block
+						         ;names anyways.
+  )
+
+#+TI
+(progn
+  (define-walker-template TICL::LET-IF walk-let-if)
+  )
+
+#+:Coral
+(progn
+  (define-walker-template ccl:%stack-block walk-let)
+  )
+
+
+
+(defun WALK-FORM (form
+		  &optional environment
+			    (walk-function
+			      #'(lambda (subform context env)
+				  (declare (ignore context env))
+				  subform)))
+  (walker-environment-bind (new-env environment :walk-function walk-function)
+    (walk-form-internal form :eval new-env)))
+
+;;;
+;;; nested-walk-form provides an interface that allows nested macros, each
+;;; of which must walk their body to just do one walk of the body of the
+;;; inner macro.  That inner walk is done with a walk function which is the
+;;; composition of the two walk functions.
+;;;
+;;; This facility works by having the walker annotate the environment that
+;;; it passes to macroexpand-1 to know which form is being macroexpanded.
+;;; If then the &whole argument to the macroexpansion function is eq to
+;;; the env-walk-form of the environment, nested-walk-form can be certain
+;;; that there are no intervening layers and that a nested walk is alright.
+;;;
+;;; There are some semantic problems with this facility.  In particular, if
+;;; the outer walk function returns T as its walk-no-more-p value, this will
+;;; prevent the inner walk function from getting a chance to walk the subforms
+;;; of the form.  This is almost never what you want, since it destroys the
+;;; equivalence between this nested-walk-form function and two seperate
+;;; walk-forms.
+;;;
+(defun NESTED-WALK-FORM (whole
+			 form
+			 &optional environment
+				   (walk-function
+				     #'(lambda (subform context env)
+					 (declare (ignore context env))
+					 subform)))
+  (if (eq whole (env-walk-form environment))
+      (let ((outer-walk-function (env-walk-function environment)))
+	(throw whole
+	  (walk-form
+	    form
+	    environment
+	    #'(lambda (f c e)
+		;; First loop to make sure the inner walk function
+		;; has done all it wants to do with this form.
+		;; Basically, what we are doing here is providing
+		;; the same contract walk-form-internal normally
+		;; provides to the inner walk function.
+		(let ((inner-result nil)
+		      (inner-no-more-p nil)
+		      (outer-result nil)
+		      (outer-no-more-p nil))
+		  (loop
+		    (multiple-value-setq (inner-result inner-no-more-p)
+					 (funcall walk-function f c e))
+		    (cond (inner-no-more-p (return))
+			  ((not (eq inner-result f)))
+			  ((not (consp inner-result)) (return))
+			  ((get-walker-template (car inner-result)) (return))
+			  (t
+			   (multiple-value-bind (expansion macrop)
+			       (walker-environment-bind
+				     (new-env e :walk-form inner-result)
+				 (macroexpand-1 inner-result new-env))
+			     (if macrop
+				 (setq inner-result expansion)
+				 (return)))))
+		    (setq f inner-result))
+		  (multiple-value-setq (outer-result outer-no-more-p)
+				       (funcall outer-walk-function
+						inner-result
+						c
+						e))
+		  (values outer-result
+			  (and inner-no-more-p outer-no-more-p)))))))
+      (walk-form form environment walk-function)))
+
+;;;
+;;; WALK-FORM-INTERNAL is the main driving function for the code walker. It
+;;; takes a form and the current context and walks the form calling itself or
+;;; the appropriate template recursively.
+;;;
+;;;   "It is recommended that a program-analyzing-program process a form
+;;;    that is a list whose car is a symbol as follows:
+;;;
+;;;     1. If the program has particular knowledge about the symbol,
+;;;        process the form using special-purpose code.  All of the
+;;;        standard special forms should fall into this category.
+;;;     2. Otherwise, if macro-function is true of the symbol apply
+;;;        either macroexpand or macroexpand-1 and start over.
+;;;     3. Otherwise, assume it is a function call. "
+;;;     
+
+(defun walk-form-internal (form context env
+			   &aux newform newnewform
+				walk-no-more-p macrop
+				fn template)
+  ;; First apply the walk-function to perform whatever translation
+  ;; the user wants to this form.  If the second value returned
+  ;; by walk-function is T then we don't recurse...
+  (catch form
+    (multiple-value-setq (newform walk-no-more-p)
+      (funcall (env-walk-function env) form context env))
+    (catch newform
+      (cond (walk-no-more-p newform)
+	    ((not (eq form newform))
+	     (walk-form-internal newform context env))
+	    ((not (consp newform)) newform)
+	    ((setq template (get-walker-template (setq fn (car newform))))
+	     (if (symbolp template)
+		 (funcall template newform context env)
+		 (walk-template newform template context env)))
+	    (t
+	     (multiple-value-setq (newnewform macrop)
+	       (walker-environment-bind (new-env env :walk-form newform)
+		 (macroexpand-1 newform new-env)))
+	     (cond (macrop (walk-form-internal newnewform context env))
+		   ((and (symbolp fn)
+			 (not (fboundp fn))
+			 (special-form-p fn))
+		    (error
+		      "~S is a special form, not defined in the CommonLisp.~%~
+                       manual This code walker doesn't know how to walk it.~%~
+                       Define a template for this special form and try again."
+		      fn))
+		   (t
+		    ;; Otherwise, walk the form as if its just a standard 
+		    ;; functioncall using a template for standard function
+		    ;; call.
+		    (walk-template
+		      newnewform '(call repeat (eval)) context env))))))))
+
+(defun walk-template (form template context env)
+  (if (atom template)
+      (ecase template
+        ((EVAL FUNCTION TEST EFFECT RETURN)
+         (walk-form-internal form :EVAL env))
+        ((QUOTE NIL) form)
+        (SET
+          (walk-form-internal form :SET env))
+        ((LAMBDA CALL)
+	 (cond ((symbolp form) form)
+	       #+Lispm
+	       ((sys:validate-function-spec form) form)
+	       (t (walk-form-internal form context env)))))
+      (case (car template)
+        (REPEAT
+          (walk-template-handle-repeat form
+                                       (cdr template)
+				       ;; For the case where nothing happens
+				       ;; after the repeat optimize out the
+				       ;; call to length.
+				       (if (null (cddr template))
+					   ()
+					   (nthcdr (- (length form)
+						      (length
+							(cddr template)))
+						   form))
+                                       context
+				       env))
+        (IF
+	  (walk-template form
+			 (if (if (listp (cadr template))
+				 (eval (cadr template))
+				 (funcall (cadr template) form))
+			     (caddr template)
+			     (cadddr template))
+			 context
+			 env))
+        (REMOTE
+          (walk-template form (cadr template) context env))
+        (otherwise
+          (cond ((atom form) form)
+                (t (recons form
+                           (walk-template
+			     (car form) (car template) context env)
+                           (walk-template
+			     (cdr form) (cdr template) context env))))))))
+
+(defun walk-template-handle-repeat (form template stop-form context env)
+  (if (eq form stop-form)
+      (walk-template form (cdr template) context env)
+      (walk-template-handle-repeat-1 form
+				     template
+				     (car template)
+				     stop-form
+				     context
+				     env)))
+
+(defun walk-template-handle-repeat-1 (form template repeat-template
+					   stop-form context env)
+  (cond ((null form) ())
+        ((eq form stop-form)
+         (if (null repeat-template)
+             (walk-template stop-form (cdr template) context env)       
+             (error "While handling repeat:
+                     ~%~Ran into stop while still in repeat template.")))
+        ((null repeat-template)
+         (walk-template-handle-repeat-1
+	   form template (car template) stop-form context env))
+        (t
+         (recons form
+                 (walk-template (car form) (car repeat-template) context env)
+                 (walk-template-handle-repeat-1 (cdr form)
+						template
+						(cdr repeat-template)
+						stop-form
+						context
+						env)))))
+
+(defun walk-repeat-eval (form env)
+  (and form
+       (recons form
+	       (walk-form-internal (car form) :eval env)
+	       (walk-repeat-eval (cdr form) env))))
+
+(defun recons (x car cdr)
+  (if (or (not (eq (car x) car))
+          (not (eq (cdr x) cdr)))
+      (cons car cdr)
+      x))
+
+(defun relist (x &rest args)
+  (relist-internal x args nil))
+
+(defun relist* (x &rest args)
+  (relist-internal x args 't))
+
+(defun relist-internal (x args *p)
+  (if (null (cdr args))
+      (if *p (car args) (list (car args)))
+      (recons x
+	      (car args)
+	      (relist-internal (cdr x) (cdr args) *p))))
+
+
+  ;;   
+;;;;;; Special walkers
+  ;;
+
+(defun walk-declarations (body fn env
+			       &optional doc-string-p declarations old-body
+			       &aux (form (car body)) macrop new-form)
+  (cond ((and (stringp form)			;might be a doc string
+              (cdr body)			;isn't the returned value
+              (null doc-string-p)		;no doc string yet
+              (null declarations))		;no declarations yet
+         (recons body
+                 form
+                 (walk-declarations (cdr body) fn env t)))
+        ((and (listp form) (eq (car form) 'declare))
+         ;; Got ourselves a real live declaration.  Record it, look for more.
+         (dolist (declaration (cdr form))
+	   (let ((type (car declaration))
+		 (name (cadr declaration))
+		 (args (cddr declaration)))
+	     (if (member type *variable-declarations*)
+		 (note-declaration `(,type
+				     ,(or (variable-lexical-p name env) name)
+				     ,.args)
+				   env)
+		 (note-declaration declaration env))
+	     (push declaration declarations)))
+         (recons body
+                 form
+                 (walk-declarations
+		   (cdr body) fn env doc-string-p declarations)))
+        ((and form
+	      (listp form)
+	      (null (get-walker-template (car form)))
+	      (progn
+		(multiple-value-setq (new-form macrop)
+				     (macroexpand-1 form env))
+		macrop))
+	 ;; This form was a call to a macro.  Maybe it expanded
+	 ;; into a declare?  Recurse to find out.
+	 (walk-declarations (recons body new-form (cdr body))
+			    fn env doc-string-p declarations
+			    (or old-body body)))
+	(t
+	 ;; Now that we have walked and recorded the declarations,
+	 ;; call the function our caller provided to expand the body.
+	 ;; We call that function rather than passing the real-body
+	 ;; back, because we are RECONSING up the new body.
+	 (funcall fn (or old-body body) env))))
+
+
+(defun walk-unexpected-declare (form context env)
+  (declare (ignore context env))
+  (warn "Encountered declare ~S in a place where a declare was not expected."
+	form)
+  form)
+
+(defun walk-arglist (arglist context env &optional (destructuringp nil)
+					 &aux arg)
+  (cond ((null arglist) ())
+        ((symbolp (setq arg (car arglist)))
+         (or (member arg lambda-list-keywords)
+             (note-lexical-binding arg env))
+         (recons arglist
+                 arg
+                 (walk-arglist (cdr arglist)
+                               context
+			       env
+                               (and destructuringp
+				    (not (member arg
+						 lambda-list-keywords))))))
+        ((consp arg)
+         (prog1 (if destructuringp
+                    (walk-arglist arg context env destructuringp)
+                    (recons arglist
+                            (relist* arg
+                                     (car arg)
+                                     (walk-form-internal (cadr arg) :eval env)
+                                     (cddr arg))
+                            (walk-arglist (cdr arglist) context env nil)))
+                (if (symbolp (car arg))
+                    (note-lexical-binding (car arg) env)
+                    (note-lexical-binding (cadar arg) env))
+                (or (null (cddr arg))
+                    (not (symbolp (caddr arg)))
+                    (note-lexical-binding (caddr arg) env))))
+          (t
+	   (error "Can't understand something in the arglist ~S" arglist))))
+
+(defun walk-let (form context env)
+  (walk-let/let* form context env nil))
+
+(defun walk-let* (form context env)
+  (walk-let/let* form context env t))
+
+(defun walk-prog (form context env)
+  (walk-prog/prog* form context env nil))
+
+(defun walk-prog* (form context env)
+  (walk-prog/prog* form context env t))
+
+(defun walk-do (form context env)
+  (walk-do/do* form context env nil))
+
+(defun walk-do* (form context env)
+  (walk-do/do* form context env t))
+
+(defun walk-let/let* (form context old-env sequentialp)
+  (walker-environment-bind (new-env old-env)
+    (let* ((let/let* (car form))
+	   (bindings (cadr form))
+	   (body (cddr form))
+	   (walked-bindings 
+	     (walk-bindings-1 bindings
+			      old-env
+			      new-env
+			      context
+			      sequentialp))
+	   (walked-body
+	     (walk-declarations body #'walk-repeat-eval new-env)))
+      (relist*
+	form let/let* walked-bindings walked-body))))
+
+(defun walk-prog/prog* (form context old-env sequentialp)
+  (walker-environment-bind (new-env old-env)
+    (let* ((let/let* (car form))
+	   (bindings (cadr form))
+	   (body (cddr form))
+	   (walked-bindings 
+	     (walk-bindings-1 bindings
+			      old-env
+			      new-env
+			      context
+			      sequentialp))
+	   (walked-body
+	     (walk-declarations 
+	       body
+	       #'(lambda (real-body real-env)
+		   (walk-tagbody-1 real-body context real-env))
+	       new-env)))
+      (relist*
+	form let/let* walked-bindings walked-body))))
+
+(defun walk-do/do* (form context old-env sequentialp)
+  (walker-environment-bind (new-env old-env)
+    (let* ((do/do* (car form))
+	   (bindings (cadr form))
+	   (end-test (caddr form))
+	   (body (cdddr form))
+	   (walked-bindings (walk-bindings-1 bindings
+					     old-env
+					     new-env
+					     context
+					     sequentialp))
+	   (walked-body
+	     (walk-declarations body #'walk-repeat-eval new-env)))
+      (relist* form
+	       do/do*
+	       (walk-bindings-2 bindings walked-bindings context new-env)
+	       (walk-template end-test '(test repeat (eval)) context new-env)
+	       walked-body))))
+
+(defun walk-let-if (form context env)
+  (let ((test (cadr form))
+	(bindings (caddr form))
+	(body (cdddr form)))
+    (walk-form-internal
+      `(let ()
+	 (declare (special ,@(mapcar #'(lambda (x) (if (listp x) (car x) x))
+				     bindings)))
+	 (flet ((.let-if-dummy. () ,@body))
+	   (if ,test
+	       (let ,bindings (.let-if-dummy.))
+	       (.let-if-dummy.))))
+      context
+      env)))
+
+(defun walk-multiple-value-bind (form context old-env)
+  (walker-environment-bind (new-env old-env)
+    (let* ((mvb (car form))
+	   (bindings (cadr form))
+	   (mv-form (walk-template (caddr form) 'eval context old-env))
+	   (body (cdddr form))
+	   walked-bindings
+	   (walked-body
+	     (walk-declarations 
+	       body
+	       #'(lambda (real-body real-env)
+		   (setq walked-bindings
+			 (walk-bindings-1 bindings
+					  old-env
+					  new-env
+					  context
+					  nil))
+		   (walk-repeat-eval real-body real-env))
+	       new-env)))
+      (relist* form mvb walked-bindings mv-form walked-body))))
+
+(defun walk-bindings-1 (bindings old-env new-env context sequentialp)
+  (and bindings
+       (let ((binding (car bindings)))
+         (recons bindings
+                 (if (symbolp binding)
+                     (prog1 binding
+                            (note-lexical-binding binding new-env))
+                     (prog1 (relist* binding
+				     (car binding)
+				     (walk-form-internal (cadr binding)
+							 context
+							 (if sequentialp
+							     new-env
+							     old-env))
+				     (cddr binding))	;save cddr for DO/DO*
+						        ;it is the next value
+						        ;form. Don't walk it
+						        ;now though.
+                            (note-lexical-binding (car binding) new-env)))
+                 (walk-bindings-1 (cdr bindings)
+				  old-env
+				  new-env
+				  context
+				  sequentialp)))))
+
+(defun walk-bindings-2 (bindings walked-bindings context env)
+  (and bindings
+       (let ((binding (car bindings))
+             (walked-binding (car walked-bindings)))
+         (recons bindings
+		 (if (symbolp binding)
+		     binding
+		     (relist* binding
+			      (car walked-binding)
+			      (cadr walked-binding)
+			      (walk-template (cddr binding)
+					     '(eval)
+					     context
+					     env)))		 
+                 (walk-bindings-2 (cdr bindings)
+				  (cdr walked-bindings)
+				  context
+				  env)))))
+
+(defun walk-lambda (form context old-env)
+  (walker-environment-bind (new-env old-env)
+    (let* ((arglist (cadr form))
+           (body (cddr form))
+           (walked-arglist (walk-arglist arglist context new-env))
+           (walked-body
+             (walk-declarations body #'walk-repeat-eval new-env)))
+      (relist* form
+               (car form)
+	       walked-arglist
+               walked-body))))
+
+(defun walk-named-lambda (form context old-env)
+  (walker-environment-bind (new-env old-env)
+    (let* ((name (cadr form))
+	   (arglist (caddr form))
+           (body (cdddr form))
+           (walked-arglist (walk-arglist arglist context new-env))
+           (walked-body
+             (walk-declarations body #'walk-repeat-eval new-env)))
+      (relist* form
+               (car form)
+	       name
+	       walked-arglist
+               walked-body))))  
+
+(defun walk-tagbody (form context env)
+  (recons form (car form) (walk-tagbody-1 (cdr form) context env)))
+
+(defun walk-tagbody-1 (form context env)
+  (and form
+       (recons form
+               (walk-form-internal (car form)
+				   (if (symbolp (car form)) 'quote context)
+				   env)
+               (walk-tagbody-1 (cdr form) context env))))
+
+(defun walk-compiler-let (form context old-env)
+  (declare (ignore context))
+  (let ((vars ())
+	(vals ()))
+    (dolist (binding (cadr form))
+      (cond ((symbolp binding) (push binding vars) (push nil vals))
+	    (t
+	     (push (car binding) vars)
+	     (push (eval (cadr binding)) vals))))
+    (relist* form
+	     (car form)
+	     (cadr form)
+	     (progv vars vals (walk-repeat-eval (cddr form) old-env)))))
+
+(defun walk-macrolet (form context old-env)
+  (walker-environment-bind (macro-env
+			    nil
+			    :walk-function (env-walk-function old-env))
+    (labels ((walk-definitions (definitions)
+	       (and definitions
+		    (let ((definition (car definitions)))
+		      (recons definitions
+                              (relist* definition
+                                       (car definition)
+                                       (walk-arglist (cadr definition)
+						     context
+						     macro-env
+						     t)
+                                       (walk-declarations (cddr definition)
+							  #'walk-repeat-eval
+							  macro-env))
+			      (walk-definitions (cdr definitions)))))))
+      (with-new-definition-in-environment (new-env old-env form)
+	(relist* form
+		 (car form)
+		 (walk-definitions (cadr form))
+		 (walk-declarations (cddr form)
+				    #'walk-repeat-eval
+				    new-env))))))
+
+(defun walk-flet (form context old-env)
+  (labels ((walk-definitions (definitions)
+	     (if (null definitions)
+		 ()
+		 (recons definitions
+			 (walk-lambda (car definitions) context old-env)
+			 (walk-definitions (cdr definitions))))))
+    (recons form
+	    (car form)
+	    (recons (cdr form)
+		    (walk-definitions (cadr form))
+		    (with-new-definition-in-environment (new-env old-env form)
+		      (walk-declarations (cddr form)
+					 #'walk-repeat-eval
+					 new-env))))))
+
+(defun walk-labels (form context old-env)
+  (with-new-definition-in-environment (new-env old-env form)
+    (labels ((walk-definitions (definitions)
+	       (if (null definitions)
+		   ()
+		   (recons definitions
+			   (walk-lambda (car definitions) context new-env)
+			   (walk-definitions (cdr definitions))))))
+      (recons form
+	      (car form)
+	      (recons (cdr form)
+		      (walk-definitions (cadr form))
+		      (walk-declarations (cddr form)
+					 #'walk-repeat-eval
+					 new-env))))))
+
+(defun walk-if (form context env)
+  (let ((predicate (cadr form))
+	(arm1 (caddr form))
+	(arm2 
+	  (if (cddddr form)
+	      (progn
+		(warn "In the form:~%~S~%~
+                       IF only accepts three arguments, you are using ~D.~%~
+                       It is true that some Common Lisps support this, but ~
+                       it is not~%~
+                       truly legal Common Lisp.  For now, this code ~
+                       walker is interpreting ~%~
+                       the extra arguments as extra else clauses. ~
+                       Even if this is what~%~
+                       you intended, you should fix your source code."
+		      form
+		      (length (cdr form)))
+		(cons 'progn (cdddr form)))
+	      (cadddr form))))
+    (relist form
+	    'if
+	    (walk-form-internal predicate context env)
+	    (walk-form-internal arm1 context env)
+	    (walk-form-internal arm2 context env))))
+
+
+;;;
+;;; Tests tests tests
+;;;
+
+#|
+;;; 
+;;; Here are some examples of the kinds of things you should be able to do
+;;; with your implementation of the macroexpansion environment hacking
+;;; mechanism.
+;;; 
+;;; with-lexical-macros is kind of like macrolet, but it only takes names
+;;; of the macros and actual macroexpansion functions to use to macroexpand
+;;; them.  The win about that is that for macros which want to wrap several
+;;; macrolets around their body, they can do this but have the macroexpansion
+;;; functions be compiled.  See the WITH-RPUSH example.
+;;;
+;;; If the implementation had a special way of communicating the augmented
+;;; environment back to the evaluator that would be totally great.  It would
+;;; mean that we could just augment the environment then pass control back
+;;; to the implementations own compiler or interpreter.  We wouldn't have
+;;; to call the actual walker.  That would make this much faster.  Since the
+;;; principal client of this is defmethod it would make compiling defmethods
+;;; faster and that would certainly be a win.
+;;;
+(defmacro with-lexical-macros (macros &body body &environment old-env)
+  (with-augmented-environment (new-env old-env :macros macros)
+    (walk-form (cons 'progn body) :environment new-env)))
+
+(defun expand-rpush (form env)
+  `(push ,(caddr form) ,(cadr form)))
+
+(defmacro with-rpush (&body body)
+  `(with-lexical-macros ,(list (list 'rpush #'expand-rpush)) ,@body))
+
+
+;;;
+;;; Unfortunately, I don't have an automatic tester for the walker.  
+;;; Instead there is this set of test cases with a description of
+;;; how each one should go.
+;;; 
+(defmacro take-it-out-for-a-test-walk (form)
+  `(take-it-out-for-a-test-walk-1 ',form))
+
+(defun take-it-out-for-a-test-walk-1 (form)
+  (terpri)
+  (terpri)
+  (let ((copy-of-form (copy-tree form))
+	(result (walk-form form nil
+		  #'(lambda (x y env)
+		      (format t "~&Form: ~S ~3T Context: ~A" x y)
+		      (when (symbolp x)
+			(let ((lexical (variable-lexical-p x env))
+			      (special (variable-special-p x env)))
+			  (when lexical
+			    (format t ";~3T")
+			    (format t "lexically bound"))
+			  (when special
+			    (format t ";~3T")
+			    (format t "declared special"))
+			  (when (boundp x)
+			    (format t ";~3T")
+			    (format t "bound: ~S " (eval x)))))
+		      x))))
+    (cond ((not (equal result copy-of-form))
+	   (format t "~%Warning: Result not EQUAL to copy of start."))
+	  ((not (eq result form))
+	   (format t "~%Warning: Result not EQ to copy of start.")))
+    (pprint result)
+    result))
+
+(defmacro foo (&rest ignore) ''global-foo)
+
+(defmacro bar (&rest ignore) ''global-bar)
+
+(take-it-out-for-a-test-walk (list arg1 arg2 arg3))
+(take-it-out-for-a-test-walk (list (cons 1 2) (list 3 4 5)))
+
+(take-it-out-for-a-test-walk (progn (foo) (bar 1)))
+
+(take-it-out-for-a-test-walk (block block-name a b c))
+(take-it-out-for-a-test-walk (block block-name (list a) b c))
+
+(take-it-out-for-a-test-walk (catch catch-tag (list a) b c))
+;;;
+;;; This is a fairly simple macrolet case.  While walking the body of the
+;;; macro, x should be lexically bound. In the body of the macrolet form
+;;; itself, x should not be bound.
+;;; 
+(take-it-out-for-a-test-walk
+  (macrolet ((foo (x) (list x) ''inner))
+    x
+    (foo 1)))
+
+;;;
+;;; A slightly more complex macrolet case.  In the body of the macro x
+;;; should not be lexically bound.  In the body of the macrolet form itself
+;;; x should be bound.  Note that THIS CASE WILL CAUSE AN ERROR when it
+;;; tries to macroexpand the call to foo.
+;;; 
+(take-it-out-for-a-test-walk
+     (let ((x 1))
+       (macrolet ((foo () (list x) ''inner))
+	 x
+	 (foo))))
+
+;;;
+;;; A truly hairy use of compiler-let and macrolet.  In the body of the
+;;; macro x should not be lexically bound.  In the body of the macrolet
+;;; itself x should not be lexically bound.  But the macro should expand
+;;; into 1.
+;;; 
+(take-it-out-for-a-test-walk
+  (compiler-let ((x 1))
+    (let ((x 2))
+      (macrolet ((foo () x))
+	x
+	(foo)))))
+
+
+(take-it-out-for-a-test-walk
+  (flet ((foo (x) (list x y))
+	 (bar (x) (list x y)))
+    (foo 1)))
+
+(take-it-out-for-a-test-walk
+  (let ((y 2))
+    (flet ((foo (x) (list x y))
+	   (bar (x) (list x y)))
+      (foo 1))))
+
+(take-it-out-for-a-test-walk
+  (labels ((foo (x) (bar x))
+	   (bar (x) (foo x)))
+    (foo 1)))
+
+(take-it-out-for-a-test-walk
+  (flet ((foo (x) (foo x)))
+    (foo 1)))
+
+(take-it-out-for-a-test-walk
+  (flet ((foo (x) (foo x)))
+    (flet ((bar (x) (foo x)))
+      (bar 1))))
+
+(take-it-out-for-a-test-walk (compiler-let ((a 1) (b 2)) (foo a) b))
+(take-it-out-for-a-test-walk (prog () (declare (special a b))))
+(take-it-out-for-a-test-walk (let (a b c)
+                               (declare (special a b))
+                               (foo a) b c))
+(take-it-out-for-a-test-walk (let (a b c)
+                               (declare (special a) (special b))
+                               (foo a) b c))
+(take-it-out-for-a-test-walk (let (a b c)
+                               (declare (special a))
+                               (declare (special b))
+                               (foo a) b c))
+(take-it-out-for-a-test-walk (let (a b c)
+                               (declare (special a))
+                               (declare (special b))
+                               (let ((a 1))
+                                 (foo a) b c)))
+(take-it-out-for-a-test-walk (eval-when ()
+                               a
+                               (foo a)))
+(take-it-out-for-a-test-walk (eval-when (eval when load)
+                               a
+                               (foo a)))
+
+(take-it-out-for-a-test-walk (multiple-value-bind (a b) (foo a b) (list a b)))
+(take-it-out-for-a-test-walk (multiple-value-bind (a b)
+				 (foo a b)
+			       (declare (special a))
+			       (list a b)))
+(take-it-out-for-a-test-walk (progn (function foo)))
+(take-it-out-for-a-test-walk (progn a b (go a)))
+(take-it-out-for-a-test-walk (if a b c))
+(take-it-out-for-a-test-walk (if a b))
+(take-it-out-for-a-test-walk ((lambda (a b) (list a b)) 1 2))
+(take-it-out-for-a-test-walk ((lambda (a b) (declare (special a)) (list a b))
+			      1 2))
+(take-it-out-for-a-test-walk (let ((a a) (b a) (c b)) (list a b c)))
+(take-it-out-for-a-test-walk (let* ((a a) (b a) (c b)) (list a b c)))
+(take-it-out-for-a-test-walk (let ((a a) (b a) (c b))
+                               (declare (special a b))
+                               (list a b c)))
+(take-it-out-for-a-test-walk (let* ((a a) (b a) (c b))
+                               (declare (special a b))
+                               (list a b c)))
+(take-it-out-for-a-test-walk (let ((a 1) (b 2))
+                               (foo bar)
+                               (declare (special a))
+                               (foo a b)))
+(take-it-out-for-a-test-walk (multiple-value-call #'foo a b c))
+(take-it-out-for-a-test-walk (multiple-value-prog1 a b c))
+(take-it-out-for-a-test-walk (progn a b c))
+(take-it-out-for-a-test-walk (progv vars vals a b c))
+(take-it-out-for-a-test-walk (quote a))
+(take-it-out-for-a-test-walk (return-from block-name a b c))
+(take-it-out-for-a-test-walk (setq a 1))
+(take-it-out-for-a-test-walk (setq a (foo 1) b (bar 2) c 3))
+(take-it-out-for-a-test-walk (tagbody a b c (go a)))
+(take-it-out-for-a-test-walk (the foo (foo-form a b c)))
+(take-it-out-for-a-test-walk (throw tag-form a))
+(take-it-out-for-a-test-walk (unwind-protect (foo a b) d e f))
+
+(defmacro flet-1 (a b) ''outer)
+(defmacro labels-1 (a b) ''outer)
+
+(take-it-out-for-a-test-walk
+  (flet ((flet-1 (a b) () (flet-1 a b) (list a b)))
+    (flet-1 1 2)
+    (foo 1 2)))
+(take-it-out-for-a-test-walk
+  (labels ((label-1 (a b) () (label-1 a b)(list a b)))
+    (label-1 1 2)
+    (foo 1 2)))
+(take-it-out-for-a-test-walk (macrolet ((macrolet-1 (a b) (list a b)))
+                               (macrolet-1 a b)
+                               (foo 1 2)))
+
+(take-it-out-for-a-test-walk (macrolet ((foo (a) `(inner-foo-expanded ,a)))
+                               (foo 1)))
+
+(take-it-out-for-a-test-walk (progn (bar 1)
+                                    (macrolet ((bar (a)
+						 `(inner-bar-expanded ,a)))
+                                      (bar 2))))
+
+(take-it-out-for-a-test-walk (progn (bar 1)
+                                    (macrolet ((bar (s)
+						 (bar s)
+						 `(inner-bar-expanded ,s)))
+                                      (bar 2))))
+
+(take-it-out-for-a-test-walk (cond (a b)
+                                   ((foo bar) a (foo a))))
+
+
+(let ((the-lexical-variables ()))
+  (walk-form '(let ((a 1) (b 2))
+		#'(lambda (x) (list a b x y)))
+	     ()
+	     #'(lambda (form context env)
+		 (when (and (symbolp form)
+			    (variable-lexical-p form env))
+		   (push form the-lexical-variables))
+		 form))
+  (or (and (= (length the-lexical-variables) 3)
+	   (member 'a the-lexical-variables)
+	   (member 'b the-lexical-variables)
+	   (member 'x the-lexical-variables))
+      (error "Walker didn't do lexical variables of a closure properly.")))
+    
+|#
+
+()
diff --git a/pcl/xerox-low.lisp b/pcl/xerox-low.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..37094bdb22f01b5426a8be8f9247a3f0c6967b66
--- /dev/null
+++ b/pcl/xerox-low.lisp
@@ -0,0 +1,172 @@
+;;; -*- Mode:LISP; Package:(PCL Lisp 1000); Base:10.; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+;;; This is the 1100 (Xerox version) of the file portable-low.
+;;;
+
+(in-package 'pcl)
+
+(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.
+;;; 
+#+Xerox-Medley
+(defstruct (std-instance (:predicate std-instance-p)
+			 (:conc-name %std-instance-)
+			 (:constructor %%allocate-instance--class ())
+			 (:fast-accessors t)
+			 (:print-function %print-std-instance))
+  (wrapper nil :type il:fullxpointer)
+  (slots nil))
+
+#+Xerox-Lyric
+(eval-when (eval load compile)
+  (il:datatype std-instance
+	       ((wrapper il:fullxpointer)
+	        slots))
+
+  (xcl:definline std-instance-p (x)
+    (typep x 'std-instance))
+  
+  (xcl:definline %%allocate-instance--class ()
+    (il:create std-instance))
+
+  (xcl:definline %std-instance-wrapper (x) 
+    (il:fetch (std-instance wrapper) il:of x))
+
+  (xcl:definline %std-instance-slots (x) 
+    (il:fetch (std-instance slots) il:of x))
+
+  (xcl:definline set-%std-instance-wrapper (x value) 
+    (il:replace (std-instance wrapper) il:of x il:with value))
+
+  (xcl:definline set-%std-instance-slots (x value) 
+    (il:replace (std-instance slots) il:of x il:with value))
+
+  (defsetf %std-instance-wrapper set-%std-instance-wrapper)
+
+  (defsetf %std-instance-slots set-%std-instance-slots)
+
+  (il:defprint 'std-instance '%print-std-instance)
+
+  )
+
+(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 PCL 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))
+  ())
+
+
+;;;
+;;; 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)
diff --git a/pcl/xerox-patches.lisp b/pcl/xerox-patches.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..3294e69050b206a86559c26b28434e4f77c2c833
--- /dev/null
+++ b/pcl/xerox-patches.lisp
@@ -0,0 +1,247 @@
+;;; -*- Mode: Lisp; Package: XCL-USER; Base: 10.; Syntax: Common-Lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+;;;
+
+(in-package "XCL-USER")
+
+
+;;; Patch a bug with Lambda-substitution
+
+#+Xerox-Lyric
+(defun compiler::meta-call-lambda-substitute (node)
+  (let* ((fn (compiler::call-fn node))
+	 (var-list (compiler::lambda-required fn))
+	 (spec-effects
+	  (il:for var il:in var-list
+	      il:unless (eq (compiler::variable-scope var) :lexical)
+	      il:collect (compiler::effects-representation var)))
+	 ;; Bind *SUBST-OCCURED* just so that META-SUBST-VAR-REF ahs a binding
+	 ;; to set even when nobody cares.
+	 (compiler::*subst-occurred* nil))
+    (il:for var il:in var-list
+      il:as tail il:on (compiler::call-args node)
+      il:when
+	(and (eq (compiler::variable-scope var) :lexical)
+	     (compiler::substitutable-p (car tail) var)
+	     (dolist (compiler::spec-effect spec-effects t)
+	       (when
+		   (not (compiler::null-effects-intersection compiler::spec-effect
+							     (compiler::node-affected (car tail))))
+		 (return nil)))
+	     (dolist (compiler::later-arg (cdr tail) t)
+	       (when (not (compiler::passable (car tail) compiler::later-arg))
+		 (return nil))))
+	il:do
+	  (setf (compiler::lambda-body fn)
+		(compiler::meta-substitute (car tail) var
+					   (compiler::lambda-body fn))))
+    (when (null (compiler::node-meta-p (compiler::lambda-body fn)))
+      (setf (compiler::node-meta-p fn) nil)
+      (setq compiler::*made-changes* t))))
+
+;;; Some simple optimizations missing from the compiler.
+
+
+;; Shift by a constant.
+
+;; Unfortunately, these cause the compiler to generate spurious warning
+;; messages about "Unknown function IL:LLSH1 called from ..."  It's not often
+;; you come across a place where COMPILER-LET is really needed.
+
+#+Xerox-Lyric
+(progn
+
+(defvar *ignore-shift-by-constant-optimization* nil
+  "Marker used for informing the shift-by-constant optimizers that they are in
+ the shift function, and should not optimize.")
+
+(defun il:lrsh1 (x)
+  (compiler-let ((*ignore-shift-by-constant-optimization* t))
+    (il:lrsh x 1)))
+
+(defun il:lrsh8 (x)
+  (compiler-let ((*ignore-shift-by-constant-optimization* t))
+    (il:lrsh x 8)))
+
+(defun il:llsh1 (x)
+  (compiler-let ((*ignore-shift-by-constant-optimization* t))
+    (il:llsh x 1)))
+
+(defun il:llsh8 (x)
+  (compiler-let ((*ignore-shift-by-constant-optimization* t))
+    (il:llsh x 8)))
+
+(defoptimizer il:lrsh il:right-shift-by-constant (x n &environment env)
+  (if (and (constantp n)
+	   (not *ignore-shift-by-constant-optimization*))
+      (let ((shift-factor (eval n)))
+	(cond
+	  ((not (numberp shift-factor))
+	   (error "Non-numeric arg to ~S, ~S" 'il:lrsh shift-factor))
+	  ((= shift-factor 0)
+	   x)
+	  ((< shift-factor 0)
+	   `(il:llsh ,x ,(- shift-factor)))
+	  ((< shift-factor 8)
+	   `(il:lrsh (il:lrsh1 ,x) ,(1- shift-factor)))
+	  (t `(il:lrsh (il:lrsh8 ,x) ,(- shift-factor 8)))))
+      'compiler:pass))
+
+(defoptimizer il:llsh il:left-shift-by-constant (x n &environment env)
+  (if (and (constantp n)
+	   (not *ignore-shift-by-constant-optimization*))
+      (let ((shift-factor (eval n)))
+	(cond
+	  ((not (numberp shift-factor))
+	   (error "Non-numeric arg to ~S, ~S" 'il:llsh shift-factor))
+	  ((= shift-factor 0)
+	   x)
+	  ((< shift-factor 0)
+	   `(il:lrsh ,x ,(- shift-factor)))
+	  ((< shift-factor 8)
+	   `(il:llsh (il:llsh1 ,x) ,(1- shift-factor)))
+	  (t `(il:llsh (il:llsh8 ,x) ,(- shift-factor 8)))))
+      'compiler:pass))
+
+)
+
+
+;; Simple TYPEP optimiziation
+
+#+Xerox-Lyric
+(defoptimizer typep type-t-test (object type)
+  "Everything is of type T"
+  (if (and (constantp type) (eq (eval type) t))
+      `(progn ,object t)
+      'compiler:pass))
+
+;;; 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.
+
+#+Xerox-Lyric
+(progn
+
+(il:putprops cl::%+ compiler::side-effects-data (:none . :none))
+(il:putprops cl::%- compiler::side-effects-data (:none . :none))
+(il:putprops cl::%* compiler::side-effects-data (:none . :none))
+(il:putprops cl::%/ compiler::side-effects-data (:none . :none))
+(il:putprops cl::%logior compiler::side-effects-data (:none . :none))
+(il:putprops cl::%logeqv compiler::side-effects-data (:none . :none))
+(il:putprops cl::%= compiler::side-effects-data (:none . :none))
+(il:putprops cl::%> compiler::side-effects-data (:none . :none))
+(il:putprops cl::%< compiler::side-effects-data (:none . :none))
+(il:putprops cl::%>= compiler::side-effects-data (:none . :none))
+(il:putprops cl::%<= compiler::side-effects-data (:none . :none))
+(il:putprops cl::%/= compiler::side-effects-data (:none . :none))
+(il:putprops il:lrsh1 compiler::side-effects-data (:none . :none))
+(il:putprops il:lrsh8 compiler::side-effects-data (:none . :none))
+(il:putprops il:llsh1 compiler::side-effects-data (:none . :none))
+(il:putprops il:llsh8 compiler::side-effects-data (:none . :none))
+
+)
+
+;;; Fix a nit in the compiler
+#+Xerox-Lyric
+(progn
+
+(il:unadvise 'compile)
+(il:advise 'compile ':around '(let (compiler::*input-stream*) (inner)))
+
+)
+
+;;; 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))
+
+(xcl:defoptimizer logior optimize-logical-op-1-arg)
+(xcl:defoptimizer logxor optimize-logical-op-1-arg)
+(xcl:defoptimizer logand optimize-logical-op-1-arg)
+(xcl:defoptimizer logeqv optimize-logical-op-1-arg)
+
+
+#+Xerox-Medley
+
+;; A bug compiling LABELS
+
+(defun compiler::meta-call-labels (compiler::node compiler:context)
+  ;; 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))
+    ;; 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))
+	  ;; 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*)
+	    ;; 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* ;Found it, we can stop now.
+		  (setf (compiler::node-meta-p compiler::node) nil)
+		  (setq compiler::*made-changes* t) (return)))))
+	  ;; 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))))
+    ;; 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)))))
+    ;; 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)))
+    ;; 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)