1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
|
#| -*-Scheme-*-
$Id: comfiles.scm,v 1.9 2003/02/14 18:28:01 cph Exp $
Copyright 1989,1991,1993,2003 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
MIT/GNU Scheme 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 of the License, or (at
your option) any later version.
MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
USA.
|#
;;;; Stage recompilation checks
(declare (usual-integrations))
(define compiler-directories
`("back" "base" "fggen" "fgopt" "rtlbase" "rtlgen" "rtlopt"
,(if (eq? 'UNIX microcode-id/operating-system)
"machine"
"machines/i386")))
(define runtime-directories
'("runtime" "sf" "cref"))
(define (->string name)
(cond ((string? name) name)
((symbol? name) (symbol->string name))
(else (error "->string: Can't coerce" name))))
(define (for-each-file proc directories)
(for-each (lambda (dname)
(for-each proc
(directory-read
(string-append (->string dname)
"/*.scm"))))
directories))
;; This assumes that the working directory contains the copy of the compiler
;; to check.
(define (check-stage directories #!optional stage)
(let ((stage
(if (default-object? stage)
"STAGE2"
(->string stage))))
(for-each-file
(lambda (name)
(let* ((path0 (->pathname name))
(path1 (pathname-new-type (->pathname path0) "com"))
(path2 (pathname-new-directory
path1
(append (pathname-directory path1)
`(,stage)))))
(cond ((not (file-exists? path1))
(if (file-exists? path2)
(warn "Directory mismatch"
`(,path2 exists ,path1 does not))
(warn "Missing compiled files for" path0)))
((not (file-exists? path2))
(warn "Directory mismatch"
`(,path1 exists ,path2 does not)))
(else
(show-differences path1 path2)))))
directories)))
(define (check-compiler #!optional stage)
(check-stage compiler-directories
(if (default-object? stage) "STAGE2" stage)))
(define (compare-trees root1 root2)
(for-each (lambda (d)
(compare-directory
(pathname-as-directory (merge-pathnames d root1))
(pathname-as-directory (merge-pathnames d root2))))
(append runtime-directories
(map (lambda (d) (string-append "compiler/" d))
compiler-directories))))
(define (compare-directory d1 d2)
(for-each (lambda (p1)
(let ((p2 (merge-pathnames (file-pathname p1) d2)))
(if (file-exists? p2)
(show-differences p1 p2)
(warn "Directory mismatch" `(,p1 exists ,p2 does not)))))
(directory-read (merge-pathnames "*.com" d1))))
|