diff --git a/tools/setup.lisp b/tools/setup.lisp
index 019d566a0591f683101e67dccbf4e4a360837a92..8e7fc1875043935ff48645b905738b4302240dac 100644
--- a/tools/setup.lisp
+++ b/tools/setup.lisp
@@ -5,246 +5,124 @@
 ;;;
 (in-package "USER")
 
-;;; ### Patch...
-(in-package "LISP")
-(defun keyword-argument (keyword key-list)
-  "If keyword is present in the keylist, return it's associated value."
-  (do ((keys key-list (cddr keys)))
-      ((endp keys))
-    (when (eq (car keys) keyword)
-      (return (cadr keys)))))
-
-#+new-compiler
-(proclaim '(optimize (debug-info 2)))
-
-(in-package "EXT")
-(export '(debug *gc-verbose*))
-
-(in-package "EVAL")
-(export '(internal-eval interpreted-function-p
-			interpreted-function-lambda-expression
-			interpreted-function-closure
-			interpreted-function-name
-			interpreted-function-arglist
-			make-interpreted-function))
-#-new-compiler
-(import '*eval-stack-top* (find-package "LISP"))
-
-#-new-compiler
-(defmacro indirect-value (value-cell)
-  `(car ,value-cell))
-
-#-new-compiler
-(defmacro eval-stack-local (fp offset)
-  `(svref *eval-stack* (+ ,fp ,offset)))
-
-
-#-new-compiler
-(in-package "C" :use '("EXTENSIONS" "SYSTEM" "LISP"))
-
-#-new-compiler
-(export '(compile-for-eval lambda-eval-info-frame-size
-	  lambda-eval-info-args-passed lambda-eval-info-entries
-	  entry-node-info-st-top entry-node-info-nlx-tag
-	  *compile-time-define-macros*))
-
-#-new-compiler
-(setq clc::*peep-enable* t)
-#-new-compiler
-(setq clc::*inline-enable* t)
-#-new-compiler
-(setq ext:*safe-defstruct-accessors* nil)
-
-#-new-compiler
-(import '(lisp::boolean lisp::enumeration))
-
-;;; ### system patch...
-#-new-compiler
-(load "/../fred/usr/ram/hash.fasl")
-
-(defun zap-sym (name pkg)
-  (let ((found (find-symbol name (find-package pkg))))
-    (when (and found
-	       (eq (symbol-package found) (find-package pkg)))
-      (unintern found pkg))))
-
-#-new-compiler
-(progn
-  (zap-sym "ABORT" "C")
-  (zap-sym "CONCAT-PNAMES" "LISP")
-  (zap-sym "ARG" "LISP")
-  (zap-sym "VAR" "LISP")
-  (zap-sym "ONCE-ONLY" "COMPILER"))
+
+;;; DUMP-PACKAGE-STATE  --  Public
+;;;
+(defun dump-package-state (packages file)
+  (declare (type (or list package symbol string) packages)
+	   (type (or pathname symbol string) file))
+  (let* ((packages (lisp::package-listify packages)))
+    (collect ((forms))
+      (dolist (pkg packages)
+	(let ((nicks (package-nicknames pkg))
+	      (name (package-name pkg))
+	      (shad (package-shadowing-symbols pkg)))
+	  (forms `(unless (find-package ,name)
+		    (make-package ,name :nicknames ',nicks :use nil)))
+	  (when shad
+	    (forms `(shadow ',(mapcar #'string shad) ,name)))))
+
+      (dolist (pkg packages)
+	(forms `(use-package ',(mapcar #'package-name
+				       (package-use-list pkg))
+			     ,(package-name pkg))))
+
+      (dolist (old packages)
+	(collect ((exports))
+	  (let ((imports (make-hash-table :test #'eq)))
+	    (do-symbols (sym old)
+	      (let ((pkg (symbol-package sym))
+		    (name (symbol-name sym)))
+		(multiple-value-bind (found how)
+				     (find-symbol name old)
+		  (assert (and (eq found sym) how))
+		  (cond
+		   ((not pkg)
+		    (warn "Not dumping uninterned symbol ~S." sym))
+		   ((eq how :inherited))
+		   (t
+		    (unless (eq pkg old)
+		      (pushnew name (gethash pkg imports) :test #'string=))
+		    (when (eq how :external)
+		      (exports name)))))))
+	    (forms `(defpackage ,(package-name old)
+		      ,@(loop for pkg being each hash-key in imports
+			      for names being each hash-value in imports
+			      collect `(:import-from ,(package-name pkg)
+						     ,@names))
+		      ,@(when (exports)
+			  `((:export ,@(exports)))))))))
+
+      (with-open-file (s file :direction :output :if-exists :new-version)
+	(dolist (form (forms))
+	  (write form :stream s :pretty t)
+	  (terpri s)))))
+
+  (values))
   
