conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

* moved list->string to ikarus.strings

This commit is contained in:
Abdulaziz Ghuloum 2007-05-05 04:06:23 -04:00
parent bc4b74b895
commit a6ef1cd110
3 changed files with 33 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
src/ikarus.boot
View File

Binary file not shown.

29
src/ikarus.core.ss
View File

@ -675,35 +675,6 @@
(race ls ls ls x)))) (race ls ls ls x))))
(primitive-set! '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))))))
(primitive-set! 'length (primitive-set! 'length
(letrec ([race (letrec ([race

35
src/ikarus.strings.ss
View File

@ -1,10 +1,11 @@
(library (ikarus strings) (library (ikarus strings)
(export string-length string-ref string-set! make-string string->list string=? (export string-length string-ref string-set! make-string string->list string=?
string-append substring string) string-append substring string list->string)
(import (import
(except (ikarus) string-length string-ref string-set! make-string (except (ikarus) string-length string-ref string-set! make-string
string->list string=? string-append substring string) string->list string=? string-append substring string
list->string)
(only (scheme) (only (scheme)
$fx+ $fxsub1 $fxadd1 $char= $car $cdr $fx+ $fxsub1 $fxadd1 $char= $car $cdr
$fxzero? $fx= $fx<= $fx< $fx>= $fx- $fxzero? $fx= $fx<= $fx< $fx>= $fx-
@ -165,6 +166,36 @@
(f x i (cons ($string-ref x i) ac)))])))) (f x i (cons ($string-ref x i) ac)))]))))
(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))))))
(module (string-append) (module (string-append)
;; FIXME: make nonconsing on 0,1,2, and 3 args ;; FIXME: make nonconsing on 0,1,2, and 3 args
(define length* (define length*