From 8887ea2ef3400828aa197e81d47cdac09024f2d2 Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Fri, 22 Jul 2011 17:59:30 -0500 Subject: [PATCH] Refactors meta-function implementation further --- .../redex/private/reduction-semantics.rkt | 43 ++++++++++++------- .../redex/private/rewrite-side-conditions.rkt | 2 +- collects/redex/tests/rg-test.rkt | 2 +- collects/redex/tests/tl-test.rkt | 5 +++ 4 files changed, 34 insertions(+), 18 deletions(-) diff --git a/collects/redex/private/reduction-semantics.rkt b/collects/redex/private/reduction-semantics.rkt index a88df832d9..b2ad722df8 100644 --- a/collects/redex/private/reduction-semantics.rkt +++ b/collects/redex/private/reduction-semantics.rkt @@ -1222,8 +1222,9 @@ (if prev-metafunction 'define-metafunction/extension 'define-metafunction))]) - (unless (identifier? #'lang) - (raise-syntax-error syn-error-name "expected an identifier in the language position" orig-stx #'lang)) + (define lang-nts + ;; keep this near the beginning, so it signals the first error (PR 10062) + (relevant-nts #'lang orig-stx syn-error-name)) (when (null? (syntax-e #'rest)) (raise-syntax-error syn-error-name "no clauses" orig-stx)) (when prev-metafunction @@ -1231,14 +1232,11 @@ prev-metafunction (λ () (raise-syntax-error syn-error-name "expected a previously defined metafunction" orig-stx prev-metafunction)))) - (let ([lang-nts (language-id-nts #'lang 'define-metafunction)]) ;; keep this near the beginning, so it signals the first error (PR 10062) + (let () (let-values ([(contract-name dom-ctcs codom-contracts pats) (split-out-contract orig-stx syn-error-name #'rest relation?)]) (with-syntax ([(((original-names lhs-clauses ...) raw-rhses ...) ...) pats] - [(lhs-for-lw ...) - (with-syntax ([((lhs-for-lw _ ...) ...) pats]) - (map (λ (x) (to-lw/proc (datum->syntax #f (cdr (syntax-e x)) x))) - (syntax->list #'(lhs-for-lw ...))))]) + [(lhs-for-lw ...) (lhs-lws pats)]) (with-syntax ([((rhs stuff ...) ...) (if relation? #'((,(and (term raw-rhses) ...)) ...) #'((raw-rhses ...) ...))]) @@ -1249,15 +1247,7 @@ (raise-syntax-error syn-error-name "the extended and extending metafunctions cannot share a name" orig-stx prev-metafunction)) (parse-extras #'((stuff ...) ...)) (let-values ([(lhs-namess lhs-namess/ellipsess) - (let loop ([lhss (syntax->list (syntax (lhs ...)))]) - (if (null? lhss) - (values null null) - (let-values ([(namess namess/ellipsess) - (loop (cdr lhss))] - [(names names/ellipses) - (extract-names lang-nts syn-error-name #t (car lhss))]) - (values (cons names namess) - (cons names/ellipses namess/ellipsess)))))]) + (bound-names (syntax->list (syntax (lhs ...))) lang-nts syn-error-name)]) (with-syntax ([(rhs/wheres ...) (map (λ (sc/b rhs names names/ellipses) (bind-withs @@ -1386,6 +1376,27 @@ (map syntax-local-introduce (syntax->list #'(original-names ...)))))))))))))))])) + (define (bound-names lhss nts syn-error-name) + (let loop ([lhss lhss]) + (if (null? lhss) + (values null null) + (let-values ([(namess namess/ellipsess) + (loop (cdr lhss))] + [(names names/ellipses) + (extract-names nts syn-error-name #t (car lhss))]) + (values (cons names namess) + (cons names/ellipses namess/ellipsess)))))) + + (define (lhs-lws clauses) + (with-syntax ([((lhs-for-lw _ ...) ...) clauses]) + (map (λ (x) (to-lw/proc (datum->syntax #f (cdr (syntax-e x)) x))) + (syntax->list #'(lhs-for-lw ...))))) + + (define (relevant-nts lang orig-stx syn-error-name) + (unless (identifier? lang) + (raise-syntax-error #f "expected an identifier in the language position" orig-stx lang)) + (language-id-nts lang syn-error-name)) + (define (defined-name declared-name clauses orig-stx) (with-syntax ([(((used-names _ ...) _ ...) ...) clauses]) (let loop ([name (if declared-name diff --git a/collects/redex/private/rewrite-side-conditions.rkt b/collects/redex/private/rewrite-side-conditions.rkt index 74d6e73b9a..f477df0a48 100644 --- a/collects/redex/private/rewrite-side-conditions.rkt +++ b/collects/redex/private/rewrite-side-conditions.rkt @@ -23,7 +23,7 @@ (let ([val (syntax-local-value stx (λ () #f))]) (unless (and (set!-transformer? val) (language-id? (set!-transformer-procedure val))) - (raise-syntax-error id "expected a identifier defined by define-language" stx)) + (raise-syntax-error id "expected an identifier defined by define-language" stx)) (language-id-get (set!-transformer-procedure val) n))) (define (rewrite-side-conditions/check-errs all-nts what bind-names? orig-stx) diff --git a/collects/redex/tests/rg-test.rkt b/collects/redex/tests/rg-test.rkt index 50044f26ca..6b3c9e3d29 100644 --- a/collects/redex/tests/rg-test.rkt +++ b/collects/redex/tests/rg-test.rkt @@ -228,7 +228,7 @@ (test (with-handlers ([exn:fail:syntax? exn-message]) (parameterize ([current-namespace ns]) (expand #'(generate-term M n)))) - #rx"generate-term: expected a identifier defined by define-language( in: M)?$") + #rx"generate-term: expected an identifier defined by define-language( in: M)?$") (test-contract-violation/client (generate-term L n 1.5)) (test-contract-violation/client (generate-term L n 1 #:retries .5)) (test-contract-violation/client (generate-term L n 1 #:attempt-num .5)) diff --git a/collects/redex/tests/tl-test.rkt b/collects/redex/tests/tl-test.rkt index e327438f6b..9e69999e17 100644 --- a/collects/redex/tests/tl-test.rkt +++ b/collects/redex/tests/tl-test.rkt @@ -1027,6 +1027,11 @@ [(f x)]) #rx"expected a pattern and a right-hand side")) + (test-syn-err (define-metafunction (junk) also-junk) + #rx"expected an identifier") + (test-syn-err (define-metafunction junk also-junk) + #rx"expected an identifier") + ; ; ;