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