diff --git a/src/ikarus.boot b/src/ikarus.boot index 70c1e17..500dd0c 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/ikarus.control.ss b/src/ikarus.control.ss index 4c2bbfc..70c7854 100644 --- a/src/ikarus.control.ss +++ b/src/ikarus.control.ss @@ -1,10 +1,11 @@ (library (ikarus control) - (export call/cf call/cc dynamic-wind exit) + (export call/cf call/cc call-with-current-continuation dynamic-wind exit) (import (ikarus system $stack) - (except (ikarus) call/cf call/cc dynamic-wind exit)) + (except (ikarus) call/cf call/cc call-with-current-continuation + dynamic-wind exit)) (define primitive-call/cf (lambda (f) @@ -85,6 +86,10 @@ (unless (eq? save winders) (do-wind save)) (apply k v1 v2 v*)]))))))) + (define call-with-current-continuation + ;; look at how verbose I am ;; + (lambda (f) (call/cc f))) + (define dynamic-wind (lambda (in body out) (in) diff --git a/src/ikarus.library-manager.ss b/src/ikarus.library-manager.ss index 81c3064..e176f40 100644 --- a/src/ikarus.library-manager.ss +++ b/src/ikarus.library-manager.ss @@ -93,7 +93,6 @@ (let f ([ls (library-path)]) (and (pair? ls) (let ([name (string-append (car ls) str)]) - (printf "trying ~s\n" name) (if (file-exists? name) name (f (cdr ls)))))))) diff --git a/src/ikarus.syntax.ss b/src/ikarus.syntax.ss index fb0ca9f..839e5aa 100644 --- a/src/ikarus.syntax.ss +++ b/src/ikarus.syntax.ss @@ -775,6 +775,31 @@ (bless `(letrec ([,f (lambda ,lhs* ,b . ,b*)]) (,f . ,rhs*))) (stx-error stx "invalid syntax"))]))) + (define do-macro + (lambda (stx) + (define bind + (lambda (x) + (syntax-match x () + [(x init) `(,x ,init ,x)] + [(x init step) `(,x ,init ,step)] + [_ (stx-error stx "invalid binding")]))) + (syntax-match stx () + [(_ (binding* ...) + (test expr* ...) + command* ...) + (syntax-match (map bind binding*) () + [([x* init* step*] ...) + (if (valid-bound-ids? x*) + (bless + `(letrec ([loop + (lambda ,x* + (if ,test + (begin (void) ,@expr*) + (begin + ,@command* + (loop ,@step*))))]) + (loop ,@init*))) + (stx-error stx "duplicate bindings"))])]))) (define let*-macro (lambda (stx) (syntax-match stx () @@ -1514,6 +1539,7 @@ [(include) include-macro] [(cond) cond-macro] [(let) let-macro] + [(do) do-macro] [(or) or-macro] [(and) and-macro] [(let*) let*-macro] diff --git a/src/makefile.ss b/src/makefile.ss index 3116394..356b943 100755 --- a/src/makefile.ss +++ b/src/makefile.ss @@ -90,6 +90,7 @@ [let (macro . let)] [let* (macro . let*)] [cond (macro . cond)] + [do (macro . do)] [and (macro . and)] [or (macro . or)])) @@ -149,6 +150,7 @@ [let i r] [let* i r] [cond i r] + [do i r] [and i r] [or i r])) @@ -370,6 +372,7 @@ [values i r] [call-with-values i r] [call/cc i r] + [call-with-current-continuation i r] [call/cf i] [dynamic-wind i r] [error i]