Adding continuation-prompt-available?

Author: ktakashi

lib/sagittarius/continuations.scm

@@ -37,7 +37,7 @@
 	    call/delim-cc
 	    call-with-delimited-current-continuation
 
-	    continuation?
+	    continuation? continuation-prompt-available?
 
 	    default-continuation-prompt-tag
 	    make-continuation-prompt-tag continuation-prompt-tag?

src/lib_sagittarius.stub

@@ -1856,6 +1856,9 @@
   (define-c-proc %call/delim-cc (proc::<procedure> tag) :no-export 
     Sg_VMCallDelimitedCC)
   (define-c-proc continuation? (o) ::<boolean> :no-side-effect Sg_ContinuationP)
+  (define-c-proc continuation-prompt-available? (tag :optional (cont #f))
+    ::<boolean> :no-side-effect
+    Sg_ContinuationPromptAvailableP)
 
   (define (make-continuation-prompt-tag :optional (name (gensym))) (list name))
   (define default-continuation-prompt-tag

src/sagittarius/private/vm.h

@@ -417,6 +417,7 @@ 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);
 SG_EXTERN int      Sg_ContinuationP(SgObject o);
+SG_EXTERN int      Sg_ContinuationPromptAvailableP(SgObject tag, SgObject cont);
 SG_EXTERN SgVM*    Sg_VM();	/* get vm */
 SG_EXTERN int      Sg_SetCurrentVM(SgVM *vm);
 SG_EXTERN int      Sg_AttachVM(SgVM *vm);

src/vm.c

@@ -1859,6 +1859,31 @@ int Sg_ContinuationP(SgObject o)
   return SG_SUBRP(o) && SG_EQ(SG_PROCEDURE_NAME(o), sym_continuation);
 }
 
+int Sg_ContinuationPromptAvailableP(SgObject tag, SgObject k)
+{
+  SgContFrame *cont = NULL;
+  SgPrompt *boundary = NULL;
+  SgVM *vm = theVM;
+  if (SG_FALSEP(k)) {
+    cont = vm->cont;
+  } else if (Sg_ContinuationP(k)) {
+    SgContinuation *c = (SgContinuation *)SG_CAR(SG_SUBR_DATA(k));
+    boundary = (SgPrompt *)SG_CDR(SG_SUBR_DATA(k));
+    cont = c->cont;
+  } else {
+    Sg_Error(UC("continuation or #f is required but got %S"), k);
+  }
+  while (!bottom_cont_frame_p(vm, cont)) {
+    if (PROMPT_FRAME_MARK_P(cont)) {
+      if (((SgPrompt *)cont->pc)->tag == tag) return TRUE;
+      if ((SgPrompt *)cont->pc == boundary) return FALSE;
+    
+    }
+    cont = cont->prev;
+  }
+  return FALSE;
+}
+
 SgObject Sg_VMCallCC(SgObject proc)
 {
   SgContinuation *cont;

test/tests/sagittarius/continuations.scm

@@ -38,6 +38,31 @@
        (lambda (x) 'outer x))))
   (test-equal 'invoked (check)))
 
+(let ((p1 (make-continuation-prompt-tag 'p1))
+      (p2 (make-continuation-prompt-tag 'p2)))
+  ;; using delim-cc
+  (let ((k (call-with-continuation-prompt
+	    (lambda ()
+	      (test-assert "p1 (#t)" (continuation-prompt-available? p1))
+	      (test-assert "p2 (#f)" (not (continuation-prompt-available? p2)))
+	      (call-with-continuation-prompt
+	       (lambda ()
+		 (call/delim-cc values p2))
+	       p2))
+	    p1)))
+    (test-assert "delim-cc p1 (#f)" (not (continuation-prompt-available? p1 k)))
+    (test-assert "delim-cc p2 (#t)" (continuation-prompt-available? p2 k)))
+
+  ;; using full continuation
+  (let ((k (call-with-continuation-prompt
+	    (lambda ()
+	      (call-with-continuation-prompt
+	       (lambda () (call/cc values))
+	       p2))
+	    p1)))
+    (test-assert "call/cc p1 (#t)" (continuation-prompt-available? p1 k))
+    (test-assert "call/cc p2 (#t)" (continuation-prompt-available? p2 k))))
+
 (define-syntax test
   (lambda (x)
     (syntax-case x ()