Initial commit: parser for tiny subset of SCADE language...

1 files changed, 177 insertions, 0 deletions

diff --git a/frontend/ast_printer.ml b/frontend/ast_printer.ml
new file mode 100644
index 0000000..a02b970
--- /dev/null
+++ b/frontend/ast_printer.ml
@@ -0,0 +1,177 @@
+open Ast
+open Lexing
+
+
+(* Locations *)
+
+let string_of_position p =
+  Printf.sprintf "%s:%i:%i" p.pos_fname p.pos_lnum (p.pos_cnum - p.pos_bol)
+    
+let string_of_extent (p,q) =
+  if p.pos_fname = q.pos_fname then
+    if p.pos_lnum = q.pos_lnum then
+      if p.pos_cnum = q.pos_cnum then
+        Printf.sprintf "%s:%i.%i" p.pos_fname p.pos_lnum (p.pos_cnum - p.pos_bol)
+      else
+        Printf.sprintf "%s:%i.%i-%i" p.pos_fname p.pos_lnum (p.pos_cnum - p.pos_bol) (q.pos_cnum - q.pos_bol)
+    else
+      Printf.sprintf "%s:%i.%i-%i.%i" p.pos_fname p.pos_lnum (p.pos_cnum - p.pos_bol) q.pos_lnum (q.pos_cnum - q.pos_bol)
+  else
+    Printf.sprintf "%s:%i.%i-%s:%i.%i" p.pos_fname p.pos_lnum (p.pos_cnum - p.pos_bol) q.pos_fname q.pos_lnum (q.pos_cnum - q.pos_bol)
+
+
+(* Operators *)
+
+let string_of_unary_op = function
+  | AST_UPLUS -> "+"
+  | AST_UMINUS -> "-"
+  | AST_NOT -> "not"
+  | AST_PRE -> "pre"
+
+let string_of_binary_op = function
+  | AST_MUL -> "*"
+  | AST_DIV -> "/"
+  | AST_MOD -> "mod"
+  | AST_PLUS -> "+"
+  | AST_MINUS -> "-"
+  | AST_EQ -> "="
+  | AST_NE -> "<>"
+  | AST_LT -> "<"
+  | AST_LE -> "<="
+  | AST_GT -> ">"
+  | AST_GE -> ">="
+  | AST_AND -> "and"
+  | AST_OR -> "or"
+  | AST_ARROW -> "->"
+
+
+let binary_precedence = function
+  | AST_MUL| AST_DIV| AST_MOD-> 7
+  | AST_PLUS  | AST_MINUS -> 6
+  | AST_EQ | AST_NE -> 5
+  | AST_LT | AST_LE | AST_GT | AST_GE -> 4
+  | AST_AND -> 3
+  | AST_OR -> 2
+  | AST_ARROW -> 1
+
+let expr_precedence = function
+  | AST_unary (op, _) -> 99
+  | AST_binary(op, _, _) -> binary_precedence op
+  | _ -> 100
+
+(* utility *)
+
+let print_list f sep fmt l =
+  let rec aux = function
+    | [] -> ()
+    | [a] -> f fmt a
+    | a::b -> f fmt a; Format.pp_print_string fmt sep; aux b
+  in
+  aux l
+
+(* types *)
+
+let string_of_typ = function
+  | AST_TINT -> "int"
+  | AST_TBOOL -> "bool"
+  | AST_TREAL -> "real"
+
+(* expressions *)
+
+let print_id fmt v =
+  Format.pp_print_string fmt v
+
+let rec print_expr fmt e = 
+  match e with
+    
+  | AST_unary (op,(e1,_)) ->
+      Format.pp_print_string fmt (string_of_unary_op op);
+      if expr_precedence e1 <= expr_precedence e
+      then Format.fprintf fmt " (%a)" print_expr e1
+      else Format.fprintf fmt " %a" print_expr e1
+
+  | AST_binary (op,(e1,_),(e2,_)) ->
+      if expr_precedence e1 < expr_precedence e
+      then Format.fprintf fmt "(%a) " print_expr e1
+      else Format.fprintf fmt "%a " print_expr e1;
+      Format.pp_print_string fmt (string_of_binary_op op);
+      if expr_precedence e2 <= expr_precedence e
+      then Format.fprintf fmt " (%a)" print_expr e2
+      else Format.fprintf fmt " %a" print_expr e2
+
+  | AST_int_const (i,_) -> Format.pp_print_string fmt i
+
+  | AST_real_const (i,_) -> Format.pp_print_string fmt i
+
+  | AST_bool_const b -> Format.pp_print_bool fmt b
+
+  | AST_if((c,_), (t,_), (e,_)) -> Format.fprintf fmt
+    "if %a then %a else %a"
+    print_expr c print_expr t print_expr e
+        
+  | AST_identifier (v,_) -> print_id fmt v
+
+  | AST_instance ((i,_),l) ->
+      Format.fprintf fmt "%a(%a)"
+        print_id i (print_list print_expr ",") (List.map fst l)
+
+let print_lvalue fmt v =
+  Format.pp_print_string fmt v
+
+(* equations *)
+
+let indent ind = ind^"  "
+
+let rec print_eqn ind fmt = function
+
+  | AST_assign ((v,_),(e,_)) ->
+      Format.fprintf fmt "%s%a = %a;@\n" 
+        ind print_lvalue v print_expr e
+  | AST_assume((i, _), (e, _)) ->
+    Format.fprintf fmt "%sassume %s : %a;@\n"
+        ind i print_expr e
+  | AST_guarantee((i, _), (e, _)) ->
+    Format.fprintf fmt "%sguarantee %s : %a;@\n"
+        ind i print_expr e
+
+and print_block ind fmt b =
+  List.iter (fun (bb,_) -> print_eqn (indent ind) fmt bb) b
+
+(* declarations *)
+
+let print_var_decl fmt (pr, (i, _), ty) =
+    Format.fprintf fmt "%s%s: %s"
+        (if pr then "probe " else "")
+        i
+        (string_of_typ ty)
+
+let rec print_var_decls fmt = function
+    | [] -> ()
+    | [a] -> print_var_decl fmt a
+    | a::r ->
+        print_var_decl fmt a;
+        Format.fprintf fmt "; ";
+        print_var_decls fmt r
+
+let print_node_decl fmt d =
+    Format.fprintf fmt "node %s(%a) returns(%a)@\n"
+        d.name
+        print_var_decls d.args
+        print_var_decls d.ret;
+    if d.var <> [] then
+        Format.fprintf fmt "var %a@\n" print_var_decls d.var;
+    Format.fprintf fmt "let@\n%atel@\n@\n"
+        (print_block "") d.body
+
+let print_const_decl fmt ((i, _), ty, (e, _)) =
+    Format.fprintf fmt
+        "const %s: %s = %a@\n@\n"
+        i (string_of_typ ty)
+        print_expr e
+
+let print_toplevel fmt = function
+    | AST_node_decl (n, _) -> print_node_decl fmt n
+    | AST_const_decl (c, _) -> print_const_decl fmt c
+
+let print_prog fmt p =
+    List.iter (print_toplevel fmt) p