diff --git a/collects/macro-debugger/model/debug.ss b/collects/macro-debugger/model/debug.ss index 9297742881..8cae6af457 100644 --- a/collects/macro-debugger/model/debug.ss +++ b/collects/macro-debugger/model/debug.ss @@ -57,7 +57,7 @@ (append (loops rhss) (loop body))] [(AnyQ p:letrec-syntaxes+values (_ _ _ _ srhss _ vrhss body)) (append (loops srhss) (loops vrhss) (loop body))] - [(AnyQ p:module (_ _ _ body)) + [(AnyQ p:module (_ _ _ _ body)) (loop body)] [(AnyQ p:#%module-begin (_ _ _ pass1 pass2)) (append (loops pass1) (loops pass2))] diff --git a/collects/macro-debugger/model/deriv-c.ss b/collects/macro-debugger/model/deriv-c.ss index 23b5294e9a..bc494c673d 100644 --- a/collects/macro-debugger/model/deriv-c.ss +++ b/collects/macro-debugger/model/deriv-c.ss @@ -72,7 +72,7 @@ (define-struct (p:unknown p::STOP) () #f) ;; Module stuff.... hairy - (define-struct (p:module prule) (body) #f) + (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 diff --git a/collects/macro-debugger/model/deriv-parser.ss b/collects/macro-debugger/model/deriv-parser.ss index fd1ab6bcdb..d5a7bd1f9a 100644 --- a/collects/macro-debugger/model/deriv-parser.ss +++ b/collects/macro-debugger/model/deriv-parser.ss @@ -217,14 +217,17 @@ ;; Modules (PrimModule (#:args e1 e2 rs) + ;; Multiple forms after language + ;; #%module-begin tagging done automatically [(prim-module ! (? EE 'body)) - (make-p:module e1 e2 rs $3)] + (make-p:module e1 e2 rs #f $3)] ;; One form after language ... macro that expands into #%module-begin - [(prim-module NoError next + [(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)))]) diff --git a/collects/macro-debugger/model/deriv.ss b/collects/macro-debugger/model/deriv.ss index 7eb517fbfc..49df1024fe 100644 --- a/collects/macro-debugger/model/deriv.ss +++ b/collects/macro-debugger/model/deriv.ss @@ -117,7 +117,7 @@ (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 (body)) + (struct p:module (one-body-form? body)) (struct p:#%module-begin (pass1 pass2)) (struct p::STOP ()) (struct p:#%datum (tagged-stx)) diff --git a/collects/macro-debugger/model/hide.ss b/collects/macro-debugger/model/hide.ss index b9e21c13da..0eb897cf9f 100644 --- a/collects/macro-debugger/model/hide.ss +++ b/collects/macro-debugger/model/hide.ss @@ -103,11 +103,30 @@ [(AnyQ p:variable (e1 e2 rs)) (values d e2)] - [(AnyQ p:module (e1 e2 rs body)) - (>>Prim d e1 #t (make-p:module body) - (module name lang . _BODY) - (module name lang BODY) - ([for-deriv BODY body]))] + [(AnyQ p:module (e1 e2 rs single-body-form? body)) + ;; FIXME: Find the appropriate module-begin identifier to test + ;; otherwise, hide module, seek for body elements... + (let ([show-k + (lambda () + (>>Prim d e1 #t (make-p:module single-body-form? body) + (module name lang . _BODY) + (module name lang BODY) + ([for-deriv BODY body])))]) + (if (or single-body-form? (show-macro? #'#%plain-module-begin)) + (show-k) + (with-handlers ([nonlinearity? + (lambda (nl) + (warn 'nonlinearity + (format "~a: ~s" + (nonlinearity-message nl) + (nonlinearity-paths nl))) + (show-k))] + [localactions? + (lambda (nl) + (warn 'localactions + "opaque macro called local-expand or lifted expression") + (show-k))]) + (seek/deriv d))))] [(struct p:#%module-begin (e1 e2 rs pass1 pass2)) ;; FIXME: hide tagging (let ([lderiv (module-begin->lderiv d)]) @@ -423,7 +442,7 @@ (let ([subterms (gather-proper-subterms e1)]) (parameterize ((subterms-table subterms)) (match (seek d) - [(and ($$ error-wrap (exn tag inner)) ew) + [(and (struct error-wrap (exn tag inner)) ew) (values ew (deriv-e2 inner))] [deriv (values (rewrap d deriv) (deriv-e2 deriv))])))])) @@ -482,13 +501,18 @@ (match d ;; Primitives - - [(AnyQ p:module (e1 e2 rs body)) - (for-deriv body)] + [(AnyQ p:module (e1 e2 rs one-body-form? body)) + (cond [one-body-form? + ;; FIXME: tricky... how to do renaming? + (for-deriv body)] + [else + (with-syntax ([(?module ?name ?lang . ?body) e1] + [(?module-begin . ?body*) (lift/deriv-e1 body)]) + (>>Seek [#:rename (do-rename #'?body #'?body*)] + (for-deriv body)))])] [(AnyQ p:#%module-begin (e1 e2 rs pass1 pass2)) (let ([lderiv (module-begin->lderiv d)]) (for-lderiv lderiv))] - [(AnyQ p:variable (e1 e2 rs)) null] [(AnyQ p:define-syntaxes (e1 e2 rs rhs)) @@ -1064,7 +1088,7 @@ (cons (combine-lifts head finish inners) (loop (sub1 count))))))] ['() - (printf "module-begin->lderiv:loop: unexpected null~n") + #;(printf "module-begin->lderiv:loop: unexpected null~n") (cons #f (loop (sub1 count)))]) null)) @@ -1104,7 +1128,7 @@ (list (make-p:stop head-e2 head-e2 null)))))) (loop2 (sub1 count))))] ['() - (printf "module-body->lderiv:loop2: unexpected null~n") + #;(printf "module-body->lderiv:loop2: unexpected null~n") (cons #f (loop2 (sub1 count)))]) null)) @@ -1231,6 +1255,7 @@ [else null])) (let ([subterms (loop stx rename #t)]) + #;(printf "~nNew Table: ~s~n" t) (values subterms t)))) (define (do-rename/lambda stx rename) diff --git a/collects/macro-debugger/model/reductions.ss b/collects/macro-debugger/model/reductions.ss index b4d09dbdf0..7fe33e4f8c 100644 --- a/collects/macro-debugger/model/reductions.ss +++ b/collects/macro-debugger/model/reductions.ss @@ -28,13 +28,18 @@ ;; Primitives [(struct p:variable (e1 e2 rs)) null] - [(IntQ p:module (e1 e2 rs body)) + [(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 [($$ deriv (body-e1 _) _) body-e1])]) (cons (walk e1 (ctx body-e1) "Tag #%module-begin") (with-context ctx (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 + (reductions body))))] [(IntQ p:#%module-begin (e1 e2 rs pass1 pass2)) #;(R e1 (?module-begin . MBODY) [! exni 'blah] diff --git a/collects/macro-debugger/model/trace-raw.ss b/collects/macro-debugger/model/trace-raw.ss index 2aede4f8a5..1ae63bb685 100644 --- a/collects/macro-debugger/model/trace-raw.ss +++ b/collects/macro-debugger/model/trace-raw.ss @@ -1,6 +1,6 @@ (module trace-raw mzscheme - (require "../syntax-browser/syntax-browser.ss" + (require "../syntax-browser.ss" (lib "class.ss") (lib "lex.ss" "parser-tools") "deriv-tokens.ss"