diff --git a/code/reader/additional-conditions.lisp b/code/reader/additional-conditions.lisp index a282f82..6557989 100644 --- a/code/reader/additional-conditions.lisp +++ b/code/reader/additional-conditions.lisp @@ -192,7 +192,7 @@ (%found-character :initarg :found-character :reader found-character))) -;;; Conditions related to SHARPSIGN-DOT +;;; Conditions related to function literals (define-condition end-of-input-after-sharpsign-single-quote (end-of-file incomplete-construct) @@ -254,9 +254,19 @@ (define-condition invalid-radix (stream-position-reader-error) ((%radix :initarg :radix :reader radix))) -(define-condition invalid-default-float-format (stream-position-reader-error) - ((%exponent-marker :initarg :exponent-marker :reader exponent-marker) - (%float-format :initarg :float-format :reader float-format))) +(define-condition float-format-condition (condition) + ((%float-format :initarg :float-format :reader float-format))) + +(define-condition invalid-default-float-format (stream-position-reader-error + float-format-condition) + ((%exponent-marker :initarg :exponent-marker :reader exponent-marker))) + +(define-condition overflow-in-float (stream-position-reader-error + floating-point-overflow + float-format-condition) + ((%sign :initarg :sign :reader sign) + (%mantissa :initarg :mantissa :reader mantissa) + (%exponent :initarg :exponent :reader exponent))) ;;; Conditions related to block comments diff --git a/code/reader/generic-functions.lisp b/code/reader/generic-functions.lisp index 66b9a75..e232bde 100644 --- a/code/reader/generic-functions.lisp +++ b/code/reader/generic-functions.lisp @@ -141,17 +141,52 @@ (define-kind number-kind (literal-kind) ()) +;;; Taken from SBCL code +;;; Truncate EXPONENT if it's too large for a float. +(defun truncate-exponent (exponent mantissa) + ;; Work with base-2 logarithms to avoid conversions to floats, and + ;; convert to base-10 conservatively at the end. Use the least + ;; positive float, because denormalized exponent can be larger than + ;; normalized. + (let* ((max-exponent-bits (+ sb-vm:double-float-digits + sb-vm:double-float-bias)) + (mantissa-bits (integer-length mantissa))) + (if (minusp exponent) + (max exponent (ceiling (- (+ max-exponent-bits mantissa-bits)) + #.(cl:floor (cl:log 10 2)))) + (min exponent (floor (- max-exponent-bits mantissa-bits) + #.(cl:floor (cl:log 10 2))))))) + (define-kind float-kind (number-kind) ()) (defmethod make-literal ((client t) (kind float-kind) - &key type sign decimal-mantissa + &key stream ; TODO pass stream as required parameter for source information and error reporting? + type sign decimal-mantissa exponent-sign (exponent nil exponentp) decimal-exponent) - (let ((magnitude (* decimal-mantissa - (expt 10 (- (if exponentp - (* exponent-sign exponent) - 0) - decimal-exponent))))) - (* sign (coerce magnitude type)))) + (let* ((exponent* (- (if exponentp + (* exponent-sign exponent) + 0) + decimal-exponent)) + (exponent** (truncate-exponent exponent* decimal-mantissa)) + (magnitude (* decimal-mantissa (expt 10 exponent**)))) + (handler-case + (* sign (coerce magnitude type)) + (floating-point-overflow () + (let ((length (+ (length (format nil "~D~@[E~D~]" + decimal-mantissa exponent)) + (if (zerop decimal-exponent) 0 1) ; TODO not accurate + ))) + (%recoverable-reader-error + stream 'overflow-in-float + :position-offset (- length) + :operation 'coerce ; arithmetic-error + :operands (list magnitude type) + :sign sign ; overflow-in-float + :mantissa decimal-mantissa + :exponent exponent + :float-format type ; float-format-condition + :report 'use-replacement-float-format ; TODO report + )))))) ;;; TODO separate file? (define-kind rational-kind (number-kind) ()) diff --git a/code/reader/messages-english.lisp b/code/reader/messages-english.lisp index 3be672e..848ae79 100644 --- a/code/reader/messages-english.lisp +++ b/code/reader/messages-english.lisp @@ -361,6 +361,14 @@ 'cl:*read-default-float-format* (float-format condition))) + (define-reporter ((condition overflow-in-float) stream) + (format stream "~@" + (sign condition) + (mantissa condition) + (exponent condition) + (float-format condition))) + ;;; Conditions related to block comments (define-reporter ((condition unterminated-block-comment) stream) diff --git a/code/reader/tokens.lisp b/code/reader/tokens.lisp index 0fba47a..674ed25 100644 --- a/code/reader/tokens.lisp +++ b/code/reader/tokens.lisp @@ -218,14 +218,14 @@ :report 'use-replacement-float-format)) (setf type 'single-float)) (if exponentp - (make-literal client float-kind + (make-literal client float-kind :stream input-stream ; HACK pass stream as required argument? :type type :sign sign :decimal-mantissa (decimal-mantissa) :exponent-sign exponent-sign :exponent (exponent) :decimal-exponent decimal-exponent) - (make-literal client float-kind + (make-literal client float-kind :stream input-stream :type type :sign sign :decimal-mantissa (decimal-mantissa) diff --git a/test/reader/tokens.lisp b/test/reader/tokens.lisp index 3f3341c..e0fd2fa 100644 --- a/test/reader/tokens.lisp +++ b/test/reader/tokens.lisp @@ -405,3 +405,10 @@ (mapc #'do-interpret-token-test-case '(("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-overflow + "Make sure that too large exponents signal a FLOATING-POINT-OVERFLOW." + (mapc #'do-interpret-token-test-case + '(("1e1000000" () 10 :upcase eclector.reader::overflow-in-float 0 9) ; TODO export + ("1f1000000" () 10 :upcase eclector.reader::overflow-in-float 0 9) + ("1d1000000" () 10 :upcase eclector.reader::overflow-in-float 0 9)))) diff --git a/test/reader/utilities.lisp b/test/reader/utilities.lisp index 2420c76..97d6765 100644 --- a/test/reader/utilities.lisp +++ b/test/reader/utilities.lisp @@ -5,7 +5,6 @@ (test convert-according-to-readtable-case/smoke "Smoke test for the CONVERT-ACCORDING-TO-READTABLE-CASE function." - (mapc (lambda (foo) (destructuring-bind (token escape-ranges case expected) foo (let ((token (copy-seq token))