commit 77a121e1fdce27746c30e8a832a4cdf140744915
parent 3f73a508add811fbc45251051ca3891c4a6d26cf
Author: Matthew Flatt <mflatt@racket-lang.org>
Date: Sat, 10 May 2008 11:02:47 +0000
Ryan's macro-stepper patches
svn: r9794
original commit: 24739359e443feabd0dd7b66960ebf3a636b5ddd
Diffstat:
30 files changed, 4131 insertions(+), 1117 deletions(-)
diff --git a/collects/macro-debugger/expand.ss b/collects/macro-debugger/expand.ss
@@ -1,6 +1,7 @@
#lang scheme/base
-(require "model/trace.ss"
- "model/hide.ss")
+(require "model/trace.ss")
+
+#|
(provide expand-only
expand/hide)
@@ -22,3 +23,4 @@
(raise result))
(let-values ([(_d estx) (hide*/policy deriv show?)])
estx)))
+|#
diff --git a/collects/macro-debugger/model/debug.ss b/collects/macro-debugger/model/debug.ss
@@ -1,26 +1,21 @@
-
#lang scheme/base
(require scheme/match
"trace.ss"
"reductions.ss"
+ "reductions-config.ss"
"deriv-util.ss"
"deriv-find.ss"
- "hide.ss"
- "seek.ss"
"hiding-policies.ss"
"deriv.ss"
- "steps.ss"
- "synth-derivs.ss")
+ "steps.ss")
(provide (all-from-out "trace.ss")
(all-from-out "reductions.ss")
+ (all-from-out "reductions-config.ss")
(all-from-out "deriv.ss")
(all-from-out "deriv-util.ss")
(all-from-out "deriv-find.ss")
(all-from-out "hiding-policies.ss")
- (all-from-out "hide.ss")
- (all-from-out "seek.ss")
(all-from-out "steps.ss")
- (all-from-out "synth-derivs.ss")
(all-from-out scheme/match))
diff --git a/collects/macro-debugger/model/deriv-c.ss b/collects/macro-debugger/model/deriv-c.ss
@@ -11,11 +11,15 @@
;; Deriv
;; A Deriv is one of
-;; (make-mrule <Node(Stx)> Transformation Deriv)
+;; MRule
;; PrimDeriv
+
+;; Base = << Node(Stx) Rs ?exn >>
+
(define-struct (deriv node) () #:transparent)
+(define-struct (base deriv) (resolves ?1) #:transparent)
+
(define-struct (lift-deriv deriv) (first lift-stx second) #:transparent)
-(define-struct (mrule deriv) (transformation next) #:transparent)
(define-struct (tagrule deriv) (tagged-stx next) #:transparent)
;; A DerivLL is one of
@@ -23,9 +27,9 @@
;; Deriv
(define-struct (lift/let-deriv deriv) (first lift-stx second) #:transparent)
-;; A Transformation is
-;; (make-transformation <Node(Stx)> Rs ?exn ?Stx (list-of LocalAction) ?exn ?Stx Number)
-(define-struct (transformation node) (resolves ?1 me1 locals me2 ?2 seq) #:transparent)
+;; A MRule is
+;; (make-mrule <Base(Stx)> ?Stx (listof LocalAction) ?exn ?Stx ?Deriv)
+(define-struct (mrule base) (me1 locals me2 ?2 etx next) #:transparent)
;; A LocalAction is one of
;; (make-local-expansion <Node(Stx)> Stx ?Stx Boolean Deriv)
@@ -33,14 +37,11 @@
;; (make-local-lift Stx Identifier)
;; (make-local-lift-end Stx)
;; (make-local-bind BindSyntaxes)
-(define-struct (local-expansion node) (me1 me2 inner for-stx? lifted opaque)
+(define-struct (local-expansion node) (for-stx? me1 inner lifted me2 opaque)
#:transparent)
(define-struct local-lift (expr id) #:transparent)
(define-struct local-lift-end (decl) #:transparent)
-(define-struct local-bind (names bindrhs) #:transparent)
-
-;; Base = << Node(Stx) Rs ?exn >>
-(define-struct (base deriv) (resolves ?1) #:transparent)
+(define-struct local-bind (names ?1 renames bindrhs) #:transparent)
;; A PrimDeriv is one of
(define-struct (prule base) () #:transparent)
@@ -57,12 +58,12 @@
(define-struct (p:define-syntaxes prule) (rhs ?2) #:transparent)
(define-struct (p:define-values prule) (rhs) #:transparent)
-;; (make-p:#%expression <Base> Deriv)
+;; (make-p:#%expression <Base> Deriv ?Stx)
;; (make-p:if <Base> Boolean Deriv Deriv Deriv)
;; (make-p:wcm <Base> Deriv Deriv Deriv)
;; (make-p:set! <Base> Rs Deriv)
;; (make-p:set!-macro <Base> Rs Deriv)
-(define-struct (p:#%expression prule) (inner) #:transparent)
+(define-struct (p:#%expression prule) (inner untag) #:transparent)
(define-struct (p:if prule) (test then else) #:transparent)
(define-struct (p:wcm prule) (key mark body) #:transparent)
(define-struct (p:set! prule) (id-resolves rhs) #:transparent)
@@ -79,12 +80,14 @@
;; (make-p:case-lambda <Base> (list-of CaseLambdaClause))
;; (make-p:let-values <Base> LetRenames (list-of Deriv) BDeriv)
;; (make-p:letrec-values <Base> LetRenames (list-of Deriv) BDeriv)
-;; (make-p:letrec-syntaxes+values <Base> LSVRenames (list-of BindSyntaxes) (list-of Deriv) BDeriv)
+;; (make-p:letrec-syntaxes+values <Base> LSVRenames (list-of BindSyntaxes) (list-of Deriv) BDeriv ?Stx)
(define-struct (p:lambda prule) (renames body) #:transparent)
(define-struct (p:case-lambda prule) (renames+bodies) #:transparent)
(define-struct (p:let-values prule) (renames rhss body) #:transparent)
(define-struct (p:letrec-values prule) (renames rhss body) #:transparent)
-(define-struct (p:letrec-syntaxes+values prule) (srenames sbindrhss vrenames vrhss body) #:transparent)
+(define-struct (p:letrec-syntaxes+values prule)
+ (srenames sbindrhss vrenames vrhss body tag)
+ #:transparent)
;; (make-p:stop <Base>)
;; (make-p:unknown <Base>)
@@ -96,6 +99,7 @@
;; (make-p:require-for-syntax <Base>)
;; (make-p:require-for-template <Base>)
;; (make-p:provide <Base>)
+;; (make-p:#%variable-reference <Base>)
(define-struct (p::STOP prule) () #:transparent)
(define-struct (p:stop p::STOP) () #:transparent)
(define-struct (p:unknown p::STOP) () #:transparent)
@@ -107,13 +111,7 @@
(define-struct (p:require-for-syntax p::STOP) () #:transparent)
(define-struct (p:require-for-template p::STOP) () #:transparent)
(define-struct (p:provide p::STOP) () #:transparent)
-
-;;+ (make-p:rename <Base> Renames Deriv)
-;;+ (make-p:synth <Base> (list-of SynthItem) ?exn)
-(define-struct (p:rename prule) (renames inner) #:transparent)
-(define-struct (p:synth prule) (subterms ?2) #:transparent)
-
-
+(define-struct (p:#%variable-reference p::STOP) () #:transparent)
;; A LDeriv is
;; (make-lderiv <Node(Stxs)> ?exn (list-of Deriv))
@@ -127,22 +125,19 @@
;; (make-b:error exn)
;; (make-b:expr BlockRenames Deriv)
;; (make-b:splice BlockRenames Deriv ?exn Stxs ?exn)
-;; (make-b:defvals BlockRenames Deriv ?exn)
-;; (make-b:defstx BlockRenames Deriv ?exn BindSyntaxes)
-;;i (make-b:begin BlockRenames Deriv (list-of Deriv))
+;; (make-b:defvals BlockRenames Deriv ?exn Stx ?exn)
+;; (make-b:defstx BlockRenames Deriv ?exn Stx ?exn BindSyntaxes)
(define-struct b:error (?1) #:transparent)
(define-struct brule (renames) #:transparent)
(define-struct (b:expr brule) (head) #:transparent)
(define-struct (b:splice brule) (head ?1 tail ?2) #:transparent)
-(define-struct (b:defvals brule) (head ?1) #:transparent)
-(define-struct (b:defstx brule) (head ?1 bindrhs) #:transparent)
-;;(define-struct (b:begin brule) (head inner) #:transparent)
+(define-struct (b:defvals brule) (head ?1 rename ?2) #:transparent)
+(define-struct (b:defstx brule) (head ?1 rename ?2 bindrhs) #:transparent)
;; A BindSyntaxes is
;; (make-bind-syntaxes DerivLL ?exn)
(define-struct bind-syntaxes (rhs ?1) #:transparent)
-
;; A CaseLambdaClause is
;; (make-clc ?exn CaseLambdaRename BDeriv)
(define-struct clc (?1 renames body) #:transparent)
@@ -177,10 +172,3 @@
;; (make-p:require-for-template <Base>)
;; (make-p:provide <Base>)
;; #f
-
-;; A SynthItem is one of
-;; - (make-s:subterm Path Deriv)
-;; - (make-s:rename Path Stx Stx)
-(define-struct subitem () #:transparent)
-(define-struct (s:subterm subitem) (path deriv) #:transparent)
-(define-struct (s:rename subitem) (path before after) #:transparent)
diff --git a/collects/macro-debugger/model/deriv-parser.ss b/collects/macro-debugger/model/deriv-parser.ss
@@ -17,16 +17,6 @@
;; PARSER
-(define (parse-derivation x)
- (parameterize ((current-sequence-number 0))
- (parse-derivation* x)))
-
-(define current-sequence-number (make-parameter #f))
-(define (new-sequence-number)
- (let ([seq (current-sequence-number)])
- (current-sequence-number (add1 seq))
- seq))
-
(define-struct (exn:eval exn) (deriv))
(define empty-cms
(call-with-continuation-prompt (lambda () (current-continuation-marks))))
@@ -42,15 +32,14 @@
[(productions/I def ...)
#'(begin (production/I def) ...)]))
-(define parse-derivation*
+(define parse-derivation
(parser
(options (start Expansion)
(src-pos)
(tokens basic-tokens prim-tokens renames-tokens)
(end EOF)
- (error deriv-error)
- #;(debug "/Users/ryanc/DEBUG-PARSER.txt")
- )
+ #;(debug "/tmp/ryan/DEBUG-PARSER.txt")
+ (error deriv-error))
;; tokens
(skipped-token-values
@@ -70,6 +59,7 @@
renames-block
rename-one
rename-list
+ tag
IMPOSSIBLE)
;; Entry point
@@ -109,18 +99,16 @@
;; Expansion of an expression to primitive form
(CheckImmediateMacro
[(enter-check (? CheckImmediateMacro/Inner) exit-check)
- ($2 $1 $3 (lambda (ce1 ce2) (make p:stop ce1 ce2 null #f)))])
+ ($2 $1 $3)])
(CheckImmediateMacro/Inner
- (#:args e1 e2 k)
+ (#:args le1 e2)
[()
- (k e1 e2)]
+ (make p:stop le1 e2 null #f)]
[(visit Resolves (? MacroStep) return (? CheckImmediateMacro/Inner))
- (let ([next ($5 $4 e2 k)])
- (make mrule $1 (and next (wderiv-e2 next)) ($3 $2) next))]
+ ($3 $1 $2 ($5 $4 e2))]
[(visit Resolves tag (? MacroStep) return (? CheckImmediateMacro/Inner))
- (let ([next ($6 $5 e2 k)])
- (let ([mnode (make mrule $1 (and next (wderiv-e2 next)) ($4 $2) next)])
- (make tagrule $1 (wderiv-e2 mnode) $3 mnode)))])
+ (let ([mnode ($4 $3 $2 ($6 $5 e2))])
+ (make tagrule $1 (wderiv-e2 mnode) $3 mnode))])
;; Expansion of multiple expressions, next-separated
(NextEEs
@@ -135,29 +123,37 @@
[(visit Resolves (? EE/k))
($3 $1 $2)]
[(visit Resolves tag (? EE/k))
- (let ([next ($4 $1 $2)])
+ (let ([next ($4 $3 $2)])
(make tagrule $1 (wderiv-e2 next) $3 next))])
(EE/k
(#:args e1 rs)
- [((? PrimStep) return)
- ($1 e1 $2 rs)]
+ [(!!)
+ (make p:unknown e1 #f rs $1)]
+ [(variable return)
+ (make p:variable e1 $2 rs #f)]
+ [(enter-prim (? Prim) exit-prim return)
+ (begin
+ (unless (eq? $3 $4)
+ (fprintf (current-error-port)
+ "warning: exit-prim and return differ:\n~s\n~s\n"
+ $3 $4))
+ ($2 $1 $3 rs))]
[((? MacroStep) (? EE))
- (make mrule e1 (and $2 (wderiv-e2 $2)) ($1 rs) $2)])
+ ($1 e1 rs $2)])
+
+ (MacroStep
+ (#:args e1 rs next)
+ [(enter-macro ! macro-pre-transform (? LocalActions)
+ ! macro-post-transform ! exit-macro)
+ (make mrule e1 (and next (wderiv-e2 next)) rs $2
+ $3 $4 $6 (or $5 $7) $8 next)])
;; Keyword resolution
(Resolves
[() null]
[(resolve Resolves) (cons $1 $2)])
- ;; Single macro step (may contain local-expand calls)
- ;; MacroStep Answer = Transformation (I,E)
- (MacroStep
- (#:args rs)
- [(enter-macro ! macro-pre-transform (? LocalActions)
- ! macro-post-transform ! exit-macro)
- (make transformation $1 $8 rs $2 $3 $4 $6 (or $5 $7) (new-sequence-number))])
-
;; Local actions taken by macro
;; LocalAction Answer = (list-of LocalAction)
(LocalActions
@@ -168,15 +164,17 @@
(LocalAction
[(enter-local OptPhaseUp
- local-pre (? LocalExpand/Inner) local-post
- OptLifted OptOpaqueExpr exit-local)
- (make local-expansion $1 $8 $3 $5 $4 $2 $6 $7)]
+ local-pre (? LocalExpand/Inner) OptLifted local-post
+ OptOpaqueExpr exit-local)
+ (make local-expansion $1 $8 $2 $3 $4 $5 $6 $7)]
[(lift)
(make local-lift (cdr $1) (car $1))]
[(lift-statement)
(make local-lift-end $1)]
- [(local-bind (? BindSyntaxes))
- (make local-bind $1 $2)])
+ [(local-bind ! rename-list)
+ (make local-bind $1 $2 $3 #f)]
+ [(local-bind rename-list (? BindSyntaxes))
+ (make local-bind $1 #f $2 $3)])
(LocalExpand/Inner
[(start (? EE)) $2]
@@ -196,21 +194,6 @@
[(start (? EE))
#f])
- ;; Primitive
- (PrimStep
- (#:args e1 e2 rs)
- [(!!)
- (make p:unknown e1 e2 rs $1)]
- [(variable)
- (make p:variable e1 e2 rs #f)]
- [(enter-prim (? Prim) exit-prim)
- (begin
- (unless (eq? $3 e2)
- (fprintf (current-error-port)
- "warning: exit-prim and return differ:\n~s\n~s\n"
- $3 e2))
- ($2 $1 $3 rs))])
-
(Prim
(#:args e1 e2 rs)
[((? PrimModule)) ($1 e1 e2 rs)]
@@ -238,7 +221,8 @@
[((? PrimRequire)) ($1 e1 e2 rs)]
[((? PrimRequireForSyntax)) ($1 e1 e2 rs)]
[((? PrimRequireForTemplate)) ($1 e1 e2 rs)]
- [((? PrimProvide)) ($1 e1 e2 rs)])
+ [((? PrimProvide)) ($1 e1 e2 rs)]
+ [((? PrimVarRef)) ($1 e1 e2 rs)])
(PrimModule
(#:args e1 e2 rs)
@@ -269,13 +253,14 @@
(ModulePass1-Part
[((? EE) rename-one (? ModulePass1/Prim))
- (make mod:prim $1 $2 $3)]
+ (make mod:prim $1 $2 ($3 $2))]
[(EE rename-one ! splice)
(make mod:splice $1 $2 $3 $4)]
[(EE rename-list module-lift-loop)
(make mod:lift $1 $2 $3)])
(ModulePass1/Prim
+ (#:args e1)
[(enter-prim prim-define-values ! exit-prim)
(make p:define-values $1 $4 null $3 #f)]
[(enter-prim prim-define-syntaxes !
@@ -288,7 +273,7 @@
[(enter-prim prim-require-for-template (? Eval) exit-prim)
(make p:require-for-template $1 $4 null $3)]
[()
- #f])
+ (make p:stop e1 e1 null #f)])
(ModulePass2
(#:skipped null)
@@ -333,7 +318,9 @@
(PrimExpression
(#:args e1 e2 rs)
[(prim-expression ! (? EE))
- (make p:#%expression e1 e2 rs $2 $3)])
+ (make p:#%expression e1 e2 rs $2 $3 #f)]
+ [(prim-expression EE tag)
+ (make p:#%expression e1 e2 rs #f $2 $3)])
(PrimIf
(#:args e1 e2 rs)
@@ -359,7 +346,7 @@
(Prim#%App
(#:args e1 e2 rs)
[(prim-#%app !)
- (make p:#%app e1 e2 rs $2 (make lderiv null null #f null))]
+ (make p:#%app e1 e2 rs $2 #f)]
[(prim-#%app (? EL))
(make p:#%app e1 e2 rs #f $2)])
@@ -393,14 +380,10 @@
(#:args e1 e2 rs)
;; let*-values with bindings is "macro-like"
[(prim-let*-values !!)
- (let ([tx (make transformation e1 #f rs $2
- #f null #f #f (new-sequence-number))])
- (make mrule e1 e2 tx #f))]
+ (make mrule e1 e2 rs $2 #f null #f #f #f #f)]
[(prim-let*-values (? EE))
- (let* ([next-e1 (wderiv-e1 $2)]
- [tx (make transformation e1 next-e1 rs #f
- e1 null next-e1 #f (new-sequence-number))])
- (make mrule e1 e2 tx $2))]
+ (let* ([next-e1 (wderiv-e1 $2)])
+ (make mrule e1 e2 rs #f e1 null next-e1 #f next-e1 $2))]
;; No bindings... model as "let"
[(prim-let*-values renames-let (? NextEEs) next-group (? EB))
(make p:let-values e1 e2 rs #f $2 $3 $5)])
@@ -413,13 +396,13 @@
(PrimLetrecSyntaxes+Values
(#:args e1 e2 rs)
[(prim-letrec-syntaxes+values ! renames-letrec-syntaxes
- (? NextBindSyntaxess) next-group (? EB))
- (make p:letrec-syntaxes+values e1 e2 rs $2 $3 $4 #f null $6)]
+ (? NextBindSyntaxess) next-group (? EB) OptTag)
+ (make p:letrec-syntaxes+values e1 e2 rs $2 $3 $4 #f null $6 $7)]
[(prim-letrec-syntaxes+values renames-letrec-syntaxes
NextBindSyntaxess next-group
prim-letrec-values
- renames-let (? NextEEs) next-group (? EB))
- (make p:letrec-syntaxes+values e1 e2 rs #f $2 $3 $6 $7 $9)])
+ renames-let (? NextEEs) next-group (? EB) OptTag)
+ (make p:letrec-syntaxes+values e1 e2 rs #f $2 $3 $6 $7 $9 $10)])
;; Atomic expressions
(Prim#%Datum
@@ -461,13 +444,16 @@
(#:args e1 e2 rs)
[(prim-provide !) (make p:provide e1 e2 rs $2)])
+ (PrimVarRef
+ (#:args e1 e2 rs)
+ [(prim-varref !) (make p:#%variable-reference e1 e2 rs $2)])
+
(PrimSet
(#:args e1 e2 rs)
[(prim-set! ! Resolves next (? EE))
(make p:set! e1 e2 rs $2 $3 $5)]
[(prim-set! Resolves (? MacroStep) (? EE))
- (make p:set!-macro e1 e2 rs #f
- (make mrule e1 (and $4 (wderiv-e2 $4)) ($3 $2) $4))])
+ (make p:set!-macro e1 e2 rs #f ($3 e1 $2 $4))])
;; Blocks
;; EB Answer = BlockDerivation
@@ -494,11 +480,11 @@
(make b:expr $2 $3)]
[(next renames-block CheckImmediateMacro prim-begin ! splice !)
(make b:splice $2 $3 $5 $6 $7)]
- [(next renames-block CheckImmediateMacro prim-define-values !)
- (make b:defvals $2 $3 $5)]
+ [(next renames-block CheckImmediateMacro prim-define-values ! rename-one !)
+ (make b:defvals $2 $3 $5 $6 $7)]
[(next renames-block CheckImmediateMacro
- prim-define-syntaxes ! (? BindSyntaxes))
- (make b:defstx $2 $3 $5 $6)])
+ prim-define-syntaxes ! rename-one ! (? BindSyntaxes))
+ (make b:defstx $2 $3 $5 $6 $7 $8)])
;; BindSyntaxes Answer = Derivation
(BindSyntaxes
diff --git a/collects/macro-debugger/model/deriv-tokens.ss b/collects/macro-debugger/model/deriv-tokens.ss
@@ -41,9 +41,6 @@
local-post ; syntax
exit-local ; syntax
- enter-local/expr ; syntax
- exit-local/expr ; (cons syntax expanded-expression)
-
local-bind ; (list-of identifier)
enter-bind ; .
exit-bind ; .
@@ -77,6 +74,7 @@
prim-require-for-template prim-provide
prim-set!
prim-expression
+ prim-varref
))
;; ** Signals to tokens
@@ -148,8 +146,6 @@
(136 . ,token-lift/let-loop)
(137 . ,token-module-lift-loop)
(138 . prim-expression)
- (139 . ,token-enter-local/expr)
- (140 . ,token-exit-local/expr)
(141 . ,token-start)
(142 . ,token-tag)
(143 . ,token-local-bind)
@@ -158,6 +154,7 @@
(146 . ,token-opaque)
(147 . ,token-rename-list)
(148 . ,token-rename-one)
+ (149 . prim-varref)
))
(define (tokenize sig-n val pos)
diff --git a/collects/macro-debugger/model/hiding-policies.ss b/collects/macro-debugger/model/hiding-policies.ss
@@ -3,7 +3,7 @@
(require (for-syntax scheme/base)
scheme/match
syntax/boundmap
- "synth-engine.ss")
+ "reductions-config.ss")
(provide make-policy
standard-policy
base-policy
diff --git a/collects/macro-debugger/model/reductions-config.ss b/collects/macro-debugger/model/reductions-config.ss
@@ -0,0 +1,487 @@
+#lang scheme/base
+
+(require (for-syntax scheme/base)
+ scheme/list
+ scheme/contract
+ scheme/match
+ "deriv.ss"
+ "deriv-util.ss"
+ "stx-util.ss"
+ "context.ss"
+ "steps.ss")
+
+(define state/c (or/c state? false/c))
+(define context/c any/c)
+(define big-context/c any/c)
+
+(define (parameterlike/c c)
+ (case-> [-> c] [c . -> . any/c]))
+
+(define (list-parameter/c c)
+ (parameter/c (listof (box/c c))))
+
+(define subterms-table/c hash?)
+
+(define-syntax-rule (provide/contract* [name c] ...)
+ #;(provide/contract [name c] ...)
+ (provide name ...))
+
+(provide/contract*
+ [state/c contract?]
+ [context (parameter/c context/c)]
+ [big-context (parameter/c big-context/c)]
+ [marking-table (parameter/c (or/c hash? false/c))]
+ [current-binders (parameter/c (listof identifier?))]
+ [current-definites (parameter/c (listof identifier?))]
+ [current-frontier (parameter/c (listof syntax?))]
+ [sequence-number (parameter/c (or/c false/c exact-nonnegative-integer?))]
+ [phase (parameter/c exact-nonnegative-integer?)]
+ [visibility (parameter/c boolean?)]
+ [macro-policy (parameter/c (identifier? . -> . any))]
+ [subterms-table (parameter/c (or/c subterms-table/c false/c))]
+ [hides-flags (list-parameter/c boolean?)]
+ [block-syntax-bindings (parameter/c (listof syntaxish?))]
+ [block-value-bindings (parameter/c (listof syntaxish?))]
+ [block-expressions (parameter/c syntaxish?)]
+
+ [learn-definites ((listof identifier?) . -> . any)]
+
+ [add-frontier ((listof syntax?) . -> . any)]
+ [blaze-frontier (syntax? . -> . any)]
+
+ [current-state-with (syntaxish? syntaxish? . -> . state?)]
+ [walk ([syntaxish? syntaxish? symbol?]
+ [#:foci1 syntaxish? #:foci2 syntaxish?]
+ . ->* . step?)]
+ [stumble ([syntaxish? exn?] [#:focus syntaxish?] . ->* . misstep?)]
+
+ [current-pass-hides? (parameterlike/c boolean?)]
+
+ [available-lift-stxs (parameter/c (listof syntaxish?))]
+ [visible-lift-stxs (parameter/c (listof syntaxish?))])
+
+(provide with-context
+ with-new-local-context)
+
+;; FIXME: Steps are pairs of Configurations
+;; Configurations contain contexts, definites, etc.
+
+;; Classical Parameters
+
+;; context: parameter of Context
+(define context (make-parameter null))
+
+;; big-context: parameter of BigContext
+(define big-context (make-parameter null))
+
+;; marking-table
+(define marking-table (make-parameter #f))
+
+;; current-binders : parameterof (listof identifier)
+;; FIXME: not yet used
+(define current-binders (make-parameter null))
+
+;; current-definites : parameter of (list-of identifier)
+(define current-definites (make-parameter null))
+
+;; current-frontier : parameter of (list-of syntax)
+(define current-frontier (make-parameter null))
+
+;; sequence-number : parameter of nat
+(define sequence-number (make-parameter #f))
+
+;; New Hiding Parameters
+
+;; visibility : (parameterof boolean)
+(define visibility (make-parameter #t))
+
+;; macro-policy : (parameterof (identifier -> boolean))
+(define macro-policy (make-parameter (lambda (id) #t)))
+
+;; phase : (parameterof nat)
+(define phase (make-parameter 0))
+
+;; subterms-table : parameter of hash[syntax => (list-of Path)]
+(define subterms-table (make-parameter #f))
+
+;; hides-flags : (parameterof (listof (boxof boolean)))
+(define hides-flags (make-parameter null))
+
+;; block-syntax-bindings : (parameter/c (listof stx))
+;; block-value-bindings : (parameter/c (listof stx))
+;; block-expressions : (parameter/c (listof stx))
+(define block-value-bindings (make-parameter null))
+(define block-syntax-bindings (make-parameter null))
+(define block-expressions (make-parameter null))
+
+;; lift params
+(define available-lift-stxs (make-parameter null))
+(define visible-lift-stxs (make-parameter null))
+
+;; Hiding Structures
+
+(provide (struct-out hiding-failure)
+ (struct-out nonlinearity)
+ (struct-out localactions)
+ (struct-out hidden-lift-site))
+
+;; Machinery for reporting things that macro hiding can't handle
+(define-struct hiding-failure ())
+(define-struct (nonlinearity hiding-failure) (term paths))
+(define-struct (localactions hiding-failure) ())
+(define-struct (hidden-lift-site hiding-failure) ())
+
+;; Operations
+
+(define-syntax with-context
+ (syntax-rules ()
+ [(with-context f . body)
+ (let ([c (context)])
+ (parameterize ([context
+ (if (visibility)
+ (cons f c)
+ c)])
+ (let () . body)))]))
+
+(define-syntax with-new-local-context
+ (syntax-rules ()
+ [(with-new-local-context e . body)
+ (parameterize ([big-context
+ (cons (make bigframe (context) (list e) e)
+ (big-context))]
+ [context null])
+ . body)]))
+
+(define (learn-definites ids)
+ (current-definites
+ (append ids (current-definites))))
+
+(define (get-frontier) (or (current-frontier) null))
+
+(define (add-frontier stxs)
+ (current-frontier
+ (let ([frontier0 (current-frontier)])
+ (and frontier0 (append stxs frontier0)))))
+
+(define (blaze-frontier stx)
+ (current-frontier
+ (let ([frontier0 (current-frontier)])
+ (and frontier0
+ (remq stx frontier0)))))
+
+;; Renames mapping
+
+(define renames-mapping/c
+ ([syntax?] [#:allow-nonstx? boolean? #:default any/c] . ->* . any))
+
+(provide/contract*
+ [renames-mapping/c contract?]
+ [make-renames-mapping
+ (syntaxish? syntaxish? . -> . renames-mapping/c)]
+ [compose-renames-mappings
+ (renames-mapping/c renames-mapping/c . -> . renames-mapping/c)]
+ [apply-renames-mapping (renames-mapping/c syntaxish? . -> . syntaxish?)]
+
+ [table->renames-mapping
+ (hash? . -> . renames-mapping/c)]
+ [make-renames-table
+ (syntaxish? syntaxish? . -> . hash?)]
+ [add-to-renames-table
+ (hash? syntaxish? syntaxish? . -> . any)]
+
+ [rename-frontier/mapping
+ (renames-mapping/c . -> . any)])
+
+(define (rename-frontier/mapping mapping)
+ (current-frontier
+ (with-handlers ([exn:fail? (lambda _ #f)])
+ (for/list ([fstx (current-frontier)])
+ (let ([renamed-fstx (mapping fstx #:allow-nonstx? #t #:default null)])
+ (flatten-syntaxes renamed-fstx))))))
+
+;; apply-renames-mapping : (stx -> stx) stx -> stx
+(define (apply-renames-mapping mapping stx)
+ (cond [(and (syntax? stx)
+ (mapping stx #:allow-nonstx? #t #:default #f))
+ => (lambda (rstx)
+ (datum->syntax stx rstx stx stx))]
+ [(syntax? stx)
+ (let* ([inner (syntax-e stx)]
+ [rinner (apply-renames-mapping mapping inner)])
+ (if (eq? rinner inner)
+ stx
+ (datum->syntax stx rinner stx stx)))]
+ [(pair? stx)
+ (let ([ra (apply-renames-mapping mapping (car stx))]
+ [rb (apply-renames-mapping mapping (cdr stx))])
+ (if (and (eq? ra (car stx)) (eq? rb (cdr stx)))
+ stx
+ (cons ra rb)))]
+ [(vector? stx)
+ (let* ([elems (vector->list stx)]
+ [relems (apply-renames-mapping mapping elems)])
+ (if (eq? relems elems)
+ stx
+ (list->vector relems)))]
+ [(box? stx)
+ (let* ([inner (unbox stx)]
+ [rinner (apply-renames-mapping mapping inner)])
+ (if (eq? rinner inner)
+ stx
+ (box inner)))]
+ [(prefab-struct-key stx)
+ (let* ([inner (struct->vector stx)]
+ [rinner (apply-renames-mapping mapping inner)])
+ (if (eq? rinner inner)
+ stx
+ (apply make-prefab-struct
+ (prefab-struct-key stx)
+ (vector->list rinner))))]
+ [else stx]))
+
+;; make-renames-mapping : stx stx -> stx kw-args -> stx
+(define (make-renames-mapping from0 to0)
+ (define table (make-renames-table from0 to0))
+ (table->renames-mapping table))
+
+(define (table->renames-mapping table)
+ (lambda (stx #:allow-nonstx? [allow-nonstx? #f] #:default [default #f])
+ (let ([replacement (hash-ref table stx #f)])
+ (if replacement
+ (begin #;(printf " replacing ~s with ~s~n" stx replacement)
+ replacement)
+ (begin #;(printf " not replacing ~s~n" stx)
+ default)))))
+
+(define (make-renames-table from0 to0)
+ (define table (make-hasheq))
+ (add-to-renames-table table from0 to0)
+ table)
+
+(define (add-to-renames-table table from0 to0)
+ (let loop ([from from0] [to to0])
+ (cond [(and (syntax? from) (syntax? to))
+ (hash-set! table from to)
+ (loop (syntax-e from) (syntax-e to))]
+ [(syntax? from)
+ (hash-set! table from to)
+ (loop (syntax-e from) to)]
+ [(syntax? to)
+ (loop from (syntax-e to))]
+ [(and (pair? from) (pair? to))
+ (loop (car from) (car to))
+ (loop (cdr from) (cdr to))]
+ [(and (vector? from) (vector? to))
+ (loop (vector->list from) (vector->list to))]
+ [(and (box? from) (box? to))
+ (loop (unbox from) (unbox to))]
+ [(and (struct? from) (struct? to))
+ (loop (struct->vector from) (struct->vector to))]
+ [else
+ (unless (eqv? from to)
+ (fprintf (current-error-port)
+ "from:\n~e\n\nto:\n~e\n\n"
+ (stx->datum from)
+ (stx->datum to))
+ (fprintf (current-error-port)
+ "original from:\n~e\n\noriginal to:\n~e\n\n"
+ (stx->datum from0)
+ (stx->datum to0))
+ (error 'add-to-renames-table))
+ (void)])))
+
+(define (compose-renames-mappings first second)
+ (lambda (stx #:allow-nonstx? [allow-nonstx? #f] #:default [default #f])
+ (let ([r (first stx #:allow-nonstx? allow-nonstx? #:default #f)])
+ (if r
+ (second r #:allow-nonstx? allow-nonstx? #:default default)
+ default))))
+
+(define (flatten-syntaxes x)
+ (cond [(syntax? x)
+ (list x)]
+ [(pair? x)
+ (append (flatten-syntaxes (car x))
+ (flatten-syntaxes (cdr x)))]
+ [(vector? x)
+ (flatten-syntaxes (vector->list x))]
+ [(box? x)
+ (flatten-syntaxes (unbox x))]
+ [else null]))
+
+;; -----------------------------------
+
+(define (current-state-with e fs)
+ (make state e (foci fs) (context) (big-context)
+ (current-binders) (current-definites) (current-frontier)
+ (sequence-number)))
+
+(define (walk e1 e2 type
+ #:foci1 [foci1 e1]
+ #:foci2 [foci2 e2])
+ (make step type
+ (current-state-with e1 foci1)
+ (current-state-with e2 foci2)))
+
+(define (stumble stx exn
+ #:focus [focus stx])
+ (make misstep 'error
+ (current-state-with stx focus)
+ exn))
+
+(define (foci x)
+ (cond [(syntax? x)
+ (list x)]
+ [(null? x)
+ null]
+ [(pair? x)
+ (append (foci (car x))
+ (foci (cdr x)))]))
+
+
+;; RS: the reductions monad
+
+;; Datastructure RS
+;; Better for debugging
+
+;; RS = (rsok ReductionSequence stx stx state)
+;; | (rsfailed ReductionSequence exn)
+
+(define-struct rsok (rs real vis s))
+(define-struct rsfailed (rs exn))
+
+(define RS/c
+ (lambda (x)
+ (or (rsok? x) (rsfailed? x))))
+
+(define (RSunit steps x y s) (make rsok steps x y s))
+
+(define (RSfail steps exn) (make rsfailed steps exn))
+
+(define (RSbind a f)
+ (match a
+ [(struct rsok (rs a b s))
+ (f a b s rs)]
+ [(struct rsfailed (rs exn))
+ a]))
+
+(define (RScase a k f)
+ (match a
+ [(struct rsok (rs a b s))
+ (k rs a b s)]
+ [(struct rsfailed (rs exn))
+ (f rs exn)]))
+
+(provide RS/c)
+(provide/contract*
+ [RSunit ((listof protostep?) any/c any/c state/c . -> . RS/c)]
+ [RSfail ((listof protostep?) exn? . -> . RS/c)]
+ [RSbind (RS/c (any/c any/c state/c (listof protostep?) . -> . RS/c) . -> . RS/c)]
+ [RScase (RS/c
+ ((listof protostep?) any/c any/c state/c . -> . any)
+ ((listof protostep?) exn? . -> . any)
+ . -> . any)])
+
+#|
+;; Alternate RS = (values ?exn steps ?stx ?stx state)
+;; Avoids allocation
+;; Doesn't seem to actually matter
+
+(define (RSunit ws x y s)
+ (values #f ws x y s))
+
+(define (RSfail ws e)
+ (values e ws #f #f #f))
+
+(define-syntax-rule (RSbind a f)
+ (let-values ([(e ws x y s) a])
+ (if (not e)
+ (f x y s ws)
+ (values e ws x y s))))
+
+(define-syntax-rule (RScase a k f)
+ (let-values ([(e ws x y s) a])
+ (if (not e)
+ (k ws x y s)
+ (f ws e))))
+
+(define-syntax RS/c (make-rename-transformer #'any/c))
+
+(provide RS/c
+ RSunit
+ RSfail
+ RSbind
+ RScase)
+|#
+
+
+;; Table
+
+(provide/contract*
+ [gather-proper-subterms (syntaxish? . -> . subterms-table/c)]
+ [table-get (subterms-table/c syntax? . -> . list?)]
+ [table-apply-renames-mapping
+ ((or/c subterms-table/c false/c) renames-mapping/c boolean?
+ . -> . (or/c subterms-table/c false/c))])
+
+;; gather-proper-subterms : Syntax -> SubtermTable
+;; FIXME: Eventually, need to descend into vectors, boxes, etc.
+(define (gather-proper-subterms stx0)
+ (define (table-add! table stx v)
+ (hash-set! table stx (cons v (table-get table stx))))
+ (define (table-get table stx)
+ (hash-ref table stx null))
+ (let ([table (make-hasheq)])
+ ;; loop : Syntax Path -> void
+ (define (loop stx rpath)
+ (unless (eq? stx0 stx)
+ (table-add! table stx (reverse rpath)))
+ (let ([p (if (syntax? stx) (syntax-e stx) stx)])
+ (when (pair? p)
+ (loop-cons p rpath 0))))
+ ;; loop-cons : (cons Syntax ?) Path number -> void
+ (define (loop-cons p rpath pos)
+ (loop (car p) (cons (make ref pos) rpath))
+ (let ([t (cdr p)])
+ (cond [(syntax? t)
+ (let ([te (syntax-e t)])
+ (if (pair? te)
+ (begin
+ (table-add! table t (reverse (cons (make tail pos) rpath)))
+ (loop-cons te rpath (add1 pos)))
+ (loop t (cons (make tail pos) rpath))))]
+ [(pair? t)
+ (loop-cons t rpath (add1 pos))]
+ [(null? t)
+ (void)])))
+ (loop stx0 null)
+ table))
+
+;; table-get : Table stx -> (listof Path)
+(define (table-get t x)
+ (hash-ref t x null))
+
+;; table-apply-renames-mapping boolean : Table (stx -> stx) -> Table
+(define (table-apply-renames-mapping old mapping whole-form-rename?)
+ (and old
+ (let ([t (make-hasheq)])
+ (hash-for-each
+ old
+ (if whole-form-rename?
+ (lambda (stx paths)
+ (let ([rstx (mapping stx #:default #f)])
+ (when rstx
+ (hash-set! t rstx paths))))
+ (lambda (stx paths)
+ (let ([rstx (mapping stx #:default stx)])
+ (hash-set! t rstx paths)))))
+ t)))
+
+;; list-parameter->parameterlike : (list-parameter/c X) -> (parameterlike X)
+(define (list-parameter->parameterlike p)
+ (case-lambda
+ [() (unbox (car (p)))]
+ [(v) (set-box! (car (p)) v)]))
+
+;; current-pass-hides?
+(define current-pass-hides? (list-parameter->parameterlike hides-flags))
diff --git a/collects/macro-debugger/model/reductions-engine.ss b/collects/macro-debugger/model/reductions-engine.ss
@@ -1,481 +1,537 @@
-
#lang scheme/base
-
(require (for-syntax scheme/base)
+ (for-syntax "../stxclass/stxclass.ss")
scheme/list
scheme/contract
"deriv.ss"
+ "deriv-util.ss"
"stx-util.ss"
- "steps.ss")
+ "context.ss"
+ "steps.ss"
+ "reductions-config.ss")
(provide (all-from-out "steps.ss")
- context
- big-context
- current-derivation
- current-definites
- learn-definites
- current-frontier
- add-frontier
- blaze-frontier
- rename-frontier
- with-context
- with-derivation
- with-new-local-context
-
- RSunit
- RSzero
- RSbind
- RSadd
- RSseq
- RSforeach
- RS-steps
-
- CC
- R
- revappend
-
- walk
- walk/foci
- walk/mono
- stumble
- stumble/E)
-
-;; FIXME: Steps are pairs of Configurations
-;; Configurations contain contexts, definites, etc.
-
-;; context: parameter of Context
-(define context (make-parameter null))
-
-;; big-context: parameter of BigContext
-(define big-context (make-parameter null))
-
-;; current-derivation : parameter of Derivation
-(define current-derivation (make-parameter #f))
-
-;; current-definites : parameter of (list-of identifier)
-(define current-definites (make-parameter null))
-
-;; current-frontier : parameter of (list-of syntax)
-(define current-frontier (make-parameter null))
-
-(define-syntax with-context
- (syntax-rules ()
- [(with-context f . body)
- (let ([c (context)])
- (parameterize ([context (cons f c)])
- (let () . body)))]))
-
-(define-syntax with-derivation
- (syntax-rules ()
- [(with-derivation d . body)
- (parameterize ((current-derivation d)) . body)]))
-
-(define-syntax with-new-local-context
- (syntax-rules ()
- [(with-new-local-context e . body)
- (parameterize ([big-context
- (cons (make-bigframe (current-derivation) (context) (list e) e)
- (big-context))]
- [context null])
- . body)]))
-
-(define (learn-definites ids)
- (current-definites
- (append ids (current-definites))))
-
-(define (get-frontier) (or (current-frontier) null))
-
-(define (add-frontier stxs)
- (current-frontier
- (let ([frontier0 (current-frontier)])
- (and frontier0 (append stxs frontier0)))))
-
-(define (blaze-frontier stx)
- (current-frontier
- (let ([frontier0 (current-frontier)])
- (and frontier0
- (remq stx frontier0)))))
-
-;; -----------------------------------
-
-;; RS: The "reductions monad"
-;; (RS a) = (values ReductionSequence ?a ?exn)
-;; Not a proper monad, because of 'values'
-
-(define-syntax ->RS/c
- (syntax-rules ()
- [(->RS/c domain-c ...)
- (-> domain-c ...
- (values (listof protostep?) any/c (or/c exn? false/c)))]))
-
-(define/contract RSzero
- (->RS/c)
- (lambda () (values null #f #f)))
-
-(define/contract RSunit
- (->RS/c any/c)
- (lambda (v)
- (values null v #f)))
-
-(define/contract RSbind
- (->RS/c (->RS/c) (->RS/c any/c))
- (lambda (a f)
- (let-values ([(rseq1 final1 exn1) (a)])
- (if (not exn1)
- (let-values ([(rseq2 final2 exn2) (f final1)])
- (values (append rseq1 rseq2) final2 exn2))
- (values rseq1 final1 exn1)))))
-
-(define/contract RSseq
- (->RS/c (->RS/c) (->RS/c))
- (lambda (a b)
- (RSbind a (lambda (_) (b)))))
-
-(define/contract RSforeach
- (->RS/c (->RS/c any/c) (listof any/c))
- (lambda (f xs)
- (let loop ([xs xs])
- (if (pair? xs)
- (RSseq (lambda () (f (car xs)))
- (lambda () (loop (cdr xs))))
- (RSunit (void))))))
-
-(define/contract RSadd
- (->RS/c (listof protostep?) (->RS/c))
- (lambda (steps a)
- (let-values ([(rseq1 final1 exn1) (a)])
- (values (append steps rseq1) final1 exn1))))
-
-(define-syntax RS-steps
- (syntax-rules ()
- [(RS-steps expr)
- (let-values ([(rseq final exn) expr])
- rseq)]))
+ (all-from-out "reductions-config.ss")
+ DEBUG
+ R)
-;; CC
-;; the context constructor
-(define-syntax (CC stx)
- (syntax-case stx ()
- [(CC HOLE expr pattern)
- #'(syntax-copier HOLE expr pattern)]))
+(begin-for-syntax
+ (expr/c-use-contracts? #f))
-;; R
-;; the threaded reductions engine
+(define-syntax-rule (DEBUG form ...)
+ (when #f
+ form ... (void)))
+
+(define-syntax-rule (STRICT-CHECKS form ...)
+ (when #f
+ form ... (void)))
+
+(define RST/c (syntaxish? syntaxish? state/c list? . -> . RS/c))
+
+;; (R R-clause ...) : RST
-;; (R stx R-clause ...) : (values (list-of Step) ?stx ?exn)
;; An R-clause is one of
;; [! expr]
+;; [#:set-syntax expr]
+;; [#:expect-syntax expr]
;; [#:pattern pattern]
-;; [#:bind pattern stx-expr]
-;; [#:let-values (var ...) expr]
+;; [#:do expr ...]
+;; [#:let var expr]
+;; [#:left-foot]
;; [#:walk term2 description]
;; [#:walk/ctx pattern term2 description]
;; [#:walk/foci term2 foci1 foci2 description]
-;; [#:rename* pattern rename [description]]
+;; [#:rename pattern rename [description]]
;; [#:rename/no-step pattern stx stx]
;; [#:reductions expr]
;; [#:learn ids]
-;; [#:frontier stxs]
+;; [#:if test R-clause ...]
;; [#:when test R-clause ...]
-;; [#:if/np test R-clause ...]
+;; [#:hide-check ids]
+;; [#:seek-check]
;; [generator hole fill]
(define-syntax R
- (syntax-rules ()
- [(R form . clauses)
- (let ([form-var form])
- (R** form-var _ . clauses))]))
-
+ (syntax-parser
+ [(R . clauses)
+ #'(lambda (f v s ws)
+ (R** f v _ s ws . clauses))]))
+
+(define-syntax RP
+ (syntax-parser
+ [(RP p . clauses)
+ #'(lambda (f v s ws)
+ (R** f v p s ws . clauses))]))
+
+;; (R** form virtual-form pattern . clauses)
(define-syntax R**
- (syntax-rules (! =>)
+ (syntax-parser #:literals (! =>)
+
+ ;; (R** f v p s ws . clauses)
+ ;; f is the "real" form
+ ;; v is the "virtual" form (used for steps)
+ ;; - vis=#t: starts as f
+ ;; - vis=#f: starts as last visible term
+ ;; s is the last marked state
+ ;; ws is the list of steps, reversed
+
;; Base: done
- [(R** form-var pattern)
- (RSunit form-var)]
+ [(R** f v p s ws)
+ #'(RSunit ws f v s)]
- ;; Base: explicit continuation
- [(R** f p => k)
- (k f)]
+ [(R** f v p s ws => k . more)
+ #:declare k (expr/c #'RST/c)
+ #'(RSbind (k f v s ws)
+ (RP p . more))]
;; Error-point case
- [(R** f p [! maybe-exn] . more)
- (let ([x maybe-exn])
- (unless (or (not x) (exn? x))
- (raise-type-error 'R "exception" x))
- (if x
- (values (list (stumble f x)) #f x)
- (R** f p . more)))]
+ [(R** f v p s ws [! maybe-exn] . more)
+ #:declare maybe-exn (expr/c #'(or/c exn? false/c))
+ #'(let ([x maybe-exn])
+ (if x
+ ;; FIXME
+ (RSfail (cons (stumble v x) ws) x)
+ (R** f v p s ws . more)))]
;; Change patterns
- [(R** f p [#:pattern p2] . more)
- (R** f p2 . more)]
-
- ;; Bind pattern variables
- [(R** f p [#:bind pattern rhs] . more)
- (with-syntax ([pattern (with-syntax ([p f]) rhs)])
- (R** f p . more))]
-
- ;; Bind variables
- [(R** f p [#:let-values (var ...) rhs] . more)
- (let-values ([(var ...) (with-syntax ([p f]) rhs)])
- (R** f p . more))]
+ [(R** f v p s ws [#:pattern p2] . more)
+ #'(R** f v p2 s ws . more)]
+
+ ;; Execute expressions for effect
+ [(R** f v p s ws [#:do expr ...] . more)
+ #'(begin
+ (with-syntax ([p f])
+ expr ... (void))
+ (R** f v p s ws . more))]
+
+ [(R** f v p s ws [#:let var expr] . more)
+ #'(let ([var (with-syntax ([p f]) expr)])
+ (R** f v p s ws . more))]
+
+ [(R** f v p s ws [#:parameterize ((param expr) ...) . clauses] . more)
+ #:declare param (expr/c #'parameter?)
+ #'(RSbind (parameterize ((param expr) ...)
+ (R** f v p s ws . clauses))
+ (RP p . more))]
;; Change syntax
- [(R** f p [#:set-syntax form] . more)
- (let ([form-variable form])
- (R** form-variable p . more))]
-
- ;; Change syntax and Step (infer foci)
- [(R** f p [#:walk form2 description] . more)
- (let-values ([(form2-var description-var)
- (with-syntax ([p f])
- (values form2 description))])
- (RSadd (list (walk f form2-var description-var))
- (lambda () (R** form2-var p . more))))]
-
- ;; Change syntax and Step (explicit foci)
- [(R** f p [#:walk/foci form2 foci1 foci2 description] . more)
- (let-values ([(form2-var foci1-var foci2-var description-var)
- (with-syntax ([p f])
- (values form2 foci1 foci2 description))])
- (RSadd (list (walk/foci foci1-var foci2-var f form2-var description-var))
- (lambda () (R** form2-var p . more))))]
-
- [(R** f p [#:walk/ctx hole form2 desc] . more)
- (let-values ([(form2-var desc-var)
- (with-syntax ([p f])
- (values form2 desc))])
- (let ([k (lambda (f2) (R** f2 p . more))]
- [generator
- (lambda ()
- (lambda (d init-e1)
- (R init-e1
- [#:walk form2-var desc-var])))])
- (Run f p generator hole form2 k)))]
+ [(R** f v p s ws [#:set-syntax form] . more)
+ #:declare form (expr/c #'syntaxish?)
+ #'(let ([f2 (with-syntax ([p f]) form)])
+ ;; FIXME: should (current-pass-hides?) be relevant?
+ (let ([v2 (if (visibility) f2 v)])
+ (R** f2 v2 p s ws . more)))]
+
+ [(R** f v p s ws [#:expect-syntax expr ds] . more)
+ #:declare expr (expr/c #'syntax?)
+ #'(let ([expected (with-syntax ([p f]) expr)])
+ (STRICT-CHECKS
+ (check-same-stx 'expect-syntax f expected ds))
+ (R** f v p s ws . more))]
+
+ [(R** f v p s ws [#:left-foot] . more)
+ #'(R** f v p s ws [#:step #f v] . more)]
+ [(R** f v p s ws [#:left-foot fs] . more)
+ #'(R** f v p s ws [#:step #f fs] . more)]
+
+ [(R** f v p s ws [#:step type] . more)
+ #'(R** f v p s ws [#:step type v] . more)]
+
+ [(R** f v p s ws [#:step type fs] . more)
+ #:declare fs (expr/c #'syntaxish?)
+ #:declare type (expr/c #'(or/c step-type? false/c))
+ #'(let ([s2 (and (visibility)
+ (current-state-with v (with-syntax ([p f]) fs)))]
+ [type-var type])
+ (DEBUG
+ (printf "visibility = ~s\n" (visibility))
+ (printf "step: s1 = ~s\n" s)
+ (printf "step: s2 = ~s\n\n" s2))
+ (let ([ws2
+ (if (and (visibility) type-var)
+ (cons (make step type-var s s2) ws)
+ ws)])
+ (R** f v p s2 ws2 . more)))]
+
+ [(R** f v p s ws [#:walk form2 description] . more)
+ #:declare form2 (expr/c #'syntaxish?)
+ #'(let ([wfv (with-syntax ([p f]) form2)])
+ (R** f v p s ws
+ [#:left-foot]
+ [#:set-syntax wfv]
+ [#:step description]
+ . more))]
+
+ [(R** f v p s ws [#:reductions rs] . more)
+ #:declare rs (expr/c #'(listof step?))
+ #'(let ([ws2
+ (if (visibility)
+ (revappend (with-syntax ([p f]) rs) ws)
+ ws)])
+ (R** f v p s ws2 . more))]
+
+ [(R** f v p s ws [#:in-hole hole . clauses] . more)
+ #'(let ([k (RP p . more)]
+ [reducer
+ (lambda (_)
+ (R . clauses))])
+ (Run reducer f v p s ws hole #f k))]
;; Rename
- [(R** f p [#:rename* pattern renames] . more)
- (R** f p [#:rename* pattern renames #f] . more)]
-
- [(R** f p [#:rename* pattern renames description] . more)
- (let-values ([(renames-var description-var)
- (with-syntax ([p f])
- (values renames description))])
- (let ([pre-renames-var
- (with-syntax ([p f]) (syntax pattern))]
- [f2
- (with-syntax ([p f])
- (with-syntax ([pattern renames])
- (syntax p)))])
- (rename-frontier pre-renames-var renames-var)
- (with-context (make-renames pre-renames-var renames-var)
- (RSadd (if description-var
- (list (walk/foci pre-renames-var renames-var
- f f2
- description-var))
- null)
- (lambda () (R** f2 p . more))))))]
-
- ;; Change syntax with rename
- #;
- [(R** f p [#:rename form2 foci1 foci2 description] . more)
- (let-values ([(form2-var foci1-var foci2-var description-var)
- (with-syntax ([p f])
- (values form2 foci1 foci2 description))])
- (rename-frontier f form2-var)
- (with-context (make-renames foci1-var foci2-var)
- (RSadd (list (walk/foci foci1-var foci2-var
- f form2-var
- description-var))
- (lambda () (R** form2-var p . more)))))]
+ [(R** f v p s ws [#:rename pattern renames] . more)
+ #'(R** f v p s ws [#:rename pattern renames #f] . more)]
+ [(R** f v p s ws [#:rename pattern renames description] . more)
+ #'(R** f v p s ws [#:rename* pattern renames description #f]. more)]
+
+ [(R** f v p s ws [#:rename* pattern renames description mark-flag] . more)
+ #'(let-values ([(renames-var description-var)
+ (with-syntax ([p f])
+ (values renames description))])
+ (let* ([pre-renames-var
+ (with-syntax ([p f]) (syntax pattern))]
+ [f2
+ ((CC pattern f p) renames)]
+ [whole-form-rename? (eq? f pre-renames-var)]
+ [renames-mapping
+ (make-renames-mapping pre-renames-var renames-var)]
+ [v2
+ (cond [(or (visibility) (eq? mark-flag #f))
+ (apply-renames-mapping renames-mapping v)]
+ [(eq? mark-flag 'mark)
+ v]
+ [(eq? mark-flag 'unmark)
+ (apply-renames-mapping
+ (compose-renames-mappings
+ (table->renames-mapping (marking-table))
+ renames-mapping)
+ v)])]
+ [ws2
+ (if (and description-var (visibility))
+ (cons (walk v v2 description-var
+ #:foci1 pre-renames-var
+ #:foci2 renames-var)
+ ws)
+ ws)])
+ (parameterize ((subterms-table
+ (table-apply-renames-mapping
+ (subterms-table)
+ renames-mapping
+ whole-form-rename?)))
+ (R** f2 v2 p s ws2 . more))))]
+
+ [(R** f v p s ws [#:rename/mark pvar from to] . more)
+ #:declare from (expr/c #'syntaxish?)
+ #:declare to (expr/c #'syntaxish?)
+ #'(let ([real-from (with-syntax ([p f]) #'pvar)])
+ (STRICT-CHECKS
+ (check-same-stx 'rename/mark real-from from))
+ (when (marking-table)
+ (add-to-renames-table (marking-table) from to))
+ (R** f v p s ws [#:rename* pvar to #f 'mark] . more))]
+
+ [(R** f v p s ws [#:rename/unmark pvar from to] . more)
+ #:declare from (expr/c #'syntaxish?)
+ #:declare to (expr/c #'syntaxish?)
+ #'(let ([real-from (with-syntax ([p f]) #'pvar)])
+ (STRICT-CHECKS
+ (check-same-stx 'rename/mark real-from from))
+ (R** f v p s ws [#:rename* pvar to #f 'unmark] . more))]
;; Change syntax with rename (but no step)
- [(R** f p [#:rename/no-step pvar from to] . more)
- (let-values ([(from-var to-var)
- (with-syntax ([p f]) (values from to))])
- (let ([f2 (with-syntax ([p f])
- (with-syntax ([pvar to])
- (syntax p)))])
- (rename-frontier from-var to-var)
- (with-context (make-renames from-var to-var)
- (R** f2 p . more))))]
-
- ;; Add in arbitrary other steps
- [(R** f p [#:reductions steps] . more)
- (RSseq (lambda () steps)
- (lambda () (R** f p . more)))]
-
- ;; Add to definites
- [(R** f p [#:learn ids] . more)
- (begin (learn-definites (with-syntax ([p f]) ids))
- (R** f p . more))]
-
- ;; Add to frontier
- [(R** f p [#:frontier stxs] . more)
- (begin (add-frontier (with-syntax ([p f]) stxs))
- (R** f p . more))]
+ [(R** f v p s ws [#:rename/no-step pvar from to] . more)
+ #:declare from (expr/c #'syntaxish?)
+ #:declare to (expr/c #'syntaxish?)
+ #'(let ([real-from (with-syntax ([p f]) #'pvar)])
+ (STRICT-CHECKS
+ (check-same-stx 'rename/no-step real-from from))
+ (R** f v p s ws [#:rename pvar to] . more))]
+
+ ;; Add to definite uses
+ [(R** f v p s ws [#:learn ids] . more)
+ #:declare ids (expr/c #'(listof identifier?))
+ #'(begin (learn-definites (with-syntax ([p f]) ids))
+ (R** f v p s ws . more))]
;; Conditional (pattern changes lost afterwards ...)
- [(R** f p [#:if/np test [consequent ...] [alternate ...]] . more)
- (let ([continue (lambda (f2) (R** f2 p . more))])
- (if (with-syntax ([p f]) test)
- (R** f p consequent ... => continue)
- (R** f p alternate ... => continue)))]
+ [(R** f v p s ws [#:if test [consequent ...] [alternate ...]] . more)
+ #'(let ([continue (RP p . more)])
+ (if (with-syntax ([p f]) test)
+ (R** f v p s ws consequent ... => continue)
+ (R** f v p s ws alternate ... => continue)))]
;; Conditional (pattern changes lost afterwards ...)
- [(R** f p [#:when/np test consequent ...] . more)
- (let ([continue (lambda (f2) (R** f2 p . more))])
- (if (with-syntax ([p f]) test)
- (R** f p consequent ... => continue)
- (continue f)))]
-
- ;; Conditional
- [(R** f p [#:when test consequent ...] . more)
- (if (with-syntax ([p f]) test)
- (R** f p consequent ... . more)
- (R** f p . more))]
+ [(R** f v p s ws [#:when test consequent ...] . more)
+ #'(let ([continue (RP p . more)])
+ (if (with-syntax ([p f]) test)
+ (R** f v p s ws consequent ... => continue)
+ (continue f v s ws)))]
+
+ ;; HIDING DIRECTIVES
+ [(R** f v p s ws [#:hide-check ids] . more)
+ #:declare ids (expr/c #'(listof identifier?))
+ #'(visibility-off (andmap (macro-policy) ids)
+ v
+ (lambda () (R** f v p s ws . more)))]
+
+ [(R** f v p s ws [#:seek-check] . more)
+ #'(seek-point f v (lambda (v2) (R** f v2 p s ws . more)))]
+
+ [(R** f v p s ws [#:print-state msg] . more)
+ #'(begin (printf "** ~s\n" msg)
+ (printf "f = ~e\n" (stx->datum f))
+ (printf "v = ~e\n" (stx->datum v))
+ (printf "s = ~e\n" (stx->datum s))
+ (R** f v p s ws . more))]
+
+ ;; ** Multi-pass reductions **
+
+ ;; Pass1 does expansion.
+ ;; If something should happen regardless of whether hiding occurred in pass1,
+ ;; put it before the Pass2 marker (eg, lifting).
+ ;; Use #:unsafe-bind-visible to access 'v'
+ ;; Warning: don't do anything that relies on real 'f' before pass2
+
+ ;; If something should be hidden if any hiding occurred in pass1,
+ ;; put it after the Pass2 marker (eg, splice, block->letrec).
+
+ [(R** f v p s ws [#:pass1] . more)
+ #'(parameterize ((hides-flags (cons (box (not (visibility))) (hides-flags))))
+ (DEBUG (printf "** pass1\n"))
+ (R** f v p s ws . more))]
+
+ [(R** f v p s ws [#:pass2 clause ...] . more)
+ #'(let* ([previous-pass-hides? (current-pass-hides?)]
+ [k (lambda (f2 v2 s2 ws2)
+ (parameterize ((hides-flags (cdr (hides-flags))))
+ (when previous-pass-hides? (current-pass-hides? #t))
+ (R** f2 v2 p s2 ws2 . more)))])
+ (DEBUG (printf "** pass2\n"))
+ ;; FIXME: maybe refresh subterms table from v?
+ (visibility-off (not previous-pass-hides?)
+ v
+ (lambda ()
+ (print-viable-subterms v)
+ (R** f v p s ws clause ... => k))
+ #t))]
+
+ [(R** f v p s ws [#:with-visible-form clause ...] . more)
+ #'(let ([k (RP p [#:set-syntax f] . more)])
+ (if (visibility)
+ (R** v v p s ws clause ... => k)
+ (k f v s ws)))]
+
+ [(R** f v p s ws [#:new-local-context clause ...] . more)
+ ;; Note: pass no left-state to subclauses,
+ ;; then discard result state, restore s when return.
+ #'(RSbind (with-new-local-context v (R** f v p #f ws clause ...))
+ (lambda (f2 v2 s2 ws2) (R** f2 v2 p s ws2 . more)))]
;; Subterm handling
- [(R** f p [generator hole fill] . more)
- (let ([k (lambda (f2) (R** f2 p . more))])
- (Run f p generator hole fill k))]))
-
+ [(R** f v p s ws [reducer hole fill] . more)
+ #:declare reducer (expr/c #'(any/c . -> . RST/c))
+ #'(let ([k (RP p . more)]
+ [reducer-var reducer])
+ (Run reducer-var f v p s ws hole fill k))]))
-(define-syntax Run
- (syntax-rules ()
- [(Run f p generator hole fill k)
- (let ([reducer (generator)])
- (Run* reducer f p hole fill k))]))
-
-(define-syntax (Run* stx)
+(define-syntax (Run stx)
(syntax-case stx ()
;; Implementation of subterm handling for (hole ...) sequences
- [(Run* reducer f p (hole :::) fills k)
+ [(Run reducer f v p s ws (hole :::) fills k)
(and (identifier? #':::)
(free-identifier=? #'::: (quote-syntax ...)))
- #'(let ([ctx (CC (hole :::) f p)])
- (let ([e1s (with-syntax ([p f]) (syntax->list #'(hole :::)))])
- (run-multiple reducer ctx fills e1s k)))]
+ #'(let* ([fctx (CC (hole :::) f p)]
+ [init-e1s (with-syntax ([p f]) (syntax->list #'(hole :::)))])
+ (DEBUG
+ (printf "Run (multi, vis=~s)\n" (visibility))
+ (printf " f: ~e\n" (stx->datum f))
+ (printf " v: ~e\n" (stx->datum v))
+ (printf " p: ~e\n" 'p)
+ (printf " hole: ~e\n" '(hole :::))
+ (print-viable-subterms v))
+ (if (visibility)
+ (let ([vctx (CC (hole :::) v p)]
+ [vsubs (with-syntax ([p v]) (syntax->list #'(hole :::)))])
+ (run-multiple/visible reducer init-e1s fctx vsubs vctx fills s ws k))
+ (run-multiple/nonvisible reducer init-e1s fctx v fills s ws k)))]
;; Implementation of subterm handling
- [(Run* reducer f p hole fill k)
- #'(let ([init-e (with-syntax ([p f]) #'hole)]
- [ctx (CC hole f p)])
- (run-one reducer init-e ctx fill k))]))
-
-;; run-one : (a stx -> RS(b)) stx (b -> c) (c -> RS(d)) -> RS(d)
-(define (run-one f init-e ctx fill k)
- (RSbind (lambda () (with-context ctx (f fill init-e)))
- (lambda (final) (k (ctx final)))))
-
-;; run-multiple : (a -> RS(b)) ((list-of b) -> c) (list-of a) (list-of b) (c -> RS(d))
-;; -> RS(d)
-;; For example: a = Deriv; b = c = d = Syntax
-(define (run-multiple f ctx fills suffix k)
- (let loop ([fills fills] [prefix null] [suffix suffix])
+ [(Run reducer f v p s ws hole fill k)
+ #'(let* ([init-e (with-syntax ([p f]) #'hole)]
+ [fctx (CC hole f p)])
+ (DEBUG
+ (printf "Run (single, vis=~s)\n" (visibility))
+ (printf " f: ~e\n" (stx->datum f))
+ (printf " v: ~e\n" (stx->datum v))
+ (printf " p: ~e\n" 'p)
+ (printf " hole: ~e\n" 'hole)
+ (print-viable-subterms v))
+ (if (visibility)
+ (let ([vctx (CC hole v p)]
+ [vsub (with-syntax ([p v]) #'hole)])
+ (run-one reducer init-e fctx vsub vctx fill s ws k))
+ (run-one reducer init-e fctx v values fill s ws k)))]))
+
+;; run-one
+(define (run-one reducer init-e fctx vsub vctx fill s ws k)
+ (DEBUG
+ (printf "run-one\n")
+ (printf " fctx: ~e\n" (stx->datum (fctx #'HOLE)))
+ (printf " vctx: ~e\n" (stx->datum (vctx #'HOLE))))
+ (RSbind (with-context vctx
+ ((reducer fill) init-e vsub s ws))
+ (lambda (f2 v2 s2 ws2) (k (fctx f2) (vctx v2) s2 ws2))))
+
+;; run-multiple/visible
+(define (run-multiple/visible reducer init-e1s fctx vsubs vctx fills s ws k)
+ (DEBUG
+ (printf "run-multiple/visible\n")
+ (printf " fctx: ~e\n" (stx->datum (fctx (for/list ([dummy init-e1s]) #'HOLE))))
+ (printf " vctx: ~e\n" (stx->datum (vctx (for/list ([dummy init-e1s]) #'HOLE)))))
+ (let loop ([fills fills] [prefix null] [vprefix null] [suffix init-e1s] [vsuffix vsubs] [s s] [ws ws])
+ (cond
+ [(pair? fills)
+ (RSbind (with-context (lambda (x) (vctx (revappend vprefix (cons x (cdr vsuffix)))))
+ ((reducer (car fills)) (car suffix) (car vsuffix) s ws))
+ (lambda (f2 v2 s2 ws2)
+ (loop (cdr fills)
+ (cons f2 prefix)
+ (cons v2 vprefix)
+ (cdr suffix)
+ (cdr vsuffix)
+ s2
+ ws2)))]
+ [(null? fills)
+ (k (fctx (reverse prefix)) (vctx (reverse vprefix)) s ws)])))
+
+;; run-multiple/nonvisible
+(define (run-multiple/nonvisible reducer init-e1s fctx v fills s ws k)
+ (DEBUG
+ (printf "run-multiple/nonvisible\n")
+ (printf " fctx: ~e\n" (stx->datum (fctx (for/list ([dummy init-e1s]) #'HOLE)))))
+ (let loop ([fills fills] [prefix null] [suffix init-e1s] [v v] [s s] [ws ws])
+ (DEBUG
+ (printf " v: ~e\n" (stx->datum (datum->syntax #f v))))
(cond
[(pair? fills)
- (RSbind (lambda ()
- (with-context ctx
- (with-context (lambda (x) (revappend prefix (cons x (cdr suffix))))
- (f (car fills) (car suffix)))))
- (lambda (final)
+ (RSbind ((reducer (car fills)) (car suffix) v s ws)
+ (lambda (f2 v2 s2 ws2)
(loop (cdr fills)
- (cons final prefix)
- (cdr suffix))))]
+ (cons f2 prefix)
+ (cdr suffix)
+ v2
+ s2
+ ws2)))]
[(null? fills)
- (let ([form (ctx (reverse prefix))])
- (k form))])))
-
-;; Rename mapping
-
-(define (rename-frontier from to)
- (current-frontier
- (with-handlers ([exn:fail? (lambda _ #f)])
- (apply append
- (map (make-rename-mapping from to)
- (current-frontier))))))
-
-(define (make-rename-mapping from0 to0)
- (define table (make-hasheq))
- (let loop ([from from0] [to to0])
- (cond [(syntax? from)
- (hash-set! table from (flatten-syntaxes to))
- (loop (syntax-e from) to)]
- [(syntax? to)
- (loop from (syntax-e to))]
- [(pair? from)
- #;
- (unless (pair? to)
- (fprintf (current-error-port)
- "from:\n~s\n\n" (syntax->datum from0))
- (fprintf (current-error-port)
- "to:\n~s\n\n" (syntax->datum to0))
- (error 'frontier-renaming))
- (loop (car from) (car to))
- (loop (cdr from) (cdr to))]
- [(vector? from)
- (loop (vector->list from) (vector->list to))]
- [(box? from)
- (loop (unbox from) (unbox to))]
- [else (void)]))
- (lambda (stx)
- (let ([replacement (hash-ref table stx #f)])
- (if replacement
- (begin #;(printf " replacing ~s with ~s~n" stx replacement)
- replacement)
- (begin #;(printf " not replacing ~s~n" stx)
- (list stx))))))
-
-(define (flatten-syntaxes x)
- (cond [(syntax? x)
- (list x)]
- [(pair? x)
- (append (flatten-syntaxes (car x))
- (flatten-syntaxes (cdr x)))]
- [(vector? x)
- (flatten-syntaxes (vector->list x))]
- [(box? x)
- (flatten-syntaxes (unbox x))]
- [else null]))
-
-;; -----------------------------------
-
-;; walk : syntax(es) syntax(es) StepType -> Reduction
-;; Lifts a local step into a term step.
-(define (walk e1 e2 type)
- (make-step (current-derivation) (big-context) type (context)
- (current-definites) (get-frontier)
- (foci e1) (foci e2) e1 e2))
-
-;; walk/foci : syntaxes syntaxes syntax syntax StepType -> Reduction
-(define (walk/foci foci1 foci2 Ee1 Ee2 type)
- (make-step (current-derivation) (big-context) type (context)
- (current-definites) (get-frontier)
- (foci foci1) (foci foci2) Ee1 Ee2))
-
-;; walk/mono : syntax StepType -> Reduction
-(define (walk/mono e1 type)
- (make-mono (current-derivation) (big-context) type (context)
- (current-definites) (get-frontier)
- (foci e1) e1))
-
-;; stumble : syntax exception -> Reduction
-(define (stumble stx exn)
- (make-misstep (current-derivation) (big-context) 'error (context)
- (current-definites) (get-frontier)
- (foci stx) stx exn))
-
-;; stumble/E : syntax(s) syntax exn -> Reduction
-(define (stumble/E focus Ee1 exn)
- (make-misstep (current-derivation) (big-context) 'error (context)
- (current-definites) (get-frontier)
- (foci focus) Ee1 exn))
+ (k (fctx (reverse prefix)) v s ws)])))
;; ------------------------------------
+;; CC
+;; the context constructor
+(define-syntax (CC stx)
+ (syntax-case stx ()
+ [(CC HOLE expr pattern)
+ #'(syntax-copier HOLE expr pattern)]))
+
(define (revappend a b)
(cond [(pair? a) (revappend (cdr a) (cons (car a) b))]
[(null? a) b]))
-(define (foci x)
- (if (list? x)
- x
- (list x)))
+
+;; visibility-off : boolean stx stx (-> a) -> a
+(define (visibility-off new-visible? stx k [reset-subterms? #f])
+ (cond [(and (not new-visible?) (or (visibility) reset-subterms?))
+ (begin
+ (DEBUG
+ (printf "hide => seek: ~e\n" (stx->datum stx)))
+ (current-pass-hides? #t)
+ (let* ([subterms (gather-proper-subterms stx)]
+ [marking (marking-table)]
+ [subterms
+ (if marking
+ (table-apply-renames-mapping
+ subterms
+ (table->renames-mapping marking)
+ #f)
+ subterms)])
+ (parameterize ((visibility #f)
+ (subterms-table subterms)
+ (marking-table (or marking (make-hasheq))))
+ (k))))]
+ [else (k)]))
+
+;; Seek
+
+(provide/contract
+ [seek-point (syntaxish? syntaxish? (syntaxish? . -> . RS/c) . -> . RS/c)])
+
+;; seek-point : stx (-> RS/c) -> RS/c
+(define (seek-point stx vstx k)
+ (if (visibility)
+ (k vstx)
+ (let ([paths (table-get (subterms-table) stx)])
+ (cond [(null? paths)
+ (DEBUG (printf "seek-point: failed on ~e\n" (stx->datum stx)))
+ (k vstx)]
+ [(null? (cdr paths))
+ (let ([path (car paths)])
+ (DEBUG (printf "seek => hide: ~e\n" (stx->datum stx)))
+ (let ([ctx (lambda (x) (path-replace vstx path x))])
+ (RScase (parameterize ((visibility #t)
+ (subterms-table #f)
+ (marking-table #f))
+ ;; Found stx within vstx
+ (with-context ctx (k stx)))
+ (lambda (ws2 stx2 vstx2 s2)
+ (let ([vstx2 (ctx vstx2)])
+ (RSunit ws2 stx2 vstx2 s2)))
+ (lambda (ws exn)
+ (RSfail ws exn)))))]
+ [else
+ (raise (make nonlinearity stx paths))]))))
+
+(provide print-viable-subterms)
+(define (print-viable-subterms stx)
+ (DEBUG
+ (let ([t (subterms-table)])
+ (when t
+ (printf "viable subterms:\n")
+ (let loop ([stx stx])
+ (cond [(syntax? stx)
+ (let ([paths (table-get t stx)])
+ (if (pair? paths)
+ (printf " ~s\n" (stx->datum stx))
+ (loop (syntax-e stx))))]
+ [(pair? stx)
+ (loop (car stx))
+ (loop (cdr stx))]))))))
+
+(define (check-same-stx function actual expected [derivs null])
+ (unless (eq? actual expected)
+ (let* ([actual-datum (stx->datum actual)]
+ [expected-datum (stx->datum expected)]
+ [same-form? (equal? actual-datum expected-datum)])
+ (if same-form?
+ (fprintf (current-error-port)
+ "same form but wrong wrappings:\n~e\nwrongness:\n~e\n"
+ actual-datum
+ (wrongness actual expected))
+ (fprintf (current-error-port)
+ "got:\n~s\n\nexpected:\n~e\n"
+ actual-datum
+ expected-datum))
+ (for ([d derivs])
+ (fprintf (current-error-port)
+ "\n~e\n" d))
+ (error function
+ (if same-form?
+ "wrong starting point (wraps)!"
+ "wrong starting point (form)!")))))
+
+(define (wrongness a b)
+ (cond [(eq? a b)
+ '---]
+ [(stx-list? a)
+ (map wrongness (stx->list a) (stx->list b))]
+ [(stx-pair? a)
+ (cons (wrongness (stx-car a) (stx-car b))
+ (wrongness (stx-cdr a) (stx-cdr b)))]
+ [else (stx->datum a)]))
diff --git a/collects/macro-debugger/model/reductions.ss b/collects/macro-debugger/model/reductions.ss
@@ -10,33 +10,6 @@
(provide reductions
reductions+)
-;; Setup for reduction-engines
-
-(define (Expr) reductions*)
-(define (List) list-reductions)
-(define (Block) block-reductions)
-(define (Transformation)
- transformation-reductions)
-(define (BindSyntaxes)
- bind-syntaxes-reductions)
-(define (CaseLambdaClauses)
- case-lambda-clauses-reductions)
-(define (SynthItems)
- synth-items-reductions)
-(define (BRules)
- brules-reductions)
-(define (ModulePass)
- mbrules-reductions)
-
-;; Syntax
-
-(define-syntax match/with-derivation
- (syntax-rules ()
- [(match/with-derivation d . clauses)
- (let ([dvar d])
- (with-derivation dvar
- (match dvar . clauses)))]))
-
;; Reductions
;; reductions : WDeriv -> ReductionSequence
@@ -47,256 +20,222 @@
;; reductions+ : WDeriv -> (list-of step) (list-of identifier) ?stx ?exn
(define (reductions+ d)
(parameterize ((current-definites null)
- (current-frontier null))
- (when d (add-frontier (list (wderiv-e1 d))))
- (let-values ([(steps stx exn) (reductions* d (wderiv-e1 d))])
- (values steps (current-definites) stx exn))))
+ (current-frontier null)
+ (hides-flags (list (box #f)))
+ (sequence-number 0))
+ (RScase ((Expr d) (wderiv-e1 d) (wderiv-e1 d) #f null)
+ (lambda (steps stx vstx s)
+ (values (reverse steps) (current-definites) vstx #f))
+ (lambda (steps exn)
+ (values (reverse steps) (current-definites) #f exn)))))
-;; reductions* : WDeriv Syntax -> RS(stx)
-(define (reductions* d init-e1)
- (match d
+;; Syntax
+
+(define-syntax-rule (match/count x . clauses)
+ (begin (sequence-number (add1 (sequence-number)))
+ (match x . clauses)))
+
+;; Derivations => Steps
+
+;; Expr : Deriv -> RST
+(define (Expr d)
+ (match/count d
[(Wrap deriv (e1 e2))
- (begin (blaze-frontier e1)
- (unless (eq? init-e1 e1)
- (void)
- #;(fprintf (current-error-port)
- "starting points don't match:\n~s\n~s\n"
- init-e1 e1)
- #;(error 'reductions* "starting points don't match for: ~s" d)))]
- [_ (void)])
+ (R [#:pattern ?form]
+ [#:expect-syntax e1 (list d)]
+ [#:when (base? d)
+ [#:learn (or (base-resolves d) null)]]
+ [#:seek-check]
+ [Expr* ?form d]
+ [#:when (not (current-pass-hides?))
+ [#:set-syntax e2]])]
+ [#f
+ (R [#:seek-check]
+ => (Expr* d))]))
+
+(define (Expr* d)
(match d
- [(Wrap prule (e1 e2 rs ?1))
- (and rs (learn-definites rs))]
- [_ (void)])
- (match/with-derivation d
;; Primitives
[(Wrap p:variable (e1 e2 rs ?1))
- (R e1
- [#:learn (list e2)]
- [#:when/np (not (bound-identifier=? e1 e2))
- [#:walk e2 'resolve-variable]])]
+ (R [#:learn (list e2)]
+ [#: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 e1
- [! ?1]
+ (R [! ?1]
[#:pattern (?module ?name ?language . ?body-parts)]
- #;[#:frontier null (list #'?language #'?body-parts)]
[! ?2]
- #;[#:frontier (list #'?language) null]
- [#:when/np tag
- [#:walk/ctx ?body-parts
- (list tag)
- 'tag-module-begin]]
+ [#:when tag
+ [#:in-hole ?body-parts
+ [#:walk (list tag) 'tag-module-begin]]]
[#:pattern (?module ?name ?language ?body)]
- [#:rename* ?body rename]
- [#:when/np check
- [Expr ?body check]]
- [#:when/np tag2
- [#:walk/ctx ?body
- tag2
- 'tag-module-begin]]
+ [#:rename ?body rename]
+ [#:when check
+ [Expr ?body check]]
+ [#:when tag2
+ [#:in-hole ?body
+ [#:walk tag2 'tag-module-begin]]]
[! ?3]
[Expr ?body body]
[#:pattern ?form]
- [#:rename* ?form shift])]
+ [#:rename ?form shift])]
[(Wrap p:#%module-begin (e1 e2 rs ?1 me pass1 pass2 ?2))
- (R e1
- [! ?1]
- #;[#:let-values (_) (printf "#%module-begin:\n~s\n" me)]
+ (R [! ?1]
[#:pattern ?form]
- [#:rename* ?form me]
+ [#:rename ?form me]
[#:pattern (?module-begin . ?forms)]
- #;[#:frontier (syntax->list #'?forms)]
- #;[#:let-values (_) (printf "#%module-begin ?forms:\n~s\n" #'?forms)]
+ [#:pass1]
[ModulePass ?forms pass1]
+ [#:pass2]
+ [#:do (DEBUG (printf "** module begin pass 2\n"))]
[ModulePass ?forms pass2]
[! ?1])]
[(Wrap p:define-syntaxes (e1 e2 rs ?1 rhs ?2))
- (R e1
- [! ?1]
+ (R [! ?1]
[#:pattern (?define-syntaxes formals ?rhs)]
- [#:frontier (list #'?rhs)]
- [Expr ?rhs rhs]
+ [Expr/PhaseUp ?rhs rhs]
[! ?2])]
[(Wrap p:define-values (e1 e2 rs ?1 rhs))
- (R e1
- [! ?1]
+ (R [! ?1]
[#:pattern (?define-values ?formals ?rhs)]
- [#:frontier (list #'?rhs)]
- ;; RHS can be #f (eg, modprim)
- [#:when/np rhs
- [Expr ?rhs rhs]])]
- [(Wrap p:#%expression (e1 e2 rs ?1 inner))
- (R e1
- [! ?1]
- [#:pattern (?expr ?inner)]
- [#:frontier (list #'?inner)]
+ [#:when rhs
+ [Expr ?rhs rhs]]
+ [#:when (not rhs)
+ [#:do (DEBUG (printf "=== end (dvrhs) ===\n"))]
+ [#:do (DEBUG (printf "===\n"))]])]
+ [(Wrap p:#%expression (e1 e2 rs ?1 inner #f))
+ (R [! ?1]
+ [#:pattern (?expr-kw ?inner)]
[Expr ?inner inner])]
+ [(Wrap p:#%expression (e1 e2 rs ?1 inner untag))
+ (R [! ?1]
+ [#:pattern (?expr-kw ?inner)]
+ [#:pass1]
+ [Expr ?inner inner]
+ [#:pattern ?form]
+ [#:with-visible-form
+ [#:left-foot]
+ [#:set-syntax (stx-car (stx-cdr #'?form))]
+ [#:step 'macro]]
+ [#:pass2]
+ [#:set-syntax (stx-car (stx-cdr #'?form))]
+ [#:rename ?form untag])]
[(Wrap p:if (e1 e2 rs ?1 test then else))
- (R e1
- [! ?1]
+ (R [! ?1]
[#:pattern (?if TEST THEN ELSE)]
- [#:frontier (list #'TEST #'THEN #'ELSE)]
[Expr TEST test]
[Expr THEN then]
[Expr ELSE else])]
[(Wrap p:wcm (e1 e2 rs ?1 key mark body))
- (R e1
- [! ?1]
+ (R [! ?1]
[#:pattern (?wcm KEY MARK BODY)]
- [#:frontier (list #'KEY #'MARK #'BODY)]
[Expr KEY key]
[Expr MARK mark]
[Expr BODY body])]
[(Wrap p:begin (e1 e2 rs ?1 lderiv))
- (R e1
- [! ?1]
+ (R [! ?1]
[#:pattern (?begin . ?lderiv)]
- [#:frontier (stx->list* #'?lderiv)]
[List ?lderiv lderiv])]
[(Wrap p:begin0 (e1 e2 rs ?1 first lderiv))
- (R e1
- [! ?1]
+ (R [! ?1]
[#:pattern (?begin0 FIRST . LDERIV)]
- [#:frontier (cons #'FIRST (stx->list* #'LDERIV))]
[Expr FIRST first]
[List LDERIV lderiv])]
[(Wrap p:#%app (e1 e2 rs ?1 lderiv))
- (R e1
- [! ?1]
+ (R [! ?1]
[#:pattern (?app . LDERIV)]
- [#:frontier (stx->list* #'LDERIV)]
- [List LDERIV lderiv])]
+ [#:if lderiv
+ ([List LDERIV lderiv])
+ ([#:walk e2 'macro])])]
[(Wrap p:lambda (e1 e2 rs ?1 renames body))
- (R e1
- [! ?1]
+ (R [! ?1]
[#:pattern (?lambda ?formals . ?body)]
- [#:frontier (stx->list* #'?body)]
- [#:rename* (?formals . ?body) renames 'rename-lambda]
+ [#:rename (?formals . ?body) renames 'rename-lambda]
[Block ?body body])]
[(Wrap p:case-lambda (e1 e2 rs ?1 clauses))
- (R e1
- [! ?1]
+ (R [! ?1]
[#:pattern (?case-lambda . ?clauses)]
- [#:frontier (stx->list* #'?clauses)]
[CaseLambdaClauses ?clauses clauses])]
[(Wrap p:let-values (e1 e2 rs ?1 renames rhss body))
- (R e1
- [! ?1]
+ (R [! ?1]
[#:pattern (?let-values ([?vars ?rhs] ...) . ?body)]
- [#:frontier (append (syntax->list #'(?rhs ...)) (stx->list* #'?body))]
- [#:rename* (((?vars ?rhs) ...) . ?body) renames 'rename-let-values]
+ [#:rename (((?vars ?rhs) ...) . ?body) renames 'rename-let-values]
[Expr (?rhs ...) rhss]
[Block ?body body])]
[(Wrap p:letrec-values (e1 e2 rs ?1 renames rhss body))
- (R e1
- [! ?1]
+ (R [! ?1]
[#:pattern (?letrec-values ([?vars ?rhs] ...) . ?body)]
- [#:frontier (append (syntax->list #'(?rhs ...)) (stx->list* #'?body))]
- [#:rename* (((?vars ?rhs) ...) . ?body) renames 'rename-letrec-values]
+ [#:rename (((?vars ?rhs) ...) . ?body) renames 'rename-letrec-values]
[Expr (?rhs ...) rhss]
[Block ?body body])]
[(Wrap p:letrec-syntaxes+values
- (e1 e2 rs ?1 srenames srhss vrenames vrhss body))
- (R e1
- [! ?1]
+ (e1 e2 rs ?1 srenames srhss vrenames vrhss body tag))
+ (R [! ?1]
+ [#:pass1]
[#:pattern (?lsv ([?svars ?srhs] ...) ([?vvars ?vrhs] ...) . ?body)]
- [#:frontier (append (syntax->list #'(?srhs ...))
- (syntax->list #'(?vrhs ...))
- (stx->list* #'?body))]
- [#:rename* (((?svars ?srhs) ...) ((?vvars ?vrhs) ...) . ?body) srenames
+ [#:rename (((?svars ?srhs) ...) ((?vvars ?vrhs) ...) . ?body)
+ srenames
'rename-lsv]
[BindSyntaxes (?srhs ...) srhss]
;; If vrenames is #f, no var bindings to rename
- [#:when/np vrenames
- [#:bind (([?vvars** ?vrhs**] ...) . ?body**) vrenames]
- [#:rename* (((?vars ?vrhs) ...) . ?body) vrenames 'rename-lsv]]
+ [#:when vrenames
+ [#:rename (((?vvars ?vrhs) ...) . ?body) vrenames 'rename-lsv]]
[Expr (?vrhs ...) vrhss]
[Block ?body body]
+ [#:pass2]
[#:pattern ?form]
- [#:when/np (not (eq? #'?form e2)) ;; FIXME: correct comparison?
- [#:walk e2 'lsv-remove-syntax]])]
-
+ [#:when tag
+ [#:walk tag 'lsv-remove-syntax]])]
[(Wrap p:#%datum (e1 e2 rs ?1))
- (R e1
- [! ?1]
+ (R [! ?1]
+ [#:hide-check rs]
[#:walk e2 'macro])]
[(Wrap p:#%top (e1 e2 rs ?1))
- (R e1
+ (R [! ?1]
[#:pattern (?top . ?var)]
- [#:learn (list #'?var)]
- [! ?1])]
+ [#:learn (list #'?var)])]
[(Wrap p:provide (e1 e2 rs ?1))
- (R e1
- [! ?1]
+ (R [! ?1]
[#:walk e2 'provide])]
+ [(Wrap p:stop (e1 e2 rs ?1))
+ (R [! ?1])]
+
;; The rest of the automatic primitives
[(Wrap p::STOP (e1 e2 rs ?1))
- (R e1
- [! ?1])]
+ (R [! ?1])]
[(Wrap p:set!-macro (e1 e2 rs ?1 deriv))
- (R e1
- [! ?1]
- [#:frontier (list e1)]
+ (R [! ?1]
[#:pattern ?form]
[Expr ?form deriv])]
[(Wrap p:set! (e1 e2 rs ?1 id-rs rhs))
- (R e1
- [! ?1]
+ (R [! ?1]
[#:pattern (?set! ?var ?rhs)]
- [#:frontier (list #'?rhs)]
[#:learn id-rs]
[Expr ?rhs rhs])]
- ;; Synthetic primitives
- ;; These have their own subterm replacement mechanisms
- [(Wrap p:synth (e1 e2 rs ?1 subterms ?2))
- (R e1
- [! ?1]
- [#:pattern ?form]
- [#:frontier
- ;; Compute the frontier based on the expanded subterms
- ;; Run through the renames in reverse order to get the
- ;; pre-renamed terms
- (parameterize ((current-frontier null))
- (let loop ([subterms subterms])
- (cond [(null? subterms)
- (void)]
- [(s:subterm? (car subterms))
- (loop (cdr subterms))
- (add-frontier
- (list (wderiv-e1 (s:subterm-deriv (car subterms)))))]
- [(s:rename? (car subterms))
- (loop (cdr subterms))
- (rename-frontier (s:rename-after (car subterms))
- (s:rename-before (car subterms)))]))
- (current-frontier))]
- [SynthItems ?form subterms]
- [! ?2])]
-
- ;; FIXME: elimiate => ??
- [(Wrap p:rename (e1 e2 rs ?1 rename inner))
- (R e1
- [! ?1]
- [#:pattern ?form]
- =>
- (lambda (e)
- (rename-frontier (car rename) (cdr rename))
- (reductions* inner (wderiv-e1 inner))))]
-
;; Macros
- [(Wrap mrule (e1 e2 transformation next))
- (R e1
+ [(Wrap mrule (e1 e2 rs ?1 me1 locals me2 ?2 etx next))
+ (R [! ?1]
[#:pattern ?form]
- [Transformation ?form transformation]
- [#:frontier (list (wderiv-e1 next))]
+ [#:hide-check rs]
+ [#:learn rs]
+ [#:pass1]
+ [#:left-foot]
+ [#:rename/mark ?form e1 me1] ;; MARK
+ [LocalActions ?form locals]
+ [! ?2]
+ [#:pass2]
+ [#:set-syntax me2]
+ [#:rename/unmark ?form me2 etx] ;; UNMARK
+ [#:step 'macro]
+ [#:set-syntax etx]
[Expr ?form next])]
[(Wrap tagrule (e1 e2 tagged-stx next))
- (R e1
- [#:pattern ?form]
+ (R [#:pattern ?form]
+ [#:hide-check (list (stx-car tagged-stx))]
[#:walk tagged-stx
(case (syntax-e (stx-car tagged-stx))
((#%app) 'tag-app)
@@ -309,242 +248,343 @@
;; Lifts
[(Wrap lift-deriv (e1 e2 first lifted-stx second))
- (R e1
- [#:pattern ?form]
- [Expr ?form first]
- [#:frontier (list lifted-stx)]
- [#:walk lifted-stx 'capture-lifts]
- [Expr ?form second])]
+ (R [#:pattern ?form]
+ ;; lifted-stx has form (begin lift-n ... lift-1 orig-expr)
+ [#:let mid-stxs (reverse (stx->list (stx-cdr lifted-stx)))]
+ [#:let lifted-def-stxs (cdr mid-stxs)]
+ [#:let main-stx (car mid-stxs)]
+ [#:parameterize ((available-lift-stxs lifted-def-stxs)
+ (visible-lift-stxs null))
+ [#:pass1]
+ [Expr ?form first]
+ [#:do (when (pair? (available-lift-stxs))
+ (error 'lift-deriv "available lifts left over"))]
+ [#:let begin-stx (stx-car lifted-stx)]
+ [#:with-visible-form
+ ;; If no lifts visible, then don't show begin-wrapping
+ [#:when (pair? (visible-lift-stxs))
+ [#:walk (datum->syntax lifted-stx
+ `(,begin-stx ,@(visible-lift-stxs) ,#'?form)
+ lifted-stx
+ lifted-stx)
+ 'capture-lifts]]]
+ [#:pass2]
+ [#:set-syntax lifted-stx]
+ [Expr ?form second]])]
[(Wrap lift/let-deriv (e1 e2 first lifted-stx second))
- (R e1
- [#:pattern ?form]
- [Expr ?form first]
- [#:frontier (list lifted-stx)]
- [#:walk lifted-stx 'capture-lifts]
- [Expr ?form second])]
+ (R [#:pattern ?form]
+ ;; lifted-stx has form
+ ;; (let-values ((last-v last-lifted))
+ ;; ...
+ ;; (let-values ((first-v first-lifted)) orig-expr))
+ [#:let first-e2 (wderiv-e2 first)]
+ [#:let lift-stxs (take-lift/let-stxs lifted-stx first-e2)]
+ [#:parameterize ((available-lift-stxs lift-stxs)
+ (visible-lift-stxs null))
+ [#:pass1]
+ [Expr ?form first]
+ [#:do (when (pair? (available-lift-stxs))
+ (error 'lift/let-deriv "available lifts left over"))]
+ [#:let visible-lifts (visible-lift-stxs)]
+ [#:with-visible-form
+ [#:left-foot]
+ [#:set-syntax (reconstruct-lift/let-stx visible-lifts #'?form)]
+ [#:step 'capture-lifts]]
+ [#:pass2]
+ [#:set-syntax lifted-stx]
+ [Expr ?form second]])]
;; Skipped
- [#f (RSunit init-e1)]))
+ [#f
+ (R)]))
+
+(define (take-lift/let-stxs lifted-stx base)
+ (let loop ([lifted-stx lifted-stx] [acc null])
+ (if (eq? lifted-stx base)
+ acc
+ (with-syntax ([(?let ?binding ?inner) lifted-stx])
+ (loop #'?inner (cons (list #'?let #'?binding) acc))))))
+(define (reconstruct-lift/let-stx lifts base)
+ (if (null? lifts)
+ base
+ (datum->syntax base
+ `(,@(car lifts) ,(reconstruct-lift/let-stx (cdr lifts) base)))))
+
+;; Expr/PhaseUp : Deriv -> RST
+(define (Expr/PhaseUp d)
+ (R [#:parameterize ((phase (add1 (phase))))
+ => (Expr* d)]))
;; case-lambda-clauses-reductions :
-;; (list-of (W (list ?exn rename (W BDeriv)))) stxs -> (RS stxs)
-(define (case-lambda-clauses-reductions clauses es1)
- (blaze-frontier es1)
- (match clauses
+;; (list-of (W (list ?exn rename (W BDeriv)))) stxs -> RST
+(define (CaseLambdaClauses clauses)
+ (match/count clauses
['()
- (RSunit null)]
+ (R)]
[(cons (Wrap clc (?1 rename body)) rest)
- (R es1
- [! ?1]
+ (R [! ?1]
[#:pattern ((?formals . ?body) . ?rest)]
- [#:frontier (list #'?body #'?rest)]
- [#:rename* (?formals . ?body) rename 'rename-case-lambda]
+ [#:rename (?formals . ?body) rename 'rename-case-lambda]
[Block ?body body]
[CaseLambdaClauses ?rest rest])]))
-;; synth-items-reductions : (list-of SynthItem) syntax -> (RS syntax)
-(define (synth-items-reductions subterms e1)
- (let loop ([term e1] [subterms subterms])
- (cond [(null? subterms)
- (RSunit e1)]
- [(s:subterm? (car subterms))
- (let* ([subterm0 (car subterms)]
- [path0 (s:subterm-path subterm0)]
- [deriv0 (s:subterm-deriv subterm0)])
- (let ([ctx (lambda (x) (path-replace term path0 x))]
- ;; unused: may not be the same, due to mark/unmark???
- [init-e (path-get term path0)])
- (RSseq (lambda ()
- (with-context ctx
- (reductions* deriv0 (wderiv-e1 deriv0))))
- (lambda ()
- (loop (path-replace term path0 (wderiv-e2 deriv0))
- (cdr subterms))))))]
- [(s:rename? (car subterms))
- (let* ([subterm0 (car subterms)])
- ;; FIXME: add renaming steps?
- ;; FIXME: if so, coalesce?
- (rename-frontier (s:rename-before subterm0)
- (s:rename-after subterm0))
- (loop (path-replace term
- (s:rename-path subterm0)
- (s:rename-after subterm0))
- (cdr subterms)))])))
-
-;; transformation-reductions : Transformation stx -> (RS Stx)
-(define (transformation-reductions tx init-e1)
- (match tx
- [(Wrap transformation (e1 e2 rs ?1 me1 locals me2 ?2 seq))
- (R e1
- [! ?1]
- [#:pattern ?form]
- [#:learn rs]
- [#:reductions (reductions-locals e1 locals)]
- [! ?2]
- [#:walk e2 'macro])]))
-
-;; reductions-locals : syntax (list-of LocalAction) -> (RS void)
-(define (reductions-locals stx locals)
- (with-new-local-context stx
- (RSforeach reductions-local locals)))
-
-;; reductions-local : LocalAction -> (RS void)
-(define (reductions-local local)
- (match/with-derivation local
- [(struct local-expansion (e1 e2 me1 me2 deriv for-stx? lifted opaque))
- ;; FIXME
- ;; When lifted is present, need to locally rearrange lifts!
- (when (or lifted opaque)
- (fprintf (current-error-port)
- "reductions: local-expand-expr not fully implemented"))
- (reductions* deriv me1)]
+;; local-actions-reductions
+(define (LocalActions locals)
+ (match locals
+ ['()
+ (R)]
+ [(cons local rest)
+ (R [#:pattern ?form]
+ [#:if (visibility)
+ ;; If macro with local-expand is transparent,
+ ;; then all local-expansions must be transparent.
+ ([#:parameterize ((macro-policy (lambda _ #t)))
+ [#:new-local-context
+ [LocalAction ?form local]]])
+ ([#:pass1]
+ [LocalAction ?form local]
+ [#:pass2])]
+ [LocalActions ?form rest])]))
+
+(define (LocalAction local)
+ (match/count local
+ [(struct local-expansion (e1 e2 for-stx? me1 inner #f me2 opaque))
+ (R [#:do (when opaque
+ (fprintf (current-error-port)
+ "LocalAction: local-expand-expr\n"))]
+ [#:parameterize ((phase (if for-stx? (add1 (phase)) (phase))))
+ [#:set-syntax e1]
+ [#:pattern ?form]
+ [#:rename/mark ?form e1 me1]
+ [Expr ?form inner]
+ [#:rename/mark ?form me2 e2]])]
+ [(struct local-expansion (e1 e2 for-stx? me1 inner lifted me2 opaque))
+ (R [#:do (when opaque
+ (fprintf (current-error-port)
+ "LocalAction: not handling opaque val\n"))]
+ [#:let begin-stx (stx-car lifted)]
+ [#:let lift-stxs (cdr (reverse (stx->list (stx-cdr lifted))))]
+ [#:parameterize ((phase (if for-stx? (add1 (phase)) (phase)))
+ (available-lift-stxs lift-stxs)
+ (visible-lift-stxs null))
+ [#:set-syntax e1]
+ [#:pattern ?form]
+ [#:rename/unmark ?form e1 me1]
+ [#:pass1]
+ [Expr ?form inner]
+ [#:do (when (pair? (available-lift-stxs))
+ (error 'local-expand/capture-lifts "available lifts left over"))]
+ [#:let visible-lifts (visible-lift-stxs)]
+ [#:with-visible-form
+ [#:left-foot]
+ [#:set-syntax (datum->syntax lifted
+ `(,begin-stx ,@visible-lifts ,#'?form)
+ lifted lifted)]
+ [#:step 'splice-lifts visible-lifts]]
+ [#:pass2]
+ [#:set-syntax lifted]
+ [#:rename/mark ?form me2 e2]])]
[(struct local-lift (expr id))
- (RSadd (list (walk expr id 'local-lift))
- RSzero)]
+ ;; FIXME: add action
+ (R [#:do (unless (pair? (available-lift-stxs))
+ (error 'local-lift "out of lifts!"))
+ (when (pair? (available-lift-stxs))
+ (let ([lift-d (car (available-lift-stxs))]
+ [lift-stx (car (available-lift-stxs))])
+ (when (visibility)
+ (visible-lift-stxs (cons lift-stx (visible-lift-stxs))))
+ (available-lift-stxs (cdr (available-lift-stxs)))))]
+ [#:reductions (list (walk expr id 'local-lift))])]
[(struct local-lift-end (decl))
- (RSadd (list (walk/mono decl 'module-lift))
- RSzero)]
- [(struct local-bind (names bindrhs))
- (bind-syntaxes-reductions bindrhs)]))
-
-;; list-reductions : ListDerivation stxs -> (RS Stxs)
-(define (list-reductions ld init-es1)
- (match/with-derivation ld
+ ;; (walk/mono decl 'module-lift)
+ (R)]
+ [(struct local-bind (names ?1 renames bindrhs))
+ [R [! ?1]
+ ;; FIXME: use renames
+ [#:when bindrhs => (BindSyntaxes bindrhs)]]]))
+
+;; List : ListDerivation -> RST
+(define (List ld)
+ (match ld
[(Wrap lderiv (es1 es2 ?1 derivs))
- (R es1
- [! ?1]
+ (R [! ?1]
[#:pattern (?form ...)]
[Expr (?form ...) derivs])]
- [#f (RSunit null)]))
+ [#f
+ (R)]))
-;; block-reductions : BlockDerivation stxs -> (RS Stxs)
-(define (block-reductions bd init-es1)
- (match/with-derivation bd
+;; Block : BlockDerivation -> RST
+(define (Block bd)
+ (match/count bd
[(Wrap bderiv (es1 es2 pass1 trans pass2))
- (R es1
- [#:pattern ?form]
- [BRules ?form pass1]
- [#:when/np (eq? trans 'letrec)
- [#:walk (wlderiv-es1 pass2) 'block->letrec]]
- [#:frontier (stx->list* (wlderiv-es1 pass2))]
- [#:pattern ?form]
- [List ?form pass2])]
- [#f (RSunit null)]))
+ (R [#:pattern ?block]
+ [#:parameterize ((block-syntax-bindings null)
+ (block-value-bindings null)
+ (block-expressions null))
+ [#:pass1]
+ [BlockPass ?block pass1]
+ [#:pass2]
+ [#:when (eq? trans 'letrec)
+ [#:walk
+ (let* ([pass2-stxs (wlderiv-es1 pass2)]
+ [letrec-form (car pass2-stxs)]
+ [letrec-kw (stx-car letrec-form)]
+ [stx-bindings (reverse (block-syntax-bindings))]
+ [val-bindings (reverse (block-value-bindings))]
+ [exprs (block-expressions)]
+ [mk-letrec-form (lambda (x) (datum->syntax #f x))])
+ (list
+ (mk-letrec-form
+ `(,letrec-kw ,@(if (pair? stx-bindings)
+ (list stx-bindings)
+ null)
+ ,val-bindings
+ . ,exprs))))
+ 'block->letrec]]
+ [#:rename ?block (wlderiv-es1 pass2)]
+ [#:set-syntax (wlderiv-es1 pass2)]
+ [List ?block pass2]])]
+ [#f
+ (R)]))
-;; brules-reductions : (list-of BRule) stxs -> (RS Stxs)
-(define (brules-reductions brules es1)
- (match brules
+;; BlockPass : (list-of BRule) -> RST
+(define (BlockPass brules)
+ (match/count brules
['()
- (RSunit null)]
- [(cons (Wrap b:expr (renames head)) rest)
- (R es1
- [#:pattern (?first . ?rest)]
- [#:bind ?first* (cdr renames)]
+ (R)]
+ [(cons (Wrap b:error (exn)) rest)
+ (R [! exn])]
+ [(cons (Wrap b:splice (renames head ?1 tail ?2)) rest)
+ (R [#:pattern (?first . ?rest)]
[#:rename/no-step ?first (car renames) (cdr renames)]
+ [#:pass1]
[Expr ?first head]
- [BRules ?rest rest])]
- [(cons (Wrap b:defvals (renames head ?1)) rest)
- (R es1
- [#:pattern (?first . ?rest)]
- [#:bind ?first* (cdr renames)]
+ [! ?1]
+ [#:pass2]
+ [#:let begin-form #'?first]
+ [#:let rest-forms #'?rest]
+ [#:pattern ?forms]
+ [#:left-foot (list begin-form)]
+ [#:set-syntax (append (stx->list (stx-cdr begin-form)) rest-forms)]
+ [#:step 'splice-block (stx->list (stx-cdr begin-form))]
+ [#:rename ?forms tail]
+ [! ?2]
+ [#:pattern ?forms]
+ [BlockPass ?forms rest])]
+
+ ;; FIXME: are these pass1/2 necessary?
+
+ [(cons (Wrap b:defvals (renames head ?1 rename ?2)) rest)
+ (R [#:pattern (?first . ?rest)]
[#:rename/no-step ?first (car renames) (cdr renames)]
+ [#:pass1]
[Expr ?first head]
[! ?1]
- [#:pattern ((?define-values ?vars ?rhs) . ?rest)]
- [#:learn (syntax->list #'?vars)]
- [BRules ?rest rest])]
- [(cons (Wrap b:defstx (renames head ?1 bindrhs)) rest)
- (R es1
+ [#:pass2]
+ [#:pattern ((?define-values . ?clause) . ?rest)]
+ [#:rename ?clause rename]
+ [! ?2]
+ [#:do (block-value-bindings
+ (cons #'?clause (block-value-bindings)))]
[#:pattern (?first . ?rest)]
- [#:bind ?first* (cdr renames)]
+ [BlockPass ?rest rest])]
+ [(cons (Wrap b:defstx (renames head ?1 rename ?2 bindrhs)) rest)
+ (R [#:pattern (?first . ?rest)]
[#:rename/no-step ?first (car renames) (cdr renames)]
+ [#:pass1]
[Expr ?first head]
[! ?1]
+ [#:pass2]
+ [#:pattern ((?define-syntaxes . ?clause) . ?rest)]
+ [#:rename ?clause rename]
+ [! ?2]
+ [#:do (block-syntax-bindings
+ (cons #'?clause (block-syntax-bindings)))]
[#:pattern ((?define-syntaxes ?vars ?rhs) . ?rest)]
- [#:learn (syntax->list #'?vars)]
[BindSyntaxes ?rhs bindrhs]
- [BRules ?rest rest])]
- [(cons (Wrap b:splice (renames head ?1 tail ?2)) rest)
- (R es1
[#:pattern (?first . ?rest)]
- [#:bind ?first* (cdr renames)]
+ [BlockPass ?rest rest])]
+ [(cons (Wrap b:expr (renames head)) rest)
+ (R [#:pattern (?first . ?rest)]
[#:rename/no-step ?first (car renames) (cdr renames)]
[Expr ?first head]
- [! ?1]
- [#:walk/foci tail
- (list #'?first)
- (stx-take tail (- (stx-improper-length tail)
- (stx-improper-length #'?rest)))
- 'splice-block]
- [! ?2]
- [#:pattern ?forms]
- [BRules ?forms rest])]
- [(cons (Wrap b:error (exn)) rest)
- (R es1
- [! exn])]))
+ [#:do (block-expressions #'(?first . ?rest))]
+ ;; rest better be empty
+ [BlockPass ?rest rest])]
-;; bind-syntaxes-reductions : BindSyntaxes stx -> (RS stx)
-(define (bind-syntaxes-reductions bindrhs init-e1)
+ ))
+
+;; BindSyntaxes : BindSyntaxes -> RST
+(define (BindSyntaxes bindrhs)
(match bindrhs
[(Wrap bind-syntaxes (rhs ?1))
- (R (wderiv-e1 rhs)
- [#:pattern ?form]
- [Expr ?form rhs]
+ (R [#:pattern ?form]
+ [Expr/PhaseUp ?form rhs]
[! ?1])]))
-;; mbrules-reductions : -> (list-of MBRule) stxs -> (RS stxs)
-(define (mbrules-reductions mbrules es1)
- (match mbrules
+;; ModulePass : (list-of MBRule) -> RST
+(define (ModulePass mbrules)
+ (match/count mbrules
['()
- (RSunit null)]
+ (R)]
[(cons (Wrap mod:prim (head rename prim)) rest)
- (R es1
- [#:pattern (?firstP . ?rest)]
+ (R [#:pattern (?firstP . ?rest)]
[Expr ?firstP head]
- [#:rename* ?firstP rename]
- [Expr ?firstP prim]
+ [#:do (DEBUG (printf "** after head\n"))]
+ [#:rename ?firstP rename]
+ [#:do (DEBUG (printf "** after rename\n"))]
+ [#:when prim
+ [Expr ?firstP prim]]
+ [#:do (DEBUG (printf "** after prim\n"))]
[ModulePass ?rest rest])]
[(cons (Wrap mod:splice (head rename ?1 tail)) rest)
- (R es1
- [#:pattern (?firstB . ?rest)]
+ (R [#:pattern (?firstB . ?rest)]
+ [#:pass1]
[Expr ?firstB head]
- [#:rename* ?firstB rename]
+ [#:rename ?firstB rename]
[! ?1]
- [#:walk/foci tail
- (list #'?firstB)
- (stx-take tail (- (stx-improper-length tail)
- (stx-improper-length #'?rest)))
- 'splice-module]
+ [#:pass2]
+ [#:let begin-form #'?firstB]
+ [#:let rest-forms #'?rest]
[#:pattern ?forms]
+ [#:left-foot (list #'?firstB)]
+ [#:set-syntax (append (stx->list (stx-cdr begin-form)) rest-forms)]
+ [#:step 'splice-module (stx->list (stx-cdr begin-form))]
+ [#:rename ?forms tail]
[ModulePass ?forms rest])]
[(cons (Wrap mod:lift (head renames stxs)) rest)
- (R es1
- [#:pattern (?firstL . ?rest)]
- [Expr ?firstL head]
- [#:pattern ?forms]
- [#:when/np renames
- [#:rename* ?forms renames]]
- [#:walk/foci (append stxs #'?forms)
- null
- stxs
- 'splice-lifts]
- [ModulePass ?forms rest])]
+ (R [#:pattern (?firstL . ?rest)]
+ ;; renames has form (head-e2 . ?rest)
+ ;; stxs has form (lifted ...), specifically (last-lifted ... first-lifted)
+ [#:parameterize ((available-lift-stxs (reverse stxs))
+ (visible-lift-stxs null))
+ [#:pass1]
+ [Expr ?firstL head]
+ [#:do (when (pair? (available-lift-stxs))
+ (error 'mod:lift "available lifts left over"))]
+ [#:let visible-lifts (visible-lift-stxs)]
+ [#:pattern ?forms]
+ [#:pass2]
+ [#:when renames
+ [#:rename ?forms renames]]
+ [#:let old-forms #'?forms]
+ [#:left-foot null]
+ [#:set-syntax (append visible-lifts old-forms)]
+ [#:step 'splice-lifts visible-lifts]
+ [#:set-syntax (append stxs old-forms)]
+ [ModulePass ?forms rest]])]
[(cons (Wrap mod:lift-end (stxs)) rest)
- (R es1
- [#:pattern ?forms]
- [#:when/np (pair? stxs)
- [#:walk/foci (append stxs #'?forms)
- null
- stxs
- 'splice-module-lifts]]
+ (R [#:pattern ?forms]
+ [#:when (pair? stxs)
+ [#:left-foot null]
+ [#:set-syntax (append stxs #'?forms)]
+ [#:step 'splice-module-lifts stxs]]
[ModulePass ?forms rest])]
[(cons (Wrap mod:skip ()) rest)
- (R es1
- [#:pattern (?firstS . ?rest)]
+ (R [#:pattern (?firstS . ?rest)]
[ModulePass ?rest rest])]
[(cons (Wrap mod:cons (head)) rest)
- (R es1
- [#:pattern (?firstC . ?rest)]
+ (R [#:pattern (?firstC . ?rest)]
[Expr ?firstC head]
[ModulePass ?rest rest])]))
diff --git a/collects/macro-debugger/model/steps.ss b/collects/macro-debugger/model/steps.ss
@@ -3,35 +3,40 @@
(require "deriv.ss"
"deriv-util.ss"
"deriv-find.ss")
-(provide (all-defined-out))
-
-;; A ReductionSequence is a (list-of Reduction)
-
-;; A ProtoStep is (make-protostep Derivation BigContext StepType Context Definites)
+(provide (struct-out protostep)
+ (struct-out step)
+ (struct-out misstep)
+ (struct-out state)
+ (struct-out bigframe)
+ context-fill
+ state-term
+ step-term1
+ step-term2
+ misstep-term1
+ bigframe-term
+ step-type?
+ step-type->string
+ rewrite-step?
+ rename-step?)
+
+;; A ReductionSequence is (listof Step)
+;; A Step is one of
+;; - (make-step StepType State State)
+;; - (make-misstep StepType State exn)
+(define-struct protostep (type s1) #:transparent)
+(define-struct (step protostep) (s2) #:transparent)
+(define-struct (misstep protostep) (exn) #:transparent)
+
+;; A State is
+;; (make-state stx stxs Context BigContext (listof id) (listof id) (listof stx) nat/#f)
+(define-struct state (e foci ctx lctx binders uses frontier seq) #:transparent)
;; A Context is a list of Frames
-;; A Frame is either:
-;; - (syntax -> syntax)
-;; - (make-renames syntax syntax)
-;; - 'phase-up
-(define-struct renames (old new))
-
-;; A Definite is a (list-of identifier)
+;; A Frame is (syntax -> syntax)
;; A BigContext is (list-of BigFrame)
-;; A BigFrame is (make-bigframe Derivation Context Syntaxes Syntax)
-(define-struct bigframe (deriv ctx foci e))
-
-;; A Reduction is one of
-;; - (make-step ... Syntaxes Syntaxes Syntax Syntax)
-;; - (make-mono ... Syntaxes Syntax)
-;; - (make-misstep ... Syntax Syntax Exception)
-
-(define-struct protostep (deriv lctx type ctx definites frontier) #:transparent)
-
-(define-struct (step protostep) (foci1 foci2 e1 e2) #:transparent)
-(define-struct (mono protostep) (foci1 e1) #:transparent)
-(define-struct (misstep protostep) (foci1 e1 exn) #:transparent)
+;; A BigFrame is (make-bigframe Context Syntaxes Syntax)
+(define-struct bigframe (ctx foci e))
;; context-fill : Context Syntax -> Syntax
(define (context-fill ctx stx)
@@ -39,32 +44,18 @@
(if (null? ctx)
stx
(let ([frame0 (car ctx)])
- (if (procedure? frame0)
- (loop (cdr ctx) (frame0 stx))
- (loop (cdr ctx) stx))))))
+ (loop (cdr ctx) (frame0 stx))))))
-;; context-env : Context -> (list-of identifier)
-(define (context-env ctx)
- (let loop ([ctx ctx] [env null])
- (if (null? ctx)
- env
- (let ([frame0 (car ctx)])
- (if (renames? frame0)
- (loop (cdr ctx)
- (append (flatten-identifiers (renames-new frame0))
- env))
- (loop (cdr ctx) env))))))
+(define (state-term s)
+ (context-fill (state-ctx s) (state-e s)))
(define (step-term1 s)
- (context-fill (protostep-ctx s) (step-e1 s)))
+ (state-term (protostep-s1 s)))
(define (step-term2 s)
- (context-fill (protostep-ctx s) (step-e2 s)))
-
-(define (mono-term1 s)
- (context-fill (protostep-ctx s) (mono-e1 s)))
+ (state-term (step-s2 s)))
(define (misstep-term1 s)
- (context-fill (protostep-ctx s) (misstep-e1 s)))
+ (state-term (protostep-s1 s)))
(define (bigframe-term bf)
(context-fill (bigframe-ctx bf) (bigframe-e bf)))
@@ -104,6 +95,11 @@
[(string? x) x]
[else (error 'step-type->string "not a step type: ~s" x)]))
+(define step-type?
+ (let ([step-types (map car step-type-meanings)])
+ (lambda (x)
+ (and (memq x step-types) #t))))
+
(define (rename-step? x)
(memq (protostep-type x)
'(rename-lambda
diff --git a/collects/macro-debugger/model/stx-util.ss b/collects/macro-debugger/model/stx-util.ss
@@ -11,6 +11,9 @@
(datum->syntax template datum template template)
datum))
+(define (stx->datum x)
+ (syntax->datum (datum->syntax #f x)))
+
(define-syntax (syntax-copier stx)
(syntax-case stx ()
[(syntax-copier hole expr pattern)
@@ -79,6 +82,20 @@
(cons (car items) (take-if-possible (cdr items) (sub1 n)))
null))
+(define (reverse-take-if-possible items n)
+ (define (loop items n acc)
+ (if (and (pair? items) (positive? n))
+ (loop (cdr items) (sub1 n) (cons (car items) acc))
+ acc))
+ (loop items n null))
+
+(define (reverse-take-until items tail)
+ (define (loop items acc)
+ (if (and (pair? items) (not (eq? items tail)))
+ (loop (cdr items) (cons (car items) acc))
+ null))
+ (loop items null))
+
;; stx-improper-length : syntax -> number
(define (stx-improper-length stx)
(let loop ([stx stx] [n 0])
@@ -97,3 +114,11 @@
(cons (car x) (stx->list* (cdr x)))
(list stx)))]
[else null]))
+
+
+(define (syntaxish? x)
+ (or (syntax? x)
+ (null? x)
+ (and (pair? x)
+ (syntaxish? (car x))
+ (syntaxish? (cdr x)))))
diff --git a/collects/macro-debugger/stepper-text.ss b/collects/macro-debugger/stepper-text.ss
@@ -4,8 +4,8 @@
scheme/pretty
"model/trace.ss"
"model/reductions.ss"
+ "model/reductions-config.ss"
"model/steps.ss"
- "model/hide.ss"
"syntax-browser/partition.ss"
"syntax-browser/pretty-helper.ss")
(provide expand/step-text
@@ -54,11 +54,12 @@
(define (get-steps stx show?)
(define deriv (trace stx))
- (define hderiv
- (if show? (hide/policy deriv show?) deriv))
+ (define steps
+ (parameterize ((macro-policy show?))
+ (reductions deriv)))
(define (ok? x)
(or (rewrite-step? x) (misstep? x)))
- (filter ok? (reductions hderiv)))
+ (filter ok? steps))
(define (show-step step partition)
(cond [(step? step)
@@ -116,7 +117,7 @@
[print-hash-table #f]
[print-honu #f])
(pretty-print datum)))
-
+
(define (->show-function show)
(cond [(procedure? show)
show]
@@ -125,7 +126,7 @@
(ormap (lambda (x) (free-identifier=? x id))
show))]
[(eq? show #f)
- #f]
+ (lambda (id) #t)]
[else
(error 'expand/trace-text
"expected procedure or list of identifiers for macros to show; got: ~e"
diff --git a/collects/macro-debugger/syntax-browser/properties.ss b/collects/macro-debugger/syntax-browser/properties.ss
@@ -181,7 +181,7 @@
(display-subkv " imported from" (mpi->string (list-ref v 2)))
(display-subkv " as" (list-ref v 3))
(when (list-ref v 4)
- (display " via define-for-syntax" sub-key-sd))]))
+ (display " via define-for-syntax\n" sub-key-sd))]))
;; display-stxobj-info : syntax -> void
(define/public (display-stxobj-info stx)
diff --git a/collects/macro-debugger/view/extensions.ss b/collects/macro-debugger/view/extensions.ss
@@ -16,7 +16,6 @@
"../model/deriv.ss"
"../model/deriv-util.ss"
"../model/trace.ss"
- "../model/hide.ss"
"../model/steps.ss"
"cursor.ss"
"../util/notify.ss")
diff --git a/collects/macro-debugger/view/frame.ss b/collects/macro-debugger/view/frame.ss
@@ -18,7 +18,6 @@
"../model/deriv.ss"
"../model/deriv-util.ss"
"../model/trace.ss"
- "../model/hide.ss"
"../model/steps.ss"
"cursor.ss"
"../util/notify.ss")
diff --git a/collects/macro-debugger/view/stepper.ss b/collects/macro-debugger/view/stepper.ss
@@ -20,7 +20,6 @@
"../model/deriv-find.ss"
"../model/trace.ss"
"../model/reductions.ss"
- "../model/hide.ss"
"../model/steps.ss"
"cursor.ss"
"../util/notify.ss")
@@ -410,21 +409,16 @@
;; Strip out mzscheme's top-interactions
;; Keep anything that is a non-mzscheme top-interaction
;; Drop everything else (not original program)
- (match deriv
- [(Wrap mrule (e1 e2 tx next))
- (match tx
- [(Wrap transformation (e1 e2 rs ?1 me1 locals ?2 me2 seq))
- (cond [(ormap (lambda (x) (top-interaction-kw? x))
- rs)
- ;; Just mzscheme's top-interaction; strip it out
- (adjust-deriv/top next)]
- [(equal? (map syntax-e rs) '(#%top-interaction))
- ;; A *different* top interaction; keep it
- deriv]
- [else
- ;; Not original and not tagged with top-interaction
- #f])])]
- [else #f])))
+ (cond [(not (mrule? deriv)) #f]
+ [(for/or ([x (base-resolves deriv)]) (top-interaction-kw? x))
+ ;; Just mzscheme's top-interaction; strip it out
+ (adjust-deriv/top (mrule-next deriv))]
+ [(equal? (map syntax-e (base-resolves deriv)) '(#%top-interaction))
+ ;; A *different* top interaction; keep it
+ deriv]
+ [else
+ ;; Not original and not tagged with top-interaction
+ #f])))
(define/public (top-interaction-kw? x)
(free-identifier=? x #'#%top-interaction))
diff --git a/collects/macro-debugger/view/term-record.ss b/collects/macro-debugger/view/term-record.ss
@@ -19,22 +19,22 @@
"../model/deriv-find.ss"
"../model/deriv-parser.ss"
"../model/trace.ss"
+ "../model/reductions-config.ss"
"../model/reductions.ss"
- "../model/hide.ss"
"../model/steps.ss"
- "debug-format.ss"
+ "../util/notify.ss"
"cursor.ss"
- "../util/notify.ss")
+ "debug-format.ss")
(provide term-record%)
;; Struct for one-by-one stepping
-(define-struct (prestep protostep) (foci1 e1))
-(define-struct (poststep protostep) (foci2 e2))
+(define-struct (prestep protostep) ())
+(define-struct (poststep protostep) ())
-(define (prestep-term1 s) (context-fill (protostep-ctx s) (prestep-e1 s)))
-(define (poststep-term2 s) (context-fill (protostep-ctx s) (poststep-e2 s)))
+(define (prestep-term1 s) (state-term (protostep-s1 s)))
+(define (poststep-term2 s) (state-term (protostep-s1 s)))
;; TermRecords
@@ -53,11 +53,6 @@
(define deriv-hidden? #f)
(define binders #f)
- (define synth-deriv #f)
- (define synth-warnings null)
- (define synth-estx #f)
- (define synth-oops #f)
-
(define raw-steps #f)
(define raw-steps-estx #f)
(define definites #f)
@@ -79,11 +74,6 @@
[get-deriv deriv]
[get-deriv-hidden? deriv-hidden?]
[get-binders binders])
- (define-guarded-getters (recache-synth!)
- [get-synth-deriv synth-deriv]
- [get-synth-warnings synth-warnings]
- [get-synth-estx synth-estx]
- [get-synth-oops synth-oops])
(define-guarded-getters (recache-raw-steps!)
[get-definites definites]
[get-error error]
@@ -108,11 +98,7 @@
;; invalidate-synth! : -> void
;; Invalidates cached parts that depend on macro-hiding policy
(define/public (invalidate-synth!)
- (invalidate-raw-steps!)
- (set! synth-deriv #f)
- (set! synth-warnings null)
- (set! synth-oops #f)
- (set! synth-estx #f))
+ (invalidate-raw-steps!))
;; invalidate-deriv! : -> void
(define/public (invalidate-deriv!)
@@ -154,44 +140,25 @@
;; recache-synth! : -> void
(define/private (recache-synth!)
- (unless (or synth-deriv synth-oops)
- (recache-deriv!)
- (when deriv
- (set! synth-warnings null)
- (let ([show-macro? (send stepper get-show-macro?)]
- [force-letrec? (send config get-force-letrec-transformation?)])
- (with-handlers ([(lambda (e) #t)
- (lambda (e)
- (set! synth-oops e))])
- (let ()
- (define-values (synth-deriv* estx*)
- (if show-macro?
- (parameterize ((current-hiding-warning-handler
- (lambda (tag args)
- (set! synth-warnings
- (cons (cons tag args)
- synth-warnings))))
- (force-letrec-transformation
- force-letrec?))
- (hide*/policy deriv show-macro?))
- (values deriv (wderiv-e2 deriv))))
- (set! synth-deriv synth-deriv*)
- (set! synth-estx estx*)))))))
+ (recache-deriv!))
;; recache-raw-steps! : -> void
(define/private (recache-raw-steps!)
(unless (or raw-steps raw-steps-oops)
(recache-synth!)
- (when synth-deriv
- (with-handlers ([(lambda (e) #t)
- (lambda (e)
- (set! raw-steps-oops e))])
- (let-values ([(raw-steps* definites* estx* error*)
- (reductions+ synth-deriv)])
- (set! raw-steps raw-steps*)
- (set! raw-steps-estx estx*)
- (set! error error*)
- (set! definites definites*))))))
+ (when deriv
+ (let ([show-macro? (or (send stepper get-show-macro?)
+ (lambda (id) #t))])
+ (with-handlers ([(lambda (e) #t)
+ (lambda (e)
+ (set! raw-steps-oops e))])
+ (let-values ([(raw-steps* definites* estx* error*)
+ (parameterize ((macro-policy show-macro?))
+ (reductions+ deriv))])
+ (set! raw-steps raw-steps*)
+ (set! raw-steps-estx estx*)
+ (set! error error*)
+ (set! definites definites*)))))))
;; recache-steps! : -> void
(define/private (recache-steps!)
@@ -216,13 +183,13 @@
(define/private (reduce:one-by-one rs)
(let loop ([rs rs])
(match rs
- [(cons (struct step (d l t c df fr redex contractum e1 e2)) rs)
- (list* (make-prestep d l "Find redex" c df fr redex e1)
- (make-poststep d l t c df fr contractum e2)
+ [(cons (struct step (type s1 s2)) rs)
+ (list* (make prestep type s1)
+ (make poststep type s2)
(loop rs))]
- [(cons (struct misstep (d l t c df fr redex e1 exn)) rs)
- (list* (make-prestep d l "Find redex" c df fr redex e1)
- (make-misstep d l t c df fr redex e1 exn)
+ [(cons (struct misstep (type s1 exn)) rs)
+ (list* (make prestep type s1)
+ (make misstep type s1 exn)
(loop rs))]
['()
null])))
@@ -279,33 +246,20 @@
;; extract-protostep-seq : step -> number/#f
(define/private (extract-protostep-seq step)
- (match (protostep-deriv step)
- [(Wrap mrule (_ _ (Wrap transformation (_ _ _ _ _ _ _ _ seq)) _))
- seq]
- [else #f]))
+ ;; FIXME: add back step numbers
+ (state-seq (protostep-s1 step)))
;; Warnings display
;; on-get-focus : -> void
(define/public (on-get-focus)
- (recache-synth!)
- (display-warnings))
+ (recache-synth!))
;; on-lose-focus : -> void
(define/public (on-lose-focus)
(when steps (cursor:move-to-start steps))
(set! steps-position #f))
- ;; display-warnings : -> void
- (define/private (display-warnings)
- (let ([warnings-area (send stepper get-warnings-area)])
- (unless (send config get-suppress-warnings?)
- (for-each (lambda (tag+args)
- (let ([tag (car tag+args)]
- [args (cdr tag+args)])
- (send warnings-area add-warning tag args)))
- synth-warnings))))
-
;; Rendering
;; display-initial-term : -> void
@@ -315,14 +269,12 @@
;; display-final-term : -> void
(define/public (display-final-term)
(recache-synth!)
- (cond [(syntax? synth-estx)
- (add-syntax synth-estx binders definites)]
+ (cond [(syntax? raw-steps-estx)
+ (add-syntax raw-steps-estx binders definites)]
[(exn? error)
(add-error error)]
[raw-steps-oops
- (add-internal-error "steps" raw-steps-oops #f)]
- [synth-oops
- (add-internal-error "hiding" synth-oops #f)]))
+ (add-internal-error "steps" raw-steps-oops #f)]))
;; display-step : -> void
(define/public (display-step)
@@ -334,8 +286,6 @@
(add-final raw-steps-estx error binders definites)))]
[raw-steps-oops
(add-internal-error "steps" raw-steps-oops (wderiv-e1 deriv))]
- [synth-oops
- (add-internal-error "hiding" synth-oops (wderiv-e1 deriv))]
[raw-deriv-oops
(add-internal-error "derivation" raw-deriv-oops #f)]
[else
@@ -378,8 +328,6 @@
(define/public (add-step step binders)
(cond [(step? step)
(show-step step binders)]
- [(mono? step)
- (show-mono step binders)]
[(misstep? step)
(show-misstep step binders)]
[(prestep? step)
@@ -403,7 +351,8 @@
;; show-lctx : Step -> void
(define/private (show-lctx step binders)
- (define lctx (protostep-lctx step))
+ (define state (protostep-s1 step))
+ (define lctx (state-lctx state))
(when (pair? lctx)
(send sbview add-text "\n")
(for-each (lambda (bf)
@@ -412,15 +361,13 @@
(insert-syntax/redex (bigframe-term bf)
(bigframe-foci bf)
binders
- (protostep-definites step)
- (protostep-frontier step)))
+ (state-uses state)
+ (state-frontier state)))
(reverse lctx))))
;; separator : Step -> void
(define/private (separator step)
- (if (not (mono? step))
- (insert-step-separator (step-type->string (protostep-type step)))
- (insert-as-separator (step-type->string (protostep-type step)))))
+ (insert-step-separator (step-type->string (protostep-type step))))
;; separator/small : Step -> void
(define/private (separator/small step)
@@ -429,56 +376,41 @@
;; show-step : Step -> void
(define/private (show-step step binders)
- (insert-syntax/redex (step-term1 step)
- (step-foci1 step)
- binders
- (protostep-definites step)
- (protostep-frontier step))
+ (show-state/redex (protostep-s1 step) binders)
(separator step)
- (insert-syntax/contractum (step-term2 step)
- (step-foci2 step)
- binders
- (protostep-definites step)
- (protostep-frontier step))
+ (show-state/contractum (step-s2 step) binders)
(show-lctx step binders))
- ;; show-mono : Step -> void
- (define/private (show-mono step binders)
- (separator step)
- (insert-syntax/redex (mono-term1 step)
- null
- binders
- (protostep-definites step)
- (protostep-frontier step))
- (show-lctx step binders))
+ (define/private (show-state/redex state binders)
+ (insert-syntax/contractum (state-term state)
+ (state-foci state)
+ binders
+ (state-uses state)
+ (state-frontier state)))
+
+ (define/private (show-state/contractum state binders)
+ (insert-syntax/contractum (state-term state)
+ (state-foci state)
+ binders
+ (state-uses state)
+ (state-frontier state)))
;; show-prestep : Step -> void
(define/private (show-prestep step binders)
(separator/small step)
- (insert-syntax/redex (prestep-term1 step)
- (prestep-foci1 step)
- binders
- (protostep-definites step)
- (protostep-frontier step))
+ (show-state/redex (protostep-s1 step) binders)
(show-lctx step binders))
;; show-poststep : Step -> void
(define/private (show-poststep step binders)
(separator/small step)
- (insert-syntax/contractum (poststep-term2 step)
- (poststep-foci2 step)
- binders
- (protostep-definites step)
- (protostep-frontier step))
+ (show-state/contractum (protostep-s1 step) binders)
(show-lctx step binders))
;; show-misstep : Step -> void
(define/private (show-misstep step binders)
- (insert-syntax/redex (misstep-term1 step)
- (misstep-foci1 step)
- binders
- (protostep-definites step)
- (protostep-frontier step))
+ (define state (protostep-s1 step))
+ (show-state/redex state binders)
(separator step)
(send sbview add-error-text (exn-message (misstep-exn step)))
(send sbview add-text "\n")
@@ -486,11 +418,10 @@
(for-each (lambda (e)
(send sbview add-syntax e
'#:alpha-table binders
- '#:definites (or (protostep-definites step) null)))
+ '#:definites (or (state-uses state) null)))
(exn:fail:syntax-exprs (misstep-exn step))))
(show-lctx step binders))
-
;; insert-syntax/color : syntax syntaxes identifiers syntaxes string -> void
(define/private (insert-syntax/color stx foci binders definites frontier hi-color)
(send sbview add-syntax stx
diff --git a/collects/tests/macro-debugger/all-tests.ss b/collects/tests/macro-debugger/all-tests.ss
@@ -0,0 +1,43 @@
+
+#lang scheme/base
+(require (planet "test.ss" ("schematics" "schemeunit.plt" 2 9))
+ (planet "graphical-ui.ss" ("schematics" "schemeunit.plt" 2 9)))
+(require macro-debugger/model/debug
+ "gentest-framework.ss"
+ "gentests.ss"
+ "test-setup.ss"
+ "tests/syntax-basic.ss"
+ "tests/syntax-macros.ss"
+ "tests/syntax-modules.ss"
+ "tests/syntax-errors.ss"
+ "tests/hiding.ss"
+ "tests/regression.ss"
+ "tests/policy.ss"
+ "tests/collects.ss")
+(provide go)
+
+(define (go) (test/graphical-ui all-tests))
+(define (collects) (test/graphical-ui big-libs-tests))
+
+(define protos
+ (list proto:kernel-forms
+ proto:kernel-contexts
+ proto:macros
+ proto:modules
+ proto:errors))
+
+(define deriv-test (mk-deriv-test protos))
+(define steps-test (mk-steps-test protos))
+(define hiding-deriv-test (mk-hidden-deriv-test protos))
+(define hiding-steps-test (mk-hidden-steps-test protos))
+
+(define all-tests
+ (test-suite "All tests"
+ deriv-test
+ steps-test
+ hiding-deriv-test
+ hiding-steps-test
+ specialized-hiding-tests
+ regression-tests
+ #;seek-tests
+ policy-tests))
diff --git a/collects/tests/macro-debugger/gentest-framework.ss b/collects/tests/macro-debugger/gentest-framework.ss
@@ -0,0 +1,61 @@
+#lang scheme/base
+(provide (all-defined-out))
+
+(define-struct collection (label contents) #:transparent)
+(define-struct individual (label form attrs) #:transparent)
+
+(define-syntax define-tests
+ (syntax-rules ()
+ [(define-tests var label clause ...)
+ (define var (Test [#:suite label clause ...]))]))
+
+(define-syntax Test
+ (syntax-rules ()
+ [(Test [#:suite label clause ...])
+ (make-collection label (list (Test clause) ...))]
+ [(Test expr)
+ expr]))
+
+(define-syntax test
+ (syntax-rules ()
+ [(test label form clause ...)
+ (make-individual label 'form
+ (cons (cons '#:ok-deriv? #t)
+ (append (IClause form clause) ...)))]))
+
+(define-syntax testE
+ (syntax-rules ()
+ [(testE form clause ...)
+ (make-individual (format "~s" 'form) 'form
+ (cons (cons '#:ok-deriv? #f)
+ (append (IClause form clause) ...)))]))
+
+(define-syntax testK
+ (syntax-rules ()
+ [(testK label form clause ...)
+ (test label form #:kernel clause ...)]))
+
+(define-syntax testKE
+ (syntax-rules ()
+ [(testEK label form clause ...)
+ (testE label form #:kernel clause ...)]))
+
+(define-syntax IClause
+ (syntax-rules ()
+ [(IClause _form [#:steps spec ...])
+ (list (cons '#:steps '(spec ...)))]
+ [(IClause _form #:no-steps)
+ (list (cons '#:steps '())
+ (cons '#:hidden-steps '()))]
+ [(IClause _form #:error-step)
+ (list (cons '#:steps '(error)))]
+ [(IClause form [#:rename+error-step rename-type])
+ (list (cons '#:steps '((rename-type form) error)))]
+ [(IClause _form [#:hidden-steps spec ...])
+ (list (cons '#:hidden-steps '(spec ...)))]
+ [(IClause form #:same-hidden-steps)
+ (list (cons '#:same-hidden-steps #t))]
+ [(IClause form #:no-hidden-steps)
+ (list (cons '#:hidden-steps '()))]
+ [(Iclause form #:kernel)
+ (list (cons '#:kernel #t))]))
diff --git a/collects/tests/macro-debugger/gentests.ss b/collects/tests/macro-debugger/gentests.ss
@@ -0,0 +1,153 @@
+#lang scheme/base
+(require (planet "test.ss" ("schematics" "schemeunit.plt" 2 9))
+ macro-debugger/model/debug
+ macro-debugger/model/stx-util
+ "gentest-framework.ss"
+ "test-setup.ss")
+(provide mk-deriv-test
+ mk-steps-test
+ mk-hidden-deriv-test
+ mk-hidden-steps-test)
+
+(define (mk-deriv-test protos)
+ (mk-test "Derivations" checker-for-deriv protos))
+
+(define (mk-steps-test protos)
+ (mk-test "Reductions" checker-for-steps protos))
+
+(define (mk-hidden-deriv-test protos)
+ (mk-test "Hiding: Completes for multiple policies"
+ checker-for-hidden-deriv protos))
+
+(define (mk-hidden-steps-test protos)
+ (mk-test "Hiding: Reductions" checker-for-hidden-steps protos))
+
+(define (mk-test label checker protos)
+ (apply test-suite label
+ (filter values
+ (map (mk-gen-test checker) protos))))
+
+(define (mk-gen-test f)
+ (define (gen prototest)
+ (match prototest
+ [(struct collection (label contents))
+ (let ([tests (filter values (map gen contents))])
+ (and (pair? tests)
+ (apply test-suite label tests)))]
+ [(struct individual (label form attrs))
+ (f label form attrs)]))
+ gen)
+
+(define (checker-for-deriv label form attrs)
+ (cond [(assq '#:ok-deriv? attrs)
+ => (lambda (key+expect-ok?)
+ (test-case label
+ (let ([d (trace/ns form (assq '#:kernel attrs))])
+ (check-pred deriv? d)
+ (if (cdr key+expect-ok?)
+ (check-pred ok-node? d)
+ (check-pred interrupted-node? d)))))]
+ [else #f]))
+
+(define (checker-for-hidden-deriv label form attrs)
+ (cond [(assq '#:ok-deriv? attrs)
+ => (lambda (key+expect-ok?)
+ (test-case label
+ (let ([d (trace/ns form (assq '#:kernel attrs))]
+ [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?))))]
+ [else #f]))
+
+(define (check-hide d policy expect-ok?)
+ (let-values ([(steps defs stx2 exn)
+ (parameterize ((macro-policy policy))
+ (reductions+ d))])
+ (check-pred list? steps)
+ (check-pred reduction-sequence? steps)
+ (check-true (not (and stx2 exn)) "Must not produce both estx and exn")
+ (if expect-ok?
+ (check-pred syntax? stx2 "Expected expanded syntax")
+ (check-pred exn? exn "Expected syntax error exn"))))
+
+(define (checker-for-steps label form attrs)
+ (cond [(assq '#:steps attrs)
+ => (lambda (key+expected)
+ (test-case label
+ (let* ([d (trace/ns form (assq '#:kernel attrs))]
+ [rs (reductions d)])
+ (check-steps (cdr key+expected) rs))))]
+ [else #f]))
+
+(define (checker-for-hidden-steps label form attrs)
+ (cond [(assq '#:same-hidden-steps attrs)
+ (unless (assq '#:steps attrs)
+ (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))
+ (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))
+ (reductions d))])
+ (check-steps (cdr (assq '#:hidden-steps attrs)) rs))))]
+ [else #f]))
+
+(define (check-steps expected actual)
+ (check-pred list? actual)
+ (check-pred reduction-sequence? actual)
+ (compare-step-sequences expected actual))
+
+(define (reduction-sequence? rs)
+ (andmap protostep? rs))
+
+(define (compare-step-sequences expected actual)
+ (cond [(and (pair? expected) (pair? actual))
+ (begin (compare-steps (car expected) (car actual))
+ (compare-step-sequences (cdr expected) (cdr actual)))]
+ [(pair? expected)
+ (fail (format "missing expected steps:\n~s" expected))]
+ [(pair? actual)
+ (fail (format "too many steps:\n~a"
+ (apply append
+ (for/list ([step actual])
+ (format "~s: ~s\n"
+ (protostep-type step)
+ (stx->datum (step-term2 step)))))))]
+ [else 'ok]))
+
+(define (compare-steps expected actual)
+ (cond [(eq? expected 'error)
+ (check-pred misstep? actual)]
+ [else
+ (let ([e-tag (car expected)]
+ [e-form (cadr expected)]
+ [e-locals (cddr expected)]
+ [lctx-terms (map bigframe-term (state-lctx (protostep-s1 actual)))])
+ (check-pred step? actual)
+ (check-eq? (protostep-type actual) e-tag)
+ (check-equal-syntax? (syntax->datum (step-term2 actual))
+ e-form)
+ (check-equal? (length lctx-terms) (length e-locals)
+ "Wrong number of context frames")
+ (for ([lctx-term lctx-terms] [e-local e-locals])
+ (check-equal-syntax? (syntax->datum lctx-term)
+ e-local
+ "Context frame")))]))
+
+(define-binary-check (check-equal-syntax? a b)
+ (equal-syntax? a b))
+
+(define (equal-syntax? a b)
+ (cond [(and (pair? a) (pair? b))
+ (and (equal-syntax? (car a) (car b))
+ (equal-syntax? (cdr a) (cdr b)))]
+ [(and (symbol? a) (symbol? b))
+ (equal? (string->symbol (symbol->string a))
+ b)]
+ [else (equal? a b)]))
diff --git a/collects/tests/macro-debugger/gui-tests.ss b/collects/tests/macro-debugger/gui-tests.ss
@@ -0,0 +1,273 @@
+#lang scheme/base
+(require scheme/class
+ scheme/list
+ scheme/gui
+ framework/framework
+ mzlib/etc)
+
+(require macro-debugger/model/trace
+ macro-debugger/view/view
+ macro-debugger/view/prefs)
+
+(provide test-stepper
+ test-stepper*)
+
+(define (wait) (sleep .1))
+(define (waitb) (sleep .025))
+
+(define (get-active-frame)
+ (let ([frame (get-top-level-focus-window)])
+ (unless frame
+ (error 'get-active-frame "no active frame"))
+ frame))
+
+(define (find-object base class pred)
+ (define (find-loop obj)
+ (cond [(and (is-a? obj class) (pred obj)) obj]
+ [(is-a? obj area-container<%>)
+ (ormap find-loop (send obj get-children))]
+ [else #f]))
+ (let ([obj (find-loop base)])
+ (unless obj
+ (error 'find-object "no such ~s object satisfying ~s" class pred))
+ obj))
+
+(define (find:next frame)
+ (find-object frame button% (has-label "Step ->")))
+(define (find:prev frame)
+ (find-object frame button% (has-label "<- Step")))
+(define (find:start frame)
+ (find-object frame button% (has-label "<-- Start")))
+(define (find:end frame)
+ (find-object frame button% (has-label "End -->")))
+(define (find:up frame)
+ (find-object frame button% (has-label "Previous term")))
+(define (find:down frame)
+ (find-object frame button% (has-label "Next term")))
+
+(define (has-label label)
+ (lambda (obj) (equal? label (send obj get-label))))
+
+(define (enabled? obj)
+ (send obj is-enabled?))
+
+(define (click button)
+ (waitb)
+ (unless (enabled? button)
+ (error 'click "button not enabled"))
+ (send button command (make-object control-event% 'button)))
+
+(define (click-until-disabled button)
+ (define (loop n)
+ (if (enabled? button)
+ (begin (click button)
+ (loop (add1 n)))
+ n))
+ (loop 0))
+
+(define (click-if-enabled button)
+ (when (enabled? button)
+ (click button)))
+
+(define (check check-box value)
+ (wait)
+ (unless (enabled? check-box)
+ (error 'check "check box not enabled"))
+ (send* check-box
+ (set-value value)
+ (command (make-object control-event% 'check-box))))
+
+(define (choose choice value)
+ (wait)
+ (unless (enabled? choice)
+ (error 'choice "choice not enabled"))
+ (send* choice
+ (set-string-selection value)
+ (command (make-object control-event% 'choice))))
+
+(define (menu-check menu-item value)
+ (wait)
+ (unless (enabled? menu-item)
+ (error 'menu-check "menu item not enabled"))
+ (send* menu-item
+ (check value)
+ (command (make-object control-event% 'menu))))
+
+(define (set-policy frame policy-symbol)
+ (let ([policy (find-object frame choice% (has-label "Macro hiding: "))])
+ (case policy-symbol
+ ((none)
+ (choose policy "Disable")
+ #;(check enable #f)
+ #;(check hide-mz #f)
+ #;(check hide-libs #f))
+ ((basic)
+ (choose policy "Custom ...")
+ (check (find-object frame check-box% (has-label "Enable macro hiding")) #t)
+ (check (find-object frame check-box% (has-label "Hide mzscheme syntax")) #f)
+ (check (find-object frame check-box% (has-label "Hide library syntax")) #f))
+ ((normal)
+ (choose policy "Standard")
+ #;(check enable #t)
+ #;(check hide-mz #t)
+ #;(check hide-libs #t)))))
+
+(define (get-menu-item frame menu-path)
+ (let ([menu (send frame get-menu-bar)])
+ (define (menu-loop path menus)
+ (cond [(string? path)
+ (let ([item
+ (ormap (lambda (m)
+ (and (is-a? m labelled-menu-item<%>)
+ (equal? path (send m get-label))
+ m))
+ menus)])
+ (unless item
+ (error 'get-menu-item "no such menu item: ~s" path))
+ item)]
+ [else
+ (let ([menu
+ (ormap (lambda (m)
+ (and (is-a? m menu%)
+ (equal? (car path) (send m get-label))
+ m))
+ menus)])
+ (unless menu
+ (error 'get-menu-item "no such menu item: ~s" path))
+ (menu-loop (cdr path) (send menu get-items)))]))
+ (or (menu-loop menu-path (send menu get-items))
+ (error 'get-menu-item "no such menu item"))))
+
+(define (menu-item:one-by-one frame)
+ (get-menu-item frame '("Stepper" "Extra options" . "One term at a time")))
+(define (menu-item:show-renaming-steps frame)
+ (get-menu-item frame '("Stepper" "Extra options" . "Include renaming steps")))
+(define (menu-item:highlight-redex/contractum frame)
+ (get-menu-item frame '("Stepper" "Extra options" . "Highlight redex/contractum")))
+
+(define (set-mode frame . flags)
+ (menu-check (menu-item:one-by-one frame)
+ (memq 'one-by-one flags))
+ (menu-check (menu-item:show-renaming-steps frame)
+ (memq 'renames flags))
+ (menu-check (menu-item:highlight-redex/contractum frame)
+ (not (memq 'no-highlight flags))))
+
+(define (run-through start prev next end)
+ (begin-with-definitions
+ (click-if-enabled start)
+ (begin (for-each assert-disabled (list start prev)))
+ (define next-clicks (click-until-disabled next))
+ (begin (for-each assert-disabled (list next end)))
+ (click-if-enabled start)
+ (begin (for-each assert-disabled (list start prev)))
+ (click-if-enabled end)
+ (begin (for-each assert-disabled (list next end)))
+ (define prev-clicks (click-until-disabled prev))
+ (unless (equal? next-clicks prev-clicks)
+ (error 'run-through
+ "pressed next ~s times, pressed prev ~s times"
+ next-clicks prev-clicks))
+ (begin (for-each assert-disabled (list start prev)))))
+
+(define (assert-enabled obj)
+ (unless (enabled? obj)
+ (error 'assert-enabled "assertion failed for ~s" (send obj get-label))))
+(define (assert-disabled obj)
+ (when (enabled? obj)
+ (error 'assert-disabled "assertion failed for ~s" (send obj get-label))))
+
+;; check-threads : (-> any) -> any
+;; Runs thunk; raises error if any subthreads created by thunk raise
+;; errors, or if a subthread outlives thunk's computation.
+(define (check-threads thunk)
+ (let* ([main-cust (current-custodian)]
+ [sub-cust (make-custodian main-cust)]
+ [sub-exns null]
+ [old-uncaught-exception-handler (uncaught-exception-handler)])
+ (parameterize ((current-custodian sub-cust)
+ (uncaught-exception-handler
+ (lambda (exn)
+ (set! sub-exns (cons exn sub-exns))
+ (old-uncaught-exception-handler exn))))
+ (let ([result (thunk)])
+ ;; Check that sub-custodian has no living threads.
+ (let ([threads-still-going?
+ (ormap thread-running?
+ (filter thread?
+ (custodian-managed-list sub-cust main-cust)))])
+ (when (pair? sub-exns)
+ (raise (car sub-exns))
+ #;(error 'nice-threads "child thread raised exception"))
+ (when threads-still-going?
+ (error 'nice-threads "child thread left still running"))
+ result)))))
+
+(define (new-uninitialized-stepper)
+ (sleep 1)
+ (parameterize ((current-eventspace (make-eventspace)))
+ (let ([frame (new macro-stepper-frame%
+ (config (new macro-stepper-config/prefs/readonly%)))])
+ (send frame show #t)
+ frame)))
+
+(define (new-stepper)
+ (let ([frame (new-uninitialized-stepper)])
+ frame))
+
+(define (add-expansion frame stx)
+ (let ([widget (send frame get-widget)])
+ (send widget add-deriv (trace stx))))
+
+(define (test-stepper* stxs policies)
+ (check-threads
+ (lambda ()
+ (let ([frame (new-stepper)])
+ (let ([start (find:start frame)]
+ [prev (find:prev frame)]
+ [next (find:next frame)]
+ [end (find:end frame)]
+ [up (find:up frame)]
+ [down (find:down frame)])
+ (define (run)
+ (run-down)
+ (click-until-disabled up))
+ (define (run-down)
+ (when (enabled? down)
+ (run-through start prev next end)
+ (click down)
+ (run-down)))
+ (define (run/all-modes)
+ (set-mode frame) ;; normal by default
+ (run)
+ (set-mode frame 'no-highlight)
+ (run)
+ (set-mode frame 'renames)
+ (run)
+ ;;(set-mode frame 'no-highlight 'renames)
+ ;;(run)
+ ;;(set-mode frame 'one-by-one)
+ ;;(run)
+ ;;(set-mode frame 'one-by-one 'renames)
+ ;;(run)
+ (set-mode frame 'one-by-one 'renames 'no-highlight)
+ (run)
+ (set-mode frame))
+ (dynamic-wind
+ void
+ (lambda ()
+ (for-each (lambda (stx) (add-expansion frame stx)) stxs)
+ ;; Test different hiding policies
+ (for-each (lambda (policy)
+ (set-policy frame policy)
+ (run/all-modes))
+ policies)
+ (wait))
+ (lambda ()
+ (test:close-top-level-window frame)
+ (kill-thread
+ (eventspace-handler-thread
+ (send frame get-eventspace))))))))))
+
+(define (test-stepper expr)
+ (test-stepper* (list expr) '(none basic normal))))
diff --git a/collects/tests/macro-debugger/test-setup.ss b/collects/tests/macro-debugger/test-setup.ss
@@ -0,0 +1,154 @@
+
+#lang scheme/base
+(require macro-debugger/model/debug)
+;; Testing facilities for macro debugger
+
+(provide trace/ns
+ trace/t
+ trace/k
+ hide-all-policy
+ hide-none-policy
+ simple-policy
+
+ stx/hide-none
+ stx/hide-all
+ stx/hide-standard
+ stx/hide-simple)
+
+(define (trace/t expr)
+ (trace/ns expr #f))
+
+(define (trace/k expr)
+ (trace/ns expr #t))
+
+(define (trace/ns expr kernel?)
+ (parameterize ((current-namespace (choose-namespace kernel?)))
+ (trace expr)))
+
+(define (choose-namespace kernel?)
+ (if kernel? kernel-namespace testing-namespace))
+
+(define helper-module
+ '(module helper scheme/base
+ (require (for-syntax scheme/base))
+ (provide Tid
+ Tlist
+ Tlet
+ Tleid
+ Tlift
+ myor
+ the-current-output-port
+ wrong
+ pre-id
+ id
+ leid
+ lift)
+ (define-syntax (id stx)
+ (syntax-case stx ()
+ [(id x) #'x]))
+ (define-syntax (pre-id stx)
+ (syntax-case stx ()
+ [(pre-id x) #'(id x)]))
+ (define-syntax (leid stx)
+ (syntax-case stx ()
+ [(leid e)
+ (with-syntax ([ee (local-expand #'e 'expression null)])
+ #`(#%expression ee))]))
+ (define-syntax (lift stx)
+ (syntax-case stx ()
+ [(lift e)
+ (with-syntax ([v (syntax-local-lift-expression #'e)])
+ #'(#%expression v))]))
+ (define-syntax wrong
+ (lambda (stx)
+ (raise-syntax-error #f "macro blows up here!" stx)))
+ (define-syntax Tid
+ (syntax-rules ()
+ [(Tid e) e]))
+ (define-syntax Tlist
+ (syntax-rules ()
+ [(Tlist e) (list e)]))
+ (define-syntax Tlet
+ (syntax-rules ()
+ [(Tlet x e b) ((lambda (x) b) e)]))
+ (define-syntax (Tleid stx)
+ (syntax-case stx ()
+ [(Tleid e)
+ (with-syntax ([ee (local-expand #'e 'expression null)])
+ #`(#%expression ee))]))
+ (define-syntax (Tlift stx)
+ (syntax-case stx ()
+ [(Tlift e)
+ (with-syntax ([v (syntax-local-lift-expression #'e)])
+ #'(#%expression v))]))
+ (define-syntax myor
+ (syntax-rules ()
+ [(myor x)
+ x]
+ [(myor x y ...)
+ (let ((t x))
+ (if t t (myor y ...)))]))
+ (define-syntax the-current-output-port
+ (make-set!-transformer
+ (syntax-rules (set!)
+ [(set! the-current-output-port op)
+ (#%plain-app current-output-port op)])))))
+
+(define kernel-namespace (make-base-empty-namespace))
+(parameterize ((current-namespace kernel-namespace))
+ (namespace-require ''#%kernel)
+ (eval '(#%require (for-syntax '#%kernel)))
+ (eval helper-module)
+ (eval '(define-syntaxes (id)
+ (lambda (stx)
+ (cadr (syntax->list stx)))))
+ (eval '(define-syntaxes (Tid)
+ (lambda (stx)
+ (cadr (syntax->list stx)))))
+ (eval '(define-syntaxes (Tlist)
+ (lambda (stx)
+ (datum->syntax (quote-syntax here)
+ (list (quote-syntax list)
+ (cadr (syntax->list stx)))))))
+ (eval '(define-syntaxes (wrong)
+ (lambda (stx)
+ (raise-syntax-error #f "wrong" stx)))))
+
+(define testing-namespace (make-base-namespace))
+(parameterize ((current-namespace testing-namespace))
+ (eval '(require scheme/base))
+ (eval '(require (for-syntax scheme/base)))
+ (eval helper-module)
+
+ (eval '(require 'helper)))
+
+;; Specialized macro hiding tests
+(define (stx/hide-policy d policy)
+ (define-values (_steps _uses stx _exn)
+ (parameterize ((macro-policy policy))
+ (reductions+ d)))
+ stx)
+
+(define (stx/hide-none d)
+ (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)
+ (or (memq (syntax-e id) '())
+ (regexp-match #rx"^T" (symbol->string (syntax-e id)))))
diff --git a/collects/tests/macro-debugger/tests/collects.ss b/collects/tests/macro-debugger/tests/collects.ss
@@ -0,0 +1,324 @@
+#lang scheme/base
+(require (planet "test.ss" ("schematics" "schemeunit.plt" 2 9))
+ (planet "graphical-ui.ss" ("schematics" "schemeunit.plt" 2 9)))
+(require macro-debugger/model/debug
+ scheme/path
+ scheme/gui)
+(provide big-libs-tests
+ loadlib
+ loadfile
+ trace-modules)
+
+;; loadlib : module-path symbol -> Deriv
+(define (loadlib mod)
+ (let ([resolved ((current-module-name-resolver) mod #f #f #f)])
+ (loadfile (resolved-module-path-name resolved))))
+
+;; loadfile : path symbol -> Deriv
+(define (loadfile path)
+ (define-values (base file dir?) (split-path path))
+ (define expect-module
+ (string->symbol (path->string (path-replace-suffix file #""))))
+ (define-values (eh mnr)
+ (make-handlers (current-eval)
+ (current-module-name-resolver)))
+ #;(printf "Loading ~s\n" (path->string path))
+ #;(printf "Expecting module named '~s'\n" expect-module)
+ (parameterize ((current-load-relative-directory base)
+ (current-directory base)
+ (current-eval eh)
+ (current-module-name-resolver mnr))
+ (let-values ([(e-expr deriv)
+ ((current-load) path expect-module)])
+ (when (exn? e-expr)
+ (raise e-expr))
+ deriv)))
+
+(define (make-handlers original-eval-handler original-module-name-resolver)
+ (values
+ (lambda (expr)
+ (unless (syntax? expr)
+ (raise-type-error 'eval-handler "syntax" expr))
+ (trace/result expr))
+ (lambda args
+ (parameterize ((current-eval original-eval-handler)
+ (current-module-name-resolver original-module-name-resolver))
+ (apply original-module-name-resolver args)))))
+
+(define (test-libs name mods)
+ (test-suite name
+ (apply test-suite "Trace & Parse"
+ (for/list ([m mods]) (test-lib/deriv m)))
+ (apply test-suite "Reductions"
+ (for/list ([m mods]) (test-lib/hide m hide-none-policy)))
+ (apply test-suite "Standard hiding"
+ (for/list ([m mods]) (test-lib/hide m standard-policy)))))
+
+(define (test-lib/deriv m)
+ (test-case (format "~s" m)
+ (let ([deriv (loadlib m)])
+ (check-pred deriv? deriv "Not a deriv")
+ (check-pred ok-node? deriv "Expansion error"))))
+
+(define (test-lib/hide m policy)
+ (test-case (format "~s" m)
+ (let ([deriv (loadlib m)])
+ (check-steps deriv policy))))
+
+(define (check-steps deriv policy)
+ (define-values (steps defs stx exn)
+ (parameterize ((macro-policy policy)) (reductions+ deriv)))
+ (check-pred syntax? stx)
+ (check-eq? exn #f)
+ (check-true (list? steps) "Expected list for steps")
+ (check-reduction-sequence steps))
+
+(define (check-reduction-sequence steps)
+ (cond [(null? steps) (void)]
+ [(and (pair? steps) (step? (car steps)))
+ (check-reduction-sequence (cdr steps))]
+ [(and (pair? steps) (misstep? (car steps)))
+ (check-eq? (cdr steps) '() "Stuff after misstep")]
+ [else (fail "Bad reduction sequence")]))
+
+(define (make-tracing-module-name-resolver omnr table)
+ (case-lambda
+ [(mod rel stx load?)
+ (when load?
+ (when (not rel)
+ (hash-set! table mod #t))
+ (when rel
+ (let ([abs (rel+mod->mod rel mod)])
+ (when abs (hash-set! table abs #t)))))
+ (omnr mod rel stx load?)]
+ [args
+ (apply omnr args)]))
+
+(define (rel+mod->mod rel mod)
+ (define-values (base file dir?) (split-path (resolved-module-path-name rel)))
+ (path->mod (simplify-path (build-path base mod))))
+
+(define (path->mod path)
+ (cond [(for/or ([c (current-library-collection-paths)]) (path->mod* path c))
+ => (lambda (l)
+ (string->symbol
+ (path->string
+ (path-replace-suffix (apply build-path l) #""))))]
+ [else #f]))
+
+(define (path->mod* path base)
+ (let loop ([path (explode-path path)] [base (explode-path base)])
+ (cond [(null? base) path]
+ [(and (pair? path) (pair? base) (equal? (car path) (car base)))
+ (loop (cdr path) (cdr base))]
+ [else #f])))
+
+(define (trace-modules mods)
+ (define table (make-hash))
+ (parameterize ((current-module-name-resolver
+ (make-tracing-module-name-resolver
+ (current-module-name-resolver)
+ table))
+ (current-namespace (make-gui-namespace)))
+ (for ([mod mods])
+ (dynamic-require mod #f))
+ (let* ([loaded
+ (hash-map table (lambda (k v) k))]
+ [syms
+ (for/list ([l loaded] #:when (symbol? l)) l)]
+ [libs
+ (for/list ([l loaded] #:when (and (pair? l) (eq? (car l) 'lib))) l)]
+ [conv-libs
+ (for/list ([l libs])
+ (string->symbol
+ (string-append
+ (apply string-append
+ (for/list ([d (cddr l)]) (string-append d "/")))
+ (path->string (path-replace-suffix (cadr l) #"")))))])
+ (sort (append syms conv-libs)
+ string<?
+ #:key symbol->string
+ #:cache-keys? #t))))
+
+(define modules-from-framework (trace-modules '(framework)))
+(define modules-from-typed-scheme
+ #;(trace-modules '(typed-scheme))
+ '(#|
+ mzlib/contract
+ mzlib/etc
+ mzlib/file
+ mzlib/kw
+ mzlib/list
+ mzlib/match
+ mzlib/class
+ mzlib/cm-accomplice
+ mzlib/contract
+ mzlib/etc
+ mzlib/kw
+ mzlib/list
+ mzlib/pconvert
+ mzlib/pconvert-prop
+ mzlib/plt-match
+ mzlib/pretty
+ mzlib/private/increader
+ mzlib/private/unit-compiletime
+ mzlib/private/unit-keywords
+ mzlib/private/unit-runtime
+ mzlib/private/unit-syntax
+ mzlib/shared
+ mzlib/string
+ mzlib/struct
+ mzlib/trace
+ mzlib/unit
+ mzlib/unit-exptime
+ mzscheme
+ mzlib/plt-match
+ scheme/base
+ scheme/class
+ scheme/contract
+ scheme/include
+ scheme/list
+ scheme/match
+ scheme/match/compiler
+ scheme/match/define-forms
+ scheme/match/gen-match
+ scheme/match/legacy-match
+ scheme/match/match
+ scheme/match/match-expander
+ scheme/match/parse
+ scheme/match/parse-helper
+ scheme/match/parse-legacy
+ scheme/match/parse-quasi
+ scheme/match/patterns
+ scheme/match/reorder
+ scheme/match/split-rows
+ scheme/mzscheme
+ scheme/nest
+ scheme/private/class-internal
+ scheme/private/contract
+ scheme/private/contract-arrow
+ scheme/private/contract-basic-opters
+ scheme/private/contract-ds
+ scheme/private/contract-ds-helpers
+ scheme/private/contract-guts
+ scheme/private/contract-helpers
+ scheme/private/contract-opt
+ scheme/private/contract-opt-guts
+ scheme/private/define-struct
+ scheme/private/define-struct
+ scheme/private/for
+ scheme/private/kw
+ scheme/private/letstx-scheme
+ scheme/private/list
+ scheme/private/misc
+ scheme/private/modbeg
+ scheme/private/more-scheme
+ scheme/private/namespace
+ scheme/private/old-procs
+ scheme/private/pre-base
+ scheme/private/qqstx
+ scheme/private/reqprov
+ scheme/private/struct-info
+ scheme/private/stx
+ scheme/private/stxcase
+ scheme/private/stxcase-scheme
+ scheme/private/stxloc
+ scheme/private/stxparamkey
+ scheme/private/with-stx
+ scheme/promise
+ scheme/provide-transform
+ scheme/require-syntax
+ scheme/require-transform
+ scheme/struct-info
+ scheme/struct-info
+ scheme/stxparam
+ scheme/unit
+ scheme/unit-exptime
+ scheme/unit/lang
+ srfi/1
+ srfi/1/alist
+ srfi/1/cons
+ srfi/1/delete
+ srfi/1/filter
+ srfi/1/fold
+ srfi/1/list
+ srfi/1/lset
+ srfi/1/misc
+ srfi/1/predicate
+ srfi/1/search
+ srfi/1/selector
+ srfi/1/util
+ srfi/optional
+ srfi/provider
+ mzlib/struct
+ syntax/boundmap
+ syntax/boundmap
+ syntax/context
+ syntax/free-vars
+ syntax/kerncase
+ syntax/kerncase
+ syntax/name
+ syntax/path-spec
+ syntax/private/boundmap
+ syntax/struct
+ syntax/struct
+ syntax/stx
+ syntax/stx
+ mzlib/trace
+ |#
+ typed-scheme
+ typed-scheme/minimal
+ typed-scheme/private/base-env
+ typed-scheme/private/base-types
+ typed-scheme/private/check-subforms-unit
+ typed-scheme/private/def-binding
+ typed-scheme/private/effect-rep
+ typed-scheme/private/extra-procs
+ typed-scheme/private/free-variance
+ typed-scheme/private/infer
+ typed-scheme/private/infer-ops
+ typed-scheme/private/init-envs
+ typed-scheme/private/internal-forms
+ typed-scheme/private/interning
+ typed-scheme/private/lexical-env
+ typed-scheme/private/mutated-vars
+ typed-scheme/private/parse-type
+ typed-scheme/private/planet-requires
+ typed-scheme/private/prims
+ typed-scheme/private/provide-handling
+ typed-scheme/private/remove-intersect
+ typed-scheme/private/rep-utils
+ typed-scheme/private/require-contract
+ typed-scheme/private/resolve-type
+ typed-scheme/private/signatures
+ typed-scheme/private/subtype
+ typed-scheme/private/syntax-traversal
+ typed-scheme/private/tables
+ typed-scheme/private/tc-app-unit
+ typed-scheme/private/tc-expr-unit
+ typed-scheme/private/tc-if-unit
+ typed-scheme/private/tc-lambda-unit
+ typed-scheme/private/tc-let-unit
+ typed-scheme/private/tc-structs
+ typed-scheme/private/tc-toplevel
+ typed-scheme/private/tc-utils
+ typed-scheme/private/type-alias-env
+ typed-scheme/private/type-annotation
+ typed-scheme/private/type-comparison
+ typed-scheme/private/type-contract
+ typed-scheme/private/type-effect-convenience
+ typed-scheme/private/type-effect-printer
+ typed-scheme/private/type-env
+ typed-scheme/private/type-environments
+ typed-scheme/private/type-name-env
+ typed-scheme/private/type-rep
+ typed-scheme/private/type-utils
+ typed-scheme/private/typechecker
+ typed-scheme/private/unify
+ typed-scheme/private/union
+ typed-scheme/private/unit-utils
+ typed-scheme/private/utils
+ typed-scheme/typed-scheme))
+
+(define big-libs-tests
+ (test-libs "Collections" modules-from-typed-scheme))
diff --git a/collects/tests/macro-debugger/tests/hiding.ss b/collects/tests/macro-debugger/tests/hiding.ss
@@ -0,0 +1,181 @@
+
+#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)
+
+;; == Macro hiding
+
+(define-syntax test-hiding/policy
+ (syntax-rules ()
+ [(th form hidden-e2 policy)
+ (test-case (format "~s" 'form)
+ (let-values ([(steps defs stx exn)
+ (parameterize ((macro-policy policy))
+ (reductions+ (trace/k 'form)))])
+ (check-pred syntax? stx)
+ (check-equal? (syntax->datum stx) 'hidden-e2)))]))
+
+(define-syntax test-trivial-hiding
+ (syntax-rules ()
+ [(tth form hidden-e2)
+ (test-hiding/policy form hidden-e2 (lambda (m) #t))]))
+(define-syntax test-trivial-hiding/id
+ (syntax-rules ()
+ [(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 specialized-hiding-tests
+ (test-suite "Specialized macro hiding tests"
+ (test-suite "Result tests for trivial hiding"
+ (test-suite "Atomic expressions"
+ (test-trivial-hiding/id *)
+ (test-trivial-hiding 1 '1)
+ (test-trivial-hiding (#%datum . 1) '1)
+ (test-trivial-hiding unbound-var (#%top . unbound-var)))
+ (test-suite "Basic expressions"
+ (test-trivial-hiding/id (if * * *))
+ (test-trivial-hiding/id (with-continuation-mark * * *))
+ (test-trivial-hiding/id (define-values (x) *))
+ (test-trivial-hiding/id (define-syntaxes (x) *)))
+ (test-suite "Binding expressions"
+ (test-trivial-hiding/id (lambda (x) *))
+ (test-trivial-hiding/id (case-lambda [(x) *] [(x y) *]))
+ (test-trivial-hiding/id (let-values ([(x) *]) *))
+ (test-trivial-hiding/id (letrec-values ([(x) *]) *)))
+ (test-suite "Blocks"
+ (test-trivial-hiding/id (lambda (x y) x y))
+ (test-trivial-hiding (lambda (x y z) (begin x y) z)
+ (lambda (x y z) x y z))
+ (test-trivial-hiding/id (lambda (x y z) x (begin y z))) ;; expression begin!
+ (test-trivial-hiding (lambda (x) (define-values (y) x) y)
+ (lambda (x) (letrec-values ([(y) x]) y)))
+ (test-trivial-hiding (lambda (x) (begin (define-values (y) x)) y)
+ (lambda (x) (letrec-values ([(y) x]) y)))
+ (test-trivial-hiding (lambda (x) (begin (define-values (y) x) y) x)
+ (lambda (x) (letrec-values ([(y) x]) y x)))
+ (test-trivial-hiding (lambda (x) (id (define-values (y) x)) x)
+ (lambda (x) (letrec-values ([(y) x]) x)))
+ (test-trivial-hiding (lambda (x) (id (begin (define-values (y) x) x)))
+ (lambda (x) (letrec-values ([(y) x]) x)))
+ (test-trivial-hiding (lambda (x) (define-values (y) (id x)) y)
+ (lambda (x) (letrec-values ([(y) x]) y)))
+ (test-trivial-hiding (lambda (x y) x (id y))
+ (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))
+ (test-trivial-hiding/id (lambda (x y z) (begin x y) z))
+ (test-trivial-hiding/id (lambda (x y z) x (begin y z)))
+ (test-trivial-hiding/id (lambda (x) (define-values (y) x) y))
+ (test-trivial-hiding/id (lambda (x) (begin (define-values (y) x)) y))
+ (test-trivial-hiding/id (lambda (x) (begin (define-values (y) x) y) x))
+ (test-trivial-hiding (lambda (x) (id x))
+ (lambda (x) x))
+ (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"
+ (test-suite "Atomic expressions"
+ (test-simple-hiding/id *)
+ (test-simple-hiding/id 1)
+ (test-simple-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-suite "Opaque macros"
+ (test-simple-hiding/id (id '1))
+ (test-simple-hiding/id (id 1))
+ (test-simple-hiding/id (id (id '1)))
+ ;; app is hidden:
+ (test-simple-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-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-suite "Binding expressions"
+ (test-simple-hiding/id (lambda (x) x))
+ (test-simple-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)))))))))
diff --git a/collects/tests/macro-debugger/tests/policy.ss b/collects/tests/macro-debugger/tests/policy.ss
@@ -0,0 +1,64 @@
+#lang scheme/base
+
+(require (planet "test.ss" ("schematics" "schemeunit.plt" 2 8))
+ macro-debugger/model/debug
+ "../test-setup.ss")
+(provide policy-tests)
+
+(define ns (make-base-namespace))
+(eval '(require (prefix-in k: '#%kernel)) ns)
+(eval '(require (prefix-in base: scheme/base)) ns)
+(eval '(require (prefix-in scheme: scheme)) ns)
+
+(define-syntax-rule (test-policy policy name show?)
+ (test-case (format "~s" 'name)
+ (check-eq? (policy
+ (parameterize ((current-namespace ns))
+ (namespace-symbol->identifier 'name)))
+ show?)))
+(define-syntax-rule (test-standard name show?)
+ (test-policy standard-policy name show?))
+(define-syntax-rule (test-base name show?)
+ (test-policy base-policy name show?))
+
+(define policy-tests
+ (test-suite "Policy tests"
+ (test-suite "Base policy"
+ ;; Kernel forms
+ (test-base k:define-values #f)
+ (test-base k:lambda #f)
+ (test-base k:if #f)
+
+ ;; Scheme/base forms
+ (test-base base:define #f)
+ (test-base base:lambda #f)
+ (test-base base:#%app #f)
+ (test-base base:if #f)
+
+ ;; Other Scheme/* forms
+ (test-base scheme:match #t)
+ (test-base scheme:unit #t)
+ (test-base scheme:class #t)
+
+ ;; Unbound names
+ (test-base no-such-name #t)
+ )
+ (test-suite "Standard policy"
+ ;; Kernel forms
+ (test-standard k:define-values #f)
+ (test-standard k:lambda #f)
+ (test-standard k:if #f)
+
+ ;; Scheme/base forms
+ (test-standard base:define #f)
+ (test-standard base:lambda #f)
+ (test-standard base:#%app #f)
+ (test-standard base:if #f)
+
+ ;; Other Scheme/* forms
+ (test-standard scheme:match #f)
+ (test-standard scheme:unit #f)
+ (test-standard scheme:class #f)
+
+ ;; Unbound names
+ (test-standard no-such-name #t))))
diff --git a/collects/tests/macro-debugger/tests/regression.ss b/collects/tests/macro-debugger/tests/regression.ss
@@ -0,0 +1,170 @@
+#lang scheme/base
+(require (planet "test.ss" ("schematics" "schemeunit.plt" 2 8))
+ macro-debugger/model/debug
+ macro-debugger/model/steps
+ "../test-setup.ss")
+(provide regression-tests)
+
+(define regression-tests
+ (test-suite "Regression tests"
+ ;; Fixed 9/2006: mismatched binding+bound variables
+ (test-case "hiding on binding forms"
+ (let ([stx (stx/hide-all (trace #'(let ([x 1]) x)))])
+ (with-syntax ([(?let ([?x-def _]) ?x-use) stx])
+ (check-pred identifier? #'?x-def)
+ (check-pred identifier? #'?x-use)
+ (check bound-identifier=? #'?x-def #'?x-use))))
+ ;; Fixed 10/2/2006: bad handling of renames
+ (test-case "renames in lsv, etc"
+ (check-pred syntax? (stx/hide-none (trace #'(let () 1))))
+ (check-pred syntax? (stx/hide-none (trace #'(letrec () 1))))
+ (check-pred syntax? (stx/hide-none (trace #'(let-syntax () 1)))))
+ ;; Fixed 10/2/2006: error above manifests in classes, too
+ (test-case "renames in lsv, via class"
+ (check-pred syntax? (stx/hide-none (trace #'(class object% (super-new))))))
+ ;; Fixed 10/2/2006: PR 8305: Error in module (pass2)
+ (test-case "interrupted expr in module body"
+ (check-equal? (stx/hide-standard
+ (trace '(module m mzscheme (define x (lambda)))))
+ #f)
+ (check-equal? (stx/hide-standard
+ (trace '(module m mzscheme (void) (define x (lambda)))))
+ #f))
+ ;; Error in module (pass1)
+ (test-case "interrupted module-body element"
+ (check-equal? (stx/hide-standard (trace '(module m mzscheme (define x))))
+ #f)
+ (check-equal? (stx/hide-standard (trace '(module m mzscheme (void) (define x))))
+ #f))
+ ;; Fixed 11/13/2006: error in lsv rhs
+ (test-case "error in lsv rhs"
+ (check-pred interrupted-node?
+ (trace #'(letrec-syntaxes+values ([(x) (error 'gotcha)]) ()
+ 'never-reached))))
+ ;; Fixed 11/13/2006: lifting in module
+ (test-case "lift in module"
+ (check-pred syntax?
+ (stx/hide-none
+ (trace '(module m mzscheme
+ (require (lib "etc.ss"))
+ (define x (begin-lifted 1)))))))
+
+ ;; Fixed 2/9/2007: defstx in brules misparsed & mishandled
+ (test-case "reductions & internal define-syntax"
+ (reductions
+ (trace '(let ([x 1])
+ (define-syntax m
+ (syntax-rules ()
+ [(_ x) (begin (lambda (x) x) (lambda (x) x) x)]))
+ (m x)))))
+
+ ;; Fixed 2/9/2007: Handled b:defstx in hiding code
+ (test-case "reductions & internal define-syntax"
+ (check-pred syntax?
+ (stx/hide-none
+ (trace/t '(lambda ()
+ (define-syntaxes (m) (lambda _ (quote-syntax *)))
+ (m))))))
+
+ ;; Fixed 2/9/2007: missing stx->list before length
+ (test-case "hiding error & stx pairs"
+ (check-pred syntax?
+ (stx/hide-none
+ (trace '(let-syntax ([m (syntax-rules () [(_ x) (begin x)])])
+ (m *))))))
+ (test-case "hiding in block, splicing"
+ (stx/hide-none
+ (trace '(let-syntax ([m (syntax-rules () [(_ x) (begin x)])])
+ *
+ (m *)))))
+ (test-case "hiding in block, variable"
+ (stx/hide-none
+ (trace '(let-syntax ([m (syntax-rules () [(_ x) x])])
+ (list (m *)) ;; FIXME
+ *))))
+ (test-case "hiding in block, expression"
+ (check-pred syntax?
+ (stx/hide-none
+ (trace '(let-syntax ([m (syntax-rules () [(_ x) (list x)])])
+ (m *))))))
+
+ ;; Reported by robby (2/8/2007), traced to bug in expander
+ (test-case "hiding & lambda in module"
+ (check-pred syntax?
+ (stx/hide-none
+ (trace '(module m '#%kernel
+ (#%module-begin (lambda () 'a)))))))
+
+ ;; Discovered 5/7/2007
+ (test-case "hiding and error within lambda"
+ (let ([rs (parameterize ((macro-policy hide-all-policy))
+ (reductions (trace '(with-handlers () (lambda)))))])
+ (check-pred list? rs)
+ (check-true (andmap misstep? rs))
+ (check-true (= 1 (length rs)))))
+
+ ;; Discovered 5/7/2007
+ (test-case "hiding and error within lambda 2"
+ (let ([rs (parameterize ((macro-policy hide-all-policy))
+ (reductions (trace '(with-handlers ([void void]) (lambda)))))])
+ (check-pred list? rs)
+ (check-true (andmap misstep? rs))
+ (check-true (= 1 (length rs)))))
+
+ ;; Distilled from Robby bug report (5/12/2007)
+ ;; Fixed 5/17/2007
+ (test-case "hiding: keeping lifts in sync"
+ (let ([freshname (gensym)])
+ (eval `(module ,freshname mzscheme
+ (require (lib "contract.ss"))
+ (provide/contract [f (integer? . -> . integer?)]
+ [c integer?])
+ (define (f x) (add1 x))
+ (define c 1)))
+ (let ([rs (parameterize ((macro-policy standard-policy))
+ (reductions
+ (trace `(module m mzscheme
+ (require ',freshname)
+ (define (g y) c)
+ (define h c)
+ (add1 (g 2))))))])
+ (check-pred list? rs)
+ (check-true (andmap step? rs)))))
+
+ ;; Bug from samth (6/5/2007)
+ ;; problem seems to come from define-syntax -> letrec-syntaxes+values
+ ;; transformation, undoes expansion of srhss (so rename fails)
+ (test-case "more rename/frontier troubles"
+ (let ([rs (reductions
+ (trace '(module m (lib "htdp-advanced.ss" "lang")
+ (local [(define x 1)] x))))])
+ (check-pred list? rs)))
+
+ ;; Distilled from Sam/typed-scheme (8/24/2007)
+ (test-case "transformer calls 'expand'"
+ (check-pred deriv?
+ (trace '(let-syntax ([m (lambda (stx)
+ (syntax-case stx ()
+ [(m e)
+ (expand #'e)]))])
+ (m 4)))))
+ (test-case "define-syntaxes rhs calls 'expand'"
+ (check-pred deriv?
+ (trace '(define-syntax m (expand '(or 1 2))))))
+ (test-case "lsv rhs calls 'expand'"
+ (check-pred deriv?
+ (trace '(let-syntax ([m (expand '(or 1 2))]) 'nothing))))
+
+ ;; Added 2/18/2008
+ (test-case "interrupted module-begin"
+ (let* ([freshname (gensym)]
+ [rs (parameterize ((macro-policy standard-policy))
+ (reductions
+ (trace `(module m mzscheme
+ (require ,freshname)
+ (define (g y) c)
+ (define h c)
+ (add1 (g 2))))))])
+ (check-pred list? rs)
+ (check-true (ormap misstep? rs))))
+ ))
diff --git a/collects/tests/macro-debugger/tests/syntax-basic.ss b/collects/tests/macro-debugger/tests/syntax-basic.ss
@@ -0,0 +1,309 @@
+
+#lang scheme/base
+(require "../gentest-framework.ss")
+(provide proto:kernel-forms
+ proto:kernel-contexts)
+
+(define-tests proto:kernel-forms "Kernel forms"
+ [#:suite
+ "Atomic expressions"
+ (testK "required variable"
+ null
+ #:no-steps)
+ (testK "datum (number)"
+ 1
+ [#:steps (tag-datum (#%datum . 1))
+ (macro '1)]
+ #:no-hidden-steps)
+ (testK "datum (boolean)"
+ #f
+ [#:steps (tag-datum (#%datum . #f))
+ (macro '#f)]
+ #:no-hidden-steps)
+ (testK "datum (explicit)"
+ (#%datum . 5)
+ [#:steps (macro '5)]
+ #:no-hidden-steps)
+ (testK "#%top (implicit)"
+ unbound-variable
+ [#:steps (tag-top (#%top . unbound-variable))]
+ #:no-hidden-steps)
+ (testK "#%top (explicit)"
+ (#%top . unbound-variable)
+ #:no-steps)
+ (testK "quote"
+ (quote mumble)
+ #:no-steps)
+ (testK "#%require"
+ (#%require mzscheme)
+ #:no-steps)
+ (testK "require for-syntax"
+ (#%require (for-syntax mzscheme))
+ #:no-steps)
+ (testK "require for-template"
+ (#%require (for-template mzscheme))
+ #:no-steps)]
+
+ [#:suite
+ "Definitions"
+ (testK "define-values"
+ (define-values (x) 'a)
+ #:no-steps)
+ (testK "define-syntaxes"
+ (define-syntaxes (x) 'a)
+ #:no-steps)]
+
+ [#:suite
+ "Simple expressions"
+ (testK "if"
+ (if 'a 'b 'c)
+ #:no-steps)
+ (testK "wcm"
+ (with-continuation-mark 'a 'b 'c)
+ #:no-steps)
+ (testK "set!"
+ (set! x 'a)
+ #:no-steps)]
+
+ [#:suite
+ "Sequence-containing expressions"
+ (testK "begin"
+ (begin 'a 'b)
+ #:no-steps)
+ (testK "begin0 (single)"
+ (begin0 'a)
+ #:no-steps)
+ (testK "begin0 (multiple)"
+ (begin0 'a 'b 'c)
+ #:no-steps)
+ (testK "#%app (implicit)"
+ (+ '1 '2)
+ [#:steps (tag-app (#%app + '1 '2))]
+ #:no-hidden-steps)
+ (testK "#%app (implicit)"
+ (+ '1 '2)
+ [#:steps (tag-app (#%app + '1 '2))])
+ (testK "#%app (explicit)"
+ (#%app + '1 '2 '3)
+ #:no-steps)]
+
+ [#:suite
+ "Binding forms and blocks"
+ (testK "lambda (simple)"
+ (lambda (x) x)
+ [#:steps (rename-lambda (lambda (x) x))]
+ #:same-hidden-steps)
+ (testK "lambda (rest args)"
+ (lambda (x . y) y)
+ [#:steps (rename-lambda (lambda (x . y) y))]
+ #:same-hidden-steps)
+ (testK "lambda (multi)"
+ (lambda (x) 'a 'b)
+ [#:steps (rename-lambda (lambda (x) 'a 'b))]
+ #:same-hidden-steps)
+ (testK "letrec-values"
+ (letrec-values ([(x) 'a]) x)
+ [#:steps (rename-letrec-values (letrec-values ([(x) 'a]) x))]
+ #:same-hidden-steps)
+ (testK "letrec-values"
+ (letrec-values ([(x) 'a] [(y) 'b]) y)
+ [#:steps
+ (rename-letrec-values
+ (letrec-values ([(x) 'a] [(y) 'b]) y))]
+ #:same-hidden-steps)
+ (testK "case-lambda"
+ (case-lambda [(x) x] [(x y) y])
+ [#:steps
+ (rename-case-lambda (case-lambda [(x) x] [(x y) y]))
+ (rename-case-lambda (case-lambda [(x) x] [(x y) y]))]
+ #:same-hidden-steps)
+ (testK "let-values"
+ (let-values ([(x) 'a]) x)
+ [#:steps (rename-let-values (let-values ([(x) 'a]) x))]
+ #:same-hidden-steps)]
+
+ [#:suite
+ "Internal definitions"
+ (testK "internal begin (empty)"
+ (lambda () (begin) 'a)
+ [#:steps (rename-lambda (lambda () (begin) 'a))
+ (splice-block (lambda () 'a))]
+ #:same-hidden-steps)
+ (testK "internal begin (solo)"
+ (lambda () (begin 'b))
+ [#:steps (rename-lambda (lambda () (begin 'b)))
+ (splice-block (lambda () 'b))]
+ #:same-hidden-steps)
+ (testK "internal begin"
+ (lambda () (begin 'a) 'b)
+ [#:steps (rename-lambda (lambda () (begin 'a) 'b))
+ (splice-block (lambda () 'a 'b))]
+ #:same-hidden-steps)
+ (testK "internal begin"
+ (lambda () (begin 'a 'b) 'c)
+ [#:steps (rename-lambda (lambda () (begin 'a 'b) 'c))
+ (splice-block (lambda () 'a 'b 'c))]
+ #:same-hidden-steps)
+ (testK "internal define-values"
+ (lambda () (define-values (x) 'a) 'b)
+ [#:steps (rename-lambda (lambda () (define-values (x) 'a) 'b))
+ (block->letrec (lambda () (letrec-values ([(x) 'a]) 'b)))
+ (rename-letrec-values (lambda () (letrec-values ([(x) 'a]) 'b)))]
+ #:same-hidden-steps)
+ (testK "internal define-values in begin"
+ (lambda () (begin (define-values (x) 'a)) 'b)
+ [#:steps
+ (rename-lambda (lambda () (begin (define-values (x) 'a)) 'b))
+ (splice-block (lambda () (define-values (x) 'a) 'b))
+ (block->letrec (lambda () (letrec-values ([(x) 'a]) 'b)))
+ (rename-letrec-values (lambda () (letrec-values ([(x) 'a]) 'b)))]
+ #:same-hidden-steps)
+ (testK "internal begin, then define-values"
+ (lambda () (begin) (define-values (x) 'a) 'b)
+ [#:steps
+ (rename-lambda (lambda () (begin) (define-values (x) 'a) 'b))
+ (splice-block (lambda () (define-values (x) 'a) 'b))
+ (block->letrec (lambda () (letrec-values ([(x) 'a]) 'b)))
+ (rename-letrec-values (lambda () (letrec-values ([(x) 'a]) 'b)))]
+ #:same-hidden-steps)]
+
+ [#:suite
+ "Top-level begin"
+ (testK "begin (top-level)"
+ (begin (define-values (x) 'a) 'b)
+ #:no-steps)
+ (testK "begin (empty)"
+ (begin)
+ #:no-steps)])
+
+(define-tests proto:kernel-contexts "Kernel contexts"
+ [#:suite
+ "Definitions"
+ (testK "define-values"
+ (define-values (x) (id 'a))
+ [#:steps (macro (define-values (x) 'a))]
+ #:no-hidden-steps)
+ (testK "define-values"
+ (define-values (x) (Tid 'a))
+ [#:steps (macro (define-values (x) 'a))]
+ #:same-hidden-steps)]
+ [#:suite
+ "Simple expressions"
+ (testK "if (with else)"
+ (if (Tid 'a) (Tid 'b) (Tid 'c))
+ [#:steps (macro (if 'a (Tid 'b) (Tid 'c)))
+ (macro (if 'a 'b (Tid 'c)))
+ (macro (if 'a 'b 'c))]
+ #:same-hidden-steps)
+ (testK "wcm"
+ (with-continuation-mark (id 'a) (id 'b) (id 'c))
+ [#:steps (macro (with-continuation-mark 'a (id 'b) (id 'c)))
+ (macro (with-continuation-mark 'a 'b (id 'c)))
+ (macro (with-continuation-mark 'a 'b 'c))]
+ #:no-hidden-steps)]
+ [#:suite
+ "Sequence-containing forms"
+ (testK "begin"
+ (begin (id 'a) (id 'b))
+ [#:steps (macro (begin 'a (id 'b)))
+ (macro (begin 'a 'b))]
+ #:no-hidden-steps)
+ (testK "begin"
+ (begin (Tid 'a) (Tid 'b))
+ [#:steps (macro (begin 'a (Tid 'b)))
+ (macro (begin 'a 'b))]
+ #:same-hidden-steps)
+ (testK "begin0 (single)"
+ (begin0 (id 'a))
+ [#:steps (macro (begin0 'a))]
+ #:no-hidden-steps)
+ (testK "begin0 (multiple)"
+ (begin0 (id 'a) (id 'b))
+ [#:steps (macro (begin0 'a (id 'b)))
+ (macro (begin0 'a 'b))]
+ #:no-hidden-steps)
+ (testK "#%app (implicit)"
+ ((id cons) (id 'a) (id 'b))
+ [#:steps (tag-app (#%app (id cons) (id 'a) (id 'b)))
+ (macro (#%app cons (id 'a) (id 'b)))
+ (macro (#%app cons 'a (id 'b)))
+ (macro (#%app cons 'a 'b))]
+ #:no-hidden-steps)
+ (testK "#%app (implicit)"
+ ((Tid cons) (Tid 'a) (Tid 'b))
+ [#:steps (tag-app (#%app (Tid cons) (Tid 'a) (Tid 'b)))
+ (macro (#%app cons (Tid 'a) (Tid 'b)))
+ (macro (#%app cons 'a (Tid 'b)))
+ (macro (#%app cons 'a 'b))]
+ [#:hidden-steps (macro (cons (Tid 'a) (Tid 'b)))
+ (macro (cons 'a (Tid 'b)))
+ (macro (cons 'a 'b))])
+ (testK "#%app (explicit)"
+ (#%app (id cons) (id 'a) (id 'b))
+ [#:steps (macro (#%app cons (id 'a) (id 'b)))
+ (macro (#%app cons 'a (id 'b)))
+ (macro (#%app cons 'a 'b))]
+ #:no-hidden-steps)
+ (testK "#%app (explicit)"
+ (#%app (Tid cons) (Tid 'a) (Tid 'b))
+ [#:steps (macro (#%app cons (Tid 'a) (Tid 'b)))
+ (macro (#%app cons 'a (Tid 'b)))
+ (macro (#%app cons 'a 'b))]
+ #:same-hidden-steps)]
+
+ [#:suite
+ "Binding forms"
+ (testK "lambda (simple)"
+ (lambda (x) (id x))
+ [#:steps (rename-lambda (lambda (x) (id x)))
+ (macro (lambda (x) x))]
+ [#:hidden-steps (rename-lambda (lambda (x) (id x)))])
+ (testK "lambda (rest args)"
+ (lambda (x . y) (id y))
+ [#:steps (rename-lambda (lambda (x . y) (id y)))
+ (macro (lambda (x . y) y))]
+ [#:hidden-steps (rename-lambda (lambda (x . y) (id y)))])
+ (testK "lambda (multi)"
+ (lambda (x) (id 'a) (id 'b))
+ [#:steps (rename-lambda (lambda (x) (id 'a) (id 'b)))
+ (macro (lambda (x) 'a (id 'b)))
+ (macro (lambda (x) 'a 'b))]
+ [#:hidden-steps (rename-lambda (lambda (x) (id 'a) (id 'b)))])
+ (testK "lambda (splice)"
+ (lambda (x) (begin (id 'a) (id 'b)) (id 'c))
+ [#:steps (rename-lambda (lambda (x) (begin (id 'a) (id 'b)) (id 'c)))
+ (splice-block (lambda (x) (id 'a) (id 'b) (id 'c)))
+ (macro (lambda (x) 'a (id 'b) (id 'c)))
+ (macro (lambda (x) 'a 'b (id 'c)))
+ (macro (lambda (x) 'a 'b 'c))]
+ [#:hidden-steps
+ (rename-lambda (lambda (x) (begin (id 'a) (id 'b)) (id 'c)))
+ (splice-block (lambda (x) (id 'a) (id 'b) (id 'c)))])
+ (testK "lambda (splice 2)"
+ (lambda (x) (id (begin 'a 'b)) (id 'c))
+ [#:steps (rename-lambda (lambda (x) (id (begin 'a 'b)) (id 'c)))
+ (macro (lambda (x) (begin 'a 'b) (id 'c)))
+ (splice-block (lambda (x) 'a 'b (id 'c)))
+ (macro (lambda (x) 'a 'b 'c))])
+ (testK "case-lambda"
+ (case-lambda [(x) (id x)] [(x y) (id y)])
+ [#:steps (rename-case-lambda (case-lambda [(x) (id x)] [(x y) (id y)]))
+ (macro (case-lambda [(x) x] [(x y) (id y)]))
+ (rename-case-lambda (case-lambda [(x) x] [(x y) (id y)]))
+ (macro (case-lambda [(x) x] [(x y) y]))]
+ [#:hidden-steps
+ (rename-case-lambda (case-lambda [(x) (id x)] [(x y) (id y)]))
+ (rename-case-lambda (case-lambda [(x) (id x)] [(x y) (id y)]))])
+ (testK "let-values"
+ (let-values ([(x) (id 'a)]) (id (cons 'b x)))
+ [#:steps (rename-let-values (let-values ([(x) (id 'a)]) (id (cons 'b x))))
+ (macro (let-values ([(x) 'a]) (id (cons 'b x))))
+ (macro (let-values ([(x) 'a]) (cons 'b x)))
+ (tag-app (let-values ([(x) 'a]) (#%app cons 'b x)))])
+ (testK "letrec-values"
+ (letrec-values ([(x) (id 'a)]) (id (cons 'b x)))
+ [#:steps
+ (rename-letrec-values (letrec-values ([(x) (id 'a)]) (id (cons 'b x))))
+ (macro (letrec-values ([(x) 'a]) (id (cons 'b x))))
+ (macro (letrec-values ([(x) 'a]) (cons 'b x)))
+ (tag-app (letrec-values ([(x) 'a]) (#%app cons 'b x)))])])
diff --git a/collects/tests/macro-debugger/tests/syntax-errors.ss b/collects/tests/macro-debugger/tests/syntax-errors.ss
@@ -0,0 +1,320 @@
+
+#lang scheme/base
+(require "../gentest-framework.ss")
+(provide proto:errors)
+
+(define-tests proto:errors "Bad syntax"
+ [#:suite
+ "Atomic expressions"
+ (testKE (#%top a b c)
+ #:error-step)
+ (testKE (#%top . 5)
+ #:error-step)
+ (testKE (quote)
+ #:error-step)
+ (testKE (quote a b)
+ #:error-step)
+ (testKE (#%require . x)
+ #:error-step)
+ (testKE (#%require 5)
+ #:error-step)
+ (testKE (#%require (prefix (lib "list.ss")))
+ #:error-step)
+ (testKE (#%require (prefix 5 (lib "list.ss")))
+ #:error-step)]
+ [#:suite
+ "Definitions"
+ (testKE (define-values x 'a)
+ #:error-step)
+ (testKE (define-values (x))
+ #:error-step)
+ (testKE (define-values (x) 'a 'b)
+ #:error-step)
+ (testKE (define-values (x) . 1)
+ #:error-step)
+ (testKE (define-values (x x) 1)
+ #:error-step)
+ (testKE (define-syntaxes x 1)
+ #:error-step)
+ (testKE (define-syntaxes (x))
+ #:error-step)
+ (testKE (define-syntaxes (x) 1 2)
+ #:error-step)
+ (testKE (define-syntaxes (x) . 3)
+ #:error-step)
+ (testKE (define-syntaxes (x x) 1)
+ #:error-step)]
+
+ ;; "Simple expressions"
+ [#:suite
+ "if misapplied"
+ (testKE (if)
+ #:error-step)
+ (testKE (if 1)
+ #:error-step)
+ (testKE (if 'a 'b)
+ #:error-step)
+ (testKE (if 1 2 3 4)
+ #:error-step)
+ (testKE (if . x)
+ #:error-step)
+ (testKE (if 1 . x)
+ #:error-step)
+ (testKE (if 1 2 . x)
+ #:error-step)
+ (testKE (if 1 2 3 . x)
+ #:error-step)]
+ [#:suite
+ "wcm misapplied"
+ (testKE (with-continuation-mark)
+ #:error-step)
+ (testKE (with-continuation-mark 1)
+ #:error-step)
+ (testKE (with-continuation-mark 1 2 3 4)
+ #:error-step)
+ (testKE (with-continuation-mark . x)
+ #:error-step)
+ (testKE (with-continuation-mark 1 . x)
+ #:error-step)
+ (testKE (with-continuation-mark 1 2 . x)
+ #:error-step)
+ (testKE (with-continuation-mark 1 2 3 . x)
+ #:error-step)]
+ [#:suite
+ "set! misapplied"
+ (testKE (set!)
+ #:error-step)
+ (testKE (set! x)
+ #:error-step)
+ (testKE (set! x . 3)
+ #:error-step)
+ (testKE (set! x 1 2)
+ #:error-step)
+ (testKE (set! 1)
+ #:error-step)
+ (testKE (set! 1 2)
+ #:error-step)]
+
+ ;; "Sequence-containing expressions"
+ [#:suite
+ "begin misapplied"
+ (testKE (#%expression (begin))
+ #:error-step)
+ (testKE (begin . 1)
+ #:error-step)
+ (testKE (begin 'a . 2)
+ #:error-step)]
+ [#:suite
+ "begin0 misapplied"
+ (testKE (begin0)
+ #:error-step)
+ (testKE (begin0 . 1)
+ #:error-step)
+ (testKE (begin0 'a . 2)
+ #:error-step)
+ (testKE (begin0 'a 'b . 3)
+ #:error-step)]
+ [#:suite
+ "#%app (implicit) misapplied"
+ (testKE (+ . 1)
+ [#:steps (tag-app (#%app + . 1))
+ error])
+ (testKE (+ 1 . 2)
+ [#:steps (tag-app (#%app + 1 . 2))
+ error])
+ (testKE (+ 1 2 . 3)
+ [#:steps (tag-app (#%app + 1 2 . 3))
+ error])]
+ [#:suite
+ "#%app (explicit) misapplied"
+ (testKE (#%app . +)
+ #:error-step)
+ (testKE (#%app + . 1)
+ #:error-step)
+ (testKE (#%app + 1 . 2)
+ #:error-step)
+ (testKE (#%app + 1 2 . 3)
+ #:error-step)]
+
+ ;; "Binding forms"
+ [#:suite
+ "lambda misapplied"
+ (testKE (lambda)
+ #:error-step)
+ (testKE (lambda args)
+ #:error-step)
+ (testKE (lambda #(a b) 1)
+ #:error-step)
+ (testKE (lambda args . 1)
+ #:error-step)
+ (testKE (lambda 1 2)
+ #:error-step)
+ (testKE (lambda (1) 2)
+ #:error-step)
+ (testKE (lambda (x . 1) 2)
+ #:error-step)
+ (testKE (lambda (x x) 1)
+ #:error-step)
+ (testKE (lambda (x y x) 1)
+ #:error-step)]
+ [#:suite
+ "letrec-values misapplied"
+ (testKE (letrec-values)
+ #:error-step)
+ (testKE (letrec-values x)
+ #:error-step)
+ (testKE (letrec-values x 1)
+ #:error-step)
+ (testKE (letrec-values (x) 2)
+ #:error-step)
+ (testKE (letrec-values (x 1) 2)
+ #:error-step)
+ (testKE (letrec-values ([x 1]) 2)
+ #:error-step)
+ (testKE (letrec-values ([(x . y) 1]) 2)
+ #:error-step)
+ (testKE (letrec-values ([(x) 1 2]) 2)
+ #:error-step)
+ (testKE (letrec-values ([(x) 1] x) 2)
+ #:error-step)
+ (testKE (letrec-values ([(x) 1] [y 2]) 3)
+ #:error-step)
+ (testKE (letrec-values ([(x x) 1]) 2)
+ #:error-step)
+ (testKE (letrec-values ([(x) 1] [(x) 2]) 3)
+ #:error-step)]
+
+ [#:suite
+ "Internal definitions"
+ [#:suite
+ "Basic internal definitions"
+ (testKE (lambda () . 1) ;; FIXME
+ #:error-step)
+ (testKE (lambda () (begin))
+ [#:steps (rename-lambda (lambda () (begin)))
+ (splice-block (lambda ()))
+ error])
+ (testKE (lambda () (define-values (x) 1))
+ [#:rename+error-step rename-lambda])
+ (testKE (lambda () (define-values (x) 1) . 2)
+ [#:rename+error-step rename-lambda])
+ (testKE (lambda () (begin (define-values (x) 1) . 2))
+ [#:rename+error-step rename-lambda])
+ (testKE (lambda () (begin (define-values (x) 1) . 2) 3)
+ [#:rename+error-step rename-lambda])
+ (testKE (lambda ()
+ (define-values (x) 1)
+ (define-values (x) 2)
+ 3)
+ [#:rename+error-step rename-lambda])
+ (testKE (lambda (x)
+ (define-values (x) 'a)
+ 'b
+ (define-values (y) 'c)
+ 'd)
+ [#:steps (rename-lambda (lambda (x)
+ (define-values (x) 'a)
+ 'b
+ (define-values (y) 'c)
+ 'd))
+ (block->letrec (lambda (x)
+ (letrec-values ([(x) 'a])
+ 'b
+ (define-values (y) 'c)
+ 'd)))
+ (rename-letrec-values (lambda (x)
+ (letrec-values ([(x) 'a])
+ 'b
+ (define-values (y) 'c)
+ 'd)))
+ error])]
+ [#:suite
+ "bad internal begin"
+ (testKE (lambda () (begin . 1))
+ [#:rename+error-step rename-lambda])
+ (testKE (lambda () (begin 1 . 2))
+ [#:rename+error-step rename-lambda])
+ (testKE (lambda () (define-values (x) 1) (begin . 2))
+ [#:rename+error-step rename-lambda])
+ (testKE (lambda () (define-values (x) 1) (begin 1 . 2))
+ [#:rename+error-step rename-lambda])
+ (testKE (lambda () (define-values (x) 1) (begin . 2) 3)
+ [#:rename+error-step rename-lambda])]
+ [#:suite
+ "bad definition forms"
+ (testKE (lambda () (define-values))
+ [#:rename+error-step rename-lambda])
+ (testKE (lambda () (define-values x))
+ [#:rename+error-step rename-lambda])
+ (testKE (lambda () (define-values x 1))
+ [#:rename+error-step rename-lambda])
+ (testKE (lambda () (define-values (x . y) 1))
+ [#:rename+error-step rename-lambda])
+ (testKE (lambda () (define-values (x) . 1))
+ [#:rename+error-step rename-lambda])
+ (testKE (lambda () (define-values (x) 1 2))
+ [#:rename+error-step rename-lambda])
+ (testKE (lambda () (define-values (x x) 1))
+ [#:rename+error-step rename-lambda])]]
+ [#:suite
+ "Errors in primitive contexts"
+ [#:suite
+ "Definitions"
+ (testKE (define-syntaxes (x) (lambda))
+ #:error-step)
+ (testKE (define-values (x) (wrong))
+ #:error-step)]
+ [#:suite
+ "Simple expressions"
+ (testKE (if (wrong) 'b 'c)
+ #:error-step)
+ (testKE (if 'a (wrong) 'c)
+ #:error-step)
+ (testKE (if 'a 'b (wrong))
+ #:error-step)
+ (testKE (if (wrong) 'b)
+ #:error-step)
+ (testKE (if 'a (wrong))
+ #:error-step)
+ (testKE (with-continuation-mark (wrong) 'b 'c)
+ #:error-step)
+ (testKE (with-continuation-mark 'a (wrong) 'c)
+ #:error-step)
+ (testKE (with-continuation-mark 'a 'b (wrong))
+ #:error-step)
+ (testKE (set! x (wrong))
+ #:error-step)]
+ [#:suite
+ "Sequence-containing expressions"
+ (testKE (begin (wrong))
+ #:error-step)
+ (testKE (begin 'a (wrong))
+ #:error-step)
+ (testKE (begin0 (wrong))
+ #:error-step)
+ (testKE (begin0 'a (wrong))
+ #:error-step)
+ (testKE (#%app (wrong))
+ #:error-step)
+ (testKE (#%app + (wrong))
+ #:error-step)]
+ [#:suite
+ "Binding forms"
+ (testKE (lambda (x) (begin0 (wrong)))
+ [#:rename+error-step rename-lambda])
+ (testKE (letrec-values ([(x) (wrong)]) 1)
+ [#:rename+error-step rename-letrec-values])
+ (testKE (letrec-values ([(x) 'a]) (begin0 (wrong)))
+ [#:rename+error-step rename-letrec-values])]
+ [#:suite
+ "Internal definitions"
+ (testKE (lambda () (wrong))
+ [#:rename+error-step rename-lambda])
+ (testKE (lambda () (define-values () (wrong)) 1)
+ [#:steps
+ (rename-lambda (lambda () (define-values () (wrong)) 1))
+ (block->letrec (lambda () (letrec-values ([() (wrong)]) 1)))
+ (rename-letrec-values (lambda () (letrec-values ([() (wrong)]) 1)))
+ error])
+ (testKE (lambda () (define-values (x) 1) (wrong))
+ [#:rename+error-step rename-lambda])]])
diff --git a/collects/tests/macro-debugger/tests/syntax-macros.ss b/collects/tests/macro-debugger/tests/syntax-macros.ss
@@ -0,0 +1,125 @@
+
+#lang scheme/base
+(require "../gentest-framework.ss")
+(provide proto:macros)
+
+(define-tests proto:macros "Macros"
+ [#:suite
+ "Macros"
+ (test "id"
+ (id 'a)
+ [#:steps (macro 'a)]
+ #:no-hidden-steps)
+ (test "Tid"
+ (Tid 'a)
+ [#:steps (macro 'a)]
+ #:same-hidden-steps)
+ (test "pre-id"
+ (pre-id 'a)
+ [#:steps (macro (id 'a))
+ (macro 'a)]
+ #:no-hidden-steps)
+ (test "myor (base)"
+ (myor 'a)
+ [#:steps (macro 'a)]
+ #:no-hidden-steps)
+ (test "myor (recursive 1)"
+ (myor 'a 'b)
+ [#:steps (macro (let ((t 'a)) (if t t (myor 'b))))
+ (macro (let-values (((t) 'a)) (if t t (myor 'b))))
+ (rename-let-values (let-values (((t) 'a)) (if t t (myor 'b))))
+ (macro (let-values (((t) 'a)) (if t t 'b)))]
+ #:no-hidden-steps)
+
+ (test "leid with id"
+ (leid (id 'a))
+ [#:steps (macro 'a (leid (id 'a)))
+ (macro (#%expression 'a))]
+ #:no-hidden-steps)
+ (test "leid with Tid"
+ (leid (Tid 'a))
+ [#:steps (macro 'a (leid (Tid 'a)))
+ (macro (#%expression 'a))]
+ [#:hidden-steps (macro (leid 'a))])]
+
+ (test "lift"
+ (lift 'a)
+ [#:steps (local-lift lifted (lift 'a))
+ (macro (#%expression lifted))
+ (tag-top (#%expression (#%top . lifted)))
+ (capture-lifts (begin (define-values (lifted) 'a)
+ (#%expression (#%top . lifted))))]
+ #:no-hidden-steps)
+ (test "lift with id"
+ (lift (id 'a))
+ [#:steps (local-lift lifted (lift (id 'a)))
+ (macro (#%expression lifted))
+ (tag-top (#%expression (#%top . lifted)))
+ (capture-lifts (begin (define-values (lifted) (id 'a))
+ (#%expression (#%top . lifted))))
+ (macro (begin (define-values (lifted) 'a)
+ (#%expression (#%top . lifted))))]
+ #:no-hidden-steps)
+
+ (test "lift with Tid"
+ (lift (Tid 'a))
+ [#:steps (local-lift lifted (lift (Tid 'a)))
+ (macro (#%expression lifted))
+ (tag-top (#%expression (#%top . lifted)))
+ (capture-lifts (begin (define-values (lifted) (Tid 'a))
+ (#%expression (#%top . lifted))))
+ (macro (begin (define-values (lifted) 'a)
+ (#%expression (#%top . lifted))))]
+ ;; Don't show lifts, but do find (Tid 'a), show in orig ctx
+ [#:hidden-steps (macro (lift 'a))])
+
+ (test "Tlift"
+ (Tlift 'a)
+ [#:steps (local-lift lifted (Tlift 'a))
+ (macro (#%expression lifted))
+ (tag-top (#%expression (#%top . lifted)))
+ (capture-lifts (begin (define-values (lifted) 'a)
+ (#%expression (#%top . lifted))))]
+ [#:hidden-steps (local-lift lifted (Tlift 'a))
+ (macro (#%expression lifted))
+ (capture-lifts (begin (define-values (lifted) 'a)
+ (#%expression lifted)))])
+
+ (test "Tlift with id"
+ (Tlift (id 'a))
+ [#:steps (local-lift lifted (Tlift (id 'a)))
+ (macro (#%expression lifted))
+ (tag-top (#%expression (#%top . lifted)))
+ (capture-lifts (begin (define-values (lifted) (id 'a))
+ (#%expression (#%top . lifted))))
+ (macro (begin (define-values (lifted) 'a)
+ (#%expression (#%top . lifted))))]
+ [#:hidden-steps (local-lift lifted (Tlift (id 'a)))
+ (macro (#%expression lifted))
+ (capture-lifts (begin (define-values (lifted) (id 'a))
+ (#%expression lifted)))])
+
+ (test "Tlift with Tid"
+ (Tlift (Tid 'a))
+ [#:steps (local-lift lifted (Tlift (Tid 'a)))
+ (macro (#%expression lifted))
+ (tag-top (#%expression (#%top . lifted)))
+ (capture-lifts (begin (define-values (lifted) (Tid 'a))
+ (#%expression (#%top . lifted))))
+ (macro (begin (define-values (lifted) 'a)
+ (#%expression (#%top . lifted))))]
+ [#:steps (local-lift lifted (Tlift (Tid 'a)))
+ (macro (#%expression lifted))
+ (capture-lifts (begin (define-values (lifted) (Tid 'a))
+ (#%expression lifted)))
+ (macro (begin (define-values (lifted) 'a)
+ (#%expression lifted)))])
+
+ [#:suite "set! macros"
+ (test "set! (macro)"
+ (set! the-current-output-port 'a)
+ [#:steps
+ (macro (#%plain-app current-output-port 'a))]
+ #:no-hidden-steps)]
+
+ )
diff --git a/collects/tests/macro-debugger/tests/syntax-modules.ss b/collects/tests/macro-debugger/tests/syntax-modules.ss
@@ -0,0 +1,341 @@
+
+#lang scheme/base
+(require "../gentest-framework.ss")
+(provide proto:modules)
+
+(define-syntax-rule (testM form . clauses)
+ (test (format "~s" 'form) form . clauses))
+
+(define-tests proto:modules "Modules"
+ ;; FIXME: Finish adding hidden steps for modules
+
+ (test "module, MB, def"
+ (module m '#%kernel (#%module-begin (define-values (x) 'a)))
+ #:no-steps
+ #:no-hidden-steps)
+ (test "module, def"
+ (module m '#%kernel (define-values (x) 'a))
+ [#:steps
+ (tag-module-begin
+ (module m '#%kernel (#%module-begin (define-values (x) 'a))))]
+ #:same-hidden-steps)
+ (test "module, MB, def, use"
+ (module m '#%kernel (#%module-begin (define-values (x) 'a) x))
+ #:no-steps
+ #:no-hidden-steps)
+ (test "module, def, use"
+ (module m '#%kernel (define-values (x) 'a) x)
+ [#:steps
+ (tag-module-begin
+ (module m '#%kernel (#%module-begin (define-values (x) 'a) x)))]
+ #:same-hidden-steps)
+ (test "module, MB, quote"
+ (module m '#%kernel (#%module-begin 'a))
+ #:no-steps
+ #:no-hidden-steps)
+ (test "module, quote"
+ (module m '#%kernel 'a)
+ [#:steps
+ (tag-module-begin (module m '#%kernel (#%module-begin 'a)))]
+ #:same-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)
+ (test "module, MB, begin"
+ (module m '#%kernel (#%module-begin (begin 'a 'b)))
+ [#:steps
+ (splice-module (module m '#%kernel (#%module-begin 'a 'b)))]
+ #:same-hidden-steps)
+ (test "module, begin"
+ (module m '#%kernel (begin 'a 'b))
+ [#:steps
+ (tag-module-begin (module m '#%kernel (#%module-begin (begin 'a 'b))))
+ (splice-module (module m '#%kernel (#%module-begin 'a 'b)))]
+ #:same-hidden-steps)
+ (test "module, MB, def in begin"
+ (module m '#%kernel (#%module-begin (begin (define-values (x) 'a) x)))
+ [#:steps
+ (splice-module
+ (module m '#%kernel (#%module-begin (define-values (x) 'a) x)))]
+ #:same-hidden-steps)
+ (test "module, def in begin"
+ (module m '#%kernel (begin (define-values (x) 'a) x))
+ [#:steps
+ (tag-module-begin
+ (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)
+
+ (test "module, MB, defstx, use"
+ (module m '#%kernel
+ (#%module-begin
+ (#%require (for-syntax '#%kernel))
+ (define-syntaxes (x) (lambda (_) (if '#t (quote-syntax *) '#f)))
+ (x)))
+ [#:steps
+ (rename-lambda
+ (module m '#%kernel
+ (#%module-begin
+ (#%require (for-syntax '#%kernel))
+ (define-syntaxes (x) (lambda (_) (if '#t (quote-syntax *) '#f)))
+ (x))))
+ (macro
+ (module m '#%kernel
+ (#%module-begin
+ (#%require (for-syntax '#%kernel))
+ (define-syntaxes (x) (lambda (_) (if '#t (quote-syntax *) '#f)))
+ *)))]
+ [#:hidden-steps
+ (rename-lambda
+ (module m '#%kernel
+ (#%module-begin
+ (#%require (for-syntax '#%kernel))
+ (define-syntaxes (x) (lambda (_) (if '#t (quote-syntax *) '#f)))
+ (x))))])
+
+ (test "module k+helper, macro use"
+ (module m '#%kernel (#%require 'helper) (Tid 'a))
+ [#:steps
+ (tag-module-begin
+ (module m '#%kernel (#%module-begin (#%require 'helper) (Tid 'a))))
+ (macro
+ (module m '#%kernel
+ (#%module-begin
+ (#%require 'helper)
+ 'a)))]
+ #:same-hidden-steps)
+
+ (test "module k+helper, defs and opaque macros"
+ (module m '#%kernel
+ (#%module-begin
+ (#%require 'helper)
+ (id (define-values (x) (id '1)))
+ (id (define-values (y) (id '2)))))
+ [#:steps
+ (macro
+ (module m '#%kernel
+ (#%module-begin
+ (#%require 'helper)
+ (define-values (x) (id '1))
+ (id (define-values (y) (id '2))))))
+ (macro
+ (module m '#%kernel
+ (#%module-begin
+ (#%require 'helper)
+ (define-values (x) (id '1))
+ (define-values (y) (id '2)))))
+ (macro
+ (module m '#%kernel
+ (#%module-begin
+ (#%require 'helper)
+ (define-values (x) '1)
+ (define-values (y) (id '2)))))
+ (macro
+ (module m '#%kernel
+ (#%module-begin
+ (#%require 'helper)
+ (define-values (x) '1)
+ (define-values (y) '2))))]
+ #:no-hidden-steps)
+
+ (test "module k+helper, defs and mixed macros"
+ (module m '#%kernel
+ (#%module-begin
+ (#%require 'helper)
+ (Tid (define-values (x) (id '1)))
+ (id (define-values (y) (Tid '2)))))
+ [#:steps
+ (macro
+ (module m '#%kernel
+ (#%module-begin
+ (#%require 'helper)
+ (define-values (x) (id '1))
+ (id (define-values (y) (Tid '2))))))
+ (macro
+ (module m '#%kernel
+ (#%module-begin
+ (#%require 'helper)
+ (define-values (x) (id '1))
+ (define-values (y) (Tid '2)))))
+ (macro
+ (module m '#%kernel
+ (#%module-begin
+ (#%require 'helper)
+ (define-values (x) '1)
+ (define-values (y) (Tid '2)))))
+ (macro
+ (module m '#%kernel
+ (#%module-begin
+ (#%require 'helper)
+ (define-values (x) '1)
+ (define-values (y) '2))))]
+ [#:hidden-steps
+ (macro
+ (module m '#%kernel
+ (#%module-begin
+ (#%require 'helper)
+ (define-values (x) (id '1))
+ (id (define-values (y) (Tid '2))))))
+ (macro
+ (module m '#%kernel
+ (#%module-begin
+ (#%require 'helper)
+ (define-values (x) (id '1))
+ (id (define-values (y) '2)))))])
+
+ ;; need to test:
+ ;; begin-splicing
+ ;; lifts
+
+ (test "module mz, def, use"
+ (module m mzscheme (define-values (x) 'a) x)
+ [#:steps
+ (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)))])
+ (test "module mz, def"
+ (module m mzscheme (define-values (x) 'a))
+ [#:steps
+ (tag-module-begin
+ (module m mzscheme (#%module-begin (define-values (x) 'a))))
+ (macro
+ (module m mzscheme
+ (#%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))))])
+ (test "module mz, quote"
+ (module m mzscheme 'a)
+ [#:steps
+ (tag-module-begin
+ (module m mzscheme (#%module-begin 'a)))
+ (macro
+ (module m mzscheme
+ (#%plain-module-begin
+ (#%require (for-syntax scheme/mzscheme))
+ 'a)))]
+ [#:hidden-steps
+ (tag-module-begin
+ (module m mzscheme (#%module-begin 'a)))])
+
+ (test "module mz, begin with 2 quotes"
+ (module m mzscheme (begin 'a 'b))
+ [#:steps
+ (tag-module-begin
+ (module m mzscheme (#%module-begin (begin 'a 'b))))
+ (macro
+ (module m mzscheme
+ (#%plain-module-begin
+ (#%require (for-syntax scheme/mzscheme))
+ (begin 'a 'b))))
+ (splice-module
+ (module m mzscheme
+ (#%plain-module-begin
+ (#%require (for-syntax scheme/mzscheme))
+ 'a 'b)))]
+ [#:hidden-steps
+ (tag-module-begin
+ (module m mzscheme (#%module-begin (begin 'a 'b))))])
+
+ (test "module mz, macro use, quote"
+ (module m mzscheme (or 'a 'b) 'c)
+ [#:steps
+ (tag-module-begin
+ (module m mzscheme (#%module-begin (or 'a 'b) 'c)))
+ (macro
+ (module m mzscheme
+ (#%plain-module-begin
+ (#%require (for-syntax scheme/mzscheme))
+ (or 'a 'b)
+ 'c)))
+ (macro
+ (module m mzscheme
+ (#%plain-module-begin
+ (#%require (for-syntax scheme/mzscheme))
+ (let ([or-part 'a])
+ (if or-part or-part (or 'b)))
+ 'c)))
+ (macro
+ (module m mzscheme
+ (#%plain-module-begin
+ (#%require (for-syntax scheme/mzscheme))
+ (let-values ([(or-part) 'a])
+ (if or-part or-part (or 'b)))
+ 'c)))
+ (rename-let-values
+ (module m mzscheme
+ (#%plain-module-begin
+ (#%require (for-syntax scheme/mzscheme))
+ (let-values ([(or-part) 'a])
+ (if or-part or-part (or 'b)))
+ 'c)))
+ (macro
+ (module m mzscheme
+ (#%plain-module-begin
+ (#%require (for-syntax scheme/mzscheme))
+ (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)))])
+
+ (test "module mz, macro use"
+ (module m mzscheme (or 'a 'b))
+ [#:steps
+ (macro
+ (module m mzscheme
+ (let ([or-part 'a]) (if or-part or-part (or 'b)))))
+ (macro
+ (module m mzscheme
+ (let-values ([(or-part) 'a]) (if or-part or-part (or 'b)))))
+ (tag-module-begin
+ (module m mzscheme
+ (#%module-begin
+ (let-values ([(or-part) 'a])
+ (if or-part or-part (or 'b))))))
+ (macro
+ (module m mzscheme
+ (#%plain-module-begin
+ (#%require (for-syntax scheme/mzscheme))
+ (let-values ([(or-part) 'a])
+ (if or-part or-part (or 'b))))))
+ (rename-let-values
+ (module m mzscheme
+ (#%plain-module-begin
+ (#%require (for-syntax scheme/mzscheme))
+ (let-values ([(or-part) 'a])
+ (if or-part or-part (or 'b))))))
+ (macro
+ (module m mzscheme
+ (#%plain-module-begin
+ (#%require (for-syntax scheme/mzscheme))
+ (let-values ([(or-part) 'a])
+ (if or-part or-part 'b)))))])
+ ;; FIXME: hidden steps for above, tricky
+
+ (test "module with define-struct"
+ (module m mzscheme
+ (define-struct P (x y))
+ (P? (make-P P-x P-y))))
+ (test "module with match"
+ (module m mzscheme
+ (require (lib "match.ss"))
+ (match '4 [n (add1 n)])))
+ (test "module with match before require"
+ (module m mzscheme
+ (match '4 [n (add1 n)])
+ (require (lib "match.ss")))))
