/[guile]/guile/guile-core/scripts/scan-api
ViewVC logotype

Diff of /guile/guile-core/scripts/scan-api

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.5 by ttn, Thu May 9 16:27:40 2002 UTC revision 1.6 by ttn, Fri May 10 22:17:39 2002 UTC
# Line 26  exec ${GUILE-guile} -l $0 -c "(apply $ma Line 26  exec ${GUILE-guile} -l $0 -c "(apply $ma
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
# Line 40  exec ${GUILE-guile} -l $0 -c "(apply $ma Line 40  exec ${GUILE-guile} -l $0 -c "(apply $ma
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  ;;  ;;
# Line 59  exec ${GUILE-guile} -l $0 -c "(apply $ma Line 59  exec ${GUILE-guile} -l $0 -c "(apply $ma
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    
# Line 73  exec ${GUILE-guile} -l $0 -c "(apply $ma Line 73  exec ${GUILE-guile} -l $0 -c "(apply $ma
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)))
# Line 115  exec ${GUILE-guile} -l $0 -c "(apply $ma Line 124  exec ${GUILE-guile} -l $0 -c "(apply $ma
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)
# Line 123  exec ${GUILE-guile} -l $0 -c "(apply $ma Line 132  exec ${GUILE-guile} -l $0 -c "(apply $ma
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")
# Line 190  exec ${GUILE-guile} -l $0 -c "(apply $ma Line 204  exec ${GUILE-guile} -l $0 -c "(apply $ma
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")

Legend:
Removed from v.1.5  
changed lines
  Added in v.1.6

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26