#!/bin/sh
exec ${GUILE-guile} -e "(ttn-do scm2bin)" -s $0 "$@" # -*-scheme-*-
!#
;; Copyright (C) 2003, 2004, 2005, 2006, 2007, 2009, 2010,
;;   2011 Thien-Thi Nguyen
;;
;; This file is part of ttn-do, released under the terms of the
;; GNU General Public License as published by the Free Software
;; Foundation; either version 3, or (at your option) any later
;; version.  There is NO WARRANTY.  See file COPYING 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:
;;   -v, --verbose           -- display more info than usual
;;   -o, --output FILE       -- use FILE for output [scm2bin.out]
;;   -C, --save-c FILE       -- write composed C code to FILE
;;   -r, --rpath [DIR]       -- pass "-rpath DIR" to linker
;;                              [directory where libguile.so is installed]
;;
;; 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.
;;
;; Internally, program invocation depends on its input.  In all
;; cases, all forms are evaluated sequentially.  Then, do:
;;
;; * simple script without ‘main’
;;   (exit #t)
;;
;; * simple script with ‘main’
;;   (unmask-signals)
;;   (exit (main (command-line)))
;;
;; * module (first form is ‘define-module’) with ‘main’
;;   (define-module (guile-user))
;;   (define-macro (@ ...) ...)
;;   (unmask-signals)
;;   (exit ((@ MODULE-NAME main) (command-line)))
;;
;; A module without ‘main’ results in an error:
;; No ‘main’ procedure defined in module MODULE-NAME
;;
;; The default compiler is gcc.  Option ‘--gcc PROGRAM’ overrides this.
;;
;; Option ‘--rpath DIR’ means to to pass "--rpath DIR" to the linker.
;; This is useful if you have installed Guile in an unusual (or otherwise
;; not normally frequented by the dynamic linker/loader) place.

;;; Code:

(define-module (ttn-do scm2bin)
  #:export (main write-punily)
  #:use-module ((ttn-do zzz 0gx forms-from) #:select (forms<-file))
  #:use-module ((ttn-do zzz 0gx write-string) #:select (write-string))
  #:use-module ((ttn-do zzz banalities) #:select (check-hv
                                                  qop<-args))
  #:use-module ((ttn-do zzz personally) #:select (FE fs fso make-fso))
  #:use-module ((ttn-do zzz filesystem) #:select (safe-rewind
                                                  temporary-file-port))
  #:use-module ((ttn-do zzz subprocess) #:select (fshell-command->string))
  #:use-module ((ice-9 documentation) #:select (file-commentary))
  #:use-module ((ttn-do mogrify) #:select (editing-buffer))
  #:use-module ((srfi srfi-1) #:select (find remove))
  #:use-module ((srfi srfi-13) #:select (string-for-each
                                         string-trim-both)))

