#!/usr/bin/guile \
-e "(scripts c2x)" -s
!#
;;; c2x --- Extract initialization code from .c files

;;	Copyright (C) 2003,2004,2005 Free Software Foundation, Inc.
;;
;; 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, 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 software; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;
;; As a special exception, the Free Software Foundation gives permission
;; for additional uses of the text contained in its release of GUILE.
;;
;; The exception is that, if you link the GUILE library with other files
;; to produce an executable, this does not by itself cause the
;; resulting executable to be covered by the GNU General Public License.
;; Your use of that executable is in no way restricted on account of
;; linking the GUILE library code into it.
;;
;; This exception does not however invalidate any other reasons why
;; the executable file might be covered by the GNU General Public License.
;;
;; This exception applies only to the code released by the
;; Free Software Foundation under the name GUILE.  If you copy
;; code from other Free Software Foundation releases into a copy of
;; GUILE, as the General Public License permits, the exception does
;; not apply to the code that you add in this way.  To avoid misleading
;; anyone as to the status of such modified files, you must delete
;; this exception notice from them.
;;
;; If you write modifications of your own for GUILE, it is your choice
;; whether to permit this exception to apply to your modifications.
;; If you do not wish that, delete this exception notice.

;;; Author: Thien-Thi Nguyen <ttn@gnu.org>

;;; Commentary:

