From 5165d9e8559eda1245acee8296c81613c3770c7a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 4 Apr 2008 17:38:23 +0000 Subject: [PATCH] sync Ryan's macro-debugger changes svn: r9166 --- collects/macro-debugger/expand.ss | 2 +- collects/macro-debugger/model/debug.ss | 6 +- collects/macro-debugger/model/deriv-c.ss | 42 +- collects/macro-debugger/model/deriv-find.ss | 32 +- collects/macro-debugger/model/deriv-parser.ss | 273 ++++---- collects/macro-debugger/model/deriv-tokens.ss | 18 +- collects/macro-debugger/model/deriv.ss | 2 +- collects/macro-debugger/model/hide.ss | 602 +++--------------- .../macro-debugger/model/hiding-policies.ss | 173 ++--- .../macro-debugger/model/reductions-engine.ss | 144 +++-- collects/macro-debugger/model/reductions.ss | 380 ++++++----- collects/macro-debugger/model/seek.ss | 439 +++++++++++++ collects/macro-debugger/model/steps.ss | 1 + collects/macro-debugger/model/synth-derivs.ss | 91 ++- collects/macro-debugger/model/synth-engine.ss | 163 ++++- .../macro-debugger/model/yacc-interrupted.ss | 5 + collects/macro-debugger/stepper-text.ss | 3 - .../macro-debugger/syntax-browser/display.ss | 14 +- .../macro-debugger/syntax-browser/keymap.ss | 131 ++-- .../macro-debugger/syntax-browser/prefs.ss | 38 +- .../syntax-browser/pretty-printer.ss | 2 + .../syntax-browser/properties.ss | 3 +- .../syntax-browser/syntax-snip.ss | 272 ++++---- .../macro-debugger/syntax-browser/util.ss | 30 +- .../macro-debugger/syntax-browser/widget.ss | 69 +- collects/macro-debugger/util/hiding.ss | 46 -- collects/macro-debugger/util/mpi.ss | 23 + collects/macro-debugger/view/debug-format.ss | 2 +- collects/macro-debugger/view/extensions.ss | 72 +-- collects/macro-debugger/view/frame.ss | 15 +- collects/macro-debugger/view/hiding-panel.ss | 45 +- collects/macro-debugger/view/prefs.ss | 8 +- collects/macro-debugger/view/term-record.ss | 13 +- .../scribblings/reference/readtables.scrbl | 20 +- collects/tests/mzscheme/readtable.ss | 11 +- src/mzscheme/src/eval.c | 31 +- src/mzscheme/src/module.c | 31 +- src/mzscheme/src/schexpobs.h | 19 + src/mzscheme/src/syntax.c | 6 +- 39 files changed, 1702 insertions(+), 1575 deletions(-) create mode 100644 collects/macro-debugger/model/seek.ss delete mode 100644 collects/macro-debugger/util/hiding.ss create mode 100644 collects/macro-debugger/util/mpi.ss diff --git a/collects/macro-debugger/expand.ss b/collects/macro-debugger/expand.ss index ecb9f1ed1c..058dadf10e 100644 --- a/collects/macro-debugger/expand.ss +++ b/collects/macro-debugger/expand.ss @@ -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))) diff --git a/collects/macro-debugger/model/debug.ss b/collects/macro-debugger/model/debug.ss index d345a20631..3447f46503 100644 --- a/collects/macro-debugger/model/debug.ss +++ b/collects/macro-debugger/model/debug.ss @@ -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)) diff --git a/collects/macro-debugger/model/deriv-c.ss b/collects/macro-debugger/model/deriv-c.ss index 7a7d597c5e..64863aa0ee 100644 --- a/collects/macro-debugger/model/deriv-c.ss +++ b/collects/macro-debugger/model/deriv-c.ss @@ -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 Deriv Stx Deriv) @@ -24,7 +25,7 @@ ;; A Transformation is ;; (make-transformation 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 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 Boolean ?Deriv ?exn Deriv) -;; (make-p:#%module-begin 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 ?exn ?stx stx ?Deriv ?stx ?exn Deriv ?stx) +;; (make-p:#%module-begin 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 DerivLL) ;; (make-p:define-values Deriv) @@ -61,7 +63,7 @@ ;; (make-p:set! Rs Deriv) ;; (make-p:set!-macro 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 Stx LDeriv) ;; (make-p:begin LDeriv) ;; (make-p:begin0 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 #:transparent) diff --git a/collects/macro-debugger/model/deriv-find.ss b/collects/macro-debugger/model/deriv-find.ss index 4a0962584c..727f3a54dc 100644 --- a/collects/macro-debugger/model/deriv-find.ss +++ b/collects/macro-debugger/model/deriv-find.ss @@ -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 diff --git a/collects/macro-debugger/model/deriv-parser.ss b/collects/macro-debugger/model/deriv-parser.ss index 277d9fdde1..b6161d5e4e 100644 --- a/collects/macro-debugger/model/deriv-parser.ss +++ b/collects/macro-debugger/model/deriv-parser.ss @@ -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)]) diff --git a/collects/macro-debugger/model/deriv-tokens.ss b/collects/macro-debugger/model/deriv-tokens.ss index 7cf5f05a2e..cd5284bfd0 100644 --- a/collects/macro-debugger/model/deriv-tokens.ss +++ b/collects/macro-debugger/model/deriv-tokens.ss @@ -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) diff --git a/collects/macro-debugger/model/deriv.ss b/collects/macro-debugger/model/deriv.ss index 21c1eabb5c..a7be9bd43b 100644 --- a/collects/macro-debugger/model/deriv.ss +++ b/collects/macro-debugger/model/deriv.ss @@ -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?] diff --git a/collects/macro-debugger/model/hide.ss b/collects/macro-debugger/model/hide.ss index fb72a31411..74035ad411 100644 --- a/collects/macro-debugger/model/hide.ss +++ b/collects/macro-debugger/model/hide.ss @@ -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)))) diff --git a/collects/macro-debugger/model/hiding-policies.ss b/collects/macro-debugger/model/hiding-policies.ss index 9c10ea9389..753f3c634a 100644 --- a/collects/macro-debugger/model/hiding-policies.ss +++ b/collects/macro-debugger/model/hiding-policies.ss @@ -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))))) diff --git a/collects/macro-debugger/model/reductions-engine.ss b/collects/macro-debugger/model/reductions-engine.ss index 66b1d5dd12..ac2e9bf515 100644 --- a/collects/macro-debugger/model/reductions-engine.ss +++ b/collects/macro-debugger/model/reductions-engine.ss @@ -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) diff --git a/collects/macro-debugger/model/reductions.ss b/collects/macro-debugger/model/reductions.ss index 56cd7ba65b..ad898ebf39 100644 --- a/collects/macro-debugger/model/reductions.ss +++ b/collects/macro-debugger/model/reductions.ss @@ -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])])) diff --git a/collects/macro-debugger/model/seek.ss b/collects/macro-debugger/model/seek.ss new file mode 100644 index 0000000000..74417ba235 --- /dev/null +++ b/collects/macro-debugger/model/seek.ss @@ -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)))) diff --git a/collects/macro-debugger/model/steps.ss b/collects/macro-debugger/model/steps.ss index f8c6f2666f..fcb832d84c 100644 --- a/collects/macro-debugger/model/steps.ss +++ b/collects/macro-debugger/model/steps.ss @@ -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") diff --git a/collects/macro-debugger/model/synth-derivs.ss b/collects/macro-debugger/model/synth-derivs.ss index 9197caaa9c..db1d338317 100644 --- a/collects/macro-debugger/model/synth-derivs.ss +++ b/collects/macro-debugger/model/synth-derivs.ss @@ -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])) diff --git a/collects/macro-debugger/model/synth-engine.ss b/collects/macro-debugger/model/synth-engine.ss index d747cc629c..f4f7883a2f 100644 --- a/collects/macro-debugger/model/synth-engine.ss +++ b/collects/macro-debugger/model/synth-engine.ss @@ -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))])) diff --git a/collects/macro-debugger/model/yacc-interrupted.ss b/collects/macro-debugger/model/yacc-interrupted.ss index 4fb494e9c7..f83832b321 100644 --- a/collects/macro-debugger/model/yacc-interrupted.ss +++ b/collects/macro-debugger/model/yacc-interrupted.ss @@ -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" diff --git a/collects/macro-debugger/stepper-text.ss b/collects/macro-debugger/stepper-text.ss index 3d9ab990ac..36fb532869 100644 --- a/collects/macro-debugger/stepper-text.ss +++ b/collects/macro-debugger/stepper-text.ss @@ -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 diff --git a/collects/macro-debugger/syntax-browser/display.ss b/collects/macro-debugger/syntax-browser/display.ss index f7abc68c27..e8c6ae52e4 100644 --- a/collects/macro-debugger/syntax-browser/display.ss +++ b/collects/macro-debugger/syntax-browser/display.ss @@ -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) diff --git a/collects/macro-debugger/syntax-browser/keymap.ss b/collects/macro-debugger/syntax-browser/keymap.ss index b9f1af6dfc..dab85ada3c 100644 --- a/collects/macro-debugger/syntax-browser/keymap.ss +++ b/collects/macro-debugger/syntax-browser/keymap.ss @@ -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")))))) diff --git a/collects/macro-debugger/syntax-browser/prefs.ss b/collects/macro-debugger/syntax-browser/prefs.ss index 6777899824..95754653a9 100644 --- a/collects/macro-debugger/syntax-browser/prefs.ss +++ b/collects/macro-debugger/syntax-browser/prefs.ss @@ -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))) diff --git a/collects/macro-debugger/syntax-browser/pretty-printer.ss b/collects/macro-debugger/syntax-browser/pretty-printer.ss index 8731b22819..fd975d4271 100644 --- a/collects/macro-debugger/syntax-browser/pretty-printer.ss +++ b/collects/macro-debugger/syntax-browser/pretty-printer.ss @@ -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)] diff --git a/collects/macro-debugger/syntax-browser/properties.ss b/collects/macro-debugger/syntax-browser/properties.ss index a93fd62a57..24dba8c42b 100644 --- a/collects/macro-debugger/syntax-browser/properties.ss +++ b/collects/macro-debugger/syntax-browser/properties.ss @@ -3,7 +3,8 @@ (require scheme/class scheme/gui "interfaces.ss" - "util.ss") + "util.ss" + "../util/mpi.ss") (provide properties-view% properties-snip%) diff --git a/collects/macro-debugger/syntax-browser/syntax-snip.ss b/collects/macro-debugger/syntax-browser/syntax-snip.ss index dcc59c2ae7..4ab5b17863 100644 --- a/collects/macro-debugger/syntax-browser/syntax-snip.ss +++ b/collects/macro-debugger/syntax-browser/syntax-snip.ss @@ -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 "#" line col) - "#"))) + (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 diff --git a/collects/macro-debugger/syntax-browser/util.ss b/collects/macro-debugger/syntax-browser/util.ss index 7e5e1afb24..4c587a4c2a 100644 --- a/collects/macro-debugger/syntax-browser/util.ss +++ b/collects/macro-debugger/syntax-browser/util.ss @@ -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)])) diff --git a/collects/macro-debugger/syntax-browser/widget.ss b/collects/macro-debugger/syntax-browser/widget.ss index 0ea7d7697c..a8303f0606 100644 --- a/collects/macro-debugger/syntax-browser/widget.ss +++ b/collects/macro-debugger/syntax-browser/widget.ss @@ -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 diff --git a/collects/macro-debugger/util/hiding.ss b/collects/macro-debugger/util/hiding.ss deleted file mode 100644 index 6f4ddeb20f..0000000000 --- a/collects/macro-debugger/util/hiding.ss +++ /dev/null @@ -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))))) diff --git a/collects/macro-debugger/util/mpi.ss b/collects/macro-debugger/util/mpi.ss new file mode 100644 index 0000000000..240bc53bff --- /dev/null +++ b/collects/macro-debugger/util/mpi.ss @@ -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))) diff --git a/collects/macro-debugger/view/debug-format.ss b/collects/macro-debugger/view/debug-format.ss index 4bedfc5e5e..0cdb024bee 100644 --- a/collects/macro-debugger/view/debug-format.ss +++ b/collects/macro-debugger/view/debug-format.ss @@ -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)] diff --git a/collects/macro-debugger/view/extensions.ss b/collects/macro-debugger/view/extensions.ss index 8a43414307..4a156a868a 100644 --- a/collects/macro-debugger/view/extensions.ss +++ b/collects/macro-debugger/view/extensions.ss @@ -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))))) diff --git a/collects/macro-debugger/view/frame.ss b/collects/macro-debugger/view/frame.ss index 3e37b88c51..3d5eb74a90 100644 --- a/collects/macro-debugger/view/frame.ss +++ b/collects/macro-debugger/view/frame.ss @@ -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 diff --git a/collects/macro-debugger/view/hiding-panel.ss b/collects/macro-debugger/view/hiding-panel.ss index 2b62c2b96b..002b7c192e 100644 --- a/collects/macro-debugger/view/hiding-panel.ss +++ b/collects/macro-debugger/view/hiding-panel.ss @@ -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% diff --git a/collects/macro-debugger/view/prefs.ss b/collects/macro-debugger/view/prefs.ss index 10a25b2b9c..e21cd97aa9 100644 --- a/collects/macro-debugger/view/prefs.ss +++ b/collects/macro-debugger/view/prefs.ss @@ -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=?) diff --git a/collects/macro-debugger/view/term-record.ss b/collects/macro-debugger/view/term-record.ss index 9c54325f0c..2b67632a76 100644 --- a/collects/macro-debugger/view/term-record.ss +++ b/collects/macro-debugger/view/term-record.ss @@ -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) diff --git a/collects/scribblings/reference/readtables.scrbl b/collects/scribblings/reference/readtables.scrbl index 5264ce79e8..531accf1c8 100644 --- a/collects/scribblings/reference/readtables.scrbl +++ b/collects/scribblings/reference/readtables.scrbl @@ -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} diff --git a/collects/tests/mzscheme/readtable.ss b/collects/tests/mzscheme/readtable.ss index 54e6b4b8f2..7a33812abc 100644 --- a/collects/tests/mzscheme/readtable.ss +++ b/collects/tests/mzscheme/readtable.ss @@ -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)))) diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index 8b1e350e79..1b41e75161 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -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); diff --git a/src/mzscheme/src/module.c b/src/mzscheme/src/module.c index cdadc363a5..4a6b70f248 100644 --- a/src/mzscheme/src/module.c +++ b/src/mzscheme/src/module.c @@ -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; diff --git a/src/mzscheme/src/schexpobs.h b/src/mzscheme/src/schexpobs.h index 7a51f47edd..1dc2690360 100644 --- a/src/mzscheme/src/schexpobs.h +++ b/src/mzscheme/src/schexpobs.h @@ -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 diff --git a/src/mzscheme/src/syntax.c b/src/mzscheme/src/syntax.c index baab3ccac7..0a60d7588f 100644 --- a/src/mzscheme/src/syntax.c +++ b/src/mzscheme/src/syntax.c @@ -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 *