;; BF Compiler in Scheme
;; Jon Simons (simonsj at ccs dot neu dot edu)
;; August, 2007
;; -------------------------------------------------------------------------
#lang scheme/base

(require scheme/list)

(require "bf-lex.scm")                      ;; Lexing
(require (only-in "bf-parser.scm" parse))   ;; Parsing and AST
(require "optimizations/ops.scm")           ;; AST Optimizations


;; Target Languages
;; ----------------
;; BF Intermediate Representation
(require (prefix-in ir_   "emitters/bf-emit-ir.scm"))   ;; IR
(require (prefix-in c_    "emitters/bf-emit-c.scm"))    ;; ANSI C
(require (prefix-in java_ "emitters/bf-emit-java.scm")) ;; Java

(require (prefix-in mips_ "emitters/bf-emit-mips.scm")) ;; MIPS
(require (prefix-in x86m_ "emitters/bf-emit-x86m.scm")) ;; x86 (MASM)
;; SPARC assembly

(require (prefix-in llvm_ "emitters/bf-emit-llvm.scm")) ;; LLVM Assembly
;; Java   bytecode
;; Parrot bytecode
;; .Net   bytecode

(define version-header
  (string-append
   "Hamster v0.04  |  www.hamsterfestdestiny.org/hamster~%"
   "~%"))

;; Prints out the given error message, the usage for this program, and then
;; exits.
;;
;; usage : string -> (nothing)
(define (usage errmsg)
  (begin
    (printf (string-append
             errmsg
             "Usage: bf-compiler [extended options] target_language BF_source_file~%"
             "~%"
             "Where target_language can be one of:~%"
             "  ir         BF Intermediate Representation~%"
             "  ansi_c     ANSI C~%"
             "  java       Java~%"
             "  mips       MIPS Assembly~%"
             "  x86m       x86 Assembly (MASM)~%"
             "  llvm       LLVM Assembly~%"
             "~%"
             "BF_source_file is the name of the BF source file to compile.~%"
             "~%"
             "Extended options can be zero or more of:~%"
             "  -Omults    Turn on multiplication-loop collapsing~%"
             "  -Ozero     Turn on zero collapsing~%"
             "  -Odead     Turn on dead loop removal~%"
             "~%--~%"
             version-header))
    (exit 0)))

;; Compiles the given input-file by lexing it, parsing it, applying all of
;; the given ast-ops to the AST, and finally emits the given target
;; language to stdout.
;;
;; compile-bf : (list of functions) string string -> (nothing)
(define (compile-bf ast-ops target-lang input-file)
  (let* (;; Target Language
         (tl  (string->symbol target-lang))
         ;; Untransformed BF AST
         (parsed-ast (parse (lex input-file)))
         ;; Optimized BF AST
         (optimized-ast (foldl (lambda (fn ast) (fn ast))
                               parsed-ast
                               ast-ops))
         ;; Choose target language
         (emit (case tl
                 ((ir)     ir_emit)
                 ((ansi_c) c_emit)
                 ((java)   java_emit)
                 ((mips)   mips_emit)
                 ((x86m)   x86m_emit)
                 ((llvm)   llvm_emit)
                 (else     #f))))
    (if emit
        (printf (emit optimized-ast))
        (usage (format "Unknown target language \"~s\"~%~%" tl)))))


;; Parses the given command line arguments and invokes compile.
;;
;; main : vector -> (nothing)
(define (main args)
  (let ((argv    (vector->list (current-command-line-arguments)))
        ;; Optimizations that will be applied
        (ast-ops (list ast->ir))
        ;; Probably syntactically shorter way to do this
        (map-ops (list
                  (list '-Omults collapse-multiplier-loops)
                  (list '-Ozero  collapse-zeroes)
                  (list '-Odead  kill-dead-loops))))
    (if (>= (length argv) 2)
        (letrec ((parse-args
                  (lambda (argv ast-ops)
                    (if (= (length argv) 2)
                        (compile-bf (reverse ast-ops)
                                    (car  argv)
                                    (cadr argv))
                        (let ((op-pair (assq (string->symbol (car argv))
                                             map-ops)))
                          (if op-pair
                              (parse-args (cdr argv)
                                          (cons (cadr op-pair) ast-ops))
                              (usage (format "Unknown optimization: ~v~%"
                                             (car argv)))))))))
          (parse-args argv ast-ops))
        (usage ""))))

(main (current-command-line-arguments))