Commit | Line | Data |
---|---|---|
f752b2c7 SK |
1 | (* |
2 | * code |> pass_a_exe |> pass_a_out |> ... |> pass_z_exe |> pass_z_out | |
3 | * | |
4 | * pass a: | |
5 | * exe: OK | |
6 | * out: n/a | |
7 | * pass b: | |
8 | * exe: OK | |
9 | * out: OK | |
10 | * pass c: | |
11 | * exe: OK | |
12 | * out: ERROR | |
13 | * ... | |
14 | * | |
15 | * name | pass a | ... | pass z | |
16 | * ---------+--------+-----+-------- | |
17 | * exe foo | OK | ... | OK | |
18 | * out foo | OK | ... | ERROR | |
19 | * | |
20 | * *) | |
21 | ||
543d3420 SK |
22 | open Printf |
23 | ||
78c9eca5 | 24 | module List = ListLabels |
f752b2c7 | 25 | module String = StringLabels |
78c9eca5 | 26 | |
f752b2c7 SK |
27 | module Option : sig |
28 | type 'a t = 'a option | |
8543fc37 | 29 | |
f752b2c7 SK |
30 | val map : 'a t -> ('a -> 'b) -> 'b t |
31 | end = struct | |
32 | type 'a t = 'a option | |
8543fc37 | 33 | |
f752b2c7 SK |
34 | let map t f = |
35 | match t with | |
36 | | None -> None | |
37 | | Some x -> Some (f x) | |
38 | end | |
78c9eca5 | 39 | |
f752b2c7 SK |
40 | module Test : sig |
41 | type t | |
1946b457 | 42 | |
f752b2c7 SK |
43 | val case |
44 | : ?out_lexing : Tiger.Parser.token list | |
45 | -> ?out_parsing : Tiger.Absyn.t | |
46 | -> code : string | |
47 | -> string | |
48 | -> t | |
49 | ||
50 | val run : t list -> unit | |
51 | end = struct | |
52 | type t = | |
53 | { name : string | |
54 | ; code : string | |
55 | ; out_lexing : (Tiger.Parser.token list) option | |
56 | ; out_parsing : Tiger.Absyn.t option | |
57 | } | |
58 | ||
59 | type color = | |
60 | | Red | |
61 | | Yellow | |
62 | | Green | |
63 | ||
64 | ||
65 | let color_to_ansi_code = function | |
66 | | Red -> "\027[0;31m" | |
67 | | Yellow -> "\027[0;33m" | |
68 | | Green -> "\027[0;32m" | |
69 | ||
70 | let color color string = | |
71 | let color_on = color_to_ansi_code color in | |
72 | let color_off = "\027[0m" in | |
73 | sprintf "%s%s%s" color_on string color_off | |
74 | ||
75 | let case ?(out_lexing) ?(out_parsing) ~code name = | |
76 | { name | |
77 | ; code | |
78 | ; out_lexing | |
79 | ; out_parsing | |
80 | } | |
81 | ||
82 | let bar_sep = String.make 80 '-' | |
83 | let bar_end = String.make 80 '=' | |
84 | ||
85 | let indent = | |
86 | let unit_spaces = 2 in | |
87 | fun n -> | |
88 | String.make (n * unit_spaces) ' ' | |
89 | ||
90 | let pass_lexing code : (Tiger.Parser.token list, string) result = | |
91 | let lexbuf = Lexing.from_string code in | |
92 | let rec tokens () = | |
93 | let token = Tiger.Lexer.token lexbuf in | |
94 | (* Avoiding fragile pattern-matching *) | |
95 | if token = Tiger.Parser.EOF then [] else token :: tokens () | |
96 | in | |
97 | match tokens () with | |
98 | | exception e -> Error (Printexc.to_string e) | |
99 | | tokens -> Ok tokens | |
100 | ||
101 | let pass_parsing code = | |
102 | let lb = Lexing.from_string code in | |
103 | match Tiger.Parser.program Tiger.Lexer.token lb with | |
104 | | exception Parsing.Parse_error -> | |
105 | let module L = Lexing in | |
106 | let L.({lex_curr_p = {pos_lnum=l; pos_bol=b; pos_cnum=c; _}; _}) = lb in | |
107 | let msg = sprintf "Syntax error around line: %d, column: %d" l (c - b) in | |
108 | Error msg | |
109 | | ast -> | |
110 | Ok ast | |
111 | ||
112 | let s = sprintf | |
113 | let p = printf | |
114 | let p_ln = print_newline | |
115 | let p_indent n = p "%s" (indent n) | |
116 | ||
117 | let run tests = | |
118 | let error_count = ref 0 in | |
119 | let run_pass f input output : string * string = | |
120 | match f input with | |
121 | | exception e -> | |
122 | incr error_count; | |
123 | ( s "%s: %s" (color Red "ERROR") (Printexc.to_string e) | |
124 | , "n/a" | |
125 | ) | |
126 | | Error msg -> | |
127 | incr error_count; | |
128 | ( s "%s: %s" (color Red "ERROR") msg | |
129 | , "n/a" | |
130 | ) | |
131 | | Ok produced -> | |
132 | let exe = s "%s" (color Green "OK") in | |
133 | let out = | |
134 | match | |
135 | Option.map output (fun expected -> expected = produced) | |
136 | with | |
137 | | None -> | |
138 | s "%s" (color Yellow "n/a") | |
139 | | Some true -> | |
140 | s "%s" (color Green "OK") | |
141 | | Some false -> | |
142 | incr error_count; | |
143 | s "%s" (color Red "ERROR") | |
144 | in | |
145 | (exe, out) | |
146 | in | |
147 | List.iter tests ~f:( | |
148 | fun {name; code; out_lexing; out_parsing} -> | |
149 | let ( lexing_exe, lexing_out) = run_pass pass_lexing code out_lexing in | |
150 | let (parsing_exe, parsing_out) = run_pass pass_parsing code out_parsing in | |
151 | p "%s" bar_sep; p_ln (); | |
152 | p "Test: %S" name; p_ln (); | |
153 | p_indent 1; p "Lexing:"; p_ln (); | |
154 | p_indent 2; p "exe: %s" lexing_exe; p_ln (); | |
155 | p_indent 2; p "out: %s" lexing_out; p_ln (); | |
156 | p_indent 1; p "Parsing:"; p_ln (); | |
157 | p_indent 2; p "exe: %s" parsing_exe; p_ln (); | |
158 | p_indent 2; p "out: %s" parsing_out; p_ln (); | |
159 | ); | |
160 | p "%s" bar_end; p_ln (); | |
161 | exit !error_count | |
162 | end | |
163 | ||
164 | let test_cases_from_book = | |
165 | [ Test.case | |
166 | "Book test 1: an array type and an array variable" | |
167 | ~code: | |
168 | " \ | |
169 | /* an array type and an array variable */ \ | |
170 | let \ | |
171 | type arrtype = array of int \ | |
172 | var arr1:arrtype := \ | |
173 | arrtype [10] of 0 \ | |
174 | in \ | |
175 | arr1 \ | |
176 | end \ | |
177 | " | |
178 | ~out_lexing:( | |
179 | let open Tiger.Parser in | |
180 | [ LET; | |
181 | TYPE; ID "arrtype"; EQ; ARRAY; OF; ID "int"; | |
182 | VAR; ID "arr1"; COLON; ID "arrtype"; ASSIGN; | |
183 | ID "arrtype"; LBRACK; INT 10; RBRACK; OF; INT 0; | |
184 | IN; | |
185 | ID "arr1"; | |
186 | END | |
187 | ] | |
188 | ) | |
189 | ; Test.case | |
190 | "Book test 2: arr1 is valid since expression 0 is int = myint" | |
191 | ~code: | |
192 | " \ | |
193 | /* arr1 is valid since expression 0 is int = myint */ \ | |
194 | let \ | |
195 | type myint = int \ | |
196 | type arrtype = array of myint \ | |
197 | var arr1:arrtype := \ | |
198 | arrtype [10] of 0 \ | |
199 | in \ | |
200 | arr1 \ | |
201 | end \ | |
202 | " | |
203 | ~out_lexing:( | |
204 | let open Tiger.Parser in | |
205 | [ LET; | |
206 | TYPE; ID "myint"; EQ; ID "int"; | |
207 | TYPE; ID "arrtype"; EQ; ARRAY; OF; ID "myint"; | |
208 | VAR; ID "arr1"; COLON; ID "arrtype"; ASSIGN; | |
209 | ID "arrtype"; LBRACK; INT 10; RBRACK; OF; INT 0; | |
210 | IN; | |
211 | ID "arr1"; | |
212 | END | |
213 | ] | |
214 | ) | |
215 | ; Test.case | |
216 | "Book test 3: a record type and a record variable" | |
217 | ~code: | |
218 | " \ | |
219 | /* a record type and a record variable */ \ | |
220 | let \ | |
221 | type rectype = \ | |
222 | { name : string \ | |
223 | , age : int \ | |
224 | } \ | |
225 | var rec1 : rectype := \ | |
226 | rectype \ | |
227 | { name = \"Nobody\" \ | |
228 | , age = 1000 \ | |
229 | } \ | |
230 | in \ | |
231 | rec1.name := \"Somebody\"; \ | |
232 | rec1 \ | |
233 | end \ | |
234 | " | |
235 | ~out_lexing:( | |
236 | let open Tiger.Parser in | |
237 | [ LET; | |
238 | TYPE; ID "rectype"; EQ; | |
239 | LBRACE; ID "name"; COLON; ID "string"; | |
240 | COMMA; ID "age"; COLON; ID "int"; | |
241 | RBRACE; | |
242 | VAR; ID "rec1"; COLON; ID "rectype"; ASSIGN; | |
243 | ID "rectype"; | |
244 | LBRACE; ID "name"; EQ; STRING "Nobody"; | |
245 | COMMA; ID "age"; EQ; INT 1000; | |
246 | RBRACE; | |
247 | IN; | |
248 | ID "rec1"; DOT; ID "name"; ASSIGN; STRING "Somebody"; SEMICOLON; | |
249 | ID "rec1"; | |
250 | END | |
251 | ] | |
252 | ) | |
253 | ; Test.case | |
254 | "Book test 4: define a recursive function" | |
255 | ~code: | |
256 | " \ | |
257 | /* define a recursive function */ \ | |
258 | let \ | |
259 | \ | |
260 | /* calculate n! */ \ | |
261 | function nfactor(n: int): int = \ | |
262 | if n = 0 \ | |
263 | then 1 \ | |
264 | else n * nfactor(n-1) \ | |
265 | \ | |
266 | in \ | |
267 | nfactor(10) \ | |
268 | end \ | |
269 | " | |
270 | ~out_lexing:( | |
271 | let open Tiger.Parser in | |
272 | [ LET; | |
273 | FUNCTION; ID "nfactor"; LPAREN; ID "n"; COLON; ID "int"; RPAREN; COLON; ID "int"; EQ; | |
274 | IF; ID "n"; EQ; INT 0; | |
275 | THEN; INT 1; | |
276 | ELSE; ID "n"; TIMES; ID "nfactor"; LPAREN; ID "n"; MINUS; INT 1; RPAREN; | |
277 | IN; | |
278 | ID "nfactor"; LPAREN; INT 10; RPAREN; | |
279 | END | |
280 | ] | |
281 | ) | |
282 | ; Test.case | |
283 | "Book test 9: error : types of then - else differ" | |
284 | ~code: | |
285 | " \ | |
286 | /* error : types of then - else differ */ \ | |
287 | if (5>4) then 13 else \" \" \ | |
288 | " | |
289 | ~out_lexing:( | |
290 | let open Tiger.Parser in | |
291 | [ IF; LPAREN; INT 5; GT; INT 4; RPAREN; THEN; INT 13; ELSE; STRING " " | |
292 | ] | |
293 | ) | |
294 | ] | |
cb00a20d | 295 | |
15ade902 | 296 | (* |
68a223c2 | 297 | let test_case_from_book_queens = |
82e73e6c | 298 | let code = |
68a223c2 | 299 | "\ |
82e73e6c SK |
300 | /* A program to solve the 8-queens problem */ \n\ |
301 | \n\ | |
302 | let \n\ | |
303 | var N := 8 \n\ | |
304 | \n\ | |
305 | type intArray = array of int \n\ | |
306 | \n\ | |
307 | var row := intArray [ N ] of 0 \n\ | |
308 | var col := intArray [ N ] of 0 \n\ | |
309 | var diag1 := intArray [N+N-1] of 0 \n\ | |
310 | var diag2 := intArray [N+N-1] of 0 \n\ | |
311 | \n\ | |
312 | function printboard() = ( \n\ | |
313 | for i := 0 to N-1 do ( \n\ | |
314 | for j := 0 to N-1 do print(if col[i]=j then \" O\" else \" .\"); \n\ | |
315 | print(\"\n\") \n\ | |
316 | ); \n\ | |
317 | print(\"\n\") \n\ | |
318 | ) \n\ | |
319 | \n\ | |
320 | function try(c:int) = ( \n\ | |
321 | /* for i:= 0 to c do print(\".\"); print(\"\n\"); flush();*/ \n\ | |
322 | if c=N \n\ | |
323 | then printboard() \n\ | |
324 | else \n\ | |
325 | for r := 0 to N-1 \n\ | |
326 | do \n\ | |
327 | if row[r]=0 & diag1[r+c]=0 & diag2[r+7-c]=0 \n\ | |
328 | then ( \n\ | |
329 | row[r] := 1; \n\ | |
330 | diag1[r+c] := 1; \n\ | |
331 | diag2[r+7-c] := 1; \n\ | |
332 | col[c] := r; \n\ | |
333 | try(c+1); \n\ | |
334 | row[r] := 0; \n\ | |
335 | diag1[r+c] := 0; \n\ | |
336 | diag2[r+7-c] := 0 \n\ | |
337 | ) \n\ | |
338 | ) \n\ | |
339 | in \n\ | |
340 | try(0) \n\ | |
341 | end \n\ | |
342 | " | |
343 | in | |
344 | (code, code, []) | |
15ade902 | 345 | *) |
82e73e6c | 346 | |
68a223c2 SK |
347 | let tests_micro_cases = |
348 | let open Tiger.Parser in | |
2c754e82 SK |
349 | [ (let code = "nil" in Test.case code ~code ~out_lexing:[NIL]) |
350 | ; (let code = "5" in Test.case code ~code ~out_lexing:[INT 5]) | |
351 | ; (let code = "-5" in Test.case code ~code ~out_lexing:[MINUS; INT 5]) | |
352 | ; (let code = "f()" in Test.case code ~code ~out_lexing:[ID "f"; LPAREN; RPAREN]) | |
353 | ; (let code = "abc.i" in Test.case code ~code ~out_lexing:[ID "abc"; DOT; ID "i"]) | |
354 | ; (let code = "abc[0]" in Test.case code ~code ~out_lexing:[ID "abc"; LBRACK; INT 0; RBRACK]) | |
78c9eca5 | 355 | |
2c754e82 SK |
356 | ; (let code = "abc[0] := foo()" in Test.case code ~code |
357 | ~out_lexing: | |
358 | [ID "abc"; LBRACK; INT 0; RBRACK; ASSIGN; ID "foo"; LPAREN; RPAREN]) | |
68a223c2 | 359 | |
2c754e82 SK |
360 | ; (let code = "abc [5] of nil" in Test.case code ~code |
361 | ~out_lexing: | |
362 | [ID "abc"; LBRACK; INT 5; RBRACK; OF; NIL]) | |
543d3420 | 363 | |
2c754e82 SK |
364 | ; (let code = "f(\"a\", 3, foo)" in Test.case code ~code |
365 | ~out_lexing: | |
366 | [ID "f"; LPAREN; STRING "a"; COMMA; INT 3; COMMA; ID "foo"; RPAREN]) | |
f752b2c7 | 367 | ] |
543d3420 | 368 | |
f752b2c7 SK |
369 | let tests = |
370 | test_cases_from_book @ tests_micro_cases | |
543d3420 | 371 | |
f752b2c7 SK |
372 | let () = |
373 | Test.run tests |