guile18/scripts/snarf-check-and-output-texi

   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)"
   4 exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
   5 !#
   6 ;;; snarf-check-and-output-texi --- called by the doc snarfer.
   7
   8 ;;      Copyright (C) 2001, 2002, 2006 Free Software Foundation, Inc.
   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
  22 ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  23 ;; Boston, MA 02110-1301 USA
  24
  25 ;;; Author: Michael Livshin
  26
  27 ;;; Code:
  28
  29 (define-module (scripts snarf-check-and-output-texi)
  30     :use-module (ice-9 streams)
  31     :use-module (ice-9 match)
  32     :export (snarf-check-and-output-texi))
  33
  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
  42 (define *manual-flag* #f)
  43
  44 (define (snarf-check-and-output-texi . flags)
  45   (if (member "--manual" flags)
  46       (set! *manual-flag* #t))
  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)))))
  72
  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)
  81
  82   (when (stream-null? input)
  83     (error 'syntax "premature end of file"))
  84
  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))
  97
  98     (when (stream-null? input)
  99       (error 'syntax "premature end of file in directive context"))
 100
 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"))
 116
 117     (let ((token (stream-car input)))
 118       (cond
 119         ((eq? (car token) 'brace_close)
 120          (end-multiline)
 121          (cont (stream-cdr input)))
 122
 123         (else (consume-upto-cookie process-multiline-directive
 124                                    input
 125                                    loop))))))
 126
 127 (define *file* #f)
 128 (define *line* #f)
 129 (define *c-function-name* #f)
 130 (define *function-name* #f)
 131 (define *snarf-type* #f)
 132 (define *args* #f)
 133 (define *sig* #f)
 134 (define *docstring* #f)
 135
 136 (define (begin-multiline)
 137   (set! *file* #f)
 138   (set! *line* #f)
 139   (set! *c-function-name* #f)
 140   (set! *function-name* #f)
 141   (set! *snarf-type* #f)
 142   (set! *args* #f)
 143   (set! *sig* #f)
 144   (set! *docstring* #f))
 145
 146 (define *primitive-deffnx-signature* "@deffnx {Scheme Procedure} ")
 147 (define *primitive-deffnx-sig-length* (string-length *primitive-deffnx-signature*))
 148
 149 (define (end-multiline)
 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)"
 157              *file* *line* *function-name* (length *args*) all)))
 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*)
 164                   (let loop-req ((args *args*) (r 0))
 165                     (if (< r req)
 166                       (begin
 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))
 182                                   (loop-tail (cdr tail))))))))))))))
 183           (scm-deffnx
 184             (if (and *manual-flag* (eq? *snarf-type* 'primitive))
 185                 (with-output-to-string
 186                   (lambda ()
 187                     (format #t "@deffnx {C Function} ~A (" *c-function-name*)
 188                     (unless (null? *args*)
 189                       (format #t "~A" (car *args*))
 190                       (let loop ((args (cdr *args*)))
 191                         (unless (null? args)
 192                           (format #t ", ~A" (car args))
 193                           (loop (cdr args)))))
 194                     (format #t ")\n")))
 195                 #f)))
 196       (format #t "\n\f~A\n" *function-name*)
 197       (format #t "@c snarfed from ~A:~A\n" *file* *line*)
 198       (format #t "@deffn {Scheme Procedure} ~A\n" nice-sig)
 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")
 212       (display "@end deffn\n"))))
 213
 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
 228
 229      (('(paren_close . paren_close))
 230       '())
 231
 232      (('(comma . comma) rest ...)
 233       (do-args rest))
 234
 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
 242
 243      (('(paren_open . paren_open) '(id . void) '(paren_close . paren_close))
 244       '())
 245
 246      (('(paren_open . paren_open) rest ...)
 247       (do-args rest))
 248
 249      (x (error (format #f "invalid arglist syntax: ~A" (map cdr x))))))
 250
 251   (define do-command
 252     (match-lambda
 253
 254      (('cname ('id . name))
 255       (set! *c-function-name* (texi-quote (symbol->string name))))
 256
 257      (('fname ('string . name) ...)
 258       (set! *function-name* (texi-quote (apply string-append name))))
 259
 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      ;; newer gccs like to throw around more location markers into the
 271      ;; preprocessed source; these (hash . hash) bits are what they translate to
 272      ;; in snarfy terms.
 273      (('location ('string . file) ('int . line) ('hash . 'hash))
 274       (set! *file* file)
 275       (set! *line* line))
 276
 277      (('location ('hash . 'hash) ('string . file) ('int . line) ('hash . 'hash))
 278       (set! *file* file)
 279       (set! *line* line))
 280
 281      (('arglist rest ...)
 282       (set! *args* (do-arglist rest)))
 283
 284      (('argsig ('int . req) ('int . opt) ('int . var))
 285       (set! *sig* (list req opt var)))
 286
 287      (x (error (format #f "unknown doc attribute: ~A" x)))))
 288
 289   (define do-directive
 290     (match-lambda
 291
 292      ((('id . command) rest ...)
 293       (do-command (cons command rest)))
 294
 295      ((('string . string) ...)
 296       (set! *docstring* string))
 297
 298      (x (error (format #f "unknown doc attribute syntax: ~A" x)))))
 299
 300   (do-directive l))
 301
 302 (define (process-singleline l)
 303
 304   (define do-argpos
 305     (match-lambda
 306      ((('id . name) ('int . pos) ('int . line))
 307       (let ((idx (list-index *args* name)))
 308         (when idx
 309           (unless (= (+ idx 1) pos)
 310             (display (format #f "~A:~A: wrong position for argument ~A: ~A (should be ~A)\n"
 311                              *file* line name pos (+ idx 1))
 312                      (current-error-port))))))
 313      (x #f)))
 314
 315   (define do-command
 316     (match-lambda
 317      (('(id . argpos) rest ...)
 318       (do-argpos rest))
 319      (x (error (format #f "unknown check: ~A" x)))))
 320
 321   (when *function-name*
 322     (do-command l)))
 323
 324 (define main snarf-check-and-output-texi)