/* 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 */ #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 i, 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;}
/* 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 */
#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 i, 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;
}