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

macro stepper:

Browse Source 
fixed bug with opaque result of syntax-local-expand-expression
  fixed debug-file support

svn: r14395
This commit is contained in:
Ryan Culpepper 2009-04-01 02:15:09 +00:00
parent 2c85b7a795
commit a2ebc93bd8
4 changed files with 22 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -31,12 +31,7 @@
;; (make-mrule <Base(Stx)> ?Stx (listof LocalAction) ?exn ?Stx ?Deriv) ;; (make-mrule <Base(Stx)> ?Stx (listof LocalAction) ?exn ?Stx ?Deriv)
(define-struct (mrule base) (me1 locals me2 ?2 etx next) #:transparent) (define-struct (mrule base) (me1 locals me2 ?2 etx next) #:transparent)
;; A LocalAction is one of ;; A LocalAction is one of ???
;; (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) (for-stx? me1 inner lifted me2 opaque) (define-struct (local-expansion node) (for-stx? me1 inner lifted me2 opaque)
#:transparent) #:transparent)
(define-struct local-lift (expr id) #:transparent) (define-struct local-lift (expr id) #:transparent)

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

@ -41,6 +41,9 @@
(match/count d (match/count d
[(Wrap deriv (e1 e2)) [(Wrap deriv (e1 e2))
(R [#:pattern ?form] (R [#:pattern ?form]
[#:let transparent-stx (hash-ref opaque-table (syntax-e #'?form) #f)]
[#:when transparent-stx
[#:set-syntax transparent-stx]]
[#:expect-syntax e1 (list d)] [#:expect-syntax e1 (list d)]
[#:when (base? d) [#:when (base? d)
[#:learn (or (base-resolves d) null)]] [#:learn (or (base-resolves d) null)]]
@ -366,20 +369,16 @@
(define (LocalAction local) (define (LocalAction local)
(match/count local (match/count local
[(struct local-expansion (e1 e2 for-stx? me1 inner #f me2 opaque)) [(struct local-expansion (e1 e2 for-stx? me1 inner #f me2 opaque))
(R [#:do (when opaque (R [#:parameterize ((phase (if for-stx? (add1 (phase)) (phase))))
(fprintf (current-error-port)
"LocalAction: local-expand-expr\n"))]
[#:parameterize ((phase (if for-stx? (add1 (phase)) (phase))))
[#:set-syntax e1] [#:set-syntax e1]
[#:pattern ?form] [#:pattern ?form]
[#:rename/mark ?form e1 me1] [#:rename/mark ?form e1 me1]
[Expr ?form inner] [Expr ?form inner]
[#:rename/mark ?form me2 e2]])] [#:rename/mark ?form me2 e2]
[#:do (when opaque
(hash-set! opaque-table (syntax-e opaque) e2))]])]
[(struct local-expansion (e1 e2 for-stx? me1 inner lifted me2 opaque)) [(struct local-expansion (e1 e2 for-stx? me1 inner lifted me2 opaque))
(R [#:do (when opaque (R [#:let begin-stx (stx-car lifted)]
(fprintf (current-error-port)
"LocalAction: not handling opaque val\n"))]
[#:let begin-stx (stx-car lifted)]
[#:let lift-stxs (cdr (reverse (stx->list (stx-cdr lifted))))] [#:let lift-stxs (cdr (reverse (stx->list (stx-cdr lifted))))]
[#:parameterize ((phase (if for-stx? (add1 (phase)) (phase))) [#:parameterize ((phase (if for-stx? (add1 (phase)) (phase)))
(available-lift-stxs lift-stxs) (available-lift-stxs lift-stxs)
@ -400,7 +399,9 @@
[#:step 'splice-lifts visible-lifts]] [#:step 'splice-lifts visible-lifts]]
[#:pass2] [#:pass2]
[#:set-syntax lifted] [#:set-syntax lifted]
[#:rename/mark ?form me2 e2]])] [#:rename/mark ?form me2 e2]
[#:do (when opaque
(hash-set! opaque-table (syntax-e opaque) e2))]])]
[(struct local-lift (expr id)) [(struct local-lift (expr id))
;; FIXME: add action ;; FIXME: add action
(R [#:do (unless (pair? (available-lift-stxs)) (R [#:do (unless (pair? (available-lift-stxs))
@ -613,3 +614,10 @@
(apply fprintf (current-error-port) args) (apply fprintf (current-error-port) args)
(when #t (when #t
(apply error sym args))) (apply error sym args)))
;; opaque-table
;; Weakly remembers assoc between opaque values and
;; actual syntax, so that actual can be substituted in
;; for destructuring.
;; FIXME: perhaps add event for opaque-stx unwrapping?
(define opaque-table (make-weak-hasheq))

2
collects/macro-debugger/view/debug-format.ss
View File

@ -22,7 +22,7 @@
[(symbol? d) `(quote ,d)] [(symbol? d) `(quote ,d)]
[(string? d) `(quote ,d)] [(string? d) `(quote ,d)]
[(pair? d) `(cons ,(serialize-datum (car d)) ,(serialize-datum (cdr d)))] [(pair? d) `(cons ,(serialize-datum (car d)) ,(serialize-datum (cdr d)))]
[(null? d) '()] [(null? d) ''()]
[(exn? d) `(make-exn ,(exn-message d) (current-continuation-marks))] [(exn? d) `(make-exn ,(exn-message d) (current-continuation-marks))]
[(syntax? d) `(datum->syntax #f ',(syntax->datum d))] [(syntax? d) `(datum->syntax #f ',(syntax->datum d))]
#;[(syntax? d) `(eval (quote ,(compile `(,#'quote-syntax ,d))))] #;[(syntax? d) `(eval (quote ,(compile `(,#'quote-syntax ,d))))]

6
collects/macro-debugger/view/debug.ss
View File

@ -22,10 +22,8 @@
(super-new))) (super-new)))
(define (make-stepper) (define (make-stepper)
(let ([f (new macro-stepper-frame% (define director (new macro-stepper-director%))
(config (new macro-stepper-config/prefs%)))]) (send director new-stepper))
(send f show #t)
(send f get-widget)))
(define (debug-file file) (define (debug-file file)
(let-values ([(events msg ctx) (load-debug-file file)]) (let-values ([(events msg ctx) (load-debug-file file)])