;;; 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*))
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))
(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*))
(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
(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))
(%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.
(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))
(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))
(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))
(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