[m-rev.] Add an IL backend to Mercury Tcl/Tk

[Jonathan Morgan]

Estimated hours taken: 8
Branches: main

Add an IL backend to Mercury Tcl/Tk using TickleSharp.

extras/graphics/mercury_tcltk/Mmakefile:
        Add instructions to build the library in the IL grade.
extras/graphics/mercury_tcltk/README:
        Add a URL for TickleSharp.
extras/graphics/mercury_tcltk/mtcltk.m
        Implement the entire interface with C# code referencing TickleSharp.
extras/graphics/mercury_tcltk/mtk.m
        Add C# foreign code for getting and setting the Tk counter.

Jon

Index: Mmakefile
===================================================================
RCS file: /home/mercury1/repository/mercury/extras/graphics/mercury_tcltk/Mmakefile,v
retrieving revision 1.5
diff -u -r1.5 Mmakefile
--- Mmakefile	15 Aug 2005 04:11:42 -0000	1.5
+++ Mmakefile	27 Mar 2006 05:31:38 -0000
@@ -17,6 +17,14 @@
 # tcl/tk header files are.
 # EXTRA_CFLAGS = -I/usr/include/tcl8.0

+# If you are using the IL backend, you need to let csc know where the
+# TickleSharp assembly is.
+
+TICKLESHARP_DIR =
+
+LIB_MS_CSCFLAGS	= /lib:`$(FIX_PATH_FOR_CSC) $(TICKLESHARP_DIR)` \
+	/r:TickleSharp.dll
+
 LIBRARY = libmercury_tcltk

 MAIN_TARGET = $(LIBRARY)
