From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 25 Sep 2001 05:15:17 +0000 (+0000)
Subject: Add type checking to all procedures, and rewrite some of the loops for
X-Git-Tag: 20090517-FFI~2557
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f673dc560f1127332ba4fc33b4e356ae6ad0b0f3;p=mit-scheme.git
Add type checking to all procedures, and rewrite some of the loops for
speed.
---
diff --git a/v7/src/runtime/chrset.scm b/v7/src/runtime/chrset.scm
index 25d798a23..697d30704 100644
--- a/v7/src/runtime/chrset.scm
+++ b/v7/src/runtime/chrset.scm
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Id: chrset.scm,v 14.15 2001/09/24 04:16:19 cph Exp $
+$Id: chrset.scm,v 14.16 2001/09/25 05:15:17 cph Exp $
Copyright (c) 1988-2001 Massachusetts Institute of Technology
@@ -28,33 +28,47 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
(define-structure (char-set (type-descriptor char-set-rtd))
(table #f read-only #t))
+(define-integrable (guarantee-char-set object procedure)
+ (if (not (char-set? object))
+ (error:wrong-type-argument object "character set" procedure)))
+
(define-integrable char-set-table-length 256)
(define (char-set . chars)
(chars->char-set chars))
(define (chars->char-set chars)
+ (if (not (list-of-type? chars
+ (lambda (char)
+ (and (char? char)
+ (fix:< (char->integer char) char-set-table-length)))))
+ (error:wrong-type-argument chars "ASCII chars" 'CHARS->CHAR-SET))
(let ((table (make-string char-set-table-length)))
(vector-8b-fill! table 0 char-set-table-length 0)
(do ((chars chars (cdr chars)))
((not (pair? chars)))
- (vector-8b-set! table
- (let ((code (char->integer (car chars))))
- (if (fix:>= code char-set-table-length)
- (error:bad-range-argument chars 'CHARS->CHAR-SET))
- code)
- 1))
+ (vector-8b-set! table (char->integer (car chars)) 1))
(make-char-set table)))
(define (string->char-set string)
- (let ((table (make-string char-set-table-length)))
+ (guarantee-string string 'STRING->CHAR-SET)
+ (let ((n-chars (string-length string))
+ (table (make-string char-set-table-length)))
(vector-8b-fill! table 0 char-set-table-length 0)
- (do ((i (fix:- (string-length string) 1) (fix:- i 1)))
- ((fix:< i 0))
+ (do ((i 0 (fix:+ i 1)))
+ ((fix:= i n-chars))
(vector-8b-set! table (vector-8b-ref string i) 1))
(make-char-set table)))
(define (ascii-range->char-set lower upper)
+ (if (not (index-fixnum? lower))
+ (error:wrong-type-argument lower "index fixnum" 'ASCII-RANGE->CHAR-SET))
+ (if (not (index-fixnum? upper))
+ (error:wrong-type-argument upper "index fixnum" 'ASCII-RANGE->CHAR-SET))
+ (if (not (fix:<= lower upper))
+ (error:bad-range-argument lower 'ASCII-RANGE->CHAR-SET))
+ (if (not (fix:<= upper char-set-table-length))
+ (error:bad-range-argument upper 'ASCII-RANGE->CHAR-SET))
(let ((table (make-string char-set-table-length)))
(vector-8b-fill! table 0 lower 0)
(vector-8b-fill! table lower upper 1)
@@ -63,58 +77,68 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
(define (predicate->char-set predicate)
(let ((table (make-string char-set-table-length)))
- (let loop ((code 0))
- (if (fix:< code char-set-table-length)
- (begin
- (vector-8b-set! table
- code
- (if (predicate (integer->char code)) 1 0))
- (loop (fix:+ code 1)))))
+ (do ((code 0 (fix:+ code 1)))
+ ((fix:= code char-set-table-length))
+ (vector-8b-set! table code (if (predicate (integer->char code)) 1 0)))
(make-char-set table)))
(define (char-set-members char-set)
- (if (not (char-set? char-set))
- (error:wrong-type-argument char-set "character set" 'CHAR-SET-MEMBERS))
+ (guarantee-char-set char-set 'CHAR-SET-MEMBERS)
(let ((table (char-set-table char-set)))
- (let loop ((code char-set-table-length) (chars '()))
- (if (fix:< 0 code)
+ (let loop ((code (fix:- char-set-table-length 1)) (chars '()))
+ (if (fix:= code 0)
+ (if (fix:= 0 (vector-8b-ref table code))
+ chars
+ (cons (integer->char code) chars))
(loop (fix:- code 1)
- (if (fix:= 0 (vector-8b-ref table (fix:- code 1)))
+ (if (fix:= 0 (vector-8b-ref table code))
chars
- (cons (integer->char (fix:- code 1)) chars)))
- chars))))
+ (cons (integer->char code) chars)))))))
(define (char-set-member? char-set char)
- (if (not (char-set? char-set))
- (error:wrong-type-argument char-set "character set" 'CHAR-SET-MEMBER?))
- (let ((code (char->integer char)))
- (and (fix:< code char-set-table-length)
- (not (fix:= 0 (vector-8b-ref (char-set-table char-set) code))))))
+ (guarantee-char-set char-set 'CHAR-SET-MEMBER?)
+ (guarantee-char char 'CHAR-SET-MEMBER?)
+ (%char-set-member? char-set char))
+
+(define (%char-set-member? char-set char)
+ (and (fix:< (char->integer char) char-set-table-length)
+ (not (fix:= 0
+ (vector-8b-ref (char-set-table char-set)
+ (char->integer char))))))
(define (char-set-invert char-set)
+ (guarantee-char-set char-set 'CHAR-SET-INVERT)
(predicate->char-set
(lambda (char)
- (not (char-set-member? char-set char)))))
+ (not (%char-set-member? char-set char)))))
(define (char-set-union . char-sets)
+ (guarantee-char-sets char-sets 'CHAR-SET-UNION)
(predicate->char-set
(lambda (char)
(there-exists? char-sets
(lambda (char-set)
- (char-set-member? char-set char))))))
+ (%char-set-member? char-set char))))))
(define (char-set-intersection . char-sets)
+ (guarantee-char-sets char-sets 'CHAR-SET-INTERSECTION)
(predicate->char-set
(lambda (char)
(for-all? char-sets
(lambda (char-set)
- (char-set-member? char-set char))))))
+ (%char-set-member? char-set char))))))
+
+(define (guarantee-char-sets char-sets procedure)
+ (for-each (lambda (char-set) (guarantee-char-set char-set procedure))
+ char-sets))
(define (char-set-difference include exclude)
+ (guarantee-char-set include 'CHAR-SET-DIFFERENCE)
+ (guarantee-char-set exclude 'CHAR-SET-DIFFERENCE)
(predicate->char-set
(lambda (char)
- (and (char-set-member? include char)
- (not (char-set-member? exclude char))))))
+ (and (%char-set-member? include char)
+ (not (%char-set-member? exclude char))))))
;;;; System Character Sets
@@ -169,27 +193,59 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
(set! char-set:not-alphanumeric (char-set-invert char-set:alphanumeric))
(set! char-set:not-standard (char-set-invert char-set:standard))
unspecific)
-
+
(define (char-upper-case? char)
- (char-set-member? char-set:upper-case char))
+ (guarantee-char char 'CHAR-UPPER-CASE?)
+ (%char-upper-case? char))
+
+(define-integrable (%char-upper-case? char)
+ (%char-set-member? char-set:upper-case char))
(define (char-lower-case? char)
- (char-set-member? char-set:lower-case char))
+ (guarantee-char char 'CHAR-LOWER-CASE?)
+ (%char-lower-case? char))
+
+(define-integrable (%char-lower-case? char)
+ (%char-set-member? char-set:lower-case char))
(define (char-numeric? char)
- (char-set-member? char-set:numeric char))
+ (guarantee-char char 'CHAR-NUMERIC?)
+ (%char-numeric? char))
+
+(define-integrable (%char-numeric? char)
+ (%char-set-member? char-set:numeric char))
(define (char-graphic? char)
- (char-set-member? char-set:graphic char))
+ (guarantee-char char 'CHAR-GRAPHIC?)
+ (%char-graphic? char))
+
+(define-integrable (%char-graphic? char)
+ (%char-set-member? char-set:graphic char))
(define (char-whitespace? char)
- (char-set-member? char-set:whitespace char))
+ (guarantee-char char 'CHAR-WHITESPACE?)
+ (%char-whitespace? char))
+
+(define-integrable (%char-whitespace? char)
+ (%char-set-member? char-set:whitespace char))
(define (char-alphabetic? char)
- (char-set-member? char-set:alphabetic char))
+ (guarantee-char char 'CHAR-ALPHABETIC?)
+ (%char-alphabetic? char))
+
+(define-integrable (%char-alphabetic? char)
+ (%char-set-member? char-set:alphabetic char))
(define (char-alphanumeric? char)
- (char-set-member? char-set:alphanumeric char))
+ (guarantee-char char 'CHAR-ALPHANUMERIC?)
+ (%char-alphanumeric? char))
+
+(define-integrable (%char-alphanumeric? char)
+ (%char-set-member? char-set:alphanumeric char))
(define (char-standard? char)
- (char-set-member? char-set:standard char))
\ No newline at end of file
+ (guarantee-char char 'CHAR-STANDARD?)
+ (%char-standard? char))
+
+(define-integrable (%char-standard? char)
+ (%char-set-member? char-set:standard char))
\ No newline at end of file