/* file: "setup.c" */

/* Copyright (C) 1994-1998 by Marc Feeley, All Rights Reserved. */

/* 
 * This module contains the routines that setup the Scheme program for
 * execution.
 */

#define ___INCLUDED_FROM_SETUP
#define ___VERSION 21
#include "gambit.h"

#include "os.h"
#include "setup.h"
#include "mem.h"
#include "c_intf.h"

#include <stdio.h>
#include <stdlib.h>

/* 
 * Global state structure.
 */

___EXP_DATA(___global_state_struct,___gstate);


/*---------------------------------------------------------------------------*/

/*
 * Global variables needed by this module.
 */

int ___comply_to_standard_scheme; /* Indicates if in standard Scheme mode. */
___WORD ___symbol_table;          /* Hash table of all interned symbols.   */
___WORD ___keyword_table;         /* Hash table of all interned keywords.  */
___WORD ___arguments;             /* List of command line arguments.       */
___WORD ___exec_vector;
___WORD ___internal_return;

___NEED_GLO(___G__23__23_initial_2d_continuation)


/*---------------------------------------------------------------------------*/

/*
 * ___debug_level is non-zero if debugging information is requested.
 */

int ___debug_level = 0;


/* 
 * Length of symbol table and keyword table.
 */

#define SYMKEY_TBL_LENGTH 359


/*---------------------------------------------------------------------------*/

/* 
 * Interrupt handling.
 *
 * '___raise_interrupt (code)' is called when an interrupt has
 * occured.  At some later point in time, the Gambit kernel will cause
 * the Scheme procedure ##interrupt-handler to be called with a single
 * integer argument indicating which interrupt has been received.
 * Interrupt codes are defined in "gambit.h".  Currently, the
 * following codes are defined:
 *
 *   ___INTR_USER    user has interrupted the program (e.g. ctrl-C)
 *   ___INTR_TIMER   interval timer has elapsed
 *   ___INTR_GC      a garbage collection has finished
 */

___EXP_FUNC(void,___raise_interrupt) ___P((int code),(code)
int code;)
{
  ___processor_state pstate = ___PSTATE;

  /* 
   * Note: ___raise_interrupt may be called before the processor state
   * is initialized.  As a consequence, the interrupt(s) received
   * before the initialization of the processor state will be ignored.
   */

  pstate->intr_flag[code] = 1;
  if (pstate->intr_enabled)
    pstate->stack_trip = pstate->stack_base;
}

/*---------------------------------------------------------------------------*/

___HIDDEN void fatal_heap_overflow ___PVOID
{
  ___fatal_error ("Heap overflow during setup");
}

___HIDDEN ___WORD alloc_perm_vector ___P((unsigned long n),(n)
unsigned long n;)
{
  ___WORD result;
  result = ___alloc_scmobj (___sVECTOR, n<<___LWS, ___PERM);
  if (result == ___FAL)
    fatal_heap_overflow ();
  return result;
}

/* 
 * 'make_perm_string_from_charstring (str)' converts the
 * null-terminated C string 'str' to a Scheme string.  A permanent
 * object is allocated.  The value ___FAL is returned if the object
 * can not be allocated.
 */

___HIDDEN ___WORD make_perm_string_from_charstring ___P((char *str),(str)
char *str;)
{
  ___WORD r;
  unsigned long i, n = 0;
  while (str[n] != 0)
    n++;
  r = ___alloc_scmobj (___sSTRING, n<<___LCS, ___PERM);
  if (r == ___FAL)
    fatal_heap_overflow ();
  for (i=0; i<n; i++)
    /* No error possible because a 'char' always fits in a Scheme char. */
    ___STRINGSET(r,___FIX(i),___CHR((unsigned char)str[i]))
  return r;
}

/* 
 * 'make_perm_string_from_utf8string (str)' converts the UTF-8 encoded
 * C string 'str' to a Scheme string.  A permanent object is
 * allocated.  The value ___FAL is returned if the object can not be
 * allocated.
 */

___HIDDEN ___WORD make_perm_string_from_utf8string
   ___P((___UTF8STRING str),(str)
___UTF8STRING str;)
{
  ___WORD r;
  unsigned long i, n = 0;
  ___UTF8STRING p = str;
  while (___utf8_get (&p) != 0) /* advance until end or error */
    n++;
  r = ___alloc_scmobj (___sSTRING, n<<___LCS, ___STILL);
  if (r == ___FAL)
    fatal_heap_overflow ();
  p = str;
  for (i=0; i<n; i++)
    {
      ___UTF8STRING start = p;
      ___UCS4 c = ___utf8_get (&p);
      if (p == start || c > ___MAX_CHR)
        ___fatal_error ("Illegal UTF-8 encoding during setup");
      ___STRINGSET(r,___FIX(i),___CHR(c))
    }
  return r;
}

/*
 * The hashing functions 'hash_utf8string (str)' and 'hash_schemestring (str)'
 * must compute the same value as the function 'targ-hash' in the file
 * "gsc/_t-c-3.scm".
 */

___HIDDEN ___U32 hash_utf8string ___P((___UTF8STRING str),(str)
___UTF8STRING str;)
{
  ___U32 h = 0;
  ___UTF8STRING p = str;
  ___UCS4 c;

  while (1)
    {
      ___UTF8STRING start = p;
      c = ___utf8_get (&p);
      if (p == start || c > ___MAX_CHR)
        ___fatal_error ("Illegal UTF-8 encoding during setup");
      if (c == 0)
        return h & ___MAX_FIX;
      h = (h<<8) + c;
      h = h ^ (h>>24);
    }
}

