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

;;;(load "values.scm")

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

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

(define (s1-evaln program vars comps expr k)
  (cond
   ((con-expr? expr)
    (k (con-expr->datum expr)))
   ((var-expr? expr)
    ((var-lookup vars comps (var-expr->name expr)) k))
   ((if-expr? expr)
    (s1-evaln
     program vars comps (if-expr->test expr)
     (lambda (b)
       (if b
	   (s1-evaln program vars comps (if-expr->then expr) k)
	   (s1-evaln program vars comps (if-expr->else expr) k)))))
   ((call-expr? expr)
    (let ((comps (map (lambda (expr)
		       (lambda (k)
			 (s1-evaln program vars comps e k)))
		     (call-expr->args expr))))
      (s1-apply program (call-expr->name expr) comps k)))
   ((op-expr? expr)
    (s1-eval*
     program vars comps (op-expr->args expr)
     (lambda (args)
       (s1-apply-primitive (op-expr->name expr) args k))))
   ((lambda-expr? expr)
    (k (lambda (x)
	 (lambda (k)
	   (s1-evaln
	    program
	    (cons (lambda-expr->formal expr) vars)
	    (cons x comps)
	    (lambda-expr->body expr)
	    k)))))
   ((apply-expr? expr)
    (s1-evaln
     program vars comps (apply-expr->rator expr)
     (lambda (rator)
       (let ((comp (lambda (k)
		     (s1-evaln program vars comps (apply-expr->rand expr) k))))
	 ((rator comp) k)))))
   (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*))))
    (else 'UNDEFINED-PRIMITIVE)))

(define (s1-evaln* program vars comps exprs k)
  (if (pair? exprs)
      (s1-evaln program vars comps (car exprs)
	       (lambda (v)
		 (s1-evaln* program vars comps (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))

(define (unitc x)
  (lambda (k) (k x)))