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 / compiler / etc / comfiles.scm < prev    next >
Text File  |  1999-01-02  |  2KB  |  78 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: comfiles.scm,v 1.6 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1989-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. ;;;; Stage recompilation checks
  23.  
  24. (declare (usual-integrations))
  25.  
  26. (define compiler-directories
  27.   `("back" "base" "fggen" "fgopt" "rtlbase" "rtlgen" "rtlopt"
  28.        ,(if (equal? microcode-id/operating-system-name "unix")
  29.         "machine"
  30.         "machines/i386")))       
  31.  
  32. (define runtime-directories
  33.   '("runtime" "sf" "cref"))
  34.  
  35. (define (->string name)
  36.   (cond ((string? name) name)
  37.     ((symbol? name) (symbol->string name))
  38.     (else (error "->string: Can't coerce" name))))
  39.  
  40. (define (for-each-file proc directories)
  41.   (for-each (lambda (dname)
  42.           (for-each proc
  43.             (directory-read
  44.              (string-append (->string dname)
  45.                     "/*.scm"))))
  46.         directories))
  47.  
  48. ;; This assumes that the working directory contains the copy of the compiler
  49. ;; to check.
  50.  
  51. (define (check-stage directories #!optional stage)
  52.   (let ((stage
  53.      (if (default-object? stage)
  54.          "STAGE2"
  55.          (->string stage))))
  56.     (for-each-file
  57.      (lambda (name)
  58.        (let* ((path0 (->pathname name))
  59.           (path1 (pathname-new-type (->pathname path0) "com"))
  60.           (path2 (pathname-new-directory
  61.               path1
  62.               (append (pathname-directory path1)
  63.                   `(,stage)))))
  64.      (cond ((not (file-exists? path1))
  65.         (if (file-exists? path2)
  66.             (warn "Directory mismatch"
  67.               `(,path2 exists ,path1 does not))
  68.             (warn "Missing compiled files for" path0)))
  69.            ((not (file-exists? path2))
  70.         (warn "Directory mismatch"
  71.               `(,path1 exists ,path2 does not)))
  72.            (else
  73.         (show-differences path1 path2)))))
  74.      directories)))
  75.  
  76. (define (check-compiler #!optional stage)
  77.   (check-stage compiler-directories
  78.            (if (default-object? stage) "STAGE2" stage)))