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

sync Ryan's macro-debugger changes

Browse Source 
svn: r9166
This commit is contained in:
Matthew Flatt 2008-04-04 17:38:23 +00:00
parent f7ec875386
commit 5165d9e855
39 changed files with 1702 additions and 1575 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/macro-debugger/expand.ss
View File

@ -20,5 +20,5 @@
(let-values ([(result deriv) (trace/result stx)])
(when (exn? result)
(raise result))
(let-values ([(_d estx) (hide/policy deriv show?)])
(let-values ([(_d estx) (hide*/policy deriv show?)])
estx)))

6
collects/macro-debugger/model/debug.ss
View File

@ -7,9 +7,11 @@
"deriv-util.ss"
"deriv-find.ss"
"hide.ss"
"seek.ss"
"hiding-policies.ss"
"deriv.ss"
"steps.ss")
"steps.ss"
"synth-derivs.ss")
(provide (all-from-out "trace.ss")
(all-from-out "reductions.ss")
@ -18,5 +20,7 @@
(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))

42
collects/macro-debugger/model/deriv-c.ss
View File

@ -16,6 +16,7 @@
(define-struct (deriv node) () #: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
;; (make-lift/let-deriv <Node(Stx)> Deriv Stx Deriv)
@ -24,7 +25,7 @@
;; A Transformation is
;; (make-transformation <Node(Stx)> Rs ?exn ?Stx (list-of LocalAction) ?exn ?Stx Number)
(define-struct (transformation node) (resolves ?1 me1 locals ?2 me2 seq) #:transparent)
(define-struct (transformation node) (resolves ?1 me1 locals me2 ?2 seq) #:transparent)
;; A LocalAction is one of
;; (make-local-expansion <Node(Stx)> Stx ?Stx Boolean Deriv)
@ -32,11 +33,11 @@
;; (make-local-lift Stx Identifier)
;; (make-local-lift-end Stx)
;; (make-local-bind BindSyntaxes)
(define-struct (local-expansion node) (me1 me2 for-stx? inner) #:transparent)
(define-struct (local-expansion/expr node) (me1 me2 for-stx? opaque inner) #:transparent)
(define-struct (local-expansion node) (me1 me2 inner for-stx? lifted opaque)
#:transparent)
(define-struct local-lift (expr id) #:transparent)
(define-struct local-lift-end (decl) #:transparent)
(define-struct local-bind (bindrhs) #:transparent)
(define-struct local-bind (names bindrhs) #:transparent)
;; Base = << Node(Stx) Rs ?exn >>
(define-struct (base deriv) (resolves ?1) #:transparent)
@ -45,10 +46,11 @@
(define-struct (prule base) () #:transparent)
(define-struct (p:variable prule) () #:transparent)
;; (make-p:module <Base> Boolean ?Deriv ?exn Deriv)
;; (make-p:#%module-begin <Base> ModulePass1 ModulePass2 ?exn)
(define-struct (p:module prule) (one-body-form? mb ?2 body) #:transparent)
(define-struct (p:#%module-begin prule) (pass1 pass2 ?2) #:transparent)
;; (make-p:module <Base> ?exn ?stx stx ?Deriv ?stx ?exn Deriv ?stx)
;; (make-p:#%module-begin <Base> Stx ModulePass1 ModulePass2 ?exn)
(define-struct (p:module prule) (?2 tag rename check tag2 ?3 body shift)
#:transparent)
(define-struct (p:#%module-begin prule) (me pass1 pass2 ?2) #:transparent)
;; (make-p:define-syntaxes <Base> DerivLL)
;; (make-p:define-values <Base> Deriv)
@ -61,7 +63,7 @@
;; (make-p:set! <Base> Rs Deriv)
;; (make-p:set!-macro <Base> Rs Deriv)
(define-struct (p:#%expression prule) (inner) #:transparent)
(define-struct (p:if prule) (full? test then else) #: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)
(define-struct (p:set!-macro prule) (deriv) #:transparent)
@ -69,7 +71,7 @@
;; (make-p:#%app <Base> Stx LDeriv)
;; (make-p:begin <Base> LDeriv)
;; (make-p:begin0 <Base> Deriv LDeriv)
(define-struct (p:#%app prule) (tagged-stx lderiv) #:transparent)
(define-struct (p:#%app prule) (lderiv) #:transparent)
(define-struct (p:begin prule) (lderiv) #:transparent)
(define-struct (p:begin0 prule) (first lderiv) #:transparent)
@ -97,8 +99,8 @@
(define-struct (p::STOP prule) () #:transparent)
(define-struct (p:stop p::STOP) () #:transparent)
(define-struct (p:unknown p::STOP) () #:transparent)
(define-struct (p:#%top p::STOP) (tagged-stx) #:transparent)
(define-struct (p:#%datum p::STOP) (tagged-stx) #:transparent)
(define-struct (p:#%top p::STOP) () #:transparent)
(define-struct (p:#%datum p::STOP) () #:transparent)
(define-struct (p:quote p::STOP) () #:transparent)
(define-struct (p:quote-syntax p::STOP) () #:transparent)
(define-struct (p:require p::STOP) () #:transparent)
@ -151,21 +153,21 @@
;; A ModPass2 is (list-of ModRule2)
;; A ModRule1 is one of
;; (make-mod:prim Deriv ModPrim)
;; (make-mod:splice Deriv ?exn Stxs)
;; (make-mod:lift Deriv Stxs)
;; (make-mod:prim Deriv Stx ModPrim)
;; (make-mod:splice Deriv Stx ?exn Stxs)
;; (make-mod:lift Deriv ?Stxs Stxs)
;; (make-mod:lift-end Stxs)
;; A ModRule2 is one of
;; (make-mod:skip)
;; (make-mod:cons Deriv)
;; (make-mod:lift Deriv Stxs)
(define-struct modrule () #:transparent)
(define-struct (mod:cons modrule) (head) #:transparent)
(define-struct (mod:prim modrule) (head prim) #:transparent)
(define-struct (mod:skip modrule) () #:transparent)
(define-struct (mod:splice modrule) (head ?1 tail) #:transparent)
(define-struct (mod:lift modrule) (head tail) #:transparent)
(define-struct (mod:prim modrule) (head rename prim) #:transparent)
(define-struct (mod:splice modrule) (head rename ?1 tail) #:transparent)
(define-struct (mod:lift modrule) (head renames tail) #:transparent)
(define-struct (mod:lift-end modrule) (tail) #:transparent)
(define-struct (mod:cons modrule) (head) #:transparent)
(define-struct (mod:skip modrule) () #:transparent)
;; A ModPrim is a PRule in:
;; (make-p:define-values <Base> #:transparent)

32
collects/macro-debugger/model/deriv-find.ss
View File

@ -20,7 +20,8 @@
;; find-deriv : (deriv -> boolean) (deriv -> boolean) deriv -> deriv/#f
;; Finds the first deriv that matches; throws the rest away
(define (find-deriv pred stop-short d)
(let ([stop (lambda (x) (or (pred x) (stop-short x)))])
(let* ([stop-short (or stop-short (lambda (x) #f))]
[stop (lambda (x) (or (pred x) (stop-short x)))])
(let/ec return (find-deriv/unit+join+zero pred stop d return (lambda _ #f) #f))))
;; find-deriv/unit+join+zero
@ -36,15 +37,15 @@
[(? stop-short d) zero]
[(Wrap mrule (_ _ tx next))
(join (loop tx) (loop next))]
[(Wrap tagrule (_ _ _ next))
(loop next)]
[(Wrap lift-deriv (_ _ first lift second))
(join (loop first) (loop second))]
[(Wrap transformation (_ _ _ _ _ locals _ _ _))
(loops locals)]
[(struct local-expansion (_ _ _ _ _ deriv))
[(struct local-expansion (_ _ _ _ deriv _ _ _))
(loop deriv)]
[(struct local-expansion/expr (_ _ _ _ _ _ deriv))
(loop deriv)]
[(struct local-bind (bindrhs))
[(struct local-bind (_ bindrhs))
(loop bindrhs)]
[(Wrap p:define-syntaxes (_ _ _ _ rhs _))
(loop rhs)]
@ -52,7 +53,7 @@
(loop rhs)]
[(Wrap p:#%expression (_ _ _ _ inner))
(loop inner)]
[(Wrap p:if (_ _ _ _ _ test then else))
[(Wrap p:if (_ _ _ _ test then else))
(join (loop test) (loop then) (loop else))]
[(Wrap p:wcm (_ _ _ _ key value body))
(join (loop key) (loop value) (loop body))]
@ -64,7 +65,7 @@
(loop lderiv)]
[(Wrap p:begin0 (_ _ _ _ first lderiv))
(join (loop first) (loop lderiv))]
[(Wrap p:#%app (_ _ _ _ _ lderiv))
[(Wrap p:#%app (_ _ _ _ lderiv))
(loop lderiv)]
[(Wrap p:lambda (_ _ _ _ _ body))
(loop body)]
@ -76,9 +77,9 @@
(join (loops rhss) (loop body))]
[(Wrap p:letrec-syntaxes+values (_ _ _ _ _ srhss _ vrhss body))
(join (loops srhss) (loops vrhss) (loop body))]
[(Wrap p:module (_ _ _ _ _ _ _ body ))
(loop body)]
[(Wrap p:#%module-begin (_ _ _ _ pass1 pass2 _))
[(Wrap p:module (_ _ _ _ _ _ _ check _ _ body _))
(join (loop check) (loop body))]
[(Wrap p:#%module-begin (_ _ _ _ _ pass1 pass2 _))
(join (loops pass1) (loops pass2))]
[(Wrap p:rename (_ _ _ _ _ inner))
(loop inner)]
@ -102,11 +103,11 @@
;; (join (loop head) (loop inner))]
[(Wrap mod:cons (head))
(loop head)]
[(Wrap mod:prim (head prim))
[(Wrap mod:prim (head _ prim))
(join (loop head) (loop prim))]
[(Wrap mod:splice (head _ _))
[(Wrap mod:splice (head _ _ _))
(loop head)]
[(Wrap mod:lift (head tail))
[(Wrap mod:lift (head _ tail))
(join (loop head) (loop tail))]
[(Wrap mod:lift-end (tail))
(loop tail)]
@ -128,10 +129,7 @@
[(Wrap deriv (e1 e2))
(pred e1)]
[_ #f])
(match-lambda
;; FIXME: Why?
[(Wrap p:module (_ _ _ _ _ _ _ _)) #t]
[_ #f])
(lambda _ #f)
d))
;; extract-all-fresh-names : Derivation -> syntaxlike

273
collects/macro-debugger/model/deriv-parser.ss
View File

@ -49,7 +49,8 @@
(tokens basic-tokens prim-tokens renames-tokens)
(end EOF)
(error deriv-error)
#;(debug "DEBUG-PARSER.txt"))
#;(debug "/Users/ryanc/DEBUG-PARSER.txt")
)
;; tokens
(skipped-token-values
@ -60,12 +61,15 @@
enter-list exit-list
enter-check exit-check
local-post exit-local exit-local/expr
local-bind enter-bind exit-bind
phase-up module-body
renames-lambda
renames-case-lambda
renames-let
renames-letrec-syntaxes
renames-block
rename-one
rename-list
IMPOSSIBLE)
;; Entry point
@ -76,42 +80,17 @@
(productions/I
;; Expand/Lifts
;; Expand with possible lifting
(EE/Lifts
(#:no-wrap)
[((? EE)) $1]
[((? EE/Lifts+)) $1])
(EE/Lifts+
(#:no-wrap)
[(EE lift-loop (? EE/Lifts))
(let ([e1 (wderiv-e1 $1)]
[e2 (wderiv-e2 $3)])
(make lift-deriv e1 e2 $1 $2 $3))])
;; Expansion of an expression
;; EE Answer = Derivation (I)
(EE
(#:no-wrap)
[(visit (? PrimStep) return)
($2 $1 $3)]
[((? EE/Macro))
$1])
(EE/Macro
(#:wrap)
[(visit (? MacroStep) (? EE))
(make mrule $1 (and $3 (wderiv-e2 $3)) $2 $3)])
;; Expand/LetLifts
;; Used for expand_lift_to_let (rhs of define-syntaxes, mostly)
;; Expand, convert lifts to let (rhs of define-syntaxes, mostly)
(EE/LetLifts
(#:no-wrap)
[((? EE)) $1]
[((? EE/LetLifts+)) $1])
(EE/LetLifts+
(#:wrap)
[(EE lift/let-loop (? EE/LetLifts))
(let ([initial (wderiv-e1 $1)]
[final (wderiv-e2 $3)])
@ -120,126 +99,128 @@
;; Evaluation
;; Answer = ?exn
(Eval
(#:no-wrap)
[() #f]
[(!!) $1]
[(start EE/Interrupted) (create-eval-exn $2)]
[(start EE (? Eval)) $3]
[(start CheckImmediateMacro/Interrupted) (create-eval-exn $2)]
[(start CheckImmediateMacro (? Eval)) $3])
;; Expansion of an expression to primitive form
(CheckImmediateMacro
(#:no-wrap)
[(enter-check (? CheckImmediateMacro/Inner) exit-check)
($2 $1 $3 (lambda (ce1 ce2) (make p:stop ce1 ce2 null #f)))])
(CheckImmediateMacro/Inner
(#:args e1 e2 k)
(#:wrap)
[()
(k e1 e2)]
[(visit (? MacroStep) return (? CheckImmediateMacro/Inner))
(let ([next ($4 $3 e2 k)])
(make mrule $1 (and next (wderiv-e2 next)) $2 next))])
[(visit Resolves (? MacroStep) return (? CheckImmediateMacro/Inner))
(let ([next ($5 $4 e2 k)])
(make mrule $1 (and next (wderiv-e2 next)) ($3 $2) next))]
[(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)))])
;; Expansion of multiple expressions, next-separated
(NextEEs
(#:no-wrap)
(#:skipped null)
[() null]
[(next (? EE) (? NextEEs)) (cons $2 $3)])
;; EE
;; Expand expression (term)
(EE
[(visit Resolves (? EE/k))
($3 $1 $2)]
[(visit Resolves tag (? EE/k))
(let ([next ($4 $1 $2)])
(make tagrule $1 (wderiv-e2 next) $3 next))])
(EE/k
(#:args e1 rs)
[((? PrimStep) return)
($1 e1 $2 rs)]
[((? MacroStep) (? EE))
(make mrule e1 (and $2 (wderiv-e2 $2)) ($1 rs) $2)])
;; Keyword resolution
(Resolves
(#:no-wrap)
[() null]
[(resolve Resolves) (cons $1 $2)])
;; Single macro step (may contain local-expand calls)
;; MacroStep Answer = Transformation (I,E)
(MacroStep
(#:wrap)
[(Resolves enter-macro ! macro-pre-transform (? LocalActions)
! macro-post-transform exit-macro)
(make transformation $2 $8 $1 $3 $4 $5 $6 $7 (new-sequence-number))])
(#: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
(#:no-wrap)
(#:skipped null)
[() null]
[((? LocalAction) (? LocalActions)) (cons $1 $2)]
[((? NotReallyLocalAction) (? LocalActions)) $2])
(LocalAction
(#:no-wrap)
[(enter-local local-pre start (? EE) local-post exit-local)
(make local-expansion $1 $6 $2 $5 #f $4)]
[(enter-local phase-up local-pre start (? EE) local-post exit-local)
(make local-expansion $1 $7 $3 $6 #t $5)]
[(enter-local/expr local-pre start (? EE) local-post exit-local/expr)
(make local-expansion/expr $1 (car $6) $2 $5 #f (cdr $6) $4)]
[(enter-local/expr local-pre phase-up start (? EE) local-post exit-local/expr)
(make local-expansion/expr $1 (car $7) $3 $6 #t (cdr $7) $5)]
[(enter-local OptPhaseUp
local-pre (? LocalExpand/Inner) local-post
OptLifted OptOpaqueExpr exit-local)
(make local-expansion $1 $8 $3 $5 $4 $2 $6 $7)]
[(lift)
(make local-lift (cdr $1) (car $1))]
[(lift-statement)
(make local-lift-end $1)]
[((? BindSyntaxes))
(make local-bind $1)])
[(local-bind (? BindSyntaxes))
(make local-bind $1 $2)])
(LocalExpand/Inner
[(start (? EE)) $2]
[((? CheckImmediateMacro)) $1])
(OptLifted
[(lift-loop) $1]
[() #f])
(OptOpaqueExpr
[(opaque) $1]
[() #f])
(OptPhaseUp
[(phase-up) #t]
[() #f])
(NotReallyLocalAction
(#:no-wrap)
;; called 'expand' (not 'local-expand') within transformer
[(start (? EE))
(make local-expansion (wderiv-e1 $2)
(wderiv-e2 $2)
(wderiv-e1 $2)
(wderiv-e2 $2)
#f
$2)])
#f])
;; Primitive
(PrimStep
(#:args e1 e2)
(#:no-wrap)
[(Resolves (? PrimError))
($2 e1 e2 $1)]
[(Resolves Variable)
($2 e1 e2 $1)]
[(Resolves enter-prim (? Prim) exit-prim)
($3 e1 e2 $1)]
[(Resolves enter-prim (? TaggedPrim) exit-prim)
($3 e1 $4 $1 $2)])
(PrimError
(#:args e1 e2 rs)
(#:wrap)
[(! IMPOSSIBLE)
(make p:unknown e1 e2 rs $1)])
(Variable
(#:args e1 e2 rs)
(#:wrap)
[(!!)
(make p:unknown e1 e2 rs $1)]
[(variable)
(make p:variable e1 e2 rs #f)])
(TaggedPrim
(#:args e1 e2 rs tagged-stx)
(#:no-wrap)
[((? Prim#%App)) ($1 e1 e2 rs tagged-stx)]
[((? Prim#%Datum)) ($1 e1 e2 rs tagged-stx)]
[((? Prim#%Top)) ($1 e1 e2 rs tagged-stx)])
(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)
(#:no-wrap)
[((? PrimModule)) ($1 e1 e2 rs)]
[((? Prim#%ModuleBegin)) ($1 e1 e2 rs)]
[((? PrimDefineSyntaxes)) ($1 e1 e2 rs)]
[((? PrimDefineValues)) ($1 e1 e2 rs)]
[((? PrimExpression)) ($1 e1 e2 rs)]
[((? Prim#%App)) ($1 e1 e2 rs)]
[((? Prim#%Datum)) ($1 e1 e2 rs)]
[((? Prim#%Top)) ($1 e1 e2 rs)]
[((? PrimIf)) ($1 e1 e2 rs)]
[((? PrimWCM)) ($1 e1 e2 rs)]
[((? PrimSet)) ($1 e1 e2 rs)]
@ -261,22 +242,24 @@
(PrimModule
(#:args e1 e2 rs)
(#:wrap)
;; Multiple forms after language: tagging done automatically
[(prim-module (? Eval) (? EE))
(make p:module e1 e2 rs $2 #f #f #f $3)]
;; One form after language: macro that expands into #%module-begin
[(prim-module Eval next (? CheckImmediateMacro) next ! (? EE))
(make p:module e1 e2 rs #f #t $4 $6 $7)])
[(prim-module ! next (? Eval) OptTag rename-one
(? OptCheckImmediateMacro) OptTag !
(? EE) rename-one)
(make p:module e1 e2 rs $2 $4 $5 $6 $7 $8 $9 $10 $11)])
(OptTag
[() #f]
[(tag) $1])
(OptCheckImmediateMacro
[() #f]
[((? CheckImmediateMacro)) $1])
(Prim#%ModuleBegin
(#:args e1 e2 rs)
(#:wrap)
[(prim-#%module-begin ! (? ModulePass1) next-group (? ModulePass2) !)
(make p:#%module-begin e1 e2 rs $2 $3 $5 $6)])
[(prim-#%module-begin ! rename-one
(? ModulePass1) next-group (? ModulePass2) !)
(make p:#%module-begin e1 e2 rs $2 $3 $4 $6 $7)])
(ModulePass1
(#:no-wrap)
(#:skipped null)
[() null]
[(next (? ModulePass1-Part) (? ModulePass1))
@ -285,16 +268,14 @@
(cons (make mod:lift-end $1) $2)])
(ModulePass1-Part
(#:wrap)
[((? EE) (? ModulePass1/Prim))
(make mod:prim $1 $2)]
[(EE ! splice)
(make mod:splice $1 $2 $3)]
[(EE module-lift-loop)
(make mod:lift $1 $2)])
[((? EE) rename-one (? ModulePass1/Prim))
(make mod:prim $1 $2 $3)]
[(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
(#:wrap)
[(enter-prim prim-define-values ! exit-prim)
(make p:define-values $1 $4 null $3 #f)]
[(enter-prim prim-define-syntaxes !
@ -306,13 +287,10 @@
(make p:require-for-syntax $1 $4 null $3)]
[(enter-prim prim-require-for-template (? Eval) exit-prim)
(make p:require-for-template $1 $4 null $3)]
[(enter-prim prim-provide ! exit-prim)
(make p:provide $1 $4 null $3)]
[()
#f])
(ModulePass2
(#:no-wrap)
(#:skipped null)
[() null]
[(next (? ModulePass2-Part) (? ModulePass2))
@ -321,106 +299,98 @@
(cons (make mod:lift-end $1) $2)])
(ModulePass2-Part
(#:no-wrap)
;; not normal; already handled
[()
(make mod:skip)]
;; provide: special
[(enter-prim prim-provide (? ModuleProvide/Inner) exit-prim)
(make mod:cons (make p:provide $1 $4 null $3))]
;; normal: expand completely
[((? EE))
(make mod:cons $1)]
;; catch lifts
[(EE module-lift-loop)
(make mod:lift $1 $2)])
(make mod:lift $1 #f $2)])
(ModuleProvide/Inner
[() #f]
[(!!) $1]
[(EE/Interrupted) $1]
[(EE (? ModuleProvide/Inner)) $2])
;; Definitions
(PrimDefineSyntaxes
(#:args e1 e2 rs)
(#:wrap)
[(prim-define-syntaxes ! (? EE/LetLifts) (? Eval))
(make p:define-syntaxes e1 e2 rs $2 $3 $4)])
(PrimDefineValues
(#:args e1 e2 rs)
(#:wrap)
[(prim-define-values ! (? EE))
(make p:define-values e1 e2 rs $2 $3)])
;; Simple expressions
(PrimExpression
(#:args e1 e2 rs)
(#:wrap)
[(prim-expression ! (? EE))
(make p:#%expression e1 e2 rs $2 $3)])
(PrimIf
(#:args e1 e2 rs)
(#:wrap)
[(prim-if ! (? EE) next (? EE) next (? EE))
(make p:if e1 e2 rs $2 #t $3 $5 $7)]
[(prim-if next-group (? EE) next (? EE))
(make p:if e1 e2 rs #f #f $3 $5 #f)])
(make p:if e1 e2 rs $2 $3 $5 $7)])
(PrimWCM
(#:args e1 e2 rs)
(#:wrap)
[(prim-wcm ! (? EE) next (? EE) next (? EE))
(make p:wcm e1 e2 rs $2 $3 $5 $7)])
;; Sequence-containing expressions
(PrimBegin
(#:args e1 e2 rs)
(#:wrap)
[(prim-begin ! (? EL))
(make p:begin e1 e2 rs $2 $3)])
(PrimBegin0
(#:args e1 e2 rs)
(#:wrap)
[(prim-begin0 ! next (? EE) next (? EL))
(make p:begin0 e1 e2 rs $2 $4 $6)])
(Prim#%App
(#:args e1 e2 rs tagged-stx)
(#:wrap)
(#:args e1 e2 rs)
[(prim-#%app !)
(make p:#%app e1 e2 rs $2 tagged-stx (make lderiv null null #f null))]
(make p:#%app e1 e2 rs $2 (make lderiv null null #f null))]
[(prim-#%app (? EL))
(make p:#%app e1 e2 rs #f tagged-stx $2)])
(make p:#%app e1 e2 rs #f $2)])
;; Binding expressions
(PrimLambda
(#:args e1 e2 rs)
(#:wrap)
[(prim-lambda ! renames-lambda (? EB))
(make p:lambda e1 e2 rs $2 $3 $4)])
(PrimCaseLambda
(#:args e1 e2 rs)
(#:wrap)
[(prim-case-lambda ! (? NextCaseLambdaClauses))
(make p:case-lambda e1 e2 rs $2 $3)])
(NextCaseLambdaClauses
(#:skipped null)
(#:no-wrap)
[(next (? CaseLambdaClause) (? NextCaseLambdaClauses))
(cons $2 $3)]
[() null])
(CaseLambdaClause
(#:wrap)
[(! renames-case-lambda (? EB))
(make clc $1 $2 $3)])
(PrimLetValues
(#:args e1 e2 rs)
(#:wrap)
[(prim-let-values ! renames-let (? NextEEs) next-group (? EB))
(make p:let-values e1 e2 rs $2 $3 $4 $6)])
(PrimLet*Values
(#:args e1 e2 rs)
(#:wrap)
;; let*-values with bindings is "macro-like"
[(prim-let*-values !!)
(let ([tx (make transformation e1 #f rs $2
@ -429,7 +399,7 @@
[(prim-let*-values (? EE))
(let* ([next-e1 (wderiv-e1 $2)]
[tx (make transformation e1 next-e1 rs #f
e1 null #f next-e1 (new-sequence-number))])
e1 null next-e1 #f (new-sequence-number))])
(make mrule e1 e2 tx $2))]
;; No bindings... model as "let"
[(prim-let*-values renames-let (? NextEEs) next-group (? EB))
@ -437,13 +407,11 @@
(PrimLetrecValues
(#:args e1 e2 rs)
(#:wrap)
[(prim-letrec-values ! renames-let (? NextEEs) next-group (? EB))
(make p:letrec-values e1 e2 rs $2 $3 $4 $6)])
(PrimLetrecSyntaxes+Values
(#:args e1 e2 rs)
(#:wrap)
[(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)]
@ -455,66 +423,55 @@
;; Atomic expressions
(Prim#%Datum
(#:args e1 e2 rs tagged-stx)
(#:wrap)
[(prim-#%datum !) (make p:#%datum e1 e2 rs $2 tagged-stx)])
(#:args e1 e2 rs)
[(prim-#%datum !) (make p:#%datum e1 e2 rs $2)])
(Prim#%Top
(#:args e1 e2 rs tagged-stx)
(#:wrap)
[(prim-#%top !) (make p:#%top e1 e2 rs $2 tagged-stx)])
(#:args e1 e2 rs)
[(prim-#%top !) (make p:#%top e1 e2 rs $2)])
(PrimSTOP
(#:args e1 e2 rs)
(#:wrap)
[(prim-stop !) (make p:stop e1 e2 rs $2)])
(PrimQuote
(#:args e1 e2 rs)
(#:wrap)
[(prim-quote !) (make p:quote e1 e2 rs $2)])
(PrimQuoteSyntax
(#:args e1 e2 rs)
(#:wrap)
[(prim-quote-syntax !) (make p:quote-syntax e1 e2 rs $2)])
(PrimRequire
(#:args e1 e2 rs)
(#:wrap)
[(prim-require (? Eval))
(make p:require e1 e2 rs $2)])
(PrimRequireForSyntax
(#:args e1 e2 rs)
(#:wrap)
[(prim-require-for-syntax (? Eval))
(make p:require-for-syntax e1 e2 rs $2)])
(PrimRequireForTemplate
(#:args e1 e2 rs)
(#:wrap)
[(prim-require-for-template (? Eval))
(make p:require-for-template e1 e2 rs $2)])
(PrimProvide
(#:args e1 e2 rs)
(#:wrap)
[(prim-provide !) (make p:provide e1 e2 rs $2)])
(PrimSet
(#:args e1 e2 rs)
(#:wrap)
[(prim-set! ! Resolves next (? EE))
(make p:set! e1 e2 rs $2 $3 $5)]
[(prim-set! (? MacroStep) (? EE))
[(prim-set! Resolves (? MacroStep) (? EE))
(make p:set!-macro e1 e2 rs #f
(make mrule e1 (and $3 (wderiv-e2 $3)) $2 $3))])
(make mrule e1 (and $4 (wderiv-e2 $4)) ($3 $2) $4))])
;; Blocks
;; EB Answer = BlockDerivation
(EB
(#:wrap)
[(enter-block (? BlockPass1) block->list (? EL))
(make bderiv $1 (and $4 (wlderiv-es2 $4))
$2 'list $4)]
@ -524,7 +481,6 @@
;; BlockPass1 Answer = (list-of BRule)
(BlockPass1
(#:no-wrap)
(#:skipped null)
[() null]
[((? BRule) (? BlockPass1))
@ -532,7 +488,6 @@
;; BRule Answer = BRule
(BRule
(#:wrap)
[(next !!)
(make b:error $2)]
[(next renames-block (? CheckImmediateMacro))
@ -547,13 +502,11 @@
;; BindSyntaxes Answer = Derivation
(BindSyntaxes
(#:wrap)
[(phase-up (? EE/LetLifts) (? Eval))
(make bind-syntaxes $2 $3)])
[(enter-bind (? EE/LetLifts) next (? Eval) exit-bind)
(make bind-syntaxes $2 $4)])
;; NextBindSyntaxess Answer = (list-of Derivation)
(NextBindSyntaxess
(#:no-wrap)
(#:skipped null)
[() null]
[(next (? BindSyntaxes) (? NextBindSyntaxess)) (cons $2 $3)])
@ -561,7 +514,6 @@
;; Lists
;; EL Answer = ListDerivation
(EL
(#:wrap)
(#:skipped #f)
[(enter-list ! (? EL*) exit-list)
;; FIXME: Workaround for bug in events
@ -571,7 +523,6 @@
;; EL* Answer = (listof Derivation)
(EL*
(#:no-wrap)
(#:skipped null)
[() null]
[(next (? EE) (? EL*)) (cons $2 $3)])

18
collects/macro-debugger/model/deriv-tokens.ss
View File

@ -44,7 +44,16 @@
enter-local/expr ; syntax
exit-local/expr ; (cons syntax expanded-expression)
variable ; (cons identifier identifier)
local-bind ; (list-of identifier)
enter-bind ; .
exit-bind ; .
opaque ; opaque-syntax
variable ; (cons identifier identifier)
tag ; syntax
rename-one ; syntax
rename-list ; (list-of syntax)
IMPOSSIBLE ; useful for error-handling clauses that have no NoError counterpart
))
@ -142,6 +151,13 @@
(139 . ,token-enter-local/expr)
(140 . ,token-exit-local/expr)
(141 . ,token-start)
(142 . ,token-tag)
(143 . ,token-local-bind)
(144 . ,token-enter-bind)
(145 . ,token-exit-bind)
(146 . ,token-opaque)
(147 . ,token-rename-list)
(148 . ,token-rename-one)
))
(define (tokenize sig-n val pos)

2
collects/macro-debugger/model/deriv.ss
View File

@ -59,8 +59,8 @@
[?1 (?? exn?)]
[me1 (?? syntax?)]
[locals (?? (listof localaction/c))]
[?2 (?? exn?)]
[me2 (?? syntax?)]
[?2 (?? exn?)]
[seq number?]))
(struct (local-expansion node)
([z1 syntax?]

602
collects/macro-debugger/model/hide.ss
View File

@ -7,9 +7,11 @@
"synth-engine.ss"
"synth-derivs.ss"
"stx-util.ss"
"context.ss")
"context.ss"
"seek.ss")
(provide hide/policy
hide*/policy
macro-policy
force-letrec-transformation
current-hiding-warning-handler
@ -18,81 +20,17 @@
(struct-out localactions)
(struct-out hidden-lift-site))
;; hide/policy : WDeriv (identifier -> boolean) -> (values WDeriv syntax)
;; hide/policy : WDeriv (identifier -> boolean) -> WDeriv
(define (hide/policy deriv show-macro?)
(parameterize ((macro-policy show-macro?))
(let-values ([(d s) (hide*/policy deriv show-macro?)])
d))
;; hide*/policy : WDeriv (identifier -> boolean) -> (values WDeriv syntax)
(define (hide*/policy deriv show-macro?)
(parameterize ((macro-policy show-macro?)
(current-seek-processor hide/deriv))
(hide deriv)))
;; Warnings
(define (handle-hiding-failure d failure)
(match failure
[(struct nonlinearity (term paths))
(warn 'nonlinearity term paths d)]
[(struct localactions ())
(warn 'localactions d)]
[(struct hidden-lift-site ())
(warn 'hidden-lift-site d)]))
(define-syntax DEBUG-LIFTS
(syntax-rules ()
[(DEBUG-LIFTS . b)
(begin . b)]))
;; current-unvisited-lifts : (paramter-of Derivation)
;; The derivs for the lifts yet to be seen in the processing
;; of the first part of the current lift-deriv.
(define current-unvisited-lifts (make-parameter null))
;; current-unhidden-lifts : (parameter-of Derivation)
;; The derivs for those lifts that occur within unhidden macros.
;; Derivs are moved from the current-unvisited-lifts to this list.
(define current-unhidden-lifts (make-parameter null))
;; add-unhidden-lift : Derivation -> void
(define (add-unhidden-lift d)
(when d
(current-unhidden-lifts
(cons d (current-unhidden-lifts)))))
;; extract/remove-unvisted-lift : identifier -> Derivation
(define (extract/remove-unvisited-lift id)
(define (get-defined-id d)
(match d
[(Wrap deriv (e1 e2))
(with-syntax ([(?define-values (?id) ?expr) e1])
#'?id)]))
;; The Wrong Way
(let ([unvisited (current-unvisited-lifts)])
(if (null? unvisited)
(begin (printf "hide:extract/remove-unvisited-lift: out of lifts!")
#f)
(let ([lift (car unvisited)])
(DEBUG-LIFTS
(printf "extracting lift: ~s left\n" (length (cdr unvisited))))
(current-unvisited-lifts (cdr unvisited))
lift)))
;; The Right Way
;; FIXME: Doesn't work inside of modules. Why not?
#;
(let loop ([lifts (current-unvisited-lifts)]
[prefix null])
(cond [(null? lifts)
(DEBUG-LIFTS
(fprintf (current-error-port)
"hide:extract/remove-unvisited-lift: can't find lift for ~s~n"
id))
(raise (make localactions))]
[(bound-identifier=? id (get-defined-id (car lifts)))
(let ([lift (car lifts)])
(current-unvisited-lifts
(let loop ([prefix prefix] [lifts (cdr lifts)])
(if (null? prefix)
lifts
(loop (cdr prefix) (cons (car prefix) lifts)))))
lift)]
[else
(loop (cdr lifts) (cons (car lifts) prefix))])))
;
;
@ -162,6 +100,11 @@
;; The derivation is "visible" or "active" by default,
;; but pieces of it may need to be hidden.
;; hide/deriv : WDeriv -> WDeriv
(define (hide/deriv d)
(let-values ([(d s) (hide d)])
d))
;; hide : WDeriv -> (values WDeriv syntax)
(define (hide deriv)
(for-deriv deriv))
@ -172,6 +115,21 @@
;; Primitives
[(Wrap p:variable (e1 e2 rs ?1))
(values d e2)]
[(Wrap p:module (e1 e2 rs ?1 ?2 tag rename check tag2 ?3 body shift))
(let ([show-k
(lambda ()
(>>Prim d e1 #t (p:module ?2 tag rename check tag2 ?3 body shift)
(module name lang . _BODY)
(module name lang BODY)
([for-deriv BODY body])))])
(if (or (show-macro? #'module))
(show-k)
(with-handlers ([hiding-failure?
(lambda (failure)
(handle-hiding-failure d failure)
(show-k))])
(seek/deriv d))))]
#; ;; OLD CODE
[(Wrap p:module (e1 e2 rs ?1 #f #f #f body))
(let ([show-k
(lambda ()
@ -186,6 +144,7 @@
(handle-hiding-failure d failure)
(show-k))])
(seek/deriv d))))]
#; ;; OLD CODE
[(Wrap p:module (e1 e2 rs ?1 #t mb ?2 body))
(let ([show-k
(lambda ()
@ -201,7 +160,7 @@
(handle-hiding-failure d failure)
(show-k))])
(seek/deriv d))))]
[(Wrap p:#%module-begin (e1 e2 rs ?1 pass1 pass2 ?2))
[(Wrap p:#%module-begin (e1 e2 rs ?1 me pass1 pass2 ?2))
(let ([lderiv (module-begin->lderiv d)])
(recv [(lderiv es2) (for-lderiv lderiv)]
[(d) (lderiv->module-begin lderiv e1 rs)]
@ -218,17 +177,12 @@
(>>P d (p:#%expression inner)
(#%expression INNER)
([for-deriv INNER inner]))]
[(Wrap p:if (e1 e2 rs ?1 full? test then else))
(if full?
(>>P d (p:if full? test then else)
(if TEST THEN ELSE)
([for-deriv TEST test]
[for-deriv THEN then]
[for-deriv ELSE else]))
(>>P d (p:if full? test then else)
(if TEST THEN)
([for-deriv TEST test]
[for-deriv THEN then])))]
[(Wrap p:if (e1 e2 rs ?1 test then else))
(>>P d (p:if test then else)
(if TEST THEN ELSE)
([for-deriv TEST test]
[for-deriv THEN then]
[for-deriv ELSE else]))]
[(Wrap p:wcm (e1 e2 rs ?1 key mark body))
(>>P d (p:wcm key mark body)
(wcm KEY MARK BODY)
@ -252,14 +206,10 @@
(begin0 FIRST . LDERIV)
([for-deriv FIRST first]
[for-lderiv LDERIV lderiv]))]
[(Wrap p:#%app (e1 e2 rs ?1 tagged-stx ld))
(if (or (eq? e1 tagged-stx) (show-macro? #'#%app))
;; If explicitly tagged, simple
(>>Prim d tagged-stx #t (p:#%app tagged-stx ld)
(#%app . LDERIV) (#%app . LDERIV)
([for-lderiv LDERIV ld]))
;; If implicitly tagged:
(seek/deriv d))]
[(Wrap p:#%app (e1 e2 rs ?1 ld))
(>>P d (p:#%app ld)
(#%app . LDERIV)
([for-lderiv LDERIV ld]))]
[(Wrap p:lambda (e1 e2 rs ?1 renames body))
(>>P d (p:lambda renames body)
(lambda FORMALS . BODY)
@ -297,26 +247,22 @@
[for-bind-syntaxess (SRHS ...) srhss]
[for-derivs (VRHS ...) vrhss]
[for-bderiv BODY body])))]
[(Wrap p:#%datum (e1 e2 rs ?1 tagged-stx))
(cond [(or (eq? tagged-stx e1) (show-macro? #'#%datum))
(values d e2)]
[else
(seek/deriv d)])]
[(Wrap p:#%top (e1 e2 rs ?1 tagged-stx))
(cond [(or (eq? tagged-stx e1) (show-macro? #'#%top))
(values d e2)]
[else
(seek/deriv d)])]
[(Wrap p:#%datum (e1 e2 rs ?1))
(let ([show-k (lambda () (values d e2))])
(if (ormap show-macro? rs)
(show-k)
(seek/deriv/on-fail d show-k)))]
[(Wrap p:#%top (e1 e2 rs ?1))
(values d e2)]
[(Wrap p::STOP (e1 e2 rs ?1))
(values d e2)]
[(Wrap p:rename (e1 e2 rs ?1 rename inner))
(>>P d (p:rename rename inner)
INNER
([for-deriv INNER inner]))]
;; Macros
[(Wrap mrule (e1 e2 tx next))
(let ([show-k
(lambda ()
@ -326,12 +272,18 @@
e2)))])
(if (show-transformation? tx)
(show-k)
(with-handlers ([hiding-failure?
(lambda (failure)
(handle-hiding-failure d failure)
(show-k))])
(seek/deriv d))))]
(seek/deriv/on-fail d show-k)))]
[(Wrap tagrule (e1 e2 tagged-stx next))
(let ([show-k
(lambda ()
(recv [(next e2) (for-deriv next)]
(values (make tagrule e1 e2 tagged-stx next)
e2)))])
(if (show-macro? (stx-car tagged-stx))
(show-k)
(seek/deriv/on-fail d show-k)))]
;; Lift
;; Shaky invariant:
;; Only lift-exprs occur in first... no lift-end-module-decls
@ -421,18 +373,20 @@
;; for-transformation : Transformation -> Transformation
(define (for-transformation tx)
(match tx
[(Wrap transformation (e1 e2 rs ?1 me1 locals ?2 me2 _seq))
[(Wrap transformation (e1 e2 rs ?1 me1 locals me2 ?2 _seq))
(let ([locals (and locals (map for-local-action locals))])
(make transformation e1 e2 rs ?1 me1 locals ?2 me2 _seq))]))
(make transformation e1 e2 rs ?1 me1 locals me2 ?2 _seq))]))
;; for-local-action : LocalAction -> LocalAction
(define (for-local-action la)
(match la
[(struct local-expansion (e1 e2 me1 me2 for-stx? deriv))
(let-values ([(deriv e2) (for-deriv deriv)])
(make local-expansion e1 e2 me1 me2 for-stx? deriv))]
[(struct local-expansion/expr (e1 e2 me1 me2 for-stx? opaque deriv))
(error 'hide:for-local-action "not implemented for local-expand-expr")]
[(struct local-expansion (e1 e2 me1 me2 deriv for-stx? lifted opaque))
(parameterize ((phase (if for-stx? (add1 (phase)) (phase))))
(when (or lifted opaque)
(fprintf (current-error-port)
"for-local-action: warning: losing information\n"))
(let-values ([(deriv e2) (for-deriv deriv)])
(make local-expansion e1 e2 me1 me2 deriv for-stx? lifted opaque)))]
[(struct local-lift (expr id))
(add-unhidden-lift (extract/remove-unvisited-lift id))
la]
@ -440,9 +394,9 @@
(DEBUG-LIFTS
(printf "hide:for-local-action: local-lift-end unimplemented~n"))
la]
[(struct local-bind (bindrhs))
[(struct local-bind (names bindrhs))
(let-values ([(bindrhs e2) (for-bind-syntaxes bindrhs)])
(make local-bind bindrhs))]))
(make local-bind names bindrhs))]))
;; for-case-lambda-clauses : (list-of CaseLambdaClause) -> (list-of CaseLambdaClause) Stxs
(define (for-case-lambda-clauses clauses)
@ -546,277 +500,6 @@
es2)))]
[#f (values #f #f)])))
;
; ;;
; ;;
; ;
; ;
; ;;;;; ;;;; ;;;; ; ;;;
; ;; ; ; ; ; ; ; ;
; ;; ;; ;; ;; ;; ; ;
; ;;; ;;;;;;; ;;;;;;; ;;;
; ;;;; ; ; ;;;
; ; ;; ;; ;; ; ;;
; ; ;; ;; ;; ; ;;
; ;;;;;; ;;;; ;;;; ;;; ;;;
;
;; Seek:
;; The derivation is "inactive" or "hidden" by default,
;; but pieces of it can become visible if they correspond to subterms
;; of the hidden syntax.
;; seek/deriv : WDeriv -> (values WDeriv syntax)
;; Seeks for derivations of all proper subterms of the derivation's
;; initial syntax.
(define (seek/deriv d)
(match d
[(Wrap deriv (e1 e2))
(let ([subterms (gather-proper-subterms e1)])
(parameterize ((subterms-table subterms))
(let ([sd (seek d)])
(values sd (wderiv-e2 sd)))))]))
;; seek : WDeriv -> WDeriv
;; Expects macro-policy, subterms-table to be set up already
(define (seek d)
(match d
[(Wrap deriv (e1 e2))
(recv [(subterms hidden-exn) (subterm-derivations d)]
(begin (check-nonlinear-subterms subterms)
;; Now subterm substitution is safe, because they don't overlap
(create-synth-deriv e1 subterms hidden-exn)))]))
;; create-synth-deriv : syntax (list-of Subterm) ?exn -> WDeriv
(define (create-synth-deriv e1 subterms hidden-exn)
(let ([e2 (if hidden-exn #f (substitute-subterms e1 subterms))])
(make p:synth e1 e2 null #f subterms hidden-exn)))
;; subterm-derivations : Derivation -> (list-of Subterm) ?exn
(define (subterm-derivations d)
(subterms-of-deriv d))
;; subterms-of-deriv : Derivation -> (list-of Subterm) ?exn
(define (subterms-of-deriv d)
(let ([path (check-visible d)])
(if path
(let-values ([(d _) (hide d)])
(SKunit (list (make s:subterm path d))))
(subterms-of-unlucky-deriv d))))
;; subterms-of-deriv/phase-up : Derivation -> (list-of Subterm) ?exn
(define (subterms-of-deriv/phase-up d)
(parameterize ((phase (add1 (phase))))
(subterms-of-deriv d)))
;; check-visible : Derivation -> Path/#f
(define (check-visible d)
(match d
[(Wrap deriv (e1 e2))
(let ([paths (table-get (subterms-table) e1)])
(cond [(null? paths) #f]
[(null? (cdr paths))
(car paths)]
[else
;; More than one path to the same(eq?) syntax object
;; Not good.
;; FIXME: Better to delay check to here, or check whole table first?
;; FIXME
(raise
(make nonlinearity e1 paths))]))]
[#f #f]))
;; subterms-of-unlucky-deriv : Derivation -> (list-of Subterm) ?exn
;; Guarantee: (wderiv-e1 deriv) is not in subterms table
(define (subterms-of-unlucky-deriv d)
(match d
;; Primitives
[(Wrap p:module (e1 e2 rs ?1 one-body-form? mb ?2 body))
(cond [one-body-form?
;; FIXME: tricky... how to do renaming?
(>>Seek [! ?1]
(subterms-of-deriv mb)
[! ?1]
(subterms-of-deriv body))]
[else
(with-syntax ([(?module ?name ?lang . ?body) e1]
[(?module-begin . ?body*) (wderiv-e1 body)])
(>>Seek [! ?1]
[#:rename (do-rename #'?body #'?body*)]
[! ?2]
(subterms-of-deriv body)))])]
[(Wrap p:#%module-begin (e1 e2 rs ?1 pass1 pass2 ?2))
(>>Seek [! ?1]
(subterms-of-lderiv (module-begin->lderiv d))
[! ?2])]
[(Wrap p:variable (e1 e2 rs ?1))
(>>Seek)]
[(Wrap p:define-syntaxes (e1 e2 rs ?1 rhs ?2))
(>>Seek [! ?1]
(subterms-of-deriv/phase-up rhs)
[! ?2])]
[(Wrap p:define-values (e1 e2 rs ?1 rhs))
(>>Seek [! ?1]
(subterms-of-deriv rhs))]
[(Wrap p:#%expression (e1 e2 rs ?1 inner))
(>>Seek [! ?1]
(subterms-of-deriv inner))]
[(Wrap p:if (e1 e2 rs ?1 full? test then else))
(>>Seek [! ?1]
(subterms-of-deriv test)
(subterms-of-deriv then)
(if full?
(subterms-of-deriv else)
(SKzero)))]
[(Wrap p:wcm (e1 e2 rs ?1 key value body))
(>>Seek [! ?1]
(subterms-of-deriv key)
(subterms-of-deriv value)
(subterms-of-deriv body))]
[(Wrap p:set! (e1 e2 rs ?1 id-resolves rhs))
(>>Seek [! ?1]
(subterms-of-deriv rhs))]
[(Wrap p:set!-macro (e1 e2 rs ?1 deriv))
(>>Seek [! ?1]
(subterms-of-deriv deriv))]
[(Wrap p:begin (e1 e2 rs ?1 lderiv))
(>>Seek [! ?1]
(subterms-of-lderiv lderiv))]
[(Wrap p:begin0 (e1 e2 rs ?1 head lderiv))
(>>Seek [! ?1]
(subterms-of-deriv head)
(subterms-of-lderiv lderiv))]
[(Wrap p:#%app (e1 e2 rs ?1 tagges-stx lderiv))
(>>Seek [! ?1]
(subterms-of-lderiv lderiv))]
[(Wrap p:lambda (e1 e2 rs ?1 renames body))
(>>Seek [! ?1]
[#:rename (do-rename/lambda e1 renames)]
(subterms-of-bderiv body))]
[(Wrap p:case-lambda (e1 e2 rs ?1 clauses))
(>>Seek [! ?1]
(SKmap2 subterms-of-case-lambda-clause
clauses
(stx->list (stx-cdr e1))))]
[(Wrap p:let-values (e1 e2 rs ?1 renames rhss body))
(>>Seek [! ?1]
[#:rename (do-rename/let e1 renames)]
(SKmap subterms-of-deriv rhss)
(subterms-of-bderiv body))]
[(Wrap p:letrec-values (e1 e2 rs ?1 renames rhss body))
(>>Seek [! ?1]
[#:rename (do-rename/let e1 renames)]
(SKmap subterms-of-deriv rhss)
(subterms-of-bderiv body))]
[(Wrap p:letrec-syntaxes+values (e1 e2 rs ?1 srenames srhss vrenames vrhss body))
(>>Seek [! ?1]
[#:rename (do-rename/lsv1 e1 srenames)]
(SKmap subterms-of-bind-syntaxes srhss)
[#:rename (do-rename/lsv2 srenames vrenames)]
(SKmap subterms-of-deriv vrhss)
(subterms-of-bderiv body))]
[(Wrap p::STOP (e1 e2 rs ?1))
(>>Seek)]
;; synth (should synth be idempotent?... heh, no point for now)
[(Wrap p:rename (e1 e2 rs ?1 rename inner))
(>>Seek [! ?1]
[#:rename (do-rename (car rename) (cdr rename))]
(subterms-of-deriv inner))]
;; Macros
[(Wrap mrule (e1 e2 tx next))
(recv [(subterms exn table) (subterms-of-transformation tx)]
(parameterize ((subterms-table table))
(SKseq (lambda () (values subterms exn))
(lambda () (subterms-of-deriv next)))))]
[(Wrap lift-deriv (e1 e2 first lifted-stx next))
(raise (make hidden-lift-site))]
[(Wrap lift/let-deriv (e1 e2 first lifted-stx next))
(raise (make hidden-lift-site))]
;; Errors
[#f (SKzero)]
))
;; subterms-of-transformation : Transformation -> (list-of Subterm) ?exn Table
(define (subterms-of-transformation tx)
(match tx
[(Wrap transformation (e1 e2 rs ?1 me1 locals ?2 me2 _seq))
;; FIXME: We'll need to use e1/e2/me1/me2 to synth locals, perhaps
;; FIXME: and we'll also need to account for *that* marking, too...
(let ([end-table #f])
(recv [(ss exn)
(>>Seek [! ?1]
[#:rename/no (do-rename e1 me1)]
(SKmap subterms-of-local-action locals)
[! ?2]
[#:rename/no (do-rename me2 e2)]
(begin (set! end-table (subterms-table))
(SKzero)))]
(values ss exn end-table)))]))
;; subterms-of-local-action : LocalAction -> (list-of Subterm) ?exn
(define (subterms-of-local-action local)
(match local
[(struct local-expansion (e1 e2 me1 me2 subterms-of-stx? deriv))
(>>Seek [#:rename/no (do-rename me1 e1)] ;; FIXME: right order?
(recv [(subterms exn) (subterms-of-deriv deriv)]
(if (pair? (filter s:subterm? subterms))
(raise (make localactions))
(values subterms exn))))]
[(struct local-expansion/expr (e1 e2 me1 me2 subterms-of-stx? opaque deriv))
(>>Seek [#:rename/no (do-rename me1 e1)] ;; FIXME: right order?
(recv [(subterms exn) (subterms-of-deriv deriv)]
(if (pair? (filter s:subterm? subterms))
(raise (make localactions))
(values subterms exn))))]
[(struct local-lift (expr id))
;; FIXME: seek in the lifted deriv, transplant subterm expansions *here*
(extract/remove-unvisited-lift id)]
[(struct local-lift-end (decl))
;; FIXME
(>>Seek)]
[(struct local-bind (bindrhs))
(recv [(subterms exn) (subterms-of-bind-syntaxes bindrhs)]
(if (pair? (filter s:subterm? subterms))
(raise (make localactions))
(values subterms exn)))]))
;; subterms-of-lderiv : ListDerivation -> (list-of Subterm)
(define (subterms-of-lderiv ld)
(match ld
[(Wrap lderiv (es1 es2 ?1 derivs))
(>>Seek [! ?1]
(SKmap subterms-of-deriv derivs))]
[#f (SKzero)]))
;; subterms-of-bderiv : BlockDerivation -> (list-of Subterm)
(define (subterms-of-bderiv bd)
(subterms-of-lderiv (bderiv->lderiv bd)))
;; subterms-of-case-lambda-clause : Syntax CaseLambdaClause -> (list-of Subterm) ?exn
(define (subterms-of-case-lambda-clause stx clause)
(match clause
[(Wrap clc (?1 renames body))
(>>Seek [! ?1]
[#:rename (do-rename/case-lambda stx renames)]
(subterms-of-bderiv body))]))
;; subterms-of-bind-syntaxes : BindSyntaxes -> (list-of Subterm) ?exn
(define (subterms-of-bind-syntaxes bindrhs)
(match bindrhs
[(Wrap bind-syntaxes (rhs ?1))
(>>Seek (subterms-of-deriv rhs)
[! ?1])]))
;
; ;;;;
; ;; ;
@ -835,6 +518,7 @@
; ;;;;
;
;; show-macro? : identifier -> boolean
(define (show-macro? id)
((macro-policy) id))
@ -842,138 +526,6 @@
;; show-mrule? : MRule -> boolean
(define (show-transformation? tx)
(match tx
[(Wrap transformation (e1 e2 rs ?1 me1 locals ?2 me2 _seq))
[(Wrap transformation (e1 e2 rs ?1 me1 locals me2 ?2 _seq))
(ormap show-macro? rs)]))
;; gather-one-subterm : syntax syntax -> SubtermTable
(define (gather-one-subterm whole part)
(let ([table (make-hash-table)])
(let ([paths (find-subterm-paths part whole)])
(for-each (lambda (p) (table-add! table part p)) paths))
table))
;; gather-proper-subterms : Syntax -> SubtermTable
;; FIXME: Eventually, need to descend into vectors, boxes, etc.
(define (gather-proper-subterms stx0)
(let ([table (make-hash-table)])
;; loop : Syntax Path -> void
(define (loop stx rpath)
(unless (eq? stx0 stx)
(table-add! table stx (reverse rpath)))
(let ([p (syntax-e 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))
(define (map/2values f items)
(if (null? items)
(values null null)
(let*-values ([(a0 b0) (f (car items))]
[(as bs) (map/2values f (cdr items))])
(values (cons a0 as) (cons b0 bs)))))
;
; ;;;;
; ;; ;
; ; ; ;
; ; ; ;
; ;;;;;; ;;;;; ; ;;; ; ;;;;
; ; ; ; ;; ;; ; ; ;
; ; ; ; ;; ; ;; ;;
; ; ;;;; ; ;; ; ;;;;;;;
; ; ;; ; ; ;; ; ;
; ; ;; ; ; ;; ; ;;
; ;; ;; ;; ; ; ; ;;
; ;;; ;;; ;; ;;;; ;;;;;;; ;;;;
;
;
;
;; A Table is a hashtable[syntax => (list-of Path)
(define (table-add! table stx v)
(hash-table-put! table stx (cons v (table-get table stx))))
(define (table-add-if-absent! table stx v)
(unless (memq v (table-get table stx))
(table-add! table stx v)))
(define (table-get table stx)
(hash-table-get table stx (lambda () null)))
;; do-rename : syntax syntax -> (values (list-of Subterm) Table)
(define (do-rename stx rename)
(let ([t (make-hash-table)]
[old (subterms-table)])
;; loop : syntax syntax -> (list-of Subterm)
;; Puts things into the new table, too
;; If active? is #f, always returns null
(define (loop stx rename active?)
(cond [(and (syntax? stx) (syntax? rename))
(let ([paths (table-get old stx)])
(if (pair? paths)
(begin (hash-table-put! t rename paths)
(loop (syntax-e stx) (syntax-e rename) #f)
(if active?
(map (lambda (p) (make s:rename p stx rename))
paths)
null))
(loop (syntax-e stx) (syntax-e rename) active?)))]
[(syntax? rename)
(loop stx (syntax-e rename) active?)]
[(syntax? stx)
(loop (syntax-e stx) rename active?)]
[(and (pair? stx) (pair? rename))
(append
(loop (car stx) (car rename) active?)
(loop (cdr stx) (cdr rename) active?))]
[else
null]))
(let ([subterms (loop stx rename #t)])
(values subterms t))))
(define (do-rename/lambda stx rename)
(if rename
(with-syntax ([(?lambda ?formals . ?body) stx])
(do-rename (cons #'?formals #'?body) rename))
(values null (subterms-table))))
(define (do-rename/let stx rename)
(if rename
(with-syntax ([(?let ?bindings . ?body) stx])
(do-rename (cons #'?bindings #'?body) rename))
(values null (subterms-table))))
(define (do-rename/case-lambda stx rename)
(if rename
(with-syntax ([(?formals . ?body) stx])
(do-rename (cons #'?formals #'?body) rename))
(values null (subterms-table))))
(define (do-rename/lsv1 stx rename)
(if rename
(with-syntax ([(?lsv ?sbindings ?vbindings . ?body) stx])
(do-rename (cons #'?sbindings (cons #'?vbindings #'?body)) rename))
(values null (subterms-table))))
(define (do-rename/lsv2 old-rename rename)
(if rename
(with-syntax ([(?sbindings ?vbindings . ?body) old-rename])
(do-rename (cons #'?vbindings #'?body) rename))
(values null (subterms-table))))

173
collects/macro-debugger/model/hiding-policies.ss
View File

@ -2,100 +2,103 @@
#lang scheme/base
(require (for-syntax scheme/base)
scheme/match
syntax/boundmap)
(provide (all-defined-out))
syntax/boundmap
"synth-engine.ss")
(provide make-policy
standard-policy
base-policy
hide-all-policy
hide-none-policy)
(define-struct hiding-policy
(opaque-modules opaque-ids opaque-kernel opaque-libs transparent-ids)
#:mutable)
;; make-policy : bool^4 (listof (identifier bindinglist (bool -> void) -> void))
;; -> identifier -> bool
(define (make-policy hide-mzscheme?
hide-libs?
hide-contracts?
hide-transformers?
specialized-policies)
(lambda (id)
(define now (phase))
(define binding
(cond [(= now 0) (identifier-binding id)]
[(= now 1) (identifier-transformer-binding id)]
[else #f]))
(define-values (def-mod def-name nom-mod nom-name)
(if (pair? binding)
(values (car binding)
(cadr binding)
(caddr binding)
(cadddr binding))
(values #f #f #f #f)))
(let/ec return
(let loop ([policies specialized-policies])
(when (pair? policies)
((car policies) id binding return)
(loop (cdr policies))))
(cond [(and hide-mzscheme? def-mod (scheme-module? def-mod))
#f]
[(and hide-libs? def-mod (lib-module? def-mod))
#f]
[(and hide-contracts? def-name
(regexp-match #rx"^provide/contract-id-"
(symbol->string def-name)))
#f]
[(and hide-transformers? (positive? now))
#f]
[else #t]))))
(define (policy-hide-module p m)
(hash-table-put! (hiding-policy-opaque-modules p) m #t))
(define (policy-unhide-module p m)
(hash-table-remove! (hiding-policy-opaque-modules p) m))
(define standard-policy
(make-policy #t #t #t #t null))
(define (policy-hide-kernel p)
(set-hiding-policy-opaque-kernel! p #t))
(define (policy-unhide-kernel p)
(set-hiding-policy-opaque-kernel! p #f))
(define base-policy
(make-policy #t #f #f #f null))
(define (policy-hide-libs p)
(set-hiding-policy-opaque-libs! p #t))
(define (policy-unhide-libs p)
(set-hiding-policy-opaque-libs! p #f))
(define (hide-all-policy id) #f)
(define (hide-none-policy id) #t)
(define (policy-hide-id p id)
(policy-unshow-id p id)
(module-identifier-mapping-put! (hiding-policy-opaque-ids p) id #t))
(define (policy-unhide-id p id)
(module-identifier-mapping-put! (hiding-policy-opaque-ids p) id #f))
(define (policy-show-id p id)
(policy-unhide-id p id)
(module-identifier-mapping-put! (hiding-policy-transparent-ids p) id #t))
(define (policy-unshow-id p id)
(module-identifier-mapping-put! (hiding-policy-transparent-ids p) id #f))
;;
(define (new-hiding-policy)
(make-hiding-policy (make-hash-table)
(make-module-identifier-mapping)
#f
#f
(make-module-identifier-mapping)))
(define (new-standard-hiding-policy)
(let ([p (new-hiding-policy)])
(policy-hide-kernel p)
(policy-hide-libs p)
p))
;; ---
(define-syntax inline
(syntax-rules ()
[(inline ([name expr] ...) . body)
(let-syntax ([name
(lambda (x)
(syntax-case x ()
[xx (identifier? #'xx) #'expr]))] ...)
. body)]))
(define (/false) #f)
(define (policy-show-macro? policy id)
(match policy
[(struct hiding-policy (opaque-modules
opaque-identifiers
opaque-kernel
opaque-libs
transparent-identifiers))
(inline ([not-opaque-id
(not (module-identifier-mapping-get opaque-identifiers id /false))]
[transparent-id
(module-identifier-mapping-get transparent-identifiers id /false)])
(let ([binding (identifier-binding id)])
(if (list? binding)
(let-values ([(srcmod srcname nommod nomname _) (apply values binding)])
(inline ([opaque-srcmod (hash-table-get opaque-modules srcmod /false)]
[opaque-nommod (hash-table-get opaque-modules nommod /false)]
;; FIXME
[in-kernel?
(and (symbol? srcmod)
(eq? #\# (string-ref (symbol->string srcmod) 0)))]
[in-lib-module?
(lib-module? srcmod)])
(or transparent-id
(and (not opaque-srcmod)
(not opaque-nommod)
(not (and in-kernel? opaque-kernel))
(not (and in-lib-module? opaque-libs))
not-opaque-id))))
(or transparent-id
not-opaque-id))))]))
(define (scheme-module? mpi)
(let ([abs (find-absolute-module-path mpi)])
(and abs
(or (base-module-path? abs)
(scheme-lib-module-path? abs)))))
(define (lib-module? mpi)
(let ([abs (find-absolute-module-path mpi)])
(and abs (lib-module-path? abs))))
(define (find-absolute-module-path mpi)
(and (module-path-index? mpi)
(let-values ([(path rel) (module-path-index-split mpi)])
(cond [(pair? path) (memq (car path) '(lib planet))]
[(string? path) (lib-module? rel)]
(cond [(and (pair? path) (memq (car path) '(quote lib planet)))
path]
[(symbol? path) path]
[(string? path) (find-absolute-module-path rel)]
[else #f]))))
(define (base-module-path? mp)
(and (pair? mp)
(eq? 'quote (car mp))
(regexp-match #rx"^#%" (symbol->string (cadr mp)))))
(define (scheme-lib-module-path? mp)
(cond [(symbol? mp)
(scheme-collection-name? (symbol->string mp))]
[(and (pair? mp) (eq? (car mp) 'lib))
(cond [(string? (cadr mp)) (null? (cddr mp))
(scheme-collection-name? (cadr mp))]
[(symbol? (cadr mp))
(scheme-collection-name? (symbol->string (cadr mp)))]
[else #f])]
[else #f]))
(define (scheme-collection-name? path)
(or (regexp-match? #rx"^scheme/base(/.)?" path)
(regexp-match? #rx"^mzscheme(/.)?" path)))
(define (lib-module-path? mp)
(or (symbol? mp)
(and (pair? mp) (memq (car mp) '(lib planet)))))

144
collects/macro-debugger/model/reductions-engine.ss
View File

@ -158,16 +158,19 @@
[(CC HOLE expr pattern)
#'(syntax-copier HOLE expr pattern)]))
;; (R stx R-clause ...)
;; R
;; the threaded reductions engine
;; (R stx R-clause ...) : (values (list-of Step) ?stx ?exn)
;; An R-clause is one of
;; [! expr]
;; [#:pattern pattern]
;; [#:bind pattern stx-expr]
;; [#:let-values (var ...) expr]
;; [#:set-syntax stx-expr]
;; [#:walk term2 foci1 foci2 description]
;; [#:walk term2 description]
;; [#:rename form2 foci1 foci2 description]
;; [#:walk/ctx pattern term2 description]
;; [#:walk/foci term2 foci1 foci2 description]
;; [#:rename* pattern rename [description]]
;; [#:rename/no-step pattern stx stx]
;; [#:reductions expr]
;; [#:learn ids]
@ -176,26 +179,22 @@
;; [#:if/np test R-clause ...]
;; [generator hole fill]
;; R
;; the threaded reductions engine
;; (R form . clauses) : (values (list-of Step) ?stx ?exn)
(define-syntax R
(syntax-rules ()
[(R form . clauses)
(R** #f _ [#:set-syntax form] . clauses)]))
(let ([form-var form])
(R** form-var _ . clauses))]))
(define-syntax R**
(syntax-rules (! =>)
;; Base: done
[(R** form-var pattern)
(RSunit form-var)]
;; Base: explicit continuation
[(R** f p => k)
(k f)]
;; Error-point case
[(R** f p [! maybe-exn] . more)
(let ([x maybe-exn])
@ -204,34 +203,26 @@
(if x
(values (list (stumble f x)) #f x)
(R** f p . 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))]
;; Change syntax
[(R** f p [#:set-syntax form] . more)
(let ([form-variable form])
(R** form-variable p . more))]
;; Change syntax and Step (explicit foci)
[(R** f p [#:walk 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))))]
;; Change syntax and Step (infer foci)
[(R** f p [#:walk form2 description] . more)
(let-values ([(form2-var description-var)
@ -239,8 +230,52 @@
(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)))]
;; 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])
@ -251,7 +286,7 @@
f form2-var
description-var))
(lambda () (R** form2-var p . more)))))]
;; Change syntax with rename (but no step)
[(R** f p [#:rename/no-step pvar from to] . more)
(let-values ([(from-var to-var)
@ -262,42 +297,42 @@
(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))]
;; 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)))]
;; 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))]
;; Subterm handling
[(R** f p [generator hole fill] . more)
(let ([k (lambda (f2) (R** f2 p . more))])
@ -307,22 +342,28 @@
(define-syntax Run
(syntax-rules ()
[(Run f p generator hole fill k)
(let ([reducer (with-syntax ([p f]) (generator))])
(let ([reducer (generator)])
(Run* reducer f p hole fill k))]))
(define-syntax (Run* stx)
(syntax-case stx ()
;; Implementation of subterm handling for (hole ...) sequences
[(Run* f form-var pattern (hole :::) fills k)
[(Run* reducer f p (hole :::) fills k)
(and (identifier? #':::)
(free-identifier=? #'::: (quote-syntax ...)))
#'(let ([ctx (CC (hole :::) form-var pattern)])
(let ([e1s (with-syntax ([pattern form-var]) (syntax->list #'(hole :::)))])
(run-multiple f ctx fills e1s k)))]
#'(let ([ctx (CC (hole :::) f p)])
(let ([e1s (with-syntax ([p f]) (syntax->list #'(hole :::)))])
(run-multiple reducer ctx fills e1s k)))]
;; Implementation of subterm handling
[(Run* f form-var pattern hole fill k)
#'(let ([ctx (CC hole form-var pattern)])
(run-one f ctx fill k))]))
[(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)
@ -334,21 +375,15 @@
(RSbind (lambda ()
(with-context ctx
(with-context (lambda (x) (revappend prefix (cons x (cdr suffix))))
(f (car fills)))))
(lambda (final)
(loop (cdr fills)
(cons final prefix)
(cdr suffix))))]
(f (car fills) (car suffix)))))
(lambda (final)
(loop (cdr fills)
(cons final prefix)
(cdr suffix))))]
[(null? fills)
(let ([form (ctx (reverse prefix))])
(k form))])))
;; run-one : (a -> RS(b)) (b -> c) (c -> RS(d)) -> RS(d)
(define (run-one f ctx fill k)
(RSbind (lambda () (with-context ctx (f fill)))
(lambda (final)
(k (ctx final)))))
;; Rename mapping
(define (rename-frontier from to)
@ -367,7 +402,8 @@
[(syntax? to)
(loop from (syntax-e to))]
[(pair? from)
#;(unless (pair? to)
#;
(unless (pair? to)
(fprintf (current-error-port)
"from:\n~s\n\n" (syntax->datum from0))
(fprintf (current-error-port)

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

@ -19,14 +19,14 @@
transformation-reductions)
(define (BindSyntaxes)
bind-syntaxes-reductions)
(define ((CaseLambdaClauses e1))
(mk-case-lambda-clauses-reductions e1))
(define ((SynthItems e1))
(mk-synth-items-reductions e1))
(define ((BRules es1))
(mk-brules-reductions es1))
(define ((ModulePass es1))
(mk-mbrules-reductions es1))
(define (CaseLambdaClauses)
case-lambda-clauses-reductions)
(define (SynthItems)
synth-items-reductions)
(define (BRules)
brules-reductions)
(define (ModulePass)
mbrules-reductions)
;; Syntax
@ -41,24 +41,28 @@
;; reductions : WDeriv -> ReductionSequence
(define (reductions d)
(parameterize ((current-definites null)
(current-frontier null))
(when d (add-frontier (list (wderiv-e1 d))))
(RS-steps (reductions* d))))
(let-values ([(steps definites estx exn) (reductions+ d)])
steps))
;; 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 ([(rs stx exn) (reductions* d)])
(values rs (current-definites) stx exn))))
(let-values ([(steps stx exn) (reductions* d (wderiv-e1 d))])
(values steps (current-definites) stx exn))))
;; reductions* : WDeriv -> RS(stx)
(define (reductions* d)
;; reductions* : WDeriv Syntax -> RS(stx)
(define (reductions* d init-e1)
(match d
[(Wrap deriv (e1 e2))
(blaze-frontier e1)]
(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)])
(match d
[(Wrap prule (e1 e2 rs ?1))
@ -70,38 +74,41 @@
(R e1
[#:learn (list e2)]
[#:when/np (not (bound-identifier=? e1 e2))
[#:walk e2 e1 e2 'resolve-variable]])]
[(Wrap p:module (e1 e2 rs ?1 #f #f #f body))
[#:walk e2 'resolve-variable]])]
[(Wrap p:module (e1 e2 rs ?1 ?2 tag rename check tag2 ?3 body shift))
(R e1
[! ?1]
[#:pattern (?module ?name ?language . ?_body)]
[#:walk (d->so e1 `(,#'?module ,#'?name ,#'?language ,(wderiv-e1 body)))
'tag-module-begin]
[#:pattern (?module ?name ?language ?body)]
[#:frontier (list #'?body)]
[Expr ?body body])]
[(Wrap p:module (e1 e2 rs ?1 #t mb ?2 body))
(R e1
[! ?1]
[#:pattern (?module ?name ?language ?body)]
[#:frontier (list #'?body)]
[Expr ?body mb]
[#:pattern (?module ?name ?language . ?body-parts)]
#;[#:frontier null (list #'?language #'?body-parts)]
[! ?2]
[#:when/np (not (eq? (wderiv-e2 mb) (wderiv-e1 body)))
[#:walk
(d->so e1 `(,#'?module ,#'?name ,#'?language
,(wderiv-e1 body)))
'tag-module-begin]]
[Expr ?body body])]
[(Wrap p:#%module-begin (e1 e2 rs ?1 pass1 pass2 ?2))
#;[#:frontier (list #'?language) null]
[#:when/np tag
[#:walk/ctx ?body-parts
(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]]
[! ?3]
[Expr ?body body]
[#:pattern ?form]
[#: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)]
[#:pattern ?form]
[#:rename* ?form me]
[#:pattern (?module-begin . ?forms)]
[#:frontier (stx->list* #'?forms)]
[(ModulePass #'?forms)
?forms pass1]
[(ModulePass #'?forms)
?forms pass2]
#;[#:frontier (syntax->list #'?forms)]
#;[#:let-values (_) (printf "#%module-begin ?forms:\n~s\n" #'?forms)]
[ModulePass ?forms pass1]
[ModulePass ?forms pass2]
[! ?1])]
[(Wrap p:define-syntaxes (e1 e2 rs ?1 rhs ?2))
(R e1
@ -124,21 +131,14 @@
[#:pattern (?expr ?inner)]
[#:frontier (list #'?inner)]
[Expr ?inner inner])]
[(Wrap p:if (e1 e2 rs ?1 full? test then else))
(if full?
(R e1
[! ?1]
[#:pattern (?if TEST THEN ELSE)]
[#:frontier (list #'TEST #'THEN #'ELSE)]
[Expr TEST test]
[Expr THEN then]
[Expr ELSE else])
(R e1
[! ?1]
[#:pattern (?if TEST THEN)]
[#:frontier (list #'TEST #'THEN)]
[Expr TEST test]
[Expr THEN then]))]
[(Wrap p:if (e1 e2 rs ?1 test then else))
(R e1
[! ?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]
@ -160,42 +160,31 @@
[#:frontier (cons #'FIRST (stx->list* #'LDERIV))]
[Expr FIRST first]
[List LDERIV lderiv])]
[(Wrap p:#%app (e1 e2 rs ?1 tagged-stx lderiv))
[(Wrap p:#%app (e1 e2 rs ?1 lderiv))
(R e1
[! ?1]
[#:when/np (not (eq? tagged-stx e1))
[#:walk tagged-stx 'tag-app]]
[#:pattern (?app . LDERIV)]
[#:frontier (stx->list* #'LDERIV)]
[List LDERIV lderiv])]
[(Wrap p:lambda (e1 e2 rs ?1 renames body))
(R e1
[! ?1]
[#:bind (?formals* . ?body*) renames]
[#:pattern (?lambda ?formals . ?body)]
[#:frontier (stx->list* #'?body)]
[#:rename (syntax/skeleton e1 (?lambda ?formals* . ?body*))
#'?formals #'?formals*
'rename-lambda]
[#:rename* (?formals . ?body) renames 'rename-lambda]
[Block ?body body])]
[(Wrap p:case-lambda (e1 e2 rs ?1 clauses))
(R e1
[! ?1]
[#:pattern (?case-lambda . ?clauses)]
[#:frontier (stx->list* #'?clauses)]
[(CaseLambdaClauses (stx->list* #'?clauses))
?clauses clauses])]
[CaseLambdaClauses ?clauses clauses])]
[(Wrap p:let-values (e1 e2 rs ?1 renames rhss body))
(R e1
[! ?1]
[#:pattern (?let-values ([?vars ?rhs] ...) . ?body)]
[#:frontier (append (syntax->list #'(?rhs ...)) (stx->list* #'?body))]
[#:bind (([?vars* ?rhs*] ...) . ?body*) renames]
[#:rename
(syntax/skeleton e1 (?let-values ([?vars* ?rhs*] ...) . ?body*))
(syntax->list #'(?vars ...))
(syntax->list #'(?vars* ...))
'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))
@ -203,12 +192,7 @@
[! ?1]
[#:pattern (?letrec-values ([?vars ?rhs] ...) . ?body)]
[#:frontier (append (syntax->list #'(?rhs ...)) (stx->list* #'?body))]
[#:bind (([?vars* ?rhs*] ...) . ?body*) renames]
[#:rename
(syntax/skeleton e1 (?letrec-values ([?vars* ?rhs*] ...) . ?body*))
(syntax->list #'(?vars ...))
(syntax->list #'(?vars* ...))
'rename-letrec-values]
[#:rename* (((?vars ?rhs) ...) . ?body) renames 'rename-letrec-values]
[Expr (?rhs ...) rhss]
[Block ?body body])]
[(Wrap p:letrec-syntaxes+values
@ -219,49 +203,39 @@
[#:frontier (append (syntax->list #'(?srhs ...))
(syntax->list #'(?vrhs ...))
(stx->list* #'?body))]
[#:bind (([?svars* ?srhs*] ...) ([?vvars* ?vrhs*] ...) . ?body*) srenames]
[#:rename
(syntax/skeleton e1
(?lsv ([?svars* ?srhs*] ...) ([?vvars* ?vrhs*] ...)
. ?body*))
(syntax->list #'(?svars ...))
(syntax->list #'(?svars* ...))
'rename-lsv]
[#: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
(syntax/skeleton e1 (?lsv ([?svars* ?srhs*] ...)
([?vvars** ?vrhs**] ...)
. ?body**))
(syntax->list #'(?vvars* ...))
(syntax->list #'(?vvars** ...))
'rename-lsv]]
[#:rename* (((?vars ?vrhs) ...) . ?body) vrenames 'rename-lsv]]
[Expr (?vrhs ...) vrhss]
[Block ?body body]
[#:pattern ?form]
[#:when/np (not (eq? #'?form e2)) ;; FIXME: correct comparison?
[#:walk e2 'lsv-remove-syntax]])]
;; The auto-tagged atomic primitives
[(Wrap p:#%datum (e1 e2 rs ?1 tagged-stx))
[(Wrap p:#%datum (e1 e2 rs ?1))
(R e1
[#:when/np (not (eq? e1 tagged-stx))
[#:walk tagged-stx 'tag-datum]]
[! ?1])]
[(Wrap p:#%top (e1 e2 rs ?1 tagged-stx))
[! ?1]
[#:walk e2 'macro])]
[(Wrap p:#%top (e1 e2 rs ?1))
(R e1
[#:when/np (not (eq? e1 tagged-stx))
[#:walk tagged-stx 'tag-top]]
[#:pattern (?top . ?var)]
[#:learn (list #'?var)]
[! ?1])]
[(Wrap p:provide (e1 e2 rs ?1))
(R e1
[! ?1]
[#:walk e2 'provide])]
;; The rest of the automatic primitives
[(Wrap p::STOP (e1 e2 rs ?1))
(R e1
[! ?1])]
[(Wrap p:set!-macro (e1 e2 rs ?1 deriv))
(R e1
[! ?1]
@ -275,7 +249,7 @@
[#: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))
@ -299,17 +273,18 @@
(rename-frontier (s:rename-after (car subterms))
(s:rename-before (car subterms)))]))
(current-frontier))]
[(SynthItems e1) ?form subterms]
[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)))]
(reductions* inner (wderiv-e1 inner))))]
;; Macros
[(Wrap mrule (e1 e2 transformation next))
@ -318,9 +293,21 @@
[Transformation ?form transformation]
[#:frontier (list (wderiv-e1 next))]
[Expr ?form next])]
[(Wrap tagrule (e1 e2 tagged-stx next))
(R e1
[#:pattern ?form]
[#:walk tagged-stx
(case (syntax-e (stx-car tagged-stx))
((#%app) 'tag-app)
((#%datum) 'tag-datum)
((#%top) 'tag-top)
(else
(error 'reductions "unknown tagged syntax: ~s" tagged-stx)))]
[Expr ?form next])]
;; Lifts
[(Wrap lift-deriv (e1 e2 first lifted-stx second))
(R e1
[#:pattern ?form]
@ -328,7 +315,7 @@
[#:frontier (list lifted-stx)]
[#:walk lifted-stx 'capture-lifts]
[Expr ?form second])]
[(Wrap lift/let-deriv (e1 e2 first lifted-stx second))
(R e1
[#:pattern ?form]
@ -336,13 +323,13 @@
[#:frontier (list lifted-stx)]
[#:walk lifted-stx 'capture-lifts]
[Expr ?form second])]
;; Skipped
[#f (RSzero)]))
;; mk-case-lambda-clauses-reductions : stxs ->
;; (list-of (W (list ?exn rename (W BDeriv)))) -> (RS stxs)
(define ((mk-case-lambda-clauses-reductions es1) clauses)
;; Skipped
[#f (RSunit init-e1)]))
;; 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
['()
@ -352,16 +339,12 @@
[! ?1]
[#:pattern ((?formals . ?body) . ?rest)]
[#:frontier (list #'?body #'?rest)]
[#:bind (?formals* . ?body*) rename]
[#:rename (syntax/skeleton es1 ((?formals* . ?body*) . ?rest))
#'?formals #'?formals*
'rename-case-lambda]
[#:rename* (?formals . ?body) rename 'rename-case-lambda]
[Block ?body body]
[(CaseLambdaClauses (cdr es1))
?rest rest])]))
[CaseLambdaClauses ?rest rest])]))
;; mk-synth-items-reductions : syntax -> (list-of SynthItem) -> (RS syntax)
(define ((mk-synth-items-reductions e1) subterms)
;; 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)]
@ -369,9 +352,12 @@
(let* ([subterm0 (car subterms)]
[path0 (s:subterm-path subterm0)]
[deriv0 (s:subterm-deriv subterm0)])
(let ([ctx (lambda (x) (path-replace term path0 x))])
(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)))
(with-context ctx
(reductions* deriv0 (wderiv-e1 deriv0))))
(lambda ()
(loop (path-replace term path0 (wderiv-e2 deriv0))
(cdr subterms))))))]
@ -386,20 +372,17 @@
(s:rename-after subterm0))
(cdr subterms)))])))
;; transformation-reductions : Transformation -> (RS Stx)
(define (transformation-reductions tx)
;; transformation-reductions : Transformation stx -> (RS Stx)
(define (transformation-reductions tx init-e1)
(match tx
[(Wrap transformation (e1 e2 rs ?1 me1 locals ?2 me2 seq))
[(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
(list #'?form)
(list e2)
'macro])]))
[#:walk e2 'macro])]))
;; reductions-locals : syntax (list-of LocalAction) -> (RS void)
(define (reductions-locals stx locals)
@ -409,23 +392,24 @@
;; reductions-local : LocalAction -> (RS void)
(define (reductions-local local)
(match/with-derivation local
[(struct local-expansion (e1 e2 me1 me2 for-stx? deriv))
(reductions* deriv)]
[(struct local-expansion/expr (e1 e2 me1 me2 for-stx? opaque deriv))
(fprintf (current-error-port)
"reductions: local-expand-expr not fully implemented")
(reductions* deriv)]
[(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)]
[(struct local-lift (expr id))
(RSadd (list (walk expr id 'local-lift))
RSzero)]
[(struct local-lift-end (decl))
(RSadd (list (walk/mono decl 'module-lift))
RSzero)]
[(struct local-bind (bindrhs))
[(struct local-bind (names bindrhs))
(bind-syntaxes-reductions bindrhs)]))
;; list-reductions : ListDerivation -> (RS Stxs)
(define (list-reductions ld)
;; list-reductions : ListDerivation stxs -> (RS Stxs)
(define (list-reductions ld init-es1)
(match/with-derivation ld
[(Wrap lderiv (es1 es2 ?1 derivs))
(R es1
@ -434,13 +418,13 @@
[Expr (?form ...) derivs])]
[#f (RSunit null)]))
;; block-reductions : BlockDerivation -> (RS Stxs)
(define (block-reductions bd)
;; block-reductions : BlockDerivation stxs -> (RS Stxs)
(define (block-reductions bd init-es1)
(match/with-derivation bd
[(Wrap bderiv (es1 es2 pass1 trans pass2))
(R es1
[#:pattern ?form]
[(BRules es1) ?form pass1]
[BRules ?form pass1]
[#:when/np (eq? trans 'letrec)
[#:walk (wlderiv-es1 pass2) 'block->letrec]]
[#:frontier (stx->list* (wlderiv-es1 pass2))]
@ -448,8 +432,8 @@
[List ?form pass2])]
[#f (RSunit null)]))
;; mk-brules-reductions : stxs -> (list-of BRule) -> (RS Stxs)
(define ((mk-brules-reductions es1) brules)
;; brules-reductions : (list-of BRule) stxs -> (RS Stxs)
(define (brules-reductions brules es1)
(match brules
['()
(RSunit null)]
@ -459,7 +443,7 @@
[#:bind ?first* (cdr renames)]
[#:rename/no-step ?first (car renames) (cdr renames)]
[Expr ?first head]
[(BRules (stx-cdr es1)) ?rest rest])]
[BRules ?rest rest])]
[(cons (Wrap b:defvals (renames head ?1)) rest)
(R es1
[#:pattern (?first . ?rest)]
@ -469,7 +453,7 @@
[! ?1]
[#:pattern ((?define-values ?vars ?rhs) . ?rest)]
[#:learn (syntax->list #'?vars)]
[(BRules (stx-cdr es1)) ?rest rest])]
[BRules ?rest rest])]
[(cons (Wrap b:defstx (renames head ?1 bindrhs)) rest)
(R es1
[#:pattern (?first . ?rest)]
@ -480,7 +464,7 @@
[#:pattern ((?define-syntaxes ?vars ?rhs) . ?rest)]
[#:learn (syntax->list #'?vars)]
[BindSyntaxes ?rhs bindrhs]
[(BRules (stx-cdr es1)) ?rest rest])]
[BRules ?rest rest])]
[(cons (Wrap b:splice (renames head ?1 tail ?2)) rest)
(R es1
[#:pattern (?first . ?rest)]
@ -488,20 +472,20 @@
[#:rename/no-step ?first (car renames) (cdr renames)]
[Expr ?first head]
[! ?1]
[#:walk tail
(list #'?first)
(stx-take tail (- (stx-improper-length tail)
(stx-improper-length #'?rest)))
'splice-block]
[#:walk/foci tail
(list #'?first)
(stx-take tail (- (stx-improper-length tail)
(stx-improper-length #'?rest)))
'splice-block]
[! ?2]
[#:pattern ?forms]
[(BRules (stx->list* #'?forms)) ?forms rest])]
[BRules ?forms rest])]
[(cons (Wrap b:error (exn)) rest)
(R es1
[! exn])]))
;; bind-syntaxes-reductions : BindSyntaxes -> (RS stx)
(define (bind-syntaxes-reductions bindrhs)
;; bind-syntaxes-reductions : BindSyntaxes stx -> (RS stx)
(define (bind-syntaxes-reductions bindrhs init-e1)
(match bindrhs
[(Wrap bind-syntaxes (rhs ?1))
(R (wderiv-e1 rhs)
@ -509,54 +493,58 @@
[Expr ?form rhs]
[! ?1])]))
;; mk-mbrules-reductions : stx -> (list-of MBRule) -> (RS stxs)
(define ((mk-mbrules-reductions es1) mbrules)
;; mbrules-reductions : -> (list-of MBRule) stxs -> (RS stxs)
(define (mbrules-reductions mbrules es1)
(match mbrules
['()
(RSunit null)]
[(cons (Wrap mod:skip ()) rest)
[(cons (Wrap mod:prim (head rename prim)) rest)
(R es1
[#:pattern (?first . ?rest)]
[(ModulePass (stx-cdr es1)) ?rest rest])]
[(cons (Wrap mod:cons (head)) rest)
[#:pattern (?firstP . ?rest)]
[Expr ?firstP head]
[#:rename* ?firstP rename]
[Expr ?firstP prim]
[ModulePass ?rest rest])]
[(cons (Wrap mod:splice (head rename ?1 tail)) rest)
(R es1
[#:pattern (?first . ?rest)]
[Expr ?first head]
[(ModulePass (stx-cdr es1)) ?rest rest])]
[(cons (Wrap mod:prim (head prim)) rest)
(R es1
[#:pattern (?first . ?rest)]
[Expr ?first head]
[Expr ?first prim]
[(ModulePass (stx-cdr es1)) ?rest rest])]
[(cons (Wrap mod:splice (head ?1 tail)) rest)
(R es1
[#:pattern (?first . ?rest)]
[Expr ?first head]
[#:pattern (?firstB . ?rest)]
[Expr ?firstB head]
[#:rename* ?firstB rename]
[! ?1]
[#:walk tail
(list #'?first)
(stx-take tail (- (stx-improper-length tail)
(stx-improper-length #'?rest)))
'splice-module]
[#:walk/foci tail
(list #'?firstB)
(stx-take tail (- (stx-improper-length tail)
(stx-improper-length #'?rest)))
'splice-module]
[#:pattern ?forms]
[(ModulePass #'?forms) ?forms rest])]
[(cons (Wrap mod:lift (head stxs)) rest)
[ModulePass ?forms rest])]
[(cons (Wrap mod:lift (head renames stxs)) rest)
(R es1
[#:pattern (?first . ?rest)]
[Expr ?first head]
[#:pattern (?firstL . ?rest)]
[Expr ?firstL head]
[#:pattern ?forms]
[#:walk (append stxs #'?forms)
null
stxs
'splice-lifts]
[(ModulePass #'?forms) ?forms rest])]
[#:when/np renames
[#:rename* ?forms renames]]
[#:walk/foci (append stxs #'?forms)
null
stxs
'splice-lifts]
[ModulePass ?forms rest])]
[(cons (Wrap mod:lift-end (stxs)) rest)
(R es1
[#:pattern ?forms]
[#:when/np (pair? stxs)
[#:walk (append stxs #'?forms)
null
stxs
'splice-module-lifts]]
[(ModulePass #'?forms) ?forms rest])]))
[#:walk/foci (append stxs #'?forms)
null
stxs
'splice-module-lifts]]
[ModulePass ?forms rest])]
[(cons (Wrap mod:skip ()) rest)
(R es1
[#:pattern (?firstS . ?rest)]
[ModulePass ?rest rest])]
[(cons (Wrap mod:cons (head)) rest)
(R es1
[#:pattern (?firstC . ?rest)]
[Expr ?firstC head]
[ModulePass ?rest rest])]))

439
collects/macro-debugger/model/seek.ss Normal file
View File

@ -0,0 +1,439 @@
#lang scheme/base
(require scheme/match
scheme/list
"deriv.ss"
"deriv-util.ss"
"synth-engine.ss"
"synth-derivs.ss"
"stx-util.ss"
"context.ss")
(provide seek/deriv/on-fail
seek/deriv
current-seek-processor)
(define current-seek-processor (make-parameter values))
(define (process-node d)
((current-seek-processor) d))
;
; ;;
; ;;
; ;
; ;
; ;;;;; ;;;; ;;;; ; ;;;
; ;; ; ; ; ; ; ; ;
; ;; ;; ;; ;; ;; ; ;
; ;;; ;;;;;;; ;;;;;;; ;;;
; ;;;; ; ; ;;;
; ; ;; ;; ;; ; ;;
; ; ;; ;; ;; ; ;;
; ;;;;;; ;;;; ;;;; ;;; ;;;
;
;; Seek:
;; The derivation is "inactive" or "hidden" by default,
;; but pieces of it can become visible if they correspond to subterms
;; of the hidden syntax.
;; seek/deriv/on-fail : WDeriv (-> (values WDeriv syntax)) -> (values WDeriv syntax)
(define (seek/deriv/on-fail d fail-k)
(with-handlers ([hiding-failure?
(lambda (failure)
(handle-hiding-failure d failure)
(fail-k))])
(seek/deriv d)))
;; seek/deriv : WDeriv -> (values WDeriv syntax)
;; Seeks for derivations of all proper subterms of the derivation's
;; initial syntax.
(define (seek/deriv d)
(match d
[(Wrap deriv (e1 e2))
(let ([subterms (gather-proper-subterms e1)])
(parameterize ((subterms-table subterms))
(let ([sd (seek d)])
(values sd (wderiv-e2 sd)))))]))
;; seek : WDeriv -> WDeriv
;; Expects macro-policy, subterms-table to be set up already
(define (seek d)
(match d
[(Wrap deriv (e1 e2))
(SKlet ((subterms hidden-exn) (subterm-derivations d))
(begin (check-nonlinear-subterms subterms)
;; Now subterm substitution is safe, because they don't overlap
(create-synth-deriv e1 subterms hidden-exn)))]))
;; create-synth-deriv : syntax (list-of Subterm) ?exn -> WDeriv
(define (create-synth-deriv e1 subterms hidden-exn)
(let ([e2 (if hidden-exn #f (substitute-subterms e1 subterms))])
(make p:synth e1 e2 null #f subterms hidden-exn)))
;; subterm-derivations : Derivation -> SK
(define (subterm-derivations d)
(subterms-of-deriv d))
;; subterms-of-deriv : Derivation -> SK
(define (subterms-of-deriv d)
(let ([path (check-visible d)])
(if path
(let ([d (process-node d)])
(SKunit (list (make s:subterm path d))))
(subterms-of-unlucky-deriv d))))
;; subterms-of-deriv/phase-up : Derivation -> SK
(define (subterms-of-deriv/phase-up d)
(parameterize ((phase (add1 (phase))))
(subterms-of-deriv d)))
;; check-visible : Derivation -> Path/#f
(define (check-visible d)
(match d
[(Wrap deriv (e1 e2))
(let ([paths (table-get (subterms-table) e1)])
(cond [(null? paths) #f]
[(null? (cdr paths))
(car paths)]
[else
;; More than one path to the same(eq?) syntax object
;; Not good.
;; FIXME: Better to delay check to here, or check whole table first?
;; FIXME
(raise
(make nonlinearity e1 paths))]))]
[#f #f]))
;; subterms-of-unlucky-deriv : Derivation -> SK
;; Guarantee: (wderiv-e1 deriv) is not in subterms table
(define (subterms-of-unlucky-deriv d)
(match d
;; Primitives
[(Wrap p:module (e1 e2 rs ?1 ?2 tag rename check tag2 ?3 body shift))
(match (normalize-module d)
[(Wrap p:module (e1 e2 rs ?1 ?2 tag rename check tag2 ?3 body shift))
(>>Seek [! ?1]
[! ?2]
[#:rename
(do-rename (if tag
tag
(with-syntax ([(?module ?name ?lang ?body)
e1])
#'?body))
rename)]
(subterms-of-deriv check)
;; FIXME: tag
[! ?3]
(subterms-of-deriv body))])]
[(Wrap p:#%module-begin (e1 e2 rs ?1 me pass1 pass2 ?2))
(>>Seek [! ?1]
(subterms-of-lderiv (module-begin->lderiv d))
[! ?2])]
[(Wrap p:variable (e1 e2 rs ?1))
(>>Seek)]
[(Wrap p:define-syntaxes (e1 e2 rs ?1 rhs ?2))
(>>Seek [! ?1]
(subterms-of-deriv/phase-up rhs)
[! ?2])]
[(Wrap p:define-values (e1 e2 rs ?1 rhs))
(>>Seek [! ?1]
(subterms-of-deriv rhs))]
[(Wrap p:#%expression (e1 e2 rs ?1 inner))
(>>Seek [! ?1]
(subterms-of-deriv inner))]
[(Wrap p:if (e1 e2 rs ?1 test then else))
(>>Seek [! ?1]
(subterms-of-deriv test)
(subterms-of-deriv then)
(subterms-of-deriv else))]
[(Wrap p:wcm (e1 e2 rs ?1 key value body))
(>>Seek [! ?1]
(subterms-of-deriv key)
(subterms-of-deriv value)
(subterms-of-deriv body))]
[(Wrap p:set! (e1 e2 rs ?1 id-resolves rhs))
(>>Seek [! ?1]
(subterms-of-deriv rhs))]
[(Wrap p:set!-macro (e1 e2 rs ?1 deriv))
(>>Seek [! ?1]
(subterms-of-deriv deriv))]
[(Wrap p:begin (e1 e2 rs ?1 lderiv))
(>>Seek [! ?1]
(subterms-of-lderiv lderiv))]
[(Wrap p:begin0 (e1 e2 rs ?1 head lderiv))
(>>Seek [! ?1]
(subterms-of-deriv head)
(subterms-of-lderiv lderiv))]
[(Wrap p:#%app (e1 e2 rs ?1 lderiv))
(>>Seek [! ?1]
(subterms-of-lderiv lderiv))]
[(Wrap p:lambda (e1 e2 rs ?1 renames body))
(>>Seek [! ?1]
[#:rename (do-rename/lambda e1 renames)]
(subterms-of-bderiv body))]
[(Wrap p:case-lambda (e1 e2 rs ?1 clauses))
(>>Seek [! ?1]
(SKmap2 subterms-of-case-lambda-clause
clauses
(stx->list (stx-cdr e1))))]
[(Wrap p:let-values (e1 e2 rs ?1 renames rhss body))
(>>Seek [! ?1]
[#:rename (do-rename/let e1 renames)]
(SKmap subterms-of-deriv rhss)
(subterms-of-bderiv body))]
[(Wrap p:letrec-values (e1 e2 rs ?1 renames rhss body))
(>>Seek [! ?1]
[#:rename (do-rename/let e1 renames)]
(SKmap subterms-of-deriv rhss)
(subterms-of-bderiv body))]
[(Wrap p:letrec-syntaxes+values (e1 e2 rs ?1 srenames srhss vrenames vrhss body))
(>>Seek [! ?1]
[#:rename (do-rename/lsv1 e1 srenames)]
(SKmap subterms-of-bind-syntaxes srhss)
[#:rename (do-rename/lsv2 srenames vrenames)]
(SKmap subterms-of-deriv vrhss)
(subterms-of-bderiv body))]
[(Wrap p::STOP (e1 e2 rs ?1))
(>>Seek)]
;; synth (should synth be idempotent?... heh, no point for now)
[(Wrap p:rename (e1 e2 rs ?1 rename inner))
(>>Seek [! ?1]
[#:rename (do-rename (car rename) (cdr rename))]
(subterms-of-deriv inner))]
;; Macros
[(Wrap mrule (e1 e2 tx next))
(recv [(sk1 table) (subterms-of-transformation tx)]
(parameterize ((subterms-table table))
(SKseq sk1
(subterms-of-deriv next))))]
[(Wrap tagrule (e1 e2 tagged-stx next))
(subterms-of-deriv next)]
[(Wrap lift-deriv (e1 e2 first lifted-stx next))
(raise (make hidden-lift-site))]
[(Wrap lift/let-deriv (e1 e2 first lifted-stx next))
(raise (make hidden-lift-site))]
;; Errors
[#f (SKzero)]
))
;; subterms-of-transformation : Transformation -> SK Table
(define (subterms-of-transformation tx)
(match tx
[(Wrap transformation (e1 e2 rs ?1 me1 locals me2 ?2 _seq))
;; FIXME: We'll need to use e1/e2/me1/me2 to synth locals, perhaps
;; FIXME: and we'll also need to account for *that* marking, too...
(let ([end-table #f])
(let ([sk1
(>>Seek [! ?1]
[#:rename/no (do-rename e1 me1)]
(SKmap subterms-of-local-action locals)
[! ?2]
[#:rename/no (do-rename me2 e2)]
(begin (set! end-table (subterms-table))
(SKzero)))])
(values sk1 end-table)))]))
;; subterms-of-local-action : LocalAction -> SK
(define (subterms-of-local-action local)
(match local
[(struct local-expansion (e1 e2 me1 me2 deriv for-stx? lifted opaque))
(>>Seek [#:rename/no (do-rename me1 e1)] ;; FIXME: right order?
(let ([sk1 (subterms-of-deriv deriv)])
(SKlet ((subterms exn) sk1)
(if (pair? (filter s:subterm? subterms))
(raise (make localactions))
sk1))))]
[(struct local-lift (expr id))
;; FIXME: seek in the lifted deriv, transplant subterm expansions *here*
(let ([d (extract/remove-unvisited-lift id)])
(subterms-of-deriv d))]
[(struct local-lift-end (decl))
;; FIXME
(>>Seek)]
[(struct local-bind (names bindrhs))
;; FIXME: learn names
(let ([sk1 (subterms-of-bind-syntaxes bindrhs)])
(SKlet ((subterms exn) sk1)
(if (pair? (filter s:subterm? subterms))
(raise (make localactions))
sk1)))]))
;; subterms-of-lderiv : ListDerivation -> SK
(define (subterms-of-lderiv ld)
(match ld
[(Wrap lderiv (es1 es2 ?1 derivs))
(>>Seek [! ?1]
(SKmap subterms-of-deriv derivs))]
[#f (SKzero)]))
;; subterms-of-bderiv : BlockDerivation -> SK
(define (subterms-of-bderiv bd)
(subterms-of-lderiv (bderiv->lderiv bd)))
;; subterms-of-case-lambda-clause : CaseLambdaClause Syntax -> SK
(define (subterms-of-case-lambda-clause clause stx)
(match clause
[(Wrap clc (?1 renames body))
(>>Seek [! ?1]
[#:rename (do-rename/case-lambda stx renames)]
(subterms-of-bderiv body))]))
;; subterms-of-bind-syntaxes : BindSyntaxes -> SK
(define (subterms-of-bind-syntaxes bindrhs)
(match bindrhs
[(Wrap bind-syntaxes (rhs ?1))
(>>Seek (subterms-of-deriv rhs)
[! ?1])]))
;
; ;;;;
; ;; ;
; ; ;
; ; ;
; ; ;;; ;;;; ; ;; ;;; ;;;; ;;; ;;; ;;;;;
; ;; ; ; ; ; ;;; ;; ; ; ;;; ; ;; ;
; ; ; ;; ;; ; ; ;; ;; ;; ; ; ;;
; ; ; ;;;;;;; ; ; ;; ;;;;;;; ; ;;;
; ; ; ; ; ; ;; ; ; ;;;;
; ; ; ;; ; ; ;; ;; ; ; ;;
; ; ; ;; ; ; ; ;; ; ; ;;
; ;;; ;;; ;;;; ;;;;;;; ;;;; ;;;; ;;;;;; ;;;;;;
; ;
; ;
; ;;;;
;
;; gather-one-subterm : syntax syntax -> SubtermTable
(define (gather-one-subterm whole part)
(let ([table (make-hash-table)])
(let ([paths (find-subterm-paths part whole)])
(for-each (lambda (p) (table-add! table part p)) paths))
table))
;; gather-proper-subterms : Syntax -> SubtermTable
;; FIXME: Eventually, need to descend into vectors, boxes, etc.
(define (gather-proper-subterms stx0)
(let ([table (make-hash-table)])
;; loop : Syntax Path -> void
(define (loop stx rpath)
(unless (eq? stx0 stx)
(table-add! table stx (reverse rpath)))
(let ([p (syntax-e 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))
;
; ;;;;
; ;; ;
; ; ; ;
; ; ; ;
; ;;;;;; ;;;;; ; ;;; ; ;;;;
; ; ; ; ;; ;; ; ; ;
; ; ; ; ;; ; ;; ;;
; ; ;;;; ; ;; ; ;;;;;;;
; ; ;; ; ; ;; ; ;
; ; ;; ; ; ;; ; ;;
; ;; ;; ;; ; ; ; ;;
; ;;; ;;; ;; ;;;; ;;;;;;; ;;;;
;
;
;
;; A Table is a hashtable[syntax => (list-of Path)
(define (table-add! table stx v)
(hash-table-put! table stx (cons v (table-get table stx))))
(define (table-add-if-absent! table stx v)
(unless (memq v (table-get table stx))
(table-add! table stx v)))
(define (table-get table stx)
(hash-table-get table stx (lambda () null)))
;; do-rename : syntax syntax -> (values (list-of Subterm) Table)
(define (do-rename stx rename)
(let ([t (make-hash-table)]
[old (subterms-table)])
;; loop : syntax syntax -> (list-of Subterm)
;; Puts things into the new table, too
;; If active? is #f, always returns null
(define (loop stx rename active?)
(cond [(and (syntax? stx) (syntax? rename))
(let ([paths (table-get old stx)])
(if (pair? paths)
(begin (hash-table-put! t rename paths)
(loop (syntax-e stx) (syntax-e rename) #f)
(if active?
(map (lambda (p) (make s:rename p stx rename))
paths)
null))
(loop (syntax-e stx) (syntax-e rename) active?)))]
[(syntax? rename)
(loop stx (syntax-e rename) active?)]
[(syntax? stx)
(loop (syntax-e stx) rename active?)]
[(and (pair? stx) (pair? rename))
(append
(loop (car stx) (car rename) active?)
(loop (cdr stx) (cdr rename) active?))]
[else
null]))
(let ([subterms (loop stx rename #t)])
(values subterms t))))
(define (do-rename/lambda stx rename)
(if rename
(with-syntax ([(?lambda ?formals . ?body) stx])
(do-rename (cons #'?formals #'?body) rename))
(values null (subterms-table))))
(define (do-rename/let stx rename)
(if rename
(with-syntax ([(?let ?bindings . ?body) stx])
(do-rename (cons #'?bindings #'?body) rename))
(values null (subterms-table))))
(define (do-rename/case-lambda stx rename)
(if rename
(with-syntax ([(?formals . ?body) stx])
(do-rename (cons #'?formals #'?body) rename))
(values null (subterms-table))))
(define (do-rename/lsv1 stx rename)
(if rename
(with-syntax ([(?lsv ?sbindings ?vbindings . ?body) stx])
(do-rename (cons #'?sbindings (cons #'?vbindings #'?body)) rename))
(values null (subterms-table))))
(define (do-rename/lsv2 old-rename rename)
(if rename
(with-syntax ([(?sbindings ?vbindings . ?body) old-rename])
(do-rename (cons #'?vbindings #'?body) rename))
(values null (subterms-table))))

1
collects/macro-debugger/model/steps.ss
View File

@ -87,6 +87,7 @@
(tag-datum . "Tag datum")
(tag-top . "Tag top-level variable")
(capture-lifts . "Capture lifts")
(provide . "Expand provide-specs")
(local-lift . "Macro lifted expression to top-level")
(module-lift . "Macro lifted declaration to end of module")

91
collects/macro-debugger/model/synth-derivs.ss
View File

@ -106,6 +106,10 @@
(recv [(next e2) (head-loop next)]
(values (make mrule e1 e2 tx next)
e2))]
[(Wrap tagrule (e1 e2 tagged-stx next))
(recv [(next e2) (head-loop next)]
(values (make tagrule e1 e2 tagged-stx next)
e2))]
[(Wrap p:variable (e1 e2 rs ?1))
(adjust-tail e2 rs)]
;; FIXME: appropriate?
@ -312,13 +316,17 @@
;; FIXME: Need extra +1 in case of improper list?
(loop (stx-improper-length suffix)))
;; module-begin->lderiv : p:#%module-begin -> ??? ListDerivation
;; module-begin->lderiv : p:#%module-begin -> ListDerivation
;; Only use when ?1 is #f.
(define (module-begin->lderiv pr)
(let-values ([(forms pass1 pass2)
(let-values ([(init-forms forms pass1 pass2)
(match pr
[(Wrap p:#%module-begin (e1 _ _ #f pass1 pass2 ?2))
(values (stx-cdr e1) pass1 pass2)])])
[(Wrap p:#%module-begin (e1 _ _ #f me pass1 pass2 ?2))
;; FIXME: use 'me'???
(values (stx->list (stx-cdr e1))
(stx->list (stx-cdr me))
pass1
pass2)])])
;; eat-skip : -> void
(define (eat-skip)
@ -343,7 +351,7 @@
;; loop-nz : number -> (list-of WDeriv)
(define (loop-nz count)
(match pass1
[(cons (Wrap mod:prim (head prim)) next)
[(cons (Wrap mod:prim (head rename prim)) next)
(let ([form0 (stx-car forms)]
[pass1-part (car pass1)])
(set! forms (stx-cdr forms))
@ -352,20 +360,22 @@
(cons (wrap/rename-from form0
(combine-prim pass1-part pass2-part))
(loop (sub1 count)))))]
[(cons (Wrap mod:splice (head ?1 tail)) next)
[(cons (Wrap mod:splice (head rename ?1 tail)) next)
(let ([form0 (stx-car forms)]
[pass1-part (car pass1)])
(set! forms tail)
(set! pass1 next)
(if (not ?1)
(let ([inner-n (- (length (stx->list tail))
(length (stx->list (stx-cdr forms))))])
(let ([inner-n (length (stx->list (stx-cdr rename)))])
(let ([inners (loop inner-n)])
(cons (wrap/rename-from form0 (combine-begin head inners))
(cons (wrap/rename-from form0
(combine-begin head rename inners))
(loop (sub1 count)))))
(combine-derivs head
;; FIXME: use rename!
(make p:begin (wderiv-e2 head) #f null ?1 #f))))]
[(cons (Wrap mod:lift (head tail)) next)
[(cons (Wrap mod:lift (head renames tail)) next)
;; FIXME: use renames
(let ([form0 (stx-car forms)]
[inner-n (length (stx->list tail))])
(set! forms (stx-cdr forms))
@ -399,7 +409,7 @@
[(cons (Wrap mod:cons (deriv)) next)
(set! pass2 next)
(cons deriv (loop2 (sub1 count)))]
[(cons (Wrap mod:lift (deriv tail)) next)
[(cons (Wrap mod:lift (deriv #f tail)) next)
(set! pass2 next)
(let* ([head-e1 (wderiv-e1 deriv)]
[head-e2 (wderiv-e2 deriv)]
@ -434,14 +444,16 @@
#;(printf "module-body->lderiv:loop2: unexpected null~n")
(cons #f (loop2 (sub1 count)))])
null))
(define (outer-loop)
(if (pair? pass1)
(append (loop 1) (outer-loop))
null))
(let* ([derivs (outer-loop)]
[es1 forms]
(let* ([inner-derivs (outer-loop)]
[used-forms (take-if-possible init-forms (length inner-derivs))]
[derivs (map wrap/rename-from used-forms inner-derivs)]
[es1 init-forms]
[es2 (wderivlist-es2 derivs)])
(make lderiv es1 es2 #f derivs))))
@ -449,24 +461,30 @@
;; The MRule is always a mod:prim rule.
;; Need to insert a rename step in between...
(define (combine-prim mr deriv)
(let ([head (mod:prim-head mr)]
[pr (mod:prim-prim mr)])
(match-let ([(Wrap mod:prim (head rename pr)) mr])
(define (adapt d)
(wrap/rename-from rename
(or d (make p:stop rename rename null #f))))
(match pr
[(Wrap p:define-syntaxes (e1 e2 rs ?1 rhs ?2))
;; deriv is #f or trivial
(combine-derivs head pr)]
(unless (eq? deriv #f)
(error 'combine-prim "deriv not expected to be present: ~s" deriv))
(combine-derivs head (adapt pr))]
[(Wrap p:define-values (e1 e2 '() ?1 #f))
;; deriv is a pderiv for the entire define-values form
(combine-derivs head deriv)]
(combine-derivs head (adapt deriv))]
[#f
;; deriv is a complete derivation of the rest of the form
(combine-derivs head deriv)]
(combine-derivs head (adapt deriv))]
[(Wrap p::STOP (e1 e2 rs ?1))
;; deriv is #f
(combine-derivs head pr)])))
(unless (eq? deriv #f)
(error 'combine-prim "deriv not expected to be present: ~s" deriv))
(combine-derivs head (adapt pr))])))
;; combine-begin : OkDeriv (list-of (W Deriv)) -> WDeriv
(define (combine-begin head inners)
(define (combine-begin head rename inners)
(let* ([inners-es1 (map wderiv-e1 inners)]
[inners-es2 (wderivlist-es2 inners)]
[begin-e1 (wderiv-e2 head)]
@ -477,7 +495,8 @@
(combine-derivs
head
(let ([ld (make lderiv inners-es1 inners-es2 #f inners)])
(make p:begin begin-e1 begin-e2 null #f ld)))))
(wrap/rename-from rename
(make p:begin begin-e1 begin-e2 null #f ld))))))
;; combine-lifts : OkDeriv WDeriv (list-of WDeriv) -> WDeriv
(define (combine-lifts head finish inners)
@ -509,11 +528,20 @@
(with-syntax ([(?module-begin . _) e1]
[inners-es1* inners-es1]
[inners-es2* inners-es2])
#;
(unless (= (length inners) (length (stx->list inners-es1)))
(printf "~s\n" ld)
(error 'lderiv->module-begin "inners-es1 wrong length"))
#;
(unless (= (length inners) (length (stx->list inners-es2)))
(printf "~s\n" ld)
(error 'lderiv->module-begin "inners-es2 wrong length"))
(make p:#%module-begin
(syntax/skeleton e1 (?module-begin . inners-es1*))
(syntax/skeleton e1 (?module-begin . inners-es2*))
rs
#f
(syntax/skeleton e1 (?module-begin . inners-es1*))
(map (lambda (d) (make mod:cons d)) inners)
(map (lambda (x) (make mod:skip)) inners)
#f))]))
@ -545,3 +573,20 @@
derivs]
[#f
null])))]))
;; normalize-module : Deriv -> Deriv
(define (normalize-module d)
(match d
[(Wrap p:module (e1 e2 rs #f #f tag rename check tag2 #f body shift))
(let* ([check* #f]
[post-check-stx (if check (wderiv-e2 check) rename)]
[tag2* #f]
[body* (if tag2
(make tagrule post-check-stx (wderiv-e2 body) tag2 body)
body)]
[body** (if check
(combine-derivs check body*)
body*)])
(make p:module e1 e2 rs #f #f tag rename check* tag2* #f body** shift))]
[_ d]))

163
collects/macro-debugger/model/synth-engine.ss
View File

@ -20,11 +20,21 @@
current-hiding-warning-handler
warn
handle-hiding-failure
(struct-out hiding-failure)
(struct-out nonlinearity)
(struct-out localactions)
(struct-out hidden-lift-site)
DEBUG-LIFTS
current-unvisited-lifts
current-unhidden-lifts
add-unhidden-lift
extract/remove-unvisited-lift
(struct-out SKtuple)
SKlet
SKunit
SKzero
SKseq
@ -61,6 +71,85 @@
(define-struct (localactions hiding-failure) ())
(define-struct (hidden-lift-site hiding-failure) ())
;; Warnings
(define (handle-hiding-failure d failure)
(match failure
[(struct nonlinearity (term paths))
(warn 'nonlinearity term paths d)]
[(struct localactions ())
(warn 'localactions d)]
[(struct hidden-lift-site ())
(warn 'hidden-lift-site d)]))
;; Lift management
(define-syntax DEBUG-LIFTS
(syntax-rules ()
[(DEBUG-LIFTS . b)
(void)]
#;
[(DEBUG-LIFTS . b)
(begin . b)]))
;; current-unvisited-lifts : (paramter-of Derivation)
;; The derivs for the lifts yet to be seen in the processing
;; of the first part of the current lift-deriv.
(define current-unvisited-lifts (make-parameter null))
;; current-unhidden-lifts : (parameter-of Derivation)
;; The derivs for those lifts that occur within unhidden macros.
;; Derivs are moved from the current-unvisited-lifts to this list.
(define current-unhidden-lifts (make-parameter null))
;; add-unhidden-lift : Derivation -> void
(define (add-unhidden-lift d)
(when d
(current-unhidden-lifts
(cons d (current-unhidden-lifts)))))
;; extract/remove-unvisted-lift : identifier -> Derivation
(define (extract/remove-unvisited-lift id)
(define (get-defined-id d)
(match d
[(Wrap deriv (e1 e2))
(with-syntax ([(?define-values (?id) ?expr) e1])
#'?id)]))
;; The Wrong Way
(let ([unvisited (current-unvisited-lifts)])
(if (null? unvisited)
(begin (DEBUG-LIFTS
(printf "hide:extract/remove-unvisited-lift: out of lifts!"))
#f)
(let ([lift (car unvisited)])
(DEBUG-LIFTS
(printf "extracting lift: ~s left\n" (length (cdr unvisited))))
(current-unvisited-lifts (cdr unvisited))
lift)))
;; The Right Way
;; FIXME: Doesn't work inside of modules. Why not?
#;
(let loop ([lifts (current-unvisited-lifts)]
[prefix null])
(cond [(null? lifts)
(DEBUG-LIFTS
(fprintf (current-error-port)
"hide:extract/remove-unvisited-lift: can't find lift for ~s~n"
id))
(raise (make localactions))]
[(bound-identifier=? id (get-defined-id (car lifts)))
(let ([lift (car lifts)])
(current-unvisited-lifts
(let loop ([prefix prefix] [lifts (cdr lifts)])
(if (null? prefix)
lifts
(loop (cdr prefix) (cons (car prefix) lifts)))))
lift)]
[else
(loop (cdr lifts) (cons (car lifts) prefix))])))
;; Macros
@ -71,6 +160,8 @@
[(recv [(var ...) expr] . more)
(let-values ([(var ...) expr]) (recv . more))]))
;; H data
(define (Hunit d s)
(values d s #f))
@ -160,48 +251,52 @@
;; Seek
;; SK = (values (list-of SubItem) ?exn)
;; OLD SK = (values (list-of SubItem) ?exn)
(define-struct SKtuple (subs exn))
(define subitem/c (or/c s:subterm? s:rename?))
(define-syntax ->SK/c
(syntax-rules ()
[(->SK/c domain ...)
(-> domain ... (values (listof subitem/c) (or/c exn? false/c)))]))
(define SK/c (struct/c SKtuple (listof subitem/c) (or/c exn? false/c)))
(define-syntax-rule (SKlet ([x y] c) . body)
(match-let ([(struct SKtuple (x y)) c]) . body))
(define/contract SKunit
(->SK/c (listof subitem/c))
(lambda (x)
(values x #f)))
((listof subitem/c) . -> . SK/c)
(lambda (x) (make SKtuple x #f)))
(define/contract SKzero
(->SK/c)
(lambda () (values null #f)))
(-> SK/c)
(lambda () (make SKtuple null #f)))
(define/contract SKfail
(->SK/c exn?)
(lambda (exn)
(values null exn)))
(exn? . -> . SK/c)
(lambda (exn) (make SKtuple null exn)))
(define/contract SKseq
(->SK/c (->SK/c) (->SK/c))
(SK/c SK/c . -> . SK/c)
(lambda (c1 c2)
(recv [(si1 exn1) (c1)]
(if (not exn1)
(recv [(si2 exn2) (c2)]
(values (append si1 si2) exn2))
(values si1 exn1)))))
(SKlet ((si1 exn1) c1)
(if (not exn1)
(SKlet ((si2 exn2) c2)
(make SKtuple (append si1 si2) exn2))
(make SKtuple si1 exn1)))))
(define (SKmap f xs)
(if (pair? xs)
(SKseq (lambda () (f (car xs)))
(lambda () (SKmap f (cdr xs))))
(SKzero)))
(define/contract SKmap
((any/c . -> . SK/c) (listof any/c) . -> . SK/c)
(lambda (f xs)
(if (pair? xs)
(SKseq (f (car xs))
(SKmap f (cdr xs)))
(SKzero))))
(define (SKmap2 f xs ys)
(if (pair? xs)
(SKseq (lambda () (f (car xs) (car ys)))
(lambda () (SKmap f (cdr xs) (cdr ys))))
(SKzero)))
(define/contract SKmap2
((any/c any/c . -> . SK/c) (listof any/c) (listof any/c) . -> . SK/c)
(lambda (f xs ys)
(if (pair? xs)
(SKseq (f (car xs) (car ys))
(SKmap2 f (cdr xs) (cdr ys)))
(SKzero))))
(define-syntax >>Seek
(syntax-rules (! =>)
@ -220,8 +315,8 @@
[(>>Seek [#:rename expr] . more)
(let-values ([(subterms new-table) expr])
(parameterize ((subterms-table new-table))
(SKseq (lambda () (SKunit subterms))
(lambda () (>>Seek . more)))))]
(SKseq (SKunit subterms)
(>>Seek . more))))]
[(>>Seek expr . more)
(SKseq (lambda () expr)
(lambda () (>>Seek . more)))]))
(SKseq expr
(>>Seek . more))]))

5
collects/macro-debugger/model/yacc-interrupted.ss
View File

@ -234,6 +234,11 @@
(define wrap?
(let ([wrap? (assq '#:wrap options)]
[no-wrap? (assq '#:no-wrap options)])
(when (and wrap? no-wrap?)
(raise-syntax-error 'split
"cannot specify both #:wrap and #:no-wrap"
stx))
#;
(unless (and (or wrap? no-wrap?) (not (and wrap? no-wrap?)))
(raise-syntax-error 'split
"must specify exactly one of #:wrap, #:no-wrap"

3
collects/macro-debugger/stepper-text.ss
View File

@ -6,7 +6,6 @@
"model/reductions.ss"
"model/steps.ss"
"model/hide.ss"
"model/hiding-policies.ss"
"syntax-browser/partition.ss"
"syntax-browser/pretty-helper.ss")
(provide expand/step-text
@ -125,8 +124,6 @@
(lambda (id)
(ormap (lambda (x) (free-identifier=? x id))
show))]
[(hiding-policy? show)
(lambda (x) (policy-show-macro? show x))]
[(eq? show #f)
#f]
[else

14
collects/macro-debugger/syntax-browser/display.ss
View File

@ -176,11 +176,6 @@
(let ([end (get-end-position)])
;; Pretty printer always inserts final newline; we remove it here.
(send text delete (sub1 end) end))
;; Set font to standard
(send text change-style
(code-style text)
(get-start-position)
(get-end-position))
(let ([offset (get-start-position)])
(fixup-parentheses text range offset)
(for-each
@ -191,8 +186,13 @@
(send text set-clickback (+ offset start) (+ offset end)
(lambda (_1 _2 _3)
(send controller set-selected-syntax stx)))))
(send range all-ranges))
range)))
(send range all-ranges)))
;; Set font to standard
(send text change-style
(code-style text)
(get-start-position)
(get-end-position))
range))
;; fixup-parentheses : text range -> void
(define (fixup-parentheses text range offset)

131
collects/macro-debugger/syntax-browser/keymap.ss
View File

@ -4,35 +4,73 @@
scheme/gui
"interfaces.ss"
"partition.ss")
(provide syntax-keymap%
context-menu%)
(provide smart-keymap%
syntax-keymap%)
(define syntax-keymap%
(define smart-keymap%
(class keymap%
(init editor)
(init-field controller)
(inherit add-function
map-function
chain-to-keymap)
(super-new)
(define/public (get-context-menu%)
context-menu%)
smart-context-menu%)
(define/public (make-context-menu)
(new (get-context-menu%) (controller controller) (keymap this)))
;; Key mappings
(field (the-context-menu #f))
(set! the-context-menu (new (get-context-menu%)))
(map-function "rightbutton" "popup-context-window")
;; Functionality
(add-function "popup-context-window"
(lambda (editor event)
(do-popup-context-window editor event)))
(chain-to-keymap (send editor get-keymap) #t)
(send editor set-keymap this)
(define/private (do-popup-context-window editor event)
(define-values (x y)
(send editor dc-location-to-editor-location
(send event get-x)
(send event get-y)))
(define admin (send editor get-admin))
(send admin popup-menu the-context-menu x y))
))
(define smart-context-menu%
(class popup-menu%
(define on-demand-actions null)
(define/public (add-on-demand p)
(set! on-demand-actions (cons p on-demand-actions)))
(define/override (on-demand)
(for-each (lambda (p) (p)) on-demand-actions))
(super-new)))
(define syntax-keymap%
(class smart-keymap%
(init-field controller
config)
(inherit add-function
map-function
call-function
chain-to-keymap)
(inherit-field the-context-menu)
(field [copy-menu #f]
[clear-menu #f]
[props-menu #f])
(super-new)
;; Functionality
(define/public (get-controller) controller)
(add-function "copy-text"
(lambda (_ event)
(define stx (send controller get-selected-syntax))
@ -48,38 +86,17 @@
(add-function "show-syntax-properties"
(lambda (i e)
(error 'show-syntax-properties "not provided by this keymap")))
(send config set-props-shown? #t)))
;; Attach to editor
(chain-to-keymap (send editor get-keymap) #t)
(send editor set-keymap this)
(define/public (get-controller) controller)
(define/private (do-popup-context-window editor event)
(define-values (x y)
(send editor dc-location-to-editor-location
(send event get-x)
(send event get-y)))
(define admin (send editor get-admin))
(send admin popup-menu (make-context-menu) x y))))
(define context-menu%
(class popup-menu%
(init-field keymap)
(init-field controller)
(super-new)
(field [copy-menu #f]
[clear-menu #f]
[props-menu #f])
(add-function "hide-syntax-properties"
(lambda (i e)
(send config set-props-shown? #f)))
(define/public (add-edit-items)
(set! copy-menu
(new menu-item% (label "Copy") (parent this)
(new menu-item% (label "Copy") (parent the-context-menu)
(callback (lambda (i e)
(send keymap call-function "copy-text" i e)))))
(call-function "copy-text" i e)))))
(void))
(define/public (after-edit-items)
@ -89,24 +106,26 @@
(set! clear-menu
(new menu-item%
(label "Clear selection")
(parent this)
(parent the-context-menu)
(callback
(lambda (i e)
(send keymap call-function "clear-syntax-selection" i e)))))
(call-function "clear-syntax-selection" i e)))))
(set! props-menu
(new menu-item%
(label "Show syntax properties")
(parent this)
(parent the-context-menu)
(callback
(lambda (i e)
(send keymap call-function "show-syntax-properties" i e)))))
(lambda (i e)
(if (send config get-props-shown?)
(call-function "hide-syntax-properties" i e)
(call-function "show-syntax-properties" i e))))))
(void))
(define/public (after-selection-items)
(void))
(define/public (add-partition-items)
(let ([secondary (new menu% (label "identifier=?") (parent this))])
(let ([secondary (new menu% (label "identifier=?") (parent the-context-menu))])
(for-each
(lambda (name func)
(let ([this-choice
@ -128,15 +147,10 @@
(void))
(define/public (add-separator)
(new separator-menu-item% (parent this)))
(new separator-menu-item% (parent the-context-menu)))
(define/override (on-demand)
(define stx (send controller get-selected-syntax))
(send copy-menu enable (and stx #t))
(send clear-menu enable (and stx #t))
(super on-demand))
;; Initialize menu
;; Initialization
(add-edit-items)
(after-edit-items)
@ -147,4 +161,15 @@
(add-separator)
(add-partition-items)
(after-partition-items)
))
(send the-context-menu add-on-demand
(lambda ()
(define stx (send controller get-selected-syntax))
(send copy-menu enable (and stx #t))
(send clear-menu enable (and stx #t))))
(send config listen-props-shown?
(lambda (shown?)
(send props-menu set-label
(if shown?
"Hide syntax properties"
"Show syntax properties"))))))

38
collects/macro-debugger/syntax-browser/prefs.ss
View File

@ -3,11 +3,15 @@
(require scheme/class
framework/framework
"interfaces.ss"
"../util/notify.ss"
"../util/misc.ss")
(provide syntax-prefs%
syntax-prefs-mixin
syntax-prefs/readonly%
pref:tabify)
#;pref:tabify
#;pref:height
#;pref:width
#;pref:props-percentage)
(preferences:set-default 'SyntaxBrowser:Width 700 number?)
(preferences:set-default 'SyntaxBrowser:Height 600 number?)
@ -18,14 +22,28 @@
(pref:get/set pref:height SyntaxBrowser:Height)
(pref:get/set pref:props-percentage SyntaxBrowser:PropertiesPanelPercentage)
(pref:get/set pref:props-shown? SyntaxBrowser:PropertiesPanelShown)
(pref:get/set pref:tabify framework:tabify)
(define syntax-prefs-mixin
(closure-mixin (syntax-prefs<%>)
(pref:width pref:width)
(pref:height pref:height)
(pref:props-percentage pref:props-percentage)
(pref:props-shown? pref:props-shown?)))
(define syntax-prefs-base%
(class object%
(notify-methods width)
(notify-methods height)
(notify-methods props-percentage)
(notify-methods props-shown?)
(super-new)))
(define syntax-prefs% (syntax-prefs-mixin object%))
(define syntax-prefs%
(class syntax-prefs-base%
(connect-to-pref width pref:width)
(connect-to-pref height pref:height)
(connect-to-pref props-percentage pref:props-percentage)
(connect-to-pref props-shown? pref:props-shown?)
(super-new)))
(define syntax-prefs/readonly%
(class syntax-prefs-base%
(connect-to-pref/readonly width pref:width)
(connect-to-pref/readonly height pref:height)
(connect-to-pref/readonly props-percentage pref:props-percentage)
(connect-to-pref/readonly props-shown? pref:props-shown?)
(super-new)))

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

@ -85,6 +85,8 @@
[else #f]))
(define (pp-better-style-table)
(basic-style-list)
#; ;; Messes up formatting too much :(
(let* ([pref (pref:tabify)]
[table (car pref)]
[begin-rx (cadr pref)]

3
collects/macro-debugger/syntax-browser/properties.ss
View File

@ -3,7 +3,8 @@
(require scheme/class
scheme/gui
"interfaces.ss"
"util.ss")
"util.ss"
"../util/mpi.ss")
(provide properties-view%
properties-snip%)

272
collects/macro-debugger/syntax-browser/syntax-snip.ss
View File

@ -6,26 +6,57 @@
mzlib/match
mzlib/list
mzlib/string
"../util/notify.ss"
"interfaces.ss"
"display.ss"
"controller.ss"
"keymap.ss"
"properties.ss"
"partition.ss")
"partition.ss"
"prefs.ss")
(provide syntax-value-snip%)
(provide syntax-snip%
syntax-value-snip%)
(define syntax-snip-config-base%
(class object%
(notify-methods props-shown?)
(super-new)))
(define syntax-snip-config%
(class syntax-snip-config-base%
(define/override (init-props-shown?) (new notify-box% (value #f)))
(super-new)))
(define dumb-host%
(class object%
(define controller (new controller%))
(define config (new syntax-snip-config%))
(super-new)
(define/public (get-controller) controller)
(define/public (get-config) config)
(define/public (add-keymap text snip)
(send text set-keymap
(new syntax-keymap%
(controller controller)
(editor text)
(config config))))))
;; syntax-value-snip%
(define syntax-value-snip%
(class* editor-snip% (readable-snip<%>)
(init-field ((stx syntax)))
(init-field host)
(init-field (host (new dumb-host%)))
(inherit set-margin
set-inset)
(define text (new text:standard-style-list%))
(super-new (editor text) (with-border? #f))
(set-margin 0 0 0 0)
(set-inset 2 2 2 2)
;;(set-inset 2 2 2 2)
;;(set-margin 2 2 2 2)
(set-inset 0 0 0 0)
(send text begin-edit-sequence)
(send text change-style (make-object style-delta% 'change-alignment 'top))
(define display
@ -48,12 +79,18 @@
#'(p)))
))
;; syntax-snip%
#;
(define syntax-snip%
(class* editor-snip% (readable-snip<%>)
(init-field ((stx syntax)))
(init-field primary-partition)
(define top-aligned
(make-object style-delta% 'change-alignment 'top))
(define-struct styled (contents style clickback))
;; clicky-snip%
(define clicky-snip%
(class* editor-snip% ()
(init-field [open-style '(border)]
[closed-style '(tight-text-fit)])
(inherit set-margin
set-inset
set-snipclass
@ -61,76 +98,54 @@
show-border
get-admin)
(define properties-snip (new properties-snip%))
(define -outer (new text%))
(super-new (editor -outer) (with-border? #f))
(set-margin 0 0 0 0)
(set-inset 0 0 0 0)
(set-snipclass snip-class)
(send -outer select-all)
(set-margin 2 2 2 2)
(set-inset 2 2 2 2)
;;(set-margin 3 0 0 0)
;;(set-inset 1 0 0 0)
;;(set-margin 0 0 0 0)
;;(set-inset 0 0 0 0)
(define the-syntax-snip
(new syntax-value-snip%
(syntax stx)
(controller controller)
;; FIXME
#;(syntax-keymap% syntax-keymap%)
))
(define the-summary
(let ([line (syntax-line stx)]
[col (syntax-column stx)])
(if (and line col)
(format "#<syntax:~s:~s>" line col)
"#<syntax>")))
(define/public (closed-contents) null)
(define/public (open-contents) null)
(define shown? #f)
(define/public (refresh)
(if shown?
(refresh/shown)
(refresh/hidden)))
(define open? #f)
(define/private (refresh/hidden)
(define/public (refresh-contents)
(send* -outer
(begin-edit-sequence)
(lock #f)
(erase))
(set-tight-text-fit #t)
(show-border #f)
(outer:insert (show-icon) style:hyper
(lambda _ (set! shown? #t) (refresh)))
(outer:insert the-summary)
(send* -outer
(do-style (if open? open-style closed-style))
(outer:insert (if open? (hide-icon) (show-icon))
style:hyper
(if open?
(lambda _
(set! open? #f)
(refresh-contents))
(lambda _
(set! open? #t)
(refresh-contents))))
(for-each (lambda (s) (outer:insert s))
(if open? (open-contents) (closed-contents)))
(send* -outer
(change-style top-aligned 0 (send -outer last-position))
(lock #t)
(end-edit-sequence)))
(define/private (refresh/shown)
(send* -outer
(begin-edit-sequence)
(lock #f)
(erase))
(set-tight-text-fit #f)
(show-border #t)
(outer:insert (hide-icon) style:hyper
(lambda _ (set! shown? #f) (refresh)))
(outer:insert " ")
(outer:insert the-syntax-snip)
(outer:insert " ")
(if (props-shown?)
(begin (outer:insert "<" style:green (lambda _ (show #f)))
(outer:insert properties-snip))
(begin (outer:insert ">" style:green (lambda _ (show #t)))))
(send* -outer
(change-style (make-object style-delta% 'change-alignment 'top)
0
(send -outer last-position))
(lock #t)
(end-edit-sequence)))
(define/private (do-style style)
(show-border (memq 'border style))
(set-tight-text-fit (memq 'tight-text-fit style)))
(define/private outer:insert
(case-lambda
[(obj)
(outer:insert obj style:normal)]
(if (styled? obj)
(outer:insert (styled-contents obj)
(styled-style obj)
(styled-clickback obj))
(outer:insert obj style:normal))]
[(text style)
(outer:insert text style #f)]
[(text style clickback)
@ -141,78 +156,78 @@
(when clickback
(send -outer set-clickback start end clickback))))]))
(send -outer hide-caret #t)
(send -outer lock #t)
(refresh-contents)
))
;; syntax-snip%
(define syntax-snip%
(class* clicky-snip% (readable-snip<%>)
(init-field ((stx syntax)))
(init-field (host (new dumb-host%)))
(define config (send host get-config))
(inherit set-snipclass
refresh-contents)
(define the-syntax-snip
(new syntax-value-snip%
(syntax stx)
(host host)))
(define the-summary
(let* ([t (new text%)]
[es (new editor-snip% (editor t) (with-border? #f))])
(send es set-margin 0 0 0 0)
(send es set-inset 0 0 0 0)
(send t insert (format "~s" stx))
es))
(define properties-snip
(new properties-container-snip%
(controller (send host get-controller))))
(define/override (closed-contents)
(list the-summary))
(define/override (open-contents)
(list " "
the-syntax-snip
" "
properties-snip))
;; Snip methods
(define/override (copy)
(new syntax-snip% (syntax stx)))
(define/override (write stream)
(send stream put (string->bytes/utf-8 (format "~s" (marshall-syntax stx)))))
(send stream put
(string->bytes/utf-8
(format "~s" (marshall-syntax stx)))))
(define/public (read-special src line col pos)
(send the-syntax-snip read-special src line col pos))
(define/private (find-primary-partition)
#;(define editor (send (get-admin) get-editor))
(new-bound-partition))
(send config listen-props-shown?
(lambda (?) (refresh-contents)))
(super-new)
(set-snipclass snip-class)))
;; syntax-properties-controller methods
(define properties-shown? #f)
(define/public (props-shown?)
properties-shown?)
(define/public (show ?)
(set! properties-shown? ?)
(refresh))
(define/public (set-syntax stx)
(send properties-snip set-syntax stx))
(define properties-container-snip%
(class clicky-snip%
(init controller)
(refresh)
(send -outer hide-caret #t)
(send -outer lock #t)
))
(define properties-snip
(new properties-snip% (controller controller)))
;; independent-properties-controller%
#;
(define independent-properties-controller%
(class* object% (syntax-properties-controller<%>)
(init-field controller)
(init-field ((stx syntax) #f))
;; Properties display
(define parent
(new frame% (label "Properties") (height (pref:height))
(width (floor (* (pref:props-percentage) (pref:width))))))
(define pv (new properties-view% (parent parent)))
(define/private (show-properties)
(unless (send parent is-shown?)
(send parent show #t)))
(define/public (set-syntax stx)
(send pv set-syntax stx))
(define/public (show ?)
(send parent show ?))
(define/public (props-shown?)
(send parent is-shown?))
(super-new)))
#;
(define snip-keymap-extension@
(unit
(import (prefix pre: keymap^))
(export keymap^)
(define syntax-keymap%
(class pre:syntax-keymap%
(init-field snip)
(inherit add-function)
(super-new (controller (send snip get-controller)))
(add-function "show-syntax-properties"
(lambda (i e)
(send snip show-props)))))))
(define/override (open-contents)
(list #;(show-properties-icon)
properties-snip))
(define/override (closed-contents)
(list (show-properties-icon)))
(super-new (open-style '())
(closed-style '()))))
(define style:normal (make-object style-delta% 'change-normal))
(define style:hyper
@ -276,7 +291,6 @@
[else (string->symbol (format "unknown-object: ~s" obj))]))
;; COPIED AND MODIFIED from mrlib/syntax-browser.ss
#;
(define syntax-snipclass%
(class snip-class%
(define/override (read stream)
@ -284,12 +298,12 @@
(unmarshall-syntax (read-from-string (send stream get-bytes)))))
(super-instantiate ())))
#;(define snip-class (make-object syntax-snipclass%))
#;(send snip-class set-version 2)
#;(send snip-class set-classname
(define snip-class (make-object syntax-snipclass%))
(send snip-class set-version 2)
(send snip-class set-classname
(format "~s" '(lib "implementation.ss" "macro-debugger" "syntax-browser")))
#;(send (get-the-snip-class-list) add snip-class)
(send (get-the-snip-class-list) add snip-class)
(define (unmarshall-syntax stx)
(match stx
[`(syntax

30
collects/macro-debugger/syntax-browser/util.ss
View File

@ -2,9 +2,7 @@
#lang scheme/base
(require scheme/class)
(provide with-unlock
make-text-port
mpi->string
mpi->list)
make-text-port)
;; with-unlock SYNTAX (expression)
;; (with-unlock text-expression . body)
@ -31,29 +29,3 @@
(lambda (special buffer? enable-break?)
(send text insert special (end-position))
#t)))
;; mpi->string : module-path-index -> string
(define (mpi->string mpi)
(if (module-path-index? mpi)
(let ([mps (mpi->list mpi)])
(cond [(and (pair? mps) (pair? (cdr mps)))
(apply string-append
(format "~s" (car mps))
(map (lambda (x) (format " <= ~s" x)) (cdr mps)))]
[(and (pair? mps) (null? (cdr mps)))
(format "~s" (car mps))]
[(null? mps) "this module"]))
(format "~s" mpi)))
;; mpi->list : module-path-index -> (list-of module-spec)
(define (mpi->list mpi)
(cond [(module-path-index? mpi)
(let-values ([(path rel) (module-path-index-split mpi)])
(cond [(and (pair? path) (memq (car path) '(file lib planet)))
(cons path null)]
[path
(cons path (mpi->list rel))]
[else '()]))]
[(not mpi)
'()]
[else (list mpi)]))

69
collects/macro-debugger/syntax-browser/widget.ss
View File

@ -16,9 +16,7 @@
"properties.ss"
"text.ss"
"util.ss")
(provide widget%
widget-keymap%
widget-context-menu%)
(provide widget%)
;; widget%
;; A syntax widget creates its own syntax-controller.
@ -27,7 +25,7 @@
(init parent)
(init-field config)
(define controller (new controller%))
(field [controller (new controller%)])
(define -main-panel
(new vertical-panel% (parent parent)))
@ -41,19 +39,15 @@
(new properties-view%
(parent -props-panel)
(controller controller)))
(define props-percentage (send config pref:props-percentage))
(define/public (setup-keymap)
(new widget-keymap%
(new syntax-keymap%
(editor -text)
(widget this)))
(config config)))
(send -text set-styles-sticky #f)
(send -text lock #t)
(send -split-panel set-percentages
(list (- 1 props-percentage) props-percentage))
;; syntax-properties-controller<%> methods
(define/public (props-shown?)
@ -65,16 +59,25 @@
(define/public (show-props show?)
(if show?
(unless (send -props-panel is-shown?)
(send -split-panel add-child -props-panel)
(send -split-panel set-percentages
(list (- 1 props-percentage) props-percentage))
(let ([p (send config get-props-percentage)])
(send -split-panel add-child -props-panel)
(update-props-percentage p))
(send -props-panel show #t))
(when (send -props-panel is-shown?)
(set! props-percentage
(cadr (send -split-panel get-percentages)))
(send -split-panel delete-child -props-panel)
(send -props-panel show #f))))
(send config listen-props-percentage
(lambda (p)
(update-props-percentage p)))
(send config listen-props-shown?
(lambda (show?)
(show-props show?)))
(define/private (update-props-percentage p)
(send -split-panel set-percentages
(list (- 1 p) p)))
;;
(define/public (get-controller) controller)
@ -84,8 +87,9 @@
(define/public (get-main-panel) -main-panel)
(define/public (shutdown)
(unless (= props-percentage (send config pref:props-percentage))
(send config pref:props-percentage props-percentage)))
(when (props-shown?)
(send config set-props-percentage
(cadr (send -split-panel get-percentages)))))
;; syntax-browser<%> Methods
@ -99,7 +103,7 @@
(send -text insert text)
(let ([b (send -text last-position)])
(send -text change-style error-text-style a b)))))
(define/public (add-clickback text handler)
(with-unlock -text
(let ([a (send -text last-position)])
@ -215,35 +219,6 @@
;; Specialized classes for widget
(define widget-keymap%
(class syntax-keymap%
(init-field widget)
(super-new (controller (send widget get-controller)))
(inherit add-function)
(inherit-field controller)
(define/override (get-context-menu%)
widget-context-menu%)
(add-function "show-syntax-properties"
(lambda (i e)
(send widget toggle-props)))
(define/public (get-widget) widget)))
(define widget-context-menu%
(class context-menu%
(inherit-field keymap)
(inherit-field props-menu)
(define/override (on-demand)
(send props-menu set-label
(if (send (send keymap get-widget) props-shown?)
"Hide syntax properties"
"Show syntax properties"))
(super on-demand))
(super-new)))
(define browser-text%
(class (text:arrows-mixin
(text:tacking-mixin

46
collects/macro-debugger/util/hiding.ss
View File

@ -1,46 +0,0 @@
#lang scheme/base
(provide (all-defined-out))
(define (scheme-module? mpi)
(let ([abs (find-absolute-module-path mpi)])
(and abs
(or (base-module-path? abs)
(scheme-lib-module-path? abs)))))
(define (lib-module? mpi)
(let ([abs (find-absolute-module-path mpi)])
(and abs (lib-module-path? abs))))
(define (find-absolute-module-path mpi)
(and (module-path-index? mpi)
(let-values ([(path rel) (module-path-index-split mpi)])
(cond [(and (pair? path) (memq (car path) '(quote lib planet)))
path]
[(symbol? path) path]
[(string? path) (find-absolute-module-path rel)]
[else #f]))))
(define (base-module-path? mp)
(and (pair? mp)
(eq? 'quote (car mp))
(regexp-match #rx"^#%" (symbol->string (cadr mp)))))
(define (scheme-lib-module-path? mp)
(cond [(symbol? mp)
(scheme-collection-name? (symbol->string mp))]
[(and (pair? mp) (eq? (car mp) 'lib))
(cond [(string? (cadr mp)) (null? (cddr mp))
(scheme-collection-name? (cadr mp))]
[(symbol? (cadr mp))
(scheme-collection-name? (symbol->string (cadr mp)))]
[else #f])]
[else #f]))
(define (scheme-collection-name? path)
(or (regexp-match? #rx"^scheme(/.)?" path)
(regexp-match? #rx"^mzscheme(/.)?" path)))
(define (lib-module-path? mp)
(or (symbol? mp)
(and (pair? mp) (memq (car mp) '(lib planet)))))

23
collects/macro-debugger/util/mpi.ss Normal file
View File

@ -0,0 +1,23 @@
#lang scheme/base
(provide mpi->list
mpi->string)
(define (mpi->list mpi)
(cond [(module-path-index? mpi)
(let-values ([(path relto) (module-path-index-split mpi)])
(cond [(not path) null]
[(not relto) (list path)]
[else (cons path (mpi->list relto))]))]
[(not mpi) null]
[else (list mpi)]))
;; mpi->string : module-path-index -> string
(define (mpi->string mpi)
(if (module-path-index? mpi)
(let ([mps (mpi->list mpi)])
(cond [(pair? mps)
(apply string-append
(format "~s" (car mps))
(map (lambda (x) (format " <= ~s" x)) (cdr mps)))]
[(null? mps) "this module"]))
(format "~s" mpi)))

2
collects/macro-debugger/view/debug-format.ss
View File

@ -14,7 +14,7 @@
(write (map serialize-context-frame
(continuation-mark-set->context
(exn-continuation-marks exn)))))
'replace))
#:exists 'replace))
(define (serialize-datum d)
(cond [(number? d) `(quote ,d)]

72
collects/macro-debugger/view/extensions.ss
View File

@ -12,6 +12,7 @@
"warning.ss"
"hiding-panel.ss"
(prefix-in s: "../syntax-browser/widget.ss")
(prefix-in s: "../syntax-browser/keymap.ss")
"../model/deriv.ss"
"../model/deriv-util.ss"
"../model/trace.ss"
@ -20,22 +21,24 @@
"cursor.ss"
"../util/notify.ss")
(provide stepper-keymap%
stepper-context-menu%
stepper-syntax-widget%)
;; Extensions
(define stepper-keymap%
(class s:widget-keymap%
(class s:syntax-keymap%
(init-field macro-stepper)
(inherit-field controller)
(inherit add-function)
(inherit-field config
controller
the-context-menu)
(inherit add-function
call-function)
(define show-macro #f)
(define hide-macro #f)
(super-new)
(define/override (get-context-menu%)
stepper-context-menu%)
(define/public (get-hiding-panel)
(send macro-stepper get-macro-hiding-prefs))
@ -44,54 +47,50 @@
(send* (get-hiding-panel)
(add-show-identifier)
(refresh))))
(add-function "hiding:hide-macro"
(lambda (i e)
(send* (get-hiding-panel)
(add-hide-identifier)
(refresh))))))
(refresh))))
;; Menu
(define stepper-context-menu%
(class s:widget-context-menu%
(inherit-field keymap)
(inherit add-separator)
(field [show-macro #f]
[hide-macro #f])
(define/override (after-selection-items)
(super after-selection-items)
(add-separator)
(set! show-macro
(new menu-item% (label "Show this macro") (parent this)
(new menu-item% (label "Show selected identifier") (parent the-context-menu)
(callback (lambda (i e)
(send keymap call-function "hiding:show-macro" i e)))))
(call-function "hiding:show-macro" i e)))))
(set! hide-macro
(new menu-item% (label "Hide this macro") (parent this)
(new menu-item% (label "Hide selected identifier") (parent the-context-menu)
(callback (lambda (i e)
(send keymap call-function "hiding:hide-macro" i e)))))
(call-function "hiding:hide-macro" i e)))))
(enable/disable-hide/show #f)
(void))
(define/override (on-demand)
(define hiding-panel (send keymap get-hiding-panel))
(define controller (send keymap get-controller))
(define stx (send controller get-selected-syntax))
(define id? (identifier? stx))
(send show-macro enable id?)
(send hide-macro enable id?)
(super on-demand))
(super-new)))
(define/private (enable/disable-hide/show ?)
(send show-macro enable ?)
(send hide-macro enable ?))
(send controller listen-selected-syntax
(lambda (stx)
(enable/disable-hide/show (identifier? stx))))))
(define stepper-syntax-widget%
(class s:widget%
(init-field macro-stepper)
(inherit get-text)
(inherit-field controller)
(define/override (setup-keymap)
(new stepper-keymap%
(editor (get-text))
(widget this)
(config (send macro-stepper get-config))
(controller controller)
(macro-stepper macro-stepper)))
(define/override (show-props show?)
@ -99,13 +98,4 @@
(send macro-stepper update/preserve-view))
(super-new
(config (new config-adapter%
(config (send macro-stepper get-config)))))))
(define config-adapter%
(class object%
(init-field config)
(define/public pref:props-percentage
(case-lambda [() (send config get-props-percentage)]
[(v) (send config set-props-percentage v)]))
(super-new)))
(config (send macro-stepper get-config)))))

15
collects/macro-debugger/view/frame.ss
View File

@ -92,8 +92,10 @@
(new (get-macro-stepper-widget%)
(parent (get-area-container))
(config config)))
(define controller (send widget get-controller))
(define/public (get-widget) widget)
(define/public (get-controller) controller)
(define/public (add-obsoleted-warning)
(unless obsoleted?
@ -116,7 +118,6 @@
"Show syntax properties"
(get-field show-syntax-properties? config))
;; FIXME: rewrite with notify-box
(let ([id-menu
(new (get-menu%)
(label "Identifier=?")
@ -128,24 +129,24 @@
(parent id-menu)
(callback
(lambda _
(send (send widget get-controller)
set-identifier=? p))))])
(send (send widget get-controller)
listen-identifier=?
(send controller set-identifier=? p))))])
(send controller listen-identifier=?
(lambda (name+func)
(send this-choice check
(eq? (car name+func) (car p)))))))
(sb:identifier=-choices)))
(let ([identifier=? (send config get-identifier=?)])
(when identifier=?
(let ([p (assoc identifier=? (sb:identifier=-choices))])
(send (send widget get-controller) set-identifier=? p))))
(send controller set-identifier=? p))))
(new (get-menu-item%)
(label "Clear selection")
(parent stepper-menu)
(callback
(lambda _ (send (send widget get-controller) select-syntax #f))))
(lambda _ (send controller set-selected-syntax #f))))
(new separator-menu-item% (parent stepper-menu))
(menu-option/notify-box stepper-menu

45
collects/macro-debugger/view/hiding-panel.ss
View File

@ -4,54 +4,15 @@
scheme/gui
scheme/list
syntax/boundmap
"../model/synth-engine.ss"
"../syntax-browser/util.ss"
"../util/notify.ss"
"../util/hiding.ss")
"../model/hiding-policies.ss"
"../util/mpi.ss"
"../util/notify.ss")
(provide macro-hiding-prefs-widget%)
(define mode:disable "Disable")
(define mode:standard "Standard")
(define mode:custom "Custom ...")
(define (make-policy hide-mzscheme?
hide-libs?
hide-contracts?
hide-transformers?
specialized-policies)
(lambda (id)
(define now (phase))
(define binding
(cond [(= now 0) (identifier-binding id)]
[(= now 1) (identifier-transformer-binding id)]
[else #f]))
(define-values (def-mod def-name nom-mod nom-name)
(if (pair? binding)
(values (car binding)
(cadr binding)
(caddr binding)
(cadddr binding))
(values #f #f #f #f)))
(let/ec return
(let loop ([policies specialized-policies])
(when (pair? policies)
((car policies) id binding return)
(loop (cdr policies))))
(cond [(and hide-mzscheme? def-mod (scheme-module? def-mod))
#f]
[(and hide-libs? def-mod (lib-module? def-mod))
#f]
[(and hide-contracts? def-name
(regexp-match #rx"^provide/contract-id-"
(symbol->string def-name)))
#f]
[(and hide-transformers? (positive? now))
#f]
[else #t]))))
(define standard-policy
(make-policy #t #t #t #t null))
;; macro-hiding-prefs-widget%
(define macro-hiding-prefs-widget%
(class object%

8
collects/macro-debugger/view/prefs.ss
View File

@ -10,6 +10,7 @@
(preferences:set-default 'MacroStepper:Frame:Width 700 number?)
(preferences:set-default 'MacroStepper:Frame:Height 600 number?)
(preferences:set-default 'MacroStepper:PropertiesShown? #f boolean?)
(preferences:set-default 'MacroStepper:PropertiesPanelPercentage 1/3 number?)
(preferences:set-default 'MacroStepper:MacroHidingMode "Standard" string?)
(preferences:set-default 'MacroStepper:ShowSyntaxProperties? #f boolean?)
@ -26,6 +27,7 @@
(pref:get/set pref:width MacroStepper:Frame:Width)
(pref:get/set pref:height MacroStepper:Frame:Height)
(pref:get/set pref:props-shown? MacroStepper:PropertiesShown?)
(pref:get/set pref:props-percentage MacroStepper:PropertiesPanelPercentage)
(pref:get/set pref:macro-hiding-mode MacroStepper:MacroHidingMode)
(pref:get/set pref:show-syntax-properties? MacroStepper:ShowSyntaxProperties?)
@ -44,8 +46,9 @@
(class object%
(notify-methods width)
(notify-methods height)
(notify-methods macro-hiding-mode)
(notify-methods props-shown?)
(notify-methods props-percentage)
(notify-methods macro-hiding-mode)
(notify-methods show-syntax-properties?)
(notify-methods show-hiding-panel?)
(notify-methods identifier=?)
@ -63,8 +66,9 @@
(class macro-stepper-config-base%
(connect-to-pref width pref:width)
(connect-to-pref height pref:height)
(connect-to-pref macro-hiding-mode pref:macro-hiding-mode)
(connect-to-pref props-shown? pref:props-shown?)
(connect-to-pref props-percentage pref:props-percentage)
(connect-to-pref macro-hiding-mode pref:macro-hiding-mode)
(connect-to-pref show-syntax-properties? pref:show-syntax-properties?)
(connect-to-pref show-hiding-panel? pref:show-hiding-panel?)
(connect-to-pref identifier=? pref:identifier=?)

13
collects/macro-debugger/view/term-record.ss
View File

@ -173,7 +173,7 @@
synth-warnings))))
(force-letrec-transformation
force-letrec?))
(hide/policy deriv show-macro?))
(hide*/policy deriv show-macro?))
(values deriv (wderiv-e2 deriv))))
(set! synth-deriv synth-deriv*)
(set! synth-estx estx*)))))))
@ -390,7 +390,7 @@
(define/public (add-syntax stx binders definites)
(send sbview add-syntax stx
'#:alpha-table binders
'#:definites definites))
'#:definites (or definites null)))
(define/private (add-final stx error binders definites)
(when stx
@ -483,9 +483,10 @@
(send sbview add-error-text (exn-message (misstep-exn step)))
(send sbview add-text "\n")
(when (exn:fail:syntax? (misstep-exn step))
(for-each (lambda (e) (send sbview add-syntax e
'#:alpha-table binders
'#:definites (protostep-definites step)))
(for-each (lambda (e)
(send sbview add-syntax e
'#:alpha-table binders
'#:definites (or (protostep-definites step) null)))
(exn:fail:syntax-exprs (misstep-exn step))))
(show-lctx step binders))
@ -493,7 +494,7 @@
;; 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
'#:definites definites
'#:definites (or definites null)
'#:alpha-table binders
'#:hi-color hi-color
'#:hi-stxs (if (send config get-highlight-foci?) foci null)

20
collects/scribblings/reference/readtables.scrbl
View File

@ -293,7 +293,7 @@ character and the @scheme[#f] readtable.}
(object-name port)))]
[(ch port src line col pos)
;; `read-syntax' mode
(datum->syntax-object
(datum->syntax
#f
(wrap (parse port
(lambda ()
@ -343,12 +343,12 @@ no other location information is available).
When a reader-extension procedure is called in syntax-reading mode
(via @scheme[read-syntax], @|etc|), it should generally return a syntax
object that has no lexical context (e.g., a syntax object created
using @scheme[datum->syntax-object] with @scheme[#f] as the first
using @scheme[datum->syntax] with @scheme[#f] as the first
argument and with the given location information as the third
argument). Another possible result is a special-comment value (see
@secref["special-comments"]). If the procedure's result is not a
syntax object and not a special-comment value, it is converted to one
using @scheme[datum->syntax-object].
using @scheme[datum->syntax].
When a reader-extension procedure is called in non-syntax-reading
modes, it should generally not return a syntax object. If a syntax
@ -361,13 +361,13 @@ is a special-comment value (see @secref["special-comments"]), then
delimiting comment and otherwise ignore it.
Also, in either context, the result may be copied to prevent mutation
to pairs, vectors, or boxes before the read result is completed, and
to support the construction of graphs with cycles. Mutable pairs,
boxes, and vectors are copied, along with any pairs, boxes, or vectors
that lead to such mutable values, to placeholders produced by a
recursive read (see @scheme[read/recursive]), or to references of a
shared value. Graph structure (including cycles) is preserved in the
copy.
to vectors or boxes before the read result is completed, and to
support the construction of graphs with cycles. Mutable boxes,
vectors, and @tech{prefab} structures are copied, along with any
pairs, boxes, vectors, pre prefab structures that lead to such mutable
values, to placeholders produced by a recursive read (see
@scheme[read/recursive]), or to references of a shared value. Graph
structure (including cycles) is preserved in the copy.
@;------------------------------------------------------------------------
@section[#:tag "special-comments"]{Special Comments}

11
collects/tests/mzscheme/readtable.ss
View File

@ -62,6 +62,12 @@
[(ch port src line col pos)
(test #\_ values ch)
(read-char port) (read-char port) (read-char port)
(make-special-comment #f)])]
[comment3.2
(case-lambda
[(ch port src line col pos)
(test #\? values ch)
(read-char port) (read-char port) (read-char port)
(make-special-comment #f)])])
(let ([t (make-readtable #f
#\$ 'terminating-macro plain-dollar
@ -71,7 +77,8 @@
#\= #\\ #f
#\~ #\space #f
#\_ 'terminating-macro comment3
#\$ 'dispatch-macro hash-dollar)])
#\$ 'dispatch-macro hash-dollar
#\? 'dispatch-macro comment3.2)])
(test-values '(#\a #f #f) (lambda () (readtable-mapping t #\a)))
(test-values '(#\| #f #f) (lambda () (readtable-mapping t #\^)))
(test-values '(#\( #f #f) (lambda () (readtable-mapping t #\<)))
@ -131,7 +138,9 @@
(test-read "a _xxx b" '(a b))
(test-read "(a _xxx b)" '((a b)))
(test-read "(a _xxx . b)" '((a . b)))
(test-read "(a #?xxx . b)" '((a . b)))
(test-read "(a . _xxx b)" '((a . b)))
(test-read "(a . #?xxx b)" '((a . b)))
(if old-caret?
(test-read "(a ^_xxx^ b)" '((a ^ ^ b)))
(test-read "(a ^_xxx^ b)" '((a _xxx b))))

31
src/mzscheme/src/eval.c
View File

@ -5413,7 +5413,8 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
return f(form, env, rec, drec);
} else {
form = scheme_datum_to_syntax(scheme_make_pair(stx, form), form, form, 0, 2);
SCHEME_EXPAND_OBSERVE_TAG(rec[drec].observer, form);
if (SAME_TYPE(SCHEME_TYPE(var), scheme_syntax_compiler_type)) {
if (rec[drec].comp) {
Scheme_Syntax *f;
@ -8952,11 +8953,7 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
observer = scheme_get_expand_observe();
if (observer) {
if (for_expr) {
SCHEME_EXPAND_OBSERVE_ENTER_LOCAL_EXPR(observer, l);
} else {
SCHEME_EXPAND_OBSERVE_ENTER_LOCAL(observer, l);
}
SCHEME_EXPAND_OBSERVE_ENTER_LOCAL(observer, l);
if (for_stx) {
SCHEME_EXPAND_OBSERVE_PHASE_UP(observer);
}
@ -8987,14 +8984,20 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
drec[0].value_name = scheme_false; /* or scheme_current_thread->current_local_name ? */
drec[0].certs = scheme_current_thread->current_local_certs;
drec[0].depth = -2;
drec[0].observer = observer;
xl = scheme_check_immediate_macro(l, env, drec, 0, 0, &gval, NULL, NULL);
if (SAME_OBJ(xl, l))
if (SAME_OBJ(xl, l)) {
SCHEME_EXPAND_OBSERVE_LOCAL_POST(observer, xl);
SCHEME_EXPAND_OBSERVE_EXIT_LOCAL(observer, orig_l);
return orig_l;
}
if (catch_lifts_key)
if (catch_lifts_key) {
xl = add_lifts_as_begin(xl, scheme_frame_get_lifts(env), env);
SCHEME_EXPAND_OBSERVE_LIFT_LOOP(observer,xl);
}
l = xl;
} else {
@ -9034,7 +9037,8 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
if (for_expr) {
Scheme_Object *a[2];
SCHEME_EXPAND_OBSERVE_EXIT_LOCAL_EXPR(observer, l, exp_expr);
SCHEME_EXPAND_OBSERVE_OPAQUE_EXPR(observer, exp_expr);
SCHEME_EXPAND_OBSERVE_EXIT_LOCAL(observer, l);
a[0] = l;
a[1] = exp_expr;
return scheme_values(2, a);
@ -9293,9 +9297,12 @@ static Scheme_Object *
local_eval(int argc, Scheme_Object **argv)
{
Scheme_Comp_Env *env, *stx_env, *old_stx_env;
Scheme_Object *l, *a, *rib, *expr, *certs, *names;
Scheme_Object *l, *a, *rib, *expr, *certs, *names, *observer;
int cnt = 0, pos;
observer = scheme_get_expand_observe();
SCHEME_EXPAND_OBSERVE_LOCAL_BIND(observer, argv[0]);
names = argv[0];
for (l = names; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
a = SCHEME_CAR(l);
@ -9347,7 +9354,7 @@ local_eval(int argc, Scheme_Object **argv)
rec.depth = -1;
rec.value_name = scheme_false;
rec.certs = certs;
rec.observer = scheme_get_expand_observe();
rec.observer = observer;
/* Evaluate and bind syntaxes */
expr = scheme_add_remove_mark(expr, scheme_current_thread->current_local_mark);

31
src/mzscheme/src/module.c
View File

@ -4818,6 +4818,8 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
self_modidx,
scheme_false);
SCHEME_EXPAND_OBSERVE_NEXT(rec[drec].observer);
/* load the module for the initial require */
iim = module_load(_module_resolve(iidx, m->ii_src, 1), menv, NULL);
start_module(iim, menv, 0, iidx, 1, 0, scheme_null);
@ -4870,6 +4872,11 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
}
fm = scheme_datum_to_syntax(fm, form, form, 0, 2);
if (check_mb) {
SCHEME_EXPAND_OBSERVE_TAG(rec[drec].observer, fm);
}
fm = scheme_stx_property(fm, module_name_symbol, SCHEME_PTR_VAL(m->modname));
if (!empty_self_modidx) {
@ -4885,14 +4892,12 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
fm = scheme_add_rename(fm, rn_set);
SCHEME_EXPAND_OBSERVE_RENAME_ONE(rec[drec].observer, fm);
if (!check_mb) {
SCHEME_EXPAND_OBSERVE_NEXT(rec[drec].observer);
fm = scheme_check_immediate_macro(fm, benv, rec, drec, 0, &mbval, NULL, NULL);
SCHEME_EXPAND_OBSERVE_NEXT(rec[drec].observer);
/* If expansion is not the primitive `#%module-begin', add local one: */
if (!SAME_OBJ(mbval, modbeg_syntax)) {
Scheme_Object *mb;
@ -4902,6 +4907,9 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
fm = scheme_stx_property(fm, module_name_symbol, SCHEME_PTR_VAL(m->modname));
/* Since fm is a newly-created syntax object, we need to re-add renamings: */
fm = scheme_add_rename(fm, rn_set);
SCHEME_EXPAND_OBSERVE_TAG(rec[drec].observer, fm);
check_mb = 1;
}
}
@ -4990,7 +4998,8 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
/* rename tables no longer needed; NULL them out */
menv->rename_set = NULL;
}
SCHEME_EXPAND_OBSERVE_RENAME_ONE(rec[drec].observer, fm);
return fm;
}
@ -5382,17 +5391,18 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
scheme_rec_add_certs(rec, drec, form);
observer = rec[drec].observer;
/* It's possible that #%module-begin expansion introduces
marked identifiers for definitions. */
form = scheme_add_rename(form, post_ex_rn_set);
SCHEME_EXPAND_OBSERVE_RENAME_ONE(observer, form);
maybe_has_lifts = 0;
lift_ctx = scheme_generate_lifts_key();
/* Pass 1 */
observer = rec[drec].observer;
/* Partially expand all expressions, and process definitions, requires,
and provides. Also, flatten top-level `begin' expressions: */
for (fm = SCHEME_STX_CDR(form); !SCHEME_STX_NULLP(fm); ) {
@ -5430,7 +5440,9 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
fm = SCHEME_STX_CDR(fm);
e = scheme_add_rename(e, post_ex_rn_set);
fm = scheme_named_map_1(NULL, add_a_rename, fm, post_ex_rn_set);
fm = scheme_append(fst, scheme_make_pair(e, fm));
fm = scheme_make_pair(e, fm);
SCHEME_EXPAND_OBSERVE_RENAME_LIST(observer, fm);
fm = scheme_append(fst, fm);
SCHEME_EXPAND_OBSERVE_MODULE_LIFT_LOOP(observer, fst);
} else {
/* No definition lifts added... */
@ -5442,6 +5454,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
if (fst && SCHEME_STX_SYMBOLP(fst) && scheme_stx_module_eq(scheme_begin_stx, fst, 0)) {
fm = SCHEME_STX_CDR(fm);
e = scheme_add_rename(e, post_ex_rn_set);
SCHEME_EXPAND_OBSERVE_RENAME_ONE(observer, e);
fm = scheme_flatten_begin(e, fm);
SCHEME_EXPAND_OBSERVE_SPLICE(observer, fm);
if (SCHEME_STX_NULLP(fm)) {
@ -5461,6 +5474,8 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
if (!e) break; /* (begin) expansion at end */
e = scheme_add_rename(e, post_ex_rn_set);
SCHEME_EXPAND_OBSERVE_RENAME_ONE(observer, e);
if (SCHEME_STX_PAIRP(e)) {
Scheme_Object *fst;

19
src/mzscheme/src/schexpobs.h
View File

@ -147,4 +147,23 @@ extern Scheme_Object *scheme_get_expand_observe();
#define SCHEME_EXPAND_OBSERVE_START_EXPAND(obs) \
_SCHEME_EXPOBS(obs,141,scheme_false)
#define SCHEME_EXPAND_OBSERVE_TAG(obs,stx) \
_SCHEME_EXPOBS(obs,142,stx)
#define SCHEME_EXPAND_OBSERVE_LOCAL_BIND(obs,ids) \
_SCHEME_EXPOBS(obs,143,ids)
#define SCHEME_EXPAND_OBSERVE_ENTER_BIND(obs) \
_SCHEME_EXPOBS(obs,144,scheme_false)
#define SCHEME_EXPAND_OBSERVE_EXIT_BIND(obs) \
_SCHEME_EXPOBS(obs,145,scheme_false)
#define SCHEME_EXPAND_OBSERVE_OPAQUE_EXPR(obs,val) \
_SCHEME_EXPOBS(obs,146,val)
#define SCHEME_EXPAND_OBSERVE_RENAME_LIST(obs,vals) \
_SCHEME_EXPOBS(obs,147,vals)
#define SCHEME_EXPAND_OBSERVE_RENAME_ONE(obs,val) \
_SCHEME_EXPOBS(obs,148,val)
#endif

6
src/mzscheme/src/syntax.c
View File

@ -5511,7 +5511,7 @@ void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object
/* First expand for expansion-observation */
if (!rec[drec].comp) {
scheme_init_expand_recs(rec, drec, &mrec, 1);
SCHEME_EXPAND_OBSERVE_PHASE_UP(mrec.observer);
SCHEME_EXPAND_OBSERVE_ENTER_BIND(rec[drec].observer);
a = scheme_expand_expr_lift_to_let(a, eenv, &mrec, 0);
}
@ -5544,6 +5544,8 @@ void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object
but it's not likely that a let-syntax-bound macro is going
to run lots of times, so JITting is probably not worth it. */
SCHEME_EXPAND_OBSERVE_NEXT(rec[drec].observer);
a = eval_letmacro_rhs(a, rhs_env, ri->max_let_depth, rp, eenv->genv->phase, certs);
if (SAME_OBJ(a, SCHEME_MULTIPLE_VALUES)) {
@ -5596,6 +5598,8 @@ void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object
scheme_set_local_syntax(i++, name, macro, stx_env);
}
*_pos = i;
SCHEME_EXPAND_OBSERVE_EXIT_BIND(rec[drec].observer);
}
static Scheme_Object *