/* Moscow SML primitives */

#include <math.h>
#include <sys/time.h>
#include <sys/times.h>
#include <sys/resource.h>
#include <dirent.h>
#include <errno.h>
#include <stdio.h>
#include <stdlib.h>
#include <sys/param.h> 
#include <sys/stat.h>
#include <time.h>
#include <unistd.h>
#include <utime.h>
#include <ctype.h>
#include "fail.h"
#include "memory.h"
#include "str.h"
#include "runtime.h"

#if defined(sun) && !defined(__svr4__)
#define tm2cal(tptr)	timelocal(tptr)
#else
#define tm2cal(tptr)	mktime(tptr)
#endif

#define Raise_float_if(cond) \
   if( cond ) \
      { mlraise(Atom(float_exn)); }

#define Check_float(dval) \
   Raise_float_if( (dval > maxdouble) || (dval < -maxdouble) )

/* Structural equality on trees. */
/* Note how reference cells are treated! */

static int sml_equal_aux(v1, v2)
     value v1,v2;
{
  mlsize_t i;
  value * p1, * p2;

 again:
  if (v1 == v2) return 1;
  if (Is_long(v1) || Is_long(v2)) return 0;
  if (!Is_in_heap(v1) && !Is_young(v1)) return 0;
  if (!Is_in_heap(v2) && !Is_young(v2)) return 0;
  if (Tag_val(v1) != Tag_val(v2)) return 0;
  switch(Tag_val(v1)) {
  case String_tag:
    return (compare_strings(v1, v2) == Val_long(0));
  case Double_tag:
    return (Double_val(v1) == Double_val(v2));
  case Reference_tag:  /* Different reference cells are not equal! */
  case Abstract_tag:
  case Final_tag:
    return 0;
  case Closure_tag:
    invalid_argument("sml_equal: functional value");
  default:
    i = Wosize_val(v1);
    if (i != Wosize_val(v2)) return 0;
    for(p1 = Op_val(v1), p2 = Op_val(v2);
        i > 1;
        i--, p1++, p2++)
      if (!sml_equal_aux(*p1, *p2)) return 0;
    v1 = *p1;
    v2 = *p2;                   /* Tail-call */
    goto again;
  }
}

value sml_equal(v1, v2) /* ML */
     value v1, v2;
{
  return Atom(sml_equal_aux(v1,v2));
}

value sml_not_equal(v1, v2) /* ML */
     value v1, v2;
{
  return Atom(!sml_equal_aux(v1,v2));
}

value sml_system(cmd)        /* ML */
     value cmd;
{
  return Val_int(system(String_val(cmd)));
}

value sml_abs_int(x)          /* ML */
    value x;
{ value tmp, v;
  tmp = Long_val(x);
  if( tmp < 0 ) tmp = -tmp;
  v = Val_long(tmp);
  if( Long_val(v) != tmp )
    mlraise(Atom(SMLEXN_OVF));
  return v;
}

value sml_floor(f)              /* ML */
     value f;
{ double r;
  long i;
  value v;
  r = Double_val(f);
  if( r >= 0.0 )
    { if( r >= ((double) (Max_long+1)) ) goto raise_floor;
      i = (long) r;
    }
  else
    { if( r < ((double) Min_long) ) goto raise_floor;
      i = (long) r;
      if( r < ((double) i) ) i -= 1;
    }
  v = Val_long(i);
  if( Long_val(v) != i )  goto raise_floor;
  return v;

raise_floor:
    mlraise(Atom(SMLEXN_OVF));
}

value sml_ceil(f)              /* ML */
     value f;
{ double r;
  long i;
  value v;
  r = Double_val(f);
  if( r >= 0.0 )
    { if( r > ((double) (Max_long)) ) goto raise_ceil;
      i = (long) r;
      if( r > ((double) i) ) i += 1;
    }
  else
    { if( r <= ((double) (Min_long-1)) ) goto raise_ceil;
      i = (long) r;
    }
  v = Val_long(i);
  if( Long_val(v) != i )  goto raise_ceil;
  return v;

raise_ceil:
    mlraise(Atom(SMLEXN_OVF));
}

