Commit | Line | Data |
---|---|---|
091cf411 TTN |
1 | ;;; scan-api --- Scan and group interpreter and libguile interface elements |
2 | ||
6e7d5622 | 3 | ;; Copyright (C) 2002, 2006 Free Software Foundation, Inc. |
091cf411 TTN |
4 | ;; |
5 | ;; This program is free software; you can redistribute it and/or | |
6 | ;; modify it under the terms of the GNU General Public License as | |
7 | ;; published by the Free Software Foundation; either version 2, or | |
8 | ;; (at your option) any later version. | |
9 | ;; | |
10 | ;; This program is distributed in the hope that it will be useful, | |
11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
13 | ;; General Public License for more details. | |
14 | ;; | |
15 | ;; You should have received a copy of the GNU General Public License | |
16 | ;; along with this software; see the file COPYING. If not, write to | |
92205699 MV |
17 | ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
18 | ;; Boston, MA 02110-1301 USA | |
091cf411 TTN |
19 | |
20 | ;;; Author: Thien-Thi Nguyen <ttn@gnu.org> | |
21 | ||
22 | ;;; Commentary: | |
23 | ||
e366d58b | 24 | ;; Usage: scan-api GUILE SOFILE [GROUPINGS ...] |
091cf411 TTN |
25 | ;; |
26 | ;; Invoke GUILE, an executable guile interpreter, and use nm(1) on SOFILE, a | |
27 | ;; shared-object library, to determine available interface elements, and | |
28 | ;; display them to stdout as an alist: | |
29 | ;; | |
30 | ;; ((meta ...) (interface ...)) | |
31 | ;; | |
32 | ;; The meta fields are `GUILE_LOAD_PATH', `LTDL_LIBRARY_PATH', `guile' | |
33 | ;; `libguileinterface', `sofile' and `groups'. The interface elements are in | |
34 | ;; turn sub-alists w/ keys `groups' and `scan-data'. Interface elements | |
35 | ;; initially belong in one of two groups `Scheme' or `C' (but not both -- | |
36 | ;; signal error if that happens). | |
37 | ;; | |
e366d58b TTN |
38 | ;; Optional GROUPINGS ... are files each containing a single "grouping |
39 | ;; definition" alist with each entry of the form: | |
091cf411 TTN |
40 | ;; |
41 | ;; (NAME (description "DESCRIPTION") (members SYM...)) | |
42 | ;; | |
43 | ;; All of the SYM... should be proper subsets of the interface. In addition | |
44 | ;; to `description' and `members' forms, the entry may optionally include: | |
45 | ;; | |
46 | ;; (grok USE-MODULES (lambda (x) CODE)) | |
47 | ;; | |
48 | ;; where CODE implements a group-membership predicate to be applied to `x', a | |
49 | ;; symbol. [When evaluated, CODE can assume (use-modules MODULE) has been | |
50 | ;; executed where MODULE is an element of USE-MODULES, a list. [NOT YET | |
51 | ;; IMPLEMENTED!]] | |
52 | ;; | |
53 | ;; Currently, there are two convenience predicates that operate on `x': | |
54 | ;; (in-group? x GROUP) | |
55 | ;; (name-prefix? x PREFIX) | |
d1d0c7af | 56 | ;; |
e366d58b TTN |
57 | ;; TODO: Allow for concurrent Scheme/C membership. |
58 | ;; Completely separate reporting. | |
091cf411 TTN |
59 | |
60 | ;;; Code: | |
61 | ||
091cf411 TTN |
62 | (define-module (scripts scan-api) |
63 | :use-module (ice-9 popen) | |
64 | :use-module (ice-9 rdelim) | |
65 | :use-module (ice-9 regex) | |
66 | :export (scan-api)) | |
67 | ||
68 | (define put set-object-property!) | |
69 | (define get object-property) | |
70 | ||
e366d58b TTN |
71 | (define (add-props object . args) |
72 | (let loop ((args args)) | |
73 | (if (null? args) | |
74 | object ; retval | |
75 | (let ((key (car args)) | |
76 | (value (cadr args))) | |
77 | (put object key value) | |
78 | (loop (cddr args)))))) | |
79 | ||
091cf411 TTN |
80 | (define (scan re command match) |
81 | (let ((rx (make-regexp re)) | |
82 | (port (open-pipe command OPEN_READ))) | |
83 | (let loop ((line (read-line port))) | |
84 | (or (eof-object? line) | |
85 | (begin | |
86 | (cond ((regexp-exec rx line) => match)) | |
87 | (loop (read-line port))))))) | |
88 | ||
89 | (define (scan-Scheme! ht guile) | |
90 | (scan "^.guile.+: ([^ \t]+)([ \t]+(.+))*$" | |
91 | (format #f "~A -c '~S ~S'" | |
92 | guile | |
93 | '(use-modules (ice-9 session)) | |
94 | '(apropos ".")) | |
95 | (lambda (m) | |
96 | (let ((x (string->symbol (match:substring m 1)))) | |
97 | (put x 'Scheme (or (match:substring m 3) | |
98 | "")) | |
99 | (hashq-set! ht x #t))))) | |
100 | ||
101 | (define (scan-C! ht sofile) | |
94173d5f | 102 | (scan "^[0-9a-fA-F]+ ([B-TV-Z]) (.+)$" |
091cf411 TTN |
103 | (format #f "nm ~A" sofile) |
104 | (lambda (m) | |
105 | (let ((x (string->symbol (match:substring m 2)))) | |
106 | (put x 'C (string->symbol (match:substring m 1))) | |
107 | (and (hashq-get-handle ht x) | |
108 | (error "both Scheme and C:" x)) | |
109 | (hashq-set! ht x #t))))) | |
110 | ||
111 | (define THIS-MODULE (current-module)) | |
112 | ||
113 | (define (in-group? x group) | |
114 | (memq group (get x 'groups))) | |
115 | ||
116 | (define (name-prefix? x prefix) | |
117 | (string-match (string-append "^" prefix) (symbol->string x))) | |
118 | ||
119 | (define (add-group-name! x name) | |
120 | (put x 'groups (cons name (get x 'groups)))) | |
121 | ||
e366d58b | 122 | (define (make-grok-proc name form) |
091cf411 TTN |
123 | (let* ((predicate? (eval form THIS-MODULE)) |
124 | (p (lambda (x) | |
125 | (and (predicate? x) | |
126 | (add-group-name! x name))))) | |
127 | (put p 'name name) | |
128 | p)) | |
129 | ||
e366d58b | 130 | (define (make-members-proc name members) |
091cf411 TTN |
131 | (let ((p (lambda (x) |
132 | (and (memq x members) | |
133 | (add-group-name! x name))))) | |
134 | (put p 'name name) | |
135 | p)) | |
136 | ||
e366d58b TTN |
137 | (define (make-grouper files) ; \/^^^o/ . o |
138 | (let ((hook (make-hook 1))) ; /\____\ | |
139 | (for-each | |
140 | (lambda (file) | |
141 | (for-each | |
142 | (lambda (gdef) | |
143 | (let ((name (car gdef)) | |
144 | (members (assq-ref gdef 'members)) | |
145 | (grok (assq-ref gdef 'grok))) | |
146 | (or members grok | |
147 | (error "bad grouping, must have `members' or `grok'")) | |
148 | (add-hook! hook | |
149 | (if grok | |
150 | (add-props (make-grok-proc name (cadr grok)) | |
151 | 'description | |
152 | (assq-ref gdef 'description)) | |
153 | (make-members-proc name members)) | |
154 | #t))) ; append | |
155 | (read (open-file file OPEN_READ)))) | |
156 | files) | |
091cf411 TTN |
157 | hook)) |
158 | ||
159 | (define (scan-api . args) | |
160 | (let ((guile (list-ref args 0)) | |
161 | (sofile (list-ref args 1)) | |
e366d58b | 162 | (grouper (false-if-exception (make-grouper (cddr args)))) |
091cf411 TTN |
163 | (ht (make-hash-table 3331))) |
164 | (scan-Scheme! ht guile) | |
165 | (scan-C! ht sofile) | |
166 | (let ((all (sort (hash-fold (lambda (key value prior-result) | |
e366d58b TTN |
167 | (add-props |
168 | key | |
169 | 'string (symbol->string key) | |
170 | 'scan-data (or (get key 'Scheme) | |
171 | (get key 'C)) | |
172 | 'groups (if (get key 'Scheme) | |
173 | '(Scheme) | |
174 | '(C))) | |
175 | (and grouper (run-hook grouper key)) | |
091cf411 TTN |
176 | (cons key prior-result)) |
177 | '() | |
178 | ht) | |
179 | (lambda (a b) | |
e366d58b TTN |
180 | (string<? (get a 'string) |
181 | (get b 'string)))))) | |
e4af2baf | 182 | (format #t ";;; generated by scan-api -- do not edit!\n\n") |
091cf411 TTN |
183 | (format #t "(\n") |
184 | (format #t "(meta\n") | |
185 | (format #t " (GUILE_LOAD_PATH . ~S)\n" | |
186 | (or (getenv "GUILE_LOAD_PATH") "")) | |
187 | (format #t " (LTDL_LIBRARY_PATH . ~S)\n" | |
188 | (or (getenv "LTDL_LIBRARY_PATH") "")) | |
189 | (format #t " (guile . ~S)\n" guile) | |
190 | (format #t " (libguileinterface . ~S)\n" | |
191 | (let ((i #f)) | |
192 | (scan "(.+)" | |
193 | (format #f "~A -c '(display ~A)'" | |
194 | guile | |
195 | '(assq-ref %guile-build-info | |
196 | 'libguileinterface)) | |
197 | (lambda (m) (set! i (match:substring m 1)))) | |
198 | i)) | |
199 | (format #t " (sofile . ~S)\n" sofile) | |
200 | (format #t " ~A\n" | |
94a972ac TTN |
201 | (cons 'groups (append (if grouper |
202 | (map (lambda (p) (get p 'name)) | |
203 | (hook->list grouper)) | |
204 | '()) | |
205 | '(Scheme C)))) | |
091cf411 TTN |
206 | (format #t ") ;; end of meta\n") |
207 | (format #t "(interface\n") | |
208 | (for-each (lambda (x) | |
209 | (format #t "(~A ~A (scan-data ~S))\n" | |
210 | x | |
211 | (cons 'groups (get x 'groups)) | |
212 | (get x 'scan-data))) | |
213 | all) | |
214 | (format #t ") ;; end of interface\n") | |
215 | (format #t ") ;; eof\n"))) | |
216 | #t) | |
217 | ||
218 | (define main scan-api) | |
219 | ||
220 | ;;; scan-api ends here |