summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJulian Graham <julian.graham@aya.yale.edu>2010-03-28 19:40:16 -0400
committerJulian Graham <julian.graham@aya.yale.edu>2010-05-20 21:18:03 -0400
commit0c7398a7dc471bc7b9f09b65dba7e33f4ac88af5 (patch)
tree89f3d73cd8ece516a99cc814f862ee2edfe9c46a
parent2359a9a49ef4dd70e112d517b11b05840440b522 (diff)
downloadguile-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.scm29
-rw-r--r--module/rnrs/6/syntax-case.scm16
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))))
+)