March 2026 - cmucl-cvs - mailman3.common-lisp.net

[Git][cmucl/cmucl][issue-480-double-double-hex-printer] 2 commits: Add comments to the write-hex-float subroutines
by Raymond Toy (＠rtoy) 10 Mar '26

10 Mar '26

Raymond Toy pushed to branch issue-480-double-double-hex-printer at cmucl / cmucl Commits: b9279317 by Raymond Toy at 2026-03-10T08:15:54-07:00 Add comments to the write-hex-float subroutines Generated by Claude. - - - - - a15d70c5 by Raymond Toy at 2026-03-10T08:26:57-07:00 Write-hex-float was not handling NaN and infinity for double-double Handle NaN and infinity for double-doubles in the same way as done for write-hex-float-double. - - - - - 1 changed file: - src/code/ext-code.lisp Changes: ===================================== src/code/ext-code.lisp ===================================== @@ -35,119 +35,161 @@ ""))) (defun write-hex-float-double (x stream) - "Print a single-float or double-float in hex format onto STREAM." - ;; Float type and mantissa width are derived from the type of X. + "Print a single- or double-float in hex format onto STREAM. + Float type and mantissa width are derived from the type of X." (multiple-value-bind (mantissa-bits suffix-char min-c-exp) (etypecase x - (single-float (values 23 #\f -126)) - (double-float (values 52 nil -1022))) + (single-float (values (1- (float-digits 1f0)) #\f (- vm:single-float-bias))) + (double-float (values (1- (float-digits 1d0)) nil (- vm:double-float-bias)))) + ;; Print the sign, but not for NaN since float-sign is unreliable there. (when (and (not (float-nan-p x)) (minusp (float-sign x))) (write-char #\- stream)) (let ((x (abs x))) (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 + ;; integer-decode-float returns (significand exponent sign) where + ;; x = significand * 2^exponent. The significand has mantissa-bits+1 + ;; bits for normal numbers (including the implicit leading 1 bit) and + ;; fewer for denormals, which CMUCL normalizes so that the significand + ;; always has exactly mantissa-bits+1 bits, adjusting the exponent + ;; accordingly. (multiple-value-bind (significand exponent sign) (integer-decode-float x) (declare (ignore sign)) + ;; c-exp is the C-style binary exponent, i.e. the exponent of the + ;; leading 1 bit. For a normal number with a (mantissa-bits+1)-bit + ;; significand, c-exp = exponent + mantissa-bits. (let* ((c-exp (+ exponent mantissa-bits)) + ;; A number is denormal if its c-exp is below the minimum + ;; normal exponent. We cannot detect this by checking the + ;; significand bit width because CMUCL normalizes denormals. (denormalp (< c-exp min-c-exp)) + ;; We print the fraction in hex, rounding up the number of + ;; mantissa bits to a multiple of 4. (hex-digits (ceiling mantissa-bits 4)) + ;; frac-shift aligns the mantissa-bits fraction bits to the + ;; hex-digits*4 grid. (frac-shift (- (* 4 hex-digits) mantissa-bits)) + ;; For a normal number, mask off the implicit leading 1 bit + ;; to get just the fraction, then shift to align to hex grid. + ;; For a denormal, the leading bit is 0 so there is nothing + ;; to mask; instead shift right to account for the reduced + ;; exponent. (frac (if denormalp (ash significand (+ (- c-exp min-c-exp) frac-shift)) (ash (logand significand (1- (ash 1 mantissa-bits))) frac-shift))) + ;; Denormals are printed with exponent min-c-exp and a + ;; leading 0 digit rather than 1. (out-exp (if denormalp min-c-exp c-exp)) (frac-str (trim-trailing-zeros - (format nil "~v,'0X" hex-digits frac)))) + (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)) + (when (>= out-exp 0) (write-char #\+ stream)) (format stream "~D" out-exp) - (when suffix-char - (write-char suffix-char stream))))))) + (when suffix-char (write-char suffix-char stream))))))) (values))) #+double-double (defun write-hex-float-double-double (x stream) - "Print a double-double-float in hex format onto STREAM." - ;; Reconstructs the full significand from hi and lo components using - ;; exact integer arithmetic before formatting." + "Print a double-double-float in hex format onto STREAM. + Reconstructs the full significand from hi and lo components + using exact integer arithmetic before formatting." (let* ((hi (kernel:double-double-hi x)) - (lo (kernel:double-double-lo x)) - (hi (abs hi))) - (when (minusp (float-sign (kernel:double-double-hi x))) + (lo (kernel:double-double-lo x))) + ;; Print the sign, but not for NaN since float-sign is unreliable there. + (when (and (not (float-nan-p x)) (minusp (float-sign hi))) (write-char #\- stream)) - (cond - ((zerop hi) - (write-string "0x0p+0w" stream)) - (t - (multiple-value-bind (sig-hi exp-hi sign-hi) - (integer-decode-float hi) - (declare (ignore sign-hi)) - (multiple-value-bind (sig-lo exp-lo sign-lo) - (integer-decode-float lo) - (let* ((signed-sig-lo (* sign-lo sig-lo)) - (combined-sig (if (zerop lo) - sig-hi - (+ (ash sig-hi (- exp-hi exp-lo)) - signed-sig-lo))) - (combined-exp (if (zerop lo) exp-hi exp-lo)) - (total-bits (integer-length combined-sig)) - (c-exp (+ combined-exp total-bits -1)) - (min-c-exp -1022) - (denormalp (< c-exp min-c-exp)) - (raw-frac-bits (if (zerop lo) - 52 - (+ (- exp-hi exp-lo) - 52))) - (frac-bits (* 4 (ceiling raw-frac-bits 4))) - (hex-digits (/ frac-bits 4)) - (shift (if denormalp - (+ (- frac-bits (1- total-bits)) - (- c-exp min-c-exp)) - (- frac-bits (1- total-bits)))) - (frac (if denormalp - (ash combined-sig shift) - (logand (ash combined-sig shift) - (1- (ash 1 frac-bits))))) - (out-exp (if denormalp min-c-exp c-exp)) - (frac-str (trim-trailing-zeros - (format nil "~v,'0X" hex-digits frac)))) - (write-string "0x" 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)) - (format stream "~D" out-exp) - (write-char #\w stream)))))) - (values))) + (let ((hi (abs hi))) + (cond + ((float-nan-p x) + (write-string "0x0.0p+nanw" stream)) + + ((float-infinity-p x) + (write-string "0x1.0p+infw" stream)) + + ((zerop hi) + (write-string "0x0p+0w" stream)) + + (t + (multiple-value-bind (sig-hi exp-hi sign-hi) + (integer-decode-float hi) + (declare (ignore sign-hi)) + (multiple-value-bind (sig-lo exp-lo sign-lo) + (integer-decode-float lo) + (let* ((double-mant-bits (1- (float-digits 1d0))) + (min-c-exp (- vm:double-float-bias)) + ;; Preserve the sign of lo when combining with hi. + (signed-sig-lo (* sign-lo sig-lo)) + ;; Reconstruct the full integer significand by shifting + ;; sig-hi up to align with sig-lo's exponent, then adding. + ;; If lo is zero there is nothing to add. + (combined-sig (if (zerop lo) + sig-hi + (+ (ash sig-hi (- exp-hi exp-lo)) + signed-sig-lo))) + ;; The combined significand is at the scale of lo's exponent + ;; (or hi's if lo is zero). + (combined-exp (if (zerop lo) exp-hi exp-lo)) + (total-bits (integer-length combined-sig)) + ;; c-exp is the exponent of the leading 1 bit, i.e. the + ;; C-style binary exponent. + (c-exp (+ combined-exp total-bits -1)) + (denormalp (< c-exp min-c-exp)) + ;; The number of fraction bits we need to print spans from + ;; the leading bit of hi down to the last bit of lo. When + ;; lo is zero we only need double-mant-bits fraction bits. + ;; We round up to a multiple of 4 for clean hex output. + (raw-frac-bits (if (zerop lo) + double-mant-bits + (+ (- exp-hi exp-lo) double-mant-bits))) + (frac-bits (* 4 (ceiling raw-frac-bits 4))) + (hex-digits (/ frac-bits 4)) + ;; Shift the combined significand so the fraction bits are + ;; left-aligned in a frac-bits-wide field. For denormals, + ;; adjust the shift to account for the reduced exponent. + (shift (if denormalp + (+ (- frac-bits (1- total-bits)) + (- c-exp min-c-exp)) + (- frac-bits (1- total-bits)))) + ;; For normal numbers mask off the leading 1 bit; for + ;; denormals the leading bit is already 0 so no mask needed. + (frac (if denormalp + (ash combined-sig shift) + (logand (ash combined-sig shift) + (1- (ash 1 frac-bits))))) + (out-exp (if denormalp min-c-exp c-exp)) + (frac-str (trim-trailing-zeros + (format nil "~v,'0X" hex-digits frac)))) + (write-string "0x" 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)) + (format stream "~D" out-exp) + (write-char #\w stream)))))) + (values)))) ;;; WRITE-HEX-FLOAT -- Public ;;; View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/528946709fcb5b5c50458f… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/528946709fcb5b5c50458f… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-480-double-double-hex-printer] 6 commits: Update release notes
by Raymond Toy (＠rtoy) 09 Mar '26

09 Mar '26

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/d95ddfb90d55bce73e0517… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/d95ddfb90d55bce73e0517… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-480-double-double-hex-printer] 2 commits: Update cmucl.pot for new/changed docstrings
by Raymond Toy (＠rtoy) 08 Mar '26

08 Mar '26

Raymond Toy pushed to branch issue-480-double-double-hex-printer at cmucl / cmucl Commits: 38972cfe by Raymond Toy at 2026-03-08T15:01:33-07:00 Update cmucl.pot for new/changed docstrings - - - - - d948a386 by Raymond Toy at 2026-03-08T15:01:41-07:00 Clean up code and tests a bit. - - - - - 3 changed files: - src/code/ext-code.lisp - src/i18n/locale/cmucl.pot - tests/extensions.lisp Changes: ===================================== src/code/ext-code.lisp ===================================== @@ -23,10 +23,6 @@ ;;;; C-style hex float printer and parser -;;; FLOAT-TO-HEX-STRING -- Public -;;; -;;; Return a string representing a single and double-floats in C-style -;;; hex format. (defun trim-trailing-zeros (s) "Remove trailing zero characters from string S, preserving internal zeros." (let ((last-nonzero (position #\0 s :test #'char/= :from-end t))) @@ -35,70 +31,65 @@ ""))) -(defun write-hex-float-double (x stream mantissa-bits type) - "Print a single- or double-float in hex format onto STREAM. - MANTISSA-BITS is 23 for single, 52 for double (excluding implicit leading 1). - X must be the original float of the appropriate type; do not pre-coerce." - (when (and (not (float-nan-p x)) (minusp (float-sign x))) - (write-char #\- stream)) - (let ((x (abs x))) - (cond - ((float-nan-p x) - (write-string "0x0.0p+nan" stream) - (ecase type - (:single (write-char #\f stream)) - (:double (values)))) +(defun write-hex-float-double (x stream) + "Print a single-float or double-float in hex format onto STREAM." + ;; Float type and mantissa width are derived from the type of X. + (multiple-value-bind (mantissa-bits suffix-char min-c-exp) + (etypecase x + (single-float (values 23 #\f -126)) + (double-float (values 52 nil -1022))) + (when (and (not (float-nan-p x)) (minusp (float-sign x))) + (write-char #\- stream)) + (let ((x (abs x))) + (cond + ((float-nan-p x) + (write-string "0x0.0p+nan" stream) + (when suffix-char (write-char suffix-char stream))) - ((float-infinity-p x) - (write-string "0x1.0p+inf" stream) - (ecase type - (:single (write-char #\f stream)) - (:double (values)))) + ((float-infinity-p x) + (write-string "0x1.0p+inf" stream) + (when suffix-char (write-char suffix-char stream))) - ((zerop x) - (write-string "0x0p+0" stream) - (ecase type - (:single (write-char #\f stream)) - (:double (values)))) + ((zerop x) + (write-string "0x0p+0" stream) + (when suffix-char (write-char suffix-char stream))) - (t - (multiple-value-bind (significand exponent sign) - (integer-decode-float x) - (declare (ignore sign)) - (let* ((c-exp (+ exponent mantissa-bits)) - (min-c-exp (ecase type - (:double -1022) - (:single -126))) - (denormalp (< c-exp min-c-exp)) - (hex-digits (ceiling mantissa-bits 4)) - (frac-shift (- (* 4 hex-digits) mantissa-bits)) - (frac (if denormalp - (ash significand - (+ (- c-exp min-c-exp) frac-shift)) - (ash (logand significand - (1- (ash 1 mantissa-bits))) - frac-shift))) - (out-exp (if denormalp min-c-exp c-exp)) - (frac-str (trim-trailing-zeros - (format nil "~v,'0X" hex-digits frac)))) - (write-string "0x" 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) - (ecase type - (:single (write-char #\f stream)) - (:double (values)))))))) - (values)) + (t + (multiple-value-bind (significand exponent sign) + (integer-decode-float x) + (declare (ignore sign)) + (let* ((c-exp (+ exponent mantissa-bits)) + (denormalp (< c-exp min-c-exp)) + (hex-digits (ceiling mantissa-bits 4)) + (frac-shift (- (* 4 hex-digits) mantissa-bits)) + (frac (if denormalp + (ash significand + (+ (- c-exp min-c-exp) frac-shift)) + (ash (logand significand + (1- (ash 1 mantissa-bits))) + frac-shift))) + (out-exp (if denormalp min-c-exp c-exp)) + (frac-str (trim-trailing-zeros + (format nil "~v,'0X" hex-digits frac)))) + (write-string "0x" 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) + (when suffix-char + (write-char suffix-char stream))))))) + (values))) +#+double-double (defun write-hex-float-double-double (x stream) - "Print a double-double-float in hex format onto STREAM. - Reconstructs the full significand from hi and lo components - using exact integer arithmetic before formatting." + "Print a double-double-float in hex format onto STREAM." + ;; Reconstructs the full significand from hi and lo components using + ;; exact integer arithmetic before formatting." (let* ((hi (kernel:double-double-hi x)) (lo (kernel:double-double-lo x)) (hi (abs hi))) @@ -125,7 +116,8 @@ (denormalp (< c-exp min-c-exp)) (raw-frac-bits (if (zerop lo) 52 - (+ (- exp-hi exp-lo) 52))) + (+ (- exp-hi exp-lo) + 52))) (frac-bits (* 4 (ceiling raw-frac-bits 4))) (hex-digits (/ frac-bits 4)) (shift (if denormalp @@ -145,25 +137,16 @@ (write-char #\. stream) (write-string frac-str stream)) (write-char #\p stream) - (when (>= out-exp 0) (write-char #\+ stream)) + (when (>= out-exp 0) + (write-char #\+ stream)) (write-string (format nil "~D" out-exp) stream) (write-char #\w stream)))))) (values))) -(defun write-hex-float (x &optional (stream *standard-output*)) - "Write float X to STREAM in C-style hex format. - STREAM defaults to *standard-output*. - single-float => 0x<mantissa>p<exp>f - double-float => 0x<mantissa>p<exp> - double-double-float => 0x<mantissa>p<exp>w - Negative zero is printed with a leading minus sign." - (let ((*print-case* :downcase)) - (etypecase x - (double-double-float (write-hex-float-double-double x stream)) - (double-float (write-hex-float-double x stream 52 :double)) - (single-float (write-hex-float-double x stream 23 :single)))) - (values)) - +;;; FLOAT-TO-HEX-STRING -- Public +;;; +;;; Return a string representing a single and double-floats in C-style +;;; hex format. (defun float-to-hex-string (x) "Return a string containing the C-style hex float representation of X. single-float => \"0x<mantissa>p<exp>f\" @@ -173,6 +156,30 @@ (write-hex-float x s))) +;;; WRITE-HEX-FLOAT -- Public +;;; +;;; Writes a float value (single, double, or double-double) in hex +;;; format to a stream, defaulting to *standard-output*. +(defun write-hex-float (x &optional (stream *standard-output*)) + "Write float X to STREAM in C-style hex format. STREAM defaults to *standard-output*. + + single-float => 0x<mantissa>p<exp>f + double-float => 0x<mantissa>p<exp> + double-double-float => 0x<mantissa>p<exp>w + + Negative zero is printed with a leading minus sign." + (let ((*print-case* :downcase)) + (etypecase x + (single-float + (write-hex-float-double x stream)) + (double-float + (write-hex-float-double x stream)) + #+double-double + (double-double-float + (write-hex-float-double-double x stream)))) + (values)) + + ;;; FORMAT-HEX-FLOAT -- Public ;;; ;;; Function that can be used in a FORMAT ~/ @@ -180,18 +187,15 @@ "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 \"~@/format-hex-float/\" 3.0d0) => +0x1.8p+1" + Example: (format t \"~@/ext:format-hex-float/\" 3.0d0) => +0x1.8p+1" (declare (ignore colonp args)) (when (and atsignp - (not (float-nan-p (if (typep x 'ext:double-double-float) - (kernel:double-double-hi x) - x))) - (not (minusp (float-sign (if (typep x 'ext:double-double-float) - (kernel:double-double-hi x) - x))))) + (not (float-nan-p x)) + (not (minusp (float-sign x)))) (write-char #\+ stream)) (write-hex-float x stream)) + (define-condition hex-parse-error (parse-error) ((text :initarg :text :reader hex-parse-error-text) (message :initarg :message :reader hex-parse-error-message)) ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -6066,28 +6066,11 @@ msgid "" msgstr "" #: src/code/ext-code.lisp -msgid "" -"Print a single- or double-float in hex format onto STREAM.\n" -" MANTISSA-BITS is 23 for single, 52 for double (excluding implicit " -"leading 1).\n" -" X must be the original float of the appropriate type; do not pre-coerce." -msgstr "" - -#: src/code/ext-code.lisp -msgid "" -"Print a double-double-float in hex format onto STREAM.\n" -" Reconstructs the full significand from hi and lo components\n" -" using exact integer arithmetic before formatting." +msgid "Print a single-float or double-float in hex format onto STREAM." msgstr "" #: src/code/ext-code.lisp -msgid "" -"Write float X to STREAM in C-style hex format.\n" -" STREAM defaults to *standard-output*.\n" -" single-float => 0x<mantissa>p<exp>f\n" -" double-float => 0x<mantissa>p<exp>\n" -" double-double-float => 0x<mantissa>p<exp>w\n" -" Negative zero is printed with a leading minus sign." +msgid "Print a double-double-float in hex format onto STREAM." msgstr "" #: src/code/ext-code.lisp @@ -6098,12 +6081,24 @@ msgid "" " double-double-float => \"0x<mantissa>p<exp>w\"" msgstr "" +#: src/code/ext-code.lisp +msgid "" +"Write float X to STREAM in C-style hex format. STREAM defaults to *standard-" +"output*.\n" +"\n" +" single-float => 0x<mantissa>p<exp>f\n" +" double-float => 0x<mantissa>p<exp>\n" +" double-double-float => 0x<mantissa>p<exp>w\n" +"\n" +" Negative zero is printed with a leading minus sign." +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 \"~@/format-hex-float/\" 3.0d0) => +0x1.8p+1" +" Example: (format t \"~@/ext:format-hex-float/\" 3.0d0) => +0x1.8p+1" msgstr "" #: src/code/ext-code.lisp ===================================== tests/extensions.lisp ===================================== @@ -10,6 +10,8 @@ (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 (assert-equal "0x0p+0" (ext:float-to-hex-string 0.0d0)) (assert-equal "-0x0p+0" (ext:float-to-hex-string -0.0d0))) @@ -19,12 +21,12 @@ (assert-equal "-0x1p+0" (ext:float-to-hex-string -1.0d0))) (define-test write-double-powers-of-two - (assert-equal "0x1p+1" (ext:float-to-hex-string 2.0d0)) - (assert-equal "0x1p-1" (ext:float-to-hex-string 0.5d0)) - (assert-equal "0x1p+52" (ext:float-to-hex-string (expt 2.0d0 52))) - (assert-equal "0x1p-52" (ext:float-to-hex-string (expt 2.0d0 -52))) - (assert-equal "0x1p+1023" (ext:float-to-hex-string (expt 2.0d0 1023))) - (assert-equal "0x1p-1022" (ext:float-to-hex-string (expt 2.0d0 -1022)))) + (assert-equal "0x1p+1" (ext:float-to-hex-string (scale-float 1.0d0 1))) + (assert-equal "0x1p-1" (ext:float-to-hex-string (scale-float 1.0d0 -1))) + (assert-equal "0x1p+52" (ext:float-to-hex-string (scale-float 1.0d0 52))) + (assert-equal "0x1p-52" (ext:float-to-hex-string (scale-float 1.0d0 -52))) + (assert-equal "0x1p+1023" (ext:float-to-hex-string (scale-float 1.0d0 1023))) + (assert-equal "0x1p-1022" (ext:float-to-hex-string (scale-float 1.0d0 -1022)))) (define-test write-double-fractions (assert-equal "0x1.8p+1" (ext:float-to-hex-string 3.0d0)) @@ -33,8 +35,8 @@ (assert-equal "0x1.921fb54442d18p+1" (ext:float-to-hex-string pi))) (define-test write-double-denormals - (assert-equal "0x0.8p-1022" (ext:float-to-hex-string (expt 2.0d0 -1023))) - (assert-equal "0x0.0000000000001p-1022" (ext:float-to-hex-string (expt 2.0d0 -1074)))) + (assert-equal "0x0.8p-1022" (ext:float-to-hex-string (scale-float 1.0d0 -1023))) + (assert-equal "0x0.0000000000001p-1022" (ext:float-to-hex-string (scale-float 1.0d0 -1074)))) (define-test write-double-special (assert-equal "0x1.0p+inf" @@ -58,10 +60,10 @@ (assert-equal "0x1.8p+1f" (ext:float-to-hex-string 3.0f0)) (assert-equal "0x1.555556p-2f" (ext:float-to-hex-string (/ 1.0f0 3.0f0))) (assert-equal "0x1.fffffep+127f" (ext:float-to-hex-string most-positive-single-float)) - (assert-equal "0x1p-126f" (ext:float-to-hex-string (expt 2.0f0 -126)))) + (assert-equal "0x1p-126f" (ext:float-to-hex-string (scale-float 1.0f0 -126)))) (define-test write-single-denormals - (assert-equal "0x0.000002p-126f" (ext:float-to-hex-string (expt 2.0f0 -149)))) + (assert-equal "0x0.000002p-126f" (ext:float-to-hex-string (scale-float 1.0f0 -149)))) (define-test write-single-special (assert-equal "0x1.0p+inff" @@ -82,11 +84,13 @@ (assert-equal "0x1p+0w" (ext:float-to-hex-string 1.0w0)) (assert-equal "-0x1p+0w" (ext:float-to-hex-string -1.0w0)) (assert-equal "0x1.8p+1w" (ext:float-to-hex-string 3.0w0)) - (assert-equal "0x1p+64w" (ext:float-to-hex-string (expt 2.0w0 64))) + (assert-equal "0x1p+64w" (ext:float-to-hex-string (scale-float 1.0w0 64))) (assert-equal "0x1.921fb54442d18p+1w" (ext:float-to-hex-string (coerce pi 'ext:double-double-float))) (assert-equal "0x1.fffffffffffff8p-1w" - (ext:float-to-hex-string (- 1.0w0 (expt 2.0w0 -54))))) + (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) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/9ac58853a31d60a157e02b… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/9ac58853a31d60a157e02b… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-480-double-double-hex-printer
by Raymond Toy (＠rtoy) 08 Mar '26

08 Mar '26

Raymond Toy pushed new branch issue-480-double-double-hex-printer at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-480-double-double-h… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-486-rename-openlibm-functions] 4 commits: Fix #488: Add log2f function from openlibm
by Raymond Toy (＠rtoy) 05 Mar '26

05 Mar '26

Raymond Toy pushed to branch issue-486-rename-openlibm-functions at cmucl / cmucl Commits: 12f6a778 by Raymond Toy at 2026-03-04T14:51:03-08:00 Fix #488: Add log2f function from openlibm - - - - - f103e3fd by Raymond Toy at 2026-03-04T14:51:03-08:00 Merge branch 'issue-488-add-openlibm-log2f' into 'master' Fix #488: Add log2f function from openlibm Closes #488 See merge request cmucl/cmucl!364 - - - - - b96d1d0f by Raymond Toy at 2026-03-04T16:20:53-08:00 Merge branch 'master' into issue-486-rename-openlibm-functions - - - - - 66a5234a by Raymond Toy at 2026-03-04T16:24:32-08:00 Use __ieee754_log2f without it being renamed to log2f Just remove the `#define` for it from math_private.h. Add a comment in irrat.c for why we declarations for the functions. - - - - - 4 changed files: - src/lisp/Config.x86_common - src/lisp/irrat.c - + src/lisp/openlibm/e_log2f.c - src/lisp/openlibm/math_private.h Changes: ===================================== src/lisp/Config.x86_common ===================================== @@ -110,6 +110,7 @@ OPENLIBM_SRCS = \ $(OPENLIBM_DIR)/e_hypotf.c \ $(OPENLIBM_DIR)/e_log10f.c \ $(OPENLIBM_DIR)/e_logf.c \ + $(OPENLIBM_DIR)/e_log2f.c \ $(OPENLIBM_DIR)/e_powf.c \ $(OPENLIBM_DIR)/e_rem_pio2f.c \ $(OPENLIBM_DIR)/e_sinhf.c \ ===================================== src/lisp/irrat.c ===================================== @@ -56,7 +56,10 @@ extern float cr_expm1f(float); extern void cr_sincosf(float, float *, float *); #else #include "openlibm_math.h" - +/* + * Declare the openlibm functions we use. This is needed because we + * changed the names of the openlibm functions. + */ extern float openlibm_asinhf(float); extern float openlibm_atanf(float); extern float openlibm_cosf(float); @@ -78,8 +81,6 @@ extern float __ieee754_log10f(float); extern float __ieee754_sinhf(float); extern float __ieee754_hypotf(float, float); - - #endif ===================================== src/lisp/openlibm/e_log2f.c ===================================== @@ -0,0 +1,85 @@ +/* + * ==================================================== + * Copyright (C) 1993 by Sun Microsystems, Inc. All rights reserved. + * + * Developed at SunPro, a Sun Microsystems, Inc. business. + * Permission to use, copy, modify, and distribute this + * software is freely granted, provided that this notice + * is preserved. + * ==================================================== + */ + +#include "cdefs-compat.h" +//__FBSDID("$FreeBSD: src/lib/msun/src/e_log2f.c,v 1.5 2011/10/15 05:23:28 das Exp $"); + +/* + * Float version of e_log2.c. See the latter for most comments. + */ + +#include <openlibm_math.h> + +#include "math_private.h" +#include "k_logf.h" + +// VBS +#define float_t float + +static const float +two25 = 3.3554432000e+07, /* 0x4c000000 */ +ivln2hi = 1.4428710938e+00, /* 0x3fb8b000 */ +ivln2lo = -1.7605285393e-04; /* 0xb9389ad4 */ + +static const float zero = 0.0; + +OLM_DLLEXPORT float +__ieee754_log2f(float x) +{ + float f,hfsq,hi,lo,r,y; + int32_t i,k,hx; + + GET_FLOAT_WORD(hx,x); + + k=0; + if (hx < 0x00800000) { /* x < 2**-126 */ + if ((hx&0x7fffffff)==0) + return -two25/zero; /* log(+-0)=-inf */ + if (hx<0) return (x-x)/zero; /* log(-#) = NaN */ + k -= 25; x *= two25; /* subnormal number, scale up x */ + GET_FLOAT_WORD(hx,x); + } + if (hx >= 0x7f800000) return x+x; + if (hx == 0x3f800000) + return zero; /* log(1) = +0 */ + k += (hx>>23)-127; + hx &= 0x007fffff; + i = (hx+(0x4afb0d))&0x800000; + SET_FLOAT_WORD(x,hx|(i^0x3f800000)); /* normalize x or x/2 */ + k += (i>>23); + y = (float)k; + f = x - (float)1.0; + hfsq = (float)0.5*f*f; + r = k_log1pf(f); + + /* + * We no longer need to avoid falling into the multi-precision + * calculations due to compiler bugs breaking Dekker's theorem. + * Keep avoiding this as an optimization. See e_log2.c for more + * details (some details are here only because the optimization + * is not yet available in double precision). + * + * Another compiler bug turned up. With gcc on i386, + * (ivln2lo + ivln2hi) would be evaluated in float precision + * despite runtime evaluations using double precision. So we + * must cast one of its terms to float_t. This makes the whole + * expression have type float_t, so return is forced to waste + * time clobbering its extra precision. + */ + if (sizeof(float_t) > sizeof(float)) + return (r - hfsq + f) * ((float_t)ivln2lo + ivln2hi) + y; + + hi = f - hfsq; + GET_FLOAT_WORD(hx,hi); + SET_FLOAT_WORD(hi,hx&0xfffff000); + lo = (f - hi) - hfsq + r; + return (lo+hi)*ivln2lo + lo*ivln2hi + hi*ivln2hi + y; +} ===================================== src/lisp/openlibm/math_private.h ===================================== @@ -334,14 +334,12 @@ extern float __ieee754_coshf(float); #define __ieee754_lgammaf_r lgammaf_r #if 0 #define __ieee754_log10f log10f -#else -extern float __ieee754_log10f(float); -#endif #define __ieee754_log2f log2f -#if 0 #define __ieee754_sinhf sinhf #define __ieee754_hypotf hypotf #else +extern float __ieee754_log10f(float); +extern float __ieee754_log2f(float); extern float __ieee754_sinhf(float); extern float __ieee754_hypotf(float, float); #endif View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/ae5589e335096b04cc9ad2… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/ae5589e335096b04cc9ad2… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Fix #488: Add log2f function from openlibm
by Raymond Toy (＠rtoy) 04 Mar '26

04 Mar '26

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 12f6a778 by Raymond Toy at 2026-03-04T14:51:03-08:00 Fix #488: Add log2f function from openlibm - - - - - f103e3fd by Raymond Toy at 2026-03-04T14:51:03-08:00 Merge branch 'issue-488-add-openlibm-log2f' into 'master' Fix #488: Add log2f function from openlibm Closes #488 See merge request cmucl/cmucl!364 - - - - - 2 changed files: - src/lisp/Config.x86_common - + src/lisp/openlibm/e_log2f.c Changes: ===================================== src/lisp/Config.x86_common ===================================== @@ -110,6 +110,7 @@ OPENLIBM_SRCS = \ $(OPENLIBM_DIR)/e_hypotf.c \ $(OPENLIBM_DIR)/e_log10f.c \ $(OPENLIBM_DIR)/e_logf.c \ + $(OPENLIBM_DIR)/e_log2f.c \ $(OPENLIBM_DIR)/e_powf.c \ $(OPENLIBM_DIR)/e_rem_pio2f.c \ $(OPENLIBM_DIR)/e_sinhf.c \ ===================================== src/lisp/openlibm/e_log2f.c ===================================== @@ -0,0 +1,85 @@ +/* + * ==================================================== + * Copyright (C) 1993 by Sun Microsystems, Inc. All rights reserved. + * + * Developed at SunPro, a Sun Microsystems, Inc. business. + * Permission to use, copy, modify, and distribute this + * software is freely granted, provided that this notice + * is preserved. + * ==================================================== + */ + +#include "cdefs-compat.h" +//__FBSDID("$FreeBSD: src/lib/msun/src/e_log2f.c,v 1.5 2011/10/15 05:23:28 das Exp $"); + +/* + * Float version of e_log2.c. See the latter for most comments. + */ + +#include <openlibm_math.h> + +#include "math_private.h" +#include "k_logf.h" + +// VBS +#define float_t float + +static const float +two25 = 3.3554432000e+07, /* 0x4c000000 */ +ivln2hi = 1.4428710938e+00, /* 0x3fb8b000 */ +ivln2lo = -1.7605285393e-04; /* 0xb9389ad4 */ + +static const float zero = 0.0; + +OLM_DLLEXPORT float +__ieee754_log2f(float x) +{ + float f,hfsq,hi,lo,r,y; + int32_t i,k,hx; + + GET_FLOAT_WORD(hx,x); + + k=0; + if (hx < 0x00800000) { /* x < 2**-126 */ + if ((hx&0x7fffffff)==0) + return -two25/zero; /* log(+-0)=-inf */ + if (hx<0) return (x-x)/zero; /* log(-#) = NaN */ + k -= 25; x *= two25; /* subnormal number, scale up x */ + GET_FLOAT_WORD(hx,x); + } + if (hx >= 0x7f800000) return x+x; + if (hx == 0x3f800000) + return zero; /* log(1) = +0 */ + k += (hx>>23)-127; + hx &= 0x007fffff; + i = (hx+(0x4afb0d))&0x800000; + SET_FLOAT_WORD(x,hx|(i^0x3f800000)); /* normalize x or x/2 */ + k += (i>>23); + y = (float)k; + f = x - (float)1.0; + hfsq = (float)0.5*f*f; + r = k_log1pf(f); + + /* + * We no longer need to avoid falling into the multi-precision + * calculations due to compiler bugs breaking Dekker's theorem. + * Keep avoiding this as an optimization. See e_log2.c for more + * details (some details are here only because the optimization + * is not yet available in double precision). + * + * Another compiler bug turned up. With gcc on i386, + * (ivln2lo + ivln2hi) would be evaluated in float precision + * despite runtime evaluations using double precision. So we + * must cast one of its terms to float_t. This makes the whole + * expression have type float_t, so return is forced to waste + * time clobbering its extra precision. + */ + if (sizeof(float_t) > sizeof(float)) + return (r - hfsq + f) * ((float_t)ivln2lo + ivln2hi) + y; + + hi = f - hfsq; + GET_FLOAT_WORD(hx,hi); + SET_FLOAT_WORD(hi,hx&0xfffff000); + lo = (f - hi) - hfsq + r; + return (lo+hi)*ivln2lo + lo*ivln2hi + hi*ivln2hi + y; +} View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/66c5af5473626dc9395306… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/66c5af5473626dc9395306… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-488-add-openlibm-log2f
by Raymond Toy (＠rtoy) 04 Mar '26

04 Mar '26

Raymond Toy pushed new branch issue-488-add-openlibm-log2f at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-488-add-openlibm-lo… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-486-rename-openlibm-functions] Undo change, restoring core-math for linux
by Raymond Toy (＠rtoy) 04 Mar '26

04 Mar '26

Raymond Toy pushed to branch issue-486-rename-openlibm-functions at cmucl / cmucl Commits: ae5589e3 by Raymond Toy at 2026-03-04T12:40:04-08:00 Undo change, restoring core-math for linux - - - - - 1 changed file: - src/code/linux-os.lisp Changes: ===================================== src/code/linux-os.lisp ===================================== @@ -27,7 +27,6 @@ (register-lisp-runtime-feature :executable) ;; Core-math is used for the special functions providing ;; correctly-rounded numerical results. -#+nil (register-lisp-runtime-feature :core-math) (setq *software-type* "Linux") View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/ae5589e335096b04cc9ad27… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/ae5589e335096b04cc9ad27… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-486-rename-openlibm-functions
by Raymond Toy (＠rtoy) 04 Mar '26

04 Mar '26

Raymond Toy pushed new branch issue-486-rename-openlibm-functions at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-486-rename-openlibm… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-435-add-core-math-lisp-support] Make expf overflow
by Raymond Toy (＠rtoy) 04 Mar '26

04 Mar '26

Raymond Toy pushed to branch issue-435-add-core-math-lisp-support at cmucl / cmucl Commits: a03443c7 by Raymond Toy at 2026-03-04T06:59:11-08:00 Make expf overflow It seems the compiler on Darwin has constant-folded the product of huge*huge to be infinity. Change this so that the compiler doesn't constant-fold it by creating a volatile float to compute the product that will overflow a float. - - - - - 1 changed file: - src/lisp/openlibm/e_expf.c Changes: ===================================== src/lisp/openlibm/e_expf.c ===================================== @@ -58,7 +58,10 @@ __ieee754_expf(float x) return x+x; /* NaN */ if(hx==0x7f800000) return (xsb==0)? x:0.0; /* exp(+-inf)={inf,0} */ - if(x > o_threshold) return huge*huge; /* overflow */ + if(x > o_threshold) { + volatile float fhuge = huge; + return fhuge*fhuge; /* overflow */ + } if(x < u_threshold) return twom100*twom100; /* underflow */ } View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/a03443c70abd7a41c91be30… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/a03443c70abd7a41c91be30… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0