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

merged changes from branches/ryanc/ms-v4

Browse Source 
svn: r7741

original commit: 60fe499e4ee6a8a064de4ace1c2f6bfffe16e742
This commit is contained in:
Ryan Culpepper 2007-11-15 18:37:40 +00:00
parent b70053ae2a
commit f9c94375e9
19 changed files with 1905 additions and 1817 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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")

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

@ -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 <Node(Stx)> Deriv Stxs TopDeriv)
;; Deriv
;; A Deriv is one of
;; (make-mrule <Node(Stx)> 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 <Node(Stx)> 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 <Node(Stx)> 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 <Node(Stx)> Stx ?Stx Boolean Deriv)
;; (make-local-expansion/expr <Node(Stx)> 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 <Base> Boolean ?Deriv ?exn Deriv)
;; (make-p:#%module-begin <Base> 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 <Base> DerivLL)
;; (make-p:define-values <Base> 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 <Base> Deriv)
;; (make-p:if <Base> Boolean Deriv Deriv Deriv)
;; (make-p:wcm <Base> Deriv Deriv Deriv)
;; (make-p:set! <Base> Rs Deriv)
;; (make-p:set!-macro <Base> Rs Deriv)
(define-struct (p:#%expression prule) (inner) #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 <Base> Stx LDeriv)
;; (make-p:begin <Base> LDeriv)
;; (make-p:begin0 <Base> 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 <Base> LambdaRenames BDeriv)
;; (make-p:case-lambda <Base> (list-of CaseLambdaClause))
;; (make-p:let-values <Base> LetRenames (list-of Deriv) BDeriv)
;; (make-p:letrec-values <Base> LetRenames (list-of Deriv) BDeriv)
;; (make-p:letrec-syntaxes+values <Base> LSVRenames (list-of BindSyntaxes) (list-of Deriv) BDeriv)
(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 <Base>)
;; (make-p:unknown <Base>)
;; (make-p:#%top <Base> Stx)
;; (make-p:#%datum <Base> Stx)
;; (make-p:quote <Base>)
;; (make-p:quote-syntax <Base>)
;; (make-p:require <Base>)
;; (make-p:require-for-syntax <Base>)
;; (make-p:require-for-template <Base>)
;; (make-p:provide <Base>)
(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 <Base> Renames Deriv)
;;+ (make-p:synth <Base> (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 <Node(Stxs)> ?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 <Node(Stxs)> (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 <Base> #f)
;; (make-p:define-syntaxes <Base> Deriv)
;; (make-p:require <Base>)
;; (make-p:require-for-syntax <Base>)
;; (make-p:require-for-template <Base>)
;; (make-p:provide <Base>)
;; #f
;; A SynthItem is one of
;; - (make-s:subterm Path Deriv)
;; - (make-s:rename Path Stx Stx)
(define-struct subitem () #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)
)

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

@ -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)])
)))
)

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

@ -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)))
)

422
collects/macro-debugger/model/deriv-util.ss
View File

@ -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, <list, append, null> 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 ...)))]))
)

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

@ -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?]))
))

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

@ -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)

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

@ -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])]))
)

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

@ -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")

49
collects/macro-debugger/model/stx-util.ss
View File

@ -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]))
)

9
collects/macro-debugger/model/trace.ss
View File

@ -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

56
collects/macro-debugger/model/yacc-ext.ss
View File

@ -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 ...))))))]))
)

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

@ -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]))
)
)

4
collects/macro-debugger/syntax-browser/controller.ss
View File

@ -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<%>)

9
collects/macro-debugger/syntax-browser/interfaces.ss
View File

@ -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

83
collects/macro-debugger/syntax-browser/text.ss
View File

@ -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

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

@ -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)))
)

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

@ -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))

25
collects/macro-debugger/view/stepper.ss
View File

@ -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))