[m-rev.] for review: changes to tcl/tk binding

[Julien Fischer]

Estimated hours taken: 4.5.
Branches: main.

The tcl/tk binding was failing to compile because it was trying
to #include mtcltk.h.  This diff fixes that and also updates things
to use the new foreign language interface.

extras/graphics/mercury_tcltk/Mercury.options:
	New file. When compiling mercury_tcltk.m do not issue warning
	messages about the file not exporting anything.

extras/graphics/mercury_tcltk/Mmakefile:
	Add a comment about tk header files and how it may be necessary
	on some Linux systems to tell the compiler where they are.

extras/graphics/mercury_tcltk/mtcltk.m:
extras/graphics/mercury/tcltk/mtk.m:
	Add some missing MR_* prefixes.
	Use pragma foreign_proc, foreign_code etc instead of pragma c_code.


Index: Mercury.options
===================================================================
RCS file: Mercury.options
diff -N Mercury.options
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ Mercury.options	25 Jul 2003 15:52:58 -0000
@@ -0,0 +1 @@
+MCFLAGS-mercury_tcltk=--no-warn-nothing-exported
Index: Mmakefile
===================================================================
RCS file: /home/mercury1/repository/mercury/extras/graphics/mercury_tcltk/Mmakefile,v
retrieving revision 1.2
diff -u -r1.2 Mmakefile
--- Mmakefile	16 Jul 2001 10:21:44 -0000	1.2
+++ Mmakefile	1 Aug 2003 07:08:58 -0000
@@ -1,10 +1,16 @@

+include Mercury.options
+
 # You may need to modify the line below

 MLLIBS    = -ltk8.0 -ltcl8.0 -L/usr/X11R6/lib -lX11 -lXmu -lXext -lm -ldl \
    	    -lXt -lICE -lSM

 MLFLAGS	  = -R/usr/X11R6/lib
+
+# On some Linux machines you may need to let mgnuc know where the
+# tcl/tk header files are.
+# EXTRA_CFLAGS = -I/usr/include/tcl8.0

 LIBRARY = libmercury_tcltk

Index: mtcltk.m
===================================================================
RCS file: /home/mercury1/repository/mercury/extras/graphics/mercury_tcltk/mtcltk.m,v
retrieving revision 1.6
diff -u -r1.6 mtcltk.m
--- mtcltk.m	13 Feb 2002 09:56:27 -0000	1.6
+++ mtcltk.m	1 Aug 2003 06:57:54 -0000
@@ -85,7 +85,7 @@

 :- type tcl_interp == c_pointer.

