X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Freader.lisp;h=6ae6ce414e52f4ddad597a811baae4d951805a31;hb=eaec8176060e89efa39f01017df1f6204e491ecc;hp=4dba26e03a12d53cf650ae69943ff42c681699fc;hpb=90d05e4ae39a451ce13a25f4467d0d280ff49593;p=sbcl.git

diff --git a/src/code/reader.lisp b/src/code/reader.lisp
index 4dba26e..6ae6ce4 100644
--- a/src/code/reader.lisp
+++ b/src/code/reader.lisp
@@ -292,8 +292,8 @@ standard Lisp readtable when NIL."
     (values fun-value
             ;; NON-TERMINATING-P return value:
             (if fun-value
-                (or (constituentp char)
-                    (not (terminating-macrop char)))
+                (or (constituentp char designated-readtable)
+                    (not (terminating-macrop char designated-readtable)))
                 ;; ANSI's definition of GET-MACRO-CHARACTER says this
                 ;; value is NIL when CHAR is not a macro character.
                 ;; I.e. this value means not just "non-terminating
@@ -440,15 +440,11 @@ standard Lisp readtable when NIL."
 ;;;; implementation of the read buffer
 
 (defvar *read-buffer*)
-(defvar *read-buffer-length*)
-;;; FIXME: Is it really helpful to have *READ-BUFFER-LENGTH* be a
-;;; separate variable instead of just calculating it on the fly as
-;;; (LENGTH *READ-BUFFER*)?
 
 (defvar *inch-ptr*) ; *OUCH-PTR* always points to next char to write.
 (defvar *ouch-ptr*) ; *INCH-PTR* always points to next char to read.
 
-(declaim (type index *read-buffer-length* *inch-ptr* *ouch-ptr*))
+(declaim (type index *inch-ptr* *ouch-ptr*))
 (declaim (type (simple-array character (*)) *read-buffer*))
 
 (declaim (inline reset-read-buffer))
@@ -460,18 +456,19 @@ standard Lisp readtable when NIL."
 (declaim (inline ouch-read-buffer))
 (defun ouch-read-buffer (char)
   ;; When buffer overflow
-  (when (>= *ouch-ptr* *read-buffer-length*)
+  (let ((op *ouch-ptr*))
+    (declare (optimize (sb!c::insert-array-bounds-checks 0)))
+    (when (>= op (length *read-buffer*))
     ;; Size should be doubled.
-    (grow-read-buffer))
-  (setf (elt *read-buffer* *ouch-ptr*) char)
-  (setq *ouch-ptr* (1+ *ouch-ptr*)))
+      (grow-read-buffer))
+    (setf (elt *read-buffer* op) char)
+    (setq *ouch-ptr* (1+ op))))
 
 (defun grow-read-buffer ()
   (let* ((rbl (length *read-buffer*))
          (new-length (* 2 rbl))
          (new-buffer (make-string new-length)))
-    (setq *read-buffer* (replace new-buffer *read-buffer*))
-    (setq *read-buffer-length* new-length)))
+    (setq *read-buffer* (replace new-buffer *read-buffer*))))
 
 (defun inch-read-buffer ()
   (if (>= *inch-ptr* *ouch-ptr*)
@@ -492,17 +489,25 @@ standard Lisp readtable when NIL."
 (defun read-buffer-to-string ()
   (subseq *read-buffer* 0 *ouch-ptr*))
 
-(defmacro with-reader ((&optional recursive-p) &body body)
-  #!+sb-doc
-  "If RECURSIVE-P is NIL, bind *READER-BUFFER* and its subservient
-variables to allow for nested and thread safe reading."
-  `(if ,recursive-p
-       (progn ,@body)
-       (let* ((*read-buffer* (make-string 128))
-              (*read-buffer-length* 128)
-              (*ouch-ptr* 0)
-              (*inch-ptr* 0))
-         ,@body)))
+(defmacro with-read-buffer (() &body body)
+  `(let* ((*read-buffer* (make-string 128))
+          (*ouch-ptr* 0)
+          (*inch-ptr* 0))
+     ,@body))
+
+(declaim (inline read-buffer-boundp))
+(defun read-buffer-boundp ()
+  (and (boundp '*read-buffer*)
+       (boundp '*ouch-ptr*)
+       (boundp '*inch-ptr*)))
+
+(defun check-for-recursive-read (stream recursive-p operator-name)
+  (when (and recursive-p (not (read-buffer-boundp)))
+    (simple-reader-error
+     stream
+     "~A was invoked with RECURSIVE-P being true outside ~
+      of a recursive read operation."
+     `(,operator-name))))
 
 ;;;; READ-PRESERVING-WHITESPACE, READ-DELIMITED-LIST, and READ
 
@@ -518,17 +523,10 @@ variables to allow for nested and thread safe reading."
 
 (declaim (special *standard-input*))
 
-;;; READ-PRESERVING-WHITESPACE behaves just like READ, only it makes
-;;; sure to leave terminating whitespace in the stream. (This is a
-;;; COMMON-LISP exported symbol.)
-(defun read-preserving-whitespace (&optional (stream *standard-input*)
-                                             (eof-error-p t)
-                                             (eof-value nil)
-                                             (recursivep nil))
-  #!+sb-doc
-  "Read from STREAM and return the value read, preserving any whitespace
-   that followed the object."
-  (if recursivep
+;;; Like READ-PRESERVING-WHITESPACE, but doesn't check the read buffer
+;;; for being set up properly.
+(defun %read-preserving-whitespace (stream eof-error-p eof-value recursive-p)
+  (if recursive-p
       ;; a loop for repeating when a macro returns nothing
       (loop
        (let ((char (read-char stream eof-error-p *eof-object*)))
@@ -541,9 +539,22 @@ variables to allow for nested and thread safe reading."
                   ;; Repeat if macro returned nothing.
                   (when result
                     (return (unless *read-suppress* (car result)))))))))
-      (with-reader ()
-        (let ((*sharp-equal-alist* nil))
-          (read-preserving-whitespace stream eof-error-p eof-value t)))))
+      (let ((*sharp-equal-alist* nil))
+        (with-read-buffer ()
+          (%read-preserving-whitespace stream eof-error-p eof-value t)))))
+
+;;; READ-PRESERVING-WHITESPACE behaves just like READ, only it makes
+;;; sure to leave terminating whitespace in the stream. (This is a
+;;; COMMON-LISP exported symbol.)
+(defun read-preserving-whitespace (&optional (stream *standard-input*)
+                                             (eof-error-p t)
+                                             (eof-value nil)
+                                             (recursive-p nil))
+  #!+sb-doc
+  "Read from STREAM and return the value read, preserving any whitespace
+   that followed the object."
+  (check-for-recursive-read stream recursive-p 'read-preserving-whitespace)
+  (%read-preserving-whitespace stream eof-error-p eof-value recursive-p))
 
 ;;; Return NIL or a list with one thing, depending.
 ;;;
@@ -558,18 +569,17 @@ variables to allow for nested and thread safe reading."
 
 (defun read (&optional (stream *standard-input*)
                        (eof-error-p t)
-                       (eof-value ())
-                       (recursivep ()))
+                       (eof-value nil)
+                       (recursive-p nil))
   #!+sb-doc
   "Read the next Lisp value from STREAM, and return it."
-  (let ((result (read-preserving-whitespace stream
-                                            eof-error-p
-                                            eof-value
-                                            recursivep)))
+  (check-for-recursive-read stream recursive-p 'read)
+  (let ((result (%read-preserving-whitespace stream eof-error-p eof-value
+                                             recursive-p)))
     ;; This function generally discards trailing whitespace. If you
     ;; don't want to discard trailing whitespace, call
     ;; CL:READ-PRESERVING-WHITESPACE instead.
-    (unless (or (eql result eof-value) recursivep)
+    (unless (or (eql result eof-value) recursive-p)
       (let ((next-char (read-char stream nil nil)))
         (unless (or (null next-char)
                     (whitespace[2]p next-char))
@@ -583,12 +593,20 @@ variables to allow for nested and thread safe reading."
   #!+sb-doc
   "Read Lisp values from INPUT-STREAM until the next character after a
    value's representation is ENDCHAR, and return the objects as a list."
-  (with-reader (recursive-p)
-    (do ((char (flush-whitespace input-stream)
-               (flush-whitespace input-stream))
-         (retlist ()))
-        ((char= char endchar) (unless *read-suppress* (nreverse retlist)))
-      (setq retlist (nconc (read-maybe-nothing input-stream char) retlist)))))
+  (check-for-recursive-read input-stream recursive-p 'read-delimited-list)
+  (flet ((%read-delimited-list (endchar input-stream)
+           (do ((char (flush-whitespace input-stream)
+                      (flush-whitespace input-stream))
+                (retlist ()))
+               ((char= char endchar)
+                (unless *read-suppress* (nreverse retlist)))
+             (setq retlist (nconc (read-maybe-nothing input-stream char)
+                                  retlist)))))
+    (declare (inline %read-delimited-list))
+    (if recursive-p
+        (%read-delimited-list endchar input-stream)
+        (with-read-buffer ()
+          (%read-delimited-list endchar input-stream)))))
 
 ;;;; basic readmacro definitions
 ;;;;
@@ -1524,23 +1542,77 @@ variables to allow for nested and thread safe reading."
 
 ;;;; READ-FROM-STRING
 
-(defun read-from-string (string &optional (eof-error-p t) eof-value
-                                &key (start 0) end
-                                preserve-whitespace)
-  #!+sb-doc
-  "The characters of string are successively given to the lisp reader
-   and the lisp object built by the reader is returned. Macro chars
-   will take effect."
-  (declare (string string))
+(defun maybe-note-read-from-string-signature-issue (eof-error-p)
+  ;; The interface is so unintuitive that we explicitly check for the common
+  ;; error.
+  (when (member eof-error-p '(:start :end :preserve-whitespace))
+    (style-warn "~@<~S as EOF-ERROR-P argument to ~S: probable error. ~
+               Two optional arguments must be provided before the ~
+               first keyword argument.~:@>"
+                eof-error-p 'read-from-string)
+    t))
+
+(declaim (ftype (sfunction (string t t index (or null index) t) (values t index))
+                %read-from-string))
+(defun %read-from-string (string eof-error-p eof-value start end preserve-whitespace)
   (with-array-data ((string string :offset-var offset)
                     (start start)
                     (end end)
                     :check-fill-pointer t)
     (let ((stream (make-string-input-stream string start end)))
       (values (if preserve-whitespace
-                  (read-preserving-whitespace stream eof-error-p eof-value)
+                  (%read-preserving-whitespace stream eof-error-p eof-value nil)
                   (read stream eof-error-p eof-value))
               (- (string-input-stream-current stream) offset)))))
+
+(defun read-from-string (string &optional (eof-error-p t) eof-value
+                                &key (start 0) end preserve-whitespace)
+  #!+sb-doc
+  "The characters of string are successively given to the lisp reader
+   and the lisp object built by the reader is returned. Macro chars
+   will take effect."
+  (declare (string string))
+  (maybe-note-read-from-string-signature-issue eof-error-p)
+  (%read-from-string string eof-error-p eof-value start end preserve-whitespace))
+
+(define-compiler-macro read-from-string (&whole form string &rest args)
+  ;; Check this at compile-time, and rewrite it so we're silent at runtime.
+  (destructuring-bind (&optional (eof-error-p t) eof-value &rest keys)
+      args
+    (cond ((maybe-note-read-from-string-signature-issue eof-error-p)
+           `(read-from-string ,string t ,eof-value ,@keys))
+          (t
+           (let* ((start (gensym "START"))
+                  (end (gensym "END"))
+                  (preserve-whitespace (gensym "PRESERVE-WHITESPACE"))
+                  bind seen ignore)
+             (do ()
+                 ((not (cdr keys))
+                  ;; Odd number of keys, punt.
+                  (when keys (return-from read-from-string form)))
+               (let* ((key (pop keys))
+                      (value (pop keys))
+                      (var (case key
+                             (:start start)
+                             (:end end)
+                             (:preserve-whitespace preserve-whitespace)
+                             (otherwise
+                              (return-from read-from-string form)))))
+                 (when (member key seen)
+                   (setf var (gensym "IGNORE"))
+                   (push var ignore))
+                 (push key seen)
+                 (push (list var value) bind)))
+             (dolist (default (list (list start 0)
+                                    (list end nil)
+                                    (list preserve-whitespace nil)))
+               (unless (assoc (car default) bind)
+                 (push default bind)))
+             (once-only ((string string))
+               `(let ,(nreverse bind)
+                  ,@(when ignore `((declare (ignore ,@ignore))))
+                  (%read-from-string ,string ,eof-error-p ,eof-value
+                                     ,start ,end ,preserve-whitespace))))))))
 
 ;;;; PARSE-INTEGER