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
158
159
160
161
162
163
164
165
166
167
168
169
|
(***********************************************************************)
(* *)
(* 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 Q Public License version 1.0. *)
(* *)
(***********************************************************************)
(* $Id$ *)
(* Loading and installation of user-defined printer functions *)
open Misc
open Longident
open Path
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
(* Symtable has global state, and normally holds the symbol table
for the debuggee. We need to switch it temporarily to the
symbol table for the debugger. *)
let debugger_symtable = ref (None: Symtable.global_map option)
let use_debugger_symtable fn arg =
let old_symtable = Symtable.current_state() in
begin match !debugger_symtable with
| None ->
Dynlink.init();
Dynlink.allow_unsafe_modules true;
debugger_symtable := Some(Symtable.current_state())
| Some st ->
Symtable.restore_state st
end;
try
let result = fn arg in
debugger_symtable := Some(Symtable.current_state());
Symtable.restore_state old_symtable;
result
with exn ->
Symtable.restore_state old_symtable;
raise exn
(* Load a .cmo or .cma file *)
open Format
let rec loadfiles ppf name =
try
let filename = find_in_path !Config.load_path name in
use_debugger_symtable Dynlink.loadfile filename;
let d = Filename.dirname name in
if d <> Filename.current_dir_name then begin
if not (List.mem d !Config.load_path) then
Config.load_path := d :: !Config.load_path;
end;
fprintf ppf "File %s loaded@." filename;
true
with
| Dynlink.Error (Dynlink.Unavailable_unit unit) ->
loadfiles ppf (String.uncapitalize unit ^ ".cmo")
&&
loadfiles ppf name
| Not_found ->
fprintf ppf "Cannot find file %s@." name;
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_path = function
Pident id -> Symtable.get_global_value id
| Pdot(p, s, pos) -> Obj.field (eval_path p) pos
| Papply(p1, p2) -> fatal_error "Loadprinter.eval_path"
(* Install, remove a printer (as in toplevel/topdirs) *)
let match_printer_type desc typename =
let (printer_type, _) =
try
Env.lookup_type (Ldot(Lident "Topdirs", typename)) Env.empty
with Not_found ->
raise (Error(Unbound_identifier(Ldot(Lident "Topdirs", typename)))) in
Ctype.init_def(Ident.current_time());
Ctype.begin_def();
let ty_arg = Ctype.newvar() in
Ctype.unify Env.empty
(Ctype.newconstr printer_type [ty_arg])
(Ctype.instance Env.empty desc.val_type);
Ctype.end_def();
Ctype.generalize ty_arg;
ty_arg
let find_printer_type lid =
try
let (path, desc) = Env.lookup_value lid Env.empty in
let (ty_arg, is_old_style) =
try
(match_printer_type desc "printer_type_new", false)
with Ctype.Unify _ ->
(match_printer_type desc "printer_type_old", true) in
(ty_arg, path, is_old_style)
with
| Not_found -> raise(Error(Unbound_identifier lid))
| Ctype.Unify _ -> raise(Error(Wrong_type lid))
let install_printer ppf lid =
let (ty_arg, path, is_old_style) = find_printer_type lid in
let v =
try
use_debugger_symtable eval_path 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
|
