;;ilasm compiler
;;Alex 'killer_storm' Mizrahi, 2005

(defun dispatch-form (form bindings)
  (if (atom form)
      (load-atom form bindings)
    (process-form (car form) (cdr form) bindings)))

(defparameter *il-commands* nil)
(defparameter *locals* nil)
(defparameter *function-signatures* nil)

(defun il-emit (&rest params)
  (setq *il-commands* (append *il-commands*
			      (list (apply #'format nil params)))))

(defun load-atom (form bindings)
  (let ((binding (assoc form bindings)))
    (if binding
	(progn
	  (ecase (cadr binding)
	    (:arg (il-emit "ldarg ~a~%" (cddr binding)))
	    (:var (il-emit "ldloc ~a~%" (cddr binding)))))
      (if (integerp form)
	  (progn
	    (il-emit "ldc.i4 ~a~%" form)
	    (il-emit "box [mscorlib]System.Int32~%"))
	(error "unbound variable ~a" form)))))

(defparameter *ilout* nil)

(defun defun-output (fun-name param-count ret-type)
  (format *ilout* ".method public static ~A ~A(~{~A~^, ~}) cil managed~%{~%" ret-type fun-name
	  (loop repeat param-count collect "object"))
  (format *ilout* ".locals init (~{~A~^, ~})~%"
	  (reverse *locals*))
  (dolist (line *il-commands*)
    (princ line *ilout*))
  (format *ilout* "}~%"))

(defun process-defun (rest bindings is-void)
  (let ((fun-name (first rest))
	(paramlist (second rest))
	(body (cddr rest)))
    (setq bindings nil)
    (setq *locals* nil)
    (setq *il-commands* nil)
    (setq *function-signatures* (acons fun-name (length paramlist) *function-signatures*))
    (loop for i upfrom 0
      for param in paramlist
      do (setq bindings 
	       (acons param (cons :arg i) bindings)))
    (dolist (form body)
      (dispatch-form form bindings))	     
    (when is-void
      (il-emit "pop~%"))
    (il-emit "ret~%")
    (defun-output fun-name (length paramlist) (if is-void "void" "object"))))

(defgeneric process-form (first rest bindings)
  (:method ((first (eql 'assembly)) rest bindings)
	   (let ((is-extern (and (> (length rest) 1)
				 (eq (second rest) :extern))))
	     (format *ilout* ".assembly ~A ~A {}~%" (if is-extern "extern" "") (first rest))))
  (:method ((first (eql 'defun)) rest bindings)
	   (process-defun rest bindings nil))
  (:method ((first (eql 'defun-void)) rest bindings)
	   (process-defun rest bindings t))
  (:method ((first (eql 'let1)) rest bindings)
	   (let* ((declaration (first rest))
		  (body (cdr rest))
		  (var (first declaration))
		  (init-expr (second declaration)))
	     (let ((new-local-id (length *locals*)))
	       (push "object" *locals*)
	       (setq bindings (acons var (cons :var new-local-id) bindings))	       
	       (dispatch-form init-expr bindings)
	       (il-emit "stloc ~a~%" new-local-id)
	       (dolist (form body)
		 (dispatch-form form bindings)))))
  (:method ((first (eql 'entrypoint)) rest bindings)
	   (il-emit ".entrypoint~%"))
  (:method ((first (eql '+)) rest bindings)
	   (dispatch-form (first rest) bindings)
	   (il-emit "unbox [mscorlib]System.Int32~%")
	   (il-emit "ldind.i4~%")
	   (dolist (form (cdr rest))
	     (dispatch-form form bindings)
	     (il-emit "unbox [mscorlib]System.Int32~%")	     
	     (il-emit "ldind.i4~%")
	     (il-emit "add~%"))
	   (il-emit "box [mscorlib]System.Int32~%")
	   ))

(defmethod process-form (first rest bindings) ;;appears to be a function call
  (let ((fun-sig (assoc first *function-signatures*)))
    (if fun-sig
	(progn 
	  (when (/= (length rest) (cdr fun-sig))
	    (error "parameter count mismatch for function ~a, needs ~a parameters, got ~a"
		   first (cdr fun-sig) (length rest)))
	  (dolist (form rest)
	    (dispatch-form form bindings))
	  (il-emit "call object ~a (~{~a~^, ~})~%" first 
		   (loop repeat (cdr fun-sig) collect "object")) )
      (error "function ~a not found" first))))

(defmethod process-form ((first (eql 'print)) rest bindings)
	   (dispatch-form (first rest) bindings)
	   (il-emit "dup~%")
	   (il-emit "call void [mscorlib]System.Console::WriteLine(object)"))

	     
(defun il-compile-file (source-file-path result-file-path)
  (with-open-file (*ilout* result-file-path :direction :output :if-exists :supersede :if-does-not-exist :create)
    (setq *function-signatures* nil)
    (with-open-file (*src* source-file-path)
      (loop for code = (read *src* nil)
	while code
	do (dispatch-form code nil)))))