From 28e9bdcbabcc7a32cd183071e1535c5c90e59095 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 22 Apr 2014 22:14:27 -0500 Subject: [PATCH] more fixing redex / undefined interactions --- .../redex/private/defined-checks.rkt | 11 ++------ .../redex-lib/redex/private/judgment-form.rkt | 28 +++++++++++-------- .../redex-lib/redex/private/term-fn.rkt | 4 +-- .../redex-lib/redex/private/term.rkt | 9 ++++-- .../judgment-form-undefined.rktd | 2 +- .../redex/tests/run-err-tests/term.rktd | 2 +- 6 files changed, 28 insertions(+), 28 deletions(-) diff --git a/pkgs/redex-pkgs/redex-lib/redex/private/defined-checks.rkt b/pkgs/redex-pkgs/redex-lib/redex/private/defined-checks.rkt index d8044b2921..f66e5e0dcb 100644 --- a/pkgs/redex-pkgs/redex-lib/redex/private/defined-checks.rkt +++ b/pkgs/redex-pkgs/redex-lib/redex/private/defined-checks.rkt @@ -1,14 +1,7 @@ #lang racket/base -(require "error.rkt" - racket/undefined) -(provide check-defined-lexical - check-defined-module) - -(define (check-defined-lexical value name desc) - ;; Needed? - (when (eq? undefined value) - (report-undefined name desc))) +(require "error.rkt") +(provide check-defined-module) (define (check-defined-module thunk name desc) (with-handlers ([exn:fail:contract:variable? diff --git a/pkgs/redex-pkgs/redex-lib/redex/private/judgment-form.rkt b/pkgs/redex-pkgs/redex-lib/redex/private/judgment-form.rkt index a067104907..72c9c4ac63 100644 --- a/pkgs/redex-pkgs/redex-lib/redex/private/judgment-form.rkt +++ b/pkgs/redex-pkgs/redex-lib/redex/private/judgment-form.rkt @@ -528,18 +528,22 @@ (define-values (judgment-form-name dup-form-names mode position-contracts clauses rule-names) (parse-judgment-form-body body syn-err-name stx (identifier? orig) is-relation?)) (define definitions - #`(begin - (define-syntax #,judgment-form-name - (judgment-form '#,judgment-form-name '#,(cdr (syntax->datum mode)) #'judgment-form-runtime-proc - #'mk-judgment-form-proc #'#,lang #'jf-lws - '#,rule-names #'judgment-runtime-gen-clauses #'mk-judgment-gen-clauses #'jf-term-proc #,is-relation?)) - (define-values (mk-judgment-form-proc mk-judgment-gen-clauses) - (compile-judgment-form #,judgment-form-name #,mode #,lang #,clauses #,rule-names #,position-contracts - #,orig #,stx #,syn-err-name judgment-runtime-gen-clauses)) - (define judgment-form-runtime-proc (mk-judgment-form-proc #,lang)) - (define jf-lws (compiled-judgment-form-lws #,clauses #,judgment-form-name #,stx)) - (define judgment-runtime-gen-clauses (mk-judgment-gen-clauses #,lang (λ () (judgment-runtime-gen-clauses)))) - (define jf-term-proc (make-jf-term-proc #,judgment-form-name #,syn-err-name #,lang #,nts #,mode)))) + (with-syntax ([judgment-form-runtime-proc + (syntax-property (syntax/loc judgment-form-name judgment-form-runtime-proc) + 'undefined-error-name + (syntax-e judgment-form-name))]) + #`(begin + (define-syntax #,judgment-form-name + (judgment-form '#,judgment-form-name '#,(cdr (syntax->datum mode)) #'judgment-form-runtime-proc + #'mk-judgment-form-proc #'#,lang #'jf-lws + '#,rule-names #'judgment-runtime-gen-clauses #'mk-judgment-gen-clauses #'jf-term-proc #,is-relation?)) + (define-values (mk-judgment-form-proc mk-judgment-gen-clauses) + (compile-judgment-form #,judgment-form-name #,mode #,lang #,clauses #,rule-names #,position-contracts + #,orig #,stx #,syn-err-name judgment-runtime-gen-clauses)) + (define judgment-form-runtime-proc (mk-judgment-form-proc #,lang)) + (define jf-lws (compiled-judgment-form-lws #,clauses #,judgment-form-name #,stx)) + (define judgment-runtime-gen-clauses (mk-judgment-gen-clauses #,lang (λ () (judgment-runtime-gen-clauses)))) + (define jf-term-proc (make-jf-term-proc #,judgment-form-name #,syn-err-name #,lang #,nts #,mode))))) (syntax-property (values ;prune-syntax (if (eq? 'top-level (syntax-local-context)) diff --git a/pkgs/redex-pkgs/redex-lib/redex/private/term-fn.rkt b/pkgs/redex-pkgs/redex-lib/redex/private/term-fn.rkt index 1bf5ef294a..87c12cf2cf 100644 --- a/pkgs/redex-pkgs/redex-lib/redex/private/term-fn.rkt +++ b/pkgs/redex-pkgs/redex-lib/redex/private/term-fn.rkt @@ -52,8 +52,8 @@ (transformer-predicate defined-term? stx)) (define (defined-check id desc #:external [external id]) - (if (eq? (identifier-binding id) 'lexical) - (quasisyntax/loc external (check-defined-lexical #,id '#,external #,desc)) + (if (equal? (identifier-binding id) 'lexical) + (datum->syntax id (syntax-e id) external id) (quasisyntax/loc external (check-defined-module (λ () #,id) '#,external #,desc)))) (define (not-expression-context stx) diff --git a/pkgs/redex-pkgs/redex-lib/redex/private/term.rkt b/pkgs/redex-pkgs/redex-lib/redex/private/term.rkt index 205292fd2f..278d23a14f 100644 --- a/pkgs/redex-pkgs/redex-lib/redex/private/term.rkt +++ b/pkgs/redex-pkgs/redex-lib/redex/private/term.rkt @@ -467,6 +467,9 @@ (syntax-parse stx [(_ x:id t:expr) (not-expression-context stx) - #'(begin - (define term-val (term t)) - (define-syntax x (defined-term #'term-val)))])) + (with-syntax ([term-val (syntax-property (syntax/loc #'x term-val) + 'undefined-error-name + (syntax-e #'x))]) + #'(begin + (define term-val (term t)) + (define-syntax x (defined-term #'term-val))))])) diff --git a/pkgs/redex-pkgs/redex-test/redex/tests/run-err-tests/judgment-form-undefined.rktd b/pkgs/redex-pkgs/redex-test/redex/tests/run-err-tests/judgment-form-undefined.rktd index 35beaed38f..cb26621a4e 100644 --- a/pkgs/redex-pkgs/redex-test/redex/tests/run-err-tests/judgment-form-undefined.rktd +++ b/pkgs/redex-pkgs/redex-test/redex/tests/run-err-tests/judgment-form-undefined.rktd @@ -1,4 +1,4 @@ -("reference to judgment form q before its definition" +("q: undefined;\n cannot use before initialization" ([use q]) ([def q]) (let () (judgment-holds (use 1)) diff --git a/pkgs/redex-pkgs/redex-test/redex/tests/run-err-tests/term.rktd b/pkgs/redex-pkgs/redex-test/redex/tests/run-err-tests/term.rktd index 71d7052667..1f0933cb46 100644 --- a/pkgs/redex-pkgs/redex-test/redex/tests/run-err-tests/term.rktd +++ b/pkgs/redex-pkgs/redex-test/redex/tests/run-err-tests/term.rktd @@ -41,7 +41,7 @@ ([rhs 'a]) ([ellipsis ...]) (term-let ([(x ellipsis) rhs]) 3)) -("reference to term x before its definition" +("x: undefined;\n cannot use before initialization" ([use x]) ([def x]) (let () (define t (term (use y)))