| 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)) |