#ifdef __MWERKS__
#include <Types.h>
double_t nearbyint ( double_t x );
#define rint nearbyint
#endif

value sml_round(f)              /* ML */
     value f;
{ double r;
  long i;
  value v;
  /* Apparently no rint() in djgpp's libm: */
#if defined(MSDOS) || defined(hpux)
  r = Double_val(f);
  if( r >= 0.0 )
    { if( (r+0.5) >= ((double) (Max_long+1)) ) goto raise_round;
      i = (long) (r+0.5);
    }
  else
    { if( (r-0.5) < ((double) Min_long) ) goto raise_round;
      i = (long) (r-0.5);
    }
  v = Val_long(i);
  if( Long_val(v) != i )  goto raise_round;
#else
  r = rint(Double_val(f));
  if ((r > (double) (Max_long)) || (r < (double)(Min_long))) goto raise_round;
  i = (long) r;
  v = Val_long(i);
#endif

  return v;

raise_round:
    mlraise(Atom(SMLEXN_OVF));
}

value sml_trunc(f)              /* ML */
     value f;
{ double r;
  long i;
  value v;
  r = Double_val(f);
  if ((r >= (double) (Max_long+1)) || (r <= (double)(Min_long-1))) 
    goto raise_trunc;
  i = (long) r;
  v = Val_long(i);
  return v;

raise_trunc:
    mlraise(Atom(SMLEXN_OVF));
}

value sml_abs_real(f)              /* ML */
     value f;
{ double r;
  float_exn = SMLEXN_OVF;
  r = Double_val(f);
  if( r >= 0.0 )
    return f;
  else
    r = -r;
    Check_float(r);
    return copy_double(r);
}

value sml_sqrt(f)         /* ML */
     value f;
{ double r;
  float_exn = SMLEXN_DOMAIN;
  r = Double_val(f);
  Raise_float_if( r < 0.0 );
  r = sqrt(r);
  Check_float(r);
  return copy_double(r);
}

value sml_sin(f)         /* ML */
     value f;
{ double r;
  r = Double_val(f);
  r = sin(r);
  if( r != r || r > 1.0 || r < -1.0 )
    failwith("sin: argument too large");
  return copy_double(r);
}

value sml_cos(f)         /* ML */
     value f;
{ double r;
  r = Double_val(f);
  r = cos(r);
  if( r != r || r > 1.0 || r < -1.0 )
    failwith("cos: argument too large");
  return copy_double(r);
}

value sml_exp(f)           /* ML */
     value f;
{ double r;
  float_exn = SMLEXN_OVF;
  r = exp(Double_val(f));
  Check_float(r);
  return copy_double(r);
}

value sml_ln(f)           /* ML */
     value f;
{ double r;
  float_exn = SMLEXN_DOMAIN;
  r = Double_val(f);
  Raise_float_if( r <= 0.0 );
  r = log(r);
  Check_float(r);
  return copy_double(r);
}

value scandec(p, max)
     char *p;
     unsigned long max;
{ unsigned long res;
  int c, d;
  res = 0;
  while (1) {
    c = *p;
    if (c >= '0' && c <= '9')
      d = c - '0';
    else
      break;
    if( (res > (max/10)) ||
        ((res == (max/10) && ((max % 10) <= d))) )
      goto raise_failure;
    res = 10 * res + d;
    p++;
  }
  if (*p != 0)
    goto raise_failure;
  return res;

  raise_failure:
    failwith("scandec");
}

value scanhex(p, max)
     char *p;
     unsigned long max;
{ unsigned long res;
  int c, d;
  res = 0;
  while (1) {
    c = toupper(*p);
    if (c >= '0' && c <= '9')
      d = c - '0';
    else if (c >= 'A' && c <= 'F')
      d = c + (10 - 'A');
    else
      break;
    if( (res > (max/16)) ||
        ((res == (max/16) && ((max % 16) <= d))) )
      goto raise_failure;
    res = 16 * res + d;
    p++;
  }
  if (*p != 0)
    goto raise_failure;
  return res;

  raise_failure:
    failwith("scandec");
}

