diff --git a/pcl/compat.lisp b/pcl/compat.lisp
deleted file mode 100644
index 606915388599787e139609db4539d203cf61bca7..0000000000000000000000000000000000000000
--- a/pcl/compat.lisp
+++ /dev/null
@@ -1,31 +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.
-;;; *************************************************************************
-;;;
-
-(in-package :pcl)
-
-()
-
diff --git a/pcl/defsys.lisp b/pcl/defsys.lisp
index 3f8c49bfb67ecbc464412dd741feb5d37656abca..cb5db3e00ce07016902d9abce2efde88069341ee 100644
--- a/pcl/defsys.lisp
+++ b/pcl/defsys.lisp
@@ -26,7 +26,7 @@
 ;;;
 
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defsys.lisp,v 1.25 2002/08/26 02:23:12 pmai Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defsys.lisp,v 1.26 2002/08/26 02:40:55 pmai 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
@@ -494,7 +494,6 @@ and load your system with:
    (ctypes      t                                   t (defclass defcombin))
    (construct   t                                   t (defclass boot defs low))
    (env         t                                   t (defclass boot defs low fin))
-   (compat      t                                   t ())
    (cmucl-documentation t			    t () CMU)
    (precom1     (dlisp)                             t (defs low cache fin dfun))
    (precom2     (dlisp)                             t (defs low cache fin dfun))
