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))
(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))))
)

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

@ -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))))
)