let slicing_selector (popup_factory:GMenu.menu GMenu.factory)
(main_ui:Design.main_window_extension_points) ~button localizable =
if (not (Db.Value.is_computed ())) || not (Enable.get ())
then
ignore
(popup_factory#add_item "_Slicing ..."
~callback:
(fun () ->
if (not (Db.Value.is_computed ()))
then gui_compute_values main_ui ;
if Db.Value.is_computed ()
then Enable.set true))
else
let slicing_project = !Db.Slicing.Project.get_project () in
if button = 1 then
begin let level = 0 in
let slicing_view project =
gui_annot_info main_ui ~level (fun () -> "Highlighting for " ^ (!Db.Slicing.Project.get_name project))
in
Extlib.may slicing_view slicing_project;
if SlicingParameters.Verbose.get () > level then begin
let slicing_mark project =
let slicing_mark kf get_mark =
let add_mark_info txt = gui_annot_info ~level main_ui (fun () -> "Tag: " ^ (txt ())) in
let slices = !Db.Slicing.Slice.get_all project kf in
match slices with
| [] ->
add_mark_info (fun () ->
if !Db.Slicing.Project.is_called project kf
then
(Pretty_utils.sfprintf "<src>%a"
!Db.Slicing.Mark.pretty (!Db.Slicing.Mark.get_from_src_func project kf))
else
"< >< >")
| slices ->
if !Db.Slicing.Project.is_called project kf
then begin
assert (not (kf == fst (Globals.entry_point ()))) ;
add_mark_info (fun () ->
Pretty_utils.sfprintf "<src>%a"
!Db.Slicing.Mark.pretty (!Db.Slicing.Mark.get_from_src_func project kf))
end ;
let mark_slice slice =
add_mark_info (fun () -> Pretty_utils.sfprintf "%a" !Db.Slicing.Mark.pretty (get_mark slice))
in List.iter mark_slice slices
in match localizable with
| Pretty_source.PTermLval(Some kf,(Kstmt ki),_)
| Pretty_source.PLval (Some kf,(Kstmt ki),_)
| Pretty_source.PStmt (kf,ki) -> slicing_mark kf (fun slice -> !Db.Slicing.Slice.get_mark_from_stmt slice ki)
| Pretty_source.PVDecl (Some kf,vi) -> slicing_mark kf (fun slice -> !Db.Slicing.Slice.get_mark_from_local_var slice vi)
| _ -> ()
in Extlib.may slicing_mark slicing_project
end
end
else if button = 3 then begin
let submenu = popup_factory#add_submenu "Slicing" in
let slicing_factory =
new Design.protected_menu_factory (main_ui:>Gtk_helper.host) submenu
in
let add_slicing_item name = add_item slicing_factory name in
let mk_slice = gui_mk_slice main_ui in
let add_slice_menu kf_opt kf_ki_opt =
add_slicing_item "Slice calls to"
kf_opt
~callback:(fun kf ->
mk_slice
~info:(fun () -> Pretty_utils.sfprintf "Request for slicing effects of function %a"
Kernel_function.pretty_name kf)
((mk_selection_all !Db.Slicing.Select.select_func_calls_to) kf));
add_slicing_item "Slice calls into"
kf_opt
~callback:(fun kf ->
mk_slice
~info:(fun () -> Pretty_utils.sfprintf "Request for slicing entrance into function %a"
Kernel_function.pretty_name kf)
((mk_selection_all !Db.Slicing.Select.select_func_calls_into) kf));
add_slicing_item "Slice result"
(Extlib.opt_filter (fun kf ->
let is_not_void_kf x =
match x.Cil_types.vtype with
| Cil_types.TFun (Cil_types.TVoid (_),_,_,_) -> false
| _ -> true
in is_not_void_kf (Kernel_function.get_vi kf))
kf_opt)
~callback:(fun kf ->
mk_slice
~info:(fun () -> Pretty_utils.sfprintf "Request for returned value of function %a"
Kernel_function.pretty_name kf)
((mk_selection_all !Db.Slicing.Select.select_func_return) kf));
add_slicing_item "Slice stmt"
kf_ki_opt
~callback:(fun (kf, ki) ->
mk_slice
~info:(fun () -> Pretty_utils.sfprintf "Request for slicing effects of statement %d"
ki.sid)
((mk_selection_all !Db.Slicing.Select.select_stmt) ki kf));
add_slicing_item "Slice lval"
kf_ki_opt
~callback:(fun (kf, ki) ->
let do_with_txt txt =
try
let lval_str = Cilutil.StringSet.add txt Cilutil.StringSet.empty in
mk_slice
~info:(fun () -> Pretty_utils.sfprintf "Request for slicing Lvalue %s before statement %d"
txt
ki.sid)
((mk_selection_cad !Db.Slicing.Select.select_stmt_lval)
lval_str ~before:true ki ~scope:ki ~eval:ki kf)
with e -> main_ui#error "Invalid expression: %s" (Printexc.to_string e)
in
let txt =
GToolbox.input_string
~title:"Input a pure Lvalue expression to slice before current statement"
""
in Extlib.may do_with_txt txt);
add_slicing_item "Slice rd"
kf_ki_opt
~callback:(fun (kf, ki) ->
let do_with_txt txt =
try
let lval_str = Cilutil.StringSet.add txt Cilutil.StringSet.empty in
mk_slice
~info:(fun () -> Pretty_utils.sfprintf "Request for slicing read accesses to Lvalue %s"
txt)
((mk_selection_cad !Db.Slicing.Select.select_func_lval_rw)
~rd:lval_str ~wr:Cilutil.StringSet.empty ~scope:ki ~eval:ki kf)
with e -> main_ui#error "Invalid expression: %s" (Printexc.to_string e)
in
let txt =
GToolbox.input_string
~title:"Input a pure Lvalue expression to slice read accesses"
""
in Extlib.may do_with_txt txt);
add_slicing_item "Slice wr"
kf_ki_opt
~callback:(fun (kf, ki) ->
let do_with_txt txt =
try
let lval_str = Cilutil.StringSet.add txt Cilutil.StringSet.empty in
mk_slice
~info:(fun () -> Pretty_utils.sfprintf "Request for slicing writen accesses to Lvalue %s"
txt)
((mk_selection_cad !Db.Slicing.Select.select_func_lval_rw)
~rd:Cilutil.StringSet.empty ~wr:lval_str ~scope:ki ~eval:ki kf)
with e -> main_ui#error "Invalid expression: %s" (Printexc.to_string e)
in
let txt =
GToolbox.input_string
~title:"Input a pure Lvalue expression to slice read accesses"
""
in Extlib.may do_with_txt txt);
add_slicing_item "Slice ctrl"
kf_ki_opt
~callback:(fun (kf, ki) ->
mk_slice
~info:(fun () -> Pretty_utils.sfprintf "Request for slicing accessibility to statement %d"
ki.sid)
((mk_selection_all !Db.Slicing.Select.select_stmt_ctrl) ki kf))
in
let some_kf_from_vi vi =
try let kf = Globals.Functions.get vi in
if Enable.get () && !Db.Value.is_called kf then Some kf else None
with Not_found -> None in
let some_kf_from_lv lv =
match lv with
| Var vi,_ -> some_kf_from_vi vi
| _ -> None in
let some_kf_ki kf ki =
if Enable.get ()
&& !Db.Value.is_called kf
&& Db.Value.is_accessible (Cil_types.Kstmt ki)
then Some (kf, ki) else None in
begin
match localizable with
| Pretty_source.PLval (Some kf,(Kstmt stmt),lv) ->
add_slice_menu (some_kf_from_lv lv) (some_kf_ki kf stmt)
| Pretty_source.PTermLval(Some kf,(Kstmt ki),_)
| Pretty_source.PStmt (kf,ki) ->
add_slice_menu None (some_kf_ki kf ki)
| Pretty_source.PVDecl (_,vi) ->
add_slice_menu (some_kf_from_vi vi) None
| _ ->
add_slice_menu None None
end;
let projects = !Db.Slicing.Project.get_all() in
ignore (slicing_factory#add_separator ());
add_slicing_item "_Disable"
(Some ())
~callback:(fun () -> Enable.set false);
add_slicing_item "_Clear"
(if slicing_project = None then None else Some ())
~callback:(fun () -> gui_set_project main_ui None) ;
List.iter
(fun proj ->
let add_highlight_menu sensitive =
add_slicing_item
("Highlight " ^ (Pretty_utils.escape_underscores (!Db.Slicing.Project.get_name proj)))
sensitive
~callback:(fun () -> gui_set_project main_ui (Some proj))
in match slicing_project with
| Some project -> add_highlight_menu (if (proj == project) then None else Some ())
| None -> add_highlight_menu (Some()))
projects;
end