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
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
|
(****************************************************************************)
(* the diy toolsuite *)
(* *)
(* Jade Alglave, University College London, UK. *)
(* Luc Maranget, INRIA Paris-Rocquencourt, France. *)
(* *)
(* Copyright 2015-present Institut National de Recherche en Informatique et *)
(* en Automatique and the authors. All rights reserved. *)
(* *)
(* This software is governed by the CeCILL-B license under French law and *)
(* abiding by the rules of distribution of free software. You can use, *)
(* modify and/ or redistribute the software under the terms of the CeCILL-B *)
(* license as circulated by CEA, CNRS and INRIA at the following URL *)
(* "http://www.cecill.info". We also give a copy in LICENSE.txt. *)
(****************************************************************************)
open Printf
exception Over
module Action = struct
type t = Check | Rewrite
let tags = ["check"; "rewrite";]
let parse s = match Misc.lowercase s with
| "check" -> Some Check
| "rewrite" -> Some Rewrite
| _ -> None
let pp = function
| Check -> "check"
| Rewrite -> "rewrite"
end
module Top
(Opt:
sig
val verbose : int
val back : bool
val action : Action.t
val check_name : string -> bool
end) =
struct
open Action
module T = struct
type t =
{ tname : string ;
hash : string option;
map : string -> string; }
end
module Make(A:ArchBase.S)(Pte:PteVal.S) = struct
let zyva name parsed =
let tname = name.Name.name in
let hash = MiscParser.get_hash parsed in
let map = OutMapping.info_to_tr parsed.MiscParser.info in
if Opt.verbose > 1
then
eprintf "%s %s\n"
tname
(match hash with
| None -> "none"
| Some h -> h);
{ T.tname = tname ;
hash = hash;
map=map; }
end
module Z = ToolParse.Top(T)(Make)
type name = {fname:string; tname:string;}
let do_test name (kh,km as k) =
try
let {T.tname = tname;
hash = h; map=map;} = Z.from_file name in
let h = Misc.as_some h in
let old = StringMap.safe_find h tname kh in
if old <> h then begin
eprintf "Different hashes for test %s" tname ;
raise Over
end ;
StringMap.add tname h kh,StringMap.add tname map km
with
| Misc.Exit -> k
| Misc.Fatal msg|Misc.UserError msg ->
Warn.warn_always "%a %s" Pos.pp_pos0 name msg ;
k
| e ->
eprintf "\nFatal: %a Adios\n" Pos.pp_pos0 name ;
raise e
let zyva tests logs =
let env,map =
Misc.fold_argv_or_stdin
do_test tests (StringMap.empty,StringMap.empty) in
let module Lex =
LexHashLog.Make
(struct
let verbose = Opt.verbose
let back = Opt.back
let ppinfo = match Opt.action with
| Check ->
fun pos name ->
printf
"%a: hash mismatch for test %s\n%!" Pos.pp_pos pos name
| Rewrite ->
if Opt.verbose > 0 then
fun pos name ->
eprintf
"%a: rewrite hash for test %s\n" Pos.pp_pos pos name
else
fun _ _ -> ()
let env = env
let map = map
let check_name = Opt.check_name
end) in
match logs with
| [] ->
let action = match Opt.action with
| Check -> Lex.check_chan
| Rewrite -> Lex.rewrite_chan in
action stdin
| _::_ ->
let action = match Opt.action with
| Check -> Lex.check
| Rewrite -> Lex.rewrite in
let action =
if Opt.verbose > 0 then
fun fname ->
eprintf "reading %s\n%!" fname ;
action fname
else action in
List.iter action logs
end
let verbose = ref 0
let back = ref false
let action = ref Action.Check
let names = ref []
let rename = ref []
let excl = ref []
let tests = ref []
let arg = ref []
let prog =
if Array.length Sys.argv > 0 then Sys.argv.(0)
else "mhash"
let () =
let open CheckName in
Arg.parse
[
"-v",Arg.Unit (fun () -> incr verbose), " be verbose";
"-back", Arg.Unit (fun () -> back := true), " backward compatibility";
parse_select tests;
parse_rename rename;
parse_names names;
parse_excl excl;
begin let module P = ParseTag.Make(Action) in
P.parse "-action" action "action performed" end ;
]
(fun s -> arg := !arg @ [s])
(sprintf "Usage: %s [options]* [log]*" prog)
let tests = !tests
let logs = !arg
module Check =
CheckName.Make
(struct
let verbose = !verbose
let rename = !rename
let select = []
let names = !names
let excl = !excl
end)
module X =
Top
(struct
let verbose = !verbose
let back = !back
let action = !action
let check_name n = Check.ok n
end)
let () = X.zyva tests logs
|
