From 570a8df298d55167d4b2ebb5a437272bfcf569f7 Mon Sep 17 00:00:00 2001 From: "Tarn W. Burton" Date: Sun, 18 Aug 2024 10:07:54 -0400 Subject: [PATCH] Update to quaviver:triple-float and add underflow detection --- code/reader/additional-conditions.lisp | 7 +++++++ code/reader/messages-english.lisp | 12 ++++++++++++ code/reader/package.lisp | 1 + code/reader/tokens.lisp | 24 +++++++++++++++++++++--- test/reader/tokens.lisp | 23 +++++++++++++++++++++-- 5 files changed, 62 insertions(+), 5 deletions(-) diff --git a/code/reader/additional-conditions.lisp b/code/reader/additional-conditions.lisp index 51b42ce..3cf175d 100644 --- a/code/reader/additional-conditions.lisp +++ b/code/reader/additional-conditions.lisp @@ -268,6 +268,13 @@ (%mantissa :initarg :mantissa :reader mantissa) (%exponent :initarg :exponent :reader exponent))) +(define-condition underflow-in-float (stream-position-reader-error + floating-point-underflow + float-format-condition) + ((%sign :initarg :sign :reader sign) + (%mantissa :initarg :mantissa :reader mantissa) + (%exponent :initarg :exponent :reader exponent))) + ;;; Conditions related to block comments (define-condition unterminated-block-comment (missing-delimiter) diff --git a/code/reader/messages-english.lisp b/code/reader/messages-english.lisp index 13a4fc2..ba9bcae 100644 --- a/code/reader/messages-english.lisp +++ b/code/reader/messages-english.lisp @@ -361,6 +361,18 @@ 'cl:*read-default-float-format* (float-format condition))) + (define-reporter ((condition underflow-in-float) stream) + (format stream "~@" + #+maybe " Failed operation was ~ + (~A~{~^ ~A~}).~@:>" + (sign condition) + (mantissa condition) + (exponent condition) + (float-format condition) + #+maybe (arithmetic-error-operation condition) + #+maybe (arithmetic-error-operands condition))) + (define-reporter ((condition overflow-in-float) stream) (format stream "~@" diff --git a/code/reader/package.lisp b/code/reader/package.lisp index 8acf084..4febc4c 100644 --- a/code/reader/package.lisp +++ b/code/reader/package.lisp @@ -221,6 +221,7 @@ #:invalid-radix #:invalid-default-float-format #:overflow-in-float + #:underflow-in-float #:unterminated-block-comment diff --git a/code/reader/tokens.lisp b/code/reader/tokens.lisp index ae2678a..ef5803a 100644 --- a/code/reader/tokens.lisp +++ b/code/reader/tokens.lisp @@ -222,9 +222,28 @@ 0) decimal-exponent))) (handler-case - (quaviver:integer-float + (quaviver:triple-float (load-time-value (make-instance 'quaviver/liebler:client)) ; TODO: temporary type 10 significand exponent sign) + (floating-point-underflow (condition) + (let ((length (+ (length (format nil "~D~:[~;E~:[~;+~]~2:*~D~]" + (* sign significand) (when exponentp (exponent)) exponent-sign)) ; TODO: don't call it again + (if (zerop decimal-exponent) 0 1) ; TODO not accurate + ))) + ;; The condition report might print the objects passed as + ;; `:operands' which is fine since we pass truncated values. + (%recoverable-reader-error + input-stream 'underflow-in-float + :position-offset (- length) ; `stream-position-condition' + :operation (arithmetic-error-operation condition) ; `arithmetic-error' + :operands (arithmetic-error-operands condition) ; `arithmetic-error' + :float-format type ; `float-format-condition' + :sign sign ; `underflow-in-float' + :mantissa significand ; `underflow-in-float' + :exponent exponent ; `underflow-in-float' + :report 'use-replacement-float-format ; TODO report + ) + (quaviver:triple-float nil type 2 0 0 sign))) (floating-point-overflow (condition) (let ((length (+ (length (format nil "~D~:[~;E~:[~;+~]~2:*~D~]" (* sign significand) (when exponentp (exponent)) exponent-sign)) ; TODO: don't call it again @@ -243,8 +262,7 @@ :exponent exponent ; `overflow-in-float' :report 'use-replacement-float-format ; TODO report ) - ;; TODO: most extreme value instead? - (coerce 1.0 type)))))))) + (quaviver:triple-float nil type 2 0 :infinity sign)))))))) (macrolet ((next-cond ((char-var &optional return-symbol-if-eoi (colon-go-symbol t)) &body clauses) diff --git a/test/reader/tokens.lisp b/test/reader/tokens.lisp index 52e3ca3..1436a12 100644 --- a/test/reader/tokens.lisp +++ b/test/reader/tokens.lisp @@ -406,11 +406,30 @@ '(("1.0" () 10 :upcase eclector.reader:invalid-default-float-format 3 0) ("1e0" () 10 :upcase eclector.reader:invalid-default-float-format 1 1))))) +(test interpret-token.default/floating-point-underflow + "Make sure that too large exponents signal a UNDERFLOW-IN-FLOAT condition." + (mapc #'do-interpret-token-test-case + '(("1e-1000000" () 10 :upcase eclector.reader:underflow-in-float 0 10) + ("1s-1000000" () 10 :upcase eclector.reader:underflow-in-float 0 10) + ("1f-1000000" () 10 :upcase eclector.reader:underflow-in-float 0 10) + ("1d-1000000" () 10 :upcase eclector.reader:underflow-in-float 0 10) + ("1l-1000000" () 10 :upcase eclector.reader:underflow-in-float 0 10) + ("-1e-1000000" () 10 :upcase eclector.reader:underflow-in-float 0 11) + ("-1s-1000000" () 10 :upcase eclector.reader:underflow-in-float 0 11) + ("-1f-1000000" () 10 :upcase eclector.reader:underflow-in-float 0 11) + ("-1d-1000000" () 10 :upcase eclector.reader:underflow-in-float 0 11) + ("-1l-1000000" () 10 :upcase eclector.reader:underflow-in-float 0 11)))) + (test interpret-token.default/floating-point-overflow "Make sure that too large exponents signal a OVERFLOW-IN-FLOAT condition." (mapc #'do-interpret-token-test-case '(("1e1000000" () 10 :upcase eclector.reader:overflow-in-float 0 9) + ("1s1000000" () 10 :upcase eclector.reader:overflow-in-float 0 9) ("1f1000000" () 10 :upcase eclector.reader:overflow-in-float 0 9) ("1d1000000" () 10 :upcase eclector.reader:overflow-in-float 0 9) - ("1d+1000000" () 10 :upcase eclector.reader:overflow-in-float 0 10) - ("-1d+1000000" () 10 :upcase eclector.reader:overflow-in-float 0 10)))) + ("1l1000000" () 10 :upcase eclector.reader:overflow-in-float 0 9) + ("-1e1000000" () 10 :upcase eclector.reader:overflow-in-float 0 10) + ("-1s1000000" () 10 :upcase eclector.reader:overflow-in-float 0 10) + ("-1f1000000" () 10 :upcase eclector.reader:overflow-in-float 0 10) + ("-1d1000000" () 10 :upcase eclector.reader:overflow-in-float 0 10) + ("-1l1000000" () 10 :upcase eclector.reader:overflow-in-float 0 10))))