-:- pragma c_header_code("
+:- pragma foreign_decl("C", "
 /*
  * tkAppInit.c --
  *
@@ -102,7 +102,6 @@
  */

 #include ""tk.h""
-#include ""mtcltk.h""
 ").


@@ -111,22 +110,23 @@
  * Sun shared libraries to be used for Tcl.
  */

-:- pragma c_code("
-extern int matherr(void);
-int *tclDummyMathPtr = (int *) matherr;
+:- pragma foreign_code("C", "
+	extern int matherr(void);
+	int *tclDummyMathPtr = (int *) matherr;
 ").

-:- pragma c_header_code("
+:- pragma foreign_decl("C", "
 	extern MR_Word mtcltk_mercury_initializer;
 	char *mtcltk_strdup(const char *str);
 ").

-:- pragma c_code("
-	Word mtcltk_mercury_initializer;
+:- pragma foreign_code("C", "
+	MR_Word mtcltk_mercury_initializer;
 ").

-:- pragma c_code(mtcltk__main(Closure::pred(in, di, uo) is det, Args::in,
-		IO0::di, IO::uo), may_call_mercury, "
+:- pragma foreign_proc("C", mtcltk__main(Closure::pred(in, di, uo) is det,
+		Args::in, IO0::di, IO::uo),
+	[may_call_mercury, promise_pure], "
 {
     MR_Word l;
     int     argc, i;
@@ -138,7 +138,7 @@
     argc = 0;
     for(l = Args; l != MR_list_empty(); l = MR_list_tail(l))
 	argc++;
-    MR_incr_hp(MR_LVALUE_CAST(Word, argv), argc + 1);
+    MR_incr_hp(MR_LVALUE_CAST(MR_Word, argv), argc + 1);

     for(i = 0, l = Args; l != list_empty(); l = list_tail(l), i++)
 	argv[i] = (char *) MR_list_head(l);
@@ -160,7 +160,7 @@
 :- pragma export(call_mercury_initializer(pred(in, di, uo) is det, in, di, uo),
 		"mtcltk_call_mercury_initializer").

-:- pragma c_code("
+:- pragma foreign_code("C", "
 /*
  *----------------------------------------------------------------------
  *
@@ -193,7 +193,8 @@
     }
     Tcl_StaticPackage(interp, tk_str, Tk_Init, (Tcl_PackageInitProc *) NULL);

-    mtcltk_call_mercury_initializer(mtcltk_mercury_initializer, (Word)interp);
+    mtcltk_call_mercury_initializer(mtcltk_mercury_initializer,
+    		(MR_Word)interp);

     return TCL_OK;
 }
@@ -201,8 +202,9 @@

 	% XXX Had to change Status to RStatus because using Status
 	% resulted in *parse errors* in gcc :-(
-:- pragma c_code(eval(Interp::in, Cmd::in, RStatus::out, Result::out,
-		IO0::di, IO::uo), may_call_mercury, "
+:- pragma foreign_proc("C", eval(Interp::in, Cmd::in, RStatus::out, Result::out,
+		IO0::di, IO::uo),
+	[may_call_mercury, promise_pure], "
 {
 	int err;

@@ -228,17 +230,17 @@
 {
 	MR_Word newstr;

-	assert(str);
+	MR_assert(str);
 	MR_incr_hp_atomic(newstr, (strlen(str) + sizeof(MR_Word))
                 / sizeof(MR_Word));
-	assert(newstr);
+	MR_assert(newstr);
 	strcpy((char *) newstr, str);

 	return (char *) newstr;
 }
 ").

-:- pragma c_header_code("
+:- pragma foreign_decl("C", "
 int mtcltk_do_callback(ClientData clientData, Tcl_Interp *interp,
 		 int argc, char *argv[]);
 ").
@@ -258,7 +260,7 @@
 		in, in, out, out, di, uo),
 		"mtcltk_call_mercury_closure").

-:- pragma c_code("
+:- pragma foreign_code("C", "
 int mtcltk_do_callback(ClientData clientData, Tcl_Interp *interp,
 		 int argc, char *argv[])
 {
@@ -269,7 +271,8 @@
 	/* convert the array of strings into a Mercury list of strings */
 	args = MR_list_empty();
 	for (i = argc - 1; i >= 0; i--) {
-		args = MR_list_cons(mtcltk_strdup(argv[i]), args);
+		args = MR_list_cons((MR_Word) mtcltk_strdup(argv[i]),
+			(MR_Word) args);
 	}

 	mtcltk_call_mercury_closure((MR_Word) clientData, (MR_Word) interp,
@@ -285,17 +288,19 @@
 :- pragma export(tcl_status_ok(in), "mtcltk_tcl_status_ok").
 tcl_status_ok(tcl_ok).

-:- pragma c_code(create_command(Interp::in, Name::in,
-			Closure::pred(in, in, out, out, di, uo) is det,
-			IO0::di, IO::uo), may_call_mercury,
+:- pragma foreign_proc("C", create_command(Interp::in, Name::in,
+		Closure::pred(in, in, out, out, di, uo) is det,
+		IO0::di, IO::uo),
+	[may_call_mercury, promise_pure],
 "{
 	Tcl_CreateCommand((Tcl_Interp *)Interp, Name, mtcltk_do_callback,
 				(ClientData)Closure, NULL);
 	IO = IO0;
 }").

-:- pragma c_code(delete_command(Interp::in, Name::in, Result::out,
-			IO0::di, IO::uo),
+:- pragma foreign_proc("C", delete_command(Interp::in, Name::in, Result::out,
+		IO0::di, IO::uo),
+	[will_not_call_mercury, promise_pure],
 "{
 	int err;
 	err = Tcl_DeleteCommand((Tcl_Interp *)Interp, Name);
@@ -303,7 +308,7 @@
 	IO = IO0;
 }").

-:- pragma c_code("
+:- pragma foreign_code("C", "

 #ifdef MR_CONSERVATIVE_GC

@@ -344,4 +349,5 @@
 ").

 %-----------------------------------------------------------------------------%
+:- end_module mtcltk.
 %-----------------------------------------------------------------------------%
Index: mtk.m
===================================================================
RCS file: /home/mercury1/repository/mercury/extras/graphics/mercury_tcltk/mtk.m,v
retrieving revision 1.4
diff -u -r1.4 mtk.m
--- mtk.m	16 Jul 2001 10:21:44 -0000	1.4
+++ mtk.m	31 Jul 2003 06:11:40 -0000
@@ -1662,25 +1662,30 @@
 command_wrapper(Closure, Interp, _Args, tcl_ok, "") -->
 	call(Closure, Interp).

-:- pragma c_header_code("
+:- pragma foreign_decl("C", "
 	extern MR_Integer	tk_direct_thingy_counter;
 ").

-:- pragma c_code("
+:- pragma foreign_code("C", "
 	MR_Integer	tk_direct_thingy_counter = 0;
 ").

 :- pred get_thingy_counter(int::out, io__state::di, io__state::uo) is det.

-:- pragma c_code(get_thingy_counter(Int::out, IO0::di, IO::uo), "
+:- pragma foreign_proc("C", get_thingy_counter(Int::out, IO0::di, IO::uo),
+	[will_not_call_mercury, promise_pure], "
 	Int = tk_direct_thingy_counter;
 	IO = IO0;
 ").

 :- pred set_thingy_counter(int::in, io__state::di, io__state::uo) is det.

-:- pragma c_code(set_thingy_counter(Int::in, IO0::di, IO::uo), "
+:- pragma foreign_proc("C", set_thingy_counter(Int::in, IO0::di, IO::uo),
+	[will_not_call_mercury, promise_pure], "
 	tk_direct_thingy_counter = Int;
 	IO = IO0;
 ").

+%-----------------------------------------------------------------------------%
+:- 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
--------------------------------------------------------------------------