more robust continuations, and implement 'loop' function

include/lang2/builtins.x.h

 X("print", l2_builtin_print)
 X("len", l2_builtin_len)
 X("if", l2_builtin_if)
+X("loop", l2_builtin_loop)
 #endif

include/lang2/vm/vm.h

 struct l2_vm;
 struct l2_vm_array;
 typedef l2_word (*l2_vm_cfunction)(struct l2_vm *vm, l2_word argc, l2_word *argv);
+typedef l2_word (*l2_vm_contcallback)(struct l2_vm *vm, l2_word retval, l2_word cont);
+typedef void (*l2_vm_gcmarker)(
+		struct l2_vm *vm, void *data, void (*mark)(struct l2_vm *vm, l2_word id));
 
 enum l2_value_type {
 	L2_VAL_TYPE_NONE,
 enum l2_value_flags {
 	L2_VAL_MARKED = 1 << 6,
 	L2_VAL_CONST = 1 << 7,
+	L2_VAL_CONT_CALLBACK = 1 << 7, // Re-use the const bit
+};
+
+struct l2_vm_contcontext {
+	l2_vm_contcallback callback;
+	l2_vm_gcmarker marker;
 };
 
 // The smallest size an l2_vm_value can be is 16 bytes on common platforms.
 	// Byte 0: 4 bytes
 	union {
 		l2_word ns_parent;
+		l2_word cont_call;
 	} extra;
 
 	// Byte 4: 1 byte, 3 bytes padding
 			l2_word ns;
 		} func;
 		l2_vm_cfunction cfunc;
-		struct {
-			l2_word call;
-			l2_word arg;
-		} cont;
+		struct l2_vm_contcontext *cont;
 		char *error;
 	};
 };

lib/vm/builtins.c

 			cond->atom == vm->values[vm->ktrue].atom) {
 		l2_word ret_id = l2_vm_alloc(vm, L2_VAL_TYPE_CONTINUATION, 0);
 		struct l2_vm_value *ret = &vm->values[ret_id];
-		ret->cont.call = argv[1];
-		ret->cont.arg = 0;
+		ret->extra.cont_call = argv[1];
 		return ret_id;
 	} else if (argc == 3) {
 		l2_word ret_id = l2_vm_alloc(vm, L2_VAL_TYPE_CONTINUATION, 0);
 		struct l2_vm_value *ret = &vm->values[ret_id];
-		ret->cont.call = argv[2];
-		ret->cont.arg = 0;
+		ret->extra.cont_call = argv[2];
 		return ret_id;
 	} else {
 		return 0;
 	}
 }
+
+struct loop_context {
+	struct l2_vm_contcontext base;
+	l2_word cond;
+};
+
+static l2_word loop_callback(struct l2_vm *vm, l2_word retval, l2_word cont) {
+	struct l2_vm_value *ret = &vm->values[retval];
+	if (
+			l2_vm_value_type(ret) == L2_VAL_TYPE_ATOM &&
+			ret->atom == vm->values[vm->ktrue].atom) {
+		return cont;
+	}
+
+	return retval;
+}
+
+static void loop_marker(
+		struct l2_vm *vm, void *data, void (*mark)(struct l2_vm *vm, l2_word id)) {
+	struct loop_context *ctx = data;
+	mark(vm, ctx->cond);
+}
+
+l2_word l2_builtin_loop(struct l2_vm *vm, l2_word argc, l2_word *argv) {
+	if (argc != 1 && argc != 2) {
+		return l2_vm_error(vm, "Expected 1 or 2 arguments");
+	}
+
+	struct loop_context *ctx = malloc(sizeof(*ctx));
+	if (ctx == NULL) {
+		return l2_vm_error(vm, "Allocation failure");
+	}
+
+	ctx->base.callback = loop_callback;
+	ctx->base.marker = loop_marker;
+	ctx->cond = argv[0];
+
+	l2_word cont_id = l2_vm_alloc(vm, L2_VAL_TYPE_CONTINUATION, 0);
+	struct l2_vm_value *cont = &vm->values[cont_id];
+	cont->extra.cont_call = argv[0];
+	cont->cont = &ctx->base;
+	return cont_id;
+}

lib/vm/print.c

 
 	case L2_VAL_TYPE_CFUNCTION:
 		// ISO C doesn't let you cast a function pointer to void*.
