1 ;;; snarf-check-and-output-texi --- called by the doc snarfer.
3 ;; Copyright (C) 2001, 2002, 2006, 2011, 2014 Free Software Foundation, Inc.
5 ;; This program is free software; you can redistribute it and/or
6 ;; modify it under the terms of the GNU Lesser General Public License
7 ;; as published by the Free Software Foundation; either version 3, or
8 ;; (at your option) any later version.
10 ;; This program is distributed in the hope that it will be useful,
11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;; Lesser General Public License for more details.
15 ;; You should have received a copy of the GNU Lesser General Public
16 ;; License along with this software; see the file COPYING.LESSER. If
17 ;; not, write to the Free Software Foundation, Inc., 51 Franklin
18 ;; Street, Fifth Floor, Boston, MA 02110-1301 USA
20 ;;; Author: Michael Livshin
24 (define-module (scripts snarf-check-and-output-texi)
25 :use-module (ice-9 streams)
26 :use-module (ice-9 match)
27 :export (snarf-check-and-output-texi))
29 (define %include-in-guild-list #f)
30 (define %summary "Transform snarfed .doc files into texinfo documentation.")
32 ;;; why aren't these in some module?
34 (define-macro (when cond . body)
35 `(if ,cond (begin ,@body)))
37 (define-macro (unless cond . body)
38 `(if (not ,cond) (begin ,@body)))
40 (define *manual-flag* #f)
42 (define (snarf-check-and-output-texi . flags)
43 (if (member "--manual" flags)
44 (set! *manual-flag* #t))
45 (process-stream (current-input-port)))
47 (define (process-stream port)
48 (let loop ((input (stream-map (match-lambda
50 (cons 'id (string->symbol s)))
52 (cons 'int (string->number s)))
54 (cons 'int (string->number s 8)))
56 (cons 'int (string->number s 16)))
62 (make-stream (lambda (s)
66 ((memq (stream-car s) '(eol hash))
67 (loop (stream-cdr s)))
68 (else (cons (stream-car s) (stream-cdr s))))))
69 (port->stream port read)))))
71 (unless (stream-null? input)
72 (let ((token (stream-car input)))
73 (if (eq? (car token) 'snarf_cookie)
74 (dispatch-top-cookie (stream-cdr input)
76 (loop (stream-cdr input)))))))
78 (define (dispatch-top-cookie input cont)
80 (when (stream-null? input)
81 (error 'syntax "premature end of file"))
83 (let ((token (stream-car input)))
85 ((eq? (car token) 'brace_open)
86 (consume-multiline (stream-cdr input)
89 (consume-upto-cookie process-singleline
93 (define (consume-upto-cookie process input cont)
94 (let loop ((acc '()) (input input))
96 (when (stream-null? input)
97 (error 'syntax "premature end of file in directive context"))
99 (let ((token (stream-car input)))
101 ((eq? (car token) 'snarf_cookie)
102 (process (reverse! acc))
103 (cont (stream-cdr input)))
105 (else (loop (cons token acc) (stream-cdr input)))))))
107 (define (consume-multiline input cont)
110 (let loop ((input input))
112 (when (stream-null? input)
113 (error 'syntax "premature end of file in multiline context"))
115 (let ((token (stream-car input)))
117 ((eq? (car token) 'brace_close)
119 (cont (stream-cdr input)))
121 (else (consume-upto-cookie process-multiline-directive
127 (define *c-function-name* #f)
128 (define *function-name* #f)
129 (define *snarf-type* #f)
132 (define *docstring* #f)
134 (define (begin-multiline)
137 (set! *c-function-name* #f)
138 (set! *function-name* #f)
139 (set! *snarf-type* #f)
142 (set! *docstring* #f))
144 (define *primitive-deffnx-signature* "@deffnx {Scheme Procedure} ")
145 (define *primitive-deffnx-sig-length* (string-length *primitive-deffnx-signature*))
147 (define (end-multiline)
148 (let* ((req (car *sig*))
151 (all (+ req opt var)))
152 (if (and (not (eqv? *snarf-type* 'register))
153 (not (= (length *args*) all)))
154 (error (format #f "~A:~A: ~A's C implementation takes ~A args (should take ~A)"
155 *file* *line* *function-name* (length *args*) all)))
157 (if (eq? *snarf-type* 'register)
159 (with-output-to-string
161 (format #t "~A" *function-name*)
162 (let loop-req ((args *args*) (r 0))
165 (format #t " ~A" (car args))
166 (loop-req (cdr args) (+ 1 r)))
167 (let loop-opt ((o 0) (args args) (tail '()))
170 (format #t " [~A" (car args))
171 (loop-opt (+ 1 o) (cdr args) (cons #\] tail)))
176 (let loop-tail ((tail tail))
177 (if (not (null? tail))
179 (format #t "~A" (car tail))
180 (loop-tail (cdr tail))))))))))))))
182 (if (and *manual-flag* (eq? *snarf-type* 'primitive))
183 (with-output-to-string
185 (format #t "@deffnx {C Function} ~A (" *c-function-name*)
186 (unless (null? *args*)
187 (format #t "~A" (car *args*))
188 (let loop ((args (cdr *args*)))
190 (format #t ", ~A" (car args))
194 (format #t "\n
\f~A\n" *function-name*)
195 (format #t "@c snarfed from ~A:~A\n" *file* *line*)
196 (format #t "@deffn {Scheme Procedure} ~A\n" nice-sig)
197 (let loop ((strings *docstring*) (scm-deffnx scm-deffnx))
198 (cond ((null? strings))
199 ((or (not scm-deffnx)
200 (and (>= (string-length (car strings))
201 *primitive-deffnx-sig-length*)
202 (string=? (substring (car strings)
203 0 *primitive-deffnx-sig-length*)
204 *primitive-deffnx-signature*)))
205 (display (car strings))
206 (loop (cdr strings) scm-deffnx))
207 (else (display scm-deffnx)
210 (display "@end deffn\n"))))
212 (define (texi-quote s)
214 (if (= i (string-length s))
216 (string-append (let ((ss (substring s i (+ i 1))))
217 (if (string=? ss "@")
222 (define (process-multiline-directive l)
227 (('(paren_close . paren_close))
230 (('(comma . comma) rest ...)
233 (('(id . SCM) ('id . name) rest ...)
234 (cons name (do-args rest)))
236 (x (error (format #f "invalid argument syntax: ~A" (map cdr x))))))
241 (('(paren_open . paren_open) '(id . void) '(paren_close . paren_close))
244 (('(paren_open . paren_open) rest ...)
247 (x (error (format #f "invalid arglist syntax: ~A" (map cdr x))))))
252 (('cname ('id . name))
253 (set! *c-function-name* (texi-quote (symbol->string name))))
255 (('fname ('string . name) ...)
256 (set! *function-name* (texi-quote (apply string-append name))))
258 (('type ('id . type))
259 (set! *snarf-type* type))
261 (('type ('int . num))
262 (set! *snarf-type* num))
264 (('location ('string . file) ('int . line))
269 (set! *args* (do-arglist rest)))
271 (('argsig ('int . req) ('int . opt) ('int . var))
272 (set! *sig* (list req opt var)))
274 (x (error (format #f "unknown doc attribute: ~A" x)))))
279 ((('id . command) rest ...)
280 (do-command (cons command rest)))
282 ((('string . string) ...)
283 (set! *docstring* string))
285 (x (error (format #f "unknown doc attribute syntax: ~A" x)))))
289 (define (process-singleline l)
293 ((('id . name) ('int . pos) ('int . line))
294 (let ((idx (list-index *args* name)))
296 (unless (= (+ idx 1) pos)
297 (display (format #f "~A:~A: wrong position for argument ~A: ~A (should be ~A)\n"
298 *file* line name pos (+ idx 1))
299 (current-error-port))))))
304 (('(id . argpos) rest ...)
306 (x (error (format #f "unknown check: ~A" x)))))
308 (when *function-name*
311 (define main snarf-check-and-output-texi)