;;;;
;;;; stklos-compile.stk -- Call the stklos compiler
;;;;
;;;; Copyright © 2001-2024 Erick Gallesio <eg@stklos.net>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;;           Author: Erick Gallesio [eg@unice.fr]
;;;;    Creation date:  4-Dec-2001 18:12 (eg)
;;;;

(import STKLOS-COMPILER)

(define *output* "a.out")
(define *prepend-code* '())
(define *c-code* #f)
(define *expr* #f)
(define *case-sensitive* #t)

;; ----------------------------------------------------------------------
;;      convert-to-C ...
;; ----------------------------------------------------------------------
(define (convert-to-C src dst module-name)
  (define (header in out)
    (format out "/*  -*- C -*-\n")
    (format out "  This file was automatically generated on ~A\n" (date))
    (format out "  This is a dump of the image in file ~A\n" (port-file-name in))
    (format out "  ***DO NOT EDIT BY HAND***\n*/\n")
    (format out "#include <stklos.h>\n\n"))

  (define (footer out name)
    (format out "#ifdef MODULE_ENTRY\n")
    (format out "MODULE_ENTRY_START(~S) {\n" name)
    (format out "  STk_execute_C_bytecode(__module_consts, __module_code);\n")
    (format out "} MODULE_ENTRY_END\n\n")
    (format out "MODULE_ENTRY_INFO() {\n")
    (format out "   return STk_read_from_C_string(__module_infos);\n")
    (format out "}\n")
    (format out "#endif\n"))


  (let ((in   (open-input-file src))
        (out  (open-output-file dst)))
    ;; Output the header
    (header in out)

    ;; Skip the symbol STklos
    (read in)

    ;; Write file information (information is not used for now)
    (let ((info (read in))
          (str  (open-output-string)))
      (write info str)
      (format out "static char* __module_infos = ~S;\n"
              (get-output-string str)))

    ;; Write constants
    (let ((v   (read in))
          (str (open-output-string)))
      (write v str)
      (format out "static char* __module_consts = ~S;\n\n" (get-output-string str)))

    ;; Write the code
    (let ((sz (read in)))
      (format out "static STk_instr __module_code [] = { \n")
      (read-byte in)  ; To skip the newline after size
      (dotimes (i sz)
        (let* ((c1 (read-byte in))
               (c2 (read-byte in)))
          (format out
                  "~a"
                  (string-append
                   "0x"
                   (number->string (bit-or (bit-shift c1 8) c2)
                                   16)))
          (when (< i (- sz 1))
            (display ", " out))
          (when (= (modulo i 10) 9)
            (newline out))))
      (display "};\n\n" out))
    (footer out module-name)
    (flush-output-port out)
    (close-port out)))

;; ----------------------------------------------------------------------
;;      compile-to-bytecode ...
;; ----------------------------------------------------------------------
(define (compile-to-bytecode file out)
  (compile-file file out
                :prepend *prepend-code*
                :case-sensitive *case-sensitive*)
  (chmod out #o755))

;; ----------------------------------------------------------------------
;;      compile-to-C-code ...
;; ----------------------------------------------------------------------
(define (compile-to-C-code file out)
  (let ((tmp  (create-temp-file))
        (name (file-prefix (basename file))))
    (compile-to-bytecode file tmp)
    (convert-to-C tmp out name)
    (remove-file tmp)))

;; ----------------------------------------------------------------------
;;      main ...
;; ----------------------------------------------------------------------
(define (main args)
  (parse-arguments args
     "Usage: stklos-compile [options] file"
     "Compile a stklos file to byte codes"
     ""
     "Input options"
     (("case-sensitive" :alternate "c"  :help "Be case sensitive on symbols")
      (set! *case-sensitive* #t))
     (("case-insensitive" :alternate "i"  :help "Be case insensitive on symbols")
      (set! *case-sensitive* #f))
     (("colon-position" :alternate "p" :arg pos
       :help "Allowed position of ':' for keywords")
      (cond
       ((member pos '("none" "before" "after" "both"))
        (keyword-colon-position (string->symbol pos)))
       (else
        (eprintf "~a: bad position ~s\n" (program-name) pos)
        (exit 1))))

     "Output options"
     (("output" :alternate "o" :arg file :help "Output compiled code in <file>")
        (set! *output* file))
     (("C-code" :alternate "C" :help "Produce C code")
        (set! *c-code* #t))

     "Compiling options"
     (("evaluate" :alternate "e" :arg expr
       :help "Evaluate <expr> before compiling file")
      (set! *expr* expr))
     (("prepend-code" :alternate "k" :arg expr
       :help "Insert <expr> before file contents")
      (set! *prepend-code* (append *prepend-code* (list expr))))
     (("define-feature" :alternate "D" :arg name
       :help "Add <name> to known features (SRFI 138)")
      (with-handler (lambda (c)
                      (die (format "Error in --define-feature ~A option" name)))
                    (srfi0-register-feature! (string->symbol name))))
     (("line-info" :alternate "l" :help "Insert line numbers in generated file")
        (compiler:gen-line-number #t))
     (("show-instructions" :alternate "S" :help "Show instructions in generated file")
         (compiler:show-assembly-code #t))
     (("compiler-flags" :alternate "F" :arg flags :help "Add (+) or suppress (-) compiler flags")
      (%compiler-set-flags flags))

     "Path options"
     (("prepend-load-path" :alternate "I" :arg dir
       :help "Prepend <dir> to the loading path")
      (set! (load-path) (cons dir (load-path))))
     (("append-load-path"  :alternate "A" :arg dir
       :help "Append <dir> to the loading path")
      (set! (load-path) (append (load-path) (list dir))))

     "Misc. options"
     (("no-time" :help "Don't display file compilation time")
        (compiler:time-display #f))
     (("help" :alternate "h" :help "This help")
        (arg-usage (current-output-port))
        (exit 0))

     "\nCompiler flags (option -F)"
     "   Flags are separated by commas, booleans flags must be prefixed by '+' or  '-'"
     "   Example:"
     "      -compiler-flags='+line-info,-time-display,unroll-iterations=3'"
     "  Possible flags:"
     "    line-info          Insert line numbers in generated file (as -l option)"
     "    show-instructions  Show instructions in generated file (as -S option)"
     "    time-display       Print file compilation time"
     "    keep-formals       Keep formal arguments in closures"
     "    keep-source        Keep source code in closures"
     "    inline-usuals      Inline usual functions"
     "    source-rewrite     Permit source rewrite/simplification"
     "    unroll-iterations  Set the number of iterations to be unrolled"
     "    peephole-optimizer Use peephole optimizer"

     (else
      (cond
        ((= (length other-arguments) 1)
         ;; Evaluate prelude code
         (when (string? *expr*)
           (with-handler (lambda (c)
                           (die (format "Error in --evaluate ~A option" *expr*)))
              (eval (read-from-string *expr*)
                    (interaction-environment))))
         ;; Produce code
         (set! *prepend-code*
           (map (lambda (s) (read-from-string s))
                *prepend-code*))
         ;; Compile
         (let ((in (car other-arguments)))
           (with-handler (lambda (c)
                           (eprintf "~a:0: Error: ~a\n" in (condition-message c))
                           (emergency-exit 1))
              (if *c-code*
                  (compile-to-C-code   in *output*)
                  (compile-to-bytecode in *output*))))
         (exit 0))
        (else
          (arg-usage (current-error-port))
          (exit 1))))))
