Commit | Line | Data |
---|---|---|
c2247b78 | 1 | #!/bin/sh |
1d8b3259 | 2 | guild compile "$0" |
c2247b78 AW |
3 | exec guile -q -s "$0" "$@" |
4 | !# | |
5 | ||
6 | (unless (defined? 'setrlimit) | |
7 | ;; Without an rlimit, this test can take down your system, as it | |
8 | ;; consumes all of your memory. That doesn't seem like something we | |
9 | ;; should run as part of an automated test suite. | |
10 | (exit 0)) | |
11 | ||
12 | (catch #t | |
13 | ;; Silence GC warnings. | |
14 | (lambda () | |
15 | (current-warning-port (open-output-file "/dev/null"))) | |
16 | (lambda (k . args) | |
17 | (print-exception (current-error-port) #f k args) | |
18 | (write "Skipping test.\n" (current-error-port)) | |
19 | (exit 0))) | |
20 | ||
56f79491 AW |
21 | ;; 50 MB. |
22 | (define *limit* (* 50 1024 1024)) | |
c2247b78 AW |
23 | |
24 | (call-with-values (lambda () (getrlimit 'as)) | |
25 | (lambda (soft hard) | |
26 | (unless (and soft (< soft *limit*)) | |
27 | (setrlimit 'as (if hard (min *limit* hard) *limit*) hard)))) | |
28 | ||
29 | (define (test thunk) | |
30 | (catch 'out-of-memory | |
31 | (lambda () | |
32 | (thunk) | |
33 | (error "should not be reached")) | |
34 | (lambda _ | |
35 | #t))) | |
36 | ||
37 | (use-modules (rnrs bytevectors)) | |
38 | ||
39 | (test (lambda () | |
56f79491 AW |
40 | ;; Unhappily, on 32-bit systems, vectors are limited to 16M |
41 | ;; elements. Boo. Anyway, a vector with 16M elements takes 64 | |
42 | ;; MB, which doesn't fit into 50 MB. | |
43 | (make-vector (1- (ash 1 24))))) | |
c2247b78 AW |
44 | (test (lambda () |
45 | ;; Likewise for a bytevector. This is different from the above, | |
46 | ;; as the elements of a bytevector are not traced by GC. | |
47 | (make-bytevector #e1e9))) | |
48 | (test (lambda () | |
49 | ;; This one is the kicker -- we allocate pairs until the heap | |
50 | ;; can't expand. This is the hardest test to deal with because | |
51 | ;; the error-handling machinery has no memory in which to work. | |
52 | (iota #e1e8))) | |
53 | (test (lambda () | |
54 | ;; The same, but also causing allocating during the unwind | |
55 | ;; (ouch!) | |
56 | (dynamic-wind | |
57 | (lambda () #t) | |
58 | (lambda () (iota #e1e8)) | |
59 | (lambda () (iota #e1e8))))) | |
60 | ||
61 | ;; Local Variables: | |
62 | ;; mode: scheme | |
63 | ;; End: |