1 ;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*-
2 ;;;; Andy Wingo <wingo@pobox.com> --- May 2009
4 ;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
6 ;;;; This library is free software; you can redistribute it and/or
7 ;;;; modify it under the terms of the GNU Lesser General Public
8 ;;;; License as published by the Free Software Foundation; either
9 ;;;; version 3 of the License, or (at your option) any later version.
11 ;;;; This library is distributed in the hope that it will be useful,
12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 ;;;; Lesser General Public License for more details.
16 ;;;; You should have received a copy of the GNU Lesser General Public
17 ;;;; License along with this library; if not, write to the Free Software
18 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
20 (define-module (test-suite tree-il)
21 #:use-module (test-suite lib)
22 #:use-module (system base compile)
23 #:use-module (system base pmatch)
24 #:use-module (system base message)
25 #:use-module (language tree-il)
26 #:use-module (language tree-il primitives)
27 #:use-module (srfi srfi-13))
29 (define-syntax-rule (pass-if-primitives-resolved in expected)
30 (pass-if (format #f "primitives-resolved in ~s" 'in)
31 (let* ((module (let ((m (make-module)))
32 (beautify-user-module! m)
34 (orig (parse-tree-il 'in))
35 (resolved (expand-primitives (resolve-primitives orig module))))
36 (or (equal? (unparse-tree-il resolved) 'expected)
38 (format (current-error-port)
39 "primitive test failed: got ~s, expected ~s"
43 (define-syntax pass-if-tree-il->scheme
46 (assert-scheme->tree-il->scheme in pat #t))
49 (pmatch (tree-il->scheme
50 (compile 'in #:from 'scheme #:to 'tree-il))
51 (pat (guard guard-exp) #t)
55 (with-test-prefix "primitives"
57 (with-test-prefix "eqv?"
59 (pass-if-primitives-resolved
60 (primcall eqv? (toplevel x) (const #f))
61 (primcall eq? (const #f) (toplevel x)))
63 (pass-if-primitives-resolved
64 (primcall eqv? (toplevel x) (const ()))
65 (primcall eq? (const ()) (toplevel x)))
67 (pass-if-primitives-resolved
68 (primcall eqv? (const #t) (lexical x y))
69 (primcall eq? (const #t) (lexical x y)))
71 (pass-if-primitives-resolved
72 (primcall eqv? (const this-is-a-symbol) (toplevel x))
73 (primcall eq? (const this-is-a-symbol) (toplevel x)))
75 (pass-if-primitives-resolved
76 (primcall eqv? (const 42) (toplevel x))
77 (primcall eq? (const 42) (toplevel x)))
79 (pass-if-primitives-resolved
80 (primcall eqv? (const 42.0) (toplevel x))
81 (primcall eqv? (const 42.0) (toplevel x)))
83 (pass-if-primitives-resolved
84 (primcall eqv? (const #nil) (toplevel x))
85 (primcall eq? (const #nil) (toplevel x))))
87 (with-test-prefix "equal?"
89 (pass-if-primitives-resolved
90 (primcall equal? (toplevel x) (const #f))
91 (primcall eq? (const #f) (toplevel x)))
93 (pass-if-primitives-resolved
94 (primcall equal? (toplevel x) (const ()))
95 (primcall eq? (const ()) (toplevel x)))
97 (pass-if-primitives-resolved
98 (primcall equal? (const #t) (lexical x y))
99 (primcall eq? (const #t) (lexical x y)))
101 (pass-if-primitives-resolved
102 (primcall equal? (const this-is-a-symbol) (toplevel x))
103 (primcall eq? (const this-is-a-symbol) (toplevel x)))
105 (pass-if-primitives-resolved
106 (primcall equal? (const 42) (toplevel x))
107 (primcall eq? (const 42) (toplevel x)))
109 (pass-if-primitives-resolved
110 (primcall equal? (const 42.0) (toplevel x))
111 (primcall equal? (const 42.0) (toplevel x)))
113 (pass-if-primitives-resolved
114 (primcall equal? (const #nil) (toplevel x))
115 (primcall eq? (const #nil) (toplevel x)))))
118 (with-test-prefix "tree-il->scheme"
119 (pass-if-tree-il->scheme
120 (case-lambda ((a) a) ((b c) (list b c)))
121 (case-lambda ((,a) ,a1) ((,b ,c) (list ,b1 ,c1)))
122 (and (eq? a a1) (eq? b b1) (eq? c c1))))
125 (with-test-prefix "contification"
126 (pass-if "http://debbugs.gnu.org/9769"
127 ((compile '(lambda ()
128 (let ((fail (lambda () #f)))
129 (let ((test (lambda () (fail))))
132 ;; Prevent inlining. We're testing contificatoin here,
133 ;; and inlining it will reduce the entire thing to #t.
134 #:opts '(#:partial-eval? #f)))))
140 (with-test-prefix "many args"
141 (pass-if "call with > 256 args"
142 (equal? (compile `(1+ (sum ,@(iota 1000)))
143 #:env (current-module))
144 (1+ (apply sum (iota 1000)))))
146 (pass-if "tail call with > 256 args"
147 (equal? (compile `(sum ,@(iota 1000))
148 #:env (current-module))
149 (apply sum (iota 1000)))))
153 (with-test-prefix "tree-il-fold"
156 (let ((up 0) (down 0) (mark (list 'mark)))
158 (tree-il-fold (lambda (x y) (set! down (1+ down)) y)
159 (lambda (x y) (set! up (1+ up)) y)
165 (pass-if "lambda and application"
166 (let* ((ups '()) (downs '())
167 (result (tree-il-fold (lambda (x y)
168 (set! downs (cons x downs))
171 (set! ups (cons x ups))
177 (((x y) #f #f #f () (x1 y1))
182 (define (strip-source x)
183 (post-order (lambda (x)
184 (set! (tree-il-src x) #f)
188 (equal? (map strip-source (list-head (reverse ups) 3))
189 (list (make-toplevel-ref #f '+)
190 (make-lexical-ref #f 'x 'x1)
191 (make-lexical-ref #f 'y 'y1)))
192 (equal? (map strip-source (reverse (list-head downs 3)))
193 (list (make-toplevel-ref #f '+)
194 (make-lexical-ref #f 'x 'x1)
195 (make-lexical-ref #f 'y 'y1)))))))
202 ;; Make sure we get English messages.
203 (setlocale LC_ALL "C")
205 (define (call-with-warnings thunk)
206 (let ((port (open-output-string)))
207 (with-fluids ((*current-warning-port* port)
208 (*current-warning-prefix* ""))
210 (let ((warnings (get-output-string port)))
211 (string-tokenize warnings
212 (char-set-complement (char-set #\newline))))))
214 (define %opts-w-unused
215 '(#:warnings (unused-variable)))
217 (define %opts-w-unused-toplevel
218 '(#:warnings (unused-toplevel)))
220 (define %opts-w-unbound
221 '(#:warnings (unbound-variable)))
223 (define %opts-w-arity
224 '(#:warnings (arity-mismatch)))
226 (define %opts-w-format
227 '(#:warnings (format)))
229 (define %opts-w-duplicate-case-datum
230 '(#:warnings (duplicate-case-datum)))
232 (define %opts-w-bad-case-datum
233 '(#:warnings (bad-case-datum)))
236 (with-test-prefix "warnings"
238 (pass-if "unknown warning type"
239 (let ((w (call-with-warnings
241 (compile #t #:opts '(#:warnings (does-not-exist)))))))
242 (and (= (length w) 1)
243 (number? (string-contains (car w) "unknown warning")))))
245 (with-test-prefix "unused-variable"
248 (null? (call-with-warnings
250 (compile '(lambda (x y) (+ x y))
251 #:opts %opts-w-unused)))))
253 (pass-if "let/unused"
254 (let ((w (call-with-warnings
256 (compile '(lambda (x)
259 #:opts %opts-w-unused)))))
260 (and (= (length w) 1)
261 (number? (string-contains (car w) "unused variable `y'")))))
263 (pass-if "shadowed variable"
264 (let ((w (call-with-warnings
266 (compile '(lambda (x)
270 #:opts %opts-w-unused)))))
271 (and (= (length w) 1)
272 (number? (string-contains (car w) "unused variable `y'")))))
275 (null? (call-with-warnings
278 (letrec ((x (lambda () (y)))
281 #:opts %opts-w-unused)))))
283 (pass-if "unused argument"
284 ;; Unused arguments should not be reported.
285 (null? (call-with-warnings
287 (compile '(lambda (x y z) #t)
288 #:opts %opts-w-unused)))))
290 (pass-if "special variable names"
291 (null? (call-with-warnings
294 (let ((_ 'underscore)
295 (#{gensym name}# 'ignore-me))
298 #:opts %opts-w-unused))))))
300 (with-test-prefix "unused-toplevel"
302 (pass-if "used after definition"
303 (null? (call-with-warnings
305 (let ((in (open-input-string
306 "(define foo 2) foo")))
309 #:opts %opts-w-unused-toplevel))))))
311 (pass-if "used before definition"
312 (null? (call-with-warnings
314 (let ((in (open-input-string
315 "(define (bar) foo) (define foo 2) (bar)")))
318 #:opts %opts-w-unused-toplevel))))))
320 (pass-if "unused but public"
321 (let ((in (open-input-string
322 "(define-module (test-suite tree-il x) #:export (bar))
323 (define (bar) #t)")))
324 (null? (call-with-warnings
328 #:opts %opts-w-unused-toplevel))))))
330 (pass-if "unused but public (more)"
331 (let ((in (open-input-string
332 "(define-module (test-suite tree-il x) #:export (bar))
335 (define (foo) #t)")))
336 (null? (call-with-warnings
340 #:opts %opts-w-unused-toplevel))))))
342 (pass-if "unused but define-public"
343 (null? (call-with-warnings
345 (compile '(define-public foo 2)
347 #:opts %opts-w-unused-toplevel)))))
349 (pass-if "used by macro"
350 ;; FIXME: See comment about macros at `unused-toplevel-analysis'.
353 (null? (call-with-warnings
355 (let ((in (open-input-string
358 (syntax-rules () ((_) (bar))))")))
361 #:opts %opts-w-unused-toplevel))))))
364 (let ((w (call-with-warnings
366 (compile '(define foo 2)
368 #:opts %opts-w-unused-toplevel)))))
369 (and (= (length w) 1)
370 (number? (string-contains (car w)
371 (format #f "top-level variable `~A'"
374 (pass-if "unused recursive"
375 (let ((w (call-with-warnings
377 (compile '(define (foo) (foo))
379 #:opts %opts-w-unused-toplevel)))))
380 (and (= (length w) 1)
381 (number? (string-contains (car w)
382 (format #f "top-level variable `~A'"
385 (pass-if "unused mutually recursive"
386 (let* ((in (open-input-string
387 "(define (foo) (bar)) (define (bar) (foo))"))
388 (w (call-with-warnings
392 #:opts %opts-w-unused-toplevel)))))
393 (and (= (length w) 2)
394 (number? (string-contains (car w)
395 (format #f "top-level variable `~A'"
397 (number? (string-contains (cadr w)
398 (format #f "top-level variable `~A'"
401 (pass-if "special variable names"
402 (null? (call-with-warnings
404 (compile '(define #{gensym name}# 'ignore-me)
406 #:opts %opts-w-unused-toplevel))))))
408 (with-test-prefix "unbound variable"
411 (null? (call-with-warnings
413 (compile '+ #:opts %opts-w-unbound)))))
417 (w (call-with-warnings
421 #:opts %opts-w-unbound)))))
422 (and (= (length w) 1)
423 (number? (string-contains (car w)
424 (format #f "unbound variable `~A'"
429 (w (call-with-warnings
431 (compile `(set! ,v 7)
433 #:opts %opts-w-unbound)))))
434 (and (= (length w) 1)
435 (number? (string-contains (car w)
436 (format #f "unbound variable `~A'"
439 (pass-if "module-local top-level is visible"
440 (let ((m (make-module))
442 (beautify-user-module! m)
443 (compile `(define ,v 123)
444 #:env m #:opts %opts-w-unbound)
445 (null? (call-with-warnings
450 #:opts %opts-w-unbound))))))
452 (pass-if "module-local top-level is visible after"
453 (let ((m (make-module))
455 (beautify-user-module! m)
456 (null? (call-with-warnings
458 (let ((in (open-input-string
461 (define chbouib 5)")))
464 #:opts %opts-w-unbound)))))))
466 (pass-if "optional arguments are visible"
467 (null? (call-with-warnings
469 (compile '(lambda* (x #:optional y z) (list x y z))
470 #:opts %opts-w-unbound
473 (pass-if "keyword arguments are visible"
474 (null? (call-with-warnings
476 (compile '(lambda* (x #:key y z) (list x y z))
477 #:opts %opts-w-unbound
480 (pass-if "GOOPS definitions are visible"
481 (let ((m (make-module))
483 (beautify-user-module! m)
484 (module-use! m (resolve-interface '(oop goops)))
485 (null? (call-with-warnings
487 (let ((in (open-input-string
488 "(define-class <foo> ()
489 (bar #:getter foo-bar))
490 (define z (foo-bar (make <foo>)))")))
493 #:opts %opts-w-unbound))))))))
495 (with-test-prefix "arity mismatch"
498 (null? (call-with-warnings
500 (compile '(cons 'a 'b) #:opts %opts-w-arity)))))
502 (pass-if "direct application"
503 (let ((w (call-with-warnings
505 (compile '((lambda (x y) (or x y)) 1 2 3 4 5)
508 (and (= (length w) 1)
509 (number? (string-contains (car w)
510 "wrong number of arguments to")))))
512 (let ((w (call-with-warnings
514 (compile '(let ((f (lambda (x y) (+ x y))))
518 (and (= (length w) 1)
519 (number? (string-contains (car w)
520 "wrong number of arguments to")))))
523 (let ((w (call-with-warnings
525 (compile '(cons 1 2 3 4)
528 (and (= (length w) 1)
529 (number? (string-contains (car w)
530 "wrong number of arguments to")))))
532 (pass-if "alias to global"
533 (let ((w (call-with-warnings
535 (compile '(let ((f cons)) (f 1 2 3 4))
538 (and (= (length w) 1)
539 (number? (string-contains (car w)
540 "wrong number of arguments to")))))
542 (pass-if "alias to lexical to global"
543 (let ((w (call-with-warnings
545 (compile '(let ((f number?))
550 (and (= (length w) 1)
551 (number? (string-contains (car w)
552 "wrong number of arguments to")))))
554 (pass-if "alias to lexical"
555 (let ((w (call-with-warnings
557 (compile '(let ((f (lambda (x y z) (+ x y z))))
562 (and (= (length w) 1)
563 (number? (string-contains (car w)
564 "wrong number of arguments to")))))
567 (let ((w (call-with-warnings
569 (compile '(letrec ((odd? (lambda (x) (even? (1- x))))
576 (and (= (length w) 1)
577 (number? (string-contains (car w)
578 "wrong number of arguments to")))))
580 (pass-if "case-lambda"
581 (null? (call-with-warnings
583 (compile '(let ((f (case-lambda
593 (pass-if "case-lambda with wrong number of arguments"
594 (let ((w (call-with-warnings
596 (compile '(let ((f (case-lambda
602 (and (= (length w) 1)
603 (number? (string-contains (car w)
604 "wrong number of arguments to")))))
606 (pass-if "case-lambda*"
607 (null? (call-with-warnings
609 (compile '(let ((f (case-lambda*
620 (pass-if "case-lambda* with wrong arguments"
621 (let ((w (call-with-warnings
623 (compile '(let ((f (case-lambda*
631 (and (= (length w) 2)
632 (null? (filter (lambda (w)
636 w "wrong number of arguments to"))))
639 (pass-if "top-level applicable struct"
640 (null? (call-with-warnings
642 (compile '(let ((p current-warning-port))
648 (pass-if "top-level applicable struct with wrong arguments"
649 (let ((w (call-with-warnings
651 (compile '(let ((p current-warning-port))
655 (and (= (length w) 1)
656 (number? (string-contains (car w)
657 "wrong number of arguments to")))))
659 (pass-if "local toplevel-defines"
660 (let ((w (call-with-warnings
662 (let ((in (open-input-string "
668 (and (= (length w) 1)
669 (number? (string-contains (car w)
670 "wrong number of arguments to")))))
672 (pass-if "global toplevel alias"
673 (let ((w (call-with-warnings
675 (let ((in (open-input-string "
681 (and (= (length w) 1)
682 (number? (string-contains (car w)
683 "wrong number of arguments to")))))
685 (pass-if "local toplevel overrides global"
686 (null? (call-with-warnings
688 (let ((in (open-input-string "
690 (define (foo x) (cons))")))
695 (pass-if "keyword not passed and quiet"
696 (null? (call-with-warnings
698 (compile '(let ((f (lambda* (x #:key y) y)))
703 (pass-if "keyword passed and quiet"
704 (null? (call-with-warnings
706 (compile '(let ((f (lambda* (x #:key y) y)))
711 (pass-if "keyword passed to global and quiet"
712 (null? (call-with-warnings
714 (let ((in (open-input-string "
715 (use-modules (system base compile))
716 (compile '(+ 2 3) #:env (current-module))")))
721 (pass-if "extra keyword"
722 (let ((w (call-with-warnings
724 (compile '(let ((f (lambda* (x #:key y) y)))
728 (and (= (length w) 1)
729 (number? (string-contains (car w)
730 "wrong number of arguments to")))))
732 (pass-if "extra keywords allowed"
733 (null? (call-with-warnings
735 (compile '(let ((f (lambda* (x #:key y #:allow-other-keys)
741 (with-test-prefix "format"
743 (pass-if "quiet (no args)"
744 (null? (call-with-warnings
746 (compile '(format #t "hey!")
747 #:opts %opts-w-format
750 (pass-if "quiet (1 arg)"
751 (null? (call-with-warnings
753 (compile '(format #t "hey ~A!" "you")
754 #:opts %opts-w-format
757 (pass-if "quiet (2 args)"
758 (null? (call-with-warnings
760 (compile '(format #t "~A ~A!" "hello" "world")
761 #:opts %opts-w-format
764 (pass-if "wrong port arg"
765 (let ((w (call-with-warnings
767 (compile '(format 10 "foo")
768 #:opts %opts-w-format
770 (and (= (length w) 1)
771 (number? (string-contains (car w)
772 "wrong port argument")))))
774 (pass-if "non-literal format string"
775 (let ((w (call-with-warnings
777 (compile '(format #f fmt)
778 #:opts %opts-w-format
780 (and (= (length w) 1)
781 (number? (string-contains (car w)
782 "non-literal format string")))))
784 (pass-if "non-literal format string using gettext"
785 (null? (call-with-warnings
787 (compile '(format #t (gettext "~A ~A!") "hello" "world")
788 #:opts %opts-w-format
791 (pass-if "non-literal format string using gettext as _"
792 (null? (call-with-warnings
794 (compile '(format #t (_ "~A ~A!") "hello" "world")
795 #:opts %opts-w-format
798 (pass-if "non-literal format string using gettext as top-level _"
799 (null? (call-with-warnings
802 (define (_ s) (gettext s "my-domain"))
803 (format #t (_ "~A ~A!") "hello" "world"))
804 #:opts %opts-w-format
807 (pass-if "non-literal format string using gettext as module-ref _"
808 (null? (call-with-warnings
810 (compile '(format #t ((@@ (foo) _) "~A ~A!") "hello" "world")
811 #:opts %opts-w-format
814 (pass-if "non-literal format string using gettext as lexical _"
815 (null? (call-with-warnings
817 (compile '(let ((_ (lambda (s)
818 (gettext s "my-domain"))))
819 (format #t (_ "~A ~A!") "hello" "world"))
820 #:opts %opts-w-format
823 (pass-if "non-literal format string using ngettext"
824 (null? (call-with-warnings
827 (ngettext "~a thing" "~a things" n "dom") n)
828 #:opts %opts-w-format
831 (pass-if "non-literal format string using ngettext as N_"
832 (null? (call-with-warnings
834 (compile '(format #t (N_ "~a thing" "~a things" n) n)
835 #:opts %opts-w-format
838 (pass-if "non-literal format string with (define _ gettext)"
839 (null? (call-with-warnings
844 (format #t (_ "~A ~A!") "hello" "world")))
845 #:opts %opts-w-format
848 (pass-if "wrong format string"
849 (let ((w (call-with-warnings
851 (compile '(format #f 'not-a-string)
852 #:opts %opts-w-format
854 (and (= (length w) 1)
855 (number? (string-contains (car w)
856 "wrong format string")))))
858 (pass-if "wrong number of args"
859 (let ((w (call-with-warnings
861 (compile '(format "shbweeb")
862 #:opts %opts-w-format
864 (and (= (length w) 1)
865 (number? (string-contains (car w)
866 "wrong number of arguments")))))
868 (pass-if "~%, ~~, ~&, ~t, ~_, ~!, ~|, ~/, ~q and ~\\n"
869 (null? (call-with-warnings
871 (compile '((@ (ice-9 format) format) some-port
872 "~&~3_~~ ~\n~12they~% ~!~|~/~q")
873 #:opts %opts-w-format
876 (pass-if "one missing argument"
877 (let ((w (call-with-warnings
879 (compile '(format some-port "foo ~A~%")
880 #:opts %opts-w-format
882 (and (= (length w) 1)
883 (number? (string-contains (car w)
884 "expected 1, got 0")))))
886 (pass-if "one missing argument, gettext"
887 (let ((w (call-with-warnings
889 (compile '(format some-port (gettext "foo ~A~%"))
890 #:opts %opts-w-format
892 (and (= (length w) 1)
893 (number? (string-contains (car w)
894 "expected 1, got 0")))))
896 (pass-if "two missing arguments"
897 (let ((w (call-with-warnings
899 (compile '((@ (ice-9 format) format) #f
900 "foo ~10,2f and bar ~S~%")
901 #:opts %opts-w-format
903 (and (= (length w) 1)
904 (number? (string-contains (car w)
905 "expected 2, got 0")))))
907 (pass-if "one given, one missing argument"
908 (let ((w (call-with-warnings
910 (compile '(format #t "foo ~A and ~S~%" hey)
911 #:opts %opts-w-format
913 (and (= (length w) 1)
914 (number? (string-contains (car w)
915 "expected 2, got 1")))))
917 (pass-if "too many arguments"
918 (let ((w (call-with-warnings
920 (compile '(format #t "foo ~A~%" 1 2)
921 #:opts %opts-w-format
923 (and (= (length w) 1)
924 (number? (string-contains (car w)
925 "expected 1, got 2")))))
928 (null? (call-with-warnings
930 (compile '((@ (ice-9 format) format) #t
931 "foo ~h ~a~%" 123.4 'bar)
932 #:opts %opts-w-format
935 (pass-if "~:h with locale object"
936 (null? (call-with-warnings
938 (compile '((@ (ice-9 format) format) #t
939 "foo ~:h~%" 123.4 %global-locale)
940 #:opts %opts-w-format
943 (pass-if "~:h without locale object"
944 (let ((w (call-with-warnings
946 (compile '((@ (ice-9 format) format) #t "foo ~,2:h" 123.4)
947 #:opts %opts-w-format
949 (and (= (length w) 1)
950 (number? (string-contains (car w)
951 "expected 2, got 1")))))
953 (with-test-prefix "conditionals"
955 (null? (call-with-warnings
957 (compile '((@ (ice-9 format) format) #f "~A ~[foo~;bar~;baz~;~] ~10,2f"
959 #:opts %opts-w-format
962 (pass-if "literals with selector"
963 (let ((w (call-with-warnings
965 (compile '((@ (ice-9 format) format) #f "~2[foo~;bar~;baz~;~] ~A"
967 #:opts %opts-w-format
969 (and (= (length w) 1)
970 (number? (string-contains (car w)
971 "expected 1, got 2")))))
973 (pass-if "escapes (exact count)"
974 (let ((w (call-with-warnings
976 (compile '((@ (ice-9 format) format) #f "~[~a~;~a~]")
977 #:opts %opts-w-format
979 (and (= (length w) 1)
980 (number? (string-contains (car w)
981 "expected 2, got 0")))))
983 (pass-if "escapes with selector"
984 (let ((w (call-with-warnings
986 (compile '((@ (ice-9 format) format) #f "~1[chbouib~;~a~]")
987 #:opts %opts-w-format
989 (and (= (length w) 1)
990 (number? (string-contains (car w)
991 "expected 1, got 0")))))
993 (pass-if "escapes, range"
994 (let ((w (call-with-warnings
996 (compile '((@ (ice-9 format) format) #f "~[chbouib~;~a~;~2*~a~]")
997 #:opts %opts-w-format
999 (and (= (length w) 1)
1000 (number? (string-contains (car w)
1001 "expected 1 to 4, got 0")))))
1004 (let ((w (call-with-warnings
1006 (compile '((@ (ice-9 format) format) #f "~@[temperature=~d~]")
1007 #:opts %opts-w-format
1009 (and (= (length w) 1)
1010 (number? (string-contains (car w)
1011 "expected 1, got 0")))))
1014 (let ((w (call-with-warnings
1016 (compile '((@ (ice-9 format) format) #f "~:[~[hey~;~a~;~va~]~;~3*~]")
1017 #:opts %opts-w-format
1019 (and (= (length w) 1)
1020 (number? (string-contains (car w)
1021 "expected 2 to 4, got 0")))))
1023 (pass-if "unterminated"
1024 (let ((w (call-with-warnings
1026 (compile '((@ (ice-9 format) format) #f "~[unterminated")
1027 #:opts %opts-w-format
1029 (and (= (length w) 1)
1030 (number? (string-contains (car w)
1031 "unterminated conditional")))))
1033 (pass-if "unexpected ~;"
1034 (let ((w (call-with-warnings
1036 (compile '((@ (ice-9 format) format) #f "foo~;bar")
1037 #:opts %opts-w-format
1039 (and (= (length w) 1)
1040 (number? (string-contains (car w)
1043 (pass-if "unexpected ~]"
1044 (let ((w (call-with-warnings
1046 (compile '((@ (ice-9 format) format) #f "foo~]")
1047 #:opts %opts-w-format
1049 (and (= (length w) 1)
1050 (number? (string-contains (car w)
1054 (null? (call-with-warnings
1056 (compile '((@ (ice-9 format) format) #f "~A ~{~S~} ~A"
1057 'hello '("ladies" "and")
1059 #:opts %opts-w-format
1062 (pass-if "~{...~}, too many args"
1063 (let ((w (call-with-warnings
1065 (compile '((@ (ice-9 format) format) #f "~{~S~}" 1 2 3)
1066 #:opts %opts-w-format
1068 (and (= (length w) 1)
1069 (number? (string-contains (car w)
1070 "expected 1, got 3")))))
1073 (null? (call-with-warnings
1075 (compile '((@ (ice-9 format) format) #f "~@{~S~}" 1 2 3)
1076 #:opts %opts-w-format
1079 (pass-if "~@{...~}, too few args"
1080 (let ((w (call-with-warnings
1082 (compile '((@ (ice-9 format) format) #f "~A ~@{~S~}")
1083 #:opts %opts-w-format
1085 (and (= (length w) 1)
1086 (number? (string-contains (car w)
1087 "expected at least 1, got 0")))))
1089 (pass-if "unterminated ~{...~}"
1090 (let ((w (call-with-warnings
1092 (compile '((@ (ice-9 format) format) #f "~{")
1093 #:opts %opts-w-format
1095 (and (= (length w) 1)
1096 (number? (string-contains (car w)
1100 (null? (call-with-warnings
1102 (compile '((@ (ice-9 format) format) #f "~:@(~A ~A~)" 'foo 'bar)
1103 #:opts %opts-w-format
1107 (let ((w (call-with-warnings
1109 (compile '((@ (ice-9 format) format) #f "~v_foo")
1110 #:opts %opts-w-format
1112 (and (= (length w) 1)
1113 (number? (string-contains (car w)
1114 "expected 1, got 0")))))
1116 (null? (call-with-warnings
1118 (compile '((@ (ice-9 format) format) #f "~v:@y" 1 123)
1119 #:opts %opts-w-format
1124 (let ((w (call-with-warnings
1126 (compile '((@ (ice-9 format) format) #f "~2*~a" 'a 'b)
1127 #:opts %opts-w-format
1129 (and (= (length w) 1)
1130 (number? (string-contains (car w)
1131 "expected 3, got 2")))))
1134 (null? (call-with-warnings
1136 (compile '((@ (ice-9 format) format) #f "~?" "~d ~d" '(1 2))
1137 #:opts %opts-w-format
1141 (null? (call-with-warnings
1143 (compile '((@ (ice-9 format) format) #f "~a ~^ ~a" 0 1)
1144 #:opts %opts-w-format
1147 (pass-if "~^, too few args"
1148 (let ((w (call-with-warnings
1150 (compile '((@ (ice-9 format) format) #f "~a ~^ ~a")
1151 #:opts %opts-w-format
1153 (and (= (length w) 1)
1154 (number? (string-contains (car w)
1155 "expected at least 1, got 0")))))
1157 (pass-if "parameters: +,-,#, and '"
1158 (null? (call-with-warnings
1160 (compile '((@ (ice-9 format) format) some-port
1161 "~#~ ~,,-2f ~,,+2f ~'A~" 1234 1234)
1162 #:opts %opts-w-format
1165 (pass-if "complex 1"
1166 (let ((w (call-with-warnings
1168 (compile '((@ (ice-9 format) format) #f
1169 "~4@S ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n"
1171 #:opts %opts-w-format
1173 (and (= (length w) 1)
1174 (number? (string-contains (car w)
1175 "expected 4, got 6")))))
1177 (pass-if "complex 2"
1178 (let ((w (call-with-warnings
1180 (compile '((@ (ice-9 format) format) #f
1181 "~:(~A~) Commands~:[~; [abbrev]~]:~2%"
1183 #:opts %opts-w-format
1185 (and (= (length w) 1)
1186 (number? (string-contains (car w)
1187 "expected 2, got 4")))))
1189 (pass-if "complex 3"
1190 (let ((w (call-with-warnings
1192 (compile '((@ (ice-9 format) format) #f "~9@a~:[~*~3_~;~3d~] ~v:@y~%")
1193 #:opts %opts-w-format
1195 (and (= (length w) 1)
1196 (number? (string-contains (car w)
1197 "expected 5, got 0")))))
1199 (pass-if "ice-9 format"
1200 (let ((w (call-with-warnings
1202 (let ((in (open-input-string
1203 "(use-modules ((ice-9 format)
1204 #:renamer (symbol-prefix-proc 'i9-)))
1205 (i9-format #t \"yo! ~A\" 1 2)")))
1206 (read-and-compile in
1207 #:opts %opts-w-format
1209 (and (= (length w) 1)
1210 (number? (string-contains (car w)
1211 "expected 1, got 2")))))
1213 (pass-if "not format"
1214 (null? (call-with-warnings
1216 (compile '(let ((format chbouib))
1217 (format #t "not ~A a format string"))
1218 #:opts %opts-w-format
1221 (with-test-prefix "simple-format"
1224 (null? (call-with-warnings
1226 (compile '(simple-format #t "foo ~a bar ~s ~%~~" 1 2)
1227 #:opts %opts-w-format
1230 (pass-if "wrong number of args"
1231 (let ((w (call-with-warnings
1233 (compile '(simple-format #t "foo ~a ~s~%" 'one-missing)
1234 #:opts %opts-w-format
1236 (and (= (length w) 1)
1237 (number? (string-contains (car w) "wrong number")))))
1239 (pass-if "unsupported"
1240 (let ((w (call-with-warnings
1242 (compile '(simple-format #t "foo ~x~%" 16)
1243 #:opts %opts-w-format
1245 (and (= (length w) 1)
1246 (number? (string-contains (car w) "unsupported format option")))))
1248 (pass-if "unsupported, gettext"
1249 (let ((w (call-with-warnings
1251 (compile '(simple-format #t (gettext "foo ~2f~%") 3.14)
1252 #:opts %opts-w-format
1254 (and (= (length w) 1)
1255 (number? (string-contains (car w) "unsupported format option")))))
1257 (pass-if "unsupported, ngettext"
1258 (let ((w (call-with-warnings
1260 (compile '(simple-format #t (ngettext "s ~x" "p ~x" x) x)
1261 #:opts %opts-w-format
1263 (and (= (length w) 1)
1264 (number? (string-contains (car w) "unsupported format option")))))))
1266 (with-test-prefix "duplicate-case-datum"
1269 (null? (call-with-warnings
1271 (compile '(case x ((1) 'one) ((2) 'two))
1272 #:opts %opts-w-duplicate-case-datum
1275 (pass-if "one duplicate"
1276 (let ((w (call-with-warnings
1282 #:opts %opts-w-duplicate-case-datum
1284 (and (= (length w) 1)
1285 (number? (string-contains (car w) "duplicate")))))
1287 (pass-if "one duplicate"
1288 (let ((w (call-with-warnings
1293 #:opts %opts-w-duplicate-case-datum
1295 (and (= (length w) 1)
1296 (number? (string-contains (car w) "duplicate"))))))
1298 (with-test-prefix "bad-case-datum"
1301 (null? (call-with-warnings
1303 (compile '(case x ((1) 'one) ((2) 'two))
1304 #:opts %opts-w-bad-case-datum
1308 (let ((w (call-with-warnings
1313 #:opts %opts-w-bad-case-datum
1315 (and (= (length w) 1)
1316 (number? (string-contains (car w)
1317 "cannot be meaningfully compared")))))
1319 (pass-if "one clause element not eqv?"
1320 (let ((w (call-with-warnings
1324 #:opts %opts-w-duplicate-case-datum
1326 (and (= (length w) 1)
1327 (number? (string-contains (car w)
1328 "cannot be meaningfully compared")))))))
1331 ;; eval: (put 'pass-if-primitives-resolved 'scheme-indent-function 1)
1332 ;; eval: (put 'pass-if-tree-il->scheme 'scheme-indent-function 1)