X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/0353a2d817d0d5b3c563af4fa1b5c7c1fe7ce3a6..4df52c924dad7c7450dea61186b0820b5da844d1:/test-suite/tests/tree-il.test

diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 1a11d354f..5d12f0c48 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -1,7 +1,7 @@
 ;;;; tree-il.test --- test suite for compiling tree-il   -*- scheme -*-
 ;;;; Andy Wingo <wingo@pobox.com> --- May 2009
 ;;;;
-;;;; 	Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;; 	Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -69,38 +69,6 @@
          (pat (guard guard-exp) #t)
          (_ #f))))))
 
-(define peval
-  ;; The partial evaluator.
-  (@@ (language tree-il optimize) peval))
-
-(define-syntax pass-if-peval
-  (syntax-rules (resolve-primitives)
-    ((_ in pat)
-     (pass-if-peval in pat
-                    (compile 'in #:from 'scheme #:to 'tree-il)))
-    ((_ resolve-primitives in pat)
-     (pass-if-peval in pat
-                    (expand-primitives!
-                     (resolve-primitives!
-                      (compile 'in #:from 'scheme #:to 'tree-il)
-                      (current-module)))))
-    ((_ in pat code)
-     (pass-if 'in
-       (let ((evaled (unparse-tree-il (peval code))))
-         (pmatch evaled
-           (pat #t)
-           (_   (pk 'peval-mismatch)
-                ((@ (ice-9 pretty-print) pretty-print)
-                    'in)
-                (newline)
-                ((@ (ice-9 pretty-print) pretty-print)
-                    evaled)
-                (newline)
-                ((@ (ice-9 pretty-print) pretty-print)
-                    'pat)
-                (newline)
-                #f)))))))
-
 
 (with-test-prefix "tree-il->scheme"
   (pass-if-tree-il->scheme
@@ -116,15 +84,15 @@
    (begin (void) (const 1))
    (program () (std-prelude 0 0 #f) (label _) (const 1) (call return 1)))
   (assert-tree-il->glil
-   (apply (primitive +) (void) (const 1))
+   (primcall + (void) (const 1))
    (program () (std-prelude 0 0 #f) (label _) (void) (call add1 1) (call return 1))))
 
 (with-test-prefix "application"
   (assert-tree-il->glil
-   (apply (toplevel foo) (const 1))
+   (call (toplevel foo) (const 1))
    (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (const 1) (call tail-call 1)))
   (assert-tree-il->glil
-   (begin (apply (toplevel foo) (const 1)) (void))
+   (begin (call (toplevel foo) (const 1)) (void))
    (program () (std-prelude 0 0 #f) (label _) (call new-frame 0) (toplevel ref foo) (const 1) (mv-call 1 ,l1)
             (call drop 1) (branch br ,l2)
             (label ,l3) (mv-bind 0 #f)
@@ -132,7 +100,7 @@
             (void) (call return 1))
    (and (eq? l1 l3) (eq? l2 l4)))
   (assert-tree-il->glil
-   (apply (toplevel foo) (apply (toplevel bar)))
+   (call (toplevel foo) (call (toplevel bar)))
    (program ()  (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call new-frame 0) (toplevel ref bar) (call call 0)
             (call tail-call 1))))
 
@@ -151,7 +119,7 @@
    (eq? l1 l3) (eq? l2 l4))
 
   (assert-tree-il->glil
-   (apply (primitive null?) (if (toplevel foo) (const 1) (const 2)))
+   (primcall null? (if (toplevel foo) (const 1) (const 2)))
    (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1)
             (const 1) (branch br ,l2)
                     (label ,l3) (const 2) (label ,l4)
@@ -168,7 +136,7 @@
    (program () (std-prelude 0 0 #f) (label _) (const #f) (call return 1)))
 
   (assert-tree-il->glil
-   (apply (primitive null?) (primitive +))
+   (primcall null? (primitive +))
    (program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call null? 1)
             (call return 1))))
 
@@ -180,7 +148,7 @@
             (lexical #t #f ref 0) (call return 1)
             (unbind)))
 
-  (assert-tree-il->glil without-partial-evaluation
+  (assert-tree-il->glil with-options (#:partial-eval? #f #:cse? #f)
    (let (x) (y) ((const 1)) (begin (lexical x y) (const #f)))
    (program () (std-prelude 0 1 #f) (label _)
             (const 1) (bind (x #f 0)) (lexical #t #f set 0)
@@ -188,7 +156,7 @@
             (unbind)))
 
   (assert-tree-il->glil without-partial-evaluation
-   (let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y)))
+   (let (x) (y) ((const 1)) (primcall null? (lexical x y)))
    (program () (std-prelude 0 1 #f) (label _)
             (const 1) (bind (x #f 0)) (lexical #t #f set 0)
             (lexical #t #f ref 0) (call null? 1) (call return 1)
@@ -198,7 +166,7 @@
   (assert-tree-il->glil
    ;; unreferenced sets may be optimized away -- make sure they are ref'd
    (let (x) (y) ((const 1))
-        (set! (lexical x y) (apply (primitive 1+) (lexical x y))))
+        (set! (lexical x y) (primcall 1+ (lexical x y))))
    (program () (std-prelude 0 1 #f) (label _)
             (const 1) (bind (x #t 0)) (lexical #t #t box 0)
             (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
@@ -207,7 +175,7 @@
 
   (assert-tree-il->glil
    (let (x) (y) ((const 1))
-        (begin (set! (lexical x y) (apply (primitive 1+) (lexical x y)))
+        (begin (set! (lexical x y) (primcall 1+ (lexical x y)))
                (lexical x y)))
    (program () (std-prelude 0 1 #f) (label _)
             (const 1) (bind (x #t 0)) (lexical #t #t box 0)
@@ -217,8 +185,8 @@
 
   (assert-tree-il->glil
    (let (x) (y) ((const 1))
-     (apply (primitive null?)
-            (set! (lexical x y) (apply (primitive 1+) (lexical x y)))))
+     (primcall null?
+           (set! (lexical x y) (primcall 1+ (lexical x y)))))
    (program () (std-prelude 0 1 #f) (label _)
             (const 1) (bind (x #t 0)) (lexical #t #t box 0)
             (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) (void)
@@ -239,7 +207,7 @@
             (const #f) (call return 1)))
 
   (assert-tree-il->glil
-   (apply (primitive null?) (@ (foo) bar))
+   (primcall null? (@ (foo) bar))
    (program () (std-prelude 0 0 #f) (label _)
             (module public ref (foo) bar)
             (call null? 1) (call return 1)))
@@ -257,7 +225,7 @@
             (const #f) (call return 1)))
 
   (assert-tree-il->glil
-   (apply (primitive null?) (@@ (foo) bar))
+   (primcall null? (@@ (foo) bar))
    (program () (std-prelude 0 0 #f) (label _)
             (module private ref (foo) bar)
             (call null? 1) (call return 1))))
@@ -276,7 +244,7 @@
             (const #f) (call return 1)))
 
   (assert-tree-il->glil
-   (apply (primitive null?) (set! (@ (foo) bar) (const 2)))
+   (primcall null? (set! (@ (foo) bar) (const 2)))
    (program () (std-prelude 0 0 #f) (label _)
             (const 2) (module public set (foo) bar)
             (void) (call null? 1) (call return 1)))
@@ -294,7 +262,7 @@
             (const #f) (call return 1)))
 
   (assert-tree-il->glil
-   (apply (primitive null?) (set! (@@ (foo) bar) (const 2)))
+   (primcall null? (set! (@@ (foo) bar) (const 2)))
    (program () (std-prelude 0 0 #f) (label _)
             (const 2) (module private set (foo) bar)
             (void) (call null? 1) (call return 1))))
@@ -313,7 +281,7 @@
             (const #f) (call return 1)))
 
   (assert-tree-il->glil
-   (apply (primitive null?) (toplevel bar))
+   (primcall null? (toplevel bar))
    (program () (std-prelude 0 0 #f) (label _)
             (toplevel ref bar)
             (call null? 1) (call return 1))))
@@ -332,7 +300,7 @@
             (const #f) (call return 1)))
 
   (assert-tree-il->glil
-   (apply (primitive null?) (set! (toplevel bar) (const 2)))
+   (primcall null? (set! (toplevel bar) (const 2)))
    (program () (std-prelude 0 0 #f) (label _)
             (const 2) (toplevel set bar)
             (void) (call null? 1) (call return 1))))
@@ -351,7 +319,7 @@
             (const #f) (call return 1)))
 
   (assert-tree-il->glil
-   (apply (primitive null?) (define bar (const 2)))
+   (primcall null? (define bar (const 2)))
    (program () (std-prelude 0 0 #f) (label _)
             (const 2) (toplevel define bar)
             (void) (call null? 1) (call return 1))))
@@ -369,7 +337,7 @@
 
   (assert-tree-il->glil
    ;; This gets simplified by `peval'.
-   (apply (primitive null?) (const 2))
+   (primcall null? (const 2))
    (program () (std-prelude 0 0 #f) (label _)
             (const #f) (call return 1))))
 
@@ -377,7 +345,7 @@
   ;; simple bindings -> let
   (assert-tree-il->glil without-partial-evaluation
    (letrec (x y) (x1 y1) ((const 10) (const 20))
-           (apply (toplevel foo) (lexical x x1) (lexical y y1)))
+           (call (toplevel foo) (lexical x x1) (lexical y y1)))
    (program () (std-prelude 0 2 #f) (label _)
             (const 10) (const 20)
             (bind (x #f 0) (y #f 1))
@@ -389,8 +357,8 @@
 
   ;; complex bindings -> box and set! within let
   (assert-tree-il->glil without-partial-evaluation
-   (letrec (x y) (x1 y1) ((apply (toplevel foo)) (apply (toplevel bar)))
-           (apply (primitive +) (lexical x x1) (lexical y y1)))
+   (letrec (x y) (x1 y1) ((call (toplevel foo)) (call (toplevel bar)))
+           (primcall + (lexical x x1) (lexical y y1)))
    (program () (std-prelude 0 4 #f) (label _)
             (void) (void) ;; what are these?
             (bind (x #t 0) (y #t 1))
@@ -399,14 +367,16 @@
             (call new-frame 0) (toplevel ref bar) (call call 0)
             (bind (x #f 2) (y #f 3)) (lexical #t #f set 3) (lexical #t #f set 2)
             (lexical #t #f ref 2) (lexical #t #t set 0)
-            (lexical #t #f ref 3) (lexical #t #t set 1) (unbind)
+            (lexical #t #f ref 3) (lexical #t #t set 1)
+            (void) (lexical #t #f set 2) (void) (lexical #t #f set 3) ;; clear bindings
+            (unbind)
             (lexical #t #t ref 0) (lexical #t #t ref 1)
             (call add 2) (call return 1) (unbind)))
   
   ;; complex bindings in letrec* -> box and set! in order
   (assert-tree-il->glil without-partial-evaluation
-   (letrec* (x y) (x1 y1) ((apply (toplevel foo)) (apply (toplevel bar)))
-            (apply (primitive +) (lexical x x1) (lexical y y1)))
+   (letrec* (x y) (x1 y1) ((call (toplevel foo)) (call (toplevel bar)))
+            (primcall + (lexical x x1) (lexical y y1)))
    (program () (std-prelude 0 2 #f) (label _)
             (void) (void) ;; what are these?
             (bind (x #t 0) (y #t 1))
@@ -525,29 +495,46 @@
 
   (assert-tree-il->glil
    ;; This gets simplified by `peval'.
-   (apply (primitive null?) (begin (const #f) (const 2)))
+   (primcall null? (begin (const #f) (const 2)))
    (program () (std-prelude 0 0 #f) (label _)
             (const #f) (call return 1))))
 
 (with-test-prefix "values"
   (assert-tree-il->glil
-   (apply (primitive values)
-          (apply (primitive values) (const 1) (const 2)))
+   (primcall values
+             (primcall values (const 1) (const 2)))
    (program () (std-prelude 0 0 #f) (label _)
             (const 1) (call return 1)))
 
   (assert-tree-il->glil
-   (apply (primitive values)
-          (apply (primitive values) (const 1) (const 2))
-          (const 3))
+   (primcall values
+             (primcall values (const 1) (const 2))
+             (const 3))
    (program () (std-prelude 0 0 #f) (label _)
             (const 1) (const 3) (call return/values 2)))
 
   (assert-tree-il->glil
-   (apply (primitive +)
-          (apply (primitive values) (const 1) (const 2)))
+   (primcall +
+             (primcall values (const 1) (const 2)))
+   (program () (std-prelude 0 0 #f) (label _)
+            (const 1) (call return 1)))
+
+  ;; Testing `(values foo)' in push context with RA.
+  (assert-tree-il->glil without-partial-evaluation
+   (primcall cdr
+             (letrec (lp) (#{lp ~V9KrhVD4PFEL6oCTrLg3A}#)
+                     ((lambda ((name . lp))
+                        (lambda-case ((() #f #f #f () ())
+                                      (primcall values (const (one two)))))))
+                     (call (lexical lp #{lp ~V9KrhVD4PFEL6oCTrLg3A}#))))
    (program () (std-prelude 0 0 #f) (label _)
-            (const 1) (call return 1))))
+            (branch br _) ;; entering the fix, jump to :2
+            ;; :1 body of lp, jump to :3
+            (label _) (bind) (const (one two)) (branch br _) (unbind)
+            ;; :2 initial call of lp, jump to :1
+            (label _) (bind) (branch br _) (label _) (unbind)
+            ;; :3 the push continuation
+            (call cdr 1) (call return 1))))
 
 ;; FIXME: binding info for or-hacked locals might bork the disassembler,
 ;; and could be tightened in any case
@@ -587,10 +574,10 @@
 
 (with-test-prefix "apply"
   (assert-tree-il->glil
-   (apply (primitive @apply) (toplevel foo) (toplevel bar))
+   (primcall @apply (toplevel foo) (toplevel bar))
    (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (toplevel ref bar) (call tail-apply 2)))
   (assert-tree-il->glil
-   (begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void))
+   (begin (primcall @apply (toplevel foo) (toplevel bar)) (void))
    (program () (std-prelude 0 0 #f) (label _)
             (call new-frame 0) (toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1)
             (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f)
@@ -598,7 +585,7 @@
             (void) (call return 1))
    (and (eq? l1 l3) (eq? l2 l4)))
   (assert-tree-il->glil
-   (apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel baz)))
+   (call (toplevel foo) (call (toplevel @apply) (toplevel bar) (toplevel baz)))
    (program () (std-prelude 0 0 #f) (label _)
             (toplevel ref foo)
             (call new-frame 0) (toplevel ref bar) (toplevel ref baz) (call apply 2)
@@ -606,10 +593,10 @@
 
 (with-test-prefix "call/cc"
   (assert-tree-il->glil
-   (apply (primitive @call-with-current-continuation) (toplevel foo))
+   (primcall @call-with-current-continuation (toplevel foo))
    (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call tail-call/cc 1)))
   (assert-tree-il->glil
-   (begin (apply (primitive @call-with-current-continuation) (toplevel foo)) (void))
+   (begin (primcall @call-with-current-continuation (toplevel foo)) (void))
    (program () (std-prelude 0 0 #f) (label _)
             (call new-frame 0) (toplevel ref call-with-current-continuation) (toplevel ref foo) (mv-call 1 ,l1)
             (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f)
@@ -617,699 +604,25 @@
             (void) (call return 1))
    (and (eq? l1 l3) (eq? l2 l4)))
   (assert-tree-il->glil
-   (apply (toplevel foo)
-          (apply (toplevel @call-with-current-continuation) (toplevel bar)))
+   (call (toplevel foo)
+          (call (toplevel @call-with-current-continuation) (toplevel bar)))
    (program () (std-prelude 0 0 #f) (label _)
             (toplevel ref foo)
             (toplevel ref bar) (call call/cc 1)
             (call tail-call 1))))
 
 
-(with-test-prefix "partial evaluation"
-
-  (pass-if-peval
-    ;; First order, primitive.
-    (let ((x 1) (y 2)) (+ x y))
-    (const 3))
-
-  (pass-if-peval
-    ;; First order, thunk.
-    (let ((x 1) (y 2))
-      (let ((f (lambda () (+ x y))))
-        (f)))
-    (const 3))
-
-  (pass-if-peval resolve-primitives
-    ;; First order, let-values (requires primitive expansion for
-    ;; `call-with-values'.)
-    (let ((x 0))
-      (call-with-values
-          (lambda () (if (zero? x) (values 1 2) (values 3 4)))
-        (lambda (a b)
-          (+ a b))))
-    (const 3))
-
-  (pass-if-peval
-    ;; First order, coalesced, mutability preserved.
-    (cons 0 (cons 1 (cons 2 (list 3 4 5))))
-    (apply (primitive list)
-           (const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))
-
-  (pass-if-peval
-   ;; First order, coalesced, mutability preserved.
-   (cons 0 (cons 1 (cons 2 (list 3 4 5))))
-   ;; This must not be a constant.
-   (apply (primitive list)
-          (const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))
-
-  (pass-if-peval
-    ;; First order, coalesced, immutability preserved.
-    (cons 0 (cons 1 (cons 2 '(3 4 5))))
-    (apply (primitive cons) (const 0)
-           (apply (primitive cons) (const 1)
-                  (apply (primitive cons) (const 2)
-                         (const (3 4 5))))))
-
-  ;; These two tests doesn't work any more because we changed the way we
-  ;; deal with constants -- now the algorithm will see a construction as
-  ;; being bound to the lexical, so it won't propagate it.  It can't
-  ;; even propagate it in the case that it is only referenced once,
-  ;; because:
-  ;;
-  ;;   (let ((x (cons 1 2))) (lambda () x))
-  ;;
-  ;; is not the same as
-  ;;
-  ;;   (lambda () (cons 1 2))
-  ;;
-  ;; Perhaps if we determined that not only was it only referenced once,
-  ;; it was not closed over by a lambda, then we could propagate it, and
-  ;; re-enable these two tests.
-  ;;
-  #;
-  (pass-if-peval
-   ;; First order, mutability preserved.
-   (let loop ((i 3) (r '()))
-     (if (zero? i)
-         r
-         (loop (1- i) (cons (cons i i) r))))
-   (apply (primitive list)
-          (apply (primitive cons) (const 1) (const 1))
-          (apply (primitive cons) (const 2) (const 2))
-          (apply (primitive cons) (const 3) (const 3))))
-  ;;
-  ;; See above.
-  #;
-  (pass-if-peval
-   ;; First order, evaluated.
-   (let loop ((i 7)
-              (r '()))
-     (if (<= i 0)
-         (car r)
-         (loop (1- i) (cons i r))))
-   (const 1))
-
-  ;; Instead here are tests for what happens for the above cases: they
-  ;; unroll but they don't fold.
-  (pass-if-peval
-   (let loop ((i 3) (r '()))
-     (if (zero? i)
-         r
-         (loop (1- i) (cons (cons i i) r))))
-   (letrec (loop) (_) (_)
-           (let (r) (_)
-                ((apply (primitive list)
-                        (apply (primitive cons) (const 3) (const 3))))
-                (let (r) (_)
-                     ((apply (primitive cons)
-                             (apply (primitive cons) (const 2) (const 2))
-                             (lexical r _)))
-                     (apply (primitive cons)
-                            (apply (primitive cons) (const 1) (const 1))
-                            (lexical r _))))))
-
-  ;; See above.
-  (pass-if-peval
-   (let loop ((i 4)
-              (r '()))
-     (if (<= i 0)
-         (car r)
-         (loop (1- i) (cons i r))))
-   (letrec (loop) (_) (_)
-           (let (r) (_)
-                ((apply (primitive list) (const 4)))
-                (let (r) (_)
-                     ((apply (primitive cons)
-                             (const 3)
-                             (lexical r _)))
-                     (let (r) (_)
-                          ((apply (primitive cons)
-                                  (const 2)
-                                  (lexical r _)))
-                          (let (r) (_)
-                               ((apply (primitive cons)
-                                       (const 1)
-                                       (lexical r _)))
-                               (apply (primitive car)
-                                      (lexical r _))))))))
-
-   ;; Static sums.
-  (pass-if-peval
-   (let loop ((l '(1 2 3 4)) (sum 0))
-     (if (null? l)
-         sum
-         (loop (cdr l) (+ sum (car l)))))
-   (const 10))
-
-  (pass-if-peval
-   ;; Mutability preserved.
-   ((lambda (x y z) (list x y z)) 1 2 3)
-   (apply (primitive list) (const 1) (const 2) (const 3)))
-
-  (pass-if-peval
-   ;; Don't propagate effect-free expressions that operate on mutable
-   ;; objects.
-   (let* ((x (list 1))
-          (y (car x)))
-     (set-car! x 0)
-     y)
-   (let (x) (_) ((apply (primitive list) (const 1)))
-        (let (y) (_) ((apply (primitive car) (lexical x _)))
-             (begin
-               (apply (toplevel set-car!) (lexical x _) (const 0))
-               (lexical y _)))))
-  
-  (pass-if-peval
-   ;; Don't propagate effect-free expressions that operate on objects we
-   ;; don't know about.
-   (let ((y (car x)))
-     (set-car! x 0)
-     y)
-   (let (y) (_) ((apply (primitive car) (toplevel x)))
-        (begin
-          (apply (toplevel set-car!) (toplevel x) (const 0))
-          (lexical y _))))
-  
-  (pass-if-peval
-   ;; Infinite recursion
-   ((lambda (x) (x x)) (lambda (x) (x x)))
-   (let (x) (_)
-        ((lambda _
-           (lambda-case
-            (((x) _ _ _ _ _)
-             (apply (lexical x _) (lexical x _))))))
-        (apply (lexical x _) (lexical x _))))
-
-  (pass-if-peval
-    ;; First order, aliased primitive.
-    (let* ((x *) (y (x 1 2))) y)
-    (const 2))
-
-  (pass-if-peval
-    ;; First order, shadowed primitive.
-    (begin
-      (define (+ x y) (pk x y))
-      (+ 1 2))
-    (begin
-      (define +
-        (lambda (_)
-          (lambda-case
-           (((x y) #f #f #f () (_ _))
-            (apply (toplevel pk) (lexical x _) (lexical y _))))))
-      (apply (toplevel +) (const 1) (const 2))))
-
-  (pass-if-peval
-    ;; First-order, effects preserved.
-    (let ((x 2))
-      (do-something!)
-      x)
-    (begin
-      (apply (toplevel do-something!))
-      (const 2)))
-
-  (pass-if-peval
-    ;; First order, residual bindings removed.
-    (let ((x 2) (y 3))
-      (* (+ x y) z))
-    (apply (primitive *) (const 5) (toplevel z)))
-
-  (pass-if-peval
-    ;; First order, with lambda.
-    (define (foo x)
-      (define (bar z) (* z z))
-      (+ x (bar 3)))
-    (define foo
-      (lambda (_)
-        (lambda-case
-         (((x) #f #f #f () (_))
-          (apply (primitive +) (lexical x _) (const 9)))))))
-
-  (pass-if-peval
-    ;; First order, with lambda inlined & specialized twice.
-    (let ((f (lambda (x y)
-               (+ (* x top) y)))
-          (x 2)
-          (y 3))
-      (+ (* x (f x y))
-         (f something x)))
-    (apply (primitive +)
-           (apply (primitive *)
-                  (const 2)
-                  (apply (primitive +)  ; (f 2 3)
-                         (apply (primitive *)
-                                (const 2)
-                                (toplevel top))
-                         (const 3)))
-           (let (x) (_) ((toplevel something))                    ; (f something 2)
-                ;; `something' is not const, so preserve order of
-                ;; effects with a lexical binding.
-                (apply (primitive +)
-                       (apply (primitive *)
-                              (lexical x _)
-                              (toplevel top))
-                       (const 2)))))
-  
-  (pass-if-peval
-   ;; First order, with lambda inlined & specialized 3 times.
-   (let ((f (lambda (x y) (if (> x 0) y x))))
-     (+ (f -1 0)
-        (f 1 0)
-        (f -1 y)
-        (f 2 y)
-        (f z y)))
-   (apply (primitive +)
-          (const -1)                      ; (f -1 0)
-          (const 0)                       ; (f 1 0)
-          (begin (toplevel y) (const -1)) ; (f -1 y)
-          (toplevel y)                    ; (f 2 y)
-          (let (x y) (_ _) ((toplevel z) (toplevel y)) ; (f z y)
-               (if (apply (primitive >) (lexical x _) (const 0))
-                   (lexical y _)
-                   (lexical x _)))))
-
-  (pass-if-peval
-    ;; First order, conditional.
-    (let ((y 2))
-      (lambda (x)
-        (if (> y 0)
-            (display x)
-            'never-reached)))
-    (lambda ()
-      (lambda-case
-       (((x) #f #f #f () (_))
-        (apply (toplevel display) (lexical x _))))))
-
-  (pass-if-peval
-    ;; First order, recursive procedure.
-    (letrec ((fibo (lambda (n)
-                     (if (<= n 1)
-                         n
-                         (+ (fibo (- n 1))
-                            (fibo (- n 2)))))))
-      (fibo 4))
-    (const 3))
-
-  (pass-if-peval
-   ;; Don't propagate toplevel references, as intervening expressions
-   ;; could alter their bindings.
-   (let ((x top))
-     (foo)
-     x)
-   (let (x) (_) ((toplevel top))
-        (begin
-          (apply (toplevel foo))
-          (lexical x _))))
-
-  (pass-if-peval
-    ;; Higher order.
-    ((lambda (f x)
-       (f (* (car x) (cadr x))))
-     (lambda (x)
-       (+ x 1))
-     '(2 3))
-    (const 7))
-
-  (pass-if-peval
-    ;; Higher order with optional argument (default value).
-    ((lambda* (f x #:optional (y 0))
-       (+ y (f (* (car x) (cadr x)))))
-     (lambda (x)
-       (+ x 1))
-     '(2 3))
-    (const 7))
-
-  (pass-if-peval
-    ;; Higher order with optional argument (caller-supplied value).
-    ((lambda* (f x #:optional (y 0))
-       (+ y (f (* (car x) (cadr x)))))
-     (lambda (x)
-       (+ x 1))
-     '(2 3)
-     35)
-    (const 42))
-
-  (pass-if-peval
-    ;; Higher order with optional argument (side-effecting default
-    ;; value).
-    ((lambda* (f x #:optional (y (foo)))
-       (+ y (f (* (car x) (cadr x)))))
-     (lambda (x)
-       (+ x 1))
-     '(2 3))
-    (let (y) (_) ((apply (toplevel foo)))
-         (apply (primitive +) (lexical y _) (const 7))))
-
-  (pass-if-peval
-    ;; Higher order with optional argument (caller-supplied value).
-    ((lambda* (f x #:optional (y (foo)))
-       (+ y (f (* (car x) (cadr x)))))
-     (lambda (x)
-       (+ x 1))
-     '(2 3)
-     35)
-    (const 42))
-
-  (pass-if-peval
-    ;; Higher order.
-    ((lambda (f) (f x)) (lambda (x) x))
-    (toplevel x))
-
-  (pass-if-peval
-    ;; Bug reported at
-    ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html>.
-    (let ((fold (lambda (f g) (f (g top)))))
-      (fold 1+ (lambda (x) x)))
-    (apply (primitive 1+) (toplevel top)))
-  
-  (pass-if-peval
-    ;; Procedure not inlined when residual code contains recursive calls.
-    ;; <http://debbugs.gnu.org/9542>
-    (letrec ((fold (lambda (f x3 b null? car cdr)
-                     (if (null? x3)
-                         b
-                         (f (car x3) (fold f (cdr x3) b null? car cdr))))))
-      (fold * x 1 zero? (lambda (x1) x1) (lambda (x2) (- x2 1))))
-    (letrec (fold) (_) (_)
-            (apply (lexical fold _)
-                   (primitive *)
-                   (toplevel x)
-                   (const 1)
-                   (primitive zero?)
-                   (lambda ()
-                     (lambda-case
-                      (((x1) #f #f #f () (_))
-                       (lexical x1 _))))
-                   (lambda ()
-                     (lambda-case
-                      (((x2) #f #f #f () (_))
-                       (apply (primitive -) (lexical x2 _) (const 1))))))))
-
-  (pass-if "inlined lambdas are alpha-renamed"
-    ;; In this example, `make-adder' is inlined more than once; thus,
-    ;; they should use different gensyms for their arguments, because
-    ;; the various optimization passes assume uniquely-named variables.
-    ;;
-    ;; Bug reported at
-    ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html> and
-    ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00029.html>.
-    (pmatch (unparse-tree-il
-             (peval (compile
-                     '(let ((make-adder
-                             (lambda (x) (lambda (y) (+ x y)))))
-                        (cons (make-adder 1) (make-adder 2)))
-                     #:to 'tree-il)))
-      ((apply (primitive cons)
-              (lambda ()
-                (lambda-case
-                 (((y) #f #f #f () (,gensym1))
-                  (apply (primitive +)
-                         (const 1)
-                         (lexical y ,ref1)))))
-              (lambda ()
-                (lambda-case
-                 (((y) #f #f #f () (,gensym2))
-                  (apply (primitive +)
-                         (const 2)
-                         (lexical y ,ref2))))))
-       (and (eq? gensym1 ref1)
-            (eq? gensym2 ref2)
-            (not (eq? gensym1 gensym2))))
-      (_ #f)))
-
-  (pass-if-peval
-    ;; Higher order, mutually recursive procedures.
-    (letrec ((even? (lambda (x)
-                      (or (= 0 x)
-                          (odd? (- x 1)))))
-             (odd?  (lambda (x)
-                      (not (even? (- x 1))))))
-      (and (even? 4) (odd? 7)))
-    (const #t))
-
-  ;;
-  ;; Below are cases where constant propagation should bail out.
-  ;;
-
-  (pass-if-peval
-    ;; Non-constant lexical is not propagated.
-    (let ((v (make-vector 6 #f)))
-      (lambda (n)
-        (vector-set! v n n)))
-    (let (v) (_)
-         ((apply (toplevel make-vector) (const 6) (const #f)))
-         (lambda ()
-           (lambda-case
-            (((n) #f #f #f () (_))
-             (apply (toplevel vector-set!)
-                    (lexical v _) (lexical n _) (lexical n _)))))))
-
-  (pass-if-peval
-    ;; Mutable lexical is not propagated.
-    (let ((v (vector 1 2 3)))
-      (lambda ()
-        v))
-    (let (v) (_)
-         ((apply (primitive vector) (const 1) (const 2) (const 3)))
-         (lambda ()
-           (lambda-case
-            ((() #f #f #f () ())
-             (lexical v _))))))
-
-  (pass-if-peval
-    ;; Lexical that is not provably pure is not inlined nor propagated.
-    (let* ((x (if (> p q) (frob!) (display 'chbouib)))
-           (y (* x 2)))
-      (+ x x y))
-    (let (x) (_) ((if (apply (primitive >) (toplevel p) (toplevel q))
-                      (apply (toplevel frob!))
-                      (apply (toplevel display) (const chbouib))))
-         (let (y) (_) ((apply (primitive *) (lexical x _) (const 2)))
-              (apply (primitive +)
-                     (lexical x _) (lexical x _) (lexical y _)))))
-
-  (pass-if-peval
-    ;; Non-constant arguments not propagated to lambdas.
-    ((lambda (x y z)
-       (vector-set! x 0 0)
-       (set-car! y 0)
-       (set-cdr! z '()))
-     (vector 1 2 3)
-     (make-list 10)
-     (list 1 2 3))
-    (let (x y z) (_ _ _)
-         ((apply (primitive vector) (const 1) (const 2) (const 3))
-          (apply (toplevel make-list) (const 10))
-          (apply (primitive list) (const 1) (const 2) (const 3)))
-         (begin
-           (apply (toplevel vector-set!)
-                  (lexical x _) (const 0) (const 0))
-           (apply (toplevel set-car!)
-                  (lexical y _) (const 0))
-           (apply (toplevel set-cdr!)
-                  (lexical z _) (const ())))))
-
-  (pass-if-peval
-   (let ((foo top-foo) (bar top-bar))
-     (let* ((g (lambda (x y) (+ x y)))
-            (f (lambda (g x) (g x x))))
-       (+ (f g foo) (f g bar))))
-   (let (foo bar) (_ _) ((toplevel top-foo) (toplevel top-bar))
-        (apply (primitive +)
-               (apply (primitive +) (lexical foo _) (lexical foo _))
-               (apply (primitive +) (lexical bar _) (lexical bar _)))))
-
-  (pass-if-peval
-    ;; Fresh objects are not turned into constants, nor are constants
-    ;; turned into fresh objects.
-    (let* ((c '(2 3))
-           (x (cons 1 c))
-           (y (cons 0 x)))
-      y)
-    (let (x) (_) ((apply (primitive cons) (const 1) (const (2 3))))
-         (apply (primitive cons) (const 0) (lexical x _))))
-
-  (pass-if-peval
-    ;; Bindings mutated.
-    (let ((x 2))
-      (set! x 3)
-      x)
-    (let (x) (_) ((const 2))
-         (begin
-           (set! (lexical x _) (const 3))
-           (lexical x _))))
-
-  (pass-if-peval
-    ;; Bindings mutated.
-    (letrec ((x 0)
-             (f (lambda ()
-                  (set! x (+ 1 x))
-                  x)))
-      (frob f) ; may mutate `x'
-      x)
-    (letrec (x) (_) ((const 0))
-            (begin
-              (apply (toplevel frob) (lambda _ _))
-              (lexical x _))))
-
-  (pass-if-peval
-    ;; Bindings mutated.
-    (letrec ((f (lambda (x)
-                  (set! f (lambda (_) x))
-                  x)))
-      (f 2))
-    (letrec _ . _))
-
-  (pass-if-peval
-    ;; Bindings possibly mutated.
-    (let ((x (make-foo)))
-      (frob! x) ; may mutate `x'
-      x)
-    (let (x) (_) ((apply (toplevel make-foo)))
-         (begin
-           (apply (toplevel frob!) (lexical x _))
-           (lexical x _))))
-
-  (pass-if-peval
-    ;; Inlining stops at recursive calls with dynamic arguments.
-    (let loop ((x x))
-      (if (< x 0) x (loop (1- x))))
-    (letrec (loop) (_) ((lambda (_)
-                          (lambda-case
-                           (((x) #f #f #f () (_))
-                            (if _ _
-                                (apply (lexical loop _)
-                                       (apply (primitive 1-)
-                                              (lexical x _))))))))
-            (apply (lexical loop _) (toplevel x))))
-
-  (pass-if-peval
-    ;; Recursion on the 2nd argument is fully evaluated.
-    (let ((x (top)))
-      (let loop ((x x) (y 10))
-        (if (> y 0)
-            (loop x (1- y))
-            (foo x y))))
-    (let (x) (_) ((apply (toplevel top)))
-         (letrec (loop) (_) (_)
-                 (apply (toplevel foo) (lexical x _) (const 0)))))
-
-  (pass-if-peval
-    ;; Inlining aborted when residual code contains recursive calls.
-    ;;
-    ;; <http://debbugs.gnu.org/9542>
-    (let loop ((x x) (y 0))
-      (if (> y 0)
-          (loop (1- x) (1- y))
-          (if (< x 0)
-              x
-              (loop (1+ x) (1+ y)))))
-    (letrec (loop) (_) ((lambda (_)
-                          (lambda-case
-                           (((x y) #f #f #f () (_ _))
-                            (if (apply (primitive >)
-                                       (lexical y _) (const 0))
-                                _ _)))))
-            (apply (lexical loop _) (toplevel x) (const 0))))
-
-  (pass-if-peval
-    ;; Infinite recursion: `peval' gives up and leaves it as is.
-    (letrec ((f (lambda (x) (g (1- x))))
-             (g (lambda (x) (h (1+ x))))
-             (h (lambda (x) (f x))))
-      (f 0))
-    (letrec _ . _))
-
-  (pass-if-peval
-    ;; Constant folding: cons
-   (begin (cons 1 2) #f)
-   (const #f))
-  
-  (pass-if-peval
-    ;; Constant folding: cons
-   (begin (cons (foo) 2) #f)
-   (begin (apply (toplevel foo)) (const #f)))
-  
-  (pass-if-peval
-    ;; Constant folding: cons
-   (if (cons 0 0) 1 2)
-   (const 1))
-  
-  (pass-if-peval
-   ;; Constant folding: car+cons
-   (car (cons 1 0))
-   (const 1))
-  
-  (pass-if-peval
-   ;; Constant folding: cdr+cons
-   (cdr (cons 1 0))
-   (const 0))
-  
-  (pass-if-peval
-   ;; Constant folding: car+cons, impure
-   (car (cons 1 (bar)))
-   (begin (apply (toplevel bar)) (const 1)))
-  
-  (pass-if-peval
-   ;; Constant folding: cdr+cons, impure
-   (cdr (cons (bar) 0))
-   (begin (apply (toplevel bar)) (const 0)))
-  
-  (pass-if-peval
-   ;; Constant folding: car+list
-   (car (list 1 0))
-   (const 1))
-  
-  (pass-if-peval
-   ;; Constant folding: cdr+list
-   (cdr (list 1 0))
-   (apply (primitive list) (const 0)))
-  
-  (pass-if-peval
-   ;; Constant folding: car+list, impure
-   (car (list 1 (bar)))
-   (begin (apply (toplevel bar)) (const 1)))
-  
-  (pass-if-peval
-   ;; Constant folding: cdr+list, impure
-   (cdr (list (bar) 0))
-   (begin (apply (toplevel bar)) (apply (primitive list) (const 0))))
-  
-  (pass-if-peval
-   resolve-primitives
-   ;; Prompt is removed if tag is unreferenced
-   (let ((tag (make-prompt-tag)))
-     (call-with-prompt tag
-                       (lambda () 1)
-                       (lambda args args)))
-   (const 1))
-  
-  (pass-if-peval
-   resolve-primitives
-   ;; Prompt is removed if tag is unreferenced, with explicit stem
-   (let ((tag (make-prompt-tag "foo")))
-     (call-with-prompt tag
-                       (lambda () 1)
-                       (lambda args args)))
-   (const 1))
-
-  (pass-if-peval
-   resolve-primitives
-   ;; `while' without `break' or `continue' has no prompts and gets its
-   ;; condition folded.  Unfortunately the outer `lp' does not yet get
-   ;; elided.
-   (while #t #t)
-   (letrec (lp) (_)
-           ((lambda _
-              (lambda-case
-               ((() #f #f #f () ())
-                (letrec (loop) (_)
-                        ((lambda _
-                           (lambda-case
-                            ((() #f #f #f () ())
-                             (apply (lexical loop _))))))
-                        (apply (lexical loop _)))))))
-           (apply (lexical lp _)))))
-
+(with-test-prefix "labels allocation"
+  (pass-if "http://debbugs.gnu.org/9769"
+    ((compile '(lambda ()
+                 (let ((fail (lambda () #f)))
+                   (let ((test (lambda () (fail))))
+                     (test))
+                   #t))
+              ;; Prevent inlining.  We're testing analyze.scm's
+              ;; labels allocator here, and inlining it will
+              ;; reduce the entire thing to #t.
+              #:opts '(#:partial-eval? #f)))))
 
 
 (with-test-prefix "tree-il-fold"
@@ -1342,9 +655,9 @@
                                   '(lambda ()
                                      (lambda-case
                                       (((x y) #f #f #f () (x1 y1))
-                                       (apply (toplevel +)
-                                              (lexical x x1)
-                                              (lexical y y1)))
+                                       (call (toplevel +)
+                                             (lexical x x1)
+                                             (lexical y y1)))
                                       #f))))))
       (and (equal? (map strip-source leaves)
                    (list (make-lexical-ref #f 'y 'y1)
@@ -1790,6 +1103,26 @@
                                   w "wrong number of arguments to"))))
                              w)))))
 
+     (pass-if "top-level applicable struct"
+       (null? (call-with-warnings
+               (lambda ()
+                 (compile '(let ((p current-warning-port))
+                             (p (+ (p) 1))
+                             (p))
+                          #:opts %opts-w-arity
+                          #:to 'assembly)))))
+
+     (pass-if "top-level applicable struct with wrong arguments"
+       (let ((w (call-with-warnings
+                 (lambda ()
+                   (compile '(let ((p current-warning-port))
+                               (p 1 2 3))
+                            #:opts %opts-w-arity
+                            #:to 'assembly)))))
+         (and (= (length w) 1)
+              (number? (string-contains (car w)
+                                        "wrong number of arguments to")))))
+
      (pass-if "local toplevel-defines"
        (let ((w (call-with-warnings
                   (lambda ()
@@ -1916,12 +1249,69 @@
                                         "non-literal format string")))))
 
      (pass-if "non-literal format string using gettext"
+       (null? (call-with-warnings
+               (lambda ()
+                 (compile '(format #t (gettext "~A ~A!") "hello" "world")
+                          #:opts %opts-w-format
+                          #:to 'assembly)))))
+
+     (pass-if "non-literal format string using gettext as _"
        (null? (call-with-warnings
                (lambda ()
                  (compile '(format #t (_ "~A ~A!") "hello" "world")
                           #:opts %opts-w-format
                           #:to 'assembly)))))
 
+     (pass-if "non-literal format string using gettext as top-level _"
+       (null? (call-with-warnings
+               (lambda ()
+                 (compile '(begin
+                             (define (_ s) (gettext s "my-domain"))
+                             (format #t (_ "~A ~A!") "hello" "world"))
+                          #:opts %opts-w-format
+                          #:to 'assembly)))))
+
+     (pass-if "non-literal format string using gettext as module-ref _"
+       (null? (call-with-warnings
+               (lambda ()
+                 (compile '(format #t ((@@ (foo) _) "~A ~A!") "hello" "world")
+                          #:opts %opts-w-format
+                          #:to 'assembly)))))
+
+     (pass-if "non-literal format string using gettext as lexical _"
+       (null? (call-with-warnings
+               (lambda ()
+                 (compile '(let ((_ (lambda (s)
+                                      (gettext s "my-domain"))))
+                             (format #t (_ "~A ~A!") "hello" "world"))
+                          #:opts %opts-w-format
+                          #:to 'assembly)))))
+
+     (pass-if "non-literal format string using ngettext"
+       (null? (call-with-warnings
+               (lambda ()
+                 (compile '(format #t
+                                   (ngettext "~a thing" "~a things" n "dom") n)
+                          #:opts %opts-w-format
+                          #:to 'assembly)))))
+
+     (pass-if "non-literal format string using ngettext as N_"
+       (null? (call-with-warnings
+               (lambda ()
+                 (compile '(format #t (N_ "~a thing" "~a things" n) n)
+                          #:opts %opts-w-format
+                          #:to 'assembly)))))
+
+     (pass-if "non-literal format string with (define _ gettext)"
+       (null? (call-with-warnings
+               (lambda ()
+                 (compile '(begin
+                             (define _ gettext)
+                             (define (foo)
+                               (format #t (_ "~A ~A!") "hello" "world")))
+                          #:opts %opts-w-format
+                          #:to 'assembly)))))
+
      (pass-if "wrong format string"
        (let ((w (call-with-warnings
                  (lambda ()
@@ -1945,7 +1335,8 @@
      (pass-if "~%, ~~, ~&, ~t, ~_, and ~\\n"
        (null? (call-with-warnings
                (lambda ()
-                 (compile '(format some-port "~&~3_~~ ~\n~12they~%")
+                 (compile '((@ (ice-9 format) format) some-port
+                            "~&~3_~~ ~\n~12they~%")
                           #:opts %opts-w-format
                           #:to 'assembly)))))
 
@@ -1962,7 +1353,7 @@
      (pass-if "one missing argument, gettext"
        (let ((w (call-with-warnings
                  (lambda ()
-                   (compile '(format some-port (_ "foo ~A~%"))
+                   (compile '(format some-port (gettext "foo ~A~%"))
                             #:opts %opts-w-format
                             #:to 'assembly)))))
          (and (= (length w) 1)
@@ -1972,7 +1363,8 @@
      (pass-if "two missing arguments"
        (let ((w (call-with-warnings
                  (lambda ()
-                   (compile '(format #f "foo ~10,2f and bar ~S~%")
+                   (compile '((@ (ice-9 format) format) #f
+                              "foo ~10,2f and bar ~S~%")
                             #:opts %opts-w-format
                             #:to 'assembly)))))
          (and (= (length w) 1)
@@ -1999,11 +1391,37 @@
               (number? (string-contains (car w)
                                         "expected 1, got 2")))))
 
+     (pass-if "~h"
+       (null? (call-with-warnings
+                 (lambda ()
+                   (compile '((@ (ice-9 format) format) #t
+                              "foo ~h ~a~%" 123.4 'bar)
+                            #:opts %opts-w-format
+                            #:to 'assembly)))))
+
+     (pass-if "~:h with locale object"
+       (null? (call-with-warnings
+                 (lambda ()
+                   (compile '((@ (ice-9 format) format) #t
+                              "foo ~:h~%" 123.4 %global-locale)
+                            #:opts %opts-w-format
+                            #:to 'assembly)))))
+
+     (pass-if "~:h without locale object"
+       (let ((w (call-with-warnings
+                 (lambda ()
+                   (compile '((@ (ice-9 format) format) #t "foo ~,2:h" 123.4)
+                            #:opts %opts-w-format
+                            #:to 'assembly)))))
+         (and (= (length w) 1)
+              (number? (string-contains (car w)
+                                        "expected 2, got 1")))))
+
      (with-test-prefix "conditionals"
        (pass-if "literals"
         (null? (call-with-warnings
                 (lambda ()
-                  (compile '(format #f "~A ~[foo~;bar~;baz~;~] ~10,2f"
+                  (compile '((@ (ice-9 format) format) #f "~A ~[foo~;bar~;baz~;~] ~10,2f"
                                     'a 1 3.14)
                            #:opts %opts-w-format
                            #:to 'assembly)))))
@@ -2011,7 +1429,7 @@
        (pass-if "literals with selector"
          (let ((w (call-with-warnings
                    (lambda ()
-                     (compile '(format #f "~2[foo~;bar~;baz~;~] ~A"
+                     (compile '((@ (ice-9 format) format) #f "~2[foo~;bar~;baz~;~] ~A"
                                        1 'dont-ignore-me)
                               #:opts %opts-w-format
                               #:to 'assembly)))))
@@ -2022,7 +1440,7 @@
        (pass-if "escapes (exact count)"
          (let ((w (call-with-warnings
                    (lambda ()
-                     (compile '(format #f "~[~a~;~a~]")
+                     (compile '((@ (ice-9 format) format) #f "~[~a~;~a~]")
                               #:opts %opts-w-format
                               #:to 'assembly)))))
            (and (= (length w) 1)
@@ -2032,7 +1450,7 @@
        (pass-if "escapes with selector"
          (let ((w (call-with-warnings
                    (lambda ()
-                     (compile '(format #f "~1[chbouib~;~a~]")
+                     (compile '((@ (ice-9 format) format) #f "~1[chbouib~;~a~]")
                               #:opts %opts-w-format
                               #:to 'assembly)))))
            (and (= (length w) 1)
@@ -2042,7 +1460,7 @@
        (pass-if "escapes, range"
          (let ((w (call-with-warnings
                    (lambda ()
-                     (compile '(format #f "~[chbouib~;~a~;~2*~a~]")
+                     (compile '((@ (ice-9 format) format) #f "~[chbouib~;~a~;~2*~a~]")
                               #:opts %opts-w-format
                               #:to 'assembly)))))
            (and (= (length w) 1)
@@ -2052,7 +1470,7 @@
        (pass-if "@"
          (let ((w (call-with-warnings
                    (lambda ()
-                     (compile '(format #f "~@[temperature=~d~]")
+                     (compile '((@ (ice-9 format) format) #f "~@[temperature=~d~]")
                               #:opts %opts-w-format
                               #:to 'assembly)))))
            (and (= (length w) 1)
@@ -2062,7 +1480,7 @@
        (pass-if "nested"
          (let ((w (call-with-warnings
                    (lambda ()
-                     (compile '(format #f "~:[~[hey~;~a~;~va~]~;~3*~]")
+                     (compile '((@ (ice-9 format) format) #f "~:[~[hey~;~a~;~va~]~;~3*~]")
                               #:opts %opts-w-format
                               #:to 'assembly)))))
            (and (= (length w) 1)
@@ -2072,7 +1490,7 @@
        (pass-if "unterminated"
          (let ((w (call-with-warnings
                    (lambda ()
-                     (compile '(format #f "~[unterminated")
+                     (compile '((@ (ice-9 format) format) #f "~[unterminated")
                               #:opts %opts-w-format
                               #:to 'assembly)))))
            (and (= (length w) 1)
@@ -2082,7 +1500,7 @@
        (pass-if "unexpected ~;"
          (let ((w (call-with-warnings
                    (lambda ()
-                     (compile '(format #f "foo~;bar")
+                     (compile '((@ (ice-9 format) format) #f "foo~;bar")
                               #:opts %opts-w-format
                               #:to 'assembly)))))
            (and (= (length w) 1)
@@ -2092,7 +1510,7 @@
        (pass-if "unexpected ~]"
          (let ((w (call-with-warnings
                    (lambda ()
-                     (compile '(format #f "foo~]")
+                     (compile '((@ (ice-9 format) format) #f "foo~]")
                               #:opts %opts-w-format
                               #:to 'assembly)))))
            (and (= (length w) 1)
@@ -2102,7 +1520,7 @@
      (pass-if "~{...~}"
        (null? (call-with-warnings
                (lambda ()
-                 (compile '(format #f "~A ~{~S~} ~A"
+                 (compile '((@ (ice-9 format) format) #f "~A ~{~S~} ~A"
                                    'hello '("ladies" "and")
                                    'gentlemen)
                           #:opts %opts-w-format
@@ -2111,7 +1529,7 @@
      (pass-if "~{...~}, too many args"
        (let ((w (call-with-warnings
                  (lambda ()
-                   (compile '(format #f "~{~S~}" 1 2 3)
+                   (compile '((@ (ice-9 format) format) #f "~{~S~}" 1 2 3)
                             #:opts %opts-w-format
                             #:to 'assembly)))))
          (and (= (length w) 1)
@@ -2121,14 +1539,14 @@
      (pass-if "~@{...~}"
        (null? (call-with-warnings
                (lambda ()
-                 (compile '(format #f "~@{~S~}" 1 2 3)
+                 (compile '((@ (ice-9 format) format) #f "~@{~S~}" 1 2 3)
                           #:opts %opts-w-format
                           #:to 'assembly)))))
 
      (pass-if "~@{...~}, too few args"
        (let ((w (call-with-warnings
                  (lambda ()
-                   (compile '(format #f "~A ~@{~S~}")
+                   (compile '((@ (ice-9 format) format) #f "~A ~@{~S~}")
                             #:opts %opts-w-format
                             #:to 'assembly)))))
          (and (= (length w) 1)
@@ -2138,7 +1556,7 @@
      (pass-if "unterminated ~{...~}"
        (let ((w (call-with-warnings
                  (lambda ()
-                   (compile '(format #f "~{")
+                   (compile '((@ (ice-9 format) format) #f "~{")
                             #:opts %opts-w-format
                             #:to 'assembly)))))
          (and (= (length w) 1)
@@ -2148,14 +1566,14 @@
      (pass-if "~(...~)"
        (null? (call-with-warnings
                (lambda ()
-                 (compile '(format #f "~:@(~A ~A~)" 'foo 'bar)
+                 (compile '((@ (ice-9 format) format) #f "~:@(~A ~A~)" 'foo 'bar)
                           #:opts %opts-w-format
                           #:to 'assembly)))))
 
      (pass-if "~v"
        (let ((w (call-with-warnings
                  (lambda ()
-                   (compile '(format #f "~v_foo")
+                   (compile '((@ (ice-9 format) format) #f "~v_foo")
                             #:opts %opts-w-format
                             #:to 'assembly)))))
          (and (= (length w) 1)
@@ -2164,7 +1582,7 @@
      (pass-if "~v:@y"
        (null? (call-with-warnings
                (lambda ()
-                 (compile '(format #f "~v:@y" 1 123)
+                 (compile '((@ (ice-9 format) format) #f "~v:@y" 1 123)
                           #:opts %opts-w-format
                           #:to 'assembly)))))
 
@@ -2172,7 +1590,7 @@
      (pass-if "~*"
        (let ((w (call-with-warnings
                  (lambda ()
-                   (compile '(format #f "~2*~a" 'a 'b)
+                   (compile '((@ (ice-9 format) format) #f "~2*~a" 'a 'b)
                             #:opts %opts-w-format
                             #:to 'assembly)))))
          (and (= (length w) 1)
@@ -2182,14 +1600,14 @@
      (pass-if "~?"
        (null? (call-with-warnings
                (lambda ()
-                 (compile '(format #f "~?" "~d ~d" '(1 2))
+                 (compile '((@ (ice-9 format) format) #f "~?" "~d ~d" '(1 2))
                           #:opts %opts-w-format
                           #:to 'assembly)))))
 
      (pass-if "complex 1"
        (let ((w (call-with-warnings
                  (lambda ()
-                   (compile '(format #f
+                   (compile '((@ (ice-9 format) format) #f
                                      "~4@S    ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n"
                                      1 2 3 4 5 6)
                             #:opts %opts-w-format
@@ -2201,7 +1619,7 @@
      (pass-if "complex 2"
        (let ((w (call-with-warnings
                  (lambda ()
-                   (compile '(format #f
+                   (compile '((@ (ice-9 format) format) #f
                                      "~:(~A~) Commands~:[~; [abbrev]~]:~2%"
                                      1 2 3 4)
                             #:opts %opts-w-format
@@ -2213,7 +1631,7 @@
      (pass-if "complex 3"
        (let ((w (call-with-warnings
                  (lambda ()
-                   (compile '(format #f "~9@a~:[~*~3_~;~3d~] ~v:@y~%")
+                   (compile '((@ (ice-9 format) format) #f "~9@a~:[~*~3_~;~3d~] ~v:@y~%")
                             #:opts %opts-w-format
                             #:to 'assembly)))))
          (and (= (length w) 1)
@@ -2240,4 +1658,49 @@
                  (compile '(let ((format chbouib))
                              (format #t "not ~A a format string"))
                           #:opts %opts-w-format
-                          #:to 'assembly)))))))
+                          #:to 'assembly)))))
+
+     (with-test-prefix "simple-format"
+
+       (pass-if "good"
+         (null? (call-with-warnings
+                 (lambda ()
+                   (compile '(simple-format #t "foo ~a bar ~s ~%~~" 1 2)
+                            #:opts %opts-w-format
+                            #:to 'assembly)))))
+
+       (pass-if "wrong number of args"
+         (let ((w (call-with-warnings
+                   (lambda ()
+                     (compile '(simple-format #t "foo ~a ~s~%" 'one-missing)
+                              #:opts %opts-w-format
+                              #:to 'assembly)))))
+           (and (= (length w) 1)
+                (number? (string-contains (car w) "wrong number")))))
+
+       (pass-if "unsupported"
+         (let ((w (call-with-warnings
+                   (lambda ()
+                     (compile '(simple-format #t "foo ~x~%" 16)
+                              #:opts %opts-w-format
+                              #:to 'assembly)))))
+           (and (= (length w) 1)
+                (number? (string-contains (car w) "unsupported format option")))))
+
+       (pass-if "unsupported, gettext"
+         (let ((w (call-with-warnings
+                   (lambda ()
+                     (compile '(simple-format #t (gettext "foo ~2f~%") 3.14)
+                              #:opts %opts-w-format
+                              #:to 'assembly)))))
+           (and (= (length w) 1)
+                (number? (string-contains (car w) "unsupported format option")))))
+
+       (pass-if "unsupported, ngettext"
+         (let ((w (call-with-warnings
+                   (lambda ()
+                     (compile '(simple-format #t (ngettext "s ~x" "p ~x" x) x)
+                              #:opts %opts-w-format
+                              #:to 'assembly)))))
+           (and (= (length w) 1)
+                (number? (string-contains (car w) "unsupported format option"))))))))