1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-03 02:36:19 +02:00

peval: Add test for multiple-value returns.

* test-suite/tests/tree-il.test (pass-if-peval): Support the
  `resolve-primitives' keyword.
  ("partial evaluation"): Add test for `call-with-values'.
This commit is contained in:
Ludovic Courtès 2011-09-21 22:56:45 +02:00
parent ec6e09bee7
commit a4c7fe5cde

View file

@ -23,6 +23,7 @@
#: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))
@ -73,11 +74,19 @@
(@@ (language tree-il optimize) peval))
(define-syntax pass-if-peval
(syntax-rules ()
(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 (compile 'in #:from 'scheme #:to 'tree-il)))))
(let ((evaled (unparse-tree-il (peval code))))
(pmatch evaled
(pat #t)
(_ (pk 'peval-mismatch evaled) #f)))))))
@ -620,6 +629,16 @@
(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.
(cons 0 (cons 1 (cons 2 (list 3 4 5))))