C311 Fall96. Assignment 8 (solution)

;;
;; C311 Assignment 8
;; CPS Transformation (Registers and Stacks)
;; Due F 11/08/96 @ 5:00pm
;;


(define a-reg  'ignored)
(define v-reg  'ignored)
(define n-reg  'ignored)
(define ls-reg 'ignored)
(define s0-reg 'ignored)
(define s1-reg 'ignored)

; 1. list index

(define list-index
  (lambda (a ls)
    (push! 'final-frame)
    (set! a-reg a)
    (set! ls-reg ls)
    (list-index-cps/reg)))

(define list-index-cps/reg
  (lambda ()
    (cond
      [(null? ls-reg)
       (set! v-reg -1)
       (apply-k/reg)]
      [(eq? (car ls-reg) a-reg)
       (set! v-reg 0)
       (apply-k/reg)]
      [else
	(push! 'listindex-frame)
	(set! a-reg a-reg)
	(set! ls-reg (cdr ls-reg))
	(list-index-cps/reg)])))


; 2. intersection

(define intersection
  (lambda (s0 s1)
    (push! 'final-frame)
    (set! s0-reg s0)
    (set! s1-reg s1)
    (intersection-cps/reg)))

(define intersection-cps/reg
  (lambda ()
    (cond
      [(null? s0-reg)
       (set! v-reg '())
       (apply-k/reg)]
      [(memq (car s0-reg) s1-reg)
       (push! s0-reg)
       (push! 'intersection-frame)
       (set! s0-reg (cdr s0-reg))
       (set! s1-reg s1-reg)
       (intersection-cps/reg)]
      [else
	(set! s0-reg (cdr s0-reg))
	(set! s1-reg s1-reg)
	(intersection-cps/reg)])))


; 3 count-parens

(define count-parens
  (lambda (ls)
    (push! 'final-frame)
    (set! ls-reg ls)
    (count-parens-cps/reg)))

(define count-parens-cps/reg
  (lambda ()
    (cond
      [(null? ls-reg)
       (set! v-reg 2)
       (apply-k/reg)]
      [(list? (car ls-reg))
       (push! ls-reg)
       (push! 'countparens-frame)
       (set! ls-reg (car ls-reg))
       (count-parens-cps/reg)]
      [else
	(set! ls-reg (cdr ls-reg))
	(count-parens-cps/reg)])))


; 4 depth

(define depth
  (lambda (ls)
    (push! 'final-frame)
    (set! ls-reg ls)
    (depth-cps/reg)))

(define depth-cps/reg
  (lambda ()
    (cond
      [(null? ls-reg)
       (set! v-reg 1)
       (apply-k/reg)]
      [(pair? ls-reg)
       (push! ls-reg)
       (push! 'depth-frame)
       (set! ls-reg (car ls-reg))
       (depth-cps/reg)]
      [else
	(set! v-reg 0)
       	(apply-k/reg)])))


; vector-index

(define vector-index
  (lambda (a v)
    (push! 'final-frame)
    (set! a-reg a)
    (set! v-reg v)
    (vector-index-cps/reg)))

(define vector-index-cps/reg
  (lambda ()
    (let ([vlen (vector-length v-reg)])
      (letrec ([vindex-hlp-cps/reg
		 (lambda ()
		   (cond
		     [(= vlen n-reg)
		      (set! v-reg -1)
		      (apply-k/reg)]
		     [(eq? (vector-ref v-reg n-reg) a-reg)
		      (set! v-reg n-reg)
		      (apply-k/reg)]
		     [else
		       (set! n-reg (add1 n-reg))
		       (vindex-hlp-cps/reg)]))])
	(set! n-reg 0)
	(vindex-hlp-cps/reg)))))

;;
;; apply-k
;;

(define apply-k/reg
  (lambda ()
    (let ([frame-tag (top)])
      (pop!)
      (case frame-tag
	(listindex-frame
	  (let ([answ v-reg])
	    (if (= answ -1)
		(begin
		  (set! v-reg -1)
		  (apply-k/reg))
		(begin
		  (set! v-reg (add1 answ))
		  (apply-k/reg)))))
	(intersection-frame
	  (let ([v v-reg]
		[s0 (top)])
	    (pop!)
	    (set! v-reg (cons (car s0) v))
	    (apply-k/reg)))
	(countparens-frame
	  (let ([v-car v-reg]
		[ls (top)])
	    (pop!)
	    (push! v-car)
	    (push! 'countparens2-frame)
	    (set! ls-reg (cdr ls))
	    (count-parens-cps/reg)))
	(countparens2-frame
	  (let ([v-cdr v-reg]
		[v-car (top)])
	    (pop!)
	    (set! v-reg  (+ v-car v-cdr))
	    (apply-k/reg)))
	(depth-frame
	  (let ([v-car v-reg]
		[ls  (top)])
	    (pop!)
	    (push! v-car)
	    (push! 'depth2-frame)
	    (set! ls-reg (cdr ls))
	    (depth-cps/reg)))
	(depth2-frame
	  (let ([v-cdr v-reg]
		[v-car (top)])
	    (pop!)
	    (set! v-reg (max (add1 v-car) v-cdr))
	    (apply-k/reg)))
	(final-frame ()
	  v-reg)
	(else (error 'apply-k "invalid continuation ~s" frame))))))


;;
;;  stack
;;

(define empty? 'ignored)
(define push!  'ignored)
(define pop!   'ignored)
(define top    'ignored)
(let ([stack '()])
  (set! empty?
	(lambda ()
		(null? stack)))
  (set! push!
	(lambda (x)
	  (set! stack (cons x stack))))
  (set! pop!
	(lambda ()
	  (if (empty?)
	      (error 'stack-pop "stack is empty")
	      (set! stack (cdr stack)))))
  (set! top
	(lambda ()
	  (if (empty?)
	      (error 'stack-top "stack is empty")
	      (car stack)))))