guile/scripts/scan-api

#!/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)
;;
;; TODO: Move symbol->string to hash-fold to make sorting more efficient.
;;       Allow for concurrent Scheme/C membership.

;;; 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 (if grouping-hook
                                (map (lambda (p) (get p 'name))
                                     (hook->list grouping-hook))
                                '(Scheme C))))
      (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