___HIDDEN ___U32 hash_schemestring ___P((___WORD str),(str)
___WORD str;)
{
  unsigned long i, n = ___INT(___STRINGLENGTH(str));
  ___U32 h = 0;
  for (i=0; i<n; i++)
    {
      h = (h<<8) + ___INT(___STRINGREF(str,___FIX(i)));
      h = h ^ (h>>24);
    }
  return h & ___MAX_FIX;
}

___HIDDEN ___WORD symkey_table ___P((unsigned int subtype),(subtype)
unsigned int subtype;)
{
  switch (subtype)
    {
    case ___sKEYWORD:
      return ___keyword_table;
    default: /* assume ___sSYMBOL */
      return ___symbol_table;
    }
}

___HIDDEN ___WORD find_symkey_from_utf8string
   ___P((char *str, unsigned int subtype),(str, subtype)
char *str;
unsigned int subtype;)
{
  ___WORD tbl = symkey_table (subtype);
  ___U32 h = hash_utf8string (str);
  ___WORD probe = ___FIELD(tbl,h%SYMKEY_TBL_LENGTH);

  while (probe != ___NUL)
    {
      ___WORD obj = ___CAR(probe);
      ___WORD name = ___FIELD(obj,0);
      unsigned long i;
      unsigned long n = ___INT(___STRINGLENGTH(name));
      ___UTF8STRING p = str;
      for (i=0; i<n; i++)
        if (___utf8_get (&p) != (___UCS4)___INT(___STRINGREF(name,___FIX(i))))
          goto next;
      if (___utf8_get (&p) == 0)
        return obj;
    next:
      probe = ___CDR(probe);
    }

  return ___FAL;
}

___WORD ___find_symkey_from_schemestring
   ___P((___WORD str, unsigned int subtype),(str, subtype)
___WORD str;
unsigned int subtype;)
{
  ___WORD tbl = symkey_table (subtype);
  ___U32 h = hash_schemestring (str);
  ___WORD probe = ___FIELD(tbl,h%SYMKEY_TBL_LENGTH);

  while (probe != ___NUL)
    {
      ___WORD obj = ___CAR(probe);
      ___WORD name = ___FIELD(obj,0);
      long i = 0;
      long n = ___INT(___STRINGLENGTH(name));
      if (___INT(___STRINGLENGTH(str)) == n)
        {
          for (i=0; i<n; i++)
            if (___STRINGREF(str,___FIX(i)) != ___STRINGREF(name,___FIX(i)))
              goto next;
          return obj;
        }
    next:
      probe = ___CDR(probe);
    }

  return ___FAL;
}

___WORD ___new_symkey
   ___P((___WORD name, unsigned int subtype),(name, subtype)
___WORD name; /* name must be a permanent object */
unsigned int subtype;)
{
  ___WORD tbl = symkey_table (subtype);
  ___U32 h = hash_schemestring (name);
  ___WORD obj, lst;

  switch (subtype)
    {
    case ___sKEYWORD:
      obj = ___alloc_scmobj (___sKEYWORD, ___KEYWORD_SIZE<<___LWS, ___PERM);
      break;
    default: /* assume ___sSYMBOL */
      obj = ___alloc_scmobj (___sSYMBOL, ___SYMBOL_SIZE<<___LWS, ___PERM);
      break;
    }

  if (obj == ___FAL)
    return ___FAL;

  ___FIELD(obj,0) = name;
  ___FIELD(obj,1) = ___FIX(h);
  if (subtype == ___sSYMBOL)
    ___FIELD(obj,2) = 0;

  h = h % SYMKEY_TBL_LENGTH;

  lst = ___make_pair (obj, ___FIELD(tbl,h), ___PERM);

  if (lst == ___FAL)
    return ___FAL;

  ___FIELD(tbl,h) = lst;

  return obj;
}

___HIDDEN ___WORD make_symkey
   ___P((___UTF8STRING str, unsigned int subtype),(str, subtype)
___UTF8STRING str;
unsigned int subtype;)
{
  ___WORD obj = find_symkey_from_utf8string (str, subtype);

  if (obj == ___FAL)
    {
      obj = ___new_symkey (make_perm_string_from_utf8string (str), subtype);
      if (obj == ___FAL)
        fatal_heap_overflow ();
    }

  return obj;
}

___HIDDEN ___glo_struct *make_global
   ___P((___UTF8STRING str, int supply),(str, supply)
___UTF8STRING str;
int supply;)
{
  ___WORD sym = make_symkey (str, ___sSYMBOL);
  ___WORD glo = ___FIELD(sym,2);
  ___glo_struct *p;

  if (glo != 0)
  {
    p = (___glo_struct*)glo;
    if (supply && (p->val == ___UNB1))
      p->val = ___UNB2;
    return p;
  }
  else
    {
      ___processor_state pstate = ___PSTATE;
      p = ___alloc_global_var ();
      if (p == 0)
        ___fatal_error ("Can't allocate global var");
      p->val = supply?___UNB2:___UNB1;
      p->prm = ___FAL;
      p->next = 0;
      if (pstate->glo_list_head == 0)
        pstate->glo_list_head = (___WORD)p;
      else
        ((___glo_struct*)pstate->glo_list_tail)->next = (___WORD)p;
      pstate->glo_list_tail = (___WORD)p;
      ___FIELD(sym,2) = (___WORD)p;
      return p;
    }
}

___HIDDEN char module_prefix[] = ___MODULE_PREFIX;

#define module_prefix_length (sizeof(module_prefix)-1)

___HIDDEN char c_id_prefix[] =
#ifdef ___IMPORTED_ID_PREFIX
___IMPORTED_ID_PREFIX
#endif
___C_ID_PREFIX;

