| … | |
… | |
| 714 | (not (cond-eval (cadr condition))))) |
714 | (not (cond-eval (cadr condition))))) |
| 715 | (else (error "cond-expand : unknown operator" (car condition))))))) |
715 | (else (error "cond-expand : unknown operator" (car condition))))))) |
| 716 | |
716 | |
| 717 | (gc-verbose #f) |
717 | (gc-verbose #f) |
| 718 | |
718 | |
|
|
719 | ; compatibility functions added by schmorp@schmorp.de |
|
|
720 | (macro (defmacro dform) |
|
|
721 | (let ((name (cadr dform)) (formals (caddr dform)) (body (cdddr dform))) |
|
|
722 | `(define-macro (,name . ,formals) ,@body))) |
|
|
723 | |
| 719 | ;; srfi-1 |
724 | ;; srfi-1 |
| 720 | |
725 | |
| 721 | (define (check-arg pred val caller) |
726 | (define (check-arg pred val caller) |
| 722 | (let lp ((val val)) |
727 | (let lp ((val val)) |
| 723 | (if (pred val) val (lp (error "Bad argument" val pred caller))))) |
728 | (if (pred val) val (lp (error "Bad argument" val pred caller))))) |
| 724 | |
729 | |
| 725 | ;(load "srfi-1-reference.scm") |
730 | (load "srfi-1-reference.scm") |
| 726 | |
731 | |
| 727 | ;; end of init |
732 | ;; end of init |
| 728 | |
733 | |
| 729 | ;(define xx (call-with-current-continuation (lambda (x) x))) |
|
|
| 730 | ; |
|
|
| 731 | ; (display xx) |
|
|
| 732 | ; (display "A\n")(xx xx) |
|
|
| 733 | ; (display "b\n")(xx xx) |
|
|
| 734 | ; (display "c\n")(xx xx) |
|
|
| 735 | ; (display "d\n")(xx xx) |
|
|
| 736 | |
|
|
| 737 | ;(do ((j 0 (+ j 1))) ((> j 100000)) ()) |
734 | ;(do ((j 0 (+ j 1))) ((> j 100000)) ()) |
| 738 | |
735 | |
|
|
736 | ;(define call/cc call-with-current-continuation) |
|
|
737 | |
|
|
738 | (define (coroutine routine) |
|
|
739 | (let ((current routine) |
|
|
740 | (status 'suspended)) |
|
|
741 | (lambda args |
|
|
742 | (cond ((null? args) |
|
|
743 | (if (eq? status 'dead) |
|
|
744 | (error 'dead-coroutine) |
|
|
745 | (let ((continuation-and-value |
|
|
746 | (call/cc (lambda (return) |
|
|
747 | (let ((returner |
|
|
748 | (lambda (value) |
|
|
749 | (call/cc (lambda (next) |
|
|
750 | (return (cons next value))))))) |
|
|
751 | (current returner) |
|
|
752 | (set! status 'dead)))))) |
|
|
753 | (if (pair? continuation-and-value) |
|
|
754 | (begin (set! current (car continuation-and-value)) |
|
|
755 | (cdr continuation-and-value)) |
|
|
756 | continuation-and-value)))) |
|
|
757 | ((eq? (car args) 'status?) status) |
|
|
758 | ((eq? (car args) 'dead?) (eq? status 'dead)) |
|
|
759 | ((eq? (car args) 'alive?) (not (eq? status 'dead))) |
|
|
760 | ((eq? (car args) 'kill!) (set! status 'dead)) |
|
|
761 | (true nil))))) |
|
|
762 | |
|
|
763 | (define test-coroutine-1 |
|
|
764 | (coroutine (lambda (yield) |
|
|
765 | (display "HELLO!") |
|
|
766 | (yield 1) |
|
|
767 | (display "WORLD!") |
|
|
768 | (yield 2) |
|
|
769 | (display "SORRY, I'M OUT")))) |
|
|
770 | (test-coroutine-1 'status?) |
|
|
771 | (test-coroutine-1 'dead?) |
|
|
772 | (test-coroutine-1 'alive?) |
|
|
773 | (test-coroutine-1) |
|
|
774 | (test-coroutine-1) |
|
|
775 | (test-coroutine-1) |
|
|
776 | (test-coroutine-1 'status?) |
|
|
777 | (test-coroutine-1 'dead?) |
|
|
778 | (test-coroutine-1) |
