mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-03 13:20:26 +02:00
Code Activity

Add R6RS `syntax-violation' to (rnrs syntax-case).

Browse source 
* 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.
This commit is contained in:
Julian Graham 2010-03-28 19:40:16 -04:00
parent 2359a9a49e
commit 0c7398a7dc
2 changed files with 26 additions and 19 deletions
Download patch file Download diff file Expand all files Collapse all files

29
module/rnrs/6/exceptions.scm
View file

@ -22,7 +22,6 @@
(import (rnrs base (6)) (import (rnrs base (6))
(rnrs conditions (6)) (rnrs conditions (6))
(rnrs records procedural (6)) (rnrs records procedural (6))
(rnrs syntax-case (6))
(only (guile) with-throw-handler)) (only (guile) with-throw-handler))
(define raise (@@ (rnrs records procedural) r6rs-raise)) (define raise (@@ (rnrs records procedural) r6rs-raise))
@ -51,22 +50,18 @@
*unspecified*)))) *unspecified*))))
(define-syntax guard0 (define-syntax guard0
(lambda (stx) (syntax-rules ()
(syntax-case stx () ((_ (variable cond-clause ...) body)
((_ (variable cond-clause ...) body) (call/cc (lambda (continuation)
(syntax (call/cc (lambda (continuation) (with-exception-handler
(with-exception-handler (lambda (variable)
(lambda (variable) (continuation (cond cond-clause ...)))
(continuation (cond cond-clause ...))) (lambda () body)))))))
(lambda () body)))))))))
(define-syntax guard (define-syntax guard
(lambda (stx) (syntax-rules (else)
(syntax-case stx (else) ((_ (variable cond-clause ... . ((else else-clause ...))) body)
((_ (variable cond-clause ... . ((else else-clause ...))) body) (guard0 (variable cond-clause ... (else else-clause ...)) body))
(syntax (guard0 (variable cond-clause ... (else else-clause ...)) ((_ (variable cond-clause ...) body)
body))) (guard0 (variable cond-clause ... (else (raise variable))) body))))
((_ (variable cond-clause ...) body)
(syntax (guard0 (variable cond-clause ... (else (raise variable)))
body))))))
) )

16
module/rnrs/6/syntax-case.scm
View file

@ -50,6 +50,18 @@
quasisyntax quasisyntax
unsyntax 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))))
)