Implementing &continuation

Author: ktakashi

lib/core/conditions.scm

@@ -45,6 +45,9 @@
 
 	  &syntax-case syntax-case-condition?
 	  &syntax-pattern syntax-pattern-condition? condition-syntax-pattern
+	  
+	  &continuation make-continuation-violation
+	  continuation-violation? continuation-violation-prompt-tag
 	  ;; NB: we might want to use different type of mechanism of
 	  ;;     tracing stack trace, so don't export it for now.
 	  ;; &stack-trace stack-trace-condition?
@@ -116,6 +119,8 @@
   (initialize-builtin-condition &syntax-case &condition)
   (initialize-builtin-condition &syntax-pattern &syntax-case pattern)
 
+  (initialize-builtin-condition &continuation &violation prompt-tag)
+
   (define (condition-predicate rtd)
     (let ((class (slot-ref rtd 'class)))
       (lambda (o)
@@ -178,6 +183,9 @@
   (define condition-syntax-pattern
     (condition-accessor (record-type-rtd &syntax-pattern) &syntax-pattern))
 
+  (define continuation-violation-prompt-tag
+    (condition-accessor (record-type-rtd &continuation)
+			&continuation-violation-prompt-tag))
   (define-syntax define-condition-type
     (lambda (x)
       (syntax-case x ()

src/exceptions.c

@@ -210,10 +210,7 @@ SG_DEFINE_BASE_CLASS(Sg_ViolationClass, SgCondition,
 		     condition0_printer, NULL, NULL, Sg_ConditionAllocate,
 		     serious_cpl);
 static SgClass *violation_cpl[] = {
-  SG_CLASS_VIOLATION,
-  SG_CLASS_SERIOUS,
-  SG_CLASS_CONDITION,
-  SG_CLASS_TOP,
+  SG_VIOLATION_CPL,
   NULL
 };
 SG_DEFINE_BASE_CLASS(Sg_AssertionClass, SgCondition,

src/sagittarius/private/exceptions.h

@@ -340,6 +340,13 @@ typedef struct SgSyntaxPatternConditionRec
     SG_CLASS_CONDITION,				\
     SG_CLASS_TOP				\
 
+#define SG_VIOLATION_CPL			\
+  SG_CLASS_VIOLATION,				\
+    SG_CLASS_SERIOUS,				\
+    SG_CLASS_CONDITION,				\
+    SG_CLASS_TOP
+
+
 #define SG_DEFINE_CONDITION_ALLOCATOR(name, type)		\
   static SgObject name(SgClass *klass, SgObject initargs) {	\
     type *c = SG_ALLOCATE(type, klass);				\

src/sagittarius/private/vm.h

@@ -44,9 +44,12 @@
 
 SG_CLASS_DECL(Sg_BoxClass);
 SG_CLASS_DECL(Sg_VMClass);
+/* &continuation */
+SG_CLASS_DECL(Sg_ContinuationViolationClass);
 
 #define SG_CLASS_BOX (&Sg_BoxClass)
 #define SG_CLASS_VM  (&Sg_VMClass)
+#define SG_CLASS_CONTINUATION_VIOLATION (&Sg_ContinuationViolationClass)
 
 struct SgBoxRec
 {
@@ -57,6 +60,16 @@ struct SgBoxRec
 #define SG_BOX(obj)  ((SgBox*)(obj))
 #define SG_BOXP(obj) SG_XTYPEP(obj, SG_CLASS_BOX)
 
+typedef struct SgContinuationViolationRec
+{
+  SG_INSTANCE_HEADER;
+  SgObject promptTag;
+} SgContinuationViolation;
+#define SG_CONTINUATION_VIOLATION(o) ((SgContinuationViolation *)o)
+#define SG_CONTINUATION_VIOLATIONP(o) SG_ISA(o, SG_CLASS_CONTINUATION_VIOLATION)
+#define SG_CONTINUATION_VIOLATION_PROMPT_TAG(o) \
+  SG_CONTINUATION_VIOLATION(o)->promptTag
+
 /* continuation frame */
 typedef struct SgContFrameRec
 {

src/vm.c

@@ -36,6 +36,7 @@
 #include "sagittarius/private/core.h"
 #include "sagittarius/private/closure.h"
 #include "sagittarius/private/error.h"
+#include "sagittarius/private/exceptions.h"
 #include "sagittarius/private/file.h"
 #include "sagittarius/private/generic.h"
 #include "sagittarius/private/hashtable.h"
@@ -45,6 +46,7 @@
 #include "sagittarius/private/pair.h"
 #include "sagittarius/private/port.h"
 #include "sagittarius/private/transcoder.h"
+#include "sagittarius/private/record.h"
 #include "sagittarius/private/reader.h"
 #include "sagittarius/private/string.h"
 #include "sagittarius/private/symbol.h"
@@ -139,6 +141,46 @@ static void vm_print(SgObject obj, SgPort *port, SgWriteContext *ctx)
 
 SG_DEFINE_BUILTIN_CLASS_SIMPLE(Sg_VMClass, vm_print);
 
+static SgClass *violation_cpl[] = {
+  SG_VIOLATION_CPL,
+  NULL
+};
+
+static void cont_violation_printer(SgObject o, SgPort *p, SgWriteContext *ctx)
+{
+  Sg_Printf(p, UC("#<&continuation %S>"),
+	    SG_CONTINUATION_VIOLATION_PROMPT_TAG(o));
+}
+
+static SgObject cont_violation_allocate(SgClass *klass, SgObject initargs)
+{
+  SgContinuationViolation *c = SG_ALLOCATE(SgContinuationViolation, klass);
+  SG_SET_CLASS(c, klass);
+  return SG_OBJ(c);
+}
+
+static void cont_violation_tag_set(SgContinuationViolation *c, SgObject tag)
+{
+  if (!SG_CONTINUATION_VIOLATIONP(c)) {
+    Sg_Error(UC("&continuation required but got %S"), c);
+  }
+  SG_CONTINUATION_VIOLATION_PROMPT_TAG(c) = tag;
+}
+
+static SgObject cont_violation_tag(SgContinuationViolation *c)
+{
+  return SG_CONTINUATION_VIOLATION_PROMPT_TAG(c);
+}
+
+static SgSlotAccessor cont_violation_slot[] = {
+  SG_CLASS_SLOT_SPEC("prompt-tag", 0, cont_violation_tag, cont_violation_tag_set),
+  {{ NULL }}
+};
+
+SG_DEFINE_BASE_CLASS(Sg_ContinuationViolationClass, SgContinuationViolation,
+		     cont_violation_printer, NULL, NULL, cont_violation_allocate,
+		     violation_cpl);
+
 static SgObject copy_generics(SgObject lib)
 {
   SgObject h = SG_NIL, t = SG_NIL, gs;
@@ -3409,6 +3451,14 @@ void Sg__PostInitVM()
   if (SG_UNBOUNDP(b)) {
     Sg_Panic("`raise` was not found.");
   }
+  SG_INIT_CONDITION(SG_CLASS_CONTINUATION_VIOLATION, lib, "&continuation",
+		    cont_violation_slot);
+  SG_INIT_CONDITION_PRED(SG_CLASS_CONTINUATION_VIOLATION, lib,
+			 "continuation-violation?");
+  SG_INIT_CONDITION_CTR(SG_CLASS_CONTINUATION_VIOLATION, lib,
+			"make-continuation-violation", 1);
+  SG_INIT_CONDITION_ACC(cont_violation_tag, lib,
+			"&continuation-violation-prompt-tag");
   raise_proc = SG_GLOC_GET(SG_GLOC(b));
   b = Sg_FindBinding(lib, SG_INTERN("raise-continuable"), SG_UNBOUND);
   if (SG_UNBOUNDP(b)) {