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} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
6
;;; snarf-check-and-output-texi --- called by the doc snarfer.
8
;; Copyright (C) 2001, 2002, 2006 Free Software Foundation, Inc.
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.
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.
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., 51 Franklin Street, Fifth Floor,
23
;; Boston, MA 02110-1301 USA
25
;;; Author: Michael Livshin
29
(define-module (scripts snarf-check-and-output-texi)
30
:use-module (ice-9 streams)
31
:use-module (ice-9 match)
32
:export (snarf-check-and-output-texi))
34
;;; why aren't these in some module?
36
(define-macro (when cond . body)
37
`(if ,cond (begin ,@body)))
39
(define-macro (unless cond . body)
40
`(if (not ,cond) (begin ,@body)))
42
(define *manual-flag* #f)
44
(define (snarf-check-and-output-texi . flags)
45
(if (member "--manual" flags)
46
(set! *manual-flag* #t))
47
(process-stream (current-input-port)))
49
(define (process-stream port)
50
(let loop ((input (stream-map (match-lambda
52
(cons 'id (string->symbol s)))
54
(cons 'int (string->number s)))
56
(cons 'int (string->number s 8)))
58
(cons 'int (string->number s 16)))
64
(make-stream (lambda (s)
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)))))
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)
78
(loop (stream-cdr input)))))))
80
(define (dispatch-top-cookie input cont)
82
(when (stream-null? input)
83
(error 'syntax "premature end of file"))
85
(let ((token (stream-car input)))
87
((eq? (car token) 'brace_open)
88
(consume-multiline (stream-cdr input)
91
(consume-upto-cookie process-singleline
95
(define (consume-upto-cookie process input cont)
96
(let loop ((acc '()) (input input))
98
(when (stream-null? input)
99
(error 'syntax "premature end of file in directive context"))
101
(let ((token (stream-car input)))
103
((eq? (car token) 'snarf_cookie)
104
(process (reverse! acc))
105
(cont (stream-cdr input)))
107
(else (loop (cons token acc) (stream-cdr input)))))))
109
(define (consume-multiline input cont)
112
(let loop ((input input))
114
(when (stream-null? input)
115
(error 'syntax "premature end of file in multiline context"))
117
(let ((token (stream-car input)))
119
((eq? (car token) 'brace_close)
121
(cont (stream-cdr input)))
123
(else (consume-upto-cookie process-multiline-directive
129
(define *c-function-name* #f)
130
(define *function-name* #f)
131
(define *snarf-type* #f)
134
(define *docstring* #f)
136
(define (begin-multiline)
139
(set! *c-function-name* #f)
140
(set! *function-name* #f)
141
(set! *snarf-type* #f)
144
(set! *docstring* #f))
146
(define *primitive-deffnx-signature* "@deffnx {Scheme Procedure} ")
147
(define *primitive-deffnx-sig-length* (string-length *primitive-deffnx-signature*))
149
(define (end-multiline)
150
(let* ((req (car *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* *function-name* (length *args*) all)))
159
(if (eq? *snarf-type* 'register)
161
(with-output-to-string
163
(format #t "~A" *function-name*)
164
(let loop-req ((args *args*) (r 0))
167
(format #t " ~A" (car args))
168
(loop-req (cdr args) (+ 1 r)))
169
(let loop-opt ((o 0) (args args) (tail '()))
172
(format #t " [~A" (car args))
173
(loop-opt (+ 1 o) (cdr args) (cons #\] tail)))
178
(let loop-tail ((tail tail))
179
(if (not (null? tail))
181
(format #t "~A" (car tail))
182
(loop-tail (cdr tail))))))))))))))
184
(if (and *manual-flag* (eq? *snarf-type* 'primitive))
185
(with-output-to-string
187
(format #t "@deffnx {C Function} ~A (" *c-function-name*)
188
(unless (null? *args*)
189
(format #t "~A" (car *args*))
190
(let loop ((args (cdr *args*)))
192
(format #t ", ~A" (car args))
196
(format #t "\n ~A\n" *function-name*)
197
(format #t "@c snarfed from ~A:~A\n" *file* *line*)
198
(format #t "@deffn {Scheme Procedure} ~A\n" nice-sig)
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)
212
(display "@end deffn\n"))))
214
(define (texi-quote s)
216
(if (= i (string-length s))
218
(string-append (let ((ss (substring s i (+ i 1))))
219
(if (string=? ss "@")
224
(define (process-multiline-directive l)
229
(('(paren_close . paren_close))
232
(('(comma . comma) rest ...)
235
(('(id . SCM) ('id . name) rest ...)
236
(cons name (do-args rest)))
238
(x (error (format #f "invalid argument syntax: ~A" (map cdr x))))))
243
(('(paren_open . paren_open) '(id . void) '(paren_close . paren_close))
246
(('(paren_open . paren_open) rest ...)
249
(x (error (format #f "invalid arglist syntax: ~A" (map cdr x))))))
254
(('cname ('id . name))
255
(set! *c-function-name* (texi-quote (symbol->string name))))
257
(('fname ('string . name) ...)
258
(set! *function-name* (texi-quote (apply string-append name))))
260
(('type ('id . type))
261
(set! *snarf-type* type))
263
(('type ('int . num))
264
(set! *snarf-type* num))
266
(('location ('string . file) ('int . line))
271
(set! *args* (do-arglist rest)))
273
(('argsig ('int . req) ('int . opt) ('int . var))
274
(set! *sig* (list req opt var)))
276
(x (error (format #f "unknown doc attribute: ~A" x)))))
281
((('id . command) rest ...)
282
(do-command (cons command rest)))
284
((('string . string) ...)
285
(set! *docstring* string))
287
(x (error (format #f "unknown doc attribute syntax: ~A" x)))))
291
(define (process-singleline l)
295
((('id . name) ('int . pos) ('int . line))
296
(let ((idx (list-index *args* name)))
298
(unless (= (+ idx 1) pos)
299
(display (format #f "~A:~A: wrong position for argument ~A: ~A (should be ~A)\n"
300
*file* line name pos (+ idx 1))
301
(current-error-port))))))
306
(('(id . argpos) rest ...)
308
(x (error (format #f "unknown check: ~A" x)))))
310
(when *function-name*
313
(define main snarf-check-and-output-texi)
added
removed
scripts/snarf-check-and-output-texi
