~ chicken-core (master) /tests/library-tests.scm

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