Mtk enhancement

[Thomas Charles CONWAY]

Oops - I meant to include the new src in the previous message.

Here it is....
-- 
ZZ:wq!
^X^C
Thomas Conway               				      conway at cs.mu.oz.au
AD DEUM ET VINUM	  			      Every sword has two edges.

%-----------------------------------------------------------------------------%
% Copyright (C) 1997 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.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%

% mtk -- the Mercury interface to Tk/Tcl
% authors: conway, fjh
% Stability: medium.

%-----------------------------------------------------------------------------%
%
%	To use the Mercury interface to Tk/Tcl, you will need to
%	link with the Tcl and Tk libraries. To do this, you'll need
%	to add a line like the following to your Mmake file:
%
%	MLLIBS = -ltcl7.5 -ltk4.1
%	and on linux, -ldl
%
%	If Tcl and Tk are installed in places that are not on the
%	default search path for libraries then you'll need to add
%	a -L flag to your MFLAGS to search there. You may also need
%	to add flags to make the executable look in the right places
%	for dynamic libraries. On the Solaris machines at cs.mu.oz.au
%	I had to use the following MLFLAGS to get things going:
%
%	MLFLAGS = -Wl,-R,/usr/local/lib -L/usr/local/lib
%	MLLIBS = -ltcl7.5 -ltk4.1
%
%-----------------------------------------------------------------------------%
:- module mtk.
:- interface.

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

	% The tcl_interp type is an abstract data type that
	% represents a Tcl interpreter.
:- type tcl_interp.

	% 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.

	% mtk: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
	%		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
	%	finally starts the Tk event loop
	%
:- pred mtk:main(pred(tcl_interp, io__state, io__state),
		list(string), io__state, io__state).
:- mode mtk:main(pred(in, di, uo) is det, in, di, uo) is det.

	% mtk:eval(Interp, Command, Status, Result):
	%	evaluates `Command' in `Interp'.
	%	if successful, returns `Status = tcl_ok'
	%	and binds `Result' to the return string,
	%	otherwise returns `Status = tcl_error'
	%	and binds `Result' to the error message.
:- pred mtk:eval(tcl_interp, string, tcl_status, string, io__state, io__state).
:- mode mtk:eval(in, in, out, out, di, uo) is det.

	% mtk: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
	%		`call(Command, Interp, Args, Status, Result)'
	% 	to invoke the Mercury procedure `Command' passing `Interp'
	%	and `Args', which is the list of arguments (including the
	%	command name `Name') passed to the command.  If successful,
	%	`Command' should return `Status = tcl_ok' and a return value
	%	in `Result'.  If an error occurs, `Command' should return
	%	`Status = tcl_error' and should bind `Result' to an
	%	appropriate error message.
:- pred mtk:create_command(tcl_interp, string,
		pred(tcl_interp, list(string), tcl_status, string,
		io__state, io__state),
		io__state, io__state).