#define c_id_prefix_length (sizeof(c_id_prefix)-1)

___HIDDEN char c_id_suffix[] =
#ifdef ___IMPORTED_ID_SUFFIX
___IMPORTED_ID_SUFFIX
#endif
"";

#define c_id_suffix_length (sizeof(c_id_suffix)-1)

___HIDDEN char hex_digits[] = "0123456789abcdef";

#define c_id_subsequent(unicode) \
(((unicode)>='A'&&(unicode)<='Z') || \
 ((unicode)>='a'&&(unicode)<='z') || \
 ((unicode)>='0'&&(unicode)<='9') || \
 ((unicode)=='_'))

___HIDDEN int scheme_id_to_c_id
   ___P((char *scm_id, char *c_id, long max_length),(scm_id, c_id, max_length)
char *scm_id;
char *c_id;
long max_length;)
{
  long i = 0;
  long j = 0;
  unsigned char c, c2;
  long k, n;

  while ((c = scm_id[i++]) != '\0')
    {
      if (c == '_')
        {
          if (j+2 > max_length)
            return 0;
          c_id[j++] = '_';
          c_id[j++] = '_';
        }
      else if (c_id_subsequent(c))
        {
          if (j+1 > max_length)
            return 0;
          c_id[j++] = c;
        }
      else
        {
          c2 = c;
          n = 1;
          while (c2 > 15)
            {
              c2 = c2 >> 4;
              n++;
            }
          if (j+n+2 > max_length)
            return 0;
          c_id[j++] = '_';
          for (k=n-1; k>=0; k--)
            {
              c_id[j+k] = hex_digits[c & 15];
              c = c >> 4;
            }
          j += n;
          c_id[j++] = '_';
        }
    }
  if (j+1 > max_length)
    return 0;
  c_id[j++] = '\0';
  return 1;
}

/*---------------------------------------------------------------------------*/

/* Alignment of objects */

___HIDDEN ___WORD *align
   ___P((___WORD *from, long words, int flonum),(from, words, flonum)
___WORD *from;
long words;
int flonum;)
{
  ___WORD *to;
#if ___WS == 4
  if (flonum)
    to = ___ALIGNUP((from+1), (___FLONUM_SIZE<<___LWS)) - 1;
  else
#endif
    to = ___ALIGNUP(from, ___WS);

  if (from != to)
    {
      /* move object up */
      int i;
      for (i=words-1; i>=0; i--)
        to[i] = from[i];
    }
  return to;
}

___HIDDEN ___WORD align_subtyped ___P((___WORD *ptr),(ptr)
___WORD *ptr;)
{
  ___WORD head = ptr[0];
  int subtype = ___HD_SUBTYPE(head);
  int words = ___HD_WORDS(head);
  return ___TAG(align (ptr, words+1, subtype>=___sF64VECTOR), ___tSUBTYPED);
}

/*---------------------------------------------------------------------------*/

/* Routines to setup a module for execution */

___HIDDEN ___mod_or_lnk linker_to_mod_or_lnk
   ___P((___mod_or_lnk (*linker) (___global_state_struct*)),(linker)
___mod_or_lnk (*linker) ();)
{
  ___mod_or_lnk mol = linker (___GSTATE);
  if (mol->module.kind == ___LINKFILE_KIND)
    {
      void **p = mol->linkfile.linker_tbl;
      while (*p != 0)
        {
          *p = linker_to_mod_or_lnk
                 (*(___mod_or_lnk (**) ___P((___global_state_struct*),()))p);
          p++;
        }
    }
  return mol;
}

___HIDDEN int for_each_module
   ___P((___mod_or_lnk mol, int (*proc) (___module_struct*)), (mol, proc)
___mod_or_lnk mol;
int (*proc) ();)
{
  if (mol->module.kind == ___LINKFILE_KIND)
    {
      void **p = mol->linkfile.linker_tbl;
      while (*p != 0)
        {
          int err = for_each_module ((___mod_or_lnk)*p++, proc);
          if (err != 0)
            return err;
        }
      return 0; /* no error */
    }
  else
    return proc ((___module_struct*)mol);
}

___HIDDEN void fixref
   ___P((___WORD *p,
         ___WORD *sym_tbl,
         ___WORD *key_tbl,
         ___WORD *cns_tbl,
         ___WORD *sub_tbl),
        (p, sym_tbl, key_tbl, cns_tbl, sub_tbl)
___WORD *p;
___WORD *sym_tbl;
___WORD *key_tbl;
___WORD *cns_tbl;
___WORD *sub_tbl;)
{
  ___WORD v = *p;
  switch (___TYP(v))
    {
    case ___tPAIR:
      if (___INT(v)<0)
        *p = sym_tbl[-1-___INT(v)];
      else
        *p = ___TAG(___ALIGNUP(&cns_tbl[(___PAIR_SIZE+1)*___INT(v)],___WS),___tPAIR);
      break;

    case ___tSUBTYPED:
      if (___INT(v)<0)
        *p = key_tbl[-1-___INT(v)];
      else
        *p = sub_tbl[___INT(v)];
      break;
    }
}

