guile/modules/system/documentation/c-snarf.scm

   1 ;;; c-snarf.scm  --  Parsing documentation "snarffed" from C files.
   2 ;;;
   3 ;;; Copyright 2006-2012 Free Software Foundation, Inc.
   4 ;;;
   5 ;;;
   6 ;;; This program is free software; you can redistribute it and/or modify
   7 ;;; it under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or
   9 ;;; (at your option) any later version.
  10 ;;;
  11 ;;; This program is distributed in the hope that it will be useful,
  12 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with this program; if not, write to the Free Software
  18 ;;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  19
  20 (define-module (system documentation c-snarf)
  21   :use-module (ice-9 popen)
  22   :use-module (ice-9 rdelim)
  23
  24   :use-module (srfi srfi-13)
  25   :use-module (srfi srfi-14)
  26   :use-module (srfi srfi-39)
  27
  28   :export (run-cpp-and-extract-snarfing
  29            parse-snarfing
  30            parse-snarfed-line))
  31
  32 ;;; Author:  Ludovic Courtès
  33 ;;;
  34 ;;; Commentary:
  35 ;;;
  36 ;;; This module provides tools to parse and otherwise manipulate
  37 ;;; documentation "snarffed" from C files, i.e., information obtained by
  38 ;;; running the C preprocessor with the @code{-DSCM_MAGIC_SNARF_DOCS} flag.
  39 ;;;
  40 ;;; Code:
  41
  42
  43 \f
  44 ;;;
  45 ;;; High-level API.
  46 ;;;
  47
  48 (define (run-cpp-and-extract-snarfing file cpp cpp-flags)
  49   (let ((pipe (apply open-pipe* OPEN_READ
  50                      (cons cpp (append cpp-flags (list file))))))
  51     (parse-snarfing pipe)))
  52
  53 \f
  54 ;;;
  55 ;;; Parsing magic-snarffed CPP output.
  56 ;;;
  57
  58 (define (parse-c-argument-list arg-string)
  59   "Parse @var{arg-string} (a string representing a ANSI C argument list,
  60 e.g., @var{(const SCM first, SCM second_arg)}) and return a list of strings
  61 denoting the argument names."
  62   (define %c-symbol-char-set
  63     (char-set-adjoin char-set:letter+digit #\_))
  64
  65   (let loop ((args (string-tokenize (string-trim-both arg-string #\space)
  66                                     %c-symbol-char-set))
  67              (type? #t)
  68              (result '()))
  69     (if (null? args)
  70         (reverse! result)
  71         (let ((the-arg (car args)))
  72           (cond ((and type? (string=? the-arg "const"))
  73                  (loop (cdr args) type? result))
  74                 ((and type? (string=? the-arg "SCM"))
  75                  (loop (cdr args) (not type?) result))
  76                 (type? ;; any other type, e.g., `void'
  77                  (loop (cdr args) (not type?) result))
  78                 (else
  79                  (loop (cdr args) (not type?) (cons the-arg result))))))))
  80
  81 (define (parse-documentation-item item)
  82   "Parse @var{item} (a string), a single function string produced by the C
  83 preprocessor.  The result is an alist whose keys represent specific aspects
  84 of a procedure's documentation: @code{c-name}, @code{scheme-name},
  85  @code{documentation} (a Texinfo documentation string), etc."
  86
  87   (define (read-strings)
  88     ;; Read several subsequent strings and return their concatenation.
  89     (let loop ((str (read))
  90                (result '()))
  91       (if (or (eof-object? str)
  92               (not (string? str)))
  93           (string-concatenate (reverse! result))
  94           (loop (read) (cons str result)))))
  95
  96   (let* ((item (string-trim-both item #\space))
  97          (space (string-index item #\space)))
  98     (if (not space)
  99         (error "invalid documentation item" item)
 100         (let ((kind (substring item 0 space))
 101               (rest (substring item space (string-length item))))
 102           (cond ((string=? kind "cname")
 103                  (cons 'c-name (string-trim-both rest #\space)))
 104                 ((string=? kind "fname")
 105                  (cons 'scheme-name
 106                        (with-input-from-string rest read-strings)))
 107                 ((string=? kind "type")
 108                  (cons 'type (with-input-from-string rest read)))
 109                 ((string=? kind "location")
 110                  (cons 'location
 111                        (with-input-from-string rest
 112                          (lambda ()
 113                            (let loop ((str (read))
 114                                       (result '()))
 115                              (if (eof-object? str)
 116                                  (reverse! result)
 117                                  (loop (read) (cons str result))))))))
 118                 ((string=? kind "arglist")
 119                  (cons 'arguments
 120                        (parse-c-argument-list rest)))
 121                 ((string=? kind "argsig")
 122                  (cons 'signature
 123                        (with-input-from-string rest
 124                          (lambda ()
 125                            (let ((req (read)) (opt (read)) (rst? (read)))
 126                              (list (cons 'required req)
 127                                    (cons 'optional opt)
 128                                    (cons 'rest?    (= 1 rst?))))))))
 129                 (else
 130                  ;; docstring (may consist of several C strings which we
 131                  ;; assume to be equivalent to Scheme strings)
 132                  (cons 'documentation
 133                        (with-input-from-string item read-strings))))))))
 134
 135 (define (parse-snarfed-line line)
 136   "Parse @var{line}, a string that contains documentation returned for a
 137 single function by the C preprocessor with the @code{-DSCM_MAGIC_SNARF_DOCS}
 138 option.  @var{line} is assumed to be a complete \"^^ { ... ^^ }\" sequence."
 139   (define (caret-split str)
 140     (let loop ((str str)
 141                (result '()))
 142       (if (string=? str "")
 143           (reverse! result)
 144           (let ((caret (string-index str #\^))
 145                 (len (string-length str)))
 146             (if caret
 147                 (if (and (> (- len caret) 0)
 148                          (eq? (string-ref str (+ caret 1)) #\^))
 149                     (loop (substring str (+ 2 caret) len)
 150                           (cons (string-take str (- caret 1)) result))
 151                     (error "single caret not allowed" str))
 152                 (loop "" (cons str result)))))))
 153
 154   (let ((items (caret-split (substring line 4
 155                                        (- (string-length line) 4)))))
 156     (map parse-documentation-item items)))
 157
 158
 159 (define (parse-snarfing port)
 160   "Read C preprocessor (where the @code{SCM_MAGIC_SNARF_DOCS} macro is
 161 defined) output from @var{port} a return a list of alist, each of which
 162 contains information about a specific function described in the C
 163 preprocessor output."
 164   (define start-marker "^^ {")
 165   (define end-marker   "^^ }")
 166
 167   (define (read-snarf-lines start)
 168     ;; Read the snarf lines that follow START until and end marker is found.
 169     (let loop ((line   start)
 170                (result '()))
 171       (cond ((eof-object? line)
 172              ;; EOF in the middle of a "^^ { ... ^^ }" sequence; shouldn't
 173              ;; happen.
 174              line)
 175             ((string-contains line end-marker)
 176              =>
 177              (lambda (end)
 178                (let ((result (cons (string-take line (+ 3 end))
 179                                    result)))
 180                  (string-concatenate-reverse result))))
 181             ((string-prefix? "#" line)
 182              ;; Presumably a "# LINENUM" directive; skip it.
 183              (loop (read-line port) result))
 184             (else
 185              (loop (read-line port)
 186                    (cons line result))))))
 187
 188   (let loop ((line (read-line port))
 189              (result '()))
 190     (cond ((eof-object? line)
 191            result)
 192           ((string-contains line start-marker)
 193            =>
 194            (lambda (start)
 195              (let ((line
 196                     (read-snarf-lines (string-drop line start))))
 197                (loop (read-line port)
 198                      (cons (parse-snarfed-line line) result)))))
 199           (else
 200            (loop (read-line port) result)))))
 201
 202
 203 ;;; c-snarf.scm ends here
 204
 205 ;;; Local Variables:
 206 ;;; mode: scheme
 207 ;;; coding: latin-1
 208 ;;; End:
 209
 210 ;;; arch-tag: dcba2446-ee43-46d8-a47e-e6e12f121988