diff options
Diffstat (limited to 'schmooz.scm')
| -rw-r--r-- | schmooz.scm | 605 |
1 files changed, 605 insertions, 0 deletions
diff --git a/schmooz.scm b/schmooz.scm new file mode 100644 index 0000000..9664ac3 --- /dev/null +++ b/schmooz.scm @@ -0,0 +1,605 @@ +;;; schmooz.scm: Program for extracting texinfo comments from Scheme. +;;; Copyright (C) 1998 Radey Shouman and Aubrey Jaffer. +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +;;$Header: /usr/local/cvsroot/slib/schmooz.scm,v 1.7 1998/09/10 20:34:26 radey Exp $ +;;$Name: $ + +;;; REPORT an error or warning +(define report + (lambda args + (display *scheme-source-name*) + (display ": In function `") + (display *procedure*) + (display "': ") + (newline) + + (display *derived-txi-name*) + (display ": ") + (display *output-line*) + (display ": warning: ") + (apply qreport args))) + +(define qreport + (lambda args + (for-each (lambda (x) (write x) (display #\ )) args) + (newline))) + +(require 'common-list-functions) ;some +(require 'string-search) +(require 'fluid-let) +(require 'line-i/o) ;read-line +(require 'filename) +(require 'scanf) +;;(require 'debug) (set! *qp-width* 100) (define qreport qpn) + +;;; This allows us to test without generating files +(define *scheme-source* (current-input-port)) +(define *scheme-source-name* "stdin") +(define *derived-txi* (current-output-port)) +(define *derived-txi-name* "?") + +(define *procedure* #f) +(define *output-line* 0) + +(define CONTLINE -80) + +;;; OUT indents and displays the arguments +(define (out indent . args) + (cond ((>= indent 0) + (newline *derived-txi*) + (set! *output-line* (+ 1 *output-line*)) + (do ((j indent (- j 8))) + ((> 8 j) + (do ((i j (- i 1))) + ((>= 0 i)) + (display #\ *derived-txi*))) + (display #\ *derived-txi*)))) + (for-each (lambda (a) + (cond ((symbol? a) + (display a *derived-txi*)) + ((string? a) + (display a *derived-txi*) + #+f + (cond ((string-index a #\nl) + (set! *output-line* (+ 1 *output-line*)) + (report "newline in string" a)))) + (else + (display a *derived-txi*)))) + args)) + +;; LINE is a string, ISTRT the index in LINE at which to start. +;; Returns a list (next-char-number . list-of-tokens). +;; arguments look like: +;; "(arg1 arg2)" or "{arg1,arg2}" or the whole line is split +;; into whitespace separated tokens. +(define (parse-args line istrt) + (define (tok1 istrt close sep? splice) + (let loop-args ((istrt istrt) + (args '())) + (let loop ((iend istrt)) + (cond ((>= iend (string-length line)) + (if close + (slib:error close "not found in" line) + (cons iend + (reverse + (if (> iend istrt) + (cons (substring line istrt iend) args) + args))))) + ((eqv? close (string-ref line iend)) + (cons (+ iend 1) + (reverse (if (> iend istrt) + (cons (substring line istrt iend) args) + args)))) + ((sep? (string-ref line iend)) + (let ((arg (and (> iend istrt) + (substring line istrt iend)))) + (if (equal? arg splice) + (let ((rest (tok1 (+ iend 1) close sep? splice))) + (cons (car rest) + (append args (cadr rest)))) + (loop-args (+ iend 1) + (if arg + (cons arg args) + args))))) + (else + (loop (+ iend 1))))))) + (let skip ((istrt istrt)) + (cond ((>= istrt (string-length line)) (cons istrt '())) + ((char-whitespace? (string-ref line istrt)) + (skip (+ istrt 1))) + ((eqv? #\{ (string-ref line istrt)) + (tok1 (+ 1 istrt) #\} (lambda (c) (eqv? c #\,)) #f)) + ((eqv? #\( (string-ref line istrt)) + (tok1 (+ 1 istrt) #\) char-whitespace? ".")) + (else + (tok1 istrt #f char-whitespace? #f))))) + + +;; Substitute @ macros in string LINE. +;; Returns a list, the first element is the substituted version +;; of LINE, the rest are lists beginning with '@dfn or '@args +;; and followed by the arguments that were passed to those macros. +;; MACS is an alist of (macro-name . macro-value) pairs. +(define (substitute-macs line macs) + (define (get-word i) + (let loop ((j (+ i 1))) + (cond ((>= j (string-length line)) + (substring line i j)) + ((or (char-alphabetic? (string-ref line j)) + (char-numeric? (string-ref line j))) + (loop (+ j 1))) + (else (substring line i j))))) + (let loop ((istrt 0) + (i 0) + (res '())) + (cond ((>= i (string-length line)) + (list + (apply string-append + (reverse + (cons (substring line istrt (string-length line)) + res))))) + ((char=? #\@ (string-ref line i)) + (let* ((w (get-word i)) + (symw (string->symbol w))) + (cond ((eq? '@cname symw) + (let ((args (parse-args + line (+ i (string-length w))))) + (cond ((and args (= 2 (length args))) + (loop (car args) (car args) + (cons + (string-append + "@code{" (cadr args) "}") + (cons (substring line istrt i) res)))) + (else + (report "@cname wrong number of args" line) + (loop istrt (+ i (string-length w)) res))))) + ((eq? '@dfn symw) + (let* ((args (parse-args + line (+ i (string-length w)))) + (inxt (car args)) + (rest (loop inxt inxt + (cons (substring line istrt inxt) + res)))) + (cons (car rest) + (cons (cons '@dfn (cdr args)) + (cdr rest))))) + ((eq? '@args symw) + (let* ((args (parse-args + line (+ i (string-length w)))) + (inxt (car args)) + (rest (loop inxt inxt res))) + (cons (car rest) + (cons (cons '@args (cdr args)) + (cdr rest))))) + ((assq symw macs) => + (lambda (s) + (loop (+ i (string-length w)) + (+ i (string-length w)) + (cons (cdr s) + (cons (substring line istrt i) res))))) + (else (loop istrt (+ i (string-length w)) res))))) + (else (loop istrt (+ i 1) res))))) + + +(define (sexp-def sexp) + (and (pair? sexp) + (memq (car sexp) '(DEFINE DEFVAR DEFCONST DEFINE-SYNTAX DEFMACRO)) + (car sexp))) + +(define def->var-name cadr) + +(define (def->args sexp) + (define name (cadr sexp)) + (define (body forms) + (if (pair? forms) + (if (null? (cdr forms)) + (form (car forms)) + (body (cdr forms))) + #f)) + (define (form sexp) + (if (pair? sexp) + (case (car sexp) + ((LAMBDA) (cons name (cadr sexp))) + ((BEGIN) (body (cdr sexp))) + ((LET LET* LETREC) + (if (or (null? (cadr sexp)) + (pair? (cadr sexp))) + (body (cddr sexp)) + (body (cdddr sexp)))) ;named LET + (else #f)) + #f)) + (case (car sexp) + ((DEFINE) (if (pair? name) + name + (form (caddr sexp)))) + ((DEFINE-SYNTAX) '()) + ((DEFMACRO) (cons (cadr sexp) (caddr sexp))) + ((DEFVAR DEFCONST) #f) + (else (slib:error 'schmooz "doesn't look like definition" sexp)))) + +;; Generate alist of argument macro definitions. +;; If ARGS is a symbol or string, then the definitions will be used in a +;; `defvar', if ARGS is a (possibly improper) list, they will be used in +;; a `defun'. +(define (scheme-args->macros args) + (define (arg->string a) + (if (string? a) a (symbol->string a))) + (define (arg->macros arg i) + (let ((s (number->string i)) + (m (string-append "@var{" (arg->string arg) "}"))) + (list (cons (string->symbol (string-append "@" s)) m) + (cons (string->symbol (string-append "@arg" s)) m)))) + (let* ((fun? (pair? args)) + (arg0 (if fun? (car args) args)) + (args (if fun? (cdr args) '()))) + (let ((m0 (string-append + (if fun? "@code{" "@var{") (arg->string arg0) "}"))) + (append + (list (cons '@arg0 m0) (cons '@0 m0)) + (let recur ((i 1) + (args args)) + (cond ((null? args) '()) + ((or (symbol? args) ;Rest list + (string? args)) + (arg->macros args i)) + (else + (append (arg->macros (car args) i) + (recur (+ i 1) (cdr args)))))))))) + +;; Extra processing to be done for @dfn +(define (out-cindex arg) + (out 0 "@cindex " arg)) + +;; ARGS looks like the cadr of a function definition: +;; (fun-name arg1 arg2 ...) +(define (schmooz-fun defop args body xdefs) + (define (out-header args op) + (let ((fun (car args)) + (args (cdr args))) + (out 0 #\@ op #\space fun) + (let loop ((args args)) + (cond ((null? args)) + ((symbol? args) + (loop (symbol->string args))) + ((string? args) + (out CONTLINE " " + (let ((n (- (string-length args) 1))) + (if (eqv? #\s (string-ref args n)) + (substring args 0 n) + args)) + " @dots{}")) + ((pair? args) + (out CONTLINE " " + (if (or (eq? '... (car args)) + (equal? "..." (car args))) + "@dots{}" + (car args))) + (loop (cdr args))) + (else (slib:error 'schmooz-fun args)))))) + (let* ((mac-list (scheme-args->macros args)) + (ops (case defop + ((DEFINE-SYNTAX) '("defspec" . "defspecx")) + ((DEFMACRO) '("defmac" . "defmacx")) + (else '("defun" . "defunx"))))) + (out-header args (car ops)) + (let loop ((xdefs xdefs)) + (cond ((pair? xdefs) + (out-header (car xdefs) (cdr ops)) + (loop (cdr xdefs))))) + (for-each (lambda (subl) + (out 0 (car subl)) + (for-each (lambda (l) + (case (car l) + ((@dfn) + (out-cindex (cadr l))) + ((@args) + (out-header + (cons (car args) (cdr l)) + (cdr ops))))) + (cdr subl))) + (map (lambda (bl) + (substitute-macs bl mac-list)) + body)) + (out 0 "@end " (car ops)) + (out 0))) + +(define (schmooz-var defop name body xdefs) + (let* ((mac-list (scheme-args->macros name))) + (out 0 "@defvar " name) + (let loop ((xdefs xdefs)) + (cond ((pair? xdefs) + (out 0 "@defvarx " (car xdefs)) + (loop (cdr xdefs))))) + (for-each (lambda (subl) + (out 0 (car subl)) + (for-each (lambda (l) + (case (car l) + ((@dfn) (out-cindex (cadr l))) + (else + (report "bad macro" l)))) + (cdr subl))) + (map (lambda (bl) + (substitute-macs bl mac-list)) + body)) + (out 0 "@end defvar") + (out 0))) + +;;; SCHMOOZ files. +(define schmooz + (let* ((scheme-file? (filename:match-ci?? "*??scm")) + (txi-file? (filename:match-ci?? "*??txi")) + (texi-file? (let ((tex? (filename:match-ci?? "*??tex")) + (texi? (filename:match-ci?? "*??texi"))) + (lambda (filename) (or (txi-file? filename) + (tex? filename) + (texi? filename)))))) + (define (schmooz-texi-file file) + (call-with-input-file file + (lambda (port) + (do ((pos (find-string-from-port? "@include" port) + (find-string-from-port? "@include" port))) + ((not pos)) + (let ((fname #f)) + (cond ((not (eqv? 1 (fscanf port " %s" fname)))) + ((not (txi-file? fname))) + ((not (file-exists? + (replace-suffix fname "txi" "scm")))) + (else (schmooz + (replace-suffix fname "txi" "scm"))))))))) + (define (schmooz-scm-file file txi-name) + (display "Schmoozing ") (write file) + (display " -> ") (write txi-name) (newline) + (fluid-let ((*scheme-source* (open-file file "r")) + (*scheme-source-name* file) + (*derived-txi* (open-file txi-name "w")) + (*derived-txi-name* txi-name)) + (set! *output-line* 1) + (schmooz-tops schmooz-top) + (close-input-port *scheme-source*) + (close-output-port *derived-txi*))) + (lambda files + (for-each (lambda (file) + (define sl (string-length file)) + (cond ((scheme-file? file) + (schmooz-scm-file + file (replace-suffix file "scm" "txi"))) + ((texi-file? file) (schmooz-texi-file file)))) + files)))) + +;;; SCHMOOZ-TOPS - schmooz top level forms. +(define (schmooz-tops schmooz-top) + (let ((doc-lines '()) + (doc-args #f)) + (define (skip-ws line istrt) + (do ((i istrt (+ i 1))) + ((or (>= i (string-length line)) + (not (memv (string-ref line i) + '(#\space #\tab #\;)))) + (substring line i (string-length line))))) + + (define (tok1 line) + (let loop ((i 0)) + (cond ((>= i (string-length line)) line) + ((or (char-whitespace? (string-ref line i)) + (memv (string-ref line i) '(#\; #\( #\{))) + (substring line 0 i)) + (else (loop (+ i 1)))))) + + (define (read-cmt-line) + (cond ((eqv? #\; (peek-char *scheme-source*)) + (read-char *scheme-source*) + (read-cmt-line)) + (else (read-line *scheme-source*)))) + + (define (read-newline) + (if (char=? #\cr (read-char *scheme-source*)) + (if (char=? #\nl (peek-char *scheme-source*)) + (read-char *scheme-source*) + (report "stranded #\\cr")))) + + (define (lp c) + (cond ((eof-object? c) + (cond ((pair? doc-lines) + (report "No definition found for @body doc lines" + (reverse doc-lines))))) + ((memv c '(#\cr #\nl)) + (read-newline) + (set! *output-line* (+ 1 *output-line*)) + (newline *derived-txi*) + (lp (peek-char *scheme-source*))) + ((char-whitespace? c) + (write-char (read-char *scheme-source*) *derived-txi*) + (lp (peek-char *scheme-source*))) + ((char=? c #\;) + (c-cmt c)) + (else + (sx)))) + + (define (sx) + (let* ((s1 (read *scheme-source*)) + (ss ;Read all forms separated only by single newlines. + (let recur () + (case (peek-char *scheme-source*) + ((#\cr) (read-char *scheme-source*) (recur)) + ((#\nl) (read-char *scheme-source*) + (if (eqv? #\( (peek-char *scheme-source*)) + (cons (read *scheme-source*) (recur)) + '())) + (else '()))))) + (cond ((eof-object? s1)) + (else + (schmooz-top s1 ss (reverse doc-lines) doc-args) + (set! doc-lines '()) + (set! doc-args #f) + (lp (peek-char *scheme-source*)))))) + + (define (out-cmt line) + (let ((subl (substitute-macs line '()))) + (newline *derived-txi*) + (display (car subl) *derived-txi*) + (for-each + (lambda (l) + (case (car l) + ((@dfn) + (out-cindex (cadr l))) + (else + (report "bad macro" line)))) + (cdr subl)))) + + ;;Comments not transcribed to generated Texinfo files. + (define (c-cmt c) + (cond ((eof-object? c) (lp c)) + ((eqv? #\; c) + (read-char *scheme-source*) + (c-cmt (peek-char *scheme-source*))) + ;; Escape to start Texinfo comments + ((eqv? #\@ c) + (let* ((line (read-line *scheme-source*)) + (tok (tok1 line))) + (cond ((or (string=? tok "@body") + (string=? tok "@text")) + (set! doc-lines + (cons (skip-ws line (string-length tok)) + doc-lines)) + (body-cmt (peek-char *scheme-source*))) + ((string=? tok "@args") + (let ((args + (parse-args line (string-length tok)))) + (set! doc-args (cdr args)) + (set! doc-lines + (cons (skip-ws line (car args)) + doc-lines))) + (body-cmt (peek-char *scheme-source*))) + (else + (out-cmt (if (string=? tok "@") + (skip-ws line 1) + line)) + (doc-cmt (peek-char *scheme-source*)))))) + ;; Transcribe the comment line to C source file. + (else + (read-line *scheme-source*) ;(out-c-cmt ) + (lp (peek-char *scheme-source*))))) + + ;;Comments incorporated in generated Texinfo files. + ;;Continue adding lines to DOC-LINES until a non-comment + ;;line is reached (may be a blank line). + (define (body-cmt c) + (cond ((eof-object? c) (lp c)) + ((eqv? #\; c) + (set! doc-lines (cons (read-cmt-line) doc-lines)) + (body-cmt (peek-char *scheme-source*))) + ((memv c '(#\nl #\cr)) + (read-newline) + (lp (peek-char *scheme-source*))) + ;; Allow whitespace before ; in doc comments. + ((char-whitespace? c) + (read-char *scheme-source*) + (body-cmt (peek-char *scheme-source*))) + (else + (lp (peek-char *scheme-source*))))) + + ;;Comments incorporated in generated Texinfo files. + ;;Transcribe comments to current position in Texinfo file + ;;until a non-comment line is reached (may be a blank line). + (define (doc-cmt c) + (cond ((eof-object? c) (lp c)) + ((eqv? #\; c) + (out-cmt (read-cmt-line)) + ;;(out-c-cmt (car ls)) + (doc-cmt (peek-char *scheme-source*))) + ((memv c '(#\nl #\cr)) + (read-newline) + (newline *derived-txi*) + (lp (peek-char *scheme-source*))) + ;; Allow whitespace before ; in doc comments. + ((char-whitespace? c) + (read-char *scheme-source*) + (doc-cmt (peek-char *scheme-source*))) + (else + (newline *derived-txi*) + (lp (peek-char *scheme-source*))))) + (lp (peek-char *scheme-source*)))) + +(define (schmooz-top-doc-begin def1 defs doc proc-args) + (let ((op1 (sexp-def def1))) + (cond + ((not op1) + (or (null? doc) + (report "SCHMOOZ: no definition found for Texinfo documentation" + doc (car defs)))) + (else + (let* ((args (def->args def1)) + (args (if proc-args + (cons (if args (car args) (def->var-name def1)) + proc-args) + args))) + (let loop ((ss defs) + (smatch (list (or args (def->var-name def1))))) + (if (null? ss) + (let ((smatch (reverse smatch))) + ((if args schmooz-fun schmooz-var) + op1 (car smatch) doc (cdr smatch))) + (if (eq? op1 (sexp-def (car ss))) + (let ((a (def->args (car ss)))) + (loop (cdr ss) + (if args + (if a + (cons a smatch) + smatch) + (if a + smatch + (cons (def->var-name (car ss)) + smatch))))))))))))) + +;;; SCHMOOZ-TOP - schmooz top level form sexp. +(define (schmooz-top sexp1 sexps doc proc-args) + (cond ((not (pair? sexp1))) + ((pair? sexps) + (schmooz-top-doc-begin sexp1 sexps doc proc-args) + (set! doc '())) + (else + (case (car sexp1) + ((LOAD REQUIRE) ;If you redefine load, you lose + #f) + ((BEGIN) + (schmooz-top (cadr sexp1) '() doc proc-args) + (set! doc '()) + (for-each (lambda (s) + (schmooz-top s '() doc #f)) + (cddr sexp1))) + ((DEFVAR DEFINE DEFCONST DEFINE-SYNTAX DEFMACRO) + (let* ((args (def->args sexp1)) + (args (if proc-args + (cons (if args (car args) (cadr sexp1)) + proc-args) + args))) + (cond (args + (set! *procedure* (car args)) + (cond ((pair? doc) + (schmooz-fun (car sexp1) args doc '()) + (set! doc '())))) + (else + (cond ((pair? doc) + (schmooz-var (car sexp1) (cadr sexp1) doc '()) + (set! doc '())))))))))) + (or (null? doc) + (report + "SCHMOOZ: no definition found for Texinfo documentation" + doc sexp)) + (set! *procedure* #f)) |