(in-package "MEVAL")

(defvar *rl* nil)



(defun eval-m (expr env)
  (eval (expand-macro expr env) env))


(defun eval (expr env)
  (let* ((res nil))
    
;    (format t "eval:expr = ~S~%" (funarg-chop expr))
    (setf res
          (cond ((numberp expr) expr)
                ((atom expr) (eval-atom expr env))
                (t (eval-list expr env))))
;    (format t "eval:result = ~S~%" (funarg-chop res))
    res))

(defun eval-atom (expr env)

  (let ((erg (env-assoc expr env)))
    (if (eq (car erg) '&empty)
        (get-symbol-value expr)
      (cdr erg))))

(defun env-assoc (atm env)
  (do
      ((p env (cdr p))
       (pold nil p))
      ((or (null p) (eq (caar p) atm))
       (cond ((null p) (cons '&empty pold))
             (t (car p))))))

; set-symbol-value und get-symbol-value hier ist provisorisch. muss in cons-pack.lisp umdefiniert werden

(defun set-symbol-value (atm val)
  (setf (symbol-value atm) val))

(defun get-symbol-value (atm)
  (symbol-value atm))


(defun set-symbol-function (atm fun)
  (setf (get atm '&my-symbol-function atm) fun))

(defun get-symbol-function (atm)
  (get atm '&my-symbol-function atm))

;
;

(defun eval-list (expr env)

  (let ((head (car expr))
        (rest (cdr expr)))
    (cond ((eq head 'cond) (eval-cond rest env))
          ((eq head 'quote) (car rest))

          ((eq head 'function) (make-funarg (car rest) env))

          ((eq head 'lambda) (eval-lambda expr env))

          ((eq head 'labels) (eval-labels rest env))

          ((eq head 'let) (eval-let rest env))

          ((eq head 'setq) (eval-setq rest env))

          ((eq head 'defun) (eval-defun rest env))
          
          ((eq head 'defmacro) (eval-defmacro rest env))

          ((eq head 'progn) (eval-progn rest env))

          ((eq head 'do) (eval-do rest env))
          
          ((eq head 'do-until) (eval-do-until rest env))

          ((eq head 'funcall) (eval-funcall rest env))

          ((eq head 'and) (eval-and rest env))

          ((eq head 'or) (eval-or rest env))
          
          ((is-expr-fun head) (eval-expr-fun head rest env))
          ((is-list-fun head) (eval-list-fun head rest env))
          
          ((atom head) (eval-atom-head head rest env))
          (t (error "eval-list: wrong list header")))))



(defun make-funarg (fun env)
  (list 'funarg fun env))


(defun eval-atom-head (head rest env)
;  (format t "~%~S : ~S ~%" head rest)
;  (format t "~%~S~%" (funarg-chop env))
;  (format t "eval-atom-head:~S~%" (funarg-chop (eval head env)))
  (let ((fn (env-assoc head env))
        (fn-expr))
    (setf fn-expr
          (cond ((eq (car fn) '&empty)
                 (get-symbol-function head))
                (t (cdr fn))))
    (eval (cons fn-expr rest) env)))

(defun protect-quote (args)
  (do ((args1 args (cdr args1))
       (res nil (cons (list 'quote (car args1)) res)))
      ((null args1) (reverse res))))



(defun eval-labels (rest env)
  (let ((env-new env)
        (res nil)
        (result nil)
        (env-end nil))
    (dolist (def (car rest))
      (setf env-new (cons (cons (car def)  nil) env-new)))
    (dolist (def (car rest))
;    (format t "~%~S~%" def)
      (setf res (cons (make-funarg (list 'lambda (car (cdr def)) (car (cdr (cdr def)))) env-new) res)))
;   (format t "~%~S~%" env-new)
    (setf env-end env-new)
    (dolist (defval res)
      (rplacd (car env-end) defval)
      (setf env-end (cdr env-end)))
;   (format t "~%~S~%" (funarg-chop env-new))
    (dolist (form (cdr rest))
      (setf result (eval form env-new)))
    result))

(defun eval-let (rest env)
  (let ((var-term nil)
        (vars nil)
        (vals nil))
;    (format t "rest = ~S ~%" rest)
    (setf var-term (car rest))
    (dolist (x var-term)
      (cond ((null (cdr x))
             (setf vars (cons (car x) vars))
             (setf vals (cons nil vals)))
            (t 
             (setf vars (cons (car x) vars))
             (setf vals (cons (cadr x) vals)))))
;    (format t "vars = ~S vals = ~S ~%" vars vals)
    (eval (append (list (list 'lambda vars (cons 'progn (cdr rest)))) vals) env)))


(defun eval-setq (rest env)
  (let ((val (eval (cadr rest) env))
        (pair (env-assoc (car rest) env)))
    (if (not (eq (car pair) '&empty))
        (progn (rplacd pair val)
          val)
      (set-symbol-value (car rest) val))))

(defun eval-defun (rest env)
  (set-symbol-function (car rest)
                       (make-funarg (list 'lambda (cadr rest) (caddr rest)) env)))

(defun eval-defmacro (rest env)
  (macro-transformer-setq (car rest)
                          (cons (list 'lambda (cadr rest) (caddr rest)) env)))


(defun eval-progn (rest env)
  (let ((res nil))
    (dolist (x rest)
      (setf res (eval x env)))
    res))


(defun eval-do (rest env)
  (let ((pre (car rest))
        (tst-res (cadr rest))
        (body (cddr rest))
        (new-expr nil)
        (assign nil)
        (update nil))
    (dolist (x pre)
      (setf assign (cons (list (car x) (cadr x)) assign)))
    (dolist (x pre)
      (setf update (cons (list 'setq (car x) (caddr x)) update)))
    (setf body (append body update))
    (setf new-expr (append (list 'do-until tst-res) body))
    (setf new-expr (list 'let assign new-expr))
    (eval new-expr env)))

(defun eval-do-until (rest env)
  (let ((tst (caar rest))
        (res (cadar rest))
        (body (cons 'progn (cdr rest))))
    (do ()
        ((eval tst env) (eval res env))
      (eval body env))))


(defun eval-funcall (rest env)
  (let ((fval (eval (car rest) env))
        (argl (list-eval (cdr rest) env)))
    (eval (cons fval argl) env)))


(defun eval-and (rest env)
  (labels ((eval-and-1 (rest env acc)
             (if (null rest)
                 acc
               (let ((v1 (eval (car rest) env)))
                 (if v1
                     (eval-and-1 (cdr rest) env v1)
                   nil))))) (eval-and-1 rest env nil)))

(defun eval-or (rest env)
  (if (null rest)
      nil
    (let ((v1 (eval (car rest) env)))
      (if v1
          v1
        (eval-or (cdr rest) env)))))


(defun eval-cond (rest env)
  (let ((res nil))
    (dolist (cond-line rest)
      (if (not (null (eval (car cond-line) env)))
          (do ((cond-expr (cdr cond-line) (cdr cond-expr)))
              ((null cond-expr) (return-from eval-cond res))
            (setf res (eval (car cond-expr) env)))))
    (error "eval-cond:run out of conditions")))


(defun eval-lambda (expr env)

  (list 'funarg expr env))

(defun is-expr-fun (head)

  (member head '(+ - * / = <= >= < > null cons car cdr atom numberp not listp list eq equal)))

(defun is-list-fun (head)

  (listp head))


(defun eval-expr-fun (head rest env)
  
  (let ((args (list-eval rest env)))
    (cond ((eq head 'cons)
           (cl:apply 'cons args))
          ((eq head 'list)
           (cl:apply 'list args))
          (t (cl:apply head args)))))


(defun eval-list-fun (head rest env)
  (progn
;    (format t "head = ~S rest = ~S ~%" head rest)
    (cond ((eq (car head) 'lambda) (eval-lambda-list (cdr head) rest env))
          ((eq (car head) 'funarg) (eval-funarg (cdr head) rest env))
          (t (error "eval-list-fun: case not implemented")))))


(defun apply (fn args env)
  (cond ((listp fn)
         (cond ((eq (car fn) 'lambda) (apply-lambda (cdr fn) args env))
               ((eq (car fn) 'funarg) (apply-funarg (cdr fn) args env))
                (t (apply (eval fn env) args env))))
         ((atom fn)
          (let ((fn1 (env-assoc fn env))
                (fn-expr))
            (setf fn-expr
                  (cond ((eq (car fn1) '&empty)
                         (get-symbol-function fn))
                        (t (cdr fn1))))
            (if (not (is-macro fn-expr))
                (apply fn-expr args env)
              (error "apply: try to apply macro"))))
         (t (error "apply: case not implemented"))))


(defun apply-lambda (lambda-rest args env)
  (let ((new-env (env-bind (car lambda-rest) args env)))
    (eval (car (cdr lambda-rest)) new-env)))



(defun eval-lambda-list (lambda-rest args env)

  (let ((new-env (env-bind (car lambda-rest) (list-eval args env) env)))
;    (format t "~S / " (funarg-chop new-env))
    (eval (car (cdr lambda-rest)) new-env)))

(defun list-eval (args env)
  (let ((acc nil))   
    (dolist (x args) (setf acc (cons (eval x env) acc)))
    (reverse acc)))

(defun env-bind (vars vals old-env)
  (do
      ((vars-akt vars (cdr vars-akt))
       (vals-akt vals (cdr vals-akt))
       (res old-env old-env))
      ((or (null vars-akt)
           (eq (car vars-akt) '&rest))
       (if (not (null vars-akt))
         (push (cons (cadr vars-akt)
                     vals-akt) old-env)
         old-env))
    (push (cons (car vars-akt) (car vals-akt)) old-env)))


(defun eval-funarg (funarg-rest args env)
  (apply-funarg funarg-rest (list-eval args env) env))


(defun apply-funarg (funarg-rest args env)
  (apply (car funarg-rest) args (car (cdr funarg-rest))))





(defun funarg-chop (e)
  (cond ((atom e) e)
        ((eq (car e) 'FUNARG) (list (car e) (car (cdr e))))
        (t (cons (funarg-chop (car e)) (funarg-chop (cdr e))))))




(defun main ()

  (let ((global-env (list (cons t t) (cons nil nil))))
    (loop
     (format t ">")
     (let ((r (read-from-string (read-line)))
           (e nil))
       (if (equal r '(quit))
           (return-from main nil))
       (setf e (eval-m r global-env))
       (format t "~%~%macro-transformers = ~S~%" *macro-transformers*)
       (format t "~%~%res = ~S~%~%" (funarg-chop e))))))