This repository has been archived on 2022-08-10. You can view files and clone it, but cannot push or open issues or pull requests.
chez-openbsd/mats/7.ms
2022-07-29 15:12:07 +02:00

6245 lines
218 KiB
Scheme

;;; 7.ms
;;; Copyright 1984-2017 Cisco Systems, Inc.
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;; http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.
;;; section 7-1:
(mat load/compile-file
(error? (load "/file/not/there"))
(error? (compile-file "/file/not/there"))
(error? ; abc is not a string
(load-program 'abc))
(error? ; xxx is not a procedure
(load-program "/file/not/there" 'xxx))
(error? ; 3 is not a string
(parameterize ([source-directories '("/tmp" ".")]) (load-program 3)))
(error? ; 3 is not a string
(parameterize ([source-directories '("/tmp" ".")]) (load-program 3 values)))
(not (top-level-bound? 'aaaaa))
(let ([p (open-output-file "testfile.ss" 'replace)])
(display "(let ((x 3) (y 4)) (set! aaaaa (+ x y)))" p)
(close-output-port p)
(load "testfile.ss")
(eqv? aaaaa 7))
(call/cc
(lambda (k)
(load "testfile.ss"
(lambda (x)
(unless (equal? (annotation-stripped x)
'(let ((x 3) (y 4))
(set! aaaaa (+ x y))))
(k #f))))
#t))
(begin
(printf "***** expect \"compile-file\" message:~%")
(compile-file "testfile")
(set! aaaaa 0)
(load "testfile.so")
(eqv? aaaaa 7))
(parameterize ([fasl-compressed #f])
(printf "***** expect \"compile-file\" message:~%")
(compile-file "testfile")
(set! aaaaa 0)
(load "testfile.so")
(eqv? aaaaa 7))
(let ((ip (open-input-string "(let ((x -3) (y -4)) (set! aaaaa (+ x y)))"))
(op (open-file-output-port "testfile.so" (file-options replace))))
(compile-port ip op)
(close-input-port ip)
(close-port op)
(set! aaaaa 0)
(load "testfile.so")
(eqv? aaaaa -7))
(let ((ip (open-input-string "(let ((x -3) (y -4)) (set! aaaaa (+ x y)))"))
(op (open-file-output-port "testfile.so" (file-options replace #;compressed))))
(compile-port ip op)
(close-input-port ip)
(close-port op)
(set! aaaaa 0)
(load "testfile.so")
(eqv? aaaaa -7))
; test compiling a file containing most-negative-fixnum
(let ([p (open-output-file "testfile.ss" 'replace)])
(printf "***** expect \"compile-file\" message:~%")
(display `(define $mnfixnum ,(most-negative-fixnum)) p)
(close-output-port p)
(compile-file "testfile")
(load "testfile.so")
(eqv? $mnfixnum (most-negative-fixnum)))
)
(mat compile-to-port
(eqv?
(call-with-port (open-file-output-port "testfile.so" (file-options replace))
(lambda (op)
(compile-to-port '((define ctp1 'hello) (set! ctp1 (cons 'goodbye ctp1))) op)))
(void))
(begin
(load "testfile.so")
#t)
(equal? ctp1 '(goodbye . hello))
(begin
(with-output-to-file "testfile-ctp2a.ss"
(lambda ()
(pretty-print
'(library (testfile-ctp2a) (export fact) (import (chezscheme))
(define fact (lambda (x) (if (= x 0) 1 (* x (fact (- x 1)))))))))
'replace)
#t)
(equal?
(call-with-port (open-file-output-port "testfile.so" (file-options replace #;compressed))
(lambda (op)
(parameterize ([compile-imported-libraries #t])
(compile-to-port
'((top-level-program
(import (chezscheme) (testfile-ctp2a))
(pretty-print (fact 3))))
op))))
'((testfile-ctp2a)))
(equal?
(with-output-to-string (lambda () (load "testfile.so")))
"6\n")
)
(mat load-compiled-from-port
(begin
(define-values (o get) (open-bytevector-output-port))
(compile-to-port '((define lcfp1 'worked) 'loaded) o)
(eq? 'loaded (load-compiled-from-port (open-bytevector-input-port (get)))))
(begin
(define lcfp-bv
(let-values ([(o get) (open-bytevector-output-port)])
(compile-to-port
'((printf "revisit\n")
(define-syntax $lcfp-a (begin (printf "visit\n") (lambda (x) 0)))
(eval-when (visit revisit) (printf "visit-revisit\n"))
(eval-when (visit) 'visit-return)
'revisit-return)
o)
(get)))
#t)
(equal?
(with-output-to-string (lambda () (printf "result = ~s\n" (load-compiled-from-port (open-bytevector-input-port lcfp-bv)))))
"revisit\nvisit\nvisit-revisit\nresult = revisit-return\n")
(equal?
(with-output-to-string (lambda () (printf "result = ~s\n" (visit-compiled-from-port (open-bytevector-input-port lcfp-bv)))))
"visit\nvisit-revisit\nresult = visit-return\n")
(equal?
(with-output-to-string (lambda () (printf "result = ~s\n" (revisit-compiled-from-port (open-bytevector-input-port lcfp-bv)))))
"revisit\nvisit-revisit\nresult = revisit-return\n")
)
(mat compile-to-file
(begin
(delete-file (format "testfile.~s" (machine-type)))
(compile-to-file '((define ctf1 'hello) (set! ctf1 (cons ctf1 'goodbye))) "testfile.so")
#t)
(begin
(load "testfile.so")
#t)
;; NB: should we protect the following in case we are actually cross compiling?
(not (file-exists? (format "testfile.~s" (machine-type))))
(equal? ctf1 '(hello . goodbye))
(begin
(with-output-to-file "testfile-ctf2a.ss"
(lambda ()
(pretty-print
'(library (testfile-ctf2a) (export fib) (import (chezscheme))
(define fib (lambda (x) (if (< x 2) x (+ (fib (- x 1)) (fib (- x 2)))))))))
'replace)
#t)
(equal?
(parameterize ([compile-imported-libraries #t])
(compile-to-file
'((top-level-program
(import (chezscheme) (testfile-ctf2a))
(pretty-print (fib 11))))
"testfile.so"))
'((testfile-ctf2a)))
(not (file-exists? (format "testfile-ctf2a.~s" (machine-type))))
(not (file-exists? (format "testfile.~s" (machine-type))))
(equal?
(with-output-to-string (lambda () (load "testfile.so")))
"89\n")
(begin
(compile-to-file
'((library (testfile-ctf2a) (export fib) (import (chezscheme))
(define fib (lambda (x) (if (< x 2) x (+ (fib (- x 1)) (fib (- x 2))))))))
"testfile.so")
#t)
(not (file-exists? (format "testfile.~s" (machine-type))))
)
(mat compile-script
(error? (compile-script "/file/not/there"))
(begin
(with-output-to-file "testfile.ss"
(lambda ()
(display "#! /usr/bin/scheme --script\n")
(pretty-print '(define $cs-x 14))
(pretty-print '(define $cs-y (lambda (q) (+ $cs-x q)))))
'replace)
(compile-script "testfile")
#t)
(error? $cs-x)
(error? $cs-y)
(begin
(load "testfile.so")
#t)
(eqv? $cs-x 14)
(eqv? ($cs-y -17) -3)
(eqv? (with-input-from-file "testfile.so" read-char) #\#)
; test visit/revisit of compiled script
(begin
(with-output-to-file "testfile.ss"
(lambda ()
(printf "#! /usr/bin/scheme --script\n")
(pretty-print '(eval-when (visit) (display "hello from testfile\n")))
(pretty-print '(display "hello again from testfile\n")))
'replace)
(compile-script "testfile")
#t)
(equal?
(with-output-to-string
(lambda () (visit "testfile.so")))
"hello from testfile\n")
(equal?
(with-output-to-string
(lambda () (revisit "testfile.so")))
"hello again from testfile\n")
(equal?
(with-output-to-string
(lambda () (load "testfile.so")))
"hello from testfile\nhello again from testfile\n")
)
(mat load-program/compile-program
(error? (compile-program "/file/not/there"))
(error? (load-program "/file/not/there"))
(error? ; abc is not a string
(load-program 'abc))
(error? ; xxx is not a procedure
(load-program "/file/not/there" 'xxx))
(error? ; 3 is not a string
(parameterize ([source-directories '("/tmp" ".")]) (load-program 3)))
(error? ; 3 is not a string
(parameterize ([source-directories '("/tmp" ".")]) (load-program 3 values)))
(begin
(with-output-to-file "testfile.ss"
(lambda ()
(display "#! /usr/bin/scheme --program\n")
(pretty-print '(import (rnrs)))
(pretty-print '(define $cp-x 14))
(pretty-print '(define $cp-y (lambda (q) (+ $cp-x q))))
(pretty-print '(begin
(when (file-exists? "testfile-cp.ss")
(delete-file "testfile-cp.ss"))
(with-output-to-file "testfile-cp.ss"
(lambda () (write (cons $cp-x ($cp-y 35))))))))
'replace)
(compile-program "testfile")
#t)
(begin
(load-program "testfile.so")
#t)
(error? $cp-x)
(error? $cp-y)
(let ([p (with-input-from-file "testfile-cp.ss" read)])
(eqv? (car p) 14)
(eqv? (cdr p) 49))
(eqv? (with-input-from-file "testfile.so" read-char) #\#)
(begin
(with-output-to-file "testfile.ss"
(lambda ()
(display "#! /usr/bin/scheme --program\n")
(pretty-print '(import (rnrs)))
(pretty-print '(begin
(when (file-exists? "testfile-cp.ss")
(delete-file "testfile-cp.ss"))
(with-output-to-file "testfile-cp.ss"
(lambda () (write "hello from testfile"))))))
'replace)
#t)
(begin
(load-program "testfile.ss")
#t)
(equal? (with-input-from-file "testfile-cp.ss" read) "hello from testfile")
(begin
(with-output-to-file "testfile.ss"
(lambda ()
(display "#! /usr/bin/scheme --program\n")
(pretty-print '(import (rnrs)))
(pretty-print '(pretty-print 'hello)))
'replace)
#t)
(error? ; unbound variable pretty-print
(compile-program "testfile"))
(error? ; unbound variable pretty-print
(load-program "testfile.ss"))
(begin
(with-output-to-file "testfile.ss"
(lambda ()
(display "#! /usr/bin/scheme --program\n")
(pretty-print '(import (rnrs)))
(pretty-print '(#%write 'hello)))
'replace)
#t)
(error? ; invalid #% syntax in #!r6rs mode
(compile-program "testfile"))
(error? ; invalid #% syntax in #!r6rs mode
(load-program "testfile.ss"))
)
(mat maybe-compile
(error? ; not a procedure
(compile-program-handler 'ignore))
(procedure? (compile-program-handler))
(error? ; not a string
(maybe-compile-file '(spam)))
(error? ; not a string
(maybe-compile-file "spam" 'spam))
(error? ; not a string
(maybe-compile-file -2.5 "spam"))
(error? ; .ss file does not exist
(maybe-compile-file "probably-does-not-exist.ss"))
(error? ; .ss file does not exist
(maybe-compile-file "probably-does-not-exist.ss" "probably-does-not-exist.so"))
(begin
(with-output-to-file "testfile-mc.ss"
(lambda ()
(for-each pretty-print
'((import (chezscheme))
(pretty-print 'hello))))
'replace)
#t)
(error? ; cannot create .so file
(maybe-compile-file "testfile-mc.ss" "/probably/does/not/exist.so"))
(error? ; not a string
(maybe-compile-program '(spam)))
(error? ; not a string
(maybe-compile-program "spam" 'spam))
(error? ; not a string
(maybe-compile-program -2.5 "spam"))
(error? ; .ss file does not exist
(maybe-compile-program "probably-does-not-exist.ss"))
(error? ; .ss file does not exist
(maybe-compile-program "probably-does-not-exist.ss" "probably-does-not-exist.so"))
(begin
(with-output-to-file "testfile-mc.ss"
(lambda ()
(for-each pretty-print
'((import (chezscheme))
(pretty-print 'hello))))
'replace)
#t)
(error? ; cannot create .so file
(maybe-compile-program "testfile-mc.ss" "/probably/does/not/exist.so"))
(error? ; not a string
(maybe-compile-library '(spam)))
(error? ; not a string
(maybe-compile-library "spam" 'spam))
(error? ; not a string
(maybe-compile-library -2.5 "spam"))
(error? ; .ss file does not exist
(maybe-compile-library "probably-does-not-exist.ss"))
(error? ; .ss file does not exist
(maybe-compile-library "probably-does-not-exist.ss" "probably-does-not-exist.so"))
(begin
(with-output-to-file "testfile-mc.ss"
(lambda ()
(pretty-print
'(library (testfile-mc) (export) (import))))
'replace)
#t)
(error? ; cannot create .so file
(maybe-compile-library "testfile-mc.ss" "/probably/does/not/exist.so"))
(begin
(with-output-to-file "testfile-mc.ss"
(lambda ()
(for-each pretty-print
'((import (chezscheme))
(if))))
'replace)
#t)
(error? ; syntax error
(maybe-compile-file "testfile-mc.ss" "testfile-mc.so"))
(not (file-exists? "testfile-mc.so"))
(error? ; syntax error
(maybe-compile-program "testfile-mc.ss" "testfile-mc.so"))
(not (file-exists? "testfile-mc.so"))
(begin
(with-output-to-file "testfile-mc.ss"
(lambda ()
(pretty-print
'(library (testfile-mc) (export x) (import (chezscheme)) (define))))
'replace)
#t)
(error? ; syntax error
(maybe-compile-library "testfile-mc.ss" "testfile-mc.so"))
(not (file-exists? "testfile-mc.so"))
(begin
(for-each delete-file '("testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))
(with-output-to-file "testfile-mc-a.ss"
(lambda ()
(pretty-print
'(library (testfile-mc-a) (export a) (import (chezscheme)) (define a "a"))))
'replace)
(with-output-to-file "testfile-mc-b.ss"
(lambda ()
(pretty-print
'(library (testfile-mc-b) (export a b) (import (chezscheme) (testfile-mc-a)) (define b "b"))))
'replace)
(with-output-to-file "testfile-mc-c.ss"
(lambda ()
(pretty-print
'(define c "c")))
'replace)
(with-output-to-file "testfile-mc-foo.ss"
(lambda ()
(for-each pretty-print
'((import (chezscheme) (testfile-mc-b))
(include "testfile-mc-c.ss")
(pretty-print (list a b c)))))
'replace)
(separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #t]) (maybe-compile-program x))) 'mc-foo)
#t)
(equal?
(separate-eval '(load-program "testfile-mc-foo.so"))
"(\"a\" \"b\" \"c\")\n")
(equal?
(let ([mt* (map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))])
(separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #t]) (maybe-compile-program x))) 'mc-foo)
(map
(lambda (x y) (if (time=? x y) '= (if (time<? x y) '< '>)))
(map file-modification-time '("testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))
mt*))
'(= = =))
(equal?
(let ([mt* (map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))])
(separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #t]) (maybe-compile-library x))) 'mc-b)
(map
(lambda (x y) (if (time=? x y) '= (if (time<? x y) '< '>)))
(map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))
mt*))
'(= = =))
(equal?
(let ([mt* (map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))])
(separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #t]) (maybe-compile-library x))) 'mc-a)
(map
(lambda (x y) (if (time=? x y) '= (if (time<? x y) '< '>)))
(map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))
mt*))
'(= = =))
(touch "testfile-mc-foo.so" "testfile-mc-foo.ss")
(equal?
(let ([mt* (map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))])
(separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #t]) (maybe-compile-program x))) 'mc-foo)
(map
(lambda (x y) (if (time=? x y) '= (if (time<? x y) '< '>)))
(map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))
mt*))
'(= = >))
(equal?
(separate-eval '(load-program "testfile-mc-foo.so"))
"(\"a\" \"b\" \"c\")\n")
(touch "testfile-mc-foo.so" "testfile-mc-c.ss")
(equal?
(let ([mt* (map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))])
(separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #t]) (maybe-compile-program x))) 'mc-foo)
(map
(lambda (x y) (if (time=? x y) '= (if (time<? x y) '< '>)))
(map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))
mt*))
'(= = >))
(equal?
(separate-eval '(load-program "testfile-mc-foo.so"))
"(\"a\" \"b\" \"c\")\n")
(touch "testfile-mc-foo.so" "testfile-mc-b.ss")
(equal?
(let ([mt* (map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))])
(separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #t]) (maybe-compile-program x))) 'mc-foo)
(map
(lambda (x y) (if (time=? x y) '= (if (time<? x y) '< '>)))
(map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))
mt*))
'(= > >))
(equal?
(separate-eval '(load-program "testfile-mc-foo.so"))
"(\"a\" \"b\" \"c\")\n")
(touch "testfile-mc-foo.so" "testfile-mc-a.ss")
(equal?
(let ([mt* (map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))])
(let ([s (separate-compile '(lambda (x) (parameterize ([compile-program-handler (lambda (ifn ofn) (printf "yippee!\n") (compile-program ifn ofn))]
[compile-imported-libraries #t]
[compile-file-message #f])
(maybe-compile-program x)))
'mc-foo)])
(cons
(map
(lambda (x y) (if (time=? x y) '= (if (time<? x y) '< '>)))
(map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))
mt*)
s)))
'((> > >) . "yippee!\n"))
(equal?
(let ([mt* (map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))])
(let ([s (separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #t] [compile-file-message #f]) (maybe-compile-program x))) 'mc-foo)])
(cons
(map
(lambda (x y) (if (time=? x y) '= (if (time<? x y) '< '>)))
(map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))
mt*)
s)))
'((= = =) . ""))
(equal?
(separate-eval '(load-program "testfile-mc-foo.so"))
"(\"a\" \"b\" \"c\")\n")
(touch "testfile-mc-foo.so" "testfile-mc-b.ss")
(equal?
(let ([mt* (map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))])
(separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #t]) (maybe-compile-library x))) 'mc-b)
(map
(lambda (x y) (if (time=? x y) '= (if (time<? x y) '< '>)))
(map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))
mt*))
'(= > =))
; NB: create testfile-mc-a.ss newer than testfile-mc-1b.so, since testfile-mc-1b.so might be newer than testfile-mc-foo.so
(touch "testfile-mc-b.so" "testfile-mc-a.ss")
(equal?
(let ([mt* (map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))])
(let ([s (separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #f] [import-notify #t]) (maybe-compile-library x))) 'mc-b)])
(cons
(map
(lambda (x y) (if (time=? x y) '= (if (time<? x y) '< '>)))
(map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))
mt*)
s)))
'((= = =) . "maybe-compile-library: object file is not older\nmaybe-compile-library: did not find source file \"testfile-mc-a.chezscheme.sls\"\nmaybe-compile-library: found source file \"testfile-mc-a.ss\"\nmaybe-compile-library: found corresponding object file \"testfile-mc-a.so\"\n"))
(equal?
(let ([mt* (map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))])
(separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #t]) (maybe-compile-library x))) 'mc-b)
(map
(lambda (x y) (if (time=? x y) '= (if (time<? x y) '< '>)))
(map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))
mt*))
'(> > =))
(equal?
(let ([mt* (map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))])
(separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #t]) (maybe-compile-program x))) 'mc-foo)
(map
(lambda (x y) (if (time=? x y) '= (if (time<? x y) '< '>)))
(map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))
mt*))
'(= = >))
(equal?
(separate-eval '(load-program "testfile-mc-foo.so"))
"(\"a\" \"b\" \"c\")\n")
(begin
(for-each delete-file '("testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-e.so" "testfile-mc-f.so" "testfile-mc-foo.so"))
(with-output-to-file "testfile-mc-a.ss"
(lambda ()
(pretty-print
'(library (testfile-mc-a) (export a) (import (chezscheme)) (define a "a"))))
'replace)
(with-output-to-file "testfile-mc-b.ss"
(lambda ()
(pretty-print
'(library (testfile-mc-b) (export a b) (import (chezscheme) (testfile-mc-a)) (define b "b"))))
'replace)
(with-output-to-file "testfile-mc-c.ss"
(lambda ()
(pretty-print
'(define c "c")))
'replace)
(with-output-to-file "testfile-mc-d.ss"
(lambda ()
(pretty-print
'(module M (d)
(import (testfile-mc-a) (testfile-mc-b) (chezscheme))
(define d (vector b a)))))
'replace)
(with-output-to-file "testfile-mc-e.ss"
(lambda ()
(pretty-print
'(library (testfile-mc-e) (export e-str) (import (chezscheme)) (define e-str "e"))))
'replace)
(with-output-to-file "testfile-mc-e-import.ss"
(lambda ()
(pretty-print
'(import (testfile-mc-e))))
'replace)
(with-output-to-file "testfile-mc-f.ss"
(lambda ()
(pretty-print
'(library (testfile-mc-f) (export f-str) (import (chezscheme)) (define f-str "f"))))
'replace)
(with-output-to-file "testfile-mc-foo.ss"
(lambda ()
(for-each pretty-print
'((import (chezscheme) (testfile-mc-b))
(include "testfile-mc-c.ss")
(include "testfile-mc-d.ss")
(import M)
(meta define build-something-f
(lambda (k something)
(import (testfile-mc-f))
(datum->syntax k (string->symbol (string-append something "-" f-str)))))
(define-syntax e
(lambda (x)
(syntax-case x ()
[(k) (let ()
(include "testfile-mc-e-import.ss")
#`'#,(build-something-f #'k e-str))])))
(pretty-print (list a b c d (e))))))
'replace)
(separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #t]) (maybe-compile-file x))) 'mc-foo)
#t)
(equal?
(separate-eval '(load "testfile-mc-foo.so"))
"(\"a\" \"b\" \"c\" #(\"b\" \"a\") e-f)\n")
(equal?
(let ([mt* (map file-modification-time '("testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-e.so" "testfile-mc-f.so" "testfile-mc-foo.so"))])
(separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #t]) (maybe-compile-file x))) 'mc-foo)
(map
(lambda (x y) (if (time=? x y) '= (if (time<? x y) '< '>)))
(map file-modification-time '("testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-e.so" "testfile-mc-f.so" "testfile-mc-foo.so"))
mt*))
'(= = = = =))
(touch "testfile-mc-foo.so" "testfile-mc-foo.ss")
(equal?
(let ([mt* (map file-modification-time '("testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-e.so" "testfile-mc-f.so" "testfile-mc-foo.so"))])
(separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #t]) (maybe-compile-file x))) 'mc-foo)
(map
(lambda (x y) (if (time=? x y) '= (if (time<? x y) '< '>)))
(map file-modification-time '("testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-e.so" "testfile-mc-f.so" "testfile-mc-foo.so"))
mt*))
'(= = = = >))
(touch "testfile-mc-foo.so" "testfile-mc-a.ss")
(equal?
(let ([mt* (map file-modification-time '("testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-e.so" "testfile-mc-f.so" "testfile-mc-foo.so"))])
(separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #f]) (maybe-compile-file x))) 'mc-foo)
(map
(lambda (x y) (if (time=? x y) '= (if (time<? x y) '< '>)))
(map file-modification-time '("testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-e.so" "testfile-mc-f.so" "testfile-mc-foo.so"))
mt*))
'(= = = = =))
(equal?
(let ([mt* (map file-modification-time '("testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-e.so" "testfile-mc-f.so" "testfile-mc-foo.so"))])
(separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #t]) (maybe-compile-file x))) 'mc-foo)
(map
(lambda (x y) (if (time=? x y) '= (if (time<? x y) '< '>)))
(map file-modification-time '("testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-e.so" "testfile-mc-f.so" "testfile-mc-foo.so"))
mt*))
'(> > = = >))
(touch "testfile-mc-foo.so" "testfile-mc-c.ss")
(equal?
(let ([mt* (map file-modification-time '("testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-e.so" "testfile-mc-f.so" "testfile-mc-foo.so"))])
(separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #f]) (maybe-compile-file x))) 'mc-foo)
(map
(lambda (x y) (if (time=? x y) '= (if (time<? x y) '< '>)))
(map file-modification-time '("testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-e.so" "testfile-mc-f.so" "testfile-mc-foo.so"))
mt*))
'(= = = = >))
(touch "testfile-mc-foo.so" "testfile-mc-e.ss")
(equal?
(let ([mt* (map file-modification-time '("testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-e.so" "testfile-mc-f.so" "testfile-mc-foo.so"))])
(separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #f]) (maybe-compile-file x))) 'mc-foo)
(map
(lambda (x y) (if (time=? x y) '= (if (time<? x y) '< '>)))
(map file-modification-time '("testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-e.so" "testfile-mc-f.so" "testfile-mc-foo.so"))
mt*))
'(= = = = =))
(equal?
(let ([mt* (map file-modification-time '("testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-e.so" "testfile-mc-f.so" "testfile-mc-foo.so"))])
(separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #t]) (maybe-compile-file x))) 'mc-foo)
(map
(lambda (x y) (if (time=? x y) '= (if (time<? x y) '< '>)))
(map file-modification-time '("testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-e.so" "testfile-mc-f.so" "testfile-mc-foo.so"))
mt*))
'(= = > = >))
(touch "testfile-mc-foo.so" "testfile-mc-e-import.ss")
(equal?
(let ([mt* (map file-modification-time '("testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-e.so" "testfile-mc-f.so" "testfile-mc-foo.so"))])
(separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #f]) (maybe-compile-file x))) 'mc-foo)
(map
(lambda (x y) (if (time=? x y) '= (if (time<? x y) '< '>)))
(map file-modification-time '("testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-e.so" "testfile-mc-f.so" "testfile-mc-foo.so"))
mt*))
'(= = = = >))
(touch "testfile-mc-foo.so" "testfile-mc-f.ss")
(equal?
(let ([mt* (map file-modification-time '("testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-e.so" "testfile-mc-f.so" "testfile-mc-foo.so"))])
(separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #f]) (maybe-compile-file x))) 'mc-foo)
(map
(lambda (x y) (if (time=? x y) '= (if (time<? x y) '< '>)))
(map file-modification-time '("testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-e.so" "testfile-mc-f.so" "testfile-mc-foo.so"))
mt*))
'(= = = = =))
(equal?
(let ([mt* (map file-modification-time '("testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-e.so" "testfile-mc-f.so" "testfile-mc-foo.so"))])
(separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #t]) (maybe-compile-file x))) 'mc-foo)
(map
(lambda (x y) (if (time=? x y) '= (if (time<? x y) '< '>)))
(map file-modification-time '("testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-e.so" "testfile-mc-f.so" "testfile-mc-foo.so"))
mt*))
'(= = = > >))
(begin
(rm-rf "testdir")
(mkdir "testdir")
(mkfile "testdir/testfile-mc-1a.ss"
'(define mcratfink 'abe))
(mkfile "testdir/testfile-mc-1b.ss"
'(library (testdir testfile-mc-1b)
(export mc-1b-x)
(import (chezscheme))
(include "testfile-mc-1a.ss")
(define mc-1b-x
(lambda ()
(list mcratfink)))))
(mkfile "testdir/testfile-mc-1c.ss"
'(library (testdir testfile-mc-1c)
(export mc-1b-x)
(import (testdir testfile-mc-1b))))
(separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #t]) (compile-library x))) "testdir/testfile-mc-1c")
#t)
(equal?
(separate-eval '(let () (import (testdir testfile-mc-1c)) (mc-1b-x)))
"(abe)\n")
(equal?
(let ([mt* (map file-modification-time '("testdir/testfile-mc-1b.so" "testdir/testfile-mc-1c.so"))])
(separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #t]) (maybe-compile-library x))) "testdir/testfile-mc-1c")
(map
(lambda (x y) (if (time=? x y) '= (if (time<? x y) '< '>)))
(map file-modification-time '("testdir/testfile-mc-1b.so" "testdir/testfile-mc-1c.so"))
mt*))
'(= =))
(touch "testdir/testfile-mc-1c.so" "testdir/testfile-mc-1a.ss")
(equal?
(let ([mt* (map file-modification-time '("testdir/testfile-mc-1b.so" "testdir/testfile-mc-1c.so"))])
(separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #f]) (maybe-compile-library x))) "testdir/testfile-mc-1c")
(map
(lambda (x y) (if (time=? x y) '= (if (time<? x y) '< '>)))
(map file-modification-time '("testdir/testfile-mc-1b.so" "testdir/testfile-mc-1c.so"))
mt*))
'(= =))
(equal?
(let ([mt* (map file-modification-time '("testdir/testfile-mc-1b.so" "testdir/testfile-mc-1c.so"))])
(separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #t]) (maybe-compile-library x))) "testdir/testfile-mc-1c")
(map
(lambda (x y) (if (time=? x y) '= (if (time<? x y) '< '>)))
(map file-modification-time '("testdir/testfile-mc-1b.so" "testdir/testfile-mc-1c.so"))
mt*))
'(> >))
(touch "testdir/testfile-mc-1c.so" "testdir/testfile-mc-1b.ss")
(equal?
(let ([mt* (map file-modification-time '("testdir/testfile-mc-1b.so" "testdir/testfile-mc-1c.so"))])
(separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #f]) (maybe-compile-library x))) "testdir/testfile-mc-1c")
(map
(lambda (x y) (if (time=? x y) '= (if (time<? x y) '< '>)))
(map file-modification-time '("testdir/testfile-mc-1b.so" "testdir/testfile-mc-1c.so"))
mt*))
'(= =))
(equal?
(let ([mt* (map file-modification-time '("testdir/testfile-mc-1b.so" "testdir/testfile-mc-1c.so"))])
(separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #t]) (maybe-compile-library x))) "testdir/testfile-mc-1c")
(map
(lambda (x y) (if (time=? x y) '= (if (time<? x y) '< '>)))
(map file-modification-time '("testdir/testfile-mc-1b.so" "testdir/testfile-mc-1c.so"))
mt*))
'(> >))
(touch "testdir/testfile-mc-1c.so" "testdir/testfile-mc-1c.ss")
(equal?
(let ([mt* (map file-modification-time '("testdir/testfile-mc-1b.so" "testdir/testfile-mc-1c.so"))])
(separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #t]) (maybe-compile-library x))) "testdir/testfile-mc-1c")
(map
(lambda (x y) (if (time=? x y) '= (if (time<? x y) '< '>)))
(map file-modification-time '("testdir/testfile-mc-1b.so" "testdir/testfile-mc-1c.so"))
mt*))
'(= >))
(equal?
(let ([mt* (map file-modification-time '("testdir/testfile-mc-1b.so" "testdir/testfile-mc-1c.so"))])
(separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #f]) (maybe-compile-library x))) "testdir/testfile-mc-1c")
(map
(lambda (x y) (if (time=? x y) '= (if (time<? x y) '< '>)))
(map file-modification-time '("testdir/testfile-mc-1b.so" "testdir/testfile-mc-1c.so"))
mt*))
'(= =))
(error? ; can't find testfile-mc-1a.ss
(separate-compile 'compile-library "testdir/testfile-mc-1b"))
(begin
(separate-compile
'(lambda (x)
(parameterize ([source-directories (cons "testdir" (source-directories))])
(maybe-compile-library x)))
"testdir/testfile-mc-1b")
#t)
(error? ; can't find testfile-mc-1a.ss
(separate-compile 'maybe-compile-library "testdir/testfile-mc-1b"))
; make sure maybe-compile-file wipes out b.so when it fails to find a.ss
(or (= (optimize-level) 3) (not (file-exists? "testdir/testfile-mc-1b.so")))
(begin
(separate-compile '(lambda (x)
(parameterize ([source-directories (cons "testdir" (source-directories))])
(maybe-compile-library x)))
"testdir/testfile-mc-1b")
#t)
(touch "testdir/testfile-mc-1b.so" "testdir/testfile-mc-1a.ss")
(equal?
(let ([mt* (map file-modification-time '("testdir/testfile-mc-1b.so"))])
(separate-compile '(lambda (x)
(parameterize ([source-directories (cons "testdir" (source-directories))])
(maybe-compile-library x)))
"testdir/testfile-mc-1b")
(map
(lambda (x y) (if (time=? x y) '= (if (time<? x y) '< '>)))
(map file-modification-time '("testdir/testfile-mc-1b.so"))
mt*))
'(>))
(touch "testdir/testfile-mc-1b.so" "testdir/testfile-mc-1b.ss")
(equal?
(let ([mt* (map file-modification-time '("testdir/testfile-mc-1b.so"))])
(separate-compile '(lambda (x)
(parameterize ([source-directories (cons "testdir" (source-directories))])
(maybe-compile-library x)))
"testdir/testfile-mc-1b")
(map
(lambda (x y) (if (time=? x y) '= (if (time<? x y) '< '>)))
(map file-modification-time '("testdir/testfile-mc-1b.so"))
mt*))
'(>))
(delete-file "testdir/testfile-mc-1a.ss")
(error? ; maybe-compile-library: can't find testfile-mc-1a.ss
(separate-compile '(lambda (x)
(parameterize ([source-directories (cons "testdir" (source-directories))])
(maybe-compile-library x)))
"testdir/testfile-mc-1b"))
; make sure maybe-compile-file wipes out b.so when it fails to find a.ss
(or (= (optimize-level) 3) (not (file-exists? "testdir/testfile-mc-1b.so")))
(begin
(rm-rf "testdir")
#t)
; make sure maybe-compile-file handles incomplete fasl files
(begin
(mkfile "testfile-mc-2a.ss"
'(library (testfile-mc-2a)
(export q)
(import (chezscheme))
(define f
(lambda ()
(printf "running f\n")
"x"))
(define-syntax q
(begin
(printf "expanding testfile-mc-2a\n")
(lambda (x)
(printf "expanding q\n")
#'(f))))))
(mkfile "testfile-mc-2.ss"
'(import (chezscheme) (testfile-mc-2a))
'(define-syntax qq
(begin
(printf "expanding testfile-mc-2\n")
(lambda (x)
(printf "expanding qq\n")
#'q)))
'(printf "qq => ~a\n" qq))
(delete-file "testfile-mc-2a.so")
(delete-file "testfile-mc-2.so")
(display-string (separate-compile '(lambda (x) (parameterize ([compile-file-message #f] [compile-imported-libraries #t] [fasl-compressed #f]) (maybe-compile-program x))) 'mc-2))
#t)
(begin
(let ([p (open-file-input/output-port "testfile-mc-2a.so" (file-options no-create no-fail no-truncate))])
(set-port-length! p 73)
(close-port p))
(display-string (separate-compile '(lambda (x) (parameterize ([compile-file-message #f] [compile-imported-libraries #t] [fasl-compressed #f] [import-notify #t]) (maybe-compile-program x))) 'mc-2))
#t)
(begin
(let ([p (open-file-input/output-port "testfile-mc-2.so" (file-options no-create no-fail no-truncate))])
(set-port-length! p 87)
(close-port p))
(display-string (separate-compile '(lambda (x) (parameterize ([compile-file-message #f] [compile-imported-libraries #t] [fasl-compressed #f] [import-notify #t]) (maybe-compile-program x))) 'mc-2))
#t)
; make sure maybe-compile-file handles missing include files gracefully
(begin
(mkfile "testfile-mc-3a.ss"
"hello from 3a!")
(mkfile "testfile-mc-3b.ss"
'(library (testfile-mc-3b)
(export q)
(import (chezscheme))
(define-syntax q
(begin
(printf "expanding testfile-mc-3b\n")
(lambda (x)
(printf "expanding q\n")
(include "./testfile-mc-3a.ss"))))))
(mkfile "testfile-mc-3.ss"
'(import (chezscheme) (testfile-mc-3b))
'(define-syntax qq
(begin
(printf "expanding testfile-mc-3\n")
(lambda (x)
(printf "expanding qq\n")
#'q)))
'(printf "qq => ~a\n" qq))
(delete-file "testfile-mc-3b.so")
(delete-file "testfile-mc-3.so")
(separate-compile
'(lambda (x)
(parameterize ([compile-file-message #f] [compile-imported-libraries #t])
(maybe-compile-program x)))
'mc-3)
#t)
(begin
(delete-file "testfile-mc-3a.ss")
#t)
(error? ; separate-compile: no such file or directory: testfile-mc-3a.ss
(separate-compile
'(lambda (x)
(parameterize ([compile-file-message #f] [compile-imported-libraries #t])
(maybe-compile-program x)))
'mc-3))
; make sure maybe-compile-file handles missing include files gracefully
(begin
(define-record-type hash-bang-chezscheme)
(record-writer (type-descriptor hash-bang-chezscheme) (lambda (x p wr) (display-string "#!chezscheme")))
(mkfile "testfile-mc-4a.ss"
"hello from 4a!")
(mkfile "testfile-mc-4b.ss"
(make-hash-bang-chezscheme)
'(library (testfile-mc-4b)
(export b)
(import (chezscheme))
(define-syntax q
(lambda (x)
(if (file-exists? "testfile-mc-4a.ss")
(begin
(printf "HEY!\n")
(#%$require-include "./testfile-mc-4a.ss")
(call-with-input-file "testfile-mc-4a.ss" read))
(begin
(printf "BARLEY!\n")
"testfile-mc-4a is no more"))))
(define (b) q)))
(mkfile "testfile-mc-4.ss"
'(import (chezscheme) (testfile-mc-4b))
'(printf "q => ~a\n" (b)))
(delete-file "testfile-mc-4b.so")
(delete-file "testfile-mc-4.so")
(separate-compile
'(lambda (x)
(parameterize ([compile-file-message #f] [compile-imported-libraries #t])
(maybe-compile-program x)))
'mc-4)
#t)
(equal?
(separate-eval '(load-program "testfile-mc-4.so"))
"q => hello from 4a!\n")
(begin
(mkfile "testfile-mc-4a.ss"
"goodbye from 4a!")
(touch "testfile-mc-4.so" "testfile-mc-4a.ss")
(separate-compile
'(lambda (x)
(parameterize ([compile-file-message #f] [compile-imported-libraries #t] [import-notify #t])
(maybe-compile-program x)))
'mc-4)
#t)
(equal?
(separate-eval '(load-program "testfile-mc-4.so"))
"q => goodbye from 4a!\n")
(begin
(delete-file "testfile-mc-4a.ss")
#t)
(begin
(separate-compile
'(lambda (x)
(parameterize ([compile-file-message #f] [compile-imported-libraries #t] [import-notify #t])
(maybe-compile-program x)))
'mc-4)
#t)
(equal?
(separate-eval '(load-program "testfile-mc-4.so"))
"q => testfile-mc-4a is no more\n")
; make sure maybe-compile-file handles missing include files gracefully
(begin
(define-record-type hash-bang-chezscheme)
(record-writer (type-descriptor hash-bang-chezscheme) (lambda (x p wr) (display-string "#!chezscheme")))
(mkfile "testfile-mc-5a.ss"
"hello from 5a!")
(mkfile "testfile-mc-5b.ss"
(make-hash-bang-chezscheme)
'(library (testfile-mc-5b)
(export q)
(import (chezscheme))
(define-syntax q
(lambda (x)
(if (file-exists? "testfile-mc-5a.ss")
(begin
(printf "HEY!\n")
(#%$require-include "./testfile-mc-5a.ss")
(call-with-input-file "testfile-mc-5a.ss" read))
(begin
(printf "BARLEY!\n")
"testfile-mc-5a is no more"))))))
(mkfile "testfile-mc-5.ss"
'(import (chezscheme) (testfile-mc-5b))
'(define-syntax qq (lambda (x) #'q))
'(printf "qq => ~a\n" qq))
(delete-file "testfile-mc-5b.so")
(delete-file "testfile-mc-5.so")
(separate-compile
'(lambda (x)
(parameterize ([compile-file-message #f] [compile-imported-libraries #t])
(maybe-compile-program x)))
'mc-5)
#t)
(equal?
(separate-eval '(load-program "testfile-mc-5.so"))
"qq => hello from 5a!\n")
(begin
(mkfile "testfile-mc-5a.ss"
"goodbye from 5a!")
(touch "testfile-mc-5.so" "testfile-mc-5a.ss")
(separate-compile
'(lambda (x)
(parameterize ([compile-file-message #f] [compile-imported-libraries #t] [import-notify #t])
(maybe-compile-program x)))
'mc-5)
#t)
(equal?
(separate-eval '(load-program "testfile-mc-5.so"))
"qq => goodbye from 5a!\n")
(begin
(delete-file "testfile-mc-5a.ss")
#t)
(begin
(separate-compile
'(lambda (x)
(parameterize ([compile-file-message #f] [compile-imported-libraries #t] [import-notify #t])
(maybe-compile-program x)))
'mc-5)
#t)
(equal?
(separate-eval '(load-program "testfile-mc-5.so"))
"qq => testfile-mc-5a is no more\n")
)
(mat make-boot-file
(eq? (begin
(with-output-to-file "testfile-1.ss"
(lambda ()
(pretty-print '(display "hello 1\n")))
'replace)
(with-output-to-file "testfile-2.ss"
(lambda ()
(pretty-print '(display "hello 2\n")))
'replace)
(with-output-to-file "testfile-3.ss"
(lambda ()
(pretty-print '(display "hello 3\n")))
'replace)
(with-output-to-file "testfile-4.ss"
(lambda ()
(pretty-print '(display "hello 4\n")))
'(replace))
(with-output-to-file "testfile-5.ss"
(lambda ()
(pretty-print '(display "hello 5\n")))
'(replace))
(parameterize ([optimize-level 2])
(compile-script "testfile-1")
(compile-script "testfile-2")
(compile-file "testfile-3")
(compile-file "testfile-4")
(compile-file "testfile-5")))
(void))
(equal?
(begin
(parameterize ([optimize-level 2])
(make-boot-file "testfile.boot" '("petite")
"testfile-1.so"
"testfile-2.ss"
"testfile-3.so"
"testfile-4.so"
"testfile-5.ss"))
(let-values ([(to-stdin from-stdout from-stderr pid)
(open-process-ports
(format "~a -b ./testfile.boot -q" (patch-exec-path *scheme*))
(buffer-mode block)
(native-transcoder))])
(close-output-port to-stdin)
(let ([out (get-string-all from-stdout)]
[err (get-string-all from-stderr)])
(close-input-port from-stdout)
(close-input-port from-stderr)
(unless (eof-object? err) (error 'bootfile-test1 err))
out)))
"hello 1\nhello 2\nhello 3\nhello 4\nhello 5\n")
(equal?
(begin
(parameterize ([optimize-level 2])
(compile-to-file
'((library (A) (export a) (import (scheme)) (define a 'aye))
(library (B) (export b) (import (A) (scheme)) (define b (list a 'captain))))
"testfile-libs.so")
(make-boot-file "testfile.boot" '("petite") "testfile-libs.so"))
(let-values ([(to-stdin from-stdout from-stderr pid)
(open-process-ports
(format "~a -b ./testfile.boot -q" (patch-exec-path *scheme*))
(buffer-mode block)
(native-transcoder))])
(pretty-print '(let () (import (B)) (printf "~s\n" b)) to-stdin)
(close-output-port to-stdin)
(let ([out (get-string-all from-stdout)]
[err (get-string-all from-stderr)])
(close-input-port from-stdout)
(close-input-port from-stderr)
(unless (eof-object? err) (error 'bootfile-test1 err))
out)))
"(aye captain)\n")
(equal?
(begin
(unless (or (embedded?) (equal? *scheme* (format "~a/bin/~a/scheme~a" (path-parent *mats-dir*) (machine-type) (if (windows?) ".exe" ""))))
(errorf #f "not testing boot file based on ../boot/~a/petite.boot, since *scheme* isn't ../bin/~a/scheme~a"
(machine-type) (machine-type) (if (windows?) ".exe" "")))
(parameterize ([optimize-level 2])
(make-boot-file "testfile.boot" '()
(format "~a/boot/~a/petite.boot" (path-parent *mats-dir*) (machine-type))
"testfile-1.so"
"testfile-2.so"
"testfile-3.ss"
"testfile-4.ss"
"testfile-5.so"))
(let-values ([(to-stdin from-stdout from-stderr pid)
(open-process-ports
(format "~a -b ./testfile.boot -q" (patch-exec-path *scheme*))
(buffer-mode block)
(native-transcoder))])
(close-output-port to-stdin)
(let ([out (get-string-all from-stdout)]
[err (get-string-all from-stderr)])
(close-input-port from-stdout)
(close-input-port from-stderr)
(unless (eof-object? err) (error 'bootfile-test2 err))
out)))
"hello 1\nhello 2\nhello 3\nhello 4\nhello 5\n")
; regression test to verify that we can evaluate a foreign-callable form inside the procedure to
; which scheme-start is set, which was failing because its relocation information was discarded
; by the static-generation collection.
(equal?
(begin
(unless (or (embedded?) (equal? *scheme* (format "~a/bin/~a/scheme~a" (path-parent *mats-dir*) (machine-type) (if (windows?) ".exe" ""))))
(errorf #f "not testing boot file based on ../boot/~a/petite.boot, since *scheme* isn't ../bin/~a/scheme~a"
(machine-type) (machine-type) (if (windows?) ".exe" "")))
(mkfile "testfile.ss"
'(scheme-start
(lambda ()
(let ([x 0])
(printf "~s\n" (foreign-callable (lambda () (set! x (+ x 1)) x) () void))))))
(make-boot-file "testfile.boot" '("petite") "testfile.ss")
(let-values ([(to-stdin from-stdout from-stderr pid)
(open-process-ports
(format "~a -b ./testfile.boot -q" (patch-exec-path *scheme*))
(buffer-mode block)
(native-transcoder))])
(close-output-port to-stdin)
(let ([out (get-string-all from-stdout)]
[err (get-string-all from-stderr)])
(close-input-port from-stdout)
(close-input-port from-stderr)
(unless (eof-object? err) (error 'bootfile-test2 err))
out)))
"#<code>\n")
)
(mat hostop
(begin
(separate-compile
`(lambda (x)
(call-with-port
(open-file-output-port (format "~a.so" x) (file-options #;compressed replace))
(lambda (op)
(call-with-port
(open-file-output-port (format "~a.host" x) (file-options #;compressed replace))
(lambda (hostop)
(compile-to-port
'((library (testfile-hop1)
(export a b c)
(import (chezscheme))
(define-syntax a (identifier-syntax 17))
(module b (b1 b2)
(define b1 "23.5")
(define-syntax b2 (identifier-syntax (cons b1 b1))))
(define c (lambda (x) (import b) (vector b2 x)))))
op #f #f #f ',(machine-type) hostop))))))
"testfile-hop1")
(with-output-to-file "testfile-hop2.ss"
(lambda ()
(pretty-print '(eval-when (compile) (load "testfile-hop1.so")))
(pretty-print '(eval-when (compile) (import (testfile-hop1))))
(pretty-print '(eval-when (compile) (import b)))
(pretty-print '(pretty-print (list a b1 b2 (c 55)))))
'replace)
(with-output-to-file "testfile-hop3.ss"
(lambda ()
(pretty-print '(eval-when (compile) (load "testfile-hop1.host")))
(pretty-print '(eval-when (compile) (import (testfile-hop1))))
(pretty-print '(eval-when (compile) (import b)))
(pretty-print '(pretty-print (list a b1 b2 (c 55)))))
'replace)
(for-each separate-compile '(hop2 hop3))
#t)
(equal?
(separate-eval
'(load "testfile-hop1.so")
'(import (testfile-hop1))
'a
'(import b)
'b1
'b2
'(c 55))
"17\n\
\"23.5\"\n\
(\"23.5\" . \"23.5\")\n\
#((\"23.5\" . \"23.5\") 55)\n\
")
(equal?
(separate-eval
'(visit "testfile-hop1.so") ; visit now---$invoke-library will revisit later
'(import (testfile-hop1))
'a
'(import b)
'b1
'b2
'(c 55))
"17\n\
\"23.5\"\n\
(\"23.5\" . \"23.5\")\n\
#((\"23.5\" . \"23.5\") 55)\n\
")
(equal?
(separate-eval
'(revisit "testfile-hop1.so")
'(expand 'a)
'(guard (c [else (display-condition c) (newline)]) (eval '(import b)))
'(expand 'b1)
'(expand 'b2)
'(load "testfile-hop2.so"))
"a\n\
Exception: unknown module b\n\
b1\n\
b2\n\
(17 \"23.5\" (\"23.5\" . \"23.5\") #((\"23.5\" . \"23.5\") 55))\n\
")
(equal?
(separate-eval
'(revisit "testfile-hop1.so")
'(expand 'a)
'(guard (c [else (display-condition c) (newline)]) (eval '(import b)))
'(expand 'b1)
'(expand 'b2)
'(load "testfile-hop3.so"))
"a\n\
Exception: unknown module b\n\
b1\n\
b2\n\
(17 \"23.5\" (\"23.5\" . \"23.5\") #((\"23.5\" . \"23.5\") 55))\n\
")
(equal?
(separate-eval
'(load "testfile-hop1.host")
'(import (testfile-hop1))
'a
'(import b)
'b1
'b2
'(c 55))
"17\n\
\"23.5\"\n\
(\"23.5\" . \"23.5\")\n\
#((\"23.5\" . \"23.5\") 55)\n\
")
(equal?
(separate-eval
'(revisit "testfile-hop1.host")
'(expand 'a)
'(guard (c [else (display-condition c) (newline)]) (eval '(import b)))
'(expand 'b1)
'(expand 'b2)
'(load "testfile-hop2.so"))
"a\n\
Exception: unknown module b\n\
b1\n\
b2\n\
(17 \"23.5\" (\"23.5\" . \"23.5\") #((\"23.5\" . \"23.5\") 55))\n\
")
(equal?
(separate-eval
'(revisit "testfile-hop1.host")
'(expand 'a)
'(guard (c [else (display-condition c) (newline)]) (eval '(import b)))
'(expand 'b1)
'(expand 'b2)
'(load "testfile-hop3.so"))
"a\n\
Exception: unknown module b\n\
b1\n\
b2\n\
(17 \"23.5\" (\"23.5\" . \"23.5\") #((\"23.5\" . \"23.5\") 55))\n\
")
(begin
(#%$compile-host-library 'moi "testfile-hop1.host")
(define bv (call-with-port (open-file-input-port "testfile-hop1.host") get-bytevector-all))
#t)
(begin
; doing it a second time should be a no-op
(#%$compile-host-library 'moi "testfile-hop1.host")
(bytevector=?
(call-with-port (open-file-input-port "testfile-hop1.host") get-bytevector-all)
bv))
(begin
(set! bv #f)
#t)
(equal?
(separate-eval
'(load "testfile-hop1.host")
'(import (testfile-hop1))
'a
'(import b)
'b1
'b2
'(c 55))
"17\n\
\"23.5\"\n\
(\"23.5\" . \"23.5\")\n\
#((\"23.5\" . \"23.5\") 55)\n\
")
(equal?
(separate-eval
'(revisit "testfile-hop1.host")
'(expand 'a)
'(guard (c [else (display-condition c) (newline)]) (eval '(import b)))
'(expand 'b1)
'(expand 'b2)
'(load "testfile-hop2.so"))
"a\n\
Exception: unknown module b\n\
b1\n\
b2\n\
(17 \"23.5\" (\"23.5\" . \"23.5\") #((\"23.5\" . \"23.5\") 55))\n\
")
(equal?
(separate-eval
'(revisit "testfile-hop1.host")
'(expand 'a)
'(guard (c [else (display-condition c) (newline)]) (eval '(import b)))
'(expand 'b1)
'(expand 'b2)
'(load "testfile-hop3.so"))
"a\n\
Exception: unknown module b\n\
b1\n\
b2\n\
(17 \"23.5\" (\"23.5\" . \"23.5\") #((\"23.5\" . \"23.5\") 55))\n\
")
(equal?
(separate-eval
'(visit "testfile-hop1.so")
'(delete-file "testfile-hop1.so") ; prevent import from revisiting testfile-hop1.so
'(import (testfile-hop1))
'a
'(import b)
'(guard (c [else (display-condition c) (newline)]) (eval 'b1))
'(guard (c [else (display-condition c) (newline)]) (eval 'b2))
'(guard (c [else (display-condition c) (newline)]) (eval 'c)))
"#t\n\
17\n\
Exception: failed for testfile-hop1.so: no such file or directory\n\
Exception: failed for testfile-hop1.so: no such file or directory\n\
Exception: failed for testfile-hop1.so: no such file or directory\n\
")
)
(mat eval
(error? ; 7 is not an environment (should be reported by compile or interpret)
(eval 3 7))
(error? ; 7 is not an environment
(interpret 3 7))
(error? ; 7 is not an environment
(compile 3 7))
(eqv? (eval '(+ 3 4)) 7)
(eq? (eval '(define foo (lambda (x) x))) (void))
(eval '(let ([x '(a b c)]) (eq? (foo x) x)))
)
(mat expand ; tested in mats extend-syntax & with in 8.ms
(error? ; 7 is not an environment (should be reported by sc-expand)
(expand 3 7))
(error? ; 7 is not an environment
(sc-expand 3 7))
(procedure? expand)
)
(mat eval-when
(let ([p (open-output-file "testfile.ss" 'replace)])
(display "
(eval-when (eval) (set! aaa 'eval))
(eval-when (load) (set! aaa 'load))
(eval-when (compile) (set! aaa 'compile))
" p)
(close-output-port p)
#t)
(begin (set! aaa #f) (load "testfile.ss") (eq? aaa 'eval))
(begin (printf "***** expect \"compile-file\" message:~%")
(set! aaa #f)
(compile-file "testfile")
(eq? aaa 'compile))
(begin (set! aaa #f) (load "testfile.so") (eq? aaa 'load))
(let ([p (open-output-file "testfile.ss" 'replace)])
(display "
(eval-when (eval)
(eval-when (eval) (set! aaa 'eval@eval))
(eval-when (load) (set! aaa 'load@eval))
(eval-when (compile) (set! aaa 'compile@eval)))
(eval-when (load)
(eval-when (eval) (set! bbb 'eval@load))
(eval-when (load) (set! bbb 'load@load))
(eval-when (compile) (set! bbb 'compile@load)))
(eval-when (compile)
(eval-when (eval) (set! ccc 'eval@compile))
(eval-when (load) (set! ccc 'load@compile))
(eval-when (compile) (set! ccc 'compile@compile)))
" p)
(close-output-port p)
#t)
(begin (set! aaa #f)
(set! bbb #f)
(set! ccc #f)
(load "testfile.ss")
(equal? (list aaa bbb ccc) '(eval@eval #f #f)))
(begin (printf "***** expect \"compile-file\" message:~%")
(set! aaa #f)
(set! bbb #f)
(set! ccc #f)
(compile-file "testfile")
(equal? (list aaa bbb ccc) '(#f compile@load eval@compile)))
(begin (set! aaa #f)
(set! bbb #f)
(set! ccc #f)
(load "testfile.so")
(equal? (list aaa bbb ccc) '(#f load@load #f)))
(let ([p (open-output-file "testfile.ss" 'replace)])
(display "
(eval-when (eval) (pretty-print 'evaluating))
(eval-when (compile) (pretty-print 'compiling))
(eval-when (load) (pretty-print 'loading))
(eval-when (visit) (pretty-print 'visiting))
(eval-when (revisit) (pretty-print 'revisiting))
(eval-when (visit revisit) (pretty-print 'visit/revisit))
(eval-when (compile)
(eval-when (eval)
(pretty-print 'oops)))
(eval-when (load eval)
(eval-when (compile)
(pretty-print 'foo6)))
" p)
(close-output-port p)
#t)
(let ()
(define with-output-to-string
(lambda (p)
(parameterize ([current-output-port (open-output-string)])
(p)
(get-output-string (current-output-port)))))
(and
(string=?
(with-output-to-string
(lambda ()
(compile-file "testfile")))
"compiling testfile.ss with output to testfile.so
compiling
oops
foo6
"
)
(string=?
(with-output-to-string
(lambda ()
(visit "testfile.so")))
"visiting
visit/revisit
"
)
(string=?
(with-output-to-string
(lambda ()
(revisit "testfile.so")))
"loading
revisiting
visit/revisit
"
)
(string=?
(with-output-to-string
(lambda ()
(load "testfile.so")))
"loading
visiting
revisiting
visit/revisit
"
)))
(let ([p (open-output-file "testfile.ss" 'replace)])
(display "
(define-syntax $a (identifier-syntax 'b))
(define $foo)
(eval-when (visit) (define visit-x 17))
(eval-when (revisit) (define-syntax revisit-x (identifier-syntax 23)))
" p)
(close-output-port p)
#t)
(begin (define-syntax $foo (syntax-rules ())) #t)
(begin (define-syntax $a (syntax-rules ())) #t)
(begin (define-syntax visit-x (syntax-rules ())) #t)
(begin (define-syntax revisit-x (syntax-rules ())) #t)
(error? $foo)
(error? $a)
(error? visit-x)
(error? revisit-x)
(begin (compile-file "testfile") #t)
(eq? $a 'b)
(error? $foo)
(error? visit-x)
(error? revisit-x)
(begin (define-syntax $foo (syntax-rules ())) #t)
(begin (define-syntax $a (syntax-rules ())) #t)
(begin (define-syntax visit-x (syntax-rules ())) #t)
(begin (define-syntax revisit-x (syntax-rules ())) #t)
(begin (visit "testfile.so") #t)
(eq? $a 'b)
(error? $foo)
(eq? visit-x 17)
(error? revisit-x)
(begin (revisit "testfile.so") #t)
(eq? $a 'b)
(eq? $foo (void))
(eq? visit-x 17)
(eq? revisit-x 23)
(begin (define get-$foo (lambda () $foo)) (eq? (get-$foo) (void)))
(begin (define-syntax $foo (syntax-rules ())) #t)
(begin (define-syntax $a (syntax-rules ())) #t)
(begin (define-syntax visit-x (syntax-rules ())) #t)
(begin (define-syntax revisit-x (syntax-rules ())) #t)
(begin (revisit "testfile.so") #t)
(error? $a)
(error? $foo)
(eq? (get-$foo) (void))
(error? visit-x)
(eq? revisit-x 23)
(begin (visit "testfile.so") #t)
(eq? $a 'b)
(eq? $foo (void))
(eq? (get-$foo) (void))
(eq? visit-x 17)
(eq? revisit-x 23)
(begin (define-syntax $foo (syntax-rules ())) #t)
(begin (define-syntax $a (syntax-rules ())) #t)
(begin (define-syntax visit-x (syntax-rules ())) #t)
(begin (define-syntax revisit-x (syntax-rules ())) #t)
(begin (load "testfile.so") #t)
(eq? $a 'b)
(eq? $foo (void))
(eq? (get-$foo) (void))
(eq? visit-x 17)
(eq? revisit-x 23)
(begin (define-syntax $foo (syntax-rules ())) #t)
(begin (define-syntax $a (syntax-rules ())) #t)
(begin (define-syntax visit-x (syntax-rules ())) #t)
(begin (define-syntax revisit-x (syntax-rules ())) #t)
(begin (load "testfile.ss") #t)
(eq? $a 'b)
(eq? $foo (void))
(error? visit-x)
(error? revisit-x)
(eqv?
(let ((x 77))
(eval-when (eval)
(define x 88))
x)
88)
(eqv?
(let ((x 77))
(eval-when (compile visit load revisit)
(define x 88))
x)
77)
(begin
(define $qlist '())
(define-syntax $qdef
(syntax-rules ()
[(_ x e)
(begin
(eval-when (compile)
(set! $qlist (cons 'x $qlist)))
(eval-when (load eval)
(define x e)))]))
($qdef $bar 33)
(and (null? $qlist) (eqv? $bar 33)))
(let ([p (open-output-file "testfile.ss" 'replace)])
(pretty-print '($qdef $baz (lambda () ($qdef x 44) x)) p)
(close-output-port p)
#t)
(begin (compile-file "testfile") #t)
(equal? $qlist '($baz))
(begin (load "testfile.so") #t)
(equal? $qlist '($baz))
(eq? ($baz) 44)
; regression: make sure that visit doesn't evaluate top-level module
; inits and definition right-hand-sides
(let ([p (open-output-file "testfile.ss" 'replace)])
(display
"(eval-when (visit) (printf \"visit A\\n\"))
(eval-when (revisit) (printf \"revisit A\\n\"))
(eval-when (load compile) (printf \"compile load A\\n\"))
(define foo (printf \"evaluating top-level foo rhs\\n\"))
(printf \"evaluating top-level init\\n\")
(eval-when (visit) (printf \"visit B\\n\"))
(eval-when (revisit) (printf \"revisit B\\n\"))
(eval-when (load compile) (printf \"compile load B\\n\"))
(module ()
(define foo (printf \"evaluating module foo rhs\\n\"))
(printf \"evaluating module init\\n\"))
" p)
(close-output-port p)
#t)
(let ()
(define with-output-to-string
(lambda (p)
(parameterize ([current-output-port (open-output-string)])
(p)
(get-output-string (current-output-port)))))
(and
(string=?
(with-output-to-string
(lambda ()
(compile-file "testfile")))
"compiling testfile.ss with output to testfile.so
compile load A
compile load B
"
)
(string=?
(with-output-to-string
(lambda ()
(visit "testfile.so")))
"visit A
visit B
")
(string=?
(with-output-to-string
(lambda ()
(revisit "testfile.so")))
"revisit A
compile load A
evaluating top-level foo rhs
evaluating top-level init
revisit B
compile load B
evaluating module foo rhs
evaluating module init
")))
)
(mat compile-whole-program
(error? ; no such file or directory nosuchfile.wpo
(compile-whole-program "nosuchfile.wpo" "testfile-wpo-ab-all.so"))
(error? ; incorrect number of arguments
(compile-whole-program "testfile-wpo-ab.wpo"))
(begin
(with-output-to-file "testfile-wpo-a.ss"
(lambda ()
(pretty-print
'(library (testfile-wpo-a)
(export make-tree tree tree? tree-left tree-right tree-value)
(import (chezscheme))
(define-record-type tree
(nongenerative)
(fields (mutable left) (mutable value) (mutable right)))
(record-writer (record-type-descriptor tree)
(lambda (r p wr)
(display "#[tree " p)
(wr (tree-left r) p)
(display " " p)
(wr (tree-value r) p)
(display " " p)
(wr (tree-right r) p)
(display "]" p))))))
'replace)
(with-output-to-file "testfile-wpo-b.ss"
(lambda ()
(pretty-print
'(library (testfile-wpo-b)
(export make-constant-tree make-tree tree? tree-left tree-right
tree-value tree->list)
(import (rnrs) (testfile-wpo-a))
(define-syntax make-constant-tree
(lambda (x)
(define build-tree
(lambda (tree-desc)
(syntax-case tree-desc ()
[(l v r)
(make-tree (build-tree #'l) (syntax->datum #'v) (build-tree #'r))]
[v (make-tree #f (syntax->datum #'v) #f)])))
(syntax-case x ()
[(_ tree-desc) #`'#,(build-tree #'tree-desc)])))
(define tree->list
(lambda (t)
(let f ([t t] [s '()])
(if (not t)
s
(f (tree-left t) (cons (tree-value t) (f (tree-right t) s))))))))))
'replace)
(with-output-to-file "testfile-wpo-ab.ss"
(lambda ()
(pretty-print '(import (chezscheme) (testfile-wpo-b)))
(pretty-print '(define a (make-constant-tree ((1 2 4) 5 (8 10 12)))))
(pretty-print '(printf "constant tree: ~s~%" a))
(pretty-print '(printf "constant tree value: ~s~%" (tree-value a)))
(pretty-print '(printf "constant tree walk: ~s~%" (tree->list a))))
'replace)
(separate-compile
'(lambda (x)
(parameterize ([compile-imported-libraries #t]
[generate-wpo-files #t])
(compile-program x)))
"testfile-wpo-ab")
#t)
(file-exists? "testfile-wpo-a.wpo")
(file-exists? "testfile-wpo-b.wpo")
(file-exists? "testfile-wpo-ab.wpo")
(equal?
(separate-eval '(load-program "testfile-wpo-ab.so"))
"constant tree: #[tree #[tree #[tree #f 1 #f] 2 #[tree #f 4 #f]] 5 #[tree #[tree #f 8 #f] 10 #[tree #f 12 #f]]]\nconstant tree value: 5\nconstant tree walk: (1 2 4 5 8 10 12)\n")
(equal?
(separate-compile
'(lambda (x)
(compile-whole-program (format "~a.wpo" x) (format "~a-all.so" x)))
"testfile-wpo-ab")
"()\n")
(delete-file "testfile-wpo-a.so")
(delete-file "testfile-wpo-b.so")
(delete-file "testfile-wpo-ab.so")
(equal?
(separate-eval '(load-program "testfile-wpo-ab-all.so"))
"constant tree: #[tree #[tree #[tree #f 1 #f] 2 #[tree #f 4 #f]] 5 #[tree #[tree #f 8 #f] 10 #[tree #f 12 #f]]]\nconstant tree value: 5\nconstant tree walk: (1 2 4 5 8 10 12)\n")
(begin
(load-program "testfile-wpo-ab-all.so")
#t)
(not (memq '(testfile-wpo-a) (library-list)))
(not (memq '(testfile-wpo-b) (library-list)))
(begin
(with-output-to-file "testfile-wpo-lib.ss"
(lambda ()
(pretty-print
'(library (testfile-wpo-lib)
(export f)
(import (chezscheme))
(define (f n) (if (zero? n) 1 (* n (f (- n 1))))))))
'replace)
(separate-compile
'(lambda (x)
(parameterize ([generate-wpo-files #t])
(compile-library x)))
"testfile-wpo-lib")
(file-exists? "testfile-wpo-lib.wpo"))
(begin
(with-output-to-file "testfile-wpo-prog.ss"
(lambda ()
(pretty-print '(import (chezscheme)))
(pretty-print '(pretty-print (let () (import (testfile-wpo-lib)) (f 10))))
(pretty-print '(pretty-print ((top-level-value 'f (environment '(testfile-wpo-lib))) 10))))
'replace)
(separate-compile
'(lambda (x)
(parameterize ([generate-wpo-files #t])
(compile-program x)))
"testfile-wpo-prog")
(file-exists? "testfile-wpo-prog.wpo"))
(equal?
(separate-eval '(load-program "testfile-wpo-prog.so"))
"3628800\n3628800\n")
(equal?
(separate-compile
'(lambda (x)
(compile-whole-program (format "~a.wpo" x) (format "~a-all.so" x) #t))
"testfile-wpo-prog")
"()\n")
(equal?
(separate-compile
'(lambda (x)
(compile-whole-program (format "~a.wpo" x) (format "~a-none.so" x) #f))
"testfile-wpo-prog")
"()\n")
(delete-file "testfile-wpo-lib.ss")
(delete-file "testfile-wpo-lib.so")
(delete-file "testfile-wpo-lib.wpo")
(equal?
(separate-eval '(load-program "testfile-wpo-prog-all.so"))
"3628800\n3628800\n")
(error?
(separate-eval '(load-program "testfile-wpo-prog-none.so")))
(begin
(with-output-to-file "testfile-wpo-a3.ss"
(lambda ()
(pretty-print
'(library (testfile-wpo-a3)
(export ! z?)
(import (rnrs))
(define (z? n) (= n 0))
(define (! n) (if (z? n) 1 (* n (! (- n 1))))))))
'replace)
(with-output-to-file "testfile-wpo-b3.ss"
(lambda ()
(pretty-print
'(library (testfile-wpo-b3)
(export fib !)
(import (rnrs) (testfile-wpo-a3))
(define (fib n)
(cond
[(z? n) 1]
[(z? (- n 1)) 1]
[else (+ (fib (- n 1)) (fib (- n 2)))])))))
'replace)
(with-output-to-file "testfile-wpo-c3.ss"
(lambda ()
(pretty-print '(import (testfile-wpo-b3) (chezscheme)))
(pretty-print '(pretty-print
(list (fib 10) (! 10)
((top-level-value 'fib (environment '(testfile-wpo-b3))) 10)
((top-level-value '! (environment '(testfile-wpo-b3))) 10)
((top-level-value 'z? (environment '(testfile-wpo-a3))) 10)))))
'replace)
(separate-compile
'(lambda (x)
(parameterize ([compile-imported-libraries #t]
[generate-wpo-files #t])
(compile-program x)))
"testfile-wpo-c3")
#t)
(equal?
(separate-eval '(load-program "testfile-wpo-c3.so"))
"(89 3628800 89 3628800 #f)\n")
(equal?
(separate-compile
'(lambda (x)
(parameterize ([generate-wpo-files #t])
(compile-whole-program (format "~a.wpo" x) (format "~a-all.so" x) #t)))
"testfile-wpo-c3")
"()\n")
(delete-file "testfile-wpo-a3.ss")
(delete-file "testfile-wpo-a3.so")
(delete-file "testfile-wpo-a3.wpo")
(delete-file "testfile-wpo-b3.ss")
(delete-file "testfile-wpo-b3.so")
(delete-file "testfile-wpo-b3.wpo")
(equal?
(separate-eval '(load-program "testfile-wpo-c3-all.so"))
"(89 3628800 89 3628800 #f)\n")
(begin
(with-output-to-file "testfile-wpo-a4.ss"
(lambda ()
(pretty-print
'(library (testfile-wpo-a4)
(export !)
(import (chezscheme))
(define (! n) (if (= n 0) 1 (* n (! (- n 1))))))))
'replace)
(with-output-to-file "testfile-wpo-b4.ss"
(lambda ()
(pretty-print
'(library (testfile-wpo-b4)
(export fib)
(import (chezscheme))
(define (fib n) (if (or (= n 0) (= n 1)) 1 (+ (fib (- n 1)) (fib (- n 2))))))))
'replace)
(with-output-to-file "testfile-wpo-c4.ss"
(lambda ()
(pretty-print
'(library (testfile-wpo-c4)
(export !fib)
(import (chezscheme) (testfile-wpo-a4) (testfile-wpo-b4))
(define (!fib n) (! (fib n))))))
'replace)
(with-output-to-file "testfile-wpo-prog4.ss"
(lambda ()
(pretty-print '(import (chezscheme) (testfile-wpo-c4)))
(pretty-print '(pretty-print (!fib 5))))
'replace)
(separate-compile
'(lambda (x)
(parameterize ([compile-imported-libraries #t]
[generate-wpo-files #t])
(compile-program x)))
"testfile-wpo-prog4")
#t)
(delete-file "testfile-wpo-a4.wpo")
(equal?
(separate-compile
'(lambda (x)
(parameterize ([generate-wpo-files #t])
(compile-whole-program (format "~a.wpo" x) (format "~a-all.so" x) #t)))
'wpo-prog4)
"((testfile-wpo-a4))\n")
(begin
(rename-file "testfile-wpo-a4.ss" "testfile-wpo-a4.ss.spam")
(rename-file "testfile-wpo-b4.ss" "testfile-wpo-b4.ss.spam")
(rename-file "testfile-wpo-c4.ss" "testfile-wpo-c4.ss.spam")
(rename-file "testfile-wpo-prog4.ss" "testfile-wpo-prog4.ss.spam")
#t)
(delete-file "testfile-wpo-b4.so")
(delete-file "testfile-wpo-b4.wpo")
(delete-file "testfile-wpo-c4.so")
(delete-file "testfile-wpo-c4.wpo")
(delete-file "testfile-wpo-prog4.so")
(delete-file "testfile-wpo-prog4.wpo")
(equal?
(separate-eval '(load-program "testfile-wpo-prog4-all.so"))
"40320\n")
(delete-file "testfile-wpo-a4.so")
(error? ; library (testfile-wpo-a4) not found
(separate-eval '(load-program "testfile-wpo-prog4-all.so")))
(delete-file "testfile-wpo-prog4-all.so")
(begin
(rename-file "testfile-wpo-a4.ss.spam" "testfile-wpo-a4.ss")
(rename-file "testfile-wpo-b4.ss.spam" "testfile-wpo-b4.ss")
(rename-file "testfile-wpo-c4.ss.spam" "testfile-wpo-c4.ss")
(rename-file "testfile-wpo-prog4.ss.spam" "testfile-wpo-prog4.ss")
#t)
(begin
(separate-compile
'(lambda (x)
(parameterize ([compile-imported-libraries #t]
[generate-wpo-files #t])
(compile-program x)))
"testfile-wpo-prog4")
#t)
(delete-file "testfile-wpo-c4.wpo")
(equal?
(separate-compile
'(lambda (x)
(parameterize ([generate-wpo-files #t])
(compile-whole-program (format "~a.wpo" x) (format "~a-all.so" x) #t)))
'wpo-prog4)
"((testfile-wpo-c4))\n")
(delete-file "testfile-wpo-a4.ss")
(delete-file "testfile-wpo-b4.ss")
(delete-file "testfile-wpo-c4.ss")
(delete-file "testfile-wpo-prog4.ss")
(delete-file "testfile-wpo-a4.so")
(delete-file "testfile-wpo-a4.wpo")
(delete-file "testfile-wpo-b4.so")
(delete-file "testfile-wpo-b4.wpo")
(delete-file "testfile-wpo-prog4.so")
(delete-file "testfile-wpo-prog4.wpo")
(equal?
(separate-eval '(load-program "testfile-wpo-prog4-all.so"))
"40320\n")
(eqv?
(separate-eval
'(verify-loadability 'load "testfile-wpo-prog4-all.so"))
"")
(delete-file "testfile-wpo-c4.so")
(error? ; library (testfile-wpo-c4) not found
(separate-eval '(load-program "testfile-wpo-prog4-all.so")))
(begin
(with-output-to-file "testfile-wpo-a5.ss"
(lambda ()
(pretty-print
'(library (testfile-wpo-a5)
(export a)
(import (chezscheme))
(define a
(lambda (n)
(+ ((top-level-value 'c (environment '(testfile-wpo-c5)))) n))))))
'replace)
(with-output-to-file "testfile-wpo-b5.ss"
(lambda ()
(pretty-print
'(library (testfile-wpo-b5)
(export b)
(import (chezscheme) (testfile-wpo-a5))
(define b (a 10)))))
'replace)
(with-output-to-file "testfile-wpo-c5.ss"
(lambda ()
(pretty-print
'(library (testfile-wpo-c5)
(export c)
(import (chezscheme) (testfile-wpo-a5) (testfile-wpo-b5))
(define c (lambda () (+ (a 10) b))))))
'replace)
(with-output-to-file "testfile-wpo-prog5.ss"
(lambda ()
(pretty-print '(import (chezscheme) (testfile-wpo-b5) (testfile-wpo-c5)))
(pretty-print '(pretty-print (cons (b) c))))
'replace)
(separate-compile
'(lambda (x)
(parameterize ([compile-imported-libraries #t]
[generate-wpo-files #t])
(compile-program x)))
"testfile-wpo-prog5")
#t)
(equal?
(separate-compile
'(lambda (x)
(parameterize ([generate-wpo-files #t])
(compile-whole-program (format "~a.wpo" x) (format "~a-all.so" x) #t)))
'wpo-prog5)
"()\n")
(error? ; attempt to invoke library (testfile-wpo-c5) while it is still being loaded
(separate-eval '(load-program "testfile-wpo-prog5-all.so")))
(begin
(with-output-to-file "testfile-wpo-a6.ss"
(lambda ()
(pretty-print
'(library (testfile-wpo-a6)
(export x a)
(import (rnrs))
(define x 3)
(define z 17)
(define-syntax a (identifier-syntax z))
(display "invoke a\n"))))
'replace)
(with-output-to-file "testfile-wpo-b6.ss"
(lambda ()
(pretty-print
'(library (testfile-wpo-b6)
(export y)
(import (rnrs) (testfile-wpo-a6))
(define counter 9)
(define (y) (set! counter (+ counter 5)) (list x counter a))
(display "invoke b\n"))))
'replace)
(with-output-to-file "testfile-wpo-prog6.ss"
(lambda ()
(pretty-print '(import (testfile-wpo-b6) (rnrs) (only (chezscheme) printf)))
(pretty-print '(printf "==== ~s ====" (y)))
(pretty-print '(printf "==== ~s ====" (y))))
'replace)
(separate-compile
'(lambda (x)
(parameterize ([compile-imported-libraries #t]
[generate-wpo-files #t])
(compile-program x)))
'wpo-prog6)
#t)
(equal?
(separate-eval '(load-program "testfile-wpo-prog6.so"))
"invoke a\ninvoke b\n==== (3 14 17) ======== (3 19 17) ====")
(equal?
(separate-compile
'(lambda (x)
(parameterize ([generate-wpo-files #t])
(compile-whole-program (format "~a.wpo" x) (format "~a-all.so" x))))
'wpo-prog6)
"()\n")
(delete-file "testfile-wpo-a6.ss")
(delete-file "testfile-wpo-a6.so")
(delete-file "testfile-wpo-a6.wpo")
(delete-file "testfile-wpo-b6.ss")
(delete-file "testfile-wpo-b6.so")
(delete-file "testfile-wpo-b6.wpo")
(equal?
(separate-eval '(load-program "testfile-wpo-prog6-all.so"))
"invoke a\ninvoke b\n==== (3 14 17) ======== (3 19 17) ====")
(eqv?
(separate-eval
'(verify-loadability 'load "testfile-wpo-prog6-all.so"))
"")
(begin
(with-output-to-file "testfile-wpo-aa7.ss"
(lambda ()
(pretty-print
'(library (testfile-wpo-aa7)
(export ax)
(import (chezscheme))
(define ax (gensym))
(printf "invoking aa\n"))))
'replace)
(with-output-to-file "testfile-wpo-a7.ss"
(lambda ()
(pretty-print
'(library (testfile-wpo-a7)
(export x)
(import (chezscheme) (testfile-wpo-aa7))
(define x (cons ax (gensym)))
(printf "invoking a\n"))))
'replace)
(with-output-to-file "testfile-wpo-b7.ss"
(lambda ()
(pretty-print
'(library (testfile-wpo-b7)
(export z)
(import (chezscheme) (testfile-wpo-c7))
(define z (cons 'b y))
(printf "invoking b\n"))))
'replace)
(with-output-to-file "testfile-wpo-c7.ss"
(lambda ()
(pretty-print
'(library (testfile-wpo-c7)
(export y)
(import (chezscheme) (testfile-wpo-a7))
(define y (cons 'c x))
(printf "invoking c\n"))))
'replace)
(with-output-to-file "testfile-wpo-ab7.ss"
(lambda ()
(for-each pretty-print
'((import (chezscheme) (testfile-wpo-c7) (testfile-wpo-a7) (testfile-wpo-b7))
(pretty-print (eq? (cdr y) x))
(pretty-print (eq? (cdr z) y))
(pretty-print (and (eq? (car y) 'c) (eq? (car z) 'b))))))
'replace)
(separate-compile
'(lambda (x)
(parameterize ([compile-imported-libraries #t]
[generate-wpo-files #t])
(compile-program x)))
'wpo-ab7)
#t)
(equal?
(separate-eval '(load "testfile-wpo-ab7.so"))
"invoking aa\ninvoking a\ninvoking c\ninvoking b\n#t\n#t\n#t\n")
(delete-file "testfile-wpo-c7.ss")
(delete-file "testfile-wpo-c7.wpo")
(equal?
(separate-compile
'(lambda (x)
(parameterize ([generate-wpo-files #t])
(compile-whole-program (format "~a.wpo" x) (format "~a-all.so" x))))
'wpo-ab7)
"((testfile-wpo-c7))\n")
(equal?
(separate-eval '(load "testfile-wpo-ab7-all.so"))
"invoking aa\ninvoking a\ninvoking c\ninvoking b\n#t\n#t\n#t\n")
(begin
(with-output-to-file "testfile-wpo-extlib.chezscheme.sls"
(lambda ()
(pretty-print
'(library (testfile-wpo-extlib)
(export magic)
(import (rnrs))
(define magic (cons 9 5)))))
'replace)
(with-output-to-file "testfile-wpo-ext.ss"
(lambda ()
(pretty-print '(import (chezscheme) (testfile-wpo-extlib)))
(pretty-print '(pretty-print magic)))
'replace)
(separate-compile
'(lambda (x)
(parameterize ([compile-imported-libraries #t]
[generate-wpo-files #t])
(compile-program x)))
'wpo-ext)
#t)
(equal?
(separate-compile
'(lambda (x)
(parameterize ([generate-wpo-files #t])
(compile-whole-program (format "~a.wpo" x) (format "~a-all.so" x))))
'wpo-ext)
"()\n")
(equal?
(separate-eval '(load "testfile-wpo-ext-all.so"))
"(9 . 5)\n")
; test propagation of #! shell-script line
(begin
(define $hash-bang-line "#! /usr/bin/scheme --program\n")
(delete-file "testfile-wpo-c8.so")
(delete-file "testfile-wpo-c8-all.so")
(delete-file "testfile-wpo-c8.wpo")
(with-output-to-file "testfile-wpo-c8.ss"
(lambda ()
(display-string $hash-bang-line)
(for-each pretty-print
'((import (chezscheme))
(printf "hello\n"))))
'replace)
(separate-compile
'(lambda (x)
(parameterize ([generate-wpo-files #t])
(compile-program x)))
'wpo-c8)
(separate-compile
'(lambda (x)
(compile-whole-program (format "~a.wpo" x) (format "~a-all.so" x)))
'wpo-c8)
#t)
(equal?
(separate-eval '(load "testfile-wpo-c8.so"))
"hello\n")
(equal?
(separate-eval '(load "testfile-wpo-c8-all.so"))
"hello\n")
(equal?
(call-with-port (open-file-input-port "testfile-wpo-c8-all.so")
(lambda (ip)
(get-bytevector-n ip (string-length $hash-bang-line))))
(string->utf8 $hash-bang-line))
(eqv?
(separate-eval
'(verify-loadability 'load "testfile-wpo-c8-all.so"))
"")
(begin
(mkfile "testfile-wpo-a9.ss"
'(library (testfile-wpo-a9)
(export x)
(import (chezscheme))
(define x (eval 'x (environment '(testfile-wpo-a9))))))
(mkfile "testfile-wpo-b9.ss"
'(import (chezscheme) (testfile-wpo-a9))
'(printf "x = ~s\n" x))
(separate-compile
'(lambda (x)
(parameterize ([generate-wpo-files #t] [compile-imported-libraries #t])
(compile-program x)))
'wpo-b9)
(separate-compile
'(lambda (x)
(compile-whole-program (format "~a.wpo" x) (format "~a-all.so" x) #t))
'wpo-b9)
(separate-compile
'(lambda (x)
(compile-whole-library (format "~a.wpo" x) (format "~a-all.so" x)))
'wpo-a9)
#t)
(error? ; invoke cycle
(separate-eval
'(load-library "testfile-wpo-a9.so")
'(let () (import (testfile-wpo-a9)) x)))
(error? ; invoke cycle
(separate-eval
'(load-library "testfile-wpo-a9-all.so")
'(let () (import (testfile-wpo-a9)) x)))
(error? ; invoke cycle
(separate-eval
'(load-program "testfile-wpo-b9.so")))
(error? ; invoke cycle
(separate-eval
'(load-program "testfile-wpo-b9-all.so")))
(begin
(mkfile "testfile-wpo-a10.ss"
'(library (testfile-wpo-a10)
(export ax)
(import (chezscheme))
(define ax (cons 'a '()))))
(mkfile "testfile-wpo-b10.ss"
'(library (testfile-wpo-b10)
(export bx)
(import (chezscheme) (testfile-wpo-a10))
(define bx (cons 'b ax))))
(mkfile "testfile-wpo-c10.ss"
'(library (testfile-wpo-c10)
(export cx)
(import (chezscheme) (testfile-wpo-b10))
(define cx (cons 'c bx))))
(mkfile "testfile-wpo-d10.ss"
'(import (chezscheme) (testfile-wpo-c10))
'(printf "d: cx = ~s\n" cx))
(mkfile "testfile-wpo-e10.ss"
'(import (chezscheme) (testfile-wpo-a10))
'(printf "e: ax = ~s\n" ax))
(mkfile "testfile-wpo-f10.ss"
'(import (chezscheme) (testfile-wpo-c10))
'(printf "f: cx = ~s\n" cx))
(separate-compile
'(lambda (x)
(parameterize ([generate-wpo-files #t]
[compile-imported-libraries #t])
(compile-program x)))
'wpo-d10)
(separate-compile 'compile-program 'wpo-e10)
(separate-compile 'compile-program 'wpo-f10)
#t)
; cause b10 to be excluded from the whole program
(delete-file "testfile-wpo-b10.wpo")
(equal?
(separate-eval
'(compile-whole-program "testfile-wpo-d10.wpo"
"testfile-wpo-d10-all.so" #f))
"((testfile-wpo-b10))\n")
(equal?
(separate-eval '(verify-loadability 'visit "testfile-wpo-d10-all.so"))
"")
(equal?
(separate-eval '(verify-loadability 'revisit "testfile-wpo-d10-all.so"))
"")
(equal?
(separate-eval '(verify-loadability 'load "testfile-wpo-d10-all.so"))
"")
(equal?
(separate-eval '(load-program "testfile-wpo-d10-all.so"))
"d: cx = (c b a)\n")
; library a10 must be visible for (excluded library)
; b10's benefit, so e10 can reference its export
(equal?
(separate-eval
'(load-program "testfile-wpo-d10-all.so")
'(load-program "testfile-wpo-e10.so"))
"d: cx = (c b a)\ne: ax = (a)\n")
; library c10 need not and should not be visible, so f10
; shouldn't be able to reference its export.
(error?
(separate-eval
'(load-program "testfile-wpo-d10-all.so")
'(load-program "testfile-wpo-f10.so")))
(error? ; testfile-wpo-c10 is not visible
(separate-eval
'(load-program "testfile-wpo-d10-all.so")
'(import (testfile-wpo-c10))))
(equal?
(separate-eval
'(load-program "testfile-wpo-d10-all.so")
'(verify-loadability 'visit "testfile-wpo-f10.so"))
"d: cx = (c b a)\n")
; verify-loadability should error out trying to invoke
; c10 because c10 is not visible
(error? ; not visible
(separate-eval
'(load-program "testfile-wpo-d10-all.so")
'(verify-loadability 'revisit "testfile-wpo-f10.so")))
(error? ; not visible
(separate-eval
'(load-program "testfile-wpo-d10-all.so")
'(verify-loadability 'load "testfile-wpo-f10.so")))
(begin
(mkfile "testfile-wpo-a11.ss"
'(library (testfile-wpo-a11)
(export ax)
(import (chezscheme))
(define ax (cons 'a '()))
(printf "invoking a\n")))
(parameterize ([generate-wpo-files #t])
(compile-library "testfile-wpo-a11"))
#t)
(equal?
(compile-whole-library "testfile-wpo-a11.wpo" "testfile-wpo-a11-all.so")
'())
(equal?
(separate-eval
'(load-library "testfile-wpo-a11.so"))
"")
(equal?
(separate-eval
'(load-library "testfile-wpo-a11.so")
'(let () (import (testfile-wpo-a11)) ax))
"invoking a\n(a)\n")
(equal?
(separate-eval
'(load-library "testfile-wpo-a11-all.so"))
"")
(equal?
(separate-eval
'(load-library "testfile-wpo-a11-all.so")
'(let () (import (testfile-wpo-a11)) ax))
"invoking a\n(a)\n")
(begin
(mkfile "testfile-wpo-a12.ss"
'(library (testfile-wpo-a12)
(export ax)
(import (chezscheme))
(define ax (cons 'a '()))))
(mkfile "testfile-wpo-b12.ss"
'(library (testfile-wpo-b12)
(export bx)
(import (chezscheme) (testfile-wpo-a12))
(define bx (eval 'cx (environment '(testfile-wpo-c12))))))
(mkfile "testfile-wpo-c12.ss"
'(library (testfile-wpo-c12)
(export cx)
(import (chezscheme) (testfile-wpo-b12))
(define cx (cons 'c bx))))
(mkfile "testfile-wpo-d12.ss"
'(import (chezscheme) (testfile-wpo-c12))
'(printf "d: cx = ~s\n" cx))
(parameterize ([generate-wpo-files #t]
[compile-imported-libraries #t])
(compile-program "testfile-wpo-d12"))
#t)
(error? ; cyclc
(separate-eval '(load-program "testfile-wpo-d12.so")))
; cause b12 to be excluded from the whole library and program
(delete-file "testfile-wpo-b12.wpo")
(equal?
(separate-eval
'(compile-whole-library "testfile-wpo-c12.wpo"
"testfile-wpo-c12-all.so"))
"((testfile-wpo-b12))\n")
(equal?
(separate-eval
'(compile-whole-program "testfile-wpo-d12.wpo"
"testfile-wpo-d12-all.so" #t))
"((testfile-wpo-b12))\n")
(equal?
(separate-eval
'(load-library "testfile-wpo-c12-all.so"))
"")
(error? ; cycle
(separate-eval
'(load-library "testfile-wpo-c12-all.so")
'(let () (import (testfile-wpo-c12)) cx)))
(error? ; cycle
(separate-eval '(load-program "testfile-wpo-d12-all.so")))
; verify-loadability doesn't catch (dynamic) cycles
(equal?
(separate-eval
'(verify-loadability 'visit "testfile-wpo-c12.so"))
"")
(equal?
(separate-eval
'(verify-loadability 'revisit "testfile-wpo-c12.so"))
"")
(equal?
(separate-eval
'(verify-loadability 'load "testfile-wpo-c12.so"))
"")
; verify-loadability doesn't catch (dynamic) cycles
(equal?
(separate-eval
'(verify-loadability 'visit "testfile-wpo-d12.so"))
"")
(equal?
(separate-eval
'(verify-loadability 'revisit "testfile-wpo-d12.so"))
"")
(equal?
(separate-eval
'(verify-loadability 'load "testfile-wpo-d12.so"))
"")
)
(mat compile-whole-library
(begin
(with-output-to-file "testfile-cwl-a1.ss"
(lambda ()
(pretty-print
'(library (testfile-cwl-a1)
(export x a)
(import (rnrs))
(define x 3)
(define z 17)
(define-syntax a (identifier-syntax z))
(display "invoke a\n"))))
'replace)
(with-output-to-file "testfile-cwl-b1.ss"
(lambda ()
(pretty-print
'(library (testfile-cwl-b1)
(export y)
(import (rnrs) (testfile-cwl-a1))
(define counter 9)
(define (y) (set! counter (+ counter 5)) (list x counter a))
(display "invoke b\n"))))
'replace)
(separate-compile
'(lambda (x)
(parameterize ([compile-imported-libraries #t]
[generate-wpo-files #t])
(compile-library x)))
"testfile-cwl-b1")
#t)
(equal?
(separate-compile
'(lambda (x)
(parameterize ([generate-wpo-files #t])
(compile-whole-library (format "~a.wpo" x) (format "~a.so" x))))
'cwl-b1)
"()\n")
(begin
(rename-file "testfile-cwl-a1.ss" "testfile-cwl-a1.ss.spam")
#t)
(delete-file "testfile-cwl-a1.so")
(delete-file "testfile-cwl-a1.wpo")
(equal?
(separate-eval
'(let ()
(import (testfile-cwl-b1))
(printf ">~s\n" (y))
(printf ">~s\n" (y))))
"invoke a\ninvoke b\n>(3 14 17)\n>(3 19 17)\n")
(eqv?
(separate-eval
'(verify-loadability 'load "testfile-cwl-b1.so"))
"")
(error? ; library (testfile-cwl-a1) not found
(separate-eval
'(begin
(import (testfile-cwl-a1))
(import (testfile-cwl-b1)))))
(equal?
(separate-eval
'(let ()
(import (testfile-cwl-b1))
(import (testfile-cwl-a1))
(printf ">~s\n" (y))
(printf ">~s\n" (list a x))))
"invoke a\ninvoke b\n>(3 14 17)\n>(17 3)\n")
(begin
(rename-file "testfile-cwl-a1.ss.spam" "testfile-cwl-a1.ss")
(with-output-to-file "testfile-cwl-d1.ss"
(lambda ()
(pretty-print
'(library (testfile-cwl-d1)
(export z)
(import (rnrs) (testfile-cwl-a1))
(define counter 7)
(define (z) (set! counter (+ counter 5)) (list x counter a))
(display "invoke d\n"))))
'replace)
#t)
(equal?
(separate-compile
'(lambda (x)
(parameterize ([compile-imported-libraries #t]
[generate-wpo-files #t])
(compile-library x)))
'cwl-d1)
"compiling testfile-cwl-d1.ss with output to testfile-cwl-d1.so\ncompiling testfile-cwl-a1.ss with output to testfile-cwl-a1.so\n")
(begin
(with-output-to-file "testfile-cwl-a2.ss"
(lambda ()
(pretty-print
'(library (testfile-cwl-a2)
(export f)
(import (chezscheme))
(define (f n) (if (zero? n) 1 (* n (f (- n 1))))))))
'replace)
(separate-compile
'(lambda (x)
(parameterize ([generate-wpo-files #t])
(compile-library x)))
'cwl-a2)
(file-exists? "testfile-cwl-a2.wpo"))
(begin
(with-output-to-file "testfile-cwl-b2.ss"
(lambda ()
(pretty-print
'(library (testfile-cwl-b2)
(export main)
(import (chezscheme))
(define (main)
(import (testfile-cwl-a2))
((top-level-value 'f (environment '(testfile-cwl-a2))) 10)))))
'replace)
(separate-compile
'(lambda (x)
(parameterize ([generate-wpo-files #t])
(compile-library x)))
"testfile-cwl-b2")
(file-exists? "testfile-cwl-b2.wpo"))
(equal?
(separate-eval
'(let ()
(import (testfile-cwl-b2))
(main)))
"3628800\n")
(eqv?
(separate-eval
'(verify-loadability 'load "testfile-cwl-b2.so"))
"")
(equal?
(separate-compile
'(lambda (x)
(compile-whole-library (format "~a.wpo" x) (format "~a.so" x)))
"testfile-cwl-b2")
"()\n")
(delete-file "testfile-cwl-a2.ss")
(delete-file "testfile-cwl-a2.so")
(equal?
(separate-eval
'(let ()
(import (testfile-cwl-b2))
(main)))
"3628800\n")
(begin
(with-output-to-file "testfile-cwl-c1.ss"
(lambda ()
(pretty-print
'(library (testfile-cwl-c1)
(export main)
(import (chezscheme))
(define (main)
(import (testfile-cwl-b1))
(printf ">~s\n" ((top-level-value 'y (environment '(testfile-cwl-b1)))))
(printf ">~s\n" ((top-level-value 'y (environment '(testfile-cwl-b1)))))))))
'replace)
(separate-compile
'(lambda (x)
(parameterize ([generate-wpo-files #t])
(compile-library x)))
"testfile-cwl-c1")
#t)
(equal?
(separate-eval
'(let ()
(import (testfile-cwl-c1))
(main)))
"invoke a\ninvoke b\n>(3 14 17)\n>(3 19 17)\n")
(equal?
(separate-compile
'(lambda (x)
(compile-whole-library (format "~a.wpo" x) (format "~a.so" x)))
"testfile-cwl-c1")
"()\n")
(delete-file "testfile-cwl-a1.so")
(delete-file "testfile-cwl-a1.ss")
(delete-file "testfile-cwl-b1.so")
(delete-file "testfile-cwl-b1.ss")
(equal?
(separate-eval
'(let ()
(import (testfile-cwl-c1))
(main)))
"invoke a\ninvoke b\n>(3 14 17)\n>(3 19 17)\n")
(begin
(with-output-to-file "testfile-cwl-a3.ss"
(lambda ()
(pretty-print
'(library (testfile-cwl-a3)
(export ! z?)
(import (rnrs))
(define (z? n) (= n 0))
(define (! n) (if (z? n) 1 (* n (! (- n 1))))))))
'replace)
(with-output-to-file "testfile-cwl-b3.ss"
(lambda ()
(pretty-print
'(library (testfile-cwl-b3)
(export fib !)
(import (rnrs) (testfile-cwl-a3))
(define (fib n)
(cond
[(z? n) 1]
[(z? (- n 1)) 1]
[else (+ (fib (- n 1)) (fib (- n 2)))])))))
'replace)
(separate-compile
'(lambda (x)
(parameterize ([compile-imported-libraries #t]
[generate-wpo-files #t])
(compile-library x)))
"testfile-cwl-b3")
#t)
(equal?
(separate-eval
'(let ()
(import (testfile-cwl-b3))
(import (testfile-cwl-a3))
(pretty-print (list (! 10) (fib 10) (z? 10)))))
"(3628800 89 #f)\n")
(equal?
(separate-compile
'(lambda (x)
(parameterize ([generate-wpo-files #t])
(compile-whole-library (format "~a.wpo" x) (format "~a.so" x))))
"testfile-cwl-b3")
"()\n")
(delete-file "testfile-cwl-a3.so")
(delete-file "testfile-cwl-a3.wpo")
(equal?
(separate-eval
'(let ()
(import (testfile-cwl-b3))
(import (testfile-cwl-a3))
(pretty-print (list (! 10) (fib 10) (z? 10)))))
"(3628800 89 #f)\n")
(begin
(with-output-to-file "testfile-cwl-x4.ss"
(lambda ()
(pretty-print
'(library (testfile-cwl-x4)
(export ack)
(import (rnrs))
(define (ack m n)
(if (= m 0)
(+ n 1)
(if (= n 0)
(ack (- m 1) 1)
(ack (- m 1) (ack m (- n 1)))))))))
'replace)
(with-output-to-file "testfile-cwl-y4.ss"
(lambda ()
(pretty-print
'(library (testfile-cwl-y4)
(export fact)
(import (rnrs))
(define (fact n) (if (= n 0) 1 (* n (fact (- n 1))))))))
'replace)
(with-output-to-file "testfile-cwl-z4.ss"
(lambda ()
(pretty-print
'(library (testfile-cwl-z4)
(export fib)
(import (rnrs))
(define (fib n)
(cond
[(= n 0) 1]
[(= n 1) 1]
[else (+ (fib (- n 1)) (fib (- n 2)))])))))
'replace)
(with-output-to-file "testfile-cwl-w4.ss"
(lambda ()
(pretty-print
'(library (testfile-cwl-w4)
(export mult)
(import (rnrs))
(define (mult n m) (if (= n 1) m (+ m (mult (- n 1) m)))))))
'replace)
(with-output-to-file "testfile-cwl-a4.ss"
(lambda ()
(pretty-print
'(library (testfile-cwl-a4)
(export a-stuff)
(import (rnrs) (testfile-cwl-x4) (testfile-cwl-y4) (testfile-cwl-z4) (testfile-cwl-b4) (testfile-cwl-c4))
(define (a-stuff) (list (ack 3 4) (fib 5) (fact 10))))))
'replace)
(with-output-to-file "testfile-cwl-b4.ss"
(lambda ()
(pretty-print
'(library (testfile-cwl-b4)
(export b-stuff)
(import (rnrs) (testfile-cwl-x4) (testfile-cwl-w4))
(define (b-stuff) (mult 3 (ack 3 4))))))
'replace)
(with-output-to-file "testfile-cwl-c4.ss"
(lambda ()
(pretty-print
'(library (testfile-cwl-c4)
(export c-stuff)
(import (rnrs) (testfile-cwl-y4) (testfile-cwl-w4))
(define (c-stuff) (mult 5 (fact 10))))))
'replace)
#t)
(begin
(define (separate-compile-cwl4)
(separate-compile
'(lambda (x)
(parameterize ([compile-imported-libraries #t]
[generate-wpo-files #t])
(compile-library x)))
"testfile-cwl-b4")
(separate-compile
'(lambda (x)
(parameterize ([compile-imported-libraries #t]
[generate-wpo-files #t])
(compile-library x)))
"testfile-cwl-c4")
(separate-compile
'(lambda (x)
(parameterize ([compile-imported-libraries #t]
[generate-wpo-files #t])
(compile-library x)))
"testfile-cwl-a4")
(andmap
(lambda (n)
(and (file-exists? (format "testfile-cwl-~s4.wpo" n))
(file-exists? (format "testfile-cwl-~s4.so" n))))
'(a b c x y z w)))
#t)
(begin
(define (clear-cwl4-output)
(andmap
(lambda (n)
(and (delete (format "testfile-cwl-~s4.wpo" n))
(delete (format "testfile-cwl-~s4.so" n))))
'(a b c x y z w)))
#t)
(separate-compile-cwl4)
(equal?
(separate-eval
'(let ()
(import (testfile-cwl-a4))
(import (testfile-cwl-b4) (testfile-cwl-c4))
(pretty-print (a-stuff))
(pretty-print (b-stuff))
(pretty-print (c-stuff))))
"(125 8 3628800)\n375\n18144000\n")
(equal?
(separate-compile
'(lambda (x)
(parameterize ([generate-wpo-files #t])
(compile-whole-library (format "~a.wpo" x) (format "~a.so" x))))
"testfile-cwl-a4")
"()\n")
(andmap
(lambda (name)
(andmap
(lambda (ext)
(delete-file (format "testfile-cwl-~s4.~s" name ext)))
'(so ss wpo)))
'(b c x y z w))
(equal?
(separate-eval
'(let ()
(import (testfile-cwl-a4))
(import (testfile-cwl-b4) (testfile-cwl-c4))
(pretty-print (a-stuff))
(pretty-print (b-stuff))
(pretty-print (c-stuff))))
"(125 8 3628800)\n375\n18144000\n")
(begin
(with-output-to-file "testfile-cwl-a5.ss"
(lambda ()
(pretty-print
'(library (testfile-cwl-a5)
(export fact)
(import (rnrs))
(define (fact n) (if (= n 0) 1 (* n (fact (- n 1))))))))
'replace)
(with-output-to-file "testfile-cwl-b5.ss"
(lambda ()
(pretty-print
'(library (testfile-cwl-b5)
(export fib+fact)
(import (rnrs) (testfile-cwl-a5))
(define (fib n) (if (or (= n 0) (= n 1)) 1 (+ (fib (- n 1)) (fib (- n 2)))))
(define (fib+fact n) (+ (fib n) (fact n))))))
'replace)
(with-output-to-file "testfile-cwl-c5.ss"
(lambda ()
(pretty-print
`(library (testfile-cwl-c5)
(export ack+fact)
(import (rnrs) (testfile-cwl-a5))
(define (ack m n)
(cond
[(= m 0) (+ n 1)]
[(= n 0) (ack (- m 1) 1)]
[else (ack (- m 1) (ack m (- n 1)))]))
(define (ack+fact m n) (+ (ack m n) (fact m) (fact n))))))
'replace)
(separate-compile
'(lambda (x)
(parameterize ([compile-imported-libraries #t]
[generate-wpo-files #t])
(for-each compile-library x)))
'(quote ("testfile-cwl-b5" "testfile-cwl-c5")))
#t)
(equal?
(separate-compile
'(lambda (x)
(parameterize ([generate-wpo-files #t])
(compile-whole-library (format "~a.wpo" x) (format "~a.so" x))))
"testfile-cwl-b5")
"()\n")
(delete-file "testfile-cwl-a5.ss")
(delete-file "testfile-cwl-a5.so")
(delete-file "testfile-cwl-a5.wpo")
(equal?
(separate-eval
'(let ()
(import (testfile-cwl-b5))
(import (testfile-cwl-c5))
(list (fib+fact 10) (ack+fact 3 4))))
"(3628889 155)\n")
(begin
(with-output-to-file "testfile-cwl-a5.ss"
(lambda ()
(pretty-print
'(library (testfile-cwl-a5)
(export fact)
(import (rnrs))
(define (fact n) (if (= n 0) 1 (* n (fact (- n 1))))))))
'replace)
(separate-compile
'(lambda (x)
(parameterize ([compile-imported-libraries #t]
[generate-wpo-files #t])
(for-each compile-library x)))
'(quote ("testfile-cwl-b5" "testfile-cwl-c5")))
#t)
(equal?
(separate-compile
'(lambda (x)
(parameterize ([generate-wpo-files #t])
(compile-whole-library (format "~a.wpo" x) (format "~a.so" x))))
"testfile-cwl-b5")
"()\n")
(error? ; attempting to re-install compile-time (or run-time) part of library (testfile-cwl-a5)
(separate-eval
'(let ()
(import (testfile-cwl-c5))
(import (testfile-cwl-b5))
(list (fib+fact 10) (ack+fact 3 4)))))
(error? ; attempting to re-install compile-time (or run-time) part of library (testfile-cwl-a5)
(separate-eval
'(eval '(list (fib+fact 10) (ack+fact 3 4))
(environment '(chezscheme) '(testfile-cwl-c5) '(testfile-cwl-b5)))))
(equal?
(separate-eval
'(eval '(list (fib+fact 10) (ack+fact 3 4))
(environment '(chezscheme) '(testfile-cwl-b5) '(testfile-cwl-c5))))
"(3628889 155)\n")
(begin
(with-output-to-file "testfile-cwl-d5.ss"
(lambda ()
(pretty-print
'(eval '(list (fib+fact 10) (ack+fact 3 4))
(environment '(chezscheme) '(testfile-cwl-c5) '(testfile-cwl-b5)))))
'replace)
(separate-compile 'cwl-d5)
#t)
(error? ; attempting to re-install compile-time (or run-time) part of library (testfile-cwl-a5)
(separate-eval '(load "testfile-cwl-d5.so")))
(begin
(with-output-to-file "testfile-cwl-d5.ss"
(lambda ()
(pretty-print
'(eval '(list (fib+fact 10) (ack+fact 3 4))
(environment '(chezscheme) '(testfile-cwl-b5) '(testfile-cwl-c5)))))
'replace)
(separate-compile 'cwl-d5)
#t)
(equal?
(separate-compile
'(lambda (x)
(parameterize ([generate-wpo-files #t])
(compile-whole-library (format "~a.wpo" x) (format "~a.so" x))))
"testfile-cwl-c5")
"()\n")
(delete-file "testfile-cwl-a5.ss")
(delete-file "testfile-cwl-a5.so")
(delete-file "testfile-cwl-a5.wpo")
(error? ; attempting to re-install compile-time (or run-time) part of library (testfile-cwl-a5)
(separate-eval
'(let ()
(import (testfile-cwl-c5))
(import (testfile-cwl-b5))
(list (fib+fact 10) (ack+fact 3 4)))))
(error? ; attempting to re-install compile-time (or run-time) part of library (testfile-cwl-a5)
(separate-eval
'(let ()
(import (testfile-cwl-b5))
(import (testfile-cwl-c5))
(list (fib+fact 10) (ack+fact 3 4)))))
(begin
(with-output-to-file "testfile-cwl-a6.ss"
(lambda ()
(pretty-print
'(library (testfile-cwl-a6)
(export !)
(import (chezscheme))
(define (! n) (if (= n 0) 1 (* n (! (- n 1))))))))
'replace)
(with-output-to-file "testfile-cwl-b6.ss"
(lambda ()
(pretty-print
'(library (testfile-cwl-b6)
(export fib)
(import (chezscheme))
(define (fib n) (if (or (= n 0) (= n 1)) 1 (+ (fib (- n 1)) (fib (- n 2))))))))
'replace)
(with-output-to-file "testfile-cwl-c6.ss"
(lambda ()
(pretty-print
'(library (testfile-cwl-c6)
(export !fib)
(import (chezscheme) (testfile-cwl-a6) (testfile-cwl-b6))
(define (!fib n) (! (fib n))))))
'replace)
(with-output-to-file "testfile-cwl-d6.ss"
(lambda ()
(pretty-print
'(library (testfile-cwl-d6)
(export runit)
(import (chezscheme) (testfile-cwl-c6))
(define (runit) (pretty-print (!fib 5)))
(display "invoking d6\n"))))
'replace)
(separate-compile
'(lambda (x)
(parameterize ([compile-imported-libraries #t]
[generate-wpo-files #t])
(compile-library x)))
"testfile-cwl-d6")
#t)
(delete-file "testfile-cwl-a6.wpo")
(equal?
(separate-compile
'(lambda (x)
(parameterize ([generate-wpo-files #t])
(compile-whole-library (format "~a.wpo" x) (format "~a.so" x))))
'cwl-d6)
"((testfile-cwl-a6))\n")
(begin
(rename-file "testfile-cwl-a6.ss" "testfile-cwl-a6.ss.spam")
(rename-file "testfile-cwl-b6.ss" "testfile-cwl-b6.ss.spam")
(rename-file "testfile-cwl-c6.ss" "testfile-cwl-c6.ss.spam")
(rename-file "testfile-cwl-d6.ss" "testfile-cwl-d6.ss.spam")
#t)
(delete-file "testfile-cwl-b6.so")
(delete-file "testfile-cwl-b6.wpo")
(delete-file "testfile-cwl-c6.so")
(delete-file "testfile-cwl-c6.wpo")
(delete-file "testfile-cwl-d6.wpo")
(equal?
(separate-eval '(begin (import (testfile-cwl-d6)) (runit)))
"invoking d6\n40320\n")
(delete-file "testfile-cwl-a6.so")
(error? ; cannot find a6
(separate-eval '(begin (import (testfile-cwl-d6)) (runit))))
(delete-file "testfile-cwl-d6.so")
(begin
(rename-file "testfile-cwl-a6.ss.spam" "testfile-cwl-a6.ss")
(rename-file "testfile-cwl-b6.ss.spam" "testfile-cwl-b6.ss")
(rename-file "testfile-cwl-c6.ss.spam" "testfile-cwl-c6.ss")
(rename-file "testfile-cwl-d6.ss.spam" "testfile-cwl-d6.ss")
#t)
(begin
(separate-compile
'(lambda (x)
(parameterize ([compile-imported-libraries #t]
[generate-wpo-files #t])
(compile-library x)))
"testfile-cwl-d6")
#t)
(delete-file "testfile-cwl-c6.wpo")
(equal?
(separate-compile
'(lambda (x)
(parameterize ([generate-wpo-files #t])
(compile-whole-library (format "~a.wpo" x) (format "~a.so" x))))
'cwl-d6)
"((testfile-cwl-c6))\n")
(delete-file "testfile-cwl-a6.so")
(delete-file "testfile-cwl-a6.wpo")
(delete-file "testfile-cwl-b6.so")
(delete-file "testfile-cwl-b6.wpo")
(delete-file "testfile-cwl-d6.wpo")
(delete-file "testfile-cwl-a6.ss")
(delete-file "testfile-cwl-b6.ss")
(delete-file "testfile-cwl-c6.ss")
(delete-file "testfile-cwl-d6.ss")
(equal?
(separate-eval '(begin (import (testfile-cwl-d6)) (runit)))
"invoking d6\n40320\n")
(delete-file "testfile-cwl-c6.so")
(error? ; cannot find c6
(separate-eval '(begin (import (testfile-cwl-d6)) (runit))))
(begin
(with-output-to-file "testfile-cwl-a7.ss"
(lambda ()
(pretty-print
'(library (testfile-cwl-a7)
(export x)
(import (chezscheme))
(define $x (make-parameter 1))
(define-syntax x (identifier-syntax ($x)))
(printf "invoking a\n"))))
'replace)
(with-output-to-file "testfile-cwl-b7.ss"
(lambda ()
(pretty-print
'(library (testfile-cwl-b7)
(export z)
(import (chezscheme) (testfile-cwl-c7))
(define $z (make-parameter (+ y 1)))
(define-syntax z (identifier-syntax ($z)))
(printf "invoking b\n"))))
'replace)
(with-output-to-file "testfile-cwl-c7.ss"
(lambda ()
(pretty-print
'(library (testfile-cwl-c7)
(export y)
(import (chezscheme) (testfile-cwl-a7))
(define $y (make-parameter (+ x 1)))
(define-syntax y (identifier-syntax ($y)))
(printf "invoking c\n"))))
'replace)
(separate-compile
'(lambda (x)
(parameterize ([compile-imported-libraries #t]
[generate-wpo-files #t])
(compile-library x)))
'cwl-b7)
#t)
(delete-file "testfile-cwl-c7.wpo")
(delete-file "testfile-cwl-c7.ss")
(equal?
(separate-compile
'(lambda (x)
(parameterize ([generate-wpo-files #t])
(compile-whole-library (format "~a.wpo" x) "testfile-cwl-ab7.so")))
'cwl-b7)
"((testfile-cwl-c7))\n")
(equal?
(separate-eval
'(load "testfile-cwl-ab7.so")
'(import (testfile-cwl-a7))
'(write x)
'(newline)
'(import (testfile-cwl-b7))
'(write z)
'(newline)
'(import (testfile-cwl-c7))
'(write y)
'(newline))
"invoking a\n1\ninvoking c\ninvoking b\n3\n2\n")
(equal?
(separate-eval
'(load "testfile-cwl-ab7.so")
'(import (testfile-cwl-a7))
'(write x)
'(newline)
'(import (testfile-cwl-c7))
'(write y)
'(newline)
'(import (testfile-cwl-b7))
'(write z)
'(newline))
"invoking a\n1\ninvoking c\n2\ninvoking b\n3\n")
(equal?
(separate-eval
'(load "testfile-cwl-ab7.so")
'(import (testfile-cwl-a7))
'(write x)
'(newline)
'(import (testfile-cwl-c7))
'(write y)
'(newline))
"invoking a\n1\ninvoking c\n2\n")
(equal?
(separate-eval
'(load "testfile-cwl-ab7.so")
'(import (testfile-cwl-b7))
'(write z)
'(newline)
'(import (testfile-cwl-c7))
'(write y)
'(newline))
"invoking a\ninvoking c\ninvoking b\n3\n2\n")
(equal?
(separate-eval
'(load "testfile-cwl-ab7.so")
'(import (testfile-cwl-a7))
'(import (testfile-cwl-c7))
'(write y)
'(newline))
"invoking a\ninvoking c\n2\n")
(equal?
(separate-eval
'(load "testfile-cwl-ab7.so")
'(import (testfile-cwl-b7))
'(import (testfile-cwl-c7))
'(write y)
'(newline))
"invoking a\ninvoking c\n2\n")
(equal?
(separate-eval
'(load "testfile-cwl-ab7.so")
'(import (testfile-cwl-a7) (testfile-cwl-c7))
'(write y)
'(newline))
"invoking a\ninvoking c\n2\n")
(equal?
(separate-eval
'(load "testfile-cwl-ab7.so")
'(import (testfile-cwl-c7) (testfile-cwl-b7))
'(write y)
'(newline))
"invoking a\ninvoking c\n2\n")
(equal?
(separate-eval
'(load "testfile-cwl-ab7.so")
'(import (testfile-cwl-c7))
'(write y)
'(newline))
"invoking a\ninvoking c\n2\n")
(begin
(with-output-to-file "testfile-cwl-a8.ss"
(lambda ()
(pretty-print
'(library (testfile-cwl-a8)
(export x)
(import (chezscheme))
(define x (gensym))
(printf "invoking a\n"))))
'replace)
(with-output-to-file "testfile-cwl-b8.ss"
(lambda ()
(pretty-print
'(library (testfile-cwl-b8)
(export z)
(import (chezscheme) (testfile-cwl-c8))
(define z (cons 'b y))
(printf "invoking b\n"))))
'replace)
(with-output-to-file "testfile-cwl-c8.ss"
(lambda ()
(pretty-print
'(library (testfile-cwl-c8)
(export y)
(import (chezscheme) (testfile-cwl-a8))
(define y (cons 'c x))
(printf "invoking c\n"))))
'replace)
(with-output-to-file "testfile-cwl-d8.ss"
(lambda ()
(pretty-print
'(library (testfile-cwl-d8)
(export runit)
(import (chezscheme) (testfile-cwl-c8) (testfile-cwl-a8) (testfile-cwl-b8))
(define (runit yes?)
(pretty-print (eq? (cdr y) x))
(pretty-print (eq? (cdr z) y))
(pretty-print (and (eq? (car y) 'c) (eq? (car z) 'b)))
(when yes? (eq? (eval 'x (environment '(testfile-cwl-a8))) x))))))
'replace)
(separate-compile
'(lambda (x)
(parameterize ([compile-imported-libraries #t]
[generate-wpo-files #t])
(compile-library x)))
'cwl-d8)
#t)
(equal?
(separate-eval '(begin (import (testfile-cwl-d8)) (runit #f)))
"invoking a\ninvoking c\ninvoking b\n#t\n#t\n#t\n")
(equal?
(separate-eval '(begin (import (testfile-cwl-d8)) (runit #t)))
"invoking a\ninvoking c\ninvoking b\n#t\n#t\n#t\n#t\n")
(delete-file "testfile-cwl-c8.ss")
(delete-file "testfile-cwl-c8.wpo")
(equal?
(separate-compile
'(lambda (x)
(parameterize ([generate-wpo-files #t])
(compile-whole-library (format "~a.wpo" x) (format "~a.so" x))))
'cwl-d8)
"((testfile-cwl-c8))\n")
(equal?
(separate-eval '(begin (import (testfile-cwl-d8)) (runit #f)))
"invoking a\ninvoking c\ninvoking b\n#t\n#t\n#t\n")
(equal?
(separate-eval '(begin (import (testfile-cwl-d8)) (runit #t)))
"invoking a\ninvoking c\ninvoking b\n#t\n#t\n#t\n#t\n")
(begin
(with-output-to-file "testfile-cwl-a9.ss"
(lambda ()
(pretty-print
'(eval-when (visit)
(library (testfile-cwl-a9)
(export x)
(import (chezscheme))
(define x 5)))))
'replace)
(separate-compile
'(lambda (x)
(parameterize ([compile-imported-libraries #t]
[generate-wpo-files #t])
(compile-library x)))
'cwl-a9)
#t)
(error? ; found visit-only run-time library (testfile-cwl-a9)
(separate-compile
'(lambda (x)
(parameterize ([generate-wpo-files #t])
(compile-whole-library (format "~a.wpo" x) (format "~a.so" x))))
'cwl-a9))
(begin
(with-output-to-file "testfile-cwl-a10.ss"
(lambda ()
(pretty-print
'(library (testfile-cwl-a10)
(export f x)
(import (chezscheme) (testfile-cwl-b10))
(define f (lambda (x) (* x 17)))
(define x 5))))
'replace)
(with-output-to-file "testfile-cwl-b10.ss"
(lambda ()
(pretty-print
'(library (testfile-cwl-b10)
(export g y)
(import (chezscheme))
(define g (lambda (x) (+ x 23)))
(define y 37))))
'replace)
(separate-compile
'(lambda (x)
(parameterize ([compile-imported-libraries #t]
[generate-wpo-files #t])
(compile-library x)))
'cwl-a10)
(separate-compile
'(lambda (x)
(parameterize ([generate-wpo-files #t])
(compile-whole-library (format "~a.wpo" x) (format "~a.so" x))))
'cwl-a10)
#t)
(delete-file "testfile-cwl-a10.ss")
(delete-file "testfile-cwl-a10.wpo")
(delete-file "testfile-cwl-b10.ss")
(delete-file "testfile-cwl-b10.so")
(delete-file "testfile-cwl-b10.wpo")
(test-cp0-expansion
`(let ()
(import (testfile-cwl-a10) (testfile-cwl-b10))
(+ (f (g y)) x))
`(begin
(#3%$invoke-library '(testfile-cwl-b10) '() ',gensym?)
(#3%$invoke-library '(testfile-cwl-a10) '() ',gensym?)
1025))
(begin
(with-output-to-file "testfile-cwl-a11.ss"
(lambda ()
(pretty-print
'(library (testfile-cwl-a11)
(export f x)
(import (chezscheme) (testfile-cwl-b11))
(define f (lambda (x) (* x 17)))
(define x 5))))
'replace)
(with-output-to-file "testfile-cwl-b11.ss"
(lambda ()
(pretty-print
'(library (testfile-cwl-b11)
(export g y)
(import (chezscheme))
(define g (lambda (x) (+ x 23)))
(define y 37))))
'replace)
(separate-compile
'(lambda (x)
(parameterize ([compile-imported-libraries #t]
[generate-wpo-files #t])
(compile-library x)))
'cwl-a11)
(separate-compile
'(lambda (x)
(parameterize ([generate-wpo-files #t] [run-cp0 (lambda (cp0 x) x)])
(compile-whole-library (format "~a.wpo" x) (format "~a.so" x))))
'cwl-a11)
#t)
(delete-file "testfile-cwl-a11.ss")
(delete-file "testfile-cwl-a11.wpo")
(delete-file "testfile-cwl-b11.ss")
(delete-file "testfile-cwl-b11.so")
(delete-file "testfile-cwl-b11.wpo")
(test-cp0-expansion
`(let ()
(import (testfile-cwl-a11) (testfile-cwl-b11))
(+ (f (g y)) x))
`(begin
(#3%$invoke-library '(testfile-cwl-b11) '() ',gensym?)
(#3%$invoke-library '(testfile-cwl-a11) '() ',gensym?)
,(lambda (x) (not (eqv? x 1025)))))
(begin
(delete-file "testfile-cwl-a12.so")
(delete-file "testfile-cwl-a12.wpo")
(delete-file "testfile-cwl-b12.so")
(delete-file "testfile-cwl-b12.wpo")
(with-output-to-file "testfile-cwl-a12.ss"
(lambda ()
(pretty-print
'(library (testfile-cwl-a12)
(export f)
(import (chezscheme))
(define f (lambda (x) (* x 17))))))
'replace)
(with-output-to-file "testfile-cwl-b12.ss"
(lambda ()
(pretty-print
'(library (testfile-cwl-b12)
(export g f)
(import (chezscheme) (testfile-cwl-a12))
(define g (lambda (x) (+ x 23))))))
'replace)
(separate-compile
'(lambda (x)
(parameterize ([compile-imported-libraries #t]
[generate-wpo-files #t])
(compile-library x)))
'cwl-b12)
(separate-compile
'(lambda (x)
(parameterize ([generate-wpo-files #t])
(compile-whole-library (format "~a.wpo" x) (format "~a.so" x))))
'cwl-b12)
#t)
(equal?
(separate-eval '(let () (import (testfile-cwl-b12)) (list (f 3) (g 5))))
"(51 28)\n")
(begin
(delete-file "testfile-cwl-a13.so")
(delete-file "testfile-cwl-a13.wpo")
(delete-file "testfile-cwl-b13.so")
(delete-file "testfile-cwl-b13.wpo")
(delete-file "testfile-cwl-c13.so")
(delete-file "testfile-cwl-c13.wpo")
(with-output-to-file "testfile-cwl-a13.ss"
(lambda ()
(pretty-print
'(library (testfile-cwl-a13)
(export a)
(import (chezscheme))
(define-syntax a (identifier-syntax f))
(define f (lambda (x) (* x 17))))))
'replace)
(with-output-to-file "testfile-cwl-b13.ss"
(lambda ()
(pretty-print
'(library (testfile-cwl-b13)
(export g a)
(import (chezscheme) (testfile-cwl-a13))
(define g (lambda (x) (a x))))))
'replace)
(with-output-to-file "testfile-cwl-c13.ss"
(lambda ()
(for-each pretty-print
'((import (chezscheme) (testfile-cwl-b13))
(pretty-print (list (g 3) (a 5) (eval '(a 7) (environment '(testfile-cwl-a13))))))))
'replace)
(separate-compile
'(lambda (x)
(parameterize ([generate-wpo-files #t])
(compile-library x)))
'cwl-a13)
(separate-compile
'(lambda (x)
(parameterize ([generate-wpo-files #f])
(compile-library x)))
'cwl-b13)
(separate-compile
'(lambda (x)
(parameterize ([generate-wpo-files #t])
(compile-program x)))
'cwl-c13)
(separate-compile
'(lambda (x)
(compile-whole-program (format "~a.wpo" x) (format "~a.so" x)))
'cwl-c13)
#t)
(equal?
(separate-eval '(load-program "testfile-cwl-c13.so"))
"(51 85 119)\n")
(begin
(with-output-to-file "testfile-wpo-extlib-1.chezscheme.sls"
(lambda ()
(pretty-print
'(library (testfile-wpo-extlib-1)
(export magic)
(import (rnrs))
(define magic (cons 9 5)))))
'replace)
(with-output-to-file "testfile-wpo-extlib-2.ss"
(lambda ()
(pretty-print
'(library (testfile-wpo-extlib-2)
(export p)
(import (chezscheme) (testfile-wpo-extlib))
(define p
(lambda ()
(pretty-print magic))))))
'replace)
(separate-compile
'(lambda (x)
(parameterize ([compile-imported-libraries #t]
[generate-wpo-files #t])
(compile-library x)))
'wpo-extlib-2)
#t)
(equal?
(separate-compile
'(lambda (x)
(parameterize ([generate-wpo-files #t])
(compile-whole-library (format "~a.wpo" x) (format "~a-all.so" x))))
'wpo-extlib-2)
"()\n")
(equal?
(separate-eval '(let () (import (testfile-wpo-extlib-2)) (p)))
"(9 . 5)\n")
;; regression tests from @owaddell generated to fix problems he encountered
;; with compile-whole-library from a test generator.
(begin
(with-output-to-file "testfile-wpo-coconut.ss"
(lambda ()
(pretty-print
'(library (testfile-wpo-coconut)
(export coconut apple->coconut)
(import (scheme))
(define $init (list '_))
(define apple->coconut (cons 'apple->coconut $init))
(define coconut (list 'coconut apple->coconut $init)))))
'replace)
(with-output-to-file "testfile-wpo-banana.ss"
(lambda ()
(pretty-print
'(library (testfile-wpo-banana)
(export banana apple->banana)
(import (scheme))
(define $init (list '_))
(define apple->banana (cons 'apple->banana $init))
(define banana (list 'banana apple->banana $init)))))
'replace)
(with-output-to-file "testfile-wpo-apple.ss"
(lambda ()
(pretty-print
'(library (testfile-wpo-apple)
(export apple)
(import (scheme) (testfile-wpo-banana) (testfile-wpo-coconut))
(define $init
(list
'_
(cons 'apple->banana apple->banana)
(cons 'apple->coconut apple->coconut)))
(define apple (list 'apple $init)))))
'replace)
(with-output-to-file "testfile-wpo-main.ss"
(lambda ()
(pretty-print '(import (scheme) (testfile-wpo-banana) (testfile-wpo-coconut) (testfile-wpo-apple)))
(pretty-print '(pretty-print banana))
(pretty-print '(pretty-print coconut))
(pretty-print '(pretty-print apple)))
'replace)
(separate-compile
'(lambda (x)
(parameterize ([compile-imported-libraries #t]
[generate-wpo-files #t])
(compile-program x)))
'wpo-main)
#t)
(equal?
(separate-compile
'(lambda (x)
(parameterize ([generate-wpo-files #f])
(compile-whole-library (format "~a.wpo" x) (format "~a.so" x))))
'wpo-coconut)
"()\n")
(begin
(delete-file "testfile-wpo-coconut.wpo")
#t)
(equal?
(separate-compile
'(lambda (x)
(parameterize ([generate-wpo-files #f])
(compile-whole-library (format "~a.wpo" x) (format "~a.so" x))))
'wpo-apple)
"((testfile-wpo-coconut))\n")
(begin
(delete-file "testfile-wpo-banana.wpo")
(delete-file "testfile-wpo-apple.wpo")
(delete-file "testfile-wpo-banana.so")
#t)
(equal?
(separate-compile
'(lambda (x)
(parameterize ([library-search-handler
(let ([lsh (library-search-handler)])
(lambda (who name dirs exts)
(lsh who (if (equal? name '(testfile-wpo-banana))
'(testfile-wpo-apple)
name)
dirs exts)))])
(compile-whole-program (format "~a.wpo" x) (format "~a.so" x))))
'wpo-main)
"((testfile-wpo-apple)\n (testfile-wpo-banana)\n (testfile-wpo-coconut))\n")
(equal?
(separate-eval
'(parameterize ([library-search-handler
(let ([lsh (library-search-handler)])
(lambda (who name dirs exts)
(lsh who (if (equal? name '(testfile-wpo-banana))
'(testfile-wpo-apple)
name)
dirs exts)))])
(load-program "testfile-wpo-main.so")))
(string-append
"(banana (apple->banana _) (_))\n"
"(coconut (apple->coconut _) (_))\n"
"(apple\n (_ (apple->banana apple->banana _)\n (apple->coconut apple->coconut _)))\n"))
(begin
;; clean-up to make sure previous builds don't get in the way.
(delete-file "testfile-wpo-coconut.ss")
(delete-file "testfile-wpo-coconut.so")
(delete-file "testfile-wpo-coconut.wpo")
(delete-file "testfile-wpo-banana.ss")
(delete-file "testfile-wpo-banana.so")
(delete-file "testfile-wpo-banana.wpo")
(delete-file "testfile-wpo-apple.ss")
(delete-file "testfile-wpo-apple.so")
(delete-file "testfile-wpo-apple.wpo")
(delete-file "testfile-wpo-main.ss")
(delete-file "testfile-wpo-main.so")
(delete-file "testfile-wpo-main.wpo")
#t)
(begin
(with-output-to-file "testfile-wpo-coconut.ss"
(lambda ()
(pretty-print
'(library (testfile-wpo-coconut)
(export coconut banana->coconut apple->coconut)
(import (scheme))
(define $init (list '_))
(define banana->coconut (cons 'banana->coconut $init))
(define apple->coconut (cons 'apple->coconut $init))
(define coconut
(list 'coconut banana->coconut apple->coconut $init)))))
'replace)
(with-output-to-file "testfile-wpo-date.ss"
(lambda ()
(pretty-print
'(library (testfile-wpo-date)
(export date apple->date)
(import (scheme))
(define $init (list '_))
(define apple->date (cons 'apple->date $init))
(define date (list 'date apple->date $init)))))
'replace)
(with-output-to-file "testfile-wpo-apple.ss"
(lambda ()
(pretty-print
'(library (testfile-wpo-apple)
(export apple)
(import (scheme) (testfile-wpo-date) (testfile-wpo-coconut))
(define $init
(list
'_
(cons 'apple->date apple->date)
(cons 'apple->coconut apple->coconut)))
(define apple (list 'apple $init)))))
'replace)
(with-output-to-file "testfile-wpo-banana.ss"
(lambda ()
(pretty-print
'(library (testfile-wpo-banana)
(export banana)
(import (scheme) (testfile-wpo-coconut))
(define $init
(list '_ (cons 'banana->coconut banana->coconut)))
(define banana (list 'banana $init)))))
'replace)
(with-output-to-file "testfile-wpo-main.ss"
(lambda ()
(pretty-print '(import (scheme) (testfile-wpo-date)
(testfile-wpo-banana) (testfile-wpo-coconut)
(testfile-wpo-apple)))
(pretty-print '(pretty-print date))
(pretty-print '(pretty-print banana))
(pretty-print '(pretty-print coconut))
(pretty-print '(pretty-print apple)))
'replace)
(separate-compile
'(lambda (x)
(parameterize ([compile-imported-libraries #t]
[generate-wpo-files #t])
(compile-program x)))
'wpo-main)
#t)
(equal?
(separate-compile
'(lambda (x)
(parameterize ([generate-wpo-files #f])
(compile-whole-library (format "~a.wpo" x) (format "~a.so" x))))
'wpo-coconut)
"()\n")
(begin
(delete-file "testfile-wpo-coconut.wpo")
#t)
(equal?
(separate-compile
'(lambda (x)
(parameterize ([generate-wpo-files #f])
(compile-whole-library (format "~a.wpo" x) (format "~a.so" x))))
'wpo-apple)
"((testfile-wpo-coconut))\n")
(begin
(delete-file "testfile-wpo-date.wpo")
(delete-file "testfile-wpo-apple.wpo")
(delete-file "testfile-wpo-date.so")
#t)
(equal?
(separate-compile
'(lambda (x)
(parameterize ([library-search-handler
(let ([lsh (library-search-handler)])
(lambda (who name dirs exts)
(lsh who (if (equal? name '(testfile-wpo-date))
'(testfile-wpo-apple)
name)
dirs exts)))])
(compile-whole-program (format "~a.wpo" x) (format "~a.so" x))))
'wpo-main)
"((testfile-wpo-apple)\n (testfile-wpo-date)\n (testfile-wpo-coconut))\n")
(equal?
(separate-eval
'(parameterize ([library-search-handler
(let ([lsh (library-search-handler)])
(lambda (who name dirs exts)
(lsh who (if (equal? name '(testfile-wpo-date))
'(testfile-wpo-apple)
name)
dirs exts)))])
(load-program "testfile-wpo-main.so")))
(string-append
"(date (apple->date _) (_))\n"
"(banana (_ (banana->coconut banana->coconut _)))\n"
"(coconut (banana->coconut _) (apple->coconut _) (_))\n"
"(apple\n"
" (_ (apple->date apple->date _)\n"
" (apple->coconut apple->coconut _)))\n"))
(begin
;; clean-up to make sure previous builds don't get in the way.
(delete-file "testfile-wpo-coconut.ss")
(delete-file "testfile-wpo-coconut.so")
(delete-file "testfile-wpo-coconut.wpo")
(delete-file "testfile-wpo-date.ss")
(delete-file "testfile-wpo-date.so")
(delete-file "testfile-wpo-date.wpo")
(delete-file "testfile-wpo-banana.ss")
(delete-file "testfile-wpo-banana.so")
(delete-file "testfile-wpo-banana.wpo")
(delete-file "testfile-wpo-apple.ss")
(delete-file "testfile-wpo-apple.so")
(delete-file "testfile-wpo-apple.wpo")
(delete-file "testfile-wpo-main.ss")
(delete-file "testfile-wpo-main.so")
(delete-file "testfile-wpo-main.wpo")
#t)
(begin
(with-output-to-file "testfile-wpo-date.ss"
(lambda ()
(pretty-print
'(library (testfile-wpo-date)
(export date apple->date)
(import (scheme))
(define $init (list '_))
(define apple->date (cons 'apple->date $init))
(define date (list 'date apple->date $init)))))
'replace)
(with-output-to-file "testfile-wpo-eel.ss"
(lambda ()
(pretty-print
'(library (testfile-wpo-eel)
(export eel coconut->eel apple->eel)
(import (scheme))
(define $init (list '_))
(define coconut->eel (cons 'coconut->eel $init))
(define apple->eel (cons 'apple->eel $init))
(define eel (list 'eel coconut->eel apple->eel $init)))))
'replace)
(with-output-to-file "testfile-wpo-coconut.ss"
(lambda ()
(pretty-print
'(library (testfile-wpo-coconut)
(export coconut banana->coconut apple->coconut)
(import (scheme) (testfile-wpo-eel))
(define $init (list '_ (cons 'coconut->eel coconut->eel)))
(define banana->coconut (cons 'banana->coconut $init))
(define apple->coconut (cons 'apple->coconut $init))
(define coconut
(list 'coconut banana->coconut apple->coconut $init)))))
'replace)
(with-output-to-file "testfile-wpo-apple.ss"
(lambda ()
(pretty-print
'(library (testfile-wpo-apple)
(export apple)
(import (scheme) (testfile-wpo-date) (testfile-wpo-coconut)
(testfile-wpo-eel))
(define $init
(list
'_
(cons 'apple->date apple->date)
(cons 'apple->coconut apple->coconut)
(cons 'apple->eel apple->eel)))
(define apple (list 'apple $init)))))
'replace)
(with-output-to-file "testfile-wpo-banana.ss"
(lambda ()
(pretty-print
'(library (testfile-wpo-banana)
(export banana)
(import (scheme) (testfile-wpo-coconut))
(define $init
(list '_ (cons 'banana->coconut banana->coconut)))
(define banana (list 'banana $init)))))
'replace)
(with-output-to-file "testfile-wpo-main.ss"
(lambda ()
(pretty-print '(import (scheme) (testfile-wpo-date)
(testfile-wpo-banana) (testfile-wpo-coconut)
(testfile-wpo-apple) (testfile-wpo-eel)))
(pretty-print '(pretty-print date))
(pretty-print '(pretty-print banana))
(pretty-print '(pretty-print coconut))
(pretty-print '(pretty-print apple))
(pretty-print '(pretty-print eel)))
'replace)
(separate-compile
'(lambda (x)
(parameterize ([compile-imported-libraries #t]
[generate-wpo-files #t])
(compile-program x)))
'wpo-main)
#t)
(equal?
(separate-compile
'(lambda (x)
(parameterize ([generate-wpo-files #f])
(compile-whole-library (format "~a.wpo" x) (format "~a.so" x))))
'wpo-coconut)
"()\n")
(begin
(delete-file "testfile-wpo-eel.wpo")
(delete-file "testfile-wpo-coconut.wpo")
(delete-file "testfile-wpo-eel.so")
#t)
(equal?
(separate-compile
'(lambda (x)
(parameterize ([generate-wpo-files #f]
[library-search-handler
(let ([lsh (library-search-handler)])
(lambda (who name dirs exts)
(lsh who (if (equal? name '(testfile-wpo-eel))
'(testfile-wpo-coconut)
name)
dirs exts)))])
(compile-whole-library (format "~a.wpo" x) (format "~a.so" x))))
'wpo-apple)
"((testfile-wpo-coconut) (testfile-wpo-eel))\n")
(begin
(delete-file "testfile-wpo-date.wpo")
(delete-file "testfile-wpo-apple.wpo")
(delete-file "testfile-wpo-date.so")
#t)
(equal?
(separate-compile
'(lambda (x)
(parameterize ([library-search-handler
(let ([lsh (library-search-handler)])
(lambda (who name dirs exts)
(lsh who (cond
[(equal? name '(testfile-wpo-date)) '(testfile-wpo-apple)]
[(equal? name '(testfile-wpo-eel)) '(testfile-wpo-coconut)]
[else name])
dirs exts)))])
(compile-whole-program (format "~a.wpo" x) (format "~a.so" x))))
'wpo-main)
"((testfile-wpo-apple)\n (testfile-wpo-date)\n (testfile-wpo-coconut)\n (testfile-wpo-eel))\n")
(equal?
(separate-eval
'(parameterize ([library-search-handler
(let ([lsh (library-search-handler)])
(lambda (who name dirs exts)
(lsh who (cond
[(equal? name '(testfile-wpo-date)) '(testfile-wpo-apple)]
[(equal? name '(testfile-wpo-eel)) '(testfile-wpo-coconut)]
[else name])
dirs exts)))])
(load-program "testfile-wpo-main.so")))
(string-append
"(date (apple->date _) (_))\n"
"(banana\n"
" (_ (banana->coconut\n"
" banana->coconut\n"
" _\n"
" (coconut->eel coconut->eel _))))\n"
"(coconut\n"
" (banana->coconut _ (coconut->eel coconut->eel _))\n"
" (apple->coconut _ (coconut->eel coconut->eel _))\n"
" (_ (coconut->eel coconut->eel _)))\n"
"(apple\n"
" (_ (apple->date apple->date _)\n"
" (apple->coconut\n"
" apple->coconut\n"
" _\n"
" (coconut->eel coconut->eel _))\n"
" (apple->eel apple->eel _)))\n"
"(eel (coconut->eel _) (apple->eel _) (_))\n"))
(begin
;; clean-up to make sure previous builds don't get in the way.
(delete-file "testfile-wpo-coconut.ss")
(delete-file "testfile-wpo-coconut.so")
(delete-file "testfile-wpo-coconut.wpo")
(delete-file "testfile-wpo-eel.ss")
(delete-file "testfile-wpo-eel.so")
(delete-file "testfile-wpo-eel.wpo")
(delete-file "testfile-wpo-date.ss")
(delete-file "testfile-wpo-date.so")
(delete-file "testfile-wpo-date.wpo")
(delete-file "testfile-wpo-banana.ss")
(delete-file "testfile-wpo-banana.so")
(delete-file "testfile-wpo-banana.wpo")
(delete-file "testfile-wpo-apple.ss")
(delete-file "testfile-wpo-apple.so")
(delete-file "testfile-wpo-apple.wpo")
(delete-file "testfile-wpo-main.ss")
(delete-file "testfile-wpo-main.so")
(delete-file "testfile-wpo-main.wpo")
#t)
(begin
(with-output-to-file "testfile-deja-vu-one.ss"
(lambda ()
(pretty-print
'(library (testfile-deja-vu-one)
(export a)
(import (scheme))
(define a 3))))
'replace)
(with-output-to-file "testfile-deja-vu-two.ss"
(lambda ()
(pretty-print
'(library (testfile-deja-vu-two)
(export b)
(import (scheme) (testfile-deja-vu-one))
(define b (list 'b a)))))
'replace)
(with-output-to-file "testfile-deja-vu-dup.ss"
(lambda ()
(pretty-print
'(library (testfile-deja-vu-dup)
(export d)
(import (scheme) (testfile-deja-vu-one))
(define d (list a 'd)))))
'replace)
(with-output-to-file "testfile-deja-vu-main.ss"
(lambda ()
(for-each pretty-print
'((import (scheme) (testfile-deja-vu-one) (testfile-deja-vu-two) (testfile-deja-vu-dup))
(pretty-print (list a b d)))))
'replace)
(separate-eval
'(parameterize ([generate-wpo-files #t])
(compile-library "testfile-deja-vu-one")
(compile-library "testfile-deja-vu-two")
(compile-library "testfile-deja-vu-dup")
(compile-program "testfile-deja-vu-main")
(compile-whole-library "testfile-deja-vu-one.wpo" "testfile-deja-vu-one.done")
(compile-whole-library "testfile-deja-vu-two.wpo" "testfile-deja-vu-two.done")
(compile-whole-library "testfile-deja-vu-dup.wpo" "testfile-deja-vu-dup.done")))
#t)
(error?
(separate-eval
'(compile-whole-program "testfile-deja-vu-main.wpo" "testfile-deja-vu-main.done")))
(begin
(do ([stem '("one" "two" "dup" "main") (cdr stem)]) ((null? stem))
(do ([ext '("ss" "so" "wpo" "done") (cdr ext)]) ((null? ext))
(delete-file (format "testfile-deja-vu-~a.~a" (car stem) (car ext)))))
#t)
; verify compatibility of generate-covin-files and generate-wpo-files
(begin
(mkfile "testfile-cwl-a14.ss"
'(library (testfile-cwl-a14) (export a) (import (scheme)) (define a 123)))
(parameterize ([generate-covin-files #t]
[generate-wpo-files #t])
(compile-library "testfile-cwl-a14")
(compile-whole-library "testfile-cwl-a14.wpo" "testfile-cwl-a14.library"))
#t)
(file-exists? "testfile-cwl-a14.covin")
(eqv?
(let () (import (testfile-cwl-a14)) a)
123)
(eqv?
(separate-eval
'(verify-loadability 'load "testfile-cwl-a14.library"))
"")
)
(mat maybe-compile-whole
(begin
(delete-file "testfile-mcw-a1.so")
(delete-file "testfile-mcw-a1.wpo")
(delete-file "testfile-mcw-b1.so")
(delete-file "testfile-mcw-b1.wpo")
(delete-file "testfile-mcw-c1.so")
(delete-file "testfile-mcw-c1.wpo")
(with-output-to-file "testfile-mcw-ha1.ss"
(lambda ()
(pretty-print
'(define minor-msg-number 97)))
'replace)
(with-output-to-file "testfile-mcw-hb1.ss"
(lambda ()
(pretty-print
'(define major-msg-number 113)))
'replace)
(with-output-to-file "testfile-mcw-a1.ss"
(lambda ()
(pretty-print
'(library (testfile-mcw-a1)
(export a)
(import (chezscheme))
(define a "hello from a"))))
'replace)
(with-output-to-file "testfile-mcw-b1.ss"
(lambda ()
(pretty-print
'(library (testfile-mcw-b1)
(export b)
(import (chezscheme) (testfile-mcw-a1))
(include "testfile-mcw-ha1.ss")
(define b (lambda () (format "~a and b [~s]" a minor-msg-number))))))
'replace)
(with-output-to-file "testfile-mcw-c1.ss"
(lambda ()
(for-each pretty-print
'((import (chezscheme) (testfile-mcw-b1))
(include "testfile-mcw-hb1.ss")
(printf "~a and c [~s]\n" (b) major-msg-number))))
'replace)
(separate-compile
'(lambda (x)
(parameterize ([compile-imported-libraries #t] [generate-wpo-files #t])
(compile-program x)))
'mcw-c1)
#t)
(equal?
(separate-eval '(load-program "testfile-mcw-c1.so"))
"hello from a and b [97] and c [113]\n")
(begin
(with-output-to-file "testfile-mcw-a1.ss"
(lambda ()
(pretty-print
'(library (testfile-mcw-a1)
(export a)
(import (chezscheme))
(define a "greetings from a"))))
'replace)
(touch "testfile-mcw-a1.so" "testfile-mcw-a1.ss")
(separate-compile
'(lambda (x)
(parameterize ([compile-imported-libraries #t] [generate-wpo-files #t])
(maybe-compile-program x)))
'mcw-c1)
#t)
(equal?
(separate-eval '(load-program "testfile-mcw-c1.so"))
"greetings from a and b [97] and c [113]\n")
(begin
(separate-compile
'(lambda (x)
(compile-whole-program (format "~a.wpo" x) (format "~a.so" x)) #f)
'mcw-c1)
#t)
(equal?
(separate-eval '(load-program "testfile-mcw-c1.so"))
"greetings from a and b [97] and c [113]\n")
(begin
(with-output-to-file "testfile-mcw-a1.ss"
(lambda ()
(pretty-print
'(library (testfile-mcw-a1)
(export a)
(import (chezscheme))
(define a "salutations from a"))))
'replace)
(touch "testfile-mcw-a1.so" "testfile-mcw-a1.ss")
(separate-compile
'(lambda (x)
(parameterize ([compile-imported-libraries #t] [generate-wpo-files #t])
(parameterize ([compile-program-handler
(lambda (ifn ofn)
(compile-program ifn ofn)
(compile-whole-program (format "~a.wpo" (path-root ofn)) ofn #t))])
(maybe-compile-program x))))
'mcw-c1)
#t)
(equal?
(separate-eval '(load-program "testfile-mcw-c1.so"))
"salutations from a and b [97] and c [113]\n")
(begin
(with-output-to-file "testfile-mcw-a1.ss"
(lambda ()
(pretty-print
'(library (testfile-mcw-a1)
(export a)
(import (chezscheme))
(define a "goodbye from a"))))
'replace)
(touch "testfile-mcw-a1.so" "testfile-mcw-a1.ss")
(separate-compile
'(lambda (x)
(parameterize ([compile-imported-libraries #t] [generate-wpo-files #t])
(parameterize ([compile-program-handler
(lambda (ifn ofn)
(compile-program ifn ofn)
(compile-whole-program (format "~a.wpo" (path-root ofn)) ofn #t))])
(maybe-compile-program x))))
'mcw-c1)
#t)
(equal?
(separate-eval '(load-program "testfile-mcw-c1.so"))
"goodbye from a and b [97] and c [113]\n")
(begin
(with-output-to-file "testfile-mcw-hb1.ss"
(lambda ()
(pretty-print
'(define major-msg-number 773)))
'replace)
(touch "testfile-mcw-c1.so" "testfile-mcw-hb1.ss")
(separate-compile
'(lambda (x)
(parameterize ([compile-imported-libraries #t] [generate-wpo-files #t])
(parameterize ([compile-program-handler
(lambda (ifn ofn)
(compile-program ifn ofn)
(compile-whole-program (format "~a.wpo" (path-root ofn)) ofn #t))])
(maybe-compile-program x))))
'mcw-c1)
#t)
(equal?
(separate-eval '(load-program "testfile-mcw-c1.so"))
"goodbye from a and b [97] and c [773]\n")
(begin
(with-output-to-file "testfile-mcw-a1.ss"
(lambda ()
(pretty-print
'(library (testfile-mcw-a1)
(export a)
(import (chezscheme))
(define a "hello again from a"))))
'replace)
(touch "testfile-mcw-a1.so" "testfile-mcw-a1.ss")
(separate-compile
'(lambda (x)
(parameterize ([compile-imported-libraries #t] [generate-wpo-files #t])
(parameterize ([compile-library-handler
(lambda (ifn ofn)
(compile-library ifn ofn)
(compile-whole-library (format "~a.wpo" (path-root ofn)) ofn))])
(maybe-compile-library x))))
'mcw-b1)
#t)
(equal?
(separate-eval '(let () (import (testfile-mcw-b1)) (printf "~a\n" (b))))
"hello again from a and b [97]\n")
(begin
(with-output-to-file "testfile-mcw-ha1.ss"
(lambda ()
(pretty-print
'(define minor-msg-number -53)))
'replace)
(touch "testfile-mcw-a1.so" "testfile-mcw-a1.ss")
(separate-compile
'(lambda (x)
(parameterize ([compile-imported-libraries #t] [generate-wpo-files #t])
(parameterize ([compile-library-handler
(lambda (ifn ofn)
(compile-library ifn ofn)
(compile-whole-library (format "~a.wpo" (path-root ofn)) ofn))])
(maybe-compile-library x))))
'mcw-b1)
#t)
(equal?
(separate-eval '(let () (import (testfile-mcw-b1)) (printf "~a\n" (b))))
"hello again from a and b [-53]\n")
)
(mat library-manager
(begin
(with-output-to-file "testfile-lm-a.ss"
(lambda ()
(pretty-print
'(library (testfile-lm-a)
(export ct-a rt-a)
(import (scheme))
(meta define ct-a (begin (display "ct-a rhs\n") 123))
(define rt-a (begin (display "rt-a rhs\n") 456)))))
'replace)
(with-output-to-file "testfile-lm-b.ss"
(lambda ()
(pretty-print
'(library (testfile-lm-b)
(export b)
(import (scheme) (testfile-lm-a))
(define-syntax (use-ct-val x) (if (odd? ct-a) #'"odd" #'"even"))
(define b use-ct-val))))
'replace)
(with-output-to-file "testfile-lm-c.ss"
(lambda ()
(pretty-print
'(library (testfile-lm-c)
(export c)
(import (scheme) (testfile-lm-a))
(define use-rt-val rt-a)
(define c use-rt-val))))
'replace)
(with-output-to-file "testfile-lm-combined.ss"
(lambda ()
(pretty-print
'(begin
(include "testfile-lm-a.ss")
(include "testfile-lm-b.ss")
(include "testfile-lm-c.ss"))))
'replace)
(with-output-to-file "testfile-lm-use-b.ss"
(lambda ()
(pretty-print
'(library (testfile-lm-use-b)
(export x)
(import (scheme) (testfile-lm-b))
(meta define x b))))
'replace)
(with-output-to-file "testfile-lm-use-c.ss"
(lambda ()
(pretty-print
'(library (testfile-lm-use-c)
(export x)
(import (scheme) (testfile-lm-c))
(define-syntax (x x) c))))
'replace)
#t)
(equal?
(separate-eval
'(import-notify #t)
'(compile-library "testfile-lm-a"))
(string-append
"compiling testfile-lm-a.ss with output to testfile-lm-a.so\n"
"ct-a rhs\n"))
(equal?
(separate-eval
'(import-notify #t)
'(library-extensions '((".ss" . ".so")))
'(compile-library "testfile-lm-b")
'(printf "b = ~s\n" (let () (import (testfile-lm-b)) b)))
(string-append
"compiling testfile-lm-b.ss with output to testfile-lm-b.so\n"
"import: found source file \"testfile-lm-a.ss\"\n"
"import: found corresponding object file \"testfile-lm-a.so\"\n"
"import: object file is not older\n"
"import: visiting object file \"testfile-lm-a.so\"\n"
"ct-a rhs\n"
"b = \"odd\"\n"))
(equal?
(separate-eval
'(import-notify #t)
'(library-extensions '((".ss" . ".so")))
'(compile-library "testfile-lm-c")
'(printf "c = ~s\n" (let () (import (testfile-lm-c)) c)))
(string-append
"compiling testfile-lm-c.ss with output to testfile-lm-c.so\n"
"import: found source file \"testfile-lm-a.ss\"\n"
"import: found corresponding object file \"testfile-lm-a.so\"\n"
"import: object file is not older\n"
"import: visiting object file \"testfile-lm-a.so\"\n"
"attempting to 'revisit' previously 'visited' \"testfile-lm-a.so\" for library (testfile-lm-a) run-time info\n"
"rt-a rhs\n"
"c = 456\n"))
(equal?
;; library manager revisits object file containing a single library
;; to resolve dependencies after earlier visit
(separate-eval
'(import-notify #t)
'(library-extensions '((".ss" . ".so")))
'(visit "testfile-lm-a.so")
'(let () (import (testfile-lm-c)) c))
(string-append
"import: found source file \"testfile-lm-c.ss\"\n"
"import: found corresponding object file \"testfile-lm-c.so\"\n"
"import: object file is not older\n"
"import: visiting object file \"testfile-lm-c.so\"\n"
"import: attempting to 'revisit' previously 'visited' \"testfile-lm-c.so\" for library (testfile-lm-c) run-time info\n"
"import: attempting to 'revisit' previously 'visited' \"testfile-lm-a.so\" for library (testfile-lm-a) run-time info\n"
"rt-a rhs\n"
"456\n"))
(equal?
;; library manager visits object file containing a single library
;; to resolve dependencies after earlier revisit
(separate-eval
'(import-notify #t)
'(library-extensions '((".ss" . ".so")))
'(revisit "testfile-lm-a.so")
'(let () (import (testfile-lm-b)) b))
(string-append
"import: found source file \"testfile-lm-b.ss\"\n"
"import: found corresponding object file \"testfile-lm-b.so\"\n"
"import: object file is not older\n"
"import: visiting object file \"testfile-lm-b.so\"\n"
"import: attempting to 'visit' previously 'revisited' \"testfile-lm-a.so\" for library (testfile-lm-a) compile-time info\n"
"import: attempting to 'revisit' previously 'visited' \"testfile-lm-b.so\" for library (testfile-lm-b) run-time info\n"
"\"odd\"\n"))
(equal?
(separate-eval
'(import-notify #t)
'(library-extensions '((".ss" . ".so")))
'(compile-file "testfile-lm-combined"))
(string-append
"compiling testfile-lm-combined.ss with output to testfile-lm-combined.so\n"
"ct-a rhs\n"))
(equal?
;; library manager revisits object file containing related libraries
;; to resolve dependencies after earlier visit
(separate-eval
'(import-notify #t)
'(visit "testfile-lm-combined.so")
'(let ()
(import (testfile-lm-a))
(define-syntax (foo x) ct-a)
(printf "foo = ~s\n" foo))
'(let () (import (testfile-lm-c)) c))
(string-append
"ct-a rhs\n"
"foo = 123\n"
"import: attempting to 'revisit' previously 'visited' \"testfile-lm-combined.so\" for library (testfile-lm-c) run-time info\n"
"rt-a rhs\n"
"456\n"))
(equal?
;; library manager visits object file containing related libraries
;; to resolve dependencies after earlier revisit
(separate-eval
'(import-notify #t)
'(revisit "testfile-lm-combined.so")
'(let ()
(import (testfile-lm-a))
(define foo rt-a)
(printf "foo = ~s\n" foo))
'(let () (import (testfile-lm-b)) b))
(string-append
"import: attempting to 'visit' previously 'revisited' \"testfile-lm-combined.so\" for library (testfile-lm-a) compile-time info\n"
"rt-a rhs\n"
"foo = 456\n"
"\"odd\"\n"))
(equal?
;; library manager does not revisit due to earlier load
(separate-eval
'(import-notify #t)
'(load "testfile-lm-combined.so")
'(let ()
(import (testfile-lm-a))
(define-syntax (foo x) ct-a)
(printf "foo = ~s\n" foo))
'(let () (import (testfile-lm-c)) c))
(string-append
"ct-a rhs\n"
"foo = 123\n"
"rt-a rhs\n"
"456\n"))
(equal?
;; library manager does not revisit due to earlier load
(separate-eval
'(import-notify #t)
'(load "testfile-lm-combined.so")
'(let ()
(import (testfile-lm-a))
(define foo rt-a)
(printf "foo = ~s\n" foo))
'(let () (import (testfile-lm-b)) b))
(string-append
"rt-a rhs\n"
"foo = 456\n"
"\"odd\"\n"))
)
(mat verify-loadability
(error? ; invalid argument
(verify-loadability 'never))
(error? ; invalid argument
(verify-loadability 'never "hello.so"))
(error? ; invalid argument
(verify-loadability #f "hello.so" "goodbye.so"))
(error? ; invalid argument
(verify-loadability 'load 'hello))
(error? ; invalid argument
(verify-loadability 'load '(a . "testdir")))
(error? ; invalid argument
(verify-loadability 'load '#("a" "testdir")))
(error? ; invalid argument
(verify-loadability 'load "testfile1.so" "testfile2.so" 'hello))
(error? ; invalid argument
(verify-loadability 'load "testfile1.so" "testfile2.so" '(a . "testdir")))
(error? ; invalid argument
(verify-loadability 'load '("a" . hello)))
(error? ; invalid argument
(verify-loadability 'load '("a" . ("src" . "obj"))))
(error? ; invalid argument
(verify-loadability 'load '("a" . (("src" "obj")))))
(error? ; invalid argument
(verify-loadability 'load '("a" . ((("src" "obj"))))))
(begin
(define install
(lambda (dir . fn*)
(for-each
(lambda (fn)
(call-with-port (open-file-input-port fn)
(lambda (ip)
(call-with-port (open-file-output-port (format "~a/~a" dir (path-last fn)))
(lambda (op)
(put-bytevector op (get-bytevector-all ip)))))))
fn*)))
#t)
(eq? (verify-loadability 'visit) (void))
(eq? (verify-loadability 'revisit) (void))
(eq? (verify-loadability 'load) (void))
(error? ; not found
(verify-loadability 'load "probably not found"))
(begin
(mkfile "testfile-clA.ss"
'(import (chezscheme) (testfile-clB) (testfile-clC))
'(printf "~a, ~a\n" b c))
(mkfile "testfile-clB.ss"
'(library (testfile-clB)
(export b)
(import (chezscheme) (testfile-clB1))
(define-syntax go (lambda (x) (datum->syntax #'* (b1))))
(define b (go))))
(mkfile "testfile-clB1.ss"
'(library (testfile-clB1)
(export b1)
(import (chezscheme))
(define b1 (lambda () "hello from B1"))))
(mkfile "testfile-clC.ss"
'(library (testfile-clC)
(export c)
(import (chezscheme) (testfile-clC1))
(define c (c1))))
(mkfile "testfile-clC1.ss"
'(library (testfile-clC1)
(export c1)
(import (chezscheme))
(define-syntax c1 (syntax-rules () [(_) "hello from C1"]))))
(rm-rf "testdir-obj1")
(rm-rf "testdir-obj2")
(mkdir "testdir-obj1")
(mkdir "testdir-obj2")
(separate-eval
'(parameterize ([library-directories '(("." . "testdir-obj1"))] [compile-imported-libraries #t])
(compile-program "testfile-clA.ss" "testdir-obj1/testfile-clA.so")))
(separate-eval
'(parameterize ([library-directories '(("." . "testdir-obj2"))] [compile-imported-libraries #t])
(compile-program "testfile-clA.ss" "testdir-obj2/testfile-clA.so")))
#t)
(begin
(rm-rf "testdir-dist1")
(mkdir "testdir-dist1")
(install "testdir-dist1" "testdir-obj1/testfile-clA.so" "testdir-obj1/testfile-clB.so" "testdir-obj1/testfile-clC.so")
#t)
(eqv?
(separate-eval
'(parameterize ([cd "testdir-dist1"])
(verify-loadability 'visit "testfile-clA.so")
(verify-loadability 'revisit "testfile-clA.so")
(verify-loadability 'load "testfile-clA.so")))
"")
(equal?
(separate-eval
'(parameterize ([cd "testdir-dist1"])
(load-program "testfile-clA.so")))
"hello from B1, hello from C1\n")
(error? ; missing B1
(separate-eval
'(parameterize ([cd "testdir-dist1"])
(verify-loadability 'visit "testfile-clB.so"))))
(error? ; missing B1
(separate-eval
'(parameterize ([cd "testdir-dist1"])
(verify-loadability 'load "testfile-clB.so"))))
(error? ; missing C1
(separate-eval
'(parameterize ([cd "testdir-dist1"])
(verify-loadability 'visit "testfile-clC.so"))))
(error? ; missing C1
(separate-eval
'(parameterize ([cd "testdir-dist1"])
(verify-loadability 'load "testfile-clC.so"))))
(begin
(rm-rf "testdir-dist2")
(mkdir "testdir-dist2")
(install "testdir-dist2" "testdir-obj2/testfile-clA.so" "testdir-obj2/testfile-clB.so" "testdir-obj2/testfile-clC.so")
#t)
(equal?
(separate-eval
'(parameterize ([cd "testdir-dist2"])
(load-program "testfile-clA.so")))
"hello from B1, hello from C1\n")
(error? ; mismatched compilation instance
(separate-eval
'(verify-loadability 'revisit
'("testdir-dist1/testfile-clA.so" . "testdir-dist1")
'("testdir-dist2/testfile-clA.so" . "testdir-dist2"))))
(error? ; mismatched compilation instance
(separate-eval
'(verify-loadability 'load
'("testdir-dist1/testfile-clA.so" . "testdir-dist1")
'("testdir-dist2/testfile-clA.so" . "testdir-dist2"))))
(begin
(rm-rf "testdir-dist3")
(mkdir "testdir-dist3")
(install "testdir-dist3" "testdir-obj1/testfile-clA.so" "testdir-obj1/testfile-clB.so" "testdir-obj2/testfile-clC.so")
#t)
(error? ; mismatched compilation instance
(separate-eval
'(parameterize ([cd "testdir-dist3"])
(load-program "testfile-clA.so"))))
(eqv? ; no compile-time requirements, so no problem
(separate-eval
'(parameterize ([cd "testdir-dist3"])
(verify-loadability 'visit "testfile-clA.so")))
"")
(error? ; mismatched compilation instance
(separate-eval
'(parameterize ([cd "testdir-dist3"])
(verify-loadability 'revisit "testfile-clA.so"))))
(error? ; mismatched compilation instance
(separate-eval
'(parameterize ([cd "testdir-dist3"])
(verify-loadability 'load "testfile-clA.so"))))
(equal?
(separate-eval
'(parameterize ([cd "testdir-dist3"])
(unless (guard (c [else (printf "yes\n")]) (verify-loadability 'load "testfile-clA.so") #f)
(errorf #f "oops")))
'(parameterize ([cd "testdir-dist1"])
(printf "~s\n" (verify-loadability 'load "testfile-clA.so")))
'(parameterize ([cd "testdir-dist2"])
(printf "~s\n" (verify-loadability 'load "testfile-clA.so")))
'(let* ([ls (library-list)] [f (lambda (x) (and (member x ls) #t))])
(printf "~s\n" (map f '((testfile-clB) (testfile-clB1) (testfile-clC) (testfile-clC1)))))
'(parameterize ([cd "testdir-dist1"])
(load-program "testfile-clA.so"))
'(let* ([ls (library-list)] [f (lambda (x) (and (member x ls) #t))])
(printf "~s\n" (map f '((testfile-clB) (testfile-clB1) (testfile-clC) (testfile-clC1))))))
"yes\n#<void>\n#<void>\n(#f #f #f #f)\nhello from B1, hello from C1\n(#t #f #t #f)\n")
(equal?
(separate-eval
'(parameterize ([cd "testdir-dist3"])
(unless (guard (c [else (printf "yes\n")]) (verify-loadability 'load "testfile-clA.so") #f)
(errorf #f "oops")))
'(parameterize ([cd "testdir-dist1"])
(printf "~s\n" (verify-loadability 'load "testfile-clA.so")))
'(parameterize ([cd "testdir-dist2"])
(printf "~s\n" (verify-loadability 'load "testfile-clA.so")))
'(let* ([ls (library-list)] [f (lambda (x) (and (member x ls) #t))])
(printf "~s\n" (map f '((testfile-clB) (testfile-clB1) (testfile-clC) (testfile-clC1)))))
'(parameterize ([cd "testdir-dist2"])
(load-program "testfile-clA.so"))
'(let* ([ls (library-list)] [f (lambda (x) (and (member x ls) #t))])
(printf "~s\n" (map f '((testfile-clB) (testfile-clB1) (testfile-clC) (testfile-clC1))))))
"yes\n#<void>\n#<void>\n(#f #f #f #f)\nhello from B1, hello from C1\n(#t #f #t #f)\n")
(error? ; mismatched compilation instance
(separate-eval
'(parameterize ([library-directories '(("testdir-dist1" . "testdir-dist1"))])
(verify-loadability 'load "testdir-dist2/testfile-clA.so"))))
(error? ; mismatched compilation instance
(separate-eval
'(parameterize ([library-directories '(("testdir-dist1" . "testdir-dist1"))])
(verify-loadability 'load "testdir-dist1/testfile-clA.so" "testdir-dist2/testfile-clA.so"))))
(begin
(mkfile "testfile-clPD.ss"
'(import (chezscheme) (testfile-clD))
'(printf "~s\n" (make-Q)))
(mkfile "testfile-clPE.ss"
'(import (chezscheme) (testfile-clE))
'(printf "~s\n" (make-Q 73)))
(mkfile "testfile-clD.ss"
'(library (testfile-clD) (export make-Q Q? Q-x) (import (chezscheme) (testfile-clF))
(define-record-type Q
(nongenerative Q)
(fields x)
(protocol (lambda (new) (lambda () (new f)))))))
(mkfile "testfile-clE.ss"
'(library (testfile-clE) (export make-Q Q? Q-x) (import (chezscheme) (testfile-clG))
(define-record-type Q
(nongenerative Q)
(fields x y)
(protocol (lambda (new) (lambda (y) (new g y)))))))
(mkfile "testfile-clF.ss"
'(library (testfile-clF) (export f) (import (chezscheme)) (define f 77)))
(mkfile "testfile-clG.ss"
'(library (testfile-clG) (export g) (import (chezscheme)) (define g 123)))
(rm-rf "testdir-obj")
(mkdir "testdir-obj")
(separate-eval
'(parameterize ([library-directories '(("." . "testdir-obj"))] [compile-imported-libraries #t])
(compile-program "testfile-clPD.ss" "testdir-obj/testfile-clPD.so")))
(separate-eval
'(parameterize ([library-directories '(("." . "testdir-obj"))] [compile-imported-libraries #t])
(compile-program "testfile-clPE.ss" "testdir-obj/testfile-clPE.so")))
#t)
(begin
(rm-rf "testdir-dist")
(mkdir "testdir-dist")
(install "testdir-dist" "testdir-obj/testfile-clPD.so" "testdir-obj/testfile-clD.so" "testdir-obj/testfile-clF.so")
(install "testdir-dist" "testdir-obj/testfile-clPE.so" "testdir-obj/testfile-clE.so" "testdir-obj/testfile-clG.so")
#t)
(error? ; incompatible record-type Q
(separate-eval
'(cd "testdir-dist")
'(load-program "testfile-clPD.so")
'(load-program "testfile-clPE.so")))
(equal?
(separate-eval
'(cd "testdir-dist")
'(verify-loadability 'visit "testfile-clPD.so" "testfile-clPE.so")
'(verify-loadability 'visit "testfile-clD.so" "testfile-clE.so")
'(verify-loadability 'visit "testfile-clF.so" "testfile-clG.so")
'(verify-loadability 'revisit "testfile-clPD.so" "testfile-clPE.so")
'(verify-loadability 'revisit "testfile-clD.so" "testfile-clE.so")
'(verify-loadability 'revisit "testfile-clF.so" "testfile-clG.so")
'(verify-loadability 'load "testfile-clPD.so" "testfile-clPE.so")
'(verify-loadability 'load "testfile-clD.so" "testfile-clE.so")
'(verify-loadability 'load "testfile-clF.so" "testfile-clG.so")
'(verify-loadability 'load "testfile-clPD.so" "testfile-clPE.so" "testfile-clD.so" "testfile-clE.so" "testfile-clF.so" "testfile-clG.so")
'(load-program "testfile-clPD.so")
'(verify-loadability 'load "testfile-clPD.so" "testfile-clE.so"))
"#[Q 77]\n")
(equal?
(separate-eval
'(cd "testdir-dist")
'(verify-loadability 'visit "testfile-clPD.so" "testfile-clE.so")
'(verify-loadability 'visit "testfile-clD.so" "testfile-clE.so")
'(verify-loadability 'visit "testfile-clF.so" "testfile-clG.so")
'(verify-loadability 'revisit "testfile-clPD.so" "testfile-clE.so")
'(verify-loadability 'revisit "testfile-clD.so" "testfile-clE.so")
'(verify-loadability 'revisit "testfile-clF.so" "testfile-clG.so")
'(verify-loadability 'load "testfile-clPD.so" "testfile-clE.so")
'(verify-loadability 'load "testfile-clD.so" "testfile-clE.so")
'(verify-loadability 'load "testfile-clF.so" "testfile-clG.so")
'(verify-loadability 'load "testfile-clPD.so" "testfile-clPE.so" "testfile-clD.so" "testfile-clE.so" "testfile-clF.so" "testfile-clG.so")
'(load-program "testfile-clPE.so")
'(verify-loadability 'load "testfile-clPD.so" "testfile-clE.so"))
"#[Q 123 73]\n")
(begin
(mkfile "testfile-clH0.ss"
'(library (testfile-clH0) (export h0) (import (chezscheme))
(define h0 (lambda (x) (cons x 'a)))))
(mkfile "testfile-clH1.ss"
'(top-level-program
(import (chezscheme) (testfile-clH0))
(printf "~s\n" (h0 73))))
(mkfile "testfile-clH2.ss"
'(include "testfile-clH0.ss")
'(top-level-program
(import (chezscheme) (testfile-clH0))
(printf "~s\n" (h0 37))))
(rm-rf "testdir-obj")
(mkdir "testdir-obj")
(separate-eval
'(parameterize ([library-directories '(("." . "testdir-obj"))] [compile-imported-libraries #t])
(compile-file "testfile-clH1.ss" "testdir-obj/testfile-clH1.so")))
(separate-eval
'(parameterize ([library-directories '(("." . "testdir-obj"))] [compile-imported-libraries #t])
(compile-file "testfile-clH2.ss" "testdir-obj/testfile-clH2.so")))
#t)
(equal?
(separate-eval
'(parameterize ([library-directories '(("testdir-obj" . "testdir-obj"))])
(revisit "testdir-obj/testfile-clH1.so")))
"(73 . a)\n")
(equal?
(separate-eval
'(parameterize ([library-directories '(("testdir-obj" . "testdir-obj"))])
(revisit "testdir-obj/testfile-clH2.so")))
"(37 . a)\n")
(eqv?
(separate-eval
'(let ([libdirs '(("testdir-obj" . "testdir-obj"))])
(verify-loadability 'revisit (cons "testdir-obj/testfile-clH1.so" libdirs) (cons "testdir-obj/testfile-clH2.so" libdirs))))
"")
(error? ; mismatched compilation instance
(separate-eval
'(let ([libdirs '(("testdir-obj" . "testdir-obj"))])
(verify-loadability 'revisit (cons "testdir-obj/testfile-clH2.so" libdirs) (cons "testdir-obj/testfile-clH1.so" libdirs)))))
; make sure verify-loadability respects eval-when forms
(begin
(mkfile "testfile-clI0.ss"
'(library (testfile-clI0) (export x) (import (chezscheme)) (define x 10) (printf "invoking I0\n")))
(mkfile "testfile-clI1.ss"
'(eval-when (visit)
(top-level-program
(import (chezscheme) (testfile-clI0))
(printf "running I1, x = ~s\n" x))))
(separate-eval
'(parameterize ([compile-imported-libraries #t])
(compile-file "testfile-clI1")))
#t)
(equal?
(separate-eval '(visit "testfile-clI1.so"))
"invoking I0\nrunning I1, x = 10\n")
(equal?
(separate-eval '(revisit "testfile-clI1.so"))
"")
(equal?
(separate-eval '(load "testfile-clI1.so"))
"invoking I0\nrunning I1, x = 10\n")
(eq?
(verify-loadability 'visit "testfile-clI1.so")
(void))
(eq?
(verify-loadability 'revisit "testfile-clI1.so")
(void))
(eq?
(verify-loadability 'load "testfile-clI1.so")
(void))
(delete-file "testfile-clI0.ss")
(delete-file "testfile-clI0.so")
(error?
(verify-loadability 'visit "testfile-clI1.so"))
(eq?
(verify-loadability 'revisit "testfile-clI1.so")
(void))
(error?
(verify-loadability 'load "testfile-clI1.so"))
; make sure compile-whole-program preserves the information verify-loadability needs
(begin
(mkfile "testfile-clJ0.ss"
'(library (testfile-clJ0) (export x0) (import (chezscheme)) (define x0 'eat) (printf "invoking J0\n")))
(mkfile "testfile-clJ1.ss"
'(library (testfile-clJ1) (export x1) (import (chezscheme) (testfile-clJ0)) (define x1 (list x0 'oats)) (printf "invoking J1\n")))
(mkfile "testfile-clJ2.ss"
'(library (testfile-clJ2) (export x2) (import (chezscheme) (testfile-clJ1)) (define x2 (cons 'mares x1)) (printf "invoking J2\n")))
(mkfile "testfile-clJ3.ss"
'(import (chezscheme) (testfile-clJ2))
'(printf "running J3, x2 = ~s\n" x2))
(separate-eval
'(parameterize ([compile-imported-libraries #t] [generate-wpo-files #t])
(compile-program "testfile-clJ3")))
#t)
(equal?
(separate-eval '(verify-loadability 'load "testfile-clJ3.so"))
"")
(equal?
(separate-eval '(load-program "testfile-clJ3.so"))
"invoking J0\ninvoking J1\ninvoking J2\nrunning J3, x2 = (mares eat oats)\n")
(delete-file "testfile-clJ0.ss")
(delete-file "testfile-clJ0.wpo")
(delete-file "testfile-clJ2.ss")
(delete-file "testfile-clJ2.wpo")
((lambda (x ls) (and (member x ls) #t))
(separate-eval
'(compile-whole-program "testfile-clJ3.wpo" "testfile-clJ3-all.so"))
'("((testfile-clJ0) (testfile-clJ2))\n"
"((testfile-clJ2) (testfile-clJ0))\n"))
(delete-file "testfile-clJ1.ss")
(delete-file "testfile-clJ1.wpo")
(delete-file "testfile-clJ1.so")
(equal?
(separate-eval '(verify-loadability 'load "testfile-clJ3-all.so"))
"")
(equal?
(separate-eval '(load-program "testfile-clJ3-all.so"))
"invoking J0\ninvoking J1\ninvoking J2\nrunning J3, x2 = (mares eat oats)\n")
(eq?
(rename-file "testfile-clJ0.so" "testfile-clJ0.sav")
(void))
(error? ; missing testfile-clJ0.so
(separate-eval '(verify-loadability 'load "testfile-clJ3-all.so")))
(error? ; missing testfile-clJ0.so
(separate-eval '(load-program "testfile-clJ3-all.so")))
(eq?
(rename-file "testfile-clJ0.sav" "testfile-clJ0.so")
(void))
(delete-file "testfile-clJ2.so")
(error? ; missing testfile-clJ2.so
(separate-eval '(verify-loadability 'load "testfile-clJ3-all.so")))
(error? ; missing testfile-clJ2.so
(separate-eval '(load-program "testfile-clJ3-all.so")))
(begin
(mkfile "testfile-clK0.ss"
'(library (testfile-clK0) (export x0) (import (chezscheme)) (define x0 "chocolate") (printf "invoking K0\n")))
(mkfile "testfile-clK1.ss"
'(library (testfile-clK1) (export x1) (import (chezscheme) (testfile-clK0)) (define x1 (format "~a chip" x0)) (printf "invoking K1\n")))
(mkfile "testfile-clK2.ss"
'(import (chezscheme) (testfile-clK1))
'(printf "running K2, x1 = ~s\n" x1))
(separate-eval
'(parameterize ([compile-imported-libraries #t])
(compile-program "testfile-clK2")))
#t)
(eq?
(verify-loadability 'visit "testfile-clK1.so")
(void))
(eq?
(verify-loadability 'revisit "testfile-clK1.so")
(void))
(eq?
(verify-loadability 'load "testfile-clK1.so")
(void))
(eq?
(verify-loadability 'visit "testfile-clK1.so" "testfile-clK2.so")
(void))
(eq?
(verify-loadability 'revisit "testfile-clK1.so" "testfile-clK2.so")
(void))
(eq?
(verify-loadability 'load "testfile-clK1.so" "testfile-clK2.so")
(void))
(eq?
(verify-loadability 'visit "testfile-clK2.so" "testfile-clK1.so")
(void))
(eq?
(verify-loadability 'revisit "testfile-clK2.so" "testfile-clK1.so")
(void))
(eq?
(verify-loadability 'load "testfile-clK2.so" "testfile-clK1.so")
(void))
(equal?
(separate-eval
'(visit "testfile-clK1.so")
'(let () (import (testfile-clK1)) x1))
"invoking K0\ninvoking K1\n\"chocolate chip\"\n")
(equal?
(separate-eval '(revisit "testfile-clK2.so"))
"invoking K0\ninvoking K1\nrunning K2, x1 = \"chocolate chip\"\n")
(eq?
(strip-fasl-file "testfile-clK0.so" "testfile-clK0.so"
(fasl-strip-options compile-time-information))
(void))
(error? ; missing compile-time info for K0
(verify-loadability 'visit "testfile-clK1.so"))
(eq?
(verify-loadability 'revisit "testfile-clK1.so")
(void))
(error? ; missing compile-time info for K0
(verify-loadability 'load "testfile-clK1.so"))
(error? ; missing compile-time info
(separate-eval
'(visit "testfile-clK1.so")
'(let () (import (testfile-clK1)) x1)))
(equal?
(separate-eval '(revisit "testfile-clK2.so"))
"invoking K0\ninvoking K1\nrunning K2, x1 = \"chocolate chip\"\n")
)
(mat concatenate-object-files
(begin
(define install
(lambda (dir . fn*)
(for-each
(lambda (fn)
(call-with-port (open-file-input-port fn)
(lambda (ip)
(call-with-port (open-file-output-port (format "~a/~a" dir (path-last fn)))
(lambda (op)
(put-bytevector op (get-bytevector-all ip)))))))
fn*)))
(define test-isolated-load
(lambda (fn lib val)
(rm-rf "testdir-isolated")
(mkdir "testdir-isolated")
(install "testdir-isolated" fn)
(separate-eval
`(cd "testdir-isolated")
`(load ,fn)
`(let ()
(import ,lib)
,val))))
#t)
(begin
(mkfile "testfile-catlibA.ss"
'(library (testfile-catlibA)
(export a)
(import (chezscheme))
(define a 1)))
(mkfile "testfile-catlibB.ss"
'(library (testfile-catlibB)
(export a b)
(import (chezscheme) (testfile-catlibA))
(define b 2)))
(mkfile "testfile-catlibC.ss"
'(library (testfile-catlibC)
(export c)
(import (chezscheme) (testfile-catlibB))
(define c (+ a b))))
(separate-eval
'(compile-library "testfile-catlibA.ss" "testfile-catlibA.so"))
(separate-eval
'(compile-library "testfile-catlibB.ss" "testfile-catlibB.so"))
(separate-eval
'(compile-library "testfile-catlibC.ss" "testfile-catlibC.so"))
#t)
(eqv?
(separate-eval
'(begin
(concatenate-object-files "testfile-catlibAB.so" "testfile-catlibA.so" "testfile-catlibB.so")
(concatenate-object-files "testfile-catlibBC.so" "testfile-catlibB.so" "testfile-catlibC.so")
(concatenate-object-files "testfile-catlibABC.so" "testfile-catlibA.so" "testfile-catlibB.so" "testfile-catlibC.so")))
"")
(equal?
(test-isolated-load "testfile-catlibA.so" '(testfile-catlibA) 'a)
"1\n")
(error? ; can't find (testfile-catlibA)
(test-isolated-load "testfile-catlibB.so" '(testfile-catlibB) 'b))
(error? ; can't find (testfile-catlibA)
(test-isolated-load "testfile-catlibBC.so" '(testfile-catlibC) 'c))
(equal?
(test-isolated-load "testfile-catlibABC.so" '(testfile-catlibA) 'a)
"1\n")
(equal?
(test-isolated-load "testfile-catlibABC.so" '(testfile-catlibB) 'b)
"2\n")
(equal?
(test-isolated-load "testfile-catlibABC.so" '(testfile-catlibC) 'c)
"3\n")
(equal?
(test-isolated-load "testfile-catlibAB.so" '(testfile-catlibB) 'b)
"2\n")
(begin
(mkfile "testfile-cof1A.ss"
'(library (testfile-cof1A) (export a) (import (chezscheme))
(define-syntax a (identifier-syntax 45))))
(mkfile "testfile-cof1B.ss"
'(library (testfile-cof1B) (export b) (import (chezscheme) (testfile-cof1A))
(define b (lambda () (* a 2)))))
(mkfile "testfile-cof1P.ss"
'(import (chezscheme) (testfile-cof1A) (testfile-cof1B))
'(printf "a = ~s, (b) = ~s\n" a (b)))
(mkfile "testfile-cof1foo.ss"
'(printf "hello from foo!\n"))
(mkfile "testfile-cof1bar.ss"
'(printf "hello from bar!\n"))
(parameterize ([compile-imported-libraries #t]) (compile-program "testfile-cof1P"))
(compile-file "testfile-cof1foo")
(compile-file "testfile-cof1bar")
(let ()
(define fake-concatenate-object-files
(lambda (outfn infn . infn*)
(call-with-port (open-file-output-port outfn (file-options #;compressed replace))
(lambda (op)
(for-each
(lambda (infn)
(put-bytevector op
(call-with-port (open-file-input-port infn (file-options #;compressed)) get-bytevector-all)))
(cons infn infn*))))))
(fake-concatenate-object-files "testfile-cof1fooP.so" "testfile-cof1foo.so" "testfile-cof1P.so")
(fake-concatenate-object-files "testfile-cof1barB.so" "testfile-cof1bar.so" "testfile-cof1B.so"))
#t)
; using separate-eval since A and B already loaded in the compiling process:
(equal?
(separate-eval '(load "testfile-cof1fooP.so"))
"hello from foo!\na = 45, (b) = 90\n")
(equal?
(separate-eval
'(load "testfile-cof1barB.so")
'(printf "~s\n" (and (member '(testfile-cof1B) (library-list)) 'yes)))
"hello from bar!\nyes\n")
(equal? (separate-eval '(verify-loadability 'visit "testfile-cof1barB.so")) "")
(equal? (separate-eval '(verify-loadability 'revisit "testfile-cof1barB.so")) "")
(delete-file "testfile-cof1A.so")
; NB: this should be an error, but isn't because we're using the fake concatenate-object-files
(equal? (separate-eval '(verify-loadability 'visit "testfile-cof1barB.so")) "") ; requires testfile-cof1A.so
(equal? (separate-eval '(verify-loadability 'revisit "testfile-cof1barB.so")) "") ; doesn't require testfile-cof1A.so
(equal? (separate-eval '(verify-loadability 'visit "testfile-cof1fooP.so")) "") ; doesn't require testfile-cof1A.so
(equal? (separate-eval '(verify-loadability 'revisit "testfile-cof1fooP.so")) "") ; doesn't require testfile-cof1A.so
(delete-file "testfile-cof1B.so")
(equal? (separate-eval '(verify-loadability 'visit "testfile-cof1fooP.so")) "") ; doesn't require testfile-cof1A.so or testfile-cof1B.so
; NB: this should be an error, but isn't because we're using the fake concatenate-object-files
(equal? (separate-eval '(verify-loadability 'revisit "testfile-cof1fooP.so")) "") ; requires testfile-cof1B.so
; now with the real concatenate-object-files
(begin
(separate-eval '(parameterize ([compile-imported-libraries #t]) (compile-program "testfile-cof1P")))
(concatenate-object-files "testfile-cof1fooP.so" "testfile-cof1foo.so" "testfile-cof1P.so")
(concatenate-object-files "testfile-cof1barB.so" "testfile-cof1bar.so" "testfile-cof1B.so")
#t)
; using separate-eval since A and B already loaded in the compiling process:
(equal?
(separate-eval '(load "testfile-cof1fooP.so"))
"hello from foo!\na = 45, (b) = 90\n")
(equal?
(separate-eval
'(load "testfile-cof1barB.so")
'(printf "~s\n" (and (member '(testfile-cof1B) (library-list)) 'yes)))
"hello from bar!\nyes\n")
(equal? (separate-eval '(verify-loadability 'visit "testfile-cof1barB.so")) "")
(equal? (separate-eval '(verify-loadability 'revisit "testfile-cof1barB.so")) "")
(delete-file "testfile-cof1A.so")
(error? (separate-eval '(verify-loadability 'visit "testfile-cof1barB.so"))) ; requires testfile-cof1A.so
(equal? (separate-eval '(verify-loadability 'revisit "testfile-cof1barB.so")) "") ; doesn't require testfile-cof1A.so
(equal? (separate-eval '(verify-loadability 'visit "testfile-cof1fooP.so")) "") ; doesn't require testfile-cof1A.so
(equal? (separate-eval '(verify-loadability 'revisit "testfile-cof1fooP.so")) "") ; doesn't require testfile-cof1A.so
(delete-file "testfile-cof1B.so")
(equal? (separate-eval '(verify-loadability 'visit "testfile-cof1fooP.so")) "") ; doesn't require testfile-cof1A.so or testfile-cof1B.so
(error? (separate-eval '(verify-loadability 'revisit "testfile-cof1fooP.so"))) ; requires testfile-cof1B.so
)
;;; section 7.2:
(mat top-level-value-functions
(error? (top-level-bound? "hello"))
(error? (top-level-bound?))
(error? (top-level-bound? 45 'hello))
(error? (top-level-bound? 'hello 'hello))
(error? (top-level-bound? (scheme-environment) (scheme-environment)))
(error? (top-level-mutable? "hello"))
(error? (top-level-mutable?))
(error? (top-level-mutable? 45 'hello))
(error? (top-level-mutable? 'hello 'hello))
(error? (top-level-mutable? (scheme-environment) (scheme-environment)))
(error? (top-level-value "hello"))
(error? (top-level-value))
(error? (top-level-value 'hello 'hello))
(error? (top-level-value (scheme-environment) (scheme-environment)))
(error? (set-top-level-value! "hello" "hello"))
(error? (set-top-level-value!))
(error? (set-top-level-value! 15))
(error? (set-top-level-value! 'hello 'hello 'hello))
(error? (set-top-level-value! (scheme-environment) (scheme-environment) (scheme-environment)))
(error? (define-top-level-value "hello" "hello"))
(error? (define-top-level-value))
(error? (define-top-level-value 15))
(error? (define-top-level-value 'hello 'hello 'hello))
(error? (define-top-level-value (scheme-environment) (scheme-environment) (scheme-environment)))
(top-level-bound? 'cons (scheme-environment))
(not (top-level-mutable? 'cons (scheme-environment)))
(eq? (top-level-bound? 'probably-not-bound (scheme-environment)) #f)
(equal? (top-level-value 'top-level-value) top-level-value)
(equal?
(parameterize ([interaction-environment
(copy-environment (scheme-environment) #t)])
(eval '(define cons *))
(eval
'(list
(cons 3 4)
(fluid-let ([cons list])
(list (cons 1 2)
((top-level-value 'cons) 1 2)
((top-level-value 'cons (scheme-environment)) 1 2)
(top-level-mutable? 'cons)
(top-level-mutable? 'cons (scheme-environment))
(top-level-mutable? 'car)
(top-level-mutable? 'car (scheme-environment)))))))
'(12 ((1 2) (1 2) (1 . 2) #t #f #f #f)))
(let ([abcde 4])
(and (not (top-level-bound? 'abcde))
(begin (define-top-level-value 'abcde 3)
(eqv? (top-level-value 'abcde) 3))
(top-level-bound? 'abcde)
(begin (set-top-level-value! 'abcde 9)
(eqv? (top-level-value 'abcde) 9))
(eqv? abcde 4)))
(eqv? abcde 9)
(let ([x (gensym)])
(and (not (top-level-bound? x))
(begin (define-top-level-value x 'hi)
(eq? (top-level-value x) 'hi))
(top-level-bound? x)
(begin (set-top-level-value! x 'there)
(eq? (top-level-value x) 'there))
(eq? (eval x) 'there)))
(error? (top-level-value 'i-am-not-bound-i-hope))
(error? (top-level-value 'let))
(equal?
(parameterize ([interaction-environment
(copy-environment (scheme-environment) #t)])
(eval '(define cons (let () (import scheme) cons)))
(eval
'(fluid-let ([cons 'notcons])
(list (top-level-value 'cons)
(parameterize ([optimize-level 0]) (eval 'cons))
(parameterize ([interaction-environment (scheme-environment)])
((top-level-value 'cons) 3 4))))))
'(notcons notcons (3 . 4)))
(error? (set-top-level-value! 'let 45))
(error? (parameterize ([interaction-environment (scheme-environment)])
(eval '(define let 45) (scheme-environment))))
(error? (parameterize ([interaction-environment (scheme-environment)])
(eval '(set! let 45) (scheme-environment))))
(error? (parameterize ([interaction-environment (scheme-environment)])
(define-top-level-value 'let 45)))
(error? (parameterize ([interaction-environment (scheme-environment)])
(set-top-level-value! 'let 45)))
(error? (define-top-level-value 'let 45 (scheme-environment)))
(error? (set-top-level-value! 'let 45 (scheme-environment)))
(error? (parameterize ([interaction-environment (scheme-environment)])
(eval '(define cons 45) (scheme-environment))))
(error? (parameterize ([interaction-environment (scheme-environment)])
(eval '(set! cons 45) (scheme-environment))))
(error? (parameterize ([interaction-environment (scheme-environment)])
(define-top-level-value 'cons 45)))
(error? (parameterize ([interaction-environment (scheme-environment)])
(set-top-level-value! 'cons 45)))
(error? (define-top-level-value 'cons 45 (scheme-environment)))
(error? (set-top-level-value! 'cons 45 (scheme-environment)))
(error? (parameterize ([interaction-environment (scheme-environment)])
(eval '(define foo 45) (scheme-environment))))
(error? (parameterize ([interaction-environment (scheme-environment)])
(eval '(set! foo 45) (scheme-environment))))
(error? (parameterize ([interaction-environment (scheme-environment)])
(define-top-level-value 'foo 45)))
(error? (parameterize ([interaction-environment (scheme-environment)])
(set-top-level-value! 'foo 45)))
(error? (define-top-level-value 'foo 45 (scheme-environment)))
(error? (set-top-level-value! 'foo 45 (scheme-environment)))
(begin
(define-syntax $let (identifier-syntax let))
(equal?
($let ((x 3) (y 4)) (cons x y))
'(3 . 4)))
(eqv? (define-top-level-value '$let 76) (void))
(eqv? (top-level-value '$let) 76)
(eqv? $let 76)
; make sure implicit treatment of top-level identifiers as variables
; works when assignment occurs in loaded object file
(equal?
(begin
(with-output-to-file "testfile.ss"
(lambda () (pretty-print '(set! $fribblefratz 17)))
'replace)
(compile-file "testfile")
(load "testfile.so")
(list (top-level-bound? '$fribblefratz) (top-level-value '$fribblefratz)))
'(#t 17))
(eqv? $fribblefratz 17)
(equal?
(begin
(with-output-to-file "testfile.ss"
(lambda () (pretty-print '(set! $notfribblefratz -17)))
'replace)
; compile in a separate Scheme process
(if (windows?)
(system (format "echo (compile-file \"testfile\") | ~a" (patch-exec-path *scheme*)))
(system (format "echo '(compile-file \"testfile\")' | ~a" *scheme*)))
(load "testfile.so")
(list (top-level-bound? '$notfribblefratz) (top-level-value '$notfribblefratz)))
'(#t -17))
(eqv? $notfribblefratz -17)
)
;;; section 7.3:
(mat new-cafe
(procedure? new-cafe)
(equal?
(guard (c [else #f])
(let ([ip (open-string-input-port "(+ 3 4)")])
(let-values ([(op get) (open-string-output-port)])
(parameterize ([console-input-port ip]
[console-output-port op]
[console-error-port op]
[#%$cafe 0]
[waiter-prompt-string "Huh?"])
(new-cafe))
(get))))
"Huh? 7\nHuh? \n")
(equal?
(guard (c [else #f])
(let ([ip (open-string-input-port "(if)")])
(let-values ([(op get) (open-string-output-port)])
(parameterize ([console-input-port ip]
[console-output-port op]
[console-error-port op]
[#%$cafe 0]
[waiter-prompt-string "Huh?"])
(new-cafe))
(get))))
"Huh? \nException: invalid syntax (if)\nHuh? \n")
(equal?
(separate-eval
`(let ([ip (open-string-input-port "
(base-exception-handler
(lambda (c)
(fprintf (console-output-port) \"~%>>> \")
(display-condition c (console-output-port))
(fprintf (console-output-port) \" <<<~%\")
(reset)))
(if)")])
(let-values ([(op get) (open-string-output-port)])
(parameterize ([console-input-port ip]
[console-output-port op]
[console-error-port op]
[#%$cafe 0]
[waiter-prompt-string "Huh?"])
(new-cafe))
(get))))
"\"Huh? Huh? \\n>>> Exception: invalid syntax (if) <<<\\nHuh? \\n\"\n")
)
(mat reset
(procedure? (reset-handler))
(eqv?
(call/cc
(lambda (k)
(parameterize ([reset-handler (lambda () (k 17))])
(reset))))
17)
(error? ; unexpected return from handler
(guard (c [else (raise-continuable c)])
(parameterize ([reset-handler values])
(reset))))
)
(mat exit
(procedure? (exit-handler))
(eqv?
(call/cc
(lambda (k)
(parameterize ([exit-handler (lambda () (k 17))])
(exit))))
17)
(eqv?
(call/cc
(lambda (k)
(parameterize ([exit-handler (lambda (q) (k 17))])
(exit -1))))
17)
(error? ; unexpected return from handler
(parameterize ([exit-handler values])
(exit)))
(error? ; unexpected return from handler
(parameterize ([exit-handler values])
(exit 5)))
(begin
(define (exit-code expr)
(if (windows?)
(system (format "echo ~s | ~a -q" expr (patch-exec-path *scheme*)))
(system (format "echo '~s' | ~a -q" expr *scheme*))))
#t)
(eqv? (exit-code '(exit)) 0)
(eqv? (exit-code '(exit 15)) 15)
(eqv? (exit-code '(exit 0)) 0)
(eqv? (exit-code '(exit 24 7)) 24)
(eqv? (exit-code '(exit 0 1 2)) 0)
(eqv? (exit-code '(exit 3.14)) 1)
(eqv? (exit-code '(exit 9.8 3.14)) 1)
(begin
(with-output-to-file "testfile-exit.ss"
(lambda ()
(for-each pretty-print
'((import (scheme))
(apply exit (map string->number (command-line-arguments))))))
'replace)
#t)
(eqv? (system (format "~a --script testfile-exit.ss" (patch-exec-path *scheme*))) 0)
(eqv? (system (format "~a --script testfile-exit.ss 5" (patch-exec-path *scheme*))) 5)
(eqv? (system (format "~a --script testfile-exit.ss 0 1 2" (patch-exec-path *scheme*))) 0)
(eqv? (system (format "~a --script testfile-exit.ss 3 4 5" (patch-exec-path *scheme*))) 3)
(eqv? (system (format "~a --program testfile-exit.ss" (patch-exec-path *scheme*))) 0)
(eqv? (system (format "~a --program testfile-exit.ss 2" (patch-exec-path *scheme*))) 2)
(eqv? (system (format "~a --program testfile-exit.ss 0 1 2" (patch-exec-path *scheme*))) 0)
(eqv? (system (format "~a --program testfile-exit.ss 6 7 8" (patch-exec-path *scheme*))) 6)
)
(mat abort
(procedure? (abort-handler))
(eqv?
(call/cc
(lambda (k)
(parameterize ([abort-handler (lambda () (k 17))])
(abort))))
17)
(error? ; unexpected return from handler
(parameterize ([abort-handler values])
(abort)))
)
(mat command-line
(equal? (command-line) '(""))
(equal? (r6rs:command-line) (command-line))
(parameterize ([command-line '("cp" "x" "y")])
(and (equal? (command-line) '("cp" "x" "y"))
(equal? (r6rs:command-line) '("cp" "x" "y"))))
)
(mat command-line-arguments
(null? (command-line-arguments))
(parameterize ([command-line-arguments '("x" "y")])
(equal? (command-line-arguments) '("x" "y")))
)
;;; section 7.4:
(mat transcript-on/transcript-off ; check output
(begin
(delete-file "testscript")
(printf "***** expect transcript output:~%")
(parameterize ([console-input-port (open-input-string "(transcript-off)\n")])
(transcript-on "testscript")
(let repl ()
(display "OK, " (console-output-port))
(let ([x (read (console-input-port))])
(unless (eof-object? x)
(let ([x (eval x)])
(pretty-print x (console-output-port)))
(repl)))))
(not (eof-object? (with-input-from-file "testscript" read-char))))
)
;;; section 7.5:
(mat collect
(error? ; invalid generation
(collect-maximum-generation -1))
(error? ; invalid generation
(collect-maximum-generation 10000))
(error? ; invalid generation
(collect-maximum-generation 'static))
(error? ; invalid generation
(release-minimum-generation -1))
(error? ; invalid generation
(release-minimum-generation (+ (collect-maximum-generation) 1)))
(error? ; invalid generation
(release-minimum-generation 'static))
(let ([g (+ (collect-maximum-generation) 1)])
(guard (c [(and (message-condition? c)
(equal? (condition-message c) "invalid generation ~s")
(irritants-condition? c)
(equal? (condition-irritants c) (list g)))])
(collect g)
#f))
(let ([g (+ (collect-maximum-generation) 1)])
(guard (c [(and (message-condition? c)
(equal? (condition-message c) "invalid target generation ~s for generation ~s")
(irritants-condition? c)
(equal? (condition-irritants c) (list g 0)))])
(collect 0 g)
#f))
(error? (collect 0 -1))
(error? (collect -1 0))
(error? (collect 1 0))
(error? (collect 'static))
(with-interrupts-disabled
(collect (collect-maximum-generation))
(let ([b1 (bytes-allocated)])
(let loop ([n 1000] [x '()])
(or (= n 0) (loop (- n 1) (cons x x))))
(let ([b2 (bytes-allocated)])
(collect (collect-maximum-generation))
(let ([b3 (bytes-allocated)])
(and (> b2 b1) (< b3 b2))))))
(error? ; invalid generation
(collect 'static 1 'static))
(error? ; invalid generation
(collect 'static 1 'static))
(error? ; invalid generation
(parameterize ([collect-maximum-generation 4])
(collect 17 1 17)))
(error? ; invalid generation
(collect -1 1 'static))
(error? ; invalid maximum target generation
(parameterize ([collect-maximum-generation 4])
(collect 3 1 2)))
(error? ; invalid maximum target generation
(parameterize ([collect-maximum-generation 4])
(collect 3 1 'dynamic)))
(error? ; invalid minimum target generation
(parameterize ([collect-maximum-generation 4])
(collect 0 0 3)))
(error? ; invalid minimum target generation
(parameterize ([collect-maximum-generation 4])
(collect 0 'static 3)))
(error? ; invalid minimum target generation
(parameterize ([collect-maximum-generation 4])
(collect 0 2 1)))
(error? ; invalid minimum target generation
(parameterize ([collect-maximum-generation 4])
(collect 0 2 0)))
(error? ; invalid minimum target generation
(parameterize ([collect-maximum-generation 4])
(collect (collect-maximum-generation) 0 'static)))
(error? ; invalid minimum target generation
(parameterize ([collect-maximum-generation 4])
(collect (collect-maximum-generation) -1 'static)))
(parameterize ([collect-maximum-generation (max (collect-maximum-generation) 2)])
(with-interrupts-disabled
(collect (collect-maximum-generation))
(let ([b0-0 (bytes-allocated 0)]
[b1-0 (bytes-allocated 1)]
[bm-0 (bytes-allocated (collect-maximum-generation))])
(let* ([v (make-vector 2000)] [n (compute-size v)])
(let ([b0-1 (bytes-allocated 0)]
[b1-1 (bytes-allocated 1)]
[bm-1 (bytes-allocated (collect-maximum-generation))])
(unless (>= (- b0-1 b0-0) n) (errorf 'oops1 "b0-0 = ~s, b0-1 = ~s, b0-2 = ~s" b0-0 b0-1 b0-2))
(unless (< (- b1-1 b1-0) n) (errorf 'oops2 "b1-0 = ~s, b1-1 = ~s, b1-2 = ~s" b1-0 b1-1 b1-2))
(unless (< (- bm-1 bm-0) n) (errorf 'oops3 "bm-0 = ~s, bm-1 = ~s, bm-2 = ~s" bm-0 bm-1 bm-2))
(collect (collect-maximum-generation) 1 (collect-maximum-generation))
(let ([b0-2 (bytes-allocated 0)]
[b1-2 (bytes-allocated 1)]
[bm-2 (bytes-allocated (collect-maximum-generation))])
(unless (< (- b0-2 b0-0) n) (errorf 'oops4 "b0-0 = ~s, b0-1 = ~s, b0-2 = ~s" b0-0 b0-1 b0-2))
(unless (>= (- b1-2 b1-0) n) (errorf 'oops5 "b1-0 = ~s, b1-1 = ~s, b1-2 = ~s" b1-0 b1-1 b1-2))
(unless (< (- bm-2 bm-0) n) (errorf 'oops6 "bm-0 = ~s, bm-1 = ~s, bm-2 = ~s" bm-0 bm-1 bm-2))
(parameterize ([print-vector-length #t]) (pretty-print v))
#t))))))
(parameterize ([collect-maximum-generation 4]
[collect-generation-radix 4]
[collect-trip-bytes (expt 2 20)])
(collect (collect-maximum-generation))
(let ([b0 (maximum-memory-bytes)])
(define tail-spin
(lambda (n)
(do ([i 1 (fx+ i 1)] [next (cons 0 '()) (cdr next)])
((fx= i n))
(set-cdr! next (cons i '())))))
(tail-spin 50000000)
(let ([b1 (maximum-memory-bytes)])
(or (< (- b1 b0) (expt 2 24))
(errorf #f "b0 = ~s, b1 = ~s, b1-b0 = ~s" b0 b1 (- b1 b0))))))
)
(mat object-counts
; basic structural checks
(let ([hc (object-counts)])
(begin
(assert (list? hc))
(for-each (lambda (a) (assert (pair? a))) hc)
(for-each (lambda (a) (assert (or (symbol? (car a)) (record-type-descriptor? (car a))))) hc)
(for-each (lambda (a) (assert (list? (cdr a)))) hc)
(for-each
(lambda (a)
(for-each
(lambda (a)
(and (or (and (fixnum? (car a)) (<= 0 (car a) (collect-maximum-generation)))
(eq? (car a) 'static))
(and (fixnum? (cadr a)) (>= (cadr a) 0))
(and (fixnum? (cddr a)) (>= (cddr a) (cadr a)))))
(cdr a)))
hc)
(assert (assq 'pair hc))
(assert (assq 'procedure hc))
(assert (assq 'symbol hc))
(assert (assp record-type-descriptor? hc))
#t))
; a few idiot checks including verification of proper behavior when changing collect-maximum-generation
(parameterize ([enable-object-counts #t] [collect-maximum-generation (collect-maximum-generation)])
(pair?
(with-interrupts-disabled
(let ([cmg (collect-maximum-generation)])
(collect-maximum-generation 4)
(collect 4 4)
(let ()
(define (locate type gen ls)
(cond
[(assq type ls) =>
(lambda (a)
(cond
[(assv gen (cdr a)) => cadr]
[else #f]))]
[else #f]))
(define-record-type flub (fields x))
(define q0 (make-flub 0))
(define b0 (box 0))
(collect 0 0)
(let ([hc (object-counts)])
(assert (locate 'box 0 hc))
(assert (locate (record-type-descriptor flub) 0 hc))
(collect-maximum-generation 7)
(let ([hc (object-counts)])
(assert (locate 'box 0 hc))
(assert (locate (record-type-descriptor flub) 0 hc))
(collect 7 7)
(let ()
(define q1 (make-flub q0))
(define b1 (box b0))
(collect 6 6)
(let ()
(define q2 (make-flub q1))
(define b2 (box b1))
(collect 5 5)
(let ([hc (object-counts)])
(assert (locate 'box 5 hc))
(assert (locate 'box 6 hc))
(assert (locate 'box 7 hc))
(assert (locate (record-type-descriptor flub) 5 hc))
(assert (locate (record-type-descriptor flub) 6 hc))
(assert (locate (record-type-descriptor flub) 7 hc))
(collect-maximum-generation 5)
(let ([hc (object-counts)])
(assert (locate 'box 5 hc))
(assert (not (locate 'box 6 hc)))
(assert (not (locate 'box 7 hc)))
(assert (locate (record-type-descriptor flub) 5 hc))
(assert (not (locate (record-type-descriptor flub) 6 hc)))
(assert (not (locate (record-type-descriptor flub) 7 hc)))
(collect 5 5)
(let ([hc (object-counts)])
(assert (locate 'box 5 hc))
(assert (not (locate 'box 6 hc)))
(assert (not (locate 'box 7 hc)))
(assert (locate (record-type-descriptor flub) 5 hc))
(assert (not (locate (record-type-descriptor flub) 6 hc)))
(assert (not (locate (record-type-descriptor flub) 7 hc)))
(collect-maximum-generation cmg)
(collect cmg cmg)
(cons q2 b2)))))))))))))
; make sure we can handle turning enable-object-counts on and off
(equal?
(parameterize ([collect-request-handler void])
(define-record-type frob (fields x))
(define x (list (make-frob 3)))
(parameterize ([enable-object-counts #t]) (collect 0 0))
(parameterize ([enable-object-counts #f]) (collect 0 1))
(do ([n 100000 (fx- n 1)])
((fx= n 0))
(set! x (cons n x)))
(parameterize ([enable-object-counts #t]) (collect 1 1))
(cons (length x) (cadr (assq 1 (cdr (assq (record-type-descriptor frob) (object-counts)))))))
`(100001 . 1))
(let ([a (assq 'reloc-table (object-counts))])
(or (not a) (not (assq 'static (cdr a)))))
)
(mat collect-rendezvous
(begin
(define (check-working-gc collect)
(with-interrupts-disabled
(let ([p (weak-cons (gensym) #f)])
(collect)
(eq? (car p) #!bwp))))
(and (check-working-gc collect)
(check-working-gc collect-rendezvous)))
(or (not (threaded?))
(let ([m (make-mutex)]
[c (make-condition)]
[done? #f])
(fork-thread
(lambda ()
(let loop ()
(mutex-acquire m)
(cond
[done?
(condition-signal c)
(mutex-release m)]
[else
(mutex-release m)
(loop)]))))
(and (check-working-gc collect-rendezvous)
;; End thread:
(begin
(mutex-acquire m)
(set! done? #t)
(condition-wait c m)
(mutex-release m)
;; Make sure the thread is really done
(let loop ()
(unless (= 1 (#%$top-level-value '$active-threads))
(loop)))
;; Plain `collect` should work again:
(check-working-gc collect)))))
)
;;; section 7.6:
(mat time
(begin (printf "***** expect time output (nonzero allocation):~%")
(time (let loop ([n 1000] [x '()])
(or (= n 0) (loop (- n 1) (cons x x))))))
(begin (printf "***** expect time output (nonzero cpu & real time):~%")
(time (letrec ([tak (lambda (x y z)
(if (>= y x)
z
(tak (tak (1- x) y z)
(tak (1- y) z x)
(tak (1- z) x y))))])
(tak 18 12 6)))
#t)
(begin (printf "***** expect time output (>= 2 collections):~%")
(time (begin (collect) (collect)))
#t)
)
(mat sstats
(begin
(define exact-integer?
(lambda (x)
(and (exact? x) (integer? x))))
(define exact-nonnegative-integer?
(lambda (x)
(and (exact-integer? x) (nonnegative? x))))
(define sstats-time?
(lambda (t type)
(and (time? t) (eq? (time-type t) type))))
#t)
(error? ; invalid cpu time
(make-sstats 0 (make-time 'time-monotonic 0 0) 0 0 (make-time 'time-collector-cpu 0 0) (make-time 'time-collector-real 0 0) 0))
(error? ; invalid real time
(make-sstats (make-time 'time-duration 0 0) 0 0 0 (make-time 'time-collector-cpu 0 0) (make-time 'time-collector-real 0 0) 0))
(error? ; invalid bytes
(make-sstats (make-time 'time-duration 0 0) (make-time 'time-monotonic 0 0) 0.0 0 (make-time 'time-collector-cpu 0 0) (make-time 'time-collector-real 0 0) 0))
(error? ; invalid gc-count
(make-sstats (make-time 'time-duration 0 0) (make-time 'time-monotonic 0 0) 0 "oops" (make-time 'time-collector-cpu 0 0) (make-time 'time-collector-real 0 0) 0))
(error? ; invalid gc-cpu
(make-sstats (make-time 'time-duration 0 0) (make-time 'time-monotonic 0 0) 0 0 0 (make-time 'time-collector-real 0 0) 0))
(error? ; invalid gc-real
(make-sstats (make-time 'time-duration 0 0) (make-time 'time-monotonic 0 0) 0 0 (make-time 'time-collector-cpu 0 0) 0 0))
(error? ; invalid gc-bytes
(make-sstats (make-time 'time-duration 0 0) (make-time 'time-monotonic 0 0) 0 0 (make-time 'time-collector-cpu 0 0) (make-time 'time-collector-real 0 0) 0.0))
(begin
(define sstats
(make-sstats
(make-time 'time-process 0 0)
(make-time 'time-monotonic 0 0)
0
0
(make-time 'time-collector-cpu 0 0)
(make-time 'time-collector-real 0 0)
0))
#t)
(sstats? sstats)
(error? ; not an sstats record
(sstats-cpu 'it))
(error? ; not an sstats record
(sstats-real 'is))
(error? ; not an sstats record
(sstats-bytes 'fun))
(error? ; not an sstats record
(sstats-gc-count 'to))
(error? ; not an sstats record
(sstats-gc-cpu 'write))
(error? ; not an sstats record
(sstats-gc-real 'mats))
(error? ; not an sstats record
(sstats-gc-bytes '(not really)))
(sstats-time? (sstats-cpu sstats) 'time-process)
(sstats-time? (sstats-real sstats) 'time-monotonic)
(eqv? (sstats-bytes sstats) 0)
(eqv? (sstats-gc-count sstats) 0)
(sstats-time? (sstats-gc-cpu sstats) 'time-collector-cpu)
(sstats-time? (sstats-gc-real sstats) 'time-collector-real)
(eqv? (sstats-gc-bytes sstats) 0)
(error? ; not an sstats record
(set-sstats-cpu! 'it (make-time 'time-duration 1 0)))
(error? ; not an sstats record
(set-sstats-real! 'is (make-time 'time-duration 1 0)))
(error? ; not an sstats record
(set-sstats-bytes! 'fun 11))
(error? ; not an sstats record
(set-sstats-gc-count! 'to 13))
(error? ; not an sstats record
(set-sstats-gc-cpu! 'write (make-time 'time-duration 1 0)))
(error? ; not an sstats record
(set-sstats-gc-real! 'mats (make-time 'time-duration 1 0)))
(error? ; not an sstats record
(set-sstats-gc-bytes! '(not really) 17))
(error? ; 12 is not a time
(set-sstats-cpu! sstats 12))
(error? ; 12 is not a time
(set-sstats-real! sstats 12))
(error? ; 12 is not a time
(set-sstats-gc-cpu! sstats 12))
(error? ; 12 is not a time
(set-sstats-gc-real! sstats 12))
(error? ; #[time whatsit] is not a time
(set-sstats-gc-real! sstats (make-assertion-violation)))
(begin
(set-sstats-cpu! sstats (make-time 'time-utc 12 3))
(set-sstats-cpu! sstats (make-time 'time-monotonic 12 3))
(set-sstats-cpu! sstats (make-time 'time-duration 12 3))
(set-sstats-cpu! sstats (make-time 'time-thread 12 3))
(set-sstats-cpu! sstats (make-time 'time-collector-cpu 12 3))
(set-sstats-cpu! sstats (make-time 'time-collector-real 12 3))
(set-sstats-real! sstats (make-time 'time-utc 12 3))
(set-sstats-real! sstats (make-time 'time-duration 12 3))
(set-sstats-real! sstats (make-time 'time-process 12 3))
(set-sstats-real! sstats (make-time 'time-thread 12 3))
(set-sstats-real! sstats (make-time 'time-collector-cpu 12 3))
(set-sstats-real! sstats (make-time 'time-collector-real 12 3))
(set-sstats-gc-cpu! sstats (make-time 'time-utc 12 3))
(set-sstats-gc-cpu! sstats (make-time 'time-monotonic 12 3))
(set-sstats-gc-cpu! sstats (make-time 'time-duration 12 3))
(set-sstats-gc-cpu! sstats (make-time 'time-process 12 3))
(set-sstats-gc-cpu! sstats (make-time 'time-thread 12 3))
(set-sstats-gc-cpu! sstats (make-time 'time-collector-real 12 3))
(set-sstats-gc-real! sstats (make-time 'time-utc 12 3))
(set-sstats-gc-real! sstats (make-time 'time-monotonic 12 3))
(set-sstats-gc-real! sstats (make-time 'time-duration 12 3))
(set-sstats-gc-real! sstats (make-time 'time-process 12 3))
(set-sstats-gc-real! sstats (make-time 'time-thread 12 3))
(set-sstats-gc-real! sstats (make-time 'time-collector-cpu 12 3))
#t)
(eq? (set-sstats-cpu! sstats (make-time 'time-process 12 3)) (void))
(eq? (set-sstats-real! sstats (make-time 'time-monotonic 12 3)) (void))
(eq? (set-sstats-gc-cpu! sstats (make-time 'time-collector-cpu 12 3)) (void))
(eq? (set-sstats-gc-real! sstats (make-time 'time-collector-real 12 3)) (void))
(error? (set-sstats-bytes! sstats 12.3))
(error? (set-sstats-bytes! sstats 12.0))
(error? (set-sstats-gc-count! sstats 3+4i))
(error? (set-sstats-gc-count! sstats #f))
(error? (set-sstats-gc-bytes! sstats 8/3))
(error? (set-sstats-gc-bytes! sstats 'twelve))
(eq? (set-sstats-bytes! sstats 12) (void))
(eq? (set-sstats-gc-count! sstats 3) (void))
(eq? (set-sstats-gc-bytes! sstats 8) (void))
(begin
(define sstats-diff
(sstats-difference
(make-sstats
(make-time 'time-process 83 5)
(make-time 'time-monotonic 12 1)
5
23
(make-time 'time-collector-cpu (expt 2 8) 0)
(make-time 'time-collector-real 735 1000007)
29)
(make-sstats
(make-time 'time-process 3 0)
(make-time 'time-monotonic 10333221 2)
20
3
(make-time 'time-collector-cpu 0 0)
(make-time 'time-collector-real 0 0)
4)))
#t)
(sstats? sstats-diff)
(sstats-time? (sstats-cpu sstats-diff) 'time-duration)
(time=? (sstats-cpu sstats-diff) (make-time 'time-duration 80 5))
(sstats-time? (sstats-real sstats-diff) 'time-duration)
(time=? (sstats-real sstats-diff) (make-time 'time-duration 989666791 -2))
(eqv? (sstats-bytes sstats-diff) -15)
(eqv? (sstats-gc-count sstats-diff) 20)
(sstats-time? (sstats-gc-cpu sstats-diff) 'time-duration)
(time=? (sstats-gc-cpu sstats-diff) (make-time 'time-duration (expt 2 8) 0))
(sstats-time? (sstats-gc-real sstats-diff) 'time-duration)
(time=? (sstats-gc-real sstats-diff) (make-time 'time-duration 735 1000007))
(eqv? (sstats-gc-bytes sstats-diff) 25)
(let ([sstats (statistics)])
(and
(sstats? sstats)
(sstats-time? (sstats-cpu sstats) 'time-thread)
(sstats-time? (sstats-real sstats) 'time-monotonic)
(exact-nonnegative-integer? (sstats-bytes sstats))
(exact-nonnegative-integer? (sstats-gc-count sstats))
(sstats-time? (sstats-gc-cpu sstats) 'time-collector-cpu)
(sstats-time? (sstats-gc-real sstats) 'time-collector-real)
(exact-nonnegative-integer? (sstats-gc-bytes sstats))))
(let ([sstats (sstats-difference (statistics) (statistics))])
(and
(sstats? sstats)
(sstats-time? (sstats-cpu sstats) 'time-duration)
(sstats-time? (sstats-real sstats) 'time-duration)
(exact-integer? (sstats-bytes sstats))
(exact-integer? (sstats-gc-count sstats))
(sstats-time? (sstats-gc-cpu sstats) 'time-duration)
(sstats-time? (sstats-gc-real sstats) 'time-duration)
(exact-integer? (sstats-gc-bytes sstats))))
)
(mat display-statistics ; check output
(let ([s (with-output-to-string display-statistics)])
(and (string? s) (> (string-length s) 50)))
)
(mat cpu-time
(> (cpu-time) 0)
(let ([x (cpu-time)])
(<= x (cpu-time)))
)
(mat real-time
(> (real-time) 0)
(let ([x (real-time)])
(<= x (real-time)))
)
(mat bytes-allocated
(error? (bytes-allocated 'yuk))
(error? (bytes-allocated -1))
(error? (bytes-allocated (+ (collect-maximum-generation) 1)))
(error? (bytes-allocated (+ (most-positive-fixnum) 1)))
(error? (bytes-allocated #f))
(error? (bytes-allocated (+ (collect-maximum-generation) 1) 'new))
(error? (bytes-allocated (+ (collect-maximum-generation) 1) #f))
(error? (bytes-allocated 0 'gnu))
(error? (bytes-allocated #f 'gnu))
(error? (bytes-allocated 'static 'gnu))
(> (bytes-allocated) 0)
(andmap (lambda (g) (>= (bytes-allocated g) 0)) (iota (+ (collect-maximum-generation) 1)))
(>= (bytes-allocated 'static) 0)
(let ([x (bytes-allocated)])
(<= x (bytes-allocated)))
(>= (initial-bytes-allocated) 0)
(>= (collections) 0)
(>= (bytes-deallocated) 0)
(let ([b (bytes-deallocated)] [c (collections)])
(let ([x (make-list 10 'a)])
(pretty-print x)
(collect)
(and (> (collections) c) (> (bytes-deallocated) b))))
(>= (bytes-allocated #f #f) 0)
(andmap (lambda (space)
(>= (bytes-allocated #f space) 0))
(#%$spaces))
(let ()
(define fudge 2000)
(define ~=
(lambda (x y)
(<= (abs (- x y)) fudge)))
(define all-gen
(append (iota (+ (collect-maximum-generation) 1)) '(static)))
(for-each
(lambda (space)
(critical-section
(let ([n1 (bytes-allocated #f space)]
[n2 (fold-left (lambda (bytes gen)
(+ bytes (bytes-allocated gen space)))
0
all-gen)])
(unless (~= n1 n2)
(errorf #f "discrepancy for space ~s: ~d vs ~d" space n1 n2)))))
(#%$spaces))
(for-each
(lambda (gen)
(critical-section
(let ([n1 (bytes-allocated gen #f)]
[n2 (fold-left (lambda (bytes space)
(+ bytes (bytes-allocated gen space)))
0
(#%$spaces))])
(unless (~= n1 n2)
(errorf #f "discrepancy for generation ~s: ~d vs ~d" gen n1 n2)))))
all-gen)
(critical-section
(let ([n1 (bytes-allocated #f #f)]
[n2 (fold-left (lambda (bytes gen)
(fold-left (lambda (bytes space)
(+ bytes (bytes-allocated gen space)))
bytes
(#%$spaces)))
0
all-gen)])
(unless (~= n1 n2)
(errorf #f "discrepancy in bytes-allocated: ~d vs ~d" n1 n2))))
#t)
)
(mat memory-bytes
(critical-section
(let ([x (maximum-memory-bytes)])
(<= (current-memory-bytes) x)))
(critical-section
(let ([x (maximum-memory-bytes)])
(reset-maximum-memory-bytes!)
(let ([y (maximum-memory-bytes)])
(<= y x))))
)
(mat date-and-time
(let ([s (date-and-time)])
(printf "***** check date-and-time: ~s~%" s)
(string? s))
)
;;; section 7-7:
(mat trace-lambda ; check output
(letrec ([fact (trace-lambda fact (x)
(if (= x 0)
1
(* x (fact (- x 1)))))])
(printf "***** expect trace of (fact 3):~%")
(eqv? (fact 3) 6))
)
(mat trace-let ; check output
(begin (printf "***** expect trace of (fib 3):~%")
(eqv? (trace-let fib ([x 3])
(if (< x 2)
1
(+ (fib (- x 1)) (fib (- x 2)))))
3))
)
(mat trace/untrace
(begin (set! lslen
(lambda (ls)
(if (null? ls)
0
(+ (lslen (cdr ls)) 1))))
(and (equal? (trace lslen) '(lslen))
(equal? (trace) '(lslen))
(begin (printf "***** expect trace of (lslen '(a b c)):~%")
(eqv? (lslen '(a b c)) 3))
(equal? (untrace lslen) '(lslen))
(equal? (trace) '())
(equal? (trace lslen) '(lslen))
(equal? (trace lslen) '(lslen))
(begin (set! lslen (lambda (x) x))
(printf "***** do *not* expect output:~%")
(eqv? (lslen 'a) 'a))
(equal? (trace lslen) '(lslen))
(begin (printf "***** expect trace of (lslen 'a):~%")
(eqv? (lslen 'a) 'a))
(equal? (untrace) '(lslen))
(equal? (trace) '())
(begin (printf "***** do *not* expect output:~%")
(eqv? (lslen 'a) 'a))))
)
;;; section 7-8:
(mat error
(error? (errorf 'a "hit me!"))
(error? (let f ([n 10]) (if (= n 0) (errorf 'f "n is ~s" n) (f (- n 1)))))
)
(mat keyboard-interrupt-handler ; must be tested by hand
(procedure? (keyboard-interrupt-handler))
)
(mat collect-request-handler
(procedure? (collect-request-handler))
(call/cc
(lambda (k)
(parameterize ([collect-request-handler
(lambda ()
(collect)
(k #t))])
(let f ([x '()]) (f (list-copy (cons 'a x)))))))
)
(mat timer-interrupt-handler ; tested in mat set-timer below
(procedure? (timer-interrupt-handler))
)
;;; section 7-9:
(mat set-timer
(let ([count1 0])
(timer-interrupt-handler (lambda () (set! count1 (+ count1 1))))
(set-timer (+ 10 (random 10)))
(let loop2 ([count2 1])
(cond
[(= count2 100)]
[(= count1 count2)
(set-timer (+ 10 (random 10)))
(loop2 (+ count2 1))]
[else (loop2 count2)])))
)
(mat disable-interrupts-enable-interrupts
(and (= (disable-interrupts) 1)
(= (disable-interrupts) 2)
(= (enable-interrupts) 1)
(= (enable-interrupts) 0))
(call/cc
(lambda (k)
(timer-interrupt-handler (lambda () (k #t)))
(disable-interrupts)
(parameterize ([timer-interrupt-handler (lambda () (k #f))])
(set-timer 1)
(let loop ([n 1000]) (or (= n 0) (loop (- n 1)))))
(enable-interrupts)
(let loop ([n 1000]) (or (= n 0) (loop (- n 1))))
#f))
)
(mat with-interrupts-disabled
(call/cc
(lambda (k)
(timer-interrupt-handler (lambda () (k #t)))
(with-interrupts-disabled
(parameterize ([timer-interrupt-handler (lambda () (k #f))])
(set-timer 1)
(let loop ([n 1000]) (or (= n 0) (loop (- n 1))))))
(let loop ([n 1000]) (or (= n 0) (loop (- n 1))))
#f))
; test old name
(call/cc
(lambda (k)
(timer-interrupt-handler (lambda () (k #t)))
(critical-section
(parameterize ([timer-interrupt-handler (lambda () (k #f))])
(set-timer 1)
(let loop ([n 1000]) (or (= n 0) (loop (- n 1))))))
(let loop ([n 1000]) (or (= n 0) (loop (- n 1))))
#f))
)