From 3c049e3711c16756594fb0937321c323dec722c5 Mon Sep 17 00:00:00 2001
From: pmai <pmai>
Date: Mon, 26 Aug 2002 02:40:58 +0000
Subject: [PATCH] Conservatively removed some unused files in the pcl
 directory.  Most of the files are completely unintresting, though the
 *lap.lisp code might be interesting for someone looking to make PCL work
 without the compiler being present, which would make runtime images much more
 useful.  Still, anyone interested can look in the CVS Attic.  A number of
 currently unused files, like structure-class.lisp, user-instances.lisp and
 extensions.lisp have been left in for the time being, becauses they might
 even be useful to certain users.

---
 pcl/compat.lisp         |  31 --
 pcl/defsys.lisp         |   3 +-
 pcl/dlap.lisp           | 611 ---------------------------------------
 pcl/inline.lisp         | 263 -----------------
 pcl/lap.lisp            | 502 --------------------------------
 pcl/list-functions.lisp | 141 ---------
 pcl/make-test.lisp      |  47 ---
 pcl/plap.lisp           | 353 -----------------------
 pcl/quadlap.lisp        | 619 ----------------------------------------
 pcl/time.lisp           | 156 ----------
 10 files changed, 1 insertion(+), 2725 deletions(-)
 delete mode 100644 pcl/compat.lisp
 delete mode 100644 pcl/dlap.lisp
 delete mode 100644 pcl/inline.lisp
 delete mode 100644 pcl/lap.lisp
 delete mode 100644 pcl/list-functions.lisp
 delete mode 100644 pcl/make-test.lisp
 delete mode 100644 pcl/plap.lisp
 delete mode 100644 pcl/quadlap.lisp
 delete mode 100644 pcl/time.lisp

diff --git a/pcl/compat.lisp b/pcl/compat.lisp
deleted file mode 100644
index 606915388..000000000
--- 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 3f8c49bfb..cb5db3e00 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 c9ecda9e8..000000000
--- 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 91122050e..000000000
--- 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 eaaeeba08..000000000
--- 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 f4601a439..000000000
--- 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 a80a006e1..000000000
--- 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 3b670ea38..000000000
--- 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 ad90099e5..000000000
--- 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 2b5d9cbfe..000000000
--- 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))))
-- 
GitLab