all expression forms tested for zo-marshal
svn: r13998
This commit is contained in:
Matthew Flatt
parent
cdfb6e5f67
commit
282a404ada
|
|
@ -129,14 +129,14 @@
|
|||
[(struct primval (id))
|
||||
(void)]
|
||||
[(struct assign (id rhs undef-ok?))
|
||||
(traverse-expr rhs)]
|
||||
(traverse-expr rhs visit)]
|
||||
[(struct localref (unbox? offset clear? other-clears?))
|
||||
(void)]
|
||||
[(? lam?)
|
||||
(traverse-lam expr visit)]
|
||||
[(struct case-lam (name lams))
|
||||
(traverse-data name visit)
|
||||
(for-each (lambda (lam) (traverse-lam expr visit)) lams)]
|
||||
(for-each (lambda (lam) (traverse-lam lam visit)) lams)]
|
||||
[(struct let-one (rhs body))
|
||||
(traverse-expr rhs visit)
|
||||
(traverse-expr body visit)]
|
||||
|
|
@ -212,6 +212,7 @@
|
|||
(define variable-type-num 24)
|
||||
(define top-type-num 87)
|
||||
(define case-lambda-sequence-type-num 96)
|
||||
(define begin0-sequence-type-num 97)
|
||||
(define prefix-type-num 103)
|
||||
|
||||
(define-syntax define-enum
|
||||
|
|
@ -300,6 +301,7 @@
|
|||
#f))
|
||||
|
||||
(define-struct case-seq (name lams))
|
||||
(define-struct (seq0 seq) ())
|
||||
|
||||
(define-struct out (s shared-index))
|
||||
|
||||
|
|
@ -414,6 +416,8 @@
|
|||
*dummy*
|
||||
ids))
|
||||
out)]
|
||||
[(struct seq0 (forms))
|
||||
(out-marshaled begin0-sequence-type-num (map protect-quote forms) out)]
|
||||
[(struct seq (forms))
|
||||
(out-marshaled sequence-type-num (map protect-quote forms) out)]
|
||||
[(struct splice (forms))
|
||||
|
|
@ -425,12 +429,14 @@
|
|||
(match expr
|
||||
[(struct toplevel (depth pos const? ready?))
|
||||
(out-marshaled toplevel-type-num
|
||||
(if (or const? ready?)
|
||||
(cons pos
|
||||
(bitwise-ior
|
||||
(if const? #x1 0)
|
||||
(if ready? #x2 0)))
|
||||
pos)
|
||||
(cons
|
||||
depth
|
||||
(if (or const? ready?)
|
||||
(cons pos
|
||||
(bitwise-ior
|
||||
(if const? #x1 0)
|
||||
(if ready? #x2 0)))
|
||||
pos))
|
||||
out)]
|
||||
[(struct topsyntax (depth pos midpt))
|
||||
(out-marshaled quote-syntax-type-num
|
||||
|
|
@ -464,8 +470,17 @@
|
|||
[(? lam?)
|
||||
(out-lam expr out)]
|
||||
[(struct case-lam (name lams))
|
||||
(out-syntax CASE_LAMBDA_EXPD
|
||||
(make-case-seq name lams))]
|
||||
(let ([seq (make-case-seq name lams)])
|
||||
;; If all closures are empy, generate a case sequence directly
|
||||
(if (andmap (lambda (lam)
|
||||
(or (closure? lam)
|
||||
(and (lam? lam)
|
||||
(equal? (lam-closure-map lam) #()))))
|
||||
lams)
|
||||
(out-data seq out)
|
||||
(out-syntax CASE_LAMBDA_EXPD
|
||||
seq
|
||||
out)))]
|
||||
[(struct case-seq (name lams))
|
||||
(out-marshaled case-lambda-sequence-type-num
|
||||
(cons (or name null)
|
||||
|
|
@ -526,7 +541,7 @@
|
|||
(out-form expr out)]
|
||||
[(struct beg0 (exprs))
|
||||
(out-syntax BEGIN0_EXPD
|
||||
(make-seq exprs)
|
||||
(make-seq0 exprs)
|
||||
out)]
|
||||
[(struct with-cont-mark (key val body))
|
||||
(out-marshaled wcm-type-num
|
||||
|
|
@ -539,6 +554,10 @@
|
|||
(out-lam expr out)]
|
||||
[(struct indirect (val))
|
||||
(out-expr val out)]
|
||||
[(struct varref (expr))
|
||||
(out-syntax REF_EXPD
|
||||
expr
|
||||
out)]
|
||||
[else (out-value expr out)]))
|
||||
|
||||
(define (out-lam expr out)
|
||||
|
|
@ -549,7 +568,9 @@
|
|||
expr
|
||||
out
|
||||
(lambda ()
|
||||
(out-lam expr out)))]
|
||||
(out-byte CPT_CLOSURE out)
|
||||
(out-number ((out-shared-index out) expr) out)
|
||||
(out-lam lam out)))]
|
||||
[(struct lam (name flags num-params param-types rest? closure-map max-let-depth body))
|
||||
(let* ([l (protect-quote body)]
|
||||
[any-refs? (ormap (lambda (t) (eq? t 'ref)) param-types)]
|
||||
|
|
@ -594,6 +615,8 @@
|
|||
(define (out-data expr out)
|
||||
(cond
|
||||
[(prefix? expr) (out-prefix expr out)]
|
||||
[(global-bucket? expr) (out-toplevel expr out)]
|
||||
[(module-variable? expr) (out-toplevel expr out)]
|
||||
[else (out-form expr out)]))
|
||||
|
||||
(define (out-value expr out)
|
||||
|
|
@ -666,6 +689,11 @@
|
|||
(let ([vec (svector-vec expr)])
|
||||
(for ([n (in-range (sub1 (vector-length vec)) -1 -1)])
|
||||
(out-number (vector-ref vec n) out)))]
|
||||
[(module-path-index? expr)
|
||||
(out-byte CPT_MODULE_INDEX out)
|
||||
(let-values ([(name base) (module-path-index-split expr)])
|
||||
(out-data name out)
|
||||
(out-data base out))]
|
||||
[else
|
||||
(out-byte CPT_QUOTE out)
|
||||
(let ([s (open-output-bytes)])
|
||||
|
|
|
|||
|
|
@ -214,7 +214,7 @@
|
|||
(define (read-apply-values v)
|
||||
(make-apply-values (car v) (cdr v)))
|
||||
(define (read-splice v)
|
||||
(make-splice v))
|
||||
(make-splice (seq-forms v)))
|
||||
|
||||
(define (read-module v)
|
||||
(match v
|
||||
|
|
|
|||
|
|
@ -6,9 +6,46 @@
|
|||
(require compiler/zo-parse
|
||||
compiler/zo-marshal)
|
||||
|
||||
(define-struct mpi (n b) #:transparent)
|
||||
|
||||
;; Exposes content of module-path indices, strip away
|
||||
;; closure ids, and normalize `indirects' so we can compare them
|
||||
;; with `equal?':
|
||||
(define mpx
|
||||
(case-lambda
|
||||
[(v) (let ([it (make-hash)])
|
||||
(let loop ([v v])
|
||||
(cond
|
||||
[(pair? v) (cons (loop (car v)) (loop (cdr v)))]
|
||||
[(indirect? v)
|
||||
(or (hash-ref it v #f)
|
||||
(let ([i (make-indirect #f)])
|
||||
(hash-set! it v i)
|
||||
(set-indirect-v! i
|
||||
(make-closure
|
||||
(loop (closure-code (indirect-v v)))
|
||||
'closure))
|
||||
i))]
|
||||
[(closure? v) (make-indirect
|
||||
(make-closure (loop (closure-code v)) 'closure))]
|
||||
[(struct? v) (let-values ([(st ?) (struct-info v)])
|
||||
(if st
|
||||
(let ([c (struct-type-make-constructor st)])
|
||||
(apply c
|
||||
(map loop
|
||||
(cdr
|
||||
(vector->list
|
||||
(struct->vector v))))))
|
||||
v))]
|
||||
[(module-path-index? v)
|
||||
(let-values ([(name base) (module-path-index-split v)])
|
||||
(make-mpi name base))]
|
||||
[else v])))]
|
||||
[(f v) (mpx (f v))]))
|
||||
|
||||
(define (check expr val #:wrap [wrap values])
|
||||
(let ([s (zo-marshal expr)])
|
||||
(test expr zo-parse (open-input-bytes s))
|
||||
(test (mpx expr) mpx zo-parse (open-input-bytes s))
|
||||
(test val wrap (eval (parameterize ([read-accept-compiled #t])
|
||||
(read (open-input-bytes s)))))))
|
||||
|
||||
|
|
@ -23,6 +60,12 @@
|
|||
(define list-id (get-id #'list))
|
||||
(define object-name-id (get-id #'object-name))
|
||||
|
||||
(define GLOBALV 78)
|
||||
(module zo-m scheme/base
|
||||
(provide x)
|
||||
(define x 88))
|
||||
(require 'zo-m)
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define (make-simple e)
|
||||
|
|
@ -31,6 +74,17 @@
|
|||
(make-prefix 0 null null)
|
||||
e))
|
||||
|
||||
(define (make-global e)
|
||||
(make-compilation-top
|
||||
10
|
||||
(make-prefix 0 (list (make-global-bucket 'GLOBALV)
|
||||
(make-module-variable (module-path-index-join ''zo-m #f)
|
||||
'x
|
||||
-1
|
||||
0))
|
||||
null)
|
||||
e))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(check (make-simple 5)
|
||||
|
|
@ -181,4 +235,173 @@
|
|||
|
||||
;; ----------------------------------------
|
||||
|
||||
(check (make-global
|
||||
(make-toplevel 0 0 #f #f))
|
||||
78)
|
||||
(check (make-global
|
||||
(make-toplevel 0 1 #f #f))
|
||||
88)
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(check (make-simple
|
||||
(make-seq (list 1 56)))
|
||||
56)
|
||||
(check (make-simple
|
||||
(make-splice (list 1 57)))
|
||||
57)
|
||||
(check (make-global
|
||||
(make-splice (list (make-toplevel 0 0 #f #f) 57)))
|
||||
57)
|
||||
(check (make-simple
|
||||
(make-beg0 (list 1 56)))
|
||||
1)
|
||||
(check (make-global
|
||||
(make-beg0 (list 57 (make-toplevel 0 0 #f #f))))
|
||||
57)
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(check (make-simple
|
||||
(make-closure
|
||||
(make-lam 'proc
|
||||
null
|
||||
1
|
||||
'(val)
|
||||
#f
|
||||
#()
|
||||
10
|
||||
(make-localref #f 0 #f #f))
|
||||
'proc))
|
||||
8
|
||||
#:wrap (lambda (f) (f 8)))
|
||||
|
||||
(define rec-proc
|
||||
(let ([self (make-indirect #f)])
|
||||
(set-indirect-v! self
|
||||
(make-closure
|
||||
(make-lam 'proc
|
||||
null
|
||||
1
|
||||
'(val)
|
||||
#f
|
||||
#()
|
||||
10
|
||||
(make-branch
|
||||
(make-localref #f 0 #f #f)
|
||||
self
|
||||
17))
|
||||
'proc))
|
||||
self))
|
||||
|
||||
(check (make-simple
|
||||
rec-proc)
|
||||
17
|
||||
#:wrap (lambda (f) (f #f)))
|
||||
(check (make-simple
|
||||
rec-proc)
|
||||
'proc
|
||||
#:wrap (lambda (f) (object-name (f #t))))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define cl-proc
|
||||
(make-case-lam
|
||||
'cl-proc
|
||||
(list
|
||||
(make-lam 'proc
|
||||
null
|
||||
1
|
||||
'(val)
|
||||
#f
|
||||
#()
|
||||
10
|
||||
(make-localref #f 0 #f #f))
|
||||
(make-lam 'proc
|
||||
null
|
||||
2
|
||||
'(val val)
|
||||
#f
|
||||
#()
|
||||
10
|
||||
(make-application
|
||||
(make-primval list-id)
|
||||
(list
|
||||
(make-localref #f 2 #f #f)
|
||||
(make-localref #f 3 #f #f)))))))
|
||||
|
||||
(check (make-simple cl-proc)
|
||||
#:wrap (lambda (f) (f 3))
|
||||
3)
|
||||
(check (make-simple cl-proc)
|
||||
#:wrap (lambda (f) (f 1 2))
|
||||
'(1 2))
|
||||
(check (make-simple cl-proc)
|
||||
#:wrap object-name
|
||||
'cl-proc)
|
||||
|
||||
(define cl-proc2
|
||||
(make-let-one
|
||||
'cl1
|
||||
(make-let-one
|
||||
'cl2
|
||||
(make-case-lam
|
||||
'cl-proc
|
||||
(list
|
||||
(make-lam 'proc
|
||||
null
|
||||
0
|
||||
'()
|
||||
#f
|
||||
#(0)
|
||||
10
|
||||
(make-localref #f 0 #f #f))
|
||||
(make-lam 'proc
|
||||
null
|
||||
1
|
||||
'(val)
|
||||
#f
|
||||
#(1)
|
||||
10
|
||||
(make-application
|
||||
(make-primval list-id)
|
||||
(list
|
||||
(make-localref #f 2 #f #f)
|
||||
(make-localref #f 3 #f #f)))))))))
|
||||
(check (make-simple cl-proc2)
|
||||
#:wrap (lambda (f) (f))
|
||||
'cl2)
|
||||
(check (make-simple cl-proc2)
|
||||
#:wrap (lambda (f) (f 2))
|
||||
'(cl1 2))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(check (make-global
|
||||
(make-varref (make-toplevel 0 0 #f #f)))
|
||||
#:wrap variable-reference?
|
||||
#t)
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(check (make-global
|
||||
(make-assign (make-toplevel 0 0 #f #f)
|
||||
99
|
||||
#f))
|
||||
(void))
|
||||
(test 99 values GLOBALV)
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(check (make-global
|
||||
(make-apply-values
|
||||
(make-primval list-id)
|
||||
(make-application
|
||||
(make-primval values-id)
|
||||
(list 503
|
||||
507))))
|
||||
'(503 507))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(report-errs)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user