;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*-
;;;; Andy Wingo <wingo@pobox.com> --- May 2009
;;;;
-;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013 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
\f
(with-test-prefix "primitives"
- (pass-if-primitives-resolved
- (apply (primitive equal?) (toplevel x) (const #f))
- (apply (primitive not) (toplevel x)))
+ (with-test-prefix "eqv?"
- (pass-if-primitives-resolved
- (apply (primitive equal?) (toplevel x) (const ()))
- (apply (primitive null?) (toplevel x)))
+ (pass-if-primitives-resolved
+ (apply (primitive eqv?) (const #f) (toplevel x))
+ (apply (primitive eq?) (const #f) (toplevel x)))
- (pass-if-primitives-resolved
- (apply (primitive equal?) (const #t) (lexical x y))
- (apply (primitive eq?) (const #t) (lexical x y)))
+ (pass-if-primitives-resolved
+ (apply (primitive eqv?) (const ()) (toplevel x))
+ (apply (primitive eq?) (const ()) (toplevel x)))
- (pass-if-primitives-resolved
- (apply (primitive equal?) (const this-is-a-symbol) (toplevel x))
- (apply (primitive eq?) (const this-is-a-symbol) (toplevel x)))
+ (pass-if-primitives-resolved
+ (apply (primitive eqv?) (const #t) (lexical x y))
+ (apply (primitive eq?) (const #t) (lexical x y)))
- (pass-if-primitives-resolved
- (apply (primitive equal?) (const 42) (toplevel x))
- (apply (primitive eq?) (const 42) (toplevel x)))
+ (pass-if-primitives-resolved
+ (apply (primitive eqv?) (const this-is-a-symbol) (toplevel x))
+ (apply (primitive eq?) (const this-is-a-symbol) (toplevel x)))
- (pass-if-primitives-resolved
- (apply (primitive equal?) (const 42.0) (toplevel x))
- (apply (primitive equal?) (const 42.0) (toplevel x)))
+ (pass-if-primitives-resolved
+ (apply (primitive eqv?) (const 42) (toplevel x))
+ (apply (primitive eq?) (const 42) (toplevel x)))
- (pass-if-primitives-resolved
- (apply (primitive equal?) (const #nil) (toplevel x))
- (apply (primitive eq?) (const #nil) (toplevel x))))
+ (pass-if-primitives-resolved
+ (apply (primitive eqv?) (const 42.0) (toplevel x))
+ (apply (primitive eqv?) (const 42.0) (toplevel x)))
+
+ (pass-if-primitives-resolved
+ (apply (primitive eqv?) (const #nil) (toplevel x))
+ (apply (primitive eq?) (const #nil) (toplevel x))))
+
+ (with-test-prefix "equal?"
+
+ (pass-if-primitives-resolved
+ (apply (primitive equal?) (const #f) (toplevel x))
+ (apply (primitive eq?) (const #f) (toplevel x)))
+
+ (pass-if-primitives-resolved
+ (apply (primitive equal?) (const ()) (toplevel x))
+ (apply (primitive eq?) (const ()) (toplevel x)))
+
+ (pass-if-primitives-resolved
+ (apply (primitive equal?) (const #t) (lexical x y))
+ (apply (primitive eq?) (const #t) (lexical x y)))
+
+ (pass-if-primitives-resolved
+ (apply (primitive equal?) (const this-is-a-symbol) (toplevel x))
+ (apply (primitive eq?) (const this-is-a-symbol) (toplevel x)))
+
+ (pass-if-primitives-resolved
+ (apply (primitive equal?) (const 42) (toplevel x))
+ (apply (primitive eq?) (const 42) (toplevel x)))
+
+ (pass-if-primitives-resolved
+ (apply (primitive equal?) (const 42.0) (toplevel x))
+ (apply (primitive equal?) (const 42.0) (toplevel x)))
+
+ (pass-if-primitives-resolved
+ (apply (primitive equal?) (const #nil) (toplevel x))
+ (apply (primitive eq?) (const #nil) (toplevel x)))))
\f
(with-test-prefix "tree-il->scheme"
#:opts '(#:partial-eval? #f)))))
\f
+(define (sum . args)
+ (apply + args))
+
+(with-test-prefix "many args"
+ (pass-if "call with > 256 args"
+ (equal? (compile `(1+ (sum ,@(iota 1000)))
+ #:env (current-module))
+ (1+ (apply sum (iota 1000)))))
+
+ (pass-if "tail call with > 256 args"
+ (equal? (compile `(sum ,@(iota 1000))
+ #:env (current-module))
+ (apply sum (iota 1000)))))
+
+
+\f
(with-test-prefix "tree-il-fold"
(pass-if "empty tree"
(define %opts-w-format
'(#:warnings (format)))
+(define %opts-w-duplicate-case-datum
+ '(#:warnings (duplicate-case-datum)))
+
+(define %opts-w-bad-case-datum
+ '(#:warnings (bad-case-datum)))
+
(with-test-prefix "warnings"
(number? (string-contains (car w)
"wrong number of arguments")))))
- (pass-if "~%, ~~, ~&, ~t, ~_, and ~\\n"
+ (pass-if "~%, ~~, ~&, ~t, ~_, ~!, ~|, ~/, ~q and ~\\n"
(null? (call-with-warnings
(lambda ()
(compile '((@ (ice-9 format) format) some-port
- "~&~3_~~ ~\n~12they~%")
+ "~&~3_~~ ~\n~12they~% ~!~|~/~q")
#:opts %opts-w-format
#:to 'assembly)))))
#:opts %opts-w-format
#:to 'assembly)))))
+ (pass-if "~^"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '((@ (ice-9 format) format) #f "~a ~^ ~a" 0 1)
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+
+ (pass-if "~^, too few args"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '((@ (ice-9 format) format) #f "~a ~^ ~a")
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w)
+ "expected at least 1, got 0")))))
+
+ (pass-if "parameters: +,-,#, and '"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '((@ (ice-9 format) format) some-port
+ "~#~ ~,,-2f ~,,+2f ~'A~" 1234 1234)
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+
(pass-if "complex 1"
(let ((w (call-with-warnings
(lambda ()
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
- (number? (string-contains (car w) "unsupported format option"))))))))
+ (number? (string-contains (car w) "unsupported format option")))))))
+
+ (with-test-prefix "duplicate-case-datum"
+
+ (pass-if "quiet"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(case x ((1) 'one) ((2) 'two))
+ #:opts %opts-w-duplicate-case-datum
+ #:to 'assembly)))))
+
+ (pass-if "one duplicate"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '(case x
+ ((1) 'one)
+ ((2) 'two)
+ ((1) 'one-again))
+ #:opts %opts-w-duplicate-case-datum
+ #:to 'assembly)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w) "duplicate")))))
+
+ (pass-if "one duplicate"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '(case x
+ ((1 2 3) 'a)
+ ((1) 'one))
+ #:opts %opts-w-duplicate-case-datum
+ #:to 'assembly)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w) "duplicate"))))))
+
+ (with-test-prefix "bad-case-datum"
+
+ (pass-if "quiet"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(case x ((1) 'one) ((2) 'two))
+ #:opts %opts-w-bad-case-datum
+ #:to 'assembly)))))
+
+ (pass-if "not eqv?"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '(case x
+ ((1) 'one)
+ (("bad") 'bad))
+ #:opts %opts-w-bad-case-datum
+ #:to 'assembly)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w)
+ "cannot be meaningfully compared")))))
+
+ (pass-if "one clause element not eqv?"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '(case x
+ ((1 (2) 3) 'a))
+ #:opts %opts-w-duplicate-case-datum
+ #:to 'assembly)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w)
+ "cannot be meaningfully compared")))))))
;; Local Variables:
;; eval: (put 'pass-if-primitives-resolved 'scheme-indent-function 1)
HCoop / bpt / guile.git / blobdiff