1 files changed, 475 insertions, 0 deletions
diff --git a/ocaml-binary-annot/typing/oprint.ml b/ocaml-binary-annot/typing/oprint.ml
new file mode 100644
index 0000000000..ca5db71a63
--- /dev/null
+++ b/ocaml-binary-annot/typing/oprint.ml
@@ -0,0 +1,475 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*                  Projet Cristal, INRIA Rocquencourt                 *)
+(*                                                                     *)
+(*  Copyright 2002 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+open Format
+open Outcometree
+
+exception Ellipsis
+
+let cautious f ppf arg =
+  try f ppf arg with
+    Ellipsis -> fprintf ppf "..."
+
+let rec print_ident ppf =
+  function
+    Oide_ident s -> fprintf ppf "%s" s
+  | Oide_dot (id, s) -> fprintf ppf "%a.%s" print_ident id s
+  | Oide_apply (id1, id2) ->
+      fprintf ppf "%a(%a)" print_ident id1 print_ident id2
+
+let parenthesized_ident name =
+  (List.mem name ["or"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"])
+  ||
+  (match name.[0] with
+      'a'..'z' | '\223'..'\246' | '\248'..'\255' | '_' ->
+        false
+    | _ -> true)
+
+let value_ident ppf name =
+  if parenthesized_ident name then
+    fprintf ppf "( %s )" name
+  else
+    fprintf ppf "%s" name
+
+(* Values *)
+
+let valid_float_lexeme s =
+  let l = String.length s in
+  let rec loop i =
+    if i >= l then s ^ "." else
+    match s.[i] with
+    | '0' .. '9' | '-' -> loop (i+1)
+    | _ -> s
+  in loop 0
+
+let float_repres f =
+  match classify_float f with
+    FP_nan -> "nan"
+  | FP_infinite ->
+      if f < 0.0 then "neg_infinity" else "infinity"
+  | _ ->
+      let float_val =
+        let s1 = Printf.sprintf "%.12g" f in
+        if f = float_of_string s1 then s1 else
+        let s2 = Printf.sprintf "%.15g" f in
+        if f = float_of_string s2 then s2 else
+        Printf.sprintf "%.18g" f
+      in valid_float_lexeme float_val
+
+let parenthesize_if_neg ppf fmt v isneg =
+  if isneg then pp_print_char ppf '(';
+  fprintf ppf fmt v;
+  if isneg then pp_print_char ppf ')'
+
+let print_out_value ppf tree =
+  let rec print_tree_1 ppf =
+    function
+    | Oval_constr (name, [param]) ->
+        fprintf ppf "@[<1>%a@ %a@]" print_ident name print_constr_param param
+    | Oval_constr (name, (_ :: _ as params)) ->
+        fprintf ppf "@[<1>%a@ (%a)@]" print_ident name
+          (print_tree_list print_tree_1 ",") params
+    | Oval_variant (name, Some param) ->
+        fprintf ppf "@[<2>`%s@ %a@]" name print_constr_param param
+    | tree -> print_simple_tree ppf tree
+  and print_constr_param ppf = function
+    | Oval_int i -> parenthesize_if_neg ppf "%i" i (i < 0)
+    | Oval_int32 i -> parenthesize_if_neg ppf "%lil" i (i < 0l)
+    | Oval_int64 i -> parenthesize_if_neg ppf "%LiL" i (i < 0L)
+    | Oval_nativeint i -> parenthesize_if_neg ppf "%nin" i (i < 0n)
+    | Oval_float f -> parenthesize_if_neg ppf "%s" (float_repres f) (f < 0.0)
+    | tree -> print_simple_tree ppf tree
+  and print_simple_tree ppf =
+    function
+      Oval_int i -> fprintf ppf "%i" i
+    | Oval_int32 i -> fprintf ppf "%lil" i
+    | Oval_int64 i -> fprintf ppf "%LiL" i
+    | Oval_nativeint i -> fprintf ppf "%nin" i
+    | Oval_float f -> fprintf ppf "%s" (float_repres f)
+    | Oval_char c -> fprintf ppf "%C" c
+    | Oval_string s ->
+        begin try fprintf ppf "%S" s with
+          Invalid_argument "String.create" -> fprintf ppf "<huge string>"
+        end
+    | Oval_list tl ->
+        fprintf ppf "@[<1>[%a]@]" (print_tree_list print_tree_1 ";") tl
+    | Oval_array tl ->
+        fprintf ppf "@[<2>[|%a|]@]" (print_tree_list print_tree_1 ";") tl
+    | Oval_constr (name, []) -> print_ident ppf name
+    | Oval_variant (name, None) -> fprintf ppf "`%s" name
+    | Oval_stuff s -> fprintf ppf "%s" s
+    | Oval_record fel ->
+        fprintf ppf "@[<1>{%a}@]" (cautious (print_fields true)) fel
+    | Oval_ellipsis -> raise Ellipsis
+    | Oval_printer f -> f ppf
+    | Oval_tuple tree_list ->
+        fprintf ppf "@[<1>(%a)@]" (print_tree_list print_tree_1 ",") tree_list
+    | tree -> fprintf ppf "@[<1>(%a)@]" (cautious print_tree_1) tree
+  and print_fields first ppf =
+    function
+      [] -> ()
+    | (name, tree) :: fields ->
+        if not first then fprintf ppf ";@ ";
+        fprintf ppf "@[<1>%a@ =@ %a@]" print_ident name (cautious print_tree_1)
+          tree;
+        print_fields false ppf fields
+  and print_tree_list print_item sep ppf tree_list =
+    let rec print_list first ppf =
+      function
+        [] -> ()
+      | tree :: tree_list ->
+          if not first then fprintf ppf "%s@ " sep;
+          print_item ppf tree;
+          print_list false ppf tree_list
+    in
+    cautious (print_list true) ppf tree_list
+  in
+  cautious print_tree_1 ppf tree
+
+let out_value = ref print_out_value
+
+(* Types *)
+
+let rec print_list_init pr sep ppf =
+  function
+    [] -> ()
+  | a :: l -> sep ppf; pr ppf a; print_list_init pr sep ppf l
+
+let rec print_list pr sep ppf =
+  function
+    [] -> ()
+  | [a] -> pr ppf a
+  | a :: l -> pr ppf a; sep ppf; print_list pr sep ppf l
+
+let pr_present =
+  print_list (fun ppf s -> fprintf ppf "`%s" s) (fun ppf -> fprintf ppf "@ ")
+
+let pr_vars =
+  print_list (fun ppf s -> fprintf ppf "'%s" s) (fun ppf -> fprintf ppf "@ ")
+
+let rec print_out_type ppf =
+  function
+  | Otyp_alias (ty, s) ->
+      fprintf ppf "@[%a@ as '%s@]" print_out_type ty s
+  | Otyp_poly (sl, ty) ->
+      fprintf ppf "@[<hov 2>%a.@ %a@]"
+        pr_vars sl
+        print_out_type ty
+  | ty ->
+      print_out_type_1 ppf ty
+
+and print_out_type_1 ppf =
+  function
+    Otyp_arrow (lab, ty1, ty2) ->
+      fprintf ppf "@[%s%a ->@ %a@]" (if lab <> "" then lab ^ ":" else "")
+        print_out_type_2 ty1 print_out_type_1 ty2
+  | ty -> print_out_type_2 ppf ty
+and print_out_type_2 ppf =
+  function
+    Otyp_tuple tyl ->
+      fprintf ppf "@[<0>%a@]" (print_typlist print_simple_out_type " *") tyl
+  | ty -> print_simple_out_type ppf ty
+and print_simple_out_type ppf =
+  function
+    Otyp_class (ng, id, tyl) ->
+      fprintf ppf "@[%a%s#%a@]" print_typargs tyl (if ng then "_" else "")
+        print_ident id
+  | Otyp_constr (id, tyl) ->
+      fprintf ppf "@[%a%a@]" print_typargs tyl print_ident id
+  | Otyp_object (fields, rest) ->
+      fprintf ppf "@[<2>< %a >@]" (print_fields rest) fields
+  | Otyp_stuff s -> fprintf ppf "%s" s
+  | Otyp_var (ng, s) -> fprintf ppf "'%s%s" (if ng then "_" else "") s
+  | Otyp_variant (non_gen, row_fields, closed, tags) ->
+      let print_present ppf =
+        function
+          None | Some [] -> ()
+        | Some l -> fprintf ppf "@;<1 -2>> @[<hov>%a@]" pr_present l
+      in
+      let print_fields ppf =
+        function
+          Ovar_fields fields ->
+            print_list print_row_field (fun ppf -> fprintf ppf "@;<1 -2>| ")
+              ppf fields
+        | Ovar_name (id, tyl) ->
+            fprintf ppf "@[%a%a@]" print_typargs tyl print_ident id
+      in
+      fprintf ppf "%s[%s@[<hv>@[<hv>%a@]%a ]@]" (if non_gen then "_" else "")
+        (if closed then if tags = None then " " else "< "
+         else if tags = None then "> " else "? ")
+        print_fields row_fields
+        print_present tags
+  | Otyp_alias _ | Otyp_poly _ | Otyp_arrow _ | Otyp_tuple _ as ty ->
+      fprintf ppf "@[<1>(%a)@]" print_out_type ty
+  | Otyp_abstract | Otyp_sum _ | Otyp_record _ | Otyp_manifest (_, _) -> ()
+  | Otyp_module (p, n, tyl) ->
+      fprintf ppf "@[<1>(module %s" p;
+      let first = ref true in
+      List.iter2
+        (fun s t ->
+          let sep = if !first then (first := false; "with") else "and" in
+          fprintf ppf " %s type %s = %a" sep s print_out_type t
+        )
+        n tyl;
+      fprintf ppf ")@]"
+and print_fields rest ppf =
+  function
+    [] ->
+      begin match rest with
+        Some non_gen -> fprintf ppf "%s.." (if non_gen then "_" else "")
+      | None -> ()
+      end
+  | [s, t] ->
+      fprintf ppf "%s : %a" s print_out_type t;
+      begin match rest with
+        Some _ -> fprintf ppf ";@ "
+      | None -> ()
+      end;
+      print_fields rest ppf []
+  | (s, t) :: l ->
+      fprintf ppf "%s : %a;@ %a" s print_out_type t (print_fields rest) l
+and print_row_field ppf (l, opt_amp, tyl) =
+  let pr_of ppf =
+    if opt_amp then fprintf ppf " of@ &@ "
+    else if tyl <> [] then fprintf ppf " of@ "
+    else fprintf ppf ""
+  in
+  fprintf ppf "@[<hv 2>`%s%t%a@]" l pr_of (print_typlist print_out_type " &")
+    tyl
+and print_typlist print_elem sep ppf =
+  function
+    [] -> ()
+  | [ty] -> print_elem ppf ty
+  | ty :: tyl ->
+      fprintf ppf "%a%s@ %a" print_elem ty sep (print_typlist print_elem sep)
+        tyl
+and print_typargs ppf =
+  function
+    [] -> ()
+  | [ty1] -> fprintf ppf "%a@ " print_simple_out_type ty1
+  | tyl -> fprintf ppf "@[<1>(%a)@]@ " (print_typlist print_out_type ",") tyl
+
+let out_type = ref print_out_type
+
+(* Class types *)
+
+let type_parameter ppf (ty, (co, cn)) =
+  fprintf ppf "%s'%s" (if not cn then "+" else if not co then "-" else "")
+    (*if co then if cn then "!" else "+" else if cn then "-" else "?"*)
+    ty
+
+let print_out_class_params ppf =
+  function
+    [] -> ()
+  | tyl ->
+      fprintf ppf "@[<1>[%a]@]@ "
+        (print_list type_parameter (fun ppf -> fprintf ppf ", "))
+        tyl
+
+let rec print_out_class_type ppf =
+  function
+    Octy_constr (id, tyl) ->
+      let pr_tyl ppf =
+        function
+          [] -> ()
+        | tyl ->
+            fprintf ppf "@[<1>[%a]@]@ " (print_typlist !out_type ",") tyl
+      in
+      fprintf ppf "@[%a%a@]" pr_tyl tyl print_ident id
+  | Octy_fun (lab, ty, cty) ->
+      fprintf ppf "@[%s%a ->@ %a@]" (if lab <> "" then lab ^ ":" else "")
+        print_out_type_2 ty print_out_class_type cty
+  | Octy_signature (self_ty, csil) ->
+      let pr_param ppf =
+        function
+          Some ty -> fprintf ppf "@ @[(%a)@]" !out_type ty
+        | None -> ()
+      in
+      fprintf ppf "@[<hv 2>@[<2>object%a@]@ %a@;<1 -2>end@]" pr_param self_ty
+        (print_list print_out_class_sig_item (fun ppf -> fprintf ppf "@ "))
+        csil
+and print_out_class_sig_item ppf =
+  function
+    Ocsg_constraint (ty1, ty2) ->
+      fprintf ppf "@[<2>constraint %a =@ %a@]" !out_type ty1
+        !out_type ty2
+  | Ocsg_method (name, priv, virt, ty) ->
+      fprintf ppf "@[<2>method %s%s%s :@ %a@]"
+        (if priv then "private " else "") (if virt then "virtual " else "")
+        name !out_type ty
+  | Ocsg_value (name, mut, vr, ty) ->
+      fprintf ppf "@[<2>val %s%s%s :@ %a@]"
+        (if mut then "mutable " else "")
+        (if vr then "virtual " else "")
+        name !out_type ty
+
+let out_class_type = ref print_out_class_type
+
+(* Signature *)
+
+let out_module_type = ref (fun _ -> failwith "Oprint.out_module_type")
+let out_sig_item = ref (fun _ -> failwith "Oprint.out_sig_item")
+let out_signature = ref (fun _ -> failwith "Oprint.out_signature")
+
+let rec print_out_module_type ppf =
+  function
+    Omty_abstract -> ()
+  | Omty_functor (name, mty_arg, mty_res) ->
+      fprintf ppf "@[<2>functor@ (%s : %a) ->@ %a@]" name
+        print_out_module_type mty_arg print_out_module_type mty_res
+  | Omty_ident id -> fprintf ppf "%a" print_ident id
+  | Omty_signature sg ->
+      fprintf ppf "@[<hv 2>sig@ %a@;<1 -2>end@]" !out_signature sg
+and print_out_signature ppf =
+  function
+    [] -> ()
+  | [item] -> !out_sig_item ppf item
+  | item :: items ->
+      fprintf ppf "%a@ %a" !out_sig_item item print_out_signature items
+and print_out_sig_item ppf =
+  function
+    Osig_class (vir_flag, name, params, clt, rs) ->
+      fprintf ppf "@[<2>%s%s@ %a%s@ :@ %a@]"
+        (if rs = Orec_next then "and" else "class")
+        (if vir_flag then " virtual" else "") print_out_class_params params
+        name !out_class_type clt
+  | Osig_class_type (vir_flag, name, params, clt, rs) ->
+      fprintf ppf "@[<2>%s%s@ %a%s@ =@ %a@]"
+        (if rs = Orec_next then "and" else "class type")
+        (if vir_flag then " virtual" else "") print_out_class_params params
+        name !out_class_type clt
+  | Osig_exception (id, tyl) ->
+      fprintf ppf "@[<2>exception %a@]" print_out_constr (id, tyl)
+  | Osig_modtype (name, Omty_abstract) ->
+      fprintf ppf "@[<2>module type %s@]" name
+  | Osig_modtype (name, mty) ->
+      fprintf ppf "@[<2>module type %s =@ %a@]" name !out_module_type mty
+  | Osig_module (name, mty, rs) ->
+      fprintf ppf "@[<2>%s %s :@ %a@]"
+        (match rs with Orec_not -> "module"
+                     | Orec_first -> "module rec"
+                     | Orec_next -> "and")
+        name !out_module_type mty
+  | Osig_type(td, rs) ->
+        print_out_type_decl
+          (if rs = Orec_next then "and" else "type")
+          ppf td
+  | Osig_value (name, ty, prims) ->
+      let kwd = if prims = [] then "val" else "external" in
+      let pr_prims ppf =
+        function
+          [] -> ()
+        | s :: sl ->
+            fprintf ppf "@ = \"%s\"" s;
+            List.iter (fun s -> fprintf ppf "@ \"%s\"" s) sl
+      in
+      fprintf ppf "@[<2>%s %a :@ %a%a@]" kwd value_ident name !out_type
+        ty pr_prims prims
+
+and print_out_type_decl kwd ppf (name, args, ty, priv, constraints) =
+  let print_constraints ppf params =
+    List.iter
+      (fun (ty1, ty2) ->
+         fprintf ppf "@ @[<2>constraint %a =@ %a@]" !out_type ty1
+           !out_type ty2)
+      params
+  in
+  let type_defined ppf =
+    match args with
+      [] -> fprintf ppf "%s" name
+    | [arg] -> fprintf ppf "@[%a@ %s@]" type_parameter arg name
+    | _ ->
+        fprintf ppf "@[(@[%a)@]@ %s@]"
+          (print_list type_parameter (fun ppf -> fprintf ppf ",@ ")) args name
+  in
+  let print_manifest ppf =
+    function
+      Otyp_manifest (ty, _) -> fprintf ppf " =@ %a" !out_type ty
+    | _ -> ()
+  in
+  let print_name_args ppf =
+    fprintf ppf "%s %t%a" kwd type_defined print_manifest ty
+  in
+  let ty =
+    match ty with
+      Otyp_manifest (_, ty) -> ty
+    | _ -> ty
+  in
+  let print_private ppf = function
+    Asttypes.Private -> fprintf ppf " private"
+  | Asttypes.Public -> () in
+  let rec print_out_tkind ppf = function
+  | Otyp_abstract -> ()
+  | Otyp_record lbls ->
+      fprintf ppf " =%a {%a@;<1 -2>}"
+        print_private priv
+        (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls
+  | Otyp_sum constrs ->
+      fprintf ppf " =%a@;<1 2>%a"
+        print_private priv
+        (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) constrs
+  | ty ->
+      fprintf ppf " =%a@;<1 2>%a"
+        print_private priv
+        !out_type ty
+  in
+  fprintf ppf "@[<2>@[<hv 2>%t%a@]%a@]"
+    print_name_args
+    print_out_tkind ty
+    print_constraints constraints
+and print_out_constr ppf (name, tyl) =
+  match tyl with
+    [] -> fprintf ppf "%s" name
+  | _ ->
+      fprintf ppf "@[<2>%s of@ %a@]" name
+        (print_typlist print_simple_out_type " *") tyl
+and print_out_label ppf (name, mut, arg) =
+  fprintf ppf "@[<2>%s%s :@ %a@];" (if mut then "mutable " else "") name
+    !out_type arg
+
+let _ = out_module_type := print_out_module_type
+let _ = out_signature := print_out_signature
+let _ = out_sig_item := print_out_sig_item
+
+(* Phrases *)
+
+let print_out_exception ppf exn outv =
+  match exn with
+    Sys.Break -> fprintf ppf "Interrupted.@."
+  | Out_of_memory -> fprintf ppf "Out of memory during evaluation.@."
+  | Stack_overflow ->
+      fprintf ppf "Stack overflow during evaluation (looping recursion?).@."
+  | _ -> fprintf ppf "@[Exception:@ %a.@]@." !out_value outv
+
+let rec print_items ppf =
+  function
+    [] -> ()
+  | (tree, valopt) :: items ->
+      begin match valopt with
+        Some v ->
+          fprintf ppf "@[<2>%a =@ %a@]" !out_sig_item tree
+            !out_value v
+      | None -> fprintf ppf "@[%a@]" !out_sig_item tree
+      end;
+      if items <> [] then fprintf ppf "@ %a" print_items items
+
+let print_out_phrase ppf =
+  function
+    Ophr_eval (outv, ty) ->
+      fprintf ppf "@[- : %a@ =@ %a@]@." !out_type ty !out_value outv
+  | Ophr_signature [] -> ()
+  | Ophr_signature items -> fprintf ppf "@[<v>%a@]@." print_items items
+  | Ophr_exception (exn, outv) -> print_out_exception ppf exn outv
+
+let out_phrase = ref print_out_phrase