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
18 open Misc
19 open Longident
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 (* Load a .cmo or .cma file *)
34
35 open Format
36
37 let rec loadfiles ppf name =
38 try
39 let filename = Load_path.find name in
40 Dynlink.allow_unsafe_modules true;
41 Dynlink.loadfile filename;
42 let d = Filename.dirname name in
43 if d <> Filename.current_dir_name then begin
44 if not (List.mem d (Load_path.get_paths ())) then
45 Load_path.add_dir d;
46 end;
47 fprintf ppf "File %s loaded@."
48 (if d <> Filename.current_dir_name then
49 filename
50 else
51 Filename.basename filename);
52 true
53 with
54 | Dynlink.Error (Dynlink.Unavailable_unit unit) ->
55 loadfiles ppf (String.uncapitalize_ascii unit ^ ".cmo")
56 &&
57 loadfiles ppf name
58 | Not_found ->
59 fprintf ppf "Cannot find file %s@." name;
60 false
61 | Sys_error msg ->
62 fprintf ppf "%s: %s@." name msg;
63 false
64 | Dynlink.Error e ->
65 raise(Error(Load_failure e))
66
67 let loadfile ppf name =
68 ignore(loadfiles ppf name)
69
70 (* Return the value referred to by a path (as in toplevel/topdirs) *)
71 (* Note: evaluation proceeds in the debugger memory space, not in
72 the debuggee. *)
73
74 let rec eval_address = function
75 | Env.Aident id ->
76 assert (Ident.persistent id);
77 let bytecode_or_asm_symbol = Ident.name id in
78 begin match Dynlink.unsafe_get_global_value ~bytecode_or_asm_symbol with
79 | None ->
80 raise (Symtable.Error (Symtable.Undefined_global bytecode_or_asm_symbol))
81 | Some obj -> obj
82 end
83 | Env.Adot(addr, pos) -> Obj.field (eval_address addr) pos
84
85 let eval_value_path env path =
86 match Env.find_value_address path env with
87 | addr -> eval_address addr
88 | exception Not_found ->
89 fatal_error ("Cannot find address for: " ^ (Path.name path))
90
91 (* Install, remove a printer (as in toplevel/topdirs) *)
92
93 (* since 4.00, "topdirs.cmi" is not in the same directory as the standard
94 library, so we load it beforehand as it cannot be found in the search path. *)
95 let init () =
96 let topdirs =
97 Filename.concat !Parameters.topdirs_path "topdirs.cmi" in
98 ignore (Env.read_signature "Topdirs" topdirs)
99
100 let match_printer_type desc typename =
101 let printer_type =
102 match
103 Env.find_type_by_name
104 (Ldot(Lident "Topdirs", typename)) Env.empty
105 with
106 | path, _ -> path
107 | exception Not_found ->
108 raise (Error(Unbound_identifier(Ldot(Lident "Topdirs", typename))))
109 in
110 Ctype.begin_def();
111 let ty_arg = Ctype.newvar() in
112 Ctype.unify Env.empty
113 (Ctype.newconstr printer_type [ty_arg])
114 (Ctype.instance desc.val_type);
115 Ctype.end_def();
116 Ctype.generalize ty_arg;
117 ty_arg
118
119 let find_printer_type lid =
120 match Env.find_value_by_name lid Env.empty with
121 | (path, desc) -> begin
122 match match_printer_type desc "printer_type_new" with
123 | ty_arg -> (ty_arg, path, false)
124 | exception Ctype.Unify _ -> begin
125 match match_printer_type desc "printer_type_old" with
126 | ty_arg -> (ty_arg, path, true)
127 | exception Ctype.Unify _ -> raise(Error(Wrong_type lid))
128 end
129 end
130 | exception Not_found ->
131 raise(Error(Unbound_identifier lid))
132
133 let install_printer ppf lid =
134 let (ty_arg, path, is_old_style) = find_printer_type lid in
135 let v =
136 try
137 eval_value_path Env.empty path
138 with Symtable.Error(Symtable.Undefined_global s) ->
139 raise(Error(Unavailable_module(s, lid))) in
140 let print_function =
141 if is_old_style then
142 (fun _formatter repr -> Obj.obj v (Obj.obj repr))
143 else
144 (fun formatter repr -> Obj.obj v formatter (Obj.obj repr)) in
145 Printval.install_printer path ty_arg ppf print_function
146
147 let remove_printer lid =
148 let (_ty_arg, path, _is_old_style) = find_printer_type lid in
149 try
150 Printval.remove_printer path
151 with Not_found ->
152 raise(Error(No_active_printer lid))
153
154 (* Error report *)
155
156 open Format
157
158 let report_error ppf = function
159 | Load_failure e ->
160 fprintf ppf "@[Error during code loading: %s@]@."
161 (Dynlink.error_message e)
162 | Unbound_identifier lid ->
163 fprintf ppf "@[Unbound identifier %a@]@."
164 Printtyp.longident lid
165 | Unavailable_module(md, lid) ->
166 fprintf ppf
167 "@[The debugger does not contain the code for@ %a.@ \
168 Please load an implementation of %s first.@]@."
169 Printtyp.longident lid md
170 | Wrong_type lid ->
171 fprintf ppf "@[%a has the wrong type for a printing function.@]@."
172 Printtyp.longident lid
173 | No_active_printer lid ->
174 fprintf ppf "@[%a is not currently active as a printing function.@]@."
175 Printtyp.longident lid
176