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\f~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)