suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

PR 10002

Browse Source 
svn: r13002
This commit is contained in:
Robby Findler 2009-01-04 18:08:37 +00:00
parent 8a2753efb8
commit 9b84def3c1
1 changed files with 26 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
collects/redex/private/reduction-semantics.ss
View File

@ -1045,25 +1045,35 @@
(define (check-clauses stx syn-error-name rest)
(syntax-case rest ()
[([(lhs ...) roc ...] ...)
[([(lhs ...) roc1 roc2 ...] ...)
rest]
[([(lhs ...) rhs ...] ...)
(begin
(for-each
(λ (clause)
(syntax-case clause ()
[(a b) (void)]
[x (raise-syntax-error syn-error-name "expected a pattern and a right-hand side" stx clause)]))
(syntax->list #'([(lhs ...) rhs ...] ...)))
(raise-syntax-error syn-error-name "error checking failed.3" stx))]
[([x roc ...] ...)
(for-each
(λ (x)
(syntax-case x ()
[(lhs ...) (void)]
[x (raise-syntax-error syn-error-name "expected a function prototype" stx #'x)]))
(syntax->list #'(x ...)))
(raise-syntax-error syn-error-name "error checking failed.1" stx)]
(begin
(for-each
(λ (x)
(syntax-case x ()
[(lhs ...) (void)]
[x (raise-syntax-error syn-error-name "expected a function prototype" stx #'x)]))
(syntax->list #'(x ...)))
(raise-syntax-error syn-error-name "error checking failed.1" stx))]
[(x ...)
(for-each
(λ (x)
(syntax-case x ()
[(stuff ...) (void)]
[x (raise-syntax-error syn-error-name "expected a metafunction clause" stx #'x)]))
(syntax->list #'(x ...)))
(raise-syntax-error syn-error-name "error checking failed.2" stx)]))
(begin
(for-each
(λ (x)
(syntax-case x ()
[(stuff ...) (void)]
[x (raise-syntax-error syn-error-name "expected a metafunction clause" stx #'x)]))
(syntax->list #'(x ...)))
(raise-syntax-error syn-error-name "error checking failed.2" stx))]))
(define (extract-side-conditions name stx stuffs)
(let loop ([stuffs (syntax->list stuffs)]