diff options
Diffstat (limited to 'otherlibs/labltk/support/cltkDMain.c')
| -rw-r--r-- | otherlibs/labltk/support/cltkDMain.c | 229 |
1 files changed, 0 insertions, 229 deletions
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(); - } -} |