(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*)
(defmacro with-read-buffer (() &body body)
`(let* ((*read-buffer* (make-string 128))
- (*read-buffer-length* 128)
(*ouch-ptr* 0)
(*inch-ptr* 0))
,@body))
-(defun check-for-recursive-read (recursive-p operator-name)
- (when (and recursive-p
- (not (and (boundp '*read-buffer*)
- (boundp '*read-buffer-length*)
- (boundp '*ouch-ptr*)
- (boundp '*inch-ptr*))))
- (error 'simple-reader-error
- :format-control "~A was invoked with RECURSIVE-P being true outside ~
- of a recursive read operation."
- :format-arguments `(,operator-name))))
-
+(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
#!+sb-doc
"Read from STREAM and return the value read, preserving any whitespace
that followed the object."
- (check-for-recursive-read recursive-p 'read-preserving-whitespace)
+ (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.
(recursive-p nil))
#!+sb-doc
"Read the next Lisp value from STREAM, and return it."
- (check-for-recursive-read recursive-p 'read)
+ (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
#!+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."
- (check-for-recursive-read recursive-p 'read-delimited-list)
+ (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))