;; Metacircular evaluator for a Scheme subset with the built-in
;; functions: quote, if, set!, define, eq?, lambda, load, car, cdr,
;; cons, number?, pair?, string?, +, -, *, /, =, the built-in symbol
;; null, constants #t, #f , #oef and primitive datatypes symbols,
;; numbers, strings and pairs.  Tim Finin, finin@umbc.edu, May 2010.

(require scheme/mpair)

(define (mceval exp (env global-env))
  ;; evaluate expression exp in environment env
  (cond ((or (number? exp) (string? exp) (boolean? exp)(eof-object? exp)) exp)
        ((symbol? exp) (lookup exp env))
	((eq? exp eof) eof)
	((not (pair? exp)) (error "mceval: Unknown expression type" exp))
        ((eq? (first exp) 'quote) (second exp))
        ((eq? (first exp) 'if) 
         (if (mceval (second exp) env)
             (mceval (third exp) env)
             (mceval (fourth exp) env)))
        ((eq? (first exp) 'set!)
         (mcset (second exp) (mceval (third exp) env) env))
        ((eq? (first exp) 'define)
         (if (pair? (second exp))
             (mcdefine (caadr exp)
                       (list 'LAMBDA (cdadr exp) (cddr exp) env)
		       env)
             (mcdefine (second exp) (mceval (third exp) env) env)))
        ((eq? (first exp) 'lambda)
         (list 'LAMBDA (second exp) (cddr exp) env))
	((eq? (first exp) 'load) (call-with-input-file (second exp) mcloader))
        (else (mcapply (mceval (first exp) env)
                       (map (lambda (x)(mceval x env)) (cdr exp))))))

(define (mceval-seq lst env)
  ;; eval list of expressions lst in environment env, returning last value
  (last (map (lambda (x) (mceval x env)) lst)))

(define (mcapply proc args)
  ;; apply procedure proc to arguments args
  (cond ((procedure? proc) (apply proc args))
	((and (pair? proc) (eq? (first proc) 'LAMBDA))
         (mceval-seq (third proc) 
                     (cons (mmap mcons (l2ml (second proc)) (l2ml args)) (fourth proc))))
        (else (error "mcapply: Unknown procedure type" proc))))

(define (lookup var env)
  ;; return value of variable var in environment env
  (cond ((null? env) (error "unbound variable" var))
        ((massoc var (first env))
         (mcdr (massoc var (first env))))
        (else (lookup var (rest env)))))
      
(define (mcdefine var val env)
  ;; define variable var in environment env, gving it value val
  (printf "(mcdefine ~s ~s ~s)~n" var val env)
  (let ((frame (first env)))
    (if (massoc var frame)
        (set-mcdr! (massoc var frame) val)
        (set-mcdr! (mlast-pair frame)
                   (mcons (mcons var val) null))))
  (void))

(define (mlast-pair ml)
  ;; like last-pair but for mlists: returns last mpair of the mlist
  (if (null? (mcdr ml)) 
      ml 
      (mlast-pair (mcdr ml))))

(define (mcset var val env)
  ;; set variable var to value val in environment env
  (cond ((null? env) (error "Unbound variable (set) " var))
        ((massoc var (first env))
         (set-mcdr! (massoc var (first env)) val)
         (void))
        (else (lookup var (rest env)))))

(define (mcloader file)
  ;; read and mceval expressions in file w.r.t. global-env
  (if (eq? eof (mceval (read file)))
      (void)
      (mcloader file)))

(define (mcscheme)
  ;; mcscheme read-eval-print loop
  (printf "mcscheme> ")
  (mcprint (mceval (read) global-env))
  (mcscheme))

(define (mcprint x) 
  ;; print x iff it is not void
  (or (void? x) (printf "~s~n" x)))

(define (l2ml l)
  ;; takes a list and returns an mlist
  (if (null? l) l (mcons (car l) (l2ml (cdr l)))))

(define (error msg . args) 
  ;; print an error message, return #<void>
  (printf "MCSCHEME ERROR: ~a ~s.~n" msg args) 
  (void))

;; define these primitives using their Scheme counterparts
(define builtins (l2ml '(car cdr cons number? pair? string? eq? + - * / =)))

;; intialize global environment
(define global-env (list (mmap mcons builtins (mmap eval builtins))))

"meta-circular scheme interpreter, (mcscheme) to start, ^C to leave"