;; Usage: c2x [-o OUTFILE] [CPP-ARGS ...]
;;
;; Process CPP-ARGS using the C pre-processor and some other programs.
;; Write output to a file named OUTFILE or to the standard output when no
;; OUTFILE has been specified or when OUTFILE is "-".  CPP-ARGS should
;; include an input filename.
;;
;; If there are errors during processing, delete OUTFILE and exit with
;; non-zero status.
;;
;; During snarfing, the pre-processor macro SCM_MAGIC_SNARFER is defined.
;; Also, c2x passes "-I GUILE-INCLUDE-DIR" to the pre-processor, where
;; GUILE-INCLUDE-DIR is the directory Guile's header files are installed.
;; (You can display this value with the command "guile-tools guile-config
;; info includedir".)
;;
;; If env var CPP is set, use its value instead of the C pre-processor
;; determined at Guile configure-time.  (You can display this value with
;; the command "guile-tools guile-config acsubst CPP".)

;;; Code:

(define-module (scripts c2x)
  #:autoload (scripts PROGRAM) (HVQC-MAIN)
  #:autoload (scripts guile-config-data) (guile-config-data)
  #:autoload (ice-9 regex) (match:substring match:suffix)
  #:autoload (ice-9 rdelim) (read-line write-line)
  #:autoload (ice-9 popen) (open-input-pipe)
  ;; not yet
  ;; #:export (c2x)
  )

(define (jaminc)
  (simple-format #f "-I ~A " (assq-ref %guile-build-info 'includedir)))
;;(define (jaminc) "")                    ; mask-zonk on install

(define (snarf-cmd magic? args)
  (simple-format #f "~A ~A~A~A"
                 (or (getenv "CPP")
                     (assq-ref guile-config-data 'CPP))
                 (if magic? "-DSCM_MAGIC_SNARFER " "")
                 (jaminc)
                 (apply string-append
                        (map (lambda (s)
                               (simple-format #f "~S " s))
                             args))))

(define init-rx (make-regexp " +SCM__I"))
(define doc-rx  (make-regexp " *SCM__D"))

(define (snarf! outp args good! bad!)
  (let* ((exports '())
         (count 0) (skip #f)            ; performance hack for second pass
         (inp (open-input-pipe (snarf-cmd #t args)))
         (next (lambda () (set! count (1+ count)) (read-line inp)))
         (next-fast (lambda () (read-line inp)))
         (acc (list 0)))                ;-( nothing is real ;-)
    (cond ((let loop ((line (next)) (tp acc))
             (cond ((eof-object? line)
                    (= 0 (status:exit-val (close-pipe inp))))
                   ((regexp-exec init-rx line)
                    => (lambda (m)
                         (let ((look (match:suffix m)))
                           (cond
                            ;; handle chained (not at bol) SCM__I
                            ((and=> (regexp-exec init-rx look)
                                    (lambda (mm) (match:start mm 0)))
                             => (lambda (split)
                                  (set-cdr! tp (list (substring look 0 split)))
                                  (loop (substring look split)
                                        (cdr tp))))
                            ;; handle incomplete line
                            ((not (string-index look #\;))
                             (loop (string-append line (next)) tp))
                            ;; save the line
                            (else
                             (set-cdr! tp (list (match:suffix m)))
                             (or skip (begin
                                        (set! skip count)
                                        (set! next next-fast)))
                             (loop (next) (cdr tp)))))))
                   (else (loop (next) tp))))
           (let ((oldline #f)
                 (in2 (open-input-pipe (snarf-cmd #f args)))
                 (gsubr-rx (make-regexp "scm_make_gsubr *\\( *([^ ,]+)[ ,]"))
                 (frags-rx (make-regexp "\\[\\] *= *(\"[^;]+\") *;")))
             (define (synch! sync-rx)
               (let sync ((line (or oldline (read-line in2))))
                 (cond (skip
                        (set! count (1+ count))
                        (or (< count skip)
                            (set! skip #f))
                        (sync (read-line in2)))
                       ((regexp-exec sync-rx line)
                        => (lambda (m)
                             (let* ((frags
                                     (let acc ((line (match:suffix m)))
                                       (cond ((regexp-exec frags-rx line)
                                              => (lambda (m)
                                                   (set! oldline (match:suffix m))
                                                   (with-input-from-string
                                                       (simple-format
                                                        #f "(~A)"
                                                        (match:substring m 1))
                                                     read)))
                                             (else
                                              (acc (string-append
                                                    line (read-line in2)))))))
                                    (name (string->symbol
                                           (apply string-append frags))))
                               (set! exports (cons name exports)))))
                       (else
                        (set! oldline #f)
                        (sync (read-line in2))))))
             (set! count 0)
             (for-each (lambda (line)
                         (let ((worthy (cond ((regexp-exec doc-rx line)
                                              => match:prefix)
                                             (else line))))
                           (and=> (regexp-exec gsubr-rx line)
                                  (lambda (m)
                                    (synch! (make-regexp
                                             (simple-format
                                              #f "static const char ~A *"
                                              (match:substring m 1))))))
                           (write-line worthy outp)))
                       (cdr acc))       ;-( ignore nothing! ;-)
             (let drain ((line (read-line in2)))
               (or (eof-object? line)
                   (drain (read-line in2))))
             (close-pipe in2))
           (for-each (lambda (x) (write-line x outp))
                     `("{"
                       "static char *exports SCM_UNUSED ="
                       ,(simple-format
                         ;; note: token chosen to be "reasonably unique"
                         ;;       (aka "unlikely to be used elsewhere"),
                         ;;       but this is not guaranteed.  its principle
                         ;;       criteria is having invalid `read' syntax.
                         #f "\"#_export ~S\";"
                         (reverse! exports))
                       "}"))
           (good!))
          (else
           (bad!)))))

(define (c2x/main args)
  (let* ((count (length args))
         ;; Do arg processing "manually" (avoiding qop and even getopt-long)
         ;; since the majority of the args are destined to be passed to cpp.
         (has-minus-o? (and (> count 3) (string=? "-o" (cadr args))))
         (outfile (if has-minus-o?
                      (caddr args)
                      "-"))
         (cpp-args (if has-minus-o?
                       (cdddr args)
                       (cdr args))))
    (snarf! (if (string=? "-" outfile)
                (current-output-port)
                ;; Ensure something non-empty is in the output file before the
                ;; snarfing begins, since the C file typically does #include
                ;; "OUTFILE", and might not properly guard against circular
                ;; dependency.  (Non-empty because file existence alone is
                ;; insufficient for some old pre-processors.)
                (let ((outp (open-output-file outfile)))
                  (simple-format outp "/* greetings from c2x! */\n")
                  (close-port outp)
                  (open-file outfile "a")))
            cpp-args
            (lambda () #t)
            (lambda () (or (string=? "-" outfile)
                           (delete-file outfile))
                    #f))))

(define (main args)
  (HVQC-MAIN args c2x/main
             '(usage . commentary)
             '(package . "Guile")))     ; see "manually" comment in c2x/main

;;; c2x ends here
