[m-rev.] diff: minor fixes for Tcl/Tk binding

[Julien Fischer]

Estimated hours taken: 0.2
Branches: main, release

extras/graphics/mercury_tcltk/mtcltk.m:
 	Avoid a warning from the C compiler cause by a missing const
 	qualifier.

 	Convert this module to 4-space indentation and make a few
 	other minor formatting changes to bring into line with
 	our current coding standard.

Julien.

Index: mtcltk.m
===================================================================
RCS file: /home/mercury1/repository/mercury/extras/graphics/mercury_tcltk/mtcltk.m,v
retrieving revision 1.10
diff -u -b -r1.10 mtcltk.m
--- mtcltk.m	21 Apr 2006 05:24:29 -0000	1.10
+++ mtcltk.m	26 Jul 2006 07:41:57 -0000
@@ -1,23 +1,30 @@
  %-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
  % Copyright (C) 1997-1998,2000, 2003, 2005-2006 The University of Melbourne.
  % This file may only be copied under the terms of the GNU Library General
  % Public License - see the file COPYING.LIB in the Mercury distribution.
  %-----------------------------------------------------------------------------%
  %
-% mtcltk -- the Mercury interface to Tk/Tcl
-% authors: conway, fjh
+% File: mtcltk.m.
+% Authors: conway, fjh.
  % Stability: medium.
  %
-% See the file "HOWTO" for instructions on how to link with
-% this library.
+% A Mercury interface to Tcl/Tk.
+%
+% See the file "HOWTO" for instructions on how to link with this library.
  %
  %-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%

  :- module mtcltk.
  :- interface.

  :- import_module io.
-:- import_module list, string.
+:- import_module list.
+:- import_module string.
+
+%-----------------------------------------------------------------------------%

  	% The tcl_interp type is an abstract data type that
  	% represents a Tcl interpreter.
@@ -27,12 +34,14 @@
  	% The tcl_status type is the type that is returned by tcl
  	% commands to indicate whether or not they were successful.
  	%
-:- type tcl_status ---> tcl_ok ; tcl_error.
+:- type tcl_status
+    --->    tcl_ok
+    ;       tcl_error.

  	% mtcltk.main(Callback, Args):
  	%	first initializes a Tcl interpreter `Interp' using `Args';
  	%		the first `Arg' should be the program name (which you
-	%		can obtain using io__progname), and the remainder
+    %       can obtain using io.progname), and the remainder
  	%		are arguments that are passed to Interp
  	%	then invokes `Callback' with `Interp', which you can use to
  	%		add your own Tcl commands and/or to invoke Tk commands
@@ -41,7 +50,7 @@
  :- pred mtcltk.main(pred(tcl_interp, io, io)::(pred(in, di, uo) is det),
  	list(string)::in, io::di, io::uo) is det.

-	% mtcltk__eval(Interp, Command, Status, Result):
+    % mtcltk.eval(Interp, Command, Status, Result):
  	%	evaluates `Command' in `Interp'.
  	%	if successful, returns `Status = tcl_ok'
  	%	and binds `Result' to the return string,
@@ -51,7 +60,7 @@
  :- pred mtcltk.eval(tcl_interp::in, string::in, tcl_status::out, string::out,
  	io::di, io::uo) is det.

-	% mtcltk__create_command(Interp, Name, Command):
+    % mtcltk.create_command(Interp, Name, Command).
  	%	creates a new Tcl command called `Name' in `Interp'.
  	%	Whenever `Name' is evaluated as a Tcl command in `Interp',
  	%	the Tcl interpreter will use
@@ -68,9 +77,10 @@
  	pred(tcl_interp, list(string), tcl_status, string, io, io)
  	::(pred(in, in, out, out, di, uo) is det), io::di, io::uo) is det.

