| … | |
… | |
| 737 | |
737 | |
| 738 | (load "srfi-1-reference.scm") |
738 | (load "srfi-1-reference.scm") |
| 739 | |
739 | |
| 740 | ;; end of init |
740 | ;; end of init |
| 741 | |
741 | |
| 742 | ;(do ((j 0 (+ j 1))) ((> j 100000)) ()) |
742 | (load "test.scm") |
| 743 | |
743 | |
| 744 | ;(define call/cc call-with-current-continuation) |
|
|
| 745 | |
|
|
| 746 | (define (coroutine routine) |
|
|
| 747 | (let ((current routine) |
|
|
| 748 | (status 'suspended)) |
|
|
| 749 | (lambda args |
|
|
| 750 | (cond ((null? args) |
|
|
| 751 | (if (eq? status 'dead) |
|
|
| 752 | (error 'dead-coroutine) |
|
|
| 753 | (let ((continuation-and-value |
|
|
| 754 | (call/cc (lambda (return) |
|
|
| 755 | (let ((returner |
|
|
| 756 | (lambda (value) |
|
|
| 757 | (call/cc (lambda (next) |
|
|
| 758 | (return (cons next value))))))) |
|
|
| 759 | (current returner) |
|
|
| 760 | (set! status 'dead)))))) |
|
|
| 761 | (if (pair? continuation-and-value) |
|
|
| 762 | (begin (set! current (car continuation-and-value)) |
|
|
| 763 | (cdr continuation-and-value)) |
|
|
| 764 | continuation-and-value)))) |
|
|
| 765 | ((eq? (car args) 'status?) status) |
|
|
| 766 | ((eq? (car args) 'dead?) (eq? status 'dead)) |
|
|
| 767 | ((eq? (car args) 'alive?) (not (eq? status 'dead))) |
|
|
| 768 | ((eq? (car args) 'kill!) (set! status 'dead)) |
|
|
| 769 | (true nil))))) |
|
|
| 770 | |
|
|
| 771 | (define test-coroutine-1 |
|
|
| 772 | (coroutine (lambda (yield) |
|
|
| 773 | (display "HELLO!") |
|
|
| 774 | (yield 1) |
|
|
| 775 | (display "WORLD!") |
|
|
| 776 | (yield 2) |
|
|
| 777 | (display "SORRY, I'M OUT")))) |
|
|
| 778 | (test-coroutine-1 'status?) |
|
|
| 779 | (test-coroutine-1 'dead?) |
|
|
| 780 | (test-coroutine-1 'alive?) |
|
|
| 781 | (test-coroutine-1) |
|
|
| 782 | (test-coroutine-1) |
|
|
| 783 | (test-coroutine-1) |
|
|
| 784 | (test-coroutine-1 'status?) |
|
|
| 785 | (test-coroutine-1 'dead?) |
|
|
| 786 | (test-coroutine-1) |
|
|
