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

generalized `begin-for-syntax'

Browse Source 
original commit: d3c56c9f13
This commit is contained in:
Matthew Flatt 2011-09-05 16:08:16 -06:00
parent 1161087456
commit 278f090e83
9 changed files with 229 additions and 139 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
collects/compiler/decompile.rkt
View File

@ -164,16 +164,20 @@
(define (decompile-module mod-form stack stx-ht) (define (decompile-module mod-form stack stx-ht)
(match mod-form (match mod-form
[(struct mod (name srcname self-modidx prefix provides requires body syntax-body unexported [(struct mod (name srcname self-modidx prefix provides requires body syntax-bodies unexported
max-let-depth dummy lang-info internal-context)) max-let-depth dummy lang-info internal-context))
(let-values ([(globs defns) (decompile-prefix prefix stx-ht)] (let-values ([(globs defns) (decompile-prefix prefix stx-ht)]
[(stack) (append '(#%modvars) stack)] [(stack) (append '(#%modvars) stack)]
[(closed) (make-hasheq)]) [(closed) (make-hasheq)])
`(module ,name .... `(module ,name ....
,@defns ,@defns
,@(map (lambda (form) ,@(for/list ([b (in-list syntax-bodies)])
(decompile-form form globs stack closed stx-ht)) (let loop ([n (sub1 (car b))])
syntax-body) (if (zero? n)
(cons 'begin
(for/list ([form (in-list (cdr b))])
(decompile-form form globs stack closed stx-ht)))
(list 'begin-for-syntax (loop (sub1 n))))))
,@(map (lambda (form) ,@(map (lambda (form)
(decompile-form form globs stack closed stx-ht)) (decompile-form form globs stack closed stx-ht))
body)))] body)))]
@ -190,18 +194,19 @@
(list-ref/protect (glob-desc-vars globs) pos 'def-vals)])) (list-ref/protect (glob-desc-vars globs) pos 'def-vals)]))
ids) ids)
,(decompile-expr rhs globs stack closed))] ,(decompile-expr rhs globs stack closed))]
[(struct def-syntaxes (ids rhs prefix max-let-depth)) [(struct def-syntaxes (ids rhs prefix max-let-depth dummy))
`(define-syntaxes ,ids `(define-syntaxes ,ids
,(let-values ([(globs defns) (decompile-prefix prefix stx-ht)]) ,(let-values ([(globs defns) (decompile-prefix prefix stx-ht)])
`(let () `(let ()
,@defns ,@defns
,(decompile-form rhs globs '(#%globals) closed stx-ht))))] ,(decompile-form rhs globs '(#%globals) closed stx-ht))))]
[(struct def-for-syntax (ids rhs prefix max-let-depth)) [(struct seq-for-syntax (exprs prefix max-let-depth dummy))
`(define-values-for-syntax ,ids `(begin-for-syntax
,(let-values ([(globs defns) (decompile-prefix prefix stx-ht)]) ,(let-values ([(globs defns) (decompile-prefix prefix stx-ht)])
`(let () `(let ()
,@defns ,@defns
,(decompile-form rhs globs '(#%globals) closed stx-ht))))] ,@(for/list ([rhs (in-list exprs)])
(decompile-form rhs globs '(#%globals) closed stx-ht)))))]
[(struct seq (forms)) [(struct seq (forms))
`(begin ,@(map (lambda (form) `(begin ,@(map (lambda (form)
(decompile-form form globs stack closed stx-ht)) (decompile-form form globs stack closed stx-ht))

4
collects/compiler/demodularizer/gc-toplevels.rkt
View File

@ -64,7 +64,7 @@
(build-graph! new-lhs rhs)] (build-graph! new-lhs rhs)]
[(? def-syntaxes?) [(? def-syntaxes?)
(error 'build-graph "Doesn't handle syntax")] (error 'build-graph "Doesn't handle syntax")]
[(? def-for-syntax?) [(? seq-for-syntax?)
(error 'build-graph "Doesn't handle syntax")] (error 'build-graph "Doesn't handle syntax")]
[(struct req (reqs dummy)) [(struct req (reqs dummy))
(build-graph! lhs dummy)] (build-graph! lhs dummy)]
@ -197,7 +197,7 @@
#f)] #f)]
[(? def-syntaxes?) [(? def-syntaxes?)
(error 'gc-tls "Doesn't handle syntax")] (error 'gc-tls "Doesn't handle syntax")]
[(? def-for-syntax?) [(? seq-for-syntax?)
(error 'gc-tls "Doesn't handle syntax")] (error 'gc-tls "Doesn't handle syntax")]
[(struct req (reqs dummy)) [(struct req (reqs dummy))
(make-req reqs (update dummy))] (make-req reqs (update dummy))]

3
collects/compiler/demodularizer/merge.rkt
View File

@ -108,7 +108,8 @@
(define (merge-module max-let-depth top-prefix mod-form) (define (merge-module max-let-depth top-prefix mod-form)
(match mod-form (match mod-form
[(struct mod (name srcname self-modidx mod-prefix provides requires body syntax-body unexported mod-max-let-depth dummy lang-info internal-context)) [(struct mod (name srcname self-modidx mod-prefix provides requires body syntax-bodies
unexported mod-max-let-depth dummy lang-info internal-context))
(define toplevel-offset (length (prefix-toplevels top-prefix))) (define toplevel-offset (length (prefix-toplevels top-prefix)))
(define topsyntax-offset (length (prefix-stxs top-prefix))) (define topsyntax-offset (length (prefix-stxs top-prefix)))
(define lift-offset (prefix-num-lifts top-prefix)) (define lift-offset (prefix-num-lifts top-prefix))

5
collects/compiler/demodularizer/nodep.rkt
View File

@ -112,7 +112,8 @@
(define (nodep-module mod-form phase) (define (nodep-module mod-form phase)
(match mod-form (match mod-form
[(struct mod (name srcname self-modidx prefix provides requires body syntax-body unexported max-let-depth dummy lang-info internal-context)) [(struct mod (name srcname self-modidx prefix provides requires body syntax-bodies
unexported max-let-depth dummy lang-info internal-context))
(define new-prefix prefix) (define new-prefix prefix)
; Cache all the mpi paths ; Cache all the mpi paths
(for-each (match-lambda (for-each (match-lambda
@ -127,7 +128,7 @@
(append (requires->modlist requires phase) (append (requires->modlist requires phase)
(if (and phase (zero? phase)) (if (and phase (zero? phase))
(begin (log-debug (format "[~S] lang-info : ~S" name lang-info)) ; XXX Seems to always be #f now (begin (log-debug (format "[~S] lang-info : ~S" name lang-info)) ; XXX Seems to always be #f now
(list (make-mod name srcname self-modidx new-prefix provides requires body empty (list (make-mod name srcname self-modidx new-prefix provides requires body syntax-bodies empty
unexported max-let-depth dummy lang-info internal-context))) unexported max-let-depth dummy lang-info internal-context)))
(begin (log-debug (format "[~S] Dropping module @ ~S" name phase)) (begin (log-debug (format "[~S] Dropping module @ ~S" name phase))
empty))))] empty))))]

2
collects/compiler/demodularizer/update-toplevels.rkt
View File

@ -10,7 +10,7 @@
(update rhs))] (update rhs))]
[(? def-syntaxes?) [(? def-syntaxes?)
(error 'increment "Doesn't handle syntax")] (error 'increment "Doesn't handle syntax")]
[(? def-for-syntax?) [(? seq-for-syntax?)
(error 'increment "Doesn't handle syntax")] (error 'increment "Doesn't handle syntax")]
[(struct req (reqs dummy)) [(struct req (reqs dummy))
(make-req reqs (update dummy))] (make-req reqs (update dummy))]

103
collects/compiler/zo-marshal.rkt
View File

@ -158,7 +158,7 @@
(define quote-syntax-type-num 14) (define quote-syntax-type-num 14)
(define define-values-type-num 15) (define define-values-type-num 15)
(define define-syntaxes-type-num 16) (define define-syntaxes-type-num 16)
(define define-for-syntax-type-num 17) (define begin-for-syntax-type-num 17)
(define set-bang-type-num 18) (define set-bang-type-num 18)
(define boxenv-type-num 19) (define boxenv-type-num 19)
(define begin0-sequence-type-num 20) (define begin0-sequence-type-num 20)
@ -256,8 +256,6 @@
(define BITS_PER_MZSHORT 32) (define BITS_PER_MZSHORT 32)
(define *dummy* #f)
(define (int->bytes x) (define (int->bytes x)
(integer->integer-bytes x (integer->integer-bytes x
4 4
@ -522,21 +520,20 @@
(out-marshaled define-values-type-num (out-marshaled define-values-type-num
(list->vector (cons (protect-quote rhs) ids)) (list->vector (cons (protect-quote rhs) ids))
out)] out)]
[(struct def-syntaxes (ids rhs prefix max-let-depth)) [(struct def-syntaxes (ids rhs prefix max-let-depth dummy))
(out-marshaled define-syntaxes-type-num (out-marshaled define-syntaxes-type-num
(list->vector (list* (protect-quote rhs) (list->vector (list* (protect-quote rhs)
prefix prefix
max-let-depth max-let-depth
*dummy* dummy
ids)) ids))
out)] out)]
[(struct def-for-syntax (ids rhs prefix max-let-depth)) [(struct seq-for-syntax (rhs prefix max-let-depth dummy))
(out-marshaled define-for-syntax-type-num (out-marshaled begin-for-syntax-type-num
(list->vector (list* (protect-quote rhs) (vector (map protect-quote rhs)
prefix prefix
max-let-depth max-let-depth
*dummy* dummy)
ids))
out)] out)]
[(struct beg0 (forms)) [(struct beg0 (forms))
(out-marshaled begin0-sequence-type-num (map protect-quote forms) out)] (out-marshaled begin0-sequence-type-num (map protect-quote forms) out)]
@ -825,7 +822,7 @@
(define (out-module mod-form out) (define (out-module mod-form out)
(match mod-form (match mod-form
[(struct mod (name srcname self-modidx prefix provides requires body syntax-body unexported [(struct mod (name srcname self-modidx prefix provides requires body syntax-bodies unexported
max-let-depth dummy lang-info internal-context)) max-let-depth dummy lang-info internal-context))
(let* ([lookup-req (lambda (phase) (let* ([lookup-req (lambda (phase)
(let ([a (assq phase requires)]) (let ([a (assq phase requires)])
@ -844,6 +841,11 @@
(if (ormap values p) (if (ormap values p)
(list->vector p) (list->vector p)
#f)))))] #f)))))]
[extract-unexported
(lambda (phase)
(let ([a (assq phase unexported)])
(and a
(cdr a))))]
[list->vector/#f (lambda (default l) [list->vector/#f (lambda (default l)
(if (andmap (lambda (x) (equal? x default)) l) (if (andmap (lambda (x) (equal? x default)) l)
#f #f
@ -861,45 +863,54 @@
[l (cons (lookup-req 1) l)] ; et-requires [l (cons (lookup-req 1) l)] ; et-requires
[l (cons (lookup-req 0) l)] ; requires [l (cons (lookup-req 0) l)] ; requires
[l (cons (list->vector body) l)] [l (cons (list->vector body) l)]
[l (cons (list->vector [l (append (reverse
(for/list ([i (in-list syntax-body)]) (for/list ([b (in-list syntax-bodies)])
(define (maybe-one l) ;; a single symbol is ok (for/vector ([i (in-list (cdr b))])
(if (and (pair? l) (null? (cdr l))) (define (maybe-one l) ;; a single symbol is ok
(car l) (if (and (pair? l) (null? (cdr l)))
l)) (car l)
(match i l))
[(struct def-syntaxes (ids rhs prefix max-let-depth)) (match i
(vector (maybe-one ids) rhs max-let-depth prefix #f)] [(struct def-syntaxes (ids rhs prefix max-let-depth dummy))
[(struct def-for-syntax (ids rhs prefix max-let-depth)) (vector (maybe-one ids) rhs max-let-depth prefix #f)]
(vector (maybe-one ids) rhs max-let-depth prefix #t)]))) [(struct seq-for-syntax ((list rhs) prefix max-let-depth dummy))
l)] (vector #f rhs max-let-depth prefix #t)]))))
l)]
[l (append (apply [l (append (apply
append append
(map (lambda (l) (map (lambda (l)
(let ([phase (car l)] (let* ([phase (car l)]
[all (append (cadr l) (caddr l))]) [all (append (cadr l) (caddr l))]
(list phase [protects (extract-protects phase)]
(list->vector/#f 0 (map (lambda (p) (= 1 (provided-src-phase p))) [unexported (extract-unexported phase)])
all)) (append
(list->vector/#f #f (map (lambda (p) (list phase)
(if (eq? (provided-nom-src p) (if (and (not protects)
(provided-src p)) (not unexported))
#f ; #f means "same as src" (list (void))
(provided-nom-src p))) (let ([unexported (or unexported
all)) '(() ()))])
(list->vector (map provided-src-name all)) (list (list->vector (cadr unexported))
(list->vector (map provided-src all)) (length (cadr unexported))
(list->vector (map provided-name all)) (list->vector (car unexported))
(length (cadr l)) (length (car unexported))
(length all)))) protects)))
(list (list->vector/#f 0 (map provided-src-phase all))
(list->vector/#f #f (map (lambda (p)
(if (eq? (provided-nom-src p)
(provided-src p))
#f ; #f means "same as src"
(provided-nom-src p)))
all))
(list->vector (map provided-src-name all))
(list->vector (map provided-src all))
(list->vector (map provided-name all))
(length (cadr l))
(length all)))))
provides)) provides))
l)] l)]
[l (cons (length provides) l)] ; number of provide sets [l (cons (length provides) l)] ; number of provide sets
[l (cons (extract-protects 0) l)] ; protects [l (cons (add1 (length syntax-bodies)) l)]
[l (cons (extract-protects 1) l)] ; et protects
[l (list* (list->vector (car unexported)) (length (car unexported)) l)] ; indirect-provides
[l (list* (list->vector (cadr unexported)) (length (cadr unexported)) l)] ; indirect-syntax-provides
[l (list* (list->vector (caddr unexported)) (length (caddr unexported)) l)] ; indirect-et-provides
[l (cons prefix l)] [l (cons prefix l)]
[l (cons dummy l)] [l (cons dummy l)]
[l (cons max-let-depth l)] [l (cons max-let-depth l)]

159
collects/compiler/zo-parse.rkt
View File

@ -181,19 +181,19 @@
(cdr (vector->list v)) (cdr (vector->list v))
(vector-ref v 0))) (vector-ref v 0)))
; XXX Allocates unnessary list
(define (read-define-syntaxes mk v)
(mk (list-tail (vector->list v) 4)
(vector-ref v 0)
(vector-ref v 1)
(vector-ref v 2)
#;(vector-ref v 3)))
(define (read-define-syntax v) (define (read-define-syntax v)
(read-define-syntaxes make-def-syntaxes v)) (make-def-syntaxes (list-tail (vector->list v) 4)
(vector-ref v 0)
(vector-ref v 1)
(vector-ref v 2)
(vector-ref v 3)))
(define (read-define-for-syntax v) (define (read-begin-for-syntax v)
(read-define-syntaxes make-def-for-syntax v)) (make-seq-for-syntax
(vector-ref v 0)
(vector-ref v 1)
(vector-ref v 2)
(vector-ref v 3)))
(define (read-set! v) (define (read-set! v)
(make-assign (cadr v) (cddr v) (car v))) (make-assign (cadr v) (cddr v) (car v)))
@ -225,50 +225,65 @@
(lambda _ #t) (lambda _ #t)
(lambda _ #t))))) (lambda _ #t)))))
(define (split-phase-data rest n)
(let loop ([n n] [rest rest] [phase-accum null])
(cond
[(zero? n)
(values (reverse phase-accum) rest)]
[else
(let ([maybe-indirect (list-ref rest 1)])
(if (void? maybe-indirect)
;; no indirect or protect info:
(loop (sub1 n)
(list-tail rest 9)
(cons (take rest 9) phase-accum))
;; has indirect or protect info:
(loop (sub1 n)
(list-tail rest (+ 5 8))
(cons (take rest (+ 5 8)) phase-accum))))])))
(define (read-module v) (define (read-module v)
(match v (match v
[`(,name ,srcname ,self-modidx ,lang-info ,functional? ,et-functional? [`(,name ,srcname ,self-modidx ,lang-info ,functional? ,et-functional?
,rename ,max-let-depth ,dummy ,rename ,max-let-depth ,dummy
,prefix ,prefix ,num-phases
,indirect-et-provides ,num-indirect-et-provides
,indirect-syntax-provides ,num-indirect-syntax-provides
,indirect-provides ,num-indirect-provides
,protects ,et-protects
,provide-phase-count . ,rest) ,provide-phase-count . ,rest)
(let ([phase-data (take rest (* 8 provide-phase-count))]) (let*-values ([(phase-data rest-module) (split-phase-data rest provide-phase-count)]
(match (list-tail rest (* 8 provide-phase-count)) [(bodies rest-module) (values (take rest-module num-phases)
[`(,syntax-body ,body (drop rest-module num-phases))])
,requires ,syntax-requires ,template-requires ,label-requires (match rest-module
,more-requires-count . ,more-requires) [`(,requires ,syntax-requires ,template-requires ,label-requires
,more-requires-count . ,more-requires)
(make-mod name srcname self-modidx (make-mod name srcname self-modidx
prefix (let loop ([l phase-data]) prefix
(if (null? l) ;; provides:
null (for/list ([l (in-list phase-data)])
(let ([num-vars (list-ref l 6)] (let* ([phase (list-ref l 0)]
[ps (for/list ([name (in-vector (list-ref l 5))] [has-info? (not (void? (list-ref l 1)))]
[src (in-vector (list-ref l 4))] [delta (if has-info? 5 1)]
[src-name (in-vector (list-ref l 3))] [num-vars (list-ref l (+ delta 6))]
[nom-src (or (list-ref l 2) [num-all (list-ref l (+ delta 7))]
(in-cycle (in-value #f)))] [ps (for/list ([name (in-vector (list-ref l (+ delta 5)))]
[src-phase (or (list-ref l 1) [src (in-vector (list-ref l (+ delta 4)))]
(in-cycle (in-value #f)))] [src-name (in-vector (list-ref l (+ delta 3)))]
[protected? (or (case (car l) [nom-src (or (list-ref l (+ delta 2))
[(0) protects] (in-cycle (in-value #f)))]
[(1) et-protects] [src-phase (or (list-ref l (+ delta 1))
[else #f]) (in-cycle (in-value 0)))]
(in-cycle (in-value #f)))]) [protected? (cond
(make-provided name src src-name [(or (not has-info?)
(or nom-src src) (not (list-ref l 5)))
(if src-phase 1 0) (in-cycle (in-value #f))]
protected?))]) [else (list-ref l 5)])])
(if (null? ps) (make-provided name src src-name
(loop (list-tail l 8)) (or nom-src src)
(cons src-phase
(list protected?))])
(car l) (list
(take ps num-vars) phase
(drop ps num-vars)) (take ps num-vars)
(loop (list-tail l 8))))))) (drop ps num-vars))))
;; requires:
(list* (list*
(cons 0 requires) (cons 0 requires)
(cons 1 syntax-requires) (cons 1 syntax-requires)
@ -276,20 +291,34 @@
(cons #f label-requires) (cons #f label-requires)
(for/list ([(phase reqs) (in-list* more-requires 2)]) (for/list ([(phase reqs) (in-list* more-requires 2)])
(cons phase reqs))) (cons phase reqs)))
(vector->list body) ;; body:
(map (lambda (sb) (vector->list (last bodies))
(match sb ;; syntax-bodies: add phase to each list, break apart
[(? def-syntaxes?) sb] (for/list ([b (cdr (reverse bodies))]
[(? def-for-syntax?) sb] [i (in-naturals 1)])
[`#(,ids ,expr ,max-let-depth ,prefix ,for-stx?) (cons i
((if for-stx? (for/list ([sb (in-vector b)])
make-def-for-syntax (match sb
make-def-syntaxes) [`#(,ids ,expr ,max-let-depth ,prefix ,for-stx?)
(if (list? ids) ids (list ids)) expr prefix max-let-depth)])) (if for-stx?
(vector->list syntax-body)) (make-seq-for-syntax (list expr) prefix max-let-depth #f)
(list (vector->list indirect-provides) (make-def-syntaxes
(vector->list indirect-syntax-provides) (if (list? ids) ids (list ids)) expr prefix max-let-depth #f))]
(vector->list indirect-et-provides)) [else (error 'zo-parse "bad phase ~a body element: ~e" i sb)]))))
;; unexported:
(for/list ([l (in-list phase-data)]
#:when (not (void? (list-ref l 1))))
(let* ([phase (list-ref l 0)]
[indirect-syntax
;; could check: (list-ref l 2) should be size of vector:
(list-ref l 1)]
[indirect
;; could check: (list-ref l 4) should be size of vector:
(list-ref l 3)])
(list
phase
(vector->list indirect)
(vector->list indirect-syntax))))
max-let-depth max-let-depth
dummy dummy
lang-info lang-info
@ -313,7 +342,7 @@
[(14) 'quote-syntax-type] [(14) 'quote-syntax-type]
[(15) 'define-values-type] [(15) 'define-values-type]
[(16) 'define-syntaxes-type] [(16) 'define-syntaxes-type]
[(17) 'define-for-syntax-type] [(17) 'begin-for-syntax-type]
[(18) 'set-bang-type] [(18) 'set-bang-type]
[(19) 'boxenv-type] [(19) 'boxenv-type]
[(20) 'begin0-sequence-type] [(20) 'begin0-sequence-type]
@ -350,7 +379,7 @@
(cons 'free-id-info-type read-free-id-info) (cons 'free-id-info-type read-free-id-info)
(cons 'define-values-type read-define-values) (cons 'define-values-type read-define-values)
(cons 'define-syntaxes-type read-define-syntax) (cons 'define-syntaxes-type read-define-syntax)
(cons 'define-for-syntax-type read-define-for-syntax) (cons 'begin-for-syntax-type read-begin-for-syntax)
(cons 'set-bang-type read-set!) (cons 'set-bang-type read-set!)
(cons 'boxenv-type read-boxenv) (cons 'boxenv-type read-boxenv)
(cons 'require-form-type read-require) (cons 'require-form-type read-require)

27
collects/compiler/zo-structs.rkt
View File

@ -80,7 +80,7 @@
[src (or/c module-path-index? #f)] [src (or/c module-path-index? #f)]
[src-name symbol?] [src-name symbol?]
[nom-src any/c] ; should be (or/c module-path-index? #f) [nom-src any/c] ; should be (or/c module-path-index? #f)
[src-phase (or/c 0 1)] [src-phase exact-nonnegative-integer?]
[protected? boolean?])) [protected? boolean?]))
(define-form-struct (toplevel expr) ([depth exact-nonnegative-integer?] (define-form-struct (toplevel expr) ([depth exact-nonnegative-integer?]
@ -89,18 +89,19 @@
[ready? boolean?])) ; access binding via prefix array (which is on stack) [ready? boolean?])) ; access binding via prefix array (which is on stack)
(define-form-struct (seq form) ([forms (listof (or/c form? any/c))])) ; `begin' (define-form-struct (seq form) ([forms (listof (or/c form? any/c))])) ; `begin'
(define-form-struct (seq-for-syntax form) ([forms (listof (or/c form? any/c))] ; `begin-for-syntax'
[prefix prefix?]
[max-let-depth exact-nonnegative-integer?]
[dummy (or/c toplevel? #f)]))
;; Definitions (top level or within module): ;; Definitions (top level or within module):
(define-form-struct (def-values form) ([ids (listof (or/c toplevel? symbol?))] ; added symbol? (define-form-struct (def-values form) ([ids (listof (or/c toplevel? symbol?))]
[rhs (or/c expr? seq? any/c)])) [rhs (or/c expr? seq? any/c)]))
(define-form-struct (def-syntaxes form) ([ids (listof (or/c toplevel? symbol?))] ; added symbol? (define-form-struct (def-syntaxes form) ([ids (listof (or/c toplevel? symbol?))]
[rhs (or/c expr? seq? any/c)] [rhs (or/c expr? seq? any/c)]
[prefix prefix?] [prefix prefix?]
[max-let-depth exact-nonnegative-integer?])) [max-let-depth exact-nonnegative-integer?]
(define-form-struct (def-for-syntax form) ([ids (listof (or/c toplevel? symbol?))] ; added symbol? [dummy (or/c toplevel? #f)]))
[rhs (or/c expr? seq? any/c)]
[prefix prefix?]
[max-let-depth exact-nonnegative-integer?]))
(define-form-struct (mod form) ([name symbol?] (define-form-struct (mod form) ([name symbol?]
[srcname symbol?] [srcname symbol?]
@ -111,10 +112,12 @@
(listof provided?)))] (listof provided?)))]
[requires (listof (cons/c (or/c exact-integer? #f) [requires (listof (cons/c (or/c exact-integer? #f)
(listof module-path-index?)))] (listof module-path-index?)))]
[body (listof (or/c form? any/c))] [body (listof (or/c form? any/c))]
[syntax-body (listof (or/c def-syntaxes? def-for-syntax?))] [syntax-bodies (listof (cons/c exact-positive-integer?
[unexported (list/c (listof symbol?) (listof symbol?) (listof (or/c def-syntaxes? seq-for-syntax?))))]
(listof symbol?))] [unexported (listof (list/c exact-nonnegative-integer?
(listof symbol?)
(listof symbol?)))]
[max-let-depth exact-nonnegative-integer?] [max-let-depth exact-nonnegative-integer?]
[dummy toplevel?] [dummy toplevel?]
[lang-info (or/c #f (vector/c module-path? symbol? any/c))] [lang-info (or/c #f (vector/c module-path? symbol? any/c))]

40
collects/tests/compiler/zo.rkt Normal file
View File

@ -0,0 +1,40 @@
#lang racket/base
(require racket/pretty
compiler/zo-parse
compiler/zo-marshal
compiler/decompile)
(define ex-mod1
'(module m racket
(begin-for-syntax
(define fs 10)
(list fs))
(define-syntax (m stx)
#'10)
(m)
(begin-for-syntax
(list fs))))
(define ex-mod2
'(module m racket
(define t 8)
(define s 10)
(provide t (protect-out s))))
(define (check ex-mod)
(let ([c (parameterize ([current-namespace (make-base-namespace)])
(compile ex-mod))])
(let ([o (open-output-bytes)])
(write c o)
(let ([p (zo-parse (open-input-bytes (get-output-bytes o)))])
(let ([b (zo-marshal p)])
(let ([p2 (zo-parse (open-input-bytes b))]
[to-string (lambda (p)
(let ([o (open-output-bytes)])
(print p o)
(get-output-string o)))])
(unless (equal? (to-string p) (to-string p2))
(error 'zo "failed on example: ~e" ex-mod))))))))
(check ex-mod1)
(check ex-mod2)