2007-05-05 03:46:26 -04:00
|
|
|
|
|
|
|
(library (ikarus strings)
|
2007-05-05 04:00:32 -04:00
|
|
|
(export string-length string-ref string-set! make-string string->list string=?
|
2007-05-05 04:07:48 -04:00
|
|
|
string-append substring string list->string uuid)
|
2007-05-05 03:46:26 -04:00
|
|
|
(import
|
2007-05-05 03:58:40 -04:00
|
|
|
(except (ikarus) string-length string-ref string-set! make-string
|
2007-05-05 04:06:23 -04:00
|
|
|
string->list string=? string-append substring string
|
2007-05-05 04:07:48 -04:00
|
|
|
list->string uuid)
|
2007-05-05 03:51:38 -04:00
|
|
|
(only (scheme)
|
2007-05-05 03:58:40 -04:00
|
|
|
$fx+ $fxsub1 $fxadd1 $char= $car $cdr
|
2007-05-05 04:02:27 -04:00
|
|
|
$fxzero? $fx= $fx<= $fx< $fx>= $fx-
|
2007-05-05 03:53:19 -04:00
|
|
|
$string-length $string-ref
|
2007-05-05 03:49:51 -04:00
|
|
|
$make-string $string-set!))
|
|
|
|
|
2007-05-05 03:51:38 -04:00
|
|
|
|
|
|
|
(define string-length
|
|
|
|
(lambda (x)
|
|
|
|
(unless (string? x)
|
|
|
|
(error 'string-length "~s is not a string" x))
|
|
|
|
($string-length x)))
|
|
|
|
|
|
|
|
|
2007-05-05 03:46:26 -04:00
|
|
|
(define (string-ref s i)
|
|
|
|
(unless (string? s)
|
|
|
|
(error 'string-ref "~s is not a string" s))
|
|
|
|
(unless (fixnum? i)
|
|
|
|
(error 'string-ref "~s is not a valid index" i))
|
|
|
|
(unless (and ($fx< i ($string-length s))
|
|
|
|
($fx<= 0 i))
|
|
|
|
(error 'string-ref "index ~s is out of range for ~s" i s))
|
2007-05-05 03:49:51 -04:00
|
|
|
($string-ref s i))
|
|
|
|
|
2007-05-05 03:58:40 -04:00
|
|
|
|
|
|
|
(define string-set!
|
|
|
|
(lambda (s i c)
|
|
|
|
(unless (string? s)
|
|
|
|
(error 'string-set! "~s is not a string" s))
|
|
|
|
(unless (fixnum? i)
|
|
|
|
(error 'string-set! "~s is not a valid index" i))
|
|
|
|
(unless (and ($fx< i ($string-length s))
|
|
|
|
($fx>= i 0))
|
|
|
|
(error 'string-set! "index ~s is out of range for ~s" i s))
|
|
|
|
(unless (char? c)
|
|
|
|
(error 'string-set! "~s is not a character" c))
|
|
|
|
($string-set! s i c)))
|
2007-05-05 03:49:51 -04:00
|
|
|
|
|
|
|
(define make-string
|
|
|
|
(let ()
|
|
|
|
(define fill!
|
|
|
|
(lambda (s i n c)
|
|
|
|
(cond
|
|
|
|
[($fx= i n) s]
|
|
|
|
[else
|
|
|
|
($string-set! s i c)
|
|
|
|
(fill! s ($fx+ i 1) n c)])))
|
|
|
|
(define make-string
|
|
|
|
(case-lambda
|
|
|
|
[(n)
|
|
|
|
(unless (and (fixnum? n) (fx>= n 0))
|
|
|
|
(error 'make-string "~s is not a valid length" n))
|
|
|
|
($make-string n)]
|
|
|
|
[(n c)
|
|
|
|
(unless (and (fixnum? n) (fx>= n 0))
|
|
|
|
(error 'make-string "~s is not a valid length" n))
|
|
|
|
(unless (char? c)
|
|
|
|
(error 'make-string "~s is not a character" c))
|
|
|
|
(fill! ($make-string n) 0 n c)]))
|
|
|
|
make-string))
|
2007-05-05 03:53:19 -04:00
|
|
|
|
|
|
|
|
2007-05-05 04:04:58 -04:00
|
|
|
(define string
|
|
|
|
;;; FIXME: add case-lambda
|
|
|
|
(letrec ([length
|
|
|
|
(lambda (ls n)
|
|
|
|
(cond
|
|
|
|
[(null? ls) n]
|
|
|
|
[(char? ($car ls)) (length ($cdr ls) ($fx+ n 1))]
|
|
|
|
[else (error 'string "~s is not a character" ($car ls))]))]
|
|
|
|
[loop
|
|
|
|
(lambda (s ls i n)
|
|
|
|
(cond
|
|
|
|
[($fx= i n) s]
|
|
|
|
[else
|
|
|
|
($string-set! s i ($car ls))
|
|
|
|
(loop s ($cdr ls) ($fx+ i 1) n)]))])
|
|
|
|
(lambda ls
|
|
|
|
(let ([n (length ls 0)])
|
|
|
|
(let ([s (make-string n)])
|
|
|
|
(loop s ls 0 n))))))
|
|
|
|
|
2007-05-05 04:02:27 -04:00
|
|
|
(module (substring)
|
|
|
|
(define fill
|
|
|
|
(lambda (s d si sj di)
|
|
|
|
(cond
|
|
|
|
[($fx= si sj) d]
|
|
|
|
[else
|
|
|
|
($string-set! d di ($string-ref s si))
|
|
|
|
(fill s d ($fxadd1 si) sj ($fxadd1 di))])))
|
|
|
|
(define substring
|
|
|
|
(lambda (s n m)
|
|
|
|
(unless (string? s)
|
|
|
|
(error 'substring "~s is not a string" s))
|
|
|
|
(let ([len ($string-length s)])
|
|
|
|
(unless (and (fixnum? n)
|
|
|
|
($fx>= n 0)
|
|
|
|
($fx< n len))
|
|
|
|
(error 'substring "~s is not a valid start index for ~s" n s))
|
|
|
|
(unless (and (fixnum? m)
|
|
|
|
($fx>= m 0)
|
|
|
|
($fx<= m len))
|
|
|
|
(error 'substring "~s is not a valid end index for ~s" m s))
|
|
|
|
(let ([len ($fx- m n)])
|
|
|
|
(if ($fx<= len 0)
|
|
|
|
""
|
|
|
|
(fill s ($make-string len) n m 0)))))))
|
|
|
|
|
2007-05-05 03:57:14 -04:00
|
|
|
(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))])))
|
|
|
|
|
2007-05-05 03:53:19 -04:00
|
|
|
(define string->list
|
|
|
|
(lambda (x)
|
|
|
|
(unless (string? x)
|
|
|
|
(error 'string->list "~s is not a string" x))
|
|
|
|
(let f ([x x] [i ($string-length x)] [ac '()])
|
|
|
|
(cond
|
|
|
|
[($fxzero? i) ac]
|
|
|
|
[else
|
|
|
|
(let ([i ($fxsub1 i)])
|
|
|
|
(f x i (cons ($string-ref x i) ac)))]))))
|
|
|
|
|
|
|
|
|
2007-05-05 04:06:23 -04:00
|
|
|
(define list->string
|
|
|
|
(letrec ([race
|
|
|
|
(lambda (h t ls n)
|
|
|
|
(if (pair? h)
|
|
|
|
(let ([h ($cdr h)])
|
|
|
|
(if (pair? h)
|
|
|
|
(if (not (eq? h t))
|
|
|
|
(race ($cdr h) ($cdr t) ls ($fx+ n 2))
|
|
|
|
(error 'reverse "circular list ~s" ls))
|
|
|
|
(if (null? h)
|
|
|
|
($fx+ n 1)
|
|
|
|
(error 'reverse "~s is not a proper list" ls))))
|
|
|
|
(if (null? h)
|
|
|
|
n
|
|
|
|
(error 'reverse "~s is not a proper list" ls))))]
|
|
|
|
[fill
|
|
|
|
(lambda (s i ls)
|
|
|
|
(cond
|
|
|
|
[(null? ls) s]
|
|
|
|
[else
|
|
|
|
(let ([c ($car ls)])
|
|
|
|
(unless (char? c)
|
|
|
|
(error 'list->string "~s is not a character" c))
|
|
|
|
($string-set! s i c)
|
|
|
|
(fill s ($fxadd1 i) (cdr ls)))]))])
|
|
|
|
(lambda (ls)
|
|
|
|
(let ([n (race ls ls ls 0)])
|
|
|
|
(let ([s ($make-string n)])
|
|
|
|
(fill s 0 ls))))))
|
|
|
|
|
2007-05-05 04:00:32 -04:00
|
|
|
(module (string-append)
|
|
|
|
;; FIXME: make nonconsing on 0,1,2, and 3 args
|
|
|
|
(define length*
|
|
|
|
(lambda (s* n)
|
|
|
|
(cond
|
|
|
|
[(null? s*) n]
|
|
|
|
[else
|
|
|
|
(let ([a ($car s*)])
|
|
|
|
(unless (string? a)
|
|
|
|
(error 'string-append "~s is not a string" a))
|
|
|
|
(length* ($cdr s*) ($fx+ n ($string-length a))))])))
|
|
|
|
(define fill-string
|
|
|
|
(lambda (s a si sj ai)
|
|
|
|
(unless ($fx= si sj)
|
|
|
|
($string-set! s si ($string-ref a ai))
|
|
|
|
(fill-string s a ($fxadd1 si) sj ($fxadd1 ai)))))
|
|
|
|
(define fill-strings
|
|
|
|
(lambda (s s* i)
|
|
|
|
(cond
|
|
|
|
[(null? s*) s]
|
|
|
|
[else
|
|
|
|
(let ([a ($car s*)])
|
|
|
|
(let ([n ($string-length a)])
|
|
|
|
(let ([j ($fx+ i n)])
|
|
|
|
(fill-string s a i j 0)
|
|
|
|
(fill-strings s ($cdr s*) j))))])))
|
|
|
|
(define string-append
|
|
|
|
(lambda s*
|
|
|
|
(let ([n (length* s* 0)])
|
|
|
|
(let ([s ($make-string n)])
|
|
|
|
(fill-strings s s* 0))))))
|
2007-05-05 03:53:19 -04:00
|
|
|
|
2007-05-05 04:07:48 -04:00
|
|
|
|
|
|
|
(define uuid
|
|
|
|
(lambda ()
|
|
|
|
(let ([s (make-string 16)])
|
|
|
|
(or (foreign-call "ik_uuid" s)
|
|
|
|
(error 'uuid "failed!")))))
|
2007-05-05 03:49:51 -04:00
|
|
|
)
|