;;;;
;;;; stklos-compile.stk	-- Call the stklos compiler
;;;;
;;;; Copyright © 2001-2010 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;;
;;;; 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)
;;;; Last file update: 10-Aug-2010 13:02 (eg)
;;;;

(import STKLOS-COMPILER)

(define *output* "a.out")
(define *c-code* #f)
(define *expr* #f)

;; ----------------------------------------------------------------------
;;	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 informations
    (let ((info (read in))
	  (str  (open-output-string)))
      (write info str)
      (format out "static char* __module_infos = ~S;\n\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-char in)  ; To skip the newline after size
      (dotimes (i sz)
	(let* ((c1 (read-char in))
	       (c2 (read-char in)))
	  (format out
		  "~5f"
		  (string-append
		   "0x"
		   (number->string (bit-or (bit-shift (char->integer c1) 8)
					   (char->integer 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)
  (chmod out #o755))

;; ----------------------------------------------------------------------
;;	compile-to-C-code ...
;; ----------------------------------------------------------------------
(define (compile-to-C-code file out)
  (let ((tmp  (temporary-file-name))
	(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")
        (read-case-sensitive #t))

     "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))
     (("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))

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

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

     (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
	 (if *c-code*
	     (compile-to-C-code (car other-arguments) *output*)
	     (compile-to-bytecode (car other-arguments) *output*))
	 (exit 0))
	(else
	  (arg-usage (current-error-port))
	  (exit 1))))))