diff --git a/pcl/RCSSNAP.last-merge b/pcl/RCSSNAP.last-merge
deleted file mode 100644
index f52f08ee4a4ec46f50b650267a124a501deda53f..0000000000000000000000000000000000000000
--- a/pcl/RCSSNAP.last-merge
+++ /dev/null
@@ -1,84 +0,0 @@
-./RCS/12-7-88-notes.text,v	1.1
-./RCS/3-17-88-notes.text,v	1.1
-./RCS/3-19-87-notes.text,v	1.1
-./RCS/4-21-87-notes.text,v	1.1
-./RCS/4-29-87-notes.text,v	1.1
-./RCS/5-22-87-notes.text,v	1.1
-./RCS/5-22-89-notes.text,v	1.1
-./RCS/8-28-88-notes.text,v	1.1
-./RCS/boot.lisp,v	1.3
-./RCS/braid.lisp,v	1.2
-./RCS/cache.lisp,v	1.2
-./RCS/cloe-low.lisp,v	1.1
-./RCS/cmu-low.lisp,v	1.6
-./RCS/cmu-low.pmaxf,v	1.1
-./RCS/combin.lisp,v	1.2
-./RCS/combin.pmaxf,v	1.1
-./RCS/compat.lisp,v	1.2
-./RCS/compat.pmaxf,v	1.1
-./RCS/construct.lisp,v	1.3
-./RCS/construct.pmaxf,v	1.1
-./RCS/coral-low.lisp,v	1.2
-./RCS/cpatch.lisp,v	1.2
-./RCS/cpl.lisp,v	1.2
-./RCS/cpl.pmaxf,v	1.1
-./RCS/ctypes.lisp,v	1.2
-./RCS/ctypes.pmaxf,v	1.1
-./RCS/defclass.lisp,v	1.5
-./RCS/defcombin.lisp,v	1.2
-./RCS/defs.lisp,v	1.4
-./RCS/defsys.lisp,v	1.4
-./RCS/dfun.lisp,v	1.2
-./RCS/dlap.lisp,v	1.2
-./RCS/env.lisp,v	1.3
-./RCS/excl-low.lisp,v	1.2
-./RCS/fin.lisp,v	1.5
-./RCS/fixup.lisp,v	1.2
-./RCS/fngen.lisp,v	1.2
-./RCS/fsc.lisp,v	1.2
-./RCS/gcl-patches.lisp,v	1.2
-./RCS/genera-low.lisp,v	1.2
-./RCS/get-pcl.text,v	1.2
-./RCS/gold-low.lisp,v	1.2
-./RCS/hp-low.lisp,v	1.2
-./RCS/ibcl-low.lisp,v	1.2
-./RCS/ibcl-patches.lisp,v	1.2
-./RCS/init.lisp,v	1.2
-./RCS/iterate.lisp,v	1.2
-./RCS/kcl-low.lisp,v	1.2
-./RCS/kcl-mods.text,v	1.2
-./RCS/kcl-notes.text,v	1.1
-./RCS/kcl-patches.lisp,v	1.2
-./RCS/lap.lisp,v	1.3
-./RCS/lap.text,v	1.2
-./RCS/low.lisp,v	1.2
-./RCS/lucid-low.lisp,v	1.2
-./RCS/macros.lisp,v	1.2
-./RCS/methods.lisp,v	1.2
-./RCS/notes.text,v	1.1
-./RCS/pcl-env-internal.lisp,v	1.2
-./RCS/pcl-env.lisp,v	1.2
-./RCS/pcl-env.text,v	1.2
-./RCS/pclcom.lisp,v	1.1
-./RCS/pclload.lisp,v	1.2
-./RCS/pkg.lisp,v	1.3
-./RCS/plap.lisp,v	1.4
-./RCS/precom1.lisp,v	1.2
-./RCS/precom2.lisp,v	1.2
-./RCS/precom4.lisp,v	1.2
-./RCS/pyr-low.lisp,v	1.2
-./RCS/pyr-patches.lisp,v	1.2
-./RCS/quadlap.lisp,v	1.2
-./RCS/readme.text,v	1.2
-./RCS/rel-7-2-patches.lisp,v	1.2
-./RCS/rel-8-patches.lisp,v	1.1
-./RCS/slots.lisp,v	1.2
-./RCS/std-class.lisp,v	1.2
-./RCS/sysdef.lisp,v	1.1
-./RCS/ti-low.lisp,v	1.2
-./RCS/ti-patches.lisp,v	1.2
-./RCS/vaxl-low.lisp,v	1.2
-./RCS/vector.lisp,v	1.2
-./RCS/walk.lisp,v	1.5
-./RCS/xerox-low.lisp,v	1.2
-./RCS/xerox-patches.lisp,v	1.2
diff --git a/pcl/boot.lisp b/pcl/boot.lisp
index 41686b1c1c456cae485b4ef5ec504537614cb227..ebf6f0c76e9c60b1bbbe85030ece964aa4fc923e 100644
--- a/pcl/boot.lisp
+++ b/pcl/boot.lisp
@@ -26,7 +26,7 @@
 ;;;
 #+cmu
 (ext:file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/boot.lisp,v 1.17 1998/10/22 00:32:30 dtc Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/boot.lisp,v 1.18 1999/03/11 16:51:01 pw Exp $")
 
 (in-package :pcl)
 
@@ -242,7 +242,6 @@ work during bootstrapping.
 ;;;
 ;;;
 (defmacro DEFMETHOD (&rest args &environment env)
-  #+(or (not :lucid) :lcl3.0)	
   (declare (arglist name
 		    {method-qualifier}*
 		    specialized-lambda-list
@@ -622,7 +621,6 @@ work during bootstrapping.
 #+cmu
 (declaim (ext:freeze-type fast-method-call))
 
-#-akcl
 (defmacro fmc-funcall (fn pv-cell next-method-call &rest args)
   `(funcall ,fn ,pv-cell ,next-method-call ,@args))
 
@@ -853,8 +851,6 @@ work during bootstrapping.
 	 `(call-next-method-bind
 	    (flet (,@(and call-next-method-p
 		       '((call-next-method (&rest cnm-args)
-			  #+Genera
-			  (declare (dbg:invisible-frame :clos-internal))
 			  #+copy-&rest-arg (setq args (copy-list args))
 			  (call-next-method-body cnm-args))))
 		     ,@(and next-method-p-p
@@ -863,9 +859,6 @@ work during bootstrapping.
 	      ,@body)))))
 
 (defmacro bind-args ((lambda-list args) &body body)
-  #|| ; Lucid and Allegro don't compile the function inline
-  `(apply #'(lambda ,lambda-list ,@body) ,args)
-  ||#
   (let ((args-tail '.args-tail.)
 	(key '.key.)
 	(state 'required))
@@ -1054,7 +1047,7 @@ work during bootstrapping.
 	  *mf1p* (gethash method-function *method-function-plist*)))
   *mf1p*)
 
-(defun #-setf SETF\ PCL\ METHOD-FUNCTION-PLIST #+setf (setf method-function-plist)
+(defun (setf method-function-plist)
        (val method-function)
   (unless (eq method-function *mf1*)
     (rotatef *mf1* *mf2*)
@@ -1069,7 +1062,7 @@ work during bootstrapping.
 (defun method-function-get (method-function key &optional default)
   (getf (method-function-plist method-function) key default))
 
-(defun #-setf SETF\ PCL\ METHOD-FUNCTION-GET #+setf (setf method-function-get)
+(defun (setf method-function-get)
        (val method-function key)
   (setf (getf (method-function-plist method-function) key) val))
 
@@ -1251,7 +1244,7 @@ work during bootstrapping.
 	(decl `(ftype ,(ftype-declaration-from-lambda-list lambda-list #+cmu spec)
 		      ,spec)))
     #+cmu (proclaim decl)
-    #+kcl (setf (get spec 'compiler::proclaimed-closure) t)))
+   ))
 
 ;;;; Early generic-function support
 ;;;
