diff options
Diffstat (limited to 'ocaml-binary-annot/debugger/eval.ml')
| -rw-r--r-- | ocaml-binary-annot/debugger/eval.ml | 207 |
1 files changed, 207 insertions, 0 deletions
diff --git a/ocaml-binary-annot/debugger/eval.ml b/ocaml-binary-annot/debugger/eval.ml new file mode 100644 index 0000000000..7ee1339f01 --- /dev/null +++ b/ocaml-binary-annot/debugger/eval.ml @@ -0,0 +1,207 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* Objective Caml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 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$ *) + +open Misc +open Path +open Instruct +open Types +open Parser_aux + +type error = + Unbound_identifier of Ident.t + | Not_initialized_yet of Path.t + | Unbound_long_identifier of Longident.t + | Unknown_name of int + | Tuple_index of type_expr * int * int + | Array_index of int * int + | List_index of int * int + | String_index of string * int * int + | Wrong_item_type of type_expr * int + | Wrong_label of type_expr * string + | Not_a_record of type_expr + | No_result + +exception Error of error + +let abstract_type = + Btype.newgenty (Tconstr (Pident (Ident.create "<abstr>"), [], ref Mnil)) + +let rec path event = function + Pident id -> + if Ident.global id then + try + Debugcom.Remote_value.global (Symtable.get_global_position id) + with Symtable.Error _ -> raise(Error(Unbound_identifier id)) + else + begin match event with + Some ev -> + begin try + let pos = Ident.find_same id ev.ev_compenv.ce_stack in + Debugcom.Remote_value.local (ev.ev_stacksize - pos) + with Not_found -> + try + let pos = Ident.find_same id ev.ev_compenv.ce_heap in + Debugcom.Remote_value.from_environment pos + with Not_found -> + raise(Error(Unbound_identifier id)) + end + | None -> + raise(Error(Unbound_identifier id)) + end + | Pdot(root, fieldname, pos) -> + let v = path event root in + if not (Debugcom.Remote_value.is_block v) then + raise(Error(Not_initialized_yet root)); + Debugcom.Remote_value.field v pos + | Papply(p1, p2) -> + fatal_error "Eval.path: Papply" + +let rec expression event env = function + E_ident lid -> + begin try + let (p, valdesc) = Env.lookup_value lid env in + (begin match valdesc.val_kind with + Val_ivar (_, cl_num) -> + let (p0, _) = + Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env + in + let v = path event p0 in + let i = path event p in + Debugcom.Remote_value.field v (Debugcom.Remote_value.obj i) + | _ -> + path event p + end, + Ctype.correct_levels valdesc.val_type) + with Not_found -> + raise(Error(Unbound_long_identifier lid)) + end + | E_result -> + begin match event with + Some {ev_kind = Event_after ty; ev_typsubst = subst} when !Frames.current_frame = 0 -> + (Debugcom.Remote_value.accu(), Subst.type_expr subst ty) + | _ -> + raise(Error(No_result)) + end + | E_name n -> + begin try + Printval.find_named_value n + with Not_found -> + raise(Error(Unknown_name n)) + end + | E_item(arg, n) -> + let (v, ty) = expression event env arg in + begin match (Ctype.repr(Ctype.expand_head_opt env ty)).desc with + Ttuple ty_list -> + if n < 1 || n > List.length ty_list + then raise(Error(Tuple_index(ty, List.length ty_list, n))) + else (Debugcom.Remote_value.field v (n-1), List.nth ty_list (n-1)) + | Tconstr(path, [ty_arg], _) when Path.same path Predef.path_array -> + let size = Debugcom.Remote_value.size v in + if n >= size + then raise(Error(Array_index(size, n))) + else (Debugcom.Remote_value.field v n, ty_arg) + | Tconstr(path, [ty_arg], _) when Path.same path Predef.path_list -> + let rec nth pos v = + if not (Debugcom.Remote_value.is_block v) then + raise(Error(List_index(pos, n))) + else if pos = n then + (Debugcom.Remote_value.field v 0, ty_arg) + else + nth (pos + 1) (Debugcom.Remote_value.field v 1) + in nth 0 v + | Tconstr(path, [], _) when Path.same path Predef.path_string -> + let s = (Debugcom.Remote_value.obj v : string) in + if n >= String.length s + then raise(Error(String_index(s, String.length s, n))) + else (Debugcom.Remote_value.of_int(Char.code s.[n]), + Predef.type_char) + | _ -> + raise(Error(Wrong_item_type(ty, n))) + end + | E_field(arg, lbl) -> + let (v, ty) = expression event env arg in + begin match (Ctype.repr(Ctype.expand_head_opt env ty)).desc with + Tconstr(path, args, _) -> + let tydesc = Env.find_type path env in + begin match tydesc.type_kind with + Type_record(lbl_list, repr) -> + let (pos, ty_res) = + find_label lbl env ty path tydesc 0 lbl_list in + (Debugcom.Remote_value.field v pos, ty_res) + | _ -> raise(Error(Not_a_record ty)) + end + | _ -> raise(Error(Not_a_record ty)) + end + +and find_label lbl env ty path tydesc pos = function + [] -> + raise(Error(Wrong_label(ty, lbl))) + | (name, mut, ty_arg) :: rem -> + if name = lbl then begin + let ty_res = + Btype.newgenty(Tconstr(path, tydesc.type_params, ref Mnil)) + in + (pos, + try Ctype.apply env [ty_res] ty_arg [ty] with Ctype.Cannot_apply -> + abstract_type) + end else + find_label lbl env ty path tydesc (pos + 1) rem + +(* Error report *) + +open Format + +let report_error ppf = function + | Unbound_identifier id -> + fprintf ppf "@[Unbound identifier %s@]@." (Ident.name id) + | Not_initialized_yet path -> + fprintf ppf + "@[The module path %a is not yet initialized.@ \ + Please run program forward@ \ + until its initialization code is executed.@]@." + Printtyp.path path + | Unbound_long_identifier lid -> + fprintf ppf "@[Unbound identifier %a@]@." Printtyp.longident lid + | Unknown_name n -> + fprintf ppf "@[Unknown value name $%i@]@." n + | Tuple_index(ty, len, pos) -> + Printtyp.reset_and_mark_loops ty; + fprintf ppf + "@[Cannot extract field number %i from a %i-tuple of type@ %a@]@." + pos len Printtyp.type_expr ty + | Array_index(len, pos) -> + fprintf ppf + "@[Cannot extract element number %i from an array of length %i@]@." pos len + | List_index(len, pos) -> + fprintf ppf + "@[Cannot extract element number %i from a list of length %i@]@." pos len + | String_index(s, len, pos) -> + fprintf ppf + "@[Cannot extract character number %i@ \ + from the following string of length %i:@ %S@]@." + pos len s + | Wrong_item_type(ty, pos) -> + fprintf ppf + "@[Cannot extract item number %i from a value of type@ %a@]@." + pos Printtyp.type_expr ty + | Wrong_label(ty, lbl) -> + fprintf ppf + "@[The record type@ %a@ has no label named %s@]@." + Printtyp.type_expr ty lbl + | Not_a_record ty -> + fprintf ppf + "@[The type@ %a@ is not a record type@]@." Printtyp.type_expr ty + | No_result -> + fprintf ppf "@[No result available at current program event@]@." |