From f9c94375e9d1a0fd3b417d251ae3213459d2b206 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Thu, 15 Nov 2007 18:37:40 +0000 Subject: [PATCH] merged changes from branches/ryanc/ms-v4 svn: r7741 original commit: 60fe499e4ee6a8a064de4ace1c2f6bfffe16e742 --- collects/macro-debugger/model/debug.ss | 2 + collects/macro-debugger/model/deriv-c.ss | 238 ++--- collects/macro-debugger/model/deriv-parser.ss | 577 ++++++------ collects/macro-debugger/model/deriv-tokens.ss | 16 +- collects/macro-debugger/model/deriv-util.ss | 422 ++------- collects/macro-debugger/model/deriv.ss | 634 +++++++------ .../macro-debugger/model/reductions-engine.ss | 335 +++++-- collects/macro-debugger/model/reductions.ss | 880 ++++++++---------- collects/macro-debugger/model/steps.ss | 5 +- collects/macro-debugger/model/stx-util.ss | 49 +- collects/macro-debugger/model/trace.ss | 9 +- collects/macro-debugger/model/yacc-ext.ss | 56 +- .../macro-debugger/model/yacc-interrupted.ss | 331 ++++--- .../syntax-browser/controller.ss | 4 +- .../syntax-browser/interfaces.ss | 9 +- .../macro-debugger/syntax-browser/text.ss | 83 +- .../macro-debugger/syntax-browser/widget.ss | 19 +- collects/macro-debugger/view/hiding-panel.ss | 28 +- collects/macro-debugger/view/stepper.ss | 25 +- 19 files changed, 1905 insertions(+), 1817 deletions(-) diff --git a/collects/macro-debugger/model/debug.ss b/collects/macro-debugger/model/debug.ss index 1e03645..0d76b39 100644 --- a/collects/macro-debugger/model/debug.ss +++ b/collects/macro-debugger/model/debug.ss @@ -3,6 +3,7 @@ (require (lib "plt-match.ss")) (require "trace.ss" "deriv-util.ss" + "deriv-find.ss" "hide.ss" "hiding-policies.ss" "deriv.ss" @@ -11,6 +12,7 @@ (provide (all-from "trace.ss") (all-from "deriv.ss") (all-from "deriv-util.ss") + (all-from "deriv-find.ss") (all-from "hiding-policies.ss") (all-from "hide.ss") (all-from "steps.ss") diff --git a/collects/macro-debugger/model/deriv-c.ss b/collects/macro-debugger/model/deriv-c.ss index e8a12d3..be85e5d 100644 --- a/collects/macro-debugger/model/deriv-c.ss +++ b/collects/macro-debugger/model/deriv-c.ss @@ -2,66 +2,103 @@ (module deriv-c mzscheme (provide (all-defined)) - ;; A Derivation is either - ;; - a PRule - ;; - (make-mrule syntax syntax Transformation Derivation) - ;; - (make-lift-deriv syntax syntax Derivation syntax Derivation) - ;; - (make-lift/let-deriv syntax syntax Derivation syntax Derivation) - (define-struct deriv (e1 e2) #f) - (define-struct (mrule deriv) (transformation next) #f) + ;; A Node(a) is: + ;; (make-node a ?a) + (define-struct node (z1 z2) #f) + + ;; A TopDeriv is one of + ;; (make-lift-deriv Deriv Stxs TopDeriv) + ;; Deriv + + ;; A Deriv is one of + ;; (make-mrule Transformation Deriv) + ;; PrimDeriv + (define-struct (deriv node) () #f) (define-struct (lift-deriv deriv) (first lift-stx second) #f) + (define-struct (mrule deriv) (transformation next) #f) + + ;; A DerivLL is one of + ;; (make-lift/let-deriv Deriv Stx Deriv) + ;; Deriv (define-struct (lift/let-deriv deriv) (first lift-stx second) #f) ;; A Transformation is - ;; (make-transformation syntax syntax (listof identifier) syntax syntax (listof LocalAction)) - ;; - resolves is the list of identifiers resolved by the macro keyword - ;; - me1 is the marked version of the input syntax - ;; - me2 is the marked version of the output syntax - (define-struct transformation (e1 e2 resolves me1 me2 locals seq) #f) + ;; (make-transformation Rs ?exn ?Stx (list-of LocalAction) ?exn ?Stx Number) + (define-struct (transformation node) (resolves ?1 me1 locals ?2 me2 seq) #f) ;; A LocalAction is one of - ;; - (make-local-expansion Syntax Syntax Syntax Syntax boolean Derivation) - ;; - (make-local-expansion/expr Syntax Syntax Syntax Syntax boolean Derivation) - ;; - (make-local-lift Syntax Identifier) - (define-struct local-expansion (e1 e2 me1 me2 for-stx? deriv) #f) - (define-struct local-expansion/expr (e1 e2 me1 me2 for-stx? opaque deriv) #f) + ;; (make-local-expansion Stx ?Stx Boolean Deriv) + ;; (make-local-expansion/expr Stx ?Stx Boolean ?Opaque Deriv) + ;; (make-local-lift Stx Identifier) + ;; (make-local-lift-end Stx) + ;; (make-local-bind BindSyntaxes) + (define-struct (local-expansion node) (me1 me2 for-stx? inner) #f) + (define-struct (local-expansion/expr node) (me1 me2 for-stx? opaque inner) #f) (define-struct local-lift (expr id) #f) (define-struct local-lift-end (decl) #f) - (define-struct local-bind (deriv) #f) + (define-struct local-bind (bindrhs) #f) - ;; A PRule is one of ... - (define-struct (prule deriv) (resolves) #f) + ;; Base = << Node(Stx) Rs ?exn >> + (define-struct (base deriv) (resolves ?1) #f) - ;; Lexical or Mapped Variable + ;; A PrimDeriv is one of + (define-struct (prule base) () #f) (define-struct (p:variable prule) () #f) - - ;; Definitions: one subterm each - (define-struct (p:define-syntaxes prule) (rhs) #f) + + ;; (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) #f) + (define-struct (p:#%module-begin prule) (pass1 pass2 ?2) #f) + + ;; (make-p:define-syntaxes DerivLL) + ;; (make-p:define-values Deriv) + (define-struct (p:define-syntaxes prule) (rhs ?2) #f) (define-struct (p:define-values prule) (rhs) #f) - - ;; Simple expressions - (define-struct (p:expression prule) (inner) #f) + + ;; (make-p:#%expression Deriv) + ;; (make-p:if Boolean Deriv Deriv Deriv) + ;; (make-p:wcm Deriv Deriv Deriv) + ;; (make-p:set! Rs Deriv) + ;; (make-p:set!-macro Rs Deriv) + (define-struct (p:#%expression prule) (inner) #f) (define-struct (p:if prule) (full? test then else) #f) (define-struct (p:wcm prule) (key mark body) #f) (define-struct (p:set! prule) (id-resolves rhs) #f) (define-struct (p:set!-macro prule) (deriv) #f) - - ;; Sequence-containing expressions + + ;; (make-p:#%app Stx LDeriv) + ;; (make-p:begin LDeriv) + ;; (make-p:begin0 Deriv LDeriv) + (define-struct (p:#%app prule) (tagged-stx lderiv) #f) (define-struct (p:begin prule) (lderiv) #f) (define-struct (p:begin0 prule) (first lderiv) #f) - (define-struct (p:#%app prule) (tagged-stx lderiv) #f) - ;; Binding expressions + ;; (make-p:lambda LambdaRenames BDeriv) + ;; (make-p:case-lambda (list-of CaseLambdaClause)) + ;; (make-p:let-values LetRenames (list-of Deriv) BDeriv) + ;; (make-p:letrec-values LetRenames (list-of Deriv) BDeriv) + ;; (make-p:letrec-syntaxes+values LSVRenames (list-of BindSyntaxes) (list-of Deriv) BDeriv) (define-struct (p:lambda prule) (renames body) #f) (define-struct (p:case-lambda prule) (renames+bodies) #f) (define-struct (p:let-values prule) (renames rhss body) #f) (define-struct (p:letrec-values prule) (renames rhss body) #f) - (define-struct (p:letrec-syntaxes+values prule) (srenames srhss vrenames vrhss body) #f) - - ;; Atomic primitives: no subterms + (define-struct (p:letrec-syntaxes+values prule) (srenames sbindrhss vrenames vrhss body) #f) + + ;; (make-p:stop ) + ;; (make-p:unknown ) + ;; (make-p:#%top Stx) + ;; (make-p:#%datum Stx) + ;; (make-p:quote ) + ;; (make-p:quote-syntax ) + ;; (make-p:require ) + ;; (make-p:require-for-syntax ) + ;; (make-p:require-for-template ) + ;; (make-p:provide ) (define-struct (p::STOP prule) () #f) - (define-struct (p:#%datum p::STOP) (tagged-stx) #f) + (define-struct (p:stop p::STOP) () #f) + (define-struct (p:unknown p::STOP) () #f) (define-struct (p:#%top p::STOP) (tagged-stx) #f) + (define-struct (p:#%datum p::STOP) (tagged-stx) #f) (define-struct (p:quote p::STOP) () #f) (define-struct (p:quote-syntax p::STOP) () #f) (define-struct (p:require p::STOP) () #f) @@ -69,97 +106,82 @@ (define-struct (p:require-for-template p::STOP) () #f) (define-struct (p:provide p::STOP) () #f) - ;; for stop expander - (define-struct (p:stop p::STOP) () #f) - ;; for early primitive errors - (define-struct (p:unknown p::STOP) () #f) - - ;; Module stuff.... hairy - (define-struct (p:module prule) (one-body-form? body) #f) - (define-struct (p:#%module-begin prule) (pass1 pass2) #f) - ;; where pass1 is a ModPass1 - ;; and pass2 is a ModPass2 - - ;; Artificial Rename - ;; FIXME: Go back and add more info later, such as rename-identity + ;;+ (make-p:rename Renames Deriv) + ;;+ (make-p:synth (list-of SynthItem) ?exn) (define-struct (p:rename prule) (renames inner) #f) + (define-struct (p:synth prule) (subterms ?2) #f) - ;; Synthetic primitive - (define-struct (p:synth prule) (subterms) #f) - ;; where subterms is list-of-Subterm - ;; A Subterm is one of - ;; - (make-s:subterm Path Derivation) - ;; - (make-s:rename Path Syntax Syntax) - (define-struct s:subterm (path deriv) #f) - (define-struct s:rename (path before after) #f) + + ;; A LDeriv is + ;; (make-lderiv ?exn (list-of Deriv)) + (define-struct (lderiv node) (?1 derivs) #f) - ;; A ListDerivation is (make-lderiv Syntaxes Syntaxes (listof Derivation)) - (define-struct lderiv (es1 es2 derivs) #f) + ;; A BDeriv is + ;; (make-bderiv (list-of BRule) (U 'list 'letrec) LDeriv) + (define-struct (bderiv node) (pass1 trans pass2) #f) - ;; A BlockDerivation is (make-bderiv syntax-list syntax-list BlockPass1 Transition LDeriv) - ;; where Transition = (union 'letrec 'list) - (define-struct bderiv (es1 es2 pass1 trans pass2) #f) - - ;; A BlockPass1 is list-of-BRule ;; A BRule is one of - ;; - (make-b:defvals BlockRename Derivation/#f) - ;; - (make-b:devstx BlockRename Derivation Derivation) - ;; - (make-b:splice BlockRename Derivation Syntaxes) - ;; - (make-b:expr BlockRename Derivation) - ;; - (make-b:begin BlockRename Derivation List-of-BRule) - ;; This last only used in macro-hiding - ;; A BlockRename is (cons syntax syntax) - ;; It always applies only to the current block element - + ;; (make-b:error exn) + ;; (make-b:expr BlockRenames Deriv) + ;; (make-b:splice BlockRenames Deriv ?exn Stxs ?exn) + ;; (make-b:defvals BlockRenames Deriv ?exn) + ;; (make-b:defstx BlockRenames Deriv ?exn BindSyntaxes) + ;;i (make-b:begin BlockRenames Deriv (list-of Deriv)) + (define-struct b:error (?1) #f) (define-struct brule (renames) #f) - (define-struct (b:defvals brule) (head) #f) - (define-struct (b:defstx brule) (deriv rhs) #f) - (define-struct (b:splice brule) (head tail) #f) (define-struct (b:expr brule) (head) #f) - (define-struct (b:begin brule) (head inner) #f) + (define-struct (b:splice brule) (head ?1 tail ?2) #f) + (define-struct (b:defvals brule) (head ?1) #f) + (define-struct (b:defstx brule) (head ?1 bindrhs) #f) +;;(define-struct (b:begin brule) (head inner) #f) + + ;; A BindSyntaxes is + ;; (make-bind-syntaxes DerivLL ?exn) + (define-struct bind-syntaxes (rhs ?1) #f) + + + ;; A CaseLambdaClause is + ;; (make-clc ?exn CaseLambdaRename BDeriv) + (define-struct clc (?1 renames body) #f) + + ;; A BlockRename is (cons Stx Stx) + + ;; A ModPass1 is (list-of ModRule1) + ;; A ModPass2 is (list-of ModRule2) - ;; A ModPass1 is a list of ModRule1 ;; A ModRule1 is one of - ;; - (make-mod:prim Derivation ModPrim) - ;; - (make-mod:splice Derivation tail) - ;; - (make-mod:lift Derivation tail) - ;; - (make-mod:begin Derivation (list-of ModRule1)) - - ;; A ModPrim is a PRule in: - ;; - (make-p:define-values syntax syntax () #f) - ;; - (make-p:define-syntaxes syntax syntax () Derivation) - ;; - (make-p:require syntax syntax ()) - ;; - (make-p:require-for-syntax syntax syntax ()) - ;; - (make-p:require-for-template syntax syntax ()) - ;; - (make-p:provide syntax syntax ()) - ;; - #f - - ;; A ModPass2 is a list of ModRule2 + ;; (make-mod:prim Deriv ModPrim) + ;; (make-mod:splice Deriv ?exn Stxs) + ;; (make-mod:lift Deriv Stxs) + ;; (make-mod:lift-end Stxs) ;; A ModRule2 is one of - ;; - (make-mod:skip) - ;; - (make-mod:cons Derivation) - ;; - (make-mod:lift Derivation syntaxes) - + ;; (make-mod:skip) + ;; (make-mod:cons Deriv) + ;; (make-mod:lift Deriv Stxs) (define-struct modrule () #f) (define-struct (mod:cons modrule) (head) #f) (define-struct (mod:prim modrule) (head prim) #f) (define-struct (mod:skip modrule) () #f) - (define-struct (mod:splice modrule) (head tail) #f) + (define-struct (mod:splice modrule) (head ?1 tail) #f) (define-struct (mod:lift modrule) (head tail) #f) (define-struct (mod:lift-end modrule) (tail) #f) - (define-struct (mod:begin modrule) (head inner) #f) - ;; Handling Syntax Errors - ;; ---------------------- + ;; A ModPrim is a PRule in: + ;; (make-p:define-values #f) + ;; (make-p:define-syntaxes Deriv) + ;; (make-p:require ) + ;; (make-p:require-for-syntax ) + ;; (make-p:require-for-template ) + ;; (make-p:provide ) + ;; #f + + ;; A SynthItem is one of + ;; - (make-s:subterm Path Deriv) + ;; - (make-s:rename Path Stx Stx) + (define-struct subitem () #f) + (define-struct (s:subterm subitem) (path deriv) #f) + (define-struct (s:rename subitem) (path before after) #f) - ;; An interrupted node is (make-interrupted-wrap symbol node) - ;; where node is one of Derivation, ListDerivation, BlockDerivation, - ;; PRule, MRule, BRule, or ModRule - (define-struct interrupted-wrap (tag inner) #f) - ;; An error-wrapped node is (make-error-wrap exception symbol node) - ;; where node is one of PRule, MRule, BRule, or ModRule - (define-struct error-wrap (exn tag inner) #f) - ) diff --git a/collects/macro-debugger/model/deriv-parser.ss b/collects/macro-debugger/model/deriv-parser.ss index 3019dcc..e60992f 100644 --- a/collects/macro-debugger/model/deriv-parser.ss +++ b/collects/macro-debugger/model/deriv-parser.ss @@ -6,12 +6,14 @@ "deriv-util.ss" "deriv-tokens.ss") (provide parse-derivation) - + (define (deriv-error ok? name value start end) (if ok? - (error 'derivation-parser "error on token #~a: <~s, ~s>" start name value) + (error 'derivation-parser + "error on token #~a: <~s, ~s>" + start name value) (error 'derivation-parser "bad token #~a" start))) - + ;; PARSER (define (parse-derivation x) @@ -23,7 +25,22 @@ (let ([seq (current-sequence-number)]) (current-sequence-number (add1 seq)) seq)) + + (define-struct (exn:eval exn) (deriv)) + (define empty-cms + (call-with-continuation-prompt (lambda () (current-continuation-marks)))) + (define (create-eval-exn deriv) + (make-exn:eval "exception during evaluation" + empty-cms + deriv)) + (define-production-splitter production/I values values) + + (define-syntax (productions/I stx) + (syntax-case stx () + [(productions/I def ...) + #'(begin (production/I def) ...)])) + (define parse-derivation* (parser (options (start Expansion) @@ -31,29 +48,25 @@ (tokens basic-tokens prim-tokens renames-tokens) (end EOF) (error deriv-error) - #;(debug "debug-parser.txt")) + #;(debug "DEBUG-PARSER.txt")) - ;; Required (non-hygienically) by productions/I - (productions - #;(Error [(syntax-error) $1]) - (NoError [() #f])) - ;; tokens - (skipped-token-values visit resolve next next-group return - enter-macro macro-pre-transform macro-post-transform exit-macro - enter-prim exit-prim - enter-block block->list block->letrec splice - enter-list exit-list - enter-check exit-check - local-post exit-local exit-local/expr - phase-up module-body - renames-lambda - renames-case-lambda - renames-let - renames-letrec-syntaxes - renames-block - IMPOSSIBLE) - + (skipped-token-values + visit resolve next next-group return + enter-macro macro-pre-transform macro-post-transform exit-macro + enter-prim exit-prim + enter-block block->list block->letrec splice + enter-list exit-list + enter-check exit-check + local-post exit-local exit-local/expr + phase-up module-body + renames-lambda + renames-case-lambda + renames-let + renames-letrec-syntaxes + renames-block + IMPOSSIBLE) + ;; Entry point (productions (Expansion @@ -62,90 +75,92 @@ (productions/I - ;; Expansion of an expression - ;; EE Answer = Derivation (I) - (EE - (#:no-wrap) - [(visit (? PrimStep 'prim) return) - $2] - [(visit (? TaggedPrimStep 'prim) return) - ($2 $1)] - [(visit VariableStep return) - ($2 $1 $3)] - [((? EE/Macro)) - $1]) - (EE/Macro - [(visit (? MacroStep 'macro) (? EE 'next)) - (make-mrule $1 (and (deriv? $3) (deriv-e2 $3)) $2 $3)]) - ;; Expand/Lifts - ;; Expand/Lifts Answer = Derivation (I) (EE/Lifts (#:no-wrap) [((? EE)) $1] [((? EE/Lifts+)) $1]) - (EE/Lifts+ - [(EE lift-loop (? EE/Lifts)) - (let ([initial (deriv-e1 $1)] - [final (and (deriv? $3) (deriv-e2 $3))]) - (make-lift-deriv initial final $1 $2 $3))]) + (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 - ;; Expand/LetLifts Answer = Derivation (I) ;; Used for expand_lift_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 (deriv-e1 $1)] - [final (and (deriv? $3) (deriv-e2 $3))]) - (make-lift/let-deriv initial final $1 $2 $3))]) - + (let ([initial (wderiv-e1 $1)] + [final (wderiv-e2 $3)]) + (make lift/let-deriv initial final $1 $2 $3))]) + ;; Evaluation + ;; Answer = ?exn (Eval (#:no-wrap) [() #f] - [(start (? EE) (? Eval)) #f] - [(start (? CheckImmediateMacro) (? Eval)) #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 Answer = Derivation (I) (CheckImmediateMacro (#:no-wrap) [(enter-check (? CheckImmediateMacro/Inner) exit-check) - ($2 $1 $3 (lambda (ce1 ce2) (make-p:stop ce1 ce2 null)))]) + ($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 'macro) return (? CheckImmediateMacro/Inner 'next)) + [(visit (? MacroStep) return (? CheckImmediateMacro/Inner)) (let ([next ($4 $3 e2 k)]) - (make-mrule $1 (and (deriv? next) (deriv-e2 next)) $2 next))]) + (make mrule $1 (and next (wderiv-e2 next)) $2 next))]) ;; Expansion of multiple expressions, next-separated - ;; NextEEs Answer = (listof Derivation) (NextEEs (#:no-wrap) (#:skipped null) [() null] - [(next (? EE 'first) (? NextEEs 'rest)) (cons $2 $3)]) + [(next (? EE) (? NextEEs)) (cons $2 $3)]) ;; Keyword resolution - ;; Resolves Answer = (listof identifier) - (Resolves [() null] - [(resolve Resolves) (cons $1 $2)]) - + (Resolves + (#:no-wrap) + [() null] + [(resolve Resolves) (cons $1 $2)]) + ;; Single macro step (may contain local-expand calls) ;; MacroStep Answer = Transformation (I,E) - (MacroStep - [(Resolves enter-macro - (! 'bad-transformer) - macro-pre-transform (? LocalActions 'locals) (! 'transform) macro-post-transform - exit-macro) - (make-transformation $2 $8 $1 $4 $7 $5 (new-sequence-number))]) + (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))]) ;; Local actions taken by macro ;; LocalAction Answer = (list-of LocalAction) @@ -159,66 +174,63 @@ (LocalAction (#:no-wrap) [(enter-local local-pre start (? EE) local-post exit-local) - (make-local-expansion $1 $6 $2 $5 #f $4)] + (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)] + (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)] + (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)] + (make local-expansion/expr $1 (car $7) $3 $6 #t (cdr $7) $5)] [(lift) - (make-local-lift (cdr $1) (car $1))] + (make local-lift (cdr $1) (car $1))] [(lift-statement) - (make-local-lift-end $1)] - [(phase-up (? EE/LetLifts)) - (make-local-bind $2)]) + (make local-lift-end $1)] + [((? BindSyntaxes)) + (make local-bind $1)]) (NotReallyLocalAction (#:no-wrap) ;; called 'expand' (not 'local-expand') within transformer [(start (? EE)) - (make-local-expansion (lift/deriv-e1 $2) - (lift/deriv-e2 $2) - (lift/deriv-e1 $2) - (lift/deriv-e2 $2) + (make local-expansion (wderiv-e1 $2) + (wderiv-e2 $2) + (wderiv-e1 $2) + (wderiv-e2 $2) #f $2)]) - - ;; Multiple calls to local-expand - ;; EEs Answer = (listof Derivation) - (EEs - (#:skipped null) - (#:no-wrap) - [() null] - [((? EE 'first) (? EEs 'rest)) (cons $1 $2)]) - - ;; Primitive syntax step - ;; PrimStep Answer = PRule - (PrimStep - (#:no-wrap) - [(Resolves NoError enter-prim (? Prim) exit-prim) - ($4 $3 $5 $1)]) - - (VariableStep - (#:no-wrap) - (#:args e1 e2) - [(Resolves variable) - (make-p:variable e1 e2 $1)]) - - ;; Tagged Primitive syntax - ;; TaggedPrimStep Answer = syntax -> PRule - (TaggedPrimStep - (#:no-wrap) - (#:args orig-stx) - [(Resolves ! IMPOSSIBLE) - (make-p:unknown orig-stx #f $1)] - [(Resolves NoError enter-prim ! IMPOSSIBLE) - (make-p:unknown orig-stx #f $1)] - [(Resolves NoError enter-prim (? TaggedPrim) exit-prim) - ($4 orig-stx $5 $1 $3)]) ;; Primitive - ;; Prim Answer = syntax syntax (listof identifier) -> PRule + (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) + [(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)]) + (Prim (#:args e1 e2 rs) (#:no-wrap) @@ -245,254 +257,269 @@ [((? PrimRequireForSyntax)) ($1 e1 e2 rs)] [((? PrimRequireForTemplate)) ($1 e1 e2 rs)] [((? PrimProvide)) ($1 e1 e2 rs)]) - - ;; Tagged Primitive - ;; TaggedPrim Answer = syntax syntax (list-of identifier) syntax -> PRule - (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)]) - ;; Modules (PrimModule (#:args e1 e2 rs) - ;; Multiple forms after language - ;; #%module-begin tagging done automatically - [(prim-module ! (? Eval) (? EE 'body)) - (make-p:module e1 e2 rs #f $4)] - - ;; One form after language ... macro that expands into #%module-begin - [(prim-module NoError next - enter-check (? CheckImmediateMacro/Inner) exit-check - (! 'module-begin) next (? EE)) - (make-p:module e1 e2 rs - #t - ($5 $4 - (and (deriv? $9) (deriv-e2 $9)) - (lambda (ce1 ce2) $9)))]) - + (#: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#%ModuleBegin (#:args e1 e2 rs) - [(prim-#%module-begin (! 'malformed) - (? ModulePass1 'pass1) next-group - (? ModulePass2 'pass2) - (! 'provides)) - (make-p:#%module-begin e1 e2 rs $3 $5)]) + (#:wrap) + [(prim-#%module-begin ! (? ModulePass1) next-group (? ModulePass2) !) + (make p:#%module-begin e1 e2 rs $2 $3 $5 $6)]) (ModulePass1 - (#:skipped null) (#:no-wrap) + (#:skipped null) [() null] [(next (? ModulePass1-Part) (? ModulePass1)) (cons $2 $3)] [(module-lift-end-loop (? ModulePass1)) - (cons (make-mod:lift-end $1) $2)]) + (cons (make mod:lift-end $1) $2)]) (ModulePass1-Part - (#:no-wrap) + (#:wrap) [((? EE) (? ModulePass1/Prim)) - (make-mod:prim $1 $2)] - [(EE NoError module-lift-loop) - (make-mod:lift $1 $2)] + (make mod:prim $1 $2)] [(EE ! splice) - (make-mod:splice $1 $3)]) + (make mod:splice $1 $2 $3)] + [(EE module-lift-loop) + (make mod:lift $1 $2)]) (ModulePass1/Prim + (#:wrap) [(enter-prim prim-define-values ! exit-prim) - (make-p:define-values $1 $4 null #f)] - [(enter-prim prim-define-syntaxes ! phase-up (? EE/LetLifts) (? Eval) exit-prim) - (make-p:define-syntaxes $1 $7 null $5)] - [(enter-prim prim-require ! (? Eval) exit-prim) - (make-p:require $1 $5 null)] - [(enter-prim prim-require-for-syntax ! (? Eval) exit-prim) - (make-p:require-for-syntax $1 $5 null)] - [(enter-prim prim-require-for-template ! (? Eval) exit-prim) - (make-p:require-for-template $1 $5 null)] + (make p:define-values $1 $4 null $3 #f)] + [(enter-prim prim-define-syntaxes ! + phase-up (? EE/LetLifts) (? Eval) exit-prim) + (make p:define-syntaxes $1 $7 null $3 $5 $6)] + [(enter-prim prim-require (? Eval) exit-prim) + (make p:require $1 $4 null $3)] + [(enter-prim prim-require-for-syntax (? Eval) exit-prim) + (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)] + (make p:provide $1 $4 null $3)] [() #f]) (ModulePass2 - (#:skipped null) (#:no-wrap) + (#:skipped null) [() null] [(next (? ModulePass2-Part) (? ModulePass2)) (cons $2 $3)] [(module-lift-end-loop (? ModulePass2)) - (cons (make-mod:lift-end $1) $2)]) + (cons (make mod:lift-end $1) $2)]) (ModulePass2-Part (#:no-wrap) ;; not normal; already handled [() - (make-mod:skip)] + (make mod:skip)] ;; normal: expand completely [((? EE)) - (make-mod:cons $1)] + (make mod:cons $1)] ;; catch lifts [(EE module-lift-loop) - (make-mod:lift $1 $2)]) + (make mod:lift $1 $2)]) ;; Definitions (PrimDefineSyntaxes (#:args e1 e2 rs) + (#:wrap) [(prim-define-syntaxes ! (? EE/LetLifts) (? Eval)) - (make-p:define-syntaxes e1 e2 rs $3)]) - + (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 $3)]) - + (make p:define-values e1 e2 rs $2 $3)]) + ;; Simple expressions (PrimExpression (#:args e1 e2 rs) - [(prim-expression ! (? EE 'inner)) - (make-p:expression e1 e2 rs $3)]) + (#:wrap) + [(prim-expression ! (? EE)) + (make p:#%expression e1 e2 rs $2 $3)]) (PrimIf (#:args e1 e2 rs) - [(prim-if ! (? EE 'test) next (? EE 'then) next (? EE 'else)) - (make-p:if e1 e2 rs #t $3 $5 $7)] - [(prim-if NoError next-group (? EE 'test) next (? EE 'then)) - (make-p:if e1 e2 rs #f $4 $6 #f)]) - + (#: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)]) + (PrimWCM (#:args e1 e2 rs) - [(prim-wcm ! (? EE 'key) next (? EE 'mark) next (? EE 'body)) - (make-p:wcm e1 e2 rs $3 $5 $7)]) - + (#: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 $3)]) - + (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 $4 $6)]) - + (make p:begin0 e1 e2 rs $2 $4 $6)]) + (Prim#%App (#:args e1 e2 rs tagged-stx) + (#:wrap) [(prim-#%app !) - (make-p:#%app e1 e2 rs tagged-stx (make-lderiv null null null))] - [(prim-#%app NoError (? EL)) - (make-p:#%app e1 e2 rs tagged-stx $3)]) - + (make p:#%app e1 e2 rs $2 tagged-stx (make lderiv null null #f null))] + [(prim-#%app (? EL)) + (make p:#%app e1 e2 rs #f tagged-stx $2)]) + ;; Binding expressions (PrimLambda (#:args e1 e2 rs) + (#:wrap) [(prim-lambda ! renames-lambda (? EB)) - (make-p:lambda e1 e2 rs $3 $4)]) - + (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 $3)]) - + (make p:case-lambda e1 e2 rs $2 $3)]) + (NextCaseLambdaClauses (#:skipped null) - [(next ! renames-case-lambda (? EB 'first) (? NextCaseLambdaClauses 'rest)) - (cons (cons $3 $4) $5)] + (#: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) - [(prim-let-values ! renames-let (? NextEEs 'rhss) next-group (? EB 'body)) - (make-p:let-values e1 e2 rs $3 $4 $6)]) - + (#: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 ! (? EE)) - (let ([next-e1 (lift/deriv-e1 $3)]) - (make-mrule e1 e2 (make-transformation e1 next-e1 rs e1 next-e1 null (new-sequence-number)) $3))] + [(prim-let*-values !!) + (let ([tx (make transformation e1 #f rs $2 + #f null #f #f (new-sequence-number))]) + (make mrule e1 e2 tx #f))] + [(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))]) + (make mrule e1 e2 tx $2))] ;; No bindings... model as "let" - [(prim-let*-values NoError renames-let (? NextEEs 'rhss) next-group (? EB 'body)) - (make-p:let-values e1 e2 rs $3 $4 $6)]) + [(prim-let*-values renames-let (? NextEEs) next-group (? EB)) + (make p:let-values e1 e2 rs #f $2 $3 $5)]) (PrimLetrecValues (#:args e1 e2 rs) - [(prim-letrec-values ! renames-let (? NextEEs 'rhss) next-group (? EB 'body)) - (make-p:letrec-values e1 e2 rs $3 $4 $6)]) - + (#: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) - [(prim-letrec-syntaxes+values (! 'bad-syntax) renames-letrec-syntaxes - (? NextBindSyntaxess 'srhss) next-group (? EB 'body)) - (make-p:letrec-syntaxes+values e1 e2 rs $3 $4 #f null $6)] - [(prim-letrec-syntaxes+values NoError renames-letrec-syntaxes + (#: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)] + [(prim-letrec-syntaxes+values renames-letrec-syntaxes NextBindSyntaxess next-group - prim-letrec-values (! 'impossible?) - renames-let (? NextEEs 'vrhss) next-group (? EB 'body)) - (make-p:letrec-syntaxes+values e1 e2 rs $3 $4 $8 $9 $11)]) - + prim-letrec-values + renames-let (? NextEEs) next-group (? EB)) + (make p:letrec-syntaxes+values e1 e2 rs #f $2 $3 $6 $7 $9)]) + ;; Atomic expressions (Prim#%Datum (#:args e1 e2 rs tagged-stx) - [(prim-#%datum !) (make-p:#%datum e1 e2 rs tagged-stx)]) + (#:wrap) + [(prim-#%datum !) (make p:#%datum e1 e2 rs $2 tagged-stx)]) (Prim#%Top (#:args e1 e2 rs tagged-stx) - [(prim-#%top !) (make-p:#%top e1 e2 rs tagged-stx)]) + (#:wrap) + [(prim-#%top !) (make p:#%top e1 e2 rs $2 tagged-stx)]) (PrimSTOP (#:args e1 e2 rs) - [(prim-stop !) (make-p:stop e1 e2 rs)]) - + (#:wrap) + [(prim-stop !) (make p:stop e1 e2 rs $2)]) + (PrimQuote (#:args e1 e2 rs) - [(prim-quote !) (make-p:quote e1 e2 rs)]) - + (#:wrap) + [(prim-quote !) (make p:quote e1 e2 rs $2)]) + (PrimQuoteSyntax (#:args e1 e2 rs) - [(prim-quote-syntax !) (make-p:quote-syntax e1 e2 rs)]) - + (#:wrap) + [(prim-quote-syntax !) (make p:quote-syntax e1 e2 rs $2)]) + (PrimRequire (#:args e1 e2 rs) - [(prim-require ! (? Eval)) - (make-p:require e1 e2 rs)]) - + (#:wrap) + [(prim-require (? Eval)) + (make p:require e1 e2 rs $2)]) + (PrimRequireForSyntax (#:args e1 e2 rs) - [(prim-require-for-syntax ! (? Eval)) - (make-p:require-for-syntax e1 e2 rs)]) - + (#:wrap) + [(prim-require-for-syntax (? Eval)) + (make p:require-for-syntax e1 e2 rs $2)]) + (PrimRequireForTemplate (#:args e1 e2 rs) - [(prim-require-for-template ! (? Eval)) - (make-p:require-for-template e1 e2 rs)]) - + (#:wrap) + [(prim-require-for-template (? Eval)) + (make p:require-for-template e1 e2 rs $2)]) + (PrimProvide (#:args e1 e2 rs) - [(prim-provide !) (make-p:provide 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 $3 $5)] - [(prim-set! NoError (? MacroStep 'macro) (? EE 'continue)) - (make-p:set!-macro e1 e2 rs (make-mrule e1 (and (deriv? $4) (deriv-e2 $4)) $3 $4))]) - + (make p:set! e1 e2 rs $2 $3 $5)] + [(prim-set! (? MacroStep) (? EE)) + (make p:set!-macro e1 e2 rs #f + (make mrule e1 (and $3 (wderiv-e2 $3)) $2 $3))]) + ;; Blocks ;; EB Answer = BlockDerivation - (EB - [(enter-block (? BlockPass1 'pass1) block->list (? EL 'pass2)) - (make-bderiv $1 - (and (lderiv? $4) (lderiv-es2 $4)) - $2 - 'list - $4)] - [(enter-block BlockPass1 block->letrec (? EL 'pass2)) - (make-bderiv $1 - (and (lderiv? $4) (lderiv-es2 $4)) - $2 - 'letrec - $4)]) + (EB + (#:wrap) + [(enter-block (? BlockPass1) block->list (? EL)) + (make bderiv $1 (and $4 (wlderiv-es2 $4)) + $2 'list $4)] + [(enter-block BlockPass1 block->letrec (? EL)) + (make bderiv $1 (and $4 (wlderiv-es2 $4)) + $2 'letrec $4)]) ;; BlockPass1 Answer = (list-of BRule) (BlockPass1 @@ -504,42 +531,50 @@ ;; BRule Answer = BRule (BRule - [(next ! IMPOSSIBLE) - #f] - [(next NoError renames-block (? CheckImmediateMacro 'check)) - (make-b:expr $3 $4)] - [(next NoError renames-block CheckImmediateMacro prim-begin ! splice !) - (make-b:splice $3 $4 $7)] - [(next NoError renames-block CheckImmediateMacro prim-define-values !) - (make-b:defvals $3 $4)] - [(next NoError renames-block CheckImmediateMacro - prim-define-syntaxes (? BindSyntaxes 'bind)) - (make-b:defstx $3 $4 $6)]) + (#:wrap) + [(next !!) + (make b:error $2)] + [(next renames-block (? CheckImmediateMacro)) + (make b:expr $2 $3)] + [(next renames-block CheckImmediateMacro prim-begin ! splice !) + (make b:splice $2 $3 $5 $6 $7)] + [(next renames-block CheckImmediateMacro prim-define-values !) + (make b:defvals $2 $3 $5)] + [(next renames-block CheckImmediateMacro + prim-define-syntaxes ! (? BindSyntaxes)) + (make b:defstx $2 $3 $5 $6)]) ;; BindSyntaxes Answer = Derivation (BindSyntaxes - [(phase-up (? EE/LetLifts) ! (? Eval)) $2]) - + (#:wrap) + [(phase-up (? EE/LetLifts) (? Eval)) + (make bind-syntaxes $2 $3)]) + ;; NextBindSyntaxess Answer = (list-of Derivation) (NextBindSyntaxess - (#:skipped null) (#:no-wrap) + (#:skipped null) [() null] - [(next (? BindSyntaxes 'first) (? NextBindSyntaxess 'rest)) (cons $2 $3)]) - + [(next (? BindSyntaxes) (? NextBindSyntaxess)) (cons $2 $3)]) + ;; Lists ;; EL Answer = ListDerivation (EL + (#:wrap) (#:skipped #f) - [(enter-list ! (? EL*) exit-list) (make-lderiv $1 $4 $3)]) + [(enter-list ! (? EL*) exit-list) + ;; FIXME: Workaround for bug in events + (if (null? $3) + (make lderiv null null $2 $3) + (make lderiv $1 $4 $2 $3))]) ;; EL* Answer = (listof Derivation) (EL* (#:no-wrap) (#:skipped null) [() null] - [(next (? EE 'first) (? EL* 'rest)) (cons $2 $3)]) - + [(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 cc5fa2f..7b34f08 100644 --- a/collects/macro-debugger/model/deriv-tokens.ss +++ b/collects/macro-debugger/model/deriv-tokens.ss @@ -43,12 +43,12 @@ enter-local/expr ; syntax exit-local/expr ; (cons syntax expanded-expression) - + variable ; (cons identifier identifier) IMPOSSIBLE ; useful for error-handling clauses that have no NoError counterpart )) - + (define-tokens renames-tokens (renames-lambda ; (cons syntax syntax) renames-case-lambda ; (cons syntax syntax) @@ -56,7 +56,9 @@ renames-letrec-syntaxes ; (cons (listof syntax) (cons (listof syntax) syntax)) renames-block ; (cons syntax syntax) ... different, contains both pre+post )) - (define-empty-tokens prim-tokens + + ;; Empty tokens + (define-tokens prim-tokens (prim-module prim-#%module-begin prim-define-syntaxes prim-define-values prim-if prim-wcm prim-begin prim-begin0 prim-#%app prim-lambda @@ -67,9 +69,9 @@ prim-set! prim-expression )) - + ;; ** Signals to tokens - + (define signal-mapping `((EOF . EOF) (error . ,token-syntax-error) @@ -141,7 +143,7 @@ (140 . ,token-exit-local/expr) (141 . ,token-start) )) - + (define (tokenize sig-n val pos) (let ([p (assv sig-n signal-mapping)]) (if (pair? p) @@ -154,5 +156,5 @@ (define (signal->symbol sig-n) (cdr (assv sig-n signal-mapping))) - + ) diff --git a/collects/macro-debugger/model/deriv-util.ss b/collects/macro-debugger/model/deriv-util.ss index 95cea98..d839d43 100644 --- a/collects/macro-debugger/model/deriv-util.ss +++ b/collects/macro-debugger/model/deriv-util.ss @@ -3,360 +3,98 @@ (require "deriv.ss" (lib "list.ss") (lib "plt-match.ss")) - (provide IntW - ErrW - AnyQ - IntQ - + (require-for-syntax (lib "scheme/private/struct-info.ss")) + + (provide make + Wrap - lift/wrap - rewrap - rewrap/nt - outer-rewrap - lift/deriv-e1 - lift/deriv-e2 - lift/lderiv-es1 - lift/lderiv-es2 - wrapped? + + ok-node? + interrupted-node? - find-derivs - find-deriv - find-derivs/syntax - extract-all-fresh-names - flatten-identifiers) + wderiv-e1 + wderiv-e2 + wlderiv-es1 + wlderiv-es2 + wbderiv-es1 + wbderiv-es2 - ;; IntW - ;; Matches only interrupted wraps - (define-match-expander IntW - (syntax-rules () - [(IntW S (var ...)) - (struct interrupted-wrap (_ (struct S (var ...))))] - [(IntW S (var ...) tag) - (struct interrupted-wrap (tag (struct S (var ...))))])) - - ;; ErrW - ;; Matches only error wraps - (define-match-expander ErrW - (syntax-rules () - [(ErrW S (var ...)) - (struct error-wrap (_ _ (struct S (var ...))))] - [(ErrW S (var ...) exn) - (struct error-wrap (exn _ (struct S (var ...))))] - [(ErrW S (var ...) tag exn) - (struct error-wrap (exn tag (struct S (var ...))))])) + wderivlist-es2) - ;; AnyQ matcher + ;; Wrap matcher ;; Matches unwrapped, interrupted wrapped, or error wrapped - (define-match-expander AnyQ - (syntax-rules () - [(AnyQ S (var ...)) - (app unwrap (struct S (var ...)))] - [(AnyQ S (var ...) exni) - (and (app unwrap (struct S (var ...))) - (app extract-exni exni))])) - - ;; IntQ - ;; Matches interrupted wraps and unwrapped structs - (define-match-expander IntQ - (syntax-rules () - [(IntQ S (var ...)) - (? not-error-wrap? (app unwrap (struct S (var ...))))] - [(IntQ S (var ...) tag) - (? not-error-wrap? - (app unwrap (struct S (var ...))) - (app extract-tag tag))])) - (define-match-expander Wrap - (syntax-rules () - [(Wrap x) - (app unwrap x)])) + (lambda (stx) + (syntax-case stx () + [(Wrap S (var ...)) + (syntax/loc stx (struct S (var ...)))]))) + + ;; ---- - (define (unwrap x) - (match x - [(struct interrupted-wrap (tag inner)) - inner] - [(struct error-wrap (exn tag inner)) - inner] - [else x])) + (define (check sym pred type x) + (unless (pred x) + (raise-type-error sym type x))) - (define (extract-exni x) - (match x - [(struct interrupted-wrap (tag inner)) - (cons #f tag)] - [(struct error-wrap (exn tag inner)) - (cons exn tag)] - [else #f])) - - (define (extract-tag x) - (match x - [(struct interrupted-wrap (tag inner)) - tag] - [(struct error-wrap (exn tag inner)) - tag] - [else #f])) - - (define (not-error-wrap? x) - (not (error-wrap? x))) - - ;; lift/wrap : ('a -> 'b) boolean -> Wrap('a) -> Wrap('b) - (define (lift/wrap f preserve-tag?) - (lambda (x) - (match x - [(struct interrupted-wrap (tag inner)) - (make-interrupted-wrap (and preserve-tag? tag) (f inner))] - [(struct error-wrap (exn tag inner)) - (make-error-wrap exn (and preserve-tag? tag) (f inner))] - [x - (f x)]))) - - ;; rewrap : Wrap('a) 'b -> Wrap('b) - (define (rewrap x y) - (if (wrapped? y) - y - ((lift/wrap (lambda (x) y) #t) x))) + (define (ok-node? x) + (check 'ok-node? node? "node" x) + (and (node-z1 x) #t)) + (define (interrupted-node? x) + (check 'interrupted-node? node? "node" x) + (not (node-z2 x))) - ;; rewrap/nt : Wrap('a) 'b -> Wrap('b) - (define (rewrap/nt x y) - (if (wrapped? y) - y - ((lift/wrap (lambda (x) y) #f) x))) - - (define (outer-rewrap x y) - (if (and (wrapped? x) (not (wrapped? y))) - (make-interrupted-wrap #f y) - y)) - (define (lift/deriv-e1 x) - (match x - [(AnyQ deriv (e1 _)) e1])) - - (define (lift/deriv-e2 x) - (match x - [(AnyQ deriv (_ e2)) e2])) - - (define (lift/lderiv-es1 x) - (match x - [(AnyQ lderiv (es1 es2 _)) es1])) + (define (wderiv-e1 x) + (check 'wderiv-e1 deriv? "deriv" x) + (node-z1 x)) + (define (wderiv-e2 x) + (check 'wderiv-e2 deriv? "deriv" x) + (node-z2 x)) - (define (lift/lderiv-es2 x) - (match x - [(AnyQ lderiv (es1 es2 _)) es2])) + (define (wlderiv-es1 x) + (check 'wlderiv-es1 lderiv? "lderiv" x) + (node-z1 x)) + (define (wlderiv-es2 x) + (check 'wlderiv-es2 lderiv? "lderiv" x) + (node-z2 x)) - (define (wrapped? x) - (or (interrupted-wrap? x) - (error-wrap? x))) + (define (wbderiv-es1 x) + (check 'wbderiv-es1 bderiv? "bderiv" x) + (node-z1 x)) + (define (wbderiv-es2 x) + (check 'wbderiv-es2 bderiv? "bderiv" x)) - ;; Utilities for finding subderivations + ;; wderivlist-es2 : (list-of WDeriv) -> (list-of Stx)/#f + (define (wderivlist-es2 xs) + (let ([es2 (map wderiv-e2 xs)]) + (and (andmap syntax? es2) es2))) - ;; find-derivs : (deriv -> boolean) (deriv -> boolean) deriv -> (list-of deriv) - (define (find-derivs pred stop-short d) - (let ([stop (lambda (x) (or (pred x) (stop-short x)))]) - (find-deriv/unit+join+zero pred stop d list append null))) - - ;; 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/ec return (find-deriv/unit+join+zero pred stop d return (lambda _ #f) #f)))) - - ;; find-deriv/unit+join+zero - ;; Parameterized over monad operations for combining the results - ;; For example, collects the results into a list - (define (find-deriv/unit+join+zero pred stop-short d unit join zero) - (define (loop d) - (if (pred d) - (join (unit d) (loop-inner d)) - (loop-inner d))) - (define (loop-inner d) - (match d - [(? stop-short d) zero] - [(AnyQ mrule (_ _ tx next)) - (join (loop tx) (loop next))] - [(AnyQ lift-deriv (_ _ first lift second)) - (join (loop first) (loop second))] - [(AnyQ transformation (_ _ _ _ _ locals _)) - (loops locals)] - [(struct local-expansion (_ _ _ _ _ deriv)) - (loop deriv)] - [(struct local-expansion/expr (_ _ _ _ _ _ deriv)) - (loop deriv)] - [(struct local-bind (deriv)) - (loop deriv)] - [(AnyQ p:define-syntaxes (_ _ _ rhs)) - (loop rhs)] - [(AnyQ p:define-values (_ _ _ rhs)) - (loop rhs)] - [(AnyQ p:expression (_ _ _ inner)) - (loop inner)] - [(AnyQ p:if (_ _ _ _ test then else)) - (join (loop test) (loop then) (loop else))] - [(AnyQ p:wcm (_ _ _ key value body)) - (join (loop key) (loop value) (loop body))] - [(AnyQ p:set! (_ _ _ _ rhs)) - (loop rhs)] - [(AnyQ p:set!-macro (_ _ _ deriv)) - (loop deriv)] - [(AnyQ p:begin (_ _ _ lderiv)) - (loop lderiv)] - [(AnyQ p:begin0 (_ _ _ first lderiv)) - (join (loop first) (loop lderiv))] - [(AnyQ p:#%app (_ _ _ _ lderiv)) - (loop lderiv)] - [(AnyQ p:lambda (_ _ _ _ body)) - (loop body)] - [(AnyQ p:case-lambda (_ _ _ rbs)) - (apply join (map loop (map cdr (or rbs null))))] - [(AnyQ p:let-values (_ _ _ _ rhss body)) - (join (loops rhss) (loop body))] - [(AnyQ p:letrec-values (_ _ _ _ rhss body)) - (join (loops rhss) (loop body))] - [(AnyQ p:letrec-syntaxes+values (_ _ _ _ srhss _ vrhss body)) - (join (loops srhss) (loops vrhss) (loop body))] - [(AnyQ p:module (_ _ _ _ body)) - (loop body)] - [(AnyQ p:#%module-begin (_ _ _ pass1 pass2)) - (join (loops pass1) (loops pass2))] - [(AnyQ p:rename (_ _ _ _ inner)) - (loop inner)] - [(AnyQ p:synth (_ _ _ subterms)) - (loops (map s:subterm-deriv - (filter s:subterm? subterms)))] - - [(AnyQ lderiv (_ _ derivs)) - (loops derivs)] - [(AnyQ bderiv (_ _ pass1 _ pass2)) - (join (loops pass1) (loop pass2))] - [(AnyQ b:defvals (_ head)) - (loop head)] - [(AnyQ b:defstx (_ deriv rhs)) - (join (loop deriv) (loop rhs))] - [(AnyQ b:splice (_ head _)) - (loop head)] - [(AnyQ b:expr (_ head)) - (loop head)] - [(AnyQ b:begin (_ head inner)) - (join (loop head) (loop inner))] - [(AnyQ mod:cons (head)) - (loop head)] - [(AnyQ mod:prim (head prim)) - (join (loop head) (loop prim))] - [(AnyQ mod:splice (head _)) - (loop head)] - [(AnyQ mod:lift (head tail)) - (join (loop head) (loop tail))] - [(AnyQ mod:lift-end (tail)) - (loop tail)] - [(AnyQ mod:begin (head inner)) - (join (loop head) (loop inner))] - - [else zero])) - - (define (loops ds) - (if (list? ds) - (apply join (map loop ds)) - zero)) - (loop d)) - - (define (find-derivs/syntax pred d) - (find-derivs (match-lambda - [(AnyQ deriv (e1 e2)) - (pred e1)] - [_ #f]) - (match-lambda - ;; FIXME: Why? - [(AnyQ p:module (_ _ _ _ _)) #t] - [_ #f]) - d)) - - ;; extract-all-fresh-names : Derivation -> syntaxlike - ;; FIXME: Missing case-lambda - (define (extract-all-fresh-names d) - (define (renaming-node? x) - (or (and (error-wrap? x) - (renaming-node? (error-wrap-inner x))) - (and (interrupted-wrap? x) - (renaming-node? (interrupted-wrap-inner x))) - (p:lambda? x) - (p:case-lambda? x) - (p:let-values? x) - (p:letrec-values? x) - (p:letrec-syntaxes+values? x) - (p:rename? x) - (b:defvals? x) - (b:defstx? x) - (p:define-values? x) - (p:define-syntaxes? x))) - (define (extract-fresh-names d) - (match d - [(AnyQ p:lambda (e1 e2 rs renames body)) - (if renames - (with-syntax ([(?formals . ?body) renames]) - #'?formals) - null)] - [(AnyQ p:let-values (e1 e2 rs renames rhss body)) - (if renames - (with-syntax ([(((?vars ?rhs) ...) . ?body) renames]) - #'(?vars ...)) - null)] - [(AnyQ p:letrec-values (e1 e2 rs renames rhss body)) - (if renames - (with-syntax ([(((?vars ?rhs) ...) . ?body) renames]) - #'(?vars ...)) - null)] - [(AnyQ p:letrec-syntaxes+values (e1 e2 rs srenames srhss vrenames vrhss body)) - (cons - (if srenames - (with-syntax ([(((?svars ?srhs) ...) ((?vvars ?vrhs) ...) . ?body) - srenames]) - #'(?svars ... ?vvars ...)) - null) - (if vrenames - (with-syntax ([(((?vvars ?vrhs) ...) . ?body) vrenames]) - #'(?vvars ...)) - null))] - [(AnyQ b:defvals (rename head)) - (let ([head-e2 (lift/deriv-e2 head)]) - (if head-e2 - (with-syntax ([(?dv ?vars ?rhs) head-e2]) - #'?vars) - null))] - [(AnyQ b:defstx (rename head rhs)) - (let ([head-e2 (lift/deriv-e2 head)]) - (if head-e2 - (with-syntax ([(?ds ?svars ?rhs) head-e2]) - #'?svars) - null))] - [(AnyQ p:define-values (e1 e2 rs rhs)) - (if rhs - (with-syntax ([(?dv ?vars ?rhs) e1]) - #'?vars) - null)] - [(AnyQ p:define-syntaxes (e1 e2 rs rhs)) - (if rhs - (with-syntax ([(?ds ?svars ?srhs) e1]) - #'?svars) - null)] - [_ null])) - - (let ([all-renaming-forms - (find-deriv/unit+join+zero - renaming-node? - (lambda (d) #f) - d - list - append - null)]) - (flatten-identifiers (map extract-fresh-names all-renaming-forms)))) - - ;; flatten-identifiers : syntaxlike -> (list-of identifier) - (define (flatten-identifiers stx) + ;; ---- + + (define-syntax (make stx) (syntax-case stx () - [id (identifier? #'id) (list #'id)] - [() null] - [(x . y) (append (flatten-identifiers #'x) (flatten-identifiers #'y))] - [else (error 'flatten-identifers "neither syntax list nor identifier: ~s" - (if (syntax? stx) - (syntax-object->datum stx) - stx))])) - -) + [(make S expr ...) + (unless (identifier? #'S) + (raise-syntax-error #f "not an identifier" stx #'S)) + (let () + (define (no-info) (raise-syntax-error #f "not a struct" stx #'S)) + (define info + (extract-struct-info + (syntax-local-value #'S no-info))) + (define constructor (list-ref info 1)) + (define accessors (list-ref info 3)) + (unless (identifier? #'constructor) + (raise-syntax-error #f "constructor not available for struct" stx #'S)) + (unless (andmap identifier? accessors) + (raise-syntax-error #f "incomplete info for struct type" stx #'S)) + (let ([num-slots (length accessors)] + [num-provided (length (syntax->list #'(expr ...)))]) + (unless (= num-provided num-slots) + (raise-syntax-error + #f + (format "wrong number of arguments for struct ~s (expected ~s)" + (syntax-e #'S) + num-slots) + stx))) + (with-syntax ([constructor constructor]) + #'(constructor expr ...)))])) + ) diff --git a/collects/macro-debugger/model/deriv.ss b/collects/macro-debugger/model/deriv.ss index 49df102..ffe82aa 100644 --- a/collects/macro-debugger/model/deriv.ss +++ b/collects/macro-debugger/model/deriv.ss @@ -6,319 +6,365 @@ ;; NO CONTRACTS - (provide (all-from "deriv-c.ss")) + #;(provide (all-from "deriv-c.ss")) + ;; CONTRACTS - -#; (begin - (define (stx-list-like? x) - (or (syntax? x) - (null? x) - (and (pair? x) (syntax? (car x)) (stx-list-like? (cdr x))))) - - (define (maybe c) (or/c c false/c)) - (define node/c (or/c deriv? lderiv? bderiv? transformation? brule? modrule?)) - (define errnode/c (or/c prule? transformation? lderiv? brule? modrule?)) - (define tag/c (maybe symbol?)) - (define syntax/f (maybe syntax?)) + (define (?? c) (or/c c false/c)) + + (define (stx? x) + (or (syntax? x) + (and (pair? x) (stx? (car x)) (stx? (cdr x))) + (null? x))) + + (define (stx-list-like? x) + (let ([x (stx->list x)]) + (and x (andmap syntax? x)))) + + (define syntax/f (?? syntax?)) (define syntaxes/c stx-list-like?) - (define syntaxes/f (maybe syntaxes/c)) - - (define (anyw C) - (or/c (struct/c error-wrap exn? tag/c C) - (struct/c interrupted-wrap tag/c C))) - (define (anyq C) - (or/c C (anyw C))) - (define (intw C) - (struct/c interrupted-wrap tag/c C)) - (define (intq C) - (or/c C (intw C))) - + (define syntaxes/f (?? syntaxes/c)) (define resolves/c (listof identifier?)) + (define localaction/c + (or/c local-expansion? local-expansion/expr? local-lift? + local-lift-end? local-bind?)) + (provide/contract - (struct deriv - ([e1 syntax?] - [e2 syntax/f])) - (struct (mrule deriv) - ([e1 syntax?] - [e2 syntax/f] - [transformation (anyq transformation?)] - [next (maybe (anyq deriv?))])) + (struct node + ([z1 any/c] + [z2 any/c])) + (struct (deriv node) + ([z1 syntax?] + [z2 syntax/f])) (struct (lift-deriv deriv) - ([e1 syntax?] - [e2 syntax/f] + ([z1 syntax?] + [z2 syntax/f] [first deriv?] [lift-stx syntax?] - [second (anyq deriv?)])) + [second deriv?])) + (struct (mrule deriv) + ([z1 syntax?] + [z2 syntax/f] + [transformation transformation?] + [next (?? deriv?)])) (struct (lift/let-deriv deriv) - ([e1 syntax?] - [e2 syntax/f] + ([z1 syntax?] + [z2 syntax/f] [first deriv?] [lift-stx syntax?] - [second (anyq deriv?)])) - (struct transformation - ([e1 syntax?] - [e2 syntax/f] + [second deriv?])) + (struct (transformation node) + ([z1 syntax?] + [z2 syntax/f] [resolves resolves/c] + [?1 (?? exn?)] + [me1 (?? syntax?)] + [locals (?? (listof localaction/c))] + [?2 (?? exn?)] + [me2 (?? syntax?)] + [seq number?])) + (struct (local-expansion node) + ([z1 syntax?] + [z2 syntax/f] [me1 syntax?] [me2 syntax/f] - [locals (listof (or/c local-expansion? local-lift? local-lift-end? local-bind?))])) - (struct (prule deriv) - ([e1 syntax?] - [e2 syntax/f] - [resolves resolves/c])) - (struct (p:#%app prule) - ([e1 syntax?] - [e2 syntax/f] + [for-stx? boolean?] + [inner deriv?])) + (struct (local-expansion/expr node) + ([z1 syntax?] + [z2 syntax/f] + [me1 syntax?] + [me2 syntax/f] + [for-stx? boolean?] + [opaque any/c] + [inner deriv?])) + (struct local-lift + ([expr syntax?] + [id identifier?])) + (struct local-lift-end + ([decl syntax?])) + (struct local-bind + ([bindrhs bind-syntaxes?])) + (struct (base deriv) + ([z1 syntax?] + [z2 syntax/f] [resolves resolves/c] - [tagged-stx syntax?] - [lderiv (anyq (maybe lderiv?))])) + [?1 (?? exn?)])) + (struct (prule base) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)])) + (struct (p:variable prule) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)])) + (struct (p:module prule) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)] + [one-body-form? boolean?] + [mb (?? deriv?)] + [?2 (?? exn?)] + [body (?? deriv?)])) + (struct (p:#%module-begin prule) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)] + [pass1 (?? (listof modrule?))] + [pass2 (?? (listof modrule?))] + [?2 (?? exn?)])) + (struct (p:define-syntaxes prule) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)] + [rhs (?? deriv?)] + [?2 (?? exn?)])) + (struct (p:define-values prule) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)] + [rhs (?? deriv?)])) + (struct (p:#%expression prule) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)] + [inner (?? deriv?)])) + (struct (p:if prule) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)] + [full? boolean?] + [test (?? deriv?)] + [then (?? deriv?)] + [else (?? deriv?)])) + (struct (p:wcm prule) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)] + [key (?? deriv?)] + [mark (?? deriv?)] + [body (?? deriv?)])) + (struct (p:set! prule) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)] + [id-resolves (?? resolves/c)] + [rhs (?? deriv?)])) + (struct (p:set!-macro prule) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)] + [deriv (?? deriv?)])) + (struct (p:#%app prule) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)] + [tagged-stx syntax/f] + [lderiv (?? lderiv?)])) + (struct (p:begin prule) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)] + [lderiv (?? lderiv?)])) + (struct (p:begin0 prule) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)] + [first (?? deriv?)] + [lderiv (?? lderiv?)])) + (struct (p:lambda prule) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)] + [renames any/c] ;; fixme + [body (?? bderiv?)])) + (struct (p:case-lambda prule) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)] + [renames+bodies (listof clc?)])) + (struct (p:let-values prule) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)] + [renames any/c] ;; fixme + [rhss (?? (listof deriv?))] + [body (?? bderiv?)])) + (struct (p:letrec-values prule) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)] + [renames any/c] ;; fixme + [rhss (?? (listof deriv?))] + [body (?? bderiv?)])) + (struct (p:letrec-syntaxes+values prule) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)] + [srenames any/c] ;; fixme + [sbindrhss (?? (listof bind-syntaxes?))] + [vrenames any/c] ;; fixme + [vrhss (?? (listof deriv?))] + [body (?? bderiv?)])) + (struct (p::STOP prule) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)])) + (struct (p:stop p::STOP) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)])) + (struct (p:unknown p::STOP) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)])) + (struct (p:#%top p::STOP) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)] + [tagged-stx syntax/f])) + (struct (p:#%datum p::STOP) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)] + [tagged-stx syntax/f])) + (struct (p:quote p::STOP) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)])) + (struct (p:quote-syntax p::STOP) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)])) + (struct (p:require p::STOP) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)])) + (struct (p:require-for-syntax p::STOP) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)])) + (struct (p:require-for-template p::STOP) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)])) + (struct (p:provide p::STOP) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)])) + (struct (p:rename prule) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)] + [renames any/c] + [inner (?? deriv?)])) + (struct (p:synth prule) + ([z1 syntax?] + [z2 syntax/f] + [resolves resolves/c] + [?1 (?? exn?)] + [subterms (?? (listof subitem?))] + [?2 (?? exn?)])) - (struct lderiv - ([es1 syntaxes/c] - [es2 syntaxes/f] - [derivs (listof (anyq deriv?))])) + (struct (lderiv node) + ([z1 stx?] + [z2 syntaxes/f] + [?1 (?? exn?)] + [derivs (?? (listof deriv?))])) + (struct (bderiv node) + ([z1 stx?] + [z2 syntaxes/f] + [pass1 (?? (listof (or/c b:error? brule?)))] + [trans (symbols 'list 'letrec)] + [pass2 (?? lderiv?)])) - (struct interrupted-wrap - ([tag (or/c symbol? false/c)] - [inner node/c])) - (struct error-wrap - ([exn exn?] - [tag (or/c symbol? false/c)] - [inner errnode/c]))) + (struct b:error + ([?1 exn?])) + (struct brule + ([renames any/c])) + (struct (b:expr brule) + ([renames any/c] + [head deriv?])) + (struct (b:splice brule) + ([renames any/c] + [head deriv?] + [?1 (?? exn?)] + [tail (?? stx?)] + [?2 (?? exn?)])) + (struct (b:defvals brule) + ([renames any/c] + [head deriv?] + [?1 (?? exn?)])) + (struct (b:defstx brule) + ([renames any/c] + [head deriv?] + [?1 (?? exn?)] + [bindrhs (?? bind-syntaxes?)])) + (struct bind-syntaxes + ([rhs deriv?] + [?1 (?? exn?)])) - (provide ;(struct deriv (e1 e2)) - ;(struct mrule (transformation next)) - ;(struct lift-deriv (first lift-stx second)) - ;(struct lift/let-deriv (first lift-stx second)) - - ;(struct transformation (e1 e2 resolves me1 me2 locals)) + (struct clc + ([?1 (?? exn?)] + [renames any/c] + [body (?? bderiv?)])) - (struct local-expansion (e1 e2 me1 me2 deriv)) - (struct local-lift (expr id)) - (struct local-lift-end (decl)) - (struct local-bind (deriv)) + (struct modrule ()) + (struct (mod:cons modrule) + ([head deriv?])) + (struct (mod:prim modrule) + ([head deriv?] + [prim (?? deriv?)])) + (struct (mod:skip modrule) ()) + (struct (mod:splice modrule) + ([head deriv?] + [?1 (?? exn?)] + [tail (?? stx?)])) + (struct (mod:lift modrule) + ([head deriv?] + [tail syntaxes/c])) + (struct (mod:lift-end modrule) + ([tail syntaxes/c])) - ;(struct prule (resolves)) - (struct p:variable ()) - (struct p:define-syntaxes (rhs)) - (struct p:define-values (rhs)) - (struct p:if (full? test then else)) - (struct p:wcm (key mark body)) - (struct p:set! (id-resolves rhs)) - (struct p:set!-macro (deriv)) - (struct p:begin (lderiv)) - (struct p:begin0 (first lderiv)) - ;(struct p:#%app (tagged-stx lderiv)) - (struct p:lambda (renames body)) - (struct p:case-lambda (renames+bodies)) - (struct p:let-values (renames body)) - (struct p:letrec-values (renames rhss body)) - (struct p:letrec-syntaxes+values (srenames srhss vrenames vrhss body)) - (struct p:module (one-body-form? body)) - (struct p:#%module-begin (pass1 pass2)) - (struct p::STOP ()) - (struct p:#%datum (tagged-stx)) - (struct p:#%top (tagged-stx)) - (struct p:quote ()) - (struct p:quote-syntax ()) - (struct p:require ()) - (struct p:require-for-syntax ()) - (struct p:require-for-template ()) - (struct p:provide ()) - (struct p:stop ()) - (struct p:unknown ()) - (struct p:rename (renames inner)) - - (struct p:synth (subterms)) - (struct s:subterm (path deriv)) - (struct s:rename (path before after)) - - ;(struct lderiv (es1 es2 derivs)) - (struct bderiv (es1 es2 pass1 trans pass2)) - - (struct brule (renames)) - (struct b:defvals (head)) - (struct b:defstx (deriv rhs)) - (struct b:splice (head tail)) - (struct b:expr (head)) - (struct b:begin (head inner)) - - (struct modrule ()) - (struct mod:cons (head)) - (struct mod:prim (head prim)) - (struct mod:skip ()) - (struct mod:splice (head tail)) - (struct mod:lift (head tail)) - (struct mod:lift-end (tail)) - (struct mod:begin (head inner)) - - ;(struct interrupted-wrap (tag inner)) - ;(struct error-wrap (exn tag inner)) - ) - - - ;; Well-formedness - - ;; Predicates on well-formed derivations - #; - (define (wf-ok-deriv? x) - (match x - [($ pderiv e1 e2 prule) - (and (syntax? e1) - (syntax? e2) - (wf-ok-prule? prule))] - [($ mderiv e1 e2 mrule next) - (and (syntax? e1) - (syntax? e2) - (wf-ok-mrule? mrule) - (wf-ok-deriv? next))] - [else #f])) - - #; - (define (wf-ok-mrule? x) - (match x - [($ mrule e1 e2 rs me1 me2 locals) - (and (syntax? e1) - (syntax? e2) - (list? rs) - (andmap identifier? rs) - (syntax? me1) - (syntax? me2) - (list? locals) - (andmap wf-ok-deriv? locals))] - [else #f])) - - #; - (define (wf-ok-basic-prule? x) - (match x - [($ prule e1 e2 rs) - (and (syntax? e1) - (syntax? e2) - (list? rs) - (andmap identifier? rs))] - [else #f])) - - #; - (define (wf-ok-prule? x) - (and (wf-ok-basic-prule? x) - (match x - [($ p:variable _ _ _) #t] - [($ p:define-syntaxes _ _ _ rhs) - (wf-ok-deriv? rhs)] - [($ p:define-values _ _ _ rhs) - (wf-ok-deriv? rhs)] - [($ p:if _ _ _ test then else) - (and (wf-ok-deriv? test) - (wf-ok-deriv? then) - (wf-ok-deriv? else))] - [($ p:wcm _ _ _ key value body) - (and (wf-ok-deriv? key) - (wf-ok-deriv? value) - (wf-ok-deriv? body))] - [($ p:set! _ _ _ id-rs rhs) - (and (list? id-rs) - (andmap identifier? id-rs) - (wf-ok-deriv? rhs))] - [($ p:set!-macro _ _ _ deriv) - (wf-ok-deriv? deriv)] - [($ p:begin _ _ _ lderiv) - (wf-ok-lderiv? lderiv)] - [($ p:begin0 _ _ _ first lderiv) - (and (wf-ok-deriv? first) - (wf-ok-lderiv? lderiv))] - [($ p:#%app _ _ _ lderiv) - (wf-ok-lderiv? lderiv)] - [($ p:lambda _ _ _ renames body) - (and (pair? renames) - (syntax? (car renames)) - (syntax? (cdr renames)) - (wf-ok-bderiv? body))] - [($ p:case-lambda _ _ _ (renames+bodies ...)) - (andmap (lambda (r+b) - (and (pair? r+b) - (pair? (car r+b)) - (syntax? (caar r+b)) - (syntax? (cdar r+b)) - (wf-ok-bderiv? (cdr r+b)))) - renames+bodies)] - [($ p:let-values _ _ _ (renames ...) (rhss ...) body) - (and (andmap (lambda (r) - (and (pair? r) - (syntax? (car r)) - (syntax? (cdr r)))) - renames) - (andmap wf-ok-deriv? rhss) - (= (length renames) (length rhss)) - (wf-ok-bderiv? body))] - [($ p:letrec-values _ _ _ (renames ...) (rhss ...) body) - (and (andmap (lambda (r) - (and (pair? r) - (syntax? (car r)) - (syntax? (cdr r)))) - renames) - (andmap wf-ok-deriv? rhss) - (= (length renames) (length rhss)) - (wf-ok-bderiv? body))] - [($ p:letrec-syntaxes+values _ _ _ - (srenames ...) (srhss ...) (vrenames ...) (vrhss ...) body) - (and (andmap (lambda (r) - (and (pair? r) (syntax? (car r)) (syntax? (cdr r)))) - srenames) - (andmap wf-ok-deriv? srhss) - (= (length srenames) (length srhss)) - (andmap (lambda (r) - (and (pair? r) (syntax? (car r)) (syntax? (cdr r)))) - vrenames) - (andmap wf-ok-deriv? vrhss) - (= (length vrenames) (length vrhss)) - (wf-ok-bderiv? body))] - [($ p::STOP _ _ _) #t] - [else #f]))) - - #; - (define (wf-ok-lderiv? x) - (match x - [($ lderiv es1 es2 derivs) - (and (list? es1) - (andmap syntax? es1) - (list? es2) - (andmap syntax? es2) - (list? derivs) - (andmap wf-ok-lderiv? derivs))] - [else #f])) - - #; - (define (wf-ok-bderiv? x) - (define (wf-ok-brule? x) - (match x - [($ brskip renames next) - (and (void renames) - (wf-ok-brule? next))] - [($ brcons renames head next) - (and (void renames) - (wf-ok-deriv? head) - (wf-ok-brule? next))] - [($ brdefstx renames deriv rhs next) - (and (void renames) - (wf-ok-deriv? deriv) - (wf-ok-deriv? rhs) - (wf-ok-brule? next))] - [($ brsplice tail next) - (and (list? tail) - (andmap syntax? tail) - (wf-ok-brule? next))] - [else #f])) - (match x - [($ bderiv es1 es2 pass1 trans pass2) - (and (wf-ok-brule? pass1) - (wf-ok-lderiv? pass2))] - [else #f])) - - #; - (define (wf-exn-deriv? x) - #f) - ) - ) + (struct subitem ()) + (struct (s:subterm subitem) + ([path any/c] + [deriv deriv?])) + (struct (s:rename subitem) + ([path any/c] + [before syntax?] + [after syntax?])) + )) diff --git a/collects/macro-debugger/model/reductions-engine.ss b/collects/macro-debugger/model/reductions-engine.ss index 5790674..2b5c6a6 100644 --- a/collects/macro-debugger/model/reductions-engine.ss +++ b/collects/macro-debugger/model/reductions-engine.ss @@ -1,9 +1,13 @@ +;; FIXME: Steps are pairs of Configurations +;; Configurations contain contexts, definites, etc. + (module reductions-engine mzscheme (require (lib "list.ss") "deriv.ss" "stx-util.ss" "steps.ss") + (require (lib "contract.ss")) (provide (all-from "steps.ss")) (provide context @@ -18,6 +22,15 @@ with-context with-derivation with-new-local-context + + RSunit + RSzero + RSbind + RSadd + RSseq + RSforeach + RS-steps + CC R revappend) @@ -64,7 +77,8 @@ . body)])) (define (learn-definites ids) - (current-definites (append ids (current-definites)))) + (current-definites + (append ids (current-definites)))) (define (get-frontier) (or (current-frontier) null)) @@ -81,6 +95,60 @@ ;; ----------------------------------- + ;; RS: The "reductions monad" + ;; (RS a) = (values ReductionSequence ?a ?exn) + ;; Not a proper monad, because of 'values' + + (define-syntax ->RS/c + (syntax-rules () + [(->RS/c domain-c ...) + (-> domain-c ... + (values (listof protostep?) any/c (or/c exn? false/c)))])) + + (define/contract RSzero + (->RS/c) + (lambda () (values null #f #f))) + + (define/contract RSunit + (->RS/c any/c) + (lambda (v) + (values null v #f))) + + (define/contract RSbind + (->RS/c (->RS/c) (->RS/c any/c)) + (lambda (a f) + (let-values ([(rseq1 final1 exn1) (a)]) + (if (not exn1) + (let-values ([(rseq2 final2 exn2) (f final1)]) + (values (append rseq1 rseq2) final2 exn2)) + (values rseq1 final1 exn1))))) + + (define/contract RSseq + (->RS/c (->RS/c) (->RS/c)) + (lambda (a b) + (RSbind a (lambda (_) (b))))) + + (define/contract RSforeach + (->RS/c (->RS/c any/c) (listof any/c)) + (lambda (f xs) + (let loop ([xs xs]) + (if (pair? xs) + (RSseq (lambda () (f (car xs))) + (lambda () (loop (cdr xs)))) + (RSunit (void)))))) + + (define/contract RSadd + (->RS/c (listof protostep?) (->RS/c)) + (lambda (steps a) + (let-values ([(rseq1 final1 exn1) (a)]) + (values (append steps rseq1) final1 exn1)))) + + (define-syntax RS-steps + (syntax-rules () + [(RS-steps expr) + (let-values ([(rseq final exn) expr]) + rseq)])) + ;; CC ;; the context constructor (define-syntax (CC stx) @@ -88,128 +156,197 @@ [(CC HOLE expr pattern) #'(syntax-copier HOLE expr pattern)])) + ;; (R stx R-clause ...) + ;; 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] + ;; [#:rename/no-step pattern stx stx] + ;; [#:reductions expr] + ;; [#:learn ids] + ;; [#:frontier stxs] + ;; [#:when test R-clause ...] + ;; [#: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] [#:pattern pattern] . clauses)])) - - (define-syntax (R** stx) - (syntax-case stx (! @ List Block =>) + (R** #f _ [#:set-syntax form] . clauses)])) + + (define-syntax R** + (syntax-rules (! =>) + ;; Base: done [(R** form-var pattern) - #'null] + (RSunit form-var)] + ;; Base: explicit continuation [(R** f p => k) - #'(k f)] + (k f)] + + ;; Error-point case + [(R** f p [! maybe-exn] . more) + (let ([x maybe-exn]) + (unless (or (not x) (exn? x)) + (raise-type-error 'R "exception" x)) + (if x + (values (list (stumble f x)) #f x) + (R** f p . more)))] ;; Change patterns [(R** f p [#:pattern p2] . more) - #'(R** f 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))] + (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 with step + (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))]) - (cons (walk/foci foci1-var foci2-var f form2-var description-var) - (R** form2-var p . more)))] - [(R** f p [#:rename form2 foci1 foci2 description] . more) - #'(let-values ([(form2-var foci1-var foci2-var description-var) - (with-syntax ([p f]) - (values form2 foci1 foci2 description))]) - (rename-frontier f form2-var) - (with-context (make-renames foci1-var foci2-var) - (cons (walk/foci foci1-var foci2-var - f form2-var - description-var) - (R** form2-var p . 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) - (with-syntax ([p f]) - (values form2 description))]) - (cons (walk f form2-var description-var) - (R** form2-var p . more)))] + (let-values ([(form2-var description-var) + (with-syntax ([p f]) + (values form2 description))]) + (RSadd (list (walk f form2-var description-var)) + (lambda () (R** form2-var p . more))))] + + ;; Change syntax with rename + [(R** f p [#:rename form2 foci1 foci2 description] . more) + (let-values ([(form2-var foci1-var foci2-var description-var) + (with-syntax ([p f]) + (values form2 foci1 foci2 description))]) + (rename-frontier f form2-var) + (with-context (make-renames foci1-var foci2-var) + (RSadd (list (walk/foci foci1-var foci2-var + f form2-var + description-var)) + (lambda () (R** form2-var p . more)))))] + + ;; Change syntax with rename (but no step) + [(R** f p [#:rename/no-step pvar from to] . more) + (let-values ([(from-var to-var) + (with-syntax ([p f]) (values from to))]) + (let ([f2 (with-syntax ([p f]) + (with-syntax ([pvar to]) + (syntax p)))]) + (rename-frontier from-var to-var) + (with-context (make-renames from-var to-var) + (R** f2 p . more))))] + + ;; Add in arbitrary other steps + [(R** f p [#:reductions steps] . more) + (RSseq (lambda () steps) + (lambda () (R** f p . more)))] + + ;; Add to definites [(R** f p [#:learn ids] . more) - #'(begin (learn-definites ids) - (R** f p . 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))] - + (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 [#:if test consequent ...] . more) - #'(if (with-syntax ([p f]) test) - (R** f p consequent ... . more) - (R** f p . more))] + [(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))]) + (Run f p generator hole fill k))])) - ;; Error-point case - [(R** f p [! info] . more) - #'(R** f p [! info #f] . more)] - [(R** f p [! info key] . more) - #'(let ([continue (lambda () (R** f p . more))]) - (cond [(and (pair? info) (car info)) - ;; error-wrap - ;; If this is the key, then insert the misstep here and stop. - ;; This stops processing *within* an error-wrapped prim. - (if (or (eq? key #f) (eq? key (cdr info))) - (list (stumble f (car info))) - (continue))] - [else - (continue)]))] - - [(R** f p [Generator hole0 fill0] . more) - #'(let-values ([(reducer get-e1 get-e2) Generator]) - (R** f p [reducer get-e1 get-e2 hole0 fill0] . more))] - - ;; Implementation for (hole ...) sequences - [(R** form-var pattern - [f0 get-e1 get-e2 (hole0 :::) fill0s] . more) + + (define-syntax Run + (syntax-rules () + [(Run f p generator hole fill k) + (let ([reducer (with-syntax ([p f]) (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) (and (identifier? #':::) (module-identifier=? #'::: (quote-syntax ...))) - #'(let ([ctx0 (CC (hole0 :::) form-var pattern)]) - (let ([e1s (with-syntax ([pattern form-var]) (syntax->list #'(hole0 :::)))]) - (let loop ([fills fill0s] [prefix null] [suffix e1s]) - (cond - [(pair? fills) - (append - (with-context ctx0 - (with-context (lambda (x) (revappend prefix (cons x (cdr suffix)))) - (f0 (car fills)))) - (cond [(interrupted-wrap? (car fills)) - null] - [(error-wrap? (car fills)) - null] - [else - (loop (cdr fills) - (cons (get-e2 (car fills)) prefix) - (cdr suffix))]))] - [(null? fills) - (let ([form-var (ctx0 (reverse prefix))]) - (R** form-var pattern . more))]))))] - ;; Implementation - [(R** form-var pattern - [f0 get-e1 get-e2 hole0 fill0] . more) - #'(let ([ctx0 (CC hole0 form-var pattern)]) - (append (with-context ctx0 - (f0 fill0)) - ;; If the last thing we ran through was interrupted, - ;; then there's nothing left to do. - ;; This stops processing *after* an error-wrapped deriv. - (cond [(interrupted-wrap? fill0) null] - [(error-wrap? fill0) null] - [else - (let ([form-var (ctx0 (get-e2 fill0))]) - (R** form-var pattern . more))])))])) + #'(let ([ctx (CC (hole :::) form-var pattern)]) + (let ([e1s (with-syntax ([pattern form-var]) (syntax->list #'(hole :::)))]) + (run-multiple f 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-multiple : (a -> RS(b)) ((list-of b) -> c) (list-of a) (list-of b) (c -> RS(d)) + ;; -> RS(d) + ;; For example: a = Deriv; b = c = d = Syntax + (define (run-multiple f ctx fills suffix k) + (let loop ([fills fills] [prefix null] [suffix suffix]) + (cond + [(pair? fills) + (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))))] + [(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) diff --git a/collects/macro-debugger/model/reductions.ss b/collects/macro-debugger/model/reductions.ss index 0efbe4a..41f5257 100644 --- a/collects/macro-debugger/model/reductions.ss +++ b/collects/macro-debugger/model/reductions.ss @@ -12,18 +12,24 @@ ;; Setup for reduction-engines - (define-syntax Expr - (syntax-id-rules () - [Expr (values reductions* deriv-e1 deriv-e2)])) - (define-syntax List - (syntax-id-rules () - [List (values list-reductions lderiv-es1 lderiv-es2)])) - (define-syntax Block - (syntax-id-rules () - [Block (values block-reductions bderiv-es1 bderiv-es2)])) - + (define (Expr) reductions*) + (define (List) list-reductions) + (define (Block) block-reductions) + (define (Transformation) + 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)) + ;; Syntax - + (define-syntax match/with-derivation (syntax-rules () [(match/with-derivation d . clauses) @@ -32,130 +38,139 @@ (match dvar . clauses)))])) ;; Reductions - - ;; reductions : Derivation -> ReductionSequence + + ;; reductions : WDeriv -> ReductionSequence (define (reductions d) (parameterize ((current-definites null) (current-frontier null)) - (when d (add-frontier (list (lift/deriv-e1 d)))) - (reductions* d))) + (when d (add-frontier (list (wderiv-e1 d)))) + (RS-steps (reductions* d)))) + ;; reductions+definites : WDeriv -> (values ReductionSequence (list-of identifier)) (define (reductions+definites d) (parameterize ((current-definites null) (current-frontier null)) - (when d (add-frontier (list (lift/deriv-e1 d)))) - (let ([rs (reductions* d)]) + (when d (add-frontier (list (wderiv-e1 d)))) + (let ([rs (RS-steps (reductions* d))]) (values rs (current-definites))))) - + + ;; reductions* : WDeriv -> RS(stx) (define (reductions* d) (match d - [(AnyQ prule (e1 e2 rs)) - (and rs (learn-definites rs)) + [(Wrap deriv (e1 e2)) (blaze-frontier e1)] [_ (void)]) + (match d + [(Wrap prule (e1 e2 rs ?1)) + (and rs (learn-definites rs))] + [_ (void)]) (match/with-derivation d ;; Primitives - [(struct p:variable (e1 e2 rs)) - (learn-definites (list e2)) - (if (bound-identifier=? e1 e2) - null - (list (walk e1 e2 'resolve-variable)))] - [(IntQ p:module (e1 e2 rs #f body)) - (with-syntax ([(?module name language . BODY) e1]) - (let ([ctx (lambda (x) (d->so e1 `(,#'?module ,#'name ,#'language ,x)))] - [body-e1 (match body [(AnyQ deriv (body-e1 _)) body-e1])]) - (cons (walk e1 (ctx body-e1) 'tag-module-begin) - (with-context ctx - (add-frontier (list (lift/deriv-e1 body))) - (reductions* body)))))] - [(IntQ p:module (e1 e2 rs #t body)) - (with-syntax ([(?module name language . BODY) e1]) - (let ([ctx (lambda (x) (d->so e1 `(,#'?module ,#'name ,#'language ,x)))]) - (with-context ctx - (add-frontier (list (lift/deriv-e1 body))) - (reductions* body))))] - [(AnyQ p:#%module-begin (e1 e2 rs pass1 pass2)) - (with-syntax ([(?#%module-begin form ...) e1]) - (let ([frame (lambda (x) (d->so e1 (cons #'?#%module-begin x)))]) - (let-values ([(reductions1 final-stxs1) - (with-context frame - (add-frontier (syntax->list #'(form ...))) - (mbrules-reductions pass1 (syntax->list #'(form ...)) #t))]) - (let-values ([(reductions2 final-stxs2) - (with-context frame - ;(add-frontier final-stxs1) - (mbrules-reductions pass2 final-stxs1 #f))]) - (if (error-wrap? d) - (append reductions1 reductions2 - (list (stumble (frame final-stxs2) (error-wrap-exn d)))) - (append reductions1 reductions2))))))] - [(AnyQ p:define-syntaxes (e1 e2 rs rhs) exni) + [(Wrap p:variable (e1 e2 rs ?1)) (R e1 - [! exni] - [#:pattern (?define-syntaxes formals RHS)] - [#:frontier (list #'RHS)] - [Expr RHS rhs])] - [(AnyQ p:define-values (e1 e2 rs rhs) exni) + [#: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)) (R e1 - [! exni] - [#:pattern (?define-values formals RHS)] - [#:frontier (list #'RHS)] - [#:if rhs - [Expr RHS rhs]])] - [(AnyQ p:expression (e1 e2 rs inner) exni) + [! ?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 - [! exni] - [#:pattern (?expr INNER)] - [Expr INNER inner])] - [(AnyQ p:if (e1 e2 rs full? test then else) exni) + [! ?1] + [#:pattern (?module ?name ?language ?body)] + [#:frontier (list #'?body)] + [Expr ?body mb] + [! ?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)) + (R e1 + [! ?1] + [#:pattern (?module-begin . ?forms)] + [#:frontier (stx->list* #'?forms)] + [(ModulePass #'?forms) + ?forms pass1] + [(ModulePass #'?forms) + ?forms pass2] + [! ?1])] + [(Wrap p:define-syntaxes (e1 e2 rs ?1 rhs ?2)) + (R e1 + [! ?1] + [#:pattern (?define-syntaxes formals ?rhs)] + [#:frontier (list #'?rhs)] + [Expr ?rhs rhs] + [! ?2])] + [(Wrap p:define-values (e1 e2 rs ?1 rhs)) + (R e1 + [! ?1] + [#:pattern (?define-values ?formals ?rhs)] + [#:frontier (list #'?rhs)] + ;; RHS can be #f (eg, modprim) + [#:when/np rhs + [Expr ?rhs rhs]])] + [(Wrap p:#%expression (e1 e2 rs ?1 inner)) + (R e1 + [! ?1] + [#:pattern (?expr ?inner)] + [#:frontier (list #'?inner)] + [Expr ?inner inner])] + [(Wrap p:if (e1 e2 rs ?1 full? test then else)) (if full? (R e1 - [! exni] + [! ?1] [#:pattern (?if TEST THEN ELSE)] [#:frontier (list #'TEST #'THEN #'ELSE)] [Expr TEST test] [Expr THEN then] [Expr ELSE else]) (R e1 - [! exni] + [! ?1] [#:pattern (?if TEST THEN)] [#:frontier (list #'TEST #'THEN)] [Expr TEST test] [Expr THEN then]))] - [(AnyQ p:wcm (e1 e2 rs key mark body) exni) + [(Wrap p:wcm (e1 e2 rs ?1 key mark body)) (R e1 - [! exni] + [! ?1] [#:pattern (?wcm KEY MARK BODY)] [#:frontier (list #'KEY #'MARK #'BODY)] [Expr KEY key] [Expr MARK mark] [Expr BODY body])] - [(AnyQ p:begin (e1 e2 rs lderiv) exni) + [(Wrap p:begin (e1 e2 rs ?1 lderiv)) (R e1 - [! exni] - [#:pattern (?begin . LDERIV)] - [#:frontier (stx->list* #'LDERIV)] - [List LDERIV lderiv])] - [(AnyQ p:begin0 (e1 e2 rs first lderiv) exni) + [! ?1] + [#:pattern (?begin . ?lderiv)] + [#:frontier (stx->list* #'?lderiv)] + [List ?lderiv lderiv])] + [(Wrap p:begin0 (e1 e2 rs ?1 first lderiv)) (R e1 - [! exni] + [! ?1] [#:pattern (?begin0 FIRST . LDERIV)] [#:frontier (cons #'FIRST (stx->list* #'LDERIV))] [Expr FIRST first] [List LDERIV lderiv])] - [(AnyQ p:#%app (e1 e2 rs tagged-stx lderiv) exni) - (let ([tail - (R tagged-stx - [! exni] - [#:pattern (?#%app . LDERIV)] - [#:frontier (stx->list* #'LDERIV)] - [List LDERIV lderiv])]) - (if (eq? tagged-stx e1) - tail - (cons (walk e1 tagged-stx 'tag-app) tail)))] - [(AnyQ p:lambda (e1 e2 rs renames body) exni) + [(Wrap p:#%app (e1 e2 rs ?1 tagged-stx lderiv)) (R e1 - [! exni] + [! ?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)] @@ -163,34 +178,16 @@ #'?formals #'?formals* 'rename-lambda] [Block ?body body])] - [(struct p:case-lambda (e1 e2 rs renames+bodies)) - #; + [(Wrap p:case-lambda (e1 e2 rs ?1 clauses)) (R e1 - [! exni] - [#:pattern (?case-lambda [?formals . ?body] ...)] - ;; FIXME: frontier - [#:bind [(?formals* . ?body*) ...] (map car renames+bodies)] - [#:rename - (syntax/skeleton e1 (?case-lambda [?formals* . ?body*] ...)) - (syntax->list #'(?formals ...)) - (syntax->list #'(?formals* ...)) - 'rename-case-lambda] - [Block (?body ...) (map cdr renames+bodies)]) - (with-syntax ([(?case-lambda [?formals . ?body] ...) e1] - [((?formals* . ?body*) ...) (map car renames+bodies)]) - (add-frontier (apply append (map stx->list* (syntax->list #'(?body ...))))) - (let ([mid (syntax/skeleton e1 (?case-lambda [?formals* . ?body*] ...))]) - (rename-frontier #'(?formals ...) #'(?formals* ...)) - (cons (walk/foci (syntax->list #'(?formals ...)) - (syntax->list #'(?formals* ...)) - e1 mid 'rename-case-lambda) - ;; FIXME: Missing renames frames here - (R mid - [#:pattern (CASE-LAMBDA [FORMALS . BODY] ...)] - [Block (BODY ...) (map cdr renames+bodies)]))))] - [(AnyQ p:let-values (e1 e2 rs renames rhss body) exni) + [! ?1] + [#:pattern (?case-lambda . ?clauses)] + [#:frontier (stx->list* #'?clauses)] + [(CaseLambdaClauses (stx->list* #'?clauses)) + ?clauses clauses])] + [(Wrap p:let-values (e1 e2 rs ?1 renames rhss body)) (R e1 - [! exni] + [! ?1] [#:pattern (?let-values ([?vars ?rhs] ...) . ?body)] [#:frontier (append (syntax->list #'(?rhs ...)) (stx->list* #'?body))] [#:bind (([?vars* ?rhs*] ...) . ?body*) renames] @@ -201,9 +198,9 @@ 'rename-let-values] [Expr (?rhs ...) rhss] [Block ?body body])] - [(AnyQ p:letrec-values (e1 e2 rs renames rhss body) exni) + [(Wrap p:letrec-values (e1 e2 rs ?1 renames rhss body)) (R e1 - [! exni] + [! ?1] [#:pattern (?letrec-values ([?vars ?rhs] ...) . ?body)] [#:frontier (append (syntax->list #'(?rhs ...)) (stx->list* #'?body))] [#:bind (([?vars* ?rhs*] ...) . ?body*) renames] @@ -214,10 +211,10 @@ 'rename-letrec-values] [Expr (?rhs ...) rhss] [Block ?body body])] - [(AnyQ p:letrec-syntaxes+values - (e1 e2 rs srenames srhss vrenames vrhss body) exni) + [(Wrap p:letrec-syntaxes+values + (e1 e2 rs ?1 srenames srhss vrenames vrhss body)) (R e1 - [! exni] + [! ?1] [#:pattern (?lsv ([?svars ?srhs] ...) ([?vvars ?vrhs] ...) . ?body)] [#:frontier (append (syntax->list #'(?srhs ...)) (syntax->list #'(?vrhs ...)) @@ -230,165 +227,186 @@ (syntax->list #'(?svars ...)) (syntax->list #'(?svars* ...)) 'rename-lsv] - [Expr (?srhs ...) srhss] + [BindSyntaxes (?srhs ...) srhss] ;; If vrenames is #f, no var bindings to rename - [#:if vrenames - [#:bind (([?vvars** ?vrhs**] ...) . ?body**) vrenames] - [#:rename - (syntax/skeleton e1 (?lsv ([?svars* ?srhs*] ...) - ([?vvars** ?vrhs**] ...) - . ?body**)) - (syntax->list #'(?vvars* ...)) - (syntax->list #'(?vvars** ...)) - 'rename-lsv]] + [#: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]] [Expr (?vrhs ...) vrhss] [Block ?body body] - => (lambda (mid) - (list (walk mid e2 'lsv-remove-syntax))))] + [#:pattern ?form] + [#:when/np (not (eq? #'?form e2)) ;; FIXME: correct comparison? + [#:walk e2 'lsv-remove-syntax]])] ;; The auto-tagged atomic primitives - [(AnyQ p:#%datum (e1 e2 rs tagged-stx) exni) - (append (if (eq? e1 tagged-stx) - null - (list (walk e1 tagged-stx 'tag-datum))) - (if exni - (list (stumble tagged-stx (car exni))) - null))] - [(AnyQ p:#%top (e1 e2 rs tagged-stx) exni) - (with-syntax ([(?top . ?var) tagged-stx]) - (learn-definites (list #'?var))) - (append (if (eq? e1 tagged-stx) - null - (list (walk e1 tagged-stx 'tag-top))) - (if exni - (list (stumble tagged-stx (car exni))) - null))] + [(Wrap p:#%datum (e1 e2 rs ?1 tagged-stx)) + (R e1 + [#:when/np (not (eq? e1 tagged-stx)) + [#:walk tagged-stx 'tag-datum]] + [! ?1])] + [(Wrap p:#%top (e1 e2 rs ?1 tagged-stx)) + (R e1 + [#:when/np (not (eq? e1 tagged-stx)) + [#:walk tagged-stx 'tag-top]] + [#:pattern (?top . ?var)] + [#:learn (list #'?var)] + [! ?1])] ;; The rest of the automatic primitives - [(AnyQ p::STOP (e1 e2 rs) exni) + [(Wrap p::STOP (e1 e2 rs ?1)) (R e1 - [! exni])] - - [(AnyQ p:set!-macro (e1 e2 rs deriv) exni) + [! ?1])] + + [(Wrap p:set!-macro (e1 e2 rs ?1 deriv)) (R e1 - [! exni] + [! ?1] [#:frontier (list e1)] - => (lambda (mid) - (reductions* deriv)))] - [(AnyQ p:set! (e1 e2 rs id-rs rhs) exni) + [#:pattern ?form] + [Expr ?form deriv])] + [(Wrap p:set! (e1 e2 rs ?1 id-rs rhs)) (R e1 - [! exni] - [#:pattern (SET! VAR RHS)] - [#:frontier (list #'RHS)] + [! ?1] + [#:pattern (?set! ?var ?rhs)] + [#:frontier (list #'?rhs)] [#:learn id-rs] - [Expr RHS rhs])] - + [Expr ?rhs rhs])] + ;; Synthetic primitives ;; These have their own subterm replacement mechanisms - ;; FIXME: Frontier - [(and d (AnyQ p:synth (e1 e2 rs subterms))) - ;; First, compute the frontier based on the expanded subterms - ;; Run through the renames in reverse order to get the pre-renamed terms - (define synth-frontier - (parameterize ((current-frontier null)) - (let floop ([subterms subterms]) - (cond [(null? subterms) - (void)] - [(s:subterm? (car subterms)) - (floop (cdr subterms)) - (add-frontier - (list (lift/deriv-e1 (s:subterm-deriv (car subterms)))))] - [(s:rename? (car subterms)) - (floop (cdr subterms)) - (rename-frontier (s:rename-after (car subterms)) - (s:rename-before (car subterms)))])) - (current-frontier))) - (add-frontier synth-frontier) - ;; Then compute the reductions - (let loop ([term e1] [subterms subterms]) - (cond [(null? subterms) - (let ([exn (and (error-wrap? d) (error-wrap-exn d))]) - (if exn - (list (stumble term exn)) - null))] - [(s:subterm? (car subterms)) - (let* ([subterm0 (car subterms)] - [path0 (s:subterm-path subterm0)] - [deriv0 (s:subterm-deriv subterm0)]) - (let ([ctx (lambda (x) (path-replace term path0 x))]) - (append (with-context ctx - (reductions* deriv0)) - (loop (and term - (deriv? deriv0) - (path-replace term path0 (deriv-e2 deriv0))) - (cdr subterms)))))] - [(s:rename? (car subterms)) - (let* ([subterm0 (car subterms)]) - ;; FIXME: add renaming steps? - ;; FIXME: if so, coalesce? - (rename-frontier (s:rename-before subterm0) - (s:rename-after subterm0)) - (loop (and term - (path-replace term - (s:rename-path subterm0) - (s:rename-after subterm0))) - (cdr subterms)))]))] - - ;; FIXME - [(IntQ p:rename (e1 e2 rs rename inner)) - (rename-frontier (car rename) (cdr rename)) - (reductions* inner)] - - ;; Error + [(Wrap p:synth (e1 e2 rs ?1 subterms ?2)) + (R e1 + [! ?1] + [#:pattern ?form] + [#:frontier + ;; Compute the frontier based on the expanded subterms + ;; Run through the renames in reverse order to get the + ;; pre-renamed terms + (parameterize ((current-frontier null)) + (let loop ([subterms subterms]) + (cond [(null? subterms) + (void)] + [(s:subterm? (car subterms)) + (loop (cdr subterms)) + (add-frontier + (list (wderiv-e1 (s:subterm-deriv (car subterms)))))] + [(s:rename? (car subterms)) + (loop (cdr subterms)) + (rename-frontier (s:rename-after (car subterms)) + (s:rename-before (car subterms)))])) + (current-frontier))] + [(SynthItems e1) ?form subterms] + [! ?2])] + ;; FIXME: elimiate => ?? + [(Wrap p:rename (e1 e2 rs ?1 rename inner)) + (R e1 + [! ?1] + => + (lambda (e) + (rename-frontier (car rename) (cdr rename)) + (reductions* inner)))] + ;; Macros - [(IntQ mrule (e1 e2 transformation next)) - (blaze-frontier e1) - ;;(printf "frontier for mrule: ~s~n" (current-frontier)) - (append (reductions-transformation transformation) - (begin (when next (add-frontier (list (lift/deriv-e1 next)))) - (reductions* next)))] - + [(Wrap mrule (e1 e2 transformation next)) + (R e1 + [#:pattern ?form] + [Transformation ?form transformation] + [#:frontier (list (wderiv-e1 next))] + [Expr ?form next])] + ;; Lifts - - [(IntQ lift-deriv (e1 e2 first lifted-stx second)) - (blaze-frontier e1) - (let ([rs1 (reductions* first)]) - (add-frontier (list lifted-stx)) - (append rs1 - (list (walk (deriv-e2 first) lifted-stx 'capture-lifts)) - (reductions* second)))] - + + [(Wrap lift-deriv (e1 e2 first lifted-stx second)) + (R e1 + [#:pattern ?form] + [Expr ?form first] + [#:frontier (list lifted-stx)] + [#:walk lifted-stx 'capture-lifts] + [Expr ?form second])] + + [(Wrap lift/let-deriv (e1 e2 first lifted-stx second)) + (R e1 + [#:pattern ?form] + [Expr ?form first] + [#:frontier (list lifted-stx)] + [#:walk lifted-stx 'capture-lifts] + [Expr ?form second])] + ;; Skipped - - [#f null] - - #; - [else (error 'reductions "unmatched case: ~s" d)])) + [#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) + (blaze-frontier es1) + (match clauses + ['() + (RSunit null)] + [(cons (Wrap clc (?1 rename body)) rest) + (R es1 + [! ?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] + [Block ?body body] + [(CaseLambdaClauses (cdr es1)) + ?rest rest])])) + + ;; mk-synth-items-reductions : syntax -> (list-of SynthItem) -> (RS syntax) + (define ((mk-synth-items-reductions e1) subterms) + (let loop ([term e1] [subterms subterms]) + (cond [(null? subterms) + (RSunit e1)] + [(s:subterm? (car subterms)) + (let* ([subterm0 (car subterms)] + [path0 (s:subterm-path subterm0)] + [deriv0 (s:subterm-deriv subterm0)]) + (let ([ctx (lambda (x) (path-replace term path0 x))]) + (RSseq (lambda () + (with-context ctx (reductions* deriv0))) + (lambda () + (loop (path-replace term path0 (wderiv-e2 deriv0)) + (cdr subterms))))))] + [(s:rename? (car subterms)) + (let* ([subterm0 (car subterms)]) + ;; FIXME: add renaming steps? + ;; FIXME: if so, coalesce? + (rename-frontier (s:rename-before subterm0) + (s:rename-after subterm0)) + (loop (path-replace term + (s:rename-path subterm0) + (s:rename-after subterm0)) + (cdr subterms)))]))) - ;; reductions-transformation : Transformation -> ReductionSequence - (define (reductions-transformation tx) + ;; transformation-reductions : Transformation -> (RS Stx) + (define (transformation-reductions tx) (match tx - [(struct transformation (e1 e2 rs me1 me2 locals seq)) - (learn-definites rs) - (append (reductions-locals e1 locals) - (list (walk e1 e2 'macro-step)))] - [(IntW transformation (e1 e2 rs me1 me2 locals seq) 'locals) - (learn-definites rs) - (reductions-locals e1 locals)] - [(ErrW transformation (e1 e2 rs me1 me2 locals seq) 'bad-transformer exn) - (learn-definites rs) - (list (stumble e1 exn))] - [(ErrW transformation (e1 e2 rs me1 me2 locals seq) 'transform exn) - (learn-definites rs) - (append (reductions-locals e1 locals) - (list (stumble e1 exn)))])) + [(Wrap transformation (e1 e2 rs ?1 me1 locals ?2 me2 seq)) + (R e1 + [! ?1] + [#:pattern ?form] + [#:learn rs] + [#:reductions (reductions-locals e1 locals)] + [! ?2] + [#:walk e2 + (list #'?form) + (list e2) + 'macro])])) - ;; reductions-locals : syntax (list-of LocalAction) -> ReductionSequence + ;; reductions-locals : syntax (list-of LocalAction) -> (RS void) (define (reductions-locals stx locals) (with-new-local-context stx - (apply append (map reductions-local locals)))) - - ;; reductions-local : LocalAction -> ReductionSequence + (RSforeach reductions-local locals))) + + ;; reductions-local : LocalAction -> (RS void) (define (reductions-local local) (match/with-derivation local [(struct local-expansion (e1 e2 me1 me2 for-stx? deriv)) @@ -398,219 +416,149 @@ "reductions: local-expand-expr not fully implemented") (reductions* deriv)] [(struct local-lift (expr id)) - (list (walk expr id 'local-lift))] + (RSadd (list (walk expr id 'local-lift)) + RSzero)] [(struct local-lift-end (decl)) - (list (walk/mono decl 'module-lift))] + (RSadd (list (walk/mono decl 'module-lift)) + RSzero)] [(struct local-bind (deriv)) (reductions* deriv)])) - ;; list-reductions : ListDerivation -> ReductionSequence + ;; list-reductions : ListDerivation -> (RS Stxs) (define (list-reductions ld) (match/with-derivation ld - [(IntQ lderiv (es1 es2 derivs)) - (let loop ([derivs derivs] [suffix es1]) - (cond [(pair? derivs) - (append - (with-context (lambda (x) (cons x (stx-cdr suffix))) - (reductions* (car derivs))) - (with-context (lambda (x) (cons (deriv-e2 (car derivs)) x)) - (loop (cdr derivs) (stx-cdr suffix))))] - [(null? derivs) - null]))] - [(ErrW lderiv (es1 es2 derivs) _ exn) - (list (stumble es1 exn))] - - [#f null])) - - ;; block-reductions : BlockDerivation -> ReductionSequence + [(Wrap lderiv (es1 es2 ?1 derivs)) + (R es1 + [! ?1] + [#:pattern (?form ...)] + [Expr (?form ...) derivs])] + [#f (RSunit null)])) + + ;; block-reductions : BlockDerivation -> (RS Stxs) (define (block-reductions bd) (match/with-derivation bd - ;; If interrupted in pass1, skip pass2 - [(IntW bderiv (es1 es2 pass1 trans pass2) 'pass1) - (let-values ([(reductions stxs) (brules-reductions pass1 es1)]) - reductions)] - ;; Otherwise, do both - [(IntQ bderiv (es1 es2 pass1 trans pass2)) - (let-values ([(reductions1 stxs1) (brules-reductions pass1 es1)]) - (append reductions1 - (if (eq? trans 'letrec) - (match pass2 - [(AnyQ lderiv (pass2-es1 _ _)) - (list (walk stxs1 pass2-es1 'block->letrec))]) - null) - (begin (add-frontier (stx->list* (lift/lderiv-es1 pass2))) - (list-reductions pass2))))] - [#f null])) - - ;; brules-reductions : (list-of-BRule) syntax-list -> ReductionSequence syntax-list - (define (brules-reductions brules all-stxs) - (let loop ([brules brules] [suffix all-stxs] [prefix null] [rss null]) - (cond [(pair? brules) - (let ([brule0 (car brules)] - [next (cdr brules)]) - (match/with-derivation brule0 - [(struct b:expr (renames head)) - (rename-frontier (car renames) (cdr renames)) - (let ([estx (deriv-e2 head)]) - (loop next (stx-cdr suffix) (cons estx prefix) - (cons (with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix)))) - (reductions* head)) - rss)))] - [(IntW b:expr (renames head) tag) - (rename-frontier (car renames) (cdr renames)) - (loop next #f #f - (cons (with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix)))) - (reductions* head)) - rss))] - [(struct b:defvals (renames head)) - (rename-frontier (car renames) (cdr renames)) - (let ([head-rs - (with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix)))) - (reductions* head))]) - (loop next (stx-cdr suffix) (cons (deriv-e2 head) prefix) - (cons head-rs rss)))] - [(AnyQ b:defstx (renames head rhs)) - (rename-frontier (car renames) (cdr renames)) - (let* ([estx (deriv-e2 head)] - [estx2 (and (deriv? rhs) - (with-syntax ([(?ds ?vars ?rhs) estx] - [?rhs* (deriv-e2 rhs)]) - (datum->syntax-object estx - `(,#'?ds ,#'?vars ,#'?rhs*) - estx estx)))]) - (loop next (stx-cdr suffix) (cons estx2 prefix) - (with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix)))) - (cons (with-context (CC ?rhs estx (?ds ?vars ?rhs)) - (reductions* rhs)) - (cons (reductions* head) - rss)))))] - [(struct b:splice (renames head tail)) - (rename-frontier (car renames) (cdr renames)) - (loop next tail prefix - (cons (list (walk/foci (deriv-e2 head) - (stx-take tail - (- (stx-improper-length tail) - (stx-improper-length (stx-cdr suffix)))) - (revappend prefix - (cons (deriv-e2 head) (stx-cdr suffix))) - (revappend prefix tail) - 'splice-block)) - (cons (with-context (lambda (x) - (revappend prefix (cons x (stx-cdr suffix)))) - (reductions* head)) - rss)))] - [(struct b:begin (renames head derivs)) - ;; FIXME - (error 'unimplemented)] - [(struct error-wrap (exn tag _inner)) - (values (list (stumble/E suffix (revappend prefix suffix) exn)) - (revappend prefix suffix))]))] - [(null? brules) - (values (apply append (reverse rss)) - (revappend prefix suffix))]))) + [(Wrap bderiv (es1 es2 pass1 trans pass2)) + (R es1 + [#:pattern ?form] + [(BRules es1) ?form pass1] + [#:when/np (eq? trans 'letrec) + [#:walk (wlderiv-es1 pass2) 'block->letrec]] + [#:frontier (stx->list* (wlderiv-es1 pass2))] + [#:pattern ?form] + [List ?form pass2])] + [#f (RSunit null)])) - ;; mbrules-reductions : MBRules (list-of syntax) -> ReductionSequence - ;; The reprocess-on-lift? argument controls the behavior of a mod:lift event. - ;; In Pass1, #t; in Pass2, #f. - (define (mbrules-reductions mbrules all-stxs reprocess-on-lift?) - ;(printf "**** MB Reductions, pass ~s~n" (if reprocess-on-lift? 1 2)) - (let* ([final-stxs #f] - [reductions - (let loop ([mbrules mbrules] [suffix all-stxs] [prefix null]) - (define (the-context x) (revappend prefix (cons x (stx-cdr suffix)))) - (cond [(pair? mbrules) - (let ([mbrule0 (car mbrules)] - [next (cdr mbrules)]) - (match/with-derivation mbrule0 - [(struct mod:skip ()) - ;(blaze-frontier (stx-car suffix)) - (loop next (stx-cdr suffix) (cons (stx-car suffix) prefix))] - [(struct mod:cons (head)) - ;(blaze-frontier (stx-car suffix)) - (rename-frontier (stx-car suffix) (lift/deriv-e1 head)) - (add-frontier (list (lift/deriv-e1 head))) - (append (with-context the-context (append (reductions* head))) - (let ([estx (and (deriv? head) (deriv-e2 head))]) - (loop next (stx-cdr suffix) (cons estx prefix))))] - [(AnyQ mod:prim (head prim)) - ;(blaze-frontier (stx-car suffix)) - (rename-frontier (stx-car suffix) (lift/deriv-e1 head)) - (add-frontier (list (lift/deriv-e1 head))) - (append (with-context the-context - (append (reductions* head) - (begin - (when prim - (add-frontier (list (lift/deriv-e1 prim)))) - (reductions* prim)))) - (let ([estx - (if prim - (lift/deriv-e2 prim) - (and (deriv? head) (deriv-e2 head)))]) - (loop next (stx-cdr suffix) (cons estx prefix))))] - [(ErrW mod:splice (head stxs) exn) - ;(blaze-frontier (stx-car suffix)) - (rename-frontier (stx-car suffix) (lift/deriv-e1 head)) - (add-frontier (list (lift/deriv-e1 head))) - (append (with-context the-context (reductions* head)) - (list (stumble (deriv-e2 head) exn)))] - [(struct mod:splice (head stxs)) - ;(blaze-frontier (stx-car suffix)) - (rename-frontier (stx-car suffix) (lift/deriv-e1 head)) - (add-frontier (list (lift/deriv-e1 head))) - (append - (with-context the-context (reductions* head)) - (let ([suffix-tail (stx-cdr suffix)] - [head-e2 (deriv-e2 head)]) - (let ([new-stxs (stx-take stxs - (- (stx-improper-length stxs) - (stx-improper-length suffix-tail)))]) - (cons (walk/foci head-e2 - new-stxs - (revappend prefix (cons head-e2 suffix-tail)) - (revappend prefix stxs) - 'splice-module) - (begin (add-frontier new-stxs) - (loop next stxs prefix))))))] - [(struct mod:lift (head stxs)) - ;; FIXME: frontier - (append - (with-context the-context (reductions* head)) - (let ([suffix-tail (stx-cdr suffix)] - [head-e2 (deriv-e2 head)]) - (let ([new-suffix (append stxs (cons head-e2 suffix-tail))]) - (cons (walk/foci null - stxs - (revappend prefix (cons head-e2 suffix-tail)) - (revappend prefix new-suffix) - 'splice-lifts) - (loop next - new-suffix - prefix)))))] - [(struct mod:lift-end (tail)) - ;; FIXME: frontier - (append - (if (pair? tail) - (list (walk/foci null - tail - (revappend prefix suffix) - (revappend prefix tail) - 'splice-module-lifts)) - null) - (loop next tail prefix))]))] - [(null? mbrules) - (set! final-stxs (reverse prefix)) - null]))]) - (values reductions final-stxs))) + ;; mk-brules-reductions : stxs -> (list-of BRule) -> (RS Stxs) + (define ((mk-brules-reductions es1) brules) + (match brules + ['() + (RSunit null)] + [(cons (Wrap b:expr (renames head)) rest) + (R es1 + [#:pattern (?first . ?rest)] + [#:bind ?first* (cdr renames)] + [#:rename/no-step ?first (car renames) (cdr renames)] + [Expr ?first head] + [(BRules (stx-cdr es1)) ?rest rest])] + [(cons (Wrap b:defvals (renames head ?1)) rest) + (R es1 + [#:pattern (?first . ?rest)] + [#:bind ?first* (cdr renames)] + [#:rename/no-step ?first (car renames) (cdr renames)] + [Expr ?first head] + [! ?1] + [#:pattern ((?define-values ?vars ?rhs) . ?rest)] + [#:learn (syntax->list #'?vars)] + [(BRules (stx-cdr es1)) ?rest rest])] + [(cons (Wrap b:defstx (renames head ?1 bindrhs)) rest) + (R es1 + [#:pattern (?first . ?rest)] + [#:bind ?first* (cdr renames)] + [#:rename/no-step ?first (car renames) (cdr renames)] + [Expr ?first head] + [! ?1] + [#:pattern ((?define-syntaxes ?vars ?rhs) . ?rest)] + [#:learn (syntax->list #'?vars)] + [BindSyntaxes ?rhs bindrhs] + [(BRules (stx-cdr es1)) ?rest rest])] + [(cons (Wrap b:splice (renames head ?1 tail ?2)) rest) + (R es1 + [#:pattern (?first . ?rest)] + [#:bind ?first* (cdr renames)] + [#: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] + [! ?2] + [#:pattern ?forms] + [(BRules (stx->list* #'?forms)) ?forms rest])] + [(cons (Wrap b:error (exn)) rest) + (R es1 + [! exn])])) - (define (stx->list* stx) - (cond [(pair? stx) - (cons (car stx) (stx->list* (cdr stx)))] - [(null? stx) - null] - [(syntax? stx) - (let ([x (syntax-e stx)]) - (if (pair? x) - (cons (car x) (stx->list* (cdr x))) - (list stx)))] - [else null])) + ;; bind-syntaxes-reductions : BindSyntaxes -> (RS stx) + (define (bind-syntaxes-reductions bindrhs) + (match bindrhs + [(Wrap bind-syntaxes (rhs ?1)) + (R (wderiv-e1 rhs) + [#:pattern ?form] + [Expr ?form rhs] + [! ?1])])) + + ;; mk-mbrules-reductions : stx -> (list-of MBRule) -> (RS stxs) + (define ((mk-mbrules-reductions es1) mbrules) + (match mbrules + ['() + (RSunit null)] + [(cons (Wrap mod:skip ()) rest) + (R es1 + [#:pattern (?first . ?rest)] + [(ModulePass (stx-cdr es1)) ?rest rest])] + [(cons (Wrap mod:cons (head)) 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] + [! ?1] + [#:walk tail + (list #'?first) + (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) + (R es1 + [#:pattern (?first . ?rest)] + [Expr ?first head] + [#:pattern ?forms] + [#:walk (append stxs #'?forms) + null + stxs + 'splice-lifts] + [(ModulePass #'?forms) ?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])])) + ) diff --git a/collects/macro-debugger/model/steps.ss b/collects/macro-debugger/model/steps.ss index 4ad8e07..64a3b03 100644 --- a/collects/macro-debugger/model/steps.ss +++ b/collects/macro-debugger/model/steps.ss @@ -1,7 +1,8 @@ (module steps mzscheme (require "deriv.ss" - "deriv-util.ss") + "deriv-util.ss" + "deriv-find.ss") (provide (all-defined)) ;; A ReductionSequence is a (list-of Reduction) @@ -71,7 +72,7 @@ ;; A StepType is a simple in the following alist. (define step-type-meanings - '((macro-step . "Macro transformation") + '((macro . "Macro transformation") (rename-lambda . "Rename formal parameters") (rename-case-lambda . "Rename formal parameters") diff --git a/collects/macro-debugger/model/stx-util.ss b/collects/macro-debugger/model/stx-util.ss index cceef1f..0a62d09 100644 --- a/collects/macro-debugger/model/stx-util.ss +++ b/collects/macro-debugger/model/stx-util.ss @@ -31,25 +31,32 @@ [(syntax/restamp (pa (... ...)) new-expr old-expr) #`(let ([new-parts (stx->list new-expr)] [old-parts (stx->list old-expr)]) - #; + ;; FIXME (unless (= (length new-parts) (length old-parts)) (printf "** syntax/restamp~n~s~n" (quote-syntax #,stx)) (printf "pattern : ~s~n" (syntax-object->datum #'(pa (... ...)))) - (printf "old parts: ~s~n" old-parts) - (printf "new parts: ~s~n" new-parts)) + (printf "old parts: ~s~n" (map syntax-object->datum old-parts)) + (printf "new parts: ~s~n" (map syntax-object->datum new-parts))) (d->so old-expr (map (lambda (new old) (syntax/restamp pa new old)) new-parts old-parts)))] [(syntax/restamp (pa . pb) new-expr old-expr) - #'(let ([na (stx-car new-expr)] - [nb (stx-cdr new-expr)] - [oa (stx-car old-expr)] - [ob (stx-cdr old-expr)]) - (d->so old-expr - (cons (syntax/restamp pa na oa) - (syntax/restamp pb nb ob))))] + ;; FIXME + #'(begin + (unless (and (stx-pair? new-expr) (stx-pair? old-expr)) + (printf "** syntax/restamp~n~s~n" (quote-syntax #,stx)) + (printf "pattern : ~s~n" (syntax-object->datum (quote-syntax (pa . pb)))) + (printf "old parts: ~s~n" old-expr) + (printf "new parts: ~s~n" new-expr)) + (let ([na (stx-car new-expr)] + [nb (stx-cdr new-expr)] + [oa (stx-car old-expr)] + [ob (stx-cdr old-expr)]) + (d->so old-expr + (cons (syntax/restamp pa na oa) + (syntax/restamp pb nb ob)))))] [(syntax/restamp pvar new-expr old-expr) #'new-expr])) @@ -64,10 +71,30 @@ (cond [(zero? n) null] [else (cons (stx-car items) (stx-take (stx-cdr items) (sub1 n)))])) + (define (take-if-possible items n) + (unless (number? n) + (raise-type-error 'take-if-possible "number" n)) + (if (and (pair? items) (positive? n)) + (cons (car items) (take-if-possible (cdr items) (sub1 n))) + null)) + ;; stx-improper-length : syntax -> number (define (stx-improper-length stx) (let loop ([stx stx] [n 0]) (if (stx-pair? stx) (loop (stx-cdr stx) (add1 n)) n))) - ) + + (define (stx->list* stx) + (cond [(pair? stx) + (cons (car stx) (stx->list* (cdr stx)))] + [(null? stx) + null] + [(syntax? stx) + (let ([x (syntax-e stx)]) + (if (pair? x) + (cons (car x) (stx->list* (cdr x))) + (list stx)))] + [else null])) + +) diff --git a/collects/macro-debugger/model/trace.ss b/collects/macro-debugger/model/trace.ss index a6d4d7c..5898e8a 100644 --- a/collects/macro-debugger/model/trace.ss +++ b/collects/macro-debugger/model/trace.ss @@ -1,14 +1,11 @@ (module trace mzscheme - (require (lib "lex.ss" "parser-tools") - (lib "class.ss")) + (require (lib "lex.ss" "parser-tools")) (require "deriv.ss" "deriv-parser.ss" "deriv-tokens.ss" - "reductions.ss" - "hide.ss" - "hiding-policies.ss") - + "reductions.ss") + (provide trace-verbose? trace trace/result diff --git a/collects/macro-debugger/model/yacc-ext.ss b/collects/macro-debugger/model/yacc-ext.ss index e8b65a9..9af3f87 100644 --- a/collects/macro-debugger/model/yacc-ext.ss +++ b/collects/macro-debugger/model/yacc-ext.ss @@ -4,7 +4,8 @@ (require (prefix yacc: (lib "yacc.ss" "parser-tools"))) (provide parser options - productions) + productions + definitions) (define-syntax options (lambda (stx) @@ -13,32 +14,37 @@ (define-syntax productions (lambda (stx) (raise-syntax-error #f "productions keyword used out of context" stx))) - + + (define-syntax definitions + (lambda (stx) + (raise-syntax-error #f "definitions keyword used out of context" stx))) + (define-syntax (parser stx) (syntax-case stx () [(parser form ...) - (let* ([stop-list (list #'begin #'options #'productions)] - [forms (syntax->list #'(form ...))] - [options+productions - (let loop ([forms forms] [opts null] [prods null]) - (if (pair? forms) - (let ([eform0 (local-expand (car forms) 'expression stop-list)] - [forms (cdr forms)]) - (syntax-case eform0 (begin options productions) - [(begin subform ...) - (loop (append (syntax->list #'(subform ...)) forms) opts prods)] - [(options subform ...) - (loop forms (append (syntax->list #'(subform ...)) opts) prods)] - [(productions subform ...) - (loop forms opts (append (syntax->list #'(subform ...)) prods))] - [else - (raise-syntax-error #f "bad parser subform" eform0)])) - (cons opts (reverse prods))))] - [opts (car options+productions)] - [prods (cdr options+productions)]) + (let ([stop-list (list #'begin #'options #'productions #'definitions)] + [forms (syntax->list #'(form ...))]) + (define-values (opts prods defs) + (let loop ([forms forms] [opts null] [prods null] [defs null]) + (if (pair? forms) + (let ([eform0 (local-expand (car forms) 'expression stop-list)] + [forms (cdr forms)]) + (syntax-case eform0 (begin options productions definitions) + [(begin subform ...) + (loop (append (syntax->list #'(subform ...)) forms) opts prods defs)] + [(options subform ...) + (loop forms (append (syntax->list #'(subform ...)) opts) prods defs)] + [(productions subform ...) + (loop forms opts (append (syntax->list #'(subform ...)) prods) defs)] + [(definitions subform ...) + (loop forms opts prods (append (syntax->list #'(subform ...)) defs))] + [else + (raise-syntax-error #f "bad parser subform" eform0)])) + (values opts prods defs)))) (with-syntax ([(opt ...) opts] - [(prod ...) prods]) - #'(yacc:parser opt ... (grammar prod ...))))])) - - + [(prod ...) prods] + [(def ...) defs]) + #'(let () + def ... + (#%expression (yacc:parser opt ... (grammar prod ...))))))])) ) diff --git a/collects/macro-debugger/model/yacc-interrupted.ss b/collects/macro-debugger/model/yacc-interrupted.ss index 8530b3e..faf8627 100644 --- a/collects/macro-debugger/model/yacc-interrupted.ss +++ b/collects/macro-debugger/model/yacc-interrupted.ss @@ -1,30 +1,33 @@ (module yacc-interrupted mzscheme - (require "deriv.ss" - "yacc-ext.ss") - (provide ! ? - production/I - productions/I + (require-for-syntax (lib "etc.ss")) + (require "yacc-ext.ss") + (provide ! ? !! + define-production-splitter skipped-token-values %skipped %action) ;; Grammar macros for "interrupted parses" - ;; Uses interrupted-wrap and error-wrap from deriv.ss - + (define-syntax ! (lambda (stx) (raise-syntax-error #f "keyword ! used out of context" stx))) - + + (define-syntax !! + (lambda (stx) + (raise-syntax-error #f "keyword !! used out of context" stx))) + (define-syntax ? (lambda (stx) (raise-syntax-error #f "keyword ? used out of context" stx))) - - (define-syntax (productions/I stx) - (syntax-case stx () - [(productions/I def ...) - #'(begin (production/I def) ...)])) - + + (define-syntax define-production-splitter + (syntax-rules () + [(define-production-splitter name ok intW) + (define-syntax name + (make-production-splitter #'ok #'intW))])) + (define-for-syntax (partition-options/alternates forms) (let loop ([forms forms] [options null] [alts null]) (if (pair? forms) @@ -33,17 +36,17 @@ (loop (cdr forms) (cons (cons #:args #'args) options) alts)] [(#:skipped expr) (loop (cdr forms) (cons (cons #:skipped #'expr) options) alts)] - [(#:no-interrupted) - (loop (cdr forms) (cons (cons #:no-interrupted #t) options) alts)] + [(#:wrap) + (loop (cdr forms) (cons (cons #:wrap #t) options) alts)] [(#:no-wrap) (loop (cdr forms) (cons (cons #:no-wrap #t) options) alts)] - [(#:no-wrap-error) - (loop (cdr forms) (cons (cons #:no-wrap-error #t) options) alts)] [(kw . args) (keyword? (syntax-e #'kw)) - (raise-syntax-error #f "bad keyword" (car forms))] + (raise-syntax-error 'split "bad keyword" (car forms))] [(pattern action) - (loop (cdr forms) options (cons (cons #'pattern #'action) alts))]) + (loop (cdr forms) options (cons (cons #'pattern #'action) alts))] + [other + (raise-syntax-error 'split "bad grammar option or alternate" #'other)]) (values options (reverse alts))))) (define-for-syntax (symbol+ . args) @@ -53,118 +56,203 @@ [(number? x) (number->string x)] [(symbol? x) (symbol->string x)])) (string->symbol (apply string-append (map norm args)))) - + (define-for-syntax (I symbol) (syntax-local-introduce (syntax-local-get-shadower (datum->syntax-object #f symbol)))) - - (define-for-syntax (elaborate-skipped-tail head tail action) - (define new-tail - (let loop ([parts tail]) - (syntax-case parts (? !) - [() #'()] - [(! . parts-rest) (loop #'((! #f) . parts-rest))] - [((! expr) . parts-rest) - (with-syntax ([NoError (I 'NoError)] - [parts-rest (loop #'parts-rest)]) - #'(NoError . parts-rest))] + + (define-for-syntax ($name n) + (I (symbol+ '$ n))) + + (define-for-syntax (interrupted-name s) + (I (symbol+ s '/Interrupted))) + + (define-for-syntax (skipped-name s) + (I (symbol+ s '/Skipped))) + + (define-for-syntax (elaborate-skipped-tail head tail position args mk-action) + (define-values (new-tail new-arguments) + (let loop ([parts tail] [position position] [rtail null] [arguments null]) + (syntax-case parts (? ! !!) + [() + (values (reverse rtail) (reverse arguments))] + [(! . parts-rest) + (loop #'parts-rest position rtail (cons #'#f arguments))] + [(!! . parts-rest) + (raise-syntax-error 'split + "cannot have !! after potential error" + #'!!)] [((? NT) . parts-rest) - (loop #'((? NT #f) . parts-rest))] - [((? NT expr) . parts-rest) - (loop #'(NT . parts-rest))] - [(part0 . parts-rest) - (identifier? #'part0) - (with-syntax ([part0/Skipped (I (symbol+ #'part0 '/Skipped))] - [parts-rest (loop #'parts-rest)]) - #'(part0/Skipped . parts-rest))]))) - (with-syntax ([head head] - [new-tail new-tail]) - (cons #'(head . new-tail) - action))) - - (define-for-syntax (elaborate-successful-alternate alt) + (loop #'(NT . parts-rest) position rtail arguments)] + [(NT . parts-rest) + (identifier? #'NT) + (loop #'parts-rest + (add1 position) + (cons (skipped-name #'NT) rtail) + (cons ($name position) arguments))]))) + (define arguments (append (reverse args) new-arguments)) + (cons #`(#,head . #,new-tail) + (mk-action arguments))) + + (define-for-syntax ((make-elaborate-successful-alternate wrap? okW) alt) (define pattern (car alt)) - (define action (cdr alt)) - (cons (let loop ([parts pattern]) - (syntax-case parts (? !) - [() #'()] - [(! . parts-rest) - (loop #'((! #f) . parts-rest))] - [((! expr) . parts-rest) - (with-syntax ([NoError (I 'NoError)] - [parts-rest (loop #'parts-rest)]) - #'(NoError . parts-rest))] - [((? NT) . parts-rest) - (loop #'((? NT #f) . parts-rest))] - [((? NT expr) . parts-rest) - (with-syntax ([parts-rest (loop #'parts-rest)]) - #'(NT . parts-rest))] - [(part0 . parts-rest) - (identifier? #'part0) - (with-syntax ([parts-rest (loop #'parts-rest)]) - #'(part0 . parts-rest))])) - action)) - - (define-for-syntax (elaborate-interrupted-alternate alt wrap? wrap-error?) + (define action-function (cdr alt)) + (define-values (new-patterns arguments) + (let loop ([parts pattern] [rpattern null] [position 1] [args null]) + (syntax-case parts (? ! !!) + [() (values (list (reverse rpattern)) (reverse args))] + [(! . parts-rest) + (loop #'parts-rest rpattern position (cons #'#f args))] + [(!!) + (values null null)] + [((? NT) . parts-rest) + (loop (cons #'NT #'parts-rest) rpattern position args)] + [(NT . parts-rest) + (identifier? #'NT) + (loop #'parts-rest (cons #'NT rpattern) + (add1 position) (cons ($name position) args))]))) + (map (lambda (new-pattern) + (cons (datum->syntax-object #f new-pattern pattern) + #`(#,action-function #,(if wrap? okW #'values) #,@arguments))) + new-patterns)) + + (define-for-syntax ((make-elaborate-interrupted-alternate wrap? intW) alt) (define pattern (car alt)) - (define action (cdr alt)) - (let loop ([parts pattern] [position 1]) - (syntax-case parts (? !) + (define action-function (cdr alt)) + (define (int-action args) + (let ([wrapf (if wrap? #`(lambda (x) (#,intW x)) #'values)]) + #`(#,action-function #,wrapf #,@args))) + (let loop ([parts pattern] [position 1] [args null]) + (syntax-case parts (? ! !!) [() ;; Can't be interrupted null] [(! . parts-rest) - (loop #'((! #f) . parts-rest) position)] - [((! expr) . parts-rest) (cons ;; Error occurs - (with-syntax ([Error (I 'syntax-error #;Error)] - [action action] - [position-argument (I (symbol+ '$ position))]) - (elaborate-skipped-tail - #'Error - #'parts-rest - (if wrap-error? - #'(make-error-wrap position-argument expr action) - #'action))) + (elaborate-skipped-tail (I 'syntax-error) + #'parts-rest + (add1 position) + (cons ($name position) args) + int-action) ;; Error doesn't occur - (with-syntax ([NoError (I 'NoError)]) - (loop #'(NoError . parts-rest) position)))] + (loop #'parts-rest position (cons #'#f args)))] + [(!!) + (cons + (elaborate-skipped-tail (I 'syntax-error) + #'() + (add1 position) + (cons ($name position) args) + int-action) + null)] [((? NT) . parts-rest) - (loop #'((? NT #f) . parts-rest) position)] - [((? NT expr) . parts-rest) (cons ;; NT is interrupted - (with-syntax ([NT/I (I (symbol+ #'NT '/Interrupted))] - [action action]) - (elaborate-skipped-tail - #'NT/I - #'parts-rest - (if wrap? - #'(make-interrupted-wrap expr action) - #'action))) + (elaborate-skipped-tail (I (symbol+ #'NT '/Interrupted)) + #'parts-rest + (add1 position) + (cons ($name position) args) + int-action) ;; NT is not interrupted - (loop #'(NT . parts-rest) position))] + (loop #'(NT . parts-rest) position args))] [(part0 . parts-rest) (identifier? #'part0) (map (lambda (clause) (cons #`(part0 . #,(car clause)) (cdr clause))) - (loop #'parts-rest (add1 position)))]))) + (loop #'parts-rest (add1 position) (cons ($name position) args)))]))) + + (define-for-syntax (generate-action-name nt pos) + (syntax-local-get-shadower + (datum->syntax-object #f (symbol+ 'action-for- nt '/ pos)))) - (define-syntax (production/I stx) + (define-for-syntax ((make-rewrite-alt+def nt args-spec) alt pos) + (define pattern (car alt)) + (define action (cdr alt)) + (define-values (var-indexes non-var-indexes) + (let loop ([pattern pattern] [n 1] [vars null] [nonvars null]) + (syntax-case pattern () + [(first . more) + (syntax-case #'first (! ? !!) + [! + (loop #'more (add1 n) (cons n vars) nonvars)] + [(! . _) + (raise-syntax-error 'split + "misuse of ! grammar form" + pattern #'first)] + [!! + (when (pair? (syntax-e #'more)) + (raise-syntax-error 'split + "nothing may follow !!" + pattern)) + (loop #'more (add1 n) (cons n vars) nonvars)] + [(!! . _) + (raise-syntax-error 'split + "misuse of !! grammar form" + pattern #'first)] + [(? NT) + (identifier? #'NT) + (loop #'more (add1 n) (cons n vars) nonvars)] + [(? . _) + (raise-syntax-error 'split + "misuse of ? grammar form" + pattern #'first)] + [NT + (identifier? #'NT) + (loop #'more (add1 n) (cons n vars) nonvars)] + [other + (raise-syntax-error 'rewrite-pattern + "invalid grammar pattern" + pattern #'first)])] + [() + (values (reverse vars) (reverse nonvars))]))) + (define variables (map $name var-indexes)) + (define non-var-names (map $name non-var-indexes)) + (define action-function (generate-action-name nt pos)) + (cons (cons pattern action-function) + (with-syntax ([(var ...) variables] + [(nonvar ...) non-var-names] + [action-function action-function] + [action action]) + #`(define (action-function wrap var ...) + (let-syntax ([nonvar invalid-$name-use] ...) + #,(if args-spec + #`(lambda #,args-spec (wrap action)) + #`(wrap action))))))) + + (define-for-syntax (invalid-$name-use stx) + (raise-syntax-error #f "no value for positional variable" stx)) + + ;; An alternate is (cons pattern action-expr) + ;; An alternate* is (cons pattern action-function-name) + + (define-for-syntax ((make-production-splitter okW intW) stx) (syntax-case stx () - [(production/I (name form ...)) + [(_ (name form ...)) (let () - (define-values (options alternates) + (define-values (options alternates0) (partition-options/alternates (syntax->list #'(form ...)))) + (define wrap? + (let ([wrap? (assq #:wrap options)] + [no-wrap? (assq #:no-wrap options)]) + (unless (and (or wrap? no-wrap?) (not (and wrap? no-wrap?))) + (raise-syntax-error 'split + "must specify exactly one of #:wrap, #:no-wrap" + stx)) + (and wrap? #t))) + (define args-spec + (let ([p (assq #:args options)]) (and p (cdr p)))) + (define rewrite-alt+def (make-rewrite-alt+def #'name args-spec)) + (define alternates+definitions + (map rewrite-alt+def alternates0 (build-list (length alternates0) add1))) + (define alternates (map car alternates+definitions)) + (define action-definitions (map cdr alternates+definitions)) + (define elaborate-successful-alternate + (make-elaborate-successful-alternate wrap? okW)) + (define elaborate-interrupted-alternate + (make-elaborate-interrupted-alternate wrap? intW)) (define successful-alternates - (map elaborate-successful-alternate alternates)) + (apply append (map elaborate-successful-alternate alternates))) (define interrupted-alternates - (apply append - (map (lambda (a) - (elaborate-interrupted-alternate a - (not (assq #:no-wrap options)) - (not (assq #:no-wrap-error options)))) - alternates))) + (apply append (map elaborate-interrupted-alternate alternates))) (with-syntax ([((success-pattern . success-action) ...) successful-alternates] [((interrupted-pattern . interrupted-action) ...) @@ -175,19 +263,15 @@ [name/Interrupted (I (symbol+ #'name '/Interrupted))] [%action ((syntax-local-certifier) #'%action)]) #`(begin + (definitions #,@action-definitions) (productions - (name [success-pattern - (%action args-spec success-action)] - ...) - (name/Skipped [() (%skipped args-spec skip-spec)])) - #,(if (and (not (assq #:no-interrupted options)) - (pair? interrupted-alternates)) - #'(productions - (name/Interrupted [interrupted-pattern - (%action args-spec interrupted-action)] - ...)) - #'(begin)))))])) - + (name [success-pattern success-action] ...) + #,(if (pair? interrupted-alternates) + #'(name/Interrupted [interrupted-pattern interrupted-action] + ...) + #'(name/Interrupted [(IMPOSSIBLE) #f])) + (name/Skipped [() (%skipped args-spec skip-spec)])))))])) + (define-syntax (skipped-token-values stx) (syntax-case stx () [(skipped-token-values) @@ -201,19 +285,18 @@ (with-syntax ([name/Skipped (I (symbol+ #'name '/Skipped))]) #'(begin (productions (name/Skipped [() value])) (skipped-token-values . more)))])) - + (define-syntax (%skipped stx) (syntax-case stx () [(%skipped args (#:skipped . expr)) #'(%action args expr)] [(%skipped args #f) #'(%action args #f)])) - + (define-syntax (%action stx) (syntax-case stx () - [(elaborate-action (#:args . args) action) + [(%action (#:args . args) action) #'(lambda args action)] - [(elaborate-action #f action) + [(%action #f action) #'action])) - - ) \ No newline at end of file + ) diff --git a/collects/macro-debugger/syntax-browser/controller.ss b/collects/macro-debugger/syntax-browser/controller.ss index 3231c9a..7882d4f 100644 --- a/collects/macro-debugger/syntax-browser/controller.ss +++ b/collects/macro-debugger/syntax-browser/controller.ss @@ -27,13 +27,13 @@ (mixin (displays-manager<%>) (selection-manager<%>) (inherit-field displays) (field/notify selected-syntax (new notify-box% (value #f))) - + (super-new) (listen-selected-syntax (lambda (new-value) (for-each (lambda (display) (send display refresh)) displays))))) - + ;; mark-manager-mixin (define mark-manager-mixin (mixin () (mark-manager<%>) diff --git a/collects/macro-debugger/syntax-browser/interfaces.ss b/collects/macro-debugger/syntax-browser/interfaces.ss index 240ddb8..dc35d1d 100644 --- a/collects/macro-debugger/syntax-browser/interfaces.ss +++ b/collects/macro-debugger/syntax-browser/interfaces.ss @@ -15,14 +15,11 @@ ;; selection-manager<%> (define selection-manager<%> (interface () - ;; set-selected-syntax : syntax -> void + ;; selected-syntax : syntax/#f set-selected-syntax - - ;; get-selected-syntax : -> syntax get-selected-syntax - - ;; listen-selected-syntax : (syntax -> void) -> void - listen-selected-syntax)) + listen-selected-syntax + )) ;; mark-manager<%> ;; Manages marks, mappings from marks to colors diff --git a/collects/macro-debugger/syntax-browser/text.ss b/collects/macro-debugger/syntax-browser/text.ss index 0407472..609f25e 100644 --- a/collects/macro-debugger/syntax-browser/text.ss +++ b/collects/macro-debugger/syntax-browser/text.ss @@ -4,11 +4,16 @@ (lib "class.ss") (lib "mred.ss" "mred") (lib "arrow.ss" "drscheme") - (lib "framework.ss" "framework")) + (lib "framework.ss" "framework") + "../util/notify.ss") - (provide text:mouse-drawings<%> + (provide text:hover<%> + text:hover-identifier<%> + text:mouse-drawings<%> text:arrows<%> + text:hover-mixin + text:hover-identifier-mixin text:mouse-drawings-mixin text:tacking-mixin text:arrows-mixin) @@ -26,6 +31,8 @@ ;; A Drawing is (make-drawing number number (??? -> void) boolean boolean) (define-struct drawing (start end draw visible? tacked?) #f) + (define-struct idloc (start end id) #f) + (define (mean x y) (/ (+ x y) 2)) @@ -57,6 +64,16 @@ (send dc set-text-background old-background) (send dc set-text-mode old-mode)))) + (define text:hover<%> + (interface (text:basic<%>) + update-hover-position)) + + (define text:hover-identifier<%> + (interface () + get-hovered-identifier + set-hovered-identifier + listen-hovered-identifier)) + (define text:mouse-drawings<%> (interface (text:basic<%>) add-mouse-drawing @@ -69,8 +86,51 @@ add-question-arrow add-billboard)) + (define text:hover-mixin + (mixin (text:basic<%>) (text:hover<%>) + (inherit dc-location-to-editor-location + find-position) + + (define/override (on-default-event ev) + (define gx (send ev get-x)) + (define gy (send ev get-y)) + (define-values (x y) (dc-location-to-editor-location gx gy)) + (define pos (find-position x y)) + (super on-default-event ev) + (case (send ev get-event-type) + ((enter motion leave) + (update-hover-position pos)))) + + (define/public (update-hover-position pos) + (void)) + + (super-new))) + + (define text:hover-identifier-mixin + (mixin (text:hover<%>) (text:hover-identifier<%>) + (field/notify hovered-identifier (new notify-box% (value #f))) + + (define idlocs null) + + (define/public (add-identifier-location start end id) + (set! idlocs (cons (make-idloc start end id) idlocs))) + + (define/public (delete-all-identifier-locations) + (set! idlocs null) + (set-hovered-identifier #f)) + + (define/override (update-hover-position pos) + (super update-hover-position pos) + (let search ([idlocs idlocs]) + (cond [(null? idlocs) (set-hovered-identifier #f)] + [(and (<= (idloc-start (car idlocs)) pos) + (< pos (idloc-end (car idlocs)))) + (set-hovered-identifier (idloc-id (car idlocs)))] + [else (search (cdr idlocs))]))) + (super-new))) + (define text:mouse-drawings-mixin - (mixin (text:basic<%>) (text:mouse-drawings<%>) + (mixin (text:hover<%>) (text:mouse-drawings<%>) (inherit dc-location-to-editor-location find-position invalidate-bitmap-cache) @@ -101,16 +161,10 @@ (when (or (drawing-visible? d) (unbox (drawing-tacked? d))) ((drawing-draw d) this dc left top right bottom dx dy)))))) - (define/override (on-default-event ev) - (define gx (send ev get-x)) - (define gy (send ev get-y)) - (define-values (x y) (dc-location-to-editor-location gx gy)) - (define pos (find-position x y)) - (super on-default-event ev) - (case (send ev get-event-type) - ((enter motion leave) - (let ([changed? (update-visible-drawings pos)]) - (when changed? (invalidate-bitmap-cache 0.0 0.0 +inf.0 +inf.0)))))) + (define/override (update-hover-position pos) + (super update-hover-position pos) + (let ([changed? (update-visible-drawings pos)]) + (when changed? (invalidate-bitmap-cache 0.0 0.0 +inf.0 +inf.0)))) (define/private (update-visible-drawings pos) (let ([changed? #f]) @@ -260,7 +314,8 @@ (define text:mouse-drawings% (text:mouse-drawings-mixin - text:standard-style-list%)) + (text:hover-mixin + text:standard-style-list%))) (define text:arrows% (text:arrows-mixin diff --git a/collects/macro-debugger/syntax-browser/widget.ss b/collects/macro-debugger/syntax-browser/widget.ss index e180453..1983294 100644 --- a/collects/macro-debugger/syntax-browser/widget.ss +++ b/collects/macro-debugger/syntax-browser/widget.ss @@ -49,14 +49,12 @@ (widget this))) (send -text lock #t) + (send -split-panel set-percentages (list (- 1 props-percentage) props-percentage)) ;; syntax-properties-controller<%> methods - (define/public (set-syntax stx) - (send props set-syntax stx)) - (define/public (props-shown?) (send -props-panel is-shown?)) @@ -128,6 +126,7 @@ "purple"))) (send range get-ranges id))] [_ (void)]) + (let ([binder (get-binder id)]) (when binder (for-each @@ -150,7 +149,7 @@ (send range get-ranges binder))))) (send range get-identifier-list)))) display))) - + (define/public (add-separator) (with-unlock -text (send* -text @@ -163,9 +162,6 @@ (send -text delete-all-drawings)) (send controller remove-all-syntax-displays)) - (define/public (select-syntax stx) - (send controller select-syntax stx)) - (define/public (get-text) -text) ;; internal-add-syntax : syntax -> display @@ -225,8 +221,11 @@ (class (text:arrows-mixin (text:tacking-mixin (text:mouse-drawings-mixin - (text:hide-caret/selection-mixin - (editor:standard-style-list-mixin text:basic%))))) + (text:hover-mixin + (text:hide-caret/selection-mixin + (editor:standard-style-list-mixin text:basic%)))))) + (inherit set-autowrap-bitmap) (define/override (default-style-name) "Basic") - (super-new))) + (super-new (auto-wrap #t)) + (set-autowrap-bitmap #f))) ) diff --git a/collects/macro-debugger/view/hiding-panel.ss b/collects/macro-debugger/view/hiding-panel.ss index 0010d3f..3d6fa84 100644 --- a/collects/macro-debugger/view/hiding-panel.ss +++ b/collects/macro-debugger/view/hiding-panel.ss @@ -6,7 +6,8 @@ (lib "boundmap.ss" "syntax") "util.ss" "../model/synth-engine.ss" - "../syntax-browser/util.ss") + "../syntax-browser/util.ss" + "../util/hiding.ss") (provide macro-hiding-prefs-widget%) (define mode:disable "Disable") @@ -36,11 +37,9 @@ (when (pair? policies) ((car policies) id binding return) (loop (cdr policies)))) - (cond [(and hide-mzscheme? (symbol? def-mod) - (regexp-match #rx"^#%" (symbol->string def-mod))) + (cond [(and hide-mzscheme? def-mod (scheme-module? def-mod)) #f] - [(and hide-libs? def-mod - (lib-module? def-mod)) + [(and hide-libs? def-mod (lib-module? def-mod)) #f] [(and hide-contracts? def-name (regexp-match #rx"^provide/contract-id-" @@ -290,23 +289,16 @@ (super-new) (update-visibility))) - (define (lib-module? 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)] - [else #f])))) - (define (get-id-key id) - (let ([binding - (or (identifier-binding id) - (identifier-transformer-binding id))]) + id + #; ;; FIXME + (let ([binding (identifier-binding id)]) (get-id-key/binding id binding))) (define (get-id-key/binding id binding) - (cond [(pair? binding) - binding] - [else id])) + (cond [(pair? binding) + (list (car binding) (cadr binding))] + [else id])) (define (key=? key1 key2) (cond [(and (identifier? key1) (identifier? key2)) diff --git a/collects/macro-debugger/view/stepper.ss b/collects/macro-debugger/view/stepper.ss index 9c24b1d..df541c9 100644 --- a/collects/macro-debugger/view/stepper.ss +++ b/collects/macro-debugger/view/stepper.ss @@ -16,6 +16,7 @@ (prefix s: "../syntax-browser/params.ss") "../model/deriv.ss" "../model/deriv-util.ss" + "../model/deriv-find.ss" "../model/trace.ss" "../model/hide.ss" "../model/steps.ss" @@ -270,7 +271,7 @@ (define/public-final (navigate-down/pred p) (let* ([termlist (cursor:suffix->list terms)] [pred (lambda (trec) - (and (p (lift/deriv-e1 (trec-deriv trec))) + (and (p (wderiv-e1 (trec-deriv trec))) trec))] [term (ormap pred termlist)]) (unless term @@ -395,7 +396,7 @@ (send sbview add-text "Internal error computing reductions. Original term:\n") (send sbview add-syntax - (lift/deriv-e1 (trec-deriv (focused-term))))))) + (wderiv-e1 (trec-deriv (focused-term))))))) ;; update:show-lctx : Step -> void (define/private (update:show-lctx step) @@ -496,7 +497,7 @@ (when (pair? suffix0) (for-each (lambda (trec) (send sbview add-syntax - (lift/deriv-e1 (trec-deriv trec)) + (wderiv-e1 (trec-deriv trec)) #:alpha-table alpha-table)) (cdr suffix0))))) @@ -559,10 +560,10 @@ (send warnings clear) (when trec (unless (send config get-suppress-warnings?) - (for-each (lambda (tag+message) - (let ([tag (car tag+message)] - [message (cdr tag+message)]) - (send warnings add-warning tag message))) + (for-each (lambda (tag+args) + (let ([tag (car tag+args)] + [args (cdr tag+args)]) + (send warnings add-warning tag args))) (trec-warnings trec))))) ;; recache : TermRecord -> void @@ -573,7 +574,7 @@ (lambda (e) (handle-recache-error e 'macro-hiding) (set-trec-synth-deriv! trec 'error) - (set-trec-estx! trec (lift/deriv-e2 (trec-deriv trec))))]) + (set-trec-estx! trec (wderiv-e2 (trec-deriv trec))))]) (recache-synth trec))) (unless (trec-raw-steps trec) (with-handlers ([(lambda (e) #t) @@ -677,7 +678,7 @@ (define/private (extract-protostep-seq step) (match (protostep-deriv step) - [(AnyQ mrule (_ _ (AnyQ transformation (_ _ _ _ _ _ seq)) _)) + [(Wrap mrule (_ _ (Wrap transformation (_ _ _ _ _ _ _ _ seq)) _)) seq] [else #f])) @@ -688,15 +689,15 @@ (let ([show-macro? (get-show-macro?)]) (if show-macro? (parameterize ((current-hiding-warning-handler - (lambda (tag message) + (lambda (tag args) (set-trec-warnings! trec - (cons (cons tag message) + (cons (cons tag args) (trec-warnings trec))))) (force-letrec-transformation (send config get-force-letrec-transformation?))) (hide/policy deriv show-macro?)) - (values deriv (lift/deriv-e2 deriv))))) + (values deriv (wderiv-e2 deriv))))) (set-trec-synth-deriv! trec synth-deriv) (set-trec-estx! trec estx))