mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
* module/scripts/: Add %summary entries, and in many cases, %include-in-guild-list entries to inhibit a script from appearing in "guild list". Update list.scm to respect this new variable.
223 lines
8.1 KiB
Scheme
223 lines
8.1 KiB
Scheme
;;; scan-api --- Scan and group interpreter and libguile interface elements
|
|
|
|
;; Copyright (C) 2002, 2006, 2011 Free Software Foundation, Inc.
|
|
;;
|
|
;; This program is free software; you can redistribute it and/or
|
|
;; modify it under the terms of the GNU Lesser General Public License
|
|
;; as published by the Free Software Foundation; either version 3, or
|
|
;; (at your option) any later version.
|
|
;;
|
|
;; This program is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
;; Lesser General Public License for more details.
|
|
;;
|
|
;; You should have received a copy of the GNU Lesser General Public
|
|
;; License along with this software; see the file COPYING.LESSER. If
|
|
;; not, write to the Free Software Foundation, Inc., 51 Franklin
|
|
;; Street, Fifth Floor, Boston, MA 02110-1301 USA
|
|
|
|
;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
|
|
|
|
;;; Commentary:
|
|
|
|
;; Usage: scan-api GUILE SOFILE [GROUPINGS ...]
|
|
;;
|
|
;; Invoke GUILE, an executable guile interpreter, and use nm(1) on SOFILE, a
|
|
;; shared-object library, to determine available interface elements, and
|
|
;; display them to stdout as an alist:
|
|
;;
|
|
;; ((meta ...) (interface ...))
|
|
;;
|
|
;; The meta fields are `GUILE_LOAD_PATH', `LTDL_LIBRARY_PATH', `guile'
|
|
;; `libguileinterface', `sofile' and `groups'. The interface elements are in
|
|
;; turn sub-alists w/ keys `groups' and `scan-data'. Interface elements
|
|
;; initially belong in one of two groups `Scheme' or `C' (but not both --
|
|
;; signal error if that happens).
|
|
;;
|
|
;; Optional GROUPINGS ... are files each containing a single "grouping
|
|
;; definition" alist with each entry of the form:
|
|
;;
|
|
;; (NAME (description "DESCRIPTION") (members SYM...))
|
|
;;
|
|
;; All of the SYM... should be proper subsets of the interface. In addition
|
|
;; to `description' and `members' forms, the entry may optionally include:
|
|
;;
|
|
;; (grok USE-MODULES (lambda (x) CODE))
|
|
;;
|
|
;; where CODE implements a group-membership predicate to be applied to `x', a
|
|
;; symbol. [When evaluated, CODE can assume (use-modules MODULE) has been
|
|
;; executed where MODULE is an element of USE-MODULES, a list. [NOT YET
|
|
;; IMPLEMENTED!]]
|
|
;;
|
|
;; Currently, there are two convenience predicates that operate on `x':
|
|
;; (in-group? x GROUP)
|
|
;; (name-prefix? x PREFIX)
|
|
;;
|
|
;; TODO: Allow for concurrent Scheme/C membership.
|
|
;; Completely separate reporting.
|
|
|
|
;;; Code:
|
|
|
|
(define-module (scripts scan-api)
|
|
:use-module (ice-9 popen)
|
|
:use-module (ice-9 rdelim)
|
|
:use-module (ice-9 regex)
|
|
:export (scan-api))
|
|
|
|
(define %include-in-guild-list #f)
|
|
(define %summary "Generate an API description for a Guile extension.")
|
|
|
|
(define put set-object-property!)
|
|
(define get object-property)
|
|
|
|
(define (add-props object . args)
|
|
(let loop ((args args))
|
|
(if (null? args)
|
|
object ; retval
|
|
(let ((key (car args))
|
|
(value (cadr args)))
|
|
(put object key value)
|
|
(loop (cddr args))))))
|
|
|
|
(define (scan re command match)
|
|
(let ((rx (make-regexp re))
|
|
(port (open-pipe command OPEN_READ)))
|
|
(let loop ((line (read-line port)))
|
|
(or (eof-object? line)
|
|
(begin
|
|
(cond ((regexp-exec rx line) => match))
|
|
(loop (read-line port)))))))
|
|
|
|
(define (scan-Scheme! ht guile)
|
|
(scan "^.guile.+: ([^ \t]+)([ \t]+(.+))*$"
|
|
(format #f "~A -c '~S ~S'"
|
|
guile
|
|
'(use-modules (ice-9 session))
|
|
'(apropos "."))
|
|
(lambda (m)
|
|
(let ((x (string->symbol (match:substring m 1))))
|
|
(put x 'Scheme (or (match:substring m 3)
|
|
""))
|
|
(hashq-set! ht x #t)))))
|
|
|
|
(define (scan-C! ht sofile)
|
|
(scan "^[0-9a-fA-F]+ ([B-TV-Z]) (.+)$"
|
|
(format #f "nm ~A" sofile)
|
|
(lambda (m)
|
|
(let ((x (string->symbol (match:substring m 2))))
|
|
(put x 'C (string->symbol (match:substring m 1)))
|
|
(and (hashq-get-handle ht x)
|
|
(error "both Scheme and C:" x))
|
|
(hashq-set! ht x #t)))))
|
|
|
|
(define THIS-MODULE (current-module))
|
|
|
|
(define (in-group? x group)
|
|
(memq group (get x 'groups)))
|
|
|
|
(define (name-prefix? x prefix)
|
|
(string-match (string-append "^" prefix) (symbol->string x)))
|
|
|
|
(define (add-group-name! x name)
|
|
(put x 'groups (cons name (get x 'groups))))
|
|
|
|
(define (make-grok-proc name form)
|
|
(let* ((predicate? (eval form THIS-MODULE))
|
|
(p (lambda (x)
|
|
(and (predicate? x)
|
|
(add-group-name! x name)))))
|
|
(put p 'name name)
|
|
p))
|
|
|
|
(define (make-members-proc name members)
|
|
(let ((p (lambda (x)
|
|
(and (memq x members)
|
|
(add-group-name! x name)))))
|
|
(put p 'name name)
|
|
p))
|
|
|
|
(define (make-grouper files) ; \/^^^o/ . o
|
|
(let ((hook (make-hook 1))) ; /\____\
|
|
(for-each
|
|
(lambda (file)
|
|
(for-each
|
|
(lambda (gdef)
|
|
(let ((name (car gdef))
|
|
(members (assq-ref gdef 'members))
|
|
(grok (assq-ref gdef 'grok)))
|
|
(or members grok
|
|
(error "bad grouping, must have `members' or `grok'"))
|
|
(add-hook! hook
|
|
(if grok
|
|
(add-props (make-grok-proc name (cadr grok))
|
|
'description
|
|
(assq-ref gdef 'description))
|
|
(make-members-proc name members))
|
|
#t))) ; append
|
|
(read (open-file file OPEN_READ))))
|
|
files)
|
|
hook))
|
|
|
|
(define (scan-api . args)
|
|
(let ((guile (list-ref args 0))
|
|
(sofile (list-ref args 1))
|
|
(grouper (false-if-exception (make-grouper (cddr args))))
|
|
(ht (make-hash-table 3331)))
|
|
(scan-Scheme! ht guile)
|
|
(scan-C! ht sofile)
|
|
(let ((all (sort (hash-fold (lambda (key value prior-result)
|
|
(add-props
|
|
key
|
|
'string (symbol->string key)
|
|
'scan-data (or (get key 'Scheme)
|
|
(get key 'C))
|
|
'groups (if (get key 'Scheme)
|
|
'(Scheme)
|
|
'(C)))
|
|
(and grouper (run-hook grouper key))
|
|
(cons key prior-result))
|
|
'()
|
|
ht)
|
|
(lambda (a b)
|
|
(string<? (get a 'string)
|
|
(get b 'string))))))
|
|
(format #t ";;; generated by scan-api -- do not edit!\n\n")
|
|
(format #t "(\n")
|
|
(format #t "(meta\n")
|
|
(format #t " (GUILE_LOAD_PATH . ~S)\n"
|
|
(or (getenv "GUILE_LOAD_PATH") ""))
|
|
(format #t " (LTDL_LIBRARY_PATH . ~S)\n"
|
|
(or (getenv "LTDL_LIBRARY_PATH") ""))
|
|
(format #t " (guile . ~S)\n" guile)
|
|
(format #t " (libguileinterface . ~S)\n"
|
|
(let ((i #f))
|
|
(scan "(.+)"
|
|
(format #f "~A -c '(display ~A)'"
|
|
guile
|
|
'(assq-ref %guile-build-info
|
|
'libguileinterface))
|
|
(lambda (m) (set! i (match:substring m 1))))
|
|
i))
|
|
(format #t " (sofile . ~S)\n" sofile)
|
|
(format #t " ~A\n"
|
|
(cons 'groups (append (if grouper
|
|
(map (lambda (p) (get p 'name))
|
|
(hook->list grouper))
|
|
'())
|
|
'(Scheme C))))
|
|
(format #t ") ;; end of meta\n")
|
|
(format #t "(interface\n")
|
|
(for-each (lambda (x)
|
|
(format #t "(~A ~A (scan-data ~S))\n"
|
|
x
|
|
(cons 'groups (get x 'groups))
|
|
(get x 'scan-data)))
|
|
all)
|
|
(format #t ") ;; end of interface\n")
|
|
(format #t ") ;; eof\n")))
|
|
#t)
|
|
|
|
(define main scan-api)
|
|
|
|
;;; scan-api ends here
|