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