Adding initial implementation of call-with-continuation-mark

Author: ktakashi

src/sagittarius/private/vm.h

@@ -442,6 +442,8 @@ SG_EXTERN SgObject Sg_VMCallCP(SgObject proc, SgObject tag,
 			       SgObject handler, SgObject args);
 /* call-with-continuation-barrier */
 SG_EXTERN SgObject Sg_VMCallCB(SgObject thunk);
+/* call-with-continuation-mark */
+SG_EXTERN SgObject Sg_VMCallCM(SgObject key, SgObject value, SgObject thunk);
 SG_EXTERN SgObject Sg_VMCallComp(SgObject proc, SgObject tag);
 SG_EXTERN SgObject Sg_VMCallDelimitedCC(SgObject proc, SgObject tag);
 SG_EXTERN SgObject Sg_VMAbortCC(SgObject tag, SgObject args);

src/vm.c

@@ -1019,6 +1019,15 @@ static void expand_stack(SgVM *vm);
 
 #define C_CONT_MARK NULL
 
+static void push_cont_marks(SgVM *vm, SgContFrame *cont)
+{
+  SgContMarks *cm = SG_NEW(SgContMarks);
+  cm->frame = cont;
+  cm->entries = NULL;
+  cm->prev = vm->marks;
+  vm->marks = cm;
+}
+
 void Sg_VMPushCC(SgCContinuationProc *after, void **data, int datasize)
 {
   int i;
@@ -1039,6 +1048,7 @@ void Sg_VMPushCC(SgCContinuationProc *after, void **data, int datasize)
   for (i = 0; i < datasize; i++) {
     PUSH(s, SG_OBJ(data[i]));
   }
+  push_cont_marks(vm, cc);
   CONT(vm) = cc;
   FP(vm) = SP(vm) = s;
 }
@@ -1063,6 +1073,7 @@ enum {
     newcont->pc = (SgWord *)next_pc;		\
     newcont->cl = CL(vm);			\
     newcont->fp = FP(vm);			\
+    push_cont_marks(vm, newcont);		\
     CONT(vm) = newcont;				\
     SP(vm) += CONT_FRAME_SIZE;			\
   } while (0)
@@ -2336,6 +2347,18 @@ SgObject Sg_VMCallCB(SgObject thunk)
   return Sg_VMApply0(thunk);
 }
 
+/* this will be wrapped by the with-continuation-mark macro */
+SgObject Sg_VMCallCM(SgObject key, SgObject value, SgObject thunk)
+{
+  SgVM *vm = theVM;
+  SgMarkEntry *e = SG_NEW(SgMarkEntry);
+  e->key = key;
+  e->value = value;
+  e->next = vm->marks->entries;
+  vm->marks->entries = e;
+  return Sg_VMApply0(thunk);
+}
+
 SgObject Sg_MakeContinuationPromptTag(SgObject name)
 {
   return make_prompt_tag(name);
@@ -2698,18 +2721,23 @@ static SG_DEFINE_SUBR(default_exception_handler_rec, 1, 0,
 
 #define TAIL_POS(vm)  (*PC(vm) == RET)
 
-static SgContFrame *skip_prompt_frame(SgContFrame *cont)
+static SgContFrame *skip_prompt_frame(SgVM *vm)
 {
+  SgContFrame *cont = vm->cont;
+  SgContMarks *marks = vm->marks;
   while (PROMPT_FRAME_MARK_P(cont)) {
     remove_prompt(theVM, (SgPrompt *)cont->pc);
     cont = cont->prev;
+    marks = marks->prev;
   }
+  vm->marks = marks;
   return cont;
 }
 
 #define POP_CONT()							\
   do {									\
-    SgContFrame *cont__ = skip_prompt_frame(CONT(vm));			\
+    SgContFrame *cont__ = skip_prompt_frame(vm);			\
+    vm->marks = vm->marks->prev;					\
     if (cont__->fp == C_CONT_MARK) {					\
       void *data__[SG_CCONT_DATA_SIZE];					\
       SgObject v__ = AC(vm);						\