suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

accidentally pushed a commit I didn't intend to

Browse Source 
Revert "IN PROGRESS: started on redex undefined check update"

This reverts commit 3859a6f69e.
This commit is contained in:
Robby Findler 2014-04-16 22:07:01 -05:00
parent 3859a6f69e
commit b08a831fc9
7 changed files with 77 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
pkgs/redex-pkgs/redex-lib/redex/private/defined-checks.rkt Normal file
View File

@ -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))

2
pkgs/redex-pkgs/redex-lib/redex/private/judgment-form.rkt
View File

@ -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

19
pkgs/redex-pkgs/redex-lib/redex/private/term-fn.rkt
View File

@ -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))

4
pkgs/redex-pkgs/redex-lib/redex/private/term.rkt
View File

@ -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)]

24
pkgs/redex-pkgs/redex-test/redex/tests/defined-checks-test.rkt Normal file
View File

@ -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)

37
pkgs/redex-pkgs/redex-test/redex/tests/run-tests.rkt
View File

@ -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"<redex-examples>" file)
(build-path examples-path (cadr (regexp-match #rx"^<redex-examples>/(.*)$" 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"<redex-examples>" file)
(build-path examples-path (cadr (regexp-match #rx"^<redex-examples>/(.*)$" 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)))

8
pkgs/redex-pkgs/redex-test/redex/tests/tl-test.rkt
View File

@ -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")
;
;