------------------------->  GNU Sather - sourcefile  <-------------------------
-- Copyright (C) 199x by International Computer Science Institute            --
-- This file is part of the GNU Sather package. It is free software; you may --
-- redistribute  and/or modify it under the terms of the  GNU General Public --
-- License (GPL)  as  published  by the  Free  Software  Foundation;  either --
-- version 2 of the license, or (at your option) any later version.          --
-- This  program  is distributed  in the  hope that it will  be  useful, but --
-- WITHOUT ANY WARRANTY without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See Doc/GPL for more details.        --
-- The license text is also available from:  Free Software Foundation, Inc., --
-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA                     --
-------------->  Please email comments to <bug-sather@gnu.org>  <--------------

-- TkCallback.sa: Some types of callbacks
-- Author: Matthias Ernst <mernst@desy.de>
	
abstract class $TKKIT_CB is		-- a sather callback
   id: STR;			-- the callback name

   call_from_tcl(argv: ARRAY{STR}): TUP{INT, STR}; -- only call from TCL

   -- gives a TCL statement to call this callback
   -- useful for bindings:
   -- thisbox.bind_command("<B1>", thiscb.call_str(void))
   -- or direct calls
   call_str(argv: ARRAY{STR}): STR;
end;

-------------------------------------------------------------------

class STD_TKKIT_CB is
   readonly attr id: STR;

   call_str(argv: ARRAY{STR}): STR is
      res ::= "tkk" + "it_cb " + id; -- this clashes with c_interface.c::tkkit_cb

      loop
	 res := res + " " + argv.elt!
      end;

      return res;
   end;
end; -- class STD_TKKIT_CB

-------------------------------------------------------------------

class TKKIT_CB_ARGS_RES < $TKKIT_CB is		-- a callback with arguments
   include STD_TKKIT_CB;

   private attr rout: ROUT{ARRAY{STR}}: TUP{INT, STR};

   create(the_id: STR, rout: ROUT{ARRAY{STR}}: TUP{INT, STR}): SAME is
      c ::= new;

      c.id := the_id;
      c.rout := rout;

      return c;
   end;
   
   call_from_tcl(argv: ARRAY{STR}): TUP{INT, STR} is
      return rout.call(argv);
   end;
end; -- class TKKIT_ARGS_RES_CB

-------------------------------------------------------------------
class TKKIT_CB_RES < $TKKIT_CB is	-- a callback without arguments
   include STD_TKKIT_CB;

   private attr rout: ROUT: TUP{INT, STR};

   create(the_id: STR, rout: ROUT: TUP{INT, STR}): SAME is
      c ::= new;

      c.id := the_id;
      c.rout := rout;

      return c;
   end;

   call_from_tcl(argv: ARRAY{STR}): TUP{INT, STR} is
      if argv.size /= 0 then
	 return #(TCL_TK::Error, "Callback doesn't take arguments");
      else
	 return rout.call;
      end;
   end;
end; -- class TKKIT_RES_CB

-------------------------------------------------------------------

class TKKIT_CB_ARGS < $TKKIT_CB is
   include STD_TKKIT_CB;

   private attr rout: ROUT{ARRAY{STR}};

   create(the_id: STR, rout: ROUT{ARRAY{STR}}): SAME is
      c ::= new;

      c.id := the_id;
      c.rout := rout;

      return c;
   end;

   call_from_tcl(argv: ARRAY{STR}): TUP{INT, STR} is
      rout.call(argv);
      return #(TCL_TK::Ok, "");
   end;
end; -- class TKKIT_CB_ARGS < $TKKIT_CB

-------------------------------------------------------------------

class TKKIT_CB < $TKKIT_CB is	-- a callback without args or result
   include STD_TKKIT_CB;

   private attr rout: ROUT;

   create(the_id: STR, rout: ROUT): SAME is
      c ::= new;

      c.id := the_id;
      c.rout := rout;

      return c;
   end;

   call_from_tcl(argv: ARRAY{STR}): TUP{INT, STR} is
      if argv.size /= 0 then
	 return #(TCL_TK::Error, "Callback doesn't take arguments");
      else
	 rout.call;
	 return #(TCL_TK::Ok, "");
      end;
   end;
end; -- class TKKIT_CB < $TKKIT_CB

-------------------------------------------------------------------

