26 |
|
|
27 |
;;; Commentary: |
;;; Commentary: |
28 |
|
|
29 |
;; Usage: scan-api GUILE SOFILE [GROUPINGS] |
;; Usage: scan-api GUILE SOFILE [GROUPINGS ...] |
30 |
;; |
;; |
31 |
;; Invoke GUILE, an executable guile interpreter, and use nm(1) on SOFILE, a |
;; Invoke GUILE, an executable guile interpreter, and use nm(1) on SOFILE, a |
32 |
;; shared-object library, to determine available interface elements, and |
;; shared-object library, to determine available interface elements, and |
40 |
;; initially belong in one of two groups `Scheme' or `C' (but not both -- |
;; initially belong in one of two groups `Scheme' or `C' (but not both -- |
41 |
;; signal error if that happens). |
;; signal error if that happens). |
42 |
;; |
;; |
43 |
;; Optional arg GROUPINGS is a file containing a grouping definition alist, |
;; Optional GROUPINGS ... are files each containing a single "grouping |
44 |
;; each entry of which has the form: |
;; definition" alist with each entry of the form: |
45 |
;; |
;; |
46 |
;; (NAME (description "DESCRIPTION") (members SYM...)) |
;; (NAME (description "DESCRIPTION") (members SYM...)) |
47 |
;; |
;; |
59 |
;; (in-group? x GROUP) |
;; (in-group? x GROUP) |
60 |
;; (name-prefix? x PREFIX) |
;; (name-prefix? x PREFIX) |
61 |
;; |
;; |
62 |
;; TODO: Move symbol->string to hash-fold to make sorting more efficient. |
;; TODO: Allow for concurrent Scheme/C membership. |
63 |
;; Allow for concurrent Scheme/C membership. |
;; Completely separate reporting. |
64 |
|
|
65 |
;;; Code: |
;;; Code: |
66 |
|
|
73 |
(define put set-object-property!) |
(define put set-object-property!) |
74 |
(define get object-property) |
(define get object-property) |
75 |
|
|
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 |
|
|
85 |
(define (scan re command match) |
(define (scan re command match) |
86 |
(let ((rx (make-regexp re)) |
(let ((rx (make-regexp re)) |
87 |
(port (open-pipe command OPEN_READ))) |
(port (open-pipe command OPEN_READ))) |
124 |
(define (add-group-name! x name) |
(define (add-group-name! x name) |
125 |
(put x 'groups (cons name (get x 'groups)))) |
(put x 'groups (cons name (get x 'groups)))) |
126 |
|
|
127 |
(define (make-grok-hook name form) |
(define (make-grok-proc name form) |
128 |
(let* ((predicate? (eval form THIS-MODULE)) |
(let* ((predicate? (eval form THIS-MODULE)) |
129 |
(p (lambda (x) |
(p (lambda (x) |
130 |
(and (predicate? x) |
(and (predicate? x) |
132 |
(put p 'name name) |
(put p 'name name) |
133 |
p)) |
p)) |
134 |
|
|
135 |
(define (make-members-hook name members) |
(define (make-members-proc name members) |
136 |
(let ((p (lambda (x) |
(let ((p (lambda (x) |
137 |
(and (memq x members) |
(and (memq x members) |
138 |
(add-group-name! x name))))) |
(add-group-name! x name))))) |
139 |
(put p 'name name) |
(put p 'name name) |
140 |
p)) |
p)) |
141 |
|
|
142 |
(define (make-grouping-hook file) |
(define (make-grouper files) ; \/^^^o/ . o |
143 |
(let ((hook (make-hook 1))) |
(let ((hook (make-hook 1))) ; /\____\ |
144 |
(for-each (lambda (gdef) |
(for-each |
145 |
(let ((name (car gdef)) |
(lambda (file) |
146 |
(members (assq-ref gdef 'members)) |
(for-each |
147 |
(grok (assq-ref gdef 'grok))) |
(lambda (gdef) |
148 |
(or members grok |
(let ((name (car gdef)) |
149 |
(error "bad grouping, must have `members' or `grok'")) |
(members (assq-ref gdef 'members)) |
150 |
(add-hook! hook |
(grok (assq-ref gdef 'grok))) |
151 |
(if grok |
(or members grok |
152 |
(make-grok-hook name (cadr grok)) |
(error "bad grouping, must have `members' or `grok'")) |
153 |
(make-members-hook name members)) |
(add-hook! hook |
154 |
#t))) ; append |
(if grok |
155 |
(read (open-file file "r"))) |
(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) |
162 |
hook)) |
hook)) |
163 |
|
|
164 |
(define (scan-api . args) |
(define (scan-api . args) |
165 |
(let ((guile (list-ref args 0)) |
(let ((guile (list-ref args 0)) |
166 |
(sofile (list-ref args 1)) |
(sofile (list-ref args 1)) |
167 |
(grouping-hook (false-if-exception |
(grouper (false-if-exception (make-grouper (cddr args)))) |
|
(make-grouping-hook (list-ref args 2)))) |
|
168 |
(ht (make-hash-table 3331))) |
(ht (make-hash-table 3331))) |
169 |
(scan-Scheme! ht guile) |
(scan-Scheme! ht guile) |
170 |
(scan-C! ht sofile) |
(scan-C! ht sofile) |
171 |
(let ((all (sort (hash-fold (lambda (key value prior-result) |
(let ((all (sort (hash-fold (lambda (key value prior-result) |
172 |
(put key 'scan-data |
(add-props |
173 |
(or (get key 'Scheme) |
key |
174 |
(get key 'C))) |
'string (symbol->string key) |
175 |
(put key 'groups |
'scan-data (or (get key 'Scheme) |
176 |
(if (get key 'Scheme) |
(get key 'C)) |
177 |
'(Scheme) |
'groups (if (get key 'Scheme) |
178 |
'(C))) |
'(Scheme) |
179 |
(and grouping-hook |
'(C))) |
180 |
(run-hook grouping-hook key)) |
(and grouper (run-hook grouper key)) |
181 |
(cons key prior-result)) |
(cons key prior-result)) |
182 |
'() |
'() |
183 |
ht) |
ht) |
184 |
(lambda (a b) |
(lambda (a b) |
185 |
(string<? (symbol->string a) |
(string<? (get a 'string) |
186 |
(symbol->string b)))))) |
(get b 'string)))))) |
187 |
(format #t ";;; generated ~A UTC by scan-api -- do not edit!\n\n" |
(format #t ";;; generated ~A UTC by scan-api -- do not edit!\n\n" |
188 |
(strftime "%Y-%m-%d %H:%M:%S" (gmtime (current-time)))) |
(strftime "%Y-%m-%d %H:%M:%S" (gmtime (current-time)))) |
189 |
(format #t "(\n") |
(format #t "(\n") |
204 |
i)) |
i)) |
205 |
(format #t " (sofile . ~S)\n" sofile) |
(format #t " (sofile . ~S)\n" sofile) |
206 |
(format #t " ~A\n" |
(format #t " ~A\n" |
207 |
(cons 'groups (if grouping-hook |
(cons 'groups (if grouper |
208 |
(map (lambda (p) (get p 'name)) |
(map (lambda (p) (get p 'name)) |
209 |
(hook->list grouping-hook)) |
(hook->list grouper)) |
210 |
'(Scheme C)))) |
'(Scheme C)))) |
211 |
(format #t ") ;; end of meta\n") |
(format #t ") ;; end of meta\n") |
212 |
(format #t "(interface\n") |
(format #t "(interface\n") |