value sml_int_of_string(s)          /* ML */
     value s;
{ value v;
  long res;
  int sign;
  char * p;

  p = String_val(s);
  sign = 1;
  if (*p == '~') {
    sign = -1;
    p++;
  }
  res = sign * scandec(p, (unsigned long)Min_long);
  v = Val_long(res);
  if( Long_val(v) != res )
    goto raise_failure;
  return v;

  raise_failure:
    failwith("sml_int_of_string");
}

value sml_concat(s1, s2)        /* ML */
     value s1, s2;
{
  mlsize_t len1, len2, len;
  value s;
  Push_roots(r, 2);
  r[0] = s1;
  r[1] = s2;
  len1 = string_length(s1);
  len2 = string_length(s2);
  len = len1 + len2;
  if( (len + sizeof (value)) / sizeof (value) > Max_wosize )
    mlraise(Atom(END_OF_FILE_EXN)); /* This translates to exn Size! 
				       See src/compiler/Smlexc.sml */
  s = alloc_string(len);
  bcopy(&Byte(r[0],0), &Byte(s,0), len1);
  bcopy(&Byte(r[1],0), &Byte(s,len1), len2);
  Pop_roots();
  return s;
}

value sml_chr(v)          /* ML */
     value v;
{
  long i;
  value s;
  i = Long_val(v);
  if( i < 0 || i > 255 )
    mlraise(Atom(SMLEXN_CHR));
  s = alloc_string(1);
  *(&Byte(s,0)) = (unsigned char) i;
  return s;
}

value sml_ord(s)          /* ML */
     value s;
{
  long i;
  if( string_length(s) == 0 )
    mlraise(Atom(SMLEXN_ORD));
  i = (unsigned char) *(&Byte(s,0));
  return Val_long(i);
}

value sml_float_of_string(s)        /* ML */
     value s;
{

  char buff[64];
  mlsize_t len;
  int i, e_len;
  char c;
  char *p;
  double r;

  len = string_length(s);
  if(len > sizeof(buff) - 1)
    failwith("sml_float_of_string: argument too large");
  p = String_val(s);
  e_len = -1;
  for (i = 0; i<len; i++) {
    c = *p++;
    switch( c ) {
        case '~':
          buff[i] = '-'; break;
        case 'E':
          buff[i] = 'e'; e_len = 0; break;
        default:
          buff[i] = c;
          if( e_len >= 0 ) e_len++;
          Raise_float_if( e_len > 5 )
          break;
    }
  }
  buff[len] = 0;
  r = atof(buff);
  if( (r > maxdouble) || (r < -maxdouble) )
    failwith("sml_float_of_string: result too large");
  return copy_double(r);
}


static int countChar(c, s)
   int c; char* s;
{
  char *p; int count;

  count = 0;
  for( p=s; *p != '\0'; p++ ) {
    if( *p == c ) count++;
  }
  return count;
}

/* Here we remove all '+', and replace '-' and 'e' */
/* with '~' and 'E', respectively. */

static void mkSMLMinus(s)
  char *s;
{
  char *p, *q;

  for( p=s, q=s; *p != '\0'; p++ ) {
    switch( *p ) {
        case '+': break;
        case '-': *q++ = '~'; break;
        case 'e': *q++ = 'E'; break;
        default: *q++ = *p;
    }
  }
  *q = '\0';
  return;
}

value sml_string_of_int(arg)      /* ML */
     value arg;
{
  char format_buffer[32];

  sprintf(format_buffer, "%ld", Long_val(arg));
  mkSMLMinus(format_buffer);
  return copy_string(format_buffer);
}