-		printf("C FUNCTION, %jx\n", (uintmax_t)val->cfunc);
+		printf("C FUNCTION, %8jx\n", (uintmax_t)val->cfunc);
 		break;
 
 	case L2_VAL_TYPE_ERROR:
 		break;
 
 	case L2_VAL_TYPE_CONTINUATION:
-		printf("CONTINUATION, call %u, cont %jx\n",
+		printf("CONTINUATION, call %u, cont %08jx\n",
 				val->extra.cont_call, (uintmax_t)val->cont);
 		break;
 	}
 		return;
 
 	case L2_OP_FUNC_CALL_U4:
-		printf("FUNC_CALL %08x\n", read_u4le(ops, ptr));
+		printf("FUNC_CALL %u\n", read_u4le(ops, ptr));
 		return;
 	case L2_OP_FUNC_CALL_U1:
-		printf("FUNC_CALL %02x\n", read_u1le(ops, ptr));
+		printf("FUNC_CALL %u\n", read_u1le(ops, ptr));
 		return;
 
 	case L2_OP_FUNC_CALL_INFIX:
 		return;
 
 	case L2_OP_RJMP_U4:
-		printf("RJMP %08x\n", read_u4le(ops, ptr));
+		printf("RJMP %u\n", read_u4le(ops, ptr));
 		return;
 	case L2_OP_RJMP_U1:
-		printf("RJMP %02x\n", read_u1le(ops, ptr));
+		printf("RJMP %u\n", read_u1le(ops, ptr));
 		return;
 
 	case L2_OP_STACK_FRAME_LOOKUP_U4:
-		printf("STACK_FRAME_LOOKUP %08x\n", read_u4le(ops, ptr));
+		printf("STACK_FRAME_LOOKUP %u\n", read_u4le(ops, ptr));
 		return;
 	case L2_OP_STACK_FRAME_LOOKUP_U1:
-		printf("STACK_FRAME_LOOKUP %02x\n", read_u1le(ops, ptr));
+		printf("STACK_FRAME_LOOKUP %u\n", read_u1le(ops, ptr));
 		return;
 
 	case L2_OP_STACK_FRAME_SET_U4:
-		printf("STACK_FRAME_SET %08x\n", read_u4le(ops, ptr));
+		printf("STACK_FRAME_SET %u\n", read_u4le(ops, ptr));
 		return;
 	case L2_OP_STACK_FRAME_SET_U1:
-		printf("STACK_FRAME_SET %02x\n", read_u1le(ops, ptr));
+		printf("STACK_FRAME_SET %u\n", read_u1le(ops, ptr));
 		return;
 
 	case L2_OP_STACK_FRAME_REPLACE_U4:
-		printf("STACK_FRAME_REPLACE %08x\n", read_u4le(ops, ptr));
+		printf("STACK_FRAME_REPLACE %u\n", read_u4le(ops, ptr));
 		return;
 	case L2_OP_STACK_FRAME_REPLACE_U1:
-		printf("STACK_FRAME_REPLACE %02x\n", read_u1le(ops, ptr));
+		printf("STACK_FRAME_REPLACE %u\n", read_u1le(ops, ptr));
 		return;
 
 	case L2_OP_RET:
 		return;
 
 	case L2_OP_ALLOC_ATOM_U4:
-		printf("ALLOC_ATOM %08x\n", read_u4le(ops, ptr));
+		printf("ALLOC_ATOM %u\n", read_u4le(ops, ptr));
 		return;
 	case L2_OP_ALLOC_ATOM_U1:
-		printf("ALLOC_ATOM %02x\n", read_u1le(ops, ptr));
+		printf("ALLOC_ATOM %u\n", read_u1le(ops, ptr));
 		return;
 
 	case L2_OP_ALLOC_REAL_D8:
 		{
 			l2_word w1 = read_u4le(ops, ptr);
 			l2_word w2 = read_u4le(ops, ptr);;
-			printf("ALLOC_BUFFER_STATIC %08x %08x\n", w1, w2);
+			printf("ALLOC_BUFFER_STATIC %u %u\n", w1, w2);
 		}
 		return;
 	case L2_OP_ALLOC_BUFFER_STATIC_U1:
 		{
 			l2_word w1 = read_u1le(ops, ptr);
 			l2_word w2 = read_u1le(ops, ptr);;
-			printf("ALLOC_BUFFER_STATIC %02x %02x\n", w1, w2);
+			printf("ALLOC_BUFFER_STATIC %u %u\n", w1, w2);
 		}
 		return;
 
 	case L2_OP_ALLOC_ARRAY_U4:
