Import Upstream version 2c3upstream/2c3

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