summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/language/tree-il/compile-glil.scm7
-rw-r--r--test-suite/tests/tree-il.test21
2 files changed, 22 insertions, 6 deletions
diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index de55026ab..a9f6df938 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -1,6 +1,6 @@
;;; TREE-IL -> GLIL compiler
-;; Copyright (C) 2001,2008,2009,2010,2011 Free Software Foundation, Inc.
+;; Copyright (C) 2001,2008,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
@@ -341,13 +341,12 @@
(comp-push proc)
(emit-code src (make-glil-call 'call 0))
(maybe-emit-return))
- ((1)
- (comp-push (car args)))
(else
;; Taking advantage of unspecified order of evaluation of
;; arguments.
(for-each comp-drop (cdr args))
- (comp-push (car args)))))
+ (comp-push (car args))
+ (maybe-emit-return))))
((vals)
(for-each comp-push args)
(emit-code #f (make-glil-const (length args)))
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 0b00f6f8a..bb56c23cd 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -1,7 +1,7 @@
;;;; 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
@@ -549,7 +549,24 @@
(apply (primitive +)
(apply (primitive values) (const 1) (const 2)))
(program () (std-prelude 0 0 #f) (label _)
- (const 1) (call return 1))))
+ (const 1) (call return 1)))
+
+ ;; 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}#))))
+ (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