diff --git a/scheme/ikarus.boot.orig b/scheme/ikarus.boot.orig index 303e0fa..f2e80ba 100644 Binary files a/scheme/ikarus.boot.orig and b/scheme/ikarus.boot.orig differ diff --git a/scheme/makefile.ss b/scheme/makefile.ss index e381854..84696a6 100755 --- a/scheme/makefile.ss +++ b/scheme/makefile.ss @@ -150,6 +150,7 @@ [unsyntax-splicing (macro . unsyntax-splicing)] [trace-lambda (macro . trace-lambda)] [trace-define (macro . trace-define)] + [guard (macro . guard)] [eol-style (macro . eol-style)] [buffer-mode (macro . buffer-mode)] [file-options (macro . file-options)] @@ -984,7 +985,7 @@ [raise i r ex] [raise-continuable i r ex] [with-exception-handler i r ex] - [guard r ex] + [guard i r ex] [binary-port? r ip] [buffer-mode i r ip] [buffer-mode? i r ip] diff --git a/scheme/psyntax.expander.ss b/scheme/psyntax.expander.ss index cea0f41..db9656e 100644 --- a/scheme/psyntax.expander.ss +++ b/scheme/psyntax.expander.ss @@ -1029,6 +1029,36 @@ "not a procedure" v))))) (stx-error stx "invalid formals")))))) + (define guard-macro + (lambda (x) + (syntax-match x (else) + [(_ (con clause* ... [else e e* ...]) b b* ...) + (bless + `((call/cc + (lambda (outerk) + (lambda () + (with-exception-handler + (lambda (,con) + (outerk + (lambda () + (cond ,@clause* [else ,e ,@e*])))) + (lambda () #f ,b ,@b*)))))))] + [(_ (con clause* ...) b b* ...) + (bless + `((call/cc + (lambda (outerk) + (lambda () + (with-exception-handler + (lambda (,con) + ((call/cc + (lambda (raisek) + (outerk + (lambda () + (cond ,@clause* + [else + (raisek (lambda () (raise ,con)))]))))))) + (lambda () #f ,b ,@b* )))))))]))) + (define time-macro (lambda (stx) (syntax-match stx () @@ -2150,6 +2180,7 @@ ((delay) delay-macro) ((assert) assert-macro) ((endianness) endianness-macro) + ((guard) guard-macro) ((trace-lambda) trace-lambda-macro) ((trace-define) trace-define-macro) ((define-condition-type) define-condition-type-macro) @@ -2640,18 +2671,19 @@ ;;; given a library name, like (foo bar (1 2 3)), ;;; returns the identifiers and the version of the library ;;; as (foo bar) (1 2 3). - (define (parse-library-name x) + (define (parse-library-name spec) (define (parse x) (syntax-match x () - ((x* ... (v* ...)) - (and (for-all symbol? x*) - (for-all (lambda (x) (and (integer? x) (exact? x))) v*)) - (values x* v*)) - ((x* ...) (for-all symbol? x*) - (values x* '())) - (_ (stx-error x "invalid library name")))) - (let-values (((name* ver*) (parse x))) - (when (null? name*) (stx-error x "empty library name")) + [((v* ...)) + (for-all (lambda (x) (and (integer? x) (exact? x))) v*) + (values '() v*)] + [(x . rest) (symbol? x) + (let-values ([(x* v*) (parse rest)]) + (values (cons x x*) v*))] + [() (values '() '())] + [_ (stx-error spec "invalid library name")])) + (let-values (((name* ver*) (parse spec))) + (when (null? name*) (stx-error spec "empty library name")) (values name* ver*))) ;;; given a library form, returns the name part, the export @@ -2862,7 +2894,7 @@ (let-values (((imp* invoke-req* visit-req* invoke-code visit-code export-subst export-env) (library-body-expander exp* imp* b*))) - (values name imp* invoke-req* visit-req* + (values name ver imp* invoke-req* visit-req* invoke-code visit-code export-subst export-env)))))) @@ -2958,11 +2990,11 @@ (let ((loc (car x)) (proc (cadr x))) (set-symbol-value! loc proc))) macro*)) - (let-values (((name imp* inv* vis* invoke-code macro* export-subst export-env) + (let-values (((name ver imp* inv* vis* invoke-code macro* export-subst export-env) (core-library-expander x))) (let ((id (gensym)) (name name) - (ver '()) ;;; FIXME + (ver ver) ;;; FIXME (imp* (map library-spec imp*)) (vis* (map library-spec vis*)) (inv* (map library-spec inv*))) diff --git a/scheme/todo-r6rs.ss b/scheme/todo-r6rs.ss index 7bed3ef..4581d8f 100755 --- a/scheme/todo-r6rs.ss +++ b/scheme/todo-r6rs.ss @@ -32,6 +32,7 @@ [fi (rnrs files (6))] [ne (null-environment)] [sr (rnrs sorting (6))] + [ex (rnrs exceptions (6))] [ls (rnrs lists (6))] [ri (rnrs records inspection (6))] [rp (rnrs records procedural (6))] @@ -41,7 +42,6 @@ [ba (rnrs base (6))] [bv (rnrs bytevectors (6))] [uc (rnrs unicode (6))] - [ex (rnrs exceptions (6))] [bw (rnrs arithmetic bitwise (6))] [fx (rnrs arithmetic fixnums (6))] [fl (rnrs arithmetic flonums (6))] @@ -507,7 +507,7 @@ [raise C ex] [raise-continuable C ex] [with-exception-handler C ex] - [guard S ex] + [guard C ex] ;;; [binary-port? S ip] [buffer-mode C ip]