From 15ecd1ada227a60bcb3a660a4924c8d9449cb997 Mon Sep 17 00:00:00 2001 From: Gabor Melis Date: Tue, 5 Jul 2005 10:49:46 +0000 Subject: [PATCH] 0.9.2.25: * use a fresh read buffer for non-recursive reads to allow for nested and thread safe reading * killed read-from-string's string-input-stream and stringify-object's string-output-stream cache mainly for thread safety reasons * as a side-effect potentially huge buffers do not linger --- NEWS | 2 ++ src/code/print.lisp | 9 ++---- src/code/reader.lisp | 70 ++++++++++++++++++++++------------------------ tests/reader.impure.lisp | 19 +++++++++++++ version.lisp-expr | 2 +- 5 files changed, 57 insertions(+), 45 deletions(-) diff --git a/NEWS b/NEWS index bc4b411..8a3a2bd 100644 --- a/NEWS +++ b/NEWS @@ -17,6 +17,7 @@ changes in sbcl-0.9.3 relative to sbcl-0.9.2: * various error reporting improvements. * optimizations: LOGNOR on fixnums is improved in the MIPS backend. (Thanks to Thiemo Seufer) + * bug fix: nested reader invokations work correctly * threads ** added x86-64 support ** incompatible change: the threading api now works with thread @@ -25,6 +26,7 @@ changes in sbcl-0.9.3 relative to sbcl-0.9.2: starting up or going down ** bug fix: a race where an exiting thread could lose its stack to gc ** fixed numerous gc deadlocks introduced in the pthread merge + ** bug fix: fixed thread safety issues in read and print * fixed some bugs revealed by Paul Dietz' test suite: ** TYPE-ERRORs from signalled by COERCE now have DATUM and EXPECTED-TYPE slots filled. diff --git a/src/code/print.lisp b/src/code/print.lisp index 4d7aa09..018cf57 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -230,16 +230,11 @@ ;;; This produces the printed representation of an object as a string. ;;; The few ...-TO-STRING functions above call this. -(defvar *string-output-streams* ()) (defun stringify-object (object) - (let ((stream (if *string-output-streams* - (pop *string-output-streams*) - (make-string-output-stream)))) + (let ((stream (make-string-output-stream))) (setup-printer-state) (output-object object stream) - (prog1 - (get-output-stream-string stream) - (push stream *string-output-streams*)))) + (get-output-stream-string stream))) ;;;; support for the PRINT-UNREADABLE-OBJECT macro diff --git a/src/code/reader.lisp b/src/code/reader.lisp index 86b223e..cbdb50d 100644 --- a/src/code/reader.lisp +++ b/src/code/reader.lisp @@ -63,7 +63,8 @@ ;; FIXME: should probably become inline function `(if (typep ,char 'base-char) (elt (character-attribute-array ,rt) (char-code ,char)) - (gethash ,char (character-attribute-hash-table ,rt) +char-attr-constituent+))) + (gethash ,char (character-attribute-hash-table ,rt) + +char-attr-constituent+))) (defun set-cat-entry (char newvalue &optional (rt *readtable*)) (if (typep char 'base-char) @@ -292,7 +293,8 @@ ((/= (the fixnum (if (typep char 'base-char) (aref attribute-array (char-code char)) - (gethash char attribute-hash-table +char-attr-constituent+))) + (gethash char attribute-hash-table + +char-attr-constituent+))) +char-attr-whitespace+) (done-with-fast-read-char) char))) @@ -305,7 +307,8 @@ (/= (the fixnum (if (typep char 'base-char) (aref attribute-array (char-code char)) - (gethash char attribute-hash-table +char-attr-constituent+))) + (gethash char attribute-hash-table + +char-attr-constituent+))) +char-attr-whitespace+)) (if (eq char :eof) (error 'end-of-file :stream stream) @@ -374,11 +377,6 @@ ;; *INCH-PTR* always points to next char to read. (setq *inch-ptr* 0))) -(defun !cold-init-read-buffer () - (setq *read-buffer* (make-string 512)) ; initial bufsize - (setq *read-buffer-length* 512) - (reset-read-buffer)) - ;;; FIXME I removed "THE FIXNUM"'s from OUCH-READ-BUFFER and ;;; OUCH-UNREAD-BUFFER, check to make sure that Python really is smart ;;; enough to make good code without them. And while I'm at it, @@ -428,6 +426,18 @@ (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))) ;;;; READ-PRESERVING-WHITESPACE, READ-DELIMITED-LIST, and READ @@ -464,10 +474,11 @@ (result (multiple-value-list (funcall macrofun stream char)))) ;; Repeat if macro returned nothing. - (when result + (when result (return (unless *read-suppress* (car result))))))))) - (let ((*sharp-equal-alist* nil)) - (read-preserving-whitespace stream eof-error-p eof-value t)))) + (with-reader () + (let ((*sharp-equal-alist* nil)) + (read-preserving-whitespace stream eof-error-p eof-value t))))) ;;; Return NIL or a list with one thing, depending. ;;; @@ -507,12 +518,12 @@ #!+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." - (declare (ignore 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)))) + (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))))) ;;;; basic readmacro definitions ;;;; @@ -1485,11 +1496,6 @@ ;;;; READ-FROM-STRING -;;; FIXME: Is it really worth keeping this pool? -(defvar *read-from-string-spares* () - #!+sb-doc - "A resource of string streams for Read-From-String.") - (defun read-from-string (string &optional (eof-error-p t) eof-value &key (start 0) end preserve-whitespace) @@ -1498,23 +1504,14 @@ and the lisp object built by the reader is returned. Macro chars will take effect." (declare (string string)) - (with-array-data ((string string :offset-var offset) (start start) (end (%check-vector-sequence-bounds string start end))) - (unless *read-from-string-spares* - (push (make-string-input-stream "" 0 0) *read-from-string-spares*)) - (let ((stream (pop *read-from-string-spares*))) - (setf (string-input-stream-string stream) - (coerce string '(simple-array character (*)))) - (setf (string-input-stream-current stream) start) - (setf (string-input-stream-end stream) end) - (unwind-protect - (values (if preserve-whitespace - (read-preserving-whitespace stream eof-error-p eof-value) - (read stream eof-error-p eof-value)) - (- (string-input-stream-current stream) offset)) - (push stream *read-from-string-spares*))))) + (let ((stream (make-string-input-stream string start end))) + (values (if preserve-whitespace + (read-preserving-whitespace stream eof-error-p eof-value) + (read stream eof-error-p eof-value)) + (- (string-input-stream-current stream) offset))))) ;;;; PARSE-INTEGER @@ -1577,7 +1574,6 @@ ;;;; reader initialization code (defun !reader-cold-init () - (!cold-init-read-buffer) (!cold-init-constituent-trait-table) (!cold-init-standard-readtable) ;; FIXME: This was commented out, but should probably be restored. diff --git a/tests/reader.impure.lisp b/tests/reader.impure.lisp index 46be9f9..1d90ae1 100644 --- a/tests/reader.impure.lisp +++ b/tests/reader.impure.lisp @@ -83,5 +83,24 @@ (assert (eq (symbol-package (read-from-string "||::FOO")) (find-package ""))) +;;; test nested reads, test case by Helmut Eller for cmucl +(defclass my-in-stream (sb-gray:fundamental-character-input-stream) + ((last-char :initarg :last-char))) + +(let ((string " a ") + (i 0)) + (defmethod sb-gray:stream-read-char ((s my-in-stream)) + (with-input-from-string (s "b") (read s)) + (with-slots (last-char) s + (cond (last-char (prog1 last-char (setf last-char nil))) + (t (prog1 (aref string i) + (setq i (mod (1+ i) (length string))))))))) + +(defmethod sb-gray:stream-unread-char ((s my-in-stream) char) + (setf (slot-value s 'last-char) char) + nil) + +(assert (eq 'a (read (make-instance 'my-in-stream :last-char nil)))) + ;;; success (quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index d065352..9622ec5 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.2.24" +"0.9.2.25" -- 1.7.10.4