minor changes in parser

src/ast.ml

@@ -21,8 +21,8 @@ let pp_binop fmt = function
   | Mul -> Format.pp_print_char fmt '*'
   | Div -> Format.pp_print_char fmt '/'
 
-let prec_un = function Neg -> 5
-let prec_bin = function Add | Sub -> 3 | Mul | Div -> 4
+let prec_un = function Neg -> 4
+let prec_bin = function Add | Sub -> 2 | Mul | Div -> 3
 
 let prec_expr e =
   match e.data with
@@ -99,8 +99,8 @@ let pp_bcmp fmt = function
   | BGt -> Format.pp_print_char fmt '>'
   | BNeq -> Format.pp_print_string fmt "<>"
 
-let prec_bun = function BNot -> 5
-let prec_bbin = function BOr -> 3 | BAnd -> 4
+let prec_bun = function BNot -> 4
+let prec_bbin = function BOr -> 2 | BAnd -> 3
 
 let prec_bexpr e =
   match e.data with
@@ -164,9 +164,8 @@ let assoc_stmt = function
 
 let prec_stmt = function
   | Assign _ | Skip -> -1
-  | Seq _ -> 0
-  | While _ | IfThenElse (_, _, None) -> 1
-  | IfThenElse _ -> 2
+  | Seq _ | While _ | IfThenElse (_, _, None) -> 0
+  | IfThenElse _ -> 1
 
 let is_seq s = match s.data with Seq _ -> true | _ -> false
 
@@ -175,7 +174,7 @@ let rec pp_stmt0_ lvl fmt = function
   | Skip -> Format.pp_print_string fmt "skip"
   | Seq (s1, s2) as s ->
       let n = prec_stmt s in
-      if n < lvl then Format.fprintf fmt "@[@[<v 2>{ %a@]@ }@]" (pp_stmt0_ n) s
+      if n < lvl then Format.fprintf fmt "@[@[<v 2>{ %a@];@ }@]" (pp_stmt0_ n) s
       else
         let lvl1, lvl2 =
           match assoc_stmt s with
@@ -187,21 +186,21 @@ let rec pp_stmt0_ lvl fmt = function
           s2
   | While (b, s1) as s ->
       let n = prec_stmt s in
-      if n < lvl then Format.fprintf fmt "@[@[<v 2>{ %a@]@ }@]" (pp_stmt0_ n) s
+      if n < lvl then Format.fprintf fmt "@[@[<v 2>{ %a@];@ }@]" (pp_stmt0_ n) s
       else
         let lvl1 = n in
-        Format.fprintf fmt "@[<hv>while %a do@ %a@]" pp_bexpr b (pp_stmt_ lvl1)
-          s1
+        Format.fprintf fmt "@[<hv>while %a do@ %a@ done@]" pp_bexpr b
+          (pp_stmt_ lvl1) s1
   | IfThenElse (b, s1, None) as s ->
       let n = prec_stmt s in
-      if n < lvl then Format.fprintf fmt "@[@[<v 2>{ %a@]@ }@]" (pp_stmt0_ n) s
+      if n < lvl then Format.fprintf fmt "@[@[<v 2>{ %a@];@ }@]" (pp_stmt0_ n) s
       else
         let lvl1 = n in
         Format.fprintf fmt "@[<hv>if %a@ then %a@]" pp_bexpr b (pp_stmt_ lvl1)
           s1
   | IfThenElse (b, s1, Some s2) as s ->
       let n = prec_stmt s in
-      if n < lvl then Format.fprintf fmt "@[@[<v 2>{ %a@]@ }@]" (pp_stmt0_ n) s
+      if n < lvl then Format.fprintf fmt "@[@[<v 2>{ %a@];@ }@]" (pp_stmt0_ n) s
       else
         let lvl1, lvl2 =
           match assoc_stmt s with
