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

update Redex to cooperate with the new undefined semantics

Browse Source
This commit is contained in:
Robby Findler 2014-04-16 22:07:38 -05:00
parent 1cb1ff284b
commit 0372249eba
6 changed files with 56 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
pkgs/redex-pkgs/redex-lib/redex/private/defined-checks.rkt
View File

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

43
pkgs/redex-pkgs/redex-lib/redex/private/reduction-semantics.rkt
View File

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

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

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

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

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

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

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

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