module/scripts/scan-api.scm

   1 ;;; scan-api --- Scan and group interpreter and libguile interface elements
   2
   3 ;;      Copyright (C) 2002, 2006, 2011 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: Thien-Thi Nguyen <ttn@gnu.org>
  21
  22 ;;; Commentary:
  23
  24 ;; Usage: scan-api GUILE SOFILE [GROUPINGS ...]
  25 ;;
  26 ;; Invoke GUILE, an executable guile interpreter, and use nm(1) on SOFILE, a
  27 ;; shared-object library, to determine available interface elements, and
  28 ;; display them to stdout as an alist:
  29 ;;
  30 ;;   ((meta ...) (interface ...))
  31 ;;
  32 ;; The meta fields are `GUILE_LOAD_PATH', `LTDL_LIBRARY_PATH', `guile'
  33 ;; `libguileinterface', `sofile' and `groups'.  The interface elements are in
  34 ;; turn sub-alists w/ keys `groups' and `scan-data'.  Interface elements
  35 ;; initially belong in one of two groups `Scheme' or `C' (but not both --
  36 ;; signal error if that happens).
  37 ;;
  38 ;; Optional GROUPINGS ... are files each containing a single "grouping
  39 ;; definition" alist with each entry of the form:
  40 ;;
  41 ;;   (NAME (description "DESCRIPTION") (members SYM...))
  42 ;;
  43 ;; All of the SYM... should be proper subsets of the interface.  In addition
  44 ;; to `description' and `members' forms, the entry may optionally include:
  45 ;;
  46 ;;   (grok USE-MODULES (lambda (x) CODE))
  47 ;;
  48 ;; where CODE implements a group-membership predicate to be applied to `x', a
  49 ;; symbol.  [When evaluated, CODE can assume (use-modules MODULE) has been
  50 ;; executed where MODULE is an element of USE-MODULES, a list.  [NOT YET
  51 ;; IMPLEMENTED!]]
  52 ;;
  53 ;; Currently, there are two convenience predicates that operate on `x':
  54 ;;   (in-group? x GROUP)
  55 ;;   (name-prefix? x PREFIX)
  56 ;;
  57 ;; TODO: Allow for concurrent Scheme/C membership.
  58 ;;       Completely separate reporting.
  59
  60 ;;; Code:
  61
  62 (define-module (scripts scan-api)
  63   :use-module (ice-9 popen)
  64   :use-module (ice-9 rdelim)
  65   :use-module (ice-9 regex)
  66   :export (scan-api))
  67
  68 (define %include-in-guild-list #f)
  69 (define %summary "Generate an API description for a Guile extension.")
  70
  71 (define put set-object-property!)
  72 (define get object-property)
  73
  74 (define (add-props object . args)
  75   (let loop ((args args))
  76     (if (null? args)
  77         object                          ; retval
  78         (let ((key (car args))
  79               (value (cadr args)))
  80           (put object key value)
  81           (loop (cddr args))))))
  82
  83 (define (scan re command match)
  84   (let ((rx (make-regexp re))
  85         (port (open-pipe command OPEN_READ)))
  86     (let loop ((line (read-line port)))
  87       (or (eof-object? line)
  88           (begin
  89             (cond ((regexp-exec rx line) => match))
  90             (loop (read-line port)))))))
  91
  92 (define (scan-Scheme! ht guile)
  93   (scan "^.guile.+: ([^ \t]+)([ \t]+(.+))*$"
  94         (format #f "~A -c '~S ~S'"
  95                 guile
  96                 '(use-modules (ice-9 session))
  97                 '(apropos "."))
  98         (lambda (m)
  99           (let ((x (string->symbol (match:substring m 1))))
 100             (put x 'Scheme (or (match:substring m 3)
 101                                ""))
 102             (hashq-set! ht x #t)))))
 103
 104 (define (scan-C! ht sofile)
 105   (scan "^[0-9a-fA-F]+ ([B-TV-Z]) (.+)$"
 106         (format #f "nm ~A" sofile)
 107         (lambda (m)
 108           (let ((x (string->symbol (match:substring m 2))))
 109             (put x 'C (string->symbol (match:substring m 1)))
 110             (and (hashq-get-handle ht x)
 111                  (error "both Scheme and C:" x))
 112             (hashq-set! ht x #t)))))
 113
 114 (define THIS-MODULE (current-module))
 115
 116 (define (in-group? x group)
 117   (memq group (get x 'groups)))
 118
 119 (define (name-prefix? x prefix)
 120   (string-match (string-append "^" prefix) (symbol->string x)))
 121
 122 (define (add-group-name! x name)
 123   (put x 'groups (cons name (get x 'groups))))
 124
 125 (define (make-grok-proc name form)
 126   (let* ((predicate? (eval form THIS-MODULE))
 127          (p (lambda (x)
 128               (and (predicate? x)
 129                    (add-group-name! x name)))))
 130     (put p 'name name)
 131     p))
 132
 133 (define (make-members-proc name members)
 134   (let ((p (lambda (x)
 135              (and (memq x members)
 136                   (add-group-name! x name)))))
 137     (put p 'name name)
 138     p))
 139
 140 (define (make-grouper files)            ; \/^^^o/ . o
 141   (let ((hook (make-hook 1)))           ; /\____\
 142     (for-each
 143      (lambda (file)
 144        (for-each
 145         (lambda (gdef)
 146           (let ((name (car gdef))
 147                 (members (assq-ref gdef 'members))
 148                 (grok (assq-ref gdef 'grok)))
 149             (or members grok
 150                 (error "bad grouping, must have `members' or `grok'"))
 151             (add-hook! hook
 152                        (if grok
 153                            (add-props (make-grok-proc name (cadr grok))
 154                                       'description
 155                                       (assq-ref gdef 'description))
 156                            (make-members-proc name members))
 157                        #t)))            ; append
 158         (read (open-file file OPEN_READ))))
 159      files)
 160     hook))
 161
 162 (define (scan-api . args)
 163   (let ((guile (list-ref args 0))
 164         (sofile (list-ref args 1))
 165         (grouper (false-if-exception (make-grouper (cddr args))))
 166         (ht (make-hash-table 3331)))
 167     (scan-Scheme! ht guile)
 168     (scan-C!      ht sofile)
 169     (let ((all (sort (hash-fold (lambda (key value prior-result)
 170                                   (add-props
 171                                    key
 172                                    'string (symbol->string key)
 173                                    'scan-data (or (get key 'Scheme)
 174                                                   (get key 'C))
 175                                    'groups (if (get key 'Scheme)
 176                                                '(Scheme)
 177                                                '(C)))
 178                                   (and grouper (run-hook grouper key))
 179                                   (cons key prior-result))
 180                                 '()
 181                                 ht)
 182                      (lambda (a b)
 183                        (string<? (get a 'string)
 184                                  (get b 'string))))))
 185       (format #t ";;; generated by scan-api -- do not edit!\n\n")
 186       (format #t "(\n")
 187       (format #t "(meta\n")
 188       (format #t "  (GUILE_LOAD_PATH . ~S)\n"
 189               (or (getenv "GUILE_LOAD_PATH") ""))
 190       (format #t "  (LTDL_LIBRARY_PATH . ~S)\n"
 191               (or (getenv "LTDL_LIBRARY_PATH") ""))
 192       (format #t "  (guile . ~S)\n" guile)
 193       (format #t "  (libguileinterface . ~S)\n"
 194               (let ((i #f))
 195                 (scan "(.+)"
 196                       (format #f "~A -c '(display ~A)'"
 197                               guile
 198                               '(assq-ref %guile-build-info
 199                                          'libguileinterface))
 200                       (lambda (m) (set! i (match:substring m 1))))
 201                 i))
 202       (format #t "  (sofile . ~S)\n" sofile)
 203       (format #t "  ~A\n"
 204               (cons 'groups (append (if grouper
 205                                         (map (lambda (p) (get p 'name))
 206                                              (hook->list grouper))
 207                                         '())
 208                                     '(Scheme C))))
 209       (format #t ") ;; end of meta\n")
 210       (format #t "(interface\n")
 211       (for-each (lambda (x)
 212                   (format #t "(~A ~A (scan-data ~S))\n"
 213                           x
 214                           (cons 'groups (get x 'groups))
 215                           (get x 'scan-data)))
 216                 all)
 217       (format #t ") ;; end of interface\n")
 218       (format #t ") ;; eof\n")))
 219   #t)
 220
 221 (define main scan-api)
 222
 223 ;;; scan-api ends here