;;; Simple Scheme expression evaluator,
;;; with extensive collection of primitive procedures,
;;; and assignments, lambda expressions, procedure calls, 
;;; and definitions, using static scope rules.
;;; (But without explicit let- or let*-expressions.)
;;; Environments are lists of frames; frames are lists 
;;; of (var . val) pairs, innermost frame at front.
;;; Intermediate explicit control version, using CPS,
;;; based on EOPL, Fig. 9.2.2 (see later versions).

(load "environments.s")

; Evaluate expression exp in environment env 
;
(define (mc-eval exp env k)
  (cond ((constant? exp) (k exp))
        ((quotation? exp) (k (quoted-arg exp)))
        ((variable? exp) (k  (get-var-value exp env)))
        ((function? exp) (k (make-procedure exp env)))
        ((conditional? exp) (eval-if exp env k))
        ((definition? exp) (install-definition exp env k))
        ((assignment? exp) (do-assignment exp env k))
        ((application? exp) 
         (mc-eval (operator exp) env
                  (lambda (proc)
                    (mc-eval-args (operands exp) env
                                  (lambda (args) (mc-apply proc args k))))))
        (else (error "invalid expression:" exp))))

; Constants: number
;
(define constant? number?)

; Quotations: ('quote expression)
;
(define (quotation? exp) (and (pair? exp) (eq? (car exp) 'quote)))
(define quoted-arg cadr)

; Variables: symbol
;
(define variable? symbol?)

; Functions (lambda-expressions): ('lambda parameters exp ...)
;
(define (function? exp) (and (pair? exp) (eq? (car exp) 'lambda)))
(define fn-parameters cadr)
(define fn-body cddr)

; Procedures: ('procedure parameters body environment)
;
(define (xprocedure? proc) (and (pair? proc) (eq? (car proc) 'procedure)))
(define (make-procedure lambda-expr env) 
  (list 'procedure (fn-parameters lambda-expr) (fn-body lambda-expr) env))
(define proc-parameters cadr)
(define proc-body caddr)
(define proc-env cadddr)

; Conditionals: ('if condition consequent alternative)
;
(define (conditional? exp) (and (pair? exp) (eq? (car exp) 'if)))
(define condition cadr)
(define consequent caddr)
(define alternative cadddr)
(define (true? val) (eq? val #t))

(define (eval-if exp env k)
  (mc-eval (condition exp) env
           (lambda (test)
             (if (true? test)
                 (mc-eval (consequent exp) env k)
                 (mc-eval (alternative exp) env k)))))

; Definitions: ('define var exp) or ('define (function param ...) exp ...)
;
(define (definition? exp)
  (and (pair? exp) (eq? (car exp) 'define)))
(define (definition-var exp)
  (if (variable? (cadr exp)) (cadr exp) (caadr exp)))
(define (definition-value exp) 
  (if (variable? (cadr exp))
      (caddr exp)
      (cons 'lambda
            (cons (cdadr exp)     ; parameters
                  (cddr exp)))))  ; body

(define (install-definition exp env k)
  (mc-eval (definition-value exp) env 
		   (lambda (val) (k (define-var! (definition-var exp) val env)))))

(define (define-var! var val env)
  (let ((b (binding-in-frame var (first-frame env))))
    (if (pair? b)
        (set-binding-value! b val)
        (set-first-frame!
         env
         (extend-frame (make-binding var val) (first-frame env))))
    var)) ; return defined variable

; Assignments: ('set! var exp)
;
(define (assignment? exp)
  (and (pair? exp) (eq? (car exp) 'set!)))
(define assignment-var cadr)
(define assignment-value caddr)

(define (do-assignment exp env k)
  (mc-eval (assignment-value exp) env
           (lambda (val) (set-var-value! (assignment-var exp) val env)
			             (k val)))) ; return new value

; Applications (procedure calls): (operator operand ... )
;
(define application? pair?)
(define operator car)
(define operands cdr)

; Evaluate a list of procedure call arguments
;
(define (mc-eval-args args env k)
  (if (null? args)
      (k '())
      (mc-eval (car args) env
               (lambda (val)
                 (mc-eval-args (cdr args) env
                               (lambda (vals) (k (cons val vals))))))))

; Apply procedure proc to (evaluated) arguments args
;
(define (mc-apply proc args k)
  (cond ((primitive? proc)      ; primitive procedure
         (k (apply-primitive proc args)))
        ((xprocedure? proc)     ; compound procedure
         (eval-sequence (proc-body proc)
                        (extend-env (proc-parameters proc) 
                                    args 
                                    (proc-env proc))
                        k))
        (else (error "invalid operator:" proc))))

; Evaluate a nonempty sequence of expressions
; 
(define (eval-sequence exps env k)
  (if (null? (cdr exps))
      (mc-eval (car exps) env k)
      (mc-eval (car exps) env
               (lambda (v)
                 (eval-sequence (cdr exps) env k)))))


; Primitive (built-in) operations: ('primitive opcode)
;
(define (primitive? proc) 
  (and (pair? proc) (eq? (car proc) 'primitive)))
(define (make-primitive opcode) (list 'primitive opcode))
(define primitive-opcode cadr)

; Apply primitive operation for opcode to args
;
(define (apply-primitive proc args)
  (case (primitive-opcode proc)
    ((+) (+ (car args) (cadr args)))
    ((-) (- (car args) (cadr args)))
    ((*) (* (car args) (cadr args)))
    ((/) (/ (car args) (cadr args)))
    ((=) (= (car args) (cadr args)))
    ((<) (< (car args) (cadr args)))
    ((<=) (<= (car args) (cadr args)))
    ((>) (> (car args) (cadr args)))
    ((>=) (>= (car args) (cadr args)))
    ((car) (car (car args)))
    ((cdr) (cdr (car args)))
    ((cons) (cons (car args) (cadr args)))
    ((list) args)
    ((null?) (null? (car args)))
    ((pair?) (pair? (car args)))
    ((eq?) (eq? (car args) (cadr args)))
    ((equal?) (equal? (car args) (cadr args)))
    ((not) (not (car args)))
    ((and) (error "and not implemented"))
    ((or) (error "or not implemented"))
    ((number?) (number? (car args)))
    ((symbol?) (symbol? (car args)))
    ((boolean?) (boolean? (car args)))
    ((procedure?) (boolean? (car args)))
    (else (error "unimplemented primitive operation:" opcode))))

; User interface: (mc-scheme)
;
(define (init-env)
  (list
   (append (list (cons 'nil '()) (cons '#f #f) (cons '#t #t))
           (map (lambda (var) (cons var (make-primitive var)))
                '(+ - * / = < <= > >= car cdr cons list null? pair? eq? equal?
                    not and or number? symbol? boolean? procedure?)))))

(define global-env (init-env))

(define (mc-scheme)
  (display "mc-eval7==> ")
  (let ((input (read)))
    (if (not (eof-object? input))
        (begin (display (mc-eval input global-env (lambda (v) v))) 
               (newline) 
               (mc-scheme)))))

;;; eof