diff --git a/scripts/scan-api b/scripts/scan-api new file mode 100755 index 000000000..d345790b2 --- /dev/null +++ b/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 + +;;; 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) + (stringstring 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