commit f9c94375e9d1a0fd3b417d251ae3213459d2b206
parent b70053ae2adbfd971bb0e445fea0187a66b58009
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Thu, 15 Nov 2007 18:37:40 +0000
merged changes from branches/ryanc/ms-v4
svn: r7741
original commit: 60fe499e4ee6a8a064de4ace1c2f6bfffe16e742
Diffstat:
19 files changed, 1898 insertions(+), 1811 deletions(-)
diff --git a/collects/macro-debugger/model/debug.ss b/collects/macro-debugger/model/debug.ss
@@ -3,6 +3,7 @@
(require (lib "plt-match.ss"))
(require "trace.ss"
"deriv-util.ss"
+ "deriv-find.ss"
"hide.ss"
"hiding-policies.ss"
"deriv.ss"
@@ -11,6 +12,7 @@
(provide (all-from "trace.ss")
(all-from "deriv.ss")
(all-from "deriv-util.ss")
+ (all-from "deriv-find.ss")
(all-from "hiding-policies.ss")
(all-from "hide.ss")
(all-from "steps.ss")
diff --git a/collects/macro-debugger/model/deriv-c.ss b/collects/macro-debugger/model/deriv-c.ss
@@ -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 ListDerivation is (make-lderiv Syntaxes Syntaxes (listof Derivation))
- (define-struct lderiv (es1 es2 derivs) #f)
+
+ ;; A LDeriv is
+ ;; (make-lderiv <Node(Stxs)> ?exn (list-of Deriv))
+ (define-struct (lderiv node) (?1 derivs) #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 BDeriv is
+ ;; (make-bderiv <Node(Stxs)> (list-of BRule) (U 'list 'letrec) LDeriv)
+ (define-struct (bderiv node) (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 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 BindSyntaxes is
+ ;; (make-bind-syntaxes DerivLL ?exn)
+ (define-struct bind-syntaxes (rhs ?1) #f)
- ;; 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
- ;; A ModRule2 is one of
- ;; - (make-mod:skip)
- ;; - (make-mod:cons Derivation)
- ;; - (make-mod:lift Derivation syntaxes)
+ ;; 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 ModRule1 is one of
+ ;; (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 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)
-
)
diff --git a/collects/macro-debugger/model/deriv-parser.ss b/collects/macro-debugger/model/deriv-parser.ss
@@ -6,12 +6,14 @@
"deriv-util.ss"
"deriv-tokens.ss")
(provide parse-derivation)
-
+
(define (deriv-error ok? name value start end)
(if ok?
- (error 'derivation-parser "error on token #~a: <~s, ~s>" start name value)
+ (error 'derivation-parser
+ "error on token #~a: <~s, ~s>"
+ start name value)
(error 'derivation-parser "bad token #~a" start)))
-
+
;; PARSER
(define (parse-derivation x)
@@ -23,7 +25,22 @@
(let ([seq (current-sequence-number)])
(current-sequence-number (add1 seq))
seq))
+
+ (define-struct (exn:eval exn) (deriv))
+ (define empty-cms
+ (call-with-continuation-prompt (lambda () (current-continuation-marks))))
+ (define (create-eval-exn deriv)
+ (make-exn:eval "exception during evaluation"
+ empty-cms
+ deriv))
+ (define-production-splitter production/I values values)
+
+ (define-syntax (productions/I stx)
+ (syntax-case stx ()
+ [(productions/I def ...)
+ #'(begin (production/I def) ...)]))
+
(define parse-derivation*
(parser
(options (start Expansion)
@@ -31,29 +48,25 @@
(tokens basic-tokens prim-tokens renames-tokens)
(end EOF)
(error deriv-error)
- #;(debug "debug-parser.txt"))
+ #;(debug "DEBUG-PARSER.txt"))
- ;; Required (non-hygienically) by productions/I
- (productions
- #;(Error [(syntax-error) $1])
- (NoError [() #f]))
-
;; tokens
- (skipped-token-values visit resolve next next-group return
- enter-macro macro-pre-transform macro-post-transform exit-macro
- enter-prim exit-prim
- enter-block block->list block->letrec splice
- enter-list exit-list
- enter-check exit-check
- local-post exit-local exit-local/expr
- phase-up module-body
- renames-lambda
- renames-case-lambda
- renames-let
- renames-letrec-syntaxes
- renames-block
- IMPOSSIBLE)
-
+ (skipped-token-values
+ visit resolve next next-group return
+ enter-macro macro-pre-transform macro-post-transform exit-macro
+ enter-prim exit-prim
+ enter-block block->list block->letrec splice
+ enter-list exit-list
+ enter-check exit-check
+ local-post exit-local exit-local/expr
+ phase-up module-body
+ renames-lambda
+ renames-case-lambda
+ renames-let
+ renames-letrec-syntaxes
+ renames-block
+ IMPOSSIBLE)
+
;; Entry point
(productions
(Expansion
@@ -62,90 +75,92 @@
(productions/I
- ;; Expansion of an expression
- ;; EE Answer = Derivation (I)
- (EE
- (#:no-wrap)
- [(visit (? PrimStep 'prim) return)
- $2]
- [(visit (? TaggedPrimStep 'prim) return)
- ($2 $1)]
- [(visit VariableStep return)
- ($2 $1 $3)]
- [((? EE/Macro))
- $1])
- (EE/Macro
- [(visit (? MacroStep 'macro) (? EE 'next))
- (make-mrule $1 (and (deriv? $3) (deriv-e2 $3)) $2 $3)])
-
;; Expand/Lifts
- ;; Expand/Lifts Answer = Derivation (I)
(EE/Lifts
(#:no-wrap)
[((? EE)) $1]
[((? EE/Lifts+)) $1])
+
(EE/Lifts+
+ (#:no-wrap)
[(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))])
+ (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
+
+ ;; Primitive
(PrimStep
+ (#:args e1 e2)
(#:no-wrap)
- [(Resolves NoError enter-prim (? Prim) exit-prim)
- ($4 $3 $5 $1)])
+ [(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)])
- (VariableStep
- (#:no-wrap)
- (#:args e1 e2)
- [(Resolves variable)
- (make-p:variable e1 e2 $1)])
-
- ;; Tagged Primitive syntax
- ;; TaggedPrimStep Answer = syntax -> PRule
- (TaggedPrimStep
+ (Variable
+ (#:args e1 e2 rs)
+ (#:wrap)
+ [(variable)
+ (make p:variable e1 e2 rs #f)])
+
+ (TaggedPrim
+ (#:args e1 e2 rs tagged-stx)
(#: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)])
+ [((? Prim#%App)) ($1 e1 e2 rs tagged-stx)]
+ [((? Prim#%Datum)) ($1 e1 e2 rs tagged-stx)]
+ [((? Prim#%Top)) ($1 e1 e2 rs tagged-stx)])
- ;; Primitive
- ;; Prim Answer = syntax syntax (listof identifier) -> PRule
(Prim
(#:args e1 e2 rs)
(#:no-wrap)
@@ -245,254 +257,269 @@
[((? PrimRequireForSyntax)) ($1 e1 e2 rs)]
[((? PrimRequireForTemplate)) ($1 e1 e2 rs)]
[((? PrimProvide)) ($1 e1 e2 rs)])
-
- ;; Tagged Primitive
- ;; TaggedPrim Answer = syntax syntax (list-of identifier) syntax -> PRule
- (TaggedPrim
- (#:args e1 e2 rs tagged-stx)
- (#:no-wrap)
- [((? Prim#%App)) ($1 e1 e2 rs tagged-stx)]
- [((? Prim#%Datum)) ($1 e1 e2 rs tagged-stx)]
- [((? Prim#%Top)) ($1 e1 e2 rs tagged-stx)])
- ;; Modules
(PrimModule
(#:args e1 e2 rs)
- ;; Multiple forms after language
- ;; #%module-begin tagging done automatically
- [(prim-module ! (? Eval) (? EE 'body))
- (make-p:module e1 e2 rs #f $4)]
-
- ;; One form after language ... macro that expands into #%module-begin
- [(prim-module NoError next
- enter-check (? CheckImmediateMacro/Inner) exit-check
- (! 'module-begin) next (? EE))
- (make-p:module e1 e2 rs
- #t
- ($5 $4
- (and (deriv? $9) (deriv-e2 $9))
- (lambda (ce1 ce2) $9)))])
-
+ (#:wrap)
+ ;; Multiple forms after language: tagging done automatically
+ [(prim-module (? Eval) (? EE))
+ (make p:module e1 e2 rs $2 #f #f #f $3)]
+ ;; One form after language: macro that expands into #%module-begin
+ [(prim-module Eval next (? CheckImmediateMacro) next ! (? EE))
+ (make p:module e1 e2 rs #f #t $4 $6 $7)])
+
(Prim#%ModuleBegin
(#:args e1 e2 rs)
- [(prim-#%module-begin (! 'malformed)
- (? ModulePass1 'pass1) next-group
- (? ModulePass2 'pass2)
- (! 'provides))
- (make-p:#%module-begin e1 e2 rs $3 $5)])
+ (#:wrap)
+ [(prim-#%module-begin ! (? ModulePass1) next-group (? ModulePass2) !)
+ (make p:#%module-begin e1 e2 rs $2 $3 $5 $6)])
(ModulePass1
- (#:skipped null)
(#:no-wrap)
+ (#:skipped null)
[() null]
[(next (? ModulePass1-Part) (? ModulePass1))
(cons $2 $3)]
[(module-lift-end-loop (? ModulePass1))
- (cons (make-mod:lift-end $1) $2)])
+ (cons (make mod:lift-end $1) $2)])
(ModulePass1-Part
- (#:no-wrap)
+ (#:wrap)
[((? EE) (? ModulePass1/Prim))
- (make-mod:prim $1 $2)]
- [(EE NoError module-lift-loop)
- (make-mod:lift $1 $2)]
+ (make mod:prim $1 $2)]
[(EE ! splice)
- (make-mod:splice $1 $3)])
+ (make mod:splice $1 $2 $3)]
+ [(EE module-lift-loop)
+ (make mod:lift $1 $2)])
(ModulePass1/Prim
+ (#:wrap)
[(enter-prim prim-define-values ! exit-prim)
- (make-p:define-values $1 $4 null #f)]
- [(enter-prim prim-define-syntaxes ! phase-up (? EE/LetLifts) (? Eval) exit-prim)
- (make-p:define-syntaxes $1 $7 null $5)]
- [(enter-prim prim-require ! (? Eval) exit-prim)
- (make-p:require $1 $5 null)]
- [(enter-prim prim-require-for-syntax ! (? Eval) exit-prim)
- (make-p:require-for-syntax $1 $5 null)]
- [(enter-prim prim-require-for-template ! (? Eval) exit-prim)
- (make-p:require-for-template $1 $5 null)]
+ (make p:define-values $1 $4 null $3 #f)]
+ [(enter-prim prim-define-syntaxes !
+ phase-up (? EE/LetLifts) (? Eval) exit-prim)
+ (make p:define-syntaxes $1 $7 null $3 $5 $6)]
+ [(enter-prim prim-require (? Eval) exit-prim)
+ (make p:require $1 $4 null $3)]
+ [(enter-prim prim-require-for-syntax (? Eval) exit-prim)
+ (make p:require-for-syntax $1 $4 null $3)]
+ [(enter-prim prim-require-for-template (? Eval) exit-prim)
+ (make p:require-for-template $1 $4 null $3)]
[(enter-prim prim-provide ! exit-prim)
- (make-p:provide $1 $4 null)]
+ (make p:provide $1 $4 null $3)]
[()
#f])
(ModulePass2
- (#:skipped null)
(#:no-wrap)
+ (#:skipped null)
[() null]
[(next (? ModulePass2-Part) (? ModulePass2))
(cons $2 $3)]
[(module-lift-end-loop (? ModulePass2))
- (cons (make-mod:lift-end $1) $2)])
+ (cons (make mod:lift-end $1) $2)])
(ModulePass2-Part
(#:no-wrap)
;; not normal; already handled
[()
- (make-mod:skip)]
+ (make mod:skip)]
;; normal: expand completely
[((? EE))
- (make-mod:cons $1)]
+ (make mod:cons $1)]
;; catch lifts
[(EE module-lift-loop)
- (make-mod:lift $1 $2)])
+ (make mod:lift $1 $2)])
;; Definitions
(PrimDefineSyntaxes
(#:args e1 e2 rs)
+ (#:wrap)
[(prim-define-syntaxes ! (? EE/LetLifts) (? Eval))
- (make-p:define-syntaxes e1 e2 rs $3)])
-
+ (make p:define-syntaxes e1 e2 rs $2 $3 $4)])
+
(PrimDefineValues
(#:args e1 e2 rs)
+ (#:wrap)
[(prim-define-values ! (? EE))
- (make-p:define-values e1 e2 rs $3)])
-
+ (make p:define-values e1 e2 rs $2 $3)])
+
;; Simple expressions
(PrimExpression
(#:args e1 e2 rs)
- [(prim-expression ! (? EE 'inner))
- (make-p:expression e1 e2 rs $3)])
+ (#:wrap)
+ [(prim-expression ! (? EE))
+ (make p:#%expression e1 e2 rs $2 $3)])
(PrimIf
(#:args e1 e2 rs)
- [(prim-if ! (? EE 'test) next (? EE 'then) next (? EE 'else))
- (make-p:if e1 e2 rs #t $3 $5 $7)]
- [(prim-if NoError next-group (? EE 'test) next (? EE 'then))
- (make-p:if e1 e2 rs #f $4 $6 #f)])
-
+ (#:wrap)
+ [(prim-if ! (? EE) next (? EE) next (? EE))
+ (make p:if e1 e2 rs $2 #t $3 $5 $7)]
+ [(prim-if next-group (? EE) next (? EE))
+ (make p:if e1 e2 rs #f #f $3 $5 #f)])
+
(PrimWCM
(#:args e1 e2 rs)
- [(prim-wcm ! (? EE 'key) next (? EE 'mark) next (? EE 'body))
- (make-p:wcm e1 e2 rs $3 $5 $7)])
-
+ (#:wrap)
+ [(prim-wcm ! (? EE) next (? EE) next (? EE))
+ (make p:wcm e1 e2 rs $2 $3 $5 $7)])
+
;; Sequence-containing expressions
(PrimBegin
(#:args e1 e2 rs)
+ (#:wrap)
[(prim-begin ! (? EL))
- (make-p:begin e1 e2 rs $3)])
-
+ (make p:begin e1 e2 rs $2 $3)])
+
(PrimBegin0
(#:args e1 e2 rs)
+ (#:wrap)
[(prim-begin0 ! next (? EE) next (? EL))
- (make-p:begin0 e1 e2 rs $4 $6)])
-
+ (make p:begin0 e1 e2 rs $2 $4 $6)])
+
(Prim#%App
(#:args e1 e2 rs tagged-stx)
+ (#:wrap)
[(prim-#%app !)
- (make-p:#%app e1 e2 rs tagged-stx (make-lderiv null null null))]
- [(prim-#%app NoError (? EL))
- (make-p:#%app e1 e2 rs tagged-stx $3)])
-
+ (make p:#%app e1 e2 rs $2 tagged-stx (make lderiv null null #f null))]
+ [(prim-#%app (? EL))
+ (make p:#%app e1 e2 rs #f tagged-stx $2)])
+
;; Binding expressions
(PrimLambda
(#:args e1 e2 rs)
+ (#:wrap)
[(prim-lambda ! renames-lambda (? EB))
- (make-p:lambda e1 e2 rs $3 $4)])
-
+ (make p:lambda e1 e2 rs $2 $3 $4)])
+
(PrimCaseLambda
(#:args e1 e2 rs)
+ (#:wrap)
[(prim-case-lambda ! (? NextCaseLambdaClauses))
- (make-p:case-lambda e1 e2 rs $3)])
-
+ (make p:case-lambda e1 e2 rs $2 $3)])
+
(NextCaseLambdaClauses
(#:skipped null)
- [(next ! renames-case-lambda (? EB 'first) (? NextCaseLambdaClauses 'rest))
- (cons (cons $3 $4) $5)]
+ (#:no-wrap)
+ [(next (? CaseLambdaClause) (? NextCaseLambdaClauses))
+ (cons $2 $3)]
[() null])
-
+
+ (CaseLambdaClause
+ (#:wrap)
+ [(! renames-case-lambda (? EB))
+ (make clc $1 $2 $3)])
+
(PrimLetValues
(#:args e1 e2 rs)
- [(prim-let-values ! renames-let (? NextEEs 'rhss) next-group (? EB 'body))
- (make-p:let-values e1 e2 rs $3 $4 $6)])
-
+ (#:wrap)
+ [(prim-let-values ! renames-let (? NextEEs) next-group (? EB))
+ (make p:let-values e1 e2 rs $2 $3 $4 $6)])
+
(PrimLet*Values
(#:args e1 e2 rs)
+ (#:wrap)
;; let*-values with bindings is "macro-like"
- [(prim-let*-values ! (? EE))
- (let ([next-e1 (lift/deriv-e1 $3)])
- (make-mrule e1 e2 (make-transformation e1 next-e1 rs e1 next-e1 null (new-sequence-number)) $3))]
+ [(prim-let*-values !!)
+ (let ([tx (make transformation e1 #f rs $2
+ #f null #f #f (new-sequence-number))])
+ (make mrule e1 e2 tx #f))]
+ [(prim-let*-values (? EE))
+ (let* ([next-e1 (wderiv-e1 $2)]
+ [tx (make transformation e1 next-e1 rs #f
+ e1 null #f next-e1 (new-sequence-number))])
+ (make mrule e1 e2 tx $2))]
;; No bindings... model as "let"
- [(prim-let*-values NoError renames-let (? NextEEs 'rhss) next-group (? EB 'body))
- (make-p:let-values e1 e2 rs $3 $4 $6)])
+ [(prim-let*-values renames-let (? NextEEs) next-group (? EB))
+ (make p:let-values e1 e2 rs #f $2 $3 $5)])
(PrimLetrecValues
(#:args e1 e2 rs)
- [(prim-letrec-values ! renames-let (? NextEEs 'rhss) next-group (? EB 'body))
- (make-p:letrec-values e1 e2 rs $3 $4 $6)])
-
+ (#:wrap)
+ [(prim-letrec-values ! renames-let (? NextEEs) next-group (? EB))
+ (make p:letrec-values e1 e2 rs $2 $3 $4 $6)])
+
(PrimLetrecSyntaxes+Values
(#:args e1 e2 rs)
- [(prim-letrec-syntaxes+values (! 'bad-syntax) renames-letrec-syntaxes
- (? NextBindSyntaxess 'srhss) next-group (? EB 'body))
- (make-p:letrec-syntaxes+values e1 e2 rs $3 $4 #f null $6)]
- [(prim-letrec-syntaxes+values NoError renames-letrec-syntaxes
+ (#:wrap)
+ [(prim-letrec-syntaxes+values ! renames-letrec-syntaxes
+ (? NextBindSyntaxess) next-group (? EB))
+ (make p:letrec-syntaxes+values e1 e2 rs $2 $3 $4 #f null $6)]
+ [(prim-letrec-syntaxes+values renames-letrec-syntaxes
NextBindSyntaxess next-group
- prim-letrec-values (! 'impossible?)
- renames-let (? NextEEs 'vrhss) next-group (? EB 'body))
- (make-p:letrec-syntaxes+values e1 e2 rs $3 $4 $8 $9 $11)])
-
+ prim-letrec-values
+ renames-let (? NextEEs) next-group (? EB))
+ (make p:letrec-syntaxes+values e1 e2 rs #f $2 $3 $6 $7 $9)])
+
;; Atomic expressions
(Prim#%Datum
(#:args e1 e2 rs tagged-stx)
- [(prim-#%datum !) (make-p:#%datum e1 e2 rs tagged-stx)])
+ (#:wrap)
+ [(prim-#%datum !) (make p:#%datum e1 e2 rs $2 tagged-stx)])
(Prim#%Top
(#:args e1 e2 rs tagged-stx)
- [(prim-#%top !) (make-p:#%top e1 e2 rs tagged-stx)])
+ (#:wrap)
+ [(prim-#%top !) (make p:#%top e1 e2 rs $2 tagged-stx)])
(PrimSTOP
(#:args e1 e2 rs)
- [(prim-stop !) (make-p:stop e1 e2 rs)])
-
+ (#:wrap)
+ [(prim-stop !) (make p:stop e1 e2 rs $2)])
+
(PrimQuote
(#:args e1 e2 rs)
- [(prim-quote !) (make-p:quote e1 e2 rs)])
-
+ (#:wrap)
+ [(prim-quote !) (make p:quote e1 e2 rs $2)])
+
(PrimQuoteSyntax
(#:args e1 e2 rs)
- [(prim-quote-syntax !) (make-p:quote-syntax e1 e2 rs)])
-
+ (#:wrap)
+ [(prim-quote-syntax !) (make p:quote-syntax e1 e2 rs $2)])
+
(PrimRequire
(#:args e1 e2 rs)
- [(prim-require ! (? Eval))
- (make-p:require e1 e2 rs)])
-
+ (#:wrap)
+ [(prim-require (? Eval))
+ (make p:require e1 e2 rs $2)])
+
(PrimRequireForSyntax
(#:args e1 e2 rs)
- [(prim-require-for-syntax ! (? Eval))
- (make-p:require-for-syntax e1 e2 rs)])
-
+ (#:wrap)
+ [(prim-require-for-syntax (? Eval))
+ (make p:require-for-syntax e1 e2 rs $2)])
+
(PrimRequireForTemplate
(#:args e1 e2 rs)
- [(prim-require-for-template ! (? Eval))
- (make-p:require-for-template e1 e2 rs)])
-
+ (#:wrap)
+ [(prim-require-for-template (? Eval))
+ (make p:require-for-template e1 e2 rs $2)])
+
(PrimProvide
(#:args e1 e2 rs)
- [(prim-provide !) (make-p:provide e1 e2 rs)])
-
+ (#:wrap)
+ [(prim-provide !) (make p:provide e1 e2 rs $2)])
+
(PrimSet
(#:args e1 e2 rs)
+ (#:wrap)
[(prim-set! ! Resolves next (? EE))
- (make-p:set! e1 e2 rs $3 $5)]
- [(prim-set! NoError (? MacroStep 'macro) (? EE 'continue))
- (make-p:set!-macro e1 e2 rs (make-mrule e1 (and (deriv? $4) (deriv-e2 $4)) $3 $4))])
-
+ (make p:set! e1 e2 rs $2 $3 $5)]
+ [(prim-set! (? MacroStep) (? EE))
+ (make p:set!-macro e1 e2 rs #f
+ (make mrule e1 (and $3 (wderiv-e2 $3)) $2 $3))])
+
;; Blocks
;; EB Answer = BlockDerivation
- (EB
- [(enter-block (? BlockPass1 'pass1) block->list (? EL 'pass2))
- (make-bderiv $1
- (and (lderiv? $4) (lderiv-es2 $4))
- $2
- 'list
- $4)]
- [(enter-block BlockPass1 block->letrec (? EL 'pass2))
- (make-bderiv $1
- (and (lderiv? $4) (lderiv-es2 $4))
- $2
- 'letrec
- $4)])
+ (EB
+ (#:wrap)
+ [(enter-block (? BlockPass1) block->list (? EL))
+ (make bderiv $1 (and $4 (wlderiv-es2 $4))
+ $2 'list $4)]
+ [(enter-block BlockPass1 block->letrec (? EL))
+ (make bderiv $1 (and $4 (wlderiv-es2 $4))
+ $2 'letrec $4)])
;; BlockPass1 Answer = (list-of BRule)
(BlockPass1
@@ -504,42 +531,50 @@
;; BRule Answer = BRule
(BRule
- [(next ! IMPOSSIBLE)
- #f]
- [(next NoError renames-block (? CheckImmediateMacro 'check))
- (make-b:expr $3 $4)]
- [(next NoError renames-block CheckImmediateMacro prim-begin ! splice !)
- (make-b:splice $3 $4 $7)]
- [(next NoError renames-block CheckImmediateMacro prim-define-values !)
- (make-b:defvals $3 $4)]
- [(next NoError renames-block CheckImmediateMacro
- prim-define-syntaxes (? BindSyntaxes 'bind))
- (make-b:defstx $3 $4 $6)])
+ (#:wrap)
+ [(next !!)
+ (make b:error $2)]
+ [(next renames-block (? CheckImmediateMacro))
+ (make b:expr $2 $3)]
+ [(next renames-block CheckImmediateMacro prim-begin ! splice !)
+ (make b:splice $2 $3 $5 $6 $7)]
+ [(next renames-block CheckImmediateMacro prim-define-values !)
+ (make b:defvals $2 $3 $5)]
+ [(next renames-block CheckImmediateMacro
+ prim-define-syntaxes ! (? BindSyntaxes))
+ (make b:defstx $2 $3 $5 $6)])
;; BindSyntaxes Answer = Derivation
(BindSyntaxes
- [(phase-up (? EE/LetLifts) ! (? Eval)) $2])
-
+ (#:wrap)
+ [(phase-up (? EE/LetLifts) (? Eval))
+ (make bind-syntaxes $2 $3)])
+
;; NextBindSyntaxess Answer = (list-of Derivation)
(NextBindSyntaxess
- (#:skipped null)
(#:no-wrap)
+ (#:skipped null)
[() null]
- [(next (? BindSyntaxes 'first) (? NextBindSyntaxess 'rest)) (cons $2 $3)])
-
+ [(next (? BindSyntaxes) (? NextBindSyntaxess)) (cons $2 $3)])
+
;; Lists
;; EL Answer = ListDerivation
(EL
+ (#:wrap)
(#:skipped #f)
- [(enter-list ! (? EL*) exit-list) (make-lderiv $1 $4 $3)])
+ [(enter-list ! (? EL*) exit-list)
+ ;; FIXME: Workaround for bug in events
+ (if (null? $3)
+ (make lderiv null null $2 $3)
+ (make lderiv $1 $4 $2 $3))])
;; EL* Answer = (listof Derivation)
(EL*
(#:no-wrap)
(#:skipped null)
[() null]
- [(next (? EE 'first) (? EL* 'rest)) (cons $2 $3)])
-
+ [(next (? EE) (? EL*)) (cons $2 $3)])
+
)))
-
+
)
diff --git a/collects/macro-debugger/model/deriv-tokens.ss b/collects/macro-debugger/model/deriv-tokens.ss
@@ -43,12 +43,12 @@
enter-local/expr ; syntax
exit-local/expr ; (cons syntax expanded-expression)
-
+
variable ; (cons identifier identifier)
IMPOSSIBLE ; useful for error-handling clauses that have no NoError counterpart
))
-
+
(define-tokens renames-tokens
(renames-lambda ; (cons syntax syntax)
renames-case-lambda ; (cons syntax syntax)
@@ -56,7 +56,9 @@
renames-letrec-syntaxes ; (cons (listof syntax) (cons (listof syntax) syntax))
renames-block ; (cons syntax syntax) ... different, contains both pre+post
))
- (define-empty-tokens prim-tokens
+
+ ;; Empty tokens
+ (define-tokens prim-tokens
(prim-module prim-#%module-begin
prim-define-syntaxes prim-define-values
prim-if prim-wcm prim-begin prim-begin0 prim-#%app prim-lambda
@@ -67,9 +69,9 @@
prim-set!
prim-expression
))
-
+
;; ** Signals to tokens
-
+
(define signal-mapping
`((EOF . EOF)
(error . ,token-syntax-error)
@@ -141,7 +143,7 @@
(140 . ,token-exit-local/expr)
(141 . ,token-start)
))
-
+
(define (tokenize sig-n val pos)
(let ([p (assv sig-n signal-mapping)])
(if (pair? p)
@@ -154,5 +156,5 @@
(define (signal->symbol sig-n)
(cdr (assv sig-n signal-mapping)))
-
+
)
diff --git a/collects/macro-debugger/model/deriv-util.ss b/collects/macro-debugger/model/deriv-util.ss
@@ -3,360 +3,98 @@
(require "deriv.ss"
(lib "list.ss")
(lib "plt-match.ss"))
- (provide IntW
- ErrW
- AnyQ
- IntQ
-
- Wrap
- lift/wrap
- rewrap
- rewrap/nt
- outer-rewrap
- lift/deriv-e1
- lift/deriv-e2
- lift/lderiv-es1
- lift/lderiv-es2
- wrapped?
+ (require-for-syntax (lib "scheme/private/struct-info.ss"))
- find-derivs
- find-deriv
- find-derivs/syntax
- extract-all-fresh-names
- flatten-identifiers)
+ (provide make
- ;; 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 ...))))]))
+ Wrap
+
+ ok-node?
+ interrupted-node?
- ;; 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 ...))))]))
+ wderiv-e1
+ wderiv-e2
+ wlderiv-es1
+ wlderiv-es2
+ wbderiv-es1
+ wbderiv-es2
+
+ 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)]))
-
- (define (unwrap x)
- (match x
- [(struct interrupted-wrap (tag inner))
- inner]
- [(struct error-wrap (exn tag inner))
- inner]
- [else 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)))
+ (lambda (stx)
+ (syntax-case stx ()
+ [(Wrap S (var ...))
+ (syntax/loc stx (struct S (var ...)))])))
- ;; 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)))
+ ;; ----
- ;; 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 (check sym pred type x)
+ (unless (pred x)
+ (raise-type-error sym type 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)))
- (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 (lift/lderiv-es2 x)
- (match x
- [(AnyQ lderiv (es1 es2 _)) es2]))
+ (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 (wrapped? x)
- (or (interrupted-wrap? x)
- (error-wrap? x)))
-
- ;; Utilities for finding subderivations
+ (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))
- ;; 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)
- (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))]))
+ (define (wbderiv-es1 x)
+ (check 'wbderiv-es1 bderiv? "bderiv" x)
+ (node-z1 x))
+ (define (wbderiv-es2 x)
+ (check 'wbderiv-es2 bderiv? "bderiv" x))
+
+ ;; wderivlist-es2 : (list-of WDeriv) -> (list-of Stx)/#f
+ (define (wderivlist-es2 xs)
+ (let ([es2 (map wderiv-e2 xs)])
+ (and (andmap syntax? es2) es2)))
+
+ ;; ----
-)
+ (define-syntax (make stx)
+ (syntax-case stx ()
+ [(make S expr ...)
+ (unless (identifier? #'S)
+ (raise-syntax-error #f "not an identifier" stx #'S))
+ (let ()
+ (define (no-info) (raise-syntax-error #f "not a struct" stx #'S))
+ (define info
+ (extract-struct-info
+ (syntax-local-value #'S no-info)))
+ (define constructor (list-ref info 1))
+ (define accessors (list-ref info 3))
+ (unless (identifier? #'constructor)
+ (raise-syntax-error #f "constructor not available for struct" stx #'S))
+ (unless (andmap identifier? accessors)
+ (raise-syntax-error #f "incomplete info for struct type" stx #'S))
+ (let ([num-slots (length accessors)]
+ [num-provided (length (syntax->list #'(expr ...)))])
+ (unless (= num-provided num-slots)
+ (raise-syntax-error
+ #f
+ (format "wrong number of arguments for struct ~s (expected ~s)"
+ (syntax-e #'S)
+ num-slots)
+ stx)))
+ (with-syntax ([constructor constructor])
+ #'(constructor expr ...)))]))
+ )
diff --git a/collects/macro-debugger/model/deriv.ss b/collects/macro-debugger/model/deriv.ss
@@ -6,319 +6,365 @@
;; NO CONTRACTS
- (provide (all-from "deriv-c.ss"))
+ #;(provide (all-from "deriv-c.ss"))
+
;; CONTRACTS
+
+ (define (?? c) (or/c c false/c))
-#; (begin
- (define (stx-list-like? x)
+ (define (stx? 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))
+ (and (pair? x) (stx? (car x)) (stx? (cdr x)))
+ (null? x)))
- (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 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 (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 (?? 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]))
+ [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]
+ [?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)
- ([e1 syntax?]
- [e2 syntax/f]
+ ([z1 syntax?]
+ [z2 syntax/f]
[resolves resolves/c]
- [tagged-stx syntax?]
- [lderiv (anyq (maybe lderiv?))]))
-
- (struct lderiv
- ([es1 syntaxes/c]
- [es2 syntaxes/f]
- [derivs (listof (anyq deriv?))]))
-
- (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])))
-
-
- (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 local-expansion (e1 e2 me1 me2 deriv))
- (struct local-lift (expr id))
- (struct local-lift-end (decl))
- (struct local-bind (deriv))
-
- ;(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))
+ [?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 interrupted-wrap (tag inner))
- ;(struct error-wrap (exn tag inner))
- )
-
+ (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?)]))
- ;; 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]))
+ (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?)]))
- #;
- (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]))
+ (struct bind-syntaxes
+ ([rhs deriv?]
+ [?1 (?? exn?)]))
- #;
- (define (wf-ok-basic-prule? x)
- (match x
- [($ prule e1 e2 rs)
- (and (syntax? e1)
- (syntax? e2)
- (list? rs)
- (andmap identifier? rs))]
- [else #f]))
+ (struct clc
+ ([?1 (?? exn?)]
+ [renames any/c]
+ [body (?? bderiv?)]))
- #;
- (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]))
+ (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]))
- #;
- (define (wf-ok-bderiv? x)
- (define (wf-ok-brule? x)
- (match x
- [($ brskip renames next)
- (and (void renames)
- (wf-ok-brule? next))]
- [($ brcons renames head next)
- (and (void renames)
- (wf-ok-deriv? head)
- (wf-ok-brule? next))]
- [($ brdefstx renames deriv rhs next)
- (and (void renames)
- (wf-ok-deriv? deriv)
- (wf-ok-deriv? rhs)
- (wf-ok-brule? next))]
- [($ brsplice tail next)
- (and (list? tail)
- (andmap syntax? tail)
- (wf-ok-brule? next))]
- [else #f]))
- (match x
- [($ bderiv es1 es2 pass1 trans pass2)
- (and (wf-ok-brule? pass1)
- (wf-ok-lderiv? pass2))]
- [else #f]))
-
- #;
- (define (wf-exn-deriv? x)
- #f)
- )
- )
+ (struct subitem ())
+ (struct (s:subterm subitem)
+ ([path any/c]
+ [deriv deriv?]))
+ (struct (s:rename subitem)
+ ([path any/c]
+ [before syntax?]
+ [after syntax?]))
+ ))
diff --git a/collects/macro-debugger/model/reductions-engine.ss b/collects/macro-debugger/model/reductions-engine.ss
@@ -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))]
-
- ;; Conditional
- [(R** f p [#:if test consequent ...] . more)
- #'(if (with-syntax ([p f]) test)
- (R** f p consequent ... . more)
- (R** f p . more))]
-
- ;; 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)]))]
+ (begin (add-frontier (with-syntax ([p f]) stxs))
+ (R** f p . more))]
- [(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))]
+ ;; 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)))]
- ;; Implementation for (hole ...) sequences
- [(R** form-var pattern
- [f0 get-e1 get-e2 (hole0 :::) fill0s] . more)
+ ;; Conditional (pattern changes lost afterwards ...)
+ [(R** f p [#:when/np test consequent ...] . more)
+ (let ([continue (lambda (f2) (R** f2 p . more))])
+ (if (with-syntax ([p f]) test)
+ (R** f p consequent ... => continue)
+ (continue f)))]
+
+ ;; Conditional
+ [(R** f p [#:when test consequent ...] . more)
+ (if (with-syntax ([p f]) test)
+ (R** f p consequent ... . more)
+ (R** f p . more))]
+
+ ;; Subterm handling
+ [(R** f p [generator hole fill] . more)
+ (let ([k (lambda (f2) (R** f2 p . more))])
+ (Run f p generator hole fill k))]))
+
+
+ (define-syntax Run
+ (syntax-rules ()
+ [(Run f p generator hole fill k)
+ (let ([reducer (with-syntax ([p f]) (generator))])
+ (Run* reducer f p hole fill k))]))
+
+ (define-syntax (Run* stx)
+ (syntax-case stx ()
+ ;; Implementation of subterm handling for (hole ...) sequences
+ [(Run* f form-var pattern (hole :::) fills k)
(and (identifier? #':::)
(module-identifier=? #'::: (quote-syntax ...)))
- #'(let ([ctx0 (CC (hole0 :::) form-var pattern)])
- (let ([e1s (with-syntax ([pattern form-var]) (syntax->list #'(hole0 :::)))])
- (let loop ([fills fill0s] [prefix null] [suffix e1s])
- (cond
- [(pair? fills)
- (append
- (with-context ctx0
- (with-context (lambda (x) (revappend prefix (cons x (cdr suffix))))
- (f0 (car fills))))
- (cond [(interrupted-wrap? (car fills))
- null]
- [(error-wrap? (car fills))
- null]
- [else
- (loop (cdr fills)
- (cons (get-e2 (car fills)) prefix)
- (cdr suffix))]))]
- [(null? fills)
- (let ([form-var (ctx0 (reverse prefix))])
- (R** form-var pattern . more))]))))]
- ;; Implementation
- [(R** form-var pattern
- [f0 get-e1 get-e2 hole0 fill0] . more)
- #'(let ([ctx0 (CC hole0 form-var pattern)])
- (append (with-context ctx0
- (f0 fill0))
- ;; If the last thing we ran through was interrupted,
- ;; then there's nothing left to do.
- ;; This stops processing *after* an error-wrapped deriv.
- (cond [(interrupted-wrap? fill0) null]
- [(error-wrap? fill0) null]
- [else
- (let ([form-var (ctx0 (get-e2 fill0))])
- (R** form-var pattern . more))])))]))
+ #'(let ([ctx (CC (hole :::) form-var pattern)])
+ (let ([e1s (with-syntax ([pattern form-var]) (syntax->list #'(hole :::)))])
+ (run-multiple f ctx fills e1s k)))]
+ ;; Implementation of subterm handling
+ [(Run* f form-var pattern hole fill k)
+ #'(let ([ctx (CC hole form-var pattern)])
+ (run-one f ctx fill k))]))
+
+ ;; run-multiple : (a -> RS(b)) ((list-of b) -> c) (list-of a) (list-of b) (c -> RS(d))
+ ;; -> RS(d)
+ ;; For example: a = Deriv; b = c = d = Syntax
+ (define (run-multiple f ctx fills suffix k)
+ (let loop ([fills fills] [prefix null] [suffix suffix])
+ (cond
+ [(pair? fills)
+ (RSbind (lambda ()
+ (with-context ctx
+ (with-context (lambda (x) (revappend prefix (cons x (cdr suffix))))
+ (f (car fills)))))
+ (lambda (final)
+ (loop (cdr fills)
+ (cons final prefix)
+ (cdr suffix))))]
+ [(null? fills)
+ (let ([form (ctx (reverse prefix))])
+ (k form))])))
+
+ ;; run-one : (a -> RS(b)) (b -> c) (c -> RS(d)) -> RS(d)
+ (define (run-one f ctx fill k)
+ (RSbind (lambda () (with-context ctx (f fill)))
+ (lambda (final)
+ (k (ctx final)))))
-
;; Rename mapping
(define (rename-frontier from to)
diff --git a/collects/macro-debugger/model/reductions.ss b/collects/macro-debugger/model/reductions.ss
@@ -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
+ [#: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
+ [! ?1]
+ [#:pattern (?module ?name ?language . ?_body)]
+ [#:walk (d->so e1 `(,#'?module ,#'?name ,#'?language ,(wderiv-e1 body)))
+ 'tag-module-begin]
+ [#:pattern (?module ?name ?language ?body)]
+ [#:frontier (list #'?body)]
+ [Expr ?body body])]
+ [(Wrap p:module (e1 e2 rs ?1 #t mb ?2 body))
+ (R e1
+ [! ?1]
+ [#:pattern (?module ?name ?language ?body)]
+ [#:frontier (list #'?body)]
+ [Expr ?body mb]
+ [! ?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
- [! exni]
- [#:pattern (?define-syntaxes formals RHS)]
- [#:frontier (list #'RHS)]
- [Expr RHS rhs])]
- [(AnyQ p:define-values (e1 e2 rs rhs) exni)
+ [! ?1]
+ [#:pattern (?define-syntaxes formals ?rhs)]
+ [#:frontier (list #'?rhs)]
+ [Expr ?rhs rhs]
+ [! ?2])]
+ [(Wrap p:define-values (e1 e2 rs ?1 rhs))
(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 (?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
- [! exni]
- [#:pattern (?expr INNER)]
- [Expr INNER inner])]
- [(AnyQ p:if (e1 e2 rs full? test then else) exni)
+ [! ?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)))]
-
- ;; Skipped
- [#f null]
+ [(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])]
- #;
- [else (error 'reductions "unmatched case: ~s" d)]))
+ [(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 (RSzero)]))
+
+ ;; mk-case-lambda-clauses-reductions : stxs ->
+ ;; (list-of (W (list ?exn rename (W BDeriv)))) -> (RS stxs)
+ (define ((mk-case-lambda-clauses-reductions es1) clauses)
+ (blaze-frontier es1)
+ (match clauses
+ ['()
+ (RSunit null)]
+ [(cons (Wrap clc (?1 rename body)) rest)
+ (R es1
+ [! ?1]
+ [#:pattern ((?formals . ?body) . ?rest)]
+ [#:frontier (list #'?body #'?rest)]
+ [#:bind (?formals* . ?body*) rename]
+ [#:rename (syntax/skeleton es1 ((?formals* . ?body*) . ?rest))
+ #'?formals #'?formals*
+ 'rename-case-lambda]
+ [Block ?body body]
+ [(CaseLambdaClauses (cdr es1))
+ ?rest rest])]))
+
+ ;; mk-synth-items-reductions : syntax -> (list-of SynthItem) -> (RS syntax)
+ (define ((mk-synth-items-reductions e1) subterms)
+ (let loop ([term e1] [subterms subterms])
+ (cond [(null? subterms)
+ (RSunit e1)]
+ [(s:subterm? (car subterms))
+ (let* ([subterm0 (car subterms)]
+ [path0 (s:subterm-path subterm0)]
+ [deriv0 (s:subterm-deriv subterm0)])
+ (let ([ctx (lambda (x) (path-replace term path0 x))])
+ (RSseq (lambda ()
+ (with-context ctx (reductions* deriv0)))
+ (lambda ()
+ (loop (path-replace term path0 (wderiv-e2 deriv0))
+ (cdr subterms))))))]
+ [(s:rename? (car subterms))
+ (let* ([subterm0 (car subterms)])
+ ;; FIXME: add renaming steps?
+ ;; FIXME: if so, coalesce?
+ (rename-frontier (s:rename-before subterm0)
+ (s:rename-after subterm0))
+ (loop (path-replace term
+ (s:rename-path subterm0)
+ (s:rename-after subterm0))
+ (cdr subterms)))])))
- ;; reductions-transformation : Transformation -> ReductionSequence
- (define (reductions-transformation tx)
+ ;; transformation-reductions : Transformation -> (RS Stx)
+ (define (transformation-reductions tx)
(match tx
- [(struct transformation (e1 e2 rs me1 me2 locals seq))
- (learn-definites rs)
- (append (reductions-locals e1 locals)
- (list (walk e1 e2 'macro-step)))]
- [(IntW transformation (e1 e2 rs me1 me2 locals seq) 'locals)
- (learn-definites rs)
- (reductions-locals e1 locals)]
- [(ErrW transformation (e1 e2 rs me1 me2 locals seq) 'bad-transformer exn)
- (learn-definites rs)
- (list (stumble e1 exn))]
- [(ErrW transformation (e1 e2 rs me1 me2 locals seq) 'transform exn)
- (learn-definites rs)
- (append (reductions-locals e1 locals)
- (list (stumble e1 exn)))]))
+ [(Wrap transformation (e1 e2 rs ?1 me1 locals ?2 me2 seq))
+ (R e1
+ [! ?1]
+ [#:pattern ?form]
+ [#:learn rs]
+ [#:reductions (reductions-locals e1 locals)]
+ [! ?2]
+ [#:walk e2
+ (list #'?form)
+ (list e2)
+ 'macro])]))
- ;; reductions-locals : syntax (list-of LocalAction) -> ReductionSequence
+ ;; reductions-locals : syntax (list-of LocalAction) -> (RS void)
(define (reductions-locals stx locals)
(with-new-local-context stx
- (apply append (map reductions-local locals))))
-
- ;; reductions-local : LocalAction -> ReductionSequence
+ (RSforeach reductions-local locals)))
+
+ ;; reductions-local : LocalAction -> (RS void)
(define (reductions-local local)
(match/with-derivation local
[(struct local-expansion (e1 e2 me1 me2 for-stx? deriv))
@@ -398,219 +416,149 @@
"reductions: local-expand-expr not fully implemented")
(reductions* deriv)]
[(struct local-lift (expr id))
- (list (walk expr id 'local-lift))]
+ (RSadd (list (walk expr id 'local-lift))
+ RSzero)]
[(struct local-lift-end (decl))
- (list (walk/mono decl 'module-lift))]
+ (RSadd (list (walk/mono decl 'module-lift))
+ RSzero)]
[(struct local-bind (deriv))
(reductions* deriv)]))
- ;; list-reductions : ListDerivation -> ReductionSequence
+ ;; list-reductions : ListDerivation -> (RS Stxs)
(define (list-reductions ld)
(match/with-derivation ld
- [(IntQ lderiv (es1 es2 derivs))
- (let loop ([derivs derivs] [suffix es1])
- (cond [(pair? derivs)
- (append
- (with-context (lambda (x) (cons x (stx-cdr suffix)))
- (reductions* (car derivs)))
- (with-context (lambda (x) (cons (deriv-e2 (car derivs)) x))
- (loop (cdr derivs) (stx-cdr suffix))))]
- [(null? derivs)
- null]))]
- [(ErrW lderiv (es1 es2 derivs) _ exn)
- (list (stumble es1 exn))]
-
- [#f null]))
-
- ;; block-reductions : BlockDerivation -> ReductionSequence
+ [(Wrap lderiv (es1 es2 ?1 derivs))
+ (R es1
+ [! ?1]
+ [#:pattern (?form ...)]
+ [Expr (?form ...) derivs])]
+ [#f (RSunit null)]))
+
+ ;; block-reductions : BlockDerivation -> (RS Stxs)
(define (block-reductions bd)
(match/with-derivation bd
- ;; If interrupted in pass1, skip pass2
- [(IntW bderiv (es1 es2 pass1 trans pass2) 'pass1)
- (let-values ([(reductions stxs) (brules-reductions pass1 es1)])
- reductions)]
- ;; Otherwise, do both
- [(IntQ bderiv (es1 es2 pass1 trans pass2))
- (let-values ([(reductions1 stxs1) (brules-reductions pass1 es1)])
- (append reductions1
- (if (eq? trans 'letrec)
- (match pass2
- [(AnyQ lderiv (pass2-es1 _ _))
- (list (walk stxs1 pass2-es1 'block->letrec))])
- null)
- (begin (add-frontier (stx->list* (lift/lderiv-es1 pass2)))
- (list-reductions pass2))))]
- [#f null]))
-
- ;; brules-reductions : (list-of-BRule) syntax-list -> ReductionSequence syntax-list
- (define (brules-reductions brules all-stxs)
- (let loop ([brules brules] [suffix all-stxs] [prefix null] [rss null])
- (cond [(pair? brules)
- (let ([brule0 (car brules)]
- [next (cdr brules)])
- (match/with-derivation brule0
- [(struct b:expr (renames head))
- (rename-frontier (car renames) (cdr renames))
- (let ([estx (deriv-e2 head)])
- (loop next (stx-cdr suffix) (cons estx prefix)
- (cons (with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix))))
- (reductions* head))
- rss)))]
- [(IntW b:expr (renames head) tag)
- (rename-frontier (car renames) (cdr renames))
- (loop next #f #f
- (cons (with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix))))
- (reductions* head))
- rss))]
- [(struct b:defvals (renames head))
- (rename-frontier (car renames) (cdr renames))
- (let ([head-rs
- (with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix))))
- (reductions* head))])
- (loop next (stx-cdr suffix) (cons (deriv-e2 head) prefix)
- (cons head-rs rss)))]
- [(AnyQ b:defstx (renames head rhs))
- (rename-frontier (car renames) (cdr renames))
- (let* ([estx (deriv-e2 head)]
- [estx2 (and (deriv? rhs)
- (with-syntax ([(?ds ?vars ?rhs) estx]
- [?rhs* (deriv-e2 rhs)])
- (datum->syntax-object estx
- `(,#'?ds ,#'?vars ,#'?rhs*)
- estx estx)))])
- (loop next (stx-cdr suffix) (cons estx2 prefix)
- (with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix))))
- (cons (with-context (CC ?rhs estx (?ds ?vars ?rhs))
- (reductions* rhs))
- (cons (reductions* head)
- rss)))))]
- [(struct b:splice (renames head tail))
- (rename-frontier (car renames) (cdr renames))
- (loop next tail prefix
- (cons (list (walk/foci (deriv-e2 head)
- (stx-take tail
- (- (stx-improper-length tail)
- (stx-improper-length (stx-cdr suffix))))
- (revappend prefix
- (cons (deriv-e2 head) (stx-cdr suffix)))
- (revappend prefix tail)
- 'splice-block))
- (cons (with-context (lambda (x)
- (revappend prefix (cons x (stx-cdr suffix))))
- (reductions* head))
- rss)))]
- [(struct b:begin (renames head derivs))
- ;; FIXME
- (error 'unimplemented)]
- [(struct error-wrap (exn tag _inner))
- (values (list (stumble/E suffix (revappend prefix suffix) exn))
- (revappend prefix suffix))]))]
- [(null? brules)
- (values (apply append (reverse rss))
- (revappend prefix suffix))])))
+ [(Wrap bderiv (es1 es2 pass1 trans pass2))
+ (R es1
+ [#:pattern ?form]
+ [(BRules es1) ?form pass1]
+ [#:when/np (eq? trans 'letrec)
+ [#:walk (wlderiv-es1 pass2) 'block->letrec]]
+ [#:frontier (stx->list* (wlderiv-es1 pass2))]
+ [#:pattern ?form]
+ [List ?form pass2])]
+ [#f (RSunit null)]))
- ;; mbrules-reductions : MBRules (list-of syntax) -> ReductionSequence
- ;; The reprocess-on-lift? argument controls the behavior of a mod:lift event.
- ;; In Pass1, #t; in Pass2, #f.
- (define (mbrules-reductions mbrules all-stxs reprocess-on-lift?)
- ;(printf "**** MB Reductions, pass ~s~n" (if reprocess-on-lift? 1 2))
- (let* ([final-stxs #f]
- [reductions
- (let loop ([mbrules mbrules] [suffix all-stxs] [prefix null])
- (define (the-context x) (revappend prefix (cons x (stx-cdr suffix))))
- (cond [(pair? mbrules)
- (let ([mbrule0 (car mbrules)]
- [next (cdr mbrules)])
- (match/with-derivation mbrule0
- [(struct mod:skip ())
- ;(blaze-frontier (stx-car suffix))
- (loop next (stx-cdr suffix) (cons (stx-car suffix) prefix))]
- [(struct mod:cons (head))
- ;(blaze-frontier (stx-car suffix))
- (rename-frontier (stx-car suffix) (lift/deriv-e1 head))
- (add-frontier (list (lift/deriv-e1 head)))
- (append (with-context the-context (append (reductions* head)))
- (let ([estx (and (deriv? head) (deriv-e2 head))])
- (loop next (stx-cdr suffix) (cons estx prefix))))]
- [(AnyQ mod:prim (head prim))
- ;(blaze-frontier (stx-car suffix))
- (rename-frontier (stx-car suffix) (lift/deriv-e1 head))
- (add-frontier (list (lift/deriv-e1 head)))
- (append (with-context the-context
- (append (reductions* head)
- (begin
- (when prim
- (add-frontier (list (lift/deriv-e1 prim))))
- (reductions* prim))))
- (let ([estx
- (if prim
- (lift/deriv-e2 prim)
- (and (deriv? head) (deriv-e2 head)))])
- (loop next (stx-cdr suffix) (cons estx prefix))))]
- [(ErrW mod:splice (head stxs) exn)
- ;(blaze-frontier (stx-car suffix))
- (rename-frontier (stx-car suffix) (lift/deriv-e1 head))
- (add-frontier (list (lift/deriv-e1 head)))
- (append (with-context the-context (reductions* head))
- (list (stumble (deriv-e2 head) exn)))]
- [(struct mod:splice (head stxs))
- ;(blaze-frontier (stx-car suffix))
- (rename-frontier (stx-car suffix) (lift/deriv-e1 head))
- (add-frontier (list (lift/deriv-e1 head)))
- (append
- (with-context the-context (reductions* head))
- (let ([suffix-tail (stx-cdr suffix)]
- [head-e2 (deriv-e2 head)])
- (let ([new-stxs (stx-take stxs
- (- (stx-improper-length stxs)
- (stx-improper-length suffix-tail)))])
- (cons (walk/foci head-e2
- new-stxs
- (revappend prefix (cons head-e2 suffix-tail))
- (revappend prefix stxs)
- 'splice-module)
- (begin (add-frontier new-stxs)
- (loop next stxs prefix))))))]
- [(struct mod:lift (head stxs))
- ;; FIXME: frontier
- (append
- (with-context the-context (reductions* head))
- (let ([suffix-tail (stx-cdr suffix)]
- [head-e2 (deriv-e2 head)])
- (let ([new-suffix (append stxs (cons head-e2 suffix-tail))])
- (cons (walk/foci null
- stxs
- (revappend prefix (cons head-e2 suffix-tail))
- (revappend prefix new-suffix)
- 'splice-lifts)
- (loop next
- new-suffix
- prefix)))))]
- [(struct mod:lift-end (tail))
- ;; FIXME: frontier
- (append
- (if (pair? tail)
- (list (walk/foci null
- tail
- (revappend prefix suffix)
- (revappend prefix tail)
- 'splice-module-lifts))
- null)
- (loop next tail prefix))]))]
- [(null? mbrules)
- (set! final-stxs (reverse prefix))
- null]))])
- (values reductions final-stxs)))
+ ;; mk-brules-reductions : stxs -> (list-of BRule) -> (RS Stxs)
+ (define ((mk-brules-reductions es1) brules)
+ (match brules
+ ['()
+ (RSunit null)]
+ [(cons (Wrap b:expr (renames head)) rest)
+ (R es1
+ [#:pattern (?first . ?rest)]
+ [#:bind ?first* (cdr renames)]
+ [#:rename/no-step ?first (car renames) (cdr renames)]
+ [Expr ?first head]
+ [(BRules (stx-cdr es1)) ?rest rest])]
+ [(cons (Wrap b:defvals (renames head ?1)) rest)
+ (R es1
+ [#:pattern (?first . ?rest)]
+ [#:bind ?first* (cdr renames)]
+ [#:rename/no-step ?first (car renames) (cdr renames)]
+ [Expr ?first head]
+ [! ?1]
+ [#:pattern ((?define-values ?vars ?rhs) . ?rest)]
+ [#:learn (syntax->list #'?vars)]
+ [(BRules (stx-cdr es1)) ?rest rest])]
+ [(cons (Wrap b:defstx (renames head ?1 bindrhs)) rest)
+ (R es1
+ [#:pattern (?first . ?rest)]
+ [#:bind ?first* (cdr renames)]
+ [#:rename/no-step ?first (car renames) (cdr renames)]
+ [Expr ?first head]
+ [! ?1]
+ [#:pattern ((?define-syntaxes ?vars ?rhs) . ?rest)]
+ [#:learn (syntax->list #'?vars)]
+ [BindSyntaxes ?rhs bindrhs]
+ [(BRules (stx-cdr es1)) ?rest rest])]
+ [(cons (Wrap b:splice (renames head ?1 tail ?2)) rest)
+ (R es1
+ [#:pattern (?first . ?rest)]
+ [#:bind ?first* (cdr renames)]
+ [#:rename/no-step ?first (car renames) (cdr renames)]
+ [Expr ?first head]
+ [! ?1]
+ [#:walk tail
+ (list #'?first)
+ (stx-take tail (- (stx-improper-length tail)
+ (stx-improper-length #'?rest)))
+ 'splice-block]
+ [! ?2]
+ [#:pattern ?forms]
+ [(BRules (stx->list* #'?forms)) ?forms rest])]
+ [(cons (Wrap b:error (exn)) rest)
+ (R es1
+ [! exn])]))
- (define (stx->list* stx)
- (cond [(pair? stx)
- (cons (car stx) (stx->list* (cdr stx)))]
- [(null? stx)
- null]
- [(syntax? stx)
- (let ([x (syntax-e stx)])
- (if (pair? x)
- (cons (car x) (stx->list* (cdr x)))
- (list stx)))]
- [else null]))
+ ;; bind-syntaxes-reductions : BindSyntaxes -> (RS stx)
+ (define (bind-syntaxes-reductions bindrhs)
+ (match bindrhs
+ [(Wrap bind-syntaxes (rhs ?1))
+ (R (wderiv-e1 rhs)
+ [#:pattern ?form]
+ [Expr ?form rhs]
+ [! ?1])]))
+
+ ;; mk-mbrules-reductions : stx -> (list-of MBRule) -> (RS stxs)
+ (define ((mk-mbrules-reductions es1) mbrules)
+ (match mbrules
+ ['()
+ (RSunit null)]
+ [(cons (Wrap mod:skip ()) rest)
+ (R es1
+ [#:pattern (?first . ?rest)]
+ [(ModulePass (stx-cdr es1)) ?rest rest])]
+ [(cons (Wrap mod:cons (head)) rest)
+ (R es1
+ [#:pattern (?first . ?rest)]
+ [Expr ?first head]
+ [(ModulePass (stx-cdr es1)) ?rest rest])]
+ [(cons (Wrap mod:prim (head prim)) rest)
+ (R es1
+ [#:pattern (?first . ?rest)]
+ [Expr ?first head]
+ [Expr ?first prim]
+ [(ModulePass (stx-cdr es1)) ?rest rest])]
+ [(cons (Wrap mod:splice (head ?1 tail)) rest)
+ (R es1
+ [#:pattern (?first . ?rest)]
+ [Expr ?first head]
+ [! ?1]
+ [#:walk tail
+ (list #'?first)
+ (stx-take tail (- (stx-improper-length tail)
+ (stx-improper-length #'?rest)))
+ 'splice-module]
+ [#:pattern ?forms]
+ [(ModulePass #'?forms) ?forms rest])]
+ [(cons (Wrap mod:lift (head stxs)) rest)
+ (R es1
+ [#:pattern (?first . ?rest)]
+ [Expr ?first head]
+ [#:pattern ?forms]
+ [#:walk (append stxs #'?forms)
+ null
+ stxs
+ 'splice-lifts]
+ [(ModulePass #'?forms) ?forms rest])]
+ [(cons (Wrap mod:lift-end (stxs)) rest)
+ (R es1
+ [#:pattern ?forms]
+ [#:when/np (pair? stxs)
+ [#:walk (append stxs #'?forms)
+ null
+ stxs
+ 'splice-module-lifts]]
+ [(ModulePass #'?forms) ?forms rest])]))
+
)
diff --git a/collects/macro-debugger/model/steps.ss b/collects/macro-debugger/model/steps.ss
@@ -1,7 +1,8 @@
(module steps mzscheme
(require "deriv.ss"
- "deriv-util.ss")
+ "deriv-util.ss"
+ "deriv-find.ss")
(provide (all-defined))
;; A ReductionSequence is a (list-of Reduction)
@@ -71,7 +72,7 @@
;; A StepType is a simple in the following alist.
(define step-type-meanings
- '((macro-step . "Macro transformation")
+ '((macro . "Macro transformation")
(rename-lambda . "Rename formal parameters")
(rename-case-lambda . "Rename formal parameters")
diff --git a/collects/macro-debugger/model/stx-util.ss b/collects/macro-debugger/model/stx-util.ss
@@ -31,25 +31,32 @@
[(syntax/restamp (pa (... ...)) new-expr old-expr)
#`(let ([new-parts (stx->list new-expr)]
[old-parts (stx->list old-expr)])
- #;
+ ;; FIXME
(unless (= (length new-parts) (length old-parts))
(printf "** syntax/restamp~n~s~n" (quote-syntax #,stx))
(printf "pattern : ~s~n" (syntax-object->datum #'(pa (... ...))))
- (printf "old parts: ~s~n" old-parts)
- (printf "new parts: ~s~n" new-parts))
+ (printf "old parts: ~s~n" (map syntax-object->datum old-parts))
+ (printf "new parts: ~s~n" (map syntax-object->datum new-parts)))
(d->so
old-expr
(map (lambda (new old) (syntax/restamp pa new old))
new-parts
old-parts)))]
[(syntax/restamp (pa . pb) new-expr old-expr)
- #'(let ([na (stx-car new-expr)]
- [nb (stx-cdr new-expr)]
- [oa (stx-car old-expr)]
- [ob (stx-cdr old-expr)])
- (d->so old-expr
- (cons (syntax/restamp pa na oa)
- (syntax/restamp pb nb ob))))]
+ ;; FIXME
+ #'(begin
+ (unless (and (stx-pair? new-expr) (stx-pair? old-expr))
+ (printf "** syntax/restamp~n~s~n" (quote-syntax #,stx))
+ (printf "pattern : ~s~n" (syntax-object->datum (quote-syntax (pa . pb))))
+ (printf "old parts: ~s~n" old-expr)
+ (printf "new parts: ~s~n" new-expr))
+ (let ([na (stx-car new-expr)]
+ [nb (stx-cdr new-expr)]
+ [oa (stx-car old-expr)]
+ [ob (stx-cdr old-expr)])
+ (d->so old-expr
+ (cons (syntax/restamp pa na oa)
+ (syntax/restamp pb nb ob)))))]
[(syntax/restamp pvar new-expr old-expr)
#'new-expr]))
@@ -64,10 +71,30 @@
(cond [(zero? n) null]
[else (cons (stx-car items) (stx-take (stx-cdr items) (sub1 n)))]))
+ (define (take-if-possible items n)
+ (unless (number? n)
+ (raise-type-error 'take-if-possible "number" n))
+ (if (and (pair? items) (positive? n))
+ (cons (car items) (take-if-possible (cdr items) (sub1 n)))
+ null))
+
;; stx-improper-length : syntax -> number
(define (stx-improper-length stx)
(let loop ([stx stx] [n 0])
(if (stx-pair? stx)
(loop (stx-cdr stx) (add1 n))
n)))
- )
+
+ (define (stx->list* stx)
+ (cond [(pair? stx)
+ (cons (car stx) (stx->list* (cdr stx)))]
+ [(null? stx)
+ null]
+ [(syntax? stx)
+ (let ([x (syntax-e stx)])
+ (if (pair? x)
+ (cons (car x) (stx->list* (cdr x)))
+ (list stx)))]
+ [else null]))
+
+)
diff --git a/collects/macro-debugger/model/trace.ss b/collects/macro-debugger/model/trace.ss
@@ -1,14 +1,11 @@
(module trace mzscheme
- (require (lib "lex.ss" "parser-tools")
- (lib "class.ss"))
+ (require (lib "lex.ss" "parser-tools"))
(require "deriv.ss"
"deriv-parser.ss"
"deriv-tokens.ss"
- "reductions.ss"
- "hide.ss"
- "hiding-policies.ss")
-
+ "reductions.ss")
+
(provide trace-verbose?
trace
trace/result
diff --git a/collects/macro-debugger/model/yacc-ext.ss b/collects/macro-debugger/model/yacc-ext.ss
@@ -4,7 +4,8 @@
(require (prefix yacc: (lib "yacc.ss" "parser-tools")))
(provide parser
options
- productions)
+ productions
+ definitions)
(define-syntax options
(lambda (stx)
@@ -13,32 +14,37 @@
(define-syntax productions
(lambda (stx)
(raise-syntax-error #f "productions keyword used out of context" stx)))
-
+
+ (define-syntax definitions
+ (lambda (stx)
+ (raise-syntax-error #f "definitions keyword used out of context" stx)))
+
(define-syntax (parser stx)
(syntax-case stx ()
[(parser form ...)
- (let* ([stop-list (list #'begin #'options #'productions)]
- [forms (syntax->list #'(form ...))]
- [options+productions
- (let loop ([forms forms] [opts null] [prods null])
- (if (pair? forms)
- (let ([eform0 (local-expand (car forms) 'expression stop-list)]
- [forms (cdr forms)])
- (syntax-case eform0 (begin options productions)
- [(begin subform ...)
- (loop (append (syntax->list #'(subform ...)) forms) opts prods)]
- [(options subform ...)
- (loop forms (append (syntax->list #'(subform ...)) opts) prods)]
- [(productions subform ...)
- (loop forms opts (append (syntax->list #'(subform ...)) prods))]
- [else
- (raise-syntax-error #f "bad parser subform" eform0)]))
- (cons opts (reverse prods))))]
- [opts (car options+productions)]
- [prods (cdr options+productions)])
+ (let ([stop-list (list #'begin #'options #'productions #'definitions)]
+ [forms (syntax->list #'(form ...))])
+ (define-values (opts prods defs)
+ (let loop ([forms forms] [opts null] [prods null] [defs null])
+ (if (pair? forms)
+ (let ([eform0 (local-expand (car forms) 'expression stop-list)]
+ [forms (cdr forms)])
+ (syntax-case eform0 (begin options productions definitions)
+ [(begin subform ...)
+ (loop (append (syntax->list #'(subform ...)) forms) opts prods defs)]
+ [(options subform ...)
+ (loop forms (append (syntax->list #'(subform ...)) opts) prods defs)]
+ [(productions subform ...)
+ (loop forms opts (append (syntax->list #'(subform ...)) prods) defs)]
+ [(definitions subform ...)
+ (loop forms opts prods (append (syntax->list #'(subform ...)) defs))]
+ [else
+ (raise-syntax-error #f "bad parser subform" eform0)]))
+ (values opts prods defs))))
(with-syntax ([(opt ...) opts]
- [(prod ...) prods])
- #'(yacc:parser opt ... (grammar prod ...))))]))
-
-
+ [(prod ...) prods]
+ [(def ...) defs])
+ #'(let ()
+ def ...
+ (#%expression (yacc:parser opt ... (grammar prod ...))))))]))
)
diff --git a/collects/macro-debugger/model/yacc-interrupted.ss b/collects/macro-debugger/model/yacc-interrupted.ss
@@ -1,30 +1,33 @@
(module yacc-interrupted mzscheme
- (require "deriv.ss"
- "yacc-ext.ss")
- (provide ! ?
- production/I
- productions/I
+ (require-for-syntax (lib "etc.ss"))
+ (require "yacc-ext.ss")
+ (provide ! ? !!
+ define-production-splitter
skipped-token-values
%skipped
%action)
;; Grammar macros for "interrupted parses"
- ;; Uses interrupted-wrap and error-wrap from deriv.ss
-
+
(define-syntax !
(lambda (stx)
(raise-syntax-error #f "keyword ! used out of context" stx)))
-
+
+ (define-syntax !!
+ (lambda (stx)
+ (raise-syntax-error #f "keyword !! used out of context" stx)))
+
(define-syntax ?
(lambda (stx)
(raise-syntax-error #f "keyword ? used out of context" stx)))
-
- (define-syntax (productions/I stx)
- (syntax-case stx ()
- [(productions/I def ...)
- #'(begin (production/I def) ...)]))
-
+
+ (define-syntax define-production-splitter
+ (syntax-rules ()
+ [(define-production-splitter name ok intW)
+ (define-syntax name
+ (make-production-splitter #'ok #'intW))]))
+
(define-for-syntax (partition-options/alternates forms)
(let loop ([forms forms] [options null] [alts null])
(if (pair? forms)
@@ -33,17 +36,17 @@
(loop (cdr forms) (cons (cons #:args #'args) options) alts)]
[(#:skipped expr)
(loop (cdr forms) (cons (cons #:skipped #'expr) options) alts)]
- [(#:no-interrupted)
- (loop (cdr forms) (cons (cons #:no-interrupted #t) options) alts)]
+ [(#:wrap)
+ (loop (cdr forms) (cons (cons #:wrap #t) options) alts)]
[(#:no-wrap)
(loop (cdr forms) (cons (cons #:no-wrap #t) options) alts)]
- [(#:no-wrap-error)
- (loop (cdr forms) (cons (cons #:no-wrap-error #t) options) alts)]
[(kw . args)
(keyword? (syntax-e #'kw))
- (raise-syntax-error #f "bad keyword" (car forms))]
+ (raise-syntax-error 'split "bad keyword" (car forms))]
[(pattern action)
- (loop (cdr forms) options (cons (cons #'pattern #'action) alts))])
+ (loop (cdr forms) options (cons (cons #'pattern #'action) alts))]
+ [other
+ (raise-syntax-error 'split "bad grammar option or alternate" #'other)])
(values options (reverse alts)))))
(define-for-syntax (symbol+ . args)
@@ -53,118 +56,203 @@
[(number? x) (number->string x)]
[(symbol? x) (symbol->string x)]))
(string->symbol (apply string-append (map norm args))))
-
+
(define-for-syntax (I symbol)
(syntax-local-introduce
(syntax-local-get-shadower (datum->syntax-object #f symbol))))
-
- (define-for-syntax (elaborate-skipped-tail head tail action)
- (define new-tail
- (let loop ([parts tail])
- (syntax-case parts (? !)
- [() #'()]
- [(! . parts-rest) (loop #'((! #f) . parts-rest))]
- [((! expr) . parts-rest)
- (with-syntax ([NoError (I 'NoError)]
- [parts-rest (loop #'parts-rest)])
- #'(NoError . parts-rest))]
+
+ (define-for-syntax ($name n)
+ (I (symbol+ '$ n)))
+
+ (define-for-syntax (interrupted-name s)
+ (I (symbol+ s '/Interrupted)))
+
+ (define-for-syntax (skipped-name s)
+ (I (symbol+ s '/Skipped)))
+
+ (define-for-syntax (elaborate-skipped-tail head tail position args mk-action)
+ (define-values (new-tail new-arguments)
+ (let loop ([parts tail] [position position] [rtail null] [arguments null])
+ (syntax-case parts (? ! !!)
+ [()
+ (values (reverse rtail) (reverse arguments))]
+ [(! . parts-rest)
+ (loop #'parts-rest position rtail (cons #'#f arguments))]
+ [(!! . parts-rest)
+ (raise-syntax-error 'split
+ "cannot have !! after potential error"
+ #'!!)]
[((? NT) . parts-rest)
- (loop #'((? NT #f) . parts-rest))]
- [((? NT expr) . parts-rest)
- (loop #'(NT . parts-rest))]
- [(part0 . parts-rest)
- (identifier? #'part0)
- (with-syntax ([part0/Skipped (I (symbol+ #'part0 '/Skipped))]
- [parts-rest (loop #'parts-rest)])
- #'(part0/Skipped . parts-rest))])))
- (with-syntax ([head head]
- [new-tail new-tail])
- (cons #'(head . new-tail)
- action)))
-
- (define-for-syntax (elaborate-successful-alternate alt)
+ (loop #'(NT . parts-rest) position rtail arguments)]
+ [(NT . parts-rest)
+ (identifier? #'NT)
+ (loop #'parts-rest
+ (add1 position)
+ (cons (skipped-name #'NT) rtail)
+ (cons ($name position) arguments))])))
+ (define arguments (append (reverse args) new-arguments))
+ (cons #`(#,head . #,new-tail)
+ (mk-action arguments)))
+
+ (define-for-syntax ((make-elaborate-successful-alternate wrap? okW) alt)
(define pattern (car alt))
- (define action (cdr alt))
- (cons (let loop ([parts pattern])
- (syntax-case parts (? !)
- [() #'()]
- [(! . parts-rest)
- (loop #'((! #f) . parts-rest))]
- [((! expr) . parts-rest)
- (with-syntax ([NoError (I 'NoError)]
- [parts-rest (loop #'parts-rest)])
- #'(NoError . parts-rest))]
- [((? NT) . parts-rest)
- (loop #'((? NT #f) . parts-rest))]
- [((? NT expr) . parts-rest)
- (with-syntax ([parts-rest (loop #'parts-rest)])
- #'(NT . parts-rest))]
- [(part0 . parts-rest)
- (identifier? #'part0)
- (with-syntax ([parts-rest (loop #'parts-rest)])
- #'(part0 . parts-rest))]))
- action))
-
- (define-for-syntax (elaborate-interrupted-alternate alt wrap? wrap-error?)
+ (define action-function (cdr alt))
+ (define-values (new-patterns arguments)
+ (let loop ([parts pattern] [rpattern null] [position 1] [args null])
+ (syntax-case parts (? ! !!)
+ [() (values (list (reverse rpattern)) (reverse args))]
+ [(! . parts-rest)
+ (loop #'parts-rest rpattern position (cons #'#f args))]
+ [(!!)
+ (values null null)]
+ [((? NT) . parts-rest)
+ (loop (cons #'NT #'parts-rest) rpattern position args)]
+ [(NT . parts-rest)
+ (identifier? #'NT)
+ (loop #'parts-rest (cons #'NT rpattern)
+ (add1 position) (cons ($name position) args))])))
+ (map (lambda (new-pattern)
+ (cons (datum->syntax-object #f new-pattern pattern)
+ #`(#,action-function #,(if wrap? okW #'values) #,@arguments)))
+ new-patterns))
+
+ (define-for-syntax ((make-elaborate-interrupted-alternate wrap? intW) alt)
(define pattern (car alt))
- (define action (cdr alt))
- (let loop ([parts pattern] [position 1])
- (syntax-case parts (? !)
+ (define action-function (cdr alt))
+ (define (int-action args)
+ (let ([wrapf (if wrap? #`(lambda (x) (#,intW x)) #'values)])
+ #`(#,action-function #,wrapf #,@args)))
+ (let loop ([parts pattern] [position 1] [args null])
+ (syntax-case parts (? ! !!)
[()
;; Can't be interrupted
null]
[(! . parts-rest)
- (loop #'((! #f) . parts-rest) position)]
- [((! expr) . parts-rest)
(cons
;; Error occurs
- (with-syntax ([Error (I 'syntax-error #;Error)]
- [action action]
- [position-argument (I (symbol+ '$ position))])
- (elaborate-skipped-tail
- #'Error
- #'parts-rest
- (if wrap-error?
- #'(make-error-wrap position-argument expr action)
- #'action)))
+ (elaborate-skipped-tail (I 'syntax-error)
+ #'parts-rest
+ (add1 position)
+ (cons ($name position) args)
+ int-action)
;; Error doesn't occur
- (with-syntax ([NoError (I 'NoError)])
- (loop #'(NoError . parts-rest) position)))]
+ (loop #'parts-rest position (cons #'#f args)))]
+ [(!!)
+ (cons
+ (elaborate-skipped-tail (I 'syntax-error)
+ #'()
+ (add1 position)
+ (cons ($name position) args)
+ int-action)
+ null)]
[((? NT) . parts-rest)
- (loop #'((? NT #f) . parts-rest) position)]
- [((? NT expr) . parts-rest)
(cons
;; NT is interrupted
- (with-syntax ([NT/I (I (symbol+ #'NT '/Interrupted))]
- [action action])
- (elaborate-skipped-tail
- #'NT/I
- #'parts-rest
- (if wrap?
- #'(make-interrupted-wrap expr action)
- #'action)))
+ (elaborate-skipped-tail (I (symbol+ #'NT '/Interrupted))
+ #'parts-rest
+ (add1 position)
+ (cons ($name position) args)
+ int-action)
;; NT is not interrupted
- (loop #'(NT . parts-rest) position))]
+ (loop #'(NT . parts-rest) position args))]
[(part0 . parts-rest)
(identifier? #'part0)
(map (lambda (clause) (cons #`(part0 . #,(car clause)) (cdr clause)))
- (loop #'parts-rest (add1 position)))])))
+ (loop #'parts-rest (add1 position) (cons ($name position) args)))])))
+
+ (define-for-syntax (generate-action-name nt pos)
+ (syntax-local-get-shadower
+ (datum->syntax-object #f (symbol+ 'action-for- nt '/ pos))))
- (define-syntax (production/I stx)
+ (define-for-syntax ((make-rewrite-alt+def nt args-spec) alt pos)
+ (define pattern (car alt))
+ (define action (cdr alt))
+ (define-values (var-indexes non-var-indexes)
+ (let loop ([pattern pattern] [n 1] [vars null] [nonvars null])
+ (syntax-case pattern ()
+ [(first . more)
+ (syntax-case #'first (! ? !!)
+ [!
+ (loop #'more (add1 n) (cons n vars) nonvars)]
+ [(! . _)
+ (raise-syntax-error 'split
+ "misuse of ! grammar form"
+ pattern #'first)]
+ [!!
+ (when (pair? (syntax-e #'more))
+ (raise-syntax-error 'split
+ "nothing may follow !!"
+ pattern))
+ (loop #'more (add1 n) (cons n vars) nonvars)]
+ [(!! . _)
+ (raise-syntax-error 'split
+ "misuse of !! grammar form"
+ pattern #'first)]
+ [(? NT)
+ (identifier? #'NT)
+ (loop #'more (add1 n) (cons n vars) nonvars)]
+ [(? . _)
+ (raise-syntax-error 'split
+ "misuse of ? grammar form"
+ pattern #'first)]
+ [NT
+ (identifier? #'NT)
+ (loop #'more (add1 n) (cons n vars) nonvars)]
+ [other
+ (raise-syntax-error 'rewrite-pattern
+ "invalid grammar pattern"
+ pattern #'first)])]
+ [()
+ (values (reverse vars) (reverse nonvars))])))
+ (define variables (map $name var-indexes))
+ (define non-var-names (map $name non-var-indexes))
+ (define action-function (generate-action-name nt pos))
+ (cons (cons pattern action-function)
+ (with-syntax ([(var ...) variables]
+ [(nonvar ...) non-var-names]
+ [action-function action-function]
+ [action action])
+ #`(define (action-function wrap var ...)
+ (let-syntax ([nonvar invalid-$name-use] ...)
+ #,(if args-spec
+ #`(lambda #,args-spec (wrap action))
+ #`(wrap action)))))))
+
+ (define-for-syntax (invalid-$name-use stx)
+ (raise-syntax-error #f "no value for positional variable" stx))
+
+ ;; An alternate is (cons pattern action-expr)
+ ;; An alternate* is (cons pattern action-function-name)
+
+ (define-for-syntax ((make-production-splitter okW intW) stx)
(syntax-case stx ()
- [(production/I (name form ...))
+ [(_ (name form ...))
(let ()
- (define-values (options alternates)
+ (define-values (options alternates0)
(partition-options/alternates (syntax->list #'(form ...))))
+ (define wrap?
+ (let ([wrap? (assq #:wrap options)]
+ [no-wrap? (assq #:no-wrap options)])
+ (unless (and (or wrap? no-wrap?) (not (and wrap? no-wrap?)))
+ (raise-syntax-error 'split
+ "must specify exactly one of #:wrap, #:no-wrap"
+ stx))
+ (and wrap? #t)))
+ (define args-spec
+ (let ([p (assq #:args options)]) (and p (cdr p))))
+ (define rewrite-alt+def (make-rewrite-alt+def #'name args-spec))
+ (define alternates+definitions
+ (map rewrite-alt+def alternates0 (build-list (length alternates0) add1)))
+ (define alternates (map car alternates+definitions))
+ (define action-definitions (map cdr alternates+definitions))
+ (define elaborate-successful-alternate
+ (make-elaborate-successful-alternate wrap? okW))
+ (define elaborate-interrupted-alternate
+ (make-elaborate-interrupted-alternate wrap? intW))
(define successful-alternates
- (map elaborate-successful-alternate alternates))
+ (apply append (map elaborate-successful-alternate alternates)))
(define interrupted-alternates
- (apply append
- (map (lambda (a)
- (elaborate-interrupted-alternate a
- (not (assq #:no-wrap options))
- (not (assq #:no-wrap-error options))))
- alternates)))
+ (apply append (map elaborate-interrupted-alternate alternates)))
(with-syntax ([((success-pattern . success-action) ...)
successful-alternates]
[((interrupted-pattern . interrupted-action) ...)
@@ -175,19 +263,15 @@
[name/Interrupted (I (symbol+ #'name '/Interrupted))]
[%action ((syntax-local-certifier) #'%action)])
#`(begin
+ (definitions #,@action-definitions)
(productions
- (name [success-pattern
- (%action args-spec success-action)]
- ...)
- (name/Skipped [() (%skipped args-spec skip-spec)]))
- #,(if (and (not (assq #:no-interrupted options))
- (pair? interrupted-alternates))
- #'(productions
- (name/Interrupted [interrupted-pattern
- (%action args-spec interrupted-action)]
- ...))
- #'(begin)))))]))
-
+ (name [success-pattern success-action] ...)
+ #,(if (pair? interrupted-alternates)
+ #'(name/Interrupted [interrupted-pattern interrupted-action]
+ ...)
+ #'(name/Interrupted [(IMPOSSIBLE) #f]))
+ (name/Skipped [() (%skipped args-spec skip-spec)])))))]))
+
(define-syntax (skipped-token-values stx)
(syntax-case stx ()
[(skipped-token-values)
@@ -201,19 +285,18 @@
(with-syntax ([name/Skipped (I (symbol+ #'name '/Skipped))])
#'(begin (productions (name/Skipped [() value]))
(skipped-token-values . more)))]))
-
+
(define-syntax (%skipped stx)
(syntax-case stx ()
[(%skipped args (#:skipped . expr))
#'(%action args expr)]
[(%skipped args #f)
#'(%action args #f)]))
-
+
(define-syntax (%action stx)
(syntax-case stx ()
- [(elaborate-action (#:args . args) action)
+ [(%action (#:args . args) action)
#'(lambda args action)]
- [(elaborate-action #f action)
+ [(%action #f action)
#'action]))
-
- )
-\ No newline at end of file
+ )
diff --git a/collects/macro-debugger/syntax-browser/controller.ss b/collects/macro-debugger/syntax-browser/controller.ss
@@ -27,13 +27,13 @@
(mixin (displays-manager<%>) (selection-manager<%>)
(inherit-field displays)
(field/notify selected-syntax (new notify-box% (value #f)))
-
+
(super-new)
(listen-selected-syntax
(lambda (new-value)
(for-each (lambda (display) (send display refresh))
displays)))))
-
+
;; mark-manager-mixin
(define mark-manager-mixin
(mixin () (mark-manager<%>)
diff --git a/collects/macro-debugger/syntax-browser/interfaces.ss b/collects/macro-debugger/syntax-browser/interfaces.ss
@@ -15,14 +15,11 @@
;; selection-manager<%>
(define selection-manager<%>
(interface ()
- ;; set-selected-syntax : syntax -> void
+ ;; selected-syntax : syntax/#f
set-selected-syntax
-
- ;; get-selected-syntax : -> syntax
get-selected-syntax
-
- ;; listen-selected-syntax : (syntax -> void) -> void
- listen-selected-syntax))
+ listen-selected-syntax
+ ))
;; mark-manager<%>
;; Manages marks, mappings from marks to colors
diff --git a/collects/macro-debugger/syntax-browser/text.ss b/collects/macro-debugger/syntax-browser/text.ss
@@ -4,11 +4,16 @@
(lib "class.ss")
(lib "mred.ss" "mred")
(lib "arrow.ss" "drscheme")
- (lib "framework.ss" "framework"))
+ (lib "framework.ss" "framework")
+ "../util/notify.ss")
- (provide text:mouse-drawings<%>
+ (provide text:hover<%>
+ text:hover-identifier<%>
+ text:mouse-drawings<%>
text:arrows<%>
+ text:hover-mixin
+ text:hover-identifier-mixin
text:mouse-drawings-mixin
text:tacking-mixin
text:arrows-mixin)
@@ -26,6 +31,8 @@
;; A Drawing is (make-drawing number number (??? -> void) boolean boolean)
(define-struct drawing (start end draw visible? tacked?) #f)
+ (define-struct idloc (start end id) #f)
+
(define (mean x y)
(/ (+ x y) 2))
@@ -57,6 +64,16 @@
(send dc set-text-background old-background)
(send dc set-text-mode old-mode))))
+ (define text:hover<%>
+ (interface (text:basic<%>)
+ update-hover-position))
+
+ (define text:hover-identifier<%>
+ (interface ()
+ get-hovered-identifier
+ set-hovered-identifier
+ listen-hovered-identifier))
+
(define text:mouse-drawings<%>
(interface (text:basic<%>)
add-mouse-drawing
@@ -69,8 +86,51 @@
add-question-arrow
add-billboard))
+ (define text:hover-mixin
+ (mixin (text:basic<%>) (text:hover<%>)
+ (inherit dc-location-to-editor-location
+ find-position)
+
+ (define/override (on-default-event ev)
+ (define gx (send ev get-x))
+ (define gy (send ev get-y))
+ (define-values (x y) (dc-location-to-editor-location gx gy))
+ (define pos (find-position x y))
+ (super on-default-event ev)
+ (case (send ev get-event-type)
+ ((enter motion leave)
+ (update-hover-position pos))))
+
+ (define/public (update-hover-position pos)
+ (void))
+
+ (super-new)))
+
+ (define text:hover-identifier-mixin
+ (mixin (text:hover<%>) (text:hover-identifier<%>)
+ (field/notify hovered-identifier (new notify-box% (value #f)))
+
+ (define idlocs null)
+
+ (define/public (add-identifier-location start end id)
+ (set! idlocs (cons (make-idloc start end id) idlocs)))
+
+ (define/public (delete-all-identifier-locations)
+ (set! idlocs null)
+ (set-hovered-identifier #f))
+
+ (define/override (update-hover-position pos)
+ (super update-hover-position pos)
+ (let search ([idlocs idlocs])
+ (cond [(null? idlocs) (set-hovered-identifier #f)]
+ [(and (<= (idloc-start (car idlocs)) pos)
+ (< pos (idloc-end (car idlocs))))
+ (set-hovered-identifier (idloc-id (car idlocs)))]
+ [else (search (cdr idlocs))])))
+ (super-new)))
+
(define text:mouse-drawings-mixin
- (mixin (text:basic<%>) (text:mouse-drawings<%>)
+ (mixin (text:hover<%>) (text:mouse-drawings<%>)
(inherit dc-location-to-editor-location
find-position
invalidate-bitmap-cache)
@@ -101,16 +161,10 @@
(when (or (drawing-visible? d) (unbox (drawing-tacked? d)))
((drawing-draw d) this dc left top right bottom dx dy))))))
- (define/override (on-default-event ev)
- (define gx (send ev get-x))
- (define gy (send ev get-y))
- (define-values (x y) (dc-location-to-editor-location gx gy))
- (define pos (find-position x y))
- (super on-default-event ev)
- (case (send ev get-event-type)
- ((enter motion leave)
- (let ([changed? (update-visible-drawings pos)])
- (when changed? (invalidate-bitmap-cache 0.0 0.0 +inf.0 +inf.0))))))
+ (define/override (update-hover-position pos)
+ (super update-hover-position pos)
+ (let ([changed? (update-visible-drawings pos)])
+ (when changed? (invalidate-bitmap-cache 0.0 0.0 +inf.0 +inf.0))))
(define/private (update-visible-drawings pos)
(let ([changed? #f])
@@ -260,7 +314,8 @@
(define text:mouse-drawings%
(text:mouse-drawings-mixin
- text:standard-style-list%))
+ (text:hover-mixin
+ text:standard-style-list%)))
(define text:arrows%
(text:arrows-mixin
diff --git a/collects/macro-debugger/syntax-browser/widget.ss b/collects/macro-debugger/syntax-browser/widget.ss
@@ -49,14 +49,12 @@
(widget this)))
(send -text lock #t)
+
(send -split-panel set-percentages
(list (- 1 props-percentage) props-percentage))
;; syntax-properties-controller<%> methods
- (define/public (set-syntax stx)
- (send props set-syntax stx))
-
(define/public (props-shown?)
(send -props-panel is-shown?))
@@ -128,6 +126,7 @@
"purple")))
(send range get-ranges id))]
[_ (void)])
+
(let ([binder (get-binder id)])
(when binder
(for-each
@@ -150,7 +149,7 @@
(send range get-ranges binder)))))
(send range get-identifier-list))))
display)))
-
+
(define/public (add-separator)
(with-unlock -text
(send* -text
@@ -163,9 +162,6 @@
(send -text delete-all-drawings))
(send controller remove-all-syntax-displays))
- (define/public (select-syntax stx)
- (send controller select-syntax stx))
-
(define/public (get-text) -text)
;; internal-add-syntax : syntax -> display
@@ -225,8 +221,11 @@
(class (text:arrows-mixin
(text:tacking-mixin
(text:mouse-drawings-mixin
- (text:hide-caret/selection-mixin
- (editor:standard-style-list-mixin text:basic%)))))
+ (text:hover-mixin
+ (text:hide-caret/selection-mixin
+ (editor:standard-style-list-mixin text:basic%))))))
+ (inherit set-autowrap-bitmap)
(define/override (default-style-name) "Basic")
- (super-new)))
+ (super-new (auto-wrap #t))
+ (set-autowrap-bitmap #f)))
)
diff --git a/collects/macro-debugger/view/hiding-panel.ss b/collects/macro-debugger/view/hiding-panel.ss
@@ -6,7 +6,8 @@
(lib "boundmap.ss" "syntax")
"util.ss"
"../model/synth-engine.ss"
- "../syntax-browser/util.ss")
+ "../syntax-browser/util.ss"
+ "../util/hiding.ss")
(provide macro-hiding-prefs-widget%)
(define mode:disable "Disable")
@@ -36,11 +37,9 @@
(when (pair? policies)
((car policies) id binding return)
(loop (cdr policies))))
- (cond [(and hide-mzscheme? (symbol? def-mod)
- (regexp-match #rx"^#%" (symbol->string def-mod)))
+ (cond [(and hide-mzscheme? def-mod (scheme-module? def-mod))
#f]
- [(and hide-libs? def-mod
- (lib-module? def-mod))
+ [(and hide-libs? def-mod (lib-module? def-mod))
#f]
[(and hide-contracts? def-name
(regexp-match #rx"^provide/contract-id-"
@@ -290,23 +289,16 @@
(super-new)
(update-visibility)))
- (define (lib-module? mpi)
- (and (module-path-index? mpi)
- (let-values ([(path rel) (module-path-index-split mpi)])
- (cond [(pair? path) (memq (car path) '(lib planet))]
- [(string? path) (lib-module? rel)]
- [else #f]))))
-
(define (get-id-key id)
- (let ([binding
- (or (identifier-binding id)
- (identifier-transformer-binding id))])
+ id
+ #; ;; FIXME
+ (let ([binding (identifier-binding id)])
(get-id-key/binding id binding)))
(define (get-id-key/binding id binding)
- (cond [(pair? binding)
- binding]
- [else id]))
+ (cond [(pair? binding)
+ (list (car binding) (cadr binding))]
+ [else id]))
(define (key=? key1 key2)
(cond [(and (identifier? key1) (identifier? key2))
diff --git a/collects/macro-debugger/view/stepper.ss b/collects/macro-debugger/view/stepper.ss
@@ -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))
