anil.recoil.org
My working unpac repository
1(**************************************************************************)
2(* *)
3(* OCaml *)
4(* *)
5(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
6(* *)
7(* Copyright 1997 Institut National de Recherche en Informatique et *)
8(* en Automatique. *)
9(* *)
10(* All rights reserved. This file is distributed under the terms of *)
11(* the GNU Lesser General Public License version 2.1, with the *)
12(* special exception on linking described in the file LICENSE. *)
13(* *)
14(**************************************************************************)
15
16(* Loading and installation of user-defined printer functions *)
17
18open Misc
19
20(* Error report *)
21
22type error = [
23 Topprinters.error
24 | `Load_failure of Dynlink.error
25 | `Unavailable_module of string * Longident.t
26]
27
28exception Error of error
29
30(* Load a .cmo or .cma file *)
31
32open Format
33
34let rec loadfiles ppf name =
35 try
36 let filename = Load_path.find name in
37 Dynlink.allow_unsafe_modules true;
38 Dynlink.loadfile filename;
39 let d = Filename.dirname name in
40 if d <> Filename.current_dir_name then begin
41 if not (List.mem d (Load_path.get_path_list ())) then
42 Load_path.add_dir ~hidden:false d;
43 end;
44 fprintf ppf "File %s loaded@."
45 (if d <> Filename.current_dir_name then
46 filename
47 else
48 Filename.basename filename);
49 true
50 with
51 | Dynlink.Error (Dynlink.Unavailable_unit unit) ->
52 loadfiles ppf (Unit_info.normalize unit ^ ".cmo")
53 &&
54 loadfiles ppf name
55 | Not_found ->
56 fprintf ppf "Cannot find file %s@." name;
57 false
58 | Sys_error msg ->
59 fprintf ppf "%s: %s@." name msg;
60 false
61 | Dynlink.Error e ->
62 raise(Error(`Load_failure e))
63
64let loadfile ppf name =
65 ignore(loadfiles ppf name)
66
67(* Return the value referred to by a path (as in toplevel/topdirs) *)
68(* Note: evaluation proceeds in the debugger memory space, not in
69 the debuggee. *)
70
71let rec eval_address = function
72 | Env.Aident id ->
73 assert (Ident.persistent id);
74 let bytecode_or_asm_symbol = Ident.name id in
75 begin match Dynlink.unsafe_get_global_value ~bytecode_or_asm_symbol with
76 | None ->
77 raise (Symtable.Error (Symtable.Undefined_global
78 (Symtable.Global.Glob_compunit (Cmo_format.Compunit
79 bytecode_or_asm_symbol))))
80 | Some obj -> obj
81 end
82 | Env.Adot(addr, pos) -> Obj.field (eval_address addr) pos
83
84let eval_value_path env path =
85 match Env.find_value_address path env with
86 | addr -> eval_address addr
87 | exception Not_found ->
88 fatal_error ("Cannot find address for: " ^ (Path.name path))
89
90(* Install, remove a printer (as in toplevel/topdirs) *)
91
92let install_printer lid =
93 let eval_value_path env path =
94 try
95 eval_value_path env path
96 with Symtable.Error(Symtable.Undefined_global global) ->
97 let s = Symtable.Global.name global in
98 raise (Error (`Unavailable_module(s, lid))) in
99 match Topprinters.install eval_value_path Env.empty lid with
100 | Error error -> raise (Error (error :> error))
101 | Ok () -> ()
102
103let remove_printer lid =
104 match Topprinters.remove Env.empty lid with
105 | Error error -> raise (Error (error :> error))
106 | Ok () -> ()
107
108(* Error report *)
109
110open Format
111module Style = Misc.Style
112let quoted_longident =
113 Format_doc.compat @@ Style.as_inline_code Printtyp.Doc.longident
114
115let report_error ppf = function
116 | `Load_failure e ->
117 fprintf ppf "@[Error during code loading: %s@]@."
118 (Dynlink.error_message e)
119 | `Unbound_identifier lid ->
120 fprintf ppf "@[Unbound identifier %a@]@."
121 quoted_longident lid
122 | `Unavailable_module(md, lid) ->
123 fprintf ppf
124 "@[The debugger does not contain the code for@ %a.@ \
125 Please load an implementation of %s first.@]@."
126 quoted_longident lid md
127 | `Wrong_type lid ->
128 fprintf ppf "@[%a has the wrong type for a printing function.@]@."
129 quoted_longident lid
130 | `No_active_printer path ->
131 fprintf ppf "@[%a is not currently active as a printing function.@]@."
132 Printtyp.path path