From bbc648384f07d8a990a81e2dbb7d40972abe0889 Mon Sep 17 00:00:00 2001
From: Erwan Jahier <erwan.jahier@univ-grenoble-alpes.fr>
Date: Tue, 15 Jun 2021 09:23:46 +0200
Subject: [PATCH] Fix rdbgui4sasa when used with salut
---
tools/rdbg4sasa/gtkgui.ml | 53 +++++++++++++++++++------------
tools/rdbg4sasa/sasa-rdbg-cmds.ml | 8 +++--
tools/rdbgui4sasa/rdbgui.ml | 8 +++--
3 files changed, 43 insertions(+), 26 deletions(-)
diff --git a/tools/rdbg4sasa/gtkgui.ml b/tools/rdbg4sasa/gtkgui.ml
index dc0629a7..2c8e7ae0 100644
--- a/tools/rdbg4sasa/gtkgui.ml
+++ b/tools/rdbg4sasa/gtkgui.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 11/06/2021 (at 15:24) by Erwan Jahier> *)
+(* Time-stamp: <modified the 15/06/2021 (at 09:21) by Erwan Jahier> *)
#thread
#require "lablgtk3"
@@ -13,7 +13,6 @@ open Data
@return liste de tuples (nom, etat, activable)
*)
let rdbg_nodes_info e: (string * string * bool) list =
- (* récupère une liste qui dit si chaque état de chaque noeud est activable/pas activable *)
let enabled =
List.filter (fun (n,v) -> String.length n > 5 && String.sub n 0 5 = "Enab_") e.data
in
@@ -53,7 +52,8 @@ let rdbg_nodes_enabled e =
in
last::res
-type daemon_kind = Distributed | Synchronous | Central | LocCentral | ManualCentral | Manual
+type daemon_kind =
+ Distributed | Synchronous | Central | LocCentral | ManualCentral | Manual
let daemon_kind = ref ManualCentral
let refresh_fun_tbl = Hashtbl.create 1
@@ -80,10 +80,13 @@ let (fake_val_of_type : Data.t -> Data.v) = function
(**********************************************************************************)
(* Write with colors *)
let create_tags (buffer:GText.buffer) =
- ignore (buffer#create_tag ~name:"blue_foreground" [`FAMILY "monospace"; `FOREGROUND "blue"]);
- ignore (buffer#create_tag ~name:"black_foreground" [`FAMILY "monospace"; `FOREGROUND "black"]);
- ignore (buffer#create_tag ~name:"red_foreground" [`FAMILY "monospace"; `FOREGROUND "red"]);
- ignore (buffer#create_tag ~name:"green_foreground" [`FAMILY "monospace"; `FOREGROUND "green"]);
+ let mktags n c =
+ ignore (buffer#create_tag ~name:n [`FAMILY "monospace";`FOREGROUND c])
+ in
+ mktags "blue_foreground" "blue";
+ mktags "black_foreground" "black";
+ mktags "red_foreground" "red";
+ mktags "green_foreground" "green";
ignore (buffer#create_tag ~name:"red_background" [`BACKGROUND "red"]);
()
@@ -190,11 +193,15 @@ let init_rdbg_hook () =
let set_tooltip b = b#misc#set_tooltip_text
let start () =
+ (* création du rdbg_mv_hook et de tout ce qu'il faut autour *)
+ if !custom_mode_ref then init_rdbg_hook ();
if args.salut_mode then
(* In this mode, the hook plays first to provide fake values to
sasa but the hook does not need input at this first step *)
- e:=goto_hook_exit !e;
- if !custom_mode_ref then e := goto_hook_call !e;
+ e:=next_cond_gen !e (fun e -> e.name="mv_hook" && e.kind=Exit) (fun e -> e.next());
+
+ if !custom_mode_ref then
+ e:=next_cond_gen !e (fun e -> e.name="mv_hook" && e.kind=Call) (fun e -> e.next());
redos := [!e.nb];
ckpt_list := [!e];
round_reset !e.nb;
@@ -212,8 +219,6 @@ let restart p _ =
let custom_daemon p gtext vbox step_button back_step_button round_button
legitimate_button undo_button =
- (* création du rdbg_mv_hook et de tout ce qu'il faut autour *)
- init_rdbg_hook ();
let daemon_box = GPack.hbox ~packing:vbox#add () ~homogeneous:true ~height:15 in
let dk_dd = GButton.radio_button ~active:(!daemon_kind=Distributed)
@@ -234,6 +239,8 @@ let custom_daemon p gtext vbox step_button back_step_button round_button
set_tooltip dk_manual (Printf.sprintf "Set the manual mode");
set_tooltip dk_manual_central (Printf.sprintf "Set the manual central mode");
+ start ();
+
blue_add gtext#buffer (str_of_sasa_event false !e);
d();
let nodes_enabled = rdbg_nodes_enabled !e in
@@ -363,10 +370,14 @@ let custom_daemon p gtext vbox step_button back_step_button round_button
let counter_lbl = GMisc.label ~packing:counter_container#pack () in
let incB = GButton.button ~label:"+" ~packing:incr_container#add () in
let adj = GData.adjustment ~lower:0. ~upper:100. ~step_incr:1. ~page_incr:10. () in
- ignore (decB#connect#clicked ~callback:(fun () -> adj#set_value (float(counter#get-1))));
- ignore (incB#connect#clicked ~callback:(fun () -> adj#set_value (float(counter#get+1))));
- ignore (adj#connect#value_changed ~callback:(fun () -> counter#set (truncate adj#value)));
- ignore (counter#connect#changed ~callback:(fun n -> counter_lbl#set_text (string_of_int n)));
+ ignore (decB#connect#clicked
+ ~callback:(fun () -> adj#set_value (float(counter#get-1))));
+ ignore (incB#connect#clicked
+ ~callback:(fun () -> adj#set_value (float(counter#get+1))));
+ ignore (adj#connect#value_changed
+ ~callback:(fun () -> counter#set (truncate adj#value)));
+ ignore (counter#connect#changed
+ ~callback:(fun n -> counter_lbl#set_text (string_of_int n)));
counter#set 1;
set_tooltip counter_container (Printf.sprintf "Set the priority of %s" name);
Hashtbl.add counter_map name counter
@@ -384,7 +395,7 @@ let custom_daemon p gtext vbox step_button back_step_button round_button
hide undo_button;
(match !oracle_button_ref with Some b -> hide b | None -> ());
hide round_button; hide pushbox_grid; hide counter_grid;
- let checkbox = Hashtbl.find checkbox_map node in
+ let checkbox = try Hashtbl.find checkbox_map node with Not_found -> assert false in
if enabled then
show checkbox
else (
@@ -400,7 +411,7 @@ let custom_daemon p gtext vbox step_button back_step_button round_button
hide step_button;
hide round_button; hide checkbox_grid; hide counter_grid;
show pushbox_grid;
- let pushbox = Hashtbl.find pushbox_map node in
+ let pushbox = try Hashtbl.find pushbox_map node with Not_found -> assert false in
if enabled then show pushbox else hide pushbox;
pushbox#set_sensitive enabled
@@ -451,7 +462,7 @@ let custom_daemon p gtext vbox step_button back_step_button round_button
let rec get_higher_priority nl =
let prio n =
- let counter = Hashtbl.find counter_map n in
+ let counter = try Hashtbl.find counter_map n with Not_found -> assert false in
counter#get
in
let rec aux p acc = function
@@ -533,7 +544,6 @@ let ic_stdout = stdin
open GButton
(* GTK3 *)
let main () =
- start ();
let _locale = GtkMain.Main.init () in
let _thread = GtkThread.start () in
let window = GWindow.window
@@ -616,6 +626,7 @@ let main () =
else
(fun _ -> ())
in
+
let a_gui_step e =
(* set the daemongui_tbl and step to the next event where the user
is asked to choose whom to activate *)
@@ -623,7 +634,7 @@ let main () =
set_daemongui_tbl e;
let e = goto_hook_exit e in
let e = goto_hook_call e in
- if not args.salut_mode && is_silent e then
+ if not args.salut_mode && is_silent ~dflt:false e then
(* go to Ltop so that the round number can be updated *)
next_cond e (fun e -> e.kind = Ltop)
else
@@ -644,7 +655,7 @@ let main () =
next_round_gui_loop !round_st_ref.cpt ;
if
!custom_mode_ref && args.salut_mode && !e.name<>"mv_hook"
- && !e.kind<>Call && not (is_silent !e)
+ && !e.kind<>Call && not (is_silent ~dflt:false !e)
then
e:= goto_hook_call !e
)
diff --git a/tools/rdbg4sasa/sasa-rdbg-cmds.ml b/tools/rdbg4sasa/sasa-rdbg-cmds.ml
index 3118e2ad..feaf7726 100644
--- a/tools/rdbg4sasa/sasa-rdbg-cmds.ml
+++ b/tools/rdbg4sasa/sasa-rdbg-cmds.ml
@@ -10,10 +10,12 @@ open Sasacore.Topology;;
-let is_silent e =
+let is_silent ?(dflt=true) e =
match List.assoc_opt "silent" e.data with
| Some B b -> b
- | _ -> failwith "The silent value is not available in this event"
+ | _ ->
+ Printf.printf "The silent value is not available at event %d\n%!" e.nb;
+ dflt
let is_legitimate e =
match List.assoc_opt "legitimate" e.data with
@@ -84,7 +86,7 @@ let (round : RdbgEvent.t -> bool) =
set_round_st_mask cmask;
round
| None ->
- if !round_st_ref.mask = [] && is_silent e then false else
+ if !round_st_ref.mask = [] && (e.data=[] || is_silent e) then false else
let round =
if not
( (* we check if a round occurs when activated processes are available *)
diff --git a/tools/rdbgui4sasa/rdbgui.ml b/tools/rdbgui4sasa/rdbgui.ml
index 54b66692..edaa729a 100644
--- a/tools/rdbgui4sasa/rdbgui.ml
+++ b/tools/rdbgui4sasa/rdbgui.ml
@@ -5,7 +5,9 @@ let rdbg_cmd =
let cmd = List.tl (List.map quote (Array.to_list Sys.argv)) in
let str = String.concat " " cmd in
let salut_mode = not (Str.string_match (Str.regexp ".*sasa .*\\.dot") str 0) in
- let str = Str.replace_first (Str.regexp "sasa ") "sasa -custd -replay " str in
+ let str = if salut_mode then str else
+ Str.replace_first (Str.regexp "sasa ") "sasa -custd -replay " str
+ in
let sasa_opt = if salut_mode then "--salut" else "--sasa" in
String.concat " " ("rdbg"::sasa_opt::str::[])
@@ -25,4 +27,6 @@ let _ =
let n = Array.length Sys.argv in
welcome ();
if n = 1 && Mypervasives.ls "rdbg-session" "ml" = [] then exit 0;
- Sys.command (rdbg_cmd ^ gui)
+ let cmd = rdbg_cmd ^ gui in
+ Printf.printf "%s\n%!" cmd;
+ Sys.command cmd
--
GitLab