(define (prod lst) (let ((p 1)) loop: (when (null? l) (goto out:))

1. (define (prod lst) (let ((p 1)) loop: (when (null? l) (goto out:)) (set! p (* p (head lst))) (set! lst (tail lst)) (when (zero? p) (goto out:)) (goto loop:) out: (echo "Product =" p))) (define (prod lst) (let ((p 1) (loop: #f)) (let/cc out: (let/cc here (set! loop: here)) (when (null? lst) (out:)) (set! p (* p (head lst))) (set! lst (tail lst)) (when (zero? p) (out:)) (loop:)) (echo "Product =" p)))

2. ==> (prod '(1 2 3 4)) 24 ==> (define a (list 0 1 2 3)) ==> (set! a (append '(1 2 3 4 5 6) (append! a a))) ==> a (1 2 3 4 5 6 0 1 2 3 0 1 2 3 0 1 2 3 ... ) ==> (prod a) 0

3. (define toplevel-k #f) (let/cc k (set! toplevel-k k)) (define continue #f) (define (abort msg) (let/cc cont (set! continue (lambda () (set! continue #f) (cont #f))) (toplevel-k (list 'abort: msg)))) (define (fact n) (abort (list 'fact n)) (if (<= n 0) 1 (* n (fact (sub1 n))))) ==> (fact 4) (abort: (fact 4)) ==> (continue) (abort: (fact 3)) ==> (continue) (abort: (fact 2)) ==> (continue) (abort: (fact 1)) ==> (continue) (abort: (fact 0)) ==> (continue) 24 ==> (continue) ERROR - continue is now #f

4. (define processes '()) (define (enqueue-process! p) (set! Processes (append processes (list p)))) (define (dequeue-process!) (begin0 (head processes) (set! processes (tail processes)))) (define (more-processes?) (not (null? processes))) (define (done) (if (more-processes?) ((dequeue-process!)) (error "all done"))) (define (yield) (let/cc me (enqueue-process! me) (done))) (define (fork f) (let/cc me (enqueue-process! me) (f) (done)))

5. ==> (main) name: foo 6 name: bar 4 name: foo 5 name: baz 2 name: bar 3 name: foo 4 name: baz 1 name: bar 2 name: foo 3 name: baz 0 name: bar 1 name: foo 2 name: bar 0 name: foo 1 name: foo 0 all done (define (make-foo name n) (define (loop n) (echo "name:" name n) (yield) (sleep 1) (if (zero? n) (done) (loop (sub1 n)))) (lambda () (loop n))) (define (main) (fork (make-foo "foo" 6)) (fork (make-foo "bar" 4)) (fork (make-foo "baz" 2)) (done))

6. (defgeneric (do-match xs pattern success fail)) ;; match a single token (defmethod (do-match xs (p <symbol>) s f) (if (and (not (null? xs)) (eq? (head xs) p)) (s (tail xs) f) (f)))

7. (defstruct <pattern>) ;; define the "or" pattern with two parts (defstruct (<~or> <pattern>) p1 p2) (define ~or make-~or) (defmethod (do-match xs (p <~or>) s f) (do-match xs (~or-p1 p) s (lambda () (do-match xs (~or-p2 p) s f))))

8. ;; define a sequence of two patterns (defstruct (<~seq> <pattern>) p1 p2) (define ~seq make-~seq) (defmethod (do-match xs (p <~seq>) s f) (do-match xs (~seq-p1 p) (lambda (xs f) (do-match xs (~seq-p2 p) s f)) f))

9. ;; a structure that represents repeated patterns, ;; zero ot more times (defstruct (<~rep> <pattern>) p) (define ~rep make-~rep) (defmethod (do-match xs (p <~rep>) s f) (do-match xs (~seq (~rep-p p) p) s (lambda () (s xs f))))

10. ;; utility function that turns a string ;; into a token (symbol) list (define (string->symbols str) (map string->symbol (map string (string->list str)))) ;; this is the entry point (define (match x pattern) (do-match (append (string->symbols x) '($)) (~seq pattern '$) ;; toplevel success continuation (lambda (xs f) #t) ;; toplevel failure (lambda () #f)))

11. (match "a" 'a) (match "a" (~or 'a 'b)) (match "a" (~seq 'a 'b)) (match "ab" (~seq 'a 'b)) (define ab* (~rep (~seq 'a 'b))) (match "a" ab*) (match "ab" ab*) (match "aba" ab*) (match "abab" ab*) (match "" ab*) (match "abc" (~seq (~or 'a (~seq 'a 'b)) 'c)) (define foo (~rep (~or (~seq 'a 'b) (~seq 'a (~seq 'b 'a))))) (match "" foo) (match "ab" foo) (match "aba" foo) (match "ababa" foo) (match "abaaba" foo) (match "abaaaba" foo)

12. x' == (lambda (k) (k x)) (lambda (x) E)' == (lambda (k) (k (lambda (x) E'))) (E1 E2)' == (lambda (k) (E1' (lambda (x1) (E2' (lambda (x2) (k (x1 x2)))))))