module/scripts/snarf-check-and-output-texi.scm

   1 ;;; snarf-check-and-output-texi --- called by the doc snarfer.
   2
   3 ;; Copyright (C) 2001, 2002, 2006, 2011, 2014 Free Software Foundation, Inc.
   4 ;;
   5 ;; This program is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the GNU Lesser General Public License
   7 ;; as published by the Free Software Foundation; either version 3, or
   8 ;; (at your option) any later version.
   9 ;;
  10 ;; This program is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;; Lesser General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU Lesser General Public
  16 ;; License along with this software; see the file COPYING.LESSER.  If
  17 ;; not, write to the Free Software Foundation, Inc., 51 Franklin
  18 ;; Street, Fifth Floor, Boston, MA 02110-1301 USA
  19
  20 ;;; Author: Michael Livshin
  21
  22 ;;; Code:
  23
  24 (define-module (scripts snarf-check-and-output-texi)
  25     :use-module (ice-9 streams)
  26     :use-module (ice-9 match)
  27     :export (snarf-check-and-output-texi))
  28
  29 (define %include-in-guild-list #f)
  30 (define %summary "Transform snarfed .doc files into texinfo documentation.")
  31
  32 ;;; why aren't these in some module?
  33
  34 (define-macro (when cond . body)
  35   `(if ,cond (begin ,@body)))
  36
  37 (define-macro (unless cond . body)
  38   `(if (not ,cond) (begin ,@body)))
  39
  40 (define *manual-flag* #f)
  41
  42 (define (snarf-check-and-output-texi . flags)
  43   (if (member "--manual" flags)
  44       (set! *manual-flag* #t))
  45   (process-stream (current-input-port)))
  46
  47 (define (process-stream port)
  48   (let loop ((input (stream-map (match-lambda
  49                                  (('id . s)
  50                                   (cons 'id (string->symbol s)))
  51                                  (('int_dec . s)
  52                                   (cons 'int (string->number s)))
  53                                  (('int_oct . s)
  54                                   (cons 'int (string->number s 8)))
  55                                  (('int_hex . s)
  56                                   (cons 'int (string->number s 16)))
  57                                  ((and x (? symbol?))
  58                                   (cons x x))
  59                                  ((and x (? string?))
  60                                   (cons 'string x))
  61                                  (x x))
  62                                 (make-stream (lambda (s)
  63                                                (let loop ((s s))
  64                                                  (cond
  65                                                    ((stream-null? s) #t)
  66                                                    ((memq (stream-car s) '(eol hash))
  67                                                     (loop (stream-cdr s)))
  68                                                    (else (cons (stream-car s) (stream-cdr s))))))
  69                                              (port->stream port read)))))
  70
  71     (unless (stream-null? input)
  72       (let ((token (stream-car input)))
  73         (if (eq? (car token) 'snarf_cookie)
  74           (dispatch-top-cookie (stream-cdr input)
  75                                loop)
  76           (loop (stream-cdr input)))))))
  77
  78 (define (dispatch-top-cookie input cont)
  79
  80   (when (stream-null? input)
  81     (error 'syntax "premature end of file"))
  82
  83   (let ((token (stream-car input)))
  84     (cond
  85       ((eq? (car token) 'brace_open)
  86        (consume-multiline (stream-cdr input)
  87                           cont))
  88       (else
  89        (consume-upto-cookie process-singleline
  90                             input
  91                             cont)))))
  92
  93 (define (consume-upto-cookie process input cont)
  94   (let loop ((acc '()) (input input))
  95
  96     (when (stream-null? input)
  97       (error 'syntax "premature end of file in directive context"))
  98
  99     (let ((token (stream-car input)))
 100       (cond
 101         ((eq? (car token) 'snarf_cookie)
 102          (process (reverse! acc))
 103          (cont (stream-cdr input)))
 104
 105         (else (loop (cons token acc) (stream-cdr input)))))))
 106
 107 (define (consume-multiline input cont)
 108   (begin-multiline)
 109
 110   (let loop ((input input))
 111
 112     (when (stream-null? input)
 113       (error 'syntax "premature end of file in multiline context"))
 114
 115     (let ((token (stream-car input)))
 116       (cond
 117         ((eq? (car token) 'brace_close)
 118          (end-multiline)
 119          (cont (stream-cdr input)))
 120
 121         (else (consume-upto-cookie process-multiline-directive
 122                                    input
 123                                    loop))))))
 124
 125 (define *file* #f)
 126 (define *line* #f)
 127 (define *c-function-name* #f)
 128 (define *function-name* #f)
 129 (define *snarf-type* #f)
 130 (define *args* #f)
 131 (define *sig* #f)
 132 (define *docstring* #f)
 133
 134 (define (begin-multiline)
 135   (set! *file* #f)
 136   (set! *line* #f)
 137   (set! *c-function-name* #f)
 138   (set! *function-name* #f)
 139   (set! *snarf-type* #f)
 140   (set! *args* #f)
 141   (set! *sig* #f)
 142   (set! *docstring* #f))
 143
 144 (define *primitive-deffnx-signature* "@deffnx {Scheme Procedure} ")
 145 (define *primitive-deffnx-sig-length* (string-length *primitive-deffnx-signature*))
 146
 147 (define (end-multiline)
 148   (let* ((req (car *sig*))
 149          (opt (cadr *sig*))
 150          (var (caddr *sig*))
 151          (all (+ req opt var)))
 152     (if (and (not (eqv? *snarf-type* 'register))
 153              (not (= (length *args*) all)))
 154       (error (format #f "~A:~A: ~A's C implementation takes ~A args (should take ~A)"
 155              *file* *line* *function-name* (length *args*) all)))
 156     (let ((nice-sig
 157             (if (eq? *snarf-type* 'register)
 158               *function-name*
 159               (with-output-to-string
 160                 (lambda ()
 161                   (format #t "~A" *function-name*)
 162                   (let loop-req ((args *args*) (r 0))
 163                     (if (< r req)
 164                       (begin
 165                        (format #t " ~A" (car args))
 166                        (loop-req (cdr args) (+ 1 r)))
 167                       (let loop-opt ((o 0) (args args) (tail '()))
 168                        (if (< o opt)
 169                          (begin
 170                           (format #t " [~A" (car args))
 171                           (loop-opt (+ 1 o) (cdr args) (cons #\] tail)))
 172                          (begin
 173                           (if (> var 0)
 174                             (format #t " . ~A"
 175                                     (car args)))
 176                           (let loop-tail ((tail tail))
 177                                (if (not (null? tail))
 178                                  (begin
 179                                   (format #t "~A" (car tail))
 180                                   (loop-tail (cdr tail))))))))))))))
 181           (scm-deffnx
 182             (if (and *manual-flag* (eq? *snarf-type* 'primitive))
 183                 (with-output-to-string
 184                   (lambda ()
 185                     (format #t "@deffnx {C Function} ~A (" *c-function-name*)
 186                     (unless (null? *args*)
 187                       (format #t "~A" (car *args*))
 188                       (let loop ((args (cdr *args*)))
 189                         (unless (null? args)
 190                           (format #t ", ~A" (car args))
 191                           (loop (cdr args)))))
 192                     (format #t ")\n")))
 193                 #f)))
 194       (format #t "\n\f~A\n" *function-name*)
 195       (format #t "@c snarfed from ~A:~A\n" *file* *line*)
 196       (format #t "@deffn {Scheme Procedure} ~A\n" nice-sig)
 197       (let loop ((strings *docstring*) (scm-deffnx scm-deffnx))
 198         (cond ((null? strings))
 199               ((or (not scm-deffnx)
 200                    (and (>= (string-length (car strings))
 201                             *primitive-deffnx-sig-length*)
 202                         (string=? (substring (car strings)
 203                                              0 *primitive-deffnx-sig-length*)
 204                                   *primitive-deffnx-signature*)))
 205                (display (car strings))
 206                (loop (cdr strings) scm-deffnx))
 207               (else (display scm-deffnx)
 208                     (loop strings #f))))
 209       (display "\n")
 210       (display "@end deffn\n"))))
 211
 212 (define (texi-quote s)
 213   (let rec ((i 0))
 214     (if (= i (string-length s))
 215       ""
 216       (string-append (let ((ss (substring s i (+ i 1))))
 217                        (if (string=? ss "@")
 218                          "@@"
 219                          ss))
 220                      (rec (+ i 1))))))
 221
 222 (define (process-multiline-directive l)
 223
 224   (define do-args
 225     (match-lambda
 226
 227      (('(paren_close . paren_close))
 228       '())
 229
 230      (('(comma . comma) rest ...)
 231       (do-args rest))
 232
 233      (('(id . SCM) ('id . name) rest ...)
 234       (cons name (do-args rest)))
 235
 236      (x (error (format #f "invalid argument syntax: ~A" (map cdr x))))))
 237
 238   (define do-arglist
 239     (match-lambda
 240
 241      (('(paren_open . paren_open) '(id . void) '(paren_close . paren_close))
 242       '())
 243
 244      (('(paren_open . paren_open) rest ...)
 245       (do-args rest))
 246
 247      (x (error (format #f "invalid arglist syntax: ~A" (map cdr x))))))
 248
 249   (define do-command
 250     (match-lambda
 251
 252      (('cname ('id . name))
 253       (set! *c-function-name* (texi-quote (symbol->string name))))
 254
 255      (('fname ('string . name) ...)
 256       (set! *function-name* (texi-quote (apply string-append name))))
 257
 258      (('type ('id . type))
 259       (set! *snarf-type* type))
 260
 261      (('type ('int . num))
 262       (set! *snarf-type* num))
 263
 264      (('location ('string . file) ('int . line))
 265       (set! *file* file)
 266       (set! *line* line))
 267
 268      (('arglist rest ...)
 269       (set! *args* (do-arglist rest)))
 270
 271      (('argsig ('int . req) ('int . opt) ('int . var))
 272       (set! *sig* (list req opt var)))
 273
 274      (x (error (format #f "unknown doc attribute: ~A" x)))))
 275
 276   (define do-directive
 277     (match-lambda
 278
 279      ((('id . command) rest ...)
 280       (do-command (cons command rest)))
 281
 282      ((('string . string) ...)
 283       (set! *docstring* string))
 284
 285      (x (error (format #f "unknown doc attribute syntax: ~A" x)))))
 286
 287   (do-directive l))
 288
 289 (define (process-singleline l)
 290
 291   (define do-argpos
 292     (match-lambda
 293      ((('id . name) ('int . pos) ('int . line))
 294       (let ((idx (list-index *args* name)))
 295         (when idx
 296           (unless (= (+ idx 1) pos)
 297             (display (format #f "~A:~A: wrong position for argument ~A: ~A (should be ~A)\n"
 298                              *file* line name pos (+ idx 1))
 299                      (current-error-port))))))
 300      (x #f)))
 301
 302   (define do-command
 303     (match-lambda
 304      (('(id . argpos) rest ...)
 305       (do-argpos rest))
 306      (x (error (format #f "unknown check: ~A" x)))))
 307
 308   (when *function-name*
 309     (do-command l)))
 310
 311 (define main snarf-check-and-output-texi)