-#-new-compiler
-(let ((sym (find-symbol "%CHARACTER-TYPE" (find-package "SYSTEM"))))
-  (when sym
-    (makunbound sym)
-    (unintern sym (find-package "SYSTEM"))))
-
-
-#-new-compiler
-(in-package "EXTENSIONS")
-#-new-compiler
-(export '(info clear-info define-info-class define-info-type))
-#-new-compiler
-(export '(ignorable truly-the maybe-inline))
-
-#-new-compiler
-(export '(lisp::with-compilation-unit lisp::debug-info) "LISP")
-
-#-new-compiler
-(export '(system::%g-vector-structure-name-slot
-	  system::find-if-in-closure
-	  system::*file-input-handlers*)
-	"SYSTEM")
-
-#-new-compiler
-(let ((found (find-symbol "CONCAT-PNAMES" (find-package "LISP"))))
-  (when found
-    (unintern found (find-package "LISP"))))
-
-#-new-compiler
-(in-package "DEBUG")
-#-new-compiler
-(export '(var arg))
-
-
-(in-package "DEBUG-INTERNALS" :nicknames '("DI"))
-
-;;; The compiler's debug-source structure is almost exactly what we want, so
-;;; just get these symbols and export them.
+
+;;; COPY-PACKAGES  --  Public
 ;;;
-(import '(c::debug-source-from c::debug-source-name c::debug-source-created
-	  c::debug-source-compiled c::debug-source-start-positions
-	  c::debug-source c::debug-source-p))
-
-(export '(debug-variable-name debug-variable-package debug-variable-symbol
-	  debug-variable-id debug-variable-value debug-variable-validity
-	  debug-variable-valid-value debug-variable debug-variable-p
-
-	  top-frame frame-down frame-up frame-debug-function
-	  frame-code-location eval-in-frame return-from-frame frame-catches
-	  frame-number frame frame-p
-
-	  do-blocks debug-function-lambda-list do-debug-function-variables
-	  debug-function-symbol-variables ambiguous-debug-variables
-	  preprocess-for-eval function-debug-function debug-function-function
-	  debug-function-kind debug-function-name debug-function
-	  debug-function-p
-
-	  do-debug-block-locations debug-block-successors debug-block
-	  debug-block-p debug-block-elsewhere-p
-
-	  make-breakpoint activate-breakpoint deactivate-breakpoint
-	  breakpoint-hook-function breakpoint-info breakpoint-kind
-	  breakpoint-what breakpoint breakpoint-p
-
-	  code-location-debug-function code-location-debug-block
-	  code-location-top-level-form-offset code-location-form-number
-	  code-location-debug-source code-location code-location-p
-	  unknown-code-location unknown-code-location-p
-
-	  debug-source-from debug-source-name debug-source-created
-	  debug-source-compiled debug-source-root-number
-	  debug-source-start-positions form-number-translations
-	  source-path-context debug-source debug-source-p
-
-	  debug-condition no-debug-info no-debug-function-returns
-	  no-debug-blocks lambda-list-unavailable
-
-	  debug-error unhandled-condition invalid-control-stack-pointer
-	  unknown-code-location unknown-debug-variable invalid-value))
-
-
-#-new-compiler
-(in-package "LISP")
-#-new-compiler
-(import '(
-	  ct-a-val-sap ct-a-val-type ct-a-val-offset ct-a-val-size
-	  ct-a-val-p ct-a-val make-ct-a-val ct-a-val-alien
-	  check<= check= %alien-indirect %bind-aligned-sap
-	  naturalize-integer deport-integer naturalize-boolean deport-boolean
-	  sap-ref-8 sap-ref-16 sap-ref-32
-	  signed-sap-ref-8 signed-sap-ref-16 signed-sap-ref-32 int-sap sap-int
-	  %set-sap-ref-8 %set-sap-ref-16 %set-sap-ref-32
-	  %set-alien-access %standard-char-p %string-char-p
+(defun copy-packages (packages)
+  "Rename all the of the Named packages to OLD-Name, and then create new
+  packages for each name that have the same names, nicknames, imports, shadows
+  and exports.  If any of the OLD-Name packages already exist, then we quietly
+  do nothing."
+  (let* ((packages (lisp::package-listify packages))
+	 (names (mapcar #'package-name packages))
+	 (new-names (mapcar #'(lambda (x)
+				(concatenate 'string "OLD-" x))
+			    names)))
+    (unless (some #'find-package new-names)
+      (collect ((new-packages))
+	(flet ((trans-pkg (x)
+		 (or (cdr (assoc x (new-packages))) x)))
+	  (loop for pkg in packages and new in new-names do
+	    (let ((nicks (package-nicknames pkg))
+		  (name (package-name pkg)))
+	      (rename-package pkg new)
+	      (let ((new-pkg (make-package name :nicknames nicks :use nil))
+		    (shad (package-shadowing-symbols pkg)))
+		(when shad
+		  (shadow shad new-pkg))
+		(new-packages (cons pkg new-pkg)))))
 	  
-	  *alien-eval-when* make-alien alien-type alien-size alien-address
-	  copy-alien dispose-alien defalien alien-value
-	  alien-bind defoperator alien-index alien-indirect
-	  bits bytes words long-words port perq-string
-	  boolean defenumeration enumeration
-	  system-area-pointer pointer alien alien-access
-	  alien-assign alien-sap define-alien-stack
-	  with-stack-alien null-terminated-string c-procedure
-	  unstructured record-size
-	  )
-	(find-package "C"))
-
-(export 'function-lambda-expression)
-
-;;; Hack to prevent SETF from expanding these macros out of the environment,
-;;; since these are functions in the new system.
-;;;
-#-new-compiler
-(dolist (x '(sap-ref-8 sap-ref-16 sap-ref-32))
-  (fmakunbound x))
-
-(in-package "C")
-(define-condition parse-unknown-type (condition)
-		  (specifier))
-
-(in-package "USER")
-
-;;; Hack until real definition exists:
-;;;
-#-new-compiler
-(defmacro with-compilation-unit (glue &rest body)
-  (declare (ignore glue))
-  `(let ((lisp::*in-compilation-unit* t))
-     (declare (special lisp::*in-compilation-unit*))
-     ,@body))
-;;;
-;;; So the real WCU won't die in bootstrap env.
-#-new-compiler
-(defvar lisp::*in-compilation-unit* nil)
-#-new-compiler
-(defun c::print-summary (a b)
-  (declare (ignore a b)))
-
-
-#-new-compiler
-(setq lisp::*maximum-interpreter-error-checking* nil)
+	  (loop for (old . new) in (new-packages) do
+	    (dolist (use (package-use-list old))
+	      (use-package (trans-pkg use) new)))
+	  
+	  (loop for (old . new) in (new-packages) do
+	    (do-symbols (sym old)
+	      (let ((pkg (symbol-package sym))
+		    (name (symbol-name sym)))
+		(multiple-value-bind (found how)
+				     (find-symbol name old)
+		  (assert (and (eq found sym) how))
+		  (cond
+		   ((not pkg)
+		    (warn "Not copying uninterned symbol ~S." sym))
+		   ((or (eq how :inherited)
+			(and (eq how :internal) (eq pkg old))))
+		   (t
+		    (let* ((npkg (trans-pkg pkg))
+			   (nsym (intern name npkg)))
+		      (multiple-value-bind (ignore new-how)
+					   (find-symbol name new)
+			(declare (ignore ignore))
+			(unless new-how (import nsym new)))
+		      (when (eq how :external)
+			(export nsym new)))))))))))))
+  (values))
 
 
 ;;;; Compile utility:
 
 ;;; Switches:
 ;;;
-(defvar *interactive* nil) ; Batch compilation mode?
-(defvar *new-compile* t) ; Use new compiler?
-
-(setq *bytes-consed-between-gcs* 1500000)
-
-(setq *gc-notify-before*
-      #'(lambda (&rest foo)
-	  (cond (*interactive*
-		 (apply #'lisp::default-gc-notify-before foo))
-		(t
-		 (write-char #\. *terminal-io*)
-		 (force-output *terminal-io*)))))
-
-(setq *gc-notify-after*
-      #'(lambda (&rest foo)
-	  (when *interactive*
-	    (apply #'lisp::default-gc-notify-after foo))))
-
+(defvar *interactive* t) ; Batch compilation mode?
 
 (defvar *log-file* nil)
 (defvar *last-file-position*)
-(defvar *compiled-files* (make-hash-table :test #'equal))
-
 
 (defmacro with-compiler-log-file ((name) &body forms)
   `(if *interactive*
@@ -261,11 +139,7 @@
 	   (close *log-file*)))))
 
 
-(proclaim '(special lisp::*bootstrap-defmacro*))
-
-(defun comf (name &key always-once proceed load output-file
-		  ((:bootstrap-macros lisp::*bootstrap-defmacro*) nil))
-  #+new-compiler
+(defun comf (name &key always-once proceed load output-file assem)
   (declare (ignore always-once))
   (when (and *log-file*
 	     (> (- (file-position *log-file*) *last-file-position*) 10000))
@@ -276,48 +150,44 @@
 	 (obj (if output-file
 		  (pathname output-file)
 		  (make-pathname :defaults src
-				 :type (c:backend-fasl-file-type
-					c:*target-backend*))))
-	 (obj-pn (probe-file obj)))
+				 :type
+				 (if assem
+				     "assem"
+				     (c:backend-fasl-file-type c:*backend*))))))
 
-    (unless (and obj-pn
-		 (>= (file-write-date obj-pn) (file-write-date src))
-		 #+nil
-		 (equalp (pathname-directory
-			  (lisp::sub-probe-file (first (search-list src))))
-			 (pathname-directory obj-pn))
-		 #-new-compiler
-		 (or (gethash src *compiled-files*)
-		     (not always-once)))
+    (unless (and (probe-file obj)
+		 (>= (file-write-date obj) (file-write-date src)))
       (write-line name)
       (format *error-output* "~2&Start time: ~A, compiling ~A.~%"
 	      (ext:format-universal-time nil (get-universal-time))
 	      name)
-      (cond
-       (*interactive*
-	(compile-file src  :error-file nil  :output-file obj)
-	(when load
-	  (load name :verbose t)))
-       (t
-	(handler-bind ((error #'(lambda (condition)
-				  (format *error-output* "~2&~A~2&"
-					  condition)
-				  (when proceed
-				    (format *error-output* "Proceeding...~%")
-				    (continue))
-				  (format *error-output* "Aborting...~%")
-				  (handler-case
-				      (let ((*debug-io* *error-output*))
-					(debug:backtrace))
-				    (error (condition)
-				      (declare (ignore condition))
-				      (format t "Error in backtrace!~%")))
-				  (format t "Error abort.~%")
-				  (return-from comf))))
-	  (compile-file src  :error-file nil  :output-file obj)
+      (catch 'blow-this-file
+	(cond
+	 (*interactive*
+	  (if assem
+	      (c::assemble-file src :output-file obj)
+	      (compile-file src  :error-file nil  :output-file obj))
 	  (when load
-	    (load name :verbose t)))))
-      (setf (gethash src *compiled-files*) t))
+	    (load name :verbose t)))
+	 (t
+	  (handler-bind ((error #'(lambda (condition)
+				    (format *error-output* "~2&~A~2&"
+					    condition)
+				    (when proceed
+				      (format *error-output* "Proceeding...~%")
+				      (continue))
+				    (format *error-output* "Aborting...~%")
+				    (handler-case
+					(let ((*debug-io* *error-output*))
+					  (debug:backtrace))
+				      (error (condition)
+					(declare (ignore condition))
+					(format t "Error in backtrace!~%")))
+				    (format t "Error abort.~%")
+				    (return-from comf))))
+	    (if assem
+		(c::assemble-file src :output-file obj)
+		(compile-file src  :error-file nil  :output-file obj))
+	    (when load
+	      (load name :verbose t)))))))))
 
-    ;; Only set after compilation so that it can be bound around the call.
-    (setq lisp::*bootstrap-defmacro* nil)))