diff options
author | Julian Graham <julian.graham@aya.yale.edu> | 2010-03-28 19:40:16 -0400 |
---|---|---|
committer | Julian Graham <julian.graham@aya.yale.edu> | 2010-05-20 21:18:03 -0400 |
commit | 0c7398a7dc471bc7b9f09b65dba7e33f4ac88af5 (patch) | |
tree | 89f3d73cd8ece516a99cc814f862ee2edfe9c46a | |
parent | 2359a9a49ef4dd70e112d517b11b05840440b522 (diff) | |
download | guile-0c7398a7dc471bc7b9f09b65dba7e33f4ac88af5.tar.gz |
Add R6RS `syntax-violation' to (rnrs syntax-case).
* module/rnrs/6/exceptions.scm: Remove dependency on (rnrs syntax-case);
rewrite guard and guard0 in using syntax-rules in terms of syntax-case.
* module/rnrs/6/syntax-case.scm: Add syntax-violation implementation.
-rw-r--r-- | module/rnrs/6/exceptions.scm | 29 | ||||
-rw-r--r-- | module/rnrs/6/syntax-case.scm | 16 |
2 files changed, 26 insertions, 19 deletions
diff --git a/module/rnrs/6/exceptions.scm b/module/rnrs/6/exceptions.scm index 87dfe70b9..70526f53b 100644 --- a/module/rnrs/6/exceptions.scm +++ b/module/rnrs/6/exceptions.scm @@ -22,7 +22,6 @@ (import (rnrs base (6)) (rnrs conditions (6)) (rnrs records procedural (6)) - (rnrs syntax-case (6)) (only (guile) with-throw-handler)) (define raise (@@ (rnrs records procedural) r6rs-raise)) @@ -51,22 +50,18 @@ *unspecified*)))) (define-syntax guard0 - (lambda (stx) - (syntax-case stx () - ((_ (variable cond-clause ...) body) - (syntax (call/cc (lambda (continuation) - (with-exception-handler - (lambda (variable) - (continuation (cond cond-clause ...))) - (lambda () body))))))))) + (syntax-rules () + ((_ (variable cond-clause ...) body) + (call/cc (lambda (continuation) + (with-exception-handler + (lambda (variable) + (continuation (cond cond-clause ...))) + (lambda () body))))))) (define-syntax guard - (lambda (stx) - (syntax-case stx (else) - ((_ (variable cond-clause ... . ((else else-clause ...))) body) - (syntax (guard0 (variable cond-clause ... (else else-clause ...)) - body))) - ((_ (variable cond-clause ...) body) - (syntax (guard0 (variable cond-clause ... (else (raise variable))) - body)))))) + (syntax-rules (else) + ((_ (variable cond-clause ... . ((else else-clause ...))) body) + (guard0 (variable cond-clause ... (else else-clause ...)) body)) + ((_ (variable cond-clause ...) body) + (guard0 (variable cond-clause ... (else (raise variable))) body)))) ) diff --git a/module/rnrs/6/syntax-case.scm b/module/rnrs/6/syntax-case.scm index 91ca6002e..6aa1cef3c 100644 --- a/module/rnrs/6/syntax-case.scm +++ b/module/rnrs/6/syntax-case.scm @@ -50,6 +50,18 @@ quasisyntax unsyntax - unsyntax-splicing + unsyntax-splicing) + (ice-9 optargs) + (rnrs base (6)) + (rnrs conditions (6)) + (rnrs exceptions (6)) + (rnrs records procedural (6))) - syntax-violation))) + (define* (syntax-violation who message form #:optional subform) + (let* ((conditions (list (make-message-condition message) + (make-syntax-violation form subform))) + (conditions (if who + (cons (make-who-condition who) conditions) + conditions))) + (raise (apply condition conditions)))) +) |