-		printf("ALLOC_ARRAY %08x\n", read_u4le(ops, ptr));
+		printf("ALLOC_ARRAY %u\n", read_u4le(ops, ptr));
 		return;
 	case L2_OP_ALLOC_ARRAY_U1:
-		printf("ALLOC_ARRAY %02x\n", read_u1le(ops, ptr));
+		printf("ALLOC_ARRAY %u\n", read_u1le(ops, ptr));
 		return;
 
 	case L2_OP_ALLOC_NAMESPACE:
 		return;
 
 	case L2_OP_ALLOC_FUNCTION_U4:
-		printf("ALLOC_FUNCTION %08x\n", read_u4le(ops, ptr));
+		printf("ALLOC_FUNCTION %u\n", read_u4le(ops, ptr));
 		return;
 	case L2_OP_ALLOC_FUNCTION_U1:
-		printf("ALLOC_FUNCTION %02x\n", read_u1le(ops, ptr));
+		printf("ALLOC_FUNCTION %u\n", read_u1le(ops, ptr));
 		return;
 
 	case L2_OP_NAMESPACE_SET_U4:
-		printf("NAMESPACE_SET %08x\n", read_u4le(ops, ptr));
+		printf("NAMESPACE_SET %u\n", read_u4le(ops, ptr));
 		return;
 	case L2_OP_NAMESPACE_SET_U1:
-		printf("NAMESPACE_SET %02x\n", read_u1le(ops, ptr));
+		printf("NAMESPACE_SET %u\n", read_u1le(ops, ptr));
 		return;
 
 	case L2_OP_NAMESPACE_LOOKUP_U4:
-		printf("NAMESPACE_LOOKUP %08x\n", read_u4le(ops, ptr));
+		printf("NAMESPACE_LOOKUP %u\n", read_u4le(ops, ptr));
 		return;
 	case L2_OP_NAMESPACE_LOOKUP_U1:
-		printf("NAMESPACE_LOOKUP %02x\n", read_u1le(ops, ptr));
+		printf("NAMESPACE_LOOKUP %u\n", read_u1le(ops, ptr));
 		return;
 
 	case L2_OP_ARRAY_LOOKUP_U4:
-		printf("ARRAY_LOOKUP %08x\n", read_u4le(ops, ptr));
+		printf("ARRAY_LOOKUP %u\n", read_u4le(ops, ptr));
 		return;
 	case L2_OP_ARRAY_LOOKUP_U1:
-		printf("ARRAY_LOOKUP %02x\n", read_u1le(ops, ptr));
+		printf("ARRAY_LOOKUP %u\n", read_u1le(ops, ptr));
 		return;
 
 	case L2_OP_ARRAY_SET_U4:
-		printf("ARRAY_SET %08x\n", read_u4le(ops, ptr));
+		printf("ARRAY_SET %u\n", read_u4le(ops, ptr));
 		return;
 	case L2_OP_ARRAY_SET_U1:
-		printf("ARRAY_SET %02x\n", read_u1le(ops, ptr));
+		printf("ARRAY_SET %u\n", read_u1le(ops, ptr));
 		return;
 
 	case L2_OP_DYNAMIC_LOOKUP:
 		return;
 	}
 
-	printf("? %02x\n", opcode);
+	printf("? 0x%02x\n", opcode);
 }
 
 void l2_vm_print_bytecode(unsigned char *ops, size_t opcount) {

lib/vm/vm.c

 		gc_mark_namespace(vm, val);
 	} else if (typ == L2_VAL_TYPE_FUNCTION) {
 		gc_mark(vm, val->func.ns);
+	} else if (
+			typ == L2_VAL_TYPE_CONTINUATION &&
+			val->cont != NULL && val->cont->marker != NULL) {
+		val->cont->marker(vm, val->cont, gc_mark);
 	}
 }
 
 		free(val->ns);
 	} else if (typ == L2_VAL_TYPE_ERROR) {
 		free(val->error);
+	} else if (typ == L2_VAL_TYPE_CONTINUATION) {
+		free(val->cont);
 	}
 }
 
 	vm->values[builtins].flags = L2_VAL_TYPE_NAMESPACE;
 	vm->fstack[vm->fsptr].ns = builtins;
 	vm->fstack[vm->fsptr].retptr = 0;
