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

[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

[Git][cmucl/cmucl][issue-425-correctly-rounded-math-functions-single-float] 2 commits: Add tests for %powf based on the tests for %pow
by Raymond Toy (＠rtoy) 19 Feb '26

19 Feb '26

Raymond Toy pushed to branch issue-425-correctly-rounded-math-functions-single-float at cmucl / cmucl Commits: a5f3dc8a by Raymond Toy at 2026-02-18T19:22:08-08:00 Add tests for %powf based on the tests for %pow There are currently many failed tests: (FDLIBM-TESTS::%POWF.CASE.13 FDLIBM-TESTS::%POWF.CASE.12 FDLIBM-TESTS::%POWF.CASE.9 FDLIBM-TESTS::%POWF.CASE.8 FDLIBM-TESTS::%POWF.CASE.5 FDLIBM-TESTS::%POWF.CASE.4 FDLIBM-TESTS::%POWF.CASE.3) - - - - - 59387511 by Raymond Toy at 2026-02-18T19:41:20-08:00 Use single-float versions of qNaN and sNaN In a few places we forgot to use the single-float versions of `*qnan*` and `*snan*`. This fixes many tests, but we still fail (FDLIBM-TESTS::%POWF.CASE.13 FDLIBM-TESTS::%POWF.CASE.12 FDLIBM-TESTS::%POWF.CASE.8 FDLIBM-TESTS::%POWF.CASE.5) These signal division-by-zero instead of silently returning an infinity. - - - - - 1 changed file: - tests/fdlibm.lisp Changes: ===================================== tests/fdlibm.lisp ===================================== @@ -1062,6 +1062,14 @@ (assert-equal 1d0 (kernel:%pow ext:double-float-negative-infinity 0d0))) +(define-test %powf.case.1 + (:tag :fdlibm) + ;; anything ^ 0 is 1 + (assert-equal 1f0 + (kernel:%powf ext:single-float-positive-infinity 0f0)) + (assert-equal 1f0 + (kernel:%powf ext:single-float-negative-infinity 0f0))) + (define-test %pow.case.2 (:tag :fdlibm) ;; anything ^ 1 is itself @@ -1070,6 +1078,14 @@ (assert-equal ext:double-float-negative-infinity (kernel:%pow ext:double-float-negative-infinity 1d0))) +(define-test %powf.case.2 + (:tag :fdlibm) + ;; anything ^ 1 is itself + (assert-equal ext:single-float-positive-infinity + (kernel:%powf ext:single-float-positive-infinity 1f0)) + (assert-equal ext:single-float-negative-infinity + (kernel:%powf ext:single-float-negative-infinity 1f0))) + (define-test %pow.case.3 (:tag :fdlibm) ;; anything ^ NaN is NaN @@ -1078,6 +1094,14 @@ (assert-true (ext:float-nan-p (kernel:%pow ext:double-float-positive-infinity *qnan*)))) +(define-test %powf.case.3 + (:tag :fdlibm) + ;; anything ^ NaN is NaN + (assert-true (ext:float-nan-p + (kernel:%powf (float pi 1f0) *qnan-single-float*))) + (assert-true (ext:float-nan-p + (kernel:%powf ext:single-float-positive-infinity *qnan-single-float*)))) + (define-test %pow.case.4 (:tag :fdlibm) ;; NaN ^ non-zero is NaN @@ -1086,6 +1110,14 @@ (assert-true (ext:float-nan-p (kernel:%pow *qnan* ext:double-float-positive-infinity)))) +(define-test %powf.case.4 + (:tag :fdlibm) + ;; NaN ^ non-zero is NaN + (assert-true (ext:float-nan-p + (kernel:%powf *qnan-single-float* (float pi 1f0)))) + (assert-true (ext:float-nan-p + (kernel:%powf *qnan-single-float* ext:single-float-positive-infinity)))) + (define-test %pow.case.5 (:tag :fdlibm) ;; (|x| > 1) ^ +inf is +inf @@ -1094,6 +1126,14 @@ (assert-equal ext:double-float-positive-infinity (kernel:%pow (- pi) ext:double-float-positive-infinity))) +(define-test %powf.case.5 + (:tag :fdlibm) + ;; (|x| > 1) ^ +inf is +inf + (assert-equal ext:single-float-positive-infinity + (kernel:%powf (float pi 1f0) ext:single-float-positive-infinity)) + (assert-equal ext:single-float-positive-infinity + (kernel:%powf (float (- pi) 1f0) ext:single-float-positive-infinity))) + (define-test %pow.case.6 (:tag :fdlibm) ;; (|x| > 1) ^ -inf is +0 @@ -1102,6 +1142,14 @@ (assert-equal +0d0 (kernel:%pow (- pi) ext:double-float-negative-infinity))) +(define-test %powf.case.6 + (:tag :fdlibm) + ;; (|x| > 1) ^ -inf is +0 + (assert-equal +0f0 + (kernel:%powf (float pi 1f0) ext:single-float-negative-infinity)) + (assert-equal +0f0 + (kernel:%powf (float (- pi) 1f0) ext:single-float-negative-infinity))) + (define-test %pow.case.7 (:tag :fdlibm) ;; (|x| < 1) ^ +inf is +0 @@ -1110,6 +1158,14 @@ (assert-equal +0d0 (kernel:%pow -0.5d0 ext:double-float-positive-infinity))) +(define-test %powf.case.7 + (:tag :fdlibm) + ;; (|x| < 1) ^ +inf is +0 + (assert-equal +0f0 + (kernel:%powf 0.5f0 ext:single-float-positive-infinity)) + (assert-equal +0f0 + (kernel:%powf -0.5f0 ext:single-float-positive-infinity))) + (define-test %pow.case.8 (:tag :fdlibm) ;; (|x| < 1) ^ -inf is +inf @@ -1118,6 +1174,14 @@ (assert-equal ext:double-float-positive-infinity (kernel:%pow -0.5d0 ext:double-float-negative-infinity))) +(define-test %powf.case.8 + (:tag :fdlibm) + ;; (|x| < 1) ^ -inf is +inf + (assert-equal ext:single-float-positive-infinity + (kernel:%powf 0.5f0 ext:single-float-negative-infinity)) + (assert-equal ext:single-float-positive-infinity + (kernel:%powf -0.5f0 ext:single-float-negative-infinity))) + (define-test %pow.case.9 (:tag :fdlibm) ;; std::pow says 1^exp is 1 for any exp, including NaN. (-1)^(+/-inf) @@ -1159,6 +1223,47 @@ (assert-true (ext:float-nan-p (kernel:%pow -1d0 ext:double-float-negative-infinity)))))) +(define-test %powf.case.9 + (:tag :fdlibm) + ;; std::pow says 1^exp is 1 for any exp, including NaN. (-1)^(+/-inf) + ;; is 1. No errors signaled. + #+core-math + (progn + (assert-equal 1f0 + (kernel:%powf 1f0 ext:single-float-positive-infinity)) + (assert-equal 1f0 + (kernel:%powf 1f0 ext:single-float-negative-infinity)) + (assert-equal 1f0 + (kernel:%powf 1f0 *qnan-single-float*)) + (assert-equal 1f0 + (kernel:%powf -1f0 ext:single-float-positive-infinity)) + (assert-equal 1f0 + (kernel:%powf -1f0 ext:single-float-negative-infinity))) + #-core-math + ;; +-1 ^ +-inf is NaN. + ;; + ;; But the implementation signals invalid operation, so we need to + ;; check for that. + ;; + (progn + (assert-error 'floating-point-invalid-operation + (kernel:%powf 1f0 ext:single-float-positive-infinity)) + (assert-error 'floating-point-invalid-operation + (kernel:%powf 1f0 ext:single-float-negative-infinity)) + (assert-error 'floating-point-invalid-operation + (kernel:%powf -1f0 ext:single-float-positive-infinity)) + (assert-error 'floating-point-invalid-operation + (kernel:%powf -1f0 ext:single-float-negative-infinity)) + (ext:with-float-traps-masked (:invalid) + (assert-true (ext:float-nan-p + (kernel:%powf 1f0 ext:single-float-positive-infinity))) + (assert-true (ext:float-nan-p + (kernel:%powf 1f0 ext:single-float-negative-infinity))) + (assert-true (ext:float-nan-p + (kernel:%powf -1f0 ext:single-float-positive-infinity))) + (assert-true (ext:float-nan-p + (kernel:%powf -1f0 ext:single-float-negative-infinity)))))) + (define-test %pow.case.10 (:tag :fdlibm) ;; +0 ^ (+anything except 0, Nan) is +0 @@ -1167,6 +1272,14 @@ (assert-equal +0d0 (kernel:%pow +0d0 ext:double-float-positive-infinity))) +(define-test %powf.case.10 + (:tag :fdlibm) + ;; +0 ^ (+anything except 0, Nan) is +0 + (assert-equal +0f0 + (kernel:%powf +0f0 10f0)) + (assert-equal +0f0 + (kernel:%powf +0f0 ext:single-float-positive-infinity))) + (define-test %pow.case.11 (:tag :fdlibm) ;; +0 ^ (+anything except 0, Nan, odd integer) is +0 @@ -1175,6 +1288,14 @@ (assert-equal +0d0 (kernel:%pow -0d0 ext:double-float-positive-infinity))) +(define-test %powf.case.11 + (:tag :fdlibm) + ;; +0 ^ (+anything except 0, Nan, odd integer) is +0 + (assert-equal +0f0 + (kernel:%powf -0f0 10f0)) + (assert-equal +0f0 + (kernel:%powf -0f0 ext:single-float-positive-infinity))) + (define-test %pow.case.12 (:tag :fdlibm) ;; +0 ^ (-anything except 0, Nan) is +inf @@ -1189,6 +1310,22 @@ (assert-equal ext:double-float-positive-infinity (kernel:%pow +0d0 ext:double-float-negative-infinity))) +(define-test %powf.case.12 + (:tag :fdlibm) + ;; +0 ^ (-anything except 0, Nan) is +inf + ;; + ;; But fdlibm signals error for (+0)^(-10) instead of returning inf. Check this. + #+nil + (assert-error 'division-by-zero + (kernel:%powf +0f0 -10f0)) + #+nil + (ext:with-float-traps-masked (:divide-by-zero) + (assert-equal ext:single-float-positive-infinity + (kernel:%powf +0f0 -10f0))) + ;; No signals here. + (assert-equal ext:single-float-positive-infinity + (kernel:%powf +0f0 ext:single-float-negative-infinity))) + (define-test %pow.case.13 (:tag :fdlibm) ;; -0 ^ (-anything except 0, Nan, odd integer) is +inf @@ -1203,24 +1340,56 @@ (assert-equal ext:double-float-positive-infinity (kernel:%pow +0d0 ext:double-float-negative-infinity))) +(define-test %powf.case.13 + (:tag :fdlibm) + ;; -0 ^ (-anything except 0, Nan, odd integer) is +inf + ;; + ;; But (-0)^(-10) signals division by zero + (assert-error 'division-by-zero + (kernel:%powf -0f0 -10f0)) + (ext:with-float-traps-masked (:divide-by-zero) + (assert-equal ext:single-float-positive-infinity + (kernel:%powf -0f0 -10f0))) + ;; But no error here. + (assert-equal ext:single-float-positive-infinity + (kernel:%powf +0f0 ext:single-float-negative-infinity))) + (define-test %pow.case.14 (:tag :fdlibm) ;; -0 ^ (odd integer) = -( +0 ^ (odd integer)) (assert-equal (- (kernel:%pow +0d0 5d0)) (kernel:%pow -0d0 5d0))) +(define-test %powf.case.14 + (:tag :fdlibm) + ;; -0 ^ (odd integer) = -( +0 ^ (odd integer)) + (assert-equal (- (kernel:%powf +0f0 5f0)) + (kernel:%powf -0f0 5f0))) + (define-test %pow.case.15 (:tag :fdlibm) ;; +inf ^ (+anything except 0, NaN) is +inf (assert-equal ext:double-float-positive-infinity (kernel:%pow ext:double-float-positive-infinity pi))) +(define-test %powf.case.15 + (:tag :fdlibm) + ;; +inf ^ (+anything except 0, NaN) is +inf + (assert-equal ext:single-float-positive-infinity + (kernel:%powf ext:single-float-positive-infinity (float pi 1f0)))) + (define-test %pow.case.16 (:tag :fdlibm) ;; +inf ^ (-anything except 0, NaN) is +0 (assert-equal +0d0 (kernel:%pow ext:double-float-positive-infinity (- pi)))) +(define-test %powf.case.16 + (:tag :fdlibm) + ;; +inf ^ (-anything except 0, NaN) is +0 + (assert-equal +0f0 + (kernel:%powf ext:single-float-positive-infinity (float (- pi) 1f0)))) + (define-test %pow.case.17 (:tag :fdlibm) ;; -inf ^ (anything) = -0 ^ (-anything) @@ -1232,6 +1401,17 @@ (assert-equal (kernel:%pow -0d0 pi) (kernel:%pow ext:double-float-negative-infinity (- pi)))) +(define-test %powf.case.17 + (:tag :fdlibm) + ;; -inf ^ (anything) = -0 ^ (-anything) + (assert-equal (ext:with-float-traps-masked (:divide-by-zero) + ;; This produces a divide-by-zero error so mask it + ;; to get a value. + (kernel:%powf -0f0 (float (- pi) 1f0))) + (kernel:%powf ext:single-float-negative-infinity (float pi 1f0))) + (assert-equal (kernel:%powf -0f0 (float pi 1f0)) + (kernel:%powf ext:single-float-negative-infinity (float (- pi) 1f0)))) + (define-test %pow.case.18 (:tag :fdlibm) ;; (-anything) ^ integer is (-1)^integer * (+anything ^ integer) @@ -1242,6 +1422,16 @@ (kernel:%pow base (coerce power 'double-float)) base power)))) +(define-test %powf.case.18 + (:tag :fdlibm) + ;; (-anything) ^ integer is (-1)^integer * (+anything ^ integer) + (dolist (base '(-2f0 -10f0)) + (dolist (power '(5 -5)) + (assert-equal (* (expt -1 power) + (kernel:%powf (- base) (coerce power 'single-float))) + (kernel:%powf base (coerce power 'single-float)) + base power)))) + (define-test %pow.case.19 (:tag :fdlibm) ;; (-anything except 0 and inf) ^ non-integer is NaN @@ -1252,3 +1442,14 @@ (ext:with-float-traps-masked (:invalid) (assert-true (ext:float-nan-p (kernel:%pow -2d0 1.5d0))))) + +(define-test %powf.case.19 + (:tag :fdlibm) + ;; (-anything except 0 and inf) ^ non-integer is NaN + ;; + ;; But this signals invalid, so check for that too. + (assert-error 'floating-point-invalid-operation + (kernel:%powf -2f0 1.5f0)) + (ext:with-float-traps-masked (:invalid) + (assert-true (ext:float-nan-p + (kernel:%powf -2f0 1.5f0))))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/84314210c115db75920939… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/84314210c115db75920939… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] Update list of fixed tickets
by Raymond Toy (＠rtoy) 18 Feb '26

18 Feb '26

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 3434a963 by Raymond Toy at 2026-02-18T10:53:11-08:00 Update list of fixed tickets [skip-ci] - - - - - 1 changed file: - src/general-info/release-22a.md Changes: ===================================== src/general-info/release-22a.md ===================================== @@ -28,20 +28,35 @@ public domain. * #373: Add macros to handle temp files and directories * #387: Update CLX from upstream to version from 2024-09-11 * #408: Add C functions to get user name and home dir + * #424: Use fdlibm `hypot` to implement the `hypot` function + instead of using the version from libm. + * #426: Type `float-modes` is incorrect for x87 FPU modes * #428: Add some constants for common values in irrat.lisp + * #431: `set-floating-point-modes` incorrectly clears out x87 + precision and rounding modes * #437: Use `realpath` to find the lisp executable + * #441: Fedora 42 unable to compile core-math pow.c function + * #443: cim-info.tar.bz2 missing from cmucl.org * #444: `unix-stat` and friends return wrong timestamp + * #446: Simplify getting the errno values. * #449: Touch 64-bit timestamp.txt with desired time for testing * #446: Use C compiler to get errno values to update UNIX defpackage with errno symbols + * #452: Move bin/errno-foo.lisp to src/tools. * #453: Use correct flags for analyzer and always save logs. + * #454: `make-pathname` signals errors for "silly" values. * #456: Improve accuracy for division of complex double-floats using Baudin and Smith's robust complex division algorithm with improvements by Patrick McGehearty. - * #458: Spurious overflow in double-double-float multiply - * #459: Improve accuracy for division of complex + * #457: `delete-directory` was not returning anything so you + couldn't tell if it succeeded or not. + * #458: Spurious overflow in double-double-float multiply. + * #459: Improve accuracy for division of complex. double-double-floats. The same algorithm is used here as for #456. + * #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` * Other changes: * Improvements to the PCL implementation of CLOS: * Changes to building procedure: View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/3434a96310bce31753072e7… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/3434a96310bce31753072e7… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-425-correctly-rounded-math-functions-single-float] 3 commits: Fix #473: Signal underflow with core-math exp
by Raymond Toy (＠rtoy) 18 Feb '26

18 Feb '26

Raymond Toy pushed to branch issue-425-correctly-rounded-math-functions-single-float at cmucl / cmucl Commits: 9bf28346 by Raymond Toy at 2026-02-18T07:18:07-08:00 Fix #473: Signal underflow with core-math exp - - - - - b26718dd by Raymond Toy at 2026-02-18T07:18:07-08:00 Merge branch 'issue-473-make-cr-exp-signal-underflow' into 'master' Fix #473: Signal underflow with core-math exp Closes #473 See merge request cmucl/cmucl!351 - - - - - 84314210 by Raymond Toy at 2026-02-18T07:19:08-08:00 Merge branch 'master' into issue-425-correctly-rounded-math-functions-single-float - - - - - 0 changed files: Changes: View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/7fa0f3c1b96345e130abba… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/7fa0f3c1b96345e130abba… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Fix #473: Signal underflow with core-math exp
by Raymond Toy (＠rtoy) 18 Feb '26

18 Feb '26

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 9bf28346 by Raymond Toy at 2026-02-18T07:18:07-08:00 Fix #473: Signal underflow with core-math exp - - - - - b26718dd by Raymond Toy at 2026-02-18T07:18:07-08:00 Merge branch 'issue-473-make-cr-exp-signal-underflow' into 'master' Fix #473: Signal underflow with core-math exp Closes #473 See merge request cmucl/cmucl!351 - - - - - 2 changed files: - src/lisp/irrat.c - tests/fdlibm.lisp Changes: ===================================== src/lisp/irrat.c ===================================== @@ -40,7 +40,7 @@ extern void cr_sincos(double, double *, double *); */ #define MAYBE_SIGNAL_INVALID(test, val) \ - if ((test)) { \ + if ((test)) { \ return fdlibm_setexception(val, FDLIBM_INVALID); \ } @@ -197,6 +197,27 @@ 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); ===================================== tests/fdlibm.lisp ===================================== @@ -210,13 +210,9 @@ (ext:with-float-traps-masked (:overflow) (assert-equal ext:double-float-positive-infinity (kernel:%exp 710d0))) - (let ((modes (ext:get-floating-point-modes))) - (unwind-protect - (progn - (ext:set-floating-point-modes :traps '(:underflow)) - (assert-error 'floating-point-underflow - (kernel:%exp -1000d0))) - (apply #'ext:set-floating-point-modes modes))) + (ext:with-float-traps-enabled (:underflow) + (assert-error 'floating-point-underflow + (kernel:%exp -1000d0))) (let ((x (scale-float 1d0 -29)) (x0 0d0)) ;; exp(x) = x, |x| < 2^-28, with inexact exception unlees x = 0 View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/53a087cadc014ec991da88… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/53a087cadc014ec991da88… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0