Commit | Line | Data |
---|---|---|
9ddacf86 KN |
1 | ;;; "schmooz.scm" Program for extracting texinfo comments from Scheme. |
2 | ;;; Copyright (C) 1998, 2000 Radey Shouman and Aubrey Jaffer. | |
3 | ; | |
4 | ;Permission to copy this software, to redistribute it, and to use it | |
5 | ;for any purpose is granted, subject to the following restrictions and | |
6 | ;understandings. | |
7 | ; | |
8 | ;1. Any copy made of this software must include this copyright notice | |
9 | ;in full. | |
10 | ; | |
11 | ;2. I have made no warrantee or representation that the operation of | |
12 | ;this software will be error-free, and I am under no obligation to | |
13 | ;provide any services, by way of maintenance, update, or otherwise. | |
14 | ; | |
15 | ;3. In conjunction with products arising from the use of this | |
16 | ;material, there shall be no use of my name in any advertising, | |
17 | ;promotional, or sales literature without prior written consent in | |
18 | ;each case. | |
19 | ||
20 | ;;$Header: /home/ludo/src/guile/gitification/guile-cvs/guile/guile/guile-vm/module/slib/schmooz.scm,v 1.1 2001/04/14 11:24:46 kei Exp $ | |
21 | ;;$Name: $ | |
22 | ||
23 | ;;; REPORT an error or warning | |
24 | (define report | |
25 | (lambda args | |
26 | (display *scheme-source-name*) | |
27 | (display ": In function `") | |
28 | (display *procedure*) | |
29 | (display "': ") | |
30 | (newline) | |
31 | ||
32 | (display *derived-txi-name*) | |
33 | (display ": ") | |
34 | (display *output-line*) | |
35 | (display ": warning: ") | |
36 | (apply qreport args))) | |
37 | ||
38 | (define qreport | |
39 | (lambda args | |
40 | (for-each (lambda (x) (write x) (display #\ )) args) | |
41 | (newline))) | |
42 | ||
43 | (require 'common-list-functions) ;some | |
44 | (require 'string-search) | |
45 | (require 'fluid-let) | |
46 | (require 'line-i/o) ;read-line | |
47 | (require 'filename) | |
48 | (require 'scanf) | |
49 | ;;(require 'debug) (set! *qp-width* 100) (define qreport qpn) | |
50 | ||
51 | ;;; This allows us to test without generating files | |
52 | (define *scheme-source* (current-input-port)) | |
53 | (define *scheme-source-name* "stdin") | |
54 | (define *derived-txi* (current-output-port)) | |
55 | (define *derived-txi-name* "?") | |
56 | ||
57 | (define *procedure* #f) | |
58 | (define *output-line* 0) | |
59 | ||
60 | (define CONTLINE -80) | |
61 | ||
62 | ;;; OUT indents and displays the arguments | |
63 | (define (out indent . args) | |
64 | (cond ((>= indent 0) | |
65 | (newline *derived-txi*) | |
66 | (set! *output-line* (+ 1 *output-line*)) | |
67 | (do ((j indent (- j 8))) | |
68 | ((> 8 j) | |
69 | (do ((i j (- i 1))) | |
70 | ((>= 0 i)) | |
71 | (display #\ *derived-txi*))) | |
72 | (display #\ *derived-txi*)))) | |
73 | (for-each (lambda (a) | |
74 | (cond ((symbol? a) | |
75 | (display a *derived-txi*)) | |
76 | ((string? a) | |
77 | (display a *derived-txi*) | |
78 | ; (cond ((string-index a #\newline) | |
79 | ; (set! *output-line* (+ 1 *output-line*)) | |
80 | ; (report "newline in string" a))) | |
81 | ) | |
82 | (else | |
83 | (display a *derived-txi*)))) | |
84 | args)) | |
85 | ||
86 | ;; LINE is a string, ISTRT the index in LINE at which to start. | |
87 | ;; Returns a list (next-char-number . list-of-tokens). | |
88 | ;; arguments look like: | |
89 | ;; "(arg1 arg2)" or "{arg1,arg2}" or the whole line is split | |
90 | ;; into whitespace separated tokens. | |
91 | (define (parse-args line istrt) | |
92 | (define (tok1 istrt close sep? splice) | |
93 | (let loop-args ((istrt istrt) | |
94 | (args '())) | |
95 | (let loop ((iend istrt)) | |
96 | (cond ((>= iend (string-length line)) | |
97 | (if close | |
98 | (slib:error close "not found in" line) | |
99 | (cons iend | |
100 | (reverse | |
101 | (if (> iend istrt) | |
102 | (cons (substring line istrt iend) args) | |
103 | args))))) | |
104 | ((eqv? close (string-ref line iend)) | |
105 | (cons (+ iend 1) | |
106 | (reverse (if (> iend istrt) | |
107 | (cons (substring line istrt iend) args) | |
108 | args)))) | |
109 | ((sep? (string-ref line iend)) | |
110 | (let ((arg (and (> iend istrt) | |
111 | (substring line istrt iend)))) | |
112 | (if (equal? arg splice) | |
113 | (let ((rest (tok1 (+ iend 1) close sep? splice))) | |
114 | (cons (car rest) | |
115 | (append args (cadr rest)))) | |
116 | (loop-args (+ iend 1) | |
117 | (if arg | |
118 | (cons arg args) | |
119 | args))))) | |
120 | (else | |
121 | (loop (+ iend 1))))))) | |
122 | (let skip ((istrt istrt)) | |
123 | (cond ((>= istrt (string-length line)) (cons istrt '())) | |
124 | ((char-whitespace? (string-ref line istrt)) | |
125 | (skip (+ istrt 1))) | |
126 | ((eqv? #\{ (string-ref line istrt)) | |
127 | (tok1 (+ 1 istrt) #\} (lambda (c) (eqv? c #\,)) #f)) | |
128 | ((eqv? #\( (string-ref line istrt)) | |
129 | (tok1 (+ 1 istrt) #\) char-whitespace? ".")) | |
130 | (else | |
131 | (tok1 istrt #f char-whitespace? #f))))) | |
132 | ||
133 | ||
134 | ;; Substitute @ macros in string LINE. | |
135 | ;; Returns a list, the first element is the substituted version | |
136 | ;; of LINE, the rest are lists beginning with '@dfn or '@args | |
137 | ;; and followed by the arguments that were passed to those macros. | |
138 | ;; MACS is an alist of (macro-name . macro-value) pairs. | |
139 | (define (substitute-macs line macs) | |
140 | (define (get-word i) | |
141 | (let loop ((j (+ i 1))) | |
142 | (cond ((>= j (string-length line)) | |
143 | (substring line i j)) | |
144 | ((or (char-alphabetic? (string-ref line j)) | |
145 | (char-numeric? (string-ref line j))) | |
146 | (loop (+ j 1))) | |
147 | (else (substring line i j))))) | |
148 | (let loop ((istrt 0) | |
149 | (i 0) | |
150 | (res '())) | |
151 | (cond ((>= i (string-length line)) | |
152 | (list | |
153 | (apply string-append | |
154 | (reverse | |
155 | (cons (substring line istrt (string-length line)) | |
156 | res))))) | |
157 | ((char=? #\@ (string-ref line i)) | |
158 | (let* ((w (get-word i)) | |
159 | (symw (string->symbol w))) | |
160 | (cond ((eq? '@cname symw) | |
161 | (let ((args (parse-args | |
162 | line (+ i (string-length w))))) | |
163 | (cond ((and args (= 2 (length args))) | |
164 | (loop (car args) (car args) | |
165 | (cons | |
166 | (string-append | |
167 | "@code{" (cadr args) "}") | |
168 | (cons (substring line istrt i) res)))) | |
169 | (else | |
170 | (report "@cname wrong number of args" line) | |
171 | (loop istrt (+ i (string-length w)) res))))) | |
172 | ((eq? '@dfn symw) | |
173 | (let* ((args (parse-args | |
174 | line (+ i (string-length w)))) | |
175 | (inxt (car args)) | |
176 | (rest (loop inxt inxt | |
177 | (cons (substring line istrt inxt) | |
178 | res)))) | |
179 | (cons (car rest) | |
180 | (cons (cons '@dfn (cdr args)) | |
181 | (cdr rest))))) | |
182 | ((eq? '@args symw) | |
183 | (let* ((args (parse-args | |
184 | line (+ i (string-length w)))) | |
185 | (inxt (car args)) | |
186 | (rest (loop inxt inxt res))) | |
187 | (cons (car rest) | |
188 | (cons (cons '@args (cdr args)) | |
189 | (cdr rest))))) | |
190 | ((assq symw macs) => | |
191 | (lambda (s) | |
192 | (loop (+ i (string-length w)) | |
193 | (+ i (string-length w)) | |
194 | (cons (cdr s) | |
195 | (cons (substring line istrt i) res))))) | |
196 | (else (loop istrt (+ i (string-length w)) res))))) | |
197 | (else (loop istrt (+ i 1) res))))) | |
198 | ||
199 | ||
200 | (define (sexp-def sexp) | |
201 | (and (pair? sexp) | |
202 | (memq (car sexp) '(DEFINE DEFVAR DEFCONST DEFINE-SYNTAX DEFMACRO)) | |
203 | (car sexp))) | |
204 | ||
205 | (define def->var-name cadr) | |
206 | ||
207 | (define (def->args sexp) | |
208 | (define name (cadr sexp)) | |
209 | (define (body forms) | |
210 | (if (pair? forms) | |
211 | (if (null? (cdr forms)) | |
212 | (form (car forms)) | |
213 | (body (cdr forms))) | |
214 | #f)) | |
215 | (define (form sexp) | |
216 | (if (pair? sexp) | |
217 | (case (car sexp) | |
218 | ((LAMBDA) (cons name (cadr sexp))) | |
219 | ((BEGIN) (body (cdr sexp))) | |
220 | ((LET LET* LETREC) | |
221 | (if (or (null? (cadr sexp)) | |
222 | (pair? (cadr sexp))) | |
223 | (body (cddr sexp)) | |
224 | (body (cdddr sexp)))) ;named LET | |
225 | (else #f)) | |
226 | #f)) | |
227 | (case (car sexp) | |
228 | ((DEFINE) (if (pair? name) | |
229 | name | |
230 | (form (caddr sexp)))) | |
231 | ((DEFINE-SYNTAX) '()) | |
232 | ((DEFMACRO) (cons (cadr sexp) (caddr sexp))) | |
233 | ((DEFVAR DEFCONST) #f) | |
234 | (else (slib:error 'schmooz "doesn't look like definition" sexp)))) | |
235 | ||
236 | ;; Generate alist of argument macro definitions. | |
237 | ;; If ARGS is a symbol or string, then the definitions will be used in a | |
238 | ;; `defvar', if ARGS is a (possibly improper) list, they will be used in | |
239 | ;; a `defun'. | |
240 | (define (scheme-args->macros args) | |
241 | (define (arg->string a) | |
242 | (if (string? a) a (symbol->string a))) | |
243 | (define (arg->macros arg i) | |
244 | (let ((s (number->string i)) | |
245 | (m (string-append "@var{" (arg->string arg) "}"))) | |
246 | (list (cons (string->symbol (string-append "@" s)) m) | |
247 | (cons (string->symbol (string-append "@arg" s)) m)))) | |
248 | (let* ((fun? (pair? args)) | |
249 | (arg0 (if fun? (car args) args)) | |
250 | (args (if fun? (cdr args) '()))) | |
251 | (let ((m0 (string-append | |
252 | (if fun? "@code{" "@var{") (arg->string arg0) "}"))) | |
253 | (append | |
254 | (list (cons '@arg0 m0) (cons '@0 m0)) | |
255 | (let recur ((i 1) | |
256 | (args args)) | |
257 | (cond ((null? args) '()) | |
258 | ((or (symbol? args) ;Rest list | |
259 | (string? args)) | |
260 | (arg->macros args i)) | |
261 | (else | |
262 | (append (arg->macros (car args) i) | |
263 | (recur (+ i 1) (cdr args)))))))))) | |
264 | ||
265 | ;; Extra processing to be done for @dfn | |
266 | (define (out-cindex arg) | |
267 | (out 0 "@cindex " arg)) | |
268 | ||
269 | ;; ARGS looks like the cadr of a function definition: | |
270 | ;; (fun-name arg1 arg2 ...) | |
271 | (define (schmooz-fun defop args body xdefs) | |
272 | (define (out-header args op) | |
273 | (let ((fun (car args)) | |
274 | (args (cdr args))) | |
275 | (out 0 #\@ op #\space fun) | |
276 | (let loop ((args args)) | |
277 | (cond ((null? args)) | |
278 | ((symbol? args) | |
279 | (loop (symbol->string args))) | |
280 | ((string? args) | |
281 | (out CONTLINE " " | |
282 | (let ((n (- (string-length args) 1))) | |
283 | (if (eqv? #\s (string-ref args n)) | |
284 | (substring args 0 n) | |
285 | args)) | |
286 | " @dots{}")) | |
287 | ((pair? args) | |
288 | (out CONTLINE " " | |
289 | (if (or (eq? '... (car args)) | |
290 | (equal? "..." (car args))) | |
291 | "@dots{}" | |
292 | (car args))) | |
293 | (loop (cdr args))) | |
294 | (else (slib:error 'schmooz-fun args)))))) | |
295 | (let* ((mac-list (scheme-args->macros args)) | |
296 | (ops (case defop | |
297 | ((DEFINE-SYNTAX) '("defspec" . "defspecx")) | |
298 | ((DEFMACRO) '("defmac" . "defmacx")) | |
299 | (else '("defun" . "defunx"))))) | |
300 | (out-header args (car ops)) | |
301 | (let loop ((xdefs xdefs)) | |
302 | (cond ((pair? xdefs) | |
303 | (out-header (car xdefs) (cdr ops)) | |
304 | (loop (cdr xdefs))))) | |
305 | (for-each (lambda (subl) | |
306 | (out 0 (car subl)) | |
307 | (for-each (lambda (l) | |
308 | (case (car l) | |
309 | ((@dfn) | |
310 | (out-cindex (cadr l))) | |
311 | ((@args) | |
312 | (out-header | |
313 | (cons (car args) (cdr l)) | |
314 | (cdr ops))))) | |
315 | (cdr subl))) | |
316 | (map (lambda (bl) | |
317 | (substitute-macs bl mac-list)) | |
318 | body)) | |
319 | (out 0 "@end " (car ops)) | |
320 | (out 0))) | |
321 | ||
322 | (define (schmooz-var defop name body xdefs) | |
323 | (let* ((mac-list (scheme-args->macros name))) | |
324 | (out 0 "@defvar " name) | |
325 | (let loop ((xdefs xdefs)) | |
326 | (cond ((pair? xdefs) | |
327 | (out 0 "@defvarx " (car xdefs)) | |
328 | (loop (cdr xdefs))))) | |
329 | (for-each (lambda (subl) | |
330 | (out 0 (car subl)) | |
331 | (for-each (lambda (l) | |
332 | (case (car l) | |
333 | ((@dfn) (out-cindex (cadr l))) | |
334 | (else | |
335 | (report "bad macro" l)))) | |
336 | (cdr subl))) | |
337 | (map (lambda (bl) | |
338 | (substitute-macs bl mac-list)) | |
339 | body)) | |
340 | (out 0 "@end defvar") | |
341 | (out 0))) | |
342 | ||
343 | ;;; SCHMOOZ files. | |
344 | (define schmooz | |
345 | (let* ((scheme-file? (filename:match-ci?? "*??scm")) | |
346 | (txi-file? (filename:match-ci?? "*??txi")) | |
347 | (texi-file? (let ((tex? (filename:match-ci?? "*??tex")) | |
348 | (texi? (filename:match-ci?? "*??texi"))) | |
349 | (lambda (filename) (or (txi-file? filename) | |
350 | (tex? filename) | |
351 | (texi? filename))))) | |
352 | (txi->scm (filename:substitute?? "*txi" "*scm")) | |
353 | (scm->txi (filename:substitute?? "*scm" "*txi"))) | |
354 | (define (schmooz-texi-file file) | |
355 | (call-with-input-file file | |
356 | (lambda (port) | |
357 | (do ((pos (find-string-from-port? "@include" port) | |
358 | (find-string-from-port? "@include" port))) | |
359 | ((not pos)) | |
360 | (let ((fname #f)) | |
361 | (cond ((not (eqv? 1 (fscanf port " %s" fname)))) | |
362 | ((not (txi-file? fname))) | |
363 | ((not (file-exists? (txi->scm fname)))) | |
364 | (else (schmooz (txi->scm fname))))))))) | |
365 | (define (schmooz-scm-file file txi-name) | |
366 | (display "Schmoozing ") (write file) | |
367 | (display " -> ") (write txi-name) (newline) | |
368 | (fluid-let ((*scheme-source* (open-input-file file)) | |
369 | (*scheme-source-name* file) | |
370 | (*derived-txi* (open-output-file txi-name)) | |
371 | (*derived-txi-name* txi-name)) | |
372 | (set! *output-line* 1) | |
373 | (cond ((scheme-file? file)) | |
374 | (else (find-string-from-port? ";" *scheme-source* #\;) | |
375 | (read-line *scheme-source*))) | |
376 | (schmooz-tops schmooz-top) | |
377 | (close-input-port *scheme-source*) | |
378 | (close-output-port *derived-txi*))) | |
379 | (lambda files | |
380 | (for-each (lambda (file) | |
381 | (define sl (string-length file)) | |
382 | (cond ((texi-file? file) (schmooz-texi-file file)) | |
383 | ((scheme-file? file) | |
384 | (schmooz-scm-file file (scm->txi file))) | |
385 | (else (schmooz-scm-file | |
386 | file (string-append file ".txi"))))) | |
387 | files)))) | |
388 | ||
389 | ;;; SCHMOOZ-TOPS - schmooz top level forms. | |
390 | (define (schmooz-tops schmooz-top) | |
391 | (let ((doc-lines '()) | |
392 | (doc-args #f)) | |
393 | (define (skip-ws line istrt) | |
394 | (do ((i istrt (+ i 1))) | |
395 | ((or (>= i (string-length line)) | |
396 | (not (memv (string-ref line i) | |
397 | '(#\space #\tab #\;)))) | |
398 | (substring line i (string-length line))))) | |
399 | ||
400 | (define (tok1 line) | |
401 | (let loop ((i 0)) | |
402 | (cond ((>= i (string-length line)) line) | |
403 | ((or (char-whitespace? (string-ref line i)) | |
404 | (memv (string-ref line i) '(#\; #\( #\{))) | |
405 | (substring line 0 i)) | |
406 | (else (loop (+ i 1)))))) | |
407 | ||
408 | (define (read-cmt-line) | |
409 | (cond ((eqv? #\; (peek-char *scheme-source*)) | |
410 | (read-char *scheme-source*) | |
411 | (read-cmt-line)) | |
412 | (else (read-line *scheme-source*)))) | |
413 | ||
414 | (define (read-meta-cmt) | |
415 | (let skip ((metarg? #f)) | |
416 | (let ((c (read-char *scheme-source*))) | |
417 | (case c | |
418 | ((#\newline) (if metarg? (skip #t))) | |
419 | ((#\\) (skip #t)) | |
420 | ((#\!) (cond ((eqv? #\# (peek-char *scheme-source*)) | |
421 | (read-char *scheme-source*) | |
422 | (if #f #f)) | |
423 | (else | |
424 | (skip metarg?)))) | |
425 | (else | |
426 | (if (char? c) (skip metarg?) c)))))) | |
427 | ||
428 | (define (lp c) | |
429 | (cond ((eof-object? c) | |
430 | (cond ((pair? doc-lines) | |
431 | (report "No definition found for @body doc lines" | |
432 | (reverse doc-lines))))) | |
433 | ((eqv? c #\newline) | |
434 | (read-char *scheme-source*) | |
435 | (set! *output-line* (+ 1 *output-line*)) | |
436 | ;;(newline *derived-txi*) | |
437 | (lp (peek-char *scheme-source*))) | |
438 | ((char-whitespace? c) | |
439 | (write-char (read-char *scheme-source*) *derived-txi*) | |
440 | (lp (peek-char *scheme-source*))) | |
441 | ((char=? c #\;) | |
442 | (c-cmt c)) | |
443 | ((char=? c #\#) | |
444 | (read-char *scheme-source*) | |
445 | (if (eqv? #\! (peek-char *scheme-source*)) | |
446 | (read-meta-cmt) | |
447 | (report "misread sharp object" (peek-char *scheme-source*))) | |
448 | (lp (peek-char *scheme-source*))) | |
449 | (else | |
450 | (sx)))) | |
451 | ||
452 | (define (sx) | |
453 | (let* ((s1 (read *scheme-source*)) | |
454 | ;;Read all forms separated only by single newlines | |
455 | ;;and trailing whitespace. | |
456 | (ss (let recur () | |
457 | (let ((c (peek-char *scheme-source*))) | |
458 | (cond ((eqv? c #\newline) | |
459 | (read-char *scheme-source*) | |
460 | (if (eqv? #\( (peek-char *scheme-source*)) | |
461 | (let ((s (read *scheme-source*))) | |
462 | (cons s (recur))) | |
463 | '())) | |
464 | ((char-whitespace? c) | |
465 | (read-char *scheme-source*) | |
466 | (recur)) | |
467 | (else '())))))) | |
468 | (cond ((eof-object? s1)) | |
469 | (else | |
470 | (schmooz-top s1 ss (reverse doc-lines) doc-args) | |
471 | (set! doc-lines '()) | |
472 | (set! doc-args #f) | |
473 | (lp (peek-char *scheme-source*)))))) | |
474 | ||
475 | (define (out-cmt line) | |
476 | (let ((subl (substitute-macs line '()))) | |
477 | (display (car subl) *derived-txi*) | |
478 | (for-each | |
479 | (lambda (l) | |
480 | (case (car l) | |
481 | ((@dfn) | |
482 | (out-cindex (cadr l))) | |
483 | (else | |
484 | (report "bad macro" line)))) | |
485 | (cdr subl)) | |
486 | (newline *derived-txi*))) | |
487 | ||
488 | ;;Comments not transcribed to generated Texinfo files. | |
489 | (define (c-cmt c) | |
490 | (cond ((eof-object? c) (lp c)) | |
491 | ((eqv? #\; c) | |
492 | (read-char *scheme-source*) | |
493 | (c-cmt (peek-char *scheme-source*))) | |
494 | ;; Escape to start Texinfo comments | |
495 | ((eqv? #\@ c) | |
496 | (let* ((line (read-line *scheme-source*)) | |
497 | (tok (tok1 line))) | |
498 | (cond ((or (string=? tok "@body") | |
499 | (string=? tok "@text")) | |
500 | (set! doc-lines | |
501 | (cons (skip-ws line (string-length tok)) | |
502 | doc-lines)) | |
503 | (body-cmt (peek-char *scheme-source*))) | |
504 | ((string=? tok "@args") | |
505 | (let ((args | |
506 | (parse-args line (string-length tok)))) | |
507 | (set! doc-args (cdr args)) | |
508 | (set! doc-lines | |
509 | (cons (skip-ws line (car args)) | |
510 | doc-lines))) | |
511 | (body-cmt (peek-char *scheme-source*))) | |
512 | (else | |
513 | (out-cmt (if (string=? tok "@") | |
514 | (skip-ws line 1) | |
515 | line)) | |
516 | (doc-cmt (peek-char *scheme-source*)))))) | |
517 | ;; Transcribe the comment line to C source file. | |
518 | (else | |
519 | (read-line *scheme-source*) | |
520 | (lp (peek-char *scheme-source*))))) | |
521 | ||
522 | ;;Comments incorporated in generated Texinfo files. | |
523 | ;;Continue adding lines to DOC-LINES until a non-comment | |
524 | ;;line is reached (may be a blank line). | |
525 | (define (body-cmt c) | |
526 | (cond ((eof-object? c) (lp c)) | |
527 | ((eqv? #\; c) | |
528 | (set! doc-lines (cons (read-cmt-line) doc-lines)) | |
529 | (body-cmt (peek-char *scheme-source*))) | |
530 | ((eqv? c #\newline) | |
531 | (read-char *scheme-source*) | |
532 | (lp (peek-char *scheme-source*))) | |
533 | ;; Allow whitespace before ; in doc comments. | |
534 | ((char-whitespace? c) | |
535 | (read-char *scheme-source*) | |
536 | (body-cmt (peek-char *scheme-source*))) | |
537 | (else | |
538 | (lp (peek-char *scheme-source*))))) | |
539 | ||
540 | ;;Comments incorporated in generated Texinfo files. | |
541 | ;;Transcribe comments to current position in Texinfo file | |
542 | ;;until a non-comment line is reached (may be a blank line). | |
543 | (define (doc-cmt c) | |
544 | (cond ((eof-object? c) (lp c)) | |
545 | ((eqv? #\; c) | |
546 | (out-cmt (read-cmt-line)) | |
547 | (doc-cmt (peek-char *scheme-source*))) | |
548 | ((eqv? c #\newline) | |
549 | (read-char *scheme-source*) | |
550 | (newline *derived-txi*) | |
551 | (lp (peek-char *scheme-source*))) | |
552 | ;; Allow whitespace before ; in doc comments. | |
553 | ((char-whitespace? c) | |
554 | (read-char *scheme-source*) | |
555 | (doc-cmt (peek-char *scheme-source*))) | |
556 | (else | |
557 | (newline *derived-txi*) | |
558 | (lp (peek-char *scheme-source*))))) | |
559 | (lp (peek-char *scheme-source*)))) | |
560 | ||
561 | (define (schmooz-top-doc-begin def1 defs doc proc-args) | |
562 | (let ((op1 (sexp-def def1))) | |
563 | (cond | |
564 | ((not op1) | |
565 | (or (null? doc) | |
566 | (report "SCHMOOZ: no definition found for Texinfo documentation" | |
567 | doc (car defs)))) | |
568 | (else | |
569 | (let* ((args (def->args def1)) | |
570 | (args (if proc-args | |
571 | (cons (if args (car args) (def->var-name def1)) | |
572 | proc-args) | |
573 | args))) | |
574 | (let loop ((ss defs) | |
575 | (smatch (list (or args (def->var-name def1))))) | |
576 | (if (null? ss) | |
577 | (let ((smatch (reverse smatch))) | |
578 | ((if args schmooz-fun schmooz-var) | |
579 | op1 (car smatch) doc (cdr smatch))) | |
580 | (if (eq? op1 (sexp-def (car ss))) | |
581 | (let ((a (def->args (car ss)))) | |
582 | (loop (cdr ss) | |
583 | (if args | |
584 | (if a | |
585 | (cons a smatch) | |
586 | smatch) | |
587 | (if a | |
588 | smatch | |
589 | (cons (def->var-name (car ss)) | |
590 | smatch))))))))))))) | |
591 | ||
592 | ;;; SCHMOOZ-TOP - schmooz top level form sexp. | |
593 | (define (schmooz-top sexp1 sexps doc proc-args) | |
594 | (cond ((not (pair? sexp1))) | |
595 | ((pair? sexps) | |
596 | (if (pair? doc) | |
597 | (schmooz-top-doc-begin sexp1 sexps doc proc-args)) | |
598 | (set! doc '())) | |
599 | (else | |
600 | (case (car sexp1) | |
601 | ((LOAD REQUIRE) ;If you redefine load, you lose | |
602 | #f) | |
603 | ((BEGIN) | |
604 | (schmooz-top (cadr sexp1) '() doc proc-args) | |
605 | (set! doc '()) | |
606 | (for-each (lambda (s) | |
607 | (schmooz-top s '() doc #f)) | |
608 | (cddr sexp1))) | |
609 | ((DEFVAR DEFINE DEFCONST DEFINE-SYNTAX DEFMACRO) | |
610 | (let* ((args (def->args sexp1)) | |
611 | (args (if proc-args | |
612 | (cons (if args (car args) (cadr sexp1)) | |
613 | proc-args) | |
614 | args))) | |
615 | (cond (args | |
616 | (set! *procedure* (car args)) | |
617 | (cond ((pair? doc) | |
618 | (schmooz-fun (car sexp1) args doc '()) | |
619 | (set! doc '())))) | |
620 | (else | |
621 | (cond ((pair? doc) | |
622 | (schmooz-var (car sexp1) (cadr sexp1) doc '()) | |
623 | (set! doc '())))))))))) | |
624 | (or (null? doc) | |
625 | (report | |
626 | "SCHMOOZ: no definition found for Texinfo documentation" | |
627 | doc sexp)) | |
628 | (set! *procedure* #f)) |