mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 20:00:19 +02:00
a04906d98d
of strings and append them all to form the fname. This is needed for string literals like "u8""vector?".
313 lines
10 KiB
Scheme
Executable file
313 lines
10 KiB
Scheme
Executable file
#!/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., 59 Temple Place, Suite 330,
|
||
;; Boston, MA 02111-1307 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 ~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)
|