diff --git a/code/alieneval.lisp b/code/alieneval.lisp
index 61f1744b9506b0fe5d0901b7645d074b0caf737d..e1e6a31b34f7987808185767e7f1bf07f1ed63e4 100644
--- a/code/alieneval.lisp
+++ b/code/alieneval.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/alieneval.lisp,v 1.45 1998/02/20 07:44:10 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/alieneval.lisp,v 1.46 1998/03/21 08:11:47 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -17,8 +17,8 @@
 (use-package "SYSTEM")
 
 (export '(alien * array struct union enum function integer signed unsigned
-	  boolean values single-float double-float system-area-pointer
-	  def-alien-type def-alien-variable sap-alien
+	  boolean values single-float double-float long-float
+	  system-area-pointer def-alien-type def-alien-variable sap-alien
 	  extern-alien with-alien slot deref addr cast alien-sap alien-size
 	  alien-funcall def-alien-routine make-alien free-alien
 	  null-alien))
@@ -39,6 +39,7 @@
 	  alien-float-type alien-float-type-p
 	  alien-single-float-type alien-single-float-type-p
 	  alien-double-float-type alien-double-float-type-p
+	  alien-long-float-type alien-long-float-type-p
 	  alien-pointer-type alien-pointer-type-p alien-pointer-type-to
 	  make-alien-pointer-type
 	  alien-array-type alien-array-type-p alien-array-type-element-type
@@ -84,6 +85,7 @@
 	  alien-float-type alien-float-type-p
 	  alien-single-float-type alien-single-float-type-p
 	  alien-double-float-type alien-double-float-type-p
+	  alien-long-float-type alien-long-float-type-p
 	  alien-pointer-type alien-pointer-type-p alien-pointer-type-to
 	  make-alien-pointer-type
 	  alien-array-type alien-array-type-p alien-array-type-element-type
@@ -847,6 +849,19 @@
   `(sap-ref-double ,sap (/ ,offset vm:byte-bits)))
 
 
+#+long-float
+(def-alien-type-class (long-float :include (float (:bits 96))
+				  :include-args (type)))
+
+#+long-float
+(def-alien-type-translator long-float ()
+  (make-alien-long-float-type :type 'long-float))
+
+#+long-float
+(def-alien-type-method (long-float :extract-gen) (type sap offset)
+  (declare (ignore type))
+  `(sap-ref-long ,sap (/ ,offset vm:byte-bits)))
+
 
 ;;;; The SAP type
 
