diff --git a/bootfiles/19c/boot-2006-06-1-cross-dd-ppc.lisp b/bootfiles/19c/boot-2006-06-1-cross-dd-ppc.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..feb611059929ece9aae5b477ff6dc361d7dc0978
--- /dev/null
+++ b/bootfiles/19c/boot-2006-06-1-cross-dd-ppc.lisp
@@ -0,0 +1,245 @@
+(in-package :cl-user)
+
+;;; Rename the X86 package and backend so that new-backend does the
+;;; right thing.
+(rename-package "PPC" "OLD-PPC")
+(setf (c:backend-name c:*native-backend*) "OLD-PPC")
+
+(c::new-backend "PPC"
+   ;; Features to add here
+   '(:ppc
+     :new-assembler
+     :conservative-float-type
+     :hash-new
+     :random-mt19937
+     :darwin :bsd
+     :cmu :cmu19 :cmu19c
+     :relative-package-names		; Relative package names from Allegro
+     :linkage-table
+     :modular-arith
+     :double-double			; Double-double float support
+     :gencgc				; Generational gc
+     )
+   ;; Features to remove from current *features* here
+   '(:x86-bootstrap :alpha :osf1 :mips :x86 :i486 :pentium :ppro
+     :propagate-fun-type :propagate-float-type :constrain-float-type
+     :openbsd :freebsd :glibc2 :linux :pentium :elf :mp
+     :stack-checking :heap-overflow-check
+     :cgc :long-float :new-random :small))
+
+;;; Extern-alien-name for the new backend.
+(in-package :vm)
+(defun extern-alien-name (name)
+  (declare (type simple-string name))
+  (concatenate 'string "_" name))
+(export 'extern-alien-name)
+(export 'fixup-code-object)
+(export 'sanctify-for-execution)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Things needed to cross-compile double-double changes.
+(in-package "KERNEL")
+
+(eval-when (compile load eval)
+(c:defknown double-double-float-p (t)
+  boolean
+  (c:movable c:foldable c:flushable))
+)
+
+(eval-when (compile load eval)
+  (handler-bind ((error (lambda (c)
+			  (declare (ignore c))
+			  (invoke-restart 'continue))))
+    (defconstant type-test-ordering
+      '(fixnum single-float double-float integer #+long-float long-float
+	double-double-float bignum
+	complex ratio))
+    ))
+
+(eval-when (compile load eval)
+  (handler-bind ((error (lambda (c)
+			  (declare (ignore c))
+			  (invoke-restart 'continue))))
+    (defconstant float-formats
+      '(double-double-float long-float double-float single-float short-float))))
+
+(in-package "LISP")
+(define-fop (fop-double-double-float 67)
+  (prepare-for-fast-read-byte *fasl-file*
+    (prog1
+	(let ((hi-lo (fast-read-u-integer 4))
+	      (hi-hi (fast-read-s-integer 4))
+	      (lo-lo (fast-read-u-integer 4))
+	      (lo-hi (fast-read-s-integer 4)))
+	  (kernel::make-double-double-float
+	   (make-double-float hi-hi hi-lo)
+	   (make-double-float lo-hi lo-lo)))
+      (done-with-fast-read-byte))))
+;; End changes for double-double
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Compile the new backend.
+(pushnew :bootstrap *features*)
+(pushnew :building-cross-compiler *features*)
+(load "target:tools/comcom")
+
+;;; Load the new backend.
+(setf (search-list "c:")
+      '("target:compiler/"))
+(setf (search-list "vm:")
+      '("c:ppc/" "c:generic/"))
+(setf (search-list "assem:")
+      '("target:assembly/" "target:assembly/ppc/"))
+
+;; Load the backend of the compiler.
+
+(in-package "C")
+
+(load "vm:vm-macs")
+(load "vm:parms")
+(load "vm:objdef")
+(load "vm:interr")
+(load "assem:support")
+
+(load "target:compiler/srctran")
+(load "vm:vm-typetran")
+(load "target:compiler/float-tran")
+(load "target:compiler/saptran")
+
+(load "vm:macros")
+(load "vm:utils")
+
+(load "vm:vm")
+(load "vm:insts")
+(load "vm:primtype")
+(load "vm:move")
+(load "vm:sap")
+(load "vm:system")
+(load "vm:char")
+(load "vm:float")
+
+(load "vm:memory")
+(load "vm:static-fn")
+(load "vm:arith")
+(load "vm:cell")
+(load "vm:subprim")
+(load "vm:debug")
+(load "vm:c-call")
+(load "vm:print")
+(load "vm:alloc")
+(load "vm:call")
+(load "vm:nlx")
+(load "vm:values")
+(load "vm:array")
+(load "vm:pred")
+(load "vm:type-vops")
+
+(load "assem:assem-rtns")
+
+(load "assem:array")
+(load "assem:arith")
+(load "assem:alloc")
+
+(load "c:pseudo-vops")
+
+(check-move-function-consistency)
+
+(load "vm:new-genesis")
+
+;;; OK, the cross compiler backend is loaded.
+
+(setf *features* (remove :building-cross-compiler *features*))
+
+;;; Info environment hacks.
+(macrolet ((frob (&rest syms)
+	     `(progn ,@(mapcar #'(lambda (sym)
+				   `(handler-bind ((error #'(lambda (c)
+							      (declare (ignore c))
+							      (invoke-restart 'kernel::continue))))
+				     (defconstant ,sym
+				       (symbol-value
+					(find-symbol ,(symbol-name sym)
+						     :vm)))))
+			       syms))))
+  (frob OLD-PPC:BYTE-BITS OLD-PPC:WORD-BITS
+	#+long-float OLD-PPC:SIMPLE-ARRAY-LONG-FLOAT-TYPE 
+	OLD-PPC:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE 
+	OLD-PPC:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE
+	#+long-float OLD-PPC:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE 
+	OLD-PPC:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE 
+	OLD-PPC:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE
+	OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE 
+	OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE
+	OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE 
+	OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE 
+	OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE 
+	OLD-PPC:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE 
+	OLD-PPC:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE
+	OLD-PPC:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE 
+	OLD-PPC:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE
+	OLD-PPC:SIMPLE-BIT-VECTOR-TYPE
+	OLD-PPC:SIMPLE-STRING-TYPE OLD-PPC:SIMPLE-VECTOR-TYPE 
+	OLD-PPC:SIMPLE-ARRAY-TYPE OLD-PPC:VECTOR-DATA-OFFSET
+	))
+
+(let ((function (symbol-function 'kernel:error-number-or-lose)))
+  (let ((*info-environment* (c:backend-info-environment c:*target-backend*)))
+    (setf (symbol-function 'kernel:error-number-or-lose) function)
+    (setf (info function kind 'kernel:error-number-or-lose) :function)
+    (setf (info function where-from 'kernel:error-number-or-lose) :defined)))
+
+(defun fix-class (name)
+  (let* ((new-value (find-class name))
+	 (new-layout (kernel::%class-layout new-value))
+	 (new-cell (kernel::find-class-cell name))
+	 (*info-environment* (c:backend-info-environment c:*target-backend*)))
+    (remhash name kernel::*forward-referenced-layouts*)
+    (kernel::%note-type-defined name)
+    (setf (info type kind name) :instance)
+    (setf (info type class name) new-cell)
+    (setf (info type compiler-layout name) new-layout)
+    new-value))
+(fix-class 'c::vop-parse)
+(fix-class 'c::operand-parse)
+
+#+random-mt19937
+(declaim (notinline kernel:random-chunk))
+
+(setf c:*backend* c:*target-backend*)
+
+;;; Extern-alien-name for the new backend.
+(in-package :vm)
+(defun extern-alien-name (name)
+  (declare (type simple-string name))
+  (concatenate 'string "_" name))
+(export 'extern-alien-name)
+(export 'fixup-code-object)
+(export 'sanctify-for-execution)
+
+(in-package :cl-user)
+
+;;; Don't load compiler parts from the target compilation
+
+(defparameter *load-stuff* nil)
+
+;; hack, hack, hack: Make old-x86::any-reg the same as
+;; x86::any-reg as an SC.  Do this by adding old-x86::any-reg
+;; to the hash table with the same value as x86::any-reg.
+     
+(let ((ht (c::backend-sc-names c::*target-backend*)))
+  (setf (gethash 'old-ppc::any-reg ht)
+	(gethash 'ppc::any-reg ht)))
+
+;; A hack for ppc.  Make sure the vop, move-double-to-int-arg, is
+;; available in both the OLD-PPC and new PPC package.  (I don't know
+;; why this is needed, but it seems to be.)
+(let ((ht (c::backend-template-names c::*target-backend*)))
+  (dolist (syms '((old-ppc::move-double-to-int-arg
+		   ppc::move-double-to-int-arg)
+		  (old-ppc::move-single-to-int-arg
+		   ppc::move-single-to-int-arg)))
+    (destructuring-bind (old new)
+	syms
+      (setf (gethash old
+		     ht)
+	    (gethash new ht)))))
diff --git a/bootfiles/19c/boot-2006-06-1-cross-dd-sparc.lisp b/bootfiles/19c/boot-2006-06-1-cross-dd-sparc.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..7285f3eff88382b2594402684bf3774a01424290
--- /dev/null
+++ b/bootfiles/19c/boot-2006-06-1-cross-dd-sparc.lisp
@@ -0,0 +1,280 @@
+;;;; This is the cross-compile script for adding the
+;;;; double-double-float type for sparc.
+;;;;
+;;;; Use the standard src/tools/cross-build-world.sh script with this
+;;;; cross-compile script to generate a double-double-float build.
+;;;; Something like
+;;;;
+;;;;   src/tools/cross-build-world.sh xtarget xcross <this-file> <19c binary>
+;;;;
+;;;; Once that has been done, you still need to do a full set of
+;;;; builds to get one with double-double-float integrated in.  Use
+;;;; the boot-2006-06-1.lisp bootstrap file for that.  Something like:
+;;;;
+;;;;   src/tools/build.sh -C "sun4_solaris_sunc" -o "xtarget/lisp/lisp -noinit"
+;;;;
+
+(in-package :cl-user)
+
+;;; Rename the SPARC package and backend so that new-backend does the
+;;; right thing.
+(rename-package "SPARC" "OLD-SPARC")
+(setf (c:backend-name c:*native-backend*) "OLD-SPARC")
+
+(c::new-backend "SPARC"
+   ;; Features to add here
+   '(:sparc
+     :sparc-v9				; For Ultrasparc processors
+     :complex-fp-vops			; Some slightly faster FP vops on complex numbers
+     :linkage-table
+     :stack-checking			; Throw error if we run out of stack
+     :heap-overflow-check		; Throw error if we run out of heap
+     :gencgc				; Generational GC
+     :relative-package-names		; Relative package names from Allegro
+     :conservative-float-type
+     :hash-new
+     :random-mt19937			; MT-19937 generator
+     :cmu				; Announce this is CMUCL
+     :cmu19 :cmu19c			; Current version identifier
+     :modular-arith			; Modular arithmetic
+     :double-double			; Add double-double-float support.
+     )
+   ;; Features to remove from current *features* here
+   '(:sparc-v8 :sparc-v7		; Choose only one of :sparc-v7, :sparc-v8, :sparc-v9
+     ;; Other architectures we aren't using.
+     :x86 :x86-bootstrap
+     :alpha :osf1 :mips
+     ;; Really old stuff that should have been removed long ago.
+     :propagate-fun-type :propagate-float-type :constrain-float-type
+     ;; Other OSes were not using
+     :openbsd :freebsd :glibc2 :linux
+     :pentium
+     :long-float
+     :new-random
+     :small))
+
+;;; May need to add some symbols to *features* and
+;;; sys::*runtime-features* as well.  This might be needed even if we
+;;; have those listed above, because of the code checks for things in
+;;; *features* and not in the backend-features..  So do that here.
+
+
+;;; Extern-alien-name for the new backend.
+(in-package :vm)
+(defun extern-alien-name (name)
+  (declare (type simple-string name))
+  #+(and bsd (not elf))
+  (concatenate 'string "_" name)
+  #-(and bsd (not elf))
+  name)
+;; When compiling the compiler, vm:fixup-code-object and
+;; vm:sanctify-for-execution are undefined.  Import these to get rid
+;; of that error.
+(import 'old-sparc::fixup-code-object)
+(import 'old-sparc::sanctify-for-execution)
+(export 'extern-alien-name)
+(export 'fixup-code-object)
+(export 'sanctify-for-execution)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Things needed to cross-compile double-double changes.
+(in-package "KERNEL")
+
+(eval-when (compile load eval)
+(c:defknown double-double-float-p (t)
+  boolean
+  (c:movable c:foldable c:flushable))
+)
+
+(eval-when (compile load eval)
+  (handler-bind ((error (lambda (c)
+			  (declare (ignore c))
+			  (invoke-restart 'continue))))
+    (defconstant type-test-ordering
+      '(fixnum single-float double-float integer #+long-float long-float
+	double-double-float bignum
+	complex ratio))
+    ))
+
+(eval-when (compile load eval)
+  (handler-bind ((error (lambda (c)
+			  (declare (ignore c))
+			  (invoke-restart 'continue))))
+    (defconstant float-formats
+      '(double-double-float long-float double-float single-float short-float))))
+
+(in-package "LISP")
+(define-fop (fop-double-double-float 67)
+  (prepare-for-fast-read-byte *fasl-file*
+    (prog1
+	(let ((hi-lo (fast-read-u-integer 4))
+	      (hi-hi (fast-read-s-integer 4))
+	      (lo-lo (fast-read-u-integer 4))
+	      (lo-hi (fast-read-s-integer 4)))
+	  (kernel::make-double-double-float
+	   (make-double-float hi-hi hi-lo)
+	   (make-double-float lo-hi lo-lo)))
+      (done-with-fast-read-byte))))
+
+;; End changes for double-double
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(in-package :cl-user)
+
+;;; Compile the new backend.
+(pushnew :bootstrap *features*)
+(pushnew :building-cross-compiler *features*)
+(load "target:tools/comcom")
+
+;;; Load the new backend.
+(setf (search-list "c:")
+      '("target:compiler/"))
+(setf (search-list "vm:")
+      '("c:sparc/" "c:generic/"))
+(setf (search-list "assem:")
+      '("target:assembly/" "target:assembly/sparc/"))
+
+;; Load the backend of the compiler.
+
+(in-package "C")
+
+(load "vm:vm-macs")
+(load "vm:parms")
+(load "vm:objdef")
+(load "vm:interr")
+(load "assem:support")
+
+(load "target:compiler/srctran")
+(load "vm:vm-typetran")
+(load "target:compiler/float-tran")
+(load "target:compiler/saptran")
+
+(load "vm:macros")
+(load "vm:utils")
+
+(load "vm:vm")
+(load "vm:insts")
+(load "vm:primtype")
+(load "vm:move")
+(load "vm:sap")
+(load "vm:system")
+(load "vm:char")
+(load "vm:float")
+
+(load "vm:memory")
+(load "vm:static-fn")
+(load "vm:arith")
+(load "vm:cell")
+(load "vm:subprim")
+(load "vm:debug")
+(load "vm:c-call")
+(load "vm:print")
+(load "vm:alloc")
+(load "vm:call")
+(load "vm:nlx")
+(load "vm:values")
+(load "vm:array")
+(load "vm:pred")
+(load "vm:type-vops")
+
+(load "assem:assem-rtns")
+
+(load "assem:array")
+(load "assem:arith")
+(load "assem:alloc")
+
+(load "c:pseudo-vops")
+
+(check-move-function-consistency)
+
+(load "vm:new-genesis")
+
+;;; OK, the cross compiler backend is loaded.
+
+(setf *features* (remove :building-cross-compiler *features*))
+
+;;; Info environment hacks.
+(macrolet ((frob (&rest syms)
+	     `(progn ,@(mapcar #'(lambda (sym)
+				   `(handler-bind ((error #'(lambda (c)
+							      (declare (ignore c))
+							      (invoke-restart 'kernel::continue))))
+				      (defconstant ,sym
+					(symbol-value
+					 (find-symbol ,(symbol-name sym)
+						      :vm)))))
+			       syms))))
+  (frob OLD-SPARC:BYTE-BITS OLD-SPARC:WORD-BITS
+	OLD-SPARC:LOWTAG-BITS
+	#+long-float OLD-SPARC:SIMPLE-ARRAY-LONG-FLOAT-TYPE 
+	OLD-SPARC:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE 
+	OLD-SPARC:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE
+	#+long-float OLD-SPARC:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE 
+	OLD-SPARC:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE 
+	OLD-SPARC:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE
+	OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE 
+	OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE
+	OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE 
+	OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE 
+	OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE 
+	OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE 
+	OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE
+	OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE 
+	OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE
+	OLD-SPARC:SIMPLE-BIT-VECTOR-TYPE
+	OLD-SPARC:SIMPLE-STRING-TYPE OLD-SPARC:SIMPLE-VECTOR-TYPE 
+	OLD-SPARC:SIMPLE-ARRAY-TYPE OLD-SPARC:VECTOR-DATA-OFFSET
+	OLD-SPARC:DOUBLE-FLOAT-DIGITS
+	old-sparc:single-float-digits
+	))
+
+(let ((function (symbol-function 'kernel:error-number-or-lose)))
+  (let ((*info-environment* (c:backend-info-environment c:*target-backend*)))
+    (setf (symbol-function 'kernel:error-number-or-lose) function)
+    (setf (info function kind 'kernel:error-number-or-lose) :function)
+    (setf (info function where-from 'kernel:error-number-or-lose) :defined)))
+
+(defun fix-class (name)
+  (let* ((new-value (find-class name))
+	 (new-layout (kernel::%class-layout new-value))
+	 (new-cell (kernel::find-class-cell name))
+	 (*info-environment* (c:backend-info-environment c:*target-backend*)))
+    (remhash name kernel::*forward-referenced-layouts*)
+    (kernel::%note-type-defined name)
+    (setf (info type kind name) :instance)
+    (setf (info type class name) new-cell)
+    (setf (info type compiler-layout name) new-layout)
+    new-value))
+(fix-class 'c::vop-parse)
+(fix-class 'c::operand-parse)
+
+#+random-mt19937
+(declaim (notinline kernel:random-chunk))
+
+(setf c:*backend* c:*target-backend*)
+
+;;; Extern-alien-name for the new backend.
+(in-package :vm)
+(defun extern-alien-name (name)
+  (declare (type simple-string name))
+  #+(and bsd (not elf))
+  (concatenate 'string "_" name)
+  #-(and bsd (not elf))
+  name)
+(export 'extern-alien-name)
+(export 'fixup-code-object)
+(export 'sanctify-for-execution)
+(in-package :cl-user)
+
+;;; Don't load compiler parts from the target compilation
+
+(defparameter *load-stuff* nil)
+
+;; Sometimes during cross-compile sparc::any-reg isn't defined during
+;; cross-compile.
+;;
+;; hack, hack, hack: Make old-sparc::any-reg the same as
+;; sparc::any-reg as an SC.  Do this by adding old-sparc::any-reg
+;; to the hash table with the same value as sparc::any-reg.
+(let ((ht (c::backend-sc-names c::*target-backend*)))
+  (setf (gethash 'old-sparc::any-reg ht)
+	(gethash 'sparc::any-reg ht)))
diff --git a/bootfiles/19c/boot-2006-06-1-cross-dd-x86.lisp b/bootfiles/19c/boot-2006-06-1-cross-dd-x86.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..ebf334427202a4229844448c75fea38239946460
--- /dev/null
+++ b/bootfiles/19c/boot-2006-06-1-cross-dd-x86.lisp
@@ -0,0 +1,223 @@
+(in-package :cl-user)
+
+;;; Rename the X86 package and backend so that new-backend does the
+;;; right thing.
+(rename-package "X86" "OLD-X86")
+(setf (c:backend-name c:*native-backend*) "OLD-X86")
+
+(c::new-backend "X86"
+   ;; Features to add here
+   '(:x86 :i486 :pentium
+     :stack-checking
+     :heap-overflow-check
+     :relative-package-names
+     :mp
+     :gencgc
+     :conservative-float-type
+     :hash-new :random-mt19937
+     :linux :glibc2 :glibc2.1
+     :cmu :cmu19 :cmu19c
+     :double-double			; double-double-float
+     )
+   ;; Features to remove from current *features* here
+   '(:x86-bootstrap :alpha :osf1 :mips
+     :propagate-fun-type :propagate-float-type :constrain-float-type
+     :openbsd :freebsd :glibc2 :linux
+     :long-float :new-random :small))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Things needed to cross-compile double-double changes.
+(in-package "KERNEL")
+
+(eval-when (compile load eval)
+(c:defknown double-double-float-p (t)
+  boolean
+  (c:movable c:foldable c:flushable))
+)
+
+(eval-when (compile load eval)
+  (handler-bind ((error (lambda (c)
+			  (declare (ignore c))
+			  (invoke-restart 'continue))))
+    (defconstant type-test-ordering
+      '(fixnum single-float double-float integer #+long-float long-float
+	double-double-float bignum
+	complex ratio))
+    ))
+
+(eval-when (compile load eval)
+  (handler-bind ((error (lambda (c)
+			  (declare (ignore c))
+			  (invoke-restart 'continue))))
+    (defconstant float-formats
+      '(double-double-float long-float double-float single-float short-float))))
+
+(in-package "LISP")
+(define-fop (fop-double-double-float 67)
+  (prepare-for-fast-read-byte *fasl-file*
+    (prog1
+	(let ((hi-lo (fast-read-u-integer 4))
+	      (hi-hi (fast-read-s-integer 4))
+	      (lo-lo (fast-read-u-integer 4))
+	      (lo-hi (fast-read-s-integer 4)))
+	  (kernel::make-double-double-float
+	   (make-double-float hi-hi hi-lo)
+	   (make-double-float lo-hi lo-lo)))
+      (done-with-fast-read-byte))))
+
+;; End changes for double-double
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(in-package :cl-user)
+
+;;; Compile the new backend.
+(pushnew :bootstrap *features*)
+(pushnew :building-cross-compiler *features*)
+(load "target:tools/comcom")
+
+;;; Load the new backend.
+(setf (search-list "c:")
+      '("target:compiler/"))
+(setf (search-list "vm:")
+      '("c:x86/" "c:generic/"))
+(setf (search-list "assem:")
+      '("target:assembly/" "target:assembly/x86/"))
+
+;; Load the backend of the compiler.
+
+(in-package "C")
+
+(load "vm:vm-macs")
+(load "vm:parms")
+(load "vm:objdef")
+(load "vm:interr")
+(load "assem:support")
+
+(load "target:compiler/srctran")
+(load "vm:vm-typetran")
+(load "target:compiler/float-tran")
+(load "target:compiler/saptran")
+
+(load "vm:macros")
+(load "vm:utils")
+
+(load "vm:vm")
+(load "vm:insts")
+(load "vm:primtype")
+(load "vm:move")
+(load "vm:sap")
+(load "vm:system")
+(load "vm:char")
+(load "vm:float")
+
+(load "vm:memory")
+(load "vm:static-fn")
+(load "vm:arith")
+(load "vm:cell")
+(load "vm:subprim")
+(load "vm:debug")
+(load "vm:c-call")
+(load "vm:print")
+(load "vm:alloc")
+(load "vm:call")
+(load "vm:nlx")
+(load "vm:values")
+(load "vm:array")
+(load "vm:pred")
+(load "vm:type-vops")
+
+(load "assem:assem-rtns")
+
+(load "assem:array")
+(load "assem:arith")
+(load "assem:alloc")
+
+(load "c:pseudo-vops")
+
+(check-move-function-consistency)
+
+(load "vm:new-genesis")
+
+;;; OK, the cross compiler backend is loaded.
+
+(setf *features* (remove :building-cross-compiler *features*))
+
+;;; Info environment hacks.
+(macrolet ((frob (&rest syms)
+	     `(progn ,@(mapcar #'(lambda (sym)
+				   `(handler-bind ((error #'(lambda (c)
+							      (declare (ignore c))
+							      (invoke-restart 'kernel::continue))))
+				      (defconstant ,sym
+					(symbol-value
+					 (find-symbol ,(symbol-name sym)
+						      :vm)))))
+			       syms))))
+  (frob OLD-X86:BYTE-BITS OLD-X86:WORD-BITS
+	#+long-float OLD-X86:SIMPLE-ARRAY-LONG-FLOAT-TYPE 
+	OLD-X86:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE 
+	OLD-X86:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE
+	#+long-float OLD-X86:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE 
+	OLD-X86:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE 
+	OLD-X86:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE
+	OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE 
+	OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE
+	OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE 
+	OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE 
+	OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE 
+	OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE 
+	OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE
+	OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE 
+	OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE
+	OLD-X86:SIMPLE-BIT-VECTOR-TYPE
+	OLD-X86:SIMPLE-STRING-TYPE OLD-X86:SIMPLE-VECTOR-TYPE 
+	OLD-X86:SIMPLE-ARRAY-TYPE OLD-X86:VECTOR-DATA-OFFSET
+	))
+
+(let ((function (symbol-function 'kernel:error-number-or-lose)))
+  (let ((*info-environment* (c:backend-info-environment c:*target-backend*)))
+    (setf (symbol-function 'kernel:error-number-or-lose) function)
+    (setf (info function kind 'kernel:error-number-or-lose) :function)
+    (setf (info function where-from 'kernel:error-number-or-lose) :defined)))
+
+(defun fix-class (name)
+  (let* ((new-value (find-class name))
+	 (new-layout (kernel::%class-layout new-value))
+	 (new-cell (kernel::find-class-cell name))
+	 (*info-environment* (c:backend-info-environment c:*target-backend*)))
+    (remhash name kernel::*forward-referenced-layouts*)
+    (kernel::%note-type-defined name)
+    (setf (info type kind name) :instance)
+    (setf (info type class name) new-cell)
+    (setf (info type compiler-layout name) new-layout)
+    new-value))
+(fix-class 'c::vop-parse)
+(fix-class 'c::operand-parse)
+
+#+random-mt19937
+(declaim (notinline kernel:random-chunk))
+
+(setf c:*backend* c:*target-backend*)
+
+;;; Extern-alien-name for the new backend.
+(in-package :vm)
+(defun extern-alien-name (name)
+  (declare (type simple-string name))
+  #+(and bsd (not elf))
+  (concatenate 'string "_" name)
+  #-(and bsd (not elf))
+  name)
+(export 'extern-alien-name)
+(export 'fixup-code-object)
+(export 'sanctify-for-execution)
+(in-package :cl-user)
+
+;;; Don't load compiler parts from the target compilation
+
+(defparameter *load-stuff* nil)
+
+;; hack, hack, hack: Make old-x86::any-reg the same as
+;; x86::any-reg as an SC.  Do this by adding old-x86::any-reg
+;; to the hash table with the same value as x86::any-reg.
+(let ((ht (c::backend-sc-names c::*target-backend*)))
+  (setf (gethash 'old-x86::any-reg ht)
+	(gethash 'x86::any-reg ht)))
diff --git a/bootfiles/19c/boot-2006-06-1.lisp b/bootfiles/19c/boot-2006-06-1.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..e1bf88461948383072dc6bc7d28d100b3d1d7a48
--- /dev/null
+++ b/bootfiles/19c/boot-2006-06-1.lisp
@@ -0,0 +1,47 @@
+;;;; Bootstrap file for doing a full build from a cross-compile for
+;;;; double-double-float support.  This needs to be done using the
+;;;; build from the cross-compile for double-double-float.  See
+;;;; boot-2006-06-1-cross-dd-sparc.lisp for more info.
+(in-package :cl-user)
+(pushnew :double-double *features*)
+(setf lisp::*enable-package-locked-errors* nil)
+
+;;; This is a hack.  I need make-double-double-float,
+;;; double-double-hi, double-double-lo, and %double-double-float to
+;;; work.  For some reason, the cross-compile makes these known
+;;; functions be infinite loops, but if we compile them here and setf
+;;; fdefinition we get workingness.  
+(defun %foo (x y)
+  (declare (double-float x y))
+  (kernel:%make-double-double-float x y))
+(compile '%foo)
+
+
+
+(defun foo-hi (x)
+  (declare (type kernel:double-double-float x))
+  (kernel:double-double-hi x))
+(compile 'foo-hi)
+(defun foo-lo (x)
+  (declare (type kernel:double-double-float x))
+  (kernel:double-double-lo x))
+(compile 'foo-lo)
+(defun %coerce-foo (x)
+  (if (typep x 'kernel:double-double-float)
+      x
+      (kernel:make-double-double-float (float x 1d0) 0d0)))
+(compile '%foo)
+
+(setf (fdefinition 'kernel::%make-double-double-float) #'%foo)
+(setf (fdefinition 'kernel::double-double-hi) #'foo-hi)
+(setf (fdefinition 'kernel::double-double-lo) #'foo-lo)
+(setf (fdefinition 'kernel::%double-double-float) #'%coerce-foo)
+
+(in-package "KERNEL")
+(defun make-double-double-float (hi lo)
+  ;; Make sure the parts make sense for a double-double
+  (if (or (float-infinity-p hi) (float-nan-p hi))
+      (%make-double-double-float hi lo)
+      (multiple-value-bind (s e)
+	  (c::two-sum hi lo)
+	(%make-double-double-float s e))))
diff --git a/bootfiles/19c/boot-2006-06-2-cross-dd-ppc.lisp b/bootfiles/19c/boot-2006-06-2-cross-dd-ppc.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..ee31b24d530c79ebafcb66f2ce3f0ff244f5b782
--- /dev/null
+++ b/bootfiles/19c/boot-2006-06-2-cross-dd-ppc.lisp
@@ -0,0 +1,277 @@
+;;;
+;;; Cross-compile script to add (simple-array double-double-float (*)).
+;;;
+;;; Use the standard cross-build-world.sh with this file to
+;;; cross-compile.  For this to work, you need a binary that already
+;;; has double-double-float support, including reader support.  (A
+;;; build from the double-double-reader-branch will do nicely.)  Then
+;;; do a normal full build using the cross-compiled build to get a
+;;; binary with support for 1D simple arrays of double-double-float.
+
+(in-package :cl-user)
+
+;;; Rename the PPC package and backend so that new-backend does the
+;;; right thing.
+(rename-package "PPC" "OLD-PPC")
+(setf (c:backend-name c:*native-backend*) "OLD-PPC")
+
+(c::new-backend "PPC"
+   ;; Features to add here
+   '(:ppc
+     :new-assembler
+     :conservative-float-type
+     :hash-new
+     :random-mt19937
+     :darwin :bsd
+     :cmu :cmu19 :cmu19c
+     :relative-package-names		; Relative package names from Allegro
+     :linkage-table
+     :modular-arith
+     :double-double			; Double-double float support
+     :gencgc				; Generational gc
+     )
+   ;; Features to remove from current *features* here
+   '(:x86-bootstrap :alpha :osf1 :mips :x86 :i486 :pentium :ppro
+     :propagate-fun-type :propagate-float-type :constrain-float-type
+     :openbsd :freebsd :glibc2 :linux :pentium :elf :mp
+     :stack-checking :heap-overflow-check
+     :cgc :long-float :new-random :small))
+
+;;; Extern-alien-name for the new backend.
+(in-package :vm)
+(defun extern-alien-name (name)
+  (declare (type simple-string name))
+  (concatenate 'string "_" name))
+(export 'extern-alien-name)
+(export 'fixup-code-object)
+(export 'sanctify-for-execution)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Things needed to cross-compile double-double changes.
+(in-package "C")
+
+(eval-when (compile load eval)
+(defknown simple-array-double-double-float-p (t)
+  boolean
+  (movable foldable flushable))
+(defknown complex-double-double-float-p (t)
+  boolean
+  (movable foldable flushable))
+(defknown simple-array-complex-double-double-float-p (t)
+  boolean
+  (movable foldable flushable))
+)
+
+(in-package "LISP")
+(define-fop (fop-double-double-float-vector 88)
+  (let* ((length (read-arg 4))
+	 (result (make-array length :element-type 'double-double-float)))
+    (read-n-bytes *fasl-file* result 0 (* length 4 4))
+    result))
+
+(define-fop (fop-complex-double-double-float 89)
+  (prepare-for-fast-read-byte *fasl-file*
+    (prog1
+	(let* ((real-hi-lo (fast-read-u-integer 4))
+	       (real-hi-hi (fast-read-s-integer 4))
+	       (real-lo-lo (fast-read-u-integer 4))
+	       (real-lo-hi (fast-read-s-integer 4))
+	       (re (kernel::make-double-double-float
+		    (make-double-float real-hi-hi real-hi-lo)
+		    (make-double-float real-lo-hi real-lo-lo)))
+	       (imag-hi-lo (fast-read-u-integer 4))
+	       (imag-hi-hi (fast-read-s-integer 4))
+	       (imag-lo-lo (fast-read-u-integer 4))
+	       (imag-lo-hi (fast-read-s-integer 4))
+	       (im (kernel::make-double-double-float
+		    (make-double-float imag-hi-hi imag-hi-lo)
+		    (make-double-float imag-lo-hi imag-lo-lo))))
+	  (complex re im)) 
+      (done-with-fast-read-byte))))
+
+(define-fop (fop-complex-double-double-float-vector 90)
+  (let* ((length (read-arg 4))
+	 (result (make-array length :element-type '(complex double-double-float))))
+    (read-n-bytes *fasl-file* result 0 (* length 4 8))
+    result))
+
+
+;; End changes for double-double
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(in-package "CL-USER")
+
+;;; Compile the new backend.
+(pushnew :bootstrap *features*)
+(pushnew :building-cross-compiler *features*)
+(load "target:tools/comcom")
+
+;;; Load the new backend.
+(setf (search-list "c:")
+      '("target:compiler/"))
+(setf (search-list "vm:")
+      '("c:ppc/" "c:generic/"))
+(setf (search-list "assem:")
+      '("target:assembly/" "target:assembly/ppc/"))
+
+;; Load the backend of the compiler.
+
+(in-package "C")
+
+(load "vm:vm-macs")
+(load "vm:parms")
+(load "vm:objdef")
+(load "vm:interr")
+(load "assem:support")
+
+(load "target:compiler/srctran")
+(load "vm:vm-typetran")
+(load "target:compiler/float-tran")
+(load "target:compiler/saptran")
+
+(load "vm:macros")
+(load "vm:utils")
+
+(load "vm:vm")
+(load "vm:insts")
+(load "vm:primtype")
+(load "vm:move")
+(load "vm:sap")
+(load "vm:system")
+(load "vm:char")
+(load "vm:float")
+
+(load "vm:memory")
+(load "vm:static-fn")
+(load "vm:arith")
+(load "vm:cell")
+(load "vm:subprim")
+(load "vm:debug")
+(load "vm:c-call")
+(load "vm:print")
+(load "vm:alloc")
+(load "vm:call")
+(load "vm:nlx")
+(load "vm:values")
+(load "vm:array")
+(load "vm:pred")
+(load "vm:type-vops")
+
+(load "assem:assem-rtns")
+
+(load "assem:array")
+(load "assem:arith")
+(load "assem:alloc")
+
+(load "c:pseudo-vops")
+
+(check-move-function-consistency)
+
+(load "vm:new-genesis")
+
+;;; OK, the cross compiler backend is loaded.
+
+(setf *features* (remove :building-cross-compiler *features*))
+
+;;; Info environment hacks.
+(macrolet ((frob (&rest syms)
+	     `(progn ,@(mapcar #'(lambda (sym)
+				   `(handler-bind ((error #'(lambda (c)
+							      (declare (ignore c))
+							      (invoke-restart 'kernel::continue))))
+				     (defconstant ,sym
+				       (symbol-value
+					(find-symbol ,(symbol-name sym)
+						     :vm)))))
+			       syms))))
+  (frob OLD-PPC:BYTE-BITS OLD-PPC:WORD-BITS
+	#+long-float OLD-PPC:SIMPLE-ARRAY-LONG-FLOAT-TYPE 
+	OLD-PPC:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE 
+	OLD-PPC:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE
+	#+long-float OLD-PPC:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE 
+	OLD-PPC:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE 
+	OLD-PPC:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE
+	OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE 
+	OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE
+	OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE 
+	OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE 
+	OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE 
+	OLD-PPC:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE 
+	OLD-PPC:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE
+	OLD-PPC:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE 
+	OLD-PPC:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE
+	OLD-PPC:SIMPLE-BIT-VECTOR-TYPE
+	OLD-PPC:SIMPLE-STRING-TYPE OLD-PPC:SIMPLE-VECTOR-TYPE 
+	OLD-PPC:SIMPLE-ARRAY-TYPE OLD-PPC:VECTOR-DATA-OFFSET
+	OLD-PPC:DOUBLE-FLOAT-EXPONENT-BYTE
+	OLD-PPC:DOUBLE-FLOAT-NORMAL-EXPONENT-MAX 
+	OLD-PPC:DOUBLE-FLOAT-SIGNIFICAND-BYTE
+	OLD-PPC:SINGLE-FLOAT-EXPONENT-BYTE
+	OLD-PPC:SINGLE-FLOAT-NORMAL-EXPONENT-MAX
+	OLD-PPC:SINGLE-FLOAT-SIGNIFICAND-BYTE
+	))
+
+;; Modular arith hacks
+(setf (fdefinition 'vm::ash-left-mod32) #'old-ppc::ash-left-mod32)
+(setf (fdefinition 'vm::lognot-mod32) #'old-ppc::lognot-mod32)
+
+(let ((function (symbol-function 'kernel:error-number-or-lose)))
+  (let ((*info-environment* (c:backend-info-environment c:*target-backend*)))
+    (setf (symbol-function 'kernel:error-number-or-lose) function)
+    (setf (info function kind 'kernel:error-number-or-lose) :function)
+    (setf (info function where-from 'kernel:error-number-or-lose) :defined)))
+
+(defun fix-class (name)
+  (let* ((new-value (find-class name))
+	 (new-layout (kernel::%class-layout new-value))
+	 (new-cell (kernel::find-class-cell name))
+	 (*info-environment* (c:backend-info-environment c:*target-backend*)))
+    (remhash name kernel::*forward-referenced-layouts*)
+    (kernel::%note-type-defined name)
+    (setf (info type kind name) :instance)
+    (setf (info type class name) new-cell)
+    (setf (info type compiler-layout name) new-layout)
+    new-value))
+(fix-class 'c::vop-parse)
+(fix-class 'c::operand-parse)
+
+#+random-mt19937
+(declaim (notinline kernel:random-chunk))
+
+(setf c:*backend* c:*target-backend*)
+
+;;; Extern-alien-name for the new backend.
+(in-package :vm)
+(defun extern-alien-name (name)
+  (declare (type simple-string name))
+  (concatenate 'string "_" name))
+(export 'extern-alien-name)
+(export 'fixup-code-object)
+(export 'sanctify-for-execution)
+
+(in-package :cl-user)
+
+;;; Don't load compiler parts from the target compilation
+
+(defparameter *load-stuff* nil)
+
+;; hack, hack, hack: Make old-x86::any-reg the same as
+;; x86::any-reg as an SC.  Do this by adding old-x86::any-reg
+;; to the hash table with the same value as x86::any-reg.
+     
+(let ((ht (c::backend-sc-names c::*target-backend*)))
+  (setf (gethash 'old-ppc::any-reg ht)
+	(gethash 'ppc::any-reg ht)))
+
+;; A hack for ppc.  Make sure the vop, move-double-to-int-arg, is
+;; available in both the OLD-PPC and new PPC package.  (I don't know
+;; why this is needed, but it seems to be.)
+(let ((ht (c::backend-template-names c::*target-backend*)))
+  (dolist (syms '((old-ppc::move-double-to-int-arg
+		   ppc::move-double-to-int-arg)
+		  (old-ppc::move-single-to-int-arg
+		   ppc::move-single-to-int-arg)))
+    (destructuring-bind (old new)
+	syms
+      (setf (gethash old
+		     ht)
+	    (gethash new ht)))))
diff --git a/bootfiles/19c/boot-2006-06-2-cross-dd-sparc.lisp b/bootfiles/19c/boot-2006-06-2-cross-dd-sparc.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..7280567834dc11cb40272db8994d910a7371e183
--- /dev/null
+++ b/bootfiles/19c/boot-2006-06-2-cross-dd-sparc.lisp
@@ -0,0 +1,307 @@
+;;;; This is the cross-compile script for adding the (complex
+;;;; double-double-float), (simple-array double-double-float (*)), and
+;;;; (simple-array (complex double-double-float) (*)) types for sparc.
+;;;;
+;;;; Use the standard src/tools/cross-build-world.sh script with this
+;;;; cross-compile script to generate a double-double-float build.
+;;;; Something like
+;;;;
+;;;;   src/tools/cross-build-world.sh xtarget xcross <this-file> <dd-reader>
+;;;;
+;;;; I think this has to be built using a version that has reader
+;;;; support for double-double-float.  I didn't try it any othe way.
+;;;;
+;;;; Once that has been done, you still need to do a full set of
+;;;; builds to get these new types completely integrated in.  Don't
+;;;; need any special bootstrap files for this, so
+;;;;
+;;;;   src/tools/build.sh -C "sun4_solaris_sunc" -o "xtarget/lisp/lisp -noinit"
+;;;;
+
+(in-package :cl-user)
+
+;;; Rename the SPARC package and backend so that new-backend does the
+;;; right thing.
+(rename-package "SPARC" "OLD-SPARC")
+(setf (c:backend-name c:*native-backend*) "OLD-SPARC")
+
+(c::new-backend "SPARC"
+   ;; Features to add here
+   '(:sparc
+     :sparc-v9				; For Ultrasparc processors
+     :complex-fp-vops			; Some slightly faster FP vops on complex numbers
+     :linkage-table
+     :stack-checking			; Throw error if we run out of stack
+     :heap-overflow-check		; Throw error if we run out of heap
+     :gencgc				; Generational GC
+     :relative-package-names		; Relative package names from Allegro
+     :conservative-float-type
+     :hash-new
+     :random-mt19937			; MT-19937 generator
+     :cmu				; Announce this is CMUCL
+     :cmu19 :cmu19c			; Current version identifier
+     :modular-arith			; Modular arithmetic
+     :double-double			; Add double-double-float support.
+     )
+   ;; Features to remove from current *features* here
+   '(:sparc-v8 :sparc-v7		; Choose only one of :sparc-v7, :sparc-v8, :sparc-v9
+     ;; Other architectures we aren't using.
+     :x86 :x86-bootstrap
+     :alpha :osf1 :mips
+     ;; Really old stuff that should have been removed long ago.
+     :propagate-fun-type :propagate-float-type :constrain-float-type
+     ;; Other OSes were not using
+     :openbsd :freebsd :glibc2 :linux
+     :pentium
+     :long-float
+     :new-random
+     :small))
+
+;;; May need to add some symbols to *features* and
+;;; sys::*runtime-features* as well.  This might be needed even if we
+;;; have those listed above, because of the code checks for things in
+;;; *features* and not in the backend-features..  So do that here.
+
+
+;;; Extern-alien-name for the new backend.
+(in-package :vm)
+(defun extern-alien-name (name)
+  (declare (type simple-string name))
+  #+(and bsd (not elf))
+  (concatenate 'string "_" name)
+  #-(and bsd (not elf))
+  name)
+;; When compiling the compiler, vm:fixup-code-object and
+;; vm:sanctify-for-execution are undefined.  Import these to get rid
+;; of that error.
+(import 'old-sparc::fixup-code-object)
+(import 'old-sparc::sanctify-for-execution)
+(export 'extern-alien-name)
+(export 'fixup-code-object)
+(export 'sanctify-for-execution)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Things needed to cross-compile double-double changes.
+(in-package "C")
+(pushnew :double-double *features*)
+(defknown simple-array-double-double-float-p (t)
+  boolean
+  (movable foldable flushable))
+
+(defknown complex-double-double-float-p (t)
+  boolean
+  (movable foldable flushable))
+
+(defknown simple-array-complex-double-double-float-p (t)
+  boolean
+  (movable foldable flushable))
+
+(in-package "LISP")
+#+double-double
+(define-fop (fop-double-double-float-vector 88)
+  (let* ((length (read-arg 4))
+	 (result (make-array length :element-type 'double-double-float)))
+    (read-n-bytes *fasl-file* result 0 (* length 4 4))
+    result))
+
+#+double-double
+(define-fop (fop-complex-double-double-float 89)
+  (prepare-for-fast-read-byte *fasl-file*
+    (prog1
+	(let* ((real-hi-lo (fast-read-u-integer 4))
+	       (real-hi-hi (fast-read-s-integer 4))
+	       (real-lo-lo (fast-read-u-integer 4))
+	       (real-lo-hi (fast-read-s-integer 4))
+	       (re (kernel::make-double-double-float
+		    (make-double-float real-hi-hi real-hi-lo)
+		    (make-double-float real-lo-hi real-lo-lo)))
+	       (imag-hi-lo (fast-read-u-integer 4))
+	       (imag-hi-hi (fast-read-s-integer 4))
+	       (imag-lo-lo (fast-read-u-integer 4))
+	       (imag-lo-hi (fast-read-s-integer 4))
+	       (im (kernel::make-double-double-float
+		    (make-double-float imag-hi-hi imag-hi-lo)
+		    (make-double-float imag-lo-hi imag-lo-lo))))
+	  (complex re im)) 
+      (done-with-fast-read-byte))))
+
+#+double-double
+(define-fop (fop-complex-double-double-float-vector 90)
+  (let* ((length (read-arg 4))
+	 (result (make-array length :element-type '(complex double-double-float))))
+    (read-n-bytes *fasl-file* result 0 (* length 4 8))
+    result))
+
+;; End changes for double-double
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(in-package :cl-user)
+
+;;; Compile the new backend.
+(pushnew :bootstrap *features*)
+(pushnew :building-cross-compiler *features*)
+(load "target:tools/comcom")
+
+;;; Load the new backend.
+(setf (search-list "c:")
+      '("target:compiler/"))
+(setf (search-list "vm:")
+      '("c:sparc/" "c:generic/"))
+(setf (search-list "assem:")
+      '("target:assembly/" "target:assembly/sparc/"))
+
+;; Load the backend of the compiler.
+
+(in-package "C")
+
+(load "vm:vm-macs")
+(load "vm:parms")
+(load "vm:objdef")
+(load "vm:interr")
+(load "assem:support")
+
+(load "target:compiler/srctran")
+(load "vm:vm-typetran")
+(load "target:compiler/float-tran")
+(load "target:compiler/saptran")
+
+(load "vm:macros")
+(load "vm:utils")
+
+(load "vm:vm")
+(load "vm:insts")
+(load "vm:primtype")
+(load "vm:move")
+(load "vm:sap")
+(load "vm:system")
+(load "vm:char")
+(load "vm:float")
+
+(load "vm:memory")
+(load "vm:static-fn")
+(load "vm:arith")
+(load "vm:cell")
+(load "vm:subprim")
+(load "vm:debug")
+(load "vm:c-call")
+(load "vm:print")
+(load "vm:alloc")
+(load "vm:call")
+(load "vm:nlx")
+(load "vm:values")
+(load "vm:array")
+(load "vm:pred")
+(load "vm:type-vops")
+
+(load "assem:assem-rtns")
+
+(load "assem:array")
+(load "assem:arith")
+(load "assem:alloc")
+
+(load "c:pseudo-vops")
+
+(check-move-function-consistency)
+
+(load "vm:new-genesis")
+
+;;; OK, the cross compiler backend is loaded.
+
+(setf *features* (remove :building-cross-compiler *features*))
+
+;;; Info environment hacks.
+(macrolet ((frob (&rest syms)
+	     `(progn ,@(mapcar #'(lambda (sym)
+				   `(handler-bind ((error #'(lambda (c)
+							      (declare (ignore c))
+							      (invoke-restart 'kernel::continue))))
+				      (defconstant ,sym
+					(symbol-value
+					 (find-symbol ,(symbol-name sym)
+						      :vm)))))
+			       syms))))
+  (frob OLD-SPARC:BYTE-BITS OLD-SPARC:WORD-BITS
+	OLD-SPARC:LOWTAG-BITS
+	#+long-float OLD-SPARC:SIMPLE-ARRAY-LONG-FLOAT-TYPE 
+	OLD-SPARC:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE 
+	OLD-SPARC:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE
+	#+long-float OLD-SPARC:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE
+	#+double-double OLD-SPARC:SIMPLE-ARRAY-DOUBLE-DOUBLE-FLOAT-TYPE
+	OLD-SPARC:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE 
+	OLD-SPARC:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE
+	OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE 
+	OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE
+	OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE 
+	OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE 
+	OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE 
+	OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE 
+	OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE
+	OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE 
+	OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE
+	OLD-SPARC:SIMPLE-BIT-VECTOR-TYPE
+	OLD-SPARC:SIMPLE-STRING-TYPE OLD-SPARC:SIMPLE-VECTOR-TYPE 
+	OLD-SPARC:SIMPLE-ARRAY-TYPE OLD-SPARC:VECTOR-DATA-OFFSET
+	OLD-SPARC:DOUBLE-FLOAT-DIGITS
+	old-sparc:single-float-digits
+	OLD-SPARC:DOUBLE-FLOAT-EXPONENT-BYTE
+	OLD-SPARC:DOUBLE-FLOAT-NORMAL-EXPONENT-MAX
+	OLD-SPARC:DOUBLE-FLOAT-SIGNIFICAND-BYTE
+	OLD-SPARC:SINGLE-FLOAT-EXPONENT-BYTE
+	OLD-SPARC:SINGLE-FLOAT-NORMAL-EXPONENT-MAX
+	OLD-SPARC:SINGLE-FLOAT-SIGNIFICAND-BYTE
+	))
+
+;; Modular arith hacks
+(setf (fdefinition 'vm::ash-left-mod32) #'old-sparc::ash-left-mod32)
+(setf (fdefinition 'vm::lognot-mod32) #'old-sparc::lognot-mod32)
+
+(let ((function (symbol-function 'kernel:error-number-or-lose)))
+  (let ((*info-environment* (c:backend-info-environment c:*target-backend*)))
+    (setf (symbol-function 'kernel:error-number-or-lose) function)
+    (setf (info function kind 'kernel:error-number-or-lose) :function)
+    (setf (info function where-from 'kernel:error-number-or-lose) :defined)))
+
+(defun fix-class (name)
+  (let* ((new-value (find-class name))
+	 (new-layout (kernel::%class-layout new-value))
+	 (new-cell (kernel::find-class-cell name))
+	 (*info-environment* (c:backend-info-environment c:*target-backend*)))
+    (remhash name kernel::*forward-referenced-layouts*)
+    (kernel::%note-type-defined name)
+    (setf (info type kind name) :instance)
+    (setf (info type class name) new-cell)
+    (setf (info type compiler-layout name) new-layout)
+    new-value))
+(fix-class 'c::vop-parse)
+(fix-class 'c::operand-parse)
+
+#+random-mt19937
+(declaim (notinline kernel:random-chunk))
+
+(setf c:*backend* c:*target-backend*)
+
+;;; Extern-alien-name for the new backend.
+(in-package :vm)
+(defun extern-alien-name (name)
+  (declare (type simple-string name))
+  #+(and bsd (not elf))
+  (concatenate 'string "_" name)
+  #-(and bsd (not elf))
+  name)
+(export 'extern-alien-name)
+(export 'fixup-code-object)
+(export 'sanctify-for-execution)
+(in-package :cl-user)
+
+;;; Don't load compiler parts from the target compilation
+
+(defparameter *load-stuff* nil)
+
+;; Sometimes during cross-compile sparc::any-reg isn't defined during
+;; cross-compile.
+;;
+;; hack, hack, hack: Make old-sparc::any-reg the same as
+;; sparc::any-reg as an SC.  Do this by adding old-sparc::any-reg
+;; to the hash table with the same value as sparc::any-reg.
+(let ((ht (c::backend-sc-names c::*target-backend*)))
+  (setf (gethash 'old-sparc::any-reg ht)
+	(gethash 'sparc::any-reg ht)))
diff --git a/bootfiles/19c/boot-2006-06-2-cross-dd-x86.lisp b/bootfiles/19c/boot-2006-06-2-cross-dd-x86.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..faf219bea2d3cf56610be85c9293e9d4d80f904a
--- /dev/null
+++ b/bootfiles/19c/boot-2006-06-2-cross-dd-x86.lisp
@@ -0,0 +1,254 @@
+;;; Cross-compile script for adding (complex double-double-float),
+;;; (simple-array double-double-float (*)) and (simple-array (complex
+;;; double-double-float) (*)).
+;;;
+;;; Use this to cross-compile from a version that supports
+;;; double-double-float type with reader support.  Once this is done,
+;;; do a full rebuild to get a version with support for these new
+;;; types.
+
+(in-package :cl-user)
+
+;;; Rename the X86 package and backend so that new-backend does the
+;;; right thing.
+(rename-package "X86" "OLD-X86")
+(setf (c:backend-name c:*native-backend*) "OLD-X86")
+
+(c::new-backend "X86"
+   ;; Features to add here
+   '(:x86 :i486 :pentium
+     :stack-checking
+     :heap-overflow-check
+     :relative-package-names
+     :mp
+     :gencgc
+     :conservative-float-type
+     :hash-new :random-mt19937
+     :linux :glibc2 :glibc2.1
+     :cmu :cmu19 :cmu19c
+     :double-double			; double-double-float
+     )
+   ;; Features to remove from current *features* here
+   '(:x86-bootstrap :alpha :osf1 :mips
+     :propagate-fun-type :propagate-float-type :constrain-float-type
+     :openbsd :freebsd :glibc2 :linux
+     :long-float :new-random :small))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Things needed to cross-compile double-double changes.
+(in-package "C")
+
+(eval-when (compile load eval)
+(defknown simple-array-double-double-float-p (t)
+  boolean
+  (movable foldable flushable))
+(defknown double-double-float-p (t)
+  boolean
+  (movable foldable flushable))
+(defknown complex-double-double-float-p (t)
+  boolean
+  (movable foldable flushable))
+(defknown simple-array-complex-double-double-float-p (t)
+  boolean
+  (movable foldable flushable))
+)
+
+(in-package "LISP")
+(define-fop (fop-double-double-float-vector 88)
+  (let* ((length (read-arg 4))
+	 (result (make-array length :element-type 'double-double-float)))
+    (read-n-bytes *fasl-file* result 0 (* length 4 4))
+    result))
+
+(define-fop (fop-complex-double-double-float 89)
+  (prepare-for-fast-read-byte *fasl-file*
+    (prog1
+	(let* ((real-hi-lo (fast-read-u-integer 4))
+	       (real-hi-hi (fast-read-s-integer 4))
+	       (real-lo-lo (fast-read-u-integer 4))
+	       (real-lo-hi (fast-read-s-integer 4))
+	       (re (kernel::make-double-double-float
+		    (make-double-float real-hi-hi real-hi-lo)
+		    (make-double-float real-lo-hi real-lo-lo)))
+	       (imag-hi-lo (fast-read-u-integer 4))
+	       (imag-hi-hi (fast-read-s-integer 4))
+	       (imag-lo-lo (fast-read-u-integer 4))
+	       (imag-lo-hi (fast-read-s-integer 4))
+	       (im (kernel::make-double-double-float
+		    (make-double-float imag-hi-hi imag-hi-lo)
+		    (make-double-float imag-lo-hi imag-lo-lo))))
+	  (complex re im)) 
+      (done-with-fast-read-byte))))
+
+(define-fop (fop-complex-double-double-float-vector 90)
+  (let* ((length (read-arg 4))
+	 (result (make-array length :element-type '(complex double-double-float))))
+    (read-n-bytes *fasl-file* result 0 (* length 4 8))
+    result))
+
+;; End changes for double-double
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(in-package :cl-user)
+
+;;; Compile the new backend.
+(pushnew :bootstrap *features*)
+(pushnew :building-cross-compiler *features*)
+(load "target:tools/comcom")
+
+;;; Load the new backend.
+(setf (search-list "c:")
+      '("target:compiler/"))
+(setf (search-list "vm:")
+      '("c:x86/" "c:generic/"))
+(setf (search-list "assem:")
+      '("target:assembly/" "target:assembly/x86/"))
+
+;; Load the backend of the compiler.
+
+(in-package "C")
+
+(load "vm:vm-macs")
+(load "vm:parms")
+(load "vm:objdef")
+(load "vm:interr")
+(load "assem:support")
+
+(load "target:compiler/srctran")
+(load "vm:vm-typetran")
+(load "target:compiler/float-tran")
+(load "target:compiler/saptran")
+
+(load "vm:macros")
+(load "vm:utils")
+
+(load "vm:vm")
+(load "vm:insts")
+(load "vm:primtype")
+(load "vm:move")
+(load "vm:sap")
+(load "vm:system")
+(load "vm:char")
+(load "vm:float")
+
+(load "vm:memory")
+(load "vm:static-fn")
+(load "vm:arith")
+(load "vm:cell")
+(load "vm:subprim")
+(load "vm:debug")
+(load "vm:c-call")
+(load "vm:print")
+(load "vm:alloc")
+(load "vm:call")
+(load "vm:nlx")
+(load "vm:values")
+(load "vm:array")
+(load "vm:pred")
+(load "vm:type-vops")
+
+(load "assem:assem-rtns")
+
+(load "assem:array")
+(load "assem:arith")
+(load "assem:alloc")
+
+(load "c:pseudo-vops")
+
+(check-move-function-consistency)
+
+(load "vm:new-genesis")
+
+;;; OK, the cross compiler backend is loaded.
+
+(setf *features* (remove :building-cross-compiler *features*))
+
+;;; Info environment hacks.
+(macrolet ((frob (&rest syms)
+	     `(progn ,@(mapcar #'(lambda (sym)
+				   `(handler-bind ((error #'(lambda (c)
+							      (declare (ignore c))
+							      (invoke-restart 'kernel::continue))))
+				      (defconstant ,sym
+					(symbol-value
+					 (find-symbol ,(symbol-name sym)
+						      :vm)))))
+			       syms))))
+  (frob OLD-X86:BYTE-BITS OLD-X86:WORD-BITS
+	#+long-float OLD-X86:SIMPLE-ARRAY-LONG-FLOAT-TYPE 
+	OLD-X86:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE 
+	OLD-X86:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE
+	#+long-float OLD-X86:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE 
+	OLD-X86:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE 
+	OLD-X86:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE
+	OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE 
+	OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE
+	OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE 
+	OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE 
+	OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE 
+	OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE 
+	OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE
+	OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE 
+	OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE
+	OLD-X86:SIMPLE-BIT-VECTOR-TYPE
+	OLD-X86:SIMPLE-STRING-TYPE OLD-X86:SIMPLE-VECTOR-TYPE 
+	OLD-X86:SIMPLE-ARRAY-TYPE OLD-X86:VECTOR-DATA-OFFSET
+	OLD-X86:DOUBLE-FLOAT-EXPONENT-BYTE
+	OLD-X86:DOUBLE-FLOAT-NORMAL-EXPONENT-MAX 
+	OLD-X86:DOUBLE-FLOAT-SIGNIFICAND-BYTE
+	OLD-X86:SINGLE-FLOAT-EXPONENT-BYTE
+	OLD-X86:SINGLE-FLOAT-NORMAL-EXPONENT-MAX
+	OLD-X86:SINGLE-FLOAT-SIGNIFICAND-BYTE
+	))
+
+;; Modular arith hacks
+(setf (fdefinition 'vm::ash-left-mod32) #'old-x86::ash-left-mod32)
+(setf (fdefinition 'vm::lognot-mod32) #'old-x86::lognot-mod32)
+
+(let ((function (symbol-function 'kernel:error-number-or-lose)))
+  (let ((*info-environment* (c:backend-info-environment c:*target-backend*)))
+    (setf (symbol-function 'kernel:error-number-or-lose) function)
+    (setf (info function kind 'kernel:error-number-or-lose) :function)
+    (setf (info function where-from 'kernel:error-number-or-lose) :defined)))
+
+(defun fix-class (name)
+  (let* ((new-value (find-class name))
+	 (new-layout (kernel::%class-layout new-value))
+	 (new-cell (kernel::find-class-cell name))
+	 (*info-environment* (c:backend-info-environment c:*target-backend*)))
+    (remhash name kernel::*forward-referenced-layouts*)
+    (kernel::%note-type-defined name)
+    (setf (info type kind name) :instance)
+    (setf (info type class name) new-cell)
+    (setf (info type compiler-layout name) new-layout)
+    new-value))
+(fix-class 'c::vop-parse)
+(fix-class 'c::operand-parse)
+
+#+random-mt19937
+(declaim (notinline kernel:random-chunk))
+
+(setf c:*backend* c:*target-backend*)
+
+;;; Extern-alien-name for the new backend.
+(in-package :vm)
+(defun extern-alien-name (name)
+  (declare (type simple-string name))
+  #+(and bsd (not elf))
+  (concatenate 'string "_" name)
+  #-(and bsd (not elf))
+  name)
+(export 'extern-alien-name)
+(export 'fixup-code-object)
+(export 'sanctify-for-execution)
+(in-package :cl-user)
+
+;;; Don't load compiler parts from the target compilation
+
+(defparameter *load-stuff* nil)
+
+;; hack, hack, hack: Make old-x86::any-reg the same as
+;; x86::any-reg as an SC.  Do this by adding old-x86::any-reg
+;; to the hash table with the same value as x86::any-reg.
+(let ((ht (c::backend-sc-names c::*target-backend*)))
+  (setf (gethash 'old-x86::any-reg ht)
+	(gethash 'x86::any-reg ht)))
diff --git a/code/array.lisp b/code/array.lisp
index 09077ad849a795dab55fab68c14f738cffcb231a..0ed77832899698f3ca92b4673b9fdd04399a61b2 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.39 2005/04/13 11:59:23 pwerkowski Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/array.lisp,v 1.40 2006/06/30 18:41:22 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -137,6 +137,9 @@
     #+long-float
     (long-float
      (values #.vm:simple-array-long-float-type #+x86 96 #+sparc 128))
+    #+double-double
+    (double-double-float
+     (values #.vm::simple-array-double-double-float-type 128))
     ((complex single-float)
      (values #.vm:simple-array-complex-single-float-type 64))
     ((complex double-float)
@@ -144,6 +147,9 @@
     #+long-float
     ((complex long-float)
      (values #.vm:simple-array-complex-long-float-type #+x86 192 #+sparc 256))
+    #+double-double
+    ((complex double-double-float)
+     (values #.vm::simple-array-complex-double-double-float-type 256))
     (t (values #.vm:simple-vector-type #.vm:word-bits))))
 
 (defun %complex-vector-type-code (type)
@@ -339,9 +345,11 @@
        single-float
        double-float
        #+long-float long-float
+       #+double-double double-double-float
        (complex single-float)
        (complex double-float)
-       #+long-float (complex long-float)))))
+       #+long-float (complex long-float)
+       #+double-double (complex double-double-float)))))
 
 (defun data-vector-set (array index new-value)
   (with-array-data ((vector array) (index index) (end))
@@ -372,9 +380,11 @@
        single-float
        double-float
        #+long-float long-float
+       #+double-double double-double-float
        (complex single-float)
        (complex double-float)
-       #+long-float (complex long-float)))))
+       #+long-float (complex long-float)
+       #+double-double (complex double-double-float)))))
 
 
 
@@ -535,10 +545,14 @@
        (vm:simple-array-double-float-type 'double-float)
        #+long-float
        (vm:simple-array-long-float-type 'long-float)
+       #+double-double
+       (vm::simple-array-double-double-float-type 'double-double-float)
        (vm:simple-array-complex-single-float-type '(complex single-float))
        (vm:simple-array-complex-double-float-type '(complex double-float))
        #+long-float
        (vm:simple-array-complex-long-float-type '(complex long-float))
+       #+double-double
+       (vm::simple-array-complex-double-double-float-type '(complex double-double-float))
        ((vm:simple-array-type vm:complex-vector-type vm:complex-array-type)
 	(with-array-data ((array array) (start) (end))
 	  (declare (ignore start end))
@@ -864,13 +878,19 @@
 	((simple-array double-float (*)) (coerce 0 'double-float))
 	#+long-float
 	((simple-array long-float (*)) (coerce 0 'long-float))
+	#+double-double
+	((simple-array double-double-float (*))
+	 (coerce 0 'double-double-float))
 	((simple-array (complex single-float) (*))
 	 (coerce 0 '(complex single-float)))
 	((simple-array (complex double-float) (*))
 	 (coerce 0 '(complex double-float)))
 	#+long-float
 	((simple-array (complex long-float) (*))
-	 (coerce 0 '(complex long-float))))))
+	 (coerce 0 '(complex long-float)))
+	#+double-double
+	((simple-array (complex double-double-float) (*))
+	 (coerce 0 '(complex double-double-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 4265486a135d69ec85c9095bded768ced39c4f6c..2519acc7a5ddc333d6e5188c4f356149541cd7f0 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.40 2004/08/31 00:19:41 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/bignum.lisp,v 1.41 2006/06/30 18:41:22 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1872,6 +1872,22 @@ down to individual words.")
    (%bignum-ref bits 2)
    (%bignum-ref bits 1)))
 
+;;;
+#+double-double
+(defun double-double-from-bits (bits exp plusp)
+  (declare (fixnum exp)
+	   (optimize (ext:inhibit-warnings 3)))
+  ;; Extract the 105 bits we want.  The low 52 goes to the low
+  ;; double-float, and the remaining bits go to the high double-float.
+  ;; That's a total of 4 words.
+  (let* ((bits (ash bits -32))
+	 (lo (ldb (byte vm:double-float-digits 0) bits))
+	 (hi (ldb (byte vm:double-float-digits vm:double-float-digits) bits))
+	 (exp (- exp vm:double-float-bias)))
+    (kernel:make-double-double-float
+     (scale-float (float hi 1d0) (+ exp 53 -106))
+     (scale-float (float lo 1d0) (- exp 106)))))
+    
 
 ;;; BIGNUM-TO-FLOAT   --  Interface
 ;;;
@@ -1918,6 +1934,13 @@ down to individual words.")
 		   bits
 		   (check-exponent len vm:long-float-bias
 		                   vm:long-float-normal-exponent-max)
+		   plusp))
+		 #+double-double
+		 (double-double-float
+		  (double-double-from-bits
+		   bits
+		   (check-exponent len vm:double-float-bias
+				   vm:double-float-normal-exponent-max)
 		   plusp))))
 	     (check-exponent (exp bias max)
 	       (declare (type bignum-index len))
diff --git a/code/byte-interp.lisp b/code/byte-interp.lisp
index ad8f58853230903472eb04a29b8ac10d524351a3..2c9d2b8b4f9a262e146835fd5b1b9da78aeaeeb0 100644
--- a/code/byte-interp.lisp
+++ b/code/byte-interp.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/byte-interp.lisp,v 1.44 2003/08/27 16:09:11 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/byte-interp.lisp,v 1.45 2006/06/30 18:41:22 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -408,7 +408,7 @@
 ;;;; Inlines.
 
 (eval-when (compile eval)
-  (setq ext:*inline-expansion-limit* 100))
+  (setq ext:*inline-expansion-limit* 400))
 
 (defmacro expand-into-inlines ()
   (declare (optimize (inhibit-warnings 3)))
diff --git a/code/class.lisp b/code/class.lisp
index 7c359b3fa0708187b33b9ce049a25be21090d57d..ea9e6fec875f5ed092a145fe8fc0d88ba099b604 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.58 2004/10/12 16:53:53 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/class.lisp,v 1.59 2006/06/30 18:41:22 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -773,6 +773,14 @@
 	   :inherits (vector simple-array array sequence generic-vector
 		      generic-array mutable-sequence mutable-collection
 		      generic-sequence collection))
+	  #+double-double
+	  (simple-array-double-double-float
+	   :translation (simple-array double-double-float (*))
+	   :codes (#.vm::simple-array-double-double-float-type)
+	   :direct-superclasses (vector simple-array)
+	   :inherits (vector simple-array array sequence generic-vector
+		      generic-array mutable-sequence mutable-collection
+		      generic-sequence collection))
 	  (simple-array-complex-single-float
 	   :translation (simple-array (complex single-float) (*))
 	   :codes (#.vm:simple-array-complex-single-float-type)
@@ -795,6 +803,14 @@
 	   :inherits (vector simple-array array sequence generic-vector
 		      generic-array mutable-sequence mutable-collection
 		      generic-sequence collection))
+	  #+double-double
+	  (simple-array-complex-double-double-float
+	   :translation (simple-array (complex double-double-float) (*))
+	   :codes (#.vm::simple-array-complex-double-double-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
@@ -829,6 +845,10 @@
 	   :translation (complex long-float)
 	   :inherits (complex number generic-number)
 	   :codes (#.vm:complex-long-float-type))
+	  #+double-double
+	  (complex-double-double-float
+	   :translation (complex double-double-float)
+	   :inherits (complex number generic-number))
 	  (real :translation real :inherits (number generic-number))
 	  (float :translation float :inherits (real number generic-number))
 	  (single-float
@@ -844,6 +864,11 @@
 	   :translation long-float
 	   :inherits (float real number generic-number)
 	   :codes (#.vm:long-float-type))
+	  #+double-double
+	  (double-double-float
+	   :translation double-double-float
+	   :inherits (float real number generic-number)
+	   :codes (#.vm::double-double-float-type))
 	  (rational
 	   :translation rational
 	   :inherits (real number generic-number))
diff --git a/code/debug-int.lisp b/code/debug-int.lisp
index 21dd47ecb82880bbbc301b4fa0a44b2558fcf5fd..40684cfcdbc23ec34469f60baf457d78894eb56b 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.122 2006/01/23 14:11:02 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.123 2006/06/30 18:41:22 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -3150,6 +3150,16 @@ The result is a symbol or nil if the routine cannot be found."
       #+long-float
       (#.vm:long-reg-sc-number
        (escaped-float-value long-float))
+      #+double-double
+      (#.vm:double-double-reg-sc-number
+       (if escaped
+	   (kernel:%make-double-double-float
+	    (vm:sigcontext-float-register
+	     escaped (c:sc-offset-offset sc-offset) 'double-float)
+	    (vm:sigcontext-float-register
+	     escaped (+ (c:sc-offset-offset sc-offset) #+sparc 2 #-sparc 1)
+	     'double-float))
+	   :invalid-value-for-unescaped-register-storage))
       (#.vm:complex-single-reg-sc-number
        (if escaped
 	   (complex
@@ -3177,6 +3187,24 @@ The result is a symbol or nil if the routine cannot be found."
 	     escaped (+ (c:sc-offset-offset sc-offset) #+sparc 4)
 	     'long-float))
 	   :invalid-value-for-unescaped-register-storage))
+      #+double-double
+      (#.vm:complex-double-double-reg-sc-number
+       (if escaped
+	   (complex
+	    (kernel:%make-double-double-float
+	     (vm:sigcontext-float-register
+	      escaped (c:sc-offset-offset sc-offset) 'double-float)
+	     (vm:sigcontext-float-register
+	      escaped (+ (c:sc-offset-offset sc-offset) #+sparc 2 #-sparc 1)
+	      'double-float))
+	    (kernel:%make-double-double-float
+	     (vm:sigcontext-float-register
+	      escaped (+ (c:sc-offset-offset sc-offset) #+sparc 4 #+sparc 1)
+	      'double-float)
+	     (vm:sigcontext-float-register
+	      escaped (+ (c:sc-offset-offset sc-offset) #+sparc 6 #-sparc 3)
+	      'double-float)))
+	   :invalid-value-for-unescaped-register-storage))
       (#.vm:single-stack-sc-number
        (with-nfp (nfp)
 	 (system:sap-ref-single nfp (* (c:sc-offset-offset sc-offset)
@@ -3190,6 +3218,15 @@ The result is a symbol or nil if the routine cannot be found."
        (with-nfp (nfp)
 	 (system:sap-ref-long nfp (* (c:sc-offset-offset sc-offset)
 				     vm:word-bytes))))
+      #+double-double
+      ((#.vm:double-double-stack-sc-number
+	(with-nfp (nfp)
+	  (kernel:%make-double-double-float
+	   (system:sap-ref-double nfp (* (c:sc-offset-offset sc-offset)
+					 vm:word-bytes))
+	   (system:sap-ref-double nfp (* (+ (c:sc-offset-offset sc-offset)
+					    2)
+					 vm:word-bytes))))))
       (#.vm:complex-single-stack-sc-number
        (with-nfp (nfp)
 	 (complex
@@ -3307,6 +3344,16 @@ The result is a symbol or nil if the routine cannot be found."
       #+long-float
       (#.vm:long-reg-sc-number
        (escaped-float-value long-float))
+      #+double-double
+      (#.vm:double-double-reg-sc-number
+       (if escaped
+	   (kernel:%make-double-double-float
+	    (vm:sigcontext-float-register
+	     escaped (c:sc-offset-offset sc-offset) 'double-float)
+	    (vm:sigcontext-float-register
+	     escaped (+ (c:sc-offset-offset sc-offset) 1)
+	     'double-float))
+	   :invalid-value-for-unescaped-register-storage))
       (#.vm:complex-single-reg-sc-number
        (escaped-complex-float-value single-float))
       (#.vm:complex-double-reg-sc-number
@@ -3324,6 +3371,24 @@ The result is a symbol or nil if the routine cannot be found."
       (#.vm:long-stack-sc-number
        (system:sap-ref-long fp (- (* (+ (c:sc-offset-offset sc-offset) 3)
 				     vm:word-bytes))))
+      #+double-double
+      (#.vm:complex-double-double-reg-sc-number
+       (if escaped
+	   (complex
+	    (kernel:%make-double-double-float
+	     (vm:sigcontext-float-register
+	      escaped (c:sc-offset-offset sc-offset) 'double-float)
+	     (vm:sigcontext-float-register
+	      escaped (+ (c:sc-offset-offset sc-offset) #+sparc 2 #-sparc 1)
+	      'double-float))
+	    (kernel:%make-double-double-float
+	     (vm:sigcontext-float-register
+	      escaped (+ (c:sc-offset-offset sc-offset) #+sparc 4 #+sparc 1)
+	      'double-float)
+	     (vm:sigcontext-float-register
+	      escaped (+ (c:sc-offset-offset sc-offset) #+sparc 6 #-sparc 3)
+	      'double-float)))
+	   :invalid-value-for-unescaped-register-storage))
       (#.vm:complex-single-stack-sc-number
        (complex
 	(system:sap-ref-single fp (- (* (1+ (c:sc-offset-offset sc-offset))
@@ -3343,6 +3408,15 @@ The result is a symbol or nil if the routine cannot be found."
 				      vm:word-bytes)))
 	(system:sap-ref-long fp (- (* (+ (c:sc-offset-offset sc-offset) 6)
 				      vm:word-bytes)))))
+      #+double-double
+      ((#.vm:double-double-stack-sc-number
+	(with-nfp (nfp)
+	  (kernel:%make-double-double-float
+	   (system:sap-ref-double nfp (* (c:sc-offset-offset sc-offset)
+					 vm:word-bytes))
+	   (system:sap-ref-double nfp (* (+ (c:sc-offset-offset sc-offset)
+					    2)
+					 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/exports.lisp b/code/exports.lisp
index f5538511f03698bf6c35b0ea20b7f59a24589a6f..11dc88423302004ee3b03386b944e1c26f272957 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.251 2006/02/07 01:16:27 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.252 2006/06/30 18:41:22 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -887,7 +887,9 @@
 (dolist
     (name
      '("%SP-SET-DEFINITION" "%SP-SET-PLIST" "ARRAY-HEADER-P" "BASE-CHAR-P"
-       "DOUBLE-FLOAT-P" "LONG-FLOAT-P" "SIMPLE-ARRAY-P" "SINGLE-FLOAT-P"))
+       "DOUBLE-FLOAT-P" "LONG-FLOAT-P" "SIMPLE-ARRAY-P" "SINGLE-FLOAT-P"
+       "DOUBLE-DOUBLE-FLOAT-P"
+       "DOUBLE-DOUBLE-FLOAT"))
   (intern name "KERNEL"))
 
 (defpackage #+pmax "PMAX"
@@ -1092,7 +1094,29 @@
   #+heap-overflow-check
   (:export "DYNAMIC-SPACE-OVERFLOW-ERROR-TRAP"
 	   "DYNAMIC-SPACE-OVERFLOW-WARNING-TRAP")
-  )
+  ;;#+double-double
+  (:export "DOUBLE-DOUBLE-FLOAT-TYPE"
+	   "DOUBLE-DOUBLE-FLOAT-HI-SLOT"
+	   "DOUBLE-DOUBLE-FLOAT-LO-SLOT"
+	   "DOUBLE-DOUBLE-FLOAT-FILLER-SLOT"
+	   "DOUBLE-DOUBLE-FLOAT-SIZE"
+	   "DOUBLE-DOUBLE-REG-SC-NUMBER"
+	   "DOUBLE-DOUBLE-STACK-SC-NUMBER"
+	   "DOUBLE-DOUBLE-FLOAT-DIGITS"
+	   "SIMPLE-ARRAY-DOUBLE-DOUBLE-FLOAT-TYPE"
+
+	   "COMPLEX-DOUBLE-DOUBLE-FLOAT-TYPE"
+	   "COMPLEX-DOUBLE-DOUBLE-FLOAT-FILLER-SLOT"
+	   "COMPLEX-DOUBLE-DOUBLE-FLOAT-REAL-HI-SLOT"
+	   "COMPLEX-DOUBLE-DOUBLE-FLOAT-REAL-LO-SLOT"
+	   "COMPLEX-DOUBLE-DOUBLE-FLOAT-IMAG-HI-SLOT"
+	   "COMPLEX-DOUBLE-DOUBLE-FLOAT-IMAG-LO-SLOT"
+	   "COMPLEX-DOUBLE-DOUBLE-FLOAT-SIZE"
+	   "COMPLEX-DOUBLE-DOUBLE-REG-SC-NUMBER"
+	   "COMPLEX-DOUBLE-DOUBLE-STACK-SC-NUMBER"
+
+	   "SIMPLE-ARRAY-COMPLEX-DOUBLE-DOUBLE-FLOAT-TYPE"
+	   ))
 
 (defpackage "CONDITIONS")
 (intern "DISASSEMBLE" "LISP")
@@ -1186,6 +1210,8 @@
   (:import-from "LISP" "GET-SETF-METHOD")
   (:import-from "KERNEL" "*ANSI-DEFSTRUCT-OPTIONS-P*")
   (:import-from "SYSTEM" "MAKE-INDENTING-STREAM" "INDENTING-STREAM-P"  "BINARY-TEXT-STREAM")
+  #+double-double
+  (:import-from "KERNEL" "DOUBLE-DOUBLE-FLOAT")
   (:export   "*AFTER-GC-HOOKS*" "*AFTER-SAVE-INITIALIZATIONS*"
 	     "DEBUG"
 	     "FLOATING-POINT-INEXACT" "FLOAT-ACCURACY"
@@ -1362,7 +1388,9 @@
 
 	     "BINARY-TEXT-STREAM" "READ-VECTOR" "WRITE-VECTOR"
 
-	     "INVALID-FASL"))
+	     "INVALID-FASL")
+  #+double-double
+  (:export "DOUBLE-DOUBLE-FLOAT"))
 
 (defpackage "STREAM"
   (:import-from "SYSTEM" "LISP-STREAM")
@@ -1739,7 +1767,8 @@
 (dolist
     (name
      '("*" "ARRAY" "BOOLEAN" "DOUBLE-FLOAT" "FUNCTION" "INTEGER" "LONG-FLOAT"
-       "SINGLE-FLOAT" "UNION" "VALUES"))
+       "SINGLE-FLOAT" "UNION" "VALUES"
+       ))
   (intern name "LISP"))
 
 (defpackage "ALIEN"
@@ -2158,7 +2187,23 @@
            "SET-SYMBOL-VALUE-CONDITIONAL"
            "ATOMIC-POP-SYMBOL-VALUE"
            "ATOMIC-PUSHA"
-           "ATOMIC-PUSHD"))
+           "ATOMIC-PUSHD")
+  ;;#+double-double
+  (:export "DOUBLE-DOUBLE-FLOAT"
+	   "DOUBLE-DOUBLE-FLOAT-P"
+	   "DOUBLE-DOUBLE-HI"
+	   "DOUBLE-DOUBLE-LO"
+	   "MAKE-DOUBLE-DOUBLE-FLOAT"
+	   "%MAKE-DOUBLE-DOUBLE-FLOAT"
+	   "%DOUBLE-DOUBLE-FLOAT"
+	   "OBJECT-NOT-DOUBLE-DOUBLE-FLOAT-ERROR"
+	   "SIMPLE-ARRAY-DOUBLE-DOUBLE-FLOAT-P"
+	   "OBJECT-NOT-SIMPLE-ARRAY-DOUBLE-DOUBLE-FLOAT-ERROR"
+	   "COMPLEX-DOUBLE-DOUBLE-FLOAT-P"
+	   "OBJECT-NOT-COMPLEX-DOUBLE-DOUBLE-FLOAT-ERROR"
+
+	   "SIMPLE-ARRAY-COMPLEX-DOUBLE-DOUBLE-FLOAT-P"
+	   "OBJECT-NOT-SIMPLE-ARRAY-COMPLEX-DOUBLE-DOUBLE-FLOAT-ERROR"))
 
 (dolist
     (name
diff --git a/code/float.lisp b/code/float.lisp
index cfae17915e136297beee38e499b5c041237e7cdd..bcc5bb6a942ba49c48bebcf80e9ba9451d84cd7f 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.31 2005/08/25 21:25:09 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/float.lisp,v 1.32 2006/06/30 18:41:22 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -80,6 +80,19 @@
 			  (dpb (ash sig -32) vm:double-float-significand-byte
 			       (if (zerop sign) 0 -1)))
 		     (ldb (byte 32 0) sig)))
+
+#+double-double
+(defun double-double-from-bits (sign exp sig)
+  (declare (type bit sign) (type (unsigned-byte #.vm:double-double-float-digits) sig)
+	   (type (unsigned-byte 11) exp))
+  (let ((lo (ldb (byte vm:double-float-digits 0) sig))
+	(hi (ldb (byte vm:double-float-digits vm:double-float-digits) sig)))
+    ;; We can't return a double-double because exp might be very
+    ;; small, and the low part of the double-double would get scaled
+    ;; to 0.  So we return both parts and expect the caller to figure
+    ;; out what to do.
+    (values (scale-float (float (* hi (- 1 (* 2 sign))) 1d0) #.(- vm:double-float-digits))
+	    (scale-float (float lo 1d0) #.(- vm:double-float-digits)))))
 ;;;
 #+(and long-float x86)
 (defun long-from-bits (sign exp sig)
@@ -240,7 +253,8 @@
      (and (zerop (ldb vm:long-float-exponent-byte (long-float-exp-bits x)))
 	  (not (zerop x))))))
 
-(macrolet ((frob (name doc single double #+(and long-float x86) long)
+(macrolet ((frob (name doc single double #+(and long-float x86) long
+		       #+double-double double-double)
 	     `(defun ,name (x)
 		,doc
 		(number-dispatch ((x float))
@@ -264,7 +278,10 @@
 		     (declare (ignorable lo))
 		     (and (> (ldb vm:long-float-exponent-byte exp)
 			     vm:long-float-normal-exponent-max)
-			  ,long)))))))
+			  ,long)))
+		  #+double-double
+		  ((double-double-float)
+		   ,double-double)))))
 
   (frob float-infinity-p "Return true if the float X is an infinity (+ or -)."
     (zerop (ldb vm:single-float-significand-byte bits))
@@ -272,7 +289,9 @@
 	 (zerop lo))
     #+(and long-float x86)
     (and (zerop (ldb vm:long-float-significand-byte hi))
-	 (zerop lo)))
+	 (zerop lo))
+    #+double-double
+    (float-infinity-p (double-double-hi x)))
 
   (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)))
@@ -280,7 +299,9 @@
 	(not (zerop lo)))
     #+(and long-float x86)
     (or (not (zerop (ldb vm:long-float-significand-byte hi)))
-	(not (zerop lo))))
+	(not (zerop lo)))
+    #+double-double
+    (float-nan-p (double-double-hi x)))
 
   (frob float-trapping-nan-p
     "Return true if the float X is a trapping NaN (Not a Number)."
@@ -290,7 +311,9 @@
 		   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))))
+		   vm:long-float-trapping-nan-bit))
+    #+double-double
+    (float-trapping-nan-p (double-double-hi x))))
 
 
 ;;; FLOAT-PRECISION  --  Public
@@ -335,7 +358,9 @@
 	   (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))))
+	   (long-float (minusp (long-float-exp-bits float1)))
+	   #+double-double
+	   (double-double-float (minusp (double-double-hi float1))))
 	 (float -1 float1)
 	 (float 1 float1))
      (abs float2)))
@@ -345,7 +370,9 @@
     ((short-float single-float) vm:single-float-digits)
     ((double-float #-long-float long-float) vm:double-float-digits)
     #+long-float
-    (long-float vm:long-float-digits)))
+    (long-float vm:long-float-digits)
+    #+double-double
+    (double-double-float vm:double-double-float-digits)))
 
 (declaim (inline float-digits float-radix))
 
@@ -357,7 +384,9 @@
     ((single-float) vm:single-float-digits)
     ((double-float) vm:double-float-digits)
     #+long-float
-    ((long-float) vm:long-float-digits)))
+    ((long-float) vm:long-float-digits)
+    #+double-double
+    ((double-double-float) vm:double-double-float-digits)))
 
 (defun float-radix (f)
   "Returns (as an integer) the radix b of its floating-point
@@ -515,6 +544,21 @@
 		  (truly-the fixnum (- biased extra-bias))
 		  sign)))))
 
+#+double-double
+(defun integer-decode-double-double-float (x)
+  (declare (type double-double-float x))
+  (multiple-value-bind (hi-int hi-exp sign)
+      (integer-decode-float (double-double-hi x))
+    (if (zerop (double-double-lo x))
+	(values (ash hi-int 53) (- hi-exp 53) sign)
+	(multiple-value-bind (lo-int lo-exp lo-sign)
+	    (integer-decode-float (double-double-lo x))
+	  ;; We have x = 2^e1*i1 + 2^e2*i2
+	  ;;           = 2^e2*(2^(e1-e2)*i1 + i2)
+	  (values (+ (* lo-sign lo-int)
+		     (ash hi-int (- hi-exp lo-exp)))
+		  lo-exp
+		  sign)))))
 
 ;;; INTEGER-DECODE-LONG-FLOAT  --  Internal
 ;;;
@@ -557,7 +601,10 @@
      (integer-decode-double-float x))
     #+long-float
     ((long-float)
-     (integer-decode-long-float x))))
+     (integer-decode-long-float x))
+    #+double-double
+    ((double-double-float)
+     (integer-decode-double-double-float x))))
 
 
 (declaim (maybe-inline decode-single-float decode-double-float))
@@ -685,6 +732,16 @@
 		    lo)
 		   biased sign)))))
 
+;;; DECODE-DOUBLE-DOUBLE-FLOAT -- Public
+#+double-double
+(defun decode-double-double-float (x)
+  (declare (type double-double-float x))
+  (multiple-value-bind (hi-frac hi-exp sign)
+      (decode-float (double-double-hi x))
+    (values (make-double-double-float hi-frac
+				      (scale-float (double-double-lo x) (- hi-exp)))
+	    hi-exp
+	    (coerce sign 'double-double-float))))
 
 ;;; DECODE-FLOAT  --  Public
 ;;;
@@ -703,7 +760,10 @@
      (decode-double-float f))
     #+long-float
     ((long-float)
-     (decode-long-float f))))
+     (decode-long-float f))
+    #+double-double
+    ((double-double-float)
+     (decode-double-double-float f))))
 
 
 ;;;; SCALE-FLOAT:
@@ -821,6 +881,14 @@
   (declare (long-float x) (fixnum exp))
   (scale-float x exp))
 
+#+double-double
+(defun scale-double-double-float (x exp)
+  (declare (type double-double-float x) (fixnum exp))
+  (let ((hi (double-double-hi x))
+	(lo (double-double-lo x)))
+    (make-double-double-float (scale-double-float hi exp)
+			      (scale-double-float lo exp))))
+
 ;;; SCALE-FLOAT  --  Public
 ;;;
 ;;;    Dispatch to the correct type-specific scale-float function.
@@ -835,7 +903,10 @@
      (scale-double-float f ex))
     #+long-float
     ((long-float)
-     (scale-long-float f ex))))
+     (scale-long-float f ex))
+    #+double-double
+    ((double-double-float)
+     (scale-double-double-float f ex))))
 
 
 ;;;; Converting to/from floats:
@@ -846,8 +917,10 @@
   result is the same float format as OTHER."
   (if otherp
       (number-dispatch ((number real) (other float))
-	(((foreach rational single-float double-float #+long-float long-float)
-	  (foreach single-float double-float #+long-float long-float))
+	(((foreach rational single-float double-float #+long-float long-float
+		   #+double-double double-double-float)
+	  (foreach single-float double-float #+long-float long-float
+		   #+double-double double-double-float))
 	 (coerce number '(dispatch-type other))))
       (if (floatp number)
 	  number
@@ -857,7 +930,9 @@
 (macrolet ((frob (name type)
 	     `(defun ,name (x)
 		(number-dispatch ((x real))
-		  (((foreach single-float double-float #+long-float long-float
+		  (((foreach single-float double-float
+			     #+long-float long-float
+			     #+double-double double-double-float
 			     fixnum))
 		   (coerce x ',type))
 		  ((bignum)
@@ -867,7 +942,9 @@
   (frob %single-float single-float)
   (frob %double-float double-float)
   #+long-float
-  (frob %long-float long-float))
+  (frob %long-float long-float)
+  #+(and nil double-double)
+  (frob %double-double-float double-double-float))
 
 
 ;;; FLOAT-RATIO  --  Internal
@@ -908,9 +985,32 @@
 			(len (integer-length bits)))
 		   (cond ((> len digits)
 			  (assert (= len (the fixnum (1+ digits))))
-			  (scale-float (floatit (ash bits -1)) (1+ scale)))
+			  (multiple-value-bind (f0 f1)
+			      (floatit (ash bits -1))
+			    #||
+			    (format t "1: f0, f1 = ~A ~A~%" f0 f1)
+			    (format t "   scale = ~A~%" (1+ scale))
+			    ||#
+			    (if f1
+				(make-double-double-float
+				 (scale-float f0 (1+ scale))
+				 (scale-float f1 (+ 1 scale #.(- vm:double-float-digits))))
+				(scale-float f0 (1+ scale)))))
 			 (t
-			  (scale-float (floatit bits) scale)))))
+			  (multiple-value-bind (f0 f1)
+			      (floatit bits)
+			    #||
+			    (format t "2: f0, f1 = ~A ~A~%" f0 f1)
+			    (format t "   scale = ~A~%" scale)
+			    (format t "scale-float f0 = ~A~%" (scale-float f0 scale))
+			    (when f1
+			      (format t "scale-float f1 = ~A~%" (scale-float f1 (- scale 53))))
+			    ||#
+			    (if f1
+				(make-double-double-float
+				 (scale-float f0 scale)
+				 (scale-float f1 (- scale #.vm:double-float-digits)))
+				(scale-float f0 scale)))))))
 	       (floatit (bits)
 		 (let ((sign (if plusp 0 1)))
 		   (case format
@@ -920,7 +1020,10 @@
 		      (double-from-bits sign vm:double-float-bias bits))
 		     #+long-float
 		     (long-float
-		      (long-from-bits sign vm:long-float-bias bits))))))
+		      (long-from-bits sign vm:long-float-bias bits))
+		     #+double-double
+		     (double-double-float
+		      (double-double-from-bits sign vm:double-float-bias bits))))))
 	(loop
 	  (multiple-value-bind (fraction-and-guard rem)
 			       (truncate shifted-num den)
@@ -1030,7 +1133,15 @@ rounding modes & do ieee round-to-integer.
 	   (let ((res (ash bits exp)))
 	     (if (minusp number)
 		 (- res)
-		 res)))))))
+		 res)))))
+    #+double-double
+    ((double-double-float)
+     (multiple-value-bind (bits exp)
+	 (integer-decode-double-double-float number)
+       (let ((res (ash bits exp)))
+	 (if (minusp number)
+	     (- res)
+	     res))))))
 
 
 ;;; %UNARY-ROUND  --  Interface
@@ -1061,7 +1172,20 @@ rounding modes & do ieee round-to-integer.
 			       shifted)))
 	     (if (minusp number)
 		 (- rounded)
-		 rounded)))))))
+		 rounded)))))
+    #+double-double
+    ((double-double-float)
+     (multiple-value-bind (bits exp)
+	     (integer-decode-float number)
+	   (let* ((shifted (ash bits exp))
+		  (rounded (if (and (minusp exp)
+				    (not (zerop (logand bits
+							(ash 1 (- -1 exp))))))
+			       (1+ shifted)
+			       shifted)))
+	     (if (minusp number)
+		 (- rounded)
+		 rounded))))))
 
 (declaim (maybe-inline %unary-ftruncate/single-float
 		       %unary-ftruncate/double-float))
@@ -1156,6 +1280,11 @@ rounding modes & do ieee round-to-integer.
 		    (setf hi (logandc2 hi (- (ash 1 (- frac-bits 32)) 1)))))
 	     (kernel:make-double-float hi lo))))))
 
+#+double-double
+(defun %unary-ftruncate/double-double-float (x)
+  ;; We should do something like what we do for double-double-float,
+  ;; but I'm lazy right now.
+  (coerce (truncate x) 'double-double-float))
 
 ;;; %UNARY-FTRUNCATE  --  Interface
 ;;;
@@ -1179,7 +1308,10 @@ rounding modes & do ieee round-to-integer.
     ((single-float)
      (%unary-ftruncate/single-float number))
     ((double-float)
-     (%unary-ftruncate/double-float number))))
+     (%unary-ftruncate/double-float number))
+    #+double-double
+    ((double-double-float)
+     (%unary-ftruncate/double-double-float number))))
 	     
 
 
@@ -1188,7 +1320,8 @@ 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 #+long-float long-float))
+    (((foreach single-float double-float #+long-float long-float
+	       #+double-double double-double-float))
      (multiple-value-bind (bits exp)
 			  (integer-decode-float x)
        (if (eql bits 0)
diff --git a/code/format.lisp b/code/format.lisp
index 7dc8887f4c3673b0af337951366c97177174be35..4716c9c9db6cfa674d2681b4f8fd58f498ded4f8 100644
--- a/code/format.lisp
+++ b/code/format.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/format.lisp,v 1.69 2006/05/01 16:10:26 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/format.lisp,v 1.70 2006/06/30 18:41:22 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1189,7 +1189,9 @@
 	(single-float #\f)
 	(double-float #\d)
 	(short-float #\s)
-	(long-float #\l))))
+	(long-float #\l)
+	#+double-double
+	(double-double-float #\w))))
 
 ;;;Here we prevent the scale factor from shifting all significance out of
 ;;;a number to the right.  We allow insignificant zeroes to be shifted in
diff --git a/code/hash-new.lisp b/code/hash-new.lisp
index fcd27df77dfa07ff31b1f13efd01d588b49e87c8..4071dbe57090fdc9b610b55e9f9326883b3282fa 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.36 2005/10/21 13:09:38 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/hash-new.lisp,v 1.37 2006/06/30 18:41:22 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -973,6 +973,11 @@
 		       (ash hi (- sxmash-rotate-bits)) hi
 		       (ldb sxhash-bits-byte
 			    (logxor (ash exp (- sxmash-rotate-bits)) exp))))))
+       #+double-double
+       (double-double-float
+	;; Is this good enough?
+	(logxor (internal-sxhash (kernel:double-double-hi s-expr) depth)
+		(internal-sxhash (kernel:double-double-lo s-expr) depth)))
        (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 1af99126c194cbb1900e8b80074aa4b1eadc8c2a..19981ead3fb5aa93827ba10f4368988cdd4e3431 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.44 2005/09/09 19:36:34 pmai Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/interr.lisp,v 1.45 2006/06/30 18:41:22 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -125,6 +125,13 @@
 	 :datum object
 	 :expected-type 'long-float))
 
+#+double-double
+(deferr object-not-double-double-float-error (object)
+  (error 'type-error
+	 :function-name name
+	 :datum object
+	 :expected-type 'double-double-float))
+
 (deferr object-not-simple-string-error (object)
   (error 'type-error
 	 :function-name name
@@ -412,6 +419,13 @@
 	 :datum object
 	 :expected-type '(simple-array double-float (*))))
 
+#+double-double
+(deferr object-not-simple-array-double-double-float-error (object)
+  (error 'type-error
+	 :function-name name
+	 :datum object
+	 :expected-type '(simple-array double-double-float (*))))
+
 (deferr object-not-simple-array-complex-single-float-error (object)
   (error 'type-error
 	 :function-name name
@@ -431,6 +445,13 @@
 	 :datum object
 	 :expected-type '(simple-array (complex long-float) (*))))
 
+#+double-double
+(deferr object-not-simple-array-complex-double-double-float-error (object)
+  (error 'type-error
+	 :function-name name
+	 :datum object
+	 :expected-type '(simple-array (complex double-double-float) (*))))
+
 (deferr object-not-complex-error (object)
   (error 'type-error
 	 :function-name name
@@ -462,6 +483,13 @@
 	 :datum object
 	 :expected-type '(complex long-float)))
 
+#+double-double
+(deferr object-not-complex-double-double-float-error (object)
+  (error 'type-error
+	 :function-name name
+	 :datum object
+	 :expected-type '(complex double-double-float)))
+
 (deferr object-not-weak-pointer-error (object)
   (error 'type-error
 	 :function-name name
diff --git a/code/irrat-dd.lisp b/code/irrat-dd.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..c1602762a590f6af4eb2ea82b2304c54f2d2f38a
--- /dev/null
+++ b/code/irrat-dd.lisp
@@ -0,0 +1,1836 @@
+;;; -*- Mode: Lisp; Package: KERNEL; Log: code.log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/irrat-dd.lisp,v 1.2 2006/06/30 18:41:22 rtoy Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains all the irrational functions for double-double
+;;; float.  The algorithms and coefficients come from the Cephes math
+;;; library.  See http://www.moshier.net/#Cephes and
+;;; http://www.netlib.org/cephes/.
+;;;
+;;; Author: Raymond Toy.
+;;; 
+
+(in-package "KERNEL")
+
+;;;; Random constants, utility functions.
+
+#+nil
+(defconstant max-log
+  1.1356523406294143949491931077970764891253w4
+  "log(most-positive-double-double-float)")
+
+#+nil
+(defconstant min-log
+  -1.143276959615573793352782661133116431383730w4
+  "log(least-positive-double-double-float")
+
+(defconstant max-log
+  7.0978271289338399678773454114191w2
+  "log(most-positive-double-double-float)")
+
+(defconstant min-log
+  -7.4444007192138126231410729844608w2
+  "log(least-positive-double-double-float")
+
+
+(defconstant loge2
+  0.6931471805599453094172321214581765680755001w0
+  "log(2)")
+
+(defconstant log2e
+  1.442695040888963407359924681001892137426646w0
+  "Log base 2 of e")
+
+(defconstant log2ea
+  4.4269504088896340735992468100189213742664595w-1
+  "log2(e)-1")
+
+(defconstant dd-pi
+  3.141592653589793238462643383279502884197169w0
+  "Pi")
+
+(defconstant dd-pi/2
+  1.570796326794896619231321691639751442098585w0
+  "Pi/2")
+
+(defconstant dd-pi/4
+  0.7853981633974483096156608458198757210492923w0
+  "Pi/4")
+
+;; log2-c1 and log-c2 are log(2) arranged in such a way that log2-c1 +
+;; log2-c2 is log(2) to an accuracy greater than double-double-float.
+(defconstant log2-c1
+  6.93145751953125w-1)
+
+(defconstant log2-c2
+  1.428606820309417232121458176568075500134w-6)
+
+(defconstant sqrt-1/2
+  0.7071067811865475244008443621048490392848w0
+  "Sqrt(2)")
+
+;; Evaluate polynomial
+(defun poly-eval (x coef)
+  (declare (type double-double-float x)
+	   (type (simple-array double-double-float (*)) coef))
+  ;; y = C0 + C1*x + C2*x^2 + ...
+  ;;
+  ;; But coefficients are stored in reverse (descending powers) order:
+  ;; coef[0] = CN, ..., coef[N] = C0.
+  (let ((y 0w0))
+    (declare (type double-double-float y))
+    (loop for c across coef do
+	 (setf y (+ (* y x)
+		    c)))
+    y))
+
+(defun poly-eval-1 (x coef)
+  (declare (type double-double-float x)
+	   (type (simple-array double-double-float (*)) coef))
+  ;; Like poly-eval, except it assumes coef[N] = 1 and is omitted.
+  (let ((y 1w0))
+    (declare (type double-double-float y))
+    (loop for c across coef do
+	 (setf y (+ (* y x)
+		    c)))
+    y))
+
+
+;;; dd-%expm1
+;;;
+;;; exp(x)-1
+;;; Range reduction is accomplished by separating the argument
+;;; into an integer k and fraction f such that 
+;;;
+;;;     x    k  f
+;;;    e  = 2  e.
+;;;
+;;; An expansion x + .5 x^2 + x^3 R(x) approximates exp(f) - 1
+;;; in the basic range [-0.5 ln 2, 0.5 ln 2].
+;;;
+;;;
+;;; ACCURACY:
+;;;
+;;;                      Relative error:
+;;; arithmetic   domain     # trials      peak         rms
+;;;    IEEE    -79,+MAXLOG    100,000     1.7e-34     4.5e-35
+;;;
+
+(let ((p (make-array 8 :element-type 'double-double-float
+		     :initial-contents '(
+					 -4.888737542888633647784737721812546636240w-1
+					 4.401308817383362136048032038528753151144w1
+					 -1.716772506388927649032068540558788106762w3
+					 4.578962475841642634225390068461943438441w4
+					 -7.212432713558031519943281748462837065308w5
+					 8.944630806357575461578107295909719817253w6
+					 -5.722847283900608941516165725053359168840w7
+					 2.943520915569954073888921213330863757240w8)))
+      (q (make-array 8 :element-type 'double-double-float
+		     :initial-contents '(
+					 ;; 1.000000000000000000000000000000000000000w0
+					 1.766112549341972444333352727998584753865w9
+					 -7.848989743695296475743081255027098295771w8
+					 1.615869009634292424463780387327037251069w8
+					 -2.019684072836541751428967854947019415698w7
+					 1.682912729190313538934190635536631941751w6
+					 -9.615511549171441430850103489315371768998w4
+					 3.697714952261803935521187272204485251835w3
+					 -8.802340681794263968892934703309274564037w1)))
+      ;; ln 2^-114
+      (minarg -7.9018778583833765273564461846232128760607w1))
+  (declare (type double-double-float minarg))
+  ;; exp(x) - 1 = x + 0.5*x^2+x^3*P(x)/Q(x), for -log(2)/2 < x <
+  ;; log(2)/2, where the coefficients of P and Q are given Pn and Qn
+  ;; above.  Theoretical peak relative error = 8.1e-36.
+  (defun dd-%expm1 (x)
+    "exp(x) - 1"
+    (declare (type double-double-float x)
+	     (optimize (speed 3)))
+    ;; Range reduction is accomplished by separating the argument
+    ;; into an integer k and fraction f such that 
+    ;;
+    ;;     x    k  f
+    ;;    e  = 2  e.
+    ;;
+    ;; An expansion x + .5 x^2 + x^3 R(x) approximates exp(f) - 1
+    ;; in the basic range [-0.5 ln 2, 0.5 ln 2].
+    (when (> x max-log)
+      (return-from dd-%expm1
+	(kernel:%make-double-double-float #.ext:double-float-positive-infinity
+					  #.ext:double-float-positive-infinity)))
+    (when (< x minarg)
+      (return-from dd-%expm1 -1w0))
+
+    ;; Express x = ln(2)*(k+remainder), remainder not exceeding 1/2
+    (let* ((xx (+ log2-c1 log2-c2))
+	   (k (floor (+ 1/2 (/ (the (double-double-float * 710w0) x) xx))))
+	   (px (coerce k 'double-double-float))
+	   (qx 0w0))
+      (declare (type double-double-float xx px qx))
+      ;; remainder times ln 2
+      (decf x (* px log2-c1))
+      (decf x (* px log2-c2))
+
+      ;; Approximate exp(remainder*ln(2))
+      #+nil
+      (setf px (* x
+		  (+ p0
+		     (* x
+			(+ p1
+			   (* x
+			      (+ p2
+				 (* x
+				    (+ p3
+				       (* x
+					  (+ p4
+					     (* x
+						(+ p5
+						   (* x
+						      (+ p6
+							 (* x p7))))))))))))))))
+      #+nil
+      (setf qx (+ q0
+		  (* x
+		     (+ q1
+			(* x
+			   (+ q2
+			      (* x
+				 (+ q3
+				    (* x
+				       (+ q4
+					  (* x
+					     (+ q5
+						(* x
+						   (+ q6
+						      (* x
+							 (+ x q7))))))))))))))))
+      (setf px (poly-eval x p))
+      (setf qx (poly-eval-1 x q))
+      (setf xx (* x x))
+      (setf qx (+ x (+ (* 0.5w0 xx)
+		       (/  (* xx px)
+			   qx))))
+      ;; exp(x) = exp(k*ln(2))*exp(remainder*ln(2)) = 2^k*exp(remainder*ln(2))
+      ;;
+      ;; We have qx = exp(remainder*ln(2))-1, so exp(x) - 1 =
+      ;; 2^k*(qx+1)-1 = 2^k*qx + 2^k - 1
+      (setf px (scale-float 1w0 k))
+      (+ (* px qx)
+	 (- px 1)))))
+
+;;; dd-%exp
+;;; exp(x)
+;;; Range reduction is accomplished by separating the argument
+;;; into an integer k and fraction f such that
+;;;
+;;;     x    k  f
+;;;    e  = 2  e.
+;;;
+;;; A Pade' form of degree 2/3 is used to approximate exp(f) - 1
+;;; in the basic range [-0.5 ln 2, 0.5 ln 2].
+;;;
+;;;
+;;; ACCURACY:
+;;;
+;;;                      Relative error:
+;;; arithmetic   domain     # trials      peak         rms
+;;;    IEEE      +-MAXLOG    100,000     2.6e-34     8.6e-35
+;;;
+;;;
+;;; Error amplification in the exponential function can be
+;;; a serious matter.  The error propagation involves
+;;; exp( X(1+delta) ) = exp(X) ( 1 + X*delta + ... ),
+;;; which shows that a 1 lsb error in representing X produces
+;;; a relative error of X times 1 lsb in the function.
+;;; While the routine gives an accurate result for arguments
+;;; that are exactly represented by a long double precision
+;;; computer number, the result contains amplified roundoff
+;;; error for large arguments not exactly represented.
+
+(let ((p (make-array 5 :element-type 'double-double-float
+		     :initial-contents
+		     '(
+		       3.279723985560247033712687707263393506266w-10
+		       6.141506007208645008909088812338454698548w-7
+		       2.708775201978218837374512615596512792224w-4
+		       3.508710990737834361215404761139478627390w-2
+		       9.999999999999999999999999999999999998502w-1
+		       )))
+      (q (make-array 6 :element-type 'double-double-float
+		     :initial-contents
+		     '(
+		       2.980756652081995192255342779918052538681w-12
+		       1.771372078166251484503904874657985291164w-8
+		       1.504792651814944826817779302637284053660w-5
+		       3.611828913847589925056132680618007270344w-3
+		       2.368408864814233538909747618894558968880w-1
+		       2.000000000000000000000000000000000000150w0
+		       )))
+      ;; C1 + C2 = ln 2
+      (c1 (- log2-c1))
+      (c2 (- log2-c2)))
+  (declare (type double-double-float c1 c2))
+  ;; p and q are Pade coefficients for exp(x) - 1.  Theoretical peak
+  ;; relative error = 2.2e-37, relative peak error spread = 9.2e-38.
+  (defun dd-%exp (x)
+    (declare (type double-double-float x)
+	     (optimize (speed 3)))
+    (when (> x max-log)
+      (return-from dd-%exp
+	(kernel:%make-double-double-float #.ext:double-float-positive-infinity
+					  #.ext:double-float-positive-infinity)))
+    (when (< x min-log)
+      (return-from dd-%exp 0w0))
+    ;; Express
+    ;;   exp(x) = exp(g)*2^n
+    ;;          = exp(g)*exp(n*log(2))
+    ;;          = exp(g + n * log2)
+    (let* ((n (floor (+ 0.5w0 (* x log2e))))
+	   (px (coerce n 'double-double-float)))
+      (declare (type double-double-float px))
+      (incf x (* px c1))
+      (incf x (* px c2))
+      ;; Rational approx for exponential of fractional part:
+      ;; exp(x) = 1+2*x*p(x^2)/(q(x^2)-p(x^2))
+      ;;
+      ;; [The above comment seems not to match the code below.  But
+      ;; perhaps q(x) isn't what I think it is.]
+      (let ((xx (* x x)))
+	(setf px (* x (poly-eval xx p)))
+	(setf xx (poly-eval xx q))
+	(setf x (/ px (- xx px)))
+	(setf x (+ 1 x x))
+	(scale-float x n)))))
+
+
+;;; dd-%log
+;;; log(x), natural logarithm.
+;;; The argument is separated into its exponent and fractional
+;;; parts.  If the exponent is between -1 and +1, the logarithm
+;;; of the fraction is approximated by
+;;;
+;;;     log(1+x) = x - 0.5 x**2 + x**3 P(x)/Q(x).
+;;;
+;;; Otherwise, setting  z = 2(x-1)/x+1),
+;;; 
+;;;     log(x) = z + z**3 P(z)/Q(z).
+;;;
+;;;
+;;;
+;;; ACCURACY:
+;;;
+;;;                      Relative error:
+;;; arithmetic   domain     # trials      peak         rms
+;;;    IEEE   exp(+-MAXLOGL) 36,000      9.5e-35     4.1e-35
+;;;
+
+(let ((p (make-array 13 :element-type 'double-double-float
+		     :initial-contents
+		     '(1.538612243596254322971797716843006400388w-6
+		       4.998469661968096229986658302195402690910w-1
+		       2.321125933898420063925789532045674660756w1
+		       4.114517881637811823002128927449878962058w2
+		       3.824952356185897735160588078446136783779w3
+		       2.128857716871515081352991964243375186031w4
+		       7.594356839258970405033155585486712125861w4
+		       1.797628303815655343403735250238293741397w5
+		       2.854829159639697837788887080758954924001w5
+		       3.007007295140399532324943111654767187848w5
+		       2.014652742082537582487669938141683759923w5
+		       7.771154681358524243729929227226708890930w4
+		       1.313572404063446165910279910527789794488w4)))
+      (q (make-array 12 :element-type 'double-double-float
+		     :initial-contents
+		     '(
+		       ;; 1.000000000000000000000000000000000000000w0
+		       4.839208193348159620282142911143429644326w1
+		       9.104928120962988414618126155557301584078w2
+		       9.147150349299596453976674231612674085381w3
+		       5.605842085972455027590989944010492125825w4
+		       2.248234257620569139969141618556349415120w5
+		       6.132189329546557743179177159925690841200w5
+		       1.158019977462989115839826904108208787040w6
+		       1.514882452993549494932585972882995548426w6
+		       1.347518538384329112529391120390701166528w6
+		       7.777690340007566932935753241556479363645w5
+		       2.626900195321832660448791748036714883242w5
+		       3.940717212190338497730839731583397586124w4)))
+      (r (make-array 6 :element-type 'double-double-float
+		     :initial-contents
+		     '(-8.828896441624934385266096344596648080902w-1
+		       8.057002716646055371965756206836056074715w1
+		       -2.024301798136027039250415126250455056397w3
+		       2.048819892795278657810231591630928516206w4
+		       -8.977257995689735303686582344659576526998w4
+		       1.418134209872192732479751274970992665513w5
+		       )))
+      (s (make-array 6 :element-type 'double-double-float
+		     :initial-contents
+		     '(	;; 1.000000000000000000000000000000000000000w0
+		       -1.186359407982897997337150403816839480438w2
+		       3.998526750980007367835804959888064681098w3
+		       -5.748542087379434595104154610899551484314w4
+		       4.001557694070773974936904547424676279307w5
+		       -1.332535117259762928288745111081235577029w6
+		       1.701761051846631278975701529965589676574w6))))
+  ;; p and q are coefficients in the expansion for log(1+x) = x -
+  ;; x^2/2 + x^3*p(x)/q(x), where 1/sqrt(2) <= 1+x < sqrt(2).
+  ;; Theoretical peak relative error = 5.3e-37, relative peak error
+  ;; spread = 2.3e-14.
+  ;;
+  ;; R and S are coefficients for log(x) = z + z^3*r(z^2)/s(z^2),
+  ;; where z = 2*(x-1)/(x+1), where 1/sqrt(2) <= x < sqrt(2).
+  ;; Theoretical peak relative error = 1.1e-35, relative peak error
+  ;; spread 1.1e-9.
+  ;;
+  ;; 
+  (defun dd-%log (x)
+    (declare (type double-double-float x)
+	     (optimize (speed 3)))
+    ;; Separate mantissa from exponent
+    (multiple-value-bind (x e)
+	(decode-float x)
+      (declare (type double-double-float x)
+	       (type double-float-exponent e))
+      (let ((z 0w0)
+	    (y 0w0))
+	(declare (type double-double-float z y))
+	;; Logarithm using log(x) = z + z^3*P(z^2)/Q(z^2); where z = 2*(x-1)/x + 1;
+	(cond ((or (> e 2)
+		   (< e -2))
+	       (cond ((< x sqrt-1/2)
+		      ;; 2*(2*x-1)/(2*x+1)
+		      (decf e)
+		      (setf z (- x 0.5w0))
+		      (setf y (+ (* 0.5w0 z) 0.5w0)))
+		     (t
+		      ;; 2*(x-1)/(x+1)
+		      (setf z (- x 0.5w0))
+		      (decf z 0.5w0)
+		      (setf y (+ (* 0.5w0 x) 0.5w0))))
+	       (setf x (/ z y))
+	       (setf z (* x x))
+	       (setf z (* x (/ (* z (poly-eval z r))
+				 (poly-eval-1 z s))))
+	       (incf z (* e log2-c2))
+	       (incf z x)
+	       (incf z (* e log2-c1)))
+	      (t
+	       ;; Log using log(1+x) = x - 0.5*x^2+x^3*p(x)/q(x)
+	       (cond ((< x sqrt-1/2)
+		      (decf e)
+		      (setf x (- (scale-float x 1) 1)))
+		     (t
+		      (decf x)))
+	       (setf z (* x x))
+	       (setf y (* x (* z (/ (poly-eval x p)
+				    (poly-eval-1 x q)))))
+	       (incf y (* e log2-c2))
+	       ;; z = y - 0.5*z
+	       (setf z (- y (scale-float z -1)))
+	       (incf z x)
+	       (incf z (* e log2-c1))
+	       ))))))
+
+;;; dd-%log1p(x)
+;;; log(1+x)
+;;;
+;;; The argument 1+x is separated into its exponent and fractional
+;;; parts.  If the exponent is between -1 and +1, the logarithm
+;;; of the fraction is approximated by
+;;;
+;;;     log(1+x) = x - 0.5 x^2 + x^3 P(x)/Q(x).
+;;;
+;;; Otherwise, setting  z = 2(x-1)/x+1),
+;;; 
+;;;     log(x) = z + z^3 P(z)/Q(z).
+;;;
+;;;
+;;;
+;;; ACCURACY:
+;;;
+;;;                      Relative error:
+;;; arithmetic   domain     # trials      peak         rms
+;;;    IEEE      -1, 8       100000      1.9e-34     4.3e-35
+
+(let ((p (make-array 13 :element-type 'double-double-float
+		     :initial-contents '(
+					 1.538612243596254322971797716843006400388w-6
+					 4.998469661968096229986658302195402690910w-1
+					 2.321125933898420063925789532045674660756w1
+					 4.114517881637811823002128927449878962058w2
+					 3.824952356185897735160588078446136783779w3
+					 2.128857716871515081352991964243375186031w4
+					 7.594356839258970405033155585486712125861w4
+					 1.797628303815655343403735250238293741397w5
+					 2.854829159639697837788887080758954924001w5
+					 3.007007295140399532324943111654767187848w5
+					 2.014652742082537582487669938141683759923w5
+					 7.771154681358524243729929227226708890930w4
+					 1.313572404063446165910279910527789794488w4
+					 )))
+      (q (make-array 12 :element-type 'double-double-float
+		     :initial-contents '(
+					 ;; 1.000000000000000000000000000000000000000w0
+					 4.839208193348159620282142911143429644326w1
+					 9.104928120962988414618126155557301584078w2
+					 9.147150349299596453976674231612674085381w3
+					 5.605842085972455027590989944010492125825w4
+					 2.248234257620569139969141618556349415120w5
+					 6.132189329546557743179177159925690841200w5
+					 1.158019977462989115839826904108208787040w6
+					 1.514882452993549494932585972882995548426w6
+					 1.347518538384329112529391120390701166528w6
+					 7.777690340007566932935753241556479363645w5
+					 2.626900195321832660448791748036714883242w5
+					 3.940717212190338497730839731583397586124w4
+					 )))
+      (r (make-array 6 :element-type 'double-double-float
+		     :initial-contents '(-8.828896441624934385266096344596648080902w-1
+					 8.057002716646055371965756206836056074715w1
+					 -2.024301798136027039250415126250455056397w3
+					 2.048819892795278657810231591630928516206w4
+					 -8.977257995689735303686582344659576526998w4
+					 1.418134209872192732479751274970992665513w5
+					 )))
+      (s (make-array 6 :element-type 'double-double-float
+		     :initial-contents '(
+					 ;; 1.000000000000000000000000000000000000000w0
+					 -1.186359407982897997337150403816839480438w2
+					 3.998526750980007367835804959888064681098w3
+					 -5.748542087379434595104154610899551484314w4
+					 4.001557694070773974936904547424676279307w5
+					 -1.332535117259762928288745111081235577029w6
+					 1.701761051846631278975701529965589676574w6
+					 )))
+)
+  ;; Coefficients for log(1+x) = x - x^2 / 2 + x^3 P(x)/Q(x)
+  ;; 1/sqrt(2) <= 1+x < sqrt(2)
+  ;; Theoretical peak relative error = 5.3e-37,
+  ;; relative peak error spread = 2.3e-14
+  (defun dd-%log1p (xm1)
+    (declare (type double-double-float xm1))
+    (let ((x (+ xm1 1))
+	  (z 0w0)
+	  (y 0w0))
+      (declare (type double-double-float x y z)
+	       (optimize (speed 3)))
+      (multiple-value-bind (x e)
+	  (decode-float x)
+	(declare (type double-double-float x)
+		 (type double-float-exponent e))
+	(cond ((or (> e 2)
+		   (< e -2))
+	       ;; Log using log(x) = z + z^3*P(z^2)/Q(z^2)
+	       (cond ((< x sqrt-1/2)
+		      (decf e)
+		      (setf z (- x 0.5w0))
+		      (setf y (+ 0.5w0 (* 0.5w0 z))))
+		     (t
+		      (setf z (- x 0.5w0))
+		      (decf z 0.5w0)
+		      (setf y (+ 0.5w0 (* 0.5w0 x)))))
+	       (setf x (/ z y))
+	       (setf z (* x x))
+	       (setf z (* x (/ (* z (poly-eval z r))
+			       (poly-eval-1 z s))))
+	       (incf z (* e log2-c2))
+	       (incf z x)
+	       (incf z (* e log2-c1)))
+	      (t
+	       ;; Log using log(1+x) = x - 0.5*x^2 + x^3*p(x)/q(x)
+	       (cond ((< x sqrt-1/2)
+		      (decf e)
+		      (if (/= e 0)
+			  (setf x (- (* 2 x) 1))
+			  (setf x xm1)))
+		     (t
+		      (if (/= e 0)
+			  (decf x 1)
+			  (setf x xm1))))
+	       (setf z (* x x))
+	       (setf y (* x (/ (* z (poly-eval x p))
+			       (poly-eval-1 x q))))
+	       (incf y (* e log2-c2))
+	       (setf z (- y (* 0.5w0 z)))
+	       (incf z x)
+	       (incf z (* e log2-c1))))))))
+
+(let ((P (make-array 6 :element-type 'double-double-float
+		     :initial-contents '(
+					 1.622194395724068297909052717437740288268w3
+					 1.124862584587770079742188354390171794549w6
+					 3.047548980769660162696832999871894196102w8
+					 3.966215348072348368191433063260384329745w10
+					 2.375869584584371194838551715348965605295w12
+					 6.482835792103233269752264509192030816323w13
+					 )))
+      (Q (make-array 6 :element-type 'double-double-float
+		     :initial-contents '(
+					 ;; 1.000000000000000000000000000000000000000w0 */
+					 -9.101683853129357776079049616394849086007w2
+					 4.486400519836461218634448973793765123186w5
+					 -1.492531313030440305095318968983514314656w8
+					 3.457771488856930054902696708717192082887w10
+					 -5.193289868803472640225483235513427062460w12
+					 3.889701475261939961851358705515223019890w14))))
+  (defun dd-%sinh (x)
+    (declare (type double-double-float x)
+	     (optimize (speed 3)))
+    (let ((a (abs x)))
+      (declare (type double-double-float a))
+      (cond ((> a 1)
+	     (setf a (dd-%exp a))
+	     (setf a (- (* 0.5w0 a) (/ 0.5w0 a)))
+	     (if (< x 0)
+		 (- a)
+		 a))
+	    (t
+	     (setf a (* a a))
+	     (let ((pp (poly-eval a p))
+		   (qq (poly-eval-1 a q)))
+	       (+ x (* x a
+		       (/ pp qq)))))))))
+
+#+nil
+(defun dd-%sinh (x)
+  (declare (type double-double-float x))
+  (let ((a (abs x)))
+    (declare (type double-double-float a))
+    (cond ((> a 1)
+	   (setf a (dd-%exp a))
+	   (setf a (- (* 0.5w0 a) (/ 0.5w0 a)))
+	   (if (< x 0)
+	       (- a)
+	       a))
+	  (t
+	   ;; Use sinh(x) = 1/2*(D(x)+D(x)/(1+D(x))), here D(x) =
+	   ;; exp(x)-1.
+	   (let ((d (dd-%expm1 x)))
+	     (* 0.5w0 (+ d (/ d (+ 1 d)))))))))
+
+(defun dd-%cosh (x)
+  (declare (type double-double-float x))
+  (let ((y (dd-%exp x)))
+    (scale-float (+ y (/ y)) -1)))
+
+(let ((P (make-array 6 :element-type 'double-double-float
+		     :initial-contents '(-6.505693197948351084912624750702492767503w-6
+					 -9.804083860188429726356968570322356183383w-1
+					 -5.055287638900473250703725789725376004355w2
+					 -7.307477148073823966594990496301416814519w4
+					 -3.531606586182691280701462523692471322688w6
+					 -4.551377146142783468144190926206842300707w7
+					 )))
+      (Q (make-array 5 :element-type 'double-double-float
+		     :initial-contents '(
+					 ;; 1.000000000000000000000000000000000000000w0 */
+					 5.334865598460027935735737253027154828002w2
+					 8.058475607422391042912151298751537172870w4
+					 4.197073523796142343374222405869721575491w6
+					 6.521134551226147545983467868553677881771w7
+					 1.365413143842835040443257277862054198329w8))))
+  (defun dd-%tanh (x)
+    (declare (type double-double-float x)
+	     (optimize (speed 3)))
+    (let ((z (abs x)))
+      (declare (type double-double-float z))
+      (cond ((> z (* 0.5w0 max-log))
+	     (if (> x 0)
+		 1w0
+		 -1w0))
+	    ((> z 0.625w0)
+	     (let ((s (dd-%exp (* 2 z))))
+	       (setf z (- 1 (/ 2 (+ s 1))))
+	       (if (minusp x)
+		   (- z)
+		   z)))
+	    (t
+	     (let* ((s (* x x)))
+	       (declare (optimize speed))
+	       (setf z (/ (poly-eval s p)
+			  (poly-eval-1 s q)))
+	       (setf z (* x s z))
+	       (+ x z)))))))
+
+(let ((P (make-array 10 :element-type 'double-double-float
+		     :initial-contents '(
+					 -9.217569843805850417698565442251656375681w-1
+					 5.321929116410615470118183794063211260728w1
+					 -9.139522976807685333981548145417830690552w2
+					 7.204314536952949779101646454146682033772w3
+					 -3.097809640165146436529075324081668598891w4
+					 7.865376554210973897486215630898496100534w4
+					 -1.211716814094785128366087489224821937203w5
+					 1.112669508789123834670923967462068457013w5
+					 -5.600242872292477863751728708249167956542w4
+					 1.188901082233997739779618679364295772810w4
+					 )))
+      (Q (make-array 10 :element-type 'double-double-float
+		     :initial-contents '(
+					 ;; 1.000000000000000000000000000000000000000w0 */
+					 -6.807348436010016270202879229504392062418w1
+					 1.386763299649315831625106608182196351693w3
+					 -1.310805752656879543134785263832907269320w4
+					 6.872174720355764193772953852564737816928w4
+					 -2.181008360536226513009076189881617939380w5
+					 4.362736119602298592874941767284979857248w5
+					 -5.535251007539393347687001489396152923502w5
+					 4.321594849688346708841188057241308805551w5
+					 -1.894075056489862952285849974761239845873w5
+					 3.566703246701993219338856038092901974725w4
+					 ))))
+  (defun dd-%atanh (x)
+    (declare (type double-double-float x)
+	     (optimize (speed 3)))
+    (cond ((minusp x)
+	   (- (the double-double-float (dd-%atanh (- x)))))
+	  ((< x 1w-12)
+	   x)
+	  ((< x  0.5w0)
+	   (let ((z (* x x)))
+	     (+ x (* x z (/ (poly-eval z p)
+			    (poly-eval-1 z q))))))
+	  (t
+	   (* 0.5w0 (dd-%log (/ (+ 1 x)
+			       (- 1 x))))))))
+
+
+(let ((P (make-array 9 :element-type 'double-double-float
+		     :initial-contents '(
+					 -8.104404283317298189545629468767571317688w-1
+					 -4.954206127425209147110732546633675599008w1
+					 -8.438175619831548439550086251740438689853w2
+					 -6.269710069245210459536983820505214648057w3
+					 -2.418935474493501382372711518024193326434w4
+					 -5.208121780431312783866941311277024486498w4
+					 -6.302755086521614763280617114866439227971w4
+					 -4.003566436224198252093684987323233921339w4
+					 -1.037690841528359305134494613113086980551w4
+					 )))
+      (Q (make-array 9 :element-type 'double-double-float
+		     :initial-contents '(
+					 ;; 1.000000000000000000000000000000000000000w0 */
+					 8.175806439951395194771977809279448392548w1
+					 1.822215299975696008284027212745010251320w3
+					 1.772040003462901790853111853838978236828w4
+					 9.077625379864046240143413577745818879353w4
+					 2.675554475070211205153169988669677418808w5
+					 4.689758557916492969463473819426544383586w5
+					 4.821923684550711724710891114802924039911w5
+					 2.682316388947175963642524537892687560973w5
+					 6.226145049170155830806967678679167550122w4))))
+  (defun dd-%asinh (x)
+    (declare (type double-double-float x)
+	     (optimize (speed 3)))
+    (cond ((minusp x)
+	   (- (the double-double-float (dd-%asinh (- x)))))
+	  #+nil
+	  ((> x 1w10)
+	   (+ loge2 (dd-%log x)))
+	  ((< x 0.5w0)
+	   (let* ((z (* x x))
+		  (a (* z (/ (poly-eval z p)
+			     (poly-eval-1 z q)))))
+	     (+ (* a x) x)))
+	  (t
+	   (dd-%log (+ x (sqrt (1+ (* x x)))))))))
+
+(let ((P (make-array 10 :element-type 'double-double-float
+		     :initial-contents '(
+					 1.895467874386341763387398084072833727168w-1
+					 6.443902084393244878979969557171256604767w1
+					 3.914593556594721458616408528941154205393w3
+					 9.164040999602964494412169748897754668733w4
+					 1.065909694792026382660307834723001543839w6
+					 6.899169896709615182428217047370629406305w6
+					 2.599781868717579447900896150777162652518w7
+					 5.663733059389964024656501196827345337766w7
+					 6.606302846870644033621560858582696134512w7
+					 3.190482951215438078279772140481195200593w7
+					 )))
+      (Q (make-array 9 :element-type 'double-double-float
+		     :initial-contents '(
+					 ;; 1.000000000000000000000000000000000000000w0 */
+					 1.635418024331924674147953764918262009321w2
+					 7.290983678312632723073455563799692165828w3
+					 1.418207894088607063257675159183397062114w5
+					 1.453154285419072886840913424715826321357w6
+					 8.566841438576725234955968880501739464425w6
+					 3.003448667795089562511136059766833630017w7
+					 6.176592872899557661256383958395266919654w7
+					 6.872176426138597206811541870289420510034w7
+					 3.190482951215438078279772140481195226621w7
+					 ))))
+  (defun dd-%acosh (x)
+    (declare (type double-double-float x)
+	     (optimize (speed 3)))
+    (cond ((> x 1w17)
+	   (+ loge2 (dd-%log x)))
+	  (t
+	   (let ((z (- x 1)))
+	     (cond ((< z 0.5w0)
+		    (* (sqrt (* 2 z))
+		       (/ (poly-eval z p)
+			  (poly-eval-1 z q))))
+		   (t
+		    (dd-%log (+ x (sqrt (* z (+ 1 x))))))))))))
+
+(let ((P (make-array 10 :element-type 'double-double-float
+		     :initial-contents '(
+					 -8.067112765482705313585175280952515549833w-1
+					 4.845649797786849136525020822000172350977w1
+					 -8.510195404865297879959793548843395926847w2
+					 6.815196841370292688574521445731895826485w3
+					 -2.967135182120339728996157454994675519735w4
+					 7.612250656518818109652985996692466409670w4
+					 -1.183360579752620455689557157684221905030w5
+					 1.095432262510413338755837156377401348063w5
+					 -5.554124580991113991999636773382495788705w4
+					 1.187132626694762543537732514905488896985w4
+					 )))
+      (Q (make-array 10 :element-type 'double-double-float
+		     :initial-contents '(
+					 ;;  1.000000000000000000000000000000000000000w0 */
+					 -8.005471061732009595694099899234272342478w1
+					 1.817324228942812880965069608562483918025w3
+					 -1.867017317425756524289537002141956583706w4
+					 1.048196619402464497478959760337779705622w5
+					 -3.527040897897253459022458866536165564103w5
+					 7.426302422018858001691440351763370029242w5
+					 -9.863068411558756277454631976667880674474w5
+					 8.025654653926121907774766642393757364326w5
+					 -3.653000557802254281954969843055623398839w5
+					 7.122795760168575261226395089432959614179w4
+					 ))))
+  (defun dd-%asin (x)
+    (declare (type double-double-float x)
+	     (optimize (speed 3)))
+    (cond ((minusp x)
+	   (- (the double-double-float (dd-%asin (- x)))))
+	  #+nil
+	  ((< x 1w-8)
+	   x)
+	  (t
+	   (let ((flag nil)
+		 (z 0w0)
+		 (zz 0w0))
+	     (declare (type double-double-float z zz))
+	     (cond ((> x 0.5w0)
+		    (setf zz (- 0.5w0 x))
+		    (setf zz (scale-float (+ zz 0.5w0) -1))
+		    (setf z (sqrt zz))
+		    (setf flag t))
+		   (t
+		    (setf z x)
+		    (setf zz (* z z))
+		    (setf flag nil)))
+	     (let ((p (* zz (/ (poly-eval zz p)
+			       (poly-eval-1 zz q)))))
+	       (setf z (+ (* z p) z))
+	       (when flag
+		 (setf z (+ z z))
+		 (setf z (- dd-pi/2 z)))
+	       z))))))
+
+(defun dd-%acos (x)
+  (declare (type double-double-float x)
+	   (optimize (speed 3)))
+  (cond ((< x -0.5w0)
+	 (- dd-pi
+	    (* 2 (dd-%asin (sqrt (* 0.5w0 (+ 1 x)))))))
+	((> x 0.5w0)
+	 (* 2 (dd-%asin (sqrt (* 0.5w0 (- 1w0 x))))))
+	(t
+	 (- dd-pi/2 (dd-%asin x)))))
+
+(let ((P (make-array 9 :element-type 'double-double-float
+		     :initial-contents '(
+					 -6.635810778635296712545011270011752799963w-4
+					 -8.768423468036849091777415076702113400070w-1
+					 -2.548067867495502632615671450650071218995w1
+					 -2.497759878476618348858065206895055957104w2
+					 -1.148164399808514330375280133523543970854w3
+					 -2.792272753241044941703278827346430350236w3
+					 -3.696264445691821235400930243493001671932w3
+					 -2.514829758941713674909996882101723647996w3
+					 -6.880597774405940432145577545328795037141w2
+					 )))
+      (Q (make-array 8 :element-type 'double-double-float
+		     :initial-contents '(
+					 ;; 1.000000000000000000000000000000000000000w0 */
+					 3.566239794444800849656497338030115886153w1
+					 4.308348370818927353321556740027020068897w2
+					 2.494680540950601626662048893678584497900w3
+					 7.928572347062145288093560392463784743935w3
+					 1.458510242529987155225086911411015961174w4
+					 1.547394317752562611786521896296215170819w4
+					 8.782996876218210302516194604424986107121w3
+					 2.064179332321782129643673263598686441900w3
+					 )))
+
+      ;; tan( 3*pi/8 )
+      (T3P8  2.414213562373095048801688724209698078569672w0)
+      ;; tan( pi/8 )
+      (TP8 0.414213562373095048801688724209698078569672w0))
+  (declare (type double-double-float t3p8 tp8))
+  (defun dd-%atan (x)
+    (declare (type double-double-float x)
+	     (optimize (speed 3)))
+    (when (minusp x)
+      (return-from dd-%atan (- (the double-double-float (dd-%atan (- x))))))
+    ;; range reduction
+    (let ((y 0w0))
+      (declare (type double-double-float y))
+      (cond ((> x t3p8)
+	     (setf y dd-pi/2)
+	     (setf x (/ -1 x)))
+	    ((> x tp8)
+	     (setf y dd-pi/4)
+	     (setf x (/ (- x 1)
+			(+ x 1))))
+	    (t
+	     (setf y 0w0)))
+      ;; Rational form in x^2
+      (let ((z (* x x)))
+	(setf y (+ y
+		   (* (/ (poly-eval z p)
+			 (poly-eval-1 z q))
+		      z x)
+		   x))
+	y))))
+
+(defun dd-%atan2 (y x)
+  (declare (type double-double-float x y)
+	   (optimize (speed 3)))
+  (let ((code 0)
+	(w 0w0))
+    (declare (type (integer 0 3) code)
+	     (type double-double-float w))
+    (when (minusp x)
+      (setf code 2))
+    (when (minusp y)
+      (setf code (logior code 1)))
+    (when (zerop x)
+      (unless (zerop (logand code 1))
+	(return-from dd-%atan2 (- dd-pi/2)))
+      (when (zerop y)
+	(return-from dd-%atan2 0w0))
+      (return-from dd-%atan2 dd-pi/2))
+    (when (zerop y)
+      (return-from dd-%atan2
+	(if (zerop (logand code 2))
+	    0w0
+	    dd-pi)))
+    (setf w (ecase code
+	      (0 0w0)
+	      (1 0w0)
+	      (2 dd-pi)
+	      (3 (- dd-pi))))
+
+    (+ w (dd-%atan (/ y x)))))
+       
+
+;;
+;; Here are the fractional digits of pi, in hex.
+;;
+;;  243f6a8885 a308d31319 8a2e037073 44a4093822 299f31d008 2efa98ec4e 6c89452821 e638d01377 be5466cf34 e90c6cc0ac
+;; 29b7c97c50 dd3f84d5b5 b547091792 16d5d98979 fb1bd1310b a698dfb5ac 2ffd72dbd0 1adfb7b8e1 afed6a267e 96ba7c9045 
+;;
+;; We want to express pi/4 in 3 parts such that the sum of the parts
+;; is exactly the value of pi to the higher precision.  For
+;; double-double, we want 53 bits in each part.
+;;
+;; pi/4 in hex is
+;;
+;; C90FDAA22168C234C4C6628B80DC1CD129024E088A67CC74020BBEA63B139B22514A08798E3404DDEF9519B3CD3A431B302B0A6DF25F14374FE1356D6D51C245E485B576625E7EC6F44C42E9A637ED6B0BFF5CB6F406B7EDEE386BFB5A899FA5AE9F2411
+;;
+;; 
+#||
+(let* ((frac #xC90FDAA22168C234C4C6628B80DC1CD129024E088A67CC74020BBEA63B139B22514A08798E3404DDEF9519B3CD3A431B302B0A6DF25F14374FE1356D6D51C245E485B576625E7EC6F44C42E9A637ED6B0BFF5CB6F406B7EDEE386BFB5A899FA5AE9F2411)
+       (len (integer-length frac)))
+  (format t "len = ~D bits~%" len)
+  (format t "pi/4    ~,,' ,106:b~%" (ldb (byte (* 4 106) (- len (* 4 106))) frac)))
+->
+pi/4    11001001000011111101101010100010001000010110100011000 01000110100110001001100011001100010100010111000000011 01110000011100110100010010100100000010010011100000100 01000101001100111110011000111010000000010000010111011
+
+||#
+;; d1 = (scale-float (float #b1100100100001111110110101010001000100001011010001100001000110100110001001100011001100010100010111000000011 1w0) -106)
+;; d2 = (scale-float (float #b0111000001110011010001001010010000001001001110000010001000101001100111110011000111010000000010000010111011 1w0) (* 2 -106))
+;; d3 = (scale-float (float #b1110101001100011101100010011100110110010001001010001010010100000100001111001100011100011010000000100110111 1w0) (* 3 -106))
+;; d4 = (scale-float (float #b0111101111100101010001100110110011110011010011101001000011000110110011000000101011000010100110110111110010 1w0) (* 4 -106))
+
+;; sin(x) = x + x^3 P(x^2)
+;; Theoretical peak relative error = 5.6e-39
+;; relative peak error spread = 1.7e-9
+
+(defconstant sincof
+  (make-array 12 :element-type 'double-double-float
+	      :initial-contents
+	      '(
+		6.410290407010279602425714995528976754871w-26
+		-3.868105354403065333804959405965295962871w-23
+		1.957294039628045847156851410307133941611w-20
+		-8.220635246181818130416407184286068307901w-18
+		2.811457254345322887443598804951004537784w-15
+		-7.647163731819815869711749952353081768709w-13
+		1.605904383682161459812515654720205050216w-10
+		-2.505210838544171877505034150892770940116w-8
+		2.755731922398589065255731765498970284004w-6
+		-1.984126984126984126984126984045294307281w-4
+		8.333333333333333333333333333333119885283w-3
+		-1.666666666666666666666666666666666647199w-1
+		)))
+
+;; cos(x) = 1 - .5 x^2 + x^2 (x^2 P(x^2))
+;; Theoretical peak relative error = 2.1e-37,
+;; relative peak error spread = 1.4e-8
+
+(defconstant coscof
+  (make-array 11 :element-type 'double-double-float
+	      :initial-contents
+	      '(
+		1.601961934248327059668321782499768648351w-24
+		-8.896621117922334603659240022184527001401w-22
+		4.110317451243694098169570731967589555498w-19
+		-1.561920696747074515985647487260202922160w-16
+		4.779477332386900932514186378501779328195w-14
+		-1.147074559772972328629102981460088437917w-11
+		2.087675698786809897637922200570559726116w-9
+		-2.755731922398589065255365968070684102298w-7
+		2.480158730158730158730158440896461945271w-5
+		-1.388888888888888888888888888765724370132w-3
+		4.166666666666666666666666666666459301466w-2
+		)))
+
+(defconstant dp1
+  (scale-float (float #b1100100100001111110110101010001000100001011010001100001000110100110001001100011001100010100010111000000011 1w0) -106))
+
+(defconstant dp2
+  (scale-float (float #b0111000001110011010001001010010000001001001110000010001000101001100111110011000111010000000010000010111011 1w0) (* 2 -106)))
+
+(defconstant dp3
+  (scale-float (float #b1110101001100011101100010011100110110010001001010001010010100000100001111001100011100011010000000100110111 1w0) (* 3 -106)))
+
+(defconstant dp4
+  (scale-float (float #b0111101111100101010001100110110011110011010011101001000011000110110011000000101011000010100110110111110010 1w0) (* 4 -106)))
+
+(defun dd-%sin (x)
+  (declare (type double-double-float x))
+  (when (minusp x)
+    (return-from dd-%sin (- (the double-double-float (dd-%sin (- x))))))
+  ;; y = integer part of x/(pi/4).  
+  (let* ((y (float (floor (/ x dd-pi/4)) 1w0))
+	 (z (scale-float y -4)))
+    (declare (type double-double-float y z))
+    (setf z (float (floor z) 1w0))	; integer part of y/8
+    (setf z (- y (scale-float z 4)))	; y - 16*(y/16)
+
+    (let ((j (truncate z))
+	  (sign 1))
+      (unless (zerop (logand j 1))
+	(incf j)
+	(incf y))
+      (setf j (logand j 7))
+
+      (when (> j 3)
+	(setf sign (- sign))
+	(decf j 4))
+
+      ;; Extended precision modular arithmetic
+      (setf z (- (- (- x (* y dp1))
+		    (* y dp2))
+		 (* y dp3)))
+      (let ((zz (* z z)))
+	(if (or (= j 1)
+		(= j 2))
+	    (setf y (+ (- 1 (scale-float zz -1))
+		       (* zz zz (poly-eval zz coscof))))
+	    (setf y (+ z (* z (* zz (poly-eval zz sincof))))))
+	(if (< sign 0)
+	    (- y)
+	    y)))))
+
+(defun dd-%cos (x)
+  (declare (type double-double-float x)
+	   (optimize (speed 3)))
+  (when (minusp x)
+    (return-from dd-%cos (dd-%cos (- x))))
+  ;; y = integer part of x/(pi/4).  
+  (let* ((y (float (floor (/ x dd-pi/4)) 1w0))
+	 (z (scale-float y -4)))
+    (declare (type double-double-float y z))
+    (setf z (float (floor z) 1w0))	; integer part of y/8
+    (setf z (- y (scale-float z 4)))	; y - 16*(y/16)
+
+    (let ((i (truncate z))
+	  (j 0)
+	  (sign 1))
+      (declare (type (integer 0 7) j)
+	       (type (integer -1 1) sign))
+      (unless (zerop (logand i 1))
+	(incf i)
+	(incf y))
+      (setf j (logand i 7))
+
+      (when (> j 3)
+	(setf sign (- sign))
+	(decf j 4))
+      (when (> j 1)
+	(setf sign (- sign)))
+
+      ;; Extended precision modular arithmetic.  This is basically
+      ;; computing x - y*(pi/4) accurately so that |z| < pi/4.
+      (setf z (- (- (- x (* y dp1))
+		    (* y dp2))
+		 (* y dp3)))
+      (let ((zz (* z z)))
+	(if (or (= j 1)
+		(= j 2))
+	    (setf y (+ z (* z (* zz (poly-eval zz sincof)))))
+	    (setf y (+ (- 1 (scale-float zz -1))
+		       (* zz (poly-eval zz coscof) zz))))
+	(if (< sign 0)
+	    (- y)
+	    y)))))
+
+(let ((P (make-array 6 :element-type 'double-double-float
+		     :initial-contents
+		     '(
+		       -9.889929415807650724957118893791829849557w-1
+		       1.272297782199996882828849455156962260810w3
+		       -4.249691853501233575668486667664718192660w5
+		       5.160188250214037865511600561074819366815w7
+		       -2.307030822693734879744223131873392503321w9
+		       2.883414728874239697964612246732416606301w10
+		       )))
+      (Q (make-array 6 :element-type 'double-double-float
+		     :initial-contents
+		     '(
+		       ;; 1.000000000000000000000000000000000000000w0 */
+		       -1.317243702830553658702531997959756728291w3
+		       4.529422062441341616231663543669583527923w5
+		       -5.733709132766856723608447733926138506824w7
+		       2.758476078803232151774723646710890525496w9
+		       -4.152206921457208101480801635640958361612w10
+		       8.650244186622719093893836740197250197602w10
+		       ))))
+  (defun dd-tancot (xx cotflag)
+    (declare (type double-double-float xx)
+	     (optimize (speed 3)))
+    (let ((x 0w0)
+	  (sign 1))
+      (declare (type double-double-float x)
+	       (type (integer -1 1) sign))
+      (cond ((minusp xx)
+	     (setf x (- xx))
+	     (setf sign -1))
+	    (t
+	     (setf x xx)))
+      (let* ((y (float (floor (/ x dd-pi/4)) 1w0))
+	     (z (scale-float y -4))
+	     (j 0))
+	(declare (type double-double-float y z)
+		 (type fixnum j))
+	(setf z (float (floor z) 1w0))
+	(setf z (- y (scale-float z 4)))
+
+	(setf j (truncate z))
+
+	(unless (zerop (logand j 1))
+	  (incf j)
+	  (incf y))
+
+	(setf z (- (- (- x (* y dp1))
+		      (* y dp2))
+		   (* y dp3)))
+	(let ((zz (* z z)))
+	  (if (> zz 1w-40)
+	      (setf y (+ z
+			 (* z (* zz (/ (poly-eval zz p)
+				       (poly-eval-1 zz q))))))
+	      (setf y z))
+	  (if (not (zerop (logand j 2)))
+	      (if cotflag
+		  (setf y (- y))
+		  (setf y (/ -1 y)))
+	      (if cotflag
+		  (setf y (/ y))))
+	  (if (< sign 0)
+	      (- y)
+	      y))))))
+
+(defun dd-%tan (x)
+  (declare (type double-double-float x))
+  (dd-tancot x nil))
+
+;;; dd-%log2
+;;; Base 2 logarithm.
+
+(let ((P (make-array 13 :element-type 'double-double-float
+		     :initial-contents
+		     '(
+		       1.538612243596254322971797716843006400388w-6
+		       4.998469661968096229986658302195402690910w-1
+		       2.321125933898420063925789532045674660756w1
+		       4.114517881637811823002128927449878962058w2
+		       3.824952356185897735160588078446136783779w3
+		       2.128857716871515081352991964243375186031w4
+		       7.594356839258970405033155585486712125861w4
+		       1.797628303815655343403735250238293741397w5
+		       2.854829159639697837788887080758954924001w5
+		       3.007007295140399532324943111654767187848w5
+		       2.014652742082537582487669938141683759923w5
+		       7.771154681358524243729929227226708890930w4
+		       1.313572404063446165910279910527789794488w4
+		       )))
+      (Q (make-array 12 :element-type 'double-double-float
+		     :initial-contents
+		     '(
+		       ;; 1.000000000000000000000000000000000000000w0
+		       4.839208193348159620282142911143429644326w1
+		       9.104928120962988414618126155557301584078w2
+		       9.147150349299596453976674231612674085381w3
+		       5.605842085972455027590989944010492125825w4
+		       2.248234257620569139969141618556349415120w5
+		       6.132189329546557743179177159925690841200w5
+		       1.158019977462989115839826904108208787040w6
+		       1.514882452993549494932585972882995548426w6
+		       1.347518538384329112529391120390701166528w6
+		       7.777690340007566932935753241556479363645w5
+		       2.626900195321832660448791748036714883242w5
+		       3.940717212190338497730839731583397586124w4
+		       )))
+      ;; Coefficients for log(x) = z + z^3 P(z^2)/Q(z^2),
+      ;; where z = 2(x-1)/(x+1)
+      ;; 1/sqrt(2) <= x < sqrt(2)
+      ;; Theoretical peak relative error = 1.1e-35,
+      ;; relative peak error spread 1.1e-9
+      (R (make-array 6 :element-type 'double-double-float
+		     :initial-contents
+		     '(
+		       -8.828896441624934385266096344596648080902w-1
+		       8.057002716646055371965756206836056074715w1
+		       -2.024301798136027039250415126250455056397w3
+		       2.048819892795278657810231591630928516206w4
+		       -8.977257995689735303686582344659576526998w4
+		       1.418134209872192732479751274970992665513w5
+		       )))
+      (S (make-array 6 :element-type 'double-double-float
+		     :initial-contents
+		     '(
+		       ;; 1.000000000000000000000000000000000000000w0 */
+		       -1.186359407982897997337150403816839480438w2
+		       3.998526750980007367835804959888064681098w3
+		       -5.748542087379434595104154610899551484314w4
+		       4.001557694070773974936904547424676279307w5
+		       -1.332535117259762928288745111081235577029w6
+		       1.701761051846631278975701529965589676574w6
+		       ))))
+  (defun dd-%log2 (x)
+    (declare (type double-double-float x)
+	     (optimize (speed 3)))
+    (multiple-value-bind (x e)
+	(decode-float x)
+      (declare (type double-double-float x)
+	       (type double-float-exponent e))
+      (let ((z 0w0)
+	    (y 0w0))
+	(declare (type double-double-float z y))
+	(cond ((or (> e 2)
+		   (< e -2))
+	       (cond ((< x sqrt-1/2)
+		      ;; 2*(2*x-1)/(2*x+1)
+		      (decf e)
+		      (setf z (- x 0.5w0))
+		      (setf y (+ (* 0.5w0 z) 0.5w0)))
+		     (t
+		      ;; 2*(x-1)/(x+1)
+		      (setf z (- x 0.5w0))
+		      (decf z 0.5w0)
+		      (setf y (+ (* 0.5w0 z) 0.5w0))))
+	       (setf x (/ z y))
+	       (setf z (* x x))
+	       (setf y (* x (/ (* z (poly-eval z r))
+			       (poly-eval-1 z s)))))
+	      (t
+	       (cond ((< x sqrt-1/2)
+		      (decf e)
+		      (setf x (- (scale-float x 1) 1)))
+		     (t
+		      (decf x)))
+	       (setf z (* x x))
+	       (setf y (* x (/ (* z (poly-eval x p))
+			       (poly-eval-1 x q))))
+	       (decf y (scale-float z -1))))
+	;; Multiply log of fraction by log2(e) and base 2 exponent by 1
+	;;
+	;; This sequence of operations is critical
+	(setf z (* y log2ea))
+	(setf z (+ z (* x log2ea)))
+	(setf z (+ z y))
+	(setf z (+ z x))
+	(setf z (+ z e))
+	z))))
+
+;;; dd-%exp2
+;;; 2^x
+
+(let ((P (make-array 5 :element-type 'double-double-float
+		     :initial-contents
+		     '(
+		       1.587171580015525194694938306936721666031w2
+		       6.185032670011643762127954396427045467506w5
+		       5.677513871931844661829755443994214173883w8
+		       1.530625323728429161131811299626419117557w11
+		       9.079594442980146270952372234833529694788w12
+		       )))
+      (Q (make-array 5 :element-type 'double-double-float
+		     :initial-contents
+		     '(
+		       ;; 1.000000000000000000000000000000000000000w0 */
+		       1.236602014442099053716561665053645270207w4
+		       2.186249607051644894762167991800811827835w7
+		       1.092141473886177435056423606755843616331w10
+		       1.490560994263653042761789432690793026977w12
+		       2.619817175234089411411070339065679229869w13
+		       ))))
+  (defun dd-%exp2 (x)
+    (declare (type double-double-float x)
+	     (optimize (speed 3)))
+    (when (>= x 1024w0)
+      (return-from dd-%exp2
+	(%make-double-double-float ext:double-float-positive-infinity
+				   ext:double-float-positive-infinity)))
+    (when (<= x -1024w0)
+      (return-from dd-%exp2 0w0))
+    (multiple-value-bind (n x)
+	(floor (the (double-double-float -1024w0 1024w0) x))
+      (declare (type double-double-float x))
+      (let* ((xx (* x x))
+	     (px (* x (poly-eval xx p))))
+	(setf x (/ px (- (poly-eval-1 xx q) px)))
+	(setf x (+ 1 (scale-float x 1)))
+	(scale-float x n)))))
+
+;;; dd-%powil
+;;; x^n where n is an integer
+
+(defun dd-%powil (x nn)
+  (declare (type double-double-float x)
+	   (fixnum nn)
+	   (optimize (speed 3)))
+  (when (zerop x)
+    (return-from dd-%powil
+      (cond ((zerop nn)
+	     1w0)
+	    ((minusp nn)
+	     (%make-double-double-float ext:double-float-positive-infinity
+					ext:double-float-positive-infinity))
+	    (t
+	     0w0))))
+  (when (zerop nn)
+    (return-from dd-%powil 1w0))
+
+  (let ((asign 0)
+	(sign 0)
+	(n nn))
+    (declare (type (integer -1 0) asign sign)
+	     (fixnum n))
+    (when (minusp x)
+      (setf asign -1)
+      (setf x (- x)))
+    (cond ((minusp nn)
+	   (setf sign -1)
+	   (setf n (- nn)))
+	  (t
+	   (setf sign 0)
+	   (setf n nn)))
+    ;; Overflow detection
+
+    ;; Calculate approximate log of answer
+    (multiple-value-bind (s lx)
+	(decode-float x)
+      (declare (type double-double-float s)
+	       (type double-float-exponent lx))
+      (let ((e (* n (1- lx))))
+	(cond ((or (zerop e)
+		   (> e 64)
+		   (< e -64))
+	       (setf s (/ (- s 7.0710678118654752w-1)
+			  (+ s 7.0710678118654752w-1)))
+	       (setf s (* (+ (- (* 2.9142135623730950w0 s)
+				0.5w0)
+			     lx)
+			  nn log2e)))
+	      (t
+	       (setf s (* loge2 e))))
+	(when (> s max-log)
+	  ;; Overflow.  What to do?
+	  (error "Overflow"))
+	(when (< s min-log)
+	  (return-from dd-%powil 0w0))
+
+	;; Handle denormal answer
+	(when (< s (- 2 max-log))
+	  (setf x (/ x))
+	  (setf sign 0))
+
+	;; First bit of the power
+	(let ((y 0w0))
+	  (declare (type double-double-float y))
+	  (cond ((zerop (logand n 1))
+		 (setf y 1w0)
+		 (setf asign 0))
+		(t
+		 (setf y x)))
+	  (let ((w x))
+	    (declare (type double-double-float w))
+	    (setf n (ash n -1))
+	    (loop while (not (zerop n))
+	       do
+	       (setf w (* w w))
+	       (unless (zerop (logand n 1))
+		 (setf y (* y w)))
+	       (setf n (ash n -1))))
+	  ;; Odd power of a negative number
+	  (unless (zerop asign)
+	    (setf y (- y)))
+
+	  (unless (zerop sign)
+	    (setf y (/ y)))
+	  y)))))
+	
+
+;;; dd-real-pow
+;;; x^y, for x and y real, and real result.
+
+(defun dd-real-pow (x y)
+  (declare (type double-double-float x y)
+	   (optimize (speed 3)))
+  (let ((nflg 0)
+	(w (floor y)))
+    ;; nflg = 1 if x < 0 raised to integer power
+    (when (and (= w y)
+	       (< (abs w) 32768))
+      (return-from dd-real-pow (dd-%powil x w)))
+
+    (when (<= x 0)
+      (cond ((zerop x)
+	     (if (zerop y)
+		 ;; 0^0
+		 (return-from dd-real-pow 1w0)
+		 ;; 0^y
+		 (return-from dd-real-pow 0w0)))
+	    (t
+	     (when (/= w y)
+	       ;; noninteger power of negative number
+	       (let ((p (the double-double-float (dd-real-pow (abs x) y)))
+		     (y*pi (* y dd-pi)))
+		 (return-from dd-real-pow (complex (* p (dd-%cos y*pi))
+						   (* p (dd-%sin y*pi))))))
+
+	     ;; For negative x, find out if the integer exponent is odd or even.
+	     (let ((w (scale-float y -1)))
+	       (declare (type double-double-float w))
+	       (setf w (ffloor w))
+	       (setf w (scale-float w 1))
+	       (when (/= w y)
+		 (setf nflg 1))
+	       (setf x (abs x))))))
+    (let ((z (dd-%log2 x)))
+      (declare (type double-double-float z))
+      (setf z (dd-%exp2 (* y z)))
+      (unless (zerop nflg)
+	(setf z (- z)))
+      z)))
+
+(defun dd-%pow (x y)
+  (declare (type double-double-float x y))
+  (dd-real-pow x y))
+
+
+;; These are essentially the same as in irrat.lisp, but very slightly
+;; modified to operate on double-double-floats.
+(defun dd-cssqs (z)
+  ;; Compute |(x+i*y)/2^k|^2 scaled to avoid over/underflow. The
+  ;; result is r + i*k, where k is an integer.
+  
+  ;; Save all FP flags
+  (let ((x (float (realpart z) 1w0))
+	(y (float (imagpart z) 1w0)))
+    ;; Would this be better handled using an exception handler to
+    ;; catch the overflow or underflow signal?  For now, we turn all
+    ;; traps off and look at the accrued exceptions to see if any
+    ;; signal would have been raised.
+    (with-float-traps-masked (:underflow :overflow)
+      (let ((rho (+ (square x) (square y))))
+	(declare (optimize (speed 3) (space 0)))
+	(cond ((and (or (float-nan-p rho)
+			(float-infinity-p rho))
+		    (or (float-infinity-p (abs x))
+			(float-infinity-p (abs y))))
+	       (values (%make-double-double-float ext:double-float-positive-infinity 0w0)
+		       0))
+	      ((let ((threshold #.(/ least-positive-double-float
+				     double-float-epsilon))
+		     (traps (ldb vm::float-sticky-bits
+				 (vm:floating-point-modes))))
+		 ;; Overflow raised or (underflow raised and rho <
+		 ;; lambda/eps)
+		 (or (not (zerop (logand vm:float-overflow-trap-bit traps)))
+		     (and (not (zerop (logand vm:float-underflow-trap-bit traps)))
+			  (< rho threshold))))
+	       ;; If we're here, neither x nor y are infinity and at
+	       ;; least one is non-zero.. Thus logb returns a nice
+	       ;; integer.
+	       (let ((k (- (logb-finite (max (abs x) (abs y))))))
+		 (values (+ (square (scalb x k))
+			    (square (scalb y k)))
+			 (- k))))
+	      (t
+	       (values rho 0)))))))
+
+(defun dd-complex-sqrt (z)
+  "Principle square root of Z
+
+Z may be any number, but the result is always a complex."
+  (declare (number z))
+  (multiple-value-bind (rho k)
+      (dd-cssqs z)
+    (declare (type (or (member 0w0) (double-double-float 0w0)) rho)
+	     (type fixnum k))
+    (let ((x (float (realpart z) 1.0w0))
+	  (y (float (imagpart z) 1.0w0))
+	  (eta 0w0)
+	  (nu 0w0))
+      (declare (type double-double-float x y eta nu))
+
+      (locally
+	  ;; space 0 to get maybe-inline functions inlined.
+	  (declare (optimize (speed 3) (space 0)))
+
+	(if (not (float-nan-p x))
+	    (setf rho (+ (scalb (abs x) (- k)) (sqrt rho))))
+
+	(cond ((oddp k)
+	       (setf k (ash k -1)))
+	      (t
+	       (setf k (1- (ash k -1)))
+	       (setf rho (+ rho rho))))
+
+	(setf rho (scalb (sqrt rho) k))
+
+	(setf eta rho)
+	(setf nu y)
+
+	(when (/= rho 0d0)
+	  (when (not (float-infinity-p (abs nu)))
+	    (setf nu (/ (/ nu rho) 2d0)))
+	  (when (< x 0d0)
+	    (setf eta (abs nu))
+	    (setf nu (float-sign y rho))))
+	(complex eta nu)))))
+
+(defun dd-complex-log-scaled (z j)
+  "Compute log(2^j*z).
+
+This is for use with J /= 0 only when |z| is huge."
+  (declare (number z)
+	   (fixnum j))
+  ;; The constants t0, t1, t2 should be evaluated to machine
+  ;; precision.  In addition, Kahan says the accuracy of log1p
+  ;; influences the choices of these constants but doesn't say how to
+  ;; choose them.  We'll just assume his choices matches our
+  ;; implementation of log1p.
+  (let ((t0 #.(/ 1 (sqrt 2.0w0)))
+	(t1 1.2w0)
+	(t2 3w0)
+	(ln2 #.(log 2w0))
+	(x (float (realpart z) 1.0w0))
+	(y (float (imagpart z) 1.0w0)))
+    (multiple-value-bind (rho k)
+	(dd-cssqs z)
+      (declare (optimize (speed 3)))
+      (let ((beta (max (abs x) (abs y)))
+	    (theta (min (abs x) (abs y))))
+	(complex (if (and (zerop k)
+			  (< t0 beta)
+			  (or (<= beta t1)
+			      (< rho t2)))
+		     (/ (dd-%log1p (+ (* (- beta 1.0d0)
+					 (+ beta 1.0d0))
+				      (* theta theta)))
+			2d0)
+		     (+ (/ (log rho) 2d0)
+			(* (+ k j) ln2)))
+		 (atan y x))))))
+
+(defun dd-complex-log (z)
+  "Log of Z = log |Z| + i * arg Z
+
+Z may be any number, but the result is always a complex."
+  (declare (number z))
+  (dd-complex-log-scaled z 0))
+	       
+;; Let us note the following "strange" behavior.  atanh 1.0d0 is
+;; +infinity, but the following code returns approx 176 + i*pi/4. The
+;; reason for the imaginary part is caused by the fact that arg i*y is
+;; never 0 since we have positive and negative zeroes.
+
+(defun dd-complex-atanh (z)
+  "Compute atanh z = (log(1+z) - log(1-z))/2"
+  (declare (number z))
+  (if (and (realp z) (< z -1))
+      ;; atanh is continuous in quadrant III in this case.
+      (dd-complex-atanh (complex z -0f0))
+      (let* ( ;; Constants
+	     (theta (/ (sqrt most-positive-double-float) 4.0w0))
+	     (rho (/ 4.0w0 (sqrt most-positive-double-float)))
+	     (half-pi dd-pi/2)
+	     (rp (float (realpart z) 1.0w0))
+	     (beta (float-sign rp 1.0w0))
+	     (x (* beta rp))
+	     (y (* beta (- (float (imagpart z) 1.0w0))))
+	     (eta 0.0w0)
+	     (nu 0.0w0))
+	;; Shouldn't need this declare.
+	(declare (double-double-float x y))
+	(locally
+	    (declare (optimize (speed 3)))
+	  (cond ((or (> x theta)
+		     (> (abs y) theta))
+		 ;; To avoid overflow...
+		 (setf nu (float-sign y half-pi))
+		 ;; eta is real part of 1/(x + iy).  This is x/(x^2+y^2),
+		 ;; which can cause overflow.  Arrange this computation so
+		 ;; that it won't overflow.
+		 (setf eta (let* ((x-bigger (> x (abs y)))
+				  (r (if x-bigger (/ y x) (/ x y)))
+				  (d (+ 1.0d0 (* r r))))
+			     (if x-bigger
+				 (/ (/ x) d)
+				 (/ (/ r y) d)))))
+		((= x 1.0w0)
+		 ;; Should this be changed so that if y is zero, eta is set
+		 ;; to +infinity instead of approx 176?  In any case
+		 ;; tanh(176) is 1.0d0 within working precision.
+		 (let ((t1 (+ 4w0 (square y)))
+		       (t2 (+ (abs y) rho)))
+		   (setf eta (dd-%log (/ (sqrt (sqrt t1))
+					 (sqrt t2))))
+		   (setf nu (* 0.5d0
+			       (float-sign y
+					   (+ half-pi (dd-%atan (* 0.5d0 t2))))))))
+		(t
+		 (let ((t1 (+ (abs y) rho)))
+		   ;; Normal case using log1p(x) = log(1 + x)
+		   (setf eta (* 0.25d0
+				(dd-%log1p (/ (* 4.0d0 x)
+					      (+ (square (- 1.0d0 x))
+						 (square t1))))))
+		   (setf nu (* 0.5d0
+			       (dd-%atan2 (* 2.0d0 y)
+					  (- (* (- 1.0d0 x)
+						(+ 1.0d0 x))
+					     (square t1))))))))
+	  (complex (* beta eta)
+		   (- (* beta nu)))))))
+
+(defun dd-complex-tanh (z)
+  "Compute tanh z = sinh z / cosh z"
+  (declare (number z))
+  (let ((x (float (realpart z) 1.0w0))
+	(y (float (imagpart z) 1.0w0)))
+    (locally
+	;; space 0 to get maybe-inline functions inlined
+	(declare (optimize (speed 3) (space 0)))
+      (cond ((> (abs x)
+		#-(or linux hpux) #.(/ (%asinh most-positive-double-float) 4d0)
+		;; This is more accurate under linux.
+		#+(or linux hpux) #.(/ (+ (%log 2.0d0)
+					  (%log most-positive-double-float)) 4d0))
+	     (complex (float-sign x)
+		      (float-sign y)))
+	    (t
+	     (let* ((tv (dd-%tan y))
+		    (beta (+ 1.0d0 (* tv tv)))
+		    (s (sinh x))
+		    (rho (sqrt (+ 1.0d0 (* s s)))))
+	       (if (float-infinity-p (abs tv))
+		   (complex (/ rho s)
+			    (/ tv))
+		   (let ((den (+ 1.0d0 (* beta s s))))
+		     (complex (/ (* beta rho s)
+				 den)
+			      (/ tv den))))))))))
+
+;; Kahan says we should only compute the parts needed.  Thus, the
+;; realpart's below should only compute the real part, not the whole
+;; complex expression.  Doing this can be important because we may get
+;; spurious signals that occur in the part that we are not using.
+;;
+;; However, we take a pragmatic approach and just use the whole
+;; expression.
+
+;; NOTE: The formula given by Kahan is somewhat ambiguous in whether
+;; it's the conjugate of the square root or the square root of the
+;; conjugate.  This needs to be checked.
+
+;; I checked.  It doesn't matter because (conjugate (sqrt z)) is the
+;; same as (sqrt (conjugate z)) for all z.  This follows because
+;;
+;; (conjugate (sqrt z)) = exp(0.5*log |z|)*exp(-0.5*j*arg z).
+;;
+;; (sqrt (conjugate z)) = exp(0.5*log|z|)*exp(0.5*j*arg conj z)
+;;
+;; and these two expressions are equal if and only if arg conj z =
+;; -arg z, which is clearly true for all z.
+
+;; NOTE: The rules of Common Lisp says that if you mix a real with a
+;; complex, the real is converted to a complex before performing the
+;; operation.  However, Kahan says in this paper (pg 176):
+;;
+;; (iii) Careless handling can turn infinity or the sign of zero into
+;;       misinformation that subsequently disappears leaving behind
+;;       only a plausible but incorrect result.  That is why compilers
+;;       must not transform z-1 into z-(1+i*0), as we have seen above,
+;;       nor -(-x-x^2) into (x+x^2), as we shall see below, lest a
+;;       subsequent logarithm or square root produce a non-zero
+;;       imaginary part whose sign is opposite to what was intended.
+;;
+;; The interesting examples are too long and complicated to reproduce
+;; here.  We refer the reader to his paper.
+;;
+;; The functions below are intended to handle the cases where a real
+;; is mixed with a complex and we don't want CL complex contagion to
+;; occur..
+
+(declaim (inline 1+z 1-z z-1 z+1))
+(defun dd-1+z (z)
+  (complex (+ 1 (realpart z)) (imagpart z)))
+(defun dd-1-z (z)
+  (complex (- 1 (realpart z)) (- (imagpart z))))
+(defun dd-z-1 (z)
+  (complex (- (realpart z) 1) (imagpart z)))
+(defun dd-z+1 (z)
+  (complex (+ (realpart z) 1) (imagpart z)))
+
+(defun dd-complex-acos (z)
+  "Compute acos z = pi/2 - asin z
+
+Z may be any number, but the result is always a complex."
+  (declare (number z))
+  (if (and (realp z) (> z 1))
+      ;; acos is continuous in quadrant IV in this case.
+      (complex-acos (complex z -0f0))
+      (let ((sqrt-1+z (complex-sqrt (1+z z)))
+	    (sqrt-1-z (complex-sqrt (1-z z))))
+	(cond ((zerop (realpart sqrt-1+z))
+	       ;; Same as below, but we compute atan ourselves (because we
+	       ;; have atan +/- infinity).
+	       (complex 
+			(if (minusp (float-sign (* (realpart sqrt-1-z)
+						   (realpart sqrt-1+z))))
+			    (- dd-pi)
+			    dd-pi)
+			(asinh (imagpart (* (conjugate sqrt-1+z)
+					    sqrt-1-z)))))
+	      (t
+	       (complex (* 2 (atan (/ (realpart sqrt-1-z)
+				      (realpart sqrt-1+z))))
+			(asinh (imagpart (* (conjugate sqrt-1+z)
+					    sqrt-1-z)))))))))
+
+(defun dd-complex-acosh (z)
+  "Compute acosh z = 2 * log(sqrt((z+1)/2) + sqrt((z-1)/2))
+
+Z may be any number, but the result is always a complex."
+  (declare (number z))
+  (let* ((sqrt-z-1 (complex-sqrt (z-1 z)))
+	 (sqrt-z+1 (complex-sqrt (z+1 z))))
+    ;; We need to handle the case where real part of sqrt-z+1 is zero,
+    ;; because division by zero with double-double-floats doesn't
+    ;; produce infinity.
+    (cond ((zerop (realpart sqrt-z+1))
+	   ;; Same as below, but we compute atan ourselves (because we
+	   ;; have atan +/- infinity).
+	   (complex (asinh (realpart (* (conjugate sqrt-z-1)
+					sqrt-z+1)))
+		    (if (minusp (float-sign (* (imagpart sqrt-z-1)
+					       (realpart sqrt-z+1))))
+			(- dd-pi)
+			dd-pi)))
+	  (t
+	   (complex (asinh (realpart (* (conjugate sqrt-z-1)
+					sqrt-z+1)))
+		    (* 2 (atan (/ (imagpart sqrt-z-1)
+				  (realpart sqrt-z+1)))))))))
+
+
+(defun dd-complex-asin (z)
+  "Compute asin z = asinh(i*z)/i
+
+Z may be any number, but the result is always a complex."
+  (declare (number z))
+  (if (and (realp z) (> z 1))
+      ;; asin is continuous in quadrant IV in this case.
+      (dd-complex-asin (complex z -0f0))
+      (let* ((sqrt-1-z (complex-sqrt (1-z z)))
+	     (sqrt-1+z (complex-sqrt (1+z z)))
+	     (den (realpart (* sqrt-1-z sqrt-1+z))))
+	(cond ((zerop den)
+	       ;; Like below but we handle atan part ourselves.
+	       (complex (if (minusp (float-sign den))
+			    (- dd-pi/2)
+			    dd-pi/2)
+		   (asinh (imagpart (* (conjugate sqrt-1-z)
+				       sqrt-1+z)))))
+	      (t
+	       (with-float-traps-masked (:divide-by-zero)
+		 ;; We get a invalid operation here when z is real and |z| > 1.
+		 (complex (atan (/ (realpart z)
+				   (realpart (* sqrt-1-z sqrt-1+z))))
+			  (asinh (imagpart (* (conjugate sqrt-1-z)
+					      sqrt-1+z))))))))))
+
+(defun dd-complex-asinh (z)
+  "Compute asinh z = log(z + sqrt(1 + z*z))
+
+Z may be any number, but the result is always a complex."
+  (declare (number z))
+  ;; asinh z = -i * asin (i*z)
+  (let* ((iz (complex (- (imagpart z)) (realpart z)))
+	 (result (complex-asin iz)))
+    (complex (imagpart result)
+	     (- (realpart result)))))
+	 
+(defun dd-complex-atan (z)
+  "Compute atan z = atanh (i*z) / i
+
+Z may be any number, but the result is always a complex."
+  (declare (number z))
+  ;; atan z = -i * atanh (i*z)
+  (let* ((iz (complex (- (imagpart z)) (realpart z)))
+	 (result (complex-atanh iz)))
+    (complex (imagpart result)
+	     (- (realpart result)))))
+
+(defun dd-complex-tan (z)
+  "Compute tan z = -i * tanh(i * z)
+
+Z may be any number, but the result is always a complex."
+  (declare (number z))
+  ;; tan z = -i * tanh(i*z)
+  (let* ((iz (complex (- (imagpart z)) (realpart z)))
+	 (result (complex-tanh iz)))
+    (complex (imagpart result)
+	     (- (realpart result)))))
diff --git a/code/irrat.lisp b/code/irrat.lisp
index 997e04538a59f2b9e5746ebc5a932fcb8a2aa223..25087903e93d6c07a14be4827273574a2118e94b 100644
--- a/code/irrat.lisp
+++ b/code/irrat.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/irrat.lisp,v 1.45 2006/05/15 23:56:11 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/irrat.lisp,v 1.46 2006/06/30 18:41:22 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -46,7 +46,10 @@
   `((((foreach fixnum single-float bignum ratio))
      (coerce (,function (coerce ,var 'double-float)) 'single-float))
     ((double-float)
-     (,function ,var))))
+     (,function ,var))
+    #+double-double
+    ((double-double-float)
+     (,(symbolicate "DD-" function) ,var))))
 
 ); eval-when (compile load eval)
 
@@ -361,16 +364,25 @@
 	 (real-expt base power 'double-float))
 	((double-float single-float)
 	 (real-expt base power 'double-float))
+	#+double-double
+	(((foreach fixnum (or bignum ratio) single-float double-float double-double-float)
+	  double-double-float)
+	 (dd-%pow (coerce base 'double-double-float) power))
+	#+double-double
+	((double-double-float
+	  (foreach fixnum (or bignum ratio) single-float double-float))
+	 (dd-%pow base (coerce power 'double-double-float)))
 	(((foreach (complex rational) (complex float)) rational)
 	 (* (expt (abs base) power)
 	    (cis (* power (phase base)))))
-	(((foreach fixnum (or bignum ratio) single-float double-float)
+	(((foreach fixnum (or bignum ratio) single-float double-float
+		   #+double-double double-double-float)
 	  complex)
 	 (if (and (zerop base) (plusp (realpart power)))
 	     (* base power)
 	     (exp (* power (log base)))))
 	(((foreach (complex float) (complex rational))
-	  (foreach complex double-float single-float))
+	  (foreach complex double-float single-float #+double-double double-double-float))
 	 (if (and (zerop base) (plusp (realpart power)))
 	     (* base power)
 	     (exp (* power (log base)))))))))
@@ -422,6 +434,14 @@
 	       (((foreach single-float fixnum bignum ratio)
 		 double-float)
 		(/ (log (coerce number 'double-float)) (log base)))
+	       #+double-double
+	       ((double-double-float
+		 (foreach double-double-float double-float single-float fixnum bignum ratio))
+		(/ (log number) (log (coerce base 'double-double-float))))
+	       #+double-double
+	       (((foreach double-float single-float fixnum bignum ratio)
+		 double-double-float)
+		(/ (log (coerce number 'double-double-float)) (log base)))
 	       (((foreach single-float fixnum bignum ratio)
 		 (foreach single-float fixnum bignum ratio))
 		;; Converting everything to double-float helps the
@@ -481,6 +501,12 @@
 	     (complex (log (- number)) (coerce pi '(dispatch-type number)))
 	     (coerce (%log (coerce number 'double-float))
 		     '(dispatch-type number))))
+	#+double-double
+	((double-double-float)
+	 (let ((hi (kernel:double-double-hi number)))
+	   (if (< (float-sign hi) 0d0)
+	       (complex (dd-%log (- number)) dd-pi)
+	       (dd-%log number))))
 	((complex)
 	 (complex-log number)))))
 
@@ -496,8 +522,15 @@
 	 (complex-sqrt number)
 	 (coerce (%sqrt (coerce number 'double-float))
 		 '(dispatch-type number))))
-     ((complex)
-      (complex-sqrt number))))
+    #+double-double
+    ((double-double-float)
+     (if (minusp number)
+	 (dd-complex-sqrt number)
+	 (multiple-value-bind (hi lo)
+	     (c::sqrt-dd (kernel:double-double-hi number) (kernel:double-double-lo number))
+	   (kernel:make-double-double-float hi lo))))
+    ((complex)
+     (complex-sqrt number))))
 
 
 ;;;; Trigonometic and Related Functions
@@ -505,8 +538,25 @@
 (defun abs (number)
   "Returns the absolute value of the number."
   (number-dispatch ((number number))
-    (((foreach single-float double-float fixnum rational))
+    (((foreach single-float double-float fixnum rational
+	       #+double-double double-double-float))
      (abs number))
+    #+(and nil double-double)
+    ((double-double-float)
+     ;; This is a hack until abs deftransform is working
+     (multiple-value-bind (hi lo)
+	 (c::abs-dd (kernel:double-double-hi number) (kernel:double-double-lo number))
+       (kernel:make-double-double-float hi lo)))
+    #+(and nil double-double)
+    ((double-double-float)
+     ;; This is a hack until abs deftransform is working
+     (let ((hi (kernel:double-double-hi number))
+	   (lo (kernel:double-double-lo number)))
+       (declare (double-float hi lo))
+       (when (minusp hi)
+	 (setf hi (- hi))
+	 (setf lo (- lo)))
+       (kernel:make-double-double-float hi lo)))
     ((complex)
      (let ((rx (realpart number))
 	   (ix (imagpart number)))
@@ -518,7 +568,10 @@
 			  (coerce ix 'double-float))
 		  'single-float))
 	 (double-float
-	  (%hypot rx ix)))))))
+	  (%hypot rx ix))
+	 #+double-double
+	 (double-double-float
+	  (error "abs complex double-double-float not implemented!")))))))
 
 (defun phase (number)
   "Returns the angle part of the polar representation of a complex number.
@@ -538,6 +591,11 @@
      (if (minusp (float-sign number))
 	 (coerce pi 'double-float)
 	 0.0d0))
+    #+double-double
+    (double-double-float
+     (if (minusp (float-sign number))
+	 dd-pi
+	 0w0))
     (complex
      (atan (imagpart number) (realpart number)))))
 
@@ -588,7 +646,14 @@
 		  (>= number (coerce -1 '(dispatch-type number)))))
 	 (coerce (%asin (coerce number 'double-float))
 		 '(dispatch-type number))
-	 	 (complex-asin number)))
+	 (complex-asin number)))
+    #+double-double
+    ((double-double-float)
+     (if (or (float-nan-p number)
+	     (and (<= number 1w0)
+		  (>= number -1w0)))
+	 (dd-%asin number)
+	 (dd-complex-asin number)))
     ((complex)
      (complex-asin number))))
 
@@ -605,7 +670,14 @@
 		  (>= number (coerce -1 '(dispatch-type number)))))
 	 (coerce (%acos (coerce number 'double-float))
 		 '(dispatch-type number))
-	 	 (complex-acos number)))
+	 (complex-acos number)))
+    #+double-double
+    ((double-double-float)
+     (if (or (float-nan-p number)
+	     (and (<= number 1w0)
+		  (>= number -1w0)))
+	 (dd-%acos number)
+	 (complex-acos number)))
     ((complex)
      (complex-acos number))))
 
@@ -634,7 +706,15 @@
 	  (((foreach single-float fixnum bignum ratio)
 	    (foreach single-float fixnum bignum ratio))
 	   (coerce (atan2 (coerce y 'double-float) (coerce x 'double-float))
-		   'single-float))))
+		   'single-float))
+	  #+double-double
+	  ((double-double-float
+	    (foreach double-double-float double-float single-float fixnum bignum ratio))
+	   (dd-%atan2 y (coerce x 'double-double-float)))
+	  #+double-double
+	  (((foreach double-float single-float fixnum bignum ratio)
+	    double-double-float)
+	   (dd-%atan2 (coerce y 'double-double-float) x))))
       (number-dispatch ((y number))
 	(handle-reals %atan y)
 	((complex)
@@ -687,6 +767,11 @@
 	 (complex-acosh number)
 	 (coerce (%acosh (coerce number 'double-float))
 		 '(dispatch-type number))))
+    #+double-double
+    ((double-double-float)
+     (if (< number 1w0)
+	 (complex-acosh number)
+	 (dd-%acosh number)))
     ((complex)
      (complex-acosh number))))
 
@@ -704,6 +789,12 @@
 	 (complex-atanh number)
 	 (coerce (%atanh (coerce number 'double-float))
 		 '(dispatch-type number))))
+    #+double-double
+    ((double-double-float)
+     (if (or (> number 1w0)
+	     (< number -1w0))
+	 (complex-atanh number)
+	 (dd-%atanh (coerce number 'double-double-float))))
     ((complex)
      (complex-atanh number))))
 
@@ -773,7 +864,7 @@
 
 (declaim (inline square))
 (defun square (x)
-  (declare (double-float x))
+  (declare (float x))
   (* x x))
 
 ;; If you have these functions in libm, perhaps they should be used
@@ -784,7 +875,7 @@
 (defun scalb (x n)
   "Compute 2^N * X without compute 2^N first (use properties of the
 underlying floating-point format"
-  (declare (type double-float x)
+  (declare (type float x)
 	   (type double-float-exponent n))
   (scale-float x n))
 
@@ -792,7 +883,7 @@ underlying floating-point format"
 (defun logb-finite (x)
   "Same as logb but X is not infinity and non-zero and not a NaN, so
 that we can always return an integer"
-  (declare (type double-float x))
+  (declare (type float x))
   (multiple-value-bind (signif expon sign)
       (decode-float x)
     (declare (ignore signif sign))
@@ -809,7 +900,7 @@ For the special cases, the following values are used:
    +/- infinity   +infinity
    0              -infinity
 "
-  (declare (type double-float x))
+  (declare (type float x))
   (cond ((float-nan-p x)
 	 x)
 	((float-infinity-p x)
@@ -817,7 +908,7 @@ For the special cases, the following values are used:
 	((zerop x)
 	 ;; The answer is negative infinity, but we are supposed to
 	 ;; signal divide-by-zero, so do the actual division
-	 (/ -1.0d0 x)
+	 (/ -1 x)
 	 )
 	(t
 	 (logb-finite x))))
@@ -884,6 +975,9 @@ and Y are coerced to single-float."
 
 Z may be any number, but the result is always a complex."
   (declare (number z))
+  #+double-double
+  (when (typep z '(or double-double-float (complex double-double-float)))
+    (return-from complex-sqrt (dd-complex-sqrt z)))
   (multiple-value-bind (rho k)
       (cssqs z)
     (declare (type (or (member 0d0) (double-float 0d0)) rho)
@@ -960,6 +1054,9 @@ This is for use with J /= 0 only when |z| is huge."
 
 Z may be any number, but the result is always a complex."
   (declare (number z))
+  #+double-double
+  (when (typep z '(or double-double-float (complex double-double-float)))
+    (return-from complex-log (dd-complex-log-scaled z 0)))
   (complex-log-scaled z 0))
 	       
 ;; Let us note the following "strange" behavior.  atanh 1.0d0 is
@@ -970,6 +1067,10 @@ Z may be any number, but the result is always a complex."
 (defun complex-atanh (z)
   "Compute atanh z = (log(1+z) - log(1-z))/2"
   (declare (number z))
+  #+double-double
+  (when (typep z '(or double-double-float (complex double-double-float)))
+    (return-from complex-atanh (dd-complex-atanh z)))
+  
   (if (and (realp z) (< z -1))
       ;; atanh is continuous in quadrant III in this case.
       (complex-atanh (complex z -0f0))
@@ -1030,6 +1131,10 @@ Z may be any number, but the result is always a complex."
 (defun complex-tanh (z)
   "Compute tanh z = sinh z / cosh z"
   (declare (number z))
+  #+double-double
+  (when (typep z '(or double-double-float (complex double-double-float)))
+    (return-from complex-tanh (dd-complex-tanh z)))
+  
   (let ((x (float (realpart z) 1.0d0))
 	(y (float (imagpart z) 1.0d0)))
     (locally
@@ -1113,6 +1218,9 @@ Z may be any number, but the result is always a complex."
 
 Z may be any number, but the result is always a complex."
   (declare (number z))
+  #+double-double
+  (when (typep z '(or double-double-float (complex double-double-float)))
+    (return-from complex-acos (dd-complex-acos z)))
   (if (and (realp z) (> z 1))
       ;; acos is continuous in quadrant IV in this case.
       (complex-acos (complex z -0f0))
@@ -1143,6 +1251,9 @@ Z may be any number, but the result is always a complex."
 
 Z may be any number, but the result is always a complex."
   (declare (number z))
+  #+double-double
+  (when (typep z '(or double-double-float (complex double-double-float)))
+    (return-from complex-asin (dd-complex-asin z)))
   (if (and (realp z) (> z 1))
       ;; asin is continuous in quadrant IV in this case.
       (complex-asin (complex z -0f0))
@@ -1160,6 +1271,9 @@ Z may be any number, but the result is always a complex."
 Z may be any number, but the result is always a complex."
   (declare (number z))
   ;; asinh z = -i * asin (i*z)
+  #+double-double
+  (when (typep z '(or double-double-float (complex double-double-float)))
+    (return-from complex-asinh (dd-complex-asinh z)))
   (let* ((iz (complex (- (imagpart z)) (realpart z)))
 	 (result (complex-asin iz)))
     (complex (imagpart result)
@@ -1171,6 +1285,9 @@ Z may be any number, but the result is always a complex."
 Z may be any number, but the result is always a complex."
   (declare (number z))
   ;; atan z = -i * atanh (i*z)
+  #+double-double
+  (when (typep z '(or double-double-float (complex double-double-float)))
+    (return-from complex-atan (dd-complex-atan z)))
   (let* ((iz (complex (- (imagpart z)) (realpart z)))
 	 (result (complex-atanh iz)))
     (complex (imagpart result)
@@ -1182,6 +1299,9 @@ Z may be any number, but the result is always a complex."
 Z may be any number, but the result is always a complex."
   (declare (number z))
   ;; tan z = -i * tanh(i*z)
+  #+double-double
+  (when (typep z '(or double-double-float (complex double-double-float)))
+    (return-from complex-tan (dd-complex-tan z)))
   (let* ((iz (complex (- (imagpart z)) (realpart z)))
 	 (result (complex-tanh iz)))
     (complex (imagpart result)
diff --git a/code/kernel.lisp b/code/kernel.lisp
index ad4e52eb299b103b0106ca1f24cfda382ff4f4eb..eb517322cfe6d2be1332e5a76a570e11a7918f14 100644
--- a/code/kernel.lisp
+++ b/code/kernel.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/kernel.lisp,v 1.15 2005/06/19 02:48:08 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/kernel.lisp,v 1.16 2006/06/30 18:41:22 rtoy Rel $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -141,6 +141,31 @@
 #+long-float
 (defun make-long-float (exp hi #+sparc mid lo)
   (make-long-float exp hi #+sparc mid lo))
+
+#+double-double
+(defun %make-double-double-float (hi lo)
+  (%make-double-double-float hi lo))
+
+#+double-double
+(declaim (inline make-double-double-float))
+#+double-double
+(defun make-double-double-float (hi lo)
+  ;; Make sure the parts make sense for a double-double
+  (declare (double-float hi lo)
+	   (inline float-infinity-p float-nan-p))
+  (if (or (float-infinity-p hi) (float-nan-p hi))
+      (%make-double-double-float hi lo)
+      (multiple-value-bind (s e)
+	  (c::two-sum hi lo)
+	(%make-double-double-float s e))))
+
+#+double-double
+(defun double-double-hi (x)
+  (double-double-hi x))
+#+double-double
+(defun double-double-lo (x)
+  (double-double-lo x))
+
 (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))
diff --git a/code/lispinit.lisp b/code/lispinit.lisp
index 28eb09647d1bb64e9a53903020dd5f6d5dd43b5b..4cd582c65608e34dc5d368e9546e19ea62c19fff 100644
--- a/code/lispinit.lisp
+++ b/code/lispinit.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/lispinit.lisp,v 1.75 2004/10/19 20:13:30 cwang Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/lispinit.lisp,v 1.76 2006/06/30 18:41:22 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -41,6 +41,9 @@
 #+heap-overflow-check
 (sys:register-lisp-runtime-feature :heap-overflow-check)
 
+#+double-double
+(sys:register-lisp-feature :double-double)
+
 ;;; Make the error system enable interrupts.
 
 (defconstant most-positive-fixnum #.vm:target-most-positive-fixnum
diff --git a/code/load.lisp b/code/load.lisp
index 061e3fd23c1f982b1495e2a17523933e29ac3ef3..badc00ead527d494d9f52e13cbe691ef9d1485d7 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.90 2005/04/14 20:52:03 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/load.lisp,v 1.91 2006/06/30 18:41:22 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -874,6 +874,53 @@
 	  (make-long-float exp hi #+sparc mid lo))
       (done-with-fast-read-byte))))
 
+#+double-double
+(define-fop (fop-double-double-float 67)
+  (prepare-for-fast-read-byte *fasl-file*
+    (prog1
+	(let ((hi-lo (fast-read-u-integer 4))
+	      (hi-hi (fast-read-s-integer 4))
+	      (lo-lo (fast-read-u-integer 4))
+	      (lo-hi (fast-read-s-integer 4)))
+	  (kernel::make-double-double-float
+	   (make-double-float hi-hi hi-lo)
+	   (make-double-float lo-hi lo-lo)))
+      (done-with-fast-read-byte))))
+
+#+double-double
+(define-fop (fop-double-double-float-vector 88)
+  (let* ((length (read-arg 4))
+	 (result (make-array length :element-type 'double-double-float)))
+    (read-n-bytes *fasl-file* result 0 (* length vm:word-bytes 4))
+    result))
+
+#+double-double
+(define-fop (fop-complex-double-double-float 89)
+  (prepare-for-fast-read-byte *fasl-file*
+    (prog1
+	(let* ((real-hi-lo (fast-read-u-integer 4))
+	       (real-hi-hi (fast-read-s-integer 4))
+	       (real-lo-lo (fast-read-u-integer 4))
+	       (real-lo-hi (fast-read-s-integer 4))
+	       (re (kernel::make-double-double-float
+		    (make-double-float real-hi-hi real-hi-lo)
+		    (make-double-float real-lo-hi real-lo-lo)))
+	       (imag-hi-lo (fast-read-u-integer 4))
+	       (imag-hi-hi (fast-read-s-integer 4))
+	       (imag-lo-lo (fast-read-u-integer 4))
+	       (imag-lo-hi (fast-read-s-integer 4))
+	       (im (kernel::make-double-double-float
+		    (make-double-float imag-hi-hi imag-hi-lo)
+		    (make-double-float imag-lo-hi imag-lo-lo))))
+	  (complex re im)) 
+      (done-with-fast-read-byte))))
+
+#+double-double
+(define-fop (fop-complex-double-double-float-vector 90)
+  (let* ((length (read-arg 4))
+	 (result (make-array length :element-type '(complex double-double-float))))
+    (read-n-bytes *fasl-file* result 0 (* length vm:word-bytes 8))
+    result))
 
 ;;;; Loading lists:
 
diff --git a/code/numbers.lisp b/code/numbers.lisp
index 0ba4c361b7d320e9325af0910f6ce2398d5385fe..eebad8419159a188daaca6ccbaa0848a7267d740 100644
--- a/code/numbers.lisp
+++ b/code/numbers.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/numbers.lisp,v 1.60 2004/09/08 16:09:28 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/numbers.lisp,v 1.61 2006/06/30 18:41:22 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -76,7 +76,8 @@
 ;;; probable first.)
 ;;;
 (defconstant type-test-ordering
-  '(fixnum single-float double-float integer #+long-float long-float bignum
+  '(fixnum single-float double-float integer #+long-float long-float
+    #+double-double double-double-float bignum
     complex ratio))
 
 ;;; Type-Test-Order  --  Internal
@@ -167,8 +168,59 @@
 
 ;;;; Binary operation dispatching utilities:
 
+;; These are helper functions to get two-arg arithmetic working.
+#+double-double
+(progn
+(defun dd-+ (a b)
+  (multiple-value-bind (x y)
+      (c::add-dd (kernel:double-double-hi a)
+		 (kernel:double-double-lo a)
+		 (kernel:double-double-hi b)
+		 (kernel:double-double-lo b))
+    (make-double-double-float x y)))
+
+(defun dd-- (a b)
+  (multiple-value-bind (x y)
+      (c::sub-dd (kernel:double-double-hi a)
+		 (kernel:double-double-lo a)
+		 (kernel:double-double-hi b)
+		 (kernel:double-double-lo b))
+    (make-double-double-float x y)))
+
+(defun dd-* (a b)
+  (multiple-value-bind (x y)
+      (c::mul-dd (kernel:double-double-hi a)
+		 (kernel:double-double-lo a)
+		 (kernel:double-double-hi b)
+		 (kernel:double-double-lo b))
+    (make-double-double-float x y)))
+  
+(defun dd-/ (a b)
+  (multiple-value-bind (x y)
+      (c::div-dd (kernel:double-double-hi a)
+		 (kernel:double-double-lo a)
+		 (kernel:double-double-hi b)
+		 (kernel:double-double-lo b))
+    (make-double-double-float x y)))
+)
+
+
 (eval-when (compile eval)
 
+#+double-double
+(defun dd-contagion (op)  
+  (case op
+    (+ 'dd-+)
+    (- 'dd--)
+    (* 'dd-*)
+    (/ 'dd-/)
+    (otherwise op)))
+
+#+double-double
+(defun dd-contagion (op)  
+  op)
+
+
 ;;; FLOAT-CONTAGION  --  Internal
 ;;;
 ;;;    Return NUMBER-DISPATCH forms for rational X float.
@@ -176,9 +228,11 @@
 (defun float-contagion (op x y &optional (rat-types '(fixnum bignum ratio)))
   `(((single-float single-float) (,op ,x ,y))
     (((foreach ,@rat-types)
-      (foreach single-float double-float #+long-float long-float))
+      (foreach single-float double-float #+long-float long-float
+	       #+double-double double-double-float))
      (,op (coerce ,x '(dispatch-type ,y)) ,y))
-    (((foreach single-float double-float #+long-float long-float)
+    (((foreach single-float double-float #+long-float long-float
+	       #+double-double double-double-float)
       (foreach ,@rat-types))
      (,op ,x (coerce ,y '(dispatch-type ,x))))
     #+long-float
@@ -187,6 +241,12 @@
     #+long-float
     ((long-float (foreach single-float double-float))
      (,op ,x (coerce ,y 'long-float)))
+    #+double-double
+    (((foreach single-float double-float double-double-float) double-double-float)
+     (,(dd-contagion op) (coerce ,x 'double-double-float) ,y))
+    #+double-double
+    ((double-double-float (foreach single-float double-float))
+     (,(dd-contagion op) ,x (coerce ,y 'double-double-float)))
     (((foreach single-float double-float) double-float)
      (,op (coerce ,x 'double-float) ,y))
     ((double-float single-float)
@@ -225,6 +285,10 @@
 	    ((and (typep realpart 'long-float)
 		  (typep imagpart 'long-float))
 	     (truly-the (complex long-float) (complex realpart imagpart)))
+	    #+double-double
+	    ((and (typep realpart 'double-double-float)
+		  (typep imagpart 'double-double-float))
+	     (truly-the (complex double-double-float) (complex realpart imagpart)))
 	    ((and (typep realpart 'double-float)
 		  (typep imagpart 'double-float))
 	     (truly-the (complex double-float) (complex realpart imagpart)))
@@ -281,6 +345,9 @@
 	#+long-float
 	((subtypep spec 'long-float)
 	 'long-float)
+	#+double-double
+	((subtypep spec 'double-double-float)
+	 'double-double-float)
 	((subtypep spec 'rational)
 	 'rational)
 	((subtypep spec 'real)
@@ -310,6 +377,11 @@
 		       (typep imagpart 'long-float))
 		  (truly-the (complex long-float)
 			     (complex realpart imagpart)))
+		 #+double-double
+		 ((and (typep realpart 'double-double-float)
+		       (typep imagpart 'double-double-float))
+		  (truly-the (complex double-double-float)
+			     (complex realpart imagpart)))
 		 ((and (typep realpart 'double-float)
 		       (typep imagpart 'double-float))
 		  (truly-the (complex double-float)
@@ -331,6 +403,9 @@
     #+long-float
     ((complex long-float)
      (truly-the long-float (realpart number)))
+    #+double-double
+    ((complex double-double-float)
+     (truly-the double-double-float (realpart number)))
     ((complex double-float)
      (truly-the double-float (realpart number)))
     ((complex single-float)
@@ -346,6 +421,9 @@
     #+long-float
     ((complex long-float)
      (truly-the long-float (imagpart number)))
+    #+double-double
+    ((complex double-double-float)
+     (truly-the double-double-float (imagpart number)))
     ((complex double-float)
      (truly-the double-float (imagpart number)))
     ((complex single-float)
@@ -445,7 +523,9 @@
 			   (,op (imagpart x) (imagpart y))))
        
        (((foreach bignum fixnum ratio single-float double-float
-		  #+long-float long-float) complex)
+		  #+long-float long-float
+		  #+double-double double-double-float)
+	 complex)
 	(complex (,op x (realpart y)) (,op 0 (imagpart y))))
 		   
        ((complex (or rational float))
@@ -516,7 +596,8 @@
 	      (iy (imagpart y)))
 	 (canonical-complex (- (* rx ry) (* ix iy)) (+ (* rx iy) (* ix ry)))))
       (((foreach bignum fixnum ratio single-float double-float
-		 #+long-float long-float)
+		 #+long-float long-float
+		 #+double-double double-double-float)
 	complex)
        (complex*real y x))
       ((complex (or rational float))
@@ -630,6 +711,11 @@
   (number-dispatch ((n number))
     (((foreach fixnum single-float double-float #+long-float long-float))
      (%negate n))
+    #+double-double
+    ((double-double-float)
+     (multiple-value-bind (hi lo)
+	 (c::neg-dd (kernel:double-double-hi n) (kernel:double-double-lo n))
+       (kernel:make-double-double-float hi lo)))
     ((bignum)
      (negate-bignum n))
     ((ratio)
@@ -666,7 +752,8 @@
       ((bignum bignum)
        (bignum-truncate number divisor))
       
-      (((foreach single-float double-float #+long-float long-float)
+      (((foreach single-float double-float #+long-float long-float
+		 #+double-double double-double-float)
 	(or rational single-float))
        (if (eql divisor 1)
 	   (let ((res (%unary-truncate number)))
@@ -678,6 +765,12 @@
       #+long-float
       (((foreach double-float single-float) long-float)
        (truncate-float long-float))
+      #+double-double
+      ((double-double-float (or single-float double-float))
+       (truncate-float double-double-float))
+      #+double-double
+      (((foreach single-float double-float) double-double-float)
+       (truncate-float double-double-float))
       ((double-float (or single-float double-float))
        (truncate-float double-float))
       ((single-float double-float)
@@ -784,7 +877,7 @@
        (multiple-value-bind (q r)
 	   (truncate number divisor)
 	 (values (float q) r)))
-      (((foreach single-float double-float)
+      (((foreach single-float double-float #+double-double double-double-float)
 	(or rational single-float))
        (if (eql divisor 1)
 	   (let ((res (%unary-ftruncate number)))
@@ -795,8 +888,15 @@
       ((single-float double-float)
        (truncate-float double-float))
       (((foreach fixnum bignum ratio)
-	(foreach single-float double-float))
-       (truncate-float (dispatch-type divisor))))))
+	(foreach single-float double-float #+double-double double-double-float))
+       (truncate-float (dispatch-type divisor)))
+      #+double-double
+      ((double-double-float (or single-float double-float double-double-float))
+       (truncate-float double-double-float))
+      #+double-double
+      (((foreach single-float double-float)
+	double-double-float)
+       (truncate-float double-double-float)))))
 
 
 (defun ffloor (number &optional (divisor 1))
@@ -910,8 +1010,42 @@
      (declare (list nlist))
      (if (< (car nlist) result) (setq result (car nlist)))))
 
+;; These are helper functions to get two-arg comparison working
+#+double-double
+(progn
+(defun dd-< (a b)
+  (c::dd< (kernel:double-double-hi a)
+	       (kernel:double-double-lo a)
+	       (kernel:double-double-hi b)
+	       (kernel:double-double-lo b)))
+(defun dd-> (a b)
+  (c::dd> (kernel:double-double-hi a)
+	       (kernel:double-double-lo a)
+	       (kernel:double-double-hi b)
+	       (kernel:double-double-lo b)))
+(defun dd-= (a b)
+  (c::dd= (kernel:double-double-hi a)
+	       (kernel:double-double-lo a)
+	       (kernel:double-double-hi b)
+	       (kernel:double-double-lo b)))
+)
+
 (eval-when (compile eval)
 
+;; This is a hack to get two-arg comparison functions going.  Convert
+;; the op to equivalent dd op.  Once the deftransforms are in place,
+;; these should go away.
+#+nil
+(defun dd-op (op)
+  (case op
+    (< 'dd-<)
+    (> 'dd->)
+    (= 'dd-=)
+    (otherwise op)))
+
+(defun dd-op (op)
+  op)
+  
 (defun basic-compare (op)
   `(((fixnum fixnum) (,op x y))
 
@@ -922,11 +1056,19 @@
     #+long-float
     ((long-float (foreach single-float double-float))
      (,op x (coerce y 'long-float)))
+    #+double-double
+    (((foreach single-float double-float double-double-float) double-double-float)
+     (,(dd-op op) (coerce x 'double-double-float) y))
+    #+double-double
+    ((double-double-float (foreach single-float double-float))
+     (,(dd-op op) x (coerce y 'double-double-float)))
     (((foreach single-float double-float) double-float)
      (,op (coerce x 'double-float) y))
     ((double-float single-float)
      (,op x (coerce y 'double-float)))
-    (((foreach single-float double-float #+long-float long-float) rational)
+    (((foreach single-float double-float #+long-float long-float
+	       #+double-double double-double-float)
+      rational)
      ;; Comparing infinity against any rational produces the same
      ;; answer as comparing infinity against 0.  Comparison against
      ;; zero is quite common, so add a special case for that.
@@ -993,7 +1135,9 @@
      (and (= (realpart x) (realpart y))
 	  (= (imagpart x) (imagpart y))))
     (((foreach fixnum bignum ratio single-float double-float
-	       #+long-float long-float) complex)
+	       #+long-float long-float
+	       #+double-double double-double-float)
+      complex)
      (and (= x (realpart y))
 	  (zerop (imagpart y))))
     ((complex (or float rational))
diff --git a/code/pred.lisp b/code/pred.lisp
index 35b3c38b6262e7a6fffc031d9713a66ec6c8ab36..0a43965155dcd531a2333ff07e82d271cedfdfe1 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.59 2003/06/06 12:22:33 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pred.lisp,v 1.60 2006/06/30 18:41:22 rtoy Rel $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -16,7 +16,10 @@
 
 (in-package "KERNEL")
 (export '(%instancep instance fixnump bignump bitp ratiop weak-pointer-p
-		     %typep class-cell-typep))
+	  %typep class-cell-typep))
+
+#+double-double
+(export '(double-double-float-p))
 
 (in-package "SYSTEM")
 (export '(system-area-pointer system-area-pointer-p))
@@ -57,8 +60,10 @@
       complex-double-float-p
       complex-float-p
       #+long-float complex-long-float-p
+      #+double-double complex-double-double-float-p
       complex-rational-p
       complex-single-float-p
+      #+double-double double-double-float-p
       double-float-p
       fdefn-p
       fixnump
@@ -101,9 +106,11 @@
       simple-array-single-float-p
       simple-array-double-float-p
       #+long-float simple-array-long-float-p
+      #+double-double simple-array-double-double-float-p
       simple-array-complex-single-float-p
       simple-array-complex-double-float-p
       #+long-float simple-array-complex-long-float-p
+      #+double-double simple-array-complex-double-double-float-p
       )))
 
 (macrolet
@@ -223,6 +230,7 @@
 		 (single-float (typep num 'single-float))
 		 (double-float (typep num 'double-float))
 		 (long-float (typep num 'long-float))
+		 (double-double-float (typep num 'double-double-float))
 		 ((nil) (floatp num))))
 	      ((nil) t)))
 	  (flet ((bound-test (val)
diff --git a/code/print.lisp b/code/print.lisp
index b993f158f338674b039ea79495eca228d9940f2f..9c5739f3c890111b9ed1f8afdd0efb10d515e01c 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.110 2006/05/01 16:10:26 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/print.lisp,v 1.111 2006/06/30 18:41:22 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1570,7 +1570,7 @@ radix-R.  If you have a power-list then pass it in as PL."
 ;;; out a large factor, since there is more negative exponent range than
 ;;; positive range.
 ;;;
-(defun scale-exponent (original-x)
+(defun scale-exponent-double (original-x)
   (let* ((x (coerce original-x 'long-float)))
     (multiple-value-bind (sig exponent)
 			 (decode-float x)
@@ -1596,6 +1596,44 @@ radix-R.  If you have a power-list then pass it in as PL."
 		     ((>= z 0.1l0)
 		      (values (float z original-x) ex))))))))))
 
+;; Like scale-exponent-double but for double-double-float.
+(defun scale-exponent-double-double (original-x)
+  (let* ((x original-x))
+    (multiple-value-bind (sig exponent)
+	(decode-float x)
+      (declare (ignore sig))
+      (if (= x 0)
+	  (values (float 0 original-x) 1)
+	  (let* ((ex (round (* exponent (log 2l0 10))))
+		 (x (if (minusp ex)
+			(if (float-denormalized-p x)
+			    #-long-float
+			    (* x (expt 10 16) (expt 10 (- (- ex) 16)))
+			    #+long-float
+			    (* x 1.0l18 (expt 10.0l0 (- (- ex) 18)))
+			    (* x 10 (expt 10 (- (- ex) 1))))
+			(/ x 10 (expt 10 (1- ex))))))
+	    (do ((d 10 (* d 10))
+		 (y x (/ x d))
+		 (ex ex (1+ ex)))
+		((< y 1)
+		 (do ((m 10 (* m 10))
+		      (z y (* y m))
+		      (ex ex (1- ex)))
+		     ((>= (* 10 z) 1)
+		      (values (float z original-x) ex))))))))))
+
+#-double-double
+(defun scale-exponent (original-x)
+  (scale-exponent-double original-x))
+
+#+double-double
+(defun scale-exponent (original-x)
+  ;; We split this into two types because we don't want
+  ;; double-double-float to slow down printing double-floats.
+  (if (typep original-x 'double-double-float)
+      (scale-exponent-double-double original-x)
+      (scale-exponent-double original-x)))
 
 ;;;; Entry point for the float printer.
 
@@ -1642,7 +1680,9 @@ radix-R.  If you have a power-list then pass it in as PL."
 		  (single-float #\f)
 		  (double-float #\d)
 		  (short-float #\s)
-		  (long-float #\L))
+		  (long-float #\L)
+		  #+double-double
+		  (double-double-float #\w))
 		exp))))
 
 
@@ -1656,7 +1696,9 @@ radix-R.  If you have a power-list then pass it in as PL."
     (single-float "SINGLE-FLOAT")
     (double-float "DOUBLE-FLOAT")
     (short-float "SHORT-FLOAT")
-    (long-float "LONG-FLOAT")))
+    (long-float "LONG-FLOAT")
+    #+double-double
+    (double-double-float "DOUBLE-DOUBLE-FLOAT")))
 
 
 ;;; OUTPUT-FLOAT-INFINITY  --  Internal
@@ -1712,6 +1754,13 @@ radix-R.  If you have a power-list then pass it in as PL."
     (output-float-infinity x stream))
    ((float-nan-p x)
     (output-float-nan x stream))
+   #+(and nil double-double)
+   ((typep x 'double-double-float)
+    ;; This is a temporary hack until we get more double-double float
+    ;; stuff in place so that we don't need this.  And being able to
+    ;; print double-double's now is quite handy while we debug the
+    ;; rest of the code.
+    (output-double-double-float x stream))
    (t
     (let ((x (cond ((minusp (float-sign x))
 		    (write-char #\- stream)
@@ -1727,12 +1776,67 @@ radix-R.  If you have a power-list then pass it in as PL."
 			  output-float-free-format-exponent-min
 			  output-float-free-format-exponent-max)))))))
 
+#+double-double
+(defun output-double-double-float (x stream)
+  (dd->string (kernel:double-double-hi x)
+	      (kernel:double-double-lo x)
+	      stream))
+
+;;; The code below for printing double-double's was written by Richard
+;;; Fateman.  Used with permission.
+
+#+double-double
+(defvar *dd-digits-to-show* 33)
+
+#+double-double
+(defun dd->lisp (a0 a1)
+  "Convert a DD number to a lisp rational"
+  (declare (double-float a0 a1))
+  (+ (rational a0) (rational a1)))
+
+#+double-double
+;; r rational number >=0
+;; n number of digits
+(defun decimalize (r n &optional (base 10))
+  (let* ((expon (if (= r 0)
+		    0
+		    (floor (cl::log (cl::abs r) base))))
+	 (frac (round (* (cl::abs r)
+			 (expt base (- n expon))))))
+    (values (signum r)
+	    frac
+	    (if (= frac 0)
+		0
+		(cl::1+ expon)))))
+
+#+double-double
+(defun dd->string (x0 x1 stream)
+  "Print out a double-double to a string"
+  (cond ((and (zerop x0) (zerop x1))
+	 (format stream "0.dd0"))
+	(t
+	 (multiple-value-bind (s r e h)
+	     (decimalize (dd->lisp x0 x1) *dd-digits-to-show* 10)
+	   ;; This is slightly modified from Richard Fateman's version to
+	   ;; print numbers in the format x.xxddee instead of 0.xxddee.
+	   (let ((out (string-right-trim "0"
+					 (subseq (setf h (format nil "~A~%" r))
+						 0
+						 (min (length h) *dd-digits-to-show*)))))
+	     (format stream "~A~A.~Aw~S"
+		     (if (< s 0) "-" "")
+		     (aref out 0)
+		     (subseq out 1)
+		     (1- e)))))))
+
 
 ;; Smallest possible (unbiased) exponents
 (defconstant double-float-min-e
   (nth-value 1 (decode-float least-positive-double-float)))
 (defconstant single-float-min-e
   (nth-value 1 (decode-float least-positive-single-float)))
+#+double-double
+(defconstant double-double-float-min-e double-float-min-e)
 
 ;;; Implementation of Figure 1 from "Printing Floating-Point Numbers
 ;;; Quickly and Accurately", by Burger and Dybvig, 1996.  As the
@@ -1758,7 +1862,9 @@ radix-R.  If you have a power-list then pass it in as PL."
 	(min-e
 	 (etypecase v
 	   (single-float single-float-min-e)
-	   (double-float double-float-min-e))))
+	   (double-float double-float-min-e)
+	   #+double-double
+	   (double-double-float double-double-float-min-e))))
     (multiple-value-bind (f e)
 	(integer-decode-float v)
       (let ( ;; FIXME: these even tests assume normal IEEE rounding
diff --git a/code/reader.lisp b/code/reader.lisp
index 0d023757f83fe96b61676bd937c56f8025552197..cab4a3446728c543599f1e1316f681655b7ab266 100644
--- a/code/reader.lisp
+++ b/code/reader.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/reader.lisp,v 1.60 2006/02/19 19:33:49 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/reader.lisp,v 1.61 2006/06/30 18:41:22 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -275,6 +275,10 @@
   (set-secondary-attribute #\d #.constituent-expt)
   (set-secondary-attribute #\s #.constituent-expt)
   (set-secondary-attribute #\l #.constituent-expt)
+  #+double-double
+  (progn
+    (set-secondary-attribute #\W #.constituent-expt)
+    (set-secondary-attribute #\w #.constituent-expt))
   ;; See CLHS 2.1.4.2 for the list of constituent characters that are
   ;; invalid constituent characters.
   (set-secondary-attribute #\Space #.constituent-invalid)
@@ -1374,7 +1378,9 @@
 ;;;; Number reading functions.
 
 (defmacro exponent-letterp (letter)
-  `(memq ,letter '(#\E #\S #\F #\L #\D #\e #\s #\f #\l #\d)))
+  `(memq ,letter '(#\E #\S #\F #\L #\D #\e #\s #\f #\l #\d
+		   #+double-double #\w
+		   #+double-double #\W)))
 
 
 (defvar *integer-reader-safe-digits*
@@ -1565,7 +1571,9 @@ the end of the stream."
                                   (#\S 'short-float)
                                   (#\F 'single-float)
                                   (#\D 'double-float)
-                                  (#\L 'long-float)))
+                                  (#\L 'long-float)
+				  #+double-double
+				  (#\W 'kernel:double-double-float)))
                   num)
 	     (setq num (make-float-aux (* (expt 10 exponent) number) divisor
 				       float-format stream))
diff --git a/code/room.lisp b/code/room.lisp
index 4565b777ddcaa7d6495809fa200d8a0d0a2bce3b..ac299bc2ed5f0f7e63ca0415e044bf29d37821d0 100644
--- a/code/room.lisp
+++ b/code/room.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/room.lisp,v 1.34 2004/10/19 20:12:45 cwang Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/room.lisp,v 1.35 2006/06/30 18:41:22 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -91,7 +91,12 @@
 		 (simple-array-single-float-type . 2)
 		 (simple-array-double-float-type . 3)
 		 (simple-array-complex-single-float-type . 3)
-		 (simple-array-complex-double-float-type . 4)))
+		 (simple-array-complex-double-float-type . 4)
+		 #+double-double
+		 (simple-array-double-double-float-type . 4)
+		 #+double-double
+		 (simple-array-complex-double-double-float-type . 5)
+		 ))
   (let ((name (car stuff))
 	(size (cdr stuff)))
     (setf (svref *meta-room-info* (symbol-value name))
@@ -477,6 +482,12 @@
 	     ((#.bignum-type
 	       #.single-float-type
 	       #.double-float-type
+	       #+double-double
+	       #.double-double-float-type
+	       #.complex-single-float-type
+	       #.complex-double-float-type
+	       #+double-double
+	       #.complex-double-double-float-type
 	       #.simple-string-type
 	       #.simple-bit-vector-type
 	       #.simple-array-unsigned-byte-2-type
@@ -490,8 +501,12 @@
 	       #.simple-array-signed-byte-32-type
 	       #.simple-array-single-float-type
 	       #.simple-array-double-float-type
+	       #+double-double
+	       #.simple-array-double-double-float-type
 	       #.simple-array-complex-single-float-type
-	       #.simple-array-complex-double-float-type)
+	       #.simple-array-complex-double-float-type
+	       #+double-double
+	       #.simple-array-complex-double-double-float-type)
 	      (incf non-descriptor-headers)
 	      (incf non-descriptor-bytes (- size word-bytes)))
 	     ((#.list-pointer-type
@@ -510,7 +525,10 @@
 	       #.symbol-header-type
 	       #.sap-type
 	       #.weak-pointer-type
-	       #.instance-header-type)
+	       #.instance-header-type
+	       #.fdefn-type
+	       #+gencgc
+	       #.scavenger-hook-type)
 	      (incf descriptor-words (truncate size word-bytes)))
 	     (t
 	      (error "Bogus type: ~D" type))))
diff --git a/code/seq.lisp b/code/seq.lisp
index 4988b069ef34876cea28d9852bffe1f1b09cb390..ada87a026c5f9259e85e221ee521628b5170f1d2 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.52 2005/02/25 18:21:21 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/seq.lisp,v 1.53 2006/06/30 18:41:22 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1014,6 +1014,9 @@
 		  #+long-float
 		  ((csubtypep type (specifier-type 'long-float))
 		   (output-type-or-lose (%long-float object)))
+		  #+double-double
+		  ((csubtypep type (specifier-type 'double-double-float))
+		   (output-type-or-lose (%double-double-float object)))
 		  ((csubtypep type (specifier-type 'float))
 		   (output-type-or-lose (%single-float object)))
 		  ((csubtypep type (specifier-type '(complex single-float)))
@@ -1026,6 +1029,10 @@
 		  ((csubtypep type (specifier-type '(complex long-float)))
 		   (complex (%long-float (realpart object))
 			    (%long-float (imagpart object))))
+		  #+double-double
+		  ((csubtypep type (specifier-type '(complex double-double-float)))
+		   (complex (%double-double-float (realpart object))
+			    (%double-double-float (imagpart object))))
 		  ((csubtypep type (specifier-type '(complex float)))
 		   (complex (%single-float (realpart object))
 			    (%single-float (imagpart object))))
diff --git a/code/type.lisp b/code/type.lisp
index 2d1f221fed4598f3cf93e6f09019e468fa721c36..3089dc99f22bf1b14cab72b96394808b3563c2e9 100644
--- a/code/type.lisp
+++ b/code/type.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/type.lisp,v 1.71 2005/05/09 15:56:03 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/type.lisp,v 1.72 2006/06/30 18:41:22 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1894,7 +1894,8 @@
 ;;;
 (eval-when (compile load eval)
   (defconstant float-formats
-    '(long-float double-float single-float short-float)))
+    '(#+double-double double-double-float
+      long-float double-float single-float short-float)))
 
 ;;; The type of a float format.
 ;;;
@@ -2214,6 +2215,8 @@
 	       (double-float (specifier-type '(complex double-float)))
 	       #+long-float
 	       (long-float (specifier-type '(complex long-float)))
+	       #+double-double
+	       (double-double-float (specifier-type '(complex double-double-float)))
 	       (rational (specifier-type '(complex rational)))
 	       (t (specifier-type '(complex real))))))
     (let ((ctype (specifier-type typespec)))
@@ -2411,7 +2414,9 @@
 		      ,(coerced-float-bound high 'single-float))
 	(double-float ,(coerced-float-bound  low 'double-float)
 		      ,(coerced-float-bound high 'double-float))
-	#+long-float ,(error "stub: no long float support yet"))))
+	#+long-float ,(error "stub: no long float support yet")
+	;; This needs to be fixed so that we can compute the bounds
+	#+double-double (double-double-float * *))))
 
 (defmacro define-float-format (f)
   `(def-bounded-type ,f float ,f))
@@ -2420,6 +2425,8 @@
 (define-float-format single-float)
 (define-float-format double-float)
 (define-float-format long-float)
+#+double-double
+(define-float-format double-double-float)
 
 (defun numeric-types-intersect (type1 type2)
   (declare (type numeric-type type1 type2))
@@ -2589,12 +2596,15 @@
 			  ((nil)
 			   ;; A double-float with any real number is a
 			   ;; double-float.
-			   #-long-float
+			   #-(and long-float (not double-double))
 			   (if (eq format1 'double-float) 'double-float nil)
 			   ;; A long-float with any real number is a
 			   ;; long-float.
-			   #+long-float
-			   (if (eq format1 'long-float) 'long-float nil)))
+			   #+(and long-float (not double-double))
+			   (if (eq format1 'long-float) 'long-float nil)
+			   #+(and (not long-float) double-double)
+			   (if (eq format1 'double-double-float) 'double-double-float nil)
+			   ))
 		:complexp (if (or (eq complexp1 :complex)
 				  (eq complexp2 :complex))
 			      :complex
diff --git a/code/typedefs.lisp b/code/typedefs.lisp
index 49df2042234920ecc270f44e9218b20ea2261476..321ca4aae24bb98737b823b6342b8057d89def07 100644
--- a/code/typedefs.lisp
+++ b/code/typedefs.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/typedefs.lisp,v 1.13 2003/04/23 15:19:41 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/typedefs.lisp,v 1.14 2006/06/30 18:41:22 rtoy Rel $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -27,7 +27,8 @@
     hash-table integer keyword list long-float nil null number package
     pathname random-state ratio rational real readtable sequence
     short-float simple-array simple-bit-vector simple-string simple-vector
-    single-float standard-char stream string base-char symbol t vector))
+    single-float standard-char stream string base-char symbol t vector
+    #+double-double double-double-float))
 
 
 ;;; Def-Type-Translator  --  Interface
diff --git a/compiler/array-tran.lisp b/compiler/array-tran.lisp
index a7fbe4078ce8eb1eafb90ea6e0b3c52eccab8911..8e880245cb881244479d7bc116815a5ef4cbfa4c 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.40 2005/05/09 13:06:59 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/array-tran.lisp,v 1.41 2006/06/30 18:41:23 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -245,6 +245,9 @@
     (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)
+    #+double-double
+    (double-double-float 0w0 128
+		  vm::simple-array-double-double-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)
@@ -262,6 +265,9 @@
     #+long-float
     ((complex long-float) #C(0.0l0 0.0l0) #+x86 192 #+sparc 256
      vm:simple-array-complex-long-float-type)
+    #+double-double
+    ((complex double-double-float) #C(0.0w0 0.0w0) 256
+     vm::simple-array-complex-double-double-float-type)
     (t 0 32 vm:simple-vector-type)))
 
 ;;; MAKE-ARRAY  --  source-transform.
diff --git a/compiler/dump.lisp b/compiler/dump.lisp
index ad189020bdc6141fc7ce2451bea50c9aaeb5abba..e7052734854f684e74692d7eff7322bb2109e29f 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.81 2005/02/15 18:15:10 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/dump.lisp,v 1.82 2006/06/30 18:41:23 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1092,6 +1092,22 @@
 	   (dump-var-signed exp-bits 4 file))
 	  (t
 	   (error "Unable to dump long-float")))))
+
+#+double-double
+(defun dump-double-double-float (float file)
+  ;; Dump out 2 double-floats
+  (flet ((dump-double (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-double (kernel:double-double-hi float))
+    (dump-double (kernel:double-double-lo float))))
+
+#+double-double
+(defun dump-complex-double-double-float (z file)
+  ;; Dump out 2 double-double-floats
+  (dump-double-double-float (realpart z) file)
+  (dump-double-double-float (imagpart z) file))
 	   
 ;;; Or a complex...
 
@@ -1116,6 +1132,10 @@
      (dump-fop 'lisp::fop-complex-long-float file)
      (dump-long-float (realpart x) file)
      (dump-long-float (imagpart x) file))
+    #+double-double
+    ((complex double-double-float)
+     (dump-fop 'lisp::fop-complex-double-double-float file)
+     (dump-complex-double-double-float x file))
     (t
      (sub-dump-object (realpart x) file)
      (sub-dump-object (imagpart x) file)
@@ -1153,7 +1173,11 @@
     #+long-float
     (long-float
      (dump-fop 'lisp::fop-long-float file)
-     (dump-long-float x file))))
+     (dump-long-float x file))
+    #+double-double
+    (double-double-float
+     (dump-fop 'lisp::fop-double-double-float file)
+     (dump-double-double-float x file))))
 
 
 ;;;; Symbol Dumping:
@@ -1372,6 +1396,10 @@
       ((simple-array long-float (*))
        (dump-long-float-vector simple-version file)
        (eq-save-object x file))
+      #+double-double
+      ((simple-array double-double-float (*))
+       (dump-double-double-float-vector simple-version file)
+       (eq-save-object x file))
       ((simple-array (complex single-float) (*))
        (dump-complex-single-float-vector simple-version file)
        (eq-save-object x file))
@@ -1382,6 +1410,10 @@
       ((simple-array (complex long-float) (*))
        (dump-complex-long-float-vector simple-version file)
        (eq-save-object x file))
+      #+double-double
+      ((simple-array (complex double-double-float) (*))
+       (dump-complex-double-double-float-vector simple-version file)
+       (eq-save-object x file))
       (t
        (dump-i-vector simple-version file)
        (eq-save-object x file)))))
@@ -1494,6 +1526,15 @@
      vec (* length vm:word-bytes #+x86 3 #+sparc 4)
      (* vm:word-bytes #+x86 3 #+sparc 4) file)))
 
+#+double-double
+(defun dump-double-double-float-vector (vec file)
+  (let* ((length (length vec))
+	 (element-size (* 4 vm:word-bytes))
+	 (bytes (* length element-size)))
+    (dump-fop 'lisp::fop-double-double-float-vector file)
+    (dump-unsigned-32 length file)
+    (dump-data-maybe-byte-swapping vec bytes element-size file)))
+
 ;;; DUMP-COMPLEX-SINGLE-FLOAT-VECTOR  --  internal.
 ;;; 
 (defun dump-complex-single-float-vector (vec file)
@@ -1512,6 +1553,15 @@
     (dump-data-maybe-byte-swapping vec (* length vm:word-bytes 2 2)
 				   (* vm:word-bytes 2) file)))
 
+#+double-double
+(defun dump-complex-double-double-float-vector (vec file)
+  (let* ((length (length vec))
+	 (element-size (* 8 vm:word-bytes))
+	 (bytes (* length element-size)))
+    (dump-fop 'lisp::fop-complex-double-double-float-vector file)
+    (dump-unsigned-32 length file)
+    (dump-data-maybe-byte-swapping vec bytes element-size file)))
+
 ;;; DUMP-COMPLEX-LONG-FLOAT-VECTOR  --  internal.
 ;;; 
 #+long-float
diff --git a/compiler/float-tran.lisp b/compiler/float-tran.lisp
index e8f4c09a08a108793e4322fba43e52cc42990f2b..5da2e8db7cb792ce1b422199b7db3df0ab9c72c9 100644
--- a/compiler/float-tran.lisp
+++ b/compiler/float-tran.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/float-tran.lisp,v 1.104 2005/06/26 17:21:04 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/float-tran.lisp,v 1.105 2006/06/30 18:41:23 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -37,12 +37,53 @@
 (deftransform %double-float ((n) (double-float) * :when :both)
   'n)
 
+#+double-double
+(progn
+(defknown %double-double-float (real)
+  double-double-float
+  (movable foldable flushable))
+
+(deftransform float ((n prototype) (* double-double-float) * :when :both)
+  '(%double-double-float n))
+
+(deftransform %double-float ((n) (double-double-float) * :when :both)
+  '(double-double-hi n))
+
+(deftransform %single-float ((n) (double-double-float) * :when :both)
+  '(float (double-double-hi n) 1f0))
+
+(deftransform %double-double-float ((n) (double-double-float) * :when :both)
+  'n)
+
+#+nil
+(defun %double-double-float (n)
+  (make-double-double-float (float n 1d0) 0d0))
+
+(defun %double-double-float (n)
+  (typecase n
+    (fixnum
+     (make-double-double-float (float n 1d0) 0d0))
+    (single-float
+     (make-double-double-float (float n 1d0) 0d0))
+    (double-float
+     (make-double-double-float (float n 1d0) 0d0))
+    (double-double-float
+     n)
+    (bignum
+     (bignum:bignum-to-float n 'double-double-float))
+    (ratio
+     (kernel::float-ratio n 'double-double-float))))
+); progn
+
 (deftransform coerce ((n type) (* *) * :when :both)
   (unless (constant-continuation-p type)
     (give-up))
   `(the ,(continuation-value type)
 	,(let ( (tspec (specifier-type (continuation-value type))) )
-	   (cond ((csubtypep tspec (specifier-type 'double-float))	
+	   (cond #+double-double
+		 ((csubtypep tspec (specifier-type 'double-double-float))
+		  '(%double-double-float n))
+		 ((csubtypep tspec (specifier-type 'double-float))	
 		  '(%double-float n))	
 		 ((csubtypep tspec (specifier-type 'float))
 		  '(%single-float n))
@@ -254,6 +295,26 @@
   (values (signed-byte 32) (unsigned-byte 32))
   (movable foldable flushable))
 
+#+double-double
+(progn
+(defknown double-double-float-p (t)
+  boolean
+  (movable foldable flushable))
+
+(defknown %make-double-double-float (double-float double-float)
+  double-double-float
+  (movable foldable flushable))
+
+
+(defknown double-double-hi (double-double-float)
+  double-float
+  (movable foldable flushable))
+
+(defknown double-double-lo (double-double-float)
+  double-float
+  (movable foldable flushable))
+
+) ; progn
 
 (deftransform float-sign ((float &optional float2)
 			  (single-float &optional single-float) *)
@@ -372,10 +433,17 @@
 	   ;; that might occur.  We can ignore underflows which become
 	   ;; zeros.
 	   (set-bound
-	    (handler-case
-	     (scale-float (bound-value x) n)
-	     (floating-point-overflow ()
-		nil))
+	    (let ((value (handler-case
+			     (scale-float (bound-value x) n)
+			   (floating-point-overflow ()
+			     nil))))
+	      ;; This check is necessary for ppc because the current
+	      ;; implementation on ppc doesn't signal floating-point
+	      ;; overflow.  (How many other places do we need to check
+	      ;; for this?)
+	      (if (and (floatp value) (float-infinity-p value))
+		  nil
+		  value))
 	    (consp x))))
     (when (and (numeric-type-p f) (numeric-type-p ex))
       (let ((f-lo (numeric-type-low f))
@@ -395,7 +463,8 @@
 	;; might get bounds like 0 and fh*2^nh < 0.  Our bounds are
 	;; backwards.  Thus, swap the bounds to get the correct
 	;; bounds.
-	(when (and new-lo new-hi (< new-hi new-lo))
+	(when (and new-lo new-hi (< (bound-value new-hi)
+				    (bound-value new-lo)))
 	  (rotatef new-lo new-hi))
 	(make-numeric-type :class (numeric-type-class f)
 			   :format (numeric-type-format f)
@@ -1291,7 +1360,7 @@
 ;;; Define some transforms for complex operations.  We do this in lieu
 ;;; of complex operation VOPs.  Some architectures have vops, though.
 ;;;
-#-complex-fp-vops
+#-(and (not double-double) complex-fp-vops)
 (macrolet ((frob (type)
 	     `(progn
 	       ;; Negation
@@ -1377,9 +1446,11 @@
 	       )))
 
   (frob single-float)
-  (frob double-float))
+  (frob double-float)
+  #+double-double
+  (frob double-double-float))
 
-#+complex-fp-vops
+#+(and (not double-double) complex-fp-vops)
 (macrolet
     ((frob (type)
        `(progn
@@ -1487,3 +1558,506 @@
 	 (specifier-type `(complex ,(or (numeric-type-format arg) 'float))))
      #'cis))
 
+
+;;; Support for double-double floats
+;;;
+;;; The algorithms contained herein are based on the code written by
+;;; Yozo Hida.  See http://www.cs.berkeley.edu/~yozo/ for more
+;;; information.
+
+#+double-double
+(progn
+  
+(declaim (inline quick-two-sum))
+(defun quick-two-sum (a b)
+  "Computes fl(a+b) and err(a+b), assuming |a| >= |b|"
+  (declare (double-float a b))
+  (let* ((s (+ a b))
+	 (e (- b (- s a))))
+    (values s e)))
+
+(declaim (inline two-sum))
+(defun two-sum (a b)
+  "Computes fl(a+b) and err(a+b)"
+  (declare (double-float a b))
+  (let* ((s (+ a b))
+	 (v (- s a))
+	 (e (+ (- a (- s v))
+	       (- b v))))
+    (values s e)))
+
+(declaim (inline add-dd))
+(defun add-dd (a0 a1 b0 b1)
+  "Add the double-double A0,A1 to the double-double B0,B1"
+  (declare (double-float a0 a1 b0 b1)
+	   (optimize (speed 3)))
+  (multiple-value-bind (s1 s2)
+      (two-sum a0 b0)
+    (declare (double-float s1 s2))
+    (multiple-value-bind (t1 t2)
+	(two-sum a1 b1)
+      (declare (double-float t1 t2))
+      (incf s2 t1)
+      (multiple-value-bind (s1 s2)
+	  (quick-two-sum s1 s2)
+	(declare (double-float s1 s2))
+	(incf s2 t2)
+	(quick-two-sum s1 s2)))))
+
+(deftransform + ((a b) (vm::double-double-float vm::double-double-float) *)
+  `(multiple-value-bind (hi lo)
+      (add-dd (kernel:double-double-hi a) (kernel:double-double-lo a)
+	      (kernel:double-double-hi b) (kernel:double-double-lo b))
+    (kernel:%make-double-double-float hi lo)))
+
+(declaim (inline quick-two-diff))
+(defun quick-two-diff (a b)
+  "Compute fl(a-b) and err(a-b), assuming |a| >= |b|"
+  (declare (double-float a b))
+  (let ((s (- a b)))
+    (values s (- (- a s) b))))
+
+(declaim (inline two-diff))
+(defun two-diff (a b)
+  "Compute fl(a-b) and err(a-b)"
+  (declare (double-float a b))
+  (let* ((s (- a b))
+	 (v (- s a))
+	 (e (- (- a (- s v))
+	       (+ b v))))
+    (values s e)))
+
+(declaim (inline sub-dd))
+(defun sub-dd (a0 a1 b0 b1)
+  "Subtract the double-double B0,B1 from A0,A1"
+  (declare (double-float a0 a1 b0 b1)
+	   (optimize (speed 3)))
+  (multiple-value-bind (s1 s2)
+      (two-diff a0 b0)
+    (declare (double-float s2))
+    (multiple-value-bind (t1 t2)
+	(two-diff a1 b1)
+      (incf s2 t1)
+      (multiple-value-bind (s1 s2)
+	  (quick-two-sum s1 s2)
+	(declare (double-float s2))
+	(incf s2 t2)
+	(quick-two-sum s1 s2)))))
+
+(declaim (inline sub-d-dd))
+(defun sub-d-dd (a b0 b1)
+  "Compute double-double = double - double-double"
+  (declare (double-float a b0 b1)
+	   (optimize (speed 3) (safety 0)))
+  (multiple-value-bind (s1 s2)
+      (two-diff a b0)
+    (declare (double-float s2))
+    (decf s2 b1)
+    (quick-two-sum s1 s2)))
+
+(declaim (inline sub-dd-d))
+(defun sub-dd-d (a0 a1 b)
+  "Subtract the double B from the double-double A0,A1"
+  (declare (double-float a0 a1 b)
+	   (optimize (speed 3) (safety 0)))
+  (multiple-value-bind (s1 s2)
+      (two-diff a0 b)
+    (declare (double-float s2))
+    (incf s2 a1)
+    (quick-two-sum s1 s2)))
+
+(deftransform - ((a b) (vm::double-double-float vm::double-double-float) *)
+  `(multiple-value-bind (hi lo)
+      (sub-dd (kernel:double-double-hi a) (kernel:double-double-lo a)
+	      (kernel:double-double-hi b) (kernel:double-double-lo b))
+     (kernel:%make-double-double-float hi lo)))
+
+(deftransform - ((a b) (double-float vm::double-double-float) *)
+  `(multiple-value-bind (hi lo)
+      (sub-d-dd a
+		(kernel:double-double-hi b) (kernel:double-double-lo b))
+     (kernel:%make-double-double-float hi lo)))
+
+(deftransform - ((a b) (vm::double-double-float double-float) *)
+  `(multiple-value-bind (hi lo)
+      (sub-dd-d (kernel:double-double-hi a) (kernel:double-double-lo a)
+		b)
+     (kernel:%make-double-double-float hi lo)))
+
+(declaim (inline two-prod))
+(defun two-prod (a b)
+  "Compute fl(a*b) and err(a*b)"
+  (declare (double-float a b))
+  (let ((p (* a b)))
+    (multiple-value-bind (a-hi a-lo)
+	(split a)
+      ;;(format t "a-hi, a-lo = ~S ~S~%" a-hi a-lo)
+      (multiple-value-bind (b-hi b-lo)
+	  (split b)
+	;;(format t "b-hi, b-lo = ~S ~S~%" b-hi b-lo)
+	(let ((e (+ (+ (- (* a-hi b-hi) p)
+		       (* a-hi b-lo)
+		       (* a-lo b-hi))
+		    (* a-lo b-lo))))
+	  (values p e))))))
+
+(declaim (inline split))
+;; This algorithm is the version given by Yozo Hida.  It has problems
+;; with overflow because we multiply by 1+2^27.
+;;
+;; But be very careful about replacing this with a new algorithm.  The
+;; values computed here are very important to get the rounding right.
+;; If you change this, the rounding may be different, which will
+;; affect other parts of the algorithm.
+;;
+;; I (rtoy) tried a different algorithm that split the number in two
+;; as described, but without overflow.  However, that caused
+;; -9.4294948327242751340284975915175w0/1w14 to return a value that
+;; wasn't really close to -9.4294948327242751340284975915175w-14.
+;;
+;; This also means we can't print numbers like 1w308 with the current
+;; printing algorithm, or even divide 1w308 by 10.
+#+nil
+(defun split (a)
+  "Split the double-float number a into a-hi and a-lo such that a =
+  a-hi + a-lo and a-hi contains the upper 26 significant bits of a and
+  a-lo contains the lower 26 bits."
+  (declare (double-float a))
+  (let* ((tmp (* a (+ 1 (expt 2 27))))
+	 (a-hi (- tmp (- tmp a)))
+	 (a-lo (- a a-hi)))
+    (values a-hi a-lo)))
+
+
+(defun split (a)
+  "Split the double-float number a into a-hi and a-lo such that a =
+  a-hi + a-lo and a-hi contains the upper 26 significant bits of a and
+  a-lo contains the lower 26 bits."
+  (declare (double-float a)
+	   (optimize (speed 3)))
+  ;; This splits the number a into 2 halves of 26 bits each, but the
+  ;; halves are, I think, supposed to be properly rounded in an IEEE
+  ;; fashion.
+  ;;
+  ;; For numbers that are very large, we use a different algorithm.
+  ;; For smaller numbers, we can use the original algorithm of Yozo
+  ;; Hida.
+  (if (> (abs a) (scale-float 1d0 (- 1023 27)))
+      ;; I've tested this algorithm against Yozo's method for 1
+      ;; billion randomly generated double-floats between 2^(-995) and
+      ;; 2^996, and identical results are obtained.  For numbers that
+      ;; are very small, this algorithm produces different numbers
+      ;; because of underflow.  For very large numbers, we, of course
+      ;; produce different results because Yozo's method causes
+      ;; overflow.
+      (let* ((tmp (* a (+ 1 (scale-float 1d0 -27))))
+	     (as (* a (scale-float 1d0 -27)))
+	     (a-hi (* (- tmp (- tmp as)) (expt 2 27)))
+	     (a-lo (- a a-hi)))
+	(values a-hi a-lo))
+      ;; Yozo's algorithm.
+      (let* ((tmp (* a (+ 1 (expt 2 27))))
+	     (a-hi (- tmp (- tmp a)))
+	     (a-lo (- a a-hi)))
+	(values a-hi a-lo))))
+
+
+(declaim (inline two-prod))
+(defun two-prod (a b)
+  "Compute fl(a*b) and err(a*b)"
+  (declare (double-float a b))
+  (let ((p (* a b)))
+    (multiple-value-bind (a-hi a-lo)
+	(split a)
+      ;;(format t "a-hi, a-lo = ~S ~S~%" a-hi a-lo)
+      (multiple-value-bind (b-hi b-lo)
+	  (split b)
+	;;(format t "b-hi, b-lo = ~S ~S~%" b-hi b-lo)
+	(let ((e (+ (+ (- (* a-hi b-hi) p)
+		       (* a-hi b-lo)
+		       (* a-lo b-hi))
+		    (* a-lo b-lo))))
+	  (values p e))))))
+
+(declaim (inline two-sqr))
+(defun two-sqr (a)
+  "Compute fl(a*a) and err(a*b).  This is a more efficient
+  implementation of two-prod"
+  (declare (double-float a))
+  (let ((q (* a a)))
+    (multiple-value-bind (a-hi a-lo)
+	(split a)
+      (values q (+ (+ (- (* a-hi a-hi) q)
+		      (* 2 a-hi a-lo))
+		   (* a-lo a-lo))))))
+
+(declaim (inline mul-dd-d))
+(defun mul-dd-d (a0 a1 b)
+  (declare (double-float a0 a1 b)
+	   (optimize (speed 3)))
+  (multiple-value-bind (p1 p2)
+      (two-prod a0 b)
+    (declare (double-float p2))
+    ;;(format t "mul-dd-d p1,p2 = ~A ~A~%" p1 p2)
+    (incf p2 (* a1 b))
+    ;;(format t "mul-dd-d p2 = ~A~%" p2)
+    (quick-two-sum p1 p2)))
+
+(declaim (inline mul-dd))
+(defun mul-dd (a0 a1 b0 b1)
+  "Multiply the double-double A0,A1 with B0,B1"
+  (declare (double-float a0 a1 b0 b1)
+	   (optimize (speed 3)))
+  (multiple-value-bind (p1 p2)
+      (two-prod a0 b0)
+    (declare (double-float p1 p2))
+    (incf p2 (* a0 b1))
+    (incf p2 (* a1 b0))
+    (multiple-value-bind (p1 p2)
+	(quick-two-sum p1 p2)
+      (values p1 p2))))
+
+(declaim (inline add-dd-d))
+(defun add-dd-d (a0 a1 b)
+  "Add the double-double A0,A1 to the double B"
+  (declare (double-float a0 a1 b)
+	   (optimize (speed 3)))
+  (multiple-value-bind (s1 s2)
+      (two-sum a0 b)
+    (declare (double-float s1 s2))
+    (incf s2 a1)
+    (quick-two-sum s1 s2)))
+
+(declaim (inline sqr-dd))
+(defun sqr-dd (a0 a1)
+  (declare (double-float a0 a1)
+	   (optimize (speed 3)))
+  (multiple-value-bind (p1 p2)
+      (two-sqr a0)
+    (declare (double-float p1 p2))
+    (incf p2 (* 2 a0 a1))
+    ;; Hida's version of sqr (qd-2.1.210) has the following line for
+    ;; the sqr function.  But if you compare this with mul-dd, this
+    ;; doesn't exist there, and if you leave it in, it produces
+    ;; results that are different from using mul-dd to square a value.
+    #+nil
+    (incf p2 (* a1 a1))
+    (quick-two-sum p1 p2)))
+
+(deftransform + ((a b) (vm::double-double-float (or integer single-float double-float)) *)
+  `(multiple-value-bind (hi lo)
+      (add-dd-d (kernel:double-double-hi a) (kernel:double-double-lo a)
+		(float b 1d0))
+     (kernel:%make-double-double-float hi lo)))
+
+(deftransform + ((a b) ((or integer single-float double-float) vm::double-double-float) *)
+  `(multiple-value-bind (hi lo)
+      (add-dd-d (kernel:double-double-hi b) (kernel:double-double-lo b)
+		(float a 1d0))
+     (kernel:%make-double-double-float hi lo)))
+
+#+nil
+(deftransform * ((a b) (vm::double-double-float vm::double-double-float) *)
+  `(multiple-value-bind (hi lo)
+      (mul-dd (kernel:double-double-hi a) (kernel:double-double-lo a)
+	      (kernel:double-double-hi b) (kernel:double-double-lo b))
+     (kernel:%make-double-double-float hi lo)))
+
+(deftransform * ((a b) (vm::double-double-float vm::double-double-float) * :node node)
+  ;; non-const-same-leaf-ref-p is stolen from two-arg-derive-type.
+  (flet ((non-const-same-leaf-ref-p (x y)
+	   ;; Just like same-leaf-ref-p, but we don't care if the
+	   ;; value of the leaf is constant or not.
+	   (declare (type continuation x y))
+	   (let ((x-use (continuation-use x))
+		 (y-use (continuation-use y)))
+	     (and (ref-p x-use)
+		  (ref-p y-use)
+		  (eq (ref-leaf x-use) (ref-leaf y-use))))))
+    (destructuring-bind (arg1 arg2)
+	(combination-args node)
+      ;; If the two args to * are the same, we square the number
+      ;; instead of multiply.  Squaring is simpler than a full
+      ;; multiply.
+      (if (non-const-same-leaf-ref-p arg1 arg2)
+	  `(multiple-value-bind (hi lo)
+	       (sqr-dd (kernel:double-double-hi a) (kernel:double-double-lo a))
+	     (kernel:%make-double-double-float hi lo))
+	  `(multiple-value-bind (hi lo)
+	       (mul-dd (kernel:double-double-hi a) (kernel:double-double-lo a)
+		       (kernel:double-double-hi b) (kernel:double-double-lo b))
+	     (kernel:%make-double-double-float hi lo))))))
+
+(deftransform * ((a b) (vm::double-double-float (or integer single-float double-float)) *)
+  `(multiple-value-bind (hi lo)
+       (mul-dd-d (kernel:double-double-hi a) (kernel:double-double-lo a)
+		 (float b 1d0))
+     (kernel:%make-double-double-float hi lo)))
+
+(deftransform * ((a b) ((or integer single-float double-float) vm::double-double-float) *)
+  `(multiple-value-bind (hi lo)
+       (mul-dd-d (kernel:double-double-hi b) (kernel:double-double-lo b)
+		 (float a 1d0))
+     (kernel:%make-double-double-float hi lo)))
+
+(declaim (inline div-dd))
+(defun div-dd (a0 a1 b0 b1)
+  "Divide the double-double A0,A1 by B0,B1"
+  (declare (double-float a0 a1 b0 b1)
+	   (optimize (speed 3))
+	   (inline sub-dd))
+  (let ((q1 (/ a0 b0)))
+    ;; (q1b0, q1b1) = q1*(b0,b1)
+    ;;(format t "q1 = ~A~%" q1)
+    (multiple-value-bind (q1b0 q1b1)
+	(mul-dd-d b0 b1 q1)
+      ;;(format t "q1*b = ~A ~A~%" q1b0 q1b1)
+      (multiple-value-bind (r0 r1)
+	  ;; r = a - q1 * b
+	  (sub-dd a0 a1 q1b0 q1b1)
+	;;(format t "r = ~A ~A~%" r0 r1)
+	(let ((q2 (/ r0 b0)))
+	  (multiple-value-bind (q2b0 q2b1)
+	      (mul-dd-d b0 b1 q2)
+	    (multiple-value-bind (r0 r1)
+		;; r = r - (q2*b)
+		(sub-dd r0 r1 q2b0 q2b1)
+	      (declare (ignore r1))
+	      (let ((q3 (/ r0 b0)))
+		(multiple-value-bind (q1 q2)
+		    (quick-two-sum q1 q2)
+		  (add-dd-d q1 q2 q3))))))))))
+
+(declaim (inline div-dd-d))
+(defun div-dd-d (a0 a1 b)
+  (declare (double-float a0 a1 b)
+	   (optimize (speed 3)))
+  (let ((q1 (/ a0 b)))
+    ;; q1 = approx quotient
+    ;; Now compute a - q1 * b
+    (multiple-value-bind (p1 p2)
+	(two-prod q1 b)
+      (multiple-value-bind (s e)
+	  (two-diff a0 p1)
+	(declare (double-float e))
+	(incf e a1)
+	(decf e p2)
+	;; Next approx
+	(let ((q2 (/ (+ s e) b)))
+	  (quick-two-sum q1 q2))))))
+
+(deftransform / ((a b) (vm::double-double-float vm::double-double-float) *)
+  `(multiple-value-bind (hi lo)
+      (div-dd (kernel:double-double-hi a) (kernel:double-double-lo a)
+	      (kernel:double-double-hi b) (kernel:double-double-lo b))
+     (kernel:%make-double-double-float hi lo)))
+
+(deftransform / ((a b) (vm::double-double-float (or integer single-float double-float)) *)
+  `(multiple-value-bind (hi lo)
+       (div-dd-d (kernel:double-double-hi a) (kernel:double-double-lo a)
+		 (float b 1d0))
+     (kernel:%make-double-double-float hi lo)))
+
+(declaim (inline sqr-d))
+(defun sqr-d (a)
+  "Square"
+  (declare (double-float a)
+	   (optimize (speed 3)))
+  (two-sqr a))
+
+(declaim (inline mul-d-d))
+(defun mul-d-d (a b)
+  (two-prod a b))
+
+(declaim (inline sqrt-dd))
+(defun sqrt-dd (a0 a1)
+  (declare (type (double-float 0d0) a0)
+	   (double-float a1)
+	   (optimize (speed 3)))
+  ;; Strategy: Use Karp's trick: if x is an approximation to sqrt(a),
+  ;; then
+  ;;
+  ;; y = a*x + (a-(a*x)^2)*x/2
+  ;;
+  ;; is an approximation that is accurate to twice the accuracy of x.
+  ;; Also, the multiplication (a*x) and [-]*x can be done with only
+  ;; half the precision.
+  (if (and (zerop a0) (zerop a1))
+      (values a0 a1)
+      (let* ((x (/ (sqrt a0)))
+	     (ax (* a0 x)))
+	(multiple-value-bind (s0 s1)
+	    (sqr-d ax)
+	  (multiple-value-bind (s2)
+	      (sub-dd a0 a1 s0 s1)
+	    (multiple-value-bind (p0 p1)
+		(mul-d-d s2 (* x 0.5d0))
+	      (add-dd-d p0 p1 ax)))))))
+
+(deftransform sqrt ((a) (vm::double-double-float) *)
+  `(multiple-value-bind (hi lo)
+      (sqrt-dd (kernel:double-double-hi a) (kernel:double-double-lo a))
+    (kernel:%make-double-double-float hi lo)))
+
+(declaim (inline neg-dd))
+(defun neg-dd (a0 a1)
+  (declare (double-float a0 a1)
+	   (optimize (speed 3)))
+  (values (- a0) (- a1)))
+
+(declaim (inline abs-dd))
+(defun abs-dd (a0 a1)
+  (declare (double-float a0 a1)
+	   (optimize (speed 3)))
+  (if (minusp a0)
+      (neg-dd a0 a1)
+      (values a0 a1)))
+
+(deftransform abs ((a) (vm::double-double-float) *)
+  `(multiple-value-bind (hi lo)
+       (abs-dd (kernel:double-double-hi a) (kernel:double-double-lo a))
+     (kernel:%make-double-double-float hi lo)))
+
+(deftransform %negate ((a) (vm::double-double-float) *)
+  `(multiple-value-bind (hi lo)
+       (neg-dd (kernel:double-double-hi a) (kernel:double-double-lo a))
+     (kernel:%make-double-double-float hi lo)))
+
+(declaim (inline dd=))
+(defun dd= (a0 a1 b0 b1)
+  (and (= a0 b0)
+       (= a1 b1)))
+  
+(declaim (inline dd<))
+(defun dd< (a0 a1 b0 b1)
+  (or (< a0 b0)
+       (and (= a0 b0)
+	    (< a1 b1))))
+
+(declaim (inline dd>))
+(defun dd> (a0 a1 b0 b1)
+  (or (> a0 b0)
+       (and (= a0 b0)
+	    (> a1 b1))))
+  
+(deftransform = ((a b) (vm::double-double-float vm::double-double-float) *)
+  `(dd= (kernel:double-double-hi a)
+	(kernel:double-double-lo a)
+	(kernel:double-double-hi b)
+	(kernel:double-double-lo b)))
+
+
+(deftransform < ((a b) (vm::double-double-float vm::double-double-float) *)
+  `(dd< (kernel:double-double-hi a)
+	(kernel:double-double-lo a)
+	(kernel:double-double-hi b)
+	(kernel:double-double-lo b)))
+
+
+(deftransform > ((a b) (vm::double-double-float vm::double-double-float) *)
+  `(dd> (kernel:double-double-hi a)
+	(kernel:double-double-lo a)
+	(kernel:double-double-hi b)
+	(kernel:double-double-lo b)))
+
+) ; progn double-double
diff --git a/compiler/generic/interr.lisp b/compiler/generic/interr.lisp
index fde0c57b245cc7d6a3f600d81d116c1b31c0b1a8..b2664f86cd46ef9d72cfc0c2b18ac6a0a6c9a653 100644
--- a/compiler/generic/interr.lisp
+++ b/compiler/generic/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/compiler/generic/interr.lisp,v 1.12 2002/08/28 13:29:27 pmai Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/interr.lisp,v 1.13 2006/06/30 18:41:23 rtoy Rel $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -61,6 +61,9 @@
   #+long-float
   (object-not-long-float
    "Object is not of type LONG-FLOAT.")
+  #+double-double
+  (object-not-double-double-float
+   "Object is not of type DOUBLE-DOUBLE-FLOAT.")
   (object-not-simple-string
    "Object is not of type SIMPLE-STRING.")
   (object-not-simple-bit-vector
@@ -155,6 +158,9 @@
   #+long-float
   (object-not-simple-array-long-float
    "Object is not of type (SIMPLE-ARRAY LONG-FLOAT (*)).")
+  #+double-double
+  (object-not-simple-array-double-double-float
+   "Object is not of type (SIMPLE-ARRAY DOUBLE-DOUBLE-FLOAT (*)).")
   (object-not-simple-array-complex-single-float
    "Object is not of type (SIMPLE-ARRAY (COMPLEX SINGLE-FLOAT) (*)).")
   (object-not-simple-array-complex-double-float
@@ -162,6 +168,9 @@
   #+long-float
   (object-not-simple-array-complex-long-float
    "Object is not of type (SIMPLE-ARRAY (COMPLEX LONG-FLOAT) (*)).")
+  #+double-double
+  (object-not-simple-array-complex-double-double-float
+   "Object is not of type (SIMPLE-ARRAY (COMPLEX DOUBLE-DOUBLE-FLOAT) (*)).")
   (object-not-complex
    "Object is not of type COMPLEX.")
   (object-not-complex-rational
@@ -175,6 +184,9 @@
   #+long-float
   (object-not-complex-long-float
    "Object is not of type (COMPLEX LONG-FLOAT).")
+  #+double-double
+  (object-not-complex-double-double-float
+   "Object is not of type (COMPLEX DOUBLE-DOUBLE-FLOAT)")
   (object-not-weak-pointer
    "Object is not a WEAK-POINTER.")
   (object-not-instance
diff --git a/compiler/generic/new-genesis.lisp b/compiler/generic/new-genesis.lisp
index 6178f1253cf6e313995426b14eb1cde32e77f477..ff0ed7b7941793c8443d31e4d73666c0f0b471ea 100644
--- a/compiler/generic/new-genesis.lisp
+++ b/compiler/generic/new-genesis.lisp
@@ -4,7 +4,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.78 2006/05/20 01:48:51 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.79 2006/06/30 18:41:23 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -482,6 +482,29 @@
 	  (write-indexed des (+ 2 vm:long-float-value-slot) exp-bits))
 	 (:big-endian
 	  (error "Long-Float not supported")))
+       des))
+    #+double-double
+    (double-double-float
+     (let* ((des (allocate-unboxed-object *dynamic* vm:word-bits
+					  (1- vm:double-double-float-size)
+					  vm:double-double-float-type))
+	    (hi (kernel:double-double-hi num))
+	    (lo (kernel:double-double-lo num))
+	    (hi-high-bits (make-random-descriptor (double-float-high-bits hi)))
+	    (hi-low-bits (make-random-descriptor (double-float-low-bits hi)))
+	    (lo-high-bits  (make-random-descriptor (double-float-high-bits lo)))
+	    (lo-low-bits (make-random-descriptor (double-float-low-bits lo))))
+       (ecase (c:backend-byte-order c:*backend*)
+	 (:little-endian
+	  (write-indexed des vm:double-double-float-lo-slot lo-low-bits)
+	  (write-indexed des (+ 1 vm:double-double-float-lo-slot) lo-high-bits)
+	  (write-indexed des vm:double-double-float-hi-slot hi-low-bits)
+	  (write-indexed des (+ 1 vm:double-double-float-hi-slot) hi-high-bits))
+	 (:big-endian
+	  (write-indexed des vm:double-double-float-hi-slot hi-high-bits)
+	  (write-indexed des (+ 1 vm:double-double-float-hi-slot) hi-low-bits)
+	  (write-indexed des vm:double-double-float-lo-slot lo-high-bits)
+	  (write-indexed des (1+ vm:double-double-float-lo-slot) lo-low-bits)))
        des))))
 
 (defun complex-single-float-to-core (num)
@@ -522,6 +545,55 @@
 	 (write-indexed des (1+ vm:complex-double-float-imag-slot) low-bits))))
     des))
 
+#+double-double
+(defun complex-double-double-float-to-core (num)
+  (declare (type (complex double-double-float) num))
+  (let ((des (allocate-unboxed-object *dynamic* vm:word-bits
+				      (1- vm::complex-double-double-float-size)
+				      vm::complex-double-double-float-type)))
+    (let* ((real (kernel:double-double-hi (realpart num)))
+	   (high-bits (make-random-descriptor (double-float-high-bits real)))
+	   (low-bits (make-random-descriptor (double-float-low-bits real))))
+      (ecase (c:backend-byte-order c:*backend*)
+	(:little-endian
+	 (write-indexed des vm:complex-double-double-float-real-hi-slot low-bits)
+	 (write-indexed des (1+ vm:complex-double-double-float-real-hi-slot) high-bits))
+	(:big-endian
+	 (write-indexed des vm:complex-double-double-float-real-hi-slot high-bits)
+	 (write-indexed des (1+ vm:complex-double-double-float-real-hi-slot) low-bits))))
+    (let* ((real (kernel:double-double-lo (realpart num)))
+	   (high-bits (make-random-descriptor (double-float-high-bits real)))
+	   (low-bits (make-random-descriptor (double-float-low-bits real))))
+      (ecase (c:backend-byte-order c:*backend*)
+	(:little-endian
+	 (write-indexed des vm:complex-double-double-float-real-lo-slot low-bits)
+	 (write-indexed des (1+ vm:complex-double-double-float-real-lo-slot) high-bits))
+	(:big-endian
+	 (write-indexed des vm:complex-double-double-float-real-lo-slot high-bits)
+	 (write-indexed des (1+ vm:complex-double-double-float-real-lo-slot) low-bits))))
+    (let* ((imag (kernel:double-double-hi (imagpart num)))
+	   (high-bits (make-random-descriptor (double-float-high-bits imag)))
+	   (low-bits (make-random-descriptor (double-float-low-bits imag))))
+      (ecase (c:backend-byte-order c:*backend*)
+	(:little-endian
+	 (write-indexed des vm:complex-double-double-float-imag-hi-slot low-bits)
+	 (write-indexed des (1+ vm:complex-double-double-float-imag-hi-slot) high-bits))
+	(:big-endian
+	 (write-indexed des vm:complex-double-double-float-imag-hi-slot high-bits)
+	 (write-indexed des (1+ vm:complex-double-double-float-imag-hi-slot) low-bits))))
+    (let* ((imag (kernel:double-double-lo (imagpart num)))
+	   (high-bits (make-random-descriptor (double-float-high-bits imag)))
+	   (low-bits (make-random-descriptor (double-float-low-bits imag))))
+      (ecase (c:backend-byte-order c:*backend*)
+	(:little-endian
+	 (write-indexed des vm:complex-double-double-float-imag-lo-slot low-bits)
+	 (write-indexed des (1+ vm:complex-double-double-float-imag-lo-slot) high-bits))
+	(:big-endian
+	 (write-indexed des vm:complex-double-double-float-imag-lo-slot high-bits)
+	 (write-indexed des (1+ vm:complex-double-double-float-imag-lo-slot) low-bits))))
+    des))
+  
+
 (defun number-to-core (number)
   "Copy the given number to the core, or flame out if we can't deal with it."
   (typecase number
@@ -536,6 +608,8 @@
     #+long-float
     ((complex long-float)
      (error "~S isn't a cold-loadable number at all!" number))
+    #+double-double
+    ((complex double-double-float) (complex-double-double-float-to-core number))
     (complex (number-pair-to-core (number-to-core (realpart number))
 				  (number-to-core (imagpart number))
 				  vm:complex-type))
@@ -1384,6 +1458,9 @@
 (not-cold-fop fop-complex-single-float-vector)
 (not-cold-fop fop-complex-double-float-vector)
 #+long-float (not-cold-fop fop-complex-long-float-vector)
+;; Why is this not-cold-fop?  I'm just cargo-culting this.
+#+double-double (not-cold-fop fop-double-double-float-vector)
+#+double-double (not-cold-fop fop-complex-double-double-float-vector)
 
 (define-cold-fop (fop-array)
   (let* ((rank (read-arg 4))
@@ -1460,12 +1537,16 @@
 
 (cold-number fop-single-float)
 (cold-number fop-double-float)
+#+double-double
+(cold-number fop-double-double-float)
 (cold-number fop-integer)
 (cold-number fop-small-integer)
 (cold-number fop-word-integer)
 (cold-number fop-byte-integer)
 (cold-number fop-complex-single-float)
 (cold-number fop-complex-double-float)
+#+double-double
+(cold-number fop-complex-double-double-float)
 
 #+long-float
 (define-cold-fop (fop-long-float)
@@ -1555,6 +1636,24 @@
 			imag-low-bits)
 	 des)))))
 
+#+(and nil double-double)
+(define-cold-fop (fop-double-double-float)
+    ;; Double-double format
+    (prepare-for-fast-read-byte *fasl-file*
+      (let* ((des (allocate-unboxed-object *dynamic* vm:word-bits
+					   (1- vm:double-double-float-size)
+					   vm:double-double-float-type))
+	     (hi-high-bits (make-random-descriptor (fast-read-s-integer 4)))
+	     (hi-low-bits (make-random-descriptor (fast-read-u-integer 4)))
+	     (lo-high-bits (make-random-descriptor (fast-read-s-integer 4)))
+	     (lo-low-bits (make-random-descriptor (fast-read-s-integer 4))))
+	(done-with-fast-read-byte)
+	(write-indexed des vm:double-double-float-hi-slot hi-high-bits)
+	(write-indexed des (1+ vm:double-double-float-hi-slot) hi-low-bits)
+	(write-indexed des vm:double-double-float-lo-slot lo-high-bits)
+	(write-indexed des (1+ vm:double-double-float-lo-slot) lo-low-bits)
+	des)))
+
 (define-cold-fop (fop-ratio)
   (let ((den (pop-stack)))
     (number-pair-to-core (pop-stack) den vm:ratio-type)))
diff --git a/compiler/generic/objdef.lisp b/compiler/generic/objdef.lisp
index 1c3138b61869424ad570acdb77d3951a349cefcf..fd45d33d2409ebde8cb365f608191048348a865e 100644
--- a/compiler/generic/objdef.lisp
+++ b/compiler/generic/objdef.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/objdef.lisp,v 1.59 2005/04/08 04:11:01 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/objdef.lisp,v 1.60 2006/06/30 18:41:23 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -34,7 +34,6 @@
 	  code-header-type function-header-type closure-header-type
 	  closure-function-header-type return-pc-header-type
 	  byte-code-function-type byte-code-closure-type
-	  dylan-function-header-type
 	  value-cell-header-type symbol-header-type base-char-type
 	  sap-type unbound-marker-type weak-pointer-type
 	  instance-header-type funcallable-instance-header-type
@@ -47,6 +46,9 @@
 	  simple-array-complex-double-float-type
 	  simple-array-complex-long-float-type))
 
+#+double-double
+(export '(double-double-float double-double-float-type))
+
 (in-package "KERNEL")
 (export '(%make-funcallable-instance
 	  #+gengc funcallable-instance-entry-point
@@ -115,10 +117,12 @@
   single-float
   double-float
   #+long-float long-float
+  #+double-double double-double-float
   complex
   complex-single-float
   complex-double-float
   #+long-float complex-long-float
+  #+double-double complex-double-double-float
   
   simple-array
   simple-string
@@ -136,9 +140,11 @@
   simple-array-single-float
   simple-array-double-float
   #+long-float simple-array-long-float
+  #+double-double simple-array-double-double-float
   simple-array-complex-single-float
   simple-array-complex-double-float
   #+long-float simple-array-complex-long-float
+  #+double-double simple-array-complex-double-double-float
   complex-string
   complex-bit-vector
   complex-vector
@@ -150,7 +156,7 @@
   funcallable-instance-header
   byte-code-function
   byte-code-closure
-  dylan-function-header
+  #-double-double dylan-function-header
   closure-function-header
   #-gengc return-pc-header
   #+gengc forwarding-pointer
@@ -529,3 +535,21 @@
   #+sparc (filler)
   (real :c-type "long double" :length #+x86 3 #+sparc 4)
   (imag :c-type "long double" :length #+x86 3 #+sparc 4))
+
+#+double-double
+(define-primitive-object (double-double-float
+			  :lowtag other-pointer-type
+			  :header double-double-float-type)
+  (filler)
+  (hi :c-type "double" :length 2)
+  (lo :c-type "double" :length 2))
+
+#+double-double
+(define-primitive-object (complex-double-double-float
+			  :lowtag other-pointer-type
+			  :header complex-double-double-float-type)
+  (filler)
+  (real-hi :c-type "double" :length 2)
+  (real-lo :c-type "double" :length 2)
+  (imag-hi :c-type "double" :length 2)
+  (imag-lo :c-type "double" :length 2))
diff --git a/compiler/generic/primtype.lisp b/compiler/generic/primtype.lisp
index 52ef540144390c86ebe4d2e70785c014e82d49e9..55d64bc44736f374ebbe31705852d00a16ce6d04 100644
--- a/compiler/generic/primtype.lisp
+++ b/compiler/generic/primtype.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/primtype.lisp,v 1.24 2004/05/24 23:15:31 cwang Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/primtype.lisp,v 1.25 2006/06/30 18:41:23 rtoy Rel $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -105,6 +105,10 @@
 (def-primitive-type double-float (double-reg descriptor-reg))
 #+long-float
 (def-primitive-type long-float (long-reg descriptor-reg))
+
+#+double-double
+(def-primitive-type double-double-float (double-double-reg descriptor-reg))
+
 (def-primitive-type complex-single-float (complex-single-reg descriptor-reg)
   :type (complex single-float))
 (def-primitive-type complex-double-float (complex-double-reg descriptor-reg)
@@ -112,6 +116,9 @@
 #+long-float
 (def-primitive-type complex-long-float (complex-long-reg descriptor-reg)
   :type (complex long-float))
+#+double-double
+(def-primitive-type complex-double-double-float (complex-double-double-reg descriptor-reg)
+  :type (complex double-double-float))
 
 ;;; Primitive other-pointer array types.
 ;;; 
@@ -142,6 +149,9 @@
   :type (simple-array single-float (*)))
 (def-primitive-type simple-array-double-float (descriptor-reg)
   :type (simple-array double-float (*)))
+#+double-double
+(def-primitive-type simple-array-double-double-float (descriptor-reg)
+  :type (simple-array double-double-float (*)))
 #+long-float
 (def-primitive-type simple-array-long-float (descriptor-reg)
   :type (simple-array long-float (*)))
@@ -152,6 +162,9 @@
 #+long-float
 (def-primitive-type simple-array-complex-long-float (descriptor-reg)
   :type (simple-array (complex long-float) (*)))
+#+double-double
+(def-primitive-type simple-array-complex-double-double-float (descriptor-reg)
+  :type (simple-array (complex double-double-float) (*)))
 
 ;;; Note: The complex array types are not inclueded, 'cause it is pointless to
 ;;; restrict VOPs to them.
@@ -198,10 +211,13 @@
     (single-float . simple-array-single-float)
     (double-float . simple-array-double-float)
     #+long-float (long-float . simple-array-long-float)
+    #+double-double
+    (double-double-float . simple-array-double-double-float)
     ((complex single-float) . simple-array-complex-single-float)
     ((complex double-float) . simple-array-complex-double-float)
     #+long-float
     ((complex long-float) . simple-array-complex-long-float)
+    #+double-double ((complex double-double-float) . simple-array-complex-double-double-float)
     (t . simple-vector))
   "An a-list for mapping simple array element types to their
   corresponding primitive types.")
@@ -344,6 +360,10 @@
 		     (long-float
 		      (values (primitive-type-or-lose 'long-float *backend*)
 			      exact))
+		     #+double-double
+		     (double-double-float
+		      (values (primitive-type-or-lose 'double-double-float *backend*)
+			      exact))
 		     (t
 		      (any)))))
 		(t
@@ -365,6 +385,11 @@
 		       (values (primitive-type-or-lose 'complex-long-float
 						       *backend*)
 			       exact))
+		      #+double-double
+		      (double-double-float
+		       (values (primitive-type-or-lose 'complex-double-double-float
+						       *backend*)
+			       exact))
 		      (t
 		       (part-of complex))))
 		  (part-of complex)))
diff --git a/compiler/generic/vm-fndb.lisp b/compiler/generic/vm-fndb.lisp
index f6159b2a0d66735fc1d31b57fac56f64eed48319..63cf8cd493ad4a633f9f357b6797158b96c0f444 100644
--- a/compiler/generic/vm-fndb.lisp
+++ b/compiler/generic/vm-fndb.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-fndb.lisp,v 1.65 2004/05/24 23:20:47 cwang Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-fndb.lisp,v 1.66 2006/06/30 18:41:23 rtoy Rel $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -48,8 +48,11 @@
 
 (defknown (fixnump bignump ratiop
 	   short-float-p single-float-p double-float-p long-float-p
+	   #+double-double double-double-float-p
 	   complex-rational-p complex-float-p complex-single-float-p
 	   complex-double-float-p #+long-float complex-long-float-p
+	   #+double-double
+	   complex-double-double-float-p
 	   base-char-p %standard-char-p %instancep
 	   array-header-p simple-array-p simple-array-unsigned-byte-2-p
 	   simple-array-unsigned-byte-4-p simple-array-unsigned-byte-8-p
@@ -61,9 +64,13 @@
 	   simple-array-complex-single-float-p
 	   simple-array-complex-double-float-p
 	   #+long-float simple-array-complex-long-float-p
+	   #+double-double simple-array-double-double-float-p
 	   system-area-pointer-p realp unsigned-byte-32-p signed-byte-32-p
 	   weak-pointer-p scavenger-hook-p code-component-p lra-p
-	   funcallable-instance-p)
+	   funcallable-instance-p
+	   #+double-double double-double-float-p
+	   #+double-double simple-array-double-double-float-p
+	   #+double-double simple-array-complex-double-double-float-p)
   (t) boolean (movable foldable flushable))
 
 
diff --git a/compiler/generic/vm-type.lisp b/compiler/generic/vm-type.lisp
index 75197867117a2a2aebc552203d7f8c8d12f4b09d..7688825809f8f9309ed467c0918b4bbd9c054366 100644
--- a/compiler/generic/vm-type.lisp
+++ b/compiler/generic/vm-type.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-type.lisp,v 1.43 2003/10/13 11:24:14 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-type.lisp,v 1.44 2006/06/30 18:41:23 rtoy Rel $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -97,8 +97,10 @@
     (signed-byte 8) (signed-byte 16) (signed-byte 30) (signed-byte 32)
     (complex single-float) (complex double-float)
     #+long-float (complex long-float)
+    #+double-double (complex double-double-float)
     base-char single-float double-float
-    #+long-float long-float))
+    #+long-float long-float
+    #+double-double double-double-float))
 
 (deftype unboxed-array (&optional dims)
   (collect ((types (list 'or)))
@@ -120,11 +122,12 @@
 ;;;    Return the symbol that describes the format of Float.
 ;;;
 (defun float-format-name (x)
-  (declare (float x) (values symbol))
+  (declare #+nil(float x) (values symbol))
   (etypecase x
     (single-float 'single-float)
     (double-float 'double-float)
-    #+long-float (long-float 'long-float)))
+    #+long-float (long-float 'long-float)
+    #+double-double (double-double-float 'double-double-float)))
 
 ;;; Specialize-Array-Type  --  Internal
 ;;;
diff --git a/compiler/generic/vm-typetran.lisp b/compiler/generic/vm-typetran.lisp
index dc08a69afd9290f4d10ea7409d892b8b8d16b8b2..f93bab595a26984d5b363f9ac76906ee6da32772 100644
--- a/compiler/generic/vm-typetran.lisp
+++ b/compiler/generic/vm-typetran.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-typetran.lisp,v 1.16 1998/07/24 17:22:32 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-typetran.lisp,v 1.17 2006/06/30 18:41:23 rtoy Rel $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -31,9 +31,13 @@
 (define-type-predicate complex-single-float-p (complex single-float))
 #+long-float
 (define-type-predicate complex-long-float-p (complex long-float))
+#+double-double
+(define-type-predicate complex-double-double-float-p (complex double-double-float))
 (define-type-predicate double-float-p double-float)
 (define-type-predicate fixnump fixnum)
 (define-type-predicate long-float-p long-float)
+#+double-double
+(define-type-predicate double-double-float-p double-double-float)
 (define-type-predicate ratiop ratio)
 (define-type-predicate short-float-p short-float)
 (define-type-predicate single-float-p single-float)
@@ -63,6 +67,10 @@
 #+long-float
 (define-type-predicate simple-array-long-float-p
 		       (simple-array long-float (*)))
+#+(and t double-double)
+(define-type-predicate simple-array-double-double-float-p
+		       (simple-array double-double-float (*)))
+
 (define-type-predicate simple-array-complex-single-float-p
 		       (simple-array (complex single-float) (*)))
 (define-type-predicate simple-array-complex-double-float-p
@@ -70,6 +78,9 @@
 #+long-float
 (define-type-predicate simple-array-complex-long-float-p
 		       (simple-array (complex long-float) (*)))
+#+(and t double-double)
+(define-type-predicate simple-array-complex-double-double-float-p
+		       (simple-array (complex double-double-float) (*)))
 (define-type-predicate system-area-pointer-p system-area-pointer)
 (define-type-predicate unsigned-byte-32-p (unsigned-byte 32))
 (define-type-predicate signed-byte-32-p (signed-byte 32))
diff --git a/compiler/ir1util.lisp b/compiler/ir1util.lisp
index fc6607ac8cff2d96c4104edf29071ad0fa66a5e6..145999b5c1e034cdc45ea9e91afe98dfd49bc640 100644
--- a/compiler/ir1util.lisp
+++ b/compiler/ir1util.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/ir1util.lisp,v 1.109 2004/12/16 21:55:37 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1util.lisp,v 1.110 2006/06/30 18:41:23 rtoy Rel $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1615,7 +1615,7 @@
   (ref-leaf (continuation-use (basic-combination-fun call))))
 
 
-(defvar *inline-expansion-limit* 200
+(defvar *inline-expansion-limit* 400
   "An upper limit on the number of inline function calls that will be expanded
    in any given code object (single function or block compilation.)")
 
diff --git a/compiler/ppc/array.lisp b/compiler/ppc/array.lisp
index 94824c4cd92514e8af7aac57860449df4e4021a3..343f42826f8acb9449c683b371630a5bd913827d 100644
--- a/compiler/ppc/array.lisp
+++ b/compiler/ppc/array.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/array.lisp,v 1.6 2006/01/18 15:21:26 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/array.lisp,v 1.7 2006/06/30 18:41:24 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -614,3 +614,121 @@
   (:results (result :scs (signed-reg)))
   (:result-types tagged-num))
 
+
+#+double-double
+(progn
+(define-vop (data-vector-ref/simple-array-double-double-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (index :scs (any-reg)))
+  (:arg-types vm::simple-array-double-double-float positive-fixnum)
+  (:results (value :scs (double-double-reg)))
+  (:result-types double-double-float)
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
+  (:generator 7
+    (let ((real-tn (double-double-reg-hi-tn value)))
+      (inst slwi offset index 2)
+      (inst addi offset offset (- (* vm:vector-data-offset vm:word-bytes)
+				  vm:other-pointer-type))
+      (inst lfdx real-tn object offset))
+    (let ((imag-tn (double-double-reg-lo-tn value)))
+      (inst addi offset offset (* 2 vm:word-bytes))
+      (inst lfdx imag-tn object offset))))
+
+(define-vop (data-vector-set/simple-array-double-double-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (index :scs (any-reg))
+	 (value :scs (double-double-reg) :target result))
+  (:arg-types vm::simple-array-double-double-float positive-fixnum
+	      double-double-float)
+  (:results (result :scs (double-double-reg)))
+  (:result-types double-double-float)
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
+  (:generator 20
+    (let ((value-real (double-double-reg-hi-tn value))
+	  (result-real (double-double-reg-hi-tn result)))
+      (inst slwi offset index 2)
+      (inst addi offset offset (- (* vm:vector-data-offset vm:word-bytes)
+				  vm:other-pointer-type))
+      (inst stfdx value-real object offset)
+      (unless (location= result-real value-real)
+	(inst fmr result-real value-real)))
+    (let ((value-imag (double-double-reg-lo-tn value))
+	  (result-imag (double-double-reg-lo-tn result)))
+      (inst addi offset offset (* 2 vm:word-bytes))
+      (inst stfdx value-imag object offset)
+      (unless (location= result-imag value-imag)
+	(inst fmr result-imag value-imag)))))
+
+(define-vop (data-vector-ref/simple-array-complex-double-double-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (index :scs (any-reg)))
+  (:arg-types simple-array-complex-double-double-float positive-fixnum)
+  (:results (value :scs (complex-double-double-reg)))
+  (:result-types complex-double-double-float)
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
+  (:generator 7
+    (let ((real-tn (complex-double-double-reg-real-hi-tn value)))
+      (inst slwi offset index 3)
+      (inst addi offset offset (- (* vm:vector-data-offset vm:word-bytes)
+				  vm:other-pointer-type))
+      (inst lfdx real-tn object offset))
+    (let ((real-tn (complex-double-double-reg-real-lo-tn value)))
+      (inst addi offset offset (* 2 vm:word-bytes))
+      (inst lfdx real-tn object offset))
+    (let ((imag-tn (complex-double-double-reg-imag-hi-tn value)))
+      (inst addi offset offset (* 2 vm:word-bytes))
+      (inst lfdx imag-tn object offset))
+    (let ((imag-tn (complex-double-double-reg-imag-lo-tn value)))
+      (inst addi offset offset (* 2 vm:word-bytes))
+      (inst lfdx imag-tn object offset))))
+
+(define-vop (data-vector-set/simple-array-complex-double-double-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (index :scs (any-reg))
+	 (value :scs (complex-double-double-reg) :target result))
+  (:arg-types simple-array-complex-double-double-float positive-fixnum
+	      complex-double-double-float)
+  (:results (result :scs (complex-double-double-reg)))
+  (:result-types complex-double-double-float)
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
+  (:generator 20
+    (let ((value-real (complex-double-double-reg-real-hi-tn value))
+	  (result-real (complex-double-double-reg-real-hi-tn result)))
+      (inst slwi offset index 3)
+      (inst addi offset offset (- (* vm:vector-data-offset vm:word-bytes)
+				  vm:other-pointer-type))
+      (inst stfdx value-real object offset)
+      (unless (location= result-real value-real)
+	(inst fmr result-real value-real)))
+    (let ((value-real (complex-double-double-reg-real-lo-tn value))
+	  (result-real (complex-double-double-reg-real-lo-tn result)))
+      (inst addi offset offset (* 2 vm:word-bytes))
+      (inst stfdx value-real object offset)
+      (unless (location= result-real value-real)
+	(inst fmr result-real value-real)))
+    (let ((value-imag (complex-double-double-reg-imag-hi-tn value))
+	  (result-imag (complex-double-double-reg-imag-hi-tn result)))
+      (inst addi offset offset (* 2 vm:word-bytes))
+      (inst stfdx value-imag object offset)
+      (unless (location= result-imag value-imag)
+	(inst fmr result-imag value-imag)))
+    (let ((value-imag (complex-double-double-reg-imag-lo-tn value))
+	  (result-imag (complex-double-double-reg-imag-lo-tn result)))
+      (inst addi offset offset (* 2 vm:word-bytes))
+      (inst stfdx value-imag object offset)
+      (unless (location= result-imag value-imag)
+	(inst fmr result-imag value-imag)))))
+
+)
diff --git a/compiler/ppc/float.lisp b/compiler/ppc/float.lisp
index 59682cc6daeb6987fde8cfdeb25e9cb2113d90a9..e883e559e38cec8011474c2b4b4ce1d8b339af9b 100644
--- a/compiler/ppc/float.lisp
+++ b/compiler/ppc/float.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/float.lisp,v 1.5 2005/11/17 03:33:45 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/float.lisp,v 1.6 2006/06/30 18:41:24 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -141,6 +141,21 @@
   (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
 		  :offset (1+ (tn-offset x))))
 
+#+double-double
+(progn
+(defun complex-double-double-reg-real-hi-tn (x)
+  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
+		  :offset (tn-offset x)))
+(defun complex-double-double-reg-real-lo-tn (x)
+  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
+		  :offset (+ 1 (tn-offset x))))
+(defun complex-double-double-reg-imag-hi-tn (x)
+  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
+		  :offset (+ 2 (tn-offset x))))
+(defun complex-double-double-reg-imag-lo-tn (x)
+  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
+		  :offset (+ 3 (tn-offset x))))
+)
 
 (define-move-function (load-complex-single 2) (vop x y)
   ((complex-single-stack) (complex-single-reg))
@@ -180,6 +195,35 @@
       (inst stfd imag-tn nfp (+ offset (* 2 vm:word-bytes))))))
 
 
+#+double-double
+(progn
+(define-move-function (load-complex-double-double 4) (vop x y)
+  ((complex-double-double-stack) (complex-double-double-reg))
+  (let ((nfp (current-nfp-tn vop))
+	(offset (* (tn-offset x) vm:word-bytes)))
+    (let ((value-tn (complex-double-double-reg-real-hi-tn y)))
+      (inst lfd value-tn nfp offset))
+    (let ((value-tn (complex-double-double-reg-real-lo-tn y)))
+      (inst lfd value-tn nfp (+ offset (* 2 vm:word-bytes))))
+    (let ((value-tn (complex-double-double-reg-imag-hi-tn y)))
+      (inst lfd value-tn nfp (+ offset (* 4 vm:word-bytes))))
+    (let ((value-tn (complex-double-double-reg-imag-lo-tn y)))
+      (inst lfd value-tn nfp (+ offset (* 6 vm:word-bytes))))))
+
+(define-move-function (store-complex-double-double 4) (vop x y)
+  ((complex-double-double-reg) (complex-double-double-stack))
+  (let ((nfp (current-nfp-tn vop))
+	(offset (* (tn-offset y) vm:word-bytes)))
+    (let ((value-tn (complex-double-double-reg-real-hi-tn x)))
+      (inst stfd value-tn nfp offset))
+    (let ((value-tn (complex-double-double-reg-real-lo-tn x)))
+      (inst stfd value-tn nfp (+ offset (* 2 vm:word-bytes))))
+    (let ((value-tn (complex-double-double-reg-imag-hi-tn x)))
+      (inst stfd value-tn nfp (+ offset (* 4 vm:word-bytes))))
+    (let ((value-tn (complex-double-double-reg-imag-lo-tn x)))
+      (inst stfd value-tn nfp (+ offset (* 6 vm:word-bytes))))))
+
+)
 ;;;
 ;;; Complex float register to register moves.
 ;;;
@@ -221,6 +265,32 @@
 (define-move-vop complex-double-move :move
   (complex-double-reg) (complex-double-reg))
 
+#+double-double
+(define-vop (complex-double-double-move)
+  (:args (x :scs (complex-double-double-reg)
+	    :target y :load-if (not (location= x y))))
+  (:results (y :scs (complex-double-double-reg) :load-if (not (location= x y))))
+  (:note "complex double float move")
+  (:generator 0
+     (unless (location= x y)
+       ;; Note the complex-float-regs are aligned to every second
+       ;; float register so there is not need to worry about overlap.
+       (let ((x-real (complex-double-double-reg-real-hi-tn x))
+	     (y-real (complex-double-double-reg-real-hi-tn y)))
+	 (inst fmr y-real x-real))
+       (let ((x-real (complex-double-double-reg-real-lo-tn x))
+	     (y-real (complex-double-double-reg-real-lo-tn y)))
+	 (inst fmr y-real x-real))
+       (let ((x-real (complex-double-double-reg-imag-hi-tn x))
+	     (y-real (complex-double-double-reg-imag-hi-tn y)))
+	 (inst fmr y-real x-real))
+       (let ((x-imag (complex-double-double-reg-imag-lo-tn x))
+	     (y-imag (complex-double-double-reg-imag-lo-tn y)))
+	 (inst fmr y-imag x-imag)))))
+;;;
+#+double-double
+(define-move-vop complex-double-double-move :move
+  (complex-double-double-reg) (complex-double-double-reg))
 
 ;;;
 ;;; Move from a complex float to a descriptor register allocating a
@@ -268,6 +338,37 @@
 (define-move-vop move-from-complex-double :move
   (complex-double-reg) (descriptor-reg))
 
+#+double-double
+(define-vop (move-from-complex-double-double)
+  (:args (x :scs (complex-double-double-reg) :to :save))
+  (:results (y :scs (descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg)) ndescr)
+  (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
+  (:note "complex double float to pointer coercion")
+  (:generator 13
+     (with-fixed-allocation (y pa-flag ndescr vm::complex-double-double-float-type
+			       vm::complex-double-double-float-size))
+     (let ((real-tn (complex-double-double-reg-real-hi-tn x)))
+       (inst stfd real-tn y (- (* vm::complex-double-double-float-real-hi-slot
+				  vm:word-bytes)
+			       vm:other-pointer-type)))
+     (let ((real-tn (complex-double-double-reg-real-lo-tn x)))
+       (inst stfd real-tn y (- (* vm::complex-double-double-float-real-lo-slot
+				  vm:word-bytes)
+			       vm:other-pointer-type)))
+     (let ((imag-tn (complex-double-double-reg-imag-hi-tn x)))
+       (inst stfd imag-tn y (- (* vm::complex-double-double-float-imag-hi-slot
+				  vm:word-bytes)
+			       vm:other-pointer-type)))
+     (let ((imag-tn (complex-double-double-reg-imag-lo-tn x)))
+       (inst stfd imag-tn y (- (* vm::complex-double-double-float-imag-lo-slot
+				  vm:word-bytes)
+			       vm:other-pointer-type)))))
+;;;
+#+double-double
+(define-move-vop move-from-complex-double-double :move
+  (complex-double-double-reg) (descriptor-reg))
+
 
 ;;;
 ;;; Move from a descriptor to a complex float register
@@ -301,6 +402,27 @@
   (descriptor-reg) (complex-double-reg))
 
 
+#+double-double
+(define-vop (move-to-complex-double-double)
+  (:args (x :scs (descriptor-reg)))
+  (:results (y :scs (complex-double-double-reg)))
+  (:note "pointer to complex float coercion")
+  (:generator 2
+    (let ((real-tn (complex-double-double-reg-real-hi-tn y)))
+      (inst lfd real-tn x (- (* complex-double-double-float-real-hi-slot word-bytes)
+			      other-pointer-type)))
+    (let ((real-tn (complex-double-double-reg-real-lo-tn y)))
+      (inst lfd real-tn x (- (* complex-double-double-float-real-lo-slot word-bytes)
+			      other-pointer-type)))
+    (let ((imag-tn (complex-double-double-reg-imag-hi-tn y)))
+      (inst lfd imag-tn x (- (* complex-double-double-float-imag-hi-slot word-bytes)
+			      other-pointer-type)))
+    (let ((imag-tn (complex-double-double-reg-imag-lo-tn y)))
+      (inst lfd imag-tn x (- (* complex-double-double-float-imag-lo-slot word-bytes)
+			      other-pointer-type)))))
+#+double-double
+(define-move-vop move-to-complex-double-double :move
+  (descriptor-reg) (complex-double-double-reg))
 ;;;
 ;;; Complex float move-argument vop
 ;;;
@@ -352,9 +474,47 @@
 (define-move-vop move-complex-double-float-argument :move-argument
   (complex-double-reg descriptor-reg) (complex-double-reg))
 
+#+double-double
+(define-vop (move-complex-double-double-float-argument)
+  (:args (x :scs (complex-double-double-reg) :target y)
+	 (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-double-reg))))
+  (:results (y))
+  (:note "complex long-float argument move")
+  (:generator 2
+    (sc-case y
+      (complex-double-double-reg
+       (unless (location= x y)
+	 (let ((x-real (complex-double-double-reg-real-hi-tn x))
+	       (y-real (complex-double-double-reg-real-hi-tn y)))
+	   (inst fmr y-real x-real))
+	 (let ((x-real (complex-double-double-reg-real-lo-tn x))
+	       (y-real (complex-double-double-reg-real-lo-tn y)))
+	   (inst fmr y-real x-real))
+	 (let ((x-imag (complex-double-double-reg-imag-hi-tn x))
+	       (y-imag (complex-double-double-reg-imag-hi-tn y)))
+	   (inst fmr y-imag x-imag))
+	 (let ((x-imag (complex-double-double-reg-imag-lo-tn x))
+	       (y-imag (complex-double-double-reg-imag-lo-tn y)))
+	   (inst fmr y-imag x-imag))))
+      (complex-double-double-stack
+       (let ((offset (* (tn-offset y) word-bytes)))
+	 (let ((real-tn (complex-double-double-reg-real-hi-tn x)))
+	   (inst stfd real-tn nfp offset))
+	 (let ((real-tn (complex-double-double-reg-real-lo-tn x)))
+	   (inst stfd real-tn nfp (+ offset (* 2 word-bytes))))
+	 (let ((imag-tn (complex-double-double-reg-imag-hi-tn x)))
+	   (inst stfd imag-tn nfp (+ offset (* 4 word-bytes))))
+	 (let ((imag-tn (complex-double-double-reg-imag-lo-tn x)))
+	   (inst stfd imag-tn nfp (+ offset (* 6 word-bytes)))))))))
+
+#+long-float
+(define-move-vop move-complex-long-float-argument :move-argument
+  (complex-long-reg descriptor-reg) (complex-long-reg))
 
 (define-move-vop move-argument :move-argument
-  (single-reg double-reg complex-single-reg complex-double-reg)
+  (single-reg double-reg complex-single-reg complex-double-reg
+	      #+double-double double-double-reg
+	      #+double-double complex-double-double-reg)
   (descriptor-reg))
 
 
@@ -930,3 +1090,273 @@
   (:variant :imag))
 
 
+;;; Support for double-double floats
+
+#+double-double
+(progn
+(deftransform eql ((x y) (double-double-float double-double-float))
+  '(and (eql (double-double-hi x) (double-double-hi y))
+     	(eql (double-double-lo x) (double-double-lo y))))
+
+(defun double-double-reg-hi-tn (x)
+  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
+		  :offset (tn-offset x)))
+
+(defun double-double-reg-lo-tn (x)
+  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
+		  :offset (1+ (tn-offset x))))
+
+(define-move-function (load-double-double 4) (vop x y)
+  ((double-double-stack) (double-double-reg))
+  (let ((nfp (current-nfp-tn vop))
+	(offset (* (tn-offset x) vm:word-bytes)))
+    (let ((hi-tn (double-double-reg-hi-tn y)))
+      (inst lfd hi-tn nfp offset))
+    (let ((lo-tn (double-double-reg-lo-tn y)))
+      (inst lfd lo-tn nfp (+ offset (* 2 vm:word-bytes))))))
+
+(define-move-function (store-double-double 4) (vop x y)
+  ((double-double-reg) (double-double-stack))
+  (let ((nfp (current-nfp-tn vop))
+	(offset (* (tn-offset y) vm:word-bytes)))
+    (let ((hi-tn (double-double-reg-hi-tn x)))
+      (inst stfd hi-tn nfp offset))
+    (let ((lo-tn (double-double-reg-lo-tn x)))
+      (inst stfd lo-tn nfp (+ offset (* 2 vm:word-bytes))))))
+
+;;; Double-double float register to register moves
+
+(define-vop (double-double-move)
+  (:args (x :scs (double-double-reg)
+	    :target y :load-if (not (location= x y))))
+  (:results (y :scs (double-double-reg) :load-if (not (location= x y))))
+  (:note "double-double float move")
+  (:generator 0
+     (unless (location= x y)
+       ;; Note the double-float-regs are aligned to every second
+       ;; float register so there is not need to worry about overlap.
+       (let ((x-hi (double-double-reg-hi-tn x))
+	     (y-hi (double-double-reg-hi-tn y)))
+	 (inst fmr y-hi x-hi))
+       (let ((x-lo (double-double-reg-lo-tn x))
+	     (y-lo (double-double-reg-lo-tn y)))
+	 (inst fmr y-lo x-lo)))))
+;;;
+(define-move-vop double-double-move :move
+  (double-double-reg) (double-double-reg))
+
+;;; Move from a complex float to a descriptor register allocating a
+;;; new complex float object in the process.
+
+(define-vop (move-from-double-double)
+  (:args (x :scs (double-double-reg) :to :save))
+  (:results (y :scs (descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg)) ndescr)
+  (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
+  (:note "double double float to pointer coercion")
+  (:generator 13
+     (with-fixed-allocation (y pa-flag ndescr vm::double-double-float-type
+			       vm::double-double-float-size))
+     (let ((hi-tn (double-double-reg-hi-tn x)))
+       (inst stfd hi-tn y (- (* vm::double-double-float-hi-slot
+				  vm:word-bytes)
+			       vm:other-pointer-type)))
+     (let ((lo-tn (double-double-reg-lo-tn x)))
+       (inst stfd lo-tn y (- (* vm::double-double-float-lo-slot
+				  vm:word-bytes)
+			       vm:other-pointer-type)))))
+;;;
+(define-move-vop move-from-double-double :move
+  (double-double-reg) (descriptor-reg))
+
+;;; Move from a descriptor to a double-double float register
+
+(define-vop (move-to-double-double)
+  (:args (x :scs (descriptor-reg)))
+  (:results (y :scs (double-double-reg)))
+  (:note "pointer to double float coercion")
+  (:generator 2
+    (let ((hi-tn (double-double-reg-hi-tn y)))
+      (inst lfd hi-tn x (- (* double-double-float-hi-slot word-bytes)
+			     other-pointer-type)))
+    (let ((lo-tn (double-double-reg-lo-tn y)))
+      (inst lfd lo-tn x (- (* double-double-float-lo-slot word-bytes)
+			   other-pointer-type)))))
+
+(define-move-vop move-to-double-double :move
+  (descriptor-reg) (double-double-reg))
+
+;;; double-double float move-argument vop
+
+(define-vop (move-double-double-float-argument)
+  (:args (x :scs (double-double-reg) :target y)
+	 (nfp :scs (any-reg) :load-if (not (sc-is y double-double-reg))))
+  (:results (y))
+  (:note "double double-float argument move")
+  (:generator 2
+    (sc-case y
+      (double-double-reg
+       (unless (location= x y)
+	 (let ((x-hi (double-double-reg-hi-tn x))
+	       (y-hi (double-double-reg-hi-tn y)))
+	   (inst fmr y-hi x-hi))
+	 (let ((x-lo (double-double-reg-lo-tn x))
+	       (y-lo (double-double-reg-lo-tn y)))
+	   (inst fmr y-lo x-lo))))
+      (double-double-stack
+       (let ((offset (* (tn-offset y) word-bytes)))
+	 (let ((hi-tn (double-double-reg-hi-tn x)))
+	   (inst stfd hi-tn nfp offset))
+	 (let ((lo-tn (double-double-reg-lo-tn x)))
+	   (inst stfd lo-tn nfp (+ offset (* 2 word-bytes)))))))))
+
+(define-move-vop move-double-double-float-argument :move-argument
+  (double-double-reg descriptor-reg) (double-double-reg))
+
+
+(define-vop (make/double-double-float)
+  (:args (hi :scs (double-reg) :target r
+	     :load-if (not (location= hi r)))
+	 (lo :scs (double-reg) :to :save))
+  (:arg-types double-float double-float)
+  (:results (r :scs (double-double-reg) :from (:argument 0)
+	       :load-if (not (sc-is r double-double-stack))))
+  (:result-types double-double-float)
+  (:translate kernel::%make-double-double-float)
+  (:note "inline double-double-float creation")
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 2
+    (sc-case r
+      (double-double-reg
+       (let ((r-hi (double-double-reg-hi-tn r)))
+	 (unless (location= hi r-hi)
+	   (inst fmr r-hi hi)))
+       (let ((r-lo (double-double-reg-lo-tn r)))
+	 (unless (location= lo r-lo)
+	   (inst fmr r-lo lo))))
+      (double-double-stack
+       (let ((nfp (current-nfp-tn vop))
+	     (offset (* (tn-offset r) vm:word-bytes)))
+	 (unless (location= hi r)
+	   (inst stfd hi nfp offset))
+	 (inst stfd lo nfp (+ offset (* 2 vm:word-bytes))))))))
+
+(define-vop (double-double-float-value)
+  (:args (x :scs (double-double-reg) :target r
+	    :load-if (not (sc-is x double-double-stack))))
+  (:arg-types double-double-float)
+  (:results (r :scs (double-reg)))
+  (:result-types double-float)
+  (:variant-vars slot)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 3
+    (sc-case x
+      (double-double-reg
+       (let ((value-tn (ecase slot
+			 (:hi (double-double-reg-hi-tn x))
+			 (:lo (double-double-reg-lo-tn x)))))
+	 (unless (location= value-tn r)
+	   (inst fmr r value-tn))))
+      (double-double-stack
+       (inst lfd r (current-nfp-tn vop) (* (+ (ecase slot
+						(:hi 0)
+						(:lo 2))
+					      (tn-offset x))
+					   vm:word-bytes))))))
+
+(define-vop (hi/double-double-float double-double-float-value)
+  (:translate kernel::double-double-hi)
+  (:note "double-double float high part")
+  (:variant :hi))
+
+(define-vop (lo/double-double-float double-double-float-value)
+  (:translate kernel::double-double-lo)
+  (:note "double-double float low part")
+  (:variant :lo))
+
+(define-vop (make-complex-double-double-float)
+  (:translate complex)
+  (:args (real :scs (double-double-reg) :target r
+	       :load-if (not (location= real r)))
+	 (imag :scs (double-double-reg) :to :save))
+  (:arg-types double-double-float double-double-float)
+  (:results (r :scs (complex-double-double-reg) :from (:argument 0)
+	       :load-if (not (sc-is r complex-double-double-stack))))
+  (:result-types complex-double-double-float)
+  (:note "inline complex double-double-float creation")
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 5
+    (sc-case r
+      (complex-double-double-reg
+       (let ((r-real (complex-double-double-reg-real-hi-tn r))
+	     (real-hi (double-double-reg-hi-tn real)))
+	 (inst fmr r-real real-hi))
+       (let ((r-real (complex-double-double-reg-real-lo-tn r))
+	     (real-lo (double-double-reg-lo-tn real)))
+	 (inst fmr r-real real-lo))
+       (let ((r-imag (complex-double-double-reg-imag-hi-tn r))
+	     (imag-hi (double-double-reg-hi-tn imag)))
+	 (inst fmr r-imag imag-hi))
+       (let ((r-imag (complex-double-double-reg-imag-lo-tn r))
+	     (imag-lo (double-double-reg-lo-tn imag)))
+	 (inst fmr r-imag imag-lo)))
+      (complex-double-double-stack
+       (let ((nfp (current-nfp-tn vop))
+	     (offset (* (tn-offset r) vm:word-bytes)))
+	 (let ((r-real (complex-double-double-reg-real-hi-tn r)))
+	   (inst stfd r-real nfp offset))
+	 (let ((r-real (complex-double-double-reg-real-lo-tn r)))
+	   (inst stfd r-real nfp (+ offset (* 2 vm:word-bytes))))
+	 (let ((r-imag (complex-double-double-reg-imag-hi-tn r)))
+	   (inst stfd r-imag nfp (+ offset (* 4 vm:word-bytes))))
+	 (let ((r-imag (complex-double-double-reg-imag-lo-tn r)))
+	   (inst stfd r-imag nfp (+ offset (* 6 vm:word-bytes)))))))))
+
+(define-vop (complex-double-double-float-value)
+  (:args (x :scs (complex-double-double-reg) :target r
+	    :load-if (not (sc-is x complex-double-double-stack))))
+  (:arg-types complex-double-double-float)
+  (:results (r :scs (double-double-reg)))
+  (:result-types double-double-float)
+  (:variant-vars slot)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 3
+    (sc-case x
+      (complex-double-double-reg
+       (let ((value-tn (ecase slot
+			 (:real (complex-double-double-reg-real-hi-tn x))
+			 (:imag (complex-double-double-reg-imag-hi-tn x))))
+	     (r-hi (double-double-reg-hi-tn r)))
+	 (unless (location= value-tn r-hi)
+	   (inst fmr r-hi value-tn)))
+       (let ((value-tn (ecase slot
+			 (:real (complex-double-double-reg-real-lo-tn x))
+			 (:imag (complex-double-double-reg-imag-lo-tn x))))
+	     (r-lo (double-double-reg-lo-tn r)))
+	 (unless (location= value-tn r-lo)
+	   (inst fmr r-lo value-tn))))
+      (complex-double-double-stack
+       (let ((r-hi (double-double-reg-hi-tn r)))
+	 (inst lfd r-hi (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 4))
+						   (tn-offset x))
+						vm:word-bytes)))
+       (let ((r-lo (double-double-reg-lo-tn r)))
+	 (inst lfd r-lo (current-nfp-tn vop) (* (+ (ecase slot (:real 2) (:imag 6))
+						   (tn-offset x))
+						vm:word-bytes)))))))
+
+(define-vop (realpart/complex-double-double-float complex-double-double-float-value)
+  (:translate realpart)
+  (:note "complex double float realpart")
+  (:variant :real))
+
+(define-vop (imagpart/complex-double-double-float complex-double-double-float-value)
+  (:translate imagpart)
+  (:note "complex double float imagpart")
+  (:variant :imag))
+
+); progn
diff --git a/compiler/ppc/insts.lisp b/compiler/ppc/insts.lisp
index f6a1fbb213f65f36ec80aba7783997070479cdc0..6038a026bdb5ac7d405c36ed39c8bf62ef168d3d 100644
--- a/compiler/ppc/insts.lisp
+++ b/compiler/ppc/insts.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/insts.lisp,v 1.18 2006/03/18 05:17:49 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/insts.lisp,v 1.19 2006/06/30 18:41:24 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -104,10 +104,12 @@
 	single-float
 	double-float
 	#+long-float long-float
+	#+double-double double-double-float
 	complex
 	complex-single-float
 	complex-double-float
 	#+long-float complex-long-float
+	#+double-double complex-double-double-float
   
 	simple-array
 	simple-string
@@ -125,9 +127,11 @@
 	simple-array-single-float
 	simple-array-double-float
 	#+long-float simple-array-long-float
+	#+double-double simple-array-double-double-float
 	simple-array-complex-single-float
 	simple-array-complex-double-float
 	#+long-float simple-array-complex-long-float
+	#+double-double simple-array-complex-double-double-float
 	complex-string
 	complex-bit-vector
 	complex-vector
@@ -139,7 +143,7 @@
 	funcallable-instance-header
 	byte-code-function
 	byte-code-closure
-	dylan-function-header
+	#-double-double dylan-function-header
 	closure-function-header
 	#-gengc return-pc-header
 	#+gengc forwarding-pointer
diff --git a/compiler/ppc/parms.lisp b/compiler/ppc/parms.lisp
index 98398beecba682fe1fc673e1ed457d5441beb3c0..38578c4815d4a8f33830804e3e9c3bc19484302e 100644
--- a/compiler/ppc/parms.lisp
+++ b/compiler/ppc/parms.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/parms.lisp,v 1.11 2006/05/07 23:50:00 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/parms.lisp,v 1.12 2006/06/30 18:41:24 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -60,6 +60,8 @@
 	  float-imprecise-trap-bit float-invalid-trap-bit
 	  float-divide-by-zero-trap-bit))
 
+#+double-double
+(export '(double-double-float-digits))
 
 
 	  
@@ -103,6 +105,9 @@
 (defconstant double-float-digits
   (+ (byte-size double-float-significand-byte) word-bits 1))
 
+#+double-double
+(defconstant double-double-float-digits
+  (* 2 double-float-digits))
 
 (defconstant float-inexact-trap-bit (ash 1 0))
 (defconstant float-divide-by-zero-trap-bit (ash 1 1))
diff --git a/compiler/ppc/type-vops.lisp b/compiler/ppc/type-vops.lisp
index f20f9edb2f91fcbcc3c0fced79b4a49ba691e58c..e70570ec0a01e8213e2d6a6eceeac7919f5c15e3 100644
--- a/compiler/ppc/type-vops.lisp
+++ b/compiler/ppc/type-vops.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/type-vops.lisp,v 1.2 2001/02/11 16:43:19 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/type-vops.lisp,v 1.3 2006/06/30 18:41:24 rtoy Rel $")
 ;;;
 ;;; **********************************************************************
 ;;; 
@@ -114,14 +114,16 @@
 
 (def-type-vops complexp check-complex complex
   object-not-complex-error vm:complex-type
-  complex-single-float-type complex-double-float-type)
+  complex-single-float-type complex-double-float-type
+  #+double-double vm::complex-double-double-float-type)
 
 (def-type-vops complex-rational-p check-complex-rational nil
   object-not-complex-rational-error complex-type)
 
 (def-type-vops complex-float-p check-complex-float nil
   object-not-complex-float-error
-  complex-single-float-type complex-double-float-type)
+  complex-single-float-type complex-double-float-type
+  #+double-double vm::complex-double-double-float-type)
 
 (def-type-vops complex-single-float-p check-complex-single-float
   complex-single-float object-not-complex-single-float-error
@@ -131,12 +133,23 @@
   complex-double-float object-not-complex-double-float-error
   complex-double-float-type)
 
+#+double-double
+(def-type-vops complex-double-double-float-p check-complex-double-double-float
+  complex-double-double-float object-not-complex-double-double-float-error
+  vm::complex-double-double-float-type)
+
+
 (def-type-vops single-float-p check-single-float single-float
   object-not-single-float-error vm:single-float-type)
 
 (def-type-vops double-float-p check-double-float double-float
   object-not-double-float-error vm:double-float-type)
 
+#+double-double
+(def-type-vops double-double-float-p check-double-double-float
+  double-double-float object-not-double-double-float-error
+  vm:double-double-float-type)
+
 (def-type-vops simple-string-p check-simple-string simple-string
   object-not-simple-string-error vm:simple-string-type)
 
@@ -208,6 +221,11 @@
   simple-array-double-float object-not-simple-array-double-float-error
   vm:simple-array-double-float-type)
 
+#+double-double
+(def-type-vops simple-array-double-double-float-p check-simple-array-double-double-float
+  simple-array-double-double-float object-not-simple-array-double-double-float-error
+  vm::simple-array-double-double-float-type)
+
 (def-type-vops simple-array-complex-single-float-p
   check-simple-array-complex-single-float
   simple-array-complex-single-float
@@ -220,6 +238,13 @@
   object-not-simple-array-complex-double-float-error
   simple-array-complex-double-float-type)
 
+#+double-double
+(def-type-vops simple-array-complex-double-double-float-p
+  check-simple-array-complex-double-double-float
+  simple-array-complex-double-double-float
+  object-not-simple-array-complex-double-double-float-error
+  vm::simple-array-complex-double-double-float-type)
+
 (def-type-vops base-char-p check-base-char base-char
   object-not-base-char-error vm:base-char-type)
 
@@ -265,8 +290,10 @@
   simple-array-signed-byte-8-type simple-array-signed-byte-16-type
   simple-array-signed-byte-30-type simple-array-signed-byte-32-type
   simple-array-single-float-type simple-array-double-float-type
+  #+double-double vm::simple-array-double-double-float-type
   simple-array-complex-single-float-type
   simple-array-complex-double-float-type
+  #+double-double vm::simple-array-complex-double-double-float-type
   complex-string-type complex-bit-vector-type complex-vector-type)
 
 (def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error
@@ -277,8 +304,10 @@
   simple-array-signed-byte-8-type simple-array-signed-byte-16-type
   simple-array-signed-byte-30-type simple-array-signed-byte-32-type
   simple-array-single-float-type simple-array-double-float-type
+  #+double-double vm::simple-array-double-double-float-type
   simple-array-complex-single-float-type
-  simple-array-complex-double-float-type)
+  simple-array-complex-double-float-type
+  #+double-double vm::simple-array-complex-double-double-float-type)
 
 (def-type-vops arrayp check-array nil object-not-array-error
   simple-array-type simple-string-type simple-bit-vector-type
@@ -288,15 +317,20 @@
   simple-array-signed-byte-8-type simple-array-signed-byte-16-type
   simple-array-signed-byte-30-type simple-array-signed-byte-32-type
   simple-array-single-float-type simple-array-double-float-type
+  #+double-double vm::simple-array-double-double-float-type
   simple-array-complex-single-float-type
   simple-array-complex-double-float-type
+  #+double-double vm::simple-array-complex-double-double-float-type
   complex-string-type complex-bit-vector-type complex-vector-type
   complex-array-type)
 
 (def-type-vops numberp check-number nil object-not-number-error
   even-fixnum-type odd-fixnum-type bignum-type ratio-type
-  single-float-type double-float-type complex-type
-  complex-single-float-type complex-double-float-type)
+  single-float-type double-float-type
+  #+double-double vm:double-double-float-type
+  complex-type
+  complex-single-float-type complex-double-float-type
+  #+double-double vm::complex-double-double-float-type)
 
 (def-type-vops rationalp check-rational nil object-not-rational-error
   vm:even-fixnum-type vm:odd-fixnum-type vm:ratio-type vm:bignum-type)
@@ -305,11 +339,13 @@
   vm:even-fixnum-type vm:odd-fixnum-type vm:bignum-type)
 
 (def-type-vops floatp check-float nil object-not-float-error
-  vm:single-float-type vm:double-float-type)
+  vm:single-float-type vm:double-float-type
+  #+double-double vm:double-double-float-type)
 
 (def-type-vops realp check-real nil object-not-real-error
   vm:even-fixnum-type vm:odd-fixnum-type vm:ratio-type vm:bignum-type
-  vm:single-float-type vm:double-float-type)
+  vm:single-float-type vm:double-float-type
+  #+double-double vm:double-double-float-type)
 
 
 ;;;; Other integer ranges.
diff --git a/compiler/ppc/vm.lisp b/compiler/ppc/vm.lisp
index b7d438f09bd56a2f96db96e35b789498d9d7e4da..51d1eaaa19647b1a7ae88b2242d142d5e9b8b0fa 100644
--- a/compiler/ppc/vm.lisp
+++ b/compiler/ppc/vm.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/vm.lisp,v 1.4 2005/12/11 03:45:36 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/vm.lisp,v 1.5 2006/06/30 18:41:24 rtoy Rel $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -150,9 +150,13 @@
   (single-stack non-descriptor-stack) ; single-floats
   (double-stack non-descriptor-stack
 		:element-size 2 :alignment 2) ; double floats.
+  #+double-double
+  (double-double-stack non-descriptor-stack :element-size 4 :alignment 2)
   (complex-single-stack non-descriptor-stack :element-size 2)
   (complex-double-stack non-descriptor-stack :element-size 4 :alignment 2)
 
+  #+double-double
+  (complex-double-double-stack non-descriptor-stack :element-size 8 :alignment 4)
 
   ;; **** Things that can go in the integer registers.
 
@@ -227,20 +231,37 @@
    :save-p t
    :alternate-scs (double-stack))
 
+  ;; Non-descriptor double-double floats
+  #+double-double
+  (double-double-reg float-registers
+   :locations #.(loop for i from 0 to 30 by 2 collect i)
+   :element-size 2 :alignment 2
+   :constant-scs ()
+   :save-p t
+   :alternate-scs (double-double-stack))
+
   (complex-single-reg float-registers
    :locations #.(loop for i from 0 to 30 by 2 collect i)
-   :element-size 2
+   :element-size 2 :alignment 2
    :constant-scs ()
    :save-p t
    :alternate-scs (complex-single-stack))
 
   (complex-double-reg float-registers
    :locations #.(loop for i from 0 to 30 by 2 collect i)
-   :element-size 2
+   :element-size 2 :alignment 2
    :constant-scs ()
    :save-p t
    :alternate-scs (complex-double-stack))
 
+  #+double-double
+  (complex-double-double-reg float-registers
+   :locations #.(loop for i from 0 to 30 by 4 collect i)
+   :element-size 4 :alignment 4
+   :constant-scs ()
+   :save-p t
+   :alternate-scs (complex-double-double-stack))
+
   ;; A catch or unwind block.
   (catch-block control-stack :element-size vm:catch-block-size))
 
diff --git a/compiler/sparc/array.lisp b/compiler/sparc/array.lisp
index ecc102e2dd67cdc2075eabcd5496adb0154bea44..02b34cc863d26337a9fcdebb7ce3da965a628668 100644
--- a/compiler/sparc/array.lisp
+++ b/compiler/sparc/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/compiler/sparc/array.lisp,v 1.32 2003/11/05 15:14:53 toy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/array.lisp,v 1.33 2006/06/30 18:41:32 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -948,3 +948,280 @@
   (:results (result :scs (unsigned-reg)))
   (:result-types unsigned-num)
   (:variant 0 vm:other-pointer-type))
+
+
+#+double-double
+(progn
+(define-vop (data-vector-ref/simple-array-double-double-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (index :scs (any-reg)))
+  (:arg-types simple-array-double-double-float positive-fixnum)
+  (:results (value :scs (double-double-reg)))
+  (:result-types double-double-float)
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
+  (:generator 7
+    (let ((hi-tn (double-double-reg-hi-tn value)))
+      (inst slln offset index 2)
+      (inst add offset (- (* vm:vector-data-offset vm:word-bytes)
+			  vm:other-pointer-type))
+      (inst lddf hi-tn object offset))
+    (let ((lo-tn (double-double-reg-lo-tn value)))
+      (inst add offset (* 2 vm:word-bytes))
+      (inst lddf lo-tn object offset))))
+
+(define-vop (data-vector-ref-c/simple-array-double-double-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result))
+  (:arg-types simple-array-double-double-float (:constant index))
+  (:info index)
+  (:results (value :scs (double-double-reg)))
+  (:result-types double-double-float)
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp)
+  (:generator 5
+    (let ((offset (+ (* index 16)
+		     (- (* vm:vector-data-offset vm:word-bytes)
+			  vm:other-pointer-type)))
+	  (hi-tn (double-double-reg-hi-tn value))
+	  (lo-tn (double-double-reg-lo-tn value)))
+      (cond ((typep (+ offset 8) '(signed-byte 13))
+	     (inst lddf hi-tn object offset)
+	     (inst lddf lo-tn object (+ offset 8)))
+	    (t
+	     (inst li temp offset)
+	     (inst lddf hi-tn object temp)
+	     (inst add temp (* 2 vm:word-bytes))
+	     (inst lddf lo-tn object temp))))))
+
+(define-vop (data-vector-set/simple-array-double-double-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (index :scs (any-reg))
+	 (value :scs (double-double-reg) :target result))
+  (:arg-types simple-array-double-double-float positive-fixnum
+	      double-double-float)
+  (:results (result :scs (double-double-reg)))
+  (:result-types double-double-float)
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
+  (:generator 20
+    (let ((value-hi (double-double-reg-hi-tn value))
+	  (result-hi (double-double-reg-hi-tn result)))
+      (inst slln offset index 2)
+      (inst add offset (- (* vm:vector-data-offset vm:word-bytes)
+			  vm:other-pointer-type))
+      (inst stdf value-hi object offset)
+      (unless (location= result-hi value-hi)
+	(move-double-reg result-hi value-hi)))
+    (let ((value-lo (double-double-reg-lo-tn value))
+	  (result-lo (double-double-reg-lo-tn result)))
+      (inst add offset (* 2 vm:word-bytes))
+      (inst stdf value-lo object offset)
+      (unless (location= result-lo value-lo)
+	(move-double-reg result-lo value-lo)))))
+
+(define-vop (data-vector-set-c/simple-array-double-double-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (value :scs (double-double-reg) :target result))
+  (:arg-types simple-array-double-double-float
+	      (:constant index)
+	      double-double-float)
+  (:info index)
+  (:results (result :scs (double-double-reg)))
+  (:result-types double-double-float)
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp)
+  (:generator 15
+    (let ((value-hi (double-double-reg-hi-tn value))
+	  (result-hi (double-double-reg-hi-tn result))
+	  (value-lo (double-double-reg-lo-tn value))
+	  (result-lo (double-double-reg-lo-tn result))
+	  (offset (+ (* index 16)
+		     (- (* vm:vector-data-offset vm:word-bytes)
+			  vm:other-pointer-type))))
+      ;; There's a possible optimization here if the offset for the
+      ;; real part fits in a signed-byte 13 but the imag part doesn't.
+      ;; We don't do this because it can't happen with the current
+      ;; values of vm:other-pointer-type and vm:vector-data-offset.
+      (cond ((typep (+ offset 8) '(signed-byte 13))
+	     (inst stdf value-hi object offset)
+	     (inst stdf value-lo object (+ offset 8)))
+	    (t
+	     (inst li temp offset)
+	     (inst stdf value-hi object temp)
+	     (inst add temp 8)
+	     (inst stdf value-lo object temp)))
+      (unless (location= result-hi value-hi)
+	(move-double-reg result-hi value-hi))
+      (unless (location= result-lo value-lo)
+	(move-double-reg result-lo value-lo)))))
+
+(define-vop (data-vector-ref/simple-array-complex-double-double-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (index :scs (any-reg)))
+  (:arg-types simple-array-complex-double-double-float positive-fixnum)
+  (:results (value :scs (complex-double-double-reg)))
+  (:result-types complex-double-double-float)
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
+  (:generator 7
+    (let ((real-tn (complex-double-double-reg-real-hi-tn value)))
+      (inst slln offset index 3)
+      (inst add offset (- (* vm:vector-data-offset vm:word-bytes)
+			  vm:other-pointer-type))
+      (inst lddf real-tn object offset))
+    (let ((real-tn (complex-double-double-reg-real-lo-tn value)))
+      (inst add offset (* 2 vm:word-bytes))
+      (inst lddf real-tn object offset))
+    (let ((imag-tn (complex-double-double-reg-imag-hi-tn value)))
+      (inst add offset (* 2 vm:word-bytes))
+      (inst lddf imag-tn object offset))
+    (let ((imag-tn (complex-double-double-reg-imag-lo-tn value)))
+      (inst add offset (* 2 vm:word-bytes))
+      (inst lddf imag-tn object offset))))
+
+(define-vop (data-vector-ref-c/simple-array-complex-double-double-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result))
+  (:arg-types simple-array-complex-double-double-float (:constant index))
+  (:info index)
+  (:results (value :scs (complex-double-double-reg)))
+  (:result-types complex-double-double-float)
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp)
+  (:generator 5
+    (let ((offset (+ (* index 16)
+		     (- (* vm:vector-data-offset vm:word-bytes)
+			  vm:other-pointer-type)))
+	  (real-hi-tn (complex-double-double-reg-real-hi-tn value))
+	  (imag-hi-tn (complex-double-double-reg-imag-hi-tn value))
+	  (real-lo-tn (complex-double-double-reg-real-lo-tn value))
+	  (imag-lo-tn (complex-double-double-reg-imag-lo-tn value)))
+      (cond ((typep (+ offset (* 6 vm:word-bytes)) '(signed-byte 13))
+	     (inst lddf real-hi-tn object offset)
+	     (inst lddf real-lo-tn object (+ offset (* 2 vm:word-bytes)))
+	     (inst lddf imag-hi-tn object (+ offset (* 4 vm:word-bytes)))
+	     (inst lddf imag-lo-tn object (+ offset (* 6 vm:word-bytes))))
+	    (t
+	     (inst li temp offset)
+	     (inst lddf real-hi-tn object temp)
+	     (inst add temp (* 2 vm:word-bytes))
+	     (inst lddf real-lo-tn object temp)
+	     (inst add temp (* 2 vm:word-bytes))
+	     (inst lddf imag-hi-tn object temp)
+	     (inst add temp (* 2 vm:word-bytes))
+	     (inst lddf imag-lo-tn object temp))))))
+
+(define-vop (data-vector-set/simple-array-complex-double-double-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (index :scs (any-reg))
+	 (value :scs (complex-double-double-reg) :target result))
+  (:arg-types simple-array-complex-double-double-float positive-fixnum
+	      complex-double-double-float)
+  (:results (result :scs (complex-double-double-reg)))
+  (:result-types complex-double-double-float)
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
+  (:generator 20
+    (let ((value-real (complex-double-double-reg-real-hi-tn value))
+	  (result-real (complex-double-double-reg-real-hi-tn result)))
+      (inst slln offset index 3)
+      (inst add offset (- (* vm:vector-data-offset vm:word-bytes)
+			  vm:other-pointer-type))
+      (inst stdf value-real object offset)
+      (unless (location= result-real value-real)
+	(move-double-reg result-real value-real)))
+    (let ((value-real (complex-double-double-reg-real-lo-tn value))
+	  (result-real (complex-double-double-reg-real-lo-tn result)))
+      (inst add offset (* 2 vm:word-bytes))
+      (inst stdf value-real object offset)
+      (unless (location= result-real value-real)
+	(move-double-reg result-real value-real)))
+    (let ((value-imag (complex-double-double-reg-imag-hi-tn value))
+	  (result-imag (complex-double-double-reg-imag-hi-tn result)))
+      (inst add offset (* 2 vm:word-bytes))
+      (inst stdf value-imag object offset)
+      (unless (location= result-imag value-imag)
+	(move-double-reg result-imag value-imag)))
+    (let ((value-imag (complex-double-double-reg-imag-lo-tn value))
+	  (result-imag (complex-double-double-reg-imag-lo-tn result)))
+      (inst add offset (* 2 vm:word-bytes))
+      (inst stdf value-imag object offset)
+      (unless (location= result-imag value-imag)
+	(move-double-reg result-imag value-imag)))))
+
+(define-vop (data-vector-set-c/simple-array-complex-double-double-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (value :scs (complex-double-double-reg) :target result))
+  (:arg-types simple-array-complex-double-double-float
+	      (:constant index)
+	      complex-double-double-float)
+  (:info index)
+  (:results (result :scs (complex-double-double-reg)))
+  (:result-types complex-double-double-float)
+  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp)
+  (:generator 15
+    (let ((value-real (complex-double-double-reg-real-hi-tn value))
+	  (result-real (complex-double-double-reg-real-hi-tn result))
+	  (value-imag (complex-double-double-reg-imag-hi-tn value))
+	  (result-imag (complex-double-double-reg-imag-hi-tn result))
+	  (offset (+ (* index 16)
+		     (- (* vm:vector-data-offset vm:word-bytes)
+			  vm:other-pointer-type))))
+      ;; There's a possible optimization here if the offset for the
+      ;; real part fits in a signed-byte 13 but the imag part doesn't.
+      ;; We don't do this because it can't happen with the current
+      ;; values of vm:other-pointer-type and vm:vector-data-offset.
+      (cond ((typep (+ offset 8) '(signed-byte 13))
+	     (inst stdf value-real object offset)
+	     (inst stdf value-imag object (+ offset 8)))
+	    (t
+	     (inst li temp offset)
+	     (inst stdf value-real object temp)
+	     (inst add temp 8)
+	     (inst stdf value-imag object temp)))
+      (unless (location= result-real value-real)
+	(move-double-reg result-real value-real))
+      (unless (location= result-imag value-imag)
+	(move-double-reg result-imag value-imag)))
+    (let ((value-real (complex-double-double-reg-real-lo-tn value))
+	  (result-real (complex-double-double-reg-real-lo-tn result))
+	  (value-imag (complex-double-double-reg-imag-lo-tn value))
+	  (result-imag (complex-double-double-reg-imag-lo-tn result))
+	  (offset (+ (* index 16)
+		     (- (* vm:vector-data-offset vm:word-bytes)
+			  vm:other-pointer-type))))
+      ;; There's a possible optimization here if the offset for the
+      ;; real part fits in a signed-byte 13 but the imag part doesn't.
+      ;; We don't do this because it can't happen with the current
+      ;; values of vm:other-pointer-type and vm:vector-data-offset.
+      (cond ((typep (+ offset (* 6 vm:word-bytes)) '(signed-byte 13))
+	     (inst stdf value-real object (+ offset (* 4 vm:word-bytes)))
+	     (inst stdf value-imag object (+ offset (* 6 vm:word-bytes))))
+	    (t
+	     (inst add temp 8)
+	     (inst stdf value-real object temp)
+	     (inst add temp 8)
+	     (inst stdf value-imag object temp)))
+      (unless (location= result-real value-real)
+	(move-double-reg result-real value-real))
+      (unless (location= result-imag value-imag)
+	(move-double-reg result-imag value-imag)))))
+
+
+)
diff --git a/compiler/sparc/float.lisp b/compiler/sparc/float.lisp
index 7b336a01f3d4e2bf426d889691a9f9a362389d87..e8fa21a7212fc1b12fbbf0311ef50d8eb9203407 100644
--- a/compiler/sparc/float.lisp
+++ b/compiler/sparc/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/compiler/sparc/float.lisp,v 1.44 2004/03/29 18:47:03 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/float.lisp,v 1.45 2006/06/30 18:41:32 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -106,7 +106,8 @@
 ;;; on the :sparc-v9 feature.
 (defun move-double-reg (dst src)
   (cond ((backend-featurep :sparc-v9)
-	 (inst fmovd dst src))
+	 (unless (location= dst src)
+	   (inst fmovd dst src)))
 	(t
 	 (dotimes (i 2)
 	   (let ((dst (make-random-tn :kind :normal
@@ -284,6 +285,21 @@
   (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg *backend*)
 		  :offset (+ (tn-offset x) 4)))
 
+#+double-double
+(progn
+(defun complex-double-double-reg-real-hi-tn (x)
+  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
+		  :offset (tn-offset x)))
+(defun complex-double-double-reg-real-lo-tn (x)
+  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
+		  :offset (+ 2 (tn-offset x))))
+(defun complex-double-double-reg-imag-hi-tn (x)
+  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
+		  :offset (+ 4 (tn-offset x))))
+(defun complex-double-double-reg-imag-lo-tn (x)
+  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
+		  :offset (+ 6 (tn-offset x))))
+)
 
 (define-move-function (load-complex-single 2) (vop x y)
   ((complex-single-stack) (complex-single-reg))
@@ -343,6 +359,36 @@
     (let ((imag-tn (complex-long-reg-imag-tn x)))
       (store-long-reg imag-tn nfp (+ offset (* 4 vm:word-bytes))))))
 
+#+double-double
+(progn
+(define-move-function (load-complex-double-double 4) (vop x y)
+  ((complex-double-double-stack) (complex-double-double-reg))
+  (let ((nfp (current-nfp-tn vop))
+	(offset (* (tn-offset x) vm:word-bytes)))
+    (let ((value-tn (complex-double-double-reg-real-hi-tn y)))
+      (inst lddf value-tn nfp offset))
+    (let ((value-tn (complex-double-double-reg-real-lo-tn y)))
+      (inst lddf value-tn nfp (+ offset (* 2 vm:word-bytes))))
+    (let ((value-tn (complex-double-double-reg-imag-hi-tn y)))
+      (inst lddf value-tn nfp (+ offset (* 4 vm:word-bytes))))
+    (let ((value-tn (complex-double-double-reg-imag-lo-tn y)))
+      (inst lddf value-tn nfp (+ offset (* 6 vm:word-bytes))))))
+
+(define-move-function (store-complex-double-double 4) (vop x y)
+  ((complex-double-double-reg) (complex-double-double-stack))
+  (let ((nfp (current-nfp-tn vop))
+	(offset (* (tn-offset y) vm:word-bytes)))
+    (let ((value-tn (complex-double-double-reg-real-hi-tn x)))
+      (inst stdf value-tn nfp offset))
+    (let ((value-tn (complex-double-double-reg-real-lo-tn x)))
+      (inst stdf value-tn nfp (+ offset (* 2 vm:word-bytes))))
+    (let ((value-tn (complex-double-double-reg-imag-hi-tn x)))
+      (inst stdf value-tn nfp (+ offset (* 4 vm:word-bytes))))
+    (let ((value-tn (complex-double-double-reg-imag-lo-tn x)))
+      (inst stdf value-tn nfp (+ offset (* 6 vm:word-bytes))))))
+
+)
+
 ;;;
 ;;; Complex float register to register moves.
 ;;;
@@ -405,6 +451,33 @@
 (define-move-vop complex-long-move :move
   (complex-long-reg) (complex-long-reg))
 
+#+double-double
+(define-vop (complex-double-double-move)
+  (:args (x :scs (complex-double-double-reg)
+	    :target y :load-if (not (location= x y))))
+  (:results (y :scs (complex-double-double-reg) :load-if (not (location= x y))))
+  (:note "complex double-double float move")
+  (:generator 0
+     (unless (location= x y)
+       ;; Note the complex-float-regs are aligned to every second
+       ;; float register so there is not need to worry about overlap.
+       (let ((x-real (complex-double-double-reg-real-hi-tn x))
+	     (y-real (complex-double-double-reg-real-hi-tn y)))
+	 (move-double-reg y-real x-real))
+       (let ((x-real (complex-double-double-reg-real-lo-tn x))
+	     (y-real (complex-double-double-reg-real-lo-tn y)))
+	 (move-double-reg y-real x-real))
+       (let ((x-real (complex-double-double-reg-imag-hi-tn x))
+	     (y-real (complex-double-double-reg-imag-hi-tn y)))
+	 (move-double-reg y-real x-real))
+       (let ((x-imag (complex-double-double-reg-imag-lo-tn x))
+	     (y-imag (complex-double-double-reg-imag-lo-tn y)))
+	 (move-double-reg y-imag x-imag)))))
+;;;
+#+double-double
+(define-move-vop complex-double-double-move :move
+  (complex-double-double-reg) (complex-double-double-reg))
+
 ;;;
 ;;; Move from a complex float to a descriptor register allocating a
 ;;; new complex float object in the process.
@@ -471,6 +544,36 @@
 (define-move-vop move-from-complex-long :move
   (complex-long-reg) (descriptor-reg))
 
+#+double-double
+(define-vop (move-from-complex-double-double)
+  (:args (x :scs (complex-double-double-reg) :to :save))
+  (:results (y :scs (descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg)) ndescr)
+  (:note "complex double-double float to pointer coercion")
+  (:generator 13
+     (with-fixed-allocation (y ndescr vm::complex-double-double-float-type
+			       vm::complex-double-double-float-size))
+     (let ((real-tn (complex-double-double-reg-real-hi-tn x)))
+       (inst stdf real-tn y (- (* vm::complex-double-double-float-real-hi-slot
+				  vm:word-bytes)
+			       vm:other-pointer-type)))
+     (let ((real-tn (complex-double-double-reg-real-lo-tn x)))
+       (inst stdf real-tn y (- (* vm::complex-double-double-float-real-lo-slot
+				  vm:word-bytes)
+			       vm:other-pointer-type)))
+     (let ((imag-tn (complex-double-double-reg-imag-hi-tn x)))
+       (inst stdf imag-tn y (- (* vm::complex-double-double-float-imag-hi-slot
+				  vm:word-bytes)
+			       vm:other-pointer-type)))
+     (let ((imag-tn (complex-double-double-reg-imag-lo-tn x)))
+       (inst stdf imag-tn y (- (* vm::complex-double-double-float-imag-lo-slot
+				  vm:word-bytes)
+			       vm:other-pointer-type)))))
+;;;
+#+double-double
+(define-move-vop move-from-complex-double-double :move
+  (complex-double-double-reg) (descriptor-reg))
+
 ;;;
 ;;; Move from a descriptor to a complex float register
 ;;;
@@ -518,6 +621,28 @@
 (define-move-vop move-to-complex-long :move
   (descriptor-reg) (complex-long-reg))
 
+#+double-double
+(define-vop (move-to-complex-double-double)
+  (:args (x :scs (descriptor-reg)))
+  (:results (y :scs (complex-double-double-reg)))
+  (:note "pointer to complex double-double float coercion")
+  (:generator 2
+    (let ((real-tn (complex-double-double-reg-real-hi-tn y)))
+      (inst lddf real-tn x (- (* complex-double-double-float-real-hi-slot word-bytes)
+			      other-pointer-type)))
+    (let ((real-tn (complex-double-double-reg-real-lo-tn y)))
+      (inst lddf real-tn x (- (* complex-double-double-float-real-lo-slot word-bytes)
+			      other-pointer-type)))
+    (let ((imag-tn (complex-double-double-reg-imag-hi-tn y)))
+      (inst lddf imag-tn x (- (* complex-double-double-float-imag-hi-slot word-bytes)
+			      other-pointer-type)))
+    (let ((imag-tn (complex-double-double-reg-imag-lo-tn y)))
+      (inst lddf imag-tn x (- (* complex-double-double-float-imag-lo-slot word-bytes)
+			      other-pointer-type)))))
+#+double-double
+(define-move-vop move-to-complex-double-double :move
+  (descriptor-reg) (complex-double-double-reg))
+
 ;;;
 ;;; Complex float move-argument vop
 ;;;
@@ -591,14 +716,48 @@
 	   (store-long-reg real-tn nfp offset))
 	 (let ((imag-tn (complex-long-reg-imag-tn x)))
 	   (store-long-reg imag-tn nfp (+ offset (* 4 word-bytes)))))))))
+
+#+double-double
+(define-vop (move-complex-double-double-float-argument)
+  (:args (x :scs (complex-double-double-reg) :target y)
+	 (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-double-reg))))
+  (:results (y))
+  (:note "complex double-double float argument move")
+  (:generator 2
+    (sc-case y
+      (complex-double-double-reg
+       (unless (location= x y)
+	 (let ((x-real (complex-double-double-reg-real-hi-tn x))
+	       (y-real (complex-double-double-reg-real-hi-tn y)))
+	   (move-double-reg y-real x-real))
+	 (let ((x-real (complex-double-double-reg-real-lo-tn x))
+	       (y-real (complex-double-double-reg-real-lo-tn y)))
+	   (move-double-reg y-real x-real))
+	 (let ((x-imag (complex-double-double-reg-imag-hi-tn x))
+	       (y-imag (complex-double-double-reg-imag-hi-tn y)))
+	   (move-long-reg y-imag x-imag))
+	 (let ((x-imag (complex-double-double-reg-imag-lo-tn x))
+	       (y-imag (complex-double-double-reg-imag-lo-tn y)))
+	   (move-long-reg y-imag x-imag))))
+      (complex-double-double-stack
+       (let ((offset (* (tn-offset y) word-bytes)))
+	 (let ((real-tn (complex-double-double-reg-real-hi-tn x)))
+	   (store-long-reg real-tn nfp offset))
+	 (let ((real-tn (complex-double-double-reg-real-lo-tn x)))
+	   (store-long-reg real-tn nfp (+ offset (* 2 word-bytes))))
+	 (let ((imag-tn (complex-double-double-reg-imag-hi-tn x)))
+	   (store-long-reg imag-tn nfp (+ offset (* 4 word-bytes))))
+	 (let ((imag-tn (complex-double-double-reg-imag-lo-tn x)))
+	   (store-long-reg imag-tn nfp (+ offset (* 6 word-bytes)))))))))
 #+long-float
 (define-move-vop move-complex-long-float-argument :move-argument
   (complex-long-reg descriptor-reg) (complex-long-reg))
 
 
 (define-move-vop move-argument :move-argument
-  (single-reg double-reg #+long-float long-reg
-   complex-single-reg complex-double-reg #+long-float complex-long-reg)
+  (single-reg double-reg #+long-float long-reg #+double-double double-double-reg
+   complex-single-reg complex-double-reg #+long-float complex-long-reg
+   #+double-double complex-double-double-reg)
   (descriptor-reg))
 
 
@@ -840,6 +999,11 @@
 	(= (long-float-high-bits x) (long-float-high-bits y))
 	(= (long-float-exp-bits x) (long-float-exp-bits y))))
 
+#+double-double
+(deftransform eql ((x y) (double-double-float double-double-float))
+  '(and (eql (double-double-hi x) (double-double-hi y))
+	(eql (double-double-lo x) (double-double-lo y))))
+
 
 ;;;; Conversion:
 
@@ -2755,3 +2919,271 @@
     (let ((fs1 (and fop rs1 (sigcontext-float-register scp rs1 format)))
 	  (fs2 (and fop rs2 (sigcontext-float-register scp rs2 format))))
       (values fop (remove nil (list fs1 fs2))))))
+
+;;; Support for double-double floats
+
+#+double-double
+(progn
+(defun double-double-reg-hi-tn (x)
+  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
+		  :offset (tn-offset x)))
+
+(defun double-double-reg-lo-tn (x)
+  ;; The low tn is 2 more than the offset because double regs are
+  ;; even.
+  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
+		  :offset (+ 2 (tn-offset x))))
+
+(define-move-function (load-double-double 4) (vop x y)
+  ((double-double-stack) (double-double-reg))
+  (let ((nfp (current-nfp-tn vop))
+	(offset (* (tn-offset x) vm:word-bytes)))
+    (let ((hi-tn (double-double-reg-hi-tn y)))
+      (inst lddf hi-tn nfp offset))
+    (let ((lo-tn (double-double-reg-lo-tn y)))
+      (inst lddf lo-tn nfp (+ offset (* 2 vm:word-bytes))))))
+
+(define-move-function (store-double-double 4) (vop x y)
+  ((double-double-reg) (double-double-stack))
+  (let ((nfp (current-nfp-tn vop))
+	(offset (* (tn-offset y) vm:word-bytes)))
+    (let ((hi-tn (double-double-reg-hi-tn x)))
+      (inst stdf hi-tn nfp offset))
+    (let ((lo-tn (double-double-reg-lo-tn x)))
+      (inst stdf lo-tn nfp (+ offset (* 2 vm:word-bytes))))))
+
+;;; Double-double float register to register moves
+
+(define-vop (double-double-move)
+  (:args (x :scs (double-double-reg)
+	    :target y :load-if (not (location= x y))))
+  (:results (y :scs (double-double-reg) :load-if (not (location= x y))))
+  (:note "double-double float move")
+  (:generator 0
+     (unless (location= x y)
+       ;; Note the double-float-regs are aligned to every second
+       ;; float register so there is not need to worry about overlap.
+       (let ((x-hi (double-double-reg-hi-tn x))
+	     (y-hi (double-double-reg-hi-tn y)))
+	 (move-double-reg y-hi x-hi))
+       (let ((x-lo (double-double-reg-lo-tn x))
+	     (y-lo (double-double-reg-lo-tn y)))
+	 (move-double-reg y-lo x-lo)))))
+;;;
+(define-move-vop double-double-move :move
+  (double-double-reg) (double-double-reg))
+
+;;; Move from a complex float to a descriptor register allocating a
+;;; new complex float object in the process.
+
+(define-vop (move-from-double-double)
+  (:args (x :scs (double-double-reg) :to :save))
+  (:results (y :scs (descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg)) ndescr)
+  (:note "double-double float to pointer coercion")
+  (:generator 13
+     (with-fixed-allocation (y ndescr vm::double-double-float-type
+			       vm::double-double-float-size))
+     (let ((hi-tn (double-double-reg-hi-tn x)))
+       (inst stdf hi-tn y (- (* vm::double-double-float-hi-slot
+				  vm:word-bytes)
+			       vm:other-pointer-type)))
+     (let ((lo-tn (double-double-reg-lo-tn x)))
+       (inst stdf lo-tn y (- (* vm::double-double-float-lo-slot
+				  vm:word-bytes)
+			       vm:other-pointer-type)))))
+;;;
+(define-move-vop move-from-double-double :move
+  (double-double-reg) (descriptor-reg))
+
+;;; Move from a descriptor to a double-double float register
+
+(define-vop (move-to-double-double)
+  (:args (x :scs (descriptor-reg)))
+  (:results (y :scs (double-double-reg)))
+  (:note "pointer to double-double float coercion")
+  (:generator 2
+    (let ((hi-tn (double-double-reg-hi-tn y)))
+      (inst lddf hi-tn x (- (* double-double-float-hi-slot word-bytes)
+			     other-pointer-type)))
+    (let ((lo-tn (double-double-reg-lo-tn y)))
+      (inst lddf lo-tn x (- (* double-double-float-lo-slot word-bytes)
+			   other-pointer-type)))))
+
+(define-move-vop move-to-double-double :move
+  (descriptor-reg) (double-double-reg))
+
+;;; double-double float move-argument vop
+
+(define-vop (move-double-double-float-argument)
+  (:args (x :scs (double-double-reg) :target y)
+	 (nfp :scs (any-reg) :load-if (not (sc-is y double-double-reg))))
+  (:results (y))
+  (:note "double-double float argument move")
+  (:generator 2
+    (sc-case y
+      (double-double-reg
+       (unless (location= x y)
+	 (let ((x-hi (double-double-reg-hi-tn x))
+	       (y-hi (double-double-reg-hi-tn y)))
+	   (move-double-reg y-hi x-hi))
+	 (let ((x-lo (double-double-reg-lo-tn x))
+	       (y-lo (double-double-reg-lo-tn y)))
+	   (move-double-reg y-lo x-lo))))
+      (double-double-stack
+       (let ((offset (* (tn-offset y) word-bytes)))
+	 (let ((hi-tn (double-double-reg-hi-tn x)))
+	   (inst stdf hi-tn nfp offset))
+	 (let ((lo-tn (double-double-reg-lo-tn x)))
+	   (inst stdf lo-tn nfp (+ offset (* 2 word-bytes)))))))))
+
+(define-move-vop move-double-double-float-argument :move-argument
+  (double-double-reg descriptor-reg) (double-double-reg))
+
+
+(define-vop (make/double-double-float)
+  (:args (hi :scs (double-reg) :target res
+	     :load-if (not (location= hi res)))
+	 (lo :scs (double-reg)))
+  (:results (res :scs (double-double-reg) :from (:argument 0)
+		 :load-if (not (sc-is res double-double-stack))))
+  (:arg-types double-float double-float)
+  (:result-types double-double-float)
+  (:translate kernel::%make-double-double-float)
+  (:note "inline double-double float creation")
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 5
+    (sc-case res
+      (double-double-reg
+       (let ((res-hi (double-double-reg-hi-tn res)))
+	 (unless (location= res-hi hi)
+	   (move-double-reg res-hi hi)))
+       (let ((res-lo (double-double-reg-lo-tn res)))
+	 (unless (location= res-lo lo)
+	   (move-double-reg res-lo lo))))
+      (double-double-stack
+       (let ((nfp (current-nfp-tn vop))
+	     (offset (* (tn-offset res) vm:word-bytes)))
+	 (unless (location= hi res)
+	   (inst stdf hi nfp offset))
+	 (inst stdf lo nfp (+ offset (* 2 vm:word-bytes))))))))
+
+(define-vop (double-double-float-value)
+  (:args (x :scs (double-double-reg) :target r
+	    :load-if (not (sc-is x double-double-stack))))
+  (:arg-types double-double-float)
+  (:results (r :scs (double-reg)))
+  (:result-types double-float)
+  (:variant-vars slot)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 3
+    (sc-case x
+      (double-double-reg
+       (let ((value-tn (ecase slot
+			 (:hi (double-double-reg-hi-tn x))
+			 (:lo (double-double-reg-lo-tn x)))))
+	 (unless (location= value-tn r)
+	   (move-double-reg r value-tn))))
+      (double-double-stack
+       (inst lddf r (current-nfp-tn vop) (* (+ (ecase slot (:hi 0) (:lo 2))
+					       (tn-offset x))
+					    vm:word-bytes))))))
+
+(define-vop (hi/double-double-value double-double-float-value)
+  (:translate kernel::double-double-hi)
+  (:note "double-double high part")
+  (:variant :hi))
+
+(define-vop (lo/double-double-value double-double-float-value)
+  (:translate kernel::double-double-lo)
+  (:note "double-double low part")
+  (:variant :lo))
+
+
+(define-vop (make-complex-double-double-float)
+  (:translate complex)
+  (:args (real :scs (double-double-reg) :target r
+	       :load-if (not (location= real r)))
+	 (imag :scs (double-double-reg) :to :save))
+  (:arg-types double-double-float double-double-float)
+  (:results (r :scs (complex-double-double-reg) :from (:argument 0)
+	       :load-if (not (sc-is r complex-double-double-stack))))
+  (:result-types complex-double-double-float)
+  (:note "inline complex double-double float creation")
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 5
+    (sc-case r
+      (complex-double-double-reg
+       (let ((r-real (complex-double-double-reg-real-hi-tn r))
+	     (real-hi (double-double-reg-hi-tn real)))
+	 (move-double-reg r-real real-hi))
+       (let ((r-real (complex-double-double-reg-real-lo-tn r))
+	     (real-lo (double-double-reg-lo-tn real)))
+	 (move-double-reg r-real real-lo))
+       (let ((r-imag (complex-double-double-reg-imag-hi-tn r))
+	     (imag-hi (double-double-reg-hi-tn imag)))
+	 (move-double-reg r-imag imag-hi))
+       (let ((r-imag (complex-double-double-reg-imag-lo-tn r))
+	     (imag-lo (double-double-reg-lo-tn imag)))
+	 (move-double-reg r-imag imag-lo)))
+      (complex-double-double-stack
+       (let ((nfp (current-nfp-tn vop))
+	     (offset (* (tn-offset r) vm:word-bytes)))
+	 (let ((r-real (complex-double-double-reg-real-hi-tn r)))
+	   (inst stdf r-real nfp offset))
+	 (let ((r-real (complex-double-double-reg-real-lo-tn r)))
+	   (inst stdf r-real nfp (+ offset (* 2 vm:word-bytes))))
+	 (let ((r-imag (complex-double-double-reg-imag-hi-tn r)))
+	   (inst stdf r-imag nfp (+ offset (* 4 vm:word-bytes))))
+	 (let ((r-imag (complex-double-double-reg-imag-lo-tn r)))
+	   (inst stdf r-imag nfp (+ offset (* 6 vm:word-bytes)))))))))
+
+(define-vop (complex-double-double-float-value)
+  (:args (x :scs (complex-double-double-reg) :target r
+	    :load-if (not (sc-is x complex-double-double-stack))))
+  (:arg-types complex-double-double-float)
+  (:results (r :scs (double-double-reg)))
+  (:result-types double-double-float)
+  (:variant-vars slot)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 3
+    (sc-case x
+      (complex-double-double-reg
+       (let ((value-tn (ecase slot
+			 (:real (complex-double-double-reg-real-hi-tn x))
+			 (:imag (complex-double-double-reg-imag-hi-tn x))))
+	     (r-hi (double-double-reg-hi-tn r)))
+	 (unless (location= value-tn r-hi)
+	   (move-double-reg r-hi value-tn)))
+       (let ((value-tn (ecase slot
+			 (:real (complex-double-double-reg-real-lo-tn x))
+			 (:imag (complex-double-double-reg-imag-lo-tn x))))
+	     (r-lo (double-double-reg-lo-tn r)))
+	 (unless (location= value-tn r-lo)
+	   (move-double-reg r-lo value-tn))))
+      (complex-double-double-stack
+       (let ((r-hi (double-double-reg-hi-tn r)))
+	 (inst lddf r-hi (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 4))
+						    (tn-offset x))
+						 vm:word-bytes)))
+       (let ((r-lo (double-double-reg-lo-tn r)))
+	 (inst lddf r-lo (current-nfp-tn vop) (* (+ (ecase slot (:real 2) (:imag 6))
+						    (tn-offset x))
+						 vm:word-bytes)))))))
+
+(define-vop (realpart/complex-double-double-float complex-double-double-float-value)
+  (:translate realpart)
+  (:note "complex double-double float realpart")
+  (:variant :real))
+
+(define-vop (imagpart/complex-double-double-float complex-double-double-float-value)
+  (:translate imagpart)
+  (:note "complex double-double float imagpart")
+  (:variant :imag))
+
+); progn
+
diff --git a/compiler/sparc/insts.lisp b/compiler/sparc/insts.lisp
index c24754392c066ed56f337d1d792b890858a59ca8..46e4f82bd645cccbc94de9533c5c57f9aa9de433 100644
--- a/compiler/sparc/insts.lisp
+++ b/compiler/sparc/insts.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/sparc/insts.lisp,v 1.52 2005/03/17 22:12:57 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/insts.lisp,v 1.53 2006/06/30 18:41:32 rtoy Rel $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -158,10 +158,12 @@ about function addresses and register values.")
 	single-float
 	double-float
 	#+long-float long-float
+	#+double-double double-double-float
 	complex
 	complex-single-float
 	complex-double-float
 	#+long-float complex-long-float
+	#+double-double complex-double-double-float
   
 	simple-array
 	simple-string
@@ -179,9 +181,11 @@ about function addresses and register values.")
 	simple-array-single-float
 	simple-array-double-float
 	#+long-float simple-array-long-float
+	#+double-double simple-array-double-double-float
 	simple-array-complex-single-float
 	simple-array-complex-double-float
 	#+long-float simple-array-complex-long-float
+	#+double-double simple-array-complex-double-double-float
 	complex-string
 	complex-bit-vector
 	complex-vector
@@ -193,7 +197,7 @@ about function addresses and register values.")
 	funcallable-instance-header
 	byte-code-function
 	byte-code-closure
-	dylan-function-header
+	#-double-double dylan-function-header
 	closure-function-header
 	#-gengc return-pc-header
 	#+gengc forwarding-pointer
diff --git a/compiler/sparc/macros.lisp b/compiler/sparc/macros.lisp
index 98f1d0e9dd4cbddaa729e633c1157e8b40913912..e3d8a9b50e37d1e82ee2afd1ad2b4984f3934560 100644
--- a/compiler/sparc/macros.lisp
+++ b/compiler/sparc/macros.lisp
@@ -5,11 +5,11 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/macros.lisp,v 1.33 2004/08/12 21:21:00 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/macros.lisp,v 1.34 2006/06/30 18:41:32 rtoy Rel $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/macros.lisp,v 1.33 2004/08/12 21:21:00 rtoy Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/macros.lisp,v 1.34 2006/06/30 18:41:32 rtoy Rel $
 ;;;
 ;;; This file contains various useful macros for generating SPARC code.
 ;;;
@@ -454,7 +454,8 @@
   (list base-char-type unbound-marker-type))
 
 (defconstant function-subtypes
-  (list funcallable-instance-header-type dylan-function-header-type
+  (list funcallable-instance-header-type
+	#-double-double dylan-function-header-type
 	function-header-type closure-function-header-type
 	closure-header-type))
 
diff --git a/compiler/sparc/parms.lisp b/compiler/sparc/parms.lisp
index d41e56b4320826c40833e127995c99cb2b177077..3fcff8c38a0b444733fd5db5108db18075b0614f 100644
--- a/compiler/sparc/parms.lisp
+++ b/compiler/sparc/parms.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/sparc/parms.lisp,v 1.50 2004/01/09 04:52:19 toy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/parms.lisp,v 1.51 2006/06/30 18:41:32 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -77,6 +77,8 @@
 	  float-imprecise-trap-bit float-invalid-trap-bit
 	  float-divide-by-zero-trap-bit))
 
+#+double-double
+(export '(double-double-float-digits))
 	  
 
 (eval-when (compile load eval)
@@ -149,6 +151,10 @@
 (defconstant long-float-digits
   (+ (byte-size long-float-significand-byte) word-bits 1))
 
+#+double-double
+(defconstant double-double-float-digits
+  (* 2 double-float-digits))
+
 (defconstant float-inexact-trap-bit (ash 1 0))
 (defconstant float-divide-by-zero-trap-bit (ash 1 1))
 (defconstant float-underflow-trap-bit (ash 1 2))
diff --git a/compiler/sparc/type-vops.lisp b/compiler/sparc/type-vops.lisp
index bdcf3ff96a08bdcd17694c03d4b8e6d545a58c41..506313919178f22229caacddfebd163d0bc8db66 100644
--- a/compiler/sparc/type-vops.lisp
+++ b/compiler/sparc/type-vops.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/sparc/type-vops.lisp,v 1.24 2005/02/07 23:23:34 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/type-vops.lisp,v 1.25 2006/06/30 18:41:32 rtoy Rel $")
 ;;;
 ;;; **********************************************************************
 ;;; 
@@ -84,7 +84,8 @@
 
 (def-type-vops complexp check-complex complex object-not-complex-error
   vm:complex-type vm:complex-single-float-type
-  vm:complex-double-float-type #+long-float vm:complex-long-float-type)
+  vm:complex-double-float-type #+long-float vm:complex-long-float-type
+  #+double-double vm::complex-double-double-float-type)
 
 (def-type-vops complex-rational-p check-complex-rational nil
   object-not-complex-rational-error vm:complex-type)
@@ -92,7 +93,8 @@
 (def-type-vops complex-float-p check-complex-float nil
   object-not-complex-float-error
   vm:complex-single-float-type vm:complex-double-float-type
-  #+long-float vm:complex-long-float-type)
+  #+long-float vm:complex-long-float-type
+  #+double-double vm::complex-double-double-float-type)
 
 (def-type-vops complex-single-float-p check-complex-single-float
   complex-single-float object-not-complex-single-float-error
@@ -107,6 +109,11 @@
   complex-long-float object-not-complex-long-float-error
   vm:complex-long-float-type)
 
+#+double-double
+(def-type-vops complex-double-double-float-p check-complex-double-double-float
+  complex-double-double-float object-not-complex-double-double-float-error
+  vm::complex-double-double-float-type)
+
 (def-type-vops single-float-p check-single-float single-float
   object-not-single-float-error vm:single-float-type)
 
@@ -117,6 +124,11 @@
 (def-type-vops long-float-p check-long-float long-float
   object-not-long-float-error vm:long-float-type)
 
+#+double-double
+(def-type-vops double-double-float-p check-double-double-float
+  double-double-float object-not-double-double-float-error
+  vm:double-double-float-type)
+	       
 (def-type-vops simple-string-p check-simple-string simple-string
   object-not-simple-string-error vm:simple-string-type)
 
@@ -193,6 +205,11 @@
   simple-array-long-float object-not-simple-array-long-float-error
   vm:simple-array-long-float-type)
 
+#+double-double
+(def-type-vops simple-array-double-double-float-p check-simple-array-double-double-float
+  simple-array-double-double-float object-not-simple-array-double-double-float-error
+  vm::simple-array-double-double-float-type)
+
 (def-type-vops simple-array-complex-single-float-p
   check-simple-array-complex-single-float
   simple-array-complex-single-float
@@ -212,6 +229,13 @@
   object-not-simple-array-complex-long-float-error
   vm:simple-array-complex-long-float-type)
 
+#+double-double
+(def-type-vops simple-array-complex-double-double-float-p
+  check-simple-array-complex-double-double-float
+  simple-array-complex-double-double-float
+  object-not-simple-array-complex-double-double-float-error
+  vm::simple-array-complex-double-double-float-type)
+
 (def-type-vops base-char-p check-base-char base-char
   object-not-base-char-error vm:base-char-type)
 
@@ -258,9 +282,11 @@
   simple-array-signed-byte-30-type simple-array-signed-byte-32-type
   vm:simple-array-single-float-type vm:simple-array-double-float-type
   #+long-float vm:simple-array-long-float-type
+  #+double-double vm::simple-array-double-double-float-type
   vm:simple-array-complex-single-float-type
   vm:simple-array-complex-double-float-type
   #+long-float vm:simple-array-complex-long-float-type
+  #+double-double vm::simple-array-complex-double-double-float-type
   vm:complex-string-type vm:complex-bit-vector-type vm:complex-vector-type)
 
 (def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error
@@ -272,9 +298,12 @@
   simple-array-signed-byte-30-type simple-array-signed-byte-32-type
   vm:simple-array-single-float-type vm:simple-array-double-float-type
   #+long-float vm:simple-array-long-float-type
+  #+double-double vm::simple-array-double-double-float-type
   vm:simple-array-complex-single-float-type
   vm:simple-array-complex-double-float-type
-  #+long-float vm:simple-array-complex-long-float-type)
+  #+long-float vm:simple-array-complex-long-float-type
+  #+double-double vm::simple-array-complex-double-double-float-type
+  )
 
 (def-type-vops arrayp check-array nil object-not-array-error
   vm:simple-array-type vm:simple-string-type vm:simple-bit-vector-type
@@ -285,17 +314,21 @@
   simple-array-signed-byte-30-type simple-array-signed-byte-32-type
   vm:simple-array-single-float-type vm:simple-array-double-float-type
   #+long-float vm:simple-array-long-float-type
+  #+double-double vm::simple-array-double-double-float-type
   vm:simple-array-complex-single-float-type
   vm:simple-array-complex-double-float-type
   #+long-float vm:simple-array-complex-long-float-type
+  #+double-double vm::simple-array-complex-double-double-float-type
   vm:complex-string-type vm:complex-bit-vector-type vm:complex-vector-type
   vm:complex-array-type)
 
 (def-type-vops numberp check-number nil object-not-number-error
   vm:even-fixnum-type vm:odd-fixnum-type vm:bignum-type vm:ratio-type
   vm:single-float-type vm:double-float-type #+long-float vm:long-float-type
+  #+double-double vm:double-double-float-type
   vm:complex-type vm:complex-single-float-type vm:complex-double-float-type
-  #+long-float vm:complex-long-float-type)
+  #+long-float vm:complex-long-float-type
+  #+double-double vm::complex-double-double-float-type)
 
 (def-type-vops rationalp check-rational nil object-not-rational-error
   vm:even-fixnum-type vm:odd-fixnum-type vm:ratio-type vm:bignum-type)
@@ -304,11 +337,13 @@
   vm:even-fixnum-type vm:odd-fixnum-type vm:bignum-type)
 
 (def-type-vops floatp check-float nil object-not-float-error
-  vm:single-float-type vm:double-float-type #+long-float vm:long-float-type)
+  vm:single-float-type vm:double-float-type #+long-float vm:long-float-type
+  #+double-double vm:double-double-float-type)
 
 (def-type-vops realp check-real nil object-not-real-error
   vm:even-fixnum-type vm:odd-fixnum-type vm:ratio-type vm:bignum-type
-  vm:single-float-type vm:double-float-type #+long-float vm:long-float-type)
+  vm:single-float-type vm:double-float-type #+long-float vm:long-float-type
+  #+double-double vm:double-double-float-type)
 
 
 ;;;; Other integer ranges.
diff --git a/compiler/sparc/vm.lisp b/compiler/sparc/vm.lisp
index a25e4def4690213d2658690512f3563a7cbc725a..587f07d10f80949a20c6f528c1c0e5ef14a00f9c 100644
--- a/compiler/sparc/vm.lisp
+++ b/compiler/sparc/vm.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/sparc/vm.lisp,v 1.25 2005/02/11 14:45:28 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/vm.lisp,v 1.26 2006/06/30 18:41:32 rtoy Rel $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -183,6 +183,8 @@
 		:element-size 2 :alignment 2) ; double floats.
   #+long-float
   (long-stack non-descriptor-stack :element-size 4 :alignment 4) ; long floats.
+  #+double-double
+  (double-double-stack non-descriptor-stack :element-size 4 :alignment 2)
   ;; complex-single-floats
   (complex-single-stack non-descriptor-stack :element-size 2)
   ;; complex-double-floats.
@@ -191,6 +193,9 @@
   ;; complex-long-floats.
   (complex-long-stack non-descriptor-stack :element-size 8 :alignment 4)
 
+  #+double-double
+  (complex-double-double-stack non-descriptor-stack :element-size 8 :alignment 4)
+  
   ;; **** Things that can go in the integer registers.
 
   ;; Immediate descriptor objects.  Don't have to be seen by GC, but nothing
@@ -302,6 +307,16 @@
    :save-p t
    :alternate-scs (long-stack))
 
+  ;; Non-descriptor double-double floats
+  #+double-double
+  (double-double-reg float-registers
+   :locations #.(loop for i from 0 below #-sparc-v9 32 #+sparc-v9 64
+		   by 4 collect i)
+   :element-size 4 :alignment 4
+   :constant-scs ()
+   :save-p t
+   :alternate-scs (double-double-stack))
+  
   (complex-single-reg float-registers
    :locations #.(loop for i from 0 to 31 by 2 collect i)
    :element-size 2 :alignment 2
@@ -328,6 +343,15 @@
    :save-p t
    :alternate-scs (complex-long-stack))
 
+  #+double-double
+  (complex-double-double-reg float-registers
+   :locations #.(loop for i from 0 below #-sparc-v9 32 #+sparc-v9 64
+		      by 8 collect i)
+   :element-size 8 :alignment 8
+   :constant-scs ()
+   :save-p t
+   :alternate-scs (complex-double-double-stack))
+
 
   ;; A catch or unwind block.
   (catch-block control-stack :element-size vm:catch-block-size)
diff --git a/compiler/srctran.lisp b/compiler/srctran.lisp
index adec075b9824df74b5a664c6f8171175812bde85..e41683bdd07869d45e0b5647095458246d5791c6 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.161 2006/01/17 18:00:33 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.162 2006/06/30 18:41:23 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -405,10 +405,11 @@
 		  (zerop (bound-value lo))
 		  (= (bound-value lo) (bound-value hi)))
 	     ;; At this point lo = hi = +/- 0.0.
-	     (cond ((eql (bound-value lo) (bound-value hi))
-		    ;; Both bounds are the same kind of signed 0.  The
-		    ;; sign of the zero tells us the sign of the
-		    ;; interval.
+	     (cond ((or (eql (bound-value lo) (bound-value hi))
+			(integerp (bound-value hi)))
+		    ;; Both bounds are the same kind of signed 0.  Or
+		    ;; the high bound is an exact 0.  The sign of the
+		    ;; zero tells us the sign of the interval.
 		    (if (= (float-sign (bound-value lo)) -1)
 			'-
 			'+))
@@ -1143,6 +1144,12 @@
     (when (null (set-difference '(-0l0 0l0) members))
       (push (specifier-type '(long-float 0l0 0l0)) misc-types)
       (setf members (set-difference members '(-0l0 0l0))))
+    #+double-double-2
+    (let ((pzero (kernel:make-double-double-float 0d0 0d0))
+	  (nzero (kernel:make-double-double-float -0d0 0d0)))
+      (when (null (set-difference (list pzero nzero) members))
+	(push (specifier-type (list 'kernel:double-double-float pzero pzero)) misc-types)
+	(setf members (set-difference members (list nzero pzero)))))
     (when (null (set-difference '(-0d0 0d0) members))
       (push (specifier-type '(double-float 0d0 0d0)) misc-types)
       (setf members (set-difference members '(-0d0 0d0))))
@@ -1643,14 +1650,16 @@
 		  (values 'integer nil))
 		 (rational
 		  (values 'rational nil))
-		 ((or single-float double-float #+long-float long-float)
+		 ((or single-float double-float #+long-float long-float
+		      #+double-double double-double-float)
 		  (values 'float rem-type))
 		 (float
 		  (values 'float nil))
 		 (real
 		  (values nil nil)))
 	     (when (member rem-type '(float single-float double-float
-				      	    #+long-float long-float))
+				      #+long-float long-float
+				      #+double-double double-double-float))
 	       (setf rem (interval-func #'(lambda (x)
 					    (coerce x rem-type))
 					rem)))
@@ -1806,7 +1815,8 @@
 		    (rem (,r-name divisor-interval))
 		    (result-type (rem-result-type number-type divisor-type)))
 	       (when (member result-type '(float single-float double-float
-					   #+long-float long-float))
+					   #+long-float long-float
+					   #+double-double double-double-float))
 		 ;; Make sure the limits on the interval have the right type.
 		 (setf rem (interval-func #'(lambda (x)
 					      (coerce x result-type))
@@ -3226,12 +3236,14 @@
 			 (member format1 '(short-float single-float)))
 			#-long-float
 			((double-float long-float) 'T)
-			#+long-float
+			#+(or long-float double-double)
 			(double-float
 			 (member format1 '(short-float single-float
 					   double-float)))
 			#+long-float
-			(long-float 'T))))
+			(long-float 'T)
+			#+double-double
+			(double-double-float 't))))
 		((and (eq class1 'float) (member class2 '(integer rational)))
 		 Nil)
 		(t
diff --git a/compiler/x86/array.lisp b/compiler/x86/array.lisp
index c2ae130c5cf2c0a0addf3b97f262745bb10bd6ba..351393cde9019a15a406798111543a02017e8dbd 100644
--- a/compiler/x86/array.lisp
+++ b/compiler/x86/array.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/array.lisp,v 1.18 2003/08/03 11:27:45 gerd Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/array.lisp,v 1.19 2006/06/30 18:41:32 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1578,3 +1578,363 @@
 (define-vop (get-vector-subtype get-header-data))
 (define-vop (set-vector-subtype set-header-data))
 
+
+#+double-double
+(progn
+(define-vop (data-vector-ref/simple-array-double-double-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (index :scs (any-reg)))
+  (:arg-types simple-array-double-double-float positive-fixnum)
+  (:results (value :scs (double-double-reg)))
+  (:result-types double-double-float)
+;;  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
+  (:generator 7
+    (let ((hi-tn (double-double-reg-hi-tn value)))
+      (with-empty-tn@fp-top (hi-tn)
+	(inst fldd (make-ea :dword :base object :index index :scale 4
+			    :disp (- (* vm:vector-data-offset vm:word-bytes)
+				     vm:other-pointer-type)))))
+    (let ((lo-tn (double-double-reg-lo-tn value)))
+      (with-empty-tn@fp-top (lo-tn)
+	(inst fldd (make-ea :dword :base object :index index :scale 4
+			    :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+					8)
+				     vm:other-pointer-type)))))))
+
+#+nil
+(define-vop (data-vector-ref-c/simple-array-double-double-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result))
+  (:arg-types simple-array-double-double-float (:constant index))
+  (:info index)
+  (:results (value :scs (double-double-reg)))
+  (:result-types double-double-float)
+;;  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp)
+  (:generator 5
+    (let ((offset (+ (* index 16)
+		     (- (* vm:vector-data-offset vm:word-bytes)
+			  vm:other-pointer-type)))
+	  (hi-tn (double-double-reg-hi-tn value))
+	  (lo-tn (double-double-reg-lo-tn value)))
+      (cond ((typep (+ offset 8) '(signed-byte 13))
+	     (inst lddf hi-tn object offset)
+	     (inst lddf lo-tn object (+ offset 8)))
+	    (t
+	     (inst li temp offset)
+	     (inst lddf hi-tn object temp)
+	     (inst add temp (* 2 vm:word-bytes))
+	     (inst lddf lo-tn object temp))))))
+
+(define-vop (data-vector-set/simple-array-double-double-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (index :scs (any-reg))
+	 (value :scs (double-double-reg) :target result))
+  (:arg-types simple-array-double-double-float positive-fixnum
+	      double-double-float)
+  (:results (result :scs (double-double-reg)))
+  (:result-types double-double-float)
+;;  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
+  (:generator 20
+    (let ((value-real (double-double-reg-hi-tn value))
+	  (result-real (double-double-reg-hi-tn result)))
+      (cond ((zerop (tn-offset value-real))
+	     ;; Value is in ST0
+	     (inst fstd (make-ea :dword :base object :index index :scale 4
+				 :disp (- (* vm:vector-data-offset
+					     vm:word-bytes)
+					  vm:other-pointer-type)))
+	     (unless (zerop (tn-offset result-real))
+	       ;; Value is in ST0 but not result.
+	       (inst fstd result-real)))
+	    (t
+	     ;; Value is not in ST0.
+	     (inst fxch value-real)
+	     (inst fstd (make-ea :dword :base object :index index :scale 4
+				 :disp (- (* vm:vector-data-offset
+					     vm:word-bytes)
+					  vm:other-pointer-type)))
+	     (cond ((zerop (tn-offset result-real))
+		    ;; The result is in ST0.
+		    (inst fstd value-real))
+		   (t
+		    ;; Neither value or result are in ST0
+		    (unless (location= value-real result-real)
+		      (inst fstd result-real))
+		    (inst fxch value-real))))))
+    (let ((value-imag (double-double-reg-lo-tn value))
+	  (result-imag (double-double-reg-lo-tn result)))
+      (inst fxch value-imag)
+      (inst fstd (make-ea :dword :base object :index index :scale 4
+			  :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+				      8)
+				   vm:other-pointer-type)))
+      (unless (location= value-imag result-imag)
+	(inst fstd result-imag))
+      (inst fxch value-imag))))
+
+#+nil
+(define-vop (data-vector-set-c/simple-array-double-double-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (value :scs (double-double-reg) :target result))
+  (:arg-types simple-array-double-double-float
+	      (:constant index)
+	      double-double-float)
+  (:info index)
+  (:results (result :scs (double-double-reg)))
+  (:result-types double-double-float)
+;;  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp)
+  (:generator 15
+    (let ((value-hi (double-double-reg-hi-tn value))
+	  (result-hi (double-double-reg-hi-tn result))
+	  (value-lo (double-double-reg-lo-tn value))
+	  (result-lo (double-double-reg-lo-tn result))
+	  (offset (+ (* index 16)
+		     (- (* vm:vector-data-offset vm:word-bytes)
+			  vm:other-pointer-type))))
+      ;; There's a possible optimization here if the offset for the
+      ;; real part fits in a signed-byte 13 but the imag part doesn't.
+      ;; We don't do this because it can't happen with the current
+      ;; values of vm:other-pointer-type and vm:vector-data-offset.
+      (cond ((typep (+ offset 8) '(signed-byte 13))
+	     (inst stdf value-hi object offset)
+	     (inst stdf value-lo object (+ offset 8)))
+	    (t
+	     (inst li temp offset)
+	     (inst stdf value-hi object temp)
+	     (inst add temp 8)
+	     (inst stdf value-lo object temp)))
+      (unless (location= result-hi value-hi)
+	(move-double-reg result-hi value-hi))
+      (unless (location= result-lo value-lo)
+	(move-double-reg result-lo value-lo)))))
+
+(define-vop (data-vector-ref/simple-array-complex-double-double-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (index :scs (any-reg)))
+  (:arg-types simple-array-complex-double-double-float positive-fixnum)
+  (:results (value :scs (complex-double-double-reg)))
+  (:result-types complex-double-double-float)
+;;  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
+  (:generator 7
+    (let ((real-tn (complex-double-double-reg-real-hi-tn value)))
+      (with-empty-tn@fp-top (real-tn)
+	(inst fldd (make-ea :dword :base object :index index :scale 8
+			    :disp (- (* vm:vector-data-offset vm:word-bytes)
+				     vm:other-pointer-type)))))
+    (let ((real-tn (complex-double-double-reg-real-lo-tn value)))
+      (with-empty-tn@fp-top (real-tn)
+	(inst fldd (make-ea :dword :base object :index index :scale 8
+			    :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+					8)
+				     vm:other-pointer-type)))))
+    (let ((imag-tn (complex-double-double-reg-imag-hi-tn value)))
+      (with-empty-tn@fp-top (imag-tn)
+	(inst fldd (make-ea :dword :base object :index index :scale 8
+			    :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+					16)
+				     vm:other-pointer-type)))))
+    (let ((imag-tn (complex-double-double-reg-imag-lo-tn value)))
+      (with-empty-tn@fp-top (imag-tn)
+	(inst fldd (make-ea :dword :base object :index index :scale 8
+			    :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+					24)
+				     vm:other-pointer-type)))))))
+
+#+nil
+(define-vop (data-vector-ref-c/simple-array-complex-double-double-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result))
+  (:arg-types simple-array-complex-double-double-float (:constant index))
+  (:info index)
+  (:results (value :scs (complex-double-double-reg)))
+  (:result-types complex-double-double-float)
+;;  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp)
+  (:generator 5
+    (let ((offset (+ (* index 16)
+		     (- (* vm:vector-data-offset vm:word-bytes)
+			  vm:other-pointer-type)))
+	  (real-hi-tn (complex-double-double-reg-real-hi-tn value))
+	  (imag-hi-tn (complex-double-double-reg-imag-hi-tn value))
+	  (real-lo-tn (complex-double-double-reg-real-lo-tn value))
+	  (imag-lo-tn (complex-double-double-reg-imag-lo-tn value)))
+      (cond ((typep (+ offset 8) '(signed-byte 13))
+	     (inst lddf real-hi-tn object offset)
+	     (inst lddf imag-hi-tn object (+ offset (* 2 vm:word-bytes)))
+	     (inst lddf real-lo-tn object (+ offset (* 4 vm:word-bytes)))
+	     (inst lddf real-lo-tn object (+ offset (* 6 vm:word-bytes))))
+	    (t
+	     (inst li temp offset)
+	     (inst lddf real-hi-tn object temp)
+	     (inst add temp (* 2 vm:word-bytes))
+	     (inst lddf imag-hi-tn object temp)
+	     (inst lddf real-lo-tn object temp)
+	     (inst add temp (* 2 vm:word-bytes))
+	     (inst lddf imag-lo-tn object temp))))))
+
+(define-vop (data-vector-set/simple-array-complex-double-double-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (index :scs (any-reg))
+	 (value :scs (complex-double-double-reg) :target result))
+  (:arg-types simple-array-complex-double-double-float positive-fixnum
+	      complex-double-double-float)
+  (:results (result :scs (complex-double-double-reg)))
+  (:result-types complex-double-double-float)
+;;  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
+  (:generator 20
+    (let ((value-real (complex-double-double-reg-real-hi-tn value))
+	  (result-real (complex-double-double-reg-real-hi-tn result)))
+      (cond ((zerop (tn-offset value-real))
+	     ;; Value is in ST0
+	     (inst fstd (make-ea :dword :base object :index index :scale 8
+				 :disp (- (* vm:vector-data-offset
+					     vm:word-bytes)
+					  vm:other-pointer-type)))
+	     (unless (zerop (tn-offset result-real))
+	       ;; Value is in ST0 but not result.
+	       (inst fstd result-real)))
+	    (t
+	     ;; Value is not in ST0.
+	     (inst fxch value-real)
+	     (inst fstd (make-ea :dword :base object :index index :scale 8
+				 :disp (- (* vm:vector-data-offset
+					     vm:word-bytes)
+					  vm:other-pointer-type)))
+	     (cond ((zerop (tn-offset result-real))
+		    ;; The result is in ST0.
+		    (inst fstd value-real))
+		   (t
+		    ;; Neither value or result are in ST0
+		    (unless (location= value-real result-real)
+		      (inst fstd result-real))
+		    (inst fxch value-real))))))
+    (let ((value-real (complex-double-double-reg-real-lo-tn value))
+	  (result-real (complex-double-double-reg-real-lo-tn result)))
+      (cond ((zerop (tn-offset value-real))
+	     ;; Value is in ST0
+	     (inst fstd (make-ea :dword :base object :index index :scale 8
+				 :disp (- (+ (* vm:vector-data-offset
+						vm:word-bytes)
+					     8)
+					  vm:other-pointer-type)))
+	     (unless (zerop (tn-offset result-real))
+	       ;; Value is in ST0 but not result.
+	       (inst fstd result-real)))
+	    (t
+	     ;; Value is not in ST0.
+	     (inst fxch value-real)
+	     (inst fstd (make-ea :dword :base object :index index :scale 8
+				 :disp (- (+ (* vm:vector-data-offset
+						vm:word-bytes)
+					     8)
+					  vm:other-pointer-type)))
+	     (cond ((zerop (tn-offset result-real))
+		    ;; The result is in ST0.
+		    (inst fstd value-real))
+		   (t
+		    ;; Neither value or result are in ST0
+		    (unless (location= value-real result-real)
+		      (inst fstd result-real))
+		    (inst fxch value-real))))))
+    (let ((value-imag (complex-double-double-reg-imag-hi-tn value))
+	  (result-imag (complex-double-double-reg-imag-hi-tn result)))
+      (inst fxch value-imag)
+      (inst fstd (make-ea :dword :base object :index index :scale 8
+			  :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+				      16)
+				   vm:other-pointer-type)))
+      (unless (location= value-imag result-imag)
+	(inst fstd result-imag))
+      (inst fxch value-imag))
+    (let ((value-imag (complex-double-double-reg-imag-lo-tn value))
+	  (result-imag (complex-double-double-reg-imag-lo-tn result)))
+      (inst fxch value-imag)
+      (inst fstd (make-ea :dword :base object :index index :scale 8
+			  :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+				      24)
+				   vm:other-pointer-type)))
+      (unless (location= value-imag result-imag)
+	(inst fstd result-imag))
+      (inst fxch value-imag))))
+
+#+nil
+(define-vop (data-vector-set-c/simple-array-complex-double-double-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (value :scs (complex-double-double-reg) :target result))
+  (:arg-types simple-array-complex-double-double-float
+	      (:constant index)
+	      complex-double-double-float)
+  (:info index)
+  (:results (result :scs (complex-double-double-reg)))
+  (:result-types complex-double-double-float)
+;;  (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp)
+  (:generator 15
+    (let ((value-real (complex-double-double-reg-real-hi-tn value))
+	  (result-real (complex-double-double-reg-real-hi-tn result))
+	  (value-imag (complex-double-double-reg-imag-hi-tn value))
+	  (result-imag (complex-double-double-reg-imag-hi-tn result))
+	  (offset (+ (* index 16)
+		     (- (* vm:vector-data-offset vm:word-bytes)
+			  vm:other-pointer-type))))
+      ;; There's a possible optimization here if the offset for the
+      ;; real part fits in a signed-byte 13 but the imag part doesn't.
+      ;; We don't do this because it can't happen with the current
+      ;; values of vm:other-pointer-type and vm:vector-data-offset.
+      (cond ((typep (+ offset 8) '(signed-byte 13))
+	     (inst stdf value-real object offset)
+	     (inst stdf value-imag object (+ offset 8)))
+	    (t
+	     (inst li temp offset)
+	     (inst stdf value-real object temp)
+	     (inst add temp 8)
+	     (inst stdf value-imag object temp)))
+      (unless (location= result-real value-real)
+	(move-double-reg result-real value-real))
+      (unless (location= result-imag value-imag)
+	(move-double-reg result-imag value-imag)))
+    (let ((value-real (complex-double-double-reg-real-lo-tn value))
+	  (result-real (complex-double-double-reg-real-lo-tn result))
+	  (value-imag (complex-double-double-reg-imag-lo-tn value))
+	  (result-imag (complex-double-double-reg-imag-lo-tn result))
+	  (offset (+ (* index 16)
+		     (- (* vm:vector-data-offset vm:word-bytes)
+			  vm:other-pointer-type))))
+      ;; There's a possible optimization here if the offset for the
+      ;; real part fits in a signed-byte 13 but the imag part doesn't.
+      ;; We don't do this because it can't happen with the current
+      ;; values of vm:other-pointer-type and vm:vector-data-offset.
+      (cond ((typep (+ offset (* 6 vm:word-bytes)) '(signed-byte 13))
+	     (inst stdf value-real object (+ offset (* 4 vm:word-bytes)))
+	     (inst stdf value-imag object (+ offset (* 6 vm:word-bytes))))
+	    (t
+	     (inst add temp 8)
+	     (inst stdf value-real object temp)
+	     (inst add temp 8)
+	     (inst stdf value-imag object temp)))
+      (unless (location= result-real value-real)
+	(move-double-reg result-real value-real))
+      (unless (location= result-imag value-imag)
+	(move-double-reg result-imag value-imag)))))
+
+)
diff --git a/compiler/x86/float.lisp b/compiler/x86/float.lisp
index 40c7f6eb1332c739169c3645cc3e71ef1f7dac89..e4e2515cf8f4d9b1a5186d21aef6747e842023b2 100644
--- a/compiler/x86/float.lisp
+++ b/compiler/x86/float.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/float.lisp,v 1.41 2003/07/03 02:14:58 toy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/float.lisp,v 1.42 2006/06/30 18:41:32 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -61,7 +61,20 @@
     (ea-for-xf-desc tn vm:complex-long-float-real-slot))
   #+long-float
   (defun ea-for-clf-imag-desc (tn)
-    (ea-for-xf-desc tn vm:complex-long-float-imag-slot)))
+    (ea-for-xf-desc tn vm:complex-long-float-imag-slot))
+  #+double-double
+  (defun ea-for-cddf-real-hi-desc (tn)
+    (ea-for-xf-desc tn vm:complex-double-double-float-real-hi-slot))
+  #+double-double
+  (defun ea-for-cddf-real-lo-desc (tn)
+    (ea-for-xf-desc tn vm:complex-double-double-float-real-lo-slot))
+  #+double-double
+  (defun ea-for-cddf-imag-hi-desc (tn)
+    (ea-for-xf-desc tn vm:complex-double-double-float-imag-hi-slot))
+  #+double-double
+  (defun ea-for-cddf-imag-lo-desc (tn)
+    (ea-for-xf-desc tn vm:complex-double-double-float-imag-lo-slot))
+  )
 
 (macrolet ((ea-for-xf-stack (tn kind)
 	     `(make-ea
@@ -86,7 +99,13 @@
 				   (:single 1)
 				   (:double 2)
 				   (:long 3))
-				 (ecase ,slot (:real 1) (:imag 2))))
+				 (ecase ,slot
+				   (:real 1)
+				   (:imag 2)
+				   (:real-hi 1)
+				   (:real-lo 2)
+				   (:imag-hi 3)
+				   (:imag-lo 4))))
 			 vm:word-bytes)))))
   (defun ea-for-csf-real-stack (tn &optional (base ebp-tn))
     (ea-for-cxf-stack tn :single :real base))
@@ -103,7 +122,21 @@
     (ea-for-cxf-stack tn :long :real base))
   #+long-float
   (defun ea-for-clf-imag-stack (tn &optional (base ebp-tn))
-    (ea-for-cxf-stack tn :long :imag base)))
+    (ea-for-cxf-stack tn :long :imag base))
+
+  #+double-double
+  (defun ea-for-cddf-real-hi-stack (tn &optional (base ebp-tn))
+    (ea-for-cxf-stack tn :double :real-hi base))
+  #+double-double
+  (defun ea-for-cddf-real-lo-stack (tn &optional (base ebp-tn))
+    (ea-for-cxf-stack tn :double :real-lo base))
+  #+double-double
+  (defun ea-for-cddf-imag-hi-stack (tn &optional (base ebp-tn))
+    (ea-for-cxf-stack tn :double :imag-hi base))
+  #+double-double
+  (defun ea-for-cddf-imag-lo-stack (tn &optional (base ebp-tn))
+    (ea-for-cxf-stack tn :double :imag-lo base))
+  )
 
 ;;; Abstract out the copying of a FP register to the FP stack top, and
 ;;; provide two alternatives for its implementation. Note: it's not
@@ -236,6 +269,21 @@
   (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg *backend*)
 		  :offset (1+ (tn-offset x))))
 
+#+double-double
+(progn
+(defun complex-double-double-reg-real-hi-tn (x)
+  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
+		  :offset (tn-offset x)))
+(defun complex-double-double-reg-real-lo-tn (x)
+  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
+		  :offset (+ 1 (tn-offset x))))
+(defun complex-double-double-reg-imag-hi-tn (x)
+  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
+		  :offset (+ 2 (tn-offset x))))
+(defun complex-double-double-reg-imag-lo-tn (x)
+  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
+		  :offset (+ 3 (tn-offset x))))
+)
 ;;; x is source, y is destination
 (define-move-function (load-complex-single 2) (vop x y)
   ((complex-single-stack) (complex-single-reg))
@@ -308,6 +356,49 @@
     (store-long-float (ea-for-clf-imag-stack y))
     (inst fxch imag-tn)))
 
+#+double-double
+(progn
+(define-move-function (load-complex-double-double 4) (vop x y)
+  ((complex-double-double-stack) (complex-double-double-reg))
+  (let ((real-tn (complex-double-double-reg-real-hi-tn y)))
+    (with-empty-tn@fp-top(real-tn)
+      (inst fldd (ea-for-cddf-real-hi-stack x))))
+  (let ((real-tn (complex-double-double-reg-real-lo-tn y)))
+    (with-empty-tn@fp-top(real-tn)
+      (inst fldd (ea-for-cddf-real-lo-stack x))))
+  (let ((imag-tn (complex-double-double-reg-imag-hi-tn y)))
+    (with-empty-tn@fp-top(imag-tn)
+      (inst fldd (ea-for-cddf-imag-hi-stack x))))
+  (let ((imag-tn (complex-double-double-reg-imag-lo-tn y)))
+    (with-empty-tn@fp-top(imag-tn)
+      (inst fldd (ea-for-cddf-imag-lo-stack x)))))
+
+(define-move-function (store-complex-double-double 4) (vop x y)
+  ((complex-double-double-reg) (complex-double-double-stack))
+  ;; FIXME: These may not be right!!!!
+  (let ((real-tn (complex-double-double-reg-real-hi-tn x)))
+    (cond ((zerop (tn-offset real-tn))
+	   (inst fstd (ea-for-cddf-real-hi-stack y)))
+	  (t
+	   (inst fxch real-tn)
+	   (inst fstd (ea-for-cddf-real-hi-stack y))
+	   (inst fxch real-tn))))
+  (let ((real-tn (complex-double-double-reg-real-lo-tn x)))
+    (cond ((zerop (tn-offset real-tn))
+	   (inst fstd (ea-for-cddf-real-lo-stack y)))
+	  (t
+	   (inst fxch real-tn)
+	   (inst fstd (ea-for-cddf-real-lo-stack y))
+	   (inst fxch real-tn))))
+  (let ((imag-tn (complex-double-double-reg-imag-hi-tn x)))
+    (inst fxch imag-tn)
+    (inst fstd (ea-for-cddf-imag-hi-stack y))
+    (inst fxch imag-tn))
+  (let ((imag-tn (complex-double-double-reg-imag-lo-tn x)))
+    (inst fxch imag-tn)
+    (inst fstd (ea-for-cddf-imag-lo-stack y))
+    (inst fxch imag-tn)))
+)
 
 ;;;; Move VOPs:
 
@@ -557,6 +648,31 @@
 (define-move-vop move-from-complex-long :move
   (complex-long-reg) (descriptor-reg))
 
+#+double-double
+(define-vop (move-from-complex-double-double)
+  (:args (x :scs (complex-double-double-reg) :to :save))
+  (:results (y :scs (descriptor-reg)))
+  (:node-var node)
+  (:note "complex double float to pointer coercion")
+  (:generator 13
+     (with-fixed-allocation (y vm::complex-double-double-float-type
+			       vm::complex-double-double-float-size node)
+       (let ((real-tn (complex-double-double-reg-real-hi-tn x)))
+	 (with-tn@fp-top(real-tn)
+	   (inst fstd (ea-for-cddf-real-hi-desc y))))
+       (let ((real-tn (complex-double-double-reg-real-lo-tn x)))
+	 (with-tn@fp-top(real-tn)
+	   (inst fstd (ea-for-cddf-real-lo-desc y))))
+       (let ((imag-tn (complex-double-double-reg-imag-hi-tn x)))
+	 (with-tn@fp-top(imag-tn)
+	   (inst fstd (ea-for-cddf-imag-hi-desc y))))
+       (let ((imag-tn (complex-double-double-reg-imag-lo-tn x)))
+	 (with-tn@fp-top(imag-tn)
+	   (inst fstd (ea-for-cddf-imag-lo-desc y)))))))
+;;;
+#+double-double
+(define-move-vop move-from-complex-double-double :move
+  (complex-double-double-reg) (descriptor-reg))
 ;;;
 ;;; Move from a descriptor to a complex float register
 ;;;
@@ -724,9 +840,76 @@
   (frob move-complex-long-float-argument
 	complex-long-reg complex-long-stack :long))
 
+#+double-double
+(define-vop (move-complex-double-double-float-argument)
+  (:args (x :scs (complex-double-double-reg) :target y)
+	 (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-double-reg))))
+  (:results (y))
+  (:note "complex double-double-float argument move")
+  (:generator 2
+    (sc-case y
+      (complex-double-double-reg
+       (unless (location= x y)
+	 (let ((x-real (complex-double-double-reg-real-hi-tn x))
+	       (y-real (complex-double-double-reg-real-hi-tn y)))
+	   (cond ((zerop (tn-offset y-real))
+		  (copy-fp-reg-to-fr0 x-real))
+		 ((zerop (tn-offset x-real))
+		  (inst fstd y-real))
+		 (t
+		  (inst fxch x-real)
+		  (inst fstd y-real)
+		  (inst fxch x-real))))
+	 (let ((x-real (complex-double-double-reg-real-lo-tn x))
+	       (y-real (complex-double-double-reg-real-lo-tn y)))
+	   (cond ((zerop (tn-offset y-real))
+		  (copy-fp-reg-to-fr0 x-real))
+		 ((zerop (tn-offset x-real))
+		  (inst fstd y-real))
+		 (t
+		  (inst fxch x-real)
+		  (inst fstd y-real)
+		  (inst fxch x-real))))
+	 (let ((x-imag (complex-double-double-reg-imag-hi-tn x))
+	       (y-imag (complex-double-double-reg-imag-hi-tn y)))
+	   (inst fxch x-imag)
+	   (inst fstd y-imag)
+	   (inst fxch x-imag))
+	 (let ((x-imag (complex-double-double-reg-imag-lo-tn x))
+	       (y-imag (complex-double-double-reg-imag-lo-tn y)))
+	   (inst fxch x-imag)
+	   (inst fstd y-imag)
+	   (inst fxch x-imag))))
+      (complex-double-double-stack
+       (let ((real-tn (complex-double-double-reg-real-hi-tn x)))
+	 (cond ((zerop (tn-offset real-tn))
+		(inst fstd (ea-for-cddf-real-hi-stack y)))
+	       (t
+		(inst fxch real-tn)
+		(inst fstd (ea-for-cddf-real-hi-stack y))
+		(inst fxch real-tn))))
+       (let ((real-tn (complex-double-double-reg-real-hi-tn x)))
+	 (cond ((zerop (tn-offset real-tn))
+		(inst fstd (ea-for-cddf-real-lo-stack y)))
+	       (t
+		(inst fxch real-tn)
+		(inst fstd (ea-for-cddf-real-lo-stack y))
+		(inst fxch real-tn))))
+       (let ((imag-tn (complex-double-double-reg-imag-hi-tn x)))
+	 (inst fxch imag-tn)
+	 (inst fstd (ea-for-cddf-imag-hi-stack y))
+	 (inst fxch imag-tn))
+       (let ((imag-tn (complex-double-double-reg-imag-lo-tn x)))
+	 (inst fxch imag-tn)
+	 (inst fstd (ea-for-cddf-imag-lo-stack y))
+	 (inst fxch imag-tn))))
+    ))
+
 (define-move-vop move-argument :move-argument
   (single-reg double-reg #+long-float long-reg
-   complex-single-reg complex-double-reg #+long-float complex-long-reg)
+   #+double-double double-double-reg
+   complex-single-reg complex-double-reg #+long-float complex-long-reg
+   #+double-double complex-double-double-reg)
   (descriptor-reg))
 
 
@@ -1206,6 +1389,12 @@
 	(= (long-float-high-bits x) (long-float-high-bits y))
 	(= (long-float-exp-bits x) (long-float-exp-bits y))))
 
+#+double-double
+(deftransform eql ((x y) (double-double-float double-double-float))
+  '(and (eql (double-double-hi x) (double-double-hi y))
+	(eql (double-double-lo x) (double-double-lo y))))
+
+
 (define-vop (=/float)
   (:args (x) (y))
   (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
@@ -4641,3 +4830,410 @@
   (:note "inline dummy FP register bias")
   (:ignore x)
   (:generator 0))
+
+;;; Support for double-double floats
+
+#+double-double
+(progn
+
+(defun double-double-reg-hi-tn (x)
+  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
+		  :offset (tn-offset x)))
+
+(defun double-double-reg-lo-tn (x)
+  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg *backend*)
+		  :offset (1+ (tn-offset x))))
+
+(define-move-function (load-double-double 4) (vop x y)
+  ((double-double-stack) (double-double-reg))
+  (let ((real-tn (double-double-reg-hi-tn y)))
+    (with-empty-tn@fp-top(real-tn)
+      (inst fldd (ea-for-cdf-real-stack x))))
+  (let ((imag-tn (double-double-reg-lo-tn y)))
+    (with-empty-tn@fp-top(imag-tn)
+      (inst fldd (ea-for-cdf-imag-stack x)))))
+
+(define-move-function (store-double-double 4) (vop x y)
+  ((double-double-reg) (double-double-stack))
+  (let ((real-tn (double-double-reg-hi-tn x)))
+    (cond ((zerop (tn-offset real-tn))
+	   (inst fstd (ea-for-cdf-real-stack y)))
+	  (t
+	   (inst fxch real-tn)
+	   (inst fstd (ea-for-cdf-real-stack y))
+	   (inst fxch real-tn))))
+  (let ((imag-tn (double-double-reg-lo-tn x)))
+    (inst fxch imag-tn)
+    (inst fstd (ea-for-cdf-imag-stack y))
+    (inst fxch imag-tn)))
+
+;;; Double-double float register to register moves
+
+(define-vop (double-double-move)
+  (:args (x :scs (double-double-reg)
+	    :target y :load-if (not (location= x y))))
+  (:results (y :scs (double-double-reg) :load-if (not (location= x y))))
+  (:note "double-double float move")
+  (:generator 0
+     (unless (location= x y)
+       ;; Note the double-float-regs are aligned to every second
+       ;; float register so there is not need to worry about overlap.
+       (let ((x-hi (double-double-reg-hi-tn x))
+	     (y-hi (double-double-reg-hi-tn y)))
+	 (cond ((zerop (tn-offset y-hi))
+		(copy-fp-reg-to-fr0 x-hi))
+	       ((zerop (tn-offset x-hi))
+		(inst fstd y-hi))
+	       (t
+		(inst fxch x-hi)
+		(inst fstd y-hi)
+		(inst fxch x-hi))))
+       (let ((x-lo (double-double-reg-lo-tn x))
+	     (y-lo (double-double-reg-lo-tn y)))
+	 (inst fxch x-lo)
+	 (inst fstd y-lo)
+	 (inst fxch x-lo)))))
+;;;
+(define-move-vop double-double-move :move
+  (double-double-reg) (double-double-reg))
+
+;;; Move from a complex float to a descriptor register allocating a
+;;; new complex float object in the process.
+
+(define-vop (move-from-double-double)
+  (:args (x :scs (double-double-reg) :to :save))
+  (:results (y :scs (descriptor-reg)))
+  (:node-var node)
+  (:note "double double float to pointer coercion")
+  (:generator 13
+     (with-fixed-allocation (y vm:double-double-float-type
+			       vm:double-double-float-size node)
+       (let ((real-tn (double-double-reg-hi-tn x)))
+	 (with-tn@fp-top(real-tn)
+	   (inst fstd (ea-for-cdf-real-desc y))))
+       (let ((imag-tn (double-double-reg-lo-tn x)))
+	 (with-tn@fp-top(imag-tn)
+	   (inst fstd (ea-for-cdf-imag-desc y)))))))
+;;;
+(define-move-vop move-from-double-double :move
+  (double-double-reg) (descriptor-reg))
+
+;;; Move from a descriptor to a double-double float register
+
+(define-vop (move-to-double-double)
+  (:args (x :scs (descriptor-reg)))
+  (:results (y :scs (double-double-reg)))
+  (:note "pointer to double-double-float coercion")
+  (:generator 2
+    (let ((real-tn (double-double-reg-hi-tn y)))
+      (with-empty-tn@fp-top(real-tn)
+	(inst fldd (ea-for-cdf-real-desc x))))
+    (let ((imag-tn (double-double-reg-lo-tn y)))
+      (with-empty-tn@fp-top(imag-tn)
+	(inst fldd (ea-for-cdf-imag-desc x))))))
+
+(define-move-vop move-to-double-double :move
+  (descriptor-reg) (double-double-reg))
+
+;;; double-double float move-argument vop
+
+(define-vop (move-double-double-float-argument)
+  (:args (x :scs (double-double-reg) :target y)
+	 (fp :scs (any-reg) :load-if (not (sc-is y double-double-reg))))
+  (:results (y))
+  (:note "double double-float argument move")
+  (:generator 2
+    (sc-case y
+      (double-double-reg
+       (unless (location= x y)
+	 (let ((x-real (double-double-reg-hi-tn x))
+	       (y-real (double-double-reg-hi-tn y)))
+	   (cond ((zerop (tn-offset y-real))
+		  (copy-fp-reg-to-fr0 x-real))
+		 ((zerop (tn-offset x-real))
+		  (inst fstd y-real))
+		 (t
+		  (inst fxch x-real)
+		  (inst fstd y-real)
+		  (inst fxch x-real))))
+	 (let ((x-imag (double-double-reg-lo-tn x))
+	       (y-imag (double-double-reg-lo-tn y)))
+	   (inst fxch x-imag)
+	   (inst fstd y-imag)
+	   (inst fxch x-imag))))
+      (double-double-stack
+       (let ((hi-tn (double-double-reg-hi-tn x)))
+	 (cond ((zerop (tn-offset hi-tn))
+		(inst fstd (ea-for-cdf-real-stack y fp)))
+	       (t
+		(inst fxch hi-tn)
+		(inst fstd (ea-for-cdf-real-stack y fp))
+		(inst fxch hi-tn))))
+       (let ((lo-tn (double-double-reg-lo-tn x)))
+	 (inst fxch lo-tn)
+	 (inst fstd (ea-for-cdf-imag-stack y fp))
+	 (inst fxch lo-tn))))))
+
+(define-move-vop move-double-double-float-argument :move-argument
+  (double-double-reg descriptor-reg) (double-double-reg))
+
+
+(define-vop (move-to-complex-double-double)
+  (:args (x :scs (descriptor-reg)))
+  (:results (y :scs (complex-double-double-reg)))
+  (:note "pointer to complex float coercion")
+  (:generator 2
+    (let ((real-tn (complex-double-double-reg-real-hi-tn y)))
+      (with-empty-tn@fp-top(real-tn)
+	(inst fldd (ea-for-cddf-real-hi-desc x))))
+    (let ((real-tn (complex-double-double-reg-real-lo-tn y)))
+      (with-empty-tn@fp-top(real-tn)
+	(inst fldd (ea-for-cddf-real-lo-desc x))))
+    (let ((imag-tn (complex-double-double-reg-imag-hi-tn y)))
+      (with-empty-tn@fp-top(imag-tn)
+	(inst fldd (ea-for-cddf-imag-hi-desc x))))
+    (let ((imag-tn (complex-double-double-reg-imag-lo-tn y)))
+      (with-empty-tn@fp-top(imag-tn)
+	(inst fldd (ea-for-cddf-imag-lo-desc x))))))
+
+(define-move-vop move-to-complex-double-double :move
+  (descriptor-reg) (complex-double-double-reg))
+
+
+(define-vop (make/double-double-float)
+  (:args (hi :scs (double-reg) :target r
+	     :load-if (not (location= hi r)))
+	 (lo :scs (double-reg) :to :save))
+  (:results (r :scs (double-double-reg) :from (:argument 0)
+	       :load-if (not (sc-is r double-double-stack))))
+  (:arg-types double-float double-float)
+  (:result-types double-double-float)
+  (:translate kernel::%make-double-double-float)
+  (:note "inline double-double-float creation")
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 5
+    (sc-case r
+      (double-double-reg
+       (let ((r-real (double-double-reg-hi-tn r)))
+	 (unless (location= hi r-real)
+	   (cond ((zerop (tn-offset r-real))
+		  (copy-fp-reg-to-fr0 hi))
+		 ((zerop (tn-offset hi))
+		  (inst fstd r-real))
+		 (t
+		  (inst fxch hi)
+		  (inst fstd r-real)
+		  (inst fxch hi)))))
+       (let ((r-imag (double-double-reg-lo-tn r)))
+	 (unless (location= lo r-imag)
+	   (cond ((zerop (tn-offset lo))
+		  (inst fstd r-imag))
+		 (t
+		  (inst fxch lo)
+		  (inst fstd r-imag)
+		  (inst fxch lo))))))
+      (double-double-stack
+       (unless (location= hi r)
+	 (cond ((zerop (tn-offset hi))
+		(inst fstd (ea-for-cdf-real-stack r)))
+	       (t
+		(inst fxch hi)
+		(inst fstd (ea-for-cdf-real-stack r))
+		(inst fxch hi))))
+       (inst fxch lo)
+       (inst fstd (ea-for-cdf-imag-stack r))
+       (inst fxch lo)))))
+
+(define-vop (double-double-value)
+  (:args (x :target r))
+  (:results (r))
+  (:variant-vars offset)
+  (:policy :fast-safe)
+  (:generator 3
+    (cond ((sc-is x double-double-reg)
+	   (let ((value-tn
+		  (make-random-tn :kind :normal
+				  :sc (sc-or-lose 'double-reg *backend*)
+				  :offset (+ offset (tn-offset x)))))
+	     (unless (location= value-tn r)
+	       (cond ((zerop (tn-offset r))
+		      (copy-fp-reg-to-fr0 value-tn))
+		     ((zerop (tn-offset value-tn))
+		      (inst fstd r))
+		     (t
+		      (inst fxch value-tn)
+		      (inst fstd r)
+		      (inst fxch value-tn))))))
+	  ((sc-is r double-reg)
+	   (let ((ea (sc-case x
+		       (double-double-stack
+			(ecase offset
+			  (0 (ea-for-cdf-real-stack x))
+			  (1 (ea-for-cdf-imag-stack x))))
+		       (descriptor-reg
+			(ecase offset
+			  (0 (ea-for-cdf-real-desc x))
+			  (1 (ea-for-cdf-imag-desc x)))))))
+	     (with-empty-tn@fp-top(r)
+	       (inst fldd ea))))
+	  (t (error "double-double-value VOP failure")))))
+
+
+(define-vop (hi/double-double-value double-double-value)
+  (:translate kernel::double-double-hi)
+  (:args (x :scs (double-double-reg double-double-stack descriptor-reg)
+	    :target r))
+  (:arg-types double-double-float)
+  (:results (r :scs (double-reg)))
+  (:result-types double-float)
+  (:note "double-double high part")
+  (:variant 0))
+
+(define-vop (lo/double-double-value double-double-value)
+  (:translate kernel::double-double-lo)
+  (:args (x :scs (double-double-reg double-double-stack descriptor-reg)
+	    :target r))
+  (:arg-types double-double-float)
+  (:results (r :scs (double-reg)))
+  (:result-types double-float)
+  (:note "double-double low part")
+  (:variant 1))
+
+(define-vop (make-complex-double-double-float)
+  (:translate complex)
+  (:args (real :scs (double-double-reg) :target r
+	       :load-if (not (location= real r)))
+	 (imag :scs (double-double-reg) :to :save))
+  (:arg-types double-double-float double-double-float)
+  (:results (r :scs (complex-double-double-reg) :from (:argument 0)
+	       :load-if (not (sc-is r complex-double-double-stack))))
+  (:result-types complex-double-double-float)
+  (:note "inline complex double-double-float creation")
+  (:policy :fast-safe)
+  (:generator 5
+    (sc-case r
+      (complex-double-double-reg
+       (let ((r-real (complex-double-double-reg-real-hi-tn r))
+	     (a-real (double-double-reg-hi-tn real)))
+	 (unless (location= a-real r-real)
+	   (cond ((zerop (tn-offset r-real))
+		  (copy-fp-reg-to-fr0 a-real))
+		 ((zerop (tn-offset a-real))
+		  (inst fstd r-real))
+		 (t
+		  (inst fxch a-real)
+		  (inst fstd r-real)
+		  (inst fxch a-real)))))
+       (let ((r-real (complex-double-double-reg-real-lo-tn r))
+	     (a-real (double-double-reg-lo-tn real)))
+	 (unless (location= a-real r-real)
+	   (cond ((zerop (tn-offset r-real))
+		  (copy-fp-reg-to-fr0 a-real))
+		 ((zerop (tn-offset a-real))
+		  (inst fstd r-real))
+		 (t
+		  (inst fxch a-real)
+		  (inst fstd r-real)
+		  (inst fxch a-real)))))
+       (let ((r-imag (complex-double-double-reg-imag-hi-tn r))
+	     (a-imag (double-double-reg-hi-tn imag)))
+	 (unless (location= a-imag r-imag)
+	   (cond ((zerop (tn-offset a-imag))
+		  (inst fstd r-imag))
+		 (t
+		  (inst fxch a-imag)
+		  (inst fstd r-imag)
+		  (inst fxch a-imag)))))
+       (let ((r-imag (complex-double-double-reg-imag-lo-tn r))
+	     (a-imag (double-double-reg-lo-tn imag)))
+	 (unless (location= a-imag r-imag)
+	   (cond ((zerop (tn-offset a-imag))
+		  (inst fstd r-imag))
+		 (t
+		  (inst fxch a-imag)
+		  (inst fstd r-imag)
+		  (inst fxch a-imag))))))
+      (complex-double-double-stack
+       (unless (location= real r)
+	 (cond ((zerop (tn-offset real))
+		(inst fstd (ea-for-cddf-real-hi-stack r)))
+	       (t
+		(inst fxch real)
+		(inst fstd (ea-for-cddf-real-hi-stack r))
+		(inst fxch real))))
+       (cond ((zerop (tn-offset real))
+		(inst fstd (ea-for-cddf-real-lo-stack r)))
+	       (t
+		(inst fxch real)
+		(inst fstd (ea-for-cddf-real-lo-stack r))
+		(inst fxch real)))
+       (let ((imag-val (complex-double-double-reg-imag-hi-tn imag)))
+	 (inst fxch imag-val)
+	 (inst fstd (ea-for-cddf-imag-hi-stack r))
+	 (inst fxch imag-val))
+       (let ((imag-val (complex-double-double-reg-imag-lo-tn imag)))
+	 (inst fxch imag-val)
+	 (inst fstd (ea-for-cddf-imag-lo-stack r))
+	 (inst fxch imag-val))))))
+
+(define-vop (complex-double-double-float-value)
+  (:args (x :scs (complex-double-double-reg) :target r
+	    :load-if (not (sc-is x complex-double-double-stack))))
+  (:arg-types complex-double-double-float)
+  (:results (r :scs (double-double-reg)))
+  (:result-types double-double-float)
+  (:variant-vars slot)
+  (:policy :fast-safe)
+  (:generator 3
+    (sc-case x
+      (complex-double-double-reg
+       (let ((value-tn (ecase slot
+			 (:real (complex-double-double-reg-real-hi-tn x))
+			 (:imag (complex-double-double-reg-imag-hi-tn x))))
+	     (r-hi (double-double-reg-hi-tn r)))
+	 (unless (location= value-tn r-hi)
+	   (cond ((zerop (tn-offset r-hi))
+		  (copy-fp-reg-to-fr0 value-tn))
+		 ((zerop (tn-offset value-tn))
+		  (inst fstd r-hi))
+		 (t
+		  (inst fxch value-tn)
+		  (inst fstd r-hi)
+		  (inst fxch value-tn)))))
+       (let ((value-tn (ecase slot
+			 (:real (complex-double-double-reg-real-lo-tn x))
+			 (:imag (complex-double-double-reg-imag-lo-tn x))))
+	     (r-lo (double-double-reg-lo-tn r)))
+	 (unless (location= value-tn r-lo)
+	   (cond ((zerop (tn-offset r-lo))
+		  (copy-fp-reg-to-fr0 value-tn))
+		 ((zerop (tn-offset value-tn))
+		  (inst fstd r-lo))
+		 (t
+		  (inst fxch value-tn)
+		  (inst fstd r-lo)
+		  (inst fxch value-tn))))))
+      (complex-double-double-stack
+       (let ((r-hi (double-double-reg-hi-tn r)))
+	 (with-empty-tn@fp-top (r-hi)
+	   (inst fld (ecase slot
+		       (:real (ea-for-cddf-real-hi-stack x))
+		       (:imag (ea-for-cddf-imag-hi-stack x))))))
+       (let ((r-lo (double-double-reg-lo-tn r)))
+	 (with-empty-tn@fp-top (r-lo)
+	   (inst fld (ecase slot
+		       (:real (ea-for-cddf-real-lo-stack x))
+		       (:imag (ea-for-cddf-imag-lo-stack x))))))))))
+
+(define-vop (realpart/complex-double-double-float complex-double-double-float-value)
+  (:translate realpart)
+  (:note "complex float realpart")
+  (:variant :real))
+
+(define-vop (imagpart/complex-double-double-float complex-double-double-float-value)
+  (:translate imagpart)
+  (:note "complex float imagpart")
+  (:variant :imag))
+
+); progn
diff --git a/compiler/x86/parms.lisp b/compiler/x86/parms.lisp
index 336bf4c44614f37fd80e5da6c948b8be4d0788a3..f801a7d7f879a2c8c7fbe4a7826c5e0b1431fb0b 100644
--- a/compiler/x86/parms.lisp
+++ b/compiler/x86/parms.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/parms.lisp,v 1.28 2004/07/07 15:03:11 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/parms.lisp,v 1.29 2006/06/30 18:41:32 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -85,6 +85,8 @@
 	  float-imprecise-trap-bit float-invalid-trap-bit
 	  float-divide-by-zero-trap-bit))
 
+#+double-double
+(export '(double-double-float-digits))
 	  
 
 (eval-when (compile load eval)
@@ -143,6 +145,10 @@
 (defconstant long-float-digits
   (+ (byte-size long-float-significand-byte) word-bits 1))
 
+#+double-double
+(defconstant double-double-float-digits
+  (* 2 double-float-digits))
+
 ;;; pfw -- from i486 microprocessor programmers reference manual
 (defconstant float-invalid-trap-bit        (ash 1 0))
 (defconstant float-denormal-trap-bit       (ash 1 1))
diff --git a/compiler/x86/type-vops.lisp b/compiler/x86/type-vops.lisp
index 6dbf364c65edd46ea816eb186ffe289520c342f2..0adfb159886df51750f8a2e9a64988ab93cfddcc 100644
--- a/compiler/x86/type-vops.lisp
+++ b/compiler/x86/type-vops.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/type-vops.lisp,v 1.12 1998/07/24 17:22:43 dtc Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/type-vops.lisp,v 1.13 2006/06/30 18:41:32 rtoy Rel $")
 ;;;
 ;;; **********************************************************************
 ;;; 
@@ -32,7 +32,7 @@
 
 
 (defparameter function-header-types
-  (list funcallable-instance-header-type dylan-function-header-type
+  (list funcallable-instance-header-type 
 	byte-code-function-type byte-code-closure-type
 	function-header-type closure-function-header-type
 	closure-header-type))
@@ -354,7 +354,8 @@
 
 (def-type-vops complexp check-complex complex object-not-complex-error
   complex-type complex-single-float-type complex-double-float-type
-  #+long-float complex-long-float-type)
+  #+long-float complex-long-float-type
+  #+double-double vm::complex-double-double-float-type)
 
 (def-type-vops complex-rational-p check-complex-rational nil
   object-not-complex-rational-error complex-type)
@@ -362,7 +363,8 @@
 (def-type-vops complex-float-p check-complex-float nil
   object-not-complex-float-error
   complex-single-float-type complex-double-float-type
-  #+long-float complex-long-float-type)
+  #+long-float complex-long-float-type
+  #+double-double vm::complex-double-double-float-type)
 
 (def-type-vops complex-single-float-p check-complex-single-float
   complex-single-float object-not-complex-single-float-error
@@ -377,6 +379,11 @@
   complex-long-float object-not-complex-long-float-error
   complex-long-float-type)
 
+#+double-double
+(def-type-vops complex-double-double-float-p check-complex-double-double-float
+  complex-double-double-float object-not-complex-double-double-float-error
+  vm::complex-double-double-float-type)
+
 (def-type-vops single-float-p check-single-float single-float
   object-not-single-float-error single-float-type)
 
@@ -387,6 +394,11 @@
 (def-type-vops long-float-p check-long-float long-float
   object-not-long-float-error long-float-type)
 
+#+double-double
+(def-type-vops double-double-float-p check-double-double-float
+  double-double-float object-not-double-double-float-error
+  vm:double-double-float-type)
+	       
 (def-type-vops simple-string-p check-simple-string simple-string
   object-not-simple-string-error simple-string-type)
 
@@ -463,6 +475,11 @@
   simple-array-long-float object-not-simple-array-long-float-error
   simple-array-long-float-type)
 
+#+double-double
+(def-type-vops simple-array-double-double-float-p check-simple-array-double-double-float
+  simple-array-double-double-float object-not-simple-array-double-double-float-error
+  vm::simple-array-double-double-float-type)
+
 (def-type-vops simple-array-complex-single-float-p
   check-simple-array-complex-single-float
   simple-array-complex-single-float
@@ -482,6 +499,13 @@
   object-not-simple-array-complex-long-float-error
   simple-array-complex-long-float-type)
 
+#+double-double
+(def-type-vops simple-array-complex-double-double-float-p
+  check-simple-array-complex-double-double-float
+  simple-array-complex-double-double-float
+  object-not-simple-array-complex-double-double-float-error
+  vm::simple-array-complex-double-double-float-type)
+
 (def-type-vops base-char-p check-base-char base-char
   object-not-base-char-error base-char-type)
 
@@ -529,9 +553,11 @@
   simple-array-signed-byte-30-type simple-array-signed-byte-32-type
   simple-array-single-float-type simple-array-double-float-type
   #+long-float simple-array-long-float-type
+  #+double-double vm::simple-array-double-double-float-type
   simple-array-complex-single-float-type
   simple-array-complex-double-float-type
   #+long-float simple-array-complex-long-float-type
+  #+double-double vm::simple-array-complex-double-double-float-type
   complex-string-type complex-bit-vector-type complex-vector-type)
 
 (def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error
@@ -543,9 +569,12 @@
   simple-array-signed-byte-30-type simple-array-signed-byte-32-type
   simple-array-single-float-type simple-array-double-float-type
   #+long-float simple-array-long-float-type
+  #+double-double vm::simple-array-double-double-float-type
   simple-array-complex-single-float-type
   simple-array-complex-double-float-type
-  #+long-float simple-array-complex-long-float-type)
+  #+long-float simple-array-complex-long-float-type
+  #+double-double vm::simple-array-complex-double-double-float-type
+  )
 
 (def-type-vops arrayp check-array nil object-not-array-error
   simple-array-type simple-string-type simple-bit-vector-type
@@ -556,17 +585,22 @@
   simple-array-signed-byte-30-type simple-array-signed-byte-32-type
   simple-array-single-float-type simple-array-double-float-type
   #+long-float simple-array-long-float-type
+  #+double-double vm::simple-array-double-double-float-type
   simple-array-complex-single-float-type
   simple-array-complex-double-float-type
   #+long-float simple-array-complex-long-float-type
+  #+double-double vm::simple-array-complex-double-double-float-type
   complex-string-type complex-bit-vector-type complex-vector-type
   complex-array-type)
 
 (def-type-vops numberp check-number nil object-not-number-error
   even-fixnum-type odd-fixnum-type bignum-type ratio-type
-  single-float-type double-float-type #+long-float long-float-type complex-type
+  single-float-type double-float-type #+long-float long-float-type
+  #+double-double vm:double-double-float-type
+  complex-type
   complex-single-float-type complex-double-float-type
-  #+long-float complex-long-float-type)
+  #+long-float complex-long-float-type
+  #+double-double vm::complex-double-double-float-type)
 
 (def-type-vops rationalp check-rational nil object-not-rational-error
   even-fixnum-type odd-fixnum-type ratio-type bignum-type)
@@ -575,11 +609,13 @@
   even-fixnum-type odd-fixnum-type bignum-type)
 
 (def-type-vops floatp check-float nil object-not-float-error
-  single-float-type double-float-type #+long-float long-float-type)
+  single-float-type double-float-type #+long-float long-float-type
+  #+double-double vm:double-double-float-type)
 
 (def-type-vops realp check-real nil object-not-real-error
   even-fixnum-type odd-fixnum-type ratio-type bignum-type
-  single-float-type double-float-type #+long-float long-float-type)
+  single-float-type double-float-type #+long-float long-float-type
+  #+double-double vm:double-double-float-type)
 
 
 ;;;; Other integer ranges.
diff --git a/compiler/x86/vm.lisp b/compiler/x86/vm.lisp
index 470fbbaabebf96ecb941c6c93821ab7f273b6d6f..6854212f684c95a14e3d17f0a9c15e28b9ebbab2 100644
--- a/compiler/x86/vm.lisp
+++ b/compiler/x86/vm.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/vm.lisp,v 1.10 1998/07/24 17:22:44 dtc Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/vm.lisp,v 1.11 2006/06/30 18:41:32 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -174,13 +174,17 @@
   (sap-stack stack)			; System area pointers.
   (single-stack stack)			; single-floats
   (double-stack stack :element-size 2)	; double-floats.
+  #+double-double
+  (double-double-stack stack :element-size 4)	; double-double-float
   #+long-float
   (long-stack stack :element-size 3)	; long-floats.
   (complex-single-stack stack :element-size 2)	; complex-single-floats
   (complex-double-stack stack :element-size 4)	; complex-double-floats
   #+long-float
   (complex-long-stack stack :element-size 6)	; complex-long-floats
-
+  #+double-double
+  (complex-double-double-stack stack :element-size 8)	; complex-double-double-floats
+  
   ;; **** Magic SCs.
 
   (ignore-me noise)
@@ -280,6 +284,14 @@
 	    :save-p t
 	    :alternate-scs (long-stack))
 
+  #+double-double
+  (double-double-reg float-registers
+		     :locations (0 2 4 6)
+		     :element-size 2
+		     :constant-scs ()
+		     :save-p t
+		     :alternate-scs (double-double-stack))
+  
   (complex-single-reg float-registers
 		      :locations (0 2 4 6)
 		      :element-size 2
@@ -301,6 +313,13 @@
 		    :constant-scs ()
 		    :save-p t
 		    :alternate-scs (complex-long-stack))
+  #+double-double
+  (complex-double-double-reg float-registers
+		      :locations (0 4)
+		      :element-size 4
+		      :constant-scs ()
+		      :save-p t
+		      :alternate-scs (complex-double-double-stack))
 
   ;; A catch or unwind block.
   (catch-block stack :element-size vm:catch-block-size)
diff --git a/general-info/release-19d.txt b/general-info/release-19d.txt
index b357d6788ed7c7cb49787a00287f8ebf4a8b67c9..8e674d046840c9f33dfa6b2bcbd8499078242409 100644
--- a/general-info/release-19d.txt
+++ b/general-info/release-19d.txt
@@ -52,6 +52,56 @@ New in this release:
       - When a core file is started, any shared libraries that were
         loaded when the core was made will be reloaded on startup.  If
         the library cannot be found, several restarts are available.
+      - Support for the new float type EXT:DOUBLE-DOUBLE-FLOAT.  This
+        includes support for complex numbers with this component type
+        and simple arrays for this type and complex numbers of this
+        type.
+
+        A DOUBLE-DOUBLE-FLOAT uses two DOUBLE-FLOAT's to represent a
+        number with >= 106 bits of precision (about 33 digits).  Known
+        issues:
+
+	* If you are expecting IEEE-style behavior, you don't get it:
+	  - signed zeroes aren't really available.  
+	  - overflows don't return infinity but return NaN instead.
+	  - rounding might not be quite the same as IEEE
+	  - SQRT is not accurate to the last bit, as required by IEEE.
+	* Multiplying by a number very close to
+	  most-positive-double-float will produce an error even if the
+	  result does not overflow.  (This is an artifact of how
+	  multiplication is done.  I don't have a solution to this.)
+	* Read/write consistency is not working.  (Because conversion
+	  from a bignum to a double-double-float doesn't really
+	  understand the internal double-double-float format.)
+	* INTEGER-DECODE-FLOAT and SCALE-FLOAT aren't "inverses".
+	  That is, you can't take the result of integer-decode-float
+	  and use scale-float to produce exactly the same number.
+	  This is because of how bignums are converted to
+	  double-doubles.
+	* FLOAT-DIGITS always returns 106 even though there could be
+	  more bits.  (Consider the double-double (1d0,1d-200)).  This
+	  will show up in PRINT where the printed result will have way
+	  more than the normal 33 digits or so.  But reading such a
+	  number back won't give the same value.
+	* There is probably more consing than is necessary in many of
+	  the standard Common Lisp functions like floor, ffloor, etc.
+	* The special functions are not fully tested.  I did a few
+	  random spot checks for each function and compared the
+	  results with maxima to verify them.
+	* The branch cuts for the special functions very likely will
+	  not match the double-float versions, mostly because we don't
+	  have working signed zeroes.
+	* Type derivation for double-double-floats might not be
+	  working quite right.
+	* PI is still a double-float.  If you want a double-double
+	  version of pi, it's KERNEL:DD-PI.  (Soon to be EXT:DD-PI.)
+	* All double-double operations are inlined by default (unless
+	  *INLINE-EXPANSION-LIMIT* is reached), so functions will tend
+	  to be very large.  (Each basic double-double operation takes
+	  some 20 FP instructions).
+	* There are probably still many bugs where double-double-float
+	  support was overlooked.
+
 
   * Numerous ANSI compliance fixes:
 
diff --git a/lisp/gencgc.c b/lisp/gencgc.c
index fe05365f1ce25a19ea125ad859d3d3358be4044d..67e39115bfd49cf68b1941b9d083ff9a948190ff 100644
--- a/lisp/gencgc.c
+++ b/lisp/gencgc.c
@@ -7,7 +7,7 @@
  *
  * Douglas Crosher, 1996, 1997, 1998, 1999.
  *
- * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/gencgc.c,v 1.70 2006/02/04 03:32:31 rtoy Exp $
+ * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/gencgc.c,v 1.71 2006/06/30 18:41:32 rtoy Exp $
  *
  */
 
@@ -4234,6 +4234,35 @@ trans_vector_long_float(lispobj object)
 }
 #endif
 
+#ifdef type_SimpleArrayDoubleDoubleFloat
+static int
+size_vector_double_double_float(lispobj * where)
+{
+    struct vector *vector;
+    int length, nwords;
+
+    vector = (struct vector *) where;
+    length = fixnum_value(vector->length);
+    nwords = CEILING(length * 4 + 2, 2);
+
+    return nwords;
+}
+
+static int
+scav_vector_double_double_float(lispobj * where, lispobj object)
+{
+    return size_vector_double_double_float(where);
+}
+
+static lispobj
+trans_vector_double_double_float(lispobj object)
+{
+    gc_assert(Pointerp(object));
+    return copy_large_unboxed_object(object,
+				     size_vector_double_double_float((lispobj *)
+							    PTR(object)));
+}
+#endif
 
 #ifdef type_SimpleArrayComplexSingleFloat
 static int
@@ -4341,6 +4370,38 @@ trans_vector_complex_long_float(lispobj object)
 								    (object)));
 }
 #endif
+
+#ifdef type_SimpleArrayComplexDoubleDoubleFloat
+static int
+size_vector_complex_double_double_float(lispobj * where)
+{
+    struct vector *vector;
+    int length, nwords;
+
+    vector = (struct vector *) where;
+    length = fixnum_value(vector->length);
+    nwords = length * 8 + 2;
+
+    return nwords;
+}
+
+static int
+scav_vector_complex_double_double_float(lispobj * where, lispobj object)
+{
+    return size_vector_complex_double_double_float(where);
+}
+
+static lispobj
+trans_vector_complex_double_double_float(lispobj object)
+{
+    gc_assert(Pointerp(object));
+    return copy_large_unboxed_object(object,
+				     size_vector_complex_double_double_float((lispobj *)
+									     PTR
+									     (object)));
+}
+#endif
+
 
 
 /* Weak Pointers */
@@ -4523,6 +4584,9 @@ gc_init_tables(void)
 #ifdef type_LongFloat
     scavtab[type_LongFloat] = scav_unboxed;
 #endif
+#ifdef type_DoubleDoubleFloat
+    scavtab[type_DoubleDoubleFloat] = scav_unboxed;
+#endif    
     scavtab[type_Complex] = scav_boxed;
 #ifdef type_ComplexSingleFloat
     scavtab[type_ComplexSingleFloat] = scav_unboxed;
@@ -4532,6 +4596,9 @@ gc_init_tables(void)
 #endif
 #ifdef type_ComplexLongFloat
     scavtab[type_ComplexLongFloat] = scav_unboxed;
+#endif
+#ifdef type_ComplexDoubleDoubleFloat
+    scavtab[type_ComplexDoubleDoubleFloat] = scav_unboxed;
 #endif
     scavtab[type_SimpleArray] = scav_boxed;
     scavtab[type_SimpleString] = scav_string;
@@ -4559,6 +4626,9 @@ gc_init_tables(void)
 #ifdef type_SimpleArrayLongFloat
     scavtab[type_SimpleArrayLongFloat] = scav_vector_long_float;
 #endif
+#ifdef type_SimpleArrayDoubleDoubleFloat
+    scavtab[type_SimpleArrayDoubleDoubleFloat] = scav_vector_double_double_float;
+#endif    
 #ifdef type_SimpleArrayComplexSingleFloat
     scavtab[type_SimpleArrayComplexSingleFloat] =
 	scav_vector_complex_single_float;
@@ -4569,6 +4639,10 @@ gc_init_tables(void)
 #endif
 #ifdef type_SimpleArrayComplexLongFloat
     scavtab[type_SimpleArrayComplexLongFloat] = scav_vector_complex_long_float;
+#endif
+#ifdef type_SimpleArrayComplexDoubleDoubleFloat
+    scavtab[type_SimpleArrayComplexDoubleDoubleFloat] =
+	scav_vector_complex_double_double_float;
 #endif
     scavtab[type_ComplexString] = scav_boxed;
     scavtab[type_ComplexBitVector] = scav_boxed;
@@ -4585,13 +4659,17 @@ gc_init_tables(void)
     scavtab[type_FuncallableInstanceHeader] = scav_closure_header;
     scavtab[type_ByteCodeFunction] = scav_closure_header;
     scavtab[type_ByteCodeClosure] = scav_closure_header;
+#ifdef type_DylanFunctionHeader
     scavtab[type_DylanFunctionHeader] = scav_closure_header;
+#endif
 #else
     scavtab[type_ClosureHeader] = scav_boxed;
     scavtab[type_FuncallableInstanceHeader] = scav_boxed;
     scavtab[type_ByteCodeFunction] = scav_boxed;
     scavtab[type_ByteCodeClosure] = scav_boxed;
+#ifdef type_DylanFunctionHeader
     scavtab[type_DylanFunctionHeader] = scav_boxed;
+#endif
 #endif
     scavtab[type_ValueCellHeader] = scav_boxed;
     scavtab[type_SymbolHeader] = scav_boxed;
@@ -4622,6 +4700,9 @@ gc_init_tables(void)
     transother[type_DoubleFloat] = trans_unboxed;
 #ifdef type_LongFloat
     transother[type_LongFloat] = trans_unboxed;
+#endif
+#ifdef type_DoubleDoubleFloat
+    transother[type_DoubleDoubleFloat] = trans_unboxed;
 #endif
     transother[type_Complex] = trans_boxed;
 #ifdef type_ComplexSingleFloat
@@ -4632,6 +4713,9 @@ gc_init_tables(void)
 #endif
 #ifdef type_ComplexLongFloat
     transother[type_ComplexLongFloat] = trans_unboxed;
+#endif
+#ifdef type_ComplexDoubleDoubleFloat
+    transother[type_ComplexDoubleDoubleFloat] = trans_unboxed;
 #endif
     transother[type_SimpleArray] = trans_boxed_large;
     transother[type_SimpleString] = trans_string;
@@ -4659,6 +4743,9 @@ gc_init_tables(void)
 #ifdef type_SimpleArrayLongFloat
     transother[type_SimpleArrayLongFloat] = trans_vector_long_float;
 #endif
+#ifdef type_SimpleArrayDoubleDoubleFloat
+    transother[type_SimpleArrayDoubleDoubleFloat] = trans_vector_double_double_float;
+#endif
 #ifdef type_SimpleArrayComplexSingleFloat
     transother[type_SimpleArrayComplexSingleFloat] =
 	trans_vector_complex_single_float;
@@ -4670,6 +4757,10 @@ gc_init_tables(void)
 #ifdef type_SimpleArrayComplexLongFloat
     transother[type_SimpleArrayComplexLongFloat] =
 	trans_vector_complex_long_float;
+#endif
+#ifdef type_SimpleArrayComplexDoubleDoubleFloat
+    transother[type_SimpleArrayComplexDoubleDoubleFloat] =
+	trans_vector_complex_double_double_float;
 #endif
     transother[type_ComplexString] = trans_boxed;
     transother[type_ComplexBitVector] = trans_boxed;
@@ -4715,6 +4806,9 @@ gc_init_tables(void)
     sizetab[type_DoubleFloat] = size_unboxed;
 #ifdef type_LongFloat
     sizetab[type_LongFloat] = size_unboxed;
+#endif
+#ifdef type_DoubleDoubleFloat
+    sizetab[type_DoubleDoubleFloat] = size_unboxed;
 #endif
     sizetab[type_Complex] = size_boxed;
 #ifdef type_ComplexSingleFloat
@@ -4725,6 +4819,9 @@ gc_init_tables(void)
 #endif
 #ifdef type_ComplexLongFloat
     sizetab[type_ComplexLongFloat] = size_unboxed;
+#endif
+#ifdef type_ComplexDoubleDoubleFloat
+    sizetab[type_ComplexDoubleDoubleFloat] = size_unboxed;
 #endif
     sizetab[type_SimpleArray] = size_boxed;
     sizetab[type_SimpleString] = size_string;
@@ -4752,6 +4849,9 @@ gc_init_tables(void)
 #ifdef type_SimpleArrayLongFloat
     sizetab[type_SimpleArrayLongFloat] = size_vector_long_float;
 #endif
+#ifdef type_SimpleArrayDoubleDoubleFloat
+    sizetab[type_SimpleArrayDoubleDoubleFloat] = size_vector_double_double_float;
+#endif
 #ifdef type_SimpleArrayComplexSingleFloat
     sizetab[type_SimpleArrayComplexSingleFloat] =
 	size_vector_complex_single_float;
@@ -4762,6 +4862,10 @@ gc_init_tables(void)
 #endif
 #ifdef type_SimpleArrayComplexLongFloat
     sizetab[type_SimpleArrayComplexLongFloat] = size_vector_complex_long_float;
+#endif
+#ifdef type_SimpleArrayComplexDoubleDoubleFloat
+    sizetab[type_SimpleArrayComplexDoubleDoubleFloat] =
+	size_vector_complex_double_double_float;
 #endif
     sizetab[type_ComplexString] = size_boxed;
     sizetab[type_ComplexBitVector] = size_boxed;
@@ -4909,7 +5013,9 @@ valid_dynamic_space_pointer(lispobj * pointer)
 	    case type_FuncallableInstanceHeader:
 	    case type_ByteCodeFunction:
 	    case type_ByteCodeClosure:
+#ifdef type_DylanFunctionHeader
 	    case type_DylanFunctionHeader:
+#endif
 		if ((size_t) pointer !=
 		    (size_t) start_addr + type_FunctionPointer) {
 		    return FALSE;
@@ -4962,7 +5068,9 @@ valid_dynamic_space_pointer(lispobj * pointer)
 	    case type_FuncallableInstanceHeader:
 	    case type_ByteCodeFunction:
 	    case type_ByteCodeClosure:
+#ifdef type_DylanFunctionHeader
 	    case type_DylanFunctionHeader:
+#endif
 		return FALSE;
 
 	    case type_InstanceHeader:
@@ -4980,6 +5088,9 @@ valid_dynamic_space_pointer(lispobj * pointer)
 #endif
 #ifdef type_ComplexLongFloat
 	    case type_ComplexLongFloat:
+#endif
+#ifdef type_ComplexDoubleDoubleFloat
+	    case type_ComplexDoubleDoubleFloat:
 #endif
 	    case type_SimpleArray:
 	    case type_ComplexString:
@@ -4995,6 +5106,9 @@ valid_dynamic_space_pointer(lispobj * pointer)
 	    case type_DoubleFloat:
 #ifdef type_LongFloat
 	    case type_LongFloat:
+#endif
+#ifdef type_DoubleDoubleFloat
+	    case type_DoubleDoubleFloat:
 #endif
 	    case type_SimpleString:
 	    case type_SimpleBitVector:
@@ -5020,6 +5134,9 @@ valid_dynamic_space_pointer(lispobj * pointer)
 #ifdef type_SimpleArrayLongFloat
 	    case type_SimpleArrayLongFloat:
 #endif
+#ifdef type_SimpleArrayDoubleDoubleFloat
+	    case type_SimpleArrayDoubleDoubleFloat:
+#endif
 #ifdef type_SimpleArrayComplexSingleFloat
 	    case type_SimpleArrayComplexSingleFloat:
 #endif
@@ -5028,6 +5145,9 @@ valid_dynamic_space_pointer(lispobj * pointer)
 #endif
 #ifdef type_SimpleArrayComplexLongFloat
 	    case type_SimpleArrayComplexLongFloat:
+#endif
+#ifdef type_SimpleArrayComplexDoubleDoubleFloat
+	    case type_SimpleArrayComplexDoubleDoubleFloat:
 #endif
 	    case type_Sap:
 	    case type_WeakPointer:
@@ -5099,6 +5219,9 @@ maybe_adjust_large_object(lispobj * where)
 #ifdef type_SimpleArrayLongFloat
       case type_SimpleArrayLongFloat:
 #endif
+#ifdef type_SimpleArrayDoubleDoubleFloat
+      case type_SimpleArrayDoubleDoubleFloat:
+#endif
 #ifdef type_SimpleArrayComplexSingleFloat
       case type_SimpleArrayComplexSingleFloat:
 #endif
@@ -5107,6 +5230,9 @@ maybe_adjust_large_object(lispobj * where)
 #endif
 #ifdef type_SimpleArrayComplexLongFloat
       case type_SimpleArrayComplexLongFloat:
+#endif
+#ifdef type_SimpleArrayComplexDoubleDoubleFloat
+      case type_SimpleArrayComplexDoubleDoubleFloat:
 #endif
 	  unboxed = TRUE;
 	  break;
@@ -6163,7 +6289,9 @@ verify_space(lispobj * start, size_t words)
 	      case type_FuncallableInstanceHeader:
 	      case type_ByteCodeFunction:
 	      case type_ByteCodeClosure:
+#ifdef type_DylanFunctionHeader
 	      case type_DylanFunctionHeader:
+#endif
 	      case type_ValueCellHeader:
 	      case type_SymbolHeader:
 	      case type_BaseChar:
@@ -6237,6 +6365,9 @@ verify_space(lispobj * start, size_t words)
 #endif
 #ifdef type_ComplexLongFloat
 	      case type_ComplexLongFloat:
+#endif
+#ifdef type_ComplexDoubleDoubleFloat
+	      case type_ComplexDoubleDoubleFloat:
 #endif
 	      case type_SimpleString:
 	      case type_SimpleBitVector:
@@ -6259,6 +6390,9 @@ verify_space(lispobj * start, size_t words)
 #endif
 	      case type_SimpleArraySingleFloat:
 	      case type_SimpleArrayDoubleFloat:
+#ifdef type_SimpleArrayDoubleDoubleFloat
+	      case type_SimpleArrayDoubleDoubleFloat:
+#endif
 #ifdef type_SimpleArrayComplexLongFloat
 	      case type_SimpleArrayLongFloat:
 #endif
@@ -6270,6 +6404,9 @@ verify_space(lispobj * start, size_t words)
 #endif
 #ifdef type_SimpleArrayComplexLongFloat
 	      case type_SimpleArrayComplexLongFloat:
+#endif
+#ifdef type_SimpleArrayComplexDoubleDoubleFloat
+	      case type_SimpleArrayComplexDoubleDoubleFloat:
 #endif
 	      case type_Sap:
 	      case type_WeakPointer:
diff --git a/lisp/print.c b/lisp/print.c
index 8a6d482195e18b3ac589a0a65e067a8a6b970283..0ee2dfc065aa70364cec007a0d3ed4ebdcabde0e 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.20 2005/09/15 18:26:52 rtoy Exp $ */
+/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/print.c,v 1.21 2006/06/30 18:41:32 rtoy Exp $ */
 
 #include <stdio.h>
 #include <string.h>
@@ -40,6 +40,9 @@ char *subtype_Names[] = {
 #ifdef type_LongFloat
     "long float",
 #endif
+#ifdef type_DoubleDoubleFloat
+    "double-double float",
+#endif    
     "complex",
 #ifdef type_ComplexSingleFloat
     "complex single float",
@@ -49,6 +52,9 @@ char *subtype_Names[] = {
 #endif
 #ifdef type_ComplexLongFloat
     "complex long float",
+#endif
+#ifdef type_ComplexDoubleDoubleFloat
+    "complex double-double float",
 #endif
     "simple-array",
     "simple-string",
@@ -76,6 +82,9 @@ char *subtype_Names[] = {
 #ifdef type_SimpleArrayLongFloat
     "(simple-array long-float (*))",
 #endif
+#ifdef type_SimpleArrayDoubleDoubleFloat
+    "(simple-array double-double-float (*))",
+#endif
 #ifdef type_SimpleArrayComplexSingleFloat
     "(simple-array (complex single-float) (*))",
 #endif
@@ -84,6 +93,9 @@ char *subtype_Names[] = {
 #endif
 #ifdef type_SimpleArrayComplexLongFloat
     "(simple-array (complex long-float) (*))",
+#endif
+#ifdef type_SimpleArrayComplexDoubleDoubleFloat
+    "(simple-array (complex double-double-float) (*))",
 #endif
     "complex-string",
     "complex-bit-vector",
@@ -529,6 +541,14 @@ print_otherptr(lispobj obj)
 	      break;
 #endif
 
+#ifdef type_DoubleDoubleFloat
+          case type_DoubleDoubleFloat:
+              NEWLINE;
+              printf("%g %g", ((struct double_double_float *) PTR(obj))->hi,
+                     ((struct double_double_float *) PTR(obj))->lo);
+              break;
+#endif              
+
 #ifdef type_ComplexSingleFloat
 	  case type_ComplexSingleFloat:
 	      NEWLINE;
@@ -556,6 +576,18 @@ print_otherptr(lispobj obj)
 	      break;
 #endif
 
+#ifdef type_ComplexDoubleDoubleFloat
+	  case type_ComplexDoubleDoubleFloat:
+	      NEWLINE;
+	      printf("%g %g", ((struct complex_double_double_float *) PTR(obj))->real_hi,
+                     ((struct complex_double_double_float *) PTR(obj))->real_lo);
+	      NEWLINE;
+	      printf("%g %g", ((struct complex_double_double_float *) PTR(obj))->imag_hi,
+                     ((struct complex_double_double_float *) PTR(obj))->imag_lo);
+	      break;
+#endif
+
+
 	  case type_SimpleString:
 	      NEWLINE;
 	      cptr = (char *) (ptr + 1);
@@ -610,6 +642,9 @@ print_otherptr(lispobj obj)
 #ifdef type_SimpleArrayLongFloat
 	  case type_SimpleArrayLongFloat:
 #endif
+#ifdef type_SimpleArrayDoubleDoubleFloat
+	  case type_SimpleArrayDoubleDoubleFloat:
+#endif
 #ifdef type_SimpleArrayComplexSingleFloat
 	  case type_SimpleArrayComplexSingleFloat:
 #endif
@@ -618,6 +653,9 @@ print_otherptr(lispobj obj)
 #endif
 #ifdef type_SimpleArrayComplexLongFloat
 	  case type_SimpleArrayComplexLongFloat:
+#endif
+#ifdef type_SimpleArrayComplexDoubleDoubleFloat
+	  case type_SimpleArrayComplexDoubleDoubleFloat:
 #endif
 	  case type_ComplexString:
 	  case type_ComplexBitVector:
diff --git a/lisp/purify.c b/lisp/purify.c
index f18237a9cc087e5f7e4f0b51b001c3bbb18927ab..3180cfcad5e9269acf3f97fe01f8af0c9ddf671d 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.36 2006/01/18 15:21:26 rtoy Exp $ 
+   $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/purify.c,v 1.37 2006/06/30 18:41:32 rtoy Exp $ 
 
    */
 #include <stdio.h>
@@ -143,6 +143,9 @@ maybe_can_move_p(lispobj thing)
 	      case type_DoubleFloat:
 #ifdef type_LongFloat
 	      case type_LongFloat:
+#endif
+#ifdef type_DoubleDoubleFloat
+	      case type_DoubleDoubleFloat:
 #endif
 	      case type_Sap:
 	      case type_SimpleVector:
@@ -170,6 +173,9 @@ maybe_can_move_p(lispobj thing)
 #ifdef type_SimpleArrayLongFloat
 	      case type_SimpleArrayLongFloat:
 #endif
+#ifdef type_SimpleArrayDoubleDoubleFloat
+	      case type_SimpleArrayDoubleDoubleFloat:
+#endif
 #ifdef type_SimpleArrayComplexSingleFloat
 	      case type_SimpleArrayComplexSingleFloat:
 #endif
@@ -178,6 +184,9 @@ maybe_can_move_p(lispobj thing)
 #endif
 #ifdef type_SimpleArrayComplexLongFloat
 	      case type_SimpleArrayComplexLongFloat:
+#endif
+#ifdef type_SimpleArrayComplexDoubleDoubleFloat
+	      case type_SimpleArrayComplexDoubleDoubleFloat:
 #endif
 	      case type_CodeHeader:
 	      case type_FunctionHeader:
@@ -189,7 +198,9 @@ maybe_can_move_p(lispobj thing)
 	      case type_ValueCellHeader:
 	      case type_ByteCodeFunction:
 	      case type_ByteCodeClosure:
+#ifdef type_DylanFunctionHeader
 	      case type_DylanFunctionHeader:
+#endif
 	      case type_WeakPointer:
 	      case type_Fdefn:
 #ifdef type_ScavengerHook
@@ -265,7 +276,9 @@ valid_dynamic_space_pointer(lispobj * pointer, lispobj * start_addr)
 	    case type_FuncallableInstanceHeader:
 	    case type_ByteCodeFunction:
 	    case type_ByteCodeClosure:
+#ifdef type_DylanFunctionHeader
 	    case type_DylanFunctionHeader:
+#endif
 		if ((int) pointer != ((int) start_addr + type_FunctionPointer)) {
 		    if (pointer_filter_verbose)
 			fprintf(stderr, "*Wf2: %p %p %lx\n", pointer,
@@ -344,7 +357,9 @@ valid_dynamic_space_pointer(lispobj * pointer, lispobj * start_addr)
 	    case type_FuncallableInstanceHeader:
 	    case type_ByteCodeFunction:
 	    case type_ByteCodeClosure:
+#ifdef type_DylanFunctionHeader
 	    case type_DylanFunctionHeader:
+#endif
 		if (pointer_filter_verbose)
 		    fprintf(stderr, "*Wo4: %p %p %lx\n", pointer, start_addr,
 			    *start_addr);
@@ -368,6 +383,9 @@ valid_dynamic_space_pointer(lispobj * pointer, lispobj * start_addr)
 #endif
 #ifdef type_ComplexLongFloat
 	    case type_ComplexLongFloat:
+#endif
+#ifdef type_ComplexDoubleDoubleFloat
+	    case type_ComplexDoubleDoubleFloat:
 #endif
 	    case type_SimpleArray:
 	    case type_ComplexString:
@@ -383,6 +401,9 @@ valid_dynamic_space_pointer(lispobj * pointer, lispobj * start_addr)
 	    case type_DoubleFloat:
 #ifdef type_LongFloat
 	    case type_LongFloat:
+#endif
+#ifdef type_DoubleDoubleFloat
+	    case type_DoubleDoubleFloat:
 #endif
 	    case type_SimpleString:
 	    case type_SimpleBitVector:
@@ -408,6 +429,9 @@ valid_dynamic_space_pointer(lispobj * pointer, lispobj * start_addr)
 #ifdef type_SimpleArrayLongFloat
 	    case type_SimpleArrayLongFloat:
 #endif
+#ifdef type_SimpleArrayDoubleDoubleFloat
+	    case type_SimpleArrayDoubleDoubleFloat:
+#endif
 #ifdef type_SimpleArrayComplexSingleFloat
 	    case type_SimpleArrayComplexSingleFloat:
 #endif
@@ -416,6 +440,9 @@ valid_dynamic_space_pointer(lispobj * pointer, lispobj * start_addr)
 #endif
 #ifdef type_SimpleArrayComplexLongFloat
 	    case type_SimpleArrayComplexLongFloat:
+#endif
+#ifdef type_SimpleArrayComplexDoubleDoubleFloat
+	    case type_SimpleArrayComplexDoubleDoubleFloat:
 #endif
 	    case type_Sap:
 	    case type_WeakPointer:
@@ -1025,6 +1052,9 @@ ptrans_otherptr(lispobj thing, lispobj header, boolean constant)
 #ifdef type_LongFloat
       case type_LongFloat:
 #endif
+#ifdef type_DoubleDoubleFloat
+      case type_DoubleDoubleFloat:
+#endif
 #ifdef type_ComplexSingleFloat
       case type_ComplexSingleFloat:
 #endif
@@ -1033,6 +1063,9 @@ ptrans_otherptr(lispobj thing, lispobj header, boolean constant)
 #endif
 #ifdef type_ComplexLongFloat
       case type_ComplexLongFloat:
+#endif
+#ifdef type_ComplexDoubleDoubleFloat
+      case type_ComplexDoubleDoubleFloat:
 #endif
       case type_Sap:
 	  return ptrans_unboxed(thing, header);
@@ -1111,6 +1144,11 @@ ptrans_otherptr(lispobj thing, lispobj header, boolean constant)
 #endif
 #endif
 
+#ifdef type_SimpleArrayDoubleDoubleFloat
+    case type_SimpleArrayDoubleDoubleFloat:
+      return ptrans_vector(thing, 128, 0, FALSE, constant);
+#endif
+      
 #ifdef type_SimpleArrayComplexSingleFloat
       case type_SimpleArrayComplexSingleFloat:
 	  return ptrans_vector(thing, 64, 0, FALSE, constant);
@@ -1131,6 +1169,12 @@ ptrans_otherptr(lispobj thing, lispobj header, boolean constant)
 #endif
 #endif
 
+#ifdef type_SimpleArrayComplexDoubleDoubleFloat
+      case type_SimpleArrayComplexDoubleDoubleFloat:
+	  return ptrans_vector(thing, 256, 0, FALSE, constant);
+#endif
+
+          
       case type_CodeHeader:
 	  return ptrans_code(thing);
 
@@ -1293,6 +1337,9 @@ pscav(lispobj * addr, int nwords, boolean constant)
 	      case type_DoubleFloat:
 #ifdef type_LongFloat
 	      case type_LongFloat:
+#endif
+#ifdef type_DoubleDoubleFloat
+	      case type_DoubleDoubleFloat:
 #endif
 	      case type_Sap:
 		  /* It's an unboxed simple object. */
@@ -1459,6 +1506,13 @@ pscav(lispobj * addr, int nwords, boolean constant)
 		  break;
 #endif
 
+#ifdef type_SimpleArrayComplexDoubleDoubleFloat
+	      case type_SimpleArrayComplexDoubleDoubleFloat:
+		  vector = (struct vector *) addr;
+		  count = fixnum_value(vector->length) * 8 + 2;
+		  break;
+#endif
+
 	      case type_CodeHeader:
 #if !(defined(i386) || defined(__x86_64))
 		  gc_abort();	/* No code headers in static space */
@@ -1483,7 +1537,9 @@ pscav(lispobj * addr, int nwords, boolean constant)
 	      case type_FuncallableInstanceHeader:
 	      case type_ByteCodeFunction:
 	      case type_ByteCodeClosure:
+#ifdef type_DylanFunctionHeader
 	      case type_DylanFunctionHeader:
+#endif
 		  /* The function self pointer needs special care on the
 		     x86 because it is the real entry point. */
 		  {
diff --git a/tools/worldbuild.lisp b/tools/worldbuild.lisp
index d266dd85abbd4477284b87f95875b9c66c106705..1dd398197e9232f79b7157cf8ae508b2c12d5da7 100644
--- a/tools/worldbuild.lisp
+++ b/tools/worldbuild.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldbuild.lisp,v 1.52 2004/07/25 18:29:10 pmai Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldbuild.lisp,v 1.53 2006/06/30 18:41:32 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -102,6 +102,8 @@
     "target:code/float"
     "target:code/float-trap"
     "target:code/irrat"
+    ,@(when (c::backend-featurep :double-double)
+	'("target:code/irrat-dd"))
     "target:code/bignum"
     "target:code/list"
     "target:code/hash-new"
diff --git a/tools/worldcom.lisp b/tools/worldcom.lisp
index 3b99f8d1c9948df394ee7bac27e9e04353a821ba..7547ba6e3f9ac43a1233d64de2075cc85dc5f748 100644
--- a/tools/worldcom.lisp
+++ b/tools/worldcom.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldcom.lisp,v 1.96 2005/09/08 20:49:57 cshapiro Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldcom.lisp,v 1.97 2006/06/30 18:41:32 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -201,6 +201,8 @@
 (comf "target:code/float-trap")
 (comf "target:code/float")
 (comf "target:code/irrat")
+#+double-double
+(comf "target:code/irrat-dd")
 
 (comf "target:code/type-boot")