;;; Simple (Scheme) expression evaluator,
;;; with extensive collection of primitive procedures,
;;; and let-expressions and environments.
;;; Environments are lists of frames; frames are lists 
;;; of (var . val) pairs, innermost frame at front.
;;; (Subsumed by file eval4.s.)

; Evaluate expression exp in environment env 
;
(define (mc-eval exp env)
  (cond ((constant? exp) exp)
        ((quotation? exp) (quoted-arg exp))
        ((variable? exp) (get-var-value exp env))
        ((conditional? exp) (eval-if exp env))
        ((let? exp) (eval-let exp env))
        ((application? exp) 
         (mc-apply (mc-eval (operator exp) env)
                   (map (lambda (operand) (mc-eval operand env))
                        (operands exp))))
        (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?)

; 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 (eval-if exp env)
  (if (mc-eval (condition exp) env)
      (mc-eval (consequent exp) env)
      (mc-eval (alternative exp) env)))

; Lets: ('let ((var value) ...) expression)
;
(define (let? exp) (and (pair? exp) (eq? (car exp) 'let)))

(define (let-bindings exp) (cadr exp))
(define (let-vars exp) (map car (cadr exp)))
(define (let-values exp) (map cadr (cadr exp)))
(define let-body caddr)

(define (eval-let exp env)
  (mc-eval (let-body exp) 
           (extend-env (let-vars exp) 
                       (map (lambda (exp) (mc-eval exp env)) (let-values exp))
                       env)))

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

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

; Environments: (frame ... )
;
(define make-env cons)
(define first-frame car)
(define rest-frames cdr)
(define set-first-frame! set-car!)

; Get value of variable in environment
;
(define (get-var-value var env)
  (let ((b (binding-in-env var env)))
    (if (pair? b)
        (binding-value b)
        (error "unbound variable" var))))

(define (binding-in-env var env)
  (if (null? env)
      '()
      (let ((b (binding-in-frame var (first-frame env))))
        (if (pair? b)
            b
            (binding-in-env var (rest-frames env))))))

; Extend env by binding values to corresponding variables
;
(define (extend-env vars values env)
  (cons (make-frame vars values) env))

; Frames: ((var . value) ...)

; Make new frame by binding values to corresponding variables
;
(define (make-frame vars values)
  (if (not (= (length vars) (length values)))
      (error "incorrect number of values supplied" values)
      (map make-binding vars values)))

(define extend-frame cons)
(define binding-in-frame assq)

; Bindings: (var . value)
;
(define make-binding cons)
(define binding-var car)        ; only used implicitly in binding-in-frame
(define binding-value cdr)
(define set-binding-value! set-cdr!)

; 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)
    ((+) (apply + args)) ;;; apply is a built-in procedure
    ((-) (apply - args))
    ((*) (apply * args))
    ((/) (apply / 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-eval3==> ")
  (display (mc-eval (read) global-env))
  (newline)
  (mc-scheme))

;;; eof