diff --git a/compiler/x86/array.lisp b/compiler/x86/array.lisp
index 565786145c59167465804e544e7fefdc0fa92e3c..1e99e139f657f29f594adfb88c6ddde7bb992e28 100644
--- a/compiler/x86/array.lisp
+++ b/compiler/x86/array.lisp
@@ -7,7 +7,7 @@
 ;;; 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.12 1998/03/03 17:35:25 dtc Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/array.lisp,v 1.13 1998/03/21 07:54:36 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -489,6 +489,121 @@
 		  (inst fxch value)))))))
 
 
+#+long-float
+(define-vop (data-vector-ref/simple-array-long-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (index :scs (any-reg)))
+  (:arg-types simple-array-long-float positive-fixnum)
+  (:temporary (:sc any-reg :from :eval :to :result) temp)
+  (:results (value :scs (long-reg)))
+  (:result-types long-float)
+  (:generator 7
+    ;; temp = 3 * index
+    (inst lea temp (make-ea :dword :base index :index index :scale 2))
+    (with-empty-tn@fp-top(value)
+      (inst fldl (make-ea :dword :base object :index temp :scale 1
+			  :disp (- (* vm:vector-data-offset vm:word-bytes)
+				   vm:other-pointer-type))))))
+
+#+long-float
+(define-vop (data-vector-ref-c/simple-array-long-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg)))
+  (:info index)
+  (:arg-types simple-array-long-float (:constant (signed-byte 30)))
+  (:results (value :scs (long-reg)))
+  (:result-types long-float)
+  (:generator 6
+   (with-empty-tn@fp-top(value)
+     (inst fldl (make-ea :dword :base object
+			 :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+				     (* 12 index))
+				  vm:other-pointer-type))))))
+
+#+long-float
+(define-vop (data-vector-set/simple-array-long-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (index :scs (any-reg))
+	 (value :scs (long-reg) :target result))
+  (:arg-types simple-array-long-float positive-fixnum long-float)
+  (:temporary (:sc any-reg :from (:argument 1) :to :result) temp)
+  (:results (result :scs (long-reg)))
+  (:result-types long-float)
+  (:generator 20
+    ;; temp = 3 * index
+    (inst lea temp (make-ea :dword :base index :index index :scale 2))
+    (cond ((zerop (tn-offset value))
+	   ;; Value is in ST0
+	   (store-long-float
+	    (make-ea :dword :base object :index temp :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 fstd result)))
+	  (t
+	   ;; Value is not in ST0.
+	   (inst fxch value)
+	   (store-long-float
+	    (make-ea :dword :base object :index temp :scale 1
+		     :disp (- (* vm:vector-data-offset vm:word-bytes)
+			      vm:other-pointer-type)))
+	   (cond ((zerop (tn-offset result))
+		  ;; The result is in ST0.
+		  (inst fstd value))
+		 (t
+		  ;; Neither value or result are in ST0
+		  (unless (location= value result)
+		    (inst fstd result))
+		  (inst fxch value)))))))
+
+#+long-float
+(define-vop (data-vector-set-c/simple-array-long-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (value :scs (long-reg) :target result))
+  (:info index)
+  (:arg-types simple-array-long-float (:constant (signed-byte 30)) long-float)
+  (:results (result :scs (long-reg)))
+  (:result-types long-float)
+  (:generator 19
+    (cond ((zerop (tn-offset value))
+	   ;; Value is in ST0
+	   (store-long-float (make-ea :dword :base object
+				      :disp (- (+ (* vm:vector-data-offset
+						     vm:word-bytes)
+						  (* 12 index))
+					       vm:other-pointer-type)))
+	   (unless (zerop (tn-offset result))
+	     ;; Value is in ST0 but not result.
+	     (inst fstd result)))
+	  (t
+	   ;; Value is not in ST0.
+	   (inst fxch value)
+	   (store-long-float (make-ea :dword :base object
+				      :disp (- (+ (* vm:vector-data-offset
+						     vm:word-bytes)
+						  (* 12 index))
+					       vm:other-pointer-type)))
+	   (cond ((zerop (tn-offset result))
+		  ;; The result is in ST0.
+		  (inst fstd value))
+		 (t
+		  ;; Neither value or result are in ST0
+		  (unless (location= value result)
+		    (inst fstd result))
+		  (inst fxch value)))))))
+
 ;;; Complex float variants.
 #+complex-float
 (progn
@@ -784,6 +899,162 @@
       (inst fxch value-imag))))
 
 
+#+long-float
+(define-vop (data-vector-ref/simple-array-complex-long-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (index :scs (any-reg)))
+  (:arg-types simple-array-complex-long-float positive-fixnum)
+  (:temporary (:sc any-reg :from :eval :to :result) temp)
+  (:results (value :scs (complex-long-reg)))
+  (:result-types complex-long-float)
+  (:generator 7
+    ;; temp = 3 * index
+    (inst lea temp (make-ea :dword :base index :index index :scale 2))
+    (let ((real-tn (complex-long-reg-real-tn value)))
+      (with-empty-tn@fp-top (real-tn)
+	(inst fldl (make-ea :dword :base object :index temp :scale 2
+			    :disp (- (* vm:vector-data-offset vm:word-bytes)
+				     vm:other-pointer-type)))))
+    (let ((imag-tn (complex-long-reg-imag-tn value)))
+      (with-empty-tn@fp-top (imag-tn)
+	(inst fldl (make-ea :dword :base object :index temp :scale 2
+			    :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+					12)
+				     vm:other-pointer-type)))))))
+
+#+long-float
+(define-vop (data-vector-ref-c/simple-array-complex-long-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg)))
+  (:info index)
+  (:arg-types simple-array-complex-long-float (:constant (signed-byte 30)))
+  (:results (value :scs (complex-long-reg)))
+  (:result-types complex-long-float)
+  (:generator 6
+    (let ((real-tn (complex-long-reg-real-tn value)))
+      (with-empty-tn@fp-top (real-tn)
+	(inst fldl (make-ea :dword :base object
+			    :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+					(* 24 index))
+				     vm:other-pointer-type)))))
+    (let ((imag-tn (complex-long-reg-imag-tn value)))
+      (with-empty-tn@fp-top (imag-tn)
+	(inst fldl (make-ea :dword :base object
+			    :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+					(* 24 index) 12)
+				     vm:other-pointer-type)))))))
+
+#+long-float
+(define-vop (data-vector-set/simple-array-complex-long-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (index :scs (any-reg))
+	 (value :scs (complex-long-reg) :target result))
+  (:arg-types simple-array-complex-long-float positive-fixnum
+	      complex-long-float)
+  (:temporary (:sc any-reg :from (:argument 1) :to :result) temp)
+  (:results (result :scs (complex-long-reg)))
+  (:result-types complex-long-float)
+  (:generator 20
+    ;; temp = 3 * index
+    (inst lea temp (make-ea :dword :base index :index index :scale 2))
+    (let ((value-real (complex-long-reg-real-tn value))
+	  (result-real (complex-long-reg-real-tn result)))
+      (cond ((zerop (tn-offset value-real))
+	     ;; Value is in ST0
+	     (store-long-float
+	      (make-ea :dword :base object :index temp :scale 2
+		       :disp (- (* vm:vector-data-offset vm:word-bytes)
+				vm:other-pointer-type)))
+	     (unless (zerop (tn-offset result-real))
+	       ;; Value is in ST0 but not result.
+	       (inst fstd result-real)))
+	    (t
+	     ;; Value is not in ST0.
+	     (inst fxch value-real)
+	     (store-long-float
+	      (make-ea :dword :base object :index temp :scale 2
+		       :disp (- (* vm:vector-data-offset vm:word-bytes)
+				vm:other-pointer-type)))
+	     (cond ((zerop (tn-offset result-real))
+		    ;; The result is in ST0.
+		    (inst fstd value-real))
+		   (t
+		    ;; Neither value or result are in ST0
+		    (unless (location= value-real result-real)
+		      (inst fstd result-real))
+		    (inst fxch value-real))))))
+    (let ((value-imag (complex-long-reg-imag-tn value))
+	  (result-imag (complex-long-reg-imag-tn result)))
+      (inst fxch value-imag)
+      (store-long-float
+       (make-ea :dword :base object :index temp :scale 2
+		:disp (- (+ (* vm:vector-data-offset vm:word-bytes) 12)
+			 vm:other-pointer-type)))
+      (unless (location= value-imag result-imag)
+	(inst fstd result-imag))
+      (inst fxch value-imag))))
+
+#+long-float
+(define-vop (data-vector-set-c/simple-array-complex-long-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (value :scs (complex-long-reg) :target result))
+  (:info index)
+  (:arg-types simple-array-complex-long-float (:constant (signed-byte 30))
+	      complex-long-float)
+  (:results (result :scs (complex-long-reg)))
+  (:result-types complex-long-float)
+  (:generator 19
+    (let ((value-real (complex-long-reg-real-tn value))
+	  (result-real (complex-long-reg-real-tn result)))
+      (cond ((zerop (tn-offset value-real))
+	     ;; Value is in ST0
+	     (store-long-float
+	      (make-ea :dword :base object
+		       :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+				   (* 24 index))
+				vm:other-pointer-type)))
+	     (unless (zerop (tn-offset result-real))
+	       ;; Value is in ST0 but not result.
+	       (inst fstd result-real)))
+	    (t
+	     ;; Value is not in ST0.
+	     (inst fxch value-real)
+	     (store-long-float
+	      (make-ea :dword :base object
+		       :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+				   (* 24 index))
+				vm:other-pointer-type)))
+	     (cond ((zerop (tn-offset result-real))
+		    ;; The result is in ST0.
+		    (inst fstd value-real))
+		   (t
+		    ;; Neither value or result are in ST0
+		    (unless (location= value-real result-real)
+		      (inst fstd result-real))
+		    (inst fxch value-real))))))
+    (let ((value-imag (complex-long-reg-imag-tn value))
+	  (result-imag (complex-long-reg-imag-tn result)))
+      (inst fxch value-imag)
+      (store-long-float
+       (make-ea :dword :base object
+		:disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+			    (* 24 index) 12)
+			 vm:other-pointer-type)))
+      (unless (location= value-imag result-imag)
+	(inst fstd result-imag))
+      (inst fxch value-imag))))
+
 ) ; complex-float
 
 
@@ -1201,6 +1472,25 @@
   (:translate %raw-set-double)
   (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
 	      double-float))
+;;;
+#+long-float
+(define-vop (raw-ref-long data-vector-ref/simple-array-long-float)
+  (:translate %raw-ref-long)
+  (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
+#+long-float
+(define-vop (raw-ref-long-c data-vector-ref-c/simple-array-long-float)
+  (:translate %raw-ref-long)
+  (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))))
+;;;
+#+long-float
+(define-vop (raw-set-double data-vector-set/simple-array-long-float)
+  (:translate %raw-set-long)
+  (:arg-types simple-array-unsigned-byte-32 positive-fixnum long-float))
+#+long-float
+(define-vop (raw-set-long-c data-vector-set-c/simple-array-long-float)
+  (:translate %raw-set-long)
+  (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
+	      long-float))
 
 ;;;; Complex-float raw structure slot accessors.
 #+complex-float
@@ -1244,6 +1534,30 @@
   (:translate %raw-set-complex-double)
   (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
 	      complex-double-float))
+;;;
+#+long-float
+(define-vop (raw-ref-complex-long
+	     data-vector-ref/simple-array-complex-long-float)
+  (:translate %raw-ref-complex-long)
+  (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
+#+long-float
+(define-vop (raw-ref-complex-long-c
+	     data-vector-ref-c/simple-array-complex-long-float)
+  (:translate %raw-ref-complex-long)
+  (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))))
+;;;
+#+long-float
+(define-vop (raw-set-complex-long
+	     data-vector-set/simple-array-complex-long-float)
+  (:translate %raw-set-complex-long)
+  (:arg-types simple-array-unsigned-byte-32 positive-fixnum
+	      complex-long-float))
+#+long-float
+(define-vop (raw-set-complex-long-c
+	     data-vector-set-c/simple-array-complex-long-float)
+  (:translate %raw-set-complex-long)
+  (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
+	      complex-long-float))
 
 ) ; end progn complex-float
 