;; Behave like @code{(write @var{x})}, but with less whitespace.
;; An exception is made for certain whitespace characters appearing in
;; a string.  They are expanded to their two-character "escaped" form:
;;
;; @example
;;     #\bel  \a     #\newline  \n     #\ht  \t
;;     #\np   \f     #\cr       \r     #\vt  \v
;; @end example
;;
;; Additionally, @samp{#\nul} is written as @samp{\0}.
;;
;; Return a boolean indicating whether or not @var{x} is @dfn{rear
;; delimiting}, i.e., can be safely followed (on the output stream)
;; without requiring intervening whitespace.  This is the case for
;; strings, vectors and @strong{most} lists.  A particular case is:
;;
;; @example
;; (write-punily 'symbol)   ;; aka (quote symbol)
;; @print{} 'symbol
;; @result{} #f
;; @end example
;;
(define (write-punily x)
  (define (list-is-quote? ls)
    (and (eq? 'quote (car ls))
         (pair? (cdr ls))
         (null? (cddr ls))))
  (cond ((vector? x)
         (display #\#)
         (write-punily (vector->list x)))
        ((null? x)
         (write x)
         #t)
        ((pair? x)
         (cond ((list-is-quote? x)
                (display #\')
                (write-punily (cadr x)))
               (else
                (display "(")
                (let loop ((rd? (write-punily (car x))) (ls (cdr x)))
                  (cond ((null? ls))
                        ((not (pair? ls))
                         (or rd? (display #\space))
                         (display ". ")
                         (write-punily ls))
                        (else
                         (let ((next (car ls)))
                           (or rd?
                               (null? next)
                               (and (pair? next)
                                    (not (list-is-quote? next)))
                               (string? next)
                               (display #\space))
                           (loop (write-punily next) (cdr ls))))))
                (display ")")
                #t)))
        ((string? x)
         (write-string x)
         #t)
        ((and (symbol? x)
              (let ((ls (string->list (symbol->string x))))
                (and (char=? (car ls) #\:)
                     (not (memq #\space ls))
                     (list->string (cdr ls)))))
         => (lambda (symbol-name-after-colon)
              (display #\:)
              (display symbol-name-after-colon)
              #f))
        (else
         (write x)
         #f)))

(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* "
#define GUILE_VERSION  (SCM_MAJOR_VERSION * 10000 \\
                        + SCM_MINOR_VERSION * 100 \\
                        + SCM_MICRO_VERSION)

static void
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;
#if GUILE_VERSION >= 10800
    scm_primitive_eval (form);
#else
    scm_eval_x (form);
#endif
  }
}

int
main (int argc, char **argv) {
  /* check--version */
  /* check--help */
  gh_enter (argc, argv, actual_main);
  return EXIT_SUCCESS;
}
")

(define *check-version-boilerplate* "
  if (2 == argc && 0 == strncmp (\"--version\", argv[1], 9) && !argv[1][9]) {
    printf (\"%s\\n\", version_text);
    return EXIT_SUCCESS;
  }
")

(define *check-help-boilerplate* "
  if (2 == argc && 0 == strncmp (\"--help\", argv[1], 6) && !argv[1][6]) {
    printf (\"%s\\n\", help_text);
    return EXIT_SUCCESS;
  }
")

(define (invocation forms)
  (define (main-defined?)
    (or (assq-ref forms 'main)
        (find (lambda (form)
                (and (pair? form)
                     (eq? 'define (car form))
                     (pair? (cdr form))
                     (pair? (cadr form))
                     (eq? 'main (caadr form))))
              forms)))
  (define (unmask-signals-maybe)
    (or (defined? 'effective-version)   ; Guile 1.8+
        '(unmask-signals)))
  (define (compacted . ls)
    (delq #t ls))
  (cond ((assq-ref forms 'define-module)
         => (lambda (def-mod-form)
              (or (main-defined?)
                  (error (fs "No ‘main’ procedure defined in module ~A"
                             (car def-mod-form))))
              (compacted
               ;; Make sure we start in the right place.
               '(define-module (guile-user))
               ;; Guile 1.6 and onward have this.
               (or (defined? '@)
                   '(define-macro (@ module-name proc-name)
                      `((#{%%\ mtargeiec\ %%}# #:OB) #:fob-ref
                        ((#{%%\ mtargeiec\ %%}# #:MU) #:module-name->fob
                         ',module-name)
                        ',proc-name)))
               ;; Do it!
               (unmask-signals-maybe)
               `(exit ((@ ,(car def-mod-form) main)
                       (command-line))))))
        ((main-defined?)
         (compacted
          (unmask-signals-maybe)
          '(exit (main (command-line)))))
        (else
         (list
          '(exit #t)))))

(define (search head x got-it)
  (define (look x)
    (cond ((not (pair? x))
           #f)
          ((and (eq? head (car x))
                ;; Don't match forms like ‘(quote HEAD)’.
                (not (null? (cdr x))))
           (throw 'found x))
          (else
           (look (car x))
           (look (cdr x)))))
  (catch 'found (lambda ()
                  (look x))
         (lambda (key arg)
           (and arg (got-it arg)))))

(define (find-check-hv x)
  (search 'check-hv x
          (lambda (full)
            (letrec ((walk (lambda (x)
                             (cond ((not (pair? x)) x)
                                   ((eq? 'help (car x))
                                    (cons 'usage (walk (cdr x))))
                                   (else
                                    (cons (walk (car x)) (walk (cdr x))))))))
              (walk (caddr full))))))

(define (find-HVQC-MAIN x)
  (search 'HVQC-MAIN x cdddr))

(define (check/extract-string! form)
  (let ((s (cdr form)))
    (and (string? s)
         (begin (set-cdr! form #f)
                s))))

(define (lift-version x name)
  (define (string-value head)
    (search head x check/extract-string!))
  (and=> (string-value 'version)
         (lambda (vers)
           (fs "~A~A ~A" name
               (cond ((string-value 'package)
                      => (lambda (pkg)
                           (fs " (~A)" pkg)))
                     (else ""))
               vers))))

(define (lift-usage forms filename)
  (search 'usage forms (lambda (form)
                         (cond ((check/extract-string! form))
                               ((eq? 'commentary (cdr form))
                                (string-trim-both (file-commentary filename)))
                               (else #f)))))

(define (s-c-c varname)
  (fs "static const char ~A[]" varname))

(define (guile-config part)
  (string-trim-both (fshell-command->string "guile-config ~A" part)))

(define (main/qop qop)
  (and (null? (qop '()))
       (error "no input file specified\ntry: scm2bin --help"))
  (or (file-exists? (car (qop '())))
      (error "cannot read: ~A" (car (qop '()))))
  (let* ((name (car (qop '())))
         (forms (forms<-file name))
         (forms/no-def (remove (lambda (form)
                                 (and (pair? form)
                                      (eq? 'define-module
                                           (car form))))
                               forms))
         (hv-main (or (find-check-hv forms/no-def)
                      (find-HVQC-MAIN forms/no-def)))
         (version-text (lift-version hv-main (basename name ".scm")))
         (help-text (lift-usage hv-main name))
         (in (with-output-to-string
               (lambda ()
                 (FE forms write-punily)
                 (FE (invocation forms) write-punily))))
         (out (fs "-o ~A" (or (qop 'output) "scm2bin.out")))
         (tmp (temporary-file-port))
         (ftmp (make-fso tmp)))
    (ftmp "#include <stdlib.h>~%")
    (ftmp "#include <libguile.h>~%")
    (ftmp "#include <guile/gh.h>~%")
    (and version-text (ftmp "~A = ~S;~%~%" (s-c-c "version_text") version-text))
    (cond (help-text
           (ftmp "~A = \"" (s-c-c "help_text"))
           (write-C-string tmp help-text)
           (ftmp "\";~%~%")))
    (ftmp "~A = \"" (s-c-c "program"))
    (write-C-string tmp in)
    (ftmp "\";~%~%")
    (editing-buffer *boilerplate-C*
      (goto-char (point-min))
      (search-forward "/* check--version */")
      (if version-text
          (insert *check-version-boilerplate*)
          (delete-region (- (match-beginning 0) 2) (1+ (match-end 0))))
      (search-forward "/* check--help */")
      (if help-text
          (insert *check-help-boilerplate*)
          (delete-region (- (match-beginning 0) 2) (1+ (match-end 0))))
      (write-to-port tmp))
    (safe-rewind tmp)
    (and=> (qop 'save-c)
           (lambda (filename)
             (system (fs "0<&~A cat >~A" (fileno tmp) filename))
             (safe-rewind tmp)))
    (let ((cmd (fs "0<&~A ~A ~A -fwhole-program -x c - -lguile ~A ~A ~A~A"
                   (fileno tmp)
                   (or (qop 'gcc) "gcc")
                   (if (qop 'verbose) " -v" "")
                   out
                   (guile-config 'compile)
                   (guile-config 'link)
                   (cond ((qop 'rpath)
                          => (lambda (dir)
                               (fs " -Wl,-rpath '-Wl,~A'"
                                   (if (eq? #t dir)
                                       (assq-ref %guile-build-info 'libdir)
                                       dir))))
                         (else "")))))
      (and (qop 'verbose)
           (fso "scm2bin: compilation command: ~A~%" cmd))
      (let ((result (system cmd)))
        (close tmp)
        (and (qop 'verbose)
             (fso "scm2bin: compilation result: ~A~%" result))
        (zero? result)))))

(define (main args)
  (check-hv args '((package . "ttn-do")
                   (version . "3.4")
                   ;; 3.4  -- don't ‘unmask-signals’ for Guile 1.8+
                   ;; 3.3  -- slogging, add ‘--save-c’, small bugfixes
                   ;; 3.2  -- add ‘--gcc PROGRAM’
                   ;; 3.1  -- slogging
                   ;; 3.0  -- initial release (of the 2nd major rewrite)
                   (help . commentary)))
  (exit (main/qop
         (qop<-args
          args '((output    (single-char #\o) (value #t))
                 (verbose   (single-char #\v))
                 (save-c    (single-char #\C) (value #t))
                 (gcc       (value #t))
                 (rpath     (single-char #\r) (value optional)))))))

;;; scm2bin.scm ends here