[bpt/guile.git] / scripts / snarf-check-and-output-texi

#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
main="(module-ref (resolve-module '(scripts snarf-check-and-output-texi)) 'main)"
exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
!#
;;; snarf-check-and-output-texi --- called by the doc snarfer.

;; 	Copyright (C) 2001, 2002 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this software; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301 USA

;;; Author: Michael Livshin

;;; Code:

(define-module (scripts snarf-check-and-output-texi)
    :use-module (ice-9 streams)
    :use-module (ice-9 match)
    :export (snarf-check-and-output-texi))

;;; why aren't these in some module?

(define-macro (when cond . body)
  `(if ,cond (begin ,@body)))

(define-macro (unless cond . body)
  `(if (not ,cond) (begin ,@body)))

(define *manual-flag* #f)

(define (snarf-check-and-output-texi . flags)
  (if (member "--manual" flags)
      (set! *manual-flag* #t))
  (process-stream (current-input-port)))

(define (process-stream port)
  (let loop ((input (stream-map (match-lambda
                                 (('id . s)
                                  (cons 'id (string->symbol s)))
                                 (('int_dec . s)
                                  (cons 'int (string->number s)))
                                 (('int_oct . s)
                                  (cons 'int (string->number s 8)))
                                 (('int_hex . s)
                                  (cons 'int (string->number s 16)))
                                 ((and x (? symbol?))
                                  (cons x x))
                                 ((and x (? string?))
                                  (cons 'string x))
                                 (x x))
                                (make-stream (lambda (s)
                                               (let loop ((s s))
                                                 (cond
                                                   ((stream-null? s) #t)
                                                   ((eq? 'eol (stream-car s))
                                                    (loop (stream-cdr s)))
                                                   (else (cons (stream-car s) (stream-cdr s))))))
                                             (port->stream port read)))))

    (unless (stream-null? input)
      (let ((token (stream-car input)))
        (if (eq? (car token) 'snarf_cookie)
          (dispatch-top-cookie (stream-cdr input)
                               loop)
          (loop (stream-cdr input)))))))

(define (dispatch-top-cookie input cont)

  (when (stream-null? input)
    (error 'syntax "premature end of file"))

  (let ((token (stream-car input)))
    (cond
      ((eq? (car token) 'brace_open)
       (consume-multiline (stream-cdr input)
                          cont))
      (else
       (consume-upto-cookie process-singleline
                            input
                            cont)))))

(define (consume-upto-cookie process input cont)
  (let loop ((acc '()) (input input))

    (when (stream-null? input)
      (error 'syntax "premature end of file in directive context"))

    (let ((token (stream-car input)))
      (cond
        ((eq? (car token) 'snarf_cookie)
         (process (reverse! acc))
         (cont (stream-cdr input)))

        (else (loop (cons token acc) (stream-cdr input)))))))

(define (consume-multiline input cont)
  (begin-multiline)

  (let loop ((input input))

    (when (stream-null? input)
      (error 'syntax "premature end of file in multiline context"))

    (let ((token (stream-car input)))
      (cond
        ((eq? (car token) 'brace_close)
         (end-multiline)
         (cont (stream-cdr input)))

        (else (consume-upto-cookie process-multiline-directive
                                   input
                                   loop))))))

(define *file* #f)
(define *line* #f)
(define *c-function-name* #f)
(define *function-name* #f)
(define *snarf-type* #f)
(define *args* #f)
(define *sig* #f)
(define *docstring* #f)

(define (begin-multiline)
  (set! *file* #f)
  (set! *line* #f)
  (set! *c-function-name* #f)
  (set! *function-name* #f)
  (set! *snarf-type* #f)
  (set! *args* #f)
  (set! *sig* #f)
  (set! *docstring* #f))

(define *primitive-deffnx-signature* "@deffnx {Scheme Procedure} ")
(define *primitive-deffnx-sig-length* (string-length *primitive-deffnx-signature*))

(define (end-multiline)
  (let* ((req (car *sig*))
         (opt (cadr *sig*))
         (var (caddr *sig*))
         (all (+ req opt var)))
    (if (and (not (eqv? *snarf-type* 'register))
             (not (= (length *args*) all)))
      (error (format #f "~A:~A: ~A's C implementation takes ~A args (should take ~A)"
             *file* *line* *function-name* (length *args*) all)))
    (let ((nice-sig
            (if (eq? *snarf-type* 'register)
              *function-name*
              (with-output-to-string
                (lambda ()
                  (format #t "~A" *function-name*)
                  (let loop-req ((args *args*) (r 0))
                    (if (< r req)
                      (begin
                       (format #t " ~A" (car args))
                       (loop-req (cdr args) (+ 1 r)))
                      (let loop-opt ((o 0) (args args) (tail '()))
                       (if (< o opt)
                         (begin
                          (format #t " [~A" (car args))
                          (loop-opt (+ 1 o) (cdr args) (cons #\] tail)))
                         (begin
                          (if (> var 0)
                            (format #t " . ~A"
                                    (car args)))
                          (let loop-tail ((tail tail))
                               (if (not (null? tail))
                                 (begin
                                  (format #t "~A" (car tail))
                                  (loop-tail (cdr tail))))))))))))))
	  (scm-deffnx
	    (if (and *manual-flag* (eq? *snarf-type* 'primitive))
		(with-output-to-string
		  (lambda ()
                    (format #t "@deffnx {C Function} ~A (" *c-function-name*)
		    (unless (null? *args*)
		      (format #t "~A" (car *args*))
		      (let loop ((args (cdr *args*)))
			(unless (null? args)
			  (format #t ", ~A" (car args))
			  (loop (cdr args)))))
		    (format #t ")\n")))
		#f)))
      (format #t "\n\f~A\n" *function-name*)
      (format #t "@c snarfed from ~A:~A\n" *file* *line*)
      (format #t "@deffn {Scheme Procedure} ~A\n" nice-sig)
      (let loop ((strings *docstring*) (scm-deffnx scm-deffnx))
	(cond ((null? strings))
	      ((or (not scm-deffnx)
		   (and (>= (string-length (car strings))
			    *primitive-deffnx-sig-length*)
			(string=? (substring (car strings)
					     0 *primitive-deffnx-sig-length*)
				  *primitive-deffnx-signature*)))
	       (display (car strings))
	       (loop (cdr strings) scm-deffnx))
	      (else (display scm-deffnx)
		    (loop strings #f))))
      (display "\n")
      (display "@end deffn\n"))))

(define (texi-quote s)
  (let rec ((i 0))
    (if (= i (string-length s))
      ""
      (string-append (let ((ss (substring s i (+ i 1))))
                       (if (string=? ss "@")
                         "@@"
                         ss))
                     (rec (+ i 1))))))

(define (process-multiline-directive l)

  (define do-args
    (match-lambda

     (('(paren_close . paren_close))
      '())

     (('(comma . comma) rest ...)
      (do-args rest))

     (('(id . SCM) ('id . name) rest ...)
      (cons name (do-args rest)))

     (x (error (format #f "invalid argument syntax: ~A" (map cdr x))))))

  (define do-arglist
    (match-lambda

     (('(paren_open . paren_open) '(id . void) '(paren_close . paren_close))
      '())

     (('(paren_open . paren_open) rest ...)
      (do-args rest))

     (x (error (format #f "invalid arglist syntax: ~A" (map cdr x))))))

  (define do-command
    (match-lambda

     (('cname ('id . name))
      (set! *c-function-name* (texi-quote (symbol->string name))))

     (('fname ('string . name) ...)
      (set! *function-name* (texi-quote (apply string-append name))))

     (('type ('id . type))
      (set! *snarf-type* type))

     (('type ('int . num))
      (set! *snarf-type* num))

     (('location ('string . file) ('int . line))
      (set! *file* file)
      (set! *line* line))

     (('arglist rest ...)
      (set! *args* (do-arglist rest)))

     (('argsig ('int . req) ('int . opt) ('int . var))
      (set! *sig* (list req opt var)))

     (x (error (format #f "unknown doc attribute: ~A" x)))))

  (define do-directive
    (match-lambda

     ((('id . command) rest ...)
      (do-command (cons command rest)))

     ((('string . string) ...)
      (set! *docstring* string))

     (x (error (format #f "unknown doc attribute syntax: ~A" x)))))

  (do-directive l))

(define (process-singleline l)

  (define do-argpos
    (match-lambda
     ((('id . name) ('int . pos) ('int . line))
      (let ((idx (list-index *args* name)))
        (when idx
          (unless (= (+ idx 1) pos)
            (display (format #f "~A:~A: wrong position for argument ~A: ~A (should be ~A)\n"
                             *file* line name pos (+ idx 1))
                     (current-error-port))))))
     (x #f)))

  (define do-command
    (match-lambda
     (('(id . argpos) rest ...)
      (do-argpos rest))
     (x (error (format #f "unknown check: ~A" x)))))

  (when *function-name*
    (do-command l)))

(define main snarf-check-and-output-texi)
Commit	Line	Data
13482e95 ML	1	#!/bin/sh
	2	# aside from this initial boilerplate, this is actually -- scheme -- code
	3	main="(module-ref (resolve-module '(scripts snarf-check-and-output-texi)) 'main)"
8c914f6b	4	exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
13482e95 ML	5	!#
	6	;;; snarf-check-and-output-texi --- called by the doc snarfer.
	7
f4e09330	8	;; Copyright (C) 2001, 2002 Free Software Foundation, Inc.
13482e95 ML	9	;;
	10	;; This program is free software; you can redistribute it and/or
	11	;; modify it under the terms of the GNU General Public License as
	12	;; published by the Free Software Foundation; either version 2, or
	13	;; (at your option) any later version.
	14	;;
	15	;; This program is distributed in the hope that it will be useful,
	16	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	17	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	18	;; General Public License for more details.
	19	;;
	20	;; You should have received a copy of the GNU General Public License
	21	;; along with this software; see the file COPYING. If not, write to
92205699 MV	22	;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
92205699 MV	23	;; Boston, MA 02110-1301 USA
13482e95	24
61897afe TTN	25	;;; Author: Michael Livshin
61897afe TTN	26
13482e95 ML	27	;;; Code:
	28
	29	(define-module (scripts snarf-check-and-output-texi)
58e17e27 ML	30	:use-module (ice-9 streams)
58e17e27 ML	31	:use-module (ice-9 match)
13482e95 ML	32	:export (snarf-check-and-output-texi))
13482e95 ML	33
58e17e27 ML	34	;;; why aren't these in some module?
	35
	36	(define-macro (when cond . body)
	37	`(if ,cond (begin ,@body)))
	38
	39	(define-macro (unless cond . body)
	40	`(if (not ,cond) (begin ,@body)))
	41
cecb4a5e NJ	42	(define manual-flag #f)
	43
	44	(define (snarf-check-and-output-texi . flags)
e21f90f0	45	(if (member "--manual" flags)
cecb4a5e	46	(set! manual-flag #t))
58e17e27 ML	47	(process-stream (current-input-port)))
	48
	49	(define (process-stream port)
	50	(let loop ((input (stream-map (match-lambda
	51	(('id . s)
	52	(cons 'id (string->symbol s)))
	53	(('int_dec . s)
	54	(cons 'int (string->number s)))
	55	(('int_oct . s)
	56	(cons 'int (string->number s 8)))
	57	(('int_hex . s)
	58	(cons 'int (string->number s 16)))
	59	((and x (? symbol?))
	60	(cons x x))
	61	((and x (? string?))
	62	(cons 'string x))
	63	(x x))
	64	(make-stream (lambda (s)
	65	(let loop ((s s))
	66	(cond
	67	((stream-null? s) #t)
	68	((eq? 'eol (stream-car s))
	69	(loop (stream-cdr s)))
	70	(else (cons (stream-car s) (stream-cdr s))))))
	71	(port->stream port read)))))
aa3eb769	72
58e17e27 ML	73	(unless (stream-null? input)
	74	(let ((token (stream-car input)))
	75	(if (eq? (car token) 'snarf_cookie)
	76	(dispatch-top-cookie (stream-cdr input)
	77	loop)
	78	(loop (stream-cdr input)))))))
	79
	80	(define (dispatch-top-cookie input cont)
aa3eb769	81
58e17e27 ML	82	(when (stream-null? input)
58e17e27 ML	83	(error 'syntax "premature end of file"))
aa3eb769	84
58e17e27 ML	85	(let ((token (stream-car input)))
	86	(cond
	87	((eq? (car token) 'brace_open)
	88	(consume-multiline (stream-cdr input)
	89	cont))
	90	(else
	91	(consume-upto-cookie process-singleline
	92	input
	93	cont)))))
	94
	95	(define (consume-upto-cookie process input cont)
	96	(let loop ((acc '()) (input input))
aa3eb769	97
58e17e27 ML	98	(when (stream-null? input)
58e17e27 ML	99	(error 'syntax "premature end of file in directive context"))
aa3eb769	100
58e17e27 ML	101	(let ((token (stream-car input)))
	102	(cond
	103	((eq? (car token) 'snarf_cookie)
	104	(process (reverse! acc))
	105	(cont (stream-cdr input)))
	106
	107	(else (loop (cons token acc) (stream-cdr input)))))))
	108
	109	(define (consume-multiline input cont)
	110	(begin-multiline)
	111
	112	(let loop ((input input))
	113
	114	(when (stream-null? input)
	115	(error 'syntax "premature end of file in multiline context"))
aa3eb769	116
58e17e27 ML	117	(let ((token (stream-car input)))
	118	(cond
	119	((eq? (car token) 'brace_close)
	120	(end-multiline)
	121	(cont (stream-cdr input)))
aa3eb769	122
58e17e27 ML	123	(else (consume-upto-cookie process-multiline-directive
	124	input
	125	loop))))))
	126
13482e95 ML	127	(define file #f)
13482e95 ML	128	(define line #f)
cecb4a5e	129	(define c-function-name #f)
13482e95 ML	130	(define function-name #f)
	131	(define snarf-type #f)
	132	(define args #f)
	133	(define sig #f)
	134	(define docstring #f)
	135
58e17e27 ML	136	(define (begin-multiline)
	137	(set! file #f)
	138	(set! line #f)
cecb4a5e	139	(set! c-function-name #f)
58e17e27 ML	140	(set! function-name #f)
	141	(set! snarf-type #f)
	142	(set! args #f)
	143	(set! sig #f)
	144	(set! docstring #f))
aa3eb769	145
8f85c0c6	146	(define primitive-deffnx-signature "@deffnx {Scheme Procedure} ")
cecb4a5e NJ	147	(define primitive-deffnx-sig-length (string-length primitive-deffnx-signature))
cecb4a5e NJ	148
58e17e27	149	(define (end-multiline)
13482e95 ML	150	(let* ((req (car sig))
	151	(opt (cadr sig))
	152	(var (caddr sig))
	153	(all (+ req opt var)))
	154	(if (and (not (eqv? snarf-type 'register))
	155	(not (= (length args) all)))
	156	(error (format #f "~A:~A: ~A's C implementation takes ~A args (should take ~A)"
f4e09330	157	file line function-name (length args) all)))
13482e95 ML	158	(let ((nice-sig
	159	(if (eq? snarf-type 'register)
	160	function-name
	161	(with-output-to-string
	162	(lambda ()
	163	(format #t "~A" function-name)
fd7ec883	164	(let loop-req ((args args) (r 0))
13482e95 ML	165	(if (< r req)
13482e95 ML	166	(begin
fd7ec883 ML	167	(format #t " ~A" (car args))
	168	(loop-req (cdr args) (+ 1 r)))
	169	(let loop-opt ((o 0) (args args) (tail '()))
	170	(if (< o opt)
	171	(begin
	172	(format #t " [~A" (car args))
	173	(loop-opt (+ 1 o) (cdr args) (cons #\] tail)))
	174	(begin
	175	(if (> var 0)
	176	(format #t " . ~A"
	177	(car args)))
	178	(let loop-tail ((tail tail))
	179	(if (not (null? tail))
	180	(begin
	181	(format #t "~A" (car tail))
cecb4a5e NJ	182	(loop-tail (cdr tail))))))))))))))
	183	(scm-deffnx
	184	(if (and manual-flag (eq? snarf-type 'primitive))
	185	(with-output-to-string
	186	(lambda ()
8f85c0c6	187	(format #t "@deffnx {C Function} ~A (" c-function-name)
cecb4a5e	188	(unless (null? args)
8f85c0c6	189	(format #t "~A" (car args))
cecb4a5e NJ	190	(let loop ((args (cdr args)))
cecb4a5e NJ	191	(unless (null? args)
8f85c0c6	192	(format #t ", ~A" (car args))
cecb4a5e NJ	193	(loop (cdr args)))))
	194	(format #t ")\n")))
	195	#f)))
13482e95 ML	196	(format #t "\n\f~A\n" function-name)
13482e95 ML	197	(format #t "@c snarfed from ~A:~A\n" file line)
8f85c0c6	198	(format #t "@deffn {Scheme Procedure} ~A\n" nice-sig)
cecb4a5e NJ	199	(let loop ((strings docstring) (scm-deffnx scm-deffnx))
	200	(cond ((null? strings))
	201	((or (not scm-deffnx)
	202	(and (>= (string-length (car strings))
	203	primitive-deffnx-sig-length)
	204	(string=? (substring (car strings)
	205	0 primitive-deffnx-sig-length)
	206	primitive-deffnx-signature)))
	207	(display (car strings))
	208	(loop (cdr strings) scm-deffnx))
	209	(else (display scm-deffnx)
	210	(loop strings #f))))
	211	(display "\n")
cecb4a5e	212	(display "@end deffn\n"))))
13482e95	213
58e17e27 ML	214	(define (texi-quote s)
	215	(let rec ((i 0))
	216	(if (= i (string-length s))
	217	""
	218	(string-append (let ((ss (substring s i (+ i 1))))
	219	(if (string=? ss "@")
	220	"@@"
	221	ss))
	222	(rec (+ i 1))))))
	223
	224	(define (process-multiline-directive l)
	225
	226	(define do-args
	227	(match-lambda
aa3eb769	228
58e17e27 ML	229	(('(paren_close . paren_close))
58e17e27 ML	230	'())
aa3eb769	231
58e17e27 ML	232	(('(comma . comma) rest ...)
58e17e27 ML	233	(do-args rest))
aa3eb769	234
58e17e27 ML	235	(('(id . SCM) ('id . name) rest ...)
	236	(cons name (do-args rest)))
	237
	238	(x (error (format #f "invalid argument syntax: ~A" (map cdr x))))))
	239
	240	(define do-arglist
	241	(match-lambda
aa3eb769	242
58e17e27 ML	243	(('(paren_open . paren_open) '(id . void) '(paren_close . paren_close))
58e17e27 ML	244	'())
aa3eb769	245
58e17e27 ML	246	(('(paren_open . paren_open) rest ...)
58e17e27 ML	247	(do-args rest))
aa3eb769	248
58e17e27 ML	249	(x (error (format #f "invalid arglist syntax: ~A" (map cdr x))))))
	250
	251	(define do-command
	252	(match-lambda
aa3eb769	253
cecb4a5e NJ	254	(('cname ('id . name))
	255	(set! c-function-name (texi-quote (symbol->string name))))
	256
a04906d9 MV	257	(('fname ('string . name) ...)
a04906d9 MV	258	(set! function-name (texi-quote (apply string-append name))))
aa3eb769	259
58e17e27 ML	260	(('type ('id . type))
	261	(set! snarf-type type))
	262
	263	(('type ('int . num))
	264	(set! snarf-type num))
	265
	266	(('location ('string . file) ('int . line))
	267	(set! file file)
	268	(set! line line))
	269
	270	(('arglist rest ...)
	271	(set! args (do-arglist rest)))
	272
	273	(('argsig ('int . req) ('int . opt) ('int . var))
	274	(set! sig (list req opt var)))
	275
	276	(x (error (format #f "unknown doc attribute: ~A" x)))))
	277
	278	(define do-directive
	279	(match-lambda
aa3eb769	280
58e17e27 ML	281	((('id . command) rest ...)
58e17e27 ML	282	(do-command (cons command rest)))
aa3eb769	283
58e17e27 ML	284	((('string . string) ...)
58e17e27 ML	285	(set! docstring string))
aa3eb769	286
58e17e27 ML	287	(x (error (format #f "unknown doc attribute syntax: ~A" x)))))
	288
	289	(do-directive l))
	290
	291	(define (process-singleline l)
aa3eb769	292
58e17e27 ML	293	(define do-argpos
	294	(match-lambda
	295	((('id . name) ('int . pos) ('int . line))
	296	(let ((idx (list-index args name)))
	297	(when idx
	298	(unless (= (+ idx 1) pos)
	299	(display (format #f "~A:~A: wrong position for argument ~A: ~A (should be ~A)\n"
4d772ae2 ML	300	file line name pos (+ idx 1))
4d772ae2 ML	301	(current-error-port))))))
58e17e27	302	(x #f)))
aa3eb769	303
58e17e27 ML	304	(define do-command
	305	(match-lambda
	306	(('(id . argpos) rest ...)
	307	(do-argpos rest))
	308	(x (error (format #f "unknown check: ~A" x)))))
aa3eb769	309
58e17e27 ML	310	(when function-name
58e17e27 ML	311	(do-command l)))
13482e95 ML	312
13482e95 ML	313	(define main snarf-check-and-output-texi)