;;; Simple constant (Scheme) expression evaluator,
;;; with extensive collection of primitive procedures.

;;; (mc-eval exp) returns the result of evaluating the constant expression exp
;;;
(define (mc-eval exp)
  (cond ((constant? exp) exp)
        ((quotation? exp) (quoted-arg exp))
        ((conditional? exp) (eval-if exp))
        ((application? exp) 
         (mc-apply (operator exp)
                   (map mc-eval (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)

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

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

;;; (mc-apply proc args) returns the result of applying procedure proc
;;; to arguments args.
;;;
(define (mc-apply proc args)
  (cond ((primitive? proc)
         (apply-primitive proc args))
        (else (error "invalid procedure for mc-apply" proc))))

; Primitive (built-in) operations
;
(define (primitive? proc) 
  (and (symbol? proc) (memq proc primitives)))

; Apply primitive operations proc to args
;
(define (apply-primitive proc args)
  (case 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)))
    ((square) (* (car args) (car args)))
    ((boolean?) (boolean? (car args)))
    (else (error "unimplemented primitive operation" opcode))))

(define primitives
  '(+ - * / = < <= > >= car cdr cons list null? pair? eq? equal?
      not and or number? symbol? square boolean?))

; User interface: (mc-scheme)
;
(define (mc-scheme)
  (display "mc-eval2==> ")
  (display (mc-eval (read)))
  (newline)
  (mc-scheme))

;;; eof