diff options
Diffstat (limited to 'module/scripts/scan-api.scm')
-rw-r--r-- | module/scripts/scan-api.scm | 223 |
1 files changed, 223 insertions, 0 deletions
diff --git a/module/scripts/scan-api.scm b/module/scripts/scan-api.scm new file mode 100644 index 000000000..86d07fc3e --- /dev/null +++ b/module/scripts/scan-api.scm @@ -0,0 +1,223 @@ +;;; scan-api --- Scan and group interpreter and libguile interface elements + +;; Copyright (C) 2002, 2006, 2011 Free Software Foundation, Inc. +;; +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public License +;; as published by the Free Software Foundation; either version 3, 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 +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this software; see the file COPYING.LESSER. 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 %include-in-guild-list #f) +(define %summary "Generate an API description for a Guile extension.") + +(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 |