let rec to_do_on_select
(popup_factory:GMenu.menu GMenu.factory)
(main_ui:Design.main_window_extension_points) button_nb selected
=
let inset_utf8 = Unicode.inset_string () in
let annot = main_ui#annot_window#buffer in
if button_nb = 1 then
begin
if Db.Value.is_computed ()
then begin
match selected with
| PStmt (_kf,ki) -> begin
(* Find kinstr and kf *)
(* Is it an accessible statement ? *)
if Db.Value.is_accessible (Kstmt ki) then begin
(* Out for this statement *)
let outs = Db.Outputs.kinstr (Kstmt ki) in
let n = ( match outs with
| Some outs ->
Pretty_utils.sfprintf
"Modifies %a@\n" Db.Outputs.pretty outs
| _ -> "\n");
in annot#insert n
end else annot#insert "This code is dead\n";
end
| PLval (_kf, ki,lv) ->
if not (isFunctionType (typeOfLval lv))
then begin
(try
let offsetmap =
!Db.Value.lval_to_offsetmap ~with_alarms:CilE.warn_none_mode ki lv
in
annot#insert (Pretty_utils.sfprintf
"Before statement:@\n%a@\n"
(pretty_offsetmap lv ) offsetmap);
with Lmap.Cannot_copy ->
let value = !Db.Value.access ki lv in
annot#insert (Pretty_utils.sfprintf "Before statement:@\n%a %s %a@\n"
!Ast_printer.d_lval lv inset_utf8 Db.Value.pretty value));
(try
let offsetmap_after = !Db.Value.lval_to_offsetmap_after ki lv in
annot#insert "At next statement:\n";
annot#insert (Pretty_utils.sfprintf "%a\n" (pretty_offsetmap lv) offsetmap_after);
with Not_found -> ());
end
| PTermLval _ -> () (* JS: TODO (?) *)
| PVDecl (_kf,_vi) -> ()
| PGlobal _ | PIP _ -> ()
end
end
else if button_nb = 3
then begin
match selected with
| PVDecl (_,vi) ->
begin
try
let kfun = Globals.Functions.get vi in
if Db.Value.is_computed ()
then
let callers = !Value.callers kfun in
(* popup a menu to jump to the definitions of the callers *)
let do_menu l =
try
List.iter
(fun (v,call_sites) ->
let v = Kernel_function.get_vi v in
let nb_sites = List.length call_sites in
let label = "Go to caller " ^
(Pretty_utils.escape_underscores
(Pretty_utils.sfprintf "%a"
Ast_info.pretty_vname v))
in
let label =
if nb_sites > 1
then
label ^ " (" ^ (string_of_int nb_sites) ^" call sites)"
else label
in
ignore
(popup_factory#add_item
label
~callback:
(fun () -> main_ui#file_tree#select_global v)))
l;
with Not_found -> ()
in
do_menu callers
else
ignore
(popup_factory#add_item
"Callers ..."
~callback:
(fun () -> (gui_compute_values main_ui)))
with Not_found ->
()
end
| PStmt (kf,ki) ->
if Db.Value.is_computed ()
then begin
let eval_expr () =
let txt =
GToolbox.input_string
~title:"Evaluate"
" Enter an ACSL expression to evaluate "
(* the spaces at beginning and end should not be necessary
but are the quickest fix for an aesthetic GTK problem *)
in
match txt with
| None -> ()
| Some txt -> try
let exp =
!Db.Properties.Interp.term_to_exp ~result:None
(!Db.Properties.Interp.expr kf ki txt)
in
begin match exp.enode with
| Lval lv | StartOf lv ->
to_do_on_select popup_factory main_ui 1 (PLval((Some kf),Kstmt ki,lv))
| _ ->
let loc =
!Db.Value.access_expr
(Kstmt ki)
exp
in
let txt =
Format.sprintf
"Before the selected statement, all the values taken by the expression %s are contained in %s@\n"
(Pretty_utils.sfprintf "%a" !Ast_printer.d_exp exp)
(Pretty_utils.sfprintf "%a" Cvalue_type.V.pretty loc)
in
annot#insert txt
end
with e ->
main_ui#error "Invalid expression: %s" (Cmdline.protect e)
in
begin
try
ignore
(popup_factory#add_item "_Evaluate expression"
~callback:eval_expr)
with Not_found -> ()
end
end
else
ignore
(popup_factory#add_item
"_Evaluate expression ..."
~callback:
(fun () -> (gui_compute_values main_ui)))
| PLval (_kf, ki, lv) ->
let ty = typeOfLval lv in
(* Do special actions for functions *)
begin
(* popup a menu to jump the definitions of the given varinfos *)
let do_menu l =
match l with
| [] -> ()
| _ ->
try
List.iter
(fun v ->
ignore
(popup_factory#add_item
("Go to definition of " ^
(Pretty_utils.escape_underscores
(Pretty_utils.sfprintf "%a"
Ast_info.pretty_vname v))
^ " (indirect)")
~callback:
(fun () ->
main_ui#file_tree#select_global v)))
l ;
with Not_found -> ()
in
(match lv with
| Var _,NoOffset when isFunctionType ty ->
(* simple literal calls are done by [Design]. *)
()
| Mem ({ enode = Lval lv}), NoOffset ->
if isFunctionType ty then
(* Function pointers *)
begin try
(* get the list of exact bases in the values *)
let value,_exact =
Cvalue_type.V.find_exact_base_without_offset
(!Db.Value.access ki lv)
in
let functions =
List.fold_left
(fun acc ->
(function
| Base.Var (vi,_) -> vi::acc
| _ -> acc))
[]
value
in
do_menu functions
with Not_found -> ()
end
| _ -> ()
)
end
| PTermLval _ -> () (* No C function calls in logic *)
| PGlobal _ -> ()
| PIP _ -> ()
end