diff options
| -rwxr-xr-x | boot/ocamlc | bin | 1531110 -> 1535399 bytes | |||
| -rwxr-xr-x | boot/ocamldep | bin | 420724 -> 421280 bytes | |||
| -rwxr-xr-x | boot/ocamllex | bin | 184001 -> 184001 bytes | |||
| -rw-r--r-- | toplevel/toploop.ml | 54 | ||||
| -rw-r--r-- | typing/oprint.ml | 18 | ||||
| -rw-r--r-- | typing/printtyp.ml | 126 | ||||
| -rw-r--r-- | typing/printtyp.mli | 5 |
7 files changed, 121 insertions, 82 deletions
diff --git a/boot/ocamlc b/boot/ocamlc Binary files differindex 50be2e2fe..c3936a291 100755 --- a/boot/ocamlc +++ b/boot/ocamlc diff --git a/boot/ocamldep b/boot/ocamldep Binary files differindex 7e86f54f3..037bec05c 100755 --- a/boot/ocamldep +++ b/boot/ocamldep diff --git a/boot/ocamllex b/boot/ocamllex Binary files differindex 4e497b7ec..41526528c 100755 --- a/boot/ocamllex +++ b/boot/ocamllex diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml index 503a11e5e..a0f6072d8 100644 --- a/toplevel/toploop.ml +++ b/toplevel/toploop.ml @@ -169,50 +169,14 @@ let load_lambda ppf lam = (* Print the outcome of an evaluation *) -let rec pr_item env items = - Printtyp.hide_rec_items items; - match items with - | Sig_value(id, decl) :: rem -> - let tree = Printtyp.tree_of_value_description id decl in - let valopt = - match decl.val_kind with - | Val_prim _ -> None - | _ -> - let v = - outval_of_value env (getvalue (Translmod.toplevel_name id)) - decl.val_type - in - Some v - in - Some (tree, valopt, rem) - | Sig_type(id, _, _) :: rem when Btype.is_row_name (Ident.name id) -> - pr_item env rem - | Sig_type(id, decl, rs) :: rem -> - let tree = Printtyp.tree_of_type_declaration id decl rs in - Some (tree, None, rem) - | Sig_exception(id, decl) :: rem -> - let tree = Printtyp.tree_of_exception_declaration id decl in - Some (tree, None, rem) - | Sig_module(id, md, rs) :: rem -> - let tree = Printtyp.tree_of_module id md.md_type rs in - Some (tree, None, rem) - | Sig_modtype(id, decl) :: rem -> - let tree = Printtyp.tree_of_modtype_declaration id decl in - Some (tree, None, rem) - | Sig_class(id, decl, rs) :: cltydecl :: tydecl1 :: tydecl2 :: rem -> - let tree = Printtyp.tree_of_class_declaration id decl rs in - Some (tree, None, rem) - | Sig_class_type(id, decl, rs) :: tydecl1 :: tydecl2 :: rem -> - let tree = Printtyp.tree_of_cltype_declaration id decl rs in - Some (tree, None, rem) - | _ -> None - -let rec item_list env = function - | [] -> [] - | items -> - match pr_item env items with - | None -> [] - | Some (tree, valopt, items) -> (tree, valopt) :: item_list env items +let pr_item = + Printtyp.print_items + (fun env -> function + | Sig_value(id, {val_kind = Val_reg; val_type}) -> + Some (outval_of_value env (getvalue (Translmod.toplevel_name id)) + val_type) + | _ -> None + ) (* The current typing environment for the toplevel *) @@ -261,7 +225,7 @@ let execute_phrase print_outcome ppf phr = let ty = Printtyp.tree_of_type_scheme exp.exp_type in Ophr_eval (outv, ty) | [] -> Ophr_signature [] - | _ -> Ophr_signature (item_list newenv sg')) + | _ -> Ophr_signature (pr_item newenv sg')) else Ophr_signature [] | Exception exn -> toplevel_env := oldenv; diff --git a/typing/oprint.ml b/typing/oprint.ml index 47a0c04a5..8084dff06 100644 --- a/typing/oprint.ml +++ b/typing/oprint.ml @@ -223,7 +223,8 @@ and print_simple_out_type ppf = print_out_type ppf ty; pp_print_char ppf ')'; pp_close_box ppf () - | Otyp_abstract | Otyp_sum _ | Otyp_record _ | Otyp_manifest (_, _) -> () + | Otyp_abstract | Otyp_sum _ | Otyp_manifest (_, _) -> () + | Otyp_record lbls -> print_record_decl ppf lbls | Otyp_module (p, n, tyl) -> fprintf ppf "@[<1>(module %s" p; let first = ref true in @@ -234,6 +235,9 @@ and print_simple_out_type ppf = ) n tyl; fprintf ppf ")@]" +and print_record_decl ppf lbls = + fprintf ppf "{%a@;<1 -2>}" + (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls and print_fields rest ppf = function [] -> @@ -278,6 +282,9 @@ and print_typargs ppf = pp_print_char ppf ')'; pp_close_box ppf (); pp_print_space ppf () +and print_out_label ppf (name, mut, arg) = + fprintf ppf "@[<2>%s%s :@ %a@];" (if mut then "mutable " else "") name + print_out_type arg let out_type = ref print_out_type @@ -441,9 +448,9 @@ and print_out_type_decl kwd ppf (name, args, ty, priv, constraints) = let print_out_tkind ppf = function | Otyp_abstract -> () | Otyp_record lbls -> - fprintf ppf " =%a {%a@;<1 -2>}" + fprintf ppf " =%a %a" print_private priv - (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls + print_record_decl lbls | Otyp_sum constrs -> fprintf ppf " =%a@;<1 2>%a" print_private priv @@ -477,11 +484,6 @@ and print_out_constr ppf (name, tyl,ret_type_opt) = tyl print_simple_out_type ret_type end - -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 diff --git a/typing/printtyp.ml b/typing/printtyp.ml index cd3a631b8..2e4dd5a33 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -739,6 +739,33 @@ let string_of_mutable = function | Immutable -> "" | Mutable -> "mutable " + +let inlined_records = ref [] + (* We don't reset this reference too often, as a hack to make + the error message produced by: + + module X : sig type 'a t = A of int end + = struct type 'a t = A of {x:int} end + + + work as expected (the type declaration is printed after + the signature, and so the definition of the inlined record is + available *) + +let get_inlined_record cd = + let id, args = + match cd.cd_args with + | [ {desc = Tconstr(Path.Pident id, args, _)} ] -> id, args + | _ -> assert false + in + try + let lbls, params = List.assoc id !inlined_records in + lbls, params, args + with Not_found -> [], [], [] + (* This can happen in an error message, where the + variant type declaration is displayed on its own *) + + let rec tree_of_type_decl id decl = reset(); @@ -781,9 +808,14 @@ let rec tree_of_type_decl id decl = | Type_abstract -> () | Type_variant cstrs -> List.iter - (fun c -> - List.iter mark_loops c.cd_args; - may mark_loops c.cd_res) + (fun cd -> + if cd.cd_inlined then + let lbls, params, args = get_inlined_record cd in + List.iter2 link_type params args; + List.iter (fun l -> mark_loops l.ld_type) lbls + else + List.iter mark_loops cd.cd_args; + may mark_loops cd.cd_res) cstrs | Type_record(l, rep) -> List.iter (fun l -> mark_loops l.ld_type) l @@ -842,13 +874,20 @@ let rec tree_of_type_decl id decl = and tree_of_constructor cd = let name = Ident.name cd.cd_id in + let arg () = + if cd.cd_inlined then + let lbls, _, _ = get_inlined_record cd in + [ Otyp_record (List.map tree_of_label lbls) ] + else + tree_of_typlist false cd.cd_args + in match cd.cd_res with - | None -> (name, tree_of_typlist false cd.cd_args, None) + | None -> (name, arg (), None) | Some res -> let nm = !names in names := []; let ret = tree_of_typexp false res in - let args = tree_of_typlist false cd.cd_args in + let args = arg () in names := nm; (name, args, Some ret) @@ -1079,6 +1118,23 @@ let filter_rem_sig item rem = ([ctydecl; tydecl1; tydecl2], rem) | Sig_class_type _, tydecl1 :: tydecl2 :: rem -> ([tydecl1; tydecl2], rem) + | Sig_type _, rem -> + let rec loop sg = function + | (Sig_type (id, + ({type_kind = Type_record (lbls, Record_inlined _)} as td), + Trec_next)) as it :: rem -> + let td = Ctype.instance_declaration td in + let lbls = + match td.type_kind with + | Type_record(lbls, _) -> lbls + | _ -> assert false + in + inlined_records := (id, (lbls, td.type_params)) :: !inlined_records; + loop (it :: sg) rem + | rem -> + List.rev sg, rem + in + loop [] rem | _ -> ([], rem) @@ -1124,36 +1180,35 @@ and tree_of_signature sg = and tree_of_signature_rec env' = function [] -> [] - | item :: rem -> + | item :: rem as items -> begin match item with Sig_type (_, _, rs) when rs <> Trec_next -> () | _ -> set_printing_env env' end; let (sg, rem) = filter_rem_sig item rem in - let trees = - match item with - | Sig_value(id, decl) -> - [tree_of_value_description id decl] - | Sig_type(id, _, _) when is_row_name (Ident.name id) -> - [] - | Sig_type(id, decl, rs) -> - hide_rec_items (item :: rem); - [Osig_type(tree_of_type_decl id decl, tree_of_rec rs)] - | Sig_exception(id, decl) -> - [tree_of_exception_declaration id decl] - | Sig_module(id, md, rs) -> - [Osig_module (Ident.name id, tree_of_modtype md.md_type, - tree_of_rec rs)] - | Sig_modtype(id, decl) -> - [tree_of_modtype_declaration id decl] - | Sig_class(id, decl, rs) -> - [tree_of_class_declaration id decl rs] - | Sig_class_type(id, decl, rs) -> - [tree_of_cltype_declaration id decl rs] - in + hide_rec_items items; + let trees = trees_of_sigitem item in let env' = Env.add_signature (item :: sg) env' in trees @ tree_of_signature_rec env' rem +and trees_of_sigitem = function + | Sig_value(id, decl) -> + [tree_of_value_description id decl] + | Sig_type(id, _, _) when is_row_name (Ident.name id) -> + [] + | Sig_type(id, decl, rs) -> + [tree_of_type_declaration id decl rs] + | Sig_exception(id, decl) -> + [tree_of_exception_declaration id decl] + | Sig_module(id, md, rs) -> + [tree_of_module id md.md_type rs] + | Sig_modtype(id, decl) -> + [tree_of_modtype_declaration id decl] + | Sig_class(id, decl, rs) -> + [tree_of_class_declaration id decl rs] + | Sig_class_type(id, decl, rs) -> + [tree_of_cltype_declaration id decl rs] + and tree_of_modtype_declaration id decl = let mty = match decl.mtd_type with @@ -1162,13 +1217,28 @@ and tree_of_modtype_declaration id decl = in Osig_modtype (Ident.name id, mty) -let tree_of_module id mty rs = +and tree_of_module id mty rs = Osig_module (Ident.name id, tree_of_modtype mty, tree_of_rec rs) let modtype ppf mty = !Oprint.out_module_type ppf (tree_of_modtype mty) let modtype_declaration id ppf decl = !Oprint.out_sig_item ppf (tree_of_modtype_declaration id decl) +(* For the toplevel: merge with tree_of_signature? *) +let rec print_items showval env = function + | [] -> [] + | item :: rem as items -> + let (sg, rem) = filter_rem_sig item rem in + hide_rec_items items; + let trees = trees_of_sigitem item in + List.map (fun d -> (d, showval env item)) trees @ + print_items showval env rem + +let print_items showval env l = + let r = print_items showval env l in + inlined_records := []; + r + (* Print a signature body (used by -i when compiling a .ml) *) let print_signature ppf tree = diff --git a/typing/printtyp.mli b/typing/printtyp.mli index 7fa00ff44..82b8608e5 100644 --- a/typing/printtyp.mli +++ b/typing/printtyp.mli @@ -42,8 +42,10 @@ val type_scheme_max: ?b_reset_names: bool -> (* Fin Maxence *) val tree_of_value_description: Ident.t -> value_description -> out_sig_item val value_description: Ident.t -> formatter -> value_description -> unit +(* val tree_of_type_declaration: Ident.t -> type_declaration -> rec_status -> out_sig_item +*) val type_declaration: Ident.t -> formatter -> type_declaration -> unit val tree_of_exception_declaration: Ident.t -> exception_declaration -> out_sig_item @@ -80,4 +82,5 @@ val report_ambiguous_type_error: (formatter -> unit) -> (formatter -> unit) -> (formatter -> unit) -> unit (* for toploop *) -val hide_rec_items: signature_item list -> unit +val print_items: (Env.t -> signature_item -> 'a option) -> + Env.t -> signature_item list -> (out_sig_item * 'a option) list |