mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 11:40:18 +02:00
Initial revision
This commit is contained in:
Thien-Thi Nguyen
parent
7c8ce087f9
commit
2b8efa0cad
1 changed files with 221 additions and 0 deletions
221
scripts/autofrisk
Executable file
221
scripts/autofrisk
Executable file
|
|
@ -0,0 +1,221 @@
|
|||
#!/bin/sh
|
||||
# aside from this initial boilerplate, this is actually -*- scheme -*- code
|
||||
main='(module-ref (resolve-module '\''(scripts autofrisk)) '\'main')'
|
||||
exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
|
||||
!#
|
||||
;;; autofrisk --- Generate module checks for use with auto* tools
|
||||
|
||||
;; Copyright (C) 2002 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., 59 Temple Place, Suite 330,
|
||||
;; Boston, MA 02111-1307 USA
|
||||
|
||||
;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Usage: autofrisk [file]
|
||||
;;
|
||||
;; This program looks for the file modules.af in the current directory
|
||||
;; and writes out modules.af.m4 containing autoconf definitions.
|
||||
;; If given, look for FILE instead of modules.af and output to FILE.m4.
|
||||
;;
|
||||
;; After running autofrisk, you should add to configure.ac the lines:
|
||||
;; AUTOFRISK_CHECKS
|
||||
;; AUTOFRISK_SUMMARY
|
||||
;; Then run "aclocal -I ." to update aclocal.m4, and finally autoconf.
|
||||
;;
|
||||
;; The modules.af file consists of a series of configuration forms (Scheme
|
||||
;; lists), which have one of the following formats:
|
||||
;; (files-glob PATTERN ...)
|
||||
;; (non-critical-external MODULE ...)
|
||||
;; (non-critical-internal MODULE ...)
|
||||
;; (programs (MODULE PROG ...) ...)
|
||||
;; (pww-varname VARNAME)
|
||||
;; PATTERN is a string that may contain "*" and "?" characters to be
|
||||
;; expanded into filenames. MODULE is a list of symbols naming a
|
||||
;; module, such as `(srfi srfi-1)'. VARNAME is a shell-safe name to use
|
||||
;; instead of "probably_wont_work", the default. This var is passed to
|
||||
;; `AC_SUBST'. PROG is a string.
|
||||
;;
|
||||
;; Only the `files-glob' form is required.
|
||||
;;
|
||||
;; TODO: Write better commentary.
|
||||
;; Make "please see README" configurable.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(define-module (scripts autofrisk)
|
||||
:autoload (ice-9 popen) (open-input-pipe)
|
||||
:use-module (srfi srfi-1)
|
||||
:use-module (srfi srfi-8)
|
||||
:use-module (srfi srfi-13)
|
||||
:use-module (srfi srfi-14)
|
||||
:use-module (scripts read-scheme-source)
|
||||
:use-module (scripts frisk)
|
||||
:export (autofrisk))
|
||||
|
||||
(define *recognized-keys* '(files-glob
|
||||
non-critical-external
|
||||
non-critical-internal
|
||||
programs
|
||||
pww-varname))
|
||||
|
||||
(define (canonical-configuration forms)
|
||||
(let ((chk (lambda (condition . x)
|
||||
(or condition (apply error "syntax error:" x)))))
|
||||
(chk (list? forms) "input not a list")
|
||||
(chk (every list? forms) "non-list element")
|
||||
(chk (every (lambda (form) (< 1 (length form))) forms) "list too short")
|
||||
(let ((un #f))
|
||||
(chk (every (lambda (form)
|
||||
(let ((key (car form)))
|
||||
(and (symbol? key)
|
||||
(or (eq? 'quote key)
|
||||
(memq key *recognized-keys*)
|
||||
(begin
|
||||
(set! un key)
|
||||
#f)))))
|
||||
forms)
|
||||
"unrecognized key:" un))
|
||||
(let ((bunched (map (lambda (key)
|
||||
(fold (lambda (form so-far)
|
||||
(or (and (eq? (car form) key)
|
||||
(cdr form)
|
||||
(append so-far (cdr form)))
|
||||
so-far))
|
||||
(list key)
|
||||
forms))
|
||||
*recognized-keys*)))
|
||||
(lambda (key)
|
||||
(assq-ref bunched key)))))
|
||||
|
||||
(define (>>strong modules)
|
||||
(for-each (lambda (module)
|
||||
(format #t "GUILE_MODULE_REQUIRED~A\n" module))
|
||||
modules))
|
||||
|
||||
(define (safe-name module)
|
||||
(let ((var (object->string module)))
|
||||
(string-map! (lambda (c)
|
||||
(if (char-set-contains? char-set:letter+digit c)
|
||||
c
|
||||
#\_))
|
||||
var)
|
||||
var))
|
||||
|
||||
(define *pww* "probably_wont_work")
|
||||
|
||||
(define (>>weak weak-edges)
|
||||
(for-each (lambda (edge)
|
||||
(let* ((up (edge-up edge))
|
||||
(down (edge-down edge))
|
||||
(var (format #f "have_guile_module~A" (safe-name up))))
|
||||
(format #t "GUILE_MODULE_AVAILABLE(~A, ~A)\n" var up)
|
||||
(format #t "test \"$~A\" = no &&\n ~A=\"~A $~A\"~A"
|
||||
var *pww* down *pww* "\n\n")))
|
||||
weak-edges))
|
||||
|
||||
(define (>>program module progs)
|
||||
(let ((vars (map (lambda (prog)
|
||||
(format #f "guile_module~Asupport_~A"
|
||||
(safe-name module)
|
||||
prog))
|
||||
progs)))
|
||||
(for-each (lambda (var prog)
|
||||
(format #t "AC_PATH_PROG(~A, ~A)\n" var prog))
|
||||
vars progs)
|
||||
(format #t "test \\\n")
|
||||
(for-each (lambda (var)
|
||||
(format #t " \"$~A\" = \"\" -o \\\n" var))
|
||||
vars)
|
||||
(format #t "~A &&\n~A=\"~A $~A\"\n\n"
|
||||
(list-ref (list "war = peace"
|
||||
"freedom = slavery"
|
||||
"ignorance = strength")
|
||||
(random 3))
|
||||
*pww* module *pww*)))
|
||||
|
||||
(define (>>programs programs)
|
||||
(for-each (lambda (form)
|
||||
(>>program (car form) (cdr form)))
|
||||
programs))
|
||||
|
||||
(define (unglob pattern)
|
||||
(let ((p (open-input-pipe (format #f "echo '(' ~A ')'" pattern))))
|
||||
(map symbol->string (read p))))
|
||||
|
||||
(define (>>checks forms)
|
||||
(let* ((cfg (canonical-configuration forms))
|
||||
(files (apply append (map unglob (cfg 'files-glob))))
|
||||
(ncx (cfg 'non-critical-external))
|
||||
(nci (cfg 'non-critical-internal))
|
||||
(prog (cfg 'non-critical))
|
||||
(report ((make-frisker) files))
|
||||
(external (report 'external)))
|
||||
(let ((pww-varname (cfg 'pww-varname)))
|
||||
(or (null? pww-varname) (set! *pww* (car pww-varname))))
|
||||
(receive (weak strong)
|
||||
(partition (lambda (module)
|
||||
(or (member module ncx)
|
||||
(every (lambda (i)
|
||||
(member i nci))
|
||||
(map edge-down (mod-down-ls module)))))
|
||||
external)
|
||||
(format #t "AC_DEFUN([AUTOFRISK_CHECKS],[\n\n")
|
||||
(>>strong strong)
|
||||
(format #t "\n~A=~S\n\n" *pww* "")
|
||||
(>>weak (fold (lambda (module so-far)
|
||||
(append so-far (mod-down-ls module)))
|
||||
(list)
|
||||
weak))
|
||||
(>>programs (cfg 'programs))
|
||||
(format #t "AC_SUBST(~A)\n])\n\n" *pww*))))
|
||||
|
||||
(define (>>summary)
|
||||
(format #t
|
||||
(symbol->string
|
||||
'#{
|
||||
AC_DEFUN([AUTOFRISK_SUMMARY],[
|
||||
if test ! "$~A" = "" ; then
|
||||
p=" ***"
|
||||
echo "$p"
|
||||
echo "$p NOTE:"
|
||||
echo "$p The following modules probably won't work:"
|
||||
echo "$p $~A"
|
||||
echo "$p They can be installed anyway, and will work if their"
|
||||
echo "$p dependencies are installed later. Please see README."
|
||||
echo "$p"
|
||||
fi
|
||||
])
|
||||
}#)
|
||||
*pww* *pww*))
|
||||
|
||||
(define (autofrisk . args)
|
||||
(let ((file (if (null? args) "modules.af" (car args))))
|
||||
(or (file-exists? file)
|
||||
(error "could not find input file:" file))
|
||||
(with-output-to-file (format #f "~A.m4" file)
|
||||
(lambda ()
|
||||
(>>checks (read-scheme-source-silently file))
|
||||
(>>summary)))))
|
||||
|
||||
(define main autofrisk)
|
||||
|
||||
;; Local variables:
|
||||
;; eval: (put 'receive 'scheme-indent-function 2)
|
||||
;; End:
|
||||
|
||||
;;; autofrisk ends here
|
||||
Loading…
Add table
Add a link
Reference in a new issue