From 4f7211e1d005696dcd29d8322fa531992ea8fed4 Mon Sep 17 00:00:00 2001
From: William Harold Newman <william.newman@airmail.net>
Date: Fri, 5 Oct 2001 23:59:26 +0000
Subject: [PATCH] 0.pre7.46: 	various refactorings and tidying.. 
 ..redid the hairy remove-ourselves-from-tail-set mess in 
 	MERGE-LETS as a separate function, 	
 DEPART-FROM-TAIL-SET 	..split diagnostic/reporting stuff
 (starting around 		(DECLAIM (SPECIAL
 *CURRENT-PATH*)) out of ir1util.lisp 		into
 ir1report.lisp 	..moved UNIX-HOST stuff around in an
 effort to get rid 		of compiler
 not-defined-(yet) warnings 	..split target-pathname.lisp
 out of pathname.lisp to support 		this 
 ..moved target-only HOST stuff from pathname.lisp (which is
 		built both on host and target) to
 filesys.lisp (which 		is flagged as :NOT-HOST in
 stems-and-flags.lisp-expr) 	..Since there's no longer
 any numbers.lisp or 		host-numbers.lisp to
 contrast to, target-numbers.lisp 		really ought
 to be called numbers.lisp. 	..split ir1-translators.lisp
 out of ir1tran.lisp (as per FIXME) 	..moved IDENTITY,
 COMPLEMENT, and CONSTANTLY out of list.lisp 		into
 funutils.lisp

---
 src/code/filesys.lisp             |   23 -
 src/code/funutils.lisp            |   41 ++
 src/code/list.lisp                |   96 +--
 src/code/numbers.lisp             | 1323 +++++++++++++++++++++++++++++++++++++
 src/code/pathname.lisp            |    9 +-
 src/code/target-numbers.lisp      | 1323 -------------------------------------
 src/code/target-pathname.lisp     |   28 +-
 src/compiler/ir1-translators.lisp | 1071 ++++++++++++++++++++++++++++++
 src/compiler/ir1report.lisp       |  518 +++++++++++++++
 src/compiler/ir1tran.lisp         | 1072 +-----------------------------
 src/compiler/ir1util.lisp         |  505 --------------
 src/compiler/locall.lisp          |   61 +-
 stems-and-flags.lisp-expr         |   16 +-
 version.lisp-expr                 |    2 +-
 14 files changed, 3066 insertions(+), 3022 deletions(-)
 create mode 100644 src/code/funutils.lisp
 create mode 100644 src/code/numbers.lisp
 delete mode 100644 src/code/target-numbers.lisp
 create mode 100644 src/compiler/ir1-translators.lisp
 create mode 100644 src/compiler/ir1report.lisp

diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp
index 8464a2c..5e33095 100644
--- a/src/code/filesys.lisp
+++ b/src/code/filesys.lisp
@@ -482,29 +482,6 @@
 	    (t
 	     (lose)))))
       (apply #'concatenate 'simple-string (strings)))))
-
-(/show0 "filesys.lisp 471")
-
-(def!struct (unix-host
-	     (:make-load-form-fun make-unix-host-load-form)
-	     (:include host
-		       (parse #'parse-unix-namestring)
-		       (unparse #'unparse-unix-namestring)
-		       (unparse-host #'unparse-unix-host)
-		       (unparse-directory #'unparse-unix-directory)
-		       (unparse-file #'unparse-unix-file)
-		       (unparse-enough #'unparse-unix-enough)
-		       (customary-case :lower))))
-
-(/show0 "filesys.lisp 486")
-
-(defvar *unix-host* (make-unix-host))
-
-(/show0 "filesys.lisp 488")
-
-(defun make-unix-host-load-form (host)
-  (declare (ignore host))
-  '*unix-host*)
 
 ;;;; wildcard matching stuff
 
diff --git a/src/code/funutils.lisp b/src/code/funutils.lisp
new file mode 100644
index 0000000..ab85f44
--- /dev/null
+++ b/src/code/funutils.lisp
@@ -0,0 +1,41 @@
+;;;; miscellaneous operations on functions, returning functions, or
+;;;; primarily useful for functional programming
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(defun identity (thing)
+  #!+sb-doc
+  "This function simply returns what was passed to it."
+  thing)
+
+(defun complement (function)
+  #!+sb-doc
+  "Return a new function that returns T whenever FUNCTION returns NIL and
+   NIL whenever FUNCTION returns non-NIL."
+  (lambda (&optional (arg0 nil arg0-p) (arg1 nil arg1-p) (arg2 nil arg2-p)
+		     &rest more-args)
+    (not (cond (more-args (apply function arg0 arg1 arg2 more-args))
+	       (arg2-p (funcall function arg0 arg1 arg2))
+	       (arg1-p (funcall function arg0 arg1))
+	       (arg0-p (funcall function arg0))
+	       (t (funcall function))))))
+
+(defun constantly (value)
+  #!+sb-doc
+  "Return a function that always returns VALUE."
+  (lambda ()
+    ;; KLUDGE: This declaration is a hack to make the closure ignore
+    ;; all its arguments without consing a &REST list or anything.
+    ;; Perhaps once DYNAMIC-EXTENT is implemented we won't need to
+    ;; screw around with this kind of thing. -- WHN 2001-04-06
+    (declare (optimize (speed 3) (safety 0)))
+    value))
diff --git a/src/code/list.lisp b/src/code/list.lisp
index 9b07696..2518954 100644
--- a/src/code/list.lisp
+++ b/src/code/list.lisp
@@ -23,91 +23,91 @@
 	  assoc-if assoc-if-not rassoc rassoc-if rassoc-if-not subst subst-if
 	  subst-if-not nsubst nsubst-if nsubst-if-not sublis nsublis))
 
-;;; These functions perform basic list operations:
-(defun car (list) #!+sb-doc "Returns the 1st object in a list." (car list))
+;;; These functions perform basic list operations.
+(defun car (list) #!+sb-doc "Return the 1st object in a list." (car list))
 (defun cdr (list)
-  #!+sb-doc "Returns all but the first object in a list."
+  #!+sb-doc "Return all but the first object in a list."
   (cdr list))
-(defun cadr (list) #!+sb-doc "Returns the 2nd object in a list." (cadr list))
-(defun cdar (list) #!+sb-doc "Returns the cdr of the 1st sublist." (cdar list))
-(defun caar (list) #!+sb-doc "Returns the car of the 1st sublist." (caar list))
+(defun cadr (list) #!+sb-doc "Return the 2nd object in a list." (cadr list))
+(defun cdar (list) #!+sb-doc "Return the cdr of the 1st sublist." (cdar list))
+(defun caar (list) #!+sb-doc "Return the car of the 1st sublist." (caar list))
 (defun cddr (list)
-  #!+sb-doc "Returns all but the 1st two objects of a list."
+  #!+sb-doc "Return all but the 1st two objects of a list."
   (cddr list))
 (defun caddr (list)
-  #!+sb-doc "Returns the 1st object in the cddr of a list."
+  #!+sb-doc "Return the 1st object in the cddr of a list."
   (caddr list))
 (defun caadr (list)
-  #!+sb-doc "Returns the 1st object in the cadr of a list."
+  #!+sb-doc "Return the 1st object in the cadr of a list."
   (caadr list))
 (defun caaar (list)
-  #!+sb-doc "Returns the 1st object in the caar of a list."
+  #!+sb-doc "Return the 1st object in the caar of a list."
   (caaar list))
 (defun cdaar (list)
-  #!+sb-doc "Returns the cdr of the caar of a list."
+  #!+sb-doc "Return the cdr of the caar of a list."
   (cdaar list))
 (defun cddar (list)
-  #!+sb-doc "Returns the cdr of the cdar of a list."
+  #!+sb-doc "Return the cdr of the cdar of a list."
   (cddar list))
 (defun cdddr (list)
-  #!+sb-doc "Returns the cdr of the cddr of a list."
+  #!+sb-doc "Return the cdr of the cddr of a list."
   (cdddr list))
 (defun cadar (list)
-  #!+sb-doc "Returns the car of the cdar of a list."
+  #!+sb-doc "Return the car of the cdar of a list."
   (cadar list))
 (defun cdadr (list)
-  #!+sb-doc "Returns the cdr of the cadr of a list."
+  #!+sb-doc "Return the cdr of the cadr of a list."
   (cdadr list))
 (defun caaaar (list)
-  #!+sb-doc "Returns the car of the caaar of a list."
+  #!+sb-doc "Return the car of the caaar of a list."
   (caaaar list))
 (defun caaadr (list)
-  #!+sb-doc "Returns the car of the caadr of a list."
+  #!+sb-doc "Return the car of the caadr of a list."
   (caaadr list))
 (defun caaddr (list)
-  #!+sb-doc "Returns the car of the caddr of a list."
+  #!+sb-doc "Return the car of the caddr of a list."
   (caaddr list))
 (defun cadddr (list)
-  #!+sb-doc "Returns the car of the cdddr of a list."
+  #!+sb-doc "Return the car of the cdddr of a list."
   (cadddr list))
 (defun cddddr (list)
-  #!+sb-doc "Returns the cdr of the cdddr of a list."
+  #!+sb-doc "Return the cdr of the cdddr of a list."
   (cddddr list))
 (defun cdaaar (list)
-  #!+sb-doc "Returns the cdr of the caaar of a list."
+  #!+sb-doc "Return the cdr of the caaar of a list."
   (cdaaar list))
 (defun cddaar (list)
-  #!+sb-doc "Returns the cdr of the cdaar of a list."
+  #!+sb-doc "Return the cdr of the cdaar of a list."
   (cddaar list))
 (defun cdddar (list)
-  #!+sb-doc "Returns the cdr of the cddar of a list."
+  #!+sb-doc "Return the cdr of the cddar of a list."
   (cdddar list))
 (defun caadar (list)
-  #!+sb-doc "Returns the car of the cadar of a list."
+  #!+sb-doc "Return the car of the cadar of a list."
   (caadar list))
 (defun cadaar (list)
-  #!+sb-doc "Returns the car of the cdaar of a list."
+  #!+sb-doc "Return the car of the cdaar of a list."
   (cadaar list))
 (defun cadadr (list)
-  #!+sb-doc "Returns the car of the cdadr of a list."
+  #!+sb-doc "Return the car of the cdadr of a list."
   (cadadr list))
 (defun caddar (list)
-  #!+sb-doc "Returns the car of the cddar of a list."
+  #!+sb-doc "Return the car of the cddar of a list."
   (caddar list))
 (defun cdaadr (list)
-  #!+sb-doc "Returns the cdr of the caadr of a list."
+  #!+sb-doc "Return the cdr of the caadr of a list."
   (cdaadr list))
 (defun cdadar (list)
-  #!+sb-doc "Returns the cdr of the cadar of a list."
+  #!+sb-doc "Return the cdr of the cadar of a list."
   (cdadar list))
 (defun cdaddr (list)
-  #!+sb-doc "Returns the cdr of the caddr of a list."
+  #!+sb-doc "Return the cdr of the caddr of a list."
   (cdaddr list))
 (defun cddadr (list)
-  #!+sb-doc "Returns the cdr of the cdadr of a list."
+  #!+sb-doc "Return the cdr of the cdadr of a list."
   (cddadr list))
 (defun cons (se1 se2)
-  #!+sb-doc "Returns a list with se1 as the car and se2 as the cdr."
+  #!+sb-doc "Return a list with SE1 as the CAR and SE2 as the CDR."
   (cons se1 se2))
 
 (declaim (maybe-inline tree-equal-test tree-equal-test-not))
@@ -479,40 +479,12 @@
 ;;;; :KEY arg optimization to save funcall of IDENTITY
 
 ;;; APPLY-KEY saves us a function call sometimes.
-;;;    This is not wrapped in an (EVAL-WHEN (COMPILE EVAL) ..)
-;;;    because this is used in seq.lisp and sort.lisp.
+;;;    This isn't wrapped in an (EVAL-WHEN (COMPILE EVAL) ..)
+;;;    because it's used in seq.lisp and sort.lisp.
 (defmacro apply-key (key element)
   `(if ,key
        (funcall ,key ,element)
        ,element))
-
-(defun identity (thing)
-  #!+sb-doc
-  "This function simply returns what was passed to it."
-  thing)
-
-(defun complement (function)
-  #!+sb-doc
-  "Return a new function that returns T whenever FUNCTION returns NIL and
-   NIL whenever FUNCTION returns non-NIL."
-  (lambda (&optional (arg0 nil arg0-p) (arg1 nil arg1-p) (arg2 nil arg2-p)
-		     &rest more-args)
-    (not (cond (more-args (apply function arg0 arg1 arg2 more-args))
-	       (arg2-p (funcall function arg0 arg1 arg2))
-	       (arg1-p (funcall function arg0 arg1))
-	       (arg0-p (funcall function arg0))
-	       (t (funcall function))))))
-
-(defun constantly (value)
-  #!+sb-doc
-  "Return a function that always returns VALUE."
-  (lambda ()
-    ;; KLUDGE: This declaration is a hack to make the closure ignore
-    ;; all its arguments without consing a &REST list or anything.
-    ;; Perhaps once DYNAMIC-EXTENT is implemented we won't need to
-    ;; screw around with this kind of thing. -- WHN 2001-04-06
-    (declare (optimize (speed 3) (safety 0)))
-    value))
 
 ;;;; macros for (&KEY (KEY #'IDENTITY) (TEST #'EQL TESTP) (TEST-NOT NIL NOTP))
 
diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp
new file mode 100644
index 0000000..aa7304a
--- /dev/null
+++ b/src/code/numbers.lisp
@@ -0,0 +1,1323 @@
+;;;; This file contains the definitions of most number functions.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!KERNEL")
+
+;;;; the NUMBER-DISPATCH macro
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+;;; Grovel an individual case to NUMBER-DISPATCH, augmenting RESULT
+;;; with the type dispatches and bodies. Result is a tree built of
+;;; alists representing the dispatching off each arg (in order). The
+;;; leaf is the body to be executed in that case.
+(defun parse-number-dispatch (vars result types var-types body)
+  (cond ((null vars)
+	 (unless (null types) (error "More types than vars."))
+	 (when (cdr result)
+	   (error "Duplicate case: ~S." body))
+	 (setf (cdr result)
+	       (sublis var-types body :test #'equal)))
+	((null types)
+	 (error "More vars than types."))
+	(t
+	 (flet ((frob (var type)
+		  (parse-number-dispatch
+		   (rest vars)
+		   (or (assoc type (cdr result) :test #'equal)
+		       (car (setf (cdr result)
+				  (acons type nil (cdr result)))))
+		   (rest types)
+		   (acons `(dispatch-type ,var) type var-types)
+		   body)))
+	   (let ((type (first types))
+		 (var (first vars)))
+	     (if (and (consp type) (eq (first type) 'foreach))
+		 (dolist (type (rest type))
+		   (frob var type))
+		 (frob var type)))))))
+
+;;; our guess for the preferred order in which to do type tests
+;;; (cheaper and/or more probable first.)
+(defparameter *type-test-ordering*
+  '(fixnum single-float double-float integer #!+long-float long-float bignum
+    complex ratio))
+
+;;; Should TYPE1 be tested before TYPE2?
+(defun type-test-order (type1 type2)
+  (let ((o1 (position type1 *type-test-ordering*))
+	(o2 (position type2 *type-test-ordering*)))
+    (cond ((not o1) nil)
+	  ((not o2) t)
+	  (t
+	   (< o1 o2)))))
+
+;;; Return an ETYPECASE form that does the type dispatch, ordering the
+;;; cases for efficiency.
+(defun generate-number-dispatch (vars error-tags cases)
+  (if vars
+      (let ((var (first vars))
+	    (cases (sort cases #'type-test-order :key #'car)))
+	`((typecase ,var
+	    ,@(mapcar #'(lambda (case)
+			  `(,(first case)
+			    ,@(generate-number-dispatch (rest vars)
+							(rest error-tags)
+							(cdr case))))
+		      cases)
+	    (t (go ,(first error-tags))))))
+      cases))
+
+) ; EVAL-WHEN
+
+;;; This is a vaguely case-like macro that does number cross-product
+;;; dispatches. The Vars are the variables we are dispatching off of.
+;;; The Type paired with each Var is used in the error message when no
+;;; case matches. Each case specifies a Type for each var, and is
+;;; executed when that signature holds. A type may be a list
+;;; (FOREACH Each-Type*), causing that case to be repeatedly
+;;; instantiated for every Each-Type. In the body of each case, any
+;;; list of the form (DISPATCH-TYPE Var-Name) is substituted with the
+;;; type of that var in that instance of the case.
+;;;
+;;; As an alternate to a case spec, there may be a form whose CAR is a
+;;; symbol. In this case, we apply the CAR of the form to the CDR and
+;;; treat the result of the call as a list of cases. This process is
+;;; not applied recursively.
+(defmacro number-dispatch (var-specs &body cases)
+  (let ((res (list nil))
+	(vars (mapcar #'car var-specs))
+	(block (gensym)))
+    (dolist (case cases)
+      (if (symbolp (first case))
+	  (let ((cases (apply (symbol-function (first case)) (rest case))))
+	    (dolist (case cases)
+	      (parse-number-dispatch vars res (first case) nil (rest case))))
+	  (parse-number-dispatch vars res (first case) nil (rest case))))
+
+    (collect ((errors)
+	      (error-tags))
+      (dolist (spec var-specs)
+	(let ((var (first spec))
+	      (type (second spec))
+	      (tag (gensym)))
+	  (error-tags tag)
+	  (errors tag)
+	  (errors `(return-from
+		    ,block
+		    (error 'simple-type-error :datum ,var
+			   :expected-type ',type
+			   :format-control
+			   "~@<Argument ~A is not a ~S: ~2I~_~S~:>"
+			   :format-arguments
+			   (list ',var ',type ,var))))))
+
+      `(block ,block
+	 (tagbody
+	   (return-from ,block
+			,@(generate-number-dispatch vars (error-tags)
+						    (cdr res)))
+	   ,@(errors))))))
+
+;;;; binary operation dispatching utilities
+
+(eval-when (:compile-toplevel :execute)
+
+;;; Return NUMBER-DISPATCH forms for rational X float.
+(defun float-contagion (op x y &optional (rat-types '(fixnum bignum ratio)))
+  `(((single-float single-float) (,op ,x ,y))
+    (((foreach ,@rat-types)
+      (foreach single-float double-float #!+long-float long-float))
+     (,op (coerce ,x '(dispatch-type ,y)) ,y))
+    (((foreach single-float double-float #!+long-float long-float)
+      (foreach ,@rat-types))
+     (,op ,x (coerce ,y '(dispatch-type ,x))))
+    #!+long-float
+    (((foreach single-float double-float long-float) long-float)
+     (,op (coerce ,x 'long-float) ,y))
+    #!+long-float
+    ((long-float (foreach single-float double-float))
+     (,op ,x (coerce ,y 'long-float)))
+    (((foreach single-float double-float) double-float)
+     (,op (coerce ,x 'double-float) ,y))
+    ((double-float single-float)
+     (,op ,x (coerce ,y 'double-float)))))
+
+;;; Return NUMBER-DISPATCH forms for bignum X fixnum.
+(defun bignum-cross-fixnum (fix-op big-op)
+  `(((fixnum fixnum) (,fix-op x y))
+    ((fixnum bignum)
+     (,big-op (make-small-bignum x) y))
+    ((bignum fixnum)
+     (,big-op x (make-small-bignum y)))
+    ((bignum bignum)
+     (,big-op x y))))
+
+) ; EVAL-WHEN
+
+;;;; canonicalization utilities
+
+;;; If IMAGPART is 0, return REALPART, otherwise make a complex. This is
+;;; used when we know that REALPART and IMAGPART are the same type, but
+;;; rational canonicalization might still need to be done.
+#!-sb-fluid (declaim (inline canonical-complex))
+(defun canonical-complex (realpart imagpart)
+  (if (eql imagpart 0)
+      realpart
+      (cond #!+long-float
+	    ((and (typep realpart 'long-float)
+		  (typep imagpart 'long-float))
+	     (truly-the (complex long-float) (complex realpart imagpart)))
+	    ((and (typep realpart 'double-float)
+		  (typep imagpart 'double-float))
+	     (truly-the (complex double-float) (complex realpart imagpart)))
+	    ((and (typep realpart 'single-float)
+		  (typep imagpart 'single-float))
+	     (truly-the (complex single-float) (complex realpart imagpart)))
+	    (t
+	     (%make-complex realpart imagpart)))))
+
+;;; Given a numerator and denominator with the GCD already divided
+;;; out, make a canonical rational. We make the denominator positive,
+;;; and check whether it is 1.
+#!-sb-fluid (declaim (inline build-ratio))
+(defun build-ratio (num den)
+  (multiple-value-bind (num den)
+      (if (minusp den)
+	  (values (- num) (- den))
+	  (values num den))
+    (if (eql den 1)
+	num
+	(%make-ratio num den))))
+
+;;; Truncate X and Y, but bum the case where Y is 1.
+#!-sb-fluid (declaim (inline maybe-truncate))
+(defun maybe-truncate (x y)
+  (if (eql y 1)
+      x
+      (truncate x y)))
+
+;;;; COMPLEXes
+
+(defun upgraded-complex-part-type (spec)
+  #!+sb-doc
+  "Returns the element type of the most specialized COMPLEX number type that
+   can hold parts of type SPEC."
+  (cond ((unknown-type-p (specifier-type spec))
+	 (error "undefined type: ~S" spec))
+	((subtypep spec 'single-float)
+	 'single-float)
+	((subtypep spec 'double-float)
+	 'double-float)
+	#!+long-float
+	((subtypep spec 'long-float)
+	 'long-float)
+	((subtypep spec 'rational)
+	 'rational)
+	(t
+	 'real)))
+
+(defun complex (realpart &optional (imagpart 0))
+  #!+sb-doc
+  "Builds a complex number from the specified components."
+  (flet ((%%make-complex (realpart imagpart)
+	   (cond #!+long-float
+		 ((and (typep realpart 'long-float)
+		       (typep imagpart 'long-float))
+		  (truly-the (complex long-float)
+			     (complex realpart imagpart)))
+		 ((and (typep realpart 'double-float)
+		       (typep imagpart 'double-float))
+		  (truly-the (complex double-float)
+			     (complex realpart imagpart)))
+		 ((and (typep realpart 'single-float)
+		       (typep imagpart 'single-float))
+		  (truly-the (complex single-float)
+			     (complex realpart imagpart)))
+		 (t
+		  (%make-complex realpart imagpart)))))
+  (number-dispatch ((realpart real) (imagpart real))
+    ((rational rational)
+     (canonical-complex realpart imagpart))
+    (float-contagion %%make-complex realpart imagpart (rational)))))
+
+(defun realpart (number)
+  #!+sb-doc
+  "Extracts the real part of a number."
+  (typecase number
+    #!+long-float
+    ((complex long-float)
+     (truly-the long-float (realpart number)))
+    ((complex double-float)
+     (truly-the double-float (realpart number)))
+    ((complex single-float)
+     (truly-the single-float (realpart number)))
+    ((complex rational)
+     (sb!kernel:%realpart number))
+    (t
+     number)))
+
+(defun imagpart (number)
+  #!+sb-doc
+  "Extracts the imaginary part of a number."
+  (typecase number
+    #!+long-float
+    ((complex long-float)
+     (truly-the long-float (imagpart number)))
+    ((complex double-float)
+     (truly-the double-float (imagpart number)))
+    ((complex single-float)
+     (truly-the single-float (imagpart number)))
+    ((complex rational)
+     (sb!kernel:%imagpart number))
+    (float
+     (float 0 number))
+    (t
+     0)))
+
+(defun conjugate (number)
+  #!+sb-doc
+  "Returns the complex conjugate of NUMBER. For non-complex numbers, this is
+  an identity."
+  (if (complexp number)
+      (complex (realpart number) (- (imagpart number)))
+      number))
+
+(defun signum (number)
+  #!+sb-doc
+  "If NUMBER is zero, return NUMBER, else return (/ NUMBER (ABS NUMBER))."
+  (if (zerop number)
+      number
+      (if (rationalp number)
+	  (if (plusp number) 1 -1)
+	  (/ number (abs number)))))
+
+;;;; ratios
+
+(defun numerator (number)
+  #!+sb-doc
+  "Return the numerator of NUMBER, which must be rational."
+  (numerator number))
+
+(defun denominator (number)
+  #!+sb-doc
+  "Return the denominator of NUMBER, which must be rational."
+  (denominator number))
+
+;;;; arithmetic operations
+
+(macrolet ((define-arith (op init doc)
+	     #!-sb-doc (declare (ignore doc))
+	     `(defun ,op (&rest args)
+		#!+sb-doc ,doc
+		(if (null args) ,init
+		  (do ((args (cdr args) (cdr args))
+		       (res (car args) (,op res (car args))))
+		      ((null args) res))))))
+  (define-arith + 0
+    "Returns the sum of its arguments. With no args, returns 0.")
+  (define-arith * 1
+    "Returns the product of its arguments. With no args, returns 1."))
+
+(defun - (number &rest more-numbers)
+  #!+sb-doc
+  "Subtracts the second and all subsequent arguments from the first.
+  With one arg, negates it."
+  (if more-numbers
+      (do ((nlist more-numbers (cdr nlist))
+	   (result number))
+	  ((atom nlist) result)
+	 (declare (list nlist))
+	 (setq result (- result (car nlist))))
+      (- number)))
+
+(defun / (number &rest more-numbers)
+  #!+sb-doc
+  "Divide the first argument by each of the following arguments, in turn.
+  With one argument, return reciprocal."
+  (if more-numbers
+      (do ((nlist more-numbers (cdr nlist))
+	   (result number))
+	  ((atom nlist) result)
+	 (declare (list nlist))
+	 (setq result (/ result (car nlist))))
+      (/ number)))
+
+(defun 1+ (number)
+  #!+sb-doc
+  "Returns NUMBER + 1."
+  (1+ number))
+
+(defun 1- (number)
+  #!+sb-doc
+  "Returns NUMBER - 1."
+  (1- number))
+
+(eval-when (:compile-toplevel)
+
+(sb!xc:defmacro two-arg-+/- (name op big-op)
+  `(defun ,name (x y)
+     (number-dispatch ((x number) (y number))
+       (bignum-cross-fixnum ,op ,big-op)
+       (float-contagion ,op x y)
+
+       ((complex complex)
+	(canonical-complex (,op (realpart x) (realpart y))
+			   (,op (imagpart x) (imagpart y))))
+       (((foreach bignum fixnum ratio single-float double-float
+		  #!+long-float long-float) complex)
+	(complex (,op x (realpart y)) (,op (imagpart y))))
+       ((complex (or rational float))
+	(complex (,op (realpart x) y) (imagpart x)))
+
+       (((foreach fixnum bignum) ratio)
+	(let* ((dy (denominator y))
+	       (n (,op (* x dy) (numerator y))))
+	  (%make-ratio n dy)))
+       ((ratio integer)
+	(let* ((dx (denominator x))
+	       (n (,op (numerator x) (* y dx))))
+	  (%make-ratio n dx)))
+       ((ratio ratio)
+	(let* ((nx (numerator x))
+	       (dx (denominator x))
+	       (ny (numerator y))
+	       (dy (denominator y))
+	       (g1 (gcd dx dy)))
+	  (if (eql g1 1)
+	      (%make-ratio (,op (* nx dy) (* dx ny)) (* dx dy))
+	      (let* ((t1 (,op (* nx (truncate dy g1)) (* (truncate dx g1) ny)))
+		     (g2 (gcd t1 g1))
+		     (t2 (truncate dx g1)))
+		(cond ((eql t1 0) 0)
+		      ((eql g2 1)
+		       (%make-ratio t1 (* t2 dy)))
+		      (T (let* ((nn (truncate t1 g2))
+				(t3 (truncate dy g2))
+				(nd (if (eql t2 1) t3 (* t2 t3))))
+			   (if (eql nd 1) nn (%make-ratio nn nd))))))))))))
+
+); Eval-When (Compile)
+
+(two-arg-+/- two-arg-+ + add-bignums)
+(two-arg-+/- two-arg-- - subtract-bignum)
+
+(defun two-arg-* (x y)
+  (flet ((integer*ratio (x y)
+	   (if (eql x 0) 0
+	       (let* ((ny (numerator y))
+		      (dy (denominator y))
+		      (gcd (gcd x dy)))
+		 (if (eql gcd 1)
+		     (%make-ratio (* x ny) dy)
+		     (let ((nn (* (truncate x gcd) ny))
+			   (nd (truncate dy gcd)))
+		       (if (eql nd 1)
+			   nn
+			   (%make-ratio nn nd)))))))
+	 (complex*real (x y)
+	   (canonical-complex (* (realpart x) y) (* (imagpart x) y))))
+    (number-dispatch ((x number) (y number))
+      (float-contagion * x y)
+
+      ((fixnum fixnum) (multiply-fixnums x y))
+      ((bignum fixnum) (multiply-bignum-and-fixnum x y))
+      ((fixnum bignum) (multiply-bignum-and-fixnum y x))
+      ((bignum bignum) (multiply-bignums x y))
+
+      ((complex complex)
+       (let* ((rx (realpart x))
+	      (ix (imagpart x))
+	      (ry (realpart y))
+	      (iy (imagpart y)))
+	 (canonical-complex (- (* rx ry) (* ix iy)) (+ (* rx iy) (* ix ry)))))
+      (((foreach bignum fixnum ratio single-float double-float
+		 #!+long-float long-float)
+	complex)
+       (complex*real y x))
+      ((complex (or rational float))
+       (complex*real x y))
+
+      (((foreach bignum fixnum) ratio) (integer*ratio x y))
+      ((ratio integer) (integer*ratio y x))
+      ((ratio ratio)
+       (let* ((nx (numerator x))
+	      (dx (denominator x))
+	      (ny (numerator y))
+	      (dy (denominator y))
+	      (g1 (gcd nx dy))
+	      (g2 (gcd dx ny)))
+	 (build-ratio (* (maybe-truncate nx g1)
+			 (maybe-truncate ny g2))
+		      (* (maybe-truncate dx g2)
+			 (maybe-truncate dy g1))))))))
+
+;;; Divide two integers, producing a canonical rational. If a fixnum,
+;;; we see whether they divide evenly before trying the GCD. In the
+;;; bignum case, we don't bother, since bignum division is expensive,
+;;; and the test is not very likely to succeed.
+(defun integer-/-integer (x y)
+  (if (and (typep x 'fixnum) (typep y 'fixnum))
+      (multiple-value-bind (quo rem) (truncate x y)
+	(if (zerop rem)
+	    quo
+	    (let ((gcd (gcd x y)))
+	      (declare (fixnum gcd))
+	      (if (eql gcd 1)
+		  (build-ratio x y)
+		  (build-ratio (truncate x gcd) (truncate y gcd))))))
+      (let ((gcd (gcd x y)))
+	(if (eql gcd 1)
+	    (build-ratio x y)
+	    (build-ratio (truncate x gcd) (truncate y gcd))))))
+
+(defun two-arg-/ (x y)
+  (number-dispatch ((x number) (y number))
+    (float-contagion / x y (ratio integer))
+
+    ((complex complex)
+     (let* ((rx (realpart x))
+	    (ix (imagpart x))
+	    (ry (realpart y))
+	    (iy (imagpart y)))
+       (if (> (abs ry) (abs iy))
+	   (let* ((r (/ iy ry))
+		  (dn (* ry (+ 1 (* r r)))))
+	     (canonical-complex (/ (+ rx (* ix r)) dn)
+				(/ (- ix (* rx r)) dn)))
+	   (let* ((r (/ ry iy))
+		  (dn (* iy (+ 1 (* r r)))))
+	     (canonical-complex (/ (+ (* rx r) ix) dn)
+				(/ (- (* ix r) rx) dn))))))
+    (((foreach integer ratio single-float double-float) complex)
+     (let* ((ry (realpart y))
+	    (iy (imagpart y)))
+       (if (> (abs ry) (abs iy))
+	   (let* ((r (/ iy ry))
+		  (dn (* ry (+ 1 (* r r)))))
+	     (canonical-complex (/ x dn)
+				(/ (- (* x r)) dn)))
+	   (let* ((r (/ ry iy))
+		  (dn (* iy (+ 1 (* r r)))))
+	     (canonical-complex (/ (* x r) dn)
+				(/ (- x) dn))))))
+    ((complex (or rational float))
+     (canonical-complex (/ (realpart x) y)
+			(/ (imagpart x) y)))
+
+    ((ratio ratio)
+     (let* ((nx (numerator x))
+	    (dx (denominator x))
+	    (ny (numerator y))
+	    (dy (denominator y))
+	    (g1 (gcd nx ny))
+	    (g2 (gcd dx dy)))
+       (build-ratio (* (maybe-truncate nx g1) (maybe-truncate dy g2))
+		    (* (maybe-truncate dx g2) (maybe-truncate ny g1)))))
+
+    ((integer integer)
+     (integer-/-integer x y))
+
+    ((integer ratio)
+     (if (zerop x)
+	 0
+	 (let* ((ny (numerator y))
+		(dy (denominator y))
+		(gcd (gcd x ny)))
+	   (build-ratio (* (maybe-truncate x gcd) dy)
+			(maybe-truncate ny gcd)))))
+
+    ((ratio integer)
+     (let* ((nx (numerator x))
+	    (gcd (gcd nx y)))
+       (build-ratio (maybe-truncate nx gcd)
+		    (* (maybe-truncate y gcd) (denominator x)))))))
+
+(defun %negate (n)
+  (number-dispatch ((n number))
+    (((foreach fixnum single-float double-float #!+long-float long-float))
+     (%negate n))
+    ((bignum)
+     (negate-bignum n))
+    ((ratio)
+     (%make-ratio (- (numerator n)) (denominator n)))
+    ((complex)
+     (complex (- (realpart n)) (- (imagpart n))))))
+
+;;;; TRUNCATE and friends
+
+(defun truncate (number &optional (divisor 1))
+  #!+sb-doc
+  "Returns number (or number/divisor) as an integer, rounded toward 0.
+  The second returned value is the remainder."
+  (macrolet ((truncate-float (rtype)
+	       `(let* ((float-div (coerce divisor ',rtype))
+		       (res (%unary-truncate (/ number float-div))))
+		  (values res
+			  (- number
+			     (* (coerce res ',rtype) float-div))))))
+    (number-dispatch ((number real) (divisor real))
+      ((fixnum fixnum) (truncate number divisor))
+      (((foreach fixnum bignum) ratio)
+       (let ((q (truncate (* number (denominator divisor))
+			  (numerator divisor))))
+	 (values q (- number (* q divisor)))))
+      ((fixnum bignum)
+       (values 0 number))
+      ((ratio (or float rational))
+       (let ((q (truncate (numerator number)
+			  (* (denominator number) divisor))))
+	 (values q (- number (* q divisor)))))
+      ((bignum fixnum)
+       (bignum-truncate number (make-small-bignum divisor)))
+      ((bignum bignum)
+       (bignum-truncate number divisor))
+
+      (((foreach single-float double-float #!+long-float long-float)
+	(or rational single-float))
+       (if (eql divisor 1)
+	   (let ((res (%unary-truncate number)))
+	     (values res (- number (coerce res '(dispatch-type number)))))
+	   (truncate-float (dispatch-type number))))
+      #!+long-float
+      ((long-float (or single-float double-float long-float))
+       (truncate-float long-float))
+      #!+long-float
+      (((foreach double-float single-float) long-float)
+       (truncate-float long-float))
+      ((double-float (or single-float double-float))
+       (truncate-float double-float))
+      ((single-float double-float)
+       (truncate-float double-float))
+      (((foreach fixnum bignum ratio)
+	(foreach single-float double-float #!+long-float long-float))
+       (truncate-float (dispatch-type divisor))))))
+
+;;; Declare these guys inline to let them get optimized a little.
+;;; ROUND and FROUND are not declared inline since they seem too
+;;; obscure and too big to inline-expand by default. Also, this gives
+;;; the compiler a chance to pick off the unary float case. Similarly,
+;;; CEILING and FLOOR are only maybe-inline for now, so that the
+;;; power-of-2 CEILING and FLOOR transforms get a chance.
+#!-sb-fluid (declaim (inline rem mod fceiling ffloor ftruncate))
+(declaim (maybe-inline ceiling floor))
+
+(defun floor (number &optional (divisor 1))
+  #!+sb-doc
+  "Returns the greatest integer not greater than number, or number/divisor.
+  The second returned value is (mod number divisor)."
+  ;; If the numbers do not divide exactly and the result of
+  ;; (/ NUMBER DIVISOR) would be negative then decrement the quotient
+  ;; and augment the remainder by the divisor.
+  (multiple-value-bind (tru rem) (truncate number divisor)
+    (if (and (not (zerop rem))
+	     (if (minusp divisor)
+		 (plusp number)
+		 (minusp number)))
+	(values (1- tru) (+ rem divisor))
+	(values tru rem))))
+
+(defun ceiling (number &optional (divisor 1))
+  #!+sb-doc
+  "Returns the smallest integer not less than number, or number/divisor.
+  The second returned value is the remainder."
+  ;; If the numbers do not divide exactly and the result of
+  ;; (/ NUMBER DIVISOR) would be positive then increment the quotient
+  ;; and decrement the remainder by the divisor.
+  (multiple-value-bind (tru rem) (truncate number divisor)
+    (if (and (not (zerop rem))
+	     (if (minusp divisor)
+		 (minusp number)
+		 (plusp number)))
+	(values (+ tru 1) (- rem divisor))
+	(values tru rem))))
+
+(defun round (number &optional (divisor 1))
+  #!+sb-doc
+  "Rounds number (or number/divisor) to nearest integer.
+  The second returned value is the remainder."
+  (if (eql divisor 1)
+      (round number)
+      (multiple-value-bind (tru rem) (truncate number divisor)
+	(let ((thresh (/ (abs divisor) 2)))
+	  (cond ((or (> rem thresh)
+		     (and (= rem thresh) (oddp tru)))
+		 (if (minusp divisor)
+		     (values (- tru 1) (+ rem divisor))
+		     (values (+ tru 1) (- rem divisor))))
+		((let ((-thresh (- thresh)))
+		   (or (< rem -thresh)
+		       (and (= rem -thresh) (oddp tru))))
+		 (if (minusp divisor)
+		     (values (+ tru 1) (- rem divisor))
+		     (values (- tru 1) (+ rem divisor))))
+		(t (values tru rem)))))))
+
+(defun rem (number divisor)
+  #!+sb-doc
+  "Returns second result of TRUNCATE."
+  (multiple-value-bind (tru rem) (truncate number divisor)
+    (declare (ignore tru))
+    rem))
+
+(defun mod (number divisor)
+  #!+sb-doc
+  "Returns second result of FLOOR."
+  (let ((rem (rem number divisor)))
+    (if (and (not (zerop rem))
+	     (if (minusp divisor)
+		 (plusp number)
+		 (minusp number)))
+	(+ rem divisor)
+	rem)))
+
+(macrolet ((def-frob (name op doc)
+	     `(defun ,name (number &optional (divisor 1))
+		,doc
+		(multiple-value-bind (res rem) (,op number divisor)
+		  (values (float res (if (floatp rem) rem 1.0)) rem)))))
+  (def-frob ffloor floor
+    "Same as FLOOR, but returns first value as a float.")
+  (def-frob fceiling ceiling
+    "Same as CEILING, but returns first value as a float." )
+  (def-frob ftruncate truncate
+    "Same as TRUNCATE, but returns first value as a float.")
+  (def-frob fround round
+    "Same as ROUND, but returns first value as a float."))
+
+;;;; comparisons
+
+(defun = (number &rest more-numbers)
+  #!+sb-doc
+  "Returns T if all of its arguments are numerically equal, NIL otherwise."
+  (do ((nlist more-numbers (cdr nlist)))
+      ((atom nlist) T)
+     (declare (list nlist))
+     (if (not (= (car nlist) number)) (return nil))))
+
+(defun /= (number &rest more-numbers)
+  #!+sb-doc
+  "Returns T if no two of its arguments are numerically equal, NIL otherwise."
+  (do* ((head number (car nlist))
+	(nlist more-numbers (cdr nlist)))
+       ((atom nlist) t)
+     (declare (list nlist))
+     (unless (do* ((nl nlist (cdr nl)))
+		  ((atom nl) T)
+	       (declare (list nl))
+	       (if (= head (car nl)) (return nil)))
+       (return nil))))
+
+(defun < (number &rest more-numbers)
+  #!+sb-doc
+  "Returns T if its arguments are in strictly increasing order, NIL otherwise."
+  (do* ((n number (car nlist))
+	(nlist more-numbers (cdr nlist)))
+       ((atom nlist) t)
+     (declare (list nlist))
+     (if (not (< n (car nlist))) (return nil))))
+
+(defun > (number &rest more-numbers)
+  #!+sb-doc
+  "Returns T if its arguments are in strictly decreasing order, NIL otherwise."
+  (do* ((n number (car nlist))
+	(nlist more-numbers (cdr nlist)))
+       ((atom nlist) t)
+     (declare (list nlist))
+     (if (not (> n (car nlist))) (return nil))))
+
+(defun <= (number &rest more-numbers)
+  #!+sb-doc
+  "Returns T if arguments are in strictly non-decreasing order, NIL otherwise."
+  (do* ((n number (car nlist))
+	(nlist more-numbers (cdr nlist)))
+       ((atom nlist) t)
+     (declare (list nlist))
+     (if (not (<= n (car nlist))) (return nil))))
+
+(defun >= (number &rest more-numbers)
+  #!+sb-doc
+  "Returns T if arguments are in strictly non-increasing order, NIL otherwise."
+  (do* ((n number (car nlist))
+	(nlist more-numbers (cdr nlist)))
+       ((atom nlist) t)
+     (declare (list nlist))
+     (if (not (>= n (car nlist))) (return nil))))
+
+(defun max (number &rest more-numbers)
+  #!+sb-doc
+  "Returns the greatest of its arguments."
+  (do ((nlist more-numbers (cdr nlist))
+       (result number))
+      ((null nlist) (return result))
+     (declare (list nlist))
+     (if (> (car nlist) result) (setq result (car nlist)))))
+
+(defun min (number &rest more-numbers)
+  #!+sb-doc
+  "Returns the least of its arguments."
+  (do ((nlist more-numbers (cdr nlist))
+       (result number))
+      ((null nlist) (return result))
+     (declare (list nlist))
+     (if (< (car nlist) result) (setq result (car nlist)))))
+
+(eval-when (:compile-toplevel :execute)
+
+;;; The INFINITE-X-FINITE-Y and INFINITE-Y-FINITE-X args tell us how
+;;; to handle the case when X or Y is a floating-point infinity and
+;;; the other arg is a rational. (Section 12.1.4.1 of the ANSI spec
+;;; says that comparisons are done by converting the float to a
+;;; rational when comparing with a rational, but infinities can't be
+;;; converted to a rational, so we show some initiative and do it this
+;;; way instead.)
+(defun basic-compare (op &key infinite-x-finite-y infinite-y-finite-x)
+  `(((fixnum fixnum) (,op x y))
+
+    ((single-float single-float) (,op x y))
+    #!+long-float
+    (((foreach single-float double-float long-float) long-float)
+     (,op (coerce x 'long-float) y))
+    #!+long-float
+    ((long-float (foreach single-float double-float))
+     (,op x (coerce y 'long-float)))
+    (((foreach single-float double-float) double-float)
+     (,op (coerce x 'double-float) y))
+    ((double-float single-float)
+     (,op x (coerce y 'double-float)))
+    (((foreach single-float double-float #!+long-float long-float) rational)
+     (if (eql y 0)
+	 (,op x (coerce 0 '(dispatch-type x)))
+	 (if (float-infinity-p x)
+	     ,infinite-x-finite-y
+	     (,op (rational x) y))))
+    (((foreach bignum fixnum ratio) float)
+     (if (float-infinity-p y)
+	 ,infinite-y-finite-x
+	 (,op x (rational y))))))
+) ; EVAL-WHEN
+
+(macrolet ((def-two-arg-</> (name op ratio-arg1 ratio-arg2 &rest cases)
+             `(defun ,name (x y)
+		(number-dispatch ((x real) (y real))
+				 (basic-compare
+				  ,op
+				  :infinite-x-finite-y
+				  (,op x (coerce 0 '(dispatch-type x)))
+				  :infinite-y-finite-x
+				  (,op (coerce 0 '(dispatch-type y)) y))
+				 (((foreach fixnum bignum) ratio)
+				  (,op x (,ratio-arg2 (numerator y)
+						      (denominator y))))
+				 ((ratio integer)
+				  (,op (,ratio-arg1 (numerator x)
+						    (denominator x))
+				       y))
+				 ((ratio ratio)
+				  (,op (* (numerator   (truly-the ratio x))
+					  (denominator (truly-the ratio y)))
+				       (* (numerator   (truly-the ratio y))
+					  (denominator (truly-the ratio x)))))
+				 ,@cases))))
+  (def-two-arg-</> two-arg-< < floor ceiling
+    ((fixnum bignum)
+     (bignum-plus-p y))
+    ((bignum fixnum)
+     (not (bignum-plus-p x)))
+    ((bignum bignum)
+     (minusp (bignum-compare x y))))
+  (def-two-arg-</> two-arg-> > ceiling floor
+    ((fixnum bignum)
+     (not (bignum-plus-p y)))
+    ((bignum fixnum)
+     (bignum-plus-p x))
+    ((bignum bignum)
+     (plusp (bignum-compare x y)))))
+
+(defun two-arg-= (x y)
+  (number-dispatch ((x number) (y number))
+    (basic-compare =
+		   ;; An infinite value is never equal to a finite value.
+		   :infinite-x-finite-y nil
+		   :infinite-y-finite-x nil)
+    ((fixnum (or bignum ratio)) nil)
+
+    ((bignum (or fixnum ratio)) nil)
+    ((bignum bignum)
+     (zerop (bignum-compare x y)))
+
+    ((ratio integer) nil)
+    ((ratio ratio)
+     (and (eql (numerator x) (numerator y))
+	  (eql (denominator x) (denominator y))))
+
+    ((complex complex)
+     (and (= (realpart x) (realpart y))
+	  (= (imagpart x) (imagpart y))))
+    (((foreach fixnum bignum ratio single-float double-float
+	       #!+long-float long-float) complex)
+     (and (= x (realpart y))
+	  (zerop (imagpart y))))
+    ((complex (or float rational))
+     (and (= (realpart x) y)
+	  (zerop (imagpart x))))))
+
+(defun eql (obj1 obj2)
+  #!+sb-doc
+  "Return T if OBJ1 and OBJ2 represent the same object, otherwise NIL."
+  (or (eq obj1 obj2)
+      (if (or (typep obj2 'fixnum)
+	      (not (typep obj2 'number)))
+	  nil
+	  (macrolet ((foo (&rest stuff)
+		       `(typecase obj2
+			  ,@(mapcar #'(lambda (foo)
+					(let ((type (car foo))
+					      (fn (cadr foo)))
+					  `(,type
+					    (and (typep obj1 ',type)
+						 (,fn obj1 obj2)))))
+				    stuff))))
+	    (foo
+	      (single-float eql)
+	      (double-float eql)
+	      #!+long-float
+	      (long-float eql)
+	      (bignum
+	       (lambda (x y)
+		 (zerop (bignum-compare x y))))
+	      (ratio
+	       (lambda (x y)
+		 (and (eql (numerator x) (numerator y))
+		      (eql (denominator x) (denominator y)))))
+	      (complex
+	       (lambda (x y)
+		 (and (eql (realpart x) (realpart y))
+		      (eql (imagpart x) (imagpart y))))))))))
+
+;;;; logicals
+
+(defun logior (&rest integers)
+  #!+sb-doc
+  "Returns the bit-wise or of its arguments. Args must be integers."
+  (declare (list integers))
+  (if integers
+      (do ((result (pop integers) (logior result (pop integers))))
+	  ((null integers) result))
+      0))
+
+(defun logxor (&rest integers)
+  #!+sb-doc
+  "Returns the bit-wise exclusive or of its arguments. Args must be integers."
+  (declare (list integers))
+  (if integers
+      (do ((result (pop integers) (logxor result (pop integers))))
+	  ((null integers) result))
+      0))
+
+(defun logand (&rest integers)
+  #!+sb-doc
+  "Returns the bit-wise and of its arguments. Args must be integers."
+  (declare (list integers))
+  (if integers
+      (do ((result (pop integers) (logand result (pop integers))))
+	  ((null integers) result))
+      -1))
+
+(defun logeqv (&rest integers)
+  #!+sb-doc
+  "Returns the bit-wise equivalence of its arguments. Args must be integers."
+  (declare (list integers))
+  (if integers
+      (do ((result (pop integers) (logeqv result (pop integers))))
+	  ((null integers) result))
+      -1))
+
+(defun lognand (integer1 integer2)
+  #!+sb-doc
+  "Returns the complement of the logical AND of integer1 and integer2."
+  (lognand integer1 integer2))
+
+(defun lognor (integer1 integer2)
+  #!+sb-doc
+  "Returns the complement of the logical OR of integer1 and integer2."
+  (lognor integer1 integer2))
+
+(defun logandc1 (integer1 integer2)
+  #!+sb-doc
+  "Returns the logical AND of (LOGNOT integer1) and integer2."
+  (logandc1 integer1 integer2))
+
+(defun logandc2 (integer1 integer2)
+  #!+sb-doc
+  "Returns the logical AND of integer1 and (LOGNOT integer2)."
+  (logandc2 integer1 integer2))
+
+(defun logorc1 (integer1 integer2)
+  #!+sb-doc
+  "Returns the logical OR of (LOGNOT integer1) and integer2."
+  (logorc1 integer1 integer2))
+
+(defun logorc2 (integer1 integer2)
+  #!+sb-doc
+  "Returns the logical OR of integer1 and (LOGNOT integer2)."
+  (logorc2 integer1 integer2))
+
+(defun lognot (number)
+  #!+sb-doc
+  "Returns the bit-wise logical not of integer."
+  (etypecase number
+    (fixnum (lognot (truly-the fixnum number)))
+    (bignum (bignum-logical-not number))))
+
+(macrolet ((def-frob (name op big-op)
+	     `(defun ,name (x y)
+	       (number-dispatch ((x integer) (y integer))
+		 (bignum-cross-fixnum ,op ,big-op)))))
+  (def-frob two-arg-and logand bignum-logical-and)
+  (def-frob two-arg-ior logior bignum-logical-ior)
+  (def-frob two-arg-xor logxor bignum-logical-xor))
+
+(defun logcount (integer)
+  #!+sb-doc
+  "Count the number of 1 bits if INTEGER is positive, and the number of 0 bits
+  if INTEGER is negative."
+  (etypecase integer
+    (fixnum
+     (logcount (truly-the (integer 0 #.(max most-positive-fixnum
+					    (lognot most-negative-fixnum)))
+			  (if (minusp (truly-the fixnum integer))
+			      (lognot (truly-the fixnum integer))
+			      integer))))
+    (bignum
+     (bignum-logcount integer))))
+
+(defun logtest (integer1 integer2)
+  #!+sb-doc
+  "Predicate which returns T if logand of integer1 and integer2 is not zero."
+  (logtest integer1 integer2))
+
+(defun logbitp (index integer)
+  #!+sb-doc
+  "Predicate returns T if bit index of integer is a 1."
+  (logbitp index integer))
+
+(defun ash (integer count)
+  #!+sb-doc
+  "Shifts integer left by count places preserving sign. - count shifts right."
+  (declare (integer integer count))
+  (etypecase integer
+    (fixnum
+     (cond ((zerop integer)
+	    0)
+	   ((fixnump count)
+	    (let ((length (integer-length (truly-the fixnum integer)))
+		  (count (truly-the fixnum count)))
+	      (declare (fixnum length count))
+	      (cond ((and (plusp count)
+			  (> (+ length count)
+			     (integer-length most-positive-fixnum)))
+		     (bignum-ashift-left (make-small-bignum integer) count))
+		    (t
+		     (truly-the fixnum
+				(ash (truly-the fixnum integer) count))))))
+	   ((minusp count)
+	    (if (minusp integer) -1 0))
+	   (t
+	    (bignum-ashift-left (make-small-bignum integer) count))))
+    (bignum
+     (if (plusp count)
+	 (bignum-ashift-left integer count)
+	 (bignum-ashift-right integer (- count))))))
+
+(defun integer-length (integer)
+  #!+sb-doc
+  "Returns the number of significant bits in the absolute value of integer."
+  (etypecase integer
+    (fixnum
+     (integer-length (truly-the fixnum integer)))
+    (bignum
+     (bignum-integer-length integer))))
+
+;;;; BYTE, bytespecs, and related operations
+
+(defun byte (size position)
+  #!+sb-doc
+  "Returns a byte specifier which may be used by other byte functions."
+  (byte size position))
+
+(defun byte-size (bytespec)
+  #!+sb-doc
+  "Returns the size part of the byte specifier bytespec."
+  (byte-size bytespec))
+
+(defun byte-position (bytespec)
+  #!+sb-doc
+  "Returns the position part of the byte specifier bytespec."
+  (byte-position bytespec))
+
+(defun ldb (bytespec integer)
+  #!+sb-doc
+  "Extract the specified byte from integer, and right justify result."
+  (ldb bytespec integer))
+
+(defun ldb-test (bytespec integer)
+  #!+sb-doc
+  "Returns T if any of the specified bits in integer are 1's."
+  (ldb-test bytespec integer))
+
+(defun mask-field (bytespec integer)
+  #!+sb-doc
+  "Extract the specified byte from integer,  but do not right justify result."
+  (mask-field bytespec integer))
+
+(defun dpb (newbyte bytespec integer)
+  #!+sb-doc
+  "Returns new integer with newbyte in specified position, newbyte is right justified."
+  (dpb newbyte bytespec integer))
+
+(defun deposit-field (newbyte bytespec integer)
+  #!+sb-doc
+  "Returns new integer with newbyte in specified position, newbyte is not right justified."
+  (deposit-field newbyte bytespec integer))
+
+(defun %ldb (size posn integer)
+  (logand (ash integer (- posn))
+	  (1- (ash 1 size))))
+
+(defun %mask-field (size posn integer)
+  (logand integer (ash (1- (ash 1 size)) posn)))
+
+(defun %dpb (newbyte size posn integer)
+  (let ((mask (1- (ash 1 size))))
+    (logior (logand integer (lognot (ash mask posn)))
+	    (ash (logand newbyte mask) posn))))
+
+(defun %deposit-field (newbyte size posn integer)
+  (let ((mask (ash (ldb (byte size 0) -1) posn)))
+    (logior (logand newbyte mask)
+	    (logand integer (lognot mask)))))
+
+;;;; BOOLE
+
+;;; The boole function dispaches to any logic operation depending on
+;;;     the value of a variable. Presently, legal selector values are [0..15].
+;;;     boole is open coded for calls with a constant selector. or with calls
+;;;     using any of the constants declared below.
+
+(defconstant boole-clr 0
+  #!+sb-doc
+  "Boole function op, makes BOOLE return 0.")
+
+(defconstant boole-set 1
+  #!+sb-doc
+  "Boole function op, makes BOOLE return -1.")
+
+(defconstant boole-1   2
+  #!+sb-doc
+  "Boole function op, makes BOOLE return integer1.")
+
+(defconstant boole-2   3
+  #!+sb-doc
+  "Boole function op, makes BOOLE return integer2.")
+
+(defconstant boole-c1  4
+  #!+sb-doc
+  "Boole function op, makes BOOLE return complement of integer1.")
+
+(defconstant boole-c2  5
+  #!+sb-doc
+  "Boole function op, makes BOOLE return complement of integer2.")
+
+(defconstant boole-and 6
+  #!+sb-doc
+  "Boole function op, makes BOOLE return logand of integer1 and integer2.")
+
+(defconstant boole-ior 7
+  #!+sb-doc
+  "Boole function op, makes BOOLE return logior of integer1 and integer2.")
+
+(defconstant boole-xor 8
+  #!+sb-doc
+  "Boole function op, makes BOOLE return logxor of integer1 and integer2.")
+
+(defconstant boole-eqv 9
+  #!+sb-doc
+  "Boole function op, makes BOOLE return logeqv of integer1 and integer2.")
+
+(defconstant boole-nand  10
+  #!+sb-doc
+  "Boole function op, makes BOOLE return log nand of integer1 and integer2.")
+
+(defconstant boole-nor   11
+  #!+sb-doc
+  "Boole function op, makes BOOLE return lognor of integer1 and integer2.")
+
+(defconstant boole-andc1 12
+  #!+sb-doc
+  "Boole function op, makes BOOLE return logandc1 of integer1 and integer2.")
+
+(defconstant boole-andc2 13
+  #!+sb-doc
+  "Boole function op, makes BOOLE return logandc2 of integer1 and integer2.")
+
+(defconstant boole-orc1  14
+  #!+sb-doc
+  "Boole function op, makes BOOLE return logorc1 of integer1 and integer2.")
+
+(defconstant boole-orc2  15
+  #!+sb-doc
+  "Boole function op, makes BOOLE return logorc2 of integer1 and integer2.")
+
+(defun boole (op integer1 integer2)
+  #!+sb-doc
+  "Bit-wise boolean function on two integers. Function chosen by OP:
+	0	BOOLE-CLR
+	1	BOOLE-SET
+	2	BOOLE-1
+  	3	BOOLE-2
+	4	BOOLE-C1
+	5	BOOLE-C2
+	6	BOOLE-AND
+	7	BOOLE-IOR
+ 	8	BOOLE-XOR
+	9	BOOLE-EQV
+	10	BOOLE-NAND
+	11	BOOLE-NOR
+	12	BOOLE-ANDC1
+	13	BOOLE-ANDC2
+	14	BOOLE-ORC1
+	15	BOOLE-ORC2"
+  (case op
+    (0 (boole 0 integer1 integer2))
+    (1 (boole 1 integer1 integer2))
+    (2 (boole 2 integer1 integer2))
+    (3 (boole 3 integer1 integer2))
+    (4 (boole 4 integer1 integer2))
+    (5 (boole 5 integer1 integer2))
+    (6 (boole 6 integer1 integer2))
+    (7 (boole 7 integer1 integer2))
+    (8 (boole 8 integer1 integer2))
+    (9 (boole 9 integer1 integer2))
+    (10 (boole 10 integer1 integer2))
+    (11 (boole 11 integer1 integer2))
+    (12 (boole 12 integer1 integer2))
+    (13 (boole 13 integer1 integer2))
+    (14 (boole 14 integer1 integer2))
+    (15 (boole 15 integer1 integer2))
+    (t (error "~S is not of type (mod 16)." op))))
+
+;;;; GCD and LCM
+
+(defun gcd (&rest numbers)
+  #!+sb-doc
+  "Returns the greatest common divisor of the arguments, which must be
+  integers. Gcd with no arguments is defined to be 0."
+  (cond ((null numbers) 0)
+	((null (cdr numbers)) (abs (the integer (car numbers))))
+	(t
+	 (do ((gcd (the integer (car numbers))
+		   (gcd gcd (the integer (car rest))))
+	      (rest (cdr numbers) (cdr rest)))
+	     ((null rest) gcd)
+	   (declare (integer gcd)
+		    (list rest))))))
+
+(defun lcm (&rest numbers)
+  #!+sb-doc
+  "Returns the least common multiple of one or more integers. LCM of no
+  arguments is defined to be 1."
+  (cond ((null numbers) 1)
+	((null (cdr numbers)) (abs (the integer (car numbers))))
+	(t
+	 (do ((lcm (the integer (car numbers))
+		   (lcm lcm (the integer (car rest))))
+	      (rest (cdr numbers) (cdr rest)))
+	     ((null rest) lcm)
+	   (declare (integer lcm) (list rest))))))
+
+(defun two-arg-lcm (n m)
+  (declare (integer n m))
+  (* (truncate (max n m) (gcd n m)) (min n m)))
+
+;;; Do the GCD of two integer arguments. With fixnum arguments, we use the
+;;; binary GCD algorithm from Knuth's seminumerical algorithms (slightly
+;;; structurified), otherwise we call BIGNUM-GCD. We pick off the special case
+;;; of 0 before the dispatch so that the bignum code doesn't have to worry
+;;; about "small bignum" zeros.
+(defun two-arg-gcd (u v)
+  (cond ((eql u 0) v)
+	((eql v 0) u)
+	(t
+	 (number-dispatch ((u integer) (v integer))
+	   ((fixnum fixnum)
+	    (locally
+	      (declare (optimize (speed 3) (safety 0)))
+	      (do ((k 0 (1+ k))
+		   (u (abs u) (ash u -1))
+		   (v (abs v) (ash v -1)))
+		  ((oddp (logior u v))
+		   (do ((temp (if (oddp u) (- v) (ash u -1))
+			      (ash temp -1)))
+		       (nil)
+		     (declare (fixnum temp))
+		     (when (oddp temp)
+		       (if (plusp temp)
+			   (setq u temp)
+			   (setq v (- temp)))
+		       (setq temp (- u v))
+		       (when (zerop temp)
+			 (let ((res (ash u k)))
+			   (declare (type (signed-byte 31) res)
+				    (optimize (inhibit-warnings 3)))
+			   (return res))))))
+		(declare (type (mod 30) k)
+			 (type (signed-byte 31) u v)))))
+	   ((bignum bignum)
+	    (bignum-gcd u v))
+	   ((bignum fixnum)
+	    (bignum-gcd u (make-small-bignum v)))
+	   ((fixnum bignum)
+	    (bignum-gcd (make-small-bignum u) v))))))
+
+;;; From discussion on comp.lang.lisp and Akira Kurihara.
+(defun isqrt (n)
+  #!+sb-doc
+  "Returns the root of the nearest integer less than n which is a perfect
+   square."
+  (declare (type unsigned-byte n) (values unsigned-byte))
+  ;; Theoretically (> n 7), i.e., n-len-quarter > 0.
+  (if (and (fixnump n) (<= n 24))
+      (cond ((> n 15) 4)
+	    ((> n  8) 3)
+	    ((> n  3) 2)
+	    ((> n  0) 1)
+	    (t 0))
+      (let* ((n-len-quarter (ash (integer-length n) -2))
+	     (n-half (ash n (- (ash n-len-quarter 1))))
+	     (n-half-isqrt (isqrt n-half))
+	     (init-value (ash (1+ n-half-isqrt) n-len-quarter)))
+	(loop
+	  (let ((iterated-value
+		 (ash (+ init-value (truncate n init-value)) -1)))
+	    (unless (< iterated-value init-value)
+	      (return init-value))
+	    (setq init-value iterated-value))))))
+
+;;;; miscellaneous number predicates
+
+(macrolet ((def-frob (name doc)
+	     `(defun ,name (number) ,doc (,name number))))
+  (def-frob zerop "Returns T if number = 0, NIL otherwise.")
+  (def-frob plusp "Returns T if number > 0, NIL otherwise.")
+  (def-frob minusp "Returns T if number < 0, NIL otherwise.")
+  (def-frob oddp "Returns T if number is odd, NIL otherwise.")
+  (def-frob evenp "Returns T if number is even, NIL otherwise."))
diff --git a/src/code/pathname.lisp b/src/code/pathname.lisp
index c24892f..a430f42 100644
--- a/src/code/pathname.lisp
+++ b/src/code/pathname.lisp
@@ -25,6 +25,9 @@
   (unparse-enough (required-argument) :type function)
   (customary-case (required-argument) :type (member :upper :lower)))
 
+(def!method print-object ((host host) stream)
+  (print-unreadable-object (host stream :type t :identity t)))
+
 (def!struct (logical-host
 	     (:make-load-form-fun make-logical-host-load-form-fun)
 	     (:include host
@@ -85,12 +88,6 @@
   ;; on standard Unix filesystems)
   (version nil :type (or integer pathname-component-tokens (member :newest))))
 
-;;; Return a value suitable, e.g., for preinitializing
-;;; *DEFAULT-PATHNAME-DEFAULTS* before *DEFAULT-PATHNAME-DEFAULTS* is
-;;; initialized (at which time we can't safely call e.g. #'PATHNAME).
-(defun make-trivial-default-pathname ()
-  (%make-pathname *unix-host* nil nil nil nil :newest))
-
 ;;; Logical pathnames have the following format:
 ;;;
 ;;; logical-namestring ::=
diff --git a/src/code/target-numbers.lisp b/src/code/target-numbers.lisp
deleted file mode 100644
index aa7304a..0000000
--- a/src/code/target-numbers.lisp
+++ /dev/null
@@ -1,1323 +0,0 @@
-;;;; This file contains the definitions of most number functions.
-
-;;;; This software is part of the SBCL system. See the README file for
-;;;; more information.
-;;;;
-;;;; This software is derived from the CMU CL system, which was
-;;;; written at Carnegie Mellon University and released into the
-;;;; public domain. The software is in the public domain and is
-;;;; provided with absolutely no warranty. See the COPYING and CREDITS
-;;;; files for more information.
-
-(in-package "SB!KERNEL")
-
-;;;; the NUMBER-DISPATCH macro
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
-
-;;; Grovel an individual case to NUMBER-DISPATCH, augmenting RESULT
-;;; with the type dispatches and bodies. Result is a tree built of
-;;; alists representing the dispatching off each arg (in order). The
-;;; leaf is the body to be executed in that case.
-(defun parse-number-dispatch (vars result types var-types body)
-  (cond ((null vars)
-	 (unless (null types) (error "More types than vars."))
-	 (when (cdr result)
-	   (error "Duplicate case: ~S." body))
-	 (setf (cdr result)
-	       (sublis var-types body :test #'equal)))
-	((null types)
-	 (error "More vars than types."))
-	(t
-	 (flet ((frob (var type)
-		  (parse-number-dispatch
-		   (rest vars)
-		   (or (assoc type (cdr result) :test #'equal)
-		       (car (setf (cdr result)
-				  (acons type nil (cdr result)))))
-		   (rest types)
-		   (acons `(dispatch-type ,var) type var-types)
-		   body)))
-	   (let ((type (first types))
-		 (var (first vars)))
-	     (if (and (consp type) (eq (first type) 'foreach))
-		 (dolist (type (rest type))
-		   (frob var type))
-		 (frob var type)))))))
-
-;;; our guess for the preferred order in which to do type tests
-;;; (cheaper and/or more probable first.)
-(defparameter *type-test-ordering*
-  '(fixnum single-float double-float integer #!+long-float long-float bignum
-    complex ratio))
-
-;;; Should TYPE1 be tested before TYPE2?
-(defun type-test-order (type1 type2)
-  (let ((o1 (position type1 *type-test-ordering*))
-	(o2 (position type2 *type-test-ordering*)))
-    (cond ((not o1) nil)
-	  ((not o2) t)
-	  (t
-	   (< o1 o2)))))
-
-;;; Return an ETYPECASE form that does the type dispatch, ordering the
-;;; cases for efficiency.
-(defun generate-number-dispatch (vars error-tags cases)
-  (if vars
-      (let ((var (first vars))
-	    (cases (sort cases #'type-test-order :key #'car)))
-	`((typecase ,var
-	    ,@(mapcar #'(lambda (case)
-			  `(,(first case)
-			    ,@(generate-number-dispatch (rest vars)
-							(rest error-tags)
-							(cdr case))))
-		      cases)
-	    (t (go ,(first error-tags))))))
-      cases))
-
-) ; EVAL-WHEN
-
-;;; This is a vaguely case-like macro that does number cross-product
-;;; dispatches. The Vars are the variables we are dispatching off of.
-;;; The Type paired with each Var is used in the error message when no
-;;; case matches. Each case specifies a Type for each var, and is
-;;; executed when that signature holds. A type may be a list
-;;; (FOREACH Each-Type*), causing that case to be repeatedly
-;;; instantiated for every Each-Type. In the body of each case, any
-;;; list of the form (DISPATCH-TYPE Var-Name) is substituted with the
-;;; type of that var in that instance of the case.
-;;;
-;;; As an alternate to a case spec, there may be a form whose CAR is a
-;;; symbol. In this case, we apply the CAR of the form to the CDR and
-;;; treat the result of the call as a list of cases. This process is
-;;; not applied recursively.
-(defmacro number-dispatch (var-specs &body cases)
-  (let ((res (list nil))
-	(vars (mapcar #'car var-specs))
-	(block (gensym)))
-    (dolist (case cases)
-      (if (symbolp (first case))
-	  (let ((cases (apply (symbol-function (first case)) (rest case))))
-	    (dolist (case cases)
-	      (parse-number-dispatch vars res (first case) nil (rest case))))
-	  (parse-number-dispatch vars res (first case) nil (rest case))))
-
-    (collect ((errors)
-	      (error-tags))
-      (dolist (spec var-specs)
-	(let ((var (first spec))
-	      (type (second spec))
-	      (tag (gensym)))
-	  (error-tags tag)
-	  (errors tag)
-	  (errors `(return-from
-		    ,block
-		    (error 'simple-type-error :datum ,var
-			   :expected-type ',type
-			   :format-control
-			   "~@<Argument ~A is not a ~S: ~2I~_~S~:>"
-			   :format-arguments
-			   (list ',var ',type ,var))))))
-
-      `(block ,block
-	 (tagbody
-	   (return-from ,block
-			,@(generate-number-dispatch vars (error-tags)
-						    (cdr res)))
-	   ,@(errors))))))
-
-;;;; binary operation dispatching utilities
-
-(eval-when (:compile-toplevel :execute)
-
-;;; Return NUMBER-DISPATCH forms for rational X float.
-(defun float-contagion (op x y &optional (rat-types '(fixnum bignum ratio)))
-  `(((single-float single-float) (,op ,x ,y))
-    (((foreach ,@rat-types)
-      (foreach single-float double-float #!+long-float long-float))
-     (,op (coerce ,x '(dispatch-type ,y)) ,y))
-    (((foreach single-float double-float #!+long-float long-float)
-      (foreach ,@rat-types))
-     (,op ,x (coerce ,y '(dispatch-type ,x))))
-    #!+long-float
-    (((foreach single-float double-float long-float) long-float)
-     (,op (coerce ,x 'long-float) ,y))
-    #!+long-float
-    ((long-float (foreach single-float double-float))
-     (,op ,x (coerce ,y 'long-float)))
-    (((foreach single-float double-float) double-float)
-     (,op (coerce ,x 'double-float) ,y))
-    ((double-float single-float)
-     (,op ,x (coerce ,y 'double-float)))))
-
-;;; Return NUMBER-DISPATCH forms for bignum X fixnum.
-(defun bignum-cross-fixnum (fix-op big-op)
-  `(((fixnum fixnum) (,fix-op x y))
-    ((fixnum bignum)
-     (,big-op (make-small-bignum x) y))
-    ((bignum fixnum)
-     (,big-op x (make-small-bignum y)))
-    ((bignum bignum)
-     (,big-op x y))))
-
-) ; EVAL-WHEN
-
-;;;; canonicalization utilities
-
-;;; If IMAGPART is 0, return REALPART, otherwise make a complex. This is
-;;; used when we know that REALPART and IMAGPART are the same type, but
-;;; rational canonicalization might still need to be done.
-#!-sb-fluid (declaim (inline canonical-complex))
-(defun canonical-complex (realpart imagpart)
-  (if (eql imagpart 0)
-      realpart
-      (cond #!+long-float
-	    ((and (typep realpart 'long-float)
-		  (typep imagpart 'long-float))
-	     (truly-the (complex long-float) (complex realpart imagpart)))
-	    ((and (typep realpart 'double-float)
-		  (typep imagpart 'double-float))
-	     (truly-the (complex double-float) (complex realpart imagpart)))
-	    ((and (typep realpart 'single-float)
-		  (typep imagpart 'single-float))
-	     (truly-the (complex single-float) (complex realpart imagpart)))
-	    (t
-	     (%make-complex realpart imagpart)))))
-
-;;; Given a numerator and denominator with the GCD already divided
-;;; out, make a canonical rational. We make the denominator positive,
-;;; and check whether it is 1.
-#!-sb-fluid (declaim (inline build-ratio))
-(defun build-ratio (num den)
-  (multiple-value-bind (num den)
-      (if (minusp den)
-	  (values (- num) (- den))
-	  (values num den))
-    (if (eql den 1)
-	num
-	(%make-ratio num den))))
-
-;;; Truncate X and Y, but bum the case where Y is 1.
-#!-sb-fluid (declaim (inline maybe-truncate))
-(defun maybe-truncate (x y)
-  (if (eql y 1)
-      x
-      (truncate x y)))
-
-;;;; COMPLEXes
-
-(defun upgraded-complex-part-type (spec)
-  #!+sb-doc
-  "Returns the element type of the most specialized COMPLEX number type that
-   can hold parts of type SPEC."
-  (cond ((unknown-type-p (specifier-type spec))
-	 (error "undefined type: ~S" spec))
-	((subtypep spec 'single-float)
-	 'single-float)
-	((subtypep spec 'double-float)
-	 'double-float)
-	#!+long-float
-	((subtypep spec 'long-float)
-	 'long-float)
-	((subtypep spec 'rational)
-	 'rational)
-	(t
-	 'real)))
-
-(defun complex (realpart &optional (imagpart 0))
-  #!+sb-doc
-  "Builds a complex number from the specified components."
-  (flet ((%%make-complex (realpart imagpart)
-	   (cond #!+long-float
-		 ((and (typep realpart 'long-float)
-		       (typep imagpart 'long-float))
-		  (truly-the (complex long-float)
-			     (complex realpart imagpart)))
-		 ((and (typep realpart 'double-float)
-		       (typep imagpart 'double-float))
-		  (truly-the (complex double-float)
-			     (complex realpart imagpart)))
-		 ((and (typep realpart 'single-float)
-		       (typep imagpart 'single-float))
-		  (truly-the (complex single-float)
-			     (complex realpart imagpart)))
-		 (t
-		  (%make-complex realpart imagpart)))))
-  (number-dispatch ((realpart real) (imagpart real))
-    ((rational rational)
-     (canonical-complex realpart imagpart))
-    (float-contagion %%make-complex realpart imagpart (rational)))))
-
-(defun realpart (number)
-  #!+sb-doc
-  "Extracts the real part of a number."
-  (typecase number
-    #!+long-float
-    ((complex long-float)
-     (truly-the long-float (realpart number)))
-    ((complex double-float)
-     (truly-the double-float (realpart number)))
-    ((complex single-float)
-     (truly-the single-float (realpart number)))
-    ((complex rational)
-     (sb!kernel:%realpart number))
-    (t
-     number)))
-
-(defun imagpart (number)
-  #!+sb-doc
-  "Extracts the imaginary part of a number."
-  (typecase number
-    #!+long-float
-    ((complex long-float)
-     (truly-the long-float (imagpart number)))
-    ((complex double-float)
-     (truly-the double-float (imagpart number)))
-    ((complex single-float)
-     (truly-the single-float (imagpart number)))
-    ((complex rational)
-     (sb!kernel:%imagpart number))
-    (float
-     (float 0 number))
-    (t
-     0)))
-
-(defun conjugate (number)
-  #!+sb-doc
-  "Returns the complex conjugate of NUMBER. For non-complex numbers, this is
-  an identity."
-  (if (complexp number)
-      (complex (realpart number) (- (imagpart number)))
-      number))
-
-(defun signum (number)
-  #!+sb-doc
-  "If NUMBER is zero, return NUMBER, else return (/ NUMBER (ABS NUMBER))."
-  (if (zerop number)
-      number
-      (if (rationalp number)
-	  (if (plusp number) 1 -1)
-	  (/ number (abs number)))))
-
-;;;; ratios
-
-(defun numerator (number)
-  #!+sb-doc
-  "Return the numerator of NUMBER, which must be rational."
-  (numerator number))
-
-(defun denominator (number)
-  #!+sb-doc
-  "Return the denominator of NUMBER, which must be rational."
-  (denominator number))
-
-;;;; arithmetic operations
-
-(macrolet ((define-arith (op init doc)
-	     #!-sb-doc (declare (ignore doc))
-	     `(defun ,op (&rest args)
-		#!+sb-doc ,doc
-		(if (null args) ,init
-		  (do ((args (cdr args) (cdr args))
-		       (res (car args) (,op res (car args))))
-		      ((null args) res))))))
-  (define-arith + 0
-    "Returns the sum of its arguments. With no args, returns 0.")
-  (define-arith * 1
-    "Returns the product of its arguments. With no args, returns 1."))
-
-(defun - (number &rest more-numbers)
-  #!+sb-doc
-  "Subtracts the second and all subsequent arguments from the first.
-  With one arg, negates it."
-  (if more-numbers
-      (do ((nlist more-numbers (cdr nlist))
-	   (result number))
-	  ((atom nlist) result)
-	 (declare (list nlist))
-	 (setq result (- result (car nlist))))
-      (- number)))
-
-(defun / (number &rest more-numbers)
-  #!+sb-doc
-  "Divide the first argument by each of the following arguments, in turn.
-  With one argument, return reciprocal."
-  (if more-numbers
-      (do ((nlist more-numbers (cdr nlist))
-	   (result number))
-	  ((atom nlist) result)
-	 (declare (list nlist))
-	 (setq result (/ result (car nlist))))
-      (/ number)))
-
-(defun 1+ (number)
-  #!+sb-doc
-  "Returns NUMBER + 1."
-  (1+ number))
-
-(defun 1- (number)
-  #!+sb-doc
-  "Returns NUMBER - 1."
-  (1- number))
-
-(eval-when (:compile-toplevel)
-
-(sb!xc:defmacro two-arg-+/- (name op big-op)
-  `(defun ,name (x y)
-     (number-dispatch ((x number) (y number))
-       (bignum-cross-fixnum ,op ,big-op)
-       (float-contagion ,op x y)
-
-       ((complex complex)
-	(canonical-complex (,op (realpart x) (realpart y))
-			   (,op (imagpart x) (imagpart y))))
-       (((foreach bignum fixnum ratio single-float double-float
-		  #!+long-float long-float) complex)
-	(complex (,op x (realpart y)) (,op (imagpart y))))
-       ((complex (or rational float))
-	(complex (,op (realpart x) y) (imagpart x)))
-
-       (((foreach fixnum bignum) ratio)
-	(let* ((dy (denominator y))
-	       (n (,op (* x dy) (numerator y))))
-	  (%make-ratio n dy)))
-       ((ratio integer)
-	(let* ((dx (denominator x))
-	       (n (,op (numerator x) (* y dx))))
-	  (%make-ratio n dx)))
-       ((ratio ratio)
-	(let* ((nx (numerator x))
-	       (dx (denominator x))
-	       (ny (numerator y))
-	       (dy (denominator y))
-	       (g1 (gcd dx dy)))
-	  (if (eql g1 1)
-	      (%make-ratio (,op (* nx dy) (* dx ny)) (* dx dy))
-	      (let* ((t1 (,op (* nx (truncate dy g1)) (* (truncate dx g1) ny)))
-		     (g2 (gcd t1 g1))
-		     (t2 (truncate dx g1)))
-		(cond ((eql t1 0) 0)
-		      ((eql g2 1)
-		       (%make-ratio t1 (* t2 dy)))
-		      (T (let* ((nn (truncate t1 g2))
-				(t3 (truncate dy g2))
-				(nd (if (eql t2 1) t3 (* t2 t3))))
-			   (if (eql nd 1) nn (%make-ratio nn nd))))))))))))
-
-); Eval-When (Compile)
-
-(two-arg-+/- two-arg-+ + add-bignums)
-(two-arg-+/- two-arg-- - subtract-bignum)
-
-(defun two-arg-* (x y)
-  (flet ((integer*ratio (x y)
-	   (if (eql x 0) 0
-	       (let* ((ny (numerator y))
-		      (dy (denominator y))
-		      (gcd (gcd x dy)))
-		 (if (eql gcd 1)
-		     (%make-ratio (* x ny) dy)
-		     (let ((nn (* (truncate x gcd) ny))
-			   (nd (truncate dy gcd)))
-		       (if (eql nd 1)
-			   nn
-			   (%make-ratio nn nd)))))))
-	 (complex*real (x y)
-	   (canonical-complex (* (realpart x) y) (* (imagpart x) y))))
-    (number-dispatch ((x number) (y number))
-      (float-contagion * x y)
-
-      ((fixnum fixnum) (multiply-fixnums x y))
-      ((bignum fixnum) (multiply-bignum-and-fixnum x y))
-      ((fixnum bignum) (multiply-bignum-and-fixnum y x))
-      ((bignum bignum) (multiply-bignums x y))
-
-      ((complex complex)
-       (let* ((rx (realpart x))
-	      (ix (imagpart x))
-	      (ry (realpart y))
-	      (iy (imagpart y)))
-	 (canonical-complex (- (* rx ry) (* ix iy)) (+ (* rx iy) (* ix ry)))))
-      (((foreach bignum fixnum ratio single-float double-float
-		 #!+long-float long-float)
-	complex)
-       (complex*real y x))
-      ((complex (or rational float))
-       (complex*real x y))
-
-      (((foreach bignum fixnum) ratio) (integer*ratio x y))
-      ((ratio integer) (integer*ratio y x))
-      ((ratio ratio)
-       (let* ((nx (numerator x))
-	      (dx (denominator x))
-	      (ny (numerator y))
-	      (dy (denominator y))
-	      (g1 (gcd nx dy))
-	      (g2 (gcd dx ny)))
-	 (build-ratio (* (maybe-truncate nx g1)
-			 (maybe-truncate ny g2))
-		      (* (maybe-truncate dx g2)
-			 (maybe-truncate dy g1))))))))
-
-;;; Divide two integers, producing a canonical rational. If a fixnum,
-;;; we see whether they divide evenly before trying the GCD. In the
-;;; bignum case, we don't bother, since bignum division is expensive,
-;;; and the test is not very likely to succeed.
-(defun integer-/-integer (x y)
-  (if (and (typep x 'fixnum) (typep y 'fixnum))
-      (multiple-value-bind (quo rem) (truncate x y)
-	(if (zerop rem)
-	    quo
-	    (let ((gcd (gcd x y)))
-	      (declare (fixnum gcd))
-	      (if (eql gcd 1)
-		  (build-ratio x y)
-		  (build-ratio (truncate x gcd) (truncate y gcd))))))
-      (let ((gcd (gcd x y)))
-	(if (eql gcd 1)
-	    (build-ratio x y)
-	    (build-ratio (truncate x gcd) (truncate y gcd))))))
-
-(defun two-arg-/ (x y)
-  (number-dispatch ((x number) (y number))
-    (float-contagion / x y (ratio integer))
-
-    ((complex complex)
-     (let* ((rx (realpart x))
-	    (ix (imagpart x))
-	    (ry (realpart y))
-	    (iy (imagpart y)))
-       (if (> (abs ry) (abs iy))
-	   (let* ((r (/ iy ry))
-		  (dn (* ry (+ 1 (* r r)))))
-	     (canonical-complex (/ (+ rx (* ix r)) dn)
-				(/ (- ix (* rx r)) dn)))
-	   (let* ((r (/ ry iy))
-		  (dn (* iy (+ 1 (* r r)))))
-	     (canonical-complex (/ (+ (* rx r) ix) dn)
-				(/ (- (* ix r) rx) dn))))))
-    (((foreach integer ratio single-float double-float) complex)
-     (let* ((ry (realpart y))
-	    (iy (imagpart y)))
-       (if (> (abs ry) (abs iy))
-	   (let* ((r (/ iy ry))
-		  (dn (* ry (+ 1 (* r r)))))
-	     (canonical-complex (/ x dn)
-				(/ (- (* x r)) dn)))
-	   (let* ((r (/ ry iy))
-		  (dn (* iy (+ 1 (* r r)))))
-	     (canonical-complex (/ (* x r) dn)
-				(/ (- x) dn))))))
-    ((complex (or rational float))
-     (canonical-complex (/ (realpart x) y)
-			(/ (imagpart x) y)))
-
-    ((ratio ratio)
-     (let* ((nx (numerator x))
-	    (dx (denominator x))
-	    (ny (numerator y))
-	    (dy (denominator y))
-	    (g1 (gcd nx ny))
-	    (g2 (gcd dx dy)))
-       (build-ratio (* (maybe-truncate nx g1) (maybe-truncate dy g2))
-		    (* (maybe-truncate dx g2) (maybe-truncate ny g1)))))
-
-    ((integer integer)
-     (integer-/-integer x y))
-
-    ((integer ratio)
-     (if (zerop x)
-	 0
-	 (let* ((ny (numerator y))
-		(dy (denominator y))
-		(gcd (gcd x ny)))
-	   (build-ratio (* (maybe-truncate x gcd) dy)
-			(maybe-truncate ny gcd)))))
-
-    ((ratio integer)
-     (let* ((nx (numerator x))
-	    (gcd (gcd nx y)))
-       (build-ratio (maybe-truncate nx gcd)
-		    (* (maybe-truncate y gcd) (denominator x)))))))
-
-(defun %negate (n)
-  (number-dispatch ((n number))
-    (((foreach fixnum single-float double-float #!+long-float long-float))
-     (%negate n))
-    ((bignum)
-     (negate-bignum n))
-    ((ratio)
-     (%make-ratio (- (numerator n)) (denominator n)))
-    ((complex)
-     (complex (- (realpart n)) (- (imagpart n))))))
-
-;;;; TRUNCATE and friends
-
-(defun truncate (number &optional (divisor 1))
-  #!+sb-doc
-  "Returns number (or number/divisor) as an integer, rounded toward 0.
-  The second returned value is the remainder."
-  (macrolet ((truncate-float (rtype)
-	       `(let* ((float-div (coerce divisor ',rtype))
-		       (res (%unary-truncate (/ number float-div))))
-		  (values res
-			  (- number
-			     (* (coerce res ',rtype) float-div))))))
-    (number-dispatch ((number real) (divisor real))
-      ((fixnum fixnum) (truncate number divisor))
-      (((foreach fixnum bignum) ratio)
-       (let ((q (truncate (* number (denominator divisor))
-			  (numerator divisor))))
-	 (values q (- number (* q divisor)))))
-      ((fixnum bignum)
-       (values 0 number))
-      ((ratio (or float rational))
-       (let ((q (truncate (numerator number)
-			  (* (denominator number) divisor))))
-	 (values q (- number (* q divisor)))))
-      ((bignum fixnum)
-       (bignum-truncate number (make-small-bignum divisor)))
-      ((bignum bignum)
-       (bignum-truncate number divisor))
-
-      (((foreach single-float double-float #!+long-float long-float)
-	(or rational single-float))
-       (if (eql divisor 1)
-	   (let ((res (%unary-truncate number)))
-	     (values res (- number (coerce res '(dispatch-type number)))))
-	   (truncate-float (dispatch-type number))))
-      #!+long-float
-      ((long-float (or single-float double-float long-float))
-       (truncate-float long-float))
-      #!+long-float
-      (((foreach double-float single-float) long-float)
-       (truncate-float long-float))
-      ((double-float (or single-float double-float))
-       (truncate-float double-float))
-      ((single-float double-float)
-       (truncate-float double-float))
-      (((foreach fixnum bignum ratio)
-	(foreach single-float double-float #!+long-float long-float))
-       (truncate-float (dispatch-type divisor))))))
-
-;;; Declare these guys inline to let them get optimized a little.
-;;; ROUND and FROUND are not declared inline since they seem too
-;;; obscure and too big to inline-expand by default. Also, this gives
-;;; the compiler a chance to pick off the unary float case. Similarly,
-;;; CEILING and FLOOR are only maybe-inline for now, so that the
-;;; power-of-2 CEILING and FLOOR transforms get a chance.
-#!-sb-fluid (declaim (inline rem mod fceiling ffloor ftruncate))
-(declaim (maybe-inline ceiling floor))
-
-(defun floor (number &optional (divisor 1))
-  #!+sb-doc
-  "Returns the greatest integer not greater than number, or number/divisor.
-  The second returned value is (mod number divisor)."
-  ;; If the numbers do not divide exactly and the result of
-  ;; (/ NUMBER DIVISOR) would be negative then decrement the quotient
-  ;; and augment the remainder by the divisor.
-  (multiple-value-bind (tru rem) (truncate number divisor)
-    (if (and (not (zerop rem))
-	     (if (minusp divisor)
-		 (plusp number)
-		 (minusp number)))
-	(values (1- tru) (+ rem divisor))
-	(values tru rem))))
-
-(defun ceiling (number &optional (divisor 1))
-  #!+sb-doc
-  "Returns the smallest integer not less than number, or number/divisor.
-  The second returned value is the remainder."
-  ;; If the numbers do not divide exactly and the result of
-  ;; (/ NUMBER DIVISOR) would be positive then increment the quotient
-  ;; and decrement the remainder by the divisor.
-  (multiple-value-bind (tru rem) (truncate number divisor)
-    (if (and (not (zerop rem))
-	     (if (minusp divisor)
-		 (minusp number)
-		 (plusp number)))
-	(values (+ tru 1) (- rem divisor))
-	(values tru rem))))
-
-(defun round (number &optional (divisor 1))
-  #!+sb-doc
-  "Rounds number (or number/divisor) to nearest integer.
-  The second returned value is the remainder."
-  (if (eql divisor 1)
-      (round number)
-      (multiple-value-bind (tru rem) (truncate number divisor)
-	(let ((thresh (/ (abs divisor) 2)))
-	  (cond ((or (> rem thresh)
-		     (and (= rem thresh) (oddp tru)))
-		 (if (minusp divisor)
-		     (values (- tru 1) (+ rem divisor))
-		     (values (+ tru 1) (- rem divisor))))
-		((let ((-thresh (- thresh)))
-		   (or (< rem -thresh)
-		       (and (= rem -thresh) (oddp tru))))
-		 (if (minusp divisor)
-		     (values (+ tru 1) (- rem divisor))
-		     (values (- tru 1) (+ rem divisor))))
-		(t (values tru rem)))))))
-
-(defun rem (number divisor)
-  #!+sb-doc
-  "Returns second result of TRUNCATE."
-  (multiple-value-bind (tru rem) (truncate number divisor)
-    (declare (ignore tru))
-    rem))
-
-(defun mod (number divisor)
-  #!+sb-doc
-  "Returns second result of FLOOR."
-  (let ((rem (rem number divisor)))
-    (if (and (not (zerop rem))
-	     (if (minusp divisor)
-		 (plusp number)
-		 (minusp number)))
-	(+ rem divisor)
-	rem)))
-
-(macrolet ((def-frob (name op doc)
-	     `(defun ,name (number &optional (divisor 1))
-		,doc
-		(multiple-value-bind (res rem) (,op number divisor)
-		  (values (float res (if (floatp rem) rem 1.0)) rem)))))
-  (def-frob ffloor floor
-    "Same as FLOOR, but returns first value as a float.")
-  (def-frob fceiling ceiling
-    "Same as CEILING, but returns first value as a float." )
-  (def-frob ftruncate truncate
-    "Same as TRUNCATE, but returns first value as a float.")
-  (def-frob fround round
-    "Same as ROUND, but returns first value as a float."))
-
-;;;; comparisons
-
-(defun = (number &rest more-numbers)
-  #!+sb-doc
-  "Returns T if all of its arguments are numerically equal, NIL otherwise."
-  (do ((nlist more-numbers (cdr nlist)))
-      ((atom nlist) T)
-     (declare (list nlist))
-     (if (not (= (car nlist) number)) (return nil))))
-
-(defun /= (number &rest more-numbers)
-  #!+sb-doc
-  "Returns T if no two of its arguments are numerically equal, NIL otherwise."
-  (do* ((head number (car nlist))
-	(nlist more-numbers (cdr nlist)))
-       ((atom nlist) t)
-     (declare (list nlist))
-     (unless (do* ((nl nlist (cdr nl)))
-		  ((atom nl) T)
-	       (declare (list nl))
-	       (if (= head (car nl)) (return nil)))
-       (return nil))))
-
-(defun < (number &rest more-numbers)
-  #!+sb-doc
-  "Returns T if its arguments are in strictly increasing order, NIL otherwise."
-  (do* ((n number (car nlist))
-	(nlist more-numbers (cdr nlist)))
-       ((atom nlist) t)
-     (declare (list nlist))
-     (if (not (< n (car nlist))) (return nil))))
-
-(defun > (number &rest more-numbers)
-  #!+sb-doc
-  "Returns T if its arguments are in strictly decreasing order, NIL otherwise."
-  (do* ((n number (car nlist))
-	(nlist more-numbers (cdr nlist)))
-       ((atom nlist) t)
-     (declare (list nlist))
-     (if (not (> n (car nlist))) (return nil))))
-
-(defun <= (number &rest more-numbers)
-  #!+sb-doc
-  "Returns T if arguments are in strictly non-decreasing order, NIL otherwise."
-  (do* ((n number (car nlist))
-	(nlist more-numbers (cdr nlist)))
-       ((atom nlist) t)
-     (declare (list nlist))
-     (if (not (<= n (car nlist))) (return nil))))
-
-(defun >= (number &rest more-numbers)
-  #!+sb-doc
-  "Returns T if arguments are in strictly non-increasing order, NIL otherwise."
-  (do* ((n number (car nlist))
-	(nlist more-numbers (cdr nlist)))
-       ((atom nlist) t)
-     (declare (list nlist))
-     (if (not (>= n (car nlist))) (return nil))))
-
-(defun max (number &rest more-numbers)
-  #!+sb-doc
-  "Returns the greatest of its arguments."
-  (do ((nlist more-numbers (cdr nlist))
-       (result number))
-      ((null nlist) (return result))
-     (declare (list nlist))
-     (if (> (car nlist) result) (setq result (car nlist)))))
-
-(defun min (number &rest more-numbers)
-  #!+sb-doc
-  "Returns the least of its arguments."
-  (do ((nlist more-numbers (cdr nlist))
-       (result number))
-      ((null nlist) (return result))
-     (declare (list nlist))
-     (if (< (car nlist) result) (setq result (car nlist)))))
-
-(eval-when (:compile-toplevel :execute)
-
-;;; The INFINITE-X-FINITE-Y and INFINITE-Y-FINITE-X args tell us how
-;;; to handle the case when X or Y is a floating-point infinity and
-;;; the other arg is a rational. (Section 12.1.4.1 of the ANSI spec
-;;; says that comparisons are done by converting the float to a
-;;; rational when comparing with a rational, but infinities can't be
-;;; converted to a rational, so we show some initiative and do it this
-;;; way instead.)
-(defun basic-compare (op &key infinite-x-finite-y infinite-y-finite-x)
-  `(((fixnum fixnum) (,op x y))
-
-    ((single-float single-float) (,op x y))
-    #!+long-float
-    (((foreach single-float double-float long-float) long-float)
-     (,op (coerce x 'long-float) y))
-    #!+long-float
-    ((long-float (foreach single-float double-float))
-     (,op x (coerce y 'long-float)))
-    (((foreach single-float double-float) double-float)
-     (,op (coerce x 'double-float) y))
-    ((double-float single-float)
-     (,op x (coerce y 'double-float)))
-    (((foreach single-float double-float #!+long-float long-float) rational)
-     (if (eql y 0)
-	 (,op x (coerce 0 '(dispatch-type x)))
-	 (if (float-infinity-p x)
-	     ,infinite-x-finite-y
-	     (,op (rational x) y))))
-    (((foreach bignum fixnum ratio) float)
-     (if (float-infinity-p y)
-	 ,infinite-y-finite-x
-	 (,op x (rational y))))))
-) ; EVAL-WHEN
-
-(macrolet ((def-two-arg-</> (name op ratio-arg1 ratio-arg2 &rest cases)
-             `(defun ,name (x y)
-		(number-dispatch ((x real) (y real))
-				 (basic-compare
-				  ,op
-				  :infinite-x-finite-y
-				  (,op x (coerce 0 '(dispatch-type x)))
-				  :infinite-y-finite-x
-				  (,op (coerce 0 '(dispatch-type y)) y))
-				 (((foreach fixnum bignum) ratio)
-				  (,op x (,ratio-arg2 (numerator y)
-						      (denominator y))))
-				 ((ratio integer)
-				  (,op (,ratio-arg1 (numerator x)
-						    (denominator x))
-				       y))
-				 ((ratio ratio)
-				  (,op (* (numerator   (truly-the ratio x))
-					  (denominator (truly-the ratio y)))
-				       (* (numerator   (truly-the ratio y))
-					  (denominator (truly-the ratio x)))))
-				 ,@cases))))
-  (def-two-arg-</> two-arg-< < floor ceiling
-    ((fixnum bignum)
-     (bignum-plus-p y))
-    ((bignum fixnum)
-     (not (bignum-plus-p x)))
-    ((bignum bignum)
-     (minusp (bignum-compare x y))))
-  (def-two-arg-</> two-arg-> > ceiling floor
-    ((fixnum bignum)
-     (not (bignum-plus-p y)))
-    ((bignum fixnum)
-     (bignum-plus-p x))
-    ((bignum bignum)
-     (plusp (bignum-compare x y)))))
-
-(defun two-arg-= (x y)
-  (number-dispatch ((x number) (y number))
-    (basic-compare =
-		   ;; An infinite value is never equal to a finite value.
-		   :infinite-x-finite-y nil
-		   :infinite-y-finite-x nil)
-    ((fixnum (or bignum ratio)) nil)
-
-    ((bignum (or fixnum ratio)) nil)
-    ((bignum bignum)
-     (zerop (bignum-compare x y)))
-
-    ((ratio integer) nil)
-    ((ratio ratio)
-     (and (eql (numerator x) (numerator y))
-	  (eql (denominator x) (denominator y))))
-
-    ((complex complex)
-     (and (= (realpart x) (realpart y))
-	  (= (imagpart x) (imagpart y))))
-    (((foreach fixnum bignum ratio single-float double-float
-	       #!+long-float long-float) complex)
-     (and (= x (realpart y))
-	  (zerop (imagpart y))))
-    ((complex (or float rational))
-     (and (= (realpart x) y)
-	  (zerop (imagpart x))))))
-
-(defun eql (obj1 obj2)
-  #!+sb-doc
-  "Return T if OBJ1 and OBJ2 represent the same object, otherwise NIL."
-  (or (eq obj1 obj2)
-      (if (or (typep obj2 'fixnum)
-	      (not (typep obj2 'number)))
-	  nil
-	  (macrolet ((foo (&rest stuff)
-		       `(typecase obj2
-			  ,@(mapcar #'(lambda (foo)
-					(let ((type (car foo))
-					      (fn (cadr foo)))
-					  `(,type
-					    (and (typep obj1 ',type)
-						 (,fn obj1 obj2)))))
-				    stuff))))
-	    (foo
-	      (single-float eql)
-	      (double-float eql)
-	      #!+long-float
-	      (long-float eql)
-	      (bignum
-	       (lambda (x y)
-		 (zerop (bignum-compare x y))))
-	      (ratio
-	       (lambda (x y)
-		 (and (eql (numerator x) (numerator y))
-		      (eql (denominator x) (denominator y)))))
-	      (complex
-	       (lambda (x y)
-		 (and (eql (realpart x) (realpart y))
-		      (eql (imagpart x) (imagpart y))))))))))
-
-;;;; logicals
-
-(defun logior (&rest integers)
-  #!+sb-doc
-  "Returns the bit-wise or of its arguments. Args must be integers."
-  (declare (list integers))
-  (if integers
-      (do ((result (pop integers) (logior result (pop integers))))
-	  ((null integers) result))
-      0))
-
-(defun logxor (&rest integers)
-  #!+sb-doc
-  "Returns the bit-wise exclusive or of its arguments. Args must be integers."
-  (declare (list integers))
-  (if integers
-      (do ((result (pop integers) (logxor result (pop integers))))
-	  ((null integers) result))
-      0))
-
-(defun logand (&rest integers)
-  #!+sb-doc
-  "Returns the bit-wise and of its arguments. Args must be integers."
-  (declare (list integers))
-  (if integers
-      (do ((result (pop integers) (logand result (pop integers))))
-	  ((null integers) result))
-      -1))
-
-(defun logeqv (&rest integers)
-  #!+sb-doc
-  "Returns the bit-wise equivalence of its arguments. Args must be integers."
-  (declare (list integers))
-  (if integers
-      (do ((result (pop integers) (logeqv result (pop integers))))
-	  ((null integers) result))
-      -1))
-
-(defun lognand (integer1 integer2)
-  #!+sb-doc
-  "Returns the complement of the logical AND of integer1 and integer2."
-  (lognand integer1 integer2))
-
-(defun lognor (integer1 integer2)
-  #!+sb-doc
-  "Returns the complement of the logical OR of integer1 and integer2."
-  (lognor integer1 integer2))
-
-(defun logandc1 (integer1 integer2)
-  #!+sb-doc
-  "Returns the logical AND of (LOGNOT integer1) and integer2."
-  (logandc1 integer1 integer2))
-
-(defun logandc2 (integer1 integer2)
-  #!+sb-doc
-  "Returns the logical AND of integer1 and (LOGNOT integer2)."
-  (logandc2 integer1 integer2))
-
-(defun logorc1 (integer1 integer2)
-  #!+sb-doc
-  "Returns the logical OR of (LOGNOT integer1) and integer2."
-  (logorc1 integer1 integer2))
-
-(defun logorc2 (integer1 integer2)
-  #!+sb-doc
-  "Returns the logical OR of integer1 and (LOGNOT integer2)."
-  (logorc2 integer1 integer2))
-
-(defun lognot (number)
-  #!+sb-doc
-  "Returns the bit-wise logical not of integer."
-  (etypecase number
-    (fixnum (lognot (truly-the fixnum number)))
-    (bignum (bignum-logical-not number))))
-
-(macrolet ((def-frob (name op big-op)
-	     `(defun ,name (x y)
-	       (number-dispatch ((x integer) (y integer))
-		 (bignum-cross-fixnum ,op ,big-op)))))
-  (def-frob two-arg-and logand bignum-logical-and)
-  (def-frob two-arg-ior logior bignum-logical-ior)
-  (def-frob two-arg-xor logxor bignum-logical-xor))
-
-(defun logcount (integer)
-  #!+sb-doc
-  "Count the number of 1 bits if INTEGER is positive, and the number of 0 bits
-  if INTEGER is negative."
-  (etypecase integer
-    (fixnum
-     (logcount (truly-the (integer 0 #.(max most-positive-fixnum
-					    (lognot most-negative-fixnum)))
-			  (if (minusp (truly-the fixnum integer))
-			      (lognot (truly-the fixnum integer))
-			      integer))))
-    (bignum
-     (bignum-logcount integer))))
-
-(defun logtest (integer1 integer2)
-  #!+sb-doc
-  "Predicate which returns T if logand of integer1 and integer2 is not zero."
-  (logtest integer1 integer2))
-
-(defun logbitp (index integer)
-  #!+sb-doc
-  "Predicate returns T if bit index of integer is a 1."
-  (logbitp index integer))
-
-(defun ash (integer count)
-  #!+sb-doc
-  "Shifts integer left by count places preserving sign. - count shifts right."
-  (declare (integer integer count))
-  (etypecase integer
-    (fixnum
-     (cond ((zerop integer)
-	    0)
-	   ((fixnump count)
-	    (let ((length (integer-length (truly-the fixnum integer)))
-		  (count (truly-the fixnum count)))
-	      (declare (fixnum length count))
-	      (cond ((and (plusp count)
-			  (> (+ length count)
-			     (integer-length most-positive-fixnum)))
-		     (bignum-ashift-left (make-small-bignum integer) count))
-		    (t
-		     (truly-the fixnum
-				(ash (truly-the fixnum integer) count))))))
-	   ((minusp count)
-	    (if (minusp integer) -1 0))
-	   (t
-	    (bignum-ashift-left (make-small-bignum integer) count))))
-    (bignum
-     (if (plusp count)
-	 (bignum-ashift-left integer count)
-	 (bignum-ashift-right integer (- count))))))
-
-(defun integer-length (integer)
-  #!+sb-doc
-  "Returns the number of significant bits in the absolute value of integer."
-  (etypecase integer
-    (fixnum
-     (integer-length (truly-the fixnum integer)))
-    (bignum
-     (bignum-integer-length integer))))
-
-;;;; BYTE, bytespecs, and related operations
-
-(defun byte (size position)
-  #!+sb-doc
-  "Returns a byte specifier which may be used by other byte functions."
-  (byte size position))
-
-(defun byte-size (bytespec)
-  #!+sb-doc
-  "Returns the size part of the byte specifier bytespec."
-  (byte-size bytespec))
-
-(defun byte-position (bytespec)
-  #!+sb-doc
-  "Returns the position part of the byte specifier bytespec."
-  (byte-position bytespec))
-
-(defun ldb (bytespec integer)
-  #!+sb-doc
-  "Extract the specified byte from integer, and right justify result."
-  (ldb bytespec integer))
-
-(defun ldb-test (bytespec integer)
-  #!+sb-doc
-  "Returns T if any of the specified bits in integer are 1's."
-  (ldb-test bytespec integer))
-
-(defun mask-field (bytespec integer)
-  #!+sb-doc
-  "Extract the specified byte from integer,  but do not right justify result."
-  (mask-field bytespec integer))
-
-(defun dpb (newbyte bytespec integer)
-  #!+sb-doc
-  "Returns new integer with newbyte in specified position, newbyte is right justified."
-  (dpb newbyte bytespec integer))
-
-(defun deposit-field (newbyte bytespec integer)
-  #!+sb-doc
-  "Returns new integer with newbyte in specified position, newbyte is not right justified."
-  (deposit-field newbyte bytespec integer))
-
-(defun %ldb (size posn integer)
-  (logand (ash integer (- posn))
-	  (1- (ash 1 size))))
-
-(defun %mask-field (size posn integer)
-  (logand integer (ash (1- (ash 1 size)) posn)))
-
-(defun %dpb (newbyte size posn integer)
-  (let ((mask (1- (ash 1 size))))
-    (logior (logand integer (lognot (ash mask posn)))
-	    (ash (logand newbyte mask) posn))))
-
-(defun %deposit-field (newbyte size posn integer)
-  (let ((mask (ash (ldb (byte size 0) -1) posn)))
-    (logior (logand newbyte mask)
-	    (logand integer (lognot mask)))))
-
-;;;; BOOLE
-
-;;; The boole function dispaches to any logic operation depending on
-;;;     the value of a variable. Presently, legal selector values are [0..15].
-;;;     boole is open coded for calls with a constant selector. or with calls
-;;;     using any of the constants declared below.
-
-(defconstant boole-clr 0
-  #!+sb-doc
-  "Boole function op, makes BOOLE return 0.")
-
-(defconstant boole-set 1
-  #!+sb-doc
-  "Boole function op, makes BOOLE return -1.")
-
-(defconstant boole-1   2
-  #!+sb-doc
-  "Boole function op, makes BOOLE return integer1.")
-
-(defconstant boole-2   3
-  #!+sb-doc
-  "Boole function op, makes BOOLE return integer2.")
-
-(defconstant boole-c1  4
-  #!+sb-doc
-  "Boole function op, makes BOOLE return complement of integer1.")
-
-(defconstant boole-c2  5
-  #!+sb-doc
-  "Boole function op, makes BOOLE return complement of integer2.")
-
-(defconstant boole-and 6
-  #!+sb-doc
-  "Boole function op, makes BOOLE return logand of integer1 and integer2.")
-
-(defconstant boole-ior 7
-  #!+sb-doc
-  "Boole function op, makes BOOLE return logior of integer1 and integer2.")
-
-(defconstant boole-xor 8
-  #!+sb-doc
-  "Boole function op, makes BOOLE return logxor of integer1 and integer2.")
-
-(defconstant boole-eqv 9
-  #!+sb-doc
-  "Boole function op, makes BOOLE return logeqv of integer1 and integer2.")
-
-(defconstant boole-nand  10
-  #!+sb-doc
-  "Boole function op, makes BOOLE return log nand of integer1 and integer2.")
-
-(defconstant boole-nor   11
-  #!+sb-doc
-  "Boole function op, makes BOOLE return lognor of integer1 and integer2.")
-
-(defconstant boole-andc1 12
-  #!+sb-doc
-  "Boole function op, makes BOOLE return logandc1 of integer1 and integer2.")
-
-(defconstant boole-andc2 13
-  #!+sb-doc
-  "Boole function op, makes BOOLE return logandc2 of integer1 and integer2.")
-
-(defconstant boole-orc1  14
-  #!+sb-doc
-  "Boole function op, makes BOOLE return logorc1 of integer1 and integer2.")
-
-(defconstant boole-orc2  15
-  #!+sb-doc
-  "Boole function op, makes BOOLE return logorc2 of integer1 and integer2.")
-
-(defun boole (op integer1 integer2)
-  #!+sb-doc
-  "Bit-wise boolean function on two integers. Function chosen by OP:
-	0	BOOLE-CLR
-	1	BOOLE-SET
-	2	BOOLE-1
-  	3	BOOLE-2
-	4	BOOLE-C1
-	5	BOOLE-C2
-	6	BOOLE-AND
-	7	BOOLE-IOR
- 	8	BOOLE-XOR
-	9	BOOLE-EQV
-	10	BOOLE-NAND
-	11	BOOLE-NOR
-	12	BOOLE-ANDC1
-	13	BOOLE-ANDC2
-	14	BOOLE-ORC1
-	15	BOOLE-ORC2"
-  (case op
-    (0 (boole 0 integer1 integer2))
-    (1 (boole 1 integer1 integer2))
-    (2 (boole 2 integer1 integer2))
-    (3 (boole 3 integer1 integer2))
-    (4 (boole 4 integer1 integer2))
-    (5 (boole 5 integer1 integer2))
-    (6 (boole 6 integer1 integer2))
-    (7 (boole 7 integer1 integer2))
-    (8 (boole 8 integer1 integer2))
-    (9 (boole 9 integer1 integer2))
-    (10 (boole 10 integer1 integer2))
-    (11 (boole 11 integer1 integer2))
-    (12 (boole 12 integer1 integer2))
-    (13 (boole 13 integer1 integer2))
-    (14 (boole 14 integer1 integer2))
-    (15 (boole 15 integer1 integer2))
-    (t (error "~S is not of type (mod 16)." op))))
-
-;;;; GCD and LCM
-
-(defun gcd (&rest numbers)
-  #!+sb-doc
-  "Returns the greatest common divisor of the arguments, which must be
-  integers. Gcd with no arguments is defined to be 0."
-  (cond ((null numbers) 0)
-	((null (cdr numbers)) (abs (the integer (car numbers))))
-	(t
-	 (do ((gcd (the integer (car numbers))
-		   (gcd gcd (the integer (car rest))))
-	      (rest (cdr numbers) (cdr rest)))
-	     ((null rest) gcd)
-	   (declare (integer gcd)
-		    (list rest))))))
-
-(defun lcm (&rest numbers)
-  #!+sb-doc
-  "Returns the least common multiple of one or more integers. LCM of no
-  arguments is defined to be 1."
-  (cond ((null numbers) 1)
-	((null (cdr numbers)) (abs (the integer (car numbers))))
-	(t
-	 (do ((lcm (the integer (car numbers))
-		   (lcm lcm (the integer (car rest))))
-	      (rest (cdr numbers) (cdr rest)))
-	     ((null rest) lcm)
-	   (declare (integer lcm) (list rest))))))
-
-(defun two-arg-lcm (n m)
-  (declare (integer n m))
-  (* (truncate (max n m) (gcd n m)) (min n m)))
-
-;;; Do the GCD of two integer arguments. With fixnum arguments, we use the
-;;; binary GCD algorithm from Knuth's seminumerical algorithms (slightly
-;;; structurified), otherwise we call BIGNUM-GCD. We pick off the special case
-;;; of 0 before the dispatch so that the bignum code doesn't have to worry
-;;; about "small bignum" zeros.
-(defun two-arg-gcd (u v)
-  (cond ((eql u 0) v)
-	((eql v 0) u)
-	(t
-	 (number-dispatch ((u integer) (v integer))
-	   ((fixnum fixnum)
-	    (locally
-	      (declare (optimize (speed 3) (safety 0)))
-	      (do ((k 0 (1+ k))
-		   (u (abs u) (ash u -1))
-		   (v (abs v) (ash v -1)))
-		  ((oddp (logior u v))
-		   (do ((temp (if (oddp u) (- v) (ash u -1))
-			      (ash temp -1)))
-		       (nil)
-		     (declare (fixnum temp))
-		     (when (oddp temp)
-		       (if (plusp temp)
-			   (setq u temp)
-			   (setq v (- temp)))
-		       (setq temp (- u v))
-		       (when (zerop temp)
-			 (let ((res (ash u k)))
-			   (declare (type (signed-byte 31) res)
-				    (optimize (inhibit-warnings 3)))
-			   (return res))))))
-		(declare (type (mod 30) k)
-			 (type (signed-byte 31) u v)))))
-	   ((bignum bignum)
-	    (bignum-gcd u v))
-	   ((bignum fixnum)
-	    (bignum-gcd u (make-small-bignum v)))
-	   ((fixnum bignum)
-	    (bignum-gcd (make-small-bignum u) v))))))
-
-;;; From discussion on comp.lang.lisp and Akira Kurihara.
-(defun isqrt (n)
-  #!+sb-doc
-  "Returns the root of the nearest integer less than n which is a perfect
-   square."
-  (declare (type unsigned-byte n) (values unsigned-byte))
-  ;; Theoretically (> n 7), i.e., n-len-quarter > 0.
-  (if (and (fixnump n) (<= n 24))
-      (cond ((> n 15) 4)
-	    ((> n  8) 3)
-	    ((> n  3) 2)
-	    ((> n  0) 1)
-	    (t 0))
-      (let* ((n-len-quarter (ash (integer-length n) -2))
-	     (n-half (ash n (- (ash n-len-quarter 1))))
-	     (n-half-isqrt (isqrt n-half))
-	     (init-value (ash (1+ n-half-isqrt) n-len-quarter)))
-	(loop
-	  (let ((iterated-value
-		 (ash (+ init-value (truncate n init-value)) -1)))
-	    (unless (< iterated-value init-value)
-	      (return init-value))
-	    (setq init-value iterated-value))))))
-
-;;;; miscellaneous number predicates
-
-(macrolet ((def-frob (name doc)
-	     `(defun ,name (number) ,doc (,name number))))
-  (def-frob zerop "Returns T if number = 0, NIL otherwise.")
-  (def-frob plusp "Returns T if number > 0, NIL otherwise.")
-  (def-frob minusp "Returns T if number < 0, NIL otherwise.")
-  (def-frob oddp "Returns T if number is odd, NIL otherwise.")
-  (def-frob evenp "Returns T if number is even, NIL otherwise."))
diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp
index 05497fc..c594357 100644
--- a/src/code/target-pathname.lisp
+++ b/src/code/target-pathname.lisp
@@ -13,10 +13,30 @@
 
 #!-sb-fluid (declaim (freeze-type logical-pathname logical-host))
 
-;;; host methods
-
-(def!method print-object ((host host) stream)
-  (print-unreadable-object (host stream :type t :identity t)))
+;;;; UNIX-HOST stuff
+
+(def!struct (unix-host
+	     (:make-load-form-fun make-unix-host-load-form)
+	     (:include host
+		       (parse #'parse-unix-namestring)
+		       (unparse #'unparse-unix-namestring)
+		       (unparse-host #'unparse-unix-host)
+		       (unparse-directory #'unparse-unix-directory)
+		       (unparse-file #'unparse-unix-file)
+		       (unparse-enough #'unparse-unix-enough)
+		       (customary-case :lower))))
+
+(defvar *unix-host* (make-unix-host))
+
+(defun make-unix-host-load-form (host)
+  (declare (ignore host))
+  '*unix-host*)
+
+;;; Return a value suitable, e.g., for preinitializing
+;;; *DEFAULT-PATHNAME-DEFAULTS* before *DEFAULT-PATHNAME-DEFAULTS* is
+;;; initialized (at which time we can't safely call e.g. #'PATHNAME).
+(defun make-trivial-default-pathname ()
+  (%make-pathname *unix-host* nil nil nil nil :newest))
 
 ;;; pathname methods
 
diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp
new file mode 100644
index 0000000..82b129f
--- /dev/null
+++ b/src/compiler/ir1-translators.lisp
@@ -0,0 +1,1071 @@
+;;;; the usual place for DEF-IR1-TRANSLATOR forms (and their
+;;;; close personal friends)
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+;;;; control special forms
+
+(def-ir1-translator progn ((&rest forms) start cont)
+  #!+sb-doc
+  "Progn Form*
+  Evaluates each Form in order, returning the values of the last form. With no
+  forms, returns NIL."
+  (ir1-convert-progn-body start cont forms))
+
+(def-ir1-translator if ((test then &optional else) start cont)
+  #!+sb-doc
+  "If Predicate Then [Else]
+  If Predicate evaluates to non-null, evaluate Then and returns its values,
+  otherwise evaluate Else and return its values. Else defaults to NIL."
+  (let* ((pred (make-continuation))
+	 (then-cont (make-continuation))
+	 (then-block (continuation-starts-block then-cont))
+	 (else-cont (make-continuation))
+	 (else-block (continuation-starts-block else-cont))
+	 (dummy-cont (make-continuation))
+	 (node (make-if :test pred
+			:consequent then-block
+			:alternative else-block)))
+    (setf (continuation-dest pred) node)
+    (ir1-convert start pred test)
+    (prev-link node pred)
+    (use-continuation node dummy-cont)
+
+    (let ((start-block (continuation-block pred)))
+      (setf (block-last start-block) node)
+      (continuation-starts-block cont)
+
+      (link-blocks start-block then-block)
+      (link-blocks start-block else-block)
+
+      (ir1-convert then-cont cont then)
+      (ir1-convert else-cont cont else))))
+
+;;;; BLOCK and TAGBODY
+
+;;;; We make an Entry node to mark the start and a :Entry cleanup to
+;;;; mark its extent. When doing GO or RETURN-FROM, we emit an Exit
+;;;; node.
+
+;;; Make a :ENTRY cleanup and emit an ENTRY node, then convert the
+;;; body in the modified environment. We make CONT start a block now,
+;;; since if it was done later, the block would be in the wrong
+;;; environment.
+(def-ir1-translator block ((name &rest forms) start cont)
+  #!+sb-doc
+  "Block Name Form*
+  Evaluate the Forms as a PROGN. Within the lexical scope of the body,
+  (RETURN-FROM Name Value-Form) can be used to exit the form, returning the
+  result of Value-Form."
+  (unless (symbolp name)
+    (compiler-error "The block name ~S is not a symbol." name))
+  (continuation-starts-block cont)
+  (let* ((dummy (make-continuation))
+	 (entry (make-entry))
+	 (cleanup (make-cleanup :kind :block
+				:mess-up entry)))
+    (push entry (lambda-entries (lexenv-lambda *lexenv*)))
+    (setf (entry-cleanup entry) cleanup)
+    (prev-link entry start)
+    (use-continuation entry dummy)
+    
+    (let* ((env-entry (list entry cont))
+           (*lexenv* (make-lexenv :blocks (list (cons name env-entry))
+				  :cleanup cleanup)))
+      (push env-entry (continuation-lexenv-uses cont))
+      (ir1-convert-progn-body dummy cont forms))))
+
+
+;;; We make CONT start a block just so that it will have a block
+;;; assigned. People assume that when they pass a continuation into
+;;; IR1-CONVERT as CONT, it will have a block when it is done.
+(def-ir1-translator return-from ((name &optional value)
+				 start cont)
+  #!+sb-doc
+  "Return-From Block-Name Value-Form
+  Evaluate the Value-Form, returning its values from the lexically enclosing
+  BLOCK Block-Name. This is constrained to be used only within the dynamic
+  extent of the BLOCK."
+  (continuation-starts-block cont)
+  (let* ((found (or (lexenv-find name blocks)
+		    (compiler-error "return for unknown block: ~S" name)))
+	 (value-cont (make-continuation))
+	 (entry (first found))
+	 (exit (make-exit :entry entry
+			  :value value-cont)))
+    (push exit (entry-exits entry))
+    (setf (continuation-dest value-cont) exit)
+    (ir1-convert start value-cont value)
+    (prev-link exit value-cont)
+    (use-continuation exit (second found))))
+
+;;; Return a list of the segments of a TAGBODY. Each segment looks
+;;; like (<tag> <form>* (go <next tag>)). That is, we break up the
+;;; tagbody into segments of non-tag statements, and explicitly
+;;; represent the drop-through with a GO. The first segment has a
+;;; dummy NIL tag, since it represents code before the first tag. The
+;;; last segment (which may also be the first segment) ends in NIL
+;;; rather than a GO.
+(defun parse-tagbody (body)
+  (declare (list body))
+  (collect ((segments))
+    (let ((current (cons nil body)))
+      (loop
+	(let ((tag-pos (position-if (complement #'listp) current :start 1)))
+	  (unless tag-pos
+	    (segments `(,@current nil))
+	    (return))
+	  (let ((tag (elt current tag-pos)))
+	    (when (assoc tag (segments))
+	      (compiler-error
+	       "The tag ~S appears more than once in the tagbody."
+	       tag))
+	    (unless (or (symbolp tag) (integerp tag))
+	      (compiler-error "~S is not a legal tagbody statement." tag))
+	    (segments `(,@(subseq current 0 tag-pos) (go ,tag))))
+	  (setq current (nthcdr tag-pos current)))))
+    (segments)))
+
+;;; Set up the cleanup, emitting the entry node. Then make a block for
+;;; each tag, building up the tag list for LEXENV-TAGS as we go.
+;;; Finally, convert each segment with the precomputed Start and Cont
+;;; values.
+(def-ir1-translator tagbody ((&rest statements) start cont)
+  #!+sb-doc
+  "Tagbody {Tag | Statement}*
+  Define tags for used with GO. The Statements are evaluated in order
+  (skipping Tags) and NIL is returned. If a statement contains a GO to a
+  defined Tag within the lexical scope of the form, then control is transferred
+  to the next statement following that tag. A Tag must an integer or a
+  symbol. A statement must be a list. Other objects are illegal within the
+  body."
+  (continuation-starts-block cont)
+  (let* ((dummy (make-continuation))
+	 (entry (make-entry))
+	 (segments (parse-tagbody statements))
+	 (cleanup (make-cleanup :kind :tagbody
+				:mess-up entry)))
+    (push entry (lambda-entries (lexenv-lambda *lexenv*)))
+    (setf (entry-cleanup entry) cleanup)
+    (prev-link entry start)
+    (use-continuation entry dummy)
+
+    (collect ((tags)
+	      (starts)
+	      (conts))
+      (starts dummy)
+      (dolist (segment (rest segments))
+	(let* ((tag-cont (make-continuation))
+               (tag (list (car segment) entry tag-cont)))          
+	  (conts tag-cont)
+	  (starts tag-cont)
+	  (continuation-starts-block tag-cont)
+          (tags tag)
+          (push (cdr tag) (continuation-lexenv-uses tag-cont))))
+      (conts cont)
+
+      (let ((*lexenv* (make-lexenv :cleanup cleanup :tags (tags))))
+	(mapc (lambda (segment start cont)
+		(ir1-convert-progn-body start cont (rest segment)))
+	      segments (starts) (conts))))))
+
+;;; Emit an EXIT node without any value.
+(def-ir1-translator go ((tag) start cont)
+  #!+sb-doc
+  "Go Tag
+  Transfer control to the named Tag in the lexically enclosing TAGBODY. This
+  is constrained to be used only within the dynamic extent of the TAGBODY."
+  (continuation-starts-block cont)
+  (let* ((found (or (lexenv-find tag tags :test #'eql)
+		    (compiler-error "Go to nonexistent tag: ~S." tag)))
+	 (entry (first found))
+	 (exit (make-exit :entry entry)))
+    (push exit (entry-exits entry))
+    (prev-link exit start)
+    (use-continuation exit (second found))))
+
+;;;; translators for compiler-magic special forms
+
+;;; This handles EVAL-WHEN in non-top-level forms. (EVAL-WHENs in
+;;; top-level forms are picked off and handled by PROCESS-TOP-LEVEL-FORM,
+;;; so that they're never seen at this level.)
+;;;
+;;; ANSI "3.2.3.1 Processing of Top Level Forms" says that processing
+;;; of non-top-level EVAL-WHENs is very simple:
+;;;   EVAL-WHEN forms cause compile-time evaluation only at top level.
+;;;   Both :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL situation specifications
+;;;   are ignored for non-top-level forms. For non-top-level forms, an
+;;;   eval-when specifying the :EXECUTE situation is treated as an
+;;;   implicit PROGN including the forms in the body of the EVAL-WHEN
+;;;   form; otherwise, the forms in the body are ignored. 
+(def-ir1-translator eval-when ((situations &rest forms) start cont)
+  #!+sb-doc
+  "EVAL-WHEN (Situation*) Form*
+  Evaluate the Forms in the specified Situations (any of :COMPILE-TOPLEVEL,
+  :LOAD-TOPLEVEL, or :EXECUTE, or (deprecated) COMPILE, LOAD, or EVAL)."
+  (multiple-value-bind (ct lt e) (parse-eval-when-situations situations)
+    (declare (ignore ct lt))
+    (ir1-convert-progn-body start cont (and e forms)))
+  (values))
+
+;;; common logic for MACROLET and SYMBOL-MACROLET
+;;;
+;;; Call DEFINITIONIZE-FUN on each element of DEFINITIONS to find its
+;;; in-lexenv representation, stuff the results into *LEXENV*, and
+;;; call FUN (with no arguments).
+(defun %funcall-in-foomacrolet-lexenv (definitionize-fun
+				       definitionize-keyword
+				       definitions
+				       fun)
+  (declare (type function definitionize-fun fun))
+  (declare (type (member :variables :functions) definitionize-keyword))
+  (declare (type list definitions))
+  (unless (= (length definitions)
+             (length (remove-duplicates definitions :key #'first)))
+    (compiler-style-warning "duplicate definitions in ~S" definitions))
+  (let* ((processed-definitions (mapcar definitionize-fun definitions))
+         (*lexenv* (make-lexenv definitionize-keyword processed-definitions)))
+    (funcall fun)))
+
+;;; Tweak *LEXENV* to include the DEFINITIONS from a MACROLET, then
+;;; call FUN (with no arguments).
+;;;
+;;; This is split off from the IR1 convert method so that it can be
+;;; shared by the special-case top-level MACROLET processing code.
+(defun funcall-in-macrolet-lexenv (definitions fun)
+  (%funcall-in-foomacrolet-lexenv
+   (lambda (definition)
+     (unless (list-of-length-at-least-p definition 2)
+       (compiler-error
+	"The list ~S is too short to be a legal local macro definition."
+	definition))
+     (destructuring-bind (name arglist &body body) definition
+       (unless (symbolp name)
+	 (compiler-error "The local macro name ~S is not a symbol." name))
+       (let ((whole (gensym "WHOLE"))
+	     (environment (gensym "ENVIRONMENT")))
+	 (multiple-value-bind (body local-decls)
+	     (parse-defmacro arglist whole body name 'macrolet
+			     :environment environment)
+	   `(,name macro .
+		   ,(compile nil
+			     `(lambda (,whole ,environment)
+				,@local-decls
+				(block ,name ,body))))))))
+   :functions
+   definitions
+   fun))
+
+(def-ir1-translator macrolet ((definitions &rest body) start cont)
+  #!+sb-doc
+  "MACROLET ({(Name Lambda-List Form*)}*) Body-Form*
+  Evaluate the Body-Forms in an environment with the specified local macros
+  defined. Name is the local macro name, Lambda-List is the DEFMACRO style
+  destructuring lambda list, and the Forms evaluate to the expansion. The
+  Forms are evaluated in the null environment."
+  (funcall-in-macrolet-lexenv definitions
+			      (lambda ()
+				(ir1-translate-locally body start cont))))
+
+(defun funcall-in-symbol-macrolet-lexenv (definitions fun)
+  (%funcall-in-foomacrolet-lexenv
+   (lambda (definition)
+     (unless (proper-list-of-length-p definition 2)
+       (compiler-error "malformed symbol/expansion pair: ~S" definition))
+     (destructuring-bind (name expansion) definition
+       (unless (symbolp name)
+         (compiler-error
+          "The local symbol macro name ~S is not a symbol."
+          name))
+       `(,name . (MACRO . ,expansion))))
+   :variables
+   definitions
+   fun))
+  
+(def-ir1-translator symbol-macrolet ((macrobindings &body body) start cont)
+  #!+sb-doc
+  "SYMBOL-MACROLET ({(Name Expansion)}*) Decl* Form*
+  Define the Names as symbol macros with the given Expansions. Within the
+  body, references to a Name will effectively be replaced with the Expansion."
+  (funcall-in-symbol-macrolet-lexenv
+   macrobindings
+   (lambda ()
+     (ir1-translate-locally body start cont))))
+
+;;; not really a special form, but..
+(def-ir1-translator declare ((&rest stuff) start cont)
+  (declare (ignore stuff))
+  ;; We ignore START and CONT too, but we can't use DECLARE IGNORE to
+  ;; tell the compiler about it here, because the DEF-IR1-TRANSLATOR
+  ;; macro would put the DECLARE in the wrong place, so..
+  start cont
+  (compiler-error "misplaced declaration"))
+
+;;;; %PRIMITIVE
+;;;;
+;;;; Uses of %PRIMITIVE are either expanded into Lisp code or turned
+;;;; into a funny function.
+
+;;; Carefully evaluate a list of forms, returning a list of the results.
+(defun eval-info-args (args)
+  (declare (list args))
+  (handler-case (mapcar #'eval args)
+    (error (condition)
+      (compiler-error "Lisp error during evaluation of info args:~%~A"
+		      condition))))
+
+;;; If there is a primitive translator, then we expand the call.
+;;; Otherwise, we convert to the %%PRIMITIVE funny function. The first
+;;; argument is the template, the second is a list of the results of
+;;; any codegen-info args, and the remaining arguments are the runtime
+;;; arguments.
+;;;
+;;; We do a bunch of error checking now so that we don't bomb out with
+;;; a fatal error during IR2 conversion.
+;;;
+;;; KLUDGE: It's confusing having multiple names floating around for
+;;; nearly the same concept: PRIMITIVE, TEMPLATE, VOP. Now that CMU
+;;; CL's *PRIMITIVE-TRANSLATORS* stuff is gone, we could call
+;;; primitives VOPs, rename TEMPLATE to VOP-TEMPLATE, rename
+;;; BACKEND-TEMPLATE-NAMES to BACKEND-VOPS, and rename %PRIMITIVE to
+;;; VOP or %VOP.. -- WHN 2001-06-11
+;;; FIXME: Look at doing this ^, it doesn't look too hard actually.
+(def-ir1-translator %primitive ((name &rest args) start cont)
+  (unless (symbolp name)
+    (compiler-error "The primitive name ~S is not a symbol." name))
+
+  (let* ((template (or (gethash name *backend-template-names*)
+		       (compiler-error
+			"The primitive name ~A is not defined."
+			name)))
+	 (required (length (template-arg-types template)))
+	 (info (template-info-arg-count template))
+	 (min (+ required info))
+	 (nargs (length args)))
+    (if (template-more-args-type template)
+	(when (< nargs min)
+	  (compiler-error "Primitive ~A was called with ~R argument~:P, ~
+	    		   but wants at least ~R."
+			  name
+			  nargs
+			  min))
+	(unless (= nargs min)
+	  (compiler-error "Primitive ~A was called with ~R argument~:P, ~
+			   but wants exactly ~R."
+			  name
+			  nargs
+			  min)))
+
+    (when (eq (template-result-types template) :conditional)
+      (compiler-error
+       "%PRIMITIVE was used with a conditional template."))
+
+    (when (template-more-results-type template)
+      (compiler-error
+       "%PRIMITIVE was used with an unknown values template."))
+
+    (ir1-convert start
+		 cont
+		 `(%%primitive ',template
+			       ',(eval-info-args
+				  (subseq args required min))
+			       ,@(subseq args 0 required)
+			       ,@(subseq args min)))))
+
+;;;; QUOTE and FUNCTION
+
+(def-ir1-translator quote ((thing) start cont)
+  #!+sb-doc
+  "QUOTE Value
+  Return Value without evaluating it."
+  (reference-constant start cont thing))
+
+(def-ir1-translator function ((thing) start cont)
+  #!+sb-doc
+  "FUNCTION Name
+  Return the lexically apparent definition of the function Name. Name may also
+  be a lambda."
+  (if (consp thing)
+      (case (car thing)
+	((lambda)
+	 (reference-leaf start cont (ir1-convert-lambda thing)))
+	((setf)
+	 (let ((var (find-lexically-apparent-function
+		     thing "as the argument to FUNCTION")))
+	   (reference-leaf start cont var)))
+	((instance-lambda)
+	 (let ((res (ir1-convert-lambda `(lambda ,@(cdr thing)))))
+	   (setf (getf (functional-plist res) :fin-function) t)
+	   (reference-leaf start cont res)))
+	(t
+	 (compiler-error "~S is not a legal function name." thing)))
+      (let ((var (find-lexically-apparent-function
+		  thing "as the argument to FUNCTION")))
+	(reference-leaf start cont var))))
+
+;;;; FUNCALL
+
+;;; FUNCALL is implemented on %FUNCALL, which can only call functions
+;;; (not symbols). %FUNCALL is used directly in some places where the
+;;; call should always be open-coded even if FUNCALL is :NOTINLINE.
+(deftransform funcall ((function &rest args) * * :when :both)
+  (let ((arg-names (make-gensym-list (length args))))
+    `(lambda (function ,@arg-names)
+       (%funcall ,(if (csubtypep (continuation-type function)
+				 (specifier-type 'function))
+		      'function
+		      '(%coerce-callable-to-function function))
+		 ,@arg-names))))
+
+(def-ir1-translator %funcall ((function &rest args) start cont)
+  (let ((fun-cont (make-continuation)))
+    (ir1-convert start fun-cont function)
+    (assert-continuation-type fun-cont (specifier-type 'function))
+    (ir1-convert-combination-args fun-cont cont args)))
+
+;;; This source transform exists to reduce the amount of work for the
+;;; compiler. If the called function is a FUNCTION form, then convert
+;;; directly to %FUNCALL, instead of waiting around for type
+;;; inference.
+(def-source-transform funcall (function &rest args)
+  (if (and (consp function) (eq (car function) 'function))
+      `(%funcall ,function ,@args)
+      (values nil t)))
+
+(deftransform %coerce-callable-to-function ((thing) (function) *
+					    :when :both
+					    :important t)
+  "optimize away possible call to FDEFINITION at runtime"
+  'thing)
+
+;;;; LET and LET*
+;;;;
+;;;; (LET and LET* can't be implemented as macros due to the fact that
+;;;; any pervasive declarations also affect the evaluation of the
+;;;; arguments.)
+
+;;; Given a list of binding specifiers in the style of Let, return:
+;;;  1. The list of var structures for the variables bound.
+;;;  2. The initial value form for each variable.
+;;;
+;;; The variable names are checked for legality and globally special
+;;; variables are marked as such. Context is the name of the form, for
+;;; error reporting purposes.
+(declaim (ftype (function (list symbol) (values list list list))
+		extract-let-variables))
+(defun extract-let-variables (bindings context)
+  (collect ((vars)
+	    (vals)
+	    (names))
+    (flet ((get-var (name)
+	     (varify-lambda-arg name
+				(if (eq context 'let*)
+				    nil
+				    (names)))))
+      (dolist (spec bindings)
+	(cond ((atom spec)
+	       (let ((var (get-var spec)))
+		 (vars var)
+		 (names (cons spec var))
+		 (vals nil)))
+	      (t
+	       (unless (proper-list-of-length-p spec 1 2)
+		 (compiler-error "The ~S binding spec ~S is malformed."
+				 context
+				 spec))
+	       (let* ((name (first spec))
+		      (var (get-var name)))
+		 (vars var)
+		 (names name)
+		 (vals (second spec)))))))
+
+    (values (vars) (vals) (names))))
+
+(def-ir1-translator let ((bindings &body body)
+			 start cont)
+  #!+sb-doc
+  "LET ({(Var [Value]) | Var}*) Declaration* Form*
+  During evaluation of the Forms, bind the Vars to the result of evaluating the
+  Value forms. The variables are bound in parallel after all of the Values are
+  evaluated."
+  (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
+    (multiple-value-bind (vars values) (extract-let-variables bindings 'let)
+      (let* ((*lexenv* (process-decls decls vars nil cont))
+	     (fun-cont (make-continuation))
+	     (fun (ir1-convert-lambda-body forms vars)))
+	(reference-leaf start fun-cont fun)
+	(ir1-convert-combination-args fun-cont cont values)))))
+
+(def-ir1-translator let* ((bindings &body body)
+			  start cont)
+  #!+sb-doc
+  "LET* ({(Var [Value]) | Var}*) Declaration* Form*
+  Similar to LET, but the variables are bound sequentially, allowing each Value
+  form to reference any of the previous Vars."
+  (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
+    (multiple-value-bind (vars values) (extract-let-variables bindings 'let*)
+      (let ((*lexenv* (process-decls decls vars nil cont)))
+	(ir1-convert-aux-bindings start cont forms vars values)))))
+
+;;; logic shared between IR1 translators for LOCALLY, MACROLET,
+;;; and SYMBOL-MACROLET
+;;;
+;;; Note that all these things need to preserve top-level-formness,
+;;; but we don't need to worry about that within an IR1 translator,
+;;; since top-level-formness is picked off by PROCESS-TOP-LEVEL-FOO
+;;; forms before we hit the IR1 transform level.
+(defun ir1-translate-locally (body start cont)
+  (declare (type list body) (type continuation start cont))
+  (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
+    (let ((*lexenv* (process-decls decls nil nil cont)))
+      (ir1-convert-aux-bindings start cont forms nil nil))))
+
+(def-ir1-translator locally ((&body body) start cont)
+  #!+sb-doc
+  "LOCALLY Declaration* Form*
+  Sequentially evaluate the Forms in a lexical environment where the
+  the Declarations have effect. If LOCALLY is a top-level form, then
+  the Forms are also processed as top-level forms."
+  (ir1-translate-locally body start cont))
+
+;;;; FLET and LABELS
+
+;;; Given a list of local function specifications in the style of
+;;; FLET, return lists of the function names and of the lambdas which
+;;; are their definitions.
+;;;
+;;; The function names are checked for legality. CONTEXT is the name
+;;; of the form, for error reporting.
+(declaim (ftype (function (list symbol) (values list list))
+		extract-flet-variables))
+(defun extract-flet-variables (definitions context)
+  (collect ((names)
+	    (defs))
+    (dolist (def definitions)
+      (when (or (atom def) (< (length def) 2))
+	(compiler-error "The ~S definition spec ~S is malformed." context def))
+
+      (let ((name (check-function-name (first def))))
+	(names name)
+	(multiple-value-bind (forms decls) (sb!sys:parse-body (cddr def))
+	  (defs `(lambda ,(second def)
+		   ,@decls
+		   (block ,(function-name-block-name name)
+		     . ,forms))))))
+    (values (names) (defs))))
+
+(def-ir1-translator flet ((definitions &body body)
+			  start cont)
+  #!+sb-doc
+  "FLET ({(Name Lambda-List Declaration* Form*)}*) Declaration* Body-Form*
+  Evaluate the Body-Forms with some local function definitions. The bindings
+  do not enclose the definitions; any use of Name in the Forms will refer to
+  the lexically apparent function definition in the enclosing environment."
+  (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
+    (multiple-value-bind (names defs)
+	(extract-flet-variables definitions 'flet)
+      (let* ((fvars (mapcar (lambda (n d)
+  			      (ir1-convert-lambda d n))
+			    names defs))
+	     (*lexenv* (make-lexenv
+			:default (process-decls decls nil fvars cont)
+			:functions (pairlis names fvars))))
+	(ir1-convert-progn-body start cont forms)))))
+
+;;; For LABELS, we have to create dummy function vars and add them to
+;;; the function namespace while converting the functions. We then
+;;; modify all the references to these leaves so that they point to
+;;; the real functional leaves. We also backpatch the FENV so that if
+;;; the lexical environment is used for inline expansion we will get
+;;; the right functions.
+(def-ir1-translator labels ((definitions &body body) start cont)
+  #!+sb-doc
+  "LABELS ({(Name Lambda-List Declaration* Form*)}*) Declaration* Body-Form*
+  Evaluate the Body-Forms with some local function definitions. The bindings
+  enclose the new definitions, so the defined functions can call themselves or
+  each other."
+  (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
+    (multiple-value-bind (names defs)
+	(extract-flet-variables definitions 'labels)
+      (let* ((new-fenv (loop for name in names
+			     collect (cons name (make-functional :name name))))
+	     (real-funs
+	      (let ((*lexenv* (make-lexenv :functions new-fenv)))
+		(mapcar (lambda (n d)
+			  (ir1-convert-lambda d n))
+			names defs))))
+
+	(loop for real in real-funs and env in new-fenv do
+	      (let ((dum (cdr env)))
+		(substitute-leaf real dum)
+		(setf (cdr env) real)))
+
+	(let ((*lexenv* (make-lexenv
+			 :default (process-decls decls nil real-funs cont)
+			 :functions (pairlis names real-funs))))
+	  (ir1-convert-progn-body start cont forms))))))
+
+;;;; THE
+
+;;; Do stuff to recognize a THE or VALUES declaration. CONT is the
+;;; continuation that the assertion applies to, TYPE is the type
+;;; specifier and Lexenv is the current lexical environment. NAME is
+;;; the name of the declaration we are doing, for use in error
+;;; messages.
+;;;
+;;; This is somewhat involved, since a type assertion may only be made
+;;; on a continuation, not on a node. We can't just set the
+;;; continuation asserted type and let it go at that, since there may
+;;; be parallel THE's for the same continuation, i.e.:
+;;;     (if ...
+;;;	 (the foo ...)
+;;;	 (the bar ...))
+;;;
+;;; In this case, our representation can do no better than the union
+;;; of these assertions. And if there is a branch with no assertion,
+;;; we have nothing at all. We really need to recognize scoping, since
+;;; we need to be able to discern between parallel assertions (which
+;;; we union) and nested ones (which we intersect).
+;;;
+;;; We represent the scoping by throwing our innermost (intersected)
+;;; assertion on CONT into the TYPE-RESTRICTIONS. As we go down, we
+;;; intersect our assertions together. If CONT has no uses yet, we
+;;; have not yet bottomed out on the first COND branch; in this case
+;;; we optimistically assume that this type will be the one we end up
+;;; with, and set the ASSERTED-TYPE to it. We can never get better
+;;; than the type that we have the first time we bottom out. Later
+;;; THE's (or the absence thereof) can only weaken this result.
+;;;
+;;; We make this work by getting USE-CONTINUATION to do the unioning
+;;; across COND branches. We can't do it here, since we don't know how
+;;; many branches there are going to be.
+(defun do-the-stuff (type cont lexenv name)
+  (declare (type continuation cont) (type lexenv lexenv))
+  (let* ((ctype (values-specifier-type type))
+	 (old-type (or (lexenv-find cont type-restrictions)
+		       *wild-type*))
+	 (intersects (values-types-equal-or-intersect old-type ctype))
+	 (int (values-type-intersection old-type ctype))
+	 (new (if intersects int old-type)))
+    (when (null (find-uses cont))
+      (setf (continuation-asserted-type cont) new))
+    (when (and (not intersects)
+	       (not (policy *lexenv*
+			    (= inhibit-warnings 3)))) ;FIXME: really OK to suppress?
+      (compiler-warning
+       "The type ~S in ~S declaration conflicts with an enclosing assertion:~%   ~S"
+       (type-specifier ctype)
+       name
+       (type-specifier old-type)))
+    (make-lexenv :type-restrictions `((,cont . ,new))
+		 :default lexenv)))
+
+;;; Assert that FORM evaluates to the specified type (which may be a
+;;; VALUES type).
+;;;
+;;; FIXME: In a version of CMU CL that I used at Cadabra ca. 20000101,
+;;; this didn't seem to expand into an assertion, at least for ALIEN
+;;; values. Check that SBCL doesn't have this problem.
+(def-ir1-translator the ((type value) start cont)
+  (let ((*lexenv* (do-the-stuff type cont *lexenv* 'the)))
+    (ir1-convert start cont value)))
+
+;;; This is like the THE special form, except that it believes
+;;; whatever you tell it. It will never generate a type check, but
+;;; will cause a warning if the compiler can prove the assertion is
+;;; wrong.
+;;;
+;;; Since the CONTINUATION-DERIVED-TYPE is computed as the union of
+;;; its uses's types, setting it won't work. Instead we must intersect
+;;; the type with the uses's DERIVED-TYPE.
+(def-ir1-translator truly-the ((type value) start cont)
+  #!+sb-doc
+  (declare (inline member))
+  (let ((type (values-specifier-type type))
+	(old (find-uses cont)))
+    (ir1-convert start cont value)
+    (do-uses (use cont)
+      (unless (member use old :test #'eq)
+	(derive-node-type use type)))))
+
+;;;; SETQ
+
+;;; If there is a definition in LEXENV-VARIABLES, just set that,
+;;; otherwise look at the global information. If the name is for a
+;;; constant, then error out.
+(def-ir1-translator setq ((&whole source &rest things) start cont)
+  (let ((len (length things)))
+    (when (oddp len)
+      (compiler-error "odd number of args to SETQ: ~S" source))
+    (if (= len 2)
+	(let* ((name (first things))
+	       (leaf (or (lexenv-find name variables)
+			 (find-free-variable name))))
+	  (etypecase leaf
+	    (leaf
+	     (when (or (constant-p leaf)
+		       (and (global-var-p leaf)
+			    (eq (global-var-kind leaf) :constant)))
+	       (compiler-error "~S is a constant and thus can't be set." name))
+	     (when (and (lambda-var-p leaf)
+			(lambda-var-ignorep leaf))
+	       ;; ANSI's definition of "Declaration IGNORE, IGNORABLE"
+	       ;; requires that this be a STYLE-WARNING, not a full warning.
+	       (compiler-style-warning
+		"~S is being set even though it was declared to be ignored."
+		name))
+	     (set-variable start cont leaf (second things)))
+	    (cons
+	     (aver (eq (car leaf) 'MACRO))
+	     (ir1-convert start cont `(setf ,(cdr leaf) ,(second things))))
+	    (heap-alien-info
+	     (ir1-convert start cont
+			  `(%set-heap-alien ',leaf ,(second things))))))
+	(collect ((sets))
+	  (do ((thing things (cddr thing)))
+	      ((endp thing)
+	       (ir1-convert-progn-body start cont (sets)))
+	    (sets `(setq ,(first thing) ,(second thing))))))))
+
+;;; This is kind of like REFERENCE-LEAF, but we generate a SET node.
+;;; This should only need to be called in SETQ.
+(defun set-variable (start cont var value)
+  (declare (type continuation start cont) (type basic-var var))
+  (let ((dest (make-continuation)))
+    (setf (continuation-asserted-type dest) (leaf-type var))
+    (ir1-convert start dest value)
+    (let ((res (make-set :var var :value dest)))
+      (setf (continuation-dest dest) res)
+      (setf (leaf-ever-used var) t)
+      (push res (basic-var-sets var))
+      (prev-link res dest)
+      (use-continuation res cont))))
+
+;;;; CATCH, THROW and UNWIND-PROTECT
+
+;;; We turn THROW into a multiple-value-call of a magical function,
+;;; since as as far as IR1 is concerned, it has no interesting
+;;; properties other than receiving multiple-values.
+(def-ir1-translator throw ((tag result) start cont)
+  #!+sb-doc
+  "Throw Tag Form
+  Do a non-local exit, return the values of Form from the CATCH whose tag
+  evaluates to the same thing as Tag."
+  (ir1-convert start cont
+	       `(multiple-value-call #'%throw ,tag ,result)))
+
+;;; This is a special special form used to instantiate a cleanup as
+;;; the current cleanup within the body. KIND is a the kind of cleanup
+;;; to make, and MESS-UP is a form that does the mess-up action. We
+;;; make the MESS-UP be the USE of the MESS-UP form's continuation,
+;;; and introduce the cleanup into the lexical environment. We
+;;; back-patch the ENTRY-CLEANUP for the current cleanup to be the new
+;;; cleanup, since this inner cleanup is the interesting one.
+(def-ir1-translator %within-cleanup ((kind mess-up &body body) start cont)
+  (let ((dummy (make-continuation))
+	(dummy2 (make-continuation)))
+    (ir1-convert start dummy mess-up)
+    (let* ((mess-node (continuation-use dummy))
+	   (cleanup (make-cleanup :kind kind
+				  :mess-up mess-node))
+	   (old-cup (lexenv-cleanup *lexenv*))
+	   (*lexenv* (make-lexenv :cleanup cleanup)))
+      (setf (entry-cleanup (cleanup-mess-up old-cup)) cleanup)
+      (ir1-convert dummy dummy2 '(%cleanup-point))
+      (ir1-convert-progn-body dummy2 cont body))))
+
+;;; This is a special special form that makes an "escape function"
+;;; which returns unknown values from named block. We convert the
+;;; function, set its kind to :ESCAPE, and then reference it. The
+;;; :Escape kind indicates that this function's purpose is to
+;;; represent a non-local control transfer, and that it might not
+;;; actually have to be compiled.
+;;;
+;;; Note that environment analysis replaces references to escape
+;;; functions with references to the corresponding NLX-INFO structure.
+(def-ir1-translator %escape-function ((tag) start cont)
+  (let ((fun (ir1-convert-lambda
+	      `(lambda ()
+		 (return-from ,tag (%unknown-values))))))
+    (setf (functional-kind fun) :escape)
+    (reference-leaf start cont fun)))
+
+;;; Yet another special special form. This one looks up a local
+;;; function and smashes it to a :CLEANUP function, as well as
+;;; referencing it.
+(def-ir1-translator %cleanup-function ((name) start cont)
+  (let ((fun (lexenv-find name functions)))
+    (aver (lambda-p fun))
+    (setf (functional-kind fun) :cleanup)
+    (reference-leaf start cont fun)))
+
+;;; We represent the possibility of the control transfer by making an
+;;; "escape function" that does a lexical exit, and instantiate the
+;;; cleanup using %WITHIN-CLEANUP.
+(def-ir1-translator catch ((tag &body body) start cont)
+  #!+sb-doc
+  "Catch Tag Form*
+  Evaluates Tag and instantiates it as a catcher while the body forms are
+  evaluated in an implicit PROGN. If a THROW is done to Tag within the dynamic
+  scope of the body, then control will be transferred to the end of the body
+  and the thrown values will be returned."
+  (ir1-convert
+   start cont
+   (let ((exit-block (gensym "EXIT-BLOCK-")))
+     `(block ,exit-block
+	(%within-cleanup
+	    :catch
+	    (%catch (%escape-function ,exit-block) ,tag)
+	  ,@body)))))
+
+;;; UNWIND-PROTECT is similar to CATCH, but more hairy. We make the
+;;; cleanup forms into a local function so that they can be referenced
+;;; both in the case where we are unwound and in any local exits. We
+;;; use %CLEANUP-FUNCTION on this to indicate that reference by
+;;; %UNWIND-PROTECT ISN'T "real", and thus doesn't cause creation of
+;;; an XEP.
+(def-ir1-translator unwind-protect ((protected &body cleanup) start cont)
+  #!+sb-doc
+  "Unwind-Protect Protected Cleanup*
+  Evaluate the form Protected, returning its values. The cleanup forms are
+  evaluated whenever the dynamic scope of the Protected form is exited (either
+  due to normal completion or a non-local exit such as THROW)."
+  (ir1-convert
+   start cont
+   (let ((cleanup-fun (gensym "CLEANUP-FUN-"))
+	 (drop-thru-tag (gensym "DROP-THRU-TAG-"))
+	 (exit-tag (gensym "EXIT-TAG-"))
+	 (next (gensym "NEXT"))
+	 (start (gensym "START"))
+	 (count (gensym "COUNT")))
+     `(flet ((,cleanup-fun () ,@cleanup nil))
+	;; FIXME: If we ever get DYNAMIC-EXTENT working, then
+	;; ,CLEANUP-FUN should probably be declared DYNAMIC-EXTENT,
+	;; and something can be done to make %ESCAPE-FUNCTION have
+	;; dynamic extent too.
+	(block ,drop-thru-tag
+	  (multiple-value-bind (,next ,start ,count)
+	      (block ,exit-tag
+		(%within-cleanup
+		    :unwind-protect
+		    (%unwind-protect (%escape-function ,exit-tag)
+				     (%cleanup-function ,cleanup-fun))
+		  (return-from ,drop-thru-tag ,protected)))
+	    (,cleanup-fun)
+	    (%continue-unwind ,next ,start ,count)))))))
+
+;;;; multiple-value stuff
+
+;;; If there are arguments, MULTIPLE-VALUE-CALL turns into an
+;;; MV-COMBINATION.
+;;;
+;;; If there are no arguments, then we convert to a normal
+;;; combination, ensuring that a MV-COMBINATION always has at least
+;;; one argument. This can be regarded as an optimization, but it is
+;;; more important for simplifying compilation of MV-COMBINATIONS.
+(def-ir1-translator multiple-value-call ((fun &rest args) start cont)
+  #!+sb-doc
+  "MULTIPLE-VALUE-CALL Function Values-Form*
+  Call Function, passing all the values of each Values-Form as arguments,
+  values from the first Values-Form making up the first argument, etc."
+  (let* ((fun-cont (make-continuation))
+	 (node (if args
+		   (make-mv-combination fun-cont)
+		   (make-combination fun-cont))))
+    (ir1-convert start fun-cont
+		 (if (and (consp fun) (eq (car fun) 'function))
+		     fun
+		     `(%coerce-callable-to-function ,fun)))
+    (setf (continuation-dest fun-cont) node)
+    (assert-continuation-type fun-cont
+			      (specifier-type '(or function symbol)))
+    (collect ((arg-conts))
+      (let ((this-start fun-cont))
+	(dolist (arg args)
+	  (let ((this-cont (make-continuation node)))
+	    (ir1-convert this-start this-cont arg)
+	    (setq this-start this-cont)
+	    (arg-conts this-cont)))
+	(prev-link node this-start)
+	(use-continuation node cont)
+	(setf (basic-combination-args node) (arg-conts))))))
+
+;;; MULTIPLE-VALUE-PROG1 is represented implicitly in IR1 by having a
+;;; the result code use result continuation (CONT), but transfer
+;;; control to the evaluation of the body. In other words, the result
+;;; continuation isn't IMMEDIATELY-USED-P by the nodes that compute
+;;; the result.
+;;;
+;;; In order to get the control flow right, we convert the result with
+;;; a dummy result continuation, then convert all the uses of the
+;;; dummy to be uses of CONT. If a use is an EXIT, then we also
+;;; substitute CONT for the dummy in the corresponding ENTRY node so
+;;; that they are consistent. Note that this doesn't amount to
+;;; changing the exit target, since the control destination of an exit
+;;; is determined by the block successor; we are just indicating the
+;;; continuation that the result is delivered to.
+;;;
+;;; We then convert the body, using another dummy continuation in its
+;;; own block as the result. After we are done converting the body, we
+;;; move all predecessors of the dummy end block to CONT's block.
+;;;
+;;; Note that we both exploit and maintain the invariant that the CONT
+;;; to an IR1 convert method either has no block or starts the block
+;;; that control should transfer to after completion for the form.
+;;; Nested MV-PROG1's work because during conversion of the result
+;;; form, we use dummy continuation whose block is the true control
+;;; destination.
+(def-ir1-translator multiple-value-prog1 ((result &rest forms) start cont)
+  #!+sb-doc
+  "MULTIPLE-VALUE-PROG1 Values-Form Form*
+  Evaluate Values-Form and then the Forms, but return all the values of
+  Values-Form."
+  (continuation-starts-block cont)
+  (let* ((dummy-result (make-continuation))
+	 (dummy-start (make-continuation))
+	 (cont-block (continuation-block cont)))
+    (continuation-starts-block dummy-start)
+    (ir1-convert start dummy-start result)
+
+    (substitute-continuation-uses cont dummy-start)
+
+    (continuation-starts-block dummy-result)
+    (ir1-convert-progn-body dummy-start dummy-result forms)
+    (let ((end-block (continuation-block dummy-result)))
+      (dolist (pred (block-pred end-block))
+	(unlink-blocks pred end-block)
+	(link-blocks pred cont-block))
+      (aver (not (continuation-dest dummy-result)))
+      (delete-continuation dummy-result)
+      (remove-from-dfo end-block))))
+
+;;;; interface to defining macros
+
+;;;; FIXME:
+;;;;   classic CMU CL comment:
+;;;;     DEFMACRO and DEFUN expand into calls to %DEFxxx functions
+;;;;     so that we get a chance to see what is going on. We define
+;;;;     IR1 translators for these functions which look at the
+;;;;     definition and then generate a call to the %%DEFxxx function.
+;;;; Alas, this implementation doesn't do the right thing for
+;;;; non-toplevel uses of these forms, so this should probably
+;;;; be changed to use EVAL-WHEN instead.
+
+;;; Return a new source path with any stuff intervening between the
+;;; current path and the first form beginning with NAME stripped off.
+;;; This is used to hide the guts of DEFmumble macros to prevent
+;;; annoying error messages.
+(defun revert-source-path (name)
+  (do ((path *current-path* (cdr path)))
+      ((null path) *current-path*)
+    (let ((first (first path)))
+      (when (or (eq first name)
+		(eq first 'original-source-start))
+	(return path)))))
+
+;;; Warn about incompatible or illegal definitions and add the macro
+;;; to the compiler environment.
+;;;
+;;; Someday we could check for macro arguments being incompatibly
+;;; redefined. Doing this right will involve finding the old macro
+;;; lambda-list and comparing it with the new one.
+(def-ir1-translator %defmacro ((qname qdef lambda-list doc) start cont
+			       :kind :function)
+  (let (;; QNAME is typically a quoted name. I think the idea is to
+	;; let %DEFMACRO work as an ordinary function when
+	;; interpreting. Whatever the reason the quote is there, we
+	;; don't want it any more. -- WHN 19990603
+	(name (eval qname))
+	;; QDEF should be a sharp-quoted definition. We don't want to
+	;; make a function of it just yet, so we just drop the
+	;; sharp-quote.
+	(def (progn
+	       (aver (eq 'function (first qdef)))
+	       (aver (proper-list-of-length-p qdef 2))
+	       (second qdef))))
+
+    (/show "doing IR1 translator for %DEFMACRO" name)
+
+    (unless (symbolp name)
+      (compiler-error "The macro name ~S is not a symbol." name))
+
+    (ecase (info :function :kind name)
+      ((nil))
+      (:function
+       (remhash name *free-functions*)
+       (undefine-function-name name)
+       (compiler-warning
+	"~S is being redefined as a macro when it was ~
+         previously ~(~A~) to be a function."
+	name
+	(info :function :where-from name)))
+      (:macro)
+      (:special-form
+       (compiler-error "The special form ~S can't be redefined as a macro."
+		       name)))
+
+    (setf (info :function :kind name) :macro
+	  (info :function :where-from name) :defined
+	  (info :function :macro-function name) (coerce def 'function))
+
+    (let* ((*current-path* (revert-source-path 'defmacro))
+	   (fun (ir1-convert-lambda def name)))
+      (setf (leaf-name fun)
+	    (concatenate 'string "DEFMACRO " (symbol-name name)))
+      (setf (functional-arg-documentation fun) (eval lambda-list))
+
+      (ir1-convert start cont `(%%defmacro ',name ,fun ,doc)))
+
+    (when sb!xc:*compile-print*
+      ;; FIXME: It would be nice to convert this, and the other places
+      ;; which create compiler diagnostic output prefixed by
+      ;; semicolons, to use some common utility which automatically
+      ;; prefixes all its output with semicolons. (The addition of
+      ;; semicolon prefixes was introduced ca. sbcl-0.6.8.10 as the
+      ;; "MNA compiler message patch", and implemented by modifying a
+      ;; bunch of output statements on a case-by-case basis, which
+      ;; seems unnecessarily error-prone and unclear, scattering
+      ;; implicit information about output style throughout the
+      ;; system.) Starting by rewriting COMPILER-MUMBLE to add
+      ;; semicolon prefixes would be a good start, and perhaps also:
+      ;;   * Add semicolon prefixes for "FOO assembled" messages emitted 
+      ;;     when e.g. src/assembly/x86/assem-rtns.lisp is processed.
+      ;;   * At least some debugger output messages deserve semicolon
+      ;;     prefixes too:
+      ;;     ** restarts table
+      ;;     ** "Within the debugger, you can type HELP for help."
+      (compiler-mumble "~&; converted ~S~%" name))))
+
+(def-ir1-translator %define-compiler-macro ((name def lambda-list doc)
+					    start cont
+					    :kind :function)
+  (let ((name (eval name))
+	(def (second def))) ; We don't want to make a function just yet...
+
+    (when (eq (info :function :kind name) :special-form)
+      (compiler-error "attempt to define a compiler-macro for special form ~S"
+		      name))
+
+    (setf (info :function :compiler-macro-function name)
+	  (coerce def 'function))
+
+    (let* ((*current-path* (revert-source-path 'define-compiler-macro))
+	   (fun (ir1-convert-lambda def name)))
+      (setf (leaf-name fun)
+	    (let ((*print-case* :upcase))
+	      (format nil "DEFINE-COMPILER-MACRO ~S" name)))
+      (setf (functional-arg-documentation fun) (eval lambda-list))
+
+      (ir1-convert start cont `(%%define-compiler-macro ',name ,fun ,doc)))
+
+    (when sb!xc:*compile-print*
+      (compiler-mumble "~&; converted ~S~%" name))))
diff --git a/src/compiler/ir1report.lisp b/src/compiler/ir1report.lisp
new file mode 100644
index 0000000..bfaab10
--- /dev/null
+++ b/src/compiler/ir1report.lisp
@@ -0,0 +1,518 @@
+;;;; machinery for reporting errors/warnings/notes/whatnot from
+;;;; the compiler
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+;;;; compiler error context determination
+
+(declaim (special *current-path*))
+
+;;; We bind print level and length when printing out messages so that
+;;; we don't dump huge amounts of garbage.
+;;;
+;;; FIXME: It's not possible to get the defaults right for everyone.
+;;; So: Should these variables be in the SB-EXT package? Or should we
+;;; just get rid of them completely and just use the bare
+;;; CL:*PRINT-FOO* variables instead?
+(declaim (type (or unsigned-byte null)
+	       *compiler-error-print-level*
+	       *compiler-error-print-length*
+	       *compiler-error-print-lines*))
+(defvar *compiler-error-print-level* 5
+  #!+sb-doc
+  "the value for *PRINT-LEVEL* when printing compiler error messages")
+(defvar *compiler-error-print-length* 10
+  #!+sb-doc
+  "the value for *PRINT-LENGTH* when printing compiler error messages")
+(defvar *compiler-error-print-lines* 12
+  #!+sb-doc
+  "the value for *PRINT-LINES* when printing compiler error messages")
+
+(defvar *enclosing-source-cutoff* 1
+  #!+sb-doc
+  "The maximum number of enclosing non-original source forms (i.e. from
+  macroexpansion) that we print in full. For additional enclosing forms, we
+  print only the CAR.")
+(declaim (type unsigned-byte *enclosing-source-cutoff*))
+
+;;; We separate the determination of compiler error contexts from the
+;;; actual signalling of those errors by objectifying the error
+;;; context. This allows postponement of the determination of how (and
+;;; if) to signal the error.
+;;;
+;;; We take care not to reference any of the IR1 so that pending
+;;; potential error messages won't prevent the IR1 from being GC'd. To
+;;; this end, we convert source forms to strings so that source forms
+;;; that contain IR1 references (e.g. %DEFUN) don't hold onto the IR.
+(defstruct (compiler-error-context
+	    #-no-ansi-print-object
+	    (:print-object (lambda (x stream)
+			     (print-unreadable-object (x stream :type t))))
+	    (:copier nil))
+  ;; a list of the stringified CARs of the enclosing non-original source forms
+  ;; exceeding the *enclosing-source-cutoff*
+  (enclosing-source nil :type list)
+  ;; a list of stringified enclosing non-original source forms
+  (source nil :type list)
+  ;; the stringified form in the original source that expanded into SOURCE
+  (original-source (required-argument) :type simple-string)
+  ;; a list of prefixes of "interesting" forms that enclose original-source
+  (context nil :type list)
+  ;; the FILE-INFO-NAME for the relevant FILE-INFO
+  (file-name (required-argument)
+	     :type (or pathname (member :lisp :stream)))
+  ;; the file position at which the top-level form starts, if applicable
+  (file-position nil :type (or index null))
+  ;; the original source part of the source path
+  (original-source-path nil :type list))
+
+;;; If true, this is the node which is used as context in compiler warning
+;;; messages.
+(declaim (type (or null compiler-error-context node) *compiler-error-context*))
+(defvar *compiler-error-context* nil)
+
+;;; a hashtable mapping macro names to source context parsers. Each parser
+;;; function returns the source-context list for that form.
+(defvar *source-context-methods* (make-hash-table))
+
+;;; documentation originally from cmu-user.tex:
+;;;   This macro defines how to extract an abbreviated source context from
+;;;   the \var{name}d form when it appears in the compiler input.
+;;;   \var{lambda-list} is a \code{defmacro} style lambda-list used to
+;;;   parse the arguments. The \var{body} should return a list of
+;;;   subforms that can be printed on about one line. There are
+;;;   predefined methods for \code{defstruct}, \code{defmethod}, etc. If
+;;;   no method is defined, then the first two subforms are returned.
+;;;   Note that this facility implicitly determines the string name
+;;;   associated with anonymous functions.
+;;; So even though SBCL itself only uses this macro within this file,
+;;; it's a reasonable thing to put in SB-EXT in case some dedicated
+;;; user wants to do some heavy tweaking to make SBCL give more
+;;; informative output about his code.
+(defmacro def-source-context (name lambda-list &body body)
+  #!+sb-doc
+  "DEF-SOURCE-CONTEXT Name Lambda-List Form*
+   This macro defines how to extract an abbreviated source context from the
+   Named form when it appears in the compiler input. Lambda-List is a DEFMACRO
+   style lambda-list used to parse the arguments. The Body should return a
+   list of subforms suitable for a \"~{~S ~}\" format string."
+  (let ((n-whole (gensym)))
+    `(setf (gethash ',name *source-context-methods*)
+	   #'(lambda (,n-whole)
+	       (destructuring-bind ,lambda-list ,n-whole ,@body)))))
+
+(def-source-context defstruct (name-or-options &rest slots)
+  (declare (ignore slots))
+  `(defstruct ,(if (consp name-or-options)
+		   (car name-or-options)
+		   name-or-options)))
+
+(def-source-context function (thing)
+  (if (and (consp thing) (eq (first thing) 'lambda) (consp (rest thing)))
+      `(lambda ,(second thing))
+      `(function ,thing)))
+
+;;; Return the first two elements of FORM if FORM is a list. Take the
+;;; CAR of the second form if appropriate.
+(defun source-form-context (form)
+  (cond ((atom form) nil)
+	((>= (length form) 2)
+	 (funcall (gethash (first form) *source-context-methods*
+			   #'(lambda (x)
+			       (declare (ignore x))
+			       (list (first form) (second form))))
+		  (rest form)))
+	(t
+	 form)))
+
+;;; Given a source path, return the original source form and a
+;;; description of the interesting aspects of the context in which it
+;;; appeared. The context is a list of lists, one sublist per context
+;;; form. The sublist is a list of some of the initial subforms of the
+;;; context form.
+;;;
+;;; For now, we use the first two subforms of each interesting form. A
+;;; form is interesting if the first element is a symbol beginning
+;;; with "DEF" and it is not the source form. If there is no
+;;; DEF-mumble, then we use the outermost containing form. If the
+;;; second subform is a list, then in some cases we return the CAR of
+;;; that form rather than the whole form (i.e. don't show DEFSTRUCT
+;;; options, etc.)
+(defun find-original-source (path)
+  (declare (list path))
+  (let* ((rpath (reverse (source-path-original-source path)))
+	 (tlf (first rpath))
+	 (root (find-source-root tlf *source-info*)))
+    (collect ((context))
+      (let ((form root)
+	    (current (rest rpath)))
+	(loop
+	  (when (atom form)
+	    (aver (null current))
+	    (return))
+	  (let ((head (first form)))
+	    (when (symbolp head)
+	      (let ((name (symbol-name head)))
+		(when (and (>= (length name) 3) (string= name "DEF" :end1 3))
+		  (context (source-form-context form))))))
+	  (when (null current) (return))
+	  (setq form (nth (pop current) form)))
+	
+	(cond ((context)
+	       (values form (context)))
+	      ((and path root)
+	       (let ((c (source-form-context root)))
+		 (values form (if c (list c) nil))))
+	      (t
+	       (values '(unable to locate source)
+		       '((some strange place)))))))))
+
+;;; Convert a source form to a string, suitably formatted for use in
+;;; compiler warnings.
+(defun stringify-form (form &optional (pretty t))
+  (let ((*print-level* *compiler-error-print-level*)
+	(*print-length* *compiler-error-print-length*)
+	(*print-lines* *compiler-error-print-lines*)
+	(*print-pretty* pretty))
+    (if pretty
+	(format nil "~<~@;  ~S~:>" (list form))
+	(prin1-to-string form))))
+
+;;; Return a COMPILER-ERROR-CONTEXT structure describing the current
+;;; error context, or NIL if we can't figure anything out. ARGS is a
+;;; list of things that are going to be printed out in the error
+;;; message, and can thus be blown off when they appear in the source
+;;; context.
+(defun find-error-context (args)
+  (let ((context *compiler-error-context*))
+    (if (compiler-error-context-p context)
+	context
+	(let ((path (or (and (boundp '*current-path*) *current-path*)
+			(if context
+			    (node-source-path context)
+			    nil))))
+	  (when (and *source-info* path)
+	    (multiple-value-bind (form src-context) (find-original-source path)
+	      (collect ((full nil cons)
+			(short nil cons))
+		(let ((forms (source-path-forms path))
+		      (n 0))
+		  (dolist (src (if (member (first forms) args)
+				   (rest forms)
+				   forms))
+		    (if (>= n *enclosing-source-cutoff*)
+			(short (stringify-form (if (consp src)
+						   (car src)
+						   src)
+					       nil))
+			(full (stringify-form src)))
+		    (incf n)))
+
+		(let* ((tlf (source-path-tlf-number path))
+		       (file-info (source-info-file-info *source-info*)))
+		  (make-compiler-error-context
+		   :enclosing-source (short)
+		   :source (full)
+		   :original-source (stringify-form form)
+		   :context src-context
+		   :file-name (file-info-name file-info)
+		   :file-position
+		   (multiple-value-bind (ignore pos)
+		       (find-source-root tlf *source-info*)
+		     (declare (ignore ignore))
+		     pos)
+		   :original-source-path
+		   (source-path-original-source path))))))))))
+
+;;;; printing error messages
+
+;;; We save the context information that we printed out most recently
+;;; so that we don't print it out redundantly.
+
+;;; The last COMPILER-ERROR-CONTEXT that we printed.
+(defvar *last-error-context* nil)
+(declaim (type (or compiler-error-context null) *last-error-context*))
+
+;;; The format string and args for the last error we printed.
+(defvar *last-format-string* nil)
+(defvar *last-format-args* nil)
+(declaim (type (or string null) *last-format-string*))
+(declaim (type list *last-format-args*))
+
+;;; The number of times that the last error message has been emitted,
+;;; so that we can compress duplicate error messages.
+(defvar *last-message-count* 0)
+(declaim (type index *last-message-count*))
+
+;;; If the last message was given more than once, then print out an
+;;; indication of how many times it was repeated. We reset the message
+;;; count when we are done.
+(defun note-message-repeats (&optional (terpri t))
+  (cond ((= *last-message-count* 1)
+	 (when terpri (terpri *error-output*)))
+	((> *last-message-count* 1)
+          (format *error-output* "~&; [Last message occurs ~D times.]~2%"
+		 *last-message-count*)))
+  (setq *last-message-count* 0))
+
+;;; Print out the message, with appropriate context if we can find it.
+;;; If the context is different from the context of the last message
+;;; we printed, then we print the context. If the original source is
+;;; different from the source we are working on, then we print the
+;;; current source in addition to the original source.
+;;;
+;;; We suppress printing of messages identical to the previous, but
+;;; record the number of times that the message is repeated.
+(defun print-compiler-message (format-string format-args)
+
+  (declare (type simple-string format-string))
+  (declare (type list format-args))
+  
+  (let ((stream *error-output*)
+	(context (find-error-context format-args)))
+    (cond
+     (context
+      (let ((file (compiler-error-context-file-name context))
+	    (in (compiler-error-context-context context))
+	    (form (compiler-error-context-original-source context))
+	    (enclosing (compiler-error-context-enclosing-source context))
+	    (source (compiler-error-context-source context))
+	    (last *last-error-context*))
+
+	(unless (and last
+		     (equal file (compiler-error-context-file-name last)))
+	  (when (pathnamep file)
+	    (note-message-repeats)
+	    (setq last nil)
+            (format stream "~2&; file: ~A~%" (namestring file))))
+
+	(unless (and last
+		     (equal in (compiler-error-context-context last)))
+	  (note-message-repeats)
+	  (setq last nil)
+          (format stream "~&")
+          (pprint-logical-block (stream nil :per-line-prefix "; ")
+            (format stream "in:~{~<~%    ~4:;~{ ~S~}~>~^ =>~}" in))
+          (format stream "~%"))
+
+
+	(unless (and last
+		     (string= form
+			      (compiler-error-context-original-source last)))
+	  (note-message-repeats)
+	  (setq last nil)
+          (format stream "~&")
+          (pprint-logical-block (stream nil :per-line-prefix "; ")
+            (format stream "  ~A" form))
+          (format stream "~&"))
+
+	(unless (and last
+		     (equal enclosing
+			    (compiler-error-context-enclosing-source last)))
+	  (when enclosing
+	    (note-message-repeats)
+	    (setq last nil)
+	    (format stream "~&; --> ~{~<~%; --> ~1:;~A~> ~}~%" enclosing)))
+
+	(unless (and last
+		     (equal source (compiler-error-context-source last)))
+	  (setq *last-format-string* nil)
+	  (when source
+	    (note-message-repeats)
+	    (dolist (src source)
+              (format stream "~&")
+              (write-string "; ==>" stream)
+              (format stream "~&")
+              (pprint-logical-block (stream nil :per-line-prefix "; ")
+                (write-string src stream)))))))
+     (t
+       (format stream "~&")
+      (note-message-repeats)
+      (setq *last-format-string* nil)
+       (format stream "~&")))
+
+    (setq *last-error-context* context)
+
+    (unless (and (equal format-string *last-format-string*)
+		 (tree-equal format-args *last-format-args*))
+      (note-message-repeats nil)
+      (setq *last-format-string* format-string)
+      (setq *last-format-args* format-args)
+      (let ((*print-level*  *compiler-error-print-level*)
+	    (*print-length* *compiler-error-print-length*)
+	    (*print-lines*  *compiler-error-print-lines*))
+        (format stream "~&")
+        (pprint-logical-block (stream nil :per-line-prefix "; ")
+          (format stream "~&~?" format-string format-args))
+        (format stream "~&"))))
+
+  (incf *last-message-count*)
+  (values))
+
+(defun print-compiler-condition (condition)
+  (declare (type condition condition))
+  (let (;; These different classes of conditions have different
+	;; effects on the return codes of COMPILE-FILE, so it's nice
+	;; for users to be able to pick them out by lexical search
+	;; through the output.
+	(what (etypecase condition
+		(style-warning 'style-warning)
+		(warning 'warning)
+		(error 'error))))
+    (multiple-value-bind (format-string format-args)
+	(if (typep condition 'simple-condition)
+	    (values (simple-condition-format-control condition)
+		    (simple-condition-format-arguments condition))
+	    (values "~A"
+		    (list (with-output-to-string (s)
+			    (princ condition s)))))
+      (print-compiler-message (format nil
+				      "caught ~S:~%  ~A"
+				      what
+				      format-string)
+			      format-args)))
+  (values))
+
+;;; COMPILER-NOTE is vaguely like COMPILER-ERROR and the other
+;;; condition-signalling functions, but it just writes some output
+;;; instead of signalling. (In CMU CL, it did signal a condition, but
+;;; this didn't seem to work all that well; it was weird to have
+;;; COMPILE-FILE return with WARNINGS-P set when the only problem was
+;;; that the compiler couldn't figure out how to compile something as
+;;; efficiently as it liked.)
+(defun compiler-note (format-string &rest format-args)
+  (unless (if *compiler-error-context*
+	      (policy *compiler-error-context* (= inhibit-warnings 3))
+	      (policy *lexenv* (= inhibit-warnings 3)))
+    (incf *compiler-note-count*)
+    (print-compiler-message (format nil "note: ~A" format-string)
+			    format-args))
+  (values))
+
+;;; Issue a note when we might or might not be in the compiler.
+(defun maybe-compiler-note (&rest rest)
+  (if (boundp '*lexenv*) ; if we're in the compiler
+      (apply #'compiler-note rest)
+      (let ((stream *error-output*))
+	(pprint-logical-block (stream nil :per-line-prefix ";")
+	  
+	  (format stream " note: ~3I~_")
+	  (pprint-logical-block (stream nil)
+	    (apply #'format stream rest)))
+	(fresh-line stream)))) ; (outside logical block, no per-line-prefix)
+
+;;; The politically correct way to print out progress messages and
+;;; such like. We clear the current error context so that we know that
+;;; it needs to be reprinted, and we also Force-Output so that the
+;;; message gets seen right away.
+(declaim (ftype (function (string &rest t) (values)) compiler-mumble))
+(defun compiler-mumble (format-string &rest format-args)
+  (note-message-repeats)
+  (setq *last-error-context* nil)
+  (apply #'format *error-output* format-string format-args)
+  (force-output *error-output*)
+  (values))
+
+;;; Return a string that somehow names the code in COMPONENT. We use
+;;; the source path for the bind node for an arbitrary entry point to
+;;; find the source context, then return that as a string.
+(declaim (ftype (function (component) simple-string) find-component-name))
+(defun find-component-name (component)
+  (let ((ep (first (block-succ (component-head component)))))
+    (aver ep) ; else no entry points??
+    (multiple-value-bind (form context)
+	(find-original-source
+	 (node-source-path (continuation-next (block-start ep))))
+      (declare (ignore form))
+      (let ((*print-level* 2)
+	    (*print-pretty* nil))
+	(format nil "~{~{~S~^ ~}~^ => ~}" context)))))
+
+;;;; condition system interface
+
+;;; Keep track of how many times each kind of condition happens.
+(defvar *compiler-error-count*)
+(defvar *compiler-warning-count*)
+(defvar *compiler-style-warning-count*)
+(defvar *compiler-note-count*)
+
+;;; Keep track of whether any surrounding COMPILE or COMPILE-FILE call
+;;; should return WARNINGS-P or FAILURE-P.
+(defvar *failure-p*)
+(defvar *warnings-p*)
+
+;;; condition handlers established by the compiler. We re-signal the
+;;; condition, then if it isn't handled, we increment our warning
+;;; counter and print the error message.
+(defun compiler-error-handler (condition)
+  (signal condition)
+  (incf *compiler-error-count*)
+  (setf *warnings-p* t
+	*failure-p* t)
+  (print-compiler-condition condition)
+  (continue condition))
+(defun compiler-warning-handler (condition)
+  (signal condition)
+  (incf *compiler-warning-count*)
+  (setf *warnings-p* t
+	*failure-p* t)
+  (print-compiler-condition condition)
+  (muffle-warning condition))
+(defun compiler-style-warning-handler (condition)
+  (signal condition)
+  (incf *compiler-style-warning-count*)
+  (setf *warnings-p* t)
+  (print-compiler-condition condition)
+  (muffle-warning condition))
+
+;;;; undefined warnings
+
+(defvar *undefined-warning-limit* 3
+  #!+sb-doc
+  "If non-null, then an upper limit on the number of unknown function or type
+  warnings that the compiler will print for any given name in a single
+  compilation. This prevents excessive amounts of output when the real
+  problem is a missing definition (as opposed to a typo in the use.)")
+
+;;; Make an entry in the *UNDEFINED-WARNINGS* describing a reference
+;;; to NAME of the specified KIND. If we have exceeded the warning
+;;; limit, then just increment the count, otherwise note the current
+;;; error context.
+;;;
+;;; Undefined types are noted by a condition handler in
+;;; WITH-COMPILATION-UNIT, which can potentially be invoked outside
+;;; the compiler, hence the BOUNDP check.
+(defun note-undefined-reference (name kind)
+  (unless (and
+	   ;; Check for boundness so we don't blow up if we're called
+	   ;; when IR1 conversion isn't going on.
+	   (boundp '*lexenv*)
+	   ;; FIXME: I'm pretty sure the INHIBIT-WARNINGS test below
+	   ;; isn't a good idea; we should have INHIBIT-WARNINGS
+	   ;; affect compiler notes, not STYLE-WARNINGs. And I'm not
+	   ;; sure what the BOUNDP '*LEXENV* test above is for; it's
+	   ;; likely a good idea, but it probably deserves an
+	   ;; explanatory comment.
+	   (policy *lexenv* (= inhibit-warnings 3)))
+    (let* ((found (dolist (warning *undefined-warnings* nil)
+		    (when (and (equal (undefined-warning-name warning) name)
+			       (eq (undefined-warning-kind warning) kind))
+		      (return warning))))
+	   (res (or found
+		    (make-undefined-warning :name name :kind kind))))
+      (unless found (push res *undefined-warnings*))
+      (when (or (not *undefined-warning-limit*)
+		(< (undefined-warning-count res) *undefined-warning-limit*))
+	(push (find-error-context (list name))
+	      (undefined-warning-warnings res)))
+      (incf (undefined-warning-count res))))
+  (values))
diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index 45f95c6..a51ab3a 100644
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -23,7 +23,7 @@
 (declaim (hash-table *source-paths*))
 (defvar *source-paths*)
 
-;;; *CURRENT-COMPONENT* is the Component structure which we link
+;;; *CURRENT-COMPONENT* is the COMPONENT structure which we link
 ;;; blocks into as we generate them. This just serves to glue the
 ;;; emitted blocks together until local call analysis and flow graph
 ;;; canonicalization figure out what is really going on. We need to
@@ -1808,1069 +1808,6 @@
 	(setf (leaf-name res) name)
 	res))))
 
-;;; FIXME: This file is rather long, and contains two distinct sections,
-;;; transform machinery above this point and transforms themselves below this
-;;; point. Why not split it in two? (ir1translate.lisp and
-;;; ir1translators.lisp?) Then consider byte-compiling the translators, too.
-
-;;;; control special forms
-
-(def-ir1-translator progn ((&rest forms) start cont)
-  #!+sb-doc
-  "Progn Form*
-  Evaluates each Form in order, returning the values of the last form. With no
-  forms, returns NIL."
-  (ir1-convert-progn-body start cont forms))
-
-(def-ir1-translator if ((test then &optional else) start cont)
-  #!+sb-doc
-  "If Predicate Then [Else]
-  If Predicate evaluates to non-null, evaluate Then and returns its values,
-  otherwise evaluate Else and return its values. Else defaults to NIL."
-  (let* ((pred (make-continuation))
-	 (then-cont (make-continuation))
-	 (then-block (continuation-starts-block then-cont))
-	 (else-cont (make-continuation))
-	 (else-block (continuation-starts-block else-cont))
-	 (dummy-cont (make-continuation))
-	 (node (make-if :test pred
-			:consequent then-block
-			:alternative else-block)))
-    (setf (continuation-dest pred) node)
-    (ir1-convert start pred test)
-    (prev-link node pred)
-    (use-continuation node dummy-cont)
-
-    (let ((start-block (continuation-block pred)))
-      (setf (block-last start-block) node)
-      (continuation-starts-block cont)
-
-      (link-blocks start-block then-block)
-      (link-blocks start-block else-block)
-
-      (ir1-convert then-cont cont then)
-      (ir1-convert else-cont cont else))))
-
-;;;; BLOCK and TAGBODY
-
-;;;; We make an Entry node to mark the start and a :Entry cleanup to
-;;;; mark its extent. When doing GO or RETURN-FROM, we emit an Exit
-;;;; node.
-
-;;; Make a :ENTRY cleanup and emit an ENTRY node, then convert the
-;;; body in the modified environment. We make CONT start a block now,
-;;; since if it was done later, the block would be in the wrong
-;;; environment.
-(def-ir1-translator block ((name &rest forms) start cont)
-  #!+sb-doc
-  "Block Name Form*
-  Evaluate the Forms as a PROGN. Within the lexical scope of the body,
-  (RETURN-FROM Name Value-Form) can be used to exit the form, returning the
-  result of Value-Form."
-  (unless (symbolp name)
-    (compiler-error "The block name ~S is not a symbol." name))
-  (continuation-starts-block cont)
-  (let* ((dummy (make-continuation))
-	 (entry (make-entry))
-	 (cleanup (make-cleanup :kind :block
-				:mess-up entry)))
-    (push entry (lambda-entries (lexenv-lambda *lexenv*)))
-    (setf (entry-cleanup entry) cleanup)
-    (prev-link entry start)
-    (use-continuation entry dummy)
-    
-    (let* ((env-entry (list entry cont))
-           (*lexenv* (make-lexenv :blocks (list (cons name env-entry))
-				  :cleanup cleanup)))
-      (push env-entry (continuation-lexenv-uses cont))
-      (ir1-convert-progn-body dummy cont forms))))
-
-
-;;; We make CONT start a block just so that it will have a block
-;;; assigned. People assume that when they pass a continuation into
-;;; IR1-CONVERT as CONT, it will have a block when it is done.
-(def-ir1-translator return-from ((name &optional value)
-				 start cont)
-  #!+sb-doc
-  "Return-From Block-Name Value-Form
-  Evaluate the Value-Form, returning its values from the lexically enclosing
-  BLOCK Block-Name. This is constrained to be used only within the dynamic
-  extent of the BLOCK."
-  (continuation-starts-block cont)
-  (let* ((found (or (lexenv-find name blocks)
-		    (compiler-error "return for unknown block: ~S" name)))
-	 (value-cont (make-continuation))
-	 (entry (first found))
-	 (exit (make-exit :entry entry
-			  :value value-cont)))
-    (push exit (entry-exits entry))
-    (setf (continuation-dest value-cont) exit)
-    (ir1-convert start value-cont value)
-    (prev-link exit value-cont)
-    (use-continuation exit (second found))))
-
-;;; Return a list of the segments of a TAGBODY. Each segment looks
-;;; like (<tag> <form>* (go <next tag>)). That is, we break up the
-;;; tagbody into segments of non-tag statements, and explicitly
-;;; represent the drop-through with a GO. The first segment has a
-;;; dummy NIL tag, since it represents code before the first tag. The
-;;; last segment (which may also be the first segment) ends in NIL
-;;; rather than a GO.
-(defun parse-tagbody (body)
-  (declare (list body))
-  (collect ((segments))
-    (let ((current (cons nil body)))
-      (loop
-	(let ((tag-pos (position-if (complement #'listp) current :start 1)))
-	  (unless tag-pos
-	    (segments `(,@current nil))
-	    (return))
-	  (let ((tag (elt current tag-pos)))
-	    (when (assoc tag (segments))
-	      (compiler-error
-	       "The tag ~S appears more than once in the tagbody."
-	       tag))
-	    (unless (or (symbolp tag) (integerp tag))
-	      (compiler-error "~S is not a legal tagbody statement." tag))
-	    (segments `(,@(subseq current 0 tag-pos) (go ,tag))))
-	  (setq current (nthcdr tag-pos current)))))
-    (segments)))
-
-;;; Set up the cleanup, emitting the entry node. Then make a block for
-;;; each tag, building up the tag list for LEXENV-TAGS as we go.
-;;; Finally, convert each segment with the precomputed Start and Cont
-;;; values.
-(def-ir1-translator tagbody ((&rest statements) start cont)
-  #!+sb-doc
-  "Tagbody {Tag | Statement}*
-  Define tags for used with GO. The Statements are evaluated in order
-  (skipping Tags) and NIL is returned. If a statement contains a GO to a
-  defined Tag within the lexical scope of the form, then control is transferred
-  to the next statement following that tag. A Tag must an integer or a
-  symbol. A statement must be a list. Other objects are illegal within the
-  body."
-  (continuation-starts-block cont)
-  (let* ((dummy (make-continuation))
-	 (entry (make-entry))
-	 (segments (parse-tagbody statements))
-	 (cleanup (make-cleanup :kind :tagbody
-				:mess-up entry)))
-    (push entry (lambda-entries (lexenv-lambda *lexenv*)))
-    (setf (entry-cleanup entry) cleanup)
-    (prev-link entry start)
-    (use-continuation entry dummy)
-
-    (collect ((tags)
-	      (starts)
-	      (conts))
-      (starts dummy)
-      (dolist (segment (rest segments))
-	(let* ((tag-cont (make-continuation))
-               (tag (list (car segment) entry tag-cont)))          
-	  (conts tag-cont)
-	  (starts tag-cont)
-	  (continuation-starts-block tag-cont)
-          (tags tag)
-          (push (cdr tag) (continuation-lexenv-uses tag-cont))))
-      (conts cont)
-
-      (let ((*lexenv* (make-lexenv :cleanup cleanup :tags (tags))))
-	(mapc (lambda (segment start cont)
-		(ir1-convert-progn-body start cont (rest segment)))
-	      segments (starts) (conts))))))
-
-;;; Emit an EXIT node without any value.
-(def-ir1-translator go ((tag) start cont)
-  #!+sb-doc
-  "Go Tag
-  Transfer control to the named Tag in the lexically enclosing TAGBODY. This
-  is constrained to be used only within the dynamic extent of the TAGBODY."
-  (continuation-starts-block cont)
-  (let* ((found (or (lexenv-find tag tags :test #'eql)
-		    (compiler-error "Go to nonexistent tag: ~S." tag)))
-	 (entry (first found))
-	 (exit (make-exit :entry entry)))
-    (push exit (entry-exits entry))
-    (prev-link exit start)
-    (use-continuation exit (second found))))
-
-;;;; translators for compiler-magic special forms
-
-;;; This handles EVAL-WHEN in non-top-level forms. (EVAL-WHENs in
-;;; top-level forms are picked off and handled by PROCESS-TOP-LEVEL-FORM,
-;;; so that they're never seen at this level.)
-;;;
-;;; ANSI "3.2.3.1 Processing of Top Level Forms" says that processing
-;;; of non-top-level EVAL-WHENs is very simple:
-;;;   EVAL-WHEN forms cause compile-time evaluation only at top level.
-;;;   Both :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL situation specifications
-;;;   are ignored for non-top-level forms. For non-top-level forms, an
-;;;   eval-when specifying the :EXECUTE situation is treated as an
-;;;   implicit PROGN including the forms in the body of the EVAL-WHEN
-;;;   form; otherwise, the forms in the body are ignored. 
-(def-ir1-translator eval-when ((situations &rest forms) start cont)
-  #!+sb-doc
-  "EVAL-WHEN (Situation*) Form*
-  Evaluate the Forms in the specified Situations (any of :COMPILE-TOPLEVEL,
-  :LOAD-TOPLEVEL, or :EXECUTE, or (deprecated) COMPILE, LOAD, or EVAL)."
-  (multiple-value-bind (ct lt e) (parse-eval-when-situations situations)
-    (declare (ignore ct lt))
-    (ir1-convert-progn-body start cont (and e forms)))
-  (values))
-
-;;; common logic for MACROLET and SYMBOL-MACROLET
-;;;
-;;; Call DEFINITIONIZE-FUN on each element of DEFINITIONS to find its
-;;; in-lexenv representation, stuff the results into *LEXENV*, and
-;;; call FUN (with no arguments).
-(defun %funcall-in-foomacrolet-lexenv (definitionize-fun
-				       definitionize-keyword
-				       definitions
-				       fun)
-  (declare (type function definitionize-fun fun))
-  (declare (type (member :variables :functions) definitionize-keyword))
-  (declare (type list definitions))
-  (unless (= (length definitions)
-             (length (remove-duplicates definitions :key #'first)))
-    (compiler-style-warning "duplicate definitions in ~S" definitions))
-  (let* ((processed-definitions (mapcar definitionize-fun definitions))
-         (*lexenv* (make-lexenv definitionize-keyword processed-definitions)))
-    (funcall fun)))
-
-;;; Tweak *LEXENV* to include the DEFINITIONS from a MACROLET, then
-;;; call FUN (with no arguments).
-;;;
-;;; This is split off from the IR1 convert method so that it can be
-;;; shared by the special-case top-level MACROLET processing code.
-(defun funcall-in-macrolet-lexenv (definitions fun)
-  (%funcall-in-foomacrolet-lexenv
-   (lambda (definition)
-     (unless (list-of-length-at-least-p definition 2)
-       (compiler-error
-	"The list ~S is too short to be a legal local macro definition."
-	definition))
-     (destructuring-bind (name arglist &body body) definition
-       (unless (symbolp name)
-	 (compiler-error "The local macro name ~S is not a symbol." name))
-       (let ((whole (gensym "WHOLE"))
-	     (environment (gensym "ENVIRONMENT")))
-	 (multiple-value-bind (body local-decls)
-	     (parse-defmacro arglist whole body name 'macrolet
-			     :environment environment)
-	   `(,name macro .
-		   ,(compile nil
-			     `(lambda (,whole ,environment)
-				,@local-decls
-				(block ,name ,body))))))))
-   :functions
-   definitions
-   fun))
-
-(def-ir1-translator macrolet ((definitions &rest body) start cont)
-  #!+sb-doc
-  "MACROLET ({(Name Lambda-List Form*)}*) Body-Form*
-  Evaluate the Body-Forms in an environment with the specified local macros
-  defined. Name is the local macro name, Lambda-List is the DEFMACRO style
-  destructuring lambda list, and the Forms evaluate to the expansion. The
-  Forms are evaluated in the null environment."
-  (funcall-in-macrolet-lexenv definitions
-			      (lambda ()
-				(ir1-translate-locally body start cont))))
-
-(defun funcall-in-symbol-macrolet-lexenv (definitions fun)
-  (%funcall-in-foomacrolet-lexenv
-   (lambda (definition)
-     (unless (proper-list-of-length-p definition 2)
-       (compiler-error "malformed symbol/expansion pair: ~S" definition))
-     (destructuring-bind (name expansion) definition
-       (unless (symbolp name)
-         (compiler-error
-          "The local symbol macro name ~S is not a symbol."
-          name))
-       `(,name . (MACRO . ,expansion))))
-   :variables
-   definitions
-   fun))
-  
-(def-ir1-translator symbol-macrolet ((macrobindings &body body) start cont)
-  #!+sb-doc
-  "SYMBOL-MACROLET ({(Name Expansion)}*) Decl* Form*
-  Define the Names as symbol macros with the given Expansions. Within the
-  body, references to a Name will effectively be replaced with the Expansion."
-  (funcall-in-symbol-macrolet-lexenv
-   macrobindings
-   (lambda ()
-     (ir1-translate-locally body start cont))))
-
-;;; not really a special form, but..
-(def-ir1-translator declare ((&rest stuff) start cont)
-  (declare (ignore stuff))
-  ;; We ignore START and CONT too, but we can't use DECLARE IGNORE to
-  ;; tell the compiler about it here, because the DEF-IR1-TRANSLATOR
-  ;; macro would put the DECLARE in the wrong place, so..
-  start cont
-  (compiler-error "misplaced declaration"))
-
-;;;; %PRIMITIVE
-;;;;
-;;;; Uses of %PRIMITIVE are either expanded into Lisp code or turned
-;;;; into a funny function.
-
-;;; Carefully evaluate a list of forms, returning a list of the results.
-(defun eval-info-args (args)
-  (declare (list args))
-  (handler-case (mapcar #'eval args)
-    (error (condition)
-      (compiler-error "Lisp error during evaluation of info args:~%~A"
-		      condition))))
-
-;;; If there is a primitive translator, then we expand the call.
-;;; Otherwise, we convert to the %%PRIMITIVE funny function. The first
-;;; argument is the template, the second is a list of the results of
-;;; any codegen-info args, and the remaining arguments are the runtime
-;;; arguments.
-;;;
-;;; We do a bunch of error checking now so that we don't bomb out with
-;;; a fatal error during IR2 conversion.
-;;;
-;;; KLUDGE: It's confusing having multiple names floating around for
-;;; nearly the same concept: PRIMITIVE, TEMPLATE, VOP. Now that CMU
-;;; CL's *PRIMITIVE-TRANSLATORS* stuff is gone, we could call
-;;; primitives VOPs, rename TEMPLATE to VOP-TEMPLATE, rename
-;;; BACKEND-TEMPLATE-NAMES to BACKEND-VOPS, and rename %PRIMITIVE to
-;;; VOP or %VOP.. -- WHN 2001-06-11
-;;; FIXME: Look at doing this ^, it doesn't look too hard actually.
-(def-ir1-translator %primitive ((name &rest args) start cont)
-  (unless (symbolp name)
-    (compiler-error "The primitive name ~S is not a symbol." name))
-
-  (let* ((template (or (gethash name *backend-template-names*)
-		       (compiler-error
-			"The primitive name ~A is not defined."
-			name)))
-	 (required (length (template-arg-types template)))
-	 (info (template-info-arg-count template))
-	 (min (+ required info))
-	 (nargs (length args)))
-    (if (template-more-args-type template)
-	(when (< nargs min)
-	  (compiler-error "Primitive ~A was called with ~R argument~:P, ~
-	    		   but wants at least ~R."
-			  name
-			  nargs
-			  min))
-	(unless (= nargs min)
-	  (compiler-error "Primitive ~A was called with ~R argument~:P, ~
-			   but wants exactly ~R."
-			  name
-			  nargs
-			  min)))
-
-    (when (eq (template-result-types template) :conditional)
-      (compiler-error
-       "%PRIMITIVE was used with a conditional template."))
-
-    (when (template-more-results-type template)
-      (compiler-error
-       "%PRIMITIVE was used with an unknown values template."))
-
-    (ir1-convert start
-		 cont
-		 `(%%primitive ',template
-			       ',(eval-info-args
-				  (subseq args required min))
-			       ,@(subseq args 0 required)
-			       ,@(subseq args min)))))
-
-;;;; QUOTE and FUNCTION
-
-(def-ir1-translator quote ((thing) start cont)
-  #!+sb-doc
-  "QUOTE Value
-  Return Value without evaluating it."
-  (reference-constant start cont thing))
-
-(def-ir1-translator function ((thing) start cont)
-  #!+sb-doc
-  "FUNCTION Name
-  Return the lexically apparent definition of the function Name. Name may also
-  be a lambda."
-  (if (consp thing)
-      (case (car thing)
-	((lambda)
-	 (reference-leaf start cont (ir1-convert-lambda thing)))
-	((setf)
-	 (let ((var (find-lexically-apparent-function
-		     thing "as the argument to FUNCTION")))
-	   (reference-leaf start cont var)))
-	((instance-lambda)
-	 (let ((res (ir1-convert-lambda `(lambda ,@(cdr thing)))))
-	   (setf (getf (functional-plist res) :fin-function) t)
-	   (reference-leaf start cont res)))
-	(t
-	 (compiler-error "~S is not a legal function name." thing)))
-      (let ((var (find-lexically-apparent-function
-		  thing "as the argument to FUNCTION")))
-	(reference-leaf start cont var))))
-
-;;;; FUNCALL
-
-;;; FUNCALL is implemented on %FUNCALL, which can only call functions
-;;; (not symbols). %FUNCALL is used directly in some places where the
-;;; call should always be open-coded even if FUNCALL is :NOTINLINE.
-(deftransform funcall ((function &rest args) * * :when :both)
-  (let ((arg-names (make-gensym-list (length args))))
-    `(lambda (function ,@arg-names)
-       (%funcall ,(if (csubtypep (continuation-type function)
-				 (specifier-type 'function))
-		      'function
-		      '(%coerce-callable-to-function function))
-		 ,@arg-names))))
-
-(def-ir1-translator %funcall ((function &rest args) start cont)
-  (let ((fun-cont (make-continuation)))
-    (ir1-convert start fun-cont function)
-    (assert-continuation-type fun-cont (specifier-type 'function))
-    (ir1-convert-combination-args fun-cont cont args)))
-
-;;; This source transform exists to reduce the amount of work for the
-;;; compiler. If the called function is a FUNCTION form, then convert
-;;; directly to %FUNCALL, instead of waiting around for type
-;;; inference.
-(def-source-transform funcall (function &rest args)
-  (if (and (consp function) (eq (car function) 'function))
-      `(%funcall ,function ,@args)
-      (values nil t)))
-
-(deftransform %coerce-callable-to-function ((thing) (function) *
-					    :when :both
-					    :important t)
-  "optimize away possible call to FDEFINITION at runtime"
-  'thing)
-
-;;;; LET and LET*
-;;;;
-;;;; (LET and LET* can't be implemented as macros due to the fact that
-;;;; any pervasive declarations also affect the evaluation of the
-;;;; arguments.)
-
-;;; Given a list of binding specifiers in the style of Let, return:
-;;;  1. The list of var structures for the variables bound.
-;;;  2. The initial value form for each variable.
-;;;
-;;; The variable names are checked for legality and globally special
-;;; variables are marked as such. Context is the name of the form, for
-;;; error reporting purposes.
-(declaim (ftype (function (list symbol) (values list list list))
-		extract-let-variables))
-(defun extract-let-variables (bindings context)
-  (collect ((vars)
-	    (vals)
-	    (names))
-    (flet ((get-var (name)
-	     (varify-lambda-arg name
-				(if (eq context 'let*)
-				    nil
-				    (names)))))
-      (dolist (spec bindings)
-	(cond ((atom spec)
-	       (let ((var (get-var spec)))
-		 (vars var)
-		 (names (cons spec var))
-		 (vals nil)))
-	      (t
-	       (unless (proper-list-of-length-p spec 1 2)
-		 (compiler-error "The ~S binding spec ~S is malformed."
-				 context
-				 spec))
-	       (let* ((name (first spec))
-		      (var (get-var name)))
-		 (vars var)
-		 (names name)
-		 (vals (second spec)))))))
-
-    (values (vars) (vals) (names))))
-
-(def-ir1-translator let ((bindings &body body)
-			 start cont)
-  #!+sb-doc
-  "LET ({(Var [Value]) | Var}*) Declaration* Form*
-  During evaluation of the Forms, bind the Vars to the result of evaluating the
-  Value forms. The variables are bound in parallel after all of the Values are
-  evaluated."
-  (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
-    (multiple-value-bind (vars values) (extract-let-variables bindings 'let)
-      (let* ((*lexenv* (process-decls decls vars nil cont))
-	     (fun-cont (make-continuation))
-	     (fun (ir1-convert-lambda-body forms vars)))
-	(reference-leaf start fun-cont fun)
-	(ir1-convert-combination-args fun-cont cont values)))))
-
-(def-ir1-translator let* ((bindings &body body)
-			  start cont)
-  #!+sb-doc
-  "LET* ({(Var [Value]) | Var}*) Declaration* Form*
-  Similar to LET, but the variables are bound sequentially, allowing each Value
-  form to reference any of the previous Vars."
-  (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
-    (multiple-value-bind (vars values) (extract-let-variables bindings 'let*)
-      (let ((*lexenv* (process-decls decls vars nil cont)))
-	(ir1-convert-aux-bindings start cont forms vars values)))))
-
-;;; logic shared between IR1 translators for LOCALLY, MACROLET,
-;;; and SYMBOL-MACROLET
-;;;
-;;; Note that all these things need to preserve top-level-formness,
-;;; but we don't need to worry about that within an IR1 translator,
-;;; since top-level-formness is picked off by PROCESS-TOP-LEVEL-FOO
-;;; forms before we hit the IR1 transform level.
-(defun ir1-translate-locally (body start cont)
-  (declare (type list body) (type continuation start cont))
-  (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
-    (let ((*lexenv* (process-decls decls nil nil cont)))
-      (ir1-convert-aux-bindings start cont forms nil nil))))
-
-(def-ir1-translator locally ((&body body) start cont)
-  #!+sb-doc
-  "LOCALLY Declaration* Form*
-  Sequentially evaluate the Forms in a lexical environment where the
-  the Declarations have effect. If LOCALLY is a top-level form, then
-  the Forms are also processed as top-level forms."
-  (ir1-translate-locally body start cont))
-
-;;;; FLET and LABELS
-
-;;; Given a list of local function specifications in the style of
-;;; FLET, return lists of the function names and of the lambdas which
-;;; are their definitions.
-;;;
-;;; The function names are checked for legality. CONTEXT is the name
-;;; of the form, for error reporting.
-(declaim (ftype (function (list symbol) (values list list))
-		extract-flet-variables))
-(defun extract-flet-variables (definitions context)
-  (collect ((names)
-	    (defs))
-    (dolist (def definitions)
-      (when (or (atom def) (< (length def) 2))
-	(compiler-error "The ~S definition spec ~S is malformed." context def))
-
-      (let ((name (check-function-name (first def))))
-	(names name)
-	(multiple-value-bind (forms decls) (sb!sys:parse-body (cddr def))
-	  (defs `(lambda ,(second def)
-		   ,@decls
-		   (block ,(function-name-block-name name)
-		     . ,forms))))))
-    (values (names) (defs))))
-
-(def-ir1-translator flet ((definitions &body body)
-			  start cont)
-  #!+sb-doc
-  "FLET ({(Name Lambda-List Declaration* Form*)}*) Declaration* Body-Form*
-  Evaluate the Body-Forms with some local function definitions. The bindings
-  do not enclose the definitions; any use of Name in the Forms will refer to
-  the lexically apparent function definition in the enclosing environment."
-  (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
-    (multiple-value-bind (names defs)
-	(extract-flet-variables definitions 'flet)
-      (let* ((fvars (mapcar (lambda (n d)
-  			      (ir1-convert-lambda d n))
-			    names defs))
-	     (*lexenv* (make-lexenv
-			:default (process-decls decls nil fvars cont)
-			:functions (pairlis names fvars))))
-	(ir1-convert-progn-body start cont forms)))))
-
-;;; For LABELS, we have to create dummy function vars and add them to
-;;; the function namespace while converting the functions. We then
-;;; modify all the references to these leaves so that they point to
-;;; the real functional leaves. We also backpatch the FENV so that if
-;;; the lexical environment is used for inline expansion we will get
-;;; the right functions.
-(def-ir1-translator labels ((definitions &body body) start cont)
-  #!+sb-doc
-  "LABELS ({(Name Lambda-List Declaration* Form*)}*) Declaration* Body-Form*
-  Evaluate the Body-Forms with some local function definitions. The bindings
-  enclose the new definitions, so the defined functions can call themselves or
-  each other."
-  (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
-    (multiple-value-bind (names defs)
-	(extract-flet-variables definitions 'labels)
-      (let* ((new-fenv (loop for name in names
-			     collect (cons name (make-functional :name name))))
-	     (real-funs
-	      (let ((*lexenv* (make-lexenv :functions new-fenv)))
-		(mapcar (lambda (n d)
-			  (ir1-convert-lambda d n))
-			names defs))))
-
-	(loop for real in real-funs and env in new-fenv do
-	      (let ((dum (cdr env)))
-		(substitute-leaf real dum)
-		(setf (cdr env) real)))
-
-	(let ((*lexenv* (make-lexenv
-			 :default (process-decls decls nil real-funs cont)
-			 :functions (pairlis names real-funs))))
-	  (ir1-convert-progn-body start cont forms))))))
-
-;;;; THE
-
-;;; Do stuff to recognize a THE or VALUES declaration. CONT is the
-;;; continuation that the assertion applies to, TYPE is the type
-;;; specifier and Lexenv is the current lexical environment. NAME is
-;;; the name of the declaration we are doing, for use in error
-;;; messages.
-;;;
-;;; This is somewhat involved, since a type assertion may only be made
-;;; on a continuation, not on a node. We can't just set the
-;;; continuation asserted type and let it go at that, since there may
-;;; be parallel THE's for the same continuation, i.e.:
-;;;     (if ...
-;;;	 (the foo ...)
-;;;	 (the bar ...))
-;;;
-;;; In this case, our representation can do no better than the union
-;;; of these assertions. And if there is a branch with no assertion,
-;;; we have nothing at all. We really need to recognize scoping, since
-;;; we need to be able to discern between parallel assertions (which
-;;; we union) and nested ones (which we intersect).
-;;;
-;;; We represent the scoping by throwing our innermost (intersected)
-;;; assertion on CONT into the TYPE-RESTRICTIONS. As we go down, we
-;;; intersect our assertions together. If CONT has no uses yet, we
-;;; have not yet bottomed out on the first COND branch; in this case
-;;; we optimistically assume that this type will be the one we end up
-;;; with, and set the ASSERTED-TYPE to it. We can never get better
-;;; than the type that we have the first time we bottom out. Later
-;;; THE's (or the absence thereof) can only weaken this result.
-;;;
-;;; We make this work by getting USE-CONTINUATION to do the unioning
-;;; across COND branches. We can't do it here, since we don't know how
-;;; many branches there are going to be.
-(defun do-the-stuff (type cont lexenv name)
-  (declare (type continuation cont) (type lexenv lexenv))
-  (let* ((ctype (values-specifier-type type))
-	 (old-type (or (lexenv-find cont type-restrictions)
-		       *wild-type*))
-	 (intersects (values-types-equal-or-intersect old-type ctype))
-	 (int (values-type-intersection old-type ctype))
-	 (new (if intersects int old-type)))
-    (when (null (find-uses cont))
-      (setf (continuation-asserted-type cont) new))
-    (when (and (not intersects)
-	       (not (policy *lexenv*
-			    (= inhibit-warnings 3)))) ;FIXME: really OK to suppress?
-      (compiler-warning
-       "The type ~S in ~S declaration conflicts with an enclosing assertion:~%   ~S"
-       (type-specifier ctype)
-       name
-       (type-specifier old-type)))
-    (make-lexenv :type-restrictions `((,cont . ,new))
-		 :default lexenv)))
-
-;;; Assert that FORM evaluates to the specified type (which may be a
-;;; VALUES type).
-;;;
-;;; FIXME: In a version of CMU CL that I used at Cadabra ca. 20000101,
-;;; this didn't seem to expand into an assertion, at least for ALIEN
-;;; values. Check that SBCL doesn't have this problem.
-(def-ir1-translator the ((type value) start cont)
-  (let ((*lexenv* (do-the-stuff type cont *lexenv* 'the)))
-    (ir1-convert start cont value)))
-
-;;; This is like the THE special form, except that it believes
-;;; whatever you tell it. It will never generate a type check, but
-;;; will cause a warning if the compiler can prove the assertion is
-;;; wrong.
-;;;
-;;; Since the CONTINUATION-DERIVED-TYPE is computed as the union of
-;;; its uses's types, setting it won't work. Instead we must intersect
-;;; the type with the uses's DERIVED-TYPE.
-(def-ir1-translator truly-the ((type value) start cont)
-  #!+sb-doc
-  (declare (inline member))
-  (let ((type (values-specifier-type type))
-	(old (find-uses cont)))
-    (ir1-convert start cont value)
-    (do-uses (use cont)
-      (unless (member use old :test #'eq)
-	(derive-node-type use type)))))
-
-;;;; SETQ
-
-;;; If there is a definition in LEXENV-VARIABLES, just set that,
-;;; otherwise look at the global information. If the name is for a
-;;; constant, then error out.
-(def-ir1-translator setq ((&whole source &rest things) start cont)
-  (let ((len (length things)))
-    (when (oddp len)
-      (compiler-error "odd number of args to SETQ: ~S" source))
-    (if (= len 2)
-	(let* ((name (first things))
-	       (leaf (or (lexenv-find name variables)
-			 (find-free-variable name))))
-	  (etypecase leaf
-	    (leaf
-	     (when (or (constant-p leaf)
-		       (and (global-var-p leaf)
-			    (eq (global-var-kind leaf) :constant)))
-	       (compiler-error "~S is a constant and thus can't be set." name))
-	     (when (and (lambda-var-p leaf)
-			(lambda-var-ignorep leaf))
-	       ;; ANSI's definition of "Declaration IGNORE, IGNORABLE"
-	       ;; requires that this be a STYLE-WARNING, not a full warning.
-	       (compiler-style-warning
-		"~S is being set even though it was declared to be ignored."
-		name))
-	     (set-variable start cont leaf (second things)))
-	    (cons
-	     (aver (eq (car leaf) 'MACRO))
-	     (ir1-convert start cont `(setf ,(cdr leaf) ,(second things))))
-	    (heap-alien-info
-	     (ir1-convert start cont
-			  `(%set-heap-alien ',leaf ,(second things))))))
-	(collect ((sets))
-	  (do ((thing things (cddr thing)))
-	      ((endp thing)
-	       (ir1-convert-progn-body start cont (sets)))
-	    (sets `(setq ,(first thing) ,(second thing))))))))
-
-;;; This is kind of like REFERENCE-LEAF, but we generate a SET node.
-;;; This should only need to be called in SETQ.
-(defun set-variable (start cont var value)
-  (declare (type continuation start cont) (type basic-var var))
-  (let ((dest (make-continuation)))
-    (setf (continuation-asserted-type dest) (leaf-type var))
-    (ir1-convert start dest value)
-    (let ((res (make-set :var var :value dest)))
-      (setf (continuation-dest dest) res)
-      (setf (leaf-ever-used var) t)
-      (push res (basic-var-sets var))
-      (prev-link res dest)
-      (use-continuation res cont))))
-
-;;;; CATCH, THROW and UNWIND-PROTECT
-
-;;; We turn THROW into a multiple-value-call of a magical function,
-;;; since as as far as IR1 is concerned, it has no interesting
-;;; properties other than receiving multiple-values.
-(def-ir1-translator throw ((tag result) start cont)
-  #!+sb-doc
-  "Throw Tag Form
-  Do a non-local exit, return the values of Form from the CATCH whose tag
-  evaluates to the same thing as Tag."
-  (ir1-convert start cont
-	       `(multiple-value-call #'%throw ,tag ,result)))
-
-;;; This is a special special form used to instantiate a cleanup as
-;;; the current cleanup within the body. KIND is a the kind of cleanup
-;;; to make, and MESS-UP is a form that does the mess-up action. We
-;;; make the MESS-UP be the USE of the MESS-UP form's continuation,
-;;; and introduce the cleanup into the lexical environment. We
-;;; back-patch the ENTRY-CLEANUP for the current cleanup to be the new
-;;; cleanup, since this inner cleanup is the interesting one.
-(def-ir1-translator %within-cleanup ((kind mess-up &body body) start cont)
-  (let ((dummy (make-continuation))
-	(dummy2 (make-continuation)))
-    (ir1-convert start dummy mess-up)
-    (let* ((mess-node (continuation-use dummy))
-	   (cleanup (make-cleanup :kind kind
-				  :mess-up mess-node))
-	   (old-cup (lexenv-cleanup *lexenv*))
-	   (*lexenv* (make-lexenv :cleanup cleanup)))
-      (setf (entry-cleanup (cleanup-mess-up old-cup)) cleanup)
-      (ir1-convert dummy dummy2 '(%cleanup-point))
-      (ir1-convert-progn-body dummy2 cont body))))
-
-;;; This is a special special form that makes an "escape function"
-;;; which returns unknown values from named block. We convert the
-;;; function, set its kind to :ESCAPE, and then reference it. The
-;;; :Escape kind indicates that this function's purpose is to
-;;; represent a non-local control transfer, and that it might not
-;;; actually have to be compiled.
-;;;
-;;; Note that environment analysis replaces references to escape
-;;; functions with references to the corresponding NLX-INFO structure.
-(def-ir1-translator %escape-function ((tag) start cont)
-  (let ((fun (ir1-convert-lambda
-	      `(lambda ()
-		 (return-from ,tag (%unknown-values))))))
-    (setf (functional-kind fun) :escape)
-    (reference-leaf start cont fun)))
-
-;;; Yet another special special form. This one looks up a local
-;;; function and smashes it to a :CLEANUP function, as well as
-;;; referencing it.
-(def-ir1-translator %cleanup-function ((name) start cont)
-  (let ((fun (lexenv-find name functions)))
-    (aver (lambda-p fun))
-    (setf (functional-kind fun) :cleanup)
-    (reference-leaf start cont fun)))
-
-;;; We represent the possibility of the control transfer by making an
-;;; "escape function" that does a lexical exit, and instantiate the
-;;; cleanup using %WITHIN-CLEANUP.
-(def-ir1-translator catch ((tag &body body) start cont)
-  #!+sb-doc
-  "Catch Tag Form*
-  Evaluates Tag and instantiates it as a catcher while the body forms are
-  evaluated in an implicit PROGN. If a THROW is done to Tag within the dynamic
-  scope of the body, then control will be transferred to the end of the body
-  and the thrown values will be returned."
-  (ir1-convert
-   start cont
-   (let ((exit-block (gensym "EXIT-BLOCK-")))
-     `(block ,exit-block
-	(%within-cleanup
-	    :catch
-	    (%catch (%escape-function ,exit-block) ,tag)
-	  ,@body)))))
-
-;;; UNWIND-PROTECT is similar to CATCH, but more hairy. We make the
-;;; cleanup forms into a local function so that they can be referenced
-;;; both in the case where we are unwound and in any local exits. We
-;;; use %CLEANUP-FUNCTION on this to indicate that reference by
-;;; %UNWIND-PROTECT ISN'T "real", and thus doesn't cause creation of
-;;; an XEP.
-(def-ir1-translator unwind-protect ((protected &body cleanup) start cont)
-  #!+sb-doc
-  "Unwind-Protect Protected Cleanup*
-  Evaluate the form Protected, returning its values. The cleanup forms are
-  evaluated whenever the dynamic scope of the Protected form is exited (either
-  due to normal completion or a non-local exit such as THROW)."
-  (ir1-convert
-   start cont
-   (let ((cleanup-fun (gensym "CLEANUP-FUN-"))
-	 (drop-thru-tag (gensym "DROP-THRU-TAG-"))
-	 (exit-tag (gensym "EXIT-TAG-"))
-	 (next (gensym "NEXT"))
-	 (start (gensym "START"))
-	 (count (gensym "COUNT")))
-     `(flet ((,cleanup-fun () ,@cleanup nil))
-	;; FIXME: If we ever get DYNAMIC-EXTENT working, then
-	;; ,CLEANUP-FUN should probably be declared DYNAMIC-EXTENT,
-	;; and something can be done to make %ESCAPE-FUNCTION have
-	;; dynamic extent too.
-	(block ,drop-thru-tag
-	  (multiple-value-bind (,next ,start ,count)
-	      (block ,exit-tag
-		(%within-cleanup
-		    :unwind-protect
-		    (%unwind-protect (%escape-function ,exit-tag)
-				     (%cleanup-function ,cleanup-fun))
-		  (return-from ,drop-thru-tag ,protected)))
-	    (,cleanup-fun)
-	    (%continue-unwind ,next ,start ,count)))))))
-
-;;;; multiple-value stuff
-
-;;; If there are arguments, MULTIPLE-VALUE-CALL turns into an
-;;; MV-COMBINATION.
-;;;
-;;; If there are no arguments, then we convert to a normal
-;;; combination, ensuring that a MV-COMBINATION always has at least
-;;; one argument. This can be regarded as an optimization, but it is
-;;; more important for simplifying compilation of MV-COMBINATIONS.
-(def-ir1-translator multiple-value-call ((fun &rest args) start cont)
-  #!+sb-doc
-  "MULTIPLE-VALUE-CALL Function Values-Form*
-  Call Function, passing all the values of each Values-Form as arguments,
-  values from the first Values-Form making up the first argument, etc."
-  (let* ((fun-cont (make-continuation))
-	 (node (if args
-		   (make-mv-combination fun-cont)
-		   (make-combination fun-cont))))
-    (ir1-convert start fun-cont
-		 (if (and (consp fun) (eq (car fun) 'function))
-		     fun
-		     `(%coerce-callable-to-function ,fun)))
-    (setf (continuation-dest fun-cont) node)
-    (assert-continuation-type fun-cont
-			      (specifier-type '(or function symbol)))
-    (collect ((arg-conts))
-      (let ((this-start fun-cont))
-	(dolist (arg args)
-	  (let ((this-cont (make-continuation node)))
-	    (ir1-convert this-start this-cont arg)
-	    (setq this-start this-cont)
-	    (arg-conts this-cont)))
-	(prev-link node this-start)
-	(use-continuation node cont)
-	(setf (basic-combination-args node) (arg-conts))))))
-
-;;; MULTIPLE-VALUE-PROG1 is represented implicitly in IR1 by having a
-;;; the result code use result continuation (CONT), but transfer
-;;; control to the evaluation of the body. In other words, the result
-;;; continuation isn't IMMEDIATELY-USED-P by the nodes that compute
-;;; the result.
-;;;
-;;; In order to get the control flow right, we convert the result with
-;;; a dummy result continuation, then convert all the uses of the
-;;; dummy to be uses of CONT. If a use is an EXIT, then we also
-;;; substitute CONT for the dummy in the corresponding ENTRY node so
-;;; that they are consistent. Note that this doesn't amount to
-;;; changing the exit target, since the control destination of an exit
-;;; is determined by the block successor; we are just indicating the
-;;; continuation that the result is delivered to.
-;;;
-;;; We then convert the body, using another dummy continuation in its
-;;; own block as the result. After we are done converting the body, we
-;;; move all predecessors of the dummy end block to CONT's block.
-;;;
-;;; Note that we both exploit and maintain the invariant that the CONT
-;;; to an IR1 convert method either has no block or starts the block
-;;; that control should transfer to after completion for the form.
-;;; Nested MV-PROG1's work because during conversion of the result
-;;; form, we use dummy continuation whose block is the true control
-;;; destination.
-(def-ir1-translator multiple-value-prog1 ((result &rest forms) start cont)
-  #!+sb-doc
-  "MULTIPLE-VALUE-PROG1 Values-Form Form*
-  Evaluate Values-Form and then the Forms, but return all the values of
-  Values-Form."
-  (continuation-starts-block cont)
-  (let* ((dummy-result (make-continuation))
-	 (dummy-start (make-continuation))
-	 (cont-block (continuation-block cont)))
-    (continuation-starts-block dummy-start)
-    (ir1-convert start dummy-start result)
-
-    (substitute-continuation-uses cont dummy-start)
-
-    (continuation-starts-block dummy-result)
-    (ir1-convert-progn-body dummy-start dummy-result forms)
-    (let ((end-block (continuation-block dummy-result)))
-      (dolist (pred (block-pred end-block))
-	(unlink-blocks pred end-block)
-	(link-blocks pred cont-block))
-      (aver (not (continuation-dest dummy-result)))
-      (delete-continuation dummy-result)
-      (remove-from-dfo end-block))))
-
-;;;; interface to defining macros
-
-;;;; FIXME:
-;;;;   classic CMU CL comment:
-;;;;     DEFMACRO and DEFUN expand into calls to %DEFxxx functions
-;;;;     so that we get a chance to see what is going on. We define
-;;;;     IR1 translators for these functions which look at the
-;;;;     definition and then generate a call to the %%DEFxxx function.
-;;;; Alas, this implementation doesn't do the right thing for
-;;;; non-toplevel uses of these forms, so this should probably
-;;;; be changed to use EVAL-WHEN instead.
-
-;;; Return a new source path with any stuff intervening between the
-;;; current path and the first form beginning with NAME stripped off.
-;;; This is used to hide the guts of DEFmumble macros to prevent
-;;; annoying error messages.
-(defun revert-source-path (name)
-  (do ((path *current-path* (cdr path)))
-      ((null path) *current-path*)
-    (let ((first (first path)))
-      (when (or (eq first name)
-		(eq first 'original-source-start))
-	(return path)))))
-
-;;; Warn about incompatible or illegal definitions and add the macro
-;;; to the compiler environment.
-;;;
-;;; Someday we could check for macro arguments being incompatibly
-;;; redefined. Doing this right will involve finding the old macro
-;;; lambda-list and comparing it with the new one.
-(def-ir1-translator %defmacro ((qname qdef lambda-list doc) start cont
-			       :kind :function)
-  (let (;; QNAME is typically a quoted name. I think the idea is to
-	;; let %DEFMACRO work as an ordinary function when
-	;; interpreting. Whatever the reason the quote is there, we
-	;; don't want it any more. -- WHN 19990603
-	(name (eval qname))
-	;; QDEF should be a sharp-quoted definition. We don't want to
-	;; make a function of it just yet, so we just drop the
-	;; sharp-quote.
-	(def (progn
-	       (aver (eq 'function (first qdef)))
-	       (aver (proper-list-of-length-p qdef 2))
-	       (second qdef))))
-
-    (/show "doing IR1 translator for %DEFMACRO" name)
-
-    (unless (symbolp name)
-      (compiler-error "The macro name ~S is not a symbol." name))
-
-    (ecase (info :function :kind name)
-      ((nil))
-      (:function
-       (remhash name *free-functions*)
-       (undefine-function-name name)
-       (compiler-warning
-	"~S is being redefined as a macro when it was ~
-         previously ~(~A~) to be a function."
-	name
-	(info :function :where-from name)))
-      (:macro)
-      (:special-form
-       (compiler-error "The special form ~S can't be redefined as a macro."
-		       name)))
-
-    (setf (info :function :kind name) :macro
-	  (info :function :where-from name) :defined
-	  (info :function :macro-function name) (coerce def 'function))
-
-    (let* ((*current-path* (revert-source-path 'defmacro))
-	   (fun (ir1-convert-lambda def name)))
-      (setf (leaf-name fun)
-	    (concatenate 'string "DEFMACRO " (symbol-name name)))
-      (setf (functional-arg-documentation fun) (eval lambda-list))
-
-      (ir1-convert start cont `(%%defmacro ',name ,fun ,doc)))
-
-    (when sb!xc:*compile-print*
-      ;; FIXME: It would be nice to convert this, and the other places
-      ;; which create compiler diagnostic output prefixed by
-      ;; semicolons, to use some common utility which automatically
-      ;; prefixes all its output with semicolons. (The addition of
-      ;; semicolon prefixes was introduced ca. sbcl-0.6.8.10 as the
-      ;; "MNA compiler message patch", and implemented by modifying a
-      ;; bunch of output statements on a case-by-case basis, which
-      ;; seems unnecessarily error-prone and unclear, scattering
-      ;; implicit information about output style throughout the
-      ;; system.) Starting by rewriting COMPILER-MUMBLE to add
-      ;; semicolon prefixes would be a good start, and perhaps also:
-      ;;   * Add semicolon prefixes for "FOO assembled" messages emitted 
-      ;;     when e.g. src/assembly/x86/assem-rtns.lisp is processed.
-      ;;   * At least some debugger output messages deserve semicolon
-      ;;     prefixes too:
-      ;;     ** restarts table
-      ;;     ** "Within the debugger, you can type HELP for help."
-      (compiler-mumble "~&; converted ~S~%" name))))
-
-(def-ir1-translator %define-compiler-macro ((name def lambda-list doc)
-					    start cont
-					    :kind :function)
-  (let ((name (eval name))
-	(def (second def))) ; We don't want to make a function just yet...
-
-    (when (eq (info :function :kind name) :special-form)
-      (compiler-error "attempt to define a compiler-macro for special form ~S"
-		      name))
-
-    (setf (info :function :compiler-macro-function name)
-	  (coerce def 'function))
-
-    (let* ((*current-path* (revert-source-path 'define-compiler-macro))
-	   (fun (ir1-convert-lambda def name)))
-      (setf (leaf-name fun)
-	    (let ((*print-case* :upcase))
-	      (format nil "DEFINE-COMPILER-MACRO ~S" name)))
-      (setf (functional-arg-documentation fun) (eval lambda-list))
-
-      (ir1-convert start cont `(%%define-compiler-macro ',name ,fun ,doc)))
-
-    (when sb!xc:*compile-print*
-      (compiler-mumble "~&; converted ~S~%" name))))
-
 ;;;; defining global functions
 
 ;;; Convert FUN as a lambda in the null environment, but use the
@@ -2952,8 +1889,11 @@
 		"previous definition"))))
 
 ;;; Convert a lambda doing all the basic stuff we would do if we were
-;;; converting a DEFUN. This is used both by the %DEFUN translator and
-;;; for global inline expansion.
+;;; converting a DEFUN. In the old CMU CL system, this was used both
+;;; by the %DEFUN translator and for global inline expansion, but
+;;; since sbcl-0.pre7.something %DEFUN does things differently.
+;;; FIXME: And now it's probably worth rethinking whether this
+;;; function is a good idea.
 ;;;
 ;;; Unless a :INLINE function, we temporarily clobber the inline
 ;;; expansion. This prevents recursive inline expansion of
diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index 2832443..31f8748 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -1272,511 +1272,6 @@
 	   nil)
 	  (t t))))
 
-;;;; compiler error context determination
-
-(declaim (special *current-path*))
-
-;;; We bind print level and length when printing out messages so that
-;;; we don't dump huge amounts of garbage.
-;;;
-;;; FIXME: It's not possible to get the defaults right for everyone.
-;;; So: Should these variables be in the SB-EXT package? Or should we
-;;; just get rid of them completely and just use the bare
-;;; CL:*PRINT-FOO* variables instead?
-(declaim (type (or unsigned-byte null)
-	       *compiler-error-print-level*
-	       *compiler-error-print-length*
-	       *compiler-error-print-lines*))
-(defvar *compiler-error-print-level* 5
-  #!+sb-doc
-  "the value for *PRINT-LEVEL* when printing compiler error messages")
-(defvar *compiler-error-print-length* 10
-  #!+sb-doc
-  "the value for *PRINT-LENGTH* when printing compiler error messages")
-(defvar *compiler-error-print-lines* 12
-  #!+sb-doc
-  "the value for *PRINT-LINES* when printing compiler error messages")
-
-(defvar *enclosing-source-cutoff* 1
-  #!+sb-doc
-  "The maximum number of enclosing non-original source forms (i.e. from
-  macroexpansion) that we print in full. For additional enclosing forms, we
-  print only the CAR.")
-(declaim (type unsigned-byte *enclosing-source-cutoff*))
-
-;;; We separate the determination of compiler error contexts from the
-;;; actual signalling of those errors by objectifying the error
-;;; context. This allows postponement of the determination of how (and
-;;; if) to signal the error.
-;;;
-;;; We take care not to reference any of the IR1 so that pending
-;;; potential error messages won't prevent the IR1 from being GC'd. To
-;;; this end, we convert source forms to strings so that source forms
-;;; that contain IR1 references (e.g. %DEFUN) don't hold onto the IR.
-(defstruct (compiler-error-context
-	    #-no-ansi-print-object
-	    (:print-object (lambda (x stream)
-			     (print-unreadable-object (x stream :type t))))
-	    (:copier nil))
-  ;; a list of the stringified CARs of the enclosing non-original source forms
-  ;; exceeding the *enclosing-source-cutoff*
-  (enclosing-source nil :type list)
-  ;; a list of stringified enclosing non-original source forms
-  (source nil :type list)
-  ;; the stringified form in the original source that expanded into SOURCE
-  (original-source (required-argument) :type simple-string)
-  ;; a list of prefixes of "interesting" forms that enclose original-source
-  (context nil :type list)
-  ;; the FILE-INFO-NAME for the relevant FILE-INFO
-  (file-name (required-argument)
-	     :type (or pathname (member :lisp :stream)))
-  ;; the file position at which the top-level form starts, if applicable
-  (file-position nil :type (or index null))
-  ;; the original source part of the source path
-  (original-source-path nil :type list))
-
-;;; If true, this is the node which is used as context in compiler warning
-;;; messages.
-(declaim (type (or null compiler-error-context node) *compiler-error-context*))
-(defvar *compiler-error-context* nil)
-
-;;; a hashtable mapping macro names to source context parsers. Each parser
-;;; function returns the source-context list for that form.
-(defvar *source-context-methods* (make-hash-table))
-
-;;; documentation originally from cmu-user.tex:
-;;;   This macro defines how to extract an abbreviated source context from
-;;;   the \var{name}d form when it appears in the compiler input.
-;;;   \var{lambda-list} is a \code{defmacro} style lambda-list used to
-;;;   parse the arguments. The \var{body} should return a list of
-;;;   subforms that can be printed on about one line. There are
-;;;   predefined methods for \code{defstruct}, \code{defmethod}, etc. If
-;;;   no method is defined, then the first two subforms are returned.
-;;;   Note that this facility implicitly determines the string name
-;;;   associated with anonymous functions.
-;;; So even though SBCL itself only uses this macro within this file,
-;;; it's a reasonable thing to put in SB-EXT in case some dedicated
-;;; user wants to do some heavy tweaking to make SBCL give more
-;;; informative output about his code.
-(defmacro def-source-context (name lambda-list &body body)
-  #!+sb-doc
-  "DEF-SOURCE-CONTEXT Name Lambda-List Form*
-   This macro defines how to extract an abbreviated source context from the
-   Named form when it appears in the compiler input. Lambda-List is a DEFMACRO
-   style lambda-list used to parse the arguments. The Body should return a
-   list of subforms suitable for a \"~{~S ~}\" format string."
-  (let ((n-whole (gensym)))
-    `(setf (gethash ',name *source-context-methods*)
-	   #'(lambda (,n-whole)
-	       (destructuring-bind ,lambda-list ,n-whole ,@body)))))
-
-(def-source-context defstruct (name-or-options &rest slots)
-  (declare (ignore slots))
-  `(defstruct ,(if (consp name-or-options)
-		   (car name-or-options)
-		   name-or-options)))
-
-(def-source-context function (thing)
-  (if (and (consp thing) (eq (first thing) 'lambda) (consp (rest thing)))
-      `(lambda ,(second thing))
-      `(function ,thing)))
-
-;;; Return the first two elements of FORM if FORM is a list. Take the
-;;; CAR of the second form if appropriate.
-(defun source-form-context (form)
-  (cond ((atom form) nil)
-	((>= (length form) 2)
-	 (funcall (gethash (first form) *source-context-methods*
-			   #'(lambda (x)
-			       (declare (ignore x))
-			       (list (first form) (second form))))
-		  (rest form)))
-	(t
-	 form)))
-
-;;; Given a source path, return the original source form and a
-;;; description of the interesting aspects of the context in which it
-;;; appeared. The context is a list of lists, one sublist per context
-;;; form. The sublist is a list of some of the initial subforms of the
-;;; context form.
-;;;
-;;; For now, we use the first two subforms of each interesting form. A
-;;; form is interesting if the first element is a symbol beginning
-;;; with "DEF" and it is not the source form. If there is no
-;;; DEF-mumble, then we use the outermost containing form. If the
-;;; second subform is a list, then in some cases we return the CAR of
-;;; that form rather than the whole form (i.e. don't show DEFSTRUCT
-;;; options, etc.)
-(defun find-original-source (path)
-  (declare (list path))
-  (let* ((rpath (reverse (source-path-original-source path)))
-	 (tlf (first rpath))
-	 (root (find-source-root tlf *source-info*)))
-    (collect ((context))
-      (let ((form root)
-	    (current (rest rpath)))
-	(loop
-	  (when (atom form)
-	    (aver (null current))
-	    (return))
-	  (let ((head (first form)))
-	    (when (symbolp head)
-	      (let ((name (symbol-name head)))
-		(when (and (>= (length name) 3) (string= name "DEF" :end1 3))
-		  (context (source-form-context form))))))
-	  (when (null current) (return))
-	  (setq form (nth (pop current) form)))
-	
-	(cond ((context)
-	       (values form (context)))
-	      ((and path root)
-	       (let ((c (source-form-context root)))
-		 (values form (if c (list c) nil))))
-	      (t
-	       (values '(unable to locate source)
-		       '((some strange place)))))))))
-
-;;; Convert a source form to a string, suitably formatted for use in
-;;; compiler warnings.
-(defun stringify-form (form &optional (pretty t))
-  (let ((*print-level* *compiler-error-print-level*)
-	(*print-length* *compiler-error-print-length*)
-	(*print-lines* *compiler-error-print-lines*)
-	(*print-pretty* pretty))
-    (if pretty
-	(format nil "~<~@;  ~S~:>" (list form))
-	(prin1-to-string form))))
-
-;;; Return a COMPILER-ERROR-CONTEXT structure describing the current
-;;; error context, or NIL if we can't figure anything out. ARGS is a
-;;; list of things that are going to be printed out in the error
-;;; message, and can thus be blown off when they appear in the source
-;;; context.
-(defun find-error-context (args)
-  (let ((context *compiler-error-context*))
-    (if (compiler-error-context-p context)
-	context
-	(let ((path (or (and (boundp '*current-path*) *current-path*)
-			(if context
-			    (node-source-path context)
-			    nil))))
-	  (when (and *source-info* path)
-	    (multiple-value-bind (form src-context) (find-original-source path)
-	      (collect ((full nil cons)
-			(short nil cons))
-		(let ((forms (source-path-forms path))
-		      (n 0))
-		  (dolist (src (if (member (first forms) args)
-				   (rest forms)
-				   forms))
-		    (if (>= n *enclosing-source-cutoff*)
-			(short (stringify-form (if (consp src)
-						   (car src)
-						   src)
-					       nil))
-			(full (stringify-form src)))
-		    (incf n)))
-
-		(let* ((tlf (source-path-tlf-number path))
-		       (file-info (source-info-file-info *source-info*)))
-		  (make-compiler-error-context
-		   :enclosing-source (short)
-		   :source (full)
-		   :original-source (stringify-form form)
-		   :context src-context
-		   :file-name (file-info-name file-info)
-		   :file-position
-		   (multiple-value-bind (ignore pos)
-		       (find-source-root tlf *source-info*)
-		     (declare (ignore ignore))
-		     pos)
-		   :original-source-path
-		   (source-path-original-source path))))))))))
-
-;;;; printing error messages
-
-;;; We save the context information that we printed out most recently
-;;; so that we don't print it out redundantly.
-
-;;; The last COMPILER-ERROR-CONTEXT that we printed.
-(defvar *last-error-context* nil)
-(declaim (type (or compiler-error-context null) *last-error-context*))
-
-;;; The format string and args for the last error we printed.
-(defvar *last-format-string* nil)
-(defvar *last-format-args* nil)
-(declaim (type (or string null) *last-format-string*))
-(declaim (type list *last-format-args*))
-
-;;; The number of times that the last error message has been emitted,
-;;; so that we can compress duplicate error messages.
-(defvar *last-message-count* 0)
-(declaim (type index *last-message-count*))
-
-;;; If the last message was given more than once, then print out an
-;;; indication of how many times it was repeated. We reset the message
-;;; count when we are done.
-(defun note-message-repeats (&optional (terpri t))
-  (cond ((= *last-message-count* 1)
-	 (when terpri (terpri *error-output*)))
-	((> *last-message-count* 1)
-          (format *error-output* "~&; [Last message occurs ~D times.]~2%"
-		 *last-message-count*)))
-  (setq *last-message-count* 0))
-
-;;; Print out the message, with appropriate context if we can find it.
-;;; If the context is different from the context of the last message
-;;; we printed, then we print the context. If the original source is
-;;; different from the source we are working on, then we print the
-;;; current source in addition to the original source.
-;;;
-;;; We suppress printing of messages identical to the previous, but
-;;; record the number of times that the message is repeated.
-(defun print-compiler-message (format-string format-args)
-
-  (declare (type simple-string format-string))
-  (declare (type list format-args))
-  
-  (let ((stream *error-output*)
-	(context (find-error-context format-args)))
-    (cond
-     (context
-      (let ((file (compiler-error-context-file-name context))
-	    (in (compiler-error-context-context context))
-	    (form (compiler-error-context-original-source context))
-	    (enclosing (compiler-error-context-enclosing-source context))
-	    (source (compiler-error-context-source context))
-	    (last *last-error-context*))
-
-	(unless (and last
-		     (equal file (compiler-error-context-file-name last)))
-	  (when (pathnamep file)
-	    (note-message-repeats)
-	    (setq last nil)
-            (format stream "~2&; file: ~A~%" (namestring file))))
-
-	(unless (and last
-		     (equal in (compiler-error-context-context last)))
-	  (note-message-repeats)
-	  (setq last nil)
-          (format stream "~&")
-          (pprint-logical-block (stream nil :per-line-prefix "; ")
-            (format stream "in:~{~<~%    ~4:;~{ ~S~}~>~^ =>~}" in))
-          (format stream "~%"))
-
-
-	(unless (and last
-		     (string= form
-			      (compiler-error-context-original-source last)))
-	  (note-message-repeats)
-	  (setq last nil)
-          (format stream "~&")
-          (pprint-logical-block (stream nil :per-line-prefix "; ")
-            (format stream "  ~A" form))
-          (format stream "~&"))
-
-	(unless (and last
-		     (equal enclosing
-			    (compiler-error-context-enclosing-source last)))
-	  (when enclosing
-	    (note-message-repeats)
-	    (setq last nil)
-	    (format stream "~&; --> ~{~<~%; --> ~1:;~A~> ~}~%" enclosing)))
-
-	(unless (and last
-		     (equal source (compiler-error-context-source last)))
-	  (setq *last-format-string* nil)
-	  (when source
-	    (note-message-repeats)
-	    (dolist (src source)
-              (format stream "~&")
-              (write-string "; ==>" stream)
-              (format stream "~&")
-              (pprint-logical-block (stream nil :per-line-prefix "; ")
-                (write-string src stream)))))))
-     (t
-       (format stream "~&")
-      (note-message-repeats)
-      (setq *last-format-string* nil)
-       (format stream "~&")))
-
-    (setq *last-error-context* context)
-
-    (unless (and (equal format-string *last-format-string*)
-		 (tree-equal format-args *last-format-args*))
-      (note-message-repeats nil)
-      (setq *last-format-string* format-string)
-      (setq *last-format-args* format-args)
-      (let ((*print-level*  *compiler-error-print-level*)
-	    (*print-length* *compiler-error-print-length*)
-	    (*print-lines*  *compiler-error-print-lines*))
-        (format stream "~&")
-        (pprint-logical-block (stream nil :per-line-prefix "; ")
-          (format stream "~&~?" format-string format-args))
-        (format stream "~&"))))
-
-  (incf *last-message-count*)
-  (values))
-
-(defun print-compiler-condition (condition)
-  (declare (type condition condition))
-  (let (;; These different classes of conditions have different
-	;; effects on the return codes of COMPILE-FILE, so it's nice
-	;; for users to be able to pick them out by lexical search
-	;; through the output.
-	(what (etypecase condition
-		(style-warning 'style-warning)
-		(warning 'warning)
-		(error 'error))))
-    (multiple-value-bind (format-string format-args)
-	(if (typep condition 'simple-condition)
-	    (values (simple-condition-format-control condition)
-		    (simple-condition-format-arguments condition))
-	    (values "~A"
-		    (list (with-output-to-string (s)
-			    (princ condition s)))))
-      (print-compiler-message (format nil
-				      "caught ~S:~%  ~A"
-				      what
-				      format-string)
-			      format-args)))
-  (values))
-
-;;; COMPILER-NOTE is vaguely like COMPILER-ERROR and the other
-;;; condition-signalling functions, but it just writes some output
-;;; instead of signalling. (In CMU CL, it did signal a condition, but
-;;; this didn't seem to work all that well; it was weird to have
-;;; COMPILE-FILE return with WARNINGS-P set when the only problem was
-;;; that the compiler couldn't figure out how to compile something as
-;;; efficiently as it liked.)
-(defun compiler-note (format-string &rest format-args)
-  (unless (if *compiler-error-context*
-	      (policy *compiler-error-context* (= inhibit-warnings 3))
-	      (policy *lexenv* (= inhibit-warnings 3)))
-    (incf *compiler-note-count*)
-    (print-compiler-message (format nil "note: ~A" format-string)
-			    format-args))
-  (values))
-
-;;; Issue a note when we might or might not be in the compiler.
-(defun maybe-compiler-note (&rest rest)
-  (if (boundp '*lexenv*) ; if we're in the compiler
-      (apply #'compiler-note rest)
-      (let ((stream *error-output*))
-	(pprint-logical-block (stream nil :per-line-prefix ";")
-	  
-	  (format stream " note: ~3I~_")
-	  (pprint-logical-block (stream nil)
-	    (apply #'format stream rest)))
-	(fresh-line stream)))) ; (outside logical block, no per-line-prefix)
-
-;;; The politically correct way to print out progress messages and
-;;; such like. We clear the current error context so that we know that
-;;; it needs to be reprinted, and we also Force-Output so that the
-;;; message gets seen right away.
-(declaim (ftype (function (string &rest t) (values)) compiler-mumble))
-(defun compiler-mumble (format-string &rest format-args)
-  (note-message-repeats)
-  (setq *last-error-context* nil)
-  (apply #'format *error-output* format-string format-args)
-  (force-output *error-output*)
-  (values))
-
-;;; Return a string that somehow names the code in COMPONENT. We use
-;;; the source path for the bind node for an arbitrary entry point to
-;;; find the source context, then return that as a string.
-(declaim (ftype (function (component) simple-string) find-component-name))
-(defun find-component-name (component)
-  (let ((ep (first (block-succ (component-head component)))))
-    (aver ep) ; else no entry points??
-    (multiple-value-bind (form context)
-	(find-original-source
-	 (node-source-path (continuation-next (block-start ep))))
-      (declare (ignore form))
-      (let ((*print-level* 2)
-	    (*print-pretty* nil))
-	(format nil "~{~{~S~^ ~}~^ => ~}" context)))))
-
-;;;; condition system interface
-
-;;; Keep track of how many times each kind of condition happens.
-(defvar *compiler-error-count*)
-(defvar *compiler-warning-count*)
-(defvar *compiler-style-warning-count*)
-(defvar *compiler-note-count*)
-
-;;; Keep track of whether any surrounding COMPILE or COMPILE-FILE call
-;;; should return WARNINGS-P or FAILURE-P.
-(defvar *failure-p*)
-(defvar *warnings-p*)
-
-;;; condition handlers established by the compiler. We re-signal the
-;;; condition, then if it isn't handled, we increment our warning
-;;; counter and print the error message.
-(defun compiler-error-handler (condition)
-  (signal condition)
-  (incf *compiler-error-count*)
-  (setf *warnings-p* t
-	*failure-p* t)
-  (print-compiler-condition condition)
-  (continue condition))
-(defun compiler-warning-handler (condition)
-  (signal condition)
-  (incf *compiler-warning-count*)
-  (setf *warnings-p* t
-	*failure-p* t)
-  (print-compiler-condition condition)
-  (muffle-warning condition))
-(defun compiler-style-warning-handler (condition)
-  (signal condition)
-  (incf *compiler-style-warning-count*)
-  (setf *warnings-p* t)
-  (print-compiler-condition condition)
-  (muffle-warning condition))
-
-;;;; undefined warnings
-
-(defvar *undefined-warning-limit* 3
-  #!+sb-doc
-  "If non-null, then an upper limit on the number of unknown function or type
-  warnings that the compiler will print for any given name in a single
-  compilation. This prevents excessive amounts of output when the real
-  problem is a missing definition (as opposed to a typo in the use.)")
-
-;;; Make an entry in the *UNDEFINED-WARNINGS* describing a reference
-;;; to NAME of the specified KIND. If we have exceeded the warning
-;;; limit, then just increment the count, otherwise note the current
-;;; error context.
-;;;
-;;; Undefined types are noted by a condition handler in
-;;; WITH-COMPILATION-UNIT, which can potentially be invoked outside
-;;; the compiler, hence the BOUNDP check.
-(defun note-undefined-reference (name kind)
-  (unless (and
-	   ;; Check for boundness so we don't blow up if we're called
-	   ;; when IR1 conversion isn't going on.
-	   (boundp '*lexenv*)
-	   ;; FIXME: I'm pretty sure the INHIBIT-WARNINGS test below
-	   ;; isn't a good idea; we should have INHIBIT-WARNINGS
-	   ;; affect compiler notes, not STYLE-WARNINGs. And I'm not
-	   ;; sure what the BOUNDP '*LEXENV* test above is for; it's
-	   ;; likely a good idea, but it probably deserves an
-	   ;; explanatory comment.
-	   (policy *lexenv* (= inhibit-warnings 3)))
-    (let* ((found (dolist (warning *undefined-warnings* nil)
-		    (when (and (equal (undefined-warning-name warning) name)
-			       (eq (undefined-warning-kind warning) kind))
-		      (return warning))))
-	   (res (or found
-		    (make-undefined-warning :name name :kind kind))))
-      (unless found (push res *undefined-warnings*))
-      (when (or (not *undefined-warning-limit*)
-		(< (undefined-warning-count res) *undefined-warning-limit*))
-	(push (find-error-context (list name))
-	      (undefined-warning-warnings res)))
-      (incf (undefined-warning-count res))))
-  (values))
-
 ;;;; careful call
 
 ;;; Apply a function to some arguments, returning a list of the values
diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp
index a347996..410fdfd 100644
--- a/src/compiler/locall.lisp
+++ b/src/compiler/locall.lisp
@@ -670,25 +670,11 @@
       (link-blocks call-block bind-block)
       next-block)))
 
-;;; Handle the environment semantics of LET conversion. We add the
-;;; lambda and its LETs to LETs for the CALL's home function. We merge
-;;; the calls for FUN with the calls for the home function, removing
-;;; FUN in the process. We also merge the ENTRIES.
-;;;
-;;; We also unlink the function head from the component head and set
-;;; COMPONENT-REANALYZE to true to indicate that the DFO should be
-;;; recomputed.
-(defun merge-lets (fun call)
-
-  (declare (type clambda fun) (type basic-combination call))
-
-  (let ((component (block-component (node-block call))))
-    (unlink-blocks (component-head component) (node-block (lambda-bind fun)))
-    (setf (component-lambdas component)
-	  (delete fun (component-lambdas component)))
-    (setf (component-reanalyze component) t))
-  (setf (lambda-call-lexenv fun) (node-lexenv call))
-
+;;; Remove FUN from the tail set of anything it used to be in the
+;;; same set as; but leave FUN with a valid tail set value of
+;;; its own, for the benefit of code which might try to pull
+;;; something out of it (e.g. return type).
+(defun depart-from-tail-set (fun)
   ;; Until sbcl-0.pre7.37.flaky5.2, we did
   ;;   (LET ((TAILS (LAMBDA-TAIL-SET FUN)))
   ;;     (SETF (TAIL-SET-FUNCTIONS TAILS)
@@ -711,13 +697,14 @@
   ;; To deal with this problem, we no longer NIL out 
   ;; (LAMBDA-TAIL-SET FUN) here. Instead:
   ;;   * If we're the only function in TAIL-SET-FUNCTIONS, it should
-  ;;     be safe to leave ourself linked to it, and vice versa.
+  ;;     be safe to leave ourself linked to it, and it to you.
   ;;   * If there are other functions in TAIL-SET-FUNCTIONS, then we're
   ;;     afraid of future optimizations on those functions causing
   ;;     the TAIL-SET object no longer to be valid to describe our
   ;;     return value. Thus, we delete ourselves from that object;
-  ;;     but we save a copy of the object for ourselves, for the use of
-  ;;     later code (e.g. FINALIZE-XEP-DEFINITION) which might want to
+  ;;     but we save a newly-allocated tail-set, derived from the old
+  ;;     one, for ourselves, for the use of later code (e.g.
+  ;;     FINALIZE-XEP-DEFINITION) which might want to
   ;;     know about our return type.
   (let* ((old-tail-set (lambda-tail-set fun))
 	 (old-tail-set-functions (tail-set-functions old-tail-set)))
@@ -727,10 +714,32 @@
       (let ((new-tail-set (copy-tail-set old-tail-set)))
 	(setf (lambda-tail-set fun) new-tail-set
 	      (tail-set-functions new-tail-set) (list fun)))))
-  ;; The documentation on TAIL-SET-INFO doesn't tell whether it
-  ;; remains valid in this case, so we nuke it on the theory that
-  ;; missing information is less dangerous than incorrect information.
-  (setf (tail-set-info (lambda-tail-set fun)) nil)
+  ;; The documentation on TAIL-SET-INFO doesn't tell whether it could
+  ;; remain valid in this case, so we nuke it on the theory that
+  ;; missing information tends to be less dangerous than incorrect
+  ;; information.
+  (setf (tail-set-info (lambda-tail-set fun)) nil))
+
+;;; Handle the environment semantics of LET conversion. We add the
+;;; lambda and its LETs to LETs for the CALL's home function. We merge
+;;; the calls for FUN with the calls for the home function, removing
+;;; FUN in the process. We also merge the ENTRIES.
+;;;
+;;; We also unlink the function head from the component head and set
+;;; COMPONENT-REANALYZE to true to indicate that the DFO should be
+;;; recomputed.
+(defun merge-lets (fun call)
+
+  (declare (type clambda fun) (type basic-combination call))
+
+  (let ((component (block-component (node-block call))))
+    (unlink-blocks (component-head component) (node-block (lambda-bind fun)))
+    (setf (component-lambdas component)
+	  (delete fun (component-lambdas component)))
+    (setf (component-reanalyze component) t))
+  (setf (lambda-call-lexenv fun) (node-lexenv call))
+
+  (depart-from-tail-set fun)
 
   (let* ((home (node-home-lambda call))
 	 (home-env (lambda-environment home)))
diff --git a/stems-and-flags.lisp-expr b/stems-and-flags.lisp-expr
index 5992a75..51dc76f 100644
--- a/stems-and-flags.lisp-expr
+++ b/stems-and-flags.lisp-expr
@@ -120,6 +120,8 @@
 
  ("src/code/defbangstruct")
 
+ ("src/code/funutils" :not-host)
+
  ;; This needs DEF!STRUCT, and is itself needed early so that structure
  ;; accessors and inline functions defined here can be compiled inline
  ;; later. (Avoiding full calls not only increases efficiency, but also
@@ -211,12 +213,12 @@
 
  ("src/code/target-signal" :not-host) ; needs OS-CONTEXT-T from x86-vm
 
- ("src/code/symbol"         :not-host)
- ("src/code/bignum"         :not-host)
- ("src/code/target-numbers" :not-host)
- ("src/code/float-trap"     :not-host)
- ("src/code/float"          :not-host)
- ("src/code/irrat"          :not-host)
+ ("src/code/symbol"     :not-host)
+ ("src/code/bignum"     :not-host)
+ ("src/code/numbers"    :not-host)
+ ("src/code/float-trap" :not-host)
+ ("src/code/float"      :not-host)
+ ("src/code/irrat"      :not-host)
 
  ("src/code/char")
  ("src/code/target-char" :not-host)
@@ -431,7 +433,9 @@
  ("src/compiler/main") ; needs DEFSTRUCT FASL-OUTPUT from dump.lisp
  ("src/compiler/target-main" :not-host)
  ("src/compiler/ir1tran")
+ ("src/compiler/ir1-translators")
  ("src/compiler/ir1util")
+ ("src/compiler/ir1report")
  ("src/compiler/ir1opt")
 
  ;; Compiling this file requires the macros SB!ASSEM:EMIT-LABEL and
diff --git a/version.lisp-expr b/version.lisp-expr
index d740002..06d6b3b 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -18,4 +18,4 @@
 ;;; for internal versions, especially for internal versions off the
 ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.pre7.45"
+"0.pre7.46"
-- 
1.7.10.4