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