program: scm2bin.scm 1.1

[Thien-Thi Nguyen]

well, that's enough dabbling in lame "compilation" techniques for now.
but at least you can do stuff like:

 $ guile -s scm2bin.scm -o $HOME/bin/scm2bin -s scm2bin.scm
 $ PATH=$HOME/bin:$PATH
 $ d=`guile-tools --help | sed '/Default/!d;s/.* //'`
 $ mkdir -p /tmp/bin
 $ for prog in `guile-tools` ;
     do scm2bin -o /tmp/bin/$prog -s -x $d/$prog || echo oops: $prog ;
   done
 $ for prog in /tmp/bin/* ; do $prog --help ; done

and other time-for-space-for-time-for-space wranglings...

note that even w/o "-s", 1.1 produces a smaller result than 1.0, due to
super-sekret punify technology (which you will never see in your spambox
for some reason ;-).

thi


___________________________________________________________
#!/bin/sh
# -*- scheme -*-
exec guile -s $0 "$@"
!#
;;; ID: scm2bin.scm,v 1.2 2003/08/02 20:41:16 ttn Exp
;;;
;;; Copyright (C) 2003 Thien-Thi Nguyen
;;; This program is part of ttn-do, released under GNU GPL v2 with ABSOLUTELY
;;; NO WARRANTY.  See http://www.gnu.org/copyleft/gpl.txt for details.

;;; Commentary:

;; Usage: scm2bin --help
;;        scm2bin --version
;;        scm2bin [OPTIONS] SCM
;;  where SCM is a scheme (.scm) program, and OPTIONS
;;  (defaults in square brackets) is zero or more of:
;;   -o, --output FILE       -- use FILE for output [scm2bin.out]
;;   -s, --scheme-static     -- also bundle upstream scheme files
;;   -x, --executable-module -- use executable module calling convention
;;
;; scm2bin creates a "binary executable file" named scm2bin.out that
;; encapsulates the code from SCM, the filename of a Scheme program.
;; This file can be run from the shell like so: ./scm2bin.out ARGS...
;; Option `--output FILE' specifies an alternative output filename.
;;
;; Option `--scheme-static' means perform a module-fan-in analysis and
;; additionally encapsulate those Scheme modules that would be loaded via
;; "use-modules".  This increases the size and reduces the startup time of
;; the executable, rendering it opaque to upgrades to upstream modules.
;; This is similar in spirit to "gcc -static" wrt shared object libraries.
;; Note, however, that the binary executable file is not "static" in that
;; sense, but only in the Scheme code sense.
;;
;; Option `--executable-module' means use the executable module calling
;; convention instead of the default "guile -s" simulation.

;;; Code:

(define *scm2bin-version* "1.1")

(cond ((getenv "ttn_do_bin")
       => (lambda (do-dir)
            (or (member do-dir %load-path)
                (set! %load-path (cons do-dir %load-path))))))

(use-modules (module-fan-in))

(use-modules (ice-9 rw))

(define (usage)
  (for-each
   write-line
   '("Usage: scm2bin --help"
     "       scm2bin --version"
     "       scm2bin [OPTIONS] SCM"
     " where SCM is a scheme (.scm) program, and OPTIONS"
     " (defaults in square brackets) is zero or more of:"
     "  -o, --output FILE       -- use FILE for output [scm2bin.out]"
     "  -s, --scheme-static     -- also bundle upstream scheme files"
     "  -x, --executable-module -- use executable module calling convention"
     )))

(use-modules (srfi srfi-13))

(define (write-C-string p s)
  (string-for-each
   (lambda (c)
     (case c
       ((#\newline) (display "\\n\"\n  \"" p))
       ((#\\) (display #\\ p) (display #\\ p))
       ((#\") (display #\\ p) (display #\" p))
       (else (display c p))))
   s))

(define *boilerplate-C* "
static int actual_main (int argc, char **argv) {
  SCM port = scm_open_input_string (gh_str02scm (program));
  while (1) {
    SCM form = scm_read (port);
    if (SCM_EOF_OBJECT_P (form)) break;
    scm_eval_x (form);
  }
  return 0;
}

int main (int argc, char **argv) {
  gh_enter (argc, argv, actual_main);
  return 0;
}
")

(define *options*
  '((version)
    (help (single-char #\h))
    (output (single-char #\o)
            (value #t))
    (verbose (single-char #\v))
    (scheme-static (single-char #\s))
    (executable-module (single-char #\x))
    ;; Add more options here.
    ))

(use-modules (scripts read-scheme-source))

(define (display-executable-module-blurb filename)
  (let loop ((forms (read-scheme-source-silently filename)))
    (if (null? forms)
        (error "could not find define-module in" filename)
        (if (eq? (caar forms) 'define-module)
            (display
             `(apply (module-ref
                      (resolve-module (quote ,(cadar forms)))
                      (quote main))
                     (cdr (command-line))))
            (loop (cdr forms))))))

(use-modules (scripts punify) (ice-9 getopt-long))

(use-modules ((srfi srfi-1) :select (filter-map)))

;;; main
(let ((parsed (getopt-long (command-line) *options*)))
  (cond ((option-ref parsed 'help #f)
         (usage)
         (exit #t))
        ((option-ref parsed 'version #f)
         (format #t "scm2bin ~A\n" *scm2bin-version*)
         (exit #t))
        ((null? (option-ref parsed '() #f))
         (usage)
         (exit #f))
        (else
         (let* ((name (car (option-ref parsed '() #f)))
                (in (if (file-exists? name)
                        (with-output-to-string
                          (lambda ()
                            (if (option-ref parsed 'scheme-static #f)
                                (apply punify
                                       (filter-map
                                        (lambda (module)
                                          (object-property module 'filename))
                                        (module-fan-in (list name))))
                                (punify name))
                            (and (option-ref parsed 'executable-module #f)
                                 (display-executable-module-blurb name))))
                        (begin
                          (format #t "scm2bin: cannot read: ~A\n"
                                  name)
                          (exit #f))))
                (out (format #f "-o ~A"
                             (option-ref parsed 'output "scm2bin.out")))
                (tmp (open-output-file "scm2bin.c")))
           (format tmp "#include <libguile.h>\n")
           (format tmp "static char program[] = \"")
           (write-C-string tmp in)
           (format tmp "\";\n\n")
           (format tmp *boilerplate-C*)
           (close tmp)
           (system (format #f "~A~A ~A ~A ~A ~A"
                           (or (and (option-ref parsed 'verbose #f)
                                    "set -x ; ")
                               "")
                           "`guile-tools guile-config acsubst CC`"
                           out
                           "`guile-tools guile-config compile`"
                           "scm2bin.c"
                           "`guile-tools guile-config link`")))
         (delete-file "scm2bin.c")
         (exit #t))))

;;; scm2bin.scm ends here