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

Trying to improve module handling

Browse Source 
svn: r4506
This commit is contained in:
Ryan Culpepper 2006-10-06 04:53:15 +00:00
parent 39145f9c71
commit 595ed01172
7 changed files with 52 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/macro-debugger/model/debug.ss
View File

@ -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))]

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

@ -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

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

@ -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)))])

2
collects/macro-debugger/model/deriv.ss
View File

@ -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))

49
collects/macro-debugger/model/hide.ss
View File

@ -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)

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

@ -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]

2
collects/macro-debugger/model/trace-raw.ss
View File

@ -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"