@@ -219,16 +218,18 @@ let pp_stmt fmt = pp_stmt_ 0 fmt
 type fun_decl = {
   name : string localized;
   args : var localized list;
-  body : stmt;
+  body : stmt option;
   return : expr;
 }
 
 let pp_fun_decl fmt { name; args; body; return } =
   let open Format in
-  fprintf fmt "@[<v 0>def %s(%a) =@ { @[%a;@ return %a@]@ }@]" name.data
+  fprintf fmt "@[<v 0>def %s(%a) =@ { @[%areturn %a;@]@ }@]" name.data
     (pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt ",@ ") pp_var)
     (List.map (fun x -> x.data) args)
-    pp_stmt body pp_expr return
+    (fun fmt opt ->
+      match opt with None -> () | Some s -> fprintf fmt "%a;@ " pp_stmt s)
+    body pp_expr return
 
 type program = fun_decl list
 

src/lexer.mll

@@ -35,6 +35,7 @@ rule lexer = parse
 | '}'     { RBRACE }
 | "skip"  { SKIP }
 | "while" { WHILE }
+| "done"  { DONE }
 | "do"    { DO }
 | "if"    { IF }
 | "then"  { THEN }

src/parser.mly

 %{
 open Location
 open Ast
+
+let rec stmts = function
+| [] -> assert false
+| [s] -> s
+| s :: l ->
+  let stmt = stmts l in
+  localize (fst s.loc, snd stmt.loc) (Seq (s, stmt))
+
 %}
 
 %token EOF
@@ -15,18 +23,17 @@ open Ast
 %token AMP2 VBAR2
 %token NOT
 
-%token SKIP WHILE DO IF THEN ELSE
+%token SKIP WHILE DO DONE IF THEN ELSE
 %token SEMI COLONEQ
 %token LBRACE RBRACE
 
 %token DEF COMMA RETURN
 
-%right SEMI             // 0
-%nonassoc DO THEN       // 1
-%nonassoc ELSE          // 2
-%left PLUS MINUS VBAR2  // 3
-%left TIMES SLASH AMP2  // 4
-%nonassoc uminus NOT    // 5
+%nonassoc THEN          // 0
+%nonassoc ELSE          // 1
+%left PLUS MINUS VBAR2  // 2
+%left TIMES SLASH AMP2  // 3
+%nonassoc uminus NOT    // 4
 
 %start<stmt> stmt_eof
 %start<program> program_eof
@@ -98,23 +105,25 @@ stmt0:
 { Skip }
 | x = VAR COLONEQ e = expr
 { Assign (x, e) }
-| s = delimited(LBRACE, stmt, RBRACE)
+| LBRACE s = stmts RBRACE
 { s.data }
-| s1 = stmt SEMI s2 = stmt
-{ Seq (s1, s2) }
-| WHILE b = bexpr DO s = stmt
+| WHILE b = bexpr DO s = stmt DONE
 { While (b, s) }
 | IF b = bexpr THEN s1 = stmt ELSE s2 = stmt
 { IfThenElse (b, s1, Some s2) }
 | IF b = bexpr THEN s1 = stmt
 { IfThenElse (b, s1, None) }
 
+stmts:
+| l = nonempty_list(terminated(stmt,SEMI))
+{ stmts l }
+
 stmt:
 | s = localized(stmt0)
 { s }
 
 stmt_eof:
-| s = stmt SEMI? EOF
+| s = stmt EOF
 { s }
 
 formal_args:
@@ -122,9 +131,12 @@ formal_args:
 { xs }
 
 fun_decl:
-| DEF f = localized(VAR) LPAR xs = formal_args RPAR EQ
-  LBRACE s = stmt SEMI? RETURN e = expr RBRACE
-{ { name = f; args = xs; body = s; return = e} }
+| DEF f = localized(VAR) LPAR xs = formal_args RPAR EQ?
+  LBRACE s = stmts RETURN e = expr SEMI? RBRACE
+{ { name = f; args = xs; body = Some s; return = e} }
+| DEF f = localized(VAR) LPAR xs = formal_args RPAR EQ?
+  LBRACE RETURN e = expr SEMI? RBRACE
+{ { name = f; args = xs; body = None; return = e} }
 
 program:
 | decls = fun_decl+

