;;; Simple 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.

; 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))
        ((function? exp) (make-procedure exp env))
        ((conditional? exp) (eval-if exp env))
        ((definition? exp) (install-definition exp env))
        ((assignment? exp) (do-assignment 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?)

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

; 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)
  (define-var! (definition-var exp)
               (mc-eval (definition-value exp) env)
               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 var

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

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

; 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
         (eval-sequence (proc-body proc)
                        (extend-env (proc-parameters proc) 
                                    args 
                                    (proc-env proc))))
        (else (error "invalid operator" proc))))

(define (eval-sequence exps env)
  (cond ((null? (cdr exps)) (mc-eval (car exps) env))
        (else (mc-eval (car exps) env)
              (eval-sequence (cdr exps) env))))

; 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))

; Update environment by changing value bound to variable
;
(define (set-var-value! var value env)
  (let ((b (binding-in-env var env)))
    (if (pair? b)
        (set-binding-value! b value)
        (error "unbound variable" var))))

; 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-eval6==> ")
 (let ((input (read)))
   (if (not (eof-object? input))
       (begin (display (mc-eval input global-env)) 
              (newline) 
              (mc-scheme)))))

;;; eof