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

* string<?, string<=?, string>?, and string>=? now have proper 

annotations
This commit is contained in:
Abdulaziz Ghuloum 2007-09-04 21:01:30 -04:00
parent 62e1527d1d
commit 1a8af2acea
3 changed files with 78 additions and 35 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.

15
src/ikarus.control.ss
View File

@ -76,6 +76,8 @@
(define call/cc
(lambda (f)
(unless (procedure? f)
(error 'call/cc "~s is not a procedure" f))
(primitive-call/cc
(lambda (k)
(let ([save winders])
@ -87,11 +89,20 @@
(apply k v1 v2 v*)])))))))
(define call-with-current-continuation
;; look at how verbose I am ;;
(lambda (f) (call/cc f)))
(lambda (f)
(unless (procedure? f)
(error 'call-with-current-continuation
"~s is not a procedure" f))
(call/cc f)))
(define dynamic-wind
(lambda (in body out)
(unless (procedure? in)
(error 'dynamic-wind "~s is not a procedure" in))
(unless (procedure? body)
(error 'dynamic-wind "~s is not a procedure" body))
(unless (procedure? out)
(error 'dynamic-wind "~s is not a procedure" out))
(in)
(set! winders (cons (cons in out) winders))
(call-with-values

98
src/ikarus.strings.ss
View File

@ -169,34 +169,26 @@
(define string-cmp
(lambda (who cmp)
(case-lambda
[(s1 s2)
(if (string? s1)
(if (string? s2)
(cmp s1 s2)
(error who "~s is not a string" s2))
(error who "~s is not a string" s1))]
[(s1 . s*)
(if (string? s1)
(let f ([s1 s1] [s* s*])
(cond
[(null? s*) #t]
[else
(let ([s2 (car s*)])
(if (string? s2)
(if (cmp s1 s2)
(f s2 (cdr s*))
(let f ([s* (cdr s*)])
(cond
[(null? s*) #f]
[(string? (car s*))
(f (cdr s*))]
[else
(error who "~s is not a string"
(car s*))]))))
(error who "~s is not a string" s2))])))
(error who "~s is not a string" s1)])))
(lambda (who cmp s1 s*)
(if (string? s1)
(let f ([s1 s1] [s* s*])
(cond
[(null? s*) #t]
[else
(let ([s2 (car s*)])
(if (string? s2)
(if (cmp s1 s2)
(f s2 (cdr s*))
(let f ([s* (cdr s*)])
(cond
[(null? s*) #f]
[(string? (car s*))
(f (cdr s*))]
[else
(error who "~s is not a string"
(car s*))]))))
(error who "~s is not a string" s2))])))
(error who "~s is not a string" s1)))
(define ($string<? s1 s2)
(let ([n1 ($string-length s1)]
@ -223,7 +215,6 @@
(f ($fxadd1 i) n s1 s2)
#f))))))))
(define ($string<=? s1 s2)
(let ([n1 ($string-length s1)]
[n2 ($string-length s2)])
@ -248,15 +239,56 @@
(if ($char= c1 c2)
(f ($fxadd1 i) n s1 s2)
#f))))))))
(define ($string>? s1 s2)
($string<? s2 s1))
(define ($string>=? s1 s2)
($string<=? s2 s1))
(define string<? (string-cmp 'string<? $string<?))
(define string<=? (string-cmp 'string<=? $string<=?))
(define string>? (string-cmp 'string>? $string>?))
(define string>=? (string-cmp 'string>=? $string>=?))
(define string<?
(case-lambda
[(s1 s2)
(if (string? s1)
(if (string? s2)
($string<? s1 s2)
(error 'string<? "~s is not a string" s2))
(error 'string<? "~s is not a string" s2))]
[(s . s*)
(string-cmp 'string<? $string<? s s*)]))
(define string<=?
(case-lambda
[(s1 s2)
(if (string? s1)
(if (string? s2)
($string<=? s1 s2)
(error 'string<=? "~s is not a string" s2))
(error 'string<=? "~s is not a string" s2))]
[(s . s*)
(string-cmp 'string<=? $string<=? s s*)]))
(define string>?
(case-lambda
[(s1 s2)
(if (string? s1)
(if (string? s2)
($string>? s1 s2)
(error 'string>? "~s is not a string" s2))
(error 'string>? "~s is not a string" s2))]
[(s . s*)
(string-cmp 'string>? $string>? s s*)]))
(define string>=?
(case-lambda
[(s1 s2)
(if (string? s1)
(if (string? s2)
($string>=? s1 s2)
(error 'string>=? "~s is not a string" s2))
(error 'string>=? "~s is not a string" s2))]
[(s . s*)
(string-cmp 'string>=? $string>=? s s*)]))
(define string->list
(lambda (x)