diff --git a/collects/redex/private/error.rkt b/collects/redex/private/error.rkt index 8d9bfbb33c..6ba0d2dd5b 100644 --- a/collects/redex/private/error.rkt +++ b/collects/redex/private/error.rkt @@ -1,8 +1,12 @@ #lang scheme/base (define-struct (exn:fail:redex exn:fail) ()) (define (redex-error name fmt . args) - (let ([str (format "~a: ~a" name (apply format fmt args))]) - (raise (make-exn:fail:redex str (current-continuation-marks))))) + (define suffix (apply format fmt args)) + (define message + (if name + (format "~a: ~a" name suffix) + suffix)) + (raise (make-exn:fail:redex message (current-continuation-marks)))) (provide redex-error exn:fail:redex? (struct-out exn:fail:redex)) diff --git a/collects/redex/private/term.rkt b/collects/redex/private/term.rkt index 5bedbf8b27..748bfe1050 100644 --- a/collects/redex/private/term.rkt +++ b/collects/redex/private/term.rkt @@ -2,7 +2,9 @@ (require (for-syntax scheme/base "term-fn.ss" + syntax/boundmap racket/syntax) + "error.rkt" "matcher.ss") (provide term term-let term-let/error-name term-let-fn term-define-fn hole in-hole) @@ -15,13 +17,13 @@ [(_ () e) (syntax e)] [(_ (a b ...) e) (syntax (with-syntax (a) (with-syntax* (b ...) e)))])) -(define-syntax (term stx) - (syntax-case stx () - [(_ arg) - #`(term/private arg)])) +(define-syntax-rule (term t) + (#%expression (term/private t))) (define-syntax (term/private orig-stx) (define outer-bindings '()) + (define applied-metafunctions + (make-free-identifier-mapping)) (define (rewrite stx) (let-values ([(rewritten _) (rewrite/max-depth stx 0)]) @@ -54,9 +56,9 @@ [(metafunc-name arg ...) (and (identifier? (syntax metafunc-name)) (term-fn? (syntax-local-value (syntax metafunc-name) (λ () #f)))) - (rewrite-application (term-fn-get-id (syntax-local-value/record (syntax metafunc-name) (λ (x) #t))) - (syntax/loc stx (arg ...)) - depth)] + (let ([f (term-fn-get-id (syntax-local-value/record (syntax metafunc-name) (λ (x) #t)))]) + (free-identifier-mapping-put! applied-metafunctions f #t) + (rewrite-application f (syntax/loc stx (arg ...)) depth))] [f (and (identifier? (syntax f)) (term-fn? (syntax-local-value (syntax f) (λ () #f)))) @@ -110,13 +112,32 @@ [(_ arg) (with-disappeared-uses (with-syntax ([rewritten (rewrite (syntax arg))]) - (let loop ([bs (reverse outer-bindings)]) - (cond - [(null? bs) (syntax (syntax->datum (quasisyntax rewritten)))] - [else (with-syntax ([rec (loop (cdr bs))] - [fst (car bs)]) - (syntax (with-syntax (fst) - rec)))]))))])) + #`(begin + #,@(free-identifier-mapping-map + applied-metafunctions + (λ (f _) + (if (eq? (identifier-binding f) 'lexical) + #`(check-defined-lexical #,f '#,f) + #`(check-defined-module (λ () #,f) '#,f)))) + #,(let loop ([bs (reverse outer-bindings)]) + (cond + [(null? bs) (syntax (syntax->datum (quasisyntax rewritten)))] + [else (with-syntax ([rec (loop (cdr bs))] + [fst (car bs)]) + (syntax (with-syntax (fst) + rec)))])))))])) + +(define (check-defined-lexical value name) + (when (eq? (letrec ([x x]) x) value) + (report-undefined-metafunction name))) + +(define (check-defined-module thunk name) + (with-handlers ([exn:fail:contract:variable? + (λ (_) (report-undefined-metafunction name))]) + (thunk))) + +(define (report-undefined-metafunction name) + (redex-error #f "metafunction ~s applied before its definition" name)) (define-syntax (term-let-fn stx) (syntax-case stx () @@ -131,7 +152,7 @@ (define-syntax (term-define-fn stx) (syntax-case stx () [(_ id exp) - (with-syntax ([(id2) (generate-temporaries (syntax (id)))]) + (with-syntax ([id2 (datum->syntax #'here (syntax-e #'id))]) (syntax (begin (define id2 exp) diff --git a/collects/redex/tests/tl-test.rkt b/collects/redex/tests/tl-test.rkt index 708c0b628b..cff229504c 100644 --- a/collects/redex/tests/tl-test.rkt +++ b/collects/redex/tests/tl-test.rkt @@ -1,4 +1,4 @@ -#lang racket +#lang racket/gui (require "../reduction-semantics.ss" "test-util.ss" (only-in "../private/matcher.ss" make-bindings make-bind) @@ -7,6 +7,7 @@ (reset-count) + (define-namespace-anchor this-namespace) (parameterize ([current-namespace syn-err-test-namespace]) (eval (quote-syntax (define-language grammar @@ -994,6 +995,27 @@ x) '(2 1))) + ;; errors for not-yet-defined metafunctions + (test (parameterize ([current-namespace (make-empty-namespace)]) + (namespace-attach-module (namespace-anchor->namespace this-namespace) 'racket/gui) + (namespace-attach-module (namespace-anchor->namespace this-namespace) 'redex/reduction-semantics) + (namespace-require 'racket) + (eval '(module m racket + (require redex) + (term (q)) + (define-language L) + (define-metafunction L [(q) ()]))) + (with-handlers ([exn:fail:redex? exn-message]) + (eval '(require 'm)) + #f)) + "metafunction q applied before its definition") + (test (with-handlers ([exn:fail:redex? exn-message]) + (let () + (term (q)) + (define-language L) + (define-metafunction L [(q) ()]) + #f)) + "metafunction q applied before its definition") (let () (test-syn-err