diff options
Diffstat (limited to 'otherlibs/labltk/support')
28 files changed, 0 insertions, 2013 deletions
diff --git a/otherlibs/labltk/support/Makefile b/otherlibs/labltk/support/Makefile deleted file mode 100644 index 23a7f4694..000000000 --- a/otherlibs/labltk/support/Makefile +++ /dev/null @@ -1,56 +0,0 @@ -include ../Makefile.config - -all: support.cmo widget.cmo protocol.cmo \ - textvariable.cmo timer.cmo fileevent.cmo \ - liblabltk41.a - -opt: support.cmx widget.cmx protocol.cmx \ - textvariable.cmx timer.cmx fileevent.cmx \ - liblabltk41.a - -COBJS=cltkCaml.o cltkEval.o cltkEvent.o cltkFile.o cltkMain.o \ - cltkMisc.o cltkTimer.o cltkVar.o cltkWait.o - -#CCFLAGS=-ccopt -g $(TKINCLUDES) -CCFLAGS=$(TKINCLUDES) - -liblabltk41.a : $(COBJS) - rm -f liblabltk41.a - ar rc liblabltk41.a $(COBJS) - $(RANLIB) liblabltk41.a - -PUB=fileevent.cmi fileevent.mli \ - protocol.cmi protocol.mli \ - textvariable.cmi textvariable.mli \ - timer.cmi timer.mli \ - widget.cmi widget.mli - -install: liblabltk41.a $(PUB) - if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi - cp $(PUB) $(INSTALLDIR) - cp liblabltk41.a $(INSTALLDIR) - cd $(INSTALLDIR); chmod 644 $(PUB) liblabltk41.a - $(RANLIB) $(INSTALLDIR)/liblabltk41.a - -clean : - rm -f *.cm* *.o *.a - -.SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmo .cmx .mlp .c .o - -.mli.cmi: - $(LABLCOMP) $(COMPFLAGS) $< - -.ml.cmo: - $(LABLCOMP) $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -.c.o: - $(LABLCOMP) $(CCFLAGS) $< - -depend: - $(LABLDEP) *.mli *.ml > .depend - -include .depend diff --git a/otherlibs/labltk/support/camltk.h b/otherlibs/labltk/support/camltk.h deleted file mode 100644 index 176ad8a8b..000000000 --- a/otherlibs/labltk/support/camltk.h +++ /dev/null @@ -1,25 +0,0 @@ -/* cltkEval.c */ -extern Tcl_Interp *cltclinterp; /* The Tcl interpretor */ - -/* copy a Caml string to the C heap. Must be deallocated with stat_free */ -char *string_to_c(); - -/* cltkCaml.c */ -/* pointers to Caml values */ -extern value *tkerror_exn; -extern value *handler_code; -int CamlCBCmd(); -void tk_error(); - -/* cltkMain.c */ -extern int signal_events; -void invoke_pending_caml_signals(); -extern Tk_Window cltk_mainWindow; -extern int cltk_slave_mode; - -/* check that initialisations took place */ -#define CheckInit() if (!cltclinterp) tk_error("Tcl/Tk not initialised") - -#define RCNAME ".camltkrc" -#define CAMLCB "camlcb" - diff --git a/otherlibs/labltk/support/cltkCaml.c b/otherlibs/labltk/support/cltkCaml.c deleted file mode 100644 index bb87ba5bd..000000000 --- a/otherlibs/labltk/support/cltkCaml.c +++ /dev/null @@ -1,70 +0,0 @@ -#include <tcl.h> -#include <tk.h> -#include <caml/mlvalues.h> -#include <caml/callback.h> -#include "camltk.h" - -value * tkerror_exn = NULL; -value * handler_code = NULL; - -/* The Tcl command for evaluating callback in Caml */ -int CamlCBCmd(clientdata, interp, argc, argv) - ClientData clientdata; - Tcl_Interp *interp; - int argc; - char *argv[]; -{ - CheckInit(); - - /* Assumes no result */ - Tcl_SetResult(interp, NULL, NULL); - if (argc >= 2) { - int id; - if (Tcl_GetInt(interp, argv[1], &id) != TCL_OK) - return TCL_ERROR; - callback2(*handler_code,Val_int(id),copy_string_list(argc - 2,&argv[2])); - /* Never fails (Caml would have raised an exception) */ - /* but result may have been set by callback */ - return TCL_OK; - } - else - return TCL_ERROR; -} - -/* Callbacks are always of type _ -> unit, to simplify storage - * But a callback can nevertheless return something (to Tcl) by - * using the following. TCL_VOLATILE ensures that Tcl will make - * a copy of the string - */ -value camltk_return (v) /* ML */ - value v; -{ - CheckInit(); - - Tcl_SetResult(cltclinterp, String_val(v), TCL_VOLATILE); - return Val_unit; -} - -/* Note: raise_with_string WILL copy the error message */ -void tk_error(errmsg) - char *errmsg; -{ - raise_with_string(*tkerror_exn, errmsg); -} - - -/* The initialisation of the C global variables pointing to Caml values - must be made accessible from Caml, so that we are sure that it *always* - takes place during loading of the protocol module - */ - -value camltk_init(v) /* ML */ - value v; -{ - /* Initialize the Caml pointers */ - if (tkerror_exn == NULL) - tkerror_exn = caml_named_value("tkerror"); - if (handler_code == NULL) - handler_code = caml_named_value("camlcb"); - return Val_unit; -} diff --git a/otherlibs/labltk/support/cltkDMain.c b/otherlibs/labltk/support/cltkDMain.c deleted file mode 100644 index 06449faf7..000000000 --- a/otherlibs/labltk/support/cltkDMain.c +++ /dev/null @@ -1,229 +0,0 @@ -#include <unistd.h> -#include <fcntl.h> -#include <tcl.h> -#include <tk.h> -#include "gc.h" -#include "exec.h" -#include "sys.h" -#include "fail.h" -#include "io.h" -#include "mlvalues.h" -#include "memory.h" -#include "camltk.h" - -#ifndef O_BINARY -#define O_BINARY 0 -#endif - - -/* - * Dealing with signals: when a signal handler is defined in Caml, - * the actual execution of the signal handler upon reception of the - * signal is delayed until we are sure we are out of the GC. - * If a signal occurs during the MainLoop, we would have to wait - * the next event for the handler to be invoked. - * The following function will invoke a pending signal handler if any, - * and we put in on a regular timer. - */ - -#define SIGNAL_INTERVAL 300 - -int signal_events = 0; /* do we have a pending timer */ - -void invoke_pending_caml_signals (clientdata) - ClientData clientdata; -{ - signal_events = 0; - enter_blocking_section(); /* triggers signal handling */ - /* Rearm timer */ - Tk_CreateTimerHandler(SIGNAL_INTERVAL, invoke_pending_caml_signals, NULL); - signal_events = 1; - leave_blocking_section(); -} -/* The following is taken from byterun/startup.c */ -header_t atom_table[256]; -code_t start_code; -asize_t code_size; - -static void init_atoms() -{ - int i; - for(i = 0; i < 256; i++) atom_table[i] = Make_header(0, i, White); -} - -static unsigned long read_size(p) - unsigned char * p; -{ - return ((unsigned long) p[0] << 24) + ((unsigned long) p[1] << 16) + - ((unsigned long) p[2] << 8) + p[3]; -} - -#define FILE_NOT_FOUND (-1) -#define TRUNCATED_FILE (-2) -#define BAD_MAGIC_NUM (-3) - -static int read_trailer(fd, trail) - int fd; - struct exec_trailer * trail; -{ - char buffer[TRAILER_SIZE]; - - lseek(fd, (long) -TRAILER_SIZE, 2); - if (read(fd, buffer, TRAILER_SIZE) < TRAILER_SIZE) return TRUNCATED_FILE; - trail->code_size = read_size(buffer); - trail->data_size = read_size(buffer+4); - trail->symbol_size = read_size(buffer+8); - trail->debug_size = read_size(buffer+12); - if (strncmp(buffer + 16, EXEC_MAGIC, 12) == 0) - return 0; - else - return BAD_MAGIC_NUM; -} - -int attempt_open(name, trail, do_open_script) - char ** name; - struct exec_trailer * trail; - int do_open_script; -{ - char * truename; - int fd; - int err; - char buf [2]; - - truename = searchpath(*name); - if (truename == 0) truename = *name; else *name = truename; - fd = open(truename, O_RDONLY | O_BINARY); - if (fd == -1) return FILE_NOT_FOUND; - if (!do_open_script){ - err = read (fd, buf, 2); - if (err < 2) { close(fd); return TRUNCATED_FILE; } - if (buf [0] == '#' && buf [1] == '!') { close(fd); return BAD_MAGIC_NUM; } - } - err = read_trailer(fd, trail); - if (err != 0) { close(fd); return err; } - return fd; -} - - -/* Command for loading the bytecode file */ -int CamlRunCmd(dummy, interp, argc, argv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ -{ - int fd; - struct exec_trailer trail; - struct longjmp_buffer raise_buf; - struct channel * chan; - - if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " foo.cmo args\"", (char *) NULL); - return TCL_ERROR; - } - fd = attempt_open(&argv[1], &trail, 1); - - switch(fd) { - case FILE_NOT_FOUND: - fatal_error_arg("Fatal error: cannot find file %s\n", argv[1]); - break; - case TRUNCATED_FILE: - case BAD_MAGIC_NUM: - fatal_error_arg( - "Fatal error: the file %s is not a bytecode executable file\n", - argv[1]); - break; - } - - if (sigsetjmp(raise_buf.buf, 1) == 0) { - - external_raise = &raise_buf; - - lseek(fd, - (long) (TRAILER_SIZE + trail.code_size + trail.data_size - + trail.symbol_size + trail.debug_size), 2); - - code_size = trail.code_size; - start_code = (code_t) stat_alloc(code_size); - if (read(fd, (char *) start_code, code_size) != code_size) - fatal_error("Fatal error: truncated bytecode file.\n"); - -#ifdef ARCH_BIG_ENDIAN - fixup_endianness(start_code, code_size); -#endif - - chan = open_descr(fd); - global_data = input_value(chan); - close_channel(chan); - /* Ensure that the globals are in the major heap. */ - oldify(global_data, &global_data); - - sys_init(argv + 1); - interprete(start_code, code_size); - return TCL_OK; - } else { - Tcl_AppendResult(interp, "Caml program", argv[1], " raised exception \"", - String_val(Field(Field(exn_bucket, 0), 0))); - return TCL_ERROR; - } -} - -int CamlInvokeCmd(dummy - - - -/* Now the real Tk stuff */ -static Tk_Window mainWindow; - -#define RCNAME ".camltkrc" -#define CAMLCB "camlcb" - -/* Initialisation of the dynamically loaded module */ -int Caml_Init(interp) - Tcl_Interp *interp; -{ - cltclinterp = interp; - /* Create the camlcallback command */ - Tcl_CreateCommand(cltclinterp, - CAMLCB, CamlCBCmd, - (ClientData)NULL,(Tcl_CmdDeleteProc *)NULL); - - /* This is required by "unknown" and thus autoload */ - Tcl_SetVar(cltclinterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); - /* Our hack for implementing break in callbacks */ - Tcl_SetVar(cltclinterp, "BreakBindingsSequence", "0", TCL_GLOBAL_ONLY); - - /* Load the traditional rc file */ - { - char *home = getenv("HOME"); - if (home != NULL) { - char *f = stat_alloc(strlen(home)+strlen(RCNAME)+2); - f[0]='\0'; - strcat(f, home); - strcat(f, "/"); - strcat(f, RCNAME); - if (0 == access(f,R_OK)) - if (TCL_OK != Tcl_EvalFile(cltclinterp,f)) { - stat_free(f); - tk_error(cltclinterp->result); - }; - stat_free(f); - } - } - - /* Initialisations from caml_main */ - { - int verbose_init = 0, - percent_free_init = Percent_free_def; - long minor_heap_init = Minor_heap_def, - heap_chunk_init = Heap_chunk_def; - - /* Machine-dependent initialization of the floating-point hardware - so that it behaves as much as possible as specified in IEEE */ - init_ieee_floats(); - init_gc (minor_heap_init, heap_chunk_init, percent_free_init, - verbose_init); - init_stack(); - init_atoms(); - } -} diff --git a/otherlibs/labltk/support/cltkEval.c b/otherlibs/labltk/support/cltkEval.c deleted file mode 100644 index ac0d3e15c..000000000 --- a/otherlibs/labltk/support/cltkEval.c +++ /dev/null @@ -1,222 +0,0 @@ -#include <stdlib.h> - -#include <tcl.h> -#include <tk.h> -#include <caml/mlvalues.h> -#include <caml/alloc.h> -#include <caml/memory.h> -#ifdef HAS_UNISTD -#include <unistd.h> -#endif -#include "camltk.h" - -/* The Tcl interpretor */ -Tcl_Interp *cltclinterp = NULL; - -/* Copy a list of strings from the C heap to Caml */ -value copy_string_list(argc, argv) - int argc; - char ** argv; -{ - value res; - int i; - value oldres = Val_unit, str = Val_unit; - - Begin_roots2 (oldres, str); - res = Val_int(0); /* [] */ - for (i = argc-1; i >= 0; i--) { - oldres = res; - str = copy_string(argv[i]); - res = alloc(2, 0); - Field(res, 0) = str; - Field(res, 1) = oldres; - } - End_roots(); - return res; -} - -/* - * Calling Tcl from Caml - * this version works on an arbitrary Tcl command - */ -value camltk_tcl_eval(str) /* ML */ -value str; -{ - int code; - char *cmd = NULL; - - CheckInit(); - - /* Tcl_Eval may write to its argument, so we take a copy - * If the evaluation raises a Caml exception, we have a space - * leak - */ - Tcl_ResetResult(cltclinterp); - cmd = string_to_c(str); - code = Tcl_Eval(cltclinterp, cmd); - stat_free(cmd); - - switch (code) { - case TCL_OK: - return copy_string(cltclinterp->result); - case TCL_ERROR: - tk_error(cltclinterp->result); - default: /* TCL_BREAK, TCL_CONTINUE, TCL_RETURN */ - tk_error("bad tcl result"); - } -} - - -/* - * Calling Tcl from Caml - * direct call, argument is TkArgs vect - type TkArgs = - TkToken of string - | TkTokenList of TkArgs list (* to be expanded *) - | TkQuote of TkArgs (* mapped to Tcl list *) - * NO PARSING, NO SUBSTITUTION - */ - -/* - * Compute the size of the argument (of type TkArgs). - * TkTokenList must be expanded, - * TkQuote count for one. - */ -int argv_size(v) -value v; -{ - switch (Tag_val(v)) { - case 0: /* TkToken */ - return 1; - case 1: /* TkTokenList */ - { int n; - value l; - for (l=Field(v,0), n=0; Is_block(l); l=Field(l,1)) - n+=argv_size(Field(l,0)); - return n; - } - case 2: /* TkQuote */ - return 1; - } -} - -/* - * Memory of allocated Tcl lists. - * We should not need more than MAX_LIST - */ -#define MAX_LIST 256 -static char *tcllists[MAX_LIST]; - -static int startfree = 0; -/* If size is lower, do not allocate */ -static char *quotedargv[16]; - -/* Fill a preallocated vector arguments, doing expansion and all. - * Assumes Tcl will - * not tamper with our strings - * make copies if strings are "persistent" - */ -int fill_args (argv, where, v) -char ** argv; -int where; -value v; -{ - switch (Tag_val(v)) { - case 0: - argv[where] = String_val(Field(v,0)); - return (where + 1); - case 1: - { value l; - for (l=Field(v,0); Is_block(l); l=Field(l,1)) - where = fill_args(argv,where,Field(l,0)); - return where; - } - case 2: - { char **tmpargv; - int size = argv_size(Field(v,0)); - if (size < 16) - tmpargv = "edargv[0]; - else - tmpargv = (char **)stat_alloc((size + 1) * sizeof(char *)); - fill_args(tmpargv,0,Field(v,0)); - tmpargv[size] = NULL; - argv[where] = Tcl_Merge(size,tmpargv); - tcllists[startfree++] = argv[where]; /* so we can free it later */ - if (size >= 16) - stat_free((char *)tmpargv); - return (where + 1); - } - } -} - -/* v is an array of TkArg */ -value camltk_tcl_direct_eval(v) /* ML */ -value v; -{ - int i; - int size; /* size of argv */ - char **argv; - int result; - Tcl_CmdInfo info; - int wherewasi,whereami; /* positions in tcllists array */ - - CheckInit(); - - /* walk the array to compute final size for Tcl */ - for(i=0,size=0;i<Wosize_val(v);i++) - size += argv_size(Field(v,i)); - - /* +2: one slot for NULL - one slot for "unknown" if command not found */ - argv = (char **)stat_alloc((size + 2) * sizeof(char *)); - - wherewasi = startfree; /* should be zero except when nested calls */ - Assert(startfree < MAX_LIST); - - /* Copy */ - { - int where; - for(i=0, where=0;i<Wosize_val(v);i++) - where = fill_args(argv,where,Field(v,i)); - argv[size] = NULL; - argv[size + 1] = NULL; - } - - Begin_roots_block ((value *) argv, size + 2); - - whereami = startfree; - - /* Eval */ - Tcl_ResetResult(cltclinterp); - if (Tcl_GetCommandInfo(cltclinterp,argv[0],&info)) { /* command found */ - result = (*info.proc)(info.clientData,cltclinterp,size,argv); - } else {/* implement the autoload stuff */ - if (Tcl_GetCommandInfo(cltclinterp,"unknown",&info)) { /* unknown found */ - for (i = size; i >= 0; i--) - argv[i+1] = argv[i]; - argv[0] = "unknown"; - result = (*info.proc)(info.clientData,cltclinterp,size+1,argv); - } else { /* ah, it isn't there at all */ - result = TCL_ERROR; - Tcl_AppendResult(cltclinterp, "Unknown command \"", - argv[0], "\"", NULL); - } - } - End_roots (); - - /* Free the various things we allocated */ - stat_free((char *)argv); - for (i=wherewasi; i<whereami; i++) - free(tcllists[i]); - startfree = wherewasi; - - switch (result) { - case TCL_OK: - return copy_string (cltclinterp->result); - case TCL_ERROR: - tk_error(cltclinterp->result); - default: /* TCL_BREAK, TCL_CONTINUE, TCL_RETURN */ - tk_error("bad tcl result"); - } -} - diff --git a/otherlibs/labltk/support/cltkEvent.c b/otherlibs/labltk/support/cltkEvent.c deleted file mode 100644 index 92221b963..000000000 --- a/otherlibs/labltk/support/cltkEvent.c +++ /dev/null @@ -1,38 +0,0 @@ -#include <tcl.h> -#include <tk.h> -#include <caml/mlvalues.h> -#include "camltk.h" - -value camltk_tk_mainloop() /* ML */ -{ - CheckInit(); - - if (cltk_slave_mode) - return Val_unit; - - if (!signal_events) { - /* Initialise signal handling */ - signal_events = 1; - Tk_CreateTimerHandler(100, invoke_pending_caml_signals, NULL); - }; - Tk_MainLoop(); - return Val_unit; -} - -/* Note: this HAS to be reported "as-is" in ML source */ -static int event_flag_table[] = { - TK_DONT_WAIT, TK_X_EVENTS, TK_FILE_EVENTS, TK_TIMER_EVENTS, TK_IDLE_EVENTS, - TK_ALL_EVENTS -}; - -value camltk_dooneevent(flags) /* ML */ - value flags; -{ - int ret; - - CheckInit(); - - ret = Tk_DoOneEvent(convert_flag_list(flags, event_flag_table)); - return Val_int(ret); -} - diff --git a/otherlibs/labltk/support/cltkFile.c b/otherlibs/labltk/support/cltkFile.c deleted file mode 100644 index a890aba11..000000000 --- a/otherlibs/labltk/support/cltkFile.c +++ /dev/null @@ -1,111 +0,0 @@ -#ifdef _WIN32 -#include <wtypes.h> -#include <winbase.h> -#include <winsock.h> -#endif -#include <tcl.h> -#include <tk.h> -#include <caml/mlvalues.h> -#include "camltk.h" - -/* - * File descriptor callbacks - */ - -void FileProc(ClientData clientdata, int mask) -{ - callback2(*handler_code,Val_int(clientdata),Val_int(0)); -} - -/* Map Unix.file_descr values to Tcl file handles */ - -#ifndef _WIN32 - -/* Unix system */ - -#if TCL_MAJOR_VERSION >= 8 -#define tcl_filehandle(fd) Int_val(fd) -#define Tcl_File int -#define Tcl_FreeFile(fd) -#else -static Tcl_File tcl_filehandle(value fd) -{ - return Tcl_GetFile((ClientData)Long_val(fd), TCL_UNIX_FD); -} -#endif - -#else - -/* Windows */ - -#define Handle_val(v) (*((HANDLE *)(v))) - -static Tcl_File tcl_filehandle(value fd) -{ - HANDLE h = Handle_val(fd); - int type; - int optval, optsize; - - optsize = sizeof(optval); - if (getsockopt((SOCKET) h, SOL_SOCKET, SO_TYPE, &optval, &optsize) == 0) - type = TCL_WIN_SOCKET; - else - switch (GetFileType(h)) { - case FILE_TYPE_CHAR: - type = TCL_WIN_CONSOLE; - case FILE_TYPE_PIPE: - type = TCL_WIN_PIPE; - case FILE_TYPE_DISK: - default: /* use WIN_FILE for unknown handles */ - type = TCL_WIN_FILE; - } - return Tcl_GetFile(h, type); -} - -#endif - -value camltk_add_file_input(fd, cbid) /* ML */ - value fd; - value cbid; -{ - CheckInit(); - Tcl_CreateFileHandler(tcl_filehandle(fd), TCL_READABLE, - FileProc, (ClientData)(Long_val(cbid))); - return Val_unit; -} - -/* We have to free the Tcl handle when we are finished using it (Tcl - * asks us to, and moreover it is probably dangerous to keep the same - * handle over two allocations of the same fd by the kernel). - * But we don't know when we are finished with the fd, so we free it - * in rem_file (it doesn't close the fd anyway). For fds for which we - * repeatedly add/rem, this will cause some overhead. - */ -value camltk_rem_file_input(fd) /* ML */ - value fd; -{ - Tcl_File fh = tcl_filehandle(fd); - Tcl_DeleteFileHandler(fh); - Tcl_FreeFile(fh); - return Val_unit; -} - -value camltk_add_file_output(fd, cbid) /* ML */ - value fd; - value cbid; -{ - CheckInit(); - Tcl_CreateFileHandler(tcl_filehandle(fd), TCL_WRITABLE, - FileProc, (ClientData) (Long_val(cbid))); - return Val_unit; -} - -value camltk_rem_file_output(fd) /* ML */ - value fd; -{ - Tcl_File fh = tcl_filehandle(fd); - Tcl_DeleteFileHandler(fh); - Tcl_FreeFile(fh); - return Val_unit; -} - diff --git a/otherlibs/labltk/support/cltkMain.c b/otherlibs/labltk/support/cltkMain.c deleted file mode 100644 index 372372a1d..000000000 --- a/otherlibs/labltk/support/cltkMain.c +++ /dev/null @@ -1,117 +0,0 @@ -#include <string.h> -#include <tcl.h> -#include <tk.h> -#include <caml/mlvalues.h> -#include <caml/memory.h> -#include <caml/callback.h> -#ifdef HAS_UNISTD -#include <unistd.h> /* for R_OK */ -#endif -#include "camltk.h" - -#ifndef R_OK -#define R_OK 4 -#endif - -/* - * Dealing with signals: when a signal handler is defined in Caml, - * the actual execution of the signal handler upon reception of the - * signal is delayed until we are sure we are out of the GC. - * If a signal occurs during the MainLoop, we would have to wait - * the next event for the handler to be invoked. - * The following function will invoke a pending signal handler if any, - * and we put in on a regular timer. - */ - -#define SIGNAL_INTERVAL 300 - -int signal_events = 0; /* do we have a pending timer */ - -void invoke_pending_caml_signals (clientdata) - ClientData clientdata; -{ - signal_events = 0; - enter_blocking_section(); /* triggers signal handling */ - /* Rearm timer */ - Tk_CreateTimerHandler(SIGNAL_INTERVAL, invoke_pending_caml_signals, NULL); - signal_events = 1; - leave_blocking_section(); -} - -/* Now the real Tk stuff */ - -Tk_Window cltk_mainWindow; - - -/* In slave mode, the interpreter *already* exists */ -int cltk_slave_mode = 0; - -/* Initialisation, based on tkMain.c */ -value camltk_opentk(display, name) /* ML */ - value display,name; -{ - if (!cltk_slave_mode) { - /* Create an interpreter, dies if error */ -#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 1 - Tcl_FindExecutable(String_val(name)); -#endif - cltclinterp = Tcl_CreateInterp(); - - if (Tcl_Init(cltclinterp) != TCL_OK) - tk_error(cltclinterp->result); - Tcl_SetVar(cltclinterp, "argv0", String_val (name), TCL_GLOBAL_ONLY); - { /* Sets display if needed */ - char *args; - char *tkargv[2]; - if (string_length(display) > 0) { - Tcl_SetVar(cltclinterp, "argc", "2", TCL_GLOBAL_ONLY); - tkargv[0] = "-display"; - tkargv[1] = String_val(display); - args = Tcl_Merge(2, tkargv); - Tcl_SetVar(cltclinterp, "argv", args, TCL_GLOBAL_ONLY); - free(args); - } - } - if (Tk_Init(cltclinterp) != TCL_OK) - tk_error(cltclinterp->result); - - /* Retrieve the main window */ - cltk_mainWindow = Tk_MainWindow(cltclinterp); - - if (NULL == cltk_mainWindow) - tk_error(cltclinterp->result); - - Tk_GeometryRequest(cltk_mainWindow,200,200); - } - - /* Create the camlcallback command */ - Tcl_CreateCommand(cltclinterp, - CAMLCB, CamlCBCmd, - (ClientData)NULL,(Tcl_CmdDeleteProc *)NULL); - - /* This is required by "unknown" and thus autoload */ - Tcl_SetVar(cltclinterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); - /* Our hack for implementing break in callbacks */ - Tcl_SetVar(cltclinterp, "BreakBindingsSequence", "0", TCL_GLOBAL_ONLY); - - /* Load the traditional rc file */ - { - char *home = getenv("HOME"); - if (home != NULL) { - char *f = stat_alloc(strlen(home)+strlen(RCNAME)+2); - f[0]='\0'; - strcat(f, home); - strcat(f, "/"); - strcat(f, RCNAME); - if (0 == access(f,R_OK)) - if (TCL_OK != Tcl_EvalFile(cltclinterp,f)) { - stat_free(f); - tk_error(cltclinterp->result); - }; - stat_free(f); - } - } - - return Val_unit; -} - diff --git a/otherlibs/labltk/support/cltkMisc.c b/otherlibs/labltk/support/cltkMisc.c deleted file mode 100644 index 22db83e46..000000000 --- a/otherlibs/labltk/support/cltkMisc.c +++ /dev/null @@ -1,42 +0,0 @@ -#include <tcl.h> -#include <tk.h> -#include <caml/mlvalues.h> -#include <caml/memory.h> -#include "camltk.h" - -/* Parsing results */ -value camltk_splitlist (v) /* ML */ - value v; -{ - int argc; - char **argv; - int result; - - CheckInit(); - - /* argv is allocated by Tcl, to be freed by us */ - result = Tcl_SplitList(cltclinterp,String_val(v),&argc,&argv); - switch(result) { - case TCL_OK: - { value res = copy_string_list(argc,argv); - free((char *)argv); /* only one large block was allocated */ - return res; - } - case TCL_ERROR: - default: - tk_error(cltclinterp->result); - } -} - -/* Copy a Caml string to the C heap. Should deallocate with stat_free */ -char *string_to_c(s) - value s; -{ - int l = string_length(s); - char *res = stat_alloc(l + 1); - bcopy(String_val(s),res,l); - res[l] = '\0'; - return res; -} - - diff --git a/otherlibs/labltk/support/cltkTimer.c b/otherlibs/labltk/support/cltkTimer.c deleted file mode 100644 index 2b8ec0e1b..000000000 --- a/otherlibs/labltk/support/cltkTimer.c +++ /dev/null @@ -1,30 +0,0 @@ -#include <tcl.h> -#include <tk.h> -#include <caml/mlvalues.h> -#include "camltk.h" - - -/* Basically the same thing as FileProc */ -void TimerProc (clientdata) - ClientData clientdata; -{ - callback2(*handler_code,Val_long(clientdata),Val_int(0)); -} - -value camltk_add_timer(milli, cbid) /* ML */ - value milli; - value cbid; -{ - CheckInit(); - /* look at tkEvent.c , Tk_Token is an int */ - return (value)Tcl_CreateTimerHandler(Int_val(milli), TimerProc, - (ClientData) (Long_val(cbid))); -} - -value camltk_rem_timer(token) /* ML */ - value token; -{ - Tcl_DeleteTimerHandler((Tcl_TimerToken) token); - return Val_unit; -} - diff --git a/otherlibs/labltk/support/cltkVar.c b/otherlibs/labltk/support/cltkVar.c deleted file mode 100644 index 9d0f08351..000000000 --- a/otherlibs/labltk/support/cltkVar.c +++ /dev/null @@ -1,109 +0,0 @@ -/* Alternative to tkwait variable */ -#include <string.h> -#include <tcl.h> -#include <tk.h> -#include <caml/mlvalues.h> -#include <caml/memory.h> -#include "camltk.h" - -value camltk_getvar(var) /* ML */ - value var; -{ - char *s; - char *stable_var = NULL; - CheckInit(); - - stable_var = string_to_c(var); - s = Tcl_GetVar(cltclinterp,stable_var, - TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG); - stat_free(stable_var); - - if (s == NULL) - tk_error(cltclinterp->result); - else - return(copy_string(s)); -} - -value camltk_setvar(var,contents) /* ML */ - value var; - value contents; -{ - char *s; - char *stable_var = NULL; - CheckInit(); - - /* SetVar makes a copy of the contents. */ - /* In case we have write traces in Caml, it's better to make sure that - var doesn't move... */ - stable_var = string_to_c(var); - s = Tcl_SetVar(cltclinterp,stable_var, String_val(contents), - TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG); - stat_free(stable_var); - - if (s == NULL) - tk_error(cltclinterp->result); - else - return(Val_unit); -} - - -/* The appropriate type is -typedef char *(Tcl_VarTraceProc) _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, char *part1, char *part2, int flags)); - */ -static char * tracevar(clientdata, interp, name1, name2, flags) - ClientData clientdata; - Tcl_Interp *interp; /* Interpreter containing variable. */ - char *name1; /* Name of variable. */ - char *name2; /* Second part of variable name. */ - int flags; /* Information about what happened. */ -{ - Tcl_UntraceVar2(interp, name1, name2, - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - tracevar, clientdata); - callback2(*handler_code,Val_int(clientdata),Val_unit); - return (char *)NULL; -} - -/* Sets up a callback upon modification of a variable */ -value camltk_trace_var(var,cbid) /* ML */ - value var; - value cbid; -{ - char *cvar = NULL; - - CheckInit(); - /* Make a copy of var, since Tcl will modify it in place, and we - * don't trust that much what it will do here - */ - cvar = string_to_c(var); - if (Tcl_TraceVar(cltclinterp, cvar, - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - tracevar, - (ClientData) (Long_val(cbid))) - != TCL_OK) { - stat_free(cvar); - tk_error(cltclinterp->result); - }; - stat_free(cvar); - return Val_unit; -} - -value camltk_untrace_var(var,cbid) /* ML */ - value var; - value cbid; -{ - char *cvar = NULL; - - CheckInit(); - /* Make a copy of var, since Tcl will modify it in place, and we - * don't trust that much what it will do here - */ - cvar = string_to_c(var); - Tcl_UntraceVar(cltclinterp, cvar, - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - tracevar, - (ClientData) (Long_val(cbid))); - stat_free(cvar); - return Val_unit; -} diff --git a/otherlibs/labltk/support/cltkWait.c b/otherlibs/labltk/support/cltkWait.c deleted file mode 100644 index 7645dd931..000000000 --- a/otherlibs/labltk/support/cltkWait.c +++ /dev/null @@ -1,89 +0,0 @@ -#include <tcl.h> -#include <tk.h> -#include <caml/mlvalues.h> -#include <caml/memory.h> -#include "camltk.h" - -/* The following are replacements for - tkwait visibility - tkwait window - in the case where we use threads (tkwait internally calls an event loop, - and thus prevents thread scheduling from taking place). - - Instead, one should set up a callback, wait for a signal, and signal - from inside the callback -*/ - -static void WaitVisibilityProc _ANSI_ARGS_((ClientData clientData, - XEvent *eventPtr)); -static void WaitWindowProc _ANSI_ARGS_((ClientData clientData, - XEvent *eventPtr)); - -/* For the other handlers, we need a bit more data */ -struct WinCBData { - int cbid; - Tk_Window win; -}; - -static void WaitVisibilityProc(clientData, eventPtr) - ClientData clientData; - XEvent *eventPtr; /* Information about event (not used). */ -{ - struct WinCBData *vis = clientData; - value cbid = Val_int(vis->cbid); - - Tk_DeleteEventHandler(vis->win, VisibilityChangeMask, - WaitVisibilityProc, clientData); - - stat_free((char *)vis); - callback2(*handler_code,cbid,Val_int(0)); -} - -/* Sets up a callback upon Visibility of a window */ -value camltk_wait_vis(win,cbid) /* ML */ - value win; - value cbid; -{ - struct WinCBData *vis = - (struct WinCBData *)stat_alloc(sizeof(struct WinCBData)); - vis->win = Tk_NameToWindow(cltclinterp, String_val(win), cltk_mainWindow); - if (vis -> win == NULL) { - stat_free((char *)vis); - tk_error(cltclinterp->result); - }; - vis->cbid = Int_val(cbid); - Tk_CreateEventHandler(vis->win, VisibilityChangeMask, - WaitVisibilityProc, (ClientData) vis); - return Val_unit; -} - -static void WaitWindowProc(clientData, eventPtr) - ClientData clientData; - XEvent *eventPtr; -{ - if (eventPtr->type == DestroyNotify) { - struct WinCBData *vis = clientData; - value cbid = Val_int(vis->cbid); - stat_free((char *)clientData); - /* The handler is destroyed by Tk itself */ - callback2(*handler_code,cbid,Val_int(0)); - } -} - -/* Sets up a callback upon window destruction */ -value camltk_wait_des(win,cbid) /* ML */ - value win; - value cbid; -{ - struct WinCBData *vis = - (struct WinCBData *)stat_alloc(sizeof(struct WinCBData)); - vis->win = Tk_NameToWindow(cltclinterp, String_val(win), cltk_mainWindow); - if (vis -> win == NULL) { - stat_free((char *)vis); - tk_error(cltclinterp->result); - }; - vis->cbid = Int_val(cbid); - Tk_CreateEventHandler(vis->win, StructureNotifyMask, - WaitWindowProc, (ClientData) vis); - return Val_unit; -} diff --git a/otherlibs/labltk/support/coerce.ml b/otherlibs/labltk/support/coerce.ml deleted file mode 100644 index 1562fbec1..000000000 --- a/otherlibs/labltk/support/coerce.ml +++ /dev/null @@ -1,2 +0,0 @@ -(* for no Support open *) -let coe = Widget.coe diff --git a/otherlibs/labltk/support/fileevent.ml b/otherlibs/labltk/support/fileevent.ml deleted file mode 100644 index ffebc909b..000000000 --- a/otherlibs/labltk/support/fileevent.ml +++ /dev/null @@ -1,64 +0,0 @@ -(* $Id$ *) - -open Unix -open Protocol - -external add_file_input : file_descr -> cbid -> unit - = "camltk_add_file_input" -external rem_file_input : file_descr -> unit - = "camltk_rem_file_input" -external add_file_output : file_descr -> cbid -> unit - = "camltk_add_file_output" -external rem_file_output : file_descr -> unit - = "camltk_rem_file_output" - -(* File input handlers *) - -let fd_table = Hashtbl.create 37 (* Avoid space leak in callback table *) - -let add_fileinput :fd callback:f = - let id = new_function_id () in - Hashtbl.add callback_naming_table key:id data:(fun _ -> f()); - Hashtbl.add fd_table key:(fd, 'r') data:id; - if !Protocol.debug then begin - Protocol.prerr_cbid id; prerr_endline " for fileinput" - end; - add_file_input fd id - -let remove_fileinput :fd = - try - let id = Hashtbl.find fd_table key:(fd, 'r') in - clear_callback id; - Hashtbl.remove fd_table key:(fd, 'r'); - if !Protocol.debug then begin - prerr_string "clear "; - Protocol.prerr_cbid id; - prerr_endline " for fileinput" - end; - rem_file_input fd - with - Not_found -> () - -let add_fileoutput :fd callback:f = - let id = new_function_id () in - Hashtbl.add callback_naming_table key:id data:(fun _ -> f()); - Hashtbl.add fd_table key:(fd, 'w') data:id; - if !Protocol.debug then begin - Protocol.prerr_cbid id; prerr_endline " for fileoutput" - end; - add_file_output fd id - -let remove_fileoutput :fd = - try - let id = Hashtbl.find fd_table key:(fd, 'w') in - clear_callback id; - Hashtbl.remove fd_table key:(fd, 'w'); - if !Protocol.debug then begin - prerr_string "clear "; - Protocol.prerr_cbid id; - prerr_endline " for fileoutput" - end; - rem_file_output fd - with - Not_found -> () - diff --git a/otherlibs/labltk/support/fileevent.mli b/otherlibs/labltk/support/fileevent.mli deleted file mode 100644 index b72f6c78c..000000000 --- a/otherlibs/labltk/support/fileevent.mli +++ /dev/null @@ -1,7 +0,0 @@ -open Unix - -val add_fileinput : fd:file_descr -> callback:(unit -> unit) -> unit -val remove_fileinput: fd:file_descr -> unit -val add_fileoutput : fd:file_descr -> callback:(unit -> unit) -> unit -val remove_fileoutput: fd:file_descr -> unit - (* see [tk] module *) diff --git a/otherlibs/labltk/support/may.ml b/otherlibs/labltk/support/may.ml deleted file mode 100644 index 202b561d9..000000000 --- a/otherlibs/labltk/support/may.ml +++ /dev/null @@ -1,10 +0,0 @@ - -(* Very easy hack for option type *) -let may f = function - Some x -> Some (f x) -| None -> None - -let maycons f x l = - match x with - Some x -> f x :: l - | None -> l diff --git a/otherlibs/labltk/support/protocol.ml b/otherlibs/labltk/support/protocol.ml deleted file mode 100644 index 6da2a1daa..000000000 --- a/otherlibs/labltk/support/protocol.ml +++ /dev/null @@ -1,190 +0,0 @@ -(* $Id$ *) - -open Widget - -type callback_buffer = string list - (* Buffer for reading callback arguments *) - -type tkArgs = - TkToken of string - | TkTokenList of tkArgs list (* to be expanded *) - | TkQuote of tkArgs (* mapped to Tcl list *) - -type cbid = int - -external opentk : string -> string -> unit - = "camltk_opentk" -external tcl_eval : string -> string - = "camltk_tcl_eval" -external tk_mainloop : unit -> unit - = "camltk_tk_mainloop" -external tcl_direct_eval : tkArgs array -> string - = "camltk_tcl_direct_eval" -external splitlist : string -> string list - = "camltk_splitlist" -external tkreturn : string -> unit - = "camltk_return" -external callback_init : unit -> unit - = "camltk_init" - -exception TkError of string - (* Raised by the communication functions *) -let _ = Callback.register_exception "tkerror" (TkError "") - -(* Debugging support *) -let debug = - ref (try Sys.getenv "CAMLTKDEBUG"; true - with Not_found -> false) - -(* This is approximative, since we don't quote what needs to be quoted *) -let dump_args args = - let rec print_arg = function - TkToken s -> prerr_string s; prerr_string " " - | TkTokenList l -> List.iter fun:print_arg l - | TkQuote a -> prerr_string "{"; print_arg a; prerr_string "} " - in - Array.iter fun:print_arg args; - prerr_newline() - -(* - * Evaluating Tcl code - * debugging support should not affect performances... - *) - -let tkEval args = - if !debug then dump_args args; - let res = tcl_direct_eval args in - if !debug then begin - prerr_string "->>"; - prerr_endline res - end; - res - -(* - * Callbacks - *) - -let cCAMLtoTKwidget w = - TkToken (Widget.name w) - -let cTKtoCAMLwidget = function - "" -> raise (Invalid_argument "cTKtoCAMLwidget") - | s -> Widget.get_atom s - - -let callback_naming_table = - (Hashtbl.create 401 : (int, callback_buffer -> unit) Hashtbl.t) - -let callback_memo_table = - (Hashtbl.create 401 : (any widget, int) Hashtbl.t) - -let new_function_id = - let counter = ref 0 in - function () -> incr counter; !counter - -let string_of_cbid = string_of_int - -(* Add a new callback, associated to widget w *) -(* The callback should be cleared when w is destroyed *) -let register_callback w callback:f = - let id = new_function_id () in - Hashtbl.add callback_naming_table key:id data:f; - if (forget_type w) <> (forget_type Widget.dummy) then - Hashtbl.add callback_memo_table key:(forget_type w) data:id; - (string_of_cbid id) - -let clear_callback id = - Hashtbl.remove callback_naming_table key:id - -(* Clear callbacks associated to a given widget *) -let remove_callbacks w = - let w = forget_type w in - let cb_ids = Hashtbl.find_all callback_memo_table key:w in - List.iter fun:clear_callback cb_ids; - for i = 1 to List.length cb_ids do - Hashtbl.remove callback_memo_table key:w - done - -(* Hand-coded callback for destroyed widgets - * This may be extended by the application, or by other layers of Camltk. - * Could use bind + of Tk, but I'd rather give an alternate mechanism so - * that hooks can be set up at load time (i.e. before openTk) - *) -let destroy_hooks = ref [] -let add_destroy_hook f = - destroy_hooks := f :: !destroy_hooks - -let _ = - add_destroy_hook (fun w -> remove_callbacks w; Widget.remove w) - -let install_cleanup () = - let call_destroy_hooks = function - [wname] -> - let w = cTKtoCAMLwidget wname in - List.iter fun:(fun f -> f w) !destroy_hooks - | _ -> raise (TkError "bad cleanup callback") in - let fid = new_function_id () in - Hashtbl.add callback_naming_table key:fid data:call_destroy_hooks; - (* setup general destroy callback *) - tcl_eval ("bind all <Destroy> {camlcb " ^ (string_of_cbid fid) ^" %W}") - - -let prerr_cbid id = - prerr_string "camlcb "; prerr_int id - -(* The callback dispatch function *) -let dispatch_callback id args = - if !debug then begin - prerr_cbid id; - List.iter fun:(fun x -> prerr_string " "; prerr_string x) args; - prerr_newline() - end; - (Hashtbl.find callback_naming_table key:id) args; - if !debug then prerr_endline "<<-" - -let protected_dispatch id args = - try - Printexc.print (dispatch_callback id) args - with - Out_of_memory -> raise Out_of_memory - | Sys.Break -> raise Sys.Break - | e -> flush Pervasives.stderr - -let _ = Callback.register "camlcb" protected_dispatch - -(* Make sure the C variables are initialised *) -let _ = callback_init () - -(* Different version of initialisation functions *) -(* Native opentk is [opentk display class] *) -let openTk () = - opentk "" "LablTk"; - install_cleanup(); - Widget.default_toplevel - -let openTkClass s = - opentk "" s; - install_cleanup(); - Widget.default_toplevel - -let openTkDisplayClass display:disp cl = - opentk disp cl; - install_cleanup(); - Widget.default_toplevel - -(* Destroy all widgets, thus cleaning up table and exiting the loop *) -let closeTk () = - tcl_eval "destroy ."; () - -let mainLoop = - tk_mainloop - - -(* [register tclname f] makes [f] available from Tcl with - name [tclname] *) -let register tclname callback:cb = - let s = register_callback Widget.default_toplevel callback:cb in - tcl_eval (Printf.sprintf "proc %s {args} {eval {camlcb %s} $args}" - tclname s); - () - diff --git a/otherlibs/labltk/support/protocol.mli b/otherlibs/labltk/support/protocol.mli deleted file mode 100644 index 4febdc87d..000000000 --- a/otherlibs/labltk/support/protocol.mli +++ /dev/null @@ -1,66 +0,0 @@ -open Widget - -(* Lower level interface *) -exception TkError of string - (* Raised by the communication functions *) - -val debug : bool ref - (* When set to true, displays approximation of intermediate Tcl code *) - -type tkArgs = - TkToken of string - | TkTokenList of tkArgs list (* to be expanded *) - | TkQuote of tkArgs (* mapped to Tcl list *) - - -(* Misc *) -external splitlist : string -> string list - = "camltk_splitlist" - -val add_destroy_hook : (any widget -> unit) -> unit - - -(* Opening, closing, and mainloop *) -val openTk : unit -> toplevel widget -val openTkClass: string -> toplevel widget -val openTkDisplayClass: display:string -> string -> toplevel widget -val closeTk : unit -> unit -val mainLoop : unit -> unit - - -(* Direct evaluation of tcl code *) -val tkEval : tkArgs array -> string - -(* Returning a value from a Tcl callback *) -val tkreturn: string -> unit - - -(* Callbacks: this is private *) - -type cbid - -type callback_buffer = string list - (* Buffer for reading callback arguments *) - -val callback_naming_table : (cbid, callback_buffer -> unit) Hashtbl.t -val callback_memo_table : (any widget, cbid) Hashtbl.t - (* Exported for debug purposes only. Don't use them unless you - know what you are doing *) -val new_function_id : unit -> cbid -val string_of_cbid : cbid -> string -val register_callback : 'a widget -> callback:(callback_buffer -> unit) -> string - (* Callback support *) -val clear_callback : cbid -> unit - (* Remove a given callback from the table *) -val remove_callbacks : 'a widget -> unit - (* Clean up callbacks associated to widget. Must be used only when - the Destroy event is bind by the user and masks the default - Destroy event binding *) - -val cTKtoCAMLwidget : string -> any widget -val cCAMLtoTKwidget : 'a widget -> tkArgs - -val register : string -> callback:(callback_buffer -> unit) -> unit - -(*-*) -val prerr_cbid : cbid -> unit diff --git a/otherlibs/labltk/support/report.ml b/otherlibs/labltk/support/report.ml deleted file mode 100644 index ee040de37..000000000 --- a/otherlibs/labltk/support/report.ml +++ /dev/null @@ -1,7 +0,0 @@ -(* Report globals from protocol to tk *) -let openTk = openTk -and openTkClass = openTkClass -and openTkDisplayClass = openTkDisplayClass -and closeTk = closeTk -and mainLoop = mainLoop -and register = register diff --git a/otherlibs/labltk/support/support.ml b/otherlibs/labltk/support/support.ml deleted file mode 100644 index 4f67d62c7..000000000 --- a/otherlibs/labltk/support/support.ml +++ /dev/null @@ -1,61 +0,0 @@ -(* $Id$ *) - -(* Extensible buffers *) -type extensible_buffer = { - mutable buffer : string; - mutable pos : int; - mutable len : int} - -let new_buffer () = { - buffer = String.create len:128; - pos = 0; - len = 128 - } - -let print_in_buffer buf s = - let l = String.length s in - if buf.pos + l > buf.len then begin - buf.buffer <- buf.buffer ^ (String.create len:(l+128)); - buf.len <- buf.len + 128 + l - end; - String.blit s pos:0 to:buf.buffer to_pos:buf.pos len:l; - buf.pos <- buf.pos + l - -let get_buffer buf = - String.sub buf.buffer pos:0 len:buf.pos - - - -(* Used by list converters *) -let catenate_sep sep = - function - [] -> "" - | [x] -> x - | x::l -> - let b = new_buffer() in - print_in_buffer b x; - List.iter l - fun:(function s -> print_in_buffer b sep; print_in_buffer b s); - get_buffer b - -(* Parsing results of Tcl *) -(* List.split a string according to char_sep predicate *) -let split_str char_sep str = - let len = String.length str in - let rec skip_sep cur = - if cur >= len then cur - else if char_sep str.[cur] then skip_sep (succ cur) - else cur in - let rec split beg cur = - if cur >= len then - if beg = cur then [] - else [String.sub str pos:beg len:(len - beg)] - else if char_sep str.[cur] - then - let nextw = skip_sep cur in - (String.sub str pos:beg len:(cur - beg)) - ::(split nextw nextw) - else split beg (succ cur) in - let wstart = skip_sep 0 in - split wstart wstart - diff --git a/otherlibs/labltk/support/support.mli b/otherlibs/labltk/support/support.mli deleted file mode 100644 index 798842298..000000000 --- a/otherlibs/labltk/support/support.mli +++ /dev/null @@ -1,11 +0,0 @@ -(* Extensible buffers *) -type extensible_buffer -val new_buffer : unit -> extensible_buffer -val print_in_buffer : extensible_buffer -> string -> unit -val get_buffer : extensible_buffer -> string - - -val catenate_sep : string -> string list -> string -val split_str : (char -> bool) -> string -> string list - (* Various string manipulations *) - diff --git a/otherlibs/labltk/support/textvariable.ml b/otherlibs/labltk/support/textvariable.ml deleted file mode 100644 index 2d4b26f4f..000000000 --- a/otherlibs/labltk/support/textvariable.ml +++ /dev/null @@ -1,135 +0,0 @@ -(* $Id$ *) - -open Protocol - -external internal_tracevar : string -> cbid -> unit - = "camltk_trace_var" -external internal_untracevar : string -> cbid -> unit - = "camltk_untrace_var" -external set : string -> to:string -> unit = "camltk_setvar" -external get : string -> string = "camltk_getvar" - - -type textVariable = string - -(* List of handles *) -let handles = Hashtbl.create 401 - -let add_handle var cbid = - try - let r = Hashtbl.find handles key:var in - r := cbid :: !r - with - Not_found -> - Hashtbl.add handles key:var data:(ref [cbid]) - -let exceptq x = - let rec ex acc = function - [] -> acc - | y::l when y == x -> ex acc l - | y::l -> ex (y::acc) l - in - ex [] - -let rem_handle var cbid = - try - let r = Hashtbl.find handles key:var in - match exceptq cbid !r with - [] -> Hashtbl.remove handles key:var - | remaining -> r := remaining - with - Not_found -> () - -(* Used when we "free" the variable (otherwise, old handlers would apply to - * new usage of the variable) - *) -let rem_all_handles var = - try - let r = Hashtbl.find handles key:var in - List.iter fun:(internal_untracevar var) !r; - Hashtbl.remove handles key:var - with - Not_found -> () - - -(* Variable trace *) -let handle vname f = - let id = new_function_id() in - let wrapped _ = - clear_callback id; - rem_handle vname id; - f() in - Hashtbl.add callback_naming_table key:id data:wrapped; - add_handle vname id; - if !Protocol.debug then begin - prerr_cbid id; prerr_string " for variable "; prerr_endline vname - end; - internal_tracevar vname id - -(* Avoid space leak (all variables are global in Tcl) *) -module StringSet = - Set.Make(struct type t = string let compare = compare end) -let freelist = ref (StringSet.empty) -let memo = Hashtbl.create 101 - -(* Added a variable v referenced by widget w *) -let add w v = - let w = Widget.forget_type w in - let r = - try Hashtbl.find memo key:w - with - Not_found -> - let r = ref StringSet.empty in - Hashtbl.add memo key:w data:r; - r in - r := StringSet.add !r elt:v - -(* to be used with care ! *) -let free v = - rem_all_handles v; - freelist := StringSet.add elt:v !freelist - -(* Free variables associated with a widget *) -let freew w = - try - let r = Hashtbl.find memo key:w in - StringSet.iter fun:free !r; - Hashtbl.remove memo key:w - with - Not_found -> () - -let _ = add_destroy_hook freew - -(* Allocate a new variable *) -let counter = ref 0 -let getv () = - let v = - if StringSet.is_empty !freelist then begin - incr counter; - "camlv("^ string_of_int !counter ^")" - end - else - let v = StringSet.choose !freelist in - freelist := StringSet.remove elt:v !freelist; - v in - set v to:""; - v - -let create ?on: w () = - let v = getv() in - begin - match w with - Some w -> add w v - | None -> () - end; - v - -(* to be used with care ! *) -let free v = - freelist := StringSet.add elt:v !freelist - -let cCAMLtoTKtextVariable s = TkToken s - -let name s = s -let coerce s = s - diff --git a/otherlibs/labltk/support/textvariable.mli b/otherlibs/labltk/support/textvariable.mli deleted file mode 100644 index bcc6842a2..000000000 --- a/otherlibs/labltk/support/textvariable.mli +++ /dev/null @@ -1,29 +0,0 @@ -(* $Id$ *) - -(* Support for Tk -textvariable option *) -open Widget -open Protocol - -type textVariable - (* TextVariable is an abstract type *) - -val create : ?on: 'a widget -> unit -> textVariable - (* Allocation of a textVariable with lifetime associated to widget - if a widget is specified *) -val set : textVariable -> to: string -> unit - (* Setting the val of a textVariable *) -val get : textVariable -> string - (* Reading the val of a textVariable *) -val name : textVariable -> string - (* Its tcl name *) - -val cCAMLtoTKtextVariable : textVariable -> tkArgs - (* Internal conversion function *) - -val handle : textVariable -> (unit -> unit) -> unit - (* Callbacks on variable modifications *) - -val coerce : string -> textVariable - -(*-*) -val free : textVariable -> unit diff --git a/otherlibs/labltk/support/timer.ml b/otherlibs/labltk/support/timer.ml deleted file mode 100644 index 531695fe0..000000000 --- a/otherlibs/labltk/support/timer.ml +++ /dev/null @@ -1,33 +0,0 @@ -(* $Id$ *) - -(* Timers *) -open Protocol - -type tkTimer = int - -external internal_add_timer : int -> cbid -> tkTimer - = "camltk_add_timer" -external internal_rem_timer : tkTimer -> unit - = "camltk_rem_timer" - -type t = tkTimer * cbid (* the token and the cb id *) - -(* A timer is used only once, so we must clean the callback table *) -let add ms:milli callback:f = - let id = new_function_id () in - let wrapped _ = - clear_callback id; (* do it first in case f raises exception *) - f() in - Hashtbl.add callback_naming_table key:id data:wrapped; - if !Protocol.debug then begin - prerr_cbid id; prerr_endline " for timer" - end; - let t = internal_add_timer milli id in - t,id - -(* If the timer has never been used, there is a small space leak in - the C heap, where a copy of id has been stored *) -let remove (tkTimer, id) = - internal_rem_timer tkTimer; - clear_callback id - diff --git a/otherlibs/labltk/support/timer.mli b/otherlibs/labltk/support/timer.mli deleted file mode 100644 index 6e7610ce2..000000000 --- a/otherlibs/labltk/support/timer.mli +++ /dev/null @@ -1,4 +0,0 @@ -type t - -val add : ms:int -> callback:(unit -> unit) -> t -val remove : t -> unit diff --git a/otherlibs/labltk/support/tkwait.ml b/otherlibs/labltk/support/tkwait.ml deleted file mode 100644 index 48a1db782..000000000 --- a/otherlibs/labltk/support/tkwait.ml +++ /dev/null @@ -1,5 +0,0 @@ - -external internal_tracevis : string -> string -> unit - = "camltk_wait_vis" -external internal_tracedestroy : string -> string -> unit - = "camltk_wait_des" diff --git a/otherlibs/labltk/support/widget.ml b/otherlibs/labltk/support/widget.ml deleted file mode 100644 index 975d97565..000000000 --- a/otherlibs/labltk/support/widget.ml +++ /dev/null @@ -1,160 +0,0 @@ -(* $Id$ *) - -(* - * Widgets - *) - -exception IllegalWidgetType of string - (* Raised when widget command applied illegally*) - -(***************************************************) -(* Widgets *) -(***************************************************) -type 'a widget = - Untyped of string -| Typed of string * string - -type any -and button -and canvas -and checkbutton -and entry -and frame -and label -and listbox -and menu -and menubutton -and message -and radiobutton -and scale -and scrollbar -and text -and toplevel - -let forget_type w = (Obj.magic (w : 'a widget) : any widget) -let coe = forget_type - -(* table of widgets *) -let table = (Hashtbl.create 401 : (string, any widget) Hashtbl.t) - -let name = function - Untyped s -> s - | Typed (s,_) -> s - -(* Normally all widgets are known *) -(* this is a provision for send commands to external tk processes *) -let known_class = function - Untyped _ -> "unknown" - | Typed (_,c) -> c - -(* This one is always created by opentk *) -let default_toplevel = - let wname = "." in - let w = Typed (wname, "toplevel") in - Hashtbl.add table key:wname data:w; - w - -(* Dummy widget to which global callbacks are associated *) -(* also passed around by camltotkoption when no widget in context *) -let dummy = - Untyped "dummy" - -let remove w = - Hashtbl.remove table key:(name w) - -(* Retype widgets returned from Tk *) -(* JPF report: sometime s is "", see Protocol.cTKtoCAMLwidget *) -let get_atom s = - try - Hashtbl.find table key:s - with - Not_found -> Untyped s - -let naming_scheme = [ - "button", "b"; - "canvas", "ca"; - "checkbutton", "cb"; - "entry", "en"; - "frame", "f"; - "label", "l"; - "listbox", "li"; - "menu", "me"; - "menubutton", "mb"; - "message", "ms"; - "radiobutton", "rb"; - "scale", "sc"; - "scrollbar", "sb"; - "text", "t"; - "toplevel", "top" ] - - -let widget_any_table = List.map fun:fst naming_scheme -(* subtypes *) -let widget_button_table = [ "button" ] -and widget_canvas_table = [ "canvas" ] -and widget_checkbutton_table = [ "checkbutton" ] -and widget_entry_table = [ "entry" ] -and widget_frame_table = [ "frame" ] -and widget_label_table = [ "label" ] -and widget_listbox_table = [ "listbox" ] -and widget_menu_table = [ "menu" ] -and widget_menubutton_table = [ "menubutton" ] -and widget_message_table = [ "message" ] -and widget_radiobutton_table = [ "radiobutton" ] -and widget_scale_table = [ "scale" ] -and widget_scrollbar_table = [ "scrollbar" ] -and widget_text_table = [ "text" ] -and widget_toplevel_table = [ "toplevel" ] - -let new_suffix clas n = - try - (List.assoc key:clas naming_scheme) ^ (string_of_int n) - with - Not_found -> "w" ^ (string_of_int n) - - -(* The function called by generic creation *) -let counter = ref 0 -let new_atom :parent ?name:nom clas = - let parentpath = name parent in - let path = - match nom with - None -> - incr counter; - if parentpath = "." - then "." ^ (new_suffix clas !counter) - else parentpath ^ "." ^ (new_suffix clas !counter) - | Some name -> - if parentpath = "." - then "." ^ (new_suffix clas !counter) - else parentpath ^ "." ^ name - in - let w = Typed(path,clas) in - Hashtbl.add table key:path data:w; - w - -(* Just create a path. Only to check existence of widgets *) -(* Use with care *) -let atom :parent name:pathcomp = - let parentpath = name parent in - let path = - if parentpath = "." - then "." ^ pathcomp - else parentpath ^ "." ^ pathcomp in - Untyped path - - - -(* Redundant with subtyping of Widget, backward compatibility *) -let check_class w clas = - match w with - Untyped _ -> () (* assume run-time check by tk*) - | Typed(_,c) -> - if List.mem clas elt:c then () - else raise (IllegalWidgetType c) - - -(* Checking membership of constructor in subtype table *) -let chk_sub errname table c = - if List.mem table elt:c then () - else raise (Invalid_argument errname) diff --git a/otherlibs/labltk/support/widget.mli b/otherlibs/labltk/support/widget.mli deleted file mode 100644 index cf139a03f..000000000 --- a/otherlibs/labltk/support/widget.mli +++ /dev/null @@ -1,91 +0,0 @@ -(* Support for widget manipulations *) - -type 'a widget - (* widget is an abstract type *) - -type any -and button -and canvas -and checkbutton -and entry -and frame -and label -and listbox -and menu -and menubutton -and message -and radiobutton -and scale -and scrollbar -and text -and toplevel - -val forget_type : 'a widget -> any widget -val coe : 'a widget -> any widget - -val default_toplevel : toplevel widget - (* [default_toplevel] is "." in Tk, the toplevel widget that is - always existing during a Tk session. Destroying [default_toplevel] - ends the main loop - *) - -val atom : parent: 'a widget -> name: string -> any widget - (* [atom parent name] returns the widget [parent.name]. The widget is - not created. Only its name is returned. In a given parent, there may - only exist one children for a given name. - This function should only be used to check the existence of a widget - with a known name. It doesn't add the widget to the internal tables - of CamlTk. - *) - -val name : 'a widget -> string - (* [name w] returns the name (tk "path") of a widget *) - -(*--*) -(* The following functions are used internally. - There is normally no need for them in users programs - *) - -val known_class : 'a widget -> string - (* [known_class w] returns the class of a widget (e.g. toplevel, frame), - as known by the CamlTk interface. - Not equivalent to "winfo w" in Tk. - *) - -val dummy : any widget - (* [dummy] is a widget used as context when we don't have any. - It is *not* a real widget. - *) - -val new_atom : parent:'a widget -> ?name: string -> string -> 'b widget - -val get_atom : string -> any widget - (* [get_atom path] returns the widget with Tk path [path] *) - -val remove : 'a widget -> unit - (* [remove w] removes widget from the internal tables *) - -(* Subtypes tables *) -val widget_any_table : string list -val widget_button_table : string list -val widget_canvas_table : string list -val widget_checkbutton_table : string list -val widget_entry_table : string list -val widget_frame_table : string list -val widget_label_table : string list -val widget_listbox_table : string list -val widget_menu_table : string list -val widget_menubutton_table : string list -val widget_message_table : string list -val widget_radiobutton_table : string list -val widget_scale_table : string list -val widget_scrollbar_table : string list -val widget_text_table : string list -val widget_toplevel_table : string list - -val chk_sub : string -> 'a list -> 'a -> unit -val check_class : 'a widget -> string list -> unit - (* Widget subtyping *) - -exception IllegalWidgetType of string - (* Raised when widget command applied illegally*) |