c_interface.sa

 
---------------------------> Sather 1.1 source file <--------------------------

class TCL_TK 
class TCL_TK is
   -- The interface to Tcl/Tk

   readonly attr interpreter:EXT_OB;
   readonly attr main_window:EXT_OB;

   Ok: INT is  return C_TCL_TK::ConstTclOk;  end;
   Error: INT is  return C_TCL_TK::ConstTclError;  end;
   Volatile: EXT_OB is    return C_TCL_TK::ConstTclVolatile  end;

   create(basename, classname: STR): SAME is
      t ::= new;
      t.interpreter := C_TCL_TK::Tcl_CreateInterp;
      C_TCL_TK::init_tcl_tk(t.interpreter);
      main_window ::= t.create_main_window(basename, classname);
      C_TCL_TK::init_raster(t.interpreter);
      sather_home ::= UNIX::sather_home;
      file_name ::= sather_home+"/System/Platforms/tcltk/startup.tcl";
      f: FILE := FILE::open_for_read(file_name);
      if void(f) or f.error then
	 raise ("Can't source startup.tcl in:"+file_name+"\n");
      end;
      f.close;
      discard ::= t.eval_file(file_name);
      return t;
   end;
   
   create_no_window(basename, classname: STR): SAME is
      t ::= new;
      t.interpreter := C_TCL_TK::Tcl_CreateInterp;
      C_TCL_TK::init_tcl_tk(t.interpreter);
      return t;
   end;

   private create_main_window(basename, classname: STR): EXT_OB is
      screen ::= UNIX::get_env("DISPLAY");
      if void(screen) then screen := ":0.0" end;
      return C_TCL_TK::Tk_CreateMainWindow(interpreter, 
					   screen, 
					   basename, 
					   classname);
   end;

   eval(script: STR): STR is
      ret ::= C_TCL_TK::Tcl_Eval(interpreter, script);
      res ::= STR::create_from_c_string(C_TCL_TK::Tcl_GetResult(interpreter));
      if ret /= Ok then
	 raise "An error occurred in an eval. Error:"+res+"\n"+script;
      else return res;   end;
   end;

   eval_file(file: STR): STR is
      ret ::= C_TCL_TK::Tcl_EvalFile(interpreter, file);
      res ::= STR::create_from_c_string(C_TCL_TK::Tcl_GetResult(interpreter));
      if ret /= Ok then
	s ::="An error occurred in evaluating file:"+file.str
	       +"\nResult="+res+"\n";
	 #ERR+s;
	 raise s;
      else
	 return res;
      end;
   end;

   main_loop is
      protect
	 C_TCL_TK::Tk_MainLoop;	-- infinitely
      when $STR then 
	 #ERR+"An error occurred!:"+exception.str+"\n";
	 raise exception.str
      end;
   end;
   
   to_array_str(cpp: EXT_OB): ARRAY{STR} is
      -- make array of STR from char **
      -- must be terminated with NULL
      l ::= #FLIST{STR};
      loop i ::= 0.up!;
	 c_str ::= C_UTIL::str_ind(cpp, i); -- the i-th string
	 until!(void(c_str));
	 l := l.push(STR::create_from_c_string(c_str));
      end;
      return l.array;
   end;
   
end; -- class TCL_TK


class TCL_TK_COMMANDS 
class TCL_TK_COMMANDS is
   -- Bound routines to be called by the callbacks
   -- "sather"  calls the bound routine associated with
   --         sather_command.   This bound routine is invoked
   --         when the "sather" command is used within Tcl.
   --        It receives as its argument an array of strings.
   -- 
   -- Specifying this routine using a bound routines provides some
   -- isolation fom the Gui/Browser so that this module can remain
   -- independant of them.
   -- 
   -- "tkkit_cb" calls the bound routine associated with 
   -- tkkit_cb_command tkkit_cb is so named for historical reasons 
   -- and should only be used by the browser. It may be renamed in 
   -- a future release
   -- 

   
   private shared private_sather_command:ROUT{ARRAY{STR}};
   private shared private_tkkit_cb:ROUT{ARRAY{STR}}:INT;
   
   sather_command: ROUT{ARRAY{STR}} is
      -- Return the bound routine associated with the callback Tcl
      -- command "sather"
      if void(private_sather_command) then 
	 raise "TCL_TK_COMMANDS::sather_command bound routine not set";
      end;
      return private_sather_command;  
   end;
   
   sather_command(r:ROUT{ARRAY{STR}}) is private_sather_command := r; end;
   -- Set the bound routine associated with the callback Tcl command
   -- "sather"
   
   -- Historical 
   tkkit_cb_command: ROUT{ARRAY{STR}}:INT is
      -- Used by the browser only
      if void(private_tkkit_cb) then 
	 raise "TCL_TK_COMMANDS::sather_command bound routine not set";
      end;
      return private_tkkit_cb;  
   end;
   
   tkkit_cb_command(r:ROUT{ARRAY{STR}}:INT) is  private_tkkit_cb := r;  end;
   -- Used by the browser only

end;


external class C_TCL_TK 
external class C_TCL_TK is		
   -- Interface to basic tcl and tk functions
   -- Depends on the  tcl.a, tk.a

   Tcl_CreateInterp: EXT_OB;	-- create a new tcl-interpreter
   Tcl_Eval(interp: EXT_OB, cmd: STR): INT;
   Tcl_EvalFile(interp: EXT_OB, file: STR): INT;

   ConstTclOk: INT;
   ConstTclError: INT;
   ConstTclVolatile: EXT_OB;
   
   Tcl_SetResult(interp: EXT_OB, str: STR, free_proc: EXT_OB);
   Tcl_ResetResult(interp: EXT_OB);
   Tcl_GetResult(interp: EXT_OB): EXT_OB;
   
   Tk_CreateMainWindow(interp: EXT_OB, screenname, basename, classname: STR): EXT_OB;
   Tk_MapWindow(w: EXT_OB);
   Tk_DoOneEvent(i: INT);
   Tk_MainLoop;
   
   init_tcl_tk(interp: EXT_OB);
   -- Initialize the callbacks
   
   init_raster(interp: EXT_OB);
   -- Initialize the raster widget
    
   sather_cb(args: EXT_OB): INT is
      -- Callback into sather from tcl. 
      sather_command:ROUT{ARRAY{STR}}:= TCL_TK_COMMANDS::sather_command;
      sather_command.call(TCL_TK::to_array_str(args));
      -- GUI_APP_END::exec_callback(args);  
      return C_TCL_TK::ConstTclOk;
   end;
    
   tkkit_cb(args: EXT_OB): INT is
      -- Same as "C_TCL_KIT::command"
      argv: ARRAY{STR} := TCL_TK::to_array_str(args);
      assert argv.size > 1;	-- contains at least "tkkit_cb <callback_name>"
      return TCL_TK_COMMANDS::tkkit_cb_command.call(argv);
   end;

end; 


external class C_UTIL 
external class C_UTIL is
   str_ind(cpp: EXT_OB, i: INT): EXT_OB; -- char *str_int(char **argv, int i)
end;