mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-19 02:00:26 +02:00
Merge remote-tracking branch 'origin/stable-2.0'
Conflicts: libguile/debug.h module/ice-9/psyntax-pp.scm module/ice-9/psyntax.scm module/language/tree-il/peval.scm module/language/tree-il/primitives.scm
This commit is contained in:
Andy Wingo
commit
dfadcf85cb
45 changed files with 20479 additions and 19006 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))))))
|
||||
|
|
|
|||
|
|
@ -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"))))))))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue