C311 Fall96. Assignment 8 (solution)

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

(define arg1-reg 'ignored)
(define arg2-reg 'ignored)
(define arg3-reg 'ignored)

; 1. list index

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

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


; 2. intersection

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

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


; 3 count-parens

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

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


; 4 depth

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

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


; vector-index

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

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

;;
;; apply-k
;;

(define apply-k/reg
  (lambda ()
    (let ([frame-tag (top)])
      (pop!)
      (case frame-tag
	(listindex-frame
	  (if (= arg1-reg -1)
	      (apply-k/reg)
	      (begin
		(set! arg1-reg (add1 arg1-reg))
		(apply-k/reg))))
	(intersection-frame
	  (let ([s0 (top)])
	    (pop!)
	    (set! arg1-reg (cons (car s0) arg1-reg))
	    (apply-k/reg)))
	(countparens-frame
	  (let ([ls (top)])
	    (pop!)
	    (push! arg1-reg)
	    (push! 'countparens2-frame)
	    (set! arg1-reg (cdr ls))
	    (count-parens-cps/reg)))
	(countparens2-frame
	  (let ([v-car (top)])
	    (pop!)
	    (set! arg1-reg  (+ v-car arg1-reg))
	    (apply-k/reg)))
	(depth-frame
	  (let ([ls  (top)])
	    (pop!)
	    (push! arg1-reg)
	    (push! 'depth2-frame)
	    (set! arg1-reg (cdr ls))
	    (depth-cps/reg)))
	(depth2-frame
	  (let ([v-car (top)])
	    (pop!)
	    (set! arg1-reg (max (add1 v-car) arg1-reg))
	    (apply-k/reg)))
	(final-frame ()
	  arg1-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)))))