[uim-commit] r1220 - in branches/r5rs/sigscheme: . test
kzk at freedesktop.org
kzk at freedesktop.org
Thu Aug 18 07:30:52 PDT 2005
Author: kzk
Date: 2005-08-18 07:29:19 -0700 (Thu, 18 Aug 2005)
New Revision: 1220
Modified:
branches/r5rs/sigscheme/datas.c
branches/r5rs/sigscheme/debug.c
branches/r5rs/sigscheme/eval.c
branches/r5rs/sigscheme/operations.c
branches/r5rs/sigscheme/sigscheme.c
branches/r5rs/sigscheme/sigscheme.h
branches/r5rs/sigscheme/sigschemetype.h
branches/r5rs/sigscheme/test/gauche-primsyn.scm
branches/r5rs/sigscheme/test/test-exp.scm
Log:
* implement "values" and "call-with-values".
This patch is created by Jun Inoue<jun.lambda at gmail.com>.
Very, Very thank you!
* sigscheme/sigscheme.c
- (SigScm_Initialize): export "values" and "call-with-values"
* sigscheme/sigscheme.h
- (Scm_NewValuePacket): new func
- (ScmOp_values, ScmOp_call_with_values): new func
* sigscheme/sigschemetype.h
- (ScmValuePacket): new type
- (value_pack): new union member
- (SCM_VALUEPACKETP, SCM_VALUEPACKET, SCM_VALUEPACKET_VALUES,
SCM_SETVALUEPACKET, SCM_SETVALUEPACKET_VALUES): new macro
* sigscheme/operations.c
- (ScmOp_eqp, ScmOp_equalp): handle ScmValuePacket
- (ScmOp_values, ScmOp_call_with_values): new func
* sigscheme/eval.c
- (qquote_internal): update comment
* sigscheme/datas.c
- (mark_obj): handle ScmValuePacket
- (ScmNewValuePacket): new func
* sigscheme/test/test-exp.scm
* sigscheme/test/gauche-primsyn.scm
- add test case for multiple values
Modified: branches/r5rs/sigscheme/datas.c
===================================================================
--- branches/r5rs/sigscheme/datas.c 2005-08-18 12:36:36 UTC (rev 1219)
+++ branches/r5rs/sigscheme/datas.c 2005-08-18 14:29:19 UTC (rev 1220)
@@ -366,6 +366,9 @@
obj = SCM_CLOSURE_ENV(obj);
goto mark_loop;
break;
+ case ScmValuePacket:
+ obj = SCM_VALUEPACKET_VALUES(obj);
+ goto mark_loop;
case ScmVector:
for (i = 0; i < SCM_VECTOR_LEN(obj); i++) {
mark_obj(SCM_VECTOR_VEC(obj)[i]);
@@ -763,6 +766,16 @@
return obj;
}
+ScmObj Scm_NewValuePacket(ScmObj values)
+{
+ ScmObj packet = SCM_NIL;
+ SCM_NEW_OBJ_INTERNAL(packet);
+
+ SCM_SETVALUEPACKET(packet);
+ SCM_SETVALUEPACKET_VALUES(packet, values);
+ return packet;
+}
+
ScmObj Scm_NewCPointer(void *data)
{
ScmObj obj = SCM_NIL;
Modified: branches/r5rs/sigscheme/debug.c
===================================================================
--- branches/r5rs/sigscheme/debug.c 2005-08-18 12:36:36 UTC (rev 1219)
+++ branches/r5rs/sigscheme/debug.c 2005-08-18 14:29:19 UTC (rev 1220)
@@ -139,6 +139,11 @@
case ScmContinuation:
fprintf(f, "#<subr continuation>");
break;
+ case ScmValuePacket:
+ fputs("#<values ", f);
+ print_list(f, SCM_VALUEPACKET_VALUES(obj), otype);
+ putc('>', f);
+ break;
case ScmEtc:
print_etc(f, obj, otype);
break;
Modified: branches/r5rs/sigscheme/eval.c
===================================================================
--- branches/r5rs/sigscheme/eval.c 2005-08-18 12:36:36 UTC (rev 1219)
+++ branches/r5rs/sigscheme/eval.c 2005-08-18 14:29:19 UTC (rev 1220)
@@ -721,7 +721,7 @@
result = qquote_internal(obj, env, nest);
if (EQ(SCM_CAR(obj), SCM_UNQUOTE_SPLICING) && nest == 1) {
- /* ,x or , at x */
+ /* , at x */
splice_flag = 1;
}
} else if (SCM_VECTORP(obj)) {
@@ -764,8 +764,7 @@
} /* foreach ls in qexpr */
/* Handle the leftover of an improper list; if qexpr is a proper
- * list, all the following will be a no-op. */
-
+ * list, all the following will be a no-op. */
if (SCM_VECTORP(ls))
result = qquote_vector(ls, env, nest);
else
Modified: branches/r5rs/sigscheme/operations.c
===================================================================
--- branches/r5rs/sigscheme/operations.c 2005-08-18 12:36:36 UTC (rev 1219)
+++ branches/r5rs/sigscheme/operations.c 2005-08-18 14:29:19 UTC (rev 1220)
@@ -130,6 +130,7 @@
break;
case ScmCPointer:
case ScmCFuncPointer:
+ case ScmValuePacket:
if (EQ(obj1, obj2))
{
return SCM_TRUE;
@@ -248,6 +249,12 @@
return SCM_TRUE;
}
break;
+ case ScmValuePacket:
+ if (EQ(SCM_VALUEPACKET_VALUES(obj1), SCM_VALUEPACKET_VALUES(obj2)))
+ {
+ return SCM_TRUE;
+ }
+ break;
}
return SCM_FALSE;
@@ -1946,6 +1953,47 @@
return ScmOp_eval(arg, env);
}
+ScmObj ScmOp_values(ScmObj argl, ScmObj env)
+{
+ /* Values with one arg must return something that fits an ordinary
+ * continuation. */
+ if (SCM_CONSP(argl) && SCM_NULLP(SCM_CDR(argl)))
+ return SCM_CAR(argl);
+
+ /* Otherwise, we'll return the values in a packet. */
+ return Scm_NewValuePacket(argl);
+}
+
+ScmObj ScmOp_call_with_values(ScmObj argl, ScmObj *envp, int *tail_flag)
+{
+ ScmObj vals;
+ ScmObj cons_wrapper;
+
+ /* This should go away when we reorganize function types. */
+ if (CHECK_2_ARGS(argl))
+ SigScm_ErrorObj("call-with-values: too few arguments: ", argl);
+
+ /* make the list (producer) and evaluate it */
+ cons_wrapper = Scm_NewCons(SCM_CAR(argl), SCM_NIL);
+ vals = ScmOp_eval(cons_wrapper, *envp);
+
+ if (!SCM_VALUEPACKETP(vals)) {
+ /* got back a single value */
+ vals = Scm_NewCons(vals, SCM_NIL);
+ } else {
+ /* extract */
+ vals = SCM_VALUEPACKET_VALUES(vals);
+ }
+
+ *tail_flag = 1;
+
+ /* cons_wrapper would have no chance of being referenced from
+ * anywhere else, so we'll reuse that object. */
+ SCM_SETCAR(cons_wrapper, SCM_CADR(argl));
+ SCM_SETCDR(cons_wrapper, vals);
+ return cons_wrapper;
+}
+
#if USE_SRFI1
#include "operations-srfi1.c"
#endif
Modified: branches/r5rs/sigscheme/sigscheme.c
===================================================================
--- branches/r5rs/sigscheme/sigscheme.c 2005-08-18 12:36:36 UTC (rev 1219)
+++ branches/r5rs/sigscheme/sigscheme.c 2005-08-18 14:29:19 UTC (rev 1220)
@@ -254,6 +254,8 @@
Scm_RegisterFuncL("for-each" , ScmOp_for_each);
Scm_RegisterFuncL("force" , ScmOp_force);
Scm_RegisterFuncL("call-with-current-continuation", ScmOp_call_with_current_continuation);
+ Scm_RegisterFuncL("values" , ScmOp_values);
+ Scm_RegisterFuncR("call-with-values" , ScmOp_call_with_values);
/* io.c */
Scm_RegisterFunc2("call-with-input-file" , ScmOp_call_with_input_file);
Scm_RegisterFunc2("call-with-output-file", ScmOp_call_with_output_file);
Modified: branches/r5rs/sigscheme/sigscheme.h
===================================================================
--- branches/r5rs/sigscheme/sigscheme.h 2005-08-18 12:36:36 UTC (rev 1219)
+++ branches/r5rs/sigscheme/sigscheme.h 2005-08-18 14:29:19 UTC (rev 1220)
@@ -132,6 +132,7 @@
ScmObj Scm_NewFilePort(FILE *file, const char *filename, enum ScmPortDirection pdireciton);
ScmObj Scm_NewStringPort(const char *str); /* input only? */
ScmObj Scm_NewContinuation(void);
+ScmObj Scm_NewValuePacket(ScmObj values);
ScmObj Scm_NewCPointer(void *data);
ScmObj Scm_NewCFuncPointer(C_FUNC func);
ScmObj Scm_Intern(const char *name);
@@ -289,6 +290,8 @@
ScmObj ScmOp_for_each(ScmObj arg, ScmObj env);
ScmObj ScmOp_force(ScmObj arg, ScmObj env);
ScmObj ScmOp_call_with_current_continuation(ScmObj arg, ScmObj env);
+ScmObj ScmOp_values(ScmObj argl, ScmObj env);
+ScmObj ScmOp_call_with_values(ScmObj args, ScmObj *envp, int *tail_flag);
/* io.c */
void SigScm_set_lib_path(const char *path);
Modified: branches/r5rs/sigscheme/sigschemetype.h
===================================================================
--- branches/r5rs/sigscheme/sigschemetype.h 2005-08-18 12:36:36 UTC (rev 1219)
+++ branches/r5rs/sigscheme/sigschemetype.h 2005-08-18 14:29:19 UTC (rev 1220)
@@ -63,7 +63,8 @@
ScmEtc = 11,
ScmCPointer = 20,
- ScmCFuncPointer = 21
+ ScmCFuncPointer = 21,
+ ScmValuePacket = 22
};
/* Function Type by argnuments */
@@ -203,6 +204,10 @@
ScmContInfo *cont_info;
} continuation;
+ struct ScmValuePacket {
+ ScmObj values;
+ } value_pack;
+
struct ScmEtc {
int type;
} etc;
@@ -331,6 +336,12 @@
#define SCM_SETCONTINUATION(a) (SCM_SETTYPE((a), ScmContinuation))
#define SCM_SETCONTINUATION_CONTINFO(a, cinfo) (SCM_CONTINUATION_CONTINFO(a) = (cinfo))
+#define SCM_VALUEPACKETP(a) (SCM_GETTYPE(a) == ScmValuePacket)
+#define SCM_VALUEPACKET(a) (sigassert(SCM_VALUEPACKETP(a)), (a))
+#define SCM_VALUEPACKET_VALUES(a) (SCM_VALUEPACKET(a)->obj.value_pack.values)
+#define SCM_SETVALUEPACKET(a) (SCM_SETTYPE((a), ScmValuePacket))
+#define SCM_SETVALUEPACKET_VALUES(a, v) (SCM_VALUEPACKET_VALUES(a) = (v))
+
/*============================================================================
Etcetra variables (Special Symbols like NIL)
============================================================================*/
Modified: branches/r5rs/sigscheme/test/gauche-primsyn.scm
===================================================================
--- branches/r5rs/sigscheme/test/gauche-primsyn.scm 2005-08-18 12:36:36 UTC (rev 1219)
+++ branches/r5rs/sigscheme/test/gauche-primsyn.scm 2005-08-18 14:29:19 UTC (rev 1220)
@@ -135,10 +135,10 @@
; (lambda () (receive x (values 1 2 3) x)))
;(test "receive" 1
; (lambda () (receive (a) 1 a)))
-;(test "call-with-values" '(1 2 3)
-; (lambda () (call-with-values (lambda () (values 1 2 3)) list)))
-;(test "call-with-values" '()
-; (lambda () (call-with-values (lambda () (values)) list)))
+(test "call-with-values" '(1 2 3)
+ (lambda () (call-with-values (lambda () (values 1 2 3)) list)))
+(test "call-with-values" '()
+ (lambda () (call-with-values (lambda () (values)) list)))
(total-report)
Modified: branches/r5rs/sigscheme/test/test-exp.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-exp.scm 2005-08-18 12:36:36 UTC (rev 1219)
+++ branches/r5rs/sigscheme/test/test-exp.scm 2005-08-18 14:29:19 UTC (rev 1220)
@@ -180,5 +180,14 @@
(assert-equal? "do test4" '(c b a) (nreverse '(a b c)))
(assert-equal? "do test5" '((5 6) (3 4) (1 2)) (nreverse '((1 2) (3 4) (5 6))))
+;; from R5RS
+(assert-equal? "values test1" 5
+ (call-with-values (lambda () (values 4 5))
+ (lambda (a b) b)))
+(assert-equal? "values test2" -1 (call-with-values * -))
+(assert "values test3" (number? (values 5)))
+(begin (values 1 2 3) 'ignore) ; not asserted, just make sure we don't blow up
+
+
(total-report)
More information about the uim-commit
mailing list