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

macro-stepper: correctly render new letrec transformation

Browse Source
This commit is contained in:
Ryan Culpepper 2010-07-09 15:56:12 -06:00
parent 9abdc72dad
commit cf195b633b
3 changed files with 11 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
collects/macro-debugger/model/reductions-config.rkt
View File

@ -44,9 +44,6 @@
[macro-policy (parameter/c (identifier? . -> . any))]
[subterms-table (parameter/c (or/c subterms-table/c false/c))]
[hides-flags (list-parameter/c boolean?)]
[block-syntax-bindings (parameter/c (listof syntaxish?))]
[block-value-bindings (parameter/c (listof syntaxish?))]
[block-expressions (parameter/c syntaxish?)]
[learn-binders ((listof identifier?) . -> . any)]
[learn-definites ((listof identifier?) . -> . any)]
@ -114,13 +111,6 @@
;; hides-flags : (parameterof (listof (boxof boolean)))
(define hides-flags (make-parameter null))
;; block-syntax-bindings : (parameter/c (listof stx))
;; block-value-bindings : (parameter/c (listof stx))
;; block-expressions : (parameter/c (listof stx))
(define block-value-bindings (make-parameter null))
(define block-syntax-bindings (make-parameter null))
(define block-expressions (make-parameter null))
;; lift params
(define available-lift-stxs (make-parameter null))
(define visible-lift-stxs (make-parameter null))

2
collects/macro-debugger/model/reductions-engine.rkt
View File

@ -46,8 +46,6 @@
;; [#:let var expr]
;; [#:left-foot]
;; [#:walk term2 description]
;; [#:walk/ctx pattern term2 description]
;; [#:walk/foci term2 foci1 foci2 description]
;; [#:rename pattern rename [description]]
;; [#:rename/no-step pattern stx stx]
;; [#:reductions expr]

45
collects/macro-debugger/model/reductions.rkt
View File

@ -462,32 +462,15 @@
(match/count bd
[(Wrap bderiv (es1 es2 pass1 trans pass2))
(R [#:pattern ?block]
[#:parameterize ((block-syntax-bindings null)
(block-value-bindings null)
(block-expressions null))
[#:pass1]
[BlockPass ?block pass1]
[#:pass2]
[#:when (eq? trans 'letrec)
[#:walk
(let* ([pass2-stxs (wlderiv-es1 pass2)]
[letrec-form (car pass2-stxs)]
[letrec-kw (stx-car letrec-form)]
[stx-bindings (reverse (block-syntax-bindings))]
[val-bindings (reverse (block-value-bindings))]
[exprs (block-expressions)]
[mk-letrec-form (lambda (x) (datum->syntax #f x))])
(list
(mk-letrec-form
`(,letrec-kw ,@(if (pair? stx-bindings)
(list stx-bindings)
null)
,val-bindings
. ,exprs))))
'block->letrec]]
[#:rename ?block (wlderiv-es1 pass2)]
[#:set-syntax (wlderiv-es1 pass2)]
[List ?block pass2]])]
[#:pass1]
[BlockPass ?block pass1]
[#:pass2]
[#:if (eq? trans 'letrec)
(;; FIXME: foci (difficult because of renaming?)
[#:walk (wlderiv-es1 pass2) 'block->letrec])
([#:rename ?block (wlderiv-es1 pass2)]
[#:set-syntax (wlderiv-es1 pass2)])]
[List ?block pass2])]
[#f
(R)]))
@ -524,13 +507,11 @@
[#:pass1]
[Expr ?first head]
[! ?1]
[#:pass2]
[#:pattern ((?define-values ?vars . ?body) . ?rest)]
[#:rename (?vars . ?body) rename]
[#:binders #'?vars]
[! ?2]
[#:do (block-value-bindings
(cons (cons #'?vars #'?body) (block-value-bindings)))]
[#:pass2]
[#:pattern (?first . ?rest)]
[BlockPass ?rest rest])]
[(cons (Wrap b:defstx (renames head ?1 rename ?2 bindrhs)) rest)
@ -539,13 +520,11 @@
[#:pass1]
[Expr ?first head]
[! ?1]
[#:pass2]
[#:pattern ((?define-syntaxes ?vars . ?body) . ?rest)]
[#:rename (?vars . ?body) rename]
[#:binders #'?vars]
[! ?2]
[#:do (block-syntax-bindings
(cons (cons #'?vars #'?body) (block-syntax-bindings)))]
[#:pass2]
[#:pattern ((?define-syntaxes ?vars ?rhs) . ?rest)]
[BindSyntaxes ?rhs bindrhs]
[#:pattern (?first . ?rest)]
@ -554,8 +533,6 @@
(R [#:pattern (?first . ?rest)]
[#:rename/no-step ?first (car renames) (cdr renames)]
[Expr ?first head]
[#:do (block-expressions #'(?first . ?rest))]
;; rest better be empty
[BlockPass ?rest rest])]
))