retCode g__isCfChar(processPo P, ptrPo a) /* Other, Format */
{
ptrI x = deRefI(&a[1]);
if (isvar(x))
return liberror(P, "__isCfChar", eINSUFARG);
else {
if (isCfChar((codePoint)IntVal(x)))
return Ok;
else
return Fail;
}
}
retCode g__isNdChar(processPo P, ptrPo a) /* Number, decimal digit */
{
ptrI x = deRefI(&a[1]);
if (isvar(x))
return liberror(P, "__isNdChar", eINSUFARG);
else {
if (isNdChar((codePoint)IntVal(x)))
return Ok;
else
return Fail;
}
}
retCode g__isZlChar(processPo P, ptrPo a) /* Separator, line */
{
ptrI x = deRefI(&a[1]);
if (isvar(x))
return liberror(P, "__isZlChar", eINSUFARG);
else {
if (isZlChar((codePoint)IntVal(x)))
return Ok;
else
return Fail;
}
}
retCode g__isPsChar(processPo P, ptrPo a) /* Punctution, open */
{
ptrI x = deRefI(&a[1]);
if (isvar(x))
return liberror(P, "__isPsChar", eINSUFARG);
else {
if (isPsChar((codePoint)IntVal(x)))
return Ok;
else
return Fail;
}
}
retCode g__isLuChar(processPo P, ptrPo a) /* Letter, uppercase */
{
ptrI x = deRefI(&a[1]);
if (isvar(x))
return liberror(P, "__isLuChar", eINSUFARG);
else {
if (isLuChar((codePoint)IntVal(x)))
return Ok;
else
return Fail;
}
}
retCode g__isMnChar(processPo P, ptrPo a) /* Mark, non spacing */
{
ptrI x = deRefI(&a[1]);
if (isvar(x))
return liberror(P, "__isMnChar", eINSUFARG);
else {
if (isMnChar((codePoint)IntVal(x)))
return Ok;
else
return Fail;
}
}
retCode g__isSkChar(processPo P, ptrPo a) /* Symbol, modifier */
{
ptrI x = deRefI(&a[1]);
if (isvar(x))
return liberror(P, "__isSkChar", eINSUFARG);
else {
if (isSkChar((codePoint)IntVal(x)))
return Ok;
else
return Fail;
}
}
retCode g__isLetterChar(processPo P, ptrPo a) {
ptrI x = deRefI(&a[1]);
if (isvar(x))
return liberror(P, "__isLetterChar", eINSUFARG);
else {
codePoint ch = (codePoint)IntVal(x);
if (isLetterChar(ch))
return Ok;
else
return Fail;
}
}
retCode g__digitCode(processPo P, ptrPo a) {
ptrI x = deRefI(&a[1]);
if (isvar(x))
return liberror(P, "__digitCode", eINSUFARG);
else {
codePoint ch = (codePoint)IntVal(x);
if (isNdChar(ch)) {
ptrI ans = allocateInteger(&P->proc.heap, digitValue(ch));
return equal(P, &a[2], &ans);
} else
return Fail;
}
}
/*
* x^3
* 2x^2
* 2x
* x
* 2
*
*/
void make_term(const char** str_p, poly_t* p)
{
printf("Entering make_term...\n");
signed char sign;
int exp;
int coeff = 1;
const char* str = *str_p;
sign = isminus(*str)
? -1
: +1;
while (isspace(*str)) {
str++;
}
if (isdigit(*str)) {
coeff = sign * read_num(str);
}
if (isvar(*str)) {
if (*(str + 1) == '^') {
str++;
str++;
} else {
str++;
}
}
exp = read_num(str);
*str_p = ++str;
if (exp + 1 > p->size) {
int old_size = p->size;
p->size = exp + 1;
// TODO Check return value.
int* new_coeffs = calloc(p->size, sizeof(int));
memcpy(new_coeffs, p->coeffs, old_size * sizeof(int));
free(p->coeffs);
p->coeffs = new_coeffs;
}
p->coeffs[exp] = coeff;
printf(" term: coeff = %d, exp = %d\n", coeff, exp);
}
retCode g_setenv(processPo P, ptrPo a) {
ptrI k = deRefI(&a[1]);
ptrI v = deRefI(&a[2]);
if (isvar(k) || !IsString(k) || !IsString(v))
return liberror(P, "setenv", eINVAL);
else {
char * key = stringVal(stringV(k));
char * val = stringVal(stringV(v));
if (setenv((char *) key, val, 1) == 0)
return Ok;
else
return liberror(P, "setenv", eSPACE);
}
}
int isnum(char check[]) {
int i=0;
int times=0;
while(check[i]!='\0') {
if((int)check[i]>=48 && (int)check[i]<=57)
{
i++;
flag=3;
}
else if(check[i]=='.' && times==0) {
times=1;
i++;
}
else {
isvar(check);
break;
}
}
return flag;
}
retCode g_getenv(processPo P, ptrPo a) {
ptrI k = deRefI(&a[1]);
if (isvar(k))
return liberror(P, "getenv", eINSUFARG);
else if (!IsString(k))
return liberror(P, "getenv", eINVAL);
else {
char * key = stringVal(stringV(k));
char *val = getenv((char*)key);
if (val != NULL) {
ptrI L = allocateCString(&P->proc.heap, val);
return equal(P, &a[3], &L);
}
else
return equal(P, &a[2], &a[3]);
}
}
int gives_number(int token) {
int com = my_symb.elems[token].com;
int i1 = com / MAXTYPE;
if (token == INDX)
return (1);
if (token == NUMTOK)
return (1);
if (i1 == FUN1TYPE && !unary_sym(token))
return (1); /* single variable functions */
if (i1 == FUN2TYPE && !binary_sym(token))
return (1); /* two-variable function */
/* !! */
/* ram: 5 issue; was
* if(i1==8||isvar(i1)||iscnst(i1)||i1==7||i1==6||i1==5||isker(i1)||i1==UFUN)return(1);
*/
if (i1 == USTACKTYPE || isvar(i1) || iscnst(i1) || i1 == TABTYPE ||
i1 == NETTYPE || isker(i1) || i1 == UFUNTYPE)
return (1);
if (com == MYIF || token == DELSHFTSYM || token == DELSYM ||
token == SHIFTSYM || token == ISHIFTSYM || com == SUMSYM)
return (1);
return (0);
}
retCode g__delay(processPo P, ptrPo a) {
ptrI x = deRefI(&a[1]);
if (isvar(x))
return liberror(P, "delay", eINSUFARG);
else {
objPo A1 = objV(x);
if (!IsFloat(A1))
return liberror(P, "delay", eNUMNEEDD);
else {
struct timespec tm;
double seconds;
double fraction = modf(FloatVal(A1), &seconds);
#define NANO (1000000000)
tm.tv_sec = (long) seconds;
tm.tv_nsec = (long) (fraction * NANO); /* Convert microseconds to nanoseconds */
switchProcessState(P, wait_timer);
if (nanosleep(&tm, NULL) != 0) {
setProcessRunnable(P);
switch (errno) {
case EINTR:
return liberror(P, "delay", eINTRUPT);
case EINVAL:
case ENOSYS:
default:
return liberror(P, "delay", eINVAL);
}
} else {
setProcessRunnable(P);
return Ok;
}
}
}
}
int main()
{
int type;
int v = 0; /* to record variable a-z for = op */
double op2;
char s[MAXOP];
while ((type = getop(s)) != EOF)
{
switch (type)
{
case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': case 'g':
case 'h': case 'i': case 'j': case 'k': case 'l': case 'm': case 'n':
case 'o': case 'p': case 'q': case 'r': case 's': case 't': case 'u':
case 'v': case 'w': case 'x': case 'y': case 'z': case '$':
/*
* note: When a variable is reset using the = operator this could
* lead to an unused value on the stack. This is why the
* stack is cleared when a newline is encountered.
*/
if (isvar(type))
{
push(getvar(type));
}
else if (type == '$')
{
printf("error: no previously printed value\n");
}
v = type; /* record for = op below */
break;
case '=':
if (v)
{
setvar(v, pop());
v = 0;
}
else
{
printf("error: no previous variable specified\n");
}
break;
case 'S':
push(sin(pop()));
break;
case 'C':
push(cos(pop()));
break;
case 'T':
push(tan(pop()));
break;
case 'X':
push(exp(pop()));
break;
case 'L':
push(log10(pop()));
break;
case 'E':
push(exp(pop()));
break;
case 'R':
push(sqrt(pop()));
break;
case 'P':
op2 = pop();
push(pow(pop(), op2));
break;
case '!':
clear();
break;
case '@':
swap();
break;
case '#':
duplicate();
break;
case '&':
printf("\t%.8g\n", setvar('$', top()));
break;
case NUMBER:
push(atof(s));
break;
case '+':
push(pop() + pop());
break;
case '*':
push(pop() * pop());
break;
case '-':
op2 = pop();
push(pop() - op2);
break;
case '/':
op2 = pop();
if (op2 != 0.0)
push(pop() / op2);
else
printf("error: zero divisor for operator '/'\n");
break;
case '%':
op2 = pop();
if (op2 != 0.0)
{
/* In C the modulus operator only works on short,
* integer, long, ... but not when the operands
* are float or double. Thus we have to emulate a
* modulus operation for operands of type double.
*
* note: <math.h> has the function fmod() for this
*
*/
double d = pop();
if (d < op2)
push(d);
else if (d == op2)
push(0.0);
else
{
while ((d -= op2) > op2)
;
if (d == op2)
push(0.0);
else
push(d);
}
}
else
printf("error: zero divisor for operator '%%'\n");
break;
/* case '|': /\* test command for ungets() *\/ */
/* ungets(" 23 4 + "); */
/* break; */
case '\n':
printf("\t%.8g\n", setvar('$', pop()));
clear(); /* clear the stack */
break;
default:
printf("error: unknown command %s\n", s);
break;
}
}
return 0;
}
ptrI errorString(heapPo H, ptrI code) {
if (!isvar(code)) {
if (code == eINSUFARG)
return allocateCString(H, "Insufficiently instantiated argument");
else if (code == eINTNEEDD)
return allocateCString(H, "Integer required");
else if (code == eNUMNEEDD)
return allocateCString(H, "Number required");
else if (code == eVARNEEDD)
return allocateCString(H, "Unbound variable required");
else if (code == eSPACE)
return allocateCString(H, "Out of heap space");
else if (code == eUNIFY)
return allocateCString(H, "Incomparible values in unification");
else if (code == eDIVZERO)
return allocateCString(H, "Division by zero");
else if (code == eLSTNEEDD)
return allocateCString(H, "List needed");
else if (code == eTPLNEEDD)
return allocateCString(H, "Tuple needed");
else if (code == eSYMNEEDD)
return allocateCString(H, "Symbol needed");
else if (code == eSTRNEEDD)
return allocateCString(H, "String required");
else if (code == eCHRNEEDD)
return allocateCString(H, "Character required");
else if (code == eINVAL)
return allocateCString(H, "invalid argument");
else if (code == eNOPERM)
return allocateCString(H, "permission denied");
else if (code == eNOFILE)
return allocateCString(H, "file not found");
else if (code == eNOTDIR)
return allocateCString(H, "not a directory");
else if (code == eCFGERR)
return allocateCString(H, "configuration problem");
else if (code == eEOF)
return allocateCString(H, "read past end-of-file");
else if (code == eIOERROR)
return allocateCString(H, "error on i/o");
else if (code == eABORT)
return allocateCString(H, "process aborted");
else if (code == eNOTFND)
return allocateCString(H, "not found");
else if (code == eCODE)
return allocateCString(H, "undefined program");
else if (code == eFAIL)
return allocateCString(H, "unexpected failure");
else if (code == eHANDLE)
return allocateCString(H, "not a valid handle");
else if (code == eINVCODE)
return allocateCString(H, "incorrect code type");
else if (code == eASSIGN)
return allocateCString(H, "assignment not allowed");
else if (code == eDEAD)
return allocateCString(H, "deadlock detected");
else if (code == eSYSTEM)
return allocateCString(H, "system overflow");
else if (code == eDUPLICATE)
return allocateCString(H, "duplicate request");
else if (code == eNOIMPL)
return allocateCString(H, "feature not implemented");
else if (code == eNOTENUF)
return allocateCString(H, "insufficient arguments given");
else if (code == eCONNECT)
return allocateCString(H, "cannot connect to host");
else if (code == eINTRUPT)
return allocateCString(H, "interrupted");
else {
char buf[MAX_MSG_LEN];
strMsg(buf, NumberOf(buf), "Unknown error code: %w", &code);
return allocateString(H, buf, uniStrLen(buf));
}
} else {
char buf[MAX_MSG_LEN];
strMsg(buf, NumberOf(buf), "Invalid error code: %w", &code);
return allocateString(H, buf, uniStrLen(buf));
}
}
gint wr_unify_term_aux(glb* g, gint x, gint y, int uniquestrflag) {
gptr db;
gint encx,ency;
gint tmp; // used by VARVAL_F macro
gptr xptr,yptr;
int xlen,ylen,uselen,ilimit,i;
#ifdef DEBUG
printf("wr_unify_term_aux called with x %d ",x);
wr_print_term(g,x);
printf(" and y %d ",y);
wr_print_term(g,y);
printf("\n");
#endif
// first check if immediately same: return 1 if yes
if (x==y) return 1;
// second, fetch var values for var args
if (isvar(x)) x=VARVAL_F(x,(g->varbanks));
if (isvar(y)) y=VARVAL_F(y,(g->varbanks));
// check again if same
if (x==y) return 1;
// go through the ladder of possibilities
// knowing that x and y are different
if (!isdatarec(x)) {
// x is a primitive
if (!isdatarec(y)) {
// both x and y are primitive
if (isvar(x)) {
SETVAR(x,y,g->varbanks,g->varstack,g->tmp_unify_vc);
// set occcheck only if y is a var too
if (g->tmp_unify_do_occcheck && isvar(y)) (g->tmp_unify_occcheck)=1;
return 1;
} else if (isvar(y)) {
SETVAR(y,x,g->varbanks,g->varstack,g->tmp_unify_vc);
// do not set occcheck here: x is a constant!
return 1;
} else {
// x and y are constants
if (wr_equal_ptr_primitives(g,x,y,uniquestrflag)) return 1;
else return 0;
}
// x is primitive, but y is not
} else if (isvar(x)) {
// x is var, y is non-primitive
if (g->tmp_unify_occcheck && wr_occurs_in(g,x,y,(gptr)(g->varbanks))) {
return 0;
} else {
SETVAR(x,y,g->varbanks,g->varstack,g->tmp_unify_vc);
if (g->tmp_unify_do_occcheck) (g->tmp_unify_occcheck)=1;
return 1;
}
} else {
// x is a constant, but y is non-primitive
return 0;
}
// x is not primitive
} else if (isvar(y)) {
// x is non-primitive, y is var
if (g->tmp_unify_occcheck && wr_occurs_in(g,y,x,(gptr)(g->varbanks))) {
return 0;
} else {
SETVAR(y,x,g->varbanks,g->varstack,g->tmp_unify_vc);
if (g->tmp_unify_do_occcheck) (g->tmp_unify_occcheck)=1;
return 1;
}
// x is not primitive, y is non-var
} else if (!isdatarec(y)) {
// x is not primitive, y is constant
return 0;
} else {
// x and y are both complex terms
db=g->db;
xptr=decode_record(db,x);
yptr=decode_record(db,y);
xlen=get_record_len(xptr);
ylen=get_record_len(yptr);
if (g->unify_samelen) {
if (xlen!=ylen) return 0;
uselen=xlen;
} else {
if (xlen<=ylen) uselen=xlen;
else uselen=ylen;
}
if (g->unify_maxuseterms) {
if (((g->unify_maxuseterms)+(g->unify_firstuseterm))<uselen)
uselen=(g->unify_firstuseterm)+(g->unify_maxuseterms);
}
ilimit=RECORD_HEADER_GINTS+uselen;
for(i=RECORD_HEADER_GINTS+(g->unify_firstuseterm); i<ilimit; i++) {
encx=*(xptr+i);
ency=*(yptr+i);
if (encx!=ency && !wr_unify_term_aux(g,encx,ency,uniquestrflag)) return 0;
}
return 1;
}
}
void
vcc_Lexer(struct tokenlist *tl, struct source *sp)
{
const char *p, *q;
unsigned u;
tl->src = sp;
for (p = sp->b; p < sp->e; ) {
/* Skip any whitespace */
if (isspace(*p)) {
p++;
continue;
}
/* Skip '#.*\n' comments */
if (*p == '#') {
while (p < sp->e && *p != '\n')
p++;
continue;
}
/* Skip C-style comments */
if (*p == '/' && p[1] == '*') {
for (q = p + 2; q < sp->e; q++) {
if (*q == '/' && q[1] == '*') {
vsb_printf(tl->sb,
"/* ... */ comment contains /*\n");
vcc_AddToken(tl, EOI, p, p + 2);
vcc_ErrWhere(tl, tl->t);
vcc_AddToken(tl, EOI, q, q + 2);
vcc_ErrWhere(tl, tl->t);
return;
}
if (*q == '*' && q[1] == '/') {
p = q + 2;
break;
}
}
if (q < sp->e)
continue;
vcc_AddToken(tl, EOI, p, p + 2);
vsb_printf(tl->sb,
"Unterminated /* ... */ comment, starting at\n");
vcc_ErrWhere(tl, tl->t);
return;
}
/* Skip C++-style comments */
if (*p == '/' && p[1] == '/') {
while (p < sp->e && *p != '\n')
p++;
continue;
}
/* Recognize inline C-code */
if (*p == 'C' && p[1] == '{') {
for (q = p + 2; q < sp->e; q++) {
if (*q == '}' && q[1] == 'C') {
vcc_AddToken(tl, CSRC, p, q + 2);
break;
}
}
if (q < sp->e) {
p = q + 2;
continue;
}
vcc_AddToken(tl, EOI, p, p + 2);
vsb_printf(tl->sb,
"Unterminated inline C source, starting at\n");
vcc_ErrWhere(tl, tl->t);
return;
}
/* Recognize long-strings */
if (*p == '{' && p[1] == '"') {
for (q = p + 2; q < sp->e; q++) {
if (*q == '"' && q[1] == '}') {
vcc_AddToken(tl, CSTR, p, q + 2);
break;
}
}
if (q < sp->e) {
p = q + 2;
u = tl->t->e - tl->t->b;
u -= 4; /* {" ... "} */
tl->t->dec = TlAlloc(tl, u + 1 );
AN(tl->t->dec);
memcpy(tl->t->dec, tl->t->b + 2, u);
tl->t->dec[u] = '\0';
continue;
}
vcc_AddToken(tl, EOI, p, p + 2);
vsb_printf(tl->sb,
"Unterminated long-string, starting at\n");
vcc_ErrWhere(tl, tl->t);
return;
}
/* Match for the fixed tokens (see token.tcl) */
u = vcl_fixed_token(p, &q);
if (u != 0) {
vcc_AddToken(tl, u, p, q);
p = q;
continue;
}
/* Match strings, with \\ and \" escapes */
if (*p == '"') {
for (q = p + 1; q < sp->e; q++) {
if (*q == '"') {
q++;
break;
}
if (*q == '\r' || *q == '\n') {
vcc_AddToken(tl, EOI, p, q);
vsb_printf(tl->sb,
"Unterminated string at\n");
vcc_ErrWhere(tl, tl->t);
return;
}
}
vcc_AddToken(tl, CSTR, p, q);
if (vcc_decstr(tl))
return;
p = q;
continue;
}
/* Match Identifiers */
if (isident1(*p)) {
for (q = p; q < sp->e; q++)
if (!isident(*q))
break;
if (isvar(*q)) {
for (; q < sp->e; q++)
if (!isvar(*q))
break;
vcc_AddToken(tl, VAR, p, q);
} else {
vcc_AddToken(tl, ID, p, q);
}
p = q;
continue;
}
/* Match numbers { [0-9]+ } */
if (isdigit(*p)) {
for (q = p; q < sp->e; q++)
if (!isdigit(*q))
break;
vcc_AddToken(tl, CNUM, p, q);
p = q;
continue;
}
vcc_AddToken(tl, EOI, p, p + 1);
vsb_printf(tl->sb, "Syntax error at\n");
vcc_ErrWhere(tl, tl->t);
return;
}
}
int queryparam(int qgetc(void), void **poffset, size_t *psize)
{
char *prefix;
struct export_params *ep;
struct export_param_list *epl;
size_t offset= 0;
size_t size= -1;
size_t n;
static size_t retval;
int c, firstc;
firstc= c= (*qgetc)();
if (c == '&' || c == '$') c= (*qgetc)();
if (!isvar(c)) goto fail;
if ((ep= params) == nil) goto fail;
epl= ep->list;
while (c != 0 && c != ',') {
prefix= "x";
n= 0;
for (;;) {
while (epl->name == nil) {
if ((ep= ep->next) == nil) goto fail;
epl= ep->list;
}
if (strncmp(prefix, epl->name, n) == 0) {
prefix= epl->name;
while (prefix[n] != 0 && c == prefix[n]) {
n++;
c= (*qgetc)();
}
}
if (prefix[n] == 0 && (!isvar(c) || prefix[0] == '[')) {
/* Got a match. */
break;
}
epl++;
}
if (prefix[0] == '[') {
/* Array reference. */
size_t idx= 0, cnt= 1, max= size / epl->size;
while (between('0', c, '9')) {
idx= idx * 10 + (c - '0');
if (idx > max) goto fail;
c= (*qgetc)();
}
if (c == ':') {
cnt= 0;
while (between('0', (c= (*qgetc)()), '9')) {
cnt= cnt * 10 + (c - '0');
}
}
if (c != ']') goto fail;
if (idx + cnt > max) cnt= max - idx;
offset+= idx * epl->size;
size= cnt * epl->size;
c= (*qgetc)();
} else
if (epl->size == -1) {
/* Vector. */
offset= (size_t) * (void **) epl->offset;
size= (* (size_t *) epl[1].offset) * epl[1].size;
} else {
/* Variable or struct field. */
offset+= (size_t) epl->offset;
if ((size_t) epl->offset > size) goto fail;
size-= (size_t) epl->offset;
if (size < epl->size) goto fail;
size= epl->size;
}
}
if (firstc == '&' || firstc == '$') {
retval= firstc == '&' ? offset : size;
offset= (size_t) &retval;
size= sizeof(retval);
}
if (c != 0 && c != ',') goto fail;
*poffset= (void *) offset;
*psize= size;
return c != 0;
fail:
while (c != 0 && c != ',') c= (*qgetc)();
*poffset= nil;
*psize= 0;
return c != 0;
}
unsigned
vcl_fixed_token(const char *p, const char **q)
{
switch (p[0]) {
case '!':
M2('=', T_NEQ);
M2('~', T_NOMATCH);
M1();
case '%':
M1();
case '&':
M2('&', T_CAND);
M1();
case '(':
M1();
case ')':
M1();
case '*':
M2('=', T_MUL);
M1();
case '+':
M2('+', T_INC);
M2('=', T_INCR);
M1();
case ',':
M1();
case '-':
M2('-', T_DEC);
M2('=', T_DECR);
M1();
case '.':
M1();
case '/':
M2('=', T_DIV);
M1();
case ';':
M1();
case '<':
M2('<', T_SHL);
M2('=', T_LEQ);
M1();
case '=':
M2('=', T_EQ);
M1();
case '>':
M2('=', T_GEQ);
M2('>', T_SHR);
M1();
case 'e':
if (p[1] == 'l' && p[2] == 's' && p[3] == 'e' &&
p[4] == 'i' && p[5] == 'f' && !isvar(p[6])) {
*q = p + 6;
return (T_ELSEIF);
}
if (p[1] == 'l' && p[2] == 's' && p[3] == 'i' &&
p[4] == 'f' && !isvar(p[5])) {
*q = p + 5;
return (T_ELSIF);
}
if (p[1] == 'l' && p[2] == 's' && p[3] == 'e' &&
!isvar(p[4])) {
*q = p + 4;
return (T_ELSE);
}
return (0);
case 'i':
if (p[1] == 'n' && p[2] == 'c' && p[3] == 'l' &&
p[4] == 'u' && p[5] == 'd' && p[6] == 'e' &&
!isvar(p[7])) {
*q = p + 7;
return (T_INCLUDE);
}
M2('f', T_IF);
return (0);
case '{':
M1();
case '|':
M2('|', T_COR);
M1();
case '}':
M1();
case '~':
M1();
default:
return (0);
}
}
void NEWgroundoperators() {
int i,j;
int *domains[1000];
int binding[1000];
int staticrestriction[1000];
atom *al;
NEWpreprocessoperators();
initactions(); /* initialize the ground action data structure */
initatomtable(); /* initialize the tables for atoms */
for(i=0;i<nOfSActions;i++) {
typedvarlist *params = Sactions[i].params;
typedvarlist *l = params;
if(flagShowInput) {
printf("Grounding schema %i:%s\n",i,symbol(Sactions[i].name));
printSaction(&Sactions[i]);
}
/* Fetch domains of the parameters */
nOfBindings = 0;
while(l != NULL) {
staticrestriction[nOfBindings] = occursinstatic(nOfBindings,Sactions[i].precon);
#ifdef DEBUG
if(staticrestriction[nOfBindings]) {
printf("Parameter %i is static.\n",nOfBindings);
printSaction(&Sactions[i]);
} else { printf("."); }
#endif
#ifdef ASSERTS
assert(isvar(l->v));
#endif
domains[nOfBindings] = getdomain(l->t);
nOfBindings += 1;
l = l->tl;
}
#ifdef ASSERTS
assert(nOfBindings < 100);
#endif
/* Go through all parameter assignments and ground */
NEWgothrough(0,i,domains,staticrestriction);
}
goal = NEWgroundfma(Sgoal,binding);
/* Go through the initial state description to assign
indices to initial state atoms. */
al = Sinit;
while(*al != NULL) {
atomindex(*al,NULL);
al = al + 1;
}
initialstate = (int *)malloc(sizeof(int) * nOfAtoms);
for(i=0;i<nOfAtoms;i++) initialstate[i] = 0;
al = Sinit;
while(*al != NULL) {
j = atomindex(*al,NULL);
initialstate[j] = 1;
#ifdef ASSERTS
assert(j>=0); assert(j<nOfAtoms);
#endif
al = al + 1;
}
}
gint wr_match_term_aux(glb* g, gint x, gint y, int uniquestrflag) {
gptr db;
gint xval,encx,ency;
gptr xptr,yptr;
int xlen,ylen,uselen,ilimit,i;
gint eqencx; // used by WR_EQUAL_TERM macro
#ifdef DEBUG
printf("wr_match_term_aux called with x %d ",x);
wr_print_term(g,x);
printf(" and y %d ",y);
wr_print_term(g,y);
printf("\n");
#endif
// check x var case immediately
if (isvar(x)) {
xval=VARVAL_DIRECT(x,(g->varbanks));
if (xval==UNASSIGNED) {
// previously unassigned var: assign now and return
SETVAR(x,y,g->varbanks,g->varstack,g->tmp_unify_vc);
return 1;
} else {
// xval must now be equal to y, else match fails
if (WR_EQUAL_TERM(g,xval,y,uniquestrflag)) return 1;
return 0;
}
}
// now x is not var
if (!isdatarec(x)) {
if (WR_EQUAL_TERM(g,x,y,uniquestrflag)) return 1;
}
if (!isdatarec(y)) return 0; // x is datarec but y is not
// now x and y are different datarecs
if (1) {
db=g->db;
xptr=decode_record(db,x);
yptr=decode_record(db,y);
xlen=get_record_len(xptr);
ylen=get_record_len(yptr);
if (g->unify_samelen) {
if (xlen!=ylen) return 0;
uselen=xlen;
} else {
if (xlen<=ylen) uselen=xlen;
else uselen=ylen;
}
if (g->unify_maxuseterms) {
if (((g->unify_maxuseterms)+(g->unify_firstuseterm))<uselen)
uselen=(g->unify_firstuseterm)+(g->unify_maxuseterms);
}
ilimit=RECORD_HEADER_GINTS+uselen;
for(i=RECORD_HEADER_GINTS+(g->unify_firstuseterm); i<ilimit; i++) {
encx=*(xptr+i);
ency=*(yptr+i);
if (!wr_match_term_aux(g,encx,ency,uniquestrflag)) return 0;
}
return 1;
}
}