Using SRFI-226 implementation of shift/reset

Adding control/prompt
Adding composable continuation inspection

Author: ktakashi

lib/sagittarius/continuations.scm

@@ -37,62 +37,52 @@
 	    call/delim-cc
 	    call-with-delimited-current-continuation
 
-	    continuation? continuation-prompt-available?
+	    continuation? composable-continuation?
+	    continuation-prompt-available?
 
 	    default-continuation-prompt-tag
 	    make-continuation-prompt-tag continuation-prompt-tag?
-	    shift reset)
+	    shift reset
+	    prompt control)
     (import (except (core) call/cc call-with-current-continuation)
 	    (core macro)
 	    (sagittarius))
 
-;; (define (call/cc proc :optional (tag (default-continuation-prompt-tag)))
-;;   (call-with-composable-continuation
-;;    (lambda (ck)
-;;      (define (k . args)
-;;        (abort-current-continuation tag (lambda () (apply ck args))))
-;;      (proc k))
-;;    tag))
-;; (define call-with-current-continuation call/cc)
-
-(define (abort-current-continuation/keep-prompt tag thunk)
-  ((call-with-continuation-prompt
-    (lambda ()
-      ((call-with-delimited-current-continuation
-	(lambda (k) (lambda () k))
-	tag)))
-    tag)
-   thunk))
-
-(define (make-call-with-shift abort-cc inserted-handler)
-  (define (call-with-shift f :optional (tag (default-continuation-prompt-tag)))
-    (call-with-composable-continuation
-     (lambda (k)
-       (abort-cc
-	tag
-	(lambda ()
-	  (f (lambda vals
-	       (call-with-continuation-prompt
-		(lambda () (apply k vals))
-		tag
-		inserted-handler))))))))
-  call-with-shift)
-
-(define call-with-shift
-  (make-call-with-shift abort-current-continuation/keep-prompt #f))
+;; From SRFI-226 implementation
+(define-syntax reset
+  (lambda (x)
+    (syntax-case x ()
+      [(reset e1 e2 ...)
+       #'(call-with-continuation-prompt
+	  (lambda ()
+	    e1 e2 ...))])))
 
 (define-syntax shift
   (lambda (x)
     (syntax-case x ()
-      ((_ id expr0 expr ...)
-       (identifier? #'id)
-       #'(call-with-shift (lambda (id) expr0 expr ...))))))
+      [(shift k e1 e2 ...)
+       #'(call-with-composable-continuation
+	  (lambda (c)
+            (define k (lambda args (reset (apply c args))))
+            (abort-current-continuation (default-continuation-prompt-tag)
+					(lambda () e1 e2 ...))))])))
 
-(define-syntax reset
+(define-syntax prompt
   (lambda (x)
     (syntax-case x ()
-      ((_ expr0 expr ...)
+      [(prompt e1 e2 ...)
        #'(call-with-continuation-prompt
-	  (lambda () expr0 expr ...))))))
+	  (lambda () e1 e2 ...)
+	  (default-continuation-prompt-tag)
+	  (lambda (thunk) (thunk)))])))
+  
+(define-syntax control
+  (lambda (x)
+    (syntax-case x ()
+      [(control k e1 e2 ...)
+       #'(call-with-composable-continuation
+	  (lambda (k)
+	    (abort-current-continuation (default-continuation-prompt-tag)
+					(lambda () e1 e2 ...))))])))
 
 )

src/lib_sagittarius.stub

@@ -1856,6 +1856,8 @@
   (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 composable-continuation? (o) ::<boolean> :no-side-effect
+    Sg_ComposableContinuationP)
   (define-c-proc continuation-prompt-available? (tag :optional (cont #f))
     ::<boolean> :no-side-effect
     Sg_ContinuationPromptAvailableP)

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_ComposableContinuationP(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);

src/vm.c

@@ -1859,25 +1859,41 @@ int Sg_ContinuationP(SgObject o)
   return SG_SUBRP(o) && SG_EQ(SG_PROCEDURE_NAME(o), sym_continuation);
 }
 
+int Sg_ComposableContinuationP(SgObject o)
+{
+  return Sg_ContinuationP(o) &&
+    ((SgContinuation *)SG_CAR(SG_SUBR_DATA(o)))->type == SG_COMPOSABLE_CONTINUATION;
+}
+
 int Sg_ContinuationPromptAvailableP(SgObject tag, SgObject k)
 {
   SgContFrame *cont = NULL;
   SgPrompt *boundary = NULL;
   SgVM *vm = theVM;
+  int type = SG_FULL_CONTINUATION;
   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;
+    type = c->type;
   } 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;
-    
+      SgPrompt *p = (SgPrompt *)cont->pc;
+      /* a bit weird, but Racket and SRFI-226 seems like this */
+      if (type == SG_COMPOSABLE_CONTINUATION) {
+	/* composable, excludes boundary */
+	if (p == boundary) return FALSE;
+	if (p->tag == tag) return TRUE;
+      } else {
+	/* delimited, includes boundary */
+	if (p->tag == tag) return TRUE;
+	if (p == boundary) return FALSE;
+      }
     }
     cont = cont->prev;
   }