diff --git a/code/array.lisp b/code/array.lisp
index 9ce55e7761b2f462f7d71d4b42376e89b75bb803..2c2743f71c7f2046a0e6a59290d8717bee5253e5 100644
--- a/code/array.lisp
+++ b/code/array.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/array.lisp,v 1.25 1997/12/18 07:18:16 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/array.lisp,v 1.26 1998/03/21 08:11:48 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -138,12 +138,18 @@
 		    (values #.vm:simple-array-signed-byte-32-type 32))
     (single-float (values #.vm:simple-array-single-float-type 32))
     (double-float (values #.vm:simple-array-double-float-type 64))
+    #+long-float
+    (long-float
+     (values #.vm:simple-array-long-float-type #+x86 96 #+sparc 128))
     #+complex-float
     ((complex single-float)
      (values #.vm:simple-array-complex-single-float-type 64))
     #+complex-float
     ((complex double-float)
      (values #.vm:simple-array-complex-double-float-type 128))
+    #+(and complex-float long-float)
+    ((complex long-float)
+     (values #.vm:simple-array-complex-long-float-type #+x86 192 #+sparc 256))
     (t (values #.vm:simple-vector-type #.vm:word-bits))))
 
 (defun %complex-vector-type-code (type)
@@ -171,8 +177,7 @@
 	(multiple-value-bind (type bits)
 			     (%vector-type-code element-type)
 	  (declare (type (unsigned-byte 8) type)
-		   (type (integer 1 #-complex-float 64
-				    #+complex-float 128) bits))
+		   (type (integer 1 256) bits))
 	  (let* ((length (car dimensions))
 		 (array (allocate-vector
 			 type
@@ -337,8 +342,10 @@
        #+signed-array (signed-byte 32)
        single-float
        double-float
+       #+long-float long-float
        #+complex-float (complex single-float)
-       #+complex-float (complex double-float)))))
+       #+complex-float (complex double-float)
+       #+(and complex-float long-float) (complex long-float)))))
 
 (defun data-vector-set (array index new-value)
   (with-array-data ((vector array) (index index) (end))
@@ -367,8 +374,10 @@
        #+signed-array (signed-byte 32)
        single-float
        double-float
+       #+long-float long-float
        #+complex-float (complex single-float)
-       #+complex-float (complex double-float)))))
+       #+complex-float (complex double-float)
+       #+(and complex-float long-float) (complex long-float)))))
 
 
 
@@ -527,10 +536,14 @@
        #+signed-array (vm:simple-array-signed-byte-32-type '(signed-byte 32))
        (vm:simple-array-single-float-type 'single-float)
        (vm:simple-array-double-float-type 'double-float)
+       #+long-float
+       (vm:simple-array-long-float-type 'long-float)
        #+complex-float
        (vm:simple-array-complex-single-float-type '(complex single-float))
        #+complex-float
        (vm:simple-array-complex-double-float-type '(complex double-float))
+       #+(and complex-float long-float)
+       (vm:simple-array-complex-long-float-type '(complex long-float))
        ((vm:simple-array-type vm:complex-vector-type vm:complex-array-type)
 	(with-array-data ((array array) (start) (end))
 	  (declare (ignore start end))
@@ -823,12 +836,17 @@
 	#+signed-array ((simple-array (signed-byte 32) (*)) 0)
 	((simple-array single-float (*)) (coerce 0 'single-float))
 	((simple-array double-float (*)) (coerce 0 'double-float))
+	#+long-float
+	((simple-array long-float (*)) (coerce 0 'long-float))
 	#+complex-float
 	((simple-array (complex single-float) (*))
 	 (coerce 0 '(complex single-float)))
 	#+complex-float
 	((simple-array (complex double-float) (*))
-	 (coerce 0 '(complex double-float))))))
+	 (coerce 0 '(complex double-float)))
+	#+(and complex-float long-float)
+	((simple-array (complex long-float) (*))
+	 (coerce 0 '(complex long-float))))))
   ;; Only arrays have fill-pointers, but vectors have their length parameter
   ;; in the same place.
   (setf (%array-fill-pointer vector) new-size)
diff --git a/code/bignum.lisp b/code/bignum.lisp
index bed54694efd2343504e1e6ab31678e111df49ac5..c3ae58286983ef4c0a0e1fbbdc4db64dfc6b94b5 100644
--- a/code/bignum.lisp
+++ b/code/bignum.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/bignum.lisp,v 1.24 1998/03/01 21:45:56 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/bignum.lisp,v 1.25 1998/03/21 08:11:49 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1049,6 +1049,17 @@
 	 hi
 	 (logior hi (ash -1 vm:float-sign-shift)))
      (%bignum-ref bits 1))))
+;;;
+#+(and long-float x86)
+(defun long-float-from-bits (bits exp plusp)
+  (declare (fixnum exp))
+  (declare (optimize (ext:inhibit-warnings 3)))
+  (make-long-float
+   (if plusp
+       exp
+       (logior exp (ash 1 15)))
+   (%bignum-ref bits 2)
+   (%bignum-ref bits 1)))
 
 
 ;;; BIGNUM-TO-FLOAT   --  Interface
@@ -1089,6 +1100,13 @@
 		   bits
 		   (check-exponent len vm:double-float-bias
 		                   vm:double-float-normal-exponent-max)
+		   plusp))
+		 #+long-float
+		 (long-float
+		  (long-float-from-bits
+		   bits
+		   (check-exponent len vm:long-float-bias
+		                   vm:long-float-normal-exponent-max)
 		   plusp))))
 	     (check-exponent (exp bias max)
 	       (declare (type bignum-index len))
diff --git a/code/class.lisp b/code/class.lisp
index d78b33ac428089c89ab8a82a890770e537ee7f01..9b2223c3728764e9df1500589d9bf458298f7d05 100644
--- a/code/class.lisp
+++ b/code/class.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/class.lisp,v 1.38 1997/11/04 15:05:36 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/class.lisp,v 1.39 1998/03/21 08:11:50 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -651,6 +651,14 @@
 	   :inherits (vector simple-array array sequence generic-vector
 		      generic-array mutable-sequence mutable-collection
 		      generic-sequence collection))
+	  #+long-float
+	  (simple-array-long-float
+	   :translation (simple-array long-float (*))
+	   :codes (#.vm:simple-array-long-float-type)
+	   :direct-superclasses (vector simple-array)
+	   :inherits (vector simple-array array sequence generic-vector
+		      generic-array mutable-sequence mutable-collection
+		      generic-sequence collection))
 	  #+complex-float
 	  (simple-array-complex-single-float
 	   :translation (simple-array (complex single-float) (*))
@@ -667,6 +675,14 @@
 	   :inherits (vector simple-array array sequence generic-vector
 		      generic-array mutable-sequence mutable-collection
 		      generic-sequence collection))
+	  #+(and complex-float long-float)
+	  (simple-array-complex-long-float
+	   :translation (simple-array (complex long-float) (*))
+	   :codes (#.vm:simple-array-complex-long-float-type)
+	   :direct-superclasses (vector simple-array)
+	   :inherits (vector simple-array array sequence generic-vector
+		      generic-array mutable-sequence mutable-collection
+		      generic-sequence collection))
 	  (generic-string
 	   :state :read-only
 	   :inherits (mutable-sequence mutable-collection generic-sequence
@@ -698,6 +714,11 @@
 	   :translation (complex double-float)
 	   :inherits (complex number generic-number)
 	   :codes (#.vm:complex-double-float-type))
+	  #+(and complex-float long-float)
+	  (complex-long-float
+	   :translation (complex long-float)
+	   :inherits (complex number generic-number)
+	   :codes (#.vm:complex-long-float-type))
 	  (real :translation real :inherits (number generic-number))
 	  (float :translation float :inherits (real number generic-number))
 	  (single-float
@@ -708,6 +729,11 @@
 	   :translation double-float
 	   :inherits (float real number generic-number)
 	   :codes (#.vm:double-float-type))
+	  #+long-float
+	  (long-float
+	   :translation long-float
+	   :inherits (float real number generic-number)
+	   :codes (#.vm:long-float-type))
 	  (rational
 	   :translation rational
 	   :inherits (real number generic-number))
diff --git a/code/debug-int.lisp b/code/debug-int.lisp
index d88f4c7dbd573a89c9c51922bafa2b11d5968a32..b915ad898da4a7145eea61498950728a2026e6fb 100644
--- a/code/debug-int.lisp
+++ b/code/debug-int.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.88 1998/02/14 21:09:48 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.89 1998/03/21 08:11:51 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -3141,18 +3141,28 @@
        (escaped-float-value single-float))
       (#.vm:double-reg-sc-number
        (escaped-float-value double-float))
+      #+long-float
+      (#.vm:long-reg-sc-number
+       (escaped-float-value long-float))
       #+complex-float
       (#.vm:complex-single-reg-sc-number
        (escaped-complex-float-value single-float))
       #+complex-float
       (#.vm:complex-double-reg-sc-number
        (escaped-complex-float-value double-float))
+      #+(and complex-float long-float)
+      (#.vm:complex-long-reg-sc-number
+       (escaped-complex-float-value long-float))
       (#.vm:single-stack-sc-number
        (system:sap-ref-single fp (- (* (1+ (c:sc-offset-offset sc-offset))
 				       vm:word-bytes))))
       (#.vm:double-stack-sc-number
        (system:sap-ref-double fp (- (* (+ (c:sc-offset-offset sc-offset) 2)
 				       vm:word-bytes))))
+      #+long-float
+      (#.vm:long-stack-sc-number
+       (system:sap-ref-long fp (- (* (+ (c:sc-offset-offset sc-offset) 3)
+				     vm:word-bytes))))
       #+complex-float
       (#.vm:complex-single-stack-sc-number
        (complex
@@ -3167,6 +3177,13 @@
 					vm:word-bytes)))
 	(system:sap-ref-double fp (- (* (+ (c:sc-offset-offset sc-offset) 4)
 					vm:word-bytes)))))
+      #+(and complex-float long-float)
+      (#.vm:complex-long-stack-sc-number
+       (complex
+	(system:sap-ref-long fp (- (* (+ (c:sc-offset-offset sc-offset) 3)
+				      vm:word-bytes)))
+	(system:sap-ref-long fp (- (* (+ (c:sc-offset-offset sc-offset) 6)
+				      vm:word-bytes)))))
       (#.vm:control-stack-sc-number
        (kernel:stack-ref fp (c:sc-offset-offset sc-offset)))
       (#.vm:base-char-stack-sc-number
diff --git a/code/defstruct.lisp b/code/defstruct.lisp
index 3ee24b5caab443652cad3544ef9f672aa118d2f2..64bab9c885e0468d557302f303ab87912c3c1f59 100644
--- a/code/defstruct.lisp
+++ b/code/defstruct.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.60 1998/03/03 17:35:19 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.61 1998/03/21 08:11:53 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -61,6 +61,11 @@
   (declare (type index index))
   (%raw-ref-double vec index))
 
+#+long-float
+(defun %raw-ref-long (vec index)
+  (declare (type index index))
+  (%raw-ref-long vec index))
+
 (defun %raw-set-single (vec index val)
   (declare (type index index))
   (%raw-set-single vec index val))
@@ -69,6 +74,11 @@
   (declare (type index index))
   (%raw-set-double vec index val))
 
+#+long-float
+(defun %raw-set-long (vec index val)
+  (declare (type index index))
+  (%raw-set-long vec index val))
+
 #+complex-float
 (progn
 
@@ -80,6 +90,11 @@
   (declare (type index index))
   (%raw-ref-complex-double vec index))
 
+#+long-float
+(defun %raw-ref-complex-long (vec index)
+  (declare (type index index))
+  (%raw-ref-complex-long vec index))
+
 (defun %raw-set-complex-single (vec index val)
   (declare (type index index))
   (%raw-set-complex-single vec index val))
@@ -88,6 +103,11 @@
   (declare (type index index))
   (%raw-set-complex-double vec index val))
 
+#+long-float
+(defun %raw-set-complex-long (vec index val)
+  (declare (type index index))
+  (%raw-set-complex-long vec index val))
+
 ) ; end progn complex-float
 
 (defun %instance-layout (instance)
@@ -145,10 +165,14 @@
 (defsetf %instance-ref %instance-set)
 (defsetf %raw-ref-single %raw-set-single)
 (defsetf %raw-ref-double %raw-set-double)
+#+long-float
+(defsetf %raw-ref-long %raw-set-long)
 #+complex-float
 (defsetf %raw-ref-complex-single %raw-set-complex-single)
 #+complex-float
 (defsetf %raw-ref-complex-double %raw-set-complex-double)
+#+(and complex-float long-float)
+(defsetf %raw-ref-complex-long %raw-set-complex-long)
 (defsetf %instance-layout %set-instance-layout)
 (defsetf %funcallable-instance-info %set-funcallable-instance-info)
 
@@ -262,9 +286,10 @@
   (type t)			; declared type specifier
   ;;
   ;; If a raw slot, what it holds.  T means not raw.
-  (raw-type t :type (member t single-float double-float
+  (raw-type t :type (member t single-float double-float #+long-float long-float
 			    #+complex-float complex-single-float
 			    #+complex-float complex-double-float
+			    #+(and complex-float long-float) complex-long-float
 			    unsigned-byte))
   (read-only nil :type (member t nil)))
 
@@ -592,12 +617,18 @@
 	       (values 'single-float 1))
 	      ((subtypep type 'double-float)
 	       (values 'double-float 2))
+	      #+long-float
+	      ((subtypep type 'long-float)
+	       (values 'long-float #+x86 3 #+sparc 4))
 	      #+complex-float
 	      ((subtypep type '(complex single-float))
 	       (values 'complex-single-float 2))
 	      #+complex-float
 	      ((subtypep type '(complex double-float))
 	       (values 'complex-double-float 4))
+	      #+(and long-float complex-float)
+	      ((subtypep type '(complex long-float))
+	       (values 'complex-long-float #+x86 6 #+sparc 8))
 	      (t (values nil nil)))
 
       (cond ((not raw-type)
@@ -962,16 +993,26 @@
      (ecase rtype
        (single-float '%raw-ref-single)
        (double-float '%raw-ref-double)
+       #+long-float
+       (long-float '%raw-ref-long)
        #+complex-float
        (complex-single-float '%raw-ref-complex-single)
        #+complex-float
        (complex-double-float '%raw-ref-complex-double)
+       #+(and complex-float long-float)
+       (complex-long-float '%raw-ref-complex-long)
        (unsigned-byte 'aref)
        ((t)
 	(if (eq (dd-type defstruct) 'funcallable-structure)
 	    '%funcallable-instance-info
 	    '%instance-ref)))
      (case rtype
+       #+(and complex-float long-float)
+       (complex-long-float
+	(truncate (dsd-index slot) #+x86 6 #+sparc 8))
+       #+long-float
+       (long-float
+	(truncate (dsd-index slot) #+x86 3 #+sparc 4))
        (double-float
 	(ash (dsd-index slot) -1))
        #+complex-float
diff --git a/code/exports.lisp b/code/exports.lisp
index f0d74a0c7c196276b82cac6d85d52cdcfd2557d2..1184336f923fb1142f19eb00cd67c300bbe46e1c 100644
--- a/code/exports.lisp
+++ b/code/exports.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.146 1998/03/10 18:26:05 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.147 1998/03/21 08:11:54 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -624,7 +624,7 @@
              "DYNAMIC-0-SPACE-START" "DYNAMIC-1-SPACE-START" "FIXNUM"
              "READ-ONLY-SPACE-START" "SHORT-FLOAT-P" "STATIC-SPACE-START"
 	     "STRING/=*" "STRING<*" "STRING<=*" "STRING=*"
-	     "STRING>*" "STRING>=*")
+             "STRING>*" "STRING>=*")
   (:export "*ASSEMBLY-UNIT-LENGTH*" "*PRIMITIVE-OBJECTS*"
 	   "AFTER-BREAKPOINT-TRAP"
 	   "ANY-REG-SC-NUMBER" "ARRAY-DATA-SLOT" "ARRAY-DIMENSIONS-OFFSET"
@@ -651,6 +651,9 @@
 	   "COMPLEX-DOUBLE-FLOAT-SIZE" "COMPLEX-DOUBLE-FLOAT-TYPE"
 	   "COMPLEX-DOUBLE-REG-SC-NUMBER" "COMPLEX-DOUBLE-STACK-SC-NUMBER" 
 	   "COMPLEX-IMAG-SLOT" "COMPLEX-REAL-SLOT"
+	   "COMPLEX-LONG-FLOAT-IMAG-SLOT" "COMPLEX-LONG-FLOAT-REAL-SLOT"
+	   "COMPLEX-LONG-FLOAT-SIZE" "COMPLEX-LONG-FLOAT-TYPE"
+	   "COMPLEX-LONG-REG-SC-NUMBER" "COMPLEX-LONG-STACK-SC-NUMBER" 
 	   "COMPLEX-SINGLE-FLOAT-IMAG-SLOT" "COMPLEX-SINGLE-FLOAT-REAL-SLOT"
 	   "COMPLEX-SINGLE-FLOAT-SIZE" "COMPLEX-SINGLE-FLOAT-TYPE"
 	   "COMPLEX-SINGLE-REG-SC-NUMBER" "COMPLEX-SINGLE-STACK-SC-NUMBER"
@@ -660,7 +663,7 @@
 	   "CONTROL-STACK-RETURN" "CONTROL-STACK-SC-NUMBER" "COUNT-NO-OPS"
 	   "CURRENT-FLOAT-TRAP" "DEFINE-FOR-EACH-PRIMITIVE-OBJECT"
 	   "DESCRIPTOR-REG-SC-NUMBER" "DESCRIPTOR-VS-NON-DESCRIPTOR-STORAGE"
-	   "DOUBLE-FLAOT-EXPONENT-BYTE" "DOUBLE-FLOAT-BIAS"
+	   "DOUBLE-FLOAT-EXPONENT-BYTE" "DOUBLE-FLOAT-BIAS"
 	   "DOUBLE-FLOAT-DIGITS" "DOUBLE-FLOAT-EXPONENT-BYTE"
 	   "DOUBLE-FLOAT-FILLER-SLOT" "DOUBLE-FLOAT-HIDDEN-BIT"
 	   "DOUBLE-FLOAT-NORMAL-EXPONENT-MAX"
@@ -700,6 +703,11 @@
 	   "INSTANCE-SLOTS-OFFSET" "INSTANCE-USAGE"
 	   "INTERIOR-REG-SC-NUMBER" "INTERNAL-ERROR-ARGUMENTS"
 	   "INTERRUPTED-FLAG" "LIST-ALLOCATED-OBJECTS" "LIST-POINTER-TYPE"
+	   "LONG-FLOAT-BIAS" "LONG-FLOAT-DIGITS" "LONG-FLOAT-EXPONENT-BYTE"
+	   "LONG-FLOAT-HIDDEN-BIT" "LONG-FLOAT-NORMAL-EXPONENT-MAX"
+	   "LONG-FLOAT-NORMAL-EXPONENT-MIN" "LONG-FLOAT-SIGNIFICAND-BYTE"
+	   "LONG-FLOAT-SIZE" "LONG-FLOAT-TRAPPING-NAN-BIT" "LONG-FLOAT-TYPE"
+	   "LONG-FLOAT-VALUE-SLOT" "LONG-REG-SC-NUMBER" "LONG-STACK-SC-NUMBER"
 	   "LOWTAG-BITS" "LOWTAG-LIMIT" "LOWTAG-MASK"
 	   "MEMORY-USAGE" "MOST-POSITIVE-COST"
 	   "NEGATIVE-IMMEDIATE-SC-NUMBER" "NON-DESCRIPTOR-REG-SC-NUMBER"
@@ -725,8 +733,11 @@
 	   "SIGCONTEXT-PROGRAM-COUNTER" "SIGCONTEXT-REGISTER"
 	   "SIGFPE-HANDLER" "SIGNED-REG-SC-NUMBER" "SIGNED-STACK-SC-NUMBER"
 	   "SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE"
+	   "SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE"
 	   "SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE"
-	   "SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE" "SIMPLE-ARRAY-SINGLE-FLOAT-TYPE"
+	   "SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE"
+	   "SIMPLE-ARRAY-LONG-FLOAT-TYPE"
+	   "SIMPLE-ARRAY-SINGLE-FLOAT-TYPE"
 	   "SIMPLE-ARRAY-TYPE" "SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE"
 	   "SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE"
 	   "SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE"
@@ -1258,18 +1269,18 @@
 	     "ALTERNATE-GET-GLOBAL-ADDRESS"))
 (dolist
     (name
-     '("*" "ARRAY" "DOUBLE-FLOAT" "FUNCTION" "INTEGER" "SINGLE-FLOAT" "UNION"
-       "VALUES"))
+     '("*" "ARRAY" "DOUBLE-FLOAT" "FUNCTION" "INTEGER" "LONG-FLOAT"
+       "SINGLE-FLOAT" "UNION" "VALUES"))
   (intern name "LISP"))
 (defpackage "ALIEN"
             (:import-from "LISP" "*" "ARRAY" "DOUBLE-FLOAT" "FUNCTION"
-             "INTEGER" "SINGLE-FLOAT" "UNION" "VALUES")
+             "INTEGER" "LONG-FLOAT" "SINGLE-FLOAT" "UNION" "VALUES")
             (:export "*" "ADDR" "ALIEN" "ALIEN-FUNCALL" "ALIEN-SAP"
              "ALIEN-SIZE" "ARRAY" "BOOLEAN" "CAST" "DEF-ALIEN-ROUTINE"
              "DEF-ALIEN-TYPE" "DEF-ALIEN-VARIABLE" "DEF-BUILTIN-ALIEN-TYPE"
              "DEREF" "DOUBLE-FLOAT" "ENUM" "EXTERN-ALIEN" "FUNCTION" "INTEGER"
-             "SAP-ALIEN" "SIGNED" "SINGLE-FLOAT" "SLOT" "STRUCT" "UNION"
-             "UNSIGNED" "VALUES" "WITH-ALIEN" "FREE-ALIEN" "NULL-ALIEN"
+             "LONG-FLOAT" "SAP-ALIEN" "SIGNED" "SINGLE-FLOAT" "SLOT" "STRUCT"
+	     "UNION" "UNSIGNED" "VALUES" "WITH-ALIEN" "FREE-ALIEN" "NULL-ALIEN"
 	     "MAKE-ALIEN" "LOAD-FOREIGN" "SYSTEM-AREA-POINTER"))
 
 (dolist
@@ -1286,6 +1297,7 @@
        "ALIEN-FUNCTION-TYPE-ARG-TYPES" "ALIEN-FUNCTION-TYPE-P"
        "ALIEN-FUNCTION-TYPE-RESULT-TYPE" "ALIEN-INTEGER-TYPE"
        "ALIEN-INTEGER-TYPE-P" "ALIEN-INTEGER-TYPE-SIGNED"
+       "ALIEN-LONG-FLOAT-TYPE" "ALIEN-LONG-FLOAT-TYPE-P"
        "ALIEN-POINTER-TYPE" "ALIEN-POINTER-TYPE-P" "ALIEN-POINTER-TYPE-TO"
        "ALIEN-RECORD-FIELD" "ALIEN-RECORD-FIELD-NAME"
        "ALIEN-RECORD-FIELD-OFFSET" "ALIEN-RECORD-FIELD-P"
@@ -1323,6 +1335,7 @@
              "ALIEN-FUNCTION-TYPE-ARG-TYPES" "ALIEN-FUNCTION-TYPE-P"
              "ALIEN-FUNCTION-TYPE-RESULT-TYPE" "ALIEN-INTEGER-TYPE"
              "ALIEN-INTEGER-TYPE-P" "ALIEN-INTEGER-TYPE-SIGNED"
+             "ALIEN-LONG-FLOAT-TYPE" "ALIEN-LONG-FLOAT-TYPE-P"
              "ALIEN-POINTER-TYPE" "ALIEN-POINTER-TYPE-P"
              "ALIEN-POINTER-TYPE-TO" "ALIEN-RECORD-FIELD"
              "ALIEN-RECORD-FIELD-NAME" "ALIEN-RECORD-FIELD-OFFSET"
@@ -1358,6 +1371,7 @@
              "ALIEN-FUNCTION-TYPE-ARG-TYPES" "ALIEN-FUNCTION-TYPE-P"
              "ALIEN-FUNCTION-TYPE-RESULT-TYPE" "ALIEN-INTEGER-TYPE"
              "ALIEN-INTEGER-TYPE-P" "ALIEN-INTEGER-TYPE-SIGNED"
+             "ALIEN-LONG-FLOAT-TYPE" "ALIEN-LONG-FLOAT-TYPE-P"
              "ALIEN-POINTER-TYPE" "ALIEN-POINTER-TYPE-P"
              "ALIEN-POINTER-TYPE-TO" "ALIEN-RECORD-FIELD"
              "ALIEN-RECORD-FIELD-NAME" "ALIEN-RECORD-FIELD-OFFSET"
@@ -1403,16 +1417,18 @@
 	   "%CLOSURE-INDEX-REF" "%COS" "%COS-QUICK" "%COSH" "%DEPOSIT-FIELD"
 	   "%DOUBLE-FLOAT" "%DPB" "%EXP" "%FUNCTION-HEADER-ARGLIST"
 	   "%FUNCTION-HEADER-NAME" "%FUNCTION-HEADER-TYPE" "%HYPOT" "%LDB"
-	   "%LOG" "%LOGB" "%LOG10" "%LOG1P" "%MAKE-COMPLEX"
-	   "%MAKE-FUNCALLABLE-INSTANCE" "%MAKE-RATIO"
+	   "%LOG" "%LOGB" "%LOG10" "%LOG1P" "%LONG-FLOAT"
+	   "%MAKE-COMPLEX" "%MAKE-FUNCALLABLE-INSTANCE" "%MAKE-RATIO"
 	   "%MASK-FIELD" "%NEGATE" "%POW"
-	   "%RAW-BITS" "%RAW-REF-COMPLEX-DOUBLE" "%RAW-REF-COMPLEX-SINGLE"
-	   "%RAW-REF-DOUBLE" "%RAW-REF-SINGLE" "%RAW-SET-COMPLEX-DOUBLE"
-	   "%RAW-SET-COMPLEX-SINGLE" "%RAW-SET-DOUBLE" "%RAW-SET-SINGLE"
+	   "%RAW-BITS" "%RAW-REF-COMPLEX-DOUBLE" "%RAW-REF-COMPLEX-LONG"
+	   "%RAW-REF-COMPLEX-SINGLE" "%RAW-REF-DOUBLE" "%RAW-REF-LONG"
+	   "%RAW-REF-SINGLE" "%RAW-SET-COMPLEX-DOUBLE"
+	   "%RAW-SET-COMPLEX-LONG" "%RAW-SET-COMPLEX-SINGLE"
+	   "%RAW-SET-DOUBLE" "%RAW-SET-LONG" "%RAW-SET-SINGLE"
 	   "%SCALB" "%SCALBN" "%SET-FUNCALLABLE-INSTANCE-FUNCTION"
 	   "%SET-FUNCALLABLE-INSTANCE-INFO" "%SET-RAW-BITS"
 	   "%SET-SAP-REF-16" "%SET-SAP-REF-32" "%SET-SAP-REF-64"
-	   "%SET-SAP-REF-8" "%SET-SAP-REF-DOUBLE"
+	   "%SET-SAP-REF-8" "%SET-SAP-REF-DOUBLE" "%SET-SAP-REF-LONG"
 	   "%SET-SAP-REF-SAP" "%SET-SAP-REF-SINGLE"
 	   "%SET-SIGNED-SAP-REF-16" "%SET-SIGNED-SAP-REF-32"
 	   "%SET-SIGNED-SAP-REF-64" "%SET-SIGNED-SAP-REF-8" 
@@ -1443,15 +1459,16 @@
 	   "BOOLEAN" "BYTE-SPECIFIER" "CALLABLE" "CHAR-INT"
 	   "CHECK-FOR-CIRCULARITY" "CODE-COMPONENT" "CODE-COMPONENT-P"
 	   "CODE-DEBUG-INFO" "CODE-HEADER-REF" "CODE-HEADER-SET"
-	   "CODE-INSTRUCTIONS" "COMPLEX-FLOAT-P" "COMPLEX-SINGLE-FLOAT-P"
-	   "COMPLEX-DOUBLE-FLOAT-P" "COMPLEX-RATIONAL-P"
+	   "CODE-INSTRUCTIONS" "COMPLEX-DOUBLE-FLOAT-P" "COMPLEX-FLOAT-P"
+	   "COMPLEX-LONG-FLOAT-P" "COMPLEX-RATIONAL-P" "COMPLEX-SINGLE-FLOAT-P"
 	   "CONSED-SEQUENCE" "CONSTANT-TYPE"
 	   "CONSTANT-TYPE-P" "CONSTANT-TYPE-TYPE" "CONTAINING-INTEGER-TYPE"
 	   "CONTROL-STACK-POINTER-SAP" "COPY-FROM-SYSTEM-AREA"
 	   "COPY-NUMERIC-TYPE" "COPY-TO-SYSTEM-AREA" "CSUBTYPEP" "CTYPE"
 	   "CTYPE-OF" "CTYPE-P" "CTYPEP" "CURRENT-FP" "CURRENT-SP"
 	   "DATA-VECTOR-REF" "DATA-VECTOR-SET" "DECODE-DOUBLE-FLOAT"
-	   "DECODE-SINGLE-FLOAT" "DESCEND-INTO" "DIVISION-BY-ZERO-ERROR"
+	   "DECODE-LONG-FLOAT" "DECODE-SINGLE-FLOAT" "DESCEND-INTO"
+	   "DIVISION-BY-ZERO-ERROR"
 	   "DOUBLE-FLOAT-EXPONENT" "DOUBLE-FLOAT-HIGH-BITS"
 	   "DOUBLE-FLOAT-LOW-BITS" "DOUBLE-FLOAT-P" "FLOAT-WAIT"
 	   "DYNAMIC-SPACE-FREE-POINTER" "ERROR-NUMBER-OR-LOSE" "FILENAME"
@@ -1466,15 +1483,19 @@
 	   "GET-LISP-OBJ-ADDRESS" "GET-LOWTAG" "GET-TYPE" "HAIRY-TYPE"
 	   "HAIRY-TYPE-CHECK-TEMPLATE" "HAIRY-TYPE-SPECIFIER"
 	   "HANDLE-CIRCULARITY" "INDEX" "INTEGER-DECODE-DOUBLE-FLOAT"
-	   "INTEGER-DECODE-SINGLE-FLOAT" "INTERNAL-TIME"
+	   "INTEGER-DECODE-LONG-FLOAT" "INTEGER-DECODE-SINGLE-FLOAT"
+	   "INTERNAL-TIME"
 	   "INVALID-ARGUMENT-COUNT-ERROR" "INVALID-ARRAY-INDEX-ERROR"
 	   "INVALID-UNWIND-ERROR" "IRRATIONAL" "KEY-INFO" "KEY-INFO-NAME"
 	   "KEY-INFO-P" "KEY-INFO-TYPE"
-	   "LAYOUT-INVALID-ERROR"
-	   "LEXICAL-ENVIRONMENT" "LONG-FLOAT-P" "LRA"
-	   "LRA-CODE-HEADER" "LRA-P" "MAKE-ALIEN-TYPE-TYPE" "MAKE-ARGS-TYPE"
+	   "LAYOUT-INVALID-ERROR" "LEXICAL-ENVIRONMENT"
+	   "LONG-FLOAT-EXPONENT" "LONG-FLOAT-EXP-BITS" "LONG-FLOAT-HIGH-BITS"
+	   "LONG-FLOAT-LOW-BITS" "LONG-FLOAT-MID-BITS" "LONG-FLOAT-P"
+	   "LRA" "LRA-CODE-HEADER" "LRA-P"
+	   "MAKE-ALIEN-TYPE-TYPE" "MAKE-ARGS-TYPE"
 	   "MAKE-ARRAY-HEADER" "MAKE-DOUBLE-FLOAT" "MAKE-FUNCTION-TYPE"
-	   "MAKE-KEY-INFO" "MAKE-LISP-OBJ" "MAKE-MEMBER-TYPE"
+	   "MAKE-KEY-INFO" "MAKE-LISP-OBJ" "MAKE-LONG-FLOAT"
+	   "MAKE-MEMBER-TYPE"
 	   "MAKE-NAMED-TYPE" "MAKE-NUMERIC-TYPE" "MAKE-SINGLE-FLOAT"
 	   "%MAKE-INSTANCE" "MAKE-UNION-TYPE"
 	   "MAKE-VALUES-TYPE" "MEMBER-TYPE" "MEMBER-TYPE-MEMBERS"
@@ -1489,20 +1510,24 @@
 	   "OBJECT-NOT-COERCABLE-TO-FUNCTION-ERROR"
 	   "OBJECT-NOT-COMPLEX-ERROR" "OBJECT-NOT-COMPLEX-FLOAT-ERROR"
 	   "OBJECT-NOT-COMPLEX-SINGLE-FLOAT-ERROR"
+	   "OBJECT-NOT-COMPLEX-LONG-FLOAT-ERROR"
 	   "OBJECT-NOT-COMPLEX-DOUBLE-FLOAT-ERROR"
 	   "OBJECT-NOT-COMPLEX-RATIONAL-ERROR" "OBJECT-NOT-CONS-ERROR"
 	   "OBJECT-NOT-DOUBLE-FLOAT-ERROR" "OBJECT-NOT-FIXNUM-ERROR"
 	   "OBJECT-NOT-FLOAT-ERROR" "OBJECT-NOT-FUNCTION-ERROR"
 	   "OBJECT-NOT-FUNCTION-OR-SYMBOL-ERROR" "OBJECT-NOT-INSTANCE-ERROR"
 	   "OBJECT-NOT-INTEGER-ERROR"
-	   "OBJECT-NOT-LIST-ERROR" "OBJECT-NOT-NUMBER-ERROR"
+	   "OBJECT-NOT-LIST-ERROR" "OBJECT-NOT-LONG-FLOAT-ERROR"
+	   "OBJECT-NOT-NUMBER-ERROR"
 	   "OBJECT-NOT-RATIO-ERROR" "OBJECT-NOT-RATIONAL-ERROR"
 	   "OBJECT-NOT-REAL-ERROR" "OBJECT-NOT-SAP-ERROR"
 	   "OBJECT-NOT-SIGNED-BYTE-32-ERROR"
 	   "OBJECT-NOT-SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-ERROR"
+	   "OBJECT-NOT-SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-ERROR"
 	   "OBJECT-NOT-SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-ERROR"
 	   "OBJECT-NOT-SIMPLE-ARRAY-DOUBLE-FLOAT-ERROR"
 	   "OBJECT-NOT-SIMPLE-ARRAY-ERROR"
+	   "OBJECT-NOT-SIMPLE-ARRAY-LONG-FLOAT-ERROR"
 	   "OBJECT-NOT-SIMPLE-ARRAY-SINGLE-FLOAT-ERROR"
 	   "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-16-ERROR"
 	   "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-2-ERROR"
@@ -1523,13 +1548,15 @@
 	   "PARSE-LAMBDA-LIST" "PARSE-UNKNOWN-TYPE"
 	   "PARSE-UNKNOWN-TYPE-SPECIFIER" "PATHNAME-DEVICE"
 	   "PATHNAME-DIRECTORY" "PATHNAME-HOST" "PATHNAME-NAME"
-	   "PATHNAME-TYPE" "PATHNAME-VERSION" "PATHNAMELIKE"
-	   "PUNT-IF-TOO-LONG" "SCALE-DOUBLE-FLOAT" "SCALE-SINGLE-FLOAT"
+	   "PATHNAME-TYPE" "PATHNAME-VERSION" "PATHNAMELIKE" "PUNT-IF-TOO-LONG"
+	   "SCALE-DOUBLE-FLOAT" "SCALE-LONG-FLOAT" "SCALE-SINGLE-FLOAT"
 	   "SEQUENCE-END" "SET-HEADER-DATA" "SHIFT-TOWARDS-END"
 	   "SHIFT-TOWARDS-START" "SIGNAL-INIT" "SIGNED-BYTE-32-P"
 	   "SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-P"
+	   "SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-P"
 	   "SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-P"
-	   "SIMPLE-ARRAY-DOUBLE-FLOAT-P" "SIMPLE-ARRAY-P"
+	   "SIMPLE-ARRAY-DOUBLE-FLOAT-P" "SIMPLE-ARRAY-LONG-FLOAT-P"
+	   "SIMPLE-ARRAY-P"
 	   "SIMPLE-ARRAY-SINGLE-FLOAT-P" "SIMPLE-ARRAY-UNSIGNED-BYTE-16-P"
 	   "SIMPLE-ARRAY-UNSIGNED-BYTE-2-P" "SIMPLE-ARRAY-UNSIGNED-BYTE-32-P"
 	   "SIMPLE-ARRAY-UNSIGNED-BYTE-4-P" "SIMPLE-ARRAY-UNSIGNED-BYTE-8-P"
@@ -1575,7 +1602,8 @@
 	   "CLASS-STATE" "INSTANCE"
 	   "*TYPE-SYSTEM-INITIALIZED*" "WEAK-POINTER-P" "FIND-LAYOUT"
 	   "DSD-NAME" "%TYPEP" "DD-RAW-INDEX" "DD-NAME" "CLASS-SUBCLASSES"
-	   "CLASS-LAYOUT" "DD-RAW-LENGTH" "NOTE-NAME-DEFINED"
+	   "CLASS-LAYOUT"
+	   "DD-RAW-LENGTH" "NOTE-NAME-DEFINED"
 	   "%CODE-CODE-SIZE" "DD-SLOTS" "%IMAGPART" "DSD-ACCESSOR" "CLASS-INIT"
 	   "%CODE-DEBUG-INFO" "DSD-%NAME" "LAYOUT-CLASS" "LAYOUT-INVALID"
 	   "%FUNCTION-NAME" "DSD-TYPE" "%INSTANCEP"
@@ -1594,7 +1622,8 @@
 	   "BYTE-FUNCTION-OR-CLOSURE" "MAKE-STANDARD-CLASS"
 	   "BYTE-FUNCTION-NAME" "CLASS-CELL-TYPEP" "BYTE-CLOSURE"
 	   "FIND-CLASS-CELL" "EXTRACT-FUNCTION-TYPE"
-	   "FUNCALLABLE-STRUCTURE-CLASS" "%RANDOM-DOUBLE-FLOAT"
+	   "FUNCALLABLE-STRUCTURE-CLASS"
+	   "%RANDOM-DOUBLE-FLOAT" "%RANDOM-LONG-FLOAT" "%RANDOM-SINGLE-FLOAT" 
 	   "RANDOM-PCL-CLASS" "BASIC-STRUCTURE-CLASS-PRINT-FUNCTION"
 	   "%FUNCALLABLE-INSTANCE-INFO" "*EVAL-STACK*" "RANDOM-CHUNK"
 	   "MAKE-FUNCALLABLE-STRUCTURE-CLASS" "LAYOUT-HASH-MAX"
@@ -1602,9 +1631,9 @@
 	   "INITIALIZE-BYTE-COMPILED-FUNCTION" "INITIALIZE-LAYOUT-HASH"
 	   "CLASS-PCL-CLASS" "FUNCALLABLE-STRUCTURE"
 	   "FUNCALLABLE-INSTANCE-FUNCTION" "%FUNCALLABLE-INSTANCE-LAYOUT"
-	   "%RANDOM-SINGLE-FLOAT" "CLASS-CELL-CLASS" "BYTE-FUNCTION"
-	   "BASIC-STRUCTURE-CLASS" "FUNCALLABLE-STRUCTURE-CLASS-P"
-	   "BYTE-CLOSURE-FUNCTION" "REGISTER-LAYOUT" "BYTE-CLOSURE-DATA"
+	   "BASIC-STRUCTURE-CLASS" "BYTE-CLOSURE-DATA"
+	   "BYTE-CLOSURE-FUNCTION" "BYTE-FUNCTION" "CLASS-CELL-CLASS"
+	   "FUNCALLABLE-STRUCTURE-CLASS-P" "REGISTER-LAYOUT"
 	   "FUNCALLABLE-INSTANCE" "RANDOM-FIXNUM-MAX" "MAKE-RANDOM-PCL-CLASS"
 	   "INSTANCE-LAMBDA" "%FUNCALLABLE-INSTANCE-LEXENV" "%MAKE-SYMBOL"
 	   "%FUNCALLABLE-INSTANCE-FUNCTION" "SYMBOL-HASH"
diff --git a/code/float-trap.lisp b/code/float-trap.lisp
index 522093d37bff95a42549144f74794560612843ee..735ffad3171ec7403e899b16d9bbec68458c9fb8 100644
--- a/code/float-trap.lisp
+++ b/code/float-trap.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/float-trap.lisp,v 1.13 1997/09/07 23:40:00 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/float-trap.lisp,v 1.14 1998/03/21 08:11:56 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -205,7 +205,7 @@
   which includes :UNDERFLOW, :OVERFLOW, :INEXACT, :INVALID and
   :DIVIDE-BY-ZERO and on the X86 :DENORMALIZED-OPERAND. The respective
   accrued exceptions are cleared at the start of the body to support
-  their testing within and restored on exit."
+  their testing within, and restored on exit."
   (let ((traps (dpb (float-trap-mask traps) float-traps-byte 0))
 	(exceptions (dpb (float-trap-mask traps) float-sticky-bits 0))
 	(trap-mask (dpb (lognot (float-trap-mask traps))
diff --git a/code/float.lisp b/code/float.lisp
index 0950bfff104421fc5d9f93cfedb3e0ba15cb8d33..426c8680661106be18527e4c3f46a15620d04ce2 100644
--- a/code/float.lisp
+++ b/code/float.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/float.lisp,v 1.17 1998/02/19 03:49:48 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/float.lisp,v 1.18 1998/03/21 08:11:56 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -14,6 +14,7 @@
 ;;; that assumes there are only two float formats: IEEE single and double.
 ;;;
 ;;; Author: Rob MacLachlan
+;;; Long-float support by Douglas Crosher, 1998.
 ;;; 
 (in-package "KERNEL")
 (export '(%unary-truncate %unary-round))
@@ -78,6 +79,14 @@
 			  (dpb (ash sig -32) vm:double-float-significand-byte
 			       (if (zerop sign) 0 -1)))
 		     (ldb (byte 32 0) sig)))
+;;;
+#+(and long-float x86)
+(defun long-from-bits (sign exp sig)
+  (declare (type bit sign) (type (unsigned-byte 64) sig)
+	   (type (unsigned-byte 15) exp))
+  (make-long-float (logior (ash sign 15) exp)
+		   (ldb (byte 32 32) sig)
+		   (ldb (byte 32 0) sig)))
 					
 
 ;;;; Float parameters:
@@ -87,9 +96,15 @@
 (defconstant least-negative-single-float (single-from-bits 1 0 1))
 (defconstant least-negative-short-float least-negative-single-float)
 (defconstant least-positive-double-float (double-from-bits 0 0 1))
+#-long-float
 (defconstant least-positive-long-float least-positive-double-float)
+#+(and long-float x86)
+(defconstant least-positive-long-float (long-from-bits 0 0 1))
 (defconstant least-negative-double-float (double-from-bits 1 0 1))
+#-long-float
 (defconstant least-negative-long-float least-negative-double-float)
+#+(and long-float x86)
+(defconstant least-negative-long-float (long-from-bits 1 0 1))
 
 (defconstant least-positive-normalized-single-float
   (single-from-bits 0 vm:single-float-normal-exponent-min 0))
@@ -101,12 +116,22 @@
   least-negative-normalized-single-float)
 (defconstant least-positive-normalized-double-float
   (double-from-bits 0 vm:double-float-normal-exponent-min 0))
+#-long-float
 (defconstant least-positive-normalized-long-float
   least-positive-normalized-double-float)
+#+(and long-float x86)
+(defconstant least-positive-normalized-long-float
+  (long-from-bits 0 vm:long-float-normal-exponent-min
+		  (ash vm:long-float-hidden-bit 32)))
 (defconstant least-negative-normalized-double-float
   (double-from-bits 1 vm:double-float-normal-exponent-min 0))
+#-long-float
 (defconstant least-negative-normalized-long-float
   least-negative-normalized-double-float)
+#+(and long-float x86)
+(defconstant least-negative-normalized-long-float
+  (long-from-bits 1 vm:long-float-normal-exponent-min
+		  (ash vm:long-float-hidden-bit 32)))
 
 (defconstant most-positive-single-float
   (single-from-bits 0 vm:single-float-normal-exponent-max
@@ -119,11 +144,21 @@
 (defconstant most-positive-double-float
   (double-from-bits 0 vm:double-float-normal-exponent-max
 		    (ldb (byte vm:double-float-digits 0) -1)))
+#-long-float
 (defconstant most-positive-long-float most-positive-double-float)
+#+(and long-float x86)
+(defconstant most-positive-long-float
+  (long-from-bits 0 vm:long-float-normal-exponent-max
+		  (ldb (byte vm:long-float-digits 0) -1)))
 (defconstant most-negative-double-float
   (double-from-bits 1 vm:double-float-normal-exponent-max
 		    (ldb (byte vm:double-float-digits 0) -1)))
+#-long-float
 (defconstant most-negative-long-float most-negative-double-float)
+#+(and long-float x86)
+(defconstant most-negative-long-float
+  (long-from-bits 1 vm:long-float-normal-exponent-max
+		  (ldb (byte vm:long-float-digits 0) -1)))
 
 (defconstant single-float-positive-infinity
   (single-from-bits 0 (1+ vm:single-float-normal-exponent-max) 0))
@@ -133,10 +168,20 @@
 (defconstant short-float-negative-infinity single-float-negative-infinity)
 (defconstant double-float-positive-infinity
   (double-from-bits 0 (1+ vm:double-float-normal-exponent-max) 0))
+#-long-float
 (defconstant long-float-positive-infinity double-float-positive-infinity)
+#+(and long-float x86)
+(defconstant long-float-positive-infinity
+  (long-from-bits 0 (1+ vm:long-float-normal-exponent-max)
+		  (ash vm:long-float-hidden-bit 32)))
 (defconstant double-float-negative-infinity
   (double-from-bits 1 (1+ vm:double-float-normal-exponent-max) 0))
+#-long-float
 (defconstant long-float-negative-infinity double-float-negative-infinity)
+#+(and long-float x86)
+(defconstant long-float-negative-infinity
+  (long-from-bits 1 (1+ vm:long-float-normal-exponent-max)
+		  (ash vm:long-float-hidden-bit 32)))
 
 (defconstant single-float-epsilon
   (single-from-bits 0 (- vm:single-float-bias (1- vm:single-float-digits)) 1))
@@ -146,10 +191,20 @@
 (defconstant short-float-negative-epsilon single-float-negative-epsilon)
 (defconstant double-float-epsilon
   (double-from-bits 0 (- vm:double-float-bias (1- vm:double-float-digits)) 1))
+#-long-float
 (defconstant long-float-epsilon double-float-epsilon)
+#+(and long-float x86)
+(defconstant long-float-epsilon
+  (long-from-bits 0 (- vm:long-float-bias (1- vm:long-float-digits))
+		  (+ 1 (ash vm:long-float-hidden-bit 32))))
 (defconstant double-float-negative-epsilon
   (double-from-bits 0 (- vm:double-float-bias vm:double-float-digits) 1))
+#-long-float
 (defconstant long-float-negative-epsilon double-float-negative-epsilon)
+#+(and long-float x86)
+(defconstant long-float-negative-epsilon
+  (long-from-bits 0 (- vm:long-float-bias vm:long-float-digits)
+		  (+ 1 (ash vm:long-float-hidden-bit 32))))
 
 
 ;;;; Float predicates and environment query:
@@ -168,9 +223,13 @@
     ((double-float)
      (and (zerop (ldb vm:double-float-exponent-byte
 		      (double-float-high-bits x)))
+	  (not (zerop x))))
+    #+(and long-float x86)
+    ((long-float)
+     (and (zerop (ldb vm:long-float-exponent-byte (long-float-exp-bits x)))
 	  (not (zerop x))))))
 
-(macrolet ((frob (name doc single double)
+(macrolet ((frob (name doc single double #+(and long-float x86) long)
 	     `(defun ,name (x)
 		,doc
 		(number-dispatch ((x float))
@@ -185,16 +244,31 @@
 		     (declare (ignorable lo))
 		     (and (> (ldb vm:double-float-exponent-byte hi)
 			     vm:double-float-normal-exponent-max)
-			  ,double)))))))
+			  ,double)))
+		  #+(and long-float x86)
+		  ((long-float)
+		   (let ((exp (long-float-exp-bits x))
+			 (hi (long-float-high-bits x))
+			 (lo (long-float-low-bits x)))
+		     (declare (ignorable lo))
+		     (and (> (ldb vm:long-float-exponent-byte exp)
+			     vm:long-float-normal-exponent-max)
+			  ,long)))))))
 
   (frob float-infinity-p "Return true if the float X is an infinity (+ or -)."
     (zerop (ldb vm:single-float-significand-byte bits))
     (and (zerop (ldb vm:double-float-significand-byte hi))
+	 (zerop lo))
+    #+(and long-float x86)
+    (and (zerop (ldb vm:long-float-significand-byte hi))
 	 (zerop lo)))
 
   (frob float-nan-p "Return true if the float X is a NaN (Not a Number)."
     (not (zerop (ldb vm:single-float-significand-byte bits)))
     (or (not (zerop (ldb vm:double-float-significand-byte hi)))
+	(not (zerop lo)))
+    #+(and long-float x86)
+    (or (not (zerop (ldb vm:long-float-significand-byte hi)))
 	(not (zerop lo))))
 
   (frob float-trapping-nan-p
@@ -202,7 +276,10 @@
     (zerop (logand (ldb vm:single-float-significand-byte bits)
 		   vm:single-float-trapping-nan-bit))
     (zerop (logand (ldb vm:double-float-significand-byte hi)
-		   vm:double-float-trapping-nan-bit))))
+		   vm:double-float-trapping-nan-bit))
+    #+(and long-float x86)
+    (zerop (logand (ldb vm:long-float-significand-byte hi)
+		   vm:long-float-trapping-nan-bit))))
 
 
 ;;; FLOAT-PRECISION  --  Public
@@ -231,7 +308,11 @@
 	 integer-decode-single-denorm))
       ((double-float)
        (frob vm:double-float-digits vm:double-float-bias
-	 integer-decode-double-denorm)))))
+	 integer-decode-double-denorm))
+      #+long-float
+      ((long-float)
+       (frob vm:long-float-digits vm:long-float-bias
+	 integer-decode-long-denorm)))))
 
 
 (defun float-sign (float1 &optional (float2 (float 1 float1)))
@@ -239,12 +320,21 @@
    float1 and, if float2 is given, has the same absolute value
    as float2."
   (declare (float float1 float2))
-  (float-sign float1 float2))
+  (* (if (etypecase float1
+	   (single-float (minusp (single-float-bits float1)))
+	   (double-float (minusp (double-float-high-bits float1)))
+	   #+long-float
+	   (long-float (minusp (long-float-exp-bits float1))))
+	 (float -1 float1)
+	 (float 1 float1))
+     (abs float2)))
 
 (defun float-format-digits (format)
   (ecase format
     ((short-float single-float) vm:single-float-digits)
-    ((double-float long-float) vm:double-float-digits)))
+    ((double-float #-long-float long-float) vm:double-float-digits)
+    #+long-float
+    (long-float vm:long-float-digits)))
 
 (proclaim '(inline float-digits float-radix))
 
@@ -254,7 +344,9 @@
    by Guy Steele for more details."
   (number-dispatch ((f float))
     ((single-float) vm:single-float-digits)
-    ((double-float) vm:double-float-digits)))
+    ((double-float) vm:double-float-digits)
+    #+long-float
+    ((long-float) vm:long-float-digits)))
 
 (defun float-radix (f)
   "Returns (as an integer) the radix b of its floating-point
@@ -378,6 +470,63 @@
 	    biased sign)))))
 
 
+;;; INTEGER-DECODE-LONG-DENORM  --  Internal
+;;;
+#+(and long-float x86)
+(defun integer-decode-long-denorm (x)
+  (declare (type long-float x))
+  (let* ((high-bits (long-float-high-bits (abs x)))
+	 (sig-high (ldb vm:long-float-significand-byte high-bits))
+	 (low-bits (long-float-low-bits x))
+	 (sign (if (minusp (float-sign x)) -1 1))
+	 (biased (- (- vm:long-float-bias) vm:long-float-digits)))
+    (if (zerop sig-high)
+	(let ((sig low-bits)
+	      (extra-bias (- vm:long-float-digits 33))
+	      (bit (ash 1 31)))
+	  (declare (type (unsigned-byte 32) sig) (fixnum extra-bias))
+	  (loop
+	    (unless (zerop (logand sig bit)) (return))
+	    (setq sig (ash sig 1))
+	    (incf extra-bias))
+	  (values (ash sig (- vm:long-float-digits 32))
+		  (truly-the fixnum (- biased extra-bias))
+		  sign))
+	(let ((sig (ash sig-high 1))
+	      (extra-bias 0))
+	  (declare (type (unsigned-byte 32) sig) (fixnum extra-bias))
+	  (loop
+	    (unless (zerop (logand sig vm:long-float-hidden-bit))
+	      (return))
+	    (setq sig (ash sig 1))
+	    (incf extra-bias))
+	  (values (logior (ash sig 32) (ash low-bits (1- extra-bias)))
+		  (truly-the fixnum (- biased extra-bias))
+		  sign)))))
+
+
+;;; INTEGER-DECODE-LONG-FLOAT  --  Internal
+;;;
+#+(and long-float x86)
+(defun integer-decode-long-float (x)
+  (declare (long-float x))
+  (let* ((hi (long-float-high-bits x))
+	 (lo (long-float-low-bits x))
+	 (exp-bits (long-float-exp-bits x))
+	 (exp (ldb vm:long-float-exponent-byte exp-bits))
+	 (sign (if (minusp exp-bits) -1 1))
+	 (biased (- exp vm:long-float-bias vm:long-float-digits)))
+    (declare (fixnum biased))
+    (unless (<= exp vm:long-float-normal-exponent-max)
+      (error "Can't decode NAN or infinity: ~S." x))
+    (cond ((and (zerop exp) (zerop hi) (zerop lo))
+	   (values 0 biased sign))
+	  ((< exp vm:long-float-normal-exponent-min)
+	   (integer-decode-long-denorm x))
+	  (t
+	   (values (logior (ash hi 32) lo) biased sign)))))
+
+
 ;;; INTEGER-DECODE-FLOAT  --  Public
 ;;;
 ;;;    Dispatch to the correct type-specific i-d-f function.
@@ -394,7 +543,10 @@
     ((single-float)
      (integer-decode-single-float x))
     ((double-float)
-     (integer-decode-double-float x))))
+     (integer-decode-double-float x))
+    #+long-float
+    ((long-float)
+     (integer-decode-long-float x))))
 
 
 (proclaim '(maybe-inline decode-single-float decode-double-float))
@@ -484,6 +636,45 @@
 		   biased sign)))))
 
 
+;;; DECODE-LONG-DENORM  --  Internal
+;;;
+#+(and long-float x86)
+(defun decode-long-denorm (x)
+  (declare (long-float x))
+  (multiple-value-bind (sig exp sign)
+		       (integer-decode-long-denorm x)
+    (values (make-long-float vm:long-float-bias (ash sig -32)
+			     (ldb (byte 32 0) sig))
+	    (truly-the fixnum (+ exp vm:long-float-digits))
+	    (float sign x))))
+
+
+;;; DECODE-LONG-FLOAT  --  Public
+;;;
+#+(and long-float x86)
+(defun decode-long-float (x)
+  (declare (long-float x))
+  (let* ((hi (long-float-high-bits x))
+	 (lo (long-float-low-bits x))
+	 (exp-bits (long-float-exp-bits x))
+	 (exp (ldb vm:long-float-exponent-byte exp-bits))
+	 (sign (if (minusp exp-bits) -1l0 1l0))
+	 (biased (truly-the long-float-exponent (- exp vm:long-float-bias))))
+    (unless (<= exp vm:long-float-normal-exponent-max)
+      (error "Can't decode NAN or infinity: ~S." x))
+    (cond ((zerop x)
+	   (values 0.0l0 biased sign))
+	  ((< exp vm:long-float-normal-exponent-min)
+	   (decode-long-denorm x))
+	  (t
+	   (values (make-long-float
+		    (dpb vm:long-float-bias vm:long-float-exponent-byte
+			 exp-bits)
+		    hi
+		    lo)
+		   biased sign)))))
+
+
 ;;; DECODE-FLOAT  --  Public
 ;;;
 ;;;    Dispatch to the appropriate type-specific function.
@@ -498,7 +689,10 @@
     ((single-float)
      (decode-single-float f))
     ((double-float)
-     (decode-double-float f))))
+     (decode-double-float f))
+    #+long-float
+    ((long-float)
+     (decode-long-float f))))
 
 
 ;;;; SCALE-FLOAT:
@@ -611,6 +805,10 @@
       (make-double-float (dpb new-exp vm:double-float-exponent-byte hi)
 			 lo)))))
 
+#+(and x86 long-float)
+(defun scale-long-float (x exp)
+  (declare (long-float x) (fixnum exp))
+  (scale-float x exp))
 
 ;;; SCALE-FLOAT  --  Public
 ;;;
@@ -623,7 +821,10 @@
     ((single-float)
      (scale-single-float f ex))
     ((double-float)
-     (scale-double-float f ex))))
+     (scale-double-float f ex))
+    #+long-float
+    ((long-float)
+     (scale-long-float f ex))))
 
 
 ;;;; Converting to/from floats:
@@ -634,8 +835,8 @@
   result is the same float format as OTHER."
   (if otherp
       (number-dispatch ((number real) (other float))
-	(((foreach rational single-float double-float)
-	  (foreach single-float double-float))
+	(((foreach rational single-float double-float #+long-float long-float)
+	  (foreach single-float double-float #+long-float long-float))
 	 (coerce number '(dispatch-type other))))
       (if (floatp number)
 	  number
@@ -645,14 +846,17 @@
 (macrolet ((frob (name type)
 	     `(defun ,name (x)
 		(number-dispatch ((x real))
-		  (((foreach single-float double-float fixnum))
+		  (((foreach single-float double-float #+long-float long-float
+			     fixnum))
 		   (coerce x ',type))
 		  ((bignum)
 		   (bignum-to-float x ',type))
 		  ((ratio)
 		   (float-ratio x ',type))))))
   (frob %single-float single-float)
-  (frob %double-float double-float))
+  (frob %double-float double-float)
+  #+long-float
+  (frob %long-float long-float))
 
 
 ;;; FLOAT-RATIO  --  Internal
@@ -698,9 +902,14 @@
 			  (scale-float (floatit bits) scale)))))
 	       (floatit (bits)
 		 (let ((sign (if plusp 0 1)))
-		   (if (eq format 'single-float)
-		       (single-from-bits sign vm:single-float-bias bits)
-		       (double-from-bits sign vm:double-float-bias bits)))))
+		   (case format
+		     (single-float
+		      (single-from-bits sign vm:single-float-bias bits))
+		     (double-float
+		      (double-from-bits sign vm:double-float-bias bits))
+		     #+long-float
+		     (long-float
+		      (long-from-bits sign vm:long-float-bias bits))))))
 	(loop
 	  (multiple-value-bind (fraction-and-guard rem)
 			       (truncate shifted-num den)
@@ -800,7 +1009,7 @@ rounding modes & do ieee round-to-integer.
   (number-dispatch ((number real))
     ((integer) number)
     ((ratio) (values (truncate (numerator number) (denominator number))))
-    (((foreach single-float double-float))
+    (((foreach single-float double-float #+long-float long-float))
      (if (< (float most-negative-fixnum number)
 	    number
 	    (float most-positive-fixnum number))
@@ -826,7 +1035,7 @@ rounding modes & do ieee round-to-integer.
   (number-dispatch ((number real))
     ((integer) number)
     ((ratio) (values (round (numerator number) (denominator number))))
-    (((foreach single-float double-float))
+    (((foreach single-float double-float #+long-float long-float))
      (if (< (float most-negative-fixnum number)
 	    number
 	    (float most-positive-fixnum number))
@@ -851,7 +1060,7 @@ rounding modes & do ieee round-to-integer.
   more efficient than RATIONALIZE, but it assumes that floating-point is
   completely accurate, giving a result that isn't as pretty."
   (number-dispatch ((x real))
-    (((foreach single-float double-float))
+    (((foreach single-float double-float #+long-float long-float))
      (multiple-value-bind (bits exp)
 			  (integer-decode-float x)
        (if (eql bits 0)
@@ -871,7 +1080,7 @@ rounding modes & do ieee round-to-integer.
   their precision.  RATIONALIZE (and also RATIONAL) preserve the invariant:
       (= x (float (rationalize x) x))"
   (number-dispatch ((x real))
-    (((foreach single-float double-float))
+    (((foreach single-float double-float #+long-float long-float))
      ;; Thanks to Kim Fateman, who stole this function rationalize-float
      ;; from macsyma's rational. Macsyma'a rationalize was written
      ;; by the legendary Gosper (rwg). Gosper is now working for Symbolics.
@@ -882,9 +1091,11 @@ rounding modes & do ieee round-to-integer.
      (cond ((minusp x) (- (rationalize (- x))))
 	   ((zerop x) 0)
 	   (t
-	    (let ((eps (if (typep x 'single-float)
-			   single-float-epsilon
-			   double-float-epsilon))
+	    (let ((eps (etypecase x
+			   (single-float single-float-epsilon)
+			   (double-float double-float-epsilon)
+			   #+long-float
+			   (long-float long-float-epsilon)))
 		  (y ())
 		  (a ()))
 	      (do ((xx x (setq y (/ (float 1.0 x) (- xx (float a x)))))
diff --git a/code/hash-new.lisp b/code/hash-new.lisp
index e4aa64889e17ba3d9f74b9736783fdf490e5347a..1dbeeb28fec497ec1d0c9bcb5db96bb67adf75ff 100644
--- a/code/hash-new.lisp
+++ b/code/hash-new.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/hash-new.lisp,v 1.1 1997/11/03 16:08:42 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/hash-new.lisp,v 1.2 1998/03/21 08:11:57 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -909,6 +909,19 @@
 	       (logxor (ash lo (- sxmash-rotate-bits))
 		       (ash hi (- sxmash-rotate-bits))
 		       lo hi))))
+       #+long-float
+       (long-float
+	(let* ((val s-expr)
+	       (lo (long-float-low-bits val))
+	       #+sparc (mid (long-float-mid-bits val))
+	       (hi (long-float-high-bits val))
+	       (exp (long-float-exp-bits val)))
+	  (ldb sxhash-bits-byte
+	       (logxor (ash lo (- sxmash-rotate-bits))
+		       #+sparc (ash mid (- sxmash-rotate-bits))
+		       (ash hi (- sxmash-rotate-bits))
+		       (ash exp (- sxmash-rotate-bits))
+		       lo hi exp))))
        (ratio (logxor (internal-sxhash (numerator s-expr) 0)
 		      (internal-sxhash (denominator s-expr) 0)))
        (complex (logxor (internal-sxhash (realpart s-expr) 0)
diff --git a/code/interr.lisp b/code/interr.lisp
index b043d9df38cf73757153f103f19d8348dc362d14..ed404b00e26cf5407f26cdbcef4472b48ba1445d 100644
--- a/code/interr.lisp
+++ b/code/interr.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/interr.lisp,v 1.32 1997/11/15 04:38:49 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/interr.lisp,v 1.33 1998/03/21 08:11:57 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -115,6 +115,13 @@
 	 :datum object
 	 :expected-type 'double-float))
 
+#+long-float
+(deferr object-not-long-float-error (object)
+  (error 'type-error
+	 :function-name name
+	 :datum object
+	 :expected-type 'long-float))
+
 (deferr object-not-simple-string-error (object)
   (error 'type-error
 	 :function-name name
@@ -411,6 +418,13 @@
 	 :datum object
 	 :expected-type '(simple-array (complex double-float) (*))))
 
+#+(and complex-float long-float)
+(deferr object-not-simple-array-complex-long-float-error (object)
+  (error 'type-error
+	 :function-name name
+	 :datum object
+	 :expected-type '(simple-array (complex long-float) (*))))
+
 (deferr object-not-complex-error (object)
   (error 'type-error
 	 :function-name name
@@ -438,6 +452,13 @@
 	 :datum object
 	 :expected-type '(complex double-float)))
 
+#+(and complex-float long-float)
+(deferr object-not-complex-long-float-error (object)
+  (error 'type-error
+	 :function-name name
+	 :datum object
+	 :expected-type '(complex long-float)))
+
 (deferr object-not-weak-pointer-error (object)
   (error 'type-error
 	 :function-name name
diff --git a/code/kernel.lisp b/code/kernel.lisp
index 968ca13bde46f26cae6ccadbce562f87b27408dd..71e1eba13d643345992ec2767518a9be9c3c5a11 100644
--- a/code/kernel.lisp
+++ b/code/kernel.lisp
@@ -5,11 +5,10 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/kernel.lisp,v 1.11 1994/10/31 04:11:27 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/kernel.lisp,v 1.12 1998/03/21 08:11:58 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/kernel.lisp,v 1.11 1994/10/31 04:11:27 ram Exp $
 ;;;    
 (in-package "KERNEL")
 
@@ -139,6 +138,17 @@
 
 (defun make-single-float (x) (make-single-float x))
 (defun make-double-float (hi lo) (make-double-float hi lo))
+#+long-float
+(defun make-long-float (exp hi #+sparc mid lo)
+  (make-long-float exp hi #+sparc mid lo))
 (defun single-float-bits (x) (single-float-bits x))
 (defun double-float-high-bits (x) (double-float-high-bits x))
 (defun double-float-low-bits (x) (double-float-low-bits x))
+#+long-float
+(defun long-float-exp-bits (x) (long-float-exp-bits x))
+#+long-float
+(defun long-float-high-bits (x) (long-float-high-bits x))
+#+(and long-float sparc)
+(defun long-float-mid-bits (x) (long-float-mid-bits x))
+#+long-float
+(defun long-float-low-bits (x) (long-float-low-bits x))
diff --git a/code/load.lisp b/code/load.lisp
index 9d12edf3d4647a8e17af7d6b4187813af042e799..2d0ae537bb87355284a70aaffacb025d07ba7c03 100644
--- a/code/load.lisp
+++ b/code/load.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/load.lisp,v 1.68 1998/03/01 21:46:08 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/load.lisp,v 1.69 1998/03/21 08:11:58 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -804,6 +804,23 @@
 	  (complex re im))
       (done-with-fast-read-byte))))
 
+#+(and complex-float long-float)
+(define-fop (fop-complex-long-float 67)
+  (prepare-for-fast-read-byte *fasl-file*
+    (prog1
+	(let* ((re-lo (fast-read-u-integer 4))
+	       #+sparc (re-mid (fast-read-u-integer 4))
+	       (re-hi (fast-read-u-integer 4))
+	       (re-exp (fast-read-s-integer #+x86 2 #+sparc 4))
+	       (re (make-long-float re-exp re-hi #+sparc re-mid re-lo))
+	       (im-lo (fast-read-u-integer 4))
+	       #+sparc (im-mid (fast-read-u-integer 4))
+	       (im-hi (fast-read-u-integer 4))
+	       (im-exp (fast-read-s-integer #+x86 2 #+sparc 4))
+	       (im (make-long-float im-exp im-hi #+sparc im-mid im-lo)))
+	  (complex re im))
+      (done-with-fast-read-byte))))
+
 (define-fop (fop-single-float 46)
   (prepare-for-fast-read-byte *fasl-file*
     (prog1 (make-single-float (fast-read-s-integer 4))
@@ -816,6 +833,17 @@
 	  (make-double-float (fast-read-s-integer 4) lo))
       (done-with-fast-read-byte))))
 
+#+long-float
+(define-fop (fop-long-float 52)
+  (prepare-for-fast-read-byte *fasl-file*
+    (prog1
+	(let ((lo (fast-read-u-integer 4))
+	      #+sparc (mid (fast-read-u-integer 4))
+	      (hi (fast-read-u-integer 4))
+	      (exp (fast-read-s-integer #+x86 2 #+sparc 4)))
+	  (make-long-float exp hi #+sparc mid lo))
+      (done-with-fast-read-byte))))
+
 
 ;;;; Loading lists:
 
@@ -905,6 +933,14 @@
     (read-n-bytes *fasl-file* result 0 (* length vm:word-bytes 2))
     result))
 
+#+long-float
+(define-fop (fop-long-float-vector 88)
+  (let* ((length (read-arg 4))
+	 (result (make-array length :element-type 'long-float)))
+    (read-n-bytes *fasl-file* result 0
+		  (* length vm:word-bytes #+x86 3 #+sparc 4))
+    result))
+
 #+complex-float
 (define-fop (fop-complex-single-float-vector 86)
   (let* ((length (read-arg 4))
@@ -919,6 +955,14 @@
     (read-n-bytes *fasl-file* result 0 (* length vm:word-bytes 2 2))
     result))
 
+#+(and complex-float long-float)
+(define-fop (fop-complex-long-float-vector 89)
+  (let* ((length (read-arg 4))
+	 (result (make-array length :element-type '(complex long-float))))
+    (read-n-bytes *fasl-file* result 0
+		  (* length vm:word-bytes #+x86 3 #+sparc 4 2))
+    result))
+
 ;;; FOP-INT-VECTOR  --  Internal
 ;;;
 ;;; *** NOT *** the FOP-INT-VECTOR as currently documented in rtguts.  Size
diff --git a/code/macros.lisp b/code/macros.lisp
index d109dad0fee3b0befea8e5788afaa6eea8a88c5c..c837cf15a0813fff4f23ccb39831028b3cba026c 100644
--- a/code/macros.lisp
+++ b/code/macros.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.53 1998/03/01 21:46:10 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.54 1998/03/21 08:12:01 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -999,6 +999,8 @@
 (defsetf sap-ref-sap %set-sap-ref-sap)
 (defsetf sap-ref-single %set-sap-ref-single)
 (defsetf sap-ref-double %set-sap-ref-double)
+#+long-float
+(defsetf sap-ref-long %set-sap-ref-long)
 
 (define-setf-method getf (place prop &optional default &environment env)
   (multiple-value-bind (temps values stores set get)
diff --git a/code/numbers.lisp b/code/numbers.lisp
index 90f6ea53b89b81e2552d500c5c1df444119f6105..8baf9f733f256a818c306c601de57183bdb5f313 100644
--- a/code/numbers.lisp
+++ b/code/numbers.lisp
@@ -5,11 +5,10 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/numbers.lisp,v 1.32 1997/12/04 03:58:31 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/numbers.lisp,v 1.33 1998/03/21 08:12:01 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/numbers.lisp,v 1.32 1997/12/04 03:58:31 dtc Exp $
 ;;;
 ;;; This file contains the definitions of most number functions.
 ;;;
@@ -17,6 +16,7 @@
 ;;; 
 ;;; Much code in this file was derived from code written by William Lott, Dave
 ;;; Mcdonald, Jim Large, Scott Fahlman, etc.
+;;; Long-float support by Douglas Crosher, 1998.
 ;;;
 (in-package "LISP")
 
@@ -76,7 +76,8 @@
 ;;; probable first.)
 ;;;
 (defconstant type-test-ordering
-  '(fixnum single-float double-float integer bignum complex ratio))
+  '(fixnum single-float double-float integer #+long-float long-float bignum
+    complex ratio))
 
 ;;; Type-Test-Order  --  Internal
 ;;;
@@ -174,10 +175,18 @@
 ;;;
 (defun float-contagion (op x y &optional (rat-types '(fixnum bignum ratio)))
   `(((single-float single-float) (,op ,x ,y))
-    (((foreach ,@rat-types) (foreach single-float double-float))
+    (((foreach ,@rat-types)
+      (foreach single-float double-float #+long-float long-float))
      (,op (coerce ,x '(dispatch-type ,y)) ,y))
-    (((foreach single-float double-float) (foreach ,@rat-types))
+    (((foreach single-float double-float #+long-float long-float)
+      (foreach ,@rat-types))
      (,op ,x (coerce ,y '(dispatch-type ,x))))
+    #+long-float
+    (((foreach single-float double-float long-float) long-float)
+     (,op (coerce ,x 'long-float) ,y))
+    #+long-float
+    ((long-float (foreach single-float double-float))
+     (,op ,x (coerce ,y 'long-float)))
     (((foreach single-float double-float) double-float)
      (,op (coerce ,x 'double-float) ,y))
     ((double-float single-float)
@@ -213,14 +222,16 @@
   (if (eql imagpart 0)
       realpart
       #+complex-float
-      (cond ((and (typep realpart 'double-float)
+      (cond #+long-float
+	    ((and (typep realpart 'long-float)
+		  (typep imagpart 'long-float))
+	     (truly-the (complex long-float) (complex realpart imagpart)))
+	    ((and (typep realpart 'double-float)
 		  (typep imagpart 'double-float))
-	     (truly-the (complex double-float)
-			(complex realpart imagpart)))
+	     (truly-the (complex double-float) (complex realpart imagpart)))
 	    ((and (typep realpart 'single-float)
 		  (typep imagpart 'single-float))
-	     (truly-the (complex single-float)
-			(complex realpart imagpart)))
+	     (truly-the (complex single-float) (complex realpart imagpart)))
 	    (t
 	     (%make-complex realpart imagpart)))
       #-complex-float
@@ -272,6 +283,9 @@
 	 'single-float)
 	((subtypep spec 'double-float)
 	 'double-float)
+	#+long-float
+	((subtypep spec 'long-float)
+	 'long-float)
 	((subtypep spec 'rational)
 	 'rational)
 	(t)))
@@ -288,7 +302,12 @@
 (defun complex (realpart &optional (imagpart 0))
   "Builds a complex number from the specified components."
   (flet ((%%make-complex (realpart imagpart)
-	   (cond ((and (typep realpart 'double-float)
+	   (cond #+long-float
+		 ((and (typep realpart 'long-float)
+		       (typep imagpart 'long-float))
+		  (truly-the (complex long-float)
+			     (complex realpart imagpart)))
+		 ((and (typep realpart 'double-float)
 		       (typep imagpart 'double-float))
 		  (truly-the (complex double-float)
 			     (complex realpart imagpart)))
@@ -317,6 +336,9 @@
 (defun realpart (number)
   "Extracts the real part of a number."
   (typecase number
+    #+long-float
+    ((complex long-float)
+     (truly-the long-float (realpart number)))
     ((complex double-float)
      (truly-the double-float (realpart number)))
     ((complex single-float)
@@ -330,6 +352,9 @@
 (defun imagpart (number)
   "Extracts the imaginary part of a number."
   (typecase number
+    #+long-float
+    ((complex long-float)
+     (truly-the long-float (imagpart number)))
     ((complex double-float)
      (truly-the double-float (imagpart number)))
     ((complex single-float)
@@ -427,7 +452,8 @@
        ((complex complex)
 	(canonical-complex (,op (realpart x) (realpart y))
 			   (,op (imagpart x) (imagpart y))))
-       (((foreach bignum fixnum ratio single-float double-float) complex)
+       (((foreach bignum fixnum ratio single-float double-float
+		  #+long-float long-float) complex)
 	(complex (,op x (realpart y)) (,op (imagpart y))))
        ((complex (or rational float))
 	(complex (,op (realpart x) y) (imagpart x)))
@@ -496,7 +522,9 @@
 	      (ry (realpart y))
 	      (iy (imagpart y)))
 	 (canonical-complex (- (* rx ry) (* ix iy)) (+ (* rx iy) (* ix ry)))))
-      (((foreach bignum fixnum ratio single-float double-float) complex)
+      (((foreach bignum fixnum ratio single-float double-float
+		 #+long-float long-float)
+	complex)
        (complex*real y x))
       ((complex (or rational float))
        (complex*real x y))
@@ -607,7 +635,7 @@
 
 (defun %negate (n)
   (number-dispatch ((n number))
-    (((foreach fixnum single-float double-float))
+    (((foreach fixnum single-float double-float #+long-float long-float))
      (%negate n))
     ((bignum)
      (negate-bignum n))
@@ -646,16 +674,24 @@
       ((bignum bignum)
        (bignum-truncate number divisor))
       
-      (((foreach single-float double-float) (or rational single-float))
+      (((foreach single-float double-float #+long-float long-float)
+	(or rational single-float))
        (if (eql divisor 1)
 	   (let ((res (%unary-truncate number)))
 	     (values res (- number (coerce res '(dispatch-type number)))))
 	   (truncate-float (dispatch-type number))))
+      #+long-float
+      ((long-float (or single-float double-float long-float))
+       (truncate-float long-float))
+      #+long-float
+      (((foreach double-float single-float) long-float)
+       (truncate-float long-float))
       ((double-float (or single-float double-float))
        (truncate-float double-float))
       ((single-float double-float)
        (truncate-float double-float))
-      (((foreach fixnum bignum ratio) (foreach single-float double-float))
+      (((foreach fixnum bignum ratio)
+	(foreach single-float double-float #+long-float long-float))
        (truncate-float (dispatch-type divisor))))))
 
 
@@ -829,11 +865,17 @@
   `(((fixnum fixnum) (,op x y))
 
     ((single-float single-float) (,op x y))
+    #+long-float
+    (((foreach single-float double-float long-float) long-float)
+     (,op (coerce x 'long-float) y))
+    #+long-float
+    ((long-float (foreach single-float double-float))
+     (,op x (coerce y 'long-float)))
     (((foreach single-float double-float) double-float)
      (,op (coerce x 'double-float) y))
     ((double-float single-float)
      (,op x (coerce y 'double-float)))
-    (((foreach single-float double-float) rational)
+    (((foreach single-float double-float #+long-float long-float) rational)
      (if (eql y 0)
 	 (,op x (coerce 0 '(dispatch-type x)))
 	 (,op (rational x) y)))
@@ -894,7 +936,8 @@
     ((complex complex)
      (and (= (realpart x) (realpart y))
 	  (= (imagpart x) (imagpart y))))
-    (((foreach fixnum bignum ratio single-float double-float) complex)
+    (((foreach fixnum bignum ratio single-float double-float
+	       #+long-float long-float) complex)
      (and (= x (realpart y))
 	  (zerop (imagpart y))))
     ((complex (or float rational))
@@ -922,6 +965,8 @@
 	    (foo
 	      (single-float eql)
 	      (double-float eql)
+	      #+long-float
+	      (long-float eql)
 	      (bignum
 	       (lambda (x y)
 		 (zerop (bignum-compare x y))))
diff --git a/code/pred.lisp b/code/pred.lisp
index 5c3c08233b9e5f1ed3284ecf86951ae87d514fb3..b483a0260fcbe546d380c42ecef3b8d77ecb24be 100644
--- a/code/pred.lisp
+++ b/code/pred.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pred.lisp,v 1.45 1998/02/03 19:22:18 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pred.lisp,v 1.46 1998/03/21 08:12:02 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -54,10 +54,11 @@
       consp
       compiled-function-p
       complexp
-      #+complex-float complex-rational-p
+      #+complex-float complex-double-float-p
       #+complex-float complex-float-p
+      #+(and complex-float long-float) complex-long-float-p
+      #+complex-float complex-rational-p
       #+complex-float complex-single-float-p
-      #+complex-float complex-double-float-p
       double-float-p
       fdefn-p
       fixnump
@@ -99,8 +100,10 @@
       #+signed-array simple-array-signed-byte-32-p
       simple-array-single-float-p
       simple-array-double-float-p
+      #+long-float simple-array-long-float-p
       #+complex-float simple-array-complex-single-float-p
       #+complex-float simple-array-complex-double-float-p
+      #+(and complex-float long-float) simple-array-complex-long-float-p
       dylan::dylan-function-p
       )))
 
diff --git a/code/print.lisp b/code/print.lisp
index 1d36c3e3c24fd1d600be2e78888e97a0eaae70c5..87b41c2d9f67fd439ea0e2e4935fa13e27e338a0 100644
--- a/code/print.lisp
+++ b/code/print.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/print.lisp,v 1.67 1997/07/26 17:14:55 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/print.lisp,v 1.68 1998/03/21 08:12:03 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1466,7 +1466,7 @@
 ;;; SCALE-EXPONENT  --  Internal
 ;;;
 ;;;    Given a non-negative floating point number, SCALE-EXPONENT returns a new
-;;; floating point number Z in the range (0.1, 1.0] and and exponent E such
+;;; floating point number Z in the range (0.1, 1.0] and an exponent E such
 ;;; that Z * 10^E is (approximately) equal to the original number.  There may
 ;;; be some loss of precision due the floating point representation.  The
 ;;; scaling is always done with long float arithmetic, which helps printing of
@@ -1487,7 +1487,9 @@
 	  (let* ((ex (round (* exponent (log 2l0 10))))
 		 (x (if (minusp ex)
 			(if (float-denormalized-p x)
-			    (* x 1.0l16 (expt 10.0l0 (- (- ex) 16)))
+			    (* x 1.0l18 (expt 10.0l0 (- (- ex)
+							#-long-float 16
+							#+long-float 18)))
 			    (* x 10.0l0 (expt 10.0l0 (- (- ex) 1))))
 			(/ x 10.0l0 (expt 10.0l0 (1- ex))))))
 	    (do ((d 10.0l0 (* d 10.0l0))
diff --git a/code/rand-mt19937.lisp b/code/rand-mt19937.lisp
index 6d101f3105728d5727653f15e0cab43765280922..0039094c6da265f435226e26cce7464a454b7cea 100644
--- a/code/rand-mt19937.lisp
+++ b/code/rand-mt19937.lisp
@@ -6,7 +6,7 @@
 ;;; placed in the Public domain, and is provided 'as is'.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/rand-mt19937.lisp,v 1.5 1998/01/13 19:18:00 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/rand-mt19937.lisp,v 1.6 1998/03/21 08:12:04 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -232,6 +232,35 @@
 	   (vm::random-mt19937 state-vector))
 	  1d0))))
 
+#+long-float
+(declaim (inline %random-long-float))
+#+long-float
+(declaim (ftype (function ((long-float (0l0)) random-state) (long-float 0l0))
+		%random-long-float))
+
+;;; Using a faster inline VOP.
+#+(and long-float x86)
+(defun %random-long-float (arg state)
+  (declare (type (long-float (0l0)) arg)
+	   (type random-state state))
+  (let ((state-vector (random-state-state state)))
+    (* arg
+       (- (lisp::make-long-float
+	   (lisp::long-float-exp-bits 1l0)
+	   (logior (vm::random-mt19937 state-vector) vm:long-float-hidden-bit)
+	   (vm::random-mt19937 state-vector))
+	  1l0))))
+
+#+(and long-float sparc)
+(defun %random-long-float (arg state)
+  (declare (type (long-float (0l0)) arg)
+	   (type random-state state))
+  (* arg
+     (- (lisp::make-long-float
+	 (lisp::long-float-exp-bits 1l0)	; X needs more work
+	 (random-chunk state) (random-chunk state) (random-chunk state))
+	1l0)))
+
 
 ;;;; Random integers:
 
@@ -268,7 +297,8 @@
 (defun random (arg &optional (state *random-state*))
   "Generate a uniformly distributed pseudo-random number between zero
   and Arg.  State, if supplied, is the random state to use."
-  (declare (inline %random-single-float %random-double-float))
+  (declare (inline %random-single-float %random-double-float
+		   #+long-float %long-float))
   (cond
     ((and (fixnump arg) (<= arg random-fixnum-max))
      (rem (random-chunk state) arg))
@@ -276,6 +306,9 @@
      (%random-single-float arg state))
     ((typep arg 'double-float)
      (%random-double-float arg state))
+    #+long-float
+    ((typep arg 'long-float)
+     (%random-long-float arg state))
     ((integerp arg)
      (%random-integer arg state))
     (t
diff --git a/code/sap.lisp b/code/sap.lisp
index f6499db7ecb3fd883010f96e764eef9bf1ceeb7c..0cb15d091c7b481636d4b59defa6d006e3fc6cd1 100644
--- a/code/sap.lisp
+++ b/code/sap.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sap.lisp,v 1.15 1998/03/04 14:56:34 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sap.lisp,v 1.16 1998/03/21 08:12:04 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -125,7 +125,7 @@
 	   (fixnum offset))
   (sap-ref-double sap offset))
 
-#+x86
+#+(or x86 long-float)
 (defun sap-ref-long (sap offset)
   "Returns the long-float at OFFSET bytes from SAP."
   (declare (type system-area-pointer sap)
@@ -224,6 +224,13 @@
 	   (type double-float new-value))
   (setf (sap-ref-double sap offset) new-value))
 
+#+long-float
+(defun %set-sap-ref-long (sap offset new-value)
+  (declare (type system-area-pointer sap)
+	   (fixnum offset)
+	   (type long-float new-value))
+  (setf (sap-ref-long sap offset) new-value))
+
 
 
 ;;;; System memory allocation.
diff --git a/code/seq.lisp b/code/seq.lisp
index e1e862e946aa40d220dc782e993253132ad4739f..c0ab6f0edb2ffdb36dff3aa52ffd5ed3adc299dc 100644
--- a/code/seq.lisp
+++ b/code/seq.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/seq.lisp,v 1.26 1998/02/14 06:51:30 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/seq.lisp,v 1.27 1998/03/21 08:12:05 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -816,6 +816,9 @@
 	       (%single-float object))
 	      ((csubtypep type (specifier-type 'double-float))
 	       (%double-float object))
+	      #+long-float
+	      ((csubtypep type (specifier-type 'long-float))
+	       (%long-float object))
 	      ((csubtypep type (specifier-type 'float))
 	       (%single-float object))
 	      ((csubtypep type (specifier-type '(complex single-float)))
@@ -824,6 +827,10 @@
 	      ((csubtypep type (specifier-type '(complex double-float)))
 	       (complex (%double-float (realpart object))
 			(%double-float (imagpart object))))
+	      #+long-float
+	      ((csubtypep type (specifier-type '(complex long-float)))
+	       (complex (%long-float (realpart object))
+			(%long-float (imagpart object))))
 	      ((csubtypep type (specifier-type 'complex))
 	       (complex object))
 	      (t
diff --git a/code/x86-vm.lisp b/code/x86-vm.lisp
index b870031ef9d9e0673863365aab7023b0e30d9cb9..46dbf7e61351d63b11118b41eb34c05c75119f43 100644
--- a/code/x86-vm.lisp
+++ b/code/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/code/x86-vm.lisp,v 1.13 1998/02/19 10:52:13 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/x86-vm.lisp,v 1.14 1998/03/21 08:12:06 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -343,6 +343,7 @@
     (let ((reg-sap (alien-sap (deref (slot (deref (slot scp 'fpstate) 0)
 					    'fpreg)
 				     index))))
+      (declare (ignorable reg-sap))
       #+not-yet
       (setf (sys:sap-ref-long reg-sap 0) (coerce new-value 'long-float))
       (coerce new-value format))))
@@ -410,9 +411,8 @@
 
 ;;; SANCTIFY-FOR-EXECUTION -- Interface.
 ;;;
-;;; Do whatever is necessary to make the given code component executable.
-;;; On the sparc, we don't need to do anything, because the i and d caches
-;;; are unified.
+;;; Do whatever is necessary to make the given code component
+;;; executable - nothing on the x86.
 ;;; 
 (defun sanctify-for-execution (component)
   (declare (ignore component))
@@ -422,21 +422,29 @@
 ;;;
 ;;; This is used in error.lisp to insure floating-point  exceptions
 ;;; are properly trapped. The compiler translates this to a VOP.
-;;; Note: if you are compiling this from an old version you may need
-;;; to disable this until the float-wait VOP is entrenched.
+;;;
 (defun float-wait()
   (float-wait))
 
 ;;; FLOAT CONSTANTS
 ;;;
-;;; These are used by the FP move-from-{single|double} VOPs
-;;; rather than the i387 load constant instructions to avoid
-;;; consing in some cases.
-
-(defvar *fp-constant-0s0* 0s0)
-(defvar *fp-constant-0d0* 0d0)
-(defvar *fp-constant-1s0* 1s0)
-(defvar *fp-constant-1d0* 1d0)
+;;; These are used by the FP move-from-{single|double} VOPs rather
+;;; than the i387 load constant instructions to avoid consing in some
+;;; cases. Note these are initialise by genesis as they are needed
+;;; early.
+;;;
+(defvar *fp-constant-0s0*)
+(defvar *fp-constant-1s0*)
+(defvar *fp-constant-0d0*)
+(defvar *fp-constant-1d0*)
+;;; The long-float constants.
+(defvar *fp-constant-0l0*)
+(defvar *fp-constant-1l0*)
+(defvar *fp-constant-pi*)
+(defvar *fp-constant-l2t*)
+(defvar *fp-constant-l2e*)
+(defvar *fp-constant-lg2*)
+(defvar *fp-constant-ln2*)
 
 ;;; Enable/Disable scavenging of the read-only space.
 (defvar *scavenge-read-only-space* nil)
diff --git a/compiler/array-tran.lisp b/compiler/array-tran.lisp
index 10f360cc8bfe1100096cdae67a17653b02e9b81f..01c27e7fdc3684771dda82a6e4705433906b087c 100644
--- a/compiler/array-tran.lisp
+++ b/compiler/array-tran.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/array-tran.lisp,v 1.25 1998/02/24 19:14:04 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/array-tran.lisp,v 1.26 1998/03/21 08:08:31 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -201,6 +201,8 @@
   '((base-char #\NULL 8 vm:simple-string-type)
     (single-float 0.0s0 32 vm:simple-array-single-float-type)
     (double-float 0.0d0 64 vm:simple-array-double-float-type)
+    #+long-float (long-float 0.0l0 #+x86 96 #+sparc 128
+		  vm:simple-array-long-float-type)
     (bit 0 1 vm:simple-bit-vector-type)
     ((unsigned-byte 2) 0 2 vm:simple-array-unsigned-byte-2-type)
     ((unsigned-byte 4) 0 4 vm:simple-array-unsigned-byte-4-type)
@@ -215,6 +217,9 @@
 		     vm:simple-array-complex-single-float-type)
     #+complex-float ((complex double-float) #C(0.0d0 0.0d0) 128
 		     vm:simple-array-complex-double-float-type)
+    #+(and complex-float long-float)
+    ((complex long-float) #C(0.0l0 0.0l0) #+x86 192 #+sparc 256
+     vm:simple-array-complex-long-float-type)
     (t 0 32 vm:simple-vector-type)))
 
 ;;; MAKE-ARRAY  --  source-transform.
diff --git a/compiler/dump.lisp b/compiler/dump.lisp
index 82e91a1738d94647b8b9e90c6b84a32318c6e439..f0b0d100296b8226cb751f0ffa91ffb8dd50e869 100644
--- a/compiler/dump.lisp
+++ b/compiler/dump.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/dump.lisp,v 1.69 1998/03/10 18:34:03 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/dump.lisp,v 1.70 1998/03/21 08:08:32 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1044,6 +1044,46 @@
   (sub-dump-object (denominator x) file)
   (dump-fop 'lisp::fop-ratio file))
 
+;;; Dump a long-float in the current *backend* format which may
+;;; require conversion from the native backend format.
+;;;
+#+(and long-float x86)
+(defun dump-long-float (float file)
+  (declare (long-float float))
+  (let ((exp-bits (long-float-exp-bits float))
+	(high-bits (long-float-high-bits float))
+	(low-bits (long-float-low-bits float)))
+    (cond ((backend-featurep :x86)	; Native dump.
+	   (dump-unsigned-32 low-bits file)
+	   (dump-unsigned-32 high-bits file)
+	   (dump-var-signed exp-bits 2 file))
+	  ((backend-featurep :sparc)
+	   ;; Some format converstion will be needed, just dump 0l0
+	   ;; for now.
+	   (unless (zerop float)
+	     (format t "Warning: dumping ~s as 0l0~%" float))
+	   (dump-unsigned-32 0 file)
+	   (dump-unsigned-32 0 file)
+	   (dump-unsigned-32 0 file)
+	   (dump-var-signed 0 4 file))
+	  (t
+	   (error "Unable to dump long-float")))))
+
+#+(and long-float sparc)
+(defun dump-long-float (float file)
+  (declare (long-float float))
+  (let ((exp-bits (long-float-exp-bits float))
+	(high-bits (long-float-high-bits float))
+	(mid-bits (long-float-mid-bits float))
+	(low-bits (long-float-low-bits float)))
+    (cond ((backend-featurep :sparc)	; Native dump
+	   (dump-unsigned-32 low-bits file)
+	   (dump-unsigned-32 mid-bits file)
+	   (dump-unsigned-32 high-bits file)
+	   (dump-var-signed exp-bits 4 file))
+	  (t
+	   (error "Unable to dump long-float")))))
+	   
 ;;; Or a complex...
 
 #+complex-float
@@ -1063,6 +1103,11 @@
        (declare (double-float im))
        (dump-unsigned-32 (double-float-low-bits im) file)
        (dump-var-signed (double-float-high-bits im) 4 file)))
+    #+long-float
+    ((complex long-float)
+     (dump-fop 'lisp::fop-complex-long-float file)
+     (dump-long-float (realpart x) file)
+     (dump-long-float (imagpart x) file))
     (t
      (sub-dump-object (realpart x) file)
      (sub-dump-object (imagpart x) file)
@@ -1103,7 +1148,11 @@
      (let ((x x))
        (declare (double-float x))
        (dump-unsigned-32 (double-float-low-bits x) file)
-       (dump-var-signed (double-float-high-bits x) 4 file)))))
+       (dump-var-signed (double-float-high-bits x) 4 file)))
+    #+long-float
+    (long-float
+     (dump-fop 'lisp::fop-long-float file)
+     (dump-long-float x file))))
 
 
 ;;;; Symbol Dumping:
@@ -1312,6 +1361,10 @@
       ((simple-array double-float (*))
        (dump-double-float-vector simple-version file)
        (eq-save-object x file))
+      #+long-float
+      ((simple-array long-float (*))
+       (dump-long-float-vector simple-version file)
+       (eq-save-object x file))
       #+complex-float
       ((simple-array (complex single-float) (*))
        (dump-complex-single-float-vector simple-version file)
@@ -1320,6 +1373,10 @@
       ((simple-array (complex double-float) (*))
        (dump-complex-double-float-vector simple-version file)
        (eq-save-object x file))
+      #+(and complex-float long-float)
+      ((simple-array (complex long-float) (*))
+       (dump-complex-long-float-vector simple-version file)
+       (eq-save-object x file))
       (t
        (dump-i-vector simple-version file)
        (eq-save-object x file)))))
@@ -1442,6 +1499,17 @@
     (dump-data-maybe-byte-swapping vec (* length vm:word-bytes 2)
 				   (* vm:word-bytes 2) file)))
 
+;;; DUMP-LONG-FLOAT-VECTOR  --  internal.
+;;; 
+#+long-float
+(defun dump-long-float-vector (vec file)
+  (let ((length (length vec)))
+    (dump-fop 'lisp::fop-long-float-vector file)
+    (dump-unsigned-32 length file)
+    (dump-data-maybe-byte-swapping
+     vec (* length vm:word-bytes #+x86 3 #+sparc 4)
+     (* vm:word-bytes #+x86 3 #+sparc 4) file)))
+
 ;;; DUMP-COMPLEX-SINGLE-FLOAT-VECTOR  --  internal.
 ;;; 
 #+complex-float
@@ -1462,6 +1530,17 @@
     (dump-data-maybe-byte-swapping vec (* length vm:word-bytes 2 2)
 				   (* vm:word-bytes 2) file)))
 
+;;; DUMP-COMPLEX-LONG-FLOAT-VECTOR  --  internal.
+;;; 
+#+(and complex-float long-float)
+(defun dump-complex-long-float-vector (vec file)
+  (let ((length (length vec)))
+    (dump-fop 'lisp::fop-complex-long-float-vector file)
+    (dump-unsigned-32 length file)
+    (dump-data-maybe-byte-swapping
+     vec (* length vm:word-bytes #+x86 3 #+sparc 4 2)
+     (* vm:word-bytes #+x86 3 #+sparc 4) file)))
+
 ;;; DUMP-DATA-BITS-MAYBE-BYTE-SWAPPING  --  internal.
 ;;;
 ;;; Dump BYTES of data from DATA-VECTOR (which must be some unboxed vector)
diff --git a/compiler/saptran.lisp b/compiler/saptran.lisp
index bad9d32fe0459649e91bc1dc959ade03562828c5..4859fbaa25c4bb1430dfa4fab9fa092a7e38f22d 100644
--- a/compiler/saptran.lisp
+++ b/compiler/saptran.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/saptran.lisp,v 1.9 1998/03/04 14:56:35 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/saptran.lisp,v 1.10 1998/03/21 08:08:33 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -102,7 +102,7 @@
   (flushable))
 (defknown sap-ref-double (system-area-pointer fixnum) double-float
   (flushable))
-#+x86
+#+(or x86 long-float)
 (defknown sap-ref-long (system-area-pointer fixnum) long-float
   (flushable))
 
@@ -112,6 +112,10 @@
 (defknown %set-sap-ref-double
 	  (system-area-pointer fixnum double-float) double-float
   ())
+#+long-float
+(defknown %set-sap-ref-long
+	  (system-area-pointer fixnum long-float) long-float
+  ())
 
 
 ;;;; Transforms for converting sap relation operators.
@@ -142,7 +146,8 @@
 	       sap-ref-sap %set-sap-ref-sap
 	       sap-ref-single %set-sap-ref-single
 	       sap-ref-double %set-sap-ref-double
-	       #+x86 sap-ref-long))
+	       #+(or x86 long-float) sap-ref-long
+	       #+long-float %set-sap-ref-long))
   (deftransform fun ((sap offset) '* '* :eval-name t)
     (extract-function-args sap 'sap+ 2)
     `(lambda (sap offset1 offset2)
diff --git a/compiler/srctran.lisp b/compiler/srctran.lisp
index 97229b524cbfe49349f4ed73efd0679790fa0b07..3192c458896d585187ca6b5fe041819e7f183e0b 100644
--- a/compiler/srctran.lisp
+++ b/compiler/srctran.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.83 1998/02/24 09:57:12 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.84 1998/03/21 08:08:34 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -994,6 +994,13 @@
       (if (member-type-p type)
 	  (setf members (union members (member-type-members type)))
 	  (push type misc-types)))
+    #+long-float
+    (when (null (set-difference '(-0l0 0l0) members))
+      #-negative-zero-is-not-zero
+      (push (specifier-type '(long-float 0l0 0l0)) misc-types)
+      #+negative-zero-is-not-zero
+      (push (specifier-type '(long-float -0l0 0l0)) misc-types)
+      (setf members (set-difference members '(-0l0 0l0))))
     (when (null (set-difference '(-0d0 0d0) members))
       #-negative-zero-is-not-zero
       (push (specifier-type '(double-float 0d0 0d0)) misc-types)
@@ -1635,13 +1642,14 @@
 		  (values 'integer nil))
 		 (rational
 		  (values 'rational nil))
-		 ((or single-float double-float)
+		 ((or single-float double-float #+long-float long-float)
 		  (values 'float rem-type))
 		 (float
 		  (values 'float nil))
 		 (real
 		  (values nil nil)))
-	     (when (member rem-type '(float single-float double-float))
+	     (when (member rem-type '(float single-float double-float
+				      	    #+long-float long-float))
 	       (setf rem (interval-func #'(lambda (x)
 					    (coerce x rem-type))
 					rem)))
@@ -1737,13 +1745,14 @@
 		      (values 'integer nil))
 		     (rational
 		      (values 'rational nil))
-		     ((or single-float double-float)
+		     ((or single-float double-float #+long-float long-float)
 		      (values 'float result-type))
 		     (float
 		      (values 'float nil))
 		     (real
 		      (values nil nil)))
-		 (when (member result-type '(float single-float double-float))
+		 (when (member result-type '(float single-float double-float
+					     #+long-float long-float))
 		   ;; Make sure the limits on the interval have
 		   ;; the right type.
 		   (setf rem (interval-func #'(lambda (x)
diff --git a/lisp/gc.c b/lisp/gc.c
index e905717e868d716ec70def0abe1ac5131496984a..cbb39444cbd4b61b49316d30efb8e65d61af820e 100644
--- a/lisp/gc.c
+++ b/lisp/gc.c
@@ -1,7 +1,7 @@
 /*
  * Stop and Copy GC based on Cheney's algorithm.
  *
- * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/gc.c,v 1.14 1997/11/01 22:58:02 dtc Exp $
+ * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/gc.c,v 1.15 1998/03/21 08:14:59 dtc Exp $
  * 
  * Written by Christopher Hoover.
  */
@@ -1640,6 +1640,57 @@ size_vector_double_float(lispobj *where)
 	return nwords;
 }
 
+
+#ifdef type_SimpleArrayLongFloat
+static int
+scav_vector_long_float(lispobj *where, lispobj object)
+{
+	struct vector *vector;
+	int length, nwords;
+
+	vector = (struct vector *) where;
+	length = fixnum_value(vector->length);
+#ifdef sparc
+	nwords = CEILING(length * 4 + 2, 2);
+#endif
+
+	return nwords;
+}
+
+static lispobj
+trans_vector_long_float(lispobj object)
+{
+	struct vector *vector;
+	int length, nwords;
+
+	gc_assert(Pointerp(object));
+
+	vector = (struct vector *) PTR(object);
+	length = fixnum_value(vector->length);
+#ifdef sparc
+	nwords = CEILING(length * 4 + 2, 2);
+#endif
+
+	return copy_large_unboxed_object(object, nwords);
+}
+
+static int
+size_vector_long_float(lispobj *where)
+{
+	struct vector *vector;
+	int length, nwords;
+
+	vector = (struct vector *) where;
+	length = fixnum_value(vector->length);
+#ifdef sparc
+	nwords = CEILING(length * 4 + 2, 2);
+#endif
+
+	return nwords;
+}
+#endif
+
+
 #ifdef type_SimpleArrayComplexSingleFloat
 static int
 scav_vector_complex_single_float(lispobj *where, lispobj object)
@@ -1726,6 +1777,55 @@ size_vector_complex_double_float(lispobj *where)
 }
 #endif
 
+#ifdef type_SimpleArrayComplexLongFloat
+static int
+scav_vector_complex_long_float(lispobj *where, lispobj object)
+{
+	struct vector *vector;
+	int length, nwords;
+
+	vector = (struct vector *) where;
+	length = fixnum_value(vector->length);
+#ifdef sparc
+	nwords = CEILING(length * 8 + 2, 2);
+#endif
+
+	return nwords;
+}
+
+static lispobj
+trans_vector_complex_long_float(lispobj object)
+{
+	struct vector *vector;
+	int length, nwords;
+
+	gc_assert(Pointerp(object));
+
+	vector = (struct vector *) PTR(object);
+	length = fixnum_value(vector->length);
+#ifdef sparc
+	nwords = CEILING(length * 8 + 2, 2);
+#endif
+
+	return copy_large_unboxed_object(object, nwords);
+}
+
+static int
+size_vector_complex_long_float(lispobj *where)
+{
+	struct vector *vector;
+	int length, nwords;
+
+	vector = (struct vector *) where;
+	length = fixnum_value(vector->length);
+#ifdef sparc
+	nwords = CEILING(length * 8 + 2, 2);
+#endif
+
+	return nwords;
+}
+#endif
+
 
 /* Weak Pointers */
 
@@ -1869,12 +1969,18 @@ void gc_init(void)
 	scavtab[type_Ratio] = scav_boxed;
 	scavtab[type_SingleFloat] = scav_unboxed;
 	scavtab[type_DoubleFloat] = scav_unboxed;
+#ifdef type_LongFloat
+	scavtab[type_LongFloat] = scav_unboxed;
+#endif
 	scavtab[type_Complex] = scav_boxed;
 #ifdef type_ComplexSingleFloat
 	scavtab[type_ComplexSingleFloat] = scav_unboxed;
 #endif
 #ifdef type_ComplexDoubleFloat
 	scavtab[type_ComplexDoubleFloat] = scav_unboxed;
+#endif
+#ifdef type_ComplexLongFloat
+	scavtab[type_ComplexLongFloat] = scav_unboxed;
 #endif
 	scavtab[type_SimpleArray] = scav_boxed;
 	scavtab[type_SimpleString] = scav_string;
@@ -1899,11 +2005,17 @@ void gc_init(void)
 #endif
 	scavtab[type_SimpleArraySingleFloat] = scav_vector_single_float;
 	scavtab[type_SimpleArrayDoubleFloat] = scav_vector_double_float;
+#ifdef type_SimpleArrayLongFloat
+	scavtab[type_SimpleArrayLongFloat] = scav_vector_long_float;
+#endif
 #ifdef type_SimpleArrayComplexSingleFloat
 	scavtab[type_SimpleArrayComplexSingleFloat] = scav_vector_complex_single_float;
 #endif
 #ifdef type_SimpleArrayComplexDoubleFloat
 	scavtab[type_SimpleArrayComplexDoubleFloat] = scav_vector_complex_double_float;
+#endif
+#ifdef type_SimpleArrayComplexLongFloat
+	scavtab[type_SimpleArrayComplexLongFloat] = scav_vector_complex_long_float;
 #endif
 	scavtab[type_ComplexString] = scav_boxed;
 	scavtab[type_ComplexBitVector] = scav_boxed;
@@ -1947,12 +2059,18 @@ void gc_init(void)
 	transother[type_Ratio] = trans_boxed;
 	transother[type_SingleFloat] = trans_unboxed;
 	transother[type_DoubleFloat] = trans_unboxed;
+#ifdef type_LongFloat
+	transother[type_LongFloat] = trans_unboxed;
+#endif
 	transother[type_Complex] = trans_boxed;
 #ifdef type_ComplexSingleFloat
 	transother[type_ComplexSingleFloat] = trans_unboxed;
 #endif
 #ifdef type_ComplexDoubleFloat
 	transother[type_ComplexDoubleFloat] = trans_unboxed;
+#endif
+#ifdef type_ComplexLongFloat
+	transother[type_ComplexLongFloat] = trans_unboxed;
 #endif
 	transother[type_SimpleArray] = trans_boxed;
 	transother[type_SimpleString] = trans_string;
@@ -1977,11 +2095,17 @@ void gc_init(void)
 #endif
 	transother[type_SimpleArraySingleFloat] = trans_vector_single_float;
 	transother[type_SimpleArrayDoubleFloat] = trans_vector_double_float;
+#ifdef type_SimpleArrayLongFloat
+	transother[type_SimpleArrayLongFloat] = trans_vector_long_float;
+#endif
 #ifdef type_SimpleArrayComplexSingleFloat
 	transother[type_SimpleArrayComplexSingleFloat] = trans_vector_complex_single_float;
 #endif
 #ifdef type_SimpleArrayComplexDoubleFloat
 	transother[type_SimpleArrayComplexDoubleFloat] = trans_vector_complex_double_float;
+#endif
+#ifdef type_SimpleArrayComplexLongFloat
+	transother[type_SimpleArrayComplexLongFloat] = trans_vector_complex_long_float;
 #endif
 	transother[type_ComplexString] = trans_boxed;
 	transother[type_ComplexBitVector] = trans_boxed;
@@ -2024,12 +2148,18 @@ void gc_init(void)
 	sizetab[type_Ratio] = size_boxed;
 	sizetab[type_SingleFloat] = size_unboxed;
 	sizetab[type_DoubleFloat] = size_unboxed;
+#ifdef type_LongFloat
+	sizetab[type_LongFloat] = size_unboxed;
+#endif
 	sizetab[type_Complex] = size_boxed;
 #ifdef type_ComplexSingleFloat
 	sizetab[type_ComplexSingleFloat] = size_unboxed;
 #endif
 #ifdef type_ComplexDoubleFloat
 	sizetab[type_ComplexDoubleFloat] = size_unboxed;
+#endif
+#ifdef type_ComplexLongFloat
+	sizetab[type_ComplexLongFloat] = size_unboxed;
 #endif
 	sizetab[type_SimpleArray] = size_boxed;
 	sizetab[type_SimpleString] = size_string;
@@ -2054,11 +2184,17 @@ void gc_init(void)
 #endif
 	sizetab[type_SimpleArraySingleFloat] = size_vector_single_float;
 	sizetab[type_SimpleArrayDoubleFloat] = size_vector_double_float;
+#ifdef type_SimpleArrayLongFloat
+	sizetab[type_SimpleArrayLongFloat] = size_vector_long_float;
+#endif
 #ifdef type_SimpleArrayComplexSingleFloat
 	sizetab[type_SimpleArrayComplexSingleFloat] = size_vector_complex_single_float;
 #endif
 #ifdef type_SimpleArrayComplexDoubleFloat
 	sizetab[type_SimpleArrayComplexDoubleFloat] = size_vector_complex_double_float;
+#endif
+#ifdef type_SimpleArrayComplexLongFloat
+	sizetab[type_SimpleArrayComplexLongFloat] = size_vector_complex_long_float;
 #endif
 	sizetab[type_ComplexString] = size_boxed;
 	sizetab[type_ComplexBitVector] = size_boxed;
diff --git a/lisp/print.c b/lisp/print.c
index 70cb540b3b3645f0ca076ee844a771d1e50546b0..26104c5031870c960e63622135b1faeb54e19b9a 100644
--- a/lisp/print.c
+++ b/lisp/print.c
@@ -1,4 +1,4 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/print.c,v 1.7 1998/03/10 18:31:12 dtc Exp $ */
+/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/print.c,v 1.8 1998/03/21 08:15:00 dtc Exp $ */
 #include <stdio.h>
 
 #include "print.h"
@@ -36,12 +36,18 @@ char *subtype_Names[] = {
     "ratio",
     "single float",
     "double float",
+#ifdef type_LongFloat
+    "long float",
+#endif
     "complex",
 #ifdef type_ComplexSingleFloat
     "complex single float",
 #endif
 #ifdef type_ComplexDoubleFloat
     "complex double float",
+#endif
+#ifdef type_ComplexLongFloat
+    "complex long float",
 #endif
     "simple-array",
     "simple-string",
@@ -66,11 +72,17 @@ char *subtype_Names[] = {
 #endif
     "(simple-array single-float (*))",
     "(simple-array double-float (*))",
+#ifdef type_SimpleArrayLongFloat
+    "(simple-array long-float (*))",
+#endif
 #ifdef type_SimpleArrayComplexSingleFloat
     "(simple-array (complex single-float) (*))",
 #endif
 #ifdef type_SimpleArrayComplexDoubleFloat
     "(simple-array (complex double-float) (*))",
+#endif
+#ifdef type_SimpleArrayComplexLongFloat
+    "(simple-array (complex long-float) (*))",
 #endif
     "complex-string",
     "complex-bit-vector",
@@ -448,6 +460,13 @@ static void print_otherptr(lispobj obj)
                 printf("%g", ((struct double_float *)PTR(obj))->value);
                 break;
 
+#ifdef type_LongFloat
+            case type_LongFloat:
+                NEWLINE;
+                printf("%Lg", ((struct long_float *)PTR(obj))->value);
+                break;
+#endif
+
 #ifdef type_ComplexSingleFloat
             case type_ComplexSingleFloat:
                 NEWLINE;
@@ -466,6 +485,15 @@ static void print_otherptr(lispobj obj)
                 break;
 #endif
 
+#ifdef type_ComplexLongFloat
+            case type_ComplexLongFloat:
+                NEWLINE;
+                printf("%Lg", ((struct complex_long_float *)PTR(obj))->real);
+                NEWLINE;
+                printf("%Lg", ((struct complex_long_float *)PTR(obj))->imag);
+                break;
+#endif
+
             case type_SimpleString:
                 NEWLINE;
                 cptr = (char *)(ptr+1);
@@ -508,11 +536,17 @@ static void print_otherptr(lispobj obj)
 #endif
             case type_SimpleArraySingleFloat:
             case type_SimpleArrayDoubleFloat:
+#ifdef type_SimpleArrayLongFloat
+            case type_SimpleArrayLongFloat:
+#endif
 #ifdef type_SimpleArrayComplexSingleFloat
 	    case type_SimpleArrayComplexSingleFloat:
 #endif
 #ifdef type_SimpleArrayComplexDoubleFloat
 	    case type_SimpleArrayComplexDoubleFloat:
+#endif
+#ifdef type_SimpleArrayComplexLongFloat
+	    case type_SimpleArrayComplexLongFloat:
 #endif
             case type_ComplexString:
             case type_ComplexBitVector:
diff --git a/lisp/purify.c b/lisp/purify.c
index 3760ce2b999bb1ffb2a79f2d9661b46350e04684..46eaa589a7db1c29d322d7d1bd686aa5378be230 100644
--- a/lisp/purify.c
+++ b/lisp/purify.c
@@ -10,7 +10,7 @@
    and x86/GENCGC stack scavenging, by Douglas Crosher, 1996, 1997,
    1998.
 
-   $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/purify.c,v 1.15 1998/01/18 15:45:35 dtc Exp $ 
+   $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/purify.c,v 1.16 1998/03/21 08:15:01 dtc Exp $ 
 
    */
 #include <stdio.h>
@@ -124,6 +124,9 @@ maybe_can_move_p(lispobj thing)
       case type_Bignum:
       case type_SingleFloat:
       case type_DoubleFloat:
+#ifdef type_LongFloat
+      case type_LongFloat:
+#endif
       case type_Sap:
       case type_SimpleVector:
       case type_SimpleString:
@@ -147,11 +150,17 @@ maybe_can_move_p(lispobj thing)
 #endif
       case type_SimpleArraySingleFloat:
       case type_SimpleArrayDoubleFloat:
+#ifdef type_SimpleArrayLongFloat
+      case type_SimpleArrayLongFloat:
+#endif
 #ifdef type_SimpleArrayComplexSingleFloat
       case type_SimpleArrayComplexSingleFloat:
 #endif
 #ifdef type_SimpleArrayComplexDoubleFloat
       case type_SimpleArrayComplexDoubleFloat:
+#endif
+#ifdef type_SimpleArrayComplexLongFloat
+      case type_SimpleArrayComplexLongFloat:
 #endif
       case type_CodeHeader:
       case type_FunctionHeader:
@@ -323,6 +332,9 @@ valid_dynamic_space_pointer(lispobj *pointer, lispobj *start_addr)
 #endif
 #ifdef type_ComplexDoubleFloat
     case type_ComplexDoubleFloat:
+#endif
+#ifdef type_ComplexLongFloat
+    case type_ComplexLongFloat:
 #endif
     case type_SimpleArray:
     case type_ComplexString:
@@ -336,6 +348,9 @@ valid_dynamic_space_pointer(lispobj *pointer, lispobj *start_addr)
     case type_Bignum:
     case type_SingleFloat:
     case type_DoubleFloat:
+#ifdef type_LongFloat
+    case type_LongFloat:
+#endif
     case type_SimpleString:
     case type_SimpleBitVector:
     case type_SimpleArrayUnsignedByte2:
@@ -357,11 +372,17 @@ valid_dynamic_space_pointer(lispobj *pointer, lispobj *start_addr)
 #endif
     case type_SimpleArraySingleFloat:
     case type_SimpleArrayDoubleFloat:
+#ifdef type_SimpleArrayLongFloat
+    case type_SimpleArrayLongFloat:
+#endif
 #ifdef type_SimpleArrayComplexSingleFloat
     case type_SimpleArrayComplexSingleFloat:
 #endif
 #ifdef type_SimpleArrayComplexDoubleFloat
     case type_SimpleArrayComplexDoubleFloat:
+#endif
+#ifdef type_SimpleArrayComplexLongFloat
+    case type_SimpleArrayComplexLongFloat:
 #endif
     case type_Sap:
     case type_WeakPointer:
@@ -926,11 +947,17 @@ static lispobj ptrans_otherptr(lispobj thing, lispobj header, boolean constant)
       case type_Bignum:
       case type_SingleFloat:
       case type_DoubleFloat:
+#ifdef type_LongFloat
+      case type_LongFloat:
+#endif
 #ifdef type_ComplexSingleFloat
       case type_ComplexSingleFloat:
 #endif
 #ifdef type_ComplexDoubleFloat
       case type_ComplexDoubleFloat:
+#endif
+#ifdef type_ComplexLongFloat
+      case type_ComplexLongFloat:
 #endif
       case type_Sap:
         return ptrans_unboxed(thing, header);
@@ -995,15 +1022,36 @@ static lispobj ptrans_otherptr(lispobj thing, lispobj header, boolean constant)
       case type_SimpleArrayDoubleFloat:
         return ptrans_vector(thing, 64, 0, FALSE, constant);
 
+#ifdef type_SimpleArrayLongFloat
+      case type_SimpleArrayLongFloat:
+#ifdef i386
+        return ptrans_vector(thing, 96, 0, FALSE, constant);
+#endif
+#ifdef sparc
+        return ptrans_vector(thing, 128, 0, FALSE, constant);
+#endif
+#endif
+
 #ifdef type_SimpleArrayComplexSingleFloat
       case type_SimpleArrayComplexSingleFloat:
         return ptrans_vector(thing, 64, 0, FALSE, constant);
 #endif
+
 #ifdef type_SimpleArrayComplexDoubleFloat
       case type_SimpleArrayComplexDoubleFloat:
         return ptrans_vector(thing, 128, 0, FALSE, constant);
 #endif
 
+#ifdef type_SimpleArrayComplexLongFloat
+      case type_SimpleArrayComplexLongFloat:
+#ifdef i386
+        return ptrans_vector(thing, 192, 0, FALSE, constant);
+#endif
+#ifdef sparc
+        return ptrans_vector(thing, 256, 0, FALSE, constant);
+#endif
+#endif
+
       case type_CodeHeader:
         return ptrans_code(thing);
 
@@ -1163,6 +1211,9 @@ static lispobj *pscav(lispobj *addr, int nwords, boolean constant)
               case type_Bignum:
               case type_SingleFloat:
               case type_DoubleFloat:
+#ifdef type_LongFloat
+              case type_LongFloat:
+#endif
               case type_Sap:
                 /* It's an unboxed simple object. */
                 count = HeaderValue(thing)+1;
@@ -1235,6 +1286,18 @@ static lispobj *pscav(lispobj *addr, int nwords, boolean constant)
                 count = fixnum_value(vector->length)*2+2;
                 break;
 
+#ifdef type_SimpleArrayLongFloat
+              case type_SimpleArrayLongFloat:
+                vector = (struct vector *)addr;
+#ifdef i386
+                count = fixnum_value(vector->length)*3+2;
+#endif
+#ifdef sparc
+                count = fixnum_value(vector->length)*4+2;
+#endif
+                break;
+#endif
+
 #ifdef type_SimpleArrayComplexDoubleFloat
               case type_SimpleArrayComplexDoubleFloat:
                 vector = (struct vector *)addr;
@@ -1242,6 +1305,18 @@ static lispobj *pscav(lispobj *addr, int nwords, boolean constant)
                 break;
 #endif
 
+#ifdef type_SimpleArrayComplexLongFloat
+              case type_SimpleArrayComplexLongFloat:
+                vector = (struct vector *)addr;
+#ifdef i386
+                count = fixnum_value(vector->length)*6+2;
+#endif
+#ifdef sparc
+                count = fixnum_value(vector->length)*8+2;
+#endif
+                break;
+#endif
+
               case type_CodeHeader:
 #ifndef i386
                 gc_abort(); /* No code headers in static space */
diff --git a/lisp/sparc-assem.S b/lisp/sparc-assem.S
index ec7d2598692308bc9dcde270e7f7dc5664dfadb6..3fbba20e22714bff54a9e7df19aa032021135504 100644
--- a/lisp/sparc-assem.S
+++ b/lisp/sparc-assem.S
@@ -229,7 +229,13 @@ _undefined_tramp:
 
 	b	1f
         unimp   trap_Cerror
-	.byte	4, 23, 254, sc_DescriptorReg, 3
+	.byte	4
+#ifdef type_LongFloat
+        .byte   24
+#else
+	.byte	23
+#endif
+	.byte	254, sc_DescriptorReg, 3
 	.align	4
 1:
 	ld	[reg_FDEFN+FDEFN_RAW_ADDR_OFFSET], reg_CODE
diff --git a/lisp/sparc-validate.h b/lisp/sparc-validate.h
index 3cbf059779554a2c3a907546580f2fa739e681fa..ca9d2d53b013aae7664817c1c1365e5da63f5b5a 100644
--- a/lisp/sparc-validate.h
+++ b/lisp/sparc-validate.h
@@ -1,6 +1,6 @@
 /*
 
- $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/sparc-validate.h,v 1.8 1994/10/27 17:13:54 ram Exp $
+ $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/sparc-validate.h,v 1.9 1998/03/21 08:15:03 dtc Exp $
 
  This code was written as part of the CMU Common Lisp project at
  Carnegie Mellon University, and has been placed in the public domain.
@@ -15,8 +15,8 @@
 #define STATIC_SPACE_SIZE   	(0x01ff8000)
 
 #define DYNAMIC_0_SPACE_START	(0x07000000)
-#define DYNAMIC_1_SPACE_START	(0x0b000000)
-#define DYNAMIC_SPACE_SIZE  	(0x03ff8000)
+#define DYNAMIC_1_SPACE_START	(0x0f000000)
+#define DYNAMIC_SPACE_SIZE  	(0x07ff8000)
 
 #define CONTROL_STACK_START 	(0x00900000)
 #define CONTROL_STACK_SIZE  	(0x00078000)
@@ -24,5 +24,5 @@
 #define BINDING_STACK_START 	(0x00980000)
 #define BINDING_STACK_SIZE  	(0x00078000)
 
-#define HOLES {0x04ff8000, 0x06ff8000, 0x0aff8000, 0x1fff8000}
+#define HOLES {0x04ff8000, 0x06ff8000, 0x0eff8000, 0x1fff8000}
 #define HOLE_SIZE 0x2000
diff --git a/lisp/x86-assem.S b/lisp/x86-assem.S
index 2f3090d323f788ceb35b3202fab5de8cf77d1a08..7c11fd22931356b94e8b2c46d21f65f42c3448b4 100644
--- a/lisp/x86-assem.S
+++ b/lisp/x86-assem.S
@@ -1,6 +1,6 @@
 ### x86-assem.S -*- Mode: Asm; -*-
 /**
- * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/x86-assem.S,v 1.12 1998/02/21 16:52:20 dtc Exp $
+ * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/x86-assem.S,v 1.13 1998/03/21 08:15:03 dtc Exp $
  *
  * Authors:	Paul F. Werkowski <pw@snoopy.mv.com>
  *		Douglas T. Crosher
@@ -136,8 +136,15 @@ GNAME(call_into_lisp):
 	fwait			# Catch any pending NPX exceptions.
 	subl	$108,%esp	# Make room for the NPX state.
 	fnsave	(%esp)		# Resets NPX
+
+	movl	(%esp),%eax	# Load NPX control word
+	andl	$0xfffff3ff,%eax	# Set rounding mode to nearest
+	orl	$0x00000300,%eax	# Set precision to 64 bits
+	pushl	%eax
 	fldcw	(%esp)		# Recover modes
-	fldz			# insure no regs are not empty
+	popl	%eax
+
+	fldz			# insure no FP regs are empty
 	fldz
 	fldz
 	fldz
@@ -263,7 +270,11 @@ GNAME(undefined_tramp):
 	int3
 	.byte	trap_Error
         .byte   2
+#ifdef type_LongFloat
+        .byte   24
+#else
         .byte   23
+#endif
         .byte   sc_DescriptorReg # EAX in the Descriptor-reg SC.
 	ret
 	.size	GNAME(undefined_tramp), .-GNAME(undefined_tramp)