Improvements to menhir pretty printer and ocaml backend

Menhir pretty printer can now print enough sail to be useful with ASL parser

Fixity declarations are now preserved in the AST

Menhir parser now runs without the Pre-lexer

Ocaml backend now supports variant typedefs, as the machinery to
generate arbitrary instances of variant types has been added to the
-undefined_gen flag

1 files changed, 17 insertions, 5 deletions

diff --git a/src/initial_check.ml b/src/initial_check.ml
index 36b6478e..6a7a1b0a 100644
--- a/src/initial_check.ml
+++ b/src/initial_check.ml
@@ -765,12 +765,19 @@ let to_ast_dec (names,k_env,def_ord) (Parse_ast.DEC_aux(regdec,l)) =
       | Parse_ast.DEC_typ_alias(typ,id,e) ->
 	DEC_typ_alias(to_ast_typ k_env def_ord typ,to_ast_id id,to_ast_alias_spec k_env def_ord e)
     ),(l,()))
-      
+
+let to_ast_prec = function
+  | Parse_ast.Infix -> Infix
+  | Parse_ast.InfixL -> InfixL
+  | Parse_ast.InfixR -> InfixR
+
 let to_ast_def (names, k_env, def_ord) partial_defs def : def_progress envs_out * (id * partial_def) list = 
   let envs = (names,k_env,def_ord) in
   match def with
   | Parse_ast.DEF_overload(id,ids) ->
-    ((Finished(DEF_overload(to_ast_id id, List.map to_ast_id ids))),envs),partial_defs
+     ((Finished(DEF_overload(to_ast_id id, List.map to_ast_id ids))),envs),partial_defs
+  | Parse_ast.DEF_fixity (prec, n, op) ->
+     ((Finished(DEF_fixity (to_ast_prec prec, n, to_ast_id op)),envs),partial_defs)
   | Parse_ast.DEF_kind(k_def) ->
     let kd,envs = to_ast_kdef envs k_def in
     ((Finished(DEF_kind(kd))),envs),partial_defs
@@ -913,7 +920,7 @@ let typschm_of_string order str =
   let (typschm, _, _) = to_ast_typschm initial_kind_env order typschm in
   typschm
 
-let val_spec_of_string order id str = mk_val_spec (VS_val_spec (typschm_of_string order str, id, Some str, false))
+let val_spec_of_string order id str = mk_val_spec (VS_val_spec (typschm_of_string order str, id, Some (string_of_id id), false))
 
 let val_spec_ids (Defs defs) =
   let val_spec_id (VS_aux (vs_aux, _)) =
@@ -965,6 +972,10 @@ let generate_undefineds vs_ids (Defs defs) =
      gen_vs (mk_id "undefined_vector") "forall 'n 'm ('a:Type). (atom('n), atom('m), 'a) -> vector('n, 'm, dec,'a) effect {undef}";
      gen_vs (mk_id "undefined_unit") "unit -> unit effect {undef}"]
   in
+  let undefined_tu = function
+    | Tu_aux (Tu_id id, _) -> mk_exp (E_id id)
+    | Tu_aux (Tu_ty_id (typ, id), _) -> mk_exp (E_app (id, [mk_lit_exp L_undef]))
+  in
   let undefined_td = function
     | TD_enum (id, _, ids, _) when not (IdSet.mem (prepend_id "undefined_" id) vs_ids) ->
        let typschm = typschm_of_string dec_ord ("unit -> " ^ string_of_id id ^ " effect {undef}") in
@@ -980,11 +991,12 @@ let generate_undefineds vs_ids (Defs defs) =
                             pat
                             (mk_exp (E_record (mk_fexps (List.map (fun (_, id) -> mk_fexp id (mk_lit_exp L_undef)) fields))))]]
     | TD_variant (id, _, typq, tus, _) when not (IdSet.mem (prepend_id "undefined_" id) vs_ids) ->
+       let pat = mk_pat (P_tup (quant_items typq |> List.map quant_item_param |> List.concat |> List.map (fun id -> mk_pat (P_id id)))) in
        [mk_val_spec (VS_val_spec (undefined_typschm id typq, prepend_id "undefined_" id, None, false));
         mk_fundef [mk_funcl (prepend_id "undefined_" id)
-                            (mk_pat (P_lit (mk_lit L_unit)))
+                            pat
                             (mk_exp (E_app (mk_id "internal_pick",
-                                            [])))]]
+                                            [mk_exp (E_list (List.map undefined_tu tus))])))]]
     | _ -> []
   in
   let rec undefined_defs = function