Initial revision.

scripts/scan-api

@@ -0,0 +1,208 @@
+#!/bin/sh
+# aside from this initial boilerplate, this is actually -*- scheme -*- code
+main='(module-ref (resolve-module '\''(scripts scan-api)) '\'main')'
+exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
+!#
+;;; scan-api --- Scan and group interpreter and libguile interface elements
+
+;; 	Copyright (C) 2002 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2, or
+;; (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this software; see the file COPYING.  If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+;; Boston, MA 02111-1307 USA
+
+;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
+
+;;; Commentary:
+
+;; Usage: scan-api GUILE SOFILE [GROUPINGS]
+;;
+;; Invoke GUILE, an executable guile interpreter, and use nm(1) on SOFILE, a
+;; shared-object library, to determine available interface elements, and
+;; display them to stdout as an alist:
+;;
+;;   ((meta ...) (interface ...))
+;;
+;; The meta fields are `GUILE_LOAD_PATH', `LTDL_LIBRARY_PATH', `guile'
+;; `libguileinterface', `sofile' and `groups'.  The interface elements are in
+;; turn sub-alists w/ keys `groups' and `scan-data'.  Interface elements
+;; initially belong in one of two groups `Scheme' or `C' (but not both --
+;; signal error if that happens).
+;;
+;; Optional arg GROUPINGS is a file containing a grouping definition alist,
+;; each entry of which has the form:
+;;
+;;   (NAME (description "DESCRIPTION") (members SYM...))
+;;
+;; All of the SYM... should be proper subsets of the interface.  In addition
+;; to `description' and `members' forms, the entry may optionally include:
+;;
+;;   (grok USE-MODULES (lambda (x) CODE))
+;;
+;; where CODE implements a group-membership predicate to be applied to `x', a
+;; symbol.  [When evaluated, CODE can assume (use-modules MODULE) has been
+;; executed where MODULE is an element of USE-MODULES, a list.  [NOT YET
+;; IMPLEMENTED!]]
+;;
+;; Currently, there are two convenience predicates that operate on `x':
+;;   (in-group? x GROUP)
+;;   (name-prefix? x PREFIX)
+
+;;; Code:
+
+(debug-enable 'debug 'backtrace)
+
+(define-module (scripts scan-api)
+  :use-module (ice-9 popen)
+  :use-module (ice-9 rdelim)
+  :use-module (ice-9 regex)
+  :export (scan-api))
+
+(define put set-object-property!)
+(define get object-property)
+
+(define (scan re command match)
+  (let ((rx (make-regexp re))
+        (port (open-pipe command OPEN_READ)))
+    (let loop ((line (read-line port)))
+      (or (eof-object? line)
+          (begin
+            (cond ((regexp-exec rx line) => match))
+            (loop (read-line port)))))))
+
+(define (scan-Scheme! ht guile)
+  (scan "^.guile.+: ([^ \t]+)([ \t]+(.+))*$"
+        (format #f "~A -c '~S ~S'"
+                guile
+                '(use-modules (ice-9 session))
+                '(apropos "."))
+        (lambda (m)
+          (let ((x (string->symbol (match:substring m 1))))
+            (put x 'Scheme (or (match:substring m 3)
+                               ""))
+            (hashq-set! ht x #t)))))
+
+(define (scan-C! ht sofile)
+  (scan "^........ ([B-TV-Z]) (.+)$"
+        (format #f "nm ~A" sofile)
+        (lambda (m)
+          (let ((x (string->symbol (match:substring m 2))))
+            (put x 'C (string->symbol (match:substring m 1)))
+            (and (hashq-get-handle ht x)
+                 (error "both Scheme and C:" x))
+            (hashq-set! ht x #t)))))
+
+(define THIS-MODULE (current-module))
+
+(define (in-group? x group)
+  (memq group (get x 'groups)))
+
+(define (name-prefix? x prefix)
+  (string-match (string-append "^" prefix) (symbol->string x)))
+
+(define (add-group-name! x name)
+  (put x 'groups (cons name (get x 'groups))))
+
+(define (make-grok-hook name form)
+  (let* ((predicate? (eval form THIS-MODULE))
+         (p (lambda (x)
+              (and (predicate? x)
+                   (add-group-name! x name)))))
+    (put p 'name name)
+    p))
+
+(define (make-members-hook name members)
+  (let ((p (lambda (x)
+             (and (memq x members)
+                  (add-group-name! x name)))))
+    (put p 'name name)
+    p))
+
+(define (make-grouping-hook file)
+  (let ((hook (make-hook 1)))
+    (for-each (lambda (gdef)
+                (let ((name (car gdef))
+                      (members (assq-ref gdef 'members))
+                      (grok (assq-ref gdef 'grok)))
+                  (or members grok
+                      (error "bad grouping, must have `members' or `grok'"))
+                  (add-hook! hook
+                             (if grok
+                                 (make-grok-hook name (cadr grok))
+                                 (make-members-hook name members))
+                             #t)))      ; append
+              (read (open-file file "r")))
+    hook))
+
+(define (scan-api . args)
+  (let ((guile (list-ref args 0))
+        (sofile (list-ref args 1))
+        (grouping-hook (false-if-exception
+                        (make-grouping-hook (list-ref args 2))))
+        (ht (make-hash-table 3331)))
+    (scan-Scheme! ht guile)
+    (scan-C!      ht sofile)
+    (let ((all (sort (hash-fold (lambda (key value prior-result)
+                                  (put key 'scan-data
+                                       (or (get key 'Scheme)
+                                           (get key 'C)))
+                                  (put key 'groups
+                                       (if (get key 'Scheme)
+                                           '(Scheme)
+                                           '(C)))
+                                  (and grouping-hook
+                                       (run-hook grouping-hook key))
+                                  (cons key prior-result))
+                                '()
+                                ht)
+                     (lambda (a b)
+                       (string<? (symbol->string a)
+                                 (symbol->string b))))))
+      (format #t ";;; generated ~A UTC by scan-api -- do not edit!\n\n"
+              (strftime "%Y-%m-%d %H:%M:%S" (gmtime (current-time))))
+      (format #t "(\n")
+      (format #t "(meta\n")
+      (format #t "  (GUILE_LOAD_PATH . ~S)\n"
+              (or (getenv "GUILE_LOAD_PATH") ""))
+      (format #t "  (LTDL_LIBRARY_PATH . ~S)\n"
+              (or (getenv "LTDL_LIBRARY_PATH") ""))
+      (format #t "  (guile . ~S)\n" guile)
+      (format #t "  (libguileinterface . ~S)\n"
+              (let ((i #f))
+                (scan "(.+)"
+                      (format #f "~A -c '(display ~A)'"
+                              guile
+                              '(assq-ref %guile-build-info
+                                         'libguileinterface))
+                      (lambda (m) (set! i (match:substring m 1))))
+                i))
+      (format #t "  (sofile . ~S)\n" sofile)
+      (format #t "  ~A\n"
+              (cons 'groups (map (lambda (p) (get p 'name))
+                                 (hook->list grouping-hook))))
+      (format #t ") ;; end of meta\n")
+      (format #t "(interface\n")
+      (for-each (lambda (x)
+                  (format #t "(~A ~A (scan-data ~S))\n"
+                          x
+                          (cons 'groups (get x 'groups))
+                          (get x 'scan-data)))
+                all)
+      (format #t ") ;; end of interface\n")
+      (format #t ") ;; eof\n")))
+  #t)
+
+(define main scan-api)
+
+;;; scan-api ends here