l4/pkg/ocaml/ocaml/contrib/otherlibs/labltk/support/cltkDMain.c

   1 /*************************************************************************/
   2 /*                                                                       */
   3 /*                Objective Caml LablTk library                          */
   4 /*                                                                       */
   5 /*         Francois Rouaix, Francois Pessaux and Jun Furuse              */
   6 /*               projet Cristal, INRIA Rocquencourt                      */
   7 /*            Jacques Garrigue, Kyoto University RIMS                    */
   8 /*                                                                       */
   9 /*   Copyright 1999 Institut National de Recherche en Informatique et    */
  10 /*   en Automatique and Kyoto University.  All rights reserved.          */
  11 /*   This file is distributed under the terms of the GNU Library         */
  12 /*   General Public License, with the special exception on linking       */
  13 /*   described in file ../../../LICENSE.                                 */
  14 /*                                                                       */
  15 /*************************************************************************/
  16
  17 /* $Id: cltkDMain.c 8899 2008-07-01 09:55:52Z weis $ */
  18
  19 #include <unistd.h>
  20 #include <fcntl.h>
  21 #include <tcl.h>
  22 #include <tk.h>
  23 #include "gc.h"
  24 #include "exec.h"
  25 #include "sys.h"
  26 #include "fail.h"
  27 #include "io.h"
  28 #include "mlvalues.h"
  29 #include "memory.h"
  30 #include "camltk.h"
  31
  32 #ifndef O_BINARY
  33 #define O_BINARY 0
  34 #endif
  35
  36
  37 /*
  38  * Dealing with signals: when a signal handler is defined in Caml,
  39  * the actual execution of the signal handler upon reception of the
  40  * signal is delayed until we are sure we are out of the GC.
  41  * If a signal occurs during the MainLoop, we would have to wait
  42  *  the next event for the handler to be invoked.
  43  * The following function will invoke a pending signal handler if any,
  44  * and we put in on a regular timer.
  45  */
  46
  47 #define SIGNAL_INTERVAL 300
  48
  49 int signal_events = 0; /* do we have a pending timer */
  50
  51 void invoke_pending_caml_signals (clientdata)
  52      ClientData clientdata;
  53 {
  54   signal_events = 0;
  55   enter_blocking_section(); /* triggers signal handling */
  56   /* Rearm timer */
  57   Tk_CreateTimerHandler(SIGNAL_INTERVAL, invoke_pending_caml_signals, NULL);
  58   signal_events = 1;
  59   leave_blocking_section();
  60 }
  61 /* The following is taken from byterun/startup.c */
  62 header_t atom_table[256];
  63 code_t start_code;
  64 asize_t code_size;
  65
  66 static void init_atoms()
  67 {
  68   int i;
  69   for(i = 0; i < 256; i++) atom_table[i] = Make_header(0, i, White);
  70 }
  71
  72 static unsigned long read_size(p)
  73      unsigned char * p;
  74 {
  75   return ((unsigned long) p[0] << 24) + ((unsigned long) p[1] << 16) +
  76          ((unsigned long) p[2] << 8) + p[3];
  77 }
  78
  79 #define FILE_NOT_FOUND (-1)
  80 #define TRUNCATED_FILE (-2)
  81 #define BAD_MAGIC_NUM (-3)
  82
  83 static int read_trailer(fd, trail)
  84      int fd;
  85      struct exec_trailer * trail;
  86 {
  87   char buffer[TRAILER_SIZE];
  88
  89   lseek(fd, (long) -TRAILER_SIZE, 2);
  90   if (read(fd, buffer, TRAILER_SIZE) < TRAILER_SIZE) return TRUNCATED_FILE;
  91   trail->code_size = read_size(buffer);
  92   trail->data_size = read_size(buffer+4);
  93   trail->symbol_size = read_size(buffer+8);
  94   trail->debug_size = read_size(buffer+12);
  95   if (strncmp(buffer + 16, EXEC_MAGIC, 12) == 0)
  96     return 0;
  97   else
  98     return BAD_MAGIC_NUM;
  99 }
 100
 101 int attempt_open(name, trail, do_open_script)
 102      char ** name;
 103      struct exec_trailer * trail;
 104      int do_open_script;
 105 {
 106   char * truename;
 107   int fd;
 108   int err;
 109   char buf [2];
 110
 111   truename = searchpath(*name);
 112   if (truename == 0) truename = *name; else *name = truename;
 113   fd = open(truename, O_RDONLY | O_BINARY);
 114   if (fd == -1) return FILE_NOT_FOUND;
 115   if (!do_open_script){
 116     err = read (fd, buf, 2);
 117     if (err < 2) { close(fd); return TRUNCATED_FILE; }
 118     if (buf [0] == '#' && buf [1] == '!') { close(fd); return BAD_MAGIC_NUM; }
 119   }
 120   err = read_trailer(fd, trail);
 121   if (err != 0) { close(fd); return err; }
 122   return fd;
 123 }
 124
 125
 126 /* Command for loading the bytecode file */
 127 int CamlRunCmd(dummy, interp, argc, argv)
 128     ClientData dummy;                   /* Not used. */
 129     Tcl_Interp *interp;                 /* Current interpreter. */
 130     int argc;                           /* Number of arguments. */
 131     char **argv;                        /* Argument strings. */
 132 {
 133   int fd;
 134   struct exec_trailer trail;
 135   struct longjmp_buffer raise_buf;
 136   struct channel * chan;
 137
 138   if (argc < 2) {
 139         Tcl_AppendResult(interp, "wrong # args: should be \"",
 140                 argv[0], " foo.cmo args\"", (char *) NULL);
 141         return TCL_ERROR;
 142   }
 143   fd = attempt_open(&argv[1], &trail, 1);
 144
 145   switch(fd) {
 146   case FILE_NOT_FOUND:
 147     fatal_error_arg("Fatal error: cannot find file %s\n", argv[1]);
 148     break;
 149   case TRUNCATED_FILE:
 150   case BAD_MAGIC_NUM:
 151     fatal_error_arg(
 152                     "Fatal error: the file %s is not a bytecode executable file\n",
 153                     argv[1]);
 154     break;
 155   }
 156
 157   if (sigsetjmp(raise_buf.buf, 1) == 0) {
 158
 159     external_raise = &raise_buf;
 160
 161     lseek(fd, - (long) (TRAILER_SIZE + trail.code_size + trail.data_size
 162                         + trail.symbol_size + trail.debug_size), 2);
 163
 164     code_size = trail.code_size;
 165     start_code = (code_t) stat_alloc(code_size);
 166     if (read(fd, (char *) start_code, code_size) != code_size)
 167       fatal_error("Fatal error: truncated bytecode file.\n");
 168
 169 #ifdef ARCH_BIG_ENDIAN
 170     fixup_endianness(start_code, code_size);
 171 #endif
 172
 173     chan = open_descr(fd);
 174     global_data = input_value(chan);
 175     close_channel(chan);
 176     /* Ensure that the globals are in the major heap. */
 177     oldify(global_data, &global_data);
 178
 179     sys_init(argv + 1);
 180     interprete(start_code, code_size);
 181     return TCL_OK;
 182   } else {
 183     Tcl_AppendResult(interp, "Caml program", argv[1], " raised exception \"",
 184                      String_val(Field(Field(exn_bucket, 0), 0)));
 185     return TCL_ERROR;
 186   }
 187 }
 188
 189 int CamlInvokeCmd(dummy
 190
 191
 192
 193 /* Now the real Tk stuff */
 194 Tk_Window cltk_mainWindow;
 195
 196 #define RCNAME ".camltkrc"
 197 #define CAMLCB "camlcb"
 198
 199 /* Initialisation of the dynamically loaded module */
 200 int Caml_Init(interp)
 201      Tcl_Interp *interp;
 202 {
 203   cltclinterp = interp;
 204   /* Create the camlcallback command */
 205   Tcl_CreateCommand(cltclinterp,
 206                     CAMLCB, CamlCBCmd,
 207                     (ClientData)NULL,(Tcl_CmdDeleteProc *)NULL);
 208
 209   /* This is required by "unknown" and thus autoload */
 210   Tcl_SetVar(cltclinterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY);
 211   /* Our hack for implementing break in callbacks */
 212   Tcl_SetVar(cltclinterp, "BreakBindingsSequence", "0", TCL_GLOBAL_ONLY);
 213
 214   /* Load the traditional rc file */
 215   {
 216     char *home = getenv("HOME");
 217     if (home != NULL) {
 218       char *f = stat_alloc(strlen(home)+strlen(RCNAME)+2);
 219       f[0]='\0';
 220       strcat(f, home);
 221       strcat(f, "/");
 222       strcat(f, RCNAME);
 223       if (0 == access(f,R_OK))
 224         if (TCL_OK != Tcl_EvalFile(cltclinterp,f)) {
 225           stat_free(f);
 226           tk_error(cltclinterp->result);
 227         };
 228       stat_free(f);
 229     }
 230   }
 231
 232   /* Initialisations from caml_main */
 233   {
 234     int verbose_init = 0,
 235         percent_free_init = Percent_free_def;
 236     long minor_heap_init = Minor_heap_def,
 237          heap_chunk_init = Heap_chunk_def;
 238
 239     /* Machine-dependent initialization of the floating-point hardware
 240        so that it behaves as much as possible as specified in IEEE */
 241     init_ieee_floats();
 242     init_gc (minor_heap_init, heap_chunk_init, percent_free_init,
 243              verbose_init);
 244     init_stack();
 245     init_atoms();
 246   }
 247 }