From 0372249ebaa3c37323c7b83f9487ad5913057e4a Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 16 Apr 2014 22:07:38 -0500 Subject: [PATCH] update Redex to cooperate with the new undefined semantics --- .../redex/private/defined-checks.rkt | 6 ++- .../redex/private/reduction-semantics.rkt | 43 ++++++++++--------- .../redex-lib/redex/private/term-fn.rkt | 9 +++- .../redex/tests/defined-checks-test.rkt | 24 ----------- .../redex-test/redex/tests/run-tests.rkt | 37 ++++++++-------- .../redex-test/redex/tests/tl-test.rkt | 8 ++-- 6 files changed, 56 insertions(+), 71 deletions(-) delete mode 100644 pkgs/redex-pkgs/redex-test/redex/tests/defined-checks-test.rkt 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 848da6a3cc..d8044b2921 100644 --- a/pkgs/redex-pkgs/redex-lib/redex/private/defined-checks.rkt +++ b/pkgs/redex-pkgs/redex-lib/redex/private/defined-checks.rkt @@ -16,4 +16,8 @@ (thunk))) (define (report-undefined name desc) - (redex-error #f "reference to ~a ~s before its definition" desc name)) + (raise + (exn:fail:contract:variable + (format "~s: undefined;\n cannot use ~a before its definition" name desc) + (current-continuation-marks) + name))) diff --git a/pkgs/redex-pkgs/redex-lib/redex/private/reduction-semantics.rkt b/pkgs/redex-pkgs/redex-lib/redex/private/reduction-semantics.rkt index ae0f03034d..4d0db0c722 100644 --- a/pkgs/redex-pkgs/redex-lib/redex/private/reduction-semantics.rkt +++ b/pkgs/redex-pkgs/redex-lib/redex/private/reduction-semantics.rkt @@ -1197,26 +1197,29 @@ prev-metafunction)) (with-syntax ([(name2 name-predicate) (generate-temporaries (list name name))] [name name]) - (with-syntax ([defs #`(begin - (define-values (name2 name-predicate) - (generate-metafunction #,orig-stx - lang - #,prev-metafunction - name - name-predicate - #,dom-ctcs - #,codom-contracts - #,pats - #,syn-error-name)) - (term-define-fn name name2))]) - (if (eq? 'top-level (syntax-local-context)) - ; Introduce the names before using them, to allow - ; metafunction definition at the top-level. - (syntax - (begin - (define-syntaxes (name2 name-predicate) (values)) - defs)) - (syntax defs))))))])) + (with-syntax ([name2+prop (syntax-property #'name2 + 'undefined-error-name + (syntax-e #'name))]) + (with-syntax ([defs #`(begin + (define-values (name2+prop name-predicate) + (generate-metafunction #,orig-stx + lang + #,prev-metafunction + name + name-predicate + #,dom-ctcs + #,codom-contracts + #,pats + #,syn-error-name)) + (term-define-fn name name2))]) + (if (eq? 'top-level (syntax-local-context)) + ; Introduce the names before using them, to allow + ; metafunction definition at the top-level. + (syntax + (begin + (define-syntaxes (name2+prop name-predicate) (values)) + defs)) + (syntax defs)))))))])) (define-for-syntax (extract-clause-names stuffss) (for/list ([stuffs (in-list (syntax->list stuffss))]) 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 8b3cd3256f..1bf5ef294a 100644 --- a/pkgs/redex-pkgs/redex-lib/redex/private/term-fn.rkt +++ b/pkgs/redex-pkgs/redex-lib/redex/private/term-fn.rkt @@ -43,7 +43,8 @@ (cond [(syntax-local-value stx (λ () #f)) => p?] [else #f]))) -(define-struct judgment-form (name mode proc mk-proc lang lws rule-names gen-clauses mk-gen-clauses term-proc relation?) +(define-struct judgment-form (name mode proc mk-proc lang lws rule-names + gen-clauses mk-gen-clauses term-proc relation?) #:transparent) (define-struct defined-term (value)) @@ -76,7 +77,11 @@ (define pattern-symbols '(any number natural integer real string variable variable-not-otherwise-mentioned hole symbol)) -(define-values (struct:metafunc-proc make-metafunc-proc metafunc-proc? metafunc-proc-ref metafunc-proc-set!) +(define-values (struct:metafunc-proc + make-metafunc-proc + metafunc-proc? + metafunc-proc-ref + metafunc-proc-set!) (make-struct-type 'metafunc-proc #f 10 0 #f null (current-inspector) 0)) (define metafunc-proc-clause-names (make-struct-field-accessor metafunc-proc-ref 1)) (define metafunc-proc-pict-info (make-struct-field-accessor metafunc-proc-ref 2)) diff --git a/pkgs/redex-pkgs/redex-test/redex/tests/defined-checks-test.rkt b/pkgs/redex-pkgs/redex-test/redex/tests/defined-checks-test.rkt deleted file mode 100644 index 29191fc20a..0000000000 --- a/pkgs/redex-pkgs/redex-test/redex/tests/defined-checks-test.rkt +++ /dev/null @@ -1,24 +0,0 @@ -#lang racket - -(require "test-util.rkt" - redex/private/error - redex/private/defined-checks) - -(reset-count) - -(define expected-message "reference to thing x before its definition") - -(test (with-handlers ([exn:fail:redex? exn-message]) - (check-defined-lexical x 'x "thing") - (define x 4) - "") - expected-message) - -(test (with-handlers ([exn:fail:redex? exn-message]) - (check-defined-module (λ () x) 'x "thing") - "") - expected-message) - -(define x 4) - -(print-tests-passed 'defined-checks-test.rkt) diff --git a/pkgs/redex-pkgs/redex-test/redex/tests/run-tests.rkt b/pkgs/redex-pkgs/redex-test/redex/tests/run-tests.rkt index eefba86155..b964573572 100644 --- a/pkgs/redex-pkgs/redex-test/redex/tests/run-tests.rkt +++ b/pkgs/redex-pkgs/redex-test/redex/tests/run-tests.rkt @@ -33,7 +33,6 @@ "pict-test.rkt" "hole-test.rkt" "stepper-test.rkt" - "defined-checks-test.rkt" "check-syntax-test.rkt" "test-docs-complete.rkt" "tut-subst-test.rkt" @@ -58,28 +57,27 @@ (define (flush) ;; these flushes are here for running under cygwin, - ;; which somehow makes mzscheme think it isn't using + ;; which somehow makes racket think it isn't using ;; an interative port (flush-output (current-error-port)) (flush-output (current-output-port))) -(for-each - (λ (test-file) - (let-values ([(file provided action) - (match test-file - [(list (? string? file) id) - (values file id (λ (x) (x)))] - [(? string?) - (values test-file #f values)])]) - (flush) - (printf "running ~a\n" file) - (flush) - (define path (if (regexp-match #rx"" file) - (build-path examples-path (cadr (regexp-match #rx"^/(.*)$" file))) - (build-path here file))) - (action (dynamic-require path provided)) - (flush))) - test-files) +(for ([test-file (in-list test-files)]) + (define-values (file provided action) + (match test-file + [(list (? string? file) id) + (values file id (λ (x) (x)))] + [(? string?) + (values test-file #f values)])) + (flush) + (printf "running ~a\n" file) + (flush) + (define path + (if (regexp-match #rx"" file) + (build-path examples-path (cadr (regexp-match #rx"^/(.*)$" file))) + (build-path here file))) + (action (dynamic-require path provided)) + (flush)) (printf "\nWARNING: didn't run color-test.rkt\n") (flush) @@ -91,4 +89,3 @@ (parameterize ([current-command-line-arguments (vector "--examples" "--no-bitmap-gui")]) (dynamic-require (quote-module-path "..") #f))) - diff --git a/pkgs/redex-pkgs/redex-test/redex/tests/tl-test.rkt b/pkgs/redex-pkgs/redex-test/redex/tests/tl-test.rkt index 8aaa5913bf..1f9ce9c62d 100644 --- a/pkgs/redex-pkgs/redex-test/redex/tests/tl-test.rkt +++ b/pkgs/redex-pkgs/redex-test/redex/tests/tl-test.rkt @@ -1217,17 +1217,17 @@ (term (q)) (define-language L) (define-metafunction L [(q) ()]))) - (with-handlers ([exn:fail:redex? exn-message]) + (with-handlers ([exn:fail:contract:variable? exn-message]) (eval '(require 'm)) #f))) - "reference to metafunction q before its definition") - (test (with-handlers ([exn:fail:redex? exn-message]) + #rx"^q: undefined;\n[^\n]*use[^\n]*before") + (test (with-handlers ([exn:fail:contract:variable? exn-message]) (let () (term (q)) (define-language L) (define-metafunction L [(q) ()]) #f)) - "reference to metafunction q before its definition") + #rx"^q: undefined;\n[^\n]*use[^\n]*before") ; ;