implment dynamic-wind in scheme

contrib/20.r7rs/scheme/base.scm

@@ -739,6 +739,40 @@
 
   ;; 6.10. Control features
 
+  (define checkpoints '((0 #f . #f)))
+
+  (define (dynamic-wind in thunk out)
+    (in)
+    (set! checkpoints `((,(+ 1 (caar checkpoints)) ,in . ,out) . ,checkpoints))
+    (let ((ans (thunk)))
+      (set! checkpoints (cdr checkpoints))
+      (out)
+      ans))
+
+  (define (do-wind here there)
+    (unless (eq? here there)
+      (if (< (caar here) (caar there))
+          (begin
+            (do-wind here (cdr there))
+            ((cadr (car there))))
+          (begin
+            ((cddr (car here)))
+            (do-wind (cdr here) there)))))
+
+  (define scheme:call/cc
+    (let ((c call/cc))
+      (lambda (f)
+        (c (lambda (k)
+             (f (let ((save checkpoints))
+                  (lambda args
+                    (do-wind checkpoints save)
+                    (set! checkpoints save)
+                    (apply k args)))))))))
+
+  ;; call/cc and scheme:call/cc cannot coincide, so overwrite them
+  (set! call/cc scheme:call/cc)
+  (set! call-with-current-continuation scheme:call/cc)
+
   (export procedure?
           apply
           map

lib/cont.c

@@ -9,7 +9,6 @@
 struct cont {
   PIC_JMPBUF *jmp;
 
-  struct checkpoint *cp;
   ptrdiff_t sp_offset;
   ptrdiff_t ci_offset;
   size_t arena_idx;
@@ -24,29 +23,12 @@ struct cont {
 
 static const pic_data_type cont_type = { "cont", NULL };
 
-static void
-do_wind(pic_state *pic, struct checkpoint *here, struct checkpoint *there)
-{
-  if (here == there)
-    return;
-
-  if (here->depth < there->depth) {
-    do_wind(pic, here, there->prev);
-    pic_call(pic, obj_value(pic, there->in), 0);
-  }
-  else {
-    pic_call(pic, obj_value(pic, here->out), 0);
-    do_wind(pic, here->prev, there);
-  }
-}
-
 void
 pic_save_point(pic_state *pic, struct cont *cont, PIC_JMPBUF *jmp)
 {
   cont->jmp = jmp;
 
   /* save runtime context */
-  cont->cp = pic->cp;
   cont->sp_offset = pic->sp - pic->stbase;
   cont->ci_offset = pic->ci - pic->cibase;
   cont->arena_idx = pic->arena_idx;
@@ -62,10 +44,7 @@ pic_save_point(pic_state *pic, struct cont *cont, PIC_JMPBUF *jmp)
 void
 pic_load_point(pic_state *pic, struct cont *cont)
 {
-  do_wind(pic, pic->cp, cont->cp);
-
   /* load runtime context */
-  pic->cp = cont->cp;
   pic->sp = pic->stbase + cont->sp_offset;
   pic->ci = pic->cibase + cont->ci_offset;
   pic->arena_idx = cont->arena_idx;
@@ -80,30 +59,6 @@ pic_exit_point(pic_state *pic)
   pic->cc = pic->cc->prev;
 }
 
-pic_value
-pic_dynamic_wind(pic_state *pic, pic_value in, pic_value thunk, pic_value out)
-{
-  struct checkpoint *here;
-  pic_value val;
-
-  pic_call(pic, in, 0);       /* enter */
-
-  here = pic->cp;
-  pic->cp = (struct checkpoint *)pic_obj_alloc(pic, sizeof(struct checkpoint), PIC_TYPE_CP);
-  pic->cp->prev = here;
-  pic->cp->depth = here->depth + 1;
-  pic->cp->in = pic_proc_ptr(pic, in);
-  pic->cp->out = pic_proc_ptr(pic, out);
-
-  val = pic_call(pic, thunk, 0);
-
-  pic->cp = here;
-
-  pic_call(pic, out, 0);      /* exit */
-
-  return val;
-}
-
 static pic_value
 cont_call(pic_state *pic)
 {
@@ -131,7 +86,6 @@ cont_call(pic_state *pic)
   pic_load_point(pic, cont);
 
   PIC_LONGJMP(pic, *cont->jmp, 1);
-
   PIC_UNREACHABLE();
 }
 
@@ -232,16 +186,6 @@ pic_cont_callcc(pic_state *pic)
   return pic_callcc(pic, f);
 }
 
-static pic_value
-pic_cont_dynamic_wind(pic_state *pic)
-{
-  pic_value in, thunk, out;
-
-  pic_get_args(pic, "lll", &in, &thunk, &out);
-
-  return pic_dynamic_wind(pic, in, thunk, out);
-}
-
 static pic_value
 pic_cont_values(pic_state *pic)
 {
@@ -276,7 +220,6 @@ pic_init_cont(pic_state *pic)
 {
   pic_defun(pic, "call-with-current-continuation", pic_cont_callcc);
   pic_defun(pic, "call/cc", pic_cont_callcc);
-  pic_defun(pic, "dynamic-wind", pic_cont_dynamic_wind);
   pic_defun(pic, "values", pic_cont_values);
   pic_defun(pic, "call-with-values", pic_cont_call_with_values);
 }

lib/ext/write.c

@@ -463,8 +463,6 @@ typename(pic_state *pic, pic_value obj)
     return "ephemeron";
   case PIC_TYPE_RECORD:
     return "record";
-  case PIC_TYPE_CP:
-    return "checkpoint";
   default:
     pic_error(pic, "typename: invalid type given", 1, obj);
   }

lib/gc.c

@@ -32,7 +32,6 @@ struct object {
     struct context cxt;
     struct port port;
     struct error err;
-    struct checkpoint cp;
     struct irep irep;
   } u;
 };
@@ -441,18 +440,6 @@ gc_mark_object(pic_state *pic, struct object *obj)
     pic->heap->weaks = weak;
     break;
   }
-  case PIC_TYPE_CP: {
-    if (obj->u.cp.prev) {
-      gc_mark_object(pic, (struct object *)obj->u.cp.prev);
-    }
-    if (obj->u.cp.in) {
-      gc_mark_object(pic, (struct object *)obj->u.cp.in);
-    }
-    if (obj->u.cp.out) {
-      LOOP((struct object *)obj->u.cp.out);
-    }
-    break;
-  }
   default:
     PIC_UNREACHABLE();
   }
@@ -604,7 +591,6 @@ gc_finalize_object(pic_state *pic, struct object *obj)
   case PIC_TYPE_ERROR:
   case PIC_TYPE_ID:
   case PIC_TYPE_RECORD:
-  case PIC_TYPE_CP:
   case PIC_TYPE_PROC_FUNC:
   case PIC_TYPE_PROC_IREP:
     break;

lib/include/picrin/value.h

@@ -35,10 +35,10 @@ enum {
   PIC_TYPE_SYMBOL    = 28,
   PIC_TYPE_PAIR      = 29,
   PIC_TYPE_CXT       = 30,
-  PIC_TYPE_CP        = 31,
   PIC_TYPE_PROC_FUNC = 32,
   PIC_TYPE_PROC_IREP = 33,
-  PIC_TYPE_IREP      = 34
+  PIC_TYPE_IREP      = 34,
+  PIC_TYPE_MAX       = 63
 };
 
 #if !PIC_NAN_BOXING
@@ -221,7 +221,6 @@ DEFPRED(pic_env_p, PIC_TYPE_ENV)
 DEFPRED(pic_rec_p, PIC_TYPE_RECORD)
 DEFPRED(pic_sym_p, PIC_TYPE_SYMBOL)
 DEFPRED(pic_pair_p, PIC_TYPE_PAIR)
-DEFPRED(pic_cp_p, PIC_TYPE_CP)
 DEFPRED(pic_proc_func_p, PIC_TYPE_PROC_FUNC)
 DEFPRED(pic_proc_irep_p, PIC_TYPE_PROC_IREP)
 DEFPRED(pic_irep_p, PIC_TYPE_IREP)

lib/object.h

@@ -169,14 +169,6 @@ struct port {
   } file;
 };
 
-struct checkpoint {
-  OBJECT_HEADER
-  struct proc *in;
-  struct proc *out;
-  int depth;
-  struct checkpoint *prev;
-};
-
 #define TYPENAME_int   "integer"
 #define TYPENAME_blob  "bytevector"
 #define TYPENAME_char  "character"
@@ -277,7 +269,6 @@ DEFPTR(pic_env_ptr, struct env)
 DEFPTR(pic_port_ptr, struct port)
 DEFPTR(pic_error_ptr, struct error)
 DEFPTR(pic_rec_ptr, struct record)
-DEFPTR(pic_cp_ptr, struct checkpoint)
 DEFPTR(pic_irep_ptr, struct irep)
 
 struct object *pic_obj_alloc(pic_state *, size_t, int type);
@@ -300,7 +291,6 @@ struct cont *pic_alloca_cont(pic_state *);
 pic_value pic_make_cont(pic_state *, struct cont *);
 void pic_save_point(pic_state *, struct cont *, PIC_JMPBUF *);
 void pic_exit_point(pic_state *);
-pic_value pic_dynamic_wind(pic_state *, pic_value in, pic_value thunk, pic_value out);
 
 pic_value pic_library_environment(pic_state *, const char *);
 

lib/state.c

@@ -181,9 +181,6 @@ pic_open(pic_allocf allocf, void *userdata)
   /* continuation chain */
   pic->cc = NULL;
 
-  /* root block */
-  pic->cp = NULL;
-
   /* prepare VM stack */
   pic->stbase = pic->sp = allocf(userdata, NULL, PIC_STACK_SIZE * sizeof(pic_value));
   pic->stend = pic->stbase + PIC_STACK_SIZE;
@@ -243,12 +240,6 @@ pic_open(pic_allocf allocf, void *userdata)
   pic->macros = pic_make_weak(pic);
   pic->dyn_env = pic_list(pic, 1, pic_make_weak(pic));
 
-  /* root block */
-  pic->cp = (struct checkpoint *)pic_obj_alloc(pic, sizeof(struct checkpoint), PIC_TYPE_CP);
-  pic->cp->prev = NULL;
-  pic->cp->depth = 0;
-  pic->cp->in = pic->cp->out = NULL;
-
   /* user land */
   pic_deflibrary(pic, "picrin.user");