Permalink
Browse files

add continuation?, amb and coroutine test

  • Loading branch information...
1 parent 73b59b9 commit ffbf8b90b7eaf053ae7a19767a4c1c9132dc4cf3 @cpylua committed Mar 25, 2012
Showing with 183 additions and 5 deletions.
  1. +5 −3 ioproc.c
  2. +53 −0 lib/amb.scm
  3. +88 −0 lib/coop-threads.scm
  4. +6 −0 lib/core.scm
  5. +14 −0 procdef.c
  6. +17 −2 test/cont.scm
View
@@ -8,13 +8,13 @@
#include "eval.h"
#include "repl.h"
#include "sform.h"
-
+#include "gc.h"
static int load_proc(object *params, object **result) {
char *filename;
FILE *in;
object *exp, *val;
- object *env;
+ object *env, *port;
if (result == NULL) {
return SC_E_NULL;
@@ -32,8 +32,10 @@ static int load_proc(object *params, object **result) {
if (in == NULL) {
return SC_E_IO_OPEN;
}
+ port = make_input_port(in); /* delay fclose to gc */
env = get_repl_env();
val = get_nrv_symbol();
+ gc_protect(port);
while (!is_eof_object((exp = sc_read(in)))) {
if (exp == NULL) {
return SC_E_LOAD;
@@ -43,7 +45,7 @@ static int load_proc(object *params, object **result) {
return SC_E_LOAD;
}
}
- fclose(in);
+ gc_abandon();
*result = val;
return 0;
}
View
@@ -0,0 +1,53 @@
+; current-continuation : -> continuation
+(define (current-continuation)
+ (call-with-current-continuation
+ (lambda (cc)
+ (cc cc))))
+
+; fail-stack : list[continuation]
+(define fail-stack '())
+
+; fail : -> ...
+(define (fail)
+ (if (not (pair? fail-stack))
+ (error "back-tracking stack exhausted!")
+ (begin
+ (let ((back-track-point (car fail-stack)))
+ (set! fail-stack (cdr fail-stack))
+ (back-track-point back-track-point)))))
+
+; amb : list[a] -> a
+(define (amb choices)
+ (let ((cc (current-continuation)))
+ (cond
+ ((null? choices) (fail))
+ ((pair? choices) (let ((choice (car choices)))
+ (set! choices (cdr choices))
+ (set! fail-stack (cons cc fail-stack))
+ choice)))))
+
+; (assert condition) will cause
+; condition to be true, and if there
+; is no way to make it true, then
+; it signals and error in the program.
+(define (assert condition)
+ (if (not condition)
+ (fail)
+ #t))
+
+
+; The following prints (4 3 5)
+(let ((a (amb (list 1 2 3 4 5 6 7)))
+ (b (amb (list 1 2 3 4 5 6 7)))
+ (c (amb (list 1 2 3 4 5 6 7))))
+
+ ; We're looking for dimensions of a legal right
+ ; triangle using the Pythagorean theorem:
+ (assert (= (* c c) (+ (* a a) (* b b))))
+ ; And, we want the second side to be the shorter one:
+ (assert (< b a))
+
+ ; Print out the answer:
+ (display (list a b c))
+ (newline))
+
View
@@ -0,0 +1,88 @@
+; thread-queue : list[continuation]
+(define thread-queue '())
+
+; halt : continuation
+(define halt #f)
+
+; void : -> void
+(define (void) (if #f #t))
+
+; current-continuation : -> continuation
+(define (current-continuation)
+ (call-with-current-continuation
+ (lambda (cc)
+ (cc cc))))
+
+; spawn : (-> anything) -> void
+(define (spawn thunk)
+ (let ((cc (current-continuation)))
+ (if (continuation? cc)
+ (set! thread-queue (append thread-queue (list cc)))
+ (begin (thunk)
+ (quit)))))
+
+; yield : value -> void
+(define (yield)
+ (let ((cc (current-continuation)))
+ (if (and (continuation? cc) (pair? thread-queue))
+ (let ((next-thread (car thread-queue)))
+ (set! thread-queue (append (cdr thread-queue) (list cc)))
+ (next-thread 'resume))
+ (void))))
+
+; quit : -> ...
+(define (quit)
+ (if (pair? thread-queue)
+ (let ((next-thread (car thread-queue)))
+ (set! thread-queue (cdr thread-queue))
+ (next-thread 'resume))
+ (halt)))
+
+; start-threads : -> ...
+(define (start-threads)
+ (let ((cc (current-continuation)))
+ (if cc
+ (begin
+ (set! halt (lambda () (cc #f)))
+ (if (null? thread-queue)
+ (void)
+ (begin
+ (let ((next-thread (car thread-queue)))
+ (set! thread-queue (cdr thread-queue))
+ (next-thread 'resume)))))
+ (void))))
+
+
+
+
+;; Example cooperatively threaded program
+(define counter 10)
+
+(define (make-thread-thunk name)
+ (define (loop)
+ (if (< counter 0)
+ (quit)
+ (begin
+ (display "in thread ")
+ (display name)
+ (display "; counter = ")
+ (display counter)
+ (newline)
+ (set! counter (- counter 1))
+ (yield)
+ (loop))))
+ loop)
+
+(spawn (make-thread-thunk 'a))
+(spawn (make-thread-thunk 'b))
+(spawn (make-thread-thunk 'c))
+
+(start-threads)
+
+
+
+
+
+
+
+
View
@@ -482,3 +482,9 @@
(define call/cc call-with-current-continuation)
+(define (values . vals)
+ (call/cc
+ (lambda (cont) (cont vals))))
+
+(define (current-continuation)
+ (call/cc (lambda (cc) (cc cc))))
View
@@ -202,6 +202,19 @@ static int is_procedure_proc(object *params, object **result) {
return 0;
}
+static int is_continuation_proc(object *params, object **result) {
+ int ret;
+ object *obj;
+
+ check_null(result);
+ check_arg1(params);
+
+ obj = car(params);
+ ret = is_cont(obj);
+ *result = ret ? get_true_obj() : get_false_obj();
+ return 0;
+}
+
static int char_to_integer_proc(object *params, object **result) {
if (result == NULL) {
return SC_E_NULL;
@@ -1282,6 +1295,7 @@ int init_primitive(object *env) {
define_proc("string?", is_string_proc);
define_proc("pair?", is_pair_proc);
define_proc("procedure?", is_procedure_proc);
+ define_proc("continuation?", is_continuation_proc);
define_proc("char->integer", char_to_integer_proc);
define_proc("integer->char", integer_to_char_proc);
View
@@ -15,10 +15,25 @@
(newline)
(define r #f)
-(+ 1 (call/cc
+(display
+ (+ 1 (call/cc
(lambda (k)
(set! r k)
- (+ 2 (k 3)))))
+ (+ 2 (k 3))))))
+(newline)
+
+(display
+ (call/cc (lambda (cc)
+ (display "I got here\n")
+ (cc "This string is passed to the continuation\n")
+ (display "But not here\n"))))
+
+(let ((start #f))
+ (if (not start)
+ (call/cc (lambda (cc)
+ (set! start cc))))
+ (display "Going to call (start)\n")
+ (start 'ok)) ; infinite loop

0 comments on commit ffbf8b9

Please sign in to comment.