~ 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 "#u8(" read))
621(assert-fail (with-input-from-string "#u8{" read))
622(assert-fail (with-input-from-string "\\" read))
623(assert-fail (with-input-from-string "|\\" read))
624(assert-fail (with-input-from-string "\"\\" read))
625
626;;; here documents
627
628(assert (string=? "" #<<A
629A
630))
631
632(assert (string=? "foo" #<<A
633foo
634A
635))
636
637(assert (string=? "\nfoo\n" #<<A
638
639foo
640
641A
642))
643
644(assert (string=? "foo\nbar\nbaz" #<<A
645foo
646bar
647baz
648A
649))
650
651;;; setters
652
653(define x '(a b c))
654(define kar car)
655(set! (kar (cdr x)) 99)
656(assert (equal? '(a 99 c) x))
657(define p (make-parameter 100))
658(assert (= 100 (p)))
659(set! (p) 1000)
660(assert (= 1000 (p)))
661
662
663;; #808: bytevectors and strings with embedded nul bytes should not be compared
664;; with ASCIIZ string comparison functions
665(assert (equal? '#u8(#xa #xb 0 #xc) '#u8(#xa #xb 0 #xc)))
666(assert (bytevector=? '#u8(#xa #xb 0 #xc) '#u8(#xa #xb 0 #xc)))
667(assert (equal=? "foo\x00;a" "foo\x00;a"))
668(assert (string=? "foo\x00;a" "foo\x00;a"))
669(assert (string-ci=? "foo\x00;a" "foo\x00;a"))
670(assert (string-ci=? "foo\x00;a" "foo\x00;A"))
671(assert (not (equal? '#u8(#xa #xb 0 #xc) '#u8(#xa #xb 0 #xd))))
672(assert (not (bytevector=? '#u8(#xa #xb 0 #xc) '#u8(#xa #xb 0 #xd))))
673(assert (not (equal=? "foo\x00;a" "foo\x00;b")))
674(assert (not (string=? "foo\x00;a" "foo\x00;b")))
675(assert (not (string-ci=? "foo\x00;a" "foo\x00;b")))
676(assert (string<? "foo\x00;a" "foo\x00;b"))
677(assert (string>? "foo\x00;b" "foo\x00;a"))
678(assert (string-ci<? "foo\x00;a" "foo\x00;B"))
679(assert (string-ci>? "foo\x00;b" "foo\x00;A"))
680
681;; hex bytevector literals
682(assert-fail (with-input-from-string "#u8{f}" read))
683(assert-fail (with-input-from-string "#u8{ff0}" read))
684(assert-fail (with-input-from-string "#u8{1}" read))
685(assert-fail (with-input-from-string "#u8{-1}" read))
686(assert-fail (with-input-from-string "#u8{ -01 }" read))
687(assert-fail (with-input-from-string "#u8{F11223344556677889900}" read))
688
689(assert (equal? '#u8{}   '#u8()))
690(assert (equal? '#u8{01} '#u8(1)))
691(assert (equal? '#u8{00 01 10 11} '#u8(0 1 16 17)))
692(assert (equal? '#u8{af fa FA AF} '#u8(175 250 250 175)))
693(assert (equal? '#u8{0001   0203  0aff} '#u8(0 1 2 3 10 255)))
694(assert (equal? '#u8{0001   0203  0aff} '#u8(0 1 2 3 10 255)))
695(assert (equal? '#u8{000102030aff}      '#u8(0 1 2 3 10 255)))
696
697;; reported by Nils Holm (#1534)
698;; https://groups.google.com/group/comp.lang.scheme/t/6b8be06b84b39a7
699(assert (not (string-ci<=? "test" "tes")))
700(assert (string-ci>=? "test" "tes"))
701
702
703;;; getter-with-setter
704
705(define foo
706  (let ((m 2))
707    (getter-with-setter
708     (lambda (x) (* x m))
709     (lambda (x) 
710       (set! m x)))))
711
712(assert (= 6 (foo 3)))
713(set! (foo) 4)
714(assert (= 20 (foo 5)))
715
716(define bar
717  (getter-with-setter
718   foo
719   (lambda (x)
720     (+ x 99))))
721
722(assert (= 12 (bar 3)))
723(assert (= 100 (set! (bar) 1)))
724(assert (= 12 (foo 3)))
725
726
727;;; equal=?
728
729(assert (not (equal=? 1 2)))
730(assert (equal=? 1 1))
731(assert (equal=? 1 1.0))
732(assert (not (equal=? 1 1.2)))
733(assert (equal=? 1.0 1))
734(assert (equal=? '#(1) '#(1.0)))
735(assert (not (equal=? 'a "a")))
736(assert (equal=? "abc" "abc"))
737(assert (equal=? '(1 2.0 3) '(1 2 3)))
738(assert (equal=? '#(1 2.0 3) '#(1 2 3)))
739(assert (equal=? '#(1 2 (3)) '#(1 2 (3))))
740(assert (not (equal=? '#(1 2 (4)) '#(1 2 (3)))))
741(assert (not (equal=? 123 '(123))))
742
743;;; parameters
744
745(define guard-called 0)
746
747(define p
748  (make-parameter 
749   1
750   (lambda (x)
751     (set! guard-called (+ guard-called 1))
752     x)))
753
754(define k
755  (parameterize ((p 2))
756    (call/cc
757     (lambda (k) 
758       (assert (= 2 (p)))
759       k))))
760
761(and k (k #f))
762
763(assert (= 2 guard-called))
764
765;; Parameters are reset correctly (#1227, pointed out by Joo ChurlSoo)
766
767(let ((a (make-parameter 1 number->string))
768      (b (make-parameter 2 number->string)))
769  (assert (equal? (list "1" "2") (list (a) (b))))
770
771  (assert (equal? (list "10" "20")
772		  (parameterize ((a 10) (b 20)) (list (a) (b)))))
773
774  (assert (equal? (list "1" "2") (list (a) (b))))
775
776  (handle-exceptions exn #f (parameterize ((a 10) (b 'x)) (void)))
777
778  (assert (equal? (list "1" "2") (list (a) (b))))
779
780  (parameterize ((a 10) (b 30) (a 20))
781    (assert (equal? (list "20" "30") (list (a) (b)))))
782
783  (assert (equal? (list "1" "2") (list (a) (b)))) )
784
785;; Special-cased parameters are reset correctly (#1285, regression
786;; caused by fix for #1227)
787
788(let ((original-input (current-input-port))
789      (original-output (current-output-port))
790      (original-error (current-error-port))
791      (original-exception-handler (current-exception-handler)))
792  (call-with-output-string
793   (lambda (out)
794     (call-with-input-string
795      "foo"
796      (lambda (in)
797	(parameterize ((current-output-port out)
798		       (current-error-port out)
799		       (current-input-port in)
800		       (current-exception-handler list))
801	  (display "bar")
802	  (display "!" (current-error-port))
803	  (assert (equal? (read) 'foo))
804	  (assert (equal? (get-output-string out) "bar!"))
805	  (assert (equal? (signal 'baz) '(baz))))))))
806  (assert (equal? original-input (current-input-port)))
807  (assert (equal? original-output (current-output-port)))
808  (assert (equal? original-error (current-error-port)))
809  (assert (equal? original-exception-handler (current-exception-handler))))
810
811;; Re-entering dynamic extent of a parameterize should not reset to
812;; original outer values but remember values when jumping out (another
813;; regression due to #1227, pointed out by Joo ChurlSoo in #1336).
814
815(let ((f (make-parameter 'a))
816      (path '())
817      (g (make-parameter 'g))
818      (c #f))
819  (let ((add (lambda () (set! path (cons (f) path)))))
820    (add)
821    (parameterize ((f 'b)
822		   (g (call-with-current-continuation
823		       (lambda (c0) (set! c c0) 'c))))
824      (add) (f (g)) (add))
825    (f 'd)
826    (add)
827    (if (< (length path) 8)
828	(c 'e)
829	(assert (equal? '(a b c d b e d b e d) (reverse path))))))
830
831(let ((f (make-parameter 'a))
832      (path '())
833      (g (make-parameter 'g))
834      (c #f))
835  (let ((add (lambda () (set! path (cons (f) path)))))
836    (add)
837    (parameterize ((f 'b))
838      (g (call-with-current-continuation (lambda (c0) (set! c c0) 'c)))
839      (add) (f (g)) (add))
840    (f 'd)
841    (add)
842    (if (< (length path) 8)
843	(c 'e)
844	(assert (equal? '(a b c d c e d e e d) (reverse path))))))
845
846;;; vector and bytevector limits
847
848(assert-fail (make-bytevector -1))
849(assert-fail (make-vector -1))
850
851;;; Resizing of vectors works to both sides
852(let ((original (vector 1 2 3 4 5 6)))
853  (assert (equal? (vector-resize original 6 -1) original))
854  (assert (not (eq? (vector-resize original 6 -1) original))))
855
856(let ((original (vector 1 2 3 4 5 6))
857      (smaller (vector 1 2 3)))
858  (assert (equal? (vector-resize original 3 -1) smaller)))
859
860(let ((original (vector 1 2 3))
861      (larger (vector 1 2 3 -1 -1 -1)))
862  (assert (equal? (vector-resize original 6 -1) larger)))
863
864;;; eval return values
865
866(assert (= 1 (eval 1)))
867(assert (eq? '() (receive (eval '(values)))))
868(assert (equal? '(1 2 3) (receive (eval '(values 1 2 3)))))
869
870;;; message checks for invalid strings
871
872(assert-fail (##sys#message "123\x00;456"))
873
874;;; vector procedures
875
876(assert (equal? '#(2 3) (subvector '#(1 2 3) 1)))
877(assert (equal? '#(2)   (subvector '#(1 2 3) 1 2)))
878(assert (equal? '#()    (subvector '#(1 2 3) 1 1)))
879(assert (equal? '#()    (subvector '#(1 2 3) 3)))
880(assert-fail (subvector '#(1 2 3) 4))
881(assert-fail (subvector '#(1 2 3) 3 4))
882
883;;; alist accessors
884
885(assert (equal? '(foo) (assq 'foo '((foo)))))
886(assert (not (assq 'foo '())))
887(assert-fail (assq 'foo '(bar)))
888(assert-fail (assq 'foo 'bar))
889
890
891(assert (equal? '(foo) (assv 'foo '((foo)))))
892(assert (not (assv 'foo '())))
893(assert-fail (assv 'foo '(bar)))
894(assert-fail (assv 'foo 'bar))
895
896(assert (equal? '("foo") (assoc "foo" '(("foo")))))
897(assert (not (assoc "foo" '())))
898(assert-fail (assoc "foo" '("bar")))
899(assert-fail (assoc "foo" "bar"))
900
901;;; list membership
902
903(assert (equal? '(foo) (memq 'foo '(bar foo))))
904(assert (not (memq 'foo '(bar))))
905(assert (not (memq 'foo '())))
906(assert-fail (memq 'foo 'foo))
907
908(assert (equal? '(foo) (memv 'foo '(bar foo))))
909(assert (not (memv 'foo '(bar))))
910(assert (not (memv 'foo '())))
911(assert-fail (memv 'foo 'foo))
912
913(assert (equal? '("foo") (member "foo" '("bar" "foo"))))
914(assert (not (member "foo" '("bar"))))
915(assert (not (member "foo" '())))
916(assert-fail (member "foo" "foo"))
917
918;; length
919
920(assert-fail (length 1))
921(assert-fail (length '(x . y)))