compiler/src/exe/tiger_tests.ml

   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
  22 open Printf
  23
  24 module List = ListLabels
  25 module String = StringLabels
  26
  27 module Option : sig
  28   type 'a t = 'a option
  29
  30   val map : 'a t -> ('a -> 'b) -> 'b t
  31 end = struct
  32   type 'a t = 'a option
  33
  34   let map t f =
  35     match t with
  36     | None   -> None
  37     | Some x -> Some (f x)
  38 end
  39
  40 module Test : sig
  41   type t
  42
  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     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
 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   ]
 299
 300 (*
 301 let test_case_from_book_queens =
 302   let code =
 303     "\
 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, [])
 349 *)
 350
 351 let tests_micro_cases =
 352   let open Tiger.Parser in
 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])
 359
 360   ; (let code = "abc[0] := foo()" in Test.case code ~code
 361       ~out_lexing:
 362         [ID "abc"; LBRACK; INT 0; RBRACK; ASSIGN; ID "foo"; LPAREN; RPAREN])
 363
 364   ; (let code = "abc [5] of nil" in Test.case code ~code
 365       ~out_lexing:
 366         [ID "abc"; LBRACK; INT 5; RBRACK; OF; NIL])
 367
 368   ; (let code = "f(\"a\", 3, foo)" in Test.case code ~code
 369       ~out_lexing:
 370         [ID "f"; LPAREN; STRING "a"; COMMA; INT 3; COMMA; ID "foo"; RPAREN])
 371   ]
 372
 373 let tests =
 374   test_cases_from_book  @ tests_micro_cases
 375
 376 let () =
 377   Test.run tests