/* Moscow ML primitives */ #include <math.h>#include <errno.h>#include <stdio.h>#include <stdlib.h>#include <string.h>#include <sys/types.h>#include <sys/stat.h>#include <time.h>#include <ctype.h> #ifdef WIN32#include <sys/timeb.h>#include <sys/utime.h>#include <io.h>#include <direct.h>#include <windows.h>#else#include <sys/time.h>#include <sys/times.h>#include <sys/resource.h>#include <dirent.h>#include <sys/param.h> #include <unistd.h>#include <utime.h>#include <limits.h>#define MAXPATHLEN _POSIX_PATH_MAX#endif #include "mlvalues.h"#include "fail.h"#include "memory.h"#include "str.h"#include "runtime.h"#include "alloc.h"#include "major_gc.h"#include "intext.h"#include "debugger.h"#include "interp.h"#include "globals.h"#include "mosml.h" /* SunOS 4 appears not to have mktime: */#if defined(sun) && !defined(__svr4__)#define tm2cal(tptr)	timelocal(tptr)#else#define tm2cal(tptr)	mktime(tptr)#endif #define Raise_float_if(cond) \   if( cond ) \      { raiseprimitive0(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(value v1, value 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(value v1, value v2) /* ML */{  return Atom(sml_equal_aux(v1,v2));} value sml_not_equal(value v1, value v2) /* ML */{  return Atom(!sml_equal_aux(v1,v2));} value sml_system(value cmd)        /* ML */{  return Val_int(system(String_val(cmd)));} value sml_abs_int(value x)          /* ML */{ value tmp, v;  tmp = Long_val(x);  if( tmp < 0 ) tmp = -tmp;  v = Val_long(tmp);  if( Long_val(v) != tmp )    raise_overflow();  return v;} value sml_floor(value f)              /* ML */{ 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:    raise_overflow();    return Val_unit;		/* Can't reach return */} value sml_ceil(value f)              /* ML */{ 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:    raise_overflow();    return Val_unit;		/* Can't reach return */} #ifdef __MWERKS__#if __MWERKS__ < 0x0400#include <Types.h>double_t nearbyint ( double_t x );#define rint nearbyint#endif#endif value sml_round(value f)              /* ML */{ double r;  long i;  value v;  /* Apparently no rint() in djgpp's libm: */#if defined(MSDOS) || defined(hpux) || defined(WIN32) || defined(plan9)  double delta;  r = floor(Double_val(f));  if (r < (double)(Min_long-1) || r > (double)(Max_long)) goto raise_round;    i = (long)r;  delta = Double_val(f) - r;   // belongs to [0, 1[  // Round to nearest even integer.  // If delta > 0.5, round up; if delta == 0.5, round to nearest even:  if (delta > 0.5 || delta == 0.5 && i % 2 != 0)    i++;  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:    raise_overflow();    return Val_unit;		/* Can't reach return */} value sml_trunc(value f)              /* ML */{ 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:  raise_overflow();  return Val_unit;		/* Can't reach return */} value sml_abs_real(value f)              /* ML */{ double r;  float_exn = SYS__EXN_OVERFLOW;  r = Double_val(f);  if( r >= 0.0 )    return f;  else    r = -r;  Check_float(r);  return copy_double(r);} value sml_sqrt(value f)         /* ML */{ double r;  float_exn = SYS__EXN_DOMAIN;  r = Double_val(f);  Raise_float_if( r < 0.0 );  r = sqrt(r);  Check_float(r);  return copy_double(r);} value sml_sin(value f)         /* ML */{ 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(value f)         /* ML */{ 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(value f)           /* ML */{ double r;  float_exn = SYS__EXN_OVERFLOW;  r = exp(Double_val(f));  Check_float(r);  return copy_double(r);} value sml_ln(value f)           /* ML */{ double r;  float_exn = SYS__EXN_DOMAIN;  r = Double_val(f);  Raise_float_if( r <= 0.0 );  r = log(r);  Check_float(r);  return copy_double(r);} unsigned long scandec(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");    return 0;		/* Can't reach return */} unsigned long scanhex(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("scanhex");    return 0;		/* Can't reach return */} value sml_int_of_string(value s)          /* ML */{ 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");    return Val_unit;		/* Can't reach return */} value sml_concat(value s1, value s2)        /* ML */{  mlsize_t len1, len2, len;  value s;  len1 = string_length(s1);  if (len1 == 0)     return s2;  len2 = string_length(s2);  if (len2 == 0)    return s1;  {     Push_roots(r, 2);    r[0] = s1;    r[1] = s2;    len = len1 + len2;    if( (len + sizeof (value)) / sizeof (value) > Max_wosize )      raiseprimitive0(SYS__EXN_SIZE);     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(value v)          /* ML */{  long i;  value s;  i = Long_val(v);  if( i < 0 || i > 255 )    raiseprimitive0(SYS__EXN_CHR);  s = alloc_string(1);  *(&Byte(s,0)) = (unsigned char) i;  return s;} value sml_ord(value s)          /* ML */{  long i;  if( string_length(s) == 0 )    raiseprimitive0(SYS__EXN_ORD);  i = (unsigned char) *(&Byte(s,0));  return Val_long(i);} value sml_float_of_string(value s)        /* ML */{   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(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'.   Also, drop a single leading zero from the exponent. */ static void mkSMLMinus(char * s){  char *p = s, *q = s;  int justafterexp = 0;		/* After exponent but before digits */    for ( ; *p != '\0'; p++) {    switch( *p ) {    case '+': break;    case '-': *q++ = '~'; break;    case 'e': *q++ = 'E'; justafterexp = 1; break;    case '0':       if (!justafterexp)	/* Don't copy zero just after exponent */	*q++ = '0';      justafterexp = 0;      break;    default: *q++ = *p; justafterexp = 0; break;    }  }  *q = '\0';  return;} value sml_string_of_int(value arg)      /* ML */{  char format_buffer[32];   sprintf(format_buffer, "%ld", Long_val(arg));  mkSMLMinus(format_buffer);  return copy_string(format_buffer);} /* Convert real x to SMLish format in format_buffer */ void string_of_float_aux(char* format_buffer, double x){  sprintf(format_buffer, "%.12g", x);  mkSMLMinus(format_buffer);  if( countChar('.', format_buffer) == 0 &&      countChar('E', format_buffer) == 0 )    strcat(format_buffer, ".0");} value sml_string_of_float(value arg)    /* ML */{  char format_buffer[64];  string_of_float_aux(format_buffer, Double_val(arg));  return copy_string(format_buffer);} 

Lines 1–500 of 1574. Load more