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

macro stepper:

Browse Source 
better module hiding
  display prefab structs
  updated tests

svn: r14085
This commit is contained in:
Ryan Culpepper 2009-03-13 05:54:17 +00:00
parent 533c8dfd8b
commit e11a24fda8
7 changed files with 183 additions and 142 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/macro-debugger/model/reductions.ss
View File

@ -3,7 +3,6 @@
(require scheme/match
"stx-util.ss"
"deriv-util.ss"
"context.ss"
"deriv.ss"
"reductions-engine.ss")
@ -61,7 +60,7 @@
[#:when (not (bound-identifier=? e1 e2))
[#:walk e2 'resolve-variable]])]
[(Wrap p:module (e1 e2 rs ?1 ?2 tag rename check tag2 ?3 body shift))
(R ;; [#:hide-check rs] ;; FIXME: test and enable!!!
(R [#:hide-check rs]
[! ?1]
[#:pattern (?module ?name ?language . ?body-parts)]
[! ?2]

15
collects/macro-debugger/syntax-browser/pretty-helper.ss
View File

@ -89,6 +89,13 @@
lp-datum)]
[(pair? obj)
(pairloop obj)]
[(struct? obj)
;; Only traverse prefab structs
(let ([pkey (prefab-struct-key obj)])
(if pkey
(let-values ([(refold fields) (unfold-pstruct obj)])
(refold (map loop fields)))
obj))]
[(symbol? obj)
(unintern obj)]
[(null? obj)
@ -117,6 +124,14 @@
flat=>stx
stx=>flat))))
;; unfold-pstruct : prefab-struct -> (values (list -> prefab-struct) list)
(define (unfold-pstruct obj)
(define key (prefab-struct-key obj))
(define fields (cdr (vector->list (struct->vector obj))))
(values (lambda (new-fields)
(apply make-prefab-struct key new-fields))
fields))
;; check+convert-special-expression : syntax -> #f/syntaxish
(define (check+convert-special-expression stx)
(define stx-list (stx->list stx))

2
collects/macro-debugger/syntax-browser/pretty-printer.ss
View File

@ -56,7 +56,7 @@
;; Printing parameters (mzscheme manual 7.9.1.4)
[print-unreadable #t]
[print-graph #f]
[print-struct #f]
[print-struct #t]
[print-box #t]
[print-vector-length #t]
[print-hash-table #f]

6
collects/tests/macro-debugger/gentests.ss
View File

@ -57,7 +57,7 @@
[expect-ok? (cdr key+expect-ok?)])
(check-hide d hide-none-policy expect-ok?)
(check-hide d hide-all-policy expect-ok?)
(check-hide d simple-policy expect-ok?))))]
(check-hide d T-policy expect-ok?))))]
[else #f]))
(define (check-hide d policy expect-ok?)
@ -86,14 +86,14 @@
(error 'checker-for-hidden-steps "no steps given for ~s" label))
(test-case label
(let* ([d (trace/ns form (assq '#:kernel attrs))]
[rs (parameterize ((macro-policy simple-policy))
[rs (parameterize ((macro-policy T-policy))
(reductions d))])
(check-steps (cdr (assq '#:steps attrs)) rs)))]
[(assq '#:hidden-steps attrs)
=> (lambda (key+expected)
(test-case label
(let* ([d (trace/ns form (assq '#:kernel attrs))]
[rs (parameterize ((macro-policy simple-policy))
[rs (parameterize ((macro-policy T-policy))
(reductions d))])
(check-steps (cdr (assq '#:hidden-steps attrs)) rs))))]
[else #f]))

38
collects/tests/macro-debugger/test-setup.ss
View File

@ -8,12 +8,15 @@
trace/k
hide-all-policy
hide-none-policy
simple-policy
T-policy
Tm-policy
stx/hide-none
stx/hide-all
stx/hide-standard
stx/hide-simple)
stx/hide-T
stx/hide-Tm)
(define (trace/t expr)
(trace/ns expr #f))
@ -133,22 +136,25 @@
(stx/hide-policy d hide-none-policy))
(define (stx/hide-all d)
(stx/hide-policy d hide-all-policy))
(define (stx/hide-simple d)
(stx/hide-policy d simple-policy))
(define (stx/hide-standard d)
(stx/hide-policy d standard-policy))
#|
(define (hide/standard d) (hide/policy d standard-policy))
(define (hide/all d) (hide/policy d hide-all-policy))
(define (hide/null d) (hide/policy d hide-none-policy))
(define (hide/except d syms)
(hide/policy d (lambda (id) (memq (syntax-e id) syms))))
(define (hide/simple d) (hide/policy d simple-policy))
|#
;; Simple hiding policy
;; ALL MACROS & primitive tags are hidden
;; EXCEPT Tlist and Tlet (and #%module-begin)
(define (simple-policy id)
(define (stx/hide-T d)
(stx/hide-policy d T-policy))
(define (stx/hide-Tm d)
(stx/hide-policy d Tm-policy))
;; T hiding policy
;; ALL macros & primitives are hidden
;; EXCEPT those starting with T (Tlist and Tlet)
(define (T-policy id)
(or (memq (syntax-e id) '())
(regexp-match #rx"^T" (symbol->string (syntax-e id)))))
;; Tm hiding policy
;; ALL MACROS & primitive tags are hidden
;; EXCEPT those starting with T (Tlist and Tlet)
;; EXCEPT module (=> #%module-begin gets tagged)
(define (Tm-policy id)
(or (memq (syntax-e id) '(module))
(regexp-match #rx"^T" (symbol->string (syntax-e id)))))

211
collects/tests/macro-debugger/tests/hiding.ss
View File

@ -1,7 +1,6 @@
#lang scheme/base
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2 8))
(planet "graphical-ui.ss" ("schematics" "schemeunit.plt" 2 8))
macro-debugger/model/debug
"../test-setup.ss")
(provide specialized-hiding-tests)
@ -27,16 +26,19 @@
[(tthi form)
(test-trivial-hiding form form)]))
(define-syntax test-simple-hiding
(syntax-rules ()
[(tsh form hidden-e2)
(test-hiding/policy form hidden-e2 simple-policy)]))
(define-syntax test-simple-hiding/id
(syntax-rules ()
[(tshi form) (test-simple-hiding form form)]))
(define-syntax-rule (test-T-hiding form hidden-e2)
(test-hiding/policy form hidden-e2 T-policy))
(define-syntax-rule (test-T-hiding/id form)
(test-T-hiding form form))
(define-syntax-rule (test-Tm-hiding form hidden-e2)
(test-hiding/policy form hidden-e2 Tm-policy))
(define-syntax-rule (test-Tm-hiding/id form)
(test-Tm-hiding form form))
(define specialized-hiding-tests
(test-suite "Specialized macro hiding tests"
(test-suite "Result tests for trivial hiding"
(test-suite "Atomic expressions"
(test-trivial-hiding/id *)
@ -74,7 +76,7 @@
(lambda (x y) x y))
(test-trivial-hiding (lambda (x) (define-values (y) (id x)) y)
(lambda (x) (letrec-values ([(y) x]) y))))
#;
#|
;; Old hiding mechanism never did letrec transformation (unless forced)
(test-suite "Block normalization"
(test-trivial-hiding/id (lambda (x y) x y))
@ -88,94 +90,119 @@
(test-trivial-hiding (lambda (x) (id (begin (define-values (y) x) x)))
(lambda (x) (begin (define-values (y) x) x)))
(test-trivial-hiding (lambda (x) (define-values (y) (id x)) y)
(lambda (x) (define-values (y) x) y))))
(test-suite "Result tests for simple hiding"
(lambda (x) (define-values (y) x) y)))
|#
)
(test-suite "Result tests for T hiding"
(test-suite "Atomic expressions"
(test-simple-hiding/id *)
(test-simple-hiding/id 1)
(test-simple-hiding/id unbound-var))
(test-T-hiding/id *)
(test-T-hiding/id 1)
(test-T-hiding/id unbound-var))
(test-suite "Basic expressions"
(test-simple-hiding/id (if 1 2 3))
(test-simple-hiding/id (with-continuation-mark 1 2 3))
(test-simple-hiding/id (define-values (x) 1))
(test-simple-hiding/id (define-syntaxes (x) 1)))
(test-T-hiding/id (if 1 2 3))
(test-T-hiding/id (with-continuation-mark 1 2 3))
(test-T-hiding/id (define-values (x) 1))
(test-T-hiding/id (define-syntaxes (x) 1)))
(test-suite "Opaque macros"
(test-simple-hiding/id (id '1))
(test-simple-hiding/id (id 1))
(test-simple-hiding/id (id (id '1)))
(test-T-hiding/id (id '1))
(test-T-hiding/id (id 1))
(test-T-hiding/id (id (id '1)))
;; app is hidden:
(test-simple-hiding/id (+ '1 '2)))
(test-T-hiding/id (+ '1 '2)))
(test-suite "Transparent macros"
(test-simple-hiding (Tlist x)
(list x))
(test-simple-hiding (Tid x) x)
(test-simple-hiding (Tlist (id x))
(list (id x)))
(test-simple-hiding (Tid (id x))
(id x))
(test-simple-hiding (id (Tlist x))
(id (list x)))
(test-simple-hiding (id (Tid x))
(id x)))
(test-T-hiding (Tlist x)
(list x))
(test-T-hiding (Tid x) x)
(test-T-hiding (Tlist (id x))
(list (id x)))
(test-T-hiding (Tid (id x))
(id x))
(test-T-hiding (id (Tlist x))
(id (list x)))
(test-T-hiding (id (Tid x))
(id x)))
(test-suite "Blocks"
(test-simple-hiding/id (lambda (x y) x y))
(test-simple-hiding (lambda (x y z) (begin x y) z)
(lambda (x y z) x y z))
(test-simple-hiding/id (lambda (x y z) x (begin y z))) ;; expression begin!
(test-simple-hiding (lambda (x) (define-values (y) x) y)
(lambda (x) (letrec-values ([(y) x]) y)))
(test-simple-hiding (lambda (x) (begin (define-values (y) x)) y)
(lambda (x) (letrec-values ([(y) x]) y)))
(test-simple-hiding (lambda (x) (begin (define-values (y) x) y) x)
(lambda (x) (letrec-values ([(y) x]) y x)))
(test-simple-hiding (lambda (x) (id x))
(lambda (x) (id x)))
(test-simple-hiding (lambda (x) (Tid x))
(lambda (x) x))
(test-simple-hiding/id (lambda (x) (id (define-values (y) x)) x))
(test-simple-hiding (lambda (x) (id (define-values (y) x)) (Tid x))
(lambda (x) (id (define-values (y) x)) x))
(test-simple-hiding/id (lambda (x) (id (begin (define-values (y) x) x))))
(test-simple-hiding (lambda (x) (begin (id (define-values (y) x)) y))
(lambda (x) (id (define-values (y) x)) y))
(test-simple-hiding (lambda (x) (id (begin (Tid (define-values (y) x)))) (Tid y))
(lambda (x) (id (begin (define-values (y) x))) y))
(test-simple-hiding (lambda (x) (id (begin (Tid (define-values (y) x)))) x (Tid y))
(lambda (x) (id (begin (define-values (y) x))) x y))
(test-simple-hiding (lambda (x) (define-values (y) (id x)) y)
(lambda (x) (letrec-values ([(y) (id x)]) y)))
(test-simple-hiding (lambda (x y) x (id y))
(lambda (x y) x (id y)))
(test-simple-hiding (lambda (x y) x (Tid y))
(lambda (x y) x y))
(test-simple-hiding (lambda (x) (id (define-values (y) x)) x (Tid y))
(lambda (x) (id (define-values (y) x)) x y))
(test-simple-hiding/id (lambda (x) (id (define-values (y) (id x))) y))
(test-simple-hiding (lambda (x) (id (define-values (y) (Tid x))) y)
(lambda (x) (id (define-values (y) x)) y)))
(test-T-hiding/id (lambda (x y) x y))
(test-T-hiding (lambda (x y z) (begin x y) z)
(lambda (x y z) x y z))
(test-T-hiding/id (lambda (x y z) x (begin y z))) ;; expression begin!
(test-T-hiding (lambda (x) (define-values (y) x) y)
(lambda (x) (letrec-values ([(y) x]) y)))
(test-T-hiding (lambda (x) (begin (define-values (y) x)) y)
(lambda (x) (letrec-values ([(y) x]) y)))
(test-T-hiding (lambda (x) (begin (define-values (y) x) y) x)
(lambda (x) (letrec-values ([(y) x]) y x)))
(test-T-hiding (lambda (x) (id x))
(lambda (x) (id x)))
(test-T-hiding (lambda (x) (Tid x))
(lambda (x) x))
(test-T-hiding/id (lambda (x) (id (define-values (y) x)) x))
(test-T-hiding (lambda (x) (id (define-values (y) x)) (Tid x))
(lambda (x) (id (define-values (y) x)) x))
(test-T-hiding/id (lambda (x) (id (begin (define-values (y) x) x))))
(test-T-hiding (lambda (x) (begin (id (define-values (y) x)) y))
(lambda (x) (id (define-values (y) x)) y))
(test-T-hiding (lambda (x) (id (begin (Tid (define-values (y) x)))) (Tid y))
(lambda (x) (id (begin (define-values (y) x))) y))
(test-T-hiding (lambda (x) (id (begin (Tid (define-values (y) x)))) x (Tid y))
(lambda (x) (id (begin (define-values (y) x))) x y))
(test-T-hiding (lambda (x) (define-values (y) (id x)) y)
(lambda (x) (letrec-values ([(y) (id x)]) y)))
(test-T-hiding (lambda (x y) x (id y))
(lambda (x y) x (id y)))
(test-T-hiding (lambda (x y) x (Tid y))
(lambda (x y) x y))
(test-T-hiding (lambda (x) (id (define-values (y) x)) x (Tid y))
(lambda (x) (id (define-values (y) x)) x y))
(test-T-hiding/id (lambda (x) (id (define-values (y) (id x))) y))
(test-T-hiding (lambda (x) (id (define-values (y) (Tid x))) y)
(lambda (x) (id (define-values (y) x)) y)))
(test-suite "Binding expressions"
(test-simple-hiding/id (lambda (x) x))
(test-simple-hiding/id (lambda (x) (id x))))
(test-T-hiding/id (lambda (x) x))
(test-T-hiding/id (lambda (x) (id x))))
(test-suite "Module declarations"
(test-simple-hiding (module m mzscheme
(require 'helper)
(define x 1))
(module m mzscheme
(#%module-begin
(require 'helper)
(define x 1))))
(test-simple-hiding (module m mzscheme
(require 'helper)
(define x (Tlist 1)))
(module m mzscheme
(#%module-begin
(require 'helper)
(define x (list 1)))))
(test-simple-hiding (module m mzscheme
(#%plain-module-begin
(require 'helper)
(define x (Tlist 1))))
(module m mzscheme
(#%plain-module-begin
(require 'helper)
(define x (list 1)))))))))
(test-T-hiding (module m mzscheme
(require 'helper)
(define x 1))
(module m mzscheme
(require 'helper)
(define x 1)))
(test-Tm-hiding (module m mzscheme
(require 'helper)
(define x 1))
(module m mzscheme
(#%module-begin
(require 'helper)
(define x 1))))
(test-T-hiding (module m mzscheme
(require 'helper)
(define x (Tlist 1)))
(module m mzscheme
(require 'helper)
(define x (list 1))))
(test-Tm-hiding (module m mzscheme
(require 'helper)
(define x (Tlist 1)))
(module m mzscheme
(#%module-begin
(require 'helper)
(define x (list 1)))))
(test-T-hiding (module m mzscheme
(#%plain-module-begin
(require 'helper)
(define x (Tlist 1))))
(module m mzscheme
(#%plain-module-begin
(require 'helper)
(define x (list 1)))))
(test-Tm-hiding (module m mzscheme
(#%plain-module-begin
(require 'helper)
(define x (Tlist 1))))
(module m mzscheme
(#%plain-module-begin
(require 'helper)
(define x (list 1)))))))))

48
collects/tests/macro-debugger/tests/syntax-modules.ss
View File

@ -18,7 +18,7 @@
[#:steps
(tag-module-begin
(module m '#%kernel (#%module-begin (define-values (x) 'a))))]
#:same-hidden-steps)
#:no-hidden-steps)
(test "module, MB, def, use"
(module m '#%kernel (#%module-begin (define-values (x) 'a) x))
#:no-steps
@ -28,7 +28,7 @@
[#:steps
(tag-module-begin
(module m '#%kernel (#%module-begin (define-values (x) 'a) x)))]
#:same-hidden-steps)
#:no-hidden-steps)
(test "module, MB, quote"
(module m '#%kernel (#%module-begin 'a))
#:no-steps
@ -37,12 +37,12 @@
(module m '#%kernel 'a)
[#:steps
(tag-module-begin (module m '#%kernel (#%module-begin 'a)))]
#:same-hidden-steps)
#:no-hidden-steps)
(test "module, 2 quotes"
(module m '#%kernel 'a 'b)
[#:steps
(tag-module-begin (module m '#%kernel (#%module-begin 'a 'b)))]
#:same-hidden-steps)
#:no-hidden-steps)
(test "module, MB, begin"
(module m '#%kernel (#%module-begin (begin 'a 'b)))
[#:steps
@ -53,7 +53,7 @@
[#:steps
(tag-module-begin (module m '#%kernel (#%module-begin (begin 'a 'b))))
(splice-module (module m '#%kernel (#%module-begin 'a 'b)))]
#:same-hidden-steps)
#:no-hidden-steps)
(test "module, MB, def in begin"
(module m '#%kernel (#%module-begin (begin (define-values (x) 'a) x)))
[#:steps
@ -67,7 +67,7 @@
(module m '#%kernel (#%module-begin (begin (define-values (x) 'a) x))))
(splice-module
(module m '#%kernel (#%module-begin (define-values (x) 'a) x)))]
#:same-hidden-steps)
#:no-hidden-steps)
(test "module, MB, defstx, use"
(module m '#%kernel
@ -106,7 +106,11 @@
(#%module-begin
(#%require 'helper)
'a)))]
#:same-hidden-steps)
[#:hidden-steps
(macro
(module m '#%kernel
(#%require 'helper)
'a))])
(test "module k+helper, defs and opaque macros"
(module m '#%kernel
@ -196,14 +200,12 @@
(tag-module-begin
(module m mzscheme (#%module-begin (define-values (x) 'a) x)))
(macro
(module m mzscheme
(#%plain-module-begin
(#%require (for-syntax scheme/mzscheme))
(define-values (x) 'a)
x)))]
[#:hidden-steps
(tag-module-begin
(module m mzscheme (#%module-begin (define-values (x) 'a) x)))])
(module m mzscheme
(#%plain-module-begin
(#%require (for-syntax scheme/mzscheme))
(define-values (x) 'a)
x)))]
#:no-hidden-steps)
(test "module mz, def"
(module m mzscheme (define-values (x) 'a))
[#:steps
@ -214,9 +216,7 @@
(#%plain-module-begin
(#%require (for-syntax scheme/mzscheme))
(define-values (x) 'a))))]
[#:hidden-steps
(tag-module-begin
(module m mzscheme (#%module-begin (define-values (x) 'a))))])
#:no-hidden-steps)
(test "module mz, quote"
(module m mzscheme 'a)
[#:steps
@ -227,9 +227,7 @@
(#%plain-module-begin
(#%require (for-syntax scheme/mzscheme))
'a)))]
[#:hidden-steps
(tag-module-begin
(module m mzscheme (#%module-begin 'a)))])
#:no-hidden-steps)
(test "module mz, begin with 2 quotes"
(module m mzscheme (begin 'a 'b))
@ -246,9 +244,7 @@
(#%plain-module-begin
(#%require (for-syntax scheme/mzscheme))
'a 'b)))]
[#:hidden-steps
(tag-module-begin
(module m mzscheme (#%module-begin (begin 'a 'b))))])
#:no-hidden-steps)
(test "module mz, macro use, quote"
(module m mzscheme (or 'a 'b) 'c)
@ -289,9 +285,7 @@
(let-values ([(or-part) 'a])
(if or-part or-part 'b))
'c)))]
[#:hidden-steps
(tag-module-begin
(module m mzscheme (#%module-begin (or 'a 'b) 'c)))])
#:no-hidden-steps)
(test "module mz, macro use"
(module m mzscheme (or 'a 'b))