-	% mtcltk.delete_command(Interp, Name, Result):
-	%	deletes the Tcl/Tk command called `Name' in `Interp'
-	%	and returns `Result'.
+    % mtcltk.delete_command(Interp, Name, Result).
+    % 
+    % Deletes the Tcl/Tk command called in `Name' in `Interp' and
+    % returns `Result'.
  	%
  :- pred mtcltk.delete_command(tcl_interp::in, string::in, tcl_status::out,
  	io::di, io::uo) is det.
@@ -117,7 +127,7 @@

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

  :- pragma foreign_code("C", "
@@ -125,8 +135,7 @@
  ").

  :- pragma foreign_proc("C",
-	mtcltk__main(Closure::pred(in, di, uo) is det, Args::in,
-		IO0::di, IO::uo), 
+    mtcltk.main(Closure::pred(in, di, uo) is det, Args::in, IO0::di, IO::uo),
  	[may_call_mercury, promise_pure], "
  {
  	MR_Word l;
@@ -135,7 +144,7 @@
  	MR_Word argv_word;

  	/*
-	** convert arguments from a list of strings to an array of strings
+    ** Convert arguments from a list of strings to an array of strings.
  	*/
  	argc = 0;
  	for (l = Args; l != MR_list_empty(); l = MR_list_tail(l)) {
@@ -162,7 +171,8 @@
  :- pred call_mercury_initializer(
  	pred(tcl_interp, io, io)::(pred(in, di, uo) is det),
  	tcl_interp::in, io::di, io::uo) is det.
-call_mercury_initializer(Closure, Interp, !IO) :- Closure(Interp, !IO).
+call_mercury_initializer(Closure, Interp, !IO) :-
+    Closure(Interp, !IO).

  :- pragma foreign_code("C", "
  /*
@@ -205,29 +215,32 @@
  	% resulted in *parse errors* in gcc :-(
  :- pragma foreign_proc("C",
  	eval(Interp::in, Cmd::in, RStatus::out, Result::out, IO0::di, IO::uo), 
-	[may_call_mercury, promise_pure], "
-{
+    [may_call_mercury, promise_pure],
+"
  	int err;

  	err = Tcl_Eval(Interp, (char *)Cmd);
+
  	switch (err) {
  		case TCL_OK:
  			RStatus = 0;
  			break;
+
  		case TCL_ERROR:
  			RStatus = 1;
  			break;
+
  		default:
-			MR_fatal_error(""Tcl_Eval returned neither ""
-					""TCL_OK or TCL_ERROR"");
+            MR_fatal_error(""Tcl_Eval returned neither TCL_OK or TCL_ERROR"");
  	}
+
  	Result = mtcltk_strdup(Interp->result);
  	IO = IO0;
-}
  ").

  :- pragma foreign_code("C", "
-char *mtcltk_strdup(const char *str)
+char *
+mtcltk_strdup(const char *str)
  {
  	MR_Word newstr;

@@ -241,11 +254,6 @@
  }
  ").

-:- pragma foreign_decl("C", "
-int mtcltk_do_callback(ClientData clientData, Tcl_Interp *interp,
-		 int argc, char *argv[]);
-").
-
  :- pragma export(call_mercury_closure(pred(in, in, out, out, di, uo) is det,
  	in, in, out, out, di, uo),
  	"mtcltk_call_mercury_closure").
@@ -257,15 +265,29 @@
  call_mercury_closure(Closure, Interp, Args, Status, Result, !IO) :-
  	Closure(Interp, Args, Status, Result, !IO).

+    % NOTE: CONST is defined in tcl.h.
+    %
+:- pragma foreign_decl("C", "
+
+extern int
+mtcltk_do_callback(ClientData clientData, Tcl_Interp *interp,
+    int argc, CONST char *argv[]);
+
+").
+
  :- pragma foreign_code("C", "
-int mtcltk_do_callback(ClientData clientData, Tcl_Interp *interp,
-		 int argc, char *argv[])
+
+int
+mtcltk_do_callback(ClientData clientData, Tcl_Interp *interp,
+    int argc, CONST char *argv[])
  {
  	MR_Word	status;
  	MR_Word	args;
  	int	i;

-	/* convert the array of strings into a Mercury list of strings */
+    /*
+    ** 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((MR_Word) mtcltk_strdup(argv[i]), 
@@ -279,6 +301,7 @@
  */
  	return (mtcltk_tcl_status_ok(status) ? TCL_OK : TCL_ERROR);
  } 
+
  ").

  :- pragma export(tcl_status_ok(in), "mtcltk_tcl_status_ok").
@@ -290,21 +313,21 @@
  		Closure::pred(in, in, out, out, di, uo) is det,
  		IO0::di, IO::uo),
  	[may_call_mercury, promise_pure],
-"{
+"
  	Tcl_CreateCommand(Interp, Name, mtcltk_do_callback,
  		(ClientData)Closure, NULL);
  	IO = IO0;
-}").
+").

  :- 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(Interp, Name);
  	Result = (err == 0 ? 0 : 1);
  	IO = IO0;
-}").
+").

  :- pragma foreign_code("C", "


--------------------------------------------------------------------------
mercury-reviews mailing list
Post messages to:       mercury-reviews at csse.unimelb.edu.au
Administrative Queries: owner-mercury-reviews at csse.unimelb.edu.au
Subscriptions:          mercury-reviews-request at csse.unimelb.edu.au
--------------------------------------------------------------------------