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