1;;;; library-tests.scm
2
3(import chicken.blob chicken.bitwise chicken.fixnum chicken.flonum
4	chicken.keyword chicken.port chicken.condition)
5
6(define-syntax assert-fail
7  (syntax-rules ()
8    ((_ exp)
9     (assert (handle-exceptions ex #t exp #f)))))
10
11(define (list-tabulate n proc)
12  (let loop ((i 0))
13    (if (fx>= i n)
14	'()
15	(cons (proc i) (loop (fx+ i 1))))))
16
17(define (every pred lst)
18  (let loop ((lst lst))
19    (cond ((null? lst))
20	  ((not (pred (car lst))) #f)
21	  (else (loop (cdr lst))))))
22
23;; numbers
24
25(assert (not (not 3)))
26(assert (= -4.0 (round -4.3)))
27(assert (= -4.0 (round -4.5)))          ; R5RS
28(assert (= 4.0 (round 3.5)))
29(assert (= 4.0 (round 4.5)))            ; R5RS
30(assert (= 4 (round (string->number "7/2"))))
31(assert (= 7 (round 7)))
32(assert (zero? (round -0.5))) 		; is actually -0.0
33(assert (zero? (round -0.3)))
34(assert (= -1 (round -0.6)))
35(assert (zero? (round 0.5)))
36(assert (zero? (round 0.3)))
37(assert (= 1.0 (round 0.6)))
38(assert (rational? 1))
39(assert (finite? 1))
40(assert-fail (finite? 'foo))
41(assert (rational? 1.0))
42(assert (finite? 1.0))
43(assert (not (rational? +inf.0)))
44(assert (not (finite? +inf.0)))
45(assert (not (rational? -inf.0)))
46(assert (not (finite? -inf.0)))
47(assert (not (rational? +nan.0)))
48(assert (not (finite? +nan.0)))
49(assert (not (rational? 'foo)))
50(assert (not (rational? "foo")))
51(assert (integer? 2))
52(assert (integer? 2.0))
53(assert (not (integer? 1.1)))
54(assert (not (integer? +inf.0)))
55(assert (not (integer? -inf.0)))
56(assert (not (integer? +nan.0)))
57(assert (not (integer? 'foo)))
58(assert (not (integer? "foo")))
59; XXX number missing
60
61;; Negative vs positive zero (see #1627)
62(assert (not (eqv? 0.0 -0.0)))
63(assert (not (equal? 0.0 -0.0)))
64(assert (= 0.0 -0.0))
65
66(assert (not (positive? 0.0)))
67(assert (not (negative? 0.0)))
68(assert (zero? 0.0))
69
70(assert (not (positive? -0.0)))
71(assert (not (negative? -0.0)))
72(assert (zero? -0.0))
73
74;; Exactness
75(assert (exact? 1))
76(assert (not (exact? 1.0)))
77(assert (not (exact? 1.1)))
78(assert-fail (exact? 'foo))
79(assert (not (inexact? 1)))
80(assert (inexact? 1.0))
81(assert (inexact? 1.1))
82(assert-fail (inexact? 'foo))
83
84;; Division by inexact zero used to fail, but now it returns +inf.0
85(assert-fail (/ 1 1 0))
86(assert (eqv? +inf.0 (/ 1 1 0.0)))
87(assert (eqv? +inf.0 (/ 1 0.0)))
88(assert-fail (/ 1 0))
89(assert-fail (/ 0))
90(assert (eqv? +inf.0 (/ 0.0)))
91
92(assert (fixnum? (/ 1)))
93
94(assert (= -3 (- 3)))
95(assert (= 3 (- -3)))
96(assert (= 2 (- 5 3)))
97(assert (> 1 (/ 3)))
98(assert (> 1 (/ 3.0)))
99(assert (= 2 (/ 8 4)))
100(assert (zero? (+)))
101(assert (= 1 (*)))
102
103(assert (= 2.5 (/ 5 2)))
104
105;; Use equal? instead of = to check equality and exactness in one go
106(assert (equal? 0 (numerator 0)))
107(assert (equal? 1 (denominator 0)))
108(assert (equal? 3 (numerator 3)))
109(assert (equal? 1 (denominator 3)))
110(assert (equal? -3 (numerator -3)))
111(assert (equal? 1 (denominator -3)))
112(assert (equal? 1.0 (numerator 0.5)))
113(assert (equal? 2.0 (denominator 0.5)))
114(assert (equal? 5.0 (numerator 1.25)))
115(assert (equal? 4.0 (denominator 1.25)))
116(assert (equal? -5.0 (numerator -1.25)))
117
118;;; A few denormalised numbers, cribbed from NetBSD ATF tests for ldexp():
119;; On some machines/OSes these tests fail due to missing hardware support
120;; and sometimes due to broken libc/libm support, so we have disabled them.
121;(assert (equal? 1.0 (numerator 1.1125369292536006915451e-308)))
122;(assert (equal? +inf.0 (denominator 1.1125369292536006915451e-308)))
123;(assert (equal? -1.0 (numerator -5.5626846462680034577256e-309)))
124;(assert (equal? +inf.0 (denominator -5.5626846462680034577256e-309)))
125;(assert (equal? 1.0 (numerator 4.9406564584124654417657e-324)))
126;(assert (equal? +inf.0 (denominator 4.9406564584124654417657e-324)))
127
128(assert (equal? 4.0 (denominator -1.25)))
129(assert (equal? 1e10 (numerator 1e10)))
130(assert (equal? 1.0 (denominator 1e10)))
131(assert-fail (numerator +inf.0))
132(assert-fail (numerator +nan.0))
133(assert-fail (denominator +inf.0))
134(assert-fail (denominator +nan.0))
135
136(assert (even? 2))
137(assert (even? 2.0))
138(assert (even? 0))
139(assert (even? 0.0))
140(assert (not (even? 3)))
141(assert (not (even? 3.0)))
142(assert (odd? 1))
143(assert (odd? 1.0))
144(assert (not (odd? 0)))
145(assert (not (odd? 0.0)))
146(assert (not (odd? 2)))
147(assert (not (odd? 2.0)))
148(assert-fail (even? 1.2))
149(assert-fail (odd? 1.2))
150(assert-fail (even? +inf.0))
151(assert-fail (odd? +inf.0))
152(assert-fail (even? +nan.0))
153(assert-fail (odd? +nan.0))
154(assert-fail (even? 'x))
155(assert-fail (odd? 'x))
156
157(assert (= 60 (arithmetic-shift 15 2)))
158(assert (= 3 (arithmetic-shift 15 -2)))
159(assert (= -60 (arithmetic-shift -15 2)))
160(assert (= -4 (arithmetic-shift -15 -2))) ; 2's complement
161(assert-fail (arithmetic-shift 0.1 2))
162;; XXX Do the following two need to fail?  Might as well use the integral value
163(assert-fail (arithmetic-shift #xf 2.0))
164(assert-fail (arithmetic-shift #xf -2.0))
165(assert-fail (arithmetic-shift #xf 2.1))
166(assert-fail (arithmetic-shift #xf -2.1))
167(assert-fail (arithmetic-shift +inf.0 2))
168(assert-fail (arithmetic-shift +nan.0 2))
169
170(assert (= 0 (gcd)))
171(assert (= 6 (gcd 6)))
172(assert (= 2 (gcd 6 8)))
173(assert (= 1 (gcd 6 8 5)))
174(assert (= 1 (gcd 6 -8 5)))
175(assert (= 2.0 (gcd 6.0 8.0)))
176(assert-fail (gcd 6.1 8.0))
177(assert-fail (gcd 6.0 8.1))
178(assert-fail (gcd +inf.0))
179(assert-fail (gcd +nan.0))
180(assert-fail (gcd 6.0 +inf.0))
181(assert-fail (gcd +inf.0 6.0))
182(assert-fail (gcd +nan.0 6.0))
183(assert-fail (gcd 6.0 +nan.0))
184
185(assert (= 1 (lcm)))
186(assert (= 6 (lcm 6)))
187(assert (= 24 (lcm 6 8)))
188(assert (= 120 (lcm 6 8 5)))
189(assert (= 24.0 (lcm 6.0 8.0)))
190(assert-fail (lcm +inf.0))
191(assert-fail (lcm +nan.0))
192(assert-fail (lcm 6.1 8.0))
193(assert-fail (lcm 6.0 8.1))
194(assert-fail (lcm 6.0 +inf.0))
195(assert-fail (lcm +inf.0 6.0))
196(assert-fail (lcm +nan.0 6.0))
197(assert-fail (lcm 6.0 +nan.0))
198
199(assert (= 3 (quotient 13 4)))
200(assert (= 3.0 (quotient 13.0 4.0)))
201(assert-fail (quotient 13.0 4.1))
202(assert-fail (quotient 13.2 4.0))
203(assert-fail (quotient +inf.0 4.0))
204(assert-fail (quotient +nan.0 4.0))
205(assert-fail (quotient 4.0 +inf.0))
206(assert-fail (quotient 4.0 +nan.0))
207
208(assert (= 1 (remainder 13 4)))
209(assert (= 1.0 (remainder 13.0 4.0)))
210(assert-fail (remainder 13.0 4.1))
211(assert-fail (remainder 13.2 4.0))
212(assert-fail (remainder +inf.0 4.0))
213(assert-fail (remainder +nan.0 4.0))
214(assert-fail (remainder 4.0 +inf.0))
215(assert-fail (remainder 4.0 +nan.0))
216
217(assert (= 1 (modulo 13 4)))
218(assert (= 1.0 (modulo 13.0 4.0)))
219(assert-fail (modulo 13.0 4.1))
220(assert-fail (modulo 13.2 4.0))
221(assert-fail (modulo +inf.0 4.0))
222(assert-fail (modulo +nan.0 4.0))
223(assert-fail (modulo 4.0 +inf.0))
224(assert-fail (modulo 4.0 +nan.0))
225
226(assert-fail (min 'x))
227(assert-fail (max 'x))
228(assert (eq? 1 (min 1 2)))
229(assert (eq? 1 (min 2 1)))
230(assert (eq? 2 (max 1 2)))
231(assert (eq? 2 (max 2 1)))
232;; must be flonum
233(assert (fp= 1.0 (min 1 2.0)))
234(assert (fp= 1.0 (min 2.0 1)))
235(assert (fp= 2.0 (max 2 1.0)))
236(assert (fp= 2.0 (max 1.0 2)))
237
238;; number->string conversion
239
240(for-each
241 (lambda (x)
242   (let ((number (car x))
243	 (radix (cadr x)))
244     (assert (eqv? number (string->number (number->string number radix) radix)))))
245 '((123 10)
246   (123 2)
247   (123 8)
248   (-123 10)
249   (-123 2)
250   (-123 8)
251   (99.2 10)
252   (-99.2 10)))
253
254;; by Christian Kellermann
255(assert
256 (equal?
257  (map (lambda (n) (number->string 32 n)) (list-tabulate 15 (cut + 2 <>)))
258  '("100000" "1012" "200" "112" "52" "44" "40" "35" "32" "2a" "28" "26" "24" "22" "20")))
259
260;; #1422
261(assert (equal? (map + '(1 2 3) '(1 2)) '(2 4)))
262(assert (equal? (map + '(1 2) '(1 2 3)) '(2 4)))
263(let ((result '()))
264  (for-each (lambda (x y) (set! result (cons (+ x y) result)))
265            '(1 2) '(1 2 3))
266  (assert (equal? result '(4 2))))
267(let ((result '()))
268  (for-each (lambda (x y) (set! result (cons (+ x y) result)))
269            '(1 2 3) '(1 2))
270  (assert (equal? result '(4 2))))
271
272;; string->number conversion
273
274(assert (= 255 (string->number "ff" 16)))
275(assert (not (string->number "fg" 16)))
276
277
278;; fp-math
279
280(define (inexact= a b)
281  (< (abs (- 1 (abs (/ a b)))) 1e-10))
282
283(assert (inexact= (sin 42.0) (fpsin 42.0)))
284(assert (inexact= (cos 42.0) (fpcos 42.0)))
285(assert (inexact= (tan 42.0) (fptan 42.0)))
286(assert (inexact= (asin 0.5) (fpasin 0.5)))
287(assert (inexact= (acos 0.5) (fpacos 0.5)))
288(assert (inexact= (atan 0.5) (fpatan 0.5)))
289(assert (inexact= (atan 42.0 1.2) (fpatan2 42.0 1.2)))
290(assert (inexact= (atan 42.0 1) (fpatan2 42.0 1.0)))
291(assert (inexact= (atan 42 1.0) (fpatan2 42.0 1.0)))
292(assert (inexact= (exp 42.0) (fpexp 42.0)))
293(assert (inexact= (log 42.0) (fplog 42.0)))
294(assert (inexact= (expt 42.0 3.5) (fpexpt 42.0 3.5)))
295(assert (inexact= (sqrt 42.0) (fpsqrt 42.0)))
296(assert (inexact= 43.0 (fpround 42.5)))
297(assert (inexact= -43.0 (fpround -42.5)))
298(assert (inexact= 42.0 (fpround 42.2)))
299(assert (inexact= 42.0 (fptruncate 42.5)))
300(assert (inexact= -42.0 (fptruncate -42.5)))
301(assert (inexact= 42.0 (fpfloor 42.2)))
302(assert (inexact= -43.0 (fpfloor -42.5)))
303(assert (inexact= 43.0 (fpceiling 42.5)))
304(assert (inexact= -42.0 (fpceiling -42.2)))
305(assert (not (fpinteger? 2.3)))
306(assert (fpinteger? 1.0))
307
308;; string->symbol
309
310;; by Jim Ursetto
311(assert
312 (eq? '|3|
313      (with-input-from-string
314	  (with-output-to-string
315	    (lambda ()
316	      (write (string->symbol "3"))))
317	read)))
318
319;;; escaped symbol syntax
320
321(assert (string=? "abc" (symbol->string '|abc|)))
322(assert (string=? "abcdef" (symbol->string '|abc||def|)))
323(assert (string=? "abcxyzdef" (symbol->string '|abc|xyz|def|)))
324(assert (string=? "abc|def" (symbol->string '|abc\|def|)))
325(assert (string=? "abc|def" (symbol->string '|abc\|def|)))
326(assert (string=? "abc" (symbol->string 'abc)))
327(assert (string=? "a c" (symbol->string 'a\ c)))
328(assert (string=? "aBc" (symbol->string 'aBc)))
329
330(parameterize ((case-sensitive #f))
331  (assert (string=? "abc" (symbol->string (with-input-from-string "aBc" read))))
332  (assert (string=? "aBc" (symbol->string (with-input-from-string "|aBc|" read))))
333  (assert (string=? "aBc" (symbol->string (with-input-from-string "a\\Bc" read)))))
334
335(parameterize ((symbol-escape #f))
336  (assert (string=? "aBc" (symbol->string (with-input-from-string "aBc" read))))
337  (assert-fail (with-input-from-string "|aBc|" read))
338  (assert-fail (with-input-from-string "a|Bc" read)))
339(parameterize ((symbol-escape #t))
340  (assert (string=? "aBc" (symbol->string (with-input-from-string "aBc" read))))
341  (assert (string=? "aBc" (symbol->string (with-input-from-string "|aBc|" read))))
342  (assert (string=? "aB c" (symbol->string (with-input-from-string "|aB c|" read))))
343  ;; The following is an extension/generalisation of r7RS
344  (assert (string=? "aBc" (symbol->string (with-input-from-string "a|Bc|" read))))
345  ;; "Unterminated string" (unterminated identifier?)
346  (assert-fail (with-input-from-string "a|Bc" read)))
347
348;;; Old style qualified low byte, see #1077
349
350(assert (string=? "##foo#bar" (symbol->string '|##foo#bar|)))
351(assert (string=? "##foo#bar" (symbol->string '##foo#bar)))
352(assert (eq? '##foo#bar '|##foo#bar|))
353
354(assert (string=? "|\\x0a|" (with-output-to-string (lambda () (write '|\n|)))))
355;; #1576
356(assert (string=? "|\\x00foo|" (with-output-to-string (lambda () (write '|\000foo|)))))
357(assert (not (keyword? '|\000foo|)))
358(assert (string=? "|###foo#bar|" (with-output-to-string (lambda () (write '|###foo#bar|)))))
359
360;;; Paren synonyms
361
362(parameterize ((parentheses-synonyms #f))
363  (assert (eq? '() (with-input-from-string "()" read)))
364  (assert-fail (with-input-from-string "[]" read))
365  (assert-fail (with-input-from-string "{}" read)))
366(parameterize ((parentheses-synonyms #t))
367  (assert (eq? '() (with-input-from-string "()" read)))
368  (assert (eq? '() (with-input-from-string "[]" read)))
369  (assert (eq? '() (with-input-from-string "{}" read))))
370
371;;; keywords
372
373(parameterize ((keyword-style #:suffix))
374  (assert (string=? "abc:" (symbol->string (with-input-from-string "|abc:|" read))))
375  (assert (string=? "abc" (keyword->string (with-input-from-string "|abc|:" read)))) ; keyword
376  (let ((kw (with-input-from-string "|foo bar|:" read))
377	(sym1 (with-input-from-string "|foo:|" read))
378	(sym2 (with-input-from-string "|:foo|" read)))
379
380    (assert (symbol? sym1))
381    (assert (not (keyword? sym1)))
382
383    (assert (symbol? sym2))
384    (assert (not (keyword? sym2)))
385
386    (assert (keyword? kw))
387    (assert (not (symbol? kw)))
388
389    (assert (eq? kw (with-input-from-string "#:|foo bar|" read)))
390    (assert (string=? "foo bar" (keyword->string kw)))
391    (assert (string=? "foo:" (symbol->string sym1)))
392    (assert (string=? ":foo" (symbol->string sym2)))
393
394    (assert (string=? "foo bar:"
395		      (with-output-to-string (lambda () (display kw)))))
396    (assert (string=? "#:|foo bar|"
397		      (with-output-to-string (lambda () (write kw)))))
398
399    (assert (string=? "|foo:|"
400		      (with-output-to-string (lambda () (write sym1)))))
401    ;; Regardless of keyword style, symbols must be quoted to avoid
402    ;; issues when reading it back with a different keyword style.
403    (assert (string=? "|:foo|"
404		      (with-output-to-string (lambda () (write sym2)))))))
405
406(parameterize ((keyword-style #:prefix))
407  (assert (string=? "abc" (keyword->string (with-input-from-string ":|abc|" read))))
408  (assert (string=? ":abc" (symbol->string (with-input-from-string "|:abc|" read))))
409  (let ((kw (with-input-from-string ":|foo bar|" read))
410	(sym1 (with-input-from-string "|:foo|" read))
411	(sym2 (with-input-from-string "|foo:|" read)))
412
413    (assert (symbol? sym1))
414    (assert (not (keyword? sym1)))
415
416    (assert (symbol? sym2))
417    (assert (not (keyword? sym2)))
418
419    (assert (keyword? kw))
420    (assert (not (symbol? kw)))
421
422    (assert (eq? kw (with-input-from-string "#:|foo bar|" read)))
423    (assert (string=? "foo bar" (keyword->string kw)))
424    (assert (string=? ":foo" (symbol->string sym1)))
425    (assert (string=? "foo:" (symbol->string sym2)))
426
427    (assert (string=? ":foo bar"
428		      (with-output-to-string (lambda () (display kw)))))
429    (assert (string=? "#:|foo bar|"
430		      (with-output-to-string (lambda () (write kw)))))
431
432    (assert (string=? "|:foo|"
433		      (with-output-to-string (lambda () (write sym1)))))
434    ;; Regardless of keyword style, symbols must be quoted to avoid
435    ;; issues when reading it back with a different keyword style.
436    (assert (string=? "|foo:|"
437		      (with-output-to-string (lambda () (write sym2)))))))
438
439(parameterize ((keyword-style #:none))
440  (let ((kw (with-input-from-string "#:|foo bar|" read))
441	(sym1 (with-input-from-string "|:foo|" read))
442	(sym2 (with-input-from-string "|foo:|" read)))
443
444    (assert (symbol? sym1))
445    (assert (not (keyword? sym1)))
446
447    (assert (symbol? sym2))
448    (assert (not (keyword? sym2)))
449
450    (assert (keyword? kw))
451    (assert (not (symbol? kw)))
452
453    (assert (eq? kw (string->keyword "foo bar"))
454    (assert (string=? "foo bar" (keyword->string kw)))
455    (assert (string=? ":foo" (symbol->string sym1)))
456    (assert (string=? "foo:" (symbol->string sym2)))
457
458    (assert (string=? ":foo"
459		      (with-output-to-string (lambda () (display kw)))))
460    (assert (string=? "#:|foo bar|"
461		      (with-output-to-string (lambda () (write kw)))))
462
463    ;; Regardless of keyword style, symbols must be quoted to avoid
464    ;; issues when reading it back with a different keyword style.
465    (assert (string=? "|:foo|"
466		      (with-output-to-string (lambda () (write sym1)))))
467    (assert (string=? "|foo:|"
468		      (with-output-to-string (lambda () (write sym2))))))))
469
470(assert (eq? '|#:| (string->symbol "#:")))
471(assert-fail (with-input-from-string "#:" read)) ; empty keyword
472(assert (eq? '|#:| (with-input-from-string (with-output-to-string (cut write '|#:|)) read)))
473
474(parameterize ((keyword-style #:suffix))
475  (assert (keyword? (with-input-from-string "abc:" read)))
476  (assert (keyword? (with-input-from-string "|abc|:" read)))
477  (assert (keyword? (with-input-from-string "a|bc|d:" read)))
478  (assert (not (keyword? (with-input-from-string "abc:||" read))))
479  (assert (not (keyword? (with-input-from-string "abc\\:" read))))
480  (assert (not (keyword? (with-input-from-string "abc|:|" read))))
481  (assert (not (keyword? (with-input-from-string "|abc:|" read)))))
482
483(parameterize ((keyword-style #:prefix))
484  (assert (keyword? (with-input-from-string ":abc" read)))
485  (assert (keyword? (with-input-from-string ":|abc|" read)))
486  (assert (keyword? (with-input-from-string ":a|bc|d" read)))
487  (assert (not (keyword? (with-input-from-string "||:abc" read))))
488  (assert (not (keyword? (with-input-from-string "\\:abc" read))))
489  (assert (not (keyword? (with-input-from-string "|:|abc" read))))
490  (assert (not (keyword? (with-input-from-string "|:abc|" read)))))
491
492(parameterize ((keyword-style #f))
493  (assert (not (keyword? (with-input-from-string ":||" read))))
494  (assert (not (keyword? (with-input-from-string "||:" read))))
495  (assert (not (keyword? (with-input-from-string ":abc" read))))
496  (assert (not (keyword? (with-input-from-string ":abc:" read))))
497  (assert (not (keyword? (with-input-from-string "abc:" read)))))
498
499(parameterize ((keyword-style #:suffix))
500  (let ((colon-sym (with-input-from-string ":" read)))
501    (assert (symbol? colon-sym))
502    (assert (not (keyword? colon-sym)))
503    (assert (string=? ":" (symbol->string colon-sym)))))
504
505(parameterize ((keyword-style #:prefix))
506  (let ((colon-sym (with-input-from-string ":" read)))
507    (assert (symbol? colon-sym))
508    (assert (not (keyword? colon-sym)))
509    (assert (string=? ":" (symbol->string colon-sym)))))
510
511;; The next two cases are a bit dubious, but we follow SRFI-88 (see
512;; also #1625).
513(parameterize ((keyword-style #:suffix))
514  (let ((colon-sym (with-input-from-string ":||" read)))
515    (assert (symbol? colon-sym))
516    (assert (not (keyword? colon-sym)))
517    (assert (string=? ":" (symbol->string colon-sym))))
518
519  (let ((empty-kw (with-input-from-string "||:" read)))
520    (assert (not (symbol? empty-kw)))
521    (assert (keyword? empty-kw))
522    (assert (string=? "" (keyword->string empty-kw)))))
523
524(parameterize ((keyword-style #:prefix))
525  (let ((empty-kw (with-input-from-string ":||" read)))
526    (assert (not (symbol? empty-kw)))
527    (assert (keyword? empty-kw))
528    (assert (string=? "" (keyword->string empty-kw))))
529
530  (let ((colon-sym (with-input-from-string "||:" read)))
531    (assert (symbol? colon-sym))
532    (assert (not (keyword? colon-sym)))
533    (assert (string=? ":" (symbol->string colon-sym)))))
534
535(assert-fail (with-input-from-string "#:" read))
536
537(let ((empty-kw (with-input-from-string "#:||" read)))
538  (assert (not (symbol? empty-kw)))
539  (assert (keyword? empty-kw))
540  (assert (string=? "" (keyword->string empty-kw))))
541
542;; TODO: It should eventually be possible to distinguish these (#1077)
543#;(let ((nul-sym (with-input-from-string "|\\x00|" read)))
544  (assert (not (keyword? nul-sym)))
545  (assert (string=? "\x00" (symbol->string nul-sym))))
546
547(assert (keyword? (with-input-from-string "42:" read)))
548(assert (keyword? (with-input-from-string ".:" read)))
549
550(assert (equal? (cons 1 2) (with-input-from-string "(1 . 2)" read)))
551(assert (every keyword? (with-input-from-string "(42: abc: .: #:: ::)" read)))
552
553;; symbols and keywords are now distinct
554(assert (not (symbol? #:foo)))
555(assert (not (symbol? (string->keyword "foo"))))
556(assert (not (keyword? 'foo)))
557(assert (not (keyword? (string->symbol "foo"))))
558
559;;; reading unterminated objects
560
561(assert-fail (with-input-from-string "(" read))
562(assert-fail (with-input-from-string "(1 . 2" read))
563(assert-fail (with-input-from-string "|" read))
564(assert-fail (with-input-from-string "\"" read))
565(assert-fail (with-input-from-string "#|" read))
566(assert-fail (with-input-from-string "#(" read))
567(assert-fail (with-input-from-string "#${" read))
568(assert-fail (with-input-from-string "\\" read))
569(assert-fail (with-input-from-string "|\\" read))
570(assert-fail (with-input-from-string "\"\\" read))
571
572;;; here documents
573
574(assert (string=? "" #<<A
575A
576))
577
578(assert (string=? "foo" #<<A
579foo
580A
581))
582
583(assert (string=? "\nfoo\n" #<<A
584
585foo
586
587A
588))
589
590(assert (string=? "foo\nbar\nbaz" #<<A
591foo
592bar
593baz
594A
595))
596
597;;; setters
598
599(define x '(a b c))
600(define kar car)
601(set! (kar (cdr x)) 99)
602(assert (equal? '(a 99 c) x))
603(define p (make-parameter 100))
604(assert (= 100 (p)))
605(set! (p) 1000)
606(assert (= 1000 (p)))
607
608
609;;; blob-literal syntax
610
611(assert (equal? '#${a} '#${0a}))
612(assert (equal? '#${ab cd} '#${abcd}))
613(assert (equal? '#${ab c} '#${ab0c}))
614(assert (equal? '#${abc} '#${ab0c}))
615(assert (equal? '#${a b c} '#${0a0b0c}))
616
617;; self-evaluating
618(assert (equal? '#${a} #${a}))
619(assert (equal? '#${abcd} #${abcd}))
620(assert (equal? '#${abc} #${abc}))
621
622
623;; #808: blobs and strings with embedded nul bytes should not be compared
624;; with ASCIIZ string comparison functions
625(assert (equal? '#${a b 0 c} '#${a b 0 c}))
626(assert (blob=? '#${a b 0 c} '#${a b 0 c}))
627(assert (equal=? "foo\x00a" "foo\x00a"))
628(assert (string=? "foo\x00a" "foo\x00a"))
629(assert (string-ci=? "foo\x00a" "foo\x00a"))
630(assert (string-ci=? "foo\x00a" "foo\x00A"))
631(assert (not (equal? '#${a b 0 c} '#${a b 0 d})))
632(assert (not (blob=? '#${a b 0 c} '#${a b 0 d})))
633(assert (not (equal=? "foo\x00a" "foo\x00b")))
634(assert (not (string=? "foo\x00a" "foo\x00b")))
635(assert (not (string-ci=? "foo\x00a" "foo\x00b")))
636(assert (string<? "foo\x00a" "foo\x00b"))
637(assert (string>? "foo\x00b" "foo\x00a"))
638(assert (string-ci<? "foo\x00a" "foo\x00B"))
639(assert (string-ci>? "foo\x00b" "foo\x00A"))
640
641;; reported by Nils Holm (#1534)
642;; https://groups.google.com/group/comp.lang.scheme/t/6b8be06b84b39a7
643(assert (not (string-ci<=? "test" "tes")))
644(assert (string-ci>=? "test" "tes"))
645
646
647;;; getter-with-setter
648
649(define foo
650  (let ((m 2))
651    (getter-with-setter
652     (lambda (x) (* x m))
653     (lambda (x)
654       (set! m x)))))
655
656(assert (= 6 (foo 3)))
657(set! (foo) 4)
658(assert (= 20 (foo 5)))
659
660(define bar
661  (getter-with-setter
662   foo
663   (lambda (x)
664     (+ x 99))))
665
666(assert (= 12 (bar 3)))
667(assert (= 100 (set! (bar) 1)))
668(assert (= 12 (foo 3)))
669
670
671;;; equal=?
672
673(assert (not (equal=? 1 2)))
674(assert (equal=? 1 1))
675(assert (equal=? 1 1.0))
676(assert (not (equal=? 1 1.2)))
677(assert (equal=? 1.0 1))
678(assert (equal=? '#(1) '#(1.0)))
679(assert (not (equal=? 'a "a")))
680(assert (equal=? "abc" "abc"))
681(assert (equal=? '(1 2.0 3) '(1 2 3)))
682(assert (equal=? '#(1 2.0 3) '#(1 2 3)))
683(assert (equal=? '#(1 2 (3)) '#(1 2 (3))))
684(assert (not (equal=? '#(1 2 (4)) '#(1 2 (3)))))
685(assert (not (equal=? 123 '(123))))
686
687;;; parameters
688
689(define guard-called 0)
690
691(define p
692  (make-parameter
693   1
694   (lambda (x)
695     (set! guard-called (+ guard-called 1))
696     x)))
697
698(define k
699  (parameterize ((p 2))
700    (call/cc
701     (lambda (k)
702       (assert (= 2 (p)))
703       k))))
704
705(and k (k #f))
706
707(assert (= 2 guard-called))
708
709;; Parameters are reset correctly (#1227, pointed out by Joo ChurlSoo)
710
711(let ((a (make-parameter 1 number->string))
712      (b (make-parameter 2 number->string)))
713  (assert (equal? (list "1" "2") (list (a) (b))))
714
715  (assert (equal? (list "10" "20")
716		  (parameterize ((a 10) (b 20)) (list (a) (b)))))
717
718  (assert (equal? (list "1" "2") (list (a) (b))))
719
720  (handle-exceptions exn #f (parameterize ((a 10) (b 'x)) (void)))
721
722  (assert (equal? (list "1" "2") (list (a) (b))))
723
724  (parameterize ((a 10) (b 30) (a 20))
725    (assert (equal? (list "20" "30") (list (a) (b)))))
726
727  (assert (equal? (list "1" "2") (list (a) (b)))) )
728
729;; Special-cased parameters are reset correctly (#1285, regression
730;; caused by fix for #1227)
731
732(let ((original-input (current-input-port))
733      (original-output (current-output-port))
734      (original-error (current-error-port))
735      (original-exception-handler (current-exception-handler)))
736  (call-with-output-string
737   (lambda (out)
738     (call-with-input-string
739      "foo"
740      (lambda (in)
741	(parameterize ((current-output-port out)
742		       (current-error-port out)
743		       (current-input-port in)
744		       (current-exception-handler list))
745	  (display "bar")
746	  (display "!" (current-error-port))
747	  (assert (equal? (read) 'foo))
748	  (assert (equal? (get-output-string out) "bar!"))
749	  (assert (equal? (signal 'baz) '(baz))))))))
750  (assert (equal? original-input (current-input-port)))
751  (assert (equal? original-output (current-output-port)))
752  (assert (equal? original-error (current-error-port)))
753  (assert (equal? original-exception-handler (current-exception-handler))))
754
755;; Re-entering dynamic extent of a parameterize should not reset to
756;; original outer values but remember values when jumping out (another
757;; regression due to #1227, pointed out by Joo ChurlSoo in #1336).
758
759(let ((f (make-parameter 'a))
760      (path '())
761      (g (make-parameter 'g))
762      (c #f))
763  (let ((add (lambda () (set! path (cons (f) path)))))
764    (add)
765    (parameterize ((f 'b)
766		   (g (call-with-current-continuation
767		       (lambda (c0) (set! c c0) 'c))))
768      (add) (f (g)) (add))
769    (f 'd)
770    (add)
771    (if (< (length path) 8)
772	(c 'e)
773	(assert (equal? '(a b c d b e d b e d) (reverse path))))))
774
775(let ((f (make-parameter 'a))
776      (path '())
777      (g (make-parameter 'g))
778      (c #f))
779  (let ((add (lambda () (set! path (cons (f) path)))))
780    (add)
781    (parameterize ((f 'b))
782      (g (call-with-current-continuation (lambda (c0) (set! c c0) 'c)))
783      (add) (f (g)) (add))
784    (f 'd)
785    (add)
786    (if (< (length path) 8)
787	(c 'e)
788	(assert (equal? '(a b c d c e d e e d) (reverse path))))))
789
790;;; vector and blob limits
791
792(assert-fail (make-blob -1))
793(assert-fail (make-vector -1))
794
795;;; Resizing of vectors works to both sides
796(let ((original (vector 1 2 3 4 5 6)))
797  (assert (equal? (vector-resize original 6 -1) original))
798  (assert (not (eq? (vector-resize original 6 -1) original))))
799
800(let ((original (vector 1 2 3 4 5 6))
801      (smaller (vector 1 2 3)))
802  (assert (equal? (vector-resize original 3 -1) smaller)))
803
804(let ((original (vector 1 2 3))
805      (larger (vector 1 2 3 -1 -1 -1)))
806  (assert (equal? (vector-resize original 6 -1) larger)))
807
808;;; eval return values
809
810(assert (= 1 (eval 1)))
811(assert (eq? '() (receive (eval '(values)))))
812(assert (equal? '(1 2 3) (receive (eval '(values 1 2 3)))))
813
814;;; message checks for invalid strings
815
816(assert-fail (##sys#message "123\x00456"))
817
818;;; vector procedures
819
820(assert (equal? '#(2 3) (subvector '#(1 2 3) 1)))
821(assert (equal? '#(2)   (subvector '#(1 2 3) 1 2)))
822(assert (equal? '#()    (subvector '#(1 2 3) 1 1)))
823(assert (equal? '#()    (subvector '#(1 2 3) 3)))
824(assert-fail (subvector '#(1 2 3) 4))
825(assert-fail (subvector '#(1 2 3) 3 4))
826
827;;; alist accessors
828
829(assert (equal? '(foo) (assq 'foo '((foo)))))
830(assert (not (assq 'foo '())))
831(assert-fail (assq 'foo '(bar)))
832(assert-fail (assq 'foo 'bar))
833
834
835(assert (equal? '(foo) (assv 'foo '((foo)))))
836(assert (not (assv 'foo '())))
837(assert-fail (assv 'foo '(bar)))
838(assert-fail (assv 'foo 'bar))
839
840(assert (equal? '("foo") (assoc "foo" '(("foo")))))
841(assert (not (assoc "foo" '())))
842(assert-fail (assoc "foo" '("bar")))
843(assert-fail (assoc "foo" "bar"))
844
845;;; list membership
846
847(assert (equal? '(foo) (memq 'foo '(bar foo))))
848(assert (not (memq 'foo '(bar))))
849(assert (not (memq 'foo '())))
850(assert-fail (memq 'foo 'foo))
851
852(assert (equal? '(foo) (memv 'foo '(bar foo))))
853(assert (not (memv 'foo '(bar))))
854(assert (not (memv 'foo '())))
855(assert-fail (memv 'foo 'foo))
856
857(assert (equal? '("foo") (member "foo" '("bar" "foo"))))
858(assert (not (member "foo" '("bar"))))
859(assert (not (member "foo" '())))
860(assert-fail (member "foo" "foo"))
861
862;; length
863
864(assert-fail (length 1))
865(assert-fail (length '(x . y)))
866