diff --git a/pcl/dlap.lisp b/pcl/dlap.lisp
deleted file mode 100644
index c9ecda9e89bc9170816c9831b10f0ada31342b48..0000000000000000000000000000000000000000
--- a/pcl/dlap.lisp
+++ /dev/null
@@ -1,611 +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.
-;;; *************************************************************************
-;;;
-
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/dlap.lisp,v 1.8 1999/05/30 23:13:57 pw Exp $")
-;;;
-
-(in-package :pcl)
-
-
-
-(defun emit-one-class-reader (class-slot-p)
-  (emit-reader/writer :reader 1 class-slot-p))
-
-(defun emit-one-class-writer (class-slot-p)
-  (emit-reader/writer :writer 1 class-slot-p))
-
-(defun emit-two-class-reader (class-slot-p)
-  (emit-reader/writer :reader 2 class-slot-p))
-
-(defun emit-two-class-writer (class-slot-p)
-  (emit-reader/writer :writer 2 class-slot-p))
-
-
-
-(defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p)
-  (let ((instance nil)
-	(arglist  ())
-	(closure-variables ())
-	(field (first-wrapper-cache-number-index))) 
-    ;;we need some field to do the fast obsolete check
-    (ecase reader/writer
-      (:reader (setq instance (dfun-arg-symbol 0)
-		     arglist  (list instance)))
-      (:writer (setq instance (dfun-arg-symbol 1)
-		     arglist  (list (dfun-arg-symbol 0) instance))))
-    (ecase 1-or-2-class
-      (1 (setq closure-variables '(wrapper-0 index miss-fn)))
-      (2 (setq closure-variables '(wrapper-0 wrapper-1 index miss-fn))))
-    (generating-lap closure-variables
-		    arglist
-       (with-lap-registers ((inst t)				   ;reg for the instance
-			    (wrapper t)
-			    (cnv fixnum-vector)
-			    (cache-no index))			   ;reg for the cache no
-	  (let ((index cache-no)				   ;This register is used
-								   ;for different values at
-								   ;different times.
-		(slots (and (null class-slot-p)
-			    (allocate-register 'vector)))
-		(csv   (and class-slot-p
-			    (allocate-register t))))
-	    (prog1 (flatten-lap
-		     (opcode :move (operand :arg instance) inst)   ;get the instance
-		     (opcode :std-instance-p inst 'std-instance)   ;if not either std-inst
-		     (opcode :fsc-instance-p inst 'fsc-instance)   ;or fsc-instance then
-		     (opcode :go 'trap)				   ;we lose
-
-		     (opcode :label 'fsc-instance)
-		     (opcode :move (operand :fsc-wrapper inst) wrapper)
-		     (and slots
-			  (opcode :move (operand :fsc-slots inst) slots))
-		     (opcode :go 'have-wrapper)
-
-		     (opcode :label 'std-instance)
-		     (opcode :move (operand :std-wrapper inst) wrapper)
-		     (and slots
-			  (opcode :move (operand :std-slots inst) slots))
-
-		     (opcode :label 'have-wrapper)
-		     (opcode :move (emit-wrapper-cache-number-vector wrapper) cnv)
-		     (opcode :move (operand :cref cnv field) cache-no)
-		     (opcode :izerop cache-no 'trap)		   ;obsolete wrapper?
-
-		     (ecase 1-or-2-class
-		       (1 (emit-check-1-class-wrapper wrapper 'wrapper-0 'trap))
-		       (2 (emit-check-2-class-wrapper wrapper 'wrapper-0 'wrapper-1 'trap)))
-		     
-		     (if class-slot-p
-			 (flatten-lap
-			  (opcode :move (operand :cvar 'index) csv)
-			  (ecase reader/writer
-			   (:reader (emit-get-class-slot csv 'trap inst))
-			   (:writer (emit-set-class-slot csv (car arglist) inst))))
-		       (flatten-lap
-			(opcode :move (operand :cvar 'index) index)
-			(ecase reader/writer
-			   (:reader (emit-get-slot slots index 'trap inst))
-			   (:writer (emit-set-slot slots index (car arglist) inst)))))
-	      
-		     (opcode :label 'trap)
-		     (emit-miss 'miss-fn))
-	      (when slots (deallocate-register slots))
-	      (when csv (deallocate-register csv))))))))
-
-
-
-(defun emit-one-index-readers (class-slot-p)
-  (let ((arglist (list (dfun-arg-symbol 0))))
-    (generating-lap '(field cache-vector mask size index miss-fn)
-		    arglist
-      (with-lap-registers ((slots vector))
-	(emit-dlap  arglist
-		    '(standard-instance)
-		    'trap
-		    (with-lap-registers ((index index))
-		      (flatten-lap
-			(opcode :move (operand :cvar 'index) index)
-			(if class-slot-p
-			    (emit-get-class-slot index 'trap slots)
-			    (emit-get-slot slots index 'trap))))
-		    (flatten-lap
-		      (opcode :label 'trap)
-		      (emit-miss 'miss-fn))
-		    nil
-		    (and (null class-slot-p) (list slots)))))))
-
-(defun emit-one-index-writers (class-slot-p)
-  (let ((arglist (list (dfun-arg-symbol 0) (dfun-arg-symbol 1))))
-    (generating-lap '(field cache-vector mask size index miss-fn)
-		    arglist
-      (with-lap-registers ((slots vector))
-	(emit-dlap arglist
-		   '(t standard-instance)
-		   'trap
-		   (with-lap-registers ((index index))
-		     (flatten-lap
-		       (opcode :move (operand :cvar 'index) index)
-		       (if class-slot-p
-			   (emit-set-class-slot index (dfun-arg-symbol 0) slots)
-			   (emit-set-slot slots index (dfun-arg-symbol 0)))))
-		   (flatten-lap
-		     (opcode :label 'trap)
-		     (emit-miss 'miss-fn))
-		   nil
-		   (and (null class-slot-p) (list nil slots)))))))
-
-
-
-(defun emit-n-n-readers ()
-  (let ((arglist (list (dfun-arg-symbol 0))))
-    (generating-lap '(field cache-vector mask size miss-fn)
-		    arglist
-      (with-lap-registers ((slots vector)
-			   (index index))
-	(emit-dlap arglist
-		   '(standard-instance)
-		   'trap
-		   (emit-get-slot slots index 'trap)
-		   (flatten-lap
-		     (opcode :label 'trap)
-		     (emit-miss 'miss-fn))
-		   index
-		   (list slots))))))
-
-(defun emit-n-n-writers ()
-  (let ((arglist (list (dfun-arg-symbol 0) (dfun-arg-symbol 1))))
-    (generating-lap '(field cache-vector mask size miss-fn)
-		    arglist
-      (with-lap-registers ((slots vector)
-			   (index index))
-	(flatten-lap
-	  (emit-dlap arglist
-		     '(t standard-instance)
-		     'trap
-		     (emit-set-slot slots index (dfun-arg-symbol 0))
-		     (flatten-lap
-		       (opcode :label 'trap)
-		       (emit-miss 'miss-fn))
-		     index
-		     (list nil slots)))))))
-  
-
-
-(defun emit-checking (metatypes applyp)
-  (let ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp)))
-    (generating-lap '(field cache-vector mask size emf miss-fn)
-		    dlap-lambda-list
-      (emit-dlap (remove '&rest dlap-lambda-list)
-		 metatypes		 
-		 'trap
-		 (with-lap-registers ((emf t))
-		   (flatten-lap
-		     (opcode :move (operand :cvar 'emf) emf)
-		     (opcode :emf-call emf)))
-		 (with-lap-registers ((miss-function t))
-		   (flatten-lap
-		     (opcode :label 'trap)
-		     (opcode :move (operand :cvar 'miss-fn) miss-function)
-		     (opcode :jmp miss-function)))
-		 nil))))
-
-(defun emit-caching (metatypes applyp)
-  (let ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp)))
-    (generating-lap '(field cache-vector mask size miss-fn)
-		    dlap-lambda-list
-      (with-lap-registers ((emf t))
-	(emit-dlap (remove '&rest dlap-lambda-list)
-		   metatypes
-		   'trap
-		   (flatten-lap
-		    (opcode :emf-call emf))
-		   (with-lap-registers ((miss-function t))
-		     (flatten-lap
-		       (opcode :label 'trap)
-		       (opcode :move (operand :cvar 'miss-fn) miss-function)
-		       (opcode :jmp miss-function)))
-		   emf)))))
-
-(defun emit-constant-value (metatypes)
-  (let ((dlap-lambda-list (make-dlap-lambda-list metatypes nil)))
-    (generating-lap '(field cache-vector mask size miss-fn)
-		    dlap-lambda-list
-      (with-lap-registers ((value t))
-	(emit-dlap dlap-lambda-list
-		   metatypes
-		   'trap
-		   (flatten-lap
-		     (opcode :return value))
-		   (with-lap-registers ((miss-function t))
-		     (flatten-lap
-		       (opcode :label 'trap)
-		       (opcode :move (operand :cvar 'miss-fn) miss-function)
-		       (opcode :jmp miss-function)))
-		   value)))))
-
-
-
-(defun emit-check-1-class-wrapper (wrapper cwrapper-0 miss-label)
-  (with-lap-registers ((cwrapper t))
-    (flatten-lap
-     (opcode :move (operand :cvar cwrapper-0) cwrapper)
-     (opcode :neq wrapper cwrapper miss-label))))		;wrappers not eq, trap
-
-(defun emit-check-2-class-wrapper (wrapper cwrapper-0 cwrapper-1 miss-label)
-  (with-lap-registers ((cwrapper t))
-    (flatten-lap
-     (opcode :move (operand :cvar cwrapper-0) cwrapper)		;This is an OR.  Isn't
-     (opcode :eq wrapper cwrapper 'hit-internal)		;assembly code fun
-     (opcode :move (operand :cvar cwrapper-1) cwrapper)		;
-     (opcode :neq wrapper cwrapper miss-label)			;
-     (opcode :label 'hit-internal))))
-
-(defun emit-get-slot (slots index trap-label &optional temp)
-  (let ((slot-unbound (operand :constant *slot-unbound*)))
-    (with-lap-registers ((val t :reuse temp))
-      (flatten-lap
-	(opcode :move (operand :instance-ref slots index) val)  ;get slot value
-	(opcode :eq val slot-unbound trap-label)		;is the slot unbound?
-	(opcode :return val)))))				;return the slot value
-
-(defun emit-set-slot (slots index new-value-arg &optional temp)
-  (with-lap-registers ((new-val t :reuse temp))
-    (flatten-lap
-      (opcode :move (operand :arg new-value-arg) new-val)	;get new value into a reg
-      (opcode :move new-val (operand :instance-ref slots index));set slot value
-      (opcode :return new-val))))
-
-(defun emit-get-class-slot (index trap-label &optional temp)
-  (let ((slot-unbound (operand :constant *slot-unbound*)))
-    (with-lap-registers ((val t :reuse temp))
-      (flatten-lap
-	(opcode :move (operand :cdr index) val)
-	(opcode :eq val slot-unbound trap-label)
-	(opcode :return val)))))
-
-(defun emit-set-class-slot (index new-value-arg &optional temp)
-  (with-lap-registers ((new-val t :reuse temp))
-    (flatten-lap
-      (opcode :move (operand :arg new-value-arg) new-val)
-      (opcode :move new-val (operand :cdr index))
-      (opcode :return new-val))))
-
-(defun emit-miss (miss-fn)
-  (with-lap-registers ((miss-fn-reg t))
-    (flatten-lap
-     (opcode :move (operand :cvar miss-fn) miss-fn-reg)		;get the miss function
-     (opcode :jmp miss-fn-reg))))				;and call it
-
-
-
-(defun dlap-wrappers (metatypes)
-  (mapcar #'(lambda (x) (and (neq x 't)
-			     (allocate-register t)))
-	  metatypes))
-
-(defun dlap-wrapper-moves (wrappers args metatypes miss-label slot-regs)
-  (gathering1 (collecting)
-    (iterate ((mt (list-elements metatypes))
-	      (arg (list-elements args))
-	      (wrapper (list-elements wrappers))
-	      (i (interval :from 0)))
-       (when wrapper
-         (gather1
-	   (emit-fetch-wrapper mt arg wrapper miss-label (nth i slot-regs)))))))
-
-(defun emit-dlap (args metatypes miss-label hit miss value-reg &optional slot-regs)
-  (let* ((wrappers (dlap-wrappers metatypes))
-	 (nwrappers (remove nil wrappers))
-	 (wrapper-moves (dlap-wrapper-moves wrappers args metatypes miss-label slot-regs)))
-    (prog1 (emit-dlap-internal nwrappers
-			       wrapper-moves
-			       hit
-			       miss
-			       miss-label
-			       value-reg)
-	   (mapc #'deallocate-register nwrappers))))
-
-(defun emit-dlap-internal (wrapper-regs wrapper-moves hit miss miss-label value-reg)
-  (cond ((cdr wrapper-regs)
-	 (emit-greater-than-1-dlap
-	   wrapper-regs wrapper-moves hit miss miss-label value-reg))
-	((null value-reg)
-	 (emit-1-nil-dlap
-	   (car wrapper-regs) (car wrapper-moves) hit miss miss-label))
-	(t
-	 (emit-1-t-dlap
-	   (car wrapper-regs) (car wrapper-moves) hit miss miss-label value-reg))))
-
-
-
-(defun emit-1-nil-dlap (wrapper wrapper-move hit miss miss-label)
-  (with-lap-registers ((location index)
-		       (primary index)
-		       (cache-vector vector))
-    (flatten-lap
-      wrapper-move
-      (opcode :move (operand :cvar 'cache-vector) cache-vector)
-      (with-lap-registers ((wrapper-cache-no index))
-	(flatten-lap
-	  (emit-1-wrapper-compute-primary-cache-location wrapper primary wrapper-cache-no)
-	  (opcode :move primary location)
-	  (emit-check-1-wrapper-in-cache cache-vector location wrapper hit)	   ;inline hit code
-	  (opcode :izerop wrapper-cache-no miss-label)))
-      (with-lap-registers ((size index))
-	(flatten-lap
-	  (opcode :move (operand :cvar 'size) size)
-	  (opcode :label 'loop)
-	  (opcode :move (operand :i1+ location) location)
-	  (opcode :fix= location primary miss-label)
-	  (opcode :fix= location size 'set-location-to-min)
-	  (opcode :label 'continue)
-	  (emit-check-1-wrapper-in-cache cache-vector location wrapper hit) 
-	  (opcode :go 'loop)
-	  (opcode :label 'set-location-to-min)
-	  (opcode :izerop primary miss-label)
-	  (opcode :move (operand :constant (index-value->index 0)) location)
-	  (opcode :go 'continue)))
-      miss)))
-
-;;;
-;;; The function below implements CACHE-VECTOR-LOCK-COUNT as the first entry 
-;;; in a cache (svref cache-vector 0).  This should probably be abstracted.
-;;;
-(defun emit-1-t-dlap (wrapper wrapper-move hit miss miss-label value)
-  (with-lap-registers ((location index)
-		       (primary index)
-		       (cache-vector vector)
-		       (initial-lock-count t))
-    (flatten-lap
-      wrapper-move
-      (opcode :move (operand :cvar 'cache-vector) cache-vector)
-      (with-lap-registers ((wrapper-cache-no index))
-	(flatten-lap
-	  (emit-1-wrapper-compute-primary-cache-location wrapper primary wrapper-cache-no)
-	  (opcode :move primary location)
-	  (opcode :move (operand :cref cache-vector 0) initial-lock-count)	   ;get lock-count
-	  (emit-check-cache-entry cache-vector location wrapper 'hit-internal)
-	  (opcode :izerop wrapper-cache-no miss-label)))    ;check for obsolescence
-      (with-lap-registers ((size index))
-	(flatten-lap
-	  (opcode :move (operand :cvar 'size) size)
-
-	  (opcode :label 'loop)
-	  (opcode :move (operand :i1+ location) location)
-	  (opcode :move (operand :i1+ location) location)
-	  (opcode :label 'continue)
-	  (opcode :fix= location primary miss-label)
-	  (opcode :fix= location size 'set-location-to-min)
-	  (emit-check-cache-entry cache-vector location wrapper 'hit-internal)
-	  (opcode :go 'loop)
-
-	  (opcode :label 'set-location-to-min)
-	  (opcode :izerop primary miss-label)
-	  (opcode :move (operand :constant (index-value->index 2)) location)
-	  (opcode :go 'continue)))
-      (opcode :label 'hit-internal)
-      (opcode :move (operand :i1+ location) location)		   ;position for getting value
-      (opcode :move (emit-cache-vector-ref cache-vector location) value)
-      (emit-lock-count-test initial-lock-count cache-vector 'hit)
-      miss
-      (opcode :label 'hit)
-      hit)))
-
-(defun emit-greater-than-1-dlap (wrappers wrapper-moves hit miss miss-label value)
-  (let ((cache-line-size (compute-line-size (+ (length wrappers) (if value 1 0)))))
-    (with-lap-registers ((location index)
-			 (primary index)
-			 (cache-vector vector)
-			 (initial-lock-count t)
-			 (next-location index)
-			 (line-size index))	;Line size holds a constant
-						;that can be folded in if there was
-						;a way to add a constant to 
-						;an index register
-      (flatten-lap
-	(apply #'flatten-lap wrapper-moves)
-	(opcode :move (operand :constant cache-line-size) line-size)
-	(opcode :move (operand :cvar 'cache-vector) cache-vector)
-	(emit-n-wrapper-compute-primary-cache-location wrappers primary miss-label)
-	(opcode :move primary location)
-	(opcode :move location next-location)
-	(opcode :move (operand :cref cache-vector 0) initial-lock-count)  ;get the lock-count
-	(with-lap-registers ((size index))
-	  (flatten-lap
-	    (opcode :move (operand :cvar 'size) size)
-	    (opcode :label 'continue)
-	    (opcode :move (operand :i+ location line-size) next-location)
-	    (emit-check-cache-line cache-vector location wrappers 'hit)
-	    (emit-adjust-location location next-location primary size 'continue miss-label)
-	    (opcode :label 'hit)
-	    (and value (opcode :move (emit-cache-vector-ref cache-vector location) value))
-	    (emit-lock-count-test initial-lock-count cache-vector 'hit-internal)
-	    miss
-	    (opcode :label 'hit-internal)
-	    hit))))))
-
-
-
-;;;
-;;; Cache related lap code
-;;;
-
-(defun emit-check-1-wrapper-in-cache (cache-vector location wrapper hit-code)
-  (let ((exit-emit-check-1-wrapper-in-cache 
-	  (make-symbol "exit-emit-check-1-wrapper-in-cache")))
-    (with-lap-registers ((cwrapper  t))
-      (flatten-lap
-	(opcode :move (emit-cache-vector-ref cache-vector location) cwrapper)
-	(opcode :neq cwrapper wrapper exit-emit-check-1-wrapper-in-cache)
-	hit-code
-	(opcode :label exit-emit-check-1-wrapper-in-cache)))))
-
-(defun emit-check-cache-entry (cache-vector location wrapper hit-label)
-  (with-lap-registers ((cwrapper t))
-    (flatten-lap
-      (opcode :move (emit-cache-vector-ref cache-vector location) cwrapper)
-      (opcode :eq cwrapper wrapper hit-label))))
-
-(defun emit-check-cache-line (cache-vector location wrappers hit-label)
-  (let ((checks
-	  (flatten-lap
-	    (gathering1 (flattening-lap)
-	      (iterate ((wrapper (list-elements wrappers)))
-		(with-lap-registers ((cwrapper t))
-		  (gather1
-		    (flatten-lap
-		      (opcode :move (emit-cache-vector-ref cache-vector location) cwrapper)
-		      (opcode :neq cwrapper wrapper 'exit-emit-check-cache-line)
-		      (opcode :move (operand :i1+ location) location)))))))))
-    (flatten-lap
-      checks
-      (opcode :go hit-label)
-      (opcode :label 'exit-emit-check-cache-line))))
-
-(defun emit-lock-count-test (initial-lock-count cache-vector hit-label)
-  ;;
-  ;; jumps to hit-label if cache-vector-lock-count consistent, otherwise, continues
-  ;; 
-  (with-lap-registers ((new-lock-count t))
-    (flatten-lap
-      (opcode :move (operand :cref cache-vector 0) new-lock-count) ;get new cache-vector-lock-count
-      (opcode :fix= new-lock-count initial-lock-count hit-label))))
-
-
-
-(defun emit-adjust-location (location next-location primary size cont-label miss-label)
-  (flatten-lap
-    (opcode :move next-location location)
-    (opcode :fix= location size 'at-end-of-cache)
-    (opcode :fix= location primary miss-label)
-    (opcode :go cont-label)
-    (opcode :label 'at-end-of-cache)
-    (opcode :fix= primary (operand :constant (index-value->index 1)) miss-label)
-    (opcode :move (operand :constant (index-value->index 1)) location)
-    (opcode :go cont-label)))
-     
-
-;; From cache.lisp
-(defun emit-cache-vector-ref (cache-vector-operand location-operand)
-  (operand :iref cache-vector-operand location-operand))
-
-(defun emit-wrapper-ref (wrapper-operand field-operand)
-  (operand :iref wrapper-operand field-operand))
-
-(defun emit-wrapper-cache-number-vector (wrapper-operand)
-  (operand :wrapper-cache-number-vector wrapper-operand))
-
-(defun emit-cache-number-vector-ref (cnv-operand field-operand)
-  (operand :iref cnv-operand field-operand))
-
-(defun emit-1-wrapper-compute-primary-cache-location (wrapper primary wrapper-cache-no)
-  (with-lap-registers ((mask index) 
-		       (cnv fixnum-vector))
-    (let ((field wrapper-cache-no))
-      (flatten-lap
-        (opcode :move (operand :cvar 'mask) mask)
-        (opcode :move (operand :cvar 'field) field)
-	(opcode :move (emit-wrapper-cache-number-vector wrapper) cnv)
-	(opcode :move (emit-cache-number-vector-ref cnv field) wrapper-cache-no)
-        (opcode :move (operand :ilogand wrapper-cache-no mask) primary)))))
-
-(defun emit-n-wrapper-compute-primary-cache-location (wrappers primary miss-label)
-  (with-lap-registers ((field index)
-		       (mask index))
-    (let ((add-wrapper-cache-numbers
-	   (flatten-lap
-	    (gathering1 (flattening-lap)
-	       (iterate ((wrapper (list-elements wrappers))
-			 (i (interval :from 1)))
-		 (gather1
-		  (with-lap-registers ((wrapper-cache-no index)
-				       (cnv fixnum-vector))
-		    (flatten-lap
-		     (opcode :move (emit-wrapper-ref wrapper field) wrapper-cache-no)
-		     (opcode :move (emit-wrapper-cache-number-vector wrapper) cnv)
-		     (opcode :move (emit-cache-number-vector-ref cnv field)
-			     wrapper-cache-no)
-		     (opcode :izerop wrapper-cache-no miss-label)
-		     (opcode :move (operand :i+ primary wrapper-cache-no) primary)
-		     (when (zerop (mod i wrapper-cache-number-adds-ok))
-		       (opcode :move (operand :ilogand primary mask) primary))))))))))
-      (flatten-lap
-       (opcode :move (operand :constant 0) primary)
-       (opcode :move (operand :cvar 'field) field)
-       (opcode :move (operand :cvar 'mask) mask)
-       add-wrapper-cache-numbers
-       (opcode :move (operand :ilogand primary mask) primary)
-       (opcode :move (operand :i1+ primary) primary)))))
-
-(defun emit-fetch-wrapper (metatype argument dest miss-label &optional slot)
-  (let ((exit-emit-fetch-wrapper (make-symbol "exit-emit-fetch-wrapper")))
-    (with-lap-registers ((arg t))
-      (ecase metatype
-	((standard-instance)
-	  (let ((get-std-inst-wrapper (make-symbol "get-std-inst-wrapper"))
-		(get-fsc-inst-wrapper (make-symbol "get-fsc-inst-wrapper")))
-	    (flatten-lap
-	      (opcode :move (operand :arg argument) arg)
-	      (opcode :std-instance-p arg get-std-inst-wrapper)	   ;is it a std wrapper?
-	      (opcode :fsc-instance-p arg get-fsc-inst-wrapper)	   ;is it a fsc wrapper?
-	      (opcode :go miss-label)
-	      (opcode :label get-fsc-inst-wrapper)
-	      (opcode :move (operand :fsc-wrapper arg) dest)	   ;get fsc wrapper
-	      (and slot
-		   (opcode :move (operand :fsc-slots arg) slot))
-	      (opcode :go exit-emit-fetch-wrapper)
-	      (opcode :label get-std-inst-wrapper)
-	      (opcode :move (operand :std-wrapper arg) dest)	   ;get std wrapper
-	      (and slot
-		   (opcode :move (operand :std-slots arg) slot))
-	      (opcode :label exit-emit-fetch-wrapper))))
-	(class
-	  (when slot (error "Can't do a slot reg for this metatype."))
-	  (let ((get-std-inst-wrapper (make-symbol "get-std-inst-wrapper"))
-		(get-fsc-inst-wrapper (make-symbol "get-fsc-inst-wrapper")))
-	    (flatten-lap
-	      (opcode :move (operand :arg argument) arg)
-	      (opcode :std-instance-p arg get-std-inst-wrapper)
-	      (opcode :fsc-instance-p arg get-fsc-inst-wrapper)
-	      (opcode :move (operand :built-in-or-structure-wrapper arg) dest)
-	      (opcode :go exit-emit-fetch-wrapper)
-	      (opcode :label get-fsc-inst-wrapper)
-	      (opcode :move (operand :fsc-wrapper arg) dest)
-	      (opcode :go exit-emit-fetch-wrapper)
-	      (opcode :label get-std-inst-wrapper)
-	      (opcode :move (operand :std-wrapper arg) dest)
-	      (opcode :label exit-emit-fetch-wrapper))))
-	((built-in-instance structure-instance)
-	  (when slot (error "Can't do a slot reg for this metatype."))
-	  (let ()
-	    (flatten-lap
-	      (opcode :move (operand :arg argument) arg)
-	      (opcode :std-instance-p arg miss-label)
-	      (opcode :fsc-instance-p arg miss-label)
-	      (opcode :move (operand :built-in-or-structure-wrapper arg) dest))))))))
-
diff --git a/pcl/inline.lisp b/pcl/inline.lisp
deleted file mode 100644
index 91122050edc7d61a2d0182b762a2e4f89c9b2585..0000000000000000000000000000000000000000
--- a/pcl/inline.lisp
+++ /dev/null
@@ -1,263 +0,0 @@
-;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
-
-(in-package :pcl)
-
-;; This file contains some of the things that will have to change to support
-;; inlining of methods.
-
-(defun make-method-lambda-internal (method-lambda &optional env)
-  (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda))
-    (error "The method-lambda argument to make-method-lambda, ~S,~
-            is not a lambda form" method-lambda))
-  (multiple-value-bind (documentation declarations real-body)
-      (extract-declarations (cddr method-lambda) env)
-    (let* ((name-decl (get-declaration 'method-name declarations))
-	   (sll-decl (get-declaration 'method-lambda-list declarations))
-	   (method-name (when (consp name-decl) (car name-decl)))
-	   (generic-function-name (when method-name (car method-name)))
-	   (specialized-lambda-list (or sll-decl (cadr method-lambda))))
-      (multiple-value-bind (parameters lambda-list specializers)
-	  (parse-specialized-lambda-list specialized-lambda-list)
-	(let* ((required-parameters
-		(mapcar #'(lambda (r s) (declare (ignore s)) r)
-			parameters
-			specializers))
-	       (slots (mapcar #'list required-parameters))
-	       (calls (list nil))
-	       (parameters-to-reference
-		(make-parameter-references specialized-lambda-list
-					   required-parameters
-					   declarations
-					   method-name
-					   specializers))
-	       (class-declarations
-		`(declare
-		  ,@(remove nil
-			    (mapcar #'(lambda (a s) (and (symbolp s)
-							 (neq s 't)
-							 `(class ,a ,s)))
-				    parameters
-				    specializers))))
-	       (method-lambda
-		  ;; Remove the documentation string and insert the
-		  ;; appropriate class declarations.  The documentation
-		  ;; string is removed to make it easy for us to insert
-		  ;; new declarations later, they will just go after the
-		  ;; cadr of the method lambda.  The class declarations
-		  ;; are inserted to communicate the class of the method's
-		  ;; arguments to the code walk.
-		  `(lambda ,lambda-list
-		     ,class-declarations
-		     ,@declarations
-		     (progn ,@parameters-to-reference)
-		     (block ,(if (listp generic-function-name)
-				 (cadr generic-function-name)
-				 generic-function-name)
-		       ,@real-body)))
-	       (constant-value-p (and (null (cdr real-body))
-				      (constantp (car real-body))))
-	       (constant-value (and constant-value-p
-				    (eval (car real-body))))
-	       (plist (if (and constant-value-p
-			       (or (typep constant-value '(or number character))
-				   (and (symbolp constant-value)
-					(symbol-package constant-value))))
-			  (list :constant-value constant-value)
-			  ()))
-	       (applyp (dolist (p lambda-list nil)
-			 (cond ((memq p '(&optional &rest &key))
-				(return t))
-			       ((eq p '&aux)
-				(return nil))))))
-	    (multiple-value-bind (walked-lambda call-next-method-p closurep
-						next-method-p-p)
-		(walk-method-lambda method-lambda required-parameters env 
-				    slots calls)
-	      (multiple-value-bind (ignore walked-declarations walked-lambda-body)
-		  (extract-declarations (cddr walked-lambda))
-		(declare (ignore ignore))
-		(when (or next-method-p-p call-next-method-p)
-		  (setq plist (list* :needs-next-methods-p 't plist)))
-		(when (some #'cdr slots)
-		  (multiple-value-bind (slot-name-lists call-list)
-		      (slot-name-lists-from-slots slots calls)
-		    (let ((pv-table-symbol (make-symbol "pv-table")))
-		      (setq plist 
-			    `(,@(when slot-name-lists 
-				  `(:slot-name-lists ,slot-name-lists))
-			      ,@(when call-list
-				  `(:call-list ,call-list))
-			      :pv-table-symbol ,pv-table-symbol
-			      ,@plist))
-		      (setq walked-lambda-body
-			    `((pv-binding (,required-parameters ,slot-name-lists
-					   ,pv-table-symbol)
-			       ,@walked-lambda-body))))))
-		(when (and (memq '&key lambda-list)
-			   (not (memq '&allow-other-keys lambda-list)))
-		  (let ((aux (memq '&aux lambda-list)))
-		    (setq lambda-list (nconc (ldiff lambda-list aux)
-					     (list '&allow-other-keys)
-					     aux))))
-		(values `(lambda (.method-args. .next-methods.)
-			   (simple-lexical-method-functions
-			       (,lambda-list .method-args. .next-methods.
-				:call-next-method-p ,call-next-method-p 
-				:next-method-p-p ,next-method-p-p
-				:closurep ,closurep
-				:applyp ,applyp)
-			     ,@walked-declarations
-			     ,@walked-lambda-body))
-			`(,@(when plist 
-			      `(:plist ,plist))
-			  ,@(when documentation 
-			      `(:documentation ,documentation)))))))))))
-
-(define-inline-function slot-value (instance slot-name) (form closure-p env)
-  :predicate (and (not closure-p) (constantp slot-name))
-  :inline-arguments (required-parameters slots)
-  :inline (optimize-slot-value     
-	   slots
-	   (can-optimize-access form required-parameters env)
-	   form))
-
-;collect information about:
-; uses of the required-parameters
-; uses of call-next-method and next-method-p:
-;   called-p
-;   apply-p
-;   arglist info
-;optimize calls to slot-value, set-slot-value, slot-boundp
-;optimize calls to find-class
-;optimize generic-function calls
-(defun make-walk-function (required-parameters info slots calls)
-  #'(lambda (form context env)
-      (cond ((not (eq context ':eval)) form)
-	    ((not (listp form)) form)
-	    ((eq (car form) 'call-next-method)
-	     (setq call-next-method-p 't)
-	     form)
-	    ((eq (car form) 'next-method-p)
-	     (setq next-method-p-p 't)
-	     form)
-	    ((and (eq (car form) 'function)
-		  (cond ((eq (cadr form) 'call-next-method)
-			 (setq call-next-method-p 't)
-			 (setq closurep t)
-			 form)
-			((eq (cadr form) 'next-method-p)
-			 (setq next-method-p-p 't)
-			 (setq closurep t)
-			 form)
-			(t nil))))
-	    ((and (or (eq (car form) 'slot-value)
-		      (eq (car form) 'set-slot-value)
-		      (eq (car form) 'slot-boundp))
-		  (constantp (caddr form)))
-	     (let ((parameter
-		    (can-optimize-access form
-					 required-parameters env)))
-	       (ecase (car form)
-		 (slot-value
-		  (optimize-slot-value     slots parameter form))
-		 (set-slot-value
-		  (optimize-set-slot-value slots parameter form))
-		 (slot-boundp
-		  (optimize-slot-boundp    slots parameter form)))))
-	    ((and (or (symbolp (car form))
-		      (and (consp (car form))
-			   (eq (caar form) 'setf)))
-		  (fboundp (car form))
-		  (if (eq *boot-state* 'complete)
-		      (standard-generic-function-p (gdefinition (car form)))
-		      (funcallable-instance-p (gdefinition (car form)))))
-	     (optimize-generic-function-call 
-	      form required-parameters env slots calls))
-	    (t form))))
-
-(defun walk-method-lambda (method-lambda required-parameters env slots calls)
-  (let* ((call-next-method-p nil)   ;flag indicating that call-next-method
-				    ;should be in the method definition
-	 (closurep nil)		    ;flag indicating that #'call-next-method
-				    ;was seen in the body of a method
-	 (next-method-p-p nil)      ;flag indicating that next-method-p
-				    ;should be in the method definition
-	 (walk-functions `((call-next-method-p
-			    ,#'(lambda (form closure-p env)
-				 (setq call-next-method-p 't)
-				 (when closure-p
-				   (setq closurep t))
-				 form))
-			   (next-method-p
-			    ,#'(lambda (form closure-p env)
-				 (setq next-method-p-p 't)
-				 (when closure-p
-				   (setq closurep t))
-				 form))
-			   ((slot-value set-slot-value slot-boundp)
-			    ,#'(lambda (form closure-p env)
-				 (if (and (not closure-p)
-					  (constantp (caddr form)))
-				     
-    (let ((walked-lambda (walk-form method-lambda env 
-				    (make-walk-function 
-				     `((call-next-method-p
-					,#'(lambda (form closure-p env)
-					     (setq call-next-method-p 't)
-					     (when closure-p
-					       (setq closurep t))
-					     form))
-				       (next-method-p
-					,#'(lambda (form closure-p env)
-					     (setq next-method-p-p 't)
-					     (when closure-p
-					       (setq closurep t))
-					     form))
-				       ((slot-value set-slot-value slot-boundp)
-					,#'(lambda (form closure-p env)
-					     (
-      (values walked-lambda
-	      call-next-method-p closurep next-method-p-p)))))
-
-(defun initialize-method-function (initargs &optional return-function-p method)
-  (let* ((mf (getf initargs ':function))
-	 (method-spec (getf initargs ':method-spec))
-	 (plist (getf initargs ':plist))
-	 (pv-table-symbol (getf plist ':pv-table-symbol))
-	 (pv-table nil)
-	 (mff (getf initargs ':fast-function)))
-    (flet ((set-mf-property (p v)
-	     (when mf
-	       (setf (method-function-get mf p) v))
-	     (when mff
-	       (setf (method-function-get mff p) v))))
-      (when method-spec
-	(when mf
-	  (setq mf (set-function-name mf method-spec)))
-	(when mff
-	  (let ((name `(,(or (get (car method-spec) 'fast-sym)
-			     (setf (get (car method-spec) 'fast-sym)
-				   (intern (format nil "FAST-~A"
-						   (car method-spec))
-					   *the-pcl-package*)))
-			 ,@(cdr method-spec))))
-	    (set-function-name mff name)
-	    (unless mf
-	      (set-mf-property :name name)))))
-      (when plist
-	(let ((snl (getf plist :slot-name-lists))
-	      (cl (getf plist :call-list)))
-	  (when (or snl cl)
-	    (setq pv-table (intern-pv-table :slot-name-lists snl
-					    :call-list cl))
-	    (when pv-table (set pv-table-symbol pv-table))
-	    (set-mf-property :pv-table pv-table)))    
-	(loop (when (null plist) (return nil))
-	      (set-mf-property (pop plist) (pop plist)))      
-	(when method
-	  (set-mf-property :method method))    
-	(when return-function-p
-	  (or mf (method-function-from-fast-function mff)))))))
-
-
-
diff --git a/pcl/lap.lisp b/pcl/lap.lisp
deleted file mode 100644
index eaaeeba084ee15828c062764ff1094892d2caf15..0000000000000000000000000000000000000000
--- a/pcl/lap.lisp
+++ /dev/null
@@ -1,502 +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.
-;;; *************************************************************************
-;;;
-
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/lap.lisp,v 1.9 2001/03/13 15:49:48 pw Exp $")
-;;;
-
-(in-package 'pcl)
-
-;;;
-;;; This file defines PCL's interface to the LAP mechanism.
-;;;
-;;; The file is divided into two parts.  The first part defines the interface
-;;; used by PCL to create abstract LAP code vectors.  PCL never creates lists
-;;; that represent LAP code directly, it always calls this mechanism to do so.
-;;; This provides a layer of error checking on the LAP code before it gets to
-;;; the implementation-specific assembler.  Note that this error checking is
-;;; syntactic only, but even so is useful to have.  Because of it, no specific
-;;; LAP assembler should worry itself with checking the syntax of the LAP code.
-;;;
-;;; The second part of the file defines the LAP assemblers for each PCL port.
-;;; These are included together in the same file to make it easier to change
-;;; them all should some random change be made in the LAP mechanism.
-;;;
-
-(defvar *make-lap-closure-generator*)
-(defvar *precompile-lap-closure-generator*)
-(defvar *lap-in-lisp*)
-
-(defun make-lap-closure-generator 
-    (closure-variables arguments iregs vregs fvregs tregs lap-code)
-  (funcall *make-lap-closure-generator*
-	   closure-variables arguments iregs 
-	   vregs fvregs tregs lap-code))
-
-(defmacro precompile-lap-closure-generator 
-    (cvars args i-regs v-regs fv-regs t-regs lap)
-  (funcall *precompile-lap-closure-generator* cvars args i-regs 
-	   v-regs fv-regs t-regs lap))
-
-(defmacro lap-in-lisp (cvars args iregs vregs fvregs tregs lap)
-  (declare (ignore cvars args))
-  `(locally (declare #.*optimize-speed*)
-     ,(make-lap-prog iregs vregs fvregs tregs
-		     (flatten-lap lap (opcode :label 'exit-lap-in-lisp)))))
-
-
-;;;
-;;; The following functions and macros are used by PCL when generating LAP
-;;; code:
-;;;
-;;;  GENERATING-LAP
-;;;  WITH-LAP-REGISTERS
-;;;  ALLOCATE-REGISTER
-;;;  DEALLOCATE-REGISTER
-;;;  LAP-FLATTEN
-;;;  OPCODE
-;;;  OPERAND
-;;; 
-(declaim '(special *generating-lap*))		;CAR   - alist of free registers
-						;CADR  - alist of allocated registers
-						;CADDR - max reg number allocated
-						;
-						;in each alist, the entries have
-						;the form:  (type . (:REG <n>))
-						;
-
-;;;
-;;; This goes around the generation of any lap code.  <body> should return a lap
-;;; code sequence, this macro will take care of converting that to a lap closure
-;;; generator.
-;;; 
-(defmacro generating-lap (closure-variables arguments &body body)
-  `(let* ((*generating-lap* (list () () -1)))
-     (finalize-lap-generation nil ,closure-variables ,arguments (progn ,@body))))
-
-(defmacro generating-lap-in-lisp (closure-variables arguments &body body)
-  `(let* ((*generating-lap* (list () () -1)))
-     (finalize-lap-generation t ,closure-variables ,arguments (progn ,@body))))
-
-;;;
-;;; Each register specification looks like:
-;;;
-;;;  (<var> <type> &key :reuse <other-reg>)
-;;;  
-(defmacro with-lap-registers (register-specifications &body body)
-  ;;
-  ;; Given that, for now, there is only one keyword argument and
-  ;; that, for now, we do no error checking, we can be pretty
-  ;; sleazy about how this works.
-  ;;
-  (flet ((make-allocations ()
-	   (gathering1 (collecting)
-	     (dolist (spec register-specifications)
-	       (gather1
-		 `(,(car spec) (or ,(cadddr spec) (allocate-register ',(cadr spec))))))))
-	 (make-deallocations ()
-	   (gathering1 (collecting)
-	     (dolist (spec register-specifications)
-	       (gather1
-		 `(unless ,(cadddr spec) (deallocate-register ,(car spec))))))))
-    `(let ,(make-allocations)
-       (multiple-value-prog1 (progn ,@body)
-			     ,@(make-deallocations)))))
-
-(defun allocate-register (type)
-  (destructuring-bind (free allocated) *generating-lap*
-    (let ((entry (assoc type free)))
-      (cond (entry
-	     (setf (car *generating-lap*)  (delete entry free)
-		   (cadr *generating-lap*) (cons entry allocated))
-	     (cdr entry))
-	    (t
-	     (let ((new `(,type . (:reg ,(incf (caddr *generating-lap*))))))
-	       (setf (cadr *generating-lap*) (cons new allocated))
-	       (cdr new)))))))
-
-(defun deallocate-register (reg)
-  (let ((entry (rassoc reg (cadr *generating-lap*))))
-    (unless entry (error "Attempt to free an unallocated register."))
-    (push entry (car *generating-lap*))
-    (setf (cadr *generating-lap*) (delete entry (cadr *generating-lap*)))))
-
-(defvar *precompiling-lap* nil)
-
-(defun finalize-lap-generation (in-lisp-p closure-variables arguments lap-code)
-  (when (cadr *generating-lap*) (error "Registers still allocated when lap being finalized."))
-  (let ((iregs ())
-	(vregs ())
-	(fvregs ())
-	(tregs ()))
-    (dolist (entry (car *generating-lap*))
-      (ecase (car entry)
-	(index  (push (caddr entry) iregs))
-	(vector (push (caddr entry) vregs))
-	(fixnum-vector (push (caddr entry) fvregs))
-	((t)    (push (caddr entry) tregs))))
-    (cond (in-lisp-p
-	   `(lap-in-lisp ,closure-variables ,arguments ,iregs 
-	                 ,vregs ,fvregs ,tregs ,lap-code))
-	  (*precompiling-lap*
-	   `(precompile-lap-closure-generator 
-	     ,closure-variables ,arguments ,iregs
-	     ,vregs ,fvregs ,tregs ,lap))
-	  (t
-	   (make-lap-closure-generator
-	     closure-variables arguments iregs 
-	     vregs fvregs tregs lap-code)))))
-
-(defun flatten-lap (&rest opcodes-or-sequences)
-  (let ((result ()))
-    (dolist (opcode-or-sequence opcodes-or-sequences result)
-      (cond ((null opcode-or-sequence))
-            ((not (consp (car opcode-or-sequence)))     ;its an opcode
-             (setf result (append result (list opcode-or-sequence))))
-            (t
-             (setf result (append result opcode-or-sequence)))))))
-
-(defmacro flattening-lap ()
-  '(let ((result ()))
-    (values #'(lambda (value) (push value result))
-     #'(lambda () (apply #'flatten-lap (reverse result))))))
-
-
-
-;;;
-;;; This code deals with the syntax of the individual opcodes and operands.
-;;; 
-  
-;;;
-;;; The first two of these variables are documented to all ports.  They are
-;;; lists of the symbols which name the lap opcodes and operands.  They can
-;;; be useful to determine whether a port has implemented all the required
-;;; opcodes and operands.
-;;;
-;;; The third of these variables is for use of the emitter only.
-;;; 
-(defvar *lap-operands* ())
-(defvar *lap-opcodes*  ())
-(defvar *lap-emitters* (make-hash-table :test #'eq :size 30))
-
-(defun opcode (name &rest args)
-  (let ((emitter (gethash name *lap-emitters*)))
-    (if emitter
-	(apply emitter args)
-	(error "No opcode named ~S." name))))
-
-(defun operand (name &rest args)
-  (let ((emitter (gethash name *lap-emitters*)))
-    (if emitter
-	(apply emitter args)
-	(error "No operand named ~S." name))))
-
-(defmacro defopcode (name types)
-  (let ((fn-name (symbol-append "LAP Opcode " name *the-pcl-package*))
-	(lambda-list
-	  (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) types)))
-    `(progn
-       (eval-when (load eval) (load-defopcode ',name ',fn-name))
-       (defun ,fn-name ,lambda-list
-	 (defopcode-1 ',name ',types ,@lambda-list)))))
-
-(defmacro defoperand (name types)
-  (let ((fn-name (symbol-append "LAP Operand " name *the-pcl-package*))
-	(lambda-list
-	  (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) types)))
-    `(progn
-       (eval-when (load eval) (load-defoperand ',name ',fn-name))
-       (defun ,fn-name ,lambda-list
-	 (defoperand-1 ',name ',types ,@lambda-list)))))
-
-(defun load-defopcode (name fn-name)
-  (if* (memq name *lap-operands*)
-       (error "LAP opcodes and operands must have disjoint names.")
-       (setf (gethash name *lap-emitters*) fn-name)
-       (pushnew name *lap-opcodes*)))
-
-(defun load-defoperand (name fn-name)
-  (if* (memq name *lap-opcodes*)
-       (error "LAP opcodes and operands must have disjoint names.")
-       (setf (gethash name *lap-emitters*) fn-name)
-       (pushnew name *lap-operands*)))
-
-(defun defopcode-1 (name operand-types &rest args)
-  (iterate ((arg (list-elements args))
-	    (type (list-elements operand-types)))
-    (check-opcode-arg name arg type))
-  (cons name (copy-list args)))
-
-(defun defoperand-1 (name operand-types &rest args)
-  (iterate ((arg (list-elements args))
-	    (type (list-elements operand-types)))
-    (check-operand-arg name arg type))
-  (cons name (copy-list args)))
-
-(defun check-opcode-arg (name arg type)
-  (labels ((usual (x)
-	     (and (consp arg) (eq (car arg) x)))
-	   (check (x)
-	     (ecase x	       
-	       ((:reg :cdr :constant :iref :instance-ref :cvar :arg :lisp :lisp-variable)
-		(usual x))
-	       (:label (symbolp arg))
-	       (:operand (and (consp arg) (memq (car arg) *lap-operands*))))))
-    (unless (if (consp type)
-		(if (eq (car type) 'or)
-		    (some #'check (cdr type))
-		    (error "What type is this?"))
-		(check type))
-      (error "The argument ~S to the opcode ~A is not of type ~S." arg name type))))
-
-(defun check-operand-arg (name arg type)  
-  (flet ((check (x)
-	   (ecase x
-	     (:symbol           (symbolp arg))
-	     (:register-number  (and (integerp arg) (>= arg 0)))
-	     (:t                t)
-	     (:reg              (and (consp arg) (eq (car arg) :reg)))
-	     (:fixnum           (typep arg 'fixnum)))))
-    (unless (if (consp type)
-		(if (eq (car type) 'or)
-		    (some #'check (cdr type))
-		    (error "What type is this?"))
-		(check type))
-      (error "The argument ~S to the operand ~A is not of type ~S." arg name type))))
-
-
-
-;;;
-;;; The actual opcodes.
-;;;
-(defopcode :break ())				;For debugging only.  Not
-(defopcode :beep  ())				;all ports are required to
-(defopcode :print (:reg))			;implement this.
-
-
-(defopcode :move (:operand (or :reg :iref :instance-ref :cdr :lisp-variable)))
-
-(defopcode :eq     ((or :reg :constant) (or :reg :constant) :label))
-(defopcode :neq    ((or :reg :constant) (or :reg :constant) :label))
-(defopcode :fix=   ((or :reg :constant) (or :reg :constant) :label))
-(defopcode :izerop (:reg :label))
-
-(defopcode :std-instance-p       (:reg :label))
-(defopcode :fsc-instance-p       (:reg :label))
-(defopcode :built-in-instance-p  (:reg :label))
-(defopcode :structure-instance-p (:reg :label))
-
-(defopcode :jmp      ((or :reg :constant)))
-(defopcode :emf-call ((or :reg :constant)))
-
-(defopcode :label  (:label))
-(defopcode :go     (:label))
-
-(defopcode :return ((or :reg :constant)))
-
-(defopcode :exit-lap-in-lisp ())
-
-;;;
-;;; The actual operands.
-;;;
-(defoperand :reg  (:register-number))
-(defoperand :cvar (:symbol))
-(defoperand :arg  (:symbol))
-
-(defoperand :cdr  (:reg))
-
-(defoperand :constant (:t))
-
-(defoperand :std-wrapper       (:reg))
-(defoperand :fsc-wrapper       (:reg))
-(defoperand :built-in-wrapper  (:reg))
-(defoperand :structure-wrapper (:reg))
-(defoperand :other-wrapper     (:reg))
-(defoperand :built-in-or-structure-wrapper (:reg))
-
-(defoperand :std-slots (:reg))
-(defoperand :fsc-slots (:reg))
-
-(defoperand :wrapper-cache-number-vector (:reg))
-
-(defoperand :cref (:reg :fixnum))
-
-(defoperand :iref (:reg :reg))
-(defoperand :iset (:reg :reg :reg))
-
-(defoperand :instance-ref (:reg :reg))
-(defoperand :instance-set (:reg :reg :reg))
-
-(defoperand :i1+     (:reg))
-(defoperand :i+      (:reg :reg))
-(defoperand :i-      (:reg :reg))
-(defoperand :ilogand (:reg :reg))
-(defoperand :ilogxor (:reg :reg))
-(defoperand :ishift  (:reg :fixnum))
-
-(defoperand :lisp (:t))
-(defoperand :lisp-variable (:symbol))
-
-
-
-;;;
-;;; LAP tests (there need to be a lot more of these)
-;;;
-#|
-(defun make-lap-test-closure-1 (result)
-  #'(lambda (arg1)
-      (declare (pcl-fast-call))
-      (declare (ignore arg1))
-      result))
-
-(defun make-lap-test-closure-2 (result)
-  #'(lambda (arg1 arg2)
-      (declare (pcl-fast-call))
-      (declare (ignore arg1 arg2))
-      result))
-
-(eval-when (eval)
-  (compile 'make-lap-test-closure-1)
-  (compile 'make-lap-test-closure-2))
-
-(declaim (special lap-win lap-lose))
-(eval-when (load eval)
-  (setq lap-win (make-lap-test-closure-1 'win)
-	lap-lose (make-lap-test-closure-1 'lose)))
-
-(defun lap-test-1 ()
-  (let* ((cg (generating-lap '(cache)
-			     '(arg)
-	       (with-lap-registers ((i0 index)
-				    (v0 vector)
-				    (t0 t))
-		 (flatten-lap 
-		   (opcode :move (operand :cvar 'cache) v0)
-		   (opcode :move (operand :arg 'arg) i0)
-		   (opcode :move (operand :iref v0 i0) t0)
-		   (opcode :jmp t0)))))
-	 
-	 (cache (make-array 32))
-	 (closure (funcall cg cache))
-	 (fn0 (make-lap-test-closure-1 'fn0))
-	 (fn1 (make-lap-test-closure-1 'fn1))
-	 (fn2 (make-lap-test-closure-1 'fn2))
-	 (in0 (index-value->index 2))
-	 (in1 (index-value->index 10))
-	 (in2 (index-value->index 27)))
-    
-    (setf (svref cache (index->index-value in0)) fn0
-	  (svref cache (index->index-value in1)) fn1
-	  (svref cache (index->index-value in2)) fn2)
-    
-    (unless (and (eq (funcall closure in0) 'fn0)
-		 (eq (funcall closure in1) 'fn1)
-		 (eq (funcall closure in2) 'fn2))
-      (error "LAP TEST 1 failed."))))
-
-(defun lap-test-2 ()            
-  (let* ((cg (generating-lap '(cache mask) 
-			     '(arg)
-	       (with-lap-registers ((i0 index)
-				    (i1 index)
-				    (i2 index)
-				    (v0 vector)
-				    (t0 t))
-
-		 (flatten-lap		  
-		   (opcode :move (operand :cvar 'cache) v0)
-		   (opcode :move (operand :arg 'arg) i0)
-		   (opcode :move (operand :cvar 'mask) i1)
-		   (opcode :move (operand :ilogand i0 i1) i2)
-		   (opcode :move (operand :iref v0 i2) t0)
-		   (opcode :jmp t0)))))
-	 (cache (make-array 32))
-	 (mask #b00110)
-	 (closure (funcall cg cache mask))
-	 (in0 (index-value->index #b00010))
-	 (in1 (index-value->index #b01010))
-	 (in2 (index-value->index #b10011)))
-    (fill cache lap-lose)
-    (setf (svref cache (index->index-value in0)) lap-win)
-    
-    (unless (and (eq (funcall closure in0) 'win)
-		 (eq (funcall closure in1) 'win)
-		 (eq (funcall closure in2) 'win))
-      (error "LAP TEST 2 failed."))))
-
-(defun lap-test-3 ()            
-  (let* ((cg (generating-lap '(addend) '(arg)
-	       (with-lap-registers
-		 ((i0 index)
-		  (i1 index)
-		  (i2 index))
-
-		 (flatten-lap		  
-		   (opcode :move (operand :cvar 'addend) i0)
-		   (opcode :move (operand :arg 'arg) i1)
-		   (opcode :move (operand :i+ i0 i1) i2)
-		   (opcode :return i2)))))
-	 (closure (funcall cg (index-value->index 5))))
-    
-    (unless (= (index->index-value (funcall closure (index-value->index 2))) 7)
-      (error "LAP TEST 3 failed."))))
-
-(defun lap-test-4 ()            
-  (let* ((cg (generating-lap '(winner loser) '(arg)
-	       (with-lap-registers ((t0 t))
-		 (flatten-lap
-		   (opcode :move (operand :arg 'arg) t0)
-		   (opcode :eq t0 (operand :constant 'foo) 'win)
-		   (opcode :move (operand :cvar 'loser) t0)
-		   (opcode :jmp t0)
-		   (opcode :label 'win)
-		   (opcode :move (operand :cvar 'winner) t0)
-		   (opcode :jmp t0)))))
-	 (closure (funcall cg #'true #'false)))
-    (unless (and (eq (funcall closure 'foo) 't)
-		 (eq (funcall closure 'bar) 'nil))
-      (error "LAP TEST 4 failed."))))
-
-(defun lap-test-5 ()            
-  (let* ((cg (generating-lap '(array) '(arg)
-	       (with-lap-registers ((r0 vector)
-				    (r1 t)
-				    (r2 index))
-		 (flatten-lap
-		   (opcode :move (operand :cvar 'array) r0)
-		   (opcode :move (operand :arg 'arg) r1)
-		   (opcode :move (operand :constant (index-value->index 0)) r2)
-		   (opcode :move r1 (operand :iref r0 r2))
-		   (opcode :return r1)))))
-	 (array (make-array 1))
-	 (closure (funcall cg array)))
-    (unless (and (=  (funcall closure 1)    (svref array 0))
-		 (eq (funcall closure 'foo) (svref array 0)))
-      (error "LAP TEST 5 failed."))))
-
-|#
-
diff --git a/pcl/list-functions.lisp b/pcl/list-functions.lisp
deleted file mode 100644
index f4601a439f50c732bb7105b6b19b0d3695862e7b..0000000000000000000000000000000000000000
--- a/pcl/list-functions.lisp
+++ /dev/null
@@ -1,141 +0,0 @@
-
-(in-package :pcl)
-
-(defvar *defun-list* nil)
-(defvar *defmethod-list* nil)
-(defvar *defmacro-list* nil)
-(defvar *defgeneric-list* nil)
-
-(defun list-functions (&optional print-p)
-  (let ((eof '(eof))
-	(*package* *package*))
-    (setq *defun-list* nil
-	  *defmethod-list* nil
-	  *defmacro-list* nil)
-    (labels ((process-form (form)
-	       (when (consp form)
-		 (case (car form)
-		   ((in-package export import shadow shadowing-import) (eval form))
-		   #+lcl3.0 (lcl:handler-bind (eval form))
-		   (let (when print-p (print form)))
-		   (defun (push (list (cadr form) (caddr form))
-				*defun-list*))
-		   (defmethod (push (list (cadr form) (caddr form)) 
-				    *defmethod-list*))
-		   (defmacro (push (list (cadr form) (caddr form)) 
-				   *defmacro-list*))
-		   (defgeneric (push (list (cadr form) (caddr form)) 
-				     *defgeneric-list*))
-		   (eval-when (mapc #'process-form (cddr form)))
-		   (progn (mapc #'process-form (cdr form)))
-		   ((defvar defparameter defconstant proclaim 
-		     defsetf defstruct deftype define-compiler-macro))
-		   ((define-walker-template defopcode defoperand 
-		     define-method-combination define-constructor-code-type 
-		     defclass))
-		   (t (when print-p (print form)))))))
-      (dolist (file (system-source-files 'pcl))
-	(with-open-file (in file :direction :input)
-	  (loop (let ((form (read in nil eof)))
-		  (when (eq form eof) (return nil))
-		  (process-form form))))))
-    (values (length *defun-list*)
-	    (length *defmethod-list*)
-	    (length *defmacro-list*)
-	    (length *defgeneric-list*))))
-
-(defun list-all-gfs (&key all-p (show-methods-p t) san-p (name "generic-functions"))
-  (let ((keys nil) (opt nil)
-	(gf-vector (make-array 10 :initial-element nil))
-	(readers nil) (writers nil) (cv nil)
-	(*package* *the-pcl-package*)
-	(*print-pretty* nil)
-	(s-a-n (find-package "SLOT-ACCESSOR-NAME"))
-	(lisp-sans (mapcar #'slot-reader-symbol '(function type))))
-    ;; This one has no predefined methods.
-    (defgeneric update-dependent (metaobject dependent &rest initargs))
-    (map-all-generic-functions 
-     #'(lambda (gf)
-	 (when (or all-p
-		   (let ((name (generic-function-name gf)))
-		     (when (consp name) (setq name (cadr name)))
-		     (and (not (find #\: (symbol-name name)))
-			  (or (eq (symbol-package name) *the-pcl-package*)
-			      (and san-p
-				   (memq name lisp-sans)
-				   (and (eq (symbol-package name) s-a-n)
-					(string= "PCL " (symbol-name name)
-						 :end2 4)))))))
-	   (let ((ll (generic-function-lambda-list gf)))
-	     (multiple-value-bind (nrequired noptional 
-					     keysp restp allow-other-keys-p keywords)
-		 (analyze-lambda-list ll)
-	       (cond ((use-constant-value-dfun-p gf t)
-		      (push gf cv))
-		     ((or keysp restp allow-other-keys-p keywords)
-		      (push gf keys))
-		     ((plusp noptional)
-		      (push gf opt))
-		     ((and (= nrequired 1)
-			   (let ((m (generic-function-methods gf)))
-			     (and m
-				  (every #'standard-reader-method-p m))))
-		      (push gf readers))
-		     ((and (= nrequired 2)
-			   (let ((m (generic-function-methods gf)))
-			     (and m
-				  (every #'standard-writer-method-p m))))
-		      (push gf writers))
-		     (t
-		      (push gf (aref gf-vector nrequired)))))))))
-    (with-open-file (out (let* ((system (get-system 'pcl))
-				(*system-directory* (funcall (car system))))
-			   (make-pathname :defaults
-					  (truename (make-source-pathname "defsys"))
-					  :name name))
-			 :direction :output)
-      (format out ";;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*-~2%")
-      (format out "(in-package :pcl)~%")
-      (flet ((print-gf-list (list)
-	       (setq list
-		     (sort (mapcar #'generic-function-name list)
-			   #'(lambda (sym1 sym2)
-			       (let* ((s1 (if (consp sym1) (cadr sym1) sym1))
-				      (s2 (if (consp sym2) (cadr sym2) sym2))
-				      (p1 (symbol-package s1))
-				      (p2 (symbol-package s2)))
-				 (if (eq p1 p2)
-				     (string< (symbol-name s1) (symbol-name s2))
-				     (string< (package-name p1) (package-name p2)))))))
-	       (dolist (sym list)
-		 (let* ((*print-case* :downcase)
-			(gf (gdefinition sym))
-			(lambda-list (generic-function-lambda-list gf)))
-		   (format out "~&~S~%" `(defgeneric ,sym ,lambda-list))
-		   (when show-methods-p
-		     (dolist (m (generic-function-methods gf))
-		       (let* ((q (method-qualifiers m))
-			      (qs (if (null q) 
-				      ""
-				      (format nil "~{~S~^ ~}" q)))
-			      (s (unparse-specializers m)))
-			 (format out "~&;  ~7A ~S~%" qs s)))
-		     (terpri out))))))
-	(when cv
-	  (format out "~%;;; class predicates~%")
-	  (print-gf-list cv))
-	(when readers
-	  (format out "~%;;; readers~%")
-	  (print-gf-list readers))
-	(when writers
-	  (format out "~%;;; writers~%")
-	  (print-gf-list writers))
-	(dotimes (i 10)
-	  (when (aref gf-vector i)
-	    (format out "~%;;; ~D argument~:P ~%" i)
-	    (print-gf-list (aref gf-vector i))))
-	(format out "~%;;; optional arguments  ~%")
-	(print-gf-list opt)
-	(format out "~%;;; keyword arguments  ~%")
-	(print-gf-list keys))
-      (terpri out))))
diff --git a/pcl/make-test.lisp b/pcl/make-test.lisp
deleted file mode 100644
index a80a006e1de668fafb3e928f689221cf319b9282..0000000000000000000000000000000000000000
--- a/pcl/make-test.lisp
+++ /dev/null
@@ -1,47 +0,0 @@
-(in-package :pcl)
-
-(defun top-level-form-form (form)
-  #+cmu
-  (if (and (consp form) (eq (car form) 'eval-when))
-      (third form)
-      form)
-  #+kcl
-  (fourth (third form))
-  #+lcl3.0
-  (third (third form)))
-
-(defun make-test ()
-  (let ((table (make-hash-table :test 'eq))
-	(count 0))
-    (labels ((fixup (form)
-	       (if (consp form)
-		   (cons (fixup (car form)) (fixup (cdr form)))
-		   (if (and (symbolp form) (null (symbol-package form)))
-		       (or (gethash form table)
-			   (setf (gethash form table)
-				 (intern (format nil "~A-%-~D" (symbol-name form)
-						 (incf count))
-					 *the-pcl-package*)))
-		       form))))
-      (with-open-file (out "test.lisp"
-			   :direction :output :if-exists :supersede)
-	(declare (type stream out))
-	(let ((*print-case* :downcase)
-	      (*print-pretty* t)
-	      (*package* *the-pcl-package*))
-	  (format out "~S~%" '(in-package :pcl))
-	  (let ((i 0)
-		(f (macroexpand '(PRECOMPILE-FUNCTION-GENERATORS PCL))))
-	    (dolist (form (cdr (top-level-form-form f)))
-	      (let ((name (intern (format nil "FGEN-~D" (incf i)))))
-		(format out "~S~%" `(defun ,name () ,(fixup form))))))
-	  (let ((i 0)
-		(f (macroexpand '(PRECOMPILE-DFUN-CONSTRUCTORS PCL))))
-	    (dolist (form (cdr f))
-	      (let ((name (intern (format nil "DFUN-CONSTR-~D" (incf i))))
-		    (form (top-level-form-form form)))
-		(format out "~S~%" `(defun ,name () 
-				      (list ,(second form)
-				            ,(third form)
-				            ,(fixup (macroexpand (fifth form))))))))))))))
-
diff --git a/pcl/plap.lisp b/pcl/plap.lisp
deleted file mode 100644
index 3b670ea38d48e56c2646c09b94d4f6d2e7404c61..0000000000000000000000000000000000000000
--- a/pcl/plap.lisp
+++ /dev/null
@@ -1,353 +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.
-;;; *************************************************************************
-;;;
-
-(ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/plap.lisp,v 1.10 2001/03/13 15:49:49 pw Exp $")
-;;;
-
-(in-package 'pcl)
-
-;;;
-;;; The portable implementation of the LAP assembler.
-;;;
-;;; The portable implementation of the LAP assembler works by translating
-;;; LAP code back into Lisp code and then compiling that Lisp code.  Note
-;;; that this implementation is actually going to get a lot of use.  Some
-;;; implementations (KCL) won't implement a native LAP assembler at all.
-;;; Other implementations may not implement native LAP assemblers for all
-;;; of their ports.  All of this implies that this portable LAP assembler
-;;; needs to generate the best code it possibly can.
-;;; 
-
-
-;;;
-;;; 
-;;;
-
-(defmacro lap-case (operand &body cases)
-  (once-only (operand)
-    `(ecase (car ,operand)
-       ,@(mapcar #'(lambda (case)
-		     `(,(car case)
-		       (apply #'(lambda ,(cadr case) ,@(cddr case))
-			      (cdr ,operand))))
-		 cases))))
-
-(defvar *lap-args*)
-(defvar *lap-rest-p*)
-(defvar *lap-i-regs*)
-(defvar *lap-v-regs*)
-(defvar *lap-fv-regs*)
-(defvar *lap-t-regs*)
-
-(defvar *lap-optimize-declaration* '#.*optimize-speed*)
-
-
-(eval-when (load eval)
-  (setq *make-lap-closure-generator*
-	#'(lambda (closure-var-names arg-names index-regs 
-		   vector-regs fixnum-vector-regs t-regs lap-code)
-	    (compile-lambda
-	      (make-lap-closure-generator-lambda
-		closure-var-names arg-names index-regs 
-		vector-regs fixnum-vector-regs t-regs lap-code)))
-
-	*precompile-lap-closure-generator*
-	#'(lambda (cvars args i-regs v-regs fv-regs t-regs lap)
-	    `(function
-	       ,(make-lap-closure-generator-lambda cvars args i-regs 
-		 v-regs fv-regs t-regs lap)))
-	*lap-in-lisp*
-	#'(lambda (cvars args iregs vregs fvregs tregs lap)
-	    (declare (ignore cvars args))
-	    (make-lap-prog
-	      iregs vregs fvregs tregs 
-	      (flatten-lap lap ;(opcode :label 'exit-lap-in-lisp)
-			   )))))
-
-(defun make-lap-closure-generator-lambda (cvars args i-regs v-regs fv-regs t-regs lap)
-  (let* ((rest (memq '&rest args))
-	 (ldiff (and rest (ldiff args rest))))
-    (when rest (setq args (append ldiff '(&rest .lap-rest-arg.))))
-    (let* ((*lap-args* (if rest ldiff args))
-	   (*lap-rest-p* (not (null rest))))
-      `(lambda ,cvars
-	 #'(lambda ,args
-             ;;
-             ;; Use LOCALLY instead of a declare on the lambda so that we don't
-             ;; suppress arg count checking...
-             (locally (declare ,*lap-optimize-declaration*)
-	       ,(make-lap-prog-internal i-regs v-regs fv-regs t-regs lap)))))))
-
-(defun make-lap-prog (i-regs v-regs fv-regs t-regs lap)
-  (let* ((*lap-args* 'lap-in-lisp)
-	 (*lap-rest-p* 'lap-in-lisp))
-    (make-lap-prog-internal i-regs v-regs fv-regs t-regs lap)))
-
-(defun make-lap-prog-internal (i-regs v-regs fv-regs t-regs lap)
-  (let* ((*lap-i-regs* i-regs)
-	 (*lap-v-regs* v-regs)
-	 (*lap-fv-regs* fv-regs)
-	 (*lap-t-regs* t-regs)
-	 (code (mapcar #'lap-opcode lap)))
-    `(prog ,(mapcar #'(lambda (reg)
-			`(,(lap-reg reg)
-			  ,(lap-reg-initial-value-form reg)))
-		    (append i-regs v-regs fv-regs t-regs))
-	   (declare (type fixnum ,@(mapcar #'lap-reg *lap-i-regs*))
-		    (type simple-vector ,@(mapcar #'lap-reg *lap-v-regs*))
-		    (type  cache-number-vector
-		          ,@(mapcar #'lap-reg *lap-fv-regs*)))
-	   ,.code)))
-
-(defvar *empty-vector* '#())
-(defvar *empty-fixnum-vector*
-  (make-array 8
-	      :element-type 'fixnum
-	      :initial-element 0))
- 
-(defun lap-reg-initial-value-form (reg)
-  (cond ((member reg *lap-i-regs*) 0)
-        ((member reg *lap-v-regs*) '*empty-vector*)
-        ((member reg *lap-fv-regs*) '*empty-fixnum-vector*)
-        ((member reg *lap-t-regs*) nil)
-        (t
-         (error "What kind of register is ~S?" reg))))
-
-(defun lap-opcode (opcode)    
-  (lap-case opcode
-    (:move (from to)
-     `(setf ,(lap-operand to) ,(lap-operand from)))
-      
-    ((:eq :neq :fix=) (arg1 arg2 label)
-     `(when ,(lap-operands (ecase (car opcode)
-			     (:eq 'eq) (:neq 'neq) (:fix= 'RUNTIME\ FIX=))
-			   arg1
-			   arg2)
-	(go ,label)))
-
-    ((:izerop) (arg label)
-     `(when ,(lap-operands 'RUNTIME\ IZEROP arg)
-	(go ,label)))
-
-    (:std-instance-p (from label)
-     `(when ,(lap-operands 'RUNTIME\ STD-INSTANCE-P from) (go ,label)))
-    (:fsc-instance-p (from label)
-     `(when ,(lap-operands 'RUNTIME\ FSC-INSTANCE-P from) (go ,label)))
-    (:built-in-instance-p (from label)
-     (declare (ignore from))
-     `(when ,t (go ,label)))			                ;***
-    (:structure-instance-p (from label)
-     `(when ,(lap-operands 'RUNTIME\ STRUCTURE-INSTANCE-P from) (go ,label)))	;***
-    
-    ((:jmp :emf-call) (fn)
-     (if (eq *lap-args* 'lap-in-lisp)
-	 (error "Can't do a :JMP in LAP-IN-LISP.")
-	 `(return
-	    ,(if (eq (car opcode) :jmp)
-		 (if *lap-rest-p*
-		     `(RUNTIME\ APPLY ,(lap-operand fn) ,@*lap-args* .lap-rest-arg.)
-		     `(RUNTIME\ FUNCALL ,(lap-operand fn) ,@*lap-args*))
-		 `(RUNTIME\ EMF-CALL ,(lap-operand fn) ,*lap-rest-p* ,@*lap-args*
-		                     ,@(when *lap-rest-p* `(.lap-rest-arg.)))))))
-
-    (:return (value)
-     `(return ,(lap-operand value)))
-      
-    (:label (label) label)
-    (:go   (label)  `(go ,label))
-
-    (:exit-lap-in-lisp () `(go exit-lap-in-lisp))
-    
-    (:break ()      `(break))
-    (:beep  ()      )
-    (:print (val)   (lap-operands 'print val))
-    ))
-
-(defun lap-operand (operand)
-  (lap-case operand
-    (:reg (n) (lap-reg n))
-    (:cdr (reg) (lap-operands 'cdr reg))
-    ((:cvar :arg) (name) name)
-    (:constant (c) `',c)
-    ((:std-wrapper :fsc-wrapper :built-in-wrapper :structure-wrapper
-      :built-in-or-structure-wrapper :std-slots :fsc-slots
-      :wrapper-cache-number-vector)
-     (x)
-     (lap-operands (ecase (car operand)
-		     (:std-wrapper       'RUNTIME\ STD-WRAPPER)
-		     (:fsc-wrapper       'RUNTIME\ FSC-WRAPPER)
-		     (:built-in-wrapper  'RUNTIME\ BUILT-IN-WRAPPER)
-		     (:structure-wrapper 'RUNTIME\ STRUCTURE-WRAPPER)
-		     (:built-in-or-structure-wrapper
-		                         'RUNTIME\ BUILT-IN-OR-STRUCTURE-WRAPPER)
-		     (:std-slots         'RUNTIME\ STD-SLOTS)
-		     (:fsc-slots         'RUNTIME\ FSC-SLOTS)
-		     (:wrapper-cache-number-vector 
-		      'RUNTIME\ WRAPPER-CACHE-NUMBER-VECTOR))
-		   x))
-    
-     
-    (:i1+     (index)         (lap-operands 'RUNTIME\ I1+ index))
-    (:i+      (index1 index2) (lap-operands 'RUNTIME\ I+ index1 index2))
-    (:i-      (index1 index2) (lap-operands 'RUNTIME\ I- index1 index2))
-    (:ilogand (index1 index2) (lap-operands 'RUNTIME\ ILOGAND index1 index2))
-    (:ilogxor (index1 index2) (lap-operands 'RUNTIME\ ILOGXOR index1 index2))
-    
-    (:iref    (vector index)       (lap-operands 'RUNTIME\ IREF vector index))
-    (:iset    (vector index value) (lap-operands 'RUNTIME\ ISET vector index value))
-
-    (:instance-ref (vector index)
-		   (lap-operands 'RUNTIME\ INSTANCE-REF vector index))
-    (:instance-set (vector index value)
-		   (lap-operands 'RUNTIME\ INSTANCE-SET vector index value))
-
-    (:cref   (vector i)       `(RUNTIME\ SVREF ,(lap-operand vector) ,i))
-    (:lisp-variable (symbol) symbol)
-    (:lisp          (form)   form)
-    ))
-
-(defun lap-operands (fn &rest regs)
-  (cons fn (mapcar #'lap-operand regs)))
-
-(defun lap-reg (n) (intern (format nil "REG~D" n) *the-pcl-package*))
-
-
-;;;
-;;; Runtime Implementations of the operands and opcodes.
-;;;
-;;; In those ports of PCL which choose not to completely re-implement the
-;;; LAP code generator, it may still be provident to consider reimplementing
-;;; one or more of these to get the compiler to produce better code.  That
-;;; is why they are split out.
-;;; 
-(declaim (declaration pcl-fast-call))
-
-(defmacro RUNTIME\ FUNCALL (fn &rest args)
-  `(funcall (the function ,fn) ,.args))
-
-(defmacro RUNTIME\ APPLY (fn &rest args)
-  `(apply (the function ,fn) ,.args))
-
-(defmacro RUNTIME\ EMF-CALL (emf restp &rest required-args+rest-arg)
-  `(invoke-effective-method-function ,emf ,restp ,@required-args+rest-arg))
-
-(defmacro RUNTIME\ STD-WRAPPER (x)
-  `(std-instance-wrapper ,x))
-
-(defmacro RUNTIME\ FSC-WRAPPER (x)
-  `(fsc-instance-wrapper ,x))
-
-(defmacro RUNTIME\ BUILT-IN-WRAPPER (x)
-  `(built-in-wrapper-of ,x))
-
-(defmacro RUNTIME\ STRUCTURE-WRAPPER (x)
-  `(built-in-or-structure-wrapper ,x))
-
-(defmacro RUNTIME\ BUILT-IN-OR-STRUCTURE-WRAPPER (x)
-  `(built-in-or-structure-wrapper ,x))
-
-(defmacro RUNTIME\ STRUCTURE-INSTANCE-P (x)
-  `(structure-instance-p ,x))
-
-(defmacro RUNTIME\ STD-SLOTS (x)
-  `(std-instance-slots (the std-instance ,x)))
-
-(defmacro RUNTIME\ FSC-SLOTS (x)
-  `(fsc-instance-slots ,x))
-
-(defmacro RUNTIME\ WRAPPER-CACHE-NUMBER-VECTOR (x)
-  `(wrapper-cache-number-vector ,x))
-
-(defmacro RUNTIME\ STD-INSTANCE-P (x)
-  `(std-instance-p ,x))
-
-(defmacro RUNTIME\ FSC-INSTANCE-P (x)
-  `(fsc-instance-p ,x))
-
-(defmacro RUNTIME\ IZEROP (x)
-  `(zerop (the fixnum ,x)))
-
-(defmacro RUNTIME\ FIX= (x y)
-  `(= (the fixnum ,x) (the fixnum ,y)))
-
-;;;
-;;; These are the implementations of the index operands.  The portable
-;;; assembler generates Lisp code that uses these macros.  Even though
-;;; the variables holding the arguments and results have type declarations
-;;; on them, we put type declarations in here.
-;;;
-;;; Some compilers are so stupid...
-;;;
-(defmacro RUNTIME\ IREF (vector index)
-  `(aref ,vector (the fixnum ,index)))
-
-(defmacro RUNTIME\ ISET (vector index value)
-  `(setf (svref (the simple-vector ,vector) (the fixnum ,index)) ,value))
-
-(defmacro RUNTIME\ INSTANCE-REF (vector index)
-  `(svref (the simple-vector ,vector) (the fixnum ,index)))
-
-(defmacro RUNTIME\ INSTANCE-SET (vector index value)
-  `(setf (svref (the simple-vector ,vector) (the fixnum ,index)) ,value))
-
-(defmacro RUNTIME\ SVREF (vector fixnum)
-  `(aref ,vector (the fixnum ,fixnum)))
-
-(defmacro RUNTIME\ I+ (index1 index2)
-  `(the fixnum (+ (the fixnum ,index1) (the fixnum ,index2))))
-
-(defmacro RUNTIME\ I- (index1 index2)  
-  `(the fixnum (- (the fixnum ,index1) (the fixnum ,index2))))
-
-(defmacro RUNTIME\ I1+ (index)
-  `(the fixnum (1+ (the fixnum ,index))))
-
-(defmacro RUNTIME\ ILOGAND (index1 index2)
-  `(the fixnum (logand (the fixnum ,index1) (the fixnum ,index2))))
-
-(defmacro RUNTIME\ ILOGXOR (index1 index2)
-  `(the fixnum (logxor (the fixnum ,index1) (the fixnum ,index2))))
-
-;;;
-;;; In the portable implementation, indexes are just fixnums.
-;;; 
-
-(defconstant index-value-limit most-positive-fixnum)
-
-(defun index-value->index (index-value) index-value)
-(defun index->index-value (index) index)
-
-(defun make-index-mask (cache-size line-size)
-  (let ((cache-size-in-bits (floor (log cache-size 2)))
-	(line-size-in-bits (floor (log line-size 2)))
-	(mask 0))
-    (dotimes (i cache-size-in-bits) (setq mask (dpb 1 (byte 1 i) mask)))
-    (dotimes (i line-size-in-bits)  (setq mask (dpb 0 (byte 1 i) mask)))
-    mask))
-
-
diff --git a/pcl/quadlap.lisp b/pcl/quadlap.lisp
deleted file mode 100644
index ad90099e53fda91099a6e68bb6c246cb19b7d716..0000000000000000000000000000000000000000
--- a/pcl/quadlap.lisp
+++ /dev/null
@@ -1,619 +0,0 @@
-;;				-[Thu Mar  1 10:54:27 1990 by jkf]-
-;; pcl to quad translation
-;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/quadlap.lisp,v 1.6 1997/02/06 21:24:19 pw Exp $
-;;
-;; copyright (c) 1990 Franz Inc.
-;;
-(in-package :compiler)
-
-
-
-
-(defvar *arg-to-treg* nil)
-(defvar *cvar-to-index* nil)
-(defvar *reg-array* nil)
-(defvar *closure-treg* nil)
-(defvar *nargs-treg* nil)
-
-(defvar *debug-sparc* nil)
-
-(defmacro pcl-make-lambda (&key required)
-  `(list 'lambda nil :unknown-type 0 compiler::.function-level. 
-	,required nil nil nil nil nil nil nil nil nil 
-	nil 'compiler::none nil nil nil 
-	nil nil nil nil nil nil 0 nil))
-
-(defmacro pcl-make-varrec (&key name loc contour-level)
-  `(list ,name nil 0 nil ,loc nil t compiler::.function-level. nil nil :unknown-type nil nil ,contour-level))
-
-(defmacro pcl-make-lap (&key lap constants cframe-size locals)
-  `(list nil ,constants ,lap nil nil ,cframe-size ,locals nil nil nil))
-
-
-(defstruct preg 
-  ;; pseudo reg descritpor
-  treg		; associated treg
-  index 	; :index if this is an index type reg
-  		; :vector if this is a vector type reg
-  )
-
-
-(defun pcl::excl-lap-closure-generator (closure-vars-names
-				   arg-names
-				   index-regs
-				   vector-regs
-				   fixnum-vector-regs
-				   t-regs
-				   lap-code)
-  (let ((function (pcl::excl-lap-closure-gen closure-vars-names
-				   arg-names
-				   index-regs
-				   (append vector-regs fixnum-vector-regs)
-				   t-regs
-				   lap-code)))
-    #'(lambda (&rest closure-vals)
-	(insert-closure-vals function closure-vals))))
-
-
-(defun pcl::excl-lap-closure-gen
-    (closure-vars-names arg-names index-regs vector-regs t-regs lap-code)
-  (let ((*quads* nil)
-	(*treg-num* 0)
-	(*all-tregs* nil)
-	(*bb-count* 0)
-	*treg-bv-size*
-	*treg-vector*
-	(*next-catch-frame* 0)
-	(*max-catch-frame* -1)
-	*catch-labels*
-	*top-label*
-	*mv-treg*
-	*mv-treg-target*
-	*zero-treg*
-	*nil-treg*
-	*bbs* *bb* lap
-	;; bbs
-	*cross-block-regs*
-	*const-tregs* *move-tregs*
-	*actuals*
-	*ignore-argcount*
-	*binds-specs*
-	*bvl-current-bv* ; for bitvector cacher
-	*bvl-used-bvs*
-	*bvl-index*
-	(*inhibit-call-count* t)
-	
-	; this fcn
-	*arg-to-treg*
-	*cvar-to-index* 
-	*reg-array*
-	minargs
-	maxargs
-	*closure-treg*
-
-	node
-	otherargregs
-	
-	*nargs-treg*
-	)
-
-    (if* *debug-sparc* 
-       then (format t ">>** << Generating sparc lap code~%"))
-    
-    (setq *nil-treg* 
-      #+allegro-v4.0 (new-reg :global t)
-      #-allegro-v4.0 (new-reg)
-      *mv-treg* (new-reg)
-      *mv-treg-target* (list *mv-treg*)
-      *zero-treg* (comp::new-reg))
-    
-    ; examine given args
-    
-    (setq minargs 0  maxargs 0)
-    (let (requireds)
-      (dolist (arg arg-names)
-	(if* (eq '&rest arg)
-	   then (setq maxargs nil)
-	   else (if* (null arg)
-		   then ; we want a name even though we won't use it
-			(setq arg (gensym)))
-		(incf minargs)
-		(incf maxargs)
-		(push (cons arg (new-reg)) *arg-to-treg*)
-		(push (pcl-make-varrec :name arg 
-				   :loc (cdr (car *arg-to-treg*))
-				   :contour-level 0)
-		      requireds)
-		))
-      (setq node (pcl-make-lambda :required  (nreverse requireds))))
-    (setq *arg-to-treg* (nreverse *arg-to-treg*))
-    
-    ; build closure vector list
-    (let ((index -1))
-      (dolist (cvar closure-vars-names)
-	(push (cons cvar (incf index)) *cvar-to-index*)))
-    
-    (let ((maxreg (max (apply #'max (cons -1 index-regs))
-		       (apply #'max (cons -1 vector-regs))
-		       (apply #'max (cons -1 t-regs)))))
-      (setq *reg-array* (make-array (1+ maxreg))))
-    
-    (dolist (index index-regs)
-      (setf (svref *reg-array* index)
-	(make-preg :treg (new-reg)
-		   :index :index)))
-    
-    (dolist (vector vector-regs)
-      (setf (svref *reg-array* vector) 
-	(make-preg :treg (new-reg)
-		   :index :vector)))
-    
-    (dolist (tr t-regs)
-      (setf (svref *reg-array* tr) (make-preg :treg (new-reg))))
-    
-
-    (if* closure-vars-names
-       then (setq *closure-treg* (new-reg)))
-    (setq *nargs-treg* (new-reg))
-        
-    ;; (md-allocate-global-tregs)
-    
-    ; function entry
-    (qe nop :arg :first-block)
-    (qe entry)
-    (qe argcount :arg (list minargs maxargs))
-    (qe lambda :d (mapcar #'cdr *arg-to-treg*))
-    (qe register :arg :nargs :d (list *nargs-treg*))
-
-    (if* *closure-treg*
-       then ; put the first closure vector in *closure-treg*
-	    (qe extract-closure-vec :d (list *closure-treg*))
-	    (let ((offsetreg (new-reg)))
-	      (qe const :arg (mdparam 'md-cons-car-adj) :d (list offsetreg))
-	      (qe ref :u (list *closure-treg* offsetreg) 
-		  :d (list *closure-treg*)
-		  :arg :long))
-	    )
-
-    (excl-gen-quads lap-code)
-
-    (if* *debug-sparc*
-       then (do-quad-list (quad next *quads*)
-	      (format t "~a~%" quad))
-
-	    (format t "basic blocks~%"))
-    
-    (setq *bbs* (qc-compute-basic-blocks *quads*))
-    
-    (excl::target-class-case
-     ((:r :m) (setq *actuals* (qc-compute-actuals *bbs*))))
-    
-    (qc-live-variable-analysis *bbs*)
-    
-    (setq *treg-bv-size* (* 16 (truncate (+ *treg-num* 15) 16)))
-      
-    (qc-build-treg-vector)
-    
-
-    (let ((*dump-bbs* nil)
-	  (r::*local-regs*
-	   ; use the in registers that aren't in use
-	   (append r::*local-regs*
-		   (if* maxargs
-		      then (nthcdr maxargs r::*in-regs* )))))
-      (unwind-protect
-	  (progn
-	    ; machine specific code generation
-	    (multiple-value-bind (lap-code literals size-struct locals)
-		#+(target-class r m e)
-		(progn
-		  #+allegro-v4.0 
-		  (md-codegen node *bbs*
-			      nil otherargregs)
-		  #-allegro-v4.0 
-		  (md-codegen node *bbs*
-			      *nil-treg* *mv-treg* *zero-treg*
-			      nil otherargregs))
-		  
-		#-(target-class r m e) (md-codegen node *bbs*)
-		(setq lap
-		  (pcl-make-lap :lap lap-code
-			    :constants literals
-			    :cframe-size size-struct
-			    :locals  locals)))
-
-	     
-	    lap)
-	(giveback-bvs)))
-    
-    #+ignore 
-    (progn (format t "sparc code pre optimization~%")
-	   (dolist (instr (lap-lap lap))
-	     (format t "> ~a~%" instr)))
-    (md-optimize lap) ; peephole optimize
-    (if* *debug-sparc*
-       then (format t "sparc code post optimization~%")
-	    (dolist (instr (lap-lap lap))
-	      (format t "> ~a~%" instr)))
-    (md-assemble lap)
-    (setq last-lap lap)
- 
-    (nl-runtime-make-a-fcnobj lap)))
-
-(defun qe-slot-access (operand offset dest)
-  ;; access a slot in a structure
-  (let ((temp (new-reg)))
-    (qe const :arg offset :d (list temp))
-    (qe ref :u (list (get-treg-of operand) temp) 
-	:d (list (get-treg-of dest))
-	:arg :long)))
-
-
-(defun get-treg-of (operand &optional res-operand)
-  ;; get the appropriate treg for the operand
-  (let ((prefer-treg (and res-operand (simple-get-treg-of res-operand))))
-    (if* (numberp operand)
-       then (let ((treg (new-reg)))
-	      (qe const :arg operand :d (list treg))
-	      treg)
-     elseif (consp operand)
-       then (ecase (car operand)
-	      (:reg 
-	       (preg-treg (svref *reg-array* (cadr operand))))
-	      (:arg 
-	       (let ((x (cdr (assoc (cadr operand) *arg-to-treg* :test #'eq))))
-		 (if* (null x)
-		    then (error "where is arg ~s" operand)
-		    else x)))
-	      (:cvar
-	       (let ((res-treg (or prefer-treg (new-reg)))
-		     (temp-treg (new-reg)))
-		 (qe const :arg (+ (mdparam 'md-svector-data0-adj)
-				   (* 4 (cdr (assoc (cadr operand)
-						    *cvar-to-index*
-						    :test #'eq))))
-		     :d (list temp-treg))
-		 (qe ref :u (list *closure-treg* temp-treg)
-		     :d (list res-treg)
-		     :arg :long)
-		 res-treg))
-	      (:constant
-	       (let ((treg (or prefer-treg (new-reg))))
-		 (qe const :arg (if* (fixnump (cadr operand))
-				   then (* 8 (cadr operand)) ; md!!
-				   else (cadr operand))
-		     :d (list treg))
-		 treg))
-	      (:index-constant
-	       ; operand invented by jkf to denote an index type constant
-	       (let ((treg (or prefer-treg (new-reg))))
-		 (qe const :arg (if* (fixnump (cadr operand))
-				   then (* 4 (cadr operand)) ; md!!
-				   else (cadr operand))
-		     :d (list treg))
-		 treg)))
-       else (error "bad operand: ~s" operand))))
-
-(defun simple-get-treg-of (operand)
-  ;; get the treg if it is so simple that we don't have to 
-  ;; emit any instructions to access it.
-  ;; return nil if we can't do it.
-  (if* (numberp operand)
-     then nil
-   elseif (consp operand)
-     then (case (car operand)
-	    (:reg 
-	     (preg-treg (svref *reg-array* (cadr operand))))
-	    (:arg 
-	     (let ((x (cdr (assoc (cadr operand) *arg-to-treg* :test #'eq))))
-	       (if* (null x)
-		  then nil
-		  else x))))
-	      
-     else nil))
-
-(defun index-p (operand)
-  ;; determine if the result of this operand is an index value
-  ;* it would be better if conversion between lisp values and
-  ;  index values were made explicit in the lap code
-  (and (consp operand)
-       (or (and (eq :reg (car operand))
-		(eq :index (preg-index (svref *reg-array* (cadr operand)))))
-	   (member (car operand)
-		   '(:i+ :i- :ilogand :ilogxor :i1+)
-		   :test #'eq))
-       t))
-
-(defun gen-index-treg (operand)
-  ;; return the non-index type operand in a index treg
-  (if* (and (consp operand)
-	    (eq ':constant (car operand)))
-     then (get-treg-of `(:index-constant ,(cadr operand)))
-     else (let ((treg (get-treg-of operand))
-		(new-reg (new-reg))
-		(shift-reg (new-reg)))
-	    (qe const :arg 1 :d (list shift-reg))
-	    (qe lsr :u (list treg shift-reg) :d (list new-reg))
-	    new-reg)))
-
-		
-	    
-  
-  
-(defun vector-preg-p (operand)
-  (and (consp operand)
-       (eq :reg (car operand))
-       (eq :vector (preg-index (svref *reg-array* (cadr operand))))))
-       
-	    
-	  
-(defun excl-gen-quads (laps)
-  ;; generate quads from the lap
-  (dolist (lap laps)
-    (if* *debug-sparc* then (format t ">> ~a~%" lap))
-    (block again
-      (let ((opcode (car lap))
-	    (op1    (cadr lap))
-	    (op2    (caddr lap)))
-	(case opcode
-	  (:move
-	   ; can be either simple (both args registers)
-	   ; or one arg can be complex and the other simple
-	   (case (car op2)
-	     ((:iref :instance-ref)
-	      ;; assume that this is a lisp store
-	      ;;(warn "assuming lisp store in ~s" lap)
-	      (let (op1-treg)
-		(if* (not (vector-preg-p (cadr op2)))
-		   then ; must offset before store
-			(error "must use vector register in ~s" lap)
-		   else (setq op1-treg (get-treg-of (cadr op2))))
-				       
-				      
-		
-		(qe set :u (list op1-treg
-				 (get-treg-of (caddr op2))
-				 (get-treg-of op1))
-		    :arg :lisp)
-		(return-from again)))
-	     (:cdr
-	      ;; it certainly is a lisp stoer
-	      (let (op1-treg const-reg)
-		(setq op1-treg (get-treg-of (cadr op2)))
-	        (setq const-reg (new-reg))
-		(qe const :arg (mdparam 'md-cons-cdr-adj) 
-		    :d (list const-reg))
-				       
-				      
-		
-		(qe set :u (list op1-treg
-				 const-reg
-				 (get-treg-of op1))
-		    :arg :lisp)
-		(return-from again))))
-	 
-	   ; the 'to'address is simple, the from address may not be
-	 
-	   (let ((index1 (index-p op1))
-		 (index2 (index-p op2))
-		 (vector1 (vector-preg-p op1))
-		 (vector2 (vector-preg-p op2)))
-	     (ecase (car op1)
-	       ((:reg :cvar :arg :constant :lisp-symbol)
-		(qe move 
-		    :u (list (get-treg-of op1 op2))
-		    :d (list (get-treg-of op2))))
-	       (:std-wrapper
-		(qe-slot-access (cadr op1) 
-				(+ (* 1 4)
-				   (comp::mdparam 'md-svector-data0-adj))
-				op2))
-	       (:std-slots
-		(qe-slot-access (cadr op1) 
-				(+ (* 2 4)
-				   (comp::mdparam 'md-svector-data0-adj))
-				op2))
-	       (:fsc-wrapper
-		(qe-slot-access (cadr op1) 
-				(+ (* (- 15 1) 4)
-				   (comp::mdparam 'md-function-const0-adj))
-				op2))
-	       (:fsc-slots
-		(qe-slot-access (cadr op1) 
-				(+ (* (- 15 2) 4)
-				   (comp::mdparam 'md-function-const0-adj))
-				op2))
-	       ((:built-in-wrapper :structure-wrapper :built-in-or-structure-wrapper)
-		(qe call :arg 'pcl::built-in-or-structure-wrapper
-		    :u (list (get-treg-of (cadr op1)))
-		    :d (list (get-treg-of op2))))
-	       (:other-wrapper
-		(warn "do other-wrapper"))
-	       ((:i+ :i- :ilogand :ilogxor)
-		(qe arith :arg (cdr (assoc (car op1) 
-					   '((:i+ . :+)
-					     (:i- . :-)
-					     (:ilogand . :logand)
-					     (:ilogxor . :logxor))
-					   :test #'eq))
-		    :u (list (get-treg-of (cadr op1))
-			     (get-treg-of (caddr op1)))
-		    :d (list (get-treg-of op2))))
-	       (:i1+
-		(let ((const-reg (new-reg)))
-		  (qe const :arg 4 ; an index value of 1
-		      :d (list const-reg))
-		  (qe arith :arg :+
-		      :u (list const-reg
-			       (get-treg-of (cadr op1)))
-		      :d (list (get-treg-of op2)))))
-		      
-	       ((:iref :cref :instance-ref)
-		(let (op1-treg)
-		  (if* (not (vector-preg-p (cadr op1)))
-		     then ; must offset before store
-			  (error "must use vector register in ~s" lap)
-		     else (setq op1-treg (get-treg-of (cadr op1))))
-				       
-		  (qe ref :u (list op1-treg
-				   (get-treg-of (caddr op1) op2))
-		      :d (list (get-treg-of op2))
-		      :arg :long)))
-	       (:cdr
-		(let ((const-reg (new-reg)))
-		  (qe const :arg (mdparam 'md-cons-cdr-adj)
-		      :d (list const-reg))
-		  (qe ref :arg :long
-		      :u (list (get-treg-of (cadr op1))
-			       const-reg)
-		      :d (list (get-treg-of op2))))))
-	     (if* (not (eq index1 index2))
-		then (let ((shiftamt (new-reg)))
-		       (qe const :arg 1 :d (list shiftamt))
-		       (if* (and index1 (not index2))
-			  then ; converting from index to non-index
-			       (qe lsl :u (list (get-treg-of op2) shiftamt)
-				   :d (list (get-treg-of op2)))
-			elseif (and (not index1) index2)
-			       ; converting to an index
-			  then (qe lsr :u (list (get-treg-of op2) shiftamt)
-				   :d (list (get-treg-of op2)))))
-	      elseif (and vector2 (not vector1))
-		then ; add vector offset
-		     (let ((tempreg (new-reg))
-			   (vreg (get-treg-of op2)))
-		       (qe const :arg (mdparam 'md-svector-data0-adj)
-			   :d (list tempreg))
-		       (qe arith :arg :+ :u (list vreg tempreg)
-			   :d (list vreg))))))
-	  (:fix=
-	   (let (tr1 tr2)
-	     (if* (index-p op1)
-		then (setq tr1 (get-treg-of op1))
-		     (if* (not (index-p op2))
-			then (setq tr2 (gen-index-treg op2))
-			else (setq tr2 (get-treg-of op2)))
-	      elseif (index-p op2)
-		then ; assert: op1 isn't an index treg
-		     (setq tr1 (gen-index-treg op1))
-		     (setq tr2 (get-treg-of op2))
-		else (setq tr1 (get-treg-of op1)
-			   tr2 (get-treg-of op2)))
-	   
-		   
-		   
-	     (qe bcc :u (list tr1 tr2)
-		 :arg (cadddr lap)
-		 :arg2 :eq )))
-	  ((:eq :neq :fix=)
-	   (if* (not (eq (index-p op1) (index-p op2)))
-	      then (error "non matching operands indexwise in: ~s" lap))
-	   (qe bcc :u (list (get-treg-of op1)
-			    (get-treg-of op2))
-	       :arg (cadddr lap)
-	       :arg2 (cdr (assoc opcode '((:eq . :eq)
-					  (:neq . :ne))
-				 :test #'eq))))
-	  (:izerop 
-	   (qe bcc :u (list (get-treg-of op1)
-			    *zero-treg*)
-	       :arg (caddr lap)
-	       :arg2 :eq))
-	  (:std-instance-p
-	   (let ((treg (get-treg-of op1))
-		 (tempreg (new-reg))
-		 (temp2reg (new-reg))
-		 (offsetreg (new-reg))
-		 (nope (pc-genlab)))
-	     (qe typecheck :u (list treg)
-		 :arg nope
-		 :arg2 '(not structure))
-	     (qe const :arg 'pcl::std-instance :d (list tempreg))
-	     (qe const :arg (mdparam 'md-svector-data0-adj) 
-		 :d (list offsetreg))
-	     (qe ref :u (list treg offsetreg) 
-		 :d (list temp2reg)
-		 :arg :long)
-	     (qe bcc :arg2 :eq :u (list tempreg temp2reg)
-		 :arg (caddr lap))
-	     (qe label :arg nope)))
-	  
-	  (:fsc-instance-p
-	   (let ((treg (get-treg-of op1))
-		 (nope (pc-genlab))
-		 (offsetreg (new-reg))
-		 (tempreg (new-reg))
-		 (checkreg (new-reg)))
-	     (qe typecheck :u (list treg)
-		 :arg nope
-		 :arg2 '(not compiled-function))
-	     (qe const :arg (mdparam 'md-function-flags-adj)
-		 :d (list offsetreg))
-	     (qe ref :u (list treg offsetreg) :d (list tempreg)
-		 :arg :ubyte)
-	     (qe const :arg pcl::funcallable-instance-flag-bit
-		 :d (list checkreg))
-	     (qe bcc :u (list checkreg tempreg)
-		 :arg (caddr lap)
-		 :arg2 :bit-and)
-	     (qe label :arg nope)))
-	  (:built-in-instance-p
-	   ; always true
-	   (qe bra :arg (caddr lap)))
-	  (:jmp
-	   (qe tail-funcall :u (list *nargs-treg* (get-treg-of op1))))
-	  (:structure-instance-p
-	   ; always true
-	   (qe bra :arg (caddr lap)))
-	  
-	  (:return
-	    (let (op-treg)
-	      (if* (index-p op1)
-		 then ; convert to lisp before returning
-		      (let ((shiftamt (new-reg)))
-			(setq op-treg (new-reg))
-			(qe const :arg 1 :d (list shiftamt))
-			(qe lsl :u (list (get-treg-of op1) shiftamt)
-			    :d (list op-treg)))
-		 else (setq op-treg (get-treg-of op1)))
-
-	      (qe move :u (list op-treg) :d *mv-treg-target*)
-	      (qe return :u *mv-treg-target*)))
-
-	  (:go
-	   (qe bra :arg (cadr lap)))
-	   
-	  (:label 
-	   (qe label :arg (cadr lap)))
-	     
-	   
-	   
-	  (t (warn "ignoring ~s" lap)))))))
-
-
-(defun insert-closure-vals (function closure-vals)
-  ;;  build a fucntion from the lap and insert 
-  (let ((newfun (sys::copy-function function)))
-    (setf (excl::fn_closure newfun) (list (apply 'vector closure-vals)))
-    newfun))
-
-  
-	     
-; test case:
-; (pcl::defclass foo () (a b c))
-; (pcl::defmethod barx ((a foo) b c)  a )
-; (apply 'pcl::excl-lap-closure-generator pcl::*tcase*)
-;
-; to turn it on
-
-(if* (not (and (boundp 'user::noquad)
-	       (symbol-value 'user::noquad)))
-   then (setq pcl::*make-lap-closure-generator* 
-	  'pcl::excl-lap-closure-generator))
-
-
-
-
-
-  
-
diff --git a/pcl/time.lisp b/pcl/time.lisp
deleted file mode 100644
index 2b5d9cbfe734153e8bab2c2d47dd2eae98c35c7b..0000000000000000000000000000000000000000
--- a/pcl/time.lisp
+++ /dev/null
@@ -1,156 +0,0 @@
-(in-package "PCL")
-
-(declaim (optimize (speed 3)(safety 0)(compilation-speed 0)))
-
-(defvar *tests*)
-(setq *tests* nil)
-
-(defvar m (car (generic-function-methods #'shared-initialize)))
-(defvar gf #'shared-initialize)
-(defvar c (find-class 'standard-class))
-
-(defclass str ()
-  ((slot :initform nil :reader str-slot))
-  (:metaclass structure-class))
-
-(defvar str (make-instance 'str))
-
-
-(push (cons "Time unoptimized slot-value.  This is case (1) from notes.text. (standard)"
-	    '(time-slot-value m 'plist 10000))
-      *tests*)
-(push (cons "Time unoptimized slot-value.  This is case (1) from notes.text. (standard)"
-	    '(time-slot-value m 'generic-function 10000))
-      *tests*)
-(push (cons "Time unoptimized slot-value.  This is case (1) from notes.text. (structure)"
-	    '(time-slot-value str 'slot 10000))
-      *tests*)
-(defun time-slot-value (object slot-name n)
-  (time (dotimes (i n) (slot-value object slot-name))))
-
-
-(push (cons "Time optimized slot-value outside of a defmethod. Case (2). (standard)"
-	    '(time-slot-value-function m 10000))
-      *tests*)
-(defun time-slot-value-function (object n)
-  (time (dotimes (i n) (slot-value object 'function))))
-
-
-(push (cons "Time optimized slot-value outside of a defmethod. Case (2). (structure)"
-	    '(time-slot-value-slot str 10000))
-      *tests*)
-(defun time-slot-value-slot (object n)
-  (time (dotimes (i n) (slot-value object 'slot))))
-
-
-(push (cons "Time one-class dfun."
-	    '(time-generic-function-methods gf 10000))
-      *tests*)
-(defun time-generic-function-methods (object n)
-  (time (dotimes (i n) (generic-function-methods object))))
-
-
-(push (cons "Time one-index dfun."
-	    '(time-class-precedence-list c 10000))
-      *tests*)
-(defun time-class-precedence-list (object n)
-  (time (dotimes (i n) (class-precedence-list object))))
-
-
-(push (cons "Time n-n dfun."
-	    '(time-method-function m 10000))
-      *tests*)
-(defun time-method-function (object n)
-  (time (dotimes (i n) (method-function object))))
-
-
-(push (cons "Time caching dfun."
-	    '(time-class-slots c 10000))
-      *tests*)
-(defun time-class-slots (object n)
-  (time (dotimes (i n) (class-slots object))))
-
-
-(push (cons "Time typep for classes."
-	    '(time-typep-standard-object m 10000))
-      *tests*)
-(defun time-typep-standard-object (object n)
-  (time (dotimes (i n) (typep object 'standard-object))))
-
-
-(push (cons "Time default-initargs."
-	    '(time-default-initargs (find-class 'plist-mixin) 1000))
-      *tests*)
-(defun time-default-initargs (class n)
-  (time (dotimes (i n) (default-initargs class nil))))
-
-
-(push (cons "Time make-instance."
-	    '(time-make-instance (find-class 'plist-mixin) 1000))
-      *tests*)
-(defun time-make-instance (class n)
-  (time (dotimes (i n) (make-instance class))))
-
-(push (cons "Time constant-keys make-instance."
-	    '(time-constant-keys-make-instance 1000))
-      *tests*)
-
-(expanding-make-instance-top-level
-(defun constant-keys-make-instance (n)
-  (dotimes (i n) (make-instance 'plist-mixin))))
-
-(precompile-random-code-segments)
-
-(defun time-constant-keys-make-instance (n)
-  (time (constant-keys-make-instance n)))
-
-(defun expand-all-macros (form)
-  (walk-form form nil #'(lambda (form context env)
-			  (if (and (eq context :eval)
-				   (consp form)
-				   (symbolp (car form))
-				   (not (special-form-p (car form)))
-				   (macro-function (car form)))
-			      (values (macroexpand form env))
-			      form))))
-
-(push (cons "Macroexpand meth-structure-slot-value"
-	    '(pprint (multiple-value-bind (pgf pm)
-			 (prototypes-for-make-method-lambda 
-			  'meth-structure-slot-value)
-		       (expand-defmethod
-			'meth-structure-slot-value pgf pm
-			nil '((object str))
-			'(#'(lambda () (slot-value object 'slot)))
-			nil))))
-      *tests*)
-
-#-kcl
-(push (cons "Show code for slot-value inside a defmethod for a structure-class. Case (3)."
-	    '(disassemble (meth-structure-slot-value str)))
-      *tests*)
-(defmethod meth-structure-slot-value ((object str))
-  #'(lambda () (slot-value object 'slot)))
-
-
-#|| ; interesting, but long.  (produces 100 lines of output)
-(push (cons "Macroexpand meth-standard-slot-value"
-	    '(pprint (expand-all-macros
-		     (expand-defmethod-internal 'meth-standard-slot-value
-		      nil '((object standard-method))
-		      '(#'(lambda () (slot-value object 'function)))
-		      nil))))
-      *tests*)
-(push (cons "Show code for slot-value inside a defmethod for a standard-class. Case (4)."
-	    '(disassemble (meth-standard-slot-value m)))
-      *tests*)
-(defmethod meth-standard-slot-value ((object standard-method))
-  #'(lambda () (slot-value object 'function)))
-||#
-
-
-(defun do-tests ()
-  (dolist (doc+form (reverse *tests*))
-    (format t "~&~%~A~%" (car doc+form))    
-    (pprint (cdr doc+form))
-    (eval (cdr doc+form))))