Merge pull request #335 from ktakashi/feature/continuation-mark

Feature/continuation mark

Author: ktakashi

lib/sagittarius/continuations.scm

@@ -45,15 +45,113 @@
 	    continuation? composable-continuation?
 	    continuation-prompt-available?
 
+	    with-continuation-mark with-continuation-marks
+	    continuation-mark-set?
+	    continuation-mark-set->list continuation-mark-set->list*
+	    current-continuation-marks
+	    continuation-mark-set-first
+	    call-with-immediate-continuation-mark
+
+	    make-continuation-mark-key continuation-mark-key?
+	    
 	    default-continuation-prompt-tag
 	    make-continuation-prompt-tag continuation-prompt-tag?
 	    shift reset
 	    prompt control)
     (import (except (core) call/cc call-with-current-continuation)
 	    (core macro)
+	    (core record)
 	    (core conditions)
 	    (sagittarius))
 
+(define-syntax with-continuation-mark
+  (lambda (x)
+    (syntax-case x ()
+      ((_ k v expr ...)
+       #'(call/cm (vector (cons k v)) (lambda () expr ...))))))
+(define-syntax with-continuation-marks
+  (lambda (x)
+    (syntax-case x ()
+      ((_ ((k v) ...) expr ...)
+       #'(call/cm (vector (cons k v) ...) (lambda () expr ...))))))
+
+(define (continuation-mark-set->list mark-set key 
+	     :optional (prompt-tag (default-continuation-prompt-tag)))
+  ;; If mark-set is #f, use current-continuation-marks
+  (let* ((ms (or mark-set (current-continuation-marks prompt-tag)))
+	 (frames (vector-ref ms 1)))
+    (let loop ((frames frames) (result '()))
+      (if (null? frames)
+	  (reverse! result)
+	  (let* ((frame (car frames))
+		 (entry (assq key frame)))
+	    (if entry
+		(loop (cdr frames) (cons (cdr entry) result))
+		(loop (cdr frames) result)))))))
+
+(define (continuation-mark-set->list* mark-set keys 
+	 :optional (default #f) (prompt-tag (default-continuation-prompt-tag)))
+  ;; Helper function to check if any key in keys has an entry in frame
+  (define (has-any-key? frame keys)
+    (let loop ((ks keys))
+      (cond ((null? ks) #f)
+	    ((assq (car ks) frame) #t)
+	    (else (loop (cdr ks))))))
+  ;; If mark-set is #f, use current-continuation-marks
+  (let* ((ms (or mark-set (current-continuation-marks prompt-tag)))
+	 (frames (vector-ref ms 1))
+	 (key-count (length keys)))
+    (let loop ((frames frames) (result '()))
+      (if (null? frames)
+	  (reverse result)
+	  (let* ((frame (car frames))
+		 ;; Check if this frame has any of our keys
+		 (has-key? (has-any-key? frame keys)))
+	    (if has-key?
+		(let ((vec (make-vector key-count default)))
+		  ;; Fill in values for each key
+		  (let key-loop ((ks keys) (i 0))
+		    (if (null? ks)
+			(loop (cdr frames) (cons vec result))
+			(let ((entry (assq (car ks) frame)))
+			  (when entry
+			    (vector-set! vec i (cdr entry)))
+			  (key-loop (cdr ks) (+ i 1))))))
+		(loop (cdr frames) result)))))))
+
+(define (continuation-mark-set-first mark-set key 
+	 :optional (default #f) (prompt-tag (default-continuation-prompt-tag)))
+  ;; If mark-set is #f, use current-continuation-marks
+  (let* ((ms (or mark-set (current-continuation-marks prompt-tag)))
+	 (frames (vector-ref ms 1)))
+    (let loop ((frames frames))
+      (if (null? frames)
+	  default
+	  (let* ((frame (car frames))
+		 (entry (assq key frame)))
+	    (if entry
+		(cdr entry)
+		(loop (cdr frames))))))))
+
+(define (continuation-mark-set->iterator . arg*)
+  (let f ((ls (apply continuation-mark-set->list* arg*)))
+    (lambda ()
+      (if (null? ls)
+          (values #f
+                  (lambda ()
+                    (apply assertion-violation
+                           'continuation-mark-set->iterator
+                           "attempt to iterate past the end"
+                           arg*)))
+          (values (car ls) (f (cdr ls)))))))
+
+(define-record-type continuation-mark-key
+  (nongenerative) (sealed #t) (opaque #f)
+  (fields (mutable name))
+  (protocol
+   (lambda (p)
+     (lambda (:optional ((name (or symbol? #f)) #f)) (p name)))))
+
 ;; From SRFI-226 implementation
 (define-syntax reset
   (lambda (x)

src/lib_sagittarius.stub

@@ -1869,6 +1869,18 @@
     (:optional (name::<symbol> (Sg_Gensym NULL)))
     Sg_MakeContinuationPromptTag)
 
+  (define-c-proc call/cm (entries::<vector> thunk::<procedure>) Sg_VMCallCM)
+  (define-c-proc continuation-mark-set? (o) ::<boolean> :no-side-effect
+    Sg_ContinuationMarkSetP)
+  (define-c-proc %cm (k tag) :no-side-effect :no-export
+    Sg_ContinuationMarks)
+  (define-c-proc %ccm (tag) :no-side-effect :no-export
+    Sg_CurrentContinuationMarks)
+  
+  (define-c-proc call-with-immediate-continuation-mark 
+    (key proc::<procedure> :optional (default #f))
+    Sg_VMCallImmediateCM)
+  
   (define default-continuation-prompt-tag
     (let ((tag (make-continuation-prompt-tag (gensym "default"))))
       (lambda () tag)))
@@ -1892,6 +1904,13 @@
 			   (default-continuation-prompt-tag)))
     (%call/delim-cc proc tag))
 
+  (define (continuation-marks k 
+	   :optional (tag (default-continuation-prompt-tag)))
+    (%cm k tag))
+  (define (current-continuation-marks 
+	   :optional (tag (default-continuation-prompt-tag)))
+    (%ccm tag))
+
   (define call/prompt call-with-continuation-prompt)
   (define abort/cc abort-current-continuation)
   (define call/comp call-with-composable-continuation)

src/sagittarius/private/vm.h

@@ -108,6 +108,8 @@ typedef enum {
   SG_DELIMIETED_CONTINUATION
 } SgContType;
 
+typedef struct SgContMarksRec SgContMarks;
+
 typedef struct SgContinucationRec
 {
   struct SgContinucationRec * prev;
@@ -120,6 +122,7 @@ typedef struct SgContinucationRec
   int          errorReporting;
   int          rewindBefore;
   SgContType   type;
+  SgContMarks *marks;
 } SgContinuation;
 
 #define SG_CONTINUATION(obj)  ((SgContinuation*)obj)
@@ -228,6 +231,18 @@ typedef struct SgPromptNodeRec
   struct SgPromptNodeRec *next;
 } SgPromptNode;
 
+typedef struct SgMarkEntryRec {
+  SgObject key;
+  SgObject value;
+  struct SgMarkEntryRec *next;
+} SgMarkEntry;
+
+struct SgContMarksRec {
+  SgContFrame *frame;
+  SgMarkEntry *entries;
+  struct SgContMarksRec *prev;
+};
+
 struct SgVMRec
 {
   SG_HEADER;
@@ -252,6 +267,7 @@ struct SgVMRec
   SgObject *fp;			/* frame pointer */
   SgObject *sp;			/* stack pointer */
   SgContFrame  *cont;     	/* saved continuation frame */
+  SgContMarks  *marks;		/* continuation marks */
   SgPromptNode *prompts;	/* prompt chain, this is the top */
   /* values buffer */
   int      valuesCount;
@@ -429,13 +445,21 @@ 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 entries, SgObject thunk);
+/* call-with-immediate-continuation-mark */
+SG_EXTERN SgObject Sg_VMCallImmediateCM(SgObject key, SgObject proc,
+					SgObject fallback);
 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 SgObject Sg_MakeContinuationPromptTag(SgObject name);
 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 int      Sg_ContinuationMarkSetP(SgObject o);
+SG_EXTERN SgObject Sg_ContinuationMarks(SgObject k, SgObject promptTag);
+SG_EXTERN SgObject Sg_CurrentContinuationMarks(SgObject promptTag);
 SG_EXTERN SgVM*    Sg_VM();	/* get vm */
 SG_EXTERN int      Sg_SetCurrentVM(SgVM *vm);
 SG_EXTERN int      Sg_AttachVM(SgVM *vm);