(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
;;;; 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))
(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*)
(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))))
\f
;;;; READ-PRESERVING-WHITESPACE, READ-DELIMITED-LIST, and READ
(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*)))
;; 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.
;;;
(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))
#!+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)))))
\f
;;;; basic readmacro definitions
;;;;
\f
;;;; 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))))))))
\f
;;;; PARSE-INTEGER