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)" | |
4 | exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@" | |
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 | ||
13482e95 ML |
25 | ;;; Code: |
26 | ||
27 | (define-module (scripts snarf-check-and-output-texi) | |
58e17e27 ML |
28 | :use-module (ice-9 streams) |
29 | :use-module (ice-9 match) | |
13482e95 ML |
30 | :export (snarf-check-and-output-texi)) |
31 | ||
58e17e27 ML |
32 | ;;; why aren't these in some module? |
33 | ||
34 | (define-macro (when cond . body) | |
35 | `(if ,cond (begin ,@body))) | |
36 | ||
37 | (define-macro (unless cond . body) | |
38 | `(if (not ,cond) (begin ,@body))) | |
39 | ||
40 | (define (snarf-check-and-output-texi) | |
41 | (process-stream (current-input-port))) | |
42 | ||
43 | (define (process-stream port) | |
44 | (let loop ((input (stream-map (match-lambda | |
45 | (('id . s) | |
46 | (cons 'id (string->symbol s))) | |
47 | (('int_dec . s) | |
48 | (cons 'int (string->number s))) | |
49 | (('int_oct . s) | |
50 | (cons 'int (string->number s 8))) | |
51 | (('int_hex . s) | |
52 | (cons 'int (string->number s 16))) | |
53 | ((and x (? symbol?)) | |
54 | (cons x x)) | |
55 | ((and x (? string?)) | |
56 | (cons 'string x)) | |
57 | (x x)) | |
58 | (make-stream (lambda (s) | |
59 | (let loop ((s s)) | |
60 | (cond | |
61 | ((stream-null? s) #t) | |
62 | ((eq? 'eol (stream-car s)) | |
63 | (loop (stream-cdr s))) | |
64 | (else (cons (stream-car s) (stream-cdr s)))))) | |
65 | (port->stream port read))))) | |
aa3eb769 | 66 | |
58e17e27 ML |
67 | (unless (stream-null? input) |
68 | (let ((token (stream-car input))) | |
69 | (if (eq? (car token) 'snarf_cookie) | |
70 | (dispatch-top-cookie (stream-cdr input) | |
71 | loop) | |
72 | (loop (stream-cdr input))))))) | |
73 | ||
74 | (define (dispatch-top-cookie input cont) | |
aa3eb769 | 75 | |
58e17e27 ML |
76 | (when (stream-null? input) |
77 | (error 'syntax "premature end of file")) | |
aa3eb769 | 78 | |
58e17e27 ML |
79 | (let ((token (stream-car input))) |
80 | (cond | |
81 | ((eq? (car token) 'brace_open) | |
82 | (consume-multiline (stream-cdr input) | |
83 | cont)) | |
84 | (else | |
85 | (consume-upto-cookie process-singleline | |
86 | input | |
87 | cont))))) | |
88 | ||
89 | (define (consume-upto-cookie process input cont) | |
90 | (let loop ((acc '()) (input input)) | |
aa3eb769 | 91 | |
58e17e27 ML |
92 | (when (stream-null? input) |
93 | (error 'syntax "premature end of file in directive context")) | |
aa3eb769 | 94 | |
58e17e27 ML |
95 | (let ((token (stream-car input))) |
96 | (cond | |
97 | ((eq? (car token) 'snarf_cookie) | |
98 | (process (reverse! acc)) | |
99 | (cont (stream-cdr input))) | |
100 | ||
101 | (else (loop (cons token acc) (stream-cdr input))))))) | |
102 | ||
103 | (define (consume-multiline input cont) | |
104 | (begin-multiline) | |
105 | ||
106 | (let loop ((input input)) | |
107 | ||
108 | (when (stream-null? input) | |
109 | (error 'syntax "premature end of file in multiline context")) | |
aa3eb769 | 110 | |
58e17e27 ML |
111 | (let ((token (stream-car input))) |
112 | (cond | |
113 | ((eq? (car token) 'brace_close) | |
114 | (end-multiline) | |
115 | (cont (stream-cdr input))) | |
aa3eb769 | 116 | |
58e17e27 ML |
117 | (else (consume-upto-cookie process-multiline-directive |
118 | input | |
119 | loop)))))) | |
120 | ||
13482e95 ML |
121 | (define *file* #f) |
122 | (define *line* #f) | |
123 | (define *function-name* #f) | |
124 | (define *snarf-type* #f) | |
125 | (define *args* #f) | |
126 | (define *sig* #f) | |
127 | (define *docstring* #f) | |
128 | ||
58e17e27 ML |
129 | (define (begin-multiline) |
130 | (set! *file* #f) | |
131 | (set! *line* #f) | |
132 | (set! *function-name* #f) | |
133 | (set! *snarf-type* #f) | |
134 | (set! *args* #f) | |
135 | (set! *sig* #f) | |
136 | (set! *docstring* #f)) | |
aa3eb769 | 137 | |
58e17e27 | 138 | (define (end-multiline) |
13482e95 ML |
139 | (let* ((req (car *sig*)) |
140 | (opt (cadr *sig*)) | |
141 | (var (caddr *sig*)) | |
142 | (all (+ req opt var))) | |
143 | (if (and (not (eqv? *snarf-type* 'register)) | |
144 | (not (= (length *args*) all))) | |
145 | (error (format #f "~A:~A: ~A's C implementation takes ~A args (should take ~A)" | |
146 | *file* *line* name (length *args*) all))) | |
147 | (let ((nice-sig | |
148 | (if (eq? *snarf-type* 'register) | |
149 | *function-name* | |
150 | (with-output-to-string | |
151 | (lambda () | |
152 | (format #t "~A" *function-name*) | |
153 | (let loop-req ((r 0)) | |
154 | (if (< r req) | |
155 | (begin | |
156 | (format #t " ~A" (list-ref *args* r)) | |
157 | (loop-req (+ 1 r))) | |
158 | (begin | |
159 | (if (> opt 0) | |
160 | (format #t "~A[" (if (> req 0) " " ""))) | |
161 | (let loop-opt ((o 0) (space #f)) | |
162 | (if (< o opt) | |
163 | (begin | |
164 | (format #t "~A~A" (if space " " "") | |
165 | (list-ref *args* (+ r o))) | |
166 | (loop-opt (+ 1 o) #t)) | |
167 | (begin | |
168 | (if (> opt 0) | |
169 | (format #t "]")) | |
170 | (if (> var 0) | |
4d772ae2 | 171 | (format #t " . ~A" |
13482e95 ML |
172 | (car (last-pair *args*))))))))))))))) |
173 | (format #t "\n\f~A\n" *function-name*) | |
174 | (format #t "@c snarfed from ~A:~A\n" *file* *line*) | |
175 | (format #t "@deffn primitive ~A\n" nice-sig) | |
176 | (let loop ((strings *docstring*)) | |
177 | (if (not (null? strings)) | |
178 | (begin | |
179 | (display (car strings)) | |
180 | (loop (cdr strings))))) | |
181 | (display "\n@end deffn\n")))) | |
182 | ||
58e17e27 ML |
183 | (define (texi-quote s) |
184 | (let rec ((i 0)) | |
185 | (if (= i (string-length s)) | |
186 | "" | |
187 | (string-append (let ((ss (substring s i (+ i 1)))) | |
188 | (if (string=? ss "@") | |
189 | "@@" | |
190 | ss)) | |
191 | (rec (+ i 1)))))) | |
192 | ||
193 | (define (process-multiline-directive l) | |
194 | ||
195 | (define do-args | |
196 | (match-lambda | |
aa3eb769 | 197 | |
58e17e27 ML |
198 | (('(paren_close . paren_close)) |
199 | '()) | |
aa3eb769 | 200 | |
58e17e27 ML |
201 | (('(comma . comma) rest ...) |
202 | (do-args rest)) | |
aa3eb769 | 203 | |
58e17e27 ML |
204 | (('(id . SCM) ('id . name) rest ...) |
205 | (cons name (do-args rest))) | |
206 | ||
207 | (x (error (format #f "invalid argument syntax: ~A" (map cdr x)))))) | |
208 | ||
209 | (define do-arglist | |
210 | (match-lambda | |
aa3eb769 | 211 | |
58e17e27 ML |
212 | (('(paren_open . paren_open) '(id . void) '(paren_close . paren_close)) |
213 | '()) | |
aa3eb769 | 214 | |
58e17e27 ML |
215 | (('(paren_open . paren_open) rest ...) |
216 | (do-args rest)) | |
aa3eb769 | 217 | |
58e17e27 ML |
218 | (x (error (format #f "invalid arglist syntax: ~A" (map cdr x)))))) |
219 | ||
220 | (define do-command | |
221 | (match-lambda | |
aa3eb769 | 222 | |
58e17e27 ML |
223 | (('fname ('string . name)) |
224 | (set! *function-name* (texi-quote name))) | |
aa3eb769 | 225 | |
58e17e27 ML |
226 | (('type ('id . type)) |
227 | (set! *snarf-type* type)) | |
228 | ||
229 | (('type ('int . num)) | |
230 | (set! *snarf-type* num)) | |
231 | ||
232 | (('location ('string . file) ('int . line)) | |
233 | (set! *file* file) | |
234 | (set! *line* line)) | |
235 | ||
236 | (('arglist rest ...) | |
237 | (set! *args* (do-arglist rest))) | |
238 | ||
239 | (('argsig ('int . req) ('int . opt) ('int . var)) | |
240 | (set! *sig* (list req opt var))) | |
241 | ||
242 | (x (error (format #f "unknown doc attribute: ~A" x))))) | |
243 | ||
244 | (define do-directive | |
245 | (match-lambda | |
aa3eb769 | 246 | |
58e17e27 ML |
247 | ((('id . command) rest ...) |
248 | (do-command (cons command rest))) | |
aa3eb769 | 249 | |
58e17e27 ML |
250 | ((('string . string) ...) |
251 | (set! *docstring* string)) | |
aa3eb769 | 252 | |
58e17e27 ML |
253 | (x (error (format #f "unknown doc attribute syntax: ~A" x))))) |
254 | ||
255 | (do-directive l)) | |
256 | ||
257 | (define (process-singleline l) | |
aa3eb769 | 258 | |
58e17e27 ML |
259 | (define do-argpos |
260 | (match-lambda | |
261 | ((('id . name) ('int . pos) ('int . line)) | |
262 | (let ((idx (list-index *args* name))) | |
263 | (when idx | |
264 | (unless (= (+ idx 1) pos) | |
265 | (display (format #f "~A:~A: wrong position for argument ~A: ~A (should be ~A)\n" | |
4d772ae2 ML |
266 | *file* line name pos (+ idx 1)) |
267 | (current-error-port)))))) | |
58e17e27 | 268 | (x #f))) |
aa3eb769 | 269 | |
58e17e27 ML |
270 | (define do-command |
271 | (match-lambda | |
272 | (('(id . argpos) rest ...) | |
273 | (do-argpos rest)) | |
274 | (x (error (format #f "unknown check: ~A" x))))) | |
aa3eb769 | 275 | |
58e17e27 ML |
276 | (when *function-name* |
277 | (do-command l))) | |
13482e95 ML |
278 | |
279 | (define main snarf-check-and-output-texi) |