Multitasking with Continuations and Lists

mtl.rkt

#lang racket/base

(define tasklist (list (list 'root (box 'no-continuation))))
(define currtask tasklist)

(define call/cc call-with-current-continuation)

(define fork
    (lambda (name)
        (call/cc
            (lambda (cc)
                (set! tasklist (cons (list name (box cc)) tasklist))
                (cc name)))))

(define swap
    (lambda ()
        (call/cc
            (lambda (cc)
                (set-box! (cadar currtask) cc)
		(schedule)))))

(define schedule
  (lambda ()
    (set! currtask (cdr currtask))
    (when (null? currtask)
      (set! currtask tasklist))
    ((unbox (cadar currtask)) #t)))

(define exit
  (lambda ()
    (set! tasklist (filter (lambda (task) (not (eq? task (car currtask)))) tasklist))
    (schedule)))

(define (test)
  (define (t1)
    (printf "t1 starts\n")
    (swap)
    (printf "t1 continues\n")
    (swap)
    (printf "t1 ends\n")
    (exit))

  (define (t2)
    (printf "t2 starts\n")
    (swap)
    (printf "t2 continues\n")
    (swap)
    (printf "t2 ends\n")
    (exit))

  (if (eq? (fork 't1) #t)
      (t1)
      (if (eq? (fork 't2) #t)
	  (t2)
	  (let loop ()
	    (printf "base thread yielding\n")
	    (swap)
	    (when (> (length tasklist) 1)
	      (loop))))))

(test)