___HIDDEN int setup_module_phase1 ___P((___module_struct *module),(module)
___module_struct *module;)
{
  int i, j;
  ___WORD *cns;

  char *name       = module->name;
  ___FAKEWORD *glo_tbl= module->glo_tbl;
  int sup_count    = module->sup_count;
  ___UTF8STRING *glo_names = module->glo_names;
  ___WORD *sym_tbl = (___WORD*)module->sym_tbl;
  int sym_count    = module->sym_count;
  ___UTF8STRING *sym_names = module->sym_names;
  ___WORD *key_tbl = (___WORD*)module->key_tbl;
  int key_count    = module->key_count;
  ___UTF8STRING *key_names = module->key_names;
  ___WORD *lp      = module->lp;
  ___WORD *lbl_tbl = (___WORD*)module->lbl_tbl;
  int lbl_count    = module->lbl_count;
  ___WORD *cns_tbl = module->cns_tbl;
  int cns_count    = module->cns_count;
  ___WORD *sub_tbl = (___WORD*)module->sub_tbl;
  int sub_count    = module->sub_count;

  if (___debug_level == 1)
    fprintf (stderr, "setting up module \"%s\"\n", name+module_prefix_length);

  if (module->version < ___VERSION)
    return 1;
  if (module->version > ___VERSION)
    return 2;

  if (cns_tbl != 0)
    cns = align (cns_tbl, (___PAIR_SIZE+1)*cns_count, 0);

  if (glo_names != 0)
    {
      /*
       * Create global variables in reverse order so that global variables
       * bound to c-lambdas are created last.
       */
      i = 0;
      while (glo_names[i] != 0)
        i++;
      while (i-- > 0)
        glo_tbl[i] = (___FAKEWORD)make_global (glo_names[i], i<sup_count);
    }

  if (sym_names != 0)
    {
      i = 0;
      while (sym_names[i] != 0)
        {
          sym_tbl[i] = make_symkey (sym_names[i], ___sSYMBOL);
          i++;
        }
    }
  else
    for (i=sym_count-1; i>=0; i--)
      sym_tbl[i] = ___TAG(___ALIGNUP(sym_tbl[i], ___WS), ___tSUBTYPED);

  if (key_names != 0)
    {
      i = 0;
      while (key_names[i] != 0)
        {
          key_tbl[i] = make_symkey (key_names[i], ___sKEYWORD);
          i++;
        }
    }
  else
    for (i=key_count-1; i>=0; i--)
      key_tbl[i] = ___TAG(___ALIGNUP(key_tbl[i], ___WS), ___tSUBTYPED);

  for (i=sub_count-1; i>=0; i--)
    sub_tbl[i] = align_subtyped ((___WORD*)sub_tbl[i]);

  for (i=cns_count-1; i>=0; i--)
  {
    fixref (cns+i*(___PAIR_SIZE+1)+1, sym_tbl, key_tbl, cns_tbl, sub_tbl);
    fixref (cns+i*(___PAIR_SIZE+1)+2, sym_tbl, key_tbl, cns_tbl, sub_tbl);
  }

  for (j=sub_count-1; j>=0; j--)
    {
      ___WORD *p = ___UNTAG_AS(sub_tbl[j],___tSUBTYPED);
      ___WORD head = p[0];
      int subtype = ___HD_SUBTYPE(head);
      int words = ___HD_WORDS(head);
      switch (subtype)
        {
        case ___sSYMBOL:
        case ___sKEYWORD:
        case ___sVECTOR:
        case ___sRATNUM:
        case ___sCPXNUM:
          for (i=1; i<=words; i++)
            fixref (p+i, sym_tbl, key_tbl, cns_tbl, sub_tbl);
        }
    }

  if (lbl_count > 0)
    {
      ___label_struct *new_lt;
      new_lt = (___label_struct*)align (lbl_tbl, lbl_count*___LS, 0);
      for (i=lbl_count-1; i>=0; i--)
        if (new_lt[i].header == ___MAKE_HD((___INTRO_SIZE<<___LWS),___sVECTOR,___PERM))
          fixref (&new_lt[i].entry, sym_tbl, key_tbl, cns_tbl, sub_tbl);
        else
          new_lt[i].entry = ___TAG(&new_lt[i].header,___tSUBTYPED);
      *lp = ___TAG(new_lt,___tSUBTYPED);
    }

  return 0; /* no error */
}

___HIDDEN int setup_module_phase2 ___P((___module_struct *module),(module)
___module_struct *module;)
{
  int i;

  ___UTF8STRING name = module->name;
  ___FAKEWORD *glo_tbl = module->glo_tbl;
  int glo_count = module->glo_count;
  int sup_count = module->sup_count;
  ___UTF8STRING *glo_names = module->glo_names;

  if (glo_names != 0)
    {
      for (i=sup_count; i<glo_count; i++)
        {
          ___glo_struct *glo = (___glo_struct*)glo_tbl[i];
          if (glo->val == ___UNB1)
            {
              fprintf (stderr,
                       "*** WARNING -- Variable \"%s\" used in module \"%s\" is undefined\n",
                       glo_names[i],
                       name+module_prefix_length);
            }
        }
    }

  module->init_proc ();

  return 0; /* no error */
}

___HIDDEN int setup_modules ___P((___mod_or_lnk mol),(mol)
___mod_or_lnk mol;)
{
  int err;
  err = for_each_module (mol, setup_module_phase1);
  if (err != 0)
    return err;
  return for_each_module (mol, setup_module_phase2);
}

___HIDDEN int module_count;

___HIDDEN int inc_module_count ___P((___module_struct *module),(module)
___module_struct *module;)
{
  if (module->lbl_count > 0)
    module_count++;
  return 0; /* no error */
}

___HIDDEN int count_modules ___P((___mod_or_lnk mol),(mol)
___mod_or_lnk mol;)
{
  module_count = 0;
  for_each_module (mol, inc_module_count);
  return module_count;
}

___HIDDEN ___WORD module_vector;

___HIDDEN int store_in_module_vector ___P((___module_struct *module),(module)
___module_struct *module;)
{
  if (module->lbl_count > 0)
    {
      ___FIELD(module_vector,module_count) = *module->lp+___LS*___WS;
      module_count++;
    }
  return 0; /* no error */
}

