guile/module/slib/schmooz.scm

;;; "schmooz.scm" Program for extracting texinfo comments from Scheme.
;;; Copyright (C) 1998, 2000 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: /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 $
;;$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*)
;		     (cond ((string-index a #\newline)
;			    (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)))))
	 (txi->scm (filename:substitute?? "*txi" "*scm"))
	 (scm->txi (filename:substitute?? "*scm" "*txi")))
    (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? (txi->scm fname))))
		    (else (schmooz (txi->scm fname)))))))))
    (define (schmooz-scm-file file txi-name)
      (display "Schmoozing ") (write file)
      (display " -> ") (write txi-name) (newline)
      (fluid-let ((*scheme-source* (open-input-file file))
		  (*scheme-source-name* file)
		  (*derived-txi* (open-output-file txi-name))
		  (*derived-txi-name* txi-name))
	(set! *output-line* 1)
	(cond ((scheme-file? file))
	      (else (find-string-from-port? ";" *scheme-source* #\;)
		    (read-line *scheme-source*)))
	(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 ((texi-file? file) (schmooz-texi-file file))
			((scheme-file? file)
			 (schmooz-scm-file file (scm->txi file)))
			(else (schmooz-scm-file
			       file (string-append file ".txi")))))
		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-meta-cmt)
      (let skip ((metarg? #f))
	(let ((c (read-char *scheme-source*)))
	  (case c
	    ((#\newline) (if metarg? (skip #t)))
	    ((#\\) (skip #t))
	    ((#\!) (cond ((eqv? #\# (peek-char *scheme-source*))
			  (read-char *scheme-source*)
			  (if #f #f))
			 (else
			  (skip metarg?))))
	    (else 
	     (if (char? c) (skip metarg?) c))))))

    (define (lp c)
      (cond ((eof-object? c)
	     (cond ((pair? doc-lines)
		    (report "No definition found for @body doc lines"
			    (reverse doc-lines)))))
	    ((eqv? c #\newline)
	     (read-char *scheme-source*)
	     (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))
	    ((char=? c #\#)
	     (read-char *scheme-source*)
	     (if (eqv? #\! (peek-char *scheme-source*))
		 (read-meta-cmt)
		 (report "misread sharp object" (peek-char *scheme-source*)))
	     (lp (peek-char *scheme-source*)))
	    (else
	     (sx))))

    (define (sx)
      (let* ((s1 (read *scheme-source*))
	     ;;Read all forms separated only by single newlines
	     ;;and trailing whitespace.
	     (ss (let recur ()
		   (let ((c (peek-char *scheme-source*)))
		     (cond ((eqv? c #\newline)
			    (read-char *scheme-source*)
			    (if (eqv? #\( (peek-char *scheme-source*))
				(let ((s (read *scheme-source*)))
				  (cons s (recur)))
				'()))
			   ((char-whitespace? c)
			    (read-char *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 '())))
	(display (car subl) *derived-txi*)
	(for-each
	 (lambda (l)
	   (case (car l)
	     ((@dfn)
	      (out-cindex (cadr l)))
	     (else
	      (report "bad macro" line))))
	 (cdr subl))
	(newline *derived-txi*)))

    ;;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*)
	     (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*)))
	    ((eqv? c #\newline)
	     (read-char *scheme-source*)
	     (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))
	     (doc-cmt (peek-char *scheme-source*)))
	    ((eqv? c #\newline)
	     (read-char *scheme-source*)
	     (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)
	 (if (pair? doc)
	     (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))