Raymond Toy pushed to branch issue-480-double-double-hex-printer at cmucl / cmucl Commits: 9d53bbb2 by Raymond Toy at 2026-03-09T14:10:11-07:00 Update release notes - - - - - 92a4957d by Raymond Toy at 2026-03-09T14:24:18-07:00 Indent code a bit more nicely. - - - - - ab72763a by Raymond Toy at 2026-03-09T14:34:32-07:00 read-hex-float accepts start and end keywords for strings If the arg is a string, the start and end keywords are used to delimit the string. These are ignored when reading from a stream. - - - - - b0607b83 by Raymond Toy at 2026-03-09T14:35:54-07:00 Update and reorder tests Put all the new tests at the beginning. The original tests are at the end. - - - - - a496d3ff by Raymond Toy at 2026-03-09T14:36:36-07:00 Update cmucl.pot for new/changed docstrings - - - - - 52894670 by Raymond Toy at 2026-03-09T14:39:14-07:00 Remove duplicate tests The following old tests have been removed: o test-hex-syntax o test-negative-zero o test-subnormal-boundaries These basically duplicate existing tests. - - - - - 4 changed files: - src/code/ext-code.lisp - src/general-info/release-22a.md - src/i18n/locale/cmucl.pot - tests/extensions.lisp Changes: ===================================== src/code/ext-code.lisp ===================================== @@ -47,15 +47,18 @@ (cond ((float-nan-p x) (write-string "0x0.0p+nan" stream) - (when suffix-char (write-char suffix-char stream))) + (when suffix-char + (write-char suffix-char stream))) ((float-infinity-p x) (write-string "0x1.0p+inf" stream) - (when suffix-char (write-char suffix-char stream))) + (when suffix-char + (write-char suffix-char stream))) ((zerop x) (write-string "0x0p+0" stream) - (when suffix-char (write-char suffix-char stream))) + (when suffix-char + (write-char suffix-char stream))) (t (multiple-value-bind (significand exponent sign) @@ -75,14 +78,15 @@ (frac-str (trim-trailing-zeros (format nil "~v,'0X" hex-digits frac)))) (write-string "0x" stream) - (write-char (if denormalp #\0 #\1) stream) + (write-char (if denormalp #\0 #\1) + stream) (unless (zerop (length frac-str)) (write-char #\. stream) (write-string frac-str stream)) (write-char #\p stream) (when (>= out-exp 0) (write-char #\+ stream)) - (write-string (format nil "~D" out-exp) stream) + (format stream "~D" out-exp) (when suffix-char (write-char suffix-char stream))))))) (values))) @@ -141,7 +145,7 @@ (write-char #\p stream) (when (>= out-exp 0) (write-char #\+ stream)) - (write-string (format nil "~D" out-exp) stream) + (format stream "~D" out-exp) (write-char #\w stream)))))) (values))) @@ -185,9 +189,9 @@ ;;; Function that can be used in a FORMAT ~/ (defun format-hex-float (stream x colonp atsignp &rest args) "Format function for use with ~/package:format-hex-float/. - Ignores colon modifier. - At-sign modifier forces a leading + sign on non-negative values. - Example: (format t \"~@/ext:format-hex-float/\" 3.0d0) => +0x1.8p+1" + Ignores colon modifier. At-sign modifier forces a leading + sign on + non-negative values. Example: (format t \"~@/ext:format-hex-float/\" + 3.0d0) => +0x1.8p+1" (declare (ignore colonp args)) (when (and atsignp (not (float-nan-p x)) @@ -203,20 +207,20 @@ ((input :initarg :input :reader hex-float-parse-error-input) (position :initarg :position :reader hex-float-parse-error-position) (message :initarg :message :reader hex-float-parse-error-message)) - (:report (lambda (c s) - (format s "Hex float parse error~@[ at position ~D~]: ~A~@[ (input: ~S)~]" - (hex-float-parse-error-position c) - (hex-float-parse-error-message c) - (hex-float-parse-error-input c))))) + (:report #'(lambda (c s) + (format s "Hex float parse error~@[ at position ~D~]: ~A~@[ (input: ~S)~]" + (hex-float-parse-error-position c) + (hex-float-parse-error-message c) + (hex-float-parse-error-input c))))) (defun read-hex-float-from-stream (stream) "Read a C-style hex float from STREAM and return a float value. - Format: [sign] 0x <hex-mantissa> [. <hex-fraction>] p <exp> [f|w] + Format: [sign] 0x <hex-mantissa> [. <hex-fraction>] p <exp> [f|w] 'f' suffix => single-float - 'w' suffix => double-double-float (CMUCL native) - no suffix => double-float - The binary exponent (p or P) is required. - Signals HEX-FLOAT-PARSE-ERROR on malformed input." + 'w' suffix => double-double-float + no suffix => double-float + The binary exponent (p or P) is required. + Signals HEX-FLOAT-PARSE-ERROR on malformed input." (flet ((parse-error (pos msg &rest args) (error 'ext:hex-float-parse-error :position pos @@ -247,8 +251,11 @@ (let ((c (peek-char nil stream nil nil))) (cond ((null c) (parse-error (pos) "Unexpected end of input, expected hex float")) - ((char= c #\-) (setf sign -1) (read-char stream)) - ((char= c #\+) (read-char stream)))) + ((char= c #\-) + (setf sign -1) + (read-char stream)) + ((char= c #\+) + (read-char stream)))) ;; Expect "0" (let ((c (read-char stream nil nil))) @@ -277,7 +284,8 @@ n-frac count) (when (and (zerop count) (peek-char nil stream nil nil) - (not (member (peek-char nil stream nil nil) '(#\p #\P)))) + (not (member (peek-char nil stream nil nil) + '(#\p #\P)))) (parse-error frac-start "Expected hex digits after decimal point"))))) ;; Mantissa must have at least one hex digit total @@ -291,8 +299,11 @@ ;; Exponent sign and digits (let ((exp-sign 1)) - (when (member (peek-char nil stream nil nil) '(#\+ #\-)) - (when (char= (read-char stream) #\-) (setf exp-sign -1))) + (when (member (peek-char nil stream nil nil) + '(#\+ #\-)) + (when (char= (read-char stream) + #\-) + (setf exp-sign -1))) (let ((exp-start (pos))) (multiple-value-bind (value count) (accumulate-digits 10) @@ -303,8 +314,12 @@ ;; Optional suffix: 'f'/'F' => single, 'w'/'W' => double-double, none => double (when (peek-char nil stream nil nil) (let ((c (peek-char nil stream nil nil))) - (cond ((member c '(#\f #\F)) (read-char stream) (setf suffix :single)) - ((member c '(#\w #\W)) (read-char stream) (setf suffix :double-double)) + (cond ((member c '(#\f #\F)) + (read-char stream) + (setf suffix :single)) + ((member c '(#\w #\W)) + (read-char stream) + (setf suffix :double-double)) ((not (or (member c '(#\space #\tab #\newline #\return #\) #\] #\} #\,)) (digit-char-p c 10))) @@ -319,8 +334,8 @@ (scale-float (* sign (float significand 1.0d0)) adjusted-exp)) (:single - (coerce (scale-float (* sign (float significand 1.0d0)) adjusted-exp) - 'single-float)) + (scale-float (* sign (float significand 1.0f0)) + adjusted-exp)) (:double-double (let* ((sig-bits (integer-length significand)) @@ -335,10 +350,9 @@ (defun read-hex-float-from-string (s &key (start 0) end) "Read a C-style hex float from string S. - START and END bound the region to read (default: entire string). - Returns two values: the float and the index of the first character - not consumed. - Signals HEX-FLOAT-PARSE-ERROR on malformed input." + START and END bound the region to read (default: entire string). + Returns two values: the float and the index of the first character + not consumed. Signals HEX-FLOAT-PARSE-ERROR on malformed input." (with-input-from-string (stream s :start start :end end) (values (read-hex-float-from-stream stream) (file-position stream)))) @@ -347,11 +361,15 @@ ;;; READ-HEX-FLOAT -- Public ;;; ;;; Read a C-style hex float number from either a string or a stream. -(defun read-hex-float (obj) - "Read a C-style hex float number from OBJ which is either a string or a stream." - (declare (type (or string stream) obj)) - (etypecase obj - (string - (read-hex-float-from-string obj)) +(defun ext:read-hex-float (stream-or-string &key (start 0) end) + "Read a C-style hex float from STREAM-OR-STRING. + If a string, START and END bound the region to read. When reading + from a string, returns two values: the float and the index of the + first character not consumed. When reading from a stream, returns + one value: the float. Signals HEX-FLOAT-PARSE-ERROR on malformed + input." + (etypecase stream-or-string (stream - (read-hex-float-from-stream obj)))) + (read-hex-float-from-stream stream-or-string)) + (string + (read-hex-float-from-string stream-or-string :start start :end end)))) ===================================== src/general-info/release-22a.md ===================================== @@ -58,6 +58,9 @@ public domain. * #463: `double-double-float` is missing comparison operations between `double-double-float` and `double-float` * #474: Add functions to print and parse C-style hex floats. + * #477: Support reading and writing double-double-float in hex + format. "w" is the suffix used to denote + double-double-floats. * Other changes: * Improvements to the PCL implementation of CLOS: * Changes to building procedure: ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -6096,35 +6096,42 @@ msgstr "" #: src/code/ext-code.lisp msgid "" "Format function for use with ~/package:format-hex-float/.\n" -" Ignores colon modifier.\n" -" At-sign modifier forces a leading + sign on non-negative values.\n" -" Example: (format t \"~@/ext:format-hex-float/\" 3.0d0) => +0x1.8p+1" +" Ignores colon modifier. At-sign modifier forces a leading + sign on\n" +" non-negative values. Example: (format t \"~@/ext:format-hex-float/\"\n" +" 3.0d0) => +0x1.8p+1" +msgstr "" + +#: src/code/ext-code.lisp +msgid "Execution of a form compiled with errors:~% ~S" msgstr "" #: src/code/ext-code.lisp msgid "" "Read a C-style hex float from STREAM and return a float value.\n" -" Format: [sign] 0x <hex-mantissa> [. <hex-fraction>] p <exp> [f|w]\n" +" Format: [sign] 0x <hex-mantissa> [. <hex-fraction>] p <exp> [f|w]\n" " 'f' suffix => single-float\n" -" 'w' suffix => double-double-float (CMUCL native)\n" -" no suffix => double-float\n" -" The binary exponent (p or P) is required.\n" -" Signals HEX-FLOAT-PARSE-ERROR on malformed input." +" 'w' suffix => double-double-float\n" +" no suffix => double-float\n" +" The binary exponent (p or P) is required.\n" +" Signals HEX-FLOAT-PARSE-ERROR on malformed input." msgstr "" #: src/code/ext-code.lisp msgid "" "Read a C-style hex float from string S.\n" -" START and END bound the region to read (default: entire string).\n" -" Returns two values: the float and the index of the first character\n" -" not consumed.\n" -" Signals HEX-FLOAT-PARSE-ERROR on malformed input." +" START and END bound the region to read (default: entire string).\n" +" Returns two values: the float and the index of the first character\n" +" not consumed. Signals HEX-FLOAT-PARSE-ERROR on malformed input." msgstr "" #: src/code/ext-code.lisp msgid "" -"Read a C-style hex float number from OBJ which is either a string or a " -"stream." +"Read a C-style hex float from STREAM-OR-STRING.\n" +" If a string, START and END bound the region to read. When reading\n" +" from a string, returns two values: the float and the index of the\n" +" first character not consumed. When reading from a stream, returns\n" +" one value: the float. Signals HEX-FLOAT-PARSE-ERROR on malformed\n" +" input." msgstr "" #: src/code/commandline.lisp ===================================== tests/extensions.lisp ===================================== @@ -4,12 +4,6 @@ (in-package "EXTENSIONS-TESTS") -(define-test float-to-hex-string - (assert-equal "0x1.8p+1" (ext:float-to-hex-string 3.0d0)) - (assert-equal "0x1.8p+1f" (ext:float-to-hex-string 3.0f0)) - (assert-equal "0x1.8p+1w" (ext:float-to-hex-string 3.0w0)) - (assert-equal "-0x1.8p+1" (ext:float-to-hex-string -3.0d0))) - ;;; ---- write-hex-float / float-to-hex-string tests ------------------------- (define-test write-double-zero @@ -91,150 +85,65 @@ (ext:float-to-hex-string (- 1.0w0 (scale-float 1.0w0 -54))))) - -(defun get-double-bits (val) - (multiple-value-bind (hi lo) (kernel:double-float-bits val) - (logior (ash (ldb (byte 32 0) hi) 32) (ldb (byte 32 0) lo)))) - -(defun get-single-bits (val) - (ldb (byte 32 0) (kernel:single-float-bits val))) - -(define-test test-hex-syntax - (:tag :validation) - (assert-error 'ext:hex-float-parse-error (ext:read-hex-float "inf")) - (assert-error 'ext:hex-float-parse-error (ext:read-hex-float "0x.p+0")) - (assert-error 'ext:hex-float-parse-error (ext:read-hex-float "0x1.0p"))) - -(define-test test-cliff-boundaries - (:tag :precision) - ;; Double Precision (-1022 Cliff) - - (assert-equal #x0010000000000000 - (get-double-bits (ext:read-hex-float "0x1.0000000000000p-1022"))) - (assert-equal #x000fffffffffffff - (get-double-bits (ext:read-hex-float "0x0.fffffffffffffp-1022"))) - (assert-equal #x001f0195cb356b8f - (get-double-bits (ext:read-hex-float "0x1.f0195cb356b8fp-1022"))) - - ;; Single Precision (-126 Cliff) - - (assert-equal #x00800000 - (get-single-bits (ext:read-hex-float "0x1.000000p-126f"))) - (assert-equal #x00400000 - (get-single-bits (ext:read-hex-float "0x0.800000p-126f"))) - (assert-equal #x7f7fffff - (get-single-bits (ext:read-hex-float "0x1.fffffep+127f")))) - -(define-test test-negative-zero - (:tag :edge-cases) - (assert-equal #x8000000000000000 - (get-double-bits (ext:read-hex-float "-0x0.0p+0"))) - (assert-equal #x80000000 - (get-single-bits (ext:read-hex-float "-0x0.0p+0f"))) - (assert-true (typep (ext:read-hex-float "-0x0.0p+0f") - 'single-float))) - -(define-test test-subnormal-boundaries - (:tag :edge) - ;; Test smallest single-float subnormal - (let* ((val (kernel:make-single-float 1)) - (str (ext:float-to-hex-string val)) - (parsed (ext:read-hex-float str))) - (assert-equal (get-single-bits val) (get-single-bits parsed) - val str parsed)) - ;; Test smallest double-float subnormal - (let* ((val (kernel:make-double-float 0 1)) - (str (ext:float-to-hex-string val)) - (parsed (ext:read-hex-float str))) - (assert-equal (get-double-bits val) (get-double-bits parsed) - val str parsed))) - -(define-test test-double-roundtrip - (:tag :stress) - (loop repeat 10000 do - (let* ((hi-bits (random #x100000000)) - (hi (if (logbitp 31 hi-bits) (- hi-bits #x100000000) hi-bits)) - (lo (random #x100000000)) - (val (kernel:make-double-float hi lo))) - (unless (or (ext:float-nan-p val) (ext:float-infinity-p val)) - (let* ((str (ext:float-to-hex-string val)) - (parsed (ext:read-hex-float str))) - (assert-equal (get-double-bits val) - (get-double-bits parsed) - val str parsed)))))) - -(define-test test-single-roundtrip - (:tag :stress) - (loop repeat 10000 do - (let* ((bits-raw (random #x100000000)) - (bits (if (logbitp 31 bits-raw) (- bits-raw #x100000000) bits-raw)) - (val (kernel:make-single-float bits))) - (unless (or (ext:float-nan-p val) (ext:float-infinity-p val)) - (let* ((str (concatenate 'string (ext:float-to-hex-string val) "f")) - (parsed (ext:read-hex-float str))) - (assert-equal (get-single-bits val) - (get-single-bits parsed) - val str parsed)))))) - ;;; ---- read-hex-float tests ------------------------------------------------ (define-test read-double-zero - (assert-true (eql 0.0d0 (ext:read-hex-float "0x0p+0"))) - (assert-true (eql -0.0d0 (ext:read-hex-float "-0x0p+0")))) + (assert-eql 0.0d0 (ext:read-hex-float "0x0p+0")) + (assert-eql -0.0d0 (ext:read-hex-float "-0x0p+0"))) (define-test read-double-values - (assert-true (eql 1.0d0 (ext:read-hex-float "0x1p+0"))) - (assert-true (eql -1.0d0 (ext:read-hex-float "-0x1p+0"))) - (assert-true (eql 2.0d0 (ext:read-hex-float "0x1p+1"))) - (assert-true (eql 0.5d0 (ext:read-hex-float "0x1p-1"))) - (assert-true (eql 3.0d0 (ext:read-hex-float "0x1.8p+1"))) - (assert-true (eql -3.0d0 (ext:read-hex-float "-0x1.8p+1"))) - (assert-true (eql pi (ext:read-hex-float "0x1.921fb54442d18p+1")))) + (assert-eql 1.0d0 (ext:read-hex-float "0x1p+0")) + (assert-eql -1.0d0 (ext:read-hex-float "-0x1p+0")) + (assert-eql 2.0d0 (ext:read-hex-float "0x1p+1")) + (assert-eql 0.5d0 (ext:read-hex-float "0x1p-1")) + (assert-eql 3.0d0 (ext:read-hex-float "0x1.8p+1")) + (assert-eql -3.0d0 (ext:read-hex-float "-0x1.8p+1")) + (assert-eql pi (ext:read-hex-float "0x1.921fb54442d18p+1"))) (define-test read-double-denormals - (assert-true (eql (scale-float 1.0d0 -1023) - (ext:read-hex-float "0x0.8p-1022"))) - (assert-true (eql (scale-float 1.0d0 -1074) - (ext:read-hex-float "0x0.0000000000001p-1022")))) + (assert-eql (scale-float 1.0d0 -1023) + (ext:read-hex-float "0x0.8p-1022")) + (assert-eql (scale-float 1.0d0 -1074) + (ext:read-hex-float "0x0.0000000000001p-1022"))) (define-test read-double-case-insensitive - (assert-true (eql 3.0d0 (ext:read-hex-float "0X1.8P+1"))) - (assert-true (eql 0.5d0 (ext:read-hex-float "0X1P-1")))) + (assert-eql 3.0d0 (ext:read-hex-float "0X1.8P+1")) + (assert-eql 0.5d0 (ext:read-hex-float "0X1P-1"))) (define-test read-single-zero - (assert-true (eql 0.0f0 (ext:read-hex-float "0x0p+0f"))) - (assert-true (eql -0.0f0 (ext:read-hex-float "-0x0p+0f")))) + (assert-eql 0.0f0 (ext:read-hex-float "0x0p+0f")) + (assert-eql -0.0f0 (ext:read-hex-float "-0x0p+0f"))) (define-test read-single-values - (assert-true (eql 1.0f0 (ext:read-hex-float "0x1p+0f"))) - (assert-true (eql -1.0f0 (ext:read-hex-float "-0x1p+0f"))) - (assert-true (eql 2.0f0 (ext:read-hex-float "0x1p+1f"))) - (assert-true (eql 3.0f0 (ext:read-hex-float "0x1.8p+1f"))) - (assert-true (eql (/ 1.0f0 3.0f0) - (ext:read-hex-float "0x1.555556p-2f"))) - (assert-true (eql most-positive-single-float - (ext:read-hex-float "0x1.fffffep+127f"))) - (assert-true (eql (scale-float 1.0f0 -149) - (ext:read-hex-float "0x0.000002p-126f")))) + (assert-eql 1.0f0 (ext:read-hex-float "0x1p+0f")) + (assert-eql -1.0f0 (ext:read-hex-float "-0x1p+0f")) + (assert-eql 2.0f0 (ext:read-hex-float "0x1p+1f")) + (assert-eql 3.0f0 (ext:read-hex-float "0x1.8p+1f")) + (assert-eql (/ 1.0f0 3.0f0) + (ext:read-hex-float "0x1.555556p-2f")) + (assert-eql most-positive-single-float + (ext:read-hex-float "0x1.fffffep+127f")) + (assert-eql (scale-float 1.0f0 -149) + (ext:read-hex-float "0x0.000002p-126f"))) (define-test read-single-case-insensitive - (assert-true (eql 3.0f0 (ext:read-hex-float "0x1.8p+1F")))) + (assert-eql 3.0f0 (ext:read-hex-float "0x1.8p+1F"))) (define-test read-double-double-zero - (assert-true (eql 0.0w0 (ext:read-hex-float "0x0p+0w"))) - (assert-true (eql -0.0w0 (ext:read-hex-float "-0x0p+0w")))) + (assert-eql 0.0w0 (ext:read-hex-float "0x0p+0w")) + (assert-eql -0.0w0 (ext:read-hex-float "-0x0p+0w"))) (define-test read-double-double-values - (assert-true (eql 1.0w0 (ext:read-hex-float "0x1p+0w"))) - (assert-true (eql -1.0w0 (ext:read-hex-float "-0x1p+0w"))) - (assert-true (eql 3.0w0 (ext:read-hex-float "0x1.8p+1w"))) - (assert-true (eql (scale-float 1.0w0 64) - (ext:read-hex-float "0x1p+64w"))) - (assert-true (eql (coerce pi 'ext:double-double-float) - (ext:read-hex-float "0x1.921fb54442d18p+1w")))) + (assert-eql 1.0w0 (ext:read-hex-float "0x1p+0w")) + (assert-eql -1.0w0 (ext:read-hex-float "-0x1p+0w")) + (assert-eql 3.0w0 (ext:read-hex-float "0x1.8p+1w")) + (assert-eql (scale-float 1.0w0 64) + (ext:read-hex-float "0x1p+64w")) + (assert-eql (coerce pi 'ext:double-double-float) + (ext:read-hex-float "0x1.921fb54442d18p+1w"))) (define-test read-double-double-case-insensitive - (assert-true (eql 3.0w0 (ext:read-hex-float "0x1.8p+1W")))) + (assert-eql 3.0w0 (ext:read-hex-float "0x1.8p+1W"))) ;;; ---- round-trip tests ---------------------------------------------------- @@ -246,7 +155,7 @@ (scale-float 1.0d0 -1022) (scale-float 1.0d0 -1074) (/ 1.0d0 3.0d0))) - (assert-true (eql x (ext:read-hex-float (ext:float-to-hex-string x))) x))) + (assert-eql x (ext:read-hex-float (ext:float-to-hex-string x))))) (define-test round-trip-single (dolist (x (list 0.0f0 -0.0f0 1.0f0 -1.0f0 @@ -255,8 +164,7 @@ (scale-float 1.0f0 -126) (scale-float 1.0f0 -149) (/ 1.0f0 3.0f0))) - (assert-true (eql x (ext:read-hex-float (ext:float-to-hex-string x))) - x))) + (assert-eql x (ext:read-hex-float (ext:float-to-hex-string x))))) (define-test round-trip-double-double (dolist (x (list 0.0w0 -0.0w0 1.0w0 -1.0w0 @@ -266,27 +174,27 @@ (- 1.0w0 (scale-float 1.0w0 -54)) ext:most-positive-double-double-float ext:least-positive-double-double-float)) - (assert-true (eql x (ext:read-hex-float (ext:float-to-hex-string x))) x))) + (assert-eql x (ext:read-hex-float (ext:float-to-hex-string x))))) ;;; ---- read-hex-float-from-string tests ------------------------------------ (define-test read-from-string-positions (multiple-value-bind (val pos) - (ext::read-hex-float-from-string "0x1.8p+1") - (assert-true (eql 3.0d0 val)) + (ext:read-hex-float "0x1.8p+1") + (assert-eql 3.0d0 val) (assert-equal 8 pos)) (multiple-value-bind (val pos) - (ext::read-hex-float-from-string "0x1.8p+1f") - (assert-true (eql 3.0f0 val)) + (ext:read-hex-float "0x1.8p+1f") + (assert-eql 3.0f0 val) (assert-equal 9 pos)) (multiple-value-bind (val pos) - (ext::read-hex-float-from-string "xxx0x1.8p+1" :start 3) - (assert-true (eql 3.0d0 val)) + (ext:read-hex-float "xxx0x1.8p+1" :start 3) + (assert-eql 3.0d0 val) (assert-equal 11 pos)) (multiple-value-bind (val pos) - (ext::read-hex-float-from-string "0x1.8p+1 etc") - (assert-true (eql 3.0d0 val)) + (ext:read-hex-float "0x1.8p+1 etc") + (assert-eql 3.0d0 val) (assert-equal 8 pos))) @@ -337,3 +245,58 @@ (assert-error 'ext:hex-float-parse-error (ext:read-hex-float "-"))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun get-double-bits (val) + (multiple-value-bind (hi lo) (kernel:double-float-bits val) + (logior (ash (ldb (byte 32 0) hi) 32) (ldb (byte 32 0) lo)))) + +(defun get-single-bits (val) + (ldb (byte 32 0) (kernel:single-float-bits val))) + +(define-test test-cliff-boundaries + (:tag :precision) + ;; Double Precision (-1022 Cliff) + + (assert-equal #x0010000000000000 + (get-double-bits (ext:read-hex-float "0x1.0000000000000p-1022"))) + (assert-equal #x000fffffffffffff + (get-double-bits (ext:read-hex-float "0x0.fffffffffffffp-1022"))) + (assert-equal #x001f0195cb356b8f + (get-double-bits (ext:read-hex-float "0x1.f0195cb356b8fp-1022"))) + + ;; Single Precision (-126 Cliff) + + (assert-equal #x00800000 + (get-single-bits (ext:read-hex-float "0x1.000000p-126f"))) + (assert-equal #x00400000 + (get-single-bits (ext:read-hex-float "0x0.800000p-126f"))) + (assert-equal #x7f7fffff + (get-single-bits (ext:read-hex-float "0x1.fffffep+127f")))) + +(define-test test-double-roundtrip + (:tag :stress) + (loop repeat 10000 do + (let* ((hi-bits (random #x100000000)) + (hi (if (logbitp 31 hi-bits) (- hi-bits #x100000000) hi-bits)) + (lo (random #x100000000)) + (val (kernel:make-double-float hi lo))) + (unless (or (ext:float-nan-p val) (ext:float-infinity-p val)) + (let* ((str (ext:float-to-hex-string val)) + (parsed (ext:read-hex-float str))) + (assert-equal (get-double-bits val) + (get-double-bits parsed) + val str parsed)))))) + +(define-test test-single-roundtrip + (:tag :stress) + (loop repeat 10000 do + (let* ((bits-raw (random #x100000000)) + (bits (if (logbitp 31 bits-raw) (- bits-raw #x100000000) bits-raw)) + (val (kernel:make-single-float bits))) + (unless (or (ext:float-nan-p val) (ext:float-infinity-p val)) + (let* ((str (concatenate 'string (ext:float-to-hex-string val) "f")) + (parsed (ext:read-hex-float str))) + (assert-equal (get-single-bits val) + (get-single-bits parsed) + val str parsed)))))) + View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/d95ddfb90d55bce73e05175... -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/d95ddfb90d55bce73e05175... You're receiving this email because of your account on gitlab.common-lisp.net.