debugger/printval.ml

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