@@ -1274,7 +1267,6 @@ work during bootstrapping.
 	       existing function-specifier all-keys))))
 
 (defun generic-clobbers-function (function-specifier)
-  #+Lispm (zl:signal 'generic-clobbers-function :name function-specifier)
   #+cmu
   (error 'kernel:simple-program-error
 	 :format-control
@@ -1284,7 +1276,7 @@ work during bootstrapping.
 	  definition.~%~
 	  The PCL-specific function MAKE-SPECIALIZABLE may be useful to you."
 	 :format-arguments (list function-specifier))
-  #-(or lispm cmu)
+  #-(or cmu)
   (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~%~
@@ -1292,32 +1284,6 @@ work during bootstrapping.
 	  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 #+Genera (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")))
-
-#+Genera
-(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))
-
 (defvar *sgf-wrapper* 
   (boot-make-wrapper (early-class-size 'standard-generic-function)
 		     'standard-generic-function))
@@ -2111,64 +2077,6 @@ work during bootstrapping.
 (eval-when (load eval)
   (setq *boot-state* 'early))
 
-
-#-cmu ;; CMUCL Has a real symbol-macrolet
-(progn
-(defmacro symbol-macrolet (bindings &body body &environment env)
-  (let ((specs (mapcar #'(lambda (binding)
-			   (list (car binding)
-				 (variable-lexical-p (car binding) env)
-				 (cadr binding)))
-		       bindings)))
-    (walk-form `(progn ,@body)
-	       env
-	       #'(lambda (f c e)
-		   (expand-symbol-macrolet-internal specs f c e)))))
-
-(defun expand-symbol-macrolet-internal (specs form context env)
-  (let ((entry nil))
-    (cond ((not (eq context :eval)) form)
-	  ((symbolp form)
-	   (if (and (setq entry (assoc form specs))
-		    (eq (cadr entry) (variable-lexical-p form env)))
-	       (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)
-					 (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))))
-)
-
 (defmacro with-slots (slots instance &body body)
   (let ((in (gensym)))
     `(let ((,in ,instance))
diff --git a/pcl/cache.lisp b/pcl/cache.lisp
index f90160ff2181e6b44b039d9cea321439e426f57d..9a0751d05320c5d93efc1b1a05d2c6526cf4c169 100644
--- a/pcl/cache.lisp
+++ b/pcl/cache.lisp
@@ -26,7 +26,7 @@
 ;;;
 #+cmu
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/cache.lisp,v 1.11 1998/12/20 04:30:16 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/cache.lisp,v 1.12 1999/03/11 16:51:02 pw Exp $")
 ;;;
 ;;; The basics of the PCL wrapper cache mechanism.
 ;;;
@@ -160,9 +160,6 @@
     (format stream "cache ~D ~S ~D" 
 	    (cache-nkeys cache) (cache-valuep cache) (cache-nlines cache))))
 
-#+akcl
-(si::freeze-defstruct 'cache)
-
 (defmacro cache-lock-count (cache)
   `(cache-vector-lock-count (cache-vector ,cache)))
 
@@ -420,7 +417,7 @@
 #+structure-wrapper
 (progn
 
-#-(or new-kcl-wrapper cmu17)
+#-(or cmu17)
 (defun make-wrapper-cache-number-vector ()
   (let ((cnv (make-array #.wrapper-cache-number-vector-length
 			 :element-type 'fixnum)))
@@ -431,34 +428,21 @@
 
 #-cmu17
 (defstruct (wrapper
-	     #+new-kcl-wrapper (:include si::basic-wrapper)
 	     (:print-function print-wrapper)
-	     #-new-kcl-wrapper
-	     (:constructor make-wrapper (no-of-instance-slots &optional class))
-	     #+new-kcl-wrapper
-	     (:constructor make-wrapper-internal))
-  #-new-kcl-wrapper
+	     (:constructor make-wrapper (no-of-instance-slots &optional class)))
   (cache-number-vector (make-wrapper-cache-number-vector)
 		       :type cache-number-vector)
-  #-new-kcl-wrapper
   (state t :type (or (member t) cons)) 
   ;;  either t or a list (state-sym new-wrapper)
   ;;           where state-sym is either :flush or :obsolete
   (instance-slots-layout nil :type list)
   (class-slots nil :type list)
-  #-new-kcl-wrapper
   (no-of-instance-slots 0 :type fixnum)
-  #-new-kcl-wrapper
   (class *the-class-t* :type class))
 
 
 (unless (boundp '*the-class-t*) (setq *the-class-t* nil))
 
-#+new-kcl-wrapper
-(defmacro wrapper-no-of-instance-slots (wrapper)
-  `(si::s-data-length ,wrapper))
-
-
 ;;; Note that for CMU, the WRAPPER of a built-in or structure class will be
 ;;; some other kind of KERNEL:LAYOUT, but this shouldn't matter, since the only
 ;;; two slots that WRAPPER adds are meaningless in those cases.
@@ -505,24 +489,6 @@
     `(%wrapper-class-slots ,wrapper))
   (defmacro wrapper-cache-number-vector (x) x))
 
-
-#+new-kcl-wrapper
-(defun make-wrapper (size &optional class)
-  (multiple-value-bind (raw slot-positions)
-      (if (< size 50)
-	  (values si::*all-t-s-type* si::*standard-slot-positions*)
-	  (values (make-array size :element-type 'unsigned-char)
-		  (let ((array (make-array size :element-type 'unsigned-short)))
-		    (dotimes (i size)
-		      (declare (fixnum i))
-		      (setf (aref array i) (* #.(si::size-of t) i))))))
-    (make-wrapper-internal :length size
-			   :raw raw
-			   :print-function 'print-std-instance
-			   :slot-position slot-positions
-			   :size (* size #.(si::size-of t))
-			   :class class)))
-
 #+cmu17
 ;;; BOOT-MAKE-WRAPPER  --  Interface
 ;;;
@@ -608,7 +574,7 @@
 
 #-cmu17
 (defmacro cache-number-vector-ref (cnv n)
-  `(#-kcl svref #+kcl aref ,cnv ,n))
+  `(svref ,cnv ,n))
 
 #+cmu17
 (defmacro cache-number-vector-ref (cnv n)
@@ -629,13 +595,12 @@
   `(wrapper-no-of-instance-slots (class-wrapper ,class)))
 
 (defmacro wrapper-class* (wrapper)
-  #-(or new-kcl-wrapper cmu17)
+  #-(or cmu17)
   `(wrapper-class ,wrapper)
-  #+(or new-kcl-wrapper cmu17)
+  #+(or cmu17)
   `(let ((wrapper ,wrapper))
      (or (wrapper-class wrapper)
          (find-structure-class
-	  #+new-kcl-wrapper (si::s-data-name wrapper)
 	  #+cmu17 (lisp:class-name (kernel:layout-class wrapper))))))
 
 ;;;
@@ -718,9 +683,6 @@
 			     (std-instance-wrapper ,object))
 			    ((fsc-instance-p ,object)
 			     (fsc-instance-wrapper ,object))
-			    #+new-kcl-wrapper
-			    (t (built-in-wrapper-of ,object))
-			    #-new-kcl-wrapper
 			    (t (wrapper-of ,object)))))
        (if (eq 't (wrapper-state ,owrapper))
 	   ,owrapper
diff --git a/pcl/cloe-low.lisp b/pcl/cloe-low.lisp
deleted file mode 100644
index af7459de3466efc5810634e85c4e1369cb1dff70..0000000000000000000000000000000000000000
--- a/pcl/cloe-low.lisp
+++ /dev/null
@@ -1,32 +0,0 @@
-;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1985, 1986, 1987, 1988 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)
-
-(defmacro object-cache-no (object mask)
-  `(logand (sys::address-of ,object) ,mask))
-
diff --git a/pcl/coral-low.lisp b/pcl/coral-low.lisp
deleted file mode 100644
index 650dd7517ba49abee36e6ce866c2a149dcef0910..0000000000000000000000000000000000000000
--- a/pcl/coral-low.lisp
+++ /dev/null
@@ -1,63 +0,0 @@
-;;;-*-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)))))
-  dfun)
-
diff --git a/pcl/cpatch.lisp b/pcl/cpatch.lisp
deleted file mode 100644
index 23641de54edc5fea9b4e3a6a12ca6844d8a90af8..0000000000000000000000000000000000000000
--- a/pcl/cpatch.lisp
+++ /dev/null
@@ -1,32 +0,0 @@
-;;				-[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/defclass.lisp b/pcl/defclass.lisp
index d6d5126b6f3465905770bacbf06b03277bb0b526..9a50f1f5ced53aa98831d155ca34d41568a1d8dd 100644
--- a/pcl/defclass.lisp
+++ b/pcl/defclass.lisp
@@ -26,7 +26,7 @@
 ;;;
 #+cmu
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defclass.lisp,v 1.13 1999/01/12 17:51:08 pw Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defclass.lisp,v 1.14 1999/03/11 16:51:04 pw Exp $")
 ;;;
 
 (in-package :pcl)
@@ -54,61 +54,13 @@
 		       (capitalize-words (car name) ()) (cdr name))
 	       (format nil "~S" name))))
     (definition-name)
-    #+Genera
-    (progn
-      #-Genera-Release-8
-      (let ((thunk-name (gensym "TOP-LEVEL-FORM")))
-	`(eval-when ,times
-	   (defun ,thunk-name ()
-	     (declare (sys:function-parent
-			,(cond ((listp name)
-				(case (first name)
-				  (defmethod `(method ,@(rest name)))
-				  (otherwise (second name))))
-			       (t name))
-			,(cond ((listp name)
-				(case (first name)
-				  ((defmethod defgeneric) 'defun)
-				  ((defclass) 'defclass)
-				  (otherwise (first name))))
-			       (t 'defun))))
-	     ,form)
-	   (,thunk-name)))
-      #+Genera-Release-8
-      `(compiler-let ((compiler:default-warning-function ',name))
-	 (eval-when ,times
-	   (funcall #'(lambda ()
-			(declare ,(cond ((listp name)
-					 (case (first name)
-					   ((defclass)
-					    `(sys:function-parent ,(second name) defclass))
-					   ((defmethod)
-					    `(sys:function-name (method ,@(rest name))))
-					   ((defgeneric)
-					    `(sys:function-name ,(second name)))
-					   (otherwise
-					     `(sys:function-name ,name))))
-					(t
-					 `(sys:function-name ,name))))
-			,form)))))
-    #+LCL3.0
-    `(compiler-let ((lucid::*compiler-message-string*
-		      (or lucid::*compiler-message-string*
-			  ,(definition-name))))
-       (eval-when ,times ,form))
+
     #+cmu
     (if (member 'compile times)
         `(eval-when ,times ,form)
         form)
-    #+kcl
-    (let* ((*print-pretty* nil)
-           (thunk-name (gensym (definition-name))))
-      (gensym "G") ; set the prefix back to something less confusing.
-      `(eval-when ,times
-         (defun ,thunk-name ()
-           ,form)
-         (,thunk-name)))
-    #-(or Genera LCL3.0 cmu kcl)
+
+    #-(or cmu)
     (make-progn `',name `(eval-when ,times ,form))))
 
 (defun make-progn (&rest forms)
diff --git a/pcl/defs.lisp b/pcl/defs.lisp
index 531874d659671234e436df07d7158c5381c78af4..100a316a470dff04ba5a3f96e7ae432c1b7b9b4c 100644
--- a/pcl/defs.lisp
+++ b/pcl/defs.lisp
@@ -75,23 +75,10 @@
 		       (non-setf-var . non-setf-case)
 		       (setf-var . setf-case))
   (declare (indentation 1 1))
-  #+setf (declare (ignore setf-var setf-case))
+  (declare (ignore setf-var setf-case))
   (once-only (spec)
-    `(cond (#-setf (symbolp ,spec) #+setf t
-	    (let ((,non-setf-var ,spec)) ,@non-setf-case))
-	   #-setf
-	   ((and (listp ,spec)
-		 (eq (car ,spec) 'setf)
-		 (symbolp (cadr ,spec)))
-	    (let ((,setf-var (cadr ,spec))) ,@setf-case))
-	   #-setf
-	   (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)))))
+    `(cond (t
+	    (let ((,non-setf-var ,spec)) ,@non-setf-case)))))
 
 ;;;
 ;;; If symbol names a function which is traced or advised, return the
@@ -99,57 +86,18 @@
 ;;; 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)
-  #+setf (fdefinition symbol)
-  #+kcl (symbol-function
-	  (let ((sym (get symbol 'si::traced)) first-form)
-	    (if (and sym
-		     (consp (symbol-function symbol))
-		     (consp (setq first-form (nth 3 (symbol-function symbol))))
-		     (eq (car first-form) 'si::trace-call))
-		sym
-		symbol)))
-  #-(or Lispm Lucid excl Xerox setf kcl) (symbol-function symbol))
+  (fdefinition symbol))
 
 ;;;
 ;;; If symbol names a function which is traced or advised, redefine
 ;;; the `real' definition without affecting the advise.
 ;;;
 (defun fdefine-carefully (name new-definition)
-  #+Lispm (si:fdefine name new-definition t t)
-  #+Lucid (let ((lucid::*redefinition-action* nil))
-	    (setf (symbol-function name) new-definition))
-  #+excl  (setf (symbol-function name) new-definition)
-  #+xerox (let ((advisedp (member name il:advisedfns :test #'eq))
-                (brokenp (member name 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 name :no-error t)
-            (xcl:unbreak-function name :no-error t)
-            (setf (symbol-function name) new-definition)
-            (when brokenp (xcl:rebreak-function name))
-            (when advisedp (xcl:readvise-function name)))
-  #+(and setf (not cmu)) (setf (fdefinition name) new-definition)
-  #+kcl (setf (symbol-function 
-	       (let ((sym (get name 'si::traced)) first-form)
-		 (if (and sym
-			  (consp (symbol-function name))
-			  (consp (setq first-form
-				       (nth 3 (symbol-function name))))
-			  (eq (car first-form) 'si::trace-call))
-		     sym
-		     name)))
-	      new-definition)
   #+cmu (progn
 	  (c::%%defun name new-definition nil)
 	  (c::note-name-defined name :function)
 	  new-definition)
-  #-(or Lispm Lucid excl Xerox setf kcl cmu)
+  #-(or cmu)
   (setf (symbol-function name) new-definition))
 
 (defun gboundp (spec)
@@ -164,11 +112,10 @@
 
 (defun gdefinition (spec)
   (parse-gspec spec
-    (name (or #-setf (macro-function name)		;??
-	      (unencapsulated-fdefinition name)))
+    (name (or (unencapsulated-fdefinition name)))
     (name (unencapsulated-fdefinition (get-setf-function-name name)))))
 
-(defun #-setf SETF\ PCL\ GDEFINITION #+setf (setf gdefinition) (new-value spec)
+(defun (setf gdefinition) (new-value spec)
   (parse-gspec spec
     (name (fdefine-carefully name new-value))
     (name (fdefine-carefully (get-setf-function-name name) new-value))))
@@ -304,20 +251,6 @@
 (defun make-eql-predicate (eql-object)
   #'(lambda (object) (eql eql-object object)))
 
-#|| ; The argument to satisfies must be a symbol.  
-(deftype class (&optional class)
-  (if class
-      `(satisfies ,(class-predicate class))
-      `(satisfies ,(class-predicate 'class))))
-
-(deftype class-eq (class)
-  `(satisfies ,(make-class-eq-predicate class)))
-||#
-
-#-(or excl cmu17)
-(deftype eql (type-object)
-  `(member ,type-object))
-
 
 ;;; Internal to this file.
 ;;;
@@ -343,24 +276,6 @@
         (t
          (error "~s is not a type" type))))
 
-;;; Not used...
-#+nil
-(defun unparse-type-list (tlist)
-  (mapcar #'unparse-type tlist))
-
-;;; Not used...
-#+nil
-(defun unparse-type (type)
-  (if (atom type)
-      (if (specializerp type)
-          (unparse-type (specializer-type type))
-          type)
-      (case (car type)
-        (eql type)
-        (class-eq `(class-eq ,(class-name (cadr type))))
-        (class (class-name (cadr type)))
-        (t `(,(car type) ,@(unparse-type-list (cdr type)))))))
-
 ;;; internal to this file...
 (defun convert-to-system-type (type)
   (case (car type)
@@ -374,17 +289,6 @@
 	   (car type)
 	   type))))
 
-;;; not used...
-#+nil
-(defun *typep (object type)
-  (setq type (*normalize-type type))
-  (cond ((member (car type) '(eql wrapper-eq class-eq class))
-         (specializer-applicable-using-type-p type `(eql ,object)))
-        ((eq (car type) 'not)
-         (not (*typep object (cadr type))))
-        (t
-         (typep object (convert-to-system-type type)))))
-
 
 ;;; *SUBTYPEP  --  Interface
 ;;;
@@ -418,23 +322,7 @@
 
 (defun do-satisfies-deftype (name predicate)
   #+cmu17 (declare (ignore name predicate))
-  #+(or :Genera (and :Lucid (not :Prime)) ExCL :coral)
-  (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)))
-  #-(or :Genera (and :Lucid (not :Prime)) ExCL :coral cmu17)
+  #-(or cmu17)
   ;; 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
@@ -526,7 +414,7 @@
 (defun plist-value (object name)
   (getf (object-plist object) name))
 
-(defun #-setf SETF\ PCL\ PLIST-VALUE #+setf (setf plist-value) (new-value object name)
+(defun (setf plist-value) (new-value object name)
   (if new-value
       (setf (getf (object-plist object) name) new-value)
       (progn
@@ -636,7 +524,7 @@
 (defclass structure-object (slot-object #+cmu17 kernel:instance) ()
   (:metaclass structure-class))
 
-(defstruct (#-cmu17 structure-object #+cmu17 dead-beef-structure-object
+(defstruct (dead-beef-structure-object
 	     (:constructor |STRUCTURE-OBJECT class constructor|)))
 
 
diff --git a/pcl/defsys.lisp b/pcl/defsys.lisp
index b76cafb40536e13f67e3e67ec9810d96fbf53f05..74163c75258d3ae2c982e8282606a5da2c855282 100644
--- a/pcl/defsys.lisp
+++ b/pcl/defsys.lisp
@@ -26,7 +26,7 @@
 ;;;
 #+cmu
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defsys.lisp,v 1.18 1998/12/20 04:30:18 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defsys.lisp,v 1.19 1999/03/11 16:51:05 pw Exp $")
 ;;;
 ;;; 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
@@ -145,33 +145,7 @@ and load your system with:
 ;;; the way they work.
 ;;; 
 (defvar *port*
-        '(#+Genera               Genera
-;         #+Genera-Release-6     Rel-6
-;         #+Genera-Release-7-1   Rel-7
-          #+Genera-Release-7-2   Rel-7
-	  #+Genera-Release-7-3   Rel-7
-          #+Genera-Release-7-1   Rel-7-1
-          #+Genera-Release-7-2   Rel-7-2
-	  #+Genera-Release-7-3   Rel-7-2	;OK for now
-	  #+Genera-Release-7-4   Rel-7-2	;OK for now
-	  #+Genera-Release-8	 Rel-8
-	  #+imach                Ivory
-	  #+Cloe-Runtime	 Cloe
-          #+Lucid                Lucid
-          #+Xerox                Xerox
-	  #+Xerox-Lyric          Xerox-Lyric
-	  #+Xerox-Medley         Xerox-Medley
-          #+TI                   TI
-          #+(and dec vax common) Vaxlisp
-          #+KCL                  KCL
-          #+IBCL                 IBCL
-          #+excl                 excl
-	  #+(and excl sun4)      excl-sun4
-          #+:CMU                 CMU
-          #+HP-HPLabs            HP-HPLabs
-          #+:gclisp              gclisp
-          #+pyramid              pyramid
-          #+:coral               coral))
+        '(#+:CMU                 CMU))
 
 ;;;
 ;;; When you get a copy of PCL (by tape or by FTP), the sources files will
@@ -199,35 +173,7 @@ and load your system with:
 ;;;       "mv *.lisp *.lsp".
 ;;;
 (defvar *default-pathname-extensions*
-  (car '(#+(and (not imach) genera)          ("lisp"  . "bin")
-	 #+(and imach genera)                ("lisp"  . "ibin")
-	 #+Cloe-Runtime                      ("l"     . "fasl")
-	 #+(and dec common vax (not ultrix)) ("LSP"   . "FAS")
-	 #+(and dec common vax ultrix)       ("lsp"   . "fas")
-	 #+KCL                               ("lsp"   . "o")
-	 #+IBCL                              ("lsp"   . "o")
-	 #+Xerox                             ("lisp"  . "dfasl")
-	 #+(and Lucid MC68000)               ("lisp"  . "lbin")
-	 #+(and Lucid VAX)                   ("lisp"  . "vbin")
-	 #+(and Lucid Prime)                 ("lisp"  . "pbin")
-	 #+(and Lucid SUNRise)               ("lisp"  . "sbin")
-	 #+(and Lucid SPARC)                 ("lisp"  . "sbin")
-	 #+(and Lucid IBM-RT-PC)             ("lisp"  . "bbin")
-	 #+(and Lucid MIPS)                  ("lisp"  . "mbin")
-	 #+(and Lucid PRISM)                 ("lisp"  . "abin")
-	 #+(and Lucid PA)                    ("lisp"  . "hbin")
-	 #+(and excl SPARC)                  ("cl"    . "sparc")
-	 #+(and excl m68k)                   ("cl"    . "m68k")
-	 #+excl                              ("cl"    . "fasl")
-         #+cmu ("lisp" . #.(c:backend-fasl-file-type c:*backend*))
-	 #+HP-HPLabs                         ("l"     . "b")
-	 #+TI ("lisp" . #.(string (si::local-binary-file-type)))
-	 #+:gclisp                           ("LSP"   . "F2S")
-	 #+pyramid                           ("clisp" . "o")
-	 #+:coral                            ("lisp"  . "fasl")
-	 #-(or symbolics (and dec common vax) KCL IBCL Xerox 
-	       lucid excl :CMU HP TI :gclisp pyramid coral)
-	                                     ("lisp"  . "lbin"))))
+  (car '(#+cmu ("lisp" . #.(c:backend-fasl-file-type c:*backend*)))))
 
 (defvar *pathname-extensions*
   (let ((proper-extensions *default-pathname-extensions*))
@@ -517,8 +463,7 @@ and load your system with:
 
 (defun load-truename (&optional (errorp nil))
   (declare (ignore errorp))
-  #+(and dec vax common) (truename (sys::source-file #'load-truename))
-  #+cmu17 *load-truename*)
+  *load-truename*)
 
 #-(or cmu Symbolics)
 (defvar *pcl-directory*
@@ -539,52 +484,19 @@ and load your system with:
   ;;                                          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)
-   (rel-8-patches   t            t            ()                rel-8)
-   (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            ())
-   (sys-proclaim    t            t            ()                kcl)
    (walk            (pkg)        (pkg)        ())
    (iterate         t            t            ())
    (macros          t            t            ())
    (low             (pkg macros) t            (macros))
    
-   
-   (genera-low     (low)         (low)        (low)            Genera)
-   (cloe-low	   (low)	 (low)	      (low)            Cloe)
-   (lucid-low      (low)         (low)        (low)            Lucid)
-   (Xerox-low      (low)         (low)        (low)            Xerox)
-   (ti-low         (low)         (low)        (low)            TI)
-   (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))
    (cache       t                                   t (low defs))
-   ;;(lap         t                                   t (low)    excl-sun4)
-   ;;(plap        t                                   t (low)    excl-sun4)
-   ;;(cpatch      t                                   t (low)    excl-sun4)
-   ;;(quadlap     t                                   t (low)    excl-sun4)
-   ;;(dlap        t                                   t (defs low fin cache lap) 
-   ;;	                                                         excl-sun4)
-   ;;#-excl-sun4
    (dlisp       t                                   t (defs low fin cache))
    (dlisp2      t                                   t (low fin cache dlisp))
    (boot        t                                   t (defs fin))
@@ -614,11 +526,7 @@ and load your system with:
    ))
 
 (defun compile-pcl (&optional m)
-  (let (#+:coral(ccl::*warn-if-redefine-kernel* nil)
-	#+Lucid (lcl:*redefinition-action* nil)
-	#+excl  (excl::*redefinition-warnings* nil)
-	#+Genera (sys:inhibit-fdefine-warnings t)
-	)
+  (let ()
     (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))
@@ -628,11 +536,7 @@ and load your system with:
 	  ((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)
-	#+Genera (sys:inhibit-fdefine-warnings t)
-	)
+  (let ()
     (cond ((null m)      (operate-on-system 'pcl :load))
 	  ((eq m :query) (operate-on-system 'pcl :query-load)))))
 
diff --git a/pcl/dlisp.lisp b/pcl/dlisp.lisp
index e8950e9356fa7f5050675383cb831143cbd3849c..b739afa78a4a29c377346e40753abcc6e99a94c5 100644
--- a/pcl/dlisp.lisp
+++ b/pcl/dlisp.lisp
@@ -26,7 +26,7 @@
 ;;;
 #+cmu
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dlisp.lisp,v 1.5 1998/12/20 04:30:19 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dlisp.lisp,v 1.6 1999/03/11 16:51:05 pw Exp $")
 ;;;
 
 (in-package :pcl)
@@ -376,10 +376,9 @@
   `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref ,wrapper field)))
      (declare (fixnum wrapper-cache-no))
      (when (zerop wrapper-cache-no) (go ,miss-label))
-     ,(let ((form `(#+lucid %logand #-lucid logand
+     ,(let ((form `(logand
 		    mask wrapper-cache-no)))
-	#+lucid form
-	#-lucid `(the fixnum ,form))))
+	`(the fixnum ,form))))
 
 (defun emit-n-wrapper-compute-primary-cache-location (wrappers miss-label)
   (declare (type list wrappers))
@@ -398,10 +397,8 @@
 			    (when (or (zerop (mod adds wrapper-cache-number-adds-ok))
 				      (eql adds len))
 			      `((setq primary
-				      ,(let ((form `(#+lucid %logand #-lucid logand
-						     primary mask)))
-					 #+lucid form
-					 #-lucid `(the fixnum ,form))))))))
+				      ,(let ((form `(logand primary mask)))
+					 `(the fixnum ,form))))))))
 		 wrappers))))
      
 ;;; cmu17 note: since std-instance-p is weakened, that branch may run
@@ -412,7 +409,7 @@
 ;;;
 (defun emit-fetch-wrapper (metatype argument miss-label &optional slot)
   (ecase metatype
-    ((standard-instance #+new-kcl-wrapper structure-instance)
+    ((standard-instance)
      `(cond ((std-instance-p ,argument)
 	     ,@(when slot `((setq ,slot (std-instance-slots ,argument))))
 	     (std-instance-wrapper ,argument))
@@ -424,9 +421,8 @@
     (class
      (when slot (error "Can't do a slot reg for this metatype."))
      `(wrapper-of-macro ,argument))
-    ((built-in-instance #-new-kcl-wrapper structure-instance)
+    ((built-in-instance structure-instance)
      (when slot (error "Can't do a slot reg for this metatype."))
-     `(#+new-kcl-wrapper built-in-wrapper-of
-       #-new-kcl-wrapper built-in-or-structure-wrapper
+     `(built-in-or-structure-wrapper
        ,argument))))
 
diff --git a/pcl/env.lisp b/pcl/env.lisp
index f872e27009259c56e5755f931078fe704add2546..b88325e66c685a25d929a11670a40c24d6478b6d 100644
--- a/pcl/env.lisp
+++ b/pcl/env.lisp
@@ -26,64 +26,31 @@
 ;;;
 #+cmu
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/env.lisp,v 1.10 1998/12/20 04:30:19 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/env.lisp,v 1.11 1999/03/11 16:51:05 pw Exp $")
 ;;;
 ;;; Basic environmental stuff.
 ;;;
 
 (in-package :pcl)
 
-#+Lucid
-(progn
-
-(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 (original-definition 'sys::arglist)
-		    function other-args)))))
-
-(redefine-function 'sys::arglist 'pcl-arglist)
-
-)
-
-
 ;;;
 ;;;
 ;;;
 
 (defgeneric describe-object (object stream))
 
-#-Genera
-(progn
-
-(defun pcl-describe (object #+Lispm &optional #+Lispm no-complaints)
-  (let (#+Lispm (*describe-no-complaints* no-complaints))
-    #+Lispm (declare (special *describe-no-complaints*))
-    (describe-object object *standard-output*)
-    (values)))
+#-cmu
+(defun pcl-describe (object)
+  (describe-object object *standard-output*)
+  (values))
 
 (defmethod describe-object (object stream)
-  #-cmu
-    (cond ((or #+kcl (packagep object))
-	   (describe-package object stream))
-	  (t
-	   (funcall (original-definition 'describe) object)))
   #+cmu
   (describe object stream))
 
 #-cmu
 (redefine-function 'describe 'pcl-describe)
 
-)
-
 (defmethod describe-object ((object slot-object) stream)
   (let* ((class (class-of object))
 	 (slotds (slots-to-inspect class object))
@@ -321,7 +288,6 @@
 ;    (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))
 
diff --git a/pcl/excl-low.lisp b/pcl/excl-low.lisp
deleted file mode 100644
index 54c734b4def26d41fc3ba078448798afeac3b517..0000000000000000000000000000000000000000
--- a/pcl/excl-low.lisp
+++ /dev/null
@@ -1,136 +0,0 @@
-;;; -*- 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*)
-	 (eq (svref x 0) 'std-instance))))
-
-(excl::defcmacro std-instance-p (x)
-  (once-only (x)
-    `(and (excl::structurep ,x)
-	  (locally
-	    (declare #.*optimize-speed*)
-	    (eq (svref ,x 0) 'std-instance)))))
-
-(excl::defcmacro fast-method-call-p (x)
-  (once-only (x)
-    `(and (excl::structurep ,x)
-	  (locally
-	    (declare #.*optimize-speed*)
-	    (eq (svref ,x 0) 'fast-method-call)))))
-
-(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.
-
-(defun (:property pcl::std-instance :inspector-function) (object)
-  (let ((class (class-of object)))
-    (cons (inspect::make-field-def "class" #'class-of :lisp)
-	  (mapcar #'(lambda (slot)
-		      (inspect::make-field-def
-		       (string (slot-definition-name slot))
-		       #'(lambda (x)
-			   (slot-value-using-class class x slot))
-		       :lisp))
-		  (slots-to-inspect class object)))))
-
-(defun (:property pcl::std-instance :inspector-type-function) (x)
-  (class-name (class-of x)))
diff --git a/pcl/fin.lisp b/pcl/fin.lisp
index db54b64c0eaa689a935f1f6922e8046b111ae59a..6adfef53b5d3eaad0bbac94d0887c39e10b74a8e 100644
--- a/pcl/fin.lisp
+++ b/pcl/fin.lisp
@@ -26,7 +26,7 @@
 ;;;
 #+cmu
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/fin.lisp,v 1.11 1998/12/20 04:30:20 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/fin.lisp,v 1.12 1999/03/11 16:51:06 pw Exp $")
 ;;;
 
   ;;   
@@ -133,1121 +133,6 @@ explicitly marked saying who wrote it.
   (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)
-                #+MIPS
-                '(#x8FD4 #x1E #x2785 #x2EEF #xA0 #x8 #x14 #xF000)
-                #-(or MC68000 SPARC BSP I386 VAX PA MIPS)
-		'(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)
-;;;      
-#+(and Genera (not Genera-Release-8))
-(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)
-  (declare (optimize (speed 3) (safety 0)))
-  #'(lambda (&rest args)
-      #+Genera (declare (dbg:invisible-frame :pcl-internals))
-      (apply function args)))
-
-(defmacro funcallable-instance-data-1 (fin data)
-  `(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 *print-lexical-closure* nil)
-
-(defun pcl-print-lexical-closure (exp stream slashify-p &optional (depth 0))
-  (declare (ignore depth))
-  (declare (special *boot-state*))
-  (if (or (eq *print-lexical-closure* exp)
-	  (neq *boot-state* 'complete)
-	  (eq (class-of exp) *the-class-t*))
-      (let ((*print-lexical-closure* nil))
-	(funcall (original-definition 'si:print-lexical-closure)
-		 exp stream slashify-p))
-      (let ((*print-escape* slashify-p)
-	    (*print-lexical-closure* exp))
-	(print-object exp stream))))
-
-(unless (boundp '*boot-state*)
-  (setq *boot-state* nil))
-
-(redefine-function 'si:print-lexical-closure 'pcl-print-lexical-closure)
-
-(defvar *function-name-level* 0)
-
-(defun pcl-function-name (function &rest other-args)
-  (if (and (eq *boot-state* 'complete)
-	   (funcallable-instance-p function)
-	   (generic-function-p function)
-	   (<= *function-name-level* 2))
-      (let ((*function-name-level* (1+ *function-name-level*)))
-	(generic-function-name function))
-      (apply (original-definition 'si:function-name) function other-args)))
-
-(redefine-function 'si:function-name 'pcl-function-name)
-
-(defun pcl-arglist (function &rest other-args)
-  (let ((defn nil))
-    (cond ((and (funcallable-instance-p function)
-		(generic-function-p function))
-	   (generic-function-pretty-arglist function))
-	  ((and (sys:validate-function-spec function)
-		(sys:fdefinedp function)
-		(setq defn (sys:fdefinition function))
-		(funcallable-instance-p defn)
-		(generic-function-p defn))
-	   (generic-function-pretty-arglist defn))
-	  (t (apply (original-definition 'zl:arglist) function other-args)))))
-
-(redefine-function 'zl:arglist 'pcl-arglist)
-
-
-;;;
-;;; This code is adapted from frame-lexical-environment and frame-function.
-;;;
-#||
-dbg:
-(progn
-
-(defvar *old-frame-function*)
-
-(defvar *inside-new-frame-function* nil)
-
-(defun new-frame-function (frame)
-  (let* ((fn (funcall *old-frame-function* frame))
-	 (location (%pointer-plus frame #+imach (defstorage-size stack-frame) #-imach 0))
-	 (env? #+3600 (location-contents location)
-	       #+imach (%memory-read location :cycle-type %memory-scavenge)))
-    (or (when (cl:consp env?)
-	  (let ((l2 (last2 env?)))
-	    (when (eq (car l2) '.this-is-a-dfun.)
-	      (cadr l2))))
-	fn)))
-
-(defun pcl::doctor-dfun-for-the-debugger (gf dfun)
-  (when (sys:lexical-closure-p dfun)
-    (let* ((env (si:lexical-closure-environment dfun))
-	   (l2 (last2 env)))
-      (unless (eq (car l2) '.this-is-a-dfun.)
-	(setf (si:lexical-closure-environment dfun)
-	      (nconc env (list '.this-is-a-dfun. gf))))))
-  dfun)
-
-(defun last2 (l)
-  (labels ((scan (2ago tail)
-	     (if (null tail)
-		 2ago
-		 (if (cl:consp tail)
-		     (scan (cdr 2ago) (cdr tail))
-		     nil))))
-    (and (cl:consp l)
-	 (cl:consp (cdr l))
-	 (scan l (cddr l)))))
-
-(eval-when (load)
-  (unless (boundp '*old-frame-function*)
-    (setq *old-frame-function* #'frame-function)
-    (setf (cl:symbol-function 'frame-function) 'new-frame-function)))
-
-)
-||#
-
-);end of #+Genera
-
-
-
-;;;
-;;; In Genera 8.0, we use a real funcallable instance (from Genera CLOS) for this.
-;;; This minimizes the subprimitive mucking around.
-;;;
-#+(and Genera Genera-Release-8)
-(progn
-
-(clos-internals::ensure-class
-  'pcl-funcallable-instance
-  :direct-superclasses '(clos-internals:funcallable-instance)
-  :slots `((:name function
-	    :initform #'(lambda (ignore &rest ignore-them-too)
-			  (declare (ignore ignore ignore-them-too))
-			  (called-fin-without-function))
-	    :initfunction ,#'(lambda nil
-			       #'(lambda (ignore &rest ignore-them-too)
-				   (declare (ignore ignore ignore-them-too))
-				   (called-fin-without-function))))
-	   ,@(mapcar #'(lambda (slot) `(:name ,slot)) funcallable-instance-data))
-  :metaclass 'clos:funcallable-standard-class)
-
-(defun pcl-funcallable-instance-trampoline (extra-arg &rest args)
-  (apply (sys:%instance-ref (clos-internals::%dispatch-instance-from-extra-argument extra-arg)
-			    3)
-	 args))
-
-(defun allocate-funcallable-instance-1 ()
-  (let ((fin (clos:make-instance 'pcl-funcallable-instance)))
-    (setf (clos-internals::%funcallable-instance-function fin)
-	  #'pcl-funcallable-instance-trampoline)
-    (setf (clos-internals::%funcallable-instance-extra-argument fin)
-	  (sys:%make-pointer sys:dtp-instance
-			     (clos-internals::%funcallable-instance-extra-argument fin)))
-    (setf (clos:slot-value fin 'clos-internals::funcallable-instance) fin)
-    fin))
-
-(scl:defsubst funcallable-instance-p (x)
-  (and (sys:funcallable-instance-p x)
-       (eq (clos-internals::%funcallable-instance-function x)
-	   #'pcl-funcallable-instance-trampoline)))
-
-(defun set-funcallable-instance-function (fin new-value)
-  (setf (clos:slot-value fin 'function) new-value))
-
-(defmacro funcallable-instance-data-1 (fin data)
-  `(clos-internals:%funcallable-instance-ref
-     ,fin (+ 4 (funcallable-instance-data-position ,data))))
-
-(defsetf funcallable-instance-data-1 (fin data) (new-value)
-  `(setf (clos-internals:%funcallable-instance-ref
-	   ,fin (+ 4 (funcallable-instance-data-position ,data)))
-	 ,new-value))
-
-(clos:defmethod clos:print-object ((fin pcl-funcallable-instance) stream)
-  (print-object fin stream))
-
-(clos:defmethod clos-internals:debugging-information-function ((fin pcl-funcallable-instance))
-  nil)
-
-(clos:defmethod clos-internals:function-name-object ((fin pcl-funcallable-instance))
-  (declare (special *boot-state*))
-  (if (and (eq *boot-state* 'complete)
-	   (generic-function-p fin))
-      (generic-function-name fin)
-      fin))
-
-(clos:defmethod clos-internals:arglist-object ((fin pcl-funcallable-instance))
-  (declare (special *boot-state*))
-  (if (and (eq *boot-state* 'complete)
-	   (generic-function-p fin))
-      (generic-function-pretty-arglist fin)
-      '(&rest args)))
-
-);end of #+Genera
-
-
-
-#+Cloe-Runtime
-(progn
-
-(defconstant funcallable-instance-closure-slots 5)
-(defconstant funcallable-instance-closure-size
-	     (+ funcallable-instance-closure-slots (length funcallable-instance-data) 1))
-
-#-CLOE-Release-2 (progn
-
-(defun allocate-funcallable-instance-1 ()
-  (let ((data (system::make-funcallable-structure 'funcallable-instance
-						  funcallable-instance-closure-size)))
-    (setf (system::%trampoline-ref data funcallable-instance-closure-slots)
-	  'funcallable-instance)
-    (set-funcallable-instance-function
-      data
-      #'(lambda (&rest ignore-them-too)
-	  (declare (ignore ignore-them-too))
-	  (called-fin-without-function)))
-    data))
-
-(proclaim '(inline funcallable-instance-p))
-(defun funcallable-instance-p (x)
-  (and (typep x 'system::trampoline)
-       (= (system::%trampoline-data-length x) funcallable-instance-closure-size)
-       (eq (system::%trampoline-ref x funcallable-instance-closure-slots)
-	   'funcallable-instance)))
-
-(defun set-funcallable-instance-function (fin new-value)
-  (when (not (funcallable-instance-p fin))
-    (error "~S is not a funcallable-instance" fin))
-  (etypecase new-value
-    (system::trampoline
-      (let ((length (system::%trampoline-data-length new-value)))
-	(cond ((> length funcallable-instance-closure-slots)
-	       (set-funcallable-instance-function
-		 fin
-		 #'(lambda (&rest args)
-		     (declare (sys:downward-rest-argument))
-		     (apply new-value args))))
-	      (t
-	       (setf (system::%trampoline-function fin)
-		     (system::%trampoline-function new-value))
-	       (dotimes (i length)
-		 (setf (system::%trampoline-ref fin i)
-		       (system::%trampoline-ref new-value i)))))))
-    (compiled-function
-      (setf (system::%trampoline-function fin) new-value))
-    (function
-      (set-funcallable-instance-function
-	fin
-	#'(lambda (&rest args)
-	    (declare (sys:downward-rest-argument))
-	    (apply new-value args))))))
-
-(defmacro funcallable-instance-data-1 (fin data)
-  `(system::%trampoline-ref ,fin (+ funcallable-instance-closure-slots
-				    1 (funcallable-instance-data-position ,data))))
-
-(defsetf funcallable-instance-data-1 (fin data) (new-value)
-  `(setf (system::%trampoline-ref ,fin (+ funcallable-instance-closure-slots
-					  1 (funcallable-instance-data-position ,data)))
-	 ,new-value))
-
-)
-
-#+CLOE-Release-2 (progn
-
-(defun allocate-funcallable-instance-1 ()
-  (let ((data (si::cons-closure funcallable-instance-closure-size)))
-    (setf (si::closure-ref data funcallable-instance-closure-slots) 'funcallable-instance)
-    (set-funcallable-instance-function
-      data
-      #'(lambda (&rest ignore-them-too)
-	  (declare (ignore ignore-them-too))
-	  (error "Called a FIN without first setting its function.")))
-    data))
-
-(proclaim '(inline funcallable-instance-p))
-(defun funcallable-instance-p (x)
-  (and (si::closurep x)
-       (= (si::closure-length x) funcallable-instance-closure-size)
-       (eq (si::closure-ref x funcallable-instance-closure-slots) 'funcallable-instance)))
-
-(defun set-funcallable-instance-function (fin new-value)
-  (when (not (funcallable-instance-p fin))
-    (error "~S is not a funcallable-instance" fin))
-  (etypecase new-value
-    (si::closure
-      (let ((length (si::closure-length new-value)))
-	(cond ((> length funcallable-instance-closure-slots)
-	       (set-funcallable-instance-function
-		 fin
-		 #'(lambda (&rest args)
-		     (declare (sys:downward-rest-argument))
-		     (apply new-value args))))
-	      (t
-	       (setf (si::closure-function fin) (si::closure-function new-value))
-	       (dotimes (i length)
-		 (si::object-set fin (+ i 3) (si::object-ref new-value (+ i 3))))))))
-    (compiled-function
-      (setf (si::closure-function fin) new-value))
-    (function
-      (set-funcallable-instance-function
-	fin
-	#'(lambda (&rest args)
-	    (declare (sys:downward-rest-argument))
-	    (apply new-value args))))))
-
-(defmacro funcallable-instance-data-1 (fin data)
-  `(si::closure-ref ,fin (+ funcallable-instance-closure-slots
-			    1 (funcallable-instance-data-position ,data))))
-
-(defsetf funcallable-instance-data-1 (fin data) (new-value)
-  `(setf (si::closure-ref ,fin (+ funcallable-instance-closure-slots
-				  1 (funcallable-instance-data-position ,data)))
-	 ,new-value))
-
-)
-
-)
-
-
-;;;
-;;;
-;;; 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:
 ;;;
@@ -1300,557 +185,6 @@ dbg:
                 
 ); End of #+cmu progn
 
-
-;;;
-;;; 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.
-;;;
-
-#+(and KCL (not 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))
-)
-
-#+IBCL
-(progn ; From Rainy Day PCL.  
-
-(defvar *funcallable-instance-marker* (list "Funcallable Instance Marker"))
-
-(defconstant funcallable-instance-closure-size 15)
-
-(defun allocate-funcallable-instance-1 ()
-  (let ((fin (allocate-funcallable-instance-2))
-	(env
-	  (make-list funcallable-instance-closure-size :initial-element nil)))
-    (set-cclosure-env fin env)
-    #+:turbo-closure (si:turbo-closure fin)
-    (dotimes (i (1- funcallable-instance-closure-size)) (pop env))
-    (setf (car env) *funcallable-instance-marker*)
-    fin))
-
-(defun allocate-funcallable-instance-2 ()
-  (let ((what-a-dumb-closure-variable ()))
-    #'(lambda (&rest args)
-	(declare (ignore args))
-	(called-fin-without-function)
-	(setq what-a-dumb-closure-variable
-	      (dummy-function what-a-dumb-closure-variable)))))
-
-(defun funcallable-instance-p (x)
-  (and (cclosurep x)
-       (let ((env (cclosure-env x)))
-	 (when (listp env)
-	   (dotimes (i (1- funcallable-instance-closure-size)) (pop env))
-	   (eq (car env) *funcallable-instance-marker*)))))
-
-(defun set-funcallable-instance-function (fin new-value)
-  (cond ((not (funcallable-instance-p fin))
-         (error "~S is not a funcallable-instance" fin))
-        ((not (functionp new-value))
-         (error "~S is not a function." new-value))
-        ((cclosurep new-value)
-         (let* ((fin-env (cclosure-env fin))
-                (new-env (cclosure-env new-value))
-                (new-env-size (length new-env))
-                (fin-env-size (- funcallable-instance-closure-size
-                                 (length funcallable-instance-data)
-				 1)))
-           (cond ((<= new-env-size fin-env-size)
-		  (do ((i 0 (+ i 1))
-		       (new-env-tail new-env (cdr new-env-tail))
-		       (fin-env-tail fin-env (cdr fin-env-tail)))
-		      ((= i fin-env-size))
-		    (setf (car fin-env-tail)
-			  (if (< i new-env-size)
-			      (car new-env-tail)
-			      nil)))		  
-		  (set-cclosure-self fin (cclosure-self new-value))
-		  (set-cclosure-data fin (cclosure-data new-value))
-		  (set-cclosure-start fin (cclosure-start new-value))
-		  (set-cclosure-size fin (cclosure-size new-value)))
-                 (t                 
-                  (set-funcallable-instance-function
-                    fin
-                    (make-trampoline new-value))))))
-	((typep new-value 'compiled-function)
-	 ;; Write NILs into the part of the cclosure environment that is
-	 ;; not being used to store the funcallable-instance-data.  Then
-	 ;; copy over the parts of the compiled function that need to be
-	 ;; copied over.
-	 (let ((env (cclosure-env fin)))
-	   (dotimes (i (- funcallable-instance-closure-size
-			  (length funcallable-instance-data)
-			  1))
-	     (setf (car env) nil)
-	     (pop env)))
-	 (set-cclosure-self fin (cfun-self new-value))
-	 (set-cclosure-data fin (cfun-data new-value))
-	 (set-cclosure-start fin (cfun-start new-value))
-	 (set-cclosure-size fin (cfun-size new-value)))	 
-        (t
-         (set-funcallable-instance-function fin
-                                            (make-trampoline new-value))))
-  fin)
-
-
-(defun make-trampoline (function)
-  #'(lambda (&rest args)
-      (apply function args)))
-
-;; this replaces funcallable-instance-data-1, set-funcallable-instance-data-1
-;; and the defsetf
-(defmacro funcallable-instance-data-1 (fin data &environment env)
-  ;; The compiler won't expand macros before deciding on optimizations,
-  ;; so we must do it here.
-  (let* ((pos-form (macroexpand `(funcallable-instance-data-position ,data)
-				env))
-	 (index-form (if (constantp pos-form)
-			 (- funcallable-instance-closure-size
-			    (eval pos-form)
-			    2)
-			 `(- funcallable-instance-closure-size
-			     (funcallable-instance-data-position ,data)
-			     2))))
-    #+:turbo-closure `(car (tc-cclosure-env-nthcdr ,index-form ,fin))
-    #-:turbo-closure `(nth ,index-form (cclosure-env ,fin))))
-
-)
-
-
-;;;
-;;; In H.P. Common Lisp
-;;; 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))
-
-#+:ccl-1.3
-(eval-when (eval compile load)
-
-;;; Make uvector-based objects (like funcallable instances) print better.
-(defun print-uvector-object (obj stream &optional print-level)
-  (declare (ignore print-level))
-  (print-object obj stream))
-
-;;; Inform the print system about funcallable instance uvectors.
-(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
 
 
   
diff --git a/pcl/fixup.lisp b/pcl/fixup.lisp
index 82c4d697434123a27486535157028e925589d22f..71b18edfcb3ef0a6f3ecf63b18863988e8baf4ee 100644
--- a/pcl/fixup.lisp
+++ b/pcl/fixup.lisp
@@ -30,10 +30,6 @@
 (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/gcl-patches.lisp b/pcl/gcl-patches.lisp
deleted file mode 100644
index 9f6f4e7d8a195d1d5a8635be78e06ffc1aef9236..0000000000000000000000000000000000000000
--- a/pcl/gcl-patches.lisp
+++ /dev/null
@@ -1,168 +0,0 @@
-;;; -*- 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)
-	   ,(PORTABLE-PROGV-UNBIND sym old-vals unbound-holder))))))
-
diff --git a/pcl/genera-low.lisp b/pcl/genera-low.lisp
deleted file mode 100644
index 71c939d1330f5bff43b16514989e016cd504ecd2..0000000000000000000000000000000000000000
--- a/pcl/genera-low.lisp
+++ /dev/null
@@ -1,423 +0,0 @@
-;;; -*- 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)
-
-(pushnew ':pcl-internals dbg:*all-invisible-frame-types*)
-
-#+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))
-
-(scl:defmethod (:describe std-instance) ()
-  (describe-object scl:self *standard-output*))
-
-(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 "~\\si:address\\" (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))
-
-
-;; 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))
-(sys: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))
-		  (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)))))
-	      (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)))
-	 (lambda-list (let ((ll-stuff (assoc 'pcl-lambda-list dlist)))
-			(if ll-stuff (cadr ll-stuff) (arglist fn))))
-	 (doc (cadr (assoc 'pcl-documentation dlist)))
-	 (plist (cadr (assoc 'pcl-plist dlist))))
-    (load-defmethod (or class 'standard-method)
-		    gspec
-		    qualifiers
-		    specializers
-		    lambda-list
-		    doc
-		    (getf plist :pv-table-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))
-  )
-
-
-
-(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
deleted file mode 100644
index e743744db43702338ff6b5b397ba7da9765b985c..0000000000000000000000000000000000000000
--- a/pcl/get-pcl.text
+++ /dev/null
@@ -1,180 +0,0 @@
-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
deleted file mode 100644
index ee47b6f21fc8f3059adec6c6cf8c10e6fefa2bb6..0000000000000000000000000000000000000000
--- a/pcl/gold-low.lisp
+++ /dev/null
@@ -1,51 +0,0 @@
-;;;-*-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))
-  (setf (get x 'gcl::compile-separately) t))
-
diff --git a/pcl/hp-low.lisp b/pcl/hp-low.lisp
deleted file mode 100644
index d1e807f6841e0cbbbc1a5788bcd3441462b3b910..0000000000000000000000000000000000000000
--- a/pcl/hp-low.lisp
+++ /dev/null
@@ -1,37 +0,0 @@
-;;; -*- 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
deleted file mode 100644
index 2ab3f77ba429c92be8f442e00e294515553b177a..0000000000000000000000000000000000000000
--- a/pcl/ibcl-low.lisp
+++ /dev/null
@@ -1,327 +0,0 @@
-;;;-*-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
deleted file mode 100644
index 68e071cef1444aa9be506fd869408e3c48f9b71b..0000000000000000000000000000000000000000
--- a/pcl/ibcl-patches.lisp
+++ /dev/null
@@ -1,129 +0,0 @@
-;;;-*-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
index e1b708364da8fd970613d4e28e3ba931ed5bcf9e..86acfcff9ef2de6acbf64a4784dcaff358561078 100644
--- a/pcl/init.lisp
+++ b/pcl/init.lisp
@@ -26,7 +26,7 @@
 ;;;
 #+cmu
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/init.lisp,v 1.9 1998/12/20 04:30:20 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/init.lisp,v 1.10 1999/03/11 16:51:09 pw Exp $")
 ;;;
 ;;; This file defines the initialization and related protocols.
 ;;; 
@@ -191,7 +191,7 @@
 	  (if (and slot-names
 		   (or (eq slot-names 't)
 		       (memq slot-name slot-names))
-		   (or #-new-kcl-wrapper (and (not std-p) (eq slot-names 't))
+		   (or (and (not std-p) (eq slot-names 't))
 		       (not (slot-boundp-using-class class instance slotd))))
 	      (let ((initfunction (slot-definition-initfunction slotd)))
 		(when initfunction
diff --git a/pcl/kcl-low.lisp b/pcl/kcl-low.lisp
deleted file mode 100644
index 77cb4f5696a7df94b18f4f5bc8ffa5bdea5ace11..0000000000000000000000000000000000000000
--- a/pcl/kcl-low.lisp
+++ /dev/null
@@ -1,438 +0,0 @@
-;;;-*-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
-	  %instance-ref
-	  %set-instance-ref))
-(in-package 'pcl)
-
-(shadow 'lisp:dotimes)
-
-(defmacro dotimes ((var form &optional (val nil)) &rest body &environment env)
-  (multiple-value-bind (doc decls bod)
-      (extract-declarations body env)
-    (declare (ignore doc))
-    (let ((limit (gensym))
-          (label (gensym)))
-      `(let ((,limit ,form)
-             (,var 0))
-         (declare (fixnum ,limit ,var))
-         ,@decls
-         (block nil
-           (tagbody
-            ,label
-              (when (>= ,var ,limit) (return-from nil ,val))
-              ,@bod
-              (setq ,var (the fixnum (1+ ,var)))
-              (go ,label)))))))
-
-(defun memq (item list) (member item list :test #'eq))
-(defun assq (item list) (assoc item list :test #'eq))
-(defun posq (item list) (position item list :test #'eq))
-
-(si:define-compiler-macro memq (item list) 
-  (let ((var (gensym)))
-    (once-only (item)
-      `(let ((,var ,list))
-         (loop (unless ,var (return nil))
-               (when (eq ,item (car ,var))
-                 (return ,var))
-               (setq ,var (cdr ,var)))))))
-
-(si:define-compiler-macro assq (item list) 
-  (let ((var (gensym)))
-    (once-only (item)
-      `(dolist (,var ,list nil)
-         (when (eq ,item (car ,var))
-           (return ,var))))))
-
-(si:define-compiler-macro posq (item list) 
-  (let ((var (gensym)) (index (gensym)))
-    (once-only (item)
-      `(let ((,var ,list) (,index 0))
-         (declare (fixnum ,index))
-         (dolist (,var ,list nil)
-           (when (eq ,item ,var)
-             (return ,index))
-           (incf ,index))))))
-
-(defun printing-random-thing-internal (thing stream)
-  (format stream "~X" (si:address thing)))
-
-(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
-;;;
-#-akcl
-(si:define-compiler-macro std-instance-p (x)
-  (once-only (x)
-    `(and (si:structurep ,x)
-          (eq (si:%structure-name ,x) 'std-instance))))
-
-#+akcl
-(progn
-
-#-new-kcl-wrapper
-;; declare that std-instance-p may be computed simply, and will not change.
-(si::freeze-defstruct 'std-instance)
-
-(si::freeze-defstruct 'method-call)
-(si::freeze-defstruct 'fast-method-call)
-
-(defvar *pcl-funcall* 
-  `(lambda (loc)
-     (compiler::wt-nl
-      "{object _funobj = " loc ";"
-      "if(Rset&&type_of(_funobj)!=t_symbol)funcall_no_event(_funobj);
-       else super_funcall(_funobj);}")))
-
-(setq compiler::*super-funcall* *pcl-funcall*)
-
-(defmacro fmc-funcall (fn pv-cell next-method-call &rest args)
-  `(funcall ,fn ,pv-cell ,next-method-call ,@args))
-
-)
-
-;;;
-;;; 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.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.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)
-
-#+new-kcl-wrapper
-(progn
-
-(defun instance-ref (slots index)
-  (si:structure-ref1 slots index))
-
-(defun set-instance-ref (slots index value)
-  (si:structure-set1 slots index value))
-
-(defsetf instance-ref set-instance-ref)
-(defsetf %instance-ref %set-instance-ref)
-)
-
-(defsetf structure-def set-structure-def)
-
-;;((name args-type result-type side-effect-p new-object-p c-expression) ...)
-(defparameter *kcl-function-inlines*
-  '((%fboundp (t) compiler::boolean nil nil "(#0)->s.s_gfdef!=OBJNULL")
-    (%symbol-function (t) t nil nil "(#0)->s.s_gfdef")
-    #-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]")
-    #+new-kcl-wrapper
-    (si:%instance-ref (t t) t nil nil "(#0)->str.str_self[fix(#1)]")
-    #+new-kcl-wrapper
-    (si:%set-instance-ref (t t t) t t nil "(#0)->str.str_self[fix(#1)]=(#2)")
-    (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")
-    #+akcl (sfun-p (t) compiler::boolean nil nil "type_of(#0)==t_sfun")
-    (%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]")
-    
-    (logxor (fixnum fixnum) fixnum nil nil "((#0) ^ (#1))")))
-  
-(defun make-function-inline (inline)
-  (setf (get (car inline) 'compiler::inline-always)
-        (list (if (fboundp 'compiler::flags)
-                  (let ((opt (cdr inline)))
-                    (list (first opt) (second opt)
-                          (logior (if (fourth opt) 1 0) ; allocates-new-storage
-                                  (if (third opt) 2 0)  ; side-effect
-                                  (if nil 4 0) ; constantp
-                                  (if (eq (car inline) 'logxor)
-                                      8 0)) ;result type from args
-                          (fifth opt)))
-                  (cdr inline)))))
-
-(defmacro define-inlines ()
-  `(progn
-    ,@(mapcan #'(lambda (inline)
-                  (let* ((*package* *the-pcl-package*)
-			 (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)))
-                      ,@(when (or (every #'(lambda (type) (eq type 't))
-                                         (cadr inline))
-                                  (char= #\% (aref (symbol-name (car inline)) 0)))
-                          `((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)
-	 (si::turbo-closure fn)
-	 ;;(when (symbolp new-name) (proclaim-defgeneric new-name nil))
-         (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 "
-#ifdef AKCL206
-use_fast_links();
-#endif
-
-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;
-#ifdef AKCL206
-  /* If we are currently using fast linking,     */
-  /* make sure to remove the link for result_cc. */
-  use_fast_links(3,Cnil,result_cc);
-#endif
-  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;
-}")
-
-(defentry %set-cclosure (object object int) (object set_cclosure))
-
-
-(defun structure-functions-exist-p ()
-  t)
-
-(si:define-compiler-macro structure-instance-p (x)
-  (once-only (x)
-    `(and (si:structurep ,x)
-          (not (eq (si:%structure-name ,x) 'std-instance)))))
-
-(defun structure-type (x)
-  (and (si:structurep x)
-       (si:%structure-name x)))
-
-(si:define-compiler-macro structure-type (x)
-  (once-only (x)
-    `(and (si:structurep ,x)
-          (si:%structure-name ,x))))
-
-(defun structure-type-p (type)
-  (or (not (null (gethash type *structure-table*)))
-      (let (#+akcl(s-data nil))
-        (and (symbolp type)
-             #+akcl (setq s-data (get type 'si::s-data))
-             #-akcl (get type 'si::is-a-structure)
-             (null #+akcl (si::s-data-type s-data)
-                   #-akcl (get type 'si::structure-type))))))
-
-(defun structure-type-included-type-name (type)
-  (or (car (gethash type *structure-table*))
-      #+akcl (let ((includes (si::s-data-includes (get type 'si::s-data))))
-	       (when includes
-		 (si::s-data-name includes)))
-      #-akcl (get type 'si::structure-include)))
-
-(defun structure-type-internal-slotds (type)
-  #+akcl (si::s-data-slot-descriptions (get type 'si::s-data))
-  #-akcl (get type 'si::structure-slot-descriptions))
-
-(defun structure-type-slot-description-list (type)
-  (or (cdr (gethash type *structure-table*))
-      (mapcan #'(lambda (slotd)
-		  #-new-kcl-wrapper
-                  (when (and slotd (car slotd))
-                    (let ((offset (fifth slotd)))
-                      (let ((reader #'(lambda (x)
-                                        #+akcl (si:structure-ref1 x offset)
-                                        #-akcl (si:structure-ref x type offset)))
-                            (writer #'(lambda (v x)
-                                        (si:structure-set x type offset v))))
-                        #+turbo-closure (si:turbo-closure reader)
-                        #+turbo-closure (si:turbo-closure writer)
-                        (let* ((reader-sym 
-				(let ((*package* *the-pcl-package*))
-				  (intern (format nil "~s SLOT~D" type offset))))
-			       (writer-sym (get-setf-function-name reader-sym))
-			       (slot-name (first slotd))
-			       (read-only-p (fourth slotd)))
-                          (setf (symbol-function reader-sym) reader)
-                          (setf (symbol-function writer-sym) writer)
-                          (do-standard-defsetf-1 reader-sym)
-                          (list (list slot-name
-                                      reader-sym
-				      reader
-                                      (and (not read-only-p) writer)))))))
-		  #+new-kcl-wrapper
-		  (list slotd))
-              (let ((slotds (structure-type-internal-slotds type))
-                    (inc (structure-type-included-type-name type)))
-                (if inc
-                    (nthcdr (length (structure-type-internal-slotds inc))
-                            slotds)
-                    slotds)))))
-            
-#+new-kcl-wrapper
-(defun si::slot-reader-function (slot)
-  (let ((offset (si::slot-offset slot)))
-    (si:turbo-closure #'(lambda (x)
-			  (si::structure-ref1 x offset)))))				
-
-#+new-kcl-wrapper
-(defun si::slot-writer-function (slot)
-  (let ((offset (si::slot-offset slot)))
-    (si:turbo-closure #'(lambda (x)
-			  (si::structure-set1 x offset)))))
-
-(mapcar #'(lambda (fname value)
-	    (setf (symbol-function fname) (symbol-function value)))
-	'(structure-slotd-name
-	  structure-slotd-accessor-symbol
-	  structure-slotd-reader-function
-	  structure-slotd-writer-function
-	  structure-slotd-type
-	  structure-slotd-init-form)
-	#-new-kcl-wrapper
-	'(first second third fourth function-returning-nil function-returning-nil)
-	#+new-kcl-wrapper
-	'(si::slot-name si::slot-accessor-name 
-	  si::slot-reader-function si::slot-writer-function
-	  si::slot-type si::slot-default-init))
-
-
-;; Construct files sys-proclaim.lisp and sys-package.lisp
-;; The file sys-package.lisp must be loaded first, since the
-;; package sys-proclaim.lisp will refer to symbols and they must
-;; be in the right packages.   sys-proclaim.lisp contains function
-;; declarations and declarations that certain things are closures.
-
-(defun renew-sys-files()
-  ;; packages:
-  (compiler::get-packages "sys-package.lisp")
-  (with-open-file (st "sys-package.lisp"
-		      :direction :output
-		      :if-exists :append)
-    (format st "(in-package 'SI)
-(export '(%structure-name
-          %compiled-function-name
-          %set-compiled-function-name))
-(in-package 'pcl)
-"))
-
-  ;; proclaims
-  (compiler::make-all-proclaims "*.fn")
-  (let ((*package* (find-package 'user)))
-  (with-open-file (st "sys-proclaim.lisp"
-		      :direction :output
-		      :if-exists :append)
-    ;;(format st "~%(IN-PACKAGE \"PCL\")~%")
-    (print
-     `(dolist (v ',
-     
-	       (sloop::sloop for v in-package "PCL"
-			     when (get v 'compiler::proclaimed-closure)
-			     collect v))
-	(setf (get v 'compiler::proclaimed-closure) t))
-     st)
-    (format st "~%")
-    )))
-
-	
diff --git a/pcl/kcl-mods.text b/pcl/kcl-mods.text
deleted file mode 100644
index 741e41ac6cdb6881e083e5ac40ecd772bee1375a..0000000000000000000000000000000000000000
--- a/pcl/kcl-mods.text
+++ /dev/null
@@ -1,224 +0,0 @@
-If you have akcl version 604 or newer, do not make these patches.
-
-
-(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:
-        ADD_FEATURE("AKCL");
-
diff --git a/pcl/kcl-notes.text b/pcl/kcl-notes.text
deleted file mode 100644
index fc8a6831ed4cd0e27c5b13f0a3dab919b6047613..0000000000000000000000000000000000000000
--- a/pcl/kcl-notes.text
+++ /dev/null
@@ -1,39 +0,0 @@
-
-Some notes on using "5/1/90  May Day PCL (REV 4b)" with KCL and AKCL.
-
-1. KCL will try to load the PCL file "init" when it starts up,
-   if you rename the files as is mentioned in defsys.lisp and the 
-   currect directory is the one containing PCL.  I suggest that
-   you do not rename any file except maybe "defsys", and also 
-   that you change the (files-renamed-p t) to (files-renamed-p nil) 
-   in defsys.lisp.
-
-2. Do not comment out the file kcl-patches.lisp, even if you are
-   using AKCL.  It contins a patch to make compiler messages more
-   informative for AKCL, and also sets compiler::*compile-ordinaries*
-   to T, so that methods will get compiled.
-
-3. While fixup.lisp compiles, there will be a pause, because 
-   KCL's compiler is not reentrant, and some uncompiled
-   code is run.  If you want, you can change the form
-   (fix-early-generic-functions) to (fix-early-generic-functions t)
-   in fixup.lisp to see what is happening.
-
-4. (If you are using AKCL 605 or newer, skip this step.)
-   If you want, you can apply the changes in kcl-mods.text
-   to your KCL or AKCL to make PCL run faster.  The file kcl-mods.text
-   is different from what it was in versions of PCL earlier than
-   May Day PCL.  If you do not make these changes, or if you made 
-   the old changes, things will still work.
-
-5. If you are using AKCL, and you previously used the kcl-low.lisp
-   file from rascal.ics.utexas.edu, you should not use it this time.
-   The kcl-low.lisp that comes with May Day PCL works fine.  (If you
-   insist on using an old version of kcl-low.lisp, you will need to
-   use an old version of the KCL part of fin.lisp as well: this is
-   what is done for IBCL, by the way.) 
-
-6. I recommend that you use AKCL version 457 or newer rather than using
-   KCL or an older version of AKCL, because there are some bugs in KCL
-   that cause problems for May Day PCL.
-
diff --git a/pcl/kcl-patches.lisp b/pcl/kcl-patches.lisp
deleted file mode 100644
index c051d9be35d7b7dbd08d8139abc979ba6a239dd8..0000000000000000000000000000000000000000
--- a/pcl/kcl-patches.lisp
+++ /dev/null
@@ -1,362 +0,0 @@
-;;;-*-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 "COMPILER")
-
-#+akcl
-(eval-when (compile load eval)
-
-(when (<= system::*akcl-version* 609)
-  (pushnew :pre_akcl_610 *features*))
-
-(if (and (boundp 'si::*akcl-version*)
-	 (>= si::*akcl-version* 604))
-    (progn
-      (pushnew :turbo-closure *features*)
-      (pushnew :turbo-closure-env-size *features*))
-    (when (fboundp 'si::allocate-growth) 
-      (pushnew :turbo-closure *features*)))
-
-;; patch around compiler bug.
-(when (<= si::*akcl-version* 609)
-  (let ((vcs "static int Vcs;
-"))
-    (unless (search vcs compiler::*cmpinclude-string*)
-      (setq compiler::*cmpinclude-string*
-	    (concatenate 'string vcs compiler::*cmpinclude-string*)))))
-
-(let ((rset "int Rset;
-"))
-  (unless (search rset compiler::*cmpinclude-string*)
-      (setq compiler::*cmpinclude-string*
-	    (concatenate 'string rset compiler::*cmpinclude-string*))))
-
-(when (get 'si::basic-wrapper 'si::s-data)
-  (pushnew :new-kcl-wrapper *features*)
-  (pushnew :structure-wrapper *features*))
-  
-)
-
-
-#+akcl
-(progn
-
-(unless (fboundp 'real-c2lambda-expr-with-key)
-  (setf (symbol-function 'real-c2lambda-expr-with-key)
-	(symbol-function 'c2lambda-expr-with-key)))
-
-(defun c2lambda-expr-with-key (lambda-list body)
-  (declare (special *sup-used*))
-  (setq *sup-used* t)
-  (real-c2lambda-expr-with-key lambda-list body))
-
-
-;There is a bug in the implementation of *print-circle* that
-;causes some akcl debugging commands (including :bt and :bl)
-;to cause the following error when PCL is being used:
-;Unrecoverable error: value stack overflow.
-
-;When a CLOS object is printed, travel_push_object ends up
-;traversing almost the whole class structure, thereby overflowing
-;the value-stack.
-
-;from lsp/debug.lsp.
-;*print-circle* is badly implemented in kcl.
-;it has two separate problems that should be fixed:
-;  1. it traverses the printed object putting all objects found
-;     on the value stack (rather than in a hash table or some
-;     other structure; this is a problem because the size of the value stack
-;     is fixed, and a potentially unbounded number of objects
-;     need to be traversed), and
-;  2. it blindly traverses all slots of any
-;     kind of structure including std-object structures.
-;     This is safe, but not always necessary, and is very time-consuming
-;     for CLOS objects (because it will always traverse every class).
-
-;For now, avoid using *print-circle* T when it will cause problems.
-
-(eval-when (compile eval)
-(defmacro si::f (op &rest args)
-    `(the fixnum (,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args) )))
-
-(defmacro si::fb (op &rest args)
-    `(,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args) ))
-)
-
-(defun si::display-env (n env)
-  (do ((v (reverse env) (cdr v)))
-      ((or (not (consp v)) (si::fb > (fill-pointer si::*display-string*) n)))
-    (or (and (consp (car v))
-	     (listp (cdar v)))
-	(return))
-    (let ((*print-circle* (can-use-print-circle-p (cadar v))))
-      (format si::*display-string* "~s=~s~@[,~]" (caar v) (cadar v) (cdr v)))))
-
-(defun si::display-compiled-env ( plength ihs &aux
-				      (base (si::ihs-vs ihs))
-				      (end (min (si::ihs-vs (1+ ihs)) (si::vs-top))))
-  (format si::*display-string* "")
-  (do ((i base )
-       (v (get (si::ihs-fname ihs) 'si::debug) (cdr v)))
-      ((or (si::fb >= i end)(si::fb > (fill-pointer si::*display-string*) plength)))
-    (let ((*print-circle* (can-use-print-circle-p (si::vs i))))
-    (format si::*display-string* "~a~@[~d~]=~s~@[,~]"
-	    (or (car v)  'si::loc) (if (not (car v)) (si::f - i base)) (si::vs i)
-	    (si::fb < (setq i (si::f + i 1)) end)))))
-
-(clines "#define objnull_p(x) ((x==OBJNULL)?Ct:Cnil)")
-(defentry objnull-p (object) (object "objnull_p"))
-
-(defun can-use-print-circle-p (x)
-  (catch 'can-use-print-circle-p
-    (can-use-print-circle-p1 x nil)))
-
-(defun can-use-print-circle-p1 (x so-far)
-  (and (not (objnull-p x)) ; because of deficiencies in the compiler, maybe?
-       (if (member x so-far)
-	   (throw 'can-use-print-circle-p t)
-	   (let ((so-far (cons x so-far)))
-	     (flet ((can-use-print-circle-p (x)
-		      (can-use-print-circle-p1 x so-far)))
-	       (typecase x
-		 (vector  (or (not (eq 't (array-element-type x)))
-			      (every #'can-use-print-circle-p x)))
-		 (cons    (and (can-use-print-circle-p (car x))
-			       (can-use-print-circle-p (cdr x))))
-		 (array   (or (not (eq 't (array-element-type x)))
-			      (let* ((rank (array-rank x))
-				     (dimensions (make-list rank)))
-				(dotimes (i rank)
-				  (setf (nth i dimensions) (array-dimension x i)))
-				(or (member 0 dimensions)
-				    (do ((cursor (make-list rank :initial-element 0)))
-					(nil)
-				      (declare (:dynamic-extent cursor))
-				      (unless (can-use-print-circle-p
-					       (apply #'aref x cursor))
-					(return nil))
-				      (when (si::increment-cursor cursor dimensions)
-					(return t)))))))
-		 (t (or (not (si:structurep x))
-			(let* ((def (si:structure-def x))
-			       (name (si::s-data-name def))
-			       (len (si::s-data-length def))
-			       (pfun (si::s-data-print-function def)))
-			  (and (null pfun)
-			       (dotimes (i len t)
-				 (unless (can-use-print-circle-p
-					  (si:structure-ref x name i))
-				   (return nil)))))))))))))
-
-(defun si::apply-display-fun (display-fun  n lis)  
-  (let ((*print-length* si::*debug-print-level*)
-	(*print-level* si::*debug-print-level*)
-	(*print-pretty* nil)
-	(*PRINT-CASE* :downcase)
-	(*print-circle* nil)
-	)
-    (setf (fill-pointer si::*display-string*) 0)
-    (format si::*display-string* "{")
-    (funcall display-fun n lis)
-    (when (si::fb > (fill-pointer si::*display-string*) n)
-      (setf (fill-pointer si::*display-string*) n)
-      (format si::*display-string* "..."))
-
-    (format si::*display-string* "}")
-    )
-  si::*display-string*
-  )
-
-;The old definition of this had a bug:
-;sometimes it returned without calling mv-values.
-(defun si::next-stack-frame (ihs &aux line-info li i k na)
-  (cond ((si::fb < ihs si::*ihs-base*)
-	 (si::mv-values nil nil nil nil nil))
-	((let (fun)
-	   ;; next lower visible ihs
-	   (si::mv-setq (fun i) (si::get-next-visible-fun ihs))
-	   (setq na fun)
-	   (cond ((and (setq line-info (get fun 'si::line-info))
-		       (do ((j (si::f + ihs 1) (si::f - j 1))
-			    (form ))
-			   ((<= j i) nil)
-			 (setq form (si::ihs-fun j))
-			 (cond ((setq li (si::get-line-of-form form line-info))
-				(return-from si::next-stack-frame 
-				  (si::mv-values
-				   i fun li
-				   ;; filename
-				   (car (aref line-info 0))
-				   ;;environment
-				   (list (si::vs (setq k (si::ihs-vs j)))
-					 (si::vs (1+ k))
-					 (si::vs (+ k 2)))))))))))))
-	((and (not (special-form-p na))
-	      (not (get na 'si::dbl-invisible))
-	      (fboundp na))
-	 (si::mv-values i na nil nil
-		    (if (si::ihs-not-interpreted-env i)
-			nil
-			(let ((i (si::ihs-vs i)))
-			  (list (si::vs i) (si::vs (1+ i)) (si::vs (si::f + i 2)))))))
-	(t (si::mv-values nil nil nil nil nil))))
-)
-
-#+pre_akcl_610
-(progn
-
-;(proclaim '(optimize (safety 0) (speed 3) (space 1)))
-
-;Not needed... make-top-level-form generates defuns now.
-;(setq compiler::*compile-ordinaries* t)
-
-(eval-when (compile load eval)
-(unless (fboundp 'original-co1typep)
-  (setf (symbol-function 'original-co1typep) #'co1typep))
-)
-
-(defun new-co1typep (f args)
-  (or (original-co1typep f args)
-      (let ((x (car args))
-	    (type (cadr args)))
-	(when (constantp type)
-	  (let ((ntype (si::normalize-type (eval type))))
-	    (when (and (eq (car ntype) 'satisfies)
-		       (cadr ntype)
-		       (symbolp (cadr ntype))
-		       (symbol-package (cadr ntype)))
-	      (c1expr `(the boolean (,(cadr ntype) ,x)))))))))
-
-(setf (symbol-function 'co1typep) #'new-co1typep)
-
-)
-
-#-(or akcl xkcl)
-(progn
-(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/low.lisp b/pcl/low.lisp
index 3e35436c99e996b508468a25d8e5951a952375ff..ce57ef71e3e9af99924f2fa94e1978faf62ce977 100644
--- a/pcl/low.lisp
+++ b/pcl/low.lisp
@@ -26,7 +26,7 @@
 ;;;
 #+cmu
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/low.lisp,v 1.9 1998/12/20 04:30:21 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/low.lisp,v 1.10 1999/03/11 16:51:10 pw Exp $")
 ;;;
 ;;; This file contains portable versions of low-level functions and macros
 ;;; which are ripe for implementation specific customization.  None of the
@@ -130,30 +130,6 @@
   `(svref ,slots ,index))
 )
 
-#+new-kcl-wrapper
-(progn
-(defvar *init-vector* (make-array 40 :fill-pointer 1 :adjustable t 
-				  :initial-element nil))
-
-(defun get-init-list (i)
-  (declare (fixnum i)(special *slot-unbound*))
-  (loop (when (< i (fill-pointer *init-vector*))
-	  (return (aref *init-vector* i)))
-	(vector-push-extend 
-	 (cons *slot-unbound*
-	       (aref *init-vector* (1- (fill-pointer *init-vector*))))
-	 *init-vector*)))
-
-(defmacro %std-instance-wrapper (instance)
-  `(structure-def ,instance))
-
-(defmacro %std-instance-slots (instance)
-  instance)
-
-(defmacro std-instance-p (x)
-  `(structurep ,x))
-)
-
 (defmacro std-instance-wrapper (x) `(%std-instance-wrapper ,x))
 (defmacro std-instance-slots   (x) `(%std-instance-slots ,x))
 
@@ -198,11 +174,7 @@
 (defconstant *slot-unbound* '..slot-unbound..)
 
 (defmacro %allocate-static-slot-storage--class (no-of-slots)
-  #+new-kcl-wrapper (declare (ignore no-of-slots))
-  #-new-kcl-wrapper
-  `(make-array ,no-of-slots :initial-element *slot-unbound*)
-  #+new-kcl-wrapper
-  (error "don't call this"))
+  `(make-array ,no-of-slots :initial-element *slot-unbound*))
 
 (defmacro std-instance-class (instance)
   `(wrapper-class* (std-instance-wrapper ,instance)))
@@ -303,8 +275,6 @@
 	#-(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)
   )
 
 (defvar *compile-lambda-break-p* nil)
@@ -362,7 +332,7 @@
 (defun doctor-dfun-for-the-debugger (gf dfun) (declare (ignore gf)) dfun)
 
 ;; From braid.lisp
-#-new-kcl-wrapper
+
 (defmacro built-in-or-structure-wrapper (x)
   (once-only (x)
     (if (structure-functions-exist-p) ; otherwise structurep is too slow for this
diff --git a/pcl/lucid-low.lisp b/pcl/lucid-low.lisp
deleted file mode 100644
index ec473574eacb58a2b9b902d88dfe5de92043a2af..0000000000000000000000000000000000000000
--- a/pcl/lucid-low.lisp
+++ /dev/null
@@ -1,384 +0,0 @@
-;;; -*- 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)
-
-(#-LCL3.0 progn #+LCL3.0 lcl:handler-bind 
-    #+LCL3.0 ((lcl:warning #'(lambda (condition)
-			       (declare (ignore condition))
-			       (lcl:muffle-warning))))
-(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"
-		   "STRUCTUREP"         "STRUCTURE-TYPE"  "STRUCTURE-LENGTH"
-		   "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*)
-
-
-
-
-#+lcl3.0
-(progn
-
-(defvar *saved-compilation-speed* 3)
-
-; the production compiler sometimes
-; screws up vars within labels
-
-(defmacro dont-use-production-compiler ()
-  '(eval-when (compile)
-     (setq *saved-compilation-speed* (if LUCID:*USE-SFC* 3 0))
-     (proclaim '(optimize (compilation-speed 3)))))
-
-(defmacro use-previous-compiler ()
-  `(eval-when (compile)
-     (proclaim '(optimize (compilation-speed ,*saved-compilation-speed*)))))
-
-)
-
-(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))
-(progn
-(defstruct-simple-predicate std-instance std-instance-p)
-(defstruct-simple-predicate fast-method-call fast-method-call-p)
-(defstruct-simple-predicate method-call method-call-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.
-	  ;; Only change the name when necessary: maybe it is read-only.
-	  (unless (eq new-name (procedure-ref fn procedure-symbol))
-	    (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)
-(restore-compiler-params)
-
-
-(in-package 'pcl)
-
-(pushnew :structure-wrapper *features*)
-
-(defun structure-functions-exist-p ()
-  t)
-
-(defun structure-instance-p (x)
-  (and (structurep x)
-       (not (eq 'std-instance (structure-type x)))))
-
-(defvar *structure-type* nil)
-(defvar *structure-length* nil)
-
-(defun structure-type-p (type)
-  (declare (special lucid::*defstructs*))
-  (let ((s-data (gethash type lucid::*defstructs*)))
-    (or (and s-data 
-	     (eq 'structure (structure-ref s-data 1 'defstruct))) ; type - Fix this
-	(and type (eq *structure-type* type)))))
-
-(defun structure-type-included-type-name (type)
-  (declare (special lucid::*defstructs*))
-  (let ((s-data (gethash type lucid::*defstructs*)))
-    (and s-data (structure-ref s-data 6 'defstruct)))) ; include - Fix this
-
-(defun structure-type-slot-description-list (type)
-  (declare (special lucid::*defstructs*))
-  (let ((s-data (gethash type lucid::*defstructs*)))
-    (if s-data
-	(nthcdr (let ((include (structure-ref s-data 6 'defstruct)))
-		  (if include
-		      (let ((inc-s-data (gethash include lucid::*defstructs*)))
-			(if inc-s-data
-			    (length (structure-ref inc-s-data 7 'defstruct))
-			    0))
-		      0))
-		(map 'list
-		     #'(lambda (slotd)
-			 (let* ((ds 'lucid::defstruct-slot)
-				(slot-name (system:structure-ref slotd 0 ds))
-				(position (system:structure-ref slotd 1 ds))
-				(accessor (system:structure-ref slotd 2 ds))
-				(read-only-p (system:structure-ref slotd 5 ds)))
-			   (list slot-name accessor
-				 #'(lambda (x)
-				     (system:structure-ref x position type))
-				 (unless read-only-p
-				   #'(lambda (v x)
-				       (setf (system:structure-ref x position type)
-					     v))))))
-		     (structure-ref s-data 7 'defstruct))) ; slots  - Fix this
-	(let ((result (make-list *structure-length*)))
-	  (dotimes (i *structure-length* result)
-	    (let* ((name (format nil "SLOT~D" i))
-		   (slot-name (intern name (or (symbol-package type) *package*)))
-		   (i i))
-	      (setf (elt result i) (list slot-name nil
-					 #'(lambda (x)
-					     (system:structure-ref x i type))
-					 nil))))))))
-
-(defun structure-slotd-name (slotd)
-  (first slotd))
-
-(defun structure-slotd-accessor-symbol (slotd)
-  (second slotd))
-
-(defun structure-slotd-reader-function (slotd)
-  (third slotd))
-
-(defun structure-slotd-writer-function (slotd)
-  (fourth slotd))
diff --git a/pcl/makefile.akcl b/pcl/makefile.akcl
deleted file mode 100644
index 057a3f9de1150a2a29841fcdeac56d9e54e4c69d..0000000000000000000000000000000000000000
--- a/pcl/makefile.akcl
+++ /dev/null
@@ -1,32 +0,0 @@
-# makefile for making pcl -- W. Schelter.
-
-#  Directions:
-# make -f makefile.akcl compile
-# make -f makefile.akcl saved_pcl
-
-SHELL=/bin/sh
-
-LISP=akcl
-
-
-SETUP='(load "pkg.lisp")(load "defsys.lisp")' \
-	'(setq pcl::*default-pathname-extensions* (cons "lisp" "o"))' \
-	'(setq pcl::*pathname-extensions* (cons "lisp" "o"))' \
-	'(load "sys-proclaim.lisp")(compiler::emit-fn t)'
-
-compile:
-	echo ${SETUP} '(pcl::compile-pcl)' | ${LISP}
-
-saved_pcl:
-	echo ${SETUP} '(pcl::load-pcl)(si::save-system "saved_pcl")' | ${LISP}
-
-
-# remake the sys-package.lisp and sys-proclaim.lisp files
-# Those files may be empty on a first build.
-remake-sys-files:
-	echo ${SETUP} '(pcl::load-pcl)(in-package "PCL")(renew-sys-files)' | ${LISP}
-	cp sys-proclaim.lisp xxx
-	cat xxx | sed -e "s/COMPILER::CMP-ANON//g" > sys-proclaim.lisp
-
-clean:
-	rm -f *.o
diff --git a/pcl/misc-kcl-patches.text b/pcl/misc-kcl-patches.text
deleted file mode 100644
index 54bb9c71848d07ad30cb468e45d384ee53d6f7ec..0000000000000000000000000000000000000000
--- a/pcl/misc-kcl-patches.text
+++ /dev/null
@@ -1,340 +0,0 @@
-c/cmpaux.c
-*** c/cmpaux.c    Mon Jul  6 00:14:55 1992
---- ../akcl-1-615/c/cmpaux.c      Thu Jun 18 20:01:07 1992
-***************
-*** 229,239 ****
-      if (leng > 0 && leng < x->st.st_dim && x->st.st_self[leng]==0)
-      return x->st.st_self;
-    if (x->st.st_dim == leng
-        && ( leng % sizeof(object))
-       )
-!     { x->st.st_self[leng] = 0;
-        return x->st.st_self;
-      }
-    else
-      {char *res=malloc(leng+1);
-       bcopy(x->st.st_self,res,leng);
---- 229,240 ----
-      if (leng > 0 && leng < x->st.st_dim && x->st.st_self[leng]==0)
-      return x->st.st_self;
-    if (x->st.st_dim == leng
-        && ( leng % sizeof(object))
-       )
-!     { if(x->st.st_self[leng] != 0)
-!          x->st.st_self[leng] = 0;
-        return x->st.st_self;
-      }
-    else
-      {char *res=malloc(leng+1);
-       bcopy(x->st.st_self,res,leng);
-c/main.c
-*** c/main.c      Mon Jul  6 00:14:59 1992
---- ../akcl-1-615/c/main.c        Fri Jul  3 02:19:37 1992
-***************
-*** 611,621 ****
-            {catch_fatal = -1;
-             if (sgc_enabled)
-               { sgc_quit();}
-             if (sgc_enabled==0)
-               { install_segmentation_catcher() ;}
-!            FEerror("Caught fatal error [memory may be damaged]"); }
-          printf("\nUnrecoverable error: %s.\n", s);
-          fflush(stdout);
-  #ifdef UNIX
-          abort();
-  #endif
---- 611,621 ----
-            {catch_fatal = -1;
-             if (sgc_enabled)
-               { sgc_quit();}
-             if (sgc_enabled==0)
-               { install_segmentation_catcher() ;}
-!            FEerror("Caught fatal error [memory may be damaged] ~A",1,make_simple_string(s)); }
-          printf("\nUnrecoverable error: %s.\n", s);
-          fflush(stdout);
-  #ifdef UNIX
-          abort();
-  #endif
-***************
-*** 853,872 ****
-  
-  siLsave_system()
-  {
-          int i;
-  
-- #ifdef HAVE_YP_UNBIND
--         extern object truename(),namestring();
-          check_arg(1);
-!         /* prevent subsequent consultation of yp by getting
-!            truename now*/
-!         vs_base[0]=namestring(truename(vs_base[0]));
-!         {char name[200];
-!          char *dom = name;
-!          if (0== getdomainname(dom,sizeof(name)))
-!            yp_unbind(dom);}
-  #endif
-          
-          saving_system = TRUE;
-          GBC(t_contiguous);
-  
---- 853,867 ----
-  
-  siLsave_system()
-  {
-          int i;
-  
-          check_arg(1);
-! #ifdef HAVE_YP_UNBIND
-!         /* see unixsave.c */
-!         {char *dname;
-!          yp_get_default_domain(&dname);}
-  #endif
-          
-          saving_system = TRUE;
-          GBC(t_contiguous);
-  
-c/num_log.c
-*** c/num_log.c   Mon Jul  6 00:15:00 1992
---- ../akcl-1-615/c/num_log.c     Mon Jun 15 21:15:59 1992
-***************
-*** 266,286 ****
-          return(~j);
-  }
-  
-  int
-  big_bitp(x, p)
-! object  x;
-! int     p;
-  { GEN u = MP(x);
-    int ans ;
-    int i = p /32;
-    if (signe(u) < 0)
-      {  save_avma;
-         u = complementi(u);
-         restore_avma;
-     }
-!   if (i < lgef(u))
-      { ans = ((MP_ITH_WORD(u,i,lgef(u))) & (1 << p%32));}
-    else if (big_sign(x) < 0) ans = 1;
-    else ans = 0;
-    return ans;
-  }
---- 266,286 ----
-          return(~j);
-  }
-  
-  int
-  big_bitp(x, p)
-! object  x;
-! int     p;
-  { GEN u = MP(x);
-    int ans ;
-    int i = p /32;
-    if (signe(u) < 0)
-      {  save_avma;
-         u = complementi(u);
-         restore_avma;
-     }
-!   if (i < lgef(u) -MP_CODE_WORDS)
-      { ans = ((MP_ITH_WORD(u,i,lgef(u))) & (1 << p%32));}
-    else if (big_sign(x) < 0) ans = 1;
-    else ans = 0;
-    return ans;
-  }
-c/unixsave.c
-*** c/unixsave.c  Mon Jul  6 00:15:07 1992
---- ../akcl-1-615/c/unixsave.c    Fri Jul  3 02:52:36 1992
-***************
-*** 71,81 ****
---- 71,160 ----
-                          break;
-                  } else
-                          break;
-  }
-  
-+ #include "page.h"
-  
-+ /* string is aligned on a word boundary */
-+ int
-+ find_string_in_memory(string,length,other_p,function)
-+      char *string;
-+      int length,other_p;
-+      int *function();
-+ {
-+   int *imem_first,*imem_last,*imem,word;
-+   char *mem;
-+   int len,page_first,page_last,i;
-+   int maxpage = page(heap_end);
-+   if(((int)string & 3) == 0 && length >= 4) /* just to be safe */
-+     {word=*(int *)string;
-+      for (page_first = 0;  page_first < maxpage;  page_first++)
-+        if ((enum type)type_map[page_first] != t_other)
-+          break;
-+      for (;  page_first < maxpage;  page_first++)
-+        if (((enum type)type_map[page_first] == t_other)?other_p:!other_p)
-+          {for (page_last = page_first+1;  page_last < maxpage;  page_last++)
-+             if ( !(((enum type)type_map[page_last] == t_other)?other_p:!other_p) )
-+               break;
-+           imem_first=(int *)pagetochar(page_first);
-+           imem_last=(int *)( ( ((int)pagetochar(page_last)) - length) &~3 );
-+           for (imem = imem_first; imem <= imem_last; imem++)
-+             if (*imem == word)
-+               {mem=(char *)imem;
-+                for(i=4; i<length && mem[i]==string[i]; i++);
-+                if(i>=length)
-+                  if((*function)(mem))
-+                    return TRUE;}}}
-+   return FALSE;
-+ }
-+ 
-+ int 
-+ fsim_first(address)
-+      char *address;
-+ {
-+   return TRUE;
-+ }
-+ 
-+ int 
-+ fsim_reset_pointer(address)
-+      char **address;
-+ {
-+   *address = NULL;
-+   return FALSE;
-+ }
-+ 
-+ #define t_other_PAGES TRUE
-+ #define NOT_t_other_PAGES FALSE
-+ 
-+ int
-+ reset_other_pointers(address)
-+      char *address;
-+ {
-+   int word=(int)address;
-+   find_string_in_memory(&word,4,t_other_PAGES,fsim_reset_pointer);
-+ }
-+ 
-+ int
-+ maybe_reset_pointers(address)
-+      char *address;
-+ {
-+   int word=(int)address;
-+   if(!find_string_in_memory(&word,4,NOT_t_other_PAGES,fsim_first))
-+     reset_other_pointers(address);
-+   return FALSE;
-+ }
-+ 
-+ reset_other_pointers_to_string(string)
-+      char *string;
-+ {
-+   int length=strlen(string)+1;
-+   find_string_in_memory(string,length,t_other_PAGES,maybe_reset_pointers);
-+ }
-+ 
-+ bool saving_system;
-+ 
-  memory_save(original_file, save_file)
-  char *original_file, *save_file;
-  {       MEM_SAVE_LOCALS;
-          char *data_begin, *data_end;
-          int original_data;
-***************
-*** 100,110 ****
---- 179,206 ----
-          n = open(save_file, O_CREAT|O_WRONLY, 0777);
-          if (n != 1 || (save = fdopen(n, "w")) != stdout) {
-                  fprintf(stderr, "Can't open the save file.\n");
-                  exit(1);
-          }
-+ 
-          setbuf(save, stdout_buf);
-+ 
-+ #ifdef HAVE_YP_UNBIND
-+ /* yp_get_default_domain() caches the result of getdomainname() in
-+    a malloc'ed block of memory; and gethostbyname saves the result of
-+    yp_get_default_domain() in yet another chunk of memory.  These
-+    cached values will cause problems if the saved image is run on a
-+    machine having a different local domainname.  [When getdomainname 
-+    is called (by CLX, for example) KCL will wait forever.]  There doesn't
-+    seem to be any way to uncache these things (apparently yp_unbind does 
-+    not do this), nor any good way to find these blocks of memory.         */
-+    
-+         if(saving_system)
-+           {char *dname;
-+            yp_get_default_domain(&dname);
-+            reset_other_pointers(dname);}
-+ #endif
-  
-          READ_HEADER;
-          FILECPY_HEADER;
-  
-          for (n = header.a_data, p = data_begin;  ;  n -= BUFSIZ, p += BUFSIZ)
-cmpnew/cmpcall.lsp
-*** cmpnew/cmpcall.lsp    Mon Jul  6 00:15:13 1992
---- ../akcl-1-615/cmpnew/cmpcall.lsp      Thu Jun 18 21:43:24 1992
-***************
-*** 118,127 ****
---- 118,128 ----
-                          ;;; responsible for maintaining this condition.
-        (let ((*vs* *vs*) (form (caddr funob)))
-             (declare (object form))
-             (cond ((and (listp args)
-                         *use-sfuncall*
-+                        (<= (length (cdr args)) 10)
-                         ;;Determine if only one value at most is required:
-                         (or
-                          (eq *value-to-go* 'trash)
-                          (and (consp *value-to-go*)
-                               (eq (car *value-to-go*) 'var))
-lsp/autoload.lsp
-*** lsp/autoload.lsp      Mon Jul  6 00:15:27 1992
---- ../akcl-1-615/lsp/autoload.lsp        Tue Jun 16 02:36:45 1992
-***************
-*** 430,440 ****
-          '(cons
-            fixnum bignum ratio short-float long-float complex
-            character symbol package hash-table
-            array vector string bit-vector
-            structure stream random-state readtable pathname
-!           cfun cclosure sfun gfun cfdata spice fat-string ))
-  
-  (defun room (&optional x)
-    (let ((l (multiple-value-list (si:room-report)))
-          maxpage leftpage ncbpage maxcbpage ncb cbgbccount npage
-          rbused rbfree nrbpage
---- 430,440 ----
-          '(cons
-            fixnum bignum ratio short-float long-float complex
-            character symbol package hash-table
-            array vector string bit-vector
-            structure stream random-state readtable pathname
-!           cfun cclosure sfun gfun vfun cfdata spice fat-string dclosure))
-  
-  (defun room (&optional x)
-    (let ((l (multiple-value-list (si:room-report)))
-          maxpage leftpage ncbpage maxcbpage ncb cbgbccount npage
-          rbused rbfree nrbpage
-lsp/cmpinit.lsp
-*** lsp/cmpinit.lsp       Mon Jul  6 00:15:28 1992
---- ../akcl-1-615/lsp/cmpinit.lsp Mon Jun 22 17:11:11 1992
-***************
-*** 4,12 ****
-  (setq compiler::*eval-when-defaults* '(compile eval load))
-  (or (fboundp 'si::get-&environment) (load "defmacro.lsp"))
-  ;(or (get 'si::s-data 'si::s-data)
-  ;    (progn (load "../lsp/setf.lsp") (load "../lsp/defstruct.lsp")))
-  (if (probe-file "sys-proclaim.lisp")(load "sys-proclaim.lisp"))
-! 
-! 
-  
-  ;;;;;
---- 4,13 ----
-  (setq compiler::*eval-when-defaults* '(compile eval load))
-  (or (fboundp 'si::get-&environment) (load "defmacro.lsp"))
-  ;(or (get 'si::s-data 'si::s-data)
-  ;    (progn (load "../lsp/setf.lsp") (load "../lsp/defstruct.lsp")))
-  (if (probe-file "sys-proclaim.lisp")(load "sys-proclaim.lisp"))
-! (unless (get 'si::basic-wrapper 'si::s-data)
-!   (setf (get 'si::s-data 'si::s-data) nil)
-!   (load "../lsp/defstruct.lsp"))
-  
-  ;;;;;
diff --git a/pcl/new-kcl-wrapper.text b/pcl/new-kcl-wrapper.text
deleted file mode 100644
index 7f161a6c5b5451b79176dee53f436e02b303403b..0000000000000000000000000000000000000000
--- a/pcl/new-kcl-wrapper.text
+++ /dev/null
@@ -1,2157 +0,0 @@
-The new-kcl-wrapper modifications make the storage of standard-objects
-and structure objects much more similar than before.  These changes should 
-greatly speed up WRAPPER-OF for structure objects and should speed up
-WRAPPER-OF for standard-instances also (but not funcallable instances).
-
-Look first at the defstructs defined here (scan this file for "(defstruct (").
-Then look at cache.lisp, at the "#+structure-wrapper" for the new definition of
-the wrapper structure.  Finally, look in low.lisp, at the 
-"#+new-structure-wrapper" for the definition of %allocate-instance--class.
-
-You need to have akcl-1-615 to use this file.
-
-This file contains new versions of the files V/c/structure.c and 
-V/lsp/defstruct.lsp, as well as small changes to the files c/gbc.c, c/sgbc.c, 
-cmpnew/cmpinit.lsp, lsp/cmpinit.lsp, and lsp/describe.lsp.
-
--- The gbc changes allow the garbage collector to work correctly even when
-structures which define other structures (ones which can be the value of 
-STRUCTURE-DEF) are not allocated in static storage. 
-
-
-c/gbc.c
-*** c/gbc.c       Tue Jun 30 04:11:00 1992
---- ../akcl-1-615/c/gbc.c Tue Jun 30 02:48:04 1992
-***************
-*** 427,453 ****
-                          break;
-                  goto COPY_STRING;
-  
-          case t_structure:
-                  mark_object(x->str.str_def);
-                  p = x->str.str_self;
-                  if (p == NULL)
-!                         break;
-!                 {object def=x->str.str_def;
-!                  unsigned char * s_type = &SLOT_TYPE(def,0);
-!                  unsigned short *s_pos= & SLOT_POS(def,0);
-!                  for (i = 0, j = S_DATA(def)->length;  i < j;  i++)
-                     if (s_type[i]==0) mark_object(STREF(object,x,s_pos[i]));
-                   if ((int)what_to_collect >= (int)t_contiguous) {
-                       if (inheap(x->str.str_self)) {
-                         if (what_to_collect == t_contiguous)
-                           mark_contblock((char *)p,
-!                                         S_DATA(def)->size);
-  
-                       } else
-!                        x->str.str_self = (object *)
-!                          copy_relblock((char *)p, S_DATA(def)->size);
-                     }}
-                  break;
-  
-          case t_stream:
-                  switch (x->sm.sm_mode) {
---- 427,461 ----
-                          break;
-                  goto COPY_STRING;
-  
-          case t_structure:
-+                 x->d.m = 2; 
-                  mark_object(x->str.str_def);
-                  p = x->str.str_self;
-                  if (p == NULL)
-!                         {x->d.m = TRUE; break;}
-!                 {object def=x->str.str_def;
-!                  struct s_data *sdef=S_DATA(def);
-!                  unsigned char *s_type;
-!                  unsigned short *s_pos;
-!                  if((int)what_to_collect >= (int)t_contiguous &&
-!                     !inheap(sdef) && def->d.m==TRUE)
-!                    sdef=(struct s_data *)(((char *)sdef)+(rb_start1-rb_start));
-!                  s_type = sdef->raw->ust.ust_self;
-!                  s_pos = &USHORT(sdef->slot_position,0);
-!                  for (i = 0, j = sdef->length;  i < j;  i++)
-                     if (s_type[i]==0) mark_object(STREF(object,x,s_pos[i]));
-                   if ((int)what_to_collect >= (int)t_contiguous) {
-                       if (inheap(x->str.str_self)) {
-                         if (what_to_collect == t_contiguous)
-                           mark_contblock((char *)p,
-!                                         sdef->size);
-  
-                       } else
-!                         x->str.str_self = (object *)
-!                          copy_relblock((char *)p, sdef->size);
-                     }}
-+                 x->d.m = TRUE; 
-                  break;
-  
-          case t_stream:
-                  switch (x->sm.sm_mode) {
-*** c/sgbc.c      Mon Jun 15 21:16:01 1992
---- akcl-1-615/c/sgbc.c   Wed Jul  1 18:37:24 1992
-***************
-*** 355,386 ****
-                  if (cp == NULL)
-                          break;
-                  goto COPY_STRING;
-  
-          case t_structure:
-                  sgc_mark_object(x->str.str_def);
-                  p = x->str.str_self;
-                  if (p == NULL)
-!                         break;
-!                 {object def=x->str.str_def;
-!                  unsigned char * s_type = &SLOT_TYPE(def,0);
-!                  unsigned short *s_pos= & SLOT_POS(def,0);
-!                  for (i = 0, j = S_DATA(def)->length;  i < j;  i++)
-                     if (s_type[i]==0 &&
-                         ON_WRITABLE_PAGE(& STREF(object,x,s_pos[i]))
-                         )
-                       sgc_mark_object(STREF(object,x,s_pos[i]));
-                   if ((int)what_to_collect >= (int)t_contiguous) {
-                       if (inheap(x->str.str_self)) {
-                         if (what_to_collect == t_contiguous)
-                           mark_contblock((char *)p,
-!                                         S_DATA(def)->size);
-  
-                       } else if(SGC_RELBLOCK_P(p))
-                         x->str.str_self = (object *)
-!                          copy_relblock((char *)p, S_DATA(def)->size);
-                     }}
-                  break;
-  
-          case t_stream:
-                  switch (x->sm.sm_mode) {
-                  case smm_input:
---- 355,394 ----
-                  if (cp == NULL)
-                          break;
-                  goto COPY_STRING;
-  
-          case t_structure:
-+                 x->d.m = 2;
-                  sgc_mark_object(x->str.str_def);
-                  p = x->str.str_self;
-                  if (p == NULL)
-!                         {x->d.m = TRUE; break;}
-!                 {object def=x->str.str_def;
-!                  struct s_data *sdef=S_DATA(def);
-!                  unsigned char *s_type;
-!                  unsigned short *s_pos;
-!                  if((int)what_to_collect >= (int)t_contiguous &&
-!                     !inheap(sdef) && def->d.m==TRUE)
-!                    sdef=(struct s_data *)(((char *)sdef)+(rb_start1-rb_start));
-!                  s_type = sdef->raw->ust.ust_self;
-!                  s_pos = &USHORT(sdef->slot_position,0);
-!                  for (i = 0, j = sdef->length;  i < j;  i++)
-                     if (s_type[i]==0 &&
-                         ON_WRITABLE_PAGE(& STREF(object,x,s_pos[i]))
-                         )
-                       sgc_mark_object(STREF(object,x,s_pos[i]));
-                   if ((int)what_to_collect >= (int)t_contiguous) {
-                       if (inheap(x->str.str_self)) {
-                         if (what_to_collect == t_contiguous)
-                           mark_contblock((char *)p,
-!                                         sdef->size);
-  
-                       } else if(SGC_RELBLOCK_P(p))
-                         x->str.str_self = (object *)
-!                          copy_relblock((char *)p, sdef->size);
-                     }}
-+                 x->d.m = TRUE; 
-                  break;
-  
-          case t_stream:
-                  switch (x->sm.sm_mode) {
-                  case smm_input:
-cmpnew/cmpinit.lsp
-*** cmpnew/cmpinit.lsp    Tue Jun 30 04:11:13 1992
---- ../akcl-1-615/cmpnew/cmpinit.lsp      Mon Jun 22 18:41:51 1992
-***************
-*** 4,7 ****
---- 4,10 ----
-  (load "sys-proclaim.lisp")
-  (setq compiler::*eval-when-defaults* '(compile eval load))
-  
-  ;(dolist (v '( cmpeval cmpopt cmptype cmpbind cmpinline cmploc cmpvar cmptop cmplet cmpcall cmpmulti cmplam cmplabel          cmpeval))   (load (format nil "~(~a~).lsp" v)))
-+ (unless (get 'si::basic-wrapper 'si::s-data)
-+   (setf (get 'si::s-data 'si::s-data) nil)
-+   (load "../lsp/defstruct.lsp"))
-lsp/cmpinit.lsp
-*** lsp/cmpinit.lsp       Tue Jun 30 04:11:26 1992
---- ../akcl-1-615/lsp/cmpinit.lsp Mon Jun 22 17:11:11 1992
-***************
-*** 5,12 ****
-  (or (fboundp 'si::get-&environment) (load "defmacro.lsp"))
-  ;(or (get 'si::s-data 'si::s-data)
-  ;    (progn (load "../lsp/setf.lsp") (load "../lsp/defstruct.lsp")))
-  (if (probe-file "sys-proclaim.lisp")(load "sys-proclaim.lisp"))
-! 
-! 
-  
-  ;;;;;
---- 5,13 ----
-  (or (fboundp 'si::get-&environment) (load "defmacro.lsp"))
-  ;(or (get 'si::s-data 'si::s-data)
-  ;    (progn (load "../lsp/setf.lsp") (load "../lsp/defstruct.lsp")))
-  (if (probe-file "sys-proclaim.lisp")(load "sys-proclaim.lisp"))
-! (unless (get 'si::basic-wrapper 'si::s-data)
-!   (setf (get 'si::s-data 'si::s-data) nil)
-!   (load "../lsp/defstruct.lsp"))
-  
-  ;;;;;
-lsp/describe.lsp
-*** lsp/describe.lsp      Tue Jun 30 04:11:27 1992
---- ../akcl-1-615/lsp/describe.lsp        Tue Jun 23 16:39:07 1992
-***************
-*** 266,282 ****
-  
-  (defun inspect-structure (x &aux name)
-    (format t "Structure of type ~a ~%Byte:[Slot Type]Slot Name   :Slot Value"
-            (setq name (type-of x)))
-!   (let* ((sd (get name 'si::s-data))
-           (spos (s-data-slot-position sd)))
-      (dolist (v (s-data-slot-descriptions sd))
-              (format t "~%~4d:~@[[~s] ~]~20a:~s"   
-!                     (aref spos (nth 4 v))
-!                     (let ((type (nth 2 v)))
-                        (if (eq t type) nil type))
-!                     (car v)
-!                     (structure-ref1 x (nth 4 v))))))
-      
-    
-  (defun inspect-object (object &aux (*inspect-level* *inspect-level*))
-    (inspect-indent)
---- 266,282 ----
-  
-  (defun inspect-structure (x &aux name)
-    (format t "Structure of type ~a ~%Byte:[Slot Type]Slot Name   :Slot Value"
-            (setq name (type-of x)))
-!   (let* ((sd (structure-def x))
-           (spos (s-data-slot-position sd)))
-      (dolist (v (s-data-slot-descriptions sd))
-              (format t "~%~4d:~@[[~s] ~]~20a:~s"   
-!                     (aref spos (slot-offset v))
-!                     (let ((type (slot-type v)))
-                        (if (eq t type) nil type))
-!                     (slot-name v)
-!                     (structure-ref1 x (slot-offset v))))))
-      
-    
-  (defun inspect-object (object &aux (*inspect-level* *inspect-level*))
-    (inspect-indent)
-==============================================================================
-=============================== c/structure.c ================================
-Changes file for /kcl/c/structure.c
-Usage \n@s[Original text\n@s|Replacement Text\n@s]
-See the file rascal.ics.utexas.edu:/usr2/ftp/merge.c
-for a program to merge change files.  Anything not between
- "\n@s[" and  "\n@s]" is a simply a comment.
-This file was constructed using emacs and  merge.el
- by (Bill Schelter)  wfs@carl.ma.utexas.edu 
-
-
-****Change:(orig (15 17 d))
-@s[object siSstructure_print_function;
-object siSstructure_slot_descriptions;
-object siSstructure_include;
-
-@s|
-@s]
-
-
-****Change:(orig (18 18 a))
-@s[
-
-@s|
-#define COERCE_DEF(x) if (type_of(x)==t_symbol) \
-  x=getf(x->s.s_plist,siLs_data,Cnil)
-
-#define check_type_structure(x) \
-  if(type_of((x))!=t_structure) \
-    FEwrong_type_argument(Sstructure,(x)) 
-
-
-
-@s]
-
-
-****Change:(orig (22 31 c))
-@s[{
-	do {
-		if (type_of(x) != t_symbol)
-		        return(FALSE);
-
-@s,       } while (x != Cnil);
-	return(FALSE);
-}
-
-@s|{ if (x==y) return 1;
-  if (type_of(x)!= t_structure
-      || type_of(y)!=t_structure)
-    FEerror("bad call to structure_subtypep",0);
-  {if (S_DATA(y)->included == Cnil) return 0;
-   while ((x=S_DATA(x)->includes) != Cnil)
-     { if (x==y) return 1;}
-   return 0;
- }}
-
-@s]
-
-
-****Change:(orig (32 32 a))
-@s[
-
-@s|
-static
-bad_raw_type()
-{           FEerror("Bad raw struct type",0);}
-
-
-
-@s]
-
-
-****Change:(orig (34 34 c))
-@s[structure_ref(x, name, n)
-
-@s|structure_ref(x, name, i)
-
-@s]
-
-
-****Change:(orig (36 38 c))
-@s[object x, name;
-int n;
-{
-	int i;
-
-@s|object x, name;
-int i;
-{unsigned short *s_pos;
- COERCE_DEF(name);
- if (type_of(x) != t_structure ||
-     (type_of(name)!=t_structure) ||
-     !structure_subtypep(x->str.str_def, name))
-   FEwrong_type_argument((type_of(name)==t_structure ?
-		          S_DATA(name)->name : name),
-		         x);
- s_pos = &SLOT_POS(x->str.str_def,0);
- switch((SLOT_TYPE(x->str.str_def,i)))
-   {
-   case aet_object: return(STREF(object,x,s_pos[i]));
-   case aet_fix:  return(make_fixnum((STREF(int,x,s_pos[i]))));
-   case aet_ch:  return(code_char(STREF(char,x,s_pos[i])));
-   case aet_bit:
-   case aet_char: return(make_fixnum(STREF(char,x,s_pos[i])));
-   case aet_sf: return(make_shortfloat(STREF(shortfloat,x,s_pos[i])));
-   case aet_lf: return(make_longfloat(STREF(longfloat,x,s_pos[i])));
-   case aet_uchar: return(make_fixnum(STREF(unsigned char,x,s_pos[i])));
-   case aet_ushort: return(make_fixnum(STREF(unsigned short,x,s_pos[i])));
-   case aet_short: return(make_fixnum(STREF(short,x,s_pos[i])));
-   default:
-     bad_raw_type();
-     return 0;
-   }}
-
-@s]
-
-
-****Change:(orig (40 43 c))
-@s[       if (type_of(x) != t_structure ||
-	    !structure_subtypep(x->str.str_name, name))
-		FEwrong_type_argument(name, x);
-	return(x->str.str_self[n]);
-
-@s|
-void
-siLstructure_ref1()
-{object x=vs_base[0];
- int n=fix(vs_base[1]);
- object def;
- check_type_structure(x);
- def=x->str.str_def;
- if(n>= S_DATA(def)->length)
-   FEerror("Structure ref out of bounds",0);
- vs_base[0]=structure_ref(x,x->str.str_def,n);
- vs_top=vs_base+1;
-
-@s]
-
-
-****Change:(orig (45 45 a))
-@s[}
-
-
-@s|}
-
-void
-siLstructure_set1()
-{object x=vs_base[0];
- int n=fix(vs_base[1]);
- object v=vs_base[2];
- object def;
- check_type_structure(x);
- def=x->str.str_def;
- if(n>= S_DATA(def)->length)
-   FEerror("Structure ref out of bounds",0);
- vs_base[0]=structure_set(x,x->str.str_def,n,v);
- vs_top=vs_base+1;
-}  
-
-
-
-@s]
-
-
-****Change:(orig (47 47 c))
-@s[structure_set(x, name, n, v)
-
-@s|structure_set(x, name, i, v)
-
-@s]
-
-
-****Change:(orig (49 51 c))
-@s[object x, name, v;
-int n;
-{
-	int i;
-
-@s|object x, name, v;
-int i;
-{unsigned short *s_pos;
- 
- COERCE_DEF(name);
- if (type_of(x) != t_structure ||
-     type_of(name) != t_structure ||
-     !structure_subtypep(x->str.str_def, name))
-   FEwrong_type_argument((type_of(name)==t_structure ?
-		          S_DATA(name)->name : name)
-		         , x);
-
-@s]
-
-
-****Change:(orig (53 57 c))
-@s[       if (type_of(x) != t_structure ||
-	    !structure_subtypep(x->str.str_name, name))
-		FEwrong_type_argument(name, x);
-	x->str.str_self[n] = v;
-
-@s,       return(v);
-
-@s|#ifdef SGC
- /* make sure the structure header is on a writable page */
- if (x->d.m) FEerror("bad gc field",0); else  x->d.m = 0;
-#endif   
- 
- s_pos= & SLOT_POS(x->str.str_def,0);
- switch(SLOT_TYPE(x->str.str_def,i)){
-   
-   case aet_object: STREF(object,x,s_pos[i])=v; break;
-   case aet_fix:  (STREF(int,x,s_pos[i]))=fix(v); break;
-   case aet_ch:  STREF(char,x,s_pos[i])=char_code(v); break;
-   case aet_bit:
-   case aet_char: STREF(char,x,s_pos[i])=fix(v); break;
-   case aet_sf: STREF(shortfloat,x,s_pos[i])=sf(v); break;
-   case aet_lf: STREF(longfloat,x,s_pos[i])=lf(v); break;
-   case aet_uchar: STREF(unsigned char,x,s_pos[i])=fix(v); break;
-   case aet_ushort: STREF(unsigned short,x,s_pos[i])=fix(v); break;
-   case aet_short: STREF(short,x,s_pos[i])=fix(v); break;
- default:
-   bad_raw_type();
-
-   }
- return(v);
-
-@s]
-
-
-****Change:(orig (59 59 a))
-@s[}
-
-
-@s|}
-
-void
-siLstructure_subtype_p()
-{object x,y;
- check_arg(2);
- x=vs_base[0];
- y=vs_base[1];
- if (type_of(x)!=t_structure)
-   {vs_base[0]=Cnil; goto BOTTOM;}
- x=x->str.str_def;
- COERCE_DEF(y);
- if (structure_subtypep(x,y)) vs_base[0]=Ct;
- else vs_base[0]=Cnil;
- BOTTOM:
- vs_top=vs_base+1;
-}
- 
-static object
-slot_name(x)
-     object x;
-{
-  if(type_of(x)==t_cons)
-    return car(x);
-  if(type_of(x)==t_structure)
-    return x->str.str_self[0];
-  return Cnil;
-}
-
-
-@s]
-
-
-****Change:(orig (64 64 a))
-@s[object x;
-{
-	object *p, s;
-
-@s|object x;
-{
-	object *p, s;
-	struct s_data *def=S_DATA(x->str.str_def);
-
-@s]
-
-
-****Change:(orig (66 69 c))
-@s[
-	s = getf(x->str.str_name->s.s_plist,
-	         siSstructure_slot_descriptions, Cnil);
-	vs_push(x->str.str_name);
-
-@s|       
-	s = def->slot_descriptions;
-	vs_push(def->name);
-
-@s]
-
-
-****Change:(orig (72 73 c))
-@s[       for (i=0, n=x->str.str_length;  !endp(s)&&i<n;  s=s->c.c_cdr, i++) {
-		*p = make_cons(car(s->c.c_car), Cnil);
-
-@s|       for (i=0, n=def->length;  !endp(s)&&i<n;  s=s->c.c_cdr, i++) {
-		*p = make_cons(slot_name(s->c.c_car), Cnil);
-
-@s]
-
-
-****Change:(orig (75 75 c))
-@s[               *p = make_cons(x->str.str_self[i], Cnil);
-
-@s|               *p = make_cons(structure_ref(x,x->str.str_def,i), Cnil);
-
-@s]
-
-
-****Change:(orig (81 81 a))
-@s[       stack_cons();
-	return(vs_pop);
-}
-
-
-@s|       stack_cons();
-	return(vs_pop);
-}
-
-void
-
-@s]
-
-
-****Change:(orig (84 85 c))
-@s[       object x;
-	int narg, i;
-
-@s|  object x,name,*base;
-  struct s_data *def;
-  int narg, i,size;
-  base=vs_base;
-  if ((narg = vs_top - base) == 0)
-    too_few_arguments();
-  x = alloc_object(t_structure);
-  name=base[0];
-  COERCE_DEF(name);
-  if (type_of(name)!=t_structure  ||
-      (def=S_DATA(name))->length != --narg)
-    FEerror("Bad make_structure args for type ~a",1,
-	    base[0]);
-  x->str.str_def = name;
-  x->str.str_self = NULL;
-  size=S_DATA(name)->size;
-  base[0] = x;
-  x->str.str_self = (object *)
-    (def->staticp == Cnil ? alloc_relblock(size)
-     : alloc_contblock(size));
-  /* There may be holes in the structure.
-     We want them zero, so that equal can work better.
-     */
-  if (S_DATA(name)->has_holes != Cnil)
-    bzero(x->str.str_self,size);
-  {unsigned char *s_type;
-   unsigned short *s_pos;
-   s_pos= (&SLOT_POS(x->str.str_def,0));
-   s_type = (&(SLOT_TYPE(x->str.str_def,0)));
-   base=base+1;
-   for (i = 0;  i < narg;  i++)
-     {object v=base[i];
-      switch(s_type[i]){
-	     
-      case aet_object: STREF(object,x,s_pos[i])=v; break;
-      case aet_fix:  (STREF(int,x,s_pos[i]))=fix(v); break;
-      case aet_ch:  STREF(char,x,s_pos[i])=char_code(v); break;
-      case aet_bit:
-      case aet_char: STREF(char,x,s_pos[i])=fix(v); break;
-      case aet_sf: STREF(shortfloat,x,s_pos[i])=sf(v); break;
-      case aet_lf: STREF(longfloat,x,s_pos[i])=lf(v); break;
-      case aet_uchar: STREF(unsigned char,x,s_pos[i])=fix(v); break;
-      case aet_ushort: STREF(unsigned short,x,s_pos[i])=fix(v); break;
-      case aet_short: STREF(short,x,s_pos[i])=fix(v); break;
-      default:
-	bad_raw_type();
-
-@s]
-
-
-****Change:(orig (87 97 c))
-@s[       if ((narg = vs_top - vs_base) == 0)
-		too_few_arguments();
-	x = alloc_object(t_structure);
-	x->str.str_name = vs_base[0];
-
-@s,               x->str.str_self[i] = vs_top[i];
-
-@s|      }}
-   vs_top = base;
-   vs_base=base-1;
-
- }
-
-@s]
-
-
-****Change:(orig (99 99 a))
-@s[}
-
-
-@s|}
-
-void
-
-@s]
-
-
-****Change:(orig (103 103 c))
-@s[       object x, y;
-	int i, j;
-
-@s|       object x, y;
-	struct s_data *def;
-
-@s]
-
-
-****Change:(orig (105 105 c))
-@s[
-	check_arg(2);
-
-@s|
-	if (vs_top-vs_base < 1) too_few_arguments();
-
-@s]
-
-
-****Change:(orig (107 110 c))
-@s[       if (type_of(x) != t_structure || x->str.str_name != vs_base[1])
-		FEwrong_type_argument(vs_base[1], x);
-	vs_base[1] = y = alloc_object(t_structure);
-	y->str.str_name = x->str.str_name;
-
-@s|       check_type_structure(x);
-	vs_base[0] = y = alloc_object(t_structure);
-	def=S_DATA(y->str.str_def = x->str.str_def);
-
-@s]
-
-
-****Change:(orig (112 116 c))
-@s[       y->str.str_length = j = x->str.str_length;
-	y->str.str_self = (object *)alloc_relblock(sizeof(object)*j);
-	for (i = 0;  i < j;  i++)
-		y->str.str_self[i] = x->str.str_self[i];
-
-@s,       vs_base++;
-
-@s|       y->str.str_self = (object *)alloc_relblock(def->size);
-	bcopy(x->str.str_self,y->str.str_self,def->size);
-	vs_top=vs_base+1;
-
-@s]
-
-
-****Change:(orig (118 118 a))
-@s[}
-
-
-@s|}
-
-void
-siLcopy_structure_header()
-{
-	object x, y;
-
-	if (vs_top-vs_base < 1) too_few_arguments();
-	x = vs_base[0];
-	check_type_structure(x);
-	vs_base[0] = y = alloc_object(t_structure);
-	y->str.str_def = x->str.str_def;
-	y->str.str_self = x->str.str_self;
-	vs_top=vs_base+1;
-}
-
-
-void
-
-@s]
-
-
-****Change:(orig (122 124 c))
-@s[       if (type_of(vs_base[0]) != t_structure)
-		FEwrong_type_argument(Sstructure, vs_base[0]);
-	vs_base[0] = vs_base[0]->str.str_name;
-
-@s|       check_type_structure(vs_base[0]);
-	vs_base[0] = S_DATA(vs_base[0]->str.str_def)->name;
-
-@s]
-
-
-****Change:(orig (127 127 c))
-@s[}
-
-siLstructure_ref()
-
-@s|}
-
-#define FIND_SLOT(str,name) ((type_of(name)==t_fixnum)?fix(name): \
-		             structure_slot_position(str,name))
-
-object
-structure_ref_new(x, name, i)
-     object x,name,i;
-
-@s]
-
-
-****Change:(orig (129 131 c))
-@s[       object x;
-	int i;
-	check_arg(3);
-
-@s|  return structure_ref(x,name,FIND_SLOT(x,i));
-}
-
-@s]
-
-
-****Change:(orig (133 144 c))
-@s[       x = vs_base[0];
-	if (type_of(x) != t_structure ||
-	    !structure_subtypep(x->str.str_name, vs_base[1]))
-		FEwrong_type_argument(vs_base[1], x);
-
-@s,       vs_base[0] = x->str.str_self[i];
-	vs_top = vs_base+1;
-
-@s|object
-structure_set_new(x, name, i, v)
-     object x,name,i,v;
-{
-  return structure_set(x,name,FIND_SLOT(x,i),v);
-
-@s]
-
-
-****Change:(orig (146 146 a))
-@s[}
-
-
-@s|}
-
-void
-siLstructure_ref()
-{
-  check_arg(3);
-  vs_base[0]=structure_ref_new(vs_base[0],vs_base[1],vs_base[2]);
-  vs_top=vs_base+1;
-}
-
-void
-
-@s]
-
-
-****Change:(orig (149 150 d))
-@s[siLstructure_set()
-{
-	object x;
-	int i;
-
-@s|siLstructure_set()
-{
-
-@s]
-
-
-****Change:(orig (152 163 c))
-@s[
-	x = vs_base[0];
-	if (type_of(x) != t_structure ||
-	    !structure_subtypep(x->str.str_name, vs_base[1]))
-
-@s,       x->str.str_self[i] = vs_base[3];
-
-@s|       structure_set_new(vs_base[0],vs_base[1],vs_base[2],vs_base[3]);
-
-@s]
-
-
-****Change:(orig (166 166 a))
-@s[       vs_base = vs_top-1;
-}
-
-
-@s|       vs_base = vs_top-1;
-}
-
-void
-
-@s]
-
-
-****Change:(orig (228 228 c))
-@s[init_structure_function()
-
-@s|void
-siLmake_s_data_structure()
-{object x,y,raw,*base;
- int i;
- check_arg(5);
- x=vs_base[0];
- base=vs_base;
- raw=vs_base[1];
- y=alloc_object(t_structure);
- y->str.str_def=y;
- y->str.str_self = (object *)( x->v.v_self);
- S_DATA(y)->name  =siLs_data;
- S_DATA(y)->length=(raw->v.v_dim);
- S_DATA(y)->raw   =raw;
- for(i=3; i<raw->v.v_dim; i++)
-   y->str.str_self[i]=Cnil;
- S_DATA(y)->slot_position=base[2];
- S_DATA(y)->slot_descriptions=base[3];
- S_DATA(y)->staticp=base[4];
- S_DATA(y)->size = (raw->v.v_dim)*sizeof(object);
- vs_base[0]=y;
- vs_top=vs_base+1;
-}
-
-object siSstructure_init,siSstructure_init_named;
-object siSname,siSdefault_init;
-object siSraw,siSslot_position,siSsize,siSstaticp,siSslot_descriptions;
-
-static object
-slot_value(str,name)
-     object str,name;
-
-@s]
-
-
-****Change:(orig (230 237 c))
-@s[       siSstructure_print_function
-	= make_si_ordinary("STRUCTURE-PRINT-FUNCTION");
-	enter_mark_origin(&siSstructure_print_function);
-	siSstructure_slot_descriptions
-
-@s,       enter_mark_origin(&siSstructure_include);
-
-@s| top:
-  if(type_of(str)==t_structure)
-    return structure_ref_new(str,str->str.str_def,name);
-  if(str->c.c_car==siSstructure_init_named)
-    {object new=get(str->c.c_cdr,siLs_data);
-     str->c.c_car=siSstructure_init;
-     str->c.c_cdr=(type_of(new)==t_structure)?new:cdr(new);}
-  if(siSstructure_init!=car(str))
-    FEerror("Illegal call to SI:MAKE-STRUCTURES 1",0);
-  {object key=intern(coerce_to_string(name),keyword_package);
-   object value=getf(cdddr(str),key,NULL);
-   if(value!=NULL)
-     return value;
-   else
-     {object slots;
-      if(str==caddr(str)&&name==siSslot_descriptions)
-	FEerror("Illegal call to SI:MAKE-STRUCTURES 2",0);
-      slots=slot_value(caddr(str),siSslot_descriptions);
-      for(;!endp(slots);slots=cdr(slots))
-	if(name==slot_value(car(slots),siSname))
-	  {object result,form=slot_value(car(slots),siSdefault_init);
-	   object *old_vs_base=vs_base,*old_vs_top=vs_top;
-	   vs_base=vs_top;vs_push(form);Leval();result=vs_base[0];
-	   vs_base=old_vs_base; vs_top=old_vs_top;
-	   return result;}
-      FEerror("Illegal call to SI:MAKE-STRUCTURES 3",0);}}
-  return Cnil;
-}
-
-@s]
-
-
-****Change:(orig (238 238 a))
-@s[
-
-@s|
-int 
-structure_slot_position(str,name)
-     object str,name;
-{
-  if(type_of(name)==t_fixnum)
-    return fix(name);
-  else
-    {object slotd_list;
-     int pos;
-     check_type_structure(str);
-     slotd_list=S_DATA(str->str.str_def)->slot_descriptions;
-     for(pos=0; type_of(slotd_list)==t_cons; pos++,slotd_list=cdr(slotd_list))
-       {object slotd=car(slotd_list);
-	if(name==((type_of(slotd)==t_structure)?
-		  slotd->str.str_self[0]:slot_value(slotd,siSname)))
-	  return pos;}
-     FEerror("Slot ~S not found in structure ~S",2,name,str);
-     return 0;}  
-}
-
-static object
-make_structures_internal(value)
-     object value;
-{
-  object str,def;
-  int def_index,i,ind;
-
-  switch(type_of(value))
-    {case t_cons:
-       if(value->c.c_car==siSstructure_init_named)
-	 {object new=get(value->c.c_cdr,siLs_data);
-	  value->c.c_car=siSstructure_init;
-	  value->c.c_cdr=(type_of(new)==t_structure)?new:cdr(new);}
-       if(car(value)!=siSstructure_init)
-	 {value->c.c_car=make_structures_internal(value->c.c_car);
-	  value->c.c_cdr=make_structures_internal(value->c.c_cdr);
-	  break;}
-       if(type_of(cadr(value))==t_structure)
-	 {value=value->c.c_cdr->c.c_car;
-	  break;}
-       {object def=caddr(value),plist=cdddr(value),result;
-	object slots,slots_tail;
-	int size,staticp,len,i;
-	if(def!=value)def=make_structures_internal(def);
-	result=alloc_object(t_structure);
-	result->str.str_def=(def==value)?result:def;
-	result->str.str_self=NULL;
-	value->c.c_cdr->c.c_car=result;
-	size=fixint(slot_value(def,siSsize));
-	staticp=Cnil!=slot_value(def,siSstaticp);
-	slots=slot_value(def,siSslot_descriptions);
-	len=length(slots);
-	result->str.str_self=(object *)(staticp?alloc_contblock(size):
-		                                alloc_relblock(size));
-	bzero(result->str.str_self,size);
-	if(def==value)
-	  {S_DATA(result)->raw=slot_value(def,siSraw);
-	   S_DATA(result)->slot_position=slot_value(def,siSslot_position);}
-	for(i=0,slots_tail=slots; i<len; i++,slots_tail=cdr(slots_tail))
-	  {object svalue=slot_value(value,slot_value(car(slots_tail),siSname));
-	   structure_set(result,result->str.str_def,i,svalue);}
-	for(i=0,slots_tail=slots; i<len; i++,slots_tail=cdr(slots_tail))
-	  {object svalue=structure_ref(result,result->str.str_def,i);
-	   svalue=make_structures_internal(svalue);
-	   structure_set(result,result->str.str_def,i,svalue);}
-	value=result;
-	break;}
-     case t_vector:
-       if ((enum aelttype)value->v.v_elttype == aet_object)
-	 {int i,len=value->v.v_dim;
-	  for(i=0; i<len; i++)
-	    value->v.v_self[i]=make_structures_internal(value->v.v_self[i]);}
-       break;
-     case t_symbol:
-       {object plist=value->s.s_plist,next;
-	for(;!endp(plist);plist=cddr(plist))
-	  {next=plist->c.c_cdr;
-	   if(plist->c.c_car==siLs_data&&
-	      type_of(next->c.c_car)==t_cons)
-	     next->c.c_car=make_structures_internal(next->c.c_car);}
-	break;}}
-  return value;   
-}
-
-void
-siLmake_structures()
-{
-  check_arg(1);
-  vs_base[0]=make_structures_internal(vs_base[0]);
-}
-
-void
-siLstructure_def()
-{check_arg(1);
- check_type_structure(vs_base[0]);
-  vs_base[0]=vs_base[0]->str.str_def;
-}
-
-short aet_sizes [] = {
-sizeof(object),  /* aet_object  t  */
-sizeof(char),  /* aet_ch  string-char  */
-sizeof(char),  /* aet_bit  bit  */
-sizeof(fixnum),  /* aet_fix  fixnum  */
-sizeof(float),  /* aet_sf  short-float  */
-sizeof(double),  /* aet_lf  long-float  */
-sizeof(char),  /* aet_char  signed char */
-sizeof(char),  /* aet_uchar  unsigned char */
-sizeof(short),  /* aet_short  signed short */
-sizeof(short)  /* aet_ushort  unsigned short   */
-};
-
-  
-
-
-
-void
-siLsize_of() 
-{ object x= vs_base[0];
-  int i;
-  i= aet_sizes[get_aelttype(x)];
-  vs_base[0]=make_fixnum(i);
-}
-  
-void
-siLaet_type()
-{vs_base[0]=make_fixnum(get_aelttype(vs_base[0]));}
-
-
-/* Return N such that something of type ARG can be aligned on
-   an address which is a multiple of N */
-
-
-void
-siLalignment()
-{struct {double x; int y; double z;
-	 float x1; int y1; float z1;}
- joe;
- joe.z=3.0;
- 
- if (vs_base[0]==Slong_float)
-   {vs_base[0]=make_fixnum((int)&joe.z- (int)&joe.y); return;}
- else
-   if (vs_base[0]==Sshort_float)
-     {vs_base[0]=make_fixnum((int)&(joe.z1)-(int)&(joe.y1)); return;}
-   else
-     {siLsize_of();}
-}
-   
-void
-swap_structure_contents(str1,str2)
-   object str1,str2;
-{
-  object def1,*self1;
-  check_type_structure(str1);
-  check_type_structure(str2);
-  def1=str1->str.str_def;
-  self1=str1->str.str_self;
-  str1->str.str_def=str2->str.str_def;
-  str1->str.str_self=str2->str.str_self;
-  str2->str.str_def=def1;
-  str2->str.str_self=self1;
-}
-
-void
-siLswap_structure_contents()
-{
-  check_arg(2);
-  swap_structure_contents(vs_base[0],vs_base[1]);
-  vs_base[0]=Cnil;
-  vs_top=vs_base+1;
-}
-
-void
-siLset_structure_def()
-{check_arg(2);
- check_type_structure(vs_base[0]);
- check_type_structure(vs_base[1]);
- vs_base[0]->str.str_def=vs_base[1];
- vs_base[0]=vs_base[1];
- vs_top=vs_base+1;
-}
-
-init_structure_function()
-{
-        siLs_data=make_si_ordinary("S-DATA");
-	siSstructure_init=make_si_ordinary("STRUCTURE-INIT");
-	siSstructure_init_named=make_si_ordinary("STRUCTURE-INIT-NAMED");
-	siSname=make_si_ordinary("NAME");
-	siSdefault_init=make_si_ordinary("DEFAULT-INIT");
-	siSraw=make_si_ordinary("RAW");
-	siSslot_position=make_si_ordinary("SLOT-POSITION");
-	siSsize=make_si_ordinary("SIZE");
-	siSstaticp=make_si_ordinary("STATICP");
-	siSslot_descriptions=make_si_ordinary("SLOT-DESCRIPTIONS");
-
-@s]
-
-
-****Change:(orig (239 239 a))
-@s[       make_si_function("MAKE-STRUCTURE", siLmake_structure);
-
-@s|       make_si_function("MAKE-STRUCTURE", siLmake_structure);
-	make_si_function("MAKE-S-DATA-STRUCTURE",siLmake_s_data_structure);
-
-@s]
-
-
-****Change:(orig (240 240 a))
-@s[       make_si_function("COPY-STRUCTURE", siLcopy_structure);
-
-@s|       make_si_function("COPY-STRUCTURE", siLcopy_structure);
-	make_si_function("COPY-STRUCTURE-HEADER", siLcopy_structure_header);
-
-@s]
-
-
-****Change:(orig (242 242 a))
-@s[       make_si_function("STRUCTURE-REF", siLstructure_ref);
-
-@s|       make_si_function("STRUCTURE-REF", siLstructure_ref);
-	make_si_function("STRUCTURE-DEF", siLstructure_def);
-	make_si_function("STRUCTURE-REF1", siLstructure_ref1);
-	make_si_function("STRUCTURE-SET1", siLstructure_set1);
-
-@s]
-
-
-****Change:(orig (245 245 c))
-@s[       make_si_function("STRUCTUREP", siLstructurep);
-
-
-@s|       make_si_function("STRUCTUREP", siLstructurep);
-	make_si_function("SIZE-OF", siLsize_of);
-	make_si_function("ALIGNMENT",siLalignment);
-	make_si_function("STRUCTURE-SUBTYPE-P",siLstructure_subtype_p);
-
-@s]
-
-
-****Change:(orig (247 247 a))
-@s[       make_si_function("LIST-NTH", siLlist_nth);
-
-@s|       make_si_function("LIST-NTH", siLlist_nth);
-	make_si_function("AET-TYPE",siLaet_type);
-	make_si_function("SWAP-STRUCTURE-CONTENTS",siLswap_structure_contents);
-	make_si_function("SET-STRUCTURE-DEF", siLset_structure_def);
-	make_si_function("MAKE-STRUCTURES", siLmake_structures);
-
-
-@s]
-
-==============================================================================
-============================== V/lsp/defstruct.lsp =============================
-Changes file for /kcl/lsp/defstruct.lsp
-Usage \n@s[Original text\n@s|Replacement Text\n@s]
-See the file rascal.ics.utexas.edu:/usr2/ftp/merge.c
-for a program to merge change files.  Anything not between
- "\n@s[" and  "\n@s]" is a simply a comment.
-This file was constructed using emacs and  merge.el
- by (Bill Schelter)  wfs@carl.ma.utexas.edu 
-
-
-****Change:(orig (20 71 c))
-@s[(defun make-access-function (name conc-name type named
-                             slot-name default-init slot-type read-only
-                             offset)
-  (declare (ignore named default-init slot-type))
-
-@s,          ((error "~S is an illegal structure type." type)))))
-
-@s|(defvar *accessors* (make-array 10 :adjustable t))
-(defvar *list-accessors* (make-array 2 :adjustable t))
-(defvar *vector-accessors* (make-array 2 :adjustable t))
-
-@s]
-
-
-****Change:(orig (72 72 a))
-@s[
-
-@s|
-(or (fboundp 'record-fn) (setf (symbol-function 'record-fn)
-		               #'(lambda (&rest l) l nil)))
-
-@s]
-
-
-****Change:(orig (73 73 a))
-@s[
-
-@s|
-(defun boot-slot-value (str name)
-  (if (structurep str)
-      (structure-ref str (structure-def str) name)
-      (getf (cdddr str) (intern (string name) :keyword))))
-
-(defun boot-set-slot-value (str name new-value)
-  (if (structurep str)
-      (structure-set str (structure-def str) name new-value)
-      (setf (getf (cdddr str) (intern (string name) :keyword)) new-value)))
-
-(defun boot-subtypep (type1 type2)
-  (or (eq type1 type2)
-      (let* ((s-data (get type1 's-data))
-	     (include (boot-s-data-name (boot-slot-value s-data 'includes))))
-	(boot-subtypep include type2))))
-
-(defun make-slot-boot (&rest args)
-  (if (get 's-data 's-data)
-      (apply #'make-slot args)
-      (list* 'structure-init
-	     nil
-	     '(structure-init-named . slot)
-	     args)))
-
-(defun make-s-data-boot (&rest args)
-  (if (get 's-data 's-data)
-      (apply #'make-s-data args)
-      (list* 'structure-init
-	     nil
-	     '(structure-init-named . s-data)
-	     args)))
-
-(defun make-boot-accessor (slot accessor)
-  (setf (symbol-function accessor) 
-	#'(lambda (object)
-	    (boot-slot-value object slot)))
-  (let ((writer (intern (format nil "SET ~A" accessor))))
-    (setf (symbol-function writer)
-	  #'(lambda (object value)
-	      (boot-set-slot-value object slot value)))
-    (eval `(defsetf ,accessor ,writer))))
-
-(defmacro defstructboot (name &rest slots)
-  (let ((conc-name (if (listp name)
-		       (string (second (assoc :conc-name (cdr name))))
-		       (format nil "~A-" name))))
-    `(progn
-       ,@(mapcar #'(lambda (slot)
-		     (let ((fname (intern (format nil "~A~A" conc-name slot))))
-		       `(make-boot-accessor ',slot ',fname)))
-	         slots))))
-
-(defstructboot (slot (:conc-name boot-slot-))
-  name default-init type read-only offset accessor-name type-changed)
-
-(defstructboot (s-data-internal (:conc-name boot-s-data-))
-  name length raw included includes staticp print-function
-  slot-descriptions slot-position size has-holes)
-
-(defstructboot (basic-wrapper (:conc-name boot-wrapper-))
-  cache-number-vector state class)
-
-(defstructboot (s-data (:conc-name boot-s-data-))
-  frozen documentation constructors offset
-  named type conc-name)
-
-(defun make-access-function (name conc-name type named include no-fun slot)
-  (declare (ignore named))
-  
-  (let* ((slot-name (boot-slot-name slot))
-	 (slot-type (boot-slot-type slot))
-	 (read-only (boot-slot-read-only slot))
-	 (offset (boot-slot-offset slot))
-	 (access-function
-	  (intern (si:string-concatenate (string conc-name)
-		                         (string slot-name))))
-	accsrs dont-overwrite)
-    (unless (boot-slot-accessor-name slot)
-      (setf (boot-slot-accessor-name slot) access-function))
-    (ecase type
-      ((nil)
-       (setf accsrs *accessors*))
-      (list
-	(setf accsrs *list-accessors*))
-      (vector
-	(setf accsrs *vector-accessors*)))
-    (or (> (length  accsrs) offset)
-	(adjust-array accsrs (+ offset 10)))
-    (unless
-     dont-overwrite
-     (record-fn access-function 'defun '(t) slot-type)
-     (or no-fun
-	 (and (fboundp access-function)
-	      (eq (aref accsrs offset) (symbol-function access-function)))
-	 (setf (symbol-function access-function)
-	   (or (aref accsrs offset)
-	       (setf (aref accsrs offset)
-		     (cond  ((eq accsrs *accessors*)
-		                #'(lambda (x)
-		                    (or (structurep x)
-		                        (error "~a is not a structure" x))
-		                    (structure-ref1 x offset)))
-		               ((eq accsrs *list-accessors*)
-		                #'(lambda(x)
-		                    (si:list-nth offset x)))
-		               ((eq accsrs *vector-accessors*)
-		                #'(lambda(x)
-		                    (aref x offset)))))))))
-    (cond (read-only
-	    (remprop access-function 'structure-access)
-	    (setf (get access-function 'struct-read-only) t))
-	  (t (remprop access-function 'setf-update-fn)
-	     (remprop access-function 'setf-lambda)
-	     (remprop access-function 'setf-documentation)
-	     (let ((tem (get access-function 'structure-access)))
-	       (cond ((and (consp tem) include
-		           (if (consp (get include 's-data))
-		               (boot-subtypep include (car tem))
-		               (subtypep include (car tem)))
-		           (eql (cdr tem) offset))
-		      ;; don't change overwrite accessor of subtype.
-		      (setq dont-overwrite t)
-		      )
-		     (t  (setf (get access-function 'structure-access)
-		               (cons (if type type name) offset)))))))
-    nil))
-
-
-@s]
-
-
-****Change:(orig (80 89 c))
-@s[                     (cond ((null x)
-                            ;; If the slot-description is NIL,
-                            ;;  it is in the padding of initial-offset.
-                            nil)
-
-@s,                           (t (car x))))
-
-@s|                    (or (boot-slot-name x)
-		         (and (boot-slot-default-init x)
-		              ;; If the slot name is NIL,
-		              ;;  it is the structure name.
-		              ;;  This is for typed structures with names.
-		              (list 'quote (boot-slot-default-init x)))))
-
-@s]
-
-
-****Change:(orig (94 97 c))
-@s[                     (cond ((null x) nil)
-                           ((null (car x)) nil)
-                           ((null (cadr x)) (list (car x)))
-                           (t (list (list  (car x) (cadr x))))))
-
-@s|                    (when (boot-slot-name x)
-		       (if (boot-slot-default-init x)
-		           (list (list (boot-slot-name x) (boot-slot-default-init x)))
-		           (list (boot-slot-name x)))))
-
-@s]
-
-
-****Change:(orig (248 248 d))
-@s[          ((error "~S is an illegal structure type" type)))))
-
-
-
-@s|          ((error "~S is an illegal structure type" type)))))
-
-
-@s]
-
-
-****Change:(orig (252 265 d))
-@s[
-(defun make-copier (name copier type named)
-  (declare (ignore named))
-  (cond ((null type)
-
-@s,        ((error "~S is an illegal structure type." type))))
-
-
-
-@s|
-@s]
-
-
-****Change:(orig (267 275 c))
-@s[  (cond ((null type)
-         ;; If TYPE is NIL, the predicate searches the link
-         ;;  of structure-include, until there is no included structure.
-         `(defun ,predicate (x)
-
-@s,                   (setq n (get n 'structure-include))))))
-
-@s|  (cond ((null type))
-	 ; done in define-structure
-
-@s]
-
-
-****Change:(orig (282 283 c))
-@s[                 (> (length x) ,name-offset)
-                 (eq (elt x ,name-offset) ',name))))
-
-@s|                 (> (the fixnum (length x)) ,name-offset)
-                 (eq (aref (the (vector t) x) ,name-offset) ',name))))
-
-@s]
-
-
-****Change:(orig (294 294 a))
-@s[                         ((= i 0) (and (consp y) (eq (car y) ',name)))
-
-@s|                         ((= i 0) (and (consp y) (eq (car y) ',name)))
-		         (declare (fixnum i))
-
-@s]
-
-
-****Change:(orig (300 301 c))
-@s[;;;  and returns a list of the form:
-;;;        (slot-name default-init slot-type read-only offset)
-
-@s|;;;  and returns a slot.
-
-@s]
-
-
-****Change:(orig (325 325 c))
-@s[    (list slot-name default-init slot-type read-only offset)))
-
-@s|    (make-slot-boot :name slot-name
-		    :default-init default-init
-		    :type slot-type
-		    :read-only read-only
-		    :offset offset)))
-
-@s]
-
-
-****Change:(orig (335 335 c))
-@s[      (let ((sds (member (caar olds) news :key #'car)))
-
-@s|      (let* ((old (car olds))
-	     (sds (member (boot-slot-name old) news :key #'slot-name))
-	     (new (car sds)))
-
-@s]
-
-
-****Change:(orig (337 348 c))
-@s[               (when (and (null (cadddr (car sds)))
-                          (cadddr (car olds)))
-                     ;; If read-only is true in the old
-                     ;;  and false in the new, signal an error.
-
-@s,                           (car (cddddr (car olds))))
-
-@s|               (when (and (null (boot-slot-read-only new))
-                          (boot-slot-read-only old))
-		 ;; If read-only is true in the old
-		 ;;  and false in the new, signal an error.
-		 (error "~S is an illegal include slot-description."
-		        new))
-	       ;; If
-	       (setf (boot-slot-type new)
-		     (best-array-element-type (boot-slot-type new)))
-	       (when (not (equal (normalize-type (or (boot-slot-type new) t))
-		                 (normalize-type (or (boot-slot-type old) t))))
-		 (error "Type mismmatch for included slot ~a" new))
-	       (cons (make-slot :name (boot-slot-name new)
-		                :default-init (boot-slot-default-init new)
-		                :type (boot-slot-type new)
-		                :read-only (boot-slot-read-only new)
-		                :offset (boot-slot-offset old))
-
-@s]
-
-
-****Change:(orig (353 353 a))
-@s[                     (overwrite-slot-descriptions news (cdr olds))))))))
-
-
-@s|                     (overwrite-slot-descriptions news (cdr olds))))))))
-
-(defvar *all-t-s-type* (make-array 50 :element-type 'unsigned-char :static t))
-
-@s]
-
-
-****Change:(orig (355 355 c))
-@s[;;; The DEFSTRUCT macro.
-
-@s|(defun make-t-type (n include slot-descriptions &aux i)
-  (let ((res  (make-array n :element-type 'unsigned-char :static t)))
-    (when include
-      (let ((tem (get include 's-data))raw)
-	(or tem (error "Included structure undefined ~a" include))
-	(setq raw (boot-s-data-raw tem))
-	(dotimes (i (min n (length raw)))
-	  (setf (aref res i) (aref raw i)))))
-    (dolist (v slot-descriptions)
-      (setq i (boot-slot-offset v))
-      (let ((type (boot-slot-type v)))
-	(cond ((<= (the fixnum (alignment type)) #. (alignment t))
-	       (setf (aref res i) (aet-type type))))))
-    (cond ((< n (length *all-t-s-type*))
-	   (dotimes (i n)
-	     (cond ((not (eql (the fixnum (aref res i)) 0))
-		    (return-from make-t-type res))))
-	   *all-t-s-type*)
-	  (t res))))
-
-@s]
-
-
-****Change:(orig (356 356 a))
-@s[
-
-@s|
-(defvar *standard-slot-positions*
-  (let ((ar (make-array 50 :element-type 'unsigned-short
-		        :static t))) 
-    (dotimes (i 50)
-	     (declare (fixnum i))
-	     (setf (aref ar i)(* #. (size-of t) i)))
-    ar))
-
-(eval-when (compile )
-(proclaim '(function round-up (fixnum fixnum ) fixnum))
-)
-
-(defun round-up (a b)
-  (declare (fixnum a b))
-  (setq a (ceiling a b))
-  (the fixnum (* a b)))
-
-
-(defun get-slot-pos (leng include slot-descriptions &aux type small-types
-		          has-holes) 
-  (declare (special *standard-slot-positions*)) include
-  (dolist (v slot-descriptions)
-    (when (boot-slot-name v)
-      (setf type (best-array-element-type (boot-slot-type v))
-	    (boot-slot-type v) type)
-      (let ((val (boot-slot-default-init v)))
-	(unless (typep val type)
-	  (if (and (symbolp val)
-		   (constantp val))
-	      (setf val (symbol-value val)))
-	  (and (constantp val)
-	       (setf (boot-slot-default-init v) (coerce val type)))))
-      (cond ((memq type '(signed-char unsigned-char
-		          short unsigned-short
-		          long-float
-		          bit))
-	     (setq small-types t)))))
-  (cond ((and (null small-types)
-	      (< leng (length *standard-slot-positions*))
-	      (list  *standard-slot-positions* (* leng #. (size-of t)) nil)))
-	(t (let ((ar (make-array leng :element-type 'unsigned-short
-		                 :static t))
-		 (pos 0)(i 0)(align 0)type (next-pos 0))
-	     (declare (fixnum pos i align next-pos))
-	     ;; A default array.
-		   
-	     (dolist (v slot-descriptions)
-	       (setq type (boot-slot-type v))
-	       (setq align (alignment type))
-	       (unless (<= align #. (alignment t))
-		 (setq type t)
-		 (setf (boot-slot-type v) t)
-		 (setq align #. (alignment t))
-		 (setf (boot-slot-type-changed v) t))
-	       (setq next-pos (round-up pos align))      
-	       (or (eql pos next-pos) (setq has-holes t))
-	       (setq pos next-pos)
-	       (setf (aref ar i) pos)
-	       (incf pos (size-of type))
-	       (incf i))
-	     (list ar (round-up pos (size-of t)) has-holes)
-	     ))))
-
-
-(defun define-structure (name conc-name type named slot-descriptions copier
-		              static include print-function constructors
-		              offset predicate &optional documentation no-funs
-		              &aux leng)
-  (and (consp type) (eq (car type) 'vector)(setq type 'vector))
-  (setq leng (length slot-descriptions))
-  (setq slot-descriptions 
-	(mapcar #'(lambda (info)
-		    (make-slot-boot :name (first info)
-		                    :default-init (second info)
-		                    :type (third info)
-		                    :read-only (fourth info)
-		                    :offset (fifth info)
-		                    :accessor-name (sixth info)
-		                    :type-changed (seventh info)))
-		slot-descriptions))
-  (dolist (x slot-descriptions)
-    (when (boot-slot-name x)
-      (make-access-function name conc-name type named include no-funs x)))
-  (when (and copier (not no-funs))
-    (setf (symbol-function copier)
-	  (ecase type
-	    ((nil) #'si::copy-structure)
-	    (list #'copy-list)
-	    (vector #'copy-seq))))
-  (let ((include-str (and include (get include 's-data))))
-    (when (and (eq include 's-data-internal)
-	       (not (eq name 'basic-wrapper)))
-      (error "only ~s can include ~s" 'basic-wrapper 's-data-internal))
-    (when include-str
-      (cond ((and (not (consp include-str))
-		  (s-data-frozen include-str)
-		  (or (not (s-data-included include-str))
-		      (not (let ((te (get name 's-data)))
-		             (and te
-		                  (eq (s-data-includes te)
-		                      include-str))))))
-	     (warn " ~a was frozen but now included"
-		   include)))
-      (let ((old-included (boot-slot-value include-str 'included)))
-	(unless (member name old-included)
-	  (boot-set-slot-value include-str 'included (cons name old-included)))))
-    (let* ((tem (get name 's-data))
-	   (g-s-p (and (null type)
-		       (get-slot-pos leng include slot-descriptions)))
-	   (slot-position (car g-s-p))
-	   (size (if g-s-p (cadr g-s-p) 0))
-	   (has-holes (caddr g-s-p))
-	   (def (make-s-data-boot :name name
-		                  :length leng
-		                  :raw
-		                  (and (null type)
-		                       (make-t-type leng include 
-		                                    slot-descriptions))
-		                  :slot-position slot-position
-		                  :size size
-		                  :has-holes has-holes
-		                  :staticp static
-		                  :includes include-str
-		                  :print-function print-function
-		                  :slot-descriptions slot-descriptions
-		                  :constructors constructors
-		                  :offset offset
-		                  :type type
-		                  :named named
-		                  :documentation documentation
-		                  :conc-name conc-name)))
-      (check-s-data tem def name)
-      (when (and (consp def) (eq name 's-data))
-	(make-structures def))))
-  (when documentation
-    (setf (get name 'structure-documentation)
-	  documentation))
-  (when (and  (null type)  predicate)
-    (record-fn predicate 'defun '(t) t)
-    (or no-funs
-	(setf (symbol-function predicate)
-	      #'(lambda (x)
-		  (si::structure-subtype-p x name))))
-    (setf (get predicate 'compiler::co1)
-	  'compiler::co1structure-predicate)
-    (setf (get predicate 'struct-predicate) name))
-  nil)
-
-(defun check-s-data (old new name)
-  (unless (and old (member name '(slot s-data-internal basic-wrapper s-data)))
-    (when (and old (eq (structure-def old) (get 's-data 's-data)))
-      (boot-set-slot-value new 'included (boot-slot-value old 'included))
-      (boot-set-slot-value new 'frozen (boot-slot-value old 'frozen)))
-    (unless (and old
-		 (eq (structure-def old) (get 's-data 's-data))
-		 (let ((new-cnv (boot-slot-value new 'cache-number-vector))
-		       (old-cnv (boot-slot-value old 'cache-number-vector)))
-		   (boot-set-slot-value new 'cache-number-vector old-cnv)
-		   (prog1 (equalp new old)
-		     (boot-set-slot-value new 'cache-number-vector new-cnv))))
-      (when old
-	(warn "structure ~a is changing" name)
-	(when (eq (structure-def old) (get 's-data 's-data))
-	  (boot-set-slot-value old 'state (list ':obsolete new))))
-      (setf (get name 's-data) new))))
-
-
-@s]
-
-
-****Change:(orig (364 364 c))
-@s[        predicate predicate-specified
-        include
-
-@s|        predicate predicate-specified
-        include include-s-data
-
-@s]
-
-
-****Change:(orig (367 367 c))
-@s[        offset name-offset
-        documentation)
-
-@s|        offset name-offset
-        documentation
-	static)
-
-@s]
-
-
-****Change:(orig (370 370 c))
-@s[          ;; The defstruct options are supplied.
-
-@s|         ;; The defstruct options are supplied.
-
-@s]
-
-
-****Change:(orig (390 425 c))
-@s[      (cond ((and (consp (car os)) (not (endp (cdar os))))
-             (setq o (caar os) v (cadar os))
-             (case o
-               (:conc-name
-
-@s,               (t (error "~S is an illegal defstruct option." o))))))
-
-@s|       (cond ((and (consp (car os)) (not (endp (cdar os))))
-	       (setq o (caar os) v (cadar os))
-	       (case o
-		 (:conc-name
-		   (if (null v)
-		       (setq conc-name "")
-		     (setq conc-name v)))
-		 (:constructor
-		   (if (null v)
-		       (setq no-constructor t)
-		     (if (endp (cddar os))
-		         (setq constructors (cons v constructors))
-		       (setq constructors (cons (cdar os) constructors)))))
-		 (:copier (setq copier v))
-		 (:static (setq static v))
-		 (:predicate
-		   (setq predicate v)
-		   (setq predicate-specified t))
-		 (:include
-		   (setq include (cdar os))
-		   (unless (setq include-s-data (get v 's-data))
-		           (error "~S is an illegal included structure." v)))
-		 (:print-function
-		  (and (consp v) (eq (car v) 'function)
-		       (setq v (second v)))
-		  (setq print-function v))
-		 (:type (setq type v))
-		 (:initial-offset (setq initial-offset v))
-		 (t (error "~S is an illegal defstruct option." o))))
-	      (t
-		(if (consp (car os))
-		    (setq o (caar os))
-		  (setq o (car os)))
-		(case o
-		  (:constructor
-		    (setq constructors
-		          (cons default-constructor constructors)))
-		  ((:conc-name :copier :predicate :print-function))
-		  (:named (setq named t))
-		  (t (error "~S is an illegal defstruct option." o))))))
-
-@s]
-
-
-****Change:(orig (426 426 a))
-@s[
-
-@s|
-    (setq conc-name (intern (string conc-name)))
-
-    (and include-s-data (not print-function)
-	 (setq print-function (boot-s-data-print-function include-s-data)))
-
-
-@s]
-
-
-****Change:(orig (434 435 c))
-@s[    (when include
-          (unless (equal type (get (car include) 'structure-type))
-
-@s|    (when include-s-data
-          (unless (equal type (boot-s-data-type include-s-data))
-
-@s]
-
-
-****Change:(orig (442 443 c))
-@s[          (t
-           (setq offset (get (car include) 'structure-offset))))
-
-@s|          (t 
-	    (setq offset (boot-s-data-offset include-s-data))))
-
-@s]
-
-
-****Change:(orig (457 458 c))
-@s[      (setq sds (cons (parse-slot-description (car ds) offset) sds))
-      (setq offset (1+ offset)))
-
-@s|       (setq sds (cons (parse-slot-description (car ds) offset) sds))
-	(setq offset (1+ offset)))
-
-@s]
-
-
-****Change:(orig (464 464 c))
-@s[                (cons (list nil name) slot-descriptions)))
-
-@s|                (cons (make-slot :default-init name) slot-descriptions)))
-
-@s]
-
-
-****Change:(orig (469 469 c))
-@s[                (append (make-list initial-offset) slot-descriptions)))
-
-@s|                (append (mapcar #'make-named-slot (make-list initial-offset))
-		        slot-descriptions)))
-
-@s]
-
-
-****Change:(orig (473 486 c))
-@s[    (cond ((null include))
-          ((endp (cdr include))
-           (setq slot-descriptions
-                 (append (get (car include) 'structure-slot-descriptions)
-
-@s,                         slot-descriptions))))
-
-@s|    (let ((include-slot-descriptions 
-	   (and include
-		(boot-s-data-slot-descriptions include-s-data))))
-      (cond ((null include))
-	    ((endp (cdr include))
-	     (setq slot-descriptions
-		   (append include-slot-descriptions
-		           slot-descriptions)))
-	    (t
-	     (setq slot-descriptions
-		   (append (overwrite-slot-descriptions
-		            (mapcar #'(lambda (sd)
-		                        (parse-slot-description sd 0))
-		                    (cdr include))
-		            include-slot-descriptions)
-		           slot-descriptions)))))
-
-@s]
-
-
-****Change:(orig (489 492 c))
-@s[           ;; If a constructor option is NIL,
-           ;;  no constructor should have been specified.
-           (when constructors
-                 (error "Contradictory constructor options.")))
-
-@s|           ;; If a constructor option is NIL,
-	    ;;  no constructor should have been specified.
-	    (when constructors
-		  (error "Contradictory constructor options.")))
-
-@s]
-
-
-****Change:(orig (494 495 c))
-@s[           ;; If no constructor is specified,
-           ;;  the default-constructor is made.
-
-@s|          ;; If no constructor is specified,
-	   ;;  the default-constructor is made.
-
-@s]
-
-
-****Change:(orig (497 497 a))
-@s[           (setq constructors (list default-constructor))))
-
-
-@s|           (setq constructors (list default-constructor))))
-
-    ;; We need a default constructor for the sharp-s-reader
-    (or (member t (mapcar 'symbolp  constructors))
-	(push (intern (string-concatenate "__si::" default-constructor))
-		      constructors))
-
-
-@s]
-
-
-****Change:(orig (509 509 c))
-@s[          (error "An print function is supplied to a typed structure."))
-
-@s|          (error "A print function is supplied to a typed structure."))
-    
-    `(progn
-       (define-structure ',name  ',conc-name ',type ',named
-		         ',(mapcar #'(lambda (slotd)
-		                       (list (boot-slot-name slotd)
-		                             (boot-slot-default-init slotd)
-		                             (boot-slot-type slotd)
-		                             (boot-slot-read-only slotd)
-		                             (boot-slot-offset slotd)
-		                             (boot-slot-accessor-name slotd)
-		                             (boot-slot-type-changed slotd)))
-		                   slot-descriptions)
-		         ',copier ',static ',include ',print-function ',constructors 
-		         ',offset ',predicate ',documentation)
-
-@s]
-
-
-****Change:(orig (511 542 c))
-@s[    `(progn (si:putprop ',name
-                        '(defstruct ,name ,@slots)
-                        'defstruct-form)
-            (si:putprop ',name t 'is-a-structure)
-
-@s,            (si:putprop ',name ,documentation 'structure-documentation)
-            ',name)))
-
-@s|       ,@(mapcar #'(lambda (constructor)
-		     (make-constructor name constructor type named
-		                       slot-descriptions))
-		 constructors)
-       ,@(if (and type predicate)
-	     (list (make-predicate name predicate type named
-		                   name-offset)))
-       ',name
-       )))
-
-@s]
-
-
-****Change:(orig (544 544 a))
-@s[
-
-
-@s|
-
-(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))
-    (declare (fixnum n))
-    (loop
-      (setq n
-	    (logand wrapper-cache-number-mask
-		    (random most-positive-fixnum *get-wrapper-cache-number*)))
-      (unless (zerop n) (return n)))))
-
-)
-
-(eval-when (compile load eval)
-
-(defconstant wrapper-cache-number-vector-length 8)
-
-(deftype cache-number-vector ()
-  `(simple-array fixnum (8)))
-
-(defconstant wrapper-layout (make-list wrapper-cache-number-vector-length
-		                       :initial-element 'number))
-
-)
-
-(defun make-wrapper-cache-number-vector ()
-  (let ((cnv (make-array #.wrapper-cache-number-vector-length
-		         :element-type 'fixnum)))
-    (dotimes (i #.wrapper-cache-number-vector-length)
-      (setf (aref cnv i) (get-wrapper-cache-number)))
-    cnv))
-
-(defstruct (slot
-	     (:static t)
-	     (:constructor make-slot)
-	     (:constructor make-named-slot (name)))
-  name
-  default-init
-  (type t)
-  read-only
-  offset
-  accessor-name
-  type-changed)
-
-;; All of the fields of s-data-internal must coincide with 
-;; the C structure s_data (see object.h).
-(defstruct (s-data-internal
-	     (:conc-name s-data-)
-	     (:constructor nil)
-	     (:static t))
-  ;; all of these slots are used by c code
-  name                    ; a symbol
-  (length 0 :type fixnum) ; length of slot-descriptions
-  raw                     ; a static array of unsigned-short (enum aelttype)
-  included                ; a list of the names of structures including this one
-  includes                ; nil or a s-data structure
-  staticp         ; t or nil
-  print-function  ; nil, a symbol, or a lambda expression
-  slot-descriptions       ; a list of slots
-  slot-position           ; a static array of unsigned-short
-  (size 0 :type fixnum) ; total size to allocate
-  has-holes)              ; t or nil
-
-(defstruct (basic-wrapper (:include s-data-internal)
-		          (:conc-name wrapper-)
-		          (:constructor nil)
-		          (:static t))
-  (cache-number-vector (make-wrapper-cache-number-vector))
-  (state t) ;  either t or a list (state-sym new-wrapper)
-  ;;           where state-sym is either :flush or :obsolete
-  (class nil))
-
-;(get name 'si::s-data) ;returns one of these:
-(defstruct (s-data (:include basic-wrapper)
-		   (:static t))
-  ;; these slots are used only from lisp
-  frozen          ; t or nil ; t means won't include this
-  documentation 
-  constructors            ; a list of either a symbol or a list symbol, arglist
-  offset          ; the total number of slots and placeholders
-  named                   ; t or nil
-  type                    ; one of: nil, list, or vector
-  conc-name)              ; an interned symbol
-
-#|| 
-(import '(si::wrapper-state si::wrapper-class si::basic-wrapper))
-
-(defstruct (wrapper (:include basic-wrapper)
-		    (:print-function print-wrapper)
-		    (:constructor make-wrapper-internal)
-		    (:predicate wrapper-p)
-		    (:conc-name wrapper-))
-  (class-slots nil :type list))
-
-(defun print-wrapper (instance stream depth)
-  (printing-random-thing (wrapper stream)
-    (format stream "Wrapper ~S" (wrapper-class wrapper))))
-||#
-
-(defun update-wrapper-state (old new same-p)
-  (unless (consp old)
-    (setf (wrapper-state old) 
-	  (list (if same-p ':flush ':obsolete) new))))
-
-(defun freeze-defstruct (name)
-  (let ((tem (and (symbolp name) (get name 's-data))))
-    (if tem (setf (s-data-frozen tem) t))))
-
-
-
-@s]
-
-
-****Change:(orig (551 553 c))
-@s[  (let ((l (read stream)))
-    (unless (get (car l) 'is-a-structure)
-            (error "~S is not a structure." (car l)))
-
-@s|  (let* ((l (prog1 (read stream t nil t)
-	      (if *read-suppress*
-		  (return-from sharp-s-reader nil))))
-	 (sd
-	   (or (get (car l) 's-data)
-	       
-	       (error "~S is not a structure." (car l)))))
-    
-
-@s]
-
-
-****Change:(orig (558 558 c))
-@s[         (do ((cs (get (car l) 'structure-constructors) (cdr cs)))
-
-@s|         (do ((cs (s-data-constructors sd) (cdr cs)))
-
-@s]
-
-
-****Change:(orig (571 571 d))
-@s[(set-dispatch-macro-character #\# #\S 'sharp-s-reader)
-
-
-
-@s|(set-dispatch-macro-character #\# #\S 'sharp-s-reader)
-
-
-@s]
-
-
-****Change:(orig (582 582 c))
-@s[(defstruct person name age sex)
-
-@s|(defstruct person name (age 20 :type signed-char) (eyes 2 :type signed-char)
-		                                        sex)
-(defstruct person name (age 20 :type signed-char) (eyes 2 :type signed-char)
-		                                        sex)
-(defstruct person1 name (age 20 :type fixnum)
-		                                        sex)
-
-@s]
-
-
-****Change:(orig (584 584 c))
-@s[(defstruct (astronaut (:include person (age 45))
-
-@s|(defstruct joe a (a1 0 :type (mod  30)) (a2 0 :type (mod  30))
-  (a3 0 :type (mod  30)) (a4 0 :type (mod 30)) )
-
-;(defstruct person name age sex)
-
-(defstruct (astronaut (:include person (age 45 :type fixnum))
-
-@s]
-
-
-****Change:(orig (605 605 a))
-@s[  associative
-  identity)
-
-@s|  associative
-  identity)
-
-
-@s]
-
-==============================================================================
diff --git a/pcl/pcl-env-internal.lisp b/pcl/pcl-env-internal.lisp
deleted file mode 100644
index 86b947bff006d5701fad6296f9f789c8f5ed9d64..0000000000000000000000000000000000000000
--- a/pcl/pcl-env-internal.lisp
+++ /dev/null
@@ -1,261 +0,0 @@
-(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
deleted file mode 100644
index 7bf4b476e0ab0cf40c8d8f1967e524542b669ad7..0000000000000000000000000000000000000000
--- a/pcl/pcl-env.lisp
+++ /dev/null
@@ -1,1629 +0,0 @@
-;;;-*-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)
-		                        ((consp x) 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
-				    (extract-specializer-names
-					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
deleted file mode 100644
index 25e090f2f2a337cf657ec2e26e243baff1cfabb5..0000000000000000000000000000000000000000
--- a/pcl/pcl-env.text
+++ /dev/null
@@ -1,105 +0,0 @@
-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/pyr-low.lisp b/pcl/pyr-low.lisp
deleted file mode 100644
index 935a7d3433aee9e9c577ea7e11247511fded56fd..0000000000000000000000000000000000000000
--- a/pcl/pyr-low.lisp
+++ /dev/null
@@ -1,50 +0,0 @@
-;;; -*- 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
deleted file mode 100644
index 32647fe97a331f75b302ded7531e16266ebb3ada..0000000000000000000000000000000000000000
--- a/pcl/pyr-patches.lisp
+++ /dev/null
@@ -1,9 +0,0 @@
-(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/readme.text b/pcl/readme.text
deleted file mode 100644
index ce9dc700fd125262b482c319ab3e59d9e70a0415..0000000000000000000000000000000000000000
--- a/pcl/readme.text
+++ /dev/null
@@ -1,11 +0,0 @@
-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
-file.
-
diff --git a/pcl/rel-7-2-patches.lisp b/pcl/rel-7-2-patches.lisp
deleted file mode 100644
index 9c9587bd6bcef4cdeec2a3f6538502dfe67dafdd..0000000000000000000000000000000000000000
--- a/pcl/rel-7-2-patches.lisp
+++ /dev/null
@@ -1,387 +0,0 @@
-;;; -*- 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)))))))
-
-;;;
-;;; 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))))))
-
-
diff --git a/pcl/rel-8-patches.lisp b/pcl/rel-8-patches.lisp
deleted file mode 100644
index 99b85b25e70dc57b9a96c0856ba7cadb6c718203..0000000000000000000000000000000000000000
--- a/pcl/rel-8-patches.lisp
+++ /dev/null
@@ -1,255 +0,0 @@
-;;; -*- 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)
-			(let ((class (get symbol 'clos-internals::class-for-name)))
-			  (when (and class
-				     (not (typep class 'clos:built-in-class)))
-			    class))
-			(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))
-	  (instance (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-boot.lisp b/pcl/slots-boot.lisp
index f0ccfe593f37db16d0ccb2b44d54a7e858b86102..8213be7dbc1e6bd5d70821049976c39421811363 100644
--- a/pcl/slots-boot.lisp
+++ b/pcl/slots-boot.lisp
@@ -26,7 +26,7 @@
 ;;;
 #+cmu
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/slots-boot.lisp,v 1.6 1998/12/20 04:30:22 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/slots-boot.lisp,v 1.7 1999/03/11 16:51:16 pw Exp $")
 ;;;
 
 (in-package :pcl)
@@ -59,7 +59,7 @@
 
 (defmacro asv-funcall (sym slot-name type &rest args)
   (declare (ignore type))
-  `(if (#-akcl fboundp #+akcl %fboundp ',sym)
+  `(if (fboundp ',sym)
        (,sym ,@args)
        (no-slot ',sym ',slot-name)))
 
@@ -114,7 +114,6 @@
 	 (fun #'(lambda (object)
 		  (not (eq (funcall reader object) *slot-unbound*)))))
     (declare (type function reader))
-    #+(and kcl turbo-closure) (si:turbo-closure fun)
     fun))		    
 
 (defun get-optimized-std-accessor-method-function (class slotd name)
diff --git a/pcl/slots.lisp b/pcl/slots.lisp
index cecc14fbc4387dae5b6a615952e6477cb5590281..401b906d616bcb35281a0ec6cc37296519f79296 100644
--- a/pcl/slots.lisp
+++ b/pcl/slots.lisp
@@ -26,7 +26,7 @@
 ;;;
 #+cmu
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/slots.lisp,v 1.10 1999/02/03 12:01:58 pw Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/slots.lisp,v 1.11 1999/03/11 16:51:16 pw Exp $")
 ;;;
 
 (in-package :pcl)
@@ -61,30 +61,15 @@
 
 (defun set-wrapper (inst new)
   (cond ((std-instance-p inst)
-	 #+new-kcl-wrapper
-	 (set-structure-def inst new)
-	 #-new-kcl-wrapper
 	 (setf (std-instance-wrapper inst) new))
 	((fsc-instance-p inst)
 	 (setf (fsc-instance-wrapper inst) new))
 	(t
 	 (error "What kind of instance is this?"))))
 
-#+ignore ; can't do this when using #+new-kcl-wrapper
-(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?"))))
-
 (defun swap-wrappers-and-slots (i1 i2)
   (without-interrupts
    (cond ((std-instance-p i1)
-	  #+new-kcl-wrapper
-	  (swap-structure-contents i1 i2)
-	  #-new-kcl-wrapper
 	  (let ((w1 (std-instance-wrapper i1))
 		(s1 (std-instance-slots i1)))
 	    (setf (std-instance-wrapper i1) (std-instance-wrapper i2))
@@ -341,12 +326,7 @@
 	   ((class structure-class) 
 	    (object structure-object)
 	    (slotd structure-effective-slot-definition))
-  #-new-kcl-wrapper t
-  #+new-kcl-wrapper
-  (let* ((function (slot-definition-internal-reader-function slotd))
-	 (value (funcall function object)))
-    #+cmu (declare (type function function))
-    (not (eq value *slot-unbound*))))
+	   t)
 
 (defmethod slot-makunbound-using-class
 	   ((class structure-class)
@@ -388,12 +368,9 @@
 
 (defmethod allocate-instance ((class structure-class) &rest initargs)
   (declare (ignore initargs))
-  #-new-kcl-wrapper
   (let ((constructor (class-defstruct-constructor class)))
     (if constructor
 	(funcall constructor)
-	(error "Can't allocate an instance of class ~S" (class-name class))))
-  #+new-kcl-wrapper
-  (allocate-standard-instance (class-wrapper class)))
+	(error "Can't allocate an instance of class ~S" (class-name class)))))
 
 
diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp
index d7f9a8df5000fb45af7b6394e1bf30d0644686b8..8a6a54bd0365e1715feab6d0597c5fae8cdd6dfd 100644
--- a/pcl/std-class.lisp
+++ b/pcl/std-class.lisp
@@ -26,7 +26,7 @@
 ;;;
 #+cmu
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.22 1999/02/12 21:47:14 pw Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.23 1999/03/11 16:51:16 pw Exp $")
 ;;;
 
 (in-package :pcl)
@@ -99,7 +99,6 @@
 	(if (eq *boot-state* 'complete)
 	    (get-accessor-method-function gf type class slotd)
 	    (get-optimized-std-accessor-method-function class slotd type))
-      #+kcl (si:turbo-closure function)
       (setf (slot-accessor-std-p slotd type) std-p)
       (setf (slot-accessor-function slotd type) function))
     (when (and old-slotd (not (eq old-std-p (slot-accessor-std-p slotd 'all))))
@@ -159,7 +158,7 @@
   (with-slots (prototype wrapper defstruct-constructor) class
     (or prototype 
 	(setq prototype 
-	      (if #-new-kcl-wrapper defstruct-constructor #+new-kcl-wrapper nil 
+	      (if defstruct-constructor 
 		  (allocate-instance class)
 		  (allocate-standard-instance wrapper))))))
 
@@ -569,17 +568,13 @@
   (setf (slot-value class 'class-precedence-list) 
 	(compute-class-precedence-list class))
   (setf (slot-value class 'slots) (compute-slots class))
-  #-(or cmu17 new-kcl-wrapper)
+  #-(or cmu17)
   (unless (slot-value class 'wrapper) 
     (setf (slot-value class 'wrapper) (make-wrapper 0 class)))
   #+cmu17
  (let ((lclass (lisp:find-class (class-name class))))
     (setf (kernel:class-pcl-class lclass) class)
     (setf (slot-value class 'wrapper) (kernel:class-layout lclass)))
-  #+new-kcl-wrapper
-  (let ((wrapper (get (class-name class) 'si::s-data)))
-    (setf (slot-value class 'wrapper) wrapper)
-    (setf (wrapper-class wrapper) class))
   (update-pv-table-cache-info class)
   (setq predicate-name (if predicate-name-p
 			   (setf (slot-value class 'predicate-name)
@@ -715,8 +710,6 @@
 		   (class-wrapper class)))))
 
       (with-slots (wrapper slots) class
-	#+new-kcl-wrapper
-	(setf (si::s-data-name nwrapper) (class-name class))
 	#+cmu17
 	(update-lisp-class-layout class nwrapper)
 	(setf slots eslotds
@@ -1133,12 +1126,10 @@
 	     (type-of (obsolete-structure-datum condition))))))
 
 (defun obsolete-instance-trap (owrapper nwrapper instance)
-  (if (not #-(or cmu17 new-kcl-wrapper)
+  (if (not #-(or cmu17)
            (or (std-instance-p instance) (fsc-instance-p instance))
 	   #+cmu17
-           (pcl-instance-p instance)
-           #+new-kcl-wrapper
-           nil)
+           (pcl-instance-p instance))
       (if *in-obsolete-instance-trap*
           *the-wrapper-of-structure-object* 
            (let ((*in-obsolete-instance-trap* t))
@@ -1209,16 +1200,13 @@
 ;;;
 ;;;
 (defmacro copy-instance-internal (instance)
-  `(#+new-kcl-wrapper if #-new-kcl-wrapper progn
-			 #+new-kcl-wrapper (not (std-instance-p ,instance))
+  `(progn
       (let* ((class (class-of instance))
 	     (copy (allocate-instance class)))
 	 (if (std-instance-p ,instance)
 	     (setf (std-instance-slots ,instance) (std-instance-slots ,instance))
 	     (setf (fsc-instance-slots ,instance) (fsc-instance-slots ,instance)))
-	 copy)
-      #+new-kcl-wrapper
-      (copy-structure-header ,instance)))
+	 copy)))
 
 (defun change-class-internal (instance new-class)
   (let* ((old-class (class-of instance))
diff --git a/pcl/sys-package.lisp b/pcl/sys-package.lisp
deleted file mode 100644
index c04430e8c08aa394a30dbffaf4999119332ab2c8..0000000000000000000000000000000000000000
--- a/pcl/sys-package.lisp
+++ /dev/null
@@ -1,149 +0,0 @@
-
-
-;;; Definitions for package SLOT-ACCESSOR-NAME of type ESTABLISH
-(LISP::IN-PACKAGE "SLOT-ACCESSOR-NAME" :USE LISP::NIL :NICKNAMES
-    '("S-A-N"))
-
-;;; Definitions for package PCL of type ESTABLISH
-(LISP::IN-PACKAGE "PCL" :USE LISP::NIL)
-
-;;; Definitions for package ITERATE of type ESTABLISH
-(LISP::IN-PACKAGE "ITERATE" :USE LISP::NIL)
-
-;;; Definitions for package WALKER of type ESTABLISH
-(LISP::IN-PACKAGE "WALKER" :USE LISP::NIL)
-
-;;; Definitions for package SLOT-ACCESSOR-NAME of type EXPORT
-(LISP::IN-PACKAGE "SLOT-ACCESSOR-NAME" :USE 'LISP::NIL :NICKNAMES
-    '("S-A-N"))
-(LISP::IMPORT 'LISP::NIL)
-(LISP::EXPORT 'LISP::NIL)
-
-;;; Definitions for package PCL of type EXPORT
-(LISP::IN-PACKAGE "PCL" :USE '("LISP" "ITERATE" "WALKER"))
-(LISP::IMPORT 'LISP::NIL)
-(LISP::EXPORT
-    '(PCL::CLASS-PRECEDENCE-LIST PCL::SLOT-DEFINITION
-         PCL::COMPUTE-APPLICABLE-METHODS-USING-CLASSES
-         PCL::SLOT-DEFINITION-WRITERS PCL::CLASS-OF
-         PCL::NO-APPLICABLE-METHOD PCL::STANDARD-WRITER-METHOD
-         PCL::ENSURE-CLASS-USING-CLASS PCL::ENSURE-GENERIC-FUNCTION
-         PCL::FIND-METHOD-COMBINATION PCL::UPDATE-DEPENDENT
-         PCL::MAP-DEPENDENTS PCL::SLOT-MISSING PCL::SPECIALIZER
-         PCL::CALL-NEXT-METHOD PCL::ENSURE-GENERIC-FUNCTION-USING-CLASS
-         PCL::SLOT-MAKUNBOUND-USING-CLASS PCL::MAKE-INSTANCES-OBSOLETE
-         PCL::INTERN-EQL-SPECIALIZER PCL::REMOVE-DIRECT-SUBCLASS
-         PCL::METHOD-GENERIC-FUNCTION PCL::METHOD-QUALIFIERS
-         PCL::FUNCALLABLE-STANDARD-CLASS PCL::EXTRACT-LAMBDA-LIST
-         PCL::STANDARD-CLASS PCL::PRINT-OBJECT PCL::STRUCTURE-CLASS
-         PCL::COMPUTE-EFFECTIVE-SLOT-DEFINITION
-         PCL::GENERIC-FUNCTION-DECLARATIONS PCL::MAKE-INSTANCE
-         PCL::METHOD-LAMBDA-LIST PCL::DEFGENERIC
-         PCL::REMOVE-DIRECT-METHOD PCL::STANDARD-DIRECT-SLOT-DEFINITION
-         PCL::GENERIC-FUNCTION-METHODS PCL::VALIDATE-SUPERCLASS
-         PCL::REINITIALIZE-INSTANCE PCL::STANDARD-METHOD
-         PCL::STANDARD-ACCESSOR-METHOD
-         PCL::FUNCALLABLE-STANDARD-INSTANCE PCL::FUNCTION-KEYWORDS
-         PCL::STANDARD PCL::FIND-METHOD PCL::EXTRACT-SPECIALIZER-NAMES
-         PCL::INITIALIZE-INSTANCE PCL::GENERIC-FLET PCL::SLOT-UNBOUND
-         PCL::STANDARD-INSTANCE PCL::SLOT-DEFINITION-TYPE
-         PCL::COMPUTE-EFFECTIVE-METHOD PCL::ALLOCATE-INSTANCE
-         PCL::SYMBOL-MACROLET PCL::GENERIC-FUNCTION
-         PCL::GENERIC-FUNCTION-METHOD-COMBINATION
-         PCL::SPECIALIZER-DIRECT-METHODS PCL::ADD-DIRECT-SUBCLASS
-         PCL::WRITER-METHOD-CLASS PCL::SLOT-DEFINITION-INITARGS
-         PCL::METHOD-SPECIALIZERS PCL::GENERIC-FUNCTION-METHOD-CLASS
-         PCL::ADD-METHOD PCL::WITH-ACCESSORS
-         PCL::SLOT-DEFINITION-ALLOCATION
-         PCL::SLOT-DEFINITION-INITFUNCTION
-         PCL::SLOT-DEFINITION-LOCATION PCL::ADD-DIRECT-METHOD
-         PCL::SLOT-BOUNDP PCL::EQL-SPECIALIZER PCL::SHARED-INITIALIZE
-         PCL::STANDARD-GENERIC-FUNCTION
-         PCL::ACCESSOR-METHOD-SLOT-DEFINITION
-         PCL::SLOT-BOUNDP-USING-CLASS PCL::ADD-DEPENDENT
-         PCL::SPECIALIZER-DIRECT-GENERIC-FUNCTION
-         PCL::WITH-ADDED-METHODS PCL::COMPUTE-CLASS-PRECEDENCE-LIST
-         PCL::REMOVE-DEPENDENT PCL::NEXT-METHOD-P
-         PCL::GENERIC-FUNCTION-NAME PCL::SLOT-VALUE
-         PCL::EFFECTIVE-SLOT-DEFINITION PCL::CLASS-FINALIZED-P
-         PCL::COMPUTE-DISCRIMINATING-FUNCTION PCL::STANDARD-OBJECT
-         PCL::CLASS-DEFAULT-INITARGS PCL::CLASS-DIRECT-SLOTS
-         PCL::FUNCALLABLE-STANDARD-INSTANCE-ACCESS PCL::BUILT-IN-CLASS
-         PCL::NO-NEXT-METHOD PCL::SLOT-MAKUNBOUND
-         PCL::STANDARD-READER-METHOD PCL::GENERIC-FUNCTION-LAMBDA-LIST
-         PCL::GENERIC-FUNCTION-ARGUMENT-PRECEDENCE-ORDER
-         PCL::INVALID-METHOD-ERROR PCL::METHOD-COMBINATION-ERROR
-         PCL::SLOT-EXISTS-P PCL::FINALIZE-INHERITANCE
-         PCL::SLOT-DEFINITION-NAME
-         PCL::STANDARD-EFFECTIVE-SLOT-DEFINITION PCL::COMPUTE-SLOTS
-         PCL::CLASS-SLOTS PCL::EFFECTIVE-SLOT-DEFINITION-CLASS
-         PCL::STANDARD-INSTANCE-ACCESS PCL::WITH-SLOTS
-         PCL::DIRECT-SLOT-DEFINITION PCL::DEFINE-METHOD-COMBINATION
-         PCL::MAKE-METHOD-LAMBDA PCL::ENSURE-CLASS
-         PCL::DIRECT-SLOT-DEFINITION-CLASS PCL::METHOD-FUNCTION
-         PCL::STANDARD-SLOT-DEFINITION PCL::CHANGE-CLASS PCL::DEFMETHOD
-         PCL::UPDATE-INSTANCE-FOR-DIFFERENT-CLASS
-         PCL::UPDATE-INSTANCE-FOR-REDEFINED-CLASS
-         PCL::FORWARD-REFERENCED-CLASS PCL::SLOT-DEFINITION-INITFORM
-         PCL::REMOVE-METHOD PCL::READER-METHOD-CLASS PCL::CALL-METHOD
-         PCL::CLASS-PROTOTYPE PCL::CLASS-NAME PCL::FIND-CLASS
-         PCL::DEFCLASS PCL::COMPUTE-APPLICABLE-METHODS
-         PCL::SLOT-VALUE-USING-CLASS PCL::METHOD-COMBINATION
-         PCL::EQL-SPECIALIZER-INSTANCE PCL::GENERIC-LABELS PCL::METHOD
-         PCL::SLOT-DEFINITION-READERS
-         PCL::CLASS-DIRECT-DEFAULT-INITARGS
-         PCL::CLASS-DIRECT-SUBCLASSES PCL::CLASS-DIRECT-SUPERCLASSES
-         PCL::SET-FUNCALLABLE-INSTANCE-FUNCTION))
-
-;;; Definitions for package ITERATE of type EXPORT
-(LISP::IN-PACKAGE "ITERATE" :USE '("WALKER" "LISP"))
-(LISP::IMPORT 'LISP::NIL)
-(LISP::EXPORT
-    '(ITERATE::SUMMING ITERATE::MINIMIZING ITERATE::PLIST-ELEMENTS
-         ITERATE::ITERATE* ITERATE::MAXIMIZING ITERATE::LIST-TAILS
-         ITERATE::*ITERATE-WARNINGS* ITERATE::GATHERING
-         ITERATE::EACHTIME ITERATE::ELEMENTS ITERATE::GATHER
-         ITERATE::LIST-ELEMENTS ITERATE::WHILE ITERATE::ITERATE
-         ITERATE::UNTIL ITERATE::JOINING ITERATE::COLLECTING
-         ITERATE::WITH-GATHERING ITERATE::INTERVAL))
-
-;;; Definitions for package WALKER of type EXPORT
-(LISP::IN-PACKAGE "WALKER" :USE '("LISP"))
-(LISP::IMPORT 'LISP::NIL)
-(LISP::EXPORT
-    '(WALKER::DEFINE-WALKER-TEMPLATE WALKER::*VARIABLE-DECLARATIONS*
-         WALKER::NESTED-WALK-FORM WALKER::VARIABLE-DECLARATION
-         WALKER::WALK-FORM-EXPAND-MACROS-P WALKER::VARIABLE-LEXICAL-P
-         WALKER::VARIABLE-SPECIAL-P WALKER::WALK-FORM
-         WALKER::MACROEXPAND-ALL WALKER::VARIABLE-GLOBALLY-SPECIAL-P))
-
-;;; Definitions for package SLOT-ACCESSOR-NAME of type SHADOW
-(LISP::IN-PACKAGE "SLOT-ACCESSOR-NAME")
-(LISP::SHADOW 'LISP::NIL)
-(LISP::SHADOWING-IMPORT 'LISP::NIL)
-(LISP::IMPORT 'LISP::NIL)
-
-;;; Definitions for package PCL of type SHADOW
-(LISP::IN-PACKAGE "PCL")
-(LISP::SHADOW '(PCL::DOTIMES PCL::DOCUMENTATION))
-(LISP::SHADOWING-IMPORT 'LISP::NIL)
-(LISP::IMPORT
-    '(SYSTEM::STRUCTURE-REF SYSTEM::STRUCTURE-DEF SYSTEM::STRUCTUREP))
-
-;;; Definitions for package ITERATE of type SHADOW
-(LISP::IN-PACKAGE "ITERATE")
-(LISP::SHADOW 'LISP::NIL)
-(LISP::SHADOWING-IMPORT 'LISP::NIL)
-(LISP::IMPORT 'LISP::NIL)
-
-;;; Definitions for package WALKER of type SHADOW
-(LISP::IN-PACKAGE "WALKER")
-(LISP::SHADOW 'LISP::NIL)
-(LISP::SHADOWING-IMPORT 'LISP::NIL)
-(LISP::IMPORT 'LISP::NIL)
-
-(in-package 'SI)
-(export '(%structure-name
-          %compiled-function-name
-          %set-compiled-function-name))
-(in-package 'pcl)
diff --git a/pcl/sys-proclaim.lisp b/pcl/sys-proclaim.lisp
deleted file mode 100644
index 15e3e4df9f970e1b955fa47d26f492a978e8e127..0000000000000000000000000000000000000000
--- a/pcl/sys-proclaim.lisp
+++ /dev/null
@@ -1,818 +0,0 @@
-
-(IN-PACKAGE "USER") 
-(PROCLAIM '(FTYPE (FUNCTION (*) FIXNUM) PCL::ZERO)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T FIXNUM *) FIXNUM)
-            PCL::COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T) FIXNUM) PCL::FAST-INSTANCE-BOUNDP-INDEX
-            PCL::ONE-INDEX-LIMIT-FN PCL::N-N-ACCESSORS-LIMIT-FN
-            PCL::CHECKING-LIMIT-FN PCL::PV-CACHE-LIMIT-FN
-            PCL::CACHE-NLINES PCL::CACHE-MAX-LOCATION PCL::CACHE-SIZE
-            PCL::CACHE-MASK PCL::ARG-INFO-NUMBER-REQUIRED
-            PCL::DEFAULT-LIMIT-FN PCL::CACHE-COUNT
-            PCL::CACHING-LIMIT-FN PCL::PV-TABLE-PV-SIZE
-            PCL::EARLY-CLASS-SIZE)) 
-(PROCLAIM '(FTYPE (FUNCTION (FIXNUM) T) PCL::POWER-OF-TWO-CEILING)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T) FUNCTION) PCL::CACHE-LIMIT-FN
-            PCL::METHOD-CALL-FUNCTION PCL::FAST-METHOD-CALL-FUNCTION)) 
-(PROCLAIM '(FTYPE (FUNCTION (T) PCL::FIELD-TYPE) PCL::CACHE-FIELD)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T) LIST) PCL::CACHE-OVERFLOW
-            PCL::PV-TABLE-SLOT-NAME-LISTS PCL::PV-TABLE-CALL-LIST)) 
-(PROCLAIM '(FTYPE (FUNCTION (T) (MEMBER NIL T)) PCL::CACHE-VALUEP)) 
-(PROCLAIM '(FTYPE (FUNCTION (T) SIMPLE-VECTOR) PCL::CACHE-VECTOR)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T) (VALUES T T)) PCL::MAKE-CLASS-PREDICATE-NAME
-            PCL::MAKE-KEYWORD)) 
-(PROCLAIM '(FTYPE (FUNCTION (FIXNUM T) T) PCL::%CCLOSURE-ENV-NTHCDR)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (FIXNUM FIXNUM T) FIXNUM)
-            PCL::COMPUTE-PRIMARY-CACHE-LOCATION)) 
-(PROCLAIM '(FTYPE (FUNCTION (T) (INTEGER 1 512)) PCL::CACHE-LINE-SIZE)) 
-(PROCLAIM '(FTYPE (FUNCTION (T) (INTEGER 1 256)) PCL::CACHE-NKEYS)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T) (OR PCL::CACHE NULL)) PCL::PV-TABLE-CACHE)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T T T T) *) PCL::MEMF-CODE-CONVERTER
-            PCL::REAL-LOAD-DEFCLASS PCL::CACHE-MISS-VALUES-INTERNAL
-            PCL::GENERATE-DISCRIMINATION-NET-INTERNAL
-            PCL::MAKE-LONG-METHOD-COMBINATION-FUNCTION
-            PCL::DO-SHORT-METHOD-COMBINATION
-            WALKER::WALK-TEMPLATE-HANDLE-REPEAT-1)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T) *)
-            PCL::GET-OPTIMIZED-STD-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION
-            ITERATE::WALK-GATHERING-BODY
-            PCL::CACHE-MISS-VALUES
-            PCL::MAKE-OPTIMIZED-STD-READER-METHOD-FUNCTION
-            PCL::OPTIMIZE-SLOT-VALUE-BY-CLASS-P PCL::ACCESSOR-VALUES1
-            PCL::EMIT-READER/WRITER
-            PCL::EMIT-ONE-OR-N-INDEX-READER/WRITER
-            WALKER::WALK-MULTIPLE-VALUE-SETQ PCL::GENERATING-LISP
-            PCL::EMIT-READER/WRITER-FUNCTION
-            PCL::EMIT-ONE-OR-N-INDEX-READER/WRITER-FUNCTION
-            WALKER::WALK-LET-IF PCL::SET-SLOT-VALUE
-            PCL::CONVERT-METHODS PCL::SLOT-VALUE-USING-CLASS-DFUN
-            PCL::SLOT-BOUNDP-USING-CLASS-DFUN
-            PCL::CHECK-METHOD-ARG-INFO PCL::LOAD-LONG-DEFCOMBIN
-            PCL::MAKE-FINAL-N-N-ACCESSOR-DFUN
-            PCL::MAKE-FINAL-CACHING-DFUN
-            PCL::MAKE-FINAL-CONSTANT-VALUE-DFUN
-            PCL::GET-CLASS-SLOT-VALUE-1 PCL::ACCESSOR-VALUES-INTERNAL
-            PCL::MAKE-OPTIMIZED-STD-WRITER-METHOD-FUNCTION
-            PCL::MAKE-OPTIMIZED-STD-BOUNDP-METHOD-FUNCTION
-            ITERATE::EXPAND-INTO-LET WALKER::WALK-FORM-INTERNAL
-            ITERATE::RENAME-VARIABLES
-            PCL::CONSTANT-VALUE-MISS PCL::CACHING-MISS
-            PCL::CHECKING-MISS
-            PCL::GET-OPTIMIZED-STD-ACCESSOR-METHOD-FUNCTION)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T T T) *)
-            PCL::COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO-INTERNAL
-            PCL::ADD-METHOD-DECLARATIONS PCL::WALK-METHOD-LAMBDA
-            PCL::MAKE-TWO-CLASS-ACCESSOR-DFUN
-            WALKER::WALK-TEMPLATE-HANDLE-REPEAT)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T T) *)
-            PCL::GET-ACCESSOR-FROM-SVUC-METHOD-FUNCTION
-            PCL::BOOTSTRAP-ACCESSOR-DEFINITION
-            PCL::GET-ACCESSOR-METHOD-FUNCTION
-            PCL::EMIT-CHECKING-OR-CACHING
-            PCL::EMIT-CHECKING-OR-CACHING-FUNCTION
-            PCL::SETF-SLOT-VALUE-USING-CLASS-DFUN
-            PCL::LOAD-SHORT-DEFCOMBIN
-            PCL::INITIALIZE-INSTANCE-SIMPLE-FUNCTION
-            PCL::MAKE-SHARED-INITIALIZE-FORM-LIST
-            PCL::MAKE-ONE-CLASS-ACCESSOR-DFUN
-            PCL::MAKE-FINAL-ONE-INDEX-ACCESSOR-DFUN
-            PCL::MAKE-FINAL-CHECKING-DFUN PCL::ACCESSOR-VALUES
-            PCL::SET-CLASS-SLOT-VALUE-1
-            PCL::GENERATE-DISCRIMINATION-NET
-            PCL::REAL-MAKE-METHOD-LAMBDA
-            PCL::ORDER-SPECIALIZERS WALKER::WALK-TEMPLATE
-            PCL::ACCESSOR-MISS)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T T T T T) *)
-            ITERATE::ITERATE-TRANSFORM-BODY)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T *) *) PCL::SLOT-VALUE-OR-DEFAULT
-            PCL::MAKE-EFFECTIVE-METHOD-FUNCTION
-            PCL::GET-EFFECTIVE-METHOD-FUNCTION
-            PCL::MAKE-N-N-ACCESSOR-DFUN WALKER:NESTED-WALK-FORM
-            PCL::MAKE-CHECKING-DFUN PCL::LOAD-DEFGENERIC
-            PCL::TYPES-FROM-ARGUMENTS
-            PCL::MAKE-DEFAULT-INITARGS-FORM-LIST
-            PCL::MAKE-FINAL-ACCESSOR-DFUN PCL::MAKE-ACCESSOR-TABLE
-            PCL::GET-SIMPLE-INITIALIZATION-FUNCTION
-            PCL::GET-COMPLEX-INITIALIZATION-FUNCTIONS
-            PCL::COMPUTE-SECONDARY-DISPATCH-FUNCTION)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T T *) *)
-            PCL::MAKE-EFFECTIVE-METHOD-FUNCTION-SIMPLE1
-            ITERATE::RENAME-LET-BINDINGS)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T *) *) PCL::MAKE-ONE-INDEX-ACCESSOR-DFUN
-            WALKER::WALK-DECLARATIONS
-            PCL::GET-SECONDARY-DISPATCH-FUNCTION)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T T T T *) *) PCL::REAL-MAKE-A-METHOD)) 
-(PROCLAIM '(FTYPE (FUNCTION (T STREAM T) T) PCL::PRINT-DFUN-INFO)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T) T) ITERATE::SIMPLE-EXPAND-GATHERING-FORM
-            ITERATE::RENAME-AND-CAPTURE-VARIABLES
-            ITERATE::VARIABLE-SAME-P
-            PCL::GET-FUNCTION-GENERATOR
-            WALKER:VARIABLE-DECLARATION PCL::GET-NEW-FUNCTION-GENERATOR
-            PCL::TRACE-METHOD-INTERNAL PCL::ONE-INDEX-DFUN-INFO
-            PCL::ONE-CLASS-DFUN-INFO
-            PCL::MAP-ALL-ORDERS SYSTEM::APPLY-DISPLAY-FUN
-            PCL::NOTE-PV-TABLE-REFERENCE
-            WALKER::RELIST-INTERNAL
-            PCL::MAKE-DFUN-CALL
-            WALKER::WALK-TAGBODY-1 WALKER::WALK-LAMBDA
-            PCL::OPTIMIZE-GF-CALL-INTERNAL
-            PCL::SKIP-OPTIMIZE-SLOT-VALUE-BY-CLASS-P
-            WALKER::WALK-COMPILER-LET PCL::SKIP-FAST-SLOT-ACCESS-P
-            WALKER::WALK-UNEXPECTED-DECLARE WALKER::WALK-FLET
-            WALKER::WALK-IF
-            WALKER::WALK-LABELS WALKER::WALK-LET WALKER::WALK-LET*
-            WALKER::WALK-LOCALLY
-            WALKER::WALK-MACROLET
-            PCL::FIX-SLOT-ACCESSORS WALKER::WALK-MULTIPLE-VALUE-BIND
-            PCL:COMPUTE-EFFECTIVE-METHOD WALKER::WALK-SETQ
-            WALKER::WALK-SYMBOL-MACROLET PCL::EMIT-SLOT-READ-FORM
-            WALKER::WALK-TAGBODY PCL::EMIT-BOUNDP-CHECK WALKER::WALK-DO
-            WALKER::WALK-DO* WALKER::WALK-PROG
-            WALKER::WALK-NAMED-LAMBDA WALKER::WALK-PROG*
-            PCL::EXPAND-DEFGENERIC PCL::EMIT-GREATER-THAN-1-DLAP
-            PCL::EMIT-1-T-DLAP
-            PCL::MAKE-METHOD-INITARGS-FORM-INTERNAL
-            PCL::ENTRY-IN-CACHE-P PCL::CONVERT-TABLE
-            PCL::MAKE-METHOD-SPEC PCL::TRACE-EMF-CALL-INTERNAL
-            PCL::FLUSH-CACHE-TRAP PCL::SET-FUNCTION-NAME-1
-            PCL::OBSOLETE-INSTANCE-TRAP
-            PCL::COMPUTE-PRECEDENCE PCL::PRINT-STD-INSTANCE
-            PCL::|SETF PCL METHOD-FUNCTION-GET|
-            PCL::|SETF PCL PLIST-VALUE|
-            WALKER::WITH-AUGMENTED-ENVIRONMENT-INTERNAL
-            PCL::CAN-OPTIMIZE-ACCESS PCL::OPTIMIZE-SLOT-VALUE
-            PCL::OPTIMIZE-SET-SLOT-VALUE PCL::DECLARE-STRUCTURE
-            PCL::OPTIMIZE-SLOT-BOUNDP
-            PCL::PRINT-CACHE PCL::COMPUTE-STD-CPL-PHASE-3
-            PCL::FIRST-FORM-TO-LISP
-            ITERATE::OPTIMIZE-ITERATE-FORM
-            PCL::WRAP-METHOD-GROUP-SPECIFIER-BINDINGS
-            PCL::MAKE-TOP-LEVEL-FORM PCL::INVALIDATE-WRAPPER
-            PCL::STANDARD-COMPUTE-EFFECTIVE-METHOD
-            PCL::MAKE-OPTIMIZED-STD-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION
-            PCL::MAKE-OPTIMIZED-STD-SETF-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION
-            PCL::MAKE-OPTIMIZED-STD-SLOT-BOUNDP-USING-CLASS-METHOD-FUNCTION
-            WALKER::RECONS ITERATE::OPTIMIZE-GATHERING-FORM)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T T) T) PCL::MAKE-EFFECTIVE-METHOD-FUNCTION1
-            PCL::MAKE-EFFECTIVE-METHOD-FUNCTION-INTERNAL
-            PCL::MAKE-EFFECTIVE-METHOD-FUNCTION-TYPE
-            PCL::MEMF-TEST-CONVERTER
-            PCL::LOAD-PRECOMPILED-DFUN-CONSTRUCTOR
-            PCL::TWO-CLASS-DFUN-INFO
-            WALKER::WALK-LET/LET* WALKER::WALK-PROG/PROG*
-            WALKER::WALK-DO/DO*
-            WALKER::WALK-BINDINGS-2 PCL::OPTIMIZE-READER
-            PCL::OPTIMIZE-WRITER
-            PCL::EMIT-CHECKING-OR-CACHING-FUNCTION-PRELIMINARY
-            PCL::MAYBE-EXPAND-ACCESSOR-FORM
-            PCL::INITIALIZE-INSTANCE-SIMPLE
-            PCL::GET-WRAPPERS-FROM-CLASSES
-            PCL::LOAD-PRECOMPILED-IIS-ENTRY
-            PCL::FILL-CACHE-P
-            PCL::ADJUST-CACHE
-            PCL::EXPAND-CACHE
-            PCL::EXPAND-SYMBOL-MACROLET-INTERNAL
-            PCL::BOOTSTRAP-SET-SLOT PCL::EXPAND-DEFCLASS PCL::GET-CACHE
-            )) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T T T) T) PCL::LOAD-FUNCTION-GENERATOR
-            PCL::EXPAND-EMF-CALL-METHOD PCL::MAKE-FGEN
-            PCL::BOOTSTRAP-MAKE-SLOT-DEFINITIONS
-            PCL::BOOTSTRAP-ACCESSOR-DEFINITIONS1
-            PCL::MAKE-FINAL-ORDINARY-DFUN-INTERNAL PCL::COMPUTE-PV-SLOT
-            WALKER::WALK-BINDINGS-1
-            PCL::OPTIMIZE-INSTANCE-ACCESS
-            PCL::OPTIMIZE-ACCESSOR-CALL
-            PCL::MAKE-METHOD-INITARGS-FORM-INTERNAL1
-            PCL::UPDATE-SLOTS-IN-PV
-            PCL::MAKE-PARAMETER-REFERENCES
-            PCL::MAKE-EMF-CACHE
-            PCL::GET-MAKE-INSTANCE-FUNCTION-INTERNAL
-            PCL::MAKE-INSTANCE-FUNCTION-COMPLEX
-            PCL::MAKE-INSTANCE-FUNCTION-SIMPLE
-            PCL::OPTIMIZE-GENERIC-FUNCTION-CALL
-            PCL::REAL-MAKE-METHOD-INITARGS-FORM
-            )) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T *) T)
-            PCL::MAKE-EFFECTIVE-METHOD-FUNCTION-SIMPLE
-            PCL::MAKE-EMF-FROM-METHOD
-            PCL::EXPAND-EFFECTIVE-METHOD-FUNCTION
-            PCL::NAMED-OBJECT-PRINT-FUNCTION PCL::FIND-CLASS-FROM-CELL
-            PCL::FIND-CLASS-PREDICATE-FROM-CELL PCL::INITIALIZE-INFO
-            PCL::GET-EFFECTIVE-METHOD-FUNCTION1 PCL::GET-DECLARATION
-            PCL::GET-METHOD-FUNCTION-PV-CELL
-            PCL:ENSURE-GENERIC-FUNCTION-USING-CLASS PCL::EMIT-MISS
-            PCL::METHOD-FUNCTION-GET PCL::PROBE-CACHE PCL::MAP-CACHE
-            PCL::GET-CACHE-FROM-CACHE PCL::PRECOMPUTE-EFFECTIVE-METHODS
-            PCL::RECORD-DEFINITION WALKER::CONVERT-MACRO-TO-LAMBDA
-            PCL::CPL-ERROR PCL::REAL-ADD-METHOD
-            PCL::REAL-ENSURE-GF-USING-CLASS--GENERIC-FUNCTION
-            PCL::REAL-ENSURE-GF-USING-CLASS--NULL
-            PCL::COMPUTE-SECONDARY-DISPATCH-FUNCTION1)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T T T T T T) T)
-            PCL::GET-SECONDARY-DISPATCH-FUNCTION2)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T T T T) T)
-            PCL::BOOTSTRAP-MAKE-SLOT-DEFINITION PCL::EMIT-SLOT-ACCESS
-            PCL::OPTIMIZE-GF-CALL PCL::SET-ARG-INFO1 PCL::LOAD-DEFCLASS
-            PCL::MAKE-EARLY-CLASS-DEFINITION)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T T *) T) PCL::FILL-DFUN-CACHE
-            PCL::EARLY-ADD-NAMED-METHOD PCL::REAL-ADD-NAMED-METHOD)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T T T T *) T) PCL::LOAD-DEFMETHOD
-            PCL::MAKE-DEFMETHOD-FORM PCL::MAKE-DEFMETHOD-FORM-INTERNAL
-            PCL::EARLY-MAKE-A-METHOD)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T *) T) PCL::CHECK-INITARGS-2-PLIST
-            PCL::CHECK-INITARGS-2-LIST WALKER::WALK-ARGLIST
-            PCL::MAKE-EMF-CALL PCL::CAN-OPTIMIZE-ACCESS1
-            PCL::EMIT-FETCH-WRAPPER PCL::FILL-CACHE PCL::FIND-METHOD
-            PCL::REAL-GET-METHOD PCL::CHECK-INITARGS-1 PCL::GET-METHOD)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T T T *) T) PCL::EMIT-DLAP
-            PCL::GET-SECONDARY-DISPATCH-FUNCTION1)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T FIXNUM) T) PCL::FILL-CACHE-FROM-CACHE-P)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T T T T T) T) PCL::EXPAND-DEFMETHOD
-            PCL::LOAD-DEFMETHOD-INTERNAL
-            )) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T T T T T T T *) T)
-            PCL::BOOTSTRAP-INITIALIZE-CLASS)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION NIL *) PCL::COUNT-ALL-DFUNS PCL::RENEW-SYS-FILES
-            PCL::EMIT-N-N-READERS PCL::EMIT-N-N-WRITERS)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION NIL T) PCL::GET-EFFECTIVE-METHOD-GENSYM
-            PCL::SHOW-EMF-CALL-TRACE PCL::BOOTSTRAP-META-BRAID
-            PCL::BOOTSTRAP-BUILT-IN-CLASSES PCL::LIST-ALL-DFUNS
-            PCL::DEFAULT-METHOD-ONLY-DFUN-INFO
-            PCL::INITIALIZE-CHECKING-OR-CACHING-FUNCTION-LIST
-            PCL::CACHES-TO-ALLOCATE PCL::UPDATE-DISPATCH-DFUNS
-            PCL::MAKE-CACHE PCL::RESET-PCL-PACKAGE
-            PCL::IN-THE-COMPILER-P PCL::STRUCTURE-FUNCTIONS-EXIST-P
-            PCL::ALLOCATE-FUNCALLABLE-INSTANCE-2
-            PCL::%%ALLOCATE-INSTANCE--CLASS
-            PCL::ALLOCATE-FUNCALLABLE-INSTANCE-1
-            PCL::DISPATCH-DFUN-INFO PCL::INITIAL-DISPATCH-DFUN-INFO
-            PCL::INITIAL-DFUN-INFO PCL::NO-METHODS-DFUN-INFO
-            PCL::SHOW-FREE-CACHE-VECTORS PCL::MAKE-CPD
-            PCL::MAKE-ARG-INFO PCL::SHOW-DFUN-CONSTRUCTORS)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (*) *) PCL::UNTRACE-METHOD
-            PCL:INVALID-METHOD-ERROR PCL:METHOD-COMBINATION-ERROR
-            PCL::LIST-LARGE-CACHES
-            PCL::UPDATE-MAKE-INSTANCE-FUNCTION-TABLE)) 
-(PROCLAIM '(FTYPE (FUNCTION (FIXNUM T *) *) PCL::FIND-FREE-CACHE-LINE)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (FIXNUM T T) *) PCL::COMPUTE-CACHE-PARAMETERS)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (*) T) PCL::|__si::MAKE-DFUN-INFO|
-            PCL::|__si::MAKE-NO-METHODS| PCL::|__si::MAKE-INITIAL|
-            PCL::|__si::MAKE-INITIAL-DISPATCH|
-            PCL::|__si::MAKE-DISPATCH|
-            PCL::|__si::MAKE-DEFAULT-METHOD-ONLY|
-            PCL::|__si::MAKE-ACCESSOR-DFUN-INFO|
-            PCL::|__si::MAKE-ONE-INDEX-DFUN-INFO|
-            PCL::MAKE-FAST-METHOD-CALL PCL::|__si::MAKE-N-N|
-            PCL::MAKE-FAST-INSTANCE-BOUNDP PCL::|__si::MAKE-ONE-CLASS|
-            PCL::|__si::MAKE-TWO-CLASS| PCL::|__si::MAKE-ONE-INDEX|
-            PCL::|__si::MAKE-CHECKING| PCL::|__si::MAKE-ARG-INFO|
-            PCL::FIX-EARLY-GENERIC-FUNCTIONS PCL::STRING-APPEND
-            PCL::|__si::MAKE-CACHING| PCL::|__si::MAKE-CONSTANT-VALUE|
-            PCL::FALSE PCL::|STRUCTURE-OBJECT class constructor|
-            PCL::PV-WRAPPERS-FROM-PV-ARGS PCL::MAKE-PV-TABLE
-            PCL::|__si::MAKE-PV-TABLE| PCL::INTERN-PV-TABLE
-            PCL::CALLED-FIN-WITHOUT-FUNCTION
-            PCL::|__si::MAKE-STD-INSTANCE| PCL::TRUE
-            PCL::MAKE-INITIALIZE-INFO PCL::|__si::MAKE-CACHE|
-            PCL::MAKE-PROGN WALKER::UNBOUND-LEXICAL-FUNCTION
-            PCL::|__si::MAKE-CLASS-PRECEDENCE-DESCRIPTION|
-            PCL::MAKE-METHOD-CALL)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T) *) PCL::TYPE-FROM-SPECIALIZER
-            PCL::*NORMALIZE-TYPE PCL::UNPARSE-TYPE
-            PCL::DEFAULT-CODE-CONVERTER PCL::CONVERT-TO-SYSTEM-TYPE
-            PCL::EMIT-CONSTANT-VALUE PCL::SFUN-P PCL::PCL-DESCRIBE
-            PCL::GET-GENERIC-FUNCTION-INFO PCL::EARLY-METHOD-FUNCTION
-            PCL::EARLY-METHOD-STANDARD-ACCESSOR-SLOT-NAME
-            PCL::SPECIALIZER-FROM-TYPE PCL::CLASS-EQ-TYPE
-            COMPILER::CAN-USE-PRINT-CIRCLE-P PCL::STRUCTURE-WRAPPER
-            PCL::FIND-STRUCTURE-CLASS PCL::MAKE-DISPATCH-DFUN
-            PCL::FIND-WRAPPER PCL::PARSE-DEFMETHOD
-            PCL::PROTOTYPES-FOR-MAKE-METHOD-LAMBDA
-            PCL::FORCE-CACHE-FLUSHES PCL::EMIT-ONE-CLASS-READER
-            PCL::EMIT-ONE-CLASS-WRITER PCL::EMIT-TWO-CLASS-READER
-            PCL::EMIT-TWO-CLASS-WRITER PCL::EMIT-ONE-INDEX-READERS
-            PCL::EMIT-ONE-INDEX-WRITERS PCL::NET-CODE-CONVERTER
-            PCL::EMIT-IN-CHECKING-CACHE-P PCL::COMPILE-IIS-FUNCTIONS
-            PCL::ANALYZE-LAMBDA-LIST
-            PCL::COMPUTE-APPLICABLE-METHODS-EMF
-            PCL::GET-DISPATCH-FUNCTION PCL::INSURE-CACHING-DFUN
-            PCL::%FBOUNDP PCL::CCLOSUREP PCL::GENERIC-FUNCTION-NAME-P
-            PCL::MAKE-FINAL-DISPATCH-DFUN
-            PCL::STRUCTURE-SLOTD-INIT-FORM
-            PCL::PARSE-METHOD-GROUP-SPECIFIER
-            PCL::METHOD-PROTOTYPE-FOR-GF
-            PCL::EARLY-COLLECT-INHERITANCE)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T) T) PCL::UNENCAPSULATED-FDEFINITION
-            PCL::DFUN-INFO-P PCL::NO-METHODS-P
-            PCL::MAKE-TYPE-PREDICATE
-            PCL::DEFAULT-TEST-CONVERTER PCL::INITIAL-P
-            PCL::UNPARSE-TYPE-LIST PCL::MAKE-CALL-METHODS
-            PCL::DEFAULT-CONSTANT-CONVERTER PCL::INITIAL-DISPATCH-P
-            PCL::DISPATCH-P PCL::GBOUNDP PCL::GMAKUNBOUND
-            PCL::DEFAULT-CONSTANTP PCL::DEFAULT-METHOD-ONLY-P
-            PCL::FGEN-TEST PCL::LOOKUP-FGEN PCL::ACCESSOR-DFUN-INFO-P
-            PCL::FGEN-GENERATOR PCL::FGEN-SYSTEM
-            PCL::ONE-INDEX-DFUN-INFO-P PCL::FAST-METHOD-CALL-P
-            PCL::N-N-P PCL::FAST-INSTANCE-BOUNDP-P
-            PCL::METHOD-FUNCTION-PV-TABLE PCL::METHOD-FUNCTION-METHOD
-            PCL::STORE-FGEN PCL::ONE-CLASS-P
-            PCL::METHOD-FUNCTION-NEEDS-NEXT-METHODS-P
-            PCL::FTYPE-DECLARATION-FROM-LAMBDA-LIST PCL::FGEN-GENSYMS
-            PCL::TWO-CLASS-P PCL::ARG-INFO-LAMBDA-LIST
-            PCL::ARG-INFO-PRECEDENCE PCL::ARG-INFO-METATYPES
-            PCL::FGEN-GENERATOR-LAMBDA SYSTEM:%STRUCTURE-NAME
-            PCL::ARG-INFO-NUMBER-OPTIONAL
-            SYSTEM:%COMPILED-FUNCTION-NAME PCL::ARG-INFO-KEY/REST-P
-            PCL::ONE-INDEX-P PCL::ARG-INFO-KEYWORDS
-            PCL::GF-INFO-SIMPLE-ACCESSOR-TYPE
-            PCL::GF-PRECOMPUTE-DFUN-AND-EMF-P
-            PCL::GF-INFO-STATIC-C-A-M-EMF PCL::CHECKING-P
-            PCL::GF-INFO-C-A-M-EMF-STD-P PCL::GF-INFO-FAST-MF-P
-            PCL::UNDEFMETHOD-1 PCL::ARG-INFO-P
-            PCL::FAST-METHOD-CALL-ARG-INFO PCL::ARG-INFO-NKEYS
-            PCL::GF-DFUN-CACHE PCL:CLASS-OF PCL::GF-DFUN-INFO
-            PCL::FUNCTION-RETURNING-NIL
-            PCL::ACCESSOR-DFUN-INFO-ACCESSOR-TYPE PCL::EVAL-FORM
-            PCL::ONE-INDEX-DFUN-INFO-INDEX
-            PCL::SLOT-INITARGS-FROM-STRUCTURE-SLOTD PCL::TYPE-CLASS
-            PCL::ONE-CLASS-WRAPPER0 PCL::EXTRACT-PARAMETERS
-            PCL::CLASS-PREDICATE PCL::EXTRACT-REQUIRED-PARAMETERS
-            PCL::MAKE-CLASS-EQ-PREDICATE PCL::TWO-CLASS-WRAPPER1
-            PCL::MAKE-EQL-PREDICATE PCL::CHECKING-FUNCTION
-            PCL::BOOTSTRAP-ACCESSOR-DEFINITIONS
-            PCL::INITIALIZE-INFO-KEY PCL::BOOTSTRAP-CLASS-PREDICATES
-            PCL::GET-BUILT-IN-CLASS-SYMBOL PCL::INITIALIZE-INFO-WRAPPER
-            PCL::GET-BUILT-IN-WRAPPER-SYMBOL PCL::DO-STANDARD-DEFSETF-1
-            PCL::CACHING-P PCL::GFS-OF-TYPE PCL::LEGAL-CLASS-NAME-P
-            PCL::STRUCTURE-TYPE-P PCL::CONSTANT-VALUE-P
-            PCL::USE-DEFAULT-METHOD-ONLY-DFUN-P
-            SYSTEM::NEXT-STACK-FRAME PCL::WRAPPER-FIELD
-            PCL::NEXT-WRAPPER-FIELD PCL::SETFBOUNDP
-            PCL::GET-SETF-FUNCTION-NAME PCL::USE-CACHING-DFUN-P
-            PCL::MAKE-PV-TYPE-DECLARATION
-            PCL::MAKE-CALLS-TYPE-DECLARATION PCL::MAP-SPECIALIZERS
-            WALKER:VARIABLE-GLOBALLY-SPECIAL-P PCL::SLOT-VECTOR-SYMBOL
-            PCL::MAKE-PERMUTATION-VECTOR PCL::STRUCTURE-OBJECT-P
-            PCL::EXPAND-MAKE-INSTANCE-FORM PCL::MAKE-CONSTANT-FUNCTION
-            PCL::FUNCTION-RETURNING-T PCL::SORT-SLOTS PCL::SORT-CALLS
-            PCL::SYMBOL-PKG-NAME
-            PCL::CLASS-HAS-A-FORWARD-REFERENCED-SUPERCLASS-P
-            PCL::INITIALIZE-INFO-BOUND-SLOTS
-            PCL::INITIALIZE-INFO-CACHED-VALID-P
-            PCL::GET-MAKE-INSTANCE-FUNCTIONS
-            PCL::INITIALIZE-INFO-CACHED-RI-VALID-P
-            PCL::INITIALIZE-INFO-CACHED-INITARGS-FORM-LIST
-            PCL::INITIALIZE-INFO-CACHED-NEW-KEYS
-            PCL::UPDATE-C-A-M-GF-INFO
-            PCL::INITIALIZE-INFO-CACHED-DEFAULT-INITARGS-FUNCTION
-            PCL::UPDATE-GF-SIMPLE-ACCESSOR-TYPE
-            PCL::UPDATE-GFS-OF-CLASS
-            PCL::INITIALIZE-INFO-CACHED-SHARED-INITIALIZE-T-FUNCTION
-            PCL::DO-STANDARD-DEFSETFS-FOR-DEFCLASS
-            PCL::STANDARD-SVUC-METHOD
-            PCL::INITIALIZE-INFO-CACHED-SHARED-INITIALIZE-NIL-FUNCTION
-            PCL:EXTRACT-LAMBDA-LIST PCL::%CCLOSURE-ENV
-            PCL::STRUCTURE-SVUC-METHOD
-            PCL::INITIALIZE-INFO-CACHED-CONSTANTS
-            PCL:EXTRACT-SPECIALIZER-NAMES PCL::METHOD-FUNCTION-PLIST
-            PCL::INITIALIZE-INFO-CACHED-COMBINED-INITIALIZE-FUNCTION
-            PCL::INITIALIZE-INFO-CACHED-MAKE-INSTANCE-FUNCTION
-            PCL::INITIALIZE-INFO-CACHED-MAKE-INSTANCE-FUNCTION-SYMBOL
-            PCL::INTERNED-SYMBOL-P PCL::GDEFINITION
-            PCL::UPDATE-CLASS-CAN-PRECEDE-P PCL::%STD-INSTANCE-WRAPPER
-            PCL::%STD-INSTANCE-SLOTS PCL::PV-TABLEP PCL::STD-INSTANCE-P
-            PCL::COMPUTE-MCASE-PARAMETERS PCL::COMPUTE-CLASS-SLOTS
-            PCL::MAKE-PV-TABLE-TYPE-DECLARATION PCL::NET-TEST-CONVERTER
-            PCL:INTERN-EQL-SPECIALIZER
-            PCL::MAKE-INSTANCE-FUNCTION-SYMBOL
-            PCL::UPDATE-ALL-C-A-M-GF-INFO
-            PCL::UPDATE-PV-TABLE-CACHE-INFO PCL::DFUN-INFO-CACHE
-            PCL::NO-METHODS-CACHE PCL::ARG-INFO-APPLYP
-            PCL::INITIAL-CACHE PCL::INITIAL-DISPATCH-CACHE
-            PCL::CHECK-CACHE PCL::DISPATCH-CACHE PCL::CLASS-FROM-TYPE
-            PCL::DEFAULT-METHOD-ONLY-CACHE PCL::DNET-METHODS-P
-            PCL::ACCESSOR-DFUN-INFO-CACHE
-            PCL::METHOD-FUNCTION-FROM-FAST-FUNCTION
-            PCL::ONE-INDEX-DFUN-INFO-CACHE
-            PCL::ONE-INDEX-DFUN-INFO-ACCESSOR-TYPE
-            PCL::METHOD-CALL-CALL-METHOD-ARGS PCL::KEYWORD-SPEC-NAME
-            PCL::N-N-CACHE PCL::GENERIC-CLOBBERS-FUNCTION
-            PCL::N-N-ACCESSOR-TYPE PCL::FAST-METHOD-CALL-PV-CELL
-            PCL::WRAPPER-FOR-STRUCTURE PCL::ONE-CLASS-CACHE
-            PCL::FAST-METHOD-CALL-NEXT-METHOD-CALL
-            PCL::ONE-CLASS-ACCESSOR-TYPE PCL::ONE-CLASS-INDEX
-            PCL::BUILT-IN-WRAPPER-OF PCL::TWO-CLASS-CACHE
-            PCL::BUILT-IN-OR-STRUCTURE-WRAPPER1
-            PCL::TWO-CLASS-ACCESSOR-TYPE PCL::TWO-CLASS-INDEX
-            PCL::ALLOCATE-CACHE-VECTOR PCL::TWO-CLASS-WRAPPER0
-            PCL::FLUSH-CACHE-VECTOR-INTERNAL PCL::ONE-INDEX-CACHE
-            PCL::EARLY-CLASS-NAME PCL::ONE-INDEX-ACCESSOR-TYPE
-            PCL::ONE-INDEX-INDEX PCL::INTERN-FUNCTION-NAME
-            PCL::CHECKING-CACHE PCL::COMPILE-LAMBDA-UNCOMPILED
-            PCL::GF-LAMBDA-LIST PCL::CACHING-CACHE
-            PCL::CONSTANT-VALUE-CACHE PCL::COMPILE-LAMBDA-DEFERRED
-            PCL::FUNCALLABLE-INSTANCE-P
-            PCL::RESET-CLASS-INITIALIZE-INFO PCL::GET-CACHE-VECTOR
-            PCL::CONSTANT-SYMBOL-P PCL::FREE-CACHE-VECTOR
-            PCL::EARLY-METHOD-LAMBDA-LIST PCL::ARG-INFO-VALID-P
-            PCL::DFUN-ARG-SYMBOL PCL::EARLY-METHOD-CLASS
-            PCL::EARLY-GF-P PCL::EARLY-GF-NAME PCL::CACHING-DFUN-INFO
-            PCL::COMPUTE-APPLICABLE-METHODS-EMF-STD-P
-            PCL::CONSTANT-VALUE-DFUN-INFO
-            PCL::RESET-CLASS-INITIALIZE-INFO-1 PCL::FREE-CACHE
-            PCL::PARSE-SPECIALIZERS PCL::RESET-INITIALIZE-INFO
-            PCL::EARLY-METHOD-QUALIFIERS
-            PCL::PROCLAIM-INCOMPATIBLE-SUPERCLASSES PCL::WRAPPER-OF
-            PCL::EARLY-METHOD-STANDARD-ACCESSOR-P
-            PCL::FUNCTION-PRETTY-ARGLIST
-            PCL::GET-MAKE-INSTANCE-FUNCTION PCL::CHECK-WRAPPER-VALIDITY
-            PCL::UNPARSE-SPECIALIZERS PCL::%SYMBOL-FUNCTION
-            PCL::FINAL-ACCESSOR-DFUN-TYPE
-            PCL::COMPLICATED-INSTANCE-CREATION-METHOD
-            PCL::DEFAULT-STRUCTUREP PCL::UPDATE-GF-INFO
-            PCL::CACHE-OWNER PCL::DEFAULT-STRUCTURE-INSTANCE-P
-            PCL::DEFAULT-STRUCTURE-TYPE PCL::STRUCTURE-TYPE
-            PCL::COMPUTE-STD-CPL-PHASE-2 PCL::GET-PV-CELL-FOR-CLASS
-            PCL::STRUCTURE-TYPE-INCLUDED-TYPE-NAME
-            PCL::STRUCTURE-TYPE-SLOT-DESCRIPTION-LIST PCL::CACHE-P
-            PCL::STRUCTURE-SLOTD-NAME
-            PCL::STRUCTURE-SLOTD-ACCESSOR-SYMBOL
-            PCL::DEFAULT-SECONDARY-DISPATCH-FUNCTION
-            PCL::STRUCTURE-SLOTD-WRITER-FUNCTION
-            PCL::FIND-CYCLE-REASONS PCL::EARLY-CLASS-DEFINITION
-            PCL::ECD-SOURCE PCL::STRUCTURE-SLOTD-TYPE
-            PCL::FORMAT-CYCLE-REASONS PCL::ECD-METACLASS PCL::CPD-CLASS
-            PCL::EARLY-CLASS-PRECEDENCE-LIST
-            PCL::METHODS-CONTAIN-EQL-SPECIALIZER-P PCL::CPD-SUPERS
-            PCL::EXPAND-LONG-DEFCOMBIN PCL::EARLY-CLASS-NAME-OF
-            PCL::CPD-AFTER PCL::EXPAND-SHORT-DEFCOMBIN
-            PCL::EARLY-CLASS-SLOTDS PCL::CPD-COUNT
-            PCL::EARLY-SLOT-DEFINITION-NAME PCL::SLOT-READER-SYMBOL
-            PCL::EARLY-SLOT-DEFINITION-LOCATION WALKER::ENV-LOCK
-            PCL::MAKE-INITIAL-DFUN PCL::EARLY-ACCESSOR-METHOD-SLOT-NAME
-            PCL::SLOT-WRITER-SYMBOL WALKER::ENV-DECLARATIONS
-            WALKER::ENV-LEXICAL-VARIABLES PCL::LIST-DFUN
-            PCL::SLOT-BOUNDP-SYMBOL PCL::MAP-ALL-GENERIC-FUNCTIONS
-            PCL::MAKE-STRUCTURE-SLOT-BOUNDP-FUNCTION
-            PCL::EARLY-CLASS-DIRECT-SUBCLASSES
-            PCL::MAKE-FUNCTION-INLINE PCL::LIST-LARGE-CACHE
-            PCL::CLASS-PRECEDENCE-DESCRIPTION-P
-            PCL::INFORM-TYPE-SYSTEM-ABOUT-STD-CLASS
-            PCL::MAKE-DEFAULT-METHOD-GROUP-DESCRIPTION
-            PCL::MAKE-OPTIMIZED-STRUCTURE-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION
-            WALKER::ENV-WALK-FUNCTION
-            WALKER::GET-IMPLEMENTATION-DEPENDENT-WALKER-TEMPLATE
-            PCL::COUNT-DFUN PCL::MAKE-INITFUNCTION
-            PCL::MAKE-OPTIMIZED-STRUCTURE-SETF-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION
-            ITERATE::VARIABLES-FROM-LET WALKER::ENV-WALK-FORM
-            PCL::MAKE-OPTIMIZED-STRUCTURE-SLOT-BOUNDP-USING-CLASS-METHOD-FUNCTION
-            PCL::INITIALIZE-INFO-P PCL::ECD-CLASS-NAME PCL::COPY-CACHE
-            PCL::COMPUTE-LINE-SIZE PCL::CANONICAL-SLOT-NAME
-            WALKER::GET-WALKER-TEMPLATE PCL::EARLY-CLASS-SLOTS
-            PCL::STRUCTURE-TYPE-INTERNAL-SLOTDS PCL::EARLY-COLLECT-CPL
-            PCL::EARLY-COLLECT-SLOTS
-            PCL::METHOD-LL->GENERIC-FUNCTION-LL
-            PCL::EARLY-COLLECT-DEFAULT-INITARGS
-            PCL::ECD-SUPERCLASS-NAMES PCL::METHOD-CALL-P
-            PCL::STRUCTURE-SLOT-BOUNDP ITERATE::SEQUENCE-ACCESSOR
-            PCL::ECD-CANONICAL-SLOTS PCL::ECD-OTHER-INITARGS)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T *) *) PCL::COERCE-TO-CLASS
-            PCL::GET-METHOD-FUNCTION WALKER:MACROEXPAND-ALL
-            PCL::GET-FUNCTION PCL::GET-FUNCTION1
-            PCL:ENSURE-GENERIC-FUNCTION PCL::PARSE-METHOD-OR-SPEC
-            PCL::EXTRACT-DECLARATIONS PCL::GET-DFUN-CONSTRUCTOR
-            PCL::MAP-ALL-CLASSES PCL::MAKE-CACHING-DFUN
-            WALKER:WALK-FORM PCL:ENSURE-CLASS
-            PCL::MAKE-METHOD-FUNCTION-INTERNAL
-            PCL::PARSE-SPECIALIZED-LAMBDA-LIST
-            PCL::MAKE-METHOD-LAMBDA-INTERNAL
-            PCL::MAKE-CONSTANT-VALUE-DFUN PCL::MAKE-FINAL-DFUN-INTERNAL
-            PCL::COMPILE-LAMBDA)) 
-(PROCLAIM '(FTYPE (FUNCTION (T T *) (VALUES T T)) PCL::SYMBOL-APPEND)) 
-(PROCLAIM '(FTYPE (FUNCTION (T *) STRING) PCL::CAPITALIZE-WORDS)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T) *) PCL::SAUT-CLASS
-            PCL::SPECIALIZER-APPLICABLE-USING-TYPE-P PCL::*TYPEP
-            PCL::COMPUTE-TEST PCL::GET-NEW-FUNCTION-GENERATOR-INTERNAL
-            PCL::COMPUTE-CODE PCL::CLASS-APPLICABLE-USING-CLASS-P
-            PCL::SAUT-AND PCL::SAUT-NOT PCL::SAUT-PROTOTYPE
-            COMPILER::CAN-USE-PRINT-CIRCLE-P1 PCL:SLOT-BOUNDP
-            PCL::DESTRUCTURE PCL:SLOT-MAKUNBOUND PCL:SLOT-VALUE
-            PCL::ENSURE-CLASS-VALUES PCL::MAKE-DIRECT-SLOTD
-            PCL::GENERATE-FAST-CLASS-SLOT-ACCESS-P
-            PCL::MUTATE-SLOTS-AND-CALLS PCL::INVOKE-EMF
-            PCL::EMIT-DEFAULT-ONLY-FUNCTION PCL::SPLIT-DECLARATIONS
-            PCL::EMIT-DEFAULT-ONLY COMPILER::C2LAMBDA-EXPR-WITH-KEY
-            PCL::SLOT-NAME-LISTS-FROM-SLOTS PCL::EMIT-CHECKING
-            PCL::UPDATE-SLOT-VALUE-GF-INFO PCL::EMIT-CACHING
-            PCL::SDFUN-FOR-CACHING PCL::SLOT-UNBOUND-INTERNAL
-            PCL::MAKE-INSTANCE-1 PCL::SET-FUNCTION-NAME
-            PCL::COMPUTE-STD-CPL-PHASE-1 PCL::FORM-LIST-TO-LISP
-            PCL::FIND-SUPERCLASS-CHAIN PCL::SAUT-CLASS-EQ
-            PCL::COMPUTE-APPLICABLE-METHODS-USING-TYPES
-            PCL::CHECK-INITARGS-VALUES PCL::SAUT-EQL PCL::*SUBTYPEP
-            ITERATE::PARSE-DECLARATIONS PCL::INITIAL-DFUN)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T *) T) PCL::MAKE-TYPE-PREDICATE-NAME
-            PCL::SET-DFUN PCL:FIND-CLASS PCL::TRACE-METHOD
-            PCL::FIND-CLASS-CELL PCL::MAKE-FINAL-DFUN
-            PCL::PV-TABLE-LOOKUP-PV-ARGS PCL::USE-DISPATCH-DFUN-P
-            WALKER::RELIST* WALKER::RELIST PCL::FIND-CLASS-PREDICATE
-            PCL::EARLY-METHOD-SPECIALIZERS
-            PCL::USE-CONSTANT-VALUE-DFUN-P PCL::MAKE-EARLY-GF
-            PCL::ALLOCATE-FUNCALLABLE-INSTANCE PCL::SET-ARG-INFO
-            PCL::INITIALIZE-METHOD-FUNCTION PCL::UPDATE-DFUN
-            PCL::MAKE-SPECIALIZABLE PCL::ALLOCATE-STRUCTURE-INSTANCE
-            PCL::ALLOCATE-STANDARD-INSTANCE
-            WALKER::WALKER-ENVIRONMENT-BIND-1
-            ITERATE::FUNCTION-LAMBDA-P ITERATE::MAYBE-WARN
-            PCL::MAKE-WRAPPER)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T) (*)) PCL::SORT-APPLICABLE-METHODS
-            PCL::SORT-METHODS)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T) T) PCL::FDEFINE-CAREFULLY
-            PCL::MAKE-INTERNAL-READER-METHOD-FUNCTION
-            PCL::MAKE-STD-READER-METHOD-FUNCTION
-            PCL::MAKE-STD-WRITER-METHOD-FUNCTION
-            ITERATE::SIMPLE-EXPAND-ITERATE-FORM
-            PCL::MAKE-STD-BOUNDP-METHOD-FUNCTION
-            PCL::DO-SATISFIES-DEFTYPE PCL::MEMF-CONSTANT-CONVERTER
-            PCL::COMPUTE-CONSTANTS PCL::CLASS-CAN-PRECEDE-P
-            PCL::SAUT-NOT-CLASS PCL::SAUT-NOT-CLASS-EQ
-            PCL::SAUT-NOT-PROTOTYPE PCL::GF-MAKE-FUNCTION-FROM-EMF
-            PCL::SAUT-NOT-EQL PCL::SUPERCLASSES-COMPATIBLE-P
-            PCL::CLASSES-HAVE-COMMON-SUBCLASS-P
-            SYSTEM:%SET-COMPILED-FUNCTION-NAME PCL:ADD-METHOD
-            SYSTEM::DISPLAY-ENV PCL::DESCRIBE-PACKAGE
-            SYSTEM::DISPLAY-COMPILED-ENV
-            PCL::PRINTING-RANDOM-THING-INTERNAL
-            PCL::MAKE-CLASS-PREDICATE
-            PCL::METHOD-FUNCTION-RETURNING-NIL
-            PCL::METHOD-FUNCTION-RETURNING-T PCL::VARIABLE-CLASS
-            PCL::MAKE-PLIST PCL::REMTAIL PCL:REMOVE-METHOD
-            PCL:SLOT-EXISTS-P PCL::DESTRUCTURE-INTERNAL
-            PCL::ACCESSOR-MISS-FUNCTION
-            PCL::UPDATE-INITIALIZE-INFO-INTERNAL PCL::N-N-DFUN-INFO
-            PCL::MAKE-CAXR PCL::MAKE-CDXR WALKER:VARIABLE-LEXICAL-P
-            WALKER:VARIABLE-SPECIAL-P PCL::CHECKING-DFUN-INFO
-            PCL::MAKE-PV-TABLE-INTERNAL PCL::FIND-SLOT-DEFINITION
-            WALKER::WALK-REPEAT-EVAL WALKER::NOTE-DECLARATION
-            PCL::MAKE-DFUN-LAMBDA-LIST WALKER::NOTE-LEXICAL-BINDING
-            PCL::MAKE-DLAP-LAMBDA-LIST PCL::ADD-DIRECT-SUBCLASSES
-            PCL::COMPUTE-PV PCL::MAKE-DFUN-ARG-LIST PCL::COMPUTE-CALLS
-            PCL::MAKE-FAST-METHOD-CALL-LAMBDA-LIST
-            PCL::UPDATE-ALL-PV-TABLE-CACHES PCL::UPDATE-CLASS
-            PCL::MAP-PV-TABLE-REFERENCES-OF PCL::ADD-SLOT-ACCESSORS
-            WALKER::ENVIRONMENT-FUNCTION PCL::REMOVE-DIRECT-SUBCLASSES
-            PCL::REMOVE-SLOT-ACCESSORS PCL::SYMBOL-LESSP
-            PCL::SYMBOL-OR-CONS-LESSP PCL::|SETF PCL FIND-CLASS|
-            PCL::|SETF PCL FIND-CLASS-PREDICATE|
-            PCL::PV-WRAPPERS-FROM-ALL-ARGS PCL::PV-TABLE-LOOKUP
-            PCL::PROCLAIM-DEFGENERIC PCL::UPDATE-CPL PCL::LIST-EQ
-            PCL::UPDATE-SLOTS PCL::COMPUTE-APPLICABLE-METHODS-FUNCTION
-            PCL::COMPUTE-EMF-FROM-WRAPPERS PCL::UPDATE-INITS
-            PCL::UPDATE-STD-OR-STR-METHODS
-            PCL::SET-STANDARD-SVUC-METHOD PCL::EMIT-1-NIL-DLAP
-            PCL::PLIST-VALUE PCL::SET-STRUCTURE-SVUC-METHOD
-            PCL::EMIT-1-WRAPPER-COMPUTE-PRIMARY-CACHE-LOCATION
-            PCL:FUNCALLABLE-STANDARD-INSTANCE-ACCESS
-            PCL::MEC-ALL-CLASSES-INTERNAL
-            PCL::EMIT-N-WRAPPER-COMPUTE-PRIMARY-CACHE-LOCATION
-            PCL::MEC-ALL-CLASSES PCL::%SET-CCLOSURE-ENV
-            PCL::MEC-ALL-CLASS-LISTS PCL::REDEFINE-FUNCTION
-            PCL::METHODS-CONVERTER PCL::COMPUTE-LAYOUT PCL::NO-SLOT
-            PCL::PV-WRAPPERS-FROM-ALL-WRAPPERS
-            PCL::NET-CONSTANT-CONVERTER PCL::AUGMENT-TYPE
-            PCL::CHANGE-CLASS-INTERNAL
-            PCL:SET-FUNCALLABLE-INSTANCE-FUNCTION
-            PCL::VALUE-FOR-CACHING PCL:STANDARD-INSTANCE-ACCESS
-            PCL::|SETF PCL METHOD-FUNCTION-PLIST| PCL::GET-KEY-ARG
-            PCL::GET-KEY-ARG1 PCL::SET-METHODS
-            PCL::SET-FUNCTION-PRETTY-ARGLIST
-            PCL::FIND-STANDARD-II-METHOD PCL::MAKE-EARLY-ACCESSOR
-            PCL::DOCTOR-DFUN-FOR-THE-DEBUGGER PCL::COMPUTE-STD-CPL
-            PCL::|SETF PCL GDEFINITION|
-            PCL::MAKE-DISCRIMINATING-FUNCTION-ARGLIST PCL::ADD-FORMS
-            PCL::CPL-INCONSISTENT-ERROR
-            PCL::REDIRECT-EARLY-FUNCTION-INTERNAL PCL::ADD-TO-CVECTOR
-            PCL::BOOTSTRAP-SLOT-INDEX PCL::QUALIFIER-CHECK-RUNTIME
-            PCL::CPL-FORWARD-REFERENCED-CLASS-ERROR
-            PCL::REAL-REMOVE-METHOD WALKER::ENVIRONMENT-MACRO
-            PCL::CANONICALIZE-SLOT-SPECIFICATION
-            PCL::CANONICALIZE-DEFCLASS-OPTION PCL::SET-WRAPPER
-            PCL::DEAL-WITH-ARGUMENTS-OPTION
-            PCL::PARSE-QUALIFIER-PATTERN PCL::SWAP-WRAPPERS-AND-SLOTS
-            ITERATE::MV-SETQ PCL::MAKE-UNORDERED-METHODS-EMF
-            PCL::CLASS-MIGHT-PRECEDE-P
-            ITERATE::EXTRACT-SPECIAL-BINDINGS
-            WALKER::VARIABLE-SYMBOL-MACRO-P PCL::RAISE-METATYPE)) 
-(PROCLAIM '(FTYPE (FUNCTION NIL FIXNUM) PCL::GET-WRAPPER-CACHE-NUMBER)) 
-(DOLIST (PCL::V '(PCL::ADD-READER-METHOD
-                     PCL::SHORT-COMBINATION-IDENTITY-WITH-ONE-ARGUMENT
-                     PCL::REMOVE-READER-METHOD PCL::EQL-SPECIALIZER-P
-                     PCL::OBJECT-PLIST
-                     PCL::SLOT-DEFINITION-DEFSTRUCT-ACCESSOR-SYMBOL
-                     PCL::SPECIALIZER-TYPE PCL::GF-DFUN-STATE
-                     PCL::CLASS-DEFSTRUCT-CONSTRUCTOR
-                     PCL::METHOD-FAST-FUNCTION PCL::SPECIALIZERP
-                     PCL::EXACT-CLASS-SPECIALIZER-P
-                     PCL::COMPATIBLE-META-CLASS-CHANGE-P
-                     PCL::UPDATE-GF-DFUN PCL::SPECIALIZER-OBJECT
-                     PCL::ACCESSOR-METHOD-SLOT-NAME
-                     PCL::SPECIALIZER-CLASS PCL::CLASS-EQ-SPECIALIZER-P
-                     PCL::SLOTS-FETCHER PCL::REMOVE-WRITER-METHOD
-                     PCL::STRUCTURE-CLASS-P PCL::UPDATE-CONSTRUCTORS
-                     PCL::DOCUMENTATION PCL::METHOD-PRETTY-ARGLIST
-                     PCL::CLASS-EQ-SPECIALIZER
-                     PCL::INFORM-TYPE-SYSTEM-ABOUT-CLASS
-                     PCL::ACCESSOR-METHOD-CLASS
-                     PCL::GENERIC-FUNCTION-PRETTY-ARGLIST
-                     PCL::MAKE-BOUNDP-METHOD-FUNCTION
-                     PCL::CLASS-PREDICATE-NAME PCL::CLASSP
-                     PCL::LEGAL-QUALIFIERS-P PCL::ADD-BOUNDP-METHOD
-                     PCL::LEGAL-LAMBDA-LIST-P
-                     PCL::|SETF PCL GENERIC-FUNCTION-NAME|
-                     PCL:DESCRIBE-OBJECT PCL::CLASS-INITIALIZE-INFO
-                     PCL::MAKE-WRITER-METHOD-FUNCTION
-                     PCL::|SETF PCL GF-DFUN-STATE|
-                     PCL::|SETF PCL SLOT-DEFINITION-NAME|
-                     PCL::|SETF PCL CLASS-NAME|
-                     PCL::INITIALIZE-INTERNAL-SLOT-FUNCTIONS
-                     PCL::|SETF PCL SLOT-DEFINITION-TYPE|
-                     PCL::METHOD-COMBINATION-P
-                     PCL::|SETF PCL GENERIC-FUNCTION-METHODS|
-                     PCL::|SETF PCL GENERIC-FUNCTION-METHOD-COMBINATION|
-                     PCL::|SETF PCL METHOD-GENERIC-FUNCTION|
-                     PCL::|SETF PCL SLOT-ACCESSOR-STD-P|
-                     PCL::LEGAL-SPECIALIZERS-P
-                     PCL::|SETF PCL OBJECT-PLIST|
-                     PCL::|SETF PCL SLOT-DEFINITION-INITFORM|
-                     PCL::|SETF PCL CLASS-DEFSTRUCT-FORM|
-                     PCL::|SETF PCL GENERIC-FUNCTION-METHOD-CLASS|
-                     PCL::SLOT-ACCESSOR-STD-P
-                     PCL::|SETF PCL GF-PRETTY-ARGLIST|
-                     PCL::|SETF PCL SLOT-ACCESSOR-FUNCTION|
-                     PCL::|SETF PCL SLOT-DEFINITION-LOCATION|
-                     PCL::|SETF PCL SLOT-DEFINITION-READER-FUNCTION|
-                     PCL::|SETF PCL SLOT-DEFINITION-WRITER-FUNCTION|
-                     PCL::|SETF PCL SLOT-DEFINITION-BOUNDP-FUNCTION|
-                     PCL::|SETF PCL SLOT-DEFINITION-INTERNAL-READER-FUNCTION|
-                     PCL::|SETF PCL SLOT-DEFINITION-INTERNAL-WRITER-FUNCTION|
-                     PCL::|SETF PCL SLOT-DEFINITION-ALLOCATION|
-                     PCL::|SETF PCL SLOT-DEFINITION-INITFUNCTION|
-                     PCL::METHOD-COMBINATION-OPTIONS
-                     PCL::|SETF PCL SLOT-DEFINITION-READERS|
-                     PCL::|SETF PCL DOCUMENTATION|
-                     PCL::FUNCALLABLE-STANDARD-CLASS-P
-                     PCL::|SETF PCL SLOT-DEFINITION-CLASS|
-                     PCL::|SETF PCL SLOT-VALUE-USING-CLASS|
-                     PCL::CLASS-CAN-PRECEDE-LIST
-                     PCL::|SETF PCL CLASS-DIRECT-SLOTS|
-                     PCL::|SETF PCL CLASS-SLOTS|
-                     PCL::SLOT-ACCESSOR-FUNCTION
-                     PCL::|SETF PCL CLASS-INCOMPATIBLE-SUPERCLASS-LIST|
-                     PCL::|SETF PCL SLOT-DEFINITION-WRITERS|
-                     PCL::SLOT-CLASS-P PCL::MAKE-READER-METHOD-FUNCTION
-                     PCL::LEGAL-METHOD-FUNCTION-P PCL::GET-METHOD
-                     PCL::SHORT-METHOD-COMBINATION-P PCL::GF-ARG-INFO
-                     PCL::SPECIALIZER-METHOD-TABLE
-                     PCL::MAKE-METHOD-INITARGS-FORM
-                     PCL::CLASS-DEFSTRUCT-FORM PCL::GF-PRETTY-ARGLIST
-                     PCL::SAME-SPECIALIZER-P
-                     PCL::SLOT-DEFINITION-BOUNDP-FUNCTION
-                     PCL::SLOT-DEFINITION-WRITER-FUNCTION
-                     PCL::SLOT-DEFINITION-READER-FUNCTION
-                     PCL::SLOT-DEFINITION-INTERNAL-WRITER-FUNCTION
-                     PCL::SLOT-DEFINITION-INTERNAL-READER-FUNCTION
-                     PCL::SLOT-DEFINITION-CLASS
-                     PCL::EQL-SPECIALIZER-OBJECT
-                     PCL::CLASS-CONSTRUCTORS PCL::SLOTS-TO-INSPECT
-                     PCL::SPECIALIZER-DIRECT-GENERIC-FUNCTIONS
-                     PCL::ADD-WRITER-METHOD
-                     PCL::LONG-METHOD-COMBINATION-FUNCTION
-                     PCL::GENERIC-FUNCTION-P PCL::LEGAL-SLOT-NAME-P
-                     PCL::CLASS-WRAPPER PCL::DEFINITION-SOURCE
-                     PCL::DEFAULT-INITARGS PCL::CLASS-SLOT-VALUE
-                     PCL::FORWARD-REFERENCED-CLASS-P
-                     PCL::GF-FAST-METHOD-FUNCTION-P
-                     PCL::LEGAL-QUALIFIER-P PCL::METHOD-P
-                     PCL::CLASS-SLOT-CELLS
-                     PCL::STANDARD-ACCESSOR-METHOD-P
-                     PCL::STANDARD-GENERIC-FUNCTION-P
-                     PCL::STANDARD-READER-METHOD-P
-                     PCL::STANDARD-METHOD-P
-                     PCL::COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS
-                     PCL::COMPUTE-DEFAULT-INITARGS
-                     PCL::|SETF PCL CLASS-SLOT-VALUE|
-                     PCL::METHOD-COMBINATION-TYPE PCL::STANDARD-CLASS-P
-                     PCL::LEGAL-SPECIALIZER-P
-                     PCL::COMPUTE-SLOT-ACCESSOR-INFO
-                     PCL::STANDARD-BOUNDP-METHOD-P
-                     PCL::RAW-INSTANCE-ALLOCATOR
-                     PCL::|SETF PCL SLOT-DEFINITION-DEFSTRUCT-ACCESSOR-SYMBOL|
-                     PCL::|SETF PCL CLASS-INITIALIZE-INFO|
-                     PCL::COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO
-                     PCL::STANDARD-WRITER-METHOD-P
-                     PCL::CLASS-INCOMPATIBLE-SUPERCLASS-LIST
-                     PCL::WRAPPER-FETCHER
-                     PCL::METHOD-COMBINATION-DOCUMENTATION
-                     PCL::|SETF PCL SLOT-DEFINITION-INITARGS|
-                     PCL::REMOVE-BOUNDP-METHOD
-                     PCL::|SETF PCL CLASS-DEFSTRUCT-CONSTRUCTOR|
-                     PCL::SHORT-COMBINATION-OPERATOR
-                     PCL::REMOVE-NAMED-METHOD
-                     PCL::LEGAL-DOCUMENTATION-P
-                     PCL:CLASS-DIRECT-SUPERCLASSES
-                     PCL:CLASS-DIRECT-SUBCLASSES
-                     PCL:CLASS-DIRECT-DEFAULT-INITARGS
-                     PCL:SLOT-DEFINITION-READERS
-                     PCL:SLOT-VALUE-USING-CLASS
-                     PCL:COMPUTE-APPLICABLE-METHODS PCL:CLASS-NAME
-                     PCL:CLASS-PROTOTYPE PCL:READER-METHOD-CLASS
-                     PCL:REMOVE-METHOD PCL:SLOT-DEFINITION-INITFORM
-                     PCL:UPDATE-INSTANCE-FOR-REDEFINED-CLASS
-                     PCL:UPDATE-INSTANCE-FOR-DIFFERENT-CLASS
-                     PCL:CHANGE-CLASS PCL:METHOD-FUNCTION
-                     PCL:DIRECT-SLOT-DEFINITION-CLASS
-                     PCL:MAKE-METHOD-LAMBDA
-                     PCL:EFFECTIVE-SLOT-DEFINITION-CLASS
-                     PCL:CLASS-SLOTS PCL:COMPUTE-SLOTS
-                     PCL:SLOT-DEFINITION-NAME PCL:FINALIZE-INHERITANCE
-                     PCL:GENERIC-FUNCTION-LAMBDA-LIST
-                     PCL:CLASS-DIRECT-SLOTS PCL:CLASS-DEFAULT-INITARGS
-                     PCL:COMPUTE-DISCRIMINATING-FUNCTION
-                     PCL:CLASS-FINALIZED-P PCL:GENERIC-FUNCTION-NAME
-                     PCL:REMOVE-DEPENDENT
-                     PCL:COMPUTE-CLASS-PRECEDENCE-LIST
-                     PCL:ADD-DEPENDENT PCL:SLOT-BOUNDP-USING-CLASS
-                     PCL:ACCESSOR-METHOD-SLOT-DEFINITION
-                     PCL:SHARED-INITIALIZE PCL:ADD-DIRECT-METHOD
-                     PCL:SLOT-DEFINITION-LOCATION
-                     PCL:SLOT-DEFINITION-INITFUNCTION
-                     PCL:SLOT-DEFINITION-ALLOCATION PCL:ADD-METHOD
-                     PCL:GENERIC-FUNCTION-METHOD-CLASS
-                     PCL:METHOD-SPECIALIZERS
-                     PCL:SLOT-DEFINITION-INITARGS
-                     PCL:WRITER-METHOD-CLASS PCL:ADD-DIRECT-SUBCLASS
-                     PCL:SPECIALIZER-DIRECT-METHODS
-                     PCL:GENERIC-FUNCTION-METHOD-COMBINATION
-                     PCL:ALLOCATE-INSTANCE PCL:COMPUTE-EFFECTIVE-METHOD
-                     PCL:SLOT-DEFINITION-TYPE PCL:SLOT-UNBOUND
-                     PCL:INITIALIZE-INSTANCE PCL:FUNCTION-KEYWORDS
-                     PCL:REINITIALIZE-INSTANCE PCL:VALIDATE-SUPERCLASS
-                     PCL:GENERIC-FUNCTION-METHODS
-                     PCL:REMOVE-DIRECT-METHOD PCL:METHOD-LAMBDA-LIST
-                     PCL:MAKE-INSTANCE
-                     PCL:COMPUTE-EFFECTIVE-SLOT-DEFINITION
-                     PCL:PRINT-OBJECT PCL:METHOD-QUALIFIERS
-                     PCL:METHOD-GENERIC-FUNCTION
-                     PCL:REMOVE-DIRECT-SUBCLASS
-                     PCL:MAKE-INSTANCES-OBSOLETE
-                     PCL:SLOT-MAKUNBOUND-USING-CLASS
-                     PCL:ENSURE-GENERIC-FUNCTION-USING-CLASS
-                     PCL:SLOT-MISSING PCL:MAP-DEPENDENTS
-                     PCL:FIND-METHOD-COMBINATION
-                     PCL:ENSURE-CLASS-USING-CLASS
-                     PCL:NO-APPLICABLE-METHOD
-                     PCL:SLOT-DEFINITION-WRITERS
-                     PCL:COMPUTE-APPLICABLE-METHODS-USING-CLASSES
-                     PCL:CLASS-PRECEDENCE-LIST))
-  (SETF (GET PCL::V 'COMPILER::PROCLAIMED-CLOSURE) T)) 
diff --git a/pcl/sysdef.lisp b/pcl/sysdef.lisp
deleted file mode 100644
index 9da68cd546d86fa3fe767d01564c52a6077fcec2..0000000000000000000000000000000000000000
--- a/pcl/sysdef.lisp
+++ /dev/null
@@ -1,121 +0,0 @@
-;;; -*- Mode: Lisp; Base: 10; Syntax: Common-Lisp; Package: DSYS -*-
-;;; File: sysdef.lisp 
-;;; Author: Richard Harris
-
-(in-package "DSYS")
-
-(defvar *pcl-compiled-p* nil)
-(defvar *pcl-loaded-p* nil)
-
-(unless (boundp 'pcl::*redefined-functions*)
-  (setq pcl::*redefined-functions* nil))
-
-(defun reset-pcl-package ()
-  (pcl::reset-pcl-package)
-  (let ((defsys (subfile '("pcl") :name "defsys")))
-    (setq pcl::*pcl-directory* defsys)
-    (load-file defsys))
-  (mapc #'(lambda (path)
-	    (setf (lfi-fwd (get-loaded-file-info path)) 0))
-	(pcl-binary-files)))
-
-(defun pcl-binary-files ()
-  (pcl::system-binary-files 'pcl::pcl))
-
-(defun maybe-load-defsys (&optional compile-defsys-p)
-  (let ((defsys (subfile '("pcl") :name "defsys"))
-	(*use-default-pathname-type* nil)
-	(*skip-load-if-loaded-p* t)
-	(*skip-compile-file-fwd* 0))
-    (set 'pcl::*pcl-directory* defsys)
-    (when compile-defsys-p
-      (compile-file defsys))
-    (let ((b-s 'pcl::*boot-state*))
-      (when (and (boundp b-s) (symbol-value b-s))
-	#+ignore (reset-pcl-package)))
-    (load-file defsys)))  
-
-(defun maybe-load-pcl (&optional force-p)
-  (unless (and (null force-p)
-	       (fboundp 'pcl::system-binary-files)
-	       (every #'(lambda (path)
-			  (let* ((path-fwd (file-write-date path))
-				 (lfi (get-loaded-file-info path)))
-			    (and lfi path-fwd (= path-fwd (lfi-fwd lfi)))))
-		      (pcl-binary-files)))
-    (let ((b-s 'pcl::*boot-state*))
-      (when (and (boundp b-s) (symbol-value b-s))
-	(reset-pcl-package)))
-    (pcl::load-pcl)))
-
-(defsystem pcl
-    (:pretty-name "PCL")
-  #+akcl
-  (:forms 
-   :compile (let ((cfn (subfile '("pcl") :name "collectfn" :type "lisp")))
-	      (unless (probe-file cfn)
-		(run-unix-command 
-		 (format nil "ln -s ~A ~A"
-			 (namestring (merge-pathnames "../cmpnew/collectfn.lsp" 
-						      si::*system-directory*))
-			 (namestring cfn))))))
-				     
-  #+akcl
-  "collectfn"
-  (:forms 
-   :compile
-   (progn
-     (maybe-load-defsys t)
-     (if (and (fboundp 'pcl::operation-transformations)
-	      (or (null (probe-file (subfile '("pcl") :name "defsys" :type "lisp")))
-		  (every #'(lambda (trans)
-			     (eq (car trans) :load))
-			 (pcl::operation-transformations 'pcl::pcl :compile))))
-	 (maybe-load-pcl)
-	 (let ((b-s 'pcl::*boot-state*))
-	   (when (and (boundp b-s) (symbol-value b-s))
-	     (reset-pcl-package))
-	   #+akcl (compiler::emit-fn t)
-	   #+akcl (load (merge-pathnames "../lsp/sys-proclaim.lisp" 
-					 si::*system-directory*))
-	   (#+cmu with-compilation-unit #-cmu progn
-	    #+cmu (:optimize 
-		   '(optimize (user::debug-info #+(and small (not testing)) .5
-			                        #-(and small (not testing)) 2)
-		              (speed #+testing 1 #-testing 2)
-		              (safety #+testing 3 #-testing 0)
-		              #+ignore (user::inhibit-warnings 2))
-		   :context-declarations
-		   '(#+ignore
-		     (:external (declare (user::optimize-interface 
-					  (safety 2) (debug-info 1))))))
-	     (proclaim #+testing *testing-declaration* 
-		       #-testing *fast-declaration*)
-	     (pcl::compile-pcl))
-	   (reset-pcl-package)
-	   (maybe-load-pcl t)))
-     #+cmu (purify))
-   :load
-   (progn 
-     (maybe-load-pcl)
-     #+cmu (purify))))
-
-(defparameter *pcl-files*
-  '((("systems") "lisp"
-     "pcl")
-    (("pcl") "lisp"
-     "sysdef"
-     "boot" "braid" "cache" "cloe-low" "cmu-low" "combin" "compat"
-     "construct" "coral-low" "cpatch" "cpl" "ctypes" "defclass" "defcombin"
-     "defs" "defsys" "dfun" "dlap" "env" "excl-low" "fin" "fixup" "fngen" "fsc"
-     "gcl-patches" "genera-low" "gold-low" "hp-low" "ibcl-low" "ibcl-patches"
-     "init" "iterate" "kcl-low" "kcl-patches" "lap" "low" "lucid-low" "macros"
-     "methods" "pcl-env-internal" "pcl-env" "pkg" "plap" "precom1" "precom2"
-     "precom4" "pyr-low" "pyr-patches" "quadlap" "rel-7-2-patches" "rel-8-patches"
-     "slots" "std-class" "sys-proclaim" "ti-low" "ti-patches" "vaxl-low" "vector" "walk"
-     "xerox-low" "xerox-patches")
-    (("pcl") "text"
-     "12-7-88-notes" "3-17-88-notes" "3-19-87-notes" "4-21-87-notes"
-     "4-29-87-notes" "5-22-87-notes" "5-22-89-notes" "8-28-88-notes"
-     "get-pcl" "kcl-mods" "kcl-notes" "lap" "notes" "pcl-env" "readme")))
-
diff --git a/pcl/ti-low.lisp b/pcl/ti-low.lisp
deleted file mode 100644
index 95f5e842e2848d8984f0a96e335ae51a7bf11e13..0000000000000000000000000000000000000000
--- a/pcl/ti-low.lisp
+++ /dev/null
@@ -1,83 +0,0 @@
-;;; -*- 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
deleted file mode 100644
index c18986109eda0ff9e4c8f596a86dcf5aef0bb0d3..0000000000000000000000000000000000000000
--- a/pcl/ti-patches.lisp
+++ /dev/null
@@ -1,105 +0,0 @@
-;;;-*-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
deleted file mode 100644
index ae9383bb5d4b432448051303561ef52424a1dbda..0000000000000000000000000000000000000000
--- a/pcl/vaxl-low.lisp
+++ /dev/null
@@ -1,80 +0,0 @@
-;;;-*-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
index dc667763681c70132f030d1a9c0072e3bd231d06..b255a2674fd6d32b7d0e9aefa4957f8597100d80 100644
--- a/pcl/vector.lisp
+++ b/pcl/vector.lisp
@@ -26,7 +26,7 @@
 ;;;
 #+cmu
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/vector.lisp,v 1.12 1998/12/20 04:30:23 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/vector.lisp,v 1.13 1999/03/11 16:51:21 pw Exp $")
 ;;;
 ;;; Permutation vectors.
 ;;;
@@ -1055,9 +1055,6 @@
 		  ((fsc-instance-p arg)
 		   (fsc-instance-wrapper arg))
 		  (t
-		   #+new-kcl-wrapper
-		   (built-in-wrapper-of arg)
-		   #-new-kcl-wrapper
 		   (built-in-or-structure-wrapper arg))))
       (unless (eq 't (wrapper-state w))
 	(setq w (check-wrapper-validity arg)))
diff --git a/pcl/xerox-low.lisp b/pcl/xerox-low.lisp
deleted file mode 100644
index 861884a5a820627ea057cc02479d85c8b58a9138..0000000000000000000000000000000000000000
--- a/pcl/xerox-low.lisp
+++ /dev/null
@@ -1,173 +0,0 @@
-;;; -*- 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
deleted file mode 100644
index 87ed713c0d581f0a3773cfdf7523b07d0858c9d2..0000000000000000000000000000000000000000
--- a/pcl/xerox-patches.lisp
+++ /dev/null
@@ -1,248 +0,0 @@
-;;; -*- 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)
-