Author: yamakenz
Date: Fri Jun 15 06:27:07 2007
New Revision: 4603
Modified:
sigscheme-trunk/NEWS
sigscheme-trunk/QALog
sigscheme-trunk/src/continuation.c
sigscheme-trunk/src/eval.c
sigscheme-trunk/test/test-continuation.scm
Log:
* src/eval.c
- (call_continuation): Fix the case continuation takes multiple values
* src/continuation.c
- (scm_call_continuation): Ditto
* test/test-continuation.scm
- Add tests for the case
* QALog
* NEWS
- Update
Modified: sigscheme-trunk/NEWS
==============================================================================
--- sigscheme-trunk/NEWS (original)
+++ sigscheme-trunk/NEWS Fri Jun 15 06:27:07 2007
@@ -30,6 +30,9 @@
- [CRITICAL] Fix unterminated string generation on singlebyte character codec
+ - [R5RS] Fix multiple values inacceptance of call-with-values continuation
+ such as (receive (x y) (call/cc (lambda (k) (k 0 1))))
+
- [R6RS] Fix invalid Unicode character acception on integer->char
- Fix unexpected memory exhaustion on negative length on make-string
Modified: sigscheme-trunk/QALog
==============================================================================
--- sigscheme-trunk/QALog (original)
+++ sigscheme-trunk/QALog Fri Jun 15 06:27:07 2007
@@ -673,25 +673,25 @@
file: continuation.c
category: core
-spec by eyes: [EMAIL PROTECTED], [EMAIL PROTECTED]
-spec by tests: [EMAIL PROTECTED], [EMAIL PROTECTED]
+spec by eyes: [EMAIL PROTECTED], [EMAIL PROTECTED], [EMAIL PROTECTED]
+spec by tests: [EMAIL PROTECTED], [EMAIL PROTECTED], [EMAIL PROTECTED]
general review: [EMAIL PROTECTED]
64-bit by eyes: [EMAIL PROTECTED]
64-bit by tests:
coding style: [EMAIL PROTECTED]
-normal case tests: [EMAIL PROTECTED]
-corner case tests: [EMAIL PROTECTED]
+normal case tests: [EMAIL PROTECTED], [EMAIL PROTECTED]
+corner case tests: [EMAIL PROTECTED], [EMAIL PROTECTED]
file: eval.c
category: core
-spec by eyes: [EMAIL PROTECTED], [EMAIL PROTECTED], [EMAIL PROTECTED],
[EMAIL PROTECTED]
-spec by tests: [EMAIL PROTECTED], [EMAIL PROTECTED], [EMAIL PROTECTED]
+spec by eyes: [EMAIL PROTECTED], [EMAIL PROTECTED], [EMAIL PROTECTED],
[EMAIL PROTECTED], [EMAIL PROTECTED]
+spec by tests: [EMAIL PROTECTED], [EMAIL PROTECTED], [EMAIL PROTECTED],
[EMAIL PROTECTED]
general review: [EMAIL PROTECTED]
64-bit by eyes: [EMAIL PROTECTED]
64-bit by tests:
coding style: [EMAIL PROTECTED]
-normal case tests: [EMAIL PROTECTED], [EMAIL PROTECTED]
-corner case tests: [EMAIL PROTECTED], [EMAIL PROTECTED]
+normal case tests: [EMAIL PROTECTED], [EMAIL PROTECTED], [EMAIL PROTECTED]
+corner case tests: [EMAIL PROTECTED], [EMAIL PROTECTED], [EMAIL PROTECTED]
file: module.c
category: core
@@ -1081,6 +1081,12 @@
Log
---
+2007-06-15 YamaKen <yamaken AT bp.iij4u.or.jp>
+ * eval.c
+ * continuation.c
+ - Fix the case continuation takes multiple values
+ - QA done again @r4603 with test-continuation.scm
+
2007-06-13 YamaKen <yamaken AT bp.iij4u.or.jp>
* module-srfi2.c
- QA done @r4583 with test-srfi2.scm and oleg-srfi2.scm
Modified: sigscheme-trunk/src/continuation.c
==============================================================================
--- sigscheme-trunk/src/continuation.c (original)
+++ sigscheme-trunk/src/continuation.c Fri Jun 15 06:27:07 2007
@@ -327,9 +327,6 @@
#endif
)
{
- if (VALUEPACKETP(ret))
- ERR_OBJ("continuations take exactly one value but got", ret);
-
/* Don't refer cont because it may already be invalidated by
* continuation_stack_unwind(). */
exit_dynamic_extent(frame->dyn_ext);
Modified: sigscheme-trunk/src/eval.c
==============================================================================
--- sigscheme-trunk/src/eval.c (original)
+++ sigscheme-trunk/src/eval.c Fri Jun 15 06:27:07 2007
@@ -140,13 +140,18 @@
enum ScmValueType need_eval)
{
ScmObj ret;
+ scm_int_t args_len;
DECLARE_INTERNAL_FUNCTION("call_continuation");
- if (!LIST_1_P(args))
- ERR_OBJ("continuation takes exactly one argument but got", args);
- ret = CAR(args);
- if (need_eval)
- ret = EVAL(ret, eval_state->env);
+ /* (receive (x y) (call/cc (lambda (k) (k 0 1)))) */
+ if (LIST_1_P(args)) {
+ ret = CAR(args);
+ if (need_eval)
+ ret = EVAL(ret, eval_state->env);
+ } else {
+ ret = (need_eval) ? map_eval(args, &args_len, eval_state->env) : args;
+ ret = SCM_MAKE_VALUEPACKET(ret);
+ }
scm_call_continuation(cont, ret);
/* NOTREACHED */
}
Modified: sigscheme-trunk/test/test-continuation.scm
==============================================================================
--- sigscheme-trunk/test/test-continuation.scm (original)
+++ sigscheme-trunk/test/test-continuation.scm Fri Jun 15 06:27:07 2007
@@ -142,4 +142,69 @@
(assert-true (tn) ((call/cc (lambda (c) c))
procedure?)))
+(tn "call/cc multiple values continuation")
+(assert-equal? (tn)
+ '()
+ (call-with-values
+ (lambda ()
+ (call/cc (lambda (k) (k))))
+ (lambda args
+ args)))
+(assert-error (tn)
+ (lambda ()
+ (call-with-values
+ (lambda ()
+ (call/cc (lambda (k) (k 0))))
+ (lambda ()
+ #t))))
+(assert-error (tn)
+ (lambda ()
+ (call-with-values
+ (lambda ()
+ (call/cc (lambda (k) (k 0))))
+ (lambda (x y)
+ #t))))
+(assert-error (tn)
+ (lambda ()
+ (call/cc (lambda (k) (k)))))
+
+(assert-equal? (tn)
+ '(0 1 2)
+ (call-with-values
+ (lambda ()
+ (call/cc (lambda (k) (k 0 1 2))))
+ (lambda args
+ args)))
+(assert-error (tn)
+ (lambda ()
+ (call-with-values
+ (lambda ()
+ (call/cc (lambda (k) (k 0 1 2))))
+ (lambda ()
+ #t))))
+(assert-error (tn)
+ (lambda ()
+ (call-with-values
+ (lambda ()
+ (call/cc (lambda (k) (k 0 1 2))))
+ (lambda (x)
+ #t))))
+(assert-error (tn)
+ (lambda ()
+ (call-with-values
+ (lambda ()
+ (call/cc (lambda (k) (k 0 1 2))))
+ (lambda (x y)
+ #t))))
+(assert-error (tn)
+ (lambda ()
+ (call-with-values
+ (lambda ()
+ (call/cc (lambda (k) (k 0 1 2))))
+ (lambda (x y z a)
+ #t))))
+(assert-error (tn)
+ (lambda ()
+ (call/cc (lambda (k) (k 0 1 2)))))
+
(total-report)
