summaryrefslogtreecommitdiff
path: root/scripts/scan-api
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2009-04-17 11:19:42 +0200
committerAndy Wingo <wingo@pobox.com>2009-04-17 11:19:42 +0200
commit6d66647d5b2c6649bb4dade734f6d583d10d797c (patch)
tree3c05d62af67617f0949fbe4a4228ac3564da0be5 /scripts/scan-api
parent798244609bfd3b4d2b12f722d9130d47abcfeb1a (diff)
downloadguile-6d66647d5b2c6649bb4dade734f6d583d10d797c.tar.gz
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.
Diffstat (limited to 'scripts/scan-api')
-rwxr-xr-xscripts/scan-api225
1 files changed, 0 insertions, 225 deletions
diff --git a/scripts/scan-api b/scripts/scan-api
deleted file mode 100755
index 3ea10dbe6..000000000
--- a/scripts/scan-api
+++ /dev/null
@@ -1,225 +0,0 @@
-#!/bin/sh
-# aside from this initial boilerplate, this is actually -*- scheme -*- code
-main='(module-ref (resolve-module '\''(scripts scan-api)) '\'main')'
-exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
-!#
-;;; 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