X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Freader.lisp;h=308d3dd7ddcae82612a511d9dfff8058c1129824;hb=9dcde13065f57a8ad55681575a298fbcac66381b;hp=4dba26e03a12d53cf650ae69943ff42c681699fc;hpb=90d05e4ae39a451ce13a25f4467d0d280ff49593;p=sbcl.git diff --git a/src/code/reader.lisp b/src/code/reader.lisp index 4dba26e..308d3dd 100644 --- a/src/code/reader.lisp +++ b/src/code/reader.lisp @@ -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 ;;;; @@ -1538,7 +1556,7 @@ variables to allow for nested and thread safe reading." :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)))))