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

zo-marshal bug fixes and start at test suite

Browse Source 
svn: r13979
This commit is contained in:
Matthew Flatt 2009-03-06 15:22:33 +00:00
parent 135d51e0f0
commit f1e646c8f9
2 changed files with 162 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/compiler/zo-marshal.ss
View File

@ -578,7 +578,7 @@
(if (memq 'preserves-marks flags) CLOS_PRESERVES_MARKS 0) (if (memq 'preserves-marks flags) CLOS_PRESERVES_MARKS 0)
(if (memq 'is-method flags) CLOS_IS_METHOD 0) (if (memq 'is-method flags) CLOS_IS_METHOD 0)
(if (memq 'single-result flags) CLOS_SINGLE_RESULT 0)) (if (memq 'single-result flags) CLOS_SINGLE_RESULT 0))
((if rest? add1 0) num-params) ((if rest? add1 values) num-params)
max-let-depth max-let-depth
name name
l) l)

161
collects/tests/mzscheme/zo-marshal.ss Normal file
View File

@ -0,0 +1,161 @@
(load-relative "loadtest.ss")
(Section 'zo-marshal)
(require compiler/zo-parse
compiler/zo-marshal)
(define (check expr val #:wrap [wrap values])
(let ([s (zo-marshal expr)])
(test expr 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 object-name-id (get-id #'object-name))
;; ----------------------------------------
(define (make-simple e)
(make-compilation-top
10
(make-prefix 0 null 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)
;; ----------------------------------------
;; ----------------------------------------
(report-errs)