From 4958e03bfa7d043768be3397f8ecac31dbe750ff Mon Sep 17 00:00:00 2001 From: rtoy <rtoy> Date: Thu, 22 Apr 2004 14:26:27 +0000 Subject: [PATCH] o Fix the float printer to print correctly: (float -54965272/1000000000000000000) was printing as -5.496527e-11 but should be -5.4965272e-11 o Fix the float reader to read correctly, without roundoff: 4.0058643e+8 was incorrectly read as 12518325, 1 (integer-decode-float results). It should be 12518326,1. o Fix the float reader to read floats correctly with unusual values of *read-base*: (let ((*read-base* 2)) (read-from-string "-4.3e+7")) used to return a symbol instead of a float. This changes ported from SBCL. --- code/print.lisp | 133 +++++++++++-- code/reader.lisp | 480 ++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 598 insertions(+), 15 deletions(-) diff --git a/code/print.lisp b/code/print.lisp index 12a0b9e53..6df6a41de 100644 --- a/code/print.lisp +++ b/code/print.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/print.lisp,v 1.87 2004/04/15 01:34:20 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/print.lisp,v 1.88 2004/04/22 14:26:27 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1638,6 +1638,15 @@ (write-string " NaN" stream))) +(defconstant output-float-free-format-exponent-min -3 + "Minimum power of 10 that allows the float printer to use free format, + instead of exponential format. See section 22.1.3.1.3: Printing Floats + in the ANSI CL standard.") +(defconstant output-float-free-format-exponent-max 8 + "Maximum power of 10 that allows the float printer to use free format, + instead of exponential format. See section 22.1.3.1.3: Printing Floats + in the ANSI CL standard.") + ;;; OUTPUT-FLOAT -- Internal ;;; ;;; Functioned called by OUTPUT-OBJECT to handle floats. @@ -1660,17 +1669,11 @@ (write-string "0.0" stream) (print-float-exponent x 0 stream)) (t - (output-float-aux x stream))))))) - -(defconstant output-float-free-format-min 1/1000 - "Minimum magnitute that allows the float printer to use free format, - instead of exponential format. See section 22.1.3.1.3: Printing Floats - in the ANSI CL standard.") -(defconstant output-float-free-format-max 10000000 - "Maximum magnitute that allows the float printer to use free format, - instead of exponential format. See section 22.1.3.1.3: Printing Floats - in the ANSI CL standard.") + (output-float-aux x stream + output-float-free-format-exponent-min + output-float-free-format-exponent-max))))))) +#+(or) (defmacro output-float-free-format-p (x) "Returns true if x can be printed in free format, as per ANSI CL." (loop with x-var = (gensym) @@ -1686,6 +1689,7 @@ (etypecase ,x-var ,@clauses))))) +#+(or) (defun output-float-aux (x stream) (if (output-float-free-format-p x) ;;free format @@ -1708,6 +1712,113 @@ ;; subtract out scale factor of 1 passed to flonum-to-string (print-float-exponent x (1- ex) stream))))) +;; Smallest possible (unbiased) exponents +(defconstant double-float-min-e + (nth-value 1 (decode-float least-positive-double-float))) +(defconstant single-float-min-e + (nth-value 1 (decode-float least-positive-single-float))) + +;;; Implementation of Figure 1 from Burger and Dybvig, 1996. As the +;;; implementation of the Dragon from Classic CMUCL says: "DO NOT EVEN +;;; THINK OF ATTEMPTING TO UNDERSTAND THIS CODE WITHOUT READING THE +;;; PAPER!" +(defun flonum-to-digits (v) + (let ((print-base 10) ; B + (float-radix 2) ; b + (float-digits (float-digits v)) ; p + (min-e + (etypecase v + (single-float single-float-min-e) + (double-float double-float-min-e)))) + (multiple-value-bind (f e) + (integer-decode-float v) + (let (;; FIXME: these even tests assume normal IEEE rounding + ;; mode. I wonder if we should cater for non-normal? + (high-ok (evenp f)) + (low-ok (evenp f)) + (result (make-array 50 :element-type 'base-char + :fill-pointer 0 :adjustable t))) + (labels ((scale (r s m+ m-) + (do ((k 0 (1+ k)) + (s s (* s print-base))) + ((not (or (> (+ r m+) s) + (and high-ok (= (+ r m+) s)))) + (do ((k k (1- k)) + (r r (* r print-base)) + (m+ m+ (* m+ print-base)) + (m- m- (* m- print-base))) + ((not (or (< (* (+ r m+) print-base) s) + (and high-ok (= (* (+ r m+) print-base) s)))) + (values k (generate r s m+ m-))))))) + (generate (r s m+ m-) + (multiple-value-bind (d r) + (truncate (* r print-base) s) + (let ((m+ (* m+ print-base)) + (m- (* m- print-base))) + (let ((tc1 (or (< r m-) (and low-ok (= r m-)))) + (tc2 (or (> (+ r m+) s) + (and high-ok (= (+ r m+) s))))) + (cond + ((and (not tc1) (not tc2)) + (vector-push-extend (char *digits* d) result) + ;; FIXME sucky tail recursion. This whole + ;; kaboodle should be DO*/LOOPified. + (generate r s m+ m-)) + ;; pedantically keeping all the conditions + ;; in so that we can move them around. + ((and (not tc1) tc2) + (vector-push-extend (char *digits* (1+ d)) result) + result) + ((and tc1 (not tc2)) + (vector-push-extend (char *digits* d) result) + result) + ((and tc1 tc2) + (vector-push-extend (char *digits* + (if (< (* r 2) s) d (1+ d))) + result) + result))))))) + (if (>= e 0) + (if (/= f (expt float-radix (1- float-digits))) + (let ((be (expt float-radix e))) + (scale (* f be 2) 2 be be)) + (let* ((be (expt float-radix e)) + (be1 (* be float-radix))) + (scale (* f be1 2) (* float-radix 2) be1 be))) + (if (or (= e min-e) (/= f (expt float-radix (1- float-digits)))) + (scale (* f 2) (* (expt float-radix (- e)) 2) 1 1) + (scale (* f float-radix 2) + (* (expt float-radix (- 1 e)) 2) float-radix 1)))))))) + +(defun output-float-aux (x stream e-min e-max) + (multiple-value-bind (e string) + (flonum-to-digits x) + (cond + ((< e-min e e-max) + ;; free format + (cond ((plusp e) + (write-string string stream :end (min (length string) e)) + (dotimes (i (- e (length string))) + (write-char #\0 stream)) + (write-char #\. stream) + (write-string string stream :start (min (length string) e)) + (when (<= (length string) e) + (write-char #\0 stream)) + (print-float-exponent x 0 stream)) + (t + (write-string "0." stream) + (dotimes (i (- e)) + (write-char #\0 stream)) + (write-string string stream) + (print-float-exponent x 0 stream)))) + (t + ;; Exponential format + (write-string string stream :end 1) + (write-char #\. stream) + (write-string string stream :start 1) + (when (= (length string) 1) + (write-char #\0 stream)) + (print-float-exponent x (1- e) stream))))) + ;;;; Other leaf objects. diff --git a/code/reader.lisp b/code/reader.lisp index 89cac919d..30b05d20b 100644 --- a/code/reader.lisp +++ b/code/reader.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/reader.lisp,v 1.44 2003/11/24 18:54:02 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/reader.lisp,v 1.45 2004/04/22 14:26:27 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -154,7 +154,9 @@ (defconstant multiple-escape 10) (defconstant package-delimiter 11) ;;fake attribute for use in read-unqualified-token - (defconstant delimiter 12)) + (defconstant delimiter 12) + (defconstant constituent-decimal-digit 13) + (defconstant constituent-digit-or-expt 14)) ;;;; Package specials. @@ -812,8 +814,10 @@ #.delimiter (if (digit-char-p ,char (max *read-base* 10)) (if (digit-char-p ,char *read-base*) - constituent-digit - constituent) + (if (= att #.constituent-expt) + constituent-digit-or-expt + constituent-digit) + constituent-decimal-digit) att)))) @@ -873,6 +877,7 @@ (cond (all-lower (raise-em)) (all-upper (lower-em)))))))))))) +#+(or) (defun read-token (stream firstchar) "This function is just an fsm that recognizes numbers and symbols." ;;check explicitly whether firstchar has entry for non-terminating @@ -1207,6 +1212,405 @@ "Symbol ~S not found in the ~A package."))) (return (intern name found))))))))) +(defun read-token (stream firstchar) + "This function is just an fsm that recognizes numbers and symbols." + ;; Check explicitly whether FIRSTCHAR has an entry for + ;; NON-TERMINATING in CHARACTER-ATTRIBUTE-TABLE and + ;; READ-DOT-NUMBER-SYMBOL in CMT. Report an error if these are + ;; violated. (If we called this, we want something that is a + ;; legitimate token!) Read in the longest possible string satisfying + ;; the Backus-Naur form for "unqualified-token". Leave the result in + ;; the *READ-BUFFER*. Return next char after token (last char read). + (when *read-suppress* + (internal-read-extended-token stream firstchar nil) + (return-from read-token nil)) + (let ((attribute-table (character-attribute-table *readtable*)) + (package-designator nil) + (colons 0) + (possibly-rational t) + (seen-digit-or-expt nil) + (possibly-float t) + (was-possibly-float nil) + (escapes ()) + (seen-multiple-escapes nil)) + (reset-read-buffer) + (prog ((char firstchar)) + (case (char-class3 char attribute-table) + (#.constituent-sign (go SIGN)) + (#.constituent-digit (go LEFTDIGIT)) + (#.constituent-digit-or-expt + (setq seen-digit-or-expt t) + (go LEFTDIGIT)) + (#.constituent-decimal-digit (go LEFTDECIMALDIGIT)) + (#.constituent-dot (go FRONTDOT)) + (#.escape (go ESCAPE)) + (#.package-delimiter (go COLON)) + (#.multiple-escape (go MULT-ESCAPE)) + ;; can't have eof, whitespace, or terminating macro as first char! + (t (go SYMBOL))) + SIGN ; saw "sign" + (ouch-read-buffer char) + (setq char (read-char stream nil nil)) + (unless char (go RETURN-SYMBOL)) + (setq possibly-rational t + possibly-float t) + (case (char-class3 char attribute-table) + (#.constituent-digit (go LEFTDIGIT)) + (#.constituent-digit-or-expt + (setq seen-digit-or-expt t) + (go LEFTDIGIT)) + (#.constituent-decimal-digit (go LEFTDECIMALDIGIT)) + (#.constituent-dot (go SIGNDOT)) + (#.escape (go ESCAPE)) + (#.package-delimiter (go COLON)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) + (t (go SYMBOL))) + LEFTDIGIT ; saw "[sign] {digit}+" + (ouch-read-buffer char) + (setq char (read-char stream nil nil)) + (unless char (return (make-integer))) + (setq was-possibly-float possibly-float) + (case (char-class3 char attribute-table) + (#.constituent-digit (go LEFTDIGIT)) + (#.constituent-decimal-digit (if possibly-float + (go LEFTDECIMALDIGIT) + (go SYMBOL))) + (#.constituent-dot (if possibly-float + (go MIDDLEDOT) + (go SYMBOL))) + (#.constituent-digit-or-expt + (if (or seen-digit-or-expt (not was-possibly-float)) + (progn (setq seen-digit-or-expt t) (go LEFTDIGIT)) + (progn (setq seen-digit-or-expt t) (go LEFTDIGIT-OR-EXPT)))) + (#.constituent-expt + (if was-possibly-float + (go EXPONENT) + (go SYMBOL))) + (#.constituent-slash (if possibly-rational + (go RATIO) + (go SYMBOL))) + (#.delimiter (unread-char char stream) + (return (make-integer))) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter (go COLON)) + (t (go SYMBOL))) + LEFTDIGIT-OR-EXPT + (ouch-read-buffer char) + (setq char (read-char stream nil nil)) + (unless char (return (make-integer))) + (case (char-class3 char attribute-table) + (#.constituent-digit (go LEFTDIGIT)) + (#.constituent-decimal-digit (error "impossible!")) + (#.constituent-dot (go SYMBOL)) + (#.constituent-digit-or-expt (go LEFTDIGIT)) + (#.constituent-expt (go SYMBOL)) + (#.constituent-sign (go EXPTSIGN)) + (#.constituent-slash (if possibly-rational + (go RATIO) + (go SYMBOL))) + (#.delimiter (unread-char char stream) + (return (make-integer))) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter (go COLON)) + (t (go SYMBOL))) + LEFTDECIMALDIGIT ; saw "[sign] {decimal-digit}+" + (assert possibly-float) + (ouch-read-buffer char) + (setq char (read-char stream nil nil)) + (unless char (go RETURN-SYMBOL)) + (case (char-class char attribute-table) + (#.constituent-digit (go LEFTDECIMALDIGIT)) + (#.constituent-dot (go MIDDLEDOT)) + (#.constituent-expt (go EXPONENT)) + (#.constituent-slash (assert (not possibly-rational)) + (go SYMBOL)) + (#.delimiter (unread-char char stream) + (go RETURN-SYMBOL)) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter (go COLON)) + (t (go SYMBOL))) + MIDDLEDOT ; saw "[sign] {digit}+ dot" + (ouch-read-buffer char) + (setq char (read-char stream nil nil)) + (unless char (return (let ((*read-base* 10)) + (make-integer)))) + (case (char-class char attribute-table) + (#.constituent-digit (go RIGHTDIGIT)) + (#.constituent-expt (go EXPONENT)) + (#.delimiter + (unread-char char stream) + (return (let ((*read-base* 10)) + (make-integer)))) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter (go COLON)) + (t (go SYMBOL))) + RIGHTDIGIT ; saw "[sign] {decimal-digit}* dot {digit}+" + (ouch-read-buffer char) + (setq char (read-char stream nil nil)) + (unless char (return (make-float))) + (case (char-class char attribute-table) + (#.constituent-digit (go RIGHTDIGIT)) + (#.constituent-expt (go EXPONENT)) + (#.delimiter + (unread-char char stream) + (return (make-float))) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter (go COLON)) + (t (go SYMBOL))) + SIGNDOT ; saw "[sign] dot" + (ouch-read-buffer char) + (setq char (read-char stream nil nil)) + (unless char (go RETURN-SYMBOL)) + (case (char-class char attribute-table) + (#.constituent-digit (go RIGHTDIGIT)) + (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (t (go SYMBOL))) + FRONTDOT ; saw "dot" + (ouch-read-buffer char) + (setq char (read-char stream nil nil)) + (unless char (%reader-error stream "dot context error")) + (case (char-class char attribute-table) + (#.constituent-digit (go RIGHTDIGIT)) + (#.constituent-dot (go DOTS)) + (#.delimiter (%reader-error stream "dot context error")) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter (go COLON)) + (t (go SYMBOL))) + EXPONENT + (ouch-read-buffer char) + (setq char (read-char stream nil nil)) + (unless char (go RETURN-SYMBOL)) + (setq possibly-float t) + (case (char-class char attribute-table) + (#.constituent-sign (go EXPTSIGN)) + (#.constituent-digit (go EXPTDIGIT)) + (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter (go COLON)) + (t (go SYMBOL))) + EXPTSIGN ; got to EXPONENT, and saw a sign character + (ouch-read-buffer char) + (setq char (read-char stream nil nil)) + (unless char (go RETURN-SYMBOL)) + (case (char-class char attribute-table) + (#.constituent-digit (go EXPTDIGIT)) + (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter (go COLON)) + (t (go SYMBOL))) + EXPTDIGIT ; got to EXPONENT, saw "[sign] {digit}+" + (ouch-read-buffer char) + (setq char (read-char stream nil nil)) + (unless char (return (make-float))) + (case (char-class char attribute-table) + (#.constituent-digit (go EXPTDIGIT)) + (#.delimiter + (unread-char char stream) + (return (make-float))) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter (go COLON)) + (t (go SYMBOL))) + RATIO ; saw "[sign] {digit}+ slash" + (ouch-read-buffer char) + (setq char (read-char stream nil nil)) + (unless char (go RETURN-SYMBOL)) + (case (char-class2 char attribute-table) + (#.constituent-digit (go RATIODIGIT)) + (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter (go COLON)) + (t (go SYMBOL))) + RATIODIGIT ; saw "[sign] {digit}+ slash {digit}+" + (ouch-read-buffer char) + (setq char (read-char stream nil nil)) + (unless char (return (make-ratio))) + (case (char-class2 char attribute-table) + (#.constituent-digit (go RATIODIGIT)) + (#.delimiter + (unread-char char stream) + (return (make-ratio))) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter (go COLON)) + (t (go SYMBOL))) + DOTS ; saw "dot {dot}+" + (ouch-read-buffer char) + (setq char (read-char stream nil nil)) + (unless char (%reader-error stream "too many dots")) + (case (char-class char attribute-table) + (#.constituent-dot (go DOTS)) + (#.delimiter + (unread-char char stream) + (%reader-error stream "too many dots")) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter (go COLON)) + (t (go SYMBOL))) + SYMBOL ; not a dot, dots, or number + (let ((stream (in-synonym-of stream))) + (stream-dispatch stream + ;; simple-stream + (prog () + SYMBOL-LOOP + (ouch-read-buffer char) + (setq char (fast-read-char nil nil)) + (unless char (go RETURN-SYMBOL)) + (case (char-class char attribute-table) + (#.escape (go ESCAPE)) + (#.delimiter (stream::%unread-char stream char) + (go RETURN-SYMBOL)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter (go COLON)) + (t (go SYMBOL-LOOP)))) + ;; lisp stream + (prepare-for-fast-read-char stream + (prog () + SYMBOL-LOOP + (ouch-read-buffer char) + (setq char (fast-read-char nil nil)) + (unless char (go RETURN-SYMBOL)) + (case (char-class char attribute-table) + (#.escape (done-with-fast-read-char) + (go ESCAPE)) + (#.delimiter (done-with-fast-read-char) + (unread-char char stream) + (go RETURN-SYMBOL)) + (#.multiple-escape (done-with-fast-read-char) + (go MULT-ESCAPE)) + (#.package-delimiter (done-with-fast-read-char) + (go COLON)) + (t (go SYMBOL-LOOP))))) + ;; fundamental-stream + (prog () + SYMBOL-LOOP + (ouch-read-buffer char) + (setq char (read-char stream nil :eof)) + (when (eq char :eof) (go RETURN-SYMBOL)) + (case (char-class char attribute-table) + (#.escape (go ESCAPE)) + (#.delimiter (unread-char char stream) + (go RETURN-SYMBOL)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter (go COLON)) + (t (go SYMBOL-LOOP)))))) + ESCAPE ; saw an escape + ;; Don't put the escape in the read buffer. + ;; READ-NEXT CHAR, put in buffer (no case conversion). + (let ((nextchar (read-char stream nil nil))) + (unless nextchar + (reader-eof-error stream "after escape character")) + (push *ouch-ptr* escapes) + (ouch-read-buffer nextchar)) + (setq char (read-char stream nil nil)) + (unless char (go RETURN-SYMBOL)) + (case (char-class char attribute-table) + (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter (go COLON)) + (t (go SYMBOL))) + MULT-ESCAPE + (setq seen-multiple-escapes t) + (do ((char (read-char stream t) (read-char stream t))) + ((multiple-escape-p char)) + (if (escapep char) (setq char (read-char stream t))) + (push *ouch-ptr* escapes) + (ouch-read-buffer char)) + (setq char (read-char stream nil nil)) + (unless char (go RETURN-SYMBOL)) + (case (char-class char attribute-table) + (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter (go COLON)) + (t (go SYMBOL))) + COLON + (casify-read-buffer escapes) + (unless (zerop colons) + (%reader-error stream "too many colons in ~S" + (read-buffer-to-string))) + (setq colons 1) + (setq package-designator + (if (plusp *ouch-ptr*) + ;; FIXME: It seems inefficient to cons up a package + ;; designator string every time we read a symbol with an + ;; explicit package prefix. Perhaps we could implement + ;; a FIND-PACKAGE* function analogous to INTERN* + ;; and friends? + (read-buffer-to-string) + (if seen-multiple-escapes + (read-buffer-to-string) + *keyword-package*))) + (reset-read-buffer) + (setq escapes ()) + (setq char (read-char stream nil nil)) + (unless char (reader-eof-error stream "after reading a colon")) + (case (char-class char attribute-table) + (#.delimiter + (unread-char char stream) + (%reader-error stream + "illegal terminating character after a colon: ~S" + char)) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter (go INTERN)) + (t (go SYMBOL))) + INTERN + (setq colons 2) + (setq char (read-char stream nil nil)) + (unless char + (reader-eof-error stream "after reading a colon")) + (case (char-class char attribute-table) + (#.delimiter + (unread-char char stream) + (%reader-error stream + "illegal terminating character after a colon: ~S" + char)) + (#.escape (go ESCAPE)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter + (%reader-error stream + "too many colons after ~S name" + package-designator)) + (t (go SYMBOL))) + RETURN-SYMBOL + (casify-read-buffer escapes) + (let ((found (if package-designator + (find-package package-designator) + *package*))) + (unless found + (error 'reader-package-error :stream stream + :format-arguments (list package-designator) + :format-control "package ~S not found")) + + (if (or (zerop colons) (= colons 2) (eq found *keyword-package*)) + (return (intern* *read-buffer* *ouch-ptr* found)) + (multiple-value-bind (symbol test) + (find-symbol* *read-buffer* *ouch-ptr* found) + (when (eq test :external) (return symbol)) + (let ((name (read-buffer-to-string))) + (with-simple-restart (continue "Use symbol anyway.") + (error 'reader-package-error :stream stream + :format-arguments (list name (package-name found)) + :format-control + (if test + "The symbol ~S is not external in the ~A package." + "Symbol ~S not found in the ~A package."))) + (return (intern name found))))))))) + (defun read-extended-token (stream &optional (*readtable* *readtable*)) "For semi-external use: returns 3 values: the string for the token, @@ -1310,6 +1714,7 @@ +#+(or) (defun make-float () ;;assume that the contents of *read-buffer* are a legal float, with nothing ;;else after it. @@ -1407,6 +1812,73 @@ ;;should never happen: (t (error "Internal error in floating point reader."))))) +(defun make-float () + ;; Assume that the contents of *read-buffer* are a legal float, with nothing + ;; else after it. + (read-unwind-read-buffer) + (let ((negative-fraction nil) + (number 0) + (divisor 1) + (negative-exponent nil) + (exponent 0) + (float-char ()) + (char (inch-read-buffer))) + (if (cond ((char= char #\+) t) + ((char= char #\-) (setq negative-fraction t))) + ;; Flush it. + (setq char (inch-read-buffer))) + ;; Read digits before the dot. + (do* ((ch char (inch-read-buffer)) + (dig (digit-char-p ch) (digit-char-p ch))) + ((not dig) (setq char ch)) + (setq number (+ (* number 10) dig))) + ;; Deal with the dot, if it's there. + (when (char= char #\.) + (setq char (inch-read-buffer)) + ;; Read digits after the dot. + (do* ((ch char (inch-read-buffer)) + (dig (and (not (eofp ch)) (digit-char-p ch)) + (and (not (eofp ch)) (digit-char-p ch)))) + ((not dig) (setq char ch)) + (setq divisor (* divisor 10)) + (setq number (+ (* number 10) dig)))) + ;; Is there an exponent letter? + (cond ((eofp char) + ;; If not, we've read the whole number. + (let ((num (make-float-aux number divisor + *read-default-float-format*))) + (return-from make-float (if negative-fraction (- num) num)))) + ((exponent-letterp char) + (setq float-char char) + ;; Build exponent. + (setq char (inch-read-buffer)) + ;; Check leading sign. + (if (cond ((char= char #\+) t) + ((char= char #\-) (setq negative-exponent t))) + ;; Flush sign. + (setq char (inch-read-buffer))) + ;; Read digits for exponent. + (do* ((ch char (inch-read-buffer)) + (dig (and (not (eofp ch)) (digit-char-p ch)) + (and (not (eofp ch)) (digit-char-p ch)))) + ((not dig) + (setq exponent (if negative-exponent (- exponent) exponent))) + (setq exponent (+ (* exponent 10) dig))) + ;; Generate and return the float, depending on FLOAT-CHAR: + (let* ((float-format (case (char-upcase float-char) + (#\E *read-default-float-format*) + (#\S 'short-float) + (#\F 'single-float) + (#\D 'double-float) + (#\L 'long-float))) + num) + (setq num (make-float-aux (* (expt 10 exponent) number) divisor float-format)) + + (return-from make-float (if negative-fraction + (- num) + num)))) + (t (error "Internal error in floating point reader."))))) + (defun make-float-aux (number divisor float-format) (coerce (/ number divisor) float-format)) -- GitLab