:- mode mtk:create_command(in, in, pred(in, in, out, out, di, uo) is det,
		di, uo) is det.

	% mtk:delete_command(Interp, Name, Result):
	%	deletes the Tcl/Tk command called `Name' in `Interp'
	%	and returns `Result'.
:- pred mtk:delete_command(tcl_interp, string, tcl_status,
		io__state, io__state).
:- mode mtk:delete_command(in, in, out, di, uo) is det.

%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%

:- implementation.

:- type tcl_interp == c_pointer.

:- pragma c_header_code("
/* 
 * tkAppInit.c --
 *
 *	Provides a default version of the Tcl_AppInit procedure for
 *	use in wish and similar Tk-based applications.
 *
 * Copyright (c) 1993 The Regents of the University of California.
 * Copyright (c) 1994 Sun Microsystems, Inc.
 *
 * See the file ""license.terms"" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * SCCS: @(#) tkAppInit.c 1.20 96/02/15 18:55:27
 */

#include ""tk.h""
#include ""mtk.h""
").


/*
 * The following variable is a special hack that is needed in order for
 * Sun shared libraries to be used for Tcl.
 */

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

:- pragma c_header_code("
	extern Word mtk_current_io_state;
	extern Word mtk_mercury_initializer;
	char *mtk_strdup(const char *str);
").

:- pragma c_code("
	Word mtk_current_io_state;
	Word mtk_mercury_initializer;
").

:- pragma c_code(mtk:main(Closure::pred(in, di, uo) is det, Args::in,
		IO0::di, IO::uo), may_call_mercury, "
{
    Word l;
    int argc, i;
    char **argv;

    /*
    ** convert arguments from a list of strings to an array of strings
    */
    argc = 0;
    for(l = Args; l != list_empty(); l = list_tail(l))
	argc++;
    incr_hp((Word)argv, argc+1);

    for(i = 0, l = Args; l != list_empty(); l = list_tail(l), i++)
	argv[i] = (char *) list_head(l);
    argv[i] = NULL;

    mtk_mercury_initializer = Closure;

    mtk_current_io_state = IO0;
    Tk_Main(argc, argv, Tcl_AppInit);
    IO = mtk_current_io_state;
}").

:- pred call_mercury_initializer(pred(tcl_interp, io__state, io__state),
		tcl_interp, io__state, io__state).
:- mode call_mercury_initializer(pred(in, di, uo) is det, in, di, uo) is det.

call_mercury_initializer(Closure, Interp) -->
	call(Closure, Interp).

:- pragma export(call_mercury_initializer(pred(in, di, uo) is det, in, di, uo),
		"mtk_call_mercury_initializer").

:- pragma c_code("
/*
 *----------------------------------------------------------------------
 *
 * Tcl_AppInit --
 *
 *	This procedure performs application-specific initialization.
 *	Most applications, especially those that incorporate additional
 *	packages, will have their own version of this procedure.
 *
 * Results:
 *	Returns a standard Tcl completion code, and leaves an error
 *	message in interp->result if an error occurs.
 *
 * Side effects:
 *	Depends on the startup script.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_AppInit(Tcl_Interp *interp)
{
    static char tk_str[] = ""Tk"";
    static char tcl_rcFileName_str[] = ""tcl_rcFileName"";
    static char gwarsrc_str[] = ""~/.gwarsrc"";

    if (Tcl_Init(interp) == TCL_ERROR) {
	return TCL_ERROR;
    }
    if (Tk_Init(interp) == TCL_ERROR) {
	return TCL_ERROR;
    }
    Tcl_StaticPackage(interp, tk_str, Tk_Init, (Tcl_PackageInitProc *) NULL);

    mtk_call_mercury_initializer(mtk_mercury_initializer,
	(Word)interp, mtk_current_io_state, &mtk_current_io_state);

    Tcl_SetVar(interp, tcl_rcFileName_str, gwarsrc_str, TCL_GLOBAL_ONLY);

    return TCL_OK;
}
").

	% 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, "
{
	int err;

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

:- pragma c_code("
char *mtk_strdup(const char *str)
{
	Word newstr;

	assert(str);
	incr_hp_atomic(newstr, (strlen(str)+sizeof(Word))/sizeof(Word));
	assert(newstr);
	strcpy((char *)newstr, str);

	return (char *)newstr;
}
").

:- pragma c_header_code("
int mtk_do_callback(ClientData clientData, Tcl_Interp *interp,
		 int argc, char *argv[]);
").

:- pred call_mercury_closure(
		pred(tcl_interp, list(string), tcl_status, string,
			io__state, io__state),
		tcl_interp, list(string), tcl_status, string,
		io__state, io__state).
:- mode call_mercury_closure(pred(in, in, out, out, di, uo) is det,
		in, in, out, out, di, uo) is det.

call_mercury_closure(Closure, Interp, Args, Status, Result) -->
	call(Closure, Interp, Args, Status, Result).

:- pragma export(call_mercury_closure(pred(in, in, out, out, di, uo) is det,
		in, in, out, out, di, uo),
		"mtk_call_mercury_closure").

:- pragma c_code("
int mtk_do_callback(ClientData clientData, Tcl_Interp *interp,
		 int argc, char *argv[])
{
	Word status;
	Word args;
	int i;

	/* convert the array of strings into a Mercury list of strings */
	args = list_empty();
	for (i = argc - 1; i >= 0; i--) {
		args = list_cons(mtk_strdup(argv[i]), args);
	}

	mtk_call_mercury_closure((Word) clientData, (Word) interp,
		args, &status, &interp->result,
		mtk_current_io_state, &mtk_current_io_state);
/*
	fprintf(stderr, ""mercury result: `%s'\n"", interp->result);
*/
	return (mtk_tcl_status_ok(status) ? TCL_OK : TCL_ERROR);
}  
").

:- pred tcl_status_ok(tcl_status::in) is semidet.
:- pragma export(tcl_status_ok(in), "mtk_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,
"{
	mtk_current_io_state = IO0;
	Tcl_CreateCommand((Tcl_Interp *)Interp, Name, mtk_do_callback,
				(ClientData)Closure, NULL);
	IO = mtk_current_io_state;
}").

:- pragma c_code(delete_command(Interp::in, Name::in, Result::out,
			IO0::di, IO::uo),
"{
	int err;
	mtk_current_io_state = IO0;
	err = Tcl_DeleteCommand((Tcl_Interp *)Interp, Name);
	Result = (err == 0 ? 0 : 1);
	IO = mtk_current_io_state;
}").

:- pragma c_code("

#ifdef CONSERVATIVE_GC

/*
** The addresses of the closures that we pass to Tk
** will be stored by Tk in malloc()'ed memory.
** However, it is essential that these pointers be
** visible to the garbage collector, otherwise it will
** think that the closures are unreferenced and reuse the storage.
** Hence we redefine malloc() and friends to call GC_malloc().
*/

void *malloc(size_t s)
{
	return GC_MALLOC(s);
}

void *calloc(size_t s, size_t n)
{
	void *t;
	t = GC_MALLOC(s*n);
	memset(t, 0, s*n);
	return t;
}

void *realloc(void *ptr, size_t s)
{
	return GC_REALLOC(ptr, s);
}

void free(void *ptr)
{
	GC_FREE(ptr);
}

#endif

").

%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%