408 lines
11 KiB
Scheme
408 lines
11 KiB
Scheme
|
|
(load-relative "loadtest.ss")
|
|
|
|
(Section 'zo-marshal)
|
|
|
|
(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 (mpx expr) mpx zo-parse (open-input-bytes s))
|
|
(test val wrap (eval (parameterize ([read-accept-compiled #t])
|
|
(read (open-input-bytes s)))))))
|
|
|
|
(define (get-id id)
|
|
(primval-id
|
|
(compilation-top-code
|
|
(zo-parse (let ([s (open-output-bytes)])
|
|
(write (compile id) s)
|
|
(open-input-bytes (get-output-bytes s)))))))
|
|
|
|
(define values-id (get-id #'values))
|
|
(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)
|
|
(make-compilation-top
|
|
10
|
|
(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)
|
|
5)
|
|
|
|
(let ([ck (lambda (cl? o-cls?)
|
|
(check (make-simple (make-let-one
|
|
51
|
|
(make-localref #f 0 cl? o-cls?)))
|
|
51))])
|
|
(ck #f #f)
|
|
(ck #t #f)
|
|
(ck #f #t))
|
|
|
|
|
|
(check (make-simple (make-let-one
|
|
15
|
|
(make-boxenv
|
|
0
|
|
(make-localref #t 0 #f #f))))
|
|
15)
|
|
|
|
(check (make-simple (make-let-void
|
|
3
|
|
#f
|
|
(make-install-value
|
|
1
|
|
0
|
|
#f
|
|
503
|
|
(make-boxenv
|
|
0
|
|
(make-localref #t 0 #f #f)))))
|
|
503)
|
|
|
|
(check (make-simple (make-let-void
|
|
3
|
|
#f
|
|
(make-install-value
|
|
2
|
|
1
|
|
#f
|
|
(make-application
|
|
(make-primval values-id)
|
|
(list 503
|
|
507))
|
|
(make-localref #f 2 #f #f))))
|
|
507)
|
|
|
|
(check (make-simple (make-branch
|
|
#t
|
|
50
|
|
-50))
|
|
50)
|
|
|
|
(check (make-simple (make-branch
|
|
#f
|
|
50
|
|
-50))
|
|
-50)
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define (make-ab body)
|
|
(make-simple (make-let-void
|
|
2
|
|
#f
|
|
(make-let-rec
|
|
(list
|
|
(make-lam 'a
|
|
null
|
|
1
|
|
'(val)
|
|
#f
|
|
#(1)
|
|
10
|
|
(make-branch
|
|
(make-localref #f 1 #f #f)
|
|
(make-localref #f 0 #f #f)
|
|
59))
|
|
(make-lam 'b
|
|
null
|
|
1
|
|
'(val)
|
|
#f
|
|
#(0)
|
|
10
|
|
(make-localref #f 0 #f #f)))
|
|
body))))
|
|
|
|
(check (make-ab 517)
|
|
517)
|
|
|
|
(check (make-ab (make-application
|
|
(make-primval object-name-id)
|
|
(list (make-localref #f 1 #f #f))))
|
|
'a)
|
|
(check (make-ab (make-application
|
|
(make-primval object-name-id)
|
|
(list (make-localref #f 2 #f #f))))
|
|
'b)
|
|
|
|
(check (make-ab (make-application
|
|
(make-localref #f 1 #f #f)
|
|
(list #f)))
|
|
59)
|
|
(check (make-ab (make-application
|
|
(make-primval object-name-id)
|
|
(list
|
|
(make-application
|
|
(make-localref #f 2 #f #f)
|
|
(list #t)))))
|
|
'b)
|
|
(check (make-ab (make-application
|
|
(make-primval object-name-id)
|
|
(list
|
|
(make-application
|
|
(make-application
|
|
(make-localref #f 3 #f #f)
|
|
(list #t))
|
|
(list -5)))))
|
|
'a)
|
|
|
|
;; ----------------------------------------
|
|
|
|
(check (make-simple
|
|
(make-let-one
|
|
'v1
|
|
(make-let-one
|
|
'v0
|
|
(make-let-one
|
|
(make-lam 'proc
|
|
null
|
|
1
|
|
'(val)
|
|
#f
|
|
#(1 2)
|
|
20
|
|
(make-application
|
|
(make-primval list-id)
|
|
(list
|
|
(make-localref #f 2 #f #f)
|
|
(make-localref #f 3 #f #f))))
|
|
(make-application
|
|
(make-localref #f 1 #f #f)
|
|
(list 5))))))
|
|
'(v0 v1))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(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)
|