miscellaneous cleanups..
..made COPY-TYPE-CLASS-COLDLY use *TYPE-CLASS-FUNCTION-SLOTS*
to reduce duplication of information
..renamed all the DEFCONSTANT FOO definitions in reader.lisp
to DEFCONSTANT +CHAR-ATTR-FOO+ style
..renamed IN-BUFFER-LENGTH to +IN-BUFFER-LENGTH+ too
..and IN-BUFFER-EXTRA to +IN-BUFFER-EXTRA+
..moved byte-interp adjacent to other byte-foo in build order
..removed EVAL-WHEN around DEFTYPEs in bit-bash.lisp
..fixed DECLAIM of *FASL-FILE*, as per kon@iki.fi cmucl-help
2001-03-19 bug report
88:
The type system doesn't understand that the intersection of the
- types (MEMBER :FOO) and (OR KEYWORD NULL) is (MEMBER :FOO).
+ types (MEMBER :FOO) and (OR KEYWORD NULL) is (MEMBER :FOO). Thus,
+ the optimizer can't make some useful valid type inferences.
89:
The type system doesn't understand the the intersection of the types
KEYWORD and (OR KEYWORD NULL) is KEYWORD, perhaps because KEYWORD
is itself an intersection type and that causes technical problems
- with the simplification.
+ with the simplification. Thus, the optimizer can't make some useful
+ valid type inferences.
+
+90:
+ a latent cross-compilation/bootstrapping bug: The cross-compilation
+ host's CL:CHAR-CODE-LIMIT is used in target code in readtable.lisp
+ and possibly elsewhere. Instead, we should use the target system's
+ CHAR-CODE-LIMIT. This will probably cause problems if we try to
+ bootstrap on a system which uses a different value of CHAR-CODE-LIMIT
+ than SBCL does.
KNOWN BUGS RELATED TO THE IR1 INTERPRETER
;;; the maximum number of bits that can be dealt with in a single call
(defconstant max-bits (ash most-positive-fixnum -2))
-(eval-when (:compile-toplevel :load-toplevel :execute)
-
-;;; FIXME: Do we really need EVAL-WHEN around the DEFTYPEs?
(deftype unit ()
`(unsigned-byte ,unit-bits))
(deftype word-offset ()
`(integer 0 (,(ceiling max-bits unit-bits))))
-
-) ; EVAL-WHEN
\f
;;;; support routines
(setf (fd-stream-n-bin stream) #'fd-stream-read-n-bytes)
(when buffer-p
(setf (lisp-stream-in-buffer stream)
- (make-array in-buffer-length
+ (make-array +in-buffer-length+
:element-type '(unsigned-byte 8)))))
(setf input-size size)
(setf input-type type)))
;;; the size of a stream in-buffer
;;;
;;; KLUDGE: The EVAL-WHEN wrapper isn't needed except when using CMU
-;;; CL as a cross-compilation host. cmucl-2.4.19 issues full WARNINGs
-;;; (not just STYLE-WARNINGs!) when processing this file, and when
-;;; processing other files which use LISP-STREAM. -- WHN 2000-12-13
+;;; CL as a cross-compilation host. Without it, cmucl-2.4.19 issues
+;;; full WARNINGs (not just STYLE-WARNINGs!) when processing this
+;;; file, and when processing other files which use LISP-STREAM.
+;;; -- WHN 2000-12-13
(eval-when (:compile-toplevel :load-toplevel :execute)
- (defconstant in-buffer-length 512))
+ (defconstant +in-buffer-length+ 512))
(deftype in-buffer-type ()
- `(simple-array (unsigned-byte 8) (,in-buffer-length)))
+ `(simple-array (unsigned-byte 8) (,+in-buffer-length+)))
(defstruct (lisp-stream (:constructor nil)
(:copier nil))
;; Buffered input.
(in-buffer nil :type (or in-buffer-type null))
- (in-index in-buffer-length :type index) ; index into IN-BUFFER
+ (in-index +in-buffer-length+ :type index) ; index into IN-BUFFER
(in #'ill-in :type function) ; READ-CHAR function
(bin #'ill-bin :type function) ; byte input function
(n-bin #'ill-bin :type function) ; n-byte input function
;;; the FASL file we're reading from
(defvar *fasl-file*)
-(declaim (type lisp-stream fasl-file))
+(declaim (type lisp-stream *fasl-file*))
(defvar *load-print* nil
#!+sb-doc
:format-control control
:format-arguments args))
\f
-;;;; constants for character attributes. These are all as in the manual.
-
-;;; FIXME: It's disturbing to bind nice names like ESCAPE and DELIMITER
-;;; as constants throughout the entire SB-IMPL package. Perhaps these
-;;; could be given some standard prefix, so instead we have constants
-;;; CHATTR-ESCAPE and CHATTR-DELIMITER and so forth.
-(defconstant whitespace 0)
-(defconstant terminating-macro 1)
-(defconstant escape 2)
-(defconstant constituent 3)
-(defconstant constituent-dot 4)
-(defconstant constituent-expt 5)
-(defconstant constituent-slash 6)
-(defconstant constituent-digit 7)
-(defconstant constituent-sign 8)
-;; the "9" entry intentionally left blank for some reason -- WHN 19990806
-(defconstant multiple-escape 10)
-(defconstant package-delimiter 11)
-(defconstant delimiter 12) ; (a fake for use in READ-UNQUALIFIED-TOKEN)
-\f
;;;; macros and functions for character tables
;;; FIXME: could be SB!XC:DEFMACRO inside EVAL-WHEN (COMPILE EVAL)
#!-sb-fluid (declaim (inline whitespacep))
(defun whitespacep (char &optional (rt *readtable*))
- (test-attribute char whitespace rt))
+ (test-attribute char +char-attr-whitespace+ rt))
(defmacro constituentp (char &optional (rt '*readtable*))
- `(>= (get-cat-entry ,char ,rt) constituent))
+ `(>= (get-cat-entry ,char ,rt) +char-attr-constituent+))
(defmacro terminating-macrop (char &optional (rt '*readtable*))
- `(test-attribute ,char terminating-macro ,rt))
+ `(test-attribute ,char +char-attr-terminating-macro+ ,rt))
(defmacro escapep (char &optional (rt '*readtable*))
- `(test-attribute ,char escape ,rt))
+ `(test-attribute ,char +char-attr-escape+ ,rt))
(defmacro multiple-escape-p (char &optional (rt '*readtable*))
- `(test-attribute ,char multiple-escape ,rt))
+ `(test-attribute ,char +char-attr-multiple-escape+ ,rt))
(defmacro token-delimiterp (char &optional (rt '*readtable*))
;; depends on actual attribute numbering above.
- `(<= (get-cat-entry ,char ,rt) terminating-macro))
+ `(<= (get-cat-entry ,char ,rt) +char-attr-terminating-macro+))
\f
;;;; secondary attribute table
-;;; There are a number of "secondary" attributes which are constant properties
-;;; of characters (as long as they are constituents).
+;;; There are a number of "secondary" attributes which are constant
+;;; properties of characters (as long as they are constituents).
(defvar *secondary-attribute-table*)
(declaim (type attribute-table *secondary-attribute-table*))
(defun !cold-init-secondary-attribute-table ()
(setq *secondary-attribute-table*
(make-array char-code-limit :element-type '(unsigned-byte 8)
- :initial-element constituent))
- (!set-secondary-attribute #\: package-delimiter)
- (!set-secondary-attribute #\| multiple-escape) ; |) [for EMACS]
- (!set-secondary-attribute #\. constituent-dot)
- (!set-secondary-attribute #\+ constituent-sign)
- (!set-secondary-attribute #\- constituent-sign)
- (!set-secondary-attribute #\/ constituent-slash)
+ :initial-element +char-attr-constituent+))
+ (!set-secondary-attribute #\: +char-attr-package-delimiter+)
+ (!set-secondary-attribute #\| +char-attr-multiple-escape+) ; |) [for EMACS]
+ (!set-secondary-attribute #\. +char-attr-constituent-dot+)
+ (!set-secondary-attribute #\+ +char-attr-constituent-sign+)
+ (!set-secondary-attribute #\- +char-attr-constituent-sign+)
+ (!set-secondary-attribute #\/ +char-attr-constituent-slash+)
(do ((i (char-code #\0) (1+ i)))
((> i (char-code #\9)))
- (!set-secondary-attribute (code-char i) constituent-digit))
- (!set-secondary-attribute #\E constituent-expt)
- (!set-secondary-attribute #\F constituent-expt)
- (!set-secondary-attribute #\D constituent-expt)
- (!set-secondary-attribute #\S constituent-expt)
- (!set-secondary-attribute #\L constituent-expt)
- (!set-secondary-attribute #\e constituent-expt)
- (!set-secondary-attribute #\f constituent-expt)
- (!set-secondary-attribute #\d constituent-expt)
- (!set-secondary-attribute #\s constituent-expt)
- (!set-secondary-attribute #\l constituent-expt))
+ (!set-secondary-attribute (code-char i) +char-attr-constituent-digit+))
+ (!set-secondary-attribute #\E +char-attr-constituent-expt+)
+ (!set-secondary-attribute #\F +char-attr-constituent-expt+)
+ (!set-secondary-attribute #\D +char-attr-constituent-expt+)
+ (!set-secondary-attribute #\S +char-attr-constituent-expt+)
+ (!set-secondary-attribute #\L +char-attr-constituent-expt+)
+ (!set-secondary-attribute #\e +char-attr-constituent-expt+)
+ (!set-secondary-attribute #\f +char-attr-constituent-expt+)
+ (!set-secondary-attribute #\d +char-attr-constituent-expt+)
+ (!set-secondary-attribute #\s +char-attr-constituent-expt+)
+ (!set-secondary-attribute #\l +char-attr-constituent-expt+))
(defmacro get-secondary-attribute (char)
`(elt *secondary-attribute-table*
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*)))
- ;; Copy from-char entries to to-char entries, but make sure that if
+ ;; Copy FROM-CHAR entries to TO-CHAR entries, but make sure that if
;; from char is a constituent you don't copy non-movable secondary
;; attributes (constituent types), and that said attributes magically
;; appear if you transform a non-constituent to a constituent.
returns T."
(if non-terminatingp
(set-cat-entry char (get-secondary-attribute char) rt)
- (set-cat-entry char terminating-macro rt))
+ (set-cat-entry char +char-attr-terminating-macro+ rt))
(set-cmt-entry char function rt)
T)
(do ((attribute-table (character-attribute-table *readtable*))
(char (fast-read-char t) (fast-read-char t)))
((/= (the fixnum (aref attribute-table (char-code char)))
- whitespace)
+ +char-attr-whitespace+)
(done-with-fast-read-char)
char)))
;; fundamental-stream
(char (stream-read-char stream) (stream-read-char stream)))
((or (eq char :eof)
(/= (the fixnum (aref attribute-table (char-code char)))
- whitespace))
+ +char-attr-whitespace+))
(if (eq char :eof)
(error 'end-of-file :stream stream)
char))))))
;; All characters default to "constituent" in MAKE-READTABLE.
;; *** un-constituent-ize some of these ***
(let ((*readtable* *standard-readtable*))
- (set-cat-entry (code-char tab-char-code) whitespace)
- (set-cat-entry #\linefeed whitespace)
- (set-cat-entry #\space whitespace)
- (set-cat-entry (code-char form-feed-char-code) whitespace)
- (set-cat-entry (code-char return-char-code) whitespace)
- (set-cat-entry #\\ escape)
+ (set-cat-entry (code-char tab-char-code) +char-attr-whitespace+)
+ (set-cat-entry #\linefeed +char-attr-whitespace+)
+ (set-cat-entry #\space +char-attr-whitespace+)
+ (set-cat-entry (code-char form-feed-char-code) +char-attr-whitespace+)
+ (set-cat-entry (code-char return-char-code) +char-attr-whitespace+)
+ (set-cat-entry #\\ +char-attr-escape+)
(set-cmt-entry #\\ #'read-token)
- (set-cat-entry (code-char rubout-char-code) whitespace)
+ (set-cat-entry (code-char rubout-char-code) +char-attr-whitespace+)
(set-cmt-entry #\: #'read-token)
(set-cmt-entry #\| #'read-token)
;; macro definitions
(declaim (special *standard-input*))
-;;; READ-PRESERVING-WHITESPACE behaves just like READ, only it makes sure
-;;; to leave terminating whitespace in the stream.
+;;; 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)
(let ((*sharp-equal-alist* nil))
(read-preserving-whitespace stream eof-error-p eof-value t)))))
+;;; Return NIL or a list with one thing, depending.
+;;;
+;;; for functions that want comments to return so that they can look
+;;; past them. Assumes char is not whitespace.
(defun read-maybe-nothing (stream char)
- ;;returns nil or a list with one thing, depending.
- ;;for functions that want comments to return so they can look
- ;;past them. Assumes char is not whitespace.
(let ((retval (multiple-value-list
(funcall (get-cmt-entry char *readtable*) stream char))))
(if retval (rplacd retval nil))))
recursivep))
(unread-char whitechar stream)))))
+;;; (This is a COMMON-LISP exported symbol.)
(defun read-delimited-list (endchar &optional
(input-stream *standard-input*)
recursive-p)
(t
(when (and (constituentp char)
(eql (get-secondary-attribute char)
- package-delimiter)
+ +char-attr-package-delimiter+)
(not colon))
(setq colon *ouch-ptr*))
(ouch-read-buffer char))))))
(defmacro char-class (char attable)
`(let ((att (aref ,attable (char-code ,char))))
(declare (fixnum att))
- (if (<= att terminating-macro)
- delimiter
+ (if (<= att +char-attr-terminating-macro+)
+ +char-attr-delimiter+
att)))
;;; Return the character class for CHAR, which might be part of a
(defmacro char-class2 (char attable)
`(let ((att (aref ,attable (char-code ,char))))
(declare (fixnum att))
- (if (<= att terminating-macro)
- delimiter
+ (if (<= att +char-attr-terminating-macro+)
+ +char-attr-delimiter+
(if (digit-char-p ,char *read-base*)
- constituent-digit
- (if (= att constituent-digit)
- constituent
+ +char-attr-constituent-digit+
+ (if (= att +char-attr-constituent-digit+)
+ +char-attr-constituent+
att)))))
-;;; Return the character class for a char which might be part of a rational or
-;;; floating number. (Assume that it is a digit if it could be.)
+;;; Return the character class for a char which might be part of a
+;;; rational or floating number. (Assume that it is a digit if it
+;;; could be.)
(defmacro char-class3 (char attable)
`(let ((att (aref ,attable (char-code ,char))))
(declare (fixnum att))
(if possibly-rational
(setq possibly-rational
(or (digit-char-p ,char *read-base*)
- (= att constituent-slash))))
+ (= att +char-attr-constituent-slash+))))
(if possibly-float
(setq possibly-float
(or (digit-char-p ,char 10)
- (= att constituent-dot))))
- (if (<= att terminating-macro)
- delimiter
+ (= att +char-attr-constituent-dot+))))
+ (if (<= att +char-attr-terminating-macro+)
+ +char-attr-delimiter+
(if (digit-char-p ,char (max *read-base* 10))
(if (digit-char-p ,char *read-base*)
- constituent-digit
- constituent)
+ +char-attr-constituent-digit+
+ +char-attr-constituent+)
att))))
\f
;;;; token fetching
"The radix that Lisp reads numbers in.")
(declaim (type (integer 2 36) *read-base*))
-;;; Modify the read buffer according to READTABLE-CASE, ignoring escapes.
-;;; ESCAPES is a list of the escaped indices, in reverse order.
+;;; Modify the read buffer according to READTABLE-CASE, ignoring
+;;; ESCAPES. ESCAPES is a list of the escaped indices, in reverse
+;;; order.
(defun casify-read-buffer (escapes)
(let ((case (readtable-case *readtable*)))
(cond
(reset-read-buffer)
(prog ((char firstchar))
(case (char-class3 char attribute-table)
- (#.constituent-sign (go SIGN))
- (#.constituent-digit (go LEFTDIGIT))
- (#.constituent-dot (go FRONTDOT))
- (#.escape (go ESCAPE))
- (#.package-delimiter (go COLON))
- (#.multiple-escape (go MULT-ESCAPE))
+ (#.+char-attr-constituent-sign+ (go SIGN))
+ (#.+char-attr-constituent-digit+ (go LEFTDIGIT))
+ (#.+char-attr-constituent-dot+ (go FRONTDOT))
+ (#.+char-attr-escape+ (go ESCAPE))
+ (#.+char-attr-package-delimiter+ (go COLON))
+ (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
;; can't have eof, whitespace, or terminating macro as first char!
(t (go SYMBOL)))
SIGN ; saw "sign"
(setq possibly-rational t
possibly-float t)
(case (char-class3 char attribute-table)
- (#.constituent-digit (go LEFTDIGIT))
- (#.constituent-dot (go SIGNDOT))
- (#.escape (go ESCAPE))
- (#.package-delimiter (go COLON))
- (#.multiple-escape (go MULT-ESCAPE))
- (#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
+ (#.+char-attr-constituent-digit+ (go LEFTDIGIT))
+ (#.+char-attr-constituent-dot+ (go SIGNDOT))
+ (#.+char-attr-escape+ (go ESCAPE))
+ (#.+char-attr-package-delimiter+ (go COLON))
+ (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
+ (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
(t (go SYMBOL)))
LEFTDIGIT ; saw "[sign] {digit}+"
(ouch-read-buffer char)
(setq char (read-char stream nil nil))
(unless char (return (make-integer)))
(case (char-class3 char attribute-table)
- (#.constituent-digit (go LEFTDIGIT))
- (#.constituent-dot (if possibly-float
- (go MIDDLEDOT)
- (go SYMBOL)))
- (#.constituent-expt (go EXPONENT))
- (#.constituent-slash (if possibly-rational
- (go RATIO)
- (go SYMBOL)))
- (#.delimiter (unread-char char stream) (return (make-integer)))
- (#.escape (go ESCAPE))
- (#.multiple-escape (go MULT-ESCAPE))
- (#.package-delimiter (go COLON))
+ (#.+char-attr-constituent-digit+ (go LEFTDIGIT))
+ (#.+char-attr-constituent-dot+ (if possibly-float
+ (go MIDDLEDOT)
+ (go SYMBOL)))
+ (#.+char-attr-constituent-expt+ (go EXPONENT))
+ (#.+char-attr-constituent-slash+ (if possibly-rational
+ (go RATIO)
+ (go SYMBOL)))
+ (#.+char-attr-delimiter+ (unread-char char stream)
+ (return (make-integer)))
+ (#.+char-attr-escape+ (go ESCAPE))
+ (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
+ (#.+char-attr-package-delimiter+ (go COLON))
(t (go SYMBOL)))
MIDDLEDOT ; saw "[sign] {digit}+ dot"
(ouch-read-buffer char)
(unless char (return (let ((*read-base* 10))
(make-integer))))
(case (char-class char attribute-table)
- (#.constituent-digit (go RIGHTDIGIT))
- (#.constituent-expt (go EXPONENT))
- (#.delimiter
+ (#.+char-attr-constituent-digit+ (go RIGHTDIGIT))
+ (#.+char-attr-constituent-expt+ (go EXPONENT))
+ (#.+char-attr-delimiter+
(unread-char char stream)
(return (let ((*read-base* 10))
(make-integer))))
- (#.escape (go ESCAPE))
- (#.multiple-escape (go MULT-ESCAPE))
- (#.package-delimiter (go COLON))
+ (#.+char-attr-escape+ (go ESCAPE))
+ (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
+ (#.+char-attr-package-delimiter+ (go COLON))
(t (go SYMBOL)))
RIGHTDIGIT ; saw "[sign] {digit}* dot {digit}+"
(ouch-read-buffer char)
(setq char (read-char stream nil nil))
(unless char (return (make-float)))
(case (char-class char attribute-table)
- (#.constituent-digit (go RIGHTDIGIT))
- (#.constituent-expt (go EXPONENT))
- (#.delimiter (unread-char char stream) (return (make-float)))
- (#.escape (go ESCAPE))
- (#.multiple-escape (go MULT-ESCAPE))
- (#.package-delimiter (go COLON))
+ (#.+char-attr-constituent-digit+ (go RIGHTDIGIT))
+ (#.+char-attr-constituent-expt+ (go EXPONENT))
+ (#.+char-attr-delimiter+
+ (unread-char char stream)
+ (return (make-float)))
+ (#.+char-attr-escape+ (go ESCAPE))
+ (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
+ (#.+char-attr-package-delimiter+ (go COLON))
(t (go SYMBOL)))
SIGNDOT ; saw "[sign] dot"
(ouch-read-buffer char)
(setq char (read-char stream nil nil))
(unless char (go RETURN-SYMBOL))
(case (char-class char attribute-table)
- (#.constituent-digit (go RIGHTDIGIT))
- (#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
- (#.escape (go ESCAPE))
- (#.multiple-escape (go MULT-ESCAPE))
+ (#.+char-attr-constituent-digit+ (go RIGHTDIGIT))
+ (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
+ (#.+char-attr-escape+ (go ESCAPE))
+ (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
(t (go SYMBOL)))
FRONTDOT ; saw "dot"
(ouch-read-buffer char)
(setq char (read-char stream nil nil))
(unless char (%reader-error stream "dot context error"))
(case (char-class char attribute-table)
- (#.constituent-digit (go RIGHTDIGIT))
- (#.constituent-dot (go DOTS))
- (#.delimiter (%reader-error stream "dot context error"))
- (#.escape (go ESCAPE))
- (#.multiple-escape (go MULT-ESCAPE))
- (#.package-delimiter (go COLON))
+ (#.+char-attr-constituent-digit+ (go RIGHTDIGIT))
+ (#.+char-attr-constituent-dot+ (go DOTS))
+ (#.+char-attr-delimiter+ (%reader-error stream "dot context error"))
+ (#.+char-attr-escape+ (go ESCAPE))
+ (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
+ (#.+char-attr-package-delimiter+ (go COLON))
(t (go SYMBOL)))
EXPONENT
(ouch-read-buffer char)
(setq char (read-char stream nil nil))
(unless char (go RETURN-SYMBOL))
(case (char-class char attribute-table)
- (#.constituent-sign (go EXPTSIGN))
- (#.constituent-digit (go EXPTDIGIT))
- (#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
- (#.escape (go ESCAPE))
- (#.multiple-escape (go MULT-ESCAPE))
- (#.package-delimiter (go COLON))
+ (#.+char-attr-constituent-sign+ (go EXPTSIGN))
+ (#.+char-attr-constituent-digit+ (go EXPTDIGIT))
+ (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
+ (#.+char-attr-escape+ (go ESCAPE))
+ (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
+ (#.+char-attr-package-delimiter+ (go COLON))
(t (go SYMBOL)))
EXPTSIGN ; got to EXPONENT, and saw a sign character
(ouch-read-buffer char)
(setq char (read-char stream nil nil))
(unless char (go RETURN-SYMBOL))
(case (char-class char attribute-table)
- (#.constituent-digit (go EXPTDIGIT))
- (#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
- (#.escape (go ESCAPE))
- (#.multiple-escape (go MULT-ESCAPE))
- (#.package-delimiter (go COLON))
+ (#.+char-attr-constituent-digit+ (go EXPTDIGIT))
+ (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
+ (#.+char-attr-escape+ (go ESCAPE))
+ (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
+ (#.+char-attr-package-delimiter+ (go COLON))
(t (go SYMBOL)))
EXPTDIGIT ; got to EXPONENT, saw "[sign] {digit}+"
(ouch-read-buffer char)
(setq char (read-char stream nil nil))
(unless char (return (make-float)))
(case (char-class char attribute-table)
- (#.constituent-digit (go EXPTDIGIT))
- (#.delimiter (unread-char char stream) (return (make-float)))
- (#.escape (go ESCAPE))
- (#.multiple-escape (go MULT-ESCAPE))
- (#.package-delimiter (go COLON))
+ (#.+char-attr-constituent-digit+ (go EXPTDIGIT))
+ (#.+char-attr-delimiter+
+ (unread-char char stream)
+ (return (make-float)))
+ (#.+char-attr-escape+ (go ESCAPE))
+ (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
+ (#.+char-attr-package-delimiter+ (go COLON))
(t (go SYMBOL)))
RATIO ; saw "[sign] {digit}+ slash"
(ouch-read-buffer char)
(setq char (read-char stream nil nil))
(unless char (go RETURN-SYMBOL))
(case (char-class2 char attribute-table)
- (#.constituent-digit (go RATIODIGIT))
- (#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
- (#.escape (go ESCAPE))
- (#.multiple-escape (go MULT-ESCAPE))
- (#.package-delimiter (go COLON))
+ (#.+char-attr-constituent-digit+ (go RATIODIGIT))
+ (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
+ (#.+char-attr-escape+ (go ESCAPE))
+ (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
+ (#.+char-attr-package-delimiter+ (go COLON))
(t (go SYMBOL)))
RATIODIGIT ; saw "[sign] {digit}+ slash {digit}+"
(ouch-read-buffer char)
(setq char (read-char stream nil nil))
(unless char (return (make-ratio)))
(case (char-class2 char attribute-table)
- (#.constituent-digit (go RATIODIGIT))
- (#.delimiter (unread-char char stream) (return (make-ratio)))
- (#.escape (go ESCAPE))
- (#.multiple-escape (go MULT-ESCAPE))
- (#.package-delimiter (go COLON))
+ (#.+char-attr-constituent-digit+ (go RATIODIGIT))
+ (#.+char-attr-delimiter+
+ (unread-char char stream)
+ (return (make-ratio)))
+ (#.+char-attr-escape+ (go ESCAPE))
+ (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
+ (#.+char-attr-package-delimiter+ (go COLON))
(t (go SYMBOL)))
DOTS ; saw "dot {dot}+"
(ouch-read-buffer char)
(setq char (read-char stream nil nil))
(unless char (%reader-error stream "too many dots"))
(case (char-class char attribute-table)
- (#.constituent-dot (go DOTS))
- (#.delimiter
+ (#.+char-attr-constituent-dot+ (go DOTS))
+ (#.+char-attr-delimiter+
(unread-char char stream)
(%reader-error stream "too many dots"))
- (#.escape (go ESCAPE))
- (#.multiple-escape (go MULT-ESCAPE))
- (#.package-delimiter (go COLON))
+ (#.+char-attr-escape+ (go ESCAPE))
+ (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
+ (#.+char-attr-package-delimiter+ (go COLON))
(t (go SYMBOL)))
SYMBOL ; not a dot, dots, or number
(let ((stream (in-synonym-of stream)))
(setq char (fast-read-char nil nil))
(unless char (go RETURN-SYMBOL))
(case (char-class char attribute-table)
- (#.escape (done-with-fast-read-char)
- (go ESCAPE))
- (#.delimiter (done-with-fast-read-char)
- (unread-char char stream)
- (go RETURN-SYMBOL))
- (#.multiple-escape (done-with-fast-read-char)
- (go MULT-ESCAPE))
- (#.package-delimiter (done-with-fast-read-char)
- (go COLON))
+ (#.+char-attr-escape+ (done-with-fast-read-char)
+ (go ESCAPE))
+ (#.+char-attr-delimiter+ (done-with-fast-read-char)
+ (unread-char char stream)
+ (go RETURN-SYMBOL))
+ (#.+char-attr-multiple-escape+ (done-with-fast-read-char)
+ (go MULT-ESCAPE))
+ (#.+char-attr-package-delimiter+ (done-with-fast-read-char)
+ (go COLON))
(t (go SYMBOL-LOOP)))))
;; fundamental-stream
(prog ()
(setq char (stream-read-char stream))
(when (eq char :eof) (go RETURN-SYMBOL))
(case (char-class char attribute-table)
- (#.escape (go ESCAPE))
- (#.delimiter (stream-unread-char stream char)
+ (#.+char-attr-escape+ (go ESCAPE))
+ (#.+char-attr-delimiter+ (stream-unread-char stream char)
(go RETURN-SYMBOL))
- (#.multiple-escape (go MULT-ESCAPE))
- (#.package-delimiter (go COLON))
+ (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
+ (#.+char-attr-package-delimiter+ (go COLON))
(t (go SYMBOL-LOOP))))))
ESCAPE ; saw an escape
;; Don't put the escape in the read buffer.
(setq char (read-char stream nil nil))
(unless char (go RETURN-SYMBOL))
(case (char-class char attribute-table)
- (#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
- (#.escape (go ESCAPE))
- (#.multiple-escape (go MULT-ESCAPE))
- (#.package-delimiter (go COLON))
+ (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
+ (#.+char-attr-escape+ (go ESCAPE))
+ (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
+ (#.+char-attr-package-delimiter+ (go COLON))
(t (go SYMBOL)))
MULT-ESCAPE
(do ((char (read-char stream t) (read-char stream t)))
(setq char (read-char stream nil nil))
(unless char (go RETURN-SYMBOL))
(case (char-class char attribute-table)
- (#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
- (#.escape (go ESCAPE))
- (#.multiple-escape (go MULT-ESCAPE))
- (#.package-delimiter (go COLON))
+ (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL))
+ (#.+char-attr-escape+ (go ESCAPE))
+ (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
+ (#.+char-attr-package-delimiter+ (go COLON))
(t (go SYMBOL)))
COLON
(casify-read-buffer escapes)
(setq char (read-char stream nil nil))
(unless char (reader-eof-error stream "after reading a colon"))
(case (char-class char attribute-table)
- (#.delimiter
+ (#.+char-attr-delimiter+
(unread-char char stream)
(%reader-error stream
"illegal terminating character after a colon: ~S"
char))
- (#.escape (go ESCAPE))
- (#.multiple-escape (go MULT-ESCAPE))
- (#.package-delimiter (go INTERN))
+ (#.+char-attr-escape+ (go ESCAPE))
+ (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
+ (#.+char-attr-package-delimiter+ (go INTERN))
(t (go SYMBOL)))
INTERN
(setq colons 2)
(unless char
(reader-eof-error stream "after reading a colon"))
(case (char-class char attribute-table)
- (#.delimiter
+ (#.+char-attr-delimiter+
(unread-char char stream)
(%reader-error stream
"illegal terminating character after a colon: ~S"
char))
- (#.escape (go ESCAPE))
- (#.multiple-escape (go MULT-ESCAPE))
- (#.package-delimiter
+ (#.+char-attr-escape+ (go ESCAPE))
+ (#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
+ (#.+char-attr-package-delimiter+
(%reader-error stream
"too many colons after ~S name"
package-designator))
(sb!xc:deftype attribute-table ()
'(simple-array (unsigned-byte 8) (#.char-code-limit)))
+;;; constants for readtable character attributes. These are all as in
+;;; the manual.
+(defconstant +char-attr-whitespace+ 0)
+(defconstant +char-attr-terminating-macro+ 1)
+(defconstant +char-attr-escape+ 2)
+(defconstant +char-attr-constituent+ 3)
+(defconstant +char-attr-constituent-dot+ 4)
+(defconstant +char-attr-constituent-expt+ 5)
+(defconstant +char-attr-constituent-slash+ 6)
+(defconstant +char-attr-constituent-digit+ 7)
+(defconstant +char-attr-constituent-sign+ 8)
+;; the "9" entry intentionally left blank for some reason -- WHN 19990806
+(defconstant +char-attr-multiple-escape+ 10)
+(defconstant +char-attr-package-delimiter+ 11)
+(defconstant +char-attr-delimiter+ 12) ; (a fake for READ-UNQUALIFIED-TOKEN)
+
(sb!xc:defstruct (readtable (:conc-name nil)
(:predicate readtablep))
#!+sb-doc
- "Readtable is a data structure that maps characters into syntax
+ "A READTABLE is a data structure that maps characters into syntax
types for the Common Lisp expression reader."
;; The CHARACTER-ATTRIBUTE-TABLE is a vector of CHAR-CODE-LIMIT
;; integers for describing the character type. Conceptually, there
- ;; are 4 distinct "primary" character attributes: WHITESPACE,
- ;; TERMINATING-MACRO, ESCAPE, and CONSTITUENT. Non-terminating
+ ;; are 4 distinct "primary" character attributes:
+ ;; +CHAR-ATTR-WHITESPACE+, +CHAR-ATTR-TERMINATING-MACRO+,
+ ;; +CHAR-ATTR-ESCAPE+, and +CHAR-ATTR-CONSTITUENT+. Non-terminating
;; macros (such as the symbol reader) have the attribute
- ;; CONSTITUENT.
+ ;; +CHAR-ATTR-CONSTITUENT+.
;;
- ;; In order to make the READ-TOKEN fast, all this information is
- ;; stored in the character attribute table by having different
- ;; varieties of constituents.
+ ;; In order to make READ-TOKEN fast, all this information is stored
+ ;; in the character attribute table by having different varieties of
+ ;; constituents.
(character-attribute-table
(make-array char-code-limit
:element-type '(unsigned-byte 8)
- :initial-element constituent)
+ :initial-element +char-attr-constituent+)
:type attribute-table)
;; The CHARACTER-MACRO-TABLE is a vector of CHAR-CODE-LIMIT
;; functions. One of these functions called with appropriate
(character-macro-table
(make-array char-code-limit :initial-element #'undefined-macro-char)
:type (simple-vector #.char-code-limit))
- ;; DISPATCH-TABLES entry, which is an alist from dispatch characters
- ;; to vectors of CHAR-CODE-LIMIT functions, for use in defining
- ;; dispatching macros (like #-macro).
+ ;; an alist from dispatch characters to vectors of CHAR-CODE-LIMIT
+ ;; functions, for use in defining dispatching macros (like #-macro)
(dispatch-tables () :type list)
(readtable-case :upcase :type (member :upcase :downcase :preserve :invert)))
;;;
;;; Many of the slots of the stream structure contain functions
;;; which are called to perform some operation on the stream. Closed
-;;; streams have #'Closed-Flame in all of their function slots. If
+;;; streams have #'CLOSED-FLAME in all of their function slots. If
;;; one side of an I/O or echo stream is closed, the whole stream is
;;; considered closed. The functions in the operation slots take
;;; arguments as follows:
;;; Misc: Stream, Operation, &Optional Arg1, Arg2
;;;
;;; In order to save space, some of the less common stream operations
-;;; are handled by just one function, the Misc method. This function
+;;; are handled by just one function, the MISC method. This function
;;; is passed a keyword which indicates the operation to perform.
;;; The following keywords are used:
;;; :listen - Return the following values:
;;; :finish-output,
;;; :force-output - Cause output to happen
;;; :clear-output - Clear any undone output
-;;; :element-type - Return the type of element the stream deals wit<h.
+;;; :element-type - Return the type of element the stream deals with.
;;; :line-length - Return the length of a line of output.
;;; :charpos - Return current output position on the line.
;;; :file-length - Return the file length of a file stream.
-;;; :file-position - Return or change the current position of a file stream.
+;;; :file-position - Return or change the current position of a
+;;; file stream.
;;; :file-name - Return the name of an associated file.
;;; :interactive-p - Is this an interactive device?
;;;
;;;
;;; THE STREAM IN-BUFFER:
;;;
-;;; The In-Buffer in the stream holds characters or bytes that
+;;; The IN-BUFFER in the stream holds characters or bytes that
;;; are ready to be read by some input function. If there is any
-;;; stuff in the In-Buffer, then the reading function can use it
+;;; stuff in the IN-BUFFER, then the reading function can use it
;;; without calling any stream method. Any stream may put stuff in
-;;; the In-Buffer, and may also assume that any input in the In-Buffer
+;;; the IN-BUFFER, and may also assume that any input in the IN-BUFFER
;;; has been consumed before any in-method is called. If a text
-;;; stream has in In-Buffer, then the first character should not be
+;;; stream has in IN-BUFFER, then the first character should not be
;;; used to buffer normal input so that it is free for unreading into.
;;;
-;;; The In-Buffer slot is a vector In-Buffer-Length long. The
-;;; In-Index is the index in the In-Buffer of the first available
-;;; object. The available objects are thus between In-Index and the
-;;; length of the In-Buffer.
+;;; The IN-BUFFER slot is a vector +IN-BUFFER-LENGTH+ long. The
+;;; IN-INDEX is the index in the IN-BUFFER of the first available
+;;; object. The available objects are thus between IN-INDEX and the
+;;; length of the IN-BUFFER.
;;;
;;; When this buffer is only accessed by the normal stream
;;; functions, the number of function calls is halved, thus
;;; potentially doubling the speed of simple operations. If the
-;;; Fast-Read-Char and Fast-Read-Byte macros are used, nearly all
+;;; FAST-READ-CHAR and FAST-READ-BYTE macros are used, nearly all
;;; function call overhead is removed, vastly speeding up these
;;; important operations.
;;;
-;;; If a stream does not have an In-Buffer, then the In-Buffer slot
-;;; must be nil, and the In-Index must be In-Buffer-Length. These are
+;;; If a stream does not have an IN-BUFFER, then the IN-BUFFER slot
+;;; must be nil, and the IN-INDEX must be +IN-BUFFER-LENGTH+. These are
;;; the default values for the slots.
\f
;;; stream manipulation functions
(declare (type (or index (member nil :start :end)) position))
(cond
(position
- (setf (lisp-stream-in-index stream) in-buffer-length)
+ (setf (lisp-stream-in-index stream) +in-buffer-length+)
(funcall (lisp-stream-misc stream) stream :file-position position))
(t
(let ((res (funcall (lisp-stream-misc stream) stream :file-position nil)))
- (when res (- res (- in-buffer-length (lisp-stream-in-index stream))))))))
+ (when res
+ (- res (- +in-buffer-length+ (lisp-stream-in-index stream))))))))
;;; declaration test functions
(t
(done-with-fast-read-char)
(return (values (shrink-vector res index) t))))))))
- ;; must be FUNDAMENTAL-STREAM
+ ;; must be Gray streams FUNDAMENTAL-STREAM
(multiple-value-bind (string eof) (stream-read-line stream)
(if (and eof (zerop (length string)))
(values (eof-or-lose stream eof-error-p eof-value) t)
(prog1
(fast-read-char eof-error-p eof-value)
(done-with-fast-read-char)))
- ;; FUNDAMENTAL-STREAM
+ ;; must be Gray streams FUNDAMENTAL-STREAM
(let ((char (stream-read-char stream)))
(if (eq char :eof)
(eof-or-lose stream eof-error-p eof-value)
(t
(funcall (lisp-stream-misc stream) stream
:unread character))))
- ;; Fundamental-stream
+ ;; must be Gray streams FUNDAMENTAL-STREAM
(stream-unread-char stream character)))
nil)
(t
(unread-char char stream)
char)))
- ;; Fundamental-stream.
+ ;; must be Gray streams FUNDAMENTAL-STREAM
(cond ((characterp peek-type)
(do ((char (stream-read-char stream) (stream-read-char stream)))
((or (eq char :eof) (char= char peek-type))
(defun listen (&optional (stream *standard-input*))
(let ((stream (in-synonym-of stream)))
(if (lisp-stream-p stream)
- (or (/= (the fixnum (lisp-stream-in-index stream)) in-buffer-length)
- ;; Test for t explicitly since misc methods return :eof sometimes.
- (eq (funcall (lisp-stream-misc stream) stream :listen) t))
- ;; Fundamental-stream.
+ (or (/= (the fixnum (lisp-stream-in-index stream)) +in-buffer-length+)
+ ;; Test for T explicitly since misc methods return :EOF sometimes.
+ (eq (funcall (lisp-stream-misc stream) stream :listen) at))
+ ;; Fall through to Gray streams FUNDAMENTAL-STREAM case.
(stream-listen stream))))
(defun read-char-no-hang (&optional (stream *standard-input*)
(let ((stream (in-synonym-of stream)))
(if (lisp-stream-p stream)
(if (funcall (lisp-stream-misc stream) stream :listen)
- ;; On t or :eof get READ-CHAR to do the work.
+ ;; On T or :EOF get READ-CHAR to do the work.
(read-char stream eof-error-p eof-value)
nil)
- ;; Fundamental-stream.
+ ;; must be Gray streams FUNDAMENTAL-STREAM
(let ((char (stream-read-char-no-hang stream)))
(if (eq char :eof)
(eof-or-lose stream eof-error-p eof-value)
(defun clear-input (&optional (stream *standard-input*))
(let ((stream (in-synonym-of stream)))
(cond ((lisp-stream-p stream)
- (setf (lisp-stream-in-index stream) in-buffer-length)
+ (setf (lisp-stream-in-index stream) +in-buffer-length+)
(funcall (lisp-stream-misc stream) stream :clear-input))
(t
(stream-clear-input stream))))
(prog1
(fast-read-byte eof-error-p eof-value t)
(done-with-fast-read-byte)))
- ;; FUNDAMENTAL-STREAM
+ ;; must be Gray streams FUNDAMENTAL-STREAM
(let ((char (stream-read-byte stream)))
(if (eq char :eof)
(eof-or-lose stream eof-error-p eof-value)
(let* ((stream (in-synonym-of stream lisp-stream))
(in-buffer (lisp-stream-in-buffer stream))
(index (lisp-stream-in-index stream))
- (num-buffered (- in-buffer-length index)))
+ (num-buffered (- +in-buffer-length+ index)))
(declare (fixnum index num-buffered))
(cond
((not in-buffer)
(t
(let ((end (+ start num-buffered)))
(%primitive sb!c:byte-blt in-buffer index buffer start end)
- (setf (lisp-stream-in-index stream) in-buffer-length)
+ (setf (lisp-stream-in-index stream) +in-buffer-length+)
(+ (funcall (lisp-stream-n-bin stream)
stream
buffer
eof-error-p)
num-buffered))))))
-;;; the amount of space we leave at the start of the in-buffer for unreading
+;;; the amount of space we leave at the start of the in-buffer for
+;;; unreading
;;;
;;; (It's 4 instead of 1 to allow word-aligned copies.)
-(defconstant in-buffer-extra 4) ; FIXME: should be symbolic constant
+(defconstant +in-buffer-extra+ 4) ; FIXME: should be symbolic constant
-;;; This function is called by the fast-read-char expansion to refill the
-;;; in-buffer for text streams. There is definitely an in-buffer, and hence
-;;; must be an n-bin method.
+;;; This function is called by the FAST-READ-CHAR expansion to refill
+;;; the IN-BUFFER for text streams. There is definitely an IN-BUFFER,
+;;; and hence must be an N-BIN method.
(defun fast-read-char-refill (stream eof-error-p eof-value)
(let* ((ibuf (lisp-stream-in-buffer stream))
(count (funcall (lisp-stream-n-bin stream)
stream
ibuf
- in-buffer-extra
- (- in-buffer-length in-buffer-extra)
+ +in-buffer-extra+
+ (- +in-buffer-length+ +in-buffer-extra+)
nil))
- (start (- in-buffer-length count)))
+ (start (- +in-buffer-length+ count)))
(declare (type index start count))
(cond ((zerop count)
- (setf (lisp-stream-in-index stream) in-buffer-length)
+ (setf (lisp-stream-in-index stream) +in-buffer-length+)
(funcall (lisp-stream-in stream) stream eof-error-p eof-value))
(t
- (when (/= start in-buffer-extra)
- (bit-bash-copy ibuf (+ (* in-buffer-extra sb!vm:byte-bits)
+ (when (/= start +in-buffer-extra+)
+ (bit-bash-copy ibuf (+ (* +in-buffer-extra+ sb!vm:byte-bits)
(* sb!vm:vector-data-offset
sb!vm:word-bits))
ibuf (+ (the index (* start sb!vm:byte-bits))
(setf (lisp-stream-in-index stream) (1+ start))
(code-char (aref ibuf start))))))
-;;; Similar to FAST-READ-CHAR-REFILL, but we don't have to leave room for
-;;; unreading.
+;;; This is similar to FAST-READ-CHAR-REFILL, but we don't have to
+;;; leave room for unreading.
(defun fast-read-byte-refill (stream eof-error-p eof-value)
(let* ((ibuf (lisp-stream-in-buffer stream))
(count (funcall (lisp-stream-n-bin stream) stream
- ibuf 0 in-buffer-length
+ ibuf 0 +in-buffer-length+
nil))
- (start (- in-buffer-length count)))
+ (start (- +in-buffer-length+ count)))
(declare (type index start count))
(cond ((zerop count)
- (setf (lisp-stream-in-index stream) in-buffer-length)
+ (setf (lisp-stream-in-index stream) +in-buffer-length+)
(funcall (lisp-stream-bin stream) stream eof-error-p eof-value))
(t
(unless (zerop start)
(when (/= (or (charpos stream) 1) 0)
(funcall (lisp-stream-out stream) stream #\newline)
t)
- ;; Fundamental-stream.
+ ;; must be Gray streams FUNDAMENTAL-STREAM
(stream-fresh-line stream))))
(defun write-string (string &optional (stream *standard-output*)
&key (start 0) (end (length (the vector string))))
- ;; FIXME: These SETFs don't look right to me. Looking at the definition
- ;; of "bounding indices" in the glossary of the ANSI spec, and extrapolating
- ;; from the behavior of other operations when their operands are the
- ;; wrong type, it seems that it would be more correct to essentially
+ ;; FIXME: These SETFs don't look right to me. Looking at the
+ ;; definition of "bounding indices" in the glossary of the ANSI
+ ;; spec, and extrapolating from the behavior of other operations
+ ;; when their operands are the wrong type, it seems that it would be
+ ;; more correct to essentially
;; (ASSERT (<= 0 START END (LENGTH STRING)))
;; instead of modifying the incorrect values.
#!+high-security
stream data offset-start offset-end))
(funcall (lisp-stream-sout stream) stream string start end))
string)
- (t ; Fundamental-stream.
+ (t ; must be Gray streams FUNDAMENTAL-STREAM
(stream-write-string stream string start end)))))
(defun write-line (string &optional (stream *standard-output*)
offset-end)))
(with-out-stream stream (lisp-stream-sout string start end)))
(funcall (lisp-stream-out stream) stream #\newline))
- (t ; Fundamental-stream.
+ (t ; must be Gray streams FUNDAMENTAL-STREAM
(stream-write-string stream string start end)
(stream-write-char stream #\Newline)))
string))
(stream-write-byte integer))
integer)
\f
-;;; This is called from lisp-steam routines that encapsulate CLOS
+;;; This is called from LISP-STREAM routines that encapsulate CLOS
;;; streams to handle the misc routines and dispatch to the
;;; appropriate Gray stream functions.
(defun stream-misc-dispatch (stream operation &optional arg1 arg2)
(ignore arg2))
(case operation
(:listen
- ;; Return true if input available, :EOF for end-of-file, otherwise NIL.
+ ;; Return T if input available, :EOF for end-of-file, otherwise NIL.
(let ((char (stream-read-char-no-hang stream)))
(when (characterp char)
(stream-unread-char stream char))
(if (lisp-stream-p syn)
(case operation
(:listen (or (/= (the fixnum (lisp-stream-in-index syn))
- in-buffer-length)
+ +in-buffer-length+)
(funcall (lisp-stream-misc syn) syn :listen)))
(t
(funcall (lisp-stream-misc syn) syn operation arg1 arg2)))
(case operation
(:listen
(if in-lisp-stream-p
- (or (/= (the fixnum (lisp-stream-in-index in)) in-buffer-length)
+ (or (/= (the fixnum (lisp-stream-in-index in)) +in-buffer-length+)
(funcall (lisp-stream-misc in) in :listen))
(stream-listen in)))
((:finish-output :force-output :clear-output)
(:listen
(or (not (null (echo-stream-unread-stuff stream)))
(if (lisp-stream-p in)
- (or (/= (the fixnum (lisp-stream-in-index in)) in-buffer-length)
+ (or (/= (the fixnum (lisp-stream-in-index in))
+ +in-buffer-length+)
(funcall (lisp-stream-misc in) in :listen))
(stream-misc-dispatch in :listen))))
(:unread (push arg1 (echo-stream-unread-stuff stream)))
(setf (fdocumentation 'make-indenting-stream 'function)
"Returns an output stream which indents its output by some amount.")
-;;; Indenting-Indent writes the correct number of spaces needed to indent
-;;; output on the given Stream based on the specified Sub-Stream.
+;;; INDENTING-INDENT writes the correct number of spaces needed to indent
+;;; output on the given STREAM based on the specified SUB-STREAM.
(defmacro indenting-indent (stream sub-stream)
;; KLUDGE: bare magic number 60
`(do ((i 0 (+ i 60))
" "
,sub-stream 0 (min 60 (- indentation i)))))
-;;; Indenting-Out writes a character to an indenting stream.
+;;; INDENTING-OUT writes a character to an indenting stream.
(defun indenting-out (stream char)
(let ((sub-stream (indenting-stream-stream stream)))
(write-char char sub-stream)
(if (char= char #\newline)
(indenting-indent stream sub-stream))))
-;;; Indenting-Sout writes a string to an indenting stream.
-
+;;; INDENTING-SOUT writes a string to an indenting stream.
(defun indenting-sout (stream string start end)
(declare (simple-string string) (fixnum start end))
(do ((i start)
(write-string* string sub-stream i end)
(setq i end))))))
-;;; Indenting-Misc just treats just the :Line-Length message differently.
-;;; Indenting-Charpos says the charpos is the charpos of the base stream minus
-;;; the stream's indentation.
-
+;;; INDENTING-MISC just treats just the :LINE-LENGTH message
+;;; differently. INDENTING-CHARPOS says the charpos is the charpos of
+;;; the base stream minus the stream's indentation.
(defun indenting-misc (stream operation &optional arg1 arg2)
(let ((sub-stream (indenting-stream-stream stream)))
(if (lisp-stream-p sub-stream)
(- charpos (indenting-stream-indentation stream)))))
(t
(funcall method sub-stream operation arg1 arg2))))
- ;; Fundamental-stream.
+ ;; must be Gray streams FUNDAMENTAL-STREAM
(case operation
(:line-length
(let ((line-length (stream-line-length sub-stream)))
(declaim (maybe-inline read-char unread-char read-byte listen))
\f
-;;;; case frobbing streams, used by format ~(...~)
+;;;; case frobbing streams, used by FORMAT ~(...~)
(defstruct (case-frob-stream
(:include lisp-stream
kind)
(values stream))
(if (case-frob-stream-p target)
- ;; If we are going to be writing to a stream that already does case
- ;; frobbing, why bother frobbing the case just so it can frob it
- ;; again?
+ ;; If we are going to be writing to a stream that already does
+ ;; case frobbing, why bother frobbing the case just so it can
+ ;; frob it again?
target
(multiple-value-bind (out sout)
(ecase kind
(funcall (lisp-stream-sout target) target str 0 len)
(stream-write-string target str 0 len))))
\f
-;;;; public interface from "EXTENSIONS" package
+;;;; stream commands
(defstruct (stream-command (:constructor make-stream-command
(name &optional args))
(print-unreadable-object (obj str :type t :identity t)
(prin1 (stream-command-name obj) str)))
+;;; Take a stream and wait for text or a command to appear on it. If
+;;; text appears before a command, return NIL, otherwise return a
+;;; command.
+;;;
;;; We can't simply call the stream's misc method because NIL is an
-;;; ambiguous return value: does it mean text arrived, or does it mean the
-;;; stream's misc method had no :GET-COMMAND implementation. We can't return
-;;; NIL until there is text input. We don't need to loop because any stream
-;;; implementing :get-command would wait until it had some input. If the
-;;; LISTEN fails, then we have some stream we must wait on.
+;;; ambiguous return value: does it mean text arrived, or does it mean
+;;; the stream's misc method had no :GET-COMMAND implementation? We
+;;; can't return NIL until there is text input. We don't need to loop
+;;; because any stream implementing :GET-COMMAND would wait until it
+;;; had some input. If the LISTEN fails, then we have some stream we
+;;; must wait on.
(defun get-stream-command (stream)
- #!+sb-doc
- "This takes a stream and waits for text or a command to appear on it. If
- text appears before a command, this returns nil, and otherwise it returns
- a command."
(let ((cmdp (funcall (lisp-stream-misc stream) stream :get-command)))
(cond (cmdp)
((listen stream)
nil)
(t
- ;; This waits for input and returns nil when it arrives.
+ ;; This waits for input and returns NIL when it arrives.
(unread-char (read-char stream) stream)))))
\f
(defun read-sequence (seq stream &key (start 0) (end nil))
;;;; These are hacks to make the reader win.
;;; This macro sets up some local vars for use by the
-;;; Fast-Read-Char macro within the enclosed lexical scope. The stream
-;;; is assumed to be a lisp-stream.
+;;; FAST-READ-CHAR macro within the enclosed lexical scope. The stream
+;;; is assumed to be a LISP-STREAM.
(defmacro prepare-for-fast-read-char (stream &body forms)
`(let* ((%frc-stream% ,stream)
(%frc-method% (lisp-stream-in %frc-stream%))
(type lisp-stream %frc-stream%))
,@forms))
-;;; This macro must be called after one is done with fast-read-char
+;;; This macro must be called after one is done with FAST-READ-CHAR
;;; inside its scope to decache the lisp-stream-in-index.
(defmacro done-with-fast-read-char ()
`(setf (lisp-stream-in-index %frc-stream%) %frc-index%))
-;;; a macro with the same calling convention as READ-CHAR, to be
-;;; used within the scope of a PREPARE-FOR-FAST-READ-CHAR
+;;; a macro with the same calling convention as READ-CHAR, to be used
+;;; within the scope of a PREPARE-FOR-FAST-READ-CHAR
(defmacro fast-read-char (&optional (eof-error-p t) (eof-value ()))
`(cond
((not %frc-buffer%)
(funcall %frc-method% %frc-stream% ,eof-error-p ,eof-value))
- ((= %frc-index% in-buffer-length)
+ ((= %frc-index% +in-buffer-length+)
(prog1 (fast-read-char-refill %frc-stream% ,eof-error-p ,eof-value)
(setq %frc-index% (lisp-stream-in-index %frc-stream%))))
(t
;;;; And these for the fasloader...
-;;; Just like Prepare-For-Fast-Read-Char except that we get the Bin
-;;; method. The stream is assumed to be a lisp-stream.
+;;; Just like PREPARE-FOR-FAST-READ-CHAR except that we get the BIN
+;;; method. The stream is assumed to be a LISP-STREAM.
;;;
;;; KLUDGE: It seems weird to have to remember to explicitly call
;;; DONE-WITH-FAST-READ-BYTE at the end of this, given that we're
(cond
((not %frc-buffer%)
(funcall %frc-method% %frc-stream% ,eof-error-p ,eof-value))
- ((= %frc-index% in-buffer-length)
+ ((= %frc-index% +in-buffer-length+)
(prog1 (fast-read-byte-refill %frc-stream% ,eof-error-p ,eof-value)
(setq %frc-index% (lisp-stream-in-index %frc-stream%))))
(t
)
(eval-when (:compile-toplevel :load-toplevel :execute)
+ ;; KLUDGE: If the slots of TYPE-CLASS ever change, the slots here
+ ;; will have to be tweaked to match. -- WHN 19991021
+ (defparameter *type-class-function-slots*
+ '((:simple-subtypep . type-class-simple-subtypep)
+ (:complex-subtypep-arg1 . type-class-complex-subtypep-arg1)
+ (:complex-subtypep-arg2 . type-class-complex-subtypep-arg2)
+ (:simple-union2 . type-class-simple-union2)
+ (:complex-union2 . type-class-complex-union2)
+ (:simple-intersection2 . type-class-simple-intersection2)
+ (:complex-intersection2 . type-class-complex-intersection2)
+ (:simple-= . type-class-simple-=)
+ (:complex-= . type-class-complex-=)
+ (:unparse . type-class-unparse))))
-;;; Copy TYPE-CLASS object X, using only operations which will work early in
-;;; cold load. (COPY-STRUCTURE won't work early in cold load, because it needs
-;;; RAW-INDEX and RAW-LENGTH information from LAYOUT-INFO, and LAYOUT-INFO
-;;; isn't initialized early in cold load.)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+;;; Copy TYPE-CLASS object X, using only operations which will work
+;;; early in cold load. (COPY-STRUCTURE won't work early in cold load,
+;;; because it needs RAW-INDEX and RAW-LENGTH information from
+;;; LAYOUT-INFO, and LAYOUT-INFO isn't initialized early in cold
+;;; load.)
;;;
-;;; FIXME: It's nasty having to maintain this hand-written copy function. And
-;;; it seems intrinsically dain-bramaged to have RAW-INDEX and RAW-LENGTH in
-;;; LAYOUT-INFO instead of directly in LAYOUT. We should fix this: * Move
-;;; RAW-INDEX and RAW-LENGTH slots into LAYOUT itself. * Rewrite the various
-;;; CHECK-LAYOUT-related functions so that they check RAW-INDEX and RAW-LENGTH
-;;; too. * Remove this special hacked copy function, just use COPY-STRUCTURE
-;;; instead. (For even more improvement, it'd be good to move the raw slots
+;;; FIXME: It's nasty having to maintain this hand-written copy
+;;; function. And it seems intrinsically dain-bramaged to have
+;;; RAW-INDEX and RAW-LENGTH in LAYOUT-INFO instead of directly in
+;;; LAYOUT. We should fix this:
+;;; * Move RAW-INDEX and RAW-LENGTH slots into LAYOUT itself.
+;;; * Rewrite the various CHECK-LAYOUT-related functions so that
+;;; they check RAW-INDEX and RAW-LENGTH too.
+;;; * Remove this special hacked copy function, just use
+;;; COPY-STRUCTURE instead.
+;;; (For even more improvement, it might be good to move the raw slots
;;; into the same object as the ordinary slots, instead of having the
-;;; unfortunate extra level of indirection. But that'd probably require a lot
-;;; of work, including updating the garbage collector to understand it.)
+;;; unfortunate extra level of indirection. But that'd probably
+;;; require a lot of work, including updating the garbage collector to
+;;; understand it. And it might even hurt overall performance, because
+;;; the positive effect of removing indirection could be cancelled by
+;;; the negative effect of imposing an unnecessary GC write barrier on
+;;; raw data which doesn't actually affect GC.)
(declaim (ftype (function (type-class) type-class) copy-type-class-coldly))
(defun copy-type-class-coldly (x)
- ;; KLUDGE: If the slots of TYPE-CLASS ever change, the slots here will have
- ;; to be hand-tweaked to match. -- WHN 19991021
+ ;; KLUDGE: If the slots of TYPE-CLASS ever change in a way not
+ ;; reflected in *TYPE-CLASS-FUNCTION-SLOTS*, the slots here will
+ ;; have to be hand-tweaked to match. -- WHN 2001-03-19
(make-type-class :name (type-class-name x)
- :simple-subtypep (type-class-simple-subtypep x)
- :complex-subtypep-arg1 (type-class-complex-subtypep-arg1 x)
- :complex-subtypep-arg2 (type-class-complex-subtypep-arg2 x)
- :simple-union2 (type-class-simple-union2 x)
- :complex-union2 (type-class-complex-union2 x)
- :simple-intersection2 (type-class-simple-intersection2 x)
- :complex-intersection2 (type-class-complex-intersection2 x)
- :simple-= (type-class-simple-= x)
- :complex-= (type-class-complex-= x)
- :unparse (type-class-unparse x)))
-
-;;; KLUDGE: If the slots of TYPE-CLASS ever change, the slots here
-;;; will have to be tweaked to match. -- WHN 19991021
-(defparameter *type-class-function-slots*
- '((:simple-subtypep . type-class-simple-subtypep)
- (:complex-subtypep-arg1 . type-class-complex-subtypep-arg1)
- (:complex-subtypep-arg2 . type-class-complex-subtypep-arg2)
- (:simple-union2 . type-class-simple-union2)
- (:complex-union2 . type-class-complex-union2)
- (:simple-intersection2 . type-class-simple-intersection2)
- (:complex-intersection2 . type-class-complex-intersection2)
- (:simple-= . type-class-simple-=)
- (:complex-= . type-class-complex-=)
- (:unparse . type-class-unparse)))
+ . #.(mapcan (lambda (type-class-function-slot)
+ (destructuring-bind (keyword . slot-accessor)
+ type-class-function-slot
+ `(,keyword (,slot-accessor x))))
+ *type-class-function-slots*)))
(defun class-function-slot-or-lose (name)
(or (cdr (assoc name *type-class-function-slots*))
("code/byte-types" :not-host)
("compiler/byte-comp")
("compiler/target-byte-comp" :not-host)
- ;; FIXME: Could byte-interp be moved here? It'd be logical..
+ ("code/byte-interp" :not-host) ; needs *SYSTEM-CONSTANT-CODES* from byte-comp
;; defines SB!DI:DO-DEBUG-FUNCTION-BLOCKS, needed by target-disassem.lisp
("code/debug-int" :not-host)
("code/bit-bash" :not-host) ; needs %NEGATE from assembly/target/arith
- ("code/byte-interp" :not-host) ; needs *SYSTEM-CONSTANT-CODES* from byte-comp
-
("code/target-load" :not-host) ; needs specials from code/load.lisp
;; FIXME: Does this really need stuff from compiler/dump.lisp?
;;; versions, and a string like "0.6.5.12" is used for versions which
;;; aren't released but correspond only to CVS tags or snapshots.
-"0.6.11.17"
+"0.6.11.18"
projects / sbcl.git / commitdiff