;; Metacircular evaluator for a Scheme subset with the built-in
;; functions: quote, if, set!, define, eq?, lambda, load, car, cdr,
;; cons, number?, pair?, string?, +, -, *, /, =, print, 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 dynamic_scope #f)

(define (mceval exp 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)) (mcerror "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))
		       env))))

(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 env)
  ;; 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)) 
                           (if dynamic_scope env (fourth proc)))))
        (else (mcerror "mcapply: Unknown procedure type" proc))))


(define (lookup var env)
  ;; return value of variable var in environment env
  (cond ((null? env) (mcerror "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
  (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) (mcerror "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) global-env))
      (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 (mcerror msg  args) 
  ;; print an error message, return #<void>
  (printf "MCERROR: ~a ~s.~n" msg args) 
  (void))

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

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

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