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