RML_END_LABEL
RML_BEGIN_LABEL(External__startsWith)
{
char *str1 = RML_STRINGDATA(rmlA0);
char *str2 = RML_STRINGDATA(rmlA1);
int i = 0;
rml_uint_t len1 = RML_HDRSTRLEN(RML_GETHDR(rmlA0)); /* string lenght1 */
rml_uint_t len2 = RML_HDRSTRLEN(RML_GETHDR(rmlA1)); /* string lenght1 */
/* if the second one is longer than the first we return false */
if (len2 > len1)
{
rmlA0 = RML_FALSE;
RML_TAILCALLK(rmlSC);
}
for (; i < len2; i++)
if (str1[i] != str2[i])
{
rmlA0 = RML_FALSE;
RML_TAILCALLK(rmlSC);
}
/* else, everything is dandy */
rmlA0 = RML_TRUE;
RML_TAILCALLK(rmlSC);
}
RML_END_LABEL
RML_BEGIN_LABEL(External__strrpl)
{
rml_uint_t len1 = RML_HDRSTRLEN(RML_GETHDR(rmlA0)); /* string lenght */
rml_uint_t len2 = RML_HDRSTRLEN(RML_GETHDR(rmlA1)); /* string lenght */
rml_uint_t len3 = RML_HDRSTRLEN(RML_GETHDR(rmlA2)); /* string lenght */
char *str1 = RML_STRINGDATA(rmlA0);
char *str2 = RML_STRINGDATA(rmlA1);
char *str3 = RML_STRINGDATA(rmlA2);
char *strpos;
if (len1 == 0 || len2==0)
{
rmlA0 = rmlA0; /* return the first string unchanged */
RML_TAILCALLK(rmlSC);
}
if ((strpos = strstr(str1, str2)) == NULL) /* the string is not there */
{
rmlA0 = rmlA0; /* return the first string unchanged */
RML_TAILCALLK(rmlSC);
}
else
{
/* string is there */
rml_uint_t len = len1-len2+len3;
/* find where */
rml_uint_t pos = (int)(strpos - str1);
/* alloc the new string */
struct rml_string *strnew = rml_prim_mkstring(len, 3);
int i, j, k;
/* reread the rmlAX, it could have been moved by the GC */
str1 = RML_STRINGDATA(rmlA0);
str2 = RML_STRINGDATA(rmlA1);
str3 = RML_STRINGDATA(rmlA2);
unsigned char *snew = (unsigned char*)strnew->data;
/* until pos, use the first string */
for(i=0; i < pos; i++)
{
*snew++ = str1[i];
}
/* now use str3 */
for(i=0; i < len3; i++)
{
*snew++ = str3[i];
}
/* until end, use the first string again */
for(i=pos+len2; i < len1; i++)
{
*snew++ = str1[i];
}
*snew = '\0';
rmlA0 = RML_TAGPTR(strnew);
RML_TAILCALLK(rmlSC);
}
}
DataField getData(const char *varname,const char *filename, unsigned int size, SimulationResult_Globals* srg)
{
DataField res;
void *cmpvar,*dataset,*lst,*datasetBackup;
double *newvars;
double d;
unsigned int i;
unsigned int ncmpvars = 0;
res.n = 0;
res.data = NULL;
/* fprintf(stderr, "getData of Var: %s from file %s\n", varname,filename); */
cmpvar = mk_nil();
cmpvar = mk_cons(mk_scon(varname),cmpvar);
dataset = SimulationResultsImpl__readDataset(filename,cmpvar,size,srg);
if (dataset==NULL) {
/* fprintf(stderr, "getData of Var: %s failed!\n",varname); */
return res;
}
/* fprintf(stderr, "Data of Var: %s\n", varname);
First calculate the length of the matrix */
datasetBackup = dataset;
while (RML_NILHDR != RML_GETHDR(dataset)) {
lst = RML_CAR(dataset);
while (RML_NILHDR != RML_GETHDR(lst)) {
res.n++;
lst = RML_CDR(lst);
}
dataset = RML_CDR(dataset);
}
if (res.n == 0) return res;
/* The allocate and read the values */
dataset = datasetBackup;
i = res.n;
res.data = (double*) malloc(sizeof(double)*res.n);
while (RML_NILHDR != RML_GETHDR(dataset)) {
lst = RML_CAR(dataset);
while (RML_NILHDR != RML_GETHDR(lst)) {
res.data[--i] = rml_prim_get_real(RML_CAR(lst));
lst = RML_CDR(lst);
}
dataset = RML_CDR(dataset);
}
assert(i == 0);
/* for (i=0;i<res.n;i++)
fprintf(stderr, "%d: %.6g\n", i, res.data[i]); */
return res;
}
/*
* p_equal.c -- implements polymorphic equality for RML
* (This is the reason why reference nodes must still be distinguishable
* from all other values.)
*/
void *rml_prim_equal(void *p, void *q)
{
tail_recur:
/* INV: ISIMM(p) <==> ISIMM(q) */
if( p == q ) {
/* Identical objects are always equal. */
return RML_TRUE;
} else if( RML_ISIMM(p) ) {
/* Different immediate values. */
return RML_FALSE;
} else {
/* Non-identical boxed values. */
rml_uint_t phdr = RML_GETHDR(p);
rml_uint_t qhdr = RML_GETHDR(q);
if( phdr == qhdr ) {
if( phdr == RML_REALHDR ) {
return (rml_prim_get_real(p) == rml_prim_get_real(q))
? RML_TRUE
: RML_FALSE;
} else if( RML_HDRISSTRING(phdr) ) {
if( !memcmp(RML_STRINGDATA(p), RML_STRINGDATA(q), RML_HDRSTRLEN(phdr)) )
return RML_TRUE;
else
return RML_FALSE;
} else if( RML_HDRISSTRUCT(phdr) ) {
rml_uint_t slots = RML_HDRSLOTS(phdr);
void **pp = RML_STRUCTDATA(p);
void **qq = RML_STRUCTDATA(q);
if( slots == 0 )
return RML_TRUE;
while( --slots > 0 )
if( rml_prim_equal(*pp++, *qq++) == RML_FALSE )
return RML_FALSE;
p = *pp;
q = *qq;
goto tail_recur;
} else {
/* Non-identical reference nodes. */
return RML_FALSE;
}
} else {
/* Different sized strings, different constructors of some datatype,
* or reference nodes with different instantiation states.
*/
return RML_FALSE;
}
}
}
RML_END_LABEL
/* list-arr.c */
RML_BEGIN_LABEL(RML__list_5farray)
{
rml_uint_t nelts = 0;
/* first compute the length of the list */
{
void *lst = rmlA0;
for(; RML_GETHDR(lst) == RML_CONSHDR; ++nelts, lst = RML_CDR(lst))
;
}
/* then allocate and initialize the vector */
{
struct rml_struct *vec = (struct rml_struct*)rml_prim_alloc(1+nelts, 1);
void *lst = rmlA0;
void **vecp = vec->data;
vec->header = RML_STRUCTHDR(nelts, 0);
rmlA0 = RML_TAGPTR(vec);
for(; nelts > 0; --nelts, lst = RML_CDR(lst))
*vecp++ = RML_CAR(lst);
}
RML_TAILCALLK(rmlSC);
}
RML_END_LABEL
RML_BEGIN_LABEL(External__substring)
{
rml_uint_t len = RML_HDRSTRLEN(RML_GETHDR(rmlA0)); /* string lenght */
int index1 = RML_UNTAGFIXNUM(rmlA1);
int index2 = RML_UNTAGFIXNUM(rmlA2);
rml_uint_t newlen = 0;
int i = 0;
if (index2 < 0) index2 = len-1;
if (index1 < 0) index1 = 0;
if (index1 > index2)
{
index1 = RML_UNTAGFIXNUM(rmlA2);
index2 = RML_UNTAGFIXNUM(rmlA1);
}
if (index2 >= len) index2 = len-1;
newlen = index2-index1 + 1;
/* alloc the new string */
struct rml_string *strnew = rml_prim_mkstring(newlen, 3);
char *str = RML_STRINGDATA(rmlA0);
unsigned char *snew = (unsigned char*)strnew->data;
for(i=index1; i <= index2; i++)
{
*snew++ = str[i];
}
*snew = '\0';
rmlA0 = RML_TAGPTR(strnew);
RML_TAILCALLK(rmlSC);
}
RML_END_LABEL
/* adrpo added string char list to string */
RML_BEGIN_LABEL(RML__string_5fchar_5flist_5fstring)
{
rml_uint_t len = 0;
/* first compute the length of the list */
{
void *lst = rmlA0;
for(; RML_GETHDR(lst) == RML_CONSHDR; ++len, lst = RML_CDR(lst))
;
}
/* then allocate and initialize the string */
{
struct rml_string *str = rml_prim_mkstring(len, 1); /* gets len+1 bytes */
void *lst = rmlA0;
unsigned char *s = (unsigned char*)str->data;
rmlA0 = RML_TAGPTR(str);
for(; len > 0; --len, lst = RML_CDR(lst))
{
/* printf ("%c ",RML_STRINGDATA(RML_CAR(lst))[0]) */
*s++ = RML_STRINGDATA(RML_CAR(lst))[0];
}
*s = '\0';
}
RML_TAILCALLK(rmlSC);
}
RML_END_LABEL
/* list-str.c */
RML_BEGIN_LABEL(RML__list_5fstring)
{
rml_uint_t len = 0;
/* first compute the length of the list */
{
void *lst = rmlA0;
for(; RML_GETHDR(lst) == RML_CONSHDR; ++len, lst = RML_CDR(lst))
;
}
/* then allocate and initialize the string */
{
struct rml_string *str = rml_prim_mkstring(len, 1); /* gets len+1 bytes */
void *lst = rmlA0;
unsigned char *s = (unsigned char*)str->data;
rmlA0 = RML_TAGPTR(str);
for(; len > 0; --len, lst = RML_CDR(lst))
*s++ = RML_UNTAGFIXNUM(RML_CAR(lst));
*s = '\0';
}
RML_TAILCALLK(rmlSC);
}
RML_END_LABEL
/* list_reverse.c */
RML_BEGIN_LABEL(RML__list_5freverse)
{
void *a1; /* cached A1 */
struct rml_struct *cons;
/* A1 := A0; A0 := NIL */
a1 = rmlA0;
rmlA0 = RML_TAGPTR(&rml_prim_nil);
/* while CONSP(A1) do A0 := CONS(CAR(A1), A0); A1 := CDR(A1) end */
while( RML_GETHDR(a1) == RML_CONSHDR ) {
rmlA1 = a1;
cons = (struct rml_struct*)rml_prim_alloc(3, 2);
a1 = rmlA1;
cons->header = RML_CONSHDR;
cons->data[0] = RML_CAR(a1);
cons->data[1] = rmlA0;
rmlA0 = RML_TAGPTR(cons);
a1 = RML_CDR(a1);
}
/* return A0 */
RML_TAILCALLK(rmlSC);
}
RML_END_LABEL
RML_BEGIN_LABEL(External__getFirstIdent)
{
rml_uint_t len = RML_HDRSTRLEN(RML_GETHDR(rmlA0)); /* string lenght */
rml_uint_t newlen = 0;
int index = 1, i=0;
char *str = RML_STRINGDATA(rmlA0);
if (!isalpha(str[0])) RML_TAILCALLK(rmlFC); /* fail if we don't start with alpha */
while((isalpha(str[index]) ||
(str[index] >= '0' && str[index] <= '9')) &&
index < len) index++;
/* alloc the new string */
struct rml_string *strnew = rml_prim_mkstring(index, 3);
str = RML_STRINGDATA(rmlA0);
unsigned char *snew = (unsigned char*)strnew->data;
for(i=0; i < index; i++)
{
*snew++ = str[i];
}
*snew = '\0';
rmlA0 = RML_TAGPTR(strnew);
RML_TAILCALLK(rmlSC);
}
RML_END_LABEL
/* lvar_set.c */
RML_BEGIN_LABEL(RML__lvar_5fset)
{
void *lvar = rmlA0;
if( RML_GETHDR(lvar) == RML_UNBOUNDHDR ) {
RML_GETHDR(lvar) = RML_BOUNDHDR;
RML_REFDATA(lvar) = rmlA1;
if( rmlTP == &rml_trail[0] ) {
(void)fprintf(stderr, "Trail overflow!\n");
rml_exit(1);
}
*--rmlTP = lvar;
RML_TAILCALLK(rmlSC);
} else
RML_TAILCALLK(rmlFC);
}
RML_END_LABEL
/* misc_print.c */
RML_BEGIN_LABEL(RML__print)
{
void *str = rmlA0;
fwrite(RML_STRINGDATA(str), RML_HDRSTRLEN(RML_GETHDR(str)), 1, stdout);
fflush(stdout);
RML_TAILCALLK(rmlSC);
}
RML_END_LABEL
RML_BEGIN_LABEL(External__toJavaName)
{
void *a0 = rmlA0;
char *str = RML_STRINGDATA(a0);
int i = 0;
int j = 1;
rml_uint_t len = RML_HDRSTRLEN(RML_GETHDR(rmlA0)); /* string lenght */
if (len < 1) RML_TAILCALLK(rmlSC);
/* check if are all caps or "_"
* if they are, do nothing!
*/
for (; i < len;)
if (str[i] != '_' && str[i] != toupper(str[i]))
break;
else i++;
if (i==len) RML_TAILCALLK(rmlSC); /* all caps or "_"; return the same */
i = 1;
char *newstr = (char*)malloc(len+1);
newstr[0] = tolower(str[0]); /* make the first one lowercase */
char *freeme = newstr;
for (; i < len;)
if (str[i] != '_')
{
newstr[j++] = str[i];
i++;
}
else /* is equal */
{
if (i+1 < len)
{
newstr[j++]=toupper(str[i+1]);
i += 2;
}
else
{
newstr[j++] = str[i];
i++;
}
}
newstr[j] = '\0';
len = strlen(newstr);
/* alloc the new string */
struct rml_string *strnew = rml_prim_mkstring(len, 1);
unsigned char *snew = (unsigned char*)strnew->data;
for(; len > 0; --len)
*snew++ = *newstr++;
*snew = '\0';
rmlA0 = RML_TAGPTR(strnew);
free(freeme);
RML_TAILCALLK(rmlSC);
}
RML_END_LABEL
/* list-delete.c */
RML_BEGIN_LABEL(RML__list_5fdelete)
{
rml_sint_t nelts = RML_UNTAGFIXNUM(rmlA1);
if( nelts < 0 )
RML_TAILCALLK(rmlFC);
else if( nelts == 0 ) {
if( RML_GETHDR(rmlA0) == RML_CONSHDR )
rmlA0 = RML_CDR(rmlA0);
else
RML_TAILCALLK(rmlFC);
} else { /* nelts > 0 */
void **chunk = (void**)rml_prim_alloc(3*nelts, 1);
void *lst = rmlA0;
rmlA0 = RML_TAGPTR(chunk);
for(;;) {
if( RML_GETHDR(lst) == RML_CONSHDR ) {
if( nelts == 0 ) {
chunk[-1] = RML_CDR(lst);
break;
} else {
chunk[0] = RML_IMMEDIATE(RML_CONSHDR);
chunk[1] = RML_CAR(lst);
chunk[2] = RML_TAGPTR(chunk + 3);
lst = RML_CDR(lst);
chunk += 3;
--nelts;
continue;
}
} else /* NIL */
RML_TAILCALLK(rmlFC);
}
}
/* return resulting list */
RML_TAILCALLK(rmlSC);
}
RML_END_LABEL
/* list_length.c */
RML_BEGIN_LABEL(RML__list_5flength)
{
void *lst = rmlA0;
rml_uint_t len = 0;
for(; RML_GETHDR(lst) == RML_CONSHDR; ++len, lst = RML_CDR(lst))
;
rmlA0 = RML_IMMEDIATE(RML_TAGFIXNUM(len));
RML_TAILCALLK(rmlSC);
}
RML_END_LABEL
RML_BEGIN_LABEL(BackendDAEEXT__setAssignment)
{
int nelts=0;
int nass1 = RML_UNTAGFIXNUM(rmlA0);
int nass2 = RML_UNTAGFIXNUM(rmlA1);
int i=0;
nelts = RML_HDRSLOTS(RML_GETHDR(rmlA2));
if (nelts > 0) {
n = nass1;
if(match) {
free(match);
}
match = (int*) malloc(n * sizeof(int));
memset(match,-1,n * sizeof(int));
for(i=0; i<n; ++i) {
match[i] = RML_UNTAGFIXNUM(RML_STRUCTDATA(rmlA2)[i])-1;
if (match[i]<0) match[i] = -1;
}
}
nelts = RML_HDRSLOTS(RML_GETHDR(rmlA3));
if (nelts > 0) {
m = nass2;
if(row_match) {
free(row_match);
}
row_match = (int*) malloc(m * sizeof(int));
memset(row_match,-1,m * sizeof(int));
for(i=0; i<m; ++i) {
row_match[i] = RML_UNTAGFIXNUM(RML_STRUCTDATA(rmlA3)[i])-1;
if (row_match[i]<0) row_match[i] = -1;
}
}
rmlA0 = mk_bcon(1);
RML_TAILCALLK(rmlSC);
}
RML_END_LABEL
/* list-nth.c */
RML_BEGIN_LABEL(RML__list_5fnth)
{
rml_sint_t i = RML_UNTAGFIXNUM(rmlA1);
void *lst = rmlA0;
for(; RML_GETHDR(lst) == RML_CONSHDR; --i, lst = RML_CDR(lst)) {
if( i == 0 ) {
rmlA0 = RML_CAR(lst);
RML_TAILCALLK(rmlSC);
}
}
RML_TAILCALLK(rmlFC);
}
RML_END_LABEL
/* list-member.c */
RML_BEGIN_LABEL(RML__list_5fmember)
{
void *x = rmlA0;
void *ys = rmlA1;
void *result = RML_FALSE;
for(; RML_GETHDR(ys) == RML_CONSHDR; ys = RML_CDR(ys)) {
if( rml_prim_equal(x, RML_CAR(ys)) != RML_FALSE ) {
result = RML_TRUE;
break;
}
}
rmlA0 = result;
RML_TAILCALLK(rmlSC);
}
RML_END_LABEL
/* list-get.c */
RML_BEGIN_LABEL(RML__list_5fget)
{
rml_sint_t i = RML_UNTAGFIXNUM(rmlA1);
void *lst = rmlA0;
i--; /* list_get starts the index at 1 */
if (i < 0) RML_TAILCALLK(rmlFC);
for(; RML_GETHDR(lst) == RML_CONSHDR; --i, lst = RML_CDR(lst))
{
if ( i == 0 )
{
rmlA0 = RML_CAR(lst);
RML_TAILCALLK(rmlSC);
}
}
RML_TAILCALLK(rmlFC);
}
RML_END_LABEL
RML_BEGIN_LABEL(RML__list_5fmap)
{
rml_uint_t nelts;
void *lst = rmlA0;
void *function = rmlA1;
/* count the number of elements in the first list */
nelts = 0;
while( RML_GETHDR(lst) == RML_CONSHDR ) {
lst = RML_CDR(lst);
++nelts;
}
/* call the relation, to build the second list */
if( nelts == 0 )
{ /* do nothing, return nil */ }
else
{
void **chunk = (void**)rml_prim_alloc(3*nelts, 2);
lst = rmlA0;
rmlA0 = RML_TAGPTR(chunk);
do {
chunk[0] = RML_IMMEDIATE(RML_CONSHDR);
rmlA0 = RML_CAR(lst); /* element */;
RML_TAILCALL(rmlA1 /* fn */,1);
chunk[1] = rmlA0;
chunk[2] = RML_TAGPTR(chunk + 3);
lst = RML_CDR(lst);
chunk += 3;
} while( --nelts != 0 );
}
/* return resulting list */
RML_TAILCALLK(rmlSC);
}
/* p_unwind.c */
void rml_prim_unwind_(void **saveTP) /* PRE: rmlTP < saveTP */
{
void **TP = rml_state_TP;
do { RML_GETHDR(*TP) = RML_UNBOUNDHDR; } while( ++TP < saveTP );
rml_state_TP = TP;
}
RML_END_LABEL
RML_BEGIN_LABEL(External__strrplall)
{
rml_uint_t len1 = RML_HDRSTRLEN(RML_GETHDR(rmlA0)); /* string lenght */
rml_uint_t len2 = RML_HDRSTRLEN(RML_GETHDR(rmlA1)); /* string lenght */
rml_uint_t len3 = RML_HDRSTRLEN(RML_GETHDR(rmlA2)); /* string lenght */
char *str1 = RML_STRINGDATA(rmlA0);
char *str2 = RML_STRINGDATA(rmlA1);
char *str3 = RML_STRINGDATA(rmlA2);
char *strpos;
if (len1 == 0 || len2==0)
{
rmlA0 = rmlA0; /* return the first string unchanged */
RML_TAILCALLK(rmlSC);
}
if ((strpos = strstr(str1, str2)) == NULL) /* the string is not there */
{
rmlA0 = rmlA0; /* return the first string unchanged */
RML_TAILCALLK(rmlSC);
}
else
{
/* string is there */
rml_uint_t len = 0;
/* find where */
rml_uint_t pos = (int)(strpos - str1);
rml_uint_t count = 1; /* we already find it once above */
/* how many times the string is there? */
strpos += len2; /* advance the position */
/*
printf ("str1 [%s], str2[%s], str3[%s]\n", str1, str2, str3);
printf ("strpos:%s\n", strpos);
*/
/* how many times the string is there? */
while ((strpos = strstr(strpos, str2)) != NULL)
{
count++;
/* printf ("strpos:%s\n", strpos); */
strpos += len2;
}
/* calculate the lenght of the new string */
len = len1+(len3-len2)*count;
/* print len
printf("len:%d, len1:%d, len2:%d, len3:%d, count:%d\n", len, len1, len2, len3, count);
*/
/* now alloc the new string */
struct rml_string *strnew = rml_prim_mkstring(len, 3);
int i, j, k;
/* reread the rmlAX, it could have been moved by the GC */
str1 = RML_STRINGDATA(rmlA0);
str2 = RML_STRINGDATA(rmlA1);
str3 = RML_STRINGDATA(rmlA2);
unsigned char *snew = (unsigned char*)strnew->data;
/* until pos, use the first string */
/* go to first */
strpos = strstr(str1, str2);
pos = (int)(strpos - str1);
do
{
/* until pos, use the first string */
/* printf("pos1:%d\n", pos); */
for(i=0; i < pos; i++)
{
*snew++ = str1[i];
}
for(i=0; i < len3; i++)
{
*snew++ = str3[i];
}
/* move the str1 pointer after str2 */
str1 += (pos+len2);
strpos = strstr(str1, str2);
if (!strpos)
{
/* copy stuff left from str1 */
for(i=0; i < strlen(str1); i++)
{
*snew++ = str1[i];
}
break;
}
pos = (int)(strpos - str1);
/* printf("pos2:%d and str1:%s\n", pos, str1); */
}
while (1);
*snew = '\0';
rmlA0 = RML_TAGPTR(strnew);
RML_TAILCALLK(rmlSC);
}
}
RML_END_LABEL
void rmldb_var_print(void *p)
{
/* printf("[%p]", p); */
if (!p) { printf ("NIL"); fflush(stdout); return; }
if( RML_ISIMM(p) )
{
printf ("%d", RML_UNTAGFIXNUM(p));
}
else
{
rml_uint_t phdr = RML_GETHDR(p);
if( phdr == RML_REALHDR )
{
printf ("%f", rml_prim_get_real(p));
fflush(stdout);
} else
if( RML_HDRISSTRING(phdr) )
{
printf ("\"%s\"", RML_STRINGDATA(p));
fflush(stdout);
/* use if neccesarry RML_HDRSTRLEN(phdr) */
} else
if( RML_HDRISSTRUCT(phdr) )
{
rml_uint_t slots = RML_HDRSLOTS(phdr);
rml_uint_t constr = RML_HDRCTOR(phdr);
void **pp = NULL;
if (slots == 0)
{
printf ("{S(%d)[%d]=NIL}", constr, slots);
fflush(stdout);
return;
}
printf ("S(%d)[%d](", constr, slots);
pp = RML_STRUCTDATA(p);
fflush(stdout);
// function definition
if ((constr == 64 || constr==13) &&
slots > 1000000) return;
if( slots != 0 )
{
// printf ("\n\t");
while( --slots > 0 )
{
rmldb_var_print(*pp++);
printf (",");
fflush(stdout);
}
p = *pp;
rmldb_var_print(*pp); printf (")"); fflush(stdout);
// goto tail_recur_debug;
}
}
else
{
printf ("UNKNOWN"); fflush(stdout);
}
}
}
void print_scon(FILE *fp, void *scon) {
fprintf(fp, "%.*s", RML_HDRSTRLEN(RML_GETHDR(scon)), RML_STRINGDATA(scon));
}