From b08a831fc94d9f70a904580e9732485ede807031 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 16 Apr 2014 22:07:01 -0500 Subject: [PATCH] accidentally pushed a commit I didn't intend to Revert "IN PROGRESS: started on redex undefined check update" This reverts commit 3859a6f69e98bc0ebeb1a83be49a4903989b84f4. --- .../redex/private/defined-checks.rkt | 19 ++++++++++ .../redex-lib/redex/private/judgment-form.rkt | 2 +- .../redex-lib/redex/private/term-fn.rkt | 19 ++++------ .../redex-lib/redex/private/term.rkt | 4 +- .../redex/tests/defined-checks-test.rkt | 24 ++++++++++++ .../redex-test/redex/tests/run-tests.rkt | 37 ++++++++++--------- .../redex-test/redex/tests/tl-test.rkt | 8 ++-- 7 files changed, 77 insertions(+), 36 deletions(-) create mode 100644 pkgs/redex-pkgs/redex-lib/redex/private/defined-checks.rkt create 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 new file mode 100644 index 0000000000..848da6a3cc --- /dev/null +++ b/pkgs/redex-pkgs/redex-lib/redex/private/defined-checks.rkt @@ -0,0 +1,19 @@ +#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))) + +(define (check-defined-module thunk name desc) + (with-handlers ([exn:fail:contract:variable? + (λ (_) (report-undefined name desc))]) + (thunk))) + +(define (report-undefined name desc) + (redex-error #f "reference to ~a ~s before its definition" desc name)) 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 a2aab86bbe..a067104907 100644 --- a/pkgs/redex-pkgs/redex-lib/redex/private/judgment-form.rkt +++ b/pkgs/redex-pkgs/redex-lib/redex/private/judgment-form.rkt @@ -231,7 +231,7 @@ [(binding-constraint ...) binding-constraints]) #`(begin #,syncheck-exp - (void #,(defined-check judgment-proc #:external #'form-name)) + (void #,(defined-check judgment-proc "judgment form" #:external #'form-name)) (judgment-form-bind-withs/proc #,rt-lang `#,output-pattern 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 db6c6d0267..8b3cd3256f 100644 --- a/pkgs/redex-pkgs/redex-lib/redex/private/term-fn.rkt +++ b/pkgs/redex-pkgs/redex-lib/redex/private/term-fn.rkt @@ -1,7 +1,6 @@ #lang racket/base -(require (for-template racket/base - racket/unsafe/undefined)) +(require (for-template racket/base "defined-checks.rkt")) (provide make-term-fn term-fn? term-fn-get-id @@ -44,17 +43,17 @@ (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)) (define (defined-term-id? stx) (transformer-predicate defined-term? stx)) -(define (defined-check id #:external [external id]) - (quasisyntax/loc external - (check-not-unsafe-undefined #,id '#,external))) +(define (defined-check id desc #:external [external id]) + (if (eq? (identifier-binding id) 'lexical) + (quasisyntax/loc external (check-defined-lexical #,id '#,external #,desc)) + (quasisyntax/loc external (check-defined-module (λ () #,id) '#,external #,desc)))) (define (not-expression-context stx) (when (eq? (syntax-local-context) 'expression) @@ -77,11 +76,7 @@ (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-lib/redex/private/term.rkt b/pkgs/redex-pkgs/redex-lib/redex/private/term.rkt index 51dc83874d..205292fd2f 100644 --- a/pkgs/redex-pkgs/redex-lib/redex/private/term.rkt +++ b/pkgs/redex-pkgs/redex-lib/redex/private/term.rkt @@ -210,7 +210,7 @@ (syntax-local-introduce #'x))]) (check-id (syntax->datum #'x) stx ellipsis-allowed?) (with-syntax ([v #`(begin - #,(defined-check ref #:external #'x) + #,(defined-check ref "term" #:external #'x) #,ref)]) (values #`(undatum v) 0)))] [(unquote x) @@ -293,7 +293,7 @@ #`(begin #,@(free-identifier-mapping-map applied-mfs - (λ (f _) (defined-check f))) + (λ (f _) (defined-check f "metafunction"))) #,(let loop ([bs outer-bindings]) (cond [(null? bs) (syntax t)] 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 new file mode 100644 index 0000000000..29191fc20a --- /dev/null +++ b/pkgs/redex-pkgs/redex-test/redex/tests/defined-checks-test.rkt @@ -0,0 +1,24 @@ +#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 b964573572..eefba86155 100644 --- a/pkgs/redex-pkgs/redex-test/redex/tests/run-tests.rkt +++ b/pkgs/redex-pkgs/redex-test/redex/tests/run-tests.rkt @@ -33,6 +33,7 @@ "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" @@ -57,27 +58,28 @@ (define (flush) ;; these flushes are here for running under cygwin, - ;; which somehow makes racket think it isn't using + ;; which somehow makes mzscheme think it isn't using ;; an interative port (flush-output (current-error-port)) (flush-output (current-output-port))) -(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)) +(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) (printf "\nWARNING: didn't run color-test.rkt\n") (flush) @@ -89,3 +91,4 @@ (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 2d417f97b5..8aaa5913bf 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:contract:variable? exn-message]) + (with-handlers ([exn:fail:redex? exn-message]) (eval '(require 'm)) #f))) - #rx"^q:[^\n]*use[^\n]*before") - (test (with-handlers ([exn:fail:contract:variable? exn-message]) + "reference to metafunction q before its definition") + (test (with-handlers ([exn:fail:redex? exn-message]) (let () (term (q)) (define-language L) (define-metafunction L [(q) ()]) #f)) - #rx"^q:[^\n]*use[^\n]*before") + "reference to metafunction q before its definition") ; ;