LilyPond-Ruby 0.1.1 → 0.1.2

data/share/guile/2.2/rnrs.scm

@@ -0,0 +1,289 @@
+;;; rnrs.scm --- The R6RS composite library
+
+;;      Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;
+;; This library 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 of the License, or (at your option) any later version.
+;; 
+;; This library 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 library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+
+(library (rnrs (6))
+  (export ;; (rnrs arithmetic bitwise)
+
+          bitwise-not bitwise-and bitwise-ior bitwise-xor bitwise-if 
+	  bitwise-bit-count bitwise-length bitwise-first-bit-set 
+	  bitwise-bit-set? bitwise-copy-bit bitwise-bit-field 
+	  bitwise-copy-bit-field bitwise-arithmetic-shift 
+	  bitwise-arithmetic-shift-left bitwise-arithmetic-shift-right
+	  bitwise-rotate-bit-field bitwise-reverse-bit-field
+          
+	  ;; (rnrs arithmetic fixnums)
+
+	  fixnum? fixnum-width least-fixnum greatest-fixnum fx=? fx>? fx<? fx>=?
+	  fx<=? fxzero? fxpositive? fxnegative? fxodd? fxeven? fxmax fxmin fx+
+	  fx* fx- fxdiv-and-mod fxdiv fxmod fxdiv0-and-mod0 fxdiv0 fxmod0
+	  fx+/carry fx-/carry fx*/carry fxnot fxand fxior fxxor fxif fxbit-count
+	  fxlength fxfirst-bit-set fxbit-set? fxcopy-bit fxbit-field
+	  fxcopy-bit-field fxarithmetic-shift fxarithmetic-shift-left
+	  fxarithmetic-shift-right fxrotate-bit-field fxreverse-bit-field
+
+	  ;; (rnrs arithmetic flonums)
+
+	  flonum? real->flonum fl=? fl<? fl<=? fl>? fl>=? flinteger? flzero? 
+	  flpositive? flnegative? flodd? fleven? flfinite? flinfinite? flnan?
+	  flmax flmin fl+ fl* fl- fl/ flabs fldiv-and-mod fldiv flmod
+	  fldiv0-and-mod0 fldiv0 flmod0 flnumerator fldenominator flfloor 
+	  flceiling fltruncate flround flexp fllog flsin flcos fltan flacos 
+	  flasin flatan flsqrt flexpt &no-infinities
+	  make-no-infinities-violation no-infinities-violation? &no-nans
+	  make-no-nans-violation no-nans-violation? fixnum->flonum
+	  
+	  ;; (rnrs base)
+
+	  boolean? symbol? char? vector? null? pair? number? string? procedure?
+	  define define-syntax syntax-rules lambda let let* let-values
+	  let*-values letrec letrec* begin quote lambda if set! cond case or 
+          and not eqv? equal? eq? + - * / max min abs numerator denominator gcd
+          lcm floor ceiling truncate round rationalize real-part imag-part 
+	  make-rectangular angle div mod div-and-mod div0 mod0 div0-and-mod0
+	  expt exact-integer-sqrt sqrt exp log sin cos tan asin acos atan 
+	  make-polar magnitude angle complex? real? rational? integer? exact? 
+	  inexact? real-valued? rational-valued? integer-valued? zero? 
+	  positive? negative? odd? even? nan? finite? infinite? exact inexact =
+	  < > <= >= number->string string->number boolean=? cons car cdr caar 
+          cadr cdar cddr caaar caadr cadar cdaar caddr cdadr cddar cdddr caaaar
+          caaadr caadar cadaar cdaaar cddaar cdadar cdaadr cadadr caaddr caddar
+          cadddr cdaddr cddadr cdddar cddddr list? list length append reverse 
+	  list-tail list-ref map for-each symbol->string string->symbol symbol=?
+	  char->integer integer->char char=? char<? char>? char<=? char>=?
+	  make-string string string-length string-ref string=? string<? string>?
+	  string<=? string>=? substring string-append string->list list->string
+	  string-for-each string-copy vector? make-vector vector vector-length 
+	  vector-ref vector-set! vector->list list->vector vector-fill! 
+	  vector-map vector-for-each error assertion-violation assert
+	  call-with-current-continuation call/cc call-with-values dynamic-wind
+	  values apply quasiquote unquote unquote-splicing let-syntax 
+	  letrec-syntax syntax-rules identifier-syntax
+
+	  ;; (rnrs bytevectors)
+	  
+	  endianness native-endianness bytevector? make-bytevector 
+	  bytevector-length bytevector=? bytevector-fill! bytevector-copy! 
+	  bytevector-copy uniform-array->bytevector bytevector-u8-ref 
+	  bytevector-s8-ref bytevector-u8-set! bytevector-s8-set! 
+	  bytevector->u8-list u8-list->bytevector bytevector-uint-ref 
+	  bytevector-uint-set! bytevector-sint-ref bytevector-sint-set!
+	  bytevector->sint-list bytevector->uint-list uint-list->bytevector 
+	  sint-list->bytevector bytevector-u16-ref bytevector-s16-ref
+	  bytevector-u16-set! bytevector-s16-set! bytevector-u16-native-ref 
+	  bytevector-s16-native-ref bytevector-u16-native-set! 
+	  bytevector-s16-native-set! bytevector-u32-ref bytevector-s32-ref
+	  bytevector-u32-set! bytevector-s32-set! bytevector-u32-native-ref 
+	  bytevector-s32-native-ref bytevector-u32-native-set! 
+	  bytevector-s32-native-set! bytevector-u64-ref bytevector-s64-ref
+	  bytevector-u64-set! bytevector-s64-set! bytevector-u64-native-ref 
+	  bytevector-s64-native-ref bytevector-u64-native-set! 
+	  bytevector-s64-native-set! bytevector-ieee-single-ref
+	  bytevector-ieee-single-set! bytevector-ieee-single-native-ref
+	  bytevector-ieee-single-native-set! bytevector-ieee-double-ref
+	  bytevector-ieee-double-set! bytevector-ieee-double-native-ref
+	  bytevector-ieee-double-native-set! string->utf8 string->utf16 
+	  string->utf32 utf8->string utf16->string utf32->string
+
+	  ;; (rnrs conditions)
+
+	  &condition condition simple-conditions condition? condition-predicate
+	  condition-accessor define-condition-type &message
+	  make-message-condition message-condition? condition-message &warning
+	  make-warning warning? &serious make-serious-condition
+	  serious-condition? &error make-error error? &violation make-violation
+	  violation? &assertion make-assertion-violation assertion-violation?
+	  &irritants make-irritants-condition irritants-condition?
+	  condition-irritants &who make-who-condition who-condition?
+	  condition-who &non-continuable make-non-continuable-violation
+	  non-continuable-violation? &implementation-restriction
+	  make-implementation-restriction-violation
+	  implementation-restriction-violation? &lexical make-lexical-violation
+	  lexical-violation? &syntax make-syntax-violation syntax-violation?
+	  syntax-violation-form syntax-violation-subform &undefined
+	  make-undefined-violation undefined-violation?
+
+	  ;; (rnrs control)
+
+	  when unless do case-lambda
+
+	  ;; (rnrs enums)
+
+	  make-enumeration enum-set-universe enum-set-indexer 
+	  enum-set-constructor enum-set->list enum-set-member? enum-set-subset?
+	  enum-set=? enum-set-union enum-set-intersection enum-set-difference
+	  enum-set-complement enum-set-projection define-enumeration
+
+	  ;; (rnrs exceptions)
+
+	  guard with-exception-handler raise raise-continuable
+
+	  ;; (rnrs files)
+
+	  file-exists? delete-file &i/o make-i/o-error i/o-error? &i/o-read 
+	  make-i/o-read-error i/o-read-error? &i/o-write make-i/o-write-error 
+	  i/o-write-error? &i/o-invalid-position 
+	  make-i/o-invalid-position-error i/o-invalid-position-error? 
+	  i/o-error-position &i/o-filename make-i/o-filename-error
+	  i/o-filename-error? i/o-error-filename &i/o-file-protection 
+	  make-i/o-file-protection-error i/o-file-protection-error?
+	  &i/o-file-is-read-only make-i/o-file-is-read-only-error
+	  i/o-file-is-read-only-error? &i/o-file-already-exists
+	  make-i/o-file-already-exists-error i/o-file-already-exists-error?
+	  &i/o-file-does-not-exist make-i/o-file-does-not-exist-error
+	  i/o-file-does-not-exist-error? &i/o-port make-i/o-port-error
+	  i/o-port-error? i/o-error-port
+
+	  ;; (rnrs hashtables)
+
+	  make-eq-hashtable make-eqv-hashtable make-hashtable hashtable?
+	  hashtable-size hashtable-ref hashtable-set! hashtable-delete!
+	  hashtable-contains? hashtable-update! hashtable-copy hashtable-clear!
+	  hashtable-keys hashtable-entries hashtable-equivalence-function
+	  hashtable-hash-function hashtable-mutable? equal-hash string-hash
+	  string-ci-hash symbol-hash
+
+	  ;; (rnrs io ports)
+
+          &i/o-decoding i/o-decoding-error?
+          make-i/o-decoding-error
+          &i/o-encoding i/o-encoding-error-char i/o-encoding-error?
+          make-i/o-encoding-error
+
+          file-options buffer-mode buffer-mode?
+	  eol-style native-eol-style error-handling-mode
+	  make-transcoder transcoder-codec transcoder-eol-style
+          transcoder-error-handling-mode native-transcoder
+	  latin-1-codec utf-8-codec utf-16-codec
+          string->bytevector bytevector->string
+	  
+	  eof-object? port? input-port? output-port? eof-object port-eof?
+	  port-transcoder
+	  binary-port? textual-port? transcoded-port
+	  port-position set-port-position!
+	  port-has-port-position? port-has-set-port-position!?
+          close-port call-with-port
+	  open-bytevector-input-port make-custom-binary-input-port get-u8 
+	  lookahead-u8 get-bytevector-n get-bytevector-n! get-bytevector-some 
+	  get-bytevector-all open-bytevector-output-port
+	  make-custom-binary-output-port put-u8 put-bytevector
+          open-string-input-port open-string-output-port
+          call-with-bytevector-output-port
+          call-with-string-output-port
+          latin-1-codec utf-8-codec utf-16-codec
+          open-file-input-port open-file-output-port open-file-input/output-port
+          make-custom-textual-output-port
+          call-with-string-output-port
+	  output-port-buffer-mode flush-output-port put-string
+          get-char get-datum get-line get-string-all get-string-n get-string-n!
+          lookahead-char
+          put-char put-datum put-string
+          standard-input-port standard-output-port standard-error-port
+          
+	  ;; (rnrs io simple)
+	  
+	  call-with-input-file call-with-output-file current-input-port
+	  current-output-port current-error-port with-input-from-file
+	  with-output-to-file open-input-file open-output-file close-input-port
+	  close-output-port read-char peek-char read write-char newline display
+	  write
+
+	  ;; (rnrs lists)
+
+	  find for-all exists filter partition fold-left fold-right remp remove 
+	  remv remq memp member memv memq assp assoc assv assq cons*
+
+	  ;; (rnrs programs)
+
+	  command-line exit
+
+	  ;; (rnrs records inspection)
+
+	  record? record-rtd record-type-name record-type-parent
+	  record-type-uid record-type-generative? record-type-sealed? 
+	  record-type-opaque? record-type-field-names record-field-mutable?
+
+	  ;; (rnrs records procedural)
+
+	  make-record-type-descriptor record-type-descriptor?
+	  make-record-constructor-descriptor record-constructor record-predicate
+	  record-accessor record-mutator
+
+	  ;; (rnrs records syntactic)
+
+	  define-record-type record-type-descriptor 
+	  record-constructor-descriptor
+
+	  ;; (rnrs sorting)
+	  
+	  list-sort vector-sort vector-sort!
+
+	  ;; (rnrs syntax-case)
+
+	  make-variable-transformer syntax
+          ;; Until the deprecated support for a unified modules and
+          ;; bindings namespace is removed, we need to manually resolve
+          ;; a conflict between two bindings: that of the (rnrs
+          ;; syntax-case) module, and the imported `syntax-case'
+          ;; binding. We do so here and below by renaming the macro
+          ;; import.
+          (rename (syntax-case-hack syntax-case))
+          identifier?  bound-identifier=? free-identifier=?
+          syntax->datum datum->syntax generate-temporaries with-syntax
+          quasisyntax unsyntax unsyntax-splicing syntax-violation
+
+	  ;; (rnrs unicode)
+	  
+	  char-upcase char-downcase char-titlecase char-foldcase
+	  char-ci=? char-ci<? char-ci>? char-ci<=? char-ci>=?
+	  char-alphabetic? char-numeric? char-whitespace? char-upper-case?
+	  char-lower-case? char-title-case? char-general-category
+	  string-upcase string-downcase string-titlecase string-foldcase
+	  string-ci=? string-ci<? string-ci>? string-ci<=? string-ci>=?
+	  string-normalize-nfd string-normalize-nfkd string-normalize-nfc
+	  string-normalize-nfkc)
+
+  (import (rnrs arithmetic bitwise (6))
+	  (rnrs arithmetic fixnums (6))
+	  (rnrs arithmetic flonums (6))
+	  (rnrs base (6))
+
+	  (rnrs bytevectors (6))
+          
+	  (rnrs conditions (6))
+	  (rnrs control (6))
+	  (rnrs enums (6))
+	  (rnrs exceptions (6))
+
+          (rnrs files (6))
+
+	  (rnrs hashtables (6))
+
+	  (rnrs io ports (6))
+
+	  (rnrs io simple (6))
+	  (rnrs lists (6))
+	  (rnrs programs (6))
+	  (rnrs records inspection (6))
+	  (rnrs records procedural (6))
+	  (rnrs records syntactic (6))
+	  (rnrs sorting (6))
+          ;; See note above on exporting syntax-case.
+	  (rename (rnrs syntax-case (6))
+                  (syntax-case syntax-case-hack))
+	  (rnrs unicode (6))))

data/share/guile/2.2/scripts/api-diff.scm

@@ -0,0 +1,179 @@
+;;; api-diff --- diff guile-api.alist files
+
+;; 	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: api-diff [-d GROUPS] ALIST-FILE-A ALIST-FILE-B
+;;
+;; Read in the alists from files ALIST-FILE-A and ALIST-FILE-B
+;; and display a (count) summary of the groups defined therein.
+;; Optional arg "--details" (or "-d") specifies a comma-separated
+;; list of groups, in which case api-diff displays instead the
+;; elements added and deleted for each of the specified groups.
+;;
+;; For scheme programming, this module exports the proc:
+;;  (api-diff A-file B-file)
+;;
+;; Note that the convention is that the "older" alist/file is
+;; specified first.
+;;
+;; TODO: Develop scheme interface.
+
+;;; Code:
+
+(define-module (scripts api-diff)
+  :use-module (ice-9 common-list)
+  :use-module (ice-9 format)
+  :use-module (ice-9 getopt-long)
+  :autoload (srfi srfi-13) (string-tokenize)
+  :export (api-diff))
+
+(define %include-in-guild-list #f)
+(define %summary "Show differences between two scan-api files.")
+
+(define (read-alist-file file)
+  (with-input-from-file file
+    (lambda () (read))))
+
+(define put set-object-property!)
+(define get object-property)
+
+(define (read-api-alist-file file)
+  (let* ((alist (read-alist-file file))
+         (meta (assq-ref alist 'meta))
+         (interface (assq-ref alist 'interface)))
+    (put interface 'meta meta)
+    (put interface 'groups (let ((ht (make-hash-table 31)))
+                             (for-each (lambda (group)
+                                         (hashq-set! ht group '()))
+                                       (assq-ref meta 'groups))
+                             ht))
+    interface))
+
+(define (hang-by-the-roots interface)
+  (let ((ht (get interface 'groups)))
+    (for-each (lambda (x)
+                (for-each (lambda (group)
+                            (hashq-set! ht group
+                                        (cons (car x)
+                                              (hashq-ref ht group))))
+                          (assq-ref x 'groups)))
+              interface))
+  interface)
+
+(define (diff? a b)
+  (let ((result (set-difference a b)))
+    (if (null? result)
+        #f                              ; CL weenies bite me
+        result)))
+
+(define (diff+note! a b note-removals note-additions note-same)
+  (let ((same? #t))
+    (cond ((diff? a b) => (lambda (x) (note-removals x) (set! same? #f))))
+    (cond ((diff? b a) => (lambda (x) (note-additions x) (set! same? #f))))
+    (and same? (note-same))))
+
+(define (group-diff i-old i-new . options)
+  (let* ((i-old (hang-by-the-roots i-old))
+         (g-old (hash-fold acons '() (get i-old 'groups)))
+         (g-old-names (map car g-old))
+         (i-new (hang-by-the-roots i-new))
+         (g-new (hash-fold acons '() (get i-new 'groups)))
+         (g-new-names (map car g-new)))
+    (cond ((null? options)
+           (diff+note! g-old-names g-new-names
+                       (lambda (removals)
+                         (format #t "groups-removed: ~A\n" removals))
+                       (lambda (additions)
+                         (format #t "groups-added: ~A\n" additions))
+                       (lambda () #t))
+           (for-each (lambda (group)
+                       (let* ((old (assq-ref g-old group))
+                              (new (assq-ref g-new group))
+                              (old-count (and old (length old)))
+                              (new-count (and new (length new)))
+                              (delta (and old new (- new-count old-count))))
+                         (format #t " ~5@A  ~5@A  :  "
+                                 (or old-count "-")
+                                 (or new-count "-"))
+                         (cond ((and old new)
+                                (let ((add-count 0) (sub-count 0))
+                                  (diff+note!
+                                   old new
+                                   (lambda (subs)
+                                     (set! sub-count (length subs)))
+                                   (lambda (adds)
+                                     (set! add-count (length adds)))
+                                   (lambda () #t))
+                                  (format #t "~5@D ~5@D : ~5@D"
+                                          add-count (- sub-count) delta)))
+                               (else
+                                (format #t "~5@A ~5@A : ~5@A" "-" "-" "-")))
+                         (format #t "     ~A\n" group)))
+                     (sort (union g-old-names g-new-names)
+                           (lambda (a b)
+                             (string<? (symbol->string a)
+                                       (symbol->string b))))))
+          ((assq-ref options 'details)
+           => (lambda (groups)
+                (for-each (lambda (group)
+                            (let* ((old (or (assq-ref g-old group) '()))
+                                   (new (or (assq-ref g-new group) '()))
+                                   (>>! (lambda (label ls)
+                                          (format #t "~A ~A:\n" group label)
+                                          (for-each (lambda (x)
+                                                      (format #t " ~A\n" x))
+                                                    ls))))
+                              (diff+note! old new
+                                          (lambda (removals)
+                                            (>>! 'removals removals))
+                                          (lambda (additions)
+                                            (>>! 'additions additions))
+                                          (lambda ()
+                                            (format #t "~A: no changes\n"
+                                                    group)))))
+                          groups)))
+          (else
+           (error "api-diff: group-diff: bad options")))))
+
+(define (api-diff . args)
+  (let* ((p (getopt-long (cons 'api-diff args)
+                         '((details (single-char #\d)
+                                    (value #t))
+                           ;; Add options here.
+                           )))
+         (rest (option-ref p '() '("/dev/null" "/dev/null")))
+         (i-old (read-api-alist-file (car rest)))
+         (i-new (read-api-alist-file (cadr rest)))
+         (options '()))
+    (cond ((option-ref p 'details #f)
+           => (lambda (groups)
+                (set! options (cons (cons 'details
+                                          (map string->symbol
+                                               (string-tokenize
+                                                groups
+                                                #\,)))
+                                    options)))))
+    (apply group-diff i-old i-new options)))
+
+(define main api-diff)
+
+;;; api-diff ends here

data/share/guile/2.2/scripts/autofrisk.scm

@@ -0,0 +1,218 @@
+;;; autofrisk --- Generate module checks for use with auto* tools
+
+;; 	Copyright (C) 2002, 2006, 2009, 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: 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 %include-in-guild-list #f)
+(define %summary "Generate snippets for use in configure.ac files.")
+
+(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))
+         (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