; macro processor

(defun defmacro (name args body)
    (let addy (addr (list 'nil))
         aargs (mapcar args (lambda (x) (implode (list x addy))))

         abody (subst-list aargs args body)
         (def name (list 'macro aargs abody))))

(defun macro-subst (tree)
    (if (atomp tree)
        tree
        (let hd (car tree)
             tl (cdr tree)
             (if (atomp hd)
                 (if (defp hd)
                     (let value (eval hd)

                          (if (not (atomp value))
                              (if (eq 'macro (car value))
                                  (let args (cadr value)
                                       body (caddr value)
                                       rbody (subst-list tl args body)
                                       (macro-subst rbody))
                                  (cons (macro-subst (car tree)) (macro-subst (cdr tree))))
                              (cons (macro-subst (car tree)) (macro-subst (cdr tree)))))
                     (cons (macro-subst (car tree)) (macro-subst (cdr tree))))
                 (cons (macro-subst (car tree)) (macro-subst (cdr tree)))))))


(defun _unique-lambda-args-subst (tree outers)
    (if (atomp tree)
        tree
        (let hd (car tree)
             tl (cdr tree)
             (if (eq hd 'lambda)
                 ;then
                 (let args (car tl)
                      body (cadr tl)
                      addy (addr (list 'nil))  ; get a unique number from the (list 'nil)
                      aargs (mapcar args (lambda (x) (implode (list x addy))))

                      (cons 'list
                        (list (list 'quote 'lambda) 
                              (list 'quote aargs)
                              (append
                                 (append (list 'list)
                                         (list (list 'lambda
                                                     outers
                                                     (_unique-lambda-args-subst
                                                         (subst-list aargs args body)
                                                         (append outers aargs)))))
                                  (mapcar outers (lambda (o) (list 'list ''quote o)))))))
                 ;else
                 (cons (_unique-lambda-args-subst hd outers) (_unique-lambda-args-subst tl outers))))))


(defun translate-lexical (args body)
    (let addy (addr (list 'nil))  ; get a unique number from the (list 'nil)
         aargs (mapcar args (lambda (x) (implode (list x addy))))

         abody (subst-list aargs args body)

         abody2 (macro-subst abody)
         abody3 (_unique-lambda-args-subst abody aargs)

         (list 'lambda aargs abody3)))

(defun _defun_lexical (name args body)
         (def name (translate-lexical args body)))

(defun translate-lexical-no-args (body) (translate-lexical 'nil body))
(defun apply-no-args (f) (f))
(def 'run '(nlambda (args) (apply-no-args (translate-lexical-no-args (car args)))))

(defmacro 'macro-demo-swap-append '(x y) '(append y x))

(_defun_lexical 'append3 '(x y z) '(macro-demo-swap-append (macro-demo-swap-append z y) x))

(defmacro 'and '(x y) '(if x y 'nil)) 

(defmacro 'or '(x y) '(let cond x (if cond cond y))) 

(defun Append3Demo (a b c) (append (list a) (list b c)))
(_defun_lexical 'incr-fn '(p q) '(lambda (x) (Append3Demo x p q)))

(def 'quasi
     (nlambda (args)
              (let x (car args)
                   _ (assert (eq 'nil (cdr args)))
                     (if (atomp x)
                         (let xx (explode x)
                              xh (car xx)
                              xt (cdr xx)
                              (if (eq xh ',)
			          (let var (implode xt)
				       val (eval var)
				       val)
				  x))
			  (cons (eval (list 'quasi (car x)))
			        (eval (list 'quasi (cdr x))))))))

(def 'define (nlambda (args)
     (let a (first args)
          b (second args)
          (if (atomp a)
              (define-symbol a  b)
              (define-function a  b)))))

(defun define-symbol (a b) (def a b))
(defun define-function (a b) (_defun_lexical (car a) (cdr a) b))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  TODO -- package

(def 'package
  (nlambda (args)
    (let pname (first args)
         pdepends (second args)
	 prest (cddr args)
	 _ (def pname (list 'package args))
	 ; TODO -- rewrite defuns in prest
	 (mapcar prest 'eval))))