;; -*- Mode: Irken -*-

(include "self/backend.scm")

(define (find-base path)
  (let ((parts (string-split path #\.))
	(rparts (reverse parts)))
    (if (not (string=? (first rparts) "scm"))
	(error1 "find-base" path)
	(string-join (reverse (cdr rparts)) "."))))

(define (read-template)
  (let ((ifile (file/open-read "header.c")))
    (let loop ((buf (file/read-buffer ifile))
	       (l '()))
      (cond ((= (string-length buf) 0) (string-concat (reverse l)))
	    (else (loop (file/read-buffer ifile)
			(list:cons buf l)))))))

(define sentinel0 "// CONSTRUCTED LITERALS //\n")
(define sentinel1 "// REGISTER_DECLARATIONS //\n")

(define (get-header-parts)
  (let ((header (read-template))
	(pos0 (string-find sentinel0 header))
	(pos1 (string-find sentinel1 header))
	)
    (if (or (= pos0 -1) (= pos1 -1))
	(error1 "template strings not found in header.c?" (:pair pos0 pos1))
	(let ((pos0 (+ pos0 (string-length sentinel0)))
	      (pos1 (+ pos1 (string-length sentinel1)))
	      (part0 (substring header 0 pos0))
	      (part1 (substring header pos0 pos1))
	      (part2 (substring header pos1 (string-length header))))
	  (:header part0 part1 part2)))))

(define (prepend-standard-macros forms context)
  (foldr list:cons forms (read-file context.standard-macros)))

(define (system cmd)
  (%%cexp (string -> int) "system (%0)" cmd))

(define (main)
  (if (< sys.argc 2)
      (error "Usage: compile <irken-src-file>"))
  (let ((context (make-context))
	(transform (transformer context))
	(path sys.argv[1])
	(base (find-base path))
	(opath (string-append base ".c"))
	(forms0 (read-file path))
	(forms1 (prepend-standard-macros forms0 context))
	(exp0 (sexp:list forms1))
	(exp1 (transform exp0))
	(_ (begin (pp 0 exp1) (newline)))
	(node0 (walk exp1))
	(node0 (apply-substs node0))
	(_ (rename-variables node0))
	(_ (begin (pp-node node0 4) newline))
	(_ (build-dependency-graph node0 context))
	(_ (print-graph context.dep-graph))
	(strong (strongly context.dep-graph))
	(_ (printn strong))
	(_ (set! context.scc-graph strong))
	(_ (analyze node0 context))
	(node1 (do-simple-optimizations node0))
	(node2 (do-inlining node1 context))
	(node3 (do-trim node2 context))
	(noden (do-simple-optimizations node3))
	(type0 (type-program noden context))
	)
    (print-string "\n-- reader --\n")
    (unread exp0)
    (newline)
    (print-string "\n-- macros --\n")
    (unread exp1)
    (newline)
    (print-string "\n-- node tree --\n")
    (pp-node node1 4) (newline)
    (print-string "\n-- after inlining --\n")
    (pp-node node2 4) (newline)
    (print-string "\n-- after trimming --\n")
    (pp-node noden 4) (newline)
    (let ((cps (compile noden context))
	  (ofile (file/open-write opath #t #o644))
	  (o (make-writer ofile)))
      (print-string "\n-- RTL --\n")
      (print-insn cps 0)
      (newline)
      ;(iterate-insns cps)
      (print-string "\n-- datatypes --\n")
      (alist/iterate
       (lambda (name dt)
	 (print-datatype dt))
       context.datatypes)
      (print-string "\n-- variables --\n")
      (print-vars context)
      (print-string "\n-- labels --\n")
      (printn context.labels)
      (print-string "\n-- records --\n")
      (printn context.records)
      (print-string "\n-- C output --\n")
      (print-string " : ") (print-string opath) (newline)
      (match (get-header-parts) with
	(:header part0 part1 part2)
	-> (begin (o.copy part0)
		  (o.copy part1)
		  (emit-registers o context)
		  (o.copy part2)
		  (emit o cps context)))
      (print-string "done.\n")
      (o.close)
      (print-string "compiling...\n")
      (let ((cmd (format "/usr/local/bin/gcc -I. -g -m64 " opath " -o " base)))
	(print-string cmd) (newline)
	(system cmd))
      )
    )
  )
  
(main)