/* File mosml/src/dynlibs/interface/cside.c -- foreign function interface
   How to access SML values from C, and how to create SML values to be 
   returned to SML. The C side of things. 
 */

#include <ctype.h>		/* For toupper */
#include <stdlib.h>		/* For malloc */
#include <string.h>		/* For strcpy */

/* Moscow ML specific includes: */

#include <mlvalues.h>		/* For Val_unit, Long_val, String_val, ... */
#include <alloc.h>		/* For copy_string, alloc_string, ...      */
#include <memory.h>		/* For Modify, Push_roots, Pop_roots       */
#include <str.h>		/* For string_length                       */
#include <interp.h>		/* For callback                            */

#ifdef WIN32
#define EXTERNML __declspec(dllexport)
#else
#define EXTERNML
#endif

/* SML type: unit -> unit */

EXTERNML value cfu(value dummy)
{
  return Val_unit;
}


/* SML type: int -> int */

EXTERNML value cfi(value v)
{
  long i = Long_val(v);

  return Val_long(i + 1);
}


/* SML type: char -> char */

EXTERNML value cfc(value v)
{
  char c = (char)Long_val(v);

  return Val_long((long)(toupper(c)));
}


/* SML type: real -> real */

EXTERNML value cfr(value v)
{
  double d = Double_val(v);

  return copy_double(2 * d);
}


/* SML type: string -> string */

EXTERNML value cfs(value v)
{
  char *oldp, *newp, *q;
  int len;
  oldp = String_val(v);		/* Null-terminated heap-allocated string */
  len = string_length(v);	/* Much faster than strlen */
  
  q = newp = malloc(len+1);	/* malloc a C string */
  strcpy(newp, oldp);		/* and copy the given ML string to it */

  while (*q)			/* Modify the C string */
    { *q = toupper(*q); q++; }
  
  return copy_string(newp);	/* Copy modified string to the ML heap */
}


/* SML type: bool -> bool */

EXTERNML value cfb(value v)
{
  int b = Bool_val(v);

  return Val_bool(!b);
}


/* SML type: int -> char -> real -> string -> bool -> int */

EXTERNML value cfcur(value vi, value vc, value vr, value vs, value vb)
{
  long i   = Long_val(vi);
  char c   = (char)Long_val(vc);
  double d = Double_val(vr);
  char *p  = String_val(vs);
  int b    = Bool_val(vb);

  return Val_long(i + c + (int)d + strlen(p) + b);
}


/* SML type: int * char * real -> int */
/* The components of a tuple v are Field(v, 0), Field(v, 1), ... */

EXTERNML value cftup(value v)
{
  long i   = Long_val(Field(v, 0)); 
  char c   = (char)Long_val(Field(v, 1));
  double d = Double_val(Field(v, 2));

  return Val_long(i + c + (int)d);
}


/* SML type: { age : int, givenname : string, surname : string } -> bool */
/* A record is really a tuple, sorted lexicograhically on labels: */

EXTERNML value cfrec(value v)
{
  long age       = Long_val(Field(v, 0));
  char *givennam = String_val(Field(v, 1)); 
  char *surnam   = String_val(Field(v, 2)); 

  return Val_bool(age > 30 || strcmp(surnam, givennam) >= 0);
}


long treesum(value v);		/* Forwards C declaration */

/* SML type: t -> int where 
   datatype t = Br of int * t * t | Brs of t list | Lf */

EXTERNML value cfdat(value v)
{
  return Val_long(treesum(v));
}


/* Traversal of an SML list data structure (auxiliary function): */

long listsum(value lst)
{
#define isCons(x) (Tag_val(x) != 0)  

  long sum = 0;
  while (isCons(lst))		    /* While non-Nil */
    {
      value elem = Field(lst, 0);   /* The list element = first arg of Cons */
      sum += treesum(elem);
      lst = Field(lst, 1);	    /* The list tail = second arg of Cons */
    }
  return sum;
}


