1.0.6.28: fix UNWIND-TO-FRAME-AND-CALL for #+SB-THREAD

[sbcl.git] / src / code / reader.lisp

diff --git a/src/code/reader.lisp b/src/code/reader.lisp
index bf17289..08d6ea3 100644 (file)
--- a/src/code/reader.lisp
+++ b/src/code/reader.lisp
@@ -114,8 +114,12 @@
 
 ;;; predicates for testing character attributes
 
-#!-sb-fluid (declaim (inline whitespacep))
-(defun whitespacep (char &optional (rt *readtable*))
+;;; the [1] and [2] here refer to ANSI glossary entries for
+;;; "whitespace".
+#!-sb-fluid (declaim (inline whitespace[1]p whitespace[2]p))
+(defun whitespace[1]p (char)
+  (test-attribute char +char-attr-whitespace+ *standard-readtable*))
+(defun whitespace[2]p (char &optional (rt *readtable*))
   (test-attribute char +char-attr-whitespace+ rt))
 
 (defmacro constituentp (char &optional (rt '*readtable*))
@@ -211,12 +215,11 @@
     really-to-readtable))
 
 (defun set-syntax-from-char (to-char from-char &optional
-                                     (to-readtable *readtable*)
-                                     (from-readtable ()))
+                             (to-readtable *readtable*) (from-readtable ()))
   #!+sb-doc
-  "Causes the syntax of TO-CHAR to be the same as FROM-CHAR in the
-  optional readtable (defaults to the current readtable). The
-  FROM-TABLE defaults to the standard Lisp readtable when NIL."
+  "Causes the syntax of TO-CHAR to be the same as FROM-CHAR in the optional
+readtable (defaults to the current readtable). The FROM-TABLE defaults to the
+standard Lisp readtable when NIL."
   (let ((really-from-readtable (or from-readtable *standard-readtable*)))
     (let ((att (get-cat-entry from-char really-from-readtable))
           (mac (get-raw-cmt-entry from-char really-from-readtable))
@@ -398,12 +401,11 @@
      (setq *ouch-ptr* (1- (the fixnum *ouch-ptr*)))))
 
 (defun grow-read-buffer ()
-  (let ((rbl (length (the simple-string *read-buffer*))))
-    (setq *read-buffer*
-          (concatenate 'simple-string
-                       *read-buffer*
-                       (make-string rbl)))
-    (setq *read-buffer-length* (* 2 rbl))))
+  (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)))
 
 (defun inchpeek-read-buffer ()
   (if (>= (the fixnum *inch-ptr*) (the fixnum *ouch-ptr*))
@@ -468,7 +470,7 @@ variables to allow for nested and thread safe reading."
       (loop
        (let ((char (read-char stream eof-error-p *eof-object*)))
          (cond ((eofp char) (return eof-value))
-               ((whitespacep char))
+               ((whitespace[2]p char))
                (t
                 (let* ((macrofun (get-coerced-cmt-entry char *readtable*))
                        (result (multiple-value-list
@@ -507,7 +509,7 @@ variables to allow for nested and thread safe reading."
     (unless (or (eql result eof-value) recursivep)
       (let ((next-char (read-char stream nil nil)))
         (unless (or (null next-char)
-                    (whitespacep next-char))
+                    (whitespace[2]p next-char))
           (unread-char next-char stream))))
     result))
 
@@ -569,7 +571,7 @@ variables to allow for nested and thread safe reading."
                               (%reader-error
                                stream
                                "Nothing appears before . in list.")))
-                           ((whitespacep nextchar)
+                           ((whitespace[2]p nextchar)
                             (setq nextchar (flush-whitespace stream))))
                      (rplacd listtail
                              ;; Return list containing last thing.
@@ -773,16 +775,20 @@ variables to allow for nested and thread safe reading."
   (let ((case (readtable-case *readtable*)))
     (cond
      ((and (null escapes) (eq case :upcase))
-      (dotimes (i *ouch-ptr*)
-        (setf (schar *read-buffer* i)
-              (char-upcase (schar *read-buffer* i)))))
+      ;; Pull the special variable access out of the loop.
+      (let ((buffer *read-buffer*))
+        (dotimes (i *ouch-ptr*)
+          (declare (optimize (sb!c::insert-array-bounds-checks 0)))
+          (setf (schar buffer i) (char-upcase (schar buffer i))))))
      ((eq case :preserve))
      (t
       (macrolet ((skip-esc (&body body)
                    `(do ((i (1- *ouch-ptr*) (1- i))
+                         (buffer *read-buffer*)
                          (escapes escapes))
                         ((minusp i))
-                      (declare (fixnum i))
+                      (declare (fixnum i)
+                               (optimize (sb!c::insert-array-bounds-checks 0)))
                       (when (or (null escapes)
                                 (let ((esc (first escapes)))
                                   (declare (fixnum esc))
@@ -791,12 +797,12 @@ variables to allow for nested and thread safe reading."
                                          (aver (= esc i))
                                          (pop escapes)
                                          nil))))
-                        (let ((ch (schar *read-buffer* i)))
+                        (let ((ch (schar buffer i)))
                           ,@body)))))
         (flet ((lower-em ()
-                 (skip-esc (setf (schar *read-buffer* i) (char-downcase ch))))
+                 (skip-esc (setf (schar buffer i) (char-downcase ch))))
                (raise-em ()
-                 (skip-esc (setf (schar *read-buffer* i) (char-upcase ch)))))
+                 (skip-esc (setf (schar buffer i) (char-upcase ch)))))
           (ecase case
             (:upcase (raise-em))
             (:downcase (lower-em))
@@ -1534,7 +1540,7 @@ variables to allow for nested and thread safe reading."
                             (return-from parse-integer (values nil end))
                             (parse-error "no non-whitespace characters in string ~S.")))
                      (declare (fixnum i))
-                     (unless (whitespacep (char string i)) (return i))))
+                     (unless (whitespace[1]p (char string i)) (return i))))
             (minusp nil)
             (found-digit nil)
             (result 0))
@@ -1553,11 +1559,11 @@ variables to allow for nested and thread safe reading."
                   (setq result (+ weight (* result radix))
                         found-digit t))
                  (junk-allowed (return nil))
-                 ((whitespacep char)
+                 ((whitespace[1]p char)
                   (loop
                    (incf index)
                    (when (= index end) (return))
-                   (unless (whitespacep (char string index))
+                   (unless (whitespace[1]p (char string index))
                       (parse-error "junk in string ~S")))
                   (return nil))
                  (t