diff options
Diffstat (limited to 'module/scripts/snarf-check-and-output-texi.scm')
| -rw-r--r-- | module/scripts/snarf-check-and-output-texi.scm | 308 |
1 files changed, 308 insertions, 0 deletions
diff --git a/module/scripts/snarf-check-and-output-texi.scm b/module/scripts/snarf-check-and-output-texi.scm new file mode 100644 index 000000000..0e7efae47 --- /dev/null +++ b/module/scripts/snarf-check-and-output-texi.scm @@ -0,0 +1,308 @@ +;;; 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 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)) + +;;; 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) |