; 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)
                 (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)
          ;(list 'quote
                       ;(list 'append
                       (append
                          (append
                               (list 'list)
                               ;(list 'quote)
                               ;(list 'nil)
                               ;(list)
                               (list (list 'lambda
                                           outers
                                           (unique-lambda-args-subst (subst-list aargs args body)
                                                                     (append outers aargs))))
                          )
                               ;(list outers)
                               ;outers
                               (mapcar outers (lambda (o) (list 'list ''quote o)))
                               ;(cons 'list outers)
                               ;(mapcar outers eval)
                       )
                       ;)
          ;)
    )
)
;(cons 'list
;    (list (list 'quote 'lambda) 
;          (list 'quote aargs)
;          ;(list 'quote
;                       ;(list 'append
;                       (append
;                          (append
;                               '(list 'list)
;                               (list (list 'lambda
;                                           outers
;                                           (unique-lambda-args-subst (subst-list aargs args body)
;                                                                     (append outers aargs))))
;                          )
;                               ;(list outers)
;                               outers
;                               ;(cons 'list outers)
;                               ;(mapcar outers eval)
;                       )
;                       ;)
;          ;)
;    )
;)
;(cons 'list
;    (list (list 'quote 'lambda) (list 'quote aargs)
;        (list 'quote (append (list (list 'lambda outers
;                      (unique-lambda-args-subst (subst-list aargs args body) (append outers aargs))
;        ))   (list outers)    ))
;    )
;)
;(cons 'list
;    (list (list 'quote 'lambda) (list 'quote aargs)
;        (list 'quote (append (list (list 'lambda outers
;                      (unique-lambda-args-subst (subst-list aargs args body) (append outers aargs))
;        ))   (list (list 'mapcar outers eval))    ))
;    )
;)
                  )

                 (cons (unique-lambda-args-subst hd outers) (unique-lambda-args-subst tl outers))))))

; ./lterp lib.lt macro.lt "(def 'a 'A)" "(def 'b 'B)"  "(unique-lambda-args-subst '(lambda (x y) (Append3Demo x a y)) '(a b))"
; AB( list 'lambda '( x<140192808> y<140192808> ) '( ( lambda ( a b ) ( Append3Demo x<140192808> a y<140192808> ) ) A B ) )

                     

(defun fn (name 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)

         (def name (list 'lambda aargs abody3))))

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

(fn '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))) 

;;;(fn 'inequality '(what)
;;;    '(if (eq what '<)
;;;         (lambda (a b) (< a b))
;;;         (lambda (a b) (> a b))))

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


;   strick@retro:~/lterp$ ./lterp   lib.lt    macro.lt  "(list incr-fn )"
;   ( ( lambda ( n<161689816> ) ( ( lambda ( n<161689816> ) ( lambda ( x<161811312> ) ( Append3Demo x<161811312> n<161689816> ) ) ) n<161689816> ) ) )
;   strick@retro:~/lterp$ ./lterp   lib.lt    macro.lt  "(incr-fn '5)"
;   ( lambda ( x<152673136> ) ( Append3Demo x<152673136> n<152551640> ) )

(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))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  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))))