___HIDDEN void setup_module_vector
   ___P((___mod_or_lnk mol, ___WORD vect),(mol, vect)
___mod_or_lnk mol;
___WORD vect;)
{
  module_count = 0;
  module_vector = vect;
  for_each_module (mol, store_in_module_vector);
}

___WORD ___load_object_file ___P((char *path, char **errmsg),(path, errmsg)
char *path;
char **errmsg;)
{
  int i;
  char temp1[___PATH_MAX_LENGTH+1];
  char temp2[___PATH_MAX_LENGTH+1];
  char *p;
  void *f;
  ___mod_or_lnk mol;
  ___WORD ev;

  for (i=module_prefix_length-1; i>=0; i--)
    temp2[i] = module_prefix[i];

  if (___path_strip_extension (path,
                               temp1,
                               ___PATH_MAX_LENGTH) == 0 ||
      ___path_strip_directory (temp1,
                               temp2+module_prefix_length,
                               ___PATH_MAX_LENGTH -
                                module_prefix_length) == 0 ||
      scheme_id_to_c_id (temp2,
                         temp1+c_id_prefix_length,
                         ___PATH_MAX_LENGTH -
                          (c_id_prefix_length+c_id_suffix_length)) == 0)
    {
      *errmsg = "path is too long";
      return ___FAL;
    }

  p = temp1;
  for (i=0; i<c_id_prefix_length; i++)
    *p++ = c_id_prefix[i];
  while (*p != '\0')
    p++;
  for (i=0; i<c_id_suffix_length; i++)
    *p++ = c_id_suffix[i];
  *p++ = '\0';

  f = ___dynamic_load (path, temp1, errmsg);
  if (f == 0)
    return ___FAL;

  mol = linker_to_mod_or_lnk
          ((___mod_or_lnk (*) ___P((___global_state_struct*),()))f);
  if (mol->linkfile.version < 0) /* was it already setup? */
    {
      *errmsg = "can't load a given object file more than once";
      return ___FAL;
    }

  switch (setup_modules (mol))
    {
    case 1:
      *errmsg =
        "object file was compiled with an older version of the compiler";
      return ___FAL;
    case 2:
      *errmsg =
        "object file was compiled with a newer version of the compiler";
      return ___FAL;
    }

  mol->linkfile.version = -1; /* mark link file as 'setup' */

  ev = ___alloc_scmobj (___sVECTOR, count_modules (mol)<<___LWS, ___STILL);
  if (ev == ___FAL)
    {
      *errmsg = "heap overflow";
      return ___FAL;
    }

  setup_module_vector (mol, ev);

  ___still_obj_refcount_dec (ev);

  return ev;
}

/*---------------------------------------------------------------------------*/

double ___round ___P((double x),(x)
double x;)
{
  double f, i, t;
  if (x < 0.0)
    {
      f = modf (-x, &i);
      if (f > 0.5 || (f == 0.5 && modf (i*0.5, &t) != 0.0))
        return -(i+1.0);
      else
        return -i;
    }
  else
    {
      f = modf (x, &i);
      if (f > 0.5 || (f == 0.5 && modf (i*0.5, &t) != 0.0))
        return i+1.0;
      else
        return i;
    }
}

#ifdef ___CPU_BIGEND
#define F64_HI8 0
#define F64_HI16 0
#else
#define F64_HI8 7
#define F64_HI16 3
#endif

double ___copysign ___P((double x, double y),(x, y)
double x;
double y;)
{
  ___U8 *px = (___U8*)&x;
  ___U8 *py = (___U8*)&y;

  px[F64_HI8] = (px[F64_HI8] & 0x7f) |
                (py[F64_HI8] & 0x80);

  return x;
}

int ___isfinite ___P((double x),(x)
double x;)
{
  ___U16 *px = (___U16*)&x;

  return ((px[F64_HI16] ^ 0x7ff0) & 0x7fff) >= 0x10;
}

int ___isnan ___P((double x),(x)
double x;)
{
  ___U16 *px = (___U16*)&x;

  return (px[F64_HI16] = (px[F64_HI16] ^ 0x7ff0) & 0x7fff) < 0x10 &&
         (((___U32*)&x)[0] | ((___U32*)&x)[1]) != 0;
}

/*---------------------------------------------------------------------------*/

___HIDDEN void init_symkey_glo1 ___P((___mod_or_lnk mol),(mol)
___mod_or_lnk mol;)
{
  if (mol->module.kind == ___LINKFILE_KIND)
    {
      void **p1 = mol->linkfile.linker_tbl;
      ___FAKEWORD *p2 = mol->linkfile.sym_list;

      while (*p1 != 0)
        init_symkey_glo1 ((___mod_or_lnk)*p1++);

      while (p2 != 0)
        {
          ___WORD *sym_ptr;
          ___glo_struct *glo;

          sym_ptr = (___WORD*)p2;

          p2 = (___FAKEWORD*)sym_ptr[0];
          glo = (___glo_struct*)sym_ptr[3];

          sym_ptr[2] = glo->prm; /* move symbol's hash value */
        }
    }
}

