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

PR 9713

Browse Source 
svn: r11457
This commit is contained in:
Robby Findler 2008-08-27 18:47:04 +00:00
parent ab2ffaa06d
commit e29709e3d1
1 changed files with 17 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -822,7 +822,7 @@
(raise-syntax-error syn-error-name "expected an identifier in the language position" orig-stx #'lang)) (raise-syntax-error syn-error-name "expected an identifier in the language position" orig-stx #'lang))
(when (null? (syntax-e #'rest)) (when (null? (syntax-e #'rest))
(raise-syntax-error syn-error-name "no clauses" orig-stx)) (raise-syntax-error syn-error-name "no clauses" orig-stx))
(let-values ([(dom-ctcs codom-contract pats) (let-values ([(contract-name dom-ctcs codom-contract pats)
(split-out-contract orig-stx syn-error-name #'rest)]) (split-out-contract orig-stx syn-error-name #'rest)])
(with-syntax ([(((name lhs-clauses ...) rhs stuff ...) ...) pats] (with-syntax ([(((name lhs-clauses ...) rhs stuff ...) ...) pats]
[(lhs-for-lw ...) [(lhs-for-lw ...)
@ -830,16 +830,24 @@
(map (λ (x) (datum->syntax #f (cdr (syntax-e x)) x)) (map (λ (x) (datum->syntax #f (cdr (syntax-e x)) x))
(syntax->list #'(lhs-for-lw ...))))]) (syntax->list #'(lhs-for-lw ...))))])
(with-syntax ([(lhs ...) #'((lhs-clauses ...) ...)] (with-syntax ([(lhs ...) #'((lhs-clauses ...) ...)]
[name (let loop ([name (car (syntax->list #'(name ...)))] [name (let loop ([name (if contract-name
[names (cdr (syntax->list #'(name ...)))]) contract-name
(car (syntax->list #'(name ...))))]
[names (if contract-name
(syntax->list #'(name ...))
(cdr (syntax->list #'(name ...))))])
(cond (cond
[(null? names) name] [(null? names) name]
[else [else
(unless (eq? (syntax-e name) (syntax-e (car names))) (unless (eq? (syntax-e name) (syntax-e (car names)))
(raise-syntax-error 'define-metafunction (raise
"expected each clause to use the same name" (make-exn:fail:syntax
stx (if contract-name
(list name (car names)))) "define-metafunction: expected each clause and the contract to use the same name"
"define-metafunction: expected each clause to use the same name")
(current-continuation-marks)
(list name
(car names)))))
(loop name (cdr names))]))]) (loop name (cdr names))]))])
(with-syntax ([(((tl-side-conds ...) ...) (with-syntax ([(((tl-side-conds ...) ...)
@ -951,7 +959,7 @@
;; initial test determines if a contract is specified or not ;; initial test determines if a contract is specified or not
(cond (cond
[(pair? (syntax-e (car (syntax->list rest)))) [(pair? (syntax-e (car (syntax->list rest))))
(values #f #'any (check-clauses stx syn-error-name rest))] (values #f #f #'any (check-clauses stx syn-error-name rest))]
[else [else
(syntax-case rest () (syntax-case rest ()
[(id colon more ...) [(id colon more ...)
@ -969,7 +977,7 @@
(let ([doms (reverse dom-pats)] (let ([doms (reverse dom-pats)]
[codomain (cadr more)] [codomain (cadr more)]
[clauses (check-clauses stx syn-error-name (cddr more))]) [clauses (check-clauses stx syn-error-name (cddr more))])
(values doms codomain clauses))] (values #'id doms codomain clauses))]
[else [else
(loop (cdr more) (cons (car more) dom-pats))])))] (loop (cdr more) (cons (car more) dom-pats))])))]
[_ [_