l4/pkg/ocaml/contrib/debugger/loadprinter.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
   6 (*                                                                     *)
   7 (*  Copyright 1997 Institut National de Recherche en Informatique et   *)
   8 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   9 (*  under the terms of the Q Public License version 1.0.               *)
  10 (*                                                                     *)
  11 (***********************************************************************)
  12
  13 (* $Id: loadprinter.ml 9226 2009-04-02 09:44:21Z xclerc $ *)
  14
  15 (* Loading and installation of user-defined printer functions *)
  16
  17 open Misc
  18 open Longident
  19 open Path
  20 open Types
  21
  22 (* Error report *)
  23
  24 type error =
  25   | Load_failure of Dynlink.error
  26   | Unbound_identifier of Longident.t
  27   | Unavailable_module of string * Longident.t
  28   | Wrong_type of Longident.t
  29   | No_active_printer of Longident.t
  30
  31 exception Error of error
  32
  33 (* Symtable has global state, and normally holds the symbol table
  34    for the debuggee. We need to switch it temporarily to the
  35    symbol table for the debugger. *)
  36
  37 let debugger_symtable = ref (None: Symtable.global_map option)
  38
  39 let use_debugger_symtable fn arg =
  40   let old_symtable = Symtable.current_state() in
  41   begin match !debugger_symtable with
  42   | None ->
  43       Dynlink.init();
  44       Dynlink.allow_unsafe_modules true;
  45       debugger_symtable := Some(Symtable.current_state())
  46   | Some st ->
  47       Symtable.restore_state st
  48   end;
  49   try
  50     let result = fn arg in
  51     debugger_symtable := Some(Symtable.current_state());
  52     Symtable.restore_state old_symtable;
  53     result
  54   with exn ->
  55     Symtable.restore_state old_symtable;
  56     raise exn
  57
  58 (* Load a .cmo or .cma file *)
  59
  60 open Format
  61
  62 let rec loadfiles ppf name =
  63   try
  64     let filename = find_in_path !Config.load_path name in
  65     use_debugger_symtable Dynlink.loadfile filename;
  66     let d = Filename.dirname name in
  67     if d <> Filename.current_dir_name then begin
  68       if not (List.mem d !Config.load_path) then
  69         Config.load_path := d :: !Config.load_path;
  70     end;
  71     fprintf ppf "File %s loaded@." filename;
  72     true
  73   with
  74   | Dynlink.Error (Dynlink.Unavailable_unit unit) ->
  75       loadfiles ppf (String.uncapitalize unit ^ ".cmo")
  76         &&
  77       loadfiles ppf name
  78   | Not_found ->
  79       fprintf ppf "Cannot find file %s@." name;
  80       false
  81   | Dynlink.Error e ->
  82       raise(Error(Load_failure e))
  83
  84 let loadfile ppf name =
  85   ignore(loadfiles ppf name)
  86
  87 (* Return the value referred to by a path (as in toplevel/topdirs) *)
  88 (* Note: evaluation proceeds in the debugger memory space, not in
  89    the debuggee. *)
  90
  91 let rec eval_path = function
  92     Pident id -> Symtable.get_global_value id
  93   | Pdot(p, s, pos) -> Obj.field (eval_path p) pos
  94   | Papply(p1, p2) -> fatal_error "Loadprinter.eval_path"
  95
  96 (* Install, remove a printer (as in toplevel/topdirs) *)
  97
  98 let match_printer_type desc typename =
  99   let (printer_type, _) =
 100     try
 101       Env.lookup_type (Ldot(Lident "Topdirs", typename)) Env.empty
 102     with Not_found ->
 103       raise (Error(Unbound_identifier(Ldot(Lident "Topdirs", typename)))) in
 104   Ctype.init_def(Ident.current_time());
 105   Ctype.begin_def();
 106   let ty_arg = Ctype.newvar() in
 107   Ctype.unify Env.empty
 108     (Ctype.newconstr printer_type [ty_arg])
 109     (Ctype.instance desc.val_type);
 110   Ctype.end_def();
 111   Ctype.generalize ty_arg;
 112   ty_arg
 113
 114 let find_printer_type lid =
 115   try
 116     let (path, desc) = Env.lookup_value lid Env.empty in
 117     let (ty_arg, is_old_style) =
 118       try
 119         (match_printer_type desc "printer_type_new", false)
 120       with Ctype.Unify _ ->
 121         (match_printer_type desc "printer_type_old", true) in
 122     (ty_arg, path, is_old_style)
 123   with
 124   | Not_found -> raise(Error(Unbound_identifier lid))
 125   | Ctype.Unify _ -> raise(Error(Wrong_type lid))
 126
 127 let install_printer ppf lid =
 128   let (ty_arg, path, is_old_style) = find_printer_type lid in
 129   let v =
 130     try
 131       use_debugger_symtable eval_path path
 132     with Symtable.Error(Symtable.Undefined_global s) ->
 133       raise(Error(Unavailable_module(s, lid))) in
 134   let print_function =
 135     if is_old_style then
 136       (fun formatter repr -> Obj.obj v (Obj.obj repr))
 137     else
 138       (fun formatter repr -> Obj.obj v formatter (Obj.obj repr)) in
 139   Printval.install_printer path ty_arg ppf print_function
 140
 141 let remove_printer lid =
 142   let (ty_arg, path, is_old_style) = find_printer_type lid in
 143   try
 144     Printval.remove_printer path
 145   with Not_found ->
 146     raise(Error(No_active_printer lid))
 147
 148 (* Error report *)
 149
 150 open Format
 151
 152 let report_error ppf = function
 153   | Load_failure e ->
 154       fprintf ppf "@[Error during code loading: %s@]@."
 155         (Dynlink.error_message e)
 156   | Unbound_identifier lid ->
 157       fprintf ppf "@[Unbound identifier %a@]@."
 158       Printtyp.longident lid
 159   | Unavailable_module(md, lid) ->
 160       fprintf ppf
 161         "@[The debugger does not contain the code for@ %a.@ \
 162            Please load an implementation of %s first.@]@."
 163         Printtyp.longident lid md
 164   | Wrong_type lid ->
 165       fprintf ppf "@[%a has the wrong type for a printing function.@]@."
 166       Printtyp.longident lid
 167   | No_active_printer lid ->
 168       fprintf ppf "@[%a is not currently active as a printing function.@]@."
 169       Printtyp.longident lid
 170
 171