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

[Git][cmucl/cmucl][issue-474-print-parse-hex-floats] ETYPECASE.15 is passing now
by Raymond Toy (＠rtoy) 24 Feb '26

24 Feb '26

Raymond Toy pushed to branch issue-474-print-parse-hex-floats at cmucl / cmucl Commits: a72ebe85 by Raymond Toy at 2026-02-24T07:12:44-08:00 ETYPECASE.15 is passing now For some reason ETYPECASE.15 is passing, so use the ansi-test branch cmucl-expected-failures instead of cmucl-expected-failures-etypecase.15. - - - - - 1 changed file: - bin/run-ansi-tests.sh Changes: ===================================== bin/run-ansi-tests.sh ===================================== @@ -36,7 +36,7 @@ shift $((OPTIND - 1)) # Use branch cmucl-expected-failures in general since this branch # generally has the list of expected failures. This is the branch to # use on cmucl master in general. -BRANCH=cmucl-expected-failures-etypecase.15 +BRANCH=cmucl-expected-failures set -x if [ -d ../ansi-test ]; then View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/a72ebe85432251c61a8cc9f… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/a72ebe85432251c61a8cc9f… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-474-print-parse-hex-floats] 3 commits: Revert changes that added extra blank lines at the end
by Raymond Toy (＠rtoy) 24 Feb '26

24 Feb '26

Raymond Toy pushed to branch issue-474-print-parse-hex-floats at cmucl / cmucl Commits: 538acc32 by Raymond Toy at 2026-02-23T19:18:53-05:00 Revert changes that added extra blank lines at the end - - - - - fd6d177f by Raymond Toy at 2026-02-23T19:19:14-05:00 Full remove old version of parse-hex-float. We use ext:parse-hex-float now. - - - - - 02e0f002 by Raymond Toy at 2026-02-23T18:27:46-08:00 Update release notes and cmucl.pot [skip-ci] - - - - - 4 changed files: - src/code/extensions.lisp - src/general-info/release-22a.md - src/i18n/locale/cmucl.pot - tests/float.lisp Changes: ===================================== src/code/extensions.lisp ===================================== @@ -724,7 +724,3 @@ ;; contents. Is there a better way? (when ,dirname (delete-directory ,dirname :recursive t)))))) - - - - ===================================== src/general-info/release-22a.md ===================================== @@ -57,6 +57,7 @@ public domain. * #460: Unit tests were not being recognized as failing on CI. * #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. * Other changes: * Improvements to the PCL implementation of CLOS: * Changes to building procedure: ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -6060,6 +6060,38 @@ msgid "" " afterward." msgstr "" +#: src/code/ext-code.lisp +msgid "" +"Prints a single or double float in bit-perfect C-style hex.\n" +" If AT-P is true, prepends '+' for non-negative finite values." +msgstr "" + +#: src/code/ext-code.lisp +msgid "" +"Convert FLOAT to C-style hex string and write it to STREAM.\n" +" Infinities are printed as \"-inf\" and \"inf\". NaN is printed as\n" +" \"nan\"." +msgstr "" + +#: src/code/ext-code.lisp +msgid "" +"Formatter for ~/ext:format-hex-float/. \n" +" Uses AT-SIGN-P (@) to force the sign. COLON-P (:) is currently ignored." +msgstr "" + +#: src/code/ext-code.lisp +msgid "" +"Reads a C-style hex float number from STREAM. A single-float or\n" +" double-float number is returned. A HEX-PARSE-ERROR is signaled for\n" +" an invalid format." +msgstr "" + +#: src/code/ext-code.lisp +msgid "" +"Parse a C-style hex float number from OBJ which is either a string or a " +"stream." +msgstr "" + #: src/code/commandline.lisp msgid "A list of all the command line arguments after --" msgstr "" ===================================== tests/float.lisp ===================================== @@ -579,27 +579,6 @@ (assert-equal -2w300 (* -2w300 1w0))) - - -;; Rudimentary code to read C %a formatted numbers that look like -;; "-0x1.c4dba4ba1ee79p-620". We assume STRING is exactly in this -;; format. No error-checking is done. -#+nil -(defun ext:parse-hex-float (string) - (let* ((sign (if (char= (aref string 0) #\-) - -1 - 1)) - (dot-posn (position #\. string)) - (p-posn (position #\p string)) - (lead (parse-integer string :start (1- dot-posn) :end dot-posn)) - (frac (parse-integer string :start (1+ dot-posn) :end p-posn :radix 16)) - (exp (parse-integer string :start (1+ p-posn)))) - (* sign - (scale-float (float (+ (ash lead 52) - frac) - 1d0) - (- exp 52))))) - ;; Relative error in terms of bits of accuracy. This is the ;; definition used by Baudin and Smith. A result of 53 means the two ;; numbers have identical bits. For complex numbers, we use the min View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/68e2a5c280e67ce1b4457e… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/68e2a5c280e67ce1b4457e… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-474-print-parse-hex-floats] 3 commits: Refactoring and renaming for final API
by Raymond Toy (＠rtoy) 24 Feb '26

24 Feb '26

