;;;; 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
#:use-module (system base pmatch)
#:use-module (system base message)
#:use-module (language tree-il)
+ #:use-module (language tree-il primitives)
#:use-module (language glil)
#:use-module (srfi srfi-13))
(post-order! (lambda (x) (set! (tree-il-src x) #f))
x))
-(define-syntax assert-scheme->glil
- (syntax-rules ()
- ((_ in out)
- (let ((tree-il (strip-source
- (compile 'in #:from 'scheme #:to 'tree-il))))
- (pass-if 'in
- (equal? (unparse-glil (compile tree-il #:from 'tree-il #:to 'glil))
- 'out))))))
-
(define-syntax assert-tree-il->glil
- (syntax-rules ()
- ((_ in pat test ...)
+ (syntax-rules (with-partial-evaluation without-partial-evaluation
+ with-options)
+ ((_ with-partial-evaluation in pat test ...)
+ (assert-tree-il->glil with-options (#:partial-eval? #t)
+ in pat test ...))
+ ((_ without-partial-evaluation in pat test ...)
+ (assert-tree-il->glil with-options (#:partial-eval? #f)
+ in pat test ...))
+ ((_ with-options opts in pat test ...)
(let ((exp 'in))
(pass-if 'in
(let ((glil (unparse-glil
(compile (strip-source (parse-tree-il exp))
- #:from 'tree-il #:to 'glil))))
+ #:from 'tree-il #:to 'glil
+ #:opts 'opts))))
(pmatch glil
(pat (guard test ...) #t)
- (else #f))))))))
+ (else #f))))))
+ ((_ in pat test ...)
+ (assert-tree-il->glil with-partial-evaluation
+ in pat test ...))))
+
+(define-syntax pass-if-tree-il->scheme
+ (syntax-rules ()
+ ((_ in pat)
+ (assert-scheme->tree-il->scheme in pat #t))
+ ((_ in pat guard-exp)
+ (pass-if 'in
+ (pmatch (tree-il->scheme
+ (compile 'in #:from 'scheme #:to 'tree-il))
+ (pat (guard guard-exp) #t)
+ (_ #f))))))
+
+\f
+(with-test-prefix "tree-il->scheme"
+ (pass-if-tree-il->scheme
+ (case-lambda ((a) a) ((b c) (list b c)))
+ (case-lambda ((,a) ,a1) ((,b ,c) (list ,b1 ,c1)))
+ (and (eq? a a1) (eq? b b1) (eq? c c1))))
(with-test-prefix "void"
(assert-tree-il->glil
(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)
(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))))
(const 1) (call return 1)
(label ,l2) (const 2) (call return 1))
(eq? l1 l2))
-
- (assert-tree-il->glil
+
+ (assert-tree-il->glil without-partial-evaluation
(begin (if (toplevel foo) (const 1) (const 2)) (const #f))
(program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1) (branch br ,l2)
(label ,l3) (label ,l4) (const #f) (call return 1))
(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)
(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))))
(with-test-prefix "lexical refs"
- (assert-tree-il->glil
+ (assert-tree-il->glil without-partial-evaluation
(let (x) (y) ((const 1)) (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 return 1)
(unbind)))
- (assert-tree-il->glil
+ (assert-tree-il->glil without-partial-evaluation
(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)
(const #f) (call return 1)
(unbind)))
- (assert-tree-il->glil
- (let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y)))
+ (assert-tree-il->glil without-partial-evaluation
+ (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)
(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)
(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)
(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)
(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)))
(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))))
(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)))
(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))))
(toplevel ref bar)
(call return 1)))
- (assert-tree-il->glil
+ (assert-tree-il->glil without-partial-evaluation
(begin (toplevel bar) (const #f))
(program () (std-prelude 0 0 #f) (label _)
(toplevel ref bar) (call drop 1)
(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))))
(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))))
(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))))
(const #f) (call return 1)))
(assert-tree-il->glil
- (apply (primitive null?) (const 2))
+ ;; This gets simplified by `peval'.
+ (primcall null? (const 2))
(program () (std-prelude 0 0 #f) (label _)
- (const 2) (call null? 1) (call return 1))))
+ (const #f) (call return 1))))
(with-test-prefix "letrec"
;; simple bindings -> let
- (assert-tree-il->glil
+ (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))
(unbind)))
;; complex bindings -> box and set! within let
- (assert-tree-il->glil
- (letrec (x y) (x1 y1) ((apply (toplevel foo)) (apply (toplevel bar)))
- (apply (primitive +) (lexical x x1) (lexical y y1)))
+ (assert-tree-il->glil without-partial-evaluation
+ (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))
(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
- (letrec* (x y) (x1 y1) ((apply (toplevel foo)) (apply (toplevel bar)))
- (apply (primitive +) (lexical x x1) (lexical y y1)))
+ (assert-tree-il->glil without-partial-evaluation
+ (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))
(call add 2) (call return 1) (unbind)))
;; simple bindings in letrec* -> equivalent to letrec
- (assert-tree-il->glil
+ (assert-tree-il->glil without-partial-evaluation
(letrec* (x y) (xx yy) ((const 1) (const 2))
(lexical y yy))
(program () (std-prelude 0 1 #f) (label _)
(const #t) (call return 1)))
(assert-tree-il->glil
- (apply (primitive null?) (begin (const #f) (const 2)))
+ ;; This gets simplified by `peval'.
+ (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
+ (primcall values
+ (primcall values (const 1) (const 2)))
(program () (std-prelude 0 0 #f) (label _)
- (const 2) (call null? 1) (call return 1))))
+ (const 1) (call return 1)))
+
+ (assert-tree-il->glil
+ (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
+ (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 _)
+ (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
(with-test-prefix "the or hack"
- (assert-tree-il->glil
+ (assert-tree-il->glil without-partial-evaluation
(let (x) (y) ((const 1))
(if (lexical x y)
(lexical x y)
(eq? l1 l2))
;; second bound var is unreferenced
- (assert-tree-il->glil
+ (assert-tree-il->glil without-partial-evaluation
(let (x) (y) ((const 1))
(if (lexical x y)
(lexical x y)
(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)
(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)
(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)
(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))))
\f
+(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)))))
+
+\f
(with-test-prefix "tree-il-fold"
(pass-if "empty tree"
'(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)
"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 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 ()
(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)))))
(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)
(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)
(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)))))
(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)))))
(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)
(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)
(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)
(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)
(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)
(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)
(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)
(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)
(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
(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)
(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)
(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)
(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)
(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)))))
(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)
(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
(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
(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)
(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"))))))))