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