Raymond Toy pushed to branch issue-474-print-parse-hex-floats at cmucl / cmucl Commits: 029170e8 by Raymond Toy at 2026-02-23T19:11:09-05:00 Refactoring and renaming for final API Merged the separate single and double hex printer into FLOAT-TO-HEX-STRING. Added WRITE-HEX-FLOAT that writes a float to the given stream, like WRITE-STRING, except for hex floats. FORMAT-HEX-FLOAT simplified to use FLOAT-TO-HEX-STRING. PARSE-HEX-FLOAT converts a hex float number from either a string or a stream. - - - - - 03794011 by Raymond Toy at 2026-02-23T19:14:14-05:00 Update exports for new API - - - - - 68e2a5c2 by Raymond Toy at 2026-02-23T19:14:33-05:00 Update tests to use the new names. - - - - - 3 changed files: - src/code/exports.lisp - src/code/ext-code.lisp - tests/extensions.lisp Changes: ===================================== src/code/exports.lisp ===================================== @@ -1370,7 +1370,8 @@ "REMOVE-PACKAGE-LOCAL-NICKNAME" "PACKAGE-LOCALLY-NICKNAMED-BY-LIST") ;; Printing and parsing of C-style hex floats - (:export "PRINT-HEX-FLOAT" + (:export "FLOAT-TO-HEX-STRING" + "WRITE-HEX-FLOAT" "FORMAT-HEX-FLOAT" "HEX-PARSE-ERROR" "PARSE-HEX-FLOAT")) ===================================== src/code/ext-code.lisp ===================================== @@ -21,100 +21,69 @@ (intl:textdomain "cmucl") -;;; C-style hex float printer and parser -(defun print-hex-single-float (val) - "Prints a single-float in C-style hex format." - (cond ((float-nan-p val) - "nan") - ((float-infinity-p val) - (if (plusp val) "inf" "-inf")) - ((zerop val) - (if (eql val -0.0f0) - "-0x0.0p+0f" "0x0.0p+0f")) - (t - (let* ((bits (ldb (byte 32 0) (kernel:single-float-bits val))) - (sign (ldb (byte 1 31) bits)) - (exp-bits (ldb (byte 8 23) bits)) - (mantissa (ldb (byte 23 0) bits)) - ;; Print lower-case hex digits. - (*print-case* :downcase)) - (if (zerop exp-bits) - ;; Subnormal: Leading digit 0, exponent fixed at -126 - (format nil "~A0x0.~6,'0Xp-126f" - (if (= sign 1) "-" "") - (ash mantissa 1)) ; Align 23 bits to 24 bits (6 hex digits) - ;; Normalized: Leading digit 1, exponent bias 127 - (format nil "~A0x1.~6,'0Xp~Af" - (if (= sign 1) "-" "") - (ash mantissa 1) ; Align 23 bits to 24 bits (6 hex digits) - (- exp-bits 127))))))) - -(defun print-hex-double-float (val) - "Prints a double-float in C-style hex format." - (cond ((float-nan-p val) - "nan") - ((float-infinity-p val) - (if (plusp val) "inf" "-inf")) - ((zerop val) - (if (eql val -0.0d0) - "-0x0.0p+0" "0x0.0p+0")) - (t - (multiple-value-bind (hi-bits lo-bits) - (kernel:double-float-bits val) - (let* ((hi (ldb (byte 32 0) hi-bits)) - (lo (ldb (byte 32 0) lo-bits)) - (sign (ldb (byte 1 31) hi)) - (exp-bits (ldb (byte 11 20) hi)) - ;; Combine 20 bits from high word and 32 bits from low word - (mantissa (logior (ash (ldb (byte 20 0) hi) 32) - lo)) - ;; Print lower-case hex digits. - (*print-case* :downcase)) - (if (zerop exp-bits) - ;; Subnormal: Leading digit 0, exponent fixed at -1022 - (format nil "~A0x0.~13,'0Xp-1022" - (if (= sign 1) "-" "") - mantissa) - ;; Normalized: Leading digit 1, exponent bias 1023 - (format nil "~A0x1.~13,'0Xp~A" - (if (= sign 1) "-" "") - mantissa ; 52 bits fits 13 hex digits perfectly - (- exp-bits 1023)))))))) +;;;; C-style hex float printer and parser -;;; PRINT-HEX-FLOAT -- Public +;;; FLOAT-TO-HEX-STRING -- Public ;;; ;;; Return a string representing a single and double-floats in C-style ;;; hex format. -(defun print-hex-float (float) - "Convert FLOAT to C-style hex string. Infinities are printed as \"-inf\" - and \"inf\". NaN is printed as \"nan\"." +(defun float-to-hex-string (val &optional at-p) + "Prints a single or double float in bit-perfect C-style hex. + If AT-P is true, prepends '+' for non-negative finite values." + (cond ((ext:float-nan-p val) "nan") + ((ext:float-infinity-p val) + (if (plusp val) (if at-p "+inf" "inf") "-inf")) + (t + (multiple-value-bind (sign exp-bits mantissa bias precision suffix) + (typecase val + (single-float + (let ((bits (ldb (byte 32 0) (kernel:single-float-bits val)))) + (values (ldb (byte 1 31) bits) + (ldb (byte 8 23) bits) + (ash (ldb (byte 23 0) bits) 1) ; Align 23 to 6 hex digits + 127 6 "f"))) + (double-float + (multiple-value-bind (hi lo) (kernel:double-float-bits val) + (values (ldb (byte 1 31) hi) + (ldb (byte 11 20) hi) + (logior (ash (ldb (byte 20 0) hi) 32) (ldb (byte 32 0) lo)) + 1023 13 ""))) + (t (error "Unsupported float type: ~S" (type-of val)))) + + (let ((sign-str (cond ((= sign 1) "-") + (at-p "+") + (t "")))) + (if (and (zerop exp-bits) (zerop mantissa)) + (format nil "~A0x0.0p+0~A" sign-str suffix) + (format nil "~A0x~A.~V,'0Xp~A~A" + sign-str + (if (zerop exp-bits) "0" "1") + precision + mantissa + (if (zerop exp-bits) (1+ (- bias)) (- exp-bits bias)) + suffix))))))) + +;;; WRITE-HEX-FLOAT -- Public +;;; +;;; Writes a float number in C-style hex format to the given stream. +(defun write-hex-float (float &optional (stream *standard-output*)) + "Convert FLOAT to C-style hex string and write it to STREAM. + Infinities are printed as \"-inf\" and \"inf\". NaN is printed as + \"nan\"." (declare (float float)) - (etypecase float - (single-float (print-hex-single-float float)) - (double-float (print-hex-double-float float)))) + (write-string (float-to-hex-string float) + stream)) ;;; FORMAT-HEX-FLOAT -- Public ;;; ;;; Function that can be used in a FORMAT ~/ (defun format-hex-float (stream arg colon-p at-sign-p &optional width) "Formatter for ~/ext:format-hex-float/. - @ forces sign (+/-). Colon modifier is ignored as per request." + Uses AT-SIGN-P (@) to force the sign. COLON-P (:) is currently ignored." (declare (ignore width colon-p)) - (let ((str (if (typep arg 'single-float) - (print-hex-single-float arg) - (print-hex-double-float arg)))) - ;; Prepend '+' if @ is used and number isn't negative or special - (when (and at-sign-p - (not (ext:float-nan-p arg)) - (not (ext:float-infinity-p arg)) - (not (char= (char str 0) #\-))) - (write-char #\+ stream)) - (write-string str stream))) + (write-string (float-to-hex-string arg at-sign-p) + stream)) -;;; PARSE-HEX-FLOAT -- Public -;;; -;;; Parse a C-style float hex strings. Always returns a double-float. -;;; Error-checking is enabled for malformed strings. (define-condition hex-parse-error (parse-error) ((text :initarg :text :reader hex-parse-error-text) (message :initarg :message :reader hex-parse-error-message)) @@ -122,68 +91,14 @@ (format s "Hex float parse error in ~S: ~A" (hex-parse-error-text c) (hex-parse-error-message c))))) -#+nil -(defun parse-hex-float (str) - "Parses hex floats using scale-float for the exponent. Strictly hex-literal only." - (let* ((str (string-trim '(#\Space #\Tab #\Newline #\Return) - (string-downcase str))) - (len (length str))) - (when (zerop len) - (error 'hex-parse-error :text str :message "Empty string")) - - (let* ((ends-with-f (and (> len 1) - (char= (char str (1- len)) #\f))) - (effective-len (if ends-with-f - (1- len) len)) - (prototype (if ends-with-f - 1.0f0 1.0d0)) - (has-sign (or (char= (char str 0) #\-) - (char= (char str 0) #\+))) - (sign (if (and has-sign - (char= (char str 0) #\-)) - -1 1)) - (start (if has-sign 1 0))) - - (unless (and (<= (+ start 2) effective-len) - (string= str "0x" :start1 start :end1 (+ start 2))) - (error 'hex-parse-error :text str :message "Missing '0x' prefix")) - - (let ((p-pos (position #\p str :start start :end effective-len))) - (unless p-pos - (error 'hex-parse-error :text str :message "Missing exponent 'p'")) - - (let* ((sig-start (+ start 2)) - (dot-pos (position #\. str :start sig-start :end p-pos)) - (exp-start (1+ p-pos)) - ;; Leading hex: digits before the dot - (leading-str (subseq str sig-start (or dot-pos p-pos))) - ;; Trailing hex: digits after the dot - (trailing-str (if dot-pos (subseq str (1+ dot-pos) p-pos) "")) - (has-digits (or (plusp (length leading-str)) - (plusp (length trailing-str))))) - - (unless has-digits - (error 'hex-parse-error :text str :message "No hex digits in significand")) - - (handler-case - (let* ((leading-int (if (string= leading-str "") 0 - (parse-integer leading-str :radix 16))) - (trailing-len (length trailing-str)) - (trailing-int (if (string= trailing-str "") 0 - (parse-integer trailing-str :radix 16))) - ;; Calculate the significand as a float: leading + (trailing / 16^len) - (significand (float (+ leading-int - (/ trailing-int (expt 16 trailing-len))) - prototype)) - ;; The exponent after 'p' - (raw-exponent (parse-integer str :start exp-start :end effective-len))) - ;; Use scale-float to apply the binary exponent efficiently - (* sign (scale-float significand raw-exponent))) - (error (c) - (error 'hex-parse-error :text str :message (format nil "~A" c))))))))) - +;;; PARSE-HEX-FLOAT-FROM-STREAM -- Public +;;; +;;; Parse a C-style float hex string from a stream. Invalid formats +;;; signal an error. A single-float or double-float may be returned. (defun parse-hex-float-from-stream (stream) - "Reads hex float from stream using double-float accumulation and a 6-character exponent buffer." + "Reads a C-style hex float number from STREAM. A single-float or + double-float number is returned. A HEX-PARSE-ERROR is signaled for + an invalid format." (let* ((sign 1.0d0) (char (peek-char t stream))) ; Skip whitespace @@ -251,6 +166,15 @@ (float result 1.0f0) result))))))) -(defun parse-hex-float (str) - (with-input-from-string (s str) - (parse-hex-float-from-stream s))) +;;; PARSE-HEX-FLOAT -- Public +;;; +;;; Parse a C-style hex float number from either a string or a stream. +(defun parse-hex-float (obj) + "Parse 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 + (with-input-from-string (s obj) + (parse-hex-float-from-stream s))) + (stream + (parse-hex-float-from-stream obj)))) ===================================== tests/extensions.lisp ===================================== @@ -21,34 +21,45 @@ (:tag :precision) ;; Double Precision (-1022 Cliff) - (assert-equal #x0010000000000000 (get-double-bits (ext:parse-hex-float "0x1.0000000000000p-1022"))) - (assert-equal #x000fffffffffffff (get-double-bits (ext:parse-hex-float "0x0.fffffffffffffp-1022"))) - (assert-equal #x001f0195cb356b8f (get-double-bits (ext:parse-hex-float "0x1.f0195cb356b8fp-1022"))) + (assert-equal #x0010000000000000 + (get-double-bits (ext:parse-hex-float "0x1.0000000000000p-1022"))) + (assert-equal #x000fffffffffffff + (get-double-bits (ext:parse-hex-float "0x0.fffffffffffffp-1022"))) + (assert-equal #x001f0195cb356b8f + (get-double-bits (ext:parse-hex-float "0x1.f0195cb356b8fp-1022"))) ;; Single Precision (-126 Cliff) - (assert-equal #x00800000 (get-single-bits (ext:parse-hex-float "0x1.000000p-126f"))) - (assert-equal #x00400000 (get-single-bits (ext:parse-hex-float "0x0.800000p-126f"))) - (assert-equal #x7f7fffff (get-single-bits (ext:parse-hex-float "0x1.fffffep+127f")))) + (assert-equal #x00800000 + (get-single-bits (ext:parse-hex-float "0x1.000000p-126f"))) + (assert-equal #x00400000 + (get-single-bits (ext:parse-hex-float "0x0.800000p-126f"))) + (assert-equal #x7f7fffff + (get-single-bits (ext:parse-hex-float "0x1.fffffep+127f")))) (define-test test-negative-zero (:tag :edge-cases) - (assert-equal #x8000000000000000 (get-double-bits (ext:parse-hex-float "-0x0.0p+0"))) - (assert-equal #x80000000 (get-single-bits (ext:parse-hex-float "-0x0.0p+0f"))) - (assert-true (typep (ext:parse-hex-float "-0x0.0p+0f") 'single-float))) + (assert-equal #x8000000000000000 + (get-double-bits (ext:parse-hex-float "-0x0.0p+0"))) + (assert-equal #x80000000 + (get-single-bits (ext:parse-hex-float "-0x0.0p+0f"))) + (assert-true (typep (ext:parse-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::print-hex-single-float val)) + (str (ext:float-to-hex-string val)) (parsed (ext:parse-hex-float str))) - (assert-equal (get-single-bits val) (get-single-bits parsed))) + (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::print-hex-double-float val)) + (str (ext:float-to-hex-string val)) (parsed (ext:parse-hex-float str))) - (assert-equal (get-double-bits val) (get-double-bits parsed)))) + (assert-equal (get-double-bits val) (get-double-bits parsed) + val str parsed))) (define-test test-double-roundtrip (:tag :stress) @@ -58,9 +69,11 @@ (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::print-hex-double-float val)) + (let* ((str (ext:float-to-hex-string val)) (parsed (ext:parse-hex-float str))) - (assert-equal (get-double-bits val) (get-double-bits parsed))))))) + (assert-equal (get-double-bits val) + (get-double-bits parsed) + val str parsed)))))) (define-test test-single-roundtrip (:tag :stress) @@ -69,6 +82,8 @@ (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::print-hex-single-float val) "f")) + (let* ((str (concatenate 'string (ext:float-to-hex-string val) "f")) (parsed (ext:parse-hex-float str))) - (assert-equal (get-single-bits val) (get-single-bits parsed))))))) + (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/71da2451e58a3fb02bc9a3… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/71da2451e58a3fb02bc9a3… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-474-print-parse-hex-floats] 4 commits: Some minor indentation formatting
by Raymond Toy (＠rtoy) 23 Feb '26

23 Feb '26

Raymond Toy pushed to branch issue-474-print-parse-hex-floats at cmucl / cmucl Commits: ab9e4523 by Raymond Toy at 2026-02-23T07:47:51-08:00 Some minor indentation formatting Makes things a little easier to read. - - - - - 950d0c30 by Raymond Toy at 2026-02-23T08:54:02-08:00 Add parse-hex-float-from-stream As an experiment, we added code to parse hex floats from a stream. And implemented parse-hex-float via parse-hex-float-from-stream. Tests pass. Also updated print-hex-single-float to append an "f" on the output. - - - - - 5e8ecebb by Raymond Toy at 2026-02-23T09:08:54-08:00 Fix format-hex-float to work with printers - - - - - 71da2451 by Raymond Toy at 2026-02-23T09:14:12-08:00 Add some tests for subnormal boundaries - - - - - 2 changed files: - src/code/ext-code.lisp - tests/extensions.lisp Changes: ===================================== src/code/ext-code.lisp ===================================== @@ -23,39 +23,53 @@ ;;; C-style hex float printer and parser (defun print-hex-single-float (val) - "Prints a single-float in bit-perfect C-style hex using raw bits." - (cond ((float-nan-p val) "nan") - ((float-infinity-p val) (if (plusp val) "inf" "-inf")) - ((zerop val) (if (eql val -0.0f0) "-0x0.0p+0" "0x0.0p+0")) + "Prints a single-float in C-style hex format." + (cond ((float-nan-p val) + "nan") + ((float-infinity-p val) + (if (plusp val) "inf" "-inf")) + ((zerop val) + (if (eql val -0.0f0) + "-0x0.0p+0f" "0x0.0p+0f")) (t (let* ((bits (ldb (byte 32 0) (kernel:single-float-bits val))) (sign (ldb (byte 1 31) bits)) (exp-bits (ldb (byte 8 23) bits)) - (mantissa (ldb (byte 23 0) bits))) + (mantissa (ldb (byte 23 0) bits)) + ;; Print lower-case hex digits. + (*print-case* :downcase)) (if (zerop exp-bits) ;; Subnormal: Leading digit 0, exponent fixed at -126 - (format nil "~A0x0.~6,'0Xp-126" + (format nil "~A0x0.~6,'0Xp-126f" (if (= sign 1) "-" "") (ash mantissa 1)) ; Align 23 bits to 24 bits (6 hex digits) ;; Normalized: Leading digit 1, exponent bias 127 - (format nil "~A0x1.~6,'0Xp~A" + (format nil "~A0x1.~6,'0Xp~Af" (if (= sign 1) "-" "") (ash mantissa 1) ; Align 23 bits to 24 bits (6 hex digits) (- exp-bits 127))))))) (defun print-hex-double-float (val) - "Prints a double-float in bit-perfect C-style hex using raw bits." - (cond ((float-nan-p val) "nan") - ((float-infinity-p val) (if (plusp val) "inf" "-inf")) - ((zerop val) (if (eql val -0.0d0) "-0x0.0p+0" "0x0.0p+0")) + "Prints a double-float in C-style hex format." + (cond ((float-nan-p val) + "nan") + ((float-infinity-p val) + (if (plusp val) "inf" "-inf")) + ((zerop val) + (if (eql val -0.0d0) + "-0x0.0p+0" "0x0.0p+0")) (t - (multiple-value-bind (hi-bits lo-bits) (kernel:double-float-bits val) + (multiple-value-bind (hi-bits lo-bits) + (kernel:double-float-bits val) (let* ((hi (ldb (byte 32 0) hi-bits)) (lo (ldb (byte 32 0) lo-bits)) (sign (ldb (byte 1 31) hi)) (exp-bits (ldb (byte 11 20) hi)) ;; Combine 20 bits from high word and 32 bits from low word - (mantissa (logior (ash (ldb (byte 20 0) hi) 32) lo))) + (mantissa (logior (ash (ldb (byte 20 0) hi) 32) + lo)) + ;; Print lower-case hex digits. + (*print-case* :downcase)) (if (zerop exp-bits) ;; Subnormal: Leading digit 0, exponent fixed at -1022 (format nil "~A0x0.~13,'0Xp-1022" @@ -82,38 +96,52 @@ ;;; FORMAT-HEX-FLOAT -- Public ;;; ;;; Function that can be used in a FORMAT ~/ -(defun format-hex-float (stream val &optional colon-p at-p &rest params) - "Format ~/ directive supporting @ (sign) modifier for single/double floats." - (declare (ignore colon-p params)) - (write-string - (typecase val - (single-float (print-hex-single-float val at-p)) - (double-float (print-hex-double-float val at-p)) - (t (format nil "~A" val))) - stream)) +(defun format-hex-float (stream arg colon-p at-sign-p &optional width) + "Formatter for ~/ext:format-hex-float/. + @ forces sign (+/-). Colon modifier is ignored as per request." + (declare (ignore width colon-p)) + (let ((str (if (typep arg 'single-float) + (print-hex-single-float arg) + (print-hex-double-float arg)))) + ;; Prepend '+' if @ is used and number isn't negative or special + (when (and at-sign-p + (not (ext:float-nan-p arg)) + (not (ext:float-infinity-p arg)) + (not (char= (char str 0) #\-))) + (write-char #\+ stream)) + (write-string str stream))) ;;; PARSE-HEX-FLOAT -- Public ;;; ;;; Parse a C-style float hex strings. Always returns a double-float. ;;; Error-checking is enabled for malformed strings. -(define-condition hex-parse-error (error) +(define-condition hex-parse-error (parse-error) ((text :initarg :text :reader hex-parse-error-text) (message :initarg :message :reader hex-parse-error-message)) (:report (lambda (c s) (format s "Hex float parse error in ~S: ~A" (hex-parse-error-text c) (hex-parse-error-message c))))) +#+nil (defun parse-hex-float (str) "Parses hex floats using scale-float for the exponent. Strictly hex-literal only." - (let* ((str (string-trim '(#\Space #\Tab #\Newline #\Return) (string-downcase str))) + (let* ((str (string-trim '(#\Space #\Tab #\Newline #\Return) + (string-downcase str))) (len (length str))) - (when (zerop len) (error 'hex-parse-error :text str :message "Empty string")) + (when (zerop len) + (error 'hex-parse-error :text str :message "Empty string")) - (let* ((ends-with-f (and (> len 1) (char= (char str (1- len)) #\f))) - (effective-len (if ends-with-f (1- len) len)) - (prototype (if ends-with-f 1.0f0 1.0d0)) - (has-sign (or (char= (char str 0) #\-) (char= (char str 0) #\+))) - (sign (if (and has-sign (char= (char str 0) #\-)) -1 1)) + (let* ((ends-with-f (and (> len 1) + (char= (char str (1- len)) #\f))) + (effective-len (if ends-with-f + (1- len) len)) + (prototype (if ends-with-f + 1.0f0 1.0d0)) + (has-sign (or (char= (char str 0) #\-) + (char= (char str 0) #\+))) + (sign (if (and has-sign + (char= (char str 0) #\-)) + -1 1)) (start (if has-sign 1 0))) (unless (and (<= (+ start 2) effective-len) @@ -121,7 +149,8 @@ (error 'hex-parse-error :text str :message "Missing '0x' prefix")) (let ((p-pos (position #\p str :start start :end effective-len))) - (unless p-pos (error 'hex-parse-error :text str :message "Missing exponent 'p'")) + (unless p-pos + (error 'hex-parse-error :text str :message "Missing exponent 'p'")) (let* ((sig-start (+ start 2)) (dot-pos (position #\. str :start sig-start :end p-pos)) @@ -130,7 +159,8 @@ (leading-str (subseq str sig-start (or dot-pos p-pos))) ;; Trailing hex: digits after the dot (trailing-str (if dot-pos (subseq str (1+ dot-pos) p-pos) "")) - (has-digits (or (plusp (length leading-str)) (plusp (length trailing-str))))) + (has-digits (or (plusp (length leading-str)) + (plusp (length trailing-str))))) (unless has-digits (error 'hex-parse-error :text str :message "No hex digits in significand")) @@ -149,4 +179,78 @@ (raw-exponent (parse-integer str :start exp-start :end effective-len))) ;; Use scale-float to apply the binary exponent efficiently (* sign (scale-float significand raw-exponent))) - (error (c) (error 'hex-parse-error :text str :message (format nil "~A" c))))))))) + (error (c) + (error 'hex-parse-error :text str :message (format nil "~A" c))))))))) + +(defun parse-hex-float-from-stream (stream) + "Reads hex float from stream using double-float accumulation and a 6-character exponent buffer." + (let* ((sign 1.0d0) + (char (peek-char t stream))) ; Skip whitespace + + ;; 1. Handle Sign + (when (member char '(#\+ #\-)) + (when (char= (read-char stream) #\-) (setf sign -1.0d0)) + (setf char (peek-char nil stream))) + + ;; 2. Verify '0x' Prefix + (unless (and (char-equal (read-char stream) #\0) + (char-equal (read-char stream) #\x)) + (error 'hex-parse-error :text "Stream" :message "Missing '0x' prefix")) + + ;; 3. Read Significand + (let ((val 0.0d0) + (digits-read 0)) + ;; Integer part loop + (loop for c = (peek-char nil stream nil nil) + for digit = (and c (digit-char-p c 16)) + while digit + do (read-char stream) + (setf val (+ (* val 16.0d0) digit)) + (incf digits-read)) + + ;; Fractional part loop + (when (eql (peek-char nil stream nil nil) #\.) + (read-char stream) ; Consume #\. + (loop with weight = (/ 1.0d0 16.0d0) + for c = (peek-char nil stream nil nil) + for digit = (and c (digit-char-p c 16)) + while digit + do (read-char stream) + (setf val (+ val (* digit weight))) + (setf weight (/ weight 16.0d0)) + (incf digits-read))) + + (unless (plusp digits-read) + (error 'hex-parse-error :text "Stream" :message "No hex digits in significand")) + + ;; 4. Handle Exponent 'p' + (let ((p-char (read-char stream nil))) + (unless (and p-char (char-equal p-char #\p)) + (error 'hex-parse-error :text "Stream" :message "Missing exponent 'p'")) + + ;; Size 6 handles sign + 3-4 digits + buffer + (let ((exp-str (make-array 6 :element-type 'character + :fill-pointer 0 + :adjustable t))) + (loop for c = (peek-char nil stream nil nil) + while (and c (find c "+-0123456789")) + do (vector-push-extend (read-char stream) exp-str)) + + (when (zerop (length exp-str)) + (error 'hex-parse-error :text "Stream" :message "Invalid or missing exponent")) + + (let* ((raw-exp (parse-integer exp-str)) + (suffix (peek-char nil stream nil #\Space)) + (is-single (char-equal suffix #\f)) + ;; Final Construction + (result (* sign (scale-float val raw-exp)))) + + (when is-single (read-char stream)) ; Consume 'f' + + (if is-single + (float result 1.0f0) + result))))))) + +(defun parse-hex-float (str) + (with-input-from-string (s str) + (parse-hex-float-from-stream s))) ===================================== tests/extensions.lisp ===================================== @@ -37,6 +37,19 @@ (assert-equal #x80000000 (get-single-bits (ext:parse-hex-float "-0x0.0p+0f"))) (assert-true (typep (ext:parse-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::print-hex-single-float val)) + (parsed (ext:parse-hex-float str))) + (assert-equal (get-single-bits val) (get-single-bits parsed))) + ;; Test smallest double-float subnormal + (let* ((val (kernel:make-double-float 0 1)) + (str (ext::print-hex-double-float val)) + (parsed (ext:parse-hex-float str))) + (assert-equal (get-double-bits val) (get-double-bits parsed)))) + (define-test test-double-roundtrip (:tag :stress) (loop repeat 10000 do View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/b32b761d8abf7d62fb04c3… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/b32b761d8abf7d62fb04c3… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-474-print-parse-hex-floats] Update parse-hex-float to handle single-float
by Raymond Toy (＠rtoy) 23 Feb '26

23 Feb '26

Raymond Toy pushed to branch issue-474-print-parse-hex-floats at cmucl / cmucl Commits: b32b761d by Raymond Toy at 2026-02-22T21:09:09-08:00 Update parse-hex-float to handle single-float Parse-hex-float also no longer recognizes inf or nan since that's not supported by the C hex float literals. Tests updated to handle single-float too. - - - - - 2 changed files: - src/code/ext-code.lisp - tests/extensions.lisp Changes: ===================================== src/code/ext-code.lisp ===================================== @@ -22,94 +22,50 @@ ;;; C-style hex float printer and parser -(defun print-hex-single-float (val &optional force-sign) - (let* ((bits (kernel:single-float-bits val)) - (u-bits (ldb (byte 32 0) bits)) - (sign-bit (ldb (byte 1 31) u-bits)) - (biased-exp (ldb (byte 8 23) u-bits)) - (fraction (ldb (byte 23 0) u-bits)) - (sign-str (cond ((= sign-bit 1) "-") (force-sign "+") (t "")))) - (cond - ((= biased-exp 255) (if (zerop fraction) (format nil "~Ainf" sign-str) "nan")) - ((and (zerop biased-exp) (zerop fraction)) (format nil "~A0x0.000000p+0" sign-str)) - ((zerop biased-exp) (format nil "~A0x0.~6,'0xp-126" sign-str fraction)) - (t (let ((exponent (- biased-exp 127))) - (format nil "~A0x1.~6,'0xp~:[~;+~]~D" sign-str fraction (not (minusp exponent)) exponent)))))) - -(defun print-hex-double-float (val &optional force-sign) - (multiple-value-bind (hi lo) (kernel:double-float-bits val) - (let* ((u-hi (ldb (byte 32 0) hi)) - (sign-bit (ldb (byte 1 31) u-hi)) - (biased-exp (ldb (byte 11 20) u-hi)) - (fraction (logior (ash (ldb (byte 20 0) u-hi) 32) lo)) - (sign-str (cond ((= sign-bit 1) "-") (force-sign "+") (t "")))) - (cond - ((= biased-exp #x7FF) (if (zerop fraction) (format nil "~Ainf" sign-str) "nan")) - ((and (zerop biased-exp) (zerop fraction)) (format nil "~A0x0.0000000000000p+0" sign-str)) - ((zerop biased-exp) (format nil "~A0x0.~13,'0xp-1022" sign-str fraction)) - (t (let ((exponent (- biased-exp 1023))) - (format nil "~A0x1.~13,'0xp~:[~;+~]~D" sign-str fraction (not (minusp exponent)) exponent))))))) - -#+nil -(defun print-hex-single-float (val &optional force-sign) - "Converts a single-float to a C-style hex string (32-bit)." - (let* ((bits (kernel:single-float-bits val)) - (u-bits (ldb (byte 32 0) bits)) - (sign-bit (ldb (byte 1 31) u-bits)) - (biased-exp (ldb (byte 8 23) u-bits)) - (fraction (ldb (byte 23 0) u-bits)) - (sign-str (cond ((= sign-bit 1) - "-") - (force-sign - "+") - (t - "")))) - (cond - ((= biased-exp 255) - (if (zerop fraction) - (format nil "~Ainf" sign-str) - "nan")) - ((and (zerop biased-exp) - (zerop fraction)) - (format nil "~A0x0.000000p+0" sign-str)) - ((zerop biased-exp) - (let ((*print-case* :downcase)) - (format nil "~A0x0.~6,'0xp-126" sign-str fraction))) - (t - (let ((*print-case* :downcase) - (exponent (- biased-exp 127))) - (format nil "~A0x1.~6,'0xp~:[~;+~]~D" - sign-str fraction (not (minusp exponent)) exponent)))))) +(defun print-hex-single-float (val) + "Prints a single-float in bit-perfect C-style hex using raw bits." + (cond ((float-nan-p val) "nan") + ((float-infinity-p val) (if (plusp val) "inf" "-inf")) + ((zerop val) (if (eql val -0.0f0) "-0x0.0p+0" "0x0.0p+0")) + (t + (let* ((bits (ldb (byte 32 0) (kernel:single-float-bits val))) + (sign (ldb (byte 1 31) bits)) + (exp-bits (ldb (byte 8 23) bits)) + (mantissa (ldb (byte 23 0) bits))) + (if (zerop exp-bits) + ;; Subnormal: Leading digit 0, exponent fixed at -126 + (format nil "~A0x0.~6,'0Xp-126" + (if (= sign 1) "-" "") + (ash mantissa 1)) ; Align 23 bits to 24 bits (6 hex digits) + ;; Normalized: Leading digit 1, exponent bias 127 + (format nil "~A0x1.~6,'0Xp~A" + (if (= sign 1) "-" "") + (ash mantissa 1) ; Align 23 bits to 24 bits (6 hex digits) + (- exp-bits 127))))))) -#+nil -(defun print-hex-double-float (val &optional force-sign) - "Converts a double-float to a C-style hex string (64-bit)." - (multiple-value-bind (hi lo) - (kernel:double-float-bits val) - (let* ((u-hi (ldb (byte 32 0) hi)) - (sign-bit (ldb (byte 1 31) u-hi)) - (biased-exp (ldb (byte 11 20) u-hi)) - (fraction (logior (ash (ldb (byte 20 0) u-hi) 32) lo)) - (sign-str (cond ((= sign-bit 1) - "-") - (force-sign "+") - (t "")))) - (cond - ((= biased-exp #x7FF) - (if (zerop fraction) - (format nil "~Ainf" sign-str) - "nan")) - ((and (zerop biased-exp) - (zerop fraction)) - (format nil "~A0x0.0000000000000p+0" sign-str)) - ((zerop biased-exp) - (let ((*print-case* :downcase)) - (format nil "~A0x0.~13,'0xp-1022" sign-str fraction))) +(defun print-hex-double-float (val) + "Prints a double-float in bit-perfect C-style hex using raw bits." + (cond ((float-nan-p val) "nan") + ((float-infinity-p val) (if (plusp val) "inf" "-inf")) + ((zerop val) (if (eql val -0.0d0) "-0x0.0p+0" "0x0.0p+0")) (t - (let ((*print-case* :downcase) - (exponent (- biased-exp 1023))) - (format nil "~A0x1.~13,'0xp~:[~;+~]~D" - sign-str fraction (not (minusp exponent)) exponent))))))) + (multiple-value-bind (hi-bits lo-bits) (kernel:double-float-bits val) + (let* ((hi (ldb (byte 32 0) hi-bits)) + (lo (ldb (byte 32 0) lo-bits)) + (sign (ldb (byte 1 31) hi)) + (exp-bits (ldb (byte 11 20) hi)) + ;; Combine 20 bits from high word and 32 bits from low word + (mantissa (logior (ash (ldb (byte 20 0) hi) 32) lo))) + (if (zerop exp-bits) + ;; Subnormal: Leading digit 0, exponent fixed at -1022 + (format nil "~A0x0.~13,'0Xp-1022" + (if (= sign 1) "-" "") + mantissa) + ;; Normalized: Leading digit 1, exponent bias 1023 + (format nil "~A0x1.~13,'0Xp~A" + (if (= sign 1) "-" "") + mantissa ; 52 bits fits 13 hex digits perfectly + (- exp-bits 1023)))))))) ;;; PRINT-HEX-FLOAT -- Public ;;; @@ -147,104 +103,50 @@ (format s "Hex float parse error in ~S: ~A" (hex-parse-error-text c) (hex-parse-error-message c))))) -#+nil (defun parse-hex-float (str) - "Parses hex strings by converting the significand to a float, then scaling." + "Parses hex floats using scale-float for the exponent. Strictly hex-literal only." (let* ((str (string-trim '(#\Space #\Tab #\Newline #\Return) (string-downcase str))) (len (length str))) (when (zerop len) (error 'hex-parse-error :text str :message "Empty string")) - (let* ((has-sign (or (char= (char str 0) #\-) (char= (char str 0) #\+))) + + (let* ((ends-with-f (and (> len 1) (char= (char str (1- len)) #\f))) + (effective-len (if ends-with-f (1- len) len)) + (prototype (if ends-with-f 1.0f0 1.0d0)) + (has-sign (or (char= (char str 0) #\-) (char= (char str 0) #\+))) (sign (if (and has-sign (char= (char str 0) #\-)) -1 1)) (start (if has-sign 1 0))) - (cond - ((string= str "inf" :start1 start) - (if (= sign 1) double-float-positive-infinity double-float-negative-infinity)) - ((string= str "nan" :start1 start) :nan) - (t - (unless (and (<= (+ start 2) len) (string= str "0x" :start1 start :end1 (+ start 2))) - (error 'hex-parse-error :text str :message "Missing '0x' prefix")) - (let ((p-pos (position #\p str :start start))) - (unless p-pos (error 'hex-parse-error :text str :message "Missing exponent 'p'")) - - ;; Check for internal whitespace - (loop for i from start below len - when (member (char str i) '(#\Space #\Tab #\Newline #\Return)) - do (error 'hex-parse-error :text str :message "Internal whitespace detected")) - - (let* ((sig-start (+ start 2)) - (dot-pos (position #\. str :start sig-start :end p-pos)) - (exp-start (1+ p-pos))) - - (handler-case - (let* ((frac-hex-len (if dot-pos (- p-pos (1+ dot-pos)) 0)) - ;; 1. Combine leading and trailing into one large integer - (significand-int - (if (null dot-pos) - (parse-integer str :start sig-start :end p-pos :radix 16) - (let ((leading (if (= sig-start dot-pos) 0 - (parse-integer str :start sig-start :end dot-pos :radix 16))) - (trailing (if (= (1+ dot-pos) p-pos) 0 - (parse-integer str :start (1+ dot-pos) :end p-pos :radix 16)))) - (+ (ash leading (* 4 frac-hex-len)) trailing)))) - ;; 2. Parse decimal exponent - (raw-exponent (parse-integer str :start exp-start :end len)) - ;; 3. Handle the "cliff" logic for 0x0. vs 0x1. - (starts-with-zero (char= (char str sig-start) #\0)) - (actual-exponent (if (and starts-with-zero (not (zerop significand-int))) - -1022 - raw-exponent))) - - ;; 4. Convert integer to float and scale by (exponent - fractional bits) - ;; scale-float is bit-exact for binary scaling. - (* sign (scale-float (float significand-int 1.0d0) - (- actual-exponent (* 4 frac-hex-len))))) - (error (c) (error 'hex-parse-error :text str :message (format nil "~A" c))))))))))) + + (unless (and (<= (+ start 2) effective-len) + (string= str "0x" :start1 start :end1 (+ start 2))) + (error 'hex-parse-error :text str :message "Missing '0x' prefix")) + + (let ((p-pos (position #\p str :start start :end effective-len))) + (unless p-pos (error 'hex-parse-error :text str :message "Missing exponent 'p'")) -(defun parse-hex-float (str) - "Parses C-style hex strings via an exact rational. Strictly validates digit presence." - (let* ((str (string-trim '(#\Space #\Tab #\Newline #\Return) (string-downcase str))) - (len (length str))) - (when (zerop len) (error 'hex-parse-error :text str :message "Empty string")) - (let* ((has-sign (or (char= (char str 0) #\-) (char= (char str 0) #\+))) - (sign (if (and has-sign (char= (char str 0) #\-)) -1 1)) - (start (if has-sign 1 0))) - (cond - ((string= str "inf" :start1 start) - (if (= sign 1) double-float-positive-infinity double-float-negative-infinity)) - ((string= str "nan" :start1 start) :nan) - (t - (unless (and (<= (+ start 2) len) (string= str "0x" :start1 start :end1 (+ start 2))) - (error 'hex-parse-error :text str :message "Missing '0x' prefix")) - (let ((p-pos (position #\p str :start start))) - (unless p-pos (error 'hex-parse-error :text str :message "Missing exponent 'p'")) - - (loop for i from start below len - when (member (char str i) '(#\Space #\Tab #\Newline #\Return)) - do (error 'hex-parse-error :text str :message "Internal whitespace detected")) + (let* ((sig-start (+ start 2)) + (dot-pos (position #\. str :start sig-start :end p-pos)) + (exp-start (1+ p-pos)) + ;; Leading hex: digits before the dot + (leading-str (subseq str sig-start (or dot-pos p-pos))) + ;; Trailing hex: digits after the dot + (trailing-str (if dot-pos (subseq str (1+ dot-pos) p-pos) "")) + (has-digits (or (plusp (length leading-str)) (plusp (length trailing-str))))) + + (unless has-digits + (error 'hex-parse-error :text str :message "No hex digits in significand")) - (let* ((sig-start (+ start 2)) - (dot-pos (position #\. str :start sig-start :end p-pos)) - (exp-start (1+ p-pos)) - ;; Strict Validation: Ensure there is at least one digit in the significand - (has-leading (and (not (eql sig-start dot-pos)) (not (eql sig-start p-pos)))) - (has-trailing (and dot-pos (not (eql (1+ dot-pos) p-pos))))) - - (unless (or has-leading has-trailing) - (error 'hex-parse-error :text str :message "No hex digits in significand")) - - (handler-case - (let* ((frac-hex-len (if dot-pos (- p-pos (1+ dot-pos)) 0)) - (significand-int - (if (null dot-pos) - (parse-integer str :start sig-start :end p-pos :radix 16) - (let ((leading (if (not has-leading) 0 - (parse-integer str :start sig-start :end dot-pos :radix 16))) - (trailing (if (not has-trailing) 0 - (parse-integer str :start (1+ dot-pos) :end p-pos :radix 16)))) - (+ (ash leading (* 4 frac-hex-len)) trailing)))) - (raw-exponent (parse-integer str :start exp-start :end len)) - ;; significand * 2^(exp - 4*frac_len) - (rational-val (* significand-int - (expt 2 (- raw-exponent (* 4 frac-hex-len)))))) - (* sign (float rational-val 1.0d0))) - (error (c) (error 'hex-parse-error :text str :message (format nil "~A" c))))))))))) + (handler-case + (let* ((leading-int (if (string= leading-str "") 0 + (parse-integer leading-str :radix 16))) + (trailing-len (length trailing-str)) + (trailing-int (if (string= trailing-str "") 0 + (parse-integer trailing-str :radix 16))) + ;; Calculate the significand as a float: leading + (trailing / 16^len) + (significand (float (+ leading-int + (/ trailing-int (expt 16 trailing-len))) + prototype)) + ;; The exponent after 'p' + (raw-exponent (parse-integer str :start exp-start :end effective-len))) + ;; Use scale-float to apply the binary exponent efficiently + (* sign (scale-float significand raw-exponent))) + (error (c) (error 'hex-parse-error :text str :message (format nil "~A" c))))))))) ===================================== tests/extensions.lisp ===================================== @@ -4,153 +4,58 @@ (in-package "EXTENSIONS-TESTS") -#+nil -(defun test-invalid-strings () - (format t "Testing invalid strings...~%") - (let ((invalid-cases '("" "1.0" "0x1.0" "0x1.0p" "0x1.zp+0" "0x.p+0" "0x1 .0p+0"))) - (dolist (case invalid-cases) - (handler-case - (progn (parse-hex-float case) (error "Failed to trap ~S" case)) - (hex-parse-error () (format t " Caught expected error for: ~S~%" case))))) - (format t "Invalid string tests passed.~%")) - -(define-test parse-hex.invalid-strings - (dolist (case '("" "1.0" "0x1.0" "0x1.0p" "0x1.zp+0" "0x.p+0" "0x1 .0p+0")) - (assert-error 'ext:hex-parse-error - (ext:parse-hex-float case) - case))) - -#+nil -(defun run-hex-float-tests (&key (iterations 20000)) - "Validates bit-consistency for double floats." - (format t "Testing ~D random bit patterns (Double Precision)...~%" iterations) - (loop repeat iterations do - (let* ((hi-bits (random (expt 2 32))) - (hi (if (logbitp 31 hi-bits) - (- hi-bits (expt 2 32)) - hi-bits)) - (lo (random (expt 2 32))) - (d-float (kernel:make-double-float hi lo)) - (d-str (print-hex-double-float d-float)) - (d-parsed (parse-hex-float d-str))) - (cond - ((eq d-parsed :nan) - (assert (float-nan-p d-float))) - (t - (multiple-value-bind (n-hi n-lo) - (kernel:double-float-bits d-parsed) - (assert (and (= (ldb (byte 32 0) hi) - (ldb (byte 32 0) n-hi)) - (= lo n-lo)))))))) - (format t "Bit verification passed.~%")) - -(define-test hex-parse-print-consistency - (loop repeat 20000 do - (let* ((hi-bits (random (expt 2 32))) - (hi (if (logbitp 31 hi-bits) - (- hi-bits (expt 2 32)) - hi-bits)) - (lo (random (expt 2 32))) - (d-float (kernel:make-double-float hi lo)) - (d-str (ext:print-hex-float d-float)) - (d-parsed (ext:parse-hex-float d-str))) - (cond - ((eq d-parsed :nan) - (assert-true (ext:float-nan-p d-float) - d-float d-parsed)) - (t - (multiple-value-bind (n-hi n-lo) - (kernel:double-float-bits d-parsed) - (assert-true (= (ldb (byte 32 0) hi) - (ldb (byte 32 0) n-hi)) - hi n-hi) - (assert-true (= lo n-lo) - lo n-lo))))))) - - -#+nil -(defun run-subnormal-stress-test () - (format t "Running subnormal stress tests...~%") - (let* ((s-str "0x0.10534ec00dae8p-1022") - (parsed (parse-hex-float s-str))) - ;; Using assumed builtin float-denormalized-p - (assert (float-denormalized-p parsed)) - (multiple-value-bind (hi lo) (kernel:double-float-bits parsed) - (assert (= (logior (ash (ldb (byte 20 0) hi) 32) lo) #x10534ec00dae8)))) - (loop repeat 5000 do - (let* ((lo (random (expt 2 32))) - (hi (random (expt 2 20))) ; biased exponent is 0 - (val (kernel:make-double-float hi lo)) - (str (ext::print-hex-double-float val)) - (parsed (parse-hex-float str))) - (unless (zerop val) - (multiple-value-bind (new-hi new-lo) (kernel:double-float-bits parsed) - (assert (and (= hi new-hi) (= lo new-lo))))))) - (format t "Subnormal stress test passed.~%")) - -(define-test hex-parse-denormals.1 - (let* ((s-str "0x0.10534ec00dae8p-1022") - (parsed (ext:parse-hex-float s-str))) - (assert-true (ext:float-denormalized-p parsed)) - (multiple-value-bind (hi lo) - (kernel:double-float-bits parsed) - (assert-true (= (logior (ash (ldb (byte 20 0) hi) 32) lo) - #x10534ec00dae8))))) +(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-parse-error (ext:parse-hex-float "inf")) + (assert-error 'ext:hex-parse-error (ext:parse-hex-float "0x.p+0")) + (assert-error 'ext:hex-parse-error (ext:parse-hex-float "0x1.0p"))) + +(define-test test-cliff-boundaries + (:tag :precision) + ;; Double Precision (-1022 Cliff) -(define-test hex-parse-denormals.random - (loop repeat 5000 do - (let* ((lo (random (expt 2 32))) - (hi (random (expt 2 20))) ; biased exponent is 0 - (val (kernel:make-double-float hi lo)) - (str (ext::print-hex-double-float val)) - (parsed (ext:parse-hex-float str))) - (unless (zerop val) - (multiple-value-bind (new-hi new-lo) - (kernel:double-float-bits parsed) - (assert-true (and (= hi new-hi) (= lo new-lo)))))))) - -#+nil -(defun run-cliff-tests () - "Tests precision around the smallest normalized and largest subnormal boundary." - (format t "Running boundary (cliff) tests...~%") - (let ((cases '(;; Smallest normalized number (2^-1022) - ("0x1.0000000000000p-1022" #x0010000000000000) - ;; Smallest normalized + 1 ULP - ("0x1.0000000000001p-1022" #x0010000000000001) - ;; Smallest normalized - 1 ULP (Largest subnormal) - ("0x0.fffffffffffffp-1022" #x000fffffffffffff) - ;; The user reported failing case - ("0x1.f0195cb356b8fp-1022" #x001f0195cb356b8f)))) - (dolist (test cases) - (destructuring-bind (str expected-bits) test - (let* ((parsed (parse-hex-float str)) - (actual-bits (multiple-value-bind (hi lo) (kernel:double-float-bits parsed) - (logior (ash (ldb (byte 32 0) hi) 32) lo)))) - (format t " Testing ~A...~%" str) - (unless (= actual-bits expected-bits) - (error "Cliff Mismatch!~%Str: ~A~%Expected: ~16,'0X~%Actual: ~16,'0X" - str expected-bits actual-bits)))))) - (format t "Cliff tests passed.~%")) - -;; Test precision around the smallest normalized and larges denormal boundary. -(define-test hex-parse-denormal-boundary - (let ((cases '(;; Smallest normalized number (2^-1022) - ("0x1.0000000000000p-1022" #x0010000000000000) - ;; Smallest normalized + 1 ULP - ("0x1.0000000000001p-1022" #x0010000000000001) - ;; Smallest normalized - 1 ULP (Largest subnormal) - ("0x0.fffffffffffffp-1022" #x000fffffffffffff) - ;; The user reported failing case - ("0x1.f0195cb356b8fp-1022" #x001f0195cb356b8f) - ;; Failing case 1: 0x0.10534ec00dae8p-1022 - ("0x0.10534ec00dae8p-1022" #x00010534ec00dae8) - ;; Failing case 2: 0x0.49df16729d954p-1022 - ("0x0.49df16729d954p-1022" #x00049df16729d954)))) - (dolist (test cases) - (destructuring-bind (str expected-bits) test - (let* ((parsed (ext:parse-hex-float str)) - (actual-bits (multiple-value-bind (hi lo) - (kernel:double-float-bits parsed) - (logior (ash (ldb (byte 32 0) hi) 32) lo)))) - (assert-equal expected-bits actual-bits - str)))))) + (assert-equal #x0010000000000000 (get-double-bits (ext:parse-hex-float "0x1.0000000000000p-1022"))) + (assert-equal #x000fffffffffffff (get-double-bits (ext:parse-hex-float "0x0.fffffffffffffp-1022"))) + (assert-equal #x001f0195cb356b8f (get-double-bits (ext:parse-hex-float "0x1.f0195cb356b8fp-1022"))) + + ;; Single Precision (-126 Cliff) + + (assert-equal #x00800000 (get-single-bits (ext:parse-hex-float "0x1.000000p-126f"))) + (assert-equal #x00400000 (get-single-bits (ext:parse-hex-float "0x0.800000p-126f"))) + (assert-equal #x7f7fffff (get-single-bits (ext:parse-hex-float "0x1.fffffep+127f")))) + +(define-test test-negative-zero + (:tag :edge-cases) + (assert-equal #x8000000000000000 (get-double-bits (ext:parse-hex-float "-0x0.0p+0"))) + (assert-equal #x80000000 (get-single-bits (ext:parse-hex-float "-0x0.0p+0f"))) + (assert-true (typep (ext:parse-hex-float "-0x0.0p+0f") 'single-float))) + +(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::print-hex-double-float val)) + (parsed (ext:parse-hex-float str))) + (assert-equal (get-double-bits val) (get-double-bits 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::print-hex-single-float val) "f")) + (parsed (ext:parse-hex-float str))) + (assert-equal (get-single-bits val) (get-single-bits parsed))))))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/b32b761d8abf7d62fb04c37… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/b32b761d8abf7d62fb04c37… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-474-print-parse-hex-floats] Move code from extensions.lisp to new file ext-code.lisp
by Raymond Toy (＠rtoy) 23 Feb '26

23 Feb '26

Raymond Toy pushed to branch issue-474-print-parse-hex-floats at cmucl / cmucl Commits: 6af9a683 by Raymond Toy at 2026-02-22T16:52:44-08:00 Move code from extensions.lisp to new file ext-code.lisp The code in extensions.lisp is always byte-compiled. I think we want the hex float printer and parser to be fast so it should be compiled natively. Hence, put them in the new file ext-code.lisp. Update worldcom and worldload to use the new file. Also parse-hex-float was updated not to use rationals but to use a float for the mantissa part and then scaling the final result by the exponent. - - - - - 4 changed files: - + src/code/ext-code.lisp - src/code/extensions.lisp - src/tools/worldcom.lisp - src/tools/worldload.lisp Changes: ===================================== src/code/ext-code.lisp ===================================== @@ -0,0 +1,250 @@ +;;; -*- Log: code.log; Package: Extensions -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +(ext:file-comment + "$Header: src/code/extensions.lisp $") +;;; +;;; +;;; ********************************************************************** +;;; +;;; Spice Lisp extensions to the language. +;;; +;;; These extensions are compiled natively instead of byte-compiled +;;; like the code in code/extensions.lisp. +;;; +;;; ********************************************************************** +(in-package "EXTENSIONS") + +(intl:textdomain "cmucl") + + +;;; C-style hex float printer and parser +(defun print-hex-single-float (val &optional force-sign) + (let* ((bits (kernel:single-float-bits val)) + (u-bits (ldb (byte 32 0) bits)) + (sign-bit (ldb (byte 1 31) u-bits)) + (biased-exp (ldb (byte 8 23) u-bits)) + (fraction (ldb (byte 23 0) u-bits)) + (sign-str (cond ((= sign-bit 1) "-") (force-sign "+") (t "")))) + (cond + ((= biased-exp 255) (if (zerop fraction) (format nil "~Ainf" sign-str) "nan")) + ((and (zerop biased-exp) (zerop fraction)) (format nil "~A0x0.000000p+0" sign-str)) + ((zerop biased-exp) (format nil "~A0x0.~6,'0xp-126" sign-str fraction)) + (t (let ((exponent (- biased-exp 127))) + (format nil "~A0x1.~6,'0xp~:[~;+~]~D" sign-str fraction (not (minusp exponent)) exponent)))))) + +(defun print-hex-double-float (val &optional force-sign) + (multiple-value-bind (hi lo) (kernel:double-float-bits val) + (let* ((u-hi (ldb (byte 32 0) hi)) + (sign-bit (ldb (byte 1 31) u-hi)) + (biased-exp (ldb (byte 11 20) u-hi)) + (fraction (logior (ash (ldb (byte 20 0) u-hi) 32) lo)) + (sign-str (cond ((= sign-bit 1) "-") (force-sign "+") (t "")))) + (cond + ((= biased-exp #x7FF) (if (zerop fraction) (format nil "~Ainf" sign-str) "nan")) + ((and (zerop biased-exp) (zerop fraction)) (format nil "~A0x0.0000000000000p+0" sign-str)) + ((zerop biased-exp) (format nil "~A0x0.~13,'0xp-1022" sign-str fraction)) + (t (let ((exponent (- biased-exp 1023))) + (format nil "~A0x1.~13,'0xp~:[~;+~]~D" sign-str fraction (not (minusp exponent)) exponent))))))) + +#+nil +(defun print-hex-single-float (val &optional force-sign) + "Converts a single-float to a C-style hex string (32-bit)." + (let* ((bits (kernel:single-float-bits val)) + (u-bits (ldb (byte 32 0) bits)) + (sign-bit (ldb (byte 1 31) u-bits)) + (biased-exp (ldb (byte 8 23) u-bits)) + (fraction (ldb (byte 23 0) u-bits)) + (sign-str (cond ((= sign-bit 1) + "-") + (force-sign + "+") + (t + "")))) + (cond + ((= biased-exp 255) + (if (zerop fraction) + (format nil "~Ainf" sign-str) + "nan")) + ((and (zerop biased-exp) + (zerop fraction)) + (format nil "~A0x0.000000p+0" sign-str)) + ((zerop biased-exp) + (let ((*print-case* :downcase)) + (format nil "~A0x0.~6,'0xp-126" sign-str fraction))) + (t + (let ((*print-case* :downcase) + (exponent (- biased-exp 127))) + (format nil "~A0x1.~6,'0xp~:[~;+~]~D" + sign-str fraction (not (minusp exponent)) exponent)))))) + +#+nil +(defun print-hex-double-float (val &optional force-sign) + "Converts a double-float to a C-style hex string (64-bit)." + (multiple-value-bind (hi lo) + (kernel:double-float-bits val) + (let* ((u-hi (ldb (byte 32 0) hi)) + (sign-bit (ldb (byte 1 31) u-hi)) + (biased-exp (ldb (byte 11 20) u-hi)) + (fraction (logior (ash (ldb (byte 20 0) u-hi) 32) lo)) + (sign-str (cond ((= sign-bit 1) + "-") + (force-sign "+") + (t "")))) + (cond + ((= biased-exp #x7FF) + (if (zerop fraction) + (format nil "~Ainf" sign-str) + "nan")) + ((and (zerop biased-exp) + (zerop fraction)) + (format nil "~A0x0.0000000000000p+0" sign-str)) + ((zerop biased-exp) + (let ((*print-case* :downcase)) + (format nil "~A0x0.~13,'0xp-1022" sign-str fraction))) + (t + (let ((*print-case* :downcase) + (exponent (- biased-exp 1023))) + (format nil "~A0x1.~13,'0xp~:[~;+~]~D" + sign-str fraction (not (minusp exponent)) exponent))))))) + +;;; PRINT-HEX-FLOAT -- Public +;;; +;;; Return a string representing a single and double-floats in C-style +;;; hex format. +(defun print-hex-float (float) + "Convert FLOAT to C-style hex string. Infinities are printed as \"-inf\" + and \"inf\". NaN is printed as \"nan\"." + (declare (float float)) + (etypecase float + (single-float (print-hex-single-float float)) + (double-float (print-hex-double-float float)))) + +;;; FORMAT-HEX-FLOAT -- Public +;;; +;;; Function that can be used in a FORMAT ~/ +(defun format-hex-float (stream val &optional colon-p at-p &rest params) + "Format ~/ directive supporting @ (sign) modifier for single/double floats." + (declare (ignore colon-p params)) + (write-string + (typecase val + (single-float (print-hex-single-float val at-p)) + (double-float (print-hex-double-float val at-p)) + (t (format nil "~A" val))) + stream)) + +;;; PARSE-HEX-FLOAT -- Public +;;; +;;; Parse a C-style float hex strings. Always returns a double-float. +;;; Error-checking is enabled for malformed strings. +(define-condition hex-parse-error (error) + ((text :initarg :text :reader hex-parse-error-text) + (message :initarg :message :reader hex-parse-error-message)) + (:report (lambda (c s) + (format s "Hex float parse error in ~S: ~A" + (hex-parse-error-text c) (hex-parse-error-message c))))) + +#+nil +(defun parse-hex-float (str) + "Parses hex strings by converting the significand to a float, then scaling." + (let* ((str (string-trim '(#\Space #\Tab #\Newline #\Return) (string-downcase str))) + (len (length str))) + (when (zerop len) (error 'hex-parse-error :text str :message "Empty string")) + (let* ((has-sign (or (char= (char str 0) #\-) (char= (char str 0) #\+))) + (sign (if (and has-sign (char= (char str 0) #\-)) -1 1)) + (start (if has-sign 1 0))) + (cond + ((string= str "inf" :start1 start) + (if (= sign 1) double-float-positive-infinity double-float-negative-infinity)) + ((string= str "nan" :start1 start) :nan) + (t + (unless (and (<= (+ start 2) len) (string= str "0x" :start1 start :end1 (+ start 2))) + (error 'hex-parse-error :text str :message "Missing '0x' prefix")) + (let ((p-pos (position #\p str :start start))) + (unless p-pos (error 'hex-parse-error :text str :message "Missing exponent 'p'")) + + ;; Check for internal whitespace + (loop for i from start below len + when (member (char str i) '(#\Space #\Tab #\Newline #\Return)) + do (error 'hex-parse-error :text str :message "Internal whitespace detected")) + + (let* ((sig-start (+ start 2)) + (dot-pos (position #\. str :start sig-start :end p-pos)) + (exp-start (1+ p-pos))) + + (handler-case + (let* ((frac-hex-len (if dot-pos (- p-pos (1+ dot-pos)) 0)) + ;; 1. Combine leading and trailing into one large integer + (significand-int + (if (null dot-pos) + (parse-integer str :start sig-start :end p-pos :radix 16) + (let ((leading (if (= sig-start dot-pos) 0 + (parse-integer str :start sig-start :end dot-pos :radix 16))) + (trailing (if (= (1+ dot-pos) p-pos) 0 + (parse-integer str :start (1+ dot-pos) :end p-pos :radix 16)))) + (+ (ash leading (* 4 frac-hex-len)) trailing)))) + ;; 2. Parse decimal exponent + (raw-exponent (parse-integer str :start exp-start :end len)) + ;; 3. Handle the "cliff" logic for 0x0. vs 0x1. + (starts-with-zero (char= (char str sig-start) #\0)) + (actual-exponent (if (and starts-with-zero (not (zerop significand-int))) + -1022 + raw-exponent))) + + ;; 4. Convert integer to float and scale by (exponent - fractional bits) + ;; scale-float is bit-exact for binary scaling. + (* sign (scale-float (float significand-int 1.0d0) + (- actual-exponent (* 4 frac-hex-len))))) + (error (c) (error 'hex-parse-error :text str :message (format nil "~A" c))))))))))) + +(defun parse-hex-float (str) + "Parses C-style hex strings via an exact rational. Strictly validates digit presence." + (let* ((str (string-trim '(#\Space #\Tab #\Newline #\Return) (string-downcase str))) + (len (length str))) + (when (zerop len) (error 'hex-parse-error :text str :message "Empty string")) + (let* ((has-sign (or (char= (char str 0) #\-) (char= (char str 0) #\+))) + (sign (if (and has-sign (char= (char str 0) #\-)) -1 1)) + (start (if has-sign 1 0))) + (cond + ((string= str "inf" :start1 start) + (if (= sign 1) double-float-positive-infinity double-float-negative-infinity)) + ((string= str "nan" :start1 start) :nan) + (t + (unless (and (<= (+ start 2) len) (string= str "0x" :start1 start :end1 (+ start 2))) + (error 'hex-parse-error :text str :message "Missing '0x' prefix")) + (let ((p-pos (position #\p str :start start))) + (unless p-pos (error 'hex-parse-error :text str :message "Missing exponent 'p'")) + + (loop for i from start below len + when (member (char str i) '(#\Space #\Tab #\Newline #\Return)) + do (error 'hex-parse-error :text str :message "Internal whitespace detected")) + + (let* ((sig-start (+ start 2)) + (dot-pos (position #\. str :start sig-start :end p-pos)) + (exp-start (1+ p-pos)) + ;; Strict Validation: Ensure there is at least one digit in the significand + (has-leading (and (not (eql sig-start dot-pos)) (not (eql sig-start p-pos)))) + (has-trailing (and dot-pos (not (eql (1+ dot-pos) p-pos))))) + + (unless (or has-leading has-trailing) + (error 'hex-parse-error :text str :message "No hex digits in significand")) + + (handler-case + (let* ((frac-hex-len (if dot-pos (- p-pos (1+ dot-pos)) 0)) + (significand-int + (if (null dot-pos) + (parse-integer str :start sig-start :end p-pos :radix 16) + (let ((leading (if (not has-leading) 0 + (parse-integer str :start sig-start :end dot-pos :radix 16))) + (trailing (if (not has-trailing) 0 + (parse-integer str :start (1+ dot-pos) :end p-pos :radix 16)))) + (+ (ash leading (* 4 frac-hex-len)) trailing)))) + (raw-exponent (parse-integer str :start exp-start :end len)) + ;; significand * 2^(exp - 4*frac_len) + (rational-val (* significand-int + (expt 2 (- raw-exponent (* 4 frac-hex-len)))))) + (* sign (float rational-val 1.0d0))) + (error (c) (error 'hex-parse-error :text str :message (format nil "~A" c))))))))))) ===================================== src/code/extensions.lisp ===================================== @@ -725,304 +725,6 @@ (when ,dirname (delete-directory ,dirname :recursive t)))))) -;;; C-style hex float printer and parser -(defun print-hex-single-float (val &optional force-sign) - (let* ((bits (kernel:single-float-bits val)) - (u-bits (ldb (byte 32 0) bits)) - (sign-bit (ldb (byte 1 31) u-bits)) - (biased-exp (ldb (byte 8 23) u-bits)) - (fraction (ldb (byte 23 0) u-bits)) - (sign-str (cond ((= sign-bit 1) "-") (force-sign "+") (t "")))) - (cond - ((= biased-exp 255) (if (zerop fraction) (format nil "~Ainf" sign-str) "nan")) - ((and (zerop biased-exp) (zerop fraction)) (format nil "~A0x0.000000p+0" sign-str)) - ((zerop biased-exp) (format nil "~A0x0.~6,'0xp-126" sign-str fraction)) - (t (let ((exponent (- biased-exp 127))) - (format nil "~A0x1.~6,'0xp~:[~;+~]~D" sign-str fraction (not (minusp exponent)) exponent)))))) - -(defun print-hex-double-float (val &optional force-sign) - (multiple-value-bind (hi lo) (kernel:double-float-bits val) - (let* ((u-hi (ldb (byte 32 0) hi)) - (sign-bit (ldb (byte 1 31) u-hi)) - (biased-exp (ldb (byte 11 20) u-hi)) - (fraction (logior (ash (ldb (byte 20 0) u-hi) 32) lo)) - (sign-str (cond ((= sign-bit 1) "-") (force-sign "+") (t "")))) - (cond - ((= biased-exp #x7FF) (if (zerop fraction) (format nil "~Ainf" sign-str) "nan")) - ((and (zerop biased-exp) (zerop fraction)) (format nil "~A0x0.0000000000000p+0" sign-str)) - ((zerop biased-exp) (format nil "~A0x0.~13,'0xp-1022" sign-str fraction)) - (t (let ((exponent (- biased-exp 1023))) - (format nil "~A0x1.~13,'0xp~:[~;+~]~D" sign-str fraction (not (minusp exponent)) exponent))))))) - -#+nil -(defun print-hex-single-float (val &optional force-sign) - "Converts a single-float to a C-style hex string (32-bit)." - (let* ((bits (kernel:single-float-bits val)) - (u-bits (ldb (byte 32 0) bits)) - (sign-bit (ldb (byte 1 31) u-bits)) - (biased-exp (ldb (byte 8 23) u-bits)) - (fraction (ldb (byte 23 0) u-bits)) - (sign-str (cond ((= sign-bit 1) - "-") - (force-sign - "+") - (t - "")))) - (cond - ((= biased-exp 255) - (if (zerop fraction) - (format nil "~Ainf" sign-str) - "nan")) - ((and (zerop biased-exp) - (zerop fraction)) - (format nil "~A0x0.000000p+0" sign-str)) - ((zerop biased-exp) - (let ((*print-case* :downcase)) - (format nil "~A0x0.~6,'0xp-126" sign-str fraction))) - (t - (let ((*print-case* :downcase) - (exponent (- biased-exp 127))) - (format nil "~A0x1.~6,'0xp~:[~;+~]~D" - sign-str fraction (not (minusp exponent)) exponent)))))) - -#+nil -(defun print-hex-double-float (val &optional force-sign) - "Converts a double-float to a C-style hex string (64-bit)." - (multiple-value-bind (hi lo) - (kernel:double-float-bits val) - (let* ((u-hi (ldb (byte 32 0) hi)) - (sign-bit (ldb (byte 1 31) u-hi)) - (biased-exp (ldb (byte 11 20) u-hi)) - (fraction (logior (ash (ldb (byte 20 0) u-hi) 32) lo)) - (sign-str (cond ((= sign-bit 1) - "-") - (force-sign "+") - (t "")))) - (cond - ((= biased-exp #x7FF) - (if (zerop fraction) - (format nil "~Ainf" sign-str) - "nan")) - ((and (zerop biased-exp) - (zerop fraction)) - (format nil "~A0x0.0000000000000p+0" sign-str)) - ((zerop biased-exp) - (let ((*print-case* :downcase)) - (format nil "~A0x0.~13,'0xp-1022" sign-str fraction))) - (t - (let ((*print-case* :downcase) - (exponent (- biased-exp 1023))) - (format nil "~A0x1.~13,'0xp~:[~;+~]~D" - sign-str fraction (not (minusp exponent)) exponent))))))) - -;;; PRINT-HEX-FLOAT -- Public -;;; -;;; Return a string representing a single and double-floats in C-style -;;; hex format. -(defun print-hex-float (float) - "Convert FLOAT to C-style hex string. Infinities are printed as \"-inf\" - and \"inf\". NaN is printed as \"nan\"." - (declare (float float)) - (etypecase float - (single-float (print-hex-single-float float)) - (double-float (print-hex-double-float float)))) - -;;; FORMAT-HEX-FLOAT -- Public -;;; -;;; Function that can be used in a FORMAT ~/ -(defun format-hex-float (stream val &optional colon-p at-p &rest params) - "Format ~/ directive supporting @ (sign) modifier for single/double floats." - (declare (ignore colon-p params)) - (write-string - (typecase val - (single-float (print-hex-single-float val at-p)) - (double-float (print-hex-double-float val at-p)) - (t (format nil "~A" val))) - stream)) - -;;; PARSE-HEX-FLOAT -- Public -;;; -;;; Parse a C-style float hex strings. Always returns a double-float. -;;; Error-checking is enabled for malformed strings. -(define-condition hex-parse-error (error) - ((text :initarg :text :reader hex-parse-error-text) - (message :initarg :message :reader hex-parse-error-message)) - (:report (lambda (c s) - (format s "Hex float parse error in ~S: ~A" - (hex-parse-error-text c) (hex-parse-error-message c))))) - -(defun parse-hex-float (str) - "Parses C-style hex strings by converting to an exact rational, then to double-float." - (let* ((str (string-trim '(#\Space #\Tab #\Newline #\Return) (string-downcase str))) - (len (length str))) - (when (zerop len) (error 'hex-parse-error :text str :message "Empty string")) - (let* ((has-sign (or (char= (char str 0) #\-) (char= (char str 0) #\+))) - (sign (if (and has-sign (char= (char str 0) #\-)) -1 1)) - (start (if has-sign 1 0))) - (cond - ((string= str "inf" :start1 start) - (if (= sign 1) double-float-positive-infinity double-float-negative-infinity)) - ((string= str "nan" :start1 start) :nan) - (t - (unless (and (<= (+ start 2) len) (string= str "0x" :start1 start :end1 (+ start 2))) - (error 'hex-parse-error :text str :message "Missing '0x' prefix")) - (let ((p-pos (position #\p str :start start))) - (unless p-pos (error 'hex-parse-error :text str :message "Missing exponent 'p'")) - - (loop for i from start below len - when (member (char str i) '(#\Space #\Tab #\Newline #\Return)) - do (error 'hex-parse-error :text str :message "Internal whitespace detected")) - - (let* ((sig-start (+ start 2)) - (dot-pos (position #\. str :start sig-start :end p-pos)) - (exp-start (1+ p-pos))) - (when (or (= sig-start p-pos) - (and dot-pos (= (1+ sig-start) p-pos) (= sig-start dot-pos))) - (error 'hex-parse-error :text str :message "No hex digits in significand")) - - (handler-case - (let* ((frac-hex-len (if dot-pos (- p-pos (1+ dot-pos)) 0)) - ;; 1. Parse significand as one large integer - (significand-int - (if (null dot-pos) - (parse-integer str :start sig-start :end p-pos :radix 16) - (let ((leading (if (= sig-start dot-pos) 0 - (parse-integer str :start sig-start :end dot-pos :radix 16))) - (trailing (if (= (1+ dot-pos) p-pos) 0 - (parse-integer str :start (1+ dot-pos) :end p-pos :radix 16)))) - (+ (ash leading (* 4 frac-hex-len)) trailing)))) - ;; 2. Parse exponent - (raw-exponent (parse-integer str :start exp-start :end len)) - ;; 3. Build exact rational: significand / 16^frac-len * 2^exponent - (rational-val (* significand-int - (expt 2 (- raw-exponent (* 4 frac-hex-len)))))) - ;; 4. Coerce to double-float - (* sign (float rational-val 1.0d0))) - (error (c) (error 'hex-parse-error :text str :message (format nil "~A" c))))))))))) - -#+nil -(defun parse-hex-float (str) - "Parses C-style hex strings into double-floats using robust integer scaling." - (let* ((str (string-trim '(#\Space #\Tab #\Newline #\Return) (string-downcase str))) - (len (length str))) - (when (zerop len) (error 'hex-parse-error :text str :message "Empty string")) - (let* ((has-sign (or (char= (char str 0) #\-) (char= (char str 0) #\+))) - (sign (if (and has-sign (char= (char str 0) #\-)) -1 1)) - (start (if has-sign 1 0))) - (cond - ((string= str "inf" :start1 start) - (if (= sign 1) double-float-positive-infinity double-float-negative-infinity)) - ((string= str "nan" :start1 start) :nan) - (t - (unless (and (<= (+ start 2) len) (string= str "0x" :start1 start :end1 (+ start 2))) - (error 'hex-parse-error :text str :message "Missing '0x' prefix")) - (let ((p-pos (position #\p str :start start))) - (unless p-pos (error 'hex-parse-error :text str :message "Missing exponent 'p'")) - - (loop for i from start below len - when (member (char str i) '(#\Space #\Tab #\Newline #\Return)) - do (error 'hex-parse-error :text str :message "Internal whitespace detected")) - - (let* ((sig-start (+ start 2)) - (dot-pos (position #\. str :start sig-start :end p-pos)) - (exp-start (1+ p-pos))) - (when (or (= sig-start p-pos) - (and dot-pos (= (1+ sig-start) p-pos) (= sig-start dot-pos))) - (error 'hex-parse-error :text str :message "No hex digits in significand")) - - (handler-case - (let* ((frac-hex-len (if dot-pos (- p-pos (1+ dot-pos)) 0)) - (significand-int - (if (null dot-pos) - (parse-integer str :start sig-start :end p-pos :radix 16) - (let ((leading (if (= sig-start dot-pos) 0 - (parse-integer str :start sig-start :end dot-pos :radix 16))) - (trailing (if (= (1+ dot-pos) p-pos) 0 - (parse-integer str :start (1+ dot-pos) :end p-pos :radix 16)))) - (+ (ash leading (* 4 frac-hex-len)) trailing)))) - (raw-exponent (parse-integer str :start exp-start :end len)) - ;; A leading zero digit in hex-float notation denotes a subnormal-style format. - (starts-with-zero (char= (char str sig-start) #\0))) - - (let ((val (if starts-with-zero - ;; Subnormal path: Fixed binary floor of -1022. - ;; Shifted by (4 * frac-hex-len) to align integer bits. - (scale-float (float significand-int 1.0d0) - (- -1022 (* 4 frac-hex-len))) - ;; Normalized path: Use provided exponent, - ;; adjusted for the integer shift. - (scale-float (float significand-int 1.0d0) - (- raw-exponent (* 4 frac-hex-len)))))) - (* sign val))) - (error (c) (error 'hex-parse-error :text str :message (format nil "~A" c))))))))))) - - - - - -#+nil -(defun parse-hex-float (str) - "Parses C-style hex strings into double-floats. \"inf\" returns - DOUBLE-FLOAT-POSITIVE-INFINITY and \"-inf\" returns - DOUBLE-FLOAT-NEGATIVE-INFINITY. \"nan\" returns :NAN." - (let* ((str (string-trim '(#\Space #\Tab #\Newline #\Return) (string-downcase str))) - (len (length str))) - (when (zerop len) - (error 'hex-parse-error :text str :message "Empty string")) - (let* ((has-sign (or (char= (char str 0) #\-) - (char= (char str 0) #\+))) - (sign (if (and has-sign (char= (char str 0) #\-)) - -1 1)) - (start (if has-sign 1 0))) - (cond - ((string= str "inf" :start1 start) - (if (= sign 1) - double-float-positive-infinity - double-float-negative-infinity)) - ((string= str "nan" :start1 start) - :nan) - (t - (unless (and (<= (+ start 2) len) - (string= str "0x" :start1 start :end1 (+ start 2))) - (error 'hex-parse-error :text str :message "Missing '0x' prefix")) - (let ((p-pos (position #\p str :start start))) - (unless p-pos - (error 'hex-parse-error :text str :message "Missing exponent 'p'")) - (unless (loop for i from start below len - never (member (char str i) - '(#\Space #\Tab #\Newline #\Return))) - (error 'hex-parse-error :text str :message "Internal whitespace detected")) - (let* ((sig-start (+ start 2)) - (dot-pos (position #\. str :start sig-start :end p-pos)) - (exp-start (1+ p-pos))) - (when (or (= sig-start p-pos) - (and dot-pos - (= (1+ sig-start) p-pos) - (= sig-start dot-pos))) - (error 'hex-parse-error :text str :message "No hex digits in significand")) - (handler-case - (let* ((frac-hex-len (if dot-pos - (- p-pos (1+ dot-pos)) - 0)) - (significand-int - (if (null dot-pos) - (parse-integer str :start sig-start :end p-pos :radix 16) - (let ((leading (if (= sig-start dot-pos) - 0 - (parse-integer str :start sig-start :end dot-pos :radix 16))) - (trailing (if (= (1+ dot-pos) p-pos) - 0 - (parse-integer str :start (1+ dot-pos) :end p-pos :radix 16)))) - (+ (ash leading (* 4 frac-hex-len)) - trailing)))) - (raw-exponent (parse-integer str :start exp-start :end len)) - ;; Scale: each fractional nibble reduces binary exponent by 4 - (val (scale-float (float significand-int 1.0d0) - (- raw-exponent - (* 4 frac-hex-len))))) - (* sign val)) - (error (c) - (error 'hex-parse-error :text str :message (format nil "~A" c))))))))))) ===================================== src/tools/worldcom.lisp ===================================== @@ -221,6 +221,7 @@ (comf "target:code/misc") (comf "target:code/misc-doc") (comf "target:code/extensions" :byte-compile t) +(comf "target:code/ext-code") (comf "target:code/commandline") (comf "target:code/env-access") ===================================== src/tools/worldload.lisp ===================================== @@ -44,6 +44,7 @@ (maybe-byte-load "target:code/extensions") +(maybe-byte-load "target:code/ext-code") (maybe-byte-load "target:code/defmacro") (maybe-byte-load "target:code/sysmacs") View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/6af9a683c80afc2d9e8907a… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/6af9a683c80afc2d9e8907a… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-474-print-parse-hex-floats] Convert the string to a rational then to a float
by Raymond Toy (＠rtoy) 22 Feb '26

22 Feb '26

Raymond Toy pushed to branch issue-474-print-parse-hex-floats at cmucl / cmucl Commits: b298deb6 by Raymond Toy at 2026-02-22T13:23:44-08:00 Convert the string to a rational then to a float The previous algorithm was rather buggy dealing with numbers at the denormal boundary. Instead, we convert the string to an exact rational and then convert that to a float. I asked Gemini to make this change. - - - - - 1 changed file: - src/code/extensions.lisp Changes: ===================================== src/code/extensions.lisp ===================================== @@ -851,6 +851,56 @@ (format s "Hex float parse error in ~S: ~A" (hex-parse-error-text c) (hex-parse-error-message c))))) +(defun parse-hex-float (str) + "Parses C-style hex strings by converting to an exact rational, then to double-float." + (let* ((str (string-trim '(#\Space #\Tab #\Newline #\Return) (string-downcase str))) + (len (length str))) + (when (zerop len) (error 'hex-parse-error :text str :message "Empty string")) + (let* ((has-sign (or (char= (char str 0) #\-) (char= (char str 0) #\+))) + (sign (if (and has-sign (char= (char str 0) #\-)) -1 1)) + (start (if has-sign 1 0))) + (cond + ((string= str "inf" :start1 start) + (if (= sign 1) double-float-positive-infinity double-float-negative-infinity)) + ((string= str "nan" :start1 start) :nan) + (t + (unless (and (<= (+ start 2) len) (string= str "0x" :start1 start :end1 (+ start 2))) + (error 'hex-parse-error :text str :message "Missing '0x' prefix")) + (let ((p-pos (position #\p str :start start))) + (unless p-pos (error 'hex-parse-error :text str :message "Missing exponent 'p'")) + + (loop for i from start below len + when (member (char str i) '(#\Space #\Tab #\Newline #\Return)) + do (error 'hex-parse-error :text str :message "Internal whitespace detected")) + + (let* ((sig-start (+ start 2)) + (dot-pos (position #\. str :start sig-start :end p-pos)) + (exp-start (1+ p-pos))) + (when (or (= sig-start p-pos) + (and dot-pos (= (1+ sig-start) p-pos) (= sig-start dot-pos))) + (error 'hex-parse-error :text str :message "No hex digits in significand")) + + (handler-case + (let* ((frac-hex-len (if dot-pos (- p-pos (1+ dot-pos)) 0)) + ;; 1. Parse significand as one large integer + (significand-int + (if (null dot-pos) + (parse-integer str :start sig-start :end p-pos :radix 16) + (let ((leading (if (= sig-start dot-pos) 0 + (parse-integer str :start sig-start :end dot-pos :radix 16))) + (trailing (if (= (1+ dot-pos) p-pos) 0 + (parse-integer str :start (1+ dot-pos) :end p-pos :radix 16)))) + (+ (ash leading (* 4 frac-hex-len)) trailing)))) + ;; 2. Parse exponent + (raw-exponent (parse-integer str :start exp-start :end len)) + ;; 3. Build exact rational: significand / 16^frac-len * 2^exponent + (rational-val (* significand-int + (expt 2 (- raw-exponent (* 4 frac-hex-len)))))) + ;; 4. Coerce to double-float + (* sign (float rational-val 1.0d0))) + (error (c) (error 'hex-parse-error :text str :message (format nil "~A" c))))))))))) + +#+nil (defun parse-hex-float (str) "Parses C-style hex strings into double-floats using robust integer scaling." (let* ((str (string-trim '(#\Space #\Tab #\Newline #\Return) (string-downcase str))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/b298deb612b2eef3f1012db… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/b298deb612b2eef3f1012db… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-474-print-parse-hex-floats
by Raymond Toy (＠rtoy) 22 Feb '26

22 Feb '26

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

1 0

[Git][cmucl/cmucl][issue-475-update-core-math] Update irrat.c for changes in the core-math binary64 code
by Raymond Toy (＠rtoy) 21 Feb '26

21 Feb '26

Raymond Toy pushed to branch issue-475-update-core-math at cmucl / cmucl Commits: b86eb7ce by Raymond Toy at 2026-02-20T19:08:16-08:00 Update irrat.c for changes in the core-math binary64 code We don't need some of the special cases anymore. In particular exp(-1000) signals underflow now. Some of the trig functions now signal invalid for inf so we don't need our checks either. - - - - - 1 changed file: - src/lisp/irrat.c Changes: ===================================== src/lisp/irrat.c ===================================== @@ -53,8 +53,9 @@ double lisp_sin(double x) { #ifdef FEATURE_CORE_MATH +#if 0 MAYBE_SIGNAL_INVALID(isinf(x), x) - +#endif return cr_sin(x); #else return fdlibm_sin(x); @@ -77,8 +78,9 @@ double lisp_tan(double x) { #ifdef FEATURE_CORE_MATH +#if 0 MAYBE_SIGNAL_INVALID(isinf(x), x) - +#endif return cr_tan(x); #else return fdlibm_tan(x); @@ -129,8 +131,9 @@ double lisp_sinh(double x) { #ifdef FEATURE_CORE_MATH +#if 0 MAYBE_SIGNAL_OVERFLOW(x) - +#endif return cr_sinh(x); #else return __ieee754_sinh(x); @@ -176,7 +179,7 @@ lisp_acosh(double x) MAYBE_SIGNAL_INVALID(x < 1, x) MAYBE_SIGNAL_OVERFLOW(x) - + return cr_acosh(x); #else return __ieee754_acosh(x); @@ -197,27 +200,6 @@ double lisp_exp(double x) { #ifdef FEATURE_CORE_MATH - /* - * For consistency, silently return NaN when x is NaN. Do not - * signal an invalid operation, even if invalid operation trap is - * enabled. This is what fdlibm does, and also what many of the - * other core-math routines do. - */ - - if (isnan(x)) { - return x; - } - - /* - * Can't depend on cr_exp to signal underflow. It seems the - * underflow has been constant-folded to zero. Hence, check for - * underflow here and explicitly signal an underflow. The - * constant here is from core-math exp.c. - */ - if (x <= -0x1.74910d52d3052p+9) { - return fdlibm_setexception(0.0, FDLIBM_UNDERFLOW); - } - return cr_exp(x); #else return __ieee754_exp(x); View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/b86eb7ce1716decabd6f345… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/b86eb7ce1716decabd6f345… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-475-update-core-math
by Raymond Toy (＠rtoy) 21 Feb '26

21 Feb '26

Raymond Toy pushed new branch issue-475-update-core-math at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-475-update-core-math You're receiving this email because of your account on gitlab.common-lisp.net.

1 0