2 # aside from this initial boilerplate, this is actually -*- scheme -*- code
3 main='(module-ref (resolve-module '\''(scripts scan-api)) '\'main')'
4 exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
6 ;;; scan-api --- Scan and group interpreter and libguile interface elements
8 ;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
10 ;; This program is free software; you can redistribute it and/or
11 ;; modify it under the terms of the GNU General Public License as
12 ;; published by the Free Software Foundation; either version 2, or
13 ;; (at your option) any later version.
15 ;; This program is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 ;; General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with this software; see the file COPYING. If not, write to
22 ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
23 ;; Boston, MA 02110-1301 USA
25 ;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
29 ;; Usage: scan-api GUILE SOFILE [GROUPINGS ...]
31 ;; Invoke GUILE, an executable guile interpreter, and use nm(1) on SOFILE, a
32 ;; shared-object library, to determine available interface elements, and
33 ;; display them to stdout as an alist:
35 ;; ((meta ...) (interface ...))
37 ;; The meta fields are `GUILE_LOAD_PATH', `LTDL_LIBRARY_PATH', `guile'
38 ;; `libguileinterface', `sofile' and `groups'. The interface elements are in
39 ;; turn sub-alists w/ keys `groups' and `scan-data'. Interface elements
40 ;; initially belong in one of two groups `Scheme' or `C' (but not both --
41 ;; signal error if that happens).
43 ;; Optional GROUPINGS ... are files each containing a single "grouping
44 ;; definition" alist with each entry of the form:
46 ;; (NAME (description "DESCRIPTION") (members SYM...))
48 ;; All of the SYM... should be proper subsets of the interface. In addition
49 ;; to `description' and `members' forms, the entry may optionally include:
51 ;; (grok USE-MODULES (lambda (x) CODE))
53 ;; where CODE implements a group-membership predicate to be applied to `x', a
54 ;; symbol. [When evaluated, CODE can assume (use-modules MODULE) has been
55 ;; executed where MODULE is an element of USE-MODULES, a list. [NOT YET
58 ;; Currently, there are two convenience predicates that operate on `x':
59 ;; (in-group? x GROUP)
60 ;; (name-prefix? x PREFIX)
62 ;; TODO: Allow for concurrent Scheme/C membership.
63 ;; Completely separate reporting.
67 (define-module (scripts scan-api)
68 :use-module (ice-9 popen)
69 :use-module (ice-9 rdelim)
70 :use-module (ice-9 regex)
73 (define put set-object-property!)
74 (define get object-property)
76 (define (add-props object . args)
77 (let loop ((args args))
80 (let ((key (car args))
82 (put object key value)
83 (loop (cddr args))))))
85 (define (scan re command match)
86 (let ((rx (make-regexp re))
87 (port (open-pipe command OPEN_READ)))
88 (let loop ((line (read-line port)))
89 (or (eof-object? line)
91 (cond ((regexp-exec rx line) => match))
92 (loop (read-line port)))))))
94 (define (scan-Scheme! ht guile)
95 (scan "^.guile.+: ([^ \t]+)([ \t]+(.+))*$"
96 (format #f "~A -c '~S ~S'"
98 '(use-modules (ice-9 session))
101 (let ((x (string->symbol (match:substring m 1))))
102 (put x 'Scheme (or (match:substring m 3)
104 (hashq-set! ht x #t)))))
106 (define (scan-C! ht sofile)
107 (scan "^[0-9a-fA-F]+ ([B-TV-Z]) (.+)$"
108 (format #f "nm ~A" sofile)
110 (let ((x (string->symbol (match:substring m 2))))
111 (put x 'C (string->symbol (match:substring m 1)))
112 (and (hashq-get-handle ht x)
113 (error "both Scheme and C:" x))
114 (hashq-set! ht x #t)))))
116 (define THIS-MODULE (current-module))
118 (define (in-group? x group)
119 (memq group (get x 'groups)))
121 (define (name-prefix? x prefix)
122 (string-match (string-append "^" prefix) (symbol->string x)))
124 (define (add-group-name! x name)
125 (put x 'groups (cons name (get x 'groups))))
127 (define (make-grok-proc name form)
128 (let* ((predicate? (eval form THIS-MODULE))
131 (add-group-name! x name)))))
135 (define (make-members-proc name members)
137 (and (memq x members)
138 (add-group-name! x name)))))
142 (define (make-grouper files) ; \/^^^o/ . o
143 (let ((hook (make-hook 1))) ; /\____\
148 (let ((name (car gdef))
149 (members (assq-ref gdef 'members))
150 (grok (assq-ref gdef 'grok)))
152 (error "bad grouping, must have `members' or `grok'"))
155 (add-props (make-grok-proc name (cadr grok))
157 (assq-ref gdef 'description))
158 (make-members-proc name members))
160 (read (open-file file OPEN_READ))))
164 (define (scan-api . args)
165 (let ((guile (list-ref args 0))
166 (sofile (list-ref args 1))
167 (grouper (false-if-exception (make-grouper (cddr args))))
168 (ht (make-hash-table 3331)))
169 (scan-Scheme! ht guile)
171 (let ((all (sort (hash-fold (lambda (key value prior-result)
174 'string (symbol->string key)
175 'scan-data (or (get key 'Scheme)
177 'groups (if (get key 'Scheme)
180 (and grouper (run-hook grouper key))
181 (cons key prior-result))
185 (string<? (get a 'string)
187 (format #t ";;; generated by scan-api -- do not edit!\n\n")
189 (format #t "(meta\n")
190 (format #t " (GUILE_LOAD_PATH . ~S)\n"
191 (or (getenv "GUILE_LOAD_PATH") ""))
192 (format #t " (LTDL_LIBRARY_PATH . ~S)\n"
193 (or (getenv "LTDL_LIBRARY_PATH") ""))
194 (format #t " (guile . ~S)\n" guile)
195 (format #t " (libguileinterface . ~S)\n"
198 (format #f "~A -c '(display ~A)'"
200 '(assq-ref %guile-build-info
202 (lambda (m) (set! i (match:substring m 1))))
204 (format #t " (sofile . ~S)\n" sofile)
206 (cons 'groups (append (if grouper
207 (map (lambda (p) (get p 'name))
208 (hook->list grouper))
211 (format #t ") ;; end of meta\n")
212 (format #t "(interface\n")
213 (for-each (lambda (x)
214 (format #t "(~A ~A (scan-data ~S))\n"
216 (cons 'groups (get x 'groups))
219 (format #t ") ;; end of interface\n")
220 (format #t ") ;; eof\n")))
223 (define main scan-api)
225 ;;; scan-api ends here