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

  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(assert (inexact= 7.0 (fp*+ 2.0 3.0 1.0)))
308(assert (inexact= 53.0 (fp*+ 10.0 5.0 3.0)))
309
310;;; Tests contributed by Christian Himpe:
311
312;; original tests:
313(assert (inexact= 7.0 (fp*+ 2.0 3.0 1.0)))
314(assert (inexact= 53.0 (fp*+ 10.0 5.0 3.0)))
315
316;; my new tests:
317(assert (inexact= 5.0 (fp*+ 1.0 2.0 3.0)))
318(assert (inexact= 2.0 (fp*+ 1.0 2.0 0.0)))
319(assert (inexact= 3.0 (fp*+ 1.0 0.0 3.0)))
320(assert (inexact= 3.0 (fp*+ 0.0 2.0 3.0)))
321(assert (inexact= 3.0 (fp*+ 0.0 0.0 3.0)))
322(assert (inexact= -1.0 (fp*+ 2.0 0.5 -2.0)))
323(assert (zero? (fp*+ 0.0 0.0 0.0)))
324(assert (zero? (fp*+ -1.0 1.0 1.0)))
325(assert (zero? (fp*+ 1.0 -1.0 1.0)))
326(assert (zero? (fp*+ -1.0 -1.0 -1.0)))
327
328(assert (infinite? (fp*+ +inf.0 1.0 1.0)))
329(assert (infinite? (fp*+ 1.0 +inf.0 1.0)))
330(assert (infinite? (fp*+ 1.0 1.0 +inf.0)))
331(assert (infinite? (fp*+ +inf.0 1.0 +inf.0)))
332(assert (nan? (fp*+ -inf.0 1.0 +inf.0)))
333(assert (nan? (fp*+ +nan.0 1.0 1.0)))
334(assert (nan? (fp*+ 1.0 +nan.0 1.0)))
335(assert (nan? (fp*+ 1.0 1.0 +nan.0)))
336(assert (nan? (fp*+ 0.0 +inf.0 1.0)))
337(assert (nan? (fp*+ -inf.0 0.0 1.0)))
338
339;; Hyperbolic function tests
340
341(assert (fp= (fpsinh -inf.0) -inf.0))
342(assert (fp= (fpsinh 0.0) 0.0))
343(assert (fp= (fpsinh +inf.0) +inf.0))
344
345(assert (fp= (fpcosh -inf.0) +inf.0))
346(assert (fp= (fpcosh 0.0) 1.0))
347(assert (fp= (fpcosh +inf.0) +inf.0))
348
349(assert (fp= (fptanh -inf.0) -1.0))
350(assert (fp= (fptanh 0.0) 0.0))
351(assert (fp= (fptanh +inf.0) 1.0))
352
353(assert (fp= (fpasinh -inf.0) -inf.0))
354(assert (fp= (fpasinh 0.0) 0.0))
355(assert (fp= (fpasinh +inf.0) +inf.0))
356
357(assert (fp= (fpacosh 1.0) 0.0))
358(assert (fp= (fpacosh +inf.0) +inf.0))
359(assert (nan? (fpacosh 0.0)))
360
361(assert (fp= (fpatanh -1.0) -inf.0))
362(assert (fp= (fpatanh 0.0) 0.0))
363(assert (fp= (fpatanh 1.0) +inf.0))
364
365;; string->symbol
366
367;; by Jim Ursetto
368(assert 
369 (eq? '|3|
370      (with-input-from-string
371	  (with-output-to-string
372	    (lambda ()
373	      (write (string->symbol "3"))))
374	read)))
375
376;;; escaped symbol syntax
377
378(assert (string=? "abc" (symbol->string '|abc|)))
379(assert (string=? "abcdef" (symbol->string '|abc||def|)))
380(assert (string=? "abcxyzdef" (symbol->string '|abc|xyz|def|)))
381(assert (string=? "abc|def" (symbol->string '|abc\|def|)))
382(assert (string=? "abc|def" (symbol->string '|abc\|def|)))
383(assert (string=? "abc" (symbol->string 'abc)))
384(assert (string=? "a c" (symbol->string 'a\ c)))
385(assert (string=? "aBc" (symbol->string 'aBc)))
386
387(parameterize ((case-sensitive #f))
388  (assert (string=? "abc" (symbol->string (with-input-from-string "aBc" read))))
389  (assert (string=? "aBc" (symbol->string (with-input-from-string "|aBc|" read))))
390  (assert (string=? "aBc" (symbol->string (with-input-from-string "a\\Bc" read)))))
391
392(parameterize ((symbol-escape #f))
393  (assert (string=? "aBc" (symbol->string (with-input-from-string "aBc" read))))
394  (assert-fail (with-input-from-string "|aBc|" read))
395  (assert-fail (with-input-from-string "a|Bc" read)))
396(parameterize ((symbol-escape #t))
397  (assert (string=? "aBc" (symbol->string (with-input-from-string "aBc" read))))
398  (assert (string=? "aBc" (symbol->string (with-input-from-string "|aBc|" read))))
399  (assert (string=? "aB c" (symbol->string (with-input-from-string "|aB c|" read))))
400  ;; The following is an extension/generalisation of r7RS
401  (assert (string=? "aBc" (symbol->string (with-input-from-string "a|Bc|" read))))
402  ;; "Unterminated string" (unterminated identifier?)
403  (assert-fail (with-input-from-string "a|Bc" read)))
404
405;;; Old style qualified low byte, see #1077
406
407(assert (string=? "##foo#bar" (symbol->string '|##foo#bar|)))
408(assert (string=? "##foo#bar" (symbol->string '##foo#bar)))
409(assert (eq? '##foo#bar '|##foo#bar|))
410
411(assert (string=? "|\\x0a|" (with-output-to-string (lambda () (write '|\n|)))))
412;; #1576
413(assert (string=? "|\\x00foo|" (with-output-to-string (lambda () (write '|\000foo|)))))
414(assert (not (keyword? '|\000foo|)))
415(assert (string=? "|###foo#bar|" (with-output-to-string (lambda () (write '|###foo#bar|)))))
416
417;;; Paren synonyms
418
419(parameterize ((parentheses-synonyms #f))
420  (assert (eq? '() (with-input-from-string "()" read)))
421  (assert-fail (with-input-from-string "[]" read))
422  (assert-fail (with-input-from-string "{}" read)))
423(parameterize ((parentheses-synonyms #t))
424  (assert (eq? '() (with-input-from-string "()" read)))
425  (assert (eq? '() (with-input-from-string "[]" read)))
426  (assert (eq? '() (with-input-from-string "{}" read))))
427
428;;; keywords
429
430(parameterize ((keyword-style #:suffix))
431  (assert (string=? "abc:" (symbol->string (with-input-from-string "|abc:|" read))))
432  (assert (string=? "abc" (keyword->string (with-input-from-string "|abc|:" read)))) ; keyword
433  (let ((kw (with-input-from-string "|foo bar|:" read))
434	(sym1 (with-input-from-string "|foo:|" read))
435	(sym2 (with-input-from-string "|:foo|" read)))
436
437    (assert (symbol? sym1))
438    (assert (not (keyword? sym1)))
439
440    (assert (symbol? sym2))
441    (assert (not (keyword? sym2)))
442
443    (assert (keyword? kw))
444    (assert (not (symbol? kw)))
445
446    (assert (eq? kw (with-input-from-string "#:|foo bar|" read)))
447    (assert (string=? "foo bar" (keyword->string kw)))
448    (assert (string=? "foo:" (symbol->string sym1)))
449    (assert (string=? ":foo" (symbol->string sym2)))
450
451    (assert (string=? "foo bar:"
452		      (with-output-to-string (lambda () (display kw)))))
453    (assert (string=? "#:|foo bar|"
454		      (with-output-to-string (lambda () (write kw)))))
455
456    (assert (string=? "|foo:|"
457		      (with-output-to-string (lambda () (write sym1)))))
458    ;; Regardless of keyword style, symbols must be quoted to avoid
459    ;; issues when reading it back with a different keyword style.
460    (assert (string=? "|:foo|"
461		      (with-output-to-string (lambda () (write sym2)))))))
462
463(parameterize ((keyword-style #:prefix))
464  (assert (string=? "abc" (keyword->string (with-input-from-string ":|abc|" read))))
465  (assert (string=? ":abc" (symbol->string (with-input-from-string "|:abc|" read))))
466  (let ((kw (with-input-from-string ":|foo bar|" read))
467	(sym1 (with-input-from-string "|:foo|" read))
468	(sym2 (with-input-from-string "|foo:|" read)))
469
470    (assert (symbol? sym1))
471    (assert (not (keyword? sym1)))
472
473    (assert (symbol? sym2))
474    (assert (not (keyword? sym2)))
475
476    (assert (keyword? kw))
477    (assert (not (symbol? kw)))
478
479    (assert (eq? kw (with-input-from-string "#:|foo bar|" read)))
480    (assert (string=? "foo bar" (keyword->string kw)))
481    (assert (string=? ":foo" (symbol->string sym1)))
482    (assert (string=? "foo:" (symbol->string sym2)))
483
484    (assert (string=? ":foo bar"
485		      (with-output-to-string (lambda () (display kw)))))
486    (assert (string=? "#:|foo bar|"
487		      (with-output-to-string (lambda () (write kw)))))
488
489    (assert (string=? "|:foo|"
490		      (with-output-to-string (lambda () (write sym1)))))
491    ;; Regardless of keyword style, symbols must be quoted to avoid
492    ;; issues when reading it back with a different keyword style.
493    (assert (string=? "|foo:|"
494		      (with-output-to-string (lambda () (write sym2)))))))
495
496(parameterize ((keyword-style #:none))
497  (let ((kw (with-input-from-string "#:|foo bar|" read))
498	(sym1 (with-input-from-string "|:foo|" read))
499	(sym2 (with-input-from-string "|foo:|" read)))
500
501    (assert (symbol? sym1))
502    (assert (not (keyword? sym1)))
503
504    (assert (symbol? sym2))
505    (assert (not (keyword? sym2)))
506
507    (assert (keyword? kw))
508    (assert (not (symbol? kw)))
509
510    (assert (eq? kw (string->keyword "foo bar"))
511    (assert (string=? "foo bar" (keyword->string kw)))
512    (assert (string=? ":foo" (symbol->string sym1)))
513    (assert (string=? "foo:" (symbol->string sym2)))
514
515    (assert (string=? ":foo"
516		      (with-output-to-string (lambda () (display kw)))))
517    (assert (string=? "#:|foo bar|"
518		      (with-output-to-string (lambda () (write kw)))))
519
520    ;; Regardless of keyword style, symbols must be quoted to avoid
521    ;; issues when reading it back with a different keyword style.
522    (assert (string=? "|:foo|"
523		      (with-output-to-string (lambda () (write sym1)))))
524    (assert (string=? "|foo:|"
525		      (with-output-to-string (lambda () (write sym2))))))))
526
527(assert (eq? '|#:| (string->symbol "#:")))
528(assert-fail (with-input-from-string "#:" read)) ; empty keyword
529(assert (eq? '|#:| (with-input-from-string (with-output-to-string (cut write '|#:|)) read)))
530
531(parameterize ((keyword-style #:suffix))
532  (assert (keyword? (with-input-from-string "abc:" read)))
533  (assert (keyword? (with-input-from-string "|abc|:" read)))
534  (assert (keyword? (with-input-from-string "a|bc|d:" read)))
535  (assert (not (keyword? (with-input-from-string "abc:||" read))))
536  (assert (not (keyword? (with-input-from-string "abc\\:" read))))
537  (assert (not (keyword? (with-input-from-string "abc|:|" read))))
538  (assert (not (keyword? (with-input-from-string "|abc:|" read)))))
539
540(parameterize ((keyword-style #:prefix))
541  (assert (keyword? (with-input-from-string ":abc" read)))
542  (assert (keyword? (with-input-from-string ":|abc|" read)))
543  (assert (keyword? (with-input-from-string ":a|bc|d" read)))
544  (assert (not (keyword? (with-input-from-string "||:abc" read))))
545  (assert (not (keyword? (with-input-from-string "\\:abc" read))))
546  (assert (not (keyword? (with-input-from-string "|:|abc" read))))
547  (assert (not (keyword? (with-input-from-string "|:abc|" read)))))
548
549(parameterize ((keyword-style #f))
550  (assert (not (keyword? (with-input-from-string ":||" read))))
551  (assert (not (keyword? (with-input-from-string "||:" read))))
552  (assert (not (keyword? (with-input-from-string ":abc" read))))
553  (assert (not (keyword? (with-input-from-string ":abc:" read))))
554  (assert (not (keyword? (with-input-from-string "abc:" read)))))
555
556(parameterize ((keyword-style #:suffix))
557  (let ((colon-sym (with-input-from-string ":" read)))
558    (assert (symbol? colon-sym))
559    (assert (not (keyword? colon-sym)))
560    (assert (string=? ":" (symbol->string colon-sym)))))
561
562(parameterize ((keyword-style #:prefix))
563  (let ((colon-sym (with-input-from-string ":" read)))
564    (assert (symbol? colon-sym))
565    (assert (not (keyword? colon-sym)))
566    (assert (string=? ":" (symbol->string colon-sym)))))
567
568;; The next two cases are a bit dubious, but we follow SRFI-88 (see
569;; also #1625).
570(parameterize ((keyword-style #:suffix))
571  (let ((colon-sym (with-input-from-string ":||" read)))
572    (assert (symbol? colon-sym))
573    (assert (not (keyword? colon-sym)))
574    (assert (string=? ":" (symbol->string colon-sym))))
575
576  (let ((empty-kw (with-input-from-string "||:" read)))
577    (assert (not (symbol? empty-kw)))
578    (assert (keyword? empty-kw))
579    (assert (string=? "" (keyword->string empty-kw)))))
580
581(parameterize ((keyword-style #:prefix))
582  (let ((empty-kw (with-input-from-string ":||" read)))
583    (assert (not (symbol? empty-kw)))
584    (assert (keyword? empty-kw))
585    (assert (string=? "" (keyword->string empty-kw))))
586
587  (let ((colon-sym (with-input-from-string "||:" read)))
588    (assert (symbol? colon-sym))
589    (assert (not (keyword? colon-sym)))
590    (assert (string=? ":" (symbol->string colon-sym)))))
591
592(assert-fail (with-input-from-string "#:" read))
593
594(let ((empty-kw (with-input-from-string "#:||" read)))
595  (assert (not (symbol? empty-kw)))
596  (assert (keyword? empty-kw))
597  (assert (string=? "" (keyword->string empty-kw))))
598
599;; TODO: It should eventually be possible to distinguish these (#1077)
600#;(let ((nul-sym (with-input-from-string "|\\x00|" read)))
601  (assert (not (keyword? nul-sym)))
602  (assert (string=? "\x00" (symbol->string nul-sym))))
603
604(assert (keyword? (with-input-from-string "42:" read)))
605(assert (keyword? (with-input-from-string ".:" read)))
606
607(assert (equal? (cons 1 2) (with-input-from-string "(1 . 2)" read)))
608(assert (every keyword? (with-input-from-string "(42: abc: .: #:: ::)" read)))
609
610;; symbols and keywords are now distinct
611(assert (not (symbol? #:foo)))
612(assert (not (symbol? (string->keyword "foo"))))
613(assert (not (keyword? 'foo)))
614(assert (not (keyword? (string->symbol "foo"))))
615
616;;; reading unterminated objects
617
618(assert-fail (with-input-from-string "(" read))
619(assert-fail (with-input-from-string "(1 . 2" 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(assert-fail (with-input-from-string "#${" read))
625(assert-fail (with-input-from-string "\\" read))
626(assert-fail (with-input-from-string "|\\" read))
627(assert-fail (with-input-from-string "\"\\" read))
628
629;;; here documents
630
631(assert (string=? "" #<<A
632A
633))
634
635(assert (string=? "foo" #<<A
636foo
637A
638))
639
640(assert (string=? "\nfoo\n" #<<A
641
642foo
643
644A
645))
646
647(assert (string=? "foo\nbar\nbaz" #<<A
648foo
649bar
650baz
651A
652))
653
654;;; setters
655
656(define x '(a b c))
657(define kar car)
658(set! (kar (cdr x)) 99)
659(assert (equal? '(a 99 c) x))
660(define p (make-parameter 100))
661(assert (= 100 (p)))
662(set! (p) 1000)
663(assert (= 1000 (p)))
664
665
666;;; blob-literal syntax
667
668(assert (equal? '#${a} '#${0a}))
669(assert (equal? '#${ab cd} '#${abcd}))
670(assert (equal? '#${ab c} '#${ab0c}))
671(assert (equal? '#${abc} '#${ab0c}))
672(assert (equal? '#${a b c} '#${0a0b0c}))
673
674;; self-evaluating
675(assert (equal? '#${a} #${a}))
676(assert (equal? '#${abcd} #${abcd}))
677(assert (equal? '#${abc} #${abc}))
678
679
680;; #808: blobs and strings with embedded nul bytes should not be compared
681;; with ASCIIZ string comparison functions
682(assert (equal? '#${a b 0 c} '#${a b 0 c}))
683(assert (blob=? '#${a b 0 c} '#${a b 0 c}))
684(assert (equal=? "foo\x00a" "foo\x00a"))
685(assert (string=? "foo\x00a" "foo\x00a"))
686(assert (string-ci=? "foo\x00a" "foo\x00a"))
687(assert (string-ci=? "foo\x00a" "foo\x00A"))
688(assert (not (equal? '#${a b 0 c} '#${a b 0 d})))
689(assert (not (blob=? '#${a b 0 c} '#${a b 0 d})))
690(assert (not (equal=? "foo\x00a" "foo\x00b")))
691(assert (not (string=? "foo\x00a" "foo\x00b")))
692(assert (not (string-ci=? "foo\x00a" "foo\x00b")))
693(assert (string<? "foo\x00a" "foo\x00b"))
694(assert (string>? "foo\x00b" "foo\x00a"))
695(assert (string-ci<? "foo\x00a" "foo\x00B"))
696(assert (string-ci>? "foo\x00b" "foo\x00A"))
697
698;; reported by Nils Holm (#1534)
699;; https://groups.google.com/group/comp.lang.scheme/t/6b8be06b84b39a7
700(assert (not (string-ci<=? "test" "tes")))
701(assert (string-ci>=? "test" "tes"))
702
703
704;;; getter-with-setter
705
706(define foo
707  (let ((m 2))
708    (getter-with-setter
709     (lambda (x) (* x m))
710     (lambda (x) 
711       (set! m x)))))
712
713(assert (= 6 (foo 3)))
714(set! (foo) 4)
715(assert (= 20 (foo 5)))
716
717(define bar
718  (getter-with-setter
719   foo
720   (lambda (x)
721     (+ x 99))))
722
723(assert (= 12 (bar 3)))
724(assert (= 100 (set! (bar) 1)))
725(assert (= 12 (foo 3)))
726
727
728;;; equal=?
729
730(assert (not (equal=? 1 2)))
731(assert (equal=? 1 1))
732(assert (equal=? 1 1.0))
733(assert (not (equal=? 1 1.2)))
734(assert (equal=? 1.0 1))
735(assert (equal=? '#(1) '#(1.0)))
736(assert (not (equal=? 'a "a")))
737(assert (equal=? "abc" "abc"))
738(assert (equal=? '(1 2.0 3) '(1 2 3)))
739(assert (equal=? '#(1 2.0 3) '#(1 2 3)))
740(assert (equal=? '#(1 2 (3)) '#(1 2 (3))))
741(assert (not (equal=? '#(1 2 (4)) '#(1 2 (3)))))
742(assert (not (equal=? 123 '(123))))
743
744;;; parameters
745
746(define guard-called 0)
747
748(define p
749  (make-parameter 
750   1
751   (lambda (x)
752     (set! guard-called (+ guard-called 1))
753     x)))
754
755(define k
756  (parameterize ((p 2))
757    (call/cc
758     (lambda (k) 
759       (assert (= 2 (p)))
760       k))))
761
762(and k (k #f))
763
764(assert (= 2 guard-called))
765
766;; Parameters are reset correctly (#1227, pointed out by Joo ChurlSoo)
767
768(let ((a (make-parameter 1 number->string))
769      (b (make-parameter 2 number->string)))
770  (assert (equal? (list "1" "2") (list (a) (b))))
771
772  (assert (equal? (list "10" "20")
773		  (parameterize ((a 10) (b 20)) (list (a) (b)))))
774
775  (assert (equal? (list "1" "2") (list (a) (b))))
776
777  (handle-exceptions exn #f (parameterize ((a 10) (b 'x)) (void)))
778
779  (assert (equal? (list "1" "2") (list (a) (b))))
780
781  (parameterize ((a 10) (b 30) (a 20))
782    (assert (equal? (list "20" "30") (list (a) (b)))))
783
784  (assert (equal? (list "1" "2") (list (a) (b)))) )
785
786;; Special-cased parameters are reset correctly (#1285, regression
787;; caused by fix for #1227)
788
789(let ((original-input (current-input-port))
790      (original-output (current-output-port))
791      (original-error (current-error-port))
792      (original-exception-handler (current-exception-handler)))
793  (call-with-output-string
794   (lambda (out)
795     (call-with-input-string
796      "foo"
797      (lambda (in)
798	(parameterize ((current-output-port out)
799		       (current-error-port out)
800		       (current-input-port in)
801		       (current-exception-handler list))
802	  (display "bar")
803	  (display "!" (current-error-port))
804	  (assert (equal? (read) 'foo))
805	  (assert (equal? (get-output-string out) "bar!"))
806	  (assert (equal? (signal 'baz) '(baz))))))))
807  (assert (equal? original-input (current-input-port)))
808  (assert (equal? original-output (current-output-port)))
809  (assert (equal? original-error (current-error-port)))
810  (assert (equal? original-exception-handler (current-exception-handler))))
811
812;; Re-entering dynamic extent of a parameterize should not reset to
813;; original outer values but remember values when jumping out (another
814;; regression due to #1227, pointed out by Joo ChurlSoo in #1336).
815
816(let ((f (make-parameter 'a))
817      (path '())
818      (g (make-parameter 'g))
819      (c #f))
820  (let ((add (lambda () (set! path (cons (f) path)))))
821    (add)
822    (parameterize ((f 'b)
823		   (g (call-with-current-continuation
824		       (lambda (c0) (set! c c0) 'c))))
825      (add) (f (g)) (add))
826    (f 'd)
827    (add)
828    (if (< (length path) 8)
829	(c 'e)
830	(assert (equal? '(a b c d b e d b e d) (reverse path))))))
831
832(let ((f (make-parameter 'a))
833      (path '())
834      (g (make-parameter 'g))
835      (c #f))
836  (let ((add (lambda () (set! path (cons (f) path)))))
837    (add)
838    (parameterize ((f 'b))
839      (g (call-with-current-continuation (lambda (c0) (set! c c0) 'c)))
840      (add) (f (g)) (add))
841    (f 'd)
842    (add)
843    (if (< (length path) 8)
844	(c 'e)
845	(assert (equal? '(a b c d c e d e e d) (reverse path))))))
846
847;;; vector and blob limits
848
849(assert-fail (make-blob -1))
850(assert-fail (make-vector -1))
851
852;;; Resizing of vectors works to both sides
853(let ((original (vector 1 2 3 4 5 6)))
854  (assert (equal? (vector-resize original 6 -1) original))
855  (assert (not (eq? (vector-resize original 6 -1) original))))
856
857(let ((original (vector 1 2 3 4 5 6))
858      (smaller (vector 1 2 3)))
859  (assert (equal? (vector-resize original 3 -1) smaller)))
860
861(let ((original (vector 1 2 3))
862      (larger (vector 1 2 3 -1 -1 -1)))
863  (assert (equal? (vector-resize original 6 -1) larger)))
864
865;;; eval return values
866
867(assert (= 1 (eval 1)))
868(assert (eq? '() (receive (eval '(values)))))
869(assert (equal? '(1 2 3) (receive (eval '(values 1 2 3)))))
870
871;;; message checks for invalid strings
872
873(assert-fail (##sys#message "123\x00456"))
874
875;;; vector procedures
876
877(assert (equal? '#(2 3) (subvector '#(1 2 3) 1)))
878(assert (equal? '#(2)   (subvector '#(1 2 3) 1 2)))
879(assert (equal? '#()    (subvector '#(1 2 3) 1 1)))
880(assert (equal? '#()    (subvector '#(1 2 3) 3)))
881(assert-fail (subvector '#(1 2 3) 4))
882(assert-fail (subvector '#(1 2 3) 3 4))
883
884;;; alist accessors
885
886(assert (equal? '(foo) (assq 'foo '((foo)))))
887(assert (not (assq 'foo '())))
888(assert-fail (assq 'foo '(bar)))
889(assert-fail (assq 'foo 'bar))
890
891
892(assert (equal? '(foo) (assv 'foo '((foo)))))
893(assert (not (assv 'foo '())))
894(assert-fail (assv 'foo '(bar)))
895(assert-fail (assv 'foo 'bar))
896
897(assert (equal? '("foo") (assoc "foo" '(("foo")))))
898(assert (not (assoc "foo" '())))
899(assert-fail (assoc "foo" '("bar")))
900(assert-fail (assoc "foo" "bar"))
901
902;;; list membership
903
904(assert (equal? '(foo) (memq 'foo '(bar foo))))
905(assert (not (memq 'foo '(bar))))
906(assert (not (memq 'foo '())))
907(assert-fail (memq 'foo 'foo))
908
909(assert (equal? '(foo) (memv 'foo '(bar foo))))
910(assert (not (memv 'foo '(bar))))
911(assert (not (memv 'foo '())))
912(assert-fail (memv 'foo 'foo))
913
914(assert (equal? '("foo") (member "foo" '("bar" "foo"))))
915(assert (not (member "foo" '("bar"))))
916(assert (not (member "foo" '())))
917(assert-fail (member "foo" "foo"))
918
919;; length
920
921(assert-fail (length 1))
922(assert-fail (length '(x . y)))