Commit | Line | Data |
---|---|---|
13482e95 ML |
1 | #!/bin/sh |
2 | # aside from this initial boilerplate, this is actually -*- scheme -*- code | |
3 | main="(module-ref (resolve-module '(scripts snarf-check-and-output-texi)) 'main)" | |
8c914f6b | 4 | exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" |
13482e95 ML |
5 | !# |
6 | ;;; snarf-check-and-output-texi --- called by the doc snarfer. | |
7 | ||
8 | ;; Copyright (C) 2001 Free Software Foundation, Inc. | |
9 | ;; | |
10 | ;; This program is free software; you can redistribute it and/or | |
11 | ;; modify it under the terms of the GNU General Public License as | |
12 | ;; published by the Free Software Foundation; either version 2, or | |
13 | ;; (at your option) any later version. | |
14 | ;; | |
15 | ;; This program is distributed in the hope that it will be useful, | |
16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
18 | ;; General Public License for more details. | |
19 | ;; | |
20 | ;; You should have received a copy of the GNU General Public License | |
21 | ;; along with this software; see the file COPYING. If not, write to | |
22 | ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, | |
23 | ;; Boston, MA 02111-1307 USA | |
24 | ||
61897afe TTN |
25 | ;;; Author: Michael Livshin |
26 | ||
13482e95 ML |
27 | ;;; Code: |
28 | ||
29 | (define-module (scripts snarf-check-and-output-texi) | |
58e17e27 ML |
30 | :use-module (ice-9 streams) |
31 | :use-module (ice-9 match) | |
13482e95 ML |
32 | :export (snarf-check-and-output-texi)) |
33 | ||
58e17e27 ML |
34 | ;;; why aren't these in some module? |
35 | ||
36 | (define-macro (when cond . body) | |
37 | `(if ,cond (begin ,@body))) | |
38 | ||
39 | (define-macro (unless cond . body) | |
40 | `(if (not ,cond) (begin ,@body))) | |
41 | ||
cecb4a5e NJ |
42 | (define *manual-flag* #f) |
43 | ||
44 | (define (snarf-check-and-output-texi . flags) | |
45 | (if (memq '--manual flags) | |
46 | (set! *manual-flag* #t)) | |
58e17e27 ML |
47 | (process-stream (current-input-port))) |
48 | ||
49 | (define (process-stream port) | |
50 | (let loop ((input (stream-map (match-lambda | |
51 | (('id . s) | |
52 | (cons 'id (string->symbol s))) | |
53 | (('int_dec . s) | |
54 | (cons 'int (string->number s))) | |
55 | (('int_oct . s) | |
56 | (cons 'int (string->number s 8))) | |
57 | (('int_hex . s) | |
58 | (cons 'int (string->number s 16))) | |
59 | ((and x (? symbol?)) | |
60 | (cons x x)) | |
61 | ((and x (? string?)) | |
62 | (cons 'string x)) | |
63 | (x x)) | |
64 | (make-stream (lambda (s) | |
65 | (let loop ((s s)) | |
66 | (cond | |
67 | ((stream-null? s) #t) | |
68 | ((eq? 'eol (stream-car s)) | |
69 | (loop (stream-cdr s))) | |
70 | (else (cons (stream-car s) (stream-cdr s)))))) | |
71 | (port->stream port read))))) | |
aa3eb769 | 72 | |
58e17e27 ML |
73 | (unless (stream-null? input) |
74 | (let ((token (stream-car input))) | |
75 | (if (eq? (car token) 'snarf_cookie) | |
76 | (dispatch-top-cookie (stream-cdr input) | |
77 | loop) | |
78 | (loop (stream-cdr input))))))) | |
79 | ||
80 | (define (dispatch-top-cookie input cont) | |
aa3eb769 | 81 | |
58e17e27 ML |
82 | (when (stream-null? input) |
83 | (error 'syntax "premature end of file")) | |
aa3eb769 | 84 | |
58e17e27 ML |
85 | (let ((token (stream-car input))) |
86 | (cond | |
87 | ((eq? (car token) 'brace_open) | |
88 | (consume-multiline (stream-cdr input) | |
89 | cont)) | |
90 | (else | |
91 | (consume-upto-cookie process-singleline | |
92 | input | |
93 | cont))))) | |
94 | ||
95 | (define (consume-upto-cookie process input cont) | |
96 | (let loop ((acc '()) (input input)) | |
aa3eb769 | 97 | |
58e17e27 ML |
98 | (when (stream-null? input) |
99 | (error 'syntax "premature end of file in directive context")) | |
aa3eb769 | 100 | |
58e17e27 ML |
101 | (let ((token (stream-car input))) |
102 | (cond | |
103 | ((eq? (car token) 'snarf_cookie) | |
104 | (process (reverse! acc)) | |
105 | (cont (stream-cdr input))) | |
106 | ||
107 | (else (loop (cons token acc) (stream-cdr input))))))) | |
108 | ||
109 | (define (consume-multiline input cont) | |
110 | (begin-multiline) | |
111 | ||
112 | (let loop ((input input)) | |
113 | ||
114 | (when (stream-null? input) | |
115 | (error 'syntax "premature end of file in multiline context")) | |
aa3eb769 | 116 | |
58e17e27 ML |
117 | (let ((token (stream-car input))) |
118 | (cond | |
119 | ((eq? (car token) 'brace_close) | |
120 | (end-multiline) | |
121 | (cont (stream-cdr input))) | |
aa3eb769 | 122 | |
58e17e27 ML |
123 | (else (consume-upto-cookie process-multiline-directive |
124 | input | |
125 | loop)))))) | |
126 | ||
13482e95 ML |
127 | (define *file* #f) |
128 | (define *line* #f) | |
cecb4a5e | 129 | (define *c-function-name* #f) |
13482e95 ML |
130 | (define *function-name* #f) |
131 | (define *snarf-type* #f) | |
132 | (define *args* #f) | |
133 | (define *sig* #f) | |
134 | (define *docstring* #f) | |
135 | ||
58e17e27 ML |
136 | (define (begin-multiline) |
137 | (set! *file* #f) | |
138 | (set! *line* #f) | |
cecb4a5e | 139 | (set! *c-function-name* #f) |
58e17e27 ML |
140 | (set! *function-name* #f) |
141 | (set! *snarf-type* #f) | |
142 | (set! *args* #f) | |
143 | (set! *sig* #f) | |
144 | (set! *docstring* #f)) | |
aa3eb769 | 145 | |
8f85c0c6 | 146 | (define *primitive-deffnx-signature* "@deffnx {Scheme Procedure} ") |
cecb4a5e NJ |
147 | (define *primitive-deffnx-sig-length* (string-length *primitive-deffnx-signature*)) |
148 | ||
58e17e27 | 149 | (define (end-multiline) |
13482e95 ML |
150 | (let* ((req (car *sig*)) |
151 | (opt (cadr *sig*)) | |
152 | (var (caddr *sig*)) | |
153 | (all (+ req opt var))) | |
154 | (if (and (not (eqv? *snarf-type* 'register)) | |
155 | (not (= (length *args*) all))) | |
156 | (error (format #f "~A:~A: ~A's C implementation takes ~A args (should take ~A)" | |
157 | *file* *line* name (length *args*) all))) | |
158 | (let ((nice-sig | |
159 | (if (eq? *snarf-type* 'register) | |
160 | *function-name* | |
161 | (with-output-to-string | |
162 | (lambda () | |
163 | (format #t "~A" *function-name*) | |
fd7ec883 | 164 | (let loop-req ((args *args*) (r 0)) |
13482e95 ML |
165 | (if (< r req) |
166 | (begin | |
fd7ec883 ML |
167 | (format #t " ~A" (car args)) |
168 | (loop-req (cdr args) (+ 1 r))) | |
169 | (let loop-opt ((o 0) (args args) (tail '())) | |
170 | (if (< o opt) | |
171 | (begin | |
172 | (format #t " [~A" (car args)) | |
173 | (loop-opt (+ 1 o) (cdr args) (cons #\] tail))) | |
174 | (begin | |
175 | (if (> var 0) | |
176 | (format #t " . ~A" | |
177 | (car args))) | |
178 | (let loop-tail ((tail tail)) | |
179 | (if (not (null? tail)) | |
180 | (begin | |
181 | (format #t "~A" (car tail)) | |
cecb4a5e NJ |
182 | (loop-tail (cdr tail)))))))))))))) |
183 | (scm-deffnx | |
184 | (if (and *manual-flag* (eq? *snarf-type* 'primitive)) | |
185 | (with-output-to-string | |
186 | (lambda () | |
8f85c0c6 | 187 | (format #t "@deffnx {C Function} ~A (" *c-function-name*) |
cecb4a5e | 188 | (unless (null? *args*) |
8f85c0c6 | 189 | (format #t "~A" (car *args*)) |
cecb4a5e NJ |
190 | (let loop ((args (cdr *args*))) |
191 | (unless (null? args) | |
8f85c0c6 | 192 | (format #t ", ~A" (car args)) |
cecb4a5e NJ |
193 | (loop (cdr args))))) |
194 | (format #t ")\n"))) | |
195 | #f))) | |
13482e95 ML |
196 | (format #t "\n\f~A\n" *function-name*) |
197 | (format #t "@c snarfed from ~A:~A\n" *file* *line*) | |
8f85c0c6 | 198 | (format #t "@deffn {Scheme Procedure} ~A\n" nice-sig) |
cecb4a5e NJ |
199 | (let loop ((strings *docstring*) (scm-deffnx scm-deffnx)) |
200 | (cond ((null? strings)) | |
201 | ((or (not scm-deffnx) | |
202 | (and (>= (string-length (car strings)) | |
203 | *primitive-deffnx-sig-length*) | |
204 | (string=? (substring (car strings) | |
205 | 0 *primitive-deffnx-sig-length*) | |
206 | *primitive-deffnx-signature*))) | |
207 | (display (car strings)) | |
208 | (loop (cdr strings) scm-deffnx)) | |
209 | (else (display scm-deffnx) | |
210 | (loop strings #f)))) | |
211 | (display "\n") | |
cecb4a5e | 212 | (display "@end deffn\n")))) |
13482e95 | 213 | |
58e17e27 ML |
214 | (define (texi-quote s) |
215 | (let rec ((i 0)) | |
216 | (if (= i (string-length s)) | |
217 | "" | |
218 | (string-append (let ((ss (substring s i (+ i 1)))) | |
219 | (if (string=? ss "@") | |
220 | "@@" | |
221 | ss)) | |
222 | (rec (+ i 1)))))) | |
223 | ||
224 | (define (process-multiline-directive l) | |
225 | ||
226 | (define do-args | |
227 | (match-lambda | |
aa3eb769 | 228 | |
58e17e27 ML |
229 | (('(paren_close . paren_close)) |
230 | '()) | |
aa3eb769 | 231 | |
58e17e27 ML |
232 | (('(comma . comma) rest ...) |
233 | (do-args rest)) | |
aa3eb769 | 234 | |
58e17e27 ML |
235 | (('(id . SCM) ('id . name) rest ...) |
236 | (cons name (do-args rest))) | |
237 | ||
238 | (x (error (format #f "invalid argument syntax: ~A" (map cdr x)))))) | |
239 | ||
240 | (define do-arglist | |
241 | (match-lambda | |
aa3eb769 | 242 | |
58e17e27 ML |
243 | (('(paren_open . paren_open) '(id . void) '(paren_close . paren_close)) |
244 | '()) | |
aa3eb769 | 245 | |
58e17e27 ML |
246 | (('(paren_open . paren_open) rest ...) |
247 | (do-args rest)) | |
aa3eb769 | 248 | |
58e17e27 ML |
249 | (x (error (format #f "invalid arglist syntax: ~A" (map cdr x)))))) |
250 | ||
251 | (define do-command | |
252 | (match-lambda | |
aa3eb769 | 253 | |
cecb4a5e NJ |
254 | (('cname ('id . name)) |
255 | (set! *c-function-name* (texi-quote (symbol->string name)))) | |
256 | ||
58e17e27 ML |
257 | (('fname ('string . name)) |
258 | (set! *function-name* (texi-quote name))) | |
aa3eb769 | 259 | |
58e17e27 ML |
260 | (('type ('id . type)) |
261 | (set! *snarf-type* type)) | |
262 | ||
263 | (('type ('int . num)) | |
264 | (set! *snarf-type* num)) | |
265 | ||
266 | (('location ('string . file) ('int . line)) | |
267 | (set! *file* file) | |
268 | (set! *line* line)) | |
269 | ||
270 | (('arglist rest ...) | |
271 | (set! *args* (do-arglist rest))) | |
272 | ||
273 | (('argsig ('int . req) ('int . opt) ('int . var)) | |
274 | (set! *sig* (list req opt var))) | |
275 | ||
276 | (x (error (format #f "unknown doc attribute: ~A" x))))) | |
277 | ||
278 | (define do-directive | |
279 | (match-lambda | |
aa3eb769 | 280 | |
58e17e27 ML |
281 | ((('id . command) rest ...) |
282 | (do-command (cons command rest))) | |
aa3eb769 | 283 | |
58e17e27 ML |
284 | ((('string . string) ...) |
285 | (set! *docstring* string)) | |
aa3eb769 | 286 | |
58e17e27 ML |
287 | (x (error (format #f "unknown doc attribute syntax: ~A" x))))) |
288 | ||
289 | (do-directive l)) | |
290 | ||
291 | (define (process-singleline l) | |
aa3eb769 | 292 | |
58e17e27 ML |
293 | (define do-argpos |
294 | (match-lambda | |
295 | ((('id . name) ('int . pos) ('int . line)) | |
296 | (let ((idx (list-index *args* name))) | |
297 | (when idx | |
298 | (unless (= (+ idx 1) pos) | |
299 | (display (format #f "~A:~A: wrong position for argument ~A: ~A (should be ~A)\n" | |
4d772ae2 ML |
300 | *file* line name pos (+ idx 1)) |
301 | (current-error-port)))))) | |
58e17e27 | 302 | (x #f))) |
aa3eb769 | 303 | |
58e17e27 ML |
304 | (define do-command |
305 | (match-lambda | |
306 | (('(id . argpos) rest ...) | |
307 | (do-argpos rest)) | |
308 | (x (error (format #f "unknown check: ~A" x))))) | |
aa3eb769 | 309 | |
58e17e27 ML |
310 | (when *function-name* |
311 | (do-command l))) | |
13482e95 ML |
312 | |
313 | (define main snarf-check-and-output-texi) |