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 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