value sml_string_of_float(arg)    /* ML */
     value arg;
{
  char format_buffer[64];

  sprintf(format_buffer, "%.12g", Double_val(arg));
  mkSMLMinus(format_buffer);
  if( countChar('.', format_buffer) == 0 &&
      countChar('E', format_buffer) == 0 )
    strcat(format_buffer, ".0");
  return copy_string(format_buffer);
}

#ifdef __MWERKS__
#pragma mpwc_newline on
#endif

value sml_makestring_of_char(arg)      /* ML */
     value arg;
{
  unsigned char c;
  char buff[8];

  c = Int_val(arg);
  switch (c)
    {
    case '"':   return copy_string("#\"\\\"\"");
    case '\\':  return copy_string("#\"\\\\\"");
    case '\a':  return copy_string("#\"\\a\"");
    case '\b':  return copy_string("#\"\\b\"");
    case '\t':  return copy_string("#\"\\t\"");
    case '\n':  return copy_string("#\"\\n\"");
    case '\v':  return copy_string("#\"\\v\"");
    case '\f':  return copy_string("#\"\\f\"");
    case '\r':  return copy_string("#\"\\r\"");
    default:
      buff[0] = '#'; buff[1] = '"';
      if( c <= 31 ) {
        buff[2] = '\\'; buff[3] = '^'; buff[4] = c + 64;
        buff[5] = '"'; buff[6] = 0;
        return copy_string(buff);
        }
      else if( (32 <= c && c <= 126) || (128 <= c && c <= 254) ) {
        buff[2] = c; buff[3] = '"'; buff[4] = 0;
        return copy_string(buff);
        }
      else {
        buff[2] = '\\';
        buff[3] = 48 + c / 100;
        buff[4] = 48 + (c / 10) % 10;
        buff[5] = 48 + c % 10;
        buff[6] = '"';
        buff[7] = 0;
        return copy_string(buff);
        }
    }
}

value sml_makestring_of_string(arg)      /* ML */
     value arg;
{
  mlsize_t arg_len, len, i;
  value res;
  char *a; char *b;
  unsigned char c;
  Push_roots(r, 1);

  r[0] = arg;
  arg_len = string_length(arg);

  a = String_val(r[0]);
  len = 0;
  for( i = 0; i < arg_len; i++ ) {
    c = a[i];
    switch (c)
      {
      case '"': case '\\': 
      case '\a': case '\b': case '\t': case '\n': case '\v': 
      case '\f': case '\r':
        len += 2; break;
      default:
        if( c <= 31)
          len += 3;
        else if( (32 <= c && c <= 126) || (128 <= c && c <= 254) )
          len += 1;
        else
          len += 4;
        break;
      }
    }

  if( (len + 2 + sizeof (value)) / sizeof (value) > Max_wosize )
    failwith("sml_string_for_read: result too large");
  res = alloc_string(len + 2);

  a = String_val(r[0]);
  b = String_val(res);
  *b++ = '"';
  for( i = 0; i < arg_len; i++) {
    c = a[i];
    switch (c)
      {
      case '"':   *b++ = '\\'; *b++ = '"';  break;
      case '\\':  *b++ = '\\'; *b++ = '\\'; break;
      case '\a':  *b++ = '\\'; *b++ = 'a';  break;
      case '\b':  *b++ = '\\'; *b++ = 'b';  break;
      case '\t':  *b++ = '\\'; *b++ = 't';  break;
      case '\n':  *b++ = '\\'; *b++ = 'n';  break;
      case '\v':  *b++ = '\\'; *b++ = 'v';  break;
      case '\f':  *b++ = '\\'; *b++ = 'f';  break;
      case '\r':  *b++ = '\\'; *b++ = 'r';  break;
      default:
        if( c <= 31 )
          { *b++ = '\\'; *b++ = '^'; *b++ = c + 64; break; }
        else if( (32 <= c && c <= 126) || (128 <= c && c <= 254) )
          { *b++ = c; break; }
        else
          { *b++ = '\\';
            *b++ = 48 + c / 100;
            *b++ = 48 + (c / 10) % 10;
            *b++ = 48 + c % 10;
            break; }
      }
    }
  *b++ = '"';
  Pop_roots();
  return res;
}

