[uim-commit] r988 - in branches/r5rs/sigscheme: . test
kzk at freedesktop.org
kzk at freedesktop.org
Wed Jul 20 11:54:21 EST 2005
Author: kzk
Date: 2005-07-19 18:54:19 -0700 (Tue, 19 Jul 2005)
New Revision: 988
Added:
branches/r5rs/sigscheme/test/test-continuation.scm
Modified:
branches/r5rs/sigscheme/datas.c
branches/r5rs/sigscheme/debug.c
branches/r5rs/sigscheme/eval.c
branches/r5rs/sigscheme/main.c
branches/r5rs/sigscheme/operations.c
branches/r5rs/sigscheme/sigscheme.c
branches/r5rs/sigscheme/sigscheme.h
branches/r5rs/sigscheme/sigschemetype.h
Log:
* Now sigscheme have "continuation" support. this feature
is implemented by using setjmp and longjmp.
* sigscheme/sigscheme.c
- (SigScm_Initialize): export "call-with-current-continuation"
* sigscheme/sigscheme.h
- (ScmOp_NewContinuation): new func
- (ScmOp_call_with_current_continuation): new func
* sigscheme/sigschemetype.h
- add ScmContinuation type and the macros related to it
* sigscheme/eval.c
- (ScmOp_eval): handle ScmContinuation
* sigscheme/datas.c
- (Scm_NewContinuation): new func
- (sweep_obj): handle ScmContinuation
* sigscheme/operations.c
- (ScmOp_call_with_current_continuation): new func
* sigscheme/test/test-continuation.scm
- testcases for "call-with-current-continuation"
* sigscheme/main.c
- add space
* sigscheme/debug.c
- support ScmPort and ScmContinuation
Modified: branches/r5rs/sigscheme/datas.c
===================================================================
--- branches/r5rs/sigscheme/datas.c 2005-07-20 01:30:45 UTC (rev 987)
+++ branches/r5rs/sigscheme/datas.c 2005-07-20 01:54:19 UTC (rev 988)
@@ -435,6 +435,10 @@
free(SCM_PORT_PORTINFO(obj));
}
break;
+ case ScmContinuation:
+ if (SCM_CONTINUATION_CONTINFO(obj)) {
+ free(SCM_CONTINUATION_CONTINFO(obj));
+ }
default:
break;
}
@@ -619,6 +623,20 @@
return obj;
}
+ScmObj Scm_NewContinuation(void)
+{
+ ScmObj obj = SCM_NIL;
+ ScmContInfo *cinfo = NULL;
+
+ SCM_NEW_OBJ_INTERNAL(obj);
+
+ SCM_SETCONTINUATION(obj);
+ cinfo = (ScmContInfo *)malloc(sizeof(ScmContInfo));
+ SCM_SETCONTINUATION_CONTINFO(obj, cinfo);
+
+ return obj;
+}
+
/*
* Symbol Name Hash Related Functions
*
Modified: branches/r5rs/sigscheme/debug.c
===================================================================
--- branches/r5rs/sigscheme/debug.c 2005-07-20 01:30:45 UTC (rev 987)
+++ branches/r5rs/sigscheme/debug.c 2005-07-20 01:54:19 UTC (rev 988)
@@ -102,6 +102,10 @@
print_vector(f, obj);
} else if (SCM_FREECELLP(obj)) {
fprintf(f, "[ FreeCell ] \n");
+ } else if (SCM_PORTP(obj)) {
+ fprintf(f, "(port)");
+ } else if (SCM_CONTINUATIONP(obj)) {
+ fprintf(f, "(continuation)");
} else {
if (EQ(obj, SCM_NIL)) {
fprintf(f, "()");
Modified: branches/r5rs/sigscheme/eval.c
===================================================================
--- branches/r5rs/sigscheme/eval.c 2005-07-20 01:30:45 UTC (rev 987)
+++ branches/r5rs/sigscheme/eval.c 2005-07-20 01:54:19 UTC (rev 988)
@@ -64,6 +64,7 @@
/*=======================================
Variable Declarations
=======================================*/
+ScmObj continuation_thrown_obj = NULL;
/*=======================================
File Local Function Declarations
@@ -311,6 +312,18 @@
SCM_CLOSURE_ENV(tmp));
return ScmOp_eval(SCM_CAR(SCM_CDR(SCM_CLOSURE_EXP(tmp))), env);
}
+ case ScmContinuation:
+ {
+ /*
+ * - eval 1st arg
+ * - store it to global variable "continuation_thrown_obj"
+ * - then longjmp
+ */
+ obj = SCM_CAR(SCM_CDR(obj));
+ continuation_thrown_obj = ScmOp_eval(obj, env);
+ longjmp(SCM_CONTINUATION_JMPENV(tmp), 1);
+ }
+ break;
case ScmEtc:
if (EQ(tmp, SCM_QUOTE)) {
return SCM_CDR(obj);
@@ -754,6 +767,9 @@
{
ScmObj bindings = SCM_NIL;
ScmObj body = SCM_NIL;
+ ScmObj vars = SCM_NIL;
+ ScmObj vals = SCM_NIL;
+ ScmObj binding = SCM_NIL;
/* sanity check */
if CHECK_2_ARGS(arg)
@@ -770,9 +786,6 @@
...)
========================================================================*/
if (SCM_CONSP(bindings)) {
- ScmObj vars = SCM_NIL;
- ScmObj vals = SCM_NIL;
- ScmObj binding = SCM_NIL;
for (; !SCM_NULLP(bindings); bindings = SCM_CDR(bindings)) {
binding = SCM_CAR(bindings);
vars = Scm_NewCons(SCM_CAR(binding), vars);
@@ -792,6 +805,9 @@
{
ScmObj bindings = SCM_NIL;
ScmObj body = SCM_NIL;
+ ScmObj vars = SCM_NIL;
+ ScmObj vals = SCM_NIL;
+ ScmObj binding = SCM_NIL;
/* sanity check */
if CHECK_2_ARGS(arg)
@@ -808,9 +824,6 @@
...)
========================================================================*/
if (SCM_CONSP(bindings)) {
- ScmObj vars = SCM_NIL;
- ScmObj vals = SCM_NIL;
- ScmObj binding = SCM_NIL;
for (; !SCM_NULLP(bindings); bindings = SCM_CDR(bindings)) {
binding = SCM_CAR(bindings);
vars = Scm_NewCons(SCM_CAR(binding), SCM_NIL);
@@ -830,6 +843,9 @@
{
ScmObj bindings = SCM_NIL;
ScmObj body = SCM_NIL;
+ ScmObj vars = SCM_NIL;
+ ScmObj vals = SCM_NIL;
+ ScmObj binding = SCM_NIL;
/* sanity check */
if CHECK_2_ARGS(arg)
@@ -846,13 +862,9 @@
...)
========================================================================*/
if (SCM_CONSP(bindings)) {
- ScmObj vars = SCM_NIL;
- ScmObj vals = SCM_NIL;
- ScmObj binding = SCM_NIL;
for (; !SCM_NULLP(bindings); bindings = SCM_CDR(bindings)) {
binding = SCM_CAR(bindings);
-
/* first, temporally add symbol to the env*/
vars = Scm_NewCons(SCM_CAR(binding), SCM_NIL);
vals = Scm_NewCons(SCM_NIL, SCM_NIL);
Modified: branches/r5rs/sigscheme/main.c
===================================================================
--- branches/r5rs/sigscheme/main.c 2005-07-20 01:30:45 UTC (rev 987)
+++ branches/r5rs/sigscheme/main.c 2005-07-20 01:54:19 UTC (rev 988)
@@ -59,7 +59,7 @@
ScmObj stdout_port = Scm_NewPort(stdout, PORT_INPUT);
ScmObj s_exp, result;
- printf("sscm>");
+ printf("sscm> ");
for( s_exp = SigScm_Read(stdin_port);
!EQ(s_exp, SCM_EOF);
@@ -67,7 +67,7 @@
{
result = ScmOp_eval(s_exp, SCM_NIL);
SigScm_DisplayToPort(stdout_port, result);
- printf("\nsscm>");
+ printf("\nsscm> ");
}
ScmOp_close_input_port(stdin_port);
Modified: branches/r5rs/sigscheme/operations.c
===================================================================
--- branches/r5rs/sigscheme/operations.c 2005-07-20 01:30:45 UTC (rev 987)
+++ branches/r5rs/sigscheme/operations.c 2005-07-20 01:54:19 UTC (rev 988)
@@ -53,6 +53,7 @@
/*=======================================
Variable Declarations
=======================================*/
+extern ScmObj continuation_thrown_obj;
/*=======================================
File Local Function Declarations
@@ -104,6 +105,7 @@
case ScmFunc:
case ScmClosure:
case ScmPort:
+ case ScmContinuation:
if (EQ(obj1, obj2))
{
return SCM_TRUE;
@@ -215,6 +217,7 @@
case ScmFunc:
case ScmClosure:
case ScmPort:
+ case ScmContinuation:
{
return SCM_UNSPECIFIED;
}
@@ -1825,3 +1828,26 @@
return ScmOp_eval(Scm_NewCons(SCM_CAR(arg), SCM_NIL), env);
}
+ScmObj ScmOp_call_with_current_continuation(ScmObj arg, ScmObj env)
+{
+ int jmpret = 0;
+ ScmObj proc = SCM_CAR(arg);
+ ScmObj cont = SCM_NIL;
+
+ if (!SCM_CLOSUREP(proc))
+ SigScm_ErrorObj("call-with-current-continuation : closure required but got ", proc);
+
+ cont = Scm_NewContinuation();
+
+ /* setjmp and check result */
+ jmpret = setjmp(SCM_CONTINUATION_JMPENV(cont));
+ if (jmpret) {
+ /* return by calling longjmp */
+ return continuation_thrown_obj;
+ }
+
+ /* execute (proc cont) */
+ SCM_SETCDR(arg, Scm_NewCons(cont, SCM_NIL));
+
+ return ScmOp_eval(arg, env);
+}
Modified: branches/r5rs/sigscheme/sigscheme.c
===================================================================
--- branches/r5rs/sigscheme/sigscheme.c 2005-07-20 01:30:45 UTC (rev 987)
+++ branches/r5rs/sigscheme/sigscheme.c 2005-07-20 01:54:19 UTC (rev 988)
@@ -233,6 +233,7 @@
Scm_InitSubrL("map" , ScmOp_map);
Scm_InitSubrL("for-each" , ScmOp_for_each);
Scm_InitSubrL("force" , ScmOp_force);
+ Scm_InitSubrL("call-with-current-continuation", ScmOp_call_with_current_continuation);
/* io.c */
Scm_InitSubr2("call-with-input-file" , ScmOp_call_with_input_file);
Scm_InitSubr2("call-with-output-file", ScmOp_call_with_output_file);
Modified: branches/r5rs/sigscheme/sigscheme.h
===================================================================
--- branches/r5rs/sigscheme/sigscheme.h 2005-07-20 01:30:45 UTC (rev 987)
+++ branches/r5rs/sigscheme/sigscheme.h 2005-07-20 01:54:19 UTC (rev 988)
@@ -119,6 +119,7 @@
ScmObj Scm_NewClosure(ScmObj exp, ScmObj env);
ScmObj Scm_NewVector(ScmObj *vec, int len);
ScmObj Scm_NewPort(FILE *file, enum ScmPortType ptype);
+ScmObj Scm_NewContinuation(void);
ScmObj Scm_Intern(const char *name);
/* eval.c */
@@ -264,6 +265,7 @@
ScmObj ScmOp_map(ScmObj arg, ScmObj env);
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);
/* io.c */
ScmObj ScmOp_call_with_input_file(ScmObj filepath, ScmObj proc);
Modified: branches/r5rs/sigscheme/sigschemetype.h
===================================================================
--- branches/r5rs/sigscheme/sigschemetype.h 2005-07-20 01:30:45 UTC (rev 987)
+++ branches/r5rs/sigscheme/sigschemetype.h 2005-07-20 01:54:19 UTC (rev 988)
@@ -38,6 +38,7 @@
System Include
=======================================*/
#include <stdio.h>
+#include <setjmp.h>
/*=======================================
Local Include
@@ -48,17 +49,18 @@
=======================================*/
/* Scheme Object Type */
enum ScmObjType {
- ScmInt = 0,
- ScmCons = 1,
- ScmSymbol = 2,
- ScmChar = 3,
- ScmString = 4,
- ScmFunc = 5,
- ScmClosure = 6,
- ScmVector = 7,
- ScmPort = 8,
- ScmFreeCell = 9,
- ScmEtc = 10
+ ScmInt = 0,
+ ScmCons = 1,
+ ScmSymbol = 2,
+ ScmChar = 3,
+ ScmString = 4,
+ ScmFunc = 5,
+ ScmClosure = 6,
+ ScmVector = 7,
+ ScmPort = 8,
+ ScmContinuation = 9,
+ ScmFreeCell = 10,
+ ScmEtc = 11
};
/* Function Type by argnuments */
@@ -93,7 +95,12 @@
char ungottenchar;
};
+typedef struct _ScmContInfo ScmContInfo;
+struct _ScmContInfo {
+ jmp_buf jmp_env;
+};
+
/* Scheme Object */
typedef struct ScmObjInternal_ ScmObjInternal;
typedef ScmObjInternal *ScmObj;
@@ -165,11 +172,15 @@
int len;
} vector;
- struct ScmPort {
+ struct ScmPort {
enum ScmPortType port_type;
ScmPortInfo *port_info;
} port;
+ struct ScmContinuation {
+ ScmContInfo *cont_info;
+ } continuation;
+
struct ScmEtc {
int type;
} etc;
@@ -277,6 +288,13 @@
#define SCM_PORTINFO_FILE(a) (SCM_PORT_PORTINFO(a)->file)
#define SCM_PORTINFO_UNGOTTENCHAR(a) (SCM_PORT_PORTINFO(a)->ungottenchar)
+#define SCM_CONTINUATIONP(a) (SCM_GETTYPE(a) == ScmContinuation)
+#define SCM_CONTINUATION(a) (sigassert(SCM_CONTINUATIONP(a)), a)
+#define SCM_CONTINUATION_CONTINFO(a) (SCM_CONTINUATION(a)->obj.continuation.cont_info)
+#define SCM_CONTINUATION_JMPENV(a) (SCM_CONTINUATION(a)->obj.continuation.cont_info->jmp_env)
+#define SCM_SETCONTINUATION(a) (SCM_SETTYPE(a, ScmContinuation))
+#define SCM_SETCONTINUATION_CONTINFO(a, cinfo) (SCM_CONTINUATION_CONTINFO(a) = cinfo)
+
/*============================================================================
Etcetra variables (Special Symbols like NIL)
============================================================================*/
Added: branches/r5rs/sigscheme/test/test-continuation.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-continuation.scm 2005-07-20 01:30:45 UTC (rev 987)
+++ branches/r5rs/sigscheme/test/test-continuation.scm 2005-07-20 01:54:19 UTC (rev 988)
@@ -0,0 +1,27 @@
+(load "test/unittest.scm")
+
+(assert-eq? "call/cc test1" -3 (call-with-current-continuation
+ (lambda (exit)
+ (for-each (lambda (x)
+ (if (negative? x)
+ (exit x)))
+ '(54 0 37 -3 245 19))
+ #t)))
+
+(define list-length
+ (lambda (obj)
+ (call-with-current-continuation
+ (lambda (return)
+ (letrec ((re
+ (lambda (obj1)
+ (cond ((null? obj1) 0)
+ ((pair? obj1)
+ (+ (re (cdr obj1)) 1))
+ (else
+ (return #f))))))
+ (re obj))))))
+
+(assert-eq? "call/cc test2" 4 (list-length '(1 2 3 4)))
+(assert-eq? "call/cc test3" #f (list-length '(a b . c)))
+
+(total-report)
More information about the uim-commit
mailing list