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;-----------------------------------------------------------------------------
147