#!/bin/sh
exec ${GUILE-guile} -e '(guile-baux fs2c)' -s $0 "$@" # -*-scheme -*-
!#
;;; fs2c --- translate flagstash spec to C code

;; Copyright (C) 2003, 2004, 2005, 2007, 2008, 2011 Thien-Thi Nguyen
;;
;; 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 3, 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.

;;; Commentary:

;; Usage: fs2c [OPTIONS] FS-SPEC
;;
;; Write C fragment to stdout derived from the flags scanned from the
;; header as specified in file FS-SPEC.  OPTIONS are zero or more of:
;;
;;  -o, --output FILE    -- write to FILE instead of stdout
;;  -I, --include DIR    -- look in DIR instead of /usr/include
;;
;; The FS-SPEC file contents are Scheme forms in the following format:
;; First is the symbol NICK, used to form C identifiers.  Next is the
;; string PRETTY, used in the external representation of the flagstash
;; object like so: "sdl-PRETTY-flags".  The rest of the forms are
;; alternating keywords and values.  These configure how fs2c scans
;; for entries.  Entries are extracted by regular expression matching
;; of lines (or a region) in a file.
;;
;; Currently, these keywords are recognized:
;;
;;  #:infile RELPATH     -- which header to scan (string)
;;  #:region (BEG END)   -- only scan lines inside BEG-END regexps (strings)
;;  #:symrgx SYMRGX      -- symbolic regular expression with
;;                          first subexpression the key (see below)
;;
;; Both #:infile and #:symrgx are required; #:region is optional.
;; SYMRGX is a list whose elements are strings, symbols and a single
;; sublist whose single string element is the one to match the key.
;; A string element expands to itself.  A symbol expands like so:
;;
;;  def     "#define"
;;  ws      "[ \t]+"
;;  ws?     "[ \t]*"
;;  x       "0x[[:xdigit:]]+"
;;  =       equivalent to (ws? "=" ws?)
;;
;; Any other symbol is converted to a string via `symbol->string'.
;; The resulting list is prefixed with "^" and then concatenated to
;; form the (string) regexp.  Because the form:
;;
;;   (def ws (STRING) ws x)
;;
;; is very common, SYMRGX recognizes (#t STRING) as equivalent.

;;; Code:

(define-module (guile-baux fs2c)
  #:export (main)
  #:use-module ((guile-baux common) #:select (fs fse die check-hv qop<-args))
  #:use-module ((guile-baux forms-from) #:select (forms<-file
                                                  forms<-port))
  #:use-module ((guile-baux temporary-file) #:select (unique-i/o-file-port))
  #:use-module ((srfi srfi-13) #:select (string-join
                                         string-concatenate))
  #:use-module ((ice-9 rdelim) #:select (read-line))
  #:use-module ((ice-9 regex) #:select (match:substring))
  #:use-module ((ice-9 popen) #:select (open-output-pipe
                                        open-input-pipe
                                        close-pipe)))

(define (rx<-symbolic symbolic-regexp)

  (define (flatten ls)
    (string-concatenate (map defrag ls)))

  (define (defrag x)
    (cond ((symbol? x) (case x
                         ((def) "#define")
                         ((ws) "[ \t]+")
                         ((ws?) "[ \t]*")
                         ((x) "0x[[:xdigit:]]+")
                         ((=) (flatten '(ws? "=" ws?)))
                         (else (symbol->string x))))
          ((pair? x) (fs "(~A)" (car x)))
          ((string? x) x)
          (else (error "bad symbolic-regexp fragment:" x))))

  (flatten (cons "^" (if (eq? #t (car symbolic-regexp))
                         `(def ws ,(cdr symbolic-regexp) ws x)
                         symbolic-regexp))))

(define (scan-file filename symrgx region)
  (let* ((rv '())
         (p (open-input-file filename))
         (rx (make-regexp (rx<-symbolic symrgx)))
         (beg-rx (and region (make-regexp (car region))))
         (end-rx (and region (make-regexp (cadr region))))
         (in? #f))
    (let loop ((line (read-line p)))
      (or (eof-object? line)
          (number? in?)
          (begin
            (cond ((and end-rx in? (regexp-exec end-rx line))
                   (set! in? 0))
                  ((and beg-rx (not in?) (regexp-exec beg-rx line))
                   (set! in? #t))
                  ((and (or (and beg-rx in?)
                            (not beg-rx))
                        (regexp-exec rx line))
                   => (lambda (m)
                        (set! rv (cons (string->symbol
                                        (match:substring m 1))
                                       rv)))))
            (loop (read-line p)))))
    (close-port p)
    (reverse! rv)))

(define (C-program header found)

  (define (line s)
    (fs "printf (\"(#x%08lx\t. ~A)\\n\", ~A);" s s))

  (string-join
   `("#include <stdio.h>"
     ,(fs "#include <~A>" header)
     "int main (void)"
     "{"
     ,@(map line found)
     "return 0;"
     "}")
   "\n" 'suffix))

(define (sorted who header found)
  (let* ((p (unique-i/o-file-port (fs "./~A.vals-" (basename who))))
         (exe (port-filename p))
         (rv #f))
    (close-port p)
    (let ((p (open-output-pipe (fs "gcc -o ~A -x c -pipe -" exe))))
      (display (C-program header found) p)
      (close-pipe p))
    (let ((p (open-input-pipe exe)))
      (set! rv (sort (forms<-port p)
                     (lambda (a b)
                       (> (car a) (car b)))))
      (close-pipe p))
    (delete-file exe)
    rv))

(define (fs2c/qop qop)
  (let* ((specfile (if (null? (qop '()))
                       (die #f "missing input file")
                       (car (qop '()))))
         (partial (forms<-file specfile))
         (nick (car partial))
         (pretty (cadr partial))
         (saved-op (current-output-port))
         (op (or (qop 'output open-output-file)
                 saved-op)))

    (define qspec
      (let ((plist (cddr partial)))
        ;; qspec
        (lambda (kw)
          (and=> (memq kw plist) cadr))))

    (define (join how . ls)
      (let ((sep (if (pair? how) (car how) how))
            (grammar (if (pair? how) (cdr how) 'infix)))
        (string-join ls sep grammar)))

    (define (spew s)
      (display s op)
      (force-output op))

    (let* ((header (in-vicinity (or (qop 'include) "/usr/include")
                                (qspec #:infile)))
           (found (scan-file header
                             (qspec #:symrgx)
                             (qspec #:region)))
           (linear (sorted specfile header found))
           (len (length linear)))
      (spew (fs "static unsigned long ~A_values[~A] = {~%  ~A~%};~%~%"
                nick len
                (string-join (map (lambda (n)
                                    (fs "0x~A" (number->string n 16)))
                                  (map car linear))
                             ",\n  ")))
      (spew (fs "static aka_t ~A_names[~A] = {~%  ~A~%};~%~%"
                nick len
                (string-join (map (lambda (sym)
                                    (fs "{ ~S }"
                                        (symbol->string sym)))
                                  (map cdr linear))
                             ",\n  ")))
      (spew (join '("\n" . suffix)
                  (fs "static flagstash_t ~A_flagstash = {" nick)
                  (join ",\n  "
                        (fs "\"sdl-~A-flags\"" pretty)
                        (fs "~A" len)
                        (fs "~A_values" nick)
                        (fs "~A_names" nick))
                  "};")))
    (close-port op)))

(define (main args)
  (check-hv args '((package . "Guile-SDL")
                   (version . "1.0")
                   ;; Note: This is based on fspec2c 1.2 from
                   ;; Guile 1.4.x, but significantly stripped
                   ;; down and specialized for Guile-SDL.
                   (help . commentary)))
  (fs2c/qop
   (qop<-args args '((output  (single-char #\o) (value #t))
                     (include (single-char #\I) (value #t))))))

;;; fs2c ends here