/* Auxiliary function demonstrating traversal of SML tree data structure. */
/* Datatype constructors are sorted alphabetically (based on ASCII) and   */
/* then numbered 0, 1, ...; the C code must use these numbers:            */

long treesum(value v)
{
  long sum = 0;
  int contag = Tag_val(v);	/* 0 = Lf, 1 = Br, 2 = Brs */
  switch (contag) {
  case 2: /* Lf */
    sum = 0; break;
  case 0: /* Br(i, t1, t2) */
    {
      long i   = Long_val(Field(v, 0));
      value t1 = Field(v, 1);	/* Left subtree */
      value t2 = Field(v, 2);	/* Right subtree */
      sum = i + treesum(t1) + treesum(t2);
      break;
    }
  case 1: /* Brs(tlist) */
    {
      value tlist = Field(v, 0); /* The list of subtrees */
      sum = listsum(tlist);
      break;
    }
  }
  return sum;
}


/* SML type: (int -> string) -> int -> string */

EXTERNML value cffun(value vf, value vi)
{
  int count = Val_long(vi);
  int ok = 1;
  value res;
  int i;
  Push_roots(r, 1);
  r[0] = vf;
  for (i=0; i<count; i++)
    if (Double_val(callback(r[0], Val_long(i))) != i+7)
      ok = 0;
  /* NB: After a callback, the garbage collector may have run, so that
     the pointer vf may have been invalidated. */
  if (ok)
    res = copy_string("Just right");
  else
    res = copy_string("Something is wrong");
  Pop_roots();
  return res;
}


/* SML type: int -> int * bool */

EXTERNML value cfrtup(value vi)
{
  long i = Long_val(vi);
  value tup = alloc_tuple(2);	/* Allocate 2-element tuple in ML heap */
  /* Must, in general, use modify to update because the GC is generational: */
  modify(&Field(tup, 0), Val_long(i / 2));
  modify(&Field(tup, 1), Val_bool(i % 2 == 1));
  return tup;
}


/* SML type: int -> { half : int, odd : bool } */
/* A record is a sorted tuple, so this function is identical to that above */

EXTERNML value cfrrec(value vi)
{
  long i = Long_val(vi);
  value tup = alloc_tuple(2);	/* Allocate 2-element tuple in ML heap */
  /* Must, in general, use modify to update because the GC is generational: */
  modify(&Field(tup, 0), Val_long(i / 2));
  modify(&Field(tup, 1), Val_bool(i % 2 == 1));
  return tup;
}


/* When allocating new values in the ML heap, special precautions must
   be made.  When the C function allocates in the ML heap, it may
   cause the garbage collector to run, which may cause it to move
   values from the young generation to the old one.  To make sure that
   the C function's copies of ML heap pointers are updated
   accordingly, register them with Push_roots (and unregister them
   with Pop_roots after use).  This is necessary if the C function's
   argument is any ML value other than int, char, or bool. */

/* SML type: string -> string -> string */
/* String concatenation (without error checking).  The resulting string is
   allocated in the ML heap, so pointers must be registered with Push_roots */

EXTERNML value cfconcat(value s1, value s2)
{
  mlsize_t len1, len2;
  value res;
  /* The Push_roots macro introduces a declaration and thus can be
     preceded only by declarations.  If necessary, put it inside a new
     block { ... }, in which Pop_roots must occur, too.  */
  Push_roots(r, 2);
  r[0] = s1;
  r[1] = s2;
  len1 = string_length(s1);
  len2 = string_length(s2);
  /* Allocating the result in the heap may cause the GC to run, which
     may move the strings given as arguments.  But in this case, the
     registered pointers r[0] and r[1] will be adjusted accordingly
     (while s1 and s2 won't be) so it is safe to use them below: */
  res = alloc_string(len1 + len2);
  /* Byte(v, i) is the proper way to refer to byte i of value v: */
  bcopy(&Byte(r[0],0), &Byte(res,0),    len1);
  bcopy(&Byte(r[1],0), &Byte(res,len1), len2);
  /* Unregister pointers r[0] and r[1] to avoid space leaks: */
  Pop_roots();
  return res;
}