Index: README
===================================================================
RCS file: /home/mercury1/repository/mercury/extras/graphics/mercury_tcltk/README,v
retrieving revision 1.2
diff -u -r1.2 README
--- README	15 Aug 2005 04:11:42 -0000	1.2
+++ README	27 Mar 2006 05:31:38 -0000
@@ -2,6 +2,8 @@
 binding for Tcl/Tk. You will need the Mercury compiler to build
 it (see <http://www.cs.mu.oz.au/mercury> to find out more about Mercury).
 You will also need Tcl/Tk 4.0 or later installed on your system.
+If you wish to use the IL backend, you will also need TickleSharp (see
+<http://forge.novell.com/modules/xfmod/project/?ticklesharp>).

 It contains the following modules:
 	mtcltk.m        - a binding to Tcl/Tk (Tk 4.0 or later)
Index: mtcltk.m
===================================================================
RCS file: /home/mercury1/repository/mercury/extras/graphics/mercury_tcltk/mtcltk.m,v
retrieving revision 1.9
diff -u -r1.9 mtcltk.m
--- mtcltk.m	15 Aug 2005 04:11:42 -0000	1.9
+++ mtcltk.m	27 Mar 2006 05:31:38 -0000
@@ -5,7 +5,7 @@
 %-----------------------------------------------------------------------------%
 %
 % mtcltk -- the Mercury interface to Tk/Tcl
-% authors: conway, fjh
+% authors: conway, fjh, Jonathan Morgan (IL backend only)
 % Stability: medium.
 %
 % See the file "HOWTO" for instructions on how to link with
@@ -82,6 +82,8 @@

 :- pragma foreign_type("C", tcl_interp, "Tcl_Interp *").

+:- pragma foreign_type("IL", tcl_interp, "class [TickleSharp]TickleSharp.Tk").
+
 :- pragma foreign_decl("C", "
 /*
 ** tkAppInit.c --
@@ -105,6 +107,13 @@
 #endif
 ").

+:- pragma foreign_decl("C#","
+using TickleSharp;
+using tcl_status = mtcltk.tcl_status_0;
+using tcl_ok = mtcltk.tcl_status_0.tcl_ok_0;
+using tcl_error = mtcltk.tcl_status_0.tcl_error_0;
+").
+
 /*
 ** The following variable is a special hack that is needed in order for
 ** Sun shared libraries to be used for Tcl.
@@ -155,6 +164,17 @@
 	IO = IO0;
 }").

+:- pragma foreign_proc("C#",
+	mtcltk__main(Closure::pred(in, di, uo) is det, Args::in,
+		_IO0::di, _IO::uo),
+	[may_call_mercury, promise_pure],
+"
+	// Command line arguments are not used in TickleSharp.
+	Tk Tk = new Tk();
+	mtcltk.mercury_code.mtcltk_call_mercury_initializer(Closure, Tk);
+	Tk.Run();
+").
+
 :- pragma export(call_mercury_initializer(pred(in, di, uo) is det, in, di, uo),
 	"mtcltk_call_mercury_initializer").
 :- pred call_mercury_initializer(
@@ -223,6 +243,26 @@
 	IO = IO0;
 }
 ").
+:- pragma foreign_proc("C#",
+	eval(Tk::in, Cmd::in, Status::out, Result::out, _IO0::di, _IO::uo),
+	[may_call_mercury, promise_pure],
+"
+	int err = Tk.Eval(Cmd);
+	
+	switch (err) {
+		case 0:
+			Status = new tcl_ok();
+			break;
+		case 1:
+			Status = new tcl_error();
+			break;
+		default:
+			mercury.runtime.Errors.fatal_error(""Tcl_Eval returned neither "" +
+					""TCL_OK or TCL_ERROR"");
+			break;
+	}
+	Result = Tk.Result;
+").

 :- pragma foreign_code("C", "
 char *mtcltk_strdup(const char *str)
@@ -275,10 +315,47 @@
 /*
 	fprintf(stderr, ""mercury result: `%s'\n"", interp->result);
 */
-	return (mtcltk_tcl_status_ok(status) ? TCL_OK : TCL_ERROR);
+    return (mtcltk_tcl_status_ok(status) ? TCL_OK : TCL_ERROR);
 }
 ").

+:- pragma foreign_code("C#", "
+
+private class mtcltk_callback	{
+	Tk tk;
+	System.Object[] Closure;
+	System.String command;
+	public mtcltk_callback(System.Object[] closure,
+            System.String str, Tk Tk)	{
+		Closure = closure;
+		command = str;
+        tk = Tk;
+		tk.CreateCommand (str, new TclTkInterface.Tcl_CmdProc
+				(mtcltk_do_callback));
+	}
+
+	public int mtcltk_do_callback(int ArrayInst)	{
+		tcl_status status = new tcl_ok();
+		System.String result = """";
+		System.String Argv = tk.GetArgArray(command, ArrayInst);
+		int argc = int.Parse(tk.GetParam(Argv,0));
+		mercury.list.list_1 args;
+		int i;
+
+		args = mercury.list.mercury_code.ML_empty_list(null);
+		for (i = argc; i > 0; i--) {
+			args = mercury.list.mercury_code.ML_cons(null,
+					tk.GetParam(Argv, i), args);
+		}
+
+		mtcltk.mercury_code.mtcltk_call_mercury_closure(Closure, tk,
+				args, ref status, ref result);
+		tk.SetTclResult(result);
+		tk.FreeArgArray(Argv);
+		return (mtcltk.mercury_code.mtcltk_tcl_status_ok(status) ? 0 : 1);
+	}
+}
+").
 :- pragma export(tcl_status_ok(in), "mtcltk_tcl_status_ok").
 :- pred tcl_status_ok(tcl_status::in) is semidet.
 tcl_status_ok(tcl_ok).
@@ -294,6 +371,15 @@
 	IO = IO0;
 }").

+:- pragma foreign_proc("C#",
+	create_command(Tk::in, Name::in,
+		Closure::pred(in, in, out, out, di, uo) is det,
+		_IO0::di, _IO::uo),
+	[may_call_mercury, promise_pure],
+"
+	mtcltk_callback callback = new mtcltk_callback(Closure, Name, Tk);
+").
+
 :- pragma foreign_proc("C",
 	delete_command(Interp::in, Name::in, Result::out, IO0::di, IO::uo),
 	[will_not_call_mercury, promise_pure],
@@ -303,6 +389,14 @@
 	Result = (err == 0 ? 0 : 1);
 	IO = IO0;
 }").
+
+:- pragma foreign_proc("C#",
+	delete_command(_Tk::in, _Name::in, Result::out, _IO0::di, _IO::uo),
+	[will_not_call_mercury, promise_pure],
+"
+	// Tcl_DeleteCommand is not bound by TickleSharp, and is unused.
+	Result = new tcl_ok();
+").

 :- pragma foreign_code("C", "

Index: mtk.m
===================================================================
RCS file: /home/mercury1/repository/mercury/extras/graphics/mercury_tcltk/mtk.m,v
retrieving revision 1.7
diff -u -r1.7 mtk.m
--- mtk.m	15 Aug 2005 04:11:42 -0000	1.7
+++ mtk.m	27 Mar 2006 05:31:38 -0000
@@ -1675,6 +1675,22 @@
 	IO = IO0;
 ").

+:- pragma foreign_code("C#", "
+	static int tk_direct_thingy_counter = 0;
+").
+
+:- pragma foreign_proc("C#", get_thingy_counter(Int::out, _IO0::di, _IO::uo),
+	[will_not_call_mercury, promise_pure],
+"
+	Int = tk_direct_thingy_counter;
+").
+
+:- pragma foreign_proc("C#", set_thingy_counter(Int::in, _IO0::di, _IO::uo),
+	[will_not_call_mercury, promise_pure],
+"
+	tk_direct_thingy_counter = Int;
+").
+
 %-----------------------------------------------------------------------------%
 :- end_module mtk.
%-----------------------------------------------------------------------------%

--------------------------------------------------------------------------
mercury-reviews mailing list
post:  mercury-reviews at cs.mu.oz.au
administrative address: owner-mercury-reviews at cs.mu.oz.au
unsubscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: unsubscribe
subscribe:   Address: mercury-reviews-request at cs.mu.oz.au Message: subscribe
--------------------------------------------------------------------------