tests/dune

+(executable
+ (name generate_dune)
+ (modules generate_dune))
+
+(rule
+ (target dune.inc.gen)
+ (deps
+  (source_tree .)
+  generate_dune.ml)
+ (action
+  (with-stdout-to
+   %{target}
+   (run ./generate_dune.exe))))
+
+(rule
+ (alias runtest)
+ (action
+  (diff dune.inc dune.inc.gen)))
+
+(include dune.inc)

tests/dune.inc

+; Test rule for input file loop.prog
+(rule
+ (alias runtest)
+ (deps loop.prog)
+ (action
+  (progn
+   (with-stdout-to
+    loop.prog.output
+    (run ../src/main.exe loop.prog))
+   (diff? loop.prog.expected loop.prog.output))))
+
+; Test rule for input file loop.while
+(rule
+ (alias runtest)
+ (deps loop.while)
+ (action
+  (progn
+   (with-stdout-to
+    loop.while.output
+    (run ../src/main.exe loop.while))
+   (diff? loop.while.expected loop.while.output))))
+

tests/generate_dune.ml

+(** @author: Benoît Montagu <benoit.montagu@inria.fr>
+    @author: Pierre Lermusiaux <pierre.lermusiaux@inria.fr>
+    Copyright Inria 2019-2024
+*)
+
+(** Allowed extensions for test files *)
+let extensions = [ ".while"; ".prog" ]
+
+(** Files that should be excluded from tests *)
+let excludes = []
+
+(** [print_rule chn file] prints the test rule for the file [file] to the output
+    channel [chn] *)
+let print_rule chn file =
+  Printf.fprintf chn
+    "; Test rule for input file %s\n\
+     (rule\n\
+    \ (alias runtest)\n\
+    \ (deps %s)\n\
+    \ (action\n\
+    \  (progn\n\
+    \   (with-stdout-to\n\
+    \    %s.output\n\
+    \    (run ../src/main.exe %s))\n\
+    \   (diff? %s.expected %s.output))))\n"
+    file file file file file file
+
+(** [is_excluded s] returns [true] iff the string [s] belongs to the list
+    [excludes] *)
+let is_excluded =
+  let module StringSet = Set.Make (String) in
+  let excludes =
+    List.fold_left (fun acc s -> StringSet.add s acc) StringSet.empty excludes
+  in
+  fun s -> StringSet.mem s excludes
+
+(** [get_files dir] gets the files that are present in the directory [dir] and
+    that end with the suffix input_ext, and removes that suffix from those
+    files. The returned list is sorted according to the ordering
+    [String.compare]. *)
+let get_files dir =
+  let all_files = Sys.readdir dir in
+  Array.fold_right
+    (fun file acc ->
+      let file = Filename.basename file in
+      if List.exists (String.equal (Filename.extension file)) extensions then
+        if is_excluded file then acc else file :: acc
+      else acc)
+    all_files []
+  |> List.sort String.compare
+
+(* we sort the result so that we get consistent output on different
+   machines (Sys.readdir does not guarantee any ordering on the
+   array of returned files) *)
+
+(** [generate_rules chn dir] generates the rules for all the files in the
+    directory [dir], and prints them to the output channel [chn] *)
+let generate_rules chn dir =
+  get_files dir |> List.iter (Printf.fprintf chn "%a\n%!" print_rule)
+
+(** Actually generate the file *)
+let () = generate_rules stdout Filename.current_dir_name

tests/loop.prog

+def loop() = {
+  while true do skip;
+  return 0
+}
+

tests/loop.prog.expected

+def loop() =
+{ while true do skip; return 0
+}

tests/loop.while

+while true do skip

tests/loop.while.expected

+while true do skip