Skip to content
Snippets Groups Projects
Commit 52168c78 authored by rtoy's avatar rtoy
Browse files

Oops. Remove unused code. Add a couple of comments.

parent 4958e03b
No related branches found
No related tags found
No related merge requests found
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (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 @@ ...@@ -1673,44 +1673,6 @@
output-float-free-format-exponent-min output-float-free-format-exponent-min
output-float-free-format-exponent-max))))))) 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 ;; Smallest possible (unbiased) exponents
(defconstant double-float-min-e (defconstant double-float-min-e
......
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (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 @@ ...@@ -155,6 +155,15 @@
(defconstant package-delimiter 11) (defconstant package-delimiter 11)
;;fake attribute for use in read-unqualified-token ;;fake attribute for use in read-unqualified-token
(defconstant delimiter 12) (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-decimal-digit 13)
(defconstant constituent-digit-or-expt 14)) (defconstant constituent-digit-or-expt 14))
...@@ -877,341 +886,6 @@ ...@@ -877,341 +886,6 @@
(cond (all-lower (raise-em)) (cond (all-lower (raise-em))
(all-upper (lower-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) (defun read-token (stream firstchar)
"This function is just an fsm that recognizes numbers and symbols." "This function is just an fsm that recognizes numbers and symbols."
;; Check explicitly whether FIRSTCHAR has an entry for ;; Check explicitly whether FIRSTCHAR has an entry for
...@@ -1713,105 +1387,6 @@ ...@@ -1713,105 +1387,6 @@
(setq number (+ num (* number base-power))))))) (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 () (defun make-float ()
;; Assume that the contents of *read-buffer* are a legal float, with nothing ;; Assume that the contents of *read-buffer* are a legal float, with nothing
;; else after it. ;; else after it.
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment