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

98
src/ikarus.strings.ss
View File

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