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