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

Macro stepper:

Browse Source 
fixed bug in reductions wrt letrec-syntaxes+values
  added more binding arrows

svn: r5702
This commit is contained in:
Ryan Culpepper 2007-02-27 23:44:25 +00:00
parent efe9e73e8e
commit e675ebf323
2 changed files with 31 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -263,7 +263,11 @@
(p:let-values? x)
(p:letrec-values? x)
(p:letrec-syntaxes+values? x)
(p:rename? 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
[(struct p:lambda (e1 e2 rs renames body))
@ -292,6 +296,28 @@
(with-syntax ([(((?vvars ?vrhs) ...) . ?body) vrenames])
#'(?vvars ...))
null))]
[(struct b:defvals (rename head))
(let ([head-e2 (lift/deriv-e2 head)])
(if head-e2
(with-syntax ([(?dv ?vars ?rhs) head-e2])
#'?vars)
null))]
[(struct b:defstx (rename head rhs))
(let ([head-e2 (lift/deriv-e2 head)])
(if head-e2
(with-syntax ([(?ds ?svars ?rhs) head-e2])
#'?svars)
null))]
[(struct p:define-values (e1 e2 rs rhs))
(if rhs
(with-syntax ([(?dv ?vars ?rhs) e1])
#'?vars)
null)]
[(struct p:define-syntaxes (e1 e2 rs rhs))
(if rhs
(with-syntax ([(?ds ?svars ?srhs) e1])
#'?svars)
null)]
[_ null]))
(let ([all-renaming-forms

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

@ -46,6 +46,7 @@
;; Primitives
[(struct p:variable (e1 e2 rs))
(learn-definites (list e2))
(if (bound-identifier=? e1 e2)
null
(list (walk e1 e2 'resolve-variable)))]
@ -185,7 +186,7 @@
(R e1
[! exni]
[#:pattern (?lsv ([?svars ?srhs] ...) ([?vvars ?vrhs] ...) . ?body)]
[#:bind (([?svars* ?srhs*] ...) ([?vvars* ?vrhs] ...) . ?body*) srenames]
[#:bind (([?svars* ?srhs*] ...) ([?vvars* ?vrhs*] ...) . ?body*) srenames]
[#:rename
(syntax/skeleton e1
(?lsv ([?svars* ?srhs*] ...) ([?vvars* ?vrhs*] ...)
@ -217,6 +218,8 @@
(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)))