X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Freader.lisp;h=04c893f7af3fc934f062c68feca650aa7167a77c;hb=15d6e7c9a2c3234f95dfe278046fa2fee1b0c007;hp=498054498ab9db8a652212fd336c2a05dcc70277;hpb=56a972e201d117a8d5d769527f2bafd23cba7de9;p=sbcl.git

diff --git a/src/code/reader.lisp b/src/code/reader.lisp
index 4980544..04c893f 100644
--- a/src/code/reader.lisp
+++ b/src/code/reader.lisp
@@ -276,6 +276,7 @@
   (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)
@@ -284,7 +285,7 @@
       (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)
@@ -301,8 +302,8 @@
 	((= 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)))))
 
 ;;;; implementation of the read buffer
 
@@ -406,18 +407,19 @@
   "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.
@@ -429,7 +431,8 @@
 		 (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)
@@ -441,9 +444,9 @@
 					    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)
@@ -658,7 +661,9 @@
 	 +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))))
 
@@ -735,7 +740,9 @@
 	(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)
@@ -743,6 +750,9 @@
       (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))
@@ -758,6 +768,9 @@
 	    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))
@@ -769,6 +782,7 @@
       (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
@@ -777,7 +791,34 @@
 	(#.+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)))
@@ -792,11 +833,8 @@
       (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))
@@ -813,10 +851,7 @@
       (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)
@@ -831,10 +866,7 @@
       (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)
@@ -848,10 +880,7 @@
       (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))
@@ -861,10 +890,7 @@
       (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))
@@ -878,10 +904,7 @@
       (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))
@@ -892,10 +915,7 @@
       (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))
@@ -906,10 +926,7 @@
       (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)))
@@ -1258,46 +1275,10 @@
 				  (#\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)
@@ -1440,7 +1421,7 @@
   #!+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