1(**************************************************************************)
2(*                                                                        *)
3(*                                 OCaml                                  *)
4(*                                                                        *)
5(*           Jerome Vouillon, projet Cristal, INRIA Rocquencourt          *)
6(*           OCaml port by John Malecki and Xavier Leroy                  *)
7(*                                                                        *)
8(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
9(*     en Automatique.                                                    *)
10(*                                                                        *)
11(*   All rights reserved.  This file is distributed under the terms of    *)
12(*   the GNU Lesser General Public License version 2.1, with the          *)
13(*   special exception on linking described in the file LICENSE.          *)
14(*                                                                        *)
15(**************************************************************************)
16
17(* To print values *)
18
19open Format
20open Parser_aux
21open Path
22open Types
23
24(* To name printed and ellipsed values *)
25
26let named_values =
27  (Hashtbl.create 29 : (int, Debugcom.Remote_value.t * type_expr) Hashtbl.t)
28let next_name = ref 1
29
30let reset_named_values () =
31  Hashtbl.clear named_values;
32  next_name := 1
33
34let name_value v ty =
35  let name = !next_name in
36  incr next_name;
37  Hashtbl.add named_values name (v, ty);
38  name
39
40let find_named_value name =
41  Hashtbl.find named_values name
42
43let check_depth depth obj ty =
44  if depth <= 0 then begin
45    let n = name_value obj ty in
46    Some (Outcometree.Oval_stuff ("$" ^ string_of_int n))
47  end else None
48
49module EvalPath =
50  struct
51    type valu = Debugcom.Remote_value.t
52    exception Error
53    let rec eval_path env = function
54      Pident id ->
55        begin try
56          Debugcom.Remote_value.global (Symtable.get_global_position id)
57        with Symtable.Error _ ->
58          raise Error
59        end
60    | Pdot(root, _fieldname, pos) ->
61        let v = eval_path env root in
62        if not (Debugcom.Remote_value.is_block v)
63        then raise Error
64        else Debugcom.Remote_value.field v pos
65    | Papply _ ->
66        raise Error
67    let same_value = Debugcom.Remote_value.same
68  end
69
70module Printer = Genprintval.Make(Debugcom.Remote_value)(EvalPath)
71
72let install_printer path ty _ppf fn =
73  Printer.install_printer path ty
74    (fun ppf remote_val ->
75       try
76         fn ppf (Obj.repr (Debugcom.Remote_value.obj remote_val))
77       with
78         Debugcom.Marshalling_error ->
79           fprintf ppf "<cannot fetch remote object>")
80
81let remove_printer = Printer.remove_printer
82
83let max_printer_depth = ref 20
84let max_printer_steps = ref 300
85
86let print_exception ppf obj =
87  let t = Printer.outval_of_untyped_exception obj in
88  !Oprint.out_value ppf t
89
90let print_value max_depth env obj (ppf : Format.formatter) ty =
91  let t =
92    Printer.outval_of_value !max_printer_steps max_depth
93      check_depth env obj ty in
94  !Oprint.out_value ppf t
95
96let print_named_value max_depth exp env obj ppf ty =
97  let print_value_name ppf = function
98  | E_ident lid ->
99      Printtyp.longident ppf lid
100  | E_name n ->
101      fprintf ppf "$%i" n
102  | _ ->
103      let n = name_value obj ty in
104      fprintf ppf "$%i" n in
105  Printtyp.reset_and_mark_loops ty;
106  fprintf ppf "@[<2>%a:@ %a@ =@ %a@]@."
107  print_value_name exp
108  Printtyp.type_expr ty
109  (print_value max_depth env obj) ty
110