1;;; misc.ms
2;;; Copyright 1984-2017 Cisco Systems, Inc.
3;;;
4;;; Licensed under the Apache License, Version 2.0 (the "License");
5;;; you may not use this file except in compliance with the License.
6;;; You may obtain a copy of the License at
7;;;
8;;; http://www.apache.org/licenses/LICENSE-2.0
9;;;
10;;; Unless required by applicable law or agreed to in writing, software
11;;; distributed under the License is distributed on an "AS IS" BASIS,
12;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13;;; See the License for the specific language governing permissions and
14;;; limitations under the License.
15
16;;; regression and other tests that don't fit somewhere more logical
17
18(define-syntax biglet
19  (lambda (x)
20    (syntax-case x ()
21      ((_ n bindings e)
22       (let ((nv (datum n)))
23         (if (= nv 0)
24             (syntax (let bindings e))
25             (with-syntax ((m (- nv 1)))
26               (syntax (biglet m ((g n) . bindings) (+ g e))))))))))
27
28(define-syntax biglambda
29  (lambda (x)
30    (syntax-case x ()
31      ((_ n vars e)
32       (let ((nv (datum n)))
33         (if (= nv 0)
34             (syntax (lambda vars e))
35             (with-syntax ((m (- nv 1)))
36               (syntax (biglambda m (g . vars) (+ g e))))))))))
37
38(mat cycle
39  (let ((x '#1=(a b . #1#)))
40    (eqv? x x))
41  (let-syntax ((a (lambda (y)
42                    (let ((x (list 'quote '*)))
43                      (set-car! (cdr x) x)
44                      (datum->syntax (syntax a) x)))))
45    (let ((a (a))) (and (pair? a) (eq? (cadr a) a))))
46  (let-syntax ((a (lambda (y)
47                      (let ((x (list 1 '*)))
48                        (set-car! (cdr x) x)
49                        (with-syntax ((l (datum->syntax (syntax a) x)))
50                          (syntax (quote l)))))))
51     (let ((a (a))) (and (pair? a) (eq? (car a) 1) (eq? (cadr a) a))))
52;  (let ((x '(#2=(#2#) . #2#)))
53;    (and (eq? (car x) (caar x)) (eq? (car x) (cdr x))))
54)
55
56(mat overflow ; attempt to force dooverflow, dooverflood, apply_dooverflood
57    ;; this should test dooverflow
58    (eqv? (let f ((n 100000))
59             (if (= n 0)
60                 0
61                 (+ (f (- n 1)) 1)))
62          100000)
63    ;; this should test dooverflow
64    (eqv? (let f ((n 10000) (m 0))
65             (if (= n 0)
66                 m
67                 (f (call/cc (lambda (k) (- n 1)))
68                    (call/cc (lambda (k) (+ (k (+ m 1)) 1))))))
69          10000)
70    ;; this should test dooverflood
71    (eqv? (let f ((n 10000))
72             (if (= n 0)
73                 0
74                 (let ((m (biglet 100 () 0)))
75                    (+ m (f (- n 1))))))
76          (* 10000 (let f ((n 100) (m 0)) (if (= n 0) m (f (- n 1) (+ m n))))))
77    ;; this should test apply_dooverflood
78    (= (length (apply list (make-list 100000))) 100000)
79    ;; this should test apply_dooverflood
80    (eqv? (let ((a (biglambda 100 () 0))
81                (ls (make-list 100 1)))
82             (let f ((n 10000))
83                (if (= n 0)
84                    0
85                    (let ((m (apply a ls)))
86                       (+ m (f (- n 1)))))))
87          (* 100 10000))
88    ; this should test overflow w/mrvs
89    (let-syntax ((first (syntax-rules ()
90                          ((_ e)
91                           (call-with-values
92                             (lambda () e)
93                             (lambda (x . args) x))))))
94      (eqv? (first (let f ((n 100000))
95                     (if (fx= n 0)
96                         (values 1 1)
97                         (values (fx+ (first (f (fx- n 1))) 1) 1))))
98            100001))
99    ; test overflow w/lots of values to large frame
100    (eqv? (let-syntax ((first (syntax-rules ()
101                                ((_ e1 e2 ...)
102                                 (call-with-values
103                                   (lambda () e1 e2 ...)
104                                   (lambda (x . args) x))))))
105            (biglet 100 () (first (apply values (make-list 10000 0)))))
106          5050)
107    (eq?
108      (let ()
109        (define foo
110          (lambda ()
111            (define-syntax a
112              (lambda (x)
113                (syntax-case x ()
114                  [(_ n)
115                   (with-syntax ([(g ...) (generate-temporaries (make-list (datum n)))])
116                     #'(let ([g 3] ...) (list g ...)))])))
117            (a 1000)))
118        (define (q n)
119          (call/1cc
120            (lambda (k0)
121              ((call/1cc
122                 (lambda (k1)
123                   (call/1cc
124                     (lambda (k2)
125                       (k1 (lambda () (let f ([n n]) (foo) (unless (fx= n 0) (f (- n 1)))) (k2)))))
126                   (k0 'done)))))))
127        (q 1000))
128      'done)
129    ; regression test for np-place-overflow-and-trap treating test part of
130    ; if-expr as tail when if-expr is tail
131    (begin
132      (define $poat-if-bug
133        (lambda (x)
134          (if (or (#3%fx= x 0) ($poat-if-bug (#3%fx- x 1)))
135              'yes
136              'no)))
137      #t)
138    (eq? ($poat-if-bug 20000) 'yes)
139)
140
141(begin
142  (define ls0 '())
143  (define ls1 '(a))
144  (define ls2 '(a b))
145  (define ls3 '(a b c))
146  (define-syntax relop-length-test
147    (lambda (x)
148      (syntax-case x ()
149        [(_ op)
150         (with-syntax (((exp ...)
151                        (map (lambda (ls)
152                               (with-syntax ((ls ls)
153                                             ((n ...) '(0 1 2 3 4 5)))
154                                 #'(list (op (length ls) n) ...)))
155                             (list #'ls0 #'ls1 #'ls2 #'ls3))))
156           (with-syntax ((exp #'(list exp ...)))
157             (with-syntax ((ans (datum->syntax #'* (interpret (datum exp)))))
158               #'(equal? exp 'ans))))]))))
159
160(mat relop-length ; test (relop (length e) n)
161  (eqv? (pretty-print (expand (relop-length-test =))) (void))
162  (relop-length-test <)
163  (relop-length-test >)
164  (relop-length-test <=)
165  (relop-length-test >=)
166
167  (relop-length-test fx=)
168  (relop-length-test fx<)
169  (relop-length-test fx>)
170  (relop-length-test fx<=)
171  (relop-length-test fx>=)
172)
173
174(mat compiler1
175   (error? ; unbound variable
176     (i-am-not-bound))
177   (begin
178     (define i-am-bound-but-not-to-a-procedure 'oops)
179     #t)
180   (error? ; non-procedure
181     (i-am-bound-but-not-to-a-procedure))
182   ;; test cpr1 code to avoid loading closer pointer for direct rec calls
183   ;; make sure closure is loaded for value ref of g
184   (letrec ((g (lambda (x)
185                  (if (eq? x 'b)
186                      (let ((h g)) (h 'c))
187                      (if (eq? x 'a)
188                          (g 'b)
189                          'okay)))))
190      (eq? (g 'a) 'okay))
191   ;; make sure closure is loaded for closure containing g
192   (letrec ((g (lambda (x)
193                  (if (eq? x 'b)
194                      (let ((h (lambda (x) (g x)))) (h 'c))
195                      (if (eq? x 'a)
196                          (g 'b)
197                          'okay)))))
198      (eq? (g 'a) 'okay))
199   ;; test for incorrect call screwing up nocp code
200   (error? (letrec ((g (lambda () (g (list))))) (g)))
201   ;; test for rest list avoidance code being fooled by assignment conversion
202   (begin
203     (define (rest-test x . y)
204       (set! y y)
205       y)
206     (equal?
207       (rest-test 1 2)
208       '(2)))
209   ;; test for bogus conversion of direct lambda calls with rest arguments
210   (equal? ((lambda x x) 1 2 3 4) '(1 2 3 4))
211   ;; test for register allocator bug
212   (let ()
213     (define (foo return) (return 'foo))
214     (define (goo return)
215       (foo (lambda (y)
216              (let ((x 'goo))
217                (return x y '() '())))))
218     (equal? (goo list) '(goo foo () ())))
219   (let ()
220     (define (foo return) (return 'foo))
221     (define (goo return)
222       (foo (lambda (y)
223              (let ((x 'goo))
224                (return x y 'hoo '() '())))))
225     (equal? (goo list) '(goo foo hoo () ())))
226   (eq? (let ((f (lambda x x))) ((begin 'a f))) '())
227   (error? (letrec ((a (lambda (v) v))) ((begin 'foo a))))
228   (equal? (let ((f (case-lambda ((x) 'a) ((x y) 'b) (z z))))
229             ((begin 'c f) 3 4 5 6))
230           '(3 4 5 6))
231   (equal? (let ((f (lambda x x)))
232             (call-with-values (lambda () ((begin 'a f))) list))
233           '(()))
234   (equal? (let ((f (lambda x x)))
235             (call-with-values (lambda () ((begin 'a f)))
236               (lambda args args)))
237           '(()))
238   (eqv?
239     (let () ; mvlet in 5.0c & before were branching to domvleterr call
240       (define id-var-name
241         (lambda ()
242           (define-syntax first
243             (syntax-rules ()
244               ((_ e) (#2%call-with-values
245                        (lambda () e)
246                        (lambda (x . ignore) x)))))
247           (let ((f (lambda () (or (first (values #f 2)) 3))))
248             (f))))
249       (id-var-name))
250     3)
251   (begin (define string->color (lambda (x) (values 1 2))) (procedure? string->color))
252   (eqv? (call-with-values
253           (lambda () (string->color #f))
254           (lambda (x y) x))
255         1)
256  ; test for cp2-store handling of binary dest with singleton next
257   (procedure?
258     (lambda (s end)
259       (let ([end (or (if s end #f) end)])
260         (if end s #f))))
261  ; make sure case-lambda clause ordering is observed
262   (equal?
263     (let ((f (case-lambda
264                [(x) (* x x)]
265                [(x y) (+ x x)]
266                [(x . r) (- x x)])))
267       (list (f 5) (f 5 4) (f 5 4 3)))
268     '(25 10 0))
269   ; make sure irreducible flow graph doesn't choke the compiler
270   (procedure?
271     (rec q
272       (case-lambda
273         [() (q 0)]
274         [(x) (q)])))
275   ; regression tests for non-tail-call mref lvalue destination
276   (begin
277     (define (c1-f a)
278       (let ([x (fxvector 0)])
279         (lambda (v) (fxvector-set! x 0 (modulo v a)) x)))
280     #t)
281   (equal? ((c1-f 7) 10) #vfx(3))
282   (begin
283     (define (c1-id x) x)
284     (define (c1-g x) (vector-set-fixnum! x 0 (c1-id 17)))
285     #t)
286   (equal? (let ([v (vector 3)]) (c1-g v) v) '#(17))
287)
288
289(mat compiler2 ; random tests
290  (eqv? (((lambda (x) (lambda (y) (- x y))) 3) 4) -1)
291  (equal? (let ((f (lambda (x) (lambda (y) (- x y)))))
292            (cons ((f 3) 4) ((f 4) 3)))
293    '(-1 . 1))
294  (eqv? (letrec ((f (lambda (a) a))
295                 (g (lambda (b) (if b (begin (f b) (g (not b))) 17))))
296          (g #f))
297    17)
298  (eqv? (letrec ((f (lambda (a) a))
299                 (g (lambda (b) (if b (begin (f b) (g (not b))) 13))))
300          (g #t))
301    13)
302  (eqv? (letrec ((f (lambda (a) a))
303                 (g (lambda (b) (if b (begin (f b) (g #f)) 11))))
304          (g #f))
305    11)
306  (eqv? (letrec ((f (lambda (a) a))
307                 (g (lambda (b) (if b (begin (f b) (g #f)) 9))))
308          (g #t))
309    9)
310  (eqv? (let ((f (lambda (x) (+ x x))))
311          (let ((g (lambda () f f)))
312            (g) ((g) 3)))
313    6)
314
315  (eqv? (letrec ((f (lambda (x) (+ x x))))
316          (letrec ((g (lambda () f f)))
317            (g) ((g) 3)))
318    6)
319  (equal? (apply (lambda (x y) (list y x)) 'a 'b '()) '(b a))
320  (equal? (apply (lambda (x . r) (list r x)) '(a b c)) '((b c) a))
321  (equal? (apply list '(1 2 3)) '(1 2 3))
322  (eqv? (apply + '(1 2 3)) 6)
323  (let ([f (lambda x x)]) (equal? (f) '()))
324  (eq? (let ()
325         (define *current-gensym* 0)
326         (define (generate-symbol)
327           (set! *current-gensym* (+ *current-gensym* 1))
328           (string->symbol (number->string *current-gensym*)))
329         (define f (lambda (x) x))
330         (f 3))
331    3)
332  (eqv? (let f ((x 0)) (if (= x 0) 1 (* x (f (- x 1))))) 1)
333  (error? (let ((f (lambda () (let ((x 3)) (lambda (y z) (or (= y 3) x))))))
334            (begin ((f) 3 (+ 'a 3))) 0))
335  (eqv? (let ((f (lambda () (let ((x 3)) (lambda (y z) (or (= y 3) x))))))
336          (begin ((f) 3 (+ 3 4)) 0))
337    0)
338  (let ((f (lambda () (lambda (y z) (or (= y 3) z))))) ((f) 3 (+ 3 4)))
339  (let ((f (lambda () (lambda (y z) (or (= z 7) z))))) ((f) 3 (+ 3 4)))
340  (let ((f (lambda (y z) (or (= y 3) z)))) (f 3 (+ 3 4)))
341  (error? (let ((f (lambda (x) (+ x x)))) (f 3 4)))
342  (error? ; invalid argument count in call to car
343    (cons (car 1 2)))
344  (error? ; invalid argument count in call to cons
345    (let loop () (loop (cons 1 2 3))))
346  (equal?
347    (call/cc
348      (lambda (k)
349        (cons (k '(a b c)))))
350    '(a b c))
351  (equal?
352    (call/cc
353      (lambda (k)
354        (let loop () (loop (k '(a b c))))))
355    '(a b c))
356  (equal?
357    (call/cc
358      (lambda (k)
359        (letrec ([sum (lambda (n) (if (= n 0) 1 (+ n (sum (- n 1)))))])
360          (cons (sum (k '(a . b)) 15)))))
361    '(a . b))
362  (equal?
363    (call/cc
364      (lambda (k)
365        (letrec ([sum (lambda (n) (if (= n 0) 1 (+ n (sum (k '(a . b)) (- n 1)))))])
366          (cons (sum 15)))))
367    '(a . b))
368  (equal?
369    (call/cc
370      (lambda (k)
371        (letrec* ([a (lambda () c)]
372                  [b (k "hi")]
373                  [c (pair? k 1)])
374          (errorf 'oops "shouldn't reach here ~s" (list a b)))))
375    "hi")
376  ; make sure we set up the stack properly before call-error
377  (or (= (optimize-level) 3)
378      (call/cc
379        (lambda (k)
380          (with-exception-handler
381            (lambda (c) (collect) (k #t))
382            (rec p (lambda () (('spam 1 2))))))))
383  ; make sure return-address is set properly and stack is otherwise
384  ; well-formed when we go through call-error for invalid consumer
385  (begin
386    (define ($foo$ x y z w p) w)
387    #t)
388  (or (= (optimize-level) 3)
389      (call/cc
390        (lambda (k)
391          (with-exception-handler (lambda (c) (collect) (k #t))
392            (lambda ()
393              (let ([x (list (lambda () (sort < '(3 2 5 7 9)) (values 1 2 3)))])
394                ($foo$ 1 2 3 4 5)
395                (call-with-values (car x) x)))))))
396  ; make sure return-address is set properly and stack is otherwise
397  ; well-formed when we go through values-error
398  (begin
399    (define $values (lambda () (printf "hello!\n") (values 1 2 3 4 5 6 7 8)))
400    #t)
401  (or (= (optimize-level) 3)
402      (eqv?
403        (call/cc
404          (lambda (k)
405            (with-exception-handler
406              (lambda (c) (collect) (k 'okay))
407              (lambda () (if ($values) 3 4)))))
408        'okay))
409  (or (= (optimize-level) 3)
410      (eqv?
411        (call/cc
412          (lambda (k)
413            (with-exception-handler
414              (lambda (c) (collect) (k 'okay))
415              (lambda ()
416                (let ([x (random 10)])
417                  (if ($values) x 4))))))
418        'okay))
419  ; make sure return-address is set properly and stack is otherwise
420  ; well-formed when we go through mvlet-error
421  (or (= (optimize-level) 3)
422      (eqv?
423        (call/cc
424          (lambda (k)
425            (with-exception-handler
426              (lambda (c) (collect) (k 'okay))
427              (lambda ()
428                (let ([x (random 10)])
429                  (call-with-values $values
430                    (lambda (x y) 'oops)))))))
431        'okay))
432  (or (= (optimize-level) 3)
433      (eqv?
434        (call/cc
435          (lambda (k)
436            (with-exception-handler
437              (lambda (c) (collect) (k 'okay))
438              (lambda ()
439                (define f (case-lambda))
440                (let ([x (random 10)])
441                  (call-with-values $values f))))))
442        'okay))
443  (or (= (optimize-level) 3)
444      (eqv?
445        (call/cc
446          (lambda (k)
447            (with-exception-handler
448              (lambda (c) (collect) (k 'okay))
449              (lambda ()
450                (let ([x (random 10)])
451                  (call-with-values
452                    (lambda () ($values) (values 1 2 3))
453                    (lambda (x y) 'oops)))))))
454        'okay))
455  ; make sure compiler doesn't bomb trying to borrow a closure
456  ; whose name isn't already free
457  (equal?
458    (let ([ls '()])
459      (let ([v (((parameterize ([run-cp0 (lambda (cp0 x) x)])
460
461                   (eval '(lambda (x y)
462                            (let ((av (lambda () (x y))))
463                              (av)
464                              (lambda ()
465                                (let ((tt (lambda () (x y))))
466                                  (begin (tt) 3)))))))
467                 (lambda (z) (set! ls (cons z ls)))
468                 17))])
469        (cons v ls)))
470    '(3 17 17))
471  ; for good measure, some where borrowing can occur
472  ; tt borrow av
473  (equal?
474    (let ([ls '()])
475      (let ([v (((parameterize ([run-cp0 (lambda (cp0 x) x)])
476                   (eval '(lambda (x y)
477                            (let ((av (lambda () (x y))))
478                              (lambda ()
479                                (av)
480                                (let ((tt (lambda () (x y))))
481                                  (begin (tt) 3)))))))
482                 (lambda (z) (set! ls (cons z ls)))
483                 17))])
484        (cons v ls)))
485    '(3 17 17))
486  ; tt borrow av (which happens to be free in tt)
487  (equal?
488    (let ([ls '()])
489      (let ([v (((parameterize ([run-cp0 (lambda (cp0 x) x)])
490
491                   (eval '(lambda (x y)
492                            (let ((av (lambda () (x y))))
493                              (lambda ()
494                                (let ((tt (lambda () (av) (x y))))
495                                  (begin (tt) 3)))))))
496                 (lambda (z) (set! ls (cons z ls)))
497                 17))])
498        (cons v ls)))
499    '(3 17 17))
500  ; tt borrow av, zz borrow av
501  (equal?
502    (let ([ls '()])
503      (let ([v ((((parameterize ([run-cp0 (lambda (cp0 x) x)])
504
505                    (eval '(lambda (x y)
506                             (let ((av (lambda () (x y))))
507                               (lambda ()
508                                 (av)
509                                 (let ((tt (lambda () (av) (x y))))
510                                   (lambda ()
511                                     (tt)
512                                     (let ([zz (lambda () (x y))])
513                                       (begin (zz) 3)))))))))
514                  (lambda (z) (set! ls (cons z ls)))
515                  17)))])
516        (cons v ls)))
517    '(3 17 17 17 17))
518  ; tt borrow av, zz borrow av
519  (equal?
520    (let ([ls '()])
521      (let ([v ((((parameterize ([run-cp0 (lambda (cp0 x) x)])
522                    (eval '(lambda (x y)
523                             (let ((av (lambda () (x y))))
524                               (lambda ()
525                                 (av)
526                                 (let ((tt (lambda () (av) (x y))))
527                                   (lambda ()
528                                     (tt)
529                                     (let ([zz (lambda () (x y))])
530                                       (begin (zz) 3)))))))))
531                  (lambda (z) (set! ls (cons z ls)))
532                  17)))])
533        (cons v ls)))
534    '(3 17 17 17 17))
535  ; zz borrow av (tt goes away)
536  (equal?
537    (let ([ls '()])
538      (let ([v ((((parameterize ([run-cp0 (lambda (cp0 x) x)])
539                    (eval '(lambda (x y)
540                             (let ((av (lambda () (x y))))
541                               (lambda ()
542                                 (av)
543                                 (let ((tt (lambda () (av) (x y))))
544                                   (lambda ()
545                                     (av)
546                                     (let ([zz (lambda () (x y))])
547                                       (begin (zz) 3)))))))))
548                  (lambda (z) (set! ls (cons z ls)))
549                  17)))])
550        (cons v ls)))
551    '(3 17 17 17))
552  ; tt borrow av, zz borrow av
553  (equal?
554    (let ([ls '()])
555      (let ([v ((((parameterize ([run-cp0 (lambda (cp0 x) x)])
556                    (eval '(lambda (x y)
557                             (let ((av (lambda () (x y))))
558                               (lambda ()
559                                 (av)
560                                 (let ((tt (lambda () (av) (x y))))
561                                   (lambda ()
562                                     (tt)
563                                     (av)
564                                     (let ([zz (lambda () (x y))])
565                                       (begin (zz) 3)))))))))
566                  (lambda (z) (set! ls (cons z ls)))
567                  17)))])
568        (cons v ls)))
569    '(3 17 17 17 17 17))
570  ; tt borrow av, zz borrow av
571  (equal?
572    (let ([ls '()])
573      (let ([v ((((parameterize ([run-cp0 (lambda (cp0 x) x)])
574                    (eval '(lambda (x y)
575                             (let ((av (lambda () (x y))))
576                               (lambda ()
577                                 (av)
578                                 (let ((tt (lambda () (av) (x y))))
579                                   (lambda ()
580                                     (let ([zz (lambda () (tt) (x y))])
581                                       (begin (zz) 3)))))))))
582                  (lambda (z) (set! ls (cons z ls)))
583                  17)))])
584        (cons v ls)))
585    '(3 17 17 17 17))
586  ; tt borrow av, zz can't borrow
587  (equal?
588    (let ([ls '()])
589      (let ([v ((((parameterize ([run-cp0 (lambda (cp0 x) x)])
590                    (eval '(lambda (x y)
591                             (let ((av (lambda () (x y))))
592                               (lambda ()
593                                 (av)
594                                 (let ((tt (lambda () (av) (x y))))
595                                   (tt)
596                                   (lambda ()
597                                     (let ([zz (lambda () (x y))])
598                                       (begin (zz) 3)))))))))
599                  (lambda (z) (set! ls (cons z ls)))
600                  17)))])
601        (cons v ls)))
602    '(3 17 17 17 17))
603  ; tt goes away, zz can't borrow
604  (equal?
605    (let ([ls '()])
606      (let ([v ((((parameterize ([run-cp0 (lambda (cp0 x) x)])
607                    (eval '(lambda (x y)
608                             (let ((av (lambda () (x y))))
609                               (lambda ()
610                                 (av)
611                                 (let ((tt (lambda () (av) (x y))))
612                                   (lambda ()
613                                     (let ([zz (lambda () (x y))])
614                                       (begin (zz) 3)))))))))
615                  (lambda (z) (set! ls (cons z ls)))
616                  17)))])
617        (cons v ls)))
618    '(3 17 17))
619  ; regression test for bug in which $flonum-exponent read past mapped memory
620  (eq?
621    (do ([n 2000 (- n 1)] [ls (iota 2000)])
622        ((= n 0) 'fini)
623      (map (lambda (x) (let ([x (exact (sqrt -2.0))]) x)) ls))
624    'fini)
625)
626
627(mat compiler3
628  ;; test cpr0 code to avoid bombing with compile-time error for apparent
629  ;; arg count mismatch in direct call
630  ;; need to add tests for mvcall and mvlet as well.
631  (equal?
632    (let ((ip (open-input-string "#f")))
633      (let ((consumer (lambda (x) (list x))))
634        (if (read ip) (consumer 1 2) (consumer 4))))
635    '(4))
636  ;; error message should come at run time, warning at compile time.
637  (guard (c [(warning? c) #t])
638    (with-output-to-file "testfile.ss"
639      (lambda ()
640        (pretty-print
641          '(let ([ip (open-input-string "#t")])
642             (let ([consumer (lambda (x) (list x))])
643               (if (read ip) (consumer 1 2) (consumer 4))))))
644      'replace)
645    (load "testfile.ss")
646    #f)
647  (error? ; incorrect argument count
648    (load "testfile.ss"))
649  (error?
650    (let ((ip (open-input-string "#t")))
651      (let ((consumer (lambda (x) (list x))))
652        (if (read ip) (consumer 1 2) (consumer 4)))))
653 ; test proper nonprocedure-procedure handling; goto is used as a symbol
654 ; but not given a value in compiler boot file.  we had been failing to
655 ; run retrofit_nonprocedure_procedure after loading the second (compiler)
656 ; boot file.
657  (begin
658    (define $goto (lambda () (goto)))
659    #t)
660  (error? ($goto))
661 ; check for nonprocedure-procedure handling when procedure is bound
662 ; to something other than a procedure
663  (error? (3 4))
664  (error? ((cons 'a 'b) 4))
665 ; check to make sure rest list is created after arguments are evaluated
666  (begin
667    (define non-eq-spines?
668      (lambda (x)
669        (let f ([ls1 (car x)] [ls2 (cdr x)])
670          (if (null? ls1)
671              (null? ls2)
672              (and (not (eq? ls1 ls2))
673                   (eq? (car ls1) (car ls2))
674                   (f (cdr ls1) (cdr ls2)))))))
675    #t)
676  (non-eq-spines?
677    (let ()
678      (define *k*)
679      (define (f)
680        (define (f . args) args)
681        (let ([ls (f (call/cc values) 1 2 3)]) (*k* ls)))
682      (define ls1 (call/cc (lambda (k) (set! *k* k) (f))))
683      (define ls2 (call/cc (lambda (k) (set! *k* k) ((car ls1) (car ls1)))))
684      (cons ls1 ls2)))
685  (non-eq-spines?
686    (let ()
687      (define *k*)
688      (define (f)
689        (define (f a . args) (cons a args))
690        (let ([ls (f (call/cc values) 1 2 3)]) (*k* ls)))
691      (define ls1 (call/cc (lambda (k) (set! *k* k) (f))))
692      (define ls2 (call/cc (lambda (k) (set! *k* k) ((car ls1) (car ls1)))))
693      (cons ls1 ls2)))
694  (non-eq-spines?
695    (let ()
696      (define *k*)
697      (define (f)
698        (define (f . args) args)
699        (let ([ls (f 1 (call/cc values) 2 3)]) (*k* ls)))
700      (define ls1 (call/cc (lambda (k) (set! *k* k) (f))))
701      (define ls2 (call/cc (lambda (k) (set! *k* k) ((cadr ls1) (cadr ls1)))))
702      (cons ls1 ls2)))
703  (non-eq-spines?
704    (let ()
705      (define *k*)
706      (define (f)
707        (define (f a . args) (cons a args))
708        (let ([ls (f 1 (call/cc values) 2 3)]) (*k* ls)))
709      (define ls1 (call/cc (lambda (k) (set! *k* k) (f))))
710      (define ls2 (call/cc (lambda (k) (set! *k* k) ((cadr ls1) (cadr ls1)))))
711      (cons ls1 ls2)))
712  (non-eq-spines?
713    (let ()
714      (define *k*)
715      (define (f)
716        (define (f a . args) (cons a args))
717        (let ([ls (f 1 2 (call/cc values) 3)]) (*k* ls)))
718      (define ls1 (call/cc (lambda (k) (set! *k* k) (f))))
719      (define ls2 (call/cc (lambda (k) (set! *k* k) ((caddr ls1) (caddr ls1)))))
720      (cons ls1 ls2)))
721  (non-eq-spines?
722    (let ()
723      (define *k*)
724      (define (f)
725        (define (f . args) args)
726        (let ([ls (f 1 2 3 (call/cc values))]) (*k* ls)))
727      (define ls1 (call/cc (lambda (k) (set! *k* k) (f))))
728      (define ls2 (call/cc (lambda (k) (set! *k* k) ((cadddr ls1) (cadddr ls1)))))
729      (cons ls1 ls2)))
730  (non-eq-spines?
731    (let ()
732      (define *k*)
733      (define (f)
734        (define (f a . args) (cons a args))
735        (let ([ls (f 1 2 3 (call/cc values))]) (*k* ls)))
736      (define ls1 (call/cc (lambda (k) (set! *k* k) (f))))
737      (define ls2 (call/cc (lambda (k) (set! *k* k) ((cadddr ls1) (cadddr ls1)))))
738      (cons ls1 ls2)))
739  ; same thing, with direct lambda applications (should complete the set)
740  (non-eq-spines?
741    (let ()
742      (define *k*)
743      (define (f)
744        (let ([ls ((lambda (a . args) (cons a args)) (call/cc values) 1 2 3)]) (*k* ls)))
745      (define ls1 (call/cc (lambda (k) (set! *k* k) (f))))
746      (define ls2 (call/cc (lambda (k) (set! *k* k) ((car ls1) (car ls1)))))
747      (cons ls1 ls2)))
748  ; same thing, with let-values (should complete the set)
749  (non-eq-spines?
750    (let ()
751      (define *k*)
752      (define (f)
753        (let ([ls (let-values ([(a . args) (values (call/cc values) 1 2 3)]) (cons a args))]) (*k* ls)))
754      (define ls1 (call/cc (lambda (k) (set! *k* k) (f))))
755      (define ls2 (call/cc (lambda (k) (set! *k* k) ((car ls1) (car ls1)))))
756      (cons ls1 ls2)))
757  ; make sure trivial cwv produces same code as let
758  ((lambda (s1 s2)
759     (call-with-port
760       (open-string-input-port s1)
761       (lambda (p1)
762         (call-with-port
763           (open-string-input-port s2)
764           (lambda (p2)
765             (let loop ()
766               (if (eof-object? (get-line p1))
767                   (eof-object? (get-line p2))
768                   (and (not (eof-object? (get-line p2)))
769                        (loop)))))))))
770   (with-output-to-string
771     (lambda ()
772       (parameterize ([gensym-count 0] [print-gensym #f] [#%$assembly-output #t] [#%$suppress-primitive-inlining #f])
773         (eval '(lambda (x)
774                  (let ()
775                    (import scheme)
776                    (call-with-values (lambda () (x)) (lambda (y) (x y)))))))))
777   (with-output-to-string
778     (lambda ()
779       (parameterize ([gensym-count 0] [print-gensym #f] [#%$assembly-output #t])
780         (eval '(lambda (x) (let ([y (x)]) (x y))))))))
781 )
782
783(mat compiler4
784 ; check for overly loose loop recognition
785  (eq? (let ([f (lambda (t)
786                  ((letrec ([merge
787                             (case-lambda [(t) (merge t t)] [(i t) 'yes])])
788                     merge)
789                   t))])
790         (f 3))
791       'yes)
792  (eq? (let ([f (lambda (t)
793                  (define merge (case-lambda [(t) (merge t t)] [(i t) 'yes]))
794                  (merge t))])
795         (f 3))
796       'yes)
797 ; original program from Bob Burger for overly loose loop recognition
798  (equal?
799    (let ()
800      (define (consolidate T)
801        (define merge
802          (case-lambda
803            [(T) (if (null? T) '() (merge (car T) (cdr T)))]
804            [(I T)
805             (if (null? T) (cons I '()) (merge I (car T) (cdr T)))]
806            [(I J T)
807             (let ([I-hi (cdr I)])
808               (if (<= (car J) I-hi)
809                   (let ([J-hi (cdr J)])
810                     (if (<= J-hi I-hi)
811                         (merge I T)
812                         (merge (cons (car I) J-hi) T)))
813                   (cons I (merge J T))))]))
814        (merge T))
815      (consolidate '((1 . 2) (2 . 5))))
816    '((1 . 5)))
817 )
818
819(mat argcnt-check
820   (eqv? (let ((f (lambda (x) #t))) (set! f (lambda (x y) x)) (f 1 2)) 1)
821   (error? (let ((f (lambda (x) x))) (f 1 2)))
822   (let ((f (case-lambda ((x) x) ((x y) #t)))) (f 1 2))
823   (error? (let ((f (case-lambda ((x) x) ((x y) x)))) (f 1 2 3)))
824   (let ((f (case-lambda ((x) x) ((x . y) #t)))) (f 1 2 3))
825   (error? (let ((f (lambda (x y z . r) x))) (f)))
826   (error? (let ((f (lambda (x y z . r) x))) (f 1)))
827   (error? (let ((f (lambda (x y z . r) x))) (f 1 2)))
828   (eqv? (let ((f (lambda (x y z . r) x))) (f 1 2 3)) 1)
829   (eqv? (let ((f (lambda (x y z . r) x))) (f 1 2 3 4)) 1)
830   (eqv? (let ((f (lambda (x y z . r) x))) (f 1 2 3 4 5)) 1)
831   (let ((f (case-lambda ((x . r) x) ((x y . r) y)))) (f #t))
832   (let ((f (case-lambda ((x y . r) y) ((x . r) x)))) (f #t))
833   (error? (let f ((x 3)) (f)))
834   (let f ((x #f)) (or x (f #t)))
835   (let f ((x #f) (y #t)) (or x (f y x)))
836   (error? (let f ((x #f) (y #t)) (or x (f #t))))
837   (let ((f (or (lambda (x) x) (lambda (x y) x)))) (f #t))
838   (error? (let ((f (or 3 (lambda (x) x)))) (f #t)))
839   (guard (c [(equal? (condition-message c) "incorrect argument count in call ~a") #t]
840             [else (raise c)])
841     (let loop ([x 1])
842       (if (fx= x 0)
843           x
844           (loop)))
845     #f)
846   (begin
847     (with-output-to-file "testfile-argcnt-check-loop.ss"
848       (lambda ()
849         (pretty-print
850           '(let loop ([x 1])
851              (if (fx= x 0)
852                  x
853                  (loop)))))
854       'replace)
855     #t)
856   (guard (c [(equal? (condition-message c) "possible incorrect argument count in call ~a") #t]
857             [else #f])
858     (load "testfile-argcnt-check-loop.ss")
859     #f)
860   (guard (c [(equal? (condition-message c) "possible incorrect argument count in call ~a") #t]
861             [else #f])
862     (compile-library "testfile-argcnt-check-loop.ss")
863     #f)
864   (begin
865     (define foo
866       (lambda ()
867         (let loop ([x 1])
868           (if (fx= x 0)
869               x
870               (loop)))))
871     #t)
872   (guard (c [(equal? (condition-message c) "incorrect argument count in call ~a") #t]
873             [else (raise c)])
874     (foo)
875     #f)
876   (begin
877     (with-output-to-file "testfile-argcnt-check-foo.ss"
878       (lambda ()
879         (pretty-print
880           '(define foo
881              (lambda ()
882                (let loop ([x 1])
883                  (if (fx= x 0)
884                      x
885                      (loop)))))))
886       'replace)
887     #t)
888   (guard (c [(equal? (condition-message c) "possible incorrect argument count in call ~a") #t]
889             [else #f])
890     (load "testfile-argcnt-check-foo.ss"))
891   (guard (c [(equal? (condition-message c) "possible incorrect argument count in call ~a") #t]
892             [else #f])
893     (compile-library "testfile-argcnt-check-foo.ss"))
894   (begin
895     (library (argcnt-check-r)
896       (export foo)
897       (import (chezscheme))
898       (define foo
899         (lambda ()
900           (let f ([x 1])
901             (if (fx= x 0)
902                 x
903                 (list (f)))))))
904     #t)
905   (guard (c [(equal? (condition-message c) "incorrect argument count in call ~a") #t]
906             [else (raise c)])
907     (let ()
908       (import (argcnt-check-r))
909       (foo)
910       #f))
911   (begin
912     (library (argcnt-check-s)
913       (export foo foo1 foo2)
914       (import (chezscheme))
915       (define foo
916         (lambda ()
917           (let loop ([x 1])
918             (if (fx= x 0)
919                 x
920                 (loop)))))
921       (define foo1 (lambda () (foo) (foo) (foo) (foo) (foo)))
922       (define foo2 (lambda () (foo))))
923     #t)
924   (guard (c [(equal? (condition-message c) "incorrect argument count in call ~a") #t]
925             [else (raise c)])
926     (let ()
927       (import (argcnt-check-s))
928       (foo)
929       #f))
930   (guard (c [(equal? (condition-message c) "incorrect argument count in call ~a") #t]
931             [else (raise c)])
932     (let ()
933       (import (argcnt-check-s))
934       (foo1)
935       #f))
936   (guard (c [(equal? (condition-message c) "incorrect argument count in call ~a") #t]
937             [else (raise c)])
938     (let ()
939       (import (argcnt-check-s))
940       (foo2)
941       #f))
942   (begin
943     (with-output-to-file "testfile-argcnt-check-s.ss"
944       (lambda ()
945         (pretty-print
946           '(library (testfile-argcnt-check-s)
947              (export foo)
948              (import (chezscheme))
949              (define foo
950                (lambda ()
951                  (let loop ([x 1])
952                    (if (fx= x 0)
953                        x
954                        (loop))))))))
955       'replace)
956     #t)
957   (guard (c [(equal? (condition-message c) "possible incorrect argument count in call ~a") #t]
958             [else (raise c)])
959     (eval '(import (testfile-argcnt-check-s)))
960     #f)
961   (guard (c [(equal? (condition-message c) "possible incorrect argument count in call ~a") #t]
962             [else (raise c)])
963     (load "testfile-argcnt-check-s.ss")
964     #f)
965   (guard (c [(equal? (condition-message c) "possible incorrect argument count in call ~a") #t]
966             [else (raise c)])
967     (compile-library "testfile-argcnt-check-s.ss")
968     #f)
969)
970
971(mat direct-call
972   (let ()
973      (define f (let ((x 3)) (lambda (y) (+ x y))))
974      (define g (lambda () (f 4)))
975      (eq? (g) 7))
976)
977
978(mat inspect ; need lots more
979  (eq? ((call/cc inspect/object) 'type) 'continuation)
980  (eq? ((call/1cc inspect/object) 'type) 'continuation)
981  (integer? ((call/cc inspect/object) 'depth))
982  (integer? ((call/1cc inspect/object) 'depth))
983  (error? ((inspect/object '#(1)) 'ref))
984  (or (equal? (current-eval) interpret)
985      (let ()
986        (define $f (lambda (x) (let ([o (call/cc inspect/object)]) (cons x o))))
987        (let ([q ($f (cons 'a 'b))])
988          (eq? ((cdr q) 'eval 'x) (car q)))))
989  (error? ; invalid message
990    ((inspect/object (cons 'car 'cdr)) 'creep))
991  (error? ; incorrect number of arguments
992    ((inspect/object (cons 'car 'cdr)) 'size))
993  (error? ; invalid generation
994    ((inspect/object (cons 'car 'cdr)) 'size 'oops))
995  (<= ((inspect/object (cons 'car 'cdr)) 'size 0) (fx* (ftype-sizeof uptr) 2))
996  (eqv? ((inspect/object (cons 0 0)) 'size 'static) (fx* (ftype-sizeof uptr) 2))
997  (equal?
998    (let ([ls (list 0 0)])
999      (set-cdr! (cdr ls) ls)
1000      (let ([x (inspect/object ls)])
1001        (let* ([size1 (x 'size 'static)] [size2 ((x 'cdr) 'size 'static)])
1002          (cons size1 size2))))
1003    (cons
1004      (fx* (ftype-sizeof uptr) 4)
1005      (fx* (ftype-sizeof uptr) 2)))
1006)
1007
1008(mat compute-size
1009  (error? (compute-size 0 -1))
1010  (error? (compute-size 0 'dynamic))
1011  (eqv? (compute-size 0) 0)
1012  (eqv? (compute-size (cons 0 0)) (fx* (ftype-sizeof uptr) 2))
1013  (eqv? (compute-size 'cons) 0)
1014  ; from the user's guide
1015  (eqv?
1016    (compute-size 0)
1017    0)
1018  (eqv?
1019    (compute-size (cons 0 0))
1020    (* (ftype-sizeof uptr) 2))
1021  (eqv?
1022    (compute-size (cons (vector #t #f) 0))
1023    (* (ftype-sizeof uptr) 6))
1024  (eqv?
1025    (compute-size
1026      (let ([x (cons 0 0)])
1027        (set-car! x x)
1028        (set-cdr! x x)
1029        x))
1030    (* (ftype-sizeof uptr) 2))
1031  (>=
1032    (let ()
1033      (define-record-type frob (fields x))
1034      (compute-size
1035        (let ([x (make-frob 0)])
1036          (cons x x))))
1037    (* (ftype-sizeof uptr) 16))
1038  (eqv?
1039    (parameterize ([collect-request-handler void])
1040      (let ()
1041        (define-record-type frob (fields x))
1042        (collect 1 1)
1043        (compute-size
1044          (let ([x (make-frob 0)])
1045            (cons x x))
1046          0)))
1047    (* (ftype-sizeof uptr) 4))
1048  ; make sure we don't venture into the undefined fields of a shot 1-shot continuation
1049  (fixnum? (let ([k (call/1cc (lambda (k) k))]) (collect) (compute-size k)))
1050)
1051
1052(mat compute-size-increments
1053  (error? (compute-size-increments 'not-a-list))
1054  (error? (compute-size-increments 0))
1055  (error? (compute-size-increments (list 0) -1))
1056  (error? (compute-size-increments (list 0) "static"))
1057  (error? (compute-size-increments (list 0) '()))
1058  (begin
1059    (define pair-size (compute-size (cons 1 2)))
1060    (define ephemeron-size (compute-size (ephemeron-cons 1 2)))
1061    #t)
1062  (equal? (list pair-size pair-size)
1063          (compute-size-increments (list (cons 1 2) (cons 3 4))))
1064  (equal? (list (* 3 pair-size) pair-size)
1065          (let ([l (list 1 2)])
1066            (compute-size-increments (list (cons 3 l) (cons 4 l)))))
1067  (equal? (list pair-size)
1068          (compute-size-increments (list (weak-cons (make-bytevector 100) #f))))
1069  (let* ([x (make-bytevector 100)]
1070         [ls (list (lambda () x) x)])
1071    (equal? (compute-size-increments ls)
1072            (reverse (compute-size-increments (reverse ls)))))
1073  ;; Ephemeron(s) found before key:
1074  (equal? (list ephemeron-size (* 2 pair-size))
1075          (compute-size-increments (let* ([p (cons 0 0)]
1076                                          [e (ephemeron-cons p (cons 0 0))])
1077                                     (list e p))))
1078  (equal? (list ephemeron-size (* 3 pair-size))
1079          (let* ([v (cons 1 2)]
1080                 [e (ephemeron-cons v (cons 3 4))])
1081            (compute-size-increments (list e (cons v #f)))))
1082  (equal? (list (* 2 (+ ephemeron-size pair-size)) (* 4 pair-size))
1083          (let* ([v (cons 1 2)]
1084                 [e* (list (ephemeron-cons v (cons 3 4))
1085                           (ephemeron-cons v (cons 5 6)))])
1086            (compute-size-increments (list e* (cons v #f)))))
1087  ;; Key found before ephemeron(s):
1088  (equal? (list (* 2 pair-size) (+ ephemeron-size pair-size))
1089          (let* ([v (cons 1 2)]
1090                 [e (ephemeron-cons v (cons 3 4))])
1091            (compute-size-increments (list (cons v #f) e))))
1092  (equal? (list (* 2 pair-size) (+ (* 4 pair-size) (* 2 ephemeron-size)))
1093          (let* ([v (cons 1 2)]
1094                 [e* (list (ephemeron-cons v (cons 3 4))
1095                           (ephemeron-cons v (cons 5 6)))])
1096            (compute-size-increments (list (cons v #f) e*))))
1097  ;; This call will encounter many kinds of objects, just to make
1098  ;; sure it doesn't fail:
1099  (list? (compute-size-increments (list (call/cc values)) 'static))
1100  ;; Check that a deactivated thread's continuation can be traversed
1101  ;; for `compute-size-increments`:
1102  (or (not (threaded?))
1103      (let* ([ready (box #f)]
1104             [saved (box #f)]
1105             [m (make-mutex)]
1106             [N 1000000]
1107             [pause-until (lambda (check)
1108                            (let loop ()
1109                              (unless (check)
1110                                (sleep (make-time 'time-duration 10000 0))
1111                                (loop))))])
1112        (mutex-acquire m)
1113        (let ([th (fork-thread
1114                   (lambda ()
1115                     (let ([bstr (make-bytevector N)])
1116                       (set-box! ready 'go)
1117                       ;; Block so that thread becomes deactivated
1118                       (mutex-acquire m)
1119                       (mutex-release m)
1120                       ;; bstr is retained in the thread's continuation until here
1121                       (set-box! saved (bytevector-u8-ref bstr 0))
1122                       (pause-until (lambda () (box-cas! ready 'finish 'done)))
1123                       ;; Block so that thread becomes deactivated, again
1124                       (mutex-acquire m)
1125                       (mutex-release m))))])
1126          ;; Wait for thread to start
1127          (pause-until (lambda () (eq? 'go (unbox ready))))
1128          ;; Wait for thread to become inactive, blocked on the mutex
1129          (pause-until (lambda () (= 1 (#%$top-level-value '$active-threads))))
1130          ;; Get thread's size, which should include bstr
1131          (let ([pre-sizes (compute-size-increments (list th))])
1132            (mutex-release m)
1133            ;; Wait for bytevector to be discarded in the thread
1134            (pause-until (lambda () (unbox saved)))
1135            (mutex-acquire m)
1136            (set-box! ready 'finish)
1137            ;; Wait for thread to become inactive again
1138            (pause-until (lambda () (= 1 (#%$top-level-value '$active-threads))))
1139            ;; Get thread's size, which shouldn't include bstr
1140            (let ([post-sizes (compute-size-increments (list th))])
1141              (mutex-release m)
1142              ;; Wait for thread to exit
1143              (let ()
1144                (define $threads (foreign-procedure "(cs)threads" () scheme-object))
1145                (pause-until (lambda () (= 1 (length ($threads))))))
1146              ;; Make sure `compute-size-increments` doesn't crash on a
1147              ;; terminated thread:
1148              (compute-size-increments (list th))
1149              ;; Main result: detected size of `bstr` in the thread
1150              ;; while it was part of the continuation
1151              (or (eq? (current-eval) interpret) ; interpreter continuation is not precise enough
1152                  (and (> (car pre-sizes) N)
1153                       (< (car post-sizes) N))))))))
1154  )
1155
1156(mat collect+compute-size-increments
1157  (eq? (void) (collect 0 0 0 #f))
1158  (eq? '() (collect 0 0 0 '()))
1159
1160  (error? (collect 0 0 0 'not-a-list))
1161  (error? (collect 0 0 0 0))
1162  (error? (collect 'not-a-generation 0 0 '()))
1163  (error? (collect 0 'not-a-generation 0 '()))
1164  (error? (collect 0 0 'not-a-generation '()))
1165  (error? (collect 1 0 0 '()))
1166
1167  (begin
1168    (define-record-type count-wrap (fields val))
1169    (collect 0 0 0 (list (make-count-wrap 0))) ; take care of one-time initialization costs
1170    (define wrap-size (car (collect 0 0 0 (list (make-count-wrap 0))))) ; includes rtd
1171    (define just-wrap-size (cadr (collect 0 0 0 (list (make-count-wrap 0) (make-count-wrap 1)))))
1172    (define pair-size (compute-size (cons 1 2)))
1173    (define ephemeron-size (compute-size (ephemeron-cons 1 2)))
1174    #t)
1175  (equal? (list pair-size pair-size)
1176          (collect 0 0 0 (list (cons 1 2) (cons 3 4))))
1177  (equal? (list (* 3 pair-size) pair-size)
1178          (let ([l (list 1 2)])
1179            (collect 0 0 0 (list (cons 3 l) (cons 4 l)))))
1180  (equal? (list pair-size)
1181          (collect 0 0 0 (list (weak-cons (make-bytevector 100) #f))))
1182  ;; Ephemeron(s) found before key:
1183  (equal? (list ephemeron-size (+ (* 2 pair-size) wrap-size))
1184          (collect 0 0 0 (let* ([p (make-count-wrap (cons 0 0))]
1185                               [e (ephemeron-cons p (cons 0 0))])
1186                           (list e p))))
1187  (equal? (list ephemeron-size (+ (* 3 pair-size) wrap-size))
1188          (let* ([v (make-count-wrap (cons 1 2))]
1189                 [e (ephemeron-cons v (cons 3 4))])
1190            (collect 0 0 0 (list e (cons v #f)))))
1191  (equal? (list (* 2 (+ ephemeron-size pair-size)) (+ (* 4 pair-size) wrap-size))
1192          (let* ([v (make-count-wrap (cons 1 2))]
1193                 [e* (list (ephemeron-cons v (cons 3 4))
1194                           (ephemeron-cons v (cons 5 6)))])
1195            (collect 0 0 0 (list e* (cons v #f)))))
1196  ;; Key found before ephemeron(s):
1197  (equal? (list (+ (* 2 pair-size) wrap-size) (+ ephemeron-size pair-size))
1198          (let* ([v (make-count-wrap (cons 1 2))]
1199                 [e (ephemeron-cons v (cons 3 4))])
1200            (collect 0 0 0 (list (cons v #f) e))))
1201  (equal? (list (* 2 pair-size) (+ (* 4 pair-size) (* 2 ephemeron-size)))
1202          (let* ([v (cons 1 2)]
1203                 [e* (list (ephemeron-cons v (cons 3 4))
1204                           (ephemeron-cons v (cons 5 6)))])
1205            (collect 0 0 0 (list (cons v #f) e*))))
1206  ;; Weakly held objects:
1207  (equal? '(0)
1208          (let* ([v (make-count-wrap (cons 1 2))]
1209                 [ls (weak-cons v '())])
1210            (collect 0 0 0 ls)))
1211  (equal? (list wrap-size pair-size (+ just-wrap-size pair-size))
1212          (let* ([v (make-count-wrap (cons 1 2))]
1213                 [ls (cons* (make-count-wrap 0) (cons v 1) (weak-cons v '()))])
1214            (collect 0 0 0 ls)))
1215  (equal? (list 0 (+ wrap-size (* 2 pair-size)))
1216          (let* ([v (make-count-wrap (cons 1 2))]
1217                 [ls (weak-cons v (cons (cons v 1) '()))])
1218            (collect 0 0 0 ls)))
1219  (equal? #!bwp
1220          (let* ([v (make-count-wrap (cons 1 2))]
1221                 [ls (weak-cons v '())])
1222            (collect 0 0 0 ls)
1223            (car ls)))
1224  ;; These calls will encounter many kinds of objects, just to make
1225  ;; sure they don't fail:
1226  (list? (collect 0 0 0 (list (call/cc values))))
1227  (list? (collect (collect-maximum-generation) (collect-maximum-generation) (collect-maximum-generation) (list (call/cc values))))
1228
1229  (let ()
1230    (define e (ephemeron-cons #t (gensym)))
1231    (collect 0 1)
1232    (let ([g (gensym)])
1233      (set-car! e g)
1234      (set! g #f)
1235      ;; For this collection, `e` is both on the dirty list
1236      ;; and involved in measuring; make sure those roles
1237      ;; don't conflict
1238      (collect 1 1 1 (list e))
1239      (equal? e (cons #!bwp #!bwp))))
1240
1241  (let ()
1242    (define e (ephemeron-cons #t 'other))
1243    (collect 0 1)
1244    (let ([g (gensym)])
1245      (set-car! e g)
1246      (collect 1 1 1 (list e))
1247      (equal? e (cons g 'other))))
1248)
1249
1250(mat compute-composition
1251  (error? (compute-composition 0 -1))
1252  (error? (compute-composition 0 "static"))
1253  (equal? (compute-composition 0) '())
1254  (equal?
1255    (sort (lambda (x y) (fx> (cadr x) (cadr y)))
1256      (compute-composition (cons (fxvector 1) (vector (fxvector 2) (fxvector 3) (list (fxvector 4))))))
1257    `((fxvector . (4 . ,(fx* 4 (ftype-sizeof uptr) 2))) (pair . (2 . ,(fx* 2 (ftype-sizeof uptr) 2))) (vector . (1 . ,(fx* 4 (ftype-sizeof uptr))))))
1258  (equal? (compute-composition 'cons) '())
1259  ; from the user's guide
1260  (begin
1261    (define $same-elements?
1262      (lambda (ls1 ls2)
1263        (and (equal? (length ls1) (length ls2))
1264             (let f ([ls1 ls1])
1265               (or (null? ls1)
1266                   (and (member (car ls1) ls2)
1267                        (f (cdr ls1))))))))
1268    #t)
1269  (equal?
1270    (compute-composition 0)
1271    '())
1272  ($same-elements?
1273    (compute-composition (cons 0 0))
1274    `((pair 1 . ,(* (ftype-sizeof uptr) 2))))
1275  (equal?
1276    (compute-composition (cons (vector #t #f) 0))
1277    `((pair 1 . ,(* (ftype-sizeof uptr) 2))
1278      (vector 1 . ,(* (ftype-sizeof uptr) 4))))
1279  (equal?
1280    (compute-composition
1281      (let ([x (cons 0 0)])
1282        (set-car! x x)
1283        (set-cdr! x x)
1284        x))
1285    `((pair 1 . ,(* (ftype-sizeof uptr) 2))))
1286  (>=
1287    (let ()
1288      (define-record-type frob (fields x))
1289      (length
1290        (compute-composition
1291          (let ([x (make-frob 0)])
1292            (cons x x)))))
1293    4) ; pair, rtd, record, fields vector, name
1294  (let ()
1295    (define-record-type frob (fields x))
1296    ($same-elements?
1297      (parameterize ([collect-request-handler void])
1298        (let ()
1299          (collect 1 1)
1300          (compute-composition
1301            (let ([x (make-frob 0)])
1302              (cons x x))
1303            0)))
1304      `((pair 1 . ,(* (ftype-sizeof uptr) 2))
1305        (,(record-type-descriptor frob) 1 . ,(* (ftype-sizeof uptr) 2)))))
1306  ; make sure we don't venture into the undefined fields of a shot 1-shot continuation
1307  (list? (let ([k (call/1cc (lambda (k) k))]) (collect) (compute-composition k)))
1308)
1309
1310(mat make-object-finder
1311  (begin
1312    (define $fo
1313      (lambda args
1314        (let ([find-next (apply make-object-finder args)])
1315          (cond
1316            [(find-next) =>
1317             (lambda (path)
1318               (unless (list? path)
1319                 (errorf '$fo-all "~s is not a list" path))
1320               path)]
1321            [else #f]))))
1322    (define $fo-all
1323      (lambda args
1324        (let ([find-next (apply make-object-finder args)])
1325          (let f ()
1326            (cond
1327              [(find-next) =>
1328               (lambda (path)
1329                 (unless (list? path)
1330                   (errorf '$fo-all "~s is not a list" path))
1331                 (cons path (f)))]
1332              [else '()])))))
1333    (define set-equal?
1334      (lambda (s1 s2)
1335        (and (= (length s1) (length s2))
1336             (andmap (lambda (x) (member x s2)) s1)
1337             #t)))
1338    #t)
1339  (error? ; not a procedure
1340    (make-object-finder 17))
1341  (error? ; invalid generation
1342    (make-object-finder not 'q (+ (collect-maximum-generation) 1)))
1343  (error? ; invalid generation
1344    (make-object-finder not 'q 'oldgen))
1345  (error? ; invalid generation
1346    (make-object-finder not 'q -1))
1347  (error? ; invalid number of arguments
1348    ((make-object-finder fixnum? 1) 'a))
1349  (not ($fo (let ([ctr 0]) (lambda (x) (set! ctr (+ ctr 1)) (when (= (mod ctr 4000) 0) (pretty-print ctr)) #f))))
1350  (pair? ($fo symbol?))
1351  (not ($fo symbol? (list 1 2 3)))
1352  (equal?
1353    ($fo symbol? (list 1 'a-symbol-probably-not-static 3))
1354    '(a-symbol-probably-not-static (a-symbol-probably-not-static 3) (1 a-symbol-probably-not-static 3)))
1355  (equal?
1356    ($fo symbol? (list 1 'a 3))
1357    '(a (a 3) (1 a 3)))
1358  (equal?
1359    ($fo symbol? (list 'a-symbol-probably-not-static 2 3))
1360    '(a-symbol-probably-not-static (a-symbol-probably-not-static 2 3)))
1361  (equal?
1362    ($fo symbol? (list 'a 2 3))
1363    '(a (a 2 3)))
1364  (equal?
1365    ($fo flonum? (list 1 3.14 3))
1366    '(3.14 (3.14 3) (1 3.14 3)))
1367  (not ($fo symbol? (vector 1 2 3)))
1368  (equal?
1369    ($fo symbol? (vector 1 'a-symbol-probably-not-static 3))
1370    '(a-symbol-probably-not-static #(1 a-symbol-probably-not-static 3)))
1371  (equal?
1372    ($fo flonum? (vector 1 3.14 3))
1373    '(3.14 #(1 3.14 3)))
1374  (equal?
1375    ($fo fixnum? (vector 1 'a-symbol-probably-not-static 3))
1376    '(1 #(1 a-symbol-probably-not-static 3)))
1377  (equal?
1378    ($fo-all fixnum? 1)
1379    '((1)))
1380  (set-equal?
1381    ($fo-all fixnum? (vector 1 'a-symbol-probably-not-static 3))
1382    '((1 #(1 a-symbol-probably-not-static 3)) (3 #(1 a-symbol-probably-not-static 3))))
1383  (set-equal?
1384    ($fo-all fixnum? (list 1 'a-symbol-probably-not-static 3))
1385    '((1 (1 a-symbol-probably-not-static 3)) (3 (3) (a-symbol-probably-not-static 3) (1 a-symbol-probably-not-static 3))))
1386  (let-values ([(g path*) (parameterize ([generate-inspector-information #f]
1387                                         [compile-profile #f]
1388                                         [current-eval compile]
1389                                         [enable-cp0 #f])
1390                            (eval `(let ()
1391                                     (define f (lambda (x) (lambda (y) (cons x '#(4 5)))))
1392                                     (define g (f '#(a b)))
1393                                     (values g ($fo-all vector? g)))))])
1394    (set-equal?
1395      path*
1396      `((#(4 5) ,(#%$closure-code g) ,g)
1397        (#(a b) ,g))))
1398  (not ($fo (lambda (x) (and (string? x) (string=? x "cons"))) 'cons 0))
1399  (list? ($fo (lambda (x) (and (string? x) (string=? x "cons"))) 'cons 'static))
1400  ; make sure we don't venture into the undefined fields of a shot 1-shot continuation
1401  (not (let ([k (call/1cc (lambda (k) k))]) (collect) ($fo (lambda (x) #f) k)))
1402)
1403
1404(mat print-vector-length
1405    (not (print-vector-length))
1406    (let ([p (open-output-string)])
1407       (write '#(1 2 3) p)
1408       (string=? (get-output-string p) "#(1 2 3)"))
1409    (let ([p (open-output-string)])
1410       (parameterize ([print-vector-length #t])
1411          (write '#(1 2 3) p))
1412       (string=? (get-output-string p) "#3(1 2 3)"))
1413    )
1414
1415(mat print-brackets
1416    (print-brackets)
1417    (let ([p (open-output-string)])
1418       (pretty-print '(let ([x x]) x) p)
1419       (string=? (get-output-string p) (format "(let ([x x]) x)~%")))
1420    (let ([p (open-output-string)])
1421       (parameterize ([print-brackets #f])
1422          (pretty-print '(let ([x x]) x) p))
1423       (string=? (get-output-string p) (format "(let ((x x)) x)~%")))
1424    )
1425
1426(mat subset
1427  (not (subset-mode))
1428  (error? (subset-mode 'ieee))
1429  (error? (subset-mode 'r4rs))
1430  (error? (subset-mode 'r5rs))
1431  (error? (subset-mode #t))
1432  (begin (subset-mode #f) (not (subset-mode)))
1433)
1434
1435(mat eval
1436  (eq? (eval '(let ((x 3)) x)) 3)
1437  (eq? (eval '(let ((x 3)) x) (interaction-environment)) 3)
1438  (eq? (eval '(let ((x 3)) x) (scheme-report-environment 5)) 3)
1439  (eq? (eval '(let ((x 3)) x) (ieee-environment)) 3)
1440  (eq? (eval '(let ((x 3)) x) (null-environment 5)) 3)
1441
1442  (eq? (eval '(let ((p (delay 3))) (force p))) 3)
1443  (eq? (eval '(let ((p (delay 3))) (force p)) (interaction-environment)) 3)
1444  (eq? (eval '(let ((p (delay 3))) (force p)) (scheme-report-environment 5)) 3)
1445  (error? (eval '(let ((p (delay 3))) (force p)) (null-environment 5)))
1446  (error? (eval '(let ((p (delay 3))) (force p)) (ieee-environment)))
1447
1448  (error? (eval '(cons 1 2) (null-environment 5)))
1449  (error? (eval '(sort < '(3 2 4)) (scheme-report-environment 5)))
1450  (error? (eval '(sort < '(3 2 4)) (ieee-environment)))
1451  (error? (eval '(sort < '(3 2 4)) (null-environment 5)))
1452)
1453
1454(mat eval2
1455  (eq? (eval '(let ((x 3)) x)) 3)
1456  (eq? (eval '(let ((x 3)) x) (interaction-environment)) 3)
1457  (eq? (eval '(let ((x 3)) x) (scheme-report-environment 5)) 3)
1458  (eq? (eval '(let ((x 3)) x) (null-environment 5)) 3)
1459  (eq? (eval '(let ((x 3)) x) (ieee-environment)) 3)
1460
1461  (eq? (eval 'list) list)
1462  (eq? (eval 'list (interaction-environment)) list)
1463  (eq? (eval 'list (scheme-report-environment 5)) list)
1464  (error? (eval 'list (null-environment 5)))
1465  (eq? (eval 'list (ieee-environment)) list)
1466
1467  (eq? (eval 'force) force)
1468  (eq? (eval 'force (interaction-environment)) force)
1469  (eq? (eval 'force (scheme-report-environment 5)) force)
1470  (error? (eval 'force (null-environment 5)))
1471  (error? (eval 'force (ieee-environment)))
1472
1473  (eq? (force (eval '(delay 17))) 17)
1474  (eq? (force (eval '(delay 17) (interaction-environment))) 17)
1475  (eq? (force (eval '(delay 17) (scheme-report-environment 5))) 17)
1476  (eq? (force (eval '(delay 17) (null-environment 5))) 17)
1477  (error? (eval '(delay 17) (ieee-environment)))
1478
1479  (error? (eval '(set! + -) (scheme-report-environment 5)))
1480  (error? (eval '(set! + -) (null-environment 5)))
1481  (error? (eval '(set! + -) (ieee-environment)))
1482
1483  (error? (eval '(define x -) (scheme-report-environment 5)))
1484  (error? (eval '(define x -) (null-environment 5)))
1485  (error? (eval '(define x -) (ieee-environment)))
1486
1487  (error? (eval '(define-syntax x list) (scheme-report-environment 5)))
1488  (error? (eval '(define-syntax x list) (null-environment 5)))
1489  (error? (eval '(define-syntax x list) (ieee-environment)))
1490  (error? (eval '(define-syntax x (syntax-rules () ((_) 4)))
1491                (ieee-environment)))
1492
1493  (eq? (eval '(syntax-case 3 () (_ 4))) 4)
1494  (eq? (eval '(syntax-case 3 () (_ 4)) (interaction-environment)) 4)
1495  (error? (eval '(syntax-case 3 () (_ 4)) (scheme-report-environment 5)))
1496  (error? (eval '(syntax-case 3 () (_ 4)) (null-environment 5)))
1497  (error? (eval '(syntax-case 3 () (_ 4)) (ieee-environment)))
1498)
1499
1500(mat getenv/putenv
1501  (procedure? getenv)
1502  (procedure? putenv)
1503  (or (embedded?)
1504      (string? (or (getenv "HOME") (getenv "HOMEPATH"))))
1505  (not (getenv "FUBULYFRATZ"))
1506  (eq? (putenv "FUBULY" "FRATZ") (void))
1507  (not (getenv "FUBULYFRATZ"))
1508  (equal? (getenv "FUBULY") "FRATZ")
1509  (eq? (putenv "FUBULY" "fratz") (void))
1510  (equal? (getenv "FUBULY") "fratz")
1511  (error? (getenv 'hello))
1512  (error? (putenv 'hello "goodbye"))
1513  (error? (putenv "hello" 'goodbye))
1514 )
1515
1516(mat source-directories
1517  (equal? (separate-eval '(source-directories)) "(\".\")\n")
1518  (equal? (parameterize ((source-directories (list "/a" ".")))
1519            (source-directories))
1520          '("/a" "."))
1521  (error? (source-directories 'a))
1522  (error? (source-directories "a"))
1523  (error? (source-directories '("a" . "b")))
1524  (error? (source-directories '(3)))
1525  (error? ; invalid exports list---not "testfile.ss not found in source directories"
1526    (begin
1527      (with-output-to-file "testfile.ss"
1528        (lambda () (pretty-print '(module (a 3) (define a 3))))
1529        'replace)
1530      (parameterize ([source-directories '("." "probably not there")])
1531        (load "testfile.ss"))))
1532)
1533
1534(mat queries
1535  (boolean? (threaded?))
1536  (boolean? (petite?))
1537  (let ([pid (get-process-id)])
1538    (and (integer? pid) (exact? pid)))
1539  (eqv? (get-thread-id) 0)
1540  (eqv? (get-process-id) (get-process-id))
1541  (eqv? (get-thread-id) (get-thread-id))
1542)
1543
1544(mat cpletrec
1545  (eq? (letrec ((x 3)) x) 3)
1546  (eq? (letrec ((x 3)) 4) 4)
1547  (eq? (letrec ((x (let ((y 4)) (lambda (x) (+ x y))))) (x 7)) 11)
1548  (eq? (letrec ((x (letrec ((y 4)) (lambda (x) (+ x y))))) (x 7)) 11)
1549  (eq? (letrec ((x 4)) (set! x 3)) (void))
1550  (eq? (letrec ((x 4)) (set! x (begin (write 'hi) 3))) (void))
1551  (eq? (letrec ((x (letrec ((y (lambda (z) (+ z z))))
1552                     (lambda (x) (y x)))))
1553         (x 3))
1554       6)
1555  (equal? (letrec ((foo (rec f (lambda (x ls) (list x ls))))) (foo 1 2))
1556    '(1 2))
1557  (eq? (letrec ((x (let ((a (+ 3 4))) (let ((b (+ a a))) b)))) x) 14)
1558  (eq? (letrec ((x (let ((a (lambda (x) (+ x 1))))
1559                     (let ((b (lambda (y) (+ (a y) y))))
1560                       (lambda (z) (* (b z) z))))))
1561         (x 3))
1562       21)
1563  (equal?
1564    (let ()
1565      (define next
1566        (let ((cnt 0))
1567          (lambda () (set! cnt (+ cnt 1)) cnt)))
1568      (define list-next
1569        (lambda ()
1570          (list (next) (next))))
1571      (sort < (cons (next) (list-next))))
1572    '(1 2 3))
1573  (record?
1574    ((let ()
1575       (define-record foo (a b c))
1576       make-foo)
1577     1 2 3))
1578  (record?
1579    ((let ()
1580       (define-record foo (a b c) (((mutable d) (+ a b))))
1581       make-foo)
1582     1 2 3))
1583  (record?
1584    ((let ()
1585       (define-record foo (a b c))
1586       make-foo)
1587     1 2 3))
1588  (error? (letrec ((x (foreign-procedure "foo" () void))) (x 17)))
1589  (equal?
1590    (letrec ((x (let ((a 3)
1591                      (b (letrec ((e (lambda (y) (eq? y x))))
1592                           (lambda () (e x))))
1593                      (d (let ((c 4)) (lambda () (+ 5 c)))))
1594                  (lambda ()
1595                    (list a (b) (d))))))
1596      (x))
1597    '(3 #t 9))
1598  (equal?
1599    (letrec ((x (let ((a 3)
1600                      (b (letrec ((e (lambda (y) (eq? y x))))
1601                           (lambda () (e x))))
1602                      (d (let ((c 4)) (lambda () (+ 5 c)))))
1603                  (lambda ()
1604                    (set! a (+ a 1))
1605                    (list a (b) (d))))))
1606      (x))
1607    '(4 #t 9))
1608  (equal?
1609    (letrec ((x (let ((a 3))
1610                  (letrec ((b (lambda (x) (+ x 2)))
1611                           (d (lambda (y) (* y y))))
1612                    (lambda ()
1613                      (set! a (+ a 1))
1614                      (list a (b a) (d a)))))))
1615      (x))
1616    '(4 6 16))
1617  (equal?
1618    (letrec ((x (let ((a 3))
1619                  (let ((b (letrec ((e (lambda (y) (eq? y x))))
1620                             (lambda () (e x))))
1621                        (d (let ((c 4)) (lambda () (+ a c)))))
1622                    (lambda ()
1623                      (set! a (+ a 1))
1624                      (list a (b) (d)))))))
1625     (x))
1626   '(4 #t 8))
1627  #;(warning?
1628    (begin
1629      (define unknown (lambda (x) x))
1630      (letrec ([foo (unknown (lambda () bar))]
1631               [bar (lambda () foo)])
1632        foo)))
1633  #;(warning?
1634    (mat/cf
1635      (begin
1636        (define unknown (lambda (x) x))
1637        (letrec ([foo (unknown (lambda () bar))]
1638                 [bar (unknown (lambda () foo))])
1639          foo))))
1640  (error?
1641    (eval '(letrec* ([f (lambda () q)] [g (f)] [q 17]) g)))
1642  (error?
1643    (eval '(begin
1644             (define unknown (lambda (x) (x)))
1645             (letrec ([foo (unknown (lambda () bar))]
1646                      [bar (lambda () foo)])
1647               foo))))
1648  (error?
1649    (eval '(mat/cf
1650             (begin
1651               (define unknown (lambda (x) (x)))
1652               (letrec ([foo (unknown (lambda () bar))]
1653                        [bar (unknown (lambda () foo))])
1654                 foo)))))
1655 ; test cpvalid/undefer interaction
1656  (error? ; attempt to reference undefined variable b
1657    (letrec* ([d (letrec ([a (lambda () c)] [b 1] [c b]) 2)]) 3))
1658  (error? ; attempt to reference undefined variable b
1659    (letrec* ([d (letrec ([a (lambda () 0)] [b 1] [c b]) 2)]) 3))
1660  (error? ; attempt to reference undefined variable a
1661    (letrec* ([d (letrec ([a (lambda () 1)] [c a]) 2)]) 3))
1662  (error? ; attempt to reference undefined variable b
1663    (letrec* ([d (letrec* ([a (lambda () 1)] [c b] [b 4]) 2)]) 3))
1664  (error? ; attempt to reference undefined variable b
1665    (letrec* ([d (letrec ([a (set! b (lambda () 0))] [b 1]) 2)]) 3))
1666  (eqv?
1667    (letrec* ([d (letrec ([a (lambda () 1)] [c (if #f a)]) 2)]) 3)
1668    3)
1669  (eqv?
1670    (letrec* ([d (letrec* ([a (lambda () 1)] [c (if #f b)] [b 4]) 2)]) 3)
1671    3)
1672  (eqv?
1673    (letrec* ([d (letrec ([a (if #f (set! b (lambda () 0)))] [b 1]) 2)]) 3)
1674    3)
1675  (eqv?
1676    (letrec* ([d (letrec ([a (lambda () 0)] [b 1] [c 2]) 2)]) 3)
1677    3)
1678  (procedure? (letrec* ([bar (letrec* ([f (lambda (x) f)]) f)]) bar))
1679  (eqv?
1680    (letrec* ([d (letrec* ([a 0] [b (set! a (lambda () 1))]) 2)]) 3)
1681    3)
1682 ; make sure we don't get valid check(s)
1683  (equivalent-expansion?
1684    (parameterize ([run-cp0 (lambda (cp0 x) (cp0 x))]
1685                   [optimize-level 2])
1686      (expand/optimize
1687        '(let ()
1688           (define f (lambda () (g)))
1689           (define g (lambda () 17))
1690           (define x (f))
1691           x)))
1692    '17)
1693  ; check for regression: cpvalid leaving behind a cpvalid-defer form
1694  (equivalent-expansion?
1695    (parameterize ([run-cp0 (lambda (cp0 x) x)]
1696                   [optimize-level 2])
1697      (expand/optimize '(letrec* ([f (letrec ([x x]) (lambda () x))]) 0)))
1698    '(let ([f (let ([valid? #f])
1699                (let ([x (#2%void)])
1700                  (set! x
1701                    (begin
1702                      (if valid?
1703                          (#2%void)
1704                          (#2%$source-violation #f #f #t
1705                            "attempt to reference undefined variable ~s" 'x))
1706                      x))
1707                  (set! valid? #t)
1708                  (lambda () x)))])
1709       0))
1710)
1711
1712(mat generate-procedure-source-information
1713  (begin
1714    (define the-source
1715      (let ([sfd (make-source-file-descriptor "the-source.ss" (open-bytevector-input-port '#vu8()))])
1716        (make-source-object sfd 10 20)))
1717    (define (make-proc full-inspect?)
1718      (parameterize ([generate-inspector-information full-inspect?]
1719                     [generate-procedure-source-information #t])
1720        (let ([e '(lambda (x) x)])
1721          (compile (make-annotation e the-source e)))))
1722    (define proc-i (make-proc #t))
1723    (define proc-n (make-proc #f))
1724    (and (procedure? proc-i)
1725         (procedure? proc-n)))
1726  (equal? (((inspect/object proc-i) 'code) 'source-object)
1727          the-source)
1728  (equal? (((inspect/object proc-n) 'code) 'source-object)
1729          the-source)
1730  (equal? ((((inspect/object proc-i) 'code) 'source) 'value)
1731          '(lambda (x) x))
1732  (equal? (((inspect/object proc-n) 'code) 'source)
1733          #f)
1734)
1735
1736(mat strip-fasl-file
1737  (error?
1738    (fasl-strip-options ratfink profile-source))
1739  (error? ; not a string
1740    (strip-fasl-file (fasl-strip-options profile-source) "testfile.so" (fasl-strip-options profile-source)))
1741  (error? ; not a string
1742    (strip-fasl-file "testfile.so" (fasl-strip-options profile-source) (fasl-strip-options profile-source)))
1743  (error? ; not a fasl-strip-options object
1744    (strip-fasl-file "testfile.so" "testfile.so" "testfile.so"))
1745  (enum-set? (fasl-strip-options))
1746  (enum-set? (fasl-strip-options inspector-source))
1747  (enum-set? (fasl-strip-options inspector-source compile-time-information))
1748  (begin
1749    (define object-file-size
1750      (lambda (path)
1751        (bytevector-length (call-with-port (open-file-input-port path (file-options compressed)) get-bytevector-all))))
1752    (define strip-and-check
1753      (lambda (in out options)
1754        (let ([n (object-file-size in)])
1755          (strip-fasl-file in out options)
1756          (< (object-file-size out) n))))
1757    #t)
1758
1759  ; plain libraries
1760  (begin
1761    (with-output-to-file "testfile-sff-1a.ss"
1762      (lambda ()
1763        (pretty-print
1764          '(library (testfile-sff-1a)
1765             (export a x)
1766             (import (chezscheme))
1767             (define-syntax a (identifier-syntax (x 5)))
1768             (define x (lambda (n) (if (= n 0) 1 (* n (x (- n 1)))))))))
1769      'replace)
1770    (with-output-to-file "testfile-sff-1b.ss"
1771      (lambda ()
1772        (pretty-print
1773          '(library (testfile-sff-1b)
1774             (export b y)
1775             (import (chezscheme) (testfile-sff-1a))
1776             (define-syntax b (syntax-rules () [(_ k) (k y)]))
1777             (define y (x 4)))))
1778      'replace)
1779    (with-output-to-file "testfile-sff-1c.ss"
1780      (lambda ()
1781        (pretty-print '(define preexisting-entries (length (profile-dump))))
1782        (pretty-print '(eval-when (compile) (import (add-prefix (testfile-sff-1a) sff-1a-))))
1783        (pretty-print '(eval-when (compile) (import (add-prefix (testfile-sff-1b) sff-1b-))))
1784        (pretty-print '(pretty-print (list (sff-1a-x 3) sff-1b-y)))
1785        (pretty-print '(pretty-print (not (((inspect/object sff-1a-x) 'code) 'source))))
1786        (pretty-print '(pretty-print (= (length (profile-dump)) preexisting-entries))))
1787      'replace)
1788    (delete-file "testfile-sff-1a.so")
1789    (delete-file "testfile-sff-1b.so")
1790    (delete-file "testfile-sff-1c.so")
1791    (separate-compile
1792      '(lambda (x)
1793         (parameterize ([generate-inspector-information #t]
1794                        [compile-profile #t]
1795                        [compile-imported-libraries #t])
1796           (compile-file x)))
1797      'sff-1c)
1798    #t)
1799  (begin
1800    (define (go)
1801      (separate-eval
1802        '(define preexisting-entries
1803           (with-exception-handler
1804             (lambda (c) (unless (warning? c) (raise-continuable c)))
1805             (lambda () (length (profile-dump-list)))))
1806        '(import (testfile-sff-1a))
1807        '(import (testfile-sff-1b))
1808        '(define-syntax so?
1809           (lambda (x)
1810             (syntax-case x ()
1811               [(_ q) (and (syntax->annotation #'q) #t)])))
1812        '(list a (b so?) (x 3) y)
1813        '(not (((inspect/object x) 'code) 'source))
1814        '(define all-entries
1815           (with-exception-handler
1816             (lambda (c) (unless (warning? c) (raise-continuable c)))
1817             (lambda () (length (profile-dump-list)))))
1818        '(= all-entries preexisting-entries)))
1819    #t)
1820  (equal?
1821    (go)
1822    "(120 #t 6 24)\n#f\n#f\n")
1823  (strip-and-check "testfile-sff-1a.so" "testfile-sff-1a.so"
1824    (fasl-strip-options inspector-source))
1825  (strip-and-check "testfile-sff-1b.so" "testfile-sff-1b.so"
1826    (fasl-strip-options inspector-source))
1827  (equal?
1828    (go)
1829    "(120 #t 6 24)\n#t\n#f\n")
1830  (strip-and-check "testfile-sff-1a.so" "testfile-sff-1a.so"
1831    (fasl-strip-options profile-source))
1832  (strip-and-check "testfile-sff-1b.so" "testfile-sff-1b.so"
1833    (fasl-strip-options profile-source))
1834  (equal?
1835    (go)
1836    "(120 #t 6 24)\n#t\n#t\n")
1837  (strip-and-check "testfile-sff-1a.so" "testfile-sff-1a.so"
1838    (fasl-strip-options source-annotations))
1839  (strip-and-check "testfile-sff-1b.so" "testfile-sff-1b.so"
1840    (fasl-strip-options source-annotations))
1841  (equal?
1842    (go)
1843    "(120 #f 6 24)\n#t\n#t\n")
1844  (strip-and-check "testfile-sff-1a.so" "testfile-sff-1a.so"
1845    (fasl-strip-options compile-time-information))
1846  (strip-and-check "testfile-sff-1b.so" "testfile-sff-1b.so"
1847    (fasl-strip-options compile-time-information))
1848  (strip-and-check "testfile-sff-1c.so" "testfile-sff-1c.so"
1849    (fasl-strip-options profile-source))
1850  (equal?
1851    (separate-eval
1852      '(guard (c [else (display-condition c) (newline) #t]) (eval '(import (testfile-sff-1b))))
1853      '(guard (c [else (display-condition c) (newline) #t]) (eval '(import (testfile-sff-1a))))
1854      '(expand 'a)
1855      '(expand 'b)
1856      '(load "testfile-sff-1c.so")
1857      '(guard (c [else (display-condition c) (newline) #t]) (eval '(import (testfile-sff-1b)))))
1858    "Exception: loading testfile-sff-1b.so did not define library (testfile-sff-1b)\n#t\n\
1859     Exception: loading testfile-sff-1a.so did not define library (testfile-sff-1a)\n#t\n\
1860     a\nb\n\
1861     (6 24)\n#t\n#t\n\
1862     Exception: loading testfile-sff-1b.so did not define compile-time information for library (testfile-sff-1b)\n#t\n\
1863     ")
1864
1865  ; scripts
1866  (begin
1867    (with-output-to-file "testfile-sff.ss"
1868      (lambda ()
1869        (printf "#! ~a --script\n" *scheme*)
1870        (pretty-print '(define (hello) (import (chezscheme)) (printf "hello\n")))
1871        (pretty-print '(hello)))
1872      'replace)
1873    (parameterize ([generate-inspector-information #t])
1874      (compile-script "testfile-sff"))
1875    #t)
1876  (strip-and-check "testfile-sff.so" "testfile-sff-stripped.so"
1877    (fasl-strip-options inspector-source))
1878  (equal?
1879    (separate-eval
1880      '(load "testfile-sff.so")
1881      '(and (((inspect/object hello) 'code) 'source) #t))
1882    "hello\n#t\n")
1883  (equal?
1884    (separate-eval
1885      '(load "testfile-sff-stripped.so")
1886      '(and (((inspect/object hello) 'code) 'source) #t))
1887    "hello\n#f\n")
1888  (equal?
1889    (run-script "./testfile-sff.so")
1890    "hello\n")
1891  (equal?
1892    (run-script "./testfile-sff-stripped.so")
1893    "hello\n")
1894
1895  ; non-library compile-time-information
1896  (begin
1897    (with-output-to-file "testfile-sff-3.ss"
1898      (lambda ()
1899        (pretty-print '(define cons vector))
1900        (pretty-print '(define-syntax + (identifier-syntax -))))
1901      'replace)
1902    (separate-compile 'sff-3)
1903    (define $orig-size (object-file-size "testfile-sff-3.so"))
1904    #t)
1905  (equal?
1906    (separate-eval
1907      '(load "testfile-sff-3.so")
1908      '(cons 3 4)
1909      '(+ 3 4))
1910    "#(3 4)\n-1\n")
1911  (strip-and-check "testfile-sff-3.so" "testfile-sff-3.so"
1912    (fasl-strip-options compile-time-information))
1913  (< (object-file-size "testfile-sff-3.so") $orig-size)
1914  (equal?
1915    (separate-eval
1916      '(load "testfile-sff-3.so")
1917      '(cons 3 4)
1918      '(+ 3 4))
1919    "(3 . 4)\n7\n")
1920  (let ([n (object-file-size "testfile-sff-3.so")])
1921    (strip-fasl-file "testfile-sff-3.so" "testfile-sff-3.so"
1922      (fasl-strip-options compile-time-information))
1923    (= (object-file-size "testfile-sff-3.so") n))
1924  (begin
1925    (mkfile "testfile-sff-4.ss"
1926      '(library (testfile-sff-4) (export a b c) (import (chezscheme))
1927         (define-syntax a (identifier-syntax 12))
1928         (define b 13)
1929         (meta define c 14)))
1930    (mkfile "testfile-sff-4p.ss"
1931      '(import (chezscheme) (testfile-sff-4))
1932      '(write b))
1933    (separate-compile
1934      '(lambda (x) (parameterize ([compile-imported-libraries #t]) (compile-program x)))
1935      'sff-4p)
1936    #t)
1937  (equal?
1938    (separate-eval
1939      '(let ()
1940         (import (testfile-sff-4))
1941         (define-syntax cc (lambda (x) c))
1942         (printf "a = ~s, b = ~s, c = ~s\n" a b cc)))
1943    "a = 12, b = 13, c = 14\n")
1944  (equal?
1945    (separate-eval
1946      '(let ([x (with-output-to-string (lambda () (load-program "testfile-sff-4p.so")))])
1947         (printf "b = ~a, a = ~s\n" x (eval 'a (environment '(testfile-sff-4))))))
1948    "b = 13, a = 12\n")
1949  (begin
1950    (strip-fasl-file "testfile-sff-4.so" "testfile-sff-4.so"
1951      (fasl-strip-options compile-time-information))
1952    #t)
1953  (error? ; no compile-time info
1954    (separate-eval
1955      '(let ()
1956         (import (testfile-sff-4))
1957         (list a b))))
1958  (error? ; no compile-time info
1959    (separate-eval
1960      '(let ([x (with-output-to-string (lambda () (load-program "testfile-sff-4p.so")))])
1961         (printf "b = ~a, a = ~s\n" x (eval 'a (environment '(testfile-sff-4)))))))
1962  (error? ; no compile-time info
1963    (separate-eval
1964      '(let ([x (with-output-to-string (lambda () (load-program "testfile-sff-4p.so")))])
1965         (printf "b = ~a, a = ~s\n" x (eval '(let () (import (testfile-sff-4)) a))))))
1966  (error? ; no compile-time info
1967    (separate-eval
1968      '(parameterize ([import-notify #t])
1969         (let ([x (with-output-to-string (lambda () (load-program "testfile-sff-4p.so")))])
1970           (printf "b = ~a, a = ~s\n" x (eval '(let () (import (testfile-sff-4)) a)))))))
1971)
1972
1973(mat $fasl-file-equal?
1974  (let ([fn (format "~a/fatfib.ss" *examples-directory*)])
1975    (parameterize ([generate-inspector-information #t])
1976      (compile-file fn "testfile-fatfib1.so"))
1977    (parameterize ([generate-inspector-information #t])
1978      (compile-file fn "testfile-fatfib2.so"))
1979    (parameterize ([generate-inspector-information #f])
1980      (compile-file fn "testfile-fatfib3.so"))
1981    #t)
1982  (error? ; not a string
1983    (#%$fasl-file-equal? 'testfile-fatfib1.so "testfile-fatfib2.so"))
1984  (error? ; not a string
1985    (#%$fasl-file-equal? 'testfile-fatfib1.so "testfile-fatfib2.so" #t))
1986  (error? ; not a string
1987    (#%$fasl-file-equal? "testfile-fatfib1.so" 13.4))
1988  (error? ; not a string
1989    (#%$fasl-file-equal? "testfile-fatfib1.so" 13.4 #f))
1990  (error? ; file doesn't exist
1991    (#%$fasl-file-equal? "testfile-fatfib1.so" "probably-does-not-exist"))
1992  (error? ; file doesn't exist
1993    (#%$fasl-file-equal? "testfile-fatfib1.so" "probably-does-not-exist" #f))
1994  (error? ; file doesn't exist
1995    (#%$fasl-file-equal? "probably-does-not-exist" "testfile-fatfib2.so"))
1996  (error? ; file doesn't exist
1997    (#%$fasl-file-equal? "probably-does-not-exist" "testfile-fatfib2.so" #t))
1998  (#%$fasl-file-equal? "testfile-fatfib1.so" "testfile-fatfib2.so")
1999  (not (#%$fasl-file-equal? "testfile-fatfib1.so" "testfile-fatfib3.so"))
2000  (error? (#%$fasl-file-equal? "testfile-fatfib1.so" "testfile-fatfib3.so" #t))
2001)
2002
2003(mat vfasl
2004  (begin
2005    (define-record-type vfasl-demo
2006      (fields x y)
2007      (nongenerative #{vfasl-demo pfwhk286n2j894o33awcq9er4-0}))
2008    (define vfasl-content (list 1 1/2 3.0 4+5i 6.0+7.0i
2009                                "apple" 'banana
2010                                (make-vfasl-demo 10 "11")
2011                                (vector 1 'two "three")
2012                                (stencil-vector 30 'one 2.0 0+3i "four")
2013                                (box 88)
2014                                "" '#() '#vu8() (make-fxvector 0) (make-flvector 0)
2015                                (string->immutable-string "") (vector->immutable-vector '#())
2016                                (bytevector->immutable-bytevector '#vu8())))
2017    (define (same-vfasl-content? v)
2018      (andmap (lambda (a b)
2019                (or (eqv? a b)
2020                    (and (or (and (string? a)
2021                                  (positive? (string-length a)))
2022                             (and (vector? a)
2023                                  (positive? (vector-length a)))
2024                             (box? a)
2025                             (stencil-vector? a))
2026                         (equal? a b))
2027                    (and (vfasl-demo? a)
2028                         (vfasl-demo? b)
2029                         (equal? (vfasl-demo-x a)
2030                                 (vfasl-demo-x b))
2031                         (equal? (vfasl-demo-y a)
2032                                 (vfasl-demo-y b)))
2033                    (begin
2034                      (printf "~s ~s\n" a b)
2035                      #f)))
2036              vfasl-content
2037              v))
2038    (compile-to-file (list `(define (vfasled) ',vfasl-content)
2039                           `(define (get-vfasled) vfasled)
2040                           `(define (call-vfasled) (vfasled)))
2041                     "testfile-fasl.so")
2042    (vfasl-convert-file "testfile-fasl.so" "testfile-vfasl.so" #f)
2043    (load "testfile-vfasl.so")
2044    #t)
2045
2046  (same-vfasl-content? (vfasled))
2047  (eq? vfasled (get-vfasled))
2048  (eq? (vfasled) (call-vfasled)))
2049
2050(mat cost-center
2051  (error? ; wrong number of arguments
2052    (make-cost-center 'foo))
2053
2054  (error? ; foo is not a cost center
2055    (with-cost-center 'foo (lambda () 5)))
2056
2057  (error? ; bar is not a procedure
2058    (with-cost-center (make-cost-center) 'bar))
2059
2060  (error? ; 5 is not a cost center
2061    (cost-center-instruction-count 5))
2062
2063  (error? ; "test" is not a cost center
2064    (cost-center-allocation-count "test"))
2065
2066  (error? ; 4.7 is not a cost center
2067    (cost-center-time 4.7))
2068
2069  (error? ; #\c is not a cost center
2070    (reset-cost-center! #\c))
2071
2072  (let ([cc (make-cost-center)])
2073    (cost-center? cc))
2074
2075  ;;; instruction cost center tests
2076  ((lambda (x)
2077     (<= 5 x 50))
2078   (let ([cc (make-cost-center)])
2079     (with-cost-center cc
2080       (lambda ()
2081         (parameterize ([generate-instruction-counts #t]
2082                        [compile-interpret-simple #f]
2083                        [enable-cp0 #f])
2084           (compile '(let ([p (cons 'a 'b)]) (car p))))))
2085     (cost-center-instruction-count cc)))
2086
2087  (begin
2088    (define $cc-sum-1
2089      (parameterize ([generate-instruction-counts #t])
2090        (compile
2091          '(lambda (ls)
2092             (let f ([ls ls])
2093               (if (null? ls)
2094                   0
2095                   (+ (car ls) (f (cdr ls)))))))))
2096    #t)
2097
2098  ((lambda (x)
2099     (<= 100 x 1000))
2100   (let ([cc (make-cost-center)])
2101     (with-cost-center cc (lambda () ($cc-sum-1 (iota 10))))
2102     (cost-center-instruction-count cc)))
2103
2104  ((lambda (x)
2105     (<= 1000 x 10000))
2106   (let ([cc (make-cost-center)])
2107     (with-cost-center cc (lambda () ($cc-sum-1 (iota 100))))
2108     (cost-center-instruction-count cc)))
2109
2110  (begin
2111    (define $cc-1 (make-cost-center))
2112    (define $cc-sum-2
2113      (parameterize ([generate-instruction-counts #t])
2114        (compile
2115          '(lambda (ls)
2116             (let f ([ls ls])
2117               (with-cost-center $cc-1
2118                 (lambda ()
2119                   (if (null? ls)
2120                       0
2121                       (+ (car ls) (f (cdr ls)))))))))))
2122    #t)
2123
2124  ((lambda (x)
2125     (<= 100 x 1500))
2126   (begin
2127     ($cc-sum-2 (iota 10))
2128     (cost-center-instruction-count $cc-1)))
2129
2130  (begin
2131    (reset-cost-center! $cc-1)
2132    #t)
2133
2134  ((lambda (x)
2135     (<= 1000 x 15000))
2136   (begin
2137     ($cc-sum-2 (iota 100))
2138     (cost-center-instruction-count $cc-1)))
2139
2140  (begin
2141    (reset-cost-center! $cc-1)
2142    #t)
2143
2144  (let ([cc (make-cost-center)])
2145    (with-cost-center cc (lambda () ($cc-sum-2 (iota 10))))
2146    (<= (cost-center-instruction-count $cc-1) (cost-center-instruction-count cc)))
2147
2148  (begin
2149    (define-syntax when-threaded
2150      (lambda (x)
2151        (syntax-case x ()
2152          [(_ e0 e1 ...)
2153           (if (threaded?)
2154               #'(begin e0 e1 ...)
2155               #'(begin #t))])))
2156    #t)
2157
2158  (when-threaded
2159    ; copied from thread.ms
2160    (begin
2161      (define $threads (foreign-procedure "(cs)threads" () scheme-object))
2162      (define $nthreads 1)
2163      (define $yield
2164        (let ([t (make-time 'time-duration 1000 0)])
2165          (lambda () (sleep t))))
2166      (define $thread-check
2167        (lambda ()
2168          (let loop ([n 10] [nt (length ($threads))])
2169            (cond
2170              [(<= nt $nthreads)
2171               (set! $nthreads nt)
2172               (collect)]
2173              [else
2174                ($yield)
2175                (let* ([ls ($threads)] [nnt (length ls)])
2176                  (cond
2177                    [(< nnt nt) (loop n nnt)]
2178                    [(= n 0)
2179                     (set! $nthreads nnt)
2180                     (errorf #f "extra threads running ~s" ls)]
2181                    [else (loop (- n 1) nnt)]))]))
2182          #t))
2183      ($thread-check)))
2184
2185  (when-threaded
2186    ((lambda (x)
2187       (<= 200 x 2000))
2188     (let ([cc (make-cost-center)]
2189           [finished #f]
2190           [finished-mutex (make-mutex)]
2191           [finished-condition (make-condition)])
2192       (define sum-th
2193         (lambda ()
2194           (with-cost-center cc (lambda () ($cc-sum-1 (iota 10))))
2195           (with-mutex finished-mutex
2196             (if finished
2197                 (condition-signal finished-condition)
2198                 (set! finished #t)))))
2199       (with-mutex finished-mutex
2200         (fork-thread sum-th)
2201         (fork-thread sum-th)
2202         (condition-wait finished-condition finished-mutex))
2203       (cost-center-instruction-count cc))))
2204
2205  (when-threaded ($thread-check))
2206
2207  (when-threaded
2208    (reset-cost-center! $cc-1)
2209    ((lambda (x)
2210       (<= 200 x 3000))
2211     (let ([finished #f]
2212           [finished-mutex (make-mutex)]
2213           [finished-condition (make-condition)])
2214       (define sum-th
2215         (lambda ()
2216           ($cc-sum-2 (iota 10))
2217           (with-mutex finished-mutex
2218             (if finished
2219                 (condition-signal finished-condition)
2220                 (set! finished #t)))))
2221       (with-mutex finished-mutex
2222         (fork-thread sum-th)
2223         (fork-thread sum-th)
2224         (condition-wait finished-condition finished-mutex))
2225       (cost-center-instruction-count $cc-1))))
2226
2227  (when-threaded ($thread-check))
2228
2229  (when-threaded
2230    (reset-cost-center! $cc-1)
2231    (let ([cc (make-cost-center)]
2232          [finished #f]
2233          [finished-mutex (make-mutex)]
2234          [finished-condition (make-condition)])
2235      (define sum-th
2236        (lambda ()
2237          (with-cost-center cc (lambda () ($cc-sum-2 (iota 10))))
2238          (with-mutex finished-mutex
2239            (if finished
2240                (condition-signal finished-condition)
2241                (set! finished #t)))))
2242       (with-mutex finished-mutex
2243         (fork-thread sum-th)
2244         (fork-thread sum-th)
2245         (condition-wait finished-condition finished-mutex))
2246       (<= (cost-center-instruction-count $cc-1)
2247           (cost-center-instruction-count cc))))
2248
2249  (when-threaded ($thread-check))
2250
2251  (begin
2252    (define $cc-fibonacci
2253      (let ([fib
2254              (parameterize ([generate-instruction-counts #t])
2255                (compile
2256                  '(rec fib
2257                     (lambda (i)
2258                       (cond
2259                         [(= i 0) 0]
2260                         [(= i 1) 1]
2261                         [else (+ (fib (- i 1))
2262                                  (fib (- i 2)))])))))])
2263        (lambda (n) (with-cost-center $cc-1 (lambda () (fib n))))))
2264    #t)
2265
2266  (let ([normal-count (begin
2267                        (reset-cost-center! $cc-1)
2268                        ($cc-fibonacci 10)
2269                        (cost-center-instruction-count $cc-1))]
2270        [eng-count (begin
2271                     (reset-cost-center! $cc-1)
2272                     (let f ([eng (make-engine (lambda () ($cc-fibonacci 10)))])
2273                       (eng 50 (lambda args (cost-center-instruction-count $cc-1)) f)))])
2274    ; range because when running in an engine the trap check might
2275    ; be taken, and it will slightly increase the instruction count
2276    (<= normal-count eng-count (+ normal-count 100)))
2277
2278  ;;; allocation cost center tests
2279  (eqv?
2280    (case (fixnum-width)
2281      [(30) 24]
2282      [(61) 48])
2283    (let ([cc (make-cost-center)])
2284      (with-cost-center cc
2285        (lambda ()
2286          (parameterize ([generate-allocation-counts #t]
2287                         [compile-interpret-simple #f])
2288            (compile '(#%list 'a 'b 'c)))))
2289      (cost-center-allocation-count cc)))
2290
2291  ((lambda (count) ; range for rand call done to test variable alloc case and 64-bit words
2292     (<= 16 count 120))
2293   (let ([cc (make-cost-center)])
2294     (with-cost-center cc
2295       (lambda ()
2296         (parameterize ([generate-allocation-counts #t] [compile-interpret-simple #f])
2297           (compile `(let ([x (fx+ 3 (random 10))])
2298                       (#3%make-vector x))))))
2299     (cost-center-allocation-count cc)))
2300
2301  (begin
2302    (define $cc-reverse-1
2303      (parameterize ([generate-allocation-counts #t])
2304        (compile
2305          '(lambda (ls)
2306             (let f ([ls ls] [rls '()])
2307               (if (null? ls)
2308                   rls
2309                   (f (cdr ls) (#%cons (car ls) rls))))))))
2310    #t)
2311
2312  (eqv?
2313    (case (fixnum-width)
2314      [(30) 80]
2315      [(61) 160])
2316    (let ([cc (make-cost-center)])
2317      (with-cost-center cc (lambda () ($cc-reverse-1 (make-list 10))))
2318      (cost-center-allocation-count cc)))
2319
2320  (eqv?
2321    (case (fixnum-width)
2322      [(30) 800]
2323      [(61) 1600])
2324    (let ([cc (make-cost-center)])
2325      (with-cost-center cc (lambda () ($cc-reverse-1 (make-list 100))))
2326      (cost-center-allocation-count cc)))
2327
2328  (begin
2329    (define $cc-2 (make-cost-center))
2330    (define $cc-reverse-2
2331      (parameterize ([generate-allocation-counts #t])
2332        (compile
2333          '(lambda (ls)
2334             (let f ([ls ls] [rls '()])
2335               (with-cost-center $cc-2
2336                 (lambda ()
2337                   (if (null? ls)
2338                       rls
2339                       (f (cdr ls) (#%cons (car ls) rls))))))))))
2340    #t)
2341
2342  ((lambda (x) ; wide range to accommodate both 4-byte and 8-byte words
2343     (<= 80 x 480))
2344   (begin
2345     ($cc-reverse-2 (make-list 10))
2346     (cost-center-allocation-count $cc-2)))
2347
2348  (begin
2349    (reset-cost-center! $cc-2)
2350    #t)
2351
2352  ((lambda (x) ; wide range to accommodate both 4-byte and 8-byte words
2353     (<= 800 x 4800))
2354   (begin
2355     ($cc-reverse-2 (make-list 100))
2356     (cost-center-allocation-count $cc-2)))
2357
2358  (begin
2359    (reset-cost-center! $cc-2)
2360    #t)
2361
2362  (let ([cc (make-cost-center)])
2363    (with-cost-center cc (lambda () ($cc-reverse-2 (make-list 10))))
2364    (<= (cost-center-allocation-count $cc-2) (cost-center-allocation-count cc)))
2365
2366  (begin
2367    (define $cc-reverse-3
2368      (let ([rev (parameterize ([generate-allocation-counts #t])
2369                   (compile
2370                     '(rec rev
2371                        (lambda (ls rls)
2372                          (if (null? ls)
2373                              rls
2374                              (rev (cdr ls) (#%cons (car ls) rls)))))))])
2375        (lambda (ls)
2376          (with-cost-center $cc-2 (lambda () (rev ls '()))))))
2377    #t)
2378
2379  (eqv?
2380    (begin
2381      (reset-cost-center! $cc-2)
2382      ($cc-reverse-3 (iota 10))
2383      (cost-center-allocation-count $cc-2))
2384    (begin
2385      (reset-cost-center! $cc-2)
2386      (let f ([eng (make-engine (lambda () ($cc-reverse-3 (iota 10))))])
2387        (eng 10 (lambda args (cost-center-allocation-count $cc-2)) f))))
2388
2389  (when-threaded
2390    (eqv?
2391      (case (fixnum-width)
2392        [(30) 160]
2393        [(61) 320])
2394      (let ([cc (make-cost-center)]
2395            [finished #f]
2396            [finished-mutex (make-mutex)]
2397            [finished-condition (make-condition)])
2398        (define reverse-th
2399          (lambda ()
2400            (with-cost-center cc (lambda () ($cc-reverse-1 (iota 10))))
2401            (with-mutex finished-mutex
2402              (if finished
2403                  (condition-signal finished-condition)
2404                  (set! finished #t)))))
2405        (with-mutex finished-mutex
2406          (fork-thread reverse-th)
2407          (fork-thread reverse-th)
2408          (condition-wait finished-condition finished-mutex))
2409        (cost-center-allocation-count cc))))
2410
2411  (when-threaded ($thread-check))
2412
2413  (when-threaded
2414    (reset-cost-center! $cc-2)
2415    ((lambda (x) ; wide range to accommodate both 4-byte and 8-byte words
2416       (<= 160 x 960))
2417     (let ([finished #f]
2418           [finished-mutex (make-mutex)]
2419           [finished-condition (make-condition)])
2420       (define reverse-th
2421         (lambda ()
2422           ($cc-reverse-2 (iota 10))
2423           (with-mutex finished-mutex
2424             (if finished
2425                 (condition-signal finished-condition)
2426                 (set! finished #t)))))
2427       (with-mutex finished-mutex
2428         (fork-thread reverse-th)
2429         (fork-thread reverse-th)
2430         (condition-wait finished-condition finished-mutex))
2431       (cost-center-allocation-count $cc-2))))
2432
2433  (when-threaded ($thread-check))
2434
2435  (when-threaded
2436    (reset-cost-center! $cc-2)
2437    (let ([cc (make-cost-center)]
2438          [finished #f]
2439          [finished-mutex (make-mutex)]
2440          [finished-condition (make-condition)])
2441      (define reverse-th
2442        (lambda ()
2443          (with-cost-center cc (lambda () ($cc-reverse-2 (iota 10))))
2444          (with-mutex finished-mutex
2445            (if finished
2446                (condition-signal finished-condition)
2447                (set! finished #t)))))
2448       (with-mutex finished-mutex
2449         (fork-thread reverse-th)
2450         (fork-thread reverse-th)
2451         (condition-wait finished-condition finished-mutex))
2452       (<= (cost-center-instruction-count $cc-2)
2453           (cost-center-instruction-count cc))))
2454
2455  (when-threaded ($thread-check))
2456
2457  ;;; instruction with allocation cost center tests
2458  ((lambda (x)
2459     (<= 10 x 50))
2460   (let ([cc (make-cost-center)])
2461     (with-cost-center cc
2462       (lambda ()
2463         (parameterize ([generate-allocation-counts #t]
2464                        [generate-instruction-counts #t]
2465                        [compile-interpret-simple #f]
2466                        [enable-cp0 #f])
2467           (compile '(let ([p (cons 'a 'b)]) (car p))))))
2468     (cost-center-instruction-count cc)))
2469
2470  (begin
2471    (define $cc-sum-1
2472      (parameterize ([generate-allocation-counts #t]
2473                     [generate-instruction-counts #t])
2474        (compile
2475          '(lambda (ls)
2476             (let f ([ls ls])
2477               (if (null? ls)
2478                   0
2479                   (+ (car ls) (f (cdr ls)))))))))
2480    #t)
2481
2482  ((lambda (x)
2483     (<= 100 x 1000))
2484   (let ([cc (make-cost-center)])
2485     (with-cost-center cc (lambda () ($cc-sum-1 (iota 10))))
2486     (cost-center-instruction-count cc)))
2487
2488  ((lambda (x)
2489     (<= 1000 x 10000))
2490   (let ([cc (make-cost-center)])
2491     (with-cost-center cc (lambda () ($cc-sum-1 (iota 100))))
2492     (cost-center-instruction-count cc)))
2493
2494  (begin
2495    (define $cc-1 (make-cost-center))
2496    (define $cc-sum-2
2497      (parameterize ([generate-allocation-counts #t]
2498                     [generate-instruction-counts #t])
2499        (compile
2500          '(lambda (ls)
2501             (let f ([ls ls])
2502               (with-cost-center $cc-1
2503                 (lambda ()
2504                   (if (null? ls)
2505                       0
2506                       (+ (car ls) (f (cdr ls)))))))))))
2507    #t)
2508
2509  ((lambda (x)
2510     (<= 100 x 1500))
2511   (begin
2512     ($cc-sum-2 (iota 10))
2513     (cost-center-instruction-count $cc-1)))
2514
2515  (begin
2516    (reset-cost-center! $cc-1)
2517    #t)
2518
2519  ((lambda (x)
2520     (<= 1000 x 15000))
2521   (begin
2522     ($cc-sum-2 (iota 100))
2523     (cost-center-instruction-count $cc-1)))
2524
2525  (begin
2526    (reset-cost-center! $cc-1)
2527    #t)
2528
2529  (let ([cc (make-cost-center)])
2530    (with-cost-center cc (lambda () ($cc-sum-2 (iota 10))))
2531    (<= (cost-center-instruction-count $cc-1) (cost-center-instruction-count cc)))
2532
2533  ;; allocation with instruction counts
2534  (eqv?
2535    (case (fixnum-width)
2536      [(30) 24]
2537      [(61) 48])
2538    (let ([cc (make-cost-center)])
2539      (with-cost-center cc
2540        (lambda ()
2541          (parameterize ([generate-allocation-counts #t]
2542                         [generate-instruction-counts #t]
2543                         [compile-interpret-simple #f])
2544            (compile '(#%list 'a 'b 'c)))))
2545      (cost-center-allocation-count cc)))
2546
2547  (let ([x (fx+ 3 (random 10))])
2548    ((lambda (count) ; range for padding on 32-bit and to accomadate 64-bit words
2549       (<= (fxsll (fx+ x 1) 2) count (fxsll (fx+ x 2) 3)))
2550     (let ([cc (make-cost-center)])
2551       (with-cost-center cc
2552         (lambda ()
2553           (parameterize ([generate-allocation-counts #t]
2554                          [generate-instruction-counts #t]
2555                          [compile-interpret-simple #f])
2556             (compile `(#%make-vector ,x)))))
2557       (cost-center-allocation-count cc))))
2558
2559  (begin
2560    (define $cc-reverse-1
2561      (parameterize ([generate-allocation-counts #t]
2562                     [generate-instruction-counts #t])
2563        (compile
2564          '(lambda (ls)
2565             (let f ([ls ls] [rls '()])
2566               (if (null? ls)
2567                   rls
2568                   (f (cdr ls) (#%cons (car ls) rls))))))))
2569    #t)
2570
2571  (eqv?
2572    (case (fixnum-width)
2573      [(30) 80]
2574      [(61) 160])
2575    (let ([cc (make-cost-center)])
2576      (with-cost-center cc (lambda () ($cc-reverse-1 (make-list 10))))
2577      (cost-center-allocation-count cc)))
2578
2579  (eqv?
2580    (case (fixnum-width)
2581      [(30) 800]
2582      [(61) 1600])
2583    (let ([cc (make-cost-center)])
2584      (with-cost-center cc (lambda () ($cc-reverse-1 (make-list 100))))
2585      (cost-center-allocation-count cc)))
2586
2587  (begin
2588    (define $cc-2 (make-cost-center))
2589    (define $cc-reverse-2
2590      (parameterize ([generate-allocation-counts #t]
2591                     [generate-instruction-counts #t])
2592        (compile
2593          '(lambda (ls)
2594             (let f ([ls ls] [rls '()])
2595               (with-cost-center $cc-2
2596                 (lambda ()
2597                   (if (null? ls)
2598                       rls
2599                       (f (cdr ls) (#%cons (car ls) rls))))))))))
2600    #t)
2601
2602  ((lambda (x) ; wide range to accommodate both 4-byte and 8-byte words
2603     (<= 80 x 480))
2604   (begin
2605     ($cc-reverse-2 (make-list 10))
2606     (cost-center-allocation-count $cc-2)))
2607
2608  (begin
2609    (reset-cost-center! $cc-2)
2610    #t)
2611
2612  ((lambda (x) ; wide range to accommodate both 4-byte and 8-byte words
2613     (<= 800 x 4800))
2614   (begin
2615     ($cc-reverse-2 (make-list 100))
2616     (cost-center-allocation-count $cc-2)))
2617
2618  (> (cost-center-allocation-count $cc-2) 0)
2619  (> (cost-center-instruction-count $cc-2) 0)
2620
2621  (begin
2622    (reset-cost-center! $cc-2)
2623    #t)
2624
2625  (fx= (cost-center-allocation-count $cc-2) 0)
2626  (fx= (cost-center-instruction-count $cc-2) 0)
2627
2628  (let ([cc (make-cost-center)])
2629    (with-cost-center cc (lambda () ($cc-reverse-2 (make-list 10))))
2630    (<= (cost-center-allocation-count $cc-2) (cost-center-allocation-count cc)))
2631
2632  (begin
2633    (define $fib (lambda (x) (if (< x 2) 1 (+ ($fib (- x 1)) ($fib (- x 2))))))
2634    #t)
2635
2636  ;; timing information (no instrumentation needed)
2637  ((lambda (x)
2638     (and (time<? (make-time 'time-duration 0 0) x)
2639          (time<? x (make-time 'time-duration 0 10))))
2640   (let ([cc (make-cost-center)])
2641     (with-cost-center #t cc
2642       (lambda ()
2643         (let ([t0 (current-time 'time-thread)])
2644           (let f ()
2645             (when (time=? (current-time 'time-thread) t0)
2646               ($fib 10)
2647               (f))))))
2648     (cost-center-time cc)))
2649
2650  (let ([cc1 (make-cost-center)] [cc2 (make-cost-center)])
2651    (with-cost-center #t cc1
2652      (lambda ()
2653        (let f ([n 10])
2654          (with-cost-center #t cc2
2655            (lambda ()
2656              (cond
2657                [(= n 0) 1]
2658                [(= n 1) 1]
2659                [else (+ (f (- n 1)) (f (- n 2)))]))))))
2660    (time<=? (cost-center-time cc2) (cost-center-time cc1)))
2661
2662  (begin
2663    (define $cc-3 (make-cost-center))
2664    (define $cc-fib
2665      (parameterize ([generate-allocation-counts #t]
2666                     [generate-instruction-counts #t])
2667        (compile
2668          '(let ()
2669             (define (n->peano n)
2670               (if (zero? n)
2671                   '()
2672                   (cons 'succ (n->peano (- n 1)))))
2673             (define peano->n length)
2674             (define (peano-sub1 n)
2675               (if (null? n)
2676                   (error 'peano-sub "cannot subtract 1 from 0")
2677                   (cdr n)))
2678             (define peano-zero '())
2679             (define (peano-add1 n) (#%cons 'succ n))
2680             (define (peano+ n1 n2)
2681               (if (eq? n1 peano-zero)
2682                   n2
2683                   (peano-add1 (peano+ (peano-sub1 n1) n2))))
2684             (lambda (n)
2685               (with-cost-center #t $cc-3
2686                 (lambda ()
2687                   (peano->n
2688                     (let f ([n (n->peano n)])
2689                       (cond
2690                         [(equal? n peano-zero) (peano-add1 peano-zero)]
2691                         [(equal? n (peano-add1 peano-zero)) (peano-add1 peano-zero)]
2692                         [else
2693                           (let ([n (peano-sub1 n)])
2694                             (peano+ (f n) (f (peano-sub1 n))))]))))))))))
2695    #t)
2696
2697  (fx= (cost-center-instruction-count $cc-3) 0)
2698  (fx= (cost-center-allocation-count $cc-3) 0)
2699  (time=? (cost-center-time $cc-3) (make-time 'time-duration 0 0))
2700
2701  ((lambda (x)
2702     (and (time<? (make-time 'time-duration 0 0) x)
2703          (or (time<? x (make-time 'time-duration 0 20))
2704              (#%$enable-check-heap))))
2705   (begin
2706     ($cc-fib 30)
2707     (cost-center-time $cc-3)))
2708
2709  (> (cost-center-instruction-count $cc-3) 0)
2710  (> (cost-center-allocation-count $cc-3) 0)
2711  (time>? (cost-center-time $cc-3) (make-time 'time-duration 0 0))
2712
2713  (begin
2714    (reset-cost-center! $cc-3)
2715    #t)
2716
2717  (fx= (cost-center-instruction-count $cc-3) 0)
2718  (fx= (cost-center-allocation-count $cc-3) 0)
2719  (time=? (cost-center-time $cc-3) (make-time 'time-duration 0 0))
2720)
2721
2722
2723
2724(mat lock-object
2725  (begin
2726    (define $locked-objects (foreign-procedure "(cs)locked_objects" () ptr))
2727    #t)
2728  (let ([ls ($locked-objects)])
2729    (unless (null? ls) (errorf #f "found locked objects ~s" ls))
2730    #t)
2731  (let ()
2732    (define-record user-event (x))
2733    (do ([n 20 (- n 1)])
2734        ((= n 0))
2735      (for-each unlock-object
2736        (map (lambda (x) (lock-object x) x)
2737          (map make-user-event
2738            (make-list 10000)))))
2739    #t)
2740  (let ([ls ($locked-objects)])
2741    (unless (null? ls) (errorf #f "found locked objects ~s" ls))
2742    #t)
2743  (let ()
2744    (define-record user-event (x))
2745    (do ([n 20 (- n 1)])
2746        ((= n 0))
2747      (for-each unlock-object
2748        (map (lambda (x)
2749               (let ([x (case x
2750                          [(0) (lambda () x)]
2751                          [(1) (cons x x)]
2752                          [(2) (vector x)]
2753                          [(3) (vector x x)]
2754                          [(4) (string #\a #\b)]
2755                          [(5) (box (cons 3 4))]
2756                          [(6) (/ 8 17)]
2757                          [(7) (exact (sin 3.0))]
2758                          [(8) (exact (sqrt -73.0))]
2759                          [(9) (call/cc values)]
2760                          [(10) (make-user-event x)])])
2761                 (lock-object x)
2762                 x))
2763             (map random (make-list 2000 11)))))
2764    #t)
2765  (let ([ls ($locked-objects)])
2766    (unless (null? ls) (errorf #f "found locked objects ~s" ls))
2767    #t)
2768  (eqv?
2769    (let ()
2770      (define (pick ls) (list-ref ls (random (length ls))))
2771     ; we don't pick then remq-first because the picked element may be
2772     ; an unlocked flonum and may be cloned into two copies by the
2773     ; collector between the pick and the remq-first
2774      (define (pick-rem ls)
2775        (let f ([ls ls] [i (random (length ls))])
2776          (if (fx= i 0)
2777              (values (car ls) (cdr ls))
2778              (let-values ([(x d) (f (cdr ls) (fx- i 1))])
2779                (values x (cons (car ls) d))))))
2780      (module (random-tree)
2781        (define leaves
2782          `(,(lambda () '())
2783            ,(lambda () 0)
2784            ,(lambda () #f)
2785            ,(lambda () #t)
2786            ,(lambda () #\q)
2787            ,(lambda () (* 3.4 5))
2788            ,(lambda () (* 15/16 5))
2789            ,(lambda () (* 1+2i 5))
2790            ,(lambda () (* 3.0-2.5i 5))
2791            ,(lambda () (pick (oblist)))
2792            ,gensym
2793            ,(lambda () (make-string (random 10) (pick '(#\$ #\! #\*))))
2794            ))
2795        (define nodes
2796          `(,(lambda (th) (cons (th) (th)))
2797            ,(lambda (th) (weak-cons (th) (th)))
2798            ,(lambda (th) (list->vector (map (lambda (x) (th)) (make-list (+ 1 (random 4))))))
2799            ,(lambda (th)
2800               (define-record frob ((immutable x) (immutable y)))
2801               (record-reader 'frob1 (type-descriptor frob))
2802               (make-frob (th) (th)))
2803            ,(lambda (th)
2804               (define-record frob ((immutable x) (mutable y)))
2805               (record-reader 'frob2 (type-descriptor frob))
2806               (make-frob (th) (th)))
2807            ,(lambda (th)
2808               (define-record frob ((immutable x) (immutable integer-32 y)))
2809               (record-reader 'frob3 (type-descriptor frob))
2810               (make-frob (th) (random 200000)))
2811            ,(lambda (th)
2812               (define-record frob ((immutable x) (mutable integer-32 y)))
2813               (record-reader 'frob4 (type-descriptor frob))
2814               (make-frob (th) (random 200000)))
2815            ,(lambda (th)
2816               (let ([x (th)] [y (th)])
2817                 (let ([f (lambda () (cons x y))])
2818                   (values f (#%$closure-code f)))))
2819            ,(lambda (th)
2820               (let ([x (th)] [y (th)])
2821                 (call/cc
2822                   (lambda (k)
2823                     (call/cc (lambda (k1) (k k1)))
2824                     (cons x y)))))
2825            ))
2826        (define random-tree
2827          (lambda (n)
2828            (let ([objects '()])
2829              (let ([t (let f ([n n])
2830                         (let-values ([t* (if (= n 0)
2831                                              ((pick leaves))
2832                                              ((pick nodes) (lambda () (f (- n 1)))))])
2833                           (set! objects (append t* objects))
2834                           (car t*)))])
2835                objects)))))
2836      (define (chew n)
2837        (let f ([ls (make-list n)])
2838          (if (< (length ls) 2)
2839              (random-tree 2)
2840              (append (f (cddr ls)) (f (cdr ls))))))
2841      (define (randomize ls)
2842        (if (null? ls)
2843            '()
2844            (let-values ([(a d) (pick-rem ls)])
2845              (cons a (randomize d)))))
2846      (define (split ls)
2847        (if (null? ls)
2848            (values '() '())
2849            (let-values ([(a ls) (pick-rem ls)])
2850              (let-values ([(ls1 ls2) (split ls)])
2851                (if (= (random 2) 0)
2852                    (values (cons a ls1) ls2)
2853                    (values ls1 (cons a ls2)))))))
2854      (define (locktest)
2855        (define m 5)
2856        (let f ([n 100] [l0 '()] [l1 '()] [l2 '()])
2857          (let ([l1addr (map #%$fxaddress l1)] [l2addr (map #%$fxaddress l2)])
2858            (chew 15)
2859            (let ([bad (remq f
2860                         (map (lambda (x a) (if (fx= (#%$fxaddress x) a) f x))
2861                              (append l1 l2)
2862                              (append l1addr l2addr)))])
2863              (unless (andmap flonum? bad)
2864                (errorf 'locktest "locked object address(es) changed for ~s" bad))))
2865          (if (= n 0)
2866              (begin
2867                (for-each unlock-object l1)
2868                (for-each unlock-object l2)
2869                (for-each unlock-object l2)
2870                'yippee!)
2871              (let-values ([(l0drop l0keep) (split l0)]
2872                           [(l1drop l1keep) (split l1)]
2873                           [(l2drop l2keep) (split l2)])
2874                (for-each unlock-object l1drop)
2875                (for-each unlock-object l2drop)
2876                (for-each unlock-object l2drop)
2877                (let-values ([(l0stay l0up) (split l0keep)]
2878                             [(l1down l1up) (split l1keep)]
2879                             [(l2down l2stay) (split l2keep)])
2880                  (for-each lock-object l0up)
2881                  (for-each lock-object l1up)
2882                  (for-each unlock-object l1down)
2883                  (for-each unlock-object l2down)
2884                  (f (- n 1)
2885                     (randomize (append l0stay l1down))
2886                     (let ([l1new (random-tree m)])
2887                       (for-each lock-object l1new)
2888                       (randomize (append l0up l2down l1new)))
2889                     (randomize (append l1up l2stay))))))))
2890      (locktest))
2891    'yippee!)
2892  (let ([ls ($locked-objects)])
2893    (unless (null? ls) (errorf #f "found locked objects ~s" ls))
2894    #t)
2895  (eqv?
2896    (let ()
2897      (define-record frob ((immutable x) (immutable y))
2898        ([(immutable hash) (hash-frob x y)]))
2899      (define leaves
2900        `(,(lambda () '())
2901          ,(lambda () 0)
2902          ,(lambda () #f)
2903          ,(lambda () #t)
2904          ,(lambda () #\q)
2905          ,(lambda () (* 3.4 5))
2906          ,(lambda () (* 15/16 5))
2907          ,(lambda () (* 1+2i 5))
2908          ,(lambda () (* 3.0-2.5i 5))
2909          ,(lambda () (pick (oblist)))
2910          ,gensym
2911          ,(lambda () (make-string (random 10) (pick '(#\$ #\! #\*))))
2912          ))
2913      (define (hash-frob x y) (+ 13 (ash (hash x) 4) (* (hash y) 7)))
2914      (define (hash x)
2915        (case x
2916          [(()) 1]
2917          [(0) 2]
2918          [(#f) 3]
2919          [(#t) 4]
2920          [(#\q) 5]
2921          [(17.0) 6]
2922          [(75/16) 7]
2923          [(5+10i) 8]
2924          [(15.0-12.5i) 9]
2925          [else
2926           (cond
2927             [(gensym? x) (+ 10 (ash (hash-string (symbol->string x)) 4))]
2928             [(symbol? x) (+ 11 (ash (hash-string (symbol->string x)) 4))]
2929             [(string? x) (+ 12 (ash (hash-string x) 4))]
2930             [(frob? x) (hash-frob (frob-x x) (frob-y x))]
2931             [else (errorf 'hash "unexpected object ~s" x)])]))
2932      (define (hash-string s)
2933        (apply logxor (map char->integer (string->list s))))
2934      (define (check-hash x)
2935        (let ([h (hash x)]) ; run regardless for error check
2936          (when (frob? x)
2937            (unless (= (hash x) (frob-hash x))
2938              (errorf 'check-hash "hash mismatch for ~s" x)))))
2939      (define (pick ls) (list-ref ls (random (length ls))))
2940     ; we don't pick then remq-first because the picked element may be
2941     ; an unlocked flonum and may be cloned into two copies by the
2942     ; collector between the pick and the remq-first
2943      (define (pick-rem ls)
2944        (let f ([ls ls] [i (random (length ls))])
2945          (if (fx= i 0)
2946              (values (car ls) (cdr ls))
2947              (let-values ([(x d) (f (cdr ls) (fx- i 1))])
2948                (values x (cons (car ls) d))))))
2949      (define random-tree
2950        (lambda (n)
2951          (let ([objects '()])
2952            (let ([t (let f ([n n])
2953                       (let-values ([t* (if (= n 0)
2954                                            ((pick leaves))
2955                                            (make-frob (f (- n 1)) (f (- n 1))))])
2956                         (set! objects (append t* objects))
2957                         (car t*)))])
2958                objects))))
2959      (define (chew n)
2960        (let f ([ls (make-list n)])
2961          (if (< (length ls) 2)
2962              (random-tree 2)
2963              (append (f (cddr ls)) (f (cdr ls))))))
2964      (define (randomize ls)
2965        (if (null? ls)
2966            '()
2967            (let-values ([(a d) (pick-rem ls)])
2968              (cons a (randomize d)))))
2969      (define (split ls)
2970        (if (null? ls)
2971            (values '() '())
2972            (let-values ([(a ls) (pick-rem ls)])
2973              (let-values ([(ls1 ls2) (split ls)])
2974                (if (= (random 2) 0)
2975                    (values (cons a ls1) ls2)
2976                    (values ls1 (cons a ls2)))))))
2977      (define (locktest)
2978        (define m 5)
2979        (let f ([n 100] [l0 '()] [l1 '()] [l2 '()])
2980          (let ([l1addr (map #%$fxaddress l1)] [l2addr (map #%$fxaddress l2)])
2981            (chew 15)
2982            (let ([bad (remq f
2983                         (map (lambda (x a) (if (fx= (#%$fxaddress x) a) f x))
2984                              (append l1 l2)
2985                              (append l1addr l2addr)))])
2986              (unless (andmap flonum? bad)
2987                (errorf 'locktest "locked object address(es) changed for ~s" bad))))
2988          (for-each check-hash l0)
2989          (for-each check-hash l1)
2990          (for-each check-hash l2)
2991          (if (= n 0)
2992              (begin
2993                (for-each unlock-object l1)
2994                (for-each unlock-object l2)
2995                (for-each unlock-object l2)
2996                'yippee!)
2997              (let-values ([(l0drop l0keep) (split l0)]
2998                           [(l1drop l1keep) (split l1)]
2999                           [(l2drop l2keep) (split l2)])
3000                (for-each unlock-object l1drop)
3001                (for-each unlock-object l2drop)
3002                (for-each unlock-object l2drop)
3003                (let-values ([(l0stay l0up) (split l0keep)]
3004                             [(l1down l1up) (split l1keep)]
3005                             [(l2down l2stay) (split l2keep)])
3006                  (for-each lock-object l0up)
3007                  (for-each lock-object l1up)
3008                  (for-each unlock-object l1down)
3009                  (for-each unlock-object l2down)
3010                  (f (- n 1)
3011                     (randomize (append l0stay l1down))
3012                     (let ([l1new (random-tree m)])
3013                       (for-each lock-object l1new)
3014                       (randomize (append l0up l2down l1new)))
3015                     (randomize (append l1up l2stay))))))))
3016      (locktest))
3017    'yippee!)
3018  (let ([ls ($locked-objects)])
3019    (unless (null? ls) (errorf #f "found locked objects ~s" ls))
3020    #t)
3021  (parameterize ([collect-request-handler void])
3022    (define x (cons 3 4))
3023    (lock-object x)
3024    (collect 1 1) ; should leave segment containing x with locked bit
3025    (set-cdr! x (cons 0 0)) ; should mark the card containing x in the segment dirty
3026    (collect 0 0) ; should crash if sweep_dirty doesn't ignore locked objects
3027    (unlock-object x)
3028    #t)
3029  (let ([ls ($locked-objects)])
3030    (unless (null? ls) (errorf #f "found locked objects ~s" ls))
3031    #t)
3032  ; shouldn't include immediates in locked-object lists
3033  (begin
3034    (lock-object -17)
3035    (lock-object #f)
3036    (lock-object #!eof)
3037    (lock-object #\newline)
3038    (let ([ls ($locked-objects)])
3039      (unless (null? ls) (errorf #f "found locked objects ~s" ls))
3040      #t))
3041  ; cons should be static, and shouldn't include static objects in locked-object lists
3042  (begin
3043    (lock-object 'cons)
3044    (let ([ls ($locked-objects)])
3045      (unless (null? ls) (errorf #f "found locked objects ~s" ls))
3046      #t))
3047  ; locked objects promoted to static generation are listed in the static-generation locked list
3048  ; so mutated locked objects are properly swept (and the cards they're in, which might contain
3049  ; random stuff, aren't)
3050  #;(parameterize ([collect-request-handler void])
3051    (define x (cons 3 4))
3052    (lock-object x)
3053    (collect (collect-maximum-generation) 'static)
3054    (let ([ls ($locked-objects)])
3055      (unless (null? ls) (errorf #f "found locked objects ~s" ls))
3056      #t))
3057
3058  ;; Make sure a locked object that spans segments is appropriately
3059  ;; swept when it's modified to ceate a backpointer
3060  (let* ([N 100000]
3061         [v (make-vector N)])
3062    (lock-object v)
3063    (collect 0)
3064    (let ([p (cons 1 2)])
3065      (vector-set! v (sub1 N) p)
3066      (collect 0)
3067      (set-car! p 'yes)
3068      (unlock-object v)
3069      (equal? '(yes . 2) (vector-ref v (sub1 N)))))
3070  )
3071
3072(mat eval-order
3073  (eqv? (call/cc (lambda (k) (0 (k 1)))) 1)
3074  (eqv? (let ([zero 0]) (call/cc (lambda (k) (zero (k 1))))) 1)
3075  (begin
3076    (define $notproc (cons 'not 'proc))
3077    (not (procedure? $notproc)))
3078  (eqv? (call/cc (lambda (k) ($notproc (k 1)))) 1)
3079)
3080
3081
3082(define eval-test
3083  (lambda (s)
3084    (with-output-to-file "testfile.ss"
3085      (lambda () (display s))
3086      'replace)
3087    (parameterize ([#%$suppress-primitive-inlining #f])
3088      (load "testfile.ss" (lambda (x) (eval x))))
3089    #t))
3090(define load-test
3091  (lambda (s)
3092    (with-output-to-file "testfile.ss"
3093      (lambda () (display s))
3094      'replace)
3095    (parameterize ([#%$suppress-primitive-inlining #f])
3096      (load "testfile.ss"))
3097    #t))
3098(define compile-test
3099  (lambda (s)
3100    (with-output-to-file "testfile.ss"
3101      (lambda () (display s))
3102      'replace)
3103    (parameterize ([#%$suppress-primitive-inlining #f])
3104      (compile-file "testfile.ss"))
3105    (load "testfile.so")
3106    #t))
3107
3108(define-syntax error/warning-mat
3109  (syntax-rules ()
3110    [(_ what string ...)
3111     (begin
3112      ; removed primitive argcnt warnings when no source is available
3113      ; to avoid warnings followed immediately by errors in the repl
3114      ; and warnings in run-time calls to eval
3115       #;(mat (what eval-warning) (warning? (eval-test string)) ...)
3116       (mat (what eval-error) (error? (eval-test string)) ...)
3117       (mat (what load-warning) (warning? (load-test string)) ...)
3118       (mat (what load-error) (error? (load-test string)) ...)
3119       (mat (what compile-warning) (warning? (compile-test string)) ...)
3120       (mat (what compile-error) (error? (compile-test string)) ...))]))
3121
3122(define-syntax error-mat
3123  (syntax-rules ()
3124    [(_ what string ...)
3125     (begin
3126       (mat (what eval-error) (error? (eval-test string)) ...)
3127       (mat (what load-error) (error? (load-test string)) ...)
3128       (mat (what compile-error) (error? (compile-test string)) ...))]))
3129
3130(error/warning-mat argcnt
3131  "; cp1in argument-count error\n\n(define f (lambda () (import scheme) (car)))\n(f)\n"
3132  "; cp1in argument-count error\n\n(define f (lambda () (import scheme) (car '(a b) '(c d))))\n(f)\n"
3133  "; cp1in argument-count error\n\n(define f (lambda () (let ([g (lambda () 0)]) (g 7))))\n(f)\n"
3134  "; cp1in argument-count error\n\n(define f (lambda () (let ([g (lambda (x) 0)]) (g))))\n(f)\n"
3135)
3136
3137(error-mat syntax
3138  "; eval-when syntax error\n\n(eval-when (compile load eval))"
3139  "; eval-when syntax error\n\n(eval-when (never) 3)"
3140  "; begin syntax error\n\n(begin 3 . 4)"
3141  "; application syntax error\n\n(f 1 2 . 3)"
3142  "; define syntax error\n\n(define foo 3 4)"
3143  "; define-syntax syntax error\n\n(define-syntax (foo x y) z)"
3144  "; cond syntax error\n\n(cond . 17)"
3145  "; lambda syntax error\n\n(lambda (x 3 y) 3)"
3146)
3147
3148(mat sci-bug
3149  (fl~= (expt 10.0 (- 21)) 1e-21)
3150  (fl~= (flexpt 10.0 (- 21.0)) 1e-21)
3151)
3152
3153(mat apropos
3154  (error? (apropos 3))
3155  (error? (apropos '(hit me)))
3156  (error? (apropos 'a 'b))
3157  (error? (apropos 'a 'b 'c))
3158  (error? (apropos))
3159  (let ([ls (apropos-list 'str)])
3160    (and (memq 'string=? ls)
3161         (memq 'display-string ls)
3162         (memq 'record-constructor ls)
3163         (not (memq 'cons ls))
3164         (not (memq 'straightjacket ls))))
3165  (let ([ls (apropos-list "str")])
3166    (and (memq 'string=? ls)
3167         (memq 'display-string ls)
3168         (memq 'record-constructor ls)
3169         (not (memq 'cons ls))
3170         (not (memq 'straightjacket ls))))
3171  (equal?
3172    (with-output-to-string (lambda () (apropos 'substring)))
3173    "interaction environment:\n  substring, substring-fill!\n(chezscheme):\n  substring, substring-fill!\n(rnrs):\n  substring\n(rnrs base):\n  substring\n(scheme):\n  substring, substring-fill!\n")
3174  (equal?
3175    (with-output-to-string (lambda () (apropos "substring")))
3176    "interaction environment:\n  substring, substring-fill!\n(chezscheme):\n  substring, substring-fill!\n(rnrs):\n  substring\n(rnrs base):\n  substring\n(scheme):\n  substring, substring-fill!\n")
3177  (equal?
3178    (with-output-to-string (lambda () (apropos 'substring (copy-environment (scheme-environment) #t '(substring-fill!)))))
3179    "supplied environment:\n  substring-fill!\n(chezscheme):\n  substring, substring-fill!\n(rnrs):\n  substring\n(rnrs base):\n  substring\n(scheme):\n  substring, substring-fill!\n")
3180  (null? (apropos-list 'thisshouldntbefound))
3181  (equal?
3182    (apropos-list 'apropos)
3183    '(apropos apropos-list
3184      ((chezscheme) apropos apropos-list)
3185      ((scheme) apropos apropos-list)))
3186  (equal? (apropos-list '$apropos-unbound1) '())
3187  (error? (eval '$apropos-unbound1))
3188  (equal? (apropos-list '$apropos-unbound1) '())
3189  (equal? (apropos-list '$apropos-bound1) '())
3190  (eq? (eval '(set! $apropos-bound1 17)) (void))
3191  (equal? (apropos-list '$apropos-bound1) '($apropos-bound1))
3192  (begin (define $apropos-env (copy-environment (scheme-environment)))
3193         (environment? $apropos-env))
3194  (equal? (apropos-list '$apropos-unbound2 $apropos-env) '())
3195  (error? (eval '$apropos-unbound2 $apropos-env))
3196  (equal? (apropos-list '$apropos-unbound2 $apropos-env) '())
3197  (equal? (apropos-list '$apropos-bound2 $apropos-env) '())
3198  (eq? (eval '(set! $apropos-bound2 17) $apropos-env) (void))
3199  (equal? (apropos-list '$apropos-bound2 $apropos-env) '($apropos-bound2))
3200)
3201
3202(mat p423 ; tests for p423 compiler
3203  (equal?
3204    (list
3205      '()
3206      75
3207      (- 2 4)
3208      (* -6 7)
3209      (cons 0 '())
3210      (cons (cons 0 '()) (cons 1 '()))
3211      (cdr (cons 16 32))
3212      (void)
3213      (if #f 3)
3214      (let () 3)
3215      (let ((x 0)) x)
3216      (let ([x 0]) x x)
3217      (let ([x 17]) (+ x x))
3218      (let ([q (add1 (add1 2))]) q)
3219      (+ 20 (if #t 122))
3220      (let ((x 16)
3221            (y 128))
3222        (* x y))
3223      (if #t
3224         (+ 20
3225           (if #t 122))
3226         10000)
3227      (let ([x 3])
3228        (let ([y (+ x (quote 4))])
3229          (+ x y)))
3230      (let ((x '(#(1 2 (3 #(4))) #() 3 #t))) x)
3231      (not (if #f #t (not #f)))
3232      (let ([x 0] [y 4000]) x)
3233      (let ((x (cons 16 32))) (pair? x))
3234      (begin (if #f 7) 3)
3235      (begin (< 1 2) 3)
3236      (begin '(1 . 2) 3)
3237      (begin (if (zero? 4) 7) 3)
3238      (let ([x 0]) (begin (if (zero? x) 7) x))
3239      (let ([x 0]) (begin (if (zero? x) (begin x 7)) x))
3240      (let ([x 0] [z 9000])
3241         (begin (if (zero? x) (begin x 7)) z))
3242      (let ([x 0] [z 9000])
3243         (begin (if (zero? x) (begin (set! x x) 7))
3244           (+ x z)))
3245      (let ([x 4]) (begin (+ (begin (set! x 17) 3) 4) x))
3246      (let ([x (cons 0 '())])
3247         (begin (if x (set-car! x (car x))) x))
3248      (let ([x (cons 0 '())])
3249         (begin (if x (set-car! x (+ (car x) (car x)))) x))
3250      (let ([x (cons 0 '())])
3251         (if (zero? (car x)) (begin (set-car! x x) 7) x))
3252      (let ([x (cons 0 '())])
3253         (let ([q x]) (if (zero? (car x)) (begin (set-car! q x) 7) x)))
3254      (let ([x 0]) (if (zero? x) (begin (set! x (+ x 5000)) x) 20))
3255      (let ([y 0]) (begin (if #t (set! y y)) y))
3256      (begin (if #t #t #t) #f)
3257      (begin (if (if #t #t #f) (if #t #t #f) (if #t #t #f)) #f)
3258      (let
3259         ([x 0]
3260          [y 4000]
3261          [z 9000])
3262         (let ((q (+ x z)))
3263           (begin
3264             (if (zero? x) (begin (set! q (+ x x)) 7))
3265             (+ y y)
3266             (+ x z))))
3267      (let ([x (let ([y 2]) y)]
3268             [y 5])
3269         (add1 x))
3270      (let ([y 4000]) (+ y y))
3271      ((lambda (y) y) 4000)
3272      (let ([f (lambda (x) x)])
3273         (add1 (f 0)))
3274      (let ([f (lambda (y) y)]) (f (f 4)))
3275      ((lambda (f) (f (f 4))) (lambda (y) y))
3276      ((let ([a 4000])
3277          (lambda (b) (+ a b)))
3278        5000)
3279      (((lambda (a)
3280           (lambda (b)
3281             (+ a b)))
3282         4000)
3283        5000)
3284      (let ([f (lambda (x) (add1 x))]) (f (f 0)))
3285      ((lambda (f) (f (f 0))) (lambda (x) (add1 x)))
3286      (let ([x 0] [f (lambda (x) x)])
3287         (let ([a (f x)] [b (f x)] [c (f x)]) (+ (+ a b) c)))
3288      (let ([x 0] [y 1] [z 2] [f (lambda (x) x)])
3289         (let ([a (f x)] [b (f y)] [c (f z)])
3290           (+ (+ a b) c)))
3291      (let ([f (lambda (x y) x)])
3292         (f 0 1))
3293      (let ([f (lambda (x y) x)])
3294         (let ([a (f 0 1)]) (f a a)))
3295      (let ([x 0] [y 1] [z 2] [f (lambda (x y z) x)])
3296         (let ([a (f x y z)]) (f a a a)))
3297      (let ([x 0] [y 1] [z 2] [f (lambda (x y z) x)])
3298         (let ([a (f x y z)] [b y] [c z]) (f a b c)))
3299      (let ([f (lambda (a b c d)
3300                  (+ a d))])
3301         (f 0 1 2 3))
3302      (let ([f (lambda (x) x)])
3303         (+ (f 0)
3304           (let ([a 0] [b 1] [c 2])
3305             (+ (f a) (+ (f b) (f c))))))
3306      (let ([f (lambda (x) x)])
3307         (+ (f 0)
3308           (let ([a 0] [b 1] [c 2])
3309             (add1 (f a)))))
3310      (let ([f (lambda (x) x)])
3311        (let ([a 1])
3312          (* (+ (f a) a) a)))
3313
3314      (let ([k (lambda (x y) x)])
3315        (let ([b 17])
3316          ((k (k k 37) 37) b (* b b))))
3317
3318      (let ([f (lambda ()
3319                 (let ([n 256])
3320                    (let ([v (make-vector n)])
3321                     (vector-set! v 32 n)
3322                     (vector-ref v 32))))])
3323        (pair? (f)))
3324      (let ((w 4) (x 8) (y 16) (z 32))
3325        (let ((f (lambda ()
3326                   (+ w (+ x (+ y z))))))
3327          (f)))
3328      (let ([f (lambda (x) x)])
3329         (+ (f 0) (let ([a 0] [b 1] [c 2] [d 3])
3330                    (+ (f a)
3331                      (+ (f b)
3332                        (+ (f c)
3333                          (f d)))))))
3334     ; test use of keywords/primitives as variables
3335      (let ([quote (lambda (x) x)]
3336            [let (lambda (x y) (- y x))]
3337            [if (lambda (x y z) (cons x z))]
3338            [cons (lambda (x y) (cons y x))]
3339            [+ 16])
3340        (set! + (* 16 2))
3341        (cons (let ((quote (lambda () 0))) +)
3342              (if (quote (not #f))
3343                  720000
3344                  -1)))
3345      (letrec () 3)
3346      (let ([a 0]) (letrec ([a (lambda () 0)] [b (lambda () 11)]) (set! a 11)))
3347      (let ([a 0]) (letrec ([a (lambda () (set! a 0))] [b 11]) (a)))
3348      (let ([a 0]) (let ([a (set! a 0)] [b 11]) a))
3349      (let ([a 5]) (let ([a 0] [b (set! a (+ a 11))]) a))
3350      (let ([x (lambda () 4)])
3351        (letrec ([y (lambda () (z))] [z x]) (y)))
3352      (letrec ([a (lambda () 0)]) (a))
3353      (letrec ([a (lambda () 0)] [b (lambda () 11)]) (a))
3354      (let ([z 4])
3355        (letrec ([f (lambda (x)
3356                      (letrec ([g (lambda (y)
3357                                    (if (= y 0) 0
3358                                        (f (- y 1))))])
3359                        (g x)))])
3360          (f z)))
3361      (let ([x 0]) (letrec ([a (lambda () 0)] [b (lambda () 11)]) (set! x 11)))
3362      (let ([a 0]) (let ([b (set! a 0)]) a))
3363      (let ([a 0]) (let ([a (set! a 0)]) (let ([b 11]) a)))
3364      (let ([a 0]) (let ([a 0]) (let ([b (set! a 11)]) a)))
3365      (let ([a 0]) (let ([a 0]) (let ([b 11]) (set! a 11))))
3366      (let ([f (let ([x 1]) (lambda (y) (+ x y)))])
3367         (let ([x 0]) (f (f x))))
3368      ((let ([t (lambda (x) (+ x 50))])
3369          (lambda (f) (t (f 1000))))
3370        (lambda (y) (+ y 2000)))
3371      (let ([x 0])
3372         (let ([f (let ([x 1]
3373                        [z x])
3374                    (lambda (y)
3375                      (+ x (+ z y))))])
3376           (f (f x))))
3377      (((lambda (t)
3378           (lambda (f) (t (f 1000))))
3379         (lambda (x) (+ x 50)))
3380        (lambda (y) (+ y 2000)))
3381      ((let ([t 50])
3382          (lambda (f)
3383            (+ t (f))))
3384        (lambda () 2000))
3385      (((lambda (t)
3386           (lambda (f)
3387             (+ t (f))))
3388         50)
3389        (lambda () 2000))
3390      ((let ([x 300])
3391          (lambda (y) (+ x y)))
3392        400)
3393      (let ([x 3] [f (lambda (x y) x)])
3394         (f (f 0 0) x))
3395      (let ([x 3] [f (lambda (x y) x)])
3396         (if (f 0 0) (f (f 0 0) x) 0))
3397      (let ([x02 3] [f01 (lambda (x04 y03) x04)])
3398         (if (not x02) (f01 (f01 0 0) x02) 0))
3399      (let ((f (lambda (x) (if (if (pair? x) (not (eq? (car x) 0)) #f) x #f))))
3400        (f (cons 0 0)))
3401      (let ((f (lambda (x)
3402                 (if (if x (not (if (pair? x) (not (eq? (car x) 0)) #f)) #f)
3403                     x #f))))
3404        (f 0))
3405      (let ((f (lambda (x) (if (if (pair? x) #t (null? x)) x '()))))
3406        (f 0))
3407      (let ([y 4])
3408         (let ([f (lambda (y) y)])
3409           (f (f y))))
3410      (let ([y 4])
3411         (let ([f (lambda (x y) 0)])
3412           (f (f y y) (f y y))))
3413      (let ([y 4])
3414         (let ([f (lambda (x y) 0)])
3415           (f (f y y) (f y (f y y)))))
3416      (let ([y 4])
3417         (let ([f (lambda (x y) 0)])
3418           (f (f y (f y y)) (f y (f y y)))))
3419      ((lambda (y) ((lambda (f) (f (f y))) (lambda (y) y))) 4)
3420      (let ([f (lambda (x) (+ x x))]) (f 4000))
3421      (let ((x (if 1000 2000 3000)))
3422         x)
3423      (let ([f (lambda (x) x)])
3424         (add1 (if #f 1 (f 22))))
3425      (let ([f (lambda (x) x)])
3426         (if (f (zero? 23)) 1 22))
3427      (let ([f (lambda (x) (if x (not x) x))]
3428             [f2 (lambda (x) (* 10 x))]
3429             [x 23])
3430         (add1 (if (f (zero? x)) 1 (* x (f2 (sub1 x))))))
3431      (let ([f (lambda () 0)])
3432         (let ([x (f)])
3433           1))
3434      (let ([f (lambda () 0)])
3435         (begin (f) 1))
3436      (let ([f (lambda (x) x)])
3437         (if #t (begin (f 3) 4) 5))
3438      (let ([f (lambda (x) x)])
3439         (begin (if #t (f 4) 5) 6))
3440      (let ([f (lambda (x) x)])
3441         (begin
3442           (if (f #t)
3443             (begin
3444               (f 3)
3445               (f 4))
3446             (f 5))
3447           (f 6)))
3448      (let ([f (lambda (x) (add1 x))])
3449         (f (let ([f 3]) (+ f 1))))
3450      (let ((x 15)
3451             (f (lambda (h v) (* h v)))
3452             (k (lambda (x) (+ x 5)))
3453             (g (lambda (x) (add1 x))))
3454         (k (g (let ((g 3)) (f g x)))))
3455      (let ([x 4])
3456         (let ([f (lambda () x)])
3457           (set! x 5)
3458           (f)))
3459      (let ([x (let ([y 2])
3460                  y)])
3461         x)
3462      (let ([x (if #t (let ([y 2])
3463                         y)
3464                  1)])
3465         x)
3466      (let ([x (let ([y (let ([z 3])
3467                           z)])
3468                  y)])
3469         x)
3470      (let ([x (if #t (let ([y (if #t (let ([z 3])
3471                                         z)
3472                                  2)])
3473                         y)
3474                  1)])
3475         x)
3476      (+ (let ([x 3])
3477            (add1 x))
3478         4)
3479      (+ (let ([x 3] [y 4])
3480            (* x y))
3481         4)
3482      (let ([x (add1 (let ([y 4]) y))]) x)
3483      (let ([x (add1 (letrec ([y (lambda () 4)]) (y)))]) x)
3484      (let ([x (+ (let ([y 4]) y)  (let ([y 4]) y))]) (add1 x))
3485      (let ([z 0])
3486         (let ([x z])
3487           z
3488           x))
3489      (let ([z 0])
3490         (let ([x (begin (let ([y 2]) (set! z y)) z)])
3491           x))
3492      (let ([x (begin (let ([y 2]) (set! y y)) (let ([z 3]) z))])
3493         x)
3494      (letrec ([one (lambda (n) (if (zero? n) 1 (one (sub1 n))))])
3495         (one 13))
3496      (letrec
3497         ((even (lambda (x) (if (zero? x) #t (odd (sub1 x)))))
3498          (odd (lambda (x) (if (zero? x) #f (even (sub1 x))))))
3499         (odd 13))
3500      (let ([t #t]
3501             [f #f])
3502         (letrec
3503           ((even (lambda (x) (if (zero? x) t (odd (sub1 x)))))
3504            (odd (lambda (x) (if (zero? x) f (even (sub1 x))))))
3505           (odd 13)))
3506      (let ((even (lambda (x) x)))
3507         (even
3508           (letrec
3509             ((even (lambda (x) (if (zero? x) #t (odd (sub1 x)))))
3510              (odd (lambda (x) (if (zero? x) #f (even (sub1 x))))))
3511             (odd 13))))
3512      (letrec ((fact (lambda (n) (if (zero? n) 1 (* n (fact (sub1 n)))))))
3513         (fact 5))
3514      (letrec ([remq (lambda (x ls)
3515                       (if (null? ls)
3516                           '()
3517                           (if (eq? (car ls) x)
3518                               (remq x (cdr ls))
3519                               (cons (car ls) (remq x (cdr ls))))))])
3520        (remq 3 '(3 1 3)))
3521      (let ([x 5])
3522         (letrec
3523           ([a
3524              (lambda (u v w) (if (zero? u) (b v w) (a (- u 1) v w)))]
3525            [b
3526              (lambda (q r)
3527                (let ([p (* q r)])
3528                  (letrec
3529                    ([e (lambda (n) (if (zero? n) (c p) (o (- n 1))))]
3530                     [o (lambda (n) (if (zero? n) (c x) (e (- n 1))))])
3531                    (e (* q r)))))]
3532            [c (lambda (x) (* 5 x))])
3533           (a 3 2 1)))
3534      (let ([f (lambda () 80)])
3535         (let ([a (f)] [b (f)])
3536           0))
3537      (let ([f (lambda () 80)])
3538         (let ([a (f)] [b (f)])
3539           (* a b)))
3540      (let ([f (lambda () 80)]
3541             [g (lambda () 80)])
3542         (let ([a (f)] [b (g)])
3543           (* a b)))
3544      (let ((f (lambda (x) (add1 x)))
3545             (g (lambda (x) (sub1 x)))
3546             (t (lambda (x) (add1 x)))
3547             (j (lambda (x) (add1 x)))
3548             (i (lambda (x) (add1 x)))
3549             (h (lambda (x) (add1 x)))
3550             (x 80))
3551         (let ((a (f x)) (b (g x)) (c (h (i (j (t x))))))
3552           (* a (* b (+ c 0)))))
3553      (let ((x 3000))
3554         (if (integer? x)
3555           (let ((y (cons x '())))
3556             (if (if (pair? y) (null? (cdr y)) #f)
3557               (+ x 5000)
3558               (- x 3000)))))
3559      (let ((x (cons 1000 2000)))
3560         (if (pair? x)
3561           (let ((temp (car x)))
3562             (set-car! x (cdr x))
3563             (set-cdr! x temp)
3564             (+ (car x) (cdr x)))
3565           10000000))
3566      (let ((v (make-vector 3)))
3567         (vector-set! v 0 10)
3568         (vector-set! v 1 20)
3569         (vector-set! v 2 30)
3570         (if (vector? v)
3571           (+ (+ (vector-length v) (vector-ref v 0))
3572             (+ (vector-ref v 1) (vector-ref v 2)))
3573           10000))
3574      (let ([fact
3575               (lambda (fact n)
3576                 (if (zero? n) 1 (* (fact fact (sub1 n)) n)))])
3577         (fact fact 5))
3578      (let ([f (lambda (x) (+ x 1000))])
3579         (if (zero? (f -2)) (f 6000) (f (f 8000))))
3580      (let ([f (lambda (x) (+ x 1000))])
3581         (if (zero? (f -1)) (f 6000) (f (f 8000))))
3582      (let ((f (lambda (x y) (+ x 1000))))
3583         (+ (if (f 3000 (begin 0 0 0)) (f (f 4000 0) 0) 8000) 2000))
3584      ((((lambda (x)
3585            (lambda (y)
3586              (lambda (z)
3587                (+ x (+ y (+ z y))))))
3588          5) 6) 7)
3589      ((((((lambda (x)
3590              (lambda (y)
3591                (lambda (z)
3592                  (lambda (w)
3593                    (lambda (u)
3594                      (+ x (+ y (+ z (+ w u)))))))))
3595            5) 6) 7) 8) 9)
3596      (let ((f (lambda (x) x)))
3597         (if (procedure? f)
3598           #t
3599           #f))
3600      (let ((sum (lambda (sum ls)
3601                    (if (null? ls)
3602                      0
3603                      (+ (car ls) (sum sum (cdr ls)))))))
3604         (sum sum (cons 1 (cons 2 (cons 3 '())))))
3605      (let ((v (make-vector 5))
3606             (w (make-vector 7)))
3607         (vector-set! v 0 #t)
3608         (vector-set! w 3 #t)
3609         (if (boolean? (vector-ref v 0))
3610           (vector-ref w 3)
3611           #f))
3612      (let ((a 5) (b 4))
3613         (if (< b 3)
3614           (eq? a (+ b 1))
3615           (if (<= b 3)
3616             (eq? (- a 1) b)
3617             (= a (+ b 2)))))
3618      (let ((a 5) (b 4))
3619         (if #f
3620           (eq? a (+ b 1))
3621           (if #f
3622             (eq? (- a 1) b)
3623             (= a (+ b 2)))))
3624      (((lambda (a)
3625           (lambda ()
3626             (+ a (if #t 200))
3627             1500))
3628         1000))
3629      (((lambda (b)
3630           (lambda (a) (set! a (if 1 2)) (+ a b)))
3631         100)
3632        200)
3633      ((((lambda (a)
3634            (lambda (b)
3635              (set! a (if b 200))
3636              (lambda (c)
3637                (set! c (if 300 400))
3638                (+ a (+ b c)))))
3639          1000)
3640         2000)
3641        3000)
3642      ((((lambda (a) (lambda (b) (lambda (c) (+ a (+ b c))))) 10) 20) 30)
3643      (+ 2 3)
3644      ((lambda (a) (+ 2 a)) 3)
3645      (((lambda (b) (lambda (a) (+ b a))) 3) 2)
3646      ((lambda (b) ((lambda (a) (+ b a)) 2)) 3)
3647      ((lambda (f) (f (f 5))) (lambda (x) x))
3648      ((let ((f (lambda (x) (+ x 3000))))
3649          (lambda (y) (f (f y))))
3650        2000)
3651      (let ((n 17) (s 18) (t 19))
3652         (let ((st (make-vector 5)))
3653           (vector-set! st 0 n)
3654           (vector-set! st 1 s)
3655           (vector-set! st 2 t)
3656           (if (not (vector? st))
3657             10000
3658             (vector-length st))))
3659      (let ((s (make-vector 1)))
3660         (vector-set! s 0 82)
3661         (if (eq? (vector-ref s 0) 82) 1000 2000))
3662      (not 17)
3663      (not #f)
3664      (let ([fact
3665               (lambda (fact n acc)
3666                 (if (zero? n) acc (fact fact (sub1 n) (* n acc))))])
3667         (fact fact 5 1))
3668      ((lambda (b c a)
3669          (let ((b (+ b a))
3670                (a (+ a (let ((a (+ b b))
3671                              (c (+ c c)))
3672                          (+ a a)))))
3673            (* a a)))
3674        2 3 4)
3675      (let ((f (lambda (x) (lambda () (x))))) ((f (lambda () 3))))
3676      (letrec ((f (lambda (x) (if (zero? x) 1 (* x (f (- x 1)))))))
3677         (let ([q 17])
3678           (let ((g (lambda (a) (set! q 10) (lambda () (a q)))))
3679             ((g f)))))
3680      (letrec ((f (lambda (x) (if (zero? x) 1 (* x (f (- x 1)))))))
3681         (let ((g (lambda (a) (lambda (b) (a b)))))
3682           ((g f) 10)))
3683      (letrec ((f (lambda () (+ a b)))
3684               (g (lambda (y) (set! g (lambda (y) y)) (+ y y)))
3685               (a 17)
3686               (b 35)
3687               (h (cons (lambda () a) (lambda (v) (set! a v)))))
3688         (let ((x1 (f)) (x2 (g 22)) (x3 ((car h))))
3689           (let ((x4 (g 22)))
3690             ((cdr h) 3)
3691             (let ((x5 (f)) (x6 ((car h))))
3692               (cons x1 (cons x2 (cons x3 (cons x4 (cons x5 x6)))))))))
3693      (letrec ((f (lambda () (+ a b)))
3694               (a 17)
3695               (b 35)
3696               (h (cons (lambda () a) (lambda () b))))
3697         (cons (f) (cons a (cons b (cons ((car h)) ((cdr h)))))))
3698      (letrec ((f (lambda (x)
3699                     (letrec ((x 3)) 3))))
3700         (letrec ((g (lambda (x) (letrec ((y 14)) (set! y 7) y))))
3701           (set! g (cons g 3))
3702           (letrec ((h (lambda (x) x)) (z 42))
3703             (cons (cdr g) (h z)))))
3704      (let ([t #t] [f #f])
3705         (let ([bools (cons t f)] [id (lambda (x) (if (not x) f t))])
3706           (letrec
3707             ([even (lambda (x) (if (zero? x) (id (car bools)) (odd (- x 1))))]
3708              [odd (lambda (y) (if (zero? y) (id (cdr bools)) (even (- y 1))))])
3709             (odd 5))))
3710      (letrec ([fib (lambda (x)
3711                      (let ([decrx (lambda () (set! x (- x 1)))])
3712                        (if (< x 2)
3713                            1
3714                            (+ (begin (decrx) (fib x))
3715                               (begin (decrx) (fib x))))))])
3716        (fib 10))
3717      (letrec ([fib (lambda (x)
3718                      (let ([decrx (lambda () (lambda (i) (set! x (- x i))))])
3719                        (if (< x 2)
3720                            1
3721                            (+ (begin ((decrx) 1) (fib x))
3722                               (begin ((decrx) 1) (fib x))))))])
3723        (fib 10))
3724      (let ((f (lambda (g u) (g (if u (g 37) u)))))
3725        (f (lambda (x) x) 75))
3726
3727      (let ((f (lambda (h u) (h (if u (h (+ u 37)) u))))
3728            (w 62))
3729        (f (lambda (x) (- w x)) (* 75 w)))
3730
3731      (let ([t #t] [f #f])
3732        (let ([bools (cons t f)] [id (lambda (x) (if (not x) f t))])
3733          (letrec
3734            ([even (lambda (x) (if (id (zero? x)) (car bools) (odd (- x 1))))]
3735             [odd (lambda (y) (if (zero? y) (id (cdr bools)) (even (- y 1))))])
3736            (odd 5))))
3737
3738      ((lambda (x y z)
3739         (let  ((f (lambda (u v) (begin (set! x u) (+ x v))))
3740                (g (lambda (r s) (begin (set! y (+ z s)) y))))
3741           (* (f '1 '2) (g '3 '4))))
3742       '10 '11 '12)
3743
3744      ((lambda (x y z)
3745         (let ((f '#f)
3746               (g (lambda (r s) (begin (set! y (+ z s)) y))))
3747           (begin
3748             (set! f
3749               (lambda (u v) (begin (set! v u) (+ x v))))
3750             (* (f '1 '2) (g '3 '4)))))
3751       '10 '11 '12)
3752
3753      (letrec ((f (lambda (x) (+ x 1)))
3754               (g (lambda (y) (f (f y)))))
3755        (+ (f 1) (g 1)))
3756
3757      (let ((y 3))
3758        (letrec
3759          ((f (lambda (x) (if (zero? x) (g (+ x 1)) (f (- x y)))))
3760           (g (lambda (x) (h (* x x))))
3761           (h (lambda (x) x)))
3762          (g 39)))
3763
3764      (letrec ((f (lambda (x) (+ x 1)))
3765               (g (lambda (y) (f (f y)))))
3766        (set! f (lambda (x) (- x 1)))
3767        (+ (f 1) (g 1)))
3768
3769      (letrec ([f (lambda () (+ a b))]
3770               [a 17]
3771               [b 35]
3772               [h (cons (lambda () a) (lambda () b))])
3773        (cons (f) (cons a (cons b (cons ((car h)) ((cdr h)))))))
3774
3775      (let ((v (make-vector 8)))
3776        (vector-set! v 0 '())
3777        (vector-set! v 1 (void))
3778        (vector-set! v 2 #f)
3779        (vector-set! v 3 (cons 3 4))
3780        (vector-set! v 4 (make-vector 3))
3781        (vector-set! v 5 #t)
3782        (vector-set! v 6 2)
3783        (vector-set! v 7 5)
3784        (vector-ref v (vector-ref v 6)))
3785
3786      (let ([x 5] [th (let ((a 1)) (lambda () a))])
3787        (letrec ([fact (lambda (n th)
3788                         (if (zero? n)
3789                             (th)
3790                             (* n (fact (- n 1) th))))])
3791          (fact x th)))
3792
3793      (let ([negative? (lambda (n) (< n 0))])
3794        (letrec
3795          ([fact
3796             (lambda (n)
3797               (if (zero? n)
3798                   1
3799                   (* n (fact (- n 1)))))]
3800           [call-fact
3801             (lambda (n)
3802               (if (not (negative? n))
3803                   (fact n)
3804                   (- 0 (fact (- 0 n)))))])
3805          (cons (call-fact 5) (call-fact -5))))
3806
3807      (letrec ([iota-fill!
3808                (lambda (v i n)
3809                  (if (not (= i n))
3810                      (begin
3811                        (vector-set! v i i)
3812                        (iota-fill! v (+ i 1) n))))])
3813        (let ([n 4])
3814          (let ([v (make-vector n)])
3815            (iota-fill! v 0 n)
3816            v)))
3817
3818    ; try with operand-constraints reg/int? returning false for ints
3819    ; to make sure that nested operands are being pulled out properly
3820      (let ((f (lambda (x) x)))
3821        (let ((g (lambda (x) (let ((y (+ x x))) (f x) (cons x y)))))
3822          (g 3)))
3823
3824    ; nested test examples
3825      (+ (let ((x 7) (y 2)) (if (if (= x 7) (< y 0) (<= 0 y)) 77 88)) 99)
3826      (+ (let ((x 7) (y -22)) (if (if (= x 7) (< y 0) (<= 0 y)) 77 88)) 99)
3827      (+ (let ((x 8) (y 2)) (if (if (= x 7) (< y 0) (<= 0 y)) 77 88)) 99)
3828      (+ (let ((x 8) (y -22)) (if (if (= x 7) (< y 0) (<= 0 y)) 77 88)) 99)
3829
3830    ; make-vector with non-constant operand and improper alignment
3831      (let ([x 6])
3832        (let ([v (make-vector x)])
3833          (vector-set! v 0 3)
3834          (vector-set! v 1 (cons (vector-ref v 0) 2))
3835          (vector-set! v 2 (cons (vector-ref v 1) 2))
3836          (vector-set! v 3 (cons (vector-ref v 2) 2))
3837          (vector-set! v 4 (cons (vector-ref v 3) 2))
3838          (vector-set! v 5 (cons (vector-ref v 4) 2))
3839          (cons (pair? (vector-ref v 5)) (car (vector-ref v 4)))))
3840
3841    ; nest some lambdas
3842      (((((lambda (a)
3843            (lambda (b)
3844              (lambda (c)
3845                (lambda (d)
3846                  (cons (cons a b) (cons c d))))))
3847           33) 55) 77) 99)
3848
3849    ; test set! on letrec rhs
3850     (letrec ([b 4])
3851       (letrec ([a (lambda (x) (set! a x) 5)])
3852         (a (lambda (x) x))
3853         (set! b 8)
3854         (a 7)))
3855
3856    ; test optimize-letrec---contributed by Jeremiah Penery
3857     (letrec ([q (cons (lambda (x)
3858                         (letrec ([b r])
3859                           b))
3860                       '())]
3861              [r 10])
3862       ((car q) 5))
3863
3864    ; normalize-context test a bit---contributed by Andy Keep
3865     (let ((x 5)) (if (set! x 6) 1 0) x)
3866
3867    ; stress the register allocator
3868      (let ((a 17))
3869        (let ((f (lambda (x)
3870                   (let ((x1 (+ x 1)) (x2 (+ x 2)))
3871                     (let ((y1 (* x1 7)) (y2 (* x2 7)))
3872                       (let ((z1 (- y1 x1)) (z2 (- y2 x2)))
3873                         (let ((w1 (* z1 a)) (w2 (* z2 a)))
3874                           (let ([g (lambda (b)
3875                                      (if (= b a)
3876                                          (cons x1 (cons y1 (cons z1 '())))
3877                                          (cons x2 (cons y2 (cons z2 '())))))]
3878                                 [h (lambda (c)
3879                                      (if (= c x) w1 w2))])
3880                             (if (if (= (* x x) (+ x x))
3881                                     #t
3882                                     (< x 0))
3883                                 (cons (g 17) (g 16))
3884                                 (cons (h x) (h (- x 0))))))))))))
3885          (cons (f 2) (cons (f -1) (cons (f 3) '())))))
3886
3887      (let ([x (cons #f #t)] [y 17])
3888        (if (if (car x) #t (< y 20))
3889            (* y (* y 2))
3890            (void)))
3891      (let ((v (make-vector (add1 37))))
3892        (vector-set! v 0 (boolean? v))
3893        (vector-set! v (* 3 11) (vector-length v))
3894        ((let ((w (cons 33 '())))
3895          (lambda ()
3896            (if (not (eq? w (cons 33 '())))
3897                (begin
3898                  (set-cdr! w (vector? v))
3899                  w))))))
3900      (let ((v (make-vector (add1 37))))
3901        (vector-set! v 0 (boolean? v))
3902        (vector-set! v (* 3 11) #t)
3903        ((let ((w (cons (sub1 34) #f)))
3904          (lambda ()
3905            (set-cdr! w v)
3906            (if (not (eq? w (cons (- (vector-length v) 5) v)))
3907                (begin
3908                  (set-car! w (vector-ref (cdr w) (car w)))
3909                  w))))))
3910
3911     ; make sure uncover-live passes don't leave behind unassigned
3912     ; or unlisted variables as a result of dead code.
3913      (letrec ([a (lambda () 1)])
3914        (let ([b 2])
3915          (if #t
3916              3
3917              (begin (a) b))))
3918
3919     ; stress test introduce-unspillables by generating
3920     ; (mset fp i (+ (mref fp j) (mref fp k)))
3921      (let ((f (lambda (x) x)))
3922        (let ((x 1) (y 2))
3923          (let ((z (f x)))
3924            (let ((w (+ x y)))
3925              (let ((q (f w)))
3926                w)))))
3927
3928     ; stress test introduce-unspillables by generating
3929     ; (mset (mref fp i) tmp (mref fp k))---can't actually get
3930     ; (mset (mref fp i) (mref fp j) (mref fp k)), 'cause we
3931     ; have to add in the vector-data offset
3932      (let ((f (lambda (x) x)))
3933        (let ((x (make-vector 4)) (y 2) (z 17))
3934          (vector-set! x y z)
3935          (let ((w (f x)))
3936            (cons (+ y z) x))))
3937      (letrec ([s0 (lambda (a b c d e)
3938                     (if (null? a)
3939                         (cons b (cons c (cons d e)))
3940                         (if (eq? (car a) #t)
3941                             (s1 (cdr a) (+ b 1) c d e)
3942                             (s2 (cdr a) b (+ c 1) d e))))]
3943               [s1 (lambda (a b c d e)
3944                     (if (eq? (car a) #t)
3945                         (s0 (cdr a) b c (+ d 1) e)
3946                         (s1 (cdr a) b c d (+ e 1))))]
3947               [s2 (lambda (a b c d e)
3948                     (if (eq? (car a) #t)
3949                         (s0 (cdr a) (+ b 1) d c e)
3950                         (s2 (cdr a) e d b c)))])
3951        (s0 '(#t #f #t #f #t #f #f #f #f #t) 10 20 30 40))
3952
3953     ; stress optimize-letrec.  in the outer letrec, q should be treated as
3954     ; 'lambda'.  in the inner letrec, f should be treated as simple,
3955     ; d as 'lambda', and a, b, c, and e as complex.
3956     ; should evaluate to ((40 #f 105 15 . #t) #t 252 36 #t 9841 . 18)
3957      (letrec ((q (lambda (x) (if (< x 1) 13 (+ (* (q (- x 2)) 3) 1)))))
3958        (letrec ((a (lambda (x) x))
3959                 (b (cons (lambda () (* c 7)) (lambda (v) (set! c v))))
3960                 (c 15)
3961                 (d (lambda (x) (set! a x) (a x)))
3962                 (e (q 12))
3963                 (f 18))
3964          (let ([a0 (a #f)] [b0 ((car b))] [c0 c])
3965            (let ([d0 (d (lambda (z) #t))])
3966              ((cdr b) (* f 2))
3967              (cons (cons (q 1) (cons a0 (cons b0 (cons c0 d0))))
3968                    (cons (a #f)
3969                          (cons ((car b))
3970                                (cons c (cons (procedure? d) (cons e f))))))))))
3971
3972      ;; Jie Li
3973      (let ((a 5))
3974        (let ((b (cons a 6)))
3975          (let ((f (lambda(x) (* x a))))
3976           (begin (if (- (f a) (car b))
3977                      (begin (set-car! b
3978                                       (if (not a) (* 2 a) (+ 2 a)))
3979                             (f a))
3980                      (if (not (not (< (f a) b)))
3981                          (f a)))
3982                  (not 3)
3983                  (void)
3984                  (f (car b))))))
3985      (letrec ([f (lambda (x y) (if (not x) (g (add1 x) (add1 y)) (h (+ x y))))]
3986               [g (lambda (u v)
3987                    (let ([a (+ u v)]
3988                          [b (* u v)])
3989                      (letrec ([e (lambda (d)
3990                                    (letrec ([p (cons a b)]
3991                                             [q (lambda (m)
3992                                                  (if (< m u)
3993                                                      (f m d)
3994                                                      (h (car p))))])
3995                                      (q (f a b))))])
3996                        (e u))))]
3997               [h (lambda (w) w)])
3998        (f 4 5))
3999      (letrec ((f (lambda (x)
4000                    (+ x (((lambda (y)
4001                             (lambda (z)
4002                               (+ y z)))
4003                           6)7))))
4004               (g (+ 5 ((lambda (w u) (+ w u)) 8 9))))
4005        g)
4006      ;; Jordan Johnson
4007      (let ((test (if (not (not 10)) #f 5)))
4008        (letrec ([num 5]
4009                 [length
4010                  (lambda (ls)
4011                    (let ((len (if ((lambda (ck) (begin ck (set! num test) ck))
4012                                    (null? ls))
4013                                   (begin num (set! num 0) num)
4014                                   (begin (length '())
4015                                          (set! num 5)
4016                                          (+ 1 (length (cdr ls)))))))
4017                      (if len len)))])
4018          (length (cons 5 (cons (if (set! num 50) (length (cons test '())) 1)
4019                                '())))))
4020      (letrec ([quotient (lambda (x y)
4021                           (if (< x 0)
4022                               (- 0 (quotient (- 0 x) y))
4023                               (if (< y 0)
4024                                   (- 0 (quotient x (- 0 y)))
4025                                   (letrec ([f (lambda (x a)
4026                                                 (if (< x y)
4027                                                     a
4028                                                     (f (- x y) (+ a 1))))])
4029                                     (f x 0)))))])
4030        (letrec ([sub-interval 1]
4031                 [sub-and-continue
4032                  (lambda (n acc k) (k (- n sub-interval) (* n acc)))]
4033                 [strange-fact
4034                  (lambda (n acc)
4035                    (if (zero? n)
4036                        (lambda (proc) (proc acc))
4037                        (sub-and-continue n acc strange-fact)))])
4038          (let ([x 20]
4039                [fact (let ((seed 1)) (lambda (n) (strange-fact n seed)))])
4040            (let ([give-fact5-answer (fact 5)]
4041                  [give-fact6-answer (fact 6)]
4042                  [answer-user (lambda (ans) (quotient ans x))])
4043              (set! x (give-fact5-answer answer-user))
4044              (begin (set! x (give-fact6-answer answer-user))
4045                     x)))))
4046      (let ((y '())
4047            (z 10))
4048        (let ((test-ls (cons 5 y)))
4049          (set! y (lambda (f)
4050                    ((lambda (g) (f (lambda (x) ((g g) x))))
4051                     (lambda (g) (f (lambda (x) ((g g) x)))))))
4052          (set! test-ls (cons z test-ls))
4053          (letrec ((length (lambda (ls)
4054                              (if (null? ls) 0 (+ 1 (length (cdr ls)))))))
4055            (let ((len (length test-ls)))
4056              (eq? (begin
4057                    (set! length (y (lambda (len)
4058                                      (lambda (ls)
4059                                        (if (null? ls)
4060                                            0
4061                                            (+ 1 (len (cdr ls))))))))
4062                    (length test-ls))
4063                   len)))))
4064      ;; Ryan Newton
4065      (letrec
4066        ((loop
4067           (lambda ()
4068             (lambda ()
4069               (loop)))))
4070        (loop)
4071        0)
4072      (letrec ([f (lambda ()
4073                    (letrec ([loop
4074                               (lambda (link)
4075                                 (lambda ()
4076                                   (link)))])
4077                      (loop (lambda () 668))))])
4078        ((f)))
4079      (if (lambda () 1)
4080          (let ((a 2))
4081            (if (if ((lambda (x)
4082                       (let ((x (set! a (set! a 1))))
4083                         x)) 1)
4084                    (if (eq? a (void))
4085                        #t
4086                        #f)
4087                    #f)
4088                #36rgood        ; dyb: cannot use symbols, so use radix 36
4089                #36rbad)))      ; syntax to make all letters digits
4090
4091     ; contributed by Ryan Newton
4092      (letrec
4093         (
4094           [dropsearch
4095             (lambda (cell tree)
4096               (letrec
4097                 ([create-link
4098                    (lambda (node f)
4099                      (lambda (g)
4100                        (if (not (pair? node))
4101                            (f g)
4102                            (if (eq? node cell)
4103                                #f
4104                                (f (create-link (car node)
4105                                                (create-link (cdr node) g)))))))]
4106                  [loop
4107                    (lambda (link)
4108                      (lambda ()
4109                        (if link
4110                            (loop (link (lambda (v) v)))
4111                            #f)))])
4112                 (loop (create-link tree (lambda (x) x)))
4113                 ))]
4114
4115           [racethunks
4116             (lambda (thunkx thunky)
4117               (if (if thunkx thunky #f)
4118                   (racethunks (thunkx) (thunky))
4119                   (if thunky
4120                       #t
4121                       (if thunkx
4122                           #f
4123                           '()))))]
4124
4125           [higher?
4126             (lambda (x y tree)
4127               (racethunks (dropsearch x tree)
4128                           (dropsearch y tree)))]
4129
4130           [under?
4131             (lambda (x y tree)
4132               (racethunks (dropsearch x y)
4133                           (dropsearch x tree)))]
4134
4135           [explore
4136             (lambda (x y tree)
4137               (if (not (pair? y))
4138                   #t
4139                   (if (eq? x y)
4140                       #f    ;This will take out anything that points to itself
4141                       (let ((result (higher? x y tree)))
4142                         (if (eq? result #t)
4143                             (if (explore y (car y) tree)
4144                                 (explore y (cdr y) tree)
4145                                 #f)
4146                             (if (eq? result #f)
4147                                 (process-vertical-jump x y tree)
4148                                 (if (eq? result '())
4149                                     (process-horizontal-jump x y tree)
4150                                     )))))))]
4151
4152           [process-vertical-jump
4153             (lambda (jumpedfrom jumpedto tree)
4154               (if
4155                 (under? jumpedfrom jumpedto tree)
4156                 #f
4157                 (fullfinite? jumpedto)))]
4158
4159           [process-horizontal-jump
4160             (lambda (jumpedfrom jumpedto tree)
4161               (fullfinite? jumpedto))]
4162
4163           [fullfinite?
4164             (lambda (pair)
4165               (if (not (pair? pair))
4166                   #t
4167                   (if (explore pair (car pair) pair)
4168                       (explore pair (cdr pair) pair)
4169                       #f)))])
4170         (cons
4171           (fullfinite? (cons 1 2))
4172           (cons
4173             (fullfinite? (let ((x (cons 1 2))) (set-car! x x) x))
4174             (cons
4175               (fullfinite? (let ([a (cons 0 0)] [b (cons 0 0)] [c (cons 0 0)])
4176                              (set-car! a b) (set-cdr! a c) (set-cdr! b c)
4177                              (set-car! b c) (set-car! c b) (set-cdr! c b) a))
4178               '())))))
4179    `(() 75 -2 -42 (0) ((0) 1) 32 ,(void) ,(void) 3 0 0 34 4
4180      142 2048 142 10 (#3(1 2 (3 #1(4))) #0() 3 #t) #f 0 #t 3
4181      3 3 3 0 0 9000 9000 17 (0) (0) 7 7 5000 0 #f #f 9000 3
4182      8000 4000 1 4 4 9000 9000 2 2 0 3 0 0 0 0 3 3 1 2 17 #f
4183      60 6 ((#t . -1) . 32) 3 ,(void) ,(void) ,(void) 0 4 0 0
4184      0 ,(void) 0 ,(void) 11 ,(void) 2 3050 2 3050 2050 2050
4185      700 0 0 0 #f 0 () 4 0 0 0 4 8000 2000 23 22 5061 1 1 4
4186      6 6 5 51 5 2 2 3 3 8 16 5 5 9 0 2 3 1 #t #t #t 120 (1)
4187      10 0 6400 6400 537516 8000 3000 63 120 10000 10000 8000
4188      24 35 #t 6 #t #f #f 1500 102 2600 60 5 5 5 5 5 8000 5
4189      1000 #f #t 120 144 3 3628800 3628800
4190      (52 44 17 22 38 . 3) (52 17 35 17 . 35) (3 . 42) #t 89
4191      89 37 4687 #t 48 176 5 1521 -1 (52 17 35 17 . 35) #f
4192      120 (120 . -120) #4(0 1 2 3) (3 . 6) 187 176 176 187
4193      (#t ((3 . 2) . 2) . 2) ((33 . 55) 77 . 99) 7 10 6
4194      (((3 21 18) 4 28 24) ((0 0 0) 1 7 6) (408 . 408)) 578
4195      (33 . #t)
4196      (#t .  #38(#f 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 #t 0))
4197      3 3 (19 . #4(0 0 17 0)) (22 32 41 . 12)
4198      ((40 #f 105 15 . #t) #t 252 36 #t 9841 . 18) 35 9 22 2
4199      120 #t 0 668 778477 (#t #f #f)))
4200  (equal?
4201    (list
4202      ;;; Abdulaziz Ghuloum
4203      ;;; this is a vanilla insertion sort routine, not really interesting but used to
4204      ;;; derive the Y-Combinator version below.
4205      (letrec ([sort
4206                 (lambda (p? ls)
4207                   (if (null? ls)
4208                       '()
4209                       (insert p? (car ls) (sort p? (cdr ls)))))]
4210               [insert
4211                 (lambda (p? x ls)
4212                   (if (null? ls)
4213                       (cons x '())
4214                       (if (p? x (car ls))
4215                           (cons x ls)
4216                           (cons (car ls) (insert p? x (cdr ls))))))])
4217        (sort (lambda (x y) (< x y)) '(4 3 2 5 6 3 6 9)))
4218
4219      ;;; and this is a more exotic insertion sort using double-Y-Combinator in order
4220      ;;; to stretch anonymous lambda expressions to their limit.  Does it hurt yet?
4221      (((lambda (le) ; this is sort
4222         ((lambda (f) (f f))
4223             (lambda (f)
4224               (le (lambda (p? ls)
4225                 ((f f) p? ls))))))
4226        (lambda (sort)
4227          (lambda (p? ls)
4228            (if (null? ls)
4229                '()
4230                (((lambda (le)  ; this is insert
4231                   ((lambda (f) (f f))
4232                       (lambda (f)
4233                         (le (lambda (x ls) ((f f) x ls))))))
4234                    (lambda (insert)
4235                   (lambda (x ls)
4236                     (if (null? ls)
4237                         (cons x '())
4238                         (if (p? x (car ls))
4239                             (cons x ls)
4240                                (cons (car ls) (insert x (cdr ls))))))))
4241                    (car ls) (sort p? (cdr ls)))))))
4242       (lambda (x y) (< x y)) ; this is the sorting criterion
4243       '(4 3 2 5 6 3 6 9)) ; and the list to be sorted
4244
4245      ;;; this is a definition of a rotate procedure that rotates the elements of a
4246      ;;; list n times.  It rotates the pair cells themselves and not the contents.
4247      ;;; It tests proper closure implementations in (set! x (cdr x)) as well as
4248      ;;; set-cdr! as it does not appear that frequently in tests.ss
4249      ;;;
4250      ;;;  before
4251      ;;;      +--+--+    +--+--+    +--+--+         +--+--+    +--+--+    +--+--+
4252      ;;;      | 1|------>| 2|------>| 3|------> ... | 6|------>| 7|------>| 8|#f|
4253      ;;;      +--+--+    +--+--+    +--+--+         +--+--+    +--+--+    +--+--+
4254      ;;;       ^^
4255      ;;;       yx
4256      ;;;
4257      ;;;  after
4258      ;;;      +--+--+    +--+--+         +--+--+    +--+--+    +--+--+    +--+--+
4259      ;;;      | 4|------>| 5|------> ... | 8|------>| 1|------>| 2|------>| 3|#f|
4260      ;;;      +--+--+    +--+--+         +--+--+    +--+--+    +--+--+    +--+--+
4261      ;;;       ^                                     ^
4262      ;;;       x                                     y
4263      (let ([x (cons 1 (cons 2 (cons 3 (cons 4 (cons 5 (cons 6 (cons 7 (cons 8 '()))))))))])
4264        (letrec ([rotate
4265                   (lambda (n)
4266                     (if (not (<= n 0))
4267                       (let ([s x])
4268                         (set! x (cdr x))
4269                         (insert s x)
4270                         (rotate (- n 1)))))]
4271                 [insert
4272                   (lambda (s x)
4273                     (if (null? (cdr x))
4274                         (begin
4275                           (set-cdr! x s)
4276                           (set-cdr! s '()))
4277                         (insert s (cdr x))))])
4278          (let ([y x])
4279            (rotate 3) ; rotate x and chop y as a side effect
4280            (cons x (cons y '()))))) ; cons for comparison
4281
4282      ;;; Albert Hartono
4283      (letrec [(length 6)
4284               (start-value 6)]
4285        ((lambda (v lst)
4286           (letrec [(length (lambda (x)
4287                              (if (null? x)
4288                                  0
4289                                  (add1 (length (cdr x))))))]
4290             (let [(ls-lg (length lst))
4291                   (v-lg (vector-length v))]
4292               (let [(new-vec (make-vector (+ ls-lg v-lg)))]
4293                 (letrec [(loop-vec
4294                           (lambda (index)
4295                             (if (= index v-lg)
4296                                 (loop-ls lst index)
4297                                 (begin
4298                                   (vector-set! new-vec index (vector-ref v index))
4299                                   (loop-vec (add1 index))))))
4300                          (loop-ls
4301                           (lambda (lst index)
4302                             (if (not (null? lst))
4303                                 (begin
4304                                   (vector-set! new-vec index (car lst))
4305                                   (loop-ls (cdr lst) (add1 index))))))]
4306                   (loop-vec 0)
4307                   new-vec)))))
4308         (let [(vec (letrec ([tmp-vec (lambda () (make-vector length))]
4309                             [fill-vector
4310                              (lambda (v lg val)
4311                                (if (zero? lg)
4312                                    v
4313                                    (begin
4314                                      (vector-set! v (sub1 lg) val)
4315                                      (fill-vector v (sub1 lg) (add1 val)))))])
4316                      (fill-vector (tmp-vec) (vector-length (tmp-vec))
4317                                   (- 0 start-value))))]
4318           vec)
4319         (letrec [(make-list (lambda (lg val)
4320                               (if (not (zero? lg))
4321                                   (cons val (make-list (sub1 lg) (sub1 val)))
4322                                   '())))]
4323           (make-list length start-value))))
4324
4325      ;;; Brooke Chenoweth
4326      ;;; a little Ackermann, just for fun
4327      ;;; if you uncomment this, you should probably make most of the passes
4328      ;;; trusted, unless you want to wait a long time for it to complete. - rkd
4329      #;(let ([x 3] [y 6])
4330        (letrec ([A (lambda (x y)
4331                      (if (= x 0)
4332                          (add1 y)
4333                          (if (= y 0)
4334                              (A (sub1 x) 1)
4335                              (A (sub1 x) (A x (sub1 y))))))])
4336          (A x y)))
4337
4338      ;;; let's try out a more substantial program
4339      ;;; the N queens problem, for several values of n
4340      ;;; solve-n-queens gives a list of the row indices for a valid queen placement, or #f if no solution
4341      (let ([n-vals '(1 2 3 4 5 6 7 8)])
4342        (letrec ([solve-n-queens
4343                   (lambda (n)
4344                     (letrec ([extend-board
4345                                (lambda (i b)
4346                                  (if (= i n)
4347                                      (let ([b (adjust b)])
4348                                        (if b (extend-board 0 b) #f))
4349                                      (if (valid? i b)
4350                                          (cons i b)
4351                                          (extend-board (+ i 1) b))))]
4352                              [valid?
4353                                (lambda (i b)
4354                                    (no-threat? (sub1 i) i (add1 i) b))]
4355                              [no-threat?
4356                                (lambda (u s d others)
4357                                  (if (null? others)
4358                                      #t
4359                                      (if (not (let ([neighbor (car others)])
4360                                                  (if (= neighbor u)
4361                                                      #t
4362                                                      (if (= neighbor s)
4363                                                          #t
4364                                                          (= neighbor d)))))
4365                                          (no-threat? (- u 1) s (+ d 1) (cdr others))
4366                                          #f)))]
4367                              [adjust
4368                                (lambda (b)
4369                                  (if b
4370                                      (if (not (null? b))
4371                                          (extend-board (add1 (car b)) (cdr b))
4372                                          #f)
4373                                      #f))]
4374                              [solve
4375                                (lambda (len b)
4376                                  (if (= n len)
4377                                      b
4378                                      (solve (add1 len) (extend-board 0 b))))])
4379                       (solve 0 '())))])
4380          (letrec ([test
4381                     (lambda (ls)
4382                       (if (null? ls)
4383                           '()
4384                           (let ([n (car ls)])
4385                             (cons (solve-n-queens n)
4386                               (test (cdr ls))))))])
4387            (test n-vals))))
4388
4389      ;;; Ronald Garcia
4390      (let ([re-apply
4391             (lambda (high)
4392               (letrec ([gen
4393                         (lambda (iter cont)
4394                           (let ([cont1 (lambda (f val) (cont f (f val)))]
4395                                 [cont2 (lambda (f val) (cont f val))])
4396                             (if (= iter 0)
4397                                 cont2
4398                                 (gen (- iter 1) cont1))))])
4399                 (gen high (lambda (f val) val))))])
4400        ((re-apply 10) (lambda (x) (+ x 1)) 5 ))
4401
4402      (let ([make-list
4403             (lambda (count)
4404               (letrec ([loop
4405                         (lambda (val counter max)
4406                           (if (= counter max)
4407                               val
4408                               (loop (cons counter val) (+ counter 1) max)))])
4409                 (loop '() 0 count)))])
4410        (make-list 12))
4411
4412      ;;; Jeremiah Willcock
4413      ;;; This test stresses two parts of the compiler: variable renaming and
4414      ;;; register allocation.  It stresses the variable renaming mechanism by
4415      ;;; using locally-bound names that match special forms in the compiler.  It
4416      ;;; stresses register allocation by having a large number of variables (and
4417      ;;; most of them are referenced).  The actual code of the program is mostly a
4418      ;;; factorial function, but with many helper lambdas to deal with the lack of
4419      ;;; if.  The list of set! statements had formerly set all variables up to z,
4420      ;;; but the list was trimmed so that it would compile using the compiler on
4421      ;;; the course Web page.  The list of cons expressions at the bottom could
4422      ;;; also be extended to z.  This program also has deeply nested expressions
4423      ;;; that will be simplified by remove-complex-opera*.  It also contains a not
4424      ;;; expression in order to test the compiler's handling of this expression
4425      ;;; type, as well as a one-armed if expression and an implicit begin.
4426      (let ([ef (lambda (x y z)
4427                  (let ([result z]) (if x (set! result y)) result))]
4428            [a 1] [b 2] [c 3] [d 4] [e 5] [f 6] [g 7] [h 8] [i 9]
4429            [j 10] [k 11] [l 12] [m 13] [n 14] [o 15] [p 16] [q 17] [r 18]
4430            [s 19] [t 20] [u 21] [v 22] [w 23] [x 24] [y 25] [z 26])
4431        (set! a 0)
4432        (set! b 0)
4433        (set! c 0)
4434        (set! d 0)
4435        (set! e 0)
4436        (set! f 0)
4437        (set! g 0)
4438        (set! h 0)
4439        (set! i 0)
4440        (set! j 0)
4441        (set! k 0)
4442        (set! l 0)
4443        (set! m 0)
4444        (set! n 0)
4445        (set! o 0)
4446        (set! p 0)
4447        (letrec ([let 5]
4448                 [letrec (lambda (x y) (set! let x) y)]
4449                 [fac (lambda (n) ((ef (not (zero? n)) (f2 n) f1)))]
4450                 [f1 (lambda () 1)]
4451                 [f2
4452                  ((lambda (f3) (lambda (n) (lambda () (* n (f3 n)))))
4453                   (lambda (n) (fac (- n 1))))]
4454                 [f3 (lambda (x) -1)]
4455                 [if (lambda (x) (lambda () (+ 1 x)))])
4456          ((lambda (lambda)
4457             (cons lambda
4458                   (cons (fac let)
4459                         (cons a (cons b (cons c (cons d (cons e (cons f
4460                           (cons g (cons h (cons i (cons j (cons k (cons l
4461                             (cons m (cons n (cons o '()))))))))))))))))))
4462           (letrec ([if 7]) ((if let))))))
4463
4464      ;; This test uses streams of integers (similar to those studied in CSCI B521
4465      ;; and B621) to produce a list of integers that are not multiples of two and
4466      ;; five.  It also has a heavy use of lambdas within the streams.  This test
4467      ;; case will test closure conversion, most of its lambdas have references to
4468      ;; free variables.  This program is purely functional, so it is much less of
4469      ;; a test of assignment conversion and begin handling than the last program.
4470      (letrec ([integers (lambda (n) (cons n (lambda () (integers (+ n 1)))))]
4471               [stream-times (lambda (s n)
4472                 (cons (* (car s) n)
4473                  (lambda () (stream-times ((cdr s)) n))))]
4474               [difference (lambda (s1 s2)
4475                 (if (if (null? s1) #t (null? s2)) '()
4476                  (if (< (car s1) (car s2))
4477                   (cons (car s1) (lambda () (difference ((cdr s1)) s2)))
4478                   (if (= (car s1) (car s2))
4479                    (difference ((cdr s1)) ((cdr s2)))
4480                    (difference s1 ((cdr s2)))))))]
4481               [stream-head (lambda (s n)
4482                 (if (if (null? s) #t (zero? n)) '()
4483                  (cons (car s)
4484                   (if (= n 1) '() (stream-head ((cdr s)) (- n 1))))))])
4485        (stream-head
4486         (difference
4487          (difference (integers 0) (stream-times (integers 0) 2))
4488          (stream-times (integers 0) 5))
4489         20))
4490
4491      ;;; Mark Meiss
4492      ;;; Test out identifier defintions, scope of letrec, the poor man's
4493      ;;; Y-combinator, and higher-order procedures.
4494      (letrec ([odd  (lambda (lambda odd)
4495                        ((odd (lambda))))]
4496                [even (lambda (letrec lambda)
4497                        (((((lambda letrec))))))])
4498         (letrec ([uf (lambda (x y z) (if (x) y z))]
4499                  [af (lambda (x y z) ((if x y z)))])
4500           (letrec ([make-sub (lambda (sub)
4501                                (lambda (n) (- n sub)))]
4502                    [odd (lambda (odd even)
4503                           (lambda (n)
4504                             ((uf (lambda () (zero? n))
4505                                  (lambda () #f)
4506                                  (lambda () ((even even odd) ((make-sub 1) n)))))))]
4507                    [even (lambda (even odd)
4508                            (lambda (n)
4509                              (af (zero? n)
4510                                  (lambda () #t)
4511                                  (lambda () ((odd odd even) ((make-sub 1) n))))))])
4512             ((even even odd) 12))))
4513
4514
4515      ;;; Test out higher-order procedures and a mixture of tail and non-tail
4516      ;;; calls by playing around with a representation of Church numerals.
4517      (letrec ([zero (lambda (f)
4518                        (lambda (x) x))]
4519                [succ (lambda (n)
4520                        (lambda (f)
4521                          (lambda (x) (f ((n f) x)))))]
4522                [zero? (lambda (n)
4523                         ((n (lambda (x) #f)) #t))])
4524         (letrec ([to-int (lambda (n)
4525                            ((n (lambda (a) (+ a 1))) 0))]
4526                  [from-int (lambda (n)
4527                              (if (= n 0) zero (succ (from-int (- n 1)))))])
4528           (letrec ([add (lambda (n)
4529                           (lambda (m) ((n succ) m)))])
4530             (- (+ 5 4)
4531                (to-int ((add (from-int 5)) (from-int 4)))))))
4532
4533      ;;; Matthew Garrett
4534      ;;; Bubble Sort on a list of numbers
4535      ;;; A recursive function defined inside a recursive function, both with the
4536      ;;; same name.
4537      (letrec ([list-length   (lambda (ls)
4538                                (letrec ([loop (lambda (ls n)
4539                                                 (if (null? ls)
4540                                                     n
4541                                                     (loop (cdr ls) (+ n 1))))])
4542                                  (loop ls 0)))]
4543               [sorted?       (lambda (lon)
4544                                (if (<= (list-length lon) 1)
4545                                    #t
4546                                    (if (< (car lon) (car (cdr lon)))
4547                                        (sorted? (cdr lon))
4548                                        #f)))]
4549               [bubble-sort   (lambda (lon)
4550                                  (if (sorted? lon)
4551                                      lon
4552                                      (bubble-sort (cdr
4553        ; cdr is necessary because of the "hold" place keeper, in this inner
4554        ; bubble-sort, which is guaranteed to get first place in this lesser to
4555        ; greater sorting.
4556        (letrec ([bubble-sort (lambda (hold list-of-numbers)
4557                                (if (null? list-of-numbers)
4558                                    (cons hold '())
4559                                    (if (< hold (car list-of-numbers))
4560                                        (cons hold
4561                                          (bubble-sort
4562                                            (car list-of-numbers)
4563                                            (cdr list-of-numbers)))
4564                                        (cons (car list-of-numbers)
4565                                          (bubble-sort hold
4566                                            (cdr list-of-numbers))))))])
4567          (bubble-sort 0 lon))))))])
4568        (bubble-sort '(5 6 4 3 8 7))))
4569    '((2 3 3 4 5 6 6 9) (2 3 3 4 5 6 6 9)
4570       ((4 5 6 7 8 1 2 3) (1 2 3))
4571       #12(-1 -2 -3 -4 -5 -6 6 5 4 3 2 1)
4572       ((0) #f #f (2 0 3 1) (3 1 4 2 0) (4 2 0 5 3 1)
4573            (5 3 1 6 4 2 0) (3 1 6 2 5 7 4 0))
4574       15 (11 10 9 8 7 6 5 4 3 2 1 0)
4575       (6 40320 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
4576       (1 3 7 9 11 13 17 19 21 23 27 29 31 33 37 39 41 43 47 49)
4577       #t 0 (3 4 5 6 7 8)))
4578)
4579
4580(mat constant-closures
4581  ; make sure that closure optimization doesn't replicate closures
4582  (let ([f (rec f (lambda (q) f))])
4583    (and
4584      (eq? f (f 3))
4585      (eq? ((f 3) 4) (f 3))))
4586  (begin
4587    (with-output-to-file "testfile-cc.ss"
4588      (lambda ()
4589        (pretty-print
4590          '(define $cc-foo (rec f (lambda (q) f)))))
4591      'replace)
4592    (compile-file "testfile-cc")
4593    (load "testfile-cc.so")
4594    #t)
4595  (eq? ($cc-foo 3) $cc-foo)
4596  (eq? (($cc-foo 3) 4) $cc-foo)
4597)
4598
4599(mat simplify-if
4600  (eqv?
4601    (let ([x 'a] [y 'b])
4602      (and (fixnum? x) (fixnum? (car y))))
4603    #f)
4604  (eqv?
4605    (let ([x 'a] [y 'b])
4606      (and (fixnum? x) (fixnum? (car y)) 75))
4607    #f)
4608  (error? ; not a port
4609    (let ([x 'a])
4610      (and (textual-port? x) (input-port? x))))
4611  (not
4612    (let ([x 'a])
4613      (and (input-port? x) (textual-port? x))))
4614  (let ([x (current-input-port)])
4615    (and (input-port? x) (textual-port? x)))
4616  (equal?
4617    (let ()
4618      (define (? x) (and (input-port? x) (if (textual-port? x) #t (binary-port? x))))
4619      (define-syntax first-value
4620        (syntax-rules ()
4621          [(_ e) (let-values ([(x . r) e]) x)]))
4622      (list
4623        (? 'a)
4624        (? (open-string-input-port ""))
4625        (? (first-value (open-string-output-port)))
4626        (? (open-bytevector-input-port #vu8()))
4627        (? (first-value (open-bytevector-output-port)))))
4628    '(#f #t #f #t #f))
4629)
4630
4631(mat virtual-registers
4632  (fixnum? (virtual-register-count))
4633  (fx>= (virtual-register-count) 0)
4634  (error? ; invalid index
4635    (virtual-register 'one))
4636  (error? ; invalid index
4637    (virtual-register -1))
4638  (error? ; invalid index
4639    (virtual-register (+ (most-positive-fixnum) 1)))
4640  (error? ; invalid index
4641    (virtual-register 0.0))
4642  (error? ; invalid index
4643    (set-virtual-register! 'one 19))
4644  (error? ; invalid index
4645    (set-virtual-register! -1 19))
4646  (error? ; invalid index
4647    (set-virtual-register! (+ (most-positive-fixnum) 1) 19))
4648  (error? ; invalid index
4649    (set-virtual-register! 0.0 19))
4650  (fx>= (virtual-register-count) 4)
4651  (eqv? (set-virtual-register! 3 'hello) (void))
4652  (eqv? (virtual-register 3) 'hello)
4653  (eqv?
4654    (let ([x 3]) (virtual-register x))
4655    'hello)
4656  (eqv?
4657    (let ([x 3] [y (cons 1 2)])
4658      (set-virtual-register! x (list y)))
4659    (void))
4660  (equal? (virtual-register 3) '((1 . 2)))
4661  (equal?
4662    (let ()
4663      (define g (make-guardian))
4664      (g (virtual-register 3))
4665      (collect)
4666      (list (virtual-register 3) (g)))
4667    '(((1 . 2)) #f))
4668)
4669
4670(mat pariah
4671  (error? ; invalid syntax
4672    (pariah))
4673  (error? ; invalid syntax
4674    (pariah . 17))
4675  (equal?
4676    (list (pariah 17))
4677    '(17))
4678  (equal?
4679    (let f ([n 10])
4680      (if (fx= n 0)
4681          (pariah 1)
4682          (* n (f (fx- n 1)))))
4683    3628800)
4684  ; make sure that cp0 doesn't remove the pariah form
4685  (equivalent-expansion?
4686    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
4687      (expand/optimize
4688        '(if (zero? (random 1000))
4689             (pariah (display 0))
4690             (display 1))))
4691    (if (= (optimize-level) 3)
4692        '(if (#3%zero? (#3%random 1000))
4693             (begin (pariah (void)) (#3%display 0))
4694             (#3%display 1))
4695        '(if (#3%zero? (#2%random 1000))
4696             (begin (pariah (void)) (#2%display 0))
4697             (#2%display 1))))
4698)
4699
4700(unless (memq (machine-type) '(arm32le tarm32le arm64le tarm64le arm64osx tarm64osx ; timestamp counter tends to be priviledged on Arm
4701                                       pb)) ; doesn't increment for pb
4702  (mat $read-time-stamp-counter
4703
4704    (let ([t (#%$read-time-stamp-counter)])
4705      (and (integer? t) (exact? t)))
4706
4707    (let ()
4708      ;; NB: pulled from thread.ms, to use as a delay
4709      (define fat+
4710        (lambda (x y)
4711          (if (zero? y)
4712              x
4713              (fat+ (1+ x) (1- y)))))
4714      (define fatfib
4715        (lambda (x)
4716          (if (< x 2)
4717              1
4718              (fat+ (fatfib (1- x)) (fatfib (1- (1- x)))))))
4719      (let loop ([count 10] [success 0])
4720        (if (fx= count 0)
4721            (>= success 9)
4722            (let ([t0 (#%$read-time-stamp-counter)])
4723              (fatfib 26)
4724              (let ([t1 (#%$read-time-stamp-counter)])
4725                (loop (fx- count 1)
4726                      (if (< t0 t1)
4727                          (fx+ success 1)
4728                          success)))))))
4729    ))
4730
4731(mat procedure-arity-mask
4732  (equal? (procedure-arity-mask (lambda () #f)) 1)
4733  (equal? (procedure-arity-mask (lambda (x) x)) 2)
4734  (equal? (procedure-arity-mask (lambda (x y z w) x)) 16)
4735  (equal? (procedure-arity-mask (interpret '(lambda (x y z w) x))) 16)
4736  (or (eq? (current-eval) interpret)
4737      (equal? (procedure-arity-mask (lambda (x y z w a b c d e f g h i j) x)) (ash 1 14)))
4738  (or (eq? (current-eval) interpret)
4739      (equal? (procedure-arity-mask (interpret '(lambda (x y z w a b c d e f g h i j) x))) (ash 1 14)))
4740  (or (eq? (current-eval) interpret)
4741      (and
4742        (equal? (procedure-arity-mask (case-lambda)) 0)
4743        (equal? (procedure-arity-mask (case-lambda [(x) x] [(x y) y])) 6)
4744        (equal? (procedure-arity-mask (case-lambda [() x] [(x . y) y])) -1)
4745        (equal? (procedure-arity-mask (case-lambda [() x] [(x y . z) y])) (bitwise-not 2))
4746        (equal? (procedure-arity-mask (case-lambda [(x y . z) y] [() x])) (bitwise-not 2))
4747        (equal? (procedure-arity-mask (case-lambda [(x) x] [(x y) y] [(x y z) z])) 14)))
4748  (equal? (procedure-arity-mask list) -1)
4749  (equal? (procedure-arity-mask cons) 4)
4750  (equal? (procedure-arity-mask list*) (bitwise-not 1))
4751
4752  (equal? (procedure-arity-mask +) -1)
4753  (equal? (procedure-arity-mask -) -2)
4754  (equal? (procedure-arity-mask max) -2)
4755
4756  (equal? (call/cc procedure-arity-mask) -1)
4757  (equal? (call/1cc procedure-arity-mask) -1)
4758  (equal? (procedure-arity-mask #%$null-continuation) 0)
4759  (equal?
4760    (parameterize ([enable-cp0 #t]) (compile '(procedure-arity-mask
4761                                                (case-lambda [a a] [(b) b]))))
4762    -1)
4763  (equal?
4764    (parameterize ([enable-cp0 #f]) (compile '(procedure-arity-mask
4765                                                (case-lambda [a a] [(b) b]))))
4766    -1)
4767
4768  (error? ; invalid argument
4769    (procedure-arity-mask 17))
4770  )
4771
4772
4773(mat procedure-name
4774  (begin
4775    (define (procedure-name f)
4776      (((inspect/object f) 'code) 'name))
4777    (define (ok-name? name expect)
4778      (or (equal? name expect)
4779          ;; interpreter currently doesn't keep names
4780          (eq? (current-eval) interpret)))
4781    (define should-be-named-f (let ([f (lambda (x) x)]) f))
4782    (define should-be-named-g (letrec ([g (lambda (x) x)]) g))
4783    (define should-be-named-h (let ([f (let ([h (lambda (x) x)]) h)]) f))
4784    (define should-be-named-i (letrec ([f (let ([i (lambda (x) x)]) i)]) f))
4785    (define should-be-named-j (let ([f (letrec ([j (lambda (x) x)]) j)]) f))
4786    (define (result-should-be-named-mk-CP)
4787      (let ([struct:CP (make-record-type-descriptor* 'CP #f #f #f #f 1 1)])
4788        (let ([mk-CP (record-constructor (make-record-constructor-descriptor
4789                                          struct:CP #f #f))])
4790          mk-CP)))
4791    #t)
4792  (ok-name? (procedure-name procedure-name) "procedure-name")
4793  (ok-name? (procedure-name should-be-named-f) "f")
4794  (ok-name? (procedure-name should-be-named-g) "g")
4795  (ok-name? (procedure-name should-be-named-h) "h")
4796  (ok-name? (procedure-name should-be-named-i) "i")
4797  (ok-name? (procedure-name should-be-named-j) "j")
4798
4799  (or (not (enable-cp0))
4800      (#%$suppress-primitive-inlining)
4801      (let ([gx (make-guardian)])
4802        (ok-name? (procedure-name gx) "gx")))
4803  (or (not (enable-cp0))
4804      (#%$suppress-primitive-inlining)
4805      (ok-name? (procedure-name (result-should-be-named-mk-CP)) "mk-CP"))
4806
4807  (or (not (enable-cp0))
4808      (andmap ok-name?
4809              (map
4810               procedure-name
4811               (let ([f (lambda (g)
4812                          (g (lambda (x) x)))])
4813                 (list (f (lambda (a) a))
4814                       (f (lambda (b) b)))))
4815              '("a" "b")))
4816  )
4817
4818
4819(mat wrapper-procedure
4820  (error? (make-wrapper-procedure))
4821  (error? (make-wrapper-procedure (lambda args args)))
4822  (error? (make-wrapper-procedure (lambda args args) 1))
4823  (error? (make-wrapper-procedure 1 1 #f))
4824  (error? (make-wrapper-procedure 'not-a-procedure 1 #f))
4825  (error? (make-wrapper-procedure (lambda args args) 'not-an-exact-integer #f))
4826  (error? (make-wrapper-procedure (lambda args args) 1.0 #f))
4827
4828  (error? (make-arity-wrapper-procedure))
4829  (error? (make-arity-wrapper-procedure (lambda args args)))
4830  (error? (make-arity-wrapper-procedure (lambda args args) 1))
4831  (error? (make-arity-wrapper-procedure 1 1 #f))
4832  (error? (make-arity-wrapper-procedure 'not-a-procedure 1 #f))
4833  (error? (make-arity-wrapper-procedure (lambda args args) 'not-an-exact-integer #f))
4834  (error? (make-arity-wrapper-procedure (lambda args args) 1.0 #f))
4835
4836  (equal? ((make-wrapper-procedure (lambda args args) 8 #f) 1 2 3)
4837          '(1 2 3))
4838  (equal? ((make-wrapper-procedure (lambda args args) 1 #f) 1 2 3) ; arity not checked!
4839          '(1 2 3))
4840  (equal? ((make-wrapper-procedure (lambda args args) (expt 2 100) #f) 1 2 3) ; arity not checked!
4841          '(1 2 3))
4842
4843  (equal? ((make-arity-wrapper-procedure (lambda args args) 8 #f) 1 2 3)
4844          '(1 2 3))
4845  (equal? ((make-arity-wrapper-procedure (lambda args args) (+ (expt 2 100) 8) #f) 1 2 3)
4846          '(1 2 3))
4847  (error? ((make-arity-wrapper-procedure (lambda args args) 1 #f) 1 2 3))
4848  (error? ((make-arity-wrapper-procedure (lambda args args) (expt 2 100) #f) 1 2 3))
4849  (equal? (make-list 100 'ok) (apply (make-arity-wrapper-procedure (lambda args args) -1 #f) (make-list 100 'ok)))
4850
4851  (equal? (procedure-arity-mask (make-wrapper-procedure (lambda args args) 1 #f))
4852          1)
4853  (equal? (procedure-arity-mask (make-wrapper-procedure (lambda args args) -12345 #f))
4854          -12345)
4855  (equal? (procedure-arity-mask (make-wrapper-procedure (lambda args args) (expt 2 100) #f))
4856          (expt 2 100))
4857
4858  (equal? (procedure-arity-mask (make-arity-wrapper-procedure (lambda args args) 1 #f))
4859          1)
4860  (equal? (procedure-arity-mask (make-arity-wrapper-procedure (lambda args args) -12345 #f))
4861          -12345)
4862  (equal? (procedure-arity-mask (make-arity-wrapper-procedure (lambda args args) (expt 2 100) #f))
4863          (expt 2 100))
4864
4865  (not (wrapper-procedure? 10))
4866  (not (wrapper-procedure? (lambda args args)))
4867  (not (wrapper-procedure? (interpret '(lambda args args))))
4868  (wrapper-procedure? (make-wrapper-procedure (lambda args args) 1 #f))
4869  (wrapper-procedure? (make-arity-wrapper-procedure (lambda args args) 1 #f))
4870
4871  (error? (wrapper-procedure-data 1))
4872  (error? (wrapper-procedure-data (lambda args args)))
4873  (error? (wrapper-procedure-data (interpret '(lambda args args))))
4874  (equal? (wrapper-procedure-data (make-wrapper-procedure (lambda args args) 1 'data))
4875          'data)
4876  (equal? (wrapper-procedure-data (make-arity-wrapper-procedure (lambda args args) 1 'data))
4877          'data)
4878
4879  (error? (set-wrapper-procedure!))
4880  (error? (set-wrapper-procedure! (make-arity-wrapper-procedure (lambda args args) 1 #f)))
4881  (error? (set-wrapper-procedure! 1 void))
4882  (error? (set-wrapper-procedure! (lambda args args) void))
4883  (error? (set-wrapper-procedure! (interpret '(lambda args args)) void))
4884  (let ([p (make-wrapper-procedure (lambda args args) 8 #f)])
4885    (set-wrapper-procedure! p vector)
4886    (equal? (p 1 2 3)
4887            '#(1 2 3)))
4888  (let ([p (make-arity-wrapper-procedure (lambda args args) 8 #f)])
4889    (set-wrapper-procedure! p vector)
4890    (equal? (p 1 2 3)
4891            '#(1 2 3)))
4892
4893  (error? (set-wrapper-procedure-data!))
4894  (error? (set-wrapper-procedure-data! (make-arity-wrapper-procedure (lambda args args) 1 #f)))
4895  (error? (set-wrapper-procedure-data! 1 #t))
4896  (error? (set-wrapper-procedure-data! (lambda args args) #t))
4897  (error? (set-wrapper-procedure-data! (interpret '(lambda args args)) #t))
4898  (let ([p (make-wrapper-procedure (lambda args args) 8 'data)])
4899    (set-wrapper-procedure-data! p 'other-data)
4900    (equal? (wrapper-procedure-data p)
4901            'other-data))
4902  (let ([p (make-arity-wrapper-procedure (lambda args args) 8 'data)])
4903    (set-wrapper-procedure-data! p 'other-data)
4904    (equal? (wrapper-procedure-data p)
4905            'other-data))
4906
4907  (let ([a (make-wrapper-procedure (lambda args args) 8 #f)])
4908    (lock-object a)
4909    (collect)
4910    (let ([g (gensym)])
4911      (set-wrapper-procedure-data! a g)
4912      (collect)
4913      (and
4914       (equal? (wrapper-procedure-data a) g)
4915       (begin (unlock-object a) #t))))
4916  (let ([a (make-arity-wrapper-procedure (lambda args args) 8 #f)])
4917    (lock-object a)
4918    (collect)
4919    (let ([g (gensym)])
4920      (set-wrapper-procedure-data! a g)
4921      (collect)
4922      (and
4923       (equal? (wrapper-procedure-data a) g)
4924       (begin (unlock-object a) #t))))
4925  )
4926
4927(mat fasl-immutable
4928  (begin
4929    (define immutable-objs (list (vector->immutable-vector '#(1 2 3))
4930                                 (string->immutable-string "abc")
4931                                 (bytevector->immutable-bytevector #vu8(1 2 3))
4932                                 (box-immutable 1)
4933                                 ;; Not immutable, but we want to test strip:
4934                                 (fxvector 1 2 3)
4935                                 (flvector 1.5 2.5 3.5)
4936                                 (stencil-vector 6 'a 'b)))
4937    (define immutable-zero-objs (list (vector->immutable-vector '#())
4938                                      (string->immutable-string "")
4939                                      (bytevector->immutable-bytevector #vu8())
4940                                      (box-immutable 1)))
4941    (define (immutable? l)
4942      (and (immutable-vector? (list-ref l 0))
4943           (immutable-string? (list-ref l 1))
4944           (immutable-bytevector? (list-ref l 2))
4945           (immutable-box? (list-ref l 3))))
4946    (define (round-trip l)
4947      (let-values ([(o get) (open-bytevector-output-port)])
4948        (fasl-write l o)
4949        (immutable? (fasl-read (open-bytevector-input-port (get))))))
4950    (define (round-trip-via-strip l)
4951      (compile-to-file (list `(set! fasl-immutable-round-trip ',l)) "testfile-immut-sff.so")
4952      (strip-fasl-file "testfile-immut-sff.so" "testfile-immut-sff.so" (fasl-strip-options))
4953      (load "testfile-immut-sff.so")
4954      (let ([l2 (eval 'fasl-immutable-round-trip)])
4955        (and (equal? l l2)
4956             (immutable? l2))))
4957    (define (round-trip-symbol sym)
4958      (let-values ([(o get) (open-bytevector-output-port)])
4959        (fasl-write sym o)
4960        (let ([s (fasl-read (open-bytevector-input-port (get)))])
4961          (and (symbol? s)
4962               (immutable-string? (symbol->string s))
4963               (or (not (gensym? s))
4964                   (immutable-string? (gensym->unique-string s)))))))
4965    #t)
4966
4967  (immutable? immutable-objs)
4968  (immutable? immutable-zero-objs)
4969  (round-trip immutable-objs)
4970  (round-trip immutable-zero-objs)
4971  (round-trip-via-strip immutable-objs)
4972  (round-trip-via-strip immutable-zero-objs)
4973
4974  (round-trip-symbol 'hello)
4975  (round-trip-symbol (string->symbol "hola"))
4976  (round-trip-symbol (gensym "bonjour"))
4977
4978  ;; Make sure `fasl-read` didn't mark "mutable" null values
4979  ;; as immutable:
4980  (mutable-vector? '#())
4981  (mutable-string? "")
4982  (mutable-bytevector? '#vu8())
4983
4984 )
4985
4986(mat show-allocation
4987  (begin
4988    (#%$show-allocation #t)
4989    #t)
4990)
4991
4992(mat current-generate-id
4993  (begin
4994    (define (make-x-generator)
4995      (let ([x-uid "gf91a5b83ujz3mogjdaij7-x"]
4996            [counter-ht (make-eq-hashtable)])
4997        (lambda (sym)
4998          (let* ([n (eq-hashtable-ref counter-ht sym 0)]
4999                 [str (if (gensym? sym) (gensym->unique-string sym) (symbol->string sym))]
5000                 [g (gensym (symbol->string sym) (format "~a-~a-~a" x-uid str n))])
5001            (eq-hashtable-set! counter-ht sym (+ n 1))
5002            g))))
5003    (and (parameterize ([current-generate-id (make-x-generator)])
5004           (eval `(module consistent-x (x make-pt pt-r)
5005                    ;; Note: `module` doesn't currently enable `x` to be inlined
5006                    (define x 1)
5007                    (define-record-type pt (fields r i)))))
5008         #t))
5009  (begin
5010    (define return-x (let ()
5011                       (import consistent-x)
5012                       (lambda () x)))
5013    (define a-pt (let ()
5014                   (import consistent-x)
5015                   (make-pt -1 -2)))
5016    (define get-r (let ()
5017                    (import consistent-x)
5018                    (lambda (p) (pt-r p))))
5019    (equal? 1 (return-x)))
5020  (equal? -1 (get-r a-pt))
5021  (begin
5022    (parameterize ([current-generate-id (make-x-generator)])
5023      (eval `(module consistent-x (x make-pt pt-x)
5024               (define x 2)
5025               (define-record-type pt (fields x y)))))
5026    (equal? 2 (return-x)))
5027  (equal? -1 (get-r a-pt))
5028  (begin
5029    (parameterize ([current-generate-id (make-x-generator)])
5030      (eval `(module consistent-x (x)
5031               (define x 3)
5032               (define-syntax def (syntax-rules () [(_) (define x 'other)]))
5033               ;; `(def)` after above definition => expect that
5034               ;; its `x` is generated second
5035               (def))))
5036    (equal? 3 (return-x)))
5037)
5038
5039(mat expand-omit-library-invocations
5040  (not (expand-omit-library-invocations))
5041  (begin
5042    (library (define-m-as-one) (export m) (import (chezscheme)) (define m 1))
5043    (define (find-define-m-as-one s)
5044      (or (eq? s 'define-m-as-one)
5045          (and (pair? s)
5046                (or (find-define-m-as-one (car s))
5047                        (find-define-m-as-one (cdr s))))))
5048    #t)
5049  (find-define-m-as-one (expand '(let () (import (define-m-as-one)) m)))
5050  (begin
5051    (expand-omit-library-invocations 'yes)
5052    (eq? #t (expand-omit-library-invocations)))
5053  (not (find-define-m-as-one (expand '(let () (import (define-m-as-one)) m))))
5054  (begin
5055    (expand-omit-library-invocations #f)
5056    (not (expand-omit-library-invocations)))
5057  (find-define-m-as-one (expand '(let () (import (define-m-as-one)) m)))
5058)
5059
5060(mat enable-unsafe-application
5061  (begin
5062   (define (get-uncprep-form e)
5063     (let ([r #f])
5064       (parameterize ([run-cp0 (lambda (cp0 e)
5065                                 (parameterize ([enable-unsafe-application #f])
5066                                   (set! r (#%$uncprep e)))
5067                                 e)])
5068         (expand/optimize e))
5069       r))
5070   #t)
5071  (equivalent-expansion? (get-uncprep-form '(lambda (x) (x)))
5072                         '(lambda (x) (x)))
5073  (equivalent-expansion? (parameterize ([enable-unsafe-application #t])
5074                           (get-uncprep-form '(lambda (x) (x))))
5075                         (if (= 3 (optimize-level))
5076                             '(lambda (x) (x))
5077                             '(lambda (x) (#3%$app x))))
5078  )
5079
5080(mat enable-unsafe-variable-reference
5081  (begin
5082   (define (get-uncprep-form e)
5083     (let ([r #f])
5084       (parameterize ([run-cp0 (lambda (cp0 e)
5085                                 (set! r (#%$uncprep e))
5086                                 e)])
5087         (expand/optimize e))
5088       r))
5089   #t)
5090  (equivalent-expansion? (parameterize ([#%$suppress-primitive-inlining #f])
5091                           (get-uncprep-form '(lambda (x) (letrec ([y y]) (+ y x)))))
5092                         (if (= 3 (optimize-level))
5093                             '(lambda (x)
5094                                (letrec ([y y])
5095                                  (#3%+ y x)))
5096                             '(lambda (x)
5097                                (let ([valid? #f])
5098                                  (letrec ([y (begin
5099                                                (if valid?
5100                                                    (#2%void)
5101                                                    (#2%$source-violation #f #f #t "attempt to reference undefined variable ~s" 'y))
5102                                                y)])
5103                                    (set! valid?  #t)
5104                                    (#2%+ y x))))))
5105  (equivalent-expansion? (parameterize ([enable-unsafe-variable-reference #t]
5106                                        [#%$suppress-primitive-inlining #f])
5107                           (get-uncprep-form '(lambda (x) (letrec ([y y]) (+ y x)))))
5108                         (if (= 3 (optimize-level))
5109                             '(lambda (x)
5110                                (letrec ([y y])
5111                                  (#3%+ y x)))
5112                             '(lambda (x)
5113                                (letrec ([y y])
5114                                  (#2%+ y x)))))
5115  )
5116
5117(mat phantom-bytevector
5118  (phantom-bytevector? (make-phantom-bytevector 0))
5119  (not (phantom-bytevector? 10))
5120  (not (phantom-bytevector? (vector 1 2 3)))
5121
5122  (error? (make-phantom-bytevector -1))
5123  (error? (make-phantom-bytevector (expt 2 100)))
5124  (error? (make-phantom-bytevector 'x))
5125
5126  (begin
5127    (define $ph (make-phantom-bytevector 0))
5128    (phantom-bytevector? $ph))
5129  (eqv? 0 (phantom-bytevector-length $ph))
5130  (eqv? (void) (set-phantom-bytevector-length! $ph 1))
5131  (eqv? 1 (phantom-bytevector-length $ph))
5132  (eqv? (void) (set-phantom-bytevector-length! $ph 100))
5133  (eqv? 100 (phantom-bytevector-length $ph))
5134
5135  (begin
5136    (collect (collect-maximum-generation))
5137    (define $pre-allocated (bytes-allocated))
5138    (define $pre-memory (current-memory-bytes))
5139    (set-phantom-bytevector-length! $ph $pre-allocated)
5140    #t)
5141
5142  ;; Big change to `(bytes-allocated)`
5143  (< (* 1.75 $pre-allocated)
5144     (bytes-allocated)
5145     (* 2.25 $pre-allocated))
5146
5147  ;; Big change to `(current-memory-bytes)`
5148  (< (+ (* 0.75 $pre-allocated)
5149        $pre-memory)
5150     (current-memory-bytes)
5151     (+ (* 1.25 $pre-memory)
5152        $pre-memory))
5153
5154  ;; Same change after GC
5155  (begin
5156    (collect (collect-maximum-generation))
5157    (< (* 1.75 $pre-allocated)
5158       (bytes-allocated)
5159       (* 2.25 $pre-allocated)))
5160
5161  ;; fasl => another jump by `$pre-allocated` bytes
5162  (begin
5163    (define $ph2
5164      (let-values ([(o get) (open-bytevector-output-port)])
5165        (fasl-write $ph o)
5166        (fasl-read (open-bytevector-input-port (get)))))
5167    (phantom-bytevector? $ph2))
5168
5169  (< (* 2.75 $pre-allocated)
5170     (bytes-allocated)
5171     (* 3.25 $pre-allocated))
5172
5173  ;; Try GC again
5174  (begin
5175    (collect (collect-maximum-generation))
5176    (< (* 2.75 $pre-allocated)
5177       (bytes-allocated)
5178       (* 3.25 $pre-allocated)))
5179
5180  ;; Let GC reclaim $ph2, and `(byte-allocated)` should go down
5181  (begin
5182    (set! $ph2 #f)
5183    (collect (collect-maximum-generation))
5184    (< (* 1.75 $pre-allocated)
5185       (bytes-allocated)
5186       (* 2.25 $pre-allocated)))
5187
5188  (> (compute-size $ph) (phantom-bytevector-length $ph))
5189
5190  ;; Change length of `$ph`, and `(byte-allocated)` should go down
5191  (begin
5192    (set-phantom-bytevector-length! $ph 0)
5193    (< (* 0.75 $pre-allocated)
5194       (bytes-allocated)
5195       (* 1.25 $pre-allocated)))
5196  )
5197
5198(mat immobile
5199  (error? (box-immobile))
5200  (error? (box-immobile 1 2))
5201
5202  (error? (make-immobile-vector))
5203  (error? (make-immobile-vector 'a))
5204  (error? (make-immobile-vector -10))
5205  (error? (make-immobile-vector (expt 2 100)))
5206  (error? (make-immobile-vector 10 1 2))
5207
5208  (error? (make-immobile-bytevector))
5209  (error? (make-immobile-bytevector 'a))
5210  (error? (make-immobile-byte-vector -10))
5211  (error? (make-immobile-bytevector (expt 2 100)))
5212  (error? (make-immobile-bytevector 10 1024))
5213  (error? (make-immobile-bytevector 10 1 2))
5214
5215  (box? (box-immobile 10))
5216  (vector? (make-immobile-vector 10))
5217  (eqv? 0 (vector-ref (make-immobile-vector 10) 9))
5218  (bytevector? (make-immobile-bytevector 10))
5219  (eqv? 0 (bytevector-u8-ref (make-immobile-bytevector 10 0) 9))
5220
5221  (begin
5222    (define (make-objects)
5223      (let loop ([i 16])
5224        (cond
5225          [(zero? i) '()]
5226          [else
5227           (let* ([b (box-immobile (format "box ~a" i))]
5228                  [b-addr (#%$fxaddress b)]
5229                  [v (make-immobile-vector (expt 2 i) b)]
5230                  [v-addr (#%$fxaddress v)]
5231                  [s (make-immobile-bytevector (expt 2 i) i)]
5232                  [s-addr (#%$fxaddress s)])
5233             (cons (list i
5234                         b b-addr
5235                         v v-addr
5236                         s s-addr)
5237                   (loop (sub1 i))))])))
5238    (define (check-objects l)
5239      (let loop ([l l])
5240        (or (null? l)
5241            (let-values ([(i b b-addr v v-addr s s-addr) (apply values (car l))])
5242              (and (equal? (format "box ~a" i) (unbox b))
5243                   (equal? (format "box ~a" i) (unbox (vector-ref v (sub1 (vector-length v)))))
5244                   (eqv? i (bytevector-u8-ref s (sub1 (bytevector-length s))))
5245                   (eqv? b-addr (#%$fxaddress b))
5246                   (eqv? v-addr (#%$fxaddress v))
5247                   (eqv? s-addr (#%$fxaddress s))
5248                   (loop (cdr l)))))))
5249    (define (mutate-objects l)
5250      (let loop ([l l])
5251        (or (null? l)
5252            (let-values ([(i b b-addr v v-addr s s-addr) (apply values (car l))])
5253              (set-box! b (format "box ~a" i))
5254              (vector-set! v (sub1 (vector-length v)) (box (unbox b)))
5255              (loop (cdr l))))))
5256    #t)
5257
5258  (with-interrupts-disabled
5259   (let ([objs (make-objects)])
5260     (and (check-objects objs)
5261          (begin
5262            (collect 0 1)
5263            (and
5264             (check-objects objs)
5265             (begin
5266               (mutate-objects objs)
5267               (collect 0 0)
5268               (and
5269                (check-objects objs)
5270                (begin
5271                  (collect (collect-maximum-generation))
5272                  (check-objects objs)))))))))
5273
5274  (or
5275   (not (threaded?))
5276   (let ([m (make-mutex)]
5277         [c (make-condition)]
5278         [running 4])
5279     (let thread-loop ([t running])
5280       (unless (= t 0)
5281         (fork-thread
5282          (lambda ()
5283            (let loop ([i 1000] [objs '()] [addrs '()])
5284              (cond
5285                [(= i 0)
5286                 (mutex-acquire m)
5287                 (set! running (sub1 running))
5288                 (condition-signal c)
5289                 (mutex-release m)]
5290                [else
5291                 (let ([v (case (modulo i 3)
5292                            [(0) (box-immobile objs)]
5293                            [(1) (make-immobile-vector i objs)]
5294                            [(2) (make-immobile-bytevector i)])])
5295                   (let ([objs (cons v objs)]
5296                         [addrs (cons (#%$fxaddress v) addrs)])
5297                     (collect-rendezvous)
5298                     (let check ([objs objs] [addrs addrs])
5299                       (unless (null? objs)
5300                         (let ([v (car objs)])
5301                           (unless (= (#%$fxaddress v) (car addrs))
5302                             (error 'immobile "address changed: ~s" v))
5303                           (cond
5304                             [(box? v)
5305                              (unless (eq? (unbox v) (cdr objs))
5306                                (error 'immobile "bad box content"))]
5307                             [(vector? v)
5308                              (let loop ([j 0])
5309                                (unless (= j (vector-length v))
5310                                  (unless (eq? (cdr objs) (vector-ref v j))
5311                                    (error 'immobile "bad vector content"))
5312                                  (loop (add1 j))))]
5313                             [(bytevector? v)
5314                              (void)]
5315                             [else
5316                              (error 'immobile "bad object: ~s" v)]))
5317                         (check (cdr objs) (cdr addrs))))
5318                     (loop (sub1 i) objs addrs)))]))))
5319         (thread-loop (sub1 t))))
5320     (mutex-acquire m)
5321     (let loop ()
5322       (unless (= running 0)
5323         (condition-wait c m)
5324         (loop)))
5325     (mutex-release m)
5326     ;; Wait for threads to exit
5327     (let ()
5328       (define $threads (foreign-procedure "(cs)threads" () scheme-object))
5329       (let loop ()
5330         (unless (= 1 (length ($threads)))
5331           (sleep (make-time 'time-duration 10000 0))
5332           (loop))))
5333     #t))
5334
5335  )
5336
5337(mat compacting
5338  ;; try to provoke the GC into putting a record into marked
5339  ;; (instead of copied) space and check the write barrier there
5340  (let loop ([N 2])
5341    (or (= N 8192)
5342        (let sel-loop ([sels (list car cadr)])
5343          (cond
5344            [(null? sels) (loop (* N 2))]
5345            [else
5346             (let ()
5347               (define rtd (make-record-type
5348                            "r"
5349                            (let loop ([i N])
5350                              (if (zero? i)
5351                                  (list '[ptr y])
5352                                  (cons `[uptr ,(string->symbol (format "x~a" i))]
5353                                        (loop (sub1 i)))))))
5354
5355               (define (make-r)
5356                 (apply (record-constructor rtd)
5357                        (let loop ([i N])
5358                          (if (zero? i)
5359                              '(the-y-value)
5360                              (cons 0 (loop (sub1 i)))))))
5361
5362               (define r-y (record-accessor rtd N))
5363               (define set-r-y! (record-mutator rtd N))
5364
5365               (define rs (list (make-r)
5366                                (make-r)
5367                                (make-r)))
5368               (collect (collect-maximum-generation))
5369               (set! rs (list (car rs) (caddr rs)))
5370               (collect (collect-maximum-generation))
5371               (set-r-y! ((car sels) rs) (string-copy "new-string-to-go"))
5372               (collect)
5373               (and (equal? (r-y ((car sels) rs))
5374                            "new-string-to-go")
5375                    (sel-loop (cdr sels))))]))))
5376  )
5377