diff --git a/src/ikarus.boot b/src/ikarus.boot index 3d28e2e..b842f42 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/ikarus.core.ss b/src/ikarus.core.ss index 55b090e..8297b08 100644 --- a/src/ikarus.core.ss +++ b/src/ikarus.core.ss @@ -73,54 +73,6 @@ -#|procedure:string=? -synopsis: - (string=? s s* ...) -description: - string=? takes 1 or more strings and returns #t if all strings are - equal. Two strings s1 and s2 are string=? if they have the same - length and if (char=? (string-ref s1 i) (string-ref s2 i)) for all - 0 <= i < (string-length s1) -|# -(let () - (define bstring=? - (lambda (s1 s2 i j) - (or ($fx= i j) - (and ($char= ($string-ref s1 i) ($string-ref s2 i)) - (bstring=? s1 s2 ($fxadd1 i) j))))) - (define check-strings-and-return-false - (lambda (s*) - (cond - [(null? s*) #f] - [(string? ($car s*)) - (check-strings-and-return-false ($cdr s*))] - [else (err ($car s*))]))) - (define strings=? - (lambda (s s* n) - (or (null? s*) - (let ([a ($car s*)]) - (unless (string? a) - (error 'string=? "~s is not a string" a)) - (if ($fx= n ($string-length a)) - (and (strings=? s ($cdr s*) n) - (bstring=? s a 0 n)) - (check-strings-and-return-false ($cdr s*))))))) - (define (err x) - (error 'string=? "~s is not a string" x)) - (primitive-set! 'string=? - (case-lambda - [(s s1) - (if (string? s) - (if (string? s1) - (let ([n ($string-length s)]) - (and ($fx= n ($string-length s1)) - (bstring=? s s1 0 n))) - (err s1)) - (err s))] - [(s . s*) - (if (string? s) - (strings=? s s* ($string-length s)) - (err s))]))) diff --git a/src/ikarus.strings.ss b/src/ikarus.strings.ss index c7e365a..eb6f27b 100644 --- a/src/ikarus.strings.ss +++ b/src/ikarus.strings.ss @@ -1,11 +1,11 @@ (library (ikarus strings) - (export string-length string-ref make-string string->list) + (export string-length string-ref make-string string->list string=?) (import (except (ikarus) string-length string-ref make-string - string->list) + string->list string=?) (only (scheme) - $fx+ $fxsub1 $fxzero? $fx= $fx<= $fx< + $fx+ $fxsub1 $fxadd1 $char= $car $cdr $fxzero? $fx= $fx<= $fx< $string-length $string-ref $make-string $string-set!)) @@ -52,6 +52,46 @@ make-string)) + (module (string=?) + (define bstring=? + (lambda (s1 s2 i j) + (or ($fx= i j) + (and ($char= ($string-ref s1 i) ($string-ref s2 i)) + (bstring=? s1 s2 ($fxadd1 i) j))))) + (define check-strings-and-return-false + (lambda (s*) + (cond + [(null? s*) #f] + [(string? ($car s*)) + (check-strings-and-return-false ($cdr s*))] + [else (err ($car s*))]))) + (define strings=? + (lambda (s s* n) + (or (null? s*) + (let ([a ($car s*)]) + (unless (string? a) + (error 'string=? "~s is not a string" a)) + (if ($fx= n ($string-length a)) + (and (strings=? s ($cdr s*) n) + (bstring=? s a 0 n)) + (check-strings-and-return-false ($cdr s*))))))) + (define (err x) + (error 'string=? "~s is not a string" x)) + (define string=? + (case-lambda + [(s s1) + (if (string? s) + (if (string? s1) + (let ([n ($string-length s)]) + (and ($fx= n ($string-length s1)) + (bstring=? s s1 0 n))) + (err s1)) + (err s))] + [(s . s*) + (if (string? s) + (strings=? s s* ($string-length s)) + (err s))]))) + (define string->list (lambda (x) (unless (string? x)