diff options
Diffstat (limited to 'test-suite')
-rw-r--r-- | test-suite/standalone/test-loose-ends.c | 36 | ||||
-rw-r--r-- | test-suite/tests/eval.test | 101 | ||||
-rw-r--r-- | test-suite/tests/gc.test | 34 | ||||
-rw-r--r-- | test-suite/tests/tree-il.test | 93 |
4 files changed, 218 insertions, 46 deletions
diff --git a/test-suite/standalone/test-loose-ends.c b/test-suite/standalone/test-loose-ends.c index 2fdbe7d4b..ee0fcf3f3 100644 --- a/test-suite/standalone/test-loose-ends.c +++ b/test-suite/standalone/test-loose-ends.c @@ -3,7 +3,7 @@ * Test items of the Guile C API that aren't covered by any other tests. */ -/* Copyright (C) 2009 Free Software Foundation, Inc. +/* Copyright (C) 2009, 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 License @@ -43,9 +43,43 @@ test_scm_from_locale_keywordn () } static void +test_scm_local_eval () +{ + SCM result; + + scm_c_use_module ("ice-9 local-eval"); + result = scm_local_eval + (scm_list_3 (scm_from_latin1_symbol ("+"), + scm_from_latin1_symbol ("x"), + scm_from_latin1_symbol ("y")), + scm_c_eval_string ("(let ((x 1) (y 2)) (the-environment))")); + + assert (scm_is_true (scm_equal_p (result, + scm_from_signed_integer (3)))); +} + +static void +test_scm_call () +{ + SCM result; + + result = scm_call (scm_c_public_ref ("guile", "+"), + scm_from_int (1), + scm_from_int (2), + SCM_UNDEFINED); + assert (scm_is_true (scm_equal_p (result, scm_from_int (3)))); + + result = scm_call (scm_c_public_ref ("guile", "list"), + SCM_UNDEFINED); + assert (scm_is_eq (result, SCM_EOL)); +} + +static void tests (void *data, int argc, char **argv) { test_scm_from_locale_keywordn (); + test_scm_local_eval (); + test_scm_call (); } int diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test index a128cd7e1..a5fbfece2 100644 --- a/test-suite/tests/eval.test +++ b/test-suite/tests/eval.test @@ -1,5 +1,5 @@ ;;;; eval.test --- tests guile's evaluator -*- scheme -*- -;;;; Copyright (C) 2000, 2001, 2006, 2007, 2009, 2010, 2011 Free Software Foundation, Inc. +;;;; Copyright (C) 2000, 2001, 2006, 2007, 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 @@ -19,7 +19,8 @@ :use-module (test-suite lib) :use-module ((srfi srfi-1) :select (unfold count)) :use-module ((system vm vm) :select (make-vm call-with-vm)) - :use-module (ice-9 documentation)) + :use-module (ice-9 documentation) + :use-module (ice-9 local-eval)) (define exception:bad-expression @@ -74,6 +75,10 @@ (with-test-prefix "evaluator" + (pass-if "definitions return #<unspecified>" + (eq? (primitive-eval '(define test-var 'foo)) + (if #f #f))) + (with-test-prefix "symbol lookup" (with-test-prefix "top level" @@ -422,4 +427,96 @@ (thunk (let loop () (cons 's (loop))))) (call-with-vm vm thunk)))) +;;; +;;; local-eval +;;; + +(with-test-prefix "local evaluation" + + (pass-if "local-eval" + + (let* ((env1 (local-eval '(let ((x 1) (y 2) (z 3)) + (define-syntax-rule (foo x) (quote x)) + (the-environment)) + (current-module))) + (env2 (local-eval '(let ((x 111) (a 'a)) + (define-syntax-rule (bar x) (quote x)) + (the-environment)) + env1))) + (local-eval '(set! x 11) env1) + (local-eval '(set! y 22) env1) + (local-eval '(set! z 33) env2) + (and (equal? (local-eval '(list x y z) env1) + '(11 22 33)) + (equal? (local-eval '(list x y z a) env2) + '(111 22 33 a))))) + + (pass-if "local-compile" + + (let* ((env1 (local-compile '(let ((x 1) (y 2) (z 3)) + (define-syntax-rule (foo x) (quote x)) + (the-environment)) + (current-module))) + (env2 (local-compile '(let ((x 111) (a 'a)) + (define-syntax-rule (bar x) (quote x)) + (the-environment)) + env1))) + (local-compile '(set! x 11) env1) + (local-compile '(set! y 22) env1) + (local-compile '(set! z 33) env2) + (and (equal? (local-compile '(list x y z) env1) + '(11 22 33)) + (equal? (local-compile '(list x y z a) env2) + '(111 22 33 a))))) + + (pass-if "the-environment within a macro" + (let ((module-a-name '(test module the-environment a)) + (module-b-name '(test module the-environment b))) + (let ((module-a (resolve-module module-a-name)) + (module-b (resolve-module module-b-name))) + (module-use! module-a (resolve-interface '(guile))) + (module-use! module-a (resolve-interface '(ice-9 local-eval))) + (eval '(begin + (define z 3) + (define-syntax-rule (test) + (let ((x 1) (y 2)) + (the-environment)))) + module-a) + (module-use! module-b (resolve-interface '(guile))) + (let ((env (local-eval `(let ((x 111) (y 222)) + ((@@ ,module-a-name test))) + module-b))) + (equal? (local-eval '(list x y z) env) + '(1 2 3)))))) + + (pass-if "capture pattern variables" + (let ((env (syntax-case #'(((a 1) (b 2) (c 3)) + ((d 4) (e 5) (f 6))) () + ((((k v) ...) ...) (the-environment))))) + (equal? (syntax->datum (local-eval '#'((k ... v ...) ...) env)) + '((a b c 1 2 3) (d e f 4 5 6))))) + + (pass-if "mixed primitive-eval, local-eval and local-compile" + + (let* ((env1 (primitive-eval '(let ((x 1) (y 2) (z 3)) + (define-syntax-rule (foo x) (quote x)) + (the-environment)))) + (env2 (local-eval '(let ((x 111) (a 'a)) + (define-syntax-rule (bar x) (quote x)) + (the-environment)) + env1)) + (env3 (local-compile '(let ((y 222) (b 'b)) + (the-environment)) + env2))) + (local-eval '(set! x 11) env1) + (local-compile '(set! y 22) env2) + (local-eval '(set! z 33) env2) + (local-compile '(set! a (* y 2)) env3) + (and (equal? (local-compile '(list x y z) env1) + '(11 22 33)) + (equal? (local-eval '(list x y z a) env2) + '(111 22 33 444)) + (equal? (local-eval '(list x y z a b) env3) + '(111 222 33 444 b)))))) + ;;; eval.test ends here diff --git a/test-suite/tests/gc.test b/test-suite/tests/gc.test index 527bef56c..97eeb195e 100644 --- a/test-suite/tests/gc.test +++ b/test-suite/tests/gc.test @@ -87,14 +87,26 @@ total))) (pass-if "Lexical vars are collectable" - (list? - (compile - '(begin - (define guardian (make-guardian)) - (let ((f (list 'foo))) - ;; Introduce a useless second reference to f to prevent the - ;; optimizer from propagating the lexical binding. - f - (guardian f)) - (gc)(gc)(gc) - (guardian)))))) + (let ((l (compile + '(begin + (define guardian (make-guardian)) + (let ((f (list 'foo))) + (guardian f)) + ;; See below. + ;; ((lambda () #t)) + (gc)(gc)(gc) + (guardian)) + ;; Prevent the optimizer from propagating f. + #:opts '(#:partial-eval? #f)))) + (if (not l) + ;; We think that something on the C stack in the VM is holding + ;; on to a reference to the list. This happens on + ;; register-poor architectures, where more locals are spilled + ;; to the stack. If more code runs before the (gc) is run, + ;; like a ((lambda () #t)), then the test passes. So given + ;; that at some point, the reference will be dropped, we will + ;; count these cases as "unresolved" instead of "fail". + ;; + ;; See http://debbugs.gnu.org/cgi/bugreport.cgi?bug=10336. + (throw 'unresolved) + (equal? l '(foo)))))) diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index ebf78146e..0ab58c98a 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -550,12 +550,12 @@ ;; Testing `(values foo)' in push context with RA. (assert-tree-il->glil without-partial-evaluation - (apply (primitive cdr) - (letrec (lp) (#{lp ~V9KrhVD4PFEL6oCTrLg3A}#) - ((lambda ((name . lp)) - (lambda-case ((() #f #f #f () ()) - (apply (toplevel values) (const (one two))))))) - (apply (lexical lp #{lp ~V9KrhVD4PFEL6oCTrLg3A}#)))) + (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 @@ -2194,7 +2194,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))))) @@ -2221,7 +2222,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) @@ -2252,7 +2254,7 @@ (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))))) @@ -2260,7 +2262,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))))) @@ -2271,7 +2273,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) @@ -2281,7 +2283,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) @@ -2291,7 +2293,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) @@ -2301,7 +2303,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) @@ -2311,7 +2313,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) @@ -2321,7 +2323,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) @@ -2331,7 +2333,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) @@ -2341,7 +2343,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) @@ -2351,7 +2353,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 @@ -2360,7 +2362,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) @@ -2370,14 +2372,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) @@ -2387,7 +2389,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) @@ -2397,14 +2399,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) @@ -2413,7 +2415,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))))) @@ -2421,7 +2423,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) @@ -2431,14 +2433,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 @@ -2450,7 +2452,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 @@ -2462,7 +2464,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) @@ -2489,4 +2491,31 @@ (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")))))))) |