;;; call-by-value CPS interpreter
;;; © 1999 Peter Thiemann

;;;(load "values.scm")

(define (s1-int program values)
  (let ((def1 (car program)))
    (s1-apply program (def->name def1) values (lambda (z) z))))

(define (s1-apply program funcname values k)
  (let ((defn (program-lookup program funcname)))
    (s1-eval program (def->formals defn) values (def->body defn) k)))

(define (s1-eval program vars values expr k)
  (cond
   ((con-expr? expr)
    (k (con-expr->datum expr)))
   ((var-expr? expr)
    (k (var-lookup vars values (var-expr->name expr))))
   ((if-expr? expr)
    (s1-eval
     program vars values (if-expr->test expr)
     (lambda (b)
       (if b
	   (s1-eval program vars values (if-expr->then expr) k)
	   (s1-eval program vars values (if-expr->else expr) k)))))
   ((call-expr? expr)
    (s1-eval*
     program vars values (call-expr->args expr)
     (lambda (args)
       (s1-apply program (call-expr->name expr) args k))))
   ((op-expr? expr)
    (s1-eval*
     program vars values (op-expr->args expr)
     (lambda (args)
       (s1-apply-primitive (op-expr->name expr) args k))))
   ((lambda-expr? expr)
    (k (lambda (x)
	 (lambda (k)
	   (s1-eval
	    program
	    (cons (lambda-expr->formal expr) vars)
	    (cons x values)
	    (lambda-expr->body expr)
	    k)))))
   ((apply-expr? expr)
    (s1-eval
     program vars values (apply-expr->rator expr)
     (lambda (rator)
       (s1-eval
	program vars values (apply-expr->rand expr)
	(lambda (rand)
	  ((rator rand) k))))))
   ((reset-expr? expr)
    (k (s1-eval
	program vars values (reset-expr->body expr)
	(lambda (z) z))))
   ((shift-expr? expr)
    (s1-eval program
	     (cons (shift-expr->formal expr) vars)
	     (cons (lambda (y) (lambda (k1) (k1 (k y)))) values)
	     (shift-expr->body expr)
	     (lambda (z) z))
   (else
    'SYNTAX-ERROR)))

(define (s1-apply-primitive name value* k)
  (case name
    ((car) (k (car (car value*))))
    ((cdr) (k (cdr (car value*))))
    ((cons) (k (cons (car value*) (cadr value*))))
    ((pair?) (k (pair? (car value*))))
    ((eq?) (k (eq? (car value*) (cadr value*))))
    ((=) (k (= (car value*) (cadr value*))))
    ((+) (k (+ (car value*) (cadr value*))))
    ((-) (k (- (car value*) (cadr value*))))
    ((*) (k (* (car value*) (cadr value*))))
    ((call/cc) (((car value*) k) k))
    (else 'UNDEFINED-PRIMITIVE)))

(define (s1-eval* program vars values exprs k)
  (if (pair? exprs)
      (s1-eval program vars values (car exprs)
	       (lambda (v)
		 (s1-eval* program vars values (cdr exprs)
			   (lambda (v*)
			     (k (cons v v*))))))
      (k '())))

(define (program-lookup program funcname)
  (if (pair? program)
      (if (eq? funcname (def->name (car program)))
	  (car program)
	  (program-lookup (cdr program) funcname))
      'UNDEFINED-FUNCTION))

(define (var-lookup vars values v)
  (if (pair? vars)
      (if (eq? v (car vars))
	  (car values)
	  (var-lookup (cdr vars) (cdr values) v))
      'UNDEFINED-VARIABLE))