2nd peek: scripts/autofrisk

[Thien-Thi Nguyen]

well, adding "programs" support was pretty easy.
i think everything after this is cosmetic and/or grunge.

thi

_____________________________
#!/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 dependency checks for 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 <address@hidden>

;;; Commentary:

;; Usage: autofrisk
;;
;; [todo]
;;
;; TODO:

;;; Code:

(debug-enable 'backtrace 'debug)        ;; here.

(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 (spew-req module)
  (format #t "GUILE_MODULE_REQUIRED~A\n" module))

(define (->varname module)
  (let ((var (object->string module)))
    (string-map! (lambda (c)
                   (if (char-set-contains? char-set:letter+digit c)
                       c
                       #\_))
                 var)
    var))

(define (spew-avail-1 module)
  (let ((v (format #f "have_guile_module~A" (->varname module))))
    (format #t "GUILE_MODULE_AVAILABLE(~A, ~A)\n" v module)
    v))

(define pww "probably_wont_work")

(define (spew-prog-support module progs)
  (let ((vars (map (lambda (prog)
                     (format #f "guile_module~Asupport_~A"
                                    (->varname 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 "false &&\n")
    (format #t "~A=\"~A $~A\"\n\n" pww module pww)))

(define (spew-avail weak-edges non-critical-deps)
  (format #t "\n~A=~S\n\n" pww "")
  (for-each (lambda (edge)
              (let* ((up (edge-up edge))
                     (down (edge-down edge))
                     (varname (spew-avail-1 up)))
                (format #t "test \"$~A\" = no &&\n  ~A=\"~A $~A\"~A"
                        varname pww down pww "\n\n")))
            weak-edges)
  (for-each (lambda (ncd)
              (cond ((assq-ref ncd 'programs)
                     => (lambda (programs)
                          (spew-prog-support (car ncd) programs)))))
            non-critical-deps)
  (format #t "if test ! \"$~A\" = \"\" ; then\n" pww)
  (format #t "    echo \"These modules probably won't work:\"\n")
  (format #t "    echo \"  $~A\"\n" pww)
  (format #t "fi\n"))

(define *recognized-keys* '(files
                            files-glob
                            non-critical-external
                            non-critical-internal
                            non-critical-deps))

(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 (unglob pattern)
  (let ((p (open-input-pipe (format #f "echo '(' ~A ')'" pattern))))
    (map symbol->string (read p))))

(define (>>ac 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)))
    (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")
      (for-each spew-req strong)
      (spew-avail (fold (lambda (module so-far)
                          (append so-far (mod-down-ls module)))
                        (list)
                        weak)
                  (cfg 'non-critical-deps))
      (format #t "\n])\n"))))

(define (autofrisk . args)
  (or (file-exists? "modules.af")
      (error "no inupt file"))
  (with-output-to-file "modules.af.m4"
    (lambda ()
      (>>ac (read-scheme-source-silently "modules.af")))))

(define main autofrisk)

;; Local variables:
;; eval: (put 'receive 'scheme-indent-function 2)
;; End:

;;; autofrisk ends here