test-suite/tests/tree-il.test

   1 ;;;; tree-il.test --- test suite for compiling tree-il   -*- scheme -*-
   2 ;;;; Andy Wingo <wingo@pobox.com> --- May 2009
   3 ;;;;
   4 ;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013,
   5 ;;;;   2014 Free Software Foundation, Inc.
   6 ;;;;
   7 ;;;; This library is free software; you can redistribute it and/or
   8 ;;;; modify it under the terms of the GNU Lesser General Public
   9 ;;;; License as published by the Free Software Foundation; either
  10 ;;;; version 3 of the License, or (at your option) any later version.
  11 ;;;;
  12 ;;;; This library is distributed in the hope that it will be useful,
  13 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15 ;;;; Lesser General Public License for more details.
  16 ;;;;
  17 ;;;; You should have received a copy of the GNU Lesser General Public
  18 ;;;; License along with this library; if not, write to the Free Software
  19 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  20
  21 (define-module (test-suite tree-il)
  22   #:use-module (test-suite lib)
  23   #:use-module (system base compile)
  24   #:use-module (system base pmatch)
  25   #:use-module (system base message)
  26   #:use-module (language tree-il)
  27   #:use-module (language tree-il primitives)
  28   #:use-module (srfi srfi-13))
  29
  30 (define-syntax-rule (pass-if-primitives-resolved in expected)
  31   (pass-if (format #f "primitives-resolved in ~s" 'in)
  32     (let* ((module   (let ((m (make-module)))
  33                        (beautify-user-module! m)
  34                        m))
  35            (orig     (parse-tree-il 'in))
  36            (resolved (expand-primitives (resolve-primitives orig module))))
  37       (or (equal? (unparse-tree-il resolved) 'expected)
  38           (begin
  39             (format (current-error-port)
  40                     "primitive test failed: got ~s, expected ~s"
  41                     resolved 'expected)
  42             #f)))))
  43
  44 (define-syntax pass-if-tree-il->scheme
  45   (syntax-rules ()
  46     ((_ in pat)
  47      (assert-scheme->tree-il->scheme in pat #t))
  48     ((_ in pat guard-exp)
  49      (pass-if 'in
  50        (pmatch (tree-il->scheme
  51                 (compile 'in #:from 'scheme #:to 'tree-il))
  52          (pat (guard guard-exp) #t)
  53          (_ #f))))))
  54
  55 \f
  56 (with-test-prefix "primitives"
  57
  58   (with-test-prefix "eqv?"
  59
  60     (pass-if-primitives-resolved
  61         (primcall eqv? (toplevel x) (const #f))
  62       (primcall eq? (const #f) (toplevel x)))
  63
  64     (pass-if-primitives-resolved
  65         (primcall eqv? (toplevel x) (const ()))
  66       (primcall eq? (const ()) (toplevel x)))
  67
  68     (pass-if-primitives-resolved
  69         (primcall eqv? (const #t) (lexical x y))
  70       (primcall eq? (const #t) (lexical x y)))
  71
  72     (pass-if-primitives-resolved
  73         (primcall eqv? (const this-is-a-symbol) (toplevel x))
  74       (primcall eq? (const this-is-a-symbol) (toplevel x)))
  75
  76     (pass-if-primitives-resolved
  77         (primcall eqv? (const 42) (toplevel x))
  78       (primcall eq? (const 42) (toplevel x)))
  79
  80     (pass-if-primitives-resolved
  81         (primcall eqv? (const 42.0) (toplevel x))
  82       (primcall eqv? (const 42.0) (toplevel x)))
  83
  84     (pass-if-primitives-resolved
  85         (primcall eqv? (const #nil) (toplevel x))
  86       (primcall eq? (const #nil) (toplevel x))))
  87
  88   (with-test-prefix "equal?"
  89
  90     (pass-if-primitives-resolved
  91         (primcall equal? (toplevel x) (const #f))
  92       (primcall eq? (const #f) (toplevel x)))
  93
  94     (pass-if-primitives-resolved
  95         (primcall equal? (toplevel x) (const ()))
  96       (primcall eq? (const ()) (toplevel x)))
  97
  98     (pass-if-primitives-resolved
  99         (primcall equal? (const #t) (lexical x y))
 100       (primcall eq? (const #t) (lexical x y)))
 101
 102     (pass-if-primitives-resolved
 103         (primcall equal? (const this-is-a-symbol) (toplevel x))
 104       (primcall eq? (const this-is-a-symbol) (toplevel x)))
 105
 106     (pass-if-primitives-resolved
 107         (primcall equal? (const 42) (toplevel x))
 108       (primcall eq? (const 42) (toplevel x)))
 109
 110     (pass-if-primitives-resolved
 111         (primcall equal? (const 42.0) (toplevel x))
 112       (primcall equal? (const 42.0) (toplevel x)))
 113
 114     (pass-if-primitives-resolved
 115         (primcall equal? (const #nil) (toplevel x))
 116       (primcall eq? (const #nil) (toplevel x)))))
 117
 118 \f
 119 (with-test-prefix "tree-il->scheme"
 120   (pass-if-tree-il->scheme
 121    (case-lambda ((a) a) ((b c) (list b c)))
 122    (case-lambda ((,a) ,a1) ((,b ,c) (list ,b1 ,c1)))
 123    (and (eq? a a1) (eq? b b1) (eq? c c1))))
 124
 125 \f
 126 (with-test-prefix "contification"
 127   (pass-if "http://debbugs.gnu.org/9769"
 128     ((compile '(lambda ()
 129                  (let ((fail (lambda () #f)))
 130                    (let ((test (lambda () (fail))))
 131                      (test))
 132                    #t))
 133               ;; Prevent inlining.  We're testing contificatoin here,
 134               ;; and inlining it will reduce the entire thing to #t.
 135               #:opts '(#:partial-eval? #f)))))
 136
 137 \f
 138 (define (sum . args)
 139   (apply + args))
 140
 141 (with-test-prefix "many args"
 142   (pass-if "call with > 256 args"
 143     (equal? (compile `(1+ (sum ,@(iota 1000)))
 144                      #:env (current-module))
 145             (1+ (apply sum (iota 1000)))))
 146
 147   (pass-if "tail call with > 256 args"
 148     (equal? (compile `(sum ,@(iota 1000))
 149                      #:env (current-module))
 150             (apply sum (iota 1000)))))
 151
 152
 153 \f
 154 (with-test-prefix "tree-il-fold"
 155
 156   (pass-if "void"
 157     (let ((up 0) (down 0) (mark (list 'mark)))
 158       (and (eq? mark
 159                 (tree-il-fold (lambda (x y) (set! down (1+ down)) y)
 160                               (lambda (x y) (set! up (1+ up)) y)
 161                               mark
 162                               (make-void #f)))
 163            (= up 1)
 164            (= down 1))))
 165
 166   (pass-if "lambda and application"
 167     (let* ((ups '()) (downs '())
 168            (result (tree-il-fold (lambda (x y)
 169                                    (set! downs (cons x downs))
 170                                    (1+ y))
 171                                  (lambda (x y)
 172                                    (set! ups (cons x ups))
 173                                    (1+ y))
 174                                  0
 175                                  (parse-tree-il
 176                                   '(lambda ()
 177                                      (lambda-case
 178                                       (((x y) #f #f #f () (x1 y1))
 179                                        (call (toplevel +)
 180                                              (lexical x x1)
 181                                              (lexical y y1)))
 182                                       #f))))))
 183       (define (strip-source x)
 184         (post-order (lambda (x)
 185                       (set! (tree-il-src x) #f)
 186                       x)
 187                     x))
 188       (and (= result 12)
 189            (equal? (map strip-source (list-head (reverse ups) 3))
 190                    (list (make-toplevel-ref #f '+)
 191                          (make-lexical-ref #f 'x 'x1)
 192                          (make-lexical-ref #f 'y 'y1)))
 193            (equal? (map strip-source (reverse (list-head downs 3)))
 194                    (list (make-toplevel-ref #f '+)
 195                          (make-lexical-ref #f 'x 'x1)
 196                          (make-lexical-ref #f 'y 'y1)))))))
 197
 198 \f
 199 ;;;
 200 ;;; Warnings.
 201 ;;;
 202
 203 ;; Make sure we get English messages.
 204 (when (defined? 'setlocale)
 205   (setlocale LC_ALL "C"))
 206
 207 (define (call-with-warnings thunk)
 208   (let ((port (open-output-string)))
 209     (with-fluids ((*current-warning-port*   port)
 210                   (*current-warning-prefix* ""))
 211       (thunk))
 212     (let ((warnings (get-output-string port)))
 213       (string-tokenize warnings
 214                        (char-set-complement (char-set #\newline))))))
 215
 216 (define %opts-w-unused
 217   '(#:warnings (unused-variable)))
 218
 219 (define %opts-w-unused-toplevel
 220   '(#:warnings (unused-toplevel)))
 221
 222 (define %opts-w-unbound
 223   '(#:warnings (unbound-variable)))
 224
 225 (define %opts-w-arity
 226   '(#:warnings (arity-mismatch)))
 227
 228 (define %opts-w-format
 229   '(#:warnings (format)))
 230
 231 (define %opts-w-duplicate-case-datum
 232   '(#:warnings (duplicate-case-datum)))
 233
 234 (define %opts-w-bad-case-datum
 235   '(#:warnings (bad-case-datum)))
 236
 237
 238 (with-test-prefix "warnings"
 239
 240    (pass-if "unknown warning type"
 241      (let ((w (call-with-warnings
 242                 (lambda ()
 243                   (compile #t #:opts '(#:warnings (does-not-exist)))))))
 244        (and (= (length w) 1)
 245             (number? (string-contains (car w) "unknown warning")))))
 246
 247    (with-test-prefix "unused-variable"
 248
 249      (pass-if "quiet"
 250        (null? (call-with-warnings
 251                 (lambda ()
 252                   (compile '(lambda (x y) (+ x y))
 253                            #:opts %opts-w-unused)))))
 254
 255      (pass-if "let/unused"
 256        (let ((w (call-with-warnings
 257                   (lambda ()
 258                     (compile '(lambda (x)
 259                                 (let ((y (+ x 2)))
 260                                   x))
 261                              #:opts %opts-w-unused)))))
 262          (and (= (length w) 1)
 263               (number? (string-contains (car w) "unused variable `y'")))))
 264
 265      (pass-if "shadowed variable"
 266        (let ((w (call-with-warnings
 267                   (lambda ()
 268                     (compile '(lambda (x)
 269                                 (let ((y x))
 270                                   (let ((y (+ x 2)))
 271                                     (+ x y))))
 272                              #:opts %opts-w-unused)))))
 273          (and (= (length w) 1)
 274               (number? (string-contains (car w) "unused variable `y'")))))
 275
 276      (pass-if "letrec"
 277        (null? (call-with-warnings
 278                 (lambda ()
 279                   (compile '(lambda ()
 280                               (letrec ((x (lambda () (y)))
 281                                        (y (lambda () (x))))
 282                                 y))
 283                            #:opts %opts-w-unused)))))
 284
 285      (pass-if "unused argument"
 286        ;; Unused arguments should not be reported.
 287        (null? (call-with-warnings
 288                 (lambda ()
 289                   (compile '(lambda (x y z) #t)
 290                            #:opts %opts-w-unused)))))
 291
 292      (pass-if "special variable names"
 293        (null? (call-with-warnings
 294                 (lambda ()
 295                   (compile '(lambda ()
 296                               (let ((_ 'underscore)
 297                                     (#{gensym name}# 'ignore-me))
 298                                 #t))
 299                            #:to 'cps
 300                            #:opts %opts-w-unused))))))
 301
 302    (with-test-prefix "unused-toplevel"
 303
 304      (pass-if "used after definition"
 305        (null? (call-with-warnings
 306                 (lambda ()
 307                   (let ((in (open-input-string
 308                              "(define foo 2) foo")))
 309                     (read-and-compile in
 310                                       #:to 'cps
 311                                       #:opts %opts-w-unused-toplevel))))))
 312
 313      (pass-if "used before definition"
 314        (null? (call-with-warnings
 315                 (lambda ()
 316                   (let ((in (open-input-string
 317                              "(define (bar) foo) (define foo 2) (bar)")))
 318                     (read-and-compile in
 319                                       #:to 'cps
 320                                       #:opts %opts-w-unused-toplevel))))))
 321
 322      (pass-if "unused but public"
 323        (let ((in (open-input-string
 324                   "(define-module (test-suite tree-il x) #:export (bar))
 325                    (define (bar) #t)")))
 326          (null? (call-with-warnings
 327                   (lambda ()
 328                     (read-and-compile in
 329                                       #:to 'cps
 330                                       #:opts %opts-w-unused-toplevel))))))
 331
 332      (pass-if "unused but public (more)"
 333        (let ((in (open-input-string
 334                   "(define-module (test-suite tree-il x) #:export (bar))
 335                    (define (bar) (baz))
 336                    (define (baz) (foo))
 337                    (define (foo) #t)")))
 338          (null? (call-with-warnings
 339                   (lambda ()
 340                     (read-and-compile in
 341                                       #:to 'cps
 342                                       #:opts %opts-w-unused-toplevel))))))
 343
 344      (pass-if "unused but define-public"
 345        (null? (call-with-warnings
 346                 (lambda ()
 347                   (compile '(define-public foo 2)
 348                            #:to 'cps
 349                            #:opts %opts-w-unused-toplevel)))))
 350
 351      (pass-if "used by macro"
 352        ;; FIXME: See comment about macros at `unused-toplevel-analysis'.
 353        (throw 'unresolved)
 354
 355        (null? (call-with-warnings
 356                 (lambda ()
 357                   (let ((in (open-input-string
 358                              "(define (bar) 'foo)
 359                               (define-syntax baz
 360                                 (syntax-rules () ((_) (bar))))")))
 361                     (read-and-compile in
 362                                       #:to 'cps
 363                                       #:opts %opts-w-unused-toplevel))))))
 364
 365      (pass-if "unused"
 366        (let ((w (call-with-warnings
 367                   (lambda ()
 368                     (compile '(define foo 2)
 369                              #:to 'cps
 370                              #:opts %opts-w-unused-toplevel)))))
 371          (and (= (length w) 1)
 372               (number? (string-contains (car w)
 373                                         (format #f "top-level variable `~A'"
 374                                                 'foo))))))
 375
 376      (pass-if "unused recursive"
 377        (let ((w (call-with-warnings
 378                   (lambda ()
 379                     (compile '(define (foo) (foo))
 380                              #:to 'cps
 381                              #:opts %opts-w-unused-toplevel)))))
 382          (and (= (length w) 1)
 383               (number? (string-contains (car w)
 384                                         (format #f "top-level variable `~A'"
 385                                                 'foo))))))
 386
 387      (pass-if "unused mutually recursive"
 388        (let* ((in (open-input-string
 389                    "(define (foo) (bar)) (define (bar) (foo))"))
 390               (w  (call-with-warnings
 391                     (lambda ()
 392                       (read-and-compile in
 393                                         #:to 'cps
 394                                         #:opts %opts-w-unused-toplevel)))))
 395          (and (= (length w) 2)
 396               (number? (string-contains (car w)
 397                                         (format #f "top-level variable `~A'"
 398                                                 'foo)))
 399               (number? (string-contains (cadr w)
 400                                         (format #f "top-level variable `~A'"
 401                                                 'bar))))))
 402
 403      (pass-if "special variable names"
 404        (null? (call-with-warnings
 405                 (lambda ()
 406                   (compile '(define #{gensym name}# 'ignore-me)
 407                            #:to 'cps
 408                            #:opts %opts-w-unused-toplevel))))))
 409
 410    (with-test-prefix "unbound variable"
 411
 412      (pass-if "quiet"
 413        (null? (call-with-warnings
 414                 (lambda ()
 415                   (compile '+ #:opts %opts-w-unbound)))))
 416
 417      (pass-if "ref"
 418        (let* ((v (gensym))
 419               (w (call-with-warnings
 420                    (lambda ()
 421                      (compile v
 422                               #:to 'cps
 423                               #:opts %opts-w-unbound)))))
 424          (and (= (length w) 1)
 425               (number? (string-contains (car w)
 426                                         (format #f "unbound variable `~A'"
 427                                                 v))))))
 428
 429      (pass-if "set!"
 430        (let* ((v (gensym))
 431               (w (call-with-warnings
 432                    (lambda ()
 433                      (compile `(set! ,v 7)
 434                               #:to 'cps
 435                               #:opts %opts-w-unbound)))))
 436          (and (= (length w) 1)
 437               (number? (string-contains (car w)
 438                                         (format #f "unbound variable `~A'"
 439                                                 v))))))
 440
 441      (pass-if "module-local top-level is visible"
 442        (let ((m (make-module))
 443              (v (gensym)))
 444          (beautify-user-module! m)
 445          (compile `(define ,v 123)
 446                   #:env m #:opts %opts-w-unbound)
 447          (null? (call-with-warnings
 448                   (lambda ()
 449                     (compile v
 450                              #:env m
 451                              #:to 'cps
 452                              #:opts %opts-w-unbound))))))
 453
 454      (pass-if "module-local top-level is visible after"
 455        (let ((m (make-module))
 456              (v (gensym)))
 457          (beautify-user-module! m)
 458          (null? (call-with-warnings
 459                   (lambda ()
 460                     (let ((in (open-input-string
 461                                "(define (f)
 462                                   (set! chbouib 3))
 463                                 (define chbouib 5)")))
 464                       (read-and-compile in
 465                                         #:env m
 466                                         #:opts %opts-w-unbound)))))))
 467
 468      (pass-if "optional arguments are visible"
 469        (null? (call-with-warnings
 470                 (lambda ()
 471                   (compile '(lambda* (x #:optional y z) (list x y z))
 472                            #:opts %opts-w-unbound
 473                            #:to 'cps)))))
 474
 475      (pass-if "keyword arguments are visible"
 476        (null? (call-with-warnings
 477                 (lambda ()
 478                   (compile '(lambda* (x #:key y z) (list x y z))
 479                            #:opts %opts-w-unbound
 480                            #:to 'cps)))))
 481
 482      (pass-if "GOOPS definitions are visible"
 483        (let ((m (make-module))
 484              (v (gensym)))
 485          (beautify-user-module! m)
 486          (module-use! m (resolve-interface '(oop goops)))
 487          (null? (call-with-warnings
 488                   (lambda ()
 489                     (let ((in (open-input-string
 490                                "(define-class <foo> ()
 491                                   (bar #:getter foo-bar))
 492                                 (define z (foo-bar (make <foo>)))")))
 493                       (read-and-compile in
 494                                         #:env m
 495                                         #:opts %opts-w-unbound))))))))
 496
 497    (with-test-prefix "arity mismatch"
 498
 499      (pass-if "quiet"
 500        (null? (call-with-warnings
 501                 (lambda ()
 502                   (compile '(cons 'a 'b) #:opts %opts-w-arity)))))
 503
 504      (pass-if "direct application"
 505        (let ((w (call-with-warnings
 506                   (lambda ()
 507                     (compile '((lambda (x y) (or x y)) 1 2 3 4 5)
 508                              #:opts %opts-w-arity
 509                              #:to 'cps)))))
 510          (and (= (length w) 1)
 511               (number? (string-contains (car w)
 512                                         "wrong number of arguments to")))))
 513      (pass-if "local"
 514        (let ((w (call-with-warnings
 515                   (lambda ()
 516                     (compile '(let ((f (lambda (x y) (+ x y))))
 517                                 (f 2))
 518                              #:opts %opts-w-arity
 519                              #:to 'cps)))))
 520          (and (= (length w) 1)
 521               (number? (string-contains (car w)
 522                                         "wrong number of arguments to")))))
 523
 524      (pass-if "global"
 525        (let ((w (call-with-warnings
 526                   (lambda ()
 527                     (compile '(cons 1 2 3 4)
 528                              #:opts %opts-w-arity
 529                              #:to 'cps)))))
 530          (and (= (length w) 1)
 531               (number? (string-contains (car w)
 532                                         "wrong number of arguments to")))))
 533
 534      (pass-if "alias to global"
 535        (let ((w (call-with-warnings
 536                   (lambda ()
 537                     (compile '(let ((f cons)) (f 1 2 3 4))
 538                              #:opts %opts-w-arity
 539                              #:to 'cps)))))
 540          (and (= (length w) 1)
 541               (number? (string-contains (car w)
 542                                         "wrong number of arguments to")))))
 543
 544      (pass-if "alias to lexical to global"
 545        (let ((w (call-with-warnings
 546                   (lambda ()
 547                     (compile '(let ((f number?))
 548                                 (let ((g f))
 549                                   (f 1 2 3 4)))
 550                              #:opts %opts-w-arity
 551                              #:to 'cps)))))
 552          (and (= (length w) 1)
 553               (number? (string-contains (car w)
 554                                         "wrong number of arguments to")))))
 555
 556      (pass-if "alias to lexical"
 557        (let ((w (call-with-warnings
 558                   (lambda ()
 559                     (compile '(let ((f (lambda (x y z) (+ x y z))))
 560                                 (let ((g f))
 561                                   (g 1)))
 562                              #:opts %opts-w-arity
 563                              #:to 'cps)))))
 564          (and (= (length w) 1)
 565               (number? (string-contains (car w)
 566                                         "wrong number of arguments to")))))
 567
 568      (pass-if "letrec"
 569        (let ((w (call-with-warnings
 570                   (lambda ()
 571                     (compile '(letrec ((odd?  (lambda (x) (even? (1- x))))
 572                                        (even? (lambda (x)
 573                                                 (or (= 0 x)
 574                                                     (odd?)))))
 575                                 (odd? 1))
 576                              #:opts %opts-w-arity
 577                              #:to 'cps)))))
 578          (and (= (length w) 1)
 579               (number? (string-contains (car w)
 580                                         "wrong number of arguments to")))))
 581
 582      (pass-if "case-lambda"
 583        (null? (call-with-warnings
 584                 (lambda ()
 585                   (compile '(let ((f (case-lambda
 586                                        ((x)     1)
 587                                        ((x y)   2)
 588                                        ((x y z) 3))))
 589                               (list (f 1)
 590                                     (f 1 2)
 591                                     (f 1 2 3)))
 592                            #:opts %opts-w-arity
 593                            #:to 'cps)))))
 594
 595      (pass-if "case-lambda with wrong number of arguments"
 596        (let ((w (call-with-warnings
 597                   (lambda ()
 598                     (compile '(let ((f (case-lambda
 599                                          ((x)     1)
 600                                          ((x y)   2))))
 601                                 (f 1 2 3))
 602                              #:opts %opts-w-arity
 603                              #:to 'cps)))))
 604          (and (= (length w) 1)
 605               (number? (string-contains (car w)
 606                                         "wrong number of arguments to")))))
 607
 608      (pass-if "case-lambda*"
 609        (null? (call-with-warnings
 610                 (lambda ()
 611                   (compile '(let ((f (case-lambda*
 612                                        ((x #:optional y) 1)
 613                                        ((x #:key y)      2)
 614                                        ((x y #:key z)    3))))
 615                               (list (f 1)
 616                                     (f 1 2)
 617                                     (f #:y 2)
 618                                     (f 1 2 #:z 3)))
 619                            #:opts %opts-w-arity
 620                            #:to 'cps)))))
 621
 622      (pass-if "case-lambda* with wrong arguments"
 623        (let ((w (call-with-warnings
 624                   (lambda ()
 625                     (compile '(let ((f (case-lambda*
 626                                          ((x #:optional y) 1)
 627                                          ((x #:key y)      2)
 628                                          ((x y #:key z)    3))))
 629                                 (list (f)
 630                                       (f 1 #:z 3)))
 631                              #:opts %opts-w-arity
 632                              #:to 'cps)))))
 633          (and (= (length w) 2)
 634               (null? (filter (lambda (w)
 635                                (not
 636                                 (number?
 637                                  (string-contains
 638                                   w "wrong number of arguments to"))))
 639                              w)))))
 640
 641      (pass-if "top-level applicable struct"
 642        (null? (call-with-warnings
 643                (lambda ()
 644                  (compile '(let ((p current-warning-port))
 645                              (p (+ (p) 1))
 646                              (p))
 647                           #:opts %opts-w-arity
 648                           #:to 'cps)))))
 649
 650      (pass-if "top-level applicable struct with wrong arguments"
 651        (let ((w (call-with-warnings
 652                  (lambda ()
 653                    (compile '(let ((p current-warning-port))
 654                                (p 1 2 3))
 655                             #:opts %opts-w-arity
 656                             #:to 'cps)))))
 657          (and (= (length w) 1)
 658               (number? (string-contains (car w)
 659                                         "wrong number of arguments to")))))
 660
 661      (pass-if "local toplevel-defines"
 662        (let ((w (call-with-warnings
 663                   (lambda ()
 664                     (let ((in (open-input-string "
 665                                 (define (g x) (f x))
 666                                 (define (f) 1)")))
 667                       (read-and-compile in
 668                                         #:opts %opts-w-arity
 669                                         #:to 'cps))))))
 670          (and (= (length w) 1)
 671               (number? (string-contains (car w)
 672                                         "wrong number of arguments to")))))
 673
 674      (pass-if "global toplevel alias"
 675        (let ((w (call-with-warnings
 676                   (lambda ()
 677                     (let ((in (open-input-string "
 678                                 (define f cons)
 679                                 (define (g) (f))")))
 680                       (read-and-compile in
 681                                         #:opts %opts-w-arity
 682                                         #:to 'cps))))))
 683          (and (= (length w) 1)
 684               (number? (string-contains (car w)
 685                                         "wrong number of arguments to")))))
 686
 687      (pass-if "local toplevel overrides global"
 688        (null? (call-with-warnings
 689                 (lambda ()
 690                   (let ((in (open-input-string "
 691                               (define (cons) 0)
 692                               (define (foo x) (cons))")))
 693                     (read-and-compile in
 694                                       #:opts %opts-w-arity
 695                                       #:to 'cps))))))
 696
 697      (pass-if "keyword not passed and quiet"
 698        (null? (call-with-warnings
 699                 (lambda ()
 700                   (compile '(let ((f (lambda* (x #:key y) y)))
 701                               (f 2))
 702                            #:opts %opts-w-arity
 703                            #:to 'cps)))))
 704
 705      (pass-if "keyword passed and quiet"
 706        (null? (call-with-warnings
 707                 (lambda ()
 708                   (compile '(let ((f (lambda* (x #:key y) y)))
 709                               (f 2 #:y 3))
 710                            #:opts %opts-w-arity
 711                            #:to 'cps)))))
 712
 713      (pass-if "keyword passed to global and quiet"
 714        (null? (call-with-warnings
 715                 (lambda ()
 716                   (let ((in (open-input-string "
 717                               (use-modules (system base compile))
 718                               (compile '(+ 2 3) #:env (current-module))")))
 719                     (read-and-compile in
 720                                       #:opts %opts-w-arity
 721                                       #:to 'cps))))))
 722
 723      (pass-if "extra keyword"
 724        (let ((w (call-with-warnings
 725                   (lambda ()
 726                     (compile '(let ((f (lambda* (x #:key y) y)))
 727                                 (f 2 #:Z 3))
 728                              #:opts %opts-w-arity
 729                              #:to 'cps)))))
 730          (and (= (length w) 1)
 731               (number? (string-contains (car w)
 732                                         "wrong number of arguments to")))))
 733
 734      (pass-if "extra keywords allowed"
 735        (null? (call-with-warnings
 736                 (lambda ()
 737                   (compile '(let ((f (lambda* (x #:key y #:allow-other-keys)
 738                                        y)))
 739                               (f 2 #:Z 3))
 740                            #:opts %opts-w-arity
 741                            #:to 'cps))))))
 742
 743    (with-test-prefix "format"
 744
 745      (pass-if "quiet (no args)"
 746        (null? (call-with-warnings
 747                (lambda ()
 748                  (compile '(format #t "hey!")
 749                           #:opts %opts-w-format
 750                           #:to 'cps)))))
 751
 752      (pass-if "quiet (1 arg)"
 753        (null? (call-with-warnings
 754                (lambda ()
 755                  (compile '(format #t "hey ~A!" "you")
 756                           #:opts %opts-w-format
 757                           #:to 'cps)))))
 758
 759      (pass-if "quiet (2 args)"
 760        (null? (call-with-warnings
 761                (lambda ()
 762                  (compile '(format #t "~A ~A!" "hello" "world")
 763                           #:opts %opts-w-format
 764                           #:to 'cps)))))
 765
 766      (pass-if "wrong port arg"
 767        (let ((w (call-with-warnings
 768                  (lambda ()
 769                    (compile '(format 10 "foo")
 770                             #:opts %opts-w-format
 771                             #:to 'cps)))))
 772          (and (= (length w) 1)
 773               (number? (string-contains (car w)
 774                                         "wrong port argument")))))
 775
 776      (pass-if "non-literal format string"
 777        (let ((w (call-with-warnings
 778                  (lambda ()
 779                    (compile '(format #f fmt)
 780                             #:opts %opts-w-format
 781                             #:to 'cps)))))
 782          (and (= (length w) 1)
 783               (number? (string-contains (car w)
 784                                         "non-literal format string")))))
 785
 786      (pass-if "non-literal format string using gettext"
 787        (null? (call-with-warnings
 788                (lambda ()
 789                  (compile '(format #t (gettext "~A ~A!") "hello" "world")
 790                           #:opts %opts-w-format
 791                           #:to 'cps)))))
 792
 793      (pass-if "non-literal format string using gettext as _"
 794        (null? (call-with-warnings
 795                (lambda ()
 796                  (compile '(format #t (_ "~A ~A!") "hello" "world")
 797                           #:opts %opts-w-format
 798                           #:to 'cps)))))
 799
 800      (pass-if "non-literal format string using gettext as top-level _"
 801        (null? (call-with-warnings
 802                (lambda ()
 803                  (compile '(begin
 804                              (define (_ s) (gettext s "my-domain"))
 805                              (format #t (_ "~A ~A!") "hello" "world"))
 806                           #:opts %opts-w-format
 807                           #:to 'cps)))))
 808
 809      (pass-if "non-literal format string using gettext as module-ref _"
 810        (null? (call-with-warnings
 811                (lambda ()
 812                  (compile '(format #t ((@@ (foo) _) "~A ~A!") "hello" "world")
 813                           #:opts %opts-w-format
 814                           #:to 'cps)))))
 815
 816      (pass-if "non-literal format string using gettext as lexical _"
 817        (null? (call-with-warnings
 818                (lambda ()
 819                  (compile '(let ((_ (lambda (s)
 820                                       (gettext s "my-domain"))))
 821                              (format #t (_ "~A ~A!") "hello" "world"))
 822                           #:opts %opts-w-format
 823                           #:to 'cps)))))
 824
 825      (pass-if "non-literal format string using ngettext"
 826        (null? (call-with-warnings
 827                (lambda ()
 828                  (compile '(format #t
 829                                    (ngettext "~a thing" "~a things" n "dom") n)
 830                           #:opts %opts-w-format
 831                           #:to 'cps)))))
 832
 833      (pass-if "non-literal format string using ngettext as N_"
 834        (null? (call-with-warnings
 835                (lambda ()
 836                  (compile '(format #t (N_ "~a thing" "~a things" n) n)
 837                           #:opts %opts-w-format
 838                           #:to 'cps)))))
 839
 840      (pass-if "non-literal format string with (define _ gettext)"
 841        (null? (call-with-warnings
 842                (lambda ()
 843                  (compile '(begin
 844                              (define _ gettext)
 845                              (define (foo)
 846                                (format #t (_ "~A ~A!") "hello" "world")))
 847                           #:opts %opts-w-format
 848                           #:to 'cps)))))
 849
 850      (pass-if "wrong format string"
 851        (let ((w (call-with-warnings
 852                  (lambda ()
 853                    (compile '(format #f 'not-a-string)
 854                             #:opts %opts-w-format
 855                             #:to 'cps)))))
 856          (and (= (length w) 1)
 857               (number? (string-contains (car w)
 858                                         "wrong format string")))))
 859
 860      (pass-if "wrong number of args"
 861        (let ((w (call-with-warnings
 862                  (lambda ()
 863                    (compile '(format "shbweeb")
 864                             #:opts %opts-w-format
 865                             #:to 'cps)))))
 866          (and (= (length w) 1)
 867               (number? (string-contains (car w)
 868                                         "wrong number of arguments")))))
 869
 870      (pass-if "~%, ~~, ~&, ~t, ~_, ~!, ~|, ~/, ~q and ~\\n"
 871        (null? (call-with-warnings
 872                (lambda ()
 873                  (compile '((@ (ice-9 format) format) some-port
 874                             "~&~3_~~ ~\n~12they~% ~!~|~/~q")
 875                           #:opts %opts-w-format
 876                           #:to 'cps)))))
 877
 878      (pass-if "one missing argument"
 879        (let ((w (call-with-warnings
 880                  (lambda ()
 881                    (compile '(format some-port "foo ~A~%")
 882                             #:opts %opts-w-format
 883                             #:to 'cps)))))
 884          (and (= (length w) 1)
 885               (number? (string-contains (car w)
 886                                         "expected 1, got 0")))))
 887
 888      (pass-if "one missing argument, gettext"
 889        (let ((w (call-with-warnings
 890                  (lambda ()
 891                    (compile '(format some-port (gettext "foo ~A~%"))
 892                             #:opts %opts-w-format
 893                             #:to 'cps)))))
 894          (and (= (length w) 1)
 895               (number? (string-contains (car w)
 896                                         "expected 1, got 0")))))
 897
 898      (pass-if "two missing arguments"
 899        (let ((w (call-with-warnings
 900                  (lambda ()
 901                    (compile '((@ (ice-9 format) format) #f
 902                               "foo ~10,2f and bar ~S~%")
 903                             #:opts %opts-w-format
 904                             #:to 'cps)))))
 905          (and (= (length w) 1)
 906               (number? (string-contains (car w)
 907                                         "expected 2, got 0")))))
 908
 909      (pass-if "one given, one missing argument"
 910        (let ((w (call-with-warnings
 911                  (lambda ()
 912                    (compile '(format #t "foo ~A and ~S~%" hey)
 913                             #:opts %opts-w-format
 914                             #:to 'cps)))))
 915          (and (= (length w) 1)
 916               (number? (string-contains (car w)
 917                                         "expected 2, got 1")))))
 918
 919      (pass-if "too many arguments"
 920        (let ((w (call-with-warnings
 921                  (lambda ()
 922                    (compile '(format #t "foo ~A~%" 1 2)
 923                             #:opts %opts-w-format
 924                             #:to 'cps)))))
 925          (and (= (length w) 1)
 926               (number? (string-contains (car w)
 927                                         "expected 1, got 2")))))
 928
 929      (pass-if "~h"
 930        (null? (call-with-warnings
 931                  (lambda ()
 932                    (compile '((@ (ice-9 format) format) #t
 933                               "foo ~h ~a~%" 123.4 'bar)
 934                             #:opts %opts-w-format
 935                             #:to 'cps)))))
 936
 937      (pass-if "~:h with locale object"
 938        (null? (call-with-warnings
 939                  (lambda ()
 940                    (compile '((@ (ice-9 format) format) #t
 941                               "foo ~:h~%" 123.4 %global-locale)
 942                             #:opts %opts-w-format
 943                             #:to 'cps)))))
 944
 945      (pass-if "~:h without locale object"
 946        (let ((w (call-with-warnings
 947                  (lambda ()
 948                    (compile '((@ (ice-9 format) format) #t "foo ~,2:h" 123.4)
 949                             #:opts %opts-w-format
 950                             #:to 'cps)))))
 951          (and (= (length w) 1)
 952               (number? (string-contains (car w)
 953                                         "expected 2, got 1")))))
 954
 955      (with-test-prefix "conditionals"
 956        (pass-if "literals"
 957         (null? (call-with-warnings
 958                 (lambda ()
 959                   (compile '((@ (ice-9 format) format) #f "~A ~[foo~;bar~;baz~;~] ~10,2f"
 960                                     'a 1 3.14)
 961                            #:opts %opts-w-format
 962                            #:to 'cps)))))
 963
 964        (pass-if "literals with selector"
 965          (let ((w (call-with-warnings
 966                    (lambda ()
 967                      (compile '((@ (ice-9 format) format) #f "~2[foo~;bar~;baz~;~] ~A"
 968                                        1 'dont-ignore-me)
 969                               #:opts %opts-w-format
 970                               #:to 'cps)))))
 971            (and (= (length w) 1)
 972                 (number? (string-contains (car w)
 973                                           "expected 1, got 2")))))
 974
 975        (pass-if "escapes (exact count)"
 976          (let ((w (call-with-warnings
 977                    (lambda ()
 978                      (compile '((@ (ice-9 format) format) #f "~[~a~;~a~]")
 979                               #:opts %opts-w-format
 980                               #:to 'cps)))))
 981            (and (= (length w) 1)
 982                 (number? (string-contains (car w)
 983                                           "expected 2, got 0")))))
 984
 985        (pass-if "escapes with selector"
 986          (let ((w (call-with-warnings
 987                    (lambda ()
 988                      (compile '((@ (ice-9 format) format) #f "~1[chbouib~;~a~]")
 989                               #:opts %opts-w-format
 990                               #:to 'cps)))))
 991            (and (= (length w) 1)
 992                 (number? (string-contains (car w)
 993                                           "expected 1, got 0")))))
 994
 995        (pass-if "escapes, range"
 996          (let ((w (call-with-warnings
 997                    (lambda ()
 998                      (compile '((@ (ice-9 format) format) #f "~[chbouib~;~a~;~2*~a~]")
 999                               #:opts %opts-w-format
1000                               #:to 'cps)))))
1001            (and (= (length w) 1)
1002                 (number? (string-contains (car w)
1003                                           "expected 1 to 4, got 0")))))
1004
1005        (pass-if "@"
1006          (let ((w (call-with-warnings
1007                    (lambda ()
1008                      (compile '((@ (ice-9 format) format) #f "~@[temperature=~d~]")
1009                               #:opts %opts-w-format
1010                               #:to 'cps)))))
1011            (and (= (length w) 1)
1012                 (number? (string-contains (car w)
1013                                           "expected 1, got 0")))))
1014
1015        (pass-if "nested"
1016          (let ((w (call-with-warnings
1017                    (lambda ()
1018                      (compile '((@ (ice-9 format) format) #f "~:[~[hey~;~a~;~va~]~;~3*~]")
1019                               #:opts %opts-w-format
1020                               #:to 'cps)))))
1021            (and (= (length w) 1)
1022                 (number? (string-contains (car w)
1023                                           "expected 2 to 4, got 0")))))
1024
1025        (pass-if "unterminated"
1026          (let ((w (call-with-warnings
1027                    (lambda ()
1028                      (compile '((@ (ice-9 format) format) #f "~[unterminated")
1029                               #:opts %opts-w-format
1030                               #:to 'cps)))))
1031            (and (= (length w) 1)
1032                 (number? (string-contains (car w)
1033                                           "unterminated conditional")))))
1034
1035        (pass-if "unexpected ~;"
1036          (let ((w (call-with-warnings
1037                    (lambda ()
1038                      (compile '((@ (ice-9 format) format) #f "foo~;bar")
1039                               #:opts %opts-w-format
1040                               #:to 'cps)))))
1041            (and (= (length w) 1)
1042                 (number? (string-contains (car w)
1043                                           "unexpected")))))
1044
1045        (pass-if "unexpected ~]"
1046          (let ((w (call-with-warnings
1047                    (lambda ()
1048                      (compile '((@ (ice-9 format) format) #f "foo~]")
1049                               #:opts %opts-w-format
1050                               #:to 'cps)))))
1051            (and (= (length w) 1)
1052                 (number? (string-contains (car w)
1053                                           "unexpected"))))))
1054
1055      (pass-if "~{...~}"
1056        (null? (call-with-warnings
1057                (lambda ()
1058                  (compile '((@ (ice-9 format) format) #f "~A ~{~S~} ~A"
1059                                    'hello '("ladies" "and")
1060                                    'gentlemen)
1061                           #:opts %opts-w-format
1062                           #:to 'cps)))))
1063
1064      (pass-if "~{...~}, too many args"
1065        (let ((w (call-with-warnings
1066                  (lambda ()
1067                    (compile '((@ (ice-9 format) format) #f "~{~S~}" 1 2 3)
1068                             #:opts %opts-w-format
1069                             #:to 'cps)))))
1070          (and (= (length w) 1)
1071               (number? (string-contains (car w)
1072                                         "expected 1, got 3")))))
1073
1074      (pass-if "~@{...~}"
1075        (null? (call-with-warnings
1076                (lambda ()
1077                  (compile '((@ (ice-9 format) format) #f "~@{~S~}" 1 2 3)
1078                           #:opts %opts-w-format
1079                           #:to 'cps)))))
1080
1081      (pass-if "~@{...~}, too few args"
1082        (let ((w (call-with-warnings
1083                  (lambda ()
1084                    (compile '((@ (ice-9 format) format) #f "~A ~@{~S~}")
1085                             #:opts %opts-w-format
1086                             #:to 'cps)))))
1087          (and (= (length w) 1)
1088               (number? (string-contains (car w)
1089                                         "expected at least 1, got 0")))))
1090
1091      (pass-if "unterminated ~{...~}"
1092        (let ((w (call-with-warnings
1093                  (lambda ()
1094                    (compile '((@ (ice-9 format) format) #f "~{")
1095                             #:opts %opts-w-format
1096                             #:to 'cps)))))
1097          (and (= (length w) 1)
1098               (number? (string-contains (car w)
1099                                         "unterminated")))))
1100
1101      (pass-if "~(...~)"
1102        (null? (call-with-warnings
1103                (lambda ()
1104                  (compile '((@ (ice-9 format) format) #f "~:@(~A ~A~)" 'foo 'bar)
1105                           #:opts %opts-w-format
1106                           #:to 'cps)))))
1107
1108      (pass-if "~v"
1109        (let ((w (call-with-warnings
1110                  (lambda ()
1111                    (compile '((@ (ice-9 format) format) #f "~v_foo")
1112                             #:opts %opts-w-format
1113                             #:to 'cps)))))
1114          (and (= (length w) 1)
1115               (number? (string-contains (car w)
1116                                         "expected 1, got 0")))))
1117      (pass-if "~v:@y"
1118        (null? (call-with-warnings
1119                (lambda ()
1120                  (compile '((@ (ice-9 format) format) #f "~v:@y" 1 123)
1121                           #:opts %opts-w-format
1122                           #:to 'cps)))))
1123
1124
1125      (pass-if "~*"
1126        (let ((w (call-with-warnings
1127                  (lambda ()
1128                    (compile '((@ (ice-9 format) format) #f "~2*~a" 'a 'b)
1129                             #:opts %opts-w-format
1130                             #:to 'cps)))))
1131          (and (= (length w) 1)
1132               (number? (string-contains (car w)
1133                                         "expected 3, got 2")))))
1134
1135      (pass-if "~?"
1136        (null? (call-with-warnings
1137                (lambda ()
1138                  (compile '((@ (ice-9 format) format) #f "~?" "~d ~d" '(1 2))
1139                           #:opts %opts-w-format
1140                           #:to 'cps)))))
1141
1142      (pass-if "~^"
1143        (null? (call-with-warnings
1144                (lambda ()
1145                  (compile '((@ (ice-9 format) format) #f "~a ~^ ~a" 0 1)
1146                           #:opts %opts-w-format
1147                           #:to 'cps)))))
1148
1149      (pass-if "~^, too few args"
1150        (let ((w (call-with-warnings
1151                  (lambda ()
1152                    (compile '((@ (ice-9 format) format) #f "~a ~^ ~a")
1153                             #:opts %opts-w-format
1154                             #:to 'cps)))))
1155          (and (= (length w) 1)
1156               (number? (string-contains (car w)
1157                                         "expected at least 1, got 0")))))
1158
1159      (pass-if "parameters: +,-,#, and '"
1160        (null? (call-with-warnings
1161                (lambda ()
1162                  (compile '((@ (ice-9 format) format) some-port
1163                             "~#~ ~,,-2f ~,,+2f ~'A~" 1234 1234)
1164                           #:opts %opts-w-format
1165                           #:to 'cps)))))
1166
1167      (pass-if "complex 1"
1168        (let ((w (call-with-warnings
1169                  (lambda ()
1170                    (compile '((@ (ice-9 format) format) #f
1171                                      "~4@S    ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n"
1172                                      1 2 3 4 5 6)
1173                             #:opts %opts-w-format
1174                             #:to 'cps)))))
1175          (and (= (length w) 1)
1176               (number? (string-contains (car w)
1177                                         "expected 4, got 6")))))
1178
1179      (pass-if "complex 2"
1180        (let ((w (call-with-warnings
1181                  (lambda ()
1182                    (compile '((@ (ice-9 format) format) #f
1183                                      "~:(~A~) Commands~:[~; [abbrev]~]:~2%"
1184                                      1 2 3 4)
1185                             #:opts %opts-w-format
1186                             #:to 'cps)))))
1187          (and (= (length w) 1)
1188               (number? (string-contains (car w)
1189                                         "expected 2, got 4")))))
1190
1191      (pass-if "complex 3"
1192        (let ((w (call-with-warnings
1193                  (lambda ()
1194                    (compile '((@ (ice-9 format) format) #f "~9@a~:[~*~3_~;~3d~] ~v:@y~%")
1195                             #:opts %opts-w-format
1196                             #:to 'cps)))))
1197          (and (= (length w) 1)
1198               (number? (string-contains (car w)
1199                                         "expected 5, got 0")))))
1200
1201      (pass-if "ice-9 format"
1202        (let ((w (call-with-warnings
1203                  (lambda ()
1204                    (let ((in (open-input-string
1205                               "(use-modules ((ice-9 format)
1206                                  #:renamer (symbol-prefix-proc 'i9-)))
1207                                (i9-format #t \"yo! ~A\" 1 2)")))
1208                      (read-and-compile in
1209                                        #:opts %opts-w-format
1210                                        #:to 'cps))))))
1211          (and (= (length w) 1)
1212               (number? (string-contains (car w)
1213                                         "expected 1, got 2")))))
1214
1215      (pass-if "not format"
1216        (null? (call-with-warnings
1217                (lambda ()
1218                  (compile '(let ((format chbouib))
1219                              (format #t "not ~A a format string"))
1220                           #:opts %opts-w-format
1221                           #:to 'cps)))))
1222
1223      (with-test-prefix "simple-format"
1224
1225        (pass-if "good"
1226          (null? (call-with-warnings
1227                  (lambda ()
1228                    (compile '(simple-format #t "foo ~a bar ~s ~%~~" 1 2)
1229                             #:opts %opts-w-format
1230                             #:to 'cps)))))
1231
1232        (pass-if "wrong number of args"
1233          (let ((w (call-with-warnings
1234                    (lambda ()
1235                      (compile '(simple-format #t "foo ~a ~s~%" 'one-missing)
1236                               #:opts %opts-w-format
1237                               #:to 'cps)))))
1238            (and (= (length w) 1)
1239                 (number? (string-contains (car w) "wrong number")))))
1240
1241        (pass-if "unsupported"
1242          (let ((w (call-with-warnings
1243                    (lambda ()
1244                      (compile '(simple-format #t "foo ~x~%" 16)
1245                               #:opts %opts-w-format
1246                               #:to 'cps)))))
1247            (and (= (length w) 1)
1248                 (number? (string-contains (car w) "unsupported format option")))))
1249
1250        (pass-if "unsupported, gettext"
1251          (let ((w (call-with-warnings
1252                    (lambda ()
1253                      (compile '(simple-format #t (gettext "foo ~2f~%") 3.14)
1254                               #:opts %opts-w-format
1255                               #:to 'cps)))))
1256            (and (= (length w) 1)
1257                 (number? (string-contains (car w) "unsupported format option")))))
1258
1259        (pass-if "unsupported, ngettext"
1260          (let ((w (call-with-warnings
1261                    (lambda ()
1262                      (compile '(simple-format #t (ngettext "s ~x" "p ~x" x) x)
1263                               #:opts %opts-w-format
1264                               #:to 'cps)))))
1265            (and (= (length w) 1)
1266                 (number? (string-contains (car w) "unsupported format option")))))))
1267
1268    (with-test-prefix "duplicate-case-datum"
1269
1270      (pass-if "quiet"
1271        (null? (call-with-warnings
1272                 (lambda ()
1273                   (compile '(case x ((1) 'one) ((2) 'two))
1274                            #:opts %opts-w-duplicate-case-datum
1275                            #:to 'cps)))))
1276
1277      (pass-if "one duplicate"
1278        (let ((w (call-with-warnings
1279                   (lambda ()
1280                     (compile '(case x
1281                                 ((1) 'one)
1282                                 ((2) 'two)
1283                                 ((1) 'one-again))
1284                              #:opts %opts-w-duplicate-case-datum
1285                              #:to 'cps)))))
1286          (and (= (length w) 1)
1287               (number? (string-contains (car w) "duplicate")))))
1288
1289      (pass-if "one duplicate"
1290        (let ((w (call-with-warnings
1291                   (lambda ()
1292                     (compile '(case x
1293                                 ((1 2 3) 'a)
1294                                 ((1)     'one))
1295                              #:opts %opts-w-duplicate-case-datum
1296                              #:to 'cps)))))
1297          (and (= (length w) 1)
1298               (number? (string-contains (car w) "duplicate"))))))
1299
1300    (with-test-prefix "bad-case-datum"
1301
1302      (pass-if "quiet"
1303        (null? (call-with-warnings
1304                 (lambda ()
1305                   (compile '(case x ((1) 'one) ((2) 'two))
1306                            #:opts %opts-w-bad-case-datum
1307                            #:to 'cps)))))
1308
1309      (pass-if "not eqv?"
1310        (let ((w (call-with-warnings
1311                   (lambda ()
1312                     (compile '(case x
1313                                 ((1)     'one)
1314                                 (("bad") 'bad))
1315                              #:opts %opts-w-bad-case-datum
1316                              #:to 'cps)))))
1317          (and (= (length w) 1)
1318               (number? (string-contains (car w)
1319                                         "cannot be meaningfully compared")))))
1320
1321      (pass-if "one clause element not eqv?"
1322        (let ((w (call-with-warnings
1323                   (lambda ()
1324                     (compile '(case x
1325                                 ((1 (2) 3) 'a))
1326                              #:opts %opts-w-duplicate-case-datum
1327                              #:to 'cps)))))
1328          (and (= (length w) 1)
1329               (number? (string-contains (car w)
1330                                         "cannot be meaningfully compared")))))))
1331
1332 ;; Local Variables:
1333 ;; eval: (put 'pass-if-primitives-resolved 'scheme-indent-function 1)
1334 ;; eval: (put 'pass-if-tree-il->scheme 'scheme-indent-function 1)
1335 ;; End: