(ql:quickload "lisp-unit")

(defpackage :compiler
  (:use :common-lisp :lisp-unit))
(in-package :compiler)

(setq *print-failures* t)

(defvar *primops*)
(setq *primops* '(car cdr cons atom progn reverse-list))

(defun process-quoted (exp)
  (if (atom exp)
	  (if exp (if (numberp exp) (list 'number exp) (list 'symbol exp)) '(list 0))
	  (list 'list (process-quoted (cdr exp)) (process-quoted (car exp)))))

(define-test process-quoted
	(assert-equal '(number 5) (process-quoted '5))
  (assert-equal '(list 0) (process-quoted '()))
  (assert-equal '(symbol foo) (process-quoted 'foo))
  (assert-equal
   '(list (list (list 0) (symbol foo)) (number 5))
   (process-quoted '(5 foo)))
  (assert-equal
   '(list (list 0) (list (list 0) (list (list 0) (number 5))))
   (process-quoted '(((5))))))

(defun process-proc (func-name func-args func-body env)
  (process-toplevel func-body (append (cons func-name (reverse func-args)) env)))

(defun rest-of-funcall (func args)
  (if (atom args) func (list 'more (rest-of-funcall func (cdr args)) (car args))))

(defun process-funcall (func-name func-args env)
  (let* ((prim-idx (position func-name *primops*))
		 (processed-args (mapcar #'(lambda (exp) (process-toplevel exp env)) func-args)))
	(if (numberp prim-idx)
		(list 'call (rest-of-funcall (list func-name nil) (cdr processed-args)) (car processed-args))
		(let ((final-args (append processed-args (list (process-toplevel func-name env)))))
		  (list 'call (rest-of-funcall '(funcall nil) (cdr final-args)) (car final-args))))))

(defun process-toplevel (exp env)
  (if (atom exp)
	  (if (numberp exp)
		  (list 'number exp)
		  (cond
			((equal exp 't)   '(symbol t))
			((equal exp 'nil) '(list 0))
			(t (let ((idx (position exp env)))
				 (if (numberp idx)
					 (list 'var (- -1 idx))
					 (error "Variable ~a not in environment" exp))))))
	  (let ((func (car exp)))
			(cond
			  ((equal func 'quote) (process-quoted (cadr exp)))
			  ((equal func 'lambda) (destructuring-bind (func-name func-args func-body) (cdr exp)
									  (list 'proc (process-proc func-name func-args func-body env))))
			  ((equal func 'if) (destructuring-bind (if-cond if-then if-else) (mapcar #'(lambda (exp) (process-toplevel exp env)) (cdr exp)) (list 'if (list 'list if-else if-then) if-cond)))
			  (t (process-funcall func (cdr exp) env))
			  ))))

(define-test process-toplevel-quote
  (assert-equal '(number 5) (process-toplevel '(quote 5) ())))

(define-test process-toplevel-if
  (assert-equal
   '(if (list (symbol x) (list (list (list 0) (number 3)) (number 2))) (symbol t))
   (process-toplevel '(if t '(2 3) 'x) ())))

(define-test process-toplevel-cdr
  (assert-equal
   '(call (car nil) (list (list (list 0) (number 2)) (number 1)))
   (process-toplevel '(car '(1 2)) ())))

(define-test process-toplevel-lambda
  (assert-equal
   '(proc (var -2))
   (process-toplevel '(lambda id (x) x) ())))

(define-test process-toplevel-funcall
  (assert-equal
   '(call (more (funcall nil) (proc (var -2))) (number 5))
   (process-toplevel '((lambda id (x) x) 5) ())))

(define-test process-toplevel-append
  (assert-equal
   '(proc (if (list (call (more (cons nil) (call (more (more (funcall nil) (var -1)) (var -2)) (call (cdr nil) (var -3)))) (call (car nil) (var -3))) (var -2)) (call (atom nil) (var -3))))
   (process-toplevel '(lambda append (x y) (if (atom x) y (cons (car x) (append (cdr x) y)))) ())
   ))

(define-test process-toplevel-append-call
  (assert-equal
   '(call (more (more (funcall nil) (proc (if (list (call (more (cons nil) (call (more (more (funcall nil) (var -1)) (var -2)) (call (cdr nil) (var -3)))) (call (car nil) (var -3))) (var -2)) (call (atom nil) (var -3))))) (list (list (list (list 0) (symbol f)) (symbol e)) (symbol d))) (list (list (list (list 0) (symbol c)) (symbol b)) (symbol a)))
   (process-toplevel '((lambda append (x y) (if (atom x) y (cons (car x) (append (cdr x) y)))) '(a b c) '(d e f)) ())))

; (run-tests)

; read a sexp, process it, print the result
(prin1 (process-toplevel (read) ()))