From c0c98ded6ca38f92f929552a70baea75d9216700 Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Sat, 18 Jan 1997 14:32:04 +0000
Subject: [PATCH] Werkowskis source kit 1.03.7

---
 FEATURES                          |    1 +
 RCSconfig                         |    3 +
 README.1st                        |  184 ++
 SHADOW                            |    1 +
 boot.lisp                         |   21 +
 clx/dependent.lisp                |  247 ++-
 clx/manager.lisp                  |    4 +-
 code/alieneval.lisp               |   12 +-
 code/bignum.lisp                  |    9 +-
 code/bit-bash.lisp                |    3 +-
 code/bsd-os.lisp                  |   66 +
 code/byte-interp.lisp             |   12 +-
 code/clx-ext.lisp                 |   10 +-
 code/debug-int.lisp               |  476 ++++-
 code/defmacro.lisp                |   34 +-
 code/error.lisp                   |   12 +-
 code/exports.lisp                 |   20 +-
 code/fd-stream.lisp               |   25 +-
 code/filesys.lisp                 |   14 +-
 code/float-trap.lisp              |   28 +-
 code/foreign.lisp                 |   46 +-
 code/format.lisp                  |    7 +-
 code/gc.lisp                      |   24 +-
 code/internet.lisp                |   82 +-
 code/irrat.lisp                   |  763 +++++++-
 code/linux-os.lisp                |   75 +
 code/lispinit.lisp                |   68 +-
 code/load.lisp                    |  108 +-
 code/macros.lisp                  |   13 +-
 code/misc.lisp                    |    6 +-
 code/ntrace.lisp                  |    4 +-
 code/numbers.lisp                 |   32 +-
 code/pathname.lisp                |   51 +-
 code/pred.lisp                    |   10 +-
 code/save.lisp                    |    7 +-
 code/seq.lisp                     |   17 +-
 code/signal.lisp                  |   51 +-
 code/unix.lisp                    |  507 ++++--
 code/x86-vm.lisp                  |  388 +++++
 compiler/aliencomp.lisp           |   16 +-
 compiler/constraint.lisp          |   74 +-
 compiler/float-tran.lisp          |  713 +++++++-
 compiler/fndb.lisp                |    8 +-
 compiler/generic/core.lisp        |   12 +-
 compiler/generic/new-genesis.lisp |  116 +-
 compiler/generic/vm-ir2tran.lisp  |    6 +-
 compiler/generic/vm-macs.lisp     |   15 +-
 compiler/generic/vm-tran.lisp     |    4 +-
 compiler/ir2tran.lisp             |   14 +-
 compiler/loadcom.lisp             |    4 +-
 compiler/main.lisp                |    8 +-
 compiler/new-assem.lisp           |   36 +-
 compiler/pack.lisp                |   89 +-
 compiler/srctran.lisp             |  598 ++++++-
 compiler/x86/alloc.lisp           |  268 +++
 compiler/x86/arith.lisp           | 1047 +++++++++++
 compiler/x86/array.lisp           |  655 +++++++
 compiler/x86/c-call.lisp          |  214 +++
 compiler/x86/call.lisp            | 1593 +++++++++++++++++
 compiler/x86/cell.lisp            |  305 ++++
 compiler/x86/char.lisp            |  171 ++
 compiler/x86/debug.lisp           |  181 ++
 compiler/x86/float.lisp           | 2252 ++++++++++++++++++++++++
 compiler/x86/insts.lisp           | 2695 +++++++++++++++++++++++++++++
 compiler/x86/macros.lisp          |  305 ++++
 compiler/x86/memory.lisp          |  109 ++
 compiler/x86/move.lisp            |  472 +++++
 compiler/x86/nlx.lisp             |  412 +++++
 compiler/x86/parms.lisp           |  284 +++
 compiler/x86/pred.lisp            |   82 +
 compiler/x86/print.lisp           |   33 +
 compiler/x86/sap.lisp             |  456 +++++
 compiler/x86/static-fn.lisp       |  182 ++
 compiler/x86/subprim.lisp         |   93 +
 compiler/x86/system.lisp          |  304 ++++
 compiler/x86/type-vops.lisp       |  599 +++++++
 compiler/x86/values.lisp          |  135 ++
 compiler/x86/vm.lisp              |  496 ++++++
 hemlock/diredcoms.lisp            |    7 +-
 hemlock/echo.lisp                 |    3 +-
 hemlock/echocoms.lisp             |    9 +-
 hemlock/eval-server.lisp          |   10 +-
 hemlock/input.lisp                |    4 +-
 hemlock/lisp-lib.lisp             |   25 +-
 hemlock/lispeval.lisp             |    5 +-
 hemlock/rompsite.lisp             |   21 +-
 motif/lisp/initial.lisp           |    6 +-
 motif/lisp/interface-glue.lisp    |    6 +-
 motif/server/Config               |    4 +
 motif/server/GNUmakefile          |    6 +-
 motif/server/main.c               |   54 +-
 pcl/boot.lisp                     |  182 +-
 pcl/braid.lisp                    |   98 +-
 pcl/cmu-low.lisp                  |  502 ++----
 pcl/defcombin.lisp                |   31 +-
 pcl/dfun.lisp                     |  160 +-
 pcl/vector.lisp                   |   47 +-
 pcl/walk.lisp                     |    5 +-
 tools/comcom.lisp                 |   50 +-
 tools/worldbuild.lisp             |    6 +-
 tools/worldcom.lisp               |    6 +-
 tools/worldload.lisp              |    4 +-
 102 files changed, 18610 insertions(+), 1138 deletions(-)
 create mode 100644 FEATURES
 create mode 100644 RCSconfig
 create mode 100644 README.1st
 create mode 100644 SHADOW
 create mode 100644 boot.lisp
 create mode 100644 code/bsd-os.lisp
 create mode 100644 code/linux-os.lisp
 create mode 100644 code/x86-vm.lisp
 create mode 100644 compiler/x86/alloc.lisp
 create mode 100644 compiler/x86/arith.lisp
 create mode 100644 compiler/x86/array.lisp
 create mode 100644 compiler/x86/c-call.lisp
 create mode 100644 compiler/x86/call.lisp
 create mode 100644 compiler/x86/cell.lisp
 create mode 100644 compiler/x86/char.lisp
 create mode 100644 compiler/x86/debug.lisp
 create mode 100644 compiler/x86/float.lisp
 create mode 100644 compiler/x86/insts.lisp
 create mode 100644 compiler/x86/macros.lisp
 create mode 100644 compiler/x86/memory.lisp
 create mode 100644 compiler/x86/move.lisp
 create mode 100644 compiler/x86/nlx.lisp
 create mode 100644 compiler/x86/parms.lisp
 create mode 100644 compiler/x86/pred.lisp
 create mode 100644 compiler/x86/print.lisp
 create mode 100644 compiler/x86/sap.lisp
 create mode 100644 compiler/x86/static-fn.lisp
 create mode 100644 compiler/x86/subprim.lisp
 create mode 100644 compiler/x86/system.lisp
 create mode 100644 compiler/x86/type-vops.lisp
 create mode 100644 compiler/x86/values.lisp
 create mode 100644 compiler/x86/vm.lisp
 create mode 100644 motif/server/Config

diff --git a/FEATURES b/FEATURES
new file mode 100644
index 000000000..ea8e6f1d2
--- /dev/null
+++ b/FEATURES
@@ -0,0 +1 @@
+:propagate-float-type :cmu18 :cmu17 :small :cgc :x86-lra
diff --git a/RCSconfig b/RCSconfig
new file mode 100644
index 000000000..f8424d49e
--- /dev/null
+++ b/RCSconfig
@@ -0,0 +1,3 @@
+new_compiler
+cmu
+<>
diff --git a/README.1st b/README.1st
new file mode 100644
index 000000000..e1771b03e
--- /dev/null
+++ b/README.1st
@@ -0,0 +1,184 @@
+January 5, 1997
+
+This is release 1.03.7 of the X86 port of CMUCL.
+
+The source kit should work on any port. The kit contains
+port specific directories only for X86. The best way to
+use the source kit is to shadow the original 17f tree
+using the EXTENTIONS:SEARCH-LIST feature.
+
+Changes since the 1.03.6 kit (23 November 96) include:
+
+Generic CMUCL: 
+
+	1. Ray Toy has provided support for logical-pathname
+	namestrings in more (all?) IO functions that take
+	logical-pathname arguments. Probe-file and load
+	with LP namestrings work.
+
+	2. A bug in TRANSLATE-PATHNAME which caused recursive
+	logical-pathname translations to fail is fixed.
+
+	3. A few bugs were flushed and fixed by Douglas Crosher
+	while working the CL-HTTP port.
+
+	4. Ray Toy's enhancements to floating-point type
+	propagation seem real stable and really useful.
+	Add :propagate-float-type to *features* before compiling
+	a world.
+
+	5. A bug in file-author which signalled an error on
+	a pathname argument was fixed. Hemlock's change-log
+	function now works.
+
+	6. A few random bugs in Hemlock were fixed.
+
+X86 specific changes:
+
+	0. Due to the following, there may be bootstrap problems
+	building this release. Please load p86/boot.lisp
+	prior to running worldcom/worldbuild/comcom. You
+	must build at least 3 generations of compiler before
+	all changes propagate into place. You will need the
+	boot.lisp file only for the first generation build.
+
+	1. Major improvements in debugger support thanks to
+	Douglas Crosher. Previous "unknown code location"
+	notes from debug with confusing debug data are now
+	replaced by useful and accurate information.
+
+	2. More math functions are open coded using Intel's
+	fancy instructions. Sin, Cos and Tan are fast
+	inlined if the argument range is known to be (mod 2^64).
+	Currently arguments outside this range return a zero
+	value. An efficiency note is printed if the compiler
+	can't optimize to fast code.
+
+	3. A problem where PCL CLOS sometimes left dangling
+	pointers in unscanned (by GC) memory has been fixed.
+
+Bugs:
+
+Compiler errors are sometimes generated from LABELS
+forms which use optional arguments. A workaround is
+to not use optional arguments or include all args at
+the call site. This seems to be the major outstanding bug.
+
+There is one known bug in restart-case which does not 
+want to work unless compiled to native code.
+
+A mis-feature is that compiled code is allocated in static
+memory. This restriction may go away in a future release.
+The impact of static allocation of compiled code is that
+any dead code is not reclaimed and contributes to VM bloat.
+This is an operational problem only in intensive incremental
+code development.
+
+Please send comments and bugs to 
+Paul Werkowski
+pw@snoopy.mv.com
+
+or to cmucl-imp@cons.org
+
+-----------------------------------------------------------------------
+Informal Release History:
+
+November 23, 1996. 1.03.6
+
+Changes since release 1.03.1 include
+
+	* The FreeBSD/X86 source code has been merged with
+	the current CMU tree which had a number of unpublished
+	fixes applied since version 17f.
+
+	* Changes specific to the Linux port have been
+	merged as well. These changes don't effect FreeBSD users.
+
+	* Major improvements to the floating-point code generators
+	thanks to Douglas Crosher.
+
+	* The internal "static-space" has changed along with
+	some internal static variable names. You probably will
+	have to recompile everything. Sorry.
+
+	* The source kit now contains improvements to floating
+	point type propagation, thanks to Ray Toy. These
+	changes are still experimental, and disabled by default
+	in the binary distribution. When enabled, Python is able
+	to optimize the results of intermediate floating point
+	types through most arithmetic operations. This is useful
+	when bounded float types are used,
+	 eg (declare (type (double-float 0d0) x y), then
+	(* x y) is known to be non-negative. See file srctran.lisp
+	for hints on how to enable this feature.
+
+	* Many internal changes and improvements too 
+	numerous to remember.
+
+
+Changes since release 1.03 include:
+
+	* A nasty little bug was found in floating-point
+	register loading that caused erroneous data to
+	be created in some conditions. It is now fixed thanks
+	to Douglas Crosher.
+
+Changes since release 1.02 include:
+
+	* Fixed some obscure bugs in the Object System.
+	Non-standard method-combination now works. These
+	changes are platform-independent.
+
+	* Fixed a problem in the definition of the arithmetic-error
+	condition which caused bad behavior with divide-by-zero
+	and floating-point exceptions.
+
+	* Changes made by Peter Van Eynde for the first Linux release
+	have been merged into the current source tree.
+
+	* Improved version of some irrational functions are included
+	thanks to Raymond Toy.
+
+	* A few random bug fixes here and there.
+
+Changes since release 1.01 include:
+
+	* Compiled library files for the major subsystems,
+	while not in the basic lisp image, are provided
+	separately on the www.mv.com/users/pw/lisp/dl
+	page. You can download what you want and use
+	bin/config to build a custom system.
+
+	* Fixed problem with handling interrupts occuring
+	during execution of forms enclosed by
+	(without-interrupts ..), for example, interrupting
+	a garbage collection and then continuing caused
+	a bus error or segment violation.
+
+	* Some random optimizations.
+
+	* Reorganized the way foreign symbols are handled.
+	If you get "Unknown foreign symbol" warnings you
+	will need to recompile some code.
+
+Changes since release 1.0 include:
+
+	* Fix to floating-point code generator that
+	caused incorrect results from FADD or FMUL when
+	both operands were in same register.
+
+	* Support for auto-gc-trigger now notifies
+	lisp to consider whether or not to initiate GC.
+
+	* Fix to save-lisp C support code which lost
+	the restart function address in some cases.
+
+	* Improvements to platform specific parts of
+	debug-internals allow better stack backtracking,
+	with less hackery.
+
+	* Includes all known patches from CMU. The bug
+	which caused the Motif inspector grief is now gone,
+	and the inspector is actually usable and useful.
+
+
diff --git a/SHADOW b/SHADOW
new file mode 100644
index 000000000..9b95b9b2c
--- /dev/null
+++ b/SHADOW
@@ -0,0 +1 @@
+/local/lisp/cmucl/17f
diff --git a/boot.lisp b/boot.lisp
new file mode 100644
index 000000000..25b055cb8
--- /dev/null
+++ b/boot.lisp
@@ -0,0 +1,21 @@
+(load "target:code/exports.lisp")
+#+x86(proclaim '(notinline kernel:%tan kernel:%atan kernel:%atan2))
+(in-package :x86)
+(eval-when (compile load eval)
+(defconstant conditions
+  '((:o . 0)
+    (:no . 1)
+    (:b . 2) (:nae . 2) (:c . 2)
+    (:nb . 3) (:ae . 3) (:nc . 3)
+    (:eq . 4) (:e . 4) (:z . 4)
+    (:ne . 5) (:nz . 5)
+    (:be . 6) (:na . 6)
+    (:nbe . 7) (:a . 7)
+    (:s . 8)
+    (:ns . 9)
+    (:p . 10) (:pe . 10)
+    (:np . 11) (:po . 11)
+    (:l . 12) (:nge . 12)
+    (:nl . 13) (:ge . 13)
+    (:le . 14) (:ng . 14)
+    (:nle . 15) (:g . 15))))
diff --git a/clx/dependent.lisp b/clx/dependent.lisp
index 2da3615b7..0f8f2b6be 100644
--- a/clx/dependent.lisp
+++ b/clx/dependent.lisp
@@ -1,4 +1,4 @@
-;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
+;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*-
 
 ;; This file contains some of the system dependent code for CLX
 
@@ -20,6 +20,12 @@
 
 (in-package :xlib)
 
+(proclaim '(declaration array-register))
+
+#+cmu
+(setf (getf ext:*herald-items* :xlib)
+      `("    CLX X Library " ,*version*))
+
 ;;; The size of the output buffer.  Must be a multiple of 4.
 (defparameter *output-buffer-size* 8192)
 
@@ -67,6 +73,9 @@
 ;;; declaration is available, it would be a good idea to make it here when
 ;;; *buffer-speed* is 3 and *buffer-safety* is 0.
 (defun declare-buffun ()
+  #+(and cmu clx-debugging)
+  '(declare (optimize (speed 1) (safety 1)))
+  #-(and cmu clx-debugging)
   `(declare (optimize (speed ,*buffer-speed*) (safety ,*buffer-safety*))))
 
 )
@@ -677,6 +686,25 @@
   #.(declare-buffun)
   (the short-float (* (the int16 value) #.(coerce (/ pi 180.0 64.0) 'short-float))))
 
+
+#+cmu (progn
+
+;;; This overrides the (probably incorrect) definition in clx.lisp.  Since PI
+;;; is irrational, there can't be a precise rational representation.  In
+;;; particular, the different float approximations will always be /=.  This
+;;; causes problems with type checking, because people might compute an
+;;; argument in any precision.  What we do is discard all the excess precision
+;;; in the value, and see if the protocal encoding falls in the desired range
+;;; (64'ths of a degree.)
+;;;
+(deftype angle () '(satisfies anglep))
+
+(defun anglep (x)
+  (and (typep x 'real)
+       (<= (* -360 64) (radians->int16 x) (* 360 64))))
+
+)
+
 
 ;;-----------------------------------------------------------------------------
 ;; Character transformation
@@ -873,16 +901,18 @@
 ;;; against re-entering request functions.  This can happen if an interrupt
 ;;; occurs and the handler attempts to use X over the same display connection.
 ;;; This can happen if the GC hooks are used to notify the user over the same
-;;; display connection.  We lock out GC's just as a dummy check for our users.
-;;; Locking out interrupts has the problem that CLX always waits for replies
-;;; within this dynamic scope, so if the server cannot reply for some reason,
-;;; we potentially dead-lock without interrupts.
+;;; display connection.  We inhibit GC notifications since display of them
+;;; could cause recursive entry into CLX.
 ;;;
 #+CMU
 (defmacro holding-lock ((locator display &optional whostate &key timeout)
 			&body body)
-  (declare (ignore locator display whostate timeout))
-  `(lisp::without-gcing (system:without-interrupts (progn ,@body))))
+  `(let ((ext:*gc-verbose* nil)
+	 (ext:*gc-inhibit-hook* nil)
+	 (ext:*before-gc-hooks* nil)
+	 (ext:*after-gc-hooks* nil))
+     ,locator ,display ,whostate ,timeout
+     (system:without-interrupts (progn ,@body))))
 
 #+Genera
 (defmacro holding-lock ((locator display &optional whostate &key timeout)
@@ -1335,7 +1365,12 @@
 ;;; The file descriptor here just gets tossed into the stream slot of the
 ;;; display object instead of a stream.
 ;;;
-#+CMU
+#+cmu
+(alien:def-alien-routine ("connect_to_server" xlib::connect-to-server)
+			 c-call:int
+  (host c-call:c-string)
+  (port c-call:int))
+#+cmu
 (defun open-x-stream (host display protocol)
   (declare (ignore protocol))
   (let ((server-fd (connect-to-server host display)))
@@ -1344,15 +1379,6 @@
     (system:make-fd-stream server-fd :input t :output t
 			   :element-type '(unsigned-byte 8))))
 
-;;; This loads the C foreign function used to make an IPC connection
-;;; to the X11 server.  It also defines the necessary types and things
-;;; to actually make the foreign call.  See the OPEN-X-STREAM function
-;;; in the dependent.lisp file.
-;;;
-#+CMU
-(ext:def-c-routine ("connect_to_server" connect-to-server) (ext:int)
-  (host system:null-terminated-string)
-  (port ext:int))
 
 ;;; BUFFER-READ-DEFAULT - read data from the X stream
 
@@ -1454,9 +1480,9 @@
   (declare (type display display)
 	   (type buffer-bytes vector)
 	   (type array-index start end)
-	   (type (or null (real 0 *)) timeout))
+	   (type (or null fixnum) timeout))
   #.(declare-buffun)
-  (cond ((and (and timeout (= timeout 0))
+  (cond ((and (eql timeout 0)
 	      (not (listen (display-input-stream display))))
 	 :timeout)
 	(t
@@ -1464,6 +1490,7 @@
 			      vector start (- end start))
 	 nil)))
 
+
 ;;; WARNING:
 ;;;	CLX performance will suffer if your lisp uses read-byte for
 ;;;	receiving all data from the X Window System server.
@@ -1573,6 +1600,15 @@
 	  (declare (type array-index index))
 	  (write-byte (aref vector index) stream))))))
 
+#+CMU
+(defun buffer-write-default (vector display start end)
+  (declare (type buffer-bytes vector)
+	   (type display display)
+	   (type array-index start end))
+  #.(declare-buffun)
+  (system:output-raw-bytes (display-output-stream display) vector start end)
+  nil)
+
 ;;; buffer-force-output-default - force output to the X stream
 
 #+excl
@@ -1580,7 +1616,7 @@
   ;; buffer-write-default does the actual writing.
   (declare (ignore display)))
 
-#-excl
+#-(or excl)
 (defun buffer-force-output-default (display)
   ;; The default buffer force-output function for use with common-lisp streams
   (declare (type display display))
@@ -1599,7 +1635,7 @@
   #.(declare-buffun)
   (excl::filesys-checking-close (display-output-stream display)))
 
-#-excl
+#-(or excl)
 (defun buffer-close-default (display &key abort)
   ;; The default buffer close function for use with common-lisp streams
   (declare (type display display))
@@ -1647,12 +1683,12 @@
 #+CMU
 (defun buffer-input-wait-default (display timeout)
   (declare (type display display)
-	   (type (or null (real 0 *)) timeout))
+	   (type (or null number) timeout))
   (let ((stream (display-input-stream display)))
     (declare (type (or null stream) stream))
     (cond ((null stream))
 	  ((listen stream) nil)
-	  ((and timeout (= timeout 0)) :timeout)
+	  ((eql timeout 0) :timeout)
 	  (t
 	   (if (system:wait-until-fd-usable (system:fd-stream-fd stream)
 					    :input timeout)
@@ -1782,7 +1818,7 @@
 ;;; buffer. This should never block, so it can be called from the scheduler.
 
 ;;; The default implementation is to just use listen.
-#-excl
+#-(or excl)
 (defun buffer-listen-default (display)
   (declare (type display display))
   (let ((stream (display-input-stream display)))
@@ -2114,21 +2150,13 @@
 #+CMU
 (defun x-error (condition &rest keyargs)
   (let ((condx (apply #'make-condition condition keyargs)))
-    (typecase condx
-      ;; This condition no longer exists.
-      #||
-      (server-disconnect
-	(let ((disp (server-disconnect-display condx)))
-	  (warn "Disabled event handling on ~S." disp)
-	  (ext::disable-clx-event-handling disp)))
-      ||#
-      (closed-display
-	(let ((disp (closed-display-display condx)))
-	  (warn "Disabled event handling on ~S." disp)
-	  (ext::disable-clx-event-handling disp))))
+    (when (eq condition 'closed-display)
+      (let ((disp (closed-display-display condx)))
+	(warn "Disabled event handling on ~S." disp)
+	(ext::disable-clx-event-handling disp)))
     (error condx)))
 
-#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU)
+#-(or lispm ansi-common-lisp excl lcl3.0 CMU)
 (defun x-error (condition &rest keyargs)
   (error "X-Error: ~a"
 	 (princ-to-string (apply #'make-condition condition keyargs))))
@@ -2589,7 +2617,7 @@
 ;; WITH-STANDARD-IO-SYNTAX equivalent, used in (SETF WM-COMMAND)
 ;;-----------------------------------------------------------------------------
 
-#-(or clx-ansi-common-lisp Genera)
+#-(or clx-ansi-common-lisp Genera CMU)
 (defun with-standard-io-syntax-function (function)
   (declare #+lispm
 	   (sys:downward-funarg function))
@@ -2611,7 +2639,7 @@
 	#+lucid (lucid::*print-structure* t))
     (funcall function)))
 
-#-(or clx-ansi-common-lisp Genera)
+#-(or clx-ansi-common-lisp Genera CMU)
 (defmacro with-standard-io-syntax (&body body)
   `(flet ((.with-standard-io-syntax-body. () ,@body))
      (with-standard-io-syntax-function #'.with-standard-io-syntax-body.)))
@@ -2691,22 +2719,22 @@
   #+(or Genera Minima) 'fixnum)
 
 (deftype pixarray-1  ()
-  '(array pixarray-1-element-type (* *)))
+  '(#+cmu simple-array #-cmu array pixarray-1-element-type (* *)))
 
 (deftype pixarray-4  ()
-  '(array pixarray-4-element-type (* *)))
+  '(#+cmu simple-array #-cmu array pixarray-4-element-type (* *)))
 
 (deftype pixarray-8  ()
-  '(array pixarray-8-element-type (* *)))
+  '(#+cmu simple-array #-cmu array pixarray-8-element-type (* *)))
 
 (deftype pixarray-16 ()
-  '(array pixarray-16-element-type (* *)))
+  '(#+cmu simple-array #-cmu array pixarray-16-element-type (* *)))
 
 (deftype pixarray-24 ()
-  '(array pixarray-24-element-type (* *)))
+  '(#+cmu simple-array #-cmu array pixarray-24-element-type (* *)))
 
 (deftype pixarray-32 ()
-  '(array pixarray-32-element-type (* *)))
+  '(#+cmu simple-array #-cmu array pixarray-32-element-type (* *)))
 
 (deftype pixarray ()
   '(or pixarray-1 pixarray-4 pixarray-8 pixarray-16 pixarray-24 pixarray-32))
@@ -2747,6 +2775,19 @@
      (declare (type (simple-array ,element-type (*)) ,variable))
      ,@body))
 
+#+CMU
+;;; We do *NOT* support viewing an array as having a different element type.
+;;; Element-type is ignored.
+;;;
+(defmacro with-underlying-simple-vector 
+	  ((variable element-type pixarray) &body body)
+  (declare (ignore element-type))
+  `(lisp::with-array-data ((,variable ,pixarray)
+			   (start)
+			   (end))
+      (declare (ignore start end))
+      ,@body))
+
 ;;; These are used to read and write pixels from and to CARD8s.
 
 ;;; READ-IMAGE-LOAD-BYTE is used to extract 1 and 4 bit pixels from CARD8s.
@@ -2916,14 +2957,16 @@
 			   (index-ceiling x 8))
 		   (index+ start padded-bytes-per-line))
 	    (y 0 (index1+ y))
-	    (left-bits (index-mod (index- x) 8))
+	    (left-bits (the array-index (mod (the fixnum (- x)) 8)))
 	    (right-bits (index-mod (index- width left-bits) 8))
-	    (middle-bits (index- width left-bits right-bits))
+	    (middle-bits (the fixnum (- (the fixnum (- width left-bits))
+					right-bits)))
 	    (middle-bytes (index-floor middle-bits 8)))
 	   ((index>= y height))
 	(declare (type array-index start y
-		       left-bits right-bits middle-bits middle-bytes))
-	(cond ((index< middle-bits 0)
+		       left-bits right-bits middle-bytes)
+		 (fixnum middle-bits))
+	(cond ((< middle-bits 0)
 	       (let ((byte (aref buffer-bbuf (index1- start)))
 		     (x (array-row-major-index array y left-bits)))
 		 (declare (type card8 byte)
@@ -2988,7 +3031,7 @@
 		     (unless (index-zerop right-bits)
 		       (let ((byte (aref buffer-bbuf end))
 			     (x (array-row-major-index
-				  array y (index+ left-bits middle-bits))))
+				 array y (index+ left-bits middle-bits))))
 			 (declare (type card8 byte)
 				  (type array-index x))
 			 (setf (aref vector (index+ x 0))
@@ -3032,7 +3075,7 @@
 		   (setf (aref vector (index+ x 7))
 			 (read-image-load-byte 1 7 byte))))
 	       )))))
-  t)
+    t)
 
 #+(or lcl3.0 excl)
 (defun fast-read-pixarray-4 (buffer-bbuf index array x y width height 
@@ -3051,7 +3094,8 @@
 			   (index-ceiling x 2))
 		   (index+ start padded-bytes-per-line))
 	    (y 0 (index1+ y))
-	    (left-nibbles (index-mod (index- x) 2))
+	    (left-nibbles (the array-index (mod (the fixnum (- (the fixnum x)))
+						2)))
 	    (right-nibbles (index-mod (index- width left-nibbles) 2))
 	    (middle-nibbles (index- width left-nibbles right-nibbles))
 	    (middle-bytes (index-floor middle-nibbles 2)))
@@ -3079,7 +3123,7 @@
 	)))
   t)
 
-#+(or Genera lcl3.0 excl)
+#+(or Genera lcl3.0 excl CMU)
 (defun fast-read-pixarray-24 (buffer-bbuf index array x y width height 
 			      padded-bytes-per-line bits-per-pixel)
   (declare (type buffer-bytes buffer-bbuf)
@@ -3125,6 +3169,63 @@
    (sys:bitblt boole-1 width height a x y pixarray 0 0))
   t)
 
+#+CMU
+(defun pixarray-element-size (pixarray)
+  (let ((eltype (array-element-type pixarray)))
+    (cond ((eq eltype 'bit) 1)
+	  ((and (consp eltype) (eq (first eltype) 'unsigned-byte))
+	   (second eltype))
+	  (t
+	   (error "Invalid pixarray: ~S." pixarray)))))
+
+#+CMU
+;;; COPY-BIT-RECT  --  Internal
+;;;
+;;;    This is the classic BITBLT operation, copying a rectangular subarray
+;;; from one array to another (but source and destination must not overlap.)
+;;; Widths are specified in bits.  Neither array can have a non-zero
+;;; displacement.  We allow extra random bit-offset to be thrown into the X.
+;;;
+(defun copy-bit-rect (source source-width sx sy dest dest-width dx dy
+			     height width)
+  (declare (type array-index source-width sx sy dest-width dx dy height width))
+   #.(declare-buffun)
+   (lisp::with-array-data ((sdata source)
+			   (sstart)
+			   (send))
+     (declare (ignore send))
+     (lisp::with-array-data ((ddata dest)
+			     (dstart)
+			     (dend))
+       (declare (ignore dend))
+       (assert (and (zerop sstart) (zerop dstart)))
+       (do ((src-idx (index+ (* vm:vector-data-offset vm:word-bits)
+			     sx (index* sy source-width))
+		     (index+ src-idx source-width))
+	    (dest-idx (index+ (* vm:vector-data-offset vm:word-bits)
+			      dx (index* dy dest-width))
+		      (index+ dest-idx dest-width))
+	    (count height (1- count)))
+	   ((zerop count))
+	 (declare (type array-index src-idx dest-idx count))
+	 (kernel:bit-bash-copy sdata src-idx ddata dest-idx width)))))
+
+#+CMU
+(defun fast-read-pixarray-using-bitblt
+       (bbuf boffset pixarray x y width height padded-bytes-per-line
+	bits-per-pixel)
+  (declare (type (array * 2) pixarray))
+  #.(declare-buffun)
+  (copy-bit-rect bbuf
+		 (index* padded-bytes-per-line vm:byte-bits)
+		 (index* boffset vm:byte-bits) 0
+		 pixarray
+		 (index* (array-dimension pixarray 1) bits-per-pixel)
+		 x y
+		 height
+		 (index* width bits-per-pixel))
+  t)
+
 #+(or Genera lcl3.0 excl)
 (defun fast-read-pixarray-with-swap
        (bbuf boffset pixarray x y width height padded-bytes-per-line
@@ -3199,13 +3300,16 @@
 				 bits-per-pixel)
 			      32))
 		     #'fast-read-pixarray-using-bitblt)
+		#+CMU
+		(and (index= (pixarray-element-size pixarray) bits-per-pixel)
+		     #'fast-read-pixarray-using-bitblt)
 		#+(or lcl3.0 excl)
 		(and (index= bits-per-pixel 1)
 		     #'fast-read-pixarray-1)
 		#+(or lcl3.0 excl)
 		(and (index= bits-per-pixel 4)
 		     #'fast-read-pixarray-4)
-		#+(or Genera lcl3.0 excl)
+		#+(or Genera lcl3.0 excl CMU)
 		(and (index= bits-per-pixel 24)
 		     #'fast-read-pixarray-24))))
       (when function
@@ -3321,7 +3425,7 @@
 		  (aref vector (index+ x 1))))))))
   t)
 
-#+(or Genera lcl3.0 excl)
+#+(or Genera lcl3.0 excl CMU)
 (defun fast-write-pixarray-24 (buffer-bbuf index array x y width height
 			       padded-bytes-per-line bits-per-pixel)
   (declare (type buffer-bytes buffer-bbuf)
@@ -3369,6 +3473,21 @@
    (sys:bitblt boole-1 width height pixarray x y a 0 0))
   t)
 
+#+CMU
+(defun fast-write-pixarray-using-bitblt
+       (bbuf boffset pixarray x y width height padded-bytes-per-line
+	bits-per-pixel)
+  #.(declare-buffun)
+  (copy-bit-rect pixarray
+		 (index* (array-dimension pixarray 1) bits-per-pixel)
+		 x y
+		 bbuf
+		 (index* padded-bytes-per-line vm:byte-bits)
+		 (index* boffset vm:byte-bits) 0
+		 height
+		 (index* width bits-per-pixel))
+  t)
+
 #+(or Genera lcl3.0 excl)
 (defun fast-write-pixarray-with-swap
        (bbuf boffset pixarray x y width height padded-bytes-per-line
@@ -3440,13 +3559,16 @@
 				 bits-per-pixel)
 			      32))
 		     #'fast-write-pixarray-using-bitblt)
+		#+CMU
+		(and (index= (pixarray-element-size pixarray) bits-per-pixel)
+		     #'fast-write-pixarray-using-bitblt)
 		#+(or lcl3.0 excl)
 		(and (index= bits-per-pixel 1)
 		     #'fast-write-pixarray-1)
 		#+(or lcl3.0 excl)
 		(and (index= bits-per-pixel 4)
 		     #'fast-write-pixarray-4)
-		#+(or Genera lcl3.0 excl)
+		#+(or Genera lcl3.0 excl CMU)
 		(and (index= bits-per-pixel 24)
 		     #'fast-write-pixarray-24))))
       (when function
@@ -3464,7 +3586,7 @@
 	   (type (member 1 4 8 16 24 32) bits-per-pixel))
   (progn pixarray copy x y width height bits-per-pixel nil)
   (or
-    #+lispm
+    #+(or lispm CMU)
     (let* ((pixarray-padded-pixels-per-line
 	     #+Genera (sys:array-row-span pixarray)
 	     #-Genera (array-dimension pixarray 1))
@@ -3475,11 +3597,22 @@
 	     #-Genera (array-dimension copy 1))
 	   (copy-padded-bits-per-line
 	     (* copy-padded-pixels-per-line bits-per-pixel)))
+      #-CMU
       (when (and (= (sys:array-element-size pixarray) bits-per-pixel)
 		 (zerop (index-mod pixarray-padded-bits-per-line 32))
 		 (zerop (index-mod copy-padded-bits-per-line 32)))
 	(sys:bitblt boole-1 width height pixarray x y copy 0 0)
+	t)
+      #+CMU
+      (when (index= (pixarray-element-size pixarray)
+		    (pixarray-element-size copy)
+		    bits-per-pixel)
+	(copy-bit-rect pixarray pixarray-padded-bits-per-line x y
+		       copy copy-padded-bits-per-line 0 0
+		       height
+		       (index* width bits-per-pixel))
 	t))
+	
     #+(or lcl3.0 excl)
     (unless (index= bits-per-pixel 24)
       (let ((pixarray-padded-bits-per-line
diff --git a/clx/manager.lisp b/clx/manager.lisp
index 5366cd18e..151e8be3c 100644
--- a/clx/manager.lisp
+++ b/clx/manager.lisp
@@ -317,8 +317,8 @@
 		(decode-type (member-vector *win-gravity-vector*) (aref vector 17)))))
       ;; Obsolete fields
       (when (or (logbitp 0 flags) (logbitp 2 flags))
-	(setf (wm-size-hints-x hints) (aref vector 1)
-	      (wm-size-hints-y hints) (aref vector 2)))
+	(setf (wm-size-hints-x hints) (card32->int32 (aref vector 1))
+	      (wm-size-hints-y hints) (card32->int32 (aref vector 2))))
       (when (or (logbitp 1 flags) (logbitp 3 flags))
 	(setf (wm-size-hints-width hints) (aref vector 3)
 	      (wm-size-hints-height hints) (aref vector 4)))
diff --git a/code/alieneval.lisp b/code/alieneval.lisp
index 7828e3668..6f37ae2d9 100644
--- a/code/alieneval.lisp
+++ b/code/alieneval.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/alieneval.lisp,v 1.37 1996/07/12 20:51:51 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/alieneval.lisp,v 1.38 1997/01/18 14:30:58 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1391,13 +1391,21 @@
 				,@(when initial-value
 				    `((setq ,symbol ,initval)))
 				,@body)
-			     (dispose-local-alien ',info ,var))))))))))))
+			     ;; This is a (temporary?) hack to
+			     ;; counter resetting the stack BEFORE
+			     ;; recovering values at stack top. We just
+			     ;; let normal stack resetting to occur. This
+			     ;; might be bad in a loop of with-alien forms.
+			     #-x86 
+			     (dispose-local-alien ',info ,var)
+			     )))))))))))
     (verify-local-auxiliaries-okay)
     `(compiler-let (*auxiliary-type-definitions*
 		    ',(append *new-auxiliary-types*
 			      *auxiliary-type-definitions*))
        ,@body)))
 
+
 
 ;;;; Runtime C values that don't correspond directly to Lisp types.
 
diff --git a/code/bignum.lisp b/code/bignum.lisp
index 47819f91b..71addb49a 100644
--- a/code/bignum.lisp
+++ b/code/bignum.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/bignum.lisp,v 1.21 1994/10/31 04:11:27 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/bignum.lisp,v 1.22 1997/01/18 14:30:50 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -2483,9 +2483,10 @@ IS LESS EFFICIENT BUT EASIER TO MAINTAIN.  BILL SAYS THIS CODE CERTAINLY WORKS!
 		     (%bignum-ref result (- len 2)))
 	 (sign-digit (%bignum-ref result (1- len)) next-digit))
 	((not (zerop (logxor sign-digit (%ashr next-digit (1- digit-size))))))
-      (when (= (decf len) 1)
-	(return))
-      (setf (%bignum-ref result len) 0)))
+	(decf len)
+	(setf (%bignum-ref result len) 0)	
+	(when (= len 1)
+	      (return))))
   len)
 
 ;;; %NORMALIZE-BIGNUM -- Internal.
diff --git a/code/bit-bash.lisp b/code/bit-bash.lisp
index 290d5b2e4..de4f47283 100644
--- a/code/bit-bash.lisp
+++ b/code/bit-bash.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/bit-bash.lisp,v 1.18 1994/10/31 04:11:27 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/bit-bash.lisp,v 1.19 1997/01/18 14:30:33 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -77,6 +77,7 @@
       (:big-endian big-endian)
       (:little-endian little-endian))))
 
+(proclaim '(inline shift-towards-start shift-towards-end))
 (defun shift-towards-start (number count)
   "Shift NUMBER by COUNT bits, adding zero bits at the ``end'' and removing
   bits from the ``start.''  On big-endian machines this is a left-shift and
diff --git a/code/bsd-os.lisp b/code/bsd-os.lisp
new file mode 100644
index 000000000..b1a673e52
--- /dev/null
+++ b/code/bsd-os.lisp
@@ -0,0 +1,66 @@
+;;; -*- Package: SYSTEM -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/bsd-os.lisp,v 1.1 1997/01/18 14:30:43 ram Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; OS interface functions for CMU CL under Mach.
+;;;
+;;; Written and maintained mostly by Skef Wholey and Rob MacLachlan.
+;;; Scott Fahlman, Dan Aronson, and Steve Handerson did stuff here, too.
+;;;
+;;; Hacked into (Free)bsd-os.lisp /Werkowski
+
+(in-package "SYSTEM")
+(use-package "EXTENSIONS")
+(export '(get-system-info get-page-size os-init))
+
+(pushnew :bsd *features*)
+(pushnew :freebsd *features*)
+
+(setq *software-type* "FreeBSD/4.4Lite")
+
+(defun software-version ()
+  "Returns a string describing version of the supporting software."
+  (string-trim '(#\newline)
+	       (with-output-to-string (stream)
+		 (run-program "/usr/bin/uname" '("-sr") :output stream))))
+
+
+;;; OS-Init initializes our operating-system interface.  It sets the values
+;;; of the global port variables to what they should be and calls the functions
+;;; that set up the argument blocks for the server interfaces.
+
+(defun os-init ()
+  nil)
+
+
+;;; GET-SYSTEM-INFO  --  Interface
+;;;
+;;;    Return system time, user time and number of page faults.
+;;;
+(defun get-system-info ()
+  (multiple-value-bind (err? utime stime maxrss ixrss idrss
+			     isrss minflt majflt)
+		       (unix:unix-getrusage unix:rusage_self)
+    (declare (ignore maxrss ixrss idrss isrss minflt))
+    (unless err?
+      (error "Unix system call getrusage failed: ~A."
+	     (unix:get-unix-error-msg utime)))
+    
+    (values utime stime majflt)))
+
+
+;;; GET-PAGE-SIZE  --  Interface
+;;;
+;;;    Return the system page size.
+;;;
+(defun get-page-size ()
+  ;; probably should call getpagesize()
+  4096)
+
diff --git a/code/byte-interp.lisp b/code/byte-interp.lisp
index 5d3ae9cbd..382b77585 100644
--- a/code/byte-interp.lisp
+++ b/code/byte-interp.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/byte-interp.lisp,v 1.31 1994/10/31 04:11:27 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/byte-interp.lisp,v 1.32 1997/01/18 14:31:13 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -163,11 +163,13 @@
 	(when (hairy-byte-function-rest-arg-p x)
 	  (res '&rest 't))
 	(ecase (hairy-byte-function-keywords-p x)
-	  ((t) (res '&key))
-	  (:allow-others (res '&key '&allow-other-keys))
+	  ((t :allow-others)
+	   (res '&key)
+	   (dolist (key (hairy-byte-function-keywords x))
+		   (res `(,(car key) t)))
+	   (if (eql (hairy-byte-function-keywords-p x) :allow-others)
+	       (res '&allow-other-keys)))
 	  ((nil)))
-	(dolist (key (hairy-byte-function-keywords x))
-	  (res `(,(car key) t)))
 	`(function ,(res) *))))))
 
 
diff --git a/code/clx-ext.lisp b/code/clx-ext.lisp
index 7aa8d3e09..5aba98c6b 100644
--- a/code/clx-ext.lisp
+++ b/code/clx-ext.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/clx-ext.lisp,v 1.10 1994/10/31 04:11:27 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/clx-ext.lisp,v 1.11 1997/01/18 14:30:53 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -49,7 +49,13 @@
   (when string
     (let* ((string (coerce string 'simple-string))
 	   (length (length string))
-	   (host-name "unix")
+	   ;;pw--unix seems to be a non-existent host on all the systems
+	   ;; I have access to, and certainly not on linux. Unless unix
+	   ;; is an alias in /etc/hosts this won't work. So, lets use
+	   ;; gethostname instead. There are also some issues regarding
+	   ;; DNS and full/part time internet connection to get in the
+	   ;; way of this working but those are not solved here.
+	   (host-name #+nil "unix" (unix:unix-gethostname))
 	   (display-num nil)
 	   (screen-num nil))
       (declare (simple-string string))
diff --git a/code/debug-int.lisp b/code/debug-int.lisp
index 5131e495f..dd9188f5d 100644
--- a/code/debug-int.lisp
+++ b/code/debug-int.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.68 1994/10/31 04:11:27 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.69 1997/01/18 14:31:08 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -836,17 +836,194 @@
 (defun kernel:function-word-offset (fun) (kernel:function-word-offset fun))
 ;;;
 (defsetf kernel:stack-ref kernel:%set-stack-ref)
-
+
 (proclaim '(inline cstack-pointer-valid-p))
+;;; This must come before any use (of course) else the cross compiler
+;;; uses it's own version which is WRONG for x86!!!
 (defun cstack-pointer-valid-p (x)
   (declare (type system:system-area-pointer x))
+  #-:x86
   (and (system:sap< x (kernel:current-sp))
        (system:sap<= #-gengc (alien:alien-sap
 			      (alien:extern-alien "control_stack" (* t)))
 		     #+gengc (kernel:mutator-control-stack-base)
 		     x)
+       (zerop (logand (system:sap-int x) #b11)))
+  #+:x86 ;; stack grows to low address values
+  (and (system:sap>= x (kernel:current-sp))
+       (system:sap>   (alien:alien-sap
+		       (alien:extern-alien "control_stack_end" (* t)))
+		      x)
        (zerop (logand (system:sap-int x) #b11))))
 
+;;;; X86 support. Don't have lra objects so will search back for code header.
+
+(eval-when (compile eval)
+  (defmacro c-var-frob (lisp-fun c-var-name)
+    `(progn
+       (declaim (inline ,lisp-fun))
+       (defun ,lisp-fun ()
+	 (alien:extern-alien ,c-var-name (alien:unsigned 32))))))
+
+(c-var-frob static-space-start "static_space")
+(c-var-frob read-only-space-start "read_only_space")
+
+(defun compiled-function-from-pc (pc &optional (limit 50000))
+  ;;; x86 hack around not having lra objects.
+  (declare (type system-area-pointer pc)
+	   (fixnum limit))
+  (let ((base (int-sap (kernel:32bit-logical-and
+			(sap-int pc)
+			(kernel:32bit-logical-not vm:lowtag-mask)))))
+    (declare (type system-area-pointer base))
+    (do ((hdrp (- (sap-int base) vm:word-bytes)
+	       (- hdrp vm:word-bytes))
+	 (times limit (1- times)))
+	((or (zerop times)
+	     (> (read-only-space-start) hdrp))
+	 nil)
+      (declare (type (unsigned-byte 32) hdrp)
+	       (fixnum times))
+      (let ((hdrval (sap-ref-32 (int-sap hdrp) 0)))
+	(declare (type (unsigned-byte 32) hdrval))
+	#+nil (format t "~&~x ~x~%" hdrp hdrval)
+	(when (and (= (kernel:32bit-logical-and hdrval vm:type-mask)
+		      vm:function-header-type)
+		   (= (sap-ref-32 (int-sap hdrp)
+				  (* vm:function-self-slot vm:word-bytes))
+		      (+ hdrp (* vm:function-code-offset vm:word-bytes))))
+	  (let ((maybe-fcn (kernel:make-lisp-obj
+			    (+ hdrp vm:function-pointer-type))))
+	    (when (and (functionp maybe-fcn) (compiled-function-p maybe-fcn))
+	      (return maybe-fcn))))))))
+
+
+
+(defun compute-lra-data-from-pc(pc)
+  ;; pc is offset from dualword aligned function header
+  (declare (type system-area-pointer pc))
+  (let ((function (compiled-function-from-pc pc)))
+    (when function
+      (let* ((code (kernel:function-code-header function))
+	     (code-header-len (* (kernel:get-header-data code)
+				 vm:word-bytes))
+	     (pc-offset
+	      (- (sap-int pc)
+		 (- (kernel:get-lisp-obj-address code)
+		    vm:other-pointer-type)
+		 code-header-len)))
+;	(format t "c-lra-fpc ~a ~a ~a~%" pc code pc-offset)
+	(values pc-offset code)))))
+
+;;; maybe these should be generalized in xxx-vm.lisp
+;;;(proclaim '(inline old-frame-pointer lisp-return-pc))
+(defun old-frame-pointer(scp)
+  (declare (type (alien:alien (* unix:sigcontext)) scp))
+  (let* #+x86 ((cfp (vm:sigcontext-register scp vm::ebp-offset))
+	       (ofp (kernel:stack-ref (int-sap cfp) vm::ocfp-save-offset)))
+	#-x86 ((ofp (vm:sigcontext-register scp vm::ocfp-offset)))
+	(declare (type (unsigned-byte 32) #+x86 cfp ofp))
+	(int-sap ofp)))
+
+
+#+x86
+(defun lisp-return-pc(scp)
+  ;;; return a value that can be used in computation
+  (declare (type (alien:alien (* unix:sigcontext)) scp))
+  (let* ((cfp (vm:sigcontext-register scp vm::ebp-offset))
+	 (lra (kernel:stack-ref (int-sap cfp) vm::return-pc-save-offset)))
+    lra))
+#-x86
+(defun lisp-return-pc(scp)
+  (declare (type (alien:alien (* unix:sigcontext)) scp))
+  (vm:sigcontext-register scp vm::lra-offset))
+
+#+x86
+(defconstant vm::nargs-offset #.vm::ecx-offset)
+#+x86
+(progn
+(defun lisp-return-pc-valid-p(loc)
+  (declare (type system-area-pointer loc))
+  (let ((code-beg (int-sap (static-space-start)))
+	(code-end (int-sap (* lisp::*static-space-free-pointer*
+			      vm:word-bytes))))
+    (and (sap< code-beg loc)
+	 (sap< loc code-end))))
+
+(declaim (inline make-fixnum))
+(defun make-fixnum (sap)
+  (kernel:make-lisp-obj (ash (sap-int sap) 2)))
+
+;; These return hopefully correct ofp ret values at a call site
+(defun maybe-lisp-from-c(fp)
+  (declare (type system-area-pointer fp))
+  (let ((s0 (kernel:stack-ref fp vm::old-fp-save-offset))
+	(s1 (kernel:stack-ref fp vm::return-pc-save-offset)))
+    (when (and (kernel:make-lisp-obj s0)(kernel:make-lisp-obj s1))
+      (let ((lisp-ofp (int-sap s0))
+	    (lisp-lra (int-sap s1)))
+	;;(format t "~&cf? ~a ~a~%" lisp-ofp lisp-lra)
+	;; Check  this logic now that C calls with lra.
+	(when (sap= lisp-ofp lisp-lra)	; Can't happen via Lisp
+	  (let ((cfp (sap-ref-sap fp (* 0 vm:word-bytes)))
+		(cra (sap-ref-sap fp (* 1 vm:word-bytes))))
+	    ;;(format t "~&cf! ~a ~a~%" cfp cra)
+	    (list (make-fixnum cra) cfp)))))))
+
+(defun maybe-lisp-from-lisp(fp)
+    (declare (type system-area-pointer fp))
+    (when (cstack-pointer-valid-p fp)
+      (let ((s0 (kernel:stack-ref fp vm::old-fp-save-offset))
+	    (s1 (kernel:stack-ref fp vm::return-pc-save-offset)))
+	(when (and (kernel:make-lisp-obj s0)
+		   (kernel:make-lisp-obj s1))
+	  (let ((ofp (int-sap s0))
+		(lra (int-sap s1)))
+	    ;;(format t "~&mlf ~a ~a~%" ofp lra)
+	    (and (cstack-pointer-valid-p ofp)
+		 (lisp-return-pc-valid-p lra)
+		 (list (kernel:make-lisp-obj s1) ofp)))))))
+
+(defun maybe-c-from-c(fp)
+  (declare (type system-area-pointer fp))
+  (let ((cfp (sap-ref-sap fp (* 0 vm:word-bytes)))
+	(cra (sap-ref-sap fp (* 1 vm:word-bytes)))
+	(end (int-sap (* lisp::*static-space-free-pointer* vm:word-bytes))))
+    ;;(format t "~&cfc? ~a ~a" cfp cra)
+    (when (cstack-pointer-valid-p cfp)
+      (cond ((sap< cra (int-sap (static-space-start)))
+	     ;;(format t "~&cfc!~%")
+	     (list (make-fixnum cra) cfp))
+	  ;; sigtrap handler from interrupt
+	  ((sap> cra end)
+	   ;;(format t "~&INT~%")
+	   (list nil cfp))))))
+
+;;; ^C a running program and get C call semantics with Lisp return address.
+(defun maybe-c-from-lisp(fp)
+  (declare (type system-area-pointer fp))
+  (let ((cfp (sap-ref-sap fp (* 0 vm:word-bytes)))
+	(cra (sap-ref-sap fp (* 1 vm:word-bytes)))
+	(end (int-sap (* lisp::*static-space-free-pointer* vm:word-bytes))))
+    ;;(format t "~&cfl? ~a ~a" cfp cra)
+    (when (cstack-pointer-valid-p cfp)
+      (cond ((sap< cra end)
+	     ;;(format t "~&cfl!~%")
+	     (list (make-fixnum cra) cfp))))))
+
+(defun x86-call-context(fp)
+  (declare (type system-area-pointer fp))
+  (let ((pair (cond ((maybe-lisp-from-lisp fp))
+		    ((maybe-lisp-from-c fp))
+		    ((maybe-c-from-c fp))
+		    ((maybe-c-from-lisp fp)))))
+    (if pair
+      (apply #'values pair)
+      (error "Debug can't resolve frame ~a" fp))))
+)
+;;; end of x86 hacks
+
+
 ;;; DESCRIPTOR-SAP -- internal
 ;;;
 ;;; Convert the descriptor into a SAP.  The bits all stay the same, we just
@@ -899,7 +1076,7 @@
 				 debug-fun)))
 		     (possibly-an-interpreted-frame
 		      (compute-calling-frame
-		       (descriptor-sap
+		       ( #-x86 descriptor-sap #+x86 int-sap
 			(get-context-value
 			 real vm::ocfp-save-offset
 			 (c::compiled-debug-function-old-fp c-d-f)))
@@ -917,15 +1094,18 @@
 		  (bogus-debug-function
 		   (let ((fp (frame-pointer real)))
 		     (when (cstack-pointer-valid-p fp)
+		       #+x86
+		        (multiple-value-bind (ra ofp) (x86-call-context fp)
+			  (compute-calling-frame ofp ra frame))
+			#-x86
 		       (compute-calling-frame
 			#-alpha
-			(system:sap-ref-sap fp (* vm::ocfp-save-offset
-						  vm:word-bytes))
+			(system:sap-ref-sap
+			 fp (* vm::ocfp-save-offset vm:word-bytes))
 			#+alpha
 			(kernel::int-sap
-			 (system:sap-ref-32 fp (* vm::ocfp-save-offset
-						  vm:word-bytes)))
-
+			 (system:sap-ref-32
+			  fp (* vm::ocfp-save-offset vm:word-bytes)))
 			#-gengc
 			(kernel:stack-ref fp vm::lra-save-offset)
 			#+gengc
@@ -941,6 +1121,7 @@
 ;;; location offset on the stack.  Loc is the saved sc-offset describing the
 ;;; main location.
 ;;;
+#-x86
 (defun get-context-value (frame stack-slot loc)
   (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
 	   (type c::sc-offset loc))
@@ -949,6 +1130,25 @@
     (if escaped
 	(sub-access-debug-var-slot pointer loc escaped)
 	(kernel:stack-ref pointer stack-slot))))
+#+x86
+(defun get-context-value (frame stack-slot loc)
+  (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
+	   (type c::sc-offset loc))
+  (let ((pointer (frame-pointer frame))
+	(escaped (compiled-frame-escaped frame)))
+    (if escaped
+	(ecase stack-slot
+	  (#.vm::ocfp-save-offset
+	   (sub-access-debug-var-slot pointer loc escaped))
+	  (#.vm::lra-save-offset
+	   (kernel:make-lisp-obj
+	    (sub-access-debug-var-slot pointer loc escaped))))
+	(ecase stack-slot
+	  (#.vm::ocfp-save-offset
+	   (kernel:stack-ref pointer stack-slot))
+	  (#.vm::lra-save-offset
+	   (kernel:make-lisp-obj (kernel:stack-ref pointer stack-slot)))))))
+
 ;;;
 (defun (setf get-context-value) (value frame stack-slot loc)
   (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
@@ -1023,23 +1223,36 @@
 ;;; Note: Sometimes LRA is actually a fixnum.  This happens when lisp calls
 ;;; into C.  In this case, the code object is stored on the stack after the
 ;;; LRA, and the LRA is the word offset.
-;;; 
+;;;
+;;;; x86 note. The non-lra version has not been tested with the
+;;;; recent changes. I'm probably going to move to just using lra
+;;;; and remove the x86-lra feature at some point.
 #-gengc
 (defun compute-calling-frame (caller lra up-frame)
   (declare (type system:system-area-pointer caller))
+  ;;(format t "ccf: ~x ~a ~a~%" (sap-int caller) lra up-frame)
   (when (cstack-pointer-valid-p caller)
     (multiple-value-bind
 	(code pc-offset escaped)
 	(if lra
 	    (multiple-value-bind
-		(word-offset code)
+		  (word-offset code)
 		(if (ext:fixnump lra)
 		    (let ((fp (frame-pointer up-frame)))
-		      (values lra
-			      (kernel:stack-ref fp (1+ vm::lra-save-offset))))
+		      #+x86 (declare (ignore fp))
+		      (values
+		       lra
+		       #-x86 ;; fake-foreign-fcn sticks CODE pointer here
+		       (kernel:stack-ref fp (1+ vm::lra-save-offset))))
+		    #+(or x86-lra (not x86))
 		    (values (kernel:get-header-data lra)
-			    (kernel:lra-code-header lra)))
+			    (kernel:lra-code-header lra))
+		    #+(and x86 (not x86-lra))
+		    (compute-lra-data-from-pc (int-sap lra)))
+			
 	      (if code
+		  #+(and x86 (not x86-lra))(values code word-offset nil)
+		  #+(or x86-lra (not x86))
 		  (values code
 			  (* (1+ (- word-offset (kernel:get-header-data code)))
 			     vm:word-bytes)
@@ -1070,7 +1283,7 @@
 				 (if up-frame (1+ (frame-number up-frame)) 0)
 				 escaped))))))
 
-#-gengc
+#-(or gengc x86)
 (defun find-escaped-frame (frame-pointer)
   (declare (type system:system-area-pointer frame-pointer))
   (dotimes (index lisp::*free-interrupt-context-index* (values nil 0 nil))
@@ -1103,7 +1316,7 @@
 		 ;; We were in an assembly routine.  Therefore, use the LRA as
 		 ;; the pc.
 		 (setf pc-offset
-		       (- (vm:sigcontext-register scp vm::lra-offset)
+		       (- (lisp-return-pc scp)
 			  (kernel:get-lisp-obj-address code)
 			  code-header-len)))
 	       (return
@@ -1114,6 +1327,29 @@
 			      (kernel:get-header-data real-lra)
 			      nil))
 		    (values code pc-offset scp)))))))))))
+#+x86
+(defun find-escaped-frame (frame-pointer)
+  (declare (type system:system-area-pointer frame-pointer))
+  (dotimes (index lisp::*free-interrupt-context-index* (values nil 0 nil))
+    (alien:with-alien
+	((lisp-interrupt-contexts (array (* unix:sigcontext) nil) :extern))
+      (let ((scp (alien:deref lisp-interrupt-contexts index)))
+	(when (sap= frame-pointer
+		    (int-sap (vm:sigcontext-register scp vm::cfp-offset)))
+	  (system:without-gcing
+	   (multiple-value-bind
+		 (pc-offset code)
+	       (compute-lra-data-from-pc (vm:sigcontext-program-counter scp))
+	     (when (symbolp code)
+	       (return (values code 0 scp)))
+	     (return
+	       (if (eq (kernel:%code-debug-info code) :bogus-lra)
+		   (let ((real-lra (kernel:code-header-ref
+				    code real-lra-slot)))
+		     (values (kernel:lra-code-header real-lra)
+			     (kernel:get-header-data real-lra)
+			     nil))
+		   (values code pc-offset scp))))))))))
 
 ;;; CODE-OBJECT-FROM-BITS  --  internal.
 ;;;
@@ -1246,8 +1482,7 @@
 		;; ### Need to do something real.
 		(values (make-bogus-debug-function "Assembler routine.")
 			0
-			(system:int-sap
-			 (vm:sigcontext-register state vm::ocfp-offset))))
+			(old-frame-pointer state)))
 	       (#.vm:trace-table-function-prologue
 		(values (make-bogus-debug-function
 			 "Function-Prologue in an assembler routine?")
@@ -1272,8 +1507,7 @@
 	       (#.vm:trace-table-call-site
 		(values (debug-function-from-pc component pc-offset)
 			pc-offset
-			(system:int-sap
-			 (vm:sigcontext-register state vm::ocfp-offset))))
+			(old-frame-pointer state)))
 	       (#.vm:trace-table-function-prologue
 		#+nil ;; ### Need to do something real.
 		(let* ((ra (system:int-sap
@@ -1363,6 +1597,8 @@
 ;;; the component, for function constants, and the c::compiled-debug-function.
 ;;;
 (defun debug-function-from-pc (component pc)
+  #+x86 ;; until no more bugs at least.
+  (declare (optimize (safety 1)(debug .5)))
   (let ((info (kernel:%code-debug-info component)))
     (cond
      ((not info)
@@ -2705,24 +2941,25 @@
 	 (frame-pointer frame)
 	 (or (compiled-debug-variable-save-sc-offset debug-var)
 	     (compiled-debug-variable-sc-offset debug-var))))))
-
+
 ;;; SUB-ACCESS-DEBUG-VAR-SLOT -- Internal.
 ;;;
+#-x86
 (defun sub-access-debug-var-slot (fp sc-offset &optional escaped)
   (macrolet ((with-escaped-value ((var) &body forms)
 	       `(if escaped
-		    (let ((,var (vm:sigcontext-register
-				 escaped
-				 (c::sc-offset-offset sc-offset))))
-		      ,@forms)
-		    :invalid-value-for-unescaped-register-storage))
+		 (let ((,var (vm:sigcontext-register
+			      escaped
+			      (c::sc-offset-offset sc-offset))))
+		   ,@forms)
+		 :invalid-value-for-unescaped-register-storage))
 	     (escaped-float-value (format)
 	       `(if escaped
-		    (vm:sigcontext-float-register
-		     escaped
-		     (c::sc-offset-offset sc-offset)
-		     ',format)
-		    :invalid-value-for-unescaped-register-storage))
+		 (vm:sigcontext-float-register
+		  escaped
+		  (c::sc-offset-offset sc-offset)
+		  ',format)
+		 :invalid-value-for-unescaped-register-storage))
 	     (with-nfp ((var) &body body)
 	       `(let ((,var (if escaped
 				(system:int-sap
@@ -2775,6 +3012,8 @@
 				       vm:word-bytes))))
       (#.vm:control-stack-sc-number
        (kernel:stack-ref fp (c::sc-offset-offset sc-offset)))
+      (#.vm:immediate-stack-sc-number
+       (kernel:stack-ref fp (c::sc-offset-offset sc-offset)))
       (#.vm:base-char-stack-sc-number
        (with-nfp (nfp)
 	 (code-char (system:sap-ref-32 nfp (* (c::sc-offset-offset sc-offset)
@@ -2792,6 +3031,90 @@
 	 (system:sap-ref-sap nfp (* (c::sc-offset-offset sc-offset)
 				    vm:word-bytes)))))))
 
+#+x86
+(defun sub-access-debug-var-slot (fp sc-offset &optional escaped)
+  (declare (type system:system-area-pointer fp))
+  (macrolet ((with-escaped-value ((var) &body forms)
+	       `(if escaped
+		 (let ((,var (vm:sigcontext-register
+			      escaped
+			      (c::sc-offset-offset sc-offset))))
+		   ,@forms)
+		 :invalid-value-for-unescaped-register-storage))
+	     (escaped-float-value (format)
+	       `(if escaped
+		 (vm:sigcontext-float-register
+		  escaped
+		  (c::sc-offset-offset sc-offset)
+		  ',format)
+		 :invalid-value-for-unescaped-register-storage)))
+    (case (c::sc-offset-scn sc-offset)
+      ((#.vm:any-reg-sc-number
+	#.vm:descriptor-reg-sc-number)
+       (system:without-gcing
+	(with-escaped-value (val)
+	  (kernel:make-lisp-obj val))))
+      (#.vm:base-char-reg-sc-number
+       (with-escaped-value (val)
+	 (code-char val)))
+      (#.vm:sap-reg-sc-number
+       (with-escaped-value (val)
+	 (system:int-sap val)))
+      (#.vm:signed-reg-sc-number
+       (with-escaped-value (val)
+	 (if (logbitp (1- vm:word-bits) val)
+	     (logior val (ash -1 vm:word-bits))
+	     val)))
+      (#.vm:unsigned-reg-sc-number
+       (with-escaped-value (val)
+	 val))
+      (#.vm:non-descriptor-reg-sc-number
+       (error "Local non-descriptor register access?"))
+      (#.vm:interior-reg-sc-number
+       (error "Local interior register access?"))
+      (#.vm:single-reg-sc-number
+       (escaped-float-value single-float))
+      (#.vm:double-reg-sc-number
+       (escaped-float-value double-float))
+      (#.vm:single-stack-sc-number
+       (system:sap-ref-single
+	(system:int-sap (- (system:sap-int fp)
+			   (* (1+ (c::sc-offset-offset sc-offset))
+			      vm:word-bytes))) 0))
+      (#.vm:double-stack-sc-number
+	(system:sap-ref-double
+	  (system:int-sap (- (system:sap-int fp)
+			  (* (+ (c::sc-offset-offset sc-offset) 2)
+				vm:word-bytes))) 0))
+      ((#.vm:control-stack-sc-number #.vm:immediate-stack-sc-number)
+       (kernel:make-lisp-obj
+	(kernel:stack-ref fp (c::sc-offset-offset sc-offset))))
+      (#.vm:base-char-stack-sc-number
+       (code-char
+	(system:sap-ref-32
+	 (system:int-sap (- (system:sap-int fp)
+			    (* (1+ (c::sc-offset-offset sc-offset))
+			       vm:word-bytes))) 0)))
+      (#.vm:unsigned-stack-sc-number
+       (system:sap-ref-32
+	(system:int-sap (- (system:sap-int fp)
+			   (* (1+ (c::sc-offset-offset sc-offset))
+			      vm:word-bytes))) 0))
+      (#.vm:signed-stack-sc-number
+       (system:signed-sap-ref-32
+	(system:int-sap (- (system:sap-int fp)
+			   (* (1+ (c::sc-offset-offset sc-offset))
+			      vm:word-bytes))) 0))
+      (#.vm:sap-stack-sc-number
+       (system:sap-ref-sap 
+	(system:int-sap (- (system:sap-int fp)
+			   (* (1+ (c::sc-offset-offset sc-offset))
+			      vm:word-bytes))) 0))
+      ;; Not using ecase to avoid recursive processing.
+      ;; I would rather see some hint as to what is wrong
+      (t (format t "Sc-offset-scn ~a fell through CASE ~%"
+		 (c::sc-offset-scn sc-offset)) nil))
+    ))
 
 ;;; %SET-DEBUG-VARIABLE-VALUE -- Internal.
 ;;;
@@ -2842,6 +3165,7 @@
 
 ;;; SUB-SET-DEBUG-VAR-SLOT -- Internal.
 ;;;
+#-x86 ;; preserve original
 (defun sub-set-debug-var-slot (fp sc-offset value &optional escaped)
   (macrolet ((set-escaped-value (val)
 	       `(if escaped
@@ -2929,6 +3253,81 @@
 					  vm:word-bytes))
 	       (the system:system-area-pointer value)))))))
 
+#+x86 
+(defun sub-set-debug-var-slot (fp sc-offset value &optional escaped)
+  (macrolet ((set-escaped-value (val)
+	       `(if escaped
+		    (setf (vm:sigcontext-register
+			   escaped
+			   (c::sc-offset-offset sc-offset))
+			  ,val)
+		    value)))
+    #+nil ;; debug
+    (format t "~&sdvs ~a ~a ~a  <= ~a~%" 
+	    (sc-number-name (c::sc-offset-scn sc-offset))
+	    (disassem::get-sc-name sc-offset c:*native-backend*)
+	    (not (null escaped))
+	    value)
+    (ecase (c::sc-offset-scn sc-offset)
+      ((#.vm:any-reg-sc-number
+	#.vm:descriptor-reg-sc-number
+	#+rt #.vm:word-pointer-reg-sc-number)
+       (system:without-gcing
+	(set-escaped-value
+	  (kernel:get-lisp-obj-address value))))
+      (#.vm:base-char-reg-sc-number
+       (set-escaped-value (char-code value)))
+      (#.vm:sap-reg-sc-number
+       (set-escaped-value (system:sap-int value)))
+      (#.vm:signed-reg-sc-number
+       (set-escaped-value (logand value (1- (ash 1 vm:word-bits)))))
+      (#.vm:unsigned-reg-sc-number
+       (set-escaped-value value))
+      (#.vm:non-descriptor-reg-sc-number
+       (error "Local non-descriptor register access?"))
+      (#.vm:interior-reg-sc-number
+       (error "Local interior register access?"))
+      (#.vm:single-reg-sc-number
+	#+nil ;; don't have escaped floats.
+       (set-escaped-float-value single-float value))
+      (#.vm:double-reg-sc-number
+	#+nil ;;  don't have escaped floats -- still in npx?
+       (set-escaped-float-value double-float value))
+      (#.vm:single-stack-sc-number
+       (setf (system:sap-ref-single
+	      (system:sap+ fp (* (1+ (c::sc-offset-offset sc-offset))
+				 (- vm:word-bytes))) 0)
+	     (the single-float value)))
+      (#.vm:double-stack-sc-number
+       (setf (system:sap-ref-double
+	      (system:sap+ fp (* (+ (c::sc-offset-offset sc-offset) 2)
+				 (- vm:word-bytes))) 0)
+	     (the double-float value)))
+      ((#.vm:control-stack-sc-number #.vm:immediate-stack-sc-number)
+       (setf (kernel:stack-ref fp (c::sc-offset-offset sc-offset)) value))
+      (#.vm:base-char-stack-sc-number
+       (setf (system:sap-ref-32
+	      (system:sap+ fp (* (1+ (c::sc-offset-offset sc-offset))
+				 (- vm:word-bytes))) 0)
+  	     (char-code (the character value))))
+      (#.vm:unsigned-stack-sc-number
+       (setf (system:sap-ref-32
+	      (system:sap+ fp (* (1+ (c::sc-offset-offset sc-offset))
+				 (- vm:word-bytes))) 0)
+	     (the (unsigned-byte 32) value)))
+      (#.vm:signed-stack-sc-number
+       (setf (system:signed-sap-ref-32
+	      (system:sap+ fp (* (1+ (c::sc-offset-offset sc-offset))
+				 (- vm:word-bytes))) 0)
+ 	     (the (signed-byte 32) value)))
+      (#.vm:sap-stack-sc-number
+       (setf (system:sap-ref-sap
+	      (system:sap+ fp (* (1+ (c::sc-offset-offset sc-offset))
+				 (- vm:word-bytes))) 0)
+	     (the system:system-area-pointer value))))))
+
+
+
 (defsetf debug-variable-value %set-debug-variable-value)
 
 
@@ -2973,6 +3372,8 @@
 ;;; This is the method for DEBUG-VARIABLE-VALIDITY for compiled-debug-variables.
 ;;; For safety, make sure basic-code-loc is what we think.
 ;;;
+;;#+x86-compile-botch ;; tn conflict S1
+
 (defun compiled-debug-variable-validity (debug-var basic-code-loc)
   (check-type basic-code-loc compiled-code-location)
   (cond ((debug-variable-alive-p debug-var)
@@ -3025,6 +3426,7 @@
 ;;; Temporary buffer used to build form-number => source-path translation in
 ;;; FORM-NUMBER-TRANSLATIONS.
 ;;;
+
 (defvar *form-number-temp* (make-array 10 :fill-pointer 0 :adjustable t))
 
 ;;; Table used to detect CAR circularities in FORM-NUMBER-TRANSLATIONS.
@@ -3609,6 +4011,18 @@
 ;;; handle breaks for internal errors.
 ;;;
 (defun handle-breakpoint (offset component signal-context)
+#+x86
+  (multiple-value-bind (byte-offset code)
+      (let* ((pc (vm:sigcontext-program-counter
+		  (alien:sap-alien signal-context (* unix:sigcontext))))
+	     (fn (compiled-function-from-pc pc)))
+	(values (- (sap-int pc)
+		   (- (kernel:get-lisp-obj-address fn)
+		      vm:function-pointer-type))
+		(kernel:function-code-header fn)))
+    (setq offset byte-offset
+	  component code))
+
   (let ((data (breakpoint-data component offset nil)))
     (unless data
       (error "Unknown breakpoint in ~S at offset ~S."
@@ -3712,7 +4126,7 @@
 	       cookie))))
 
 (defun get-function-end-breakpoint-values (scp)
-  (let ((ocfp (system:int-sap (vm:sigcontext-register scp vm::ocfp-offset)))
+  (let ((ocfp (old-frame-pointer scp))
 	(nargs (kernel:make-lisp-obj
 		(vm:sigcontext-register scp vm::nargs-offset)))
 	(reg-arg-offsets '#.vm::register-arg-offsets)
diff --git a/code/defmacro.lisp b/code/defmacro.lisp
index 4de374023..a72f03011 100644
--- a/code/defmacro.lisp
+++ b/code/defmacro.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defmacro.lisp,v 1.19 1996/05/08 13:24:59 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defmacro.lisp,v 1.20 1997/01/18 14:31:00 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -228,26 +228,30 @@
 		  (push-let-binding var nil nil))))
 	      (t
 	       (error "Non-symbol in lambda-list - ~S." var)))))
-    (push `(unless (<= ,minimum
-		       (length (the list ,(if top-level
-					      `(cdr ,arg-list-name)
-					      arg-list-name)))
-		       ,@(unless restp
-			   (list maximum)))
-	     ,(let ((arg (if top-level
-			     `(cdr ,arg-list-name)
-			     arg-list-name)))
-		(if (eq error-fun 'error)
-		    `(do-arg-count-error ',error-kind ',name ,arg ',lambda-list
-					 ,minimum ,(unless restp maximum))
-		    `(,error-fun 'defmacro-ll-arg-count-error
+    ;; Generate code to check the number of arguments, unless dotted
+    ;; in which case length will not work.
+    (unless restp
+       (push `(unless (<= ,minimum
+			  (length (the list ,(if top-level
+						 `(cdr ,arg-list-name)
+					       arg-list-name)))
+			  ,@(unless restp
+				    (list maximum)))
+		      ,(let ((arg (if top-level
+				      `(cdr ,arg-list-name)
+				    arg-list-name)))
+			 (if (eq error-fun 'error)
+			     `(do-arg-count-error ',error-kind ',name ,arg
+						  ',lambda-list ,minimum
+						  ,(unless restp maximum))
+			   `(,error-fun 'defmacro-ll-arg-count-error
 				 :kind ',error-kind
 				 ,@(when name `(:name ',name))
 				 :argument ,arg
 				 :lambda-list ',lambda-list
 				 :minimum ,minimum
 				 ,@(unless restp `(:maximum ,maximum))))))
-	  *arg-tests*)
+	     *arg-tests*))
     (if keys
 	(let ((problem (gensym "KEY-PROBLEM-"))
 	      (info (gensym "INFO-")))
diff --git a/code/error.lisp b/code/error.lisp
index 814442b4a..2f7ac1b41 100644
--- a/code/error.lisp
+++ b/code/error.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.44 1994/10/31 04:11:27 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.45 1997/01/18 14:30:53 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -681,7 +681,7 @@
    If a string, the string is printed.
 
    Condition types are classes, but (as allowed by ANSI and not as described in
-   CLtL2) and neither STANDARD-OBJECTs nor STRUCTURE-OBJECTs.  WITH-SLOTS and
+   CLtL2) are neither STANDARD-OBJECTs nor STRUCTURE-OBJECTs.  WITH-SLOTS and
    SLOT-VALUE may not be used on condition objects."
   (let* ((parent-types (or parent-types '(condition)))
 	 (layout (find-condition-layout name parent-types))
@@ -807,7 +807,10 @@
 	  (cons (list ,@(mapcar #'(lambda (x) `(cons ',(car x) ,(cadr x)))
 				bindings))
 		*handler-clusters*)))
-     ,@forms))
+     (multiple-value-prog1
+      ,@forms
+      ;; Wait for any float exceptions
+      #+x86 (float-wait))))
 
 
 ;;;; Condition definitions.
@@ -916,7 +919,8 @@
 	     (cell-error-name condition)))))
 
 (define-condition arithmetic-error (error)
-  ((operation :reader arithmetic-error-operation :initarg :operation)
+  ((operation :reader arithmetic-error-operation :initarg :operation
+	      :initform nil)
    (operands :reader arithmetic-error-operands :initarg :operands))
   (:report (lambda (condition stream)
 	     (format stream "Arithmetic error ~S signalled."
diff --git a/code/exports.lisp b/code/exports.lisp
index 77fab2a15..5a9397ce9 100644
--- a/code/exports.lisp
+++ b/code/exports.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.107 1996/07/25 15:01:00 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.108 1997/01/18 14:30:55 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -248,7 +248,8 @@
 	     "UNIX-TCGETATTR" "C-LFLAG" "VDSUSP" "C-OFLAG" "VSTOP"
 	     "C-CFLAG" "TTY-OCRNL" "VMIN" "VEOF" "TCSAFLUSH"
 	     "TTY-IXON" "C-CC" "SIOCSPGRP" "TERMIOS" "VQUIT"
-	     "UNIX-TCSETATTR" "VINTR" "VSTART" "TIOCSIGSEND"))
+	     "UNIX-TCSETATTR" "VINTR" "VSTART" "TIOCSIGSEND"
+	     #+(or svr4 freebsd linux) "O_NDELAY"))
   
 (defpackage "FORMAT")
 (defpackage "COMMON-LISP"
@@ -1036,7 +1037,8 @@
 	   "ENTRY-NODE-INFO-NLX-TAG" "ENTRY-NODE-INFO-ST-TOP"
 	   "ENVIRONMENT-DEBUG-LIVE-TN" "ENVIRONMENT-LIVE-TN"
 	   "FASL-FILE-IMPLEMENTATIONS" "FAST-SAFE-COERCE-TO-FUNCTION"
-	   "FAST-SYMBOL-FUNCTION" "FAST-SYMBOL-VALUE" "FLUSHABLE" "FOLDABLE"
+	   "FAST-SYMBOL-FUNCTION" "FAST-SYMBOL-VALUE"
+	   "FLUSHABLE" "FOLDABLE"
 	   "FORCE-TN-TO-STACK" "FOREIGN-SYMBOL-ADDRESS" "GET-VECTOR-SUBTYPE"
 	   "HALT" "IF-EQ" "INSTANCE-REF" "INSTANCE-SET"
 	   "IR2-COMPONENT-CONSTANTS" "IR2-CONVERT"
@@ -1126,7 +1128,7 @@
 "%SET-FUNCTION-SELF"
 "IR2-COMPONENT-DYNCOUNT-INFO"
 "DYNCOUNT-INFO" "DYNCOUNT-INFO-P")
-))
+)
 (defpackage "WIRE"
             (:export "*CURRENT-WIRE*" "CONNECT-TO-REMOTE-SERVER"
              "CREATE-REQUEST-SERVER" "DESTROY-REQUEST-SERVER"
@@ -1332,17 +1334,19 @@
 	   "%ARRAY-DISPLACEMENT" "%ARRAY-FILL-POINTER"
 	   "%ARRAY-FILL-POINTER-P" "%ASIN" "%ASINH" "%ATAN" "%ATAN2" "%ATANH"
 	   "%CALLER-FRAME-AND-PC" "%CHECK-BOUND" "%CLOSURE-FUNCTION"
-	   "%CLOSURE-INDEX-REF" "%COS" "%COSH" "%DEPOSIT-FIELD"
+	   "%CLOSURE-INDEX-REF" "%COS" #+x86 "%COS-QUICK" "%COSH" "%DEPOSIT-FIELD"
 	   "%DOUBLE-FLOAT" "%DPB" "%EXP" "%FUNCTION-HEADER-ARGLIST"
 	   "%FUNCTION-HEADER-NAME" "%FUNCTION-HEADER-TYPE" "%HYPOT" "%LDB"
-	   "%LOG" "%LOG10" "%MAKE-COMPLEX"
+	   "%LOG" "%LOGB" "%LOG10" "%LOG1P" "%LOG1P-LIMITED" "%MAKE-COMPLEX"
 	   "%MAKE-FUNCALLABLE-INSTANCE" "%MAKE-RATIO" "%MASK-FIELD" "%NEGATE"
-	   "%POW" "%RAW-BITS" "%SET-FUNCALLABLE-INSTANCE-FUNCTION"
+	   "%POW" "%RAW-BITS" "%SCALB" "%SCALBN" "%SET-FUNCALLABLE-INSTANCE-FUNCTION"
 	   "%SET-FUNCALLABLE-INSTANCE-INFO" "%SET-RAW-BITS" "%SET-SAP-REF-16"
 	   "%SET-SAP-REF-32" "%SET-SAP-REF-8" "%SET-SAP-REF-DOUBLE"
 	   "%SET-SAP-REF-SAP" "%SET-SAP-REF-SINGLE" "%SET-STACK-REF" "%SIN"
+	   #+x86 "%SIN-QUICK"
 	   "%SINGLE-FLOAT" "%SINH" "%SP-SET-DEFINITION" "%SP-SET-PLIST"
 	   "%SQRT" "%SXHASH-SIMPLE-STRING" "%SXHASH-SIMPLE-SUBSTRING" "%TAN"
+	   #+x86 "%TAN-QUICK"
 	   "%TANH" "%UNARY-ROUND" "%UNARY-TRUNCATE" "%WITH-ARRAY-DATA"
 	   "*CURRENT-LEVEL*" "*EMPTY-TYPE*" "*EVAL-STACK-TOP*" "*NULL-TYPE*"
 	   "*PRETTY-PRINTER*" "*UNIVERSAL-TYPE*"
@@ -1374,7 +1378,7 @@
 	   "DATA-VECTOR-REF" "DATA-VECTOR-SET" "DECODE-DOUBLE-FLOAT"
 	   "DECODE-SINGLE-FLOAT" "DESCEND-INTO" "DIVISION-BY-ZERO-ERROR"
 	   "DOUBLE-FLOAT-EXPONENT" "DOUBLE-FLOAT-HIGH-BITS"
-	   "DOUBLE-FLOAT-LOW-BITS" "DOUBLE-FLOAT-P"
+	   "DOUBLE-FLOAT-LOW-BITS" "DOUBLE-FLOAT-P" "FLOAT-WAIT"
 	   "DYNAMIC-SPACE-FREE-POINTER" "ERROR-NUMBER-OR-LOSE" "FILENAME"
 	   "FLOAT-DIGITS" "FLOAT-EXPONENT" "FLOAT-FORMAT-DIGITS"
 	   "FLOAT-FORMAT-MAX" "FLOAT-RADIX" "FORM" "FUNCALLABLE-INSTANCE-P"
diff --git a/code/fd-stream.lisp b/code/fd-stream.lisp
index d0a48b5de..28138196d 100644
--- a/code/fd-stream.lisp
+++ b/code/fd-stream.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fd-stream.lisp,v 1.37 1996/05/07 20:47:10 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fd-stream.lisp,v 1.38 1997/01/18 14:31:02 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -980,17 +980,18 @@ non-server method is also significantly more efficient for large reads.
      (setf (fd-stream-unread stream) nil)
      (setf (fd-stream-ibuf-head stream) 0)
      (setf (fd-stream-ibuf-tail stream) 0)
-     (loop
-       (let ((count (unix:unix-select (1+ (fd-stream-fd stream))
-				      (the (unsigned-byte 32)
-					   (ash 1 (fd-stream-fd stream)))
-				      0 0 0)))
-	 (cond ((eql count 1)
-		(do-input stream)
-		(setf (fd-stream-ibuf-head stream) 0)
-		(setf (fd-stream-ibuf-tail stream) 0))
-	       (t
-		(return))))))
+     (catch 'eof-input-catcher
+       (loop
+	(let ((count (unix:unix-select (1+ (fd-stream-fd stream))
+				       (the (unsigned-byte 32)
+					    (ash 1 (fd-stream-fd stream)))
+				       0 0 0)))
+	  (cond ((eql count 1)
+		 (do-input stream)
+		 (setf (fd-stream-ibuf-head stream) 0)
+		 (setf (fd-stream-ibuf-tail stream) 0))
+		(t
+		 (return t)))))))
     (:force-output
      (flush-output-buffer stream))
     (:finish-output
diff --git a/code/filesys.lisp b/code/filesys.lisp
index 6e121ee89..032e336d2 100644
--- a/code/filesys.lisp
+++ b/code/filesys.lisp
@@ -6,7 +6,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/filesys.lisp,v 1.40 1996/07/12 19:21:58 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/filesys.lisp,v 1.41 1997/01/18 14:30:48 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -632,8 +632,14 @@
 (defun unix-namestring (pathname &optional (for-input t) executable-only)
   "Convert PATHNAME into a string that can be used with UNIX system calls.
    Search-lists and wild-cards are expanded."
+  ;; toy@rtp.ericsson.se: Let unix-namestring also handle logical
+  ;; pathnames too.
+  (let ((path (let ((lpn (pathname pathname)))
+		(if (logical-pathname-p lpn)
+		    (namestring (translate-logical-pathname lpn))
+		    pathname))))
   (enumerate-search-list
-      (pathname pathname)
+      (pathname path)
     (collect ((names))
       (enumerate-matches (name pathname nil :verify-existance for-input)
 	(when (or (not executable-only)
@@ -644,7 +650,7 @@
 	(when names
 	  (when (cdr names)
 	    (error "~S is ambiguous:~{~%  ~A~}" pathname names))
-	  (return (car names)))))))
+	  (return (car names))))))))
 
 
 ;;;; TRUENAME and PROBE-FILE.
@@ -753,7 +759,7 @@
     (unless name
       (error "~S doesn't exist." file))
     (multiple-value-bind (winp dev ino mode nlink uid)
-			 (unix:unix-stat file)
+			 (unix:unix-stat name)
       (declare (ignore dev ino mode nlink))
       (if winp (lookup-login-name uid)))))
 
diff --git a/code/float-trap.lisp b/code/float-trap.lisp
index a33bd3ff2..ce6ea5bda 100644
--- a/code/float-trap.lisp
+++ b/code/float-trap.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/float-trap.lisp,v 1.8 1994/10/31 04:11:27 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/float-trap.lisp,v 1.9 1997/01/18 14:30:52 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -152,8 +152,25 @@
 ;;;
 ;;;    Signal the appropriate condition when we get a floating-point error.
 ;;;
+
+#+FreeBSD
+(define-condition floating-point-exception (arithmetic-error)
+  ((flags :initarg :traps
+	  :reader floating-point-exception-traps))
+  (:report (lambda (condition stream)
+	     (format stream "Arithmetic error ~S signalled.~%"
+		     (type-of condition))
+	     (let ((traps (floating-point-exception-traps condition)))
+	       (if traps
+		   (format stream
+			   "Trapping conditions are: ~%~{ ~s~^~}~%"
+			   traps)
+		   (write-line
+		    "No traps are enabled? How can this be?"
+		    stream))))))
+
 (defun sigfpe-handler (signal code scp)
-  (declare (ignore signal code)
+  (declare (ignore signal code #+FreeBSD scp)
 	   (type system-area-pointer scp))
   (let* ((modes (sigcontext-floating-point-modes
 		 (alien:sap-alien scp (* unix:sigcontext))))
@@ -169,5 +186,12 @@
 	   (error 'floating-point-underflow))
 	  ((not (zerop (logand float-inexact-trap-bit traps)))
 	   (error 'ext:floating-point-inexact))
+	  #+FreeBSD
+	  ((zerop (ldb float-exceptions-byte modes))
+	   ;; I can't tell what caused the exception!!
+	   (error 'floating-point-exception
+		  :traps (getf (get-floating-point-modes) :traps)))
 	  (t
 	   (error "SIGFPE with no exceptions currently enabled?")))))
+
+
diff --git a/code/foreign.lisp b/code/foreign.lisp
index 5c552f29e..ddc08ed72 100644
--- a/code/foreign.lisp
+++ b/code/foreign.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/foreign.lisp,v 1.20 1995/02/16 22:41:02 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/foreign.lisp,v 1.21 1997/01/18 14:30:46 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -25,7 +25,13 @@
 #+hppa (defconstant foreign-segment-start #x10C00000)
 #+hppa (defconstant foreign-segment-size  #x00400000)
 
+#+(and (not linux) x86)
+ (defconstant foreign-segment-start #x7000000) ; just an unused space
+#+(and (not linux) x86) 
+ (defconstant foreign-segment-size  #x00400000)
+
 (defvar *previous-linked-object-file* nil)
+#-linux
 (defvar *foreign-segment-free-pointer* foreign-segment-start)
 
 (defun pick-temporary-file-name (&optional (base "/tmp/tmp~D~C"))
@@ -51,7 +57,7 @@
 		(t
 		 (incf code))))))))
 
-#+(and sparc (not svr4))
+#+(or FreeBSD (and sparc (not svr4)))
 (alien:def-alien-type exec
   (alien:struct nil
     (magic c-call:unsigned-long)
@@ -63,7 +69,7 @@
     (trsize c-call:unsigned-long)
     (drsize c-call:unsigned-long)))
 
-#-svr4
+#-(or linux svr4)
 (defun allocate-space-in-foreign-segment (bytes)
   (let* ((pagesize-1 (1- (get-page-size)))
 	 (memory-needed (logandc2 (+ bytes pagesize-1) pagesize-1))
@@ -75,7 +81,10 @@
     (allocate-system-memory-at addr memory-needed)
     addr))
 
-#+(and sparc (not svr4))
+;;; pw-- This seems to work for FreeBSD. The MAGIC field is not tested
+;;; for correct file format so it may croak if ld fails to produce the
+;;; expected results. It is probably good enough for now.
+#+(or FreeBSD (and sparc (not svr4)))
 (defun load-object-file (name)
   (format t ";;; Loading object file...~%")
   (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
@@ -275,7 +284,7 @@
             ))
       (unix:unix-close fd))))
 
-#-solaris
+#-(or linux solaris)
 (defun parse-symbol-table (name)
   (format t ";;; Parsing symbol table...~%")
   (let ((symbol-table (make-hash-table :test #'equal)))
@@ -286,14 +295,16 @@
 	    (return))
 	  (let* ((symbol (subseq line 11))
 		 (address (parse-integer line :end 8 :radix 16))
+		 #+FreeBSD (kind (aref line 9))	; filter out .o file names
 		 (old-address (gethash symbol lisp::*foreign-symbols*)))
-	    (unless (or (null old-address) (= address old-address))
+	    (unless (or (null old-address) (= address old-address)
+			#+FreeBSD (char= kind #\F))
 	      (warn "~S moved from #x~8,'0X to #x~8,'0X.~%"
 		    symbol old-address address))
 	    (setf (gethash symbol symbol-table) address)))))
     (setf lisp::*foreign-symbols* symbol-table)))
 
-#-solaris
+#-(or linux solaris)
 (defun load-foreign (files &key
 			   (libraries '("-lc"))
 			   (base-file
@@ -364,10 +375,13 @@
 
 (export '(alternate-get-global-address))
 
-#-solaris
-(defun alternate-get-global-address (symbol) 0)
+#-(or freebsd solaris linux)
+(defun alternate-get-global-address (symbol)
+  (declare (type simple-string symbol)
+	   (ignore symbol))
+  0)
 
-#+solaris
+#+(or linux solaris)
 (progn
 
 (defconstant rtld-lazy 1)
@@ -428,10 +442,12 @@
 		      (concatenate 'string "/tmp/~D~S" (string (gensym)))))
 	(error-output (make-string-output-stream)))
 
-    (format t ";;; Running /usr/ccs/bin/ld...~%")
+    #-linux (format t ";;; Running /usr/ccs/bin/ld...~%")
+    #+linux (format t ";;; Running /usr/bin/ld...~%")
     (force-output)
     (let ((proc (ext:run-program
-		 "/usr/ccs/bin/ld"
+		 #-linux "/usr/ccs/bin/ld"
+		 #+linux "/usr/bin/ld"
 		 (list*
 			"-G"
 			"-o"
@@ -447,10 +463,12 @@
 		 :output error-output
 		 :error :output)))
       (unless proc
-	(error "Could not run /usr/ccs/bin/ld"))
+	(error  #+linux "Could not run /usr/bin/ld"
+                #-linux "Could not run /usr/ccs/bin/ld"))
       (unless (zerop (ext:process-exit-code proc))
 	(system:serve-all-events 0)
-	(error "/usr/ccs/bin/ld failed:~%~A"
+	(error #-linux "/usr/ccs/bin/ld failed:~%~A" 
+               #+linux "/usr/bin/ld failed:~%~A"
 	       (get-output-stream-string error-output)))
       (load-object-file output-file)
       (unix:unix-unlink output-file)
diff --git a/code/format.lisp b/code/format.lisp
index c7cdee2b6..385a5814a 100644
--- a/code/format.lisp
+++ b/code/format.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/format.lisp,v 1.31 1996/05/08 14:44:25 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/format.lisp,v 1.32 1997/01/18 14:31:03 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -136,7 +136,10 @@
 		 (incf posn)
 		 (push (cons posn (get-char)) params))
 		((char= char #\,)
-		 (push (cons (1- posn) nil) params))
+		 (push (cons (1- posn) nil) params)
+		 (incf posn)
+		 (if (not (char= (get-char) #\,))
+		     (decf posn)))
 		((char= char #\:)
 		 (if colonp
 		     (error 'format-error
diff --git a/code/gc.lisp b/code/gc.lisp
index cfb019e05..5eb81c72e 100644
--- a/code/gc.lisp
+++ b/code/gc.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/gc.lisp,v 1.19 1994/10/31 04:11:27 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/gc.lisp,v 1.20 1997/01/18 14:30:34 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -42,16 +42,20 @@
 (c-var-frob dynamic-0-space-start "dynamic_0_space")
 (c-var-frob dynamic-1-space-start "dynamic_1_space")
 (c-var-frob control-stack-start "control_stack")
+#+x86 (c-var-frob control-stack-end "control_stack_end")
 (c-var-frob binding-stack-start "binding_stack")
 (c-var-frob current-dynamic-space-start "current_dynamic_space")
-
 (declaim (inline dynamic-usage))
 
+#-cgc
 (defun dynamic-usage ()
   (the (unsigned-byte 32)
        (- (system:sap-int (c::dynamic-space-free-pointer))
 	  (current-dynamic-space-start))))
 
+#+cgc
+(c-var-frob dynamic-usage "cgc_bytes_allocated")
+
 (defun static-space-usage ()
   (- (* lisp::*static-space-free-pointer* vm:word-bytes)
      (static-space-start)))
@@ -61,7 +65,8 @@
      (read-only-space-start)))
 
 (defun control-stack-usage ()
-  (- (system:sap-int (c::control-stack-pointer-sap)) (control-stack-start)))
+#-x86 (- (system:sap-int (c::control-stack-pointer-sap)) (control-stack))
+#+x86 (- (control-stack-end) (system:sap-int (c::control-stack-pointer-sap))) )
 
 (defun binding-stack-usage ()
   (- (system:sap-int (c::binding-stack-pointer-sap)) (binding-stack-start)))
@@ -93,7 +98,7 @@
   (room-minimal-info)
   (vm:memory-usage :count-spaces '(:dynamic)
 		   :print-spaces t
-		   :cutoff 0.05
+		   :cutoff 0.05s0
 		   :print-summary nil))
 
 (defun room-maximal-info ()
@@ -189,9 +194,11 @@
 
 ;;; On the RT, we store the GC trigger in a ``static'' symbol instead of
 ;;; letting magic C code handle it.  It gets initialized by the startup
-;;; code.
-#+ibmrt
-(defvar rt::*internal-gc-trigger*)
+;;; code. The X86 port defines this here because it uses the `ibmrt'
+;;; feature in the C code for allocation and binding stack access and
+;;; a lot of stuff wants this INTERNAL_GC_TRIGGER available as well.
+#+(or ibmrt x86)
+(defvar vm::*internal-gc-trigger*)
 
 ;;;
 ;;; The following specials are used to control when garbage collection
@@ -392,7 +399,8 @@
 	      (when verbose-p
 		(carefully-funcall *gc-notify-after*
 				   post-gc-dyn-usage bytes-freed
-				   *gc-trigger*))))))
+				   *gc-trigger*))))
+	  (scrub-control-stack)))
       (incf *gc-run-time* (- (get-internal-run-time) start-time))))
   nil)
 
diff --git a/code/internet.lisp b/code/internet.lisp
index ed6c57085..cbc89f861 100644
--- a/code/internet.lisp
+++ b/code/internet.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/internet.lisp,v 1.17 1994/10/31 04:11:27 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/internet.lisp,v 1.18 1997/01/18 14:30:52 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -40,13 +40,32 @@
 (defconstant sock-raw 3)
 #+svr4
 (defconstant sock-raw 4)
+#+linux
+(defconstant sock-rdm 4)
+#+linux
+(defconstant sock-seqpacket 5)
+#+linux
+(defconstant sock-packet 10)
 
 (defconstant af-unix 1)
 (defconstant af-inet 2)
-
+#+linux
+(progn
+ (defconstant af-ax25 3)
+ (defconstant af-ipx 4)
+ (defconstant af-appletalk 5)
+ (defconstant af-netrom 6)
+ (defconstant af-bridge 7)
+ (defconstant af-aal5 9)
+ (defconstant af-x25 9)
+ (defconstant af-inet6 10)
+ (defconstant af-max 12))
+ 
 (defconstant msg-oob 1)
 (defconstant msg-peek 2)
 (defconstant msg-dontroute 4)
+#+linux
+(defconstant msg-proxy 16)
 
 (defvar *internet-protocols*
   (list (list :stream 6 sock-stream)
@@ -96,11 +115,51 @@
   (declare (type host-entry host))
   (car (host-entry-addr-list host)))
 
+#-FreeBSD
 (def-alien-type unix-sockaddr
   (struct nil
-    (family #-alpha short #+alpha unsigned-short)
+    (family #-(or linux alpha) short #+(or linux alpha)  unsigned-short)
     (path (array char 108))))
-
+#|
+struct  sockaddr_un {
+        u_char  sun_len;                /* sockaddr len including null */
+        u_char  sun_family;             /* AF_UNIX */
+        char    sun_path[104];          /* path name (gag) */
+};
+|#
+
+#+FreeBSD
+(def-alien-type unix-sockaddr
+    (struct nil
+      (sun-len unsigned-char)
+      (family unsigned-char)
+      (path (array char 104))))
+#|
+/*
+ * Socket address, internet style.
+ */
+struct sockaddr_in {
+        u_char  sin_len;
+        u_char  sin_family;
+        u_short sin_port;
+        struct  in_addr sin_addr;
+        char    sin_zero[8];
+};
+struct in_addr {
+        u_long s_addr;
+};
+
+|#
+#+FreeBSD
+(def-alien-type inet-sockaddr
+    (struct nil
+      (sin-len unsigned-char)
+      (family  unsigned-char)
+      (port    unsigned-short)
+      (addr    unsigned-long)
+      (zero    (array char 8))))
+
+#-FreeBSD
 (def-alien-type inet-sockaddr
   (struct nil
     (family #-alpha short #+alpha unsigned-short)
@@ -108,6 +167,7 @@
     (addr #-alpha unsigned-long #+alpha unsigned-int)
     (zero (array char 8))))
 
+
 (def-alien-type hostent
   (struct nil
     (name c-string)
@@ -158,8 +218,11 @@
 				    index))
 		      (results))
 		     (t
-		      (results (deref (deref (slot hostent 'addr-list) index)))
-		      (repeat (1+ index)))))))))))
+		      (results 
+#-linux (deref (deref (slot hostent 'addr-list) index))
+#+linux (ntohl (deref (deref (slot hostent 'addr-list) index)))
+                      )
+		      (repeat (1+ index))))))))))) 
 
 (defun create-unix-socket (&optional (kind :stream))
   (multiple-value-bind (proto type)
@@ -203,7 +266,9 @@
     (with-alien ((sockaddr inet-sockaddr))
       (setf (slot sockaddr 'family) af-inet)
       (setf (slot sockaddr 'port) (htons port))
-      (setf (slot sockaddr 'addr) (host-entry-addr hostent))
+      (setf (slot sockaddr 'addr) 
+         #-linux (host-entry-addr hostent)
+         #+linux (htonl (host-entry-addr hostent)))
       (when (minusp (unix:unix-connect socket
 				       (alien-sap sockaddr)
 				       (alien-size inet-sockaddr :bytes)))
@@ -241,7 +306,8 @@
 				       (alien-size inet-sockaddr :bytes))))
       (when (minusp connected)
 	(error "Error accepting a connection: ~A" (unix:get-unix-error-msg)))
-      (values connected (slot sockaddr 'addr)))))
+      (values connected #-linux (slot sockaddr 'addr)
+		        #+linux (ntohl (slot sockaddr 'addr))))))
 
 (defun close-socket (socket)
   (multiple-value-bind (ok err)
diff --git a/code/irrat.lisp b/code/irrat.lisp
index 7679b3b95..4dbada9bf 100644
--- a/code/irrat.lisp
+++ b/code/irrat.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/irrat.lisp,v 1.16 1996/07/08 19:17:28 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/irrat.lisp,v 1.17 1997/01/18 14:30:40 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -56,13 +56,13 @@
 ;;; Please refer to the Unix man pages for details about these routines.
 
 ;;; Trigonometric.
-(def-math-rtn "sin" 1)
-(def-math-rtn "cos" 1)
-(def-math-rtn "tan" 1)
+#-x86 (def-math-rtn "sin" 1)
+#-x86 (def-math-rtn "cos" 1)
+#-x86 (def-math-rtn "tan" 1)
 (def-math-rtn "asin" 1)
 (def-math-rtn "acos" 1)
-(def-math-rtn "atan" 1)
-(def-math-rtn "atan2" 2)
+#-x86 (def-math-rtn "atan" 1)
+#-x86 (def-math-rtn "atan2" 2)
 (def-math-rtn "sinh" 1)
 (def-math-rtn "cosh" 1)
 (def-math-rtn "tanh" 1)
@@ -71,12 +71,85 @@
 #-hpux (def-math-rtn "atanh" 1)
 
 ;;; Exponential and Logarithmic.
-(def-math-rtn "exp" 1)
-(def-math-rtn "log" 1)
-(def-math-rtn "log10" 1)
+#-x86(def-math-rtn "exp" 1)
+#-x86(def-math-rtn "log" 1)
+#-x86(def-math-rtn "log10" 1)
 (def-math-rtn "pow" 2)
-(def-math-rtn "sqrt" 1)
+#-x86 (def-math-rtn "sqrt" 1)
 (def-math-rtn "hypot" 2)
+(def-math-rtn "log1p" 1)
+
+#+x86 ;; These are needed for use by byte-compiled files.
+(progn
+  (defun %sin (x)
+    (declare (type double-float x)
+	     (values double-float))
+    (%sin x))
+  (defun %sin-quick (x)
+    (declare (double-float x)
+	     (values double-float))
+    (%sin-quick x))
+  (defun %cos (x)
+    (declare (type double-float x)
+	     (values double-float))
+    (%cos x))
+  (defun %cos-quick (x)
+    (declare (double-float x)
+	     (values double-float))
+    (%cos-quick x))
+  (defun %tan (x)
+    (declare (double-float x)
+	     (values double-float))
+    (%tan x))
+  (defun %tan-quick (x)
+    (declare (double-float x)
+	     (values double-float))
+    (%tan-quick x))
+  (defun %atan (x)
+    (declare (double-float x)
+	     (values double-float))
+    (%atan x))
+  (defun %atan2 (x y)
+    (declare (double-float x y)
+	     (values double-float))
+    (%atan2 x y))
+  (defun %exp (x)
+    (declare (type double-float x)
+	     (values double-float))
+    (%exp x))
+  (defun %log (x)
+    (declare (type double-float x)
+	     (values double-float))
+    (%log x))
+  (defun %log10 (x)
+    (declare (type double-float x)
+	     (values double-float))
+    (%log10 x))
+
+  #+nil ;; notyet
+  (defun %pow (x y)
+    (declare (type (double-float 0d0) x)
+	     (type double-float y)
+	     (values (double-float 0d0)))
+    (%pow x y))
+  (defun %sqrt (x)
+    (declare (type double-float x)
+	     (values double-float))
+    (%sqrt x))
+  (defun %scalbn (f ex)
+    (declare (type double-float f)
+	     (type (signed-byte 32) ex)
+	     (values double-float))
+    (%scalbn f ex))
+  (defun %scalb (f ex)
+    (declare (double-float f ex)
+	     (values double-float))
+    (%scalb f ex))
+  (defun %logb (x)
+     (declare (double-float x)
+ 	     (values double-float))
+     (%logb x))
+  ) ; progn
 
 
 ;;;; Power functions.
@@ -161,10 +234,8 @@
 	      (cis (* power (phase base)))))
 	  (((foreach fixnum (or bignum ratio) single-float double-float)
 	    complex)
-	   (if (minusp base)
-	       (/ (exp (* power (truly-the float (log (- base))))))
-	       (exp (* power (truly-the float (log base))))))
-	  (((foreach (complex float) (complex rational)) complex)
+	   (exp (* power (log base))))
+	  (((foreach (complex float) (complex rational)) number)
 	   (exp (* power (log base))))))))
 
 (defun log (number &optional (base nil base-p))
@@ -172,28 +243,45 @@
   (if base-p
       (/ (log number) (log base))
       (number-dispatch ((number number))
-	(((foreach fixnum bignum ratio single-float))
+	(((foreach fixnum bignum ratio))
 	 (if (minusp number)
 	     (complex (log (- number)) (coerce pi 'single-float))
 	     (coerce (%log (coerce number 'double-float)) 'single-float)))
-	((double-float)
-	 (if (minusp number)
-	     (complex (log (- number)) (coerce pi 'double-float))
-	     (%log number)))
-	((complex) (complex (log (abs number)) (phase number))))))
+	(((foreach single-float double-float))
+	 ;; Is (log -0) -infinity (libm.a) or -infinity + i*pi (Kahan)?
+	 ;; Since this doesn't seem to be an implementation issue
+	 ;; I (pw) take the Kahan result.
+	 (if (< (float-sign number)
+		(coerce 0 '(dispatch-type number)))
+	     (complex (log (- number)) (coerce pi '(dispatch-type number)))
+	     (coerce (%log (coerce number 'double-float))
+		     '(dispatch-type number))))
+	((complex)
+	 (complex-log number)))))
 
 (defun sqrt (number)
   "Return the square root of NUMBER."
   (number-dispatch ((number number))
-    (((foreach fixnum bignum ratio single-float))
+    (((foreach fixnum bignum ratio))
      (if (minusp number)
-	 (exp (/ (log number) 2))
+	 (complex-sqrt number)
 	 (coerce (%sqrt (coerce number 'double-float)) 'single-float)))
-    ((double-float)
-     (if (minusp number)
-	 (exp (/ (log number) 2))
-	 (%sqrt number)))
-    ((complex) (exp (/ (log number) 2)))))
+    (((foreach single-float double-float))
+     ;; NOTE there is a problem with (at least x86 NPX) of what result
+     ;; should be returned for (sqrt -0.0). The x86 hardware FSQRT
+     ;; instruction returns -0d0. The result is that Python will perhaps
+     ;; note the following test in generic sqrt, non-negatively constrained
+     ;; float types will be passed to FSQRT (or libm on other boxes).
+     ;; So, in the interest of consistency of compiled and interpreted
+     ;; codes, the following test is disabled for now. Maybe the float-sign
+     ;; test could be moved to the optimization codes.
+     (if (< (#+nil float-sign #-nil identity number)
+	    (coerce 0 '(dispatch-type number)))
+	 (complex-sqrt number)
+	 (coerce (%sqrt (coerce number 'double-float))
+		 '(dispatch-type number))))
+     ((complex)
+      (complex-sqrt number))))
 
 
 ;;;; Trigonometic and Related Functions
@@ -222,12 +310,16 @@
   For non-complex positive numbers, this is 0.  For non-complex negative
   numbers this is PI."
   (etypecase number
-    ((or rational single-float)
+    (rational
      (if (minusp number)
 	 (coerce pi 'single-float)
 	 0.0f0))
+    (single-float
+     (if (minusp (float-sign number))
+	 (coerce pi 'single-float)
+	 0.0f0))
     (double-float
-     (if (minusp number)
+     (if (minusp (float-sign number))
 	 (coerce pi 'double-float)
 	 0.0d0))
     (complex
@@ -241,7 +333,8 @@
     ((complex)
      (let ((x (realpart number))
 	   (y (imagpart number)))
-       (complex (* (sin x) (cosh y)) (* (cos x) (sinh y)))))))
+       (complex (* (sin x) (cosh y))
+		(* (cos x) (sinh y)))))))
 
 (defun cos (number)
   "Return the cosine of NUMBER."
@@ -250,17 +343,15 @@
     ((complex)
      (let ((x (realpart number))
 	   (y (imagpart number)))
-       (complex (* (cos x) (cosh y)) (- (* (sin x) (sinh y))))))))
+       (complex (* (cos x) (cosh y))
+		(- (* (sin x) (sinh y))))))))
 
 (defun tan (number)
   "Return the tangent of NUMBER."
   (number-dispatch ((number number))
     (handle-reals %tan number)
     ((complex)
-     (let* ((num (sin number))
-	    (denom (cos number)))
-       (if (zerop denom) (error "~S undefined tangent." number)
-	   (/ num denom))))))
+     (complex-tan number))))
 
 (defun cis (theta)
   "Return cos(Theta) + i sin(Theta), AKA exp(i Theta)."
@@ -268,14 +359,6 @@
       (error "Argument to CIS is complex: ~S" theta)
       (complex (cos theta) (sin theta))))
 
-(proclaim '(inline mult-by-i))
-(defun mult-by-i (number)
-  (complex (imagpart number)
-	   (- (realpart number))))
-
-(defun complex-asin (number)
-  (- (mult-by-i (log (+ (mult-by-i number) (sqrt (- 1 (* number number))))))))
-
 (defun asin (number)
   "Return the arc sine of NUMBER."
   (number-dispatch ((number number))
@@ -292,9 +375,6 @@
     ((complex)
      (complex-asin number))))
 
-(defun complex-acos (number)
-  (- (mult-by-i (log (+ number (mult-by-i (sqrt (- (* number number)))))))))
-
 (defun acos (number)
   "Return the arc cosine of NUMBER."
   (number-dispatch ((number number))
@@ -339,61 +419,616 @@
       (number-dispatch ((y number))
 	(handle-reals %atan y)
 	((complex)
-	 (let ((im (imagpart y))
-	       (re (realpart y)))
-	   (/ (- (log (complex (- 1 im) re))
-		 (log (complex (+ 1 im) (- re))))
-	      (complex 0 2)))))))
+	 (complex-atan y)))))
 
+;; It seems that everyone has a C version of sinh, cosh, and
+;; tanh. Let's use these for reals because the original
+;; implementations based on the definitions lose big in round-off
+;; error.  These bad definitions also mean that sin and cos for
+;; complex numbers can also lose big.
 
+#+nil
 (defun sinh (number)
   "Return the hyperbolic sine of NUMBER."
   (/ (- (exp number) (exp (- number))) 2))
 
+(defun sinh (number)
+  "Return the hyperbolic sine of NUMBER."
+  (number-dispatch ((number number))
+    (handle-reals %sinh number)
+    ((complex)
+     (let ((x (realpart number))
+	   (y (imagpart number)))
+       (complex (* (sinh x) (cos y))
+		(* (cosh x) (sin y)))))))
+
+#+nil
 (defun cosh (number)
   "Return the hyperbolic cosine of NUMBER."
   (/ (+ (exp number) (exp (- number))) 2))
 
+(defun cosh (number)
+  "Return the hyperbolic cosine of NUMBER."
+  (number-dispatch ((number number))
+    (handle-reals %cosh number)
+    ((complex)
+     (let ((x (realpart number))
+	   (y (imagpart number)))
+       (complex (* (cosh x) (cos y))
+		(* (sinh x) (sin y)))))))
+
 (defun tanh (number)
   "Return the hyperbolic tangent of NUMBER."
-  (/ (- (exp number) (exp (- number)))
-     (+ (exp number) (exp (- number)))))
-
+  (number-dispatch ((number number))
+    (handle-reals %tanh number)
+    ((complex)
+     (complex-tanh number))))
 
 (defun asinh (number)
   "Return the hyperbolic arc sine of NUMBER."
-  (log (+ number (sqrt (1+ (* number number))))))
+  (number-dispatch ((number number))
+    (handle-reals %asinh number)
+    ((complex)
+     (complex-asinh number))))
 
 (defun acosh (number)
   "Return the hyperbolic arc cosine of NUMBER."
-  (* 2 (log (+ (sqrt (/ (1+ number) 2)) (sqrt (/ (1- number) 2))))))
+  (number-dispatch ((number number))
+    ((rational)
+     ;; acosh is complex if number < 1
+     (if (< number 1)
+	 (complex-acosh number)
+	 (coerce (%acosh (coerce number 'double-float)) 'single-float)))
+    (((foreach single-float double-float))
+     (if (< number (coerce 1 '(dispatch-type number)))
+	 (complex-acosh number)
+	 (coerce (%acosh (coerce number 'double-float))
+		 '(dispatch-type number))))
+    ((complex)
+     (complex-acosh number))))
 
 (defun atanh (number)
   "Return the hyperbolic arc tangent of NUMBER."
-  (/ (- (log (1+ number)) (log (- 1 number))) 2))
-
+  (number-dispatch ((number number))
+    ((rational)
+     ;; atanh is complex if |number| > 1
+     (if (or (> number 1) (< number -1))
+	 (complex-atanh number)
+	 (coerce (%atanh (coerce number 'double-float)) 'single-float)))
+    (((foreach single-float double-float))
+     (if (or (> number (coerce 1 '(dispatch-type number)))
+	     (< number (coerce -1 '(dispatch-type number))))
+	 (complex-atanh number)
+	 (coerce (%atanh (coerce number 'double-float))
+		 '(dispatch-type number))))
+    ((complex)
+     (complex-atanh number))))
 
 ;;; HP-UX does not supply C versions of asinh, acosh, and atanh, so just
-;;; use the same equations as above, but force double-float arith.
+;;; use the definitions.
 
 #+hpux
 (defun %asinh (number)
   (declare (type double-float number)
 	   (values double-float)
 	   (optimize (speed 3) (safety 0) (inhibit-warnings 3)))
-  (log (+ number (the double-float (sqrt (1+ (* number number)))))))
+  (log (+ number (sqrt (+ 1.0d0 (* number number))))))
 
 #+hpux
 (defun %acosh (number)
-  (declare (type double-float number)
+  (declare (type (double-float 1.0d0) number)
 	   (values double-float)
 	   (optimize (speed 3) (safety 0) (inhibit-warnings 3)))
-  (* 2 (log (+ (the double-float (sqrt (/ (1+ number) 2)))
-	       (the double-float (sqrt (/ (1- number) 2)))))))
+  (log (+ number (* (sqrt (- number 1.0d0))
+		    (sqrt (+ number 1.0d0))))))
 
 #+hpux
 (defun %atanh (number)
-  (declare (type double-float number)
+  (declare (type (double-float -1.0d0 1.0d0) number)
 	   (values double-float)
 	   (optimize (speed 3) (safety 0) (inhibit-warnings 3)))
+  (* 0.5d0 (- (log (+ 1.0d0 number))
+	      (log (- 1.0d0 number)))))
+
+
+
+#+old-elfun
+(progn
+;;; Here are the old definitions of the special functions, for
+;;; complex-valued arguments.  Some of these functions suffer from
+;;; severe round-off error or unnecessary overflow.
+  
+(proclaim '(inline mult-by-i))
+(defun mult-by-i (number)
+  (complex (- (imagpart number))
+	   (realpart number)))
+
+(defun complex-sqrt (x)
+  (exp (/ (log x) 2)))
+
+(defun complex-log (x)
+  (complex (log (abs x))
+	   (phase x)))
+
+(defun complex-atanh (number)
   (/ (- (log (1+ number)) (log (- 1 number))) 2))
+
+(defun complex-tanh (number)
+  (/ (- (exp number) (exp (- number)))
+     (+ (exp number) (exp (- number)))))
+
+(defun complex-acos (number)
+  (* -2 (mult-by-i (log (+ (sqrt (/ (1+ number) 2))
+			   (mult-by-i (sqrt (/ (- 1 number) 2))))))))
+
+(defun complex-acosh (number)
+  (* 2 (log (+ (sqrt (/ (1+ number) 2)) (sqrt (/ (1- number) 2))))))
+
+(defun complex-asin (number)
+  (- (mult-by-i (log (+ (mult-by-i number) (sqrt (- 1 (* number number))))))))
+
+(defun complex-asinh (number)
+  (log (+ number (sqrt (1+ (* number number))))))
+
+(defun complex-atan (y)
+  (let ((im (imagpart y))
+	(re (realpart y)))
+    (/ (- (log (complex (- 1 im) re))
+	  (log (complex (+ 1 im) (- re))))
+       (complex 0 2))))
+
+(defun complex-tan (number)
+  (let* ((num (sin number))
+	 (denom (cos number)))
+    (if (zerop denom) (error "~S undefined tangent." number)
+	(/ num denom))))
+)
+
+#-old-specfun
+(progn
+;;;;
+;;;; This is a set of routines that implement many elementary
+;;;; transcendental functions as specified by ANSI Common Lisp.  The
+;;;; implementation is based on Kahan's paper.
+;;;;
+;;;; I believe I have accurately implemented the routines and are
+;;;; correct, but you may want to check for your self.
+;;;;
+;;;; These functions are written for CMU Lisp and take advantage of
+;;;; some of the features available there.  It may be possible,
+;;;; however, to port this to other Lisps.
+;;;;
+;;;; Some functions are significantly more accurate than the original
+;;;; definitions in CMU Lisp.  In fact, some functions in CMU Lisp
+;;;; give the wrong answer like (acos #c(-2.0 0.0)), where the true
+;;;; answer is pi + i*log(2-sqrt(3)).
+;;;;
+;;;; All of the implemented functions will take any number for an
+;;;; input, but the result will always be a either a complex
+;;;; single-float or a complex double-float.
+;;;;
+;;;; General functions
+;;;;   complex-sqrt
+;;;;   complex-log
+;;;;   complex-atanh
+;;;;   complex-tanh
+;;;;   complex-acos
+;;;;   complex-acosh
+;;;;   complex-asin
+;;;;   complex-asinh
+;;;;   complex-atan
+;;;;   complex-tan
+;;;;
+;;;; Utility functions:
+;;;;   scalb logb
+;;;;
+;;;; Internal functions:
+;;;;    square coerce-to-complex-type cssqs complex-log-scaled
+;;;;    suppress-divide-by-zero
+;;;;
+;;;;
+;;;; Please send any bug reports, comments, or improvements to Raymond
+;;;; Toy at toy@rtp.ericsson.se.
+;;;;
+;;;; References
+;;;;
+;;;; Kahan, W. "Branch Cuts for Complex Elementary Functions, or Much
+;;;; Ado About Nothing's Sign Bit" in Iserles and Powell (eds.) "The
+;;;; State of the Art in Numerical Analysis", pp. 165-211, Clarendon
+;;;; Press, 1987
+;;;;
+(declaim (inline square))
+(declaim (ftype (function (double-float) (double-float 0d0)) square))
+(defun square (x)
+  (declare (double-float x)
+	   (values (double-float 0d0)))
+  (* x x))
+
+;; If you have these functions in libm, perhaps they should be used
+;; instead of these Lisp versions.  These versions are probably good
+;; enough, especially since they are portable.
+
+(defun scalb (x n)
+  "Compute 2^N * X without compute 2^N first (use properties of the
+underlying floating-point format"
+  (declare (type double-float x)
+	   (integer n))
+  (scale-float x n))
+
+(defun logb (x)
+  "Compute an integer N such that 1 <= |2^N * x| < 2.
+For the special cases, the following values are used:
+
+    x             logb
+   NaN            NaN
+   +/- infinity   +infinity
+   0              -infinity
+"
+  (declare (type double-float x))
+  (cond ((float-trapping-nan-p x)
+	 x)
+	((float-infinity-p x)
+	 #.ext:double-float-positive-infinity)
+	((zerop x)
+	 ;; The answer is negative infinity, but we are supposed to
+	 ;; signal divide-by-zero.
+	 ;; (error 'division-by-zero :operation 'logb :operands (list x))
+	 (/ -1.0d0 x)
+	 )
+	(t
+	 (multiple-value-bind (signif expon sign)
+	     (decode-float x)
+	   (declare (ignore signif sign))
+	   ;; decode-float is almost right, except that the exponent
+	   ;; is off by one
+	   (1- expon)))))
+
+;; This function is used to create a complex number of the appropriate
+;; type.
+
+(declaim (inline coerce-to-complex-type))
+(defun coerce-to-complex-type (x y z)
+  "Create complex number with real part X and imaginary part Y such that
+it has the same type as Z.  If Z has type (complex rational), the X
+and Y are coerced to single-float."
+  (declare (double-float x y)
+	   (number z))
+  (if (subtypep (type-of (realpart z)) 'double-float)
+      (complex x y)
+      ;; Convert anything that's not a double-float to a single-float.
+      (complex (float x 1.0)
+	       (float y 1.0))))
+
+(defun cssqs (z)
+  ;; Compute |x+i*y|^2/2^k carefully.  The result is r + i*k, where k
+  ;; is an integer.
+  
+  ;; Save all FP flags
+  (let* ((fp-modes (get-floating-point-modes))
+	 (x (float (realpart z) 1d0))
+	 (y (float (imagpart z) 1d0))
+	 (k 0)
+	 (rho 0d0)
+	 )
+    (declare (double-float x y)
+	     (type (double-float 0d0) rho)
+	     (fixnum k))
+    (unwind-protect
+	 (progn
+	   ;; Would this be better handled using an exception handler
+	   ;; to catch the overflow or underflow signal?  For now, we
+	   ;; turn all traps off and look at the accrued exceptions to
+	   ;; see if any signal would have been raised.
+
+	   (set-floating-point-modes :traps nil :accrued-exceptions nil)
+
+	   (setf rho (+ (square x) (square y)))
+	   (cond ((and (or (float-trapping-nan-p rho)
+			   (float-infinity-p rho))
+		       (or (float-infinity-p (abs x))
+			   (float-infinity-p (abs y))))
+		  (setf rho #.ext:double-float-positive-infinity))
+		 ((let* ((exceptions (getf (get-floating-point-modes)
+					   :accrued-exceptions))
+			 (threshold #.(/ least-positive-double-float
+					 double-float-epsilon)))
+		    ;; overflow raised or (underflow raised and rho <
+		    ;; lambda/eps)
+		    (or (member :overflow exceptions)
+			(and (member :underflow exceptions)
+			     (< rho threshold))))
+		  (setf k (logb (max (abs x) (abs y))))
+		  (setf rho (+ (square (scalb x (- k)))
+			       (square (scalb y (- k)))))))
+	   (values rho k))
+      ;; restore over/underflow flags
+      (apply #'set-floating-point-modes fp-modes))))
+
+(defun complex-sqrt (z)
+  "Principle square root of Z
+
+Z may be any number, but the result is always a complex."
+  (declare (number z))
+  (multiple-value-bind (rho k)
+      (cssqs z)
+    (declare (type (double-float 0d0) rho)
+	     (fixnum k))
+    (let ((x (float (realpart z) 1.0d0))
+	  (y (float (imagpart z) 1.0d0))
+	  (eta 0d0)
+	  (nu 0d0))
+      (declare (double-float x y eta nu))
+
+      (if (not (float-trapping-nan-p x))
+	  (setf rho (+ (scalb (abs x) (- k)) (sqrt rho))))
+
+      (cond ((oddp k)
+	     (setf k (ash k -1)))
+	    (t
+	     (setf k (1- (ash k -1)))
+	     (setf rho (+ rho rho))))
+
+      (setf rho (scalb (sqrt rho) k))
+
+      (setf eta rho)
+      (setf nu y)
+
+      (when (/= rho 0d0)
+	    (when (not (float-infinity-p (abs nu)))
+		  (setf nu (/ (/ nu rho) 2d0)))
+	    (when (< x 0d0)
+		  (setf eta (abs nu))
+		  (setf nu (float-sign y rho))))
+      (coerce-to-complex-type eta nu z))))
+    
+(defun complex-log-scaled (z j)
+  "Compute log(2^j*z).
+
+This is for use with J /= 0 only when |z| is huge."
+  (declare (number z)
+	   (fixnum j))
+  ;; The constants t0, t1, t2 should be evaluated to machine
+  ;; precision.  In addition, Kahan says the accuracy of log1p
+  ;; influences the choices of these constants but doesn't say how to
+  ;; choose them.  We'll just assume his choices matches our
+  ;; implementation of log1p.
+  (let ((t0 #.(/ 1 (sqrt 2.0d0)))
+	(t1 1.2d0)
+	(t2 3d0)
+	(ln2 #.(log 2d0))
+	(x (float (realpart z) 1.0d0))
+	(y (float (imagpart z) 1.0d0)))
+    (multiple-value-bind (rho k)
+	(cssqs z)
+      (declare (type (double-float 0d0) rho)
+	       (fixnum k))
+      (let ((beta (max (abs x) (abs y)))
+	    (theta (min (abs x) (abs y))))
+	(declare (type (double-float 0d0) beta theta))
+	(if (and (zerop k)
+		 (< t0 beta)
+		 (or (<= beta t1)
+		     (< rho t2)))
+	    (setf rho (/ (%log1p (+ (* (- beta 1.0d0)
+				       (+ beta 1.0d0))
+				    (* theta theta)))
+			 2d0))
+	    (setf rho (+ (/ (log rho) 2d0)
+			 (* (+ k j) ln2))))
+	(setf theta (atan y x))
+	(coerce-to-complex-type rho theta z)))))
+
+(defun complex-log (z)
+  "Log of Z = log |Z| + i * arg Z
+
+Z may be any number, but the result is always a complex."
+  (declare (number z))
+  (complex-log-scaled z 0))
+	       
+;; Let us note the following "strange" behavior.  atanh 1.0d0 is
+;; +infinity, but the following code returns approx 176 + i*pi/4. The
+;; reason for the imaginary part is caused by the fact that arg i*y is
+;; never 0 since we have positive and negative zeroes.
+
+(defun complex-atanh (z)
+  "Compute atanh z = (log(1+z) - log(1-z))/2"
+  (declare (number z))
+  (let* (;; Constants
+	 (theta #.(/ (sqrt most-positive-double-float) 4.0d0))
+	 (rho #.(/ 4.0d0 (sqrt most-positive-double-float)))
+	 (half-pi #.(/ pi 2.0d0))
+	 (rp (float (realpart z) 1.0d0))
+	 (beta (float-sign rp 1.0d0))
+	 (x (* beta rp))
+	 (y (* beta (- (float (imagpart z) 1.0d0))))
+	 (eta 0.0d0)
+	 (nu 0.0d0))
+    (declare (double-float theta rho half-pi rp beta y eta nu)
+	     (type (double-float 0d0) x))
+    (cond ((or (> x theta)
+	       (> (abs y) theta))
+	   ;; To avoid overflow...
+	   (setf eta (float-sign y half-pi))
+	   ;; nu is real part of 1/(x + iy).  This is x/(x^2+y^2),
+	   ;; which can cause overflow.  Arrange this computation so
+	   ;; that it won't overflow.
+	   (setf nu (let* ((x-bigger (> x (abs y)))
+			   (r (if x-bigger (/ y x) (/ x y)))
+			   (d (+ 1.0d0 (* r r))))
+		      (declare (double-float r d))
+		      (if x-bigger
+			  (/ (/ x) d)
+			  (/ (/ r y) d)))))
+	  ((= x 1.0d0)
+	   ;; Should this be changed so that if y is zero, eta is set
+	   ;; to +infinity instead of approx 176?  In any case
+	   ;; tanh(176) is 1.0d0 within working precision.
+	   (let ((t1 (+ 4d0 (square y)))
+		 (t2 (+ (abs y) rho)))
+	     (declare (type (double-float 0d0) t1 t2))
+	     #+nil
+	     (setf eta (log (/ (sqrt (sqrt t1)))
+			    (sqrt t2)))
+	     (setf eta (* 0.5d0 (log (the (double-float 0.0d0)
+					  (/ (sqrt t1) t2)))))
+	     (setf nu (* 0.5d0
+			 (float-sign y
+				     (+ half-pi (atan (* 0.5d0 t2))))))))
+	  (t
+	   (let ((t1 (+ (abs y) rho)))
+	     (declare (double-float t1))
+	     ;; Normal case using log1p(x) = log(1 + x)
+	     (setf eta (* 0.25d0
+			  (%log1p (/ (* 4.0d0 x)
+				     (+ (square (- 1.0d0 x))
+					(square t1))))))
+	     (setf nu (* 0.5d0
+			 (atan (* 2.0d0 y)
+			       (- (* (- 1.0d0 x)
+				     (+ 1.0d0 x))
+				  (square t1))))))))
+    (coerce-to-complex-type (* beta eta)
+			    (- (* beta nu))
+			    z)))
+
+(defun complex-tanh (z)
+  "Compute tanh z = sinh z / cosh z"
+  (declare (number z))
+  (let ((x (float (realpart z) 1.0d0))
+	(y (float (imagpart z) 1.0d0)))
+    (declare (double-float x y))
+    (cond ((> (abs x)
+	      #-linux #.(/ (%asinh most-positive-double-float) 4d0)
+	      ;; This is more accurate under linux.
+	      #+linux #.(/ (+ (%log 2.0d0)
+			      (%log most-positive-double-float)) 4d0))
+	   (complex (float-sign x)
+		    (float-sign y 0.0d0)))
+	  (t
+	   (let* ((tv (tan y))
+		  (beta (+ 1.0d0 (* tv tv)))
+		  (s (sinh x))
+		  (rho (sqrt (+ 1.0d0 (* s s)))))
+	     (declare (double-float tv s)
+		      (type (double-float 0.0d0) beta rho))
+	     (if (float-infinity-p (abs tv))
+		 (coerce-to-complex-type (/ rho s)
+					 (/ tv)
+					 z)
+		 (let ((den (+ 1.0d0 (* beta s s))))
+		   (coerce-to-complex-type (/ (* beta rho s)
+					      den)
+					   (/ tv den)
+					   z))))))))
+
+;; Kahan says we should only compute the parts needed.  Thus, the
+;; realpart's below should only compute the real part, not the whole
+;; complex expression.  Doing this can be important because we may get
+;; spurious signals that occur in the part that we are not using.
+;;
+;; However, we take a pragmatic approach and just use the whole
+;; expression.
+
+;; This macro suppresses any divide-by-zero errors in the body.  After
+;; execution of the body, the floating point modes are returned as
+;; they were before entry.
+
+(defmacro suppress-divide-by-zero (&body body)
+  (let ((fp-modes (gensym)))
+    `(let ((,fp-modes (get-floating-point-modes)))
+      (unwind-protect
+	   (progn
+	     ;; Remove the divide-by-zero trap but leave everything
+	     ;; else undisturbed.
+	     (set-floating-point-modes
+	      :traps (remove :divide-by-zero (getf ,fp-modes :traps)))
+	     ,@body)
+	(apply #'set-floating-point-modes ,fp-modes)))))
+
+;; NOTE: The formula given by Kahan is somewhat ambiguous in whether
+;; it's the conjugate of the square root or the square root of the
+;; conjugate.  This needs to be checked.
+
+;; I checked.  It doesn't matter because (conjugate (sqrt z)) is the
+;; same as (sqrt (conjugate z)) for all z.  This follows because
+;;
+;; (conjugate (sqrt z)) = exp(0.5*log |z|)*exp(-0.5*j*arg z).
+;;
+;; (sqrt (conjugate z)) = exp(0.5*log|z|)*exp(0.5*j*arg conj z)
+;;
+;;.and these two expressions are equal if and only if arg conj z =
+;;-arg z, which is clearly true for all z.
+
+(defun complex-acos (z)
+  "Compute acos z = pi/2 - asin z
+
+Z may be any number, but the result is always a complex."
+  (declare (number z))
+  (let ((sqrt-1+z (complex-sqrt (+ 1 z)))
+	(sqrt-1-z (complex-sqrt (- 1 z))))
+    (suppress-divide-by-zero
+     (complex (* 2 (atan (/ (realpart sqrt-1-z)
+			    (realpart sqrt-1+z))))
+	      (asinh (imagpart (* (conjugate sqrt-1+z)
+				  sqrt-1-z)))))))
+
+(defun complex-acosh (z)
+  "Compute acosh z = 2 * log(sqrt((z+1)/2) + sqrt((z-1)/2))
+
+Z may be any number, but the result is always a complex."
+  (declare (number z))
+  (let ((sqrt-z-1 (complex-sqrt (- z 1)))
+	(sqrt-z+1 (complex-sqrt (+ z 1))))
+    (suppress-divide-by-zero
+     (complex (asinh (realpart (* (conjugate sqrt-z-1)
+				  sqrt-z+1)))
+	      (* 2 (atan (/ (imagpart sqrt-z-1)
+			    (realpart sqrt-z+1))))))))
+
+
+(defun complex-asin (z)
+  "Compute asin z = asinh(i*z)/i
+
+Z may be any number, but the result is always a complex."
+  (declare (number z))
+  (let ((sqrt-1-z (complex-sqrt (- 1 z)))
+	(sqrt-1+z (complex-sqrt (+ 1 z))))
+    (suppress-divide-by-zero
+     (complex (atan (/ (realpart z)
+		       (realpart (* sqrt-1-z sqrt-1+z))))
+	      (asinh (imagpart (* (conjugate sqrt-1-z)
+				  sqrt-1+z)))))))
+
+(defun complex-asinh (z)
+  "Compute asinh z = log(z + sqrt(1 + z*z))
+
+Z may be any number, but the result is always a complex."
+  (declare (number z))
+  ;; asinh z = -i * asin (i*z)
+  (let* ((iz (complex (- (imagpart z)) (realpart z)))
+	 (result (complex-asin iz)))
+    (complex (imagpart result)
+	     (- (realpart result)))))
+	 
+(defun complex-atan (z)
+  "Compute atan z = atanh (i*z) / i
+
+Z may be any number, but the result is always a complex."
+  (declare (number z))
+  ;; atan z = -i * atanh (i*z)
+  (let* ((iz (complex (- (imagpart z)) (realpart z)))
+	 (result (complex-atanh iz)))
+    (complex (imagpart result)
+	     (- (realpart result)))))
+
+(defun complex-tan (z)
+  "Compute tan z = -i * tanh(i * z)
+
+Z may be any number, but the result is always a complex."
+  (declare (number z))
+  ;; tan z = -i * tanh(i*z)
+  (let* ((iz (complex (- (imagpart z)) (realpart z)))
+	 (result (complex-tanh iz)))
+    (complex (imagpart result)
+	     (- (realpart result)))))
+)
diff --git a/code/linux-os.lisp b/code/linux-os.lisp
new file mode 100644
index 000000000..ffa7ec6e6
--- /dev/null
+++ b/code/linux-os.lisp
@@ -0,0 +1,75 @@
+;;; -*- Package: SYSTEM -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/linux-os.lisp,v 1.1 1997/01/18 14:30:35 ram Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; OS interface functions for CMU CL under Mach.
+;;;
+;;; Written and maintained mostly by Skef Wholey and Rob MacLachlan.
+;;; Scott Fahlman, Dan Aronson, and Steve Handerson did stuff here, too.
+;;;
+;;; Hacked into Linux-os.lisp /Werkowski
+
+(in-package "SYSTEM")
+(use-package "EXTENSIONS")
+(export '(get-system-info get-page-size os-init))
+#+nil
+(export '(*task-self* *task-data* *task-notify*))
+
+(pushnew :linux *features*)
+
+(setq *software-type* "Linux")
+
+(defun software-version ()
+  "Returns a string describing version of the supporting software."
+  #+nil
+  (string-trim '(#\newline)
+	       (with-output-to-string (stream)
+		 (run-program "/usr/cs/etc/version" ; Site dependent???
+			      nil :output stream)))
+  "n/a")
+
+
+;;; OS-Init initializes our operating-system interface.  It sets the values
+;;; of the global port variables to what they should be and calls the functions
+;;; that set up the argument blocks for the server interfaces.
+
+(defvar *task-self*)
+
+(defun os-init ()			; don't know what to do here
+  #+nil
+  (setf *task-self* (mach:mach-task_self))
+  #+sparc ;; Can't use #x20000000 thru #xDFFFFFFF, but mach tries to let us.
+  (system:allocate-system-memory-at (system:int-sap #x20000000) #xc0000000))
+
+
+;;; GET-SYSTEM-INFO  --  Interface
+;;;
+;;;    Return system time, user time and number of page faults.
+;;;
+(defun get-system-info ()
+  (multiple-value-bind (err? utime stime maxrss ixrss idrss
+			     isrss minflt majflt)
+		       (unix:unix-getrusage unix:rusage_self)
+    (declare (ignore maxrss ixrss idrss isrss minflt))
+    (unless err?
+      (error "Unix system call getrusage failed: ~A."
+	     (unix:get-unix-error-msg utime)))
+    
+    (values utime stime majflt)))
+
+
+;;; GET-PAGE-SIZE  --  Interface
+;;;
+;;;    Return the system page size.
+;;;
+(defun get-page-size ()
+  ;; probably should call getpagesize()
+  4096)
+
diff --git a/code/lispinit.lisp b/code/lispinit.lisp
index 5c63d19cc..c5280576e 100644
--- a/code/lispinit.lisp
+++ b/code/lispinit.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/lispinit.lisp,v 1.48 1996/05/07 20:19:07 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/lispinit.lisp,v 1.49 1997/01/18 14:30:42 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -263,6 +263,20 @@
     `(progn
        (%primitive print ,(symbol-name name))
        (,name))))
+#+nil
+(defun hexstr(thing)
+  (let ((addr (kernel:get-lisp-obj-address thing))
+	(str (make-string 10)))
+    (setf (char str 0) #\0
+	  (char str 1) #\x)
+    (dotimes (i 8)
+      (let* ((nib (ldb (byte 4 0) addr))
+	     (chr (char "0123456789abcdef" nib)))
+	(declare (type (unsigned-byte 4) nib)
+		 (base-char chr))
+	(setf (char str (- 9 i)) chr
+	      addr (ash addr -4))))
+    str))
 
 (defun %initial-function ()
   "Gives the world a shove and hopes it spins."
@@ -292,7 +306,7 @@
 
   (let ((funs (nreverse *lisp-initialization-functions*)))
     (%primitive print "Calling top-level forms.")
-    (dolist (fun funs)
+    (dolist (fun funs) #+nil (%primitive print (hexstr fun))
       (typecase fun
 	(function
 	 (funcall fun))
@@ -335,7 +349,8 @@
   (print-and-call package-init)
   (print-and-call kernel::signal-init)
   (setf (alien:extern-alien "internal_errors_enabled" alien:boolean) t)
-  (set-floating-point-modes :traps '(:overflow :underflow :invalid
+
+  (set-floating-point-modes :traps '(:overflow #-x86 :underflow :invalid
 					       :divide-by-zero))
   ;; This is necessary because some of the initial top level forms might
   ;; have changed the compliation policy in strange ways.
@@ -388,6 +403,11 @@
 
 ;;;; Initialization functions:
 
+;;; Print seems to not like x86 NPX denormal floats like
+;;; least-negative-single-float, so the :underflow exceptions
+;;; is disabled by default. Joe User can explicitly enable them
+;;; if desired.
+
 (defun reinit ()
   (without-interrupts
    (without-gcing
@@ -397,7 +417,7 @@
     (gc-init)
     (setf (alien:extern-alien "internal_errors_enabled" alien:boolean) t)
     (set-floating-point-modes :traps
-			      '(:overflow :underflow :invalid
+			      '(:overflow #-x86 :underflow :invalid
 					  :divide-by-zero)))))
 
 
@@ -436,6 +456,7 @@
 
 (defconstant bytes-per-scrub-unit 2048)
 
+#-x86
 (defun scrub-control-stack ()
   "Zero the unused portion of the control stack so that old objects are not
    kept alive because of uninitialized stack variables."
@@ -469,6 +490,45 @@
       (scrub (int-sap (- csp initial-offset))
 	     (* (floor initial-offset vm:word-bytes) vm:word-bytes)
 	     0))))
+
+#+x86 ;; Stack grows downwards
+(defun scrub-control-stack ()
+  "Zero the unused portion of the control stack so that old objects are not
+   kept alive because of uninitialized stack variables."
+  (declare (optimize (speed 3) (safety 0))
+	   (values (unsigned-byte 20)))
+  (labels
+      ((scrub (ptr offset count)
+	 (declare (type system-area-pointer ptr)
+		  (type (unsigned-byte 16) offset)
+		  (type (unsigned-byte 20) count)
+		  (values (unsigned-byte 20)))
+	 (let ((loc (int-sap (- (sap-int ptr) (+ offset vm:word-bytes)))))
+	   (cond ((= offset bytes-per-scrub-unit)
+		  (look (int-sap (- (sap-int ptr) bytes-per-scrub-unit))
+			0 count))
+		 (t ;; need to fix bug in %set-stack-ref
+		  (setf (sap-ref-32 loc 0) 0)
+		  (scrub ptr (+ offset vm:word-bytes) count)))))
+       (look (ptr offset count)
+	 (declare (type system-area-pointer ptr)
+		  (type (unsigned-byte 16) offset)
+		  (type (unsigned-byte 20) count)
+		  (values (unsigned-byte 20)))
+	 (let ((loc (int-sap (- (sap-int ptr) offset))))
+	   (cond ((= offset bytes-per-scrub-unit)
+		  count)
+		 ((zerop (stack-ref loc 0))
+		  (look ptr (+ offset vm:word-bytes) count))
+		 (t
+		  (scrub ptr offset (+ count vm:word-bytes)))))))
+    (let* ((csp (sap-int (c::control-stack-pointer-sap)))
+	   (initial-offset (logand csp (1- bytes-per-scrub-unit))))
+      (declare (type (unsigned-byte 32) csp))
+      (scrub (int-sap (+ csp initial-offset))
+	     (* (floor initial-offset vm:word-bytes) vm:word-bytes)
+	     0))))
+
 
 
 
diff --git a/code/load.lisp b/code/load.lisp
index c2c3e7395..080687012 100644
--- a/code/load.lisp
+++ b/code/load.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/load.lisp,v 1.58 1994/11/04 06:02:31 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/load.lisp,v 1.59 1997/01/18 14:30:39 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -594,11 +594,17 @@
 ;;;
 (defun try-default-types (pathname types)
   (dolist (type types (values nil nil))
-    (let* ((pn (make-pathname :type type :defaults pathname))
+    ;; toy@rtp.ericsson.se: add diddle-case so that this can handle
+    ;; both unix-namestrings and logical pathname namestrings.  The
+    ;; case handling seems to be the opposite between these two
+    ;; styles.
+    (let* ((pn (make-pathname
+		:type (maybe-diddle-case
+		       type (logical-pathname-p (pathname pathname)))
+		:defaults pathname))
 	   (tn (probe-file pn)))
       (when tn (return (values pn tn))))))
 
-
 ;;; INTERNAL-LOAD-DEFAULT-TYPE  --  Internal
 ;;;
 ;;;    Handle the case of INTERNAL-LOAD where the file does not exist.
@@ -1009,6 +1015,7 @@
 ;;; Load-Code loads a code object.  NItems objects are popped off the stack for
 ;;; the boxed storage section, then Size bytes of code are read in.
 ;;;
+#-x86
 (defun load-code (box-num code-length)
   (declare (fixnum box-num code-length))
   (with-fop-stack t
@@ -1027,6 +1034,101 @@
 		      #+gengc (* code-length vm:word-bytes)))
       code)))
 
+
+;;; Moving native code during a GC or purify is not trivial on the x86
+;;; port, so there are a few options for code placement.
+;;;
+;;; Byte-compiled code objects can always be moved so can be place in
+;;; the dynamics heap.  This is enabled with
+;;; *load-byte-compiled-code-to-dynamic-space*.
+;;;
+;;; Native code top level forms only have a short life so can be
+;;; safely loaded into the dynamic heap (without fixups) so long as
+;;; the GC is not active. This could be handy during a world load to
+;;; save core space without the need to enable the support for moving
+;;; x86 native code. Enable with *load-x86-tlf-to-dynamic-space*.
+;;;
+;;; One strategy for allowing the loading of x86 native code into the
+;;; dynamic heap requires that the addresses of fixups be saved for
+;;; all these code objects.  After a purify these fixups can be
+;;; dropped. This is enabled with *enable-dynamic-space-code*.
+;;;
+;;; A little analysis of the header information is used to determine
+;;; if a code object is byte compiled, or native code.
+;;;
+#+x86
+(eval-when (compile)
+  (let ((ht (c::backend-template-names c:*backend*)))
+    (unless (gethash 'c::allocate-dynamic-code-object ht)
+      (setf (gethash 'c::allocate-dynamic-code-object ht)
+	    (gethash 'vm::allocate-dynamic-code-object ht)))))
+
+(defvar *load-byte-compiled-code-to-dynamic-space* t)
+(defvar *load-x86-tlf-to-dynamic-space* nil)  ; potentially dangerous.
+(defvar *load-code-verbose* nil)
+(defvar *enable-dynamic-space-code* nil) ; experimental
+
+#+x86
+(defun load-code (box-num code-length)
+  (declare (fixnum box-num code-length))
+  (with-fop-stack t
+    (let ((stuff (list (pop-stack))))
+      (dotimes (i box-num)
+	(declare (fixnum i))
+	(push (pop-stack) stuff))
+      (let* ((dbi (car (last stuff)))	; debug-info
+	     (tto (first stuff))	; trace-table-offset
+	     (load-to-dynamic-space
+	      (or *enable-dynamic-space-code*
+	       ;; Definitely Byte compiled code?
+	       (and *load-byte-compiled-code-to-dynamic-space*
+		    (c::debug-info-p dbi)
+		    (not (c::compiled-debug-info-p dbi)))
+	       ;; Or a x86 top level form.
+	       (and *load-x86-tlf-to-dynamic-space*
+		    (c::compiled-debug-info-p dbi)
+		    (string= (c::compiled-debug-info-name dbi)
+			     "Top-Level Form")))) )
+
+	(setq stuff (nreverse stuff))
+
+	;; Check that tto is always a list for byte-compiled
+	;; code. Could be used an alternate check.
+	(when (and (typep tto 'list)
+		   (not (and (c::debug-info-p dbi)
+			     (not (c::compiled-debug-info-p dbi)))))
+	      (format t "* tto list on non-bc code: ~s~% ~s ~s~%" 
+		      stuff dbi tto))
+	
+	(when *load-code-verbose*
+	      (format t "stuff: ~s~%" stuff)
+	      (format t "   : ~s ~s ~s ~s~%" 
+		      (c::compiled-debug-info-p dbi)
+		      (c::debug-info-p dbi)
+		      (c::compiled-debug-info-name dbi)
+		      tto)
+	      (if load-to-dynamic-space
+		  (format t "   Loading to the dynamic space~%")
+		(format t "   Loading to the static space~%")))
+      
+	(let ((code
+	       (if load-to-dynamic-space
+		   (%primitive
+		    allocate-dynamic-code-object box-num code-length)
+		   (%primitive allocate-code-object box-num code-length)))
+	      (index (+ vm:code-trace-table-offset-slot box-num))) 
+	  (declare (type index index)) 
+	  (when *load-code-verbose*
+		(format t "  obj addr=~x~%"
+			(kernel::get-lisp-obj-address code)))
+	  (setf (%code-debug-info code) (pop stuff))
+	  (dotimes (i box-num)
+	    (declare (fixnum i))
+	    (setf (code-header-ref code (decf index)) (pop stuff)))
+	  (system:without-gcing
+	   (read-n-bytes *fasl-file* (code-instructions code) 0 code-length))
+	  code)))))
+
 (define-fop (fop-code 58 :nope)
   (load-code (read-arg 4) (read-arg 4)))
 
diff --git a/code/macros.lisp b/code/macros.lisp
index a7a915453..12365359f 100644
--- a/code/macros.lisp
+++ b/code/macros.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.45 1994/10/31 04:11:27 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.46 1997/01/18 14:31:12 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1405,9 +1405,14 @@
   "Binds the Var to an input stream that returns characters from String and
   executes the body.  See manual for details."
   `(let ((,var
-	  ,(if end
-	       `(make-string-input-stream ,string ,(or start 0) ,end)
-	       `(make-string-input-stream ,string ,(or start 0)))))
+	  ,(cond ((null end)
+		  `(make-string-input-stream ,string ,(or start 0)))
+		 ((symbolp end)
+		  `(if ,end
+		       (make-string-input-stream ,string ,(or start 0) ,end)
+		     (make-string-input-stream ,string ,(or start 0))))
+		 (t
+		  `(make-string-input-stream ,string ,(or start 0) ,end)))))
      ,@decls
      (unwind-protect
        (progn ,@forms)
diff --git a/code/misc.lisp b/code/misc.lisp
index a718e78e9..7330c763b 100644
--- a/code/misc.lisp
+++ b/code/misc.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/misc.lisp,v 1.22 1994/10/31 04:11:27 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/misc.lisp,v 1.23 1997/01/18 14:31:13 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -38,7 +38,7 @@
      (variable (info variable documentation name))
      (function (info function documentation name))
      (structure
-      (when (eq (info type kind name) :structure)
+      (when (eq (info type kind name) :instance)
 	(info type documentation name)))
      (type
       (info type documentation name))
@@ -51,7 +51,7 @@
     (variable (setf (info variable documentation name) string))
     (function (setf (info function documentation name) string))
     (structure
-     (unless (eq (info type kind name) :structure)
+     (unless (eq (info type kind name) :instance)
        (error "~S is not the name of a structure type." name))
      (setf (info type documentation name) string))
     (type (setf (info type documentation name) string))
diff --git a/code/ntrace.lisp b/code/ntrace.lisp
index dc41b88c4..815611aae 100644
--- a/code/ntrace.lisp
+++ b/code/ntrace.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/ntrace.lisp,v 1.12 1994/10/31 04:11:27 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/ntrace.lisp,v 1.13 1997/01/18 14:30:50 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -31,7 +31,7 @@
   "If the trace indentation exceeds this value, then indentation restarts at
    0.")
 
-(defvar *trace-encapsulate-default* :default
+(defvar *trace-encapsulate-default* #-x86 :default #+x86 t
   "The default value for the :ENCAPSULATE option to trace.")
 
 
diff --git a/code/numbers.lisp b/code/numbers.lisp
index 09b496e94..a00f47177 100644
--- a/code/numbers.lisp
+++ b/code/numbers.lisp
@@ -5,11 +5,11 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/numbers.lisp,v 1.26 1995/02/17 18:04:08 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/numbers.lisp,v 1.27 1997/01/18 14:30:37 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/numbers.lisp,v 1.26 1995/02/17 18:04:08 ram Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/numbers.lisp,v 1.27 1997/01/18 14:30:37 ram Exp $
 ;;;
 ;;; This file contains the definitions of most number functions.
 ;;;
@@ -475,16 +475,28 @@
      (let* ((rx (realpart x))
 	    (ix (imagpart x))
 	    (ry (realpart y))
-	    (iy (imagpart y))
-	    (dn (+ (* ry ry) (* iy iy))))
-       (canonical-complex (/ (+ (* rx ry) (* ix iy)) dn)
-			  (/ (- (* ix ry) (* rx iy)) dn))))
+	    (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))
-	    (dn (+ (* ry ry) (* iy iy))))
-       (canonical-complex (/ (* x ry) dn)
-			  (/ (- (* x iy)) dn))))
+	    (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)))
diff --git a/code/pathname.lisp b/code/pathname.lisp
index be71d4578..fa0f21db5 100644
--- a/code/pathname.lisp
+++ b/code/pathname.lisp
@@ -4,7 +4,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pathname.lisp,v 1.26 1996/05/07 13:14:51 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pathname.lisp,v 1.27 1997/01/18 14:30:44 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -532,19 +532,24 @@
 	      (and default-host pathname-host
 		   (not (eq (host-customary-case default-host)
 			    (host-customary-case pathname-host))))))
-	(%make-pathname (or pathname-host default-host)
-			(or (%pathname-device pathname)
+	(make-pathname :host (or pathname-host default-host)
+		       :device
+		       (or (%pathname-device pathname)
 			    (maybe-diddle-case (%pathname-device defaults)
 					       diddle-case))
+		       :directory
 			(merge-directories (%pathname-directory pathname)
 					   (%pathname-directory defaults)
 					   diddle-case)
+			:name
 			(or (%pathname-name pathname)
 			    (maybe-diddle-case (%pathname-name defaults)
 					       diddle-case))
+			:type
 			(or (%pathname-type pathname)
 			    (maybe-diddle-case (%pathname-type defaults)
 					       diddle-case))
+			:version
 			(or (%pathname-version pathname)
 			    default-version))))))
 
@@ -593,9 +598,9 @@
 			   (version nil versionp)
 			   defaults
 			   (case :local))
-  "Makes a new pathname from the component arguments.  Note that host is a host-
-   structure."
-  (declare (type (or host component-tokens) host)
+  "Makes a new pathname from the component arguments.  Note that host is
+a host-structure or string."
+  (declare (type (or string host component-tokens) host)
 	   (type component-tokens device)
 	   (type (or list string pattern component-tokens) directory)
 	   (type (or string pattern component-tokens) name type)
@@ -607,7 +612,10 @@
 	 (default-host (if defaults
 			   (%pathname-host defaults)
 			   (pathname-host *default-pathname-defaults*)))
-	 (host (or host default-host))
+	 ;; toy@rtp.ericsson.se: CLHS says make-pathname can take a
+	 ;; string (as a logical-host) for the host part.  We map that
+	 ;; string into the corresponding logical host structure.
+	 (host (or (gethash host *logical-hosts*) host default-host))
 	 (diddle-args (and (eq (host-customary-case host) :lower)
 			   (eq case :common)))
 	 (diddle-defaults
@@ -821,10 +829,11 @@
        (%parse-namestring (coerce thing 'simple-string)
 			  host defaults start end junk-allowed))
       (pathname
-       (let ((host (if host host (%pathname-host defaults))))
-	 (unless (eq host (%pathname-host thing))
+       (let* ((host (if host host (%pathname-host defaults)))
+	      (hosts-name (funcall (host-unparse-host host) host)))
+	 (unless (eq hosts-name (%pathname-host thing))
 	   (error "Hosts do not match: ~S and ~S."
-		  host (%pathname-host thing))))
+		  hosts-name (%pathname-host thing))))
        (values thing start))
       (stream
        (let ((name (file-name thing)))
@@ -1181,12 +1190,25 @@
 			    (if (eq result :error)
 				(error "~S doesn't match ~S" source from)
 				result))))
+	      #+nil ;; pw- 1/3/97 This doesn't work.
 	      (%make-pathname (or to-host source-host)
 			      (frob %pathname-device)
 			      (frob %pathname-directory translate-directories)
 			      (frob %pathname-name)
 			      (frob %pathname-type)
-			      (frob %pathname-version))))))))
+			      (frob %pathname-version))
+
+	      (let ((host      (or to-host source-host))
+		    (device    (frob %pathname-device))
+		    (directory (frob %pathname-directory translate-directories))
+		    (name      (frob %pathname-name))
+		    (type      (frob %pathname-type))
+		    (version   (frob %pathname-version)))
+		(if (logical-host-p host)
+		     (%make-logical-pathname
+		      host :unspecific directory name type version)
+		     (%make-pathname 
+		      host device directory name type version)))))))))
 
 
 ;;;; Search lists.
@@ -1750,9 +1772,10 @@
     (with-open-file (in-str (make-pathname :defaults "library:"
 					   :name host
 					   :type "translations"))
-      (format *error-output*
-	      ";; Loading pathname translations from ~A~%"
-	      (namestring (truename in-str)))
+      (if *load-verbose*
+	  (format *error-output*
+		  ";; Loading pathname translations from ~A~%"
+		  (namestring (truename in-str))))
       (setf (logical-pathname-translations host) (read in-str)))
     t))
 
diff --git a/code/pred.lisp b/code/pred.lisp
index dfc0446c6..d4f086f41 100644
--- a/code/pred.lisp
+++ b/code/pred.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pred.lisp,v 1.34 1994/10/31 04:11:27 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pred.lisp,v 1.35 1997/01/18 14:30:34 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -193,10 +193,10 @@
 	      (rational (rationalp num))
 	      (float
 	       (ecase (numeric-type-format type)
-		 (short-float (typep object 'short-float))
-		 (single-float (typep object 'single-float))
-		 (double-float (typep object 'double-float))
-		 (long-float (typep object 'long-float))
+		 (short-float (typep num 'short-float))
+		 (single-float (typep num 'single-float))
+		 (double-float (typep num 'double-float))
+		 (long-float (typep num 'long-float))
 		 ((nil) (floatp num))))
 	      ((nil) t)))
 	  (flet ((bound-test (val)
diff --git a/code/save.lisp b/code/save.lisp
index 8c5c2f5e7..778f22b0d 100644
--- a/code/save.lisp
+++ b/code/save.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/save.lisp,v 1.28 1996/05/08 02:02:37 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/save.lisp,v 1.29 1997/01/18 14:30:54 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -91,8 +91,9 @@
 
   (setf (search-list "library:")
 	(or (parse-unix-search-list :cmucllib)
-	    '(#+mach "/usr/misc/.cmucl/lib/"
-	      #-mach "/usr/local/lib/cmucl/lib/"))))
+	    '(#+mach  "/usr/misc/.cmucl/lib/"
+	      #+linux "/usr/lib/cmucl/"
+	      #-(or mach linux) "/usr/local/lib/cmucl/lib/"))))
 
 
 
diff --git a/code/seq.lisp b/code/seq.lisp
index 613b24eaf..57aca78ef 100644
--- a/code/seq.lisp
+++ b/code/seq.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/seq.lisp,v 1.21 1996/07/12 18:05:35 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/seq.lisp,v 1.22 1997/01/18 14:30:36 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -115,7 +115,7 @@
     (list
      (do ((count index (1- count))
 	  (seq sequence))
-	 ((= count 0) (rplaca seq newval) sequence)
+ 	 ((= count 0) (rplaca seq newval) newval)
        (declare (fixnum count))
        (if (atom (cdr seq))
 	   (error "~S: index too large." index)
@@ -811,12 +811,23 @@
 	       (%double-float object))
 	      ((csubtypep type (specifier-type 'float))
 	       (%single-float object))
+	      ((csubtypep type (specifier-type '(complex single-float)))
+	       (complex (%single-float (realpart object))
+			(%single-float (imagpart object))))
+	      ((csubtypep type (specifier-type '(complex double-float)))
+	       (complex (%double-float (realpart object))
+			(%double-float (imagpart object))))
 	      ((csubtypep type (specifier-type 'complex))
 	       (complex object))
 	      (t
 	       (error "~S can't be converted to type ~S."
 		      object output-type-spec)))))
-	(unless (typep res output-type-spec)
+	;; If RES has the wrong type, that means that rule of
+	;; canonical representation for complex rationals was invoked.
+	;; According to the Hyperspec, (coerce 7/2 'complex) returns
+	;; 7/2.  Thus, if the object was a rational, there is no error
+	;; here.
+	(unless (or (typep res output-type-spec) (rationalp object))
 	  (error "~S can't be converted to type ~S."
 		 object output-type-spec))
 	res))
diff --git a/code/signal.lisp b/code/signal.lisp
index c4b25d29d..5afbd40d0 100644
--- a/code/signal.lisp
+++ b/code/signal.lisp
@@ -5,11 +5,11 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/signal.lisp,v 1.24 1994/10/31 04:11:27 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/signal.lisp,v 1.25 1997/01/18 14:30:33 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/signal.lisp,v 1.24 1994/10/31 04:11:27 ram Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/signal.lisp,v 1.25 1997/01/18 14:30:33 ram Exp $
 ;;;
 ;;; Code for handling UNIX signals.
 ;;; 
@@ -51,7 +51,9 @@
 (defvar *unix-signals* nil
   "A list of unix signal structures.")
 
+
 (eval-when (compile eval)
+;(setf *unix-signals* nil) ; pve: sigh or else...
 (defmacro def-unix-signal (name number description)
   (let ((symbol (intern (symbol-name name))))
     `(progn
@@ -92,34 +94,42 @@
 ;;; Known signals
 ;;; 
 (def-unix-signal :CHECK 0 "Check")
+
 (def-unix-signal :SIGHUP 1 "Hangup")
 (def-unix-signal :SIGINT 2 "Interrupt")
 (def-unix-signal :SIGQUIT 3 "Quit")
 (def-unix-signal :SIGILL 4 "Illegal instruction")
 (def-unix-signal :SIGTRAP 5 "Trace trap")
 (def-unix-signal :SIGIOT 6 "Iot instruction")
+#-linux
 (def-unix-signal :SIGEMT 7 "Emt instruction")
 (def-unix-signal :SIGFPE 8 "Floating point exception")
 (def-unix-signal :SIGKILL 9 "Kill")
-(def-unix-signal :SIGBUS 10 "Bus error")
+(def-unix-signal :SIGBUS #-linux 10 #+linux 7 "Bus error")
 (def-unix-signal :SIGSEGV 11 "Segmentation violation")
+#-linux
 (def-unix-signal :SIGSYS 12 "Bad argument to system call")
 (def-unix-signal :SIGPIPE 13 "Write on a pipe with no one to read it")
 (def-unix-signal :SIGALRM 14 "Alarm clock")
 (def-unix-signal :SIGTERM 15 "Software termination signal")
-(def-unix-signal :SIGURG #+svr4 21 #-(or hpux svr4) 16 #+hpux 29 
-  "Urgent condition present on socket")
-(def-unix-signal :SIGSTOP #-(or hpux svr4) 17 #+hpux 24 #+svr4 23 "Stop")
-(def-unix-signal :SIGTSTP #-(or hpux svr4) 18 #+hpux 25 #+svr4 24
-  "Stop signal generated from keyboard")
-(def-unix-signal :SIGCONT #-(or hpux svr4) 19 #+hpux 26 #+svr4 25
-    "Continue after stop")
-(def-unix-signal :SIGCHLD #-hpux 20 #+hpux 18 "Child status has changed")
+#+linux
+(def-unix-signal :SIGSTKFLT 16 "Stack fault on coprocessor")
+(def-unix-signal :SIGURG #+svr4 21 #-(or hpux svr4 linux) 16 #+hpux 29
+  #+linux 23 "Urgent condition present on socket")
+(def-unix-signal :SIGSTOP #-(or hpux svr4 linux) 17 #+hpux 24 #+svr4 23 
+  #+linux 19 "Stop")
+(def-unix-signal :SIGTSTP #-(or hpux svr4 linux) 18 #+hpux 25 #+svr4 24
+  #+linux 20 "Stop signal generated from keyboard")
+(def-unix-signal :SIGCONT #-(or hpux svr4 linux) 19 #+hpux 26 #+svr4 25
+  #+linux 18 "Continue after stop")
+(def-unix-signal :SIGCHLD #-(or linux hpux) 20 
+  #+hpux 18 #+linux 17 "Child status has changed")
 (def-unix-signal :SIGTTIN #-(or hpux svr4) 21 #+hpux 27 #+svr4 26
   "Background read attempted from control terminal")
 (def-unix-signal :SIGTTOU #-(or hpux svr4) 22 #+hpux 28 #+svr4 27
   "Background write attempted to control terminal")
-(def-unix-signal :SIGIO #-(or hpux irix) 23 #+(or hpux irix) 22
+(def-unix-signal :SIGIO #-(or hpux irix linux) 23 #+(or hpux irix) 22
+  #+linux 29
   "I/O is possible on a descriptor")
 #-hpux
 (def-unix-signal :SIGXCPU #-svr4 24 #+svr4 30  "Cpu time limit exceeded")
@@ -127,14 +137,14 @@
 (def-unix-signal :SIGXFSZ #-svr4 25 #+svr4 31 "File size limit exceeded")
 (def-unix-signal :SIGVTALRM #-(or hpux svr4) 26 #+hpux 20 #+svr4 28
     "Virtual time alarm")
-(def-unix-signal :SIGPROF #-(or hpux svr4) 27 #+hpux 21 #+svr4 29
-    "Profiling timer alarm")
+(def-unix-signal :SIGPROF #-(or hpux svr4 linux) 27 #+hpux 21 #+svr4 29
+  #+linux 30 "Profiling timer alarm")
 (def-unix-signal :SIGWINCH #-(or hpux svr4) 28 #+hpux 23 #+svr4 20
     "Window size change")
-(def-unix-signal :SIGUSR1 #-(or hpux svr4) 30 #+(or hpux svr4) 16
-    "User defined signal 1")
-(def-unix-signal :SIGUSR2 #-(or hpux svr4) 31 #+(or hpux svr4) 17
-    "User defined signal 2")
+(def-unix-signal :SIGUSR1 #-(or hpux svr4 linux) 30 #+(or hpux svr4) 16
+  #+linux 10 "User defined signal 1")
+(def-unix-signal :SIGUSR2 #-(or hpux svr4 linux) 31 #+(or hpux svr4) 17
+  #+linux 12 "User defined signal 2")
 ;;; 
 ;;; These are Mach Specific
 #+mach
@@ -146,6 +156,7 @@
 #+svr4
 (def-unix-signal :SIGWAITING 32 "Process's lwps are blocked")
 
+
 ;;; SIGMASK -- Public
 ;;;
 (defmacro sigmask (&rest signals)
@@ -256,9 +267,11 @@
 (define-signal-handler sigill-handler "Illegal Instruction")
 (define-signal-handler sigtrap-handler "Breakpoint/Trap")
 (define-signal-handler sigiot-handler "SIGIOT")
+#-linux
 (define-signal-handler sigemt-handler "SIGEMT")
 (define-signal-handler sigbus-handler "Bus Error")
 (define-signal-handler sigsegv-handler "Segmentation Violation")
+#-linux
 (define-signal-handler sigsys-handler "Bad Argument to a System Call")
 (define-signal-handler sigpipe-handler "SIGPIPE")
 (define-signal-handler sigalrm-handler "SIGALRM")
@@ -275,10 +288,12 @@
   (enable-interrupt :sigill #'sigill-handler)
   (enable-interrupt :sigtrap #'sigtrap-handler)
   (enable-interrupt :sigiot #'sigiot-handler)
+  #-linux
   (enable-interrupt :sigemt #'sigemt-handler)
   (enable-interrupt :sigfpe #'vm:sigfpe-handler)
   (enable-interrupt :sigbus #'sigbus-handler)
   (enable-interrupt :sigsegv #'sigsegv-handler)
+  #-linux
   (enable-interrupt :sigsys #'sigsys-handler)
   (enable-interrupt :sigpipe #'sigpipe-handler)
   (enable-interrupt :sigalrm #'sigalrm-handler)
diff --git a/code/unix.lisp b/code/unix.lisp
index cf44aef12..270515215 100644
--- a/code/unix.lisp
+++ b/code/unix.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/unix.lisp,v 1.42 1996/07/25 20:46:19 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/unix.lisp,v 1.43 1997/01/18 14:30:40 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -24,7 +24,7 @@
 	  t-stopc t-eofc t-brkc ltchars t-suspc t-dsuspc t-rprntc t-flushc
 	  t-werasc t-lnextc sgttyb sg-ispeed sg-ospeed sg-erase sg-kill
 	  sg-flags winsize ws-row ws-col ws-xpixel ws-ypixel
-	  direct d-off d-ino d-reclen #-svr4 d-namlen d-name
+	  direct d-off d-ino d-reclen #-(or linux svr4) d-namlen d-name
 	  stat st-dev st-mode st-nlink st-uid st-gid st-rdev st-size
 	  st-atime st-mtime st-ctime st-blksize st-blocks
 	  s-ifmt s-ifdir s-ifchr s-ifblk s-ifreg s-iflnk s-ifsock
@@ -45,32 +45,32 @@
 	  unix-fcntl f-dupfd f-getfd f-setfd f-getfl f-setfl f-getown f-setown
 	  fndelay fappend fasync fcreat ftrunc fexcl unix-link unix-lseek
 	  l_set l_incr l_xtnd unix-mkdir unix-open o_rdonly o_wronly o_rdwr
-	  #+svr4 o_ndelay
+	  #+(or svr4 freebsd linux) o_ndelay
 	  o_append o_creat o_trunc o_excl unix-pipe unix-read unix-readlink
 	  unix-rename unix-rmdir unix-fast-select fd-setsize fd-set fd-clr
 	  fd-isset fd-zero unix-select unix-sync unix-fsync unix-truncate
 	  unix-ftruncate unix-symlink unix-unlink unix-write unix-ioctl
 	  tcsetpgrp tcgetpgrp tty-process-group
 	  terminal-speeds tty-raw tty-crmod tty-echo tty-lcase
-	  #-(or hpux svr4) tty-cbreak #-(or hpux svr4) tty-tandem
-	  #+(or hpux svr4) termios #+(or hpux svr4) c-lflag
-	  #+(or hpux svr4) c-iflag #+(or hpux svr4) c-oflag
-	  #+(or hpux svr4) tty-icrnl #+(or hpux svr4) tty-ocrnl
-	  #+(or hpux svr4) vdsusp #+(or hpux svr4) veof
-	  #+(or hpux svr4) vintr #+(or hpux svr4) vquit #+(or hpux svr4) vstart
-	  #+(or hpux svr4) vstop #+(or hpux svr4) vsusp
-	  #+(or hpux svr4) c-cflag
-	  #+(or hpux svr4) c-cc #+(or hpux svr4) tty-icanon
-	  #+(or hpux svr4) vmin #+(or hpux svr4) vtime
-	  #+(or hpux svr4) tty-ixon
-	  #+(or hpux svr4) tcsaflush #+(or hpux svr4)
-	  unix-tcgetattr #+(or hpux svr4) unix-tcsetattr
+	  #-(or hpux svr4 freebsd) tty-cbreak #-(or hpux svr4) tty-tandem
+	  #+(or hpux svr4 linux freebsd) termios #+(or hpux svr4 freebsd) c-lflag
+	  #+(or hpux svr4 freebsd) c-iflag #+(or hpux svr4 freebsd) c-oflag
+	  #+(or hpux svr4 freebsd) tty-icrnl #+(or hpux svr4 freebsd) tty-ocrnl
+	  #+(or hpux svr4 freebsd) vdsusp #+(or hpux svr4 freebsd) veof
+	  #+(or hpux svr4 freebsd) vintr #+(or hpux svr4 freebsd) vquit #+(or hpux svr4 freebsd) vstart
+	  #+(or hpux svr4 freebsd) vstop #+(or hpux svr4 freebsd) vsusp
+	  #+(or hpux svr4 freebsd) c-cflag
+	  #+(or hpux svr4 freebsd) c-cc #+(or hpux svr4 freebsd) tty-icanon
+	  #+(or hpux svr4 freebsd) vmin #+(or hpux svr4 freebsd) vtime
+	  #+(or hpux svr4 freebsd) tty-ixon
+	  #+(or hpux svr4 freebsd) tcsaflush #+(or hpux svr4 linux freebsd)
+	  unix-tcgetattr #+(or hpux svr4 linux freebsd) unix-tcsetattr
 	  TIOCGETP TIOCSETP TIOCFLUSH TIOCSETC TIOCGETC TIOCSLTC
 	  TIOCGLTC TIOCNOTTY TIOCSPGRP TIOCGPGRP TIOCGWINSZ TIOCSWINSZ
 	  TIOCSIGSEND
 
 	  KBDCGET KBDCSET KBDCRESET KBDCRST KBDCSSTD KBDSGET KBDGCLICK
-	  KBDSCLICK FIONREAD #+hpux siocspgrp
+	  KBDSCLICK FIONREAD #+(or hpux freebsd) siocspgrp
 	  unix-exit unix-stat unix-lstat unix-fstat
 	  unix-getrusage unix-fast-getrusage rusage_self rusage_children
 	  unix-gettimeofday
@@ -88,30 +88,48 @@
 
 ;;;; Common machine independent structures.
 
+#+bsd
+(def-alien-type quad-t (array unsigned-long 2))
+
 ;;; From sys/types.h
 
-(def-alien-type daddr-t #-alpha long #+alpha int)
+(def-alien-type daddr-t #-(or linux alpha) long #+(or linux alpha) int)
 (def-alien-type caddr-t (* char))
 (def-alien-type ino-t #-alpha unsigned-long #+alpha unsigned-int)
 (def-alien-type swblk-t long)
-(def-alien-type size-t #-alpha long #+alpha unsigned-long)
-(def-alien-type time-t #-alpha unsigned-long #+alpha unsigned-int)
-(def-alien-type dev-t #-(or alpha svr4) short #+alpha int #+svr4 unsigned-long)
+(def-alien-type size-t #-(or linux alpha) long #+linux unsigned-int 
+  #+alpha unsigned-long)
+(def-alien-type time-t #-(or linux alpha) unsigned-long #+linux long
+  #+alpha unsigned-int)
+
+(def-alien-type dev-t #-(or alpha svr4 bsd linux) short #+linux unsigned-short
+	 #+alpha int #+(and (not linux) (or bsd svr4)) unsigned-long)
+#-FreeBSD
 (def-alien-type off-t #-alpha long #+alpha unsigned-long)
+#+FreeBSD
+(def-alien-type off-t quad-t)
+#-FreeBSD
 (def-alien-type uid-t #-(or alpha svr4) unsigned-short #+alpha unsigned-int
   #+svr4 long)
+#+FreeBSD
+(def-alien-type uid-t unsigned-long)
+#-FreeBSD
 (def-alien-type gid-t #-(or alpha svr4) unsigned-short #+alpha unsigned-int
   #+svr4 long)
+#+FreeBSD
+(def-alien-type gid-t unsigned-long)
 (def-alien-type mode-t #-(or alpha svr4) unsigned-short
   #+alpha unsigned-int #+svr4 unsigned-long)
 (def-alien-type nlink-t #-svr4 unsigned-short #+svr4 unsigned-long)
 
-(defconstant FD-SETSIZE #-(or hpux alpha) 256 #+hpux 2048 #+alpha 4096)
+(defconstant FD-SETSIZE #-(or hpux alpha linux) 256 #+hpux 2048 #+alpha 4096 #+linux 1024)
 
+;; not checked for linux...
 (def-alien-type nil
   (struct fd-set
     (fds-bits (array #-alpha unsigned-long #+alpha int #.(/ fd-setsize 32)))))
 
+;; not checked for linux...
 (defmacro fd-set (offset fd-set)
   (let ((word (gensym))
 	(bit (gensym)))
@@ -120,6 +138,7 @@
 	     (logior (truly-the (unsigned-byte 32) (ash 1 ,bit))
 		     (deref (slot ,fd-set 'fds-bits) ,word))))))
 
+;; not checked for linux...
 (defmacro fd-clr (offset fd-set)
   (let ((word (gensym))
 	(bit (gensym)))
@@ -129,12 +148,14 @@
 		     (32bit-logical-not
 		      (truly-the (unsigned-byte 32) (ash 1 ,bit))))))))
 
+;; not checked for linux...
 (defmacro fd-isset (offset fd-set)
   (let ((word (gensym))
 	(bit (gensym)))
     `(multiple-value-bind (,word ,bit) (floor ,offset 32)
        (logbitp ,bit (deref (slot ,fd-set 'fds-bits) ,word)))))
 
+;; not checked for linux...
 (defmacro fd-zero (fd-set)
   `(progn
      ,@(loop for index upfrom 0 below (/ fd-setsize 32)
@@ -144,54 +165,80 @@
 
 (def-alien-type nil
   (struct timeval
-    (tv-sec time-t)		; seconds
-    (tv-usec time-t)))		; and microseconds
+    (tv-sec #-linux time-t #+linux int)		; seconds
+    (tv-usec #-linux time-t #+linux int)))		; and microseconds
 
 (def-alien-type nil
   (struct timezone
     (tz-minuteswest int)		; minutes west of Greenwich
     (tz-dsttime				; type of dst correction
-     (enum nil :none :usa :aust :wet :met :eet :can))))
+     #-linux (enum nil :none :usa :aust :wet :met :eet :can)
+     #+linux int)))
 
 (def-alien-type nil
   (struct itimerval
     (it-interval (struct timeval))	; timer interval
     (it-value (struct timeval))))	; current value
 
-#+svr4
+#+(or linux svr4)
 ; High-res time.  Actually posix definition under svr4 name.
 (def-alien-type nil
   (struct timestruc-t
     (tv-sec time-t)
     (tv-nsec long)))
 
-;;; From ioctl.h
+#+(or linux FreeBSD)
+(def-alien-type nil
+  (struct timespec-t
+    (ts-sec long)
+    (ts-nsec long)))
 
+;;; From ioctl.h
 (def-alien-type nil
   (struct tchars
     (t-intrc char)			; interrupt
     (t-quitc char)			; quit
+    #+linux (t-eofc char)
     (t-startc char)			; start output
     (t-stopc char)			; stop output
-    (t-eofc char)			; end-of-file
+    #-linux (t-eofc char)			; end-of-file
     (t-brkc char)))			; input delimiter (like nl)
 
+;; not found (semi) linux
 (def-alien-type nil
   (struct ltchars
+    #+linux (t-werasc char)			; word erase 	  
     (t-suspc char)			; stop process signal
     (t-dsuspc char)			; delayed stop process signal
     (t-rprntc char)			; reprint line
     (t-flushc char)			; flush output (toggles)
-    (t-werasc char)			; word erase
+    #-linux (t-werasc char)			; word erase
     (t-lnextc char)))			; literal next character
 
+
+
+#+(or svr4 hpux linux)
+(def-alien-type nil
+  (struct termios
+    (c-iflag unsigned-int)
+    (c-oflag unsigned-int)
+    (c-cflag unsigned-int)
+    (c-lflag unsigned-int)
+    #+(or linux hpux)
+    (c-reserved #-linux unsigned-int #+linux unsigned-char)
+    (c-cc (array unsigned-char #+hpux 16 #+(or linux solaris) 19 #+irix 23))))
+
 (def-alien-type nil
   (struct sgttyb
+    #+linux (sg-flags #+mach short #-mach int) ; mode flags 	  
     (sg-ispeed char)			; input speed.
     (sg-ospeed char)			; output speed
     (sg-erase char)			; erase character
-    (sg-kill char)			; kill character
-    (sg-flags #+mach short #-mach int))) ; mode flags
+    #-linux (sg-kill char)			; kill character
+    #-linux (sg-flags #+mach short #-mach int) ; mode flags
+    #+linux (sg-kill char)
+    #+linux (t (struct termios))
+    #+linux (check int)))
 
 (def-alien-type nil
   (struct winsize
@@ -203,32 +250,44 @@
 
 ;;; From sys/termio.h
 
-#+(or svr4 hpux)
+#+(or svr4 hpux freebsd linux)
 (def-alien-type nil
   (struct termios
     (c-iflag unsigned-int)
     (c-oflag unsigned-int)
     (c-cflag unsigned-int)
     (c-lflag unsigned-int)
-    #+hpux
-    (c-reserved unsigned-int)
-    (c-cc (array unsigned-char #+hpux 16 #+solaris 19 #+irix 23))))
+    #+(or linux hpux)
+    (c-reserved #-linux unsigned-int #+linux unsigned-char)
+    (c-cc (array unsigned-char #+hpux 16 #+(or linux solaris) 19 #+irix 23 #+freebsd 20))
+    ;; FreeBSD also has c-ispeed and c-ospeed?
+    ))
 
 ;;; From sys/dir.h
-
+#-bsd
 (def-alien-type nil
   (struct direct
     #+(and sunos (not svr4)) (d-off long) ; offset of next disk directory entry
     (d-ino ino-t); inode number of entry
-    #+svr4 (d-off long)
+    #+(or linux svr4) (d-off long)
     (d-reclen unsigned-short)		; length of this record
-    #-svr4
+    #-(or linux svr4)
     (d-namlen unsigned-short)		; length of string in d-name
     (d-name (array char 256))))		; name must be no longer than this
 
+#+bsd
+(def-alien-type nil
+  (struct direct
+    (d-fileno unsigned-long)
+    (d-reclen unsigned-short)
+    (d-type unsigned-char)
+    (d-namlen unsigned-char)		; length of string in d-name
+    (d-name (array char 256))))		; name must be no longer than this
+
 ;;; From sys/stat.h
+;; oh boy, in linux-> 2 stat(s)!!
 
-#-svr4
+#-(or svr4 freebsd linux)
 (def-alien-type nil
   (struct stat
     (st-dev dev-t)
@@ -249,34 +308,68 @@
     (st-blocks #-alpha long #+alpha int)
     (st-spare4 (array long 2))))
 
-#+svr4
+#+FreeBSD
 (def-alien-type nil
   (struct stat
     (st-dev dev-t)
-    (st-pad1 (array long 3))
     (st-ino ino-t)
-    (st-mode unsigned-long)
-    (st-nlink short)
+    (st-mode mode-t)
+    (st-nlink nlink-t)
     (st-uid uid-t)
     (st-gid gid-t)
     (st-rdev dev-t)
-    (st-pad2 (array long 2))
+    (st-atime (struct timespec-t))
+    (st-mtime (struct timespec-t))
+    (st-ctime (struct timespec-t))
+    (st-size    unsigned-long)		; really quad
+    (st-sizeh   unsigned-long)		;
+    (st-blocks  unsigned-long)		; really quad
+    (st-blocksh unsigned-long)
+    (st-blksize unsigned-long)
+    (st-flags   unsigned-long)
+    (st-gen     unsigned-long)
+    (st-lspare  long)
+    (st-qspare (array long 4))))	; 2 quads
+
+#+(or linux svr4)
+(def-alien-type nil
+  (struct stat
+    (st-dev dev-t)
+    (st-pad1 #-linux (array long 3) #+linux unsigned-short)
+    (st-ino ino-t)
+    (st-mode #-linux unsigned-long #+linux unsigned-short)
+    (st-nlink #-linux short #+linux unsigned-short)
+    (st-uid #-linux uid-t #+linux unsigned-short)
+    (st-gid #-linux gid-t #+linux unsigned-short)
+    (st-rdev dev-t)
+    (st-pad2 #-linux (array long 2) #+linux unsigned-short)
     (st-size off-t)
-    (st-pad3 long)
-    (st-atime (struct timestruc-t))
-    (st-mtime (struct timestruc-t))
-    (st-ctime (struct timestruc-t))
-    (st-blksize long)
-    (st-blocks long)
-    (st-fstype (array char 16))
-    (st-pad4 (array long 8))))
-
-(defconstant s-ifmt #o0170000)
-(defconstant s-ifdir #o0040000)
-(defconstant s-ifchr #o0020000)
-(defconstant s-ifblk #o0060000)
-(defconstant s-ifreg #o0100000)
-(defconstant s-iflnk #o0120000)
+    #-linux (st-pad3 long)
+    #+linux (st-blksize unsigned-long)
+    #+linux (st-blocks unsigned-long)
+    #-linux (st-atime (struct timestruc-t))
+    #+linux (st-atime unsigned-long)
+    #+linux (unused-1 unsigned-long)
+    #-linux (st-mtime (struct timestruc-t))
+    #+linux (st-mtime unsigned-long)
+    #+linux (unused-2 unsigned-long)
+    #-linux (st-ctime (struct timestruc-t))
+    #+linux (st-ctime unsigned-long)
+    #+linux (unused-3 unsigned-long)
+    #+linux (unused-4 unsigned-long)
+    #+linux (unused-5 unsigned-long)
+    #-linux(st-blksize long)
+    #-linux (st-blocks long)
+    #-linux (st-fstype (array char 16))
+    #-linux (st-pad4 (array long 8))))
+
+(defconstant s-ifmt   #o0170000)
+(defconstant s-ifdir  #o0040000)
+(defconstant s-ifchr  #o0020000)
+#+linux (defconstant s-ififo #x0010000)
+(defconstant s-ifblk  #o0060000)
+(defconstant s-ifreg  #o0100000)
+(defconstant s-iflnk  #o0120000)
 (defconstant s-ifsock #o0140000)
 (defconstant s-isuid #o0004000)
 (defconstant s-isgid #o0002000)
@@ -308,8 +401,8 @@
 
 (def-alien-type nil
   (struct rlimit
-    (rlim-cur #-alpha int #+alpha unsigned-int)	 ; current (soft) limit
-    (rlim-max #-alpha int #+alpha unsigned-int))); maximum value for rlim-cur
+    (rlim-cur #-(or linux alpha) int #+linux long #+alpha unsigned-int)	 ; current (soft) limit
+    (rlim-max #-(or linux alpha) int #+linux long #+alpha unsigned-int))); maximum value for rlim-cur
 
 
 
@@ -341,7 +434,7 @@
 ;;; From <errno.h>
 ;;; 
 (def-unix-error ESUCCESS 0 "Successful")
-(def-unix-error EPERM 1 "Not owner")
+(def-unix-error EPERM 1 #-linux "Not owner" #+linux "Operation not permitted")
 (def-unix-error ENOENT 2 "No such file or directory")
 (def-unix-error ESRCH 3 "No such process")
 (def-unix-error EINTR 4 "Interrupted system call")
@@ -351,12 +444,12 @@
 (def-unix-error ENOEXEC 8 "Exec format error")
 (def-unix-error EBADF 9 "Bad file number")
 (def-unix-error ECHILD 10 "No children")
-(def-unix-error EAGAIN 11 "No more processes")
-(def-unix-error ENOMEM 12 "Not enough core")
+(def-unix-error EAGAIN 11 #-linux "No more processes" #+linux "Try again")
+(def-unix-error ENOMEM 12 #-linux "Not enough core" #+linux "Out of memory")
 (def-unix-error EACCES 13 "Permission denied")
 (def-unix-error EFAULT 14 "Bad address")
 (def-unix-error ENOTBLK 15 "Block device required")
-(def-unix-error EBUSY 16 "Mount device busy")
+(def-unix-error EBUSY 16 #-linux "Mount device busy" #+linux "Device or resource busy")
 (def-unix-error EEXIST 17 "File exists")
 (def-unix-error EXDEV 18 "Cross-device link")
 (def-unix-error ENODEV 19 "No such device")
@@ -375,10 +468,10 @@
 (def-unix-error EPIPE 32 "Broken pipe")
 ;;; 
 ;;; Math
-(def-unix-error EDOM 33 "Argument too large")
-(def-unix-error ERANGE 34 "Result too large")
+(def-unix-error EDOM 33 #-linux "Argument too large" #+linux "Math argument out of domain")
+(def-unix-error ERANGE 34 #-linux "Result too large" #+linux "Math result not representable")
 ;;; 
-#-svr4
+#-(or linux svr4)
 (progn
 ;;; non-blocking and interrupt i/o
 (def-unix-error EWOULDBLOCK 35 "Operation would block")
@@ -523,6 +616,98 @@
 (def-unix-error EINPROGRESS 150 "Operation now in progress")
 (def-unix-error ESTALE 151 "Stale NFS file handle")
 )
+#+linux
+(progn
+(def-unix-error  EDEADLK         35     "Resource deadlock would occur")
+(def-unix-error  ENAMETOOLONG    36     "File name too long")
+(def-unix-error  ENOLCK          37     "No record locks available")
+(def-unix-error  ENOSYS          38     "Function not implemented")
+(def-unix-error  ENOTEMPTY       39     "Directory not empty")
+(def-unix-error  ELOOP           40     "Too many symbolic links encountered")
+(def-unix-error  EWOULDBLOCK     11     "Operation would block")
+(def-unix-error  ENOMSG          42     "No message of desired type")
+(def-unix-error  EIDRM           43     "Identifier removed")
+(def-unix-error  ECHRNG          44     "Channel number out of range")
+(def-unix-error  EL2NSYNC        45     "Level 2 not synchronized")
+(def-unix-error  EL3HLT          46     "Level 3 halted")
+(def-unix-error  EL3RST          47     "Level 3 reset")
+(def-unix-error  ELNRNG          48     "Link number out of range")
+(def-unix-error  EUNATCH         49     "Protocol driver not attached")
+(def-unix-error  ENOCSI          50     "No CSI structure available")
+(def-unix-error  EL2HLT          51     "Level 2 halted")
+(def-unix-error  EBADE           52     "Invalid exchange")
+(def-unix-error  EBADR           53     "Invalid request descriptor")
+(def-unix-error  EXFULL          54     "Exchange full")
+(def-unix-error  ENOANO          55     "No anode")
+(def-unix-error  EBADRQC         56     "Invalid request code")
+(def-unix-error  EBADSLT         57     "Invalid slot")
+(def-unix-error  EDEADLOCK       EDEADLK     "File locking deadlock error")
+(def-unix-error  EBFONT          59     "Bad font file format")
+(def-unix-error  ENOSTR          60     "Device not a stream")
+(def-unix-error  ENODATA         61     "No data available")
+(def-unix-error  ETIME           62     "Timer expired")
+(def-unix-error  ENOSR           63     "Out of streams resources")
+(def-unix-error  ENONET          64     "Machine is not on the network")
+(def-unix-error  ENOPKG          65     "Package not installed")
+(def-unix-error  EREMOTE         66     "Object is remote")
+(def-unix-error  ENOLINK         67     "Link has been severed")
+(def-unix-error  EADV            68     "Advertise error")
+(def-unix-error  ESRMNT          69     "Srmount error")
+(def-unix-error  ECOMM           70     "Communication error on send")
+(def-unix-error  EPROTO          71     "Protocol error")
+(def-unix-error  EMULTIHOP       72     "Multihop attempted")
+(def-unix-error  EDOTDOT         73     "RFS specific error")
+(def-unix-error  EBADMSG         74     "Not a data message")
+(def-unix-error  EOVERFLOW       75     "Value too large for defined data type")
+(def-unix-error  ENOTUNIQ        76     "Name not unique on network")
+(def-unix-error  EBADFD          77     "File descriptor in bad state")
+(def-unix-error  EREMCHG         78     "Remote address changed")
+(def-unix-error  ELIBACC         79     "Can not access a needed shared library")
+(def-unix-error  ELIBBAD         80     "Accessing a corrupted shared library")
+(def-unix-error  ELIBSCN         81     ".lib section in a.out corrupted")
+(def-unix-error  ELIBMAX         82     "Attempting to link in too many shared libraries")
+(def-unix-error  ELIBEXEC        83     "Cannot exec a shared library directly")
+(def-unix-error  EILSEQ          84     "Illegal byte sequence")
+(def-unix-error  ERESTART        85     "Interrupted system call should be restarted ")
+(def-unix-error  ESTRPIPE        86     "Streams pipe error")
+(def-unix-error  EUSERS          87     "Too many users")
+(def-unix-error  ENOTSOCK        88     "Socket operation on non-socket")
+(def-unix-error  EDESTADDRREQ    89     "Destination address required")
+(def-unix-error  EMSGSIZE        90     "Message too long")
+(def-unix-error  EPROTOTYPE      91     "Protocol wrong type for socket")
+(def-unix-error  ENOPROTOOPT     92     "Protocol not available")
+(def-unix-error  EPROTONOSUPPORT 93     "Protocol not supported")
+(def-unix-error  ESOCKTNOSUPPORT 94     "Socket type not supported")
+(def-unix-error  EOPNOTSUPP      95     "Operation not supported on transport endpoint")
+(def-unix-error  EPFNOSUPPORT    96     "Protocol family not supported")
+(def-unix-error  EAFNOSUPPORT    97     "Address family not supported by protocol")
+(def-unix-error  EADDRINUSE      98     "Address already in use")
+(def-unix-error  EADDRNOTAVAIL   99     "Cannot assign requested address")
+(def-unix-error  ENETDOWN        100    "Network is down")
+(def-unix-error  ENETUNREACH     101    "Network is unreachable")
+(def-unix-error  ENETRESET       102    "Network dropped connection because of reset")
+(def-unix-error  ECONNABORTED    103    "Software caused connection abort")
+(def-unix-error  ECONNRESET      104    "Connection reset by peer")
+(def-unix-error  ENOBUFS         105    "No buffer space available")
+(def-unix-error  EISCONN         106    "Transport endpoint is already connected")
+(def-unix-error  ENOTCONN        107    "Transport endpoint is not connected")
+(def-unix-error  ESHUTDOWN       108    "Cannot send after transport endpoint shutdown")
+(def-unix-error  ETOOMANYREFS    109    "Too many references: cannot splice")
+(def-unix-error  ETIMEDOUT       110    "Connection timed out")
+(def-unix-error  ECONNREFUSED    111    "Connection refused")
+(def-unix-error  EHOSTDOWN       112    "Host is down")
+(def-unix-error  EHOSTUNREACH    113    "No route to host")
+(def-unix-error  EALREADY        114    "Operation already in progress")
+(def-unix-error  EINPROGRESS     115    "Operation now in progress")
+(def-unix-error  ESTALE          116    "Stale NFS file handle")
+(def-unix-error  EUCLEAN         117    "Structure needs cleaning")
+(def-unix-error  ENOTNAM         118    "Not a XENIX named type file")
+(def-unix-error  ENAVAIL         119    "No XENIX semaphores available")
+(def-unix-error  EISNAM          120    "Is a named type file")
+(def-unix-error  EREMOTEIO       121    "Remote I/O error")
+(def-unix-error  EDQUOT          122    "Quota exceeded")
+)
+
 ;;;
 ;;; And now for something completely different ...
 (emit-unix-errors)
@@ -763,27 +948,35 @@
 (defconstant F-SETFD    2  "Set file desc. flags")
 (defconstant F-GETFL    3  "Get file flags")
 (defconstant F-SETFL    4  "Set file flags")
-#-svr4
+#-(or linux svr4)
 (defconstant F-GETOWN   5  "Get owner")
 #+svr4
 (defconstant F-GETOWN   23  "Get owner")
-#-svr4
+#+linux
+(defconstant F-GETLK    5   "Get lock")
+#-(or linux svr4)
 (defconstant F-SETOWN   6  "Set owner")
 #+svr4
 (defconstant F-SETOWN   24  "Set owner")
-
+#+linux 
+(defconstant F-SETLK    6   "Set lock")
+#+linux
+(defconstant F-SETLKW   7   "Set lock, wait for release")
+#+linux
+(defconstant F-SETOWN   8  "Set owner")
 
 ;;; File flags for F-GETFL and F-SETFL:
 
 (defconstant FNDELAY  #-osf1 #o0004 #+osf1 #o100000 "Non-blocking reads")
-(defconstant FAPPEND  #o0010   "Append on each write")
-(defconstant FASYNC   #-svr4 #o0100 #+svr4 #o10000
+(defconstant FAPPEND  #-linux #o0010 #+linux #o2000  "Append on each write") 
+(defconstant FASYNC   #-(or linux svr4) #o0100 #+svr4 #o10000 #+linux #o20000
   "Signal pgrp when data ready")
-(defconstant FCREAT   #-(or hpux svr4) #o1000 #+(or hpux svr4) #o0400
-  "Create if nonexistant")
-(defconstant FTRUNC   #-(or hpux svr4) #o2000 #+(or hpux svr4) #o1000
+;; doesn't exist in Linux ;-(
+#-linux (defconstant FCREAT   #-(or hpux svr4) #o1000 #+(or hpux svr4) #o0400
+   "Create if nonexistant")
+#-linux (defconstant FTRUNC   #-(or hpux svr4) #o2000 #+(or hpux svr4) #o1000
   "Truncate to zero length")
-(defconstant FEXCL    #-(or hpux svr4) #o4000 #+(or hpux svr4) #o2000
+#-linux (defconstant FEXCL    #-(or hpux svr4) #o4000 #+(or hpux svr4) #o2000
   "Error if already created")
 
 (defun unix-fcntl (fd cmd arg)
@@ -837,7 +1030,11 @@
   (declare (type unix-fd fd)
 	   (type (unsigned-byte 32) offset)
 	   (type (integer 0 2) whence))
-  (int-syscall ("lseek" int off-t int) fd offset whence))
+  #-(and x86 freebsd) (int-syscall ("lseek" int off-t int) fd offset whence)
+  ;; Need a 64-bit return value type for this. TBD. For now,
+  ;; don't use this with any 2G+ partitions.
+  #+(and freebsd x86) (int-syscall ("lseek" int unsigned-long unsigned-long int)
+		     fd offset 0 whence ))
 
 ;;; Unix-mkdir accepts a name and a mode and attempts to create the
 ;;; corresponding directory with mode mode.
@@ -856,14 +1053,20 @@
 (defconstant o_rdonly 0 "Read-only flag.") 
 (defconstant o_wronly 1 "Write-only flag.")
 (defconstant o_rdwr 2   "Read-write flag.")
-(defconstant o_append #o10   "Append flag.")
-#+svr4 (defconstant o_ndelay 4 "Non-blocking I/O")
-#+(or hpux svr4)
+#+(or linux svr4 freebsd)
+(defconstant o_ndelay #-linux 4 #+linux #o4000 "Non-blocking I/O")
+(defconstant o_append #-linux #o10 #+linux #o2000   "Append flag.")
+#+(or hpux svr4 linux)
 (progn
-  (defconstant o_creat #o400  "Create if nonexistant flag.") 
+  (defconstant o_creat #-linux #o400 #+linux #o100 "Create if nonexistant flag.") 
   (defconstant o_trunc #o1000  "Truncate flag.")
-  (defconstant o_excl #o2000  "Error if already exists."))
-#-(or hpux svr4)
+  (defconstant o_excl #-linux #o2000 #+linux #o200 "Error if already exists."))
+#+linux
+(progn
+   (defconstant o_noctty #o400 "Don't become controlling terminal")
+   (defconstant o_sync #o10000 "Synchronous writes (on ext2)"))
+
+#-(or hpux svr4 linux)
 (progn
   (defconstant o_creat #o1000  "Create if nonexistant flag.") 
   (defconstant o_trunc #o2000  "Truncate flag.")
@@ -1126,18 +1329,19 @@
 
 
 (defconstant terminal-speeds
-  '#(nil 50 75 110 nil 150 200 300 600 1200 1800 2400 4800 9600 nil nil))
+  '#(0 50 75 110 134 150 200 300 600 1200 1800 2400 4800 9600 nil nil
+       57600 115200))
 
-(defconstant tty-raw #o40)
-(defconstant tty-crmod #o20)
-(defconstant tty-echo #o10)
-(defconstant tty-lcase #o4)
-#-hpux
-(defconstant tty-cbreak #o2)
+(defconstant tty-raw #-linux #o40 #+linux 1)
+(defconstant tty-crmod #-linux #o20 #+linux 4)
+(defconstant tty-echo #o10) ;; 8
+(defconstant tty-lcase #-linux #o4 #+linux 2)
 #-hpux
+(defconstant tty-cbreak #-linux #o2 #+linux 64)
+#-(or linux hpux)
 (defconstant tty-tandem #o1)
 
-#+(or hpux svr4)
+#+(or hpux svr4 linux)
 (progn
   (defconstant tty-icanon #o2)
   (defconstant tty-icrnl #o400)
@@ -1147,6 +1351,16 @@
   (defconstant vintr 0)
   (defconstant vquit 1))
 
+#+freebsd
+(progn
+  (defconstant tty-icanon #x100)
+  (defconstant tty-icrnl #x100)
+  (defconstant tty-ocrnl #x2)
+  (defconstant tty-ixon #x200)
+  (defconstant veof 0)
+  (defconstant vintr 8)
+  (defconstant vquit 9))
+
 #+hpux
 (progn
   (defconstant vdsusp 21)
@@ -1157,26 +1371,38 @@
   (defconstant vtime 12)
   (defconstant tcsaflush 2))
 
-#+svr4
+#+(or linux svr4)
 (progn
-  (defconstant vdsusp 11)
+  #-linux (defconstant vdsusp 11)
   (defconstant vstart 8)
   (defconstant vstop 9)
   (defconstant vsusp 10)
-  (defconstant vmin 4)
+  (defconstant vmin #-linux 4 #+linux 6)
   (defconstant vtime 5)
-  (defconstant tcsaflush #x5410))
+  (defconstant tcsaflush #-linux #x5410 #+linux 2))
+
+#+freebsd
+(progn
+  (defconstant vdsusp 11)
+  (defconstant vstart 12)
+  (defconstant vstop 13)
+  (defconstant vsusp 10)
+  (defconstant vmin 16)
+  (defconstant vtime 17)
+  (defconstant tcsaflush #x2))
 
 
 (eval-when (compile load eval)
 
-(defconstant iocparm-mask #x7f)
-(defconstant ioc_void #x20000000)
-(defconstant ioc_out #x40000000)
-(defconstant ioc_in #x80000000)
-(defconstant ioc_inout (logior ioc_in ioc_out))
+#-(or svr4 linux)
+(progn
+ (defconstant iocparm-mask #x7f) ; Freebsd: #x1fff ?
+ (defconstant ioc_void #x20000000)
+ (defconstant ioc_out #x40000000)
+ (defconstant ioc_in #x80000000)
+ (defconstant ioc_inout (logior ioc_in ioc_out)))
 
-#-svr4
+#-(or linux svr4)
 (defmacro define-ioctl-command (name dev cmd arg &optional (parm-type :void))
   (let* ((ptype (ecase parm-type
 		  (:void ioc_void)
@@ -1193,7 +1419,7 @@
     `(eval-when (eval load compile)
        (defconstant ,name ,code))))
 
-#+svr4
+#+(or linux svr4)
 (defmacro define-ioctl-command (name dev cmd arg &optional (parm-type :void))
   (declare (ignore dev arg parm-type))
   `(eval-when (eval load compile)
@@ -1203,21 +1429,21 @@
 
 ;;; TTY ioctl commands.
 
-(define-ioctl-command TIOCGETP #\t 8 (struct sgttyb) :out)
-(define-ioctl-command TIOCSETP #\t 9 (struct sgttyb) :in)
-(define-ioctl-command TIOCFLUSH #\t 16 int :in)
-(define-ioctl-command TIOCSETC #\t 17 (struct tchars) :in)
-(define-ioctl-command TIOCGETC #\t 18 (struct tchars) :out)
+(define-ioctl-command TIOCGETP #\t #-linux 8 #+linux #x5481 (struct sgttyb) :out)
+(define-ioctl-command TIOCSETP #\t #-linux 9 #+linux #x5482 (struct sgttyb) :in)
+(define-ioctl-command TIOCFLUSH #\t #-linux 16 #+linux #x5489 int :in)
+(define-ioctl-command TIOCSETC #\t #-linux 17 #+linux #x5484 (struct tchars) :in)
+(define-ioctl-command TIOCGETC #\t #-linux 18 #+linux #x5483 (struct tchars) :out)
 (define-ioctl-command TIOCGWINSZ #\t #-hpux 104 #+hpux 107 (struct winsize)
   :out)
 (define-ioctl-command TIOCSWINSZ #\t #-hpux 103 #+hpux 106 (struct winsize)
   :in)
 
-(define-ioctl-command TIOCNOTTY #\t 113 nil :void)
+(define-ioctl-command TIOCNOTTY #\t #-linux 113 #+linux #x5422 nil :void)
 #-hpux
 (progn
-  (define-ioctl-command TIOCSLTC #\t 117 (struct ltchars) :in)
-  (define-ioctl-command TIOCGLTC #\t 116 (struct ltchars) :out)
+  (define-ioctl-command TIOCSLTC #\t #-linux 117 #+linux #x5484 (struct ltchars) :in)
+  (define-ioctl-command TIOCGLTC #\t #-linux 116 #+linux #x5485 (struct ltchars) :out)
   (define-ioctl-command TIOCSPGRP #\t #-svr4 118 #+svr4 21 int :in)
   (define-ioctl-command TIOCGPGRP #\t #-svr4 119 #+svr4 20 int :out))
 #+hpux
@@ -1229,7 +1455,7 @@
   (define-ioctl-command TIOCSIGSEND #\t 93 nil))
 
 ;;; File ioctl commands.
-(define-ioctl-command FIONREAD #\f 127 int :out)
+(define-ioctl-command FIONREAD #\f #-linux 127 #+linux #x541B int :out)
 
 
 (defun unix-ioctl (fd cmd arg)
@@ -1240,13 +1466,13 @@
 	   (type (unsigned-byte 32) cmd))
   (void-syscall ("ioctl" int unsigned-int (* char)) fd cmd arg))
 
-#+(or svr4 hpux)
+#+(or svr4 hpux freebsd linux)
 (defun unix-tcgetattr (fd termios)
   "Get terminal attributes."
   (declare (type unix-fd fd))
   (void-syscall ("tcgetattr" int (* (struct termios))) fd termios))
 
-#+(or svr4 hpux)
+#+(or svr4 hpux freebsd linux)
 (defun unix-tcsetattr (fd opt termios)
   "Set terminal attributes."
   (declare (type unix-fd fd))
@@ -1312,10 +1538,13 @@
 
 ;;; Socket options.
 
-#+hpux
+#+(or hpux freebsd)
 (define-ioctl-command SIOCSPGRP #\s 8 int :in)
 
-#+hpux
+#+linux
+(define-ioctl-command SIOCSPGRP #\s #x8904 int :in)
+
+#+(or hpux freebsd linux)
 (defun siocspgrp (fd pgrp)
   "Set the socket process-group for the unix file-descriptor FD to PGRP."
   (alien:with-alien ((alien-pgrp c-call:int pgrp))
@@ -1344,12 +1573,15 @@
 	   (slot ,buf 'st-gid)
 	   (slot ,buf 'st-rdev)
 	   (slot ,buf 'st-size)
-	   #-svr4 (slot ,buf 'st-atime)
-	   #+svr4 (slot (slot ,buf 'st-atime) 'tv-sec)
-	   #-svr4 (slot ,buf 'st-mtime)
-	   #+svr4 (slot (slot ,buf 'st-mtime) 'tv-sec)
-	   #-svr4 (slot ,buf 'st-ctime)
-	   #+svr4 (slot (slot ,buf 'st-ctime) 'tv-sec)
+	   #-(or svr4 FreeBSD) (slot ,buf 'st-atime)
+	   #+svr4    (slot (slot ,buf 'st-atime) 'tv-sec)
+           #+FreeBSD (slot (slot ,buf 'st-atime) 'ts-sec)
+	   #-(or svr4 FreeBSD)(slot ,buf 'st-mtime)
+	   #+svr4   (slot (slot ,buf 'st-mtime) 'tv-sec)
+           #+FreeBSD(slot (slot ,buf 'st-mtime) 'ts-sec)
+	   #-(or svr4 FreeBSD) (slot ,buf 'st-ctime)
+	   #+svr4   (slot (slot ,buf 'st-ctime) 'tv-sec)
+           #+FreeBSD(slot (slot ,buf 'st-ctime) 'ts-sec)
 	   (slot ,buf 'st-blksize)
 	   (slot ,buf 'st-blocks)))
 
@@ -1413,7 +1645,7 @@
    child processes (rusage_children).  NIL and an error number
    is returned if the call fails."
   (with-alien ((usage (struct rusage)))
-    (syscall* ("getrusage" int (* (struct rusage)))
+    (syscall ("getrusage" int (* (struct rusage)))
 	      (values t
 		      (+ (* (slot (slot usage 'ru-utime) 'tv-sec) 1000000)
 			 (slot (slot usage 'ru-utime) 'tv-usec))
@@ -1437,7 +1669,7 @@
 
 ;; Requires call to tzset() in main.
 ;; Don't use this now: we 
-#+svr4
+#+(or linux svr4)
 (progn
     (def-alien-variable ("daylight" unix-daylight) int)
     (def-alien-variable ("timezone" unix-timezone) time-t)
@@ -1618,6 +1850,7 @@
       (t
        (values nil enotdir)))))
 
+#-bsd
 (defun read-dir (dir)
   (declare (type directory dir))
   (let ((daddr (alien-funcall (extern-alien "readdir"
@@ -1628,7 +1861,7 @@
     (if (zerop (sap-int daddr))
 	nil
 	(with-alien ((direct (* (struct direct)) daddr))
-	  #-svr4
+	  #-(or linux svr4)
 	  (let ((nlen (slot direct 'd-namlen))
 		(ino (slot direct 'd-ino)))
 	    (declare (type (unsigned-byte 16) nlen))
@@ -1638,9 +1871,31 @@
 	       string (* vm:vector-data-offset vm:word-bits)
 	       (* nlen vm:byte-bits))
 	      (values string ino)))
-	  #+svr4
+	  #+(or linux svr4)
 	  (values (cast (slot direct 'd-name) c-string)
 		  (slot direct 'd-ino))))))
+#+bsd
+(defun read-dir (dir)
+  (declare (type directory dir))
+  (let ((daddr (alien-funcall (extern-alien "readdir"
+					    (function system-area-pointer
+						      system-area-pointer))
+			      (directory-dir-struct dir))))
+    (declare (type system-area-pointer daddr))
+    (if (zerop (sap-int daddr))
+	nil
+	(with-alien ((direct (* (struct direct)) daddr))
+	  (let ((nlen (slot direct 'd-namlen))
+		(fino (slot direct 'd-fileno)))
+	    (declare (type (unsigned-byte 8) nlen)
+		     (type (unsigned-byte 32) fino))
+	    (let ((string (make-string nlen)))
+	      (kernel:copy-from-system-area
+	       (alien-sap (addr (slot direct 'd-name))) 0
+	       string (* vm:vector-data-offset vm:word-bits)
+	       (* nlen vm:byte-bits))
+	      (values string fino)))))))
+
 
 (defun close-dir (dir)
   (declare (type directory dir))
diff --git a/code/x86-vm.lisp b/code/x86-vm.lisp
new file mode 100644
index 000000000..d32f7fb70
--- /dev/null
+++ b/code/x86-vm.lisp
@@ -0,0 +1,388 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: X86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+;(ext:file-comment
+;  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/x86-vm.lisp,v 1.1 1997/01/18 14:30:50 ram Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the X86 specific runtime stuff.
+;;;
+
+(in-package :x86)
+(use-package "SYSTEM")
+(use-package "ALIEN")
+(use-package "C-CALL")
+(use-package "UNIX")
+(use-package :kernel)
+
+(export '(fixup-code-object internal-error-arguments
+	  sigcontext-program-counter sigcontext-register
+	  sigcontext-float-register sigcontext-floating-point-modes
+	  extern-alien-name sanctify-for-execution
+	  alternate-get-global-address))
+
+
+;;;; The sigcontext structure.
+;;;; Add machine specific features to *features*
+
+(pushnew :x86 *features*)
+
+
+
+#+linux
+(def-alien-type nil 
+  (struct fpreg
+          (significand (array unsigned-short 4))
+          (exponent unsigned-short)))
+#+linux
+(def-alien-type  nil
+   (struct fpstate
+        (cw  unsigned-long)
+        (sw  unsigned-long)
+        (tag  unsigned-long)
+        (ipoff  unsigned-long)
+        (cssel  unsigned-long)
+        (dataoff  unsigned-long)
+        (datasel unsigned-long)
+        (fpreg (array (struct fpreg) 8))
+        (status unsigned-long)))
+
+;;; for FreeBSD
+#+freebsd
+(def-alien-type sigcontext
+    (struct nil
+	(sc-onstack unsigned-int)
+	(sc-mask    unsigned-int)
+	(sc-sp      unsigned-int)
+	(sc-fp	    unsigned-int)
+	(sc-isp	    unsigned-int)
+	(sc-pc	    unsigned-int)
+	(sc-efl     unsigned-int)		; sc_ps
+	(sc-es	    unsigned-int)
+	(sc-ds	    unsigned-int)
+	(sc-cs	    unsigned-int)
+	(sc-ss	    unsigned-int)
+	(sc-edi	    unsigned-int)
+	(sc-esi	    unsigned-int)
+	(sc-ebx	    unsigned-int)
+	(sc-edx	    unsigned-int)
+	(sc-ecx	    unsigned-int)
+	(sc-eax	    unsigned-int)))
+
+;; For Linux...
+#+linux
+(def-alien-type sigcontext
+    (struct nil
+	(gs  unsigned-short)
+	(__gsh   unsigned-short)
+	(fs      unsigned-short)
+	(__fsh   unsigned-short)
+	(sc-es   unsigned-short)
+	(__esh   unsigned-short)
+	(sc-ds   unsigned-short)
+	(__dsh   unsigned-short)
+	(sc-edi  unsigned-long)
+	(sc-esi  unsigned-long)
+	(ebp     unsigned-long)
+	(sc-sp   unsigned-long)
+	(sc-ebx  unsigned-long)
+	(sc-edx  unsigned-long)
+	(sc-ecx  unsigned-long)
+	(sc-eax  unsigned-long)
+	(trapno  unsigned-long)
+	(err     unsigned-long)
+	(sc-pc   unsigned-long)
+	(sc-cs   unsigned-short)
+	(__csh   unsigned-short)
+	(sc-efl  unsigned-long)
+	(esp_at_signal   unsigned-long)
+	(sc-ss   unsigned-short)
+	(__ssh   unsigned-short)
+;       (fpstate   unsigned-long) ;; fpstate struct pointer
+	(fpstate (* (struct fpstate)))
+	(sc-mask unsigned-long)
+	(cr2     unsigned-long)))
+
+
+
+;;;; MACHINE-TYPE and MACHINE-VERSION
+
+#-cross-compiler
+(defun machine-type ()
+  "Returns a string describing the type of the local machine."
+  "X86")
+
+
+#-cross-compiler
+(defun machine-version ()
+  "Returns a string describing the version of the local machine."
+  "X86")
+
+
+
+;;; FIXUP-CODE-OBJECT -- Interface
+;;; This gets called by LOAD to resolve newly positioned objects
+;;; with things (like code instructions) that have to refer to them.
+
+(defun fixup-code-object (code offset fixup kind)
+  (declare (type index offset))
+  (system:without-gcing
+   (let ((sap (truly-the system-area-pointer (c::code-instructions code))))
+     (unless (member kind '(:absolute :relative))
+       (error "Unknown code-object-fixup kind ~s." kind))
+     (ecase kind
+       (:absolute
+	;; word at sap + offset contains a value to be replaced by
+	;; adding that value to fixup.
+	(setf (sap-ref-32 sap offset)
+	      (+ fixup (sap-ref-32 sap offset))))
+       (:relative
+	;; fixup is actual address wanted. replace word with value
+	;; to add to that loc to get there.
+	;; (format t "x86-fixup ~a ~x ~x ~a~&" code offset fixup kind)
+	(let* ((loc-sap (+ (sap-int sap) offset))
+	       (rel-val (- fixup loc-sap 4)))
+	  (declare (type (unsigned-byte 32) loc-sap)
+		   (type (signed-byte 32) rel-val))
+	  ;;(format t "sap ~x ~x ~x~&" (sap-int sap) loc-sap rel-val)
+	  (setf (sap-ref-32 sap offset)  rel-val)) ))))
+  nil)
+
+
+
+;;;; Internal-error-arguments.
+
+;;; INTERNAL-ERROR-ARGUMENTS -- interface.
+;;;
+;;; Given the sigcontext, extract the internal error arguments from the
+;;; instruction stream.
+;;; 
+(defun internal-error-arguments (scp)
+  (declare (type (alien (* sigcontext)) scp))
+  (with-alien ((scp (* sigcontext) scp))
+    (let ((pc (int-sap (slot scp 'sc-pc))))
+      (declare (type system-area-pointer pc))
+      ;; using INT3 the pc is .. INT3 <here> code length bytes...
+      (let* ((length (sap-ref-8 pc 1))
+	     (vector (make-array length :element-type '(unsigned-byte 8))))
+	(declare (type (unsigned-byte 8) length)
+		 (type (simple-array (unsigned-byte 8) (*)) vector))
+	(copy-from-system-area pc (* vm:byte-bits 2)
+			       vector (* vm:word-bits
+					 vm:vector-data-offset)
+			       (* length vm:byte-bits))
+	(let* ((index 0)
+	       (error-number (c::read-var-integer vector index)))
+	  (collect ((sc-offsets))
+	    (loop
+	      (when (>= index length)
+		(return))
+	      (sc-offsets (c::read-var-integer vector index)))
+	    (values error-number (sc-offsets))))))))
+
+
+;;;; Sigcontext access functions.
+
+;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface.
+;;;
+(defun sigcontext-program-counter (scp)
+  (declare (type (alien (* sigcontext)) scp))
+  (with-alien ((scp (* sigcontext) scp))
+    (int-sap (slot scp 'sc-pc))))
+
+;;; SIGCONTEXT-REGISTER -- Interface.
+;;;
+;;; An escape register saves the value of a register for a frame that someone
+;;; interrupts.  
+;;;
+
+(defun sigcontext-register (scp index)
+  (declare (type (alien (* sigcontext)) scp))
+  (with-alien ((scp (* sigcontext) scp))
+    (case index				; ugly -- I know.
+      (#.eax-offset (slot scp 'sc-eax))
+      (#.ecx-offset (slot scp 'sc-ecx))
+      (#.edx-offset (slot scp 'sc-edx))
+      (#.ebx-offset (slot scp 'sc-ebx))
+      (#.esp-offset (slot scp 'sc-sp))
+#-linux      (#.ebp-offset (slot scp 'sc-fp))
+#+linux      (#.ebp-offset (slot scp 'ebp))
+      (#.esi-offset (slot scp 'sc-esi))
+      (#.edi-offset (slot scp 'sc-edi)))))
+
+
+(defun %set-sigcontext-register (scp index new)
+  (declare (type (alien (* sigcontext)) scp))
+  (with-alien ((scp (* sigcontext) scp))
+    (case index
+      (#.eax-offset (setf (slot scp 'sc-eax) new))
+      (#.ecx-offset (setf (slot scp 'sc-ecx) new))
+      (#.edx-offset (setf (slot scp 'sc-edx) new))
+      (#.ebx-offset (setf (slot scp 'sc-ebx) new))
+      (#.esp-offset (setf (slot scp 'sc-sp)  new))
+#-linux      (#.ebp-offset (setf (slot scp 'sc-fp)  new))
+#+linux      (#.ebp-offset (setf (slot scp 'ebp)  new))
+      (#.esi-offset (setf (slot scp 'sc-esi) new))
+      (#.edi-offset (setf (slot scp 'sc-edi) new))))
+  new)
+
+(defsetf sigcontext-register %set-sigcontext-register)
+
+
+;;; SIGCONTEXT-FLOAT-REGISTER  --  Interface
+;;;
+;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register.
+;;; Format is the type of float to return.
+;;; XXX
+#-linux
+(defun sigcontext-float-register (scp index format)
+  (declare (type (alien (* sigcontext)) scp))
+  (with-alien ((scp (* sigcontext) scp))
+    ;; fp regs not in sigcontext -- need new vop or c support
+    (let ((sap #+nil (alien-sap (slot scp 'sc-fpregs))))
+      (declare (ignore sap))
+      index
+      (ecase format
+	(single-float 0s0
+	 #+nil (system:sap-ref-single sap (* index vm:word-bytes)))
+	(double-float 0d0
+	 #+nil(system:sap-ref-double sap (* index vm:word-bytes)))))))
+
+#+linux
+(defun sigcontext-float-register (scp index format)
+  (declare (type (alien (* sigcontext)) scp))
+  (with-alien ((scp (* sigcontext) scp))
+    ;; fp regs in sigcontext !!!
+    (let ((reg-sap (alien-sap (deref (slot (deref (slot scp 'fpstate) 0)
+					    'fpreg)
+				     index))))
+      (ecase format
+        (single-float
+          (system:sap-ref-single reg-sap 0))
+        (double-float 
+          (system:sap-ref-double reg-sap 0))))))
+
+;;;
+#-linux
+(defun %set-sigcontext-float-register (scp index format new-value)
+  (declare (type (alien (* sigcontext)) scp))
+  scp index format new-value
+  #+nil
+  (with-alien ((scp (* sigcontext) scp))
+    (let ((sap (alien-sap (slot scp 'fpregs))))
+      (ecase format
+	(single-float
+	 (setf (sap-ref-single sap (* index vm:word-bytes)) new-value))
+	(double-float
+	 (setf (sap-ref-double sap (* index vm:word-bytes)) new-value))))))
+#+linux
+(defun %set-sigcontext-float-register (scp index format new-value)
+  (declare (type (alien (* sigcontext)) scp))
+  (with-alien ((scp (* sigcontext) scp))
+    (let ((reg-sap (alien-sap (deref (slot (deref (slot scp 'fpstate) 0)
+					    'fpreg)
+				     index))))
+      (ecase format
+        (single-float
+         (setf (system:sap-ref-single reg-sap 0) new-value))
+        (double-float
+         (setf (system:sap-ref-double reg-sap 0)new-value))))))
+
+;;;
+
+(defsetf sigcontext-float-register %set-sigcontext-float-register)
+
+;;; SIGCONTEXT-FLOATING-POINT-MODES  --  Interface
+;;;
+;;;    Given a sigcontext pointer, return the floating point modes word in the
+;;; same format as returned by FLOATING-POINT-MODES.
+;;;
+
+#+FreeBSD
+(defun sigcontext-floating-point-modes (scp)
+  (declare (type (alien (* sigcontext)) scp)
+	   (ignore scp))
+  ;; This is broken until some future release of FreeBSD!!!
+  (floating-point-modes))
+  
+#+linux
+(defun sigcontext-floating-point-modes (scp)
+  (declare (type (alien (* sigcontext)) scp))
+  (let ((cw (slot (deref (slot scp 'fpstate) 0) 'cw))
+	(sw (slot (deref (slot scp 'fpstate) 0) 'sw)))
+    ;;(format t "cw = ~4x~%sw = ~4x~%" cw sw)
+    ;; NOT TESTED -- clear sticky bits to clear interrupt condition
+    (setf (slot (deref (slot scp 'fpstate) 0) 'sw) (logandc2 sw #x3f))
+    ;;(format t "new sw = ~x~%" (slot (deref (slot scp 'fpstate) 0) 'sw))
+    ;; simulate floating-point-modes VOP
+    (logior (ash (logand sw #xffff) 16) (logxor (logand cw #xffff) #x3f))))
+
+
+;;; EXTERN-ALIEN-NAME -- interface.
+;;;
+;;; The loader uses this to convert alien names to the form they occure in
+;;; the symbol table (for example, prepending an underscore).
+;;;
+;;; On the x86 under FreeBSD, we prepend an underscore. If this is not
+;;; done under Linux then this is the place to make the change.
+;;;
+(defun extern-alien-name (name)
+  (declare (type simple-string name))
+  (lisp:concatenate 'string #+linux "" #-linux "_" name))
+
+;;; This used to live in foreign.lisp but it gets loaded too late
+;;; to be useful. This gets used by the loader to map lisp foreign
+;;; symbol names to the OS's version of it. This was added for the
+;;; Linux port -- maybe it makes the above extern-alien-name
+;;; obsolete?
+(defun system:alternate-get-global-address(symbol)
+  (declare (type simple-string symbol))
+  (let ((namex symbol)
+        (table lisp::*foreign-symbols*)) ; defined in load.lisp
+    (cond ((gethash namex table nil))
+#+linux   ((gethash (concatenate 'string "PVE_stub_" namex) table nil))
+#+linux   ((gethash (concatenate 'string "" namex) table nil)) ; Linux
+#+freebsd ((gethash (concatenate 'string "_" namex) table nil)); FreeBSD
+          ((gethash (concatenate 'string "__" namex) table nil))
+          ((gethash (concatenate 'string "__libc_" namex) table nil))
+          (t (progn (format t "Error: can't be in alt-get-gl-addr ~a" namex)
+	;; returning 0 is VERY dangerous!
+		0)))))
+
+
+
+;;; SANCTIFY-FOR-EXECUTION -- Interface.
+;;;
+;;; Do whatever is necessary to make the given code component executable.
+;;; On the sparc, we don't need to do anything, because the i and d caches
+;;; are unified.
+;;; 
+(defun sanctify-for-execution (component)
+  (declare (ignore component))
+  nil)
+ 
+;;; FLOAT-WAIT
+;;;
+;;; This is used in error.lisp to insure floating-point  exceptions
+;;; are properly trapped. The compiler translates this to a VOP.
+;;; Note: if you are compiling this from an old version you may need
+;;; to disable this until the float-wait VOP is entrenched.
+(defun float-wait()
+  (float-wait))
+
+;;; FLOAT CONSTANTS
+;;;
+;;; These are used by the FP move-from-{single|double} VOPs
+;;; rather than the i387 load constant instructions to avoid
+;;; consing in some cases.
+
+(defvar *fp-constant-0s0* 0s0)
+(defvar *fp-constant-0d0* 0d0)
+(defvar *fp-constant-1s0* 1s0)
+(defvar *fp-constant-1d0* 1d0)
diff --git a/compiler/aliencomp.lisp b/compiler/aliencomp.lisp
index 955ecd7c9..f3ba012bb 100644
--- a/compiler/aliencomp.lisp
+++ b/compiler/aliencomp.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/aliencomp.lisp,v 1.22 1994/10/31 04:27:28 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/aliencomp.lisp,v 1.23 1997/01/18 14:31:28 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -679,15 +679,21 @@
 	(let* ((arg (pop args))
 	       (sc (tn-sc tn))
 	       (scn (sc-number sc))
-	       (temp-tn (make-representation-tn (tn-primitive-type tn) scn))
+	       (temp-tn
+		(unless (backend-featurep :x86)
+		  (make-representation-tn (tn-primitive-type tn) scn)))
 	       (move-arg-vops (svref (sc-move-arg-vops sc) scn)))
 	  (assert arg)
 	  (assert (= (length move-arg-vops) 1) ()
 		  "No unique move-arg-vop for moves in SC ~S."
 		  (sc-name sc))
-	  (emit-move call block (continuation-tn call block arg) temp-tn)
-	  (emit-move-arg-template call block (first move-arg-vops)
-				  temp-tn nsp tn)))
+	  (if (backend-featurep :x86)
+	      (emit-move-arg-template call block (first move-arg-vops)
+				      (continuation-tn call block arg) nsp tn)
+	    (progn
+	      (emit-move call block (continuation-tn call block arg) temp-tn)
+	      (emit-move-arg-template call block (first move-arg-vops)
+				      temp-tn nsp tn)))))
       (assert (null args))
       (unless (listp result-tns)
 	(setf result-tns (list result-tns)))
diff --git a/compiler/constraint.lisp b/compiler/constraint.lisp
index e75761d33..a331e569f 100644
--- a/compiler/constraint.lisp
+++ b/compiler/constraint.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/constraint.lisp,v 1.15 1994/10/31 04:27:28 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/constraint.lisp,v 1.16 1997/01/18 14:31:31 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -305,6 +305,60 @@
       res)))
 
   
+;;; FLOAT-TYPE-P  --  Internal
+;;;
+;;;    Return true if X is a float NUMERIC-TYPE.
+;;;
+(defun float-type-p (x)
+  (declare (type ctype x))
+  (and (numeric-type-p x)
+       (eq (numeric-type-class x) 'float)
+       (eq (numeric-type-complexp x) :real)))
+
+;;; CONSTRAIN-FLOAT-TYPE  --  Internal
+;;;
+;;; Exactly the same as CONSTRAIN-INTEGER-TYPE, but for float numbers.
+;;;
+(defun constrain-float-type (x y greater or-equal)
+  (declare (type numeric-type x y))
+  (flet ((exclude (x)
+	   (cond ((not x) nil)
+		 (or-equal x)
+		 (greater
+		  (if (consp x)
+		      (car x)
+		      x))
+		 (t
+		  (if (consp x)
+		      x
+		      (list x)))))
+	 (bound (x)
+	   (if greater (numeric-type-low x) (numeric-type-high x))))
+    #+nil
+    (format t "~%constraint-float-type:~%  ~s~%  ~s~%  ~s~%  ~s~%"
+	    x y greater or-equal)
+    (let* ((x-bound (bound x))
+	   (y-bound (exclude (bound y)))
+	   (new-bound (cond ((not x-bound)
+			     y-bound)
+			    ((not y-bound)
+			     x-bound)
+			    (greater
+			     (max-bound x-bound y-bound))
+			    (t
+			     (min-bound x-bound y-bound))))
+	   (res (copy-numeric-type x)))
+      #+nil
+      (format t "x-bound, y-bound, new-bound = ~s, ~s, ~s~%"
+	      x-bound y-bound new-bound)
+      (if greater
+	  (setf (numeric-type-low res) new-bound)
+	  (setf (numeric-type-high res) new-bound))
+      #+nil
+      (format t "~&constrain-float-type returns ~s~%" res)
+      res)))
+
+  
 ;;; CONSTRAIN-REF-TYPE  --  Internal
 ;;;
 ;;;    Given the set of Constraints for a variable and the current set of
@@ -341,11 +395,18 @@
 		       (change-ref-leaf ref other)
 		       (when (constant-p other) (return)))))))
 	    ((< >)
-	     (when (and (integer-type-p res) (integer-type-p y))
-	       (let ((greater (eq kind '>)))
-		 (let ((greater (if not-p (not greater) greater)))
-		   (setq res
-			 (constrain-integer-type res y greater not-p)))))))))
+	     (cond ((and (integer-type-p res) (integer-type-p y))
+		    (let ((greater (eq kind '>)))
+		      (let ((greater (if not-p (not greater) greater)))
+			(setq res
+			      (constrain-integer-type res y greater not-p)))))
+		   #+constrain-float-type
+		   ((and (float-type-p res) (float-type-p y))
+		    (let ((greater (eq kind '>)))
+		      (let ((greater (if not-p (not greater) greater)))
+			(setq res
+			      (constrain-float-type res y greater not-p)))))
+		   )))))
       
       (let* ((cont (node-cont ref))
 	     (dest (continuation-dest cont)))
@@ -514,3 +575,4 @@
     (use-result-constraints block))
 
   (undefined-value))
+
diff --git a/compiler/float-tran.lisp b/compiler/float-tran.lisp
index 14a90785f..b4ffed819 100644
--- a/compiler/float-tran.lisp
+++ b/compiler/float-tran.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/float-tran.lisp,v 1.23 1994/10/31 04:27:28 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/float-tran.lisp,v 1.24 1997/01/18 14:31:35 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -36,17 +36,17 @@
 (deftransform %double-float ((n) (double-float) * :when :both)
   'n)
 
-(deftransform coerce ((n type)
-		      (* (constant-argument
-			  (member float short-float single-float)))
-		      * :when :both)
-  '(%single-float n))
-
-(deftransform coerce ((n type)
-		      (* (constant-argument
-			  (member double-float long-float)))
-		      * :when :both)
-  '(%double-float n))
+(deftransform coerce ((n type) (* *) * :when :both)
+  (unless (constant-continuation-p type)
+    (give-up))
+  `(the ,(continuation-value type)
+	,(let ( (tspec (specifier-type (continuation-value type))) )
+	   (cond ((csubtypep tspec (specifier-type 'double-float))	
+		  '(%double-float n))	
+		 ((csubtypep tspec (specifier-type 'float))
+		  '(%single-float n))
+		 (t
+		  (give-up))))))
 
 ;;; Not strictly float functions, but primarily useful on floats:
 ;;;
@@ -178,12 +178,88 @@
 (deftransform integer-decode-float ((x) (double-float) * :when :both)
   '(integer-decode-double-float x))
 
+#-x86
 (deftransform scale-float ((f ex) (single-float *) * :when :both)
   '(scale-single-float f ex))
 
+#-x86
 (deftransform scale-float ((f ex) (double-float *) * :when :both)
   '(scale-double-float f ex))
 
+#+x86
+(deftransform scale-float ((f ex) (single-float (signed-byte 32)) *)
+  '(coerce (%scalbn (coerce f 'double-float) ex) 'single-float))
+
+#+x86
+(deftransform scale-float ((f ex) (double-float (signed-byte 32)) *
+			   :when :both)
+  '(%scalbn f ex))
+
+;;; toy@rtp.ericsson.se:
+;;;
+;;; Optimizers for scale-float.  If the float has bounds, new bounds
+;;; are computed for the result, if possible.
+
+#+propagate-float-type
+(progn
+(macrolet
+    ((frob (name)
+       `(defoptimizer (,name derive-type) ((f ex))
+	 (flet ((scale-bound (x n)
+		  ;; We need to be a bit careful here and catch any
+		  ;; overflows that might occur.  We can ignore
+		  ;; underflows which become zeros.
+		  (set-bound
+		   (handler-case
+		       (scale-float (bound-value x) n)
+		     (floating-point-overflow ()
+		       nil))
+		   (consp x))))
+	   (let ((f-type (continuation-type f))
+		 (ex-type (continuation-type ex)))
+	     (when (and (numeric-type-p f-type)
+			(numeric-type-p ex-type))
+	       (let ((f-lo (numeric-type-low f-type))
+		     (f-hi (numeric-type-high f-type))
+		     (ex-lo (numeric-type-low ex-type))
+		     (ex-hi (numeric-type-high ex-type))
+		     (new-lo nil)
+		     (new-hi nil))
+		 (when (and f-hi ex-hi)
+		   (setf new-hi (scale-bound f-hi ex-hi)))
+		 (when (and f-lo ex-lo)
+		   (setf new-lo (scale-bound f-lo ex-lo)))
+		 (make-numeric-type :class (numeric-type-class f-type)
+				    :format (numeric-type-format f-type)
+				    :complexp :real
+				    :low new-lo
+				    :high new-hi))))))))
+  (frob scale-single-float)
+  (frob scale-double-float))
+	     
+;;; Defoptimizers for %single-float and %double-float.  This makes the
+;;; FLOAT function return the correct ranges if the input has some
+;;; defined range.  Quite useful if we want to convert some time of
+;;; bounded integer into a float.
+
+(macrolet ((frob (fun type)
+	     `(defoptimizer (,fun derive-type) ((num))
+	       (let ((num-type (continuation-type num)))
+		 (when (numeric-type-p num-type)
+		   ;; We are trying to float some number to a float
+		   ;; type. The result is obviously a float with the
+		   ;; same range as NUM.
+		   (make-numeric-type
+		    :class 'float
+		    :format ',type
+		    :low (numeric-type-low num-type)
+		    :high (numeric-type-high num-type)))))
+	     ))
+  (frob %single-float single-float)
+  (frob %double-float double-float))
+
+) ; end progn  
+  
 
 ;;;; Float contagion:
 
@@ -235,11 +311,13 @@
 
 ;;; Derive the result to be float for argument types in the appropriate domain.
 ;;;
-(dolist (stuff '((asin (real (-1.0) (1.0)))
-		 (acos (real (-1.0) (1.0)))
+#-propagate-fun-type
+(dolist (stuff '((asin (real -1.0 1.0))
+		 (acos (real -1.0 1.0))
 		 (acosh (real 1.0))
-		 (atanh (real (-1.0) (1.0)))
-		 (sqrt (real 0.0))))
+		 (atanh (real -1.0 1.0))
+		 (sqrt (real 0.0))
+		 ))
   (destructuring-bind (name type) stuff
     (let ((type (specifier-type type)))
       (setf (function-info-derive-type (function-info-or-lose name))
@@ -250,32 +328,72 @@
 				 type)
 		  (specifier-type 'float)))))))
 
+#-propagate-fun-type
 (defoptimizer (log derive-type) ((x &optional y))
   (when (and (csubtypep (continuation-type x)
-			(specifier-type '(real (0.0))))
+			(specifier-type '(real 0.0)))
 	     (or (null y)
 		 (csubtypep (continuation-type y)
-			    (specifier-type '(real (0.0))))))
+			    (specifier-type '(real 0.0)))))
     (specifier-type 'float)))
 
 
 ;;;; Irrational transforms:
 
-(defknown (%sin %cos %tan %asin %acos %atan %sinh %cosh %tanh %asinh
-		%acosh %atanh %exp %log %log10 %sqrt)
+(defknown (%tan %sinh %asinh %atanh %log %logb %log10 #+x86 %tan-quick)
 	  (double-float) double-float
   (movable foldable flushable))
 
-(defknown (%atan2 %pow %hypot)
-	  (double-float double-float) double-float
+(defknown (%sin %cos %tanh #+x86 %sin-quick #+x86 %cos-quick)
+    (double-float) (double-float -1.0d0 1.0d0)
+    (movable foldable flushable))
+
+(defknown (%asin %atan)
+    (double-float) (double-float #.(- (/ pi 2)) #.(/ pi 2))
+    (movable foldable flushable))
+    
+(defknown (%acos)
+    (double-float) (double-float 0.0d0 #.pi)
+    (movable foldable flushable))
+    
+(defknown (%cosh)
+    (double-float) (double-float 1.0d0)
+    (movable foldable flushable))
+
+(defknown (%acosh %exp %sqrt)
+    (double-float) (double-float 0.0d0)
+    (movable foldable flushable))
+
+(defknown (%hypot)
+    (double-float double-float) (double-float 0d0)
   (movable foldable flushable))
 
+(defknown (%pow)
+    (double-float double-float) double-float
+  (movable foldable flushable))
+
+(defknown (%atan2)
+    (double-float double-float) (double-float #.(- pi) #.pi)
+  (movable foldable flushable))
+
+(defknown (%scalb)
+    (double-float double-float) double-float
+  (movable foldable flushable))
+
+(defknown (%scalbn)
+    (double-float (signed-byte 32)) double-float
+    (movable foldable flushable))
+
+(defknown (%log1p-limited)
+    (double-float) double-float
+    (movable foldable flushable))
+
 (dolist (stuff '((exp %exp *)
 		 (log %log float)
 		 (sqrt %sqrt float)
-		 (sin %sin *)
-		 (cos %cos *)
-		 (tan %tan *)
+		 #-x86 (sin %sin *)
+		 #-x86 (cos %cos *)
+		 #-x86 (tan %tan *)
 		 (asin %asin float)
 		 (acos %acos float)
 		 (atan %atan *)
@@ -291,16 +409,557 @@
     (deftransform name ((x) '(double-float) rtype :eval-name t :when :both)
       `(,prim x))))
 
+;;; The argument range is limited on the x86 FP trig. functions. A
+;;; post-test can detect a failure (and load a suitable result), but
+;;; this test is avoided if possible.
+#+x86
+(dolist (stuff '((sin %sin %sin-quick)
+		 (cos %cos %cos-quick)
+		 (tan %tan %tan-quick)))
+  (destructuring-bind (name prim prim-quick) stuff
+    (deftransform name ((x) '(single-float) '* :eval-name t :when :both)
+      (cond ((csubtypep (continuation-type x)
+			(specifier-type '(single-float (#.(- (expt 2s0 64)))
+						       (#.(expt 2s0 64)))))
+	     `(coerce (,prim-quick (coerce x 'double-float)) 'single-float))
+	    (t 
+	     (compiler-note
+	      "Unable to avoid inline argument range check~@
+             because the argument range (~s) was not within 2^64"
+	      (type-specifier (continuation-type x)))
+	     `(coerce (,prim (coerce x 'double-float)) 'single-float))))
+    (deftransform name ((x) '(double-float) '* :eval-name t :when :both)
+      (cond ((csubtypep (continuation-type x)
+			(specifier-type '(double-float (#.(- (expt 2d0 64)))
+						       (#.(expt 2d0 64)))))
+	     `(,prim-quick x))
+	    (t 
+	     (compiler-note
+	      "Unable to avoid inline argument range check~@
+             because the argument range (~s) was not within 2^64"
+	      (type-specifier (continuation-type x)))
+	     `(,prim x))))))
+
 (dolist (stuff '((expt %pow t)
 		 (atan %atan2 t)))
   (destructuring-bind (name prim rtype) stuff
-    (deftransform name ((x y) '(single-float) rtype :eval-name t)
+    (deftransform name ((x y) '(single-float single-float) rtype :eval-name t)
       `(coerce (,prim (coerce x 'double-float)
 		      (coerce y 'double-float))
 	       'single-float))
-    (deftransform name ((x y) '(double-float) rtype :eval-name t :when :both)
+    (deftransform name ((x y) '(double-float double-float)
+			rtype :eval-name t :when :both)
       `(,prim x y))))
 
 (deftransform log ((x y) (float float) float)
   '(/ (log x) (log y)))
 
+
+#+propagate-fun-type
+(progn
+;;;; Optimizers for elementary functions
+;;;;
+;;;; These optimizers compute the output range of the elementary
+;;;; function, based on the domain of the input.
+;;;;
+
+;;; Handle some simple transformations
+  
+(deftransform abs ((x) ((complex double-float)) double-float :when :both)
+  '(%hypot (realpart x) (imagpart x)))
+
+(deftransform abs ((x) ((complex single-float)) single-float :when :both)
+  '(coerce (%hypot (coerce (the single-float (realpart x)) 'double-float)
+		  (coerce (the single-float (imagpart x)) 'double-float))
+	  'single-float))
+
+(deftransform phase ((x) ((complex double-float)) double-float :when :both)
+  '(%atan2 (imagpart x) (realpart x)))
+
+(deftransform phase ((x) ((complex single-float)) single-float :when :both)
+  '(coerce (%atan2 (coerce (the single-float (imagpart x)) 'double-float)
+		  (coerce (the single-float (realpart x)) 'double-float))
+	  'single-float))
+
+(deftransform phase ((x) ((float)) float :when :both)
+  '(if (minusp (float-sign x))
+      (float pi x)
+      (float 0 x)))
+
+
+;;; Return the float format of the result of an elementary function.
+;;; If the format is NIL (which means type FLOAT), we return NIL.  If
+;;; the format is 'DOUBLE-FLOAT, we return that.  For any other case,
+;;; we return 'SINGLE-FLOAT.
+  
+(proclaim '(inline elfun-format numeric-type-real-p))  
+(defun elfun-float-format (format)
+  (if format
+      (if (eq format 'double-float)
+	  'double-float
+	  'single-float)))
+
+;;; The number is of type REAL.
+
+(defun numeric-type-real-p (type)
+  (and (numeric-type-p type)
+       (eq (numeric-type-complexp type) :real)))
+
+;;; Macro to handle most cases of computing the bounds for a
+;;; function.
+;;;
+;;; NUM is a continuation representing the argument to the
+;;; function.
+;;;
+;;; COND is an sexp that returns T when the number satisfies the
+;;; desired condition.  The sexp can refer to the two variables, LO
+;;; and HI, which are set to the lower and upper bounds of NUM.
+;;;
+;;; LIMIT-FUN is a function that returns the lower and upper bounds.
+
+(defmacro elfun-derive-type (num cond limit-fun)
+  (let ((type (gensym))
+	(lo-lim (gensym))
+	(hi-lim (gensym)))
+    `(let ((,type (continuation-type ,num)))
+      (when (numeric-type-real-p ,type)
+	(let ((lo (numeric-type-low ,type))
+	      (hi (numeric-type-high ,type)))
+	  (when ,cond
+	    (multiple-value-bind (,lo-lim ,hi-lim)
+		(funcall ,limit-fun lo hi)
+	      (make-numeric-type :class 'float
+				 :format (elfun-float-format
+					  (numeric-type-format ,type))
+				 :complexp :real
+				 :low ,lo-lim
+				 :high ,hi-lim))))))))
+
+;;; Handle these monotonic increasing functions whose domain is
+;;; possibly part of the real line
+(macrolet ((frob (name cond def-lo-bnd def-hi-bnd)
+	     (let ((num (gensym))
+		   (lo-bnd (gensym))
+		   (hi-bnd (gensym)))
+	       `(defoptimizer (,name derive-type) ((,num))
+		 (elfun-derive-type
+		  ,num
+		  ,cond
+		  #'(lambda (,lo-bnd ,hi-bnd)
+		      ;; Since the function is monotonic increasing, the
+		      ;; lower bound and the upper bound are the values
+		      ;; of the function at the bounds of the input
+		      ;; range.
+		      (values (if ,lo-bnd
+				  (set-bound (,name (bound-value ,lo-bnd))
+					     (consp ,lo-bnd))
+				  ,def-lo-bnd)
+			      (if ,hi-bnd
+				  (set-bound (,name (bound-value ,hi-bnd))
+					     (consp ,hi-bnd))
+				  ,def-hi-bnd))))))))
+
+  ;; These functions are easy because they are defined for the whole
+  ;; real line.
+  (frob exp t 0 nil)
+  (frob sinh t nil nil)
+  (frob tanh t -1 1)
+  (frob asinh t nil nil)
+
+  ;; These functions are only defined for part of the real line.  The
+  ;; condition selectes the desired part of the line.
+  (frob sqrt (and lo
+		  (>= (bound-value lo) 0))
+	0 nil)
+  (frob asin (and lo hi
+		  (>= (bound-value lo) -1)
+		  (<= (bound-value hi) 1))
+	#.(- (/ pi 2)) #.(/ pi 2))
+  (frob acosh (and lo (>= (bound-value lo) 1))
+	nil nil)
+  (frob atanh (and lo hi
+		   (>= (bound-value lo) -1)
+		   (<= (bound-value hi) 1))
+	-1 1)
+  )
+
+;;; acos is monotonic decreasing, so we need to swap the function
+;;; values at the lower and upper bounds of the input domain.
+(defoptimizer (acos derive-type) ((num))
+  (elfun-derive-type
+   num
+   (and lo hi
+	(>= (bound-value lo) -1)
+	(<= (bound-value hi) 1))
+   #'(lambda (lo hi)
+       (values (if hi
+		   (set-bound (acos (bound-value hi)) (consp hi)))
+	       (if lo
+		   (set-bound (acos (bound-value lo)) (consp lo)))))))
+
+;;; Compute return type for EXPT.  No bounds are computed because
+;;; that's pretty complicated in general.  We only return a lower
+;;; bound of 0 if we know that 0 is a lower bound.  The general case
+;;; will have to wait for another day.
+
+(defoptimizer (expt derive-type) ((x y))
+  (let ((x-type (continuation-type x))
+	(y-type (continuation-type y)))
+    (when (and (numeric-type-p x-type) (numeric-type-p y-type))
+      (let ((x-lo (numeric-type-low x-type))
+	    (y-lo (numeric-type-low y-type)))
+	;; There are several cases to handle for Y.  We only handle
+	;; the case where Y is an integer and Y is a float.  For Y
+	;; rational, the result could be a rational or float.
+
+	(cond ((eq (numeric-type-class y-type) 'integer)
+	       (cond ((and y-lo (>= (bound-value y-lo) 0))
+		      ;; When the power is a non-negative integer, the
+		      ;; result is of the same class and format as the
+		      ;; base.  If the base is known to be
+		      ;; non-negative, the result is too.  We can
+		      ;; easily compute the bound on the result in
+		      ;; this case, but that's for another day.
+		      (make-numeric-type
+		       :class (numeric-type-class x-type)
+		       :format (numeric-type-format x-type)
+		       :complexp :real
+		       :low (if (and x-lo (>= (bound-value x-lo) 0))
+				0
+				nil)
+		       :high nil))
+		     (t
+		      ;; The power maybe positive or negative.
+		      (let ((pos (and x-lo (>= (bound-value x-lo) 0))))
+			;; If the base is positive, the result is
+			;; positive.
+			(cond ((member (numeric-type-class x-type)
+				       '(integer rational))
+			       ;; Rational raised to a non-negative
+			       ;; integral power is rational.
+			       (make-numeric-type
+				:class 'rational
+				:complexp :real
+				:low (if pos 0 nil)
+				:high nil))
+			      (t
+			       ;; Float raised to integral power is a
+			       ;; float.
+			       (make-numeric-type
+				:class 'float
+				:format (numeric-type-format x-type)
+				:complexp :real
+				:low (if pos 0 nil)
+				:high nil)))))))
+	      ((eq (numeric-type-class y-type) 'float)
+	       ;; The power is a float.  The result is either a float
+	       ;; or complex.  We punt if the result is complex.
+	       (let ((pos (and x-lo (>= (bound-value x-lo) 0))))
+		 ;; If both the base and the power are non-negative,
+		 ;; the result is a non-negative real.  In any case
+		 ;; the result is a float of some time.
+		 (make-numeric-type
+		  :class 'float
+		  :format (if (or (eq (numeric-type-format x-type)
+				      'double-float)
+				  (eq (numeric-type-format y-type)
+				      'double-float))
+			      'double-float
+			      'single-float)
+		  :complexp :real
+		  :low (if pos 0 nil)
+		  :high nil))))))))
+
+
+(defoptimizer (log derive-type) ((x &optional y))
+  ;; We only handle the case where both x and y are non-negative reals.
+  (when (and (csubtypep (continuation-type x)
+			(specifier-type '(real 0.0)))
+	     (or (null y)
+		 (csubtypep (continuation-type y)
+			    (specifier-type '(real 0.0)))))
+    ;; If we get here, x must be a numeric type like (real 0.0).
+    (cond (y
+	   ;; The base is given.  We punt on this case and just say
+	   ;; the result is a float.
+	   (specifier-type 'float))
+
+	  (t
+	   ;; We have (log x) for non-negative x.  Get the bounds
+	   ;; on the result.
+	   (elfun-derive-type
+	    x
+	    t
+	    #'(lambda (lo hi)
+		(values (if (zerop (bound-value lo))
+			    nil
+			    (set-bound (log (bound-value lo)) (consp lo)))
+			(if hi
+			    (set-bound (log (bound-value hi)) (consp hi))
+			    nil))))))))
+
+  
+(defoptimizer (atan derive-type) ((y &optional x))
+  ;; We only handle the case where both x and y are real
+  (let ((y-type (continuation-type y)))
+    (when (numeric-type-real-p y-type)
+      (cond ((and x (numeric-type-real-p (continuation-type x)))
+	     ;; We punt on this case and just return the max bounds
+	     (make-numeric-type
+	      :class 'float
+	      :format (float-format-max
+		       (numeric-type-format y-type)
+		       (numeric-type-format (continuation-type x)))
+	      :complexp :real
+	      :low #.(- pi)
+	      :high #.pi))
+	    (t
+	     ;; One arg case is easy to handle.
+	     (elfun-derive-type
+	      y
+	      t
+	      #'(lambda (lo hi)
+		  (values (if lo
+			      (set-bound (atan (bound-value lo)) (consp lo))
+			      #.(- (/ pi 2)))
+			  (if hi
+			      (set-bound (atan (bound-value hi)) (consp hi))
+			      #.(/ pi 2))))))))))
+
+(defoptimizer (cosh derive-type) ((num))
+  (let ((type (continuation-type num)))
+    (when (numeric-type-real-p type)
+      (multiple-value-bind (lo hi)
+	  (extract-bounds type)
+	(let* ((max-bnd (max-bound (bound-abs lo) (bound-abs hi)))
+	       (min-bnd (min-bound (bound-abs lo) (bound-abs hi))))
+	  (make-numeric-type
+	   :class 'float
+	   :format (elfun-float-format (numeric-type-format type))
+	   :complexp :real
+	   :low (if (and (bound-< lo 0) (bound-< 0 hi))
+		    ;; If zero is in the input domain, then the lower
+		    ;; bound is cosh(0).  Otherwise it's the min of
+		    ;; the bounds.
+		    1
+		    (if (symbolp min-bnd)
+			nil
+			(set-bound (cosh (bound-value min-bnd))
+				   (consp min-bnd))))
+	   :high (if (symbolp max-bnd)
+		     nil
+		     (set-bound (cosh (bound-value max-bnd))
+				(consp max-bnd)))))))))
+
+(defoptimizer (phase derive-type) ((num))
+  (let ((type (continuation-type num)))
+    (cond ((numeric-type-real-p type)
+	   ;; Taking the phase of a real number.  The answer is either 0 or pi.
+	   (multiple-value-bind (lo hi)
+	       (extract-bounds type)
+	     ;; If 0 is contained in the bounds, the answer is either
+	     ;; 0 or pi, but we don't know which, so return a float of
+	     ;; the appropriate type.
+	     (cond ((bound-< hi 0)
+		    ;; The upper bound is less than 0, so we know that
+		    ;; the phase must be pi.
+		    (make-numeric-type :class 'float
+				       :format (elfun-float-format
+						(numeric-type-format type))
+				       :complexp :real
+				       :low pi
+				       :high pi))
+		   ((bound-< 0 lo)
+		    ;; The lower bound is greater than zero,
+		    ;; so the answer must be zero.
+		    (make-numeric-type :class 'float
+				       :format (elfun-float-format
+						(numeric-type-format type))
+				       :complexp :real
+				       :low 0
+				       :high 0))
+		   (t
+		    ;; The bounds must contain zero.  The answer is 0 or pi.
+		    (make-numeric-type :class 'float
+				       :format (elfun-float-format
+						(numeric-type-format type))
+				       :complexp :real
+				       :low 0
+				       :high pi)))))
+	  (t
+	   ;; We have a complex number.  The answer is the range -pi
+	   ;; to pi.  (-pi is included because we have -0.)
+	   (make-numeric-type :class 'float
+			      :format (elfun-float-format
+				       (numeric-type-format type))
+			      :complexp :real
+			      :low #.(- pi)
+			      :high pi)))))
+		 
+;;; Make REALPART and IMAGPART return the appropriate types.  This
+;;; helps a lot in optimized code.
+
+#+nil
+(defknown (%realpart)
+    (complex) real
+    (flushable movable))
+
+#+nil
+(defknown (%imagpart)
+    (complex) real
+    (flushable movable))
+
+#+nil
+(defoptimizer (%realpart derive-type) ((num))
+  (let ((type (continuation-type num)))
+    (cond ((numeric-type-real-p type)
+	   ;; The realpart of a real has the same type and range as the input.
+	   (make-numeric-type :class (numeric-type-class type)
+			      :format (numeric-type-format type)
+			      :complexp :real
+			      :low (numeric-type-low type)
+			      :high (numeric-type-high type)))
+	  (t
+	   ;; We have a complex number.  The result has the same type
+	   ;; as the real part, except that it's real, not complex,
+	   ;; obviously.
+	   (make-numeric-type :class (numeric-type-class type)
+			      :format (numeric-type-format type)
+			      :complexp :real
+			      :low (numeric-type-low type)
+			      :high (numeric-type-high type))))))
+
+#+nil
+(defoptimizer (%imagpart derive-type) ((num))
+  (let ((type (continuation-type num)))
+    (cond ((numeric-type-real-p type)
+	   ;; The imagpart of a real has the same type as the input,
+	   ;; except that it's zero
+	   (make-numeric-type :class (numeric-type-class type)
+			      :format (numeric-type-format type)
+			      :complexp :real
+			      :low 0
+			      :high 0))
+	  (t
+	   ;; We have a complex number.  The result has the same type
+	   ;; as the imaginary part, except that it's real, not complex,
+	   ;; obviously.
+	   (make-numeric-type :class (numeric-type-class type)
+			      :format (numeric-type-format type)
+			      :complexp :real
+			      :low (numeric-type-low type)
+			      :high (numeric-type-high type))))))
+
+  
+) ;end progn
+	   
+
+;;;; Here are the optimizers for sin, cos, and tan.  While computing
+;;;; the bounds for these functions is easy, I'm not sure about the
+;;;; reliability of these functions.  Mainly, these functions do a
+;;;; range reduction which may not be exactly the same as done in the
+;;;; trig functions so that roundoff may signficantly affect the
+;;;; limits returned.
+;;;;
+;;;; Thus, if x is (double-float 1d0 #.pi), the sin optimizer would
+;;;; return (double-float 1.2246467991473534d-16
+;;;; 0.8414709848078965d0), which is close to but not the same as
+;;;; (double-float 0d0 0.8414709848078965d0), which is closer to the
+;;;; truth.
+;;;;
+;;;; Proceed at your own risk here by adding propagate-trig-fun to
+;;;; your *features*.
+
+#+(and propagate-fun-type propagate-trig-fun)
+(progn
+(defoptimizer (tan derive-type) ((num))
+  (let ((type (continuation-type num)))
+    (when (numeric-type-real-p type)
+      (let ((xl (numeric-type-low type))
+	    (xh (numeric-type-high type)))
+	(cond ((and xl xh
+		    (<= (- (bound-value xh) (bound-value xl)) pi))
+	       ;; We have a bounded input range and the range covers
+	       ;; no more than one period.  We can compute bounds now.
+	       ;; We reduce the argument range to a single period.
+	       (multiple-value-bind (npi x-lo)
+		   (truncate (bound-value xl) pi)
+		 (let* ((x-hi (- (bound-value xh) (* npi pi))))
+		   ;; If pi/2 is in the input range, the domain is the
+		   ;; whole real line.
+		   (format t "x-lo, x-hi = ~s ~s~%" x-lo x-hi)
+		   (if (<= x-lo #.(* 0.5d0 pi) x-hi)
+		       (make-numeric-type
+			:class 'float
+			:format (elfun-float-format (numeric-type-format type))
+			:complexp :real
+			:low nil
+			:high nil)
+		       (make-numeric-type
+			:class 'float
+			:format (elfun-float-format (numeric-type-format type))
+			:complexp :real
+			:low (set-bound (tan x-lo) (consp x-lo))
+			:high (set-bound (tan x-hi) (consp x-hi)))))))
+	      (t
+	       ;; The range covers more than one period, so the answer
+	       ;; is obvious.
+	       (make-numeric-type
+		:class 'float
+		:format (elfun-float-format (numeric-type-format type))
+		:complexp :real
+		:low nil
+		:high nil)))))))
+
+
+(defun trig-limits (num fun bound-one bound-minus-one)
+  (let ((type (continuation-type num)))
+    (when (numeric-type-real-p type)
+      (let ((two-pi #.(* 2 pi))
+	    (xl (numeric-type-low type))
+	    (xh (numeric-type-high type)))
+	(cond ((and xl xh
+		    (<= (- (bound-value xh) (bound-value xl)) #.(* 2 pi)))
+	       ;; We have a bounded input range and the range covers
+	       ;; no more than one period.  We can compute bounds now.
+	       ;; We reduce the argument range to a single period.
+	       (multiple-value-bind (nperiods x-lo)
+		   (ftruncate (bound-value xl) two-pi)
+		 (let* ((x-hi (- (bound-value xh) (* nperiods two-pi)))
+			(bound-list (list (set-bound (funcall fun x-lo)
+						     (consp xl))
+					  (set-bound (funcall fun x-hi)
+						     (consp xh)))))
+		   ;; Add the upper and lower values for bounds on the
+		   ;; function if the range covers the corresponding
+		   ;; points.
+		   (when (<= x-lo bound-one x-hi)
+		     (push 1 bound-list))
+		   (when (<= x-lo bound-minus-one x-hi)
+		     (push -1 bound-list))
+		   (make-numeric-type :class 'float
+				      :format (elfun-float-format
+					       (numeric-type-format type))
+				      :complexp :real
+				      :low (min-bound-list bound-list)
+				      :high (max-bound-list bound-list)))))
+	      (t
+	       ;; The range covers more than one period,
+	       ;; so the answer is obvious.
+	       (make-numeric-type :class 'float
+				  :format (elfun-float-format
+					   (numeric-type-format type))
+				  :complexp :real
+				  :low nil
+				  :high nil)))))))
+
+(defoptimizer (sin derive-type) ((num))
+  (trig-limits num #'sin #.(/ pi 2) #.(* 1.5d0 pi)))
+
+(defoptimizer (cos derive-type) ((num))
+  (trig-limits num #'cos 0 pi))
+	     
+) ; end progn
+
+
+
diff --git a/compiler/fndb.lisp b/compiler/fndb.lisp
index 8d6dc0560..01c96a25d 100644
--- a/compiler/fndb.lisp
+++ b/compiler/fndb.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/fndb.lisp,v 1.67 1996/07/08 19:01:21 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/fndb.lisp,v 1.68 1997/01/18 14:31:34 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -947,7 +947,9 @@
   (flushable))
 
 (defknown make-pathname
- (&key (:defaults pathnamelike) (:host pathname-host) (:device pathname-device)
+ (&key (:defaults pathnamelike)
+       (:host (or string pathname-host))
+       (:device pathname-device)
        (:directory (or pathname-directory string (member :wild)))
        (:name (or pathname-name string (member :wild)))
        (:type (or pathname-type string (member :wild)))
@@ -1046,7 +1048,7 @@
   (or string null)
   (flushable))
 
-(defknown describe (t &optional stream) (values))
+(defknown describe (t &optional (or stream (member t nil))) (values))
 (defknown inspect (t) (values))
 
 (defknown room (&optional (member t nil :default)) void)
diff --git a/compiler/generic/core.lisp b/compiler/generic/core.lisp
index a0e80b1a6..7cce3194d 100644
--- a/compiler/generic/core.lisp
+++ b/compiler/generic/core.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/core.lisp,v 1.31 1994/10/31 04:38:06 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/core.lisp,v 1.32 1997/01/18 14:31:14 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -95,7 +95,13 @@
 	     (gethash name lisp::*assembler-routines*))
 	    (:foreign
 	     (assert (stringp name))
-	     (gethash name lisp::*foreign-symbols*)))
+	     (gethash name lisp::*foreign-symbols*))
+	    ;;; pw -- don't the RISC systems need this too?
+	    #+x86
+	    (:code-object
+	     (values
+	      (get-lisp-obj-address code)
+	      t)))
 	(unless found
 	  (error (ecase flavor
 		   (:assembly-routine "Undefined assembler routine: ~S")
@@ -104,6 +110,8 @@
 	(vm:fixup-code-object code offset value kind)))))
 
 
+
+
 ;;; REFERENCE-CORE-FUNCTION  --  Internal
 ;;;
 ;;;    Stick a reference to the function Fun in Code-Object at index I.  If the
diff --git a/compiler/generic/new-genesis.lisp b/compiler/generic/new-genesis.lisp
index 73c3d8306..8874d6daf 100644
--- a/compiler/generic/new-genesis.lisp
+++ b/compiler/generic/new-genesis.lisp
@@ -4,7 +4,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.19 1994/10/31 04:38:06 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.20 1997/01/18 14:31:16 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -419,14 +419,14 @@
   (etypecase num
     (single-float
      (let ((des (allocate-unboxed-object *dynamic* vm:word-bits
-					 vm:single-float-size
+					 (1- vm:single-float-size)
 					 vm:single-float-type)))
        (write-indexed des vm:single-float-value-slot
 		      (make-random-descriptor (single-float-bits num)))
        des))
     (double-float
      (let ((des (allocate-unboxed-object *dynamic* vm:word-bits
-					 vm:double-float-size
+					 (1- vm:double-float-size)
 					 vm:double-float-type))
 	   (high-bits (make-random-descriptor (double-float-high-bits num)))
 	   (low-bits (make-random-descriptor (double-float-low-bits num))))
@@ -456,7 +456,7 @@
 
 (defun sap-to-core (sap)
   (let ((des (allocate-unboxed-object *dynamic* vm:word-bits
-				      vm:sap-size vm:sap-type)))
+				      (1- vm:sap-size) vm:sap-type)))
     (write-indexed des vm:sap-pointer-slot
 		   (make-random-descriptor (sap-int sap)))
     des))
@@ -554,7 +554,7 @@
 ;;;
 ;;;    Return a handle on an interned symbol.  If necessary allocate
 ;;; the symbol and record which package the symbol was referenced in.
-;;; When we allocatethe symbol, make sure we record a reference to
+;;; When we allocate the symbol, make sure we record a reference to
 ;;; the symbol in the home package so that the package gets set.
 ;;;
 (defun cold-intern (symbol &optional (package (symbol-package symbol)))
@@ -698,7 +698,13 @@
     (frob *static-space-free-pointer*
       (allocate-descriptor *static* 0 vm:even-fixnum-type))
     (frob *initial-dynamic-space-free-pointer*
-      (allocate-descriptor *dynamic* 0 vm:even-fixnum-type))))
+      (allocate-descriptor *dynamic* 0 vm:even-fixnum-type))
+    
+    (when (c:backend-featurep :x86)
+	  (frob x86::*fp-constant-0d0* (number-to-core 0d0))
+	  (frob x86::*fp-constant-1d0* (number-to-core 1d0))
+	  (frob x86::*fp-constant-0s0* (number-to-core 0s0))
+	  (frob x86::*fp-constant-1s0* (number-to-core 1s0)))))
 
 ;;; Make-Make-Package-Args  --  Internal
 ;;;
@@ -1425,9 +1431,12 @@
 	     ;; Note: we round the number of constants up to assure that
 	     ;; the code vector will be properly aligned.
 	     (round-up raw-header-size 2))
-	    (des (allocate-descriptor *dynamic*
-				      (+ (ash header-size vm:word-shift) size)
-				      vm:other-pointer-type)))
+	    (des (allocate-descriptor
+		  (if (c:backend-featurep :x86)
+		      *static*
+		    *dynamic*)
+		  (+ (ash header-size vm:word-shift) size)
+		  vm:other-pointer-type)))
        (write-memory des
 		     (make-other-immediate-descriptor header-size
 						      vm:code-header-type))
@@ -1597,12 +1606,54 @@
 	    (return))
 	  (multiple-value-bind
 	      (value name)
-	      (if (string= "0x" line :end2 2)
-		  (values (parse-integer line :start 2 :end 10 :radix 16)
-			  (subseq line 13))
-		  (values (parse-integer line :end #-alpha 8 #+alpha 16
-					 :radix 16)
-			  (subseq line #-alpha 11 #+alpha 19)))
+ 	      (if (string= "0x" line :end2 2)
+;;;		  (values (parse-integer line :start 2
+;;;					 :end #-alpha 10 #+alpha 18 :radix 16)
+;;;			  (subseq line #-alpha 13 #+alpha 19))
+;;;		  (values (parse-integer line :end #-alpha 8 #+alpha 16
+;;;					 :radix 16)
+;;;			  (subseq line #-alpha 11 #+alpha 19)))
+;;; If your nm produces 64-bit addresses, there's 3 ways to get 
+;;; new-genesis to work: Yet another is to use 'sed' in your Config file.
+;; OPTION 1 --- hard-wire 16 bit values into line
+;;              i.e. replace above six lines with these
+;		  (values (parse-integer line :start 2 :end 18 :radix 16)
+;			  (subseq line #-alpha 21 #+alpha 19))
+;		  (values (parse-integer line :end 16 :radix 16)
+;			  (subseq line #-alpha 19 #+alpha 19)))
+;; OPTION 2 --- scan line, read junk, and do subseq until non-int char found
+;		  (values (parse-integer line :start 2 :end 16 :radix 16
+;					 :junk-allowed t)
+;			  (let ((pos 2))
+;			      (loop
+;			        (setq pos (+ pos 8))
+;				(if (not (digit-char-p (char line pos) 16))
+;				    (return)))
+;			      (subseq line (+ pos 3))))
+;		  (values (parse-integer line :end 16 :radix 16
+;					 :junk-allowed t)
+;			  (let ((pos 0))
+;			      (loop
+;			        (setq pos (+ pos 8))
+;				(if (not (digit-char-p (char line pos) 16))
+;				    (return)))
+;			      (subseq line (+ pos 3)))))
+;;; OPTION 3 --- use environment variable for 64 bit linux 
+;;              i.e.  in setenv.lsp add (pushnew :linux64 *features*)
+;;              (using the alpha flag also works, but I don't know if it has
+;;               side-effects)
+		  (values (parse-integer line :start 2 :radix 16 
+					 :end #-(or alpha linux64) 10 
+					      #+(or alpha linux64) 18)
+			  (subseq line #-(or alpha linux64) 13 
+				       #+(or alpha linux64) 19))
+		  (values (parse-integer line :radix 16
+					 :end #-(or alpha linux64) 8 
+					      #+(or alpha linux64) 16)
+			  (subseq line #-(or alpha linux64) 11 
+				       #+(or alpha linux64) 19)))
+;; END OPTIONS
+
 	    (multiple-value-bind
 		(old-value found)
 		(gethash name *cold-foreign-symbol-table*)
@@ -1612,13 +1663,28 @@
       version)))
 
 (defun lookup-foreign-symbol (name)
-  (multiple-value-bind
-      (value found)
-      (gethash name *cold-foreign-symbol-table* 0)
-    (unless found
-      (warn "Undefined foreign symbol: ~S" name))
-    value))
+  (let ((is-linux (and (eq (c:backend-fasl-file-implementation c:*backend*)
+			   #.c:x86-fasl-file-implementation)
+		       (c:backend-featurep :linux))))
+
+    (cond
+     ((and is-linux (gethash (concatenate 'string "PVE_stub_" name)
+			     *cold-foreign-symbol-table* nil)))
+     ;; Non-linux case
+     ((gethash name *cold-foreign-symbol-table* nil))
+     ((and is-linux (gethash (concatenate 'string "__libc_" name)
+			     *cold-foreign-symbol-table* nil)))
+     ((and is-linux (gethash (concatenate 'string "__" name)
+			     *cold-foreign-symbol-table* nil)))
+     ((and is-linux (gethash (concatenate 'string "_" name)
+			     *cold-foreign-symbol-table* nil)))
+     (t
+      (warn "Undefined foreign symbol: ~S" name)
+      0))))
 
+;; FreeBSD wants C language symbols prefixed with "_" including all the
+;; syscalls and Unix library things. Linux doesn't or maybe does
+;; depending on things I don't know about yet?
 (defun lookup-maybe-prefix-foreign-symbol (name)
   (lookup-foreign-symbol
    (concatenate 'string
@@ -1626,7 +1692,6 @@
 		  ((#.c:pmax-fasl-file-implementation
 		    #.c:rt-fasl-file-implementation
 		    #.c:rt-afpa-fasl-file-implementation
-		    #.c:x86-fasl-file-implementation
 		    #.c:hppa-fasl-file-implementation
 		    #.c:alpha-fasl-file-implementation
 		    #.c:sgi-fasl-file-implementation)
@@ -1634,7 +1699,12 @@
 		  (#.c:sparc-fasl-file-implementation
 		   (if (c:backend-featurep :svr4)
 		       ""
-		       "_")))
+		       "_"))
+		  (#.c:x86-fasl-file-implementation
+		   (if (c:backend-featurep :freebsd)
+		       "_" ; FreeBSD
+		       "")) ; Linux
+		  )
 		name)))
 
 (defvar *cold-assembler-routines* nil)
diff --git a/compiler/generic/vm-ir2tran.lisp b/compiler/generic/vm-ir2tran.lisp
index 730090f6e..15ec1a42a 100644
--- a/compiler/generic/vm-ir2tran.lisp
+++ b/compiler/generic/vm-ir2tran.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-ir2tran.lisp,v 1.8 1994/10/31 04:38:06 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-ir2tran.lisp,v 1.9 1997/01/18 14:31:15 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -128,10 +128,6 @@
 	     (continuation-tn node block rank) result))
     (move-continuation-result node block locs cont)))
 
-#+gengc
-(setf (function-info-ltn-annotate (function-info-or-lose 'make-array-header))
-      #'annotate-funny-call)
-
 
 ;;;; Replacements for stuff in ir2tran to make gengc work.
 
diff --git a/compiler/generic/vm-macs.lisp b/compiler/generic/vm-macs.lisp
index 2c011a5fb..c49acd101 100644
--- a/compiler/generic/vm-macs.lisp
+++ b/compiler/generic/vm-macs.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-macs.lisp,v 1.15 1994/10/31 04:38:06 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-macs.lisp,v 1.16 1997/01/18 14:31:15 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -186,8 +186,7 @@
   (let ((info (function-info-or-lose name)))
     (setf (function-info-ir2-convert info)
 	  #'(lambda (node block)
-	      (ir2-convert-reffer node block name offset lowtag)))
-    (setf (function-info-ltn-annotate info) #'annotate-funny-call))
+	      (ir2-convert-reffer node block name offset lowtag))))
   name)
 
 (defmacro def-reffer (name offset lowtag)
@@ -200,8 +199,7 @@
 	      #'(lambda (node block)
 		  (ir2-convert-setfer node block name offset lowtag))
 	      #'(lambda (node block)
-		  (ir2-convert-setter node block name offset lowtag))))
-    (setf (function-info-ltn-annotate info) #'annotate-funny-call))
+		  (ir2-convert-setter node block name offset lowtag)))))
   name)
 
 (defmacro def-setter (name offset lowtag)
@@ -216,8 +214,7 @@
 						   lowtag inits))
 	      #'(lambda (node block)
 		  (ir2-convert-fixed-allocation node block name words header
-						lowtag inits))))
-    (setf (function-info-ltn-annotate info) #'annotate-funny-call))
+						lowtag inits)))))
   name)
 
 (defmacro def-alloc (name words variable-length header lowtag inits)
@@ -244,8 +241,8 @@
 ;;; one place to make sure they are all unique.
 
 (defparameter fasl-file-implementations
-  '(nil "Pmax" "Sparc" "RT" "RT/AFPA" "x86" "HPPA" "Alpha" "SGI"
-	"Big-endian byte-code" "Little-endian byte-code"))
+  '(nil "Pmax" "Sparc" "RT" "RT/AFPA" "x86" "HPPA"
+	"Big-endian byte-code" "Little-endian byte-code" "Alpha" "SGI"))
 (defconstant pmax-fasl-file-implementation 1)
 (defconstant sparc-fasl-file-implementation 2)
 (defconstant rt-fasl-file-implementation 3)
diff --git a/compiler/generic/vm-tran.lisp b/compiler/generic/vm-tran.lisp
index 28a920ec9..114a49cc4 100644
--- a/compiler/generic/vm-tran.lisp
+++ b/compiler/generic/vm-tran.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-tran.lisp,v 1.34 1994/10/31 04:38:06 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-tran.lisp,v 1.35 1997/01/18 14:31:17 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -310,7 +310,7 @@
   '(%sxhash-simple-string s-expr))
 
 (deftransform sxhash ((s-expr) (symbol))
-  (%sxhash-simple-string (symbol-name s-expr)))
+  '(%sxhash-simple-string (symbol-name s-expr)))
 
 (deftransform sxhash ((s-expr) (single-float))
   '(let ((bits (single-float-bits s-expr)))
diff --git a/compiler/ir2tran.lisp b/compiler/ir2tran.lisp
index dfaab4676..09fbde5d9 100644
--- a/compiler/ir2tran.lisp
+++ b/compiler/ir2tran.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir2tran.lisp,v 1.59 1994/10/31 04:27:28 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir2tran.lisp,v 1.60 1997/01/18 14:31:24 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1133,11 +1133,15 @@
   (declare (type bind node) (type ir2-block block) (type clambda fun))
   (let ((start-label (entry-info-offset (leaf-info fun)))
 	(env (environment-info (node-environment node))))
-    (vop xep-allocate-frame node block start-label)
     (let ((ef (functional-entry-function fun)))
-      (when (and (optional-dispatch-p ef)
-		 (optional-dispatch-more-entry ef))
-	(vop copy-more-arg node block (optional-dispatch-max-args ef)))
+      (if (and (optional-dispatch-p ef)
+	       (optional-dispatch-more-entry ef))
+	  ;; Special case the xep-allocate-frame + copy-more-arg case.
+	  (progn 
+	    (vop xep-allocate-frame node block start-label #+x86 t)
+	    (vop copy-more-arg node block (optional-dispatch-max-args ef)))
+	;; No more args, so normal entry.
+	(vop xep-allocate-frame node block start-label #+x86 nil))
       
       (if (ir2-environment-environment env)
 	  (let ((closure
diff --git a/compiler/loadcom.lisp b/compiler/loadcom.lisp
index d91bb374b..5dbb23c5a 100644
--- a/compiler/loadcom.lisp
+++ b/compiler/loadcom.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/loadcom.lisp,v 1.47 1994/10/31 04:27:28 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/loadcom.lisp,v 1.48 1997/01/18 14:31:36 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -25,7 +25,6 @@
 (load "c:ir1util")
 (load "c:ir1tran")
 (load "c:ir1final")
-(load "c:srctran")
 (load "c:array-tran")
 (load "c:seqtran")
 (load "c:typetran")
@@ -33,6 +32,7 @@
 (load "vm:vm-tran")
 (load "c:float-tran")
 (load "c:saptran")
+(load "c:srctran")
 (load "c:locall")
 (load "c:dfo")
 (load "c:ir1opt")
diff --git a/compiler/main.lisp b/compiler/main.lisp
index de05e4c40..c7159ffa3 100644
--- a/compiler/main.lisp
+++ b/compiler/main.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/main.lisp,v 1.107 1994/10/31 04:27:28 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/main.lisp,v 1.108 1997/01/18 14:31:32 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1712,12 +1712,14 @@
 	 (error-severity nil)
 	 (source (verify-source-files source))
 	 (source-info (make-file-source-info source))
-	 (default (pathname (first source))))
+	 (default (pathname (first source)))
+	 (diddle-case (logical-pathname-p (pathname default))))
     (unwind-protect
 	(progn
 	  (flet ((frob (file type)
 		   (if (eq file t)
-		       (make-pathname :type type  :defaults default)
+		       (make-pathname :type (lisp::maybe-diddle-case type diddle-case)
+				      :defaults default)
 		       (pathname file))))
 	    
 	    (when output-file
diff --git a/compiler/new-assem.lisp b/compiler/new-assem.lisp
index e4fb7c0ee..e9ae92b1c 100644
--- a/compiler/new-assem.lisp
+++ b/compiler/new-assem.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/new-assem.lisp,v 1.25 1994/10/31 04:27:28 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/new-assem.lisp,v 1.26 1997/01/18 14:31:26 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -762,13 +762,16 @@
 	    (:include annotation)
 	    (:conc-name alignment-)
 	    (:predicate alignment-p)
-	    (:constructor make-alignment (bits size)))
+	    (:constructor make-alignment (bits size fill-byte)))
   ;;
   ;; The minimum number of low-order bits that must be zero.
   (bits 0 :type alignment)
   ;;
   ;; The amount of filler we are assuming this alignment op will take.
-  (size 0 :type (integer 0 #.(1- (ash 1 max-alignment)))))
+  (size 0 :type (integer 0 #.(1- (ash 1 max-alignment))))
+  ;;
+  ;; The byte used as filling.
+  (fill-byte 0 :type (or assembly-unit (signed-byte #.assembly-unit-bits))))
 
 ;;; BACK-PATCH -- a reference to someplace that needs to be back-patched when
 ;;; we actually know what label positions, etc. are.
@@ -913,12 +916,12 @@
 
 ;;; EMIT-SKIP -- interface.
 ;;; 
-(defun emit-skip (segment amount)
+(defun emit-skip (segment amount &optional (fill-byte 0))
   "Output AMOUNT zeros (in bytes) to SEGMENT."
   (declare (type segment segment)
 	   (type index amount))
   (dotimes (i amount)
-    (emit-byte segment 0))
+    (emit-byte segment fill-byte))
   (ext:undefined-value))
 
 ;;; EMIT-ANNOTATION -- internal.
@@ -1044,7 +1047,7 @@
 ;;; number of bytes.  If so, we do so.  Otherwise, we create and emit
 ;;; an alignment note.
 ;;; 
-(defun emit-alignment (segment vop bits)
+(defun emit-alignment (segment vop bits &optional (fill-byte 0))
   (when (segment-run-scheduler segment)
     (schedule-pending-instructions segment))
   (let ((hook (segment-inst-hook segment)))
@@ -1059,12 +1062,12 @@
 	   ;; note to cover the rest.
 	   (let ((slop (logand offset (1- (ash 1 alignment)))))
 	     (unless (zerop slop)
-	       (emit-skip segment (- (ash 1 alignment) slop))))
+	       (emit-skip segment (- (ash 1 alignment) slop) fill-byte)))
 	   (let ((size (logand (1- (ash 1 bits))
 			       (lognot (1- (ash 1 alignment))))))
 	     (assert (> size 0))
-	     (emit-annotation segment (make-alignment bits size))
-	     (emit-skip segment size))
+	     (emit-annotation segment (make-alignment bits size fill-byte))
+	     (emit-skip segment size fill-byte))
 	   (setf (segment-alignment segment) bits)
 	   (setf (segment-sync-posn segment) (segment-current-posn segment)))
 	  (t
@@ -1073,10 +1076,10 @@
 	   ;; the last alignment was met.
 	   (let* ((mask (1- (ash 1 bits)))
 		  (new-offset (logand (+ offset mask) (lognot mask))))
-	     (emit-skip segment (- new-offset offset)))
+	     (emit-skip segment (- new-offset offset) fill-byte))
 	   ;; But we emit an alignment with size=0 so we can verify
 	   ;; that everything works.
-	   (emit-annotation segment (make-alignment bits 0)))))
+	   (emit-annotation segment (make-alignment bits 0 fill-byte)))))
   (ext:undefined-value))
 
 
@@ -1179,7 +1182,8 @@
 		(setf (segment-fill-pointer segment) (system:int-sap 0))
 		(setf (segment-block-end segment) (system:int-sap 0))
 		(setf (segment-last-annotation segment) prev)
-		(emit-alignment segment nil (alignment-bits note))
+		(emit-alignment segment nil (alignment-bits note)
+				(alignment-fill-byte note))
 		(let* ((new-index (segment-current-index segment))
 		       (size (- new-index index))
 		       (old-size (alignment-size note))
@@ -1374,9 +1378,9 @@
 
 ;;; ALIGN -- interface.
 ;;; 
-(defmacro align (bits)
+(defmacro align (bits &optional (fill-byte 0))
   "Emit an alignment restriction to the current segment."
-  `(emit-alignment *current-segment* *current-vop* ,bits))
+  `(emit-alignment *current-segment* *current-vop* ,bits ,fill-byte))
 
 ;;; LABEL-POSITION -- interface.
 ;;; 
@@ -1399,7 +1403,9 @@
     (setf (segment-postits segment) (segment-postits other-segment))
     (dolist (postit postits)
       (emit-back-patch segment 0 postit)))
-  (emit-alignment segment nil max-alignment)
+  (if (c:backend-featurep :x86)
+      (emit-alignment segment nil max-alignment #x90)
+    (emit-alignment segment nil max-alignment))
   (let ((offset-in-last-block (rem (segment-current-index segment)
 				   output-block-size)))
     (unless (zerop offset-in-last-block)
diff --git a/compiler/pack.lisp b/compiler/pack.lisp
index 6bf0c9ad4..e53ec2fa6 100644
--- a/compiler/pack.lisp
+++ b/compiler/pack.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/pack.lisp,v 1.53 1994/10/31 04:27:28 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/pack.lisp,v 1.54 1997/01/18 14:31:27 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1118,6 +1118,17 @@
 ;;;
 (defun select-load-tn-location (op sc)
   (declare (type tn-ref op) (type sc sc))
+
+  ;; Check any target location first.
+  (let ((target (tn-ref-target op)))
+    (when target
+      (let* ((tn (tn-ref-tn target))
+	     (loc (tn-offset tn)))
+	(when (and (eq (sc-sb sc) (sc-sb (tn-sc tn)))
+		   (member (the index loc) (sc-locations sc))
+		   (not (load-tn-conflicts-in-sc op sc loc nil)))
+	      (return-from select-load-tn-location loc)))))
+  
   (dolist (loc (sc-locations sc) nil)
     (unless (load-tn-conflicts-in-sc op sc loc nil)
       (return loc))))
@@ -1267,16 +1278,38 @@
 (proclaim '(inline check-operand-restrictions))
 (defun check-operand-restrictions (scs ops)
   (declare (list scs) (type (or tn-ref null) ops))
+
+  ;; Check the targeted operands first.
+  (do ((scs scs (cdr scs))
+       (op ops (tn-ref-across op)))
+      ((null scs))
+      (let ((target (tn-ref-target op)))
+	(when target
+	   (let* ((load-tn (tn-ref-load-tn op))
+		  (load-scs (svref (car scs)
+				   (sc-number
+				    (tn-sc (or load-tn (tn-ref-tn op)))))))
+	     (if load-tn
+		 (assert (eq load-scs t))
+	       (unless (eq load-scs t)
+		       (setf (tn-ref-load-tn op)
+			     (pack-load-tn (car scs) op))))))))
+
   (do ((scs scs (cdr scs))
        (op ops (tn-ref-across op)))
       ((null scs))
-    (let* ((load-tn (tn-ref-load-tn op))
-	   (load-scs (svref (car scs)
-			    (sc-number (tn-sc (or load-tn (tn-ref-tn op)))))))
-      (if load-tn
-	  (assert (eq load-scs t))
-	  (unless (eq load-scs t)
-	    (setf (tn-ref-load-tn op) (pack-load-tn (car scs) op))))))
+      (let ((target (tn-ref-target op)))
+	(unless target
+	   (let* ((load-tn (tn-ref-load-tn op))
+		  (load-scs (svref (car scs)
+				   (sc-number
+				    (tn-sc (or load-tn (tn-ref-tn op)))))))
+	     (if load-tn
+		 (assert (eq load-scs t))
+	       (unless (eq load-scs t)
+		       (setf (tn-ref-load-tn op)
+			     (pack-load-tn (car scs) op))))))))
+
   (undefined-value))
 	
 
@@ -1528,12 +1561,48 @@
       (unless (eq (sb-kind sb) :unbounded)
 	(error "~S wired to a location that is out of bounds." tn))
       (grow-sc sc end))
+
+    ;; For non x86 ports the presence of a save-tn associated with a
+    ;; tn is used to identify the old-fp and return-pc tns. It depends
+    ;; on the old-fp and return-pc being passed in registers.
+    (unless (backend-featurep :x86)
+      (when (and (not (eq (tn-kind tn) :specified-save))
+		 (conflicts-in-sc original sc offset))
+	    (error "~S wired to a location that it conflicts with." tn)))
+
+    ;; Use the above check, but only print a verbose warning. Helpful
+    ;; for debugging the x86 port.
+    #+x86-debug-pack-wired-tn
     (when (and (not (eq (tn-kind tn) :specified-save))
 	       (conflicts-in-sc original sc offset))
-      (error "~S wired to a location that it conflicts with." tn))
+	  (format t "~&* Pack-wired-tn possible conflict:~%  ~
+                     tn: ~s; tn-kind: ~s~%  ~
+                     sc: ~s~%  ~
+                     sb: ~s; sb-name: ~s; sb-kind: ~s~%  ~
+                     offset: ~s; end: ~s~%  ~
+                     original ~s~%  ~
+                     tn-save-tn: ~s; tn-kind of tn-save-tn: ~s~%"
+		  tn (tn-kind tn) sc
+		  sb (sb-name sb) (sb-kind sb)
+		  offset end
+		  original 
+		  (tn-save-tn tn) (tn-kind (tn-save-tn tn))))
+    
+    (when (backend-featurep :x86)
+       ;; On the x86 ports the old-fp and return-pc are often passed
+       ;; on the stack so the above hack for the other ports does not
+       ;; always work.  Here the old-fp and return-pc tns are
+       ;; identified by being on the stack in their standard save
+       ;; locations.
+       (when (and (not (eq (tn-kind tn) :specified-save))
+		  (not (and (eq (sb-name sb) 'vm::stack)
+			    (or (= offset 0)
+				(= offset 1))))
+		  (conflicts-in-sc original sc offset))
+	     (error "~S wired to a location that it conflicts with." tn)))
+    
     (add-location-conflicts original sc offset)))
 
-
 (defevent repack-block "Repacked a block due to TN unpacking.")
 
 ;;; Pack  --  Interface
diff --git a/compiler/srctran.lisp b/compiler/srctran.lisp
index 214b568ca..e0f3ba99c 100644
--- a/compiler/srctran.lisp
+++ b/compiler/srctran.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.45 1994/10/31 04:27:28 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.46 1997/01/18 14:31:30 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -253,7 +253,256 @@
 			     :low low  :high high))
 	(numeric-contagion x y))))
 
+;;; Derive-Real-Type  --  Internal
+;;;
+;;; Same as derive-integer-type except it can handle float types.
+;;; This also contains derive-integer-type as a special case.
+;;;
+#+propagate-float-type
+(defun derive-real-type (x y fun)
+  (declare (type continuation x y) (type function fun))
+  (let ((x (continuation-type x))
+	(y (continuation-type y)))
+    (derive-real-numeric-or-union-type x y fun)))
+
+#+propagate-float-type
+(defun derive-real-numeric-or-union-type (x y fun)
+  (cond ((union-type-p x)
+	 (let ((new-union '()))
+	   (dolist (type (union-type-types x))
+	     (setf new-union (cons (derive-real-numeric-or-union-type
+				    type y fun) new-union)))
+	   (make-union-type (derive-merged-union-types new-union))))
+	((union-type-p y)
+	 (let ((new-union '()))
+	   (dolist (type (union-type-types y))
+	     (setf new-union (cons (derive-real-numeric-or-union-type
+				    x type fun) new-union)))
+	   (make-union-type (derive-merged-union-types new-union))))
+	((and (numeric-type-p x) (numeric-type-p y))
+	 (derive-simple-real-type x y fun))
+	(t
+	 (numeric-contagion x y))))
+
+#+propagate-float-type
+(defun merge-types-aux (tlist)
+  ;; Merge the first interval in the list with the rest of
+  ;; intervals in the list.  The list of intervals MUST be
+  ;; sorted in ascending order of lower limits.
+  (let* ((cur (first tlist))
+	 (res (list cur)))
+    (multiple-value-bind (cur-lo cur-hi)
+	(extract-bounds cur)
+      (declare (ignore cur-lo))
+      (dolist (type (rest tlist)
+	       res)
+	(multiple-value-bind (type-lo type-hi)
+	    (extract-bounds type)
+	  (cond ((not (bound-< type-lo cur-hi))
+		 ;; Left limit of the current interval lies
+		 ;; within our interval, so merge these two
+		 ;; intervals into our interval.
+		 (setf (numeric-type-high cur)
+		       (nilify-bound (max-bound cur-hi type-hi))))
+		(t
+		 ;; Otherwise, we can't merge these two intervals
+		 (setf res (cons type res)))))))))
+
+#+propagate-float-type
+(defun merge-types (ilist &optional (result '()))
+  ;; Compare the first element with the rest to merge
+  ;; whatever we can into the first element.  The first
+  ;; element is totally merged, so we only need to consider
+  ;; whatever is left.
+  (cond ((null ilist)
+	 result)
+	((cdr ilist)
+	 (let ((new-types (merge-types-aux ilist)))
+	   (merge-types (rest new-types) (cons (first new-types) result))))
+	(t
+	 (cons (first ilist) result))))
+
+#+propagate-float-type
+(defun derive-merged-union-types (types)
+  (labels ((interval-< (a b)
+	     (multiple-value-bind (a-lo a-hi)
+		 (extract-bounds a)
+	       (declare (ignore a-hi))
+	       (multiple-value-bind (b-lo b-hi)
+		   (extract-bounds b)
+		 (declare (ignore b-hi))
+		 (bound-< a-lo b-lo)))))
+    (merge-types (sort types #'interval-<))))
+
+#+propagate-float-type
+(defun derive-simple-real-type (x y fun)
+  (declare (type numeric-type x y) (type function fun))
+  (cond ((and (eq (numeric-type-class x) 'integer)
+	      (eq (numeric-type-class y) 'integer)
+	      (eq (numeric-type-complexp x) :real)
+	      (eq (numeric-type-complexp y) :real))
+	 (multiple-value-bind (low high)
+	     (funcall fun x y)
+	   (make-numeric-type :class 'integer  :complexp :real
+			      :low low  :high high)))
+	((and (numeric-type-p x) (numeric-type-p y)
+	      (eq (numeric-type-class x) 'float)
+	      (eq (numeric-type-class y) 'float)
+	      (eq (numeric-type-complexp x) :real)
+	      (eq (numeric-type-complexp y) :real)
+	      (eq (numeric-type-format x) (numeric-type-format y)))
+	 ;; We have two floats of some kind.  We will handle float
+	 ;; contagion here instead of using the general
+	 ;; numeric-contagion which loses the bounds on the numbers,
+	 ;; if any.
+	 (multiple-value-bind (low high)
+	     (funcall fun x y)
+	   (make-numeric-type
+	    :class 'float
+	    :format (float-format-max (numeric-type-format x)
+				      (numeric-type-format y))
+	    :complexp :real
+	    :low low  :high high)))
+	(t
+	 (numeric-contagion x y))))
+
+
+;;;; Helper methods for dealing with inclusive and exclusive bounds.
+
+;;; Return the value of a bound.  Ignore the issue if the bound is
+;;; inclusive or exclusive.  If no bound is given, return nil (which
+;;; is the bound value).
+
+(defun bound-value (bnd)
+  (if (consp bnd)
+      (car bnd)
+      bnd))
+
+;;; Take a numeric argument and extract the bounds.  If any bound is
+;;; not given (nil), return the appropriate infinity instead.
+
+(defun extract-bounds (arg)
+  (let ((lo (numeric-type-low arg))
+	(hi (numeric-type-high arg)))
+    ;; Replace nil values with the appropriate bound
+    (values (or lo 'neg-inf)
+	    (or hi 'pos-inf))))
+
+;;; Convert a bound from extract-bounds to be either the bound or nil.
+
+(defun nilify-bound (b)
+  (if (symbolp b)
+      nil
+      b))
+
+(defun set-bound (val exclusive)
+  (if exclusive
+      `(,val)
+      val))
+
+(defun bound-< (x y)
+  (cond ((eq x 'pos-inf)
+	 nil)
+	((eq x 'neg-inf)
+	 (not (eq y 'neg-inf)))
+	(t
+	 ;; x is some number
+	 (if (symbolp y)
+	     (not (bound-< y x))
+	     ;; Both x and y are numbers
+	     (let ((xbnd (bound-value x))
+		   (ybnd (bound-value y)))
+	       (or (< xbnd ybnd)
+		   ;; If the bounds are equal, we need to check if the
+		   ;; bounds are exclusive.  The result is true if x is
+		   ;; an inclusive bound but y is not.
+		   (and (= xbnd ybnd)
+			(numberp x)
+			(consp y))))))))
+
+;;; Determine if a bound is less than zero
+
+(defun bound-minusp (b)
+  (bound-< b 0))
+
+;;; Determine if a bound is greater than zero
+
+(defun bound-plusp (b)
+  (not (bound-< b 0)))
+
+;;; Find the sign of a bound
+
+(defun bound-sign (x)
+  (cond ((eq x 'neg-inf)
+	 -1)
+	((eq x 'pos-inf)
+	 1)
+	(t
+	 (signum (bound-value x)))))
+
+;;; Compute the product of two bounds
+
+(defun bound-prod (x y)
+  (cond ((or (symbolp x) (symbolp y))
+	 ;; One of the numbers is infinity.  The result is also infinity.
+	 (if (minusp (* (bound-sign x) (bound-sign y)))
+	     'neg-inf
+	     'pos-inf))
+	(t
+	 ;; The limits are numbers.
+	 (let ((res (* (bound-value x) (bound-value y))))
+	   (set-bound res (or (consp x) (consp y)))))))
+  
+;;; Compute the quotient of two bounds
+
+(defun bound-quot (x y)
+  (cond ((symbolp x)
+	 ;; Infinity divided by anything will be infinity
+	 (bound-prod x y))
+	((symbolp y)
+	 ;; A number divided by infinity is always 0
+	 0)
+	(t
+	 ;; At this point we have the ratio of two numbers.  Watch out
+	 ;; for division by zero!
+	 (cond ((zerop (bound-value y))
+		(if (bound-minusp x)
+		    'neg-inf
+		    'pos-inf))
+	       (t
+		(let ((res (/ (bound-value x) (bound-value y))))
+		  (set-bound res (or (consp x) (consp y)))))))))
+
+;;; Compute the absolute value of a bound.  
+
+(defun bound-abs (x)
+  (if (symbolp x)
+      'pos-inf
+      (set-bound (abs (bound-value x)) (consp x))))
+
+;;; Given a list of float bounds, find the maximum.  If the maximum is
+;;; infinity, return nil instead.
+	     
+(defun max-bound (x y)
+  (if (bound-< x y)
+      y
+      x))
+
+(defun min-bound (x y)
+  (if (bound-< x y)
+      x
+      y))
 
+
+(defun max-bound-list (lst)
+  (nilify-bound (reduce #'max-bound lst)))
+
+(defun min-bound-list (lst)
+  (nilify-bound (reduce #'min-bound lst)))
+
+
+
+#-propagate-float-type
 (defoptimizer (+ derive-type) ((x y))
   (derive-integer-type
    x y
@@ -265,6 +514,29 @@
 	 (values (frob (numeric-type-low x) (numeric-type-low y))
 		 (frob (numeric-type-high x) (numeric-type-high y)))))))
 
+#+propagate-float-type
+(defoptimizer (+ derive-type) ((x y))
+  (derive-real-type
+   x y
+   #'(lambda (x y)
+       (labels ((frob (x y)
+		  (if (and x y)
+		      (set-bound (+ (bound-value x) (bound-value y))
+				 (or (consp x) (consp y)))
+		      nil)))
+	 #|
+	 (debug:backtrace)
+	 (format t "~%+-derive:  ~s ~s~%" x y)
+	 (format t "to ~s ~s~%"
+		 (frob (numeric-type-low x) (numeric-type-low y))
+		 (frob (numeric-type-high x) (numeric-type-high y)))
+	 |#
+	 
+	 (values (frob (numeric-type-low x) (numeric-type-low y))
+		 (frob (numeric-type-high x) (numeric-type-high y)))))))
+
+
+#-propagate-float-type
 (defoptimizer (- derive-type) ((x y))
   (derive-integer-type
    x y
@@ -276,6 +548,20 @@
 	 (values (frob (numeric-type-low x) (numeric-type-high y))
 		 (frob (numeric-type-high x) (numeric-type-low y)))))))
 
+#+propagate-float-type
+(defoptimizer (- derive-type) ((x y))
+  (derive-real-type
+   x y
+   #'(lambda (x y)
+       (labels ((frob (x y)
+		  (if (and x y)
+		      (set-bound (- (bound-value x) (bound-value y))
+				 (or (consp x) (consp y)))
+		      nil)))
+	 (values (frob (numeric-type-low x) (numeric-type-high y))
+		 (frob (numeric-type-high x) (numeric-type-low y)))))))
+
+#-propagate-float-type
 (defoptimizer (* derive-type) ((x y))
   (derive-integer-type
    x y
@@ -298,9 +584,80 @@
 			    (* x-high y-high)
 			    nil))))))))
 
+#+propagate-float-type
+(defoptimizer (* derive-type) ((x y))
+  (let ((same-arg (same-leaf-ref-p x y)))
+    (derive-real-type
+     x y
+     #'(lambda (x y)
+	 (multiple-value-bind (x-low x-high)
+	     (extract-bounds x)
+	   (cond (same-arg
+		  (let ((new-limits (list (bound-prod x-low x-low)
+					  (bound-prod x-high x-high))))
+		    ;; There are two cases to handle: 0 is in
+		    ;; the range and 0 is not.
+		    (cond ((and (bound-minusp x-low)
+				(bound-plusp x-high))
+			   ;; The low limit is 0 and the high
+			   ;; is the max of the square of the
+			   ;; bounds.  
+			   (values 0
+				   (max-bound-list new-limits)))
+			  (t
+			   ;; Since zero is not within the
+			   ;; range, the answer is obvious
+			   (values (min-bound-list new-limits)
+				   (max-bound-list new-limits))))))
+			  (t
+			   (multiple-value-bind (y-low y-high)
+			       (extract-bounds y)
+			     (let ((new-limits (list (bound-prod x-low y-low)
+						     (bound-prod x-low y-high)
+						     (bound-prod x-high y-low)
+						     (bound-prod x-high y-high))))
+			       (values (min-bound-list new-limits)
+				       (max-bound-list new-limits)))))))))))
+
+
+
+#-propagate-float-type
 (defoptimizer (/ derive-type) ((x y))
   (numeric-contagion (continuation-type x) (continuation-type y)))
 
+#+propagate-float-type
+(defoptimizer (/ derive-type) ((top bot))
+  ;; We only handle the case where both of the arguments are
+  ;; floats. Otherwise, the general numeric contagion holds.
+
+  (let ((x-num (continuation-type top))
+	(y-num (continuation-type bot)))
+    (if (not (and (numeric-type-p x-num) (numeric-type-p y-num)
+		  (eq (numeric-type-complexp x-num) :real)
+		  (eq (numeric-type-complexp y-num) :real)
+		  (eq (numeric-type-class x-num) 'float)
+		  (eq (numeric-type-class y-num) 'float)))
+	(numeric-contagion x-num y-num)
+	(derive-real-type
+	 top bot
+	 #'(lambda (x y)
+	     (multiple-value-bind (y-low y-high)
+		 (extract-bounds y)
+	       (cond ((and (bound-minusp y-low)
+			   (bound-plusp y-high))
+		      ;; If 0 is within the bounds of y, the result is
+		      ;; clear: any float is possible for the quotient.
+		      (values nil nil))
+		     (t
+		      (multiple-value-bind (x-low x-high)
+			  (extract-bounds x)
+			(let ((new-limits (list (bound-quot x-low y-low)
+						(bound-quot x-low y-high)
+						(bound-quot x-high y-low)
+						(bound-quot x-high y-high))))
+			  (values (min-bound-list new-limits)
+				  (max-bound-list new-limits))))))))))))
+
 
 (defoptimizer (ash derive-type) ((n shift))
   (or (let ((n-type (continuation-type n)))
@@ -334,6 +691,7 @@
       *universal-type*))
 
 
+#-propagate-float-type
 (macrolet ((frob (fun)
 	     `#'(lambda (type type2)
 		  (declare (ignore type2))
@@ -347,7 +705,24 @@
   (defoptimizer (lognot derive-type) ((int))
     (derive-integer-type int int (frob lognot))))
 
+#+propagate-float-type
+(macrolet ((frob (fun)
+	     `#'(lambda (type type2)
+		  (declare (ignore type2))
+		  (let ((lo (numeric-type-low type))
+			(hi (numeric-type-high type)))
+		    (values (if hi (,fun hi) nil) (if lo (,fun lo) nil))))))
+
+  (defoptimizer (%negate derive-type) ((num))
+    (flet ((negate-bound (b)
+	     (set-bound (- (bound-value b)) (consp b))))
+      (derive-real-type num num (frob negate-bound))))
 
+  (defoptimizer (lognot derive-type) ((int))
+    (derive-integer-type int int (frob lognot))))
+
+
+#-propagate-float-type
 (defoptimizer (abs derive-type) ((num))
   (let ((type (continuation-type num)))
     (if (and (numeric-type-p type)
@@ -367,7 +742,40 @@
 				       nil)))
 	(numeric-contagion type type))))
 
-
+#+propagate-float-type
+(defoptimizer (abs derive-type) ((num))
+  (let ((type (continuation-type num)))
+    (when (numeric-type-p type)
+      (cond ((eq (numeric-type-complexp type) :complex)
+	     ;; The absolute value of a complex number is always a
+	     ;; non-negative float.
+	     (make-numeric-type :class 'float
+				:format (elfun-float-format (numeric-type-format type))
+				:complexp :real
+				:low 0
+				:high nil))
+	    ((eq (numeric-type-complexp type) :real)
+	     ;; The absolute value of a real number is a non-negative
+	     ;; real of the same type.
+	     (let ((lo (numeric-type-low type))
+		   (hi (numeric-type-high type)))
+	       (make-numeric-type :class (numeric-type-class type)
+				  :format (numeric-type-format type)
+				  :complexp :real
+				  :low (cond ((and hi (minusp (bound-value hi)))
+					      (bound-abs hi))
+					     (lo
+					      (set-bound (max 0 (bound-value lo))
+							 (consp lo)))
+					     (t
+					      0))
+				  :high (if (and hi lo)
+					    (max-bound-list (list (bound-abs hi)
+								  (bound-abs lo)))
+					    nil))))))))
+
+
+;; ;; bugged below?? #-propagate-float-type)
 (defoptimizer (truncate derive-type) ((number divisor))
   (let ((number-type (continuation-type number))
 	(divisor-type (continuation-type divisor))
@@ -387,6 +795,54 @@
 					      divisor-low divisor-high))))
 	*universal-type*)))
 
+#+propagate-float-type
+(progn
+#+nil
+(defoptimizer (truncate derive-type) ((number divisor))
+  (let ((number-type (continuation-type number))
+	(divisor-type (continuation-type divisor))
+	(integer-type (specifier-type '(or integer real))))
+    (if (and (numeric-type-p number-type)
+	     (csubtypep number-type integer-type)
+	     (numeric-type-p divisor-type)
+	     (csubtypep divisor-type integer-type))
+	(let ((number-low (numeric-type-low number-type))
+	      (number-high (numeric-type-high number-type))
+	      (divisor-low (numeric-type-low divisor-type))
+	      (divisor-high (numeric-type-high divisor-type)))
+	  (setf number-low (if (consp number-low) (car number-low) number-low))
+	  (setf number-high (if (consp number-high) (car number-high) number-high))
+	  (setf divisor-low (if (consp divisor-low) (car divisor-low) divisor-low))
+	  (setf divisor-high (if (consp divisor-high) (car divisor-high) divisor-high))
+	  (if (csubtypep number-type (specifier-type 'integer))
+	      (values-specifier-type
+	       `(values ,(integer-truncate-derive-type number-low number-high
+						       divisor-low divisor-high)
+		        ,(integer-rem-derive-type number-low number-high
+						  divisor-low divisor-high)))
+	      (values-specifier-type
+	       `(values ,(integer-truncate-derive-type number-low number-high
+						       divisor-low divisor-high)
+		        ,(real-rem-derive-type number-low number-high
+					       divisor-low divisor-high)))))
+	*universal-type*)))
+
+(defoptimizer (%unary-truncate derive-type) ((number))
+  (let ((number-type (continuation-type number)))
+    (if (and (numeric-type-p number-type)
+	     (csubtypep number-type (specifier-type 'real)))
+	(let ((number-low (numeric-type-low number-type))
+	      (number-high (numeric-type-high number-type)))
+	  (setf number-low (if (consp number-low) (car number-low) number-low))
+	  (setf number-high (if (consp number-high) (car number-high) number-high))
+	  (values-specifier-type
+	   `(values ,(integer-truncate-derive-type number-low number-high 1 1)
+	     ,(real-rem-derive-type number-low number-high 1 1))))
+	*universal-type*)))
+)
+
+
+
 ;;; NUMERIC-RANGE-INFO  --  internal.
 ;;;
 ;;; Derive useful information about the range.  Returns three values:
@@ -404,6 +860,7 @@
 
 ;;; INTEGER-TRUNCATE-DERIVE-TYPE -- internal
 ;;; 
+#-propagate-float-type
 (defun integer-truncate-derive-type
        (number-low number-high divisor-low divisor-high)
   ;; The result cannot be larger in magnitude than the number, but the sign
@@ -467,7 +924,7 @@
 	     ;; The number we are dividing is unbounded, so we can't tell
 	     ;; anything about the result.
 	     'integer)))))
-	  
+
 (defun integer-rem-derive-type
        (number-low number-high divisor-low divisor-high)
   (if (and divisor-low divisor-high)
@@ -497,6 +954,106 @@
 		     0
 		     '*))))
 
+#+propagate-float-type
+(progn
+(defun integer-truncate-derive-type
+       (number-low number-high divisor-low divisor-high)
+  ;; The result cannot be larger in magnitude than the number, but the sign
+  ;; might change.  If we can determine the sign of either the number or
+  ;; the divisor, we can eliminate some of the cases.
+  (multiple-value-bind
+      (number-sign number-min number-max)
+      (numeric-range-info number-low number-high)
+    (multiple-value-bind
+	(divisor-sign divisor-min divisor-max)
+	(numeric-range-info divisor-low divisor-high)
+      (when (and divisor-max (zerop divisor-max))
+	;; We've got a problem: guarenteed division by zero.
+	(return-from integer-truncate-derive-type t))
+      (when (zerop divisor-min)
+	;; We'll assume that they arn't going to divide by zero.
+	(if (integerp divisor-min)
+	    (incf divisor-min)
+	    (incf divisor-min (if (typep divisor-min 'single-float)
+				  least-positive-normalized-single-float
+				  least-positive-normalized-double-float))))
+      (cond ((and number-sign divisor-sign)
+	     ;; We know the sign of both.
+	     (if (eq number-sign divisor-sign)
+		 ;; Same sign, so the result will be positive.
+		 `(integer ,(if divisor-max
+				(truncate number-min divisor-max)
+				0)
+			   ,(if number-max
+				(truncate number-max divisor-min)
+				'*))
+		 ;; Different signs, the result will be negative.
+		 `(integer ,(if number-max
+				(- (truncate number-max divisor-min))
+				'*)
+			   ,(if divisor-max
+				(- (truncate number-min divisor-max))
+				0))))
+	    ((eq divisor-sign '+)
+	     ;; The divisor is positive.  Therefore, the number will just
+	     ;; become closer to zero.
+	     `(integer ,(if number-low
+			    (truncate number-low divisor-min)
+			    '*)
+		       ,(if number-high
+			    (truncate number-high divisor-min)
+			    '*)))
+	    ((eq divisor-sign '-)
+	     ;; The divisor is negative.  Therefore, the absolute value of
+	     ;; the number will become closer to zero, but the sign will also
+	     ;; change.
+	     `(integer ,(if number-high
+			    (- (truncate number-high divisor-min))
+			    '*)
+		       ,(if number-low
+			    (- (truncate number-low divisor-min))
+			    '*)))
+	    ;; The divisor could be either positive or negative.
+	    (number-max
+	     ;; The number we are dividing has a bound.  Divide that by the
+	     ;; smallest posible divisor.
+	     (let ((bound (truncate number-max divisor-min)))
+	       `(integer ,(- bound) ,bound)))
+	    (t
+	     ;; The number we are dividing is unbounded, so we can't tell
+	     ;; anything about the result.
+	     'integer)))))
+	  
+(defun real-rem-derive-type
+       (number-low number-high divisor-low divisor-high)
+  (if (and divisor-low divisor-high)
+      ;; We know the range of the divisor, and the remainder must be smaller
+      ;; than the divisor.  We can tell the sign of the remainer if we know
+      ;; the sign of the number.
+      (let ((divisor-max (float (max (abs divisor-low) (abs divisor-high)))))
+	`(float ,(if (or (null number-low)
+			   (minusp number-low))
+		       (- divisor-max)
+		       0.0)
+		  ,(if (or (null number-high)
+			   (plusp number-high))
+		       divisor-max
+		       0.0)))
+      ;; The divisor is potentially either very positive or very negative.
+      ;; Therefore, the remainer is unbounded, but we might be able to tell
+      ;; something about the sign from the number.
+      `(float ,(if (and number-low (not (minusp number-low)))
+		     ;; The number we are dividing is positive.  Therefore,
+		     ;; the remainder must be positive.
+		     0.0
+		     '*)
+		,(if (and number-high (not (plusp number-high)))
+		     ;; The number we are dividing is negative.  Therefore,
+		     ;; the remainder must be negative.
+		     0.0
+		     '*))))
+)
+
 (defoptimizer (random derive-type) ((bound &optional state))
   (let ((type (continuation-type bound)))
     (when (numeric-type-p type)
@@ -1281,6 +1838,7 @@
 ;;; Y's high, the X >= Y (so return NIL).  If not, at least make sure any
 ;;; constant arg is second.
 ;;;
+#-propagate-float-type
 (defun ir1-transform-< (x y first second inverse)
   (if (same-leaf-ref-p x y)
       'nil
@@ -1300,6 +1858,28 @@
 	      (t
 	       (give-up))))))
 	      
+#+propagate-float-type
+(defun ir1-transform-< (x y first second inverse)
+  (if (same-leaf-ref-p x y)
+      'nil
+      (let* ((x-type (numeric-type-or-lose x))
+	     (y-type (numeric-type-or-lose y)))
+	#+nil
+	(format t "ir1-trans-<:~%  ~s~%  ~s~%" x-type y-type)
+	(multiple-value-bind (x-lo x-hi)
+	    (extract-bounds x-type)
+	  (multiple-value-bind (y-lo y-hi)
+	      (extract-bounds y-type)
+	    (cond ((bound-< x-hi y-lo)
+		   't)
+		  ((bound-< y-hi x-lo)
+		   'nil)
+		  ((and (constant-continuation-p first)
+			(not (constant-continuation-p second)))
+		   `(,inverse y x))
+		  (t
+		   (give-up))))))))
+	      
 
 (deftransform < ((x y) (integer integer) * :when :both)
   (ir1-transform-< x y x y '>))
@@ -1307,6 +1887,15 @@
 (deftransform > ((x y) (integer integer) * :when :both)
   (ir1-transform-< y x x y '<))
 
+#+propagate-float-type
+(deftransform < ((x y) (float float) * :when :both)
+  (ir1-transform-< x y x y '>))
+
+#+propagate-float-type
+(deftransform > ((x y) (float float) * :when :both)
+  (ir1-transform-< y x x y '<))
+
+  
 
 ;;;; Converting N-arg comparisons:
 ;;;
@@ -1546,3 +2135,6 @@
        (declare (ignore tee))
        (funcall control *standard-output* ,@arg-names)
        nil)))
+
+
+
diff --git a/compiler/x86/alloc.lisp b/compiler/x86/alloc.lisp
new file mode 100644
index 000000000..0f8729efc
--- /dev/null
+++ b/compiler/x86/alloc.lisp
@@ -0,0 +1,268 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/alloc.lisp,v 1.1 1997/01/18 14:31:20 ram Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; Allocation VOPs for the x86 port.
+;;;
+;;; Written by William Lott.
+;;;
+;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
+;;; 
+
+(in-package :x86)
+
+
+;;;; LIST and LIST*
+
+(define-vop (list-or-list*)
+  (:args (things :more t))
+  (:temporary (:sc dword-reg) ptr temp)
+  (:temporary (:sc dword-reg :to (:result 0) :target result) res)
+  (:info num)
+  (:results (result :scs (descriptor-reg)))
+  (:variant-vars star)
+  (:policy :safe)
+  (:generator 0
+    (cond ((zerop num)
+	   ;; (move result nil-value)
+	   (inst mov result nil-value))
+	  ((and star (= num 1))
+	   (move result (tn-ref-tn things)))
+	  (t
+	   (macrolet
+	       ((store-car (tn list &optional (slot vm:cons-car-slot))
+		  `(let ((reg
+			  (sc-case ,tn
+			    ((any-reg descriptor-reg) ,tn)
+			    ((descriptor-stack immediate-stack)
+			     (move temp ,tn)
+			     temp))))
+		     (storew reg ,list ,slot vm:list-pointer-type))))
+	     (let ((cons-cells (if star (1- num) num)))
+	       #-cgc
+	       (with-allocation (temp)
+		 (inst lea res
+		       (make-ea :byte :base temp :disp list-pointer-type))
+		 (inst add temp (* (pad-data-block cons-size) cons-cells)))
+	       #+cgc
+	       (with-cgc-allocation (temp (* (pad-data-block cons-size)
+					     cons-cells))
+		 (inst lea res
+		       (make-ea :byte :base temp :disp list-pointer-type)))
+	       (move ptr res)
+	       (dotimes (i (1- cons-cells))
+		 (store-car (tn-ref-tn things) ptr)
+		 (setf things (tn-ref-across things))
+		 (inst add ptr (pad-data-block cons-size))
+		 (storew ptr ptr (- cons-cdr-slot cons-size)
+			 list-pointer-type))
+	       (store-car (tn-ref-tn things) ptr)
+	       (cond (star
+		      (setf things (tn-ref-across things))
+		      (store-car (tn-ref-tn things) ptr cons-cdr-slot))
+		     (t
+		      (storew nil-value ptr cons-cdr-slot
+			      list-pointer-type)))
+	       (assert (null (tn-ref-across things)))))
+	   (move result res)))))
+
+(define-vop (list list-or-list*)
+  (:variant nil))
+
+(define-vop (list* list-or-list*)
+  (:variant t))
+
+
+;;;; Special purpose inline allocators.
+
+(define-vop (allocate-code-object)
+  (:args (boxed-arg :scs (any-reg) :target boxed)
+	 (unboxed-arg :scs (any-reg) :target unboxed))
+  (:results (result :scs (descriptor-reg)))
+  (:temporary (:sc dword-reg :from :eval) temp)
+  (:temporary (:sc dword-reg :from (:argument 0)) boxed)
+  (:temporary (:sc dword-reg :from (:argument 1)) unboxed)
+  (:generator 100
+    (move boxed boxed-arg)
+    (inst add boxed (fixnum (1+ code-trace-table-offset-slot)))
+    (inst and boxed (lognot lowtag-mask))
+    (move unboxed unboxed-arg)
+    (inst shr unboxed word-shift)
+    (inst add unboxed lowtag-mask)
+    (inst and unboxed (lognot lowtag-mask))
+    #+nil ;; keep this here in case we load code in dynamic again
+    (with-allocation (temp)
+      (inst lea result (make-ea :byte :base temp :disp other-pointer-type))
+      (inst add temp boxed)
+      (inst add temp unboxed))
+    (progn ;; now loading code into static space cause it can't move
+      (load-symbol-value temp lisp::*static-space-free-pointer*)
+      (inst lea result (make-ea :byte :base temp :disp other-pointer-type))
+      (inst add temp boxed)
+      (inst add temp unboxed)
+      (store-symbol-value temp lisp::*static-space-free-pointer*))
+    (inst shl boxed (- type-bits word-shift))
+    (inst or boxed code-header-type)
+    (storew boxed result 0 other-pointer-type)
+    (storew unboxed result code-code-size-slot other-pointer-type)
+    ;; (move temp nil-value)
+    (inst mov temp nil-value)
+    (storew temp result code-entry-points-slot other-pointer-type)
+    (storew temp result code-debug-info-slot other-pointer-type)))
+
+;;; Top-Level-Forms have a short lifetime as they are unreachable
+;;; once the loader eval's them. No point loading them in static
+;;; space. This justs gives the loader a way to grab a chunk
+;;; of the dynamic heap.
+(define-vop (allocate-dynamic-code-object)
+  (:args (boxed-arg :scs (any-reg) :target boxed)
+	 (unboxed-arg :scs (any-reg) :target unboxed))
+  (:results (result :scs (descriptor-reg)))
+  (:temporary (:sc dword-reg :from :eval) temp)
+  (:temporary (:sc dword-reg :from (:argument 0)) boxed)
+  (:temporary (:sc dword-reg :from (:argument 1)) unboxed)
+  (:generator 100
+    (move boxed boxed-arg)
+    (inst add boxed (fixnum (1+ code-trace-table-offset-slot)))
+    (inst and boxed (lognot lowtag-mask))
+    (move unboxed unboxed-arg)
+    (inst shr unboxed word-shift)
+    (inst add unboxed lowtag-mask)
+    (inst and unboxed (lognot lowtag-mask))
+    #-cgc
+    (with-allocation (temp)
+      (inst lea result (make-ea :byte :base temp :disp other-pointer-type))
+      (inst add temp boxed)
+      (inst add temp unboxed))
+    #+cgc
+    (progn 
+      (move temp boxed)
+      (inst add temp unboxed)
+      (with-cgc-allocation (temp temp)
+	(inst lea result (make-ea :byte :base temp :disp other-pointer-type))))
+    (inst shl boxed (- type-bits word-shift))
+    (inst or boxed code-header-type)
+    (storew boxed result 0 other-pointer-type)
+    (storew unboxed result code-code-size-slot other-pointer-type)
+    (inst mov temp nil-value)
+    (storew temp result code-entry-points-slot other-pointer-type)
+    (storew temp result code-debug-info-slot other-pointer-type)))
+
+(define-vop (make-fdefn)
+  (:policy :fast-safe)
+  (:translate make-fdefn)
+  (:args (name :scs (descriptor-reg) :to :eval))
+  (:temporary (:sc dword-reg) alloc)
+  (:results (result :scs (descriptor-reg) :from :argument))
+  (:generator 37
+    (with-fixed-allocation (result alloc fdefn-type fdefn-size)
+      (storew name result fdefn-name-slot other-pointer-type)
+      (storew nil-value result fdefn-function-slot other-pointer-type)
+      (storew (make-fixup (extern-alien-name "undefined_tramp") :foreign) result
+	      fdefn-raw-addr-slot other-pointer-type))))
+
+
+(define-vop (make-closure)
+	    (:args (function :to :save :scs (descriptor-reg)))
+  (:info length)
+  (:temporary (:sc any-reg) temp)
+  (:results (result :scs (descriptor-reg)))
+  (:generator 10
+   (let ((size (+ length closure-info-offset)))
+     #-cgc
+     (with-allocation (temp)
+       (inst lea result (make-ea :byte :base temp :disp function-pointer-type))
+       (inst add temp (pad-data-block size))
+       (storew 0 temp 0)
+       (storew (logior (ash (1- size) type-bits) closure-header-type)
+	       result 0 function-pointer-type))
+     #+cgc
+     (with-cgc-allocation(temp (pad-data-block size))
+       (inst lea result
+	     (make-ea :byte :base temp :disp function-pointer-type))
+       (storew (logior (ash (1- size) type-bits) closure-header-type)
+	       temp 0))
+     
+     (loadw temp function closure-function-slot function-pointer-type)
+     (storew temp result closure-function-slot function-pointer-type))))
+
+;;; The compiler likes to be able to directly make value cells.
+;;; 
+(define-vop (make-value-cell)
+  (:args (value :to :save :scs (descriptor-reg any-reg)))
+  (:temporary (:sc any-reg) temp)
+  (:results (result :scs (descriptor-reg)))
+  (:generator 10
+    (with-fixed-allocation
+	(result temp value-cell-header-type value-cell-size))
+    (storew value result value-cell-value-slot other-pointer-type)))
+
+
+
+;;;; Automatic allocators for primitive objects.
+
+(define-vop (make-unbound-marker)
+  (:args)
+  (:results (result :scs (any-reg)))
+  (:generator 1
+    (inst mov result unbound-marker-type)))
+
+(define-vop (fixed-alloc)
+  (:args)
+  (:info name words type lowtag)
+  (:ignore name)
+  (:results (result :scs (descriptor-reg)))
+  (:temporary (:sc descriptor-reg) temp)
+  (:generator #-cgc 4 #+cgc 50
+    #-cgc
+    (with-allocation(temp)		; dynamic free ptr
+      (inst lea result (make-ea :byte :base temp :disp lowtag))
+      (inst add temp (pad-data-block words))
+      (storew 0 temp 0 0))
+    #+cgc
+    (with-cgc-allocation(temp (pad-data-block words))
+      (inst lea result (make-ea :byte :base temp :disp lowtag)))
+
+    (when type				; dunno what this does yet
+      (inst mov temp (logior (ash (1- words) type-bits) type))
+      (storew temp result 0 lowtag))))
+
+(define-vop (var-alloc)
+    (:args (extra :scs (any-reg)))
+  (:arg-types positive-fixnum)
+  (:info name words type lowtag)
+  (:ignore name)
+  (:results (result :scs (descriptor-reg)))
+  (:temporary (:sc any-reg) bytes header alloc)
+  (:generator #-cgc 6 #+cgc 50
+    (inst lea bytes
+	  (make-ea :dword :base extra :disp (* (1+ words) word-bytes)))
+    (inst mov header bytes)
+    (inst shl header (- type-bits 2))	; w+1 to length field
+    
+    (inst lea header			; (w-1 << 8) | type
+	  (make-ea :dword :base header :disp (+ (ash -2 type-bits) type)))
+    (inst and bytes (lognot lowtag-mask))
+    #-cgc
+    (with-allocation (alloc)
+      (inst lea result (make-ea :byte :base alloc :disp lowtag))
+      (storew header result 0 lowtag)
+      (inst add alloc bytes)
+      (storew 0 alloc 0))
+    ;; Note that the above inst stores into the free space which
+    ;; is probably already zeroed. It is a lose in the cgc case because
+    ;; it might trash the next region header.
+    #+cgc
+    (with-cgc-allocation (alloc bytes)
+      (inst lea result (make-ea :byte :base alloc :disp lowtag))
+      (storew header result 0 lowtag))))
+
diff --git a/compiler/x86/arith.lisp b/compiler/x86/arith.lisp
new file mode 100644
index 000000000..cebeffede
--- /dev/null
+++ b/compiler/x86/arith.lisp
@@ -0,0 +1,1047 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/arith.lisp,v 1.1 1997/01/18 14:31:24 ram Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the VM definition arithmetic VOPs for the x86.
+;;;
+;;; Written by William Lott.
+;;;
+;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
+;;; 
+
+(in-package :x86)
+
+
+
+;;;; Unary operations.
+
+(define-vop (fast-safe-arith-op)
+  (:policy :fast-safe)
+  (:effects)
+  (:affected))
+
+
+(define-vop (fixnum-unop fast-safe-arith-op)
+  (:args (x :scs (any-reg) :target res))
+  (:results (res :scs (any-reg)))
+  (:note "inline fixnum arithmetic")
+  (:arg-types tagged-num)
+  (:result-types tagged-num))
+
+(define-vop (signed-unop fast-safe-arith-op)
+  (:args (x :scs (signed-reg) :target res))
+  (:results (res :scs (signed-reg)))
+  (:note "inline (signed-byte 32) arithmetic")
+  (:arg-types signed-num)
+  (:result-types signed-num))
+
+(define-vop (fast-negate/fixnum fixnum-unop)
+  (:translate %negate)
+  (:generator 1
+    (move res x)
+    (inst neg res)))
+
+(define-vop (fast-negate/signed signed-unop)
+  (:translate %negate)
+  (:generator 2
+    (move res x)
+    (inst neg res)))
+
+(define-vop (fast-lognot/fixnum fixnum-unop)
+  (:translate lognot)
+  (:generator 2
+    (move res x)
+    (inst xor res (fixnum -1))))
+
+(define-vop (fast-lognot/signed signed-unop)
+  (:translate lognot)
+  (:generator 1
+    (move res x)
+    (inst not res)))
+
+
+
+;;;; Binary fixnum operations.
+
+;;; Assume that any constant operand is the second arg...
+
+(define-vop (fast-fixnum-binop fast-safe-arith-op)
+  (:args (x :target r :scs (any-reg)
+	    :load-if (not (and (sc-is x immediate-stack)
+			       (sc-is y any-reg)
+			       (location= x r))))
+	 (y :scs (any-reg immediate-stack)))
+  (:arg-types tagged-num tagged-num)
+  (:results (r :scs (any-reg) :from (:argument 0)
+	       :load-if (not (and (sc-is x immediate-stack)
+				  (sc-is y any-reg)
+				  (location= x r)))))
+  (:result-types tagged-num)
+  (:note "inline fixnum arithmetic"))
+
+(define-vop (fast-unsigned-binop fast-safe-arith-op)
+  (:args (x :target r :scs (unsigned-reg)
+	    :load-if (not (and (sc-is x unsigned-stack)
+			       (sc-is y unsigned-reg)
+			       (location= x r))))
+	 (y :scs (unsigned-reg unsigned-stack)))
+  (:arg-types unsigned-num unsigned-num)
+  (:results (r :scs (unsigned-reg) :from (:argument 0)
+	    :load-if (not (and (sc-is x unsigned-stack)
+			       (sc-is y unsigned-reg)
+			       (location= x r)))))
+  (:result-types unsigned-num)
+  (:note "inline (unsigned-byte 32) arithmetic"))
+
+(define-vop (fast-signed-binop fast-safe-arith-op)
+  (:args (x :target r :scs (signed-reg)
+	    :load-if (not (and (sc-is x signed-stack)
+			       (sc-is y signed-reg)
+			       (location= x r))))
+	 (y :scs (signed-reg signed-stack)))
+  (:arg-types signed-num signed-num)
+  (:results (r :scs (signed-reg) :from (:argument 0)
+	    :load-if (not (and (sc-is x signed-stack)
+			       (sc-is y signed-reg)
+			       (location= x r)))))
+  (:result-types signed-num)
+  (:note "inline (signed-byte 32) arithmetic"))
+
+(define-vop (fast-fixnum-binop-c fast-safe-arith-op)
+  (:args (x :target r :scs (any-reg immediate-stack)))
+  (:info y)
+  (:arg-types tagged-num (:constant (signed-byte 30)))
+  (:results (r :scs (any-reg)
+	       :load-if (not (location= x r))))
+  (:result-types tagged-num)
+  (:note "inline fixnum arithmetic"))
+
+(define-vop (fast-unsigned-binop-c fast-safe-arith-op)
+  (:args (x :target r :scs (unsigned-reg unsigned-stack)))
+  (:info y)
+  (:arg-types unsigned-num (:constant (unsigned-byte 32)))
+  (:results (r :scs (unsigned-reg)
+	       :load-if (not (location= x r))))
+  (:result-types unsigned-num)
+  (:note "inline (unsigned-byte 32) arithmetic"))
+
+(define-vop (fast-signed-binop-c fast-safe-arith-op)
+  (:args (x :target r :scs (signed-reg signed-stack)))
+  (:info y)
+  (:arg-types signed-num (:constant (signed-byte 32)))
+  (:results (r :scs (signed-reg)
+	       :load-if (not (location= x r))))
+  (:result-types signed-num)
+  (:note "inline (signed-byte 32) arithmetic"))
+
+
+(eval-when (compile load eval)
+
+(defmacro define-binop (translate untagged-penalty op)
+  `(progn
+     (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
+		  fast-fixnum-binop)
+       (:translate ,translate)
+       (:generator 2
+	 (move r x)
+	 (inst ,op r y)))
+     (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
+		  fast-fixnum-binop-c)
+       (:translate ,translate)
+       (:generator 1
+	 (move r x)
+	 (inst ,op r (fixnum y))))
+     (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
+		  fast-signed-binop)
+       (:translate ,translate)
+       (:generator ,(1+ untagged-penalty)
+	 (move r x)
+	 (inst ,op r y)))
+     (define-vop (,(symbolicate 'fast- translate '-c/signed=>signed)
+		  fast-signed-binop-c)
+       (:translate ,translate)
+       (:generator ,untagged-penalty
+	 (move r x)
+	 (inst ,op r y)))
+     (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED")
+		  fast-unsigned-binop)
+       (:translate ,translate)
+       (:generator ,(1+ untagged-penalty)
+	 (move r x)
+	 (inst ,op r y)))
+     (define-vop (,(symbolicate 'fast- translate '-c/unsigned=>unsigned)
+		  fast-unsigned-binop-c)
+       (:translate ,translate)
+       (:generator ,untagged-penalty
+	 (move r x)
+	 (inst ,op r y)))))
+
+); eval-when
+
+
+
+;(define-binop + 4 add)
+(define-binop - 4 sub)
+(define-binop logand 2 and)
+(define-binop logior 2 or)
+(define-binop logxor 2 xor)
+
+
+;;; Special handling of add on the x86; can use lea to avoid a
+;;; register load, otherwise it uses add.
+(define-vop (fast-+/fixnum=>fixnum fast-safe-arith-op)
+  (:translate +)
+  (:args (x :target r :scs (any-reg)
+	    :load-if (not (and (sc-is x immediate-stack)
+			       (sc-is y any-reg)
+			       (location= x r))))
+	 (y :scs (any-reg immediate-stack)))
+  (:arg-types tagged-num tagged-num)
+  (:results (r :scs (any-reg) :from (:argument 0)
+	       :load-if (not (and (sc-is x immediate-stack)
+				  (sc-is y any-reg)
+				  (location= x r)))))
+  (:result-types tagged-num)
+  (:note "inline fixnum arithmetic")
+  (:generator 2
+    (if (and (sc-is x any-reg)
+	     (sc-is y any-reg)
+	     (sc-is r any-reg)
+	     (not (location= x r)))
+	(inst lea r (make-ea :dword :base x :index y :scale 1))
+      (progn
+	(move r x)
+	(inst add r y)))))
+
+(define-vop (fast-+-c/fixnum=>fixnum fast-safe-arith-op)
+  (:translate +)
+  (:args (x :target r :scs (any-reg immediate-stack)))
+  (:info y)
+  (:arg-types tagged-num (:constant (signed-byte 30)))
+  (:results (r :scs (any-reg)
+	       :load-if (not (location= x r))))
+  (:result-types tagged-num)
+  (:note "inline fixnum arithmetic")
+  (:generator 1
+    (if (and (sc-is x any-reg)
+	     (sc-is r any-reg)
+	     (not (location= x r)))
+	(inst lea r (make-ea :dword :base x :disp (fixnum y)))
+      (progn
+	(move r x)
+	(inst add r (fixnum y))))))
+
+(define-vop (fast-+/signed=>signed fast-safe-arith-op)
+  (:translate +)
+  (:args (x :target r :scs (signed-reg)
+	    :load-if (not (and (sc-is x signed-stack)
+			       (sc-is y signed-reg)
+			       (location= x r))))
+	 (y :scs (signed-reg signed-stack)))
+  (:arg-types signed-num signed-num)
+  (:results (r :scs (signed-reg) :from (:argument 0)
+	       :load-if (not (and (sc-is x signed-stack)
+				  (sc-is y signed-reg)
+				  (location= x r)))))
+  (:result-types signed-num)
+  (:note "inline (signed-byte 32) arithmetic")
+  (:generator 5
+    (if (and (sc-is x signed-reg)
+	     (sc-is y signed-reg)
+	     (sc-is r signed-reg)
+	     (not (location= x r)))
+	(inst lea r (make-ea :dword :base x :index y :scale 1))
+      (progn
+	(move r x)
+	(inst add r y)))))
+
+(define-vop (fast-+-c/signed=>signed fast-safe-arith-op)
+  (:translate +)
+  (:args (x :target r :scs (signed-reg signed-stack)))
+  (:info y)
+  (:arg-types signed-num (:constant (signed-byte 32)))
+  (:results (r :scs (signed-reg)
+	       :load-if (not (location= x r))))
+  (:result-types signed-num)
+  (:note "inline (signed-byte 32) arithmetic")
+  (:generator 4
+    (if (and (sc-is x signed-reg)
+	     (sc-is r signed-reg)
+	     (not (location= x r)))
+	(inst lea r (make-ea :dword :base x :disp y))
+      (progn
+	(move r x)
+	(inst add r y)))))
+
+(define-vop (fast-+/unsigned=>unsigned fast-safe-arith-op)
+  (:translate +)
+  (:args (x :target r :scs (unsigned-reg)
+	    :load-if (not (and (sc-is x unsigned-stack)
+			       (sc-is y unsigned-reg)
+			       (location= x r))))
+	 (y :scs (unsigned-reg unsigned-stack)))
+  (:arg-types unsigned-num unsigned-num)
+  (:results (r :scs (unsigned-reg) :from (:argument 0)
+	       :load-if (not (and (sc-is x unsigned-stack)
+				  (sc-is y unsigned-reg)
+				  (location= x r)))))
+  (:result-types unsigned-num)
+  (:note "inline (unsigned-byte 32) arithmetic")
+  (:generator 5
+    (if (and (sc-is x unsigned-reg)
+	     (sc-is y unsigned-reg)
+	     (sc-is r unsigned-reg)
+	     (not (location= x r)))
+	(inst lea r (make-ea :dword :base x :index y :scale 1))
+      (progn
+	(move r x)
+	(inst add r y)))))
+
+(define-vop (fast-+-c/unsigned=>unsigned fast-safe-arith-op)
+  (:translate +)
+  (:args (x :target r :scs (unsigned-reg unsigned-stack)))
+  (:info y)
+  (:arg-types unsigned-num (:constant (unsigned-byte 32)))
+  (:results (r :scs (unsigned-reg)
+	       :load-if (not (location= x r))))
+  (:result-types unsigned-num)
+  (:note "inline (unsigned-byte 32) arithmetic")
+  (:generator 4
+    (if (and (sc-is x unsigned-reg)
+	     (sc-is r unsigned-reg)
+	     (not (location= x r)))
+	(inst lea r (make-ea :dword :base x :disp y))
+      (progn
+	(move r x)
+	(inst add r y)))))
+
+
+;;;; Multiplication and division.
+
+(define-vop (fast-*/fixnum=>fixnum fast-safe-arith-op)
+  (:translate *)
+  ;; We need different loading characteristics.
+  (:args (x :scs (any-reg immediate-stack) :target r)
+	 (y :scs (any-reg immediate-stack)))
+  (:arg-types tagged-num tagged-num)
+  (:results (r :scs (any-reg) :from (:argument 0)))
+  (:result-types tagged-num)
+  (:note "inline fixnum arithmetic")
+  (:generator 20
+    (move r x)
+    (inst sar r 2)
+    (inst imul r y)))
+
+(define-vop (fast-*/fixnum=>fixnum-c fast-safe-arith-op)
+  (:translate *)
+  ;; We need different loading characteristics.
+  (:args (x :target r :scs (any-reg immediate-stack)))
+  (:info y)
+  (:arg-types tagged-num (:constant (signed-byte 30)))
+  (:results (r :scs (any-reg)))
+  (:result-types tagged-num)
+  (:note "inline fixnum arithmetic")
+  (:generator 18
+    (inst imul r x y)))
+
+(define-vop (fast-*/signed=>signed fast-safe-arith-op)
+  (:translate *)
+  ;; We need different loading characteristics.
+  (:args (x :scs (signed-reg signed-stack) :target r)
+	 (y :scs (signed-reg signed-stack)))
+  (:arg-types signed-num signed-num)
+  (:results (r :scs (signed-reg) :from (:argument 0)))
+  (:result-types signed-num)
+  (:note "inline (signed-byte 32) arithmetic")
+  (:generator 25
+    (move r x)
+    (inst imul r y)))
+
+(define-vop (fast-*/signed=>signed-c fast-safe-arith-op)
+  (:translate *)
+  ;; We need different loading characteristics.
+  (:args (x :target r :scs (signed-reg signed-stack)))
+  (:info y)
+  (:arg-types signed-num (:constant (signed-byte 32)))
+  (:results (r :scs (signed-reg)))
+  (:result-types signed-num)
+  (:note "inline (signed-byte 32) arithmetic")
+  (:generator 23
+    (inst imul r x y)))
+
+
+(define-vop (fast-truncate/signed=>signed fast-safe-arith-op)
+  (:translate truncate)
+  (:args (x :scs (signed-reg signed-stack) :target eax)
+	 (y :scs (signed-reg signed-stack)))
+  (:arg-types signed-num signed-num)
+  (:temporary (:sc dword-reg :offset eax-offset :target quo
+		   :from (:argument 0) :to (:result 0))
+	      eax)
+  (:temporary (:sc dword-reg :offset edx-offset :target rem
+		   :from (:argument 0) :to (:result 1))
+	      edx)
+  (:results (quo :scs (signed-reg signed-stack))
+	    (rem :scs (signed-reg signed-stack)))
+  (:result-types signed-num signed-num)
+  (:note "inline (signed-byte 32) arithmetic")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 30
+    (let ((zero (generate-error-code vop division-by-zero-error x y)))
+      (inst cmp y 0)
+      (inst jmp :eq zero))
+    (move eax x)
+    (inst cdq)
+    (inst idiv eax y)
+    (move quo eax)
+    (move rem edx)))
+
+
+
+;;;; Shifting
+(define-vop (fast-ash-c)
+  (:policy :fast-safe)
+  (:translate ash)
+  (:note nil)
+  (:args (number :scs (signed-reg unsigned-reg) :target result))
+  (:info amount)
+  (:arg-types (:or signed-num unsigned-num) (:constant integer))
+  (:results (result :scs (signed-reg unsigned-reg)))
+  (:result-types (:or signed-num unsigned-num))
+  (:generator 2
+    (cond ((and (= amount 1)
+		(not (location= number result)))
+	   (inst lea result (make-ea :dword :index number :scale 2)))
+	  ((and (= amount 2)
+		(not (location= number result)))
+	   (inst lea result (make-ea :dword :index number :scale 4)))
+	  ((and (= amount 3)
+		(not (location= number result)))
+	   (inst lea result (make-ea :dword :index number :scale 8)))
+	  (t
+	   (move result number)
+	   (cond ((plusp amount)
+		  ;; We don't have to worry about overflow because of the
+		  ;; result type restriction.
+		  (inst shl result amount))
+		 ((sc-is number signed-reg)
+		  ;; If the amount is greater than 31, only shift by 31.  We
+		  ;; have to do this because the shift instructions only look
+		  ;; at the low five bits of the result.
+		  (inst sar result (min 31 (- amount))))
+		 (t
+		  (inst shr result (min 31 (- amount)))))))))
+
+;; has problems when result is on stack -- maybe not spec'e right?
+;; targeting still not understood -- target number<>result seems ok now
+;; but extra moves required for amount.
+;; Problem shows up in code/type.lisp TYPE/=
+(define-vop (fast-ash-left)
+  (:note "inline ASH")
+  (:args (number :scs (signed-reg unsigned-reg)
+		 :target result
+		 :load-if
+		 (not (and (sc-is number signed-stack unsigned-stack)
+				    (location= number result))))
+	 (amount :scs (unsigned-reg) :target ecx))
+  (:arg-types (:or signed-num unsigned-num) positive-fixnum)
+  (:temporary (:sc dword-reg :offset ecx-offset :from (:argument 1)) ecx)
+  (:results (result :scs (signed-reg unsigned-reg)
+		    :from (:argument 0)
+		    :load-if
+		    (not (and (sc-is result signed-stack unsigned-stack)
+			      (location= number result)))))
+  (:result-types (:or signed-num unsigned-num))
+  (:translate ash)
+  (:policy :fast-safe)
+  (:generator 3
+    (move result number)
+    (move ecx amount)
+    ;; The result-type assures us that this shift will not overflow.
+    (inst shl result :cl)))
+
+
+(define-vop (fast-ash)
+  (:policy :fast-safe)
+  (:note "inline ASH")
+  (:translate ash)
+  (:args (number :scs (signed-reg unsigned-reg) :target result)
+	 (amount :scs (signed-reg) :target ecx))
+  (:arg-types (:or signed-num unsigned-num) signed-num)
+  (:results (result :scs (signed-reg unsigned-reg)
+		    :from (:argument 0)))
+  (:result-types (:or signed-num unsigned-num))
+  (:temporary (:sc dword-reg :offset ecx-offset :from (:argument 1)) ecx)
+  (:generator 5
+    (move result number)
+    (move ecx amount)
+    (inst or ecx ecx)
+    (inst jmp :ns positive)
+    (inst neg ecx)
+    (inst cmp ecx 31)
+    (inst jmp :be okay)
+    (inst mov ecx 31)
+    OKAY
+    (sc-case number
+      (signed-reg (inst sar result :cl))
+      (unsigned-reg (inst shr result :cl)))
+    (inst jmp done)
+      
+    POSITIVE
+    ;; The result-type assures us that this shift will not overflow.
+    (inst shl result :cl)
+      
+    DONE))
+
+
+;;; note documentation for this function is wrong - rtfm
+(define-vop (signed-byte-32-len)
+  (:translate integer-length)
+  (:note "inline (signed-byte 32) integer-length")
+  (:policy :fast-safe)
+  (:args (arg :scs (signed-reg signed-stack)))
+  (:arg-types signed-num)
+  (:results (res :scs (any-reg)))
+  (:result-types positive-fixnum)
+  (:generator 30
+    (move res arg)
+    (inst cmp res 0)
+    (inst jmp :ge POS)
+    (inst not res)
+    POS
+    (inst bsr res res)
+    (inst jmp :z zero)
+    (inst inc res)
+    (inst shl res 2)
+    (inst jmp done)
+    ZERO
+    (inst xor res res)
+    DONE))
+
+(define-vop (unsigned-byte-32-count)
+  (:translate logcount)
+  (:note "inline (unsigned-byte 32) logcount")
+  (:policy :fast-safe)
+  (:args (arg :scs (unsigned-reg)))
+  (:arg-types unsigned-num)
+  (:results (result :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:temporary (:sc dword-reg :from (:argument 0)) temp)
+  (:generator 30
+    (move result arg)
+
+    (inst mov temp result)
+    (inst shr temp 1)
+    (inst and result #x55555555)
+    (inst and temp #x55555555)
+    (inst add result temp)
+
+    (inst mov temp result)
+    (inst shr temp 2)
+    (inst and result #x33333333)
+    (inst and temp #x33333333)
+    (inst add result temp)
+
+    (inst mov temp result)
+    (inst shr temp 4)
+    (inst and result #x0f0f0f0f)
+    (inst and temp #x0f0f0f0f)
+    (inst add result temp)
+
+    (inst mov temp result)
+    (inst shr temp 8)
+    (inst and result #x00ff00ff)
+    (inst and temp #x00ff00ff)
+    (inst add result temp)
+
+    (inst mov temp result)
+    (inst shr temp 16)
+    (inst and result #x0000ffff)
+    (inst and temp #x0000ffff)
+    (inst add result temp)))
+
+
+
+;;;; Binary conditional VOPs:
+
+(define-vop (fast-conditional)
+  (:conditional)
+  (:info target not-p)
+  (:effects)
+  (:affected)
+  (:policy :fast-safe))
+
+(define-vop (fast-conditional/fixnum fast-conditional)
+  (:args (x :scs (any-reg)
+	    :load-if (not (and (sc-is x immediate-stack)
+			       (sc-is y any-reg))))
+	 (y :scs (any-reg immediate-stack)))
+  (:arg-types tagged-num tagged-num)
+  (:note "inline fixnum comparison"))
+
+(define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
+  (:args (x :scs (any-reg immediate-stack)))
+  (:arg-types tagged-num (:constant (signed-byte 30)))
+  (:info target not-p y))
+
+(define-vop (fast-conditional/signed fast-conditional)
+  (:args (x :scs (signed-reg)
+	    :load-if (not (and (sc-is x signed-stack)
+			       (sc-is y signed-reg))))
+	 (y :scs (signed-reg signed-stack)))
+  (:arg-types signed-num signed-num)
+  (:note "inline (signed-byte 32) comparison"))
+
+(define-vop (fast-conditional-c/signed fast-conditional/signed)
+  (:args (x :scs (signed-reg signed-stack)))
+  (:arg-types signed-num (:constant (signed-byte 32)))
+  (:info target not-p y))
+
+(define-vop (fast-conditional/unsigned fast-conditional)
+  (:args (x :scs (unsigned-reg)
+	    :load-if (not (and (sc-is x unsigned-stack)
+			       (sc-is y unsigned-reg))))
+	 (y :scs (unsigned-reg unsigned-stack)))
+  (:arg-types unsigned-num unsigned-num)
+  (:note "inline (unsigned-byte 32) comparison"))
+
+(define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
+  (:args (x :scs (unsigned-reg unsigned-stack)))
+  (:arg-types unsigned-num (:constant (unsigned-byte 32)))
+  (:info target not-p y))
+
+
+(defmacro define-conditional-vop (tran cond unsigned not-cond not-unsigned)
+  `(progn
+     ,@(mapcar
+	#'(lambda (suffix cost signed)
+	    (unless (and (member suffix '(/fixnum -c/fixnum))
+			 (eq tran 'eql))
+	      `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)"
+					     tran suffix))
+			    ,(intern
+			      (format nil "~:@(FAST-CONDITIONAL~A~)"
+				      suffix)))
+		 (:translate ,tran)
+		 (:generator ,cost
+		   (inst cmp x
+			 ,(if (eq suffix '-c/fixnum) '(fixnum y) 'y))
+		   (inst jmp (if not-p
+				 ,(if signed not-cond not-unsigned)
+				 ,(if signed cond unsigned))
+			 target)))))
+	'(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
+	'(4 3 6 5 6 5)
+	'(t t t t nil nil))))
+
+(define-conditional-vop < :l :b :ge :ae)
+
+(define-conditional-vop > :g :a :le :be)
+
+(define-conditional-vop eql :e :e :ne :ne)
+
+;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
+;;; known fixnum.
+
+;;; These versions specify a fixnum restriction on their first arg.  We have
+;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
+;;; the first arg and a higher cost.  The reason for doing this is to prevent
+;;; fixnum specific operations from being used on word integers, spuriously
+;;; consing the argument.
+;;;
+
+(define-vop (fast-eql/fixnum fast-conditional)
+  (:args (x :scs (any-reg)
+	    :load-if (not (and (sc-is x immediate-stack)
+			       (sc-is y any-reg))))
+	 (y :scs (any-reg immediate-stack)))
+  (:arg-types tagged-num tagged-num)
+  (:note "inline fixnum comparison")
+  (:translate eql)
+  (:generator 4
+    (inst cmp x y)
+    (inst jmp (if not-p :ne :e) target)))
+;;;
+(define-vop (generic-eql/fixnum fast-eql/fixnum)
+  (:args (x :scs (any-reg descriptor-reg))
+	 (y :scs (any-reg immediate-stack)))
+  (:arg-types * tagged-num)
+  (:variant-cost 7))
+
+(define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
+  (:args (x :scs (any-reg immediate-stack)))
+  (:arg-types tagged-num (:constant (signed-byte 30)))
+  (:info target not-p y)
+  (:translate eql)
+  (:generator 2
+    (inst cmp x (fixnum y))
+    (inst jmp (if not-p :ne :e) target)))
+;;;
+(define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
+  (:args (x :scs (any-reg immediate-stack descriptor-reg descriptor-stack)))
+  (:arg-types * (:constant (signed-byte 30)))
+  (:variant-cost 6))
+
+
+;;;; 32-bit logical operations
+
+(define-vop (merge-bits)
+  (:translate merge-bits)
+  (:args (shift :scs (signed-reg unsigned-reg) :target ecx)
+	 (prev :scs (unsigned-reg) :target result)
+	 (next :scs (unsigned-reg)))
+  (:arg-types tagged-num unsigned-num unsigned-num)
+  (:temporary (:sc dword-reg :offset ecx-offset :from (:argument 0)) ecx)
+  (:results (result :scs (unsigned-reg) :from (:argument 1)))
+  (:result-types unsigned-num)
+  (:policy :fast-safe)
+  (:generator 4
+    (move ecx shift)
+    (move result prev)
+    (inst shrd result next :cl)))
+
+(define-vop (32bit-logical)
+  (:args (x :scs (unsigned-reg) :target r
+	    :load-if (not (and (sc-is x unsigned-stack)
+			       (location= x r))))
+	 (y :scs (unsigned-reg)
+	    :load-if (or (not (sc-is y unsigned-stack))
+			 (and (sc-is x unsigned-stack)
+			      (location= x r)))))
+  (:arg-types unsigned-num unsigned-num)
+  (:results (r :scs (unsigned-reg)  :from (:argument 0)
+	       :load-if (not (and (sc-is x unsigned-stack)
+				  (location= x r)))))
+  (:result-types unsigned-num)
+  (:policy :fast-safe))
+
+(define-vop (32bit-logical-not)
+  (:translate 32bit-logical-not)
+  (:args (x :scs (unsigned-reg) :target r
+	    :load-if (not (and (sc-is x unsigned-stack)
+			       (location= x r)))))
+  (:arg-types unsigned-num)
+  (:results (r :scs (unsigned-reg)
+	       :load-if (not (and (sc-is x unsigned-stack)
+				  (location= x r)))))
+  (:result-types unsigned-num)
+  (:policy :fast-safe)
+  (:generator 1
+    (move r x)
+    (inst not r)))
+
+(define-vop (32bit-logical-and 32bit-logical)
+  (:translate 32bit-logical-and)
+  (:generator 1
+    (move r x)
+    (inst and r y)))
+
+(def-source-transform 32bit-logical-nand (x y)
+  `(32bit-logical-not (32bit-logical-and ,x ,y)))
+
+(define-vop (32bit-logical-or 32bit-logical)
+  (:translate 32bit-logical-or)
+  (:generator 1
+    (move r x)
+    (inst or r y)))
+
+(def-source-transform 32bit-logical-nor (x y)
+  `(32bit-logical-not (32bit-logical-or ,x ,y)))
+
+(define-vop (32bit-logical-xor 32bit-logical)
+  (:translate 32bit-logical-xor)
+  (:generator 1
+    (move r x)
+    (inst xor r y)))
+
+(def-source-transform 32bit-logical-eqv (x y)
+  `(32bit-logical-not (32bit-logical-xor ,x ,y)))
+
+(def-source-transform 32bit-logical-orc1 (x y)
+  `(32bit-logical-or (32bit-logical-not ,x) ,y))
+
+(def-source-transform 32bit-logical-orc2 (x y)
+  `(32bit-logical-or ,x (32bit-logical-not ,y)))
+
+(def-source-transform 32bit-logical-andc1 (x y)
+  `(32bit-logical-and (32bit-logical-not ,x) ,y))
+
+(def-source-transform 32bit-logical-andc2 (x y)
+  `(32bit-logical-and ,x (32bit-logical-not ,y)))
+
+
+(define-vop (shift-towards-someplace)
+  (:policy :fast-safe)
+  (:args (num :scs (unsigned-reg) :target r)
+	 (amount :scs (unsigned-reg signed-reg) :target ecx))
+  (:arg-types unsigned-num positive-fixnum)
+  (:temporary (:sc dword-reg :offset ecx-offset :from (:argument 1)) ecx)
+  (:results (r :scs (unsigned-reg)))
+  (:result-types unsigned-num))
+
+(define-vop (shift-towards-start shift-towards-someplace)
+  (:translate shift-towards-start)
+  (:generator 1
+    (move r num)
+    (move ecx amount)
+    (inst shr r :cl)))
+
+(define-vop (shift-towards-end shift-towards-someplace)
+  (:translate shift-towards-end)
+  (:generator 1
+    (move r num)
+    (move ecx amount)
+    (inst shl r :cl)))
+
+
+
+;;;; Bignum stuff.
+
+(define-vop (bignum-length get-header-data)
+  (:translate bignum::%bignum-length)
+  (:policy :fast-safe))
+
+(define-vop (bignum-set-length set-header-data)
+  (:translate bignum::%bignum-set-length)
+  (:policy :fast-safe))
+
+(define-full-reffer bignum-ref * bignum-digits-offset other-pointer-type
+  (unsigned-reg) unsigned-num bignum::%bignum-ref)
+
+(define-full-setter bignum-set * bignum-digits-offset other-pointer-type
+  (unsigned-reg) unsigned-num bignum::%bignum-set)
+
+(define-vop (digit-0-or-plus)
+  (:translate bignum::%digit-0-or-plusp)
+  (:policy :fast-safe)
+  (:args (digit :scs (unsigned-reg)))
+  (:arg-types unsigned-num)
+  (:conditional)
+  (:info target not-p)
+  (:generator 3
+    (inst or digit digit)
+    (inst jmp (if not-p :s :ns) target)))
+
+
+;;; For add and sub with carry the sc of carry argument is any-reg so
+;;; the it may be passed as a fixnum or word and thus may be 0, 1, or
+;;; 4. This is easy to deal with and may save a fixnum-word
+;;; conversion.
+;;;
+(define-vop (add-w/carry)
+  (:translate bignum::%add-with-carry)
+  (:policy :fast-safe)
+  (:args (a :scs (unsigned-reg) :target result)
+	 (b :scs (unsigned-reg unsigned-stack) :to :eval)
+	 (c :scs (any-reg) :target temp))
+  (:arg-types unsigned-num unsigned-num positive-fixnum)
+  (:temporary (:sc any-reg :from (:argument 2) :to :eval) temp)
+  (:results (result :scs (unsigned-reg) :from (:argument 0))
+	    (carry :scs (unsigned-reg)))
+  (:result-types unsigned-num positive-fixnum)
+  (:generator 4
+    (move result a)
+    (move temp c)
+    (inst neg temp) ; Set the carry flag to 0 if c=0 else to 1
+    (inst adc result b)
+    (inst mov carry 0)
+    (inst adc carry carry)))
+
+;;; Note: the borrow is the oppostite of the x86 convention - 1 for no
+;;; borrow and 0 for a borrow.
+(define-vop (sub-w/borrow)
+  (:translate bignum::%subtract-with-borrow)
+  (:policy :fast-safe)
+  (:args (a :scs (unsigned-reg) :to :eval :target result)
+	 (b :scs (unsigned-reg unsigned-stack) :to :result)
+	 (c :scs (any-reg immediate-stack)))
+  (:arg-types unsigned-num unsigned-num positive-fixnum)
+  (:results (result :scs (unsigned-reg) :from :eval)
+	    (borrow :scs (unsigned-reg)))
+  (:result-types unsigned-num positive-fixnum)
+  (:generator 5
+    (inst cmp c 1) ; Set the carry flag to 1 if c=0 else to 0
+    (move result a)
+    (inst sbb result b)
+    (inst mov borrow 0)
+    (inst adc borrow borrow)
+    (inst xor borrow 1)))
+
+
+(define-vop (bignum-mult-and-add-3-arg)
+  (:translate bignum::%multiply-and-add)
+  (:policy :fast-safe)
+  (:args (x :scs (unsigned-reg unsigned-stack) :target eax)
+	 (y :scs (unsigned-reg unsigned-stack))
+	 (carry-in :scs (unsigned-reg unsigned-stack)))
+  (:arg-types unsigned-num unsigned-num unsigned-num)
+  (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
+		   :to (:result 1) :target lo) eax)
+  (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
+		   :to (:result 0) :target hi) edx)
+  (:results (hi :scs (unsigned-reg unsigned-stack))
+	    (lo :scs (unsigned-reg unsigned-stack)))
+  (:result-types unsigned-num unsigned-num)
+  (:generator 20
+    (move eax x)
+    (inst mul eax y)
+    (inst add eax carry-in)
+    (inst adc edx 0)
+    (move hi edx)
+    (move lo eax)))
+
+(define-vop (bignum-mult-and-add-4-arg)
+  (:translate bignum::%multiply-and-add)
+  (:policy :fast-safe)
+  (:args (x :scs (unsigned-reg unsigned-stack) :target eax)
+	 (y :scs (unsigned-reg unsigned-stack))
+	 (prev :scs (unsigned-reg unsigned-stack))
+	 (carry-in :scs (unsigned-reg unsigned-stack)))
+  (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
+  (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
+		   :to (:result 1) :target lo) eax)
+  (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
+		   :to (:result 0) :target hi) edx)
+  (:results (hi :scs (unsigned-reg unsigned-stack))
+	    (lo :scs (unsigned-reg unsigned-stack)))
+  (:result-types unsigned-num unsigned-num)
+  (:generator 20
+    (move eax x)
+    (inst mul eax y)
+    (inst add eax prev)
+    (inst adc edx 0)
+    (inst add eax carry-in)
+    (inst adc edx 0)
+    (move hi edx)
+    (move lo eax)))
+
+
+(define-vop (bignum-mult)
+  (:translate bignum::%multiply)
+  (:policy :fast-safe)
+  (:args (x :scs (unsigned-reg unsigned-stack) :target eax)
+	 (y :scs (unsigned-reg unsigned-stack)))
+  (:arg-types unsigned-num unsigned-num)
+  (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
+		   :to (:result 1) :target lo) eax)
+  (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
+		   :to (:result 0) :target hi) edx)
+  (:results (hi :scs (unsigned-reg unsigned-stack))
+	    (lo :scs (unsigned-reg unsigned-stack)))
+  (:result-types unsigned-num unsigned-num)
+  (:generator 20
+    (move eax x)
+    (inst mul eax y)
+    (move hi edx)
+    (move lo eax)))
+
+(define-vop (bignum-lognot)
+  (:translate bignum::%lognot)
+  (:policy :fast-safe)
+  (:args (x :scs (unsigned-reg unsigned-stack) :target r))
+  (:arg-types unsigned-num)
+  (:results (r :scs (unsigned-reg)
+	       :load-if (not (location= x r))))
+  (:result-types unsigned-num)
+  (:generator 1
+    (move r x)
+    (inst not r)))
+
+(define-vop (fixnum-to-digit)
+  (:translate bignum::%fixnum-to-digit)
+  (:policy :fast-safe)
+  (:args (fixnum :scs (any-reg immediate-stack) :target digit))
+  (:arg-types tagged-num)
+  (:results (digit :scs (unsigned-reg)
+		   :load-if (not (location= fixnum digit))))
+  (:result-types unsigned-num)
+  (:generator 1
+    (move digit fixnum)
+    (inst sar digit 2)))
+
+(define-vop (bignum-floor)
+  (:translate bignum::%floor)
+  (:policy :fast-safe)
+  (:args (div-high :scs (unsigned-reg unsigned-stack) :target edx)
+	 (div-low :scs (unsigned-reg unsigned-stack) :target eax)
+	 (divisor :scs (unsigned-reg unsigned-stack)))
+  (:arg-types unsigned-num unsigned-num unsigned-num)
+  (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 1)
+		   :to (:result 0) :target quo) eax)
+  (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 0)
+		   :to (:result 1) :target rem) edx)
+  (:results (quo :scs (unsigned-reg unsigned-stack))
+	    (rem :scs (unsigned-reg unsigned-stack)))
+  (:result-types unsigned-num unsigned-num)
+  (:generator 300
+    (move edx div-high)
+    (move eax div-low)
+    (inst div eax divisor)
+    (move quo eax)
+    (move rem edx)))
+
+(define-vop (signify-digit)
+  (:translate bignum::%fixnum-digit-with-correct-sign)
+  (:policy :fast-safe)
+  (:args (digit :scs (unsigned-reg unsigned-stack) :target res))
+  (:arg-types unsigned-num)
+  (:results (res :scs (any-reg signed-reg)
+		 :load-if (not (and (sc-is res immediate-stack signed-stack)
+				    (location= digit res)))))
+  (:result-types signed-num)
+  (:generator 1
+    (move res digit)
+    (when (sc-is res any-reg immediate-stack)
+      (inst shl res 2))))
+
+(define-vop (digit-ashr)
+  (:translate bignum::%ashr)
+  (:policy :fast-safe)
+  (:args (digit :scs (unsigned-reg unsigned-stack) :target result)
+	 (count :scs (unsigned-reg unsigned-stack) :target ecx))
+  (:arg-types unsigned-num positive-fixnum)
+  (:temporary (:sc dword-reg :offset ecx-offset :from (:argument 1)) ecx)
+  (:results (result :scs (unsigned-reg) :from (:argument 0)
+		    :load-if (not (and (sc-is result unsigned-stack)
+				       (location= digit result)))))
+  (:result-types unsigned-num)
+  (:generator 1
+    (move result digit)
+    (move ecx count)
+    (inst sar result :cl)))
+
+(define-vop (digit-lshr digit-ashr)
+  (:translate bignum::%digit-logical-shift-right)
+  (:generator 1
+    (move result digit)
+    (move ecx count)
+    (inst shr result :cl)))
+
+(define-vop (digit-ashl digit-ashr)
+  (:translate bignum::%ashl)
+  (:generator 1
+    (move result digit)
+    (move ecx count)
+    (inst shl result :cl)))
+
+
+;;;; Static functions.
+
+(define-static-function two-arg-/ (x y) :translate /)
+
+(define-static-function two-arg-gcd (x y) :translate gcd)
+(define-static-function two-arg-lcm (x y) :translate lcm)
+
+(define-static-function two-arg-and (x y) :translate logand)
+(define-static-function two-arg-ior (x y) :translate logior)
+(define-static-function two-arg-xor (x y) :translate logxor)
diff --git a/compiler/x86/array.lisp b/compiler/x86/array.lisp
new file mode 100644
index 000000000..f5f957a96
--- /dev/null
+++ b/compiler/x86/array.lisp
@@ -0,0 +1,655 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/array.lisp,v 1.1 1997/01/18 14:31:24 ram Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    This file contains the x86 definitions for array operations.
+;;;
+;;; Written by William Lott
+;;;
+;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
+;;;
+(in-package :x86)
+
+
+;;;; Allocator for the array header.
+
+
+(define-vop (make-array-header)
+  (:translate make-array-header)
+  (:policy :fast-safe)
+  (:args (type :scs (any-reg))
+	 (rank :scs (any-reg)))
+  (:arg-types positive-fixnum positive-fixnum)
+  (:temporary (:sc any-reg) bytes)
+  (:temporary (:sc any-reg) header)
+  (:temporary (:sc any-reg) alloc)
+  (:results (result :scs (descriptor-reg)))
+  (:generator 13
+    (inst lea bytes
+	  (make-ea :dword :base rank
+		   :disp (+ (* (1+ array-dimensions-offset) word-bytes)
+			    lowtag-mask)))
+    (inst and bytes (lognot lowtag-mask))
+    (inst lea header (make-ea :dword :base rank
+			      :disp (fixnum (1- array-dimensions-offset))))
+    (inst shl header type-bits)
+    (inst or  header type)
+    (inst shr header 2)
+    #-cgc
+    (with-allocation (alloc)
+      (inst lea result (make-ea :dword :base alloc :disp other-pointer-type))
+      (inst add alloc bytes))
+    #+cgc
+    (with-cgc-allocation (alloc bytes)
+      (inst lea result (make-ea :dword :base alloc :disp other-pointer-type)))
+    (storew header result 0 other-pointer-type)))
+
+
+;;;; Additional accessors and setters for the array header.
+
+(defknown lisp::%array-dimension (t index) index
+  (flushable))
+(defknown lisp::%set-array-dimension (t index index) index
+  ())
+
+(define-full-reffer %array-dimension *
+  array-dimensions-offset other-pointer-type
+  (any-reg) positive-fixnum lisp::%array-dimension)
+
+(define-full-setter %set-array-dimension *
+  array-dimensions-offset other-pointer-type
+  (any-reg) positive-fixnum lisp::%set-array-dimension)
+
+
+(defknown lisp::%array-rank (t) index (flushable))
+
+(define-vop (array-rank-vop)
+  (:translate lisp::%array-rank)
+  (:policy :fast-safe)
+  (:args (x :scs (descriptor-reg)))
+  (:results (res :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:generator 6
+    (loadw res x 0 other-pointer-type)
+    (inst shr res type-bits)
+    (inst sub res (1- array-dimensions-offset))))
+
+
+
+;;;; Bounds checking routine.
+
+(define-vop (check-bound)
+  (:translate %check-bound)
+  (:policy :fast-safe)
+  (:args (array)
+	 (bound :scs (any-reg))
+	 (index :scs (any-reg immediate) :target result))
+  (:arg-types * positive-fixnum tagged-num)
+  (:results (result :scs (any-reg immediate-stack)))
+  (:result-types positive-fixnum)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 5
+    (let ((error (generate-error-code vop invalid-array-index-error
+				      array bound index))
+	  (index (if (sc-is index immediate) (fixnum (tn-value index)) index)))
+      (inst cmp bound index)
+      ;; We use below-or-equal even though it's an unsigned test, because
+      ;; negative indexes appear as real large unsigned numbers.  Therefore,
+      ;; we get the < 0 and >= bound test all rolled into one.
+      (inst jmp :be error)
+      (unless (and (tn-p index) (location= result index))
+        (inst mov result index))
+      )))
+
+
+;;;; Accessors/Setters
+
+;;; Variants built on top of word-index-ref, etc.  I.e. those vectors whos
+;;; elements are represented in integer registers and are built out of
+;;; 8, 16, or 32 bit elements.
+
+(eval-when (compile eval)
+
+(defmacro def-full-data-vector-frobs (type element-type &rest scs)
+  `(progn
+     (define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type
+       vector-data-offset other-pointer-type ,scs ,element-type
+       data-vector-ref)
+     (define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type
+       vector-data-offset other-pointer-type ,scs ,element-type
+       data-vector-set)))
+
+); eval-when (compile eval)
+
+(def-full-data-vector-frobs simple-vector * descriptor-reg any-reg)
+
+
+(def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num
+  unsigned-reg)
+
+;;; Integer vectors whos elements are smaller than a byte.  I.e. bit, 2-bit,
+;;; and 4-bit vectors.
+;;; 
+
+(eval-when (compile eval)
+
+(defmacro def-small-data-vector-frobs (type bits)
+  (let* ((elements-per-word (floor vm:word-bits bits))
+	 (bit-shift (1- (integer-length elements-per-word))))
+    `(progn
+       (define-vop (,(symbolicate 'data-vector-ref/ type))
+	 (:note "inline array access")
+	 (:translate data-vector-ref)
+	 (:policy :fast-safe)
+	 (:args (object :scs (descriptor-reg))
+		(index :scs (unsigned-reg)))
+	 (:arg-types ,type positive-fixnum)
+	 (:results (result :scs (unsigned-reg) :from (:argument 0)))
+	 (:result-types positive-fixnum)
+	 (:temporary (:sc dword-reg :offset ecx-offset) ecx)
+	 (:generator 20
+	   (move ecx index)
+	   (inst shr ecx ,bit-shift)
+	   (inst mov result
+		 (make-ea :dword :base object :index ecx :scale 4
+			  :disp (- (* vector-data-offset word-bytes)
+				   other-pointer-type)))
+	   (move ecx index)
+	   (inst and ecx ,(1- elements-per-word))
+	   ,@(unless (= bits 1)
+	       `((inst shl ecx ,(1- (integer-length bits)))))
+	   (inst shr result :cl)
+	   (inst and result ,(1- (ash 1 bits)))))
+       (define-vop (,(symbolicate 'data-vector-ref-c/ type))
+	 (:translate data-vector-ref)
+	 (:policy :fast-safe)
+	 (:args (object :scs (descriptor-reg)))
+	 (:arg-types ,type (:constant index))
+	 (:info index)
+	 (:results (result :scs (unsigned-reg)))
+	 (:result-types positive-fixnum)
+	 (:generator 15
+	   (multiple-value-bind (word extra) (floor index ,elements-per-word)
+	     (loadw result object (+ word vector-data-offset) 
+		    other-pointer-type)
+	     (unless (zerop extra)
+	       (inst shr result (* extra ,bits)))
+	     (unless (= extra ,(1- elements-per-word))
+	       (inst and result ,(1- (ash 1 bits)))))))
+       (define-vop (,(symbolicate 'data-vector-set/ type))
+	 (:note "inline array store")
+	 (:translate data-vector-set)
+	 (:policy :fast-safe)
+	 (:args (object :scs (descriptor-reg) :target ptr)
+		(index :scs (unsigned-reg) :target ecx)
+		(value :scs (unsigned-reg immediate) :target result))
+	 (:arg-types ,type positive-fixnum positive-fixnum)
+	 (:results (result :scs (unsigned-reg)))
+	 (:result-types positive-fixnum)
+	 (:temporary (:sc dword-reg) word-index)
+	 (:temporary (:sc dword-reg :from (:argument 0)) ptr old)
+	 (:temporary (:sc dword-reg :offset ecx-offset :from (:argument 1))
+		     ecx)
+	 (:generator 25
+	   (move word-index index)
+	   (inst shr word-index ,bit-shift)
+	   (inst lea ptr
+		 (make-ea :dword :base object :index word-index :scale 4
+			  :disp (- (* vector-data-offset word-bytes)
+				   other-pointer-type)))
+	   (loadw old ptr)
+	   (move ecx index)
+	   (inst and ecx ,(1- elements-per-word))
+	   ,@(unless (= bits 1)
+	       `((inst shl ecx ,(1- (integer-length bits)))))
+	   (inst ror old :cl)
+	   (unless (and (sc-is value immediate)
+			(= (tn-value value) ,(1- (ash 1 bits))))
+	     (inst and old ,(lognot (1- (ash 1 bits)))))
+	   (sc-case value
+	     (immediate
+	      (unless (zerop (tn-value value))
+		(inst or old (logand (tn-value value) ,(1- (ash 1 bits))))))
+	     (unsigned-reg
+	      (inst or old value)))
+	   (inst rol old :cl)
+	   (storew old ptr)
+	   (sc-case value
+	     (immediate
+	      (inst mov result (tn-value value)))
+	     (unsigned-reg
+	      (move result value)))))
+       (define-vop (,(symbolicate 'data-vector-set-c/ type))
+	 (:translate data-vector-set)
+	 (:policy :fast-safe)
+	 (:args (object :scs (descriptor-reg))
+		(value :scs (unsigned-reg immediate) :target result))
+	 (:arg-types ,type (:constant index) positive-fixnum)
+	 (:info index)
+	 (:results (result :scs (unsigned-reg)))
+	 (:result-types positive-fixnum)
+	 (:temporary (:sc dword-reg :to (:result 0)) old)
+	 (:generator 20
+	   (multiple-value-bind (word extra) (floor index ,elements-per-word)
+	     (inst mov old
+		   (make-ea :dword :base object
+			    :disp (- (* (+ word vector-data-offset) word-bytes)
+				     other-pointer-type)))
+	     (sc-case value
+	       (immediate
+		(let* ((value (tn-value value))
+		       (mask ,(1- (ash 1 bits)))
+		       (shift (* extra ,bits)))
+		  (unless (= value mask)
+		    (inst and old (lognot (ash mask shift))))
+		  (unless (zerop value)
+		    (inst or old (ash value shift)))))
+	       (unsigned-reg
+		(let ((shift (* extra ,bits)))
+		  (unless (zerop shift)
+		    (inst ror old shift)
+		    (inst and old (lognot ,(1- (ash 1 bits))))
+		    (inst or old value)
+		    (inst rol old shift)))))
+	     (inst mov (make-ea :dword :base object
+				:disp (- (* (+ word vector-data-offset) word-bytes)
+					 other-pointer-type))
+		   old)
+	     (sc-case value
+	       (immediate
+		(inst mov result (tn-value value)))
+	       (unsigned-reg
+		(move result value)))))))))
+
+
+); eval-when (compile eval)
+
+(def-small-data-vector-frobs simple-bit-vector 1)
+(def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
+(def-small-data-vector-frobs simple-array-unsigned-byte-4 4)
+
+;;; And the float variants.
+;;; 
+
+(define-vop (data-vector-ref/simple-array-single-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (any-reg)))
+  (:arg-types simple-array-single-float positive-fixnum)
+  (:results (value :scs (single-reg)))
+  (:result-types single-float)
+  (:generator 5
+   (with-empty-tn@fp-top(value)
+     (inst fld (make-ea	:dword :base object :index index :scale 1
+			:disp (- (* vm:vector-data-offset vm:word-bytes)
+				 vm:other-pointer-type))))))
+
+(define-vop (data-vector-set/simple-array-single-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (any-reg))
+	 (value :scs (single-reg) :target result))
+  (:arg-types simple-array-single-float positive-fixnum single-float)
+  (:results (result :scs (single-reg)))
+  (:result-types single-float)
+  (:generator 5
+    (if (zerop (tn-offset value))
+	(progn
+	  ;; Value is in ST0
+	  (inst fst (make-ea :dword :base object :index index :scale 1
+			     :disp (- (* vm:vector-data-offset vm:word-bytes)
+				      vm:other-pointer-type)))
+	  (unless (zerop (tn-offset result))
+	      ;; Value is in ST0 but not result.
+	      (inst fst result)))
+      (progn
+	;; Value is not in ST0.
+	(inst fxch value)
+	(inst fst (make-ea :dword :base object :index index :scale 1
+			   :disp (- (* vm:vector-data-offset vm:word-bytes)
+				    vm:other-pointer-type)))
+	(if (zerop (tn-offset result))
+	    ;; The result is in ST0.
+	    (inst fst value)
+	  (progn
+	    ;; Neither value or result are in ST0
+	    (unless (location= value result)
+		  (inst fst result))
+	    (inst fxch value)))))))
+
+(define-vop (data-vector-ref/simple-array-double-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (any-reg)))
+  (:arg-types simple-array-double-float positive-fixnum)
+  (:results (value :scs (double-reg)))
+  (:result-types double-float)
+  (:generator 7
+   (with-empty-tn@fp-top(value)
+     (inst fldd (make-ea :dword :base object :index index :scale 2
+			 :disp (- (* vm:vector-data-offset vm:word-bytes)
+				  vm:other-pointer-type))))))
+
+(define-vop (data-vector-set/simple-array-double-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (any-reg))
+	 (value :scs (double-reg) :target result))
+  (:arg-types simple-array-double-float positive-fixnum double-float)
+  (:results (result :scs (double-reg)))
+  (:result-types double-float)
+  (:generator 20
+    (if (zerop (tn-offset value))
+	(progn
+	  ;; Value is in ST0
+	  (inst fstd (make-ea :dword :base object :index index :scale 2
+			      :disp (- (* vm:vector-data-offset vm:word-bytes)
+				       vm:other-pointer-type)))
+	  (unless (zerop (tn-offset result))
+	      ;; Value is in ST0 but not result.
+	      (inst fstd result)))
+      (progn
+	;; Value is not in ST0.
+	(inst fxch value)
+	(inst fstd (make-ea :dword :base object :index index :scale 2
+			    :disp (- (* vm:vector-data-offset vm:word-bytes)
+				     vm:other-pointer-type)))
+	(if (zerop (tn-offset result))
+	    ;; The result is in ST0.
+	    (inst fstd value)
+	  (progn
+	    ;; Neither value or result are in ST0
+	    (unless (location= value result)
+		  (inst fstd result))
+	    (inst fxch value)))))))
+
+;;; These VOPs are used for implementing float slots in structures (whose raw
+;;; data is an unsigned-32 vector.
+;;; pfw-copied from hppa
+
+(define-vop (raw-ref-single data-vector-ref/simple-array-single-float)
+  (:translate %raw-ref-single)
+  (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
+;;;
+(define-vop (raw-set-single data-vector-set/simple-array-single-float)
+  (:translate %raw-set-single)
+  (:arg-types simple-array-unsigned-byte-32 positive-fixnum single-float))
+;;;
+(define-vop (raw-ref-double data-vector-ref/simple-array-double-float)
+  (:translate %raw-ref-double)
+  (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
+;;;
+(define-vop (raw-set-double data-vector-set/simple-array-double-float)
+  (:translate %raw-set-double)
+  (:arg-types simple-array-unsigned-byte-32 positive-fixnum double-float))
+
+
+;;; These vops are useful for accessing the bits of a vector irrespective of
+;;; what type of vector it is.
+;;; 
+
+(define-full-reffer raw-bits * 0 other-pointer-type (unsigned-reg) unsigned-num
+  %raw-bits)
+(define-full-setter set-raw-bits * 0 other-pointer-type (unsigned-reg)
+  unsigned-num %set-raw-bits)
+
+
+;;;; Misc. Array VOPs.
+
+(define-vop (get-vector-subtype get-header-data))
+(define-vop (set-vector-subtype set-header-data))
+
+;;;;
+;;;; dtc expanded and fixed the following:
+
+
+
+;;; unsigned-byte-8
+
+(define-vop (data-vector-ref/simple-array-unsigned-byte-8)
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (unsigned-reg)))
+  (:arg-types simple-array-unsigned-byte-8 positive-fixnum)
+  (:results (value :scs (unsigned-reg signed-reg)))
+  (:result-types positive-fixnum)
+  (:generator 5
+    (inst movzx value
+	  (make-ea :byte :base object :index index :scale 1
+		   :disp (- (* vector-data-offset word-bytes)
+			    other-pointer-type)))))
+
+
+(define-vop (data-vector-ref-c/simple-array-unsigned-byte-8)
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg)))
+  (:info index)
+  (:arg-types simple-array-unsigned-byte-8 (:constant (signed-byte 30)))
+  (:results (value :scs (unsigned-reg signed-reg)))
+  (:result-types positive-fixnum)
+  (:generator 4
+    (inst movzx value
+	  (make-ea :byte :base object
+		   :disp (- (+ (* vector-data-offset word-bytes) index)
+			    other-pointer-type)))))
+
+
+(define-vop (data-vector-set/simple-array-unsigned-byte-8)
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to (:eval 0))
+	 (index :scs (unsigned-reg) :to (:eval 0))
+	 (value :scs (unsigned-reg unsigned-stack signed-reg signed-stack)
+		:target eax))
+  (:arg-types simple-array-unsigned-byte-8 positive-fixnum positive-fixnum)
+  (:temporary (:sc dword-reg :offset eax-offset :target result
+		   :from (:argument 2) :to (:result 0))
+	      eax)
+  (:results (result :scs (unsigned-reg signed-reg)))
+  (:result-types positive-fixnum)
+  (:generator 5
+    (move eax value)
+    (inst mov
+	  (make-ea :byte :base object :index index :scale 1
+		   :disp (- (* vector-data-offset word-bytes) other-pointer-type))
+	  al-tn)
+    (move result eax)))
+
+
+(define-vop (data-vector-set-c/simple-array-unsigned-byte-8)
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to (:eval 0))
+	 (value :scs (unsigned-reg unsigned-stack signed-reg signed-stack)
+		:target eax))
+  (:info index)
+  (:arg-types simple-array-unsigned-byte-8 (:constant (signed-byte 30)) positive-fixnum)
+  (:temporary (:sc dword-reg :offset eax-offset :target result
+		   :from (:argument 1) :to (:result 0))
+	      eax)
+  (:results (result :scs (unsigned-reg signed-reg)))
+  (:result-types positive-fixnum)
+  (:generator 4
+    (move eax value)
+    (inst mov
+	  (make-ea :byte :base object
+		   :disp (- (+ (* vector-data-offset word-bytes) index)
+			    other-pointer-type))
+	  al-tn)
+    (move result eax)))
+
+
+;;; unsigned-byte-16
+
+(define-vop (data-vector-ref/simple-array-unsigned-byte-16)
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (unsigned-reg)))
+  (:arg-types simple-array-unsigned-byte-16 positive-fixnum)
+  (:results (value :scs (unsigned-reg signed-reg)))
+  (:result-types positive-fixnum)
+  (:generator 5
+    (inst movzx value
+	  (make-ea :word :base object :index index :scale 2
+		   :disp (- (* vector-data-offset word-bytes)
+			    other-pointer-type)))))
+
+
+(define-vop (data-vector-ref-c/simple-array-unsigned-byte-16)
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg)))
+  (:info index)
+  (:arg-types simple-array-unsigned-byte-16 (:constant (signed-byte 30)))
+  (:results (value :scs (unsigned-reg signed-reg)))
+  (:result-types positive-fixnum)
+  (:generator 4
+    (inst movzx value
+	  (make-ea :word :base object
+		   :disp (- (+ (* vector-data-offset word-bytes)
+			       (* 2 index))
+			    other-pointer-type)))))
+
+
+(define-vop (data-vector-set/simple-array-unsigned-byte-16)
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to (:eval 0))
+	 (index :scs (unsigned-reg) :to (:eval 0))
+	 (value :scs (unsigned-reg unsigned-stack signed-reg signed-stack)
+		:target eax))
+  (:arg-types simple-array-unsigned-byte-16 positive-fixnum positive-fixnum)
+  (:temporary (:sc dword-reg :offset eax-offset :target result
+		   :from (:argument 2) :to (:result 0))
+	      eax)
+  (:results (result :scs (unsigned-reg signed-reg)))
+  (:result-types positive-fixnum)
+  (:generator 5
+    (move eax value)
+    (inst mov (make-ea :word :base object :index index :scale 2
+		       :disp (- (* vector-data-offset word-bytes)
+				other-pointer-type))
+	  ax-tn)
+    (move result eax)))
+
+
+(define-vop (data-vector-set-c/simple-array-unsigned-byte-16)
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to (:eval 0))
+	 (value :scs (unsigned-reg unsigned-stack signed-reg signed-stack)
+		:target eax))
+  (:info index)
+  (:arg-types simple-array-unsigned-byte-16 (:constant (signed-byte 30)) positive-fixnum)
+  (:temporary (:sc dword-reg :offset eax-offset :target result
+		   :from (:argument 1) :to (:result 0))
+	      eax)
+  (:results (result :scs (unsigned-reg signed-reg)))
+  (:result-types positive-fixnum)
+  (:generator 4
+    (move eax value)
+    (inst mov
+	  (make-ea :word :base object
+		   :disp (- (+ (* vector-data-offset word-bytes)
+			       (* 2 index))
+			    other-pointer-type))
+	  ax-tn)
+    (move result eax)))
+
+
+;;; simple-string
+
+(define-vop (data-vector-ref/simple-string)
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (unsigned-reg)))
+  (:arg-types simple-string positive-fixnum)
+  (:temporary (:sc dword-reg ; byte-reg
+		   :offset eax-offset ; al-offset
+		   :target value
+		   :from (:eval 0) :to (:result 0))
+	      eax)
+  (:ignore eax)
+  (:results (value :scs (base-char-reg)))
+  (:result-types base-char)
+  (:generator 5
+    (inst mov al-tn
+	  (make-ea :byte :base object :index index :scale 1
+		   :disp (- (* vector-data-offset word-bytes) other-pointer-type)))
+    (move value al-tn)))
+
+(define-vop (data-vector-ref-c/simple-string)
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg)))
+  (:info index)
+  (:arg-types simple-string (:constant (signed-byte 30)))
+  (:temporary (:sc dword-reg :offset eax-offset :target value
+		   :from (:eval 0) :to (:result 0))
+	      eax)
+  (:ignore eax)
+  (:results (value :scs (base-char-reg)))
+  (:result-types base-char)
+  (:generator 4
+    (inst mov al-tn
+	  (make-ea :byte :base object
+		   :disp (- (+ (* vector-data-offset word-bytes) index)
+			    other-pointer-type)))
+    (move value al-tn)))
+
+
+(define-vop (data-vector-set/simple-string)
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to (:eval 0))
+	 (index :scs (unsigned-reg) :to (:eval 0))
+	 (value :scs (base-char-reg)))
+  (:arg-types simple-string positive-fixnum base-char)
+  (:results (result :scs (base-char-reg)))
+  (:result-types base-char)
+  (:generator 5 
+    (inst mov (make-ea :byte :base object :index index :scale 1
+		       :disp (- (* vector-data-offset word-bytes)
+				other-pointer-type))
+	  value)
+    (move result value)))
+
+
+(define-vop (data-vector-set/simple-string-c)
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to (:eval 0))
+	 (value :scs (base-char-reg)))
+  (:info index)
+  (:arg-types simple-string (:constant (signed-byte 30)) base-char)
+  (:results (result :scs (base-char-reg)))
+  (:result-types base-char)
+  (:generator 4
+   (inst mov (make-ea :byte :base object
+		      :disp (- (+ (* vector-data-offset word-bytes)
+				  index)
+			       other-pointer-type))
+	 value)
+   (move result value)))
diff --git a/compiler/x86/c-call.lisp b/compiler/x86/c-call.lisp
new file mode 100644
index 000000000..56911e3f9
--- /dev/null
+++ b/compiler/x86/c-call.lisp
@@ -0,0 +1,214 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/c-call.lisp,v 1.1 1997/01/18 14:31:22 ram Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the VOPs and other necessary machine specific support
+;;; routines for call-out to C.
+;;;
+;;; Written by William Lott.
+;;;
+;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
+
+(in-package :x86)
+(use-package :alien)
+(use-package :alien-internals)
+
+;; The move-argument vop is going to store args on the stack for call-out.
+;; These tn's will be used for that. move-arg is normally used for
+;; things going down the stack but C wants to have args indexed in
+;; the positive direction.
+
+
+(defun my-make-wired-tn (prim-type-name sc-name offset)
+  (make-wired-tn (primitive-type-or-lose prim-type-name *backend*)
+		 (sc-number-or-lose sc-name *backend*)
+		 offset))
+
+(defstruct arg-state
+  (stack-frame-size 0))
+
+(def-alien-type-method (integer :arg-tn) (type state)
+  (let ((stack-frame-size (arg-state-stack-frame-size state)))
+    (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
+    (multiple-value-bind
+	(ptype stack-sc)
+	(if (alien-integer-type-signed type)
+	    (values 'signed-byte-32 'signed-stack)
+	    (values 'unsigned-byte-32 'unsigned-stack))
+      (my-make-wired-tn ptype stack-sc stack-frame-size))))
+
+(def-alien-type-method (system-area-pointer :arg-tn) (type state)
+  (declare (ignore type))
+  (let ((stack-frame-size (arg-state-stack-frame-size state)))
+    (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
+    (my-make-wired-tn 'system-area-pointer
+		      'sap-stack
+		      stack-frame-size)))
+
+(def-alien-type-method (double-float :arg-tn) (type state)
+  (declare (ignore type))
+  (let ((stack-frame-size
+	 (logandc2 (1+ (arg-state-stack-frame-size state)) 1)))
+    (setf (arg-state-stack-frame-size state) (+ stack-frame-size 2))
+    (my-make-wired-tn 'double-float 'double-stack stack-frame-size)))
+
+(def-alien-type-method (single-float :arg-tn) (type state)
+  (declare (ignore type))
+  (let ((stack-frame-size (arg-state-stack-frame-size state)))
+    (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
+    (my-make-wired-tn 'single-float 'single-stack stack-frame-size)))
+
+(defstruct result-state
+  (num-results 0))
+
+(defun result-reg-offset (slot)
+  (ecase slot
+    (0 eax-offset)
+    (1 edx-offset)))
+
+(def-alien-type-method (integer :result-tn) (type state)
+  (let ((num-results (result-state-num-results state)))
+    (setf (result-state-num-results state) (1+ num-results))
+    (multiple-value-bind
+	(ptype reg-sc)
+	(if (alien-integer-type-signed type)
+	    (values 'signed-byte-32 'signed-reg)
+	    (values 'unsigned-byte-32 'unsigned-reg))
+      (my-make-wired-tn ptype reg-sc (result-reg-offset num-results)))))
+
+(def-alien-type-method (system-area-pointer :result-tn) (type state)
+  (declare (ignore type))
+  (let ((num-results (result-state-num-results state)))
+    (setf (result-state-num-results state) (1+ num-results))
+    (my-make-wired-tn 'system-area-pointer 'sap-reg
+		      (result-reg-offset num-results))))
+
+(def-alien-type-method (double-float :result-tn) (type state)
+  (declare (ignore type))
+  (let ((num-results (result-state-num-results state)))
+    (setf (result-state-num-results state) (1+ num-results))
+    (my-make-wired-tn 'double-float 'double-reg (* num-results 2))))
+
+(def-alien-type-method (single-float :result-tn) (type state)
+  (declare (ignore type))
+  (let ((num-results (result-state-num-results state)))
+    (setf (result-state-num-results state) (1+ num-results))
+    (my-make-wired-tn 'single-float 'single-reg (* num-results 2))))
+
+#+nil ;;pfw obsolete now?
+(def-alien-type-method (values :result-tn) (type state)
+  (mapcar #'(lambda (type)
+	      (invoke-alien-type-method :result-tn type state))
+	  (alien-values-type-values type)))
+
+;;; pfw - from alpha
+(def-alien-type-method (values :result-tn) (type state)
+  (let ((values (alien-values-type-values type)))
+    (when (cdr values)
+      (error "Too many result values from c-call."))
+    (when values
+      (invoke-alien-type-method :result-tn (car values) state))))
+
+(def-vm-support-routine make-call-out-tns (type)
+  (let ((arg-state (make-arg-state)))
+    (collect ((arg-tns))
+      (dolist #+nil ;; this reversed list seems to cause the alien botches!!
+	(arg-type (reverse (alien-function-type-arg-types type)))
+	(arg-type (alien-function-type-arg-types type))
+	(arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
+      (values (my-make-wired-tn 'positive-fixnum 'any-reg esp-offset)
+	      (* (arg-state-stack-frame-size arg-state) word-bytes)
+	      (arg-tns)
+	      (invoke-alien-type-method :result-tn
+					(alien-function-type-result-type type)
+					(make-result-state))))))
+
+(define-vop (foreign-symbol-address)
+  (:translate foreign-symbol-address)
+  (:policy :fast-safe)
+  (:args)
+  (:arg-types (:constant simple-string))
+  (:info foreign-symbol)
+  (:results (res :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:generator 2
+   (inst lea res (make-fixup (extern-alien-name foreign-symbol)
+			     :foreign))))
+
+(define-vop (call-out)
+  (:args (function :scs (sap-reg))
+	 (args :more t))
+  (:results (results :more t))
+  ;; eax is already wired
+  (:temporary (:sc dword-reg :offset ecx-offset) ecx)
+  (:temporary (:sc dword-reg :offset edx-offset) edx)
+  (:temporary (:sc unsigned-stack :from (:eval 0) :to (:eval 1)) cw-temp)
+  (:node-var node)
+  (:vop-var vop)
+  (:save-p t)
+  (:ignore args ecx edx)
+  (:generator 0 
+    (cond ((policy node (> space speed))
+	   (move eax-tn function)
+	   (inst call (make-fixup (extern-alien-name "call_into_c") :foreign)))
+	  (t
+	   (inst wait)  ; Catch any pending FPE exceptions
+	   (inst mov (make-ea :dword :disp (make-fixup
+					    (extern-alien-name
+					     "foreign_function_call_active")
+					    :foreign))  1)
+	   
+	   ;; Setup the NPX for C
+	   (inst fnstcw cw-temp) ; save exception masks
+	   (inst fninit)
+	   (inst fldcw cw-temp) ; restore exception masks
+	   
+	   (inst call function)
+	   ;; To give the debugger a clue. XX not really internal-error?
+	   (note-this-location vop :internal-error)
+	   
+	   ;; Restore the NPX for lisp.
+	   (inst fldz) ; insure no regs are empty
+	   (inst fldz)
+	   (inst fldz)
+	   (inst fldz)
+	   (inst fldz)
+	   (inst fldz)
+	   (inst fldz)
+	   
+	   (if (and results
+		    (location= (tn-ref-tn results) fr0-tn))
+	       ;; The return result is in fr0.
+	       (inst fxch fr7-tn) ; move the result back to fr0
+	     (inst fldz)) ; insure no regs are empty
+	   
+	   (inst mov (make-ea :dword :disp (make-fixup
+					    (extern-alien-name
+					     "foreign_function_call_active")
+					    :foreign))  0)))))
+
+(define-vop (alloc-number-stack-space)
+  (:info amount)
+  (:results (result :scs (sap-reg any-reg)))
+  (:generator 0
+    (unless (zerop amount)
+      (let ( (delta (logandc2 (+ amount 3) 3)) )
+	(inst sub esp-tn delta)))
+    (move result esp-tn)))
+
+(define-vop (dealloc-number-stack-space)
+  (:info amount)
+  (:generator 0
+    (unless (zerop amount)
+      (let ( (delta (logandc2 (+ amount 3) 3)) )
+	(inst add esp-tn delta)))))
+
diff --git a/compiler/x86/call.lisp b/compiler/x86/call.lisp
new file mode 100644
index 000000000..cb76a6ab6
--- /dev/null
+++ b/compiler/x86/call.lisp
@@ -0,0 +1,1593 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/call.lisp,v 1.1 1997/01/18 14:31:21 ram Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the VM definition of function call for the x86.
+;;;
+;;; Written by William Lott.
+;;;
+;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
+;;;
+(in-package :x86)
+
+;;;
+
+
+;;;; Interfaces to IR2 conversion:
+
+;;; Standard-Argument-Location  --  Interface
+;;;
+;;;    Return a wired TN describing the N'th full call argument passing
+;;; location.
+;;;
+(def-vm-support-routine standard-argument-location (n)
+  (declare (type unsigned-byte n))
+  (if (< n register-arg-count)
+      (make-wired-tn *any-primitive-type* descriptor-reg-sc-number
+		     (nth n register-arg-offsets))
+      (make-wired-tn *any-primitive-type* descriptor-stack-sc-number n)))
+
+
+;;; Make-Return-PC-Passing-Location  --  Interface
+;;;
+;;; Make a passing location TN for a local call return PC.
+;;;
+;;; Always wire the return PC location to the stack in its standard
+;;; location.
+;;;
+;;; No problems.
+;#+nil
+(def-vm-support-routine make-return-pc-passing-location (standard)
+  (declare (ignore standard))
+  (make-wired-tn *fixnum-primitive-type*
+		 immediate-stack-sc-number
+		 return-pc-save-offset))
+;;;
+;;; If standard is true, then use the standard (full call) location,
+;;; otherwise use any legal location.
+;;;
+;;; No problems.
+#+nil
+(def-vm-support-routine make-return-pc-passing-location (standard)
+  (if standard
+      (make-wired-tn *fixnum-primitive-type* immediate-stack-sc-number
+		     return-pc-save-offset)
+      (make-normal-tn *fixnum-primitive-type*)))
+
+;;; Make-Old-FP-Passing-Location  --  Interface
+;;;
+;;; Similar to Make-Return-PC-Passing-Location, but makes a location to pass
+;;; Old-FP in.
+;;;
+;;; This is wired in both the standard and the local-call
+;;; conventions, because we want to be able to assume it's always there.
+;;; Besides, the x86 doesn't have enough registers to really make it
+;;; profitable to pass it in a register.
+;;;
+;;; No problems
+;#+nil
+(def-vm-support-routine make-old-fp-passing-location (standard)
+  (declare (ignore standard))
+  (make-wired-tn *fixnum-primitive-type*
+		 immediate-stack-sc-number
+		 old-fp-save-offset))
+;;;
+;;; If standard is true, then use the standard (full call) location,
+;;; otherwise use any legal location.
+;;;
+;;; No problems.
+#+nil
+(def-vm-support-routine make-old-fp-passing-location (standard)
+  (if standard
+      (make-wired-tn *fixnum-primitive-type* immediate-stack-sc-number old-fp-save-offset)
+      (make-normal-tn *fixnum-primitive-type*)))
+
+;;; Make-Old-FP-Save-Location, Make-Return-PC-Save-Location  --  Interface
+;;;
+;;; Make the TNs used to hold Old-FP and Return-PC within the current
+;;; function.  We treat these specially so that the debugger can find them at a
+;;; known location.
+;;;
+;;; Without using a save-tn - which does not make much sense if it is
+;;; wire to the stack? No problems.
+(def-vm-support-routine make-old-fp-save-location (env)
+  (environment-debug-live-tn (make-wired-tn *fixnum-primitive-type*
+					    immediate-stack-sc-number
+					    old-fp-save-offset)
+			     env))
+;;;
+;;; Using a save-tn. No problems.
+#+nil
+(def-vm-support-routine make-old-fp-save-location (env)
+  (specify-save-tn
+   (environment-debug-live-tn (make-normal-tn *fixnum-primitive-type*) env)
+   (make-wired-tn *fixnum-primitive-type*
+		  immediate-stack-sc-number
+		  ocfp-save-offset)))
+
+;;;
+;;; Without using a save-tn - which does not make much sense if it is
+;;; wire to the stack? No problems.
+(def-vm-support-routine make-return-pc-save-location (env)
+  (environment-debug-live-tn (make-wired-tn *fixnum-primitive-type*
+					    immediate-stack-sc-number
+					    return-pc-save-offset)
+			     env))
+;;;
+;;; Using a save-tn. No problems.
+#+nil
+(def-vm-support-routine make-return-pc-save-location (env)
+  (let ((ptype *fixnum-primitive-type*))
+    (specify-save-tn
+     (environment-debug-live-tn (make-normal-tn ptype) env)
+     (make-wired-tn ptype
+		    immediate-stack-sc-number
+		    return-pc-save-offset))))
+
+;;; Make-Argument-Count-Location  --  Interface
+;;;
+;;;    Make a TN for the standard argument count passing location.  We only
+;;; need to make the standard location, since a count is never passed when we
+;;; are using non-standard conventions.
+;;;
+(def-vm-support-routine make-argument-count-location ()
+  (make-wired-tn *fixnum-primitive-type* any-reg-sc-number ecx-offset))
+
+
+;;; MAKE-NFP-TN  --  Interface
+;;;
+;;;    Make a TN to hold the number-stack frame pointer.  This is allocated
+;;; once per component, and is component-live.
+;;;
+(def-vm-support-routine make-nfp-tn ()
+  (make-restricted-tn *fixnum-primitive-type* ignore-me-sc-number))
+
+;;; MAKE-STACK-POINTER-TN ()
+;;; 
+(def-vm-support-routine make-stack-pointer-tn ()
+  (make-normal-tn *fixnum-primitive-type*))
+
+;;; MAKE-NUMBER-STACK-POINTER-TN ()
+;;; 
+(def-vm-support-routine make-number-stack-pointer-tn ()
+  (make-restricted-tn *fixnum-primitive-type* ignore-me-sc-number))
+
+;;; Make-Unknown-Values-Locations  --  Interface
+;;;
+;;;    Return a list of TNs that can be used to represent an unknown-values
+;;; continuation within a function.
+;;;
+(def-vm-support-routine make-unknown-values-locations ()
+  (list (make-stack-pointer-tn)
+	(make-normal-tn *fixnum-primitive-type*)))
+
+
+;;; Select-Component-Format  --  Interface
+;;;
+;;;    This function is called by the Entry-Analyze phase, allowing
+;;; VM-dependent initialization of the IR2-Component structure.  We push
+;;; placeholder entries in the Constants to leave room for additional
+;;; noise in the code object header.
+;;;
+(def-vm-support-routine select-component-format (component)
+  (declare (type component component))
+  (dotimes (i code-constants-offset)
+    (vector-push-extend nil
+			(ir2-component-constants (component-info component))))
+  (undefined-value))
+
+
+;;;; Frame hackery:
+
+;;; Used for setting up the Old-FP in local call.
+;;;
+(define-vop (current-fp)
+  (:results (val :scs (any-reg immediate-stack)))
+  (:generator 1
+    (move val ebp-tn)))
+
+;;; We don't have a seperate NFP, so we don't need to do anything here.
+;;;
+(define-vop (compute-old-nfp)
+  (:results (val))
+  (:ignore val)
+  (:generator 1
+    nil))
+
+
+(define-vop (xep-allocate-frame)
+  (:info start-lab copy-more-arg-follows)
+  (:vop-var vop)
+  (:generator 1
+    ;; Make sure the function is aligned, and drop a label pointing to this
+    ;; function header.
+    (align lowtag-bits)
+    (trace-table-entry trace-table-function-prologue)
+    (emit-label start-lab)
+    ;; Skip space for the function header.
+    (inst function-header-word)
+    (dotimes (i (1- vm:function-code-offset))
+      (inst dword 0))
+
+    ;; The start of the actual code.
+    ;; Save the return-pc.
+    (popw ebp-tn (- (1+ return-pc-save-offset)))
+
+    ;; If copy-more-arg follows it will allocate the correct stack
+    ;; size. The stack is not allocate first here as this may expose
+    ;; args on the stack if they take up more space than the frame!
+    (unless copy-more-arg-follows
+      ;; The args fit within the frame so just allocate the frame.
+      (inst lea esp-tn
+	    (make-ea :dword :base ebp-tn
+		     :disp (- (* vm:word-bytes
+				 (max 3 (sb-allocated-size 'stack)))))))
+
+    (trace-table-entry trace-table-normal)))
+
+;;; This is emitted directly before either a known-call-local, call-local,
+;;; or a multiple-call-local.  All it does is allocate stack space for the
+;;; callee (who has the same size stack as us).
+;;; 
+(define-vop (allocate-frame)
+  (:results (res :scs (any-reg immediate-stack))
+	    (nfp))
+  (:info callee)
+  (:ignore nfp callee)
+  (:generator 2
+    (move res esp-tn)
+    (inst sub esp-tn (* vm:word-bytes (sb-allocated-size 'stack)))))
+
+;;; Allocate a partial frame for passing stack arguments in a full call.  Nargs
+;;; is the number of arguments passed.  We allocate at least 3 slots, because
+;;; the XEP noise is going to want to use them before it can extend the stack.
+;;;
+(define-vop (allocate-full-call-frame)
+  (:info nargs)
+  (:results (res :scs (any-reg immediate-stack)))
+  (:generator 2
+    (move res esp-tn)
+    (inst sub esp-tn (* (max nargs 3) vm:word-bytes))))
+
+
+
+;;; Default-Unknown-Values  --  Internal
+;;;
+;;;    Emit code needed at the return-point from an unknown-values call for a
+;;; fixed number of values.  Values is the head of the TN-Ref list for the
+;;; locations that the values are to be received into.  Nvals is the number of
+;;; values that are to be received (should equal the length of Values).
+;;;
+;;;    Move-Temp is a Descriptor-Reg TN used as a temporary.
+;;;
+;;;    This code exploits the fact that in the unknown-values convention, a
+;;; single value return returns at the return PC + 2, whereas a return of other
+;;; than one value returns directly at the return PC.
+;;;
+;;;    If 0 or 1 values are expected, then we just emit an instruction to reset
+;;; the SP (which will only be executed when other than 1 value is returned.)
+;;;
+;;; In the general case we have to do three things:
+;;;  -- Default unsupplied register values.  This need only be done when a
+;;;     single value is returned, since register values are defaulted by the
+;;;     called in the non-single case.
+;;;  -- Default unsupplied stack values.  This needs to be done whenever there
+;;;     are stack values.
+;;;  -- Reset SP.  This must be done whenever other than 1 value is returned,
+;;;     regardless of the number of values desired.
+;;;
+;;;
+(defun default-unknown-values (vop values nvals)
+  (declare (type (or tn-ref null) values)
+	   (type unsigned-byte nvals))
+  (cond
+   ((<= nvals 1)
+    (note-this-location vop :single-value-return)
+    (inst mov esp-tn ebx-tn))
+   ((<= nvals register-arg-count)
+    (let ((regs-defaulted (gen-label)))
+      (note-this-location vop :unknown-return)
+      (inst jmp-short regs-defaulted)
+      ;; Default the unsuppled registers.
+      (let* ((2nd-tn-ref (tn-ref-across values))
+	     (2nd-tn (tn-ref-tn 2nd-tn-ref)))
+	(inst mov 2nd-tn nil-value)
+	(when (> nvals 2)
+	  (loop
+	    for tn-ref = (tn-ref-across 2nd-tn-ref)
+	    then (tn-ref-across tn-ref)
+	    for count from 2 below register-arg-count
+	    do count (inst mov (tn-ref-tn tn-ref) 2nd-tn))))
+      (inst mov ebx-tn esp-tn)
+      (emit-label regs-defaulted)
+      (inst mov esp-tn ebx-tn)))
+   #+bogus-code-broken-optimization
+   ((<= nvals 6)
+    ;; 29+(nvals-3)*21 bytes for this branch.  For nvals=6 that is 92
+    ;; bytes, which is the same as using the blt below.
+    (let ((regs-defaulted (gen-label))
+	  (defaulting-done (gen-label))
+	  (default-stack-slots (gen-label)))
+      ;; Branch off to the MV case.
+      (inst jmp-short regs-defaulted)
+
+      ;; Default the register args
+      (inst mov eax-tn nil-value)
+      (loop
+	for tn-ref = (tn-ref-across values)
+	         then (tn-ref-across tn-ref)
+	for count from 2 below register-arg-count
+	do count (inst mov (tn-ref-tn tn-ref) eax-tn))
+      ;; Fake other registers so it looks like we returned with all the
+      ;; registers filled in.
+      (move ebx-tn esp-tn)
+      (inst push edx-tn)
+      (inst jmp default-stack-slots)
+
+      (emit-label regs-defaulted)
+      (inst mov eax-tn nil-value)
+      (storew edx-tn ebx-tn (- word-bytes))
+      (collect ((defaults))
+	(do ((i register-arg-count (1+ i))
+	     (val (do ((i 0 (1+ i))
+		       (val values (tn-ref-across val)))
+		      ((= i register-arg-count) val))
+		  (tn-ref-across val)))
+	    ((null val))
+	  (let ((default-lab (gen-label))
+		(tn (tn-ref-tn val)))
+	    (defaults (cons default-lab tn))
+
+	    (inst cmp ecx-tn (fixnum i))
+	    (inst jmp :be default-lab)
+	    (loadw edx-tn ebx-tn i)
+	    (inst mov tn edx-tn)))
+	    
+	(emit-label defaulting-done)
+	(loadw edx-tn ebx-tn (- word-bytes))
+	(move esp-tn ebx-tn)
+	    
+	(let ((defaults (defaults)))
+	  (when defaults
+	    (assemble (*elsewhere*)
+	      (trace-table-entry trace-table-function-prologue)
+	      (dolist (default defaults)
+		(emit-label (car default))
+		(inst mov (cdr default) eax-tn))
+	      (inst jmp defaulting-done)
+	      (trace-table-entry trace-table-normal)))))))
+   (t
+    ;; 92 bytes for this branch.
+    (let ((regs-defaulted (gen-label))
+	  (restore-edi (gen-label))
+	  (no-stack-args (gen-label))
+	  (default-stack-vals (gen-label))
+	  (count-okay (gen-label)))
+      (note-this-location vop :unknown-return)
+      ;; Branch off to the MV case.
+      (inst jmp-short regs-defaulted)
+
+      ;; Default the register args, and set up the stack as if we entered
+      ;; the MV return point.
+      (inst mov ebx-tn esp-tn)
+      (inst push edx-tn)
+      (inst mov edi-tn nil-value)
+      (inst push edi-tn)
+      (inst mov esi-tn edi-tn)
+      ;; Compute a pointer to where to put the [defaulted] stack values.
+      (emit-label no-stack-args)
+      (inst lea edi-tn
+	    (make-ea :dword :base ebp-tn
+		     :disp (* (- (1+ register-arg-count)) word-bytes)))
+      ;; Load EAX with NIL so we can quickly store it, and set up stuff
+      ;; for the loop.
+      (inst mov eax-tn nil-value)
+      (inst std)
+      (inst mov ecx-tn (- nvals register-arg-count))
+      ;; Jump into the default loop.
+      (inst jmp default-stack-vals)
+
+      ;; The regs are defaulted.  We need to copy any stack arguments,
+      ;; and then default the remaining stack arguments.
+      (emit-label regs-defaulted)
+      ;; Save EDI.
+      (storew edi-tn ebx-tn (- (1+ 1)))
+      ;; Compute the number of stack arguments, and if it's zero or less,
+      ;; don't copy any stack arguments.
+      (inst sub ecx-tn (fixnum register-arg-count))
+      (inst jmp :le no-stack-args)
+
+      ;; Throw away any unwanted args.
+      (inst cmp ecx-tn (fixnum (- nvals register-arg-count)))
+      (inst jmp :be count-okay)
+      (inst mov ecx-tn (fixnum (- nvals register-arg-count)))
+      (emit-label count-okay)
+      ;; Save the number of stack values.
+      (inst mov eax-tn ecx-tn)
+      ;; Compute a pointer to where the stack args go.
+      (inst lea edi-tn
+	    (make-ea :dword :base ebp-tn
+		     :disp (* (- (1+ register-arg-count)) word-bytes)))
+      ;; Save ESI, and compute a pointer to where the args come from.
+      (storew esi-tn ebx-tn (- (1+ 2)))
+      (inst lea esi-tn
+	    (make-ea :dword :base ebx-tn
+		     :disp (* (- (1+ register-arg-count)) word-bytes)))
+      ;; Do the copy.
+      (inst shr ecx-tn word-shift)		; make word count
+      (inst std)
+      (inst rep)
+      (inst movs :dword)
+      ;; Restore ESI.
+      (loadw esi-tn ebx-tn (- (1+ 2)))
+      ;; Now we have to default the remaining args.  Find out how many.
+      ;; If none, then just blow out of here.
+      (inst sub eax-tn (fixnum (- nvals register-arg-count)))
+      (inst jmp :be restore-edi)
+      (inst mov ecx-tn eax-tn)
+      (inst shr ecx-tn word-shift)	; word count
+      ;; Load EAX with NIL for fast storing.
+      (inst mov eax-tn nil-value)
+      ;; Do the store.
+      (emit-label default-stack-vals)
+      (inst rep)
+      (inst stos eax-tn)
+      ;; Restore EDI, and reset the stack.
+      (emit-label restore-edi)
+      (loadw edi-tn ebx-tn (- (1+ 1)))
+      (inst mov esp-tn ebx-tn))))
+  (undefined-value))
+
+
+
+;;;; Unknown values receiving:
+
+;;; Receive-Unknown-Values  --  Internal
+;;;
+;;;    Emit code needed at the return point for an unknown-values call for an
+;;; arbitrary number of values.
+;;;
+;;;    We do the single and non-single cases with no shared code: there doesn't
+;;; seem to be any potential overlap, and receiving a single value is more
+;;; important efficiency-wise.
+;;;
+;;;    When there is a single value, we just push it on the stack, returning
+;;; the old SP and 1.
+;;;
+;;;    When there is a variable number of values, we move all of the argument
+;;; registers onto the stack, and return Args and Nargs.
+;;;
+;;;    Args and Nargs are TNs wired to the named locations.  We must
+;;; explicitly allocate these TNs, since their lifetimes overlap with the
+;;; results Start and Count (also, it's nice to be able to target them).
+;;;
+(defun receive-unknown-values (args nargs start count)
+  (declare (type tn args nargs start count))
+  (let ((variable-values (gen-label))
+	(done (gen-label)))
+    (inst jmp-short variable-values)
+    
+    (inst mov start esp-tn)
+    (inst push (first register-arg-tns))
+    (inst mov count (fixnum 1))
+    (inst jmp done)
+
+    (emit-label variable-values)
+    (loop
+      for arg in register-arg-tns
+      for i downfrom -1
+      do (storew arg args i)) ; dtc: this writes the registers onto
+                              ; the stack even if they are not needed,
+                              ; only the number specified in ecx are
+                              ; used and have stack allocated to
+                              ; them. No harm is done.
+    (move start args)
+    (move count nargs)
+
+    (emit-label done))
+  (undefined-value))
+
+
+;;; VOP that can be inherited by unknown values receivers.  The main thing this
+;;; handles is allocation of the result temporaries.
+;;;
+(define-vop (unknown-values-receiver)
+  (:temporary (:sc descriptor-reg :offset ebx-offset
+		   :from :eval :to (:result 0))
+	      values-start)
+  (:temporary (:sc any-reg :offset ecx-offset
+	       :from :eval :to (:result 1))
+	      nvals)
+  (:results (start :scs (any-reg immediate-stack))
+	    (count :scs (any-reg immediate-stack))))
+
+
+;;;; Local call with unknown values convention return:
+
+;;; Non-TR local call for a fixed number of values passed according to the
+;;; unknown values convention.
+;;;
+;;; FP is the frame pointer in install before doing the call.
+;;;
+;;; NFP would be the number-stack frame pointer if we had a seperate number
+;;; stack.
+;;; 
+;;; Args are the argument passing locations, which are specified only to
+;;; terminate their lifetimes in the caller.
+;;;
+;;; Values are the return value locations (wired to the standard passing
+;;; locations).
+;;; Nvals is the number of values received.
+;;;
+;;; Save is the save info, which we can ignore since saving has been done.
+;;;
+;;; Target is a continuation pointing to the start of the called function.
+;;;
+;;;
+(define-vop (call-local)
+  (:args (fp)
+	 (nfp)
+	 (args :more t))
+  (:results (values :more t))
+  (:save-p t)
+  (:move-args :local-call)
+  (:info arg-locs callee target nvals)
+  (:vop-var vop)
+  (:ignore nfp arg-locs args #+nil callee)
+  (:generator 5
+    (trace-table-entry trace-table-call-site)
+    (move ebp-tn fp)
+
+    (let ((ret-tn (callee-return-pc-tn callee)))
+
+#+nil      (format t "*call-local ~s; tn-kind ~s; tn-save-tn ~s; its tn-kind ~s~%"
+	      ret-tn (c::tn-kind ret-tn) (c::tn-save-tn ret-tn)
+	      (c::tn-kind (c::tn-save-tn ret-tn)))
+
+      ;; Is the return-pc on the stack or in a register?
+      (sc-case ret-tn
+	((immediate-stack)
+#+nil	 (format t "*call-local: ret-tn on stack; offset=~s~%"
+		 (tn-offset ret-tn))
+	 ;; Stack
+	 (storew (make-fixup nil :code-object return)
+		 ebp-tn (- (1+ (tn-offset ret-tn)))))
+
+	((any-reg descriptor-reg)
+	 ;; Register
+	 (inst lea ret-tn (make-fixup nil :code-object return)))))
+
+    (note-this-location vop :call-site)
+    (inst jmp target)
+    #+x86-lra
+    (progn 
+      (align lowtag-bits #x90)
+      (inst lra-header-word)
+      (inst nop)
+      (inst nop)
+      (inst nop))
+    RETURN
+    (default-unknown-values vop values nvals)
+    (trace-table-entry trace-table-normal)))
+
+;;; Non-TR local call for a variable number of return values passed according
+;;; to the unknown values convention.  The results are the start of the values
+;;; glob and the number of values received.
+;;;
+(define-vop (multiple-call-local unknown-values-receiver)
+  (:args (fp)
+	 (nfp)
+	 (args :more t))
+  (:save-p t)
+  (:move-args :local-call)
+  (:info save callee target)
+  (:ignore args save nfp #+nil callee)
+  (:vop-var vop)
+  (:generator 20
+    (trace-table-entry trace-table-call-site)
+    (move ebp-tn fp)
+
+    (let ((ret-tn (callee-return-pc-tn callee)))
+
+#+nil      (format t "*multiple-call-local ~s; tn-kind ~s; tn-save-tn ~s; its tn-kind ~s~%"
+	      ret-tn (c::tn-kind ret-tn) (c::tn-save-tn ret-tn)
+	      (c::tn-kind (c::tn-save-tn ret-tn)))
+
+      ;; Is the return-pc on the stack or in a register?
+      (sc-case ret-tn
+	((immediate-stack)
+#+nil	 (format t "*multiple-call-local: ret-tn on stack; offset=~s~%"
+		 (tn-offset ret-tn))
+	 ;; Stack
+	 (storew (make-fixup nil :code-object return)
+		 ebp-tn (- (1+ (tn-offset ret-tn)))))
+
+	((any-reg descriptor-reg)
+	 ;; Register
+	 (inst lea ret-tn (make-fixup nil :code-object return)))))
+
+    (note-this-location vop :call-site)
+    (inst jmp target)
+    #+x86-lra
+    (progn 
+      (align lowtag-bits #x90)
+      (inst lra-header-word)
+      (inst nop)
+      (inst nop)
+      (inst nop))
+    RETURN
+    (note-this-location vop :unknown-return)
+    (receive-unknown-values values-start nvals start count)
+    (trace-table-entry trace-table-normal)))
+
+
+;;;; Local call with known values return:
+
+;;; Non-TR local call with known return locations.  Known-value return works
+;;; just like argument passing in local call.
+;;;
+;;; Note: we can't use normal load-tn allocation for the fixed args, since all
+;;; registers may be tied up by the more operand.  Instead, we use
+;;; MAYBE-LOAD-STACK-TN.
+;;;
+(define-vop (known-call-local)
+  (:args (fp)
+	 (nfp)
+	 (args :more t))
+  (:results (res :more t))
+  (:move-args :local-call)
+  (:save-p t)
+  (:info save callee target)
+  (:ignore args res save nfp #+nil callee)
+  (:vop-var vop)
+  (:generator 5
+    (trace-table-entry trace-table-call-site)
+    (move ebp-tn fp)
+
+    (let ((ret-tn (callee-return-pc-tn callee)))
+
+#+nil      (format t "*known-call-local ~s; tn-kind ~s; tn-save-tn ~s; its tn-kind ~s~%"
+	      ret-tn (c::tn-kind ret-tn) (c::tn-save-tn ret-tn)
+	      (c::tn-kind (c::tn-save-tn ret-tn)))
+
+      ;; Is the return-pc on the stack or in a register?
+      (sc-case ret-tn
+	((immediate-stack)
+#+nil	 (format t "*known-call-local: ret-tn on stack; offset=~s~%"
+		 (tn-offset ret-tn))
+	 ;; Stack
+	 (storew (make-fixup nil :code-object return)
+		 ebp-tn (- (1+ (tn-offset ret-tn)))))
+
+	((any-reg descriptor-reg)
+	 ;; Register
+	 (inst lea ret-tn (make-fixup nil :code-object return)))))
+
+    (note-this-location vop :call-site)
+    (inst jmp target)
+    #+x86-lra
+    (progn 
+      (align lowtag-bits #x90)
+      (inst lra-header-word)
+      (inst nop)
+      (inst nop)
+      (inst nop))
+    RETURN
+    (note-this-location vop :known-return)
+    (trace-table-entry trace-table-normal)))
+
+;;; Return from known values call.  We receive the return locations as
+;;; arguments to terminate their lifetimes in the returning function.  We
+;;; restore FP and CSP and jump to the Return-PC.
+;;;
+;;; We can assume we know exactly where old-fp and return-pc are because
+;;; make-old-fp-save-location and make-return-pc-save-location always
+;;; return the same place.
+;;;
+#+nil
+(define-vop (known-return)
+  (:args (old-fp)
+	 (return-pc :scs (any-reg immediate-stack) :target rpc)
+	 (vals :more t))
+  (:move-args :known-return)
+  (:info val-locs)
+  (:temporary (:sc dword-reg :from (:argument 1)) rpc)
+  (:ignore val-locs vals)
+  (:vop-var vop)
+  (:generator 6
+    (trace-table-entry trace-table-function-epilogue)
+    ;; Save the return-pc in a register 'cause the frame-pointer is going away.
+    ;; Note this not in the usual stack location so we can't use RET
+    (move rpc return-pc)
+    ;; Restore the stack.
+    (move esp-tn ebp-tn)
+    ;; Restore the old fp.  We know OLD-FP is going to be in it's stack
+    ;; save slot, which is a different frame that than this one,
+    ;; so we don't have to worry about having just cleared
+    ;; most of the stack.
+    (move ebp-tn old-fp)
+    (inst jmp rpc)
+    (trace-table-entry trace-table-normal)))
+
+;;; From Douglas Crosher
+;;; Return from known values call.  We receive the return locations as
+;;; arguments to terminate their lifetimes in the returning function.  We
+;;; restore FP and CSP and jump to the Return-PC.
+;;;
+;;; The old-fp may be either in a register or on the stack in its
+;;; standard save locations - slot 0.
+;;;
+;;; The return-pc may be in a register or on the stack in any slot.
+;;;
+(define-vop (known-return)
+  (:args (old-fp)
+	 (return-pc)
+	 (vals :more t))
+  (:move-args :known-return)
+  (:info val-locs)
+  (:ignore val-locs vals)
+  (:vop-var vop)
+  (:generator 6
+    (trace-table-entry trace-table-function-epilogue)
+
+#+nil    (format t "*known-return: old-fp ~s, tn-kind ~s; ~s ~s~%"
+	    old-fp (c::tn-kind old-fp) (c::tn-save-tn old-fp)
+	    (c::tn-kind (c::tn-save-tn old-fp)))
+
+#+nil    (format t "*known-return: return-pc ~s, tn-kind ~s; ~s ~s~%"
+	    return-pc (c::tn-kind return-pc) (c::tn-save-tn return-pc)
+	    (c::tn-kind (c::tn-save-tn return-pc)))
+
+    ;; return-pc may be either in a register or on the stack.
+    (sc-case return-pc
+      ((any-reg descriptor-reg)
+       (sc-case old-fp
+         ((immediate-stack)
+
+#+nil	  (format t "*known-return: old-fp ~s on stack; offset=~s~%"
+		  old-fp (tn-offset old-fp))
+
+	  (cond ((zerop (tn-offset old-fp))
+		 ;; Zot all of the stack except for the old-fp.
+		 (inst lea esp-tn
+		       (make-ea :dword :base ebp-tn
+				:disp
+				(- (* (1+ old-fp-save-offset) word-bytes))))
+		 ;; Restore the old fp from its save location on the stack,
+		 ;; and zot the stack.
+		 (inst pop ebp-tn))
+
+		(t 
+		 (cerror "Continue any-way"
+			 "VOP return-local doesn't work if old-fp (in slot %s) is not in slot 0"
+			 (tn-offset old-fp)))))
+	  
+	 ((any-reg descriptor-reg)
+	  ;; Zot all the stack.
+	  (move esp-tn ebp-tn)
+	  ;; Restore the old-fp.
+	  (move ebp-tn old-fp)))
+
+       ;; Return; return-pc is in a register.
+       (inst jmp return-pc))
+
+      ((immediate-stack descriptor-stack)
+
+#+nil       (format t "*known-return: return-pc ~s on stack; offset=~s~%"
+	       return-pc (tn-offset return-pc))
+
+       ;; Zot all of the stack except for the old-fp and return-pc.
+       (inst lea esp-tn
+	     (make-ea :dword :base ebp-tn
+		      :disp
+		      (- (* (1+ (tn-offset return-pc)) word-bytes))))
+       ;; Restore the old fp.  old-fp may be either on the stack in its
+       ;; save location or in a register, in either case this restores it.
+       (move ebp-tn old-fp)
+       ;; The return pops the return address (4 bytes), then we need
+       ;; to pop all the slots before the return-pc which includes the
+       ;; 4 bytes for the old-fp.
+       (inst ret (* (tn-offset return-pc) word-bytes))))
+
+    (trace-table-entry trace-table-normal)))
+
+
+;;;; Full call:
+;;;
+;;;    There is something of a cross-product effect with full calls.  Different
+;;; versions are used depending on whether we know the number of arguments or
+;;; the name of the called function, and whether we want fixed values, unknown
+;;; values, or a tail call.
+;;;
+;;; In full call, the arguments are passed creating a partial frame on the
+;;; stack top and storing stack arguments into that frame.  On entry to the
+;;; callee, this partial frame is pointed to by FP.
+
+;;; Define-Full-Call  --  Internal
+;;;
+;;;    This macro helps in the definition of full call VOPs by avoiding code
+;;; replication in defining the cross-product VOPs.
+;;;
+;;; Name is the name of the VOP to define.
+;;; 
+;;; Named is true if the first argument is an fdefinition object whose
+;;; definition is to be called.
+;;;
+;;; Return is either :Fixed, :Unknown or :Tail:
+;;; -- If :Fixed, then the call is for a fixed number of values, returned in
+;;;    the standard passing locations (passed as result operands).
+;;; -- If :Unknown, then the result values are pushed on the stack, and the
+;;;    result values are specified by the Start and Count as in the
+;;;    unknown-values continuation representation.
+;;; -- If :Tail, then do a tail-recursive call.  No values are returned.
+;;;    The Old-Fp and Return-PC are passed as the second and third arguments.
+;;;
+;;; In non-tail calls, the pointer to the stack arguments is passed as the last
+;;; fixed argument.  If Variable is false, then the passing locations are
+;;; passed as a more arg.  Variable is true if there are a variable number of
+;;; arguments passed on the stack.  Variable cannot be specified with :Tail
+;;; return.  TR variable argument call is implemented separately.
+;;;
+;;; In tail call with fixed arguments, the passing locations are passed as a
+;;; more arg, but there is no new-FP, since the arguments have been set up in
+;;; the current frame.
+;;;
+(defmacro define-full-call (name named return variable)
+  (assert (not (and variable (eq return :tail))))
+  `(define-vop (,name
+		,@(when (eq return :unknown)
+		    '(unknown-values-receiver)))
+    (:args
+     ,@(unless (eq return :tail)
+	       '((new-fp :scs (any-reg) :to (:argument 1))))
+     
+     (fun :scs (descriptor-reg descriptor-stack)
+          :target eax :to (:argument 0))
+     
+     ,@(when (eq return :tail)
+	     '((old-fp)
+	       (return-pc)))
+      
+     ,@(unless variable '((args :more t :scs (descriptor-reg)))))
+
+    ,@(when (eq return :fixed)
+	    '((:results (values :more t))))
+   
+    (:save-p ,(if (eq return :tail) :compute-only t))
+
+    ,@(unless (or (eq return :tail) variable)
+	      '((:move-args :full-call)))
+
+    (:vop-var vop)
+    (:info
+     ,@(unless (or variable (eq return :tail)) '(arg-locs))
+     ,@(unless variable '(nargs))
+     ,@(when (eq return :fixed) '(nvals)))
+
+    (:ignore
+     ,@(unless (or variable (eq return :tail)) '(arg-locs))
+     ,@(unless variable '(args)))
+    
+    ;; We pass either the fdefn object (for named call) or the actual
+    ;; function object (for unnamed call) in EAX.  With named call,
+    ;; closure-tramp will replace it with the real function and invoke
+    ;; the real function for closures.  Non-closures do not need this
+    ;; value, so don't care what shows up in it.
+    (:temporary
+     (:sc descriptor-reg :offset eax-offset :from (:argument 0) :to :eval)
+     eax)
+
+    ;; We pass the number of arguments in ECX.
+    (:temporary (:sc dword-reg :offset ecx-offset :to :eval) ecx)
+
+    ;; With variable call, we have to load the register-args out
+    ;; of the (new) stack frame before doing the call.  Therefore,
+    ;; we have to tell the lifetime stuff that we need to use them.
+    ,@(when variable
+	    (mapcar #'(lambda (name offset)
+			`(:temporary (:sc descriptor-reg
+				      :offset ,offset
+				      :from (:argument 0)
+				      :to :eval)
+			  ,name))
+		    register-arg-names register-arg-offsets))
+
+    ,@(when (eq return :tail)
+	    '((:temporary (:sc dword-reg :from (:argument 1) :to (:argument 2))
+			  old-fp-tmp)
+	      #+x86-lra
+	      (:temporary (:sc dword-reg :from (:argument 2) :to (:argument 3))
+			  ret-pc-tmp)
+	      ))
+
+    (:generator ,(+ (if named 5 0)
+		    (if variable 19 1)
+		    (if (eq return :tail) 0 10)
+		    15
+		    (if (eq return :unknown) 25 0))
+     (trace-table-entry trace-table-call-site)
+
+     ;; This has to be done before the frame pointer is changed!
+     ;; eax stores the 'lexical environment' needed for closures
+     (move eax fun)
+     
+
+     ,@(if variable
+	   ;; For variable call, compute the number of arguments and
+	   ;; move some of the arguments to registers.
+	   (collect ((noise))
+		    ;; Compute the number of arguments.
+		    (noise '(inst mov ecx new-fp))
+		    (noise '(inst sub ecx esp-tn))
+		    ;; Move the necessary args to registers, this
+		    ;; moves them all even if they are not all needed.
+		    (loop
+		     for name in register-arg-names
+		     for index downfrom -1
+		     do (noise `(loadw ,name new-fp ,index)))
+		    (noise))
+	   '((if (zerop nargs)
+		 (inst xor ecx ecx)
+	       (inst mov ecx (fixnum nargs)))))
+     ,@(cond ((eq return :tail)
+	      '(;; Python has figured out what frame we should return
+		;; to so might as well use that clue. This seems
+		;; really important to the implementation of things
+		;; like (without-interrupts ...)
+
+		;; dtc; Could be doing a tail call from a
+		;; known-local-call etc in which the old-fp or ret-pc
+		;; are in regs or in non-standard places. If the
+		;; passing location were wired to the stack in
+		;; standard locations then these moves will be
+		;; un-necessary; this is probably best for the x86.
+		(sc-case old-fp
+		  ((immediate-stack descriptor-stack)
+		   (unless (= old-fp-save-offset (tn-offset old-fp))
+		     (format t "** tail-call old-fp not S0~%")
+		     (move old-fp-tmp old-fp)
+		     (storew old-fp-tmp ebp-tn (- (1+ old-fp-save-offset)))))
+		  ((any-reg descriptor-reg)
+		     (format t "** tail-call old-fp in reg not S0~%")
+		   (storew old-fp ebp-tn (- (1+ old-fp-save-offset)))))
+
+		#+x86-lra
+		(sc-case return-pc
+		  ((immediate-stack descriptor-stack)
+		   (unless (= return-pc-save-offset (tn-offset return-pc))
+		     (format t "** tail-call ret-pc not S1~%")
+		     (move ret-pc-tmp return-pc)
+		     (storew ret-pc-tmp ebp-tn (- (1+ return-pc-save-offset)))))
+		  ((any-reg descriptor-reg)
+		   (format t "** tail-call ret-pc in reg not S1~%")
+		   (storew return-pc ebp-tn (- (1+ return-pc-save-offset)))))
+		
+		;; For tail call, we have to push the return-pc so
+		;; that it looks like we CALLed despite the fact that
+		;; we are going to JMP.
+		(inst push return-pc)
+		))
+	     (t
+	      ;; For non-tail call, we have to save our frame pointer
+	      ;; and install the new frame pointer.  We can't load stack
+	      ;; tns after this point.
+	      `(
+		;; Python doesn't seem to allocate a frame here which
+		;; doesn't leave room for the ofp/ret stuff.
+
+		;; The variable args are on the stack and become the
+		;; frame, but there may be <3 args and 3 stack slots
+		;; are assumed allocate on the call. So need to ensure
+		;; there are at least 3 slots. This hack justs adds 3
+		;; more.
+		,(if variable
+		     '(inst sub esp-tn (fixnum 3)))
+
+		;; Save the fp
+		(storew ebp-tn new-fp (- (1+ old-fp-save-offset)))
+
+		;; Save the return address.
+		#+x86-lra
+		(storew (make-fixup nil :code-object return)
+			new-fp (- (1+ return-pc-save-offset)))
+
+		(move ebp-tn new-fp)	; NB - now on new stack frame.
+		
+		;; Push the return address for backward compatability.
+		#+x86-lra
+		(inst push (make-ea :dword :base new-fp :disp -8))
+		))
+	     )
+  
+     (note-this-location vop :call-site)
+
+     #-x86-lra
+     (inst ,(if (eq return :tail) 'jmp 'call)
+      (make-ea :dword :base eax
+	       :disp ,(if named
+			  '(- (* fdefn-raw-addr-slot word-bytes)
+			    other-pointer-type)
+			  '(- (* closure-function-slot word-bytes)
+			    function-pointer-type))))
+
+     #+x86-lra
+     (inst jmp (make-ea :dword :base eax
+			:disp ,(if named
+				   '(- (* fdefn-raw-addr-slot word-bytes)
+				       other-pointer-type)
+				 '(- (* closure-function-slot word-bytes)
+				     function-pointer-type))))
+     
+     ,@(ecase return
+	      (:fixed
+		 #+x86-lra
+		 '((align lowtag-bits #x90)
+		   (inst lra-header-word)
+		   (inst nop)
+		   (inst nop)
+		   (inst nop)
+		   RETURN
+		   (default-unknown-values vop values nvals))
+		 #-x86-lra
+		 '((default-unknown-values vop values nvals))
+		 )
+	      (:unknown
+	       #+x86-lra
+	       '((align lowtag-bits #x90)
+		 (inst lra-header-word)
+		 (inst nop)
+		 (inst nop)
+		 (inst nop)
+		 RETURN
+		 (note-this-location vop :unknown-return)
+		 (receive-unknown-values values-start nvals start count))
+	       #-x86-lra
+	       '((note-this-location vop :unknown-return)
+		 (receive-unknown-values values-start nvals start count))
+	       )
+	      (:tail))
+     (trace-table-entry trace-table-normal))))
+
+
+(define-full-call call nil :fixed nil)
+(define-full-call call-named t :fixed nil)
+(define-full-call multiple-call nil :unknown nil)
+(define-full-call multiple-call-named t :unknown nil)
+(define-full-call tail-call nil :tail nil)
+(define-full-call tail-call-named t :tail nil)
+
+(define-full-call call-variable nil :fixed t)
+(define-full-call multiple-call-variable nil :unknown t)
+
+
+;;; Defined separately, since needs special code that BLT's the arguments
+;;; down.  All the real work is done in the assembly routine.  We just
+;;; set things up so that it can find what it needs.
+;;;
+(define-vop (tail-call-variable)
+  (:args (args :scs (any-reg immediate-stack) :target esi)
+	 (function :scs (descriptor-reg descriptor-stack) :target eax)
+	 (old-fp)
+	 (ret-addr))
+  (:temporary (:sc dword-reg :offset esi-offset :from (:argument 0)) esi)
+  (:temporary (:sc dword-reg :offset eax-offset :from (:argument 1)) eax)
+;  (:ignore ret-addr old-fp)
+  (:generator 75
+    ;; Move these into the passing locations if they are not already there.
+    (move esi args)
+    (move eax function)
+
+    ;; The following assumes that the return-pc and old-fp are on the
+    ;; stack in their standard save locations - Check this.
+    (unless (and (sc-is old-fp immediate-stack descriptor-stack)
+		 (= (tn-offset old-fp) old-fp-save-offset))
+	    (error "tail-call-variable: old-fp not on stack in standard save location?"))
+    (unless (and (sc-is ret-addr immediate-stack descriptor-stack)
+		 (= (tn-offset ret-addr) return-pc-save-offset))
+	    (error "tail-call-variable: ret-addr not on stack in standard save location?"))
+    
+
+    ;; And jump to the assembly routine.
+    (inst jmp (make-fixup 'tail-call-variable :assembly-routine))))
+
+
+;;;; Unknown values return:
+
+;;; Return a single-value using the Unknown-Values convention.  Specifically,
+;;; we jump to clear the stack and jump to return-pc+2.
+;;;
+;;; We require old-fp to be in a register, because we want to reset ESP before
+;;; restoring EBP.  If old-fp were still on the stack, it could get clobbered
+;;; by a signal.
+;;; 
+;;; pfw--get wired-tn conflicts sometimes if register sc specd for args
+;;; having problems targeting args to regs -- using temps instead.
+(define-vop (return-single)
+  (:args (old-fp)
+	 (return-pc)
+	 (value))
+  (:temporary (:sc dword-reg) ofp)
+  (:temporary (:sc dword-reg) ret)
+  (:ignore value)
+  (:node-var node)
+  (:generator 6
+    (trace-table-entry trace-table-function-epilogue)
+    (move ret return-pc)
+    ;; Clear the control stack
+    (move ofp old-fp)
+    ;; Adjust the return address for the single value return.
+    (cond ((policy node (> speed space))
+	   ;; This takes 2 cycles, and 5 or 6 bytes.
+	   (inst add ret 2))
+	  (t
+	   ;; This takes 4 cycles and 2 bytes.
+	   (inst inc ret)
+	   (inst inc ret)))
+    ;; Restore the frame pointer.
+    (move esp-tn ebp-tn)
+    (move ebp-tn ofp)
+    ;; Out of here.
+    (inst jmp ret)))
+
+;;; Do unknown-values return of a fixed (other than 1) number of values.  The
+;;; Values are required to be set up in the standard passing locations.  Nvals
+;;; is the number of values returned.
+;;;
+;;; Basically, we just load ECX with the number of values returned and EBX
+;;; with a pointer to the values, set ESP to point to the end of the values,
+;;; and jump directly to return-pc.
+;;;
+(define-vop (return)
+  (:args (old-fp)
+	 (return-pc :to (:eval 1))
+	 (values :more t))
+  (:ignore values)
+  (:info nvals)
+
+  ;; In the case of other than one value, we need these registers to tell
+  ;; the caller where they are and how many there are.
+  (:temporary (:sc dword-reg :offset ebx-offset) ebx)
+  (:temporary (:sc dword-reg :offset ecx-offset) ecx)
+
+  ;; We need to stretch the lifetime of return-pc past the argument
+  ;; registers so that we can default the argument registers without
+  ;; trashing return-pc.
+  (:temporary (:sc dword-reg :offset (first register-arg-offsets) :from :eval)
+	      a0)
+  (:temporary (:sc dword-reg :offset (second register-arg-offsets) :from :eval)
+	      a1)
+  (:temporary (:sc dword-reg :offset (third register-arg-offsets) :from :eval)
+	      a2)
+
+  (:generator 6
+    (trace-table-entry trace-table-function-epilogue)
+    ;; Establish the values pointer and values count.
+    (move ebx ebp-tn)
+    (if (zerop nvals)
+	(inst xor ecx ecx) ; smaller
+      (inst mov ecx (fixnum nvals)))
+    ;; restore the frame pointer and clear as much of the stack as possible.
+    (move ebp-tn old-fp)
+    (inst lea esp-tn (make-ea :dword :base ebx :disp (- (* nvals word-bytes))))
+    ;; pre-default any argument register that need it.
+    (when (< nvals register-arg-count)
+      (let* ((arg-tns (nthcdr nvals (list a0 a1 a2)))
+	     (first (first arg-tns)))
+	(inst mov first nil-value)
+	(dolist (tn (cdr arg-tns))
+	  (inst mov tn first))))
+    ;; And away we go.  Except that return-pc is still on the
+    ;; stack and we've changed the stack pointer.  So we have to
+    ;; tell it to index off of EBX instead of EBP.
+    (inst jmp
+	  (make-ea :dword :base ebx
+		   :disp
+		   (- (* (1+ (tn-offset return-pc)) word-bytes))))
+
+    (trace-table-entry trace-table-normal)))
+
+;;; Do unknown-values return of an arbitrary number of values (passed on the
+;;; stack.)  We check for the common case of a single return value, and do that
+;;; inline using the normal single value return convention.  Otherwise, we
+;;; branch off to code that calls an assembly-routine.
+;;;
+;;; The assembly routine takes the following args:
+;;;  EAX -- the return-pc to finally jump to.
+;;;  EBX -- pointer to where to put the values.
+;;;  ECX -- number of values to find there.
+;;;  ESI -- pointer to where to find the values.
+;;;
+(define-vop (return-multiple)
+  (:args (old-fp :to (:eval 1) :target old-fp-temp)
+	 (return-pc :target eax)
+	 (vals :scs (any-reg) :target esi)
+	 (nvals :scs (any-reg) :target ecx))
+
+  (:temporary (:sc dword-reg :offset eax-offset :from (:argument 1)) eax)
+  (:temporary (:sc dword-reg :offset esi-offset :from (:argument 2)) esi)
+  (:temporary (:sc dword-reg :offset ecx-offset :from (:argument 3)) ecx)
+  (:temporary (:sc dword-reg :offset ebx-offset :from (:eval 0)) ebx)
+  (:temporary (:sc descriptor-reg :offset (first register-arg-offsets)
+		   :from (:eval 0)) a0)
+  (:temporary (:sc dword-reg :from (:eval 1)) old-fp-temp)
+  (:node-var node)
+
+  (:generator 13
+    (trace-table-entry trace-table-function-epilogue)
+    ;; Load the return-pc.
+    (move eax return-pc)
+    (unless (policy node (> space speed))
+      ;; Check for the single case.
+      (let ((not-single (gen-label)))
+	(inst cmp nvals (fixnum 1))
+	(inst jmp :ne not-single)
+	
+	;; Return with one value.
+	(loadw a0 vals -1)
+	;; Clear the stack.  We load old-fp into a register before clearing
+	;; the stack.
+	(move old-fp-temp old-fp)
+	(move esp-tn ebp-tn)
+	(move ebp-tn old-fp-temp)
+	;; Fix the return-pc to point at the single-value entry point.
+	(cond ((policy node (> speed space))
+	       ;; This takes 2 cycles, and 5 bytes.
+	       (inst add eax 2))
+	      (t
+	       ;; This takes 4 cycles and 2 bytes.
+	       (inst inc eax)
+	       (inst inc eax)))
+	;; Out of here.
+	(inst jmp eax)
+	
+	;; Nope, not the single case.  Jump to the assembly routine.
+	(emit-label not-single)))
+    (move esi vals)
+    (move ecx nvals)
+    (move ebx ebp-tn)
+    (move ebp-tn old-fp)
+    (inst jmp (make-fixup 'return-multiple :assembly-routine))
+    (trace-table-entry trace-table-normal)))
+
+
+;;;; XEP hackery:
+
+;;; We don't need to do anything special for regular functions.
+;;;
+(define-vop (setup-environment)
+  (:info label)
+  (:ignore label)
+  (:generator 0
+    ;; Don't bother doing anything.
+    nil))
+
+;;; Get the lexical environment from it's passing location.
+;;;
+(define-vop (setup-closure-environment)
+  (:results (closure :scs (descriptor-reg)))
+  (:info label)
+  (:ignore label)
+  (:generator 6
+    ;; Get result.
+    (move closure eax-tn)))
+
+;;; Copy a more arg from the argument area to the end of the current frame.
+;;; Fixed is the number of non-more arguments.
+;;;
+;;; The tricky part is doing this without trashing any of the calling
+;;; convention registers that are still needed.  This vop is emitted directly
+;;; after the xep-allocate frame.  That means the registers are in use as
+;;; follows:
+;;;
+;;;  EAX -- The lexenv.
+;;;  EBX -- Available.
+;;;  ECX -- The total number of arguments.
+;;;  EDX -- The first arg.
+;;;  EDI -- The second arg.
+;;;  ESI -- The third arg.
+;;;
+;;; So basically, we have one register available for our use: EBX.
+;;;
+;;; What we can do is push the other regs onto the stack, and then restore
+;;; their values by looking directly below where we put the more-args.
+;;; 
+(define-vop (copy-more-arg)
+  (:info fixed)
+  (:generator 20
+    ;; Avoid the copy if there are no more args.
+    (cond ((zerop fixed)
+	   (inst jecxz just-alloc-frame))
+	  (t
+	   (inst cmp ecx-tn (fixnum fixed))
+	   (inst jmp :be just-alloc-frame)))
+    
+    ;; Allocate the space on the stack.
+    ;; stack = ebp - (max 3 frame-size) - (nargs - fixed)
+    (inst lea ebx-tn
+	  (make-ea :dword :base ebp-tn
+		   :disp (- (fixnum fixed)
+			    (* vm:word-bytes
+			       (max 3 (sb-allocated-size 'stack))))))
+    (inst sub ebx-tn ecx-tn)  ; Got the new stack in ebx
+    (inst mov esp-tn ebx-tn)
+    
+    ;; Now: nargs>=1 && nargs>fixed
+    
+    ;; Save the original count of args.
+    (inst mov ebx-tn ecx-tn)
+    
+    (if (< fixed register-arg-count)
+	(progn 
+	  ;; We must stop when we run out of stack args, not when we
+	  ;; run out of more args.
+	  ;; Number to copy = nargs-3
+	  (inst sub ecx-tn (fixnum register-arg-count))
+	  ;; Everything of interest in registers.
+	  (inst jmp :be do-regs)
+	  )
+      ;; Number to copy = nargs-fixed
+      (inst sub ecx-tn (fixnum fixed))
+      )
+    
+    ;; Save edi and esi register args.
+    (inst push edi-tn)
+    (inst push esi-tn)
+    ;; Okay, we have pushed the register args.  We can trash them
+    ;; now.
+    
+    ;; Initialize dst to be end of stack; skiping the values pushed
+    ;; above.
+    (inst lea edi-tn (make-ea :dword :base esp-tn :disp 8))
+    
+    ;; Initialize src to be end of args.
+    (inst mov esi-tn ebp-tn)
+    (inst sub esi-tn ebx-tn)
+    
+    (inst shr ecx-tn word-shift)	; make word count
+    ;; And copy the args.
+    (inst cld)				; auto-inc ESI and EDI.
+    (inst rep)
+    (inst movs :dword)
+    
+    ;; So now we need to restore EDI and ESI.
+    (inst pop esi-tn)
+    (inst pop edi-tn)
+    
+    DO-REGS
+    
+    ;; Restore ECX
+    (inst mov ecx-tn ebx-tn)
+    
+    ;; Here: nargs>=1 && nargs>fixed
+    (when (< fixed register-arg-count)
+	  ;; Now we have to deposit any more args that showed up in
+	  ;; registers.
+	  (do ((i fixed))
+	      ( nil )
+	      ;; Store it relative to ebp
+	      (inst mov (make-ea :dword :base ebp-tn
+				 :disp (- (* 4
+					     (+ 1 (- i fixed)
+						(max 3 (sb-allocated-size 'stack))))))
+		    (nth i register-arg-tns))
+	      
+	      (incf i)
+	      (when (>= i register-arg-count)
+		    (return))
+	      
+	      ;; Don't deposit any more than there are.
+	      (if (zerop i)
+		  (inst test ecx-tn ecx-tn)
+		(inst cmp ecx-tn (fixnum i)))
+	      (inst jmp :eq done)))
+
+    (inst jmp done)
+    
+    JUST-ALLOC-FRAME
+    (inst lea esp-tn
+	  (make-ea :dword :base ebp-tn
+		   :disp (- (* vm:word-bytes
+			       (max 3 (sb-allocated-size 'stack))))))
+    
+    DONE))
+
+;;; More args are stored contiguously on the stack, starting immediately at
+;;; the context pointer.  The context pointer is not typed, so the lowtag is 0.
+;;;
+;(define-full-reffer more-arg * 0 0 (any-reg descriptor-reg) * %more-arg)
+
+(DEFINE-VOP (MORE-ARG)
+    (:TRANSLATE %MORE-ARG)
+  (:POLICY :FAST-SAFE)
+  (:ARGS (OBJECT :SCS (DESCRIPTOR-REG) :to :result )
+	 (INDEX :SCS (ANY-REG) :target temp))
+  (:ARG-TYPES * TAGGED-NUM)
+  (:temporary (:sc dword-reg :from (:argument 1)) temp)
+  (:RESULTS (VALUE :SCS (ANY-REG DESCRIPTOR-REG)))
+  (:RESULT-TYPES *)
+  (:GENERATOR 5
+    (move temp index)
+    (inst neg temp)
+    (INST MOV VALUE (MAKE-EA :DWORD :BASE OBJECT :INDEX temp))))
+
+(DEFINE-VOP (MORE-ARG-C)
+	    (:TRANSLATE %MORE-ARG)
+  (:POLICY :FAST-SAFE)
+  (:ARGS (OBJECT :SCS (DESCRIPTOR-REG)))
+  (:INFO INDEX)				; Note this is raw number.
+  (:ARG-TYPES * (:CONSTANT (SIGNED-BYTE 30)))
+  (:RESULTS (VALUE :SCS (ANY-REG DESCRIPTOR-REG)))
+  (:RESULT-TYPES *)
+  (:GENERATOR 5
+   (INST MOV VALUE
+	 (make-ea :dword :base object :disp (- (* index word-bytes))))))
+
+
+;;; Turn more arg (context, count) into a list.
+;;;
+(define-vop (listify-rest-args)
+  (:translate %listify-rest-args)
+  (:policy :safe)
+  (:args (context :scs (descriptor-reg) :target src)
+	 (count :scs (any-reg) :target ecx))
+  (:arg-types * tagged-num)
+  (:temporary (:sc dword-reg :offset esi-offset :from (:argument 0)) src)
+  (:temporary (:sc dword-reg :offset ecx-offset :from (:argument 1)) ecx)
+  (:temporary (:sc dword-reg :offset eax-offset) eax)
+  (:temporary (:sc dword-reg) dst)
+  (:results (result :scs (descriptor-reg)))
+  (:generator 20
+    (move src context)
+    (move ecx count)
+    ;; Check to see if there are no arguments, and just return NIL if so.
+    (inst mov result nil-value)
+    (inst jecxz done)
+    #-cgc
+    (with-allocation (eax)
+      (inst lea dst (make-ea :byte :base eax :disp list-pointer-type))
+      (inst lea eax (make-ea :dword :base eax :index ecx :scale 2)))
+    #+cgc
+    (progn
+      (inst lea eax (make-ea :dword :index ecx :scale 2))
+      (with-cgc-allocation (eax eax)
+	(inst lea dst (make-ea :byte :base eax :disp list-pointer-type))))
+    ;; Convert the count into a raw value, so we can use the LOOP inst.
+    (inst shr ecx 2)
+    ;; Set decrement mode (successive args at lower addresses)
+    (inst std)
+    ;; Set up the result.
+    (move result dst)
+    ;; Jump into the middle of the loop, 'cause that's were we want to start.
+    (inst jmp enter)
+    LOOP
+    ;; Compute a pointer to the next cons.
+    (inst add dst (* cons-size word-bytes))
+    ;; Store a pointer to this cons in the CDR of the previous cons.
+    (storew dst dst -1 list-pointer-type)
+    ENTER
+    ;; Grab one value and stash it in the car of this cons.
+    (inst lods eax)
+    (storew eax dst 0 list-pointer-type)
+    ;; Go back for more.
+    (inst loop loop)
+    ;; NIL out the last cons.
+    (storew nil-value dst 1 vm:list-pointer-type)
+    DONE))
+
+;;; Return the location and size of the more arg glob created by Copy-More-Arg.
+;;; Supplied is the total number of arguments supplied (originally passed in
+;;; ECX.)  Fixed is the number of non-rest arguments.
+;;;
+;;; We must duplicate some of the work done by Copy-More-Arg, since at that
+;;; time the environment is in a pretty brain-damaged state, preventing this
+;;; info from being returned as values.  What we do is compute
+;;; supplied - fixed, and return a pointer that many words below the current
+;;; stack top.
+;;;
+(define-vop (more-arg-context)
+  (:policy :fast-safe)
+  (:translate c::%more-arg-context)
+  (:args (supplied :target count))
+  (:arg-types positive-fixnum (:constant fixnum))
+  (:info fixed)
+  (:results (context :scs (descriptor-reg))
+	    (count :scs (any-reg)))
+  (:result-types t tagged-num)
+  (:generator 5
+    (move count supplied)
+    ;; SP at this point points at the last arg pushed.
+    ;; Point to the first more-arg, not above it.
+    (inst lea context (make-ea :dword :base esp-tn
+			       :index count :scale 1
+			       :disp (- (+ (fixnum fixed) 4))))
+    (unless (zerop fixed)
+      (inst sub count (fixnum fixed)))
+    ))
+
+;;; Signal wrong argument count error if Nargs isn't = to Count.
+;;;
+#|
+(define-vop (verify-argument-count)
+  (:policy :fast-safe)
+  (:translate c::%verify-argument-count)
+  (:args (nargs :scs (unsigned-reg))) 
+  (:arg-types positive-fixnum (:constant t))
+  (:info count)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 3
+    (let ((err-lab
+	   (generate-error-code vop invalid-argument-count-error nargs)))
+      (inst shl nargs 2)
+      (inst cmp nargs (fixnum count))
+      (inst jmp :ne err-lab))))
+|#
+
+(define-vop (verify-argument-count)
+  (:policy :fast-safe)
+  (:translate c::%verify-argument-count)
+  (:args (nargs :scs (any-reg)))
+  (:arg-types positive-fixnum (:constant t))
+  (:info count)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 3
+    (let ((err-lab
+	   (generate-error-code vop invalid-argument-count-error nargs)))
+      (if (zerop count)
+	  (inst test nargs nargs)  ; smaller instruction
+	(inst cmp nargs (fixnum count)))
+      (inst jmp :ne err-lab))))
+
+;;; Signal various errors.
+;;;
+#+old
+(macrolet ((frob (name error &rest args)
+	     `(define-vop (,name)
+		(:args ,@(mapcar #'(lambda (arg)
+				     `(,arg :scs (any-reg descriptor-reg)))
+				 args))
+		(:vop-var vop)
+		(:save-p :compute-only)
+		(:generator 1000
+		  (error-call vop ,error ,@args)))))
+  (frob argument-count-error invalid-argument-count-error nargs)
+  (frob type-check-error object-not-type-error object type)
+  (frob odd-keyword-arguments-error odd-keyword-arguments-error)
+  (frob unknown-keyword-argument-error unknown-keyword-argument-error key)
+  (frob nil-function-returned-error nil-function-returned-error fun))
+
+(macrolet ((frob (name error translate &rest args)
+	     `(define-vop (,name)
+		,@(when translate
+		    `((:policy :fast-safe)
+		      (:translate ,translate)))
+		(:args ,@(mapcar #'(lambda (arg)
+				     `(,arg :scs (any-reg descriptor-reg)))
+				 args))
+		(:vop-var vop)
+		(:save-p :compute-only)
+		(:generator 1000
+		  (error-call vop ,error ,@args)))))
+  (frob argument-count-error invalid-argument-count-error
+	c::%argument-count-error nargs)
+  (frob type-check-error object-not-type-error
+	c::%type-check-error
+    object type)
+  (frob layout-invalid-error layout-invalid-error
+	c::%layout-invalid-error
+    object layout)
+  (frob odd-keyword-arguments-error odd-keyword-arguments-error
+	c::%odd-keyword-arguments-error)
+  (frob unknown-keyword-argument-error unknown-keyword-argument-error
+	c::%unknown-keyword-argument-error key)
+  (frob nil-function-returned-error nil-function-returned-error nil fun))
diff --git a/compiler/x86/cell.lisp b/compiler/x86/cell.lisp
new file mode 100644
index 000000000..d2a1a7298
--- /dev/null
+++ b/compiler/x86/cell.lisp
@@ -0,0 +1,305 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/cell.lisp,v 1.1 1997/01/18 14:31:23 ram Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    This file contains the VM definition of various primitive memory access
+;;; VOPs for the x86.
+;;;
+;;; Written by William Lott.
+;;;
+;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
+;;; 
+
+(in-package :x86)
+
+
+
+;;;; Data object ref/set stuff.
+
+(define-vop (slot)
+  (:args (object :scs (descriptor-reg)))
+  (:info name offset lowtag)
+  (:ignore name)
+  (:results (result :scs (descriptor-reg any-reg)))
+  (:generator 1
+    (loadw result object offset lowtag)))
+
+(define-vop (set-slot)
+  (:args (object :scs (descriptor-reg))
+	 (value :scs (descriptor-reg any-reg immediate)))
+  (:info name offset lowtag)
+  (:ignore name)
+  (:results)
+  (:generator 1
+     (if (sc-is value immediate)
+        (let ((val (tn-value value)))
+           (etypecase val
+              (integer
+	       (inst mov
+		     (make-ea :dword :base object
+			      :disp (- (* offset word-bytes) lowtag))
+		     (fixnum val)))
+	      (symbol
+	       (inst mov
+		     (make-ea :dword :base object
+			      :disp (- (* offset word-bytes) lowtag))
+		     (+ nil-value (static-symbol-offset val))))
+	      (character
+	       (inst mov
+		     (make-ea :dword :base object
+			      :disp (- (* offset word-bytes) lowtag))
+		     (logior (ash (char-code val) type-bits)
+			     base-char-type)))))
+       ;; Else, value not immediate.
+       (storew value object offset lowtag))))
+
+
+
+;;;; Symbol hacking VOPs:
+
+;;; these next two cf the sparc version, by jrd.
+
+;;; The compiler likes to be able to directly SET symbols.
+;;;
+(define-vop (set cell-set)
+  (:variant symbol-value-slot other-pointer-type))
+
+;;; Do a cell ref with an error check for being unbound.
+;;;
+(define-vop (checked-cell-ref)
+  (:args (object :scs (descriptor-reg) :target obj-temp))
+  (:results (value :scs (descriptor-reg any-reg)))
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:temporary (:sc descriptor-reg :from (:argument 0)) obj-temp))
+
+
+
+;;; With Symbol-Value, we check that the value isn't the trap object.  So
+;;; Symbol-Value of NIL is NIL.
+;;;
+(define-vop (symbol-value)
+  (:translate symbol-value)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to (:result 1)))
+  (:results (value :scs (descriptor-reg any-reg)))
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 9
+    (let ((err-lab (generate-error-code vop unbound-symbol-error object)))
+      (loadw value object symbol-value-slot other-pointer-type)
+      (inst cmp value unbound-marker-type)
+      (inst jmp :e err-lab))))
+
+(define-vop (fast-symbol-value cell-ref)
+  (:variant symbol-value-slot other-pointer-type)
+  (:policy :fast)
+  (:translate symbol-value))
+
+
+(define-vop (boundp)
+  (:translate boundp)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg)))
+  (:conditional)
+  (:info target not-p)
+  (:temporary (:sc descriptor-reg :from (:argument 0)) value)
+  (:generator 9
+    (loadw value object symbol-value-slot other-pointer-type)
+    (inst cmp value unbound-marker-type)
+    (inst jmp (if not-p :e :ne) target)))
+
+
+;;;; Fdefinition (fdefn) objects.
+
+(define-vop (fdefn-function cell-ref)	; /pfw - alpha
+  (:variant fdefn-function-slot other-pointer-type))
+
+(define-vop (safe-fdefn-function)
+  (:args (object :scs (descriptor-reg) :to (:result 1)))
+  (:results (value :scs (descriptor-reg any-reg)))
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 10
+    (loadw value object fdefn-function-slot other-pointer-type)
+    (inst cmp value nil-value)
+    (let ((err-lab (generate-error-code vop undefined-symbol-error object)))
+      (inst jmp :e err-lab))))
+
+(define-vop (set-fdefn-function)
+  (:policy :fast-safe)
+  (:translate (setf fdefn-function))
+  (:args (function :scs (descriptor-reg) :target result)
+	 (fdefn :scs (descriptor-reg)))
+  (:temporary (:sc dword-reg) raw)
+  (:temporary (:sc byte-reg) type)
+  (:results (result :scs (descriptor-reg)))
+  (:generator 38
+    (load-type type function (- function-pointer-type))
+    (inst lea raw
+	  (make-ea :byte :base function
+		   :disp (- (* function-code-offset word-bytes)
+			    function-pointer-type)))
+    (inst cmp type function-header-type)
+    (inst jmp :e normal-fn)
+    (inst lea raw (make-fixup (extern-alien-name "closure_tramp") :foreign))
+    NORMAL-FN
+    (storew function fdefn fdefn-function-slot other-pointer-type)
+    (storew raw fdefn fdefn-raw-addr-slot other-pointer-type)
+    (move result function)))
+
+(define-vop (fdefn-makunbound)
+  (:policy :fast-safe)
+  (:translate fdefn-makunbound)
+  (:args (fdefn :scs (descriptor-reg) :target result))
+  (:results (result :scs (descriptor-reg)))
+  (:generator 38
+    (storew nil-value fdefn fdefn-function-slot other-pointer-type)
+    (storew (make-fixup (extern-alien-name "undefined_tramp") :foreign)
+	    fdefn fdefn-raw-addr-slot other-pointer-type)
+    (move result fdefn)))
+
+
+
+;;;; Binding and Unbinding.
+
+;;; BIND -- Establish VAL as a binding for SYMBOL.  Save the old value and
+;;; the symbol on the binding stack and stuff the new value into the
+;;; symbol.
+
+(define-vop (bind)
+  (:args (val :scs (any-reg descriptor-reg))
+	 (symbol :scs (descriptor-reg)))
+  (:temporary (:sc dword-reg) temp bsp)
+  (:generator 5
+    (load-symbol-value bsp lisp::*binding-stack-pointer*)
+    (loadw temp symbol symbol-value-slot other-pointer-type)
+    (inst add bsp (* binding-size word-bytes))
+    (store-symbol-value bsp lisp::*binding-stack-pointer*)
+    (storew temp bsp (- binding-value-slot binding-size))
+    (storew symbol bsp (- binding-symbol-slot binding-size))
+    (storew val symbol symbol-value-slot other-pointer-type)))
+
+(define-vop (unbind)
+  (:temporary (:sc dword-reg) symbol value bsp)
+  (:generator 0
+    (load-symbol-value bsp lisp::*binding-stack-pointer*)
+    (loadw symbol bsp (- binding-symbol-slot binding-size))
+    (loadw value bsp (- binding-value-slot binding-size))
+    (storew value symbol symbol-value-slot other-pointer-type)
+    (storew 0 bsp (- binding-symbol-slot binding-size))
+    (inst sub bsp (* binding-size word-bytes))
+    (store-symbol-value bsp lisp::*binding-stack-pointer*)))
+
+
+(define-vop (unbind-to-here)
+  (:args (where :scs (descriptor-reg any-reg)))
+  (:temporary (:sc dword-reg) symbol value bsp)
+  (:generator 0
+    (load-symbol-value bsp lisp::*binding-stack-pointer*)
+    (inst cmp where bsp)
+    (inst jmp :e done)
+
+    LOOP
+    (loadw symbol bsp (- binding-symbol-slot binding-size))
+    (inst or symbol symbol)
+    (inst jmp :z skip)
+    (loadw value bsp (- binding-value-slot binding-size))
+    (storew value symbol symbol-value-slot other-pointer-type)
+    (storew 0 bsp (- binding-symbol-slot binding-size))
+
+    SKIP
+    (inst sub bsp (* binding-size word-bytes))
+    (inst cmp where bsp)
+    (inst jmp :ne loop)
+    (store-symbol-value bsp lisp::*binding-stack-pointer*)
+
+    DONE))
+
+
+
+;;;; Closure indexing.
+
+(define-full-reffer closure-index-ref *
+  closure-info-offset function-pointer-type
+  (any-reg descriptor-reg) * %closure-index-ref)
+
+(define-full-setter set-funcallable-instance-info *
+  funcallable-instance-info-offset function-pointer-type
+  (any-reg descriptor-reg) * %set-funcallable-instance-info)
+
+(define-full-reffer funcallable-instance-info *
+  funcallable-instance-info-offset function-pointer-type
+  (descriptor-reg any-reg) * %funcallable-instance-info)
+
+(define-vop (funcallable-instance-lexenv cell-ref)
+  (:variant funcallable-instance-lexenv-slot function-pointer-type))
+
+(define-vop (closure-ref slot-ref)
+  (:variant closure-info-offset function-pointer-type))
+
+(define-vop (closure-init slot-set)
+  (:variant closure-info-offset function-pointer-type))
+
+
+;;;; Value Cell hackery.
+
+(define-vop (value-cell-ref cell-ref)
+  (:variant value-cell-value-slot other-pointer-type))
+
+(define-vop (value-cell-set cell-set)
+  (:variant value-cell-value-slot other-pointer-type))
+
+
+;;;; Structure hackery:
+
+(define-vop (instance-length)
+  (:policy :fast-safe)
+  (:translate %instance-length)
+  (:args (struct :scs (descriptor-reg)))
+  (:results (res :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:generator 4
+    (loadw res struct 0 instance-pointer-type)
+    (inst shr res type-bits)))
+
+(define-vop (instance-ref slot-ref)
+  (:variant instance-slots-offset instance-pointer-type)
+  (:policy :fast-safe)
+  (:translate %instance-ref)
+  (:arg-types instance (:constant index)))
+
+(define-vop (instance-set slot-set)
+  (:policy :fast-safe)
+  (:translate %instance-set)
+  (:variant instance-slots-offset instance-pointer-type)
+  (:arg-types instance (:constant index) *))
+
+(define-full-reffer instance-index-ref * instance-slots-offset
+  instance-pointer-type (any-reg descriptor-reg) * %instance-ref)
+
+(define-full-setter instance-index-set * instance-slots-offset
+  instance-pointer-type (any-reg descriptor-reg) * %instance-set)
+
+
+
+;;;; Code object frobbing.
+
+(define-full-reffer code-header-ref * 0 other-pointer-type
+  (any-reg descriptor-reg) * code-header-ref)
+
+(define-full-setter code-header-set * 0 other-pointer-type
+  (any-reg descriptor-reg) * code-header-set)
+
+
+
diff --git a/compiler/x86/char.lisp b/compiler/x86/char.lisp
new file mode 100644
index 000000000..6fdf6bd3d
--- /dev/null
+++ b/compiler/x86/char.lisp
@@ -0,0 +1,171 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/char.lisp,v 1.1 1997/01/18 14:31:20 ram Exp $")
+;;;
+;;; **********************************************************************
+;;; 
+;;; This file contains the x86 VM definition of character operations.
+;;;
+;;; Written by Rob MacLachlan
+;;; Converted for the MIPS R2000 by Christopher Hoover.
+;;; And then to the SPARC by William Lott.
+;;; And then to the x86, again by William.
+;;;
+;;; Debugged by Paul F. Werkowski, June-95.
+;;;
+(in-package :x86)
+
+
+
+;;;; Moves and coercions:
+
+;;; Move a tagged char to an untagged representation.
+;;;
+(define-vop (move-to-base-char)
+  (:args (x :scs (any-reg immediate-stack) :target al))
+  (:temporary (:sc byte-reg :offset al-offset
+		   :from (:argument 0) :to (:eval 0)) al)
+  (:ignore al)
+  (:temporary (:sc byte-reg :offset ah-offset :target y
+		   :from (:argument 0) :to (:result 0)) ah)
+  (:results (y :scs (base-char-reg base-char-stack)))
+  (:note "character untagging")
+  (:generator 1
+    (move eax-tn x)
+    (move y ah)))
+;;;
+(define-move-vop move-to-base-char :move
+  (any-reg immediate-stack) (base-char-reg base-char-stack))
+
+
+;;; Move an untagged char to a tagged representation.
+;;;
+(define-vop (move-from-base-char)
+  (:args (x :scs (base-char-reg base-char-stack) :target ah))
+  (:temporary (:sc byte-reg :offset al-offset :target y
+		   :from (:argument 0) :to (:result 0)) al)
+  (:temporary (:sc byte-reg :offset ah-offset
+		   :from (:argument 0) :to (:result 0)) ah)
+  (:results (y :scs (any-reg descriptor-reg immediate-stack)))
+  (:note "character tagging")
+  (:generator 1
+    (move ah x)				; maybe move char byte
+    (inst mov al base-char-type)	; #x86 to type bits
+    (inst and eax-tn #xffff)		; remove any junk bits
+    (move y eax-tn)))
+
+;;;
+(define-move-vop move-from-base-char :move
+  (base-char-reg base-char-stack) (any-reg descriptor-reg immediate-stack))
+
+;;; Move untagged base-char values.
+;;;
+(define-vop (base-char-move)
+  (:args (x :target y
+	    :scs (base-char-reg)
+	    :load-if (not (location= x y))))
+  (:results (y :scs (base-char-reg base-char-stack)
+	       :load-if (not (location= x y))))
+  (:note "character move")
+  (:effects)
+  (:affected)
+  (:generator 0
+    (move y x)))
+;;;
+(define-move-vop base-char-move :move
+  (base-char-reg) (base-char-reg base-char-stack))
+
+
+;;; Move untagged base-char arguments/return-values.
+;;;
+(define-vop (move-base-char-argument)
+  (:args (x :target y
+	    :scs (base-char-reg))
+	 (fp :scs (any-reg)
+	     :load-if (not (sc-is y base-char-reg))))
+  (:results (y))
+  (:note "character arg move")
+  (:generator 0
+    (sc-case y
+      (base-char-reg
+       (move y x))
+      (base-char-stack
+       (inst mov
+	     (make-ea :byte :base fp :disp (- (* (1+ (tn-offset y)) 4)))
+	     x)))))
+;;;
+(define-move-vop move-base-char-argument :move-argument
+  (any-reg base-char-reg) (base-char-reg))
+
+
+;;; Use standard MOVE-ARGUMENT + coercion to move an untagged base-char
+;;; to a descriptor passing location.
+;;;
+(define-move-vop move-argument :move-argument
+  (base-char-reg) (any-reg descriptor-reg))
+
+
+
+;;;; Other operations:
+
+(define-vop (char-code)
+  (:translate char-code)
+  (:policy :fast-safe)
+  (:args (ch :scs (base-char-reg base-char-stack)))
+  (:arg-types base-char)
+  (:results (res :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:generator 1
+    (inst movzx res ch)))
+
+(define-vop (code-char)
+  (:translate code-char)
+  (:policy :fast-safe)
+  (:args (code :scs (unsigned-reg unsigned-stack) :target eax))
+  (:arg-types positive-fixnum)
+  (:temporary (:sc dword-reg :offset eax-offset :target res
+		   :from (:argument 0) :to (:result 0))
+	      eax)
+  (:results (res :scs (base-char-reg)))
+  (:result-types base-char)
+  (:generator 1
+    (move eax code)
+    (move res al-tn)))
+
+
+;;; Comparison of base-chars.
+;;;
+(define-vop (base-char-compare)
+  (:args (x :scs (base-char-reg base-char-stack))
+	 (y :scs (base-char-reg)
+	    :load-if (not (and (sc-is x base-char-reg)
+			       (sc-is y base-char-stack)))))
+  (:arg-types base-char base-char)
+  (:conditional)
+  (:info target not-p)
+  (:policy :fast-safe)
+  (:note "inline comparison")
+  (:variant-vars condition not-condition)
+  (:generator 3
+    (inst cmp x y)
+    (inst jmp (if not-p not-condition condition) target)))
+
+(define-vop (fast-char=/base-char base-char-compare)
+  (:translate char=)
+  (:variant :e :ne))
+
+(define-vop (fast-char</base-char base-char-compare)
+  (:translate char<)
+  (:variant :b :nb))
+
+(define-vop (fast-char>/base-char base-char-compare)
+  (:translate char>)
+  (:variant :a :na))
+
diff --git a/compiler/x86/debug.lisp b/compiler/x86/debug.lisp
new file mode 100644
index 000000000..741804fec
--- /dev/null
+++ b/compiler/x86/debug.lisp
@@ -0,0 +1,181 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/debug.lisp,v 1.1 1997/01/18 14:31:21 ram Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; Compiler support for the new whizzy debugger.
+;;;
+;;; Written by William Lott.
+;;;
+;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
+;;; Debugged by Douglas Crosher 1996.
+;;; 
+(in-package :x86)
+
+(defknown di::stack-ref (system-area-pointer index)
+  #-x86 t #+x86 (unsigned-byte 32) (flushable))
+(define-vop (debug-cur-sp)
+  (:translate current-sp)
+  (:policy :fast-safe)
+  (:results (res :scs (sap-reg sap-stack)))
+  (:result-types system-area-pointer)
+  (:generator 1
+    (move res esp-tn)))
+
+(define-vop (debug-cur-fp)
+  (:translate current-fp)
+  (:policy :fast-safe)
+  (:results (res :scs (sap-reg sap-stack)))
+  (:result-types system-area-pointer)
+  (:generator 1
+    (move res ebp-tn)))
+
+#+nil
+(define-vop (read-control-stack)
+  (:translate kernel:stack-ref)
+  (:policy :fast-safe)
+  (:args (sap :scs (sap-reg) :to (:argument 1))
+	 (offset :scs (any-reg) :to (:argument 0) :target temp))
+  (:arg-types system-area-pointer tagged-num)
+  (:temporary (:sc dword-reg :from (:argument 0)) temp)
+  (:results (result :scs (descriptor-reg)))
+  (:result-types *)
+  (:generator 9
+    (move temp offset)
+    (inst neg temp)
+    (inst sub temp (fixnum 1))
+    (inst mov result (make-ea :dword :base sap :index temp))))
+
+;;; Unlike the RISC implementations, the control stack also is a number
+;;; stack and not just descriptors live there.
+
+(define-vop (read-control-stack)
+  (:translate kernel:stack-ref)
+  (:policy :fast-safe)
+  (:args (sap :scs (sap-reg) :to :eval)	; NOTE lifetime stuff IMPORTANT (why?)
+	 (offset :scs (any-reg) :target temp))
+  (:arg-types system-area-pointer positive-fixnum)
+  (:temporary (:sc dword-reg :from (:argument 1)) temp)
+  (:results (result :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:generator 9
+    (move temp offset)
+    (inst neg temp)
+    (inst mov result
+	  (make-ea :dword :base sap :disp (- word-bytes) :index temp))))
+
+(define-vop (read-control-stack-c)
+  (:translate kernel:stack-ref)
+  (:policy :fast-safe)
+  (:args (sap :scs (sap-reg)))
+  (:info index)
+  (:arg-types system-area-pointer (:constant (signed-byte 32)))
+  (:results (result :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:generator 5
+    (inst mov result (make-ea :dword :base sap
+			      :disp (- (* (1+ index) word-bytes))))))
+
+(define-vop (write-control-stack)
+  (:translate %set-stack-ref)
+  (:policy :fast-safe)
+  (:args (sap :scs (sap-reg) :to :eval)
+	 (offset :scs (any-reg) :target temp)
+	 (value :scs (descriptor-reg) :to :result :target result))
+  (:arg-types system-area-pointer positive-fixnum *)
+  (:temporary (:sc dword-reg :from (:argument 1) :to :result) temp)
+  (:results (result :scs (descriptor-reg)))
+  (:result-types *)
+  (:generator 9
+    (move temp offset)
+    (inst neg temp)
+    (inst mov
+	  (make-ea :dword :base sap :disp (- word-bytes) :index temp) value)
+    (move result value)))
+
+(define-vop (write-control-stack-c)
+  (:translate %set-stack-ref)
+  (:policy :fast-safe)
+  (:args (sap :scs (sap-reg))
+	 (value :scs (descriptor-reg) :target result))
+  (:info index)
+  (:arg-types system-area-pointer (:constant (signed-byte 30)) *)
+  (:results (result :scs (descriptor-reg)))
+  (:result-types *)
+  (:generator 5
+    (inst mov (make-ea :dword :base sap
+		       :disp (- (* (1+ index) word-bytes)))
+	  value)
+    (move result value)))
+
+(define-vop (code-from-mumble)
+  (:policy :fast-safe)
+  (:args (thing :scs (descriptor-reg)))
+  (:results (code :scs (descriptor-reg)))
+  (:temporary (:sc dword-reg) temp)
+  (:variant-vars lowtag)
+  (:generator 5
+    (let ((bogus (gen-label))
+	  (done (gen-label)))
+      (loadw temp thing 0 lowtag)
+      (inst shr temp type-bits)
+      (inst jmp :z bogus)
+      (inst shl temp (1- (integer-length word-bytes)))
+      (unless (= lowtag other-pointer-type)
+	(inst add temp (- lowtag other-pointer-type)))
+      (move code thing)
+      (inst sub code temp)
+      (emit-label done)
+      (assemble (*elsewhere*)
+	(emit-label bogus)
+	(inst mov code nil-value)
+	(inst jmp done)))))
+
+(define-vop (code-from-lra code-from-mumble)
+  (:translate di::lra-code-header)
+  (:variant other-pointer-type))
+
+(define-vop (code-from-function code-from-mumble)
+  (:translate di::function-code-header)
+  (:variant function-pointer-type))
+
+(define-vop (make-lisp-obj)
+  (:policy :fast-safe)
+  (:translate di::make-lisp-obj)
+  (:args (value :scs (unsigned-reg unsigned-stack) :target result))
+  (:arg-types unsigned-num)
+  (:results (result :scs (descriptor-reg)
+		    :load-if (not (sc-is value unsigned-reg))
+		    ))
+  (:generator 1
+    (move result value)))
+
+(define-vop (get-lisp-obj-address)
+  (:policy :fast-safe)
+  (:translate di::get-lisp-obj-address)
+  (:args (thing :scs (descriptor-reg descriptor-stack) :target result))
+  (:results (result :scs (unsigned-reg)
+		    :load-if (not (and (sc-is thing descriptor-reg)
+				       (sc-is result unsigned-stack)))))
+  (:result-types unsigned-num)
+  (:generator 1
+    (move result thing)))
+
+
+(define-vop (function-word-offset)
+  (:policy :fast-safe)
+  (:translate di::function-word-offset)
+  (:args (fun :scs (descriptor-reg)))
+  (:results (res :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:generator 5
+    (loadw res fun 0 function-pointer-type)
+    (inst shr res type-bits)))
diff --git a/compiler/x86/float.lisp b/compiler/x86/float.lisp
new file mode 100644
index 000000000..17394037e
--- /dev/null
+++ b/compiler/x86/float.lisp
@@ -0,0 +1,2252 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/float.lisp,v 1.1 1997/01/18 14:31:17 ram Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains floating point support for the x86.
+;;;
+;;; Written by William Lott.
+;;;
+;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
+;;;
+;;; Re-written and enhanced by Douglas Crosher, 1996.
+;;;
+(in-package :x86)
+
+
+
+
+(defmacro ea-for-xf-desc(tn slot)
+  `(make-ea
+    :dword :base ,tn :disp (- (* ,slot vm:word-bytes) vm:other-pointer-type)))
+
+(defun ea-for-sf-desc(tn)
+  (ea-for-xf-desc tn vm:single-float-value-slot))
+
+(defun ea-for-df-desc(tn)
+  (ea-for-xf-desc tn vm:double-float-value-slot))
+
+(defmacro ea-for-xf-stack(tn kind)
+  `(make-ea
+    :dword :base ebp-tn
+    :disp (- (* (+ (tn-offset ,tn) (case ,kind (:single 1) (:double 2)))
+	      vm:word-bytes))))
+
+(defun ea-for-sf-stack(tn)
+  (ea-for-xf-stack tn :single))
+
+(defun ea-for-df-stack(tn)
+  (ea-for-xf-stack tn :double))
+
+;;;; Move functions:
+
+;;; x is source, y is destination
+(define-move-function (load-single 6) (vop x y)
+  ((single-stack) (single-reg))
+  (with-empty-tn@fp-top(y)
+     (inst fld (ea-for-sf-stack x))))
+
+(define-move-function (store-single 6) (vop x y)
+  ((single-reg) (single-stack))
+  (if (zerop (tn-offset x))
+      (inst fst (ea-for-sf-stack y))
+    (progn
+      (inst fxch x)
+      (inst fst (ea-for-sf-stack y))
+      ;; This may not be necessary as ST0 is likely invalid now.
+      (inst fxch x))))
+
+(define-move-function (load-double 6) (vop x y)
+  ((double-stack) (double-reg))
+  (with-empty-tn@fp-top(y)
+     (inst fldd (ea-for-df-stack x))))
+
+(define-move-function (store-double 6) (vop x y)
+  ((double-reg) (double-stack))
+  (if (zerop (tn-offset x))
+      (inst fstd (ea-for-df-stack y))
+    (progn
+      (inst fxch x)
+      (inst fstd (ea-for-df-stack y))
+      ;; This may not be necessary as ST0 is likely invalid now.
+      (inst fxch x))))
+
+;;; The i387 has instructions to load some useful constants.
+;;; This doesn't save much time but might cut down on memory
+;;; access and reduce the size of the constant vector (CV).
+;;; Intel claims they are stored in a more precise form on chip.
+;;; Anyhow, might as well use the feature. It can be turned
+;;; off by hacking the "immediate-constant-sc" in vm.lisp.
+(define-move-function (load-fp-constant 6) (vop x y)
+  ((fp-single-constant)(single-reg)
+   (fp-double-constant)(double-reg))
+
+  (let ((value (c::constant-value (c::tn-leaf x))))
+    (with-empty-tn@fp-top(y)
+      (cond ((zerop value)
+	     (inst fldz))
+	    ((or (= value 1s0)(= value 1d0))
+	     (inst fld1))
+	    ((= value #.pi)
+	     (inst fldpi))
+	    ((= value #.i387-l2t)
+	     (inst fldl2t))
+	    ((= value #.i387-l2e)
+	     (inst fldl2e))
+	    ((= value #.i387-lg2)
+	     (inst fldlg2))
+	    ((= value #.i387-ln2)
+	     (inst fldln2))
+	    (t (warn "Ignoring bogus i387 Constant ~a" value))))))
+
+
+;;;; Move VOPs:
+
+;;;
+;;; Float register to register moves.
+;;;
+(define-vop (single-move)
+  (:args (x :scs (single-reg) :target y
+	    :load-if (not (and (sc-is x single-stack)
+			       (sc-is y single-stack)
+			       (location= x y)))))
+  (:results (y :scs (single-reg)
+	       :load-if (not (and (sc-is x single-stack)
+				  (sc-is y single-stack)
+				  (location= x y)))))
+  (:note "float move")
+  (:generator 0
+     (unless (location= x y)
+        (cond ((zerop (tn-offset y))
+	       (inst fxch x)
+	       (inst fst  x))
+	      ((zerop (tn-offset x))
+	       (inst fst y))
+	      (t
+	       (inst fxch x)
+	       (inst fst y)
+	       (inst fxch x))))))
+(define-move-vop single-move :move (single-reg) (single-reg))
+
+(define-vop (double-move)
+  (:args (x :scs (double-reg) :target y
+	    :load-if (not (and (sc-is x double-stack)
+			       (sc-is y double-stack)
+			       (location= x y)))))
+  (:results (y :scs (double-reg)
+	       :load-if (not (and (sc-is x double-stack)
+				  (sc-is y double-stack)
+				  (location= x y)))))
+  (:note "float move")
+  (:generator 0
+     (unless (location= x y)
+        (cond ((zerop (tn-offset y))
+	       (inst fxch x)
+	       (inst fstd x))
+	      ((zerop (tn-offset x))
+	       (inst fstd y))
+	      (t
+	       (inst fxch x)
+	       (inst fstd y)
+	       (inst fxch x))))))
+(define-move-vop double-move :move (double-reg) (double-reg))
+
+
+;;;
+;;; Move from float to a descriptor reg. allocating a new float
+;;; object in the process.
+;;;
+(define-vop (move-from-single)
+  (:args (x :scs (single-reg) :to :save
+	    :load-if (not (sc-is x fp-single-constant))
+	    ))
+  (:results (y :scs (descriptor-reg)))
+  (:temporary (:sc dword-reg) ndescr)
+  (:note "float to pointer coercion")
+  (:generator 13
+     (if (sc-is x fp-single-constant)
+	 (ecase (c::constant-value (c::tn-leaf x))
+		(0s0
+		 (load-symbol-value y *fp-constant-0s0*))
+		(1s0
+		 (load-symbol-value y *fp-constant-1s0*)))
+	 (with-fixed-allocation (y ndescr vm:single-float-type
+				   vm:single-float-size)
+	   (with-tn@fp-top(x)
+	     (inst fst (make-ea :dword :base y
+				:disp (- (* vm:single-float-value-slot
+					    vm:word-bytes)
+					 vm:other-pointer-type))))))))
+(define-move-vop move-from-single :move
+  (single-reg) (descriptor-reg))
+
+(define-vop (move-from-double)
+  (:args (x :scs (double-reg) :to :save
+	    :load-if (not (sc-is x fp-double-constant))
+	    ))
+  (:results (y :scs (descriptor-reg)))
+  (:temporary (:sc dword-reg) ndescr)
+  (:note "float to pointer coercion")
+  (:generator 13
+     (if (sc-is x fp-double-constant)
+	 (ecase (c::constant-value (c::tn-leaf x))
+		(0d0
+		 (load-symbol-value y *fp-constant-0d0*))
+		(1d0
+		 (load-symbol-value y *fp-constant-1d0*)))
+	 (with-fixed-allocation (y ndescr vm:double-float-type
+				   vm:double-float-size)
+           (with-tn@fp-top(x)
+             (inst fstd (make-ea :dword :base y
+				 :disp (- (* vm:double-float-value-slot
+					     vm:word-bytes)
+					  vm:other-pointer-type))))))))
+(define-move-vop move-from-double :move
+  (double-reg) (descriptor-reg))
+
+;;;
+;;; Move from a descriptor to a float register
+;;;
+(macrolet ((frob (name sc double-p)
+	     `(progn
+		(define-vop (,name)
+		  (:args (x :scs (descriptor-reg)))
+		  (:results (y :scs (,sc)))
+		  (:note "pointer to float coercion")
+		  (:generator 2
+		     (with-empty-tn@fp-top(y)
+		       ,@(if double-p
+			     '((inst fldd (ea-for-df-desc x)))
+			   '((inst fld  (ea-for-sf-desc x)))))))
+		(define-move-vop ,name :move (descriptor-reg) (,sc)))))
+	  (frob move-to-single single-reg nil)
+	  (frob move-to-double double-reg   t))
+
+;;;
+;;; The move argument vops.
+;;;
+;;; Note these are also used to stuffs fp numbers onto the c-call
+;;; stack so the order is different than the lisp-stack.
+
+;;; The general move-argument vop
+(macrolet ((frob (name sc stack-sc double-p)
+	     `(progn
+		(define-vop (,name)
+		  (:args (x :scs (,sc) :target y)
+			 (fp :scs (any-reg)
+			     :load-if (not (sc-is y ,sc))))
+		  (:results (y))
+		  (:note "float argument move")
+		  (:generator ,(if double-p 3 2)
+		    (sc-case y
+		      (,sc
+		       (unless (location= x y)
+	                  (cond ((zerop (tn-offset y))
+				 (inst fxch x)
+				 (inst fstd x))
+				((zerop (tn-offset x))
+				 (inst fstd y))
+				(t
+				 (inst fxch x)
+				 (inst fstd y)
+				 (inst fxch x)))))
+		      (,stack-sc
+		       (if (= (tn-offset fp) esp-offset)
+			   (let* ((offset (* (tn-offset y) word-bytes))
+				  (ea (make-ea :dword :base fp :disp offset)))
+			     (with-tn@fp-top(x)
+					    ,@(if double-p
+						  '((inst fstd ea))
+						'((inst fst  ea)))))
+			 (let ((ea (make-ea
+				    :dword :base fp
+				    :disp (- (* (+ (tn-offset y)
+						   ,(if double-p 2 1))
+						vm:word-bytes)))))
+			   (with-tn@fp-top(x)
+					  ,@(if double-p
+						'((inst fstd ea))
+					      '((inst fst  ea))))))))))
+		(define-move-vop ,name :move-argument
+		  (,sc descriptor-reg) (,sc)))))
+  (frob move-single-float-argument single-reg single-stack nil)
+  (frob move-double-float-argument double-reg double-stack t))
+
+
+;;;
+(define-move-vop move-argument :move-argument
+  (single-reg double-reg) (descriptor-reg any-reg))
+
+
+;;;; Arithmetic VOPs:
+
+;;; dtc: The floating point arithmetic vops.
+;;; 
+;;; Note: Although these can accept x and y on the stack or pointed to
+;;; from a descriptor register, they will work with register loading
+;;; without these.  Same deal with the result - it need only be a
+;;; register.  When load-tns are needed they will probably be in ST0
+;;; and the code below should be able to correctly handle all cases.
+;;;
+;;; However it seems to produce better code if all arg. and result
+;;; options are used; on the P86 there is no extra cost in using a
+;;; memory operand to the FP instructions - not so on the PPro.
+;;;
+;;; It may also be useful to handle constant args?
+(macrolet
+    ((frob (op fop-sti fopr-sti
+	       fop fopr sname scost
+	       fopd foprd dname dcost)
+       `(progn
+	 (define-vop (,sname)
+	   (:translate ,op)
+	   (:args (x :scs (single-reg single-stack descriptor-reg)
+		     :to :eval)
+		  (y :scs (single-reg single-stack descriptor-reg)
+		     :to :eval))
+	   (:temporary (:sc single-reg :offset fr0-offset
+			    :from :eval :to :result) fr0)
+	   (:results (r :scs (single-reg single-stack)))
+	   (:arg-types single-float single-float)
+	   (:result-types single-float)
+	   (:policy :fast-safe)
+	   (:note "inline float arithmetic")
+	   (:vop-var vop)
+	   (:save-p :compute-only)
+	   (:node-var node)
+	   (:generator ,scost
+	     ;; Handle a few special cases
+	     (cond
+	       ;; x, y, and r are the same register.
+	       ((and (sc-is x single-reg) (location= x r) (location= y r))
+		(cond ((zerop (tn-offset r))
+		       (inst ,fop fr0))
+		      (t
+		       (inst fxch r)
+		       ;; XX the source register will not be valid
+		       (note-next-instruction vop :internal-error)
+		       (inst ,fop fr0)
+		       (inst fxch r))))
+
+	       ;; x and r are the same register.
+	       ((and (sc-is x single-reg) (location= x r))
+		(if (zerop (tn-offset r))
+		    (sc-case y
+	               (single-reg
+			;; ST(0) = ST(0) op ST(y)
+			(inst ,fop y))
+		       ((single-stack descriptor-reg)
+			;; ST(0) = ST(0) op Mem
+			(if (sc-is y single-stack)
+			    (inst ,fop (ea-for-sf-stack y))
+			    (inst ,fop (ea-for-sf-desc y)))))
+		    (progn
+		      ;; y to ST0
+		      (sc-case y
+	                (single-reg
+			 (unless (zerop (tn-offset y))
+			   (inst fxch y)
+			   (inst fst y))) ; save in original slot
+		        ((single-stack descriptor-reg)
+		         (inst fstp fr0)
+		        (if (sc-is y single-stack)
+			    (inst fld (ea-for-sf-stack y))
+			    (inst fld (ea-for-sf-desc y)))
+		        ;; ST(i) = ST(i) op ST0
+		        (inst ,fop-sti r)))))
+		(when (policy node (or (= debug 3) (> safety speed)))
+		  (note-next-instruction vop :internal-error)
+		  (inst wait)))
+	      ;; y and r are the same register.
+	      ((and (sc-is y single-reg) (location= y r))
+	       (if (zerop (tn-offset r))
+		   (sc-case x
+	               (single-reg
+			;; ST(0) = ST(x) op ST(0)
+			(inst ,fopr x))
+		       ((single-stack descriptor-reg)
+			;; ST(0) = Mem op ST(0)
+			(if (sc-is x single-stack)
+			    (inst ,fopr (ea-for-sf-stack x))
+			  (inst ,fopr (ea-for-sf-desc x)))))
+		   (progn
+		     ;; x to ST0
+		     (sc-case x
+		      (single-reg
+		       (unless (zerop (tn-offset x))
+			       (inst fxch x) ; x to top
+			       (inst fst x))) ; save in original slot
+		      ((single-stack descriptor-reg)
+		       (inst fstp fr0)
+		       (if (sc-is x single-stack)
+			   (inst fld (ea-for-sf-stack x))
+			 (inst fld (ea-for-sf-desc x)))))
+		     ;; ST(i) = ST(0) op ST(i)
+		     (inst ,fopr-sti r)))
+	       (when (policy node (or (= debug 3) (> safety speed)))
+		 (note-next-instruction vop :internal-error)
+		 (inst wait)))
+	      ;; The default case
+	      (t
+	       ;; Get the result to ST0.
+
+	       ;; Special handling is needed if x or y are in ST0, and
+	       ;; simpler code is generated.
+	       (cond
+		;; x is in ST0
+		((and (sc-is x single-reg) (zerop (tn-offset x)))
+		 ;; ST0 = ST0 op y
+		 (sc-case y
+	           (single-reg
+		    (inst ,fop y))
+		   (single-stack
+		    (inst ,fop (ea-for-sf-stack y)))
+		   (descriptor-reg
+		    (inst ,fop (ea-for-sf-desc y)))))
+		;; y is in ST0
+		((and (sc-is y single-reg) (zerop (tn-offset y)))
+		 ;; ST0 = x op ST0
+		 (sc-case x
+	           (single-reg
+		    (inst ,fopr x))
+		   (single-stack
+		    (inst ,fopr (ea-for-sf-stack x)))
+		   (descriptor-reg
+		    (inst ,fopr (ea-for-sf-desc x)))))
+		(t
+		 ;; x to ST0
+		 (sc-case x
+	           (single-reg
+		    (inst fxch x) ; x to top
+		    (inst fst x)) ; save in original slot
+		   ((single-stack descriptor-reg)
+		    (inst fstp fr0)
+		    (if (sc-is x single-stack)
+			(inst fld (ea-for-sf-stack x))
+		      (inst fld (ea-for-sf-desc x)))))
+		 ;; ST0 = ST0 op y
+		 (sc-case y
+	           (single-reg
+		    (inst ,fop y))
+		   (single-stack
+		    (inst ,fop (ea-for-sf-stack y)))
+		   (descriptor-reg
+		    (inst ,fop (ea-for-sf-desc y))))))
+
+	       (note-next-instruction vop :internal-error)
+
+	       ;; Finally save the result
+	       (sc-case r
+                 (single-reg
+		  (cond ((zerop (tn-offset r))
+			 (when (policy node (or (= debug 3) (> safety speed)))
+			   (inst wait)))
+			(t
+			 (inst fst r))))
+		 (single-stack
+		  (inst fst (ea-for-sf-stack r))))))))
+	       
+	 (define-vop (,dname)
+	   (:translate ,op)
+	   (:args (x :scs (double-reg double-stack descriptor-reg)
+		     :to :eval)
+		  (y :scs (double-reg double-stack descriptor-reg)
+		     :to :eval))
+	   (:temporary (:sc double-reg :offset fr0-offset
+			    :from :eval :to :result) fr0)
+	   (:results (r :scs (double-reg double-stack)))
+	   (:arg-types double-float double-float)
+	   (:result-types double-float)
+	   (:policy :fast-safe)
+	   (:note "inline float arithmetic")
+	   (:vop-var vop)
+	   (:save-p :compute-only)
+	   (:node-var node)
+	   (:generator ,dcost
+	     ;; Handle a few special cases
+	     (cond
+	      ;; x, y, and r are the same register.
+	      ((and (sc-is x double-reg) (location= x r) (location= y r))
+	       (cond ((zerop (tn-offset r))
+		      (inst ,fop fr0))
+		     (t
+		      (inst fxch x)
+		      (inst ,fopd fr0)
+		      ;; XX the source register will not be valid.
+		      (note-next-instruction vop :internal-error)
+		      (inst fxch r))))
+
+	      ;; x and r are the same register.
+	      ((and (sc-is x double-reg) (location= x r))
+	       (if (zerop (tn-offset r))
+		   (sc-case y
+	               (double-reg
+			;; ST(0) = ST(0) op ST(y)
+			(inst ,fopd y))
+		       ((double-stack descriptor-reg)
+			;; ST(0) = ST(0) op Mem
+			(if (sc-is y double-stack)
+			    (inst ,fopd (ea-for-df-stack y))
+			  (inst ,fopd (ea-for-df-desc y)))))
+		   (progn
+		     ;; y to ST0
+		     (sc-case y
+	               (double-reg
+			(unless (zerop (tn-offset y))
+				(inst fxch y)
+				(inst fstd y))) ; save in original slot
+		       ((double-stack descriptor-reg)
+			(inst fstp fr0)
+			(if (sc-is y double-stack)
+			    (inst fldd (ea-for-df-stack y))
+			  (inst fldd (ea-for-df-desc y)))))
+		     ;; ST(i) = ST(i) op ST0
+		     (inst ,fop-sti r)))
+	       (when (policy node (or (= debug 3) (> safety speed)))
+		 (note-next-instruction vop :internal-error)
+		 (inst wait)))
+
+	      ;; y and r are the same register.
+	      ((and (sc-is y double-reg) (location= y r))
+	       (if (zerop (tn-offset r))
+		   (sc-case x
+	               (double-reg
+			;; ST(0) = ST(x) op ST(0)
+			(inst ,foprd x))
+		       ((double-stack descriptor-reg)
+			;; ST(0) = Mem op ST(0)
+			(if (sc-is x double-stack)
+			    (inst ,foprd (ea-for-df-stack x))
+			  (inst ,foprd (ea-for-df-desc x)))))
+		 (progn
+		   ;; x to ST0
+		   (sc-case x
+		      (double-reg
+		       (unless (zerop (tn-offset x))
+			       (inst fxch x) ; x to top
+			       (inst fst x))) ; save in original slot
+		      ((double-stack descriptor-reg)
+		       (inst fstp fr0)
+		       (if (sc-is x double-stack)
+			   (inst fldd (ea-for-df-stack x))
+			 (inst fldd (ea-for-df-desc x)))))
+		   ;; ST(i) = ST(0) op ST(i)
+		      (inst ,fopr-sti r)))
+	       (when (policy node (or (= debug 3) (> safety speed)))
+		     (note-next-instruction vop :internal-error)
+		     (inst wait)))
+	      ;; The default case
+	      (t
+	       ;; Get the result to ST0.
+
+	       ;; Special handling is needed if x or y are in ST0, and
+	       ;; simpler code is generated.
+	       (cond
+		;; x is in ST0
+		((and (sc-is x double-reg) (zerop (tn-offset x)))
+		 ;; ST0 = ST0 op y
+		 (sc-case y
+	           (double-reg
+		    (inst ,fopd y))
+		   (double-stack
+		    (inst ,fopd (ea-for-df-stack y)))
+		   (descriptor-reg
+		    (inst ,fopd (ea-for-df-desc y)))))
+		;; y is in ST0
+		((and (sc-is y double-reg) (zerop (tn-offset y)))
+		 ;; ST0 = x op ST0
+		 (sc-case x
+	           (double-reg
+		    (inst ,foprd x))
+		   (double-stack
+		    (inst ,foprd (ea-for-df-stack x)))
+		   (descriptor-reg
+		    (inst ,foprd (ea-for-df-desc x)))))
+		(t
+		 ;; x to ST0
+		 (sc-case x
+	           (double-reg
+		    (inst fxch x) ; x to top
+		    (inst fst x)) ; save in original slot
+		   ((double-stack descriptor-reg)
+		    (inst fstp fr0)
+		    (if (sc-is x double-stack)
+			(inst fldd (ea-for-df-stack x))
+		      (inst fldd (ea-for-df-desc x)))))
+		 ;; ST0 = ST0 op y
+		 (sc-case y
+		   (double-reg
+		    (inst ,fopd y))
+		   (double-stack
+		    (inst ,fopd (ea-for-df-stack y)))
+		   (descriptor-reg
+		    (inst ,fopd (ea-for-df-desc y))))))
+
+	       (note-next-instruction vop :internal-error)
+	       
+	       ;; Finally save the result
+	       (sc-case r
+	         (double-reg
+		  (cond ((zerop (tn-offset r))
+			 (when (policy node (or (= debug 3) (> safety speed)))
+			       (inst wait)))
+			(t
+			 (inst fst r))))
+		 (double-stack
+		  (inst fstd (ea-for-df-stack r)))))))))))
+
+    (frob + fadd-sti fadd-sti
+	  fadd fadd +/single-float 2
+	  faddd faddd +/double-float 2)
+    (frob - fsub-sti fsubr-sti
+	  fsub fsubr -/single-float 2
+	  fsubd fsubrd -/double-float 2)
+    (frob * fmul-sti fmul-sti
+	  fmul fmul */single-float 3
+	  fmuld fmuld */double-float 3)
+    (frob / fdiv-sti fdivr-sti
+	  fdiv fdivr //single-float 12
+	  fdivd fdivrd //double-float 12))
+
+
+(macrolet ((frob (name inst translate sc type)
+	     `(define-vop (,name)
+	       (:args (x :scs (,sc) :target fr0))
+	       (:results (y :scs (,sc)))
+	       (:translate ,translate)
+	       (:policy :fast-safe)
+	       (:arg-types ,type)
+	       (:result-types ,type)
+	       (:temporary (:sc double-reg :offset fr0-offset
+				:from :argument :to :result) fr0)
+	       (:ignore fr0)
+	       (:note "inline float arithmetic")
+	       (:vop-var vop)
+	       (:save-p :compute-only)
+	       (:generator 1
+		(note-this-location vop :internal-error)
+		(unless (zerop (tn-offset x))
+		  (inst fxch x)		; x to top of stack
+		  (unless (location= x y)
+		    (inst fst x)))	; maybe save it
+		(inst ,inst)		; clobber st0
+		(unless (zerop (tn-offset y))
+		  (inst fst y))))))
+
+  (frob abs/single-float fabs abs single-reg single-float)
+  (frob abs/double-float fabs abs double-reg double-float)
+  (frob %negate/single-float fchs %negate single-reg single-float)
+  (frob %negate/double-float fchs %negate double-reg double-float))
+
+
+;;;; Comparison:
+
+(define-vop (=/float)
+  (:args (x) (y))
+  (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
+  (:conditional)
+  (:info target not-p)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:note "inline float comparison")
+  (:ignore temp)
+  (:generator 3
+     (note-this-location vop :internal-error)
+     (cond
+      ;; x is in ST0; y is in any reg.
+      ((zerop (tn-offset x))
+       (inst fucom y))
+      ;; y is in ST0; x is in another reg.
+      ((zerop (tn-offset y))
+       (inst fucom x))
+      ;; x and y are the same register, not ST0
+      ((location= x y)
+       (inst fxch x)
+       (inst fucom fr0-tn)
+       (inst fxch x))
+      ;; x and y are different registers, neither ST0.
+      (t
+       (inst fxch x)
+       (inst fucom y)
+       (inst fxch x)))
+     (inst fnstsw)			; status word to %ea
+     (inst and ah-tn #x45)		; C3 C2 C0
+     (inst cmp ah-tn #x40)
+     (inst jmp (if not-p :ne :e) target)))
+
+(define-vop (=/single-float =/float)
+  (:translate =)
+  (:args (x :scs (single-reg))
+	 (y :scs (single-reg)))
+  (:arg-types single-float single-float))
+
+(define-vop (=/double-float =/float)
+  (:translate =)
+  (:args (x :scs (double-reg))
+	 (y :scs (double-reg)))
+  (:arg-types double-float double-float))
+
+
+(define-vop (<single-float)
+  (:translate <)
+  (:args (x :scs (single-reg single-stack descriptor-reg))
+	 (y :scs (single-reg single-stack descriptor-reg)))
+  (:arg-types single-float single-float)
+  (:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0)
+  (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
+  (:conditional)
+  (:info target not-p)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:note "inline float comparison")
+  (:ignore temp)
+  (:generator 3
+    ;; Handle a few special cases
+    (cond
+     ;; y is ST0.
+     ((and (sc-is y single-reg) (zerop (tn-offset y)))
+      (sc-case x
+        (single-reg
+	 (inst fcom x))
+	((single-stack descriptor-reg)
+	 (if (sc-is x single-stack)
+	     (inst fcom (ea-for-sf-stack x))
+	   (inst fcom (ea-for-sf-desc x)))))
+      (inst fnstsw)			; status word to %ea
+      (inst and ah-tn #x45))
+
+     ;; General case when y is not in ST0.
+     (t
+      ;; x to ST0
+      (sc-case x
+         (single-reg
+	  (unless (zerop (tn-offset x))
+		  (inst fxch x) ; x to top
+		  (inst fst x))) ; save in original slot
+	 ((single-stack descriptor-reg)
+	  (inst fstp fr0)
+	  (if (sc-is x single-stack)
+	      (inst fld (ea-for-sf-stack x))
+	    (inst fld (ea-for-sf-desc x)))))
+      (sc-case y
+        (single-reg
+	 (inst fcom y))
+	((single-stack descriptor-reg)
+	 (if (sc-is y single-stack)
+	     (inst fcom (ea-for-sf-stack y))
+	   (inst fcom (ea-for-sf-desc y)))))
+      (inst fnstsw)			; status word to %ea
+      (inst and ah-tn #x45)		; C3 C2 C0
+      (inst cmp ah-tn #x01)))
+    (inst jmp (if not-p :ne :e) target)))
+
+(define-vop (<double-float)
+  (:translate <)
+  (:args (x :scs (double-reg double-stack descriptor-reg))
+	 (y :scs (double-reg double-stack descriptor-reg)))
+  (:arg-types double-float double-float)
+  (:temporary (:sc double-reg :offset fr0-offset :from :eval) fr0)
+  (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
+  (:conditional)
+  (:info target not-p)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:note "inline float comparison")
+  (:ignore temp)
+  (:generator 3
+    ;; Handle a few special cases
+    (cond
+     ;; y is ST0.
+     ((and (sc-is y double-reg) (zerop (tn-offset y)))
+      (sc-case x
+        (double-reg
+	 (inst fcomd x))
+	((double-stack descriptor-reg)
+	 (if (sc-is x double-stack)
+	     (inst fcomd (ea-for-df-stack x))
+	   (inst fcomd (ea-for-df-desc x)))))
+      (inst fnstsw)			; status word to %ea
+      (inst and ah-tn #x45))
+
+     ;; General case when y is not in ST0.
+     (t
+      ;; x to ST0
+      (sc-case x
+         (double-reg
+	  (unless (zerop (tn-offset x))
+		  (inst fxch x) ; x to top
+		  (inst fstd x))) ; save in original slot
+	 ((double-stack descriptor-reg)
+	  (inst fstp fr0)
+	  (if (sc-is x double-stack)
+	      (inst fldd (ea-for-df-stack x))
+	    (inst fldd (ea-for-df-desc x)))))
+      (sc-case y
+        (double-reg
+	 (inst fcomd y))
+	((double-stack descriptor-reg)
+	 (if (sc-is y double-stack)
+	     (inst fcomd (ea-for-df-stack y))
+	   (inst fcomd (ea-for-df-desc y)))))
+      (inst fnstsw)			; status word to %ea
+      (inst and ah-tn #x45)		; C3 C2 C0
+      (inst cmp ah-tn #x01)))
+    (inst jmp (if not-p :ne :e) target)))
+
+
+(define-vop (>single-float)
+  (:translate >)
+  (:args (x :scs (single-reg single-stack descriptor-reg))
+	 (y :scs (single-reg single-stack descriptor-reg)))
+  (:arg-types single-float single-float)
+  (:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0)
+  (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
+  (:conditional)
+  (:info target not-p)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:note "inline float comparison")
+  (:ignore temp)
+  (:generator 3
+    ;; Handle a few special cases
+    (cond
+     ;; y is ST0.
+     ((and (sc-is y single-reg) (zerop (tn-offset y)))
+      (sc-case x
+        (single-reg
+	 (inst fcom x))
+	((single-stack descriptor-reg)
+	 (if (sc-is x single-stack)
+	     (inst fcom (ea-for-sf-stack x))
+	   (inst fcom (ea-for-sf-desc x)))))
+      (inst fnstsw)			; status word to %ea
+      (inst and ah-tn #x45)
+      (inst cmp ah-tn #x01))
+
+     ;; General case when y is not in ST0.
+     (t
+      ;; x to ST0
+      (sc-case x
+         (single-reg
+	  (unless (zerop (tn-offset x))
+		  (inst fxch x) ; x to top
+		  (inst fst x))) ; save in original slot
+	 ((single-stack descriptor-reg)
+	  (inst fstp fr0)
+	  (if (sc-is x single-stack)
+	      (inst fld (ea-for-sf-stack x))
+	    (inst fld (ea-for-sf-desc x)))))
+      (sc-case y
+        (single-reg
+	 (inst fcom y))
+	((single-stack descriptor-reg)
+	 (if (sc-is y single-stack)
+	     (inst fcom (ea-for-sf-stack y))
+	   (inst fcom (ea-for-sf-desc y)))))
+      (inst fnstsw)			; status word to %ea
+      (inst and ah-tn #x45)))
+    (inst jmp (if not-p :ne :e) target)))
+
+(define-vop (>double-float)
+  (:translate >)
+  (:args (x :scs (double-reg double-stack descriptor-reg))
+	 (y :scs (double-reg double-stack descriptor-reg)))
+  (:arg-types double-float double-float)
+  (:temporary (:sc double-reg :offset fr0-offset :from :eval) fr0)
+  (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
+  (:conditional)
+  (:info target not-p)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:note "inline float comparison")
+  (:ignore temp)
+  (:generator 3
+    ;; Handle a few special cases
+    (cond
+     ;; y is ST0.
+     ((and (sc-is y double-reg) (zerop (tn-offset y)))
+      (sc-case x
+        (double-reg
+	 (inst fcomd x))
+	((double-stack descriptor-reg)
+	 (if (sc-is x double-stack)
+	     (inst fcomd (ea-for-df-stack x))
+	   (inst fcomd (ea-for-df-desc x)))))
+      (inst fnstsw)			; status word to %ea
+      (inst and ah-tn #x45)
+      (inst cmp ah-tn #x01))
+
+     ;; General case when y is not in ST0.
+     (t
+      ;; x to ST0
+      (sc-case x
+         (double-reg
+	  (unless (zerop (tn-offset x))
+		  (inst fxch x) ; x to top
+		  (inst fstd x))) ; save in original slot
+	 ((double-stack descriptor-reg)
+	  (inst fstp fr0)
+	  (if (sc-is x double-stack)
+	      (inst fldd (ea-for-df-stack x))
+	    (inst fldd (ea-for-df-desc x)))))
+      (sc-case y
+        (double-reg
+	 (inst fcomd y))
+	((double-stack descriptor-reg)
+	 (if (sc-is y double-stack)
+	     (inst fcomd (ea-for-df-stack y))
+	   (inst fcomd (ea-for-df-desc y)))))
+      (inst fnstsw)			; status word to %ea
+      (inst and ah-tn #x45)))
+    (inst jmp (if not-p :ne :e) target)))
+
+;;; Comparisons with 0 can use the FTST instruction.
+
+(define-vop (float-test)
+  (:args (x))
+  (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
+  (:conditional)
+  (:info target not-p y)
+  (:variant-vars code)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:note "inline float comparison")
+  (:ignore temp y)
+  (:generator 2
+     (note-this-location vop :internal-error)
+     (cond
+      ;; x is in ST0
+      ((zerop (tn-offset x))
+       (inst ftst))
+      ;; x not ST0
+      (t
+       (inst fxch x)
+       (inst ftst)
+       (inst fxch x)))
+     (inst fnstsw)			; status word to %ea
+     (inst and ah-tn #x45)		; C3 C2 C0
+     (unless (zerop code)
+        (inst cmp ah-tn code))
+     (inst jmp (if not-p :ne :e) target)))
+
+(define-vop (=0/single-float float-test)
+  (:translate =)
+  (:args (x :scs (single-reg)))
+  (:arg-types single-float (:constant (single-float 0s0 0s0)))
+  (:variant #x40))
+(define-vop (=0/double-float float-test)
+  (:translate =)
+  (:args (x :scs (double-reg)))
+  (:arg-types double-float (:constant (double-float 0d0 0d0)))
+  (:variant #x40))
+
+(define-vop (<0/single-float float-test)
+  (:translate <)
+  (:args (x :scs (single-reg)))
+  (:arg-types single-float (:constant (single-float 0s0 0s0)))
+  (:variant #x01))
+(define-vop (<0/double-float float-test)
+  (:translate <)
+  (:args (x :scs (double-reg)))
+  (:arg-types double-float (:constant (double-float 0d0 0d0)))
+  (:variant #x01))
+
+(define-vop (>0/single-float float-test)
+  (:translate >)
+  (:args (x :scs (single-reg)))
+  (:arg-types single-float (:constant (single-float 0s0 0s0)))
+  (:variant #x00))
+(define-vop (>0/double-float float-test)
+  (:translate >)
+  (:args (x :scs (double-reg)))
+  (:arg-types double-float (:constant (double-float 0d0 0d0)))
+  (:variant #x00))
+
+
+;;;; Conversion:
+
+(macrolet ((frob (name translate to-sc to-type)
+	     `(define-vop (,name)
+		(:args (x :scs (signed-stack signed-reg) :target temp))
+		(:temporary (:sc signed-stack) temp)
+		(:results (y :scs (,to-sc)))
+		(:arg-types signed-num)
+		(:result-types ,to-type)
+		(:policy :fast-safe)
+		(:note "inline float coercion")
+		(:translate ,translate)
+		(:vop-var vop)
+		(:save-p :compute-only)
+		(:generator 5
+		  (sc-case x
+		    (signed-reg
+		     (inst mov temp x)
+		     (with-empty-tn@fp-top(y)
+		       (note-this-location vop :internal-error)
+		       (inst fild temp)))
+		    (signed-stack
+		     (with-empty-tn@fp-top(y)
+		       (note-this-location vop :internal-error)
+		       (inst fild x))))))))
+
+  (frob %single-float/signed %single-float single-reg single-float)
+  (frob %double-float/signed %double-float double-reg double-float))
+
+
+
+;;; These should be no-ops but the compiler might want to move
+;;; some things around
+(macrolet ((frob (name translate from-sc from-type to-sc to-type)
+	     `(define-vop (,name)
+	       (:args (x :scs (,from-sc) :target y))
+	       (:results (y :scs (,to-sc)))
+	       (:arg-types ,from-type)
+	       (:result-types ,to-type)
+	       (:policy :fast-safe)
+	       (:note "inline float coercion")
+	       (:translate ,translate)
+	       (:vop-var vop)
+	       (:save-p :compute-only)
+	       (:generator 2
+		(note-this-location vop :internal-error)
+		(unless (location= x y)
+		  (cond 
+		   ((zerop (tn-offset x))
+		    ;; x is in ST0, y is in another reg. not ST0
+		    (inst fst  y))
+		   ((zerop (tn-offset y))
+		    ;; y is in ST0, x is in another reg. not ST0
+		    (inst fxch x)
+		    (inst fst  x)) ; Restore x
+		   (t
+		    ;; Neither x or y are in ST0, and they are not in
+		    ;; the same reg.
+		    (inst fxch x)
+		    (inst fst  y)
+		    (inst fxch x))))))))
+  
+  (frob %single-float/double-float %single-float double-reg
+	double-float single-reg single-float)
+  (frob %double-float/single-float %double-float single-reg single-float
+	double-reg double-float))
+
+
+
+(macrolet ((frob (trans from-sc from-type round-p)
+	     `(define-vop (,(symbolicate trans "/" from-type))
+	       (:args (x :scs (,from-sc)))
+	       (:temporary (:sc signed-stack) stack-temp)
+	       ,@(unless round-p
+		       '((:temporary (:sc unsigned-stack) scw)
+			 (:temporary (:sc any-reg) rcw)))
+	       (:results (y :scs (signed-reg)))
+	       (:arg-types ,from-type)
+	       (:result-types signed-num)
+	       (:translate ,trans)
+	       (:policy :fast-safe)
+	       (:note "inline float truncate")
+	       (:vop-var vop)
+	       (:save-p :compute-only)
+	       (:generator 5
+		(note-this-location vop :internal-error)
+		(inst wait) 		; Catch any pending FPE exceptions
+		;; normal mode (for now) is "round to best"
+		(with-tn@fp-top(x)
+		  ,@(unless round-p
+		    '((inst fnstcw scw)	; save current control word
+		      (move rcw scw)	; into 16-bit register
+		      (inst or rcw (ash #b11 10)) ; CHOP
+		      (move stack-temp rcw)
+		      (inst fldcw stack-temp)))
+		  (sc-case y
+		    (signed-stack
+		     (inst fist y))
+		    (signed-reg
+		     (inst fist stack-temp)
+		     (inst mov y stack-temp)))
+		  ,@(unless round-p
+		     '((inst fldcw scw))))))))
+  
+  (frob %unary-truncate single-reg single-float nil)
+  (frob %unary-truncate double-reg double-float nil)
+
+  #-sun4
+  (frob %unary-round single-reg single-float t)
+  #-sun4
+  (frob %unary-round double-reg double-float t))
+
+#+sun4
+(deftransform %unary-round ((x) (float) (signed-byte 32))
+  '(let* ((trunc (truly-the (signed-byte 32) (%unary-truncate x)))
+	  (extra (- x trunc))
+	  (absx (abs extra))
+	  (one-half (float 1/2 x)))
+     (if (if (oddp trunc)
+	     (>= absx one-half)
+	     (> absx one-half))
+	 (truly-the (signed-byte 32) (%unary-truncate (+ x extra)))
+	 trunc)))
+
+(define-vop (make-single-float)
+  (:args (bits :scs (signed-reg) :target res
+	       :load-if (not (or (and (sc-is bits signed-stack)
+				      (sc-is res single-reg))
+				 (and (sc-is bits signed-stack)
+				      (sc-is res single-stack)
+				      (location= bits res))))))
+  (:results (res :scs (single-reg single-stack)))
+  (:temporary (:sc signed-stack) stack-temp)
+  (:arg-types signed-num)
+  (:result-types single-float)
+  (:translate make-single-float)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 4
+    (sc-case res
+       (single-stack
+	(sc-case bits
+	  (signed-reg
+	   (inst mov res bits))
+	  (signed-stack
+	   (assert (location= bits res)))))
+       (single-reg
+	(sc-case bits
+	  (signed-reg
+	   ;; source must be in memory
+	   (inst mov stack-temp bits)
+	   (with-empty-tn@fp-top(res)
+	      (inst fld stack-temp)))
+	  (signed-stack
+	   (with-empty-tn@fp-top(res)
+	      (inst fld bits))))))))
+
+(define-vop (make-double-float)
+  (:args (hi-bits :scs (signed-reg))
+	 (lo-bits :scs (unsigned-reg)))
+  (:results (res :scs (double-reg)))
+  (:temporary (:sc double-stack) temp)
+  (:arg-types signed-num unsigned-num)
+  (:result-types double-float)
+  (:translate make-double-float)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 2
+    (let ((offset (1+ (tn-offset temp))))
+      (storew hi-bits ebp-tn (- offset))
+      (storew lo-bits ebp-tn (- (1+ offset)))
+      (with-empty-tn@fp-top(res)
+	(inst fldd (make-ea :dword :base ebp-tn
+			    :disp (- (* (1+ offset) word-bytes))))))))
+
+(define-vop (single-float-bits)
+  (:args (float :scs (single-reg descriptor-reg)))
+  (:results (bits :scs (signed-reg)))
+  (:temporary (:sc signed-stack :from :argument :to :result) stack-temp)
+  (:arg-types single-float)
+  (:result-types signed-num)
+  (:translate single-float-bits)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 4
+    (sc-case bits
+      (signed-reg
+       (sc-case float
+	 (single-reg
+	  (with-tn@fp-top(float)
+	    (inst fst stack-temp)
+	    (inst mov bits stack-temp)))
+	 (single-stack
+	  (inst mov bits float))
+	 (descriptor-reg
+	  (loadw
+	   bits float vm:single-float-value-slot vm:other-pointer-type))))
+      (signed-stack
+       (sc-case float
+	 (single-reg
+	  (with-tn@fp-top(float)
+	    (inst fst bits))))))))
+
+;; must test
+(define-vop (double-float-high-bits)
+  (:args (float :scs (double-reg descriptor-reg)))
+  (:results (hi-bits :scs (signed-reg)))
+  (:temporary (:sc double-stack) temp)
+  (:arg-types double-float)
+  (:result-types signed-num)
+  (:translate double-float-high-bits)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 5
+    (sc-case hi-bits
+      (signed-reg
+       (sc-case float
+	 (double-reg
+	  (with-tn@fp-top(float)
+	    (let ((where (make-ea :dword :base ebp-tn
+				  :disp (- (* (+ 2 (tn-offset temp))
+					      word-bytes)))))
+	      (inst fstd where)))
+	  (loadw hi-bits ebp-tn (- (1+ (tn-offset temp)))))
+	 (double-stack
+	  (loadw hi-bits ebp-tn (- (1+ (tn-offset float)))))
+	 (descriptor-reg
+	  (loadw hi-bits float (1+ vm:double-float-value-slot)
+		 vm:other-pointer-type))))
+      #+nil ;; should not happen
+      (signed-stack
+       (sc-case float
+	 (double-reg
+	  (inst stf float (current-nfp-tn vop)
+		(* (tn-offset hi-bits) vm:word-bytes))))))))
+
+;;needs testing
+(define-vop (double-float-low-bits)
+  (:args (float :scs (double-reg descriptor-reg)))
+  (:results (lo-bits :scs (unsigned-reg)))
+  (:temporary (:sc double-stack) temp)
+  (:arg-types double-float)
+  (:result-types unsigned-num)
+  (:translate double-float-low-bits)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 5
+    (sc-case lo-bits
+      (unsigned-reg
+       (sc-case float
+	 (double-reg
+	  (with-tn@fp-top(float)
+	    (let ((where (make-ea :dword :base ebp-tn
+				  :disp (- (* (+ 2 (tn-offset temp))
+					      word-bytes)))))
+	      (inst fstd where)))
+	  (loadw lo-bits ebp-tn (- (+ 2 (tn-offset temp)))))
+	 (double-stack
+	  (loadw lo-bits ebp-tn (- (+ 2 (tn-offset float)))))
+	 (descriptor-reg
+	  (loadw lo-bits float  vm:double-float-value-slot
+		 vm:other-pointer-type))))
+      #+nil ;; should not happen
+      (unsigned-stack
+       (sc-case float
+	 (double-reg
+	  (inst stf-odd float (current-nfp-tn vop)
+		(* (tn-offset lo-bits) vm:word-bytes))))))))
+
+
+;;;; Float mode hackery:
+
+(deftype float-modes () '(unsigned-byte 32)) ; really only 16
+(defknown floating-point-modes () float-modes (flushable))
+(defknown ((setf floating-point-modes)) (float-modes)
+  float-modes)
+
+(defconstant npx-env-size (* 7 vm:word-bytes))
+(defconstant npx-cw-offset 0)
+(defconstant npx-sw-offset 4)
+
+(define-vop (floating-point-modes)
+  (:results (res :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:translate floating-point-modes)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:temporary (:sc dword-reg :offset  eax-offset :target res)  eax)
+  (:temporary (:sc dword-reg) tmp)
+  (:generator 8
+   (inst mov tmp esp-tn)		; save stack pointer
+   (inst sub esp-tn npx-env-size)	; make space on stack
+   (inst wait)                          ; Catch any pending FPE exceptions
+   (inst fstenv (make-ea :dword :base esp-tn)) ; masks all exceptions
+   (inst fldenv (make-ea :dword :base esp-tn)) ; restore previous state
+   (inst mov ax-tn (make-ea :word :base esp-tn :disp npx-sw-offset))
+   (inst shl eax 16)			; current status to high word
+   (inst mov ax-tn (make-ea :word :base esp-tn :disp npx-cw-offset))
+   (inst xor ax-tn #x3f)       ; turn exception mask to trap enable bits
+   (inst mov esp-tn tmp)		; reset stack
+   (move res eax)))
+
+(define-vop (set-floating-point-modes)
+  (:args (new :scs (unsigned-reg) :target res))
+  (:results (res :scs (unsigned-reg)))
+  (:arg-types unsigned-num)
+  (:result-types unsigned-num)
+  (:translate (setf floating-point-modes))
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:temporary (:sc dword-reg :offset eax-offset) eax)
+  (:temporary (:sc dword-reg) stmp)
+  (:temporary (:sc dword-reg) wtmp)
+  (:generator 3
+   (inst mov stmp esp-tn)		; save stack pointer
+   (inst sub esp-tn npx-env-size)	; make space on stack
+   (inst wait)                          ; Catch any pending FPE exceptions
+   (inst fstenv (make-ea :dword :base esp-tn))
+   (inst mov ax-tn (make-ea :word :base esp-tn :disp npx-sw-offset))
+   (move wtmp new)
+   (inst shr wtmp 16)			; position sticky bits
+   (inst and wtmp #x3f)
+   (inst and eax wtmp)			; maybe new sticky bits
+   (inst mov (make-ea :word :base esp-tn :disp npx-sw-offset) ax-tn)
+   (move eax new)
+   (inst xor eax #x3f)	    ; turn trap enable bits into exception mask
+   (inst mov (make-ea :word :base esp-tn :disp npx-cw-offset) ax-tn)
+   (inst fldenv (make-ea :dword :base esp-tn))
+   (move esp-tn stmp)			; reset stack
+   (move res new)))
+
+
+
+;;; Lets use some of the 80387 special functions.
+;;;
+;;; These defs will not take effect unless code/irrat.lisp is modified
+;;; to remove the inlined alien routine def.
+
+(macrolet ((frob (func trans op)
+	     `(define-vop (,func)
+	       (:args (x :scs (double-reg) :target fr0))
+	       (:temporary (:sc double-reg :offset fr0-offset
+				:from :argument :to :result) fr0)
+	       (:ignore fr0)
+	       (:results (y :scs (double-reg)))
+	       (:arg-types double-float)
+	       (:result-types double-float)
+	       (:translate ,trans)
+	       (:policy :fast-safe)
+	       (:note "inline NPX function")
+	       (:vop-var vop)
+	       (:save-p :compute-only)
+	       (:node-var node)
+	       (:generator 5
+		(note-this-location vop :internal-error)
+		(unless (zerop (tn-offset x))
+		  (inst fxch x)		; x to top of stack
+		  (unless (location= x y)
+		    (inst fst x)))	; maybe save it
+		(inst ,op)		; clobber st0
+		(cond ((zerop (tn-offset y))
+		       (when (policy node (or (= debug 3) (> safety speed)))
+			     (inst wait)))
+		      (t
+		       (inst fst y)))))))
+
+  (frob fsin-quick  %sin-quick fsin)		; arg range is 2^63
+  (frob fcos-quick  %cos-quick fcos)		; so may need frem1
+  (frob fsqrt %sqrt fsqrt))
+
+;;; Versions of fsin and fcos which handle a larger arg. range.
+(macrolet ((frob (func trans op)
+	     `(define-vop (,func)
+		(:translate ,trans)
+		(:args (x :scs (double-reg) :target fr0))
+		#+nil(:temporary (:sc word-reg :offset eax-offset
+				 :from :eval :to :result) temp)
+		(:temporary (:sc double-reg :offset fr0-offset
+				 :from :argument :to :result) fr0)
+		#+nil(:temporary (:sc double-reg :offset fr1-offset
+				 :from :argument :to :result) fr1)
+		(:results (y :scs (double-reg)))
+		(:arg-types double-float)
+		(:result-types double-float)
+		(:policy :fast-safe)
+		(:note "inline sin/cos function")
+		(:vop-var vop)
+		(:save-p :compute-only)
+		#+nil(:ignore temp)
+		(:generator 5
+		  (note-this-location vop :internal-error)
+		  (unless (zerop (tn-offset x))
+			  (inst fxch x)		 ; x to top of stack
+			  (unless (location= x y)
+				  (inst fst x))) ; maybe save it
+		  (inst ,op)
+		  (inst fnstsw)			 ; status word to %ea
+		  (inst and ah-tn #x04)		 ; C2
+		  (inst jmp :z DONE)
+		  ;; Else x was out of range so reduce it; ST0 is unchanged.
+		  #+nil				; @@@
+		  (progn			; Arg reduction is errorful
+		    (inst fstp fr1) 		; Load 2*PI
+		    (inst fldpi)
+		    (inst fadd fr0)
+		    (inst fxch fr1)
+		    LOOP
+		    (inst fprem1)
+		    (inst fnstsw)		; status word to %ea
+		    (inst and ah-tn #x04)	; C2
+		    (inst jmp :nz LOOP)
+		    (inst ,op))
+		  (progn			; @@@
+		    (inst fstp fr0)		; Else Load 0.0
+		    (inst fldz))		; on too big args
+		  DONE
+		  (unless (zerop (tn-offset y))
+			  (inst fstd y))))))
+	  (frob fsin  %sin fsin)
+	  (frob fcos  %cos fcos))
+	     
+(define-vop (ftan)
+  (:translate %tan)
+  (:args (x :scs (double-reg) :target fr0))
+  #+nil(:temporary (:sc word-reg :offset eax-offset
+		   :from :eval :to :result) temp)
+  (:temporary (:sc double-reg :offset fr0-offset
+		   :from :argument :to :result) fr0)
+  (:temporary (:sc double-reg :offset fr1-offset
+		   :from :argument :to :result) fr1)
+  (:results (y :scs (double-reg)))
+  (:arg-types double-float)
+  (:result-types double-float)
+  (:policy :fast-safe)
+  (:note "inline tan function")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  #+nil(:ignore temp)
+  (:generator 5
+    (note-this-location vop :internal-error)
+    (case (tn-offset x)
+       (0 
+	(inst fstp fr1))
+       (1
+	(inst fstp fr0))
+       (t
+	(inst fstp fr0)
+	(inst fstp fr0)
+	(inst fldd (make-random-tn :kind :normal
+				   :sc (sc-or-lose 'double-reg)
+				   :offset (- (tn-offset x) 2)))))
+    (inst fptan)
+    (inst fnstsw)			 ; status word to %ea
+    (inst and ah-tn #x04)		 ; C2
+    (inst jmp :z DONE)
+    ;; Else x was out of range so reduce it; ST0 is unchanged.
+    #+nil
+    (progn				; @@@ Reduction doesn't work well.
+      (inst fldpi)                         ; Load 2*PI
+      (inst fadd fr0)
+      (inst fxch fr1)
+      LOOP
+      (inst fprem1)
+      (inst fnstsw)			 ; status word to %ea
+      (inst and ah-tn #x04)		 ; C2
+      (inst jmp :nz LOOP)
+      (inst fstp fr1)
+      (inst fptan))
+    (progn				; @@@ just load 0.0 
+      (inst fldz)
+      (inst fxch fr1))
+    DONE
+    ;; Result is in fr1
+    (case (tn-offset y)
+       (0
+	(inst fxch fr1))
+       (1)
+       (t
+	(inst fxch fr1)
+	(inst fstd y)))))
+
+(define-vop (ftan-quick)
+  (:translate %tan-quick)
+  (:args (x :scs (double-reg) :target fr0))
+  (:temporary (:sc double-reg :offset fr0-offset
+		   :from :argument :to :result) fr0)
+  (:temporary (:sc double-reg :offset fr1-offset
+		   :from :argument :to :result) fr1)
+  (:results (y :scs (double-reg)))
+  (:arg-types double-float)
+  (:result-types double-float)
+  (:policy :fast-safe)
+  (:note "inline tan function")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 5
+    (note-this-location vop :internal-error)
+    (case (tn-offset x)
+       (0 
+	(inst fstp fr1))
+       (1
+	(inst fstp fr0))
+       (t
+	(inst fstp fr0)
+	(inst fstp fr0)
+	(inst fldd (make-random-tn :kind :normal
+				   :sc (sc-or-lose 'double-reg)
+				   :offset (- (tn-offset x) 2)))))
+    (inst fptan)
+    ;; Result is in fr1
+    (case (tn-offset y)
+      (0
+       (inst fxch fr1))
+      (1)
+      (t
+       (inst fxch fr1)
+       (inst fstd y)))))
+	     
+#+nil
+(define-vop (fexp)
+  (:translate %exp)
+  (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
+  (:temporary (:sc double-reg :offset fr0-offset
+		   :from :argument :to :result) fr0)
+  (:temporary (:sc double-reg :offset fr1-offset
+		   :from :argument :to :result) fr1)
+  (:temporary (:sc double-reg :offset fr2-offset
+		   :from :argument :to :result) fr2)
+  (:results (y :scs (double-reg)))
+  (:arg-types double-float)
+  (:result-types double-float)
+  (:policy :fast-safe)
+  (:note "inline exp function")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 5
+     (note-this-location vop :internal-error)
+     (sc-case x
+        (double-reg
+	 (cond ((zerop (tn-offset x))
+		;; x is in fr0
+		(inst fstp fr1)
+		(inst fldl2e)
+		(inst fmul fr1))
+	       (t
+		;; x is in a FP reg, not fr0
+		(inst fstp fr0)
+		(inst fldl2e)
+		(inst fmul x))))
+	((double-stack descriptor-reg)
+	 (inst fstp fr0)
+	 (inst fldl2e)
+	 (if (sc-is x double-stack)
+	     (inst fmuld (ea-for-df-stack x))
+	   (inst fmuld (ea-for-df-desc x)))))
+     ;; Now fr0=x log2(e)
+     (inst fst fr1)
+     (inst frndint)
+     (inst fst fr2)
+     (inst fsubp-sti fr1)
+     (inst f2xm1)
+     (inst fld1)
+     (inst faddp-sti fr1)
+     (inst fscale)
+     (inst fld fr0)
+     (case (tn-offset y)
+       ((0 1))
+       (t (inst fstd y)))))
+
+;;; Modified exp that handles the following special cases:
+;;; exp(+Inf) is +Inf; exp(-Inf) is 0; exp(NaN) is NaN.
+(define-vop (fexp)
+  (:translate %exp)
+  (:args (x :scs (double-reg) :target fr0))
+  (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
+  (:temporary (:sc double-reg :offset fr0-offset
+		   :from :argument :to :result) fr0)
+  (:temporary (:sc double-reg :offset fr1-offset
+		   :from :argument :to :result) fr1)
+  (:temporary (:sc double-reg :offset fr2-offset
+		   :from :argument :to :result) fr2)
+  (:results (y :scs (double-reg)))
+  (:arg-types double-float)
+  (:result-types double-float)
+  (:policy :fast-safe)
+  (:note "inline exp function")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:ignore temp)
+  (:generator 5
+     (note-this-location vop :internal-error)
+     (unless (zerop (tn-offset x))
+	     (inst fxch x)		; x to top of stack
+	     (unless (location= x y)
+		     (inst fst x)))	; maybe save it
+     ;; Check for Inf or NaN
+     (inst fxam)
+     (inst fnstsw)
+     (inst sahf)
+     (inst jmp :nc NOINFNAN)            ; Neither Inf or NaN.
+     (inst jmp :np NOINFNAN)            ; NaN gives NaN? Continue.
+     (inst and ah-tn #x02)              ; Test sign of Inf.
+     (inst jmp :z DONE)                 ; +Inf gives +Inf.
+     (inst fstp fr0)                    ; -Inf gives 0
+     (inst fldz)
+     (inst jmp-short DONE)
+     NOINFNAN
+     (inst fstp fr1)
+     (inst fldl2e)
+     (inst fmul fr1)
+     ;; Now fr0=x log2(e)
+     (inst fst fr1)
+     (inst frndint)
+     (inst fst fr2)
+     (inst fsubp-sti fr1)
+     (inst f2xm1)
+     (inst fld1)
+     (inst faddp-sti fr1)
+     (inst fscale)
+     (inst fld fr0)
+     DONE
+     (unless (zerop (tn-offset y))
+	     (inst fstd y))))
+
+(define-vop (flog)
+  (:translate %log)
+  (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
+  (:temporary (:sc double-reg :offset fr0-offset
+		   :from :argument :to :result) fr0)
+  (:temporary (:sc double-reg :offset fr1-offset
+		   :from :argument :to :result) fr1)
+  (:results (y :scs (double-reg)))
+  (:arg-types double-float)
+  (:result-types double-float)
+  (:policy :fast-safe)
+  (:note "inline log function")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 5
+     (note-this-location vop :internal-error)
+     (sc-case x
+        (double-reg
+	 (case (tn-offset x)
+	    (0
+	     ;; x is in fr0
+	     (inst fstp fr1)
+	     (inst fldln2)
+	     (inst fxch fr1))
+	    (1
+	     ;; x is in fr1
+	     (inst fstp fr0)
+	     (inst fldln2)
+	     (inst fxch fr1))
+	    (t
+	     ;; x is in a FP reg, not fr0 or fr1
+	     (inst fstp fr0)
+	     (inst fstp fr0)
+	     (inst fldln2)
+	     (inst fldd (make-random-tn :kind :normal
+					:sc (sc-or-lose 'double-reg)
+					:offset (1- (tn-offset x))))))
+	 (inst fyl2x))
+	((double-stack descriptor-reg)
+	 (inst fstp fr0)
+	 (inst fstp fr0)
+	 (inst fldln2)
+	 (if (sc-is x double-stack)
+	     (inst fldd (ea-for-df-stack x))
+	   (inst fldd (ea-for-df-desc x)))
+	 (inst fyl2x)))
+     (inst fld fr0)
+     (case (tn-offset y)
+       ((0 1))
+       (t (inst fstd y)))))
+
+(define-vop (flog10)
+  (:translate %log10)
+  (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
+  (:temporary (:sc double-reg :offset fr0-offset
+		   :from :argument :to :result) fr0)
+  (:temporary (:sc double-reg :offset fr1-offset
+		   :from :argument :to :result) fr1)
+  (:results (y :scs (double-reg)))
+  (:arg-types double-float)
+  (:result-types double-float)
+  (:policy :fast-safe)
+  (:note "inline log10 function")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 5
+     (note-this-location vop :internal-error)
+     (sc-case x
+        (double-reg
+	 (case (tn-offset x)
+	    (0
+	     ;; x is in fr0
+	     (inst fstp fr1)
+	     (inst fldlg2)
+	     (inst fxch fr1))
+	    (1
+	     ;; x is in fr1
+	     (inst fstp fr0)
+	     (inst fldlg2)
+	     (inst fxch fr1))
+	    (t
+	     ;; x is in a FP reg, not fr0 or fr1
+	     (inst fstp fr0)
+	     (inst fstp fr0)
+	     (inst fldlg2)
+	     (inst fldd (make-random-tn :kind :normal
+					:sc (sc-or-lose 'double-reg)
+					:offset (1- (tn-offset x))))))
+	 (inst fyl2x))
+	((double-stack descriptor-reg)
+	 (inst fstp fr0)
+	 (inst fstp fr0)
+	 (inst fldlg2)
+	 (if (sc-is x double-stack)
+	     (inst fldd (ea-for-df-stack x))
+	   (inst fldd (ea-for-df-desc x)))
+	 (inst fyl2x)))
+     (inst fld fr0)
+     (case (tn-offset y)
+       ((0 1))
+       (t (inst fstd y)))))
+
+(define-vop (fpow)
+  (:translate %pow)
+  (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
+	 (y :scs (double-reg double-stack descriptor-reg) :target fr1))
+  (:temporary (:sc double-reg :offset fr0-offset
+		   :from (:argument 0) :to :result) fr0)
+  (:temporary (:sc double-reg :offset fr1-offset
+		   :from (:argument 1) :to :result) fr1)
+  (:temporary (:sc double-reg :offset fr2-offset
+		   :from :load :to :result) fr2)
+  (:results (r :scs (double-reg)))
+  (:arg-types double-float double-float)
+  (:result-types double-float)
+  (:policy :fast-safe)
+  (:note "inline pow function")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 5
+     (note-this-location vop :internal-error)
+     ;; Setup x in fr0 and y in fr1
+     (cond 
+      ;; x in fr0; y in fr1
+      ((and (sc-is x double-reg) (zerop (tn-offset x))
+	    (sc-is y double-reg) (= 1 (tn-offset y))))
+      ;; y in fr1; x not in fr0
+      ((and (sc-is y double-reg) (= 1 (tn-offset y)))
+       ;; Load x to fr0
+       (inst fstp fr0)
+       (sc-case x
+          (double-reg
+	   (inst fldd (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'double-reg)
+				      :offset (1- (tn-offset x)))))
+	  (double-stack
+	   (inst fldd (ea-for-df-stack x)))
+	  (descriptor-reg
+	   (inst fldd (ea-for-df-desc x)))))
+      ;; x in fr0; y not in fr1
+      ((and (sc-is x double-reg) (zerop (tn-offset x)))
+       (inst fxch fr1)
+       ;; Now load y to fr0
+       (inst fstp fr0)
+       (sc-case y
+          (double-reg
+	   (inst fldd (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'double-reg)
+				      :offset (1- (tn-offset y)))))
+	  (double-stack
+	   (inst fldd (ea-for-df-stack y)))
+	  (descriptor-reg
+	   (inst fldd (ea-for-df-desc y))))
+       (inst fxch fr1))
+      ;; x in fr1; y not in fr1
+      ((and (sc-is x double-reg) (= 1 (tn-offset x)))
+       ;; Load y to fr0
+       (inst fstp fr0)
+       (sc-case y
+          (double-reg
+	   (inst fldd (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'double-reg)
+				      :offset (1- (tn-offset y)))))
+	  (double-stack
+	   (inst fldd (ea-for-df-stack y)))
+	  (descriptor-reg
+	   (inst fldd (ea-for-df-desc y))))
+       (inst fxch fr1))
+      ;; y in fr0;
+      ((and (sc-is y double-reg) (zerop (tn-offset y)))
+       (inst fxch fr1)
+       ;; Now load x to fr0
+       (inst fstp fr0)
+       (sc-case x
+          (double-reg
+	   (inst fldd (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'double-reg)
+				      :offset (1- (tn-offset x)))))
+	  (double-stack
+	   (inst fldd (ea-for-df-stack x)))
+	  (descriptor-reg
+	   (inst fldd (ea-for-df-desc x)))))
+      ;; Neither x or y are in either fr0 or fr1
+      (t
+       ;; Load y then x
+       (inst fstp fr0)
+       (inst fstp fr0)
+       (sc-case y
+          (double-reg
+	   (inst fldd (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'double-reg)
+				      :offset (- (tn-offset y) 2))))
+	  (double-stack
+	   (inst fldd (ea-for-df-stack y)))
+	  (descriptor-reg
+	   (inst fldd (ea-for-df-desc y))))
+       ;; Load x to fr0
+       (sc-case x
+          (double-reg
+	   (inst fldd (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'double-reg)
+				      :offset (1- (tn-offset x)))))
+	  (double-stack
+	   (inst fldd (ea-for-df-stack x)))
+	  (descriptor-reg
+	   (inst fldd (ea-for-df-desc x))))))
+      
+     ;; Now have x at fr0; and y at fr1
+     (inst fyl2x)
+     ;; Now fr0=y log2(x)
+     (inst fld fr0)
+     (inst frndint)
+     (inst fst fr2)
+     (inst fsubp-sti fr1)
+     (inst f2xm1)
+     (inst fld1)
+     (inst faddp-sti fr1)
+     (inst fscale)
+     (inst fld fr0)
+     (case (tn-offset r)
+       ((0 1))
+       (t (inst fstd r)))))
+
+(define-vop (fscalen)
+  (:translate %scalbn)
+  (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
+	 (y :scs (signed-stack signed-reg) :target temp))
+  (:temporary (:sc double-reg :offset fr0-offset
+		   :from (:argument 0) :to :result) fr0)
+  (:temporary (:sc double-reg :offset fr1-offset :from :eval :to :result) fr1)
+  (:temporary (:sc signed-stack :from (:argument 1) :to :result) temp)
+  (:results (r :scs (double-reg)))
+  (:arg-types double-float signed-num)
+  (:result-types double-float)
+  (:policy :fast-safe)
+  (:note "inline scalbn function")
+  (:generator 5
+     ;; Setup x in fr0 and y in fr1
+     (sc-case x
+       (double-reg
+	(case (tn-offset x)
+	 (0
+	  (inst fstp fr1)
+	  (sc-case y
+	    (signed-reg
+	     (inst mov temp y)
+	     (inst fild temp))
+	    (signed-stack
+	     (inst fild y)))
+	  (inst fxch fr1))
+	 (1
+	  (inst fstp fr0)
+	  (sc-case y
+	    (signed-reg
+	     (inst mov temp y)
+	     (inst fild temp))
+	    (signed-stack
+	     (inst fild y)))
+	  (inst fxch fr1))
+	 (t
+	   (inst fstp fr0)
+	   (inst fstp fr0)
+	   (sc-case y
+	     (signed-reg
+	      (inst mov temp y)
+	      (inst fild temp))
+	     (signed-stack
+	      (inst fild y)))
+	   (inst fld (make-random-tn :kind :normal
+				     :sc (sc-or-lose 'double-reg)
+				     :offset (1- (tn-offset x)))))))
+       ((double-stack descriptor-reg)
+	(inst fstp fr0)
+	(inst fstp fr0)
+	(sc-case y
+          (signed-reg
+	   (inst mov temp y)
+	   (inst fild temp))
+	  (signed-stack
+	   (inst fild y)))
+	(if (sc-is x double-stack)
+	    (inst fldd (ea-for-df-stack x))
+	  (inst fldd (ea-for-df-desc x)))))
+     (inst fscale)
+     (unless (zerop (tn-offset r))
+	     (inst fstd r))))
+
+(define-vop (fscale)
+  (:translate %scalb)
+  (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
+	 (y :scs (double-reg double-stack descriptor-reg) :target fr1))
+  (:temporary (:sc double-reg :offset fr0-offset
+		   :from (:argument 0) :to :result) fr0)
+  (:temporary (:sc double-reg :offset fr1-offset
+		   :from (:argument 1) :to :result) fr1)
+  (:results (r :scs (double-reg)))
+  (:arg-types double-float double-float)
+  (:result-types double-float)
+  (:policy :fast-safe)
+  (:note "inline scalb function")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 5
+     (note-this-location vop :internal-error)
+     ;; Setup x in fr0 and y in fr1
+     (cond 
+      ;; x in fr0; y in fr1
+      ((and (sc-is x double-reg) (zerop (tn-offset x))
+	    (sc-is y double-reg) (= 1 (tn-offset y))))
+      ;; y in fr1; x not in fr0
+      ((and (sc-is y double-reg) (= 1 (tn-offset y)))
+       ;; Load x to fr0
+       (inst fstp fr0)
+       (sc-case x
+          (double-reg
+	   (inst fldd (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'double-reg)
+				      :offset (1- (tn-offset x)))))
+	  (double-stack
+	   (inst fldd (ea-for-df-stack x)))
+	  (descriptor-reg
+	   (inst fldd (ea-for-df-desc x)))))
+      ;; x in fr0; y not in fr1
+      ((and (sc-is x double-reg) (zerop (tn-offset x)))
+       (inst fxch fr1)
+       ;; Now load y to fr0
+       (inst fstp fr0)
+       (sc-case y
+          (double-reg
+	   (inst fldd (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'double-reg)
+				      :offset (1- (tn-offset y)))))
+	  (double-stack
+	   (inst fldd (ea-for-df-stack y)))
+	  (descriptor-reg
+	   (inst fldd (ea-for-df-desc y))))
+       (inst fxch fr1))
+      ;; x in fr1; y not in fr1
+      ((and (sc-is x double-reg) (= 1 (tn-offset x)))
+       ;; Load y to fr0
+       (inst fstp fr0)
+       (sc-case y
+          (double-reg
+	   (inst fldd (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'double-reg)
+				      :offset (1- (tn-offset y)))))
+	  (double-stack
+	   (inst fldd (ea-for-df-stack y)))
+	  (descriptor-reg
+	   (inst fldd (ea-for-df-desc y))))
+       (inst fxch fr1))
+      ;; y in fr0;
+      ((and (sc-is y double-reg) (zerop (tn-offset y)))
+       (inst fxch fr1)
+       ;; Now load x to fr0
+       (inst fstp fr0)
+       (sc-case x
+          (double-reg
+	   (inst fldd (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'double-reg)
+				      :offset (1- (tn-offset x)))))
+	  (double-stack
+	   (inst fldd (ea-for-df-stack x)))
+	  (descriptor-reg
+	   (inst fldd (ea-for-df-desc x)))))
+      ;; Neither x or y are in either fr0 or fr1
+      (t
+       ;; Load y then x
+       (inst fstp fr0)
+       (inst fstp fr0)
+       (sc-case y
+          (double-reg
+	   (inst fldd (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'double-reg)
+				      :offset (- (tn-offset y) 2))))
+	  (double-stack
+	   (inst fldd (ea-for-df-stack y)))
+	  (descriptor-reg
+	   (inst fldd (ea-for-df-desc y))))
+       ;; Load x to fr0
+       (sc-case x
+          (double-reg
+	   (inst fldd (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'double-reg)
+				      :offset (1- (tn-offset x)))))
+	  (double-stack
+	   (inst fldd (ea-for-df-stack x)))
+	  (descriptor-reg
+	   (inst fldd (ea-for-df-desc x))))))
+      
+     ;; Now have x at fr0; and y at fr1
+     (inst fscale)
+     (unless (zerop (tn-offset r))
+	     (inst fstd r))))
+
+;;; Seems to work fine on a Pentium, but the range of the x argument
+;;; is limited on a 386/486.
+(define-vop (flog1p-limited)
+  (:translate %log1p-limited)
+  (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
+  (:temporary (:sc double-reg :offset fr0-offset
+		   :from :argument :to :result) fr0)
+  (:temporary (:sc double-reg :offset fr1-offset
+		   :from :argument :to :result) fr1)
+  (:results (y :scs (double-reg)))
+  (:arg-types double-float)
+  (:result-types double-float)
+  (:policy :fast-safe)
+  (:note "inline log1p with limited x range function")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 5
+     (note-this-location vop :internal-error)
+     (sc-case x
+        (double-reg
+	 (case (tn-offset x)
+	    (0
+	     ;; x is in fr0
+	     (inst fstp fr1)
+	     (inst fldln2)
+	     (inst fxch fr1))
+	    (1
+	     ;; x is in fr1
+	     (inst fstp fr0)
+	     (inst fldln2)
+	     (inst fxch fr1))
+	    (t
+	     ;; x is in a FP reg, not fr0 or fr1
+	     (inst fstp fr0)
+	     (inst fstp fr0)
+	     (inst fldln2)
+	     (inst fldd (make-random-tn :kind :normal
+					:sc (sc-or-lose 'double-reg)
+					:offset (- (tn-offset x) 2)))))
+	 (inst fyl2xp1))
+	((double-stack descriptor-reg)
+	 (inst fstp fr0)
+	 (inst fstp fr0)
+	 (inst fldln2)
+	 (if (sc-is x double-stack)
+	     (inst fldd (ea-for-df-stack x))
+	   (inst fldd (ea-for-df-desc x)))
+	 (inst fyl2xp1)))
+     (inst fld fr0)
+     (case (tn-offset y)
+       ((0 1))
+       (t (inst fstd y)))))
+
+(define-vop (flogb)
+  (:translate %logb)
+  (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
+  (:temporary (:sc double-reg :offset fr0-offset
+		   :from :argument :to :result) fr0)
+  (:temporary (:sc double-reg :offset fr1-offset
+		   :from :argument :to :result) fr1)
+  (:results (y :scs (double-reg)))
+  (:arg-types double-float)
+  (:result-types double-float)
+  (:policy :fast-safe)
+  (:note "inline logb function")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 5
+     (note-this-location vop :internal-error)
+     (sc-case x
+        (double-reg
+	 (case (tn-offset x)
+	    (0
+	     ;; x is in fr0
+	     (inst fstp fr1))
+	    (1
+	     ;; x is in fr1
+	     (inst fstp fr0))
+	    (t
+	     ;; x is in a FP reg, not fr0 or fr1
+	     (inst fstp fr0)
+	     (inst fstp fr0)
+	     (inst fldd (make-random-tn :kind :normal
+					:sc (sc-or-lose 'double-reg)
+					:offset (- (tn-offset x) 2))))))
+	((double-stack descriptor-reg)
+	 (inst fstp fr0)
+	 (inst fstp fr0)
+	 (if (sc-is x double-stack)
+	     (inst fldd (ea-for-df-stack x))
+	   (inst fldd (ea-for-df-desc x)))))
+     (inst fxtract)
+     (case (tn-offset y)
+       (0
+	(inst fxch fr1))
+       (1)
+       (t (inst fxch fr1)
+	  (inst fstd y)))))
+
+(define-vop (fatan)
+  (:translate %atan)
+  (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
+  (:temporary (:sc double-reg :offset fr0-offset
+		   :from (:argument 0) :to :result) fr0)
+  (:temporary (:sc double-reg :offset fr1-offset
+		   :from (:argument 0) :to :result) fr1)
+  (:results (r :scs (double-reg)))
+  (:arg-types double-float)
+  (:result-types double-float)
+  (:policy :fast-safe)
+  (:note "inline atan function")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 5
+     (note-this-location vop :internal-error)
+     ;; Setup x in fr1 and 1.0 in fr0
+     (cond 
+      ;; x in fr0
+      ((and (sc-is x double-reg) (zerop (tn-offset x)))
+       (inst fstp fr1))
+      ;; x in fr1
+      ((and (sc-is x double-reg) (= 1 (tn-offset x)))
+       (inst fstp fr0))
+      ;; x not in fr0 or fr1
+      (t
+       ;; Load x then 1.0
+       (inst fstp fr0)
+       (inst fstp fr0)
+       (sc-case x
+          (double-reg
+	   (inst fldd (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'double-reg)
+				      :offset (- (tn-offset x) 2))))
+	  (double-stack
+	   (inst fldd (ea-for-df-stack x)))
+	  (descriptor-reg
+	   (inst fldd (ea-for-df-desc x))))))
+     (inst fld1)
+     ;; Now have x at fr1; and 1.0 at fr0
+     (inst fpatan)
+     (inst fld fr0)
+     (case (tn-offset r)
+       ((0 1))
+       (t (inst fstd r)))))
+
+(define-vop (fatan2)
+  (:translate %atan2)
+  (:args (x :scs (double-reg double-stack descriptor-reg) :target fr1)
+	 (y :scs (double-reg double-stack descriptor-reg) :target fr0))
+  (:temporary (:sc double-reg :offset fr0-offset
+		   :from (:argument 1) :to :result) fr0)
+  (:temporary (:sc double-reg :offset fr1-offset
+		   :from (:argument 0) :to :result) fr1)
+  (:results (r :scs (double-reg)))
+  (:arg-types double-float double-float)
+  (:result-types double-float)
+  (:policy :fast-safe)
+  (:note "inline atan2 function")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 5
+     (note-this-location vop :internal-error)
+     ;; Setup x in fr1 and y in fr0
+     (cond 
+      ;; y in fr0; x in fr1
+      ((and (sc-is y double-reg) (zerop (tn-offset y))
+	    (sc-is x double-reg) (= 1 (tn-offset x))))
+      ;; x in fr1; y not in fr0
+      ((and (sc-is x double-reg) (= 1 (tn-offset x)))
+       ;; Load y to fr0
+       (inst fstp fr0)
+       (sc-case y
+          (double-reg
+	   (inst fldd (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'double-reg)
+				      :offset (1- (tn-offset y)))))
+	  (double-stack
+	   (inst fldd (ea-for-df-stack y)))
+	  (descriptor-reg
+	   (inst fldd (ea-for-df-desc y)))))
+      ;; y in fr0; x not in fr1
+      ((and (sc-is y double-reg) (zerop (tn-offset y)))
+       (inst fxch fr1)
+       ;; Now load x to fr0
+       (inst fstp fr0)
+       (sc-case x
+          (double-reg
+	   (inst fldd (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'double-reg)
+				      :offset (1- (tn-offset x)))))
+	  (double-stack
+	   (inst fldd (ea-for-df-stack x)))
+	  (descriptor-reg
+	   (inst fldd (ea-for-df-desc x))))
+       (inst fxch fr1))
+      ;; y in fr1; x not in fr1
+      ((and (sc-is y double-reg) (= 1 (tn-offset y)))
+       ;; Load x to fr0
+       (inst fstp fr0)
+       (sc-case x
+          (double-reg
+	   (inst fldd (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'double-reg)
+				      :offset (1- (tn-offset x)))))
+	  (double-stack
+	   (inst fldd (ea-for-df-stack x)))
+	  (descriptor-reg
+	   (inst fldd (ea-for-df-desc x))))
+       (inst fxch fr1))
+      ;; x in fr0;
+      ((and (sc-is x double-reg) (zerop (tn-offset x)))
+       (inst fxch fr1)
+       ;; Now load y to fr0
+       (inst fstp fr0)
+       (sc-case y
+          (double-reg
+	   (inst fldd (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'double-reg)
+				      :offset (1- (tn-offset y)))))
+	  (double-stack
+	   (inst fldd (ea-for-df-stack y)))
+	  (descriptor-reg
+	   (inst fldd (ea-for-df-desc y)))))
+      ;; Neither y or x are in either fr0 or fr1
+      (t
+       ;; Load x then y
+       (inst fstp fr0)
+       (inst fstp fr0)
+       (sc-case x
+          (double-reg
+	   (inst fldd (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'double-reg)
+				      :offset (- (tn-offset x) 2))))
+	  (double-stack
+	   (inst fldd (ea-for-df-stack x)))
+	  (descriptor-reg
+	   (inst fldd (ea-for-df-desc x))))
+       ;; Load y to fr0
+       (sc-case y
+          (double-reg
+	   (inst fldd (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'double-reg)
+				      :offset (1- (tn-offset y)))))
+	  (double-stack
+	   (inst fldd (ea-for-df-stack y)))
+	  (descriptor-reg
+	   (inst fldd (ea-for-df-desc y))))))
+      
+     ;; Now have y at fr0; and x at fr1
+     (inst fpatan)
+     (inst fld fr0)
+     (case (tn-offset r)
+       ((0 1))
+       (t (inst fstd r)))))
diff --git a/compiler/x86/insts.lisp b/compiler/x86/insts.lisp
new file mode 100644
index 000000000..4d87cc0c5
--- /dev/null
+++ b/compiler/x86/insts.lisp
@@ -0,0 +1,2695 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/insts.lisp,v 1.1 1997/01/18 14:31:19 ram Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; Description of the x86 instruction set, for 80386 and above.
+;;;
+;;; Written by William Lott
+;;;
+;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
+;;;
+;;; Debugging and enhancements by Douglas Crosher 1996.
+;;;
+
+(in-package :x86)
+
+(use-package :new-assem)
+
+(def-assembler-params
+  :scheduler-p nil)
+
+(disassem:set-disassem-params :instruction-alignment 8)
+
+
+
+;;;; Primitive emitters.
+
+(define-emitter emit-word 16
+  (byte 16 0))
+
+(define-emitter emit-dword 32
+  (byte 32 0))
+
+(define-emitter emit-byte-with-reg 8
+  (byte 5 3) (byte 3 0))
+
+(define-emitter emit-mod-reg-r/m-byte 8
+  (byte 2 6) (byte 3 3) (byte 3 0))
+
+(define-emitter emit-sib-byte 8
+  (byte 2 6) (byte 3 3) (byte 3 0))
+
+
+
+;;;; Fixup emitters.
+
+(defun emit-absolute-fixup (segment fixup)
+  (note-fixup segment :absolute fixup)
+  (let ((offset (fixup-offset fixup)))
+    (if (label-p offset)
+	(emit-back-patch segment 4
+			 #'(lambda (segment posn)
+			     (declare (ignore posn))
+			     (emit-dword segment
+					 (- (+ (component-header-length)
+					       (or (label-position offset) 0) )
+					    other-pointer-type))))
+	(emit-dword segment (or offset 0)))))
+
+(defun emit-relative-fixup (segment fixup)
+  (note-fixup segment :relative fixup)
+  (emit-dword segment (or (fixup-offset fixup) 0)))
+
+
+
+;;;; The effective-address (ea) structure.
+
+(defun reg-tn-encoding (tn)
+  (declare (type tn tn))
+  (assert (eq (sb-name (sc-sb (tn-sc tn))) 'registers))
+  (let ((offset (tn-offset tn)))
+    (logior (ash (logand offset 1) 2)
+	    (ash offset -1))))
+
+(defstruct (ea
+	    (:constructor make-ea (size &key base index scale disp))
+	    (:print-function %print-ea))
+  (size nil :type (member :byte :word :dword))
+  (base nil :type (or tn null))
+  (index nil :type (or tn null))
+  (scale 1 :type (member 1 2 4 8))
+  (disp 0 :type (or (signed-byte 32) fixup)))
+
+(defun %print-ea (ea stream depth)
+  (declare (ignore depth))
+  (cond ((or *print-escape* *print-readably*)
+	 (print-unreadable-object (ea stream :type t)
+	   (format stream
+		   "~S~@[ base=~S~]~@[ index=~S~]~@[ scale=~S~]~@[ disp=~S~]"
+		   (ea-size ea)
+		   (ea-base ea)
+		   (ea-index ea)
+		   (let ((scale (ea-scale ea)))
+		     (if (= scale 1) nil scale))
+		   (ea-disp ea))))
+	(t
+	 (format stream "~A PTR [" (symbol-name (ea-size ea)))
+	 (when (ea-base ea)
+	   (write-string (x86-location-print-name (ea-base ea)) stream)
+	   (when (ea-index ea)
+	     (write-string "+" stream)))
+	 (when (ea-index ea)
+	   (write-string (x86-location-print-name (ea-index ea)) stream))
+	 (unless (= (ea-scale ea) 1)
+	   (format stream "*~A" (ea-scale ea)))
+	 (typecase (ea-disp ea)
+	   (null)
+	   (integer
+	    (format stream "~@D" (ea-disp ea)))
+	   (t
+	    (format stream "+~A" (ea-disp ea))))
+	 (write-char #\] stream))))
+
+(defun emit-ea (segment thing reg &optional allow-constants)
+  (etypecase thing
+    (tn
+     (ecase (sb-name (sc-sb (tn-sc thing)))
+       (registers
+	(emit-mod-reg-r/m-byte segment #b11 reg (reg-tn-encoding thing)))
+       (stack
+	;; Convert stack tns into an index off of EBP.
+	(let ((disp (- (* (1+ (tn-offset thing)) word-bytes))))
+	  (cond ((< -128 disp 127)
+		 (emit-mod-reg-r/m-byte segment #b01 reg #b101)
+		 (emit-byte segment disp))
+		(t
+		 (emit-mod-reg-r/m-byte segment #b10 reg #b101)
+		 (emit-dword segment disp)))))
+       (constant
+	(unless allow-constants
+	  (error
+	   "Constant TNs can only be directly used in MOV, PUSH, and CMP."))
+	(emit-mod-reg-r/m-byte segment #b00 reg #b101)
+	(emit-absolute-fixup segment
+			     (make-fixup nil
+					 :code-object
+					 (- (* (tn-offset thing) word-bytes)
+					    other-pointer-type))))))
+    (ea
+     (let* ((base (ea-base thing))
+	    (index (ea-index thing))
+	    (scale (ea-scale thing))
+	    (disp (ea-disp thing))
+	    (mod (cond ((or (null base)
+			    (and (eql disp 0)
+				 (not (= (reg-tn-encoding base) #b101))))
+			#b00)
+		       ((and (fixnump disp) (<= -128 disp 127))
+			#b01)
+		       (t
+			#b10)))
+	    (r/m (cond (index #b100)
+		       ((null base) #b101)
+		       (t (reg-tn-encoding base)))))
+       (emit-mod-reg-r/m-byte segment mod reg r/m)
+       (when (= r/m #b100)
+	 (let ((ss (1- (integer-length scale)))
+	       (index (if (null index)
+			  #b100
+			  (let ((index (reg-tn-encoding index)))
+			    (if (= index #b100)
+				(error "Can't index off of ESP")
+				index))))
+	       (base (if (null base)
+			 #b101
+			 (reg-tn-encoding base))))
+	   (emit-sib-byte segment ss index base)))
+       (cond ((= mod #b01)
+	      (emit-byte segment disp))
+	     ((or (= mod #b10) (null base))
+	      (if (fixup-p disp)
+		  (emit-absolute-fixup segment disp)
+		  (emit-dword segment disp))))))
+    (fixup
+     (emit-mod-reg-r/m-byte segment #b00 reg #b101)
+     (emit-absolute-fixup segment thing))))
+
+(defun fp-reg-tn-p (thing)
+  (and (tn-p thing)
+       (eq (sb-name (sc-sb (tn-sc thing))) 'float-registers)))
+
+;;;
+;;; like the above, but for fp-instructions--jrd
+;;;
+(defun emit-fp-op (segment thing op)
+  (if (fp-reg-tn-p thing)
+      (emit-byte segment (dpb op (byte 3 3) (dpb (tn-offset thing)
+						 (byte 3 0)
+						 #b11000000)))
+    (emit-ea segment thing op)))
+
+(defun byte-reg-p (thing)
+  (and (tn-p thing)
+       (eq (sb-name (sc-sb (tn-sc thing))) 'registers)
+       (member (sc-name (tn-sc thing)) byte-sc-names)
+       t))
+
+(defun byte-ea-p (thing)
+  (typecase thing
+    (ea (eq (ea-size thing) :byte))
+    (tn
+     (and (member (sc-name (tn-sc thing)) byte-sc-names) t))
+    (t nil)))
+
+(defun word-reg-p (thing)
+  (and (tn-p thing)
+       (eq (sb-name (sc-sb (tn-sc thing))) 'registers)
+       (member (sc-name (tn-sc thing)) word-sc-names)
+       t))
+
+(defun word-ea-p (thing)
+  (typecase thing
+    (ea (eq (ea-size thing) :word))
+    (tn (and (member (sc-name (tn-sc thing)) word-sc-names) t))
+    (t nil)))
+
+(defun dword-reg-p (thing)
+  (and (tn-p thing)
+       (eq (sb-name (sc-sb (tn-sc thing))) 'registers)
+       (member (sc-name (tn-sc thing)) dword-sc-names)
+       t))
+
+(defun dword-ea-p (thing)
+  (typecase thing
+    (ea (eq (ea-size thing) :dword))
+    (tn
+     (and (member (sc-name (tn-sc thing)) dword-sc-names) t))
+    (t nil)))
+
+(defun register-p (thing)
+  (and (tn-p thing)
+       (eq (sb-name (sc-sb (tn-sc thing))) 'registers)))
+
+(defun accumulator-p (thing)
+  (and (register-p thing)
+       (= (tn-offset thing) 0)))
+
+(eval-when (compile load eval)
+(defconstant conditions
+  '((:o . 0)
+    (:no . 1)
+    (:b . 2) (:nae . 2) (:c . 2)
+    (:nb . 3) (:ae . 3) (:nc . 3)
+    (:eq . 4) (:e . 4) (:z . 4)
+    (:ne . 5) (:nz . 5)
+    (:be . 6) (:na . 6)
+    (:nbe . 7) (:a . 7)
+    (:s . 8)
+    (:ns . 9)
+    (:p . 10) (:pe . 10)
+    (:np . 11) (:po . 11)
+    (:l . 12) (:nge . 12)
+    (:nl . 13) (:ge . 13)
+    (:le . 14) (:ng . 14)
+    (:nle . 15) (:g . 15)))
+
+(defun conditional-opcode (condition)
+  (cdr (assoc condition conditions :test #'eq))))
+
+
+
+;;;; Utilities.
+
+#-lispworks3
+(defconstant operand-size-prefix-byte #b01100110)
+
+#+lispworks3
+(eval-when (compile load eval)
+  (defconstant operand-size-prefix-byte #b01100110))
+
+(defparameter *default-operand-size* :dword)
+
+(defun maybe-emit-operand-size-prefix (segment size)
+  (unless (or (eq size :byte) (eq size *default-operand-size*))
+    (emit-byte segment operand-size-prefix-byte)))
+
+(defun operand-size (thing)
+  (typecase thing
+    (tn
+     (case (sc-name (tn-sc thing))
+       (#.dword-sc-names
+	:dword)
+       (#.word-sc-names
+	:word)
+       (#.byte-sc-names
+	:byte)
+       ;; added by jrd.  float-registers is a separate size (?)
+       (#.float-sc-names
+	:float)
+       (#.double-sc-names
+	:double)
+       (t
+	(error "Can't tell the size of ~S ~S" thing (sc-name (tn-sc thing))))))
+    (ea
+     (ea-size thing))
+    (t
+     nil)))
+
+(defun matching-operand-size (dst src)
+  (let ((dst-size (operand-size dst))
+	(src-size (operand-size src)))
+    (if dst-size
+	(if src-size
+	    (if (eq dst-size src-size)
+		dst-size
+		(error "Size mismatch: ~S is a ~S and ~S is a ~S"
+		       dst dst-size src src-size))
+	    dst-size)
+	(if src-size
+	    src-size
+	    (error "Can't tell the size of either ~S or ~S."
+		   dst src)))))
+
+(defun emit-sized-immediate (segment size value)
+  (ecase size
+    (:byte
+     (emit-byte segment value))
+    (:word
+     (emit-word segment value))
+    (:dword
+     (emit-dword segment value))))
+
+
+
+;;;; Disassembler support stuff.
+
+(deftype reg () '(unsigned-byte 3))  
+#+cross-compiler
+(lisp:deftype reg () '(unsigned-byte 3))
+
+(eval-when (compile eval load)
+
+(defparameter *default-address-size*
+  ;; Actually, :dword is the only one really supported.
+  :dword)
+
+(defparameter byte-reg-names
+  #(al cl dl bl ah ch dh bh))
+(defparameter word-reg-names
+  #(ax cx dx bx sp bp si di))
+(defparameter dword-reg-names
+  #(eax ecx edx ebx esp ebp esi edi))
+
+(defun print-reg-with-width (value width stream dstate)
+  (declare (ignore dstate))
+  (princ (aref (ecase width
+		 (:byte byte-reg-names)
+		 (:word word-reg-names)
+		 (:dword dword-reg-names))
+	       value)
+	 stream)
+  ;; plus should do some source-var notes
+  )
+
+(defun print-reg (value stream dstate)
+  (declare (type reg value)
+	   (type stream stream)
+	   (type disassem:disassem-state dstate))
+  (print-reg-with-width value
+			(disassem:dstate-get-prop dstate 'width)
+			stream
+			dstate))
+
+(defun print-word-reg (value stream dstate)
+  (declare (type reg value)
+	   (type stream stream)
+	   (type disassem:disassem-state dstate))
+  (print-reg-with-width value
+			(or (disassem:dstate-get-prop dstate 'word-width)
+			    *default-operand-size*)
+			stream
+			dstate))
+
+(defun print-byte-reg (value stream dstate)
+  (declare (type reg value)
+	   (type stream stream)
+	   (type disassem:disassem-state dstate))
+  (print-reg-with-width value :byte stream dstate))
+
+(defun print-addr-reg (value stream dstate)
+  (declare (type reg value)
+	   (type stream stream)
+	   (type disassem:disassem-state dstate))
+  (print-reg-with-width value *default-address-size* stream dstate))
+
+;;; Value is a list of (BASE-REG OFFSET INDEX-REG INDEX-SCALE)
+(defun print-mem-access (value stream print-size-p dstate)
+  (declare (type list value)
+	   (type stream stream)
+	   (type (member t nil) print-size-p)
+	   (type disassem:disassem-state dstate))
+  (when print-size-p
+    (princ (disassem:dstate-get-prop dstate 'width) stream)
+    (princ '| PTR | stream))
+  (write-char #\[ stream)
+  (let ((firstp t))
+    (macrolet ((pel ((var val) &body body)
+		 ;; Print an element of the address, maybe with
+		 ;; a leading separator.
+		 `(let ((,var ,val))
+		    (when ,var
+		      (unless firstp
+			(write-char #\+ stream))
+		      ,@body
+		      (setq firstp nil)))))
+      (pel (base-reg (first value))
+	(print-addr-reg base-reg stream dstate))
+      (pel (index-reg (third value))
+	(print-addr-reg index-reg stream dstate)
+	(let ((index-scale (fourth value)))
+	  (when (and index-scale (not (= index-scale 1)))
+	    (write-char #\* stream)
+	    (princ index-scale stream))))
+      (let ((offset (second value)))
+	(when (and offset (or firstp (not (zerop offset))))
+	  (unless (or firstp (minusp offset))
+	    (write-char #\+ stream))
+	  (if firstp
+	      (disassem:princ16 offset stream)
+	      (princ offset stream))))))
+  (write-char #\] stream))
+
+(defun print-reg/mem (value stream dstate)
+  (declare (type (or list reg) value)
+	   (type stream stream)
+	   (type disassem:disassem-state dstate))
+  (if (typep value 'reg)
+      (print-reg value stream dstate)
+      (print-mem-access value stream nil dstate)))
+
+;; Same as print-reg/mem, but prints an explicit size indicator for
+;; memory references.
+(defun print-sized-reg/mem (value stream dstate)
+  (declare (type (or list reg) value)
+	   (type stream stream)
+	   (type disassem:disassem-state dstate))
+  (if (typep value 'reg)
+      (print-reg value stream dstate)
+      (print-mem-access value stream t dstate)))
+
+(defun print-byte-reg/mem (value stream dstate)
+  (declare (type (or list reg) value)
+	   (type stream stream)
+	   (type disassem:disassem-state dstate))
+  (if (typep value 'reg)
+      (print-byte-reg value stream dstate)
+      (print-mem-access value stream t dstate)))
+
+(defun print-label (value stream dstate)
+  (declare (ignore dstate))
+  (disassem:princ16 value stream))
+
+;;; Returns either an integer, meaning a register, or a list of
+;;; (BASE-REG OFFSET INDEX-REG INDEX-SCALE), where any component
+;;; may be missing or nil to indicate that it's not used or has the
+;;; obvious default value (e.g., 1 for the index-scale).
+(defun prefilter-reg/mem (value dstate)
+  (declare (type list value)
+	   (type disassem:disassem-state dstate))
+  (let ((mod (car value))
+	(r/m (cadr value)))
+    (declare (type (unsigned-byte 2) mod)
+	     (type (unsigned-byte 3) r/m))
+    (cond ((= mod #b11)
+	   ;; registers
+	   r/m)
+	  ((= r/m #b100)
+	   ;; sib byte
+	   (let ((sib (disassem:read-suffix 8 dstate)))
+	     (declare (type (unsigned-byte 8) sib))
+	     (let ((base-reg (ldb (byte 3 0) sib))
+		   (index-reg (ldb (byte 3 3) sib))
+		   (index-scale (ldb (byte 2 6) sib)))
+	       (declare (type (unsigned-byte 3) base-reg index-reg)
+			(type (unsigned-byte 2) index-scale))
+	       (let* ((offset
+		       (case mod
+			 (#b00
+			  (if (= base-reg #b101)
+			      (disassem:read-suffix 32 dstate)
+			      nil))
+			 (#b01
+			  (disassem:read-signed-suffix 8 dstate))
+			 (#b10
+			  (disassem:read-suffix 32 dstate)))))
+		 (list (if (and (= mod #b00) (= base-reg #b101)) nil base-reg)
+		       offset
+		       (if (= index-reg #b100) nil index-reg)
+		       (ash 1 index-scale))))))
+	  ((and (= mod #b00) (= r/m #b101))
+	   (list nil (disassem:read-suffix 32 dstate)) )
+	  ((= mod #b00)
+	   (list r/m))
+	  ((= mod #b01)
+	   (list r/m (disassem:read-signed-suffix 8 dstate)))
+	  (t				; (= mod #b10)
+	   (list r/m (disassem:read-suffix 32 dstate))))))
+
+
+;;; This is a sort of bogus prefilter that just
+;;; stores the info globally for other people to use; it
+;;; probably never gets printed.
+(defun prefilter-width (value dstate)
+  (setf (disassem:dstate-get-prop dstate 'width)
+	(if (zerop value)
+	    :byte
+	    (let ((word-width
+		   ;; set by a prefix instruction
+		   (or (disassem:dstate-get-prop dstate 'word-width)
+		       *default-operand-size*)))
+	      (when (not (eql word-width *default-operand-size*))
+		;; reset it
+		(setf (disassem:dstate-get-prop dstate 'word-width)
+		      *default-operand-size*))
+	      word-width))))
+
+(defun offset-next (value dstate)
+  (declare #|(type integer value)|#
+	   (type disassem:disassem-state dstate))
+  ;; XXX dtc; a hack to stop the disassembler causing a fatal error;
+  ;; probably caused by out of bounds offsets?
+  (if (or (null value)
+	  (and (listp value) (null (car value))))
+      0
+    (+ (disassem:dstate-next-addr dstate) (if (listp value) (car value) value))))
+
+(defun read-address (value dstate)
+  (declare (ignore value))		; always nil anyway
+  (disassem:read-suffix (width-bits *default-address-size*) dstate))
+
+(defun read-signed-imm-dword (value dstate)
+  (declare (ignore value))		; always nil anyway
+  (disassem:read-signed-suffix 32 dstate))
+
+(defun width-bits (width)
+  (ecase width
+    (:byte 8)
+    (:word 16)
+    (:dword 32)
+    (:float 32)
+    (:double 64)))
+
+); eval-when
+
+
+;;;; Disassembler argument types.
+
+(disassem:define-argument-type accum
+  :printer #'(lambda (value stream dstate)
+	       (declare (ignore value)
+			(type stream stream)
+			(type disassem:disassem-state dstate))
+	       (print-reg 0 stream dstate))
+  )
+
+(disassem:define-argument-type word-accum
+  :printer #'(lambda (value stream dstate)
+	       (declare (ignore value)
+			(type stream stream)
+			(type disassem:disassem-state dstate))
+	       (print-word-reg 0 stream dstate))
+  )
+
+(disassem:define-argument-type reg
+  :printer #'print-reg)
+
+(disassem:define-argument-type addr-reg
+  :printer #'print-addr-reg)
+
+(disassem:define-argument-type word-reg
+  :printer #'print-word-reg)
+
+(disassem:define-argument-type imm-addr
+  :prefilter #'read-address
+  :printer #'print-label)
+
+(disassem:define-argument-type imm-data
+  :prefilter #'(lambda (value dstate)
+		 (declare (ignore value)) ; always nil anyway
+		 (disassem:read-suffix
+		  (width-bits (disassem:dstate-get-prop dstate 'width))
+		  dstate))
+  )
+
+(disassem:define-argument-type signed-imm-data
+  :prefilter #'(lambda (value dstate)
+		 (declare (ignore value)) ; always nil anyway
+		 (let ((width (disassem:dstate-get-prop dstate 'width)))
+		   (disassem:read-signed-suffix (width-bits width) dstate)))
+  )
+
+(disassem:define-argument-type signed-imm-byte
+  :prefilter #'(lambda (value dstate)
+		 (declare (ignore value)) ; always nil anyway
+		 (disassem:read-signed-suffix 8 dstate)))
+
+(disassem:define-argument-type signed-imm-dword
+  :prefilter #'read-signed-imm-dword)
+
+(disassem:define-argument-type imm-word
+  :prefilter #'(lambda (value dstate)
+		 (declare (ignore value)) ; always nil anyway
+		 (let ((width
+			(or (disassem:dstate-get-prop dstate 'word-width)
+			    *default-operand-size*)))
+		   (disassem:read-suffix (width-bits width) dstate))))
+
+;;; Needed for the ret imm16 instruction
+(disassem:define-argument-type imm-word-16
+  :prefilter #'(lambda (value dstate)
+		 (declare (ignore value)) ; always nil anyway
+		 (disassem:read-suffix 16 dstate)))
+
+(disassem:define-argument-type reg/mem
+  :prefilter #'prefilter-reg/mem
+  :printer #'print-reg/mem)
+(disassem:define-argument-type sized-reg/mem
+  ;; Same as reg/mem, but prints an explicit size indicator for
+  ;; memory references.
+  :prefilter #'prefilter-reg/mem
+  :printer #'print-sized-reg/mem)
+(disassem:define-argument-type byte-reg/mem
+  :prefilter #'prefilter-reg/mem
+  :printer #'print-byte-reg/mem)
+
+;;;
+;;; added by jrd
+;;;
+(eval-when (compile load eval)
+(defun print-fp-reg (value stream dstate)
+  (declare (ignore dstate))
+  (format stream "FR~D" value))
+
+(defun prefilter-fp-reg (value dstate)
+  ;; just return it
+  (declare (ignore dstate))
+  value)
+)
+(disassem:define-argument-type fp-reg
+			       :prefilter #'prefilter-fp-reg
+			       :printer #'print-fp-reg)
+
+(disassem:define-argument-type width
+  :prefilter #'prefilter-width
+  :printer #'(lambda (value stream dstate)
+	       (if ;; (zerop value)
+		   (or (null value) (and (numberp value) (zerop value)))	; zzz jrd
+		   (princ 'b stream)
+		   (let ((word-width
+			  ;; set by a prefix instruction
+			  (or (disassem:dstate-get-prop dstate 'word-width)
+			      *default-operand-size*)))
+		     (princ (schar (symbol-name word-width) 0) stream)))))
+
+
+;;;; Disassembler instruction formats.
+
+(eval-when (compile eval)
+  (defun swap-if (direction field1 separator field2)
+    `(:if (,direction :constant 0)
+	  (,field1 ,separator ,field2)
+	  (,field2 ,separator ,field1))))
+
+(disassem:define-instruction-format (byte 8 :default-printer '(:name))
+  (op    :field (byte 8 0))
+  ;; optional fields
+  (accum :type 'accum)
+  (imm))
+
+(disassem:define-instruction-format (simple 8)
+  (op    :field (byte 7 1))
+  (width :field (byte 1 0) :type 'width)
+  ;; optional fields
+  (accum :type 'accum)
+  (imm))
+
+;;; Same as simple, but with direction bit
+(disassem:define-instruction-format (simple-dir 8 :include 'simple)
+  (op :field (byte 6 2))
+  (dir :field (byte 1 1)))
+
+;;; Same as simple, but with the immediate value occuring by default,
+;;; and with an appropiate printer.
+(disassem:define-instruction-format (accum-imm 8
+				     :include 'simple
+				     :default-printer '(:name
+							:tab accum ", " imm))
+  (imm :type 'imm-data))
+
+(disassem:define-instruction-format (reg-no-width 8
+				     :default-printer '(:name :tab reg))
+  (op	 :field (byte 5 3))
+  (reg   :field (byte 3 0) :type 'word-reg)
+  ;; optional fields
+  (accum :type 'word-accum)
+  (imm))
+
+;;; adds a width field to reg-no-width
+(disassem:define-instruction-format (reg 8 :default-printer '(:name :tab reg))
+  (op    :field (byte 4 4))
+  (width :field (byte 1 3) :type 'width)
+  (reg   :field (byte 3 0) :type 'reg)
+  ;; optional fields
+  (accum :type 'accum)
+  (imm)
+  )
+
+;;; Same as reg, but with direction bit
+(disassem:define-instruction-format (reg-dir 8 :include 'reg)
+  (op  :field (byte 3 5))
+  (dir :field (byte 1 4)))
+
+(disassem:define-instruction-format (two-bytes 16
+				     :default-printer '(:name))
+  (op :fields (list (byte 8 0) (byte 8 8))))
+
+(disassem:define-instruction-format (reg-reg/mem 16
+				     :default-printer
+				        `(:name :tab reg ", " reg/mem))
+  (op      :field (byte 7 1))
+  (width   :field (byte 1 0)	:type 'width)
+  (reg/mem :fields (list (byte 2 14) (byte 3 8))
+	   			:type 'reg/mem)
+  (reg     :field (byte 3 11)	:type 'reg)
+  ;; optional fields
+  (imm))
+
+;;; same as reg-reg/mem, but with direction bit
+(disassem:define-instruction-format (reg-reg/mem-dir 16
+				     :include 'reg-reg/mem
+				     :default-printer
+				        `(:name
+					  :tab
+					  ,(swap-if 'dir 'reg/mem ", " 'reg)))
+  (op  :field (byte 6 2))
+  (dir :field (byte 1 1)))
+
+;;; Same as reg-rem/mem, but uses the reg field as a second op code.
+(disassem:define-instruction-format (reg/mem 16
+				     :default-printer '(:name :tab reg/mem))
+  (op      :fields (list (byte 7 1) (byte 3 11)))
+  (width   :field (byte 1 0)	:type 'width)
+  (reg/mem :fields (list (byte 2 14) (byte 3 8))
+	   			:type 'sized-reg/mem)
+  ;; optional fields
+  (imm))
+
+;;; Same as reg/mem, but with the immediate value occuring by default,
+;;; and with an appropiate printer.
+(disassem:define-instruction-format (reg/mem-imm 16
+				     :include 'reg/mem
+				     :default-printer
+				        '(:name :tab reg/mem ", " imm))
+  (reg/mem :type 'sized-reg/mem)
+  (imm     :type 'imm-data))
+
+;;; Same as reg/mem, but with using the accumulator in the default printer
+(disassem:define-instruction-format
+    (accum-reg/mem 16
+     :include 'reg/mem :default-printer '(:name :tab accum ", " reg/mem))
+  (reg/mem :type 'reg/mem)		; don't need a size
+  (accum :type 'accum))
+
+;;; Same as reg-reg/mem, but with a prefix of #b00001111
+(disassem:define-instruction-format (ext-reg-reg/mem 24
+				     :default-printer
+				        `(:name :tab reg ", " reg/mem))
+  (prefix  :field (byte 8 0)	:value #b00001111)
+  (op      :field (byte 7 9))
+  (width   :field (byte 1 8)	:type 'width)
+  (reg/mem :fields (list (byte 2 22) (byte 3 16))
+	   			:type 'reg/mem)
+  (reg     :field (byte 3 19)	:type 'reg)
+  ;; optional fields
+  (imm))
+
+;;; Same as reg/mem, but with a prefix of #b00001111
+(disassem:define-instruction-format (ext-reg/mem 24
+				     :default-printer '(:name :tab reg/mem))
+  (prefix  :field (byte 8 0)	:value #b00001111)
+  (op      :fields (list (byte 7 9) (byte 3 19)))
+  (width   :field (byte 1 8)	:type 'width)
+  (reg/mem :fields (list (byte 2 22) (byte 3 16))
+	   			:type 'sized-reg/mem)
+  ;; optional fields
+  (imm))
+
+;;; ----------------------------------------------------------------
+;;; this section added by jrd, for fp instructions.  
+
+;;; 
+;;; regular fp inst to/from registers/memory
+;;;
+(disassem:define-instruction-format (floating-point 16 
+				      :default-printer `(:name :tab reg/mem))
+  (prefix :field (byte 5 3) :value #b11011)
+  (op     :fields (list (byte 3 0) (byte 3 11)))
+  (reg/mem :fields (list (byte 2 14) (byte 3 8)) :type 'reg/mem)
+  )
+
+;;;
+;;; fp insn to/from fp reg
+;;;
+(disassem:define-instruction-format (floating-point-fp 16 
+				      :default-printer `(:name :tab fp-reg))
+  (prefix :field (byte 5 3) :value #b11011)
+  (suffix :field (byte 2 14) :value #b11)
+  (op     :fields (list (byte 3 0) (byte 3 11)))
+  (fp-reg :field (byte 3 8) :type 'fp-reg)
+  )
+
+;;;
+;;; fp insn to/from fp reg, with the reversed source/destination flag.
+;;;
+(disassem:define-instruction-format
+ (floating-point-fp-d 16 
+   :default-printer `(:name :tab ,(swap-if 'd "ST0" ", " 'fp-reg)))
+  (prefix :field (byte 5 3) :value #b11011)
+  (suffix :field (byte 2 14) :value #b11)
+  (op     :fields (list (byte 2 0) (byte 3 11)))
+  (d      :field (byte 1 2))
+  (fp-reg :field (byte 3 8) :type 'fp-reg)
+  )
+
+
+;;; pfw
+;;; fp no operand isns
+;;;
+(disassem:define-instruction-format (floating-point-no 16
+				      :default-printer '(:name))
+  (prefix :field (byte 8  0) :value #b11011001)
+  (suffix :field (byte 3 13) :value #b111)
+  (op     :field (byte 5  8)))
+
+(disassem:define-instruction-format (floating-point-5 16
+				      :default-printer '(:name))
+  (prefix :field (byte 8  0) :value #b11011011)
+  (suffix :field (byte 3 13) :value #b111)
+  (op     :field (byte 5  8)))
+
+(disassem:define-instruction-format (floating-point-st 16
+				      :default-printer '(:name))
+  (prefix :field (byte 8  0) :value #b11011111)
+  (suffix :field (byte 3 13) :value #b111)
+  (op     :field (byte 5  8)))
+
+
+;;; ----------------------------------------------------------------
+
+
+;;;; General Data Transfer
+
+(eval-when (eval compile load)
+  (defun toggle-word-width (chunk inst stream dstate)
+    (declare (ignore chunk inst stream))
+    (let ((ww (or (disassem:dstate-get-prop dstate 'word-width)
+		  *default-operand-size*)))
+      (setf (disassem:dstate-get-prop dstate 'word-width)
+	    (ecase ww
+	      (:word :dword)
+	      (:dword :word))))))
+
+;;; This isn't a really an instruction, but it's easier to deal with it this
+;;; way.  We assume that it's actually used.
+(define-instruction toggle-data-size (segment)
+  (:printer byte ((op operand-size-prefix-byte))
+	    nil				; don't actually print it
+	    :control #'toggle-word-width))
+
+
+(define-instruction mov (segment dst src)
+  ;; immediate to register
+  (:printer reg ((op #b1011) (imm nil :type 'imm-data))
+	    '(:name :tab reg ", " imm))
+  ;; absolute mem to/from accumulator
+  (:printer simple-dir ((op #b101000) (imm nil :type 'imm-addr))
+	    `(:name :tab ,(swap-if 'dir 'accum ", " '("[" imm "]"))))
+  ;; register to/from register/memory
+  (:printer reg-reg/mem-dir ((op #b100010)))
+  ;; immediate to register/memory
+  (:printer reg/mem-imm ((op '(#b1100011 #b000))))
+
+  (:emitter
+   (let ((size (matching-operand-size dst src)))
+     (maybe-emit-operand-size-prefix segment size)
+     (cond ((register-p dst)
+	    (cond ((integerp src)
+		   (emit-byte-with-reg segment
+				       (if (eq size :byte)
+					   #b10110
+					   #b10111)
+				       (reg-tn-encoding dst))
+		   (emit-sized-immediate segment size src))
+		  ((and (fixup-p src) (accumulator-p dst))
+		   (emit-byte segment
+			      (if (eq size :byte)
+				  #b10100000
+				  #b10100001))
+		   (emit-absolute-fixup segment src))
+		  (t
+		   (emit-byte segment
+			      (if (eq size :byte)
+				  #b10001010
+				  #b10001011))
+		   (emit-ea segment src (reg-tn-encoding dst) t))))
+	   ((and (fixup-p dst) (accumulator-p src))
+	    (emit-byte segment (if (eq size :byte) #b10100010 #b10100011))
+	    (emit-absolute-fixup segment dst))
+	   ((integerp src)
+	    (emit-byte segment (if (eq size :byte) #b11000110 #b11000111))
+	    (emit-ea segment dst #b000)
+	    (emit-sized-immediate segment size src))
+	   ((register-p src)
+	    (emit-byte segment (if (eq size :byte) #b10001000 #b10001001))
+	    (emit-ea segment dst (reg-tn-encoding src)))
+	   ((fixup-p src)
+	    (assert (eq size :dword))
+	    (emit-byte segment #b11000111)
+	    (emit-ea segment dst #b000)
+	    (emit-absolute-fixup segment src))
+	   (t
+	    (error "Bogus arguments to MOV: ~S ~S" dst src))))))
+
+(defun emit-move-with-extension (segment dst src opcode)
+  (assert (register-p dst))
+  (let ((dst-size (operand-size dst))
+	(src-size (operand-size src)))
+    (ecase dst-size
+      (:word
+       (assert (eq src-size :byte))
+       (maybe-emit-operand-size-prefix segment :word)
+       (emit-byte segment #b00001111)
+       (emit-byte segment opcode)
+       (emit-ea segment src (reg-tn-encoding dst)))
+      (:dword
+       (ecase src-size
+	 (:byte
+	  (maybe-emit-operand-size-prefix segment :dword)
+	  (emit-byte segment #b00001111)
+	  (emit-byte segment opcode)
+	  (emit-ea segment src (reg-tn-encoding dst)))
+	 (:word
+	  (emit-byte segment #b00001111)
+	  (emit-byte segment (logior opcode 1))
+	  (emit-ea segment src (reg-tn-encoding dst))))))))
+	  
+(define-instruction movsx (segment dst src)
+  (:printer ext-reg-reg/mem ((op #b1011111) (reg nil :type 'word-reg)))
+  (:emitter
+   (emit-move-with-extension segment dst src #b10111110)))
+
+(define-instruction movzx (segment dst src)
+  (:printer ext-reg-reg/mem ((op #b1011011) (reg nil :type 'word-reg)))
+  (:emitter
+   (emit-move-with-extension segment dst src #b10110110)))
+
+(define-instruction push (segment src)
+  ;; Register.
+  (:printer reg-no-width ((op #b01010)))
+  ;; Register/Memory.
+  (:printer reg/mem ((op '(#b1111111 #b110)) (width 1)))
+  ;; Immediate.
+  (:printer byte ((op #b01101010) (imm nil :type 'signed-imm-byte))
+	    '(:name :tab imm))
+  (:printer byte ((op #b01101000) (imm nil :type 'imm-word))
+	    '(:name :tab imm))
+  ;; ### Segment registers?
+
+  (:emitter
+   (cond ((integerp src)
+	  (cond ((<= -128 src 127)
+		 (emit-byte segment #b01101010)
+		 (emit-byte segment src))
+		(t
+		 (emit-byte segment #b01101000)
+		 (emit-dword segment src))))
+	 ((fixup-p src)
+	  ;; Interpret the fixup as an immediate dword to push
+	  (emit-byte segment #b01101000)
+	  (emit-absolute-fixup segment src))
+	 (t
+	  (let ((size (operand-size src)))
+	    (assert (not (eq size :byte)))
+	    (maybe-emit-operand-size-prefix segment size)
+	    (cond ((register-p src)
+		   (emit-byte-with-reg segment #b01010 (reg-tn-encoding src)))
+		  (t
+		   (emit-byte segment #b11111111)
+		   (emit-ea segment src #b110 t))))))))
+
+(define-instruction pusha (segment)
+  (:printer byte ((op #b01100000)))
+  (:emitter
+   (emit-byte segment #b01100000)))
+
+(define-instruction pop (segment dst)
+  (:printer reg-no-width ((op #b01011)))
+  (:printer reg/mem ((op '(#b1000111 #b000)) (width 1)))
+  (:emitter
+   (let ((size (operand-size dst)))
+     (assert (not (eq size :byte)))
+     (maybe-emit-operand-size-prefix segment size)
+     (cond ((register-p dst)
+	    (emit-byte-with-reg segment #b01011 (reg-tn-encoding dst)))
+	   (t
+	    (emit-byte segment #b10001111)
+	    (emit-ea segment dst #b000))))))
+
+(define-instruction popa (segment)
+  (:printer byte ((op #b01100001)))
+  (:emitter
+   (emit-byte segment #b01100001)))
+
+(define-instruction xchg (segment operand1 operand2)
+  ;; Register with accumulator.
+  (:printer reg-no-width ((op #b10010)) '(:name :tab accum ", " reg))
+  ;; Register/Memory with Register.
+  (:printer reg-reg/mem ((op #b1000011)))
+  (:emitter
+   (let ((size (matching-operand-size operand1 operand2)))
+     (maybe-emit-operand-size-prefix segment size)
+     (labels ((xchg-acc-with-something (acc something)
+		(if (and (not (eq size :byte)) (register-p something))
+		    (emit-byte-with-reg segment
+					#b10010
+					(reg-tn-encoding something))
+		    (xchg-reg-with-something acc something)))
+	      (xchg-reg-with-something (reg something)
+		(emit-byte segment (if (eq size :byte) #b10000110 #b10000111))
+		(emit-ea segment something (reg-tn-encoding reg))))
+       (cond ((accumulator-p operand1)
+	      (xchg-acc-with-something operand1 operand2))
+	     ((accumulator-p operand2)
+	      (xchg-acc-with-something operand2 operand1))
+	     ((register-p operand1)
+	      (xchg-reg-with-something operand1 operand2))
+	     ((register-p operand2)
+	      (xchg-reg-with-something operand2 operand1))
+	     (t
+	      (error "Bogus args to XCHG: ~S ~S" operand1 operand2)))))))
+
+(define-instruction lea (segment dst src)
+  (:printer reg-reg/mem ((op #b1000110) (width 1)))
+  (:emitter
+   (assert (dword-reg-p dst))
+   (emit-byte segment #b10001101)
+   (emit-ea segment src (reg-tn-encoding dst))))
+
+
+
+;;;; Flag control instructions.
+
+;;; CLC -- Clear Carry Flag.
+;;;
+(define-instruction clc (segment)
+  (:printer byte ((op #b11111000)))
+  (:emitter
+   (emit-byte segment #b11111000)))
+
+;;; CLD -- Clear Direction Flag.
+;;;
+(define-instruction cld (segment)
+  (:printer byte ((op #b11111100)))
+  (:emitter
+   (emit-byte segment #b11111100)))
+
+;;; CLI -- Clear Iterrupt Enable Flag.
+;;;
+(define-instruction cli (segment)
+  (:printer byte ((op #b11111010)))
+  (:emitter
+   (emit-byte segment #b11111010)))
+
+;;; CMC -- Complement Carry Flag.
+;;;
+(define-instruction cmc (segment)
+  (:printer byte ((op #b11110101)))
+  (:emitter
+   (emit-byte segment #b11110101)))
+
+;;; LAHF -- Load AH into flags.
+;;;
+(define-instruction lahf (segment)
+  (:printer byte ((op #b10011111)))
+  (:emitter
+   (emit-byte segment #b10011111)))
+
+;;; POPF -- Pop flags.
+;;;
+(define-instruction popf (segment)
+  (:printer byte ((op #b10011101)))
+  (:emitter
+   (emit-byte segment #b10011101)))
+
+;;; PUSHF -- push flags.
+;;;
+(define-instruction pushf (segment)
+  (:printer byte ((op #b10011100)))
+  (:emitter
+   (emit-byte segment #b10011100)))
+
+;;; SAHF -- Store AH into flags.
+;;;
+(define-instruction sahf (segment)
+  (:printer byte ((op #b10011110)))
+  (:emitter
+   (emit-byte segment #b10011110)))
+
+;;; STC -- Set Carry Flag.
+;;;
+(define-instruction stc (segment)
+  (:printer byte ((op #b11111001)))
+  (:emitter
+   (emit-byte segment #b11111001)))
+
+;;; STD -- Set Direction Flag.
+;;;
+(define-instruction std (segment)
+  (:printer byte ((op #b11111101)))
+  (:emitter
+   (emit-byte segment #b11111101)))
+
+;;; STI -- Set Interrupt Enable Flag.
+;;;
+(define-instruction sti (segment)
+  (:printer byte ((op #b11111011)))
+  (:emitter
+   (emit-byte segment #b11111011)))
+
+
+
+;;;; Arithmetic
+
+(defun emit-random-arith-inst (name segment dst src opcode
+				    &optional allow-constants)
+  (let ((size (matching-operand-size dst src)))
+    (maybe-emit-operand-size-prefix segment size)
+    (cond
+     ((integerp src)
+      (cond ((and (not (eq size :byte)) (<= -128 src 127))
+	     (emit-byte segment #b10000011)
+	     (emit-ea segment dst opcode)
+	     (emit-byte segment src))
+	    ((accumulator-p dst)
+	     (emit-byte segment
+			(dpb opcode
+			     (byte 3 3)
+			     (if (eq size :byte)
+				 #b00000100
+				 #b00000101)))
+	     (emit-sized-immediate segment size src))
+	    (t
+	     (emit-byte segment (if (eq size :byte) #b10000000 #b10000001))
+	     (emit-ea segment dst opcode)
+	     (emit-sized-immediate segment size src))))
+     ((register-p src)
+      (emit-byte segment
+		 (dpb opcode
+		      (byte 3 3)
+		      (if (eq size :byte) #b00000000 #b00000001)))
+      (emit-ea segment dst (reg-tn-encoding src) allow-constants))
+     ((register-p dst)
+      (emit-byte segment
+		 (dpb opcode
+		      (byte 3 3)
+		      (if (eq size :byte) #b00000010 #b00000011)))
+      (emit-ea segment src (reg-tn-encoding dst) allow-constants))
+     (t
+      (error "Bogus operands to ~A" name)))))
+
+(eval-when (compile eval)
+  (defun arith-inst-printer-list (subop)
+    `((accum-imm ((op ,(dpb subop (byte 3 2) #b0000010))))
+      (reg/mem-imm ((op (#b1000000 ,subop))))
+      (reg/mem-imm ((op (#b1000001 ,subop))
+		    (imm nil :type signed-imm-byte)))
+      (reg-reg/mem-dir ((op ,(dpb subop (byte 3 1) #b000000))))))
+  )
+
+(define-instruction add (segment dst src)
+  (:printer-list
+   (arith-inst-printer-list #b000))
+  (:emitter
+   (emit-random-arith-inst "ADD" segment dst src #b000)))
+
+(define-instruction adc (segment dst src)
+  (:printer-list
+   (arith-inst-printer-list #b010))
+  (:emitter
+   (emit-random-arith-inst "ADC" segment dst src #b010)))
+
+(define-instruction sub (segment dst src)
+  (:printer-list
+   (arith-inst-printer-list #b101))
+  (:emitter
+   (emit-random-arith-inst "SUB" segment dst src #b101)))
+
+(define-instruction sbb (segment dst src)
+  (:printer-list
+   (arith-inst-printer-list #b011))
+  (:emitter
+   (emit-random-arith-inst "SBB" segment dst src #b011)))
+
+(define-instruction cmp (segment dst src)
+  (:printer-list
+   (arith-inst-printer-list #b111))
+  (:emitter
+   (emit-random-arith-inst "CMP" segment dst src #b111 t)))
+
+(define-instruction inc (segment dst)
+  ;; Register.
+  (:printer reg-no-width ((op #b01000)))
+  ;; Register/Memory
+  (:printer reg/mem ((op '(#b1111111 #b000))))
+  (:emitter
+   (let ((size (operand-size dst)))
+     (maybe-emit-operand-size-prefix segment size)
+     (cond ((and (not (eq size :byte)) (register-p dst))
+	    (emit-byte-with-reg segment #b01000 (reg-tn-encoding dst)))
+	   (t
+	    (emit-byte segment (if (eq size :byte) #b11111110 #b11111111))
+	    (emit-ea segment dst #b000))))))
+
+(define-instruction dec (segment dst)
+  ;; Register.
+  (:printer reg-no-width ((op #b01001)))
+  ;; Register/Memory
+  (:printer reg/mem ((op '(#b1111111 #b001))))
+  (:emitter
+   (let ((size (operand-size dst)))
+     (maybe-emit-operand-size-prefix segment size)
+     (cond ((and (not (eq size :byte)) (register-p dst))
+	    (emit-byte-with-reg segment #b01001 (reg-tn-encoding dst)))
+	   (t
+	    (emit-byte segment (if (eq size :byte) #b11111110 #b11111111))
+	    (emit-ea segment dst #b001))))))
+
+(define-instruction neg (segment dst)
+  (:printer reg/mem ((op '(#b1111011 #b011))))
+  (:emitter
+   (let ((size (operand-size dst)))
+     (maybe-emit-operand-size-prefix segment size)
+     (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
+     (emit-ea segment dst #b011))))
+
+(define-instruction aaa (segment)
+  (:printer byte ((op #b00110111)))
+  (:emitter
+   (emit-byte segment #b00110111)))
+
+(define-instruction aas (segment)
+  (:printer byte ((op #b00111111)))
+  (:emitter
+   (emit-byte segment #b00111111)))
+
+(define-instruction daa (segment)
+  (:printer byte ((op #b00100111)))
+  (:emitter
+   (emit-byte segment #b00100111)))
+
+(define-instruction das (segment)
+  (:printer byte ((op #b00101111)))
+  (:emitter
+   (emit-byte segment #b00101111)))
+
+(define-instruction mul (segment dst src)
+  (:printer accum-reg/mem ((op '(#b1111011 #b100))))
+  (:emitter
+   (let ((size (matching-operand-size dst src)))
+     (assert (accumulator-p dst))
+     (maybe-emit-operand-size-prefix segment size)
+     (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
+     (emit-ea segment src #b100))))
+
+(define-instruction imul (segment dst &optional src1 src2)
+  (:printer accum-reg/mem ((op '(#b1111011 #b101))))
+  (:printer ext-reg-reg/mem ((op #b1010111)))
+  (:printer reg-reg/mem ((op #b0110100) (width 1) (imm nil :type 'imm-word))
+	    '(:name :tab reg ", " reg/mem ", " imm))
+  (:printer reg-reg/mem ((op #b0110101) (width 1)
+			 (imm nil :type 'signed-imm-byte))
+	    '(:name :tab reg ", " reg/mem ", " imm))
+  (:emitter
+   (flet ((r/m-with-immed-to-reg (reg r/m immed)
+	    (let* ((size (matching-operand-size reg r/m))
+		   (sx (and (not (eq size :byte)) (<= -128 immed 127))))
+	      (maybe-emit-operand-size-prefix segment size)
+	      (emit-byte segment (if sx #b01101011 #b01101001))
+	      (emit-ea segment r/m (reg-tn-encoding reg))
+	      (if sx
+		  (emit-byte segment immed)
+		  (emit-sized-immediate segment size immed)))))
+     (cond (src2
+	    (r/m-with-immed-to-reg dst src1 src2))
+	   (src1
+	    (if (integerp src1)
+		(r/m-with-immed-to-reg dst dst src1)
+		(let ((size (matching-operand-size dst src1)))
+		  (maybe-emit-operand-size-prefix segment size)
+		  (emit-byte segment #b00001111)
+		  (emit-byte segment #b10101111)
+		  (emit-ea segment src1 (reg-tn-encoding dst)))))
+	   (t
+	    (let ((size (operand-size dst)))
+	      (maybe-emit-operand-size-prefix segment size)
+	      (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
+	      (emit-ea segment dst #b101)))))))
+
+(define-instruction div (segment dst src)
+  (:printer accum-reg/mem ((op '(#b1111011 #b110))))
+  (:emitter
+   (let ((size (matching-operand-size dst src)))
+     (assert (accumulator-p dst))
+     (maybe-emit-operand-size-prefix segment size)
+     (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
+     (emit-ea segment src #b110))))
+
+(define-instruction idiv (segment dst src)
+  (:printer accum-reg/mem ((op '(#b1111011 #b111))))
+  (:emitter
+   (let ((size (matching-operand-size dst src)))
+     (assert (accumulator-p dst))
+     (maybe-emit-operand-size-prefix segment size)
+     (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
+     (emit-ea segment src #b111))))
+
+(define-instruction aad (segment)
+  (:printer two-bytes ((op '(#b11010101 #b00001010))))
+  (:emitter
+   (emit-byte segment #b11010101)
+   (emit-byte segment #b00001010)))
+
+(define-instruction aam (segment)
+  (:printer two-bytes ((op '(#b11010100 #b00001010))))
+  (:emitter
+   (emit-byte segment #b11010100)
+   (emit-byte segment #b00001010)))
+
+;;; CBW -- Convert Byte to Word.  AX <- sign_xtnd(AL)
+;;;
+(define-instruction cbw (segment)
+  (:emitter
+   (maybe-emit-operand-size-prefix segment :word)
+   (emit-byte segment #b10011000)))
+
+;;; CWDE -- Convert Word To Double Word Extened.  EAX <- sign_xtnd(AX)
+;;;
+(define-instruction cwde (segment)
+  (:emitter
+   (maybe-emit-operand-size-prefix segment :dword)
+   (emit-byte segment #b10011000)))
+
+;;; CWD -- Convert Word to Double Word.  DX:AX <- sign_xtnd(AX)
+;;;
+(define-instruction cwd (segment)
+  (:emitter
+   (maybe-emit-operand-size-prefix segment :word)
+   (emit-byte segment #b10011001)))
+
+;;; CDQ -- Convert Double Word to Quad Word. EDX:EAX <- sign_xtnd(EAX)
+;;; 
+(define-instruction cdq (segment)
+  (:emitter
+   (maybe-emit-operand-size-prefix segment :dword)
+   (emit-byte segment #b10011001)))
+
+
+;;;; Logic.
+
+(defun emit-shift-inst (segment dst amount opcode)
+  (let ((size (operand-size dst)))
+    (maybe-emit-operand-size-prefix segment size)
+    (multiple-value-bind
+	(major-opcode immed)
+	(case amount
+	  (:cl (values #b11010010 nil))
+	  (1 (values #b11010000 nil))
+	  (t (values #b11000000 t)))
+      (emit-byte segment
+		 (if (eq size :byte) major-opcode (logior major-opcode 1)))
+      (emit-ea segment dst opcode)
+      (when immed
+	(emit-byte segment amount)))))
+
+(eval-when (compile eval)
+  (defun shift-inst-printer-list (subop)
+    `((reg/mem ((op (#b1101000 ,subop)))
+	       (:name :tab reg/mem ", 1"))
+      (reg/mem ((op (#b1101001 ,subop)))
+	       (:name :tab reg/mem ", " 'cl))
+      (reg/mem-imm ((op (#b1100000 ,subop))
+		    (imm nil :type signed-imm-byte))))))
+
+(define-instruction rol (segment dst amount)
+  (:printer-list
+   (shift-inst-printer-list #b000))
+  (:emitter
+   (emit-shift-inst segment dst amount #b000)))
+
+(define-instruction ror (segment dst amount)
+  (:printer-list
+   (shift-inst-printer-list #b001))
+  (:emitter
+   (emit-shift-inst segment dst amount #b001)))
+
+(define-instruction rcl (segment dst amount)
+  (:printer-list
+   (shift-inst-printer-list #b010))
+  (:emitter
+   (emit-shift-inst segment dst amount #b010)))
+
+(define-instruction rcr (segment dst amount)
+  (:printer-list
+   (shift-inst-printer-list #b011))
+  (:emitter
+   (emit-shift-inst segment dst amount #b011)))
+
+(define-instruction shl (segment dst amount)
+  (:printer-list
+   (shift-inst-printer-list #b100))
+  (:emitter
+   (emit-shift-inst segment dst amount #b100)))
+
+(define-instruction shr (segment dst amount)
+  (:printer-list
+   (shift-inst-printer-list #b101))
+  (:emitter
+   (emit-shift-inst segment dst amount #b101)))
+
+(define-instruction sar (segment dst amount)
+  (:printer-list
+   (shift-inst-printer-list #b111))
+  (:emitter
+   (emit-shift-inst segment dst amount #b111)))
+
+(defun emit-double-shift (segment opcode dst src amt)
+  (let ((size (matching-operand-size dst src)))
+    (when (eq size :byte)
+      (error "Double shifts can only be used with words."))
+    (maybe-emit-operand-size-prefix segment size)
+    (emit-byte segment #b00001111)
+    (emit-byte segment (dpb opcode (byte 1 3)
+			    (if (eq amt :cl) #b10100101 #b10100100)))
+    #+nil
+    (emit-ea segment dst src)
+    (emit-ea segment dst (reg-tn-encoding src))	; pw tries this
+    (unless (eq amt :cl)
+      (emit-byte segment amt))))
+
+(eval-when (compile eval)
+  (defun double-shift-inst-printer-list (op)
+    `(#+nil
+      (ext-reg-reg/mem-imm ((op ,(logior op #b100))
+			    (imm nil :type signed-imm-byte)))
+      (ext-reg-reg/mem ((op ,(logior op #b101)))
+	 (:name :tab reg/mem ", " 'cl)))))
+
+(define-instruction shld (segment dst src amt)
+  (:declare (type (or (member :cl) (mod 32)) amt))
+  (:printer-list (double-shift-inst-printer-list #b10100000))
+  (:emitter
+   (emit-double-shift segment #b0 dst src amt)))
+
+(define-instruction shrd (segment dst src amt)
+  (:declare (type (or (member :cl) (mod 32)) amt))
+  (:printer-list (double-shift-inst-printer-list #b10101000))
+  (:emitter
+   (emit-double-shift segment #b1 dst src amt)))
+
+(define-instruction and (segment dst src)
+  (:printer-list
+   (arith-inst-printer-list #b100))
+  (:emitter
+   (emit-random-arith-inst "AND" segment dst src #b100)))
+
+(define-instruction test (segment this that)
+  (:printer accum-imm ((op #b1010100)))
+  (:printer reg/mem-imm ((op '(#b1111011 #b000))))
+  (:printer reg-reg/mem ((op #b1000010)))
+  (:emitter
+   (let ((size (matching-operand-size this that)))
+     (maybe-emit-operand-size-prefix segment size)
+     (flet ((test-immed-and-something (immed something)
+	      (cond ((accumulator-p something)
+		     (emit-byte segment
+				(if (eq size :byte) #b10101000 #b10101001))
+		     (emit-sized-immediate segment size immed))
+		    (t
+		     (emit-byte segment
+				(if (eq size :byte) #b11110110 #b11110111))
+		     (emit-ea segment something #b000)
+		     (emit-sized-immediate segment size immed))))
+	    (test-reg-and-something (reg something)
+	      (emit-byte segment (if (eq size :byte) #b10000100 #b10000101))
+	      (emit-ea segment something (reg-tn-encoding reg))))
+       (cond ((integerp that)
+	      (test-immed-and-something that this))
+	     ((integerp this)
+	      (test-immed-and-something this that))
+	     ((register-p this)
+	      (test-reg-and-something this that))
+	     ((register-p that)
+	      (test-reg-and-something that this))
+	     (t
+	      (error "Bogus operans for TEST: ~S and ~S" this that)))))))
+
+(define-instruction or (segment dst src)
+  (:printer-list
+   (arith-inst-printer-list #b001))
+  (:emitter
+   (emit-random-arith-inst "OR" segment dst src #b001)))
+
+(define-instruction xor (segment dst src)
+  (:printer-list
+   (arith-inst-printer-list #b110))
+  (:emitter
+   (emit-random-arith-inst "XOR" segment dst src #b110)))
+
+(define-instruction not (segment dst)
+  (:printer reg/mem ((op '(#b1111011 #b010))))
+  (:emitter
+   (let ((size (operand-size dst)))
+     (maybe-emit-operand-size-prefix segment size)
+     (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
+     (emit-ea segment dst #b010))))
+
+
+;;;; String manipulation.
+
+(disassem:define-instruction-format (string-op 8
+				     :include 'simple
+				     :default-printer '(:name width)))
+
+(define-instruction cmps (segment size)
+  (:printer string-op ((op #b1010011)))
+  (:emitter
+   (maybe-emit-operand-size-prefix segment size)
+   (emit-byte segment (if (eq size :byte) #b10100110 #b10100111))))
+
+(define-instruction ins (segment acc)
+  (:printer string-op ((op #b0110110)))
+  (:emitter
+   (let ((size (operand-size acc)))
+     (assert (accumulator-p acc))
+     (maybe-emit-operand-size-prefix segment size)
+     (emit-byte segment (if (eq size :byte) #b01101100 #b01101101)))))
+
+(define-instruction lods (segment acc)
+  (:printer string-op ((op #b1010110)))
+  (:emitter
+   (let ((size (operand-size acc)))
+     (assert (accumulator-p acc))
+     (maybe-emit-operand-size-prefix segment size)
+     (emit-byte segment (if (eq size :byte) #b10101100 #b10101101)))))
+
+(define-instruction movs (segment size)
+  (:printer string-op ((op #b1010010)))
+  (:emitter
+   (maybe-emit-operand-size-prefix segment size)
+   (emit-byte segment (if (eq size :byte) #b10100100 #b10100101))))
+
+(define-instruction outs (segment acc)
+  (:printer string-op ((op #b0110111)))
+  (:emitter
+   (let ((size (operand-size acc)))
+     (assert (accumulator-p acc))
+     (maybe-emit-operand-size-prefix segment size)
+     (emit-byte segment (if (eq size :byte) #b01101110 #b01101111)))))
+
+(define-instruction scas (segment acc)
+  (:printer string-op ((op #b1010111)))
+  (:emitter
+   (let ((size (operand-size acc)))
+     (assert (accumulator-p acc))
+     (maybe-emit-operand-size-prefix segment size)
+     (emit-byte segment (if (eq size :byte) #b10101110 #b10101111)))))
+
+(define-instruction stos (segment acc)
+  (:printer string-op ((op #b1010101)))
+  (:emitter
+   (let ((size (operand-size acc)))
+     (assert (accumulator-p acc))
+     (maybe-emit-operand-size-prefix segment size)
+     (emit-byte segment (if (eq size :byte) #b10101010 #b10101011)))))
+
+(define-instruction xlat (segment)
+  (:printer byte ((op #b11010111)))
+  (:emitter
+   (emit-byte segment #b11010111)))
+
+(define-instruction rep (segment)
+  (:emitter
+   (emit-byte segment #b11110010)))
+
+(define-instruction repe (segment)
+  (:printer byte ((op #b11110011)))
+  (:emitter
+   (emit-byte segment #b11110011)))
+
+(define-instruction repne (segment)
+  (:printer byte ((op #b11110010)))
+  (:emitter
+   (emit-byte segment #b11110010)))
+
+
+;;;; Bit Manipulation
+
+(define-instruction bsf (segment dst src)
+  (:emitter
+   (let ((size (matching-operand-size dst src)))
+     (when (eq size :byte)
+       (error "Can't scan bytes: ~S" src))
+     (maybe-emit-operand-size-prefix segment size)
+     (emit-byte segment #b00001111)
+     (emit-byte segment #b10111100)
+     (emit-ea segment src (reg-tn-encoding dst)))))
+
+(define-instruction bsr (segment dst src)
+  (:emitter
+   (let ((size (matching-operand-size dst src)))
+     (when (eq size :byte)
+       (error "Can't scan bytes: ~S" src))
+     (maybe-emit-operand-size-prefix segment size)
+     (emit-byte segment #b00001111)
+     (emit-byte segment #b10111101)
+     (emit-ea segment src (reg-tn-encoding dst)))))
+
+(defun emit-bit-test-and-mumble (segment src index opcode)
+  (let ((size (operand-size src)))
+    (when (eq size :byte)
+      (error "Can't scan bytes: ~S" src))
+    (maybe-emit-operand-size-prefix segment size)
+    (emit-byte segment #b00001111)
+    (cond ((integerp index)
+	   (emit-byte segment #b10111010)
+	   (emit-ea segment src opcode)
+	   (emit-byte segment index))
+	  (t
+	   (emit-byte segment (dpb opcode (byte 3 3) #b10000011))
+	   (emit-ea segment src (reg-tn-encoding index))))))
+
+(define-instruction bt (segment src index)
+  (:emitter
+   (emit-bit-test-and-mumble segment src index #b100)))
+
+(define-instruction btc (segment src index)
+  (:emitter
+   (emit-bit-test-and-mumble segment src index #b111)))
+
+(define-instruction btr (segment src index)
+  (:emitter
+   (emit-bit-test-and-mumble segment src index #b110)))
+
+(define-instruction bts (segment src index)
+  (:emitter
+   (emit-bit-test-and-mumble segment src index #b101)))
+
+
+;;;; Control transfer.
+
+(eval-when (compile load eval)
+(defparameter condition-name-vec
+  (let ((vec (make-array 16 :initial-element nil)))
+    (dolist (cond conditions)
+      (when (null (aref vec (cdr cond)))
+	(setf (aref vec (cdr cond)) (car cond))))
+    vec)))
+
+(disassem:define-argument-type condition-code
+  :printer condition-name-vec)
+
+(disassem:define-argument-type displacement
+  :sign-extend t
+  :use-label #'offset-next)
+
+(disassem:define-instruction-format (short-cond-jump 16)
+  (op    :field (byte 4 4))
+  (cc	 :field (byte 4 0) :type 'condition-code)
+  (label :field (byte 8 8) :type 'displacement))
+
+(disassem:define-instruction-format (short-jump 16
+				     :default-printer '(:name :tab label))
+  (const :field (byte 4 4) :value #b1110)
+  (op	 :field (byte 4 0))
+  (label :field (byte 8 8) :type 'displacement))
+
+(disassem:define-instruction-format (near-cond-jump 16)
+  (op    :fields (list (byte 8 0) (byte 4 12)) :value '(#b00001111 #b1000))
+  (cc	 :field (byte 4 8) :type 'condition-code)
+  ;; The disassembler currently doesn't let you have an instruction > 32 bits
+  ;; long, so we fake it by using a prefilter to read the offset.
+  (label :type 'displacement :prefilter #'read-signed-imm-dword))
+
+(disassem:define-instruction-format (near-jump 8
+				     :default-printer '(:name :tab label))
+  (op    :field (byte 8 0))
+  ;; The disassembler currently doesn't let you have an instruction > 32 bits
+  ;; long, so we fake it by using a prefilter to read the address.
+  (label :type 'displacement :prefilter #'read-signed-imm-dword))
+
+
+(define-instruction call (segment where)
+  (:printer near-jump ((op #b11101000)))
+  (:printer reg/mem ((op '(#b1111111 #b010)) (width 1)))
+  (:emitter
+   (typecase where
+     (label
+      (emit-byte segment #b11101000)
+      (emit-back-patch segment 4
+		       #'(lambda (segment posn)
+			   (emit-dword segment
+				       (- (label-position where)
+					  (+ posn 4))))))
+     (fixup
+      (emit-byte segment #b11101000)
+      (emit-relative-fixup segment where))
+     (t
+      (emit-byte segment #b11111111)
+      (emit-ea segment where #b010)))))
+
+(defun emit-byte-displacement-backpatch (segment target)
+  (emit-back-patch segment 1
+		   #'(lambda (segment posn)
+		       (let ((disp (- (label-position target) (1+ posn))))
+			 (assert (<= -128 disp 127))
+			 (emit-byte segment disp)))))
+
+(define-instruction jmp (segment cond &optional where)
+  ;; conditional jumps
+  (:printer short-cond-jump ((op #b0111)) '('j cc :tab label))
+  (:printer near-cond-jump () '('j cc :tab label))
+  ;; unconditional jumps
+  (:printer short-jump ((op #b1011)))
+  (:printer near-jump ((op #b11101001)) )
+  (:printer reg/mem ((op '(#b1111111 #b100)) (width 1)))
+  (:emitter
+   (cond (where
+	  (emit-chooser
+	   segment 6 2
+	   #'(lambda (segment posn delta-if-after)
+	       (let ((disp (- (label-position where posn delta-if-after)
+			      (+ posn 2))))
+		 (when (<= -128 disp 127)
+		       (emit-byte segment
+				  (dpb (conditional-opcode cond)
+				       (byte 4 0)
+				       #b01110000))
+		       (emit-byte-displacement-backpatch segment where)
+		       t)))
+	   #'(lambda (segment posn)
+	       (let ((disp (- (label-position where) (+ posn 6))))
+		 (emit-byte segment #b00001111)
+		 (emit-byte segment
+			    (dpb (conditional-opcode cond)
+				 (byte 4 0)
+				 #b10000000))
+		 (emit-dword segment disp)))))
+	 ((label-p (setq where cond))
+	  (emit-chooser
+	   segment 5 0
+	   #'(lambda (segment posn delta-if-after)
+	       (let ((disp (- (label-position where posn delta-if-after)
+			      (+ posn 2))))
+		 (when (<= -128 disp 127)
+		       (emit-byte segment #b11101011)
+		       (emit-byte-displacement-backpatch segment where)
+		       t)))
+	   #'(lambda (segment posn)
+	       (let ((disp (- (label-position where) (+ posn 5))))
+		 (emit-byte segment #b11101001)
+		 (emit-dword segment disp))
+	       )))
+	 ((fixup-p where)
+	  (emit-byte segment #b11101001)
+	  (emit-relative-fixup segment where))
+	 (t
+	  (unless (or (ea-p where) (tn-p where))
+		  (error "Don't know what to do with ~A" where))
+	  (emit-byte segment #b11111111)
+	  (emit-ea segment where #b100)))))
+
+(define-instruction jmp-short (segment label)
+  (:emitter
+   (emit-byte segment #b11101011)
+   (emit-byte-displacement-backpatch segment label)))
+
+(define-instruction ret (segment &optional stack-delta)
+  (:printer byte ((op #b11000011)))
+  (:printer byte ((op #b11000010) (imm nil :type 'imm-word-16))
+	    '(:name :tab imm))
+  (:emitter
+   (cond (stack-delta
+	  (emit-byte segment #b11000010)
+	  (emit-word segment stack-delta))
+	 (t
+	  (emit-byte segment #b11000011)))))
+
+(define-instruction jecxz (segment target)
+  (:printer short-jump ((op #b0011)))
+  (:emitter
+   (emit-byte segment #b11100011)
+   (emit-byte-displacement-backpatch segment target)))
+
+(define-instruction loop (segment target)
+  (:printer short-jump ((op #b0010)))
+  (:emitter
+   (emit-byte segment #b11100010)	; pfw this was 11100011, or jecxz!!!!
+   (emit-byte-displacement-backpatch segment target)))
+
+(define-instruction loopz (segment target)
+  (:printer short-jump ((op #b0001)))
+  (:emitter
+   (emit-byte segment #b11100001)
+   (emit-byte-displacement-backpatch segment target)))
+
+(define-instruction loopnz (segment target)
+  (:printer short-jump ((op #b0000)))
+  (:emitter
+   (emit-byte segment #b11100000)
+   (emit-byte-displacement-backpatch segment target)))
+
+
+;;;; Conditional byte set.
+
+(disassem:define-instruction-format (cond-set 24
+				     :default-printer '('set cc :tab reg/mem))
+  (prefix :field (byte 8 0) :value #b00001111)
+  (op    :field (byte 4 12) :value #b1001)
+  (cc	 :field (byte 4 8) :type 'condition-code)
+  (reg/mem :fields (list (byte 2 22) (byte 3 16))
+	   :type 'byte-reg/mem)
+  (reg     :field (byte 3 19)	:value #b000))
+
+(define-instruction set (segment dst cond)
+  (:printer cond-set ())
+  (:emitter
+   (emit-byte segment #b00001111)
+   (emit-byte segment (dpb (conditional-opcode cond) (byte 4 0) #b10010000))
+   (emit-ea segment dst #b000)))
+
+
+;;;; Enter/Leave
+
+(disassem:define-instruction-format
+    (enter-format
+     24
+     :default-printer '(:name :tab disp (:unless (:constant 0) ", " level)))
+  (op :field (byte 8 0))
+  (disp :field (byte 16 8))
+  (level :field (byte 8 16)))
+
+(define-instruction enter (segment disp &optional (level 0))
+  (:declare (type (unsigned-byte 16) disp)
+	    (type (unsigned-byte 8) level))
+  (:emitter
+   (emit-byte segment #b11001000)
+   (emit-word segment disp)
+   (emit-byte segment level)))
+
+(define-instruction leave (segment)
+  (:printer byte ((op #b11001001)))
+  (:emitter
+   (emit-byte segment #b11001001)))
+
+
+;;;; Interrupt instructions.
+
+(disassem:define-instruction-format
+ (break 16 :default-printer '(:name :tab code))
+ (op :field (byte 8 0) :value #b11001100)
+ (code :field (byte 8 8)))
+
+(define-emitter emit-break-inst 16
+  (byte 8 0) (byte 8 8))
+
+(defun snarf-error-junk (sap offset &optional length-only)
+  (let* ((length (system:sap-ref-8 sap offset))
+         (vector (make-array length :element-type '(unsigned-byte 8))))
+    (declare (type system:system-area-pointer sap)
+             (type (unsigned-byte 8) length)
+             (type (simple-array (unsigned-byte 8) (*)) vector))
+    (cond (length-only
+           (values 0 (1+ length) nil nil))
+          (t
+           (kernel:copy-from-system-area sap (* byte-bits (1+ offset))
+                                         vector (* word-bits
+                                                   vector-data-offset)
+                                         (* length byte-bits))
+           (collect ((sc-offsets)
+                     (lengths))
+             (lengths 1)                ; the length byte
+             (let* ((index 0)
+                    (error-number (c::read-var-integer vector index)))
+               (lengths index)
+               (loop
+                 (when (>= index length)
+                   (return))
+                 (let ((old-index index))
+                   (sc-offsets (c::read-var-integer vector index))
+                   (lengths (- index old-index))))
+               (values error-number
+                       (1+ length)
+                       (sc-offsets)
+                       (lengths))))))))
+
+(defmacro break-cases (breaknum &body cases)
+  (let ((bn-temp (gensym)))
+    (collect ((clauses))
+      (dolist (case cases)
+        (clauses `((= ,bn-temp ,(car case)) ,@(cdr case))))
+      `(let ((,bn-temp ,breaknum))
+         (cond ,@(clauses))))))
+
+(defun break-control (chunk inst stream dstate)
+  (declare (ignore inst))
+  (flet ((nt (x) (if stream (disassem:note x dstate))))
+    (case (break-code chunk dstate)
+      (#.vm:error-trap
+       (nt "Error trap")
+       (disassem:handle-break-args #'snarf-error-junk stream dstate))
+      (#.vm:cerror-trap
+       (nt "Cerror trap")
+       (disassem:handle-break-args #'snarf-error-junk stream dstate))
+      (#.vm:breakpoint-trap
+       (nt "Breakpoint trap"))
+      (#.vm:pending-interrupt-trap
+       (nt "Pending interrupt trap"))
+      (#.vm:halt-trap
+       (nt "Halt trap"))
+      (#.vm:function-end-breakpoint-trap
+       (nt "Function end breakpoint trap"))
+    )))
+
+(define-instruction break (segment code)
+  (:declare (type (unsigned-byte 8) code))
+  (:printer break ((op #b11001100))
+	    '(:name :tab code)
+	    :control #'break-control )
+  (:emitter
+   (emit-break-inst segment #b11001100 code)))
+
+(define-instruction int (segment number)
+  (:declare (type (unsigned-byte 8) number))
+  (:emitter
+   (etypecase number
+     ((member 3)
+      (emit-byte segment #b11001100))
+     ((unsigned-byte 8)
+      (emit-byte segment #b11001101)
+      (emit-byte segment number)))))
+
+(define-instruction into (segment)
+  (:printer byte ((op #b11001110)))
+  (:emitter
+   (emit-byte segment #b11001110)))
+
+(define-instruction bound (segment reg bounds)
+  (:emitter
+   (let ((size (matching-operand-size reg bounds)))
+     (when (eq size :byte)
+       (error "Can't bounds-test bytes: ~S" reg))
+     (maybe-emit-operand-size-prefix segment size)
+     (emit-byte segment #b01100010)
+     (emit-ea segment bounds (reg-tn-encoding reg)))))
+
+(define-instruction iret (segment)
+  (:printer byte ((op #b11001111)))
+  (:emitter
+   (emit-byte segment #b11001111)))
+
+
+;;;; Processor control
+
+(define-instruction hlt (segment)
+  (:printer byte ((op #b11110100)))
+  (:emitter
+   (emit-byte segment #b11110100)))
+
+(define-instruction nop (segment)
+  (:printer byte ((op #b10010000)))
+  (:emitter
+   (emit-byte segment #b10010000)))
+
+(define-instruction wait (segment)
+  (:printer byte ((op #b10011011)))
+  (:emitter
+   (emit-byte segment #b10011011)))
+
+(define-instruction lock (segment)
+  (:printer byte ((op #b11110000)))
+  (:emitter
+   (emit-byte segment #b11110000)))
+
+
+
+;;;; Random hackery
+
+(define-instruction byte (segment byte)
+  (:emitter
+   (emit-byte segment byte)))
+
+(define-instruction word (segment word)
+  (:emitter
+   (emit-word segment word)))
+
+(define-instruction dword (segment dword)
+  (:emitter
+   (emit-dword segment dword)))
+
+(defun emit-header-data (segment type)
+  (emit-back-patch
+   segment 4
+   #'(lambda (segment posn)
+       (emit-dword segment
+		  (logior type
+			  (ash (+ posn (component-header-length))
+			       (- type-bits word-shift)))))))
+
+(define-instruction function-header-word (segment)
+  (:emitter
+   (emit-header-data segment function-header-type)))
+
+(define-instruction lra-header-word (segment)
+  (:emitter
+   (emit-header-data segment return-pc-header-type)))
+
+;;; ----------------------------------------------------------------
+;;; added by jrd.  fp instructions
+;;;
+
+;;;
+;;; we treat the single-precision and double-precision variants
+;;; as separate instructions
+;;;
+
+;;;
+;;; load single to st(0)
+;;;
+(define-instruction fld (segment source)
+  (:printer floating-point ((op '(#b001 #b000))))
+  (:emitter
+    (emit-byte segment #b11011001)
+    (emit-fp-op segment source #b000)))
+
+;;;
+;;; load double to st(0)
+;;;
+(define-instruction fldd (segment source)
+  (:printer floating-point ((op '(#b101 #b000))))
+  (:printer floating-point-fp ((op '(#b001 #b000))))
+  (:emitter
+   (if (fp-reg-tn-p source)
+       (emit-byte segment #b11011001)
+     (emit-byte segment #b11011101))
+    (emit-fp-op segment source #b000)))
+
+;;;
+;;; store single from st(0)
+;;;
+(define-instruction fst (segment dest)
+  (:printer floating-point ((op '(#b001 #b010))))
+  (:emitter 
+    (if (fp-reg-tn-p dest)
+	(progn 
+	  (emit-byte segment #b11011101)
+	  (emit-fp-op segment dest #b010))
+	(progn
+	  (emit-byte segment #b11011001)
+	  (emit-fp-op segment dest #b010)))))
+
+;;;
+;;; store double from st(0)
+;;;
+(define-instruction fstd (segment dest)
+  (:printer floating-point ((op '(#b101 #b010))))
+  (:printer floating-point-fp ((op '(#b101 #b010))))
+  (:emitter 
+   (if (fp-reg-tn-p dest)
+       (progn 
+	 (emit-byte segment #b11011101)
+	 (emit-fp-op segment dest #b010))
+       (progn
+	 (emit-byte segment #b11011101)
+	 (emit-fp-op segment dest #b010)))))
+
+;;; Arithmetic ops are all done with at least one operand at top of
+;;; stack. The other operand is is another register or a 32/64 bit
+;;; memory loc.
+
+;;; dtc: I've tried to follow the Intel ASM386 conventions, but note
+;;; that these conflict with the Gdb conventions for binops. To reduce
+;;; the confusion I've added comments showing the mathamatical
+;;; operation and the two syntaxes. By the ASM386 convention the
+;;; instruction syntax is:
+;;;
+;;;      Fop Source
+;;; or   Fop Destination, Source
+;;;
+;;; If only one operand is given then it is the source and the
+;;; destination is ST(0). There are reversed forms of the fsub and
+;;; fdiv instructions inducated by an 'R' suffix.
+;;;
+;;; The mathematical operation for the non-reverse form is always:
+;;;     destination = destination op source
+;;;
+;;; For the reversed form it is:
+;;;     destination = source op destination
+;;;
+;;; The instructions below only accept one operand at present which is
+;;; usually the source. I've hack in extra instructions to implement
+;;; the fops with a ST(i) destination, these have a -sti suffix and
+;;; the operand is the destination with the source being ST(0).
+
+;;;
+;;; Add single
+;;; st(0) = st(0) + memory or st(i)
+;;;
+(define-instruction fadd (segment source)
+  (:printer floating-point ((op '(#b000 #b000))))
+  (:emitter
+    (emit-byte segment #b11011000)
+    (emit-fp-op segment source #b000)))
+
+;;;
+;;; Add double
+;;; st(0) = st(0) + memory or st(i)
+;;;
+(define-instruction faddd (segment source)
+  (:printer floating-point ((op '(#b100 #b000))))
+  (:printer floating-point-fp ((op '(#b000 #b000))))
+  (:emitter
+   (if (fp-reg-tn-p source)
+       (emit-byte segment #b11011000)
+     (emit-byte segment #b11011100))
+   (emit-fp-op segment source #b000)))
+
+;;;
+;;; Add double destination st(i)
+;;; st(i) = st(0) + st(i)
+;;;
+(define-instruction fadd-sti (segment destination)
+  (:printer floating-point-fp ((op '(#b100 #b000))))
+  (:emitter
+   (assert (fp-reg-tn-p destination))
+   (emit-byte segment #b11011100)
+   (emit-fp-op segment destination #b000)))
+;;; With pop
+(define-instruction faddp-sti (segment destination)
+  (:printer floating-point-fp ((op '(#b110 #b000))))
+  (:emitter
+   (assert (fp-reg-tn-p destination))
+   (emit-byte segment #b11011110)
+   (emit-fp-op segment destination #b000)))
+
+;;;
+;;; Subtract single
+;;; st(0) = st(0) - memory or st(i)
+;;;
+(define-instruction fsub (segment source)
+  (:printer floating-point ((op '(#b000 #b100))))
+  (:emitter 
+    (emit-byte segment #b11011000)
+    (emit-fp-op segment source #b100)))
+
+;;;
+;;; Subtract single, reverse
+;;; st(0) = memory or st(i) - st(0)
+;;;
+(define-instruction fsubr (segment source)
+  (:printer floating-point ((op '(#b000 #b101))))
+  (:emitter 
+    (emit-byte segment #b11011000)
+    (emit-fp-op segment source #b101)))
+
+;;;
+;;; Subtract double
+;;; st(0) = st(0) - memory or st(i)
+;;;
+(define-instruction fsubd (segment source)
+  (:printer floating-point ((op '(#b100 #b100))))
+  (:printer floating-point-fp ((op '(#b000 #b100))))
+  (:emitter 
+   (if (fp-reg-tn-p source)
+       (emit-byte segment #b11011000)
+     (emit-byte segment #b11011100))
+   (emit-fp-op segment source #b100)))
+
+;;;
+;;; Subtract double, reverse
+;;; st(0) = memory or st(i) - st(0)
+;;;
+(define-instruction fsubrd (segment source)
+  (:printer floating-point ((op '(#b100 #b101))))
+  (:printer floating-point-fp ((op '(#b000 #b101))))
+  (:emitter 
+   (if (fp-reg-tn-p source)
+       (emit-byte segment #b11011000)
+     (emit-byte segment #b11011100))
+   (emit-fp-op segment source #b101)))
+
+;;;
+;;; Subtract double, destination st(i)
+;;; st(i) = st(i) - st(0)
+;;;
+;;; ASM386 syntax: FSUB ST(i), ST
+;;; Gdb    syntax: fsubr %st,%st(i)
+;;;
+(define-instruction fsub-sti (segment destination)
+  (:printer floating-point-fp ((op '(#b100 #b101))))
+  (:emitter 
+   (assert (fp-reg-tn-p destination))
+   (emit-byte segment #b11011100)
+   (emit-fp-op segment destination #b101)))
+;;; With a pop
+(define-instruction fsubp-sti (segment destination)
+  (:printer floating-point-fp ((op '(#b110 #b101))))
+  (:emitter 
+   (assert (fp-reg-tn-p destination))
+   (emit-byte segment #b11011110)
+   (emit-fp-op segment destination #b101)))
+
+;;;
+;;; Subtract double, reverse, destination st(i)
+;;; st(i) = st(0) - st(i)
+;;;
+;;; ASM386 syntax: FSUBR ST(i), ST
+;;; Gdb    syntax: fsub %st,%st(i)
+;;;
+(define-instruction fsubr-sti (segment destination)
+  (:printer floating-point-fp ((op '(#b100 #b100))))
+  (:emitter 
+   (assert (fp-reg-tn-p destination))
+   (emit-byte segment #b11011100)
+   (emit-fp-op segment destination #b100)))
+;;; With a pop
+(define-instruction fsubrp-sti (segment destination)
+  (:printer floating-point-fp ((op '(#b110 #b100))))
+  (:emitter 
+   (assert (fp-reg-tn-p destination))
+   (emit-byte segment #b11011110)
+   (emit-fp-op segment destination #b100)))
+
+
+;;;
+;;; Multiply single
+;;; st(0) = st(0) * memory or st(i)
+;;;
+(define-instruction fmul (segment source)
+  (:printer floating-point ((op '(#b000 #b001))))
+  (:emitter 
+    (emit-byte segment #b11011000)
+    (emit-fp-op segment source #b001)))
+
+;;;
+;;; Multiply double
+;;; st(0) = st(0) * memory or st(i)
+;;;
+(define-instruction fmuld (segment source)
+  (:printer floating-point ((op '(#b100 #b001))))
+  (:printer floating-point-fp ((op '(#b000 #b001))))
+  (:emitter 
+   (if (fp-reg-tn-p source)
+       (emit-byte segment #b11011000)
+     (emit-byte segment #b11011100))
+   (emit-fp-op segment source #b001)))
+
+;;;
+;;; Multiply double, destination st(i)
+;;; st(i) = st(i) * st(0)
+;;;
+(define-instruction fmul-sti (segment destination)
+  (:printer floating-point-fp ((op '(#b100 #b001))))
+  (:emitter 
+   (assert (fp-reg-tn-p destination))
+   (emit-byte segment #b11011100)
+   (emit-fp-op segment destination #b001)))
+
+
+
+;;;
+;;; Divide single
+;;; st(0) = st(0) / memory or st(i)
+;;;
+(define-instruction fdiv (segment source)
+  (:printer floating-point ((op '(#b000 #b110))))
+  (:emitter 
+    (emit-byte segment #b11011000)
+    (emit-fp-op segment source #b110)))
+
+;;;
+;;; Divide single, reverse
+;;; st(0) = memory or st(i) / st(0)
+;;;
+(define-instruction fdivr (segment source)
+  (:printer floating-point ((op '(#b000 #b111))))
+  (:emitter 
+    (emit-byte segment #b11011000)
+    (emit-fp-op segment source #b111)))
+
+;;;
+;;; Divide double
+;;; st(0) = st(0) / memory or st(i)
+;;;
+(define-instruction fdivd (segment source)
+  (:printer floating-point ((op '(#b100 #b110))))
+  (:printer floating-point-fp ((op '(#b000 #b110))))
+  (:emitter 
+   (if (fp-reg-tn-p source)
+       (emit-byte segment #b11011000)
+     (emit-byte segment #b11011100))
+   (emit-fp-op segment source #b110)))
+
+;;;
+;;; Divide double, reverse
+;;; st(0) = memory or st(i) / st(0)
+;;;
+(define-instruction fdivrd (segment source)
+  (:printer floating-point ((op '(#b100 #b111))))
+  (:printer floating-point-fp ((op '(#b000 #b111))))
+  (:emitter 
+   (if (fp-reg-tn-p source)
+       (emit-byte segment #b11011000)
+     (emit-byte segment #b11011100))
+   (emit-fp-op segment source #b111)))
+
+;;;
+;;; Divide double, destination st(i)
+;;; st(i) = st(i) / st(0)
+;;;
+;;; ASM386 syntax: FDIV ST(i), ST
+;;; Gdb    syntax: fdivr %st,%st(i)
+;;;
+(define-instruction fdiv-sti (segment destination)
+  (:printer floating-point-fp ((op '(#b100 #b111))))
+  (:emitter 
+   (assert (fp-reg-tn-p destination))
+   (emit-byte segment #b11011100)
+   (emit-fp-op segment destination #b111)))
+
+;;;
+;;; Divide double, reverse, destination st(i)
+;;; st(i) = st(0) / st(i)
+;;;
+;;; ASM386 syntax: FDIVR ST(i), ST
+;;; Gdb    syntax: fdiv %st,%st(i)
+;;;
+(define-instruction fdivr-sti (segment destination)
+  (:printer floating-point-fp ((op '(#b100 #b110))))
+  (:emitter 
+   (assert (fp-reg-tn-p destination))
+   (emit-byte segment #b11011100)
+   (emit-fp-op segment destination #b110)))
+
+;;;
+;;; exchange fr0 with fr(n).  no double variant
+;;;
+(define-instruction fxch (segment source)
+  (:printer floating-point-fp ((op '(#b001 #b001))))
+  (:emitter 
+    (unless (and (tn-p source)
+		 (eq (sb-name (sc-sb (tn-sc source))) 'float-registers))
+      (lisp:break))
+    (emit-byte segment #b11011001)
+    (emit-fp-op segment source #b001)))
+;;;
+;;; added by pfw
+;;;
+;;;
+;;; push 32-bit integer to st0
+(define-instruction fild(segment source)
+  (:printer floating-point ((op '(#b011 #b000))))
+  (:emitter
+   (emit-byte segment #b11011011)
+   (emit-fp-op segment source #b000)))
+;;;
+;;; store 32-bit integer
+;;;
+(define-instruction fist (segment dest)
+  (:printer floating-point ((op '(#b011 #b010))))
+  (:emitter
+   (emit-byte segment #b11011011)
+   (emit-fp-op segment dest #b010)))
+
+;;; Store and pop 32-bit interger
+(define-instruction fistp (segment dest)
+  (:printer floating-point ((op '(#b011 #b011))))
+  (:emitter
+   (emit-byte segment #b11011011)
+   (emit-fp-op segment dest #b011)))
+;;;
+;;; store single from st(0) and pop
+;;;
+(define-instruction fstp (segment dest)
+  (:printer floating-point ((op '(#b001 #b011))))
+  (:printer floating-point-fp ((op '(#b101 #b011))))
+  (:emitter 
+    (if (fp-reg-tn-p dest)
+	(progn 
+	  (emit-byte segment #b11011101)
+	  (emit-fp-op segment dest #b011))
+	(progn
+	  (emit-byte segment #b11011001)
+	  (emit-fp-op segment dest #b011)))))
+;;;
+;;; decrement stack-top pointer
+;;;
+(define-instruction fdecstp (segment)
+  (:printer floating-point-no ((op #b10110)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11110110)))
+;;;
+;;; increment stack-top pointer
+;;;
+(define-instruction fincstp (segment)
+  (:printer floating-point-no ((op #b10111)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11110111)))
+;;;
+;;; free fp register
+;;;
+(define-instruction ffree (segment dest)
+  (:printer floating-point-fp ((op '(#b101 #b000))))
+  (:emitter
+   (emit-byte segment #b11011101)
+   (emit-fp-op segment dest #b000)))
+
+(define-instruction fabs (segment)
+  (:printer floating-point-no ((op #b00001)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11100001)))
+
+(define-instruction fchs (segment)
+  (:printer floating-point-no ((op #b00000)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11100000)))
+  
+(define-instruction frndint(segment)
+  (:printer floating-point-no ((op #b11100)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11111100)))
+
+;;;
+;;; Initialize NPX
+;;;
+(define-instruction fninit(segment)
+  (:printer floating-point-5 ((op #b00011)))
+  (:emitter
+   (emit-byte segment #b11011011)
+   (emit-byte segment #b11100011)))
+
+;;;
+;;; Store Status Word to AX
+;;;
+(define-instruction fnstsw(segment)
+  (:printer floating-point-st ((op #b00000)))
+  (:emitter
+   (emit-byte segment #b11011111)
+   (emit-byte segment #b11100000)))
+
+;;;
+;;; Load Control Word
+;;;
+;;; src must be a memory location
+(define-instruction fldcw(segment src)
+  (:printer floating-point ((op '(#b001 #b101))))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-fp-op segment src #b101)))
+
+;;;
+;;; Store Control Word
+;;;
+(define-instruction fnstcw(segment dst)
+  (:printer floating-point ((op '(#b001 #b111))))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-fp-op segment dst #b111)))
+;;;
+;;; Store FP Environment
+;;;
+(define-instruction fstenv(segment dst)
+  (:printer floating-point ((op '(#b001 #b110))))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-fp-op segment dst #b110)))
+;;;
+;;; Retore FP Environment
+;;;
+(define-instruction fldenv(segment src)
+  (:printer floating-point ((op '(#b001 #b100))))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-fp-op segment src #b100)))
+;;;
+;;; Save FP State
+;;;
+(define-instruction fsave(segment dst)
+  (:printer floating-point ((op '(#b101 #b110))))
+  (:emitter
+   (emit-byte segment #b11011101)
+   (emit-fp-op segment dst #b110)))
+;;;
+;;; Restore FP State
+;;;
+(define-instruction frstor(segment src)
+  (:printer floating-point ((op '(#b101 #b100))))
+  (:emitter
+   (emit-byte segment #b11011101)
+   (emit-fp-op segment src #b100)))
+;;;
+;;; Clear exceptions
+;;;
+(define-instruction fnclex(segment)
+  (:printer floating-point-5 ((op #b00010)))
+  (:emitter
+   (emit-byte segment #b11011011)
+   (emit-byte segment #b11100010)))
+
+;;;
+;;; Comparison
+;;;
+(define-instruction fcom(segment src)
+  (:printer floating-point ((op '(#b000 #b010))))
+  (:emitter
+   (emit-byte segment #b11011000)
+   (emit-fp-op segment src #b010)))
+
+(define-instruction fcomd(segment src)
+  (:printer floating-point ((op '(#b100 #b010))))
+  (:printer floating-point-fp ((op '(#b000 #b010))))
+  (:emitter
+   (if (fp-reg-tn-p src)
+       (emit-byte segment #b11011000)
+     (emit-byte segment #b11011100))
+   (emit-fp-op segment src #b010)))
+
+;;;
+;;; Unordered comparison
+;;;
+(define-instruction fucom(segment src)
+  ;; XX Printer conflicts with frstor
+  ;; (:printer floating-point ((op '(#b101 #b100))))
+  (:emitter
+   (assert (fp-reg-tn-p src))
+   (emit-byte segment #b11011101)
+   (emit-fp-op segment src #b100)))
+
+(define-instruction ftst (segment)
+  (:printer floating-point-no ((op #b00100)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11100100)))
+
+;;;
+;;; 80387 Specials
+;;;
+;;;
+(define-instruction fsqrt(segment)
+  (:printer floating-point-no ((op #b11010)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11111010)))
+
+(define-instruction fscale(segment)
+  (:printer floating-point-no ((op #b11101)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11111101)))
+
+(define-instruction fxtract(segment)
+  (:printer floating-point-no ((op #b10100)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11110100)))
+
+(define-instruction fsin(segment)
+  (:printer floating-point-no ((op #b11110)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11111110)))
+
+(define-instruction fcos(segment)
+  (:printer floating-point-no ((op #b11111)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11111111)))
+
+(define-instruction fprem1(segment)
+  (:printer floating-point-no ((op #b10101)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11110101)))
+
+(define-instruction fprem(segment)
+  (:printer floating-point-no ((op #b11000)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11111000)))
+
+(define-instruction fxam (segment)
+  (:printer floating-point-no ((op #b00101)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11100101)))
+
+;;; These do push/pop to stack and need special handling
+;;; in any VOPs that use them. See the book.
+
+;; st0 <- st1*log2(st0)
+(define-instruction fyl2x(segment)	; POPS STACK
+  (:printer floating-point-no ((op #b10001)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11110001)))
+
+(define-instruction fyl2xp1(segment)
+  (:printer floating-point-no ((op #b11001)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11111001)))
+
+(define-instruction f2xm1(segment)
+  (:printer floating-point-no ((op #b10000)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11110000)))
+
+(define-instruction fptan(segment)	; st(0) <- 1; st(1) <- tan
+  (:printer floating-point-no ((op #b10010)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11110010)))
+
+(define-instruction fpatan(segment)	; POPS STACK
+  (:printer floating-point-no ((op #b10011)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11110011)))
+
+;;; load constant
+
+(define-instruction fldz(segment)
+  (:printer floating-point-no ((op #b01110)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11101110)))
+
+(define-instruction fld1(segment)
+  (:printer floating-point-no ((op #b01000)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11101000)))
+
+(define-instruction fldpi(segment)
+  (:printer floating-point-no ((op #b01011)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11101011)))
+
+(define-instruction fldl2t(segment)
+  (:printer floating-point-no ((op #b01001)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11101001)))
+
+(define-instruction fldl2e(segment)
+  (:printer floating-point-no ((op #b01010)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11101010)))
+
+(define-instruction fldlg2(segment)
+  (:printer floating-point-no ((op #b01100)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11101100)))
+
+(define-instruction fldln2(segment)
+  (:printer floating-point-no ((op #b01101)))
+  (:emitter
+   (emit-byte segment #b11011001)
+   (emit-byte segment #b11101101)))
diff --git a/compiler/x86/macros.lisp b/compiler/x86/macros.lisp
new file mode 100644
index 000000000..314008ba7
--- /dev/null
+++ b/compiler/x86/macros.lisp
@@ -0,0 +1,305 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/macros.lisp,v 1.1 1997/01/18 14:31:22 ram Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the a bunch of handy macros for the x86.
+;;;
+;;; Written by William Lott.
+;;;
+;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
+;;;
+(in-package :x86)
+
+
+;;; We can load/store into fp registers through the top of
+;;; stack %st(0) (fr0 here). Loads imply a push to an empty register
+;;; which then changes all the reg numbers. These macros help manage that.
+
+;;; Use this when don't have to load anything. It preserves old tos value
+;;; But probably destroys tn with operation.
+(defmacro with-tn@fp-top((tn) &body body)
+  `(progn
+    (unless (zerop (tn-offset ,tn))
+      (inst fxch ,tn))
+    ,@body
+    (unless (zerop (tn-offset ,tn))
+      (inst fxch ,tn))))
+
+;;; Use this to prepare for load of new value.
+(defmacro with-empty-tn@fp-top((tn) &body body)
+  `(progn
+    (inst fstp ,tn)
+    ,@body
+    (unless (zerop (tn-offset ,tn))
+      (inst fxch ,tn))))		; save into new dest and restore st(0)
+
+
+;;; Instruction-like macros.
+(defmacro move (dst src)
+  "Move SRC into DST unless they are location=."
+  (once-only ((n-dst dst)
+	      (n-src src))
+    `(unless (location= ,n-dst ,n-src)
+       (inst mov ,n-dst ,n-src))))
+
+(defmacro make-ea-for-object-slot (ptr slot lowtag)
+  `(make-ea :dword :base ,ptr :disp (- (* ,slot word-bytes) ,lowtag)))
+
+(defmacro loadw (value ptr &optional (slot 0) (lowtag 0))
+  `(inst mov ,value (make-ea-for-object-slot ,ptr ,slot ,lowtag)))
+
+(defmacro storew (value ptr &optional (slot 0) (lowtag 0))
+  (once-only ((value value))
+    `(inst mov (make-ea-for-object-slot ,ptr ,slot ,lowtag) ,value)))
+
+(defmacro pushw (ptr &optional (slot 0) (lowtag 0))
+  `(inst push (make-ea-for-object-slot ,ptr ,slot ,lowtag)))
+
+(defmacro popw (ptr &optional (slot 0) (lowtag 0))
+  `(inst pop (make-ea-for-object-slot ,ptr ,slot ,lowtag)))
+
+
+;;;; Macros to generate useful values.
+
+(defmacro load-symbol (reg symbol)
+  `(inst mov ,reg (+ nil-value (static-symbol-offset ,symbol))))
+
+(defmacro load-symbol-value (reg symbol)
+  `(inst mov ,reg
+	 (make-ea :dword
+		  :disp (+ nil-value
+			   (static-symbol-offset ',symbol)
+			   (ash symbol-value-slot word-shift)
+			   (- other-pointer-type)))))
+
+(defmacro store-symbol-value (reg symbol)
+  `(inst mov
+	 (make-ea :dword
+		  :disp (+ nil-value
+			   (static-symbol-offset ',symbol)
+			   (ash symbol-value-slot word-shift)
+			   (- other-pointer-type)))
+	 ,reg))
+
+
+(defmacro load-type (target source &optional (offset 0))
+  "Loads the type bits of a pointer into target independent of
+   byte-ordering issues."
+  (once-only ((n-target target)
+	      (n-source source)
+	      (n-offset offset))
+    (ecase (backend-byte-order *target-backend*)
+      (:little-endian
+       `(inst mov ,n-target
+	      (make-ea :byte :base ,n-source :disp ,n-offset)))
+      (:big-endian
+       `(inst mov ,n-target
+	      (make-ea :byte :base ,n-source :disp (+ ,n-offset 3)))))))
+
+
+;;;; Allocation helpers
+
+#-cgc
+(defmacro with-allocation ((alloc) &body body)
+  `(progn
+    (load-symbol-value ,alloc lisp::*allocation-pointer*)
+    ,@body
+    (store-symbol-value ,alloc lisp::*allocation-pointer*)
+    ))
+
+#-cgc
+(defmacro with-fixed-allocation ((result alloc type-code size) &body body)
+  `(with-allocation (,alloc)
+     (inst lea ,result
+	   (make-ea :byte :base ,alloc :disp other-pointer-type))
+     (storew (logior (ash (1- ,size) vm:type-bits) ,type-code) ,alloc)
+     (inst add ,alloc (pad-data-block ,size))
+     ,@body))
+
+;;; Support for conservative GC and allocator. Call into C...
+#+cgc
+(defmacro with-cgc-allocation((alloc-tn size) &body body)
+  `(let ((stack-offset (- 28 (* 2 (tn-offset ,alloc-tn)))))
+    ;; I need to save all regs because C might trash a few.
+    ;; This works because register offsets are assigned in the
+    ;; same order that PUSHA pushes them on the stack.
+    (inst pusha)			; Save all registers
+    (inst push ,size)			; load the size param for C
+    (inst call (make-fixup (extern-alien-name "alloc") :foreign))
+    (inst add esp-tn word-bytes)	; pop off the arg
+    (inst mov (make-ea :dword		; move result over saved alloc-tn
+	       :base esp-tn :disp stack-offset) eax-tn)
+    (inst popa)				; restore all regs 
+    ,@body))
+
+#+cgc
+(defmacro with-fixed-allocation ((result alloc type-code size) &body body)
+  `(with-cgc-allocation (,alloc (pad-data-block ,size))
+    (inst lea ,result (make-ea :byte :base ,alloc :disp other-pointer-type))
+    (storew (logior (ash (1- ,size) vm:type-bits) ,type-code) ,alloc)
+    ,@body))
+
+
+
+
+;;;; Error Code
+
+(defvar *adjustable-vectors* nil)
+
+(defmacro with-adjustable-vector ((var) &rest body)
+  `(let ((,var (or (pop *adjustable-vectors*)
+		   (make-array 16
+			       :element-type '(unsigned-byte 8)
+			       :fill-pointer 0
+			       :adjustable t))))
+     (setf (fill-pointer ,var) 0)
+     (unwind-protect
+	 (progn
+	   ,@body)
+       (push ,var *adjustable-vectors*))))
+
+(eval-when (compile load eval)
+  (defun emit-error-break (vop kind code values)
+    (let ((vector (gensym)))
+      `((inst int 3)				; i386 breakpoint instruction
+	;; The return PC points here; note the location for the debugger.
+	(let ((vop ,vop))
+  	  (when vop
+		(note-this-location vop :internal-error)))
+	(inst byte ,kind)			; eg trap_Xyyy
+	(with-adjustable-vector (,vector)	; interr arguments
+	  (write-var-integer (error-number-or-lose ',code) ,vector)
+	  ,@(mapcar #'(lambda (tn)
+			`(let ((tn ,tn))
+			   (write-var-integer
+			    (make-sc-offset (sc-number
+					     (tn-sc tn))
+			     ;; zzzzz jrd here.  tn-offset
+			     ;; is zero for constant tns.
+			     ;; (tn-offset tn)
+			     (or (tn-offset tn) 0)
+			     )
+			    ,vector)))
+		    values)
+	  (inst byte (length ,vector))
+	  (dotimes (i (length ,vector))
+	    (inst byte (aref ,vector i))))))))
+
+(defmacro error-call (vop error-code &rest values)
+  "Cause an error.  ERROR-CODE is the error to cause."
+  (cons 'progn
+	(emit-error-break vop error-trap error-code values)))
+
+
+(defmacro cerror-call (vop label error-code &rest values)
+  "Cause a continuable error.  If the error is continued, execution resumes at
+  LABEL."
+  `(progn
+     ,@(emit-error-break vop cerror-trap error-code values)
+     (inst jmp ,label)))
+
+(defmacro generate-error-code (vop error-code &rest values)
+  "Generate-Error-Code Error-code Value*
+  Emit code for an error with the specified Error-Code and context Values."
+  `(assemble (*elsewhere*)
+     (let ((start-lab (gen-label)))
+       (emit-label start-lab)
+       (error-call ,vop ,error-code ,@values)
+       start-lab)))
+
+(defmacro generate-cerror-code (vop error-code &rest values)
+  "Generate-CError-Code Error-code Value*
+  Emit code for a continuable error with the specified Error-Code and
+  context Values.  If the error is continued, execution resumes after
+  the GENERATE-CERROR-CODE form."
+  (let ((continue (gensym "CONTINUE-LABEL-"))
+	(error (gensym "ERROR-LABEL-")))
+    `(let ((,continue (gen-label))
+	   (,error (gen-label)))
+       (emit-label ,continue)
+       (assemble (*elsewhere*)
+	 (emit-label ,error)
+	 (cerror-call ,vop ,continue ,error-code ,@values))
+       ,error)))
+
+
+
+;;;; Indexed references:
+
+(defmacro define-full-reffer (name type offset lowtag scs el-type &optional translate)
+  `(progn
+     (define-vop (,name)
+       ,@(when translate
+	   `((:translate ,translate)))
+       (:policy :fast-safe)
+       (:args (object :scs (descriptor-reg))
+	      (index :scs (any-reg)))
+       (:arg-types ,type tagged-num)
+       (:results (value :scs ,scs))
+       (:result-types ,el-type)
+       (:generator 3			; pw was 5
+	 (inst mov
+	       value
+	       (make-ea :dword :base object :index index
+			:disp (- (* ,offset word-bytes) ,lowtag)))))
+     (define-vop (,(symbolicate name "-C"))
+       ,@(when translate
+	   `((:translate ,translate)))
+       (:policy :fast-safe)
+       (:args (object :scs (descriptor-reg)))
+       (:info index)
+       (:arg-types ,type (:constant (signed-byte 30)))
+       (:results (value :scs ,scs))
+       (:result-types ,el-type)
+       (:generator 2			; pw was 5
+	 (inst mov
+	       value
+	       (make-ea :dword :base object
+			:disp (- (* (+ ,offset index) word-bytes)
+				 ,lowtag)))))))
+
+(defmacro define-full-setter (name type offset lowtag scs el-type &optional translate)
+  `(progn
+     (define-vop (,name)
+       ,@(when translate
+	   `((:translate ,translate)))
+       (:policy :fast-safe)
+       (:args (object :scs (descriptor-reg))
+	      (index :scs (any-reg))
+	      (value :scs ,scs :target result))
+       (:arg-types ,type tagged-num ,el-type)
+       (:results (result :scs ,scs))
+       (:result-types ,el-type)
+       (:generator 4			; was 5
+	 (inst mov
+	       (make-ea :dword :base object :index index
+			:disp (- (* ,offset word-bytes) ,lowtag))
+	       value)
+	 (move result value)))
+     (define-vop (,(symbolicate name "-C"))
+       ,@(when translate
+	   `((:translate ,translate)))
+       (:policy :fast-safe)
+       (:args (object :scs (descriptor-reg))
+	      (value :scs ,scs :target result))
+       (:info index)
+       (:arg-types ,type (:constant (signed-byte 30)) ,el-type)
+       (:results (result :scs ,scs))
+       (:result-types ,el-type)
+       (:generator 3			; was 5
+	 (inst mov
+	       (make-ea :dword :base object
+			:disp (- (* (+ ,offset index) word-bytes)
+				 ,lowtag))
+	       value)
+	 (move result value)))))
+
diff --git a/compiler/x86/memory.lisp b/compiler/x86/memory.lisp
new file mode 100644
index 000000000..0050b6bb4
--- /dev/null
+++ b/compiler/x86/memory.lisp
@@ -0,0 +1,109 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/memory.lisp,v 1.1 1997/01/18 14:31:21 ram Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    This file contains the x86 definitions of some general purpose memory
+;;; reference VOPs inherited by basic memory reference operations.
+;;;
+;;; Written by William Lott.
+;;;
+;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
+;;; 
+
+(in-package :x86)
+
+;;; Cell-Ref and Cell-Set are used to define VOPs like CAR, where the offset to
+;;; be read or written is a property of the VOP used.  Cell-Setf is similar to
+;;; Cell-Set, but delivers the new value as the result.  Cell-Setf-Function
+;;; takes its arguments as if it were a setf function (new value first, as
+;;; apposed to a setf macro, which takes the new value last).
+;;;
+(define-vop (cell-ref)
+  (:args (object :scs (descriptor-reg)))
+  (:results (value :scs (descriptor-reg any-reg)))
+  (:variant-vars offset lowtag)
+  (:policy :fast-safe)
+  (:generator 4
+    (loadw value object offset lowtag)))
+;;;
+(define-vop (cell-set)
+  (:args (object :scs (descriptor-reg))
+         (value :scs (descriptor-reg any-reg)))
+  (:variant-vars offset lowtag)
+  (:policy :fast-safe)
+  (:generator 4
+    (storew value object offset lowtag)))
+;;;
+(define-vop (cell-setf)
+  (:args (object :scs (descriptor-reg))
+	 (value :scs (descriptor-reg any-reg)
+		:target result))
+  (:results (result :scs (descriptor-reg any-reg
+			  descriptor-stack immediate-stack)))
+  (:variant-vars offset lowtag)
+  (:policy :fast-safe)
+  (:generator 4
+    (storew value object offset lowtag)
+    (move result value)))
+;;;
+(define-vop (cell-setf-function)
+  (:args (value :scs (descriptor-reg any-reg)
+		:target result)
+	 (object :scs (descriptor-reg)))
+  (:results (result :scs (descriptor-reg any-reg
+			  descriptor-stack immediate-stack)))
+  (:variant-vars offset lowtag)
+  (:policy :fast-safe)
+  (:generator 4
+    (storew value object offset lowtag)
+    (move result value)))
+
+;;; Define-Cell-Accessors  --  Interface
+;;;
+;;;    Define accessor VOPs for some cells in an object.  If the operation name
+;;; is NIL, then that operation isn't defined.  If the translate function is
+;;; null, then we don't define a translation.
+;;;
+(defmacro define-cell-accessors (offset lowtag
+					ref-op ref-trans set-op set-trans)
+  `(progn
+     ,@(when ref-op
+	 `((define-vop (,ref-op cell-ref)
+	     (:variant ,offset ,lowtag)
+	     ,@(when ref-trans
+		 `((:translate ,ref-trans))))))
+     ,@(when set-op
+	 `((define-vop (,set-op cell-setf)
+	     (:variant ,offset ,lowtag)
+	     ,@(when set-trans
+		 `((:translate ,set-trans))))))))
+
+
+;;; Slot-Ref and Slot-Set are used to define VOPs like Closure-Ref, where the
+;;; offset is constant at compile time, but varies for different uses.
+;;;
+(define-vop (slot-ref)
+  (:args (object :scs (descriptor-reg)))
+  (:results (value :scs (descriptor-reg any-reg)))
+  (:variant-vars base lowtag)
+  (:info offset)
+  (:generator 4
+    (loadw value object (+ base offset) lowtag)))
+;;;
+(define-vop (slot-set)
+  (:args (object :scs (descriptor-reg))
+	 (value :scs (descriptor-reg any-reg)))
+  (:variant-vars base lowtag)
+  (:info offset)
+  (:generator 4
+    (storew value object (+ base offset) lowtag)))
+
diff --git a/compiler/x86/move.lisp b/compiler/x86/move.lisp
new file mode 100644
index 000000000..2a70fc15f
--- /dev/null
+++ b/compiler/x86/move.lisp
@@ -0,0 +1,472 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/move.lisp,v 1.1 1997/01/18 14:31:21 ram Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the x86 VM definition of operand loading/saving and
+;;; the Move VOP.
+;;;
+;;; Written by William Lott.
+;;;
+;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
+;;;
+(in-package :x86)
+
+(define-move-function (load-immediate 1) (vop x y)
+  ((immediate)
+   (any-reg descriptor-reg))
+  (let ((val (tn-value x)))
+    (etypecase val
+      (integer
+       (if (zerop val)
+	   (inst xor y y)
+	 (inst mov y (fixnum val))))
+      (symbol
+       (load-symbol y val))
+      (character
+       (inst mov y (logior (ash (char-code val) type-bits)
+			   base-char-type))))))
+
+(define-move-function (load-number 1) (vop x y)
+  ((immediate) (signed-reg unsigned-reg))
+  (inst mov y (tn-value x)))
+
+(define-move-function (load-base-char 1) (vop x y)
+  ((immediate) (base-char-reg))
+  (inst mov y (char-code (tn-value x))))
+
+(define-move-function (load-system-area-pointer 1) (vop x y)
+  ((immediate) (sap-reg))
+  (inst mov y (sap-int (tn-value x))))
+
+#+nil ;; original
+(define-move-function (load-constant 5) (vop x y)
+  ((constant) (descriptor-reg))
+  (inst mov y x))
+
+(define-move-function (load-constant 5) (vop x y)
+  ;; pfw adds any-reg to no effect
+  ((constant) (descriptor-reg any-reg))
+  (inst mov y x))
+
+#+nil ;; not sure this will work -- need test case
+(define-move-function (load-constant 5) (vop x y)
+  ((constant) (descriptor-reg any-reg))
+  (inst mov y (make-fixup nil :code-object (tn-offset x))))
+
+(define-move-function (load-stack 5) (vop x y)
+  ((descriptor-stack) (descriptor-reg)
+   (immediate-stack) (any-reg)
+   (base-char-stack) (base-char-reg)
+   (sap-stack) (sap-reg)
+   (signed-stack) (signed-reg)
+   (unsigned-stack) (unsigned-reg))
+  (inst mov y x))
+
+(define-move-function (store-stack 5) (vop x y)
+  ((descriptor-reg) (descriptor-stack)
+   (any-reg) (immediate-stack)
+   (base-char-reg) (base-char-stack)
+   (sap-reg) (sap-stack)
+   (signed-reg) (signed-stack)
+   (unsigned-reg) (unsigned-stack))
+  (inst mov y x))
+
+;;;
+;;; ZZZZZ added by jrd.  add a move-function for immediate-stack -> descriptor-reg.
+;;; dunno if this is right, but we get into the pickle of trying to do this kind of
+;;; move a fair amount.  see if this fixes it
+;;;
+(define-move-function (load-immediate-stack 5) (vop x y)
+		      ((immediate-stack) (descriptor-reg))
+  (inst mov x y))
+
+(define-move-function (store-immediate-stack 5) (vop x y)
+		      ((descriptor-reg) (immediate-stack))
+  (inst mov x y))
+
+;;; zzzzz seem to need this one for the verify-argument-count vop???
+;(define-move-function (move-unsigned-to-any 5) (vop x y)
+;		      ((unsigned-reg) (any-reg))
+;  (inst mov y x)
+;  (inst shl y 2))
+
+
+
+;;;; The Move VOP:
+;;;
+(define-vop (move)
+  (:args (x :target y
+	    :scs (any-reg immediate-stack descriptor-reg descriptor-stack
+			  immediate)
+	    :load-if (not (location= x y))))
+  (:results (y :scs (any-reg descriptor-reg)
+	       :load-if
+	       (not (or (location= x y)
+			(and (sc-is x any-reg descriptor-reg immediate)
+			     (sc-is y immediate-stack descriptor-stack))))))
+  (:effects)
+  (:affected)
+  (:generator 0
+    (if (and (sc-is x immediate)
+	     (sc-is y any-reg immediate-stack descriptor-reg descriptor-stack))
+	(let ((val (tn-value x)))
+	  (etypecase val
+	    (integer
+	     (if (and (zerop val) (sc-is y any-reg descriptor-reg))
+		 (inst xor y y)
+	       (inst mov y (fixnum val))))
+	    (symbol
+	     (inst mov y (+ nil-value (static-symbol-offset val))))
+	    (character
+	     (inst mov y (logior (ash (char-code val) type-bits)
+				 base-char-type)))))
+      (move y x))))
+
+(define-move-vop move :move
+  (any-reg immediate-stack descriptor-reg descriptor-stack immediate)
+  (any-reg descriptor-reg))
+
+
+;;; Make Move the check VOP for T so that type check generation doesn't think
+;;; it is a hairy type.  This also allows checking of a few of the values in a
+;;; continuation to fall out.
+;;;
+(primitive-type-vop move (:check) t)
+
+;;;    The Move-Argument VOP is used for moving descriptor values into another
+;;; frame for argument or known value passing.
+;;;
+;;; Note: It is not going to be possible to move a constant directly
+;;; to another frame, except if the destination is a register and in
+;;; this case the loading works out.
+(define-vop (move-argument)
+  (:args (x :target y
+	    :scs (any-reg descriptor-reg immediate)
+	    :load-if (not (and (sc-is y any-reg descriptor-reg)
+			       (sc-is x immediate-stack))))
+	 (fp :scs (any-reg)
+	     :load-if (not (sc-is y any-reg descriptor-reg))))
+  (:results (y))
+  (:generator 0
+    (sc-case y
+      ((any-reg descriptor-reg)
+       (if (sc-is x immediate)
+	   (let ((val (tn-value x)))
+	     (etypecase val
+	      (integer
+	       (if (zerop val)
+		   (inst xor y y)
+		 (inst mov y (fixnum val))))
+	      (symbol
+	       (load-symbol y val))
+	      (character
+	       (inst mov y (logior (ash (char-code val) type-bits)
+				   base-char-type)))))
+	 (move y x)))
+      ((descriptor-stack immediate-stack)
+       (if (sc-is x immediate)
+	   (let ((val (tn-value x)))
+	     (if (= (tn-offset fp) esp-offset)
+		 ;; C-call
+		 (etypecase val
+	           (integer
+		    (storew (fixnum val) fp (tn-offset y)))
+		   (symbol
+		    (storew (+ nil-value (static-symbol-offset val))
+			    fp (tn-offset y)))
+		   (character
+		    (storew (logior (ash (char-code val) type-bits)
+				    base-char-type)
+			    fp (tn-offset y))))
+	       ;; Lisp stack
+	       (etypecase val
+		 (integer
+		  (storew (fixnum val) fp (- (1+ (tn-offset y)))))
+		 (symbol
+		  (storew (+ nil-value (static-symbol-offset val))
+			  fp (- (1+ (tn-offset y)))))
+		 (character
+		  (storew (logior (ash (char-code val) type-bits)
+				  base-char-type)
+			  fp (- (1+ (tn-offset y))))))))
+	 (if (= (tn-offset fp) esp-offset)
+	     ;; C-call
+	     (storew x fp (tn-offset y))
+	   ;; Lisp stack
+	   (storew x fp (- (1+ (tn-offset y))))))))))
+
+;;;
+(define-move-vop move-argument :move-argument
+  (any-reg descriptor-reg)
+  (any-reg descriptor-reg))
+
+
+
+;;;; ILLEGAL-MOVE
+
+;;; This VOP exists just to begin the lifetime of a TN that couldn't be written
+;;; legally due to a type error.  An error is signalled before this VOP is
+;;; so we don't need to do anything (not that there would be anything sensible
+;;; to do anyway.)
+;;;
+(define-vop (illegal-move)
+  (:args (x) (type))
+  (:results (y))
+  (:ignore y)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 666
+    (error-call vop object-not-type-error x type)))
+
+
+
+;;;; Moves and coercions:
+
+;;; These MOVE-TO-WORD VOPs move a tagged integer to a raw full-word
+;;; representation.  Similarly, the MOVE-FROM-WORD VOPs converts a raw integer
+;;; to a tagged bignum or fixnum.
+
+;;; Arg is a fixnum, so just shift it.  We need a type restriction because some
+;;; possible arg SCs (control-stack) overlap with possible bignum arg SCs.
+;;;
+(define-vop (move-to-word/fixnum)
+  (:args (x :scs (any-reg immediate-stack descriptor-reg descriptor-stack)))
+  (:results (y :scs (signed-reg unsigned-reg)))
+  (:arg-types tagged-num)
+  (:note "fixnum untagging")
+  (:generator 1
+    (move y x)
+    (inst sar y 2)))
+;;;
+(define-move-vop move-to-word/fixnum :move
+  (any-reg descriptor-reg) (signed-reg unsigned-reg))
+
+;;; Arg is a non-immediate constant, load it.
+(define-vop (move-to-word-c)
+  (:args (x :scs (constant)))
+  (:results (y :scs (signed-reg unsigned-reg)))
+  (:note "constant load")
+  (:generator 1
+    (inst mov y (tn-value x))))
+;;;
+(define-move-vop move-to-word-c :move
+  (constant) (signed-reg unsigned-reg))
+
+
+;;; Arg is a fixnum or bignum, figure out which and load if necessary.
+(define-vop (move-to-word/integer)
+  (:args (x :scs (descriptor-reg) :target eax))
+  (:results (y :scs (signed-reg unsigned-reg)))
+  (:note "integer to untagged word coercion")
+  (:temporary (:sc dword-reg :offset eax-offset
+		   :from (:argument 0)
+		   :to (:result 0) :target y) eax)
+  (:generator 4
+    (move eax x)
+    (inst test al-tn 3)
+    (inst jmp :z fixnum)
+    (loadw y eax bignum-digits-offset other-pointer-type)
+    (inst jmp done)
+    FIXNUM
+    (inst sar eax 2)
+    (move y eax)
+    DONE))
+;;;
+(define-move-vop move-to-word/integer :move
+  (descriptor-reg) (signed-reg unsigned-reg))
+
+
+;;; Result is a fixnum, so we can just shift.  We need the result type
+;;; restriction because of the control-stack ambiguity noted above.
+;;;
+(define-vop (move-from-word/fixnum)
+  (:args (x :scs (signed-reg signed-stack unsigned-reg unsigned-stack)))
+  (:results (y :scs (any-reg descriptor-reg)))
+  (:result-types tagged-num)
+  (:note "fixnum tagging")
+  (:generator 1
+    (if (and (sc-is x signed-reg unsigned-reg)
+	     (not (location= x y)))
+	;; Uses 7 bytes, but faster on the Pentium
+	(inst lea y (make-ea :dword :index x :scale 4))
+      (progn
+	;; Uses: If x is a reg 2 + 3; if x = y uses only 3 bytes
+	(move y x)
+	(inst shl y 2)))))
+;;;
+(define-move-vop move-from-word/fixnum :move
+  (signed-reg unsigned-reg) (any-reg descriptor-reg))
+
+;;; Result may be a bignum, so we have to check.  Use a worst-case cost to make
+;;; sure people know they may be number consing.
+;;;
+(define-vop (move-from-signed)
+  (:args (x :scs (signed-reg unsigned-reg) :target eax))
+  (:temporary (:sc dword-reg :offset eax-offset :from (:argument 0)) eax)
+  (:temporary (:sc dword-reg :offset ebx-offset :to (:result 0) :target y)
+	      ebx)
+  (:temporary (:sc dword-reg :offset ecx-offset
+		   :from (:argument 0) :to (:result 0))
+	      ecx)
+  (:ignore ecx)
+  (:results (y :scs (any-reg descriptor-reg)))
+  (:note "signed word to integer coercion")
+  (:generator 20
+    (move eax x)
+    (inst call (make-fixup 'move-from-signed :assembly-routine))
+    (move y ebx)))
+
+#+notyet ;; new from dtc -- need to test
+(define-vop (move-from-signed)
+  (:args (x :scs (signed-reg unsigned-reg) :to :save))
+  (:temporary (:sc dword-reg) alloc)
+  (:results (y :scs (any-reg descriptor-reg)))
+  (:note "signed word to integer coercion")
+  (:generator 20
+     (assert (not (location= x y)))
+     (assert (not (location= x alloc)))
+     (assert (not (location= y alloc)))
+     (let ( (bignum (gen-label))
+	    (done (gen-label)) )
+       (inst mov y x)
+       (inst shl y 1)
+       (inst jmp :o bignum)
+       (inst shl y 1)
+       (inst jmp :o bignum)
+       (emit-label done)
+
+       (assemble (*elsewhere*)
+          (emit-label bignum)
+	  (with-fixed-allocation (y alloc bignum-type
+				    (+ bignum-digits-offset 1))
+             (storew x y bignum-digits-offset other-pointer-type))
+	  (inst jmp done)))))
+;;;
+(define-move-vop move-from-signed :move
+  (signed-reg) (descriptor-reg))
+
+
+;;; Check for fixnum, and possibly allocate one or two word bignum result.  Use
+;;; a worst-case cost to make sure people know they may be number consing.
+;;;
+
+(define-vop (move-from-unsigned)
+  (:args (x :scs (signed-reg unsigned-reg) :target eax))
+  (:temporary (:sc dword-reg :offset eax-offset :from (:argument 0)) eax)
+  (:temporary (:sc dword-reg :offset ebx-offset :to (:result 0) :target y)
+	      ebx)
+  (:temporary (:sc dword-reg :offset ecx-offset
+		   :from (:argument 0) :to (:result 0))
+	      ecx)
+  (:ignore ecx)
+  (:results (y :scs (any-reg descriptor-reg)))
+  (:note "unsigned word to integer coercion")
+  (:generator 20
+    (move eax x)
+    (inst call (make-fixup 'move-from-unsigned :assembly-routine))
+    (move y ebx)))
+
+#+notyet ;; from dtc -- need to test this
+(define-vop (move-from-unsigned)
+  (:args (x :scs (signed-reg unsigned-reg) :to :save))
+  (:temporary (:sc dword-reg) alloc)
+  (:results (y :scs (any-reg descriptor-reg)))
+  (:note "unsigned word to integer coercion")
+  (:generator 20
+    (assert (not (location= x y)))
+    (assert (not (location= x alloc)))
+    (assert (not (location= y alloc)))
+    (let ( (bignum (gen-label))
+	   (done (gen-label))
+	   (one-word-bignum (gen-label))
+	   (l1 (gen-label)) )
+      (inst test x #xe0000000)
+      (inst jmp :nz bignum)
+      ;; Fixnum.
+      (inst lea y (make-ea :dword :index x :scale 4)) ; Faster but bigger.
+      ;(inst mov y x)
+      ;(inst shl y 2)
+      (emit-label done)
+
+      (assemble (*elsewhere*)
+         (emit-label bignum)
+	 ;; Note: As on the mips port, space for a two word bignum is
+	 ;; always allocated and the header size is set to either one
+	 ;; or two words as appropriate.
+	 (inst jmp :ns one-word-bignum)
+	 ;; Two word bignum.
+	 (inst mov y (logior (ash (1- (+ bignum-digits-offset 2)) vm:type-bits)
+			     bignum-type))
+	 (inst jmp l1)
+	 (emit-label one-word-bignum)
+	 (inst mov y (logior (ash (1- (+ bignum-digits-offset 1)) vm:type-bits)
+			     bignum-type))
+	 (emit-label l1)
+	 (with-cgc-allocation
+	  (alloc (pad-data-block (+ bignum-digits-offset 2)))
+	  (storew y alloc)
+	  (inst lea y (make-ea :byte :base alloc :disp other-pointer-type)))
+	 (storew x y bignum-digits-offset other-pointer-type)
+	 (inst jmp done)))))
+;;;
+(define-move-vop move-from-unsigned :move
+  (unsigned-reg) (descriptor-reg))
+
+
+;;; Move untagged numbers.
+;;;
+(define-vop (word-move)
+  (:args (x :target y
+	    :scs (signed-reg unsigned-reg signed-stack unsigned-stack)
+	    :load-if (not (location= x y))))
+  (:results (y :scs (signed-reg unsigned-reg)
+	       :load-if
+	       (not (or (location= x y)
+			(and (sc-is x signed-reg unsigned-reg)
+			     (sc-is y signed-stack unsigned-stack))))))
+  (:effects)
+  (:affected)
+  (:note "word integer move")
+  (:generator 0
+    (move y x)))
+;;;
+(define-move-vop word-move :move
+  (signed-reg unsigned-reg) (signed-reg unsigned-reg))
+
+;;; Move untagged number arguments/return-values.
+;;;
+(define-vop (move-word-argument)
+  (:args (x :target y
+	    :scs (signed-reg unsigned-reg))
+	 (fp :scs (any-reg)
+	     :load-if (not (sc-is y sap-reg))))
+  (:results (y))
+  (:note "word integer argument move")
+  (:generator 0
+    (sc-case y
+      ((signed-reg unsigned-reg)
+       (move y x))
+      ((signed-stack unsigned-stack)
+       (if (= (tn-offset fp) esp-offset)
+	   (storew x fp (tn-offset y))	; c-call
+	   (storew x fp (- (1+ (tn-offset y)))))))))
+
+;;;
+(define-move-vop move-word-argument :move-argument
+  (descriptor-reg any-reg signed-reg unsigned-reg) (signed-reg unsigned-reg))
+
+
+;;; Use standard MOVE-ARGUMENT + coercion to move an untagged number to a
+;;; descriptor passing location.
+;;;
+(define-move-vop move-argument :move-argument
+  (signed-reg unsigned-reg) (any-reg descriptor-reg))
diff --git a/compiler/x86/nlx.lisp b/compiler/x86/nlx.lisp
new file mode 100644
index 000000000..6cde54f1d
--- /dev/null
+++ b/compiler/x86/nlx.lisp
@@ -0,0 +1,412 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/nlx.lisp,v 1.1 1997/01/18 14:31:22 ram Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the VM definition of non-local exit for the x86.
+;;;
+;;; Written by William Lott.
+;;;
+;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
+;;;
+(in-package :x86)
+
+;;; MAKE-NLX-SP-TN  --  Interface
+;;;
+;;;    Make an environment-live stack TN for saving the SP for NLX entry.
+;;;
+(def-vm-support-routine make-nlx-sp-tn (env)
+  (environment-live-tn
+   (make-representation-tn *fixnum-primitive-type* any-reg-sc-number)
+   env))
+
+(defun catch-block-ea (tn)
+  (assert (sc-is tn catch-block))
+  (make-ea :dword :base ebp-tn
+	   :disp (- (* (+ (tn-offset tn) catch-block-size) word-bytes))))
+
+
+;;; Save and restore dynamic environment.
+;;;
+;;;    These VOPs are used in the reentered function to restore the appropriate
+;;; dynamic environment.  Currently we only save the Current-Catch and eval
+;;; stack pointer.  We don't need to save/restore the current unwind-protect,
+;;; since unwind-protects are implicitly processed during unwinding.
+;;;
+;;; We don't need to save the BSP, because that is handled automatically.
+
+;;; Make-Dynamic-State-TNs  --  Interface
+;;;
+;;;    Return a list of TNs that can be used to snapshot the dynamic state for
+;;; use with the Save/Restore-Dynamic-Environment VOPs.
+;;;
+(def-vm-support-routine make-dynamic-state-tns ()
+  #+nil
+  (make-n-tns 2 *any-primitive-type*)
+  (make-n-tns 3 *any-primitive-type*))
+
+(define-vop (save-dynamic-state)
+  (:results (catch :scs (descriptor-reg))
+	    (eval :scs (descriptor-reg))
+	    (oldfp :scs (descriptor-reg))) ; pw adds this
+  (:vop-var vop)
+  (:generator 13
+    (load-symbol-value catch lisp::*current-catch-block*)
+    (load-symbol-value eval lisp::*eval-stack-top*)
+    (loadw oldfp ebp-tn  (- (1+ old-fp-save-offset)))))
+  
+
+(define-vop (restore-dynamic-state)
+  (:args (catch :scs (descriptor-reg))
+	 (eval :scs (descriptor-reg))
+	 (oldfp :scs (descriptor-reg)))
+  (:vop-var vop)
+  (:generator 10
+    (store-symbol-value catch lisp::*current-catch-block*)
+    (store-symbol-value eval lisp::*eval-stack-top*)
+    (storew oldfp ebp-tn (- (1+ old-fp-save-offset)))))
+
+(define-vop (current-stack-pointer)
+  (:results (res :scs (any-reg immediate-stack)))
+  (:generator 1
+    (move res esp-tn)))
+
+(define-vop (current-binding-pointer)
+  (:results (res :scs (any-reg descriptor-reg)))
+  (:generator 1
+    (load-symbol-value res lisp::*binding-stack-pointer*)))
+
+
+;;;; Unwind block hackery:
+
+;;; Compute the address of the catch block from its TN, then store into the
+;;; block the current Fp, Env, Unwind-Protect, and the entry PC.
+
+(define-vop (make-unwind-block)
+  (:args (tn))
+  (:info entry-label)
+  (:temporary (:sc dword-reg) temp)
+  (:results (block :scs (any-reg)))
+  (:generator 22
+    (inst lea block (catch-block-ea tn))
+    (load-symbol-value temp lisp::*current-unwind-protect-block*)
+    (storew temp block unwind-block-current-uwp-slot)
+    (storew ebp-tn block unwind-block-current-cont-slot)
+    (inst lea temp (make-fixup nil :code-object entry-label))
+    (storew temp block catch-block-entry-pc-slot)))
+
+;;; Like Make-Unwind-Block, except that we also store in the specified tag, and
+;;; link the block into the Current-Catch list.
+;;;
+
+(define-vop (make-catch-block)
+  (:args (tn)
+	 (tag :scs (descriptor-reg) :to (:result 1)))
+  (:info entry-label)
+  (:results (block :scs (any-reg)))
+  (:temporary (:sc descriptor-reg) temp)
+  (:generator 44
+    (inst lea block (catch-block-ea tn))
+    (load-symbol-value temp lisp::*current-unwind-protect-block*)
+    (storew temp block  unwind-block-current-uwp-slot)
+    (storew ebp-tn block  unwind-block-current-cont-slot)
+    (inst lea temp (make-fixup nil :code-object entry-label))
+    (storew temp block  catch-block-entry-pc-slot)
+    (storew tag block catch-block-tag-slot)
+    (load-symbol-value temp lisp::*current-catch-block*)
+    (storew temp block catch-block-previous-catch-slot)
+    (store-symbol-value block lisp::*current-catch-block*)))
+
+;;; Just set the current unwind-protect to TN's address.  This instantiates an
+;;; unwind block as an unwind-protect.
+;;;
+(define-vop (set-unwind-protect)
+  (:args (tn))
+  (:temporary (:sc dword-reg) new-uwp)
+  (:generator 7
+    (inst lea new-uwp (catch-block-ea tn))
+    (store-symbol-value new-uwp lisp::*current-unwind-protect-block*)))
+
+(define-vop (unlink-catch-block)
+  (:temporary (:sc dword-reg) block)
+  (:policy :fast-safe)
+  (:translate %catch-breakup)
+  (:generator 17
+    (load-symbol-value block lisp::*current-catch-block*)
+    (loadw block block catch-block-previous-catch-slot)
+    (store-symbol-value block lisp::*current-catch-block*)))
+
+(define-vop (unlink-unwind-protect)
+    (:temporary (:sc dword-reg) block)
+  (:policy :fast-safe)
+  (:translate %unwind-protect-breakup)
+  (:generator 17
+    (load-symbol-value block lisp::*current-unwind-protect-block*)
+    (loadw block block unwind-block-current-uwp-slot)
+    (store-symbol-value block lisp::*current-unwind-protect-block*)))
+
+
+;;;; NLX entry VOPs:
+#+nil ;; this is bogus?
+(define-vop (nlx-entry)
+  (:args (sp) ; Note: we can't list an sc-restriction, 'cause any load vops
+	      ; would be inserted before the return-pc label.
+	 (start)
+	 (count))
+  (:results (values :more t))
+  (:temporary (:sc descriptor-reg) nil-temp move-temp)
+  (:info label nvals)
+  (:save-p :force-to-stack)
+  (:vop-var vop)
+  (:generator 30
+    (emit-label label)
+    (note-this-location vop :non-local-entry)
+    (cond ((zerop nvals))
+	  ((= nvals 1)
+	   (let ((no-values (gen-label)))
+	     ;; (move (tn-ref-tn values) nil-value) -- jrd
+	     (inst mov (tn-ref-tn values) nil-value)
+
+	     (inst jecxz no-values)
+
+	     ;; jrd rewrote this piece.  because we can't issue an sc-restriction, 
+	     ;; as above, we generate a bogus EA here (see the expansion of LOADW)
+	     ;; and croak.  Do the move by hand.
+	     ;; (loadw (tn-ref-tn values) start -1)
+	     (inst mov move-temp start)
+	     (loadw (tn-ref-tn values) move-temp -1)
+
+	     (emit-label no-values)))
+	  (t
+	   (collect ((defaults))
+	     (inst mov nil-temp nil-value)
+	     (do ((i 0 (1+ i))
+		  (tn-ref values (tn-ref-across tn-ref)))
+		 ((null tn-ref))
+	       (let ((default-lab (gen-label))
+		     (tn (tn-ref-tn tn-ref)))
+		 (defaults (cons default-lab tn))
+		 
+		 (inst cmp count (fixnum i))
+		 (inst jmp :le default-lab)
+		 (sc-case tn
+		   ((descriptor-reg any-reg)
+		    ;; see above -- jrd
+		    ;; (loadw tn start (- (1+ i)))
+		    (inst mov move-temp start)
+		    (loadw tn move-temp (- (1+ i))))
+		   ((descriptor-stack immediate-stack)
+		    ;; (loadw move-temp start (- (1+ i)))
+		    (inst mov move-temp start)
+		    (loadw move-temp move-temp (- (1+ i)))
+		    (move tn move-temp)))))
+	     (let ((defaulting-done (gen-label)))
+	       (emit-label defaulting-done)
+	       (assemble (*elsewhere*)
+		 (dolist (def (defaults))
+		   (emit-label (car def))
+		   (move (cdr def) nil-temp))
+		 (inst jmp defaulting-done))))))
+    (inst mov esp-tn sp)))
+
+;;; see comments below regarding start arg to nlx-entry-multiple
+(define-vop (nlx-entry)
+  (:args (sp) ; Note: we can't list an sc-restriction, 'cause any load vops
+	      ; would be inserted before the return-pc label.
+	 (start)
+	 (count))
+  (:results (values :more t))
+  (:temporary (:sc descriptor-reg) nil-temp move-temp)
+  (:info label nvals)
+  (:save-p :force-to-stack)
+  (:vop-var vop)
+  (:generator 30
+    (emit-label label)
+    (note-this-location vop :non-local-entry)
+    (cond ((zerop nvals))
+	  ((= nvals 1)
+	   (let ((no-values (gen-label)))
+	     ;; (move (tn-ref-tn values) nil-value) -- jrd
+	     (inst mov (tn-ref-tn values) nil-value)
+	     
+	     (inst jecxz no-values)
+	     
+	     (move move-temp start)
+	     (loadw (tn-ref-tn values) move-temp -1)
+
+	     (emit-label no-values)))
+	  (t
+	   (collect ((defaults))
+	     (inst mov nil-temp nil-value)
+	     (do ((i 0 (1+ i))
+		  (tn-ref values (tn-ref-across tn-ref)))
+		 ((null tn-ref))
+	       (let ((default-lab (gen-label))
+		     (tn (tn-ref-tn tn-ref)))
+		 (defaults (cons default-lab tn))
+		 
+		 (inst cmp count (fixnum i))
+		 (inst jmp :le default-lab)
+		 (sc-case tn
+		   ((descriptor-reg any-reg)
+		    ;; see above -- jrd
+		    ;; (loadw tn start (- (1+ i)))
+		    (move move-temp start)
+		    (loadw tn move-temp (- (1+ i))))
+		   ((descriptor-stack immediate-stack)
+		    ;; (loadw move-temp start (- (1+ i)))
+		    (move move-temp start)
+		    (loadw move-temp move-temp (- (1+ i)))
+		    (move tn move-temp)))))
+	     (let ((defaulting-done (gen-label)))
+	       (emit-label defaulting-done)
+	       (assemble (*elsewhere*)
+		 (dolist (def (defaults))
+		   (emit-label (car def))
+		   (move (cdr def) nil-temp))
+		 (inst jmp defaulting-done))))))
+    (inst mov esp-tn sp)))
+
+#+nil ;;; this is badly broken and just kept here for reference -pw
+      ;;; actually maybe it's not so broken -- check later
+(define-vop (nlx-entry-multiple)
+  (:args (top)
+	 (source)
+	 (count :target ecx))
+  ;; Again, no SC restrictions for the args, 'cause the loading would
+  ;; happen before the entry label.
+  (:info label)
+  ;;(:temporary (:sc dword-reg :offset esi-offset) esi)
+  (:temporary (:sc dword-reg :offset ecx-offset :from (:argument 2)) ecx)
+  (:temporary (:sc dword-reg :offset esi-offset) esi)
+  (:temporary (:sc dword-reg :offset edi-offset) edi)
+  (:results (result :scs (any-reg) :from (:argument 0))
+	    (num :scs (any-reg immediate-stack)))
+  (:save-p :force-to-stack)
+  (:vop-var vop)
+  (:generator 30
+    #+x86-lra
+    (progn 
+      (align lowtag-bits #x90)
+      (inst lra-header-word)
+      (inst nop)
+      (inst nop)
+      (inst nop))
+    (emit-label label)
+    (note-this-location vop :non-local-entry)
+
+    ;; Set up the result values and copy the arguments.
+    (move result top)
+
+    ;; -- jrd.  see comments above.  need to do extra moves by hand, to
+    ;; get the ea's into registers
+    ;; (inst lea esi (make-ea :dword :base source :disp (- word-bytes)))
+    (inst lea edi (make-ea :dword :base result :disp (- word-bytes)))
+    (inst mov esi source)
+    (inst lea esi (make-ea :dword :base esi :disp (- word-bytes)))
+    (inst mov edi result)
+    (inst lea edi (make-ea :dword :base edi :disp (- word-bytes)))
+
+    (move ecx count)			; fixnum words == bytes
+    (move num ecx)
+    (inst shr ecx word-shift)		; word count for <rep movs>
+    ;; If we got zero, we be done.
+    (inst jecxz done)
+
+    ;; Copy them down.
+    (inst std)
+    (inst rep)
+    (inst movs :dword)
+
+    ;; Reset the CSP.
+    DONE
+    (inst lea esp-tn (make-ea :dword :base edi :disp word-bytes))))
+
+(define-vop (nlx-entry-multiple)
+  (:args (top)
+	 (source)
+	 (count :target ecx))
+  ;; Again, no SC restrictions for the args, 'cause the loading would
+  ;; happen before the entry label.
+  (:info label)
+  (:temporary (:sc dword-reg :offset ecx-offset :from (:argument 2)) ecx)
+  (:temporary (:sc dword-reg :offset esi-offset) esi)
+  (:temporary (:sc dword-reg :offset edi-offset) edi)
+  (:results (result :scs (any-reg) :from (:argument 0))
+	    (num :scs (any-reg immediate-stack)))
+  (:save-p :force-to-stack)
+  (:vop-var vop)
+  (:generator 30
+    #+x86-lra
+    (progn 
+      (align lowtag-bits #x90)
+      (inst lra-header-word)
+      (inst nop)
+      (inst nop)
+      (inst nop))
+    (emit-label label)
+    (note-this-location vop :non-local-entry)
+
+    ;; The RISC implementations have old-fp-save wired to a register.
+    ;; ir2tran calls (make-old-fp-save-location) to retrieve that tn
+    ;; as the source address for the thrown results. Doing that here
+    ;; provides the S0 slot as that source which is the wrong end of
+    ;; the stack. Examination of the throw-catch-unwind process shows
+    ;; that %ebx is the analog of OCFP here and at least in testing so
+    ;; far does actually point (1 above)  the values.
+    ;; Actually, now it seems that 'unwind' is supposed to set up
+    ;; edx and old-fp with certain values so that the compiler can
+    ;; call these nlx entry points correctly. NOT.
+    (move esi source)			; old-fp
+    (inst lea esi (make-ea :dword :base esi :disp (- word-bytes)))
+    ;; The 'top' arg contains the %esp value saved prior to creating
+    ;; the catch block and dynamic save structures and points to where
+    ;; the thrown values should sit.
+    (move edi top)
+    (move result edi)
+    ;; not too sure here -- yes! this seems to be correct
+    (inst lea edi (make-ea :dword :base edi :disp (- word-bytes)))
+
+    (move ecx count)			; fixnum words == bytes
+    (move num ecx)
+    (inst shr ecx word-shift)		; word count for <rep movs>
+    ;; If we got zero, we be done.
+    (inst jecxz done)
+    ;; Copy them down.
+    (inst std)
+    (inst rep)
+    (inst movs :dword)
+
+    ;; Reset the CSP (at last moved arg??)
+    DONE
+    (inst lea esp-tn (make-ea :dword :base edi :disp word-bytes))))
+
+
+;;; This VOP is just to force the TNs used in the cleanup onto the stack.
+;;;
+(define-vop (uwp-entry)
+  #+info-only
+  (:args (target)(block)(start)(count))
+  (:info label)
+  (:save-p :force-to-stack)
+  (:results (block) (start) (count))
+  (:ignore block start count)
+  (:vop-var vop)
+  (:generator 0
+    #+x86-lra
+    (progn 
+      (align lowtag-bits #x90)
+      (inst lra-header-word)
+      (inst nop)
+      (inst nop)
+      (inst nop))
+    (emit-label label)
+    (note-this-location vop :non-local-entry)))
diff --git a/compiler/x86/parms.lisp b/compiler/x86/parms.lisp
new file mode 100644
index 000000000..5c1e6293f
--- /dev/null
+++ b/compiler/x86/parms.lisp
@@ -0,0 +1,284 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: python-x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/parms.lisp,v 1.1 1997/01/18 14:31:21 ram Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    This file contains some parameterizations of various VM
+;;; attributes for the x86.  This file is separate from other stuff so 
+;;; that it can be compiled and loaded earlier. 
+;;;
+;;; Written by William Lott.
+;;;
+;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
+;;;
+
+(in-package :x86)
+(use-package :c)
+
+;;; ### Note: we simultaneously use ``word'' to mean a 32 bit quantity and
+;;; a 16 bit quantity depending on context.  This is because Intel insists
+;;; on calling 16 bit things words and 32 bit things double-words (or dwords).
+;;; Therefore, in the instruction defintion and register specs, we use the
+;;; Intel convention.  But whenever we are talking about stuff the rest of
+;;; the lisp system might be interested in, we use ``word'' to mean the size
+;;; of a descriptor object, which is 32 bits.
+
+
+;;;; Compiler constants.
+
+(eval-when (compile eval load)
+
+(setf (backend-name *target-backend*) "X86")
+(setf (backend-version *target-backend*) "Intel x86")
+(setf (backend-fasl-file-type *target-backend*) "x86f")
+(setf (backend-fasl-file-implementation *target-backend*)
+      x86-fasl-file-implementation)
+(setf (backend-fasl-file-version *target-backend*) 1)
+(setf (backend-register-save-penalty *target-backend*) 3)
+(setf (backend-byte-order *target-backend*) :little-endian)
+
+;;;#+cross-compiler
+;;;(setf (backend-package *target-backend*) :python-x86)
+
+#|
+;;;
+;;; windows NT uses a memory system granularity of 64K, which means everything
+;;; that gets mapped must be a multiple of that.  The real page size is 512, but 
+;;; that doesn't do us a whole lot of good.  Effectively, the page size is 64K
+;;;
+(setf (backend-page-size *target-backend*) 65536)
+|#
+
+(setf (backend-page-size *target-backend*) 4096)
+); eval-when
+
+
+;;;; Machine Architecture parameters:
+
+(export '(word-bits byte-bits word-shift word-bytes float-sign-shift
+
+	  single-float-bias single-float-exponent-byte
+	  single-float-significand-byte single-float-normal-exponent-min
+	  single-float-normal-exponent-max single-float-hidden-bit
+	  single-float-trapping-nan-bit single-float-digits
+
+	  double-float-bias double-float-exponent-byte
+	  double-float-significand-byte double-float-normal-exponent-min
+	  double-float-normal-exponent-max double-float-hidden-bit
+	  double-float-trapping-nan-bit double-float-digits
+
+	  float-underflow-trap-bit float-overflow-trap-bit
+	  float-imprecise-trap-bit float-invalid-trap-bit
+	  float-divide-by-zero-trap-bit))
+
+	  
+
+(eval-when (compile load eval)
+
+(defconstant word-bits 32
+  "Number of bits per word where a word holds one lisp descriptor.")
+
+(defconstant byte-bits 8
+  "Number of bits per byte where a byte is the smallest addressable object.")
+
+(defconstant word-shift (1- (integer-length (/ word-bits byte-bits)))
+  "Number of bits to shift between word addresses and byte addresses.")
+
+(defconstant word-bytes (/ word-bits byte-bits)
+  "Number of bytes in a word.")
+) ; eval-when
+
+(eval-when (compile load eval)
+(defconstant float-sign-shift 31)
+
+;; These values were taken from the alpha code. The values for
+;; bias and exponent min/max are not the same as shown in the 486 book.
+;; They may be correct for how Python uses them.
+(defconstant single-float-bias 126)	; Intel says 127
+(defconstant single-float-exponent-byte (byte 8 23))
+(defconstant single-float-significand-byte (byte 23 0))
+;; The 486 book shows the exponent range -126 to +127. The Lisp
+;; code that uses these values seems to want already biased numbers.
+(defconstant single-float-normal-exponent-min 1)
+(defconstant single-float-normal-exponent-max 254)
+(defconstant single-float-hidden-bit (ash 1 23))
+(defconstant single-float-trapping-nan-bit (ash 1 22))
+
+(defconstant double-float-bias 1022)
+(defconstant double-float-exponent-byte (byte 11 20))
+(defconstant double-float-significand-byte (byte 20 0))
+(defconstant double-float-normal-exponent-min 1)
+(defconstant double-float-normal-exponent-max #x7FE)
+(defconstant double-float-hidden-bit (ash 1 20))
+(defconstant double-float-trapping-nan-bit (ash 1 19))
+
+(defconstant single-float-digits
+  (+ (byte-size single-float-significand-byte) 1))
+
+(defconstant double-float-digits
+  (+ (byte-size double-float-significand-byte) word-bits 1))
+
+
+;;; pfw -- from i486 microprocessor programmers reference manual
+(defconstant float-invalid-trap-bit        (ash 1 0))
+(defconstant float-denormal-trap-bit       (ash 1 1)) ; not used by lisp
+(defconstant float-divide-by-zero-trap-bit (ash 1 2))
+(defconstant float-overflow-trap-bit       (ash 1 3))
+(defconstant float-underflow-trap-bit      (ash 1 4))
+(defconstant float-inexact-trap-bit        (ash 1 5))
+
+(defconstant float-round-to-nearest  0)
+(defconstant float-round-to-negative 1)
+(defconstant float-round-to-positive 2)
+(defconstant float-round-to-zero     3)
+
+(defconstant float-rounding-mode   (byte 2 10))
+(defconstant float-sticky-bits     (byte 6 16))
+(defconstant float-traps-byte      (byte 6  0))
+(defconstant float-exceptions-byte (byte 6 16))
+(defconstant float-fast-bit 0) ; No fast mode on x86
+); eval-when
+
+
+;;;; Description of the target address space.
+
+(export '(target-read-only-space-start
+	  target-static-space-start
+	  target-dynamic-space-start))
+
+;;; Where to put the different spaces.
+;;; 
+(defparameter target-read-only-space-start #x01000000)
+(defparameter target-static-space-start    #x05000000)
+(defparameter target-dynamic-space-start   #x09000000)
+
+;;; Given that NIL and T are the first things allocated in static space, we
+;;; can know their values at compile time:
+;;; 
+(defparameter nil-value #x0500000B)
+(defparameter t-value #x0500002F)
+
+
+;;;; Other random constants.
+
+(export '(halt-trap pending-interrupt-trap error-trap cerror-trap
+	  breakpoint-trap function-end-breakpoint-trap single-step-breakpoint
+	  trace-table-normal trace-table-call-site
+	  trace-table-function-prologue trace-table-function-epilogue))
+
+(defenum (:suffix -trap :start 8)
+  halt
+  pending-interrupt
+  error
+  cerror
+  breakpoint
+  function-end-breakpoint
+  single-step-breakpoint)
+
+(defenum (:prefix object-not- :suffix -trap :start 16)
+  list
+  instance)
+
+(defenum (:prefix trace-table-)
+  normal
+  call-site
+  function-prologue
+  function-epilogue)
+
+
+
+;;;; Static symbols.
+
+(export '(static-symbols static-functions))
+
+;;; These symbols are loaded into static space directly after NIL so
+;;; that the system can compute their address by adding a constant
+;;; amount to NIL.
+;;;
+;;; The fdefn objects for the static functions are loaded into static
+;;; space directly after the static symbols.  That way, the raw-addr
+;;; can be loaded directly out of them by indirecting relative to NIL.
+;;;
+;;; pfw X86 doesn't have enough registers to keep these things there.
+;;;     Note these spaces grow from low to high addresses.
+(defvar lisp::*allocation-pointer*)
+(defvar lisp::*binding-stack-pointer*)
+(defvar lisp::*x86-cgc-active-p*)
+(defvar lisp::*static-blue-bag* nil)
+
+(defparameter static-symbols
+    `(t
+
+      ;; The C startup code must fill these in.
+      lisp::lisp-environment-list
+      lisp::lisp-command-line-list
+      lisp::*initial-fdefn-objects*
+
+      ;; Functions that the C code needs to call
+      lisp::%initial-function
+      lisp::maybe-gc
+      kernel::internal-error
+      di::handle-breakpoint
+      lisp::fdefinition-object
+
+      ;; Free Pointers.
+      lisp::*read-only-space-free-pointer*
+      lisp::*static-space-free-pointer*
+      lisp::*initial-dynamic-space-free-pointer*
+
+      ;; Things needed for non-local-exit.
+      lisp::*current-catch-block*
+      lisp::*current-unwind-protect-block*
+      *eval-stack-top*
+
+      ;; Interrupt Handling
+      lisp::*free-interrupt-context-index*
+      unix::*interrupts-enabled*
+      unix::*interrupt-pending*
+
+      ;; added by pfw
+      lisp::*allocation-pointer*
+      lisp::*binding-stack-pointer*
+      lisp::*x86-cgc-active-p*
+      lisp::*internal-gc-trigger*	; Keep C code happy
+
+      *fp-constant-1s0*
+      *fp-constant-1d0*
+      *fp-constant-0s0*
+      *fp-constant-0d0*
+
+      ;; Some unused static variables - very handy for hacking.
+      lisp::*unused-static-8*
+      lisp::*unused-static-7*
+      lisp::*unused-static-6*
+      lisp::*unused-static-5*
+      lisp::*unused-static-4*
+      lisp::*unused-static-3*
+      lisp::*unused-static-2*
+      lisp::*unused-static-1*
+
+      lisp::*static-blue-bag*		; Must be last or change C code
+      ))
+
+(defparameter static-functions
+  '(length
+    two-arg-+ two-arg-- two-arg-* two-arg-/ two-arg-< two-arg-> two-arg-= eql
+    %negate two-arg-and two-arg-ior two-arg-xor two-arg-gcd two-arg-lcm
+    ))
+
+;;;
+;;; Stuff added by jrd ----
+;;;
+
+
+;;; cf the sparc PARMS.LISP
+(defparameter *assembly-unit-length* 8)
+
diff --git a/compiler/x86/pred.lisp b/compiler/x86/pred.lisp
new file mode 100644
index 000000000..5021c9c3b
--- /dev/null
+++ b/compiler/x86/pred.lisp
@@ -0,0 +1,82 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/pred.lisp,v 1.1 1997/01/18 14:31:22 ram Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    This file contains the VM definition of predicate VOPs for the x86.
+;;;
+;;; Written by William Lott.
+;;; 
+
+(in-package :x86)
+
+
+;;;; The Branch VOP.
+
+;;; The unconditional branch, emitted when we can't drop through to the desired
+;;; destination.  Dest is the continuation we transfer control to.
+;;;
+(define-vop (branch)
+  (:info dest)
+  (:generator 5
+    (inst jmp dest)))
+
+
+;;;; Conditional VOPs:
+
+;;; Note: a constant-tn is allowed in CMP; it uses an EA displacement,
+;;; not immediate data.
+(define-vop (if-eq)
+  (:args (x :scs (any-reg descriptor-reg immediate-stack descriptor-stack
+			  constant)
+	    :load-if (not (and (sc-is x immediate)
+			       (sc-is y any-reg descriptor-reg
+				      immediate-stack descriptor-stack
+				      constant))))
+	 (y :scs (any-reg descriptor-reg immediate)
+	    :load-if (not (and (sc-is x any-reg descriptor-reg immediate)
+			       (sc-is y immediate-stack descriptor-stack
+				      constant)))))
+  (:conditional)
+  (:info target not-p)
+  (:policy :fast-safe)
+  (:translate eq)
+  (:generator 3
+    (cond 
+     ((sc-is y immediate)
+      (let ((val (tn-value y)))
+	(etypecase val
+	  (integer
+	   (if (and (zerop val) (sc-is x any-reg descriptor-reg))
+	       (inst test x x) ; smaller
+	     (inst cmp x (fixnum val))))
+	  (symbol
+	   (inst cmp x (+ nil-value (static-symbol-offset val))))
+	  (character
+	   (inst cmp x (logior (ash (char-code val) type-bits)
+			       base-char-type))))))
+     ((sc-is x immediate) ; and y not immediate
+      ;; Swap the order to fit the compare instruction.
+      (let ((val (tn-value x)))
+	(etypecase val
+	  (integer
+	   (if (and (zerop val) (sc-is y any-reg descriptor-reg))
+	       (inst test y y) ; smaller
+	     (inst cmp y (fixnum val))))
+	  (symbol
+	   (inst cmp y (+ nil-value (static-symbol-offset val))))
+	  (character
+	   (inst cmp y (logior (ash (char-code val) type-bits)
+			       base-char-type))))))
+      (t
+       (inst cmp x y)))
+    
+    (inst jmp (if not-p :ne :e) target)))
diff --git a/compiler/x86/print.lisp b/compiler/x86/print.lisp
new file mode 100644
index 000000000..d9a5317f3
--- /dev/null
+++ b/compiler/x86/print.lisp
@@ -0,0 +1,33 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/print.lisp,v 1.1 1997/01/18 14:31:22 ram Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the print VOP, which is used while booting the kernel
+;;; core to keep the user entertained.
+;;;
+;;; Written by William Lott.
+;;;
+(in-package :x86)
+
+(define-vop (print)
+  (:args (object :scs (descriptor-reg any-reg)))
+  (:temporary (:sc dword-reg :offset eax-offset :target result
+		   :from :eval :to (:result 0))
+	      eax)
+  (:results (result :scs (descriptor-reg)))
+  (:save-p t)
+  (:generator 100
+    (inst push object)
+    (inst lea eax (make-fixup (extern-alien-name "debug_print") :foreign))
+    (inst call (make-fixup (extern-alien-name "call_into_c") :foreign))
+    (inst add esp-tn word-bytes)
+    (move result eax)))
diff --git a/compiler/x86/sap.lisp b/compiler/x86/sap.lisp
new file mode 100644
index 000000000..1bb0ca4ff
--- /dev/null
+++ b/compiler/x86/sap.lisp
@@ -0,0 +1,456 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/sap.lisp,v 1.1 1997/01/18 14:31:23 ram Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the x86 VM definition of SAP operations.
+;;;
+;;; Written by William Lott.
+;;;
+;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
+;;;
+(in-package :x86)
+
+
+;;;; Moves and coercions:
+
+;;; Move a tagged SAP to an untagged representation.
+;;;
+(define-vop (move-to-sap)
+  (:args (x :scs (descriptor-reg)))
+  (:results (y :scs (sap-reg)))
+  (:note "pointer to SAP coercion")
+  (:generator 1
+    (loadw y x sap-pointer-slot other-pointer-type)))
+;;;
+(define-move-vop move-to-sap :move
+  (descriptor-reg) (sap-reg))
+
+;;; Move an untagged SAP to a tagged representation.
+;;;
+
+(define-vop (move-from-sap)
+  (:args (sap :scs (sap-reg) :to :save))
+  (:temporary (:sc dword-reg) alloc)
+  (:results (res :scs (descriptor-reg)))
+  (:note "SAP to pointer coercion") 
+  (:generator 20
+    (with-fixed-allocation (res alloc sap-type sap-size)
+      (storew sap res sap-pointer-slot other-pointer-type))))
+	   
+;;;
+(define-move-vop move-from-sap :move
+  (sap-reg) (descriptor-reg))
+
+
+;;; Move untagged sap values.
+;;;
+(define-vop (sap-move)
+  (:args (x :target y
+	    :scs (sap-reg)
+	    :load-if (not (location= x y))))
+  (:results (y :scs (sap-reg)
+	       :load-if (not (location= x y))))
+  (:note "SAP move")
+  (:effects)
+  (:affected)
+  (:generator 0
+    (move y x)))
+
+
+;;;
+(define-move-vop sap-move :move
+  (sap-reg) (sap-reg))
+
+
+;;; Move untagged sap arguments/return-values.
+;;;
+(define-vop (move-sap-argument)
+  (:args (x :target y
+	    :scs (sap-reg))
+	 (fp :scs (any-reg)
+	     :load-if (not (sc-is y sap-reg))))
+  (:results (y))
+  (:note "SAP argument move")
+  (:generator 0
+    (sc-case y
+      (sap-reg
+       (move y x))
+      (sap-stack
+       (if (= (tn-offset fp) esp-offset)
+	   (storew x fp (tn-offset y))	; c-call
+	   (storew x fp (- (1+ (tn-offset y)))))))))
+;;;
+(define-move-vop move-sap-argument :move-argument
+  (descriptor-reg sap-reg) (sap-reg))
+
+
+;;; Use standard MOVE-ARGUMENT + coercion to move an untagged sap to a
+;;; descriptor passing location.
+;;;
+(define-move-vop move-argument :move-argument
+  (sap-reg) (descriptor-reg))
+
+
+
+;;;; SAP-INT and INT-SAP
+
+(define-vop (sap-int)
+  (:args (sap :scs (sap-reg) :target int))
+  (:arg-types system-area-pointer)
+  (:results (int :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:translate sap-int)
+  (:policy :fast-safe)
+  (:generator 1
+    (move int sap)))
+
+(define-vop (int-sap)
+  (:args (int :scs (unsigned-reg) :target sap))
+  (:arg-types unsigned-num)
+  (:results (sap :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:translate int-sap)
+  (:policy :fast-safe)
+  (:generator 1
+    (move sap int)))
+
+
+
+;;;; POINTER+ and POINTER-
+
+(define-vop (pointer+)
+  (:translate sap+)
+  (:args (ptr :scs (sap-reg) :target res)
+	 (offset :scs (signed-reg)))
+  (:arg-types system-area-pointer signed-num)
+  (:results (res :scs (sap-reg) :from (:argument 0)))
+  (:result-types system-area-pointer)
+  (:policy :fast-safe)
+  (:generator 1
+    (move res ptr)
+    (inst add res offset)))
+
+(define-vop (pointer+-c)
+  (:translate sap+)
+  (:args (ptr :scs (sap-reg) :target res))
+  (:info offset)
+  (:arg-types system-area-pointer (:constant (signed-byte 32)))
+  (:results (res :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:policy :fast-safe)
+  (:generator 1
+    (move res ptr)
+    (inst add res offset)))
+
+(define-vop (pointer-)
+  (:translate sap-)
+  (:args (ptr1 :scs (sap-reg) :target res)
+	 (ptr2 :scs (sap-reg)))
+  (:arg-types system-area-pointer system-area-pointer)
+  (:policy :fast-safe)
+  (:results (res :scs (signed-reg) :from (:argument 0)))
+  (:result-types signed-num)
+  (:generator 1
+    (move res ptr1)
+    (inst sub res ptr2)))
+
+
+
+;;;; mumble-SYSTEM-REF and mumble-SYSTEM-SET
+
+(eval-when (compile eval)
+
+(defmacro def-system-ref-and-set
+	  (ref-name set-name sc type size &optional signed)
+  (let ((ref-name-c (symbolicate ref-name "-C"))
+	(set-name-c (symbolicate set-name "-C"))
+	(temp-sc (symbolicate size "-REG")))
+    `(progn
+       (define-vop (,ref-name)
+	 (:translate ,ref-name)
+	 (:policy :fast-safe)
+	 (:args (sap :scs (sap-reg))
+		(offset :scs (unsigned-reg)))
+	 (:arg-types system-area-pointer unsigned-num)
+	 ,@(unless (eq size :dword)
+	     `((:temporary (:sc ,temp-sc :from (:eval 0) :to (:eval 1))
+			   temp)))
+	 (:results (result :scs (,sc)))
+	 (:result-types ,type)
+	 (:generator 5
+	   (inst mov ,(if (eq size :dword) 'result 'temp)
+		 (make-ea ,size :base sap :index offset))
+	   ,@(unless (eq size :dword)
+	       `((inst ,(if signed 'movsx 'movzx)
+		       result temp)))))
+       (define-vop (,ref-name-c)
+	 (:translate ,ref-name)
+	 (:policy :fast-safe)
+	 (:args (sap :scs (sap-reg)))
+	 (:arg-types system-area-pointer (:constant (signed-byte 32)))
+	 (:info offset)
+	 ,@(unless (eq size :dword)
+	     `((:temporary (:sc ,temp-sc :from (:eval 0) :to (:eval 1))
+			   temp)))
+	 (:results (result :scs (,sc)))
+	 (:result-types ,type)
+	 (:generator 4
+	   (inst mov ,(if (eq size :dword) 'result 'temp)
+		 (make-ea ,size :base sap :disp offset))
+	   ,@(unless (eq size :dword)
+	       `((inst ,(if signed 'movsx 'movzx)
+		       result temp)))))
+       (define-vop (,set-name)
+	 (:translate ,set-name)
+	 (:policy :fast-safe)
+	 (:args (sap :scs (sap-reg) :to (:eval 0))
+		(offset :scs (unsigned-reg) :to (:eval 0))
+		(value :scs (,sc)
+		       :target ,(if (eq size :dword) 'result 'temp)))
+	 (:arg-types system-area-pointer unsigned-num ,type)
+	 ,@(unless (eq size :dword)
+	     `((:temporary (:sc ,temp-sc :offset eax-offset
+				:from (:argument 2) :to (:result 0)
+				:target result)
+			   temp)))
+	 (:results (result :scs (,sc)))
+	 (:result-types ,type)
+	 (:generator 5
+	   ,@(unless (eq size :dword)
+	       `((move eax-tn value)))
+	   (inst mov (make-ea ,size :base sap :index offset)
+		 ,(if (eq size :dword) 'value 'temp))
+	   (move result ,(if (eq size :dword) 'value 'eax-tn))))
+       (define-vop (,set-name-c)
+	 (:translate ,set-name)
+	 (:policy :fast-safe)
+	 (:args (sap :scs (sap-reg) :to (:eval 0))
+		(value :scs (,sc)
+		       :target ,(if (eq size :dword) 'result 'temp)))
+	 (:arg-types system-area-pointer (:constant (signed-byte 32)) ,type)
+	 (:info offset)
+	 ,@(unless (eq size :dword)
+	     `((:temporary (:sc ,temp-sc :offset eax-offset
+				:from (:argument 2) :to (:result 0)
+				:target result)
+			   temp)))
+	 (:results (result :scs (,sc)))
+	 (:result-types ,type)
+	 (:generator 4
+	   ,@(unless (eq size :dword)
+	       `((move eax-tn value)))
+	   (inst mov (make-ea ,size :base sap :disp offset)
+		 ,(if (eq size :dword) 'value 'temp))
+	   (move result ,(if (eq size :dword) 'value 'eax-tn)))))))
+
+); eval-when (compile eval)
+
+(def-system-ref-and-set sap-ref-8 %set-sap-ref-8
+  unsigned-reg positive-fixnum :byte nil)
+(def-system-ref-and-set signed-sap-ref-8 %set-signed-sap-ref-8
+  signed-reg tagged-num :byte t)
+(def-system-ref-and-set sap-ref-16 %set-sap-ref-16
+  unsigned-reg positive-fixnum :word nil)
+(def-system-ref-and-set signed-sap-ref-16 %set-signed-sap-ref-16
+  signed-reg tagged-num :word t)
+(def-system-ref-and-set sap-ref-32 %set-sap-ref-32
+  unsigned-reg unsigned-num :dword nil)
+(def-system-ref-and-set signed-sap-ref-32 %set-signed-sap-ref-32
+  signed-reg signed-num :dword t)
+(def-system-ref-and-set sap-ref-sap %set-sap-ref-sap
+  sap-reg system-area-pointer :dword)
+
+
+;;; Sap-Ref-Double
+(define-vop (sap-ref-double)
+  (:translate sap-ref-double)
+  (:policy :fast-safe)
+  (:args (sap :scs (sap-reg))
+	 (offset :scs (unsigned-reg)))
+  (:arg-types system-area-pointer unsigned-num)
+  (:results (result :scs (double-reg)))
+  (:result-types double-float)
+  (:generator 5
+     (with-empty-tn@fp-top(result)
+        (inst fldd (make-ea :dword :base sap :index offset)))))
+
+(define-vop (sap-ref-double-c)
+  (:translate sap-ref-double)
+  (:policy :fast-safe)
+  (:args (sap :scs (sap-reg)))
+  (:arg-types system-area-pointer (:constant (signed-byte 32)))
+  (:info offset)
+  (:results (result :scs (double-reg)))
+  (:result-types double-float)
+  (:generator 4
+     (with-empty-tn@fp-top(result)
+        (inst fldd (make-ea :dword :base sap :disp offset)))))
+
+(define-vop (%set-sap-ref-double)
+  (:translate %set-sap-ref-double)
+  (:policy :fast-safe)
+  (:args (sap :scs (sap-reg) :to (:eval 0))
+	 (offset :scs (unsigned-reg) :to (:eval 0))
+	 (value :scs (double-reg)))
+  (:arg-types system-area-pointer unsigned-num double-float)
+  (:results (result :scs (double-reg)))
+  (:result-types double-float)
+  (:generator 5
+    (if (zerop (tn-offset value))
+	(progn
+	  ;; Value is in ST0
+	  (inst fstd (make-ea :dword :base sap :index offset))
+	  (unless (zerop (tn-offset result))
+	      ;; Value is in ST0 but not result.
+	      (inst fstd result)))
+      (progn
+	;; Value is not in ST0.
+	(inst fxch value)
+	(inst fstd (make-ea :dword :base sap :index offset))
+	(if (zerop (tn-offset result))
+	    ;; The result is in ST0.
+	    (inst fstd value)
+	  (progn
+	    ;; Neither value or result are in ST0
+	    (unless (location= value result)
+		  (inst fstd result))
+	    (inst fxch value)))))))
+
+(define-vop (%set-sap-ref-double-c)
+  (:translate %set-sap-ref-double)
+  (:policy :fast-safe)
+  (:args (sap :scs (sap-reg) :to (:eval 0))
+	 (value :scs (double-reg)))
+  (:arg-types system-area-pointer (:constant (signed-byte 32)) double-float)
+  (:info offset)
+  (:results (result :scs (double-reg)))
+  (:result-types double-float)
+  (:generator 4
+    (if (zerop (tn-offset value))
+	(progn
+	  ;; Value is in ST0
+	  (inst fstd (make-ea :dword :base sap :disp offset))
+	  (unless (zerop (tn-offset result))
+	      ;; Value is in ST0 but not result.
+	      (inst fstd result)))
+      (progn
+	;; Value is not in ST0.
+	(inst fxch value)
+	(inst fstd (make-ea :dword :base sap :disp offset))
+	(if (zerop (tn-offset result))
+	    ;; The result is in ST0.
+	    (inst fstd value)
+	  (progn
+	    ;; Neither value or result are in ST0
+	    (unless (location= value result)
+		  (inst fstd result))
+	    (inst fxch value)))))))
+
+
+;;; Sap-Ref-Single
+(define-vop (sap-ref-single)
+  (:translate sap-ref-single)
+  (:policy :fast-safe)
+  (:args (sap :scs (sap-reg))
+	 (offset :scs (unsigned-reg)))
+  (:arg-types system-area-pointer unsigned-num)
+  (:results (result :scs (single-reg)))
+  (:result-types single-float)
+  (:generator 5
+     (with-empty-tn@fp-top(result)
+        (inst fld (make-ea :dword :base sap :index offset)))))
+
+(define-vop (sap-ref-single-c)
+  (:translate sap-ref-single)
+  (:policy :fast-safe)
+  (:args (sap :scs (sap-reg)))
+  (:arg-types system-area-pointer (:constant (signed-byte 32)))
+  (:info offset)
+  (:results (result :scs (single-reg)))
+  (:result-types single-float)
+  (:generator 4
+     (with-empty-tn@fp-top(result)
+        (inst fld (make-ea :dword :base sap :disp offset)))))
+
+(define-vop (%set-sap-ref-single)
+  (:translate %set-sap-ref-single)
+  (:policy :fast-safe)
+  (:args (sap :scs (sap-reg) :to (:eval 0))
+	 (offset :scs (unsigned-reg) :to (:eval 0))
+	 (value :scs (single-reg)))
+  (:arg-types system-area-pointer unsigned-num single-float)
+  (:results (result :scs (single-reg)))
+  (:result-types single-float)
+  (:generator 5
+    (if (zerop (tn-offset value))
+	(progn
+	  ;; Value is in ST0
+	  (inst fst (make-ea :dword :base sap :index offset))
+	  (unless (zerop (tn-offset result))
+	      ;; Value is in ST0 but not result.
+	      (inst fst result)))
+      (progn
+	;; Value is not in ST0.
+	(inst fxch value)
+	(inst fst (make-ea :dword :base sap :index offset))
+	(if (zerop (tn-offset result))
+	    ;; The result is in ST0.
+	    (inst fst value)
+	  (progn
+	    ;; Neither value or result are in ST0
+	    (unless (location= value result)
+		  (inst fst result))
+	    (inst fxch value)))))))
+
+(define-vop (%set-sap-ref-single-c)
+  (:translate %set-sap-ref-single)
+  (:policy :fast-safe)
+  (:args (sap :scs (sap-reg) :to (:eval 0))
+	 (value :scs (single-reg)))
+  (:arg-types system-area-pointer (:constant (signed-byte 32)) single-float)
+  (:info offset)
+  (:results (result :scs (single-reg)))
+  (:result-types single-float)
+  (:generator 4
+    (if (zerop (tn-offset value))
+	(progn
+	  ;; Value is in ST0
+	  (inst fst (make-ea :dword :base sap :disp offset))
+	  (unless (zerop (tn-offset result))
+	      ;; Value is in ST0 but not result.
+	      (inst fst result)))
+      (progn
+	;; Value is not in ST0.
+	(inst fxch value)
+	(inst fst (make-ea :dword :base sap :disp offset))
+	(if (zerop (tn-offset result))
+	    ;; The result is in ST0.
+	    (inst fst value)
+	  (progn
+	    ;; Neither value or result are in ST0
+	    (unless (location= value result)
+		  (inst fst result))
+	    (inst fxch value)))))))
+
+
+;;; Noise to convert normal lisp data objects into SAPs.
+
+(define-vop (vector-sap)
+  (:translate vector-sap)
+  (:policy :fast-safe)
+  (:args (vector :scs (descriptor-reg) :target sap))
+  (:results (sap :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:generator 2
+    (move sap vector)
+    (inst add sap (- (* vector-data-offset word-bytes) other-pointer-type))))
+
diff --git a/compiler/x86/static-fn.lisp b/compiler/x86/static-fn.lisp
new file mode 100644
index 000000000..6dafb81ad
--- /dev/null
+++ b/compiler/x86/static-fn.lisp
@@ -0,0 +1,182 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/static-fn.lisp,v 1.1 1997/01/18 14:31:22 ram Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the VOPs and macro magic necessary to call static
+;;; functions.
+;;;
+;;; Written by William Lott.
+;;;
+;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
+;;;
+(in-package :x86)
+
+
+(define-vop (static-function-template)
+  (:save-p t)
+  (:policy :safe)
+  (:variant-vars function)
+  (:vop-var vop)
+  (:node-var node)
+  #+nil
+  (:temporary (:sc dword-reg :offset eax-offset) eax) ; used for call
+  (:temporary (:sc dword-reg :offset ebx-offset :from (:eval 1) :to (:eval 2))
+	      ebx)
+  (:ignore #+nil eax ebx)
+  (:temporary (:sc dword-reg :offset ecx-offset :from (:eval 0) :to (:eval 2))
+	      ecx))
+
+(eval-when (compile load eval)
+
+(defun static-function-template-name (num-args num-results)
+  (intern (format nil "~:@(~R-arg-~R-result-static-function~)"
+		  num-args num-results)))
+
+(defun moves (dst src)
+  (collect ((moves))
+    (do ((dst dst (cdr dst))
+	 (src src (cdr src)))
+	((or (null dst) (null src)))
+      (moves `(move ,(car dst) ,(car src))))
+    (moves)))
+
+(defun static-function-template-vop (num-args num-results)
+  (assert (and (<= num-args register-arg-count)
+	       (<= num-results register-arg-count))
+	  (num-args num-results)
+	  "Either too many args (~D) or too many results (~D).  Max = ~D"
+	  num-args num-results register-arg-count)
+  (let ((num-temps (max num-args num-results)))
+    (collect ((temp-names) (temps) (arg-names) (args) (result-names) (results))
+      (dotimes (i num-results)
+	(let ((result-name (intern (format nil "RESULT-~D" i))))
+	  (result-names result-name)
+	  (results `(,result-name :scs (any-reg descriptor-reg)))))
+      (dotimes (i num-temps)
+	(let ((temp-name (intern (format nil "TEMP-~D" i))))
+	  (temp-names temp-name)
+	  (temps `(:temporary (:sc dword-reg
+			       :offset ,(nth i register-arg-offsets)
+			       :from ,(if (< i num-args)
+					  `(:argument ,i)
+					  '(:eval 1))
+			       :to ,(if (< i num-results)
+					`(:result ,i)
+					'(:eval 1))
+			       ,@(when (< i num-results)
+				   `(:target ,(nth i (result-names)))))
+			      ,temp-name))))
+      (dotimes (i num-args)
+	(let ((arg-name (intern (format nil "ARG-~D" i))))
+	  (arg-names arg-name)
+	  (args `(,arg-name
+		  :scs (any-reg descriptor-reg)
+		  :target ,(nth i (temp-names))))))
+      `(define-vop (,(static-function-template-name num-args num-results)
+		    static-function-template)
+	(:args ,@(args))
+	,@(temps)
+	(:results ,@(results))
+	(:generator ,(+ 50 num-args num-results)
+	 ,@(moves (temp-names) (arg-names))
+	 ;; If speed is more important than size, duplicate the effect of
+	 ;; the ENTER with discrete instructions.  Takes 9 bytes/6 cycles
+	 ;; as opposed to 4 bytes/10 cycles.
+	 (cond ((policy node (> speed space))
+		(inst push ebp-tn)
+		(inst mov ebp-tn esp-tn)
+		(inst sub esp-tn (fixnum 3))) ; pw -- was 2
+	       (t
+		(inst enter (fixnum 3))))	; pw -- was 2
+	 ;; The enter instruction pushes EBP and then copies ESP into
+	 ;; EBP.  We want the new EBP to be the original ESP, so we fix it
+	 ;; up afterwards.
+	 (inst add ebp-tn (fixnum 1))
+	 (inst mov ecx (fixnum ,num-args))
+
+	 ;; jrd fixed it up this way, to deal with the fact that the thing in 
+	 ;; static-symbols is the fdefn
+	 ;; pfw says this is no longer true
+	 (inst mov eax-tn
+	  (make-ea :dword
+		   :disp (+ nil-value (static-function-offset function))))
+
+	 ;; Save the return address.
+	 #+x86-lra
+	 (storew (make-fixup nil :code-object return)
+		 ebp-tn (- (1+ return-pc-save-offset)))
+
+	 ;; Push the return address for backward compatability.
+	 #+x86-lra
+	 (inst push (make-ea :dword :base ebp-tn :disp -8))
+	 
+	 (note-this-location vop :call-site)
+	 #-x86-lra
+	 (inst call eax-tn)
+	 #+x86-lra
+	 (progn
+	   (inst jmp eax-tn)
+	   (align lowtag-bits #x90)
+	   (inst lra-header-word)
+	   (inst nop)
+	   (inst nop)
+	   (inst nop))
+	 #+x86-lra
+	 RETURN
+
+	 ,(collect ((bindings) (links))
+		   (do ((temp (temp-names) (cdr temp))
+			(name 'values (gensym))
+			(prev nil name)
+			(i 0 (1+ i)))
+		       ((= i num-results))
+		     (bindings `(,name
+				 (make-tn-ref ,(car temp) nil)))
+		     (when prev
+		       (links `(setf (tn-ref-across ,prev) ,name))))
+		   `(let ,(bindings)
+		     ,@(links)
+		     (default-unknown-values
+			 vop
+			 ,(if (zerop num-results) nil 'values)
+		       ,num-results)))
+	 ,@(moves (result-names) (temp-names)))))))
+
+
+) ; eval-when (compile load eval)
+
+
+(macrolet ((frob (num-args num-res)
+	     (static-function-template-vop (eval num-args) (eval num-res))))
+  (frob 0 1)
+  (frob 1 1)
+  (frob 2 1)
+  (frob 3 1))
+
+
+(defmacro define-static-function (name args &key (results '(x)) translate
+				       policy cost arg-types result-types)
+  `(define-vop (,name
+		,(static-function-template-name (length args)
+						(length results)))
+     (:variant ',name)
+     (:note ,(format nil "static-function ~@(~S~)" name))
+     ,@(when translate
+	 `((:translate ,translate)))
+     ,@(when policy
+	 `((:policy ,policy)))
+     ,@(when cost
+	 `((:generator-cost ,cost)))
+     ,@(when arg-types
+	 `((:arg-types ,@arg-types)))
+     ,@(when result-types
+	 `((:result-types ,@result-types)))))
diff --git a/compiler/x86/subprim.lisp b/compiler/x86/subprim.lisp
new file mode 100644
index 000000000..532cd7ed4
--- /dev/null
+++ b/compiler/x86/subprim.lisp
@@ -0,0 +1,93 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/subprim.lisp,v 1.1 1997/01/18 14:31:23 ram Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; Linkage information for standard static functions, and random vops.
+;;;
+;;; Written by William Lott.
+;;;
+;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
+;;; 
+(in-package :x86)
+
+
+
+;;;; Length
+
+(define-vop (length/list)
+  (:translate length)
+  (:args (object :scs (descriptor-reg descriptor-stack) :target ptr))
+  (:arg-types list)
+  (:temporary (:sc dword-reg :offset eax-offset) eax)
+  (:temporary (:sc dword-reg :from (:argument 0)) ptr)
+  (:results (count :scs (any-reg)))
+  (:result-types positive-fixnum)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 40
+    ;; Move OBJECT into a temp we can bash on, and initialize the count.
+    (move ptr object)
+    (inst xor count count)
+    ;; If we are starting with NIL, then it's real easy.
+    (inst cmp ptr nil-value)
+    (inst jmp :e done)
+    ;; Note: we don't have to test to see if the original argument is a
+    ;; list, because this is a :fast-safe vop.
+    LOOP
+    ;; Get the CDR and boost the count.
+    (loadw ptr ptr cons-cdr-slot list-pointer-type)
+    (inst add count (fixnum 1))
+    ;; If we hit NIL, then we are done.
+    (inst cmp ptr nil-value)
+    (inst jmp :e done)
+    ;; Otherwise, check to see if we hit the end of a dotted list.  If
+    ;; not, loop back for more.
+    (move eax ptr)
+    (inst and al-tn lowtag-mask)
+    (inst cmp al-tn list-pointer-type)
+    (inst jmp :e loop)
+    ;; It's dotted all right.  Flame out.
+    (error-call vop object-not-list-error ptr)
+    ;; We be done.
+    DONE))
+
+(define-vop (fast-length/list)
+  (:translate length)
+  (:args (object :scs (descriptor-reg descriptor-stack) :target ptr))
+  (:arg-types list)
+  (:temporary (:sc dword-reg :from (:argument 0)) ptr)
+  (:results (count :scs (any-reg)))
+  (:result-types positive-fixnum)
+  (:policy :fast)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 30
+    ;; Get a copy of OBJECT in a register we can bash on, and
+    ;; initialize COUNT.
+    (move ptr object)
+    (inst xor count count)
+    ;; If we are starting with NIL, we be done.
+    (inst cmp ptr nil-value)
+    (inst jmp :e done)
+    ;; Indirect the next cons cell, and boost the count.
+    LOOP
+    (loadw ptr ptr cons-cdr-slot list-pointer-type)
+    (inst add count (fixnum 1))
+    ;; If we arn't done, go back for more.
+    (inst cmp ptr nil-value)
+    (inst jmp :ne loop)
+    DONE))
+
+
+(define-static-function length (object) :translate length)
+
diff --git a/compiler/x86/system.lisp b/compiler/x86/system.lisp
new file mode 100644
index 000000000..a6c54aa78
--- /dev/null
+++ b/compiler/x86/system.lisp
@@ -0,0 +1,304 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/system.lisp,v 1.1 1997/01/18 14:31:19 ram Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; x86 VM definitions of various system hacking operations.
+;;;
+;;; Written by William Lott.
+;;;
+;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
+;;;
+
+(in-package :x86)
+
+
+;;;; Type frobbing VOPs
+
+(define-vop (get-lowtag)
+  (:translate get-lowtag)
+  (:policy :fast-safe)
+  (:args (object :scs (any-reg descriptor-reg immediate-stack descriptor-stack)
+		 :target result))
+  (:results (result :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:generator 1
+    (move result object)
+    (inst and result lowtag-mask)))
+
+(define-vop (get-type)
+  (:translate get-type)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg)))
+  (:temporary (:sc dword-reg :offset eax-offset :to (:result 0)) eax)
+  (:results (result :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:generator 6
+    (inst mov eax object)
+    (inst and al-tn lowtag-mask)
+    (inst cmp al-tn other-pointer-type)
+    (inst jmp :e other-ptr)
+    (inst cmp al-tn function-pointer-type)
+    (inst jmp :e function-ptr)
+
+    ;; pick off structures and list pointers
+    (inst test al-tn 1)
+    (inst jmp :ne done)
+
+    ;; pick off fixnums
+    (inst and al-tn 3)
+    (inst jmp :e done)
+
+    ;; must be an other immediate
+    (inst mov eax object)
+    (inst jmp done)
+    
+    FUNCTION-PTR
+    (load-type al-tn object (- vm:function-pointer-type))
+    (inst jmp done)
+    
+    OTHER-PTR
+    (load-type al-tn object (- vm:other-pointer-type))
+    
+    DONE
+    (inst movzx result al-tn)))
+
+(define-vop (function-subtype)
+  (:translate function-subtype)
+  (:policy :fast-safe)
+  (:args (function :scs (descriptor-reg)))
+  (:temporary (:sc byte-reg :from (:eval 0) :to (:eval 1)) temp)
+  (:results (result :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:generator 6
+    (load-type temp function (- vm:function-pointer-type))
+    (inst movzx result temp)))
+
+(define-vop (set-function-subtype)
+  (:translate (setf function-subtype))
+  (:policy :fast-safe)
+  (:args (type :scs (unsigned-reg) :target eax)
+	 (function :scs (descriptor-reg)))
+  (:arg-types positive-fixnum *)
+  (:temporary (:sc dword-reg :offset eax-offset :from (:argument 0)
+		   :to (:result 0) :target result)
+	      eax)
+  (:results (result :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:generator 6
+    (move eax type)
+    (inst mov
+	  (make-ea :byte :base function :disp (- function-pointer-type))
+	  al-tn)
+    (move result eax)))
+
+(define-vop (get-header-data)
+  (:translate get-header-data)
+  (:policy :fast-safe)
+  (:args (x :scs (descriptor-reg)))
+  (:results (res :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:generator 6
+    (loadw res x 0 other-pointer-type)
+    (inst shr res type-bits)))
+
+(define-vop (get-closure-length)
+  (:translate get-closure-length)
+  (:policy :fast-safe)
+  (:args (x :scs (descriptor-reg)))
+  (:results (res :scs (unsigned-reg)))
+  (:result-types positive-fixnum)
+  (:generator 6
+    (loadw res x 0 function-pointer-type)
+    (inst shr res type-bits)))
+
+(define-vop (set-header-data)
+  (:translate set-header-data)
+  (:policy :fast-safe)
+  (:args (x :scs (descriptor-reg) :target res :to (:result 0))
+	 (data :scs (any-reg) :target eax))
+  (:arg-types * positive-fixnum)
+  (:results (res :scs (descriptor-reg)))
+  (:temporary (:sc dword-reg :offset eax-offset
+		   :from (:argument 1) :to (:result 0)) eax)
+  (:generator 6
+    (move eax data)
+    (inst shl eax (- type-bits 2))
+    (inst mov al-tn (make-ea :byte :base x :disp (- other-pointer-type)))
+    (storew eax x 0 other-pointer-type)
+    (move res x)))
+
+(define-vop (make-fixnum)
+  (:args (ptr :scs (any-reg descriptor-reg) :target res))
+  (:results (res :scs (any-reg descriptor-reg)))
+  (:generator 1
+    ;;
+    ;; Some code (the hash table code) depends on this returning a
+    ;; positive number so make sure it does.
+    (move res ptr)
+    (inst shl res 3)
+    (inst shr res 1)))
+
+(define-vop (make-other-immediate-type)
+  (:args (val :scs (any-reg descriptor-reg) :target res)
+	 (type :scs (unsigned-reg immediate)))
+  (:results (res :scs (any-reg descriptor-reg) :from (:argument 0)))
+  (:generator 2
+    (move res val)
+    (inst shl res (- type-bits 2))
+    (inst or res (sc-case type
+		   (unsigned-reg type)
+		   (immediate (tn-value type))))))
+
+
+;;;; Allocation
+
+(define-vop (dynamic-space-free-pointer)
+  (:results (int :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:translate dynamic-space-free-pointer)
+  (:policy :fast-safe)
+  (:generator 1
+    (load-symbol-value int lisp::*allocation-pointer*)))
+
+(define-vop (binding-stack-pointer-sap)
+  (:results (int :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:translate binding-stack-pointer-sap)
+  (:policy :fast-safe)
+  (:generator 1
+    (load-symbol-value int lisp::*binding-stack-pointer*)))
+
+(define-vop (control-stack-pointer-sap)
+  (:results (int :scs (sap-reg)))
+  (:result-types system-area-pointer)
+  (:translate control-stack-pointer-sap)
+  (:policy :fast-safe)
+  (:generator 1
+    (move int esp-tn)))
+
+
+;;;; Code object frobbing.
+
+(define-vop (code-instructions)
+  (:translate code-instructions)
+  (:policy :fast-safe)
+  (:args (code :scs (descriptor-reg) :to (:result 0)))
+  (:results (sap :scs (sap-reg) :from (:argument 0)))
+  (:result-types system-area-pointer)
+  (:generator 10
+    (loadw sap code 0 other-pointer-type)
+    (inst shr sap type-bits)
+    (inst lea sap (make-ea :byte :base code :index sap :scale 4
+			   :disp (- other-pointer-type)))))
+
+(define-vop (compute-function)
+  (:args (code :scs (descriptor-reg) :to (:result 0))
+	 (offset :scs (signed-reg unsigned-reg) :to (:result 0)))
+  (:arg-types * positive-fixnum)
+  (:results (func :scs (descriptor-reg) :from (:argument 0)))
+  (:generator 10
+    (loadw func code 0 other-pointer-type)
+    (inst shr func type-bits)
+    (inst lea func
+	  (make-ea :byte :base offset :index func :scale 4
+		   :disp (- function-pointer-type other-pointer-type)))
+    (inst add func code)))
+
+(defknown %function-self (function) function (flushable))
+
+(define-vop (%function-self)
+  (:policy :fast-safe)
+  (:translate %function-self)
+  (:args (function :scs (descriptor-reg)))
+  (:results (result :scs (descriptor-reg)))
+  (:generator 3
+    (loadw result function function-self-slot function-pointer-type)
+    (inst lea result
+	  (make-ea :byte :base result 
+		   :disp (- function-pointer-type
+			    (* function-code-offset word-bytes))))))
+
+;;; Closure function slot is a pointer to raw code on X86 instead of
+;;; a pointer to the code function object itself. This VOP is used
+;;; to reference the function object given the closure object.
+(def-source-transform %closure-function (closure)
+  `(%function-self ,closure))
+
+(def-source-transform %funcallable-instance-function (fin)
+  `(%function-self ,fin))
+
+(defknown (setf %function-self) (function function) function  (unsafe))
+
+(define-vop (%set-function-self)
+  (:policy :fast-safe)
+  (:translate (setf %function-self))
+  (:args (new-self :scs (descriptor-reg) :target result :to :result)
+	 (function :scs (descriptor-reg) :to :result))
+  (:temporary (:sc any-reg :from (:argument 0) :to :result) temp)
+  (:results (result :scs (descriptor-reg)))
+  (:generator 3
+    (inst lea temp
+	  (make-ea :byte :base new-self
+		   :disp (- (ash function-code-offset word-shift)
+			    function-pointer-type)))
+    (storew temp function function-self-slot function-pointer-type)
+    (move result new-self)))
+
+;; Would have really liked to use a source-transform for this, but they
+;; don't work with setf functions.
+;; 
+(defknown ((setf %funcallable-instance-function)) (function function) function
+  (unsafe))
+(deftransform (setf %funcallable-instance-function) ((value fin))
+  '(setf (%function-self fin) value))
+
+
+
+;;;; Other random VOPs.
+
+(defknown unix::do-pending-interrupt () (values))
+(define-vop (unix::do-pending-interrupt)
+  (:policy :fast-safe)
+  (:translate unix::do-pending-interrupt)
+  (:generator 1
+    (inst int 3)
+    (inst byte pending-interrupt-trap)))
+
+(define-vop (halt)
+  (:generator 1
+    (inst int 3)
+    (inst byte halt-trap)))
+
+;;; bootstrapping
+(in-package :kernel)
+(export 'float-wait)
+(in-package  :x86)
+
+(defknown float-wait () (values))
+(define-vop (float-wait)
+  (:policy :fast-safe)
+  (:translate float-wait)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 1
+    (note-next-instruction vop :internal-error)
+    (inst wait)))
+
+;;;; Dynamic vop count collection support
+
+(define-vop (count-me)
+  (:args (count-vector :scs (descriptor-reg)))
+  (:info index)
+  (:generator 0
+    (inst inc (make-ea :dword :base count-vector
+		       :disp (- (* (+ vector-data-offset index) word-bytes)
+				other-pointer-type)))))
diff --git a/compiler/x86/type-vops.lisp b/compiler/x86/type-vops.lisp
new file mode 100644
index 000000000..5d8e4ddcc
--- /dev/null
+++ b/compiler/x86/type-vops.lisp
@@ -0,0 +1,599 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/type-vops.lisp,v 1.1 1997/01/18 14:31:23 ram Exp $")
+;;;
+;;; **********************************************************************
+;;; 
+;;; This file contains the VM definition of type testing and checking VOPs
+;;; for the x86.
+;;;
+;;; Written by William Lott.
+;;;
+;;; Debugged by Paul F. Werkowski, Spring-95.
+;;;
+(in-package :x86)
+
+
+
+;;;; Test generation utilities.
+
+(eval-when (compile eval)
+
+(defparameter immediate-types
+  (list unbound-marker-type base-char-type))
+
+
+(defparameter function-header-types
+  (list funcallable-instance-header-type dylan-function-header-type
+	byte-code-function-type byte-code-closure-type
+	function-header-type closure-function-header-type
+	closure-header-type))
+
+(defun canonicalize-headers (headers)
+  (collect ((results))
+    (let ((start nil)
+	  (prev nil)
+	  (delta (- other-immediate-1-type other-immediate-0-type)))
+      (flet ((emit-test ()
+	       (results (if (= start prev)
+			    start
+			    (cons start prev)))))
+	(dolist (header (sort headers #'<))
+	  (cond ((null start)
+		 (setf start header)
+		 (setf prev header))
+		((= header (+ prev delta))
+		 (setf prev header))
+		(t
+		 (emit-test)
+		 (setf start header)
+		 (setf prev header))))
+	(emit-test)))
+    (results)))
+
+(defmacro test-type (value target not-p &rest type-codes)
+  ;; Determine what interesting combinations we need to test for.
+  (let* ((type-codes (mapcar #'eval type-codes))
+	 (fixnump (and (member even-fixnum-type type-codes)
+		       (member odd-fixnum-type type-codes)
+		       t))
+	 (lowtags (remove lowtag-limit type-codes :test #'<))
+	 (extended (remove lowtag-limit type-codes :test #'>))
+	 (immediates (intersection extended immediate-types :test #'eql))
+	 (headers (set-difference extended immediate-types :test #'eql))
+	 (function-p (if (intersection headers function-header-types)
+			 (if (subsetp headers function-header-types)
+			     t
+			     (error "Can't test for mix of function subtypes ~
+				     and normal header types."))
+			 nil)))
+    (unless type-codes
+      (error "Must supply at least one type for test-type."))
+    (cond
+     (fixnump
+      (when (remove-if #'(lambda (x)
+			   (or (= x even-fixnum-type)
+			       (= x odd-fixnum-type)))
+		       lowtags)
+	(error "Can't mix fixnum testing with other lowtags."))
+      (when function-p
+	(error "Can't mix fixnum testing with function subtype testing."))
+      (when immediates
+	(error "Can't mix fixnum testing with other immediates."))
+      (if headers
+	  `(%test-fixnum-and-headers ,value ,target ,not-p
+				     ',(canonicalize-headers headers))
+	  `(%test-fixnum ,value ,target ,not-p)))
+     (immediates
+      (when headers
+	(error "Can't mix testing of immediates with testing of headers."))
+      (when lowtags
+	(error "Can't mix testing of immediates with testing of lowtags."))
+      (when (cdr immediates)
+	(error "Can't test multiple immediates at the same time."))
+      `(%test-immediate ,value ,target ,not-p ,(car immediates)))
+     (lowtags
+      (when (cdr lowtags)
+	(error "Can't test multiple lowtags at the same time."))
+      (if headers
+	  `(%test-lowtag-and-headers
+	    ,value ,target ,not-p ,(car lowtags)
+	    ,function-p ',(canonicalize-headers headers))
+	  `(%test-lowtag ,value ,target ,not-p ,(car lowtags))))
+     (headers
+      `(%test-headers ,value ,target ,not-p ,function-p
+		      ',(canonicalize-headers headers)))
+     (t
+      (error "Nothing to test?")))))
+
+
+); eval-when (compile eval)
+
+(defun %test-fixnum (value target not-p)
+  (inst test value 3)
+  (inst jmp (if not-p :nz :z) target))
+
+(defun %test-fixnum-and-headers (value target not-p headers)
+  (let ((drop-through (gen-label)))
+    (inst test value 3)
+    (inst jmp :z (if not-p drop-through target))
+    (%test-headers value target not-p nil headers drop-through)))
+
+(defun %test-immediate (value target not-p immediate)
+  (move eax-tn value)
+  (inst cmp al-tn immediate)
+  (inst jmp (if not-p :ne :e) target))
+
+(defun %test-lowtag (value target not-p lowtag &optional al-loaded)
+  (unless al-loaded
+    (move eax-tn value)
+    (inst and al-tn lowtag-mask))
+  (inst cmp al-tn lowtag)
+  (inst jmp (if not-p :ne :e) target))
+
+(defun %test-lowtag-and-headers (value target not-p lowtag function-p headers)
+  (let ((drop-through (gen-label)))
+    (%test-lowtag value (if not-p drop-through target) nil lowtag)
+    (%test-headers value target not-p function-p headers drop-through t)))
+
+
+(defun %test-headers (value target not-p function-p headers
+			    &optional (drop-through (gen-label)) al-loaded)
+  (let ((lowtag (if function-p function-pointer-type other-pointer-type)))
+    (multiple-value-bind
+	(equal less-or-equal when-true when-false)
+	;; EQUAL and LESS-OR-EQUAL are the conditions for branching to TARGET.
+	;; WHEN-TRUE and WHEN-FALSE are the labels to branch to when we know
+	;; it's true and when we know it's false respectively.
+	(if not-p
+	    (values :ne :a drop-through target)
+	    (values :e :na target drop-through))
+      (%test-lowtag value when-false t lowtag al-loaded)
+      (inst mov al-tn (make-ea :byte :base value :disp (- lowtag)))
+      (do ((remaining headers (cdr remaining)))
+	  ((null remaining))
+	(let ((header (car remaining))
+	      (last (null (cdr remaining))))
+	  (cond
+	   ((atom header)
+	    (inst cmp al-tn header)
+	    (if last
+		(inst jmp equal target)
+		(inst jmp :e when-true)))
+	   (t
+	     (let ((start (car header))
+		   (end (cdr header)))
+	       (unless (= start bignum-type)
+		 (inst cmp al-tn start)
+		 (inst jmp :b when-false)) ; was :l
+	       (inst cmp al-tn end)
+	       (if last
+		   (inst jmp less-or-equal target)
+		   (inst jmp :be when-true))))))) ; was :le
+      (emit-label drop-through))))
+
+;; pw -- based on RISC version. Not sure extra hair is needed yet.
+;; difference is that this one uses SUB which overwrites operand
+;; both cmp and sub take 2 cycles so maybe its a wash
+#+nil
+(defun %test-headers (value target not-p function-p headers
+			    &optional (drop-through (gen-label)) al-loaded)
+  (let ((lowtag (if function-p function-pointer-type other-pointer-type)))
+    (multiple-value-bind
+	(equal less-or-equal when-true when-false)
+	;; EQUAL and LESS-OR-EQUAL are the conditions for branching to TARGET.
+	;; WHEN-TRUE and WHEN-FALSE are the labels to branch to when we know
+	;; it's true and when we know it's false respectively.
+	(if not-p
+	    (values :ne :a drop-through target)
+	    (values :e :na target drop-through))
+      (%test-lowtag value when-false t lowtag al-loaded)
+      (inst mov al-tn (make-ea :byte :base value :disp (- lowtag)))
+      (let ((delta 0))
+	(do ((remaining headers (cdr remaining)))
+	    ((null remaining))
+	  (let ((header (car remaining))
+		(last (null (cdr remaining))))
+	    (cond
+	      ((atom header)
+	       (inst sub al-tn (- header delta))
+	       (setf delta header)
+	       (if last
+		   (inst jmp equal target)
+		   (inst jmp :e when-true)))
+	      (t
+	       (let ((start (car header))
+		     (end (cdr header)))
+		 (unless (= start bignum-type)
+		   (inst sub al-tn (- start delta))
+		   (setf delta start)
+		   (inst jmp :l when-false))
+		 (inst sub al-tn (- end delta))
+		 (setf delta end)
+		 (if last
+		     (inst jmp less-or-equal target)
+		     (inst jmp :le when-true))))))))
+      (emit-label drop-through))))
+
+
+;;;; Type checking and testing:
+
+(define-vop (check-type)
+  (:args (value :target result :scs (any-reg descriptor-reg)))
+  (:results (result :scs (any-reg descriptor-reg)))
+  (:temporary (:sc dword-reg :offset eax-offset :to (:result 0)) eax)
+  (:ignore eax)
+  (:vop-var vop)
+  (:save-p :compute-only))
+
+(define-vop (type-predicate)
+  (:args (value :scs (any-reg descriptor-reg)))
+  (:temporary (:sc dword-reg :offset eax-offset) eax)
+  (:ignore eax)
+  (:conditional)
+  (:info target not-p)
+  (:policy :fast-safe))
+
+(eval-when (compile eval)
+
+(defun cost-to-test-types (type-codes)
+  (+ (* 2 (length type-codes))
+     (if (> (apply #'max type-codes) lowtag-limit) 7 2)))
+
+(defmacro def-type-vops (pred-name check-name ptype error-code
+				   &rest type-codes)
+  (let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
+    `(progn
+       ,@(when pred-name
+	   `((define-vop (,pred-name type-predicate)
+	       (:translate ,pred-name)
+	       (:generator ,cost
+		 (test-type value target not-p ,@type-codes)))))
+       ,@(when check-name
+	   `((define-vop (,check-name check-type)
+	       (:generator ,cost
+		 (let ((err-lab
+			(generate-error-code vop ,error-code value)))
+		   (test-type value err-lab t ,@type-codes)
+		   (move result value))))))
+       ,@(when ptype
+	   `((primitive-type-vop ,check-name (:check) ,ptype))))))
+
+); eval-when (compile eval)
+
+(def-type-vops fixnump check-fixnum fixnum object-not-fixnum-error
+  even-fixnum-type odd-fixnum-type)
+
+(def-type-vops functionp check-function function
+  object-not-function-error function-pointer-type)
+
+(def-type-vops listp check-list list object-not-list-error
+  list-pointer-type)
+
+(def-type-vops %instancep check-instance instance object-not-instance-error
+  instance-pointer-type)
+
+(def-type-vops bignump check-bignum bignum
+  object-not-bignum-error bignum-type)
+
+(def-type-vops ratiop check-ratio ratio
+  object-not-ratio-error ratio-type)
+
+(def-type-vops complexp check-complex complex
+  object-not-complex-error complex-type)
+
+(def-type-vops single-float-p check-single-float single-float
+  object-not-single-float-error single-float-type)
+
+(def-type-vops double-float-p check-double-float double-float
+  object-not-double-float-error double-float-type)
+
+(def-type-vops simple-string-p check-simple-string simple-string
+  object-not-simple-string-error simple-string-type)
+
+(def-type-vops simple-bit-vector-p check-simple-bit-vector simple-bit-vector
+  object-not-simple-bit-vector-error simple-bit-vector-type)
+
+(def-type-vops simple-vector-p check-simple-vector simple-vector
+  object-not-simple-vector-error simple-vector-type)
+
+(def-type-vops simple-array-unsigned-byte-2-p
+  check-simple-array-unsigned-byte-2
+  simple-array-unsigned-byte-2
+  object-not-simple-array-unsigned-byte-2-error
+  simple-array-unsigned-byte-2-type)
+
+(def-type-vops simple-array-unsigned-byte-4-p
+  check-simple-array-unsigned-byte-4
+  simple-array-unsigned-byte-4
+  object-not-simple-array-unsigned-byte-4-error
+  simple-array-unsigned-byte-4-type)
+
+(def-type-vops simple-array-unsigned-byte-8-p
+  check-simple-array-unsigned-byte-8
+  simple-array-unsigned-byte-8
+  object-not-simple-array-unsigned-byte-8-error
+  simple-array-unsigned-byte-8-type)
+
+(def-type-vops simple-array-unsigned-byte-16-p
+  check-simple-array-unsigned-byte-16
+  simple-array-unsigned-byte-16
+  object-not-simple-array-unsigned-byte-16-error
+  simple-array-unsigned-byte-16-type)
+
+(def-type-vops simple-array-unsigned-byte-32-p
+  check-simple-array-unsigned-byte-32
+  simple-array-unsigned-byte-32
+  object-not-simple-array-unsigned-byte-32-error
+  simple-array-unsigned-byte-32-type)
+
+(def-type-vops simple-array-single-float-p check-simple-array-single-float
+  simple-array-single-float object-not-simple-array-single-float-error
+  simple-array-single-float-type)
+
+(def-type-vops simple-array-double-float-p check-simple-array-double-float
+  simple-array-double-float object-not-simple-array-double-float-error
+  simple-array-double-float-type)
+
+(def-type-vops base-char-p check-base-char base-char
+  object-not-base-char-error base-char-type)
+
+(def-type-vops system-area-pointer-p check-system-area-pointer
+  system-area-pointer object-not-sap-error sap-type)
+
+(def-type-vops weak-pointer-p check-weak-pointer weak-pointer
+  object-not-weak-pointer-error weak-pointer-type)
+
+(def-type-vops scavenger-hook-p nil nil nil
+  0)
+
+(def-type-vops code-component-p nil nil nil
+  code-header-type)
+
+(def-type-vops lra-p nil nil nil
+  return-pc-header-type)
+
+(def-type-vops fdefn-p nil nil nil
+  fdefn-type)
+
+(def-type-vops funcallable-instance-p nil nil nil
+  funcallable-instance-header-type)
+
+(def-type-vops array-header-p nil nil nil
+  simple-array-type complex-string-type complex-bit-vector-type
+  complex-vector-type complex-array-type)
+
+(def-type-vops nil check-function-or-symbol nil
+  object-not-function-or-symbol-error
+  function-pointer-type symbol-header-type)
+
+(def-type-vops stringp check-string nil object-not-string-error
+  simple-string-type complex-string-type)
+
+(def-type-vops bit-vector-p check-bit-vector nil object-not-bit-vector-error
+  simple-bit-vector-type complex-bit-vector-type)
+
+(def-type-vops vectorp check-vector nil object-not-vector-error
+  simple-string-type simple-bit-vector-type simple-vector-type
+  simple-array-unsigned-byte-2-type simple-array-unsigned-byte-4-type
+  simple-array-unsigned-byte-8-type simple-array-unsigned-byte-16-type
+  simple-array-unsigned-byte-32-type simple-array-single-float-type
+  simple-array-double-float-type complex-string-type
+  complex-bit-vector-type complex-vector-type)
+
+(def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error
+  simple-array-type simple-string-type simple-bit-vector-type
+  simple-vector-type simple-array-unsigned-byte-2-type
+  simple-array-unsigned-byte-4-type simple-array-unsigned-byte-8-type
+  simple-array-unsigned-byte-16-type simple-array-unsigned-byte-32-type
+  simple-array-single-float-type simple-array-double-float-type)
+
+(def-type-vops arrayp check-array nil object-not-array-error
+  simple-array-type simple-string-type simple-bit-vector-type
+  simple-vector-type simple-array-unsigned-byte-2-type
+  simple-array-unsigned-byte-4-type simple-array-unsigned-byte-8-type
+  simple-array-unsigned-byte-16-type simple-array-unsigned-byte-32-type
+  simple-array-single-float-type simple-array-double-float-type
+  complex-string-type complex-bit-vector-type complex-vector-type
+  complex-array-type)
+
+(def-type-vops numberp check-number nil object-not-number-error
+  even-fixnum-type odd-fixnum-type bignum-type ratio-type
+  single-float-type double-float-type complex-type)
+
+(def-type-vops rationalp check-rational nil object-not-rational-error
+  even-fixnum-type odd-fixnum-type ratio-type bignum-type)
+
+(def-type-vops integerp check-integer nil object-not-integer-error
+  even-fixnum-type odd-fixnum-type bignum-type)
+
+(def-type-vops floatp check-float nil object-not-float-error
+  single-float-type double-float-type)
+
+(def-type-vops realp check-real nil object-not-real-error
+  even-fixnum-type odd-fixnum-type ratio-type bignum-type
+  single-float-type double-float-type)
+
+
+;;;; Other integer ranges.
+
+;;; A (signed-byte 32) can be represented with either fixnum or a bignum with
+;;; exactly one digit.
+
+(define-vop (signed-byte-32-p type-predicate)
+  (:translate signed-byte-32-p)
+  (:generator 45
+    (multiple-value-bind
+	(yep nope)
+	(if not-p
+	    (values not-target target)
+	    (values target not-target))
+      (inst test value #x3)
+      (inst jmp :e yep)
+      (move eax-tn value)
+      (inst and al-tn lowtag-mask)
+      (inst cmp al-tn other-pointer-type)
+      (inst jmp :ne nope)
+      (loadw eax-tn value 0 other-pointer-type)
+      (inst cmp eax-tn (+ (ash 1 type-bits) bignum-type))
+      (inst jmp (if not-p :ne :e) target))
+    NOT-TARGET))
+
+(define-vop (check-signed-byte-32 check-type)
+  (:generator 45
+    (let ((nope (generate-error-code vop
+				     object-not-signed-byte-32-error
+				     value)))
+      (inst test value #x3)
+      (inst jmp :e yep)
+      (move eax-tn value)
+      (inst and al-tn lowtag-mask)
+      (inst cmp al-tn other-pointer-type)
+      (inst jmp :ne nope)
+      (loadw eax-tn value 0 other-pointer-type)
+      (inst cmp eax-tn (+ (ash 1 type-bits) bignum-type))
+      (inst jmp :ne nope))
+    YEP
+    (move result value)))
+
+;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a
+;;; bignum with exactly one positive digit, or a bignum with exactly two digits
+;;; and the second digit all zeros.
+
+(define-vop (unsigned-byte-32-p type-predicate)
+  (:translate unsigned-byte-32-p)
+  (:generator 45
+    (let ((not-target (gen-label))
+	  (single-word (gen-label))
+	  (fixnum (gen-label)))
+      (multiple-value-bind
+	  (yep nope)
+	  (if not-p
+	      (values not-target target)
+	      (values target not-target))
+	;; Is it a fixnum?
+	(inst test value 3)
+	(move eax-tn value)
+	(inst jmp :e fixnum)
+
+	;; If not, is it an other pointer?
+	(inst and al-tn lowtag-mask)
+	(inst cmp al-tn other-pointer-type)
+	(inst jmp :ne nope)
+	;; Get the header.
+	(loadw eax-tn value 0 other-pointer-type)
+	;; Is it one?
+	(inst cmp eax-tn (+ (ash 1 type-bits) bignum-type))
+	(inst jmp :e single-word)
+	;; If it's other than two, we can't be an (unsigned-byte 32)
+	(inst cmp eax-tn (+ (ash 2 type-bits) bignum-type))
+	(inst jmp :ne nope)
+	;; Get the second digit.
+	(loadw eax-tn value (1+ bignum-digits-offset) other-pointer-type)
+	;; All zeros, its an (unsigned-byte 32).
+	(inst or eax-tn eax-tn)
+	(inst jmp :z yep)
+	(inst jmp nope)
+	
+	(emit-label single-word)
+	;; Get the single digit.
+	(loadw eax-tn value bignum-digits-offset other-pointer-type)
+
+	;; positive implies (unsigned-byte 32).
+	(emit-label fixnum)
+	(inst or eax-tn eax-tn)
+	(inst jmp (if not-p :s :ns) target)
+
+	(emit-label not-target)))))
+
+(define-vop (check-unsigned-byte-32 check-type)
+  (:generator 45
+    (let ((nope
+	   (generate-error-code vop object-not-unsigned-byte-32-error value))
+	  (yep (gen-label))
+	  (fixnum (gen-label))
+	  (single-word (gen-label)))
+
+      ;; Is it a fixnum?
+      (inst test value 3)
+      (move eax-tn value)
+      (inst jmp :e fixnum)
+
+      ;; If not, is it an other pointer?
+      (inst and al-tn lowtag-mask)
+      (inst cmp al-tn other-pointer-type)
+      (inst jmp :ne nope)
+      ;; Get the header.
+      (loadw eax-tn value 0 other-pointer-type)
+      ;; Is it one?
+      (inst cmp eax-tn (+ (ash 1 type-bits) bignum-type))
+      (inst jmp :e single-word)
+      ;; If it's other than two, we can't be an (unsigned-byte 32)
+      (inst cmp eax-tn (+ (ash 2 type-bits) bignum-type))
+      (inst jmp :ne nope)
+      ;; Get the second digit.
+      (loadw eax-tn value (1+ bignum-digits-offset) other-pointer-type)
+      ;; All zeros, its an (unsigned-byte 32).
+      (inst or eax-tn eax-tn)
+      (inst jmp :z yep)
+      (inst jmp nope)
+	
+      (emit-label single-word)
+      ;; Get the single digit.
+      (loadw eax-tn value bignum-digits-offset other-pointer-type)
+
+      ;; positive implies (unsigned-byte 32).
+      (emit-label fixnum)
+      (inst or eax-tn eax-tn)
+      (inst jmp :s nope)
+
+      (emit-label yep)
+      (move result value))))
+
+
+;;;; List/symbol types:
+;;; 
+;;; symbolp (or symbol (eq nil))
+;;; consp (and list (not (eq nil)))
+
+(define-vop (symbolp type-predicate)
+  (:translate symbolp)
+  (:generator 12
+    (let ((is-symbol-label (if not-p drop-thru target)))
+      (inst cmp value nil-value)
+      (inst jmp :e is-symbol-label)
+      (test-type value target not-p symbol-header-type))
+    DROP-THRU))
+
+(define-vop (check-symbol check-type)
+  (:generator 12
+    (let ((error (generate-error-code vop object-not-symbol-error value)))
+      (inst cmp value nil-value)
+      (inst jmp :e drop-thru)
+      (test-type value error t symbol-header-type))
+    DROP-THRU
+    (move result value)))
+  
+(define-vop (consp type-predicate)
+  (:translate consp)
+  (:generator 8
+    (let ((is-not-cons-label (if not-p target drop-thru)))
+      (inst cmp value nil-value)
+      (inst jmp :e is-not-cons-label)
+      (test-type value target not-p list-pointer-type))
+    DROP-THRU))
+
+(define-vop (check-cons check-type)
+  (:generator 8
+    (let ((error (generate-error-code vop object-not-cons-error value)))
+      (inst cmp value nil-value)
+      (inst jmp :e error)
+      (test-type value error t list-pointer-type)
+      (move result value))))
diff --git a/compiler/x86/values.lisp b/compiler/x86/values.lisp
new file mode 100644
index 000000000..59d38b64f
--- /dev/null
+++ b/compiler/x86/values.lisp
@@ -0,0 +1,135 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/values.lisp,v 1.1 1997/01/18 14:31:23 ram Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the implementation of unknown-values VOPs.
+;;;
+;;; Written by William Lott.
+;;;
+;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
+;;; %more-arg-values by Douglas Thomas Crosher, March 1996.
+
+(in-package :x86)
+
+(define-vop (reset-stack-pointer)
+  (:args (ptr :scs (any-reg)))
+  (:generator 1
+    (move esp-tn ptr)))
+
+;;; Push some values onto the stack, returning the start and number of values
+;;; pushed as results.  It is assumed that the Vals are wired to the standard
+;;; argument locations.  Nvals is the number of values to push.
+;;;
+;;; The generator cost is pseudo-random.  We could get it right by defining a
+;;; bogus SC that reflects the costs of the memory-to-memory moves for each
+;;; operand, but this seems unworthwhile.
+;;;
+(define-vop (push-values)
+  (:args (vals :more t))
+  (:temporary (:sc dword-reg :to (:result 0) :target start) temp)
+  (:results (start) (count))
+  (:info nvals)
+  (:generator 20
+    (move temp esp-tn)			; WARN pointing 1 below
+    (do ((val vals (tn-ref-across val)))
+	((null val))
+      (inst push (tn-ref-tn val)))
+    (move start temp)
+    (inst mov count (fixnum nvals))))
+
+;;; Push a list of values on the stack, returning Start and Count as used in
+;;; unknown values continuations.
+;;;
+(define-vop (values-list)
+  (:args (arg :scs (descriptor-reg) :target list))
+  (:arg-types list)
+  (:policy :fast-safe)
+  (:results (start :scs (any-reg))
+	    (count :scs (any-reg)))
+  (:temporary (:sc descriptor-reg :from (:argument 0) :to (:result 1)) list)
+  (:temporary (:sc dword-reg :to (:result 1)) nil-temp)
+  (:temporary (:sc dword-reg :offset eax-offset :to (:result 1)) eax)
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 0
+    (move list arg)
+    (move start esp-tn)			; WARN pointing 1 below
+    (inst mov nil-temp nil-value)
+
+    LOOP
+    (inst cmp list nil-temp)
+    (inst jmp :e done)
+    (pushw list cons-car-slot list-pointer-type)
+    (loadw list list cons-cdr-slot list-pointer-type)
+    (inst mov eax list)
+    (inst and al-tn lowtag-mask)
+    (inst cmp al-tn list-pointer-type)
+    (inst jmp :e loop)
+    (error-call vop bogus-argument-to-values-list-error list)
+
+    DONE
+    (inst mov count start)		; start is high address
+    (inst sub count esp-tn)))		; stackp is low address
+
+;;; Copy the more arg block to the top of the stack so we can use them
+;;; as function arguments.
+;;;
+;;; Accepts a context as produced by more-arg-context; points to the first
+;;; value on the stack, not 4 bytes above as in other contexts.
+;;;
+;;; Return a context that is 4 bytes above the first value, suitable for
+;;; defining a new stack frame.
+;;;
+;;;
+(define-vop (%more-arg-values)
+  (:args (context :scs (descriptor-reg any-reg) :target src)
+         (skip :scs (any-reg immediate))
+         (num :scs (any-reg) :target count))
+  (:arg-types * positive-fixnum positive-fixnum)
+  (:temporary (:sc any-reg :offset esi-offset :from (:argument 0)) src)
+  (:temporary (:sc descriptor-reg :offset eax-offset) temp)
+  (:temporary (:sc dword-reg :offset ecx-offset) temp1)
+  (:results (start :scs (any-reg))
+            (count :scs (any-reg)))
+  (:generator 20
+    (sc-case skip
+      (immediate
+       (if (zerop (tn-value skip))
+	   (progn 
+	     (move src context)
+	     (move count num))
+	   (progn
+	     (inst lea src (make-ea :dword :base context
+				    :disp (- (* (tn-value skip) word-bytes))))
+	     (move count num)
+	     (inst sub count (* (tn-value skip) word-bytes)))))
+      
+      (any-reg
+       (move src context)
+       (inst sub src skip)
+       (move count num)
+       (inst sub count skip)))
+    
+    (move temp1 count)
+    (inst mov start esp-tn)
+    (inst jecxz done)  ; check for 0 count?
+    
+    (inst shr temp1 word-shift) ; convert the fixnum to a count.
+    
+    (inst std) ; move down the stack as more value are copied to the bottom.
+    LOOP
+    (inst lods temp)
+    (inst push temp)
+    (inst loop loop)
+    
+    DONE))
+ 
\ No newline at end of file
diff --git a/compiler/x86/vm.lisp b/compiler/x86/vm.lisp
new file mode 100644
index 000000000..e7b2b0514
--- /dev/null
+++ b/compiler/x86/vm.lisp
@@ -0,0 +1,496 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: python-x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/vm.lisp,v 1.1 1997/01/18 14:31:20 ram Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the VM defintion noise for the x86.
+;;;
+;;; Written by William Lott
+;;;
+;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
+;;;
+
+(in-package :x86)
+
+
+;;;; Register specs
+
+(eval-when (compile eval)
+
+(defmacro defreg (name offset size)
+  (let ((offset-sym (symbolicate name "-OFFSET"))
+	(names-vector (symbolicate "*" size "-REGISTER-NAMES*")))
+    `(progn
+       (eval-when (compile eval load)
+	 (defconstant ,offset-sym ,offset))
+       (setf (svref ,names-vector ,offset-sym) ,(symbol-name name)))))
+
+(defmacro defregset (name &rest regs)
+  `(eval-when (compile eval load)
+     (defconstant ,name
+       (list ,@(mapcar #'(lambda (name) (symbolicate name "-OFFSET")) regs)))))
+
+); eval-when 
+
+;;; Byte registers.
+;;;
+;;; Note: the encoding here is different then that used by the chip.  We
+;;; use this encoding so that the compiler thinks that AX (and EAX) overlap
+;;; AL and AH instead of AL and CL.
+;;; 
+(eval-when (compile load eval)
+  (defvar *byte-register-names* (make-array 8 :initial-element nil)))
+;;;
+(defreg al 0 :byte)
+(defreg ah 1 :byte)
+(defreg cl 2 :byte)
+(defreg ch 3 :byte)
+(defreg dl 4 :byte)
+(defreg dh 5 :byte)
+(defreg bl 6 :byte)
+(defreg bh 7 :byte)
+;;;
+(defregset byte-regs al ah cl ch dl dh bl bh)
+
+;;; Word registers.
+;;;
+(eval-when (compile load eval)
+  (defvar *word-register-names* (make-array 16 :initial-element nil)))
+;;;
+(defreg ax 0 :word)
+(defreg cx 2 :word)
+(defreg dx 4 :word)
+(defreg bx 6 :word)
+(defreg sp 8 :word)
+(defreg bp 10 :word)
+(defreg si 12 :word)
+(defreg di 14 :word)
+;;;
+(defregset word-regs ax cx dx bx si di)
+
+;;; Double Word registers.
+;;;
+(eval-when (compile load eval)
+  (defvar *dword-register-names* (make-array 16 :initial-element nil)))
+;;;
+(defreg eax 0 :dword)
+(defreg ecx 2 :dword)
+(defreg edx 4 :dword)
+(defreg ebx 6 :dword)
+(defreg esp 8 :dword)
+(defreg ebp 10 :dword)
+(defreg esi 12 :dword)
+(defreg edi 14 :dword)
+;;;
+(defregset dword-regs eax ecx edx ebx esi edi)
+
+;;; added by jrd
+(eval-when (compile load eval)
+  (defvar *float-register-names* (make-array 8 :initial-element nil)))
+(defreg fr0 0 :float)
+(defreg fr1 1 :float)
+(defreg fr2 2 :float)
+(defreg fr3 3 :float)
+(defreg fr4 4 :float)
+(defreg fr5 5 :float)
+(defreg fr6 6 :float)
+(defreg fr7 7 :float)
+(defregset float-regs fr0 fr1 fr2 fr3 fr4 fr5 fr6 fr7)
+
+;(defvar *double-float-register-names* (make-array 8 :initial-element nil))
+;(defreg dfr0 0 :double-float)
+;(defreg dfr1 1 :double-float)
+;(defreg dfr2 2 :double-float)
+;(defreg dfr3 3 :double-float)
+;(defreg dfr4 4 :double-float)
+;(defreg dfr5 5 :double-float)
+;(defreg dfr6 6 :double-float)
+;(defreg dfr7 7 :double-float)
+;(defregset double-float-regs dfr0 dfr1 dfr2 dfr3 dfr4 dfr5 dfr6 dfr7)
+
+
+;;;; SB definitions.
+
+;;; Despite the fact that there are only 8 different registers, we consider
+;;; them 16 in order to describe the overlap of byte registers.  The only
+;;; thing we need to represent is what registers overlap.  Therefore, we
+;;; consider bytes to take one unit, and words or dwords to take two.  We
+;;; don't need to tell the difference between words and dwords, because
+;;; you can't put two words in a dword.
+
+(define-storage-base registers :finite :size 16)
+
+;;;
+;;; jrd changed this from size 1 to size 8.  it doesn't seem to make much
+;;; sense to use the 387's idea of a stack.  8 separate registers is easier
+;;; to deal with.
+;;; (define-storage-base float-registers :finite :size 1)
+(define-storage-base float-registers :finite :size 8)
+
+(define-storage-base stack :unbounded :size 8)
+(define-storage-base constant :non-packed)
+(define-storage-base immediate-constant :non-packed)
+(define-storage-base noise :unbounded :size 2)
+
+
+
+;;;; SC definitions.
+
+;;;
+;;; Handy macro so we don't have to keep changing all the numbers whenever
+;;; we insert a new storage class.
+;;; 
+(defmacro define-storage-classes (&rest classes)
+  (collect ((forms))
+    (let ((index 0))
+      (dolist (class classes)
+	(let* ((sc-name (car class))
+	       (constant-name (symbolicate sc-name "-SC-NUMBER")))
+	  (forms `(define-storage-class ,sc-name ,index
+		    ,@(cdr class)))
+	  (forms `(defconstant ,constant-name ,index))
+	  (forms `(export ',constant-name))
+	  (incf index))))
+    `(progn
+       ,@(forms))))
+
+(define-storage-classes
+
+  ;; Non-immediate contstants in the constant pool
+  (constant constant)
+
+    ;; Some FP constants can be generated in the i387 silicon.
+
+    (fp-single-constant immediate-constant)
+    (fp-double-constant immediate-constant)
+    
+  (immediate immediate-constant)
+
+  ;; **** The stacks.
+
+  ;; The control stack.
+  (descriptor-stack stack)		; may be pointers, scanned by GC
+  (immediate-stack stack)		; isn't pointers, ignored by GC
+
+  ;; The non-descriptor stacks.
+  (signed-stack stack)			; (signed-byte 32)
+  (unsigned-stack stack)		; (unsigned-byte 32)
+  (base-char-stack stack)		; non-descriptor characters.
+  (sap-stack stack)			; System area pointers.
+  (single-stack stack)			; single-floats
+  (double-stack stack :element-size 2)	; double floats.
+
+  ;; **** Magic SCs.
+
+  (ignore-me noise)
+
+  ;; **** Things that can go in the integer registers.
+
+  ;; We don't have to distinguish between descriptor and non-descriptor
+  ;; registers, because we dump explicit information about what descriptor
+  ;; values are live at any potential GC point.  Therefore, we only different
+  ;; scs to distinguish between descriptor and non-descriptor values and
+  ;; to specify size.
+
+  (any-reg registers
+	   :locations #.dword-regs
+	   :element-size 2
+	   :reserve-locations (#.eax-offset)
+	   :constant-scs (immediate)
+	   :save-p t
+	   :alternate-scs (immediate-stack))
+
+  ;; Pointer descriptor objects.  Must be seen by GC.
+  (descriptor-reg registers
+		  :locations #.dword-regs
+		  :element-size 2
+		  :reserve-locations (#.eax-offset)
+		  :constant-scs
+		  (constant immediate 
+			    ;; zzz jrd added IMMEDIATE-STACK here.  
+			    ;; it seems right, and references elsewhere
+			    ;; in the code suggest that we expect to be
+			    ;; able to do this.  see 
+			    ;; DEFINE-MOVE-VOP MOVE :MOVE in MOVE.LISP
+			    
+			    ;; zzz this may not be right after all
+			    ;; immediate-stack
+			    )
+		  :save-p t
+		  :alternate-scs (descriptor-stack))
+
+  ;; Non-Descriptor characters
+  (base-char-reg registers
+		 :locations #.byte-regs
+		 :reserve-locations (#.ah-offset #.al-offset)
+		 :constant-scs (immediate)
+		 :save-p t
+		 :alternate-scs (base-char-stack))
+
+  ;; Non-Descriptor SAP's (arbitrary pointers into address space)
+  (sap-reg registers
+	   :locations #.dword-regs
+	   :element-size 2
+	   :reserve-locations (#.eax-offset)
+	   :constant-scs (immediate)
+	   :save-p t
+	   :alternate-scs (sap-stack))
+
+  ;; Non-Descriptor (signed or unsigned) numbers.
+  (signed-reg registers
+	      :locations #.dword-regs
+	      :element-size 2
+	      :reserve-locations (#.eax-offset)
+	      :constant-scs (immediate)
+	      :save-p t
+	      :alternate-scs (signed-stack))
+  (unsigned-reg registers
+		:locations #.dword-regs
+		:element-size 2
+		:reserve-locations (#.eax-offset)
+		:constant-scs (immediate)
+		:save-p t
+		:alternate-scs (unsigned-stack))
+
+  ;; Random objects that must not be seen by GC.  Used only as temporaries.
+  (dword-reg registers
+	     :locations #.dword-regs
+	     :element-size 2
+	     :reserve-locations (#.eax-offset))
+  (word-reg registers
+	    :locations #.word-regs
+	    :element-size 2
+	    :reserve-locations (#.ax-offset))
+  (byte-reg registers
+	    :locations #.byte-regs
+	    :reserve-locations (#.al-offset #.ah-offset))
+
+  ;; **** Things that can go in the floating point registers.
+
+  ;; Non-Descriptor single-floats.
+  (single-reg float-registers
+	      :locations (0 1 2 3 4 5 6 7)
+	      :constant-scs (fp-single-constant)
+	      :save-p t
+	      :alternate-scs (single-stack))
+
+  ;; Non-Descriptor double-floats.
+  (double-reg float-registers
+	      :locations (0 1 2 3 4 5 6 7)
+	      :constant-scs (fp-double-constant)
+	      :save-p t
+	      :alternate-scs (double-stack))
+
+  ;; A catch or unwind block.
+  (catch-block stack :element-size vm:catch-block-size)
+  
+  ;; added by jrd.  need to define non-descriptor-reg-sc-number for the
+  ;; debug code, among others.  this doesn't actually get used in any code.
+  (non-descriptor-reg registers
+		      :locations #.dword-regs
+		      :element-size 2
+		      :reserve-locations ())
+  ;; this one too
+  (interior-reg registers
+		      :locations #.dword-regs
+		      :element-size 2
+		      :reserve-locations ())
+  )
+
+;;; zzz added by jrd; has somebody been changing names of these things on me?
+(export 'control-stack-sc-number)
+(defconstant control-stack-sc-number descriptor-stack-sc-number)
+
+
+(eval-when (compile load eval)
+
+(defconstant byte-sc-names '(base-char-reg byte-reg base-char-stack))
+(defconstant word-sc-names '(word-reg))
+(defconstant dword-sc-names
+  '(any-reg descriptor-reg sap-reg signed-reg unsigned-reg dword-reg
+    descriptor-stack immediate-stack signed-stack unsigned-stack
+    sap-stack single-stack constant))
+
+;;;
+;;; added by jrd.  I guess the right thing to do is to treat floats
+;;; as a separate size...
+;;;
+;;; These are used to (at least) determine operand size.
+(defconstant float-sc-names '(single-reg))
+(defconstant double-sc-names '(double-reg double-stack))
+)
+
+
+
+;;;; Random TNs for the various registers.
+
+(eval-when (compile eval)
+  (defmacro def-random-reg-tns (sc-name &rest reg-names)
+    (collect ((forms))
+      (dolist (reg-name reg-names)
+	(let ((reg-tn-name (symbolicate reg-name "-TN"))
+	      (reg-offset-name (symbolicate reg-name "-OFFSET")))
+	  ;;(forms `(export ',reg-tn-name))
+	  (forms `(defparameter ,reg-tn-name
+		    (make-random-tn :kind :normal
+				    :sc (sc-or-lose ',sc-name)
+				    :offset ,reg-offset-name)))))
+      `(progn ,@(forms)))))
+
+(def-random-reg-tns dword-reg eax ebx ecx edx ebp esp edi esi)
+(def-random-reg-tns word-reg ax bx cx dx bp sp di si)
+(def-random-reg-tns byte-reg al ah bl bh cl ch dl dh)
+
+;; added by jrd
+(def-random-reg-tns single-reg fr0 fr1 fr2 fr3 fr4 fr5 fr6 fr7)
+
+;; Added by pw.
+
+(defparameter fp-single-constant-tn
+  (make-random-tn :kind :normal
+		  :sc (sc-or-lose 'fp-single-constant)
+		  :offset 31))		; Offset doesn't get used.
+(defparameter fp-double-constant-tn
+  (make-random-tn :kind :normal
+		  :sc (sc-or-lose 'fp-single-constant)
+		  :offset 31))
+
+
+
+
+;;; Immediate-Constant-SC
+;;;
+;;; Basically, if it's easier to represent the value as an immediate in
+;;; some instruction instead of in the constants pool, then return
+;;; the immediate SC.
+;;;
+
+#+nil ;; pw-- the way it was.
+(def-vm-support-routine immediate-constant-sc (value)
+  (if (or (and (symbolp value) (static-symbol-p value))
+	  #-cross-compiler
+	  (typep value 'fixnum)
+	  #+cross-compiler
+	  (and (typep value 'integer)
+	       (>= value (info variable constant-value 'most-negative-fixnum))
+	       (<= value (info variable constant-value 'most-positive-fixnum)))
+	  #-cross-compiler
+	  (typep value 'system-area-pointer)
+	  (typep value 
+                 #+lispworks3 'lisp::base-character 
+                 #-lispworks3 'base-char))
+      (sc-number-or-lose 'immediate *backend*)
+      nil))
+
+;;; I probably should use double-from-bits here
+;;; to avoid any compilation errors, but lets see
+;;; what happens. These should be part of lisp like PI?
+(defconstant i387-lg2 3.010299956639811952137389d0)
+(defconstant i387-ln2 0.6931471805599453094172321d0)
+(defconstant i387-l10 2.3025850929940456840179915d0)
+(defconstant i387-l2e (/ i387-ln2))
+(defconstant i387-l2t (/ i387-l10 i387-ln2))
+(export '(i387-lg2 i387-ln2 i387-l10 i387-l2e i387-l2t))
+
+
+;;; pw-- A good try and it works, but it also results in
+;;; extra consing when the constant is an argument to
+;;; some function. The descriptor from the constants vector
+;;; would normally be passed instead. DTC processes zero and
+;;; one in move-from-single|double as static symbols to
+;;; save on CV space for these common values.
+
+(def-vm-support-routine immediate-constant-sc (value)
+  (typecase value
+    ((or fixnum system-area-pointer character)
+     (sc-number-or-lose 'immediate *backend*))
+    (symbol
+     (if (static-symbol-p value)
+	 (sc-number-or-lose 'immediate *backend*)
+	 nil))
+    (single-float
+     (when (or (zerop value)
+	       (= 1s0 value))
+       (sc-number-or-lose 'fp-single-constant *backend*)))
+    (double-float
+     (when (or (zerop value)
+	       (= value 1d0)
+	       #| No longer!
+	       (= value #.pi)
+	       (= value #.i387-l2t)
+	       (= value #.i387-ln2)
+	       (= value #.i387-l2e)
+	       (= value #.i387-lg2)
+	       |#)
+       (sc-number-or-lose 'fp-double-constant *backend*)))))
+
+
+;;;; Function Call Parameters
+
+;;; Offsets of special stack frame locations
+(defconstant old-fp-save-offset 0)
+(defconstant return-pc-save-offset 1)
+(defconstant code-save-offset 2)
+
+
+;;; names of these things seem to have changed.  these aliases by jrd
+(defconstant ocfp-save-offset old-fp-save-offset)
+(defconstant lra-save-offset return-pc-save-offset)
+
+(defconstant cfp-offset ebp-offset)	; pfw - needed by stuff in /code
+					; related to sigcontext stuff
+;;; The number of arguments/return values passed in registers.
+;;;
+(defconstant register-arg-count 3)
+
+;;; Names, Offsets, and TNs to use for the argument registers.
+;;; 
+(defconstant register-arg-names '(edx edi esi))
+(defregset register-arg-offsets edx edi esi)
+(defparameter register-arg-tns (list edx-tn edi-tn esi-tn))
+
+;;; SINGLE-VALUE-RETURN-BYTE-OFFSET
+;;;
+;;; This is used by the debugger.
+;;;
+(export 'single-value-return-byte-offset)
+(defconstant single-value-return-byte-offset 2)
+
+
+;;; LOCATION-PRINT-NAME  --  Interface
+;;;
+;;;    This function is called by debug output routines that want a pretty name
+;;; for a TN's location.  It returns a thing that can be printed with PRINC.
+;;;
+(def-vm-support-routine location-print-name (tn)
+  (declare (type tn tn))
+  (let* ((sc (tn-sc tn))
+	 (sb (sb-name (sc-sb sc)))
+	 (offset (tn-offset tn)))
+    (ecase sb
+      (registers
+       (let* ((sc-name (sc-name sc))
+	      (name-vec (cond ((member sc-name byte-sc-names)
+			       *byte-register-names*)
+			      ((member sc-name word-sc-names)
+			       *word-register-names*)
+			      ((member sc-name dword-sc-names)
+			       *dword-register-names*))))
+	 (or (and name-vec
+		  (< -1 offset (length name-vec))
+		  (svref name-vec offset))
+	     (format nil "<Unknown Reg: off=~D, sc=~A>" offset sc-name))))
+      ;; (float-registers "FloatStackTop")
+      (float-registers (format nil "FR~D" offset))
+      (stack (format nil "S~D" offset))
+      (constant (format nil "Const~D" offset))
+      (immediate-constant "Immed")
+      (noise (symbol-name (sc-name sc))))))
diff --git a/hemlock/diredcoms.lisp b/hemlock/diredcoms.lisp
index 272390aa9..9ea2bfefc 100644
--- a/hemlock/diredcoms.lisp
+++ b/hemlock/diredcoms.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/diredcoms.lisp,v 1.4 1994/10/31 04:50:12 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/diredcoms.lisp,v 1.5 1997/01/18 14:31:50 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -330,8 +330,9 @@
   (declare (ignore p))
   (unless (hemlock-bound-p 'dired-information)
     (editor-error "Not in Dired buffer."))
-  (let ((dirs (pathname-directory
-	       (dired-info-pathname (value dired-information)))))
+  (let ((dirs (or (pathname-directory
+		   (dired-info-pathname (value dired-information)))
+		  '(:relative))))
     (dired-command nil
 		   (truename (make-pathname :directory (nconc dirs '(:UP)))))))
 
diff --git a/hemlock/echo.lisp b/hemlock/echo.lisp
index 6567b3110..bb4228104 100644
--- a/hemlock/echo.lisp
+++ b/hemlock/echo.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/echo.lisp,v 1.7 1994/10/31 04:50:12 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/echo.lisp,v 1.8 1997/01/18 14:31:53 ram Rel $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -176,6 +176,7 @@
 ;;; INIT-BITMAP-SCREEN-MANAGER in bit-screen.lisp adds this hook when
 ;;; initializing the bitmap screen manager.
 ;;;
+#+clx
 (defun raise-echo-area-when-modified (buffer modified)
   (when (and (value ed::raise-echo-area-when-modified)
 	     (eq buffer *echo-area-buffer*)
diff --git a/hemlock/echocoms.lisp b/hemlock/echocoms.lisp
index 65b79caec..41deba6da 100644
--- a/hemlock/echocoms.lisp
+++ b/hemlock/echocoms.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/echocoms.lisp,v 1.5 1994/10/31 04:50:12 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/echocoms.lisp,v 1.6 1997/01/18 14:31:55 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -22,15 +22,16 @@
 (defhvar "Ignore File Types"
   "File types to ignore when trying to complete a filename."
   :value
-  (list "fasl" "pmaxf" "sparcf" "rtf" "hpf" "axpf" "sgif" "err" ; Lisp
+  (list "fasl" "pmaxf" "sparcf" "rtf" "hpf" "axpf" "sgif" "err"
+	"x86f" "lbytef"	"core"		    ; Lisp
 	"BAK" "CKP"			    ; Backups & Checkpoints
 	"PS" "ps" "press" "otl" "dvi" "toc" ; Formatting
 	"bbl" "lof" "idx" "lot" "aux"	    ; Formatting
 	"mo" "elc"			    ; Other editors
 	"bin" "lbin"			    ; Obvious binary extensions.
-	"o" "a" "aout"			    ; UNIXY stuff
+	"o" "a" "aout" "out"		    ; UNIXY stuff
 	"bm" "onx" "snf"		    ; X stuff
-	"UU" "uu" "arc" "Z" "tar"	    ; Binary encoded files
+	"UU" "uu" "arc" "Z" "gz" "tar"	    ; Binary encoded files
 	))
 
 
diff --git a/hemlock/eval-server.lisp b/hemlock/eval-server.lisp
index b174c5511..bc863514b 100644
--- a/hemlock/eval-server.lisp
+++ b/hemlock/eval-server.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/eval-server.lisp,v 1.5 1995/02/16 23:04:48 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/eval-server.lisp,v 1.6 1997/01/18 14:31:52 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -724,7 +724,13 @@
 	    
       (do ((i 0 (1+ i))
 	   (frame (di:top-frame) (di:frame-down frame)))
-	  ((= i 3)
+	  (#-x86(= i 3)
+	   #+x86
+	   (and (> i 6)		; get past extra cruft
+		(let ((name (di:debug-function-name
+			     (di:frame-debug-function frame))))
+		  (and (not (string= name "Bogus stack frame"))
+		       (not (string= name "Foreign function call land")))))
 	   (prin1 (di:debug-function-name (di:frame-debug-function frame))
 		  *error-output*))
 	(unless frame (return)))
diff --git a/hemlock/input.lisp b/hemlock/input.lisp
index 710fba2bd..7d4186561 100644
--- a/hemlock/input.lisp
+++ b/hemlock/input.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/input.lisp,v 1.5 1995/02/17 21:10:51 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/input.lisp,v 1.6 1997/01/18 14:31:54 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -420,7 +420,7 @@
       (let* ((xwindow (make-xwindow-like-hwindow window))
 	     (window (make-window start :window xwindow)))
 	(unless window
-	  (xlib:destroy-window xwindow)
+	  #+clx(xlib:destroy-window xwindow)
 	  (editor-error "Could not create random typeout window."))))))
 
 (defun end-random-typeout (stream)
diff --git a/hemlock/lisp-lib.lisp b/hemlock/lisp-lib.lisp
index 8c1a60217..9b615c157 100644
--- a/hemlock/lisp-lib.lisp
+++ b/hemlock/lisp-lib.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/lisp-lib.lisp,v 1.3 1994/10/31 04:50:12 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/lisp-lib.lisp,v 1.4 1997/01/18 14:31:52 ram Rel $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -44,7 +44,7 @@
       (with-output-to-mark (s (buffer-point *selected-library-buffer*))
 	(dolist (lib-spec lib-directory)
 	  (let* ((path-parts (pathname-directory lib-spec))
-		 (last (svref path-parts (1- (length path-parts))))
+		 (last (elt path-parts (1- (length path-parts))))
 		 (raw-pathname (merge-pathnames last lib-spec)))
 	    (when (and (directoryp lib-spec)
 		       (probe-file (merge-pathnames
@@ -141,17 +141,20 @@
 						 error-msg)))
 	 (parts (pathname-directory base-name))
 	 (load-name (concatenate 'simple-string
-				 "load-" (svref parts (1- (length parts)))))
+				 "load-" (elt parts (1- (length parts)))))
 	 (load-pathname (merge-pathnames load-name base-name))
 	 (file-to-load
-	  (or (probe-file (merge-pathnames (make-pathname :type "fasl")
-					   load-pathname))
-	      (probe-file (merge-pathnames (make-pathname :type "lisp")
-					   load-pathname))
-	      (probe-file (merge-pathnames (make-pathname :type "fasl")
-					   base-name))
-	      (probe-file (merge-pathnames (make-pathname :type "lisp")
-					   base-name)))))
+	  (or
+	   (probe-file (compile-file-pathname load-pathname))
+	   (probe-file (merge-pathnames (make-pathname :type "fasl")
+					load-pathname))
+	   (probe-file (merge-pathnames (make-pathname :type "lisp")
+					load-pathname))
+	   (probe-file (compile-file-pathname base-name))
+	   (probe-file (merge-pathnames (make-pathname :type "fasl")
+					base-name))
+	   (probe-file (merge-pathnames (make-pathname :type "lisp")
+					base-name)))))
     (unless file-to-load (editor-error "You'll have to load it yourself."))
     file-to-load))
 
diff --git a/hemlock/lispeval.lisp b/hemlock/lispeval.lisp
index 47807eea0..955ace8f8 100644
--- a/hemlock/lispeval.lisp
+++ b/hemlock/lispeval.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/lispeval.lisp,v 1.4 1994/10/31 04:50:12 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/lispeval.lisp,v 1.5 1997/01/18 14:31:51 ram Rel $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -757,12 +757,11 @@
 	       (file-compile tn)))))))
 
 (defun older-or-non-existent-fasl-p (pathname &optional definitely)
-  (let ((obj-pn (probe-file (make-pathname :type "fasl" :defaults pathname))))
+  (let ((obj-pn (probe-file (compile-file-pathname pathname))))
     (or definitely
 	(not obj-pn)
 	(< (file-write-date obj-pn) (file-write-date pathname)))))
 
-
 
 ;;;; Error hacking stuff.
 
diff --git a/hemlock/rompsite.lisp b/hemlock/rompsite.lisp
index 161c59695..7c01331cc 100644
--- a/hemlock/rompsite.lisp
+++ b/hemlock/rompsite.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/rompsite.lisp,v 1.8 1994/10/31 04:50:12 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/rompsite.lisp,v 1.9 1997/01/18 14:31:48 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -264,7 +264,8 @@
 #+clx
 (defconstant font-map-size 16
   "The number of possible fonts in a font-map.")
-
+#-clx
+(defconstant font-map-size 16)
 
 ;;; SETUP-FONT-FAMILY sets *default-font-family*, opening the three font names
 ;;; passed in.  The font family structure is filled in from the first argument.
@@ -934,7 +935,7 @@
 
 (defvar old-ltchars)
 
-#+(or hpux irix)
+#+(or hpux irix freebsd)
 (progn
   (defvar old-c-iflag)
   (defvar old-c-oflag)
@@ -945,7 +946,7 @@
 (defun setup-input ()
   (let ((fd *editor-file-descriptor*))
     (when (unix:unix-isatty 0)
-      #+(or hpux irix)
+      #+(or hpux irix freebsd)
       (alien:with-alien ((tios (alien:struct unix:termios)))
 	(multiple-value-bind
 	    (val err)
@@ -991,7 +992,7 @@
 	  (when (null val)
 	    (error "Could not tcsetattr, unix error ~S."
 		   (unix:get-unix-error-msg err)))))
-      #-(or hpux irix)
+      #-(or hpux irix freebsd)
       (alien:with-alien ((sg (alien:struct unix:sgttyb)))
 	(multiple-value-bind
 	    (val err)
@@ -1002,7 +1003,7 @@
 	(let ((flags (alien:slot sg 'unix:sg-flags)))
 	  (setq old-flags flags)
 	  (setf (alien:slot sg 'unix:sg-flags)
-		(logand #-(or hpux irix) (logior flags unix:tty-cbreak)
+		(logand #-(or hpux irix freebsd) (logior flags unix:tty-cbreak)
 			(lognot unix:tty-echo)
 			(lognot unix:tty-crmod)))
 	  (multiple-value-bind
@@ -1011,7 +1012,7 @@
 	    (if (null val)
 		(error "Could not set tty information, unix error ~S."
 		       (unix:get-unix-error-msg err))))))
-      #-(or hpux irix)
+      #-(or hpux irix freebsd)
       (alien:with-alien ((tc (alien:struct unix:tchars)))
 	(multiple-value-bind
 	    (val err)
@@ -1072,7 +1073,7 @@
 (defun reset-input ()
   (when (unix:unix-isatty 0)
     (let ((fd *editor-file-descriptor*))
-      #+(or hpux irix)
+      #+(or hpux irix freebsd)
       (when (boundp 'old-c-lflag)
 	(alien:with-alien ((tios (alien:struct unix:termios)))
 	  (multiple-value-bind
@@ -1109,7 +1110,7 @@
 	    (when (null val)
 	      (error "Could not tcsetattr, unix error ~S."
 		     (unix:get-unix-error-msg err))))))
-      #-(or hpux irix)
+      #-(or hpux irix freebsd)
       (when (boundp 'old-flags)
 	(alien:with-alien ((sg (alien:struct unix:sgttyb)))
 	  (multiple-value-bind
@@ -1125,7 +1126,7 @@
 	      (unless val
 		(error "Could not set tty information, unix error ~S."
 		       (unix:get-unix-error-msg err)))))))
-      #-(or hpux irix)
+      #-(or hpux irix freebsd)
       (when (and (boundp 'old-tchars)
 		 (simple-vector-p old-tchars)
 		 (eq (length old-tchars) 6))
diff --git a/motif/lisp/initial.lisp b/motif/lisp/initial.lisp
index a82f53c93..6358c9a53 100644
--- a/motif/lisp/initial.lisp
+++ b/motif/lisp/initial.lisp
@@ -3,7 +3,9 @@
 ;;; **********************************************************************
 ;;; This code was written as part of the CMU Common Lisp project at
 ;;; Carnegie Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of CMU Common Lisp, please contact;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/motif/lisp/initial.lisp,v 1.3 1997/01/18 14:31:44 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -184,7 +186,7 @@
 	   "COMPOUND-STRING-COMPARE" "COMPOUND-STRING-CONCAT"
 	   "COMPOUND-STRING-COPY" "COMPOUND-STRING-CREATE"
 	   "COMPOUND-STRING-CREATE-LTOR" "COMPOUND-STRING-CREATE-SIMPLE"
-	   "COMPOUND-STRING-CREATE-EMPTY" "COMPOUND-STRING-CREATE-EXTENT"
+	   "COMPOUND-STRING-CREATE-EMPTY" "COMPOUND-STRING-EXTENT"
 	   "COMPOUND-STRING-FREE" "COMPOUND-STRING-HAS-SUBSTRING"
 	   "COMPOUND-STRING-HEIGHT" "COMPOUND-STRING-LENGTH"
 	   "COMPOUND-LINE-COUNT" "COMPOUND-STRING-NCONCAT"
diff --git a/motif/lisp/interface-glue.lisp b/motif/lisp/interface-glue.lisp
index de2acdc22..9d0b59d48 100644
--- a/motif/lisp/interface-glue.lisp
+++ b/motif/lisp/interface-glue.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/motif/lisp/interface-glue.lisp,v 1.3 1994/10/27 17:44:22 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/motif/lisp/interface-glue.lisp,v 1.4 1997/01/18 14:31:44 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -21,8 +21,7 @@
 ;;;; Functions for handling server requests
 
 (defvar reply-table
-  (vector :confirm :values :callback :event :error :warning :protocol :action
-	  :timeout))
+  (vector :confirm :values :callback :event :error :warning :protocol :action))
 
 (defun wait-for-server-reply (fd)
   (wait-for-input fd)
@@ -40,7 +39,6 @@
       (:protocol (handle-protocol reply))
       (:action   (handle-action reply))
       (:event    (handle-event reply))
-      (:timeout  (handle-timeout reply))
       (:error
        (let ((errmsg (toolkit-read-value reply)))
 	 (destroy-message reply)
diff --git a/motif/server/Config b/motif/server/Config
new file mode 100644
index 000000000..01fa2bcc7
--- /dev/null
+++ b/motif/server/Config
@@ -0,0 +1,4 @@
+CFLAGS = -O2 -I/usr/X11R6/include -I. -I$(VPATH)
+LDFLAGS = -L/usr/X11R6/lib
+LIBS = -static -lXm -dynamic -lXt -lXext -lX11 -lSM -lICE
+VPATH = ../../../p86/motif/server/:../../../17f/motif/server/
diff --git a/motif/server/GNUmakefile b/motif/server/GNUmakefile
index e126e313c..383217e50 100644
--- a/motif/server/GNUmakefile
+++ b/motif/server/GNUmakefile
@@ -6,7 +6,7 @@ LDFLAGS =
 TARGET = motifd
 OBJS = main.o server.o translations.o packet.o message.o datatrans.o \
        requests.o callbacks.o widgets.o resources.o tables.o motif.o \
-       text.o xmstring.o list.o events.o # timer-support.o
+       text.o xmstring.o list.o events.o
 
 include Config
 
@@ -14,7 +14,7 @@ $(TARGET) : $(OBJS)
 	$(CC) -o $(TARGET) $(LDFLAGS) $(OBJS) $(LIBS)
 
 tables.o : tables.c StringTable.h ClassTable.h TypeTable.h
-	$(CC) $(CFLAGS) -c tables.c
+	$(CC) $(CFLAGS) -c $<
 
 requests.o : requests.c Interface.h
-	$(CC) $(CFLAGS) -c requests.c
+	$(CC) $(CFLAGS) -c $<
diff --git a/motif/server/main.c b/motif/server/main.c
index f1e0a7793..29b4a905a 100644
--- a/motif/server/main.c
+++ b/motif/server/main.c
@@ -1,6 +1,6 @@
 /*
 
- $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/motif/server/main.c,v 1.7 1994/10/30 22:09:49 ram Exp $
+ $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/motif/server/main.c,v 1.8 1997/01/18 14:31:42 ram Exp $
 
  This code was written as part of the CMU Common Lisp project at
  Carnegie Mellon University, and has been placed in the public domain.
@@ -8,6 +8,7 @@
 */
 
 #include <stdio.h>
+#include <sys/param.h>		/* for define of BSD */
 #include <ctype.h>
 #include <sys/types.h>
 #include <sys/socket.h>
@@ -20,6 +21,13 @@
 
 #include <sys/wait.h>
 
+#ifdef __linux__
+#include <asm/posix_types.h>
+#define FD_ZERO __FD_ZERO
+#define FD_SET __FD_SET
+#define FD_ISSET __FD_ISSET
+#endif
+
 #ifdef SVR4
 #define bzero(a,n) memset(a, 0, n)
 #endif
@@ -52,6 +60,18 @@ int use_unix_socket=1;
 
 enum { Global, Normal, Local } socket_choice = Normal;
 
+#if defined BSD
+void bury_zombie ()
+{
+  /* This is called to handle SIGCHLD. Wait3 lets BSD lay
+   * the dead child process to rest. Otherwise it hangs 
+   * around until the server dies. During development this can
+   * eat up a lot of swap space.
+   */
+  int status;
+  wait3(&status, WNOHANG, NULL);
+}
+#endif
 void close_sockets()
 {
   close(unix_socket);
@@ -223,6 +243,9 @@ main(int argc, char **argv)
   signal(SIGHUP, server_shutdown);
   signal(SIGINT, server_shutdown);
   signal(SIGQUIT, server_shutdown);
+#if defined BSD
+  signal(SIGCHLD, bury_zombie);
+#endif
 
   printf("Waiting for connection.\n");
   fflush(stdout);
@@ -233,22 +256,23 @@ main(int argc, char **argv)
     if( use_unix_socket ) FD_SET(unix_socket, &rfds);
     if( use_inet_socket ) FD_SET(inet_socket, &rfds);
     nfound = select(nfds, &rfds, NULL, NULL, 0);
-    if( nfound < 0 )
+    if( nfound < 0 && errno != EINTR )
       main_err("main:  Unable to select on sockets.");
-
-    if( FD_ISSET(unix_socket, &rfds) ) {
-      printf("Accepting client on Unix socket.\n");
-      fflush(stdout);
-      establish_client(unix_socket);
-    }
-    if( FD_ISSET(inet_socket, &rfds) ) {
-      printf("Accepting client on Inet socket.\n");
-      fflush(stdout);
-      establish_client(inet_socket);
-    }
-    /* Prevent zombie children under Mach */
+    else {
+      if( FD_ISSET(unix_socket, &rfds) ) {
+	printf("Accepting client on Unix socket.\n");
+	fflush(stdout);
+	establish_client(unix_socket);
+      }
+      if( FD_ISSET(inet_socket, &rfds) ) {
+	printf("Accepting client on Inet socket.\n");
+	fflush(stdout);
+	establish_client(inet_socket);
+      }
+      /* Prevent zombie children under Mach */
 #ifdef MACH
-    wait3(&status,WNOHANG,NULL);
+      wait3(&status,WNOHANG,NULL);
 #endif
+    }
   }
 }
diff --git a/pcl/boot.lisp b/pcl/boot.lisp
index aeb7ba960..22fd4edfe 100644
--- a/pcl/boot.lisp
+++ b/pcl/boot.lisp
@@ -162,7 +162,7 @@ work during bootstrapping.
 ;;;
 (defmacro defgeneric (function-specifier lambda-list &body options)
   (expand-defgeneric function-specifier lambda-list options))
-
+#+nil ;; original version
 (defun expand-defgeneric (function-specifier lambda-list options)
   (when (listp function-specifier) (do-standard-defsetf-1 (cadr function-specifier)))
   (let ((initargs ()))
@@ -214,6 +214,78 @@ work during bootstrapping.
 	  *defgeneric-times*
 	  `(load-defgeneric ',function-specifier ',lambda-list ,@initargs)))))
 
+;; pw--Enhanced to support :method options.
+(defun expand-defgeneric (function-specifier lambda-list options)
+  (when (listp function-specifier)
+    (do-standard-defsetf-1 (cadr function-specifier)))
+  (let ((initargs ())
+	(methods ()))
+    (flet ((duplicate-option (name)
+	     (error "The option ~S appears more than once." name))
+	   (define-method(gf-name q-a-b)
+	     (let* ((arg-pos (position-if #'listp q-a-b))
+		    (arglist (elt q-a-b arg-pos))
+		    (qualifiers (subseq q-a-b 0 arg-pos))
+		    (body (nthcdr (1+ arg-pos) q-a-b)))
+	       (when (not (equal (cadr (getf initargs :method-combination))
+				 qualifiers))
+		 (error "Bad method specification in defgeneric ~a~%~
+			 -- qualifier mismatch for lamda list ~a"
+			gf-name arglist))
+	       `(defmethod ,gf-name ,@qualifiers ,arglist ,@body))))
+      ;;
+      ;; INITARG takes this screwy new argument to get around a bad
+      ;; interaction between lexical macros and setf in the Lucid
+      ;; compiler.
+      ;; 
+      (macrolet ((initarg (key &optional new)
+		   (if new
+		       `(setf (getf initargs ,key) ,new)
+		       `(getf initargs ,key))))
+	(dolist (option options)
+	  (ecase (car option)
+	    (:argument-precedence-order
+	      (if (initarg :argument-precedence-order)
+		  (duplicate-option :argument-precedence-order)
+		  (initarg :argument-precedence-order `',(cdr option))))
+	    (declare
+	      (initarg :declarations
+		       (append (cdr option) (initarg :declarations))))
+	    (:documentation
+	      (if (initarg :documentation)
+		  (duplicate-option :documentation)
+		  (initarg :documentation `',(cadr option))))
+	    (:method-combination
+	      (if (initarg :method-combination)
+		  (duplicate-option :method-combination)
+		  (initarg :method-combination `',(cdr option))))
+	    (:generic-function-class
+	      (if (initarg :generic-function-class)
+		  (duplicate-option :generic-function-class)
+		  (initarg :generic-function-class `',(cadr option))))
+	    (:method-class
+	      (if (initarg :method-class)
+		  (duplicate-option :method-class)
+		  (initarg :method-class `',(cadr option))))
+	    (:method
+	     #+nil
+	      (error
+		"DEFGENERIC doesn't support the :METHOD option yet.")
+	      (push (cdr option) methods))))
+
+	(let ((declarations (initarg :declarations)))
+	  (when declarations (initarg :declarations `',declarations))))
+    `(progn 
+       (proclaim-defgeneric ',function-specifier ',lambda-list)
+       ,(make-top-level-form
+	 `(defgeneric ,function-specifier)
+	 *defgeneric-times*
+	 `(load-defgeneric ',function-specifier ',lambda-list ,@initargs))
+       ,@(mapcar #'(lambda(m)(define-method `,function-specifier m))
+		 `,methods)
+
+       `,(function ,function-specifier)))))
+
 (defun load-defgeneric (function-specifier lambda-list &rest initargs)
   (when (listp function-specifier) (do-standard-defsetf-1 (cadr function-specifier)))
   (apply #'ensure-generic-function
@@ -331,7 +403,8 @@ work during bootstrapping.
 				 (let ((sv (eval (cadr s))))
 				   (or (interned-symbol-p sv)
 				       (integerp sv)
-				       (standard-char-p sv))))
+				       (and (characterp sv)
+					    (standard-char-p sv)))))
 			    (interned-symbol-p s)))
 		    specializers)
 	     (consp initargs-form)
@@ -580,6 +653,9 @@ work during bootstrapping.
   (function #'identity :type function)
   call-method-args)
 
+#+cmu
+(declaim (ext:freeze-type method-call))
+
 (defmacro invoke-method-call1 (function args cm-args)
   `(let ((.function. ,function)
 	 (.args. ,args)
@@ -601,6 +677,9 @@ work during bootstrapping.
   next-method-call
   arg-info)
 
+#+cmu
+(declaim (ext:freeze-type fast-method-call))
+
 #-akcl
 (defmacro fmc-funcall (fn pv-cell next-method-call &rest args)
   `(funcall ,fn ,pv-cell ,next-method-call ,@args))
@@ -614,6 +693,9 @@ work during bootstrapping.
 (defstruct fast-instance-boundp
   (index 0 :type fixnum))
 
+#+cmu
+(declaim (ext:freeze-type fast-instance-boundp))
+
 (eval-when (compile load eval)
 (defvar *allow-emf-call-tracing-p* nil)
 (defvar *enable-emf-call-tracing-p* #-testing nil #+testing t)
@@ -696,8 +778,9 @@ work during bootstrapping.
 	       (invoke-method-call ,emf ,restp ,@required-args+rest-arg))
 	      (function
 	       ,(if restp
-		    `(apply ,emf ,@required-args+rest-arg)
-		    `(funcall ,emf ,@required-args+rest-arg))))))))
+		    `(apply (the function ,emf) ,@required-args+rest-arg)
+		    `(funcall (the function ,emf)
+			      ,@required-args+rest-arg))))))))
 
 (defun invoke-emf (emf args)
   (trace-emf-call emf t args)
@@ -1284,7 +1367,8 @@ work during bootstrapping.
   (funcall continuation :specialize-it))
 
 (defvar *sgf-wrapper* 
-  (make-wrapper (early-class-size 'standard-generic-function)))
+  (boot-make-wrapper (early-class-size 'standard-generic-function)
+		     'standard-generic-function))
 
 (defvar *sgf-slots-init*
   (mapcar #'(lambda (canonical-slot)
@@ -1338,6 +1422,9 @@ work during bootstrapping.
   (gf-info-c-a-m-emf-std-p t)
   gf-info-fast-mf-p)
 
+#+cmu
+(declaim (ext:freeze-type arg-info))
+
 (defun arg-info-valid-p (arg-info)
   (not (null (arg-info-number-optional arg-info))))
 
@@ -1351,6 +1438,13 @@ work during bootstrapping.
 (defun arg-info-nkeys (arg-info)
   (count-if #'(lambda (x) (neq x 't)) (arg-info-metatypes arg-info)))
 
+;;; Keep pages clean by not setting if the value is already the same.
+(defmacro esetf (pos val)
+  (let ((valsym (gensym "value")))
+    `(let ((,valsym ,val))
+       (unless (equal ,pos ,valsym)
+	 (setf ,pos ,valsym)))))
+
 (defun set-arg-info (gf &key new-method (lambda-list nil lambda-list-p)
 			argument-precedence-order)
   (let* ((arg-info (if (eq *boot-state* 'complete)
@@ -1378,18 +1472,19 @@ work during bootstrapping.
                      existing methods of ~S."
 		     lambda-list gf))))
 	(when lambda-list-p
-	  (setf (arg-info-lambda-list arg-info) lambda-list))
+	  (esetf (arg-info-lambda-list arg-info) lambda-list))
 	(when (or lambda-list-p argument-precedence-order
 		  (null (arg-info-precedence arg-info)))
-	  (setf (arg-info-precedence arg-info)
-		(compute-precedence lambda-list nreq argument-precedence-order)))
-	(setf (arg-info-metatypes arg-info) (make-list nreq))
-	(setf (arg-info-number-optional arg-info) nopt)
-	(setf (arg-info-key/rest-p arg-info) (not (null (or keysp restp))))
-	(setf (arg-info-keywords arg-info) 
-	      (if lambda-list-p
-		  (if allow-other-keys-p t keywords)
-		  (arg-info-key/rest-p arg-info)))))
+	  (esetf (arg-info-precedence arg-info)
+		 (compute-precedence lambda-list nreq
+				     argument-precedence-order)))
+	(esetf (arg-info-metatypes arg-info) (make-list nreq))
+	(esetf (arg-info-number-optional arg-info) nopt)
+	(esetf (arg-info-key/rest-p arg-info) (not (null (or keysp restp))))
+	(esetf (arg-info-keywords arg-info) 
+	       (if lambda-list-p
+		   (if allow-other-keys-p t keywords)
+		   (arg-info-key/rest-p arg-info)))))
     (when new-method
       (check-method-arg-info gf arg-info new-method))
     (set-arg-info1 gf arg-info new-method methods was-valid-p first-p)
@@ -1457,41 +1552,43 @@ work during bootstrapping.
 	  (setq type (cond ((null type) new-type)
 			   ((eq type new-type) type)
 			   (t nil)))))
-      (setf (arg-info-metatypes arg-info) metatypes)
-      (setf (gf-info-simple-accessor-type arg-info) type)))
+      (esetf (arg-info-metatypes arg-info) metatypes)
+      (esetf (gf-info-simple-accessor-type arg-info) type)))
   (when (or (not was-valid-p) first-p)
     (multiple-value-bind (c-a-m-emf std-p)
 	(if (early-gf-p gf)
 	    (values t t)
 	    (compute-applicable-methods-emf gf))
-      (setf (gf-info-static-c-a-m-emf arg-info) c-a-m-emf)
-      (setf (gf-info-c-a-m-emf-std-p arg-info) std-p)
+      (esetf (gf-info-static-c-a-m-emf arg-info) c-a-m-emf)
+      (esetf (gf-info-c-a-m-emf-std-p arg-info) std-p)
       (unless (gf-info-c-a-m-emf-std-p arg-info)
-	(setf (gf-info-simple-accessor-type arg-info) t))))
+	(esetf (gf-info-simple-accessor-type arg-info) t))))
   (unless was-valid-p
     (let ((name (if (eq *boot-state* 'complete)
 		    (generic-function-name gf)
 		    (early-gf-name gf))))
-      (setf (gf-precompute-dfun-and-emf-p arg-info) 
-	    (let* ((sym (if (atom name) name (cadr name)))
-		   (pkg-list (cons *the-pcl-package* 
-				   (package-use-list *the-pcl-package*))))
-	      (and sym (symbolp sym)
-		   (not (null (memq (symbol-package sym) pkg-list)))
-		   (not (find #\space (symbol-name sym))))))))
-  (setf (gf-info-fast-mf-p arg-info)
-	(or (not (eq *boot-state* 'complete))
-	    (let* ((method-class (generic-function-method-class gf))
-		   (methods (compute-applicable-methods 
-			     #'make-method-lambda
-			     (list gf (class-prototype method-class)
-				   '(lambda) nil))))
-	      (and methods (null (cdr methods))
-		   (let ((specls (method-specializers (car methods))))
-		     (and (classp (car specls))
-			  (eq 'standard-generic-function (class-name (car specls)))
-			  (classp (cadr specls))
-			  (eq 'standard-method (class-name (cadr specls)))))))))
+      (esetf (gf-precompute-dfun-and-emf-p arg-info) 
+	     (let* ((sym (if (atom name) name (cadr name)))
+		    (pkg-list (cons *the-pcl-package* 
+				    (package-use-list *the-pcl-package*))))
+	       (and sym (symbolp sym)
+		    (not (null (memq (symbol-package sym) pkg-list)))
+		    (not (find #\space (symbol-name sym))))))))
+  (esetf (gf-info-fast-mf-p arg-info)
+	 (or (not (eq *boot-state* 'complete))
+	     (let* ((method-class (generic-function-method-class gf))
+		    (methods (compute-applicable-methods 
+			      #'make-method-lambda
+			      (list gf (class-prototype method-class)
+				    '(lambda) nil))))
+	       (and methods (null (cdr methods))
+		    (let ((specls (method-specializers (car methods))))
+		      (and (classp (car specls))
+			   (eq 'standard-generic-function
+			       (class-name (car specls)))
+			   (classp (cadr specls))
+			   (eq 'standard-method
+			       (class-name (cadr specls)))))))))
   arg-info)
 
 ;;;
@@ -1526,10 +1623,10 @@ work during bootstrapping.
      fin 
      (or function
 	 (if (eq spec 'print-object)
-	     #'(lambda (instance stream)
+	     #'(#+cmu kernel:instance-lambda #-cmu lambda (instance stream)
 		 (printing-random-thing (instance stream)
 		   (format stream "std-instance")))
-	     #'(lambda (&rest args)
+	     #'(#+cmu kernel:instance-lambda #-cmu lambda (&rest args)
 		 (declare (ignore args))
 		 (error "The function of the funcallable-instance ~S~
                          has not been set" fin)))))
@@ -2144,6 +2241,7 @@ work during bootstrapping.
 				 slots)
 			,@body))))
 
+
 (defmacro with-accessors (slots instance &body body)
   (let ((in (gensym)))
     `(let ((,in ,instance))
diff --git a/pcl/braid.lisp b/pcl/braid.lisp
index b05bd2db4..1aea28cc0 100644
--- a/pcl/braid.lisp
+++ b/pcl/braid.lisp
@@ -41,8 +41,8 @@
   #-new-kcl-wrapper
   (let ((instance (%%allocate-instance--class))
 	(no-of-slots (wrapper-no-of-instance-slots wrapper)))
-    (setf (%std-instance-wrapper instance) wrapper)
-    (setf (%std-instance-slots instance) 
+    (setf (std-instance-wrapper instance) wrapper)
+    (setf (std-instance-slots instance) 
 	  (if slots-init-p
 	      (make-array no-of-slots :initial-contents slots-init)
 	      (make-array no-of-slots :initial-element *slot-unbound*)))
@@ -75,10 +75,11 @@
 (defun allocate-funcallable-instance (wrapper &optional (slots-init nil slots-init-p))
   (let ((fin (allocate-funcallable-instance-1)))
     (set-funcallable-instance-function
-     fin #'(lambda (&rest args)
-	     (declare (ignore args))
-	     (error "The function of the funcallable-instance ~S has not been set"
-		    fin)))
+     fin
+     #'(#+cmu kernel:instance-lambda #-cmu lambda (&rest args)
+         (declare (ignore args))
+	 (error "The function of the funcallable-instance ~S has not been set"
+		fin)))
     (setf (fsc-instance-wrapper fin) wrapper
 	  (fsc-instance-slots fin) (allocate-funcallable-instance-slots
 				    wrapper slots-init-p slots-init))
@@ -113,7 +114,12 @@
 				     *the-pcl-package*)))
 		     `(setf ,wr ,(if (eq class 'standard-generic-function)
 				     '*sgf-wrapper*
-				     `(make-wrapper (early-class-size ',class)))
+				     #-cmu17
+				     `(make-wrapper (early-class-size ',class))
+				     #+cmu17
+				     `(boot-make-wrapper
+				       (early-class-size ',class)
+				       ',class))
 		            ,class (allocate-standard-instance
 				    ,(if (eq class 'standard-generic-function)
 					 'funcallable-standard-class-wrapper
@@ -197,7 +203,11 @@
 				   class-eq-specializer-wrapper)
 				  ((eq class standard-generic-function)
 				   standard-generic-function-wrapper)
-				  (t (make-wrapper (length slots) class))))
+				  (t
+				   #-cmu17
+				   (make-wrapper (length slots) class)
+				   #+cmu17
+				   (boot-make-wrapper (length slots) name))))
 		   (proto nil))
 	      (when (eq name 't) (setq *the-wrapper-of-t* wrapper))
 	      (set (intern (format nil "*THE-CLASS-~A*" (symbol-name name))
@@ -207,10 +217,11 @@
 		(unless (eq (getf slot :allocation :instance) :instance)
 		  (error "Slot allocation ~S not supported in bootstrap.")))
 	      
-	      (setf (wrapper-instance-slots-layout wrapper)
-		    (mapcar #'canonical-slot-name slots))
-	      (setf (wrapper-class-slots wrapper)
-		    ())
+	      (when #+cmu17 (typep wrapper 'wrapper) #-cmu17 t
+		(setf (wrapper-instance-slots-layout wrapper)
+		      (mapcar #'canonical-slot-name slots))
+		(setf (wrapper-class-slots wrapper)
+		      ()))
 	      
 	      (setq proto (if (eq meta 'funcallable-standard-class)
 			      (allocate-funcallable-instance wrapper)
@@ -460,10 +471,15 @@
     (dolist (e *built-in-classes*)
       (destructuring-bind (name supers subs cpl prototype) e
 	(let* ((class (find-class name))
-	       (wrapper (make-wrapper 0 class)))
+	       #+cmu17
+	       (lclass (lisp:find-class name))
+	       (wrapper #-cmu17(make-wrapper 0 class)
+			#+cmu17(kernel:class-layout lclass)))
 	  (set (get-built-in-class-symbol name) class)
 	  (set (get-built-in-wrapper-symbol name) wrapper)
-
+	  #+cmu17
+	  (setf (kernel:class-pcl-class lclass) class)
+	  #-cmu17
 	  (setf (wrapper-instance-slots-layout wrapper) ()
 		(wrapper-class-slots wrapper) ())
 
@@ -483,7 +499,7 @@
 ;;;
 ;;;
 ;;;
-#-new-kcl-wrapper
+#-(or new-kcl-wrapper cmu17)
 (progn
 (defvar *built-in-or-structure-wrapper-table*
   (make-hash-table :test 'eq))
@@ -541,6 +557,7 @@
 	     (built-in-or-structure-wrapper1 ,x)))))
 ||#
 
+#-cmu17
 (defmacro wrapper-of-macro (x)
   `(cond ((std-instance-p ,x)
 	  (std-instance-wrapper ,x))
@@ -551,12 +568,19 @@
 	   #-new-kcl-wrapper built-in-or-structure-wrapper
 	   ,x))))
 
+#+cmu17
+(defmacro wrapper-of-macro (x)
+  `(kernel:layout-of ,x))
+
 (defun class-of (x)
   (wrapper-class* (wrapper-of-macro x)))
 
+#+cmu17
+(declaim (inline wrapper-of))
 (defun wrapper-of (x)
   (wrapper-of-macro x))
 
+#-cmu17
 (defun structure-wrapper (x)
   (class-wrapper (find-class (structure-type x))))
 
@@ -582,13 +606,18 @@
 			:metaclass 'structure-class
 			:name symbol
 			:direct-superclasses
-			(when (structure-type-included-type-name symbol)
-			  (list (structure-type-included-type-name symbol)))
+			(cond ((lisp:subtypep symbol 'condition)
+			       (list (lisp:class-name
+				      (first (kernel:class-direct-superclasses
+					      (lisp:find-class symbol))))))
+			      ((structure-type-included-type-name symbol)
+			       (list (structure-type-included-type-name symbol))))
 			:direct-slots
 			(mapcar #'slot-initargs-from-structure-slotd
 				(structure-type-slot-description-list symbol)))))
       (error "~S is not a legal structure class name." symbol)))
 
+#-cmu17
 (eval-when (compile eval)
 
 (defun make-built-in-class-subs ()
@@ -631,6 +660,7 @@
 		 symbol)))))
 )
 
+#-cmu17
 (defun built-in-wrapper-of (x)
   #.(when (fboundp 'make-built-in-wrapper-of-body) ; so we can at least read this file
       (make-built-in-wrapper-of-body)))
@@ -676,6 +706,20 @@
 	(add-method gf class-method)))
     gf))
 
+
+#+cmu17
+;;; Set inherits from CPL and register layout.  This actually installs the
+;;; class in the lisp type system.
+;;;
+(defun update-lisp-class-layout (class layout)
+  (unless (eq (kernel:class-layout (kernel:layout-class layout))
+	      layout)
+    (setf (kernel:layout-inherits layout)
+	  (map 'vector #'class-wrapper
+	       (reverse (rest (class-precedence-list class)))))
+
+    (kernel:register-layout layout :invalidate nil)))
+
 (eval-when (load eval)
   (clrhash *find-class*)
   (bootstrap-meta-braid)
@@ -684,9 +728,29 @@
   (bootstrap-accessor-definitions nil)
   (bootstrap-class-predicates nil)
   (bootstrap-built-in-classes)
+
+  #+cmu17
+  (ext:do-hash (name x *find-class*)
+    (let* ((class (find-class-from-cell name x))
+	   (layout (class-wrapper class))
+	   (lclass (kernel:layout-class layout))
+	   (lclass-pcl-class (kernel:class-pcl-class lclass))
+	   (olclass (lisp:find-class name nil)))
+      (if lclass-pcl-class
+	  (assert (eq class lclass-pcl-class))
+	  (setf (kernel:class-pcl-class lclass) class))
+
+      (update-lisp-class-layout class layout)
+
+      (cond (olclass
+	     (assert (eq lclass olclass)))
+	    (t
+	     (setf (lisp:find-class name) lclass)))))
+
   (setq *boot-state* 'braid)
   )
 
+#-cmu17
 (deftype slot-object ()
   '(or standard-object structure-object))
 
diff --git a/pcl/cmu-low.lisp b/pcl/cmu-low.lisp
index 87bceaa3a..6b65568fa 100644
--- a/pcl/cmu-low.lisp
+++ b/pcl/cmu-low.lisp
@@ -29,6 +29,10 @@
 
 (in-package :pcl)
 
+#+small
+(setq *optimize-speed*
+      '(optimize (speed 3) (safety 0) (debug 0.5) (ext:inhibit-warnings 3)))
+		 
 (defmacro dotimes ((var count &optional (result nil)) &body body)
   `(lisp:dotimes (,var (the fixnum ,count) ,result)
      (declare (fixnum ,var))
@@ -40,19 +44,6 @@
 (defmacro without-interrupts (&rest stuff)
   `(sys:without-interrupts ,@stuff))
 
-
-;;; Print the object addr in default printers.
-;;;
-(defun printing-random-thing-internal (thing stream)
-  (format stream "{~X}" (sys:%primitive c:make-fixnum thing)))
-
-
-(eval-when (compile load eval)
-  (c:def-source-transform std-instance-p (x)
-    (ext:once-only ((n-x x))
-      `(and (ext:structurep ,n-x)
-            (eq (kernel:structure-ref ,n-x 0) 'std-instance)))))
-
 (defun function-arglist (fcn)
   "Returns the argument list of a compiled function, if possible."
   (cond ((symbolp fcn)
@@ -64,38 +55,59 @@
          (let ((lambda-expr (function-lambda-expression fcn)))
            (if lambda-expr
                (cadr lambda-expr)
-               (let ((function (kernel:%closure-function fcn)))
-                 (values (read-from-string
-                          (kernel:%function-header-arglist function)))))))))
-
-
-;;; We have this here and in fin.lisp, 'cause PCL wants to compile this
-;;; file first.
-;;; 
-(defsetf funcallable-instance-name set-funcallable-instance-name)
+               (let* ((function (kernel:%closure-function fcn))
+		      (arglist-string (kernel:%function-arglist function)))
+		 (when arglist-string
+		       (values (read-from-string arglist-string)))))))))
 
 ;;; And returns the function, not the *name*.
 (defun set-function-name (fcn new-name)
   "Set the name of a compiled function object."
+  (declare (special *boot-state* *the-class-standard-generic-function*))
   (cond ((symbolp fcn)
          (set-function-name (symbol-function fcn) new-name))
         ((funcallable-instance-p fcn)
-         (setf (funcallable-instance-name fcn) new-name)
+	 (if (if (eq *boot-state* 'complete)
+		 (typep fcn 'generic-function)
+		 (eq (class-of fcn) *the-class-standard-generic-function*))
+	     (setf (kernel:%funcallable-instance-info fcn 1) new-name)
+	     (typecase fcn
+	       (kernel:byte-closure
+		(set-function-name (kernel:byte-closure-function fcn) new-name))
+	       (kernel:byte-function
+		(setf (kernel:byte-function-name fcn) new-name))))
          fcn)
         ((eval:interpreted-function-p fcn)
          (setf (eval:interpreted-function-name fcn) new-name)
          fcn)
         (t
+	 ;; pw-- This seems wrong and causes trouble. Tests show
+	 ;; that loading CL-HTTP resulted in ~5400 closures being
+	 ;; passed through this code of which ~4000 of them pointed
+	 ;; to but 16 closure-functions, including 1015 each of
+	 ;; DEFUN MAKE-OPTIMIZED-STD-WRITER-METHOD-FUNCTION
+	 ;; DEFUN MAKE-OPTIMIZED-STD-READER-METHOD-FUNCTION
+	 ;; DEFUN MAKE-OPTIMIZED-STD-BOUNDP-METHOD-FUNCTION.
+	 ;; Since the actual functions have been moved by PURIFY
+	 ;; to memory not seen by GC, changing a pointer there
+	 ;; not only clobbers the last change but leaves a dangling
+	 ;; pointer invalid  after the next GC. Comments in low.lisp
+	 ;; indicate this code need do nothing. Setting the
+	 ;; function-name to NIL loses some info, and not changing
+	 ;; it loses some info of potential hacking value. So,
+	 ;; lets not do this...
+	 #+nil
          (let ((header (kernel:%closure-function fcn)))
 	   #+cmu17
 	   (setf (c::%function-name header) new-name)
 	   #-cmu17
            (system:%primitive c::set-function-name header new-name))
+
+	 ;; Maybe add better scheme here someday.
 	 fcn)))
 
 (in-package "C")
 
-;;From compiler/ir1util
 (def-source-context pcl:defmethod (name &rest stuff)
   (let ((arg-pos (position-if #'listp stuff)))
     (if arg-pos
@@ -104,356 +116,64 @@
 			  (elt stuff arg-pos))))
 	`(pcl:defmethod ,name "<illegal syntax>"))))
 
-(define-info-type type kind (member :primitive :defined :structure :class nil)
-  (if (or (info type builtin name)
-	  (info type translator name))
-      :primitive
-      nil))
-(define-info-type type class-info (or pcl::class symbol null) nil)
-
-(in-package "KERNEL")
-
-(export '(clos-type clos-type-class))
-
-(defmacro cold-load-init (&rest forms)
-  `(progn ,@forms))
-
-(defstruct (clos-type (:include ctype
-				 (:class-info (type-class-or-lose 'clos))
-				 (:enumerable t))
-		       (:print-function %print-type))
-  ;;
-  ;; The CLOS class.
-  (class nil))
-
-(define-type-class clos)
-
-(define-type-method (clos :unparse) (x)
-  (clos-type-class x))
-
-(define-type-method (clos :complex-union) (type1 type2)
-  (make-union-type (list type1 type2)))
-
-(define-type-method (clos :simple-=) (type1 type2)
-  (values (eq (clos-type-class type1)
-	      (clos-type-class type2))
-	  t))
-
-(define-type-method (clos :simple-subtypep) (type1 type2)
-  (let ((class1 (pcl:find-class (clos-type-class type1) nil))
-	(class2 (pcl:find-class (clos-type-class type2) nil)))
-    (if (and class1 class2)
-	(values (member class2
-			(pcl:class-precedence-list class2))  t)
-      (values nil nil))))
-
-;; Add the new ctype to its supertypes.
-;;
-(let ((the-type-* (values-specifier-type '*)))
-  (pushnew 'clos (named-type-subclasses the-type-*)))
-(let ((the-type-t (values-specifier-type 't)))
-  (pushnew 'clos (named-type-subclasses the-type-t)))
-
-(defun-cached (values-specifier-type
-	       :hash-function (lambda (x)
-				(the fixnum
-				     (logand (the fixnum (cache-hash-eq x))
-					     #x3FF)))
-	       :hash-bits 10)
-    ((spec eq))
-  (or (info type builtin spec)
-      (let ((expand (type-expand spec)))
-	(if (eq expand spec)
-	    (let* ((lspec (if (atom spec) (list spec) spec))
-		   (fun (info type translator (car lspec))))
-	      (cond
-		(fun (funcall fun lspec))
-		((and (symbolp spec)
-		      (eq (info type kind spec) :structure))
-		 (make-structure-type :name spec))
-		((and (symbolp spec)
-		      (eq (info type kind spec) :class))
-		 (make-clos-type :class spec))
-		((or (and (consp spec) (symbolp (car spec)))
-		     (symbolp spec))
-		 (signal 'parse-unknown-type :specifier spec)
-		 ;;
-		 ;; Inhibit caching...
-		 (return-from values-specifier-type
-		   (make-unknown-type :specifier spec)))
-		(t
-		 (error "Bad thing to be a type specifier: ~S."
-			spec))))
-	    (values-specifier-type expand)))))
-
-(defun ctypep (obj type)
-  (declare (type ctype type))
-  (etypecase type
-    ((or numeric-type named-type member-type array-type)
-     (values (typep obj (type-specifier type)) t))
-    (structure-type
-     (if (structurep obj)
-	 (let* ((name (structure-type-name type))
-		(info (info type structure-info name))
-		(defined-info (info type defined-structure-info name)))
-	   (if (and info defined-info
-		    (equal (c::dd-includes info)
-			   (c::dd-includes defined-info)))
-	       (values (typep obj name) t)
-	       (values nil nil)))
-	 (values nil t)))
-    (clos-type
-     (let ((class (clos-type-class type)))
-       (if (pcl::std-instance-p obj)
-	   (values (pcl::*typep obj class) t)
-	   (values nil t))))
-    (union-type
-     (dolist (mem (union-type-types type) (values nil t))
-       (multiple-value-bind (val win)
-			    (ctypep obj mem)
-	 (unless win (return (values nil nil)))
-	 (when val (return (values t t))))))
-    (function-type
-     (values (functionp obj) t))
-    (unknown-type
-     (values nil nil))
-    (alien-type-type
-     (values (alien-typep obj (alien-type-type-alien-type type)) t))
-    (hairy-type
-     ;; Now the tricky stuff.
-     (let* ((hairy-spec (hairy-type-specifier type))
-	    (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec)))
-       (ecase symbol
-	 (and
-	  (if (atom hairy-spec)
-	      (values t t)
-	      (dolist (spec (cdr hairy-spec) (values t t))
-		(multiple-value-bind (res win)
-				     (ctypep obj (specifier-type spec))
-		  (unless win (return (values nil nil)))
-		  (unless res (return (values nil t)))))))
-	 (not
-	  (multiple-value-bind
-	      (res win)
-	      (ctypep obj (specifier-type (cadr hairy-spec)))
-	    (if win
-		(values (not res) t)
-		(values nil nil))))
-	 (satisfies
-	  (let ((fun (second hairy-spec)))
-	    (cond ((and (consp fun) (eq (car fun) 'lambda))
-		   (values (not (null (funcall (coerce fun 'function) obj)))
-			   t))
-		  ((and (symbolp fun) (fboundp fun))
-		   (values (not (null (funcall fun obj))) t))
-		  (t
-		   (values nil nil))))))))))
-
-(in-package "LISP")
-
-(defun %%typep (object type)
-  (declare (type ctype type))
-  (etypecase type
-    (named-type
-     (ecase (named-type-name type)
-       ((* t)
-	t)
-       ((nil)
-	nil)
-       (character (characterp object))
-       (base-char (base-char-p object))
-       (standard-char (and (characterp object) (standard-char-p object)))
-       (extended-char
-	(and (characterp object) (not (base-char-p object))))
-       (function (functionp object))
-       (cons (consp object))
-       (symbol (symbolp object))
-       (keyword
-	(and (symbolp object)
-	     (eq (symbol-package object)
-		 (symbol-package :foo))))
-       (system-area-pointer (system-area-pointer-p object))
-       (weak-pointer (weak-pointer-p object))
-       (code-component (code-component-p object))
-       (lra (lra-p object))
-       (fdefn (fdefn-p object))
-       (scavenger-hook (scavenger-hook-p object))
-       (structure (structurep object))))
-    (numeric-type
-     (and (numberp object)
-	  (let ((num (if (complexp object) (realpart object) object)))
-	    (ecase (numeric-type-class type)
-	      (integer (integerp num))
-	      (rational (rationalp num))
-	      (float
-	       (ecase (numeric-type-format type)
-		 (short-float (typep object 'short-float))
-		 (single-float (typep object 'single-float))
-		 (double-float (typep object 'double-float))
-		 (long-float (typep object 'long-float))
-		 ((nil) (floatp num))))
-	      ((nil) t)))
-	  (flet ((bound-test (val)
-			     (let ((low (numeric-type-low type))
-				   (high (numeric-type-high type)))
-			       (and (cond ((null low) t)
-					  ((listp low) (> val (car low)))
-					  (t (>= val low)))
-				    (cond ((null high) t)
-					  ((listp high) (< val (car high)))
-					  (t (<= val high)))))))
-	    (ecase (numeric-type-complexp type)
-	      ((nil) t)
-	      (:complex
-	       (and (complexp object)
-		    (bound-test (realpart object))
-		    (bound-test (imagpart object))))
-	      (:real
-	       (and (not (complexp object))
-		    (bound-test object)))))))
-    (array-type
-     (and (arrayp object)
-	  (ecase (array-type-complexp type)
-	    ((t) (not (typep object 'simple-array)))
-	    ((nil) (typep object 'simple-array))
-	    (* t))
-	  (or (eq (array-type-dimensions type) '*)
-	      (do ((want (array-type-dimensions type) (cdr want))
-		   (got (array-dimensions object) (cdr got)))
-		  ((and (null want) (null got)) t)
-		(unless (and want got
-			     (or (eq (car want) '*)
-				 (= (car want) (car got))))
-		  (return nil))))
-	  (or (eq (array-type-element-type type) *wild-type*)
-	      (type= (array-type-specialized-element-type type)
-		     (specifier-type (array-element-type object))))))
-    (member-type
-     (if (member object (member-type-members type)) t))
-    (structure-type
-     (structure-typep object (structure-type-name type)))
-    (clos-type
-     (pcl::*typep object (clos-type-class type)))
-    (union-type
-     (dolist (type (union-type-types type))
-       (when (%%typep object type)
-	 (return t))))
-    (unknown-type
-     ;; Type may be unknown to the compiler (and SPECIFIER-TYPE), yet be
-     ;; a defined structure in the core.
-     (let ((orig-spec (unknown-type-specifier type)))
-       (if (and (symbolp orig-spec)
-		(info type defined-structure-info orig-spec))
-	   (structure-typep object orig-spec)
-	   (error "Unknown type specifier: ~S" orig-spec))))
-    (hairy-type
-     ;; Now the tricky stuff.
-     (let* ((hairy-spec (hairy-type-specifier type))
-	    (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec)))
-       (ecase symbol
-	 (and
-	  (or (atom hairy-spec)
-	      (dolist (spec (cdr hairy-spec) t)
-		(unless (%%typep object (specifier-type spec))
-		  (return nil)))))
-	 (not
-	  (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
-	    (error "Invalid type specifier: ~S" hairy-spec))
-	  (not (%%typep object (specifier-type (cadr hairy-spec)))))
-	 (satisfies
-	  (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
-	    (error "Invalid type specifier: ~S" hairy-spec))
-	  (let ((fn (cadr hairy-spec)))
-	    (if (funcall (typecase fn
-			   (function fn)
-			   (symbol (symbol-function fn))
-			   (t
-			    (coerce fn 'function)))
-			 object)
-		t
-		nil))))))
-    (alien-type-type
-     (alien-internals:alien-typep object (alien-type-type-alien-type type)))
-    (function-type
-     (error "Function types are not a legal argument to TYPEP:~%  ~S"
-	    (type-specifier type)))))
-
-(defun %deftype (name expander &optional doc)
-  (ecase (info type kind name)
-    (:primitive
-     (error "Illegal to redefine standard type: ~S." name))
-    (:structure
-     (warn "Redefining structure type ~S with DEFTYPE." name)
-     (c::undefine-structure (info type structure-info name)))
-    (:class
-     (warn "Redefining class ~S with DEFTYPE." name))
-    ((nil :defined)))
-  (setf (info type kind name) :defined)
-  (setf (info type expander name) expander)
-  (when doc
-    (setf (documentation name 'type) doc))
-  ;; ### Bootstrap hack -- we need to define types before %note-type-defined
-  ;; is defined.
-  (when (fboundp 'c::%note-type-defined)
-    (c::%note-type-defined name))
-  name)
-
-(defun type-of (object)
-  "Return the type of OBJECT."
-  (typecase object
-    ;; First the ones that we can tell by testing the lowtag
-    (fixnum 'fixnum)
-    (function (type-specifier (ctype-of object)))
-    (null 'null)
-    (list 'cons)
-
-    ;; Any other immediates.
-    (character
-     (typecase object
-       (standard-char 'standard-char)
-       (base-char 'base-char)
-       (t 'character)))
-
-    ;; And now for the complicated ones.
-    (number
-     (etypecase object
-       (fixnum 'fixnum)
-       (bignum 'bignum)
-       (float
-	(etypecase object
-	  (double-float 'double-float)
-	  (single-float 'single-float)
-	  (short-float 'short-float)
-	  (long-float 'long-float)))
-       (ratio 'ratio)
-       (complex 'complex)))
-    (symbol
-     (if (eq (symbol-package object)
-	     (symbol-package :foo))
-	 'keyword
-	 'symbol))
-    (structure
-     (let ((name (structure-ref object 0)))
-       (case name
-	 (pcl::std-instance
-	  (pcl:class-name (pcl:class-of object)))
-	 (alien-internals:alien-value
-	  `(alien:alien
-	    ,(alien-internals:unparse-alien-type
-	      (alien-internals:alien-value-type object))))
-	 (t name))))
-    (array (type-specifier (ctype-of object)))
-    (system-area-pointer 'system-area-pointer)
-    (weak-pointer 'weak-pointer)
-    (code-component 'code-component)
-    (lra 'lra)
-    (fdefn 'fdefn)
-    (scavenger-hook 'scavenger-hook)
-    (t
-     (warn "Can't figure out the type of ~S" object)
-     t)))
 
 (in-package "PCL")
+
+;;;; STD-INSTANCE
+
+;;; Under CMU17 conditional, STD-INSTANCE-P is only used to discriminate
+;;; between functions (including FINs) and normal instances, so we can return
+;;; true on structures also.  A few uses of (or std-instance-p fsc-instance-p)
+;;; are changed to pcl-instance-p.
+;;;
+(defmacro std-instance-p (x)
+  `(kernel:%instancep ,x))
+(defmacro pcl-instance-p (x)
+  `(typep (kernel:layout-of ,x) 'wrapper))
+
+
+;;; We define this as STANDARD-INSTANCE, since we're going to clobber the
+;;; layout with some standard-instance layout as soon as we make it, and we
+;;; want the accesor to still be type-correct.
+;;;
+(defstruct (standard-instance
+	    (:predicate nil)
+	    (:constructor %%allocate-instance--class ())
+	    (:alternate-metaclass kernel:instance lisp:standard-class
+				  kernel:make-standard-class))
+  (slots nil))
+
+;;; Both of these operations "work" on structures, which allows the above
+;;; weakening of std-instance-p.
+;;;
+(defmacro std-instance-slots (x) `(kernel:%instance-ref ,x 1))
+(defmacro std-instance-wrapper (x) `(kernel:%instance-layout ,x))
+
+(defmacro built-in-or-structure-wrapper (x) `(kernel:layout-of ,x))
+
+(defmacro get-wrapper (inst)
+  (ext:once-only ((wrapper `(wrapper-of ,inst)))
+    `(progn
+       (assert (typep ,wrapper 'wrapper) () "What kind of instance is this?")
+       ,wrapper)))
+
+(defmacro get-instance-wrapper-or-nil (inst)
+  (ext:once-only ((wrapper `(wrapper-of ,inst)))
+    `(if (typep ,wrapper 'wrapper)
+	 ,wrapper
+	 nil)))
+
+;;; get-slots harmless
+
+(defmacro get-slots-or-nil (inst)
+  (ext:once-only ((n-inst inst))
+    `(when (pcl-instance-p ,n-inst)
+       (if (std-instance-p ,n-inst)
+	   (std-instance-slots ,n-inst)
+	   (fsc-instance-slots ,n-inst)))))
+
+
+;;;; Structure-instance stuff:
 
 (pushnew :structure-wrapper *features*)
 
@@ -461,41 +181,51 @@
   t)
 
 (defun structure-instance-p (x)
-  (and (structurep x)
-       (not (eq (kernel:structure-ref x 0) 'std-instance))))
+  (typep x 'lisp:structure-object))
+
+(defun structurep (x)
+  (typep x 'lisp:structure-object))
 
 (defun structure-type (x)
-  (kernel:structure-ref x 0))
+  (lisp:class-name (kernel:layout-class (kernel:%instance-layout x))))
+
 
 (defun structure-type-p (type)
-  (not (null (ext:info c::type c::defined-structure-info type))))
+  (and (symbolp type)
+       (let ((class  (lisp:find-class type nil)))
+	 (and class
+	      (typep (kernel:layout-info (kernel:class-layout class))
+		     'kernel:defstruct-description)))))
+
+(defun get-structure-dd (type)
+  (kernel:layout-info (kernel:class-layout (lisp:find-class type))))
 
 (defun structure-type-included-type-name (type)
-  (let ((include (c::dd-include (ext:info c::type c::defined-structure-info type))))
+  (let ((include (kernel::dd-include (get-structure-dd type))))
     (if (consp include)
 	(car include)
 	include)))
 
 (defun structure-type-slot-description-list (type)
   (nthcdr (length (let ((include (structure-type-included-type-name type)))
-		    (and include (structure-type-slot-description-list include))))
-	  (c::dd-slots (ext:info c::type c::defined-structure-info type))))
+		    (and include (kernel:dd-slots (get-structure-dd include)))))
+	  (kernel:dd-slots (get-structure-dd type))))
 
 (defun structure-slotd-name (slotd)
-  (intern (c::dsd-%name slotd) "USER"))
+  (kernel:dsd-name slotd))
 
 (defun structure-slotd-accessor-symbol (slotd)
-  (c::dsd-accessor slotd))
+  (kernel:dsd-accessor slotd))
 
 (defun structure-slotd-reader-function (slotd)
-  (fdefinition (c::dsd-accessor slotd)))
+  (fdefinition (kernel:dsd-accessor slotd)))
 
 (defun structure-slotd-writer-function (slotd)
-  (unless (c::dsd-read-only slotd)
-    (fdefinition `(setf ,(c::dsd-accessor slotd)))))
+  (unless (kernel:dsd-read-only slotd)
+    (fdefinition `(setf ,(kernel:dsd-accessor slotd)))))
 
 (defun structure-slotd-type (slotd)
-  (c::dsd-type slotd))
+  (kernel:dsd-type slotd))
 
 (defun structure-slotd-init-form (slotd)
-  (c::dsd-default slotd))
+  (kernel::dsd-default slotd))
diff --git a/pcl/defcombin.lisp b/pcl/defcombin.lisp
index 61222ad44..3680599e9 100644
--- a/pcl/defcombin.lisp
+++ b/pcl/defcombin.lisp
@@ -107,10 +107,14 @@
 	    :qualifiers ()
 	    :specializers specializers
 	    :lambda-list '(generic-function type options)
-	    :function #'(lambda (gf type options)
-			  (declare (ignore gf))
-			  (do-short-method-combination
-			    type options operator ioa new-method doc))
+	    :function #'(lambda(args nms &rest cm-args)
+			  (declare (ignore nms cm-args))
+			  (apply 
+			   #'(lambda (gf type options)
+			       (declare (ignore gf))
+			       (do-short-method-combination
+				type options operator ioa new-method doc))
+			   args))
 	    :definition-source `((define-method-combination ,type) ,truename)))
     (when old-method
       (remove-method #'find-method-combination old-method))
@@ -222,14 +226,17 @@
 	     :qualifiers ()
 	     :specializers specializers
 	     :lambda-list '(generic-function type options)
-	     :function #'(lambda (generic-function type options)
-			   (declare (ignore generic-function))
-			   (make-instance 'long-method-combination
-			     :type type
-			     :documentation doc
-			     :options options))
-	     :definition-source `((define-method-combination ,type)
-				  ,(load-truename)))))
+	     :function #'(lambda (args nms &rest cm-args)
+			   (declare (ignore nms cm-args))
+			   (apply
+			    #'(lambda (generic-function type options)
+				(declare (ignore generic-function options))
+				(make-instance 'long-method-combination
+					       :type type
+					       :documentation doc))
+			    args))
+	 :definition-source `((define-method-combination ,type)
+			      ,(load-truename)))))
     (setf (gethash type *long-method-combination-functions*) function)
     (when old-method (remove-method #'find-method-combination old-method))
     (add-method #'find-method-combination new-method)))
diff --git a/pcl/dfun.lisp b/pcl/dfun.lisp
index ef35e338c..fb4f67e4b 100644
--- a/pcl/dfun.lisp
+++ b/pcl/dfun.lisp
@@ -325,6 +325,10 @@ And so, we are saved.
      #'(lambda (new arg)
 	 (declare (pcl-fast-call))
 	 (accessor-miss gf new arg dfun-info)))))
+
+#+cmu
+(declaim (ext:freeze-type dfun-info))
+
 
 ;;;
 ;;; ONE-CLASS-ACCESSOR
@@ -552,24 +556,111 @@ And so, we are saved.
 (defun use-dispatch-dfun-p (gf &optional (caching-p (use-caching-dfun-p gf)))
   (when (eq *boot-state* 'complete)
     (unless caching-p
-      (let* ((methods (generic-function-methods gf))
-	     (arg-info (gf-arg-info gf))
-	     (mt (arg-info-metatypes arg-info))
-	     (nreq (length mt)))
-	;;Is there a position at which every specializer is eql or non-standard?
-	(dotimes (i nreq nil)
-	  (when (not (eq 't (nth i mt)))
-	    (let ((some-std-class-specl-p nil))
-	      (dolist (method methods)
-		(let ((specl (nth i (method-specializers method))))
-		  (when (and (not (eql-specializer-p specl))
-			     (let ((sclass (specializer-class specl)))
-			       (or (null (class-finalized-p sclass))
-				   (member *the-class-standard-object*
-					   (class-precedence-list sclass)))))
-		    (setq some-std-class-specl-p t))))
-	      (unless some-std-class-specl-p
-		(return-from use-dispatch-dfun-p t)))))))))
+      ;; This should return T when almost all dispatching is by
+      ;; eql specializers or built-in classes.  In other words,
+      ;; return NIL if we might ever need to do more than
+      ;; one (non built-in) typep.
+      ;; Otherwise, it is probably at least as fast to use
+      ;; a caching dfun first, possibly followed by secondary dispatching.
+
+      #||;;; Original found in cmu 17f -- S L O W 
+      (< (dispatch-dfun-cost gf) (caching-dfun-cost gf))
+      ||#
+      ;; This uses improved dispatch-dfun-cost below
+      (let ((cdc  (caching-dfun-cost gf))) ; fast
+	(> cdc (dispatch-dfun-cost gf cdc))))))
+
+;; Try this on print-object, find-method-combination, and documentation.
+;; Look at pcl/generic-functions.lisp for other potential test cases.
+(defun show-dfun-costs (gf)
+  (when (or (symbolp gf) (consp gf))
+    (setq gf (fdefinition gf)))
+  (format t "~&Name ~S  caching cost ~D  dispatch cost ~D~%"
+	  (generic-function-name gf)
+	  (caching-dfun-cost gf)
+	  (dispatch-dfun-cost gf)))
+
+(defparameter *non-built-in-typep-cost* 1)
+(defparameter *structure-typep-cost* 1)
+(defparameter *built-in-typep-cost* 0)
+
+;; The execution time of this is exponential to some function
+;; of number of gf methods and argument lists. It was taking
+;; literally hours to load the presentation methods from the
+;; cl-http w3p kit.
+#+nil
+(defun dispatch-dfun-cost (gf)
+  (generate-discrimination-net-internal 
+   gf (generic-function-methods gf) nil
+   #'(lambda (methods known-types)
+       (declare (ignore methods known-types))
+       0)
+   #'(lambda (position type true-value false-value)
+       (declare (ignore position))
+       (+ (max true-value false-value)
+	  (if (eq 'class (car type))
+	      (let ((cpl (class-precedence-list (class-of (cadr type)))))
+		(cond((memq *the-class-built-in-class* cpl)
+		      *built-in-typep-cost*)
+		     ((memq *the-class-structure-class* cpl)
+		      *structure-typep-cost*)
+		     (t
+		      *non-built-in-typep-cost*)))
+	      0)))
+   #'identity))
+
+;; This version is from the pcl found in the gcl-2.1 distribution.
+;; Someone added a cost limit so as to keep the execution time controlled
+(defun dispatch-dfun-cost (gf &optional limit)
+  (generate-discrimination-net-internal 
+   gf (generic-function-methods gf) nil
+   #'(lambda (methods known-types)
+       (declare (ignore methods known-types))
+       0)
+   #'(lambda (position type true-value false-value)
+       (declare (ignore position))
+       (let* ((type-test-cost
+	       (if (eq 'class (car type))
+		   (let* ((metaclass (class-of (cadr type)))
+			  (mcpl (class-precedence-list metaclass)))
+		     (cond ((memq *the-class-built-in-class* mcpl)
+			    *built-in-typep-cost*)
+			   ((memq *the-class-structure-class* mcpl)
+			    *structure-typep-cost*)
+			   (t
+			    *non-built-in-typep-cost*)))
+		   0))
+	      (max-cost-so-far
+	       (+ (max true-value false-value) type-test-cost)))
+	 (when (and limit (<= limit max-cost-so-far))
+	   (return-from dispatch-dfun-cost max-cost-so-far))
+	   max-cost-so-far))
+   #'identity))
+
+
+(defparameter *cache-lookup-cost* 1)
+(defparameter *wrapper-of-cost* 0)
+(defparameter *secondary-dfun-call-cost* 1)
+
+(defun caching-dfun-cost (gf)
+  (let* ((arg-info (gf-arg-info gf))
+         (nreq (length (arg-info-metatypes arg-info))))
+    (+ *cache-lookup-cost*
+       (* *wrapper-of-cost* nreq)
+       (if (methods-contain-eql-specializer-p 
+	    (generic-function-methods gf))
+	   *secondary-dfun-call-cost*
+	   0))))
+
+#+cmu
+(progn
+  (setq *non-built-in-typep-cost* 100)
+  (setq *structure-typep-cost* 15)
+  (setq *built-in-typep-cost* 5)
+  (setq *cache-lookup-cost* 30)
+  (setq *wrapper-of-cost* 15)
+  (setq *secondary-dfun-call-cost* 30))
+  
 
 (defun make-dispatch-dfun (gf)
   (values (get-dispatch-function gf) nil (dispatch-dfun-info)))
@@ -647,7 +738,7 @@ And so, we are saved.
 
 (defun make-initial-dfun (gf)
   (let ((initial-dfun 
-	 #'(lambda (&rest args)
+	 #'(#+cmu kernel:instance-lambda #-cmu lambda (&rest args)
 	     #+copy-&rest-arg (setq args (copy-list args))
 	     (initial-dfun gf args))))
     (multiple-value-bind (dfun cache info)
@@ -682,11 +773,11 @@ And so, we are saved.
   (let* ((methods (early-gf-methods gf))
 	 (slot-name (early-method-standard-accessor-slot-name (car methods))))
     (ecase type
-      (reader #'(lambda (instance)
+      (reader #'(#+cmu kernel:instance-lambda #-cmu lambda (instance)
 		  (let* ((class (class-of instance))
 			 (class-name (bootstrap-get-slot 'class class 'name)))
 		    (bootstrap-get-slot class-name instance slot-name))))
-      (writer #'(lambda (new-value instance)
+      (writer #'(#+cmu kernel:instance-lambda #-cmu lambda (new-value instance)
 		  (let* ((class (class-of instance))
 			 (class-name (bootstrap-get-slot 'class class 'name)))
 		    (bootstrap-set-slot class-name instance slot-name new-value)))))))
@@ -773,7 +864,7 @@ And so, we are saved.
 	specls all-same-p)
     (cond ((null methods)
 	   (values
-	    #'(lambda (&rest args)
+	    #'(#+cmu kernel:instance-lambda #-cmu lambda (&rest args)
 		(apply #'no-applicable-method gf args))
 	    nil
 	    (no-methods-dfun-info)))
@@ -830,8 +921,11 @@ And so, we are saved.
 	       (caching))
 	      ((or invalidp
 		   (null nindex)))
-	      ((not (or (std-instance-p object)
-			(fsc-instance-p object)))
+	      ((not #-cmu17
+		    (or (std-instance-p object)
+			(fsc-instance-p object))
+		    #+cmu17
+		    (pcl-instance-p object))
 	       (caching))
 	      ((or (neq ntype otype) (listp wrappers))
 	       (caching))
@@ -989,6 +1083,11 @@ And so, we are saved.
     (accessor-values-internal accessor-type accessor-class methods)))
 
 (defun accessor-values-internal (accessor-type accessor-class methods)
+  (dolist (meth methods)
+    (when (if (consp meth) 
+	      (early-method-qualifiers meth)
+	      (method-qualifiers meth))
+      (return-from accessor-values-internal (values nil nil))))
   (let* ((meth (car methods))
 	 (early-p (not (eq *boot-state* 'complete)))
 	 (slot-name (when accessor-class
@@ -1378,10 +1477,15 @@ And so, we are saved.
 					    &optional all-applicable-p
 					    (all-sorted-p t) function-p)
   (if (null methods)
-      #'(lambda (method-alist wrappers)
-	  (declare (ignore method-alist wrappers))
-	  #'(lambda (&rest args)
-	      (apply #'no-applicable-method gf args)))
+      (if function-p
+          #'(lambda (method-alist wrappers)
+	      (declare (ignore method-alist wrappers))
+	      #'(#+cmu kernel:instance-lambda #-cmu lambda (&rest args)
+	          (apply #'no-applicable-method gf args)))
+	  #'(lambda (method-alist wrappers)
+	      (declare (ignore method-alist wrappers))
+	      #'(lambda (&rest args)
+		  (apply #'no-applicable-method gf args))))
       (let* ((key (car methods))
 	     (ht-value (or (gethash key *effective-method-table*)
 			   (setf (gethash key *effective-method-table*)
diff --git a/pcl/vector.lisp b/pcl/vector.lisp
index c85aecff4..013c99fd8 100644
--- a/pcl/vector.lisp
+++ b/pcl/vector.lisp
@@ -53,6 +53,9 @@
   (slot-name-lists nil :type list)
   (call-list nil :type list))
 
+#+cmu
+(declaim (ext:freeze-type pv-table))
+
 (defvar *initial-pv-table* (make-pv-table-internal nil nil))
 
 ; help new slot-value-using-class methods affect fast iv access
@@ -170,12 +173,15 @@
 	    (iterate ((slot-names (list-elements slot-name-lists)))
 	      (when slot-names
 		(let* ((wrapper     (pop wrappers))
+		       (std-p #+cmu17 (typep wrapper 'wrapper)
+			      #-cmu17 t)
 		       (class       (wrapper-class* wrapper))
-		       (class-slots (wrapper-class-slots wrapper)))
+		       (class-slots (and std-p (wrapper-class-slots wrapper))))
 		  (dolist (slot-name (cdr slot-names))
 		    (gather1
-		     (compute-pv-slot slot-name wrapper class 
-				      class-slots not-simple-p-cell)))))))))
+		     (when std-p
+		       (compute-pv-slot slot-name wrapper class 
+					class-slots not-simple-p-cell))))))))))
     (if (car not-simple-p-cell)
 	(make-permutation-vector (cons t elements))
 	(or (gethash elements *pvs*)
@@ -271,13 +277,15 @@
 
 (defun update-all-pv-table-caches (class slot-names)
   (let* ((cwrapper (class-wrapper class))
-	 (class-slots (wrapper-class-slots cwrapper))
+	 (std-p #+cmu17 (typep cwrapper 'wrapper) #-cmu17 t)
+	 (class-slots (and std-p (wrapper-class-slots cwrapper)))
 	 (class-slot-p-cell (list nil))
 	 (new-values (mapcar #'(lambda (slot-name)
 				 (cons slot-name
-				       (compute-pv-slot 
-					slot-name cwrapper class 
-					class-slots class-slot-p-cell)))
+				       (when std-p
+					 (compute-pv-slot 
+					  slot-name cwrapper class 
+					  class-slots class-slot-p-cell))))
 			     slot-names))
 	 (pv-tables nil))
     (dolist (slot-name slot-names)
@@ -290,7 +298,7 @@
       (let* ((cache (pv-table-cache pv-table))
 	     (slot-name-lists (pv-table-slot-name-lists pv-table))
 	     (pv-size (pv-table-pv-size pv-table))
-	     (pv-map (make-array pv-size)))
+	     (pv-map (make-array pv-size :initial-element nil)))
 	(let ((map-index 1)(param-index 0))
 	  (dolist (slot-name-list slot-name-lists)
 	    (dolist (slot-name (cdr slot-name-list))
@@ -864,7 +872,7 @@
      ,@forms))
 
 (defvar *non-variable-declarations*
-  '(method-name method-lambda-list
+  '(#+cmu values method-name method-lambda-list
     optimize ftype inline notinline))
 
 (defvar *variable-declarations-with-argument*
@@ -1029,15 +1037,18 @@
 	 (pv-wrappers (make-list nkeys))
 	 w (w-t pv-wrappers))
     (dolist (arg args)
-      (setq w (cond ((std-instance-p arg)
-		     (std-instance-wrapper arg))
-		    ((fsc-instance-p arg)
-		     (fsc-instance-wrapper arg))
-		    (t
-		     #+new-kcl-wrapper
-		     (built-in-wrapper-of arg)
-		     #-new-kcl-wrapper
-		     (built-in-or-structure-wrapper arg))))
+      (setq w
+	    #+cmu17 (wrapper-of arg)
+	    #-cmu17
+	    (cond ((std-instance-p arg)
+		   (std-instance-wrapper arg))
+		  ((fsc-instance-p arg)
+		   (fsc-instance-wrapper arg))
+		  (t
+		   #+new-kcl-wrapper
+		   (built-in-wrapper-of arg)
+		   #-new-kcl-wrapper
+		   (built-in-or-structure-wrapper arg))))
       (unless (eq 't (wrapper-state w))
 	(setq w (check-wrapper-validity arg)))
       (setf (car w-t) w))
diff --git a/pcl/walk.lisp b/pcl/walk.lisp
index c400fcb19..40a066074 100644
--- a/pcl/walk.lisp
+++ b/pcl/walk.lisp
@@ -1806,7 +1806,8 @@
 
 (defun walk-symbol-macrolet (form context old-env)
   (declare (ignore context))
-  (let* ((bindings (cadr form)))
+  (let* ((bindings (cadr form))
+	 (body (cddr form)))
     (walker-environment-bind
 	(new-env old-env
 		 :lexical-variables
@@ -1816,7 +1817,7 @@
 				 bindings)
 			 (env-lexical-variables old-env)))
       (relist* form 'symbol-macrolet bindings
-	       (walk-repeat-eval (cddr form) new-env)))))
+	       (walk-declarations body #'walk-repeat-eval new-env)))))
 
 (defun walk-tagbody (form context env)
   (recons form (car form) (walk-tagbody-1 (cdr form) context env)))
diff --git a/tools/comcom.lisp b/tools/comcom.lisp
index f65f1afcb..84e7f36fa 100644
--- a/tools/comcom.lisp
+++ b/tools/comcom.lisp
@@ -18,6 +18,7 @@
 	  old-c::defstruct-slot-description)
 	"C")
 
+
 (with-compiler-log-file
     ("target:compile-compiler.log"
      :optimize
@@ -37,13 +38,19 @@
 	(declare (optimize (speed 0))))
        (:external (declare (optimize-interface (safety 2) (debug 1))))))
 
+
 (comf "target:compiler/macros" :load *load-stuff* :byte-compile *byte-compile*)
-(comf "target:compiler/generic/vm-macs" :load *load-stuff* :proceed t)
-(comf "target:compiler/backend" :load *load-stuff* :proceed t)
+
+(comf "target:compiler/generic/vm-macs" :load *load-stuff* :proceed t
+	:byte-compile #+bootstrap t #-bootstrap nil)
+
+(comf "target:compiler/backend" :load *load-stuff* :proceed t
+	:byte-compile #+bootstrap t #-bootstrap nil)
 
 (defvar c::*target-backend* (c::make-backend))
 
 (comf (vmdir "target:compiler/parms") :proceed t)
+
 (comf "target:compiler/generic/objdef" :proceed t)
 (comf "target:compiler/generic/interr")
 
@@ -57,10 +64,12 @@
 (comf "target:compiler/ctype")
 (comf "target:compiler/vop" :proceed t)
 (comf "target:compiler/vmdef")
+
 (comf "target:compiler/meta-vmdef" :proceed t)
+#+bootstrap ;; pw adds
+(comf "target:compiler/meta-vmdef" :byte-compile t)
 (when *load-stuff*
   (load "target:compiler/meta-vmdef"))
-
 (comf "target:compiler/disassem" :byte-compile *byte-compile*)
 (comf "target:compiler/new-assem")
 (comf "target:compiler/alloc")
@@ -79,19 +88,21 @@
   (comf "target:compiler/ir1opt"))
 
 (comf "target:compiler/ir1final")
-(comf "target:compiler/srctran")
+;;try(comf "target:compiler/srctran")
 (comf "target:compiler/array-tran" :byte-compile *byte-compile*)
 (comf "target:compiler/seqtran" :byte-compile *byte-compile*)
 (comf "target:compiler/typetran" :byte-compile *byte-compile*)
 (comf "target:compiler/generic/vm-typetran" :byte-compile *byte-compile*)
 (comf "target:compiler/float-tran" :byte-compile *byte-compile*)
 (comf "target:compiler/saptran" :byte-compile *byte-compile*)
+(comf "target:compiler/srctran") ;; try
 (comf "target:compiler/locall")
 (comf "target:compiler/dfo")
 (comf "target:compiler/checkgen")
 (comf "target:compiler/constraint")
 (comf "target:compiler/envanal")
 
+
 (comf "target:compiler/tn")
 (comf "target:compiler/life")
 
@@ -100,16 +111,35 @@
 (comf "target:compiler/debug-dump")
 (comf "target:compiler/generic/utils")
 (comf "target:assembly/assemfile")
+#+bootstrap
+(comf "target:assembly/assemfile" :byte-compile t)
 (when *load-stuff* (load "target:assembly/assemfile"))
-		   
+
+
 (with-compilation-unit
     (:optimize '(optimize (safety #+small 0 #-small 1) #+small (debug 0)))
 
-(comf (vmdir "target:compiler/insts"))
-(comf (vmdir "target:compiler/macros") :load *load-stuff*)
-(comf (vmdir "target:compiler/vm"))
+  #-x86
+  (progn				; this is distributed order
+    (comf (vmdir "target:compiler/insts"))
+    (comf (vmdir "target:compiler/macros") :load *load-stuff*)
+    (comf (vmdir "target:compiler/vm")))
+  #+nil
+  (progn				; this works for x86
+    (comf (vmdir "target:compiler/vm"))
+    (comf (vmdir "target:compiler/macros") :load *load-stuff*)
+    (comf (vmdir "target:compiler/insts")))
+  #+x86
+  (progn				; this is needed for cross compile
+    (comf (vmdir "target:compiler/vm"))
+    (comf (vmdir "target:compiler/insts"))
+    (comf (vmdir "target:compiler/macros") :load *load-stuff*
+	   :byte-compile #+bootstrap t #-bootstrap nil)
+    )	
+  
 (comf "target:compiler/generic/primtype")
-(comf (vmdir "target:assembly/support") :load *load-stuff*)
+(comf (vmdir "target:assembly/support") :load *load-stuff*
+       :byte-compile #+bootstrap t #-bootstrap nil) ; pw
 (comf (vmdir "target:compiler/move"))
 (comf (vmdir "target:compiler/float") :byte-compile *byte-compile*)
 (comf (vmdir "target:compiler/sap") :byte-compile *byte-compile*)
@@ -119,6 +149,7 @@
 (comf (vmdir "target:compiler/static-fn"))
 (comf (vmdir "target:compiler/arith"))
 (comf (vmdir "target:compiler/subprim") :byte-compile *byte-compile*)
+
 (comf (vmdir "target:compiler/debug") :byte-compile *byte-compile*)
 (comf (vmdir "target:compiler/c-call") :byte-compile *byte-compile*)
 (comf (vmdir "target:compiler/cell"))
@@ -141,6 +172,7 @@
 ); with-compilation-unit for back end.
 
 (comf "target:compiler/aliencomp" :byte-compile *byte-compile*)
+
 (comf "target:compiler/ltv")
 (comf "target:compiler/gtn")
 (with-compilation-unit
diff --git a/tools/worldbuild.lisp b/tools/worldbuild.lisp
index 9460fc0dc..892307e5c 100644
--- a/tools/worldbuild.lisp
+++ b/tools/worldbuild.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldbuild.lisp,v 1.34 1994/10/24 19:09:08 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldbuild.lisp,v 1.35 1997/01/18 14:31:46 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -118,6 +118,10 @@
 	'("target:code/osf1-os"))
     ,@(when (c:backend-featurep :irix)
 	'("target:code/irix-os"))
+    ,@(when (c:backend-featurep :FreeBSD)
+	'("target:code/bsd-os"))
+    ,@(when (c:backend-featurep :Linux)
+	'("target:code/linux-os"))
     "target:code/serve-event"
     "target:code/stream"
     "target:code/fd-stream"
diff --git a/tools/worldcom.lisp b/tools/worldcom.lisp
index 7f01abe36..61f3f8b03 100644
--- a/tools/worldcom.lisp
+++ b/tools/worldcom.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldcom.lisp,v 1.71 1994/10/24 19:11:24 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldcom.lisp,v 1.72 1997/01/18 14:31:46 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -147,6 +147,10 @@
   (comf "target:code/osf1-os"))
 (when (c:backend-featurep :irix)
   (comf "target:code/irix-os"))
+(when (c:backend-featurep :BSD)
+  (comf "target:code/bsd-os"))
+(when (c:backend-featurep :Linux)
+  (comf "target:code/linux-os"))
 
 (when (c:backend-featurep :pmax)
   (comf "target:code/pmax-vm"))
diff --git a/tools/worldload.lisp b/tools/worldload.lisp
index 3af120fa9..f49e7071c 100644
--- a/tools/worldload.lisp
+++ b/tools/worldload.lisp
@@ -6,7 +6,7 @@
 ;;; If you want to use this code or any part of CMU Common Lisp, please contact
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldload.lisp,v 1.80 1994/10/04 12:26:38 ram Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldload.lisp,v 1.81 1997/01/18 14:31:47 ram Exp $
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -96,7 +96,7 @@
 #-(or gengc runtime) (maybe-byte-load "code:room")
 
 ;;; Overwrite some cold-loaded stuff with byte-compiled versions, if any.
-#-gengc
+#-(or x86 gengc)			; x86 has stuff in static space
 (progn
   (byte-load-over "target:code/debug")
   (byte-load-over "target:code/error")
-- 
GitLab