diff --git a/compiler/x86/c-call.lisp b/compiler/x86/c-call.lisp
index b5cc4419442315665c87e148ad51b04a116b5120..3d88124169419100f3503362ec78d258a602f985 100644
--- a/compiler/x86/c-call.lisp
+++ b/compiler/x86/c-call.lisp
@@ -7,7 +7,7 @@
 ;;; 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.7 1998/02/19 19:34:44 dtc Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/c-call.lisp,v 1.8 1998/03/21 07:54:37 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -17,7 +17,7 @@
 ;;; Written by William Lott.
 ;;;
 ;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
-;;; Debugging and Enhancements by Douglas Crosher 1996,1997.
+;;; Debugging and Enhancements by Douglas Crosher 1996,1997,1998.
 ;;;
 
 (in-package :x86)
@@ -55,6 +55,13 @@
 		      'sap-stack
 		      stack-frame-size)))
 
+#+long-float
+(def-alien-type-method (long-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) (+ stack-frame-size 3))
+    (my-make-wired-tn 'long-float 'long-stack stack-frame-size)))
+
 (def-alien-type-method (double-float :arg-tn) (type state)
   (declare (ignore type))
   (let ((stack-frame-size (arg-state-stack-frame-size state)))
@@ -92,6 +99,13 @@
     (my-make-wired-tn 'system-area-pointer 'sap-reg
 		      (result-reg-offset num-results))))
 