#ifdef __MWERKS__
#pragma mpwc_newline off
#endif

/* The following must agree with timebase in mosmllib/Time.sml: */

#define TIMEBASE (-1073741824)

/* There is another problem on the Mac: with a time base of 1904,
   most times are simply out of range of mosml integers. So, I added
   the macros below to compensate. 07Sep95 e
*/

#ifdef macintosh

#if ( __MWERKS__ >= 0x1100 )
// 15May97 e for MSL 2.1.1
#define TMacbaseyr      1900L
/* number of leap days between the two years -- MSL base was not a leap year! */
#define TLpD    ((TUNIXbaseyr-TMacbaseyr)/4)
#else
/* 28Jan93   Kjeld & Soren */
#define TMacbaseyr      1904L
/* number of leap days between the two years -- Mac base was a leap year! */
#define TLpD    ((TUNIXbaseyr-TMacbaseyr-1)/4) + 1
#endif

#define TUNIXbaseyr     1970L

/* TimeBaseDif is the number of seconds between Mac and UNIX time (GMT) */
#define TimeBaseDif     ((((TUNIXbaseyr-TMacbaseyr)*365)+TLpD)*24*60*60)

#define SYStoSMLtime(m) ((m) - TimeBaseDif)
#define SMLtoSYStime(s) ((s) + TimeBaseDif)

#else

#define SYStoSMLtime
#define SMLtoSYStime

#endif

value sml_getrealtime (v) /* ML */
    value v;
{
  value res;
  struct timeval tp;

  gettimeofday(&tp, NULL);
  res = alloc (2, 0);
  Field (res, 0) = Val_long (SYStoSMLtime(tp.tv_sec)+TIMEBASE);
  Field (res, 1) = Val_long (tp.tv_usec);
  return res;
}

value sml_getrutime (v) /* ML */
    value v;
{
  value res;

#if defined(__MWERKS__)
  res = e_getrusage();
#else
#if defined(hpux) || defined(__svr4__)
  struct tms buffer;

  long persec = sysconf(_SC_CLK_TCK);
  times(&buffer);
  res = alloc (6, 0);
  Field (res, 2) = Val_long (buffer.tms_stime / persec);
  Field (res, 3) = Val_long ((buffer.tms_stime % persec) * (1000000 / persec));
  Field (res, 4) = Val_long (buffer.tms_utime / persec);
  Field (res, 5) = Val_long ((buffer.tms_utime % persec) * (1000000 / persec));
#else
  struct rusage rusages;
  getrusage(RUSAGE_SELF, &rusages);
  res = alloc (6, 0);
  Field (res, 2) = Val_long (rusages.ru_stime.tv_sec);
  Field (res, 3) = Val_long (rusages.ru_stime.tv_usec);
  Field (res, 4) = Val_long (rusages.ru_utime.tv_sec); 
  Field (res, 5) = Val_long (rusages.ru_utime.tv_usec);
#endif

  Field (res, 0) = Val_long (gc_time.tv_sec);
  Field (res, 1) = Val_long (gc_time.tv_usec); 
#endif

  return res;
}


value sml_errno(arg)          /* ML */
     value arg;
{
  return Val_long(errno);
}

value sml_getdir(arg)		/* ML */
     value arg;
{
 char directory[MAXPATHLEN];
 char *res;

 errno = 0;
 res = getcwd(directory, MAXPATHLEN);
 if (res == NULL)
    failwith("getcwd");
 return copy_string(directory);
}

value sml_mkdir(path)          /* ML */
     value path;
{
  if (mkdir(String_val(path), 0777) == -1) 
      failwith("mkdir");
  return Val_unit;
}

value sml_rmdir(path)          /* ML */
     value path;
{
  if (rmdir(String_val(path)) == -1) 
      failwith("rmdir");
  return Val_unit;
}

