guile18/scripts/scan-api

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