+#+long-float
+(def-alien-type-method (long-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 'long-float 'long-reg (* num-results 2))))
+
 (def-alien-type-method (double-float :result-tn) (type state)
   (declare (ignore type))
   (let ((num-results (result-state-num-results state)))
diff --git a/compiler/x86/float.lisp b/compiler/x86/float.lisp
index bec9ece286c0f5e3e05edca8a61eadcddda25ac5..2048a58b21b141782d8c199ea9ed3d56c464b864 100644
--- a/compiler/x86/float.lisp
+++ b/compiler/x86/float.lisp
@@ -7,7 +7,7 @@
 ;;; 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.25 1998/03/11 17:33:58 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/float.lisp,v 1.26 1998/03/21 07:54:38 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -17,7 +17,7 @@
 ;;;
 ;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
 ;;;
-;;; Rewrite, enhancements, complex-float support by
+;;; Rewrite, enhancements, complex-float and long-float support by
 ;;; Douglas Crosher, 1996, 1997, 1998.
 ;;;
 
@@ -32,6 +32,9 @@
     (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))
+  #+long-float
+  (defun ea-for-lf-desc (tn)
+    (ea-for-xf-desc tn vm:long-float-value-slot))
   ;; Complex floats
   #+complex-float
   (defun ea-for-csf-real-desc (tn)
@@ -44,7 +47,13 @@
     (ea-for-xf-desc tn vm:complex-double-float-real-slot))
   #+complex-float
   (defun ea-for-cdf-imag-desc (tn)
-    (ea-for-xf-desc tn vm:complex-double-float-imag-slot)))
+    (ea-for-xf-desc tn vm:complex-double-float-imag-slot))
+  #+(and long-float complex-float)
+  (defun ea-for-clf-real-desc (tn)
+    (ea-for-xf-desc tn vm:complex-long-float-real-slot))
+  #+(and long-float complex-float)
+  (defun ea-for-clf-imag-desc (tn)
+    (ea-for-xf-desc tn vm:complex-long-float-imag-slot)))
 
 (macrolet ((ea-for-xf-stack (tn kind)
 	     `(make-ea
@@ -55,7 +64,10 @@
   (defun ea-for-sf-stack (tn)
     (ea-for-xf-stack tn :single))
   (defun ea-for-df-stack (tn)
-    (ea-for-xf-stack tn :double)))
+    (ea-for-xf-stack tn :double))
+  #+long-float
+  (defun ea-for-lf-stack (tn)
+    (ea-for-xf-stack tn :long)))
 
 ;;; Complex float stack EAs
 #+complex-float
@@ -77,7 +89,14 @@
   (defun ea-for-cdf-real-stack (tn &optional (base ebp-tn))
     (ea-for-cxf-stack tn :double :real base))
   (defun ea-for-cdf-imag-stack (tn &optional (base ebp-tn))
-    (ea-for-cxf-stack tn :double :imag base)))
+    (ea-for-cxf-stack tn :double :imag base))
+  ;;
+  #+long-float
+  (defun ea-for-clf-real-stack (tn &optional (base ebp-tn))
+    (ea-for-cxf-stack tn :long :real base))
+  #+long-float
+  (defun ea-for-clf-imag-stack (tn &optional (base ebp-tn))
+    (ea-for-cxf-stack tn :long :imag base)))
 
 ;;; Abstract out the copying of a FP register to the FP stack top, and
 ;;; provide two alternatives for its implementation. Note: it's not
@@ -99,6 +118,14 @@
   (inst fxch reg)
   (inst fst  reg))
 
+;;; The x86 can't store a long-float to memory without popping the
+;;; stack and marking a register as empty, so it is necessary to
+;;; restore the register from memory.
+#+long-float
+(defun store-long-float (ea)
+   (inst fstpl ea)
+   (inst fldl ea))
+
 
 ;;;; Move functions:
 
@@ -133,6 +160,23 @@
 	 ;; This may not be necessary as ST0 is likely invalid now.
 	 (inst fxch x))))
 
+#+long-float
+(define-move-function (load-long 2) (vop x y)
+  ((long-stack) (long-reg))
+  (with-empty-tn@fp-top(y)
+     (inst fldl (ea-for-lf-stack x))))
+
+#+long-float
+(define-move-function (store-long 2) (vop x y)
+  ((long-reg) (long-stack))
+  (cond ((zerop (tn-offset x))
+	 (store-long-float (ea-for-lf-stack y)))
+	(t
+	 (inst fxch x)
+	 (store-long-float (ea-for-lf-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).
@@ -140,13 +184,23 @@
 ;;; 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 2) (vop x y)
-  ((fp-constant) (single-reg double-reg))
+  ((fp-constant) (single-reg double-reg #+long-float long-reg))
   (let ((value (c::constant-value (c::tn-leaf x))))
     (with-empty-tn@fp-top(y)
       (cond ((zerop value)
 	     (inst fldz))
 	    ((= value 1l0)
 	     (inst fld1))
+	    ((= value pi)
+	     (inst fldpi))
+	    ((= value (log 10l0 2l0))
+	     (inst fldl2t))
+	    ((= value (log 2.718281828459045235360287471352662L0 2l0))
+	     (inst fldl2e))
+	    ((= value (log 2l0 10l0))
+	     (inst fldlg2))
+	    ((= value (log 2l0 2.718281828459045235360287471352662L0))
+	     (inst fldln2))
 	    (t (warn "Ignoring bogus i387 Constant ~a" value))))))
 
 
@@ -168,6 +222,15 @@
   (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
 		  :offset (1+ (tn-offset x))))
 
+#+long-float
+(defun complex-long-reg-real-tn (x)
+  (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg *backend*)
+		  :offset (tn-offset x)))
+#+long-float
+(defun complex-long-reg-imag-tn (x)
+  (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg *backend*)
+		  :offset (1+ (tn-offset x))))
+
 ;;; x is source, y is destination
 (define-move-function (load-complex-single 2) (vop x y)
   ((complex-single-stack) (complex-single-reg))
@@ -214,6 +277,32 @@
     (inst fxch imag-tn)
     (inst fstd (ea-for-cdf-imag-stack y))
     (inst fxch imag-tn)))
+
+#+long-float
+(define-move-function (load-complex-long 2) (vop x y)
+  ((complex-long-stack) (complex-long-reg))
+  (let ((real-tn (complex-long-reg-real-tn y)))
+    (with-empty-tn@fp-top(real-tn)
+      (inst fldl (ea-for-clf-real-stack x))))
+  (let ((imag-tn (complex-long-reg-imag-tn y)))
+    (with-empty-tn@fp-top(imag-tn)
+      (inst fldl (ea-for-clf-imag-stack x)))))
+
+#+long-float
+(define-move-function (store-complex-long 2) (vop x y)
+  ((complex-long-reg) (complex-long-stack))
+  (let ((real-tn (complex-long-reg-real-tn x)))
+    (cond ((zerop (tn-offset real-tn))
+	   (store-long-float (ea-for-clf-real-stack y)))
+	  (t
+	   (inst fxch real-tn)
+	   (store-long-float (ea-for-clf-real-stack y))
+	   (inst fxch real-tn))))
+  (let ((imag-tn (complex-long-reg-imag-tn x)))
+    (inst fxch imag-tn)
+    (store-long-float (ea-for-clf-imag-stack y))
+    (inst fxch imag-tn)))
+
 ) ; complex-float
 
 
@@ -247,6 +336,13 @@
   (:results (y :scs (double-reg) :load-if (not (location= x y)))))
 (define-move-vop double-move :move (double-reg) (double-reg))
 
+#+long-float
+(define-vop (long-move float-move)
+  (:args (x :scs (long-reg) :target y :load-if (not (location= x y))))
+  (:results (y :scs (long-reg) :load-if (not (location= x y)))))
+#+long-float
+(define-move-vop long-move :move (long-reg) (long-reg))
+
 #+complex-float
 (progn
 ;;;
@@ -289,6 +385,16 @@
   (:results (y :scs (complex-double-reg) :load-if (not (location= x y)))))
 (define-move-vop complex-double-move :move
   (complex-double-reg) (complex-double-reg))
+
+#+long-float
+(define-vop (complex-long-move complex-float-move)
+  (:args (x :scs (complex-long-reg)
+	    :target y :load-if (not (location= x y))))
+  (:results (y :scs (complex-long-reg) :load-if (not (location= x y)))))
+#+long-float
+(define-move-vop complex-long-move :move
+  (complex-long-reg) (complex-long-reg))
+
 ) ; complex-float
 
 
@@ -320,6 +426,20 @@
 (define-move-vop move-from-double :move
   (double-reg) (descriptor-reg))
 
+#+long-float
+(define-vop (move-from-long)
+  (:args (x :scs (long-reg) :to :save))
+  (:results (y :scs (descriptor-reg)))
+  (:node-var node)
+  (:note "float to pointer coercion")
+  (:generator 13
+     (with-fixed-allocation (y vm:long-float-type vm:long-float-size node)
+       (with-tn@fp-top(x)
+	 (store-long-float (ea-for-lf-desc y))))))
+#+long-float
+(define-move-vop move-from-long :move
+  (long-reg) (descriptor-reg))
+
 (define-vop (move-from-fp-constant)
   (:args (x :scs (fp-constant)))
   (:results (y :scs (descriptor-reg)))
@@ -328,7 +448,23 @@
        (0f0 (load-symbol-value y *fp-constant-0s0*))
        (1f0 (load-symbol-value y *fp-constant-1s0*))
        (0d0 (load-symbol-value y *fp-constant-0d0*))
-       (1d0 (load-symbol-value y *fp-constant-1d0*)))))
+       (1d0 (load-symbol-value y *fp-constant-1d0*))
+       #+long-float
+       (0l0 (load-symbol-value y *fp-constant-0l0*))
+       #+long-float
+       (1l0 (load-symbol-value y *fp-constant-1l0*))
+       #+long-float
+       (#.pi (load-symbol-value y *fp-constant-pi*))
+       #+long-float
+       (#.(log 10l0 2l0) (load-symbol-value y *fp-constant-l2t*))
+       #+long-float
+       (#.(log 2.718281828459045235360287471352662L0 2l0)
+	  (load-symbol-value y *fp-constant-l2e*))
+       #+long-float
+       (#.(log 2l0 10l0) (load-symbol-value y *fp-constant-lg2*))
+       #+long-float
+       (#.(log 2l0 2.718281828459045235360287471352662L0)
+	  (load-symbol-value y *fp-constant-ln2*)))))
 (define-move-vop move-from-fp-constant :move
   (fp-constant) (descriptor-reg))
 
@@ -353,6 +489,17 @@
        (inst fldd (ea-for-df-desc x)))))
 (define-move-vop move-to-double :move (descriptor-reg) (double-reg))
 
+#+long-float
+(define-vop (move-to-long)
+  (:args (x :scs (descriptor-reg)))
+  (:results (y :scs (long-reg)))
+  (:note "pointer to float coercion")
+  (:generator 2
+     (with-empty-tn@fp-top(y)
+       (inst fldl (ea-for-lf-desc x)))))
+#+long-float
+(define-move-vop move-to-long :move (descriptor-reg) (long-reg))
+
 
 #+complex-float
 (progn
@@ -394,6 +541,25 @@
 (define-move-vop move-from-complex-double :move
   (complex-double-reg) (descriptor-reg))
 
+#+long-float
+(define-vop (move-from-complex-long)
+  (:args (x :scs (complex-long-reg) :to :save))
+  (:results (y :scs (descriptor-reg)))
+  (:node-var node)
+  (:note "complex float to pointer coercion")
+  (:generator 13
+     (with-fixed-allocation (y vm:complex-long-float-type
+			       vm:complex-long-float-size node)
+       (let ((real-tn (complex-long-reg-real-tn x)))
+	 (with-tn@fp-top(real-tn)
+	   (store-long-float (ea-for-clf-real-desc y))))
+       (let ((imag-tn (complex-long-reg-imag-tn x)))
+	 (with-tn@fp-top(imag-tn)
+	   (store-long-float (ea-for-clf-imag-desc y)))))))
+#+long-float
+(define-move-vop move-from-complex-long :move
+  (complex-long-reg) (descriptor-reg))
+
 ;;;
 ;;; Move from a descriptor to a complex float register
 ;;;
@@ -408,15 +574,21 @@
 		      (with-empty-tn@fp-top(real-tn)
 			,@(ecase format
 			   (:single '((inst fld (ea-for-csf-real-desc x))))
-			   (:double '((inst fldd (ea-for-cdf-real-desc x)))))))
+			   (:double '((inst fldd (ea-for-cdf-real-desc x))))
+			   #+long-float
+			   (:long '((inst fldl (ea-for-clf-real-desc x)))))))
 		    (let ((imag-tn (complex-double-reg-imag-tn y)))
 		      (with-empty-tn@fp-top(imag-tn)
 			,@(ecase format
 			   (:single '((inst fld (ea-for-csf-imag-desc x))))
-			   (:double '((inst fldd (ea-for-cdf-imag-desc x)))))))))
+			   (:double '((inst fldd (ea-for-cdf-imag-desc x))))
+			   #+long-float
+			   (:long '((inst fldl (ea-for-clf-imag-desc x)))))))))
 		(define-move-vop ,name :move (descriptor-reg) (,sc)))))
 	  (frob move-to-complex-single complex-single-reg :single)
-	  (frob move-to-complex-double complex-double-reg :double))
+	  (frob move-to-complex-double complex-double-reg :double)
+	  #+long-float
+	  (frob move-to-complex-double complex-long-reg :long))
 ) ; complex-float
 
 
@@ -435,7 +607,7 @@
 			     :load-if (not (sc-is y ,sc))))
 		  (:results (y))
 		  (:note "float argument move")
-		  (:generator ,(case format (:single 2) (:double 3))
+		  (:generator ,(case format (:single 2) (:double 3) (:long 4))
 		    (sc-case y
 		      (,sc
 		       (unless (location= x y)
@@ -454,22 +626,29 @@
 			     (with-tn@fp-top(x)
 				,@(ecase format
 					 (:single '((inst fst ea)))
-					 (:double '((inst fstd ea))))))
+					 (:double '((inst fstd ea)))
+					 #+long-float
+					 (:long '((store-long-float ea))))))
 			   (let ((ea (make-ea
 				      :dword :base fp
 				      :disp (- (* (+ (tn-offset y)
 						     ,(case format
 							    (:single 1)
-							    (:double 2)))
+							    (:double 2)
+							    (:long 3)))
 						  vm:word-bytes)))))
 			     (with-tn@fp-top(x)
 			       ,@(ecase format 
 				    (:single '((inst fst  ea)))
-				    (:double '((inst fstd ea)))))))))))
+				    (:double '((inst fstd ea)))
+				    #+long-float
+				    (:long '((store-long-float ea)))))))))))
 		(define-move-vop ,name :move-argument
 		  (,sc descriptor-reg) (,sc)))))
   (frob move-single-float-argument single-reg single-stack :single)
-  (frob move-double-float-argument double-reg double-stack :double))
+  (frob move-double-float-argument double-reg double-stack :double)
+  #+long-float
+  (frob move-long-float-argument long-reg long-stack :long))
 
 ;;;; Complex float move-argument vop
 #+complex-float
@@ -481,7 +660,7 @@
 			     :load-if (not (sc-is y ,sc))))
 		  (:results (y))
 		  (:note "complex float argument move")
-		  (:generator ,(ecase format (:single 2) (:double 3))
+		  (:generator ,(ecase format (:single 2) (:double 3) (:long 4))
 		    (sc-case y
 		      (,sc
 		       (unless (location= x y)
@@ -509,7 +688,11 @@
 					(ea-for-csf-real-stack y fp))))
 				    (:double
 				     '((inst fstd
-					(ea-for-cdf-real-stack y fp))))))
+					(ea-for-cdf-real-stack y fp))))
+				    #+long-float
+				    (:long
+				     '((store-long-float
+					(ea-for-clf-real-stack y fp))))))
 			       (t
 				(inst fxch real-tn)
 				,@(ecase format
@@ -518,7 +701,11 @@
 					(ea-for-csf-real-stack y fp))))
 				    (:double
 				     '((inst fstd
-					(ea-for-cdf-real-stack y fp)))))
+					(ea-for-cdf-real-stack y fp))))
+				    #+long-float
+				    (:long
+				     '((store-long-float
+					(ea-for-clf-real-stack y fp)))))
 				(inst fxch real-tn))))
 		       (let ((imag-tn (complex-double-reg-imag-tn x)))
 			 (inst fxch imag-tn)
@@ -526,18 +713,26 @@
 			     (:single
 			      '((inst fst (ea-for-csf-imag-stack y fp))))
 			     (:double
-			      '((inst fstd (ea-for-cdf-imag-stack y fp)))))
+			      '((inst fstd (ea-for-cdf-imag-stack y fp))))
+			     #+long-float
+			     (:long
+			      '((store-long-float
+				 (ea-for-clf-imag-stack y fp)))))
 			 (inst fxch imag-tn))))))
 		(define-move-vop ,name :move-argument
 		  (,sc descriptor-reg) (,sc)))))
   (frob move-complex-single-float-argument
 	complex-single-reg complex-single-stack :single)
   (frob move-complex-double-float-argument
-	complex-double-reg complex-double-stack :double))
+	complex-double-reg complex-double-stack :double)
+  #+long-float
+  (frob move-complex-long-float-argument
+	complex-long-reg complex-long-stack :long))
 
 (define-move-vop move-argument :move-argument
-  (single-reg double-reg
-   #+complex-float complex-single-reg #+complex-float complex-double-reg)
+  (single-reg double-reg #+long-float long-reg
+   #+complex-float complex-single-reg #+complex-float complex-double-reg
+   #+(and complex-float long-float) complex-long-reg)
   (descriptor-reg))
 
 
@@ -575,7 +770,8 @@
 (macrolet
     ((frob (op fop-sti fopr-sti
 	       fop fopr sname scost
-	       fopd foprd dname dcost)
+	       fopd foprd dname dcost
+	       lname lcost)
        `(progn
 	 (define-vop (,sname)
 	   (:translate ,op)
@@ -867,20 +1063,111 @@
 			(t
 			 (inst fst r))))
 		 (double-stack
-		  (inst fstd (ea-for-df-stack r)))))))))))
+		  (inst fstd (ea-for-df-stack r))))))))
+
+	 #+long-float
+	 (define-vop (,lname)
+	   (:translate ,op)
+	   (:args (x :scs (long-reg) :to :eval)
+		  (y :scs (long-reg) :to :eval))
+	   (:temporary (:sc long-reg :offset fr0-offset
+			    :from :eval :to :result) fr0)
+	   (:results (r :scs (long-reg)))
+	   (:arg-types long-float long-float)
+	   (:result-types long-float)
+	   (:policy :fast-safe)
+	   (:note "inline float arithmetic")
+	   (:vop-var vop)
+	   (:save-p :compute-only)
+	   (:node-var node)
+	   (:generator ,lcost
+	     ;; Handle a few special cases
+	     (cond
+	      ;; x, y, and r are the same register.
+	      ((and (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.
+	      ((location= x r)
+	       (cond ((zerop (tn-offset r))
+		      ;; ST(0) = ST(0) op ST(y)
+		      (inst ,fopd y))
+		     (t
+		      ;; y to ST0
+		      (unless (zerop (tn-offset y))
+			(copy-fp-reg-to-fr0 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.
+	      ((location= y r)
+	       (cond ((zerop (tn-offset r))
+		      ;; ST(0) = ST(x) op ST(0)
+		      (inst ,foprd x))
+		     (t
+		      ;; x to ST0
+		      (unless (zerop (tn-offset x))
+			(copy-fp-reg-to-fr0 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
+		((zerop (tn-offset x))
+		 ;; ST0 = ST0 op y
+		 (inst ,fopd y))
+		;; y is in ST0
+		((zerop (tn-offset y))
+		 ;; ST0 = x op ST0
+		 (inst ,foprd x))
+		(t
+		 ;; x to ST0
+		 (copy-fp-reg-to-fr0 x)
+		 ;; ST0 = ST0 op y
+		 (inst ,fopd y)))
+
+	       (note-next-instruction vop :internal-error)
+
+	       ;; Finally save the result
+	       (cond ((zerop (tn-offset r))
+		      (when (policy node (or (= debug 3) (> safety speed)))
+			(inst wait)))
+		     (t
+		      (inst fst r))))))))))
     
     (frob + fadd-sti fadd-sti
 	  fadd fadd +/single-float 2
-	  faddd faddd +/double-float 2)
+	  faddd faddd +/double-float 2
+	  +/long-float 2)
     (frob - fsub-sti fsubr-sti
 	  fsub fsubr -/single-float 2
-	  fsubd fsubrd -/double-float 2)
+	  fsubd fsubrd -/double-float 2
+	  -/long-float 2)
     (frob * fmul-sti fmul-sti
 	  fmul fmul */single-float 3
-	  fmuld fmuld */double-float 3)
+	  fmuld fmuld */double-float 3
+	  */long-float 3)
     (frob / fdiv-sti fdivr-sti
 	  fdiv fdivr //single-float 12
-	  fdivd fdivrd //double-float 12))
+	  fdivd fdivrd //double-float 12
+	  //long-float 12))
 
 
 (macrolet ((frob (name inst translate sc type)
@@ -909,8 +1196,12 @@
 
   (frob abs/single-float fabs abs single-reg single-float)
   (frob abs/double-float fabs abs double-reg double-float)
+  #+long-float
+  (frob abs/long-float fabs abs long-reg long-float)
   (frob %negate/single-float fchs %negate single-reg single-float)
-  (frob %negate/double-float fchs %negate double-reg double-float))
+  (frob %negate/double-float fchs %negate double-reg double-float)
+  #+long-float
+  (frob %negate/long-float fchs %negate long-reg long-float))
 
 
 ;;;; Comparison:
@@ -961,6 +1252,13 @@
 	 (y :scs (double-reg)))
   (:arg-types double-float double-float))
 
+#+long-float
+(define-vop (=/long-float =/float)
+  (:translate =)
+  (:args (x :scs (long-reg))
+	 (y :scs (long-reg)))
+  (:arg-types long-float long-float))
+
 
 (define-vop (<single-float)
   (:translate <)
@@ -1064,6 +1362,42 @@
       (inst cmp ah-tn #x01)))
     (inst jmp (if not-p :ne :e) target)))
 
+#+long-float
+(define-vop (<long-float)
+  (:translate <)
+  (:args (x :scs (long-reg))
+	 (y :scs (long-reg)))
+  (:arg-types long-float long-float)
+  (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
+  (:conditional)
+  (:info target not-p)
+  (:policy :fast-safe)
+  (:note "inline float comparison")
+  (:ignore temp)
+  (:generator 3
+    (cond
+      ;; x is in ST0; y is in any reg.
+      ((zerop (tn-offset x))
+       (inst fcomd y)
+       (inst fnstsw)			; status word to ax
+       (inst and ah-tn #x45)		; C3 C2 C0
+       (inst cmp ah-tn #x01))
+      ;; y is in ST0; x is in another reg.
+      ((zerop (tn-offset y))
+       (inst fcomd x)
+       (inst fnstsw)			; status word to ax
+       (inst and ah-tn #x45))
+      ;; x and y are the same register, not ST0
+      ;; x and y are different registers, neither ST0.
+      (t
+       (inst fxch y)
+       (inst fcomd x)
+       (inst fxch y)
+       (inst fnstsw)			; status word to ax
+       (inst and ah-tn #x45)))		; C3 C2 C0
+    (inst jmp (if not-p :ne :e) target)))
+
+
 (define-vop (>single-float)
   (:translate >)
   (:args (x :scs (single-reg single-stack descriptor-reg))
@@ -1166,6 +1500,41 @@
       (inst and ah-tn #x45)))
     (inst jmp (if not-p :ne :e) target)))
 
+#+long-float
+(define-vop (>long-float)
+  (:translate >)
+  (:args (x :scs (long-reg))
+	 (y :scs (long-reg)))
+  (:arg-types long-float long-float)
+  (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
+  (:conditional)
+  (:info target not-p)
+  (:policy :fast-safe)
+  (:note "inline float comparison")
+  (:ignore temp)
+  (:generator 3
+    (cond
+      ;; y is in ST0; x is in any reg.
+      ((zerop (tn-offset y))
+       (inst fcomd x)
+       (inst fnstsw)			; status word to ax
+       (inst and ah-tn #x45)
+       (inst cmp ah-tn #x01))
+      ;; x is in ST0; y is in another reg.
+      ((zerop (tn-offset x))
+       (inst fcomd y)
+       (inst fnstsw)			; status word to ax
+       (inst and ah-tn #x45))
+      ;; y and x are the same register, not ST0
+      ;; y and x are different registers, neither ST0.
+      (t
+       (inst fxch x)
+       (inst fcomd y)
+       (inst fxch x)
+       (inst fnstsw)			; status word to ax
+       (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)
@@ -1212,6 +1581,15 @@
   #+negative-zero-is-not-zero
   (:arg-types double-float (:constant (double-float -0d0 0d0)))
   (:variant #x40))
+#+long-float
+(define-vop (=0/long-float float-test)
+  (:translate =)
+  (:args (x :scs (long-reg)))
+  #-negative-zero-is-not-zero
+  (:arg-types long-float (:constant (long-float 0l0 0l0)))
+  #+negative-zero-is-not-zero
+  (:arg-types double-float (:constant (long-float -0l0 0l0)))
+  (:variant #x40))
 
 (define-vop (<0/single-float float-test)
   (:translate <)
@@ -1229,6 +1607,15 @@
   #+negative-zero-is-not-zero
   (:arg-types double-float (:constant (double-float -0d0 0d0)))
   (:variant #x01))
+#+long-float
+(define-vop (<0/long-float float-test)
+  (:translate <)
+  (:args (x :scs (long-reg)))
+  #-negative-zero-is-not-zero
+  (:arg-types long-float (:constant (long-float 0l0 0l0)))
+  #+negative-zero-is-not-zero
+  (:arg-types long-float (:constant (long-float -0l0 0l0)))
+  (:variant #x01))
 
 (define-vop (>0/single-float float-test)
   (:translate >)
@@ -1246,6 +1633,21 @@
   #+negative-zero-is-not-zero
   (:arg-types double-float (:constant (double-float -0d0 0d0)))
   (:variant #x00))
+#+long-float
+(define-vop (>0/long-float float-test)
+  (:translate >)
+  (:args (x :scs (long-reg)))
+  #-negative-zero-is-not-zero
+  (:arg-types long-float (:constant (long-float 0l0 0l0)))
+  #+negative-zero-is-not-zero
+  (:arg-types long-float (:constant (long-float -0l0 0l0)))
+  (:variant #x00))
+
+#+long-float
+(deftransform eql ((x y) (long-float long-float))
+  `(and (= (long-float-low-bits x) (long-float-low-bits y))
+	(= (long-float-high-bits x) (long-float-high-bits y))
+	(= (long-float-exp-bits x) (long-float-exp-bits y))))
 
 
 ;;;; Conversion:
@@ -1274,7 +1676,9 @@
 		       (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))
+  (frob %double-float/signed %double-float double-reg double-float)
+  #+long-float
+  (frob %long-float/signed %long-float long-reg long-float))
 
 (macrolet ((frob (name translate to-sc to-type)
 	     `(define-vop (,name)
@@ -1295,7 +1699,9 @@
 		   (inst fildl (make-ea :dword :base esp-tn)))
 		 (inst add esp-tn 8)))))
   (frob %single-float/unsigned %single-float single-reg single-float)
-  (frob %double-float/unsigned %double-float double-reg double-float))
+  (frob %double-float/unsigned %double-float double-reg double-float)
+  #+long-float
+  (frob %long-float/unsigned %long-float long-reg long-float))
 
 ;;; These should be no-ops but the compiler might want to move
 ;;; some things around
@@ -1329,8 +1735,20 @@
   
   (frob %single-float/double-float %single-float double-reg
 	double-float single-reg single-float)
+  #+long-float
+  (frob %single-float/long-float %single-float long-reg
+	long-float single-reg single-float)
   (frob %double-float/single-float %double-float single-reg single-float
-	double-reg double-float))
+	double-reg double-float)
+  #+long-float
+  (frob %double-float/long-float %double-float long-reg long-float
+	double-reg double-float)
+  #+long-float
+  (frob %long-float/single-float %long-float single-reg single-float
+	long-reg long-float)
+  #+long-float
+  (frob %long-float/double-float %long-float double-reg double-float
+	long-reg long-float))
 
 
 
@@ -1373,8 +1791,12 @@
 		      '((inst fldcw scw)))))))))
   (frob %unary-truncate single-reg single-float nil)
   (frob %unary-truncate double-reg double-float nil)
+  #+long-float
+  (frob %unary-truncate long-reg long-float nil)
   (frob %unary-round single-reg single-float t)
-  (frob %unary-round double-reg double-float t))
+  (frob %unary-round double-reg double-float t)
+  #+long-float
+  (frob %unary-round long-reg long-float t))
 
 (macrolet ((frob (trans from-sc from-type round-p)
 	     `(define-vop (,(symbolicate trans "/" from-type "=>UNSIGNED"))
@@ -1416,8 +1838,12 @@
 		   '((inst fldcw scw)))))))
   (frob %unary-truncate single-reg single-float nil)
   (frob %unary-truncate double-reg double-float nil)
+  #+long-float
+  (frob %unary-truncate long-reg long-float nil)
   (frob %unary-round single-reg single-float t)
-  (frob %unary-round double-reg double-float t))
+  (frob %unary-round double-reg double-float t)
+  #+long-float
+  (frob %unary-round long-reg long-float t))
 
 
 (define-vop (make-single-float)
@@ -1471,6 +1897,27 @@
 	(inst fldd (make-ea :dword :base ebp-tn
 			    :disp (- (* (1+ offset) word-bytes))))))))
 
+#+long-float
+(define-vop (make-long-float)
+  (:args (exp-bits :scs (signed-reg))
+	 (hi-bits :scs (unsigned-reg))
+	 (lo-bits :scs (unsigned-reg)))
+  (:results (res :scs (long-reg)))
+  (:temporary (:sc long-stack) temp)
+  (:arg-types signed-num unsigned-num unsigned-num)
+  (:result-types long-float)
+  (:translate make-long-float)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 3
+    (let ((offset (1+ (tn-offset temp))))
+      (storew exp-bits ebp-tn (- offset))
+      (storew hi-bits ebp-tn (- (1+ offset)))
+      (storew lo-bits ebp-tn (- (+ offset 2)))
+      (with-empty-tn@fp-top(res)
+	(inst fldl (make-ea :dword :base ebp-tn
+			    :disp (- (* (+ offset 2) word-bytes))))))))
+
 (define-vop (single-float-bits)
   (:args (float :scs (single-reg descriptor-reg)
 		:load-if (not (sc-is float single-stack))))
@@ -1550,6 +1997,90 @@
 	(loadw lo-bits float vm:double-float-value-slot
 	       vm:other-pointer-type)))))
 
+#+long-float
+(define-vop (long-float-exp-bits)
+  (:args (float :scs (long-reg descriptor-reg)
+		:load-if (not (sc-is float long-stack))))
+  (:results (exp-bits :scs (signed-reg)))
+  (:temporary (:sc long-stack) temp)
+  (:arg-types long-float)
+  (:result-types signed-num)
+  (:translate long-float-exp-bits)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 5
+     (sc-case float
+       (long-reg
+	(with-tn@fp-top(float)
+	  (let ((where (make-ea :dword :base ebp-tn
+				:disp (- (* (+ 3 (tn-offset temp))
+					    word-bytes)))))
+	    (store-long-float where)))
+	(inst movsx exp-bits
+	      (make-ea :word :base ebp-tn
+		       :disp (* (- (1+ (tn-offset temp))) word-bytes))))
+       (long-stack
+	(inst movsx exp-bits
+	      (make-ea :word :base ebp-tn
+		       :disp (* (- (1+ (tn-offset float))) word-bytes))))
+       (descriptor-reg
+	(inst movsx exp-bits
+	      (make-ea :word :base float
+		       :disp (- (* (+ 2 vm:long-float-value-slot) word-bytes)
+				vm:other-pointer-type)))))))
+
+#+long-float
+(define-vop (long-float-high-bits)
+  (:args (float :scs (long-reg descriptor-reg)
+		:load-if (not (sc-is float long-stack))))
+  (:results (hi-bits :scs (unsigned-reg)))
+  (:temporary (:sc long-stack) temp)
+  (:arg-types long-float)
+  (:result-types unsigned-num)
+  (:translate long-float-high-bits)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 5
+     (sc-case float
+       (long-reg
+	(with-tn@fp-top(float)
+	  (let ((where (make-ea :dword :base ebp-tn
+				:disp (- (* (+ 3 (tn-offset temp))
+					    word-bytes)))))
+	    (store-long-float where)))
+	(loadw hi-bits ebp-tn (- (+ (tn-offset temp) 2))))
+       (long-stack
+	(loadw hi-bits ebp-tn (- (+ (tn-offset float) 2))))
+       (descriptor-reg
+	(loadw hi-bits float (1+ vm:long-float-value-slot)
+	       vm:other-pointer-type)))))
+
+#+long-float
+(define-vop (long-float-low-bits)
+  (:args (float :scs (long-reg descriptor-reg)
+		:load-if (not (sc-is float long-stack))))
+  (:results (lo-bits :scs (unsigned-reg)))
+  (:temporary (:sc long-stack) temp)
+  (:arg-types long-float)
+  (:result-types unsigned-num)
+  (:translate long-float-low-bits)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 5
+     (sc-case float
+       (long-reg
+	(with-tn@fp-top(float)
+	  (let ((where (make-ea :dword :base ebp-tn
+				:disp (- (* (+ 3 (tn-offset temp))
+					    word-bytes)))))
+	    (store-long-float where)))
+	(loadw lo-bits ebp-tn (- (+ (tn-offset temp) 3))))
+       (long-stack
+	(loadw lo-bits ebp-tn (- (+ (tn-offset float) 3))))
+       (descriptor-reg
+	(loadw lo-bits float vm:long-float-value-slot
+	       vm:other-pointer-type)))))
+
 
 ;;;; Float mode hackery:
 
@@ -1606,6 +2137,9 @@
 
 
 
+#-long-float
+(progn
+
 ;;; Lets use some of the 80387 special functions.
 ;;;
 ;;; These defs will not take effect unless code/irrat.lisp is modified
@@ -2672,61 +3206,1087 @@
      (case (tn-offset r)
        ((0 1))
        (t (inst fstd r)))))
+
+) ; progn #-long-float
+
 
-;;;; Complex float VOPs
 
-#+complex-float
+#+long-float
 (progn
 
-(define-vop (make-complex-single-float)
-  (:translate complex)
-  (:args (real :scs (single-reg) :target r)
-	 (imag :scs (single-reg) :to :save))
-  (:arg-types single-float single-float)
-  (:results (r :scs (complex-single-reg complex-single-stack)
-	       :from (:argument 0)))
-  (:result-types complex-single-float)
-  (:note "inline complex single-float creation")
-  (:policy :fast-safe)
-  (:generator 5
-    (sc-case r
-      (complex-single-reg
-       (let ((r-real (complex-double-reg-real-tn r)))
-	 (unless (location= real r-real)
-	   (cond ((zerop (tn-offset r-real))
-		  (copy-fp-reg-to-fr0 real))
-		 ((zerop (tn-offset real))
-		  (inst fstd r-real))
-		 (t
-		  (inst fxch real)
-		  (inst fstd r-real)
-		  (inst fxch real)))))
-       (let ((r-imag (complex-double-reg-imag-tn r)))
-	 (unless (location= imag r-imag)
-	   (cond ((zerop (tn-offset imag))
-		  (inst fstd r-imag))
-		 (t
-		  (inst fxch imag)
-		  (inst fstd r-imag)
-		  (inst fxch imag))))))
-      (complex-single-stack
-       (cond ((zerop (tn-offset real))
-	      (inst fst (ea-for-csf-real-stack r)))
-	     (t
-	      (inst fxch real)
-	      (inst fst (ea-for-csf-real-stack r))
-	      (inst fxch real)))
+;;; 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 (long-reg) :target fr0))
+	       (:temporary (:sc long-reg :offset fr0-offset
+				:from :argument :to :result) fr0)
+	       (:ignore fr0)
+	       (:results (y :scs (long-reg)))
+	       (:arg-types long-float)
+	       (:result-types long-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)))))))
+
+  ;; Quick versions of fsin and fcos that require the argument to be
+  ;; within range 2^63.
+  (frob fsin-quick %sin-quick fsin)
+  (frob fcos-quick %cos-quick fcos)
+  ;;
+  (frob fsqrt %sqrt fsqrt))
+
+;;; Quick version of ftan that requires the argument to be within
+;;; range 2^63.
+(define-vop (ftan-quick)
+  (:translate %tan-quick)
+  (:args (x :scs (long-reg) :target fr0))
+  (:temporary (:sc long-reg :offset fr0-offset
+		   :from :argument :to :result) fr0)
+  (:temporary (:sc long-reg :offset fr1-offset
+		   :from :argument :to :result) fr1)
+  (:results (y :scs (long-reg)))
+  (:arg-types long-float)
+  (:result-types long-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 *backend*)
+				   :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)))))
+	     
+;;; These versions of fsin, fcos, and ftan try to use argument
+;;; reduction but to do this accurately requires greater precision and
+;;; it is hopelessly inaccurate.
+#+nil
+(macrolet ((frob (func trans op)
+	     `(define-vop (,func)
+		(:translate ,trans)
+		(:args (x :scs (long-reg) :target fr0))
+		(:temporary (:sc unsigned-reg :offset eax-offset
+				 :from :eval :to :result) eax)
+		(:temporary (:sc long-reg :offset fr0-offset
+				 :from :argument :to :result) fr0)
+		(:temporary (:sc long-reg :offset fr1-offset
+				 :from :argument :to :result) fr1)
+		(:results (y :scs (long-reg)))
+		(:arg-types long-float)
+		(:result-types long-float)
+		(:policy :fast-safe)
+		(:note "inline sin/cos function")
+		(:vop-var vop)
+		(:save-p :compute-only)
+		(:ignore eax)
+		(: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 ax
+		  (inst and ah-tn #x04)		 ; C2
+		  (inst jmp :z DONE)
+		  ;; Else x was out of range so reduce it; ST0 is unchanged.
+		  (inst fstp fr1) 		; Load 2*PI
+		  (inst fldpi)
+		  (inst fadd fr0)
+		  (inst fxch fr1)
+		  LOOP
+		  (inst fprem1)
+		  (inst fnstsw)		; status word to ax
+		  (inst and ah-tn #x04)	; C2
+		  (inst jmp :nz LOOP)
+		  (inst ,op)
+		  DONE
+		  (unless (zerop (tn-offset y))
+			  (inst fstd y))))))
+	  (frob fsin  %sin fsin)
+	  (frob fcos  %cos fcos))
+	     
+#+nil
+(define-vop (ftan)
+  (:translate %tan)
+  (:args (x :scs (long-reg) :target fr0))
+  (:temporary (:sc unsigned-reg :offset eax-offset
+		   :from :argument :to :result) eax)
+  (:temporary (:sc long-reg :offset fr0-offset
+		   :from :argument :to :result) fr0)
+  (:temporary (:sc long-reg :offset fr1-offset
+		   :from :argument :to :result) fr1)
+  (:results (y :scs (long-reg)))
+  (:arg-types long-float)
+  (:result-types long-float)
+  (:policy :fast-safe)
+  (:note "inline tan function")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:ignore eax)
+  (: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 *backend*)
+				   :offset (- (tn-offset x) 2)))))
+    (inst fptan)
+    (inst fnstsw)			 ; status word to ax
+    (inst and ah-tn #x04)		 ; C2
+    (inst jmp :z DONE)
+    ;; Else x was out of range so reduce it; ST0 is unchanged.
+    (inst fldpi)                         ; Load 2*PI
+    (inst fadd fr0)
+    (inst fxch fr1)
+    LOOP
+    (inst fprem1)
+    (inst fnstsw)			 ; status word to ax
+    (inst and ah-tn #x04)		 ; C2
+    (inst jmp :nz LOOP)
+    (inst fstp fr1)
+    (inst fptan)
+    DONE
+    ;; Result is in fr1
+    (case (tn-offset y)
+       (0
+	(inst fxch fr1))
+       (1)
+       (t
+	(inst fxch fr1)
+	(inst fstd y)))))
+
+;;; These versions of fsin, fcos, and ftan simply load a 0.0 result if
+;;; the argument is out of range 2^63 and would thus be hopelessly
+;;; inaccurate.
+(macrolet ((frob (func trans op)
+	     `(define-vop (,func)
+		(:translate ,trans)
+		(:args (x :scs (long-reg) :target fr0))
+		(:temporary (:sc long-reg :offset fr0-offset
+				 :from :argument :to :result) fr0)
+		(:temporary (:sc unsigned-reg :offset eax-offset
+			     :from :argument :to :result) eax)
+		(:results (y :scs (long-reg)))
+	        (:arg-types long-float)
+	        (:result-types long-float)
+		(:policy :fast-safe)
+		(:note "inline sin/cos function")
+		(:vop-var vop)
+		(:save-p :compute-only)
+	        (:ignore eax)
+		(: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 ax
+		  (inst and ah-tn #x04)		 ; C2
+		  (inst jmp :z DONE)
+		  ;; Else x was out of range so reduce it; ST0 is unchanged.
+		  (inst fstp fr0)                ; Load 0.0
+		  (inst fldz)
+		  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 (long-reg) :target fr0))
+  (:temporary (:sc long-reg :offset fr0-offset
+		   :from :argument :to :result) fr0)
+  (:temporary (:sc long-reg :offset fr1-offset
+		   :from :argument :to :result) fr1)
+  (:temporary (:sc unsigned-reg :offset eax-offset
+		   :from :argument :to :result) eax)
+  (:results (y :scs (long-reg)))
+  (:arg-types long-float)
+  (:result-types long-float)
+  (:ignore eax)
+  (:policy :fast-safe)
+  (:note "inline tan function")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:ignore eax)
+  (: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 *backend*)
+				   :offset (- (tn-offset x) 2)))))
+    (inst fptan)
+    (inst fnstsw)			 ; status word to ax
+    (inst and ah-tn #x04)		 ; C2
+    (inst jmp :z DONE)
+    ;; Else x was out of range so reduce it; ST0 is unchanged.
+    (inst fldz)                         ; Load 0.0
+    (inst fxch fr1)
+    DONE
+    ;; Result is in fr1
+    (case (tn-offset y)
+       (0
+	(inst fxch fr1))
+       (1)
+       (t
+	(inst fxch fr1)
+	(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 (long-reg) :target fr0))
+  (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
+  (:temporary (:sc long-reg :offset fr0-offset
+		   :from :argument :to :result) fr0)
+  (:temporary (:sc long-reg :offset fr1-offset
+		   :from :argument :to :result) fr1)
+  (:temporary (:sc long-reg :offset fr2-offset
+		   :from :argument :to :result) fr2)
+  (:results (y :scs (long-reg)))
+  (:arg-types long-float)
+  (:result-types long-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 (long-reg long-stack descriptor-reg) :target fr0))
+  (:temporary (:sc long-reg :offset fr0-offset
+		   :from :argument :to :result) fr0)
+  (:temporary (:sc long-reg :offset fr1-offset
+		   :from :argument :to :result) fr1)
+  (:results (y :scs (long-reg)))
+  (:arg-types long-float)
+  (:result-types long-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
+        (long-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 *backend*)
+					:offset (1- (tn-offset x))))))
+	 (inst fyl2x))
+	((long-stack descriptor-reg)
+	 (inst fstp fr0)
+	 (inst fstp fr0)
+	 (inst fldln2)
+	 (if (sc-is x long-stack)
+	     (inst fldl (ea-for-lf-stack x))
+	     (inst fldl (ea-for-lf-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 (long-reg long-stack descriptor-reg) :target fr0))
+  (:temporary (:sc long-reg :offset fr0-offset
+		   :from :argument :to :result) fr0)
+  (:temporary (:sc long-reg :offset fr1-offset
+		   :from :argument :to :result) fr1)
+  (:results (y :scs (long-reg)))
+  (:arg-types long-float)
+  (:result-types long-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
+        (long-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 *backend*)
+					:offset (1- (tn-offset x))))))
+	 (inst fyl2x))
+	((long-stack descriptor-reg)
+	 (inst fstp fr0)
+	 (inst fstp fr0)
+	 (inst fldlg2)
+	 (if (sc-is x long-stack)
+	     (inst fldl (ea-for-lf-stack x))
+	     (inst fldl (ea-for-lf-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 (long-reg long-stack descriptor-reg) :target fr0)
+	 (y :scs (long-reg long-stack descriptor-reg) :target fr1))
+  (:temporary (:sc long-reg :offset fr0-offset
+		   :from (:argument 0) :to :result) fr0)
+  (:temporary (:sc long-reg :offset fr1-offset
+		   :from (:argument 1) :to :result) fr1)
+  (:temporary (:sc long-reg :offset fr2-offset
+		   :from :load :to :result) fr2)
+  (:results (r :scs (long-reg)))
+  (:arg-types long-float long-float)
+  (:result-types long-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 long-reg) (zerop (tn-offset x))
+	    (sc-is y long-reg) (= 1 (tn-offset y))))
+      ;; y in fr1; x not in fr0
+      ((and (sc-is y long-reg) (= 1 (tn-offset y)))
+       ;; Load x to fr0
+       (sc-case x
+          (long-reg
+	   (copy-fp-reg-to-fr0 x))
+	  (long-stack
+	   (inst fstp fr0)
+	   (inst fldl (ea-for-lf-stack x)))
+	  (descriptor-reg
+	   (inst fstp fr0)
+	   (inst fldl (ea-for-lf-desc x)))))
+      ;; x in fr0; y not in fr1
+      ((and (sc-is x long-reg) (zerop (tn-offset x)))
+       (inst fxch fr1)
+       ;; Now load y to fr0
+       (sc-case y
+          (long-reg
+	   (copy-fp-reg-to-fr0 y))
+	  (long-stack
+	   (inst fstp fr0)
+	   (inst fldl (ea-for-lf-stack y)))
+	  (descriptor-reg
+	   (inst fstp fr0)
+	   (inst fldl (ea-for-lf-desc y))))
+       (inst fxch fr1))
+      ;; x in fr1; y not in fr1
+      ((and (sc-is x long-reg) (= 1 (tn-offset x)))
+       ;; Load y to fr0
+       (sc-case y
+          (long-reg
+	   (copy-fp-reg-to-fr0 y))
+	  (long-stack
+	   (inst fstp fr0)
+	   (inst fldl (ea-for-lf-stack y)))
+	  (descriptor-reg
+	   (inst fstp fr0)
+	   (inst fldl (ea-for-lf-desc y))))
+       (inst fxch fr1))
+      ;; y in fr0;
+      ((and (sc-is y long-reg) (zerop (tn-offset y)))
+       (inst fxch fr1)
+       ;; Now load x to fr0
+       (sc-case x
+          (long-reg
+	   (copy-fp-reg-to-fr0 x))
+	  (long-stack
+	   (inst fstp fr0)
+	   (inst fldl (ea-for-lf-stack x)))
+	  (descriptor-reg
+	   (inst fstp fr0)
+	   (inst fldl (ea-for-lf-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
+          (long-reg
+	   (inst fldd (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'double-reg *backend*)
+				      :offset (- (tn-offset y) 2))))
+	  (long-stack
+	   (inst fldl (ea-for-lf-stack y)))
+	  (descriptor-reg
+	   (inst fldl (ea-for-lf-desc y))))
+       ;; Load x to fr0
+       (sc-case x
+          (long-reg
+	   (inst fldd (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'double-reg *backend*)
+				      :offset (1- (tn-offset x)))))
+	  (long-stack
+	   (inst fldl (ea-for-lf-stack x)))
+	  (descriptor-reg
+	   (inst fldl (ea-for-lf-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 (long-reg long-stack descriptor-reg) :target fr0)
+	 (y :scs (signed-stack signed-reg) :target temp))
+  (:temporary (:sc long-reg :offset fr0-offset
+		   :from (:argument 0) :to :result) fr0)
+  (:temporary (:sc long-reg :offset fr1-offset :from :eval :to :result) fr1)
+  (:temporary (:sc signed-stack :from (:argument 1) :to :result) temp)
+  (:results (r :scs (long-reg)))
+  (:arg-types long-float signed-num)
+  (:result-types long-float)
+  (:policy :fast-safe)
+  (:note "inline scalbn function")
+  (:generator 5
+     ;; Setup x in fr0 and y in fr1
+     (sc-case x
+       (long-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 *backend*)
+				     :offset (1- (tn-offset x)))))))
+       ((long-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 long-stack)
+	    (inst fldl (ea-for-lf-stack x))
+	    (inst fldl (ea-for-lf-desc x)))))
+     (inst fscale)
+     (unless (zerop (tn-offset r))
+       (inst fstd r))))
+
+(define-vop (fscale)
+  (:translate %scalb)
+  (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
+	 (y :scs (long-reg long-stack descriptor-reg) :target fr1))
+  (:temporary (:sc long-reg :offset fr0-offset
+		   :from (:argument 0) :to :result) fr0)
+  (:temporary (:sc long-reg :offset fr1-offset
+		   :from (:argument 1) :to :result) fr1)
+  (:results (r :scs (long-reg)))
+  (:arg-types long-float long-float)
+  (:result-types long-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 long-reg) (zerop (tn-offset x))
+	    (sc-is y long-reg) (= 1 (tn-offset y))))
+      ;; y in fr1; x not in fr0
+      ((and (sc-is y long-reg) (= 1 (tn-offset y)))
+       ;; Load x to fr0
+       (sc-case x
+          (long-reg
+	   (copy-fp-reg-to-fr0 x))
+	  (long-stack
+	   (inst fstp fr0)
+	   (inst fldl (ea-for-lf-stack x)))
+	  (descriptor-reg
+	   (inst fstp fr0)
+	   (inst fldl (ea-for-lf-desc x)))))
+      ;; x in fr0; y not in fr1
+      ((and (sc-is x long-reg) (zerop (tn-offset x)))
+       (inst fxch fr1)
+       ;; Now load y to fr0
+       (sc-case y
+          (long-reg
+	   (copy-fp-reg-to-fr0 y))
+	  (long-stack
+	   (inst fstp fr0)
+	   (inst fldl (ea-for-lf-stack y)))
+	  (descriptor-reg
+	   (inst fstp fr0)
+	   (inst fldl (ea-for-lf-desc y))))
+       (inst fxch fr1))
+      ;; x in fr1; y not in fr1
+      ((and (sc-is x long-reg) (= 1 (tn-offset x)))
+       ;; Load y to fr0
+       (sc-case y
+          (long-reg
+	   (copy-fp-reg-to-fr0 y))
+	  (long-stack
+	   (inst fstp fr0)
+	   (inst fldl (ea-for-lf-stack y)))
+	  (descriptor-reg
+	   (inst fstp fr0)
+	   (inst fldl (ea-for-lf-desc y))))
+       (inst fxch fr1))
+      ;; y in fr0;
+      ((and (sc-is y long-reg) (zerop (tn-offset y)))
+       (inst fxch fr1)
+       ;; Now load x to fr0
+       (sc-case x
+          (long-reg
+	   (copy-fp-reg-to-fr0 x))
+	  (long-stack
+	   (inst fstp fr0)
+	   (inst fldl (ea-for-lf-stack x)))
+	  (descriptor-reg
+	   (inst fstp fr0)
+	   (inst fldl (ea-for-lf-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
+          (long-reg
+	   (inst fldd (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'double-reg *backend*)
+				      :offset (- (tn-offset y) 2))))
+	  (long-stack
+	   (inst fldl (ea-for-lf-stack y)))
+	  (descriptor-reg
+	   (inst fldl (ea-for-lf-desc y))))
+       ;; Load x to fr0
+       (sc-case x
+          (long-reg
+	   (inst fldd (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'double-reg *backend*)
+				      :offset (1- (tn-offset x)))))
+	  (long-stack
+	   (inst fldl (ea-for-lf-stack x)))
+	  (descriptor-reg
+	   (inst fldl (ea-for-lf-desc x))))))
+      
+     ;; Now have x at fr0; and y at fr1
+     (inst fscale)
+     (unless (zerop (tn-offset r))
+	     (inst fstd r))))
+
+(define-vop (flog1p)
+  (:translate %log1p)
+  (:args (x :scs (long-reg) :to :result))
+  (:temporary (:sc long-reg :offset fr0-offset
+		   :from :argument :to :result) fr0)
+  (:temporary (:sc long-reg :offset fr1-offset
+		   :from :argument :to :result) fr1)
+  (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
+  (:results (y :scs (long-reg)))
+  (:arg-types long-float)
+  (:result-types long-float)
+  (:policy :fast-safe)
+  (:guard (not (backend-featurep :pentium)))
+  (:note "inline log1p function")
+  (:ignore temp)
+  (:generator 5
+     ;; x is in a FP reg, not fr0, fr1.
+     (inst fstp fr0)
+     (inst fstp fr0)
+     (inst fldd (make-random-tn :kind :normal
+				:sc (sc-or-lose 'double-reg *backend*)
+				:offset (- (tn-offset x) 2)))
+     ;; Check the range
+     (inst push #x3e947ae1)	; Constant 0.29
+     (inst fabs)
+     (inst fld (make-ea :dword :base esp-tn))
+     (inst fcompp)
+     (inst add esp-tn 4)
+     (inst fnstsw)			; status word to ax
+     (inst and ah-tn #x45)
+     (inst jmp :z WITHIN-RANGE)
+     ;; Out of range for fyl2xp1.
+     (inst fld1)
+     (inst faddd (make-random-tn :kind :normal
+				 :sc (sc-or-lose 'double-reg *backend*)
+				 :offset (- (tn-offset x) 1)))
+     (inst fldln2)
+     (inst fxch fr1)
+     (inst fyl2x)
+     (inst jmp DONE)
+
+     WITHIN-RANGE
+     (inst fldln2)
+     (inst fldd (make-random-tn :kind :normal
+				:sc (sc-or-lose 'double-reg *backend*)
+				:offset (- (tn-offset x) 1)))
+     (inst fyl2xp1)
+     DONE
+     (inst fld fr0)
+     (case (tn-offset y)
+       ((0 1))
+       (t (inst fstd y)))))
+
+;;; The Pentium has a less restricted implementation of the fyl2xp1
+;;; instruction and a range check can be avoided.
+(define-vop (flog1p-pentium)
+  (:translate %log1p)
+  (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
+  (:temporary (:sc long-reg :offset fr0-offset
+		   :from :argument :to :result) fr0)
+  (:temporary (:sc long-reg :offset fr1-offset
+		   :from :argument :to :result) fr1)
+  (:results (y :scs (long-reg)))
+  (:arg-types long-float)
+  (:result-types long-float)
+  (:policy :fast-safe)
+  (:guard (backend-featurep :pentium))
+  (:note "inline log1p function")
+  (:generator 5
+     (sc-case x
+        (long-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 *backend*)
+					:offset (- (tn-offset x) 2))))))
+	((long-stack descriptor-reg)
+	 (inst fstp fr0)
+	 (inst fstp fr0)
+	 (inst fldln2)
+	 (if (sc-is x long-stack)
+	     (inst fldl (ea-for-lf-stack x))
+	   (inst fldl (ea-for-lf-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 (long-reg long-stack descriptor-reg) :target fr0))
+  (:temporary (:sc long-reg :offset fr0-offset
+		   :from :argument :to :result) fr0)
+  (:temporary (:sc long-reg :offset fr1-offset
+		   :from :argument :to :result) fr1)
+  (:results (y :scs (long-reg)))
+  (:arg-types long-float)
+  (:result-types long-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
+        (long-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 *backend*)
+					:offset (- (tn-offset x) 2))))))
+	((long-stack descriptor-reg)
+	 (inst fstp fr0)
+	 (inst fstp fr0)
+	 (if (sc-is x long-stack)
+	     (inst fldl (ea-for-lf-stack x))
+	   (inst fldl (ea-for-lf-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 (long-reg long-stack descriptor-reg) :target fr0))
+  (:temporary (:sc long-reg :offset fr0-offset
+		   :from (:argument 0) :to :result) fr0)
+  (:temporary (:sc long-reg :offset fr1-offset
+		   :from (:argument 0) :to :result) fr1)
+  (:results (r :scs (long-reg)))
+  (:arg-types long-float)
+  (:result-types long-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 long-reg) (zerop (tn-offset x)))
+       (inst fstp fr1))
+      ;; x in fr1
+      ((and (sc-is x long-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
+          (long-reg
+	   (inst fldd (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'double-reg *backend*)
+				      :offset (- (tn-offset x) 2))))
+	  (long-stack
+	   (inst fldl (ea-for-lf-stack x)))
+	  (descriptor-reg
+	   (inst fldl (ea-for-lf-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 (long-reg long-stack descriptor-reg) :target fr1)
+	 (y :scs (long-reg long-stack descriptor-reg) :target fr0))
+  (:temporary (:sc long-reg :offset fr0-offset
+		   :from (:argument 1) :to :result) fr0)
+  (:temporary (:sc long-reg :offset fr1-offset
+		   :from (:argument 0) :to :result) fr1)
+  (:results (r :scs (long-reg)))
+  (:arg-types long-float long-float)
+  (:result-types long-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 long-reg) (zerop (tn-offset y))
+	    (sc-is x long-reg) (= 1 (tn-offset x))))
+      ;; x in fr1; y not in fr0
+      ((and (sc-is x long-reg) (= 1 (tn-offset x)))
+       ;; Load y to fr0
+       (sc-case y
+          (long-reg
+	   (copy-fp-reg-to-fr0 y))
+	  (long-stack
+	   (inst fstp fr0)
+	   (inst fldl (ea-for-lf-stack y)))
+	  (descriptor-reg
+	   (inst fstp fr0)
+	   (inst fldl (ea-for-lf-desc y)))))
+      ;; y in fr0; x not in fr1
+      ((and (sc-is y long-reg) (zerop (tn-offset y)))
+       (inst fxch fr1)
+       ;; Now load x to fr0
+       (sc-case x
+          (long-reg
+	   (copy-fp-reg-to-fr0 x))
+	  (long-stack
+	   (inst fstp fr0)
+	   (inst fldl (ea-for-lf-stack x)))
+	  (descriptor-reg
+	   (inst fstp fr0)
+	   (inst fldl (ea-for-lf-desc x))))
+       (inst fxch fr1))
+      ;; y in fr1; x not in fr1
+      ((and (sc-is y long-reg) (= 1 (tn-offset y)))
+       ;; Load x to fr0
+       (sc-case x
+          (long-reg
+	   (copy-fp-reg-to-fr0 x))
+	  (long-stack
+	   (inst fstp fr0)
+	   (inst fldl (ea-for-lf-stack x)))
+	  (descriptor-reg
+	   (inst fstp fr0)
+	   (inst fldl (ea-for-lf-desc x))))
+       (inst fxch fr1))
+      ;; x in fr0;
+      ((and (sc-is x long-reg) (zerop (tn-offset x)))
+       (inst fxch fr1)
+       ;; Now load y to fr0
+       (sc-case y
+          (long-reg
+	   (copy-fp-reg-to-fr0 y))
+	  (long-stack
+	   (inst fstp fr0)
+	   (inst fldl (ea-for-lf-stack y)))
+	  (descriptor-reg
+	   (inst fstp fr0)
+	   (inst fldl (ea-for-lf-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
+          (long-reg
+	   (inst fldd (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'double-reg *backend*)
+				      :offset (- (tn-offset x) 2))))
+	  (long-stack
+	   (inst fldl (ea-for-lf-stack x)))
+	  (descriptor-reg
+	   (inst fldl (ea-for-lf-desc x))))
+       ;; Load y to fr0
+       (sc-case y
+          (long-reg
+	   (inst fldd (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'double-reg *backend*)
+				      :offset (1- (tn-offset y)))))
+	  (long-stack
+	   (inst fldl (ea-for-lf-stack y)))
+	  (descriptor-reg
+	   (inst fldl (ea-for-lf-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)))))
+
+) ; progn #+long-float
+
+
+;;;; Complex float VOPs
+
+#+complex-float
+(progn
+
+(define-vop (make-complex-single-float)
+  (:translate complex)
+  (:args (real :scs (single-reg) :to :result :target r
+	       :load-if (not (location= real r)))
+	 (imag :scs (single-reg) :to :save))
+  (:arg-types single-float single-float)
+  (:results (r :scs (complex-single-reg) :from (:argument 0)
+	       :load-if (not (sc-is r complex-single-stack))))
+  (:result-types complex-single-float)
+  (:note "inline complex single-float creation")
+  (:policy :fast-safe)
+  (:generator 5
+    (sc-case r
+      (complex-single-reg
+       (let ((r-real (complex-double-reg-real-tn r)))
+	 (unless (location= real r-real)
+	   (cond ((zerop (tn-offset r-real))
+		  (copy-fp-reg-to-fr0 real))
+		 ((zerop (tn-offset real))
+		  (inst fstd r-real))
+		 (t
+		  (inst fxch real)
+		  (inst fstd r-real)
+		  (inst fxch real)))))
+       (let ((r-imag (complex-double-reg-imag-tn r)))
+	 (unless (location= imag r-imag)
+	   (cond ((zerop (tn-offset imag))
+		  (inst fstd r-imag))
+		 (t
+		  (inst fxch imag)
+		  (inst fstd r-imag)
+		  (inst fxch imag))))))
+      (complex-single-stack
+       (unless (location= real r)
+	 (cond ((zerop (tn-offset real))
+		(inst fst (ea-for-csf-real-stack r)))
+	       (t
+		(inst fxch real)
+		(inst fst (ea-for-csf-real-stack r))
+		(inst fxch real))))
        (inst fxch imag)
        (inst fst (ea-for-csf-imag-stack r))
        (inst fxch imag)))))
 
 (define-vop (make-complex-double-float)
   (:translate complex)
-  (:args (real :scs (double-reg) :target r)
+  (:args (real :scs (double-reg) :target r
+	       :load-if (not (location= real r)))
 	 (imag :scs (double-reg) :to :save))
   (:arg-types double-float double-float)
-  (:results (r :scs (complex-double-reg complex-double-stack)
-	       :from (:argument 0)))
+  (:results (r :scs (complex-double-reg) :from (:argument 0)
+	       :load-if (not (sc-is r complex-double-stack))))
   (:result-types complex-double-float)
   (:note "inline complex double-float creation")
   (:policy :fast-safe)
@@ -2752,12 +4312,13 @@
 		  (inst fstd r-imag)
 		  (inst fxch imag))))))
       (complex-double-stack
-       (cond ((zerop (tn-offset real))
-	      (inst fstd (ea-for-cdf-real-stack r)))
-	     (t
-	      (inst fxch real)
-	      (inst fstd (ea-for-cdf-real-stack r))
-	      (inst fxch real)))
+       (unless (location= real r)
+	 (cond ((zerop (tn-offset real))
+		(inst fstd (ea-for-cdf-real-stack r)))
+	       (t
+		(inst fxch real)
+		(inst fstd (ea-for-cdf-real-stack r))
+		(inst fxch real))))
        (inst fxch imag)
        (inst fstd (ea-for-cdf-imag-stack r))
        (inst fxch imag)))))
@@ -2765,11 +4326,12 @@
 #+long-float
 (define-vop (make-complex-long-float)
   (:translate complex)
-  (:args (real :scs (long-reg) :target r)
+  (:args (real :scs (long-reg) :target r
+	       :load-if (not (location= real r)))
 	 (imag :scs (long-reg) :to :save))
   (:arg-types long-float long-float)
-  (:results (r :scs (complex-long-reg complex-long-stack)
-	       :from (:argument 0)))
+  (:results (r :scs (complex-long-reg) :from (:argument 0)
+	       :load-if (not (sc-is r complex-long-stack))))
   (:result-types complex-long-float)
   (:note "inline complex long-float creation")
   (:policy :fast-safe)
@@ -2795,12 +4357,13 @@
 		  (inst fstd r-imag)
 		  (inst fxch imag))))))
       (complex-long-stack
-       (cond ((zerop (tn-offset real))
-	      (store-long-float (ea-for-clf-real-stack r)))
-	     (t
-	      (inst fxch real)
-	      (store-long-float (ea-for-clf-real-stack r))
-	      (inst fxch real)))
+       (unless (location= real r)
+	 (cond ((zerop (tn-offset real))
+		(store-long-float (ea-for-clf-real-stack r)))
+	       (t
+		(inst fxch real)
+		(store-long-float (ea-for-clf-real-stack r))
+		(inst fxch real))))
        (inst fxch imag)
        (store-long-float (ea-for-clf-imag-stack r))
        (inst fxch imag)))))
@@ -2812,7 +4375,8 @@
   (:variant-vars offset)
   (:policy :fast-safe)
   (:generator 3
-    (cond ((sc-is x complex-single-reg complex-double-reg)
+    (cond ((sc-is x complex-single-reg complex-double-reg
+		  #+long-float complex-long-reg)
 	   (let ((value-tn
 		  (make-random-tn :kind :normal
 				  :sc (sc-or-lose 'double-reg *backend*)
@@ -2850,6 +4414,19 @@
 			  (1 (ea-for-cdf-imag-desc x)))))))
 	     (with-empty-tn@fp-top(r)
 	       (inst fldd ea))))
+	  #+long-float
+	  ((sc-is r long-reg)
+	   (let ((ea (sc-case x
+		       (complex-long-stack
+			(ecase offset
+			  (0 (ea-for-clf-real-stack x))
+			  (1 (ea-for-clf-imag-stack x))))
+		       (descriptor-reg
+			(ecase offset
+			  (0 (ea-for-clf-real-desc x))
+			  (1 (ea-for-clf-imag-desc x)))))))
+	     (with-empty-tn@fp-top(r)
+	       (inst fldl ea))))
 	  (t (error "Complex-float-value VOP failure")))))
 
 (define-vop (realpart/complex-single-float complex-float-value)
@@ -2872,6 +4449,17 @@
   (:note "complex float realpart")
   (:variant 0))
 
+#+long-float
+(define-vop (realpart/complex-long-float complex-float-value)
+  (:translate realpart)
+  (:args (x :scs (complex-long-reg complex-long-stack descriptor-reg)
+	    :target r))
+  (:arg-types complex-long-float)
+  (:results (r :scs (long-reg)))
+  (:result-types long-float)
+  (:note "complex float realpart")
+  (:variant 0))
+
 (define-vop (imagpart/complex-single-float complex-float-value)
   (:translate imagpart)
   (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
@@ -2892,6 +4480,17 @@
   (:note "complex float imagpart")
   (:variant 1))
 
+#+long-float
+(define-vop (imagpart/complex-long-float complex-float-value)
+  (:translate imagpart)
+  (:args (x :scs (complex-long-reg complex-long-stack descriptor-reg)
+	    :target r))
+  (:arg-types complex-long-float)
+  (:results (r :scs (long-reg)))
+  (:result-types long-float)
+  (:note "complex float imagpart")
+  (:variant 1))
+
 ) ; complex-float
 
 
diff --git a/compiler/x86/parms.lisp b/compiler/x86/parms.lisp
index dfc53a5da7575ef88385bf435abdf42f46812dec..0b86086117035958215fbed8682b85da990f370d 100644
--- a/compiler/x86/parms.lisp
+++ b/compiler/x86/parms.lisp
@@ -7,7 +7,7 @@
 ;;; 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.9 1997/11/18 16:55:53 dtc Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/parms.lisp,v 1.10 1998/03/21 07:54:39 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -76,6 +76,11 @@
 	  double-float-normal-exponent-max double-float-hidden-bit
 	  double-float-trapping-nan-bit double-float-digits
 
+	  long-float-bias long-float-exponent-byte
+	  long-float-significand-byte long-float-normal-exponent-min
+	  long-float-normal-exponent-max long-float-hidden-bit
+	  long-float-trapping-nan-bit long-float-digits
+
 	  float-underflow-trap-bit float-overflow-trap-bit
 	  float-imprecise-trap-bit float-invalid-trap-bit
 	  float-divide-by-zero-trap-bit))
@@ -121,12 +126,22 @@
 (defconstant double-float-hidden-bit (ash 1 20))
 (defconstant double-float-trapping-nan-bit (ash 1 19))
 
+(defconstant long-float-bias 16382)
+(defconstant long-float-exponent-byte (byte 15 0))
+(defconstant long-float-significand-byte (byte 31 0))
+(defconstant long-float-normal-exponent-min 1)
+(defconstant long-float-normal-exponent-max #x7FFE)
+(defconstant long-float-hidden-bit (ash 1 31))		; Actually not hidden
+(defconstant long-float-trapping-nan-bit (ash 1 30))
+
 (defconstant single-float-digits
   (+ (byte-size single-float-significand-byte) 1))
 
 (defconstant double-float-digits
   (+ (byte-size double-float-significand-byte) word-bits 1))
 
+(defconstant long-float-digits
+  (+ (byte-size long-float-significand-byte) word-bits 1))
 
 ;;; pfw -- from i486 microprocessor programmers reference manual
 (defconstant float-invalid-trap-bit        (ash 1 0))
@@ -258,6 +273,14 @@
       *fp-constant-1d0*
       *fp-constant-0s0*
       *fp-constant-1s0*
+      ;; Following are all long-floats.
+      *fp-constant-0l0*
+      *fp-constant-1l0*
+      *fp-constant-pi*
+      *fp-constant-l2t*
+      *fp-constant-l2e*
+      *fp-constant-lg2*
+      *fp-constant-ln2*
 
       ;; Used by gencgc.
       *scavenge-read-only-space*
@@ -296,4 +319,3 @@
 
 ;;; cf the sparc PARMS.LISP
 (defparameter *assembly-unit-length* 8)
-
diff --git a/compiler/x86/sap.lisp b/compiler/x86/sap.lisp
index 7b64352df20ae1cee09c20659ab9ec3e4c2d1b9e..5dfba7fe95628a38d7284f71af252907714cfe99 100644
--- a/compiler/x86/sap.lisp
+++ b/compiler/x86/sap.lisp
@@ -7,7 +7,7 @@
 ;;; 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.7 1998/02/19 10:52:16 dtc Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/sap.lisp,v 1.8 1998/03/21 07:54:40 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -16,7 +16,7 @@
 ;;; Written by William Lott.
 ;;;
 ;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
-;;; Enhancements/debugging by Douglas T. Crosher 1996,1997.
+;;; Enhancements/debugging by Douglas T. Crosher 1996,1997,1998.
 ;;;
 (in-package :x86)
 
@@ -467,6 +467,36 @@
      (with-empty-tn@fp-top(result)
         (inst fldl (make-ea :dword :base sap :disp offset)))))
 
+#+long-float
+(define-vop (%set-sap-ref-long)
+  (:translate %set-sap-ref-long)
+  (:policy :fast-safe)
+  (:args (sap :scs (sap-reg) :to (:eval 0))
+	 (offset :scs (signed-reg) :to (:eval 0))
+	 (value :scs (long-reg)))
+  (:arg-types system-area-pointer signed-num long-float)
+  (:results (result :scs (long-reg)))
+  (:result-types long-float)
+  (:generator 5
+    (cond ((zerop (tn-offset value))
+	   ;; Value is in ST0
+	   (store-long-float (make-ea :dword :base sap :index offset))
+	   (unless (zerop (tn-offset result))
+	     ;; Value is in ST0 but not result.
+	     (inst fstd result)))
+	  (t
+	   ;; Value is not in ST0.
+	   (inst fxch value)
+	   (store-long-float (make-ea :dword :base sap :index offset))
+	   (cond ((zerop (tn-offset result))
+		  ;; The result is in ST0.
+		  (inst fstd value))
+		 (t
+		  ;; Neither value or result are in ST0
+		  (unless (location= value result)
+		    (inst fstd result))
+		  (inst fxch value)))))))
+
 
 ;;; Noise to convert normal lisp data objects into SAPs.
 
diff --git a/compiler/x86/type-vops.lisp b/compiler/x86/type-vops.lisp
index 2458b653f8c4da89c2b2f1aeb3b178720554c6a2..62194f806648e23827a99b71dd56728517f9d757 100644
--- a/compiler/x86/type-vops.lisp
+++ b/compiler/x86/type-vops.lisp
@@ -7,7 +7,7 @@
 ;;; 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.10 1998/02/19 19:35:08 dtc Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/type-vops.lisp,v 1.11 1998/03/21 07:54:40 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;; 
@@ -355,7 +355,8 @@
 (def-type-vops complexp check-complex complex object-not-complex-error
   complex-type
   #+complex-float complex-single-float-type
-  #+complex-float complex-double-float-type)
+  #+complex-float complex-double-float-type
+  #+(and complex-float long-float) complex-long-float-type)
 
 #+complex-float
 (def-type-vops complex-rational-p check-complex-rational nil
@@ -364,7 +365,8 @@
 #+complex-float
 (def-type-vops complex-float-p check-complex-float nil
   object-not-complex-float-error
-  complex-single-float-type complex-double-float-type)
+  complex-single-float-type complex-double-float-type
+  #+long-float complex-long-float-type)
 
 #+complex-float
 (def-type-vops complex-single-float-p check-complex-single-float
@@ -376,12 +378,21 @@
   complex-double-float object-not-complex-double-float-error
   complex-double-float-type)
 
+#+(and complex-float long-float)
+(def-type-vops complex-long-float-p check-complex-long-float
+  complex-long-float object-not-complex-long-float-error
+  complex-long-float-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)
 
+#+long-float
+(def-type-vops long-float-p check-long-float long-float
+  object-not-long-float-error long-float-type)
+
 (def-type-vops simple-string-p check-simple-string simple-string
   object-not-simple-string-error simple-string-type)
 
@@ -457,6 +468,11 @@
   simple-array-double-float object-not-simple-array-double-float-error
   simple-array-double-float-type)
 
+#+long-float
+(def-type-vops simple-array-long-float-p check-simple-array-long-float
+  simple-array-long-float object-not-simple-array-long-float-error
+  simple-array-long-float-type)
+
 #+complex-float
 (def-type-vops simple-array-complex-single-float-p
   check-simple-array-complex-single-float
@@ -471,6 +487,13 @@
   object-not-simple-array-complex-double-float-error
   simple-array-complex-double-float-type)
 
+#+(and complex-float long-float)
+(def-type-vops simple-array-complex-long-float-p
+  check-simple-array-complex-long-float
+  simple-array-complex-long-float
+  object-not-simple-array-complex-long-float-error
+  simple-array-complex-long-float-type)
+
 (def-type-vops base-char-p check-base-char base-char
   object-not-base-char-error base-char-type)
 
@@ -519,8 +542,10 @@
   #+signed-array simple-array-signed-byte-30-type
   #+signed-array simple-array-signed-byte-32-type
   simple-array-single-float-type simple-array-double-float-type
+  #+long-float simple-array-long-float-type
   #+complex-float simple-array-complex-single-float-type
   #+complex-float simple-array-complex-double-float-type
+  #+(and complex-float long-float) simple-array-complex-long-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
@@ -533,8 +558,10 @@
   #+signed-array simple-array-signed-byte-30-type
   #+signed-array simple-array-signed-byte-32-type
   simple-array-single-float-type simple-array-double-float-type
+  #+long-float simple-array-long-float-type
   #+complex-float simple-array-complex-single-float-type
-  #+complex-float simple-array-complex-double-float-type)
+  #+complex-float simple-array-complex-double-float-type
+  #+(and complex-float long-float) simple-array-complex-long-float-type)
 
 (def-type-vops arrayp check-array nil object-not-array-error
   simple-array-type simple-string-type simple-bit-vector-type
@@ -546,16 +573,19 @@
   #+signed-array simple-array-signed-byte-30-type
   #+signed-array simple-array-signed-byte-32-type
   simple-array-single-float-type simple-array-double-float-type
+  #+long-float simple-array-long-float-type
   #+complex-float simple-array-complex-single-float-type
   #+complex-float simple-array-complex-double-float-type
+  #+(and complex-float long-float) simple-array-complex-long-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
+  single-float-type double-float-type #+long-float long-float-type complex-type
   #+complex-float complex-single-float-type
-  #+complex-float complex-double-float-type)
+  #+complex-float complex-double-float-type
+  #+(and complex-float long-float) complex-long-float-type)
 
 (def-type-vops rationalp check-rational nil object-not-rational-error
   even-fixnum-type odd-fixnum-type ratio-type bignum-type)
@@ -564,11 +594,11 @@
   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)
+  single-float-type double-float-type #+long-float long-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)
+  single-float-type double-float-type #+long-float long-float-type)
 
 
 ;;;; Other integer ranges.
diff --git a/compiler/x86/vm.lisp b/compiler/x86/vm.lisp
index bc0db76f69e7a7f378a76c27e1d61c9168978062..05a1cc98cb62391c7904668c13f101a7eb94672b 100644
--- a/compiler/x86/vm.lisp
+++ b/compiler/x86/vm.lisp
@@ -7,7 +7,7 @@
 ;;; 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.8 1998/02/21 18:24:45 dtc Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/vm.lisp,v 1.9 1998/03/21 07:54:41 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -174,10 +174,14 @@
   (sap-stack stack)			; System area pointers.
   (single-stack stack)			; single-floats
   (double-stack stack :element-size 2)	; double-floats.
+  #+long-float
+  (long-stack stack :element-size 3)	; long-floats.
   #+complex-float
   (complex-single-stack stack :element-size 2)	; complex-single-floats
   #+complex-float
   (complex-double-stack stack :element-size 4)	; complex-double-floats
+  #+(and complex-float long-float)
+  (complex-long-stack stack :element-size 6)	; complex-long-floats
 
   ;; **** Magic SCs.
 
@@ -270,6 +274,14 @@
 	      :save-p t
 	      :alternate-scs (double-stack))
 
+  ;; Non-Descriptor long-floats.
+  #+long-float
+  (long-reg float-registers
+	    :locations (0 1 2 3 4 5 6 7)
+	    :constant-scs (fp-constant)
+	    :save-p t
+	    :alternate-scs (long-stack))
+
   #+complex-float
   (complex-single-reg float-registers
 		      :locations (0 2 4 6)
@@ -286,6 +298,14 @@
 		      :save-p t
 		      :alternate-scs (complex-double-stack))
 
+  #+(and complex-float long-float)
+  (complex-long-reg float-registers
+		    :locations (0 2 4 6)
+		    :element-size 2
+		    :constant-scs ()
+		    :save-p t
+		    :alternate-scs (complex-long-stack))
+
   ;; A catch or unwind block.
   (catch-block stack :element-size vm:catch-block-size)
   )
@@ -356,6 +376,15 @@
        (sc-number-or-lose 'fp-constant *backend*)))
     (double-float
      (when (or (eql value 0d0) (eql value 1d0))
+       (sc-number-or-lose 'fp-constant *backend*)))
+    #+long-float
+    (long-float
+     (when (or (eql value 0l0) (eql value 1l0)
+	       (eql value pi)
+	       (eql value (log 10l0 2l0))
+	       (eql value (log 2.718281828459045235360287471352662L0 2l0))
+	       (eql value (log 2l0 10l0))
+	       (eql value (log 2l0 2.718281828459045235360287471352662L0)))
        (sc-number-or-lose 'fp-constant *backend*)))))