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 (); | |
d3558060 SK |
161 | let error_count = !error_count in |
162 | let clr = (if error_count = 0 then Green else Red) in | |
163 | p "Errors: %s" (color clr (string_of_int error_count)); p_ln (); | |
164 | p "%s" bar_end; p_ln (); | |
165 | exit error_count | |
f752b2c7 SK |
166 | end |
167 | ||
168 | let test_cases_from_book = | |
169 | [ Test.case | |
170 | "Book test 1: an array type and an array variable" | |
171 | ~code: | |
172 | " \ | |
173 | /* an array type and an array variable */ \ | |
174 | let \ | |
175 | type arrtype = array of int \ | |
176 | var arr1:arrtype := \ | |
177 | arrtype [10] of 0 \ | |
178 | in \ | |
179 | arr1 \ | |
180 | end \ | |
181 | " | |
182 | ~out_lexing:( | |
183 | let open Tiger.Parser in | |
184 | [ LET; | |
185 | TYPE; ID "arrtype"; EQ; ARRAY; OF; ID "int"; | |
186 | VAR; ID "arr1"; COLON; ID "arrtype"; ASSIGN; | |
187 | ID "arrtype"; LBRACK; INT 10; RBRACK; OF; INT 0; | |
188 | IN; | |
189 | ID "arr1"; | |
190 | END | |
191 | ] | |
192 | ) | |
193 | ; Test.case | |
194 | "Book test 2: arr1 is valid since expression 0 is int = myint" | |
195 | ~code: | |
196 | " \ | |
197 | /* arr1 is valid since expression 0 is int = myint */ \ | |
198 | let \ | |
199 | type myint = int \ | |
200 | type arrtype = array of myint \ | |
201 | var arr1:arrtype := \ | |
202 | arrtype [10] of 0 \ | |
203 | in \ | |
204 | arr1 \ | |
205 | end \ | |
206 | " | |
207 | ~out_lexing:( | |
208 | let open Tiger.Parser in | |
209 | [ LET; | |
210 | TYPE; ID "myint"; EQ; ID "int"; | |
211 | TYPE; ID "arrtype"; EQ; ARRAY; OF; ID "myint"; | |
212 | VAR; ID "arr1"; COLON; ID "arrtype"; ASSIGN; | |
213 | ID "arrtype"; LBRACK; INT 10; RBRACK; OF; INT 0; | |
214 | IN; | |
215 | ID "arr1"; | |
216 | END | |
217 | ] | |
218 | ) | |
219 | ; Test.case | |
220 | "Book test 3: a record type and a record variable" | |
221 | ~code: | |
222 | " \ | |
223 | /* a record type and a record variable */ \ | |
224 | let \ | |
225 | type rectype = \ | |
226 | { name : string \ | |
227 | , age : int \ | |
228 | } \ | |
229 | var rec1 : rectype := \ | |
230 | rectype \ | |
231 | { name = \"Nobody\" \ | |
232 | , age = 1000 \ | |
233 | } \ | |
234 | in \ | |
235 | rec1.name := \"Somebody\"; \ | |
236 | rec1 \ | |
237 | end \ | |
238 | " | |
239 | ~out_lexing:( | |
240 | let open Tiger.Parser in | |
241 | [ LET; | |
242 | TYPE; ID "rectype"; EQ; | |
243 | LBRACE; ID "name"; COLON; ID "string"; | |
244 | COMMA; ID "age"; COLON; ID "int"; | |
245 | RBRACE; | |
246 | VAR; ID "rec1"; COLON; ID "rectype"; ASSIGN; | |
247 | ID "rectype"; | |
248 | LBRACE; ID "name"; EQ; STRING "Nobody"; | |
249 | COMMA; ID "age"; EQ; INT 1000; | |
250 | RBRACE; | |
251 | IN; | |
252 | ID "rec1"; DOT; ID "name"; ASSIGN; STRING "Somebody"; SEMICOLON; | |
253 | ID "rec1"; | |
254 | END | |
255 | ] | |
256 | ) | |
257 | ; Test.case | |
258 | "Book test 4: define a recursive function" | |
259 | ~code: | |
260 | " \ | |
261 | /* define a recursive function */ \ | |
262 | let \ | |
263 | \ | |
264 | /* calculate n! */ \ | |
265 | function nfactor(n: int): int = \ | |
266 | if n = 0 \ | |
267 | then 1 \ | |
268 | else n * nfactor(n-1) \ | |
269 | \ | |
270 | in \ | |
271 | nfactor(10) \ | |
272 | end \ | |
273 | " | |
274 | ~out_lexing:( | |
275 | let open Tiger.Parser in | |
276 | [ LET; | |
277 | FUNCTION; ID "nfactor"; LPAREN; ID "n"; COLON; ID "int"; RPAREN; COLON; ID "int"; EQ; | |
278 | IF; ID "n"; EQ; INT 0; | |
279 | THEN; INT 1; | |
280 | ELSE; ID "n"; TIMES; ID "nfactor"; LPAREN; ID "n"; MINUS; INT 1; RPAREN; | |
281 | IN; | |
282 | ID "nfactor"; LPAREN; INT 10; RPAREN; | |
283 | END | |
284 | ] | |
285 | ) | |
286 | ; Test.case | |
287 | "Book test 9: error : types of then - else differ" | |
288 | ~code: | |
289 | " \ | |
290 | /* error : types of then - else differ */ \ | |
291 | if (5>4) then 13 else \" \" \ | |
292 | " | |
293 | ~out_lexing:( | |
294 | let open Tiger.Parser in | |
295 | [ IF; LPAREN; INT 5; GT; INT 4; RPAREN; THEN; INT 13; ELSE; STRING " " | |
296 | ] | |
297 | ) | |
298 | ] | |
cb00a20d | 299 | |
15ade902 | 300 | (* |
68a223c2 | 301 | let test_case_from_book_queens = |
82e73e6c | 302 | let code = |
68a223c2 | 303 | "\ |
82e73e6c SK |
304 | /* A program to solve the 8-queens problem */ \n\ |
305 | \n\ | |
306 | let \n\ | |
307 | var N := 8 \n\ | |
308 | \n\ | |
309 | type intArray = array of int \n\ | |
310 | \n\ | |
311 | var row := intArray [ N ] of 0 \n\ | |
312 | var col := intArray [ N ] of 0 \n\ | |
313 | var diag1 := intArray [N+N-1] of 0 \n\ | |
314 | var diag2 := intArray [N+N-1] of 0 \n\ | |
315 | \n\ | |
316 | function printboard() = ( \n\ | |
317 | for i := 0 to N-1 do ( \n\ | |
318 | for j := 0 to N-1 do print(if col[i]=j then \" O\" else \" .\"); \n\ | |
319 | print(\"\n\") \n\ | |
320 | ); \n\ | |
321 | print(\"\n\") \n\ | |
322 | ) \n\ | |
323 | \n\ | |
324 | function try(c:int) = ( \n\ | |
325 | /* for i:= 0 to c do print(\".\"); print(\"\n\"); flush();*/ \n\ | |
326 | if c=N \n\ | |
327 | then printboard() \n\ | |
328 | else \n\ | |
329 | for r := 0 to N-1 \n\ | |
330 | do \n\ | |
331 | if row[r]=0 & diag1[r+c]=0 & diag2[r+7-c]=0 \n\ | |
332 | then ( \n\ | |
333 | row[r] := 1; \n\ | |
334 | diag1[r+c] := 1; \n\ | |
335 | diag2[r+7-c] := 1; \n\ | |
336 | col[c] := r; \n\ | |
337 | try(c+1); \n\ | |
338 | row[r] := 0; \n\ | |
339 | diag1[r+c] := 0; \n\ | |
340 | diag2[r+7-c] := 0 \n\ | |
341 | ) \n\ | |
342 | ) \n\ | |
343 | in \n\ | |
344 | try(0) \n\ | |
345 | end \n\ | |
346 | " | |
347 | in | |
348 | (code, code, []) | |
15ade902 | 349 | *) |
82e73e6c | 350 | |
68a223c2 SK |
351 | let tests_micro_cases = |
352 | let open Tiger.Parser in | |
2c754e82 SK |
353 | [ (let code = "nil" in Test.case code ~code ~out_lexing:[NIL]) |
354 | ; (let code = "5" in Test.case code ~code ~out_lexing:[INT 5]) | |
355 | ; (let code = "-5" in Test.case code ~code ~out_lexing:[MINUS; INT 5]) | |
356 | ; (let code = "f()" in Test.case code ~code ~out_lexing:[ID "f"; LPAREN; RPAREN]) | |
357 | ; (let code = "abc.i" in Test.case code ~code ~out_lexing:[ID "abc"; DOT; ID "i"]) | |
358 | ; (let code = "abc[0]" in Test.case code ~code ~out_lexing:[ID "abc"; LBRACK; INT 0; RBRACK]) | |
78c9eca5 | 359 | |
2c754e82 | 360 | ; (let code = "abc[0] := foo()" in Test.case code ~code |
ead887f4 SK |
361 | ~out_lexing: |
362 | [ID "abc"; LBRACK; INT 0; RBRACK; ASSIGN; ID "foo"; LPAREN; RPAREN]) | |
68a223c2 | 363 | |
2c754e82 | 364 | ; (let code = "abc [5] of nil" in Test.case code ~code |
ead887f4 SK |
365 | ~out_lexing: |
366 | [ID "abc"; LBRACK; INT 5; RBRACK; OF; NIL]) | |
543d3420 | 367 | |
2c754e82 | 368 | ; (let code = "f(\"a\", 3, foo)" in Test.case code ~code |
ead887f4 SK |
369 | ~out_lexing: |
370 | [ID "f"; LPAREN; STRING "a"; COMMA; INT 3; COMMA; ID "foo"; RPAREN]) | |
f752b2c7 | 371 | ] |
543d3420 | 372 | |
f752b2c7 SK |
373 | let tests = |
374 | test_cases_from_book @ tests_micro_cases | |
543d3420 | 375 | |
f752b2c7 SK |
376 | let () = |
377 | Test.run tests |