___HIDDEN void init_symkey_glo2 ___P((___mod_or_lnk mol),(mol)
___mod_or_lnk mol;)
{
  if (mol->module.kind == ___LINKFILE_KIND)
    {
      void **p1 = mol->linkfile.linker_tbl;
      ___FAKEWORD *p2 = mol->linkfile.sym_list;
      ___FAKEWORD *p3 = mol->linkfile.key_list;
      ___processor_state pstate = ___PSTATE;

      while (*p1 != 0)
        init_symkey_glo2 ((___mod_or_lnk)*p1++);

      while (p2 != 0)
        {
          ___U32 h;
          ___WORD sym, lst, str;
          ___WORD *sym_ptr;
          ___glo_struct *glo;

          sym_ptr = (___WORD*)p2;

          p2 = (___FAKEWORD*)sym_ptr[0];
          str = align_subtyped ((___WORD*)sym_ptr[1]);
          glo = (___glo_struct*)sym_ptr[3];

          glo->next = 0;
          if (pstate->glo_list_head == 0)
            pstate->glo_list_head = (___WORD)glo;
          else
            ((___glo_struct*)pstate->glo_list_tail)->next = (___WORD)glo;
          pstate->glo_list_tail = (___WORD)glo;

          *sym_ptr = ___MAKE_HD((___SYMBOL_SIZE<<___LWS),___sSYMBOL,___PERM);

          sym = align_subtyped (sym_ptr);

          h = ___INT(___FIELD(sym,1)); /* symbols are pre-hashed */

          ___FIELD(sym,0) = str;
          ___FIELD(sym,2) = (___WORD)glo;

          h = h % SYMKEY_TBL_LENGTH;

          lst = ___make_pair (sym, ___FIELD(___symbol_table,h), ___PERM);
          if (lst == ___FAL)
            fatal_heap_overflow ();

          ___FIELD(___symbol_table,h) = lst;
        }

      while (p3 != 0)
        {
          ___U32 h;
          ___WORD key, lst, str;
          ___WORD *key_ptr;

          key_ptr = (___WORD*)p3;

          p3 = (___FAKEWORD*)key_ptr[0];
          str = align_subtyped ((___WORD*)key_ptr[1]);

          *key_ptr = ___MAKE_HD((___KEYWORD_SIZE<<___LWS),___sKEYWORD,___PERM);

          key = align_subtyped (key_ptr);

          h = hash_schemestring (str);

          ___FIELD(key,0) = str;
          ___FIELD(key,1) = ___FIX(h);

          h = h % SYMKEY_TBL_LENGTH;

          lst = ___make_pair (key, ___FIELD(___keyword_table,h), ___PERM);
          if (lst == ___FAL)
            fatal_heap_overflow ();

          ___FIELD(___keyword_table,h) = lst;
        }
    }
}


/*---------------------------------------------------------------------------*/

/* C to Scheme call handler */

___EXP_FUNC(int,___call) ___P((int nargs, ___WORD proc),(nargs, proc)
int nargs;
___WORD proc;)
{
  int ___err;
  ___processor_state ___ps = ___PSTATE;
  ___WORD *___fp = ___ps->fp;
  ___WORD stack_marker = *___fp;

  /* 
   * The stack marker indicates if the stack frame of the **caller** C
   * function is still active (i.e. it hasn't returned yet).  When the
   * caller returns, #f will be stored in the stack marker so that any
   * subsequent attempt to return to that invocation of the caller will
   * be detected and trigger an error.  The stack marker is created by
   * the caller.
   */

  ___LD_ARG_REGS

  ___fp -= nargs;

  ___POP_ARGS_IN_REGS(nargs)

  ___ST_ARG_REGS

  ___ps->fp = ___fp;
  ___ps->na = nargs;
  ___ps->pc = ((___label_struct*)(proc-___tSUBTYPED))->entry;
  ___PSSELF = proc;

again:

  {
    ___BEGIN_CATCH

    ___WORD ___pc = ___ps->pc;

    while (___TYP(___pc) == ___tSUBTYPED &&
           ___SUBTYPE(___pc) == ___FIX(___sPROCEDURE))
      ___pc = ___CAST_FAKEHOST_TO_HOST(((___label_struct*)(___pc-___tSUBTYPED))->host)(___ps);

    ___fatal_error ("Jump to illegal PC");

    ___END_CATCH
  }

  if (___err != ___NO_ERR)
    if (___err == ___UNWIND_C_STACK)
      {
        ___WORD unwind_destination = *___ps->fp;
        if (stack_marker == unwind_destination) /* unwinding done? */
          ___err = ___NO_ERR;
      }
    else
      {
        ___fatal_error ("unhandled error");
        goto again;
      }

  return ___err;
}

___EXP_FUNC(void,___propagate_error) ___P((int err),(err)
int err;)
{
  ___processor_state ___ps = ___PSTATE;
  if (err != ___NO_ERR)
    ___THROW (err);
}

/*---------------------------------------------------------------------------*/

/*
 * Setup program and execute it.
 */

___HIDDEN int setup_state = 0; /* 0=pre-setup, 1=post-setup, 2=post-cleanup */

___EXP_FUNC(void,___cleanup) ___PVOID
{
  /*
   * Only do cleanup once after successful setup.
   */

  if (setup_state != 1)
    return;

  setup_state = 2;

  ___cleanup_mem ();
  ___cleanup_os ();
}

