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! (make-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! (make-listindex-frame))
	(set! a-reg a-reg)
	(set! ls-reg (cdr ls-reg))
	(list-index-cps/reg)])))

(define make-listindex-frame
  (lambda ()
    (list 'listindex-frame)))


; 2. intersection

(define intersection
  (lambda (s0 s1)
    (push! (make-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! (make-intersection-frame s0-reg))
       (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)])))

(define make-intersection-frame
  (lambda (s0)
    (list 'intersection-frame s0)))

; 3 count-parens

(define count-parens
  (lambda (ls)
    (push! (make-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! (make-countparens-frame ls-reg))
       (set! ls-reg (car ls-reg))
       (count-parens-cps/reg)]
      [else
	(set! ls-reg (cdr ls-reg))
	(count-parens-cps/reg)])))

(define make-countparens-frame
  (lambda (ls)
    (list 'countparens-frame ls)))

(define make-countparens2-frame
  (lambda (v-car)
    (list 'countparens2-frame v-car)))

; 4 depth

(define depth
  (lambda (ls)
    (push! (make-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! (make-depth-frame ls-reg))
       (set! ls-reg (car ls-reg))
       (depth-cps/reg)]
      [else
	(set! v-reg 0)
       	(apply-k/reg)])))

(define make-depth-frame
  (lambda (ls)
    (list 'depth-frame ls)))

(define make-depth2-frame
  (lambda (v-car)
    (list 'depth2-frame v-car)))

; vector-index

(define vector-index
  (lambda (a v)
    (push! (make-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 (top)])
      (pop!)
      (record-case frame
	(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 (s0)
	  (let ([v v-reg])
	    (set! v-reg (cons (car s0) v))
	    (apply-k/reg)))
	(countparens-frame (ls)
	  (let ([v-car v-reg])
	    (push! (make-countparens2-frame v-car))
	    (set! ls-reg (cdr ls))
	    (count-parens-cps/reg)))
	(countparens2-frame (v-car)
	  (let ([v-cdr v-reg])
	    (set! v-reg  (+ v-car v-cdr))
	    (apply-k/reg)))
	(depth-frame (ls)
	  (let ([v-car v-reg])
	    (push! (make-depth2-frame v-car))
	    (set! ls-reg (cdr ls))
	    (depth-cps/reg)))
	(depth2-frame (v-car)
	  (let ([v-cdr v-reg])
	    (set! v-reg (max (add1 v-car) v-cdr))
	    (apply-k/reg)))
	(final-frame ()
	  v-reg)
	(else (error 'apply-k "invalid continuation ~s" frame))))))

(define make-final-frame
  (lambda ()
    (list 'final-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)))))