C311 script8.txt -- 10/22/96

---

REPRESENTATION INDEPENDENT FORM

---

First, our previous version of subst:

> (define subst
    (lambda (new old slst)
      (subst-cps new old slst (lambda (v) v))))

> (define subst-cps
    (lambda (new old slst k)
      (if (null? slst)
        (k '())
        (if (not (pair? (car slst)))
	  (if (eq? (car slst) old)
	    (subst-cps new old (cdr slst)
	      (lambda (v) (k (cons new v))))
	    (subst-cps new old (cdr slst)
	      (lambda (v) (k (cons (car slst) v)))))
	  (subst-cps new old (car slst)
	    (lambda (v)
	      (subst-cps new old (cdr slst)
		(lambda (v1) (k (cons v v1))))))))))

> (subst 'a 'b '(a b c b))
(a a c a)

---

For representation independence, we create a continuation ADT.

Each continuation-maker abstracts over the free variables of the
corresponding lambda expression in the previous version of SUBST-CPS.

+++
> (define make-final-valcont
    (lambda ()
      (lambda (v) v)))

> (define make-subst1
    (lambda (new k)
      (lambda (v)
	(apply-continuation k (cons new v)))))

> (define make-subst2
    (lambda (slst k)
      (lambda (v)
	(apply-continuation k (cons (car slst) v)))))

> (define make-subst3
    (lambda (new old slst k)
      (lambda (v)
	(subst-cps new old (cdr slst)
	  (make-subst1 v k)))))

> (define apply-continuation
    (lambda (k v)
      (k v)))

---

Now we can write a version of SUBST-CPS that is independent of the 
representation of continuations.

> (define subst
    (lambda (new old s)
      (subst-cps new old s (make-final-valcont))))

> (define subst-cps
    (lambda (new old slst k)
      (if (null? slst)
        (apply-continuation k '())
        (if (not (pair? (car slst)))
	  (if (eq? (car slst) old)
	    (subst-cps new old (cdr slst)
	      (make-subst1 new k))
	    (subst-cps new old (cdr slst)
	      (make-subst2 slst k)))
	  (subst-cps new old (car slst)
	    (make-subst3 new old slst k))))))

> (subst 'a 'b '(a b c b))
(a a c a)

---

Next, we change the representation of continuations from procedures to data
structures by redefining the ADT.

+++
> (define make-final-valcont (lambda () '(final-valcont)))
> (define make-subst1 (lambda (new k) (list 'subst1 new k)))
> (define make-subst2 (lambda (slst k) (list 'subst2 slst k)))
> (define make-subst3 (lambda (new old slst k) (list 'subst3 new old slst k)))

> (define apply-continuation
    (lambda (k v)
      (record-case k
	(final-valcont () v)
	(subst1 (new k)
	  (apply-continuation k (cons new v)))
	(subst2 (slst k)
	  (apply-continuation k (cons (car slst) v)))
	(subst3 (new old slst k)
	  (subst-cps new old (cdr slst)
	    (make-subst1 v k)))
	(else (error "Invalid continuation:" k)))))

> (subst 'a 'b '(a b c b))
(a a c a)

+++
The body of each RECORD-CASE clause is lifted directly from the body of the
corresponding lambda expression of the previous representation.

---

Now we do the same thing for a familiar interpreter, with
the standard CPS-conversion first.

> (begin
    (define apply-env
      (lambda (env symbol)
	(record-case env
	  (empty-env ()
	    (error 'empty-env "no association for symbol: ~s" symbol))
	  (extended-env (sym-list val-vector env)
	    (let ((x (memq symbol sym-list)))
	      (if x
		(vector-ref val-vector (- (length sym-list) (length x)))
		(apply-env env symbol))))
	  (else (error 'apply-env "Invalid finite function: ~s" env)))))
    (define the-empty-env
      (list 'empty-env))
    (define extend-env
      (lambda (sym-list val-list env)
	(list 'extended-env sym-list (list->vector val-list) env)))
    (define variable? symbol?)
    (define literal? number?)
    (define app->rator car)
    (define app->rands cdr)
    (define *prim-op-names* '(+ - * add1 sub1))
    (define apply-prim-op
      (lambda (prim-op args)
	(case prim-op
	  ((+) (+ (car args) (cadr args)))
	  ((-) (- (car args) (cadr args)))
	  ((*) (* (car args) (cadr args)))
	  ((add1) (+ (car args) 1))
	  ((sub1) (- (car args) 1))
	  (else (error 'apply-prim-op "Invalid prim-op name: ~s" prim-op)))))
    (define make-prim-proc
      (lambda (prim-op-name)
	(list 'prim-proc prim-op-name)))
    (define init-env 
      (extend-env
	*prim-op-names*
	(map make-prim-proc *prim-op-names*)
	the-empty-env))
    (define decl->var car)
    (define decl->exp cadr)
    (define expand
      (lambda (exp)
	(cond
	  ((literal? exp) (list 'quote exp))
	  ((variable? exp) exp)
	  (else
	    (record-case exp
	      (quote (datum) datum)
	      (let (decls body)
		(let ((vars (map decl->var decls))
		      (exps (map decl->exp decls)))
		  (expand (cons (list 'lambda vars body) exps))))
	      (lambda (formals body)
		(list 'lambda formals (expand body)))
	      (else (map expand exp)))))))
    (define make-closure
      (lambda (formals body env)
	(list 'closure formals body env)))
    (define true-value? (lambda (x) (not (zero? x)))))

> (define eval-exp
    (lambda (exp env k)
      (if (variable? exp) (k (apply-env env exp))
	(record-case exp
	  (quote (datum) (k datum))
	  (if (test-exp then-exp else-exp)
	    (eval-exp test-exp env
	      (lambda (test)
		(if (true-value? test)
		  (eval-exp then-exp env k)
		  (eval-exp else-exp env k)))))
	  (lambda (formals body) (k (make-closure formals body env)))
	  (else (eval-exp (app->rator exp) env
		  (lambda (proc)
		    (eval-rands (app->rands exp) env
		      (lambda (args)
			(apply-proc proc args k))))))))))

> (define eval-rands
    (lambda (rands env k)
      (if (null? rands)
        (k '())
        (eval-exp (car rands) env
          (lambda (first)
            (eval-rands (cdr rands) env
              (lambda (rest)
                (k (cons first rest)))))))))

> (define apply-proc
    (lambda (proc args k)
      (record-case proc
	(prim-proc (prim-op) (k (apply-prim-op prim-op args)))
	(closure (formals body env)
	  (eval-exp body (extend-env formals args env) k))
	(else (error 'apply-proc "Invalid procedure: ~s" proc)))))

> (define run
    (lambda (exp)
      (eval-exp (expand exp) init-env (lambda (x) x))))

> (run '(let ((a 3)) (if 0 (+ 2 3) 4)))

---

Next, representation independent form, with continuations-as-procedures.

> (define eval-exp
    (lambda (exp env k)
      (if (variable? exp) (apply-continuation k (apply-env env exp))
	(record-case exp
	  (quote (datum) (apply-continuation k datum))
	  (if (test-exp then-exp else-exp)
	    (eval-exp test-exp env
	      (make-test-valcont then-exp else-exp env k)))
	  (lambda (formals body)
	    (apply-continuation k (make-closure formals body env)))
	  (else (eval-exp (app->rator exp) env
		  (make-proc-valcont (app->rands exp) env k)))))))

> (define eval-rands
    (lambda (rands env k)
      (if (null? rands)
        (apply-continuation k '())
        (eval-exp (car rands) env
          (make-first-valcont rands env k)))))

> (define apply-proc
    (lambda (proc args k)
      (record-case proc
	(prim-proc (prim-op) 
	  (apply-continuation k (apply-prim-op prim-op args)))
	(closure (formals body env)
	  (eval-exp body (extend-env formals args env) k))
	(else (error 'apply-proc "Invalid procedure: ~s" proc)))))

> (define run
    (lambda (exp)
      (eval-exp (expand exp) init-env (make-final-valcont))))

> (define make-final-valcont
    (lambda ()
      (lambda (final) final)))

> (define make-proc-valcont
    (lambda (rands env k)
      (lambda (proc)
	(eval-rands rands env (make-all-argcont proc k)))))

> (define make-all-argcont
    (lambda (proc k)
      (lambda (all)
	(apply-proc proc all k))))

> (define make-test-valcont
    (lambda (then-exp else-exp env k)
      (lambda (test)
	(if (true-value? test)
          (eval-exp then-exp env k)
          (eval-exp else-exp env k)))))

> (define make-first-valcont
    (lambda (rands env k)    
      (lambda (first)
	(eval-rands (cdr rands) env
	  (make-rest-argcont first k)))))

> (define make-rest-argcont
    (lambda (first k)
      (lambda (rest)
	(apply-continuation k (cons first rest)))))

> (define apply-continuation
    (lambda (k val) 
      (k val)))

> (run '(let ((a 3)) (if 0 (+ 2 3) 4)))

---

Now continuations as data structures.

> (define make-final-valcont (lambda () '(final-valcont)))
> (define make-proc-valcont
    (lambda (rands env k) (list 'proc-valcont rands env k)))
> (define make-all-argcont (lambda (proc k) (list 'all-argcont proc k)))
> (define make-test-valcont
    (lambda (then-exp else-exp env k)
      (list 'test-valcont then-exp else-exp env k)))
> (define make-first-valcont
    (lambda (rands env k) (list 'first-valcont rands env k)))
> (define make-rest-argcont (lambda (first k) (list 'rest-argcont first k)))

> (define apply-continuation
    (lambda (k val)
      (record-case k     
	(final-valcont ()
	  (let ((final val))
	    final))
	(proc-valcont (rands env k)
	  (let ((proc val))
	    (eval-rands rands env (make-all-argcont proc k))))
	(all-argcont (proc k) 
	  (let ((all val))
	    (apply-proc proc all k)))
	(test-valcont (then-exp else-exp env k)
	  (let ((test val))
	    (if (true-value? test)
              (eval-exp then-exp env k)
              (eval-exp else-exp env k))))
	(first-valcont (rands env k)
	  (let ((first val))
	    (eval-rands (cdr rands) env
	      (make-rest-argcont first k))))
	(rest-argcont (first k)
	  (let ((rest val))
	    (apply-continuation k (cons first rest)))))))

> (run '(let ((a 3)) (if 0 (+ 2 3) 4)))

---

As a first step towards continuations, we introduce an abort procedure:

> (define apply-proc
    (lambda (proc args k)
      (record-case proc
	(prim-proc (prim-op)
	  (apply-continuation k (apply-prim-op prim-op args)))
	(closure (formals body env)
	  (eval-exp body (extend-env formals args env) k))
	(abort () (apply-continuation (make-final-valcont) (car args)))
	(else (error 'apply-proc "Invalid procedure: ~s" proc)))))

> (define init-env (extend-env '(abort) '((abort)) init-env))

> (run '(+ 3 (* (abort 4) 5)))
4

> (define make-continuation (lambda (cont) (list 'continuation cont)))

> (define apply-proc
    (lambda (proc args k)
      (record-case proc
	(prim-proc (prim-op)
	  (apply-continuation k (apply-prim-op prim-op args)))
	(closure (formals body env)
	  (eval-exp body (extend-env formals args env) k))
	(abort ()
	  (apply-continuation final-valcont (car args)))
	(continuation (cont)
	  (apply-continuation cont (car args)))
	(else (error apply-proc "Invalid procedure: ~s" proc)))))

> (define eval-exp
    (lambda (exp env k)
      (if (variable? exp) (apply-continuation k (apply-env env exp))
	(record-case exp
	  (quote (datum) (apply-continuation k datum))
	  (if (test-exp then-exp else-exp)
	    (eval-exp test-exp env
	      (make-test-valcont then-exp else-exp env k)))
	  (lambda (formals body)
	    (apply-continuation k (make-closure formals body env)))
	  (letcont (var body)  ; NEW CLAUSE
	    (eval-exp body 
	      (extend-env
		(list var)
		(list (make-continuation k))
		env)
	      k))
	  (else (eval-exp (app->rator exp) env
		  (make-proc-valcont (app->rands exp) env k)))))))

> (define call/cc (lambda () '(call/cc)))

> (define apply-proc
    (lambda (proc args k)
      (record-case proc
	(prim-proc (prim-op)
	  (apply-continuation k (apply-prim-op prim-op args)))
	(closure (formals body env)
	  (eval-exp body (extend-env formals args env) k))
	(continuation (cont) 
	  (apply-continuation cont (car args)))
	(call/cc () 
	  (apply-proc
	    (car args)
	    (list (make-continuation k))
	    k))
	(else (error 'apply-proc "Invalid Procedure: ~s" proc)))))

> (define init-env (extend-env '(call/cc) '((call/cc)) init-env))

> (run '(+ 2 (call/cc (lambda (k) (* 3 (k 4))))))
6

---

Uses of CALL/CC

+++
A break debugging facility is the simplest use of first-class continuations.

> (define top-k 'ignored)
> (call/cc
    (lambda (k)
      (set! top-k k)))
> (define continue
    (lambda ()
      "no break to continue"))
> (define break
    (lambda (v)
      (call/cc
	(lambda (k)
	  (set! continue k)
	  (top-k v)))))
> (+ (break 'break-one) (break 'break-two))
break-two
> (continue 3)
break-one
> (continue 2)
5

---

Other uses of first-class continuations:

- breadth-first search

- coroutines (EOPL section 9.4, not responsible for)

- multi-tasking

- exception handling

---

Java exception syntax:

throw new-exception

try {
  /* try block */
} catch (ExceptionType e1) {
  /* catch statement 1 */
} catch (ExceptionType e2) {
  /* cath statement 2 */
...
} finally {
  /* finalization code */
}

---

To see how this may be implemented in Scheme, we first need DYNAMIC-WIND to
implement FLUID-LET properly.

  (DYNAMIC-WIND prelude-thunk body-thunk postlude-thunk)

usage examples: robots, files

implementation in section 9.5: not responsible for, can be simpler


(fluid-let ((var exp)) body) ==>

  (let ((var^ exp))
    (let ((swap (lambda ()
		  (let ((temp var))
		    (set! var var^)
		    (set! var^ temp)))))
      (dynamic-wind swap (lambda () body) swap)))

Usage examples: binding I/O parameters (actually, Chez Scheme uses
parameters instead), Java-style FINALLY clause.

---

(define make-parameter ; doesn't have Chez Scheme's guards
  (lambda (v)
    (lambda args
      (if (null? args)
	v
	(set! v (car args))))))

Exercise: define (PARAMIZE param value thunk)

---

Java-style try in Scheme:

(define bad-input-exn (lambda (input) (list 'bad-input-exn input)))

(try
  (lambda () (raise (make-bad-input-exn "junk")))
  bad-input-exn?
  (lambda (input)
    (printf "Bad input: ~s~n" input)))

(define raise
  (lambda (v)
    (error "Unhandled exception:" v)))

(define try
  (lambda (body-thunk guard-proc handler-proc)
    (call/cc
      (lambda (k)
	(fluid-let ((raise (let ((outer-raise raise))
			     (lambda (v)
			       (if (guard-proc v)
				 (k (handler-proc v))
				 (outer-raise v))))))
	  (body-thunk))))))

---

END

---