Commit | Line | Data |
---|---|---|
091cf411 TTN |
1 | #!/bin/sh |
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)))" "$@" | |
5 | !# | |
6 | ;;; scan-api --- Scan and group interpreter and libguile interface elements | |
7 | ||
8 | ;; Copyright (C) 2002 Free Software Foundation, Inc. | |
9 | ;; | |
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. | |
14 | ;; | |
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. | |
19 | ;; | |
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., 59 Temple Place, Suite 330, | |
23 | ;; Boston, MA 02111-1307 USA | |
24 | ||
25 | ;;; Author: Thien-Thi Nguyen <ttn@gnu.org> | |
26 | ||
27 | ;;; Commentary: | |
28 | ||
e366d58b | 29 | ;; Usage: scan-api GUILE SOFILE [GROUPINGS ...] |
091cf411 TTN |
30 | ;; |
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: | |
34 | ;; | |
35 | ;; ((meta ...) (interface ...)) | |
36 | ;; | |
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). | |
42 | ;; | |
e366d58b TTN |
43 | ;; Optional GROUPINGS ... are files each containing a single "grouping |
44 | ;; definition" alist with each entry of the form: | |
091cf411 TTN |
45 | ;; |
46 | ;; (NAME (description "DESCRIPTION") (members SYM...)) | |
47 | ;; | |
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: | |
50 | ;; | |
51 | ;; (grok USE-MODULES (lambda (x) CODE)) | |
52 | ;; | |
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 | |
56 | ;; IMPLEMENTED!]] | |
57 | ;; | |
58 | ;; Currently, there are two convenience predicates that operate on `x': | |
59 | ;; (in-group? x GROUP) | |
60 | ;; (name-prefix? x PREFIX) | |
d1d0c7af | 61 | ;; |
e366d58b TTN |
62 | ;; TODO: Allow for concurrent Scheme/C membership. |
63 | ;; Completely separate reporting. | |
091cf411 TTN |
64 | |
65 | ;;; Code: | |
66 | ||
091cf411 TTN |
67 | (define-module (scripts scan-api) |
68 | :use-module (ice-9 popen) | |
69 | :use-module (ice-9 rdelim) | |
70 | :use-module (ice-9 regex) | |
71 | :export (scan-api)) | |
72 | ||
73 | (define put set-object-property!) | |
74 | (define get object-property) | |
75 | ||
e366d58b TTN |
76 | (define (add-props object . args) |
77 | (let loop ((args args)) | |
78 | (if (null? args) | |
79 | object ; retval | |
80 | (let ((key (car args)) | |
81 | (value (cadr args))) | |
82 | (put object key value) | |
83 | (loop (cddr args)))))) | |
84 | ||
091cf411 TTN |
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) | |
90 | (begin | |
91 | (cond ((regexp-exec rx line) => match)) | |
92 | (loop (read-line port))))))) | |
93 | ||
94 | (define (scan-Scheme! ht guile) | |
95 | (scan "^.guile.+: ([^ \t]+)([ \t]+(.+))*$" | |
96 | (format #f "~A -c '~S ~S'" | |
97 | guile | |
98 | '(use-modules (ice-9 session)) | |
99 | '(apropos ".")) | |
100 | (lambda (m) | |
101 | (let ((x (string->symbol (match:substring m 1)))) | |
102 | (put x 'Scheme (or (match:substring m 3) | |
103 | "")) | |
104 | (hashq-set! ht x #t))))) | |
105 | ||
106 | (define (scan-C! ht sofile) | |
94173d5f | 107 | (scan "^[0-9a-fA-F]+ ([B-TV-Z]) (.+)$" |
091cf411 TTN |
108 | (format #f "nm ~A" sofile) |
109 | (lambda (m) | |
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))))) | |
115 | ||
116 | (define THIS-MODULE (current-module)) | |
117 | ||
118 | (define (in-group? x group) | |
119 | (memq group (get x 'groups))) | |
120 | ||
121 | (define (name-prefix? x prefix) | |
122 | (string-match (string-append "^" prefix) (symbol->string x))) | |
123 | ||
124 | (define (add-group-name! x name) | |
125 | (put x 'groups (cons name (get x 'groups)))) | |
126 | ||
e366d58b | 127 | (define (make-grok-proc name form) |
091cf411 TTN |
128 | (let* ((predicate? (eval form THIS-MODULE)) |
129 | (p (lambda (x) | |
130 | (and (predicate? x) | |
131 | (add-group-name! x name))))) | |
132 | (put p 'name name) | |
133 | p)) | |
134 | ||
e366d58b | 135 | (define (make-members-proc name members) |
091cf411 TTN |
136 | (let ((p (lambda (x) |
137 | (and (memq x members) | |
138 | (add-group-name! x name))))) | |
139 | (put p 'name name) | |
140 | p)) | |
141 | ||
e366d58b TTN |
142 | (define (make-grouper files) ; \/^^^o/ . o |
143 | (let ((hook (make-hook 1))) ; /\____\ | |
144 | (for-each | |
145 | (lambda (file) | |
146 | (for-each | |
147 | (lambda (gdef) | |
148 | (let ((name (car gdef)) | |
149 | (members (assq-ref gdef 'members)) | |
150 | (grok (assq-ref gdef 'grok))) | |
151 | (or members grok | |
152 | (error "bad grouping, must have `members' or `grok'")) | |
153 | (add-hook! hook | |
154 | (if grok | |
155 | (add-props (make-grok-proc name (cadr grok)) | |
156 | 'description | |
157 | (assq-ref gdef 'description)) | |
158 | (make-members-proc name members)) | |
159 | #t))) ; append | |
160 | (read (open-file file OPEN_READ)))) | |
161 | files) | |
091cf411 TTN |
162 | hook)) |
163 | ||
164 | (define (scan-api . args) | |
165 | (let ((guile (list-ref args 0)) | |
166 | (sofile (list-ref args 1)) | |
e366d58b | 167 | (grouper (false-if-exception (make-grouper (cddr args)))) |
091cf411 TTN |
168 | (ht (make-hash-table 3331))) |
169 | (scan-Scheme! ht guile) | |
170 | (scan-C! ht sofile) | |
171 | (let ((all (sort (hash-fold (lambda (key value prior-result) | |
e366d58b TTN |
172 | (add-props |
173 | key | |
174 | 'string (symbol->string key) | |
175 | 'scan-data (or (get key 'Scheme) | |
176 | (get key 'C)) | |
177 | 'groups (if (get key 'Scheme) | |
178 | '(Scheme) | |
179 | '(C))) | |
180 | (and grouper (run-hook grouper key)) | |
091cf411 TTN |
181 | (cons key prior-result)) |
182 | '() | |
183 | ht) | |
184 | (lambda (a b) | |
e366d58b TTN |
185 | (string<? (get a 'string) |
186 | (get b 'string)))))) | |
091cf411 TTN |
187 | (format #t ";;; generated ~A UTC by scan-api -- do not edit!\n\n" |
188 | (strftime "%Y-%m-%d %H:%M:%S" (gmtime (current-time)))) | |
189 | (format #t "(\n") | |
190 | (format #t "(meta\n") | |
191 | (format #t " (GUILE_LOAD_PATH . ~S)\n" | |
192 | (or (getenv "GUILE_LOAD_PATH") "")) | |
193 | (format #t " (LTDL_LIBRARY_PATH . ~S)\n" | |
194 | (or (getenv "LTDL_LIBRARY_PATH") "")) | |
195 | (format #t " (guile . ~S)\n" guile) | |
196 | (format #t " (libguileinterface . ~S)\n" | |
197 | (let ((i #f)) | |
198 | (scan "(.+)" | |
199 | (format #f "~A -c '(display ~A)'" | |
200 | guile | |
201 | '(assq-ref %guile-build-info | |
202 | 'libguileinterface)) | |
203 | (lambda (m) (set! i (match:substring m 1)))) | |
204 | i)) | |
205 | (format #t " (sofile . ~S)\n" sofile) | |
206 | (format #t " ~A\n" | |
94a972ac TTN |
207 | (cons 'groups (append (if grouper |
208 | (map (lambda (p) (get p 'name)) | |
209 | (hook->list grouper)) | |
210 | '()) | |
211 | '(Scheme C)))) | |
091cf411 TTN |
212 | (format #t ") ;; end of meta\n") |
213 | (format #t "(interface\n") | |
214 | (for-each (lambda (x) | |
215 | (format #t "(~A ~A (scan-data ~S))\n" | |
216 | x | |
217 | (cons 'groups (get x 'groups)) | |
218 | (get x 'scan-data))) | |
219 | all) | |
220 | (format #t ") ;; end of interface\n") | |
221 | (format #t ") ;; eof\n"))) | |
222 | #t) | |
223 | ||
224 | (define main scan-api) | |
225 | ||
226 | ;;; scan-api ends here |