value sml_opendir(path)          /* ML */
     value path;
{ DIR * dstr;

  dstr = opendir(String_val(path));
  if (dstr == NULL)
      failwith("opendir");
#ifdef MSDOS
  if (readdir(dstr) == NULL) 
      failwith("opendir");
  else
      rewinddir(dstr);
#endif
  return (value) dstr;
}

value sml_rewinddir(v)          /* ML */
     value v;
{ 
  rewinddir((DIR *) v);
  return Val_unit;
}

value sml_readdir(v)          /* ML */
     value v;
{ struct dirent *direntry;

  direntry = readdir((DIR *) v);
  if (direntry == NULL) 
      return copy_string("");
  return copy_string((*direntry).d_name);
}

value sml_closedir(v)          /* ML */
     value v;
{ 
  if (closedir((DIR *) v) == -1)
      failwith("closedir");
  return Val_unit;
}

value sml_isdir(path)          /* ML */
     value path;
{ struct stat buf;

  if (stat(String_val(path), &buf) == -1)
      failwith("stat");
  return (Val_bool(S_ISDIR(buf.st_mode)));
}

value sml_modtime(path)          /* ML */
     value path;
{ struct stat buf;

  if (stat(String_val(path), &buf) == -1)
      failwith("stat");
  return (copy_double ((double) (SYStoSMLtime(buf.st_mtime))));
}

value sml_settime(path, time)          /* ML */
     value path, time;
{ struct utimbuf tbuf;

  tbuf.actime = tbuf.modtime = SMLtoSYStime((long) (Double_val(time)));
  if (utime(String_val(path), &tbuf) == -1)
      failwith("utime");
  return Val_unit;
}

value sml_access(path, permarg)          /* ML */
     value path, permarg;
{ long perms;
  long perm = Long_val(permarg);

  perms  = ((0x1 & perm) ? R_OK : 0);
  perms |= ((0x2 & perm) ? W_OK : 0);
  perms |= ((0x4 & perm) ? X_OK : 0);
  if (perms == 0) perms = F_OK;

  if (access(String_val(path), perms) == 0)
    return Val_bool(1);
  return Val_bool(0);
}

#ifndef HAS_STRERROR
  extern int sys_nerr;
  extern char * sys_errlist [];
  extern char *realpath();
  char *mktemp();
#endif

value sml_tmpnam(v)          /* ML */
     value v;
{ char *res;

  res = tmpnam(NULL);
  if (res == NULL) 
    failwith("tmpnam");  
  return copy_string(res);
}

value sml_errormsg(err)   /* ML */
     value err;
{
  int errnum;
  errnum = Long_val(err);
#ifdef HAS_STRERROR
  return copy_string(strerror(errnum));
#else
  if (errnum < 0 || errnum >= sys_nerr) 
      return copy_string("(Unknown error)");
  else 
    return copy_string(sys_errlist[errnum]);
#endif
}

value sml_asin(f)           /* ML */
     value f;
{ double r = Double_val(f);
  float_exn = SMLEXN_DOMAIN;
  Raise_float_if( r < -1.0 || r > 1.0 );  
  r = asin(r);
  Raise_float_if( r != r );
  return copy_double(r);
}

value sml_acos(f)           /* ML */
     value f;
{ double r = Double_val(f);
  float_exn = SMLEXN_DOMAIN;
  Raise_float_if( r < -1.0 || r > 1.0 );  
  r = acos(r);
  Raise_float_if( r != r );
  return copy_double(r);
}

value sml_atan2(f1, f2)           /* ML */
     value f1, f2;
{ double r, r1, r2;
  float_exn = SMLEXN_DOMAIN;
  r1 = Double_val(f1);
  r2 = Double_val(f2);
  if (r1 == 0.0 && r2 == 0.0) 
    return copy_double(0.0);
  r = atan2(r1, r2);
  Check_float(r);
  Raise_float_if( r != r );
  return copy_double(r);
}