___EXP_FUNC(void,___setup)
   ___P((___setup_params_struct *setup_params),(setup_params)
___setup_params_struct *setup_params;)
{
  ___processor_state ___ps;
  ___mod_or_lnk mol;
  int i;

  /*
   * Only do setup once.
   */

  if (setup_state != 0)
    return;

  setup_state = 2; /* in case setup fails */

  /*
   * Setup debugging level.
   */

  ___debug_level = setup_params->debug_level;

  /* 
   * Setup the operating system module.
   */

  ___setup_os (setup_params);

  /* 
   * Setup stack and heap.
   */

  ___setup_mem (setup_params);

  /* 
   * Setup global state to avoid problems on systems that don't
   * support the dynamic loading of files that import functions.
   */

#ifdef ___CANT_IMPORT_CLIB_DYNAMICALLY

  ___GSTATE->fabs  = fabs;
  ___GSTATE->floor = floor;
  ___GSTATE->ceil  = ceil;
  ___GSTATE->exp   = exp;
  ___GSTATE->log   = log;
  ___GSTATE->sin   = sin;
  ___GSTATE->cos   = cos;
  ___GSTATE->tan   = tan;
  ___GSTATE->asin  = asin;
  ___GSTATE->acos  = acos;
  ___GSTATE->atan  = atan;
  ___GSTATE->atan2 = atan2;
  ___GSTATE->sqrt  = sqrt;

#endif

#ifdef ___USE_SETJMP
#ifdef ___CANT_IMPORT_SETJMP_DYNAMICALLY

  ___GSTATE->setjmp = setjmp;

#endif
#endif

#ifdef ___CANT_IMPORT_DYNAMICALLY

  ___GSTATE->___copysign = ___copysign;
  ___GSTATE->___isfinite = ___isfinite;
  ___GSTATE->___isnan    = ___isnan;
  ___GSTATE->___round    = ___round;

  ___GSTATE->___scmobj_to_char         = ___scmobj_to_char;
  ___GSTATE->___scmobj_to_schar        = ___scmobj_to_schar;
  ___GSTATE->___scmobj_to_uchar        = ___scmobj_to_uchar;
  ___GSTATE->___scmobj_to_latin1       = ___scmobj_to_latin1;
  ___GSTATE->___scmobj_to_ucs4         = ___scmobj_to_ucs4;
  ___GSTATE->___scmobj_to_ucs2         = ___scmobj_to_ucs2;
  ___GSTATE->___scmobj_to_short        = ___scmobj_to_short;
  ___GSTATE->___scmobj_to_ushort       = ___scmobj_to_ushort;
  ___GSTATE->___scmobj_to_int          = ___scmobj_to_int;
  ___GSTATE->___scmobj_to_uint         = ___scmobj_to_uint;
  ___GSTATE->___scmobj_to_long         = ___scmobj_to_long;
  ___GSTATE->___scmobj_to_ulong        = ___scmobj_to_ulong;
  ___GSTATE->___scmobj_to_float        = ___scmobj_to_float;
  ___GSTATE->___scmobj_to_double       = ___scmobj_to_double;
  ___GSTATE->___scmobj_to_pointer      = ___scmobj_to_pointer;
  ___GSTATE->___scmobj_to_function     = ___scmobj_to_function;
  ___GSTATE->___scmobj_to_bool         = ___scmobj_to_bool;
  ___GSTATE->___scmobj_to_charstring   = ___scmobj_to_charstring;
  ___GSTATE->___scmobj_to_latin1string = ___scmobj_to_latin1string;
  ___GSTATE->___scmobj_to_ucs4string   = ___scmobj_to_ucs4string;
  ___GSTATE->___scmobj_to_ucs2string   = ___scmobj_to_ucs2string;
  ___GSTATE->___scmobj_to_utf8string   = ___scmobj_to_utf8string;
  ___GSTATE->___free_function          = ___free_function;
  ___GSTATE->___free_string            = ___free_string;
  ___GSTATE->___char_to_scmobj         = ___char_to_scmobj;
  ___GSTATE->___schar_to_scmobj        = ___schar_to_scmobj;
  ___GSTATE->___uchar_to_scmobj        = ___uchar_to_scmobj;
  ___GSTATE->___latin1_to_scmobj       = ___latin1_to_scmobj;
  ___GSTATE->___ucs4_to_scmobj         = ___ucs4_to_scmobj;
  ___GSTATE->___ucs2_to_scmobj         = ___ucs2_to_scmobj;
  ___GSTATE->___short_to_scmobj        = ___short_to_scmobj;
  ___GSTATE->___ushort_to_scmobj       = ___ushort_to_scmobj;
  ___GSTATE->___int_to_scmobj          = ___int_to_scmobj;
  ___GSTATE->___uint_to_scmobj         = ___uint_to_scmobj;
  ___GSTATE->___long_to_scmobj         = ___long_to_scmobj;
  ___GSTATE->___ulong_to_scmobj        = ___ulong_to_scmobj;
  ___GSTATE->___float_to_scmobj        = ___float_to_scmobj;
  ___GSTATE->___double_to_scmobj       = ___double_to_scmobj;
  ___GSTATE->___pointer_to_scmobj      = ___pointer_to_scmobj;
  ___GSTATE->___function_to_scmobj     = ___function_to_scmobj;
  ___GSTATE->___bool_to_scmobj         = ___bool_to_scmobj;
  ___GSTATE->___charstring_to_scmobj   = ___charstring_to_scmobj;
  ___GSTATE->___latin1string_to_scmobj = ___latin1string_to_scmobj;
  ___GSTATE->___ucs4string_to_scmobj   = ___ucs4string_to_scmobj;
  ___GSTATE->___ucs2string_to_scmobj   = ___ucs2string_to_scmobj;
  ___GSTATE->___utf8string_to_scmobj   = ___utf8string_to_scmobj;
  ___GSTATE->___make_cdef_stack_marker = ___make_cdef_stack_marker;
  ___GSTATE->___kill_cdef_stack_marker = ___kill_cdef_stack_marker;
  ___GSTATE->___release_scmobj         = ___release_scmobj;

  ___GSTATE->___alloc_scmobj           = ___alloc_scmobj;
  ___GSTATE->___make_pair              = ___make_pair;
  ___GSTATE->___make_vector            = ___make_vector;
  ___GSTATE->___make_string            = ___make_string;
  ___GSTATE->___still_obj_refcount_inc = ___still_obj_refcount_inc;
  ___GSTATE->___still_obj_refcount_dec = ___still_obj_refcount_dec;

  ___GSTATE->___cleanup                = ___cleanup;
  ___GSTATE->___call                   = ___call;
  ___GSTATE->___propagate_error        = ___propagate_error;
  ___GSTATE->___raise_interrupt        = ___raise_interrupt;

#endif

  /* 
   * Get processor state.
   */

  ___ps = ___PSTATE;

  /* 
   * Setup exception handling.
   */


#ifdef ___USE_SETJMP

  ___ps->catcher = 0;

#endif

  /* 
   * Setup interrupt system.
   */

  ___ps->stack_trip = ___ps->stack_limit;

  ___ps->intr_enabled = 0; /* disable interrupts */
  for (i=0; i<___NB_INTRS; i++)
    ___ps->intr_flag[i] = 0;
  ___ps->intr_enabled = 1; /* enable interrupts */

  /* 
   * Setup will lists.
   */

  ___ps->executable_wills = ___TAG(0,___EXEC_WILL); /* tagged empty list */
  ___ps->non_executable_wills = ___TAG(0,0); /* tagged empty list */

  /*
   * Setup program's linker structure.
   */

  mol = linker_to_mod_or_lnk (setup_params->linker);

  /* 
   * Create empty symbol table, keyword table, and global
   * variable list.
   */

  ___symbol_table = alloc_perm_vector (SYMKEY_TBL_LENGTH);
  for (i=0; i<SYMKEY_TBL_LENGTH; i++)
    ___FIELD(___symbol_table,i) = ___NUL;

  ___keyword_table = alloc_perm_vector (SYMKEY_TBL_LENGTH);
  for (i=0; i<SYMKEY_TBL_LENGTH; i++)
    ___FIELD(___keyword_table,i) = ___NUL;

  ___ps->glo_list_head = 0;
  ___ps->glo_list_tail = 0;

  /* 
   * Initialize symbol table, keyword table, global variables
   * and primitives.
   */

  init_symkey_glo1 (mol);
  init_symkey_glo2 (mol);

  /* 
   * Setup each module.
   */

  switch (setup_modules (mol))
    {
    case 1:
      ___fatal_error
        ("Module was compiled with an older version of the compiler");
    case 2:
      ___fatal_error
        ("Module was compiled with a newer version of the compiler");
    }

  /* 
   * Create execution vector.
   */

  ___exec_vector = alloc_perm_vector (count_modules (mol));
  setup_module_vector (mol, ___exec_vector);

  /* 
   * Create list of command line arguments (accessible through ##argv).
   */

  {
    int argc = setup_params->argc;
    char **argv = setup_params->argv;
    char *dummy_argv[2];
    if (argc < 1) /* use dummy program name if none supplied */
      {
        dummy_argv[0] = "";
        dummy_argv[1] = 0;
        argc = 1;
        argv = dummy_argv;
      }
    ___arguments = ___NUL;
    for (i=argc-1; i>=0; i--)
      {
        ___WORD arg = make_perm_string_from_charstring (argv[i]);
        ___WORD x = ___make_pair (arg, ___arguments, ___PERM);
        if (x == ___FAL)
          fatal_heap_overflow ();
        ___arguments = x;
      }
  }

  /*
   * Setup standard compliance flag.
   */

  ___comply_to_standard_scheme = setup_params->standard;

  /* 
   * Setup kernel handlers.
   */

  {
    ___WORD ___start = ___G__23__23_initial_2d_continuation.prm;

#define ___PH_LBL0 1

    /*
     * The label numbers must match those in the procedure
     * "##initial-continuation" in the file "_kernel.scm".
     */

    ___internal_return             = ___LBL(1);
    ___ps->handler_break           = ___LBL(2);
    ___ps->handler_stack_limit     = ___LBL(3);
    ___ps->handler_heap_limit      = ___LBL(4);
    ___ps->handler_not_proc        = ___LBL(5);
    ___ps->handler_not_proc_glo    = ___LBL(6);
    ___ps->handler_wrong_nargs     = ___LBL(7);
    ___ps->handler_get_rest        = ___LBL(8);
    ___ps->handler_get_key         = ___LBL(9);
    ___ps->handler_get_key_rest    = ___LBL(10);
    ___ps->handler_force           = ___LBL(11);
    ___ps->handler_clam_conv_error = ___LBL(12);
    ___ps->handler_cdef_conv_error = ___LBL(13);
    ___ps->handler_return_to_c     = ___LBL(14);
    ___ps->initial_continuation    = ___LBL(15);
  }

  /*
   * Create "break frame" of initial top section.
   */

  ___ps->fp[-1] = 0;
  ___ps->fp[-2] = 0;
  ___ps->fp -= 2;
  ___ps->stack_break = ___ps->fp;

  /*
   * Create continuation frame of initial continuation.
   */

  ___ps->fp[-1] = ___ps->handler_break; /* return address */
  ___ps->fp[-2] = ___FAL;               /* space for the stack marker */
  ___ps->fp -= 2;

  /* 
   * Call kernel to start executing program.
   */

  {
    ___WORD marker;
    if (___make_cdef_stack_marker (&marker) != ___NO_ERR)
      fatal_heap_overflow ();
  }

  for (i=1; i<___NB_GVM_REGS; i++)
    ___ps->r[i] = ___VOID;

  ___ps->r[0] = ___ps->initial_continuation;

  setup_state = 1; /* allow cleanup */

  ___call (0, ___FIELD(___exec_vector,0));
}

/*---------------------------------------------------------------------------*/