+	vm->fstack[vm->fsptr].sptr = 0;
 	vm->fsptr += 1;
 
 	// Need to allocate a root namespace
 	vm->values[root].flags = L2_VAL_TYPE_NAMESPACE;
 	vm->fstack[vm->fsptr].ns = root;
 	vm->fstack[vm->fsptr].retptr = 0;
+	vm->fstack[vm->fsptr].sptr = 0;
 	vm->fsptr += 1;
 
 	// Define a C function variable for every builtin
 		// make the call stack depth unbounded
 		vm->stack[vm->sptr++] = func->cfunc(vm, argc, argv);
 		while (1) {
-			struct l2_vm_value *val = &vm->values[vm->stack[vm->sptr - 1]];
-			if (l2_vm_value_type(val) != L2_VAL_TYPE_CONTINUATION) {
+			l2_word cont_id = vm->stack[vm->sptr - 1];
+			struct l2_vm_value *cont = &vm->values[cont_id];
+			if (l2_vm_value_type(cont) != L2_VAL_TYPE_CONTINUATION) {
 				break;
 			}
 
-			l2_word cont_id = val->cont.call;
-			struct l2_vm_value *cont = &vm->values[cont_id];
-
-			l2_word new_argc;
-			l2_word new_argv[1];
-			if (val->cont.arg == 0) {
-				new_argc = 0;
-			} else {
-				new_argc = 1;
-				new_argv[0] = val->cont.arg;
+			// If there's no callback it's easy, just call the function
+			// it wants us to call
+			l2_word call_id = cont->extra.cont_call;
+			if (cont->cont == NULL) {
+				vm->sptr -= 1;
+				call_func(vm, call_id, 0, NULL);
+				break;
 			}
 
-			if (l2_vm_value_type(cont) == L2_VAL_TYPE_CFUNCTION) {
-				vm->stack[vm->sptr - 1] = cont->cfunc(vm, new_argc, new_argv);
-			} else {
-				vm->sptr -= 1;
-				call_func(vm, cont_id, new_argc, new_argv);
+			struct l2_vm_value *call = &vm->values[call_id];
+
+			if (l2_vm_value_type(call) == L2_VAL_TYPE_CFUNCTION) {
+				l2_word retval = call->cfunc(vm, 0, NULL);
+				vm->stack[vm->sptr - 1] = cont->cont->callback(vm, retval, cont_id);
+			} else if (l2_vm_value_type(call) == L2_VAL_TYPE_FUNCTION) {
+				// Leave the continuation on the stack,
+				// let the L2_OP_RET code deal with it
+				cont->flags |= L2_VAL_CONT_CALLBACK;
+				call_func(vm, call_id, 0, NULL);
 				break;
+			} else {
+				l2_word err = l2_vm_type_error(vm, call);
+				vm->stack[vm->sptr - 1] = cont->cont->callback(vm, err, cont_id);
 			}
 		}
+
 		return;
 	}
 
 			l2_word sptr = vm->fstack[vm->fsptr - 1].sptr;
 			vm->fsptr -= 1;
 			vm->sptr = sptr;
-			vm->stack[vm->sptr++] = retval;
 			vm->iptr = retptr;
+
+			l2_word cont_id;
+			struct l2_vm_value *cont = NULL;
+			if (vm->sptr > 0) {
+				cont_id = vm->stack[vm->sptr - 1];
+				cont = &vm->values[cont_id];
+			}
+
+			int iscont =
+				cont != NULL && l2_vm_value_type(cont) == L2_VAL_TYPE_CONTINUATION;
+			int nocallback =
+				!iscont || (cont->flags & L2_VAL_CONT_CALLBACK && cont->cont == NULL);
+			if (nocallback) {
+				if (iscont) {
+					vm->stack[vm->sptr - 1] = retval;
+				} else {
+					vm->stack[vm->sptr++] = retval;
+				}
+				break;
+			}
+
+			if (cont->flags & L2_VAL_CONT_CALLBACK) {
+				retval = cont->cont->callback(vm, retval, cont_id);
+				cont_id = retval;
+				cont = &vm->values[cont_id];
+
+				if (l2_vm_value_type(cont) != L2_VAL_TYPE_CONTINUATION) {
+					vm->stack[vm->sptr - 1] = retval;
+					break;
+				}
+			}
+
+			cont->flags |= L2_VAL_CONT_CALLBACK;
+			call_func(vm, cont->extra.cont_call, 0, NULL);
 		}
 		break;