value sml_pow(f1, f2)           /* ML */
     value f1, f2;
{ double r, r1, r2;
  float_exn = SMLEXN_DOMAIN;
  r1 = Double_val(f1);
  r2 = Double_val(f2);
  if (r1 == 0.0 && r2 == 0.0) 
    return copy_double(1.0);
  if (   (r1 == 0.0 && r2 < 0.0) 
      || (r1 < 0.0 && (   fabs(r2) > (double) (Max_long) 
		       || r2 != (double)(long)r2)))
    mlraise(Atom(float_exn));
  r = pow(r1, r2);
  float_exn = SMLEXN_OVF;
  Check_float(r);
  float_exn = SMLEXN_DOMAIN;
  Raise_float_if( r != r );
  return copy_double(r);
}

value sml_localtime (v) /* ML */
    value v;
{
  value res;
  struct tm *tmr;
  time_t clock = SMLtoSYStime((long) (Double_val(v)));
  tmr = localtime(&clock);
  res = alloc (9, 0);
  Field (res, 0) = Val_long ((*tmr).tm_hour);
  Field (res, 1) = Val_long ((*tmr).tm_isdst);
  Field (res, 2) = Val_long ((*tmr).tm_mday);
  Field (res, 3) = Val_long ((*tmr).tm_min); 
  Field (res, 4) = Val_long ((*tmr).tm_mon);
  Field (res, 5) = Val_long ((*tmr).tm_sec);
  Field (res, 6) = Val_long ((*tmr).tm_wday);
  Field (res, 7) = Val_long ((*tmr).tm_yday);
  Field (res, 8) = Val_long ((*tmr).tm_year);

  return res;
}

value sml_gmtime (v) /* ML */
    value v;
{
  value res;
  struct tm *tmr;
  time_t clock = SMLtoSYStime((long) (Double_val(v)));
  tmr = gmtime(&clock);
  res = alloc (9, 0);
  Field (res, 0) = Val_long ((*tmr).tm_hour);
  Field (res, 1) = Val_long ((*tmr).tm_isdst);
  Field (res, 2) = Val_long ((*tmr).tm_mday);
  Field (res, 3) = Val_long ((*tmr).tm_min); 
  Field (res, 4) = Val_long ((*tmr).tm_mon);
  Field (res, 5) = Val_long ((*tmr).tm_sec);
  Field (res, 6) = Val_long ((*tmr).tm_wday);
  Field (res, 7) = Val_long ((*tmr).tm_yday);
  Field (res, 8) = Val_long ((*tmr).tm_year);
  return res;
}

value sml_mktime (v) /* ML */
    value v;
{
  struct tm tmr;

  tmr.tm_hour  = Long_val(Field (v, 0));
  tmr.tm_isdst = Long_val(Field (v, 1));
  tmr.tm_mday  = Long_val(Field (v, 2));
  tmr.tm_min   = Long_val(Field (v, 3));
  tmr.tm_mon   = Long_val(Field (v, 4));
  tmr.tm_sec   = Long_val(Field (v, 5));
  tmr.tm_wday  = Long_val(Field (v, 6));
  tmr.tm_yday  = Long_val(Field (v, 7));
  tmr.tm_year  = Long_val(Field (v, 8));

  return copy_double((double)SYStoSMLtime(tm2cal(&tmr)));

}

value sml_asctime (v) /* ML */
    value v;
{
  struct tm tmr;
  char *res;

  tmr.tm_hour  = Long_val(Field (v, 0));
  tmr.tm_isdst = Long_val(Field (v, 1));
  tmr.tm_mday  = Long_val(Field (v, 2));
  tmr.tm_min   = Long_val(Field (v, 3));
  tmr.tm_mon   = Long_val(Field (v, 4));
  tmr.tm_sec   = Long_val(Field (v, 5));
  tmr.tm_wday  = Long_val(Field (v, 6));
  tmr.tm_yday  = Long_val(Field (v, 7));
  tmr.tm_year  = Long_val(Field (v, 8));

  tm2cal(&tmr);

  res = asctime(&tmr);
  if (res == NULL) 
      failwith("asctime");
  return copy_string(res);
}

