;; -*- 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 (getenv-or var default)
  (let ((val (getenv var)))
    (if (= 0 (string-length val))
	default
	val)))

(define (gcc base options)
  (let ((plat (uname))
	(cc (getenv-or "CC" "gcc"))
	(cflags (getenv-or "CFLAGS" "-I. -g "))
	(cflags (if (and (string=? cc "gcc")
			 (string=? plat.sysname "Darwin"))
		    (format cflags " -fnested-functions")
		    cflags))
	(cflags (format cflags " " (if options.optimize "-O" "") " " options.extra-cflags))
	(cmd (format cc " " cflags " " base ".c -o " base)))
    (print-string (format "system: " cmd "\n"))
    (system cmd)))

(define (get-options argv options)
  (for-range
      i (vector-length argv)
      (match sys.argv[i] with
	"-c" -> (set! options.nocompile #t)
	"-v" -> (set! options.verbose #t)
	"-f" -> (begin (set! i (+ i 1))
		       (set! options.extra-cflags argv[i]))
	;; this option only applies to the C compilation phase.
	"-O" -> (set! options.optimize #t)
	_ -> #u)))

(defmacro verbose
  (verbose item ...) -> (if context.options.verbose (begin item ... #u)))

(define (main)
  (if (< sys.argc 2)
      (error "Usage: compile <irken-src-file>"))
  (let ((context (make-context))
	(_ (get-options sys.argv context.options))
	(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))
	;;(_ (begin (print-string "after subst:\n") (pp-node node0)))
	(_ (rename-variables node0))
	;;(_ (begin (pp-node node0) (newline)))
	(node1 (do-one-round node0 context))
	;;(_ (begin (print-string "after first round:\n") (pp-node node1)))
	(noden (do-one-round node1 context))
	(_ (find-leaves noden))
	(_ (verbose (print-string "after second round:\n") (pp-node noden)))
	;; rebuild the graph yet again, so strongly will work.
	(_ (build-dependency-graph noden context))
	;;(_ (print-graph context.dep-graph))
	;; strongly-connected components is needed by the typing phase
	(_ (print-string "strongly-connected components:\n"))
	(strong (strongly context.dep-graph))
	(_ (verbose (printn strong)))
	(_ (set! context.scc-graph strong))
	(_ (print-string "typing...\n"))
	(type0 (type-program noden context))
	(_ (verbose (print-string "\n-- after typing --\n") (pp-node noden) (newline)))
	(cps (compile noden context))
	(ofile (file/open-write opath #t #o644))
	(o (make-writer ofile)))
    (verbose
     (print-string "\n-- RTL --\n")
     (print-insn cps 0)
     (newline)
     (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-- symbols --\n")
     (alist/iterate
      (lambda (sym index)
	(print-string (format "  " (int index) " : " (sym sym) "\n")))
      context.symbols)
     (print-string "\n-- variant labels --\n")
     (alist/iterate
      (lambda (sym index)
	(print-string (format "  " (int index) " : " (sym sym) "\n")))
      context.variant-labels))
    (print-string "\n-- C output --\n")
    (print-string " : ") (print-string opath) (newline)
    (for-each
     (lambda (path)
       (o.write (format "#include <" path ">")))
     context.cincludes)
    (match (get-header-parts) with
      (:header part0 part1 part2)
      -> (begin (o.copy part0)
		(emit-constructed o context)
		(o.copy part1)
		(emit-registers o context)
		(o.copy part2)
		(emit o cps context)))
    (emit-lookup-field o context)
    (print-string "done.\n")
    (o.close)
    (cond ((not context.options.nocompile)
	   (print-string "compiling...\n")
	   (gcc base context.options)
	   #u
	   )
	  )
    )
  )
  
(main)