;;; snarf-check-and-output-texi --- called by the doc snarfer.
;; Copyright (C) 2001, 2002, 2006, 2011, 2014 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public License
;; as published by the Free Software Foundation; either version 3, 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
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this software; see the file COPYING.LESSER. 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))
(define %include-in-guild-list #f)
(define %summary "Transform snarfed .doc files into texinfo documentation.")
;;; 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)
((memq (stream-car s) '(eol hash))
(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 ~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)