--- /dev/null
+#!/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, 2006 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., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301 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 GROUPINGS ... are files each containing a single "grouping
+;; definition" alist with each entry of 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: Allow for concurrent Scheme/C membership.
+;; Completely separate reporting.
+
+;;; Code:
+
+(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 (add-props object . args)
+ (let loop ((args args))
+ (if (null? args)
+ object ; retval
+ (let ((key (car args))
+ (value (cadr args)))
+ (put object key value)
+ (loop (cddr args))))))
+
+(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 "^[0-9a-fA-F]+ ([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-proc 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-proc name members)
+ (let ((p (lambda (x)
+ (and (memq x members)
+ (add-group-name! x name)))))
+ (put p 'name name)
+ p))
+
+(define (make-grouper files) ; \/^^^o/ . o
+ (let ((hook (make-hook 1))) ; /\____\
+ (for-each
+ (lambda (file)
+ (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
+ (add-props (make-grok-proc name (cadr grok))
+ 'description
+ (assq-ref gdef 'description))
+ (make-members-proc name members))
+ #t))) ; append
+ (read (open-file file OPEN_READ))))
+ files)
+ hook))
+
+(define (scan-api . args)
+ (let ((guile (list-ref args 0))
+ (sofile (list-ref args 1))
+ (grouper (false-if-exception (make-grouper (cddr args))))
+ (ht (make-hash-table 3331)))
+ (scan-Scheme! ht guile)
+ (scan-C! ht sofile)
+ (let ((all (sort (hash-fold (lambda (key value prior-result)
+ (add-props
+ key
+ 'string (symbol->string key)
+ 'scan-data (or (get key 'Scheme)
+ (get key 'C))
+ 'groups (if (get key 'Scheme)
+ '(Scheme)
+ '(C)))
+ (and grouper (run-hook grouper key))
+ (cons key prior-result))
+ '()
+ ht)
+ (lambda (a b)
+ (string<? (get a 'string)
+ (get b 'string))))))
+ (format #t ";;; generated by scan-api -- do not edit!\n\n")
+ (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 (append (if grouper
+ (map (lambda (p) (get p 'name))
+ (hook->list grouper))
+ '())
+ '(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
projects / lilypond.git / blobdiff