|
Packit |
bd2e5d |
/*************************************************************************/
|
|
Packit |
bd2e5d |
/* */
|
|
Packit |
bd2e5d |
/* OCaml LablTk library */
|
|
Packit |
bd2e5d |
/* */
|
|
Packit |
bd2e5d |
/* Francois Rouaix, Francois Pessaux and Jun Furuse */
|
|
Packit |
bd2e5d |
/* projet Cristal, INRIA Rocquencourt */
|
|
Packit |
bd2e5d |
/* Jacques Garrigue, Kyoto University RIMS */
|
|
Packit |
bd2e5d |
/* */
|
|
Packit |
bd2e5d |
/* Copyright 1999 Institut National de Recherche en Informatique et */
|
|
Packit |
bd2e5d |
/* en Automatique and Kyoto University. All rights reserved. */
|
|
Packit |
bd2e5d |
/* This file is distributed under the terms of the GNU Library */
|
|
Packit |
bd2e5d |
/* General Public License, with the special exception on linking */
|
|
Packit |
bd2e5d |
/* described in file ../../../LICENSE. */
|
|
Packit |
bd2e5d |
/* */
|
|
Packit |
bd2e5d |
/*************************************************************************/
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
/* $Id$ */
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
#include <unistd.h>
|
|
Packit |
bd2e5d |
#include <fcntl.h>
|
|
Packit |
bd2e5d |
#include <tcl.h>
|
|
Packit |
bd2e5d |
#include <tk.h>
|
|
Packit |
bd2e5d |
#include "gc.h"
|
|
Packit |
bd2e5d |
#include "exec.h"
|
|
Packit |
bd2e5d |
#include "sys.h"
|
|
Packit |
bd2e5d |
#include "fail.h"
|
|
Packit |
bd2e5d |
#include "io.h"
|
|
Packit |
bd2e5d |
#include "mlvalues.h"
|
|
Packit |
bd2e5d |
#include "memory.h"
|
|
Packit |
bd2e5d |
#include "camltk.h"
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
#ifndef O_BINARY
|
|
Packit |
bd2e5d |
#define O_BINARY 0
|
|
Packit |
bd2e5d |
#endif
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
/*
|
|
Packit |
bd2e5d |
* Dealing with signals: when a signal handler is defined in OCaml,
|
|
Packit |
bd2e5d |
* the actual execution of the signal handler upon reception of the
|
|
Packit |
bd2e5d |
* signal is delayed until we are sure we are out of the GC.
|
|
Packit |
bd2e5d |
* If a signal occurs during the MainLoop, we would have to wait
|
|
Packit |
bd2e5d |
* the next event for the handler to be invoked.
|
|
Packit |
bd2e5d |
* The following function will invoke a pending signal handler if any,
|
|
Packit |
bd2e5d |
* and we put in on a regular timer.
|
|
Packit |
bd2e5d |
*/
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
#define SIGNAL_INTERVAL 300
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
int signal_events = 0; /* do we have a pending timer */
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
void invoke_pending_caml_signals (clientdata)
|
|
Packit |
bd2e5d |
ClientData clientdata;
|
|
Packit |
bd2e5d |
{
|
|
Packit |
bd2e5d |
signal_events = 0;
|
|
Packit |
bd2e5d |
caml_enter_blocking_section(); /* triggers signal handling */
|
|
Packit |
bd2e5d |
/* Rearm timer */
|
|
Packit |
bd2e5d |
Tk_CreateTimerHandler(SIGNAL_INTERVAL, invoke_pending_caml_signals, NULL);
|
|
Packit |
bd2e5d |
signal_events = 1;
|
|
Packit |
bd2e5d |
caml_leave_blocking_section();
|
|
Packit |
bd2e5d |
}
|
|
Packit |
bd2e5d |
/* The following is taken from byterun/startup.c */
|
|
Packit |
bd2e5d |
header_t atom_table[256];
|
|
Packit |
bd2e5d |
code_t start_code;
|
|
Packit |
bd2e5d |
asize_t code_size;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
static void init_atoms()
|
|
Packit |
bd2e5d |
{
|
|
Packit |
bd2e5d |
int i;
|
|
Packit |
bd2e5d |
for(i = 0; i < 256; i++) atom_table[i] = Make_header(0, i, White);
|
|
Packit |
bd2e5d |
}
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
static unsigned long read_size(p)
|
|
Packit |
bd2e5d |
unsigned char * p;
|
|
Packit |
bd2e5d |
{
|
|
Packit |
bd2e5d |
return ((unsigned long) p[0] << 24) + ((unsigned long) p[1] << 16) +
|
|
Packit |
bd2e5d |
((unsigned long) p[2] << 8) + p[3];
|
|
Packit |
bd2e5d |
}
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
#define FILE_NOT_FOUND (-1)
|
|
Packit |
bd2e5d |
#define TRUNCATED_FILE (-2)
|
|
Packit |
bd2e5d |
#define BAD_MAGIC_NUM (-3)
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
static int read_trailer(fd, trail)
|
|
Packit |
bd2e5d |
int fd;
|
|
Packit |
bd2e5d |
struct exec_trailer * trail;
|
|
Packit |
bd2e5d |
{
|
|
Packit |
bd2e5d |
char buffer[TRAILER_SIZE];
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
lseek(fd, (long) -TRAILER_SIZE, 2);
|
|
Packit |
bd2e5d |
if (read(fd, buffer, TRAILER_SIZE) < TRAILER_SIZE) return TRUNCATED_FILE;
|
|
Packit |
bd2e5d |
trail->code_size = read_size(buffer);
|
|
Packit |
bd2e5d |
trail->data_size = read_size(buffer+4);
|
|
Packit |
bd2e5d |
trail->symbol_size = read_size(buffer+8);
|
|
Packit |
bd2e5d |
trail->debug_size = read_size(buffer+12);
|
|
Packit |
bd2e5d |
if (strncmp(buffer + 16, EXEC_MAGIC, 12) == 0)
|
|
Packit |
bd2e5d |
return 0;
|
|
Packit |
bd2e5d |
else
|
|
Packit |
bd2e5d |
return BAD_MAGIC_NUM;
|
|
Packit |
bd2e5d |
}
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
int attempt_open(name, trail, do_open_script)
|
|
Packit |
bd2e5d |
char ** name;
|
|
Packit |
bd2e5d |
struct exec_trailer * trail;
|
|
Packit |
bd2e5d |
int do_open_script;
|
|
Packit |
bd2e5d |
{
|
|
Packit |
bd2e5d |
char * truename;
|
|
Packit |
bd2e5d |
int fd;
|
|
Packit |
bd2e5d |
int err;
|
|
Packit |
bd2e5d |
char buf [2];
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
truename = searchpath(*name);
|
|
Packit |
bd2e5d |
if (truename == 0) truename = *name; else *name = truename;
|
|
Packit |
bd2e5d |
fd = open(truename, O_RDONLY | O_BINARY);
|
|
Packit |
bd2e5d |
if (fd == -1) return FILE_NOT_FOUND;
|
|
Packit |
bd2e5d |
if (!do_open_script){
|
|
Packit |
bd2e5d |
err = read (fd, buf, 2);
|
|
Packit |
bd2e5d |
if (err < 2) { close(fd); return TRUNCATED_FILE; }
|
|
Packit |
bd2e5d |
if (buf [0] == '#' && buf [1] == '!') { close(fd); return BAD_MAGIC_NUM; }
|
|
Packit |
bd2e5d |
}
|
|
Packit |
bd2e5d |
err = read_trailer(fd, trail);
|
|
Packit |
bd2e5d |
if (err != 0) { close(fd); return err; }
|
|
Packit |
bd2e5d |
return fd;
|
|
Packit |
bd2e5d |
}
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
/* Command for loading the bytecode file */
|
|
Packit |
bd2e5d |
int CamlRunCmd(dummy, interp, argc, argv)
|
|
Packit |
bd2e5d |
ClientData dummy; /* Not used. */
|
|
Packit |
bd2e5d |
Tcl_Interp *interp; /* Current interpreter. */
|
|
Packit |
bd2e5d |
int argc; /* Number of arguments. */
|
|
Packit |
bd2e5d |
char **argv; /* Argument strings. */
|
|
Packit |
bd2e5d |
{
|
|
Packit |
bd2e5d |
int fd;
|
|
Packit |
bd2e5d |
struct exec_trailer trail;
|
|
Packit |
bd2e5d |
struct longjmp_buffer raise_buf;
|
|
Packit |
bd2e5d |
struct channel * chan;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
if (argc < 2) {
|
|
Packit |
bd2e5d |
Tcl_AppendResult(interp, "wrong # args: should be \"",
|
|
Packit |
bd2e5d |
argv[0], " foo.cmo args\"", (char *) NULL);
|
|
Packit |
bd2e5d |
return TCL_ERROR;
|
|
Packit |
bd2e5d |
}
|
|
Packit |
bd2e5d |
fd = attempt_open(&argv[1], &trail, 1);
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
switch(fd) {
|
|
Packit |
bd2e5d |
case FILE_NOT_FOUND:
|
|
Packit |
bd2e5d |
fatal_error_arg("Fatal error: cannot find file %s\n", argv[1]);
|
|
Packit |
bd2e5d |
break;
|
|
Packit |
bd2e5d |
case TRUNCATED_FILE:
|
|
Packit |
bd2e5d |
case BAD_MAGIC_NUM:
|
|
Packit |
bd2e5d |
fatal_error_arg(
|
|
Packit |
bd2e5d |
"Fatal error: the file %s is not a bytecode executable file\n",
|
|
Packit |
bd2e5d |
argv[1]);
|
|
Packit |
bd2e5d |
break;
|
|
Packit |
bd2e5d |
}
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
if (sigsetjmp(raise_buf.buf, 1) == 0) {
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
external_raise = &raise_buf;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
lseek(fd, - (long) (TRAILER_SIZE + trail.code_size + trail.data_size
|
|
Packit |
bd2e5d |
+ trail.symbol_size + trail.debug_size), 2);
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
code_size = trail.code_size;
|
|
Packit |
bd2e5d |
start_code = (code_t) caml_stat_alloc(code_size);
|
|
Packit |
bd2e5d |
if (read(fd, (char *) start_code, code_size) != code_size)
|
|
Packit |
bd2e5d |
fatal_error("Fatal error: truncated bytecode file.\n");
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
#ifdef ARCH_BIG_ENDIAN
|
|
Packit |
bd2e5d |
fixup_endianness(start_code, code_size);
|
|
Packit |
bd2e5d |
#endif
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
chan = open_descr(fd);
|
|
Packit |
bd2e5d |
global_data = input_value(chan);
|
|
Packit |
bd2e5d |
close_channel(chan);
|
|
Packit |
bd2e5d |
/* Ensure that the globals are in the major heap. */
|
|
Packit |
bd2e5d |
oldify(global_data, &global_data);
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
sys_init(argv + 1);
|
|
Packit |
bd2e5d |
interprete(start_code, code_size);
|
|
Packit |
bd2e5d |
return TCL_OK;
|
|
Packit |
bd2e5d |
} else {
|
|
Packit |
bd2e5d |
Tcl_AppendResult(interp, "Caml program", argv[1], " raised exception \"",
|
|
Packit |
bd2e5d |
String_val(Field(Field(exn_bucket, 0), 0)));
|
|
Packit |
bd2e5d |
return TCL_ERROR;
|
|
Packit |
bd2e5d |
}
|
|
Packit |
bd2e5d |
}
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
int CamlInvokeCmd(dummy
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
/* Now the real Tk stuff */
|
|
Packit |
bd2e5d |
Tk_Window cltk_mainWindow;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
#define RCNAME ".camltkrc"
|
|
Packit |
bd2e5d |
#define CAMLCB "camlcb"
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
/* Initialisation of the dynamically loaded module */
|
|
Packit |
bd2e5d |
int Caml_Init(interp)
|
|
Packit |
bd2e5d |
Tcl_Interp *interp;
|
|
Packit |
bd2e5d |
{
|
|
Packit |
bd2e5d |
cltclinterp = interp;
|
|
Packit |
bd2e5d |
/* Create the camlcallback command */
|
|
Packit |
bd2e5d |
Tcl_CreateCommand(cltclinterp,
|
|
Packit |
bd2e5d |
CAMLCB, CamlCBCmd,
|
|
Packit |
bd2e5d |
(ClientData)NULL,(Tcl_CmdDeleteProc *)NULL);
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
/* This is required by "unknown" and thus autoload */
|
|
Packit |
bd2e5d |
Tcl_SetVar(cltclinterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY);
|
|
Packit |
bd2e5d |
/* Our hack for implementing break in callbacks */
|
|
Packit |
bd2e5d |
Tcl_SetVar(cltclinterp, "BreakBindingsSequence", "0", TCL_GLOBAL_ONLY);
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
/* Load the traditional rc file */
|
|
Packit |
bd2e5d |
{
|
|
Packit |
bd2e5d |
char *home = getenv("HOME");
|
|
Packit |
bd2e5d |
if (home != NULL) {
|
|
Packit |
bd2e5d |
char *f = caml_stat_alloc(strlen(home)+strlen(RCNAME)+2);
|
|
Packit |
bd2e5d |
f[0]='\0';
|
|
Packit |
bd2e5d |
strcat(f, home);
|
|
Packit |
bd2e5d |
strcat(f, "/");
|
|
Packit |
bd2e5d |
strcat(f, RCNAME);
|
|
Packit |
bd2e5d |
if (0 == access(f,R_OK))
|
|
Packit |
bd2e5d |
if (TCL_OK != Tcl_EvalFile(cltclinterp,f)) {
|
|
Packit |
bd2e5d |
caml_stat_free(f);
|
|
Packit |
bd2e5d |
tk_error(Tcl_GetStringResult(cltclinterp));
|
|
Packit |
bd2e5d |
};
|
|
Packit |
bd2e5d |
caml_stat_free(f);
|
|
Packit |
bd2e5d |
}
|
|
Packit |
bd2e5d |
}
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
/* Initialisations from caml_main */
|
|
Packit |
bd2e5d |
{
|
|
Packit |
bd2e5d |
int verbose_init = 0,
|
|
Packit |
bd2e5d |
percent_free_init = Percent_free_def;
|
|
Packit |
bd2e5d |
long minor_heap_init = Minor_heap_def,
|
|
Packit |
bd2e5d |
heap_chunk_init = Heap_chunk_def;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
/* Machine-dependent initialization of the floating-point hardware
|
|
Packit |
bd2e5d |
so that it behaves as much as possible as specified in IEEE */
|
|
Packit |
bd2e5d |
init_ieee_floats();
|
|
Packit |
bd2e5d |
init_gc (minor_heap_init, heap_chunk_init, percent_free_init,
|
|
Packit |
bd2e5d |
verbose_init);
|
|
Packit |
bd2e5d |
init_stack();
|
|
Packit |
bd2e5d |
init_atoms();
|
|
Packit |
bd2e5d |
}
|
|
Packit |
bd2e5d |
}
|