diff --git a/pkgs/redex-pkgs/redex-lib/redex/private/defined-checks.rkt b/pkgs/redex-pkgs/redex-lib/redex/private/defined-checks.rkt deleted file mode 100644 index 848da6a3cc..0000000000 --- a/pkgs/redex-pkgs/redex-lib/redex/private/defined-checks.rkt +++ /dev/null @@ -1,19 +0,0 @@ -#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 a067104907..a2aab86bbe 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 "judgment form" #:external #'form-name)) + (void #,(defined-check judgment-proc #: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 8b3cd3256f..db6c6d0267 100644 --- a/pkgs/redex-pkgs/redex-lib/redex/private/term-fn.rkt +++ b/pkgs/redex-pkgs/redex-lib/redex/private/term-fn.rkt @@ -1,6 +1,7 @@ #lang racket/base -(require (for-template racket/base "defined-checks.rkt")) +(require (for-template racket/base + racket/unsafe/undefined)) (provide make-term-fn term-fn? term-fn-get-id @@ -43,17 +44,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 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 (defined-check id #:external [external id]) + (quasisyntax/loc external + (check-not-unsafe-undefined #,id '#,external))) (define (not-expression-context stx) (when (eq? (syntax-local-context) 'expression) @@ -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-lib/redex/private/term.rkt b/pkgs/redex-pkgs/redex-lib/redex/private/term.rkt index 205292fd2f..51dc83874d 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 "term" #:external #'x) + #,(defined-check ref #:external #'x) #,ref)]) (values #`(undatum v) 0)))] [(unquote x) @@ -293,7 +293,7 @@ #`(begin #,@(free-identifier-mapping-map applied-mfs - (λ (f _) (defined-check f "metafunction"))) + (λ (f _) (defined-check f))) #,(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 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..2d417f97b5 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:[^\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:[^\n]*use[^\n]*before") ; ;