[uim-commit] r1799 - in branches/r5rs/sigscheme: . test
yamaken at freedesktop.org
yamaken at freedesktop.org
Tue Oct 4 06:58:34 PDT 2005
Author: yamaken
Date: 2005-10-04 06:58:31 -0700 (Tue, 04 Oct 2005)
New Revision: 1799
Modified:
branches/r5rs/sigscheme/datas.c
branches/r5rs/sigscheme/operations.c
branches/r5rs/sigscheme/sigscheme.c
branches/r5rs/sigscheme/sigscheme.h
branches/r5rs/sigscheme/sigschemeinternal.h
branches/r5rs/sigscheme/test/test-exp.scm
Log:
* This commit makes 'dynamic-wind' partially workable. Current
implementation does not support continuation handlings yet
* sigscheme/sigscheme.h
- (ScmOp_dynamic_wind): Change function type
* sigscheme/operations.c
- (ScmOp_dynamic_wind):
* Change function type
* Make workable by Scm_DynamicWind()
* sigscheme/sigschemeinternal.h
- (Scm_DynamicWind): New function decl
* sigscheme/datas.c
- (current_dynamic_extent): New variable
- (initialize_dynamic_extent, finalize_dynamic_extent,
wind_onto_dynamic_extent, unwind_dynamic_extent,
enter_dynamic_extent, exit_dynamic_extent): New static function
- (SigScm_InitStorage, SigScm_FinalizeStorage): Add dynamic extent
handlings
- (MAKE_DYNEXT_FRAME, DYNEXT_FRAME_BEFORE, DYNEXT_FRAME_AFTER): New
macro
* sigscheme/sigscheme.c
- (SigScm_Initialize_internal): Follow the function type change of
ScmOp_dynamic_wind
* sigscheme/test/test-exp.scm
- Add some tests for dynamic-wind. 2 tests are not yet passed
Modified: branches/r5rs/sigscheme/datas.c
===================================================================
--- branches/r5rs/sigscheme/datas.c 2005-10-04 13:55:25 UTC (rev 1798)
+++ branches/r5rs/sigscheme/datas.c 2005-10-04 13:58:31 UTC (rev 1799)
@@ -161,6 +161,9 @@
static jmp_buf save_regs_buf;
ScmObj *scm_stack_start_pointer = NULL;
+/* dynamic extent */
+static ScmObj current_dynamic_extent = NULL;
+
/* temporary store for a object returned from a continuation */
static ScmObj continuation_thrown_obj = NULL;
static ScmObj continuation_stack = NULL;
@@ -200,6 +203,14 @@
static void sweep_obj(ScmObj obj);
static void gc_sweep(void);
+/* dynamic extent */
+static void initialize_dynamic_extent(void);
+static void finalize_dynamic_extent(void);
+static void wind_onto_dynamic_extent(ScmObj before, ScmObj after);
+static void unwind_dynamic_extent(void);
+static void enter_dynamic_extent(ScmObj dest);
+static void exit_dynamic_extent(ScmObj dest);
+
/* continuation */
static void initialize_continuation_env(void);
static void finalize_continuation_env(void);
@@ -239,6 +250,7 @@
initialize_special_constants();
allocate_heap(&scm_heaps, scm_heap_num, SCM_HEAP_SIZE, &scm_freelist);
+ initialize_dynamic_extent();
initialize_continuation_env();
initialize_symbol_hash();
}
@@ -246,6 +258,7 @@
void SigScm_FinalizeStorage(void)
{
finalize_continuation_env();
+ finalize_dynamic_extent();
finalize_heap();
finalize_symbol_hash();
finalize_protected_var();
@@ -857,6 +870,85 @@
#endif /* SCM_USE_NONSTD_FEATURES */
/*============================================================================
+ Dynamic Extent
+============================================================================*/
+#define MAKE_DYNEXT_FRAME(before, after) (CONS(before, after))
+#define DYNEXT_FRAME_BEFORE CAR
+#define DYNEXT_FRAME_AFTER CDR
+
+static void initialize_dynamic_extent(void)
+{
+ current_dynamic_extent = SCM_NULL;
+ SigScm_GC_Protect(¤t_dynamic_extent);
+}
+
+static void finalize_dynamic_extent(void)
+{
+}
+
+static void wind_onto_dynamic_extent(ScmObj before, ScmObj after)
+{
+ current_dynamic_extent = CONS(MAKE_DYNEXT_FRAME(before, after),
+ current_dynamic_extent);
+}
+
+static void unwind_dynamic_extent(void)
+{
+ if (NULLP(current_dynamic_extent))
+ SigScm_Error("corrupted dynamic extent");
+
+ current_dynamic_extent = CDR(current_dynamic_extent);
+}
+
+/* enter a dynamic extent of another continuation (dest) */
+static void enter_dynamic_extent(ScmObj dest)
+{
+ ScmObj frame = SCM_FALSE;
+ ScmObj unwound = SCM_FALSE;
+ ScmObj retpath = SCM_NULL;
+
+ /* assumes that (SCM_NULL != NULL) */
+ for (unwound = dest; SCM_SHIFT_RAW(frame, unwound);) {
+ if (EQ(unwound, current_dynamic_extent))
+ break;
+ retpath = CONS(frame, retpath);
+ }
+
+ /* assumes that (SCM_NULL != NULL) */
+ while (SCM_SHIFT_RAW(frame, retpath)) {
+ Scm_call(DYNEXT_FRAME_BEFORE(frame), SCM_NULL);
+ }
+}
+
+/* exit to a dynamic extent of another continuation (dest) */
+static void exit_dynamic_extent(ScmObj dest)
+{
+ ScmObj frame = SCM_FALSE;
+
+ /* assumes that (SCM_NULL != NULL) */
+ while (SCM_SHIFT_RAW(frame, current_dynamic_extent)) {
+ if (EQ(current_dynamic_extent, dest))
+ return;
+ Scm_call(DYNEXT_FRAME_AFTER(frame), SCM_NULL);
+ }
+}
+
+ScmObj Scm_DynamicWind(ScmObj before, ScmObj thunk, ScmObj after)
+{
+ ScmObj ret = SCM_FALSE;
+
+ Scm_call(before, SCM_NULL);
+
+ wind_onto_dynamic_extent(before, after);
+ ret = Scm_call(thunk, SCM_NULL);
+ unwind_dynamic_extent();
+
+ Scm_call(after, SCM_NULL);
+
+ return ret;
+}
+
+/*============================================================================
Continuation
============================================================================*/
#define CONTINUATION_JMPENV SCM_CONTINUATION_OPAQUE0
Modified: branches/r5rs/sigscheme/operations.c
===================================================================
--- branches/r5rs/sigscheme/operations.c 2005-10-04 13:55:25 UTC (rev 1798)
+++ branches/r5rs/sigscheme/operations.c 2005-10-04 13:58:31 UTC (rev 1799)
@@ -1851,22 +1851,15 @@
return Scm_tailcall(consumer, vals, eval_state);
}
-/* FIXME: implement properly */
-ScmObj ScmOp_dynamic_wind(ScmObj before, ScmObj thunk, ScmObj after,
- ScmEvalState *eval_state)
+ScmObj ScmOp_dynamic_wind(ScmObj before, ScmObj thunk, ScmObj after)
{
- DECLARE_FUNCTION("dynamic-wind", ProcedureFixedTailRec3);
+ DECLARE_FUNCTION("dynamic-wind", ProcedureFixed3);
ASSERT_PROCEDUREP(before);
ASSERT_PROCEDUREP(thunk);
ASSERT_PROCEDUREP(after);
-#if 0
- eval_state->dynwind_before = before;
- eval_state->dynwind_after = after;
-#endif
-
- return Scm_tailcall(thunk, SCM_NULL, eval_state);
+ return Scm_DynamicWind(before, thunk, after);
}
/*============================================================================
Modified: branches/r5rs/sigscheme/sigscheme.c
===================================================================
--- branches/r5rs/sigscheme/sigscheme.c 2005-10-04 13:55:25 UTC (rev 1798)
+++ branches/r5rs/sigscheme/sigscheme.c 2005-10-04 13:58:31 UTC (rev 1799)
@@ -340,7 +340,7 @@
Scm_RegisterProcedureVariadic0("values" , ScmOp_values);
Scm_RegisterProcedureFixedTailRec1("call-with-current-continuation", ScmOp_call_with_current_continuation);
Scm_RegisterProcedureFixedTailRec2("call-with-values", ScmOp_call_with_values);
- Scm_RegisterProcedureFixedTailRec3("dynamic-wind", ScmOp_dynamic_wind);
+ Scm_RegisterProcedureFixed3("dynamic-wind", ScmOp_dynamic_wind);
/* io.c */
Scm_RegisterProcedureFixed2("call-with-input-file" , ScmOp_call_with_input_file);
Scm_RegisterProcedureFixed2("call-with-output-file" , ScmOp_call_with_output_file);
Modified: branches/r5rs/sigscheme/sigscheme.h
===================================================================
--- branches/r5rs/sigscheme/sigscheme.h 2005-10-04 13:55:25 UTC (rev 1798)
+++ branches/r5rs/sigscheme/sigscheme.h 2005-10-04 13:58:31 UTC (rev 1799)
@@ -508,8 +508,7 @@
ScmObj ScmOp_call_with_current_continuation(ScmObj proc, ScmEvalState *eval_state);
ScmObj ScmOp_values(ScmObj args);
ScmObj ScmOp_call_with_values(ScmObj producer, ScmObj consumer, ScmEvalState *eval_state);
-ScmObj ScmOp_dynamic_wind(ScmObj before, ScmObj thunk, ScmObj after,
- ScmEvalState *eval_state);
+ScmObj ScmOp_dynamic_wind(ScmObj before, ScmObj thunk, ScmObj after);
#if SCM_USE_NONSTD_FEATURES
ScmObj ScmOp_symbol_boundp(ScmObj sym, ScmObj rest);
#endif
Modified: branches/r5rs/sigscheme/sigschemeinternal.h
===================================================================
--- branches/r5rs/sigscheme/sigschemeinternal.h 2005-10-04 13:55:25 UTC (rev 1798)
+++ branches/r5rs/sigscheme/sigschemeinternal.h 2005-10-04 13:58:31 UTC (rev 1799)
@@ -360,6 +360,7 @@
void SigScm_FinalizeStorage(void);
ScmObj Scm_CallWithCurrentContinuation(ScmObj proc, ScmEvalState *eval_state);
void Scm_CallContinuation(ScmObj cont, ScmObj ret);
+ScmObj Scm_DynamicWind(ScmObj before, ScmObj thunk, ScmObj after);
/* eval.c */
/* environment related functions */
Modified: branches/r5rs/sigscheme/test/test-exp.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-exp.scm 2005-10-04 13:55:25 UTC (rev 1798)
+++ branches/r5rs/sigscheme/test/test-exp.scm 2005-10-04 13:58:31 UTC (rev 1799)
@@ -301,5 +301,83 @@
(write (values))
(newline)
+(define dynwind-res '())
+(define append-sym!
+ (lambda (sym)
+ (set! dynwind-res (append dynwind-res (list sym)))))
+(set! dynwind-res '())
+(assert-equal? "dynamic-wind #1"
+ '(before thunk after)
+ (begin
+ (dynamic-wind
+ (lambda ()
+ (append-sym! 'before))
+ (lambda ()
+ (append-sym! 'thunk))
+ (lambda ()
+ (append-sym! 'after)))
+ dynwind-res))
+
+(set! dynwind-res '())
+(assert-equal? "dynamic-wind #2"
+ '(before1 thunk1 before2 thunk2 after2 after1)
+ (begin
+ (dynamic-wind
+ (lambda ()
+ (append-sym! 'before1))
+ (lambda ()
+ (append-sym! 'thunk1)
+ (dynamic-wind
+ (lambda ()
+ (append-sym! 'before2))
+ (lambda ()
+ (append-sym! 'thunk2))
+ (lambda ()
+ (append-sym! 'after2))))
+ (lambda ()
+ (append-sym! 'after1)))
+ dynwind-res))
+
+;; current implementation does not support this yet
+(set! dynwind-res '())
+(assert-equal? "dynamic-wind #3"
+ '(before thunk after)
+ (begin
+ (call/cc
+ (lambda (k)
+ (dynamic-wind
+ (lambda ()
+ (append-sym! 'before))
+ (lambda ()
+ (append-sym! 'thunk)
+ (k #f))
+ (lambda ()
+ (append-sym! 'after)))))
+ dynwind-res))
+
+;; current implementation does not support this yet
+(set! dynwind-res '())
+(assert-equal? "dynamic-wind #4"
+ '(before1 thunk1 before2 thunk2 after2 after1)
+ (begin
+ (call/cc
+ (lambda (k)
+ (dynamic-wind
+ (lambda ()
+ (append-sym! 'before1))
+ (lambda ()
+ (append-sym! 'thunk1)
+ (dynamic-wind
+ (lambda ()
+ (append-sym! 'before2))
+ (lambda ()
+ (append-sym! 'thunk2)
+ (k #f))
+ (lambda ()
+ (append-sym! 'after2))))
+ (lambda ()
+ (append-sym! 'after1)))))
+ dynwind-res))
+
(total-report)
More information about the uim-commit
mailing list