test/tests/sagittarius/continuations.scm

@@ -5,21 +5,22 @@
 (test-begin "Continuations")
 
 (test-assert "continuation? (call/cc)"
-	     (continuation? (call/cc (lambda (k) k))))
+	     (continuation? (call/cc values)))
 (test-assert "continuation? (call/comp)"
-	     (continuation?
-	      (call/prompt
-	       (lambda ()
-		 (call/comp (lambda (k) k))))))
+	     (continuation? (call/prompt (lambda () (call/comp values)))))
 (test-assert "continuation? (call/delimited-cc)"
-	     (continuation?
-	      (call/prompt
-	       (lambda ()
-		 (call/delim-cc (lambda (k) k))))))
+	     (continuation? (call/prompt (lambda () (call/delim-cc values)))))
 
 (test-assert "continuation? (symbol)" (not (continuation? 'a)))
 (test-assert "continuation? (symbol)" (not (continuation? (lambda args args))))
 
+(test-assert (not (composable-continuation? (call/cc values))))
+(test-assert (not (composable-continuation?
+		   (call/prompt (lambda () (call/delim-cc values))))))
+
+(test-assert (composable-continuation?
+	      (call/prompt (lambda () (call/comp values)))))
+
 (test-assert (continuation-prompt-tag? (default-continuation-prompt-tag)))
 (test-assert (continuation-prompt-tag? (make-continuation-prompt-tag)))
 
@@ -158,4 +159,85 @@
     (test-equal "(post mid pre)" (e))
     (test-equal '(mid pre post mid pre) v)))
 
+;; From SRFI-226
+
+(test-equal 4 (+ 1 (reset 3)))
+(test-equal 5 (+ 1 (reset (* 2 (shift k 4)))))
+(test-equal 9 (+ 1 (reset (* 2 (shift k (k 4))))))
+(test-equal 17 (+ 1 (reset (* 2 (shift k (k (k 4)))))))
+(test-equal 25 (+ 1 (reset (* 2 (shift k1 (* 3 (shift k2 (k1 (k2 4)))))))))
+
+(let ()
+  (define call-with-non-composable-continuation call/delim-cc)
+  (test-equal 990
+	      (let ([tag (make-continuation-prompt-tag)])
+		(* 2
+		   (call-with-continuation-prompt
+		    (lambda ()
+		      (* 3
+			 (call-with-non-composable-continuation
+			  (lambda (k)
+			    (* 5
+			       (call-with-continuation-prompt
+				(lambda ()
+				  (* 7 (k 11)))
+				tag)))
+			  tag)))
+		    tag)))))
+
+(test-equal 6930
+	    (let ([tag (make-continuation-prompt-tag)])
+	      (* 2
+		 (call-with-continuation-prompt
+		  (lambda ()
+		    (* 3
+		       (call-with-composable-continuation
+			(lambda (k)
+			  (* 5
+			     (call-with-continuation-prompt
+			      (lambda ()
+				(* 7 (k 11)))
+			      tag)))
+			tag)))
+		  tag))))
+
+(test-equal 7 (prompt (+ 2 (control k (k 5)))))
+(test-equal 5 (prompt (+ 2 (control k 5))))
+(test-equal 12 (prompt (+ 5 (prompt (+ 2 (control k1 (+ 1 (control k2 (k2 6)))))))))
+(test-equal 8 (prompt (+ 5 (prompt (+ 2 (control k1 (+ 1 (control k2 (k1 6)))))))))
+(test-equal 18 (prompt
+		(+ 12 (prompt (+ 5 (prompt (+ 2 (control k1 (control k2 (control k3 (k3 6)))))))))))
+
+(define-syntax let/prompt
+  (syntax-rules ()
+    ((_ ((var val)  ...) body ...)
+     (let/prompt (default-continuation-prompt-tag) ((var val) ...) body ...))
+    ((_ tag ((var val)  ...) body ...)
+     (call-with-continuation-prompt
+      (lambda ()
+	(let ((var val) ...) body ...))
+      tag))))
+
+(let/prompt ()
+  (define call-with-non-composable-continuation call/delim-cc)
+  (define tag (make-continuation-prompt-tag))
+  (call-with-continuation-prompt
+   (lambda ()
+     (test-assert
+      (continuation-prompt-available? tag
+       (call-with-non-composable-continuation values))))
+   tag)
+  (call-with-continuation-prompt
+   (lambda ()
+     (test-assert
+      (continuation-prompt-available? tag
+       (call-with-non-composable-continuation values tag))))
+   tag)
+  (call-with-continuation-prompt
+   (lambda ()
+     (test-assert
+      (not (continuation-prompt-available? tag
+	    (call-with-composable-continuation values tag)))))
+   tag))
+
 (test-end)