(let ((*readtable* *standard-readtable*))
(flet ((whitespaceify (char)
+ (set-cmt-entry char nil)
(set-cat-entry char +char-attr-whitespace+)))
(whitespaceify (code-char tab-char-code))
(whitespaceify #\linefeed)
(whitespaceify (code-char return-char-code)))
(set-cat-entry #\\ +char-attr-escape+)
- (set-cmt-entry #\\ #'read-token)
+ (set-cmt-entry #\\ nil)
;; Easy macro-character definitions are in this source file.
(set-macro-character #\" #'read-string)
((= ichar #O200))
(setq char (code-char ichar))
(when (constituentp char *standard-readtable*)
- (set-cat-entry char (get-secondary-attribute char))
- (set-cmt-entry char nil)))))
+ (set-cat-entry char (get-secondary-attribute char))
+ (set-cmt-entry char nil)))))
\f
;;;; implementation of the read buffer
"Read from STREAM and return the value read, preserving any whitespace
that followed the object."
(if recursivep
- ;; a loop for repeating when a macro returns nothing
- (loop
- (let ((char (read-char stream eof-error-p *eof-object*)))
- (cond ((eofp char) (return eof-value))
- ((whitespacep char))
- (t
- (let* ((macrofun (get-coerced-cmt-entry char *readtable*))
- (result (multiple-value-list
- (funcall macrofun stream char))))
- ;; Repeat if macro returned nothing.
- (if result (return (car result))))))))
- (let ((*sharp-equal-alist* nil))
+ ;; a loop for repeating when a macro returns nothing
+ (loop
+ (let ((char (read-char stream eof-error-p *eof-object*)))
+ (cond ((eofp char) (return eof-value))
+ ((whitespacep char))
+ (t
+ (let* ((macrofun (get-coerced-cmt-entry char *readtable*))
+ (result (multiple-value-list
+ (funcall macrofun stream char))))
+ ;; Repeat if macro returned nothing.
+ (when result
+ (return (unless *read-suppress* (car result)))))))))
+ (let ((*sharp-equal-alist* nil))
(read-preserving-whitespace stream eof-error-p eof-value t))))
;;; Return NIL or a list with one thing, depending.
(funcall (get-coerced-cmt-entry char *readtable*)
stream
char))))
- (if retval (rplacd retval nil))))
+ (when (and retval (not *read-suppress*))
+ (rplacd retval nil))))
(defun read (&optional (stream *standard-input*)
(eof-error-p t)
eof-error-p
eof-value
recursivep)))
- ;; (This function generally discards trailing whitespace. If you
+ ;; This function generally discards trailing whitespace. If you
;; don't want to discard trailing whitespace, call
- ;; CL:READ-PRESERVING-WHITESPACE instead.)
+ ;; CL:READ-PRESERVING-WHITESPACE instead.
(unless (or (eql result eof-value) recursivep)
(let ((next-char (read-char stream nil nil)))
(unless (or (null next-char)
+char-attr-delimiter+
(if (digit-char-p ,char (max *read-base* 10))
(if (digit-char-p ,char *read-base*)
- +char-attr-constituent-digit+
+ (if (= att +char-attr-constituent-expt+)
+ +char-attr-constituent-digit-or-expt+
+ +char-attr-constituent-digit+)
+char-attr-constituent-decimal-digit+)
att))))
\f
(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)
(case (char-class3 char attribute-table)
(#.+char-attr-constituent-sign+ (go SIGN))
(#.+char-attr-constituent-digit+ (go LEFTDIGIT))
+ (#.+char-attr-constituent-digit-or-expt+
+ (setq seen-digit-or-expt t)
+ (go LEFTDIGIT))
(#.+char-attr-constituent-decimal-digit+ (go LEFTDECIMALDIGIT))
(#.+char-attr-constituent-dot+ (go FRONTDOT))
(#.+char-attr-escape+ (go ESCAPE))
possibly-float t)
(case (char-class3 char attribute-table)
(#.+char-attr-constituent-digit+ (go LEFTDIGIT))
+ (#.+char-attr-constituent-digit-or-expt+
+ (setq seen-digit-or-expt t)
+ (go LEFTDIGIT))
(#.+char-attr-constituent-decimal-digit+ (go LEFTDECIMALDIGIT))
(#.+char-attr-constituent-dot+ (go SIGNDOT))
(#.+char-attr-escape+ (go ESCAPE))
(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)
(#.+char-attr-constituent-digit+ (go LEFTDIGIT))
(#.+char-attr-constituent-decimal-digit+ (if possibly-float
(#.+char-attr-constituent-dot+ (if possibly-float
(go MIDDLEDOT)
(go SYMBOL)))
- (#.+char-attr-constituent-expt+ (go EXPONENT))
+ (#.+char-attr-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))))
+ (#.+char-attr-constituent-expt+
+ (if was-possibly-float
+ (go EXPONENT)
+ (go SYMBOL)))
+ (#.+char-attr-constituent-slash+ (if possibly-rational
+ (go RATIO)
+ (go SYMBOL)))
+ (#.+char-attr-delimiter+ (unread-char char stream)
+ (return (make-integer)))
+ (#.+char-attr-escape+ (go ESCAPE))
+ (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
+ (#.+char-attr-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)
+ (#.+char-attr-constituent-digit+ (go LEFTDIGIT))
+ (#.+char-attr-constituent-decimal-digit+ (bug "impossible!"))
+ (#.+char-attr-constituent-dot+ (go SYMBOL))
+ (#.+char-attr-constituent-digit-or-expt+ (go LEFTDIGIT))
+ (#.+char-attr-constituent-expt+ (go SYMBOL))
+ (#.+char-attr-constituent-sign+ (go EXPTSIGN))
(#.+char-attr-constituent-slash+ (if possibly-rational
(go RATIO)
(go SYMBOL)))
(ouch-read-buffer char)
(setq char (read-char stream nil nil))
(unless char (go RETURN-SYMBOL))
- (case (char-class3 char attribute-table)
- (#.+char-attr-constituent-digit+ (if possibly-float
- (go LEFTDECIMALDIGIT)
- (go SYMBOL)))
- (#.+char-attr-constituent-decimal-digit+ (go LEFTDECIMALDIGIT))
+ (case (char-class char attribute-table)
+ (#.+char-attr-constituent-digit+ (go LEFTDECIMALDIGIT))
(#.+char-attr-constituent-dot+ (go MIDDLEDOT))
(#.+char-attr-constituent-expt+ (go EXPONENT))
(#.+char-attr-constituent-slash+ (aver (not possibly-rational))
(unless char (return (let ((*read-base* 10))
(make-integer))))
(case (char-class char attribute-table)
- (#.+char-attr-constituent-digit+ (if possibly-float
- (go RIGHTDIGIT)
- (go SYMBOL)))
- (#.+char-attr-constituent-decimal-digit+ (go RIGHTDIGIT))
+ (#.+char-attr-constituent-digit+ (go RIGHTDIGIT))
(#.+char-attr-constituent-expt+ (go EXPONENT))
(#.+char-attr-delimiter+
(unread-char char stream)
(setq char (read-char stream nil nil))
(unless char (return (make-float stream)))
(case (char-class char attribute-table)
- (#.+char-attr-constituent-digit+ (if possibly-float
- (go RIGHTDIGIT)
- (go SYMBOL)))
- (#.+char-attr-constituent-decimal-digit+ (go RIGHTDIGIT))
+ (#.+char-attr-constituent-digit+ (go RIGHTDIGIT))
(#.+char-attr-constituent-expt+ (go EXPONENT))
(#.+char-attr-delimiter+
(unread-char char stream)
(setq char (read-char stream nil nil))
(unless char (go RETURN-SYMBOL))
(case (char-class char attribute-table)
- (#.+char-attr-constituent-digit+ (if possibly-float
- (go RIGHTDIGIT)
- (go SYMBOL)))
- (#.+char-attr-constituent-decimal-digit+ (go RIGHTDIGIT))
+ (#.+char-attr-constituent-digit+ (go RIGHTDIGIT))
(#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
(#.+char-attr-escape+ (go ESCAPE))
(#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
(setq char (read-char stream nil nil))
(unless char (%reader-error stream "dot context error"))
(case (char-class char attribute-table)
- (#.+char-attr-constituent-digit+ (if possibly-float
- (go RIGHTDIGIT)
- (go SYMBOL)))
- (#.+char-attr-constituent-decimal-digit+ (go RIGHTDIGIT))
+ (#.+char-attr-constituent-digit+ (go RIGHTDIGIT))
(#.+char-attr-constituent-dot+ (go DOTS))
(#.+char-attr-delimiter+ (%reader-error stream "dot context error"))
(#.+char-attr-escape+ (go ESCAPE))
(setq possibly-float t)
(case (char-class char attribute-table)
(#.+char-attr-constituent-sign+ (go EXPTSIGN))
- (#.+char-attr-constituent-digit+ (if possibly-float
- (go EXPTDIGIT)
- (go SYMBOL)))
- (#.+char-attr-constituent-decimal-digit+ (go EXPTDIGIT))
+ (#.+char-attr-constituent-digit+ (go EXPTDIGIT))
(#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
(#.+char-attr-escape+ (go ESCAPE))
(#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
(setq char (read-char stream nil nil))
(unless char (go RETURN-SYMBOL))
(case (char-class char attribute-table)
- (#.+char-attr-constituent-digit+ (if possibly-float
- (go EXPTDIGIT)
- (go SYMBOL)))
- (#.+char-attr-constituent-decimal-digit+ (go EXPTDIGIT))
+ (#.+char-attr-constituent-digit+ (go EXPTDIGIT))
(#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
(#.+char-attr-escape+ (go ESCAPE))
(#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
(setq char (read-char stream nil nil))
(unless char (return (make-float stream)))
(case (char-class char attribute-table)
- (#.+char-attr-constituent-digit+ (if possibly-float
- (go EXPTDIGIT)
- (go SYMBOL)))
- (#.+char-attr-constituent-decimal-digit+ (go EXPTDIGIT))
+ (#.+char-attr-constituent-digit+ (go EXPTDIGIT))
(#.+char-attr-delimiter+
(unread-char char stream)
(return (make-float stream)))
(#\F 'single-float)
(#\D 'double-float)
(#\L 'long-float)))
- num)
- ;; Raymond Toy writes: 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)
- ;; FIXME: These forms are broken w.r.t.
- ;; cross-compilation portability, as the
- ;; cross-compiler will call the host's LOG function
- ;; while attempting to constant-fold. Maybe some sort
- ;; of load-time-form magic could be used instead?
- (case float-format
- ((short-float single-float)
- (values
- (log sb!xc:least-positive-normalized-single-float 10f0)
- (log sb!xc:most-positive-single-float 10f0)))
- ((double-float #!-long-float long-float)
- (values
- (log sb!xc:least-positive-normalized-double-float 10d0)
- (log sb!xc:most-positive-double-float 10d0)))
- #!+long-float
- (long-float
- (values
- (log sb!xc:least-positive-normalized-long-float 10l0)
- (log sb!xc: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 stream))
- (setq num (* num (expt 10 exponent)))
- (return-from make-float (if negative-fraction
- (- num)
- num))))))
- ;; should never happen
+ (result (make-float-aux (* (expt 10 exponent) number)
+ divisor float-format stream)))
+ (return-from make-float
+ (if negative-fraction (- result) result))))
(t (bug "bad fallthrough in floating point reader")))))
(defun make-float-aux (number divisor float-format stream)
#!+sb-doc
"A resource of string streams for Read-From-String.")
-(defun read-from-string (string &optional eof-error-p eof-value
+(defun read-from-string (string &optional (eof-error-p t) eof-value
&key (start 0) end
preserve-whitespace)
#!+sb-doc
projects / sbcl.git / blobdiff