home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / sf / butils.scm next >
Text File  |  1999-01-02  |  4KB  |  116 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: butils.scm,v 4.10 1999/01/02 06:19:10 cph Exp $
  4.  
  5. Copyright (c) 1988-1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Build utilities
  23.  
  24. (declare (usual-integrations))
  25.  
  26. (define (directory-processor input-type output-type process-file)
  27.   (let ((directory-read
  28.      (let ((input-pattern
  29.         (make-pathname false false false 'WILD input-type 'NEWEST)))
  30.        (lambda (directory)
  31.          (directory-read
  32.           (merge-pathnames
  33.            (pathname-as-directory (merge-pathnames directory))
  34.            input-pattern))))))
  35.     (lambda (input-directory #!optional output-directory force?)
  36.       (let ((output-directory
  37.          (if (default-object? output-directory) false output-directory))
  38.         (force? (if (default-object? force?) false force?))
  39.         (output-type (output-type)))
  40.     (for-each (lambda (pathname)
  41.             (if (or force?
  42.                 (not (compare-file-modification-times
  43.                   (pathname-default-type pathname input-type)
  44.                   (let ((output-pathname
  45.                      (pathname-new-type pathname
  46.                                 output-type)))
  47.                     (if output-directory
  48.                     (merge-pathnames output-directory
  49.                              output-pathname)
  50.                     output-pathname)))))
  51.             (process-file pathname output-directory)))
  52.           (if (pair? input-directory)
  53.               (append-map! directory-read input-directory)
  54.               (directory-read input-directory)))))))
  55.  
  56. (define sf-directory
  57.   (directory-processor
  58.    "scm"
  59.    (lambda () "bin")
  60.    (lambda (pathname output-directory)
  61.      (sf pathname output-directory))))
  62.  
  63. (define compile-directory
  64.   (directory-processor
  65.    "bin"
  66.    (lambda ()
  67.      (if (environment-lookup (->environment '(compiler))
  68.                  'compiler:cross-compiling?)
  69.      "moc"
  70.      (environment-lookup (->environment '(compiler top-level))
  71.                          
  72.                  'compiled-output-extension)))
  73.    (lambda (pathname output-directory)
  74.      (compile-bin-file pathname output-directory))))
  75.  
  76. (define sf-directory?)
  77. (define compile-directory?)
  78. (let ((show-pathname
  79.        (lambda (pathname output-directory)
  80.      output-directory
  81.      (newline)
  82.      (write-string "Process file: ")
  83.      (write-string (enough-namestring pathname)))))
  84.   (set! sf-directory? (directory-processor "scm" "bin" show-pathname))
  85.   (set! compile-directory? (directory-processor "bin" "com" show-pathname)))
  86.  
  87. (define (sf-conditionally filename #!optional echo-up-to-date?)
  88.   (let ((kernel
  89.      (lambda (filename)
  90.        (call-with-values
  91.            (lambda () (sf/pathname-defaulting filename #f #f))
  92.          (lambda (input output spec)
  93.            spec
  94.            (cond ((not (compare-file-modification-times input output))
  95.               (sf filename))
  96.              ((and (not (default-object? echo-up-to-date?))
  97.                echo-up-to-date?)
  98.               (newline)
  99.               (write-string "Syntax file: ")
  100.               (write filename)
  101.               (write-string " is up to date"))))))))
  102.     (if (pair? filename)
  103.     (for-each kernel filename)
  104.     (kernel filename))))
  105.  
  106. (define (file-processed? filename input-type output-type)
  107.   (compare-file-modification-times
  108.    (pathname-default-type filename input-type)
  109.    (pathname-new-type filename output-type)))
  110.  
  111. (define (compare-file-modification-times source target)
  112.   (let ((source (file-modification-time-indirect source)))
  113.     (and source
  114.      (let ((target (file-modification-time-indirect target)))
  115.        (and target
  116.         (<= source target))))))