mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 11:50:28 +02:00
guile-tools is a scheme script that loads scheme modules
* meta/guile-tools: Changed to be a scheme script. Instead of looking for executables in a "scripts dir", we just look for modules in (scripts), and load the modules directly. * module/Makefile.am: * module/scripts/: Move the scripts into module/ so they can be compiled. Rename scripts from `foo' to `foo.scm'. * libguile/Makefile.am: Invoke the snarf->texi code via guile-tools. * configure.in: * .gitignore: Update for changes.
This commit is contained in:
Andy Wingo
parent
798244609b
commit
6d66647d5b
30 changed files with 134 additions and 290 deletions
220
module/scripts/scan-api.scm
Normal file
220
module/scripts/scan-api.scm
Normal file
|
|
@ -0,0 +1,220 @@
|
|||
;;; scan-api --- Scan and group interpreter and libguile interface elements
|
||||
|
||||
;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
|
||||
;;
|
||||
;; This program is free software; you can redistribute it and/or
|
||||
;; modify it under the terms of the GNU General Public License as
|
||||
;; published by the Free Software Foundation; either version 2, 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
|
||||
;; General Public License for more details.
|
||||
;;
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this software; see the file COPYING. 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 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
|
||||
Loading…
Add table
Add a link
Reference in a new issue