* Arrange for bytevector to be available early in the cold load.
* Eliminate redundant type-checking on procedures that call char->integer.
(bytevector-u8-set! 3)
(bytevector? 1))
-(add-boot-init!
- (lambda ()
- (register-predicate! byte? 'byte '<= exact-nonnegative-integer?)
- (register-predicate! bytevector? 'bytevector)))
-
(define (make-bytevector k #!optional byte)
(let ((bytevector (allocate-bytevector k)))
(if (not (default-object? byte))
(define-integrable char-bits-limit #x10)
(define-integrable char-integer-limit #x2000000)
-(define-integrable (%make-char code bits)
- (integer->char (fix:or (fix:lsh bits 21) code)))
-
-(define-integrable (%char-code char)
- (fix:and (char->integer char) #x1FFFFF))
-
-(define-integrable (%char-bits char)
- (fix:lsh (char->integer char) -21))
-
(define-guarantee char "character")
(define (make-char code bits)
(guarantee-limited-index-fixnum bits char-bits-limit 'MAKE-CHAR)
(%make-char code bits))
+(define-integrable (%make-char code bits)
+ (integer->char (fix:or (fix:lsh bits 21) code)))
+
(define (code->char code)
(guarantee-limited-index-fixnum code char-code-limit 'CODE->CHAR)
(integer->char code))
(define (char-code char)
- (guarantee-char char 'CHAR-CODE)
- (%char-code char))
+ (fix:and (char->integer char) #x1FFFFF))
(define (char-bits char)
- (guarantee-char char 'CHAR-BITS)
- (%char-bits char))
+ (fix:lsh (char->integer char) -21))
(define (char-bits-set? bits char)
(guarantee-limited-index-fixnum bits char-bits-limit 'CHAR-BITS-SET?)
- (guarantee-char char 'CHAR-BITS-SET?)
- (fix:= bits (fix:and (%char-bits char) bits)))
+ (fix:= bits (fix:and (char-bits char) bits)))
(define (char-bits-clear? bits char)
(guarantee-limited-index-fixnum bits char-bits-limit 'CHAR-BITS-CLEAR?)
- (guarantee-char char 'CHAR-BITS-CLEAR?)
- (fix:= 0 (fix:and (%char-bits char) bits)))
+ (fix:= 0 (fix:and (char-bits char) bits)))
(define (set-char-bits bits char)
(guarantee-limited-index-fixnum bits char-bits-limit 'SET-CHAR-BITS)
- (guarantee-char char 'SET-CHAR-BITS)
- (%make-char (%char-code char)
- (fix:or (%char-bits char) bits)))
+ (%make-char (char-code char)
+ (fix:or (char-bits char) bits)))
(define (clear-char-bits bits char)
(guarantee-limited-index-fixnum bits char-bits-limit 'CLEAR-CHAR-BITS)
- (guarantee-char char 'CLEAR-CHAR-BITS)
- (%make-char (%char-code char)
- (fix:andc (%char-bits char) bits)))
+ (%make-char (char-code char)
+ (fix:andc (char-bits char) bits)))
\f
(define (unicode-char? object)
(and (char? object)
(error:not-8-bit-char object)))
(define (char-ascii? char)
- (guarantee-char char 'CHAR-ASCII?)
(let ((n (char->integer char)))
(and (fix:< n 256)
n)))
(map char->ascii chars))
\f
(define (char=? x y)
- ;; There's no %CHAR=? because the compiler recodes CHAR=? as EQ?.
- (guarantee-char x 'CHAR=?)
- (guarantee-char y 'CHAR=?)
(fix:= (char->integer x) (char->integer y)))
(define (char<? x y)
- (guarantee-char x 'CHAR<?)
- (guarantee-char y 'CHAR<?)
- (%char<? x y))
-
-(define-integrable (%char<? x y)
(fix:< (char->integer x) (char->integer y)))
(define (char<=? x y)
- (guarantee-char x 'CHAR<=?)
- (guarantee-char y 'CHAR<=?)
- (%char<=? x y))
-
-(define-integrable (%char<=? x y)
(fix:<= (char->integer x) (char->integer y)))
(define (char>? x y)
- (guarantee-char x 'CHAR>?)
- (guarantee-char y 'CHAR>?)
- (%char>? x y))
-
-(define-integrable (%char>? x y)
(fix:> (char->integer x) (char->integer y)))
(define (char>=? x y)
- (guarantee-char x 'CHAR>=?)
- (guarantee-char y 'CHAR>=?)
- (%char>=? x y))
-
-(define-integrable (%char>=? x y)
(fix:>= (char->integer x) (char->integer y)))
(define (char-ci=? x y)
(char->integer (char-upcase char)))
\f
(define (char-downcase char)
- (guarantee-char char 'CHAR-DOWNCASE)
(%case-map-char char downcase-table))
(define (char-upcase char)
- (guarantee-char char 'CHAR-UPCASE)
(%case-map-char char upcase-table))
(define-integrable (%case-map-char char table)
- (if (fix:< (%char-code char) #x100)
- (%make-char (vector-8b-ref table (%char-code char))
- (%char-bits char))
+ (if (fix:< (char-code char) #x100)
+ (%make-char (bytevector-u8-ref table (char-code char))
+ (char-bits char))
char))
(define downcase-table)
-(define identity-table)
(define upcase-table)
(define (initialize-case-conversions!)
- (set! downcase-table (make-string #x100))
- (set! identity-table (make-string #x100))
- (set! upcase-table (make-string #x100))
+ (set! downcase-table (make-bytevector #x100))
+ (set! upcase-table (make-bytevector #x100))
(do ((i 0 (fix:+ i 1)))
((fix:= i #x100))
- (vector-8b-set! downcase-table i i)
- (vector-8b-set! identity-table i i)
- (vector-8b-set! upcase-table i i))
+ (bytevector-u8-set! downcase-table i i)
+ (bytevector-u8-set! upcase-table i i))
(let ((case-range
(lambda (uc-low uc-high lc-low)
(do ((i uc-low (fix:+ i 1))
(j lc-low (fix:+ j 1)))
((fix:> i uc-high))
- (vector-8b-set! downcase-table i j)
- (vector-8b-set! upcase-table j i)))))
+ (bytevector-u8-set! downcase-table i j)
+ (bytevector-u8-set! upcase-table j i)))))
(case-range 65 90 97)
(case-range 192 214 224)
(case-range 216 222 248)))
(string-ref "0123456789abcdefghijklmnopqrstuvwxyz" digit))
(define (char->digit char #!optional radix)
- (guarantee-char char 'CHAR->DIGIT)
(let ((code (char->integer char))
(radix
(cond ((default-object? radix)
(RUNTIME TAGGING)
(RUNTIME HASH)
(RUNTIME DYNAMIC)
- (RUNTIME BYTEVECTOR)
(RUNTIME REGULAR-SEXPRESSION)
;; Microcode data structures
(RUNTIME HISTORY)
(define (parse-atom-1 port db prefix quoting?)
(let ((port* (open-output-string))
- (table
+ (%canon
(if (db-canonicalize-symbols? db)
- downcase-table
- identity-table))
+ char-downcase
+ (lambda (char) char)))
(atom-delimiters (db-atom-delimiters db))
(constituents (db-constituents db)))
- (define (%canon char)
- ;; Assumption: No character involved in I/O has bucky bits, and
- ;; case conversion applies only to ISO-8859-1 characters.
- (let ((integer (char->integer char)))
- (if (fix:< integer #x100)
- (integer->char (vector-8b-ref table integer))
- char)))
(define (%read)
(if (pair? prefix)
(let ((char (car prefix)))
(lambda ()
;; R7RS
(register-predicate! boolean? 'boolean)
+ (register-predicate! bytevector? 'bytevector)
(register-predicate! char? 'char)
(register-predicate! default-object? 'default-object)
(register-predicate! eof-object? 'eof-object)
(register-predicate! exact-positive-integer? 'exact-positive-integer
'<= exact-integer?)
(register-predicate! exact-rational? 'exact-rational '<= rational?)
+ (register-predicate! byte? 'byte '<= exact-nonnegative-integer?)
(register-predicate! fix:fixnum? 'fixnum '<= exact-integer?)
(register-predicate! index-fixnum? 'index-fixnum '<= fix:fixnum?)
set-char-bits
unicode-char?
unicode-scalar-value?)
- (export (runtime string)
- %char<?
- downcase-table
- upcase-table)
- (export (runtime parser)
- downcase-table
- identity-table)
(export (runtime unicode)
legal-code-16?
legal-code-32?)
(define (string-ci-hash key #!optional modulus)
(string-hash (string-downcase key) modulus))
-
-;;; Character optimizations
-
-(define-integrable (%%char-downcase char)
- (integer->char (vector-8b-ref downcase-table (char->integer char))))
-
-(define-integrable (%%char-upcase char)
- (integer->char (vector-8b-ref upcase-table (char->integer char))))
-
-(define-integrable (%char-ci=? c1 c2)
- (fix:= (vector-8b-ref upcase-table (char->integer c1))
- (vector-8b-ref upcase-table (char->integer c2))))
-
-(define-integrable (%char-ci<? c1 c2)
- (fix:< (vector-8b-ref upcase-table (char->integer c1))
- (vector-8b-ref upcase-table (char->integer c2))))
\f
;;;; Basic Operations
(let ((string* (make-string end)))
(do ((i 0 (fix:+ i 1)))
((fix:= i end))
- (string-set! string* i (%%char-upcase (string-ref string i))))
+ (string-set! string* i (char-upcase (string-ref string i))))
string*)))
(define (string-upcase! string)
(define (%substring-upcase! string start end)
(do ((i start (fix:+ i 1)))
((fix:= i end))
- (string-set! string i (%%char-upcase (string-ref string i)))))
+ (string-set! string i (char-upcase (string-ref string i)))))
\f
(define (string-lower-case? string)
(guarantee-string string 'STRING-LOWER-CASE?)
(let ((string* (make-string end)))
(do ((i 0 (fix:+ i 1)))
((fix:= i end))
- (string-set! string* i (%%char-downcase (string-ref string i))))
+ (string-set! string* i (char-downcase (string-ref string i))))
string*)))
(define (string-downcase! string)
(define (%substring-downcase! string start end)
(do ((i start (fix:+ i 1)))
((fix:= i end))
- (string-set! string i (%%char-downcase (string-ref string i)))))
+ (string-set! string i (char-downcase (string-ref string i)))))
\f
(define (string-capitalized? string)
(guarantee-string string 'STRING-CAPITALIZED?)
((char=? (string-ref string1 index)
(string-ref string2 index))
(loop (fix:+ index 1)))
- ((%char<? (string-ref string1 index)
- (string-ref string2 index))
+ ((char<? (string-ref string1 index)
+ (string-ref string2 index))
(if<))
(else
(if>)))))))
(if=)
(if<))
(if>)))
- ((%char-ci=? (string-ref string1 index)
- (string-ref string2 index))
+ ((char-ci=? (string-ref string1 index)
+ (string-ref string2 index))
(loop (fix:+ index 1)))
- ((%char-ci<? (string-ref string1 index)
- (string-ref string2 index))
+ ((char-ci<? (string-ref string1 index)
+ (string-ref string2 index))
(if<))
(else
(if>)))))))
(and (fix:= end (string-length string2))
(let loop ((i 0))
(or (fix:= i end)
- (and (%char-ci=? (string-ref string1 i) (string-ref string2 i))
+ (and (char-ci=? (string-ref string1 i) (string-ref string2 i))
(loop (fix:+ i 1))))))))
(define (substring=? string1 start1 end1 string2 start2 end2)
(and (fix:= (fix:- end1 start1) (fix:- end2 start2))
(let loop ((i1 start1) (i2 start2))
(or (fix:= i1 end1)
- (and (%char-ci=? (string-ref string1 i1) (string-ref string2 i2))
+ (and (char-ci=? (string-ref string1 i1) (string-ref string2 i2))
(loop (fix:+ i1 1) (fix:+ i2 1)))))))
\f
(define (string<? string1 string2)
(let loop ((i 0))
(if (fix:= i end)
(fix:< end1 end2)
- (or (%char<? (string-ref string1 i) (string-ref string2 i))
+ (or (char<? (string-ref string1 i) (string-ref string2 i))
(and (char=? (string-ref string1 i) (string-ref string2 i))
(loop (fix:+ i 1)))))))))
(let loop ((i 0))
(if (fix:= i end)
(fix:< end1 end2)
- (or (%char-ci<? (string-ref string1 i) (string-ref string2 i))
- (and (%char-ci=? (string-ref string1 i) (string-ref string2 i))
+ (or (char-ci<? (string-ref string1 i) (string-ref string2 i))
+ (and (char-ci=? (string-ref string1 i) (string-ref string2 i))
(loop (fix:+ i 1)))))))))
(define (substring<? string1 start1 end1 string2 start2 end2)
(let loop ((i1 start1) (i2 start2))
(if (fix:= i1 end)
(fix:< len1 len2)
- (or (%char<? (string-ref string1 i1) (string-ref string2 i2))
+ (or (char<? (string-ref string1 i1) (string-ref string2 i2))
(and (char=? (string-ref string1 i1) (string-ref string2 i2))
(loop (fix:+ i1 1) (fix:+ i2 1)))))))))
(let loop ((i1 start1) (i2 start2))
(if (fix:= i1 end)
(fix:< len1 len2)
- (or (%char-ci<? (string-ref string1 i1) (string-ref string2 i2))
- (and (%char-ci=? (string-ref string1 i1)
- (string-ref string2 i2))
+ (or (char-ci<? (string-ref string1 i1) (string-ref string2 i2))
+ (and (char-ci=? (string-ref string1 i1)
+ (string-ref string2 i2))
(loop (fix:+ i1 1) (fix:+ i2 1)))))))))
\f
(define-integrable (string>? string1 string2)
(let ((end (fix:+ start1 (fix:min (fix:- end1 start1) (fix:- end2 start2)))))
(let loop ((i1 start1) (i2 start2))
(if (or (fix:= i1 end)
- (not (%char-ci=? (string-ref string1 i1)
- (string-ref string2 i2))))
+ (not (char-ci=? (string-ref string1 i1)
+ (string-ref string2 i2))))
(fix:- i1 start1)
(loop (fix:+ i1 1) (fix:+ i2 1))))))
\f
(if (fix:= end1 start)
0
(let loop ((i1 (fix:- end1 1)) (i2 (fix:- end2 1)))
- (if (%char-ci=? (string-ref string1 i1) (string-ref string2 i2))
+ (if (char-ci=? (string-ref string1 i1) (string-ref string2 i2))
(if (fix:= i1 start)
(fix:- end1 i1)
(loop (fix:- i1 1) (fix:- i2 1)))
(define (%substring-find-next-char-ci string start end char)
(let loop ((i start))
(cond ((fix:= i end) #f)
- ((%char-ci=? (string-ref string i) char) i)
+ ((char-ci=? (string-ref string i) char) i)
(else (loop (fix:+ i 1))))))
(define (string-find-previous-char string char)
(if (fix:= start end)
#f
(let loop ((i (fix:- end 1)))
- (cond ((%char-ci=? (string-ref string i) char) i)
+ (cond ((char-ci=? (string-ref string i) char) i)
((fix:= start i) #f)
(else (loop (fix:- i 1)))))))
\f
projects / mit-scheme.git / commitdiff