;;;
;;; statify - create all-in-one binary executable
;;;

;; EXPERIMENTAL

;; At this moment, libraries required by extensions need to be passed
;; explicitly, e.g.
;;   gosh statify script.scm scriptlib/foo.scm -lgdbm -lgdbm_compat -lz
;;

(use gauche.parseopt)
(use gauche.parameter)
(use gauche.config)
(use gauche.cgen)
(use gauche.process)
(use util.match)
(use file.util)
(use srfi-13)
(use srfi-42)

(define (usage)
  (exit 0 "Usage: gosh statify [-L libpath] script.scm libdir/libfile.scm ... [-llib ...]"))

(define p print)

(define libpath (make-parameter "."))

(define (main args)
  (let-args (cdr args) ([help "h|help" => (cut usage)]
                        [keep-cfile "keep-cfile"] ;this is for debugging
                        [lp "L=s" "."]
                        . args)
    (match args
      [(ifile . libfiles)
       (receive (linklibs libscm)
           (partition (cut string-prefix? "-l" <>) libfiles)
         (let ([ofile (path-sans-extension ifile)]
               [cfile (parameterize ([libpath lp])
                        (generate-cprog ifile libscm))])
           (compile cfile ofile linklibs)
           (unless keep-cfile
             (sys-unlink cfile))))]
      [_ (usage)])
    0))

(define (generate-cprog ifile libfiles)
  (receive (out tmpfile) (sys-mkstemp "tmp")
    (with-output-to-port out
      (^[]
        (p "#include <gauche.h>")
        (p "extern void Scm_InitPrelinked();")
        (p "static const char *script = ")
        (p (c-safe-string-literal (file->string ifile)))
        (p ";")

        (p "static const char *libfile[] = {")
        (dolist [libfile libfiles]
          (p (c-safe-string-literal
              (file->string (build-path (libpath) libfile))))
          (p ","))
        (p "};")

        (cond-expand
         [gauche.os.windows (generate-imp-stub "libgauche-0.9.a")]
         [else])

        (p "int main(int argc, const char **argv)")
        (p "{")
        (p "  ScmObj s, p;")

        (cond-expand
         [gauche.os.windows (p "  populate_import_pointers();")]
         [else])

        (p "  Scm_Init(GAUCHE_SIGNATURE);")
        (p "  Scm_InitPrelinked();")
        (do-ec (: f (index i) libfiles)
               (begin
                 (p "  s = SCM_MAKE_STR(libfile["i"]);")
                 (p "  p = Scm_MakeInputStringPort(SCM_STRING(s), TRUE);")
                 (p "  Scm_LoadFromPort(SCM_PORT(p), SCM_LOAD_PROPAGATE_ERROR, NULL);")
                 (p "  Scm_Provide(SCM_MAKE_STR("(c-safe-string-literal (path-sans-extension f))"));")))
        (p "  Scm_SimpleMain(argc, argv, script, 0);") ; this won't return.
        (p "  return 0;")  ; pretend to be a good citizen.
        (p "}")
        ))
    (close-output-port out)

    (cond-expand
     [gauche.os.windows (generate-deffile (path-swap-extension ifile "def")
                                          "libgauche-0.9.a")]
     [else])
    
    (rlet1 cfile #`",|tmpfile|.c" (sys-rename tmpfile cfile))))


(define (compile cfile ofile linklibs)
  (let* ([cc      (gauche-config "--cc")]
         [cflags  (gauche-config "-I")]
         [ldflags (gauche-config "-L")]
         [libs    (regexp-replace* (gauche-config "-l") #/-lgauche-\d+\.\d+/ "")]
         [links   (string-join linklibs " ")] ;; -lfoo ..
         [deffile (cond-expand
                   [gauche.os.windows
                    ""(path-swap-extension ofile "def")]
                   [else ""])]
         [cmd #`",cc -g ,cflags -o ,ofile ,ldflags ,cfile libgauche-0.9.a ,deffile ,libs ,links"]
         )
    (print cmd)
    (sys-system cmd)))

;; For MinGW
(define (generate-imp-stub libgauche)
  (define exptab (make-hash-table 'equal?))
  (dolist [entry (process-output->string-list `("nm" ,libgauche))]
    (rxmatch-case entry
      [#/T _(Scm\w+)/ (_ sym) (set! (~ exptab sym) #t)]
      [#/U __imp__(Scm\w+)/ (_ sym) (set! (~ exptab sym) #t)]))
  (hash-table-for-each exptab (^[k v] (print "void *_imp__" k ";")))
  (print "void populate_import_pointers() {")
  (print "HMODULE m = GetModuleHandle(NULL);")
  (print "if (m == NULL) { printf(\"Couldn't get module handle.  Aborting.\"); exit(1); }")
  (hash-table-for-each
   exptab
   (^[k v]
     (print "  _imp__" k " = (void*)GetProcAddress(m, \"" k "\");")
     (print "  if (_imp__"k" == NULL) { printf(\"Couldn't get address for `"k"'(%d).  Aborting.\", GetLastError()); exit (1); }")))
  (print "}")
  )

(define (generate-deffile deffile libgauche)
  (define exptab (make-tree-map string=? string<?))
  (dolist [entry (process-output->string-list `("nm" ,libgauche))]
    (rxmatch-case entry
      [#/T _(Scm\w+)/ (_ sym) (set! (~ exptab sym) #t)]))
  (with-output-to-file deffile
    (^[]
      (print "LIBRARY " (path-sans-extension libgauche))
      (print "EXPORTS")
      (tree-map-for-each
       exptab
       (^[key val] (print "  " key)))
      )))

;; Local variables:
;; mode: scheme
;; end:

