c2x that handles multiple SCM__I

[Thien-Thi Nguyen]

first a little background: c2x (and the version of guile-snarf upon
which the older c2x was modeled) uses the C preprocessor to extract and
format certain parts of macros (e.g., `SCM_DEFINE' and `SCM_SYMBOL')
defined in libguile/snarf.h[1].  on occaision you may wish to compose a
macro that uses the same underlying macros but tuned for your particular
needs, for example (from guile-sdl work-in-progress):

#define SCM_DEFINE_CONST(schemename,csymvalue) \
SCM_SYMBOL (scm_ ## csymvalue, schemename) \
; \
SCM_SNARF_INIT(\
 scm_variable_set (scm_ ## csymvalue, SCM_MAKINUM (csymvalue))\
)

this composition combines a pre-existing high-level macro SCM_SYMBOL
with a semicolon with a new SCM_SNARF_INIT macro.  if you examine
SCM_SYMBOL you see it is made of a SCM_SNARF_HERE and SCM_SNARF_INIT as
well, so it would be reasonable to consider SCM_DEFINE_CONST as the more
fundamental sequence: SCM_SNARF_HERE, SCM_SNARF_INIT, semicolon,
SCM_SNARF_INIT.  no problem, right?

well unfortunately, the C preprocessor is free to discard non-string
newlines, which means the SCM_DEFINE_CONST expansion which c2x sees is
on one line, which means in our example the SCM__I token that the
SCM_SNARF_INIT macro inserts for the benefit of c2x, occurs more than
once.  the result is that current c2x does not handle these so-called
"chained" SCM_SNARF_INIT expansions.

all this is to explain the rationale for the fixed c2x (to appear in
guile 1.4.1.97), below, which handles chained SCM_SNARF_INIT forms, as
long as they are properly separated by a semicolon.

thi


[1] http://www.glug.org/docbits/guile/Macros-c2x-recognizes.html

_____________________________________________________
#!/bin/sh
exec ${GUILE-guile} -e '(scripts c2x)' -s $0 "$@" # -*- scheme -*-
!#
;;; c2x --- Extract initialization code from .c files

;;      Copyright (C) 2003 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., 59 Temple Place, Suite 330,
;; Boston, MA 02111-1307 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 <address@hidden>

;;; 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)
  (format #f "-I ~A " (assq-ref %guile-build-info 'includedir)))
;;(define (jaminc) "")                    ; mask-zonk on install

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

(define init-rx (make-regexp "^ *SCM__I"))
(define more-rx (make-regexp "; *SCM__I"))
(define doc-rx  (make-regexp " *SCM__D"))

(define (snarf! outp args good! bad!)
  (let* ((inp (open-input-pipe (snarf-cmd args)))
         (next (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
                            ;; also handle chained (not at bol) SCM__I
                            ((and=> (regexp-exec more-rx look)
                                    (lambda (mm) (1+ (match:start mm 0))))
                             => (lambda (split)
                                  (set-cdr! tp (list (substring look 0 split)))
                                  (loop (substring look split)
                                        (cdr tp))))
                            (else
                             (set-cdr! tp (list (match:suffix m)))
                             (loop (next) (cdr tp)))))))
                   (else (loop (next) tp))))
           (for-each (lambda (line)
                       (write-line
                        (cond ((regexp-exec doc-rx line) => match:prefix)
                              (else line))
                        outp))
                     (cdr acc))         ;-( ignore nothing! ;-)
           (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-emtpy because file existence alone is
                ;; insufficient for some old pre-processors.)
                (let ((outp (open-output-file outfile)))
                  (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