0.8.16.2: TYPE-ERROR for ERROR
[sbcl.git] / src / code / reader.lisp
index 821a9e4..04c893f 100644 (file)
                   +char-attr-whitespace+)
               (done-with-fast-read-char)
               char)))
-       ;; fundamental-stream
+       ;; CLOS stream
        (do ((attribute-table (character-attribute-table *readtable*))
-            (char (stream-read-char stream) (stream-read-char stream)))
+            (char (read-char stream nil :eof) (read-char stream nil :eof)))
            ((or (eq char :eof)
                 (/= (the fixnum (aref attribute-table (char-code char)))
                     +char-attr-whitespace+))
   (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
 
 (defvar *ouch-ptr*)
 
 (declaim (type index *read-buffer-length* *inch-ptr* *ouch-ptr*))
-(declaim (simple-string *read-buffer*))
+(declaim (type (simple-array character (*)) *read-buffer*))
 
 (defmacro reset-read-buffer ()
   ;; Turn *READ-BUFFER* into an empty 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)
                     (fast-read-char nil nil)))
              ((or (not char) (char= char #\newline))
               (done-with-fast-read-char))))
-       ;; FUNDAMENTAL-STREAM
-       (do ((char (stream-read-char stream) (stream-read-char stream)))
+       ;; CLOS stream
+       (do ((char (read-char stream nil :eof) (read-char stream nil :eof)))
            ((or (eq char :eof) (char= char #\newline))))))
   ;; Don't return anything.
   (values))
               (done-with-fast-read-char))
            (if (escapep char) (setq char (fast-read-char t)))
            (ouch-read-buffer char)))
-       ;; FUNDAMENTAL-STREAM
-       (do ((char (stream-read-char stream) (stream-read-char stream)))
+       ;; CLOS stream
+       (do ((char (read-char stream nil :eof) (read-char stream nil :eof)))
            ((or (eq char :eof) (char= char closech))
             (if (eq char :eof)
                 (error 'end-of-file :stream stream)))
          (when (escapep char)
-           (setq char (stream-read-char stream))
+           (setq char (read-char stream nil :eof))
            (if (eq char :eof)
                (error 'end-of-file :stream stream)))
          (ouch-read-buffer char))))
         +char-attr-delimiter+
         (if (digit-char-p ,char (max *read-base* 10))
             (if (digit-char-p ,char *read-base*)
-                +char-attr-constituent-digit+
-                +char-attr-constituent+)
+                (if (= att +char-attr-constituent-expt+)
+                    +char-attr-constituent-digit-or-expt+
+                    +char-attr-constituent-digit+)
+                +char-attr-constituent-decimal-digit+)
             att))))
 \f
 ;;;; token fetching
        (package-designator nil)
        (colons 0)
        (possibly-rational t)
+       (seen-digit-or-expt nil)
        (possibly-float t)
-       (escapes ()))
+       (was-possibly-float nil)
+       (escapes ())
+       (seen-multiple-escapes nil))
     (reset-read-buffer)
     (prog ((char firstchar))
       (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))
        (#.+char-attr-package-delimiter+ (go COLON))
            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))
        (#.+char-attr-package-delimiter+ (go COLON))
       (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
+                                                    (go LEFTDECIMALDIGIT)
+                                                    (go SYMBOL)))
        (#.+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)))
        (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
        (#.+char-attr-package-delimiter+ (go COLON))
        (t (go SYMBOL)))
+     LEFTDECIMALDIGIT ; saw "[sign] {decimal-digit}+"
+      (aver possibly-float)
+      (ouch-read-buffer char)
+      (setq char (read-char stream nil nil))
+      (unless char (go RETURN-SYMBOL))
+      (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))
+                                        (go SYMBOL))
+       (#.+char-attr-delimiter+ (unread-char char stream)
+                                (go RETURN-SYMBOL))
+       (#.+char-attr-escape+ (go ESCAPE))
+       (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
+       (#.+char-attr-package-delimiter+ (go COLON))
+       (t (go SYMBOL)))
      MIDDLEDOT ; saw "[sign] {digit}+ dot"
       (ouch-read-buffer char)
       (setq char (read-char stream nil nil))
        (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
        (#.+char-attr-package-delimiter+ (go COLON))
        (t (go SYMBOL)))
-     RIGHTDIGIT ; saw "[sign] {digit}* dot {digit}+"
+     RIGHTDIGIT ; saw "[sign] {decimal-digit}* dot {digit}+"
       (ouch-read-buffer char)
       (setq char (read-char stream nil nil))
-      (unless char (return (make-float)))
+      (unless char (return (make-float stream)))
       (case (char-class char attribute-table)
        (#.+char-attr-constituent-digit+ (go RIGHTDIGIT))
        (#.+char-attr-constituent-expt+ (go EXPONENT))
        (#.+char-attr-delimiter+
         (unread-char char stream)
-        (return (make-float)))
+        (return (make-float stream)))
        (#.+char-attr-escape+ (go ESCAPE))
        (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
        (#.+char-attr-package-delimiter+ (go COLON))
       (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)
        (#.+char-attr-constituent-sign+ (go EXPTSIGN))
        (#.+char-attr-constituent-digit+ (go EXPTDIGIT))
      EXPTDIGIT ; got to EXPONENT, saw "[sign] {digit}+"
       (ouch-read-buffer char)
       (setq char (read-char stream nil nil))
-      (unless char (return (make-float)))
+      (unless char (return (make-float stream)))
       (case (char-class char attribute-table)
        (#.+char-attr-constituent-digit+ (go EXPTDIGIT))
        (#.+char-attr-delimiter+
         (unread-char char stream)
-        (return (make-float)))
+        (return (make-float stream)))
        (#.+char-attr-escape+ (go ESCAPE))
        (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
        (#.+char-attr-package-delimiter+ (go COLON))
      RATIODIGIT ; saw "[sign] {digit}+ slash {digit}+"
       (ouch-read-buffer char)
       (setq char (read-char stream nil nil))
-      (unless char (return (make-ratio)))
+      (unless char (return (make-ratio stream)))
       (case (char-class2 char attribute-table)
        (#.+char-attr-constituent-digit+ (go RATIODIGIT))
        (#.+char-attr-delimiter+
         (unread-char char stream)
-        (return (make-ratio)))
+        (return (make-ratio stream)))
        (#.+char-attr-escape+ (go ESCAPE))
        (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
        (#.+char-attr-package-delimiter+ (go COLON))
                 (#.+char-attr-package-delimiter+ (done-with-fast-read-char)
                                                  (go COLON))
                 (t (go SYMBOL-LOOP)))))
-           ;; fundamental-stream
+           ;; CLOS stream
            (prog ()
             SYMBOL-LOOP
             (ouch-read-buffer char)
-            (setq char (stream-read-char stream))
+            (setq char (read-char stream nil :eof))
             (when (eq char :eof) (go RETURN-SYMBOL))
             (case (char-class char attribute-table)
               (#.+char-attr-escape+ (go ESCAPE))
-              (#.+char-attr-delimiter+ (stream-unread-char stream char)
+              (#.+char-attr-delimiter+ (unread-char char stream)
                            (go RETURN-SYMBOL))
               (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
               (#.+char-attr-package-delimiter+ (go COLON))
        (#.+char-attr-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)))
                ;; a FIND-PACKAGE* function analogous to INTERN*
                ;; and friends?
                (read-buffer-to-string)
-               *keyword-package*))
+               (if seen-multiple-escapes
+                   (read-buffer-to-string)
+                   *keyword-package*)))
       (reset-read-buffer)
       (setq escapes ())
       (setq char (read-char stream nil nil))
                                 (the index (* num base))))))))
        (setq number (+ num (* number base-power)))))))
 
-(defun make-float ()
+(defun make-float (stream)
   ;; Assume that the contents of *read-buffer* are a legal float, with nothing
   ;; else after it.
   (read-unwind-read-buffer)
     (cond ((eofp char)
           ;; If not, we've read the whole number.
           (let ((num (make-float-aux number divisor
-                                     *read-default-float-format*)))
+                                     *read-default-float-format*
+                                     stream)))
             (return-from make-float (if negative-fraction (- num) num))))
          ((exponent-letterp char)
           (setq float-char char)
                                  (#\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)
-                ;; 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
-                   (values
-                    (log sb!xc:least-positive-normalized-short-float 10s0)
-                    (log sb!xc:most-positive-short-float 10s0)))
-                  (single-float
-                   (values
-                    (log sb!xc:least-positive-normalized-single-float 10f0)
-                    (log sb!xc:most-positive-single-float 10f0)))
-                  (double-float
-                   (values
-                    (log sb!xc:least-positive-normalized-double-float 10d0)
-                    (log sb!xc:most-positive-double-float 10d0)))
-                  (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))
-                (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)
-  (coerce (/ number divisor) float-format))
+(defun make-float-aux (number divisor float-format stream)
+  (handler-case
+      (coerce (/ number divisor) float-format)
+    (type-error (c)
+      (error 'reader-impossible-number-error
+            :error c :stream stream
+            :format-control "failed to build float"))))
 
-(defun make-ratio ()
+(defun make-ratio (stream)
   ;; Assume *READ-BUFFER* contains a legal ratio. Build the number from
   ;; the string.
   ;;
          (dig ()))
         ((or (eofp ch) (not (setq dig (digit-char-p ch *read-base*)))))
         (setq denominator (+ (* denominator *read-base*) dig)))
-    (let ((num (/ numerator denominator)))
+    (let ((num (handler-case
+                  (/ numerator denominator)
+                (arithmetic-error (c)
+                  (error 'reader-impossible-number-error
+                         :error c :stream stream
+                         :format-control "failed to build ratio")))))
       (if negative-number (- num) num))))
 \f
 ;;;; cruft for dispatch macros
   #!+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
    and the lisp object built by the reader is returned. Macro chars
    will take effect."
   (declare (string string))
+  
   (with-array-data ((string string)
                    (start start)
-                   (end (or end (length string))))
+                   (end (%check-vector-sequence-bounds string start end)))
     (unless *read-from-string-spares*
       (push (internal-make-string-input-stream "" 0 0)
            *read-from-string-spares*))
   (default to the beginning and end of the string)  It skips over
   whitespace characters and then tries to parse an integer. The
   radix parameter must be between 2 and 36."
-  (with-array-data ((string string)
-                   (start start)
-                   (end (or end (length string))))
-    (let ((index (do ((i start (1+ i)))
-                    ((= i end)
-                     (if junk-allowed
-                         (return-from parse-integer (values nil end))
-                         (error "no non-whitespace characters in number")))
-                  (declare (fixnum i))
-                  (unless (whitespacep (char string i)) (return i))))
-         (minusp nil)
-         (found-digit nil)
-         (result 0))
-      (declare (fixnum index))
-      (let ((char (char string index)))
-       (cond ((char= char #\-)
-              (setq minusp t)
-              (incf index))
-             ((char= char #\+)
-              (incf index))))
-      (loop
-       (when (= index end) (return nil))
-       (let* ((char (char string index))
-              (weight (digit-char-p char radix)))
-         (cond (weight
-                (setq result (+ weight (* result radix))
-                      found-digit t))
-               (junk-allowed (return nil))
-               ((whitespacep char)
-                (do ((jndex (1+ index) (1+ jndex)))
-                    ((= jndex end))
-                  (declare (fixnum jndex))
-                  (unless (whitespacep (char string jndex))
-                    (error "junk in string ~S" string)))
-                (return nil))
-               (t
-                (error "junk in string ~S" string))))
-       (incf index))
-      (values
-       (if found-digit
-          (if minusp (- result) result)
-          (if junk-allowed
-              nil
-              (error "no digits in string ~S" string)))
-       index))))
+  (macrolet ((parse-error (format-control)
+              `(error 'simple-parse-error
+                      :format-control ,format-control
+                      :format-arguments (list string))))
+    (with-array-data ((string string :offset-var offset)
+                     (start start)
+                     (end (%check-vector-sequence-bounds string start end)))
+      (let ((index (do ((i start (1+ i)))
+                      ((= i end)
+                       (if junk-allowed
+                           (return-from parse-integer (values nil end))
+                           (parse-error "no non-whitespace characters in string ~S.")))
+                    (declare (fixnum i))
+                    (unless (whitespacep (char string i)) (return i))))
+           (minusp nil)
+           (found-digit nil)
+           (result 0))
+       (declare (fixnum index))
+       (let ((char (char string index)))
+         (cond ((char= char #\-)
+                (setq minusp t)
+                (incf index))
+               ((char= char #\+)
+                (incf index))))
+       (loop
+        (when (= index end) (return nil))
+        (let* ((char (char string index))
+               (weight (digit-char-p char radix)))
+          (cond (weight
+                 (setq result (+ weight (* result radix))
+                       found-digit t))
+                (junk-allowed (return nil))
+                ((whitespacep char)
+                  (loop
+                   (incf index)
+                   (when (= index end) (return))
+                   (unless (whitespacep (char string index))
+                     (parse-error "junk in string ~S")))
+                 (return nil))
+                (t
+                 (parse-error "junk in string ~S"))))
+        (incf index))
+       (values
+        (if found-digit
+            (if minusp (- result) result)
+            (if junk-allowed
+                nil
+                (parse-error "no digits in string ~S")))
+        (- index offset))))))
 \f
 ;;;; reader initialization code