--- /dev/null
+#!/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, 2006 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))
+
+ ;; newer gccs like to throw around more location markers into the
+ ;; preprocessed source; these (hash . hash) bits are what they translate to
+ ;; in snarfy terms.
+ (('location ('string . file) ('int . line) ('hash . 'hash))
+ (set! *file* file)
+ (set! *line* line))
+
+ (('location ('hash . 'hash) ('string . file) ('int . line) ('hash . 'hash))
+ (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)
projects / lilypond.git / blobdiff