diff --git a/code/print.lisp b/code/print.lisp index 6df6a41de5ac7754de3a2ff9771cd5479cfc4f21..0889d80ce5d5715eea0bced9936b189db6903875 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.88 2004/04/22 14:26:27 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/print.lisp,v 1.89 2004/04/22 14:38:25 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1673,44 +1673,6 @@ 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) - for type in '(short-float single-float double-float long-float) - collect - `(,type - (and (>= ,x-var ,(coerce output-float-free-format-min type)) - (< ,x-var ,(coerce output-float-free-format-max type)))) - into clauses - finally - (return - `(let ((,x-var ,x)) - (etypecase ,x-var - ,@clauses))))) - -#+(or) -(defun output-float-aux (x stream) - (if (output-float-free-format-p x) - ;;free format - (multiple-value-bind (str len lpoint tpoint) - (flonum-to-string x) - (declare (ignore len)) - (when lpoint (write-char #\0 stream)) - (write-string str stream) - (when tpoint (write-char #\0 stream)) - (print-float-exponent x 0 stream)) - ;;exponential format - (multiple-value-bind (f ex) - (scale-exponent x) - (multiple-value-bind (str len lpoint tpoint) - (flonum-to-string f nil nil 1) - (declare (ignore len)) - (when lpoint (write-char #\0 stream)) - (write-string str stream) - (when tpoint (write-char #\0 stream)) - ;; 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 diff --git a/code/reader.lisp b/code/reader.lisp index 30b05d20b9cd8af6d9d458d2bdca6f6a3c4917c3..7ea038796ce8c40297bd547dd7ca56498be0a756 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.45 2004/04/22 14:26:27 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/reader.lisp,v 1.46 2004/04/22 14:38:25 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -155,6 +155,15 @@ (defconstant package-delimiter 11) ;;fake attribute for use in read-unqualified-token (defconstant delimiter 12) + ;; More fake attributes for used for reading numbers. + ;; + ;; The following two are not static but depend on *READ-BASE*. + ;; DECIMAL-DIGIT is for characters being digits in base 10 but not in + ;; base *READ-BASE* (which is therefore perforce smaller than 10); + ;; DIGIT-OR-EXPT is for characters being both exponent markers and + ;; digits in base *READ-BASE* (which is therefore perforce larger + ;; than 10). + (defconstant constituent-decimal-digit 13) (defconstant constituent-digit-or-expt 14)) @@ -877,341 +886,6 @@ (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 - ;;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 bnf 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 nil) - (colons 0) - (possibly-rational t) - (possibly-float t) - (escapes ())) - (reset-read-buffer) - (prog ((char firstchar)) - (case (char-class3 char attribute-table) - (#.constituent-sign (go SIGN)) - (#.constituent-digit (go LEFTDIGIT)) - (#.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-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))) - (case (char-class3 char attribute-table) - (#.constituent-digit (go LEFTDIGIT)) - (#.constituent-dot (if possibly-float - (go MIDDLEDOT) - (go SYMBOL))) - (#.constituent-expt (go EXPONENT)) - (#.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))) - 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] {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)) - (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 - ;;we 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 (stream::%read-char stream nil nil t t)) - (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 (stream-read-char stream)) - (when (eq char :eof) (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)))))) - 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 - (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 - (if (eql (char-class firstchar attribute-table) - #.package-delimiter) - *keyword-package* - (read-buffer-to-string))) - (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 "To many colons after ~S:" package)) - (t (go SYMBOL))) - RETURN-SYMBOL - (casify-read-buffer escapes) - (let ((found (if package - (find-package package) - *package*))) - (unless found - (error 'reader-package-error :stream stream - :format-arguments (list package) - :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-token (stream firstchar) "This function is just an fsm that recognizes numbers and symbols." ;; Check explicitly whether FIRSTCHAR has an entry for @@ -1713,105 +1387,6 @@ (setq number (+ num (* number base-power))))))) - -#+(or) -(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) - ;; toy@rtp.ericsson.se: We need to watch out if the - ;; exponent is too small or too large. We add enough to - ;; EXPONENT to make it within range and scale NUMBER - ;; appropriately. This should avoid any unnecessary - ;; underflow or overflow problems. - (multiple-value-bind (min-expo max-expo) - (case float-format - (short-float - (values - #.(log least-positive-normalized-short-float 10s0) - #.(log most-positive-short-float 10s0))) - (single-float - (values - #.(log least-positive-normalized-single-float 10f0) - #.(log most-positive-single-float 10f0))) - (double-float - (values - #.(log least-positive-normalized-double-float 10d0) - #.(log most-positive-double-float 10d0))) - (long-float - (values - #.(log least-positive-normalized-long-float 10L0) - #.(log most-positive-long-float 10L0)))) - (let ((correction (cond ((<= exponent min-expo) - (ceiling (- min-expo exponent))) - ((>= exponent max-expo) - (floor (- max-expo exponent))) - (t - 0)))) - (incf exponent correction) - (setf number (/ number (expt 10 correction))) - (setq num (make-float-aux number divisor float-format)) - (setq num (* num (expt 10 exponent))) - (return-from make-float (if negative-fraction (- num) num)))))) - ;;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.