summaryrefslogtreecommitdiffstats
path: root/schmooz.scm
diff options
context:
space:
mode:
authorDavid N. Welton <davidw@efn.org>1998-11-09 21:18:01 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:27 -0800
commit926b1b647ac830660933a5e63eb52d4a2552e264 (patch)
treee25db5f6e1441d67f5d9af063432018ee20a5f51 /schmooz.scm
parentb21cac3362022718634f7086964208b2eed8e897 (diff)
parentfa3f23105ddcf07c5900de47f19af43d1db1b597 (diff)
downloadslib-926b1b647ac830660933a5e63eb52d4a2552e264.tar.gz
slib-926b1b647ac830660933a5e63eb52d4a2552e264.zip
Import Debian changes 2c3-3debian/2c3-3
slib (2c3-3) frozen unstable; urgency=low * Fixes #16235. * Fixes #19943. * Fixes #20265. * Fixes #24917. * Fixes #27389. slib (2c3-2) frozen unstable; urgency=low * Re-uploaded for slink freeze. slib (2c3-1) unstable; urgency=low * New upstream release.
Diffstat (limited to 'schmooz.scm')
-rw-r--r--schmooz.scm605
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))