value sml_strftime (fmt, v) /* ML */
    value fmt, v;
{
  struct tm tmr;
#define BUFSIZE 256      
  char buf[BUFSIZE];
  long ressize;

  tmr.tm_hour  = Long_val(Field (v, 0));
  tmr.tm_isdst = Long_val(Field (v, 1));
  tmr.tm_mday  = Long_val(Field (v, 2));
  tmr.tm_min   = Long_val(Field (v, 3));
  tmr.tm_mon   = Long_val(Field (v, 4));
  tmr.tm_sec   = Long_val(Field (v, 5));
  tmr.tm_wday  = Long_val(Field (v, 6));
  tmr.tm_yday  = Long_val(Field (v, 7));
  tmr.tm_year  = Long_val(Field (v, 8));

  tm2cal(&tmr);

  ressize = strftime(buf, BUFSIZE, String_val(fmt), &tmr);
  if (ressize == 0 || ressize == BUFSIZE) 
      failwith("strftime");
  return copy_string(buf);
#undef BUFSIZE
}

value sml_general_string_of_float(fmt, arg)    /* ML */
     value fmt, arg;
{
#define BUFSIZE 512
  char format_buffer[BUFSIZE];
  int i;

  /* Unfortunately there seems to be no way to ensure that this does not
   * crash by overflowing the format_buffer (e.g. when specifying a huge 
   * number of decimal digits in the fixed-point format): 
   */

  sprintf(format_buffer, String_val(fmt), Double_val(arg));

  mkSMLMinus(format_buffer);
  return copy_string(format_buffer);
#undef BUFSIZE
}

value sml_filesize(path)          /* ML */
     value path;
{ struct stat buf;

  if (stat(String_val(path), &buf) == -1)
      failwith("stat");
  return (Val_long (buf.st_size));
}

value sml_int_of_hex(s)          /* ML */
     value s;
{ value v;
  long res;
  int sign;
  char * p;

  /* The argument s has form [~]?0x[0-9a-fA-F]+ */

  p = String_val(s);
  sign = 1;
  if (*p == '~') {
    sign = -1;
    p++;
  }
  /* skip 0x in s */
  p += 2; 

  res = sign * scanhex(p, (unsigned long)Min_long);
  v = Val_long(res);
  if( Long_val(v) != res )
    goto raise_failure;
  return v;

  raise_failure:
    failwith("sml_int_of_hex");
}

value sml_word_of_hex(s)          /* ML */
     value s;
{ value v;
  long res;
  char * p;

  /* The argument s has form 0wx[0-9a-fA-F]+ */

  p = String_val(s);
  /* skip 0wx in s */
  p += 3; 

  res = scanhex(p, 2 * (unsigned long)Min_long);
  v = Val_long((long)res);
  return v;
}

value sml_word_of_dec(s)          /* ML */
     value s;
{ value v;
  long res;
  char * p;

  /* The argument s has form 0w[0-9]+ */
  p = String_val(s);
  /* skip 0w in s */
  p += 2; 

  res = (long)scandec(p, 2 * (unsigned long)Min_long);
  v = Val_long((long)res);
  return v;
}

value sml_hexstring_of_word(arg)      /* ML */
     value arg;
{
  char format_buffer[32];

  sprintf(format_buffer, "0wx%lX", Long_val((unsigned long)arg));
  return copy_string(format_buffer);
}

value sml_sinh(f)         /* ML */
     value f;
{ double r;
  float_exn = SMLEXN_OVF;  
  r = Double_val(f);
  r = sinh(r);
  Check_float(r);
  return copy_double(r);
}

value sml_cosh(f)         /* ML */
     value f;
{ double r;
  float_exn = SMLEXN_OVF;
  r = Double_val(f);
  r = cosh(r);
  Check_float(r);
  return copy_double(r);
}

value sml_tanh(f)         /* ML */
     value f;
{ double r;
  float_exn = SMLEXN_DOMAIN;
  r = Double_val(f);
  r = tanh(r);
  Check_float(r);
  return copy_double(r);
}