[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