Hi folks,
I tried to compile the following program with both ghc-3.02 and ghc-4.02
(pathlevel 1), using the linux glibc binary releases. The 3.02 one works
fine but the code produced by 4.02 segmentation faults when I try to run
it.
It uses a c program, which links to code in tcl-tk v8.0. I've included
the tclhaskell.c and tclhaskell.h files at the end of this mail.
I compiled with
gcc -c -I/usr/local/opt/include -I/usr/local/opt/include
-I/usr/X11/include tclhaskell.c
ghc-4.02 -O -fvia-C -fglasgow-exts -c '-#include "tclhaskell.h"' Main.hs
ghc-4.02 -O -fvia-C -fglasgow-exts -ltk8.0 -ltcl8.0 -lX11 -lm -lc -ldl
-L/usr/local/opt/lib -L/usr/local/opt/lib -L/usr/X11/lib -L/usr/lib
-L/lib -o main Main.o tclhaskell.o
and similarly for ghc-3.02
Thanks
Meurig
--- Main.hs
-----------------------------------------------------------------
module Main where
main :: IO ()
main = do
primInitTcl
primExecuteTcl_ "button .b -text ben"
primExecuteTcl_ "pack .b"
loop
where
loop = do
still <- primRunTcl
if still then loop
else return ()
primInitTcl :: IO Bool
primInitTcl = map' int2bool $ _ccall_ primInitTcl
primExecuteTcl_ :: String -> IO ()
primExecuteTcl_ s = _ccall_ primExecuteTcl_ s
primRunTcl :: IO Bool
primRunTcl = map' int2bool (_ccall_ primRunTcl)
map' :: (a -> b) -> IO a -> IO b
map' f io = do
x <- io
return $ f x
int2bool :: Int -> Bool
int2bool 0 = False
int2bool n = True
-- tclhaskell.h
--------------------------------------------------------------
void primPutEnv (char *str);
void primTclDebug(int flg);
int primInitTcl(void);
int primRunTcl(void);
char *primExecuteTcl(char *cmd);
void primExecuteTcl_ (char *cmd);
char *primGetEvent(void);
void primSetVar(char * varname,char * inp);
-- tclhaskell.c -----------------------------------------------
/* ------------------------------------------------------------
* tclhaskell.c --
*
* Based on tkgofer.c from the TkGofer distribution.
* Changes by Chris Dornan ([EMAIL PROTECTED]).
*
* This file contains the interface for the "haskell-tcl" link.
* It is based on tkMain.c - the main program of wish.
*
* It supports a new tcl-command
* - haskell_event n : to write the string n into the event buffer
*
* The provided gofer primitives are
* - primInitTcl : to initialze tcl/tk, returns 1 if successful
* - primRunTcl : to start the eventloop of tcl/tk
* - primExecuteTcl : to evaluate an event by the tcl
interpreter
* - primGetEvent : to read the event buffer
* buffer contains event identification
* plus bind arguments
* - primSetVar : write user output into tcl variables
*
------------------------------------------------------------ */
#include <stdio.h>
#include <stdlib.h>
#include <tcl.h>
#include <tk.h>
#include <sys/types.h>
#include <sys/stat.h>
#include <unistd.h>
#include "tclhaskell.h"
void primPutEnv(char *str)
{
char *cpy = malloc(strlen(str)+1);
if (str!=NULL) {
strcpy(cpy,str);
putenv(cpy);
}
}
/* ------------------------------------------------------------
* Declaration for debug information
------------------------------------------------------------ */
Bool tcl_debug=0; /* TRUE => show debug information */
/* ------------------------------------------------------------
* Declaration for window and interpreter variables
------------------------------------------------------------ */
static Tcl_Interp *interp; /* Interpreter for this application.
*/
#define BUFFER_SIZE 2000 /* Buffers for communication
Contains identifier and
bind arguments
*/
#define QUEUE_SLOTS 20 /* The number of slots in the
buffer */
int queue_head, queue_tail, queue_full; /* The head, tail and full flag
of
the event queue, organised as a
cyclic buffer
*/
static char event_buffer[BUFFER_SIZE]; /* the event buffer */
/* ------------------------------------------------------------
* Reporting Errors
------------------------------------------------------------ */
tkh_error(char *message)
{
fprintf(stderr, "TclHaskell: %s\n", message);
}
tkh_abort(char *message)
{
tkh_error(message);
abort();
}
/* ------------------------------------------------------------
* Buffer manipulation functions
------------------------------------------------------------ */
static int slot_size(void)
{
return (BUFFER_SIZE/QUEUE_SLOTS);
}
static int slot_base(int i)
{
return (i*slot_size());
}
static void inc_index(int *i)
{
*i= (*i+1) % QUEUE_SLOTS;
}
static int init_queue(void)
{
queue_head= queue_tail= queue_full= 0;
}
static int queue_empty(void)
{
return (!queue_full && queue_head==queue_tail);
}
static void enqueue(char *str)
{
if (str[0]==0) {
tkh_error("empty event string");
return;
}
if (strlen(str)+1>slot_size()) {
tkh_error("event string too large");
return;
}
if (queue_full) {
tkh_error("event buffer overrun");
return;
}
strcpy(event_buffer+slot_base(queue_tail), str);
inc_index(&queue_tail);
if (queue_head==queue_tail)
queue_full= 1;
}
static char *dequeue(void)
{
char *item = event_buffer+slot_base(queue_head);
if (queue_empty())
tkh_abort("empty queue");
inc_index(&queue_head);
queue_full= 0;
return item;
}
/* ------------------------------------------------------------
* haskellEventCmd:
* (Registered as a new Tcl command: see initTcl, below.)
*
* This is used as part of the callback mechanism: it inserts
* argument string into the TclHaskell event queue, triggering
* primRunTcl to break its loop so that TclHaskell can retrieve
* the event descriptor woth primGetEvent.
------------------------------------------------------------ */
static int haskellEventCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
char **argv; /* Argument strings. */
{
if (tcl_debug) {
fprintf(stderr, "[Queueing Event: %s]\n", argv[1]);
}
/* ignore surplus arguments as passed to scale commands, for example
*/
if (argc<2){
Tcl_AppendResult(interp,
"haskellEvent: should have at least 1 argument",
(char *) NULL);
return TCL_ERROR;
}
enqueue(argv[1]);
return TCL_OK;
}
/* ------------------------------------------------------------
* Implementation of Haskell Primitives
------------------------------------------------------------ */
/* ------------------------------------------------------------
* primTclDebug:
* sets the debug flag
------------------------------------------------------------ */
void primTclDebug (int flg)
{
tcl_debug = flg;
}
/* ------------------------------------------------------------
* primInitTcl:
* initializes Tcl/Tk,
* and the new new command `haskellEvent',
* return 1 if successful, 0 otherwise.
------------------------------------------------------------ */
int primInitTcl (void) {
if (tcl_debug) {
fprintf(stderr, "[Initialize Tcl]\n");
}
init_queue(); /* Reset commuication buffers */
interp = Tcl_CreateInterp();
Tcl_SetVar(interp, "tcl_interactive", "0", TCL_GLOBAL_ONLY);
if (Tcl_Init(interp) == TCL_ERROR) {
fprintf(stderr, "%s\n", interp->result);
return(0);
}
if (Tk_Init(interp) == TCL_ERROR) {
fprintf(stderr, "%s\n", interp->result);
return(0);
}
/* Extensions for tcl: */
Tcl_CreateCommand(interp, "haskellEvent", haskellEventCmd,
(ClientData) NULL, (void (*)()) NULL);
return(1);
}
/* ------------------------------------------------------------
* primRunTcl:
* runs Tcl's event loop until one or more events
* are queued for Haskell processing, returning 1
* if `.' has been destroyed, 0 otherwise.
------------------------------------------------------------ */
int primRunTcl (void) {
if (tcl_debug) {
fprintf(stderr, "[TclHaskell is waiting for an event...]\n");
}
while ((Tk_GetNumMainWindows() > 0) && (queue_empty())) {
Tk_DoOneEvent(0);
}
return (Tk_GetNumMainWindows() > 0);
}
/* ------------------------------------------------------------
* primExecuteTcl:
* perform Tcl command and return result to TclHaskell
------------------------------------------------------------ */
static char *executeTcl (char *cmd);
char *primExecuteTcl (char *cmd)
{
char *result;
result= executeTcl(cmd);
if (tcl_debug) fprintf(stderr, " %s <- %s\n", result, cmd);
return result;
}
void primExecuteTcl_ (char *cmd)
{
(void) executeTcl(cmd);
if (tcl_debug) fprintf(stderr, " %s\n", cmd);
}
static char *executeTcl (char *cmd)
{
if (Tcl_Eval(interp,cmd) != TCL_OK) {
fprintf(stderr, "Tk/Tcl: %s\n", interp->result);
return ("");
}
return (interp -> result);
}
/* ------------------------------------------------------------
* primGetEvent:
* return the event buffer to gofer
------------------------------------------------------------ */
char *primGetEvent(void) {
if (queue_empty())
return ("");
else {
char *item = dequeue();
if (tcl_debug) {
fprintf (stderr, "[Processing event %s]\n", item);
}
return(item);
}
}
/* ------------------------------------------------------------
* primSetVar:
* write user output in tcl variable
* in this way, special tcl characters
* like [, $, } etc. are irrelevant for tcl.
------------------------------------------------------------ */
void primSetVar(char *varname, char *inp)
{
if (tcl_debug) {
fprintf(stderr, "set %s %s\n", varname, inp);
}
Tcl_SetVar(interp, varname, inp, TCL_GLOBAL_ONLY);
}
--
Meurig Sage
Dept of Computing Science
University of Glasgow
http://www.dcs.gla.ac.uk/~meurig
mailto:[EMAIL PROTECTED]
