utilities/gwave-doc-snarf.in

   1 #!@GUILE@ \
   2 -e main -s
   3 !#
   4 ;
   5 ; gwave-doc-snarf - extract embedded documentation from the output of
   6 ; the C preprocessor run on C code that uses the xsnarf.h macros
   7 ;
   8 (use-modules (ice-9 getopt-long)
   9              (ice-9 common-list)
  10              (ice-9 format)
  11              (ice-9 regex)
  12              (srfi srfi-13))
  13
  14 (debug-enable 'debug 'backtrace)
  15 (read-enable 'positions)
  16
  17 ;(display "gwave-doc-snarf running\n")
  18
  19 (define opts (getopt-long (program-arguments)
  20              `((verbose      (single-char #\v))
  21                (debug        (single-char #\x))
  22                )))
  23
  24 (define opt-verbose
  25   (let ((a (assq 'verbose opts)))
  26     (if a
  27         (cdr a)
  28         #f)))
  29
  30 (define opt-debug
  31   (let ((a (assq 'debug opts)))
  32     (if a
  33         (cdr a)
  34         #f)))
  35
  36 (define cmdline-files (pick string? (assq '() opts)))
  37
  38 ;-----------------------------------------------------------------------------
  39
  40 (define (main a)
  41   (for-each
  42    (lambda (f)
  43      (if opt-debug (format #t "~a:\n" f))
  44      (let ((fp (open-file f "r")))
  45        (with-input-from-port fp
  46          (lambda ()
  47            (process-file f))))
  48      )
  49    cmdline-files)
  50 )
  51
  52 (define (process-docentry e)
  53   (let*((doctype (cadr (assoc 'type e)))
  54         (name (cadr (assoc 'fname e)))
  55         (doclist (cdr (assoc 'doc e)))
  56         (argstr (cadr (assoc 'arglist e)))
  57         (src-file (cadr (assoc 'location e)))
  58         (src-line (caddr (assoc 'location e)))
  59         (arglist (split-arglist argstr))
  60         )
  61     (if opt-debug (begin
  62                     (format #t "name: ~s\n" name)
  63                     (format #t "type: ~s\n" doctype)
  64                     (format #t "location: ~s\n" (cdr (assoc 'location e)))
  65                     (format #t "arglist: ~s\n" argstr)
  66                     (format #t "argsig: ~s\n" (cdr (assoc 'argsig e)))
  67                     (format #t "doc: ~s\n" doclist)))
  68     (display "\f\n")
  69     (cond
  70      ((eq? doctype 'primitive)
  71       (format #t "Procedure: (~a~a)\n" name (string-join arglist " " 'prefix)))
  72      ((eq? doctype 'vcell)
  73       (format #t "Variable: ~a\n" name))
  74      ((eq? doctype 'concept)
  75       (format #t "Concept: ~a\n" name))
  76      ((eq? doctype 'hook)
  77       (format #t "Hook: (~a~a)\n" name (string-join arglist " " 'prefix))))
  78
  79     (for-each (lambda (s)
  80                 (format #t "~a\n" s))
  81               doclist)
  82     (format #t "[~a:~d]\n" src-file src-line)))
  83
  84 ;
  85 ; Split a string STR into a list of strings, on boundaries determined by
  86 ; where the regexp RE matches.
  87 ;
  88 (define (split re str)
  89   (let ((r (make-regexp re)))
  90     (let loop ((s str)
  91                (result '()))
  92       (let ((m (regexp-exec r s)))
  93         (if (not m)
  94             (if (< 0 (string-length s))
  95                 (reverse! (cons s result))
  96                 (reverse! result))
  97             (if (< 0 (string-length (match:prefix m)))
  98                 (loop (match:suffix m) (cons (match:prefix m) result))
  99                 (loop (match:suffix m) result)))
 100         ))))
 101
 102 ; Use the read-hash-extend facility to add a syntax for constant
 103 ; regular expressions that are to be compiled once when read in,
 104 ; instead of during the normal flow of execution.   This can let loops
 105 ; that repeatedly use a constant regexp be optimized without moving the
 106 ; expression's definition far away from its use.
 107 ;
 108 ; With this hash-extension, these two expressions behave identicaly:
 109 ;
 110 ; (regexp-exec (make-regexp "de+") "abcdeeef"))
 111 ; (regexp-exec #+"de+" "abcdeeef")
 112 ;
 113 (read-hash-extend #\+ (lambda (c port)
 114                   (let ((s (read port)))
 115                     (if (string? s)
 116                         (make-regexp s)
 117                         (error "bad #+ value; string expected")))))
 118
 119 ;
 120 ; split the C argument-list string, which looks like "(SCM foo, SCM bar)"
 121 ; into a list of strings, each containing the name of one argument.
 122 ;
 123 (define (split-arglist s)
 124   (let* (
 125          (s1 (regexp-substitute/global #f #+"^[ \t]*\\(" s 'post))
 126          (s2 (regexp-substitute/global #f #+"\\)[ \t]*$" s1 'pre))
 127          (s3 (regexp-substitute/global #f #+"[ \t]*SCM[ \t]*" s2 'pre 'post))
 128          )
 129       (split "," s3)))
 130
 131
 132 (define (process-file fname)
 133   (let ((rcaret (make-regexp "^\\^\\^")))
 134     (do ((line (read-line)
 135                (read-line)))
 136         ((eof-object? line) #f)
 137       (if (regexp-exec rcaret line)
 138           (begin
 139             (call-with-input-string
 140              (string-drop line 2)
 141              (lambda (p)
 142                (let ((slist (read p)))
 143                  (process-docentry slist)
 144                  ))))))))
 145
 146 ;-----------------------------------------------------------------------------