BOOLEAN matchOverload(TYPE *tnew, TYPE *told)
{
HASHREC *hnew = basetype(tnew)->syms->table[0];
HASHREC *hold = basetype(told)->syms->table[0];
// if (snew->templateLevel != sold->templateLevel)
// return FALSE;
if (isconst(tnew) != isconst(told))
return FALSE;
while (hnew && hold)
{
SYMBOL *snew = (SYMBOL *)hnew->p;
SYMBOL *sold = (SYMBOL *)hold->p;
if (sold->thisPtr)
{
hold = hold->next;
if (!hold)
break;
sold = hold->p;
}
if (snew->thisPtr)
{
hnew = hnew->next;
if (!hnew)
break;
snew = hnew->p;
}
if (snew->tp->type == bt_templateparam)
{
if (sold->tp->type != bt_templateparam ||
snew->tp->templateParam->p->type != sold->tp->templateParam->p->type ||
snew->tp->templateParam->p->type != kw_typename ||
(snew->tp->templateParam->p->byClass.dflt || sold->tp->templateParam->p->byClass.dflt) &&
(!snew->tp->templateParam->p->byClass.dflt || !sold->tp->templateParam->p->byClass.dflt ||
!comparetypes(sold->tp->templateParam->p->byClass.dflt, snew->tp->templateParam->p->byClass.dflt, TRUE)))
break;
}
else if (sold->tp->type == bt_any || snew->tp->type == bt_any) // packed template param
break;
else if (!comparetypes(sold->tp, snew->tp, TRUE) && !sameTemplate(sold->tp, snew->tp) || basetype(sold->tp)->type != basetype(snew->tp)->type)
break;
else
{
TYPE *tps = sold->tp;
TYPE *tpn = snew->tp;
if (isref(tps))
tps = basetype(tps)->btp;
if (isref(tpn))
tpn = basetype(tpn)->btp;
if (isconst(tpn) != isconst(tps) || isvolatile(tpn) != isvolatile(tps))
break;
}
hold = hold->next;
hnew = hnew->next;
}
if (!hold && !hnew)
return TRUE;
return NULL;
}
prolog_term intern_rec(CTXTdeclc prolog_term term) {
int areaindex, reclen, i, j;
CPtr hc_term;
Cell dterm[255];
Cell arg;
// printf("intern_rec\n");
// create term-record with all fields dereffed in dterm
XSB_Deref(term);
if (isinternstr(term)) {printf("old\n"); return term;}
if (isconstr(term)) {
areaindex = get_arity(get_str_psc(term));
reclen = areaindex + 1;
cell(dterm) = (Cell)get_str_psc(term); // copy psc ptr
j=1;
} else if (islist(term)) {
areaindex = LIST_INDEX;
reclen = 2;
j=0;
} else return 0;
for (i=j; i<reclen; i++) {
arg = get_str_arg(term,i); // works for lists and strs
XSB_Deref(arg);
if (isref(arg) || (isstr(arg) && !isinternstr(arg)) || isattv(arg)) {
return 0;
}
cell(dterm+i) = arg;
}
hc_term = insert_interned_rec(reclen, areaindex, dterm);
if (islist(term)) return makelist(hc_term); else return makecs(hc_term);
}
void
process(FILE *fp)
{
char buf[BUFSIZ];
char *cp;
int count;
while (fgets(buf, sizeof buf, fp) != NULL) {
Line++;
cp = strchr(buf, '@');
if (cp == NULL) {
fputs(buf, stdout);
continue;
}
do {
count = isref(cp);
if (count == 0) {
cp++;
cp = strchr(cp, '@');
if (cp == NULL) {
fputs(buf, stdout);
goto next;
}
continue;
}
/* got one */
repair(buf, cp, count);
break;
} while (cp != NULL);
next: ;
}
}
BOOLEAN matchingCharTypes(TYPE *typ1, TYPE *typ2)
{
if (isref(typ1))
typ1 = basetype(typ1)->btp;
if (isref(typ2))
typ2 = basetype(typ2)->btp;
while (ispointer(typ1) && ispointer(typ2))
{
typ1 = basetype(typ1)->btp;
typ2 = basetype(typ2)->btp;
}
typ1 = basetype(typ1);
typ2 = basetype(typ2);
if (typ1->type == bt_char)
{
if (cparams.prm_charisunsigned)
{
if (typ2->type == bt_unsigned_char)
return TRUE;
}
else
{
if (typ2->type == bt_signed_char)
return TRUE;
}
}
else if (typ2->type == bt_char)
{
if (cparams.prm_charisunsigned)
{
if (typ1->type == bt_unsigned_char)
return TRUE;
}
else
{
if (typ1->type == bt_signed_char)
return TRUE;
}
}
return FALSE;
}
static xsbBool set_error_code(CTXTdeclc int ErrCode, int ErrCodeArgNumber, char *Where)
{
prolog_term ecode_value_term, ecode_arg_term = p2p_new(CTXT);
ecode_value_term = reg_term(CTXTc ErrCodeArgNumber);
if (!isref(ecode_value_term) &&
!(isointeger(ecode_value_term)))
xsb_abort("[%s] Arg %d (the error code) must be a variable or an integer!",
Where, ErrCodeArgNumber);
c2p_int(CTXTc ErrCode, ecode_arg_term);
return p2p_unify(CTXTc ecode_arg_term, ecode_value_term);
}
static TYPE *lambda_type(TYPE *tp, enum e_cm mode)
{
if (mode == cmRef)
{
TYPE *tp1;
tp = basetype(tp);
if (isref(tp))
{
tp = tp->btp;
}
tp1 = Alloc(sizeof(TYPE));
tp1->type = bt_lref;
tp1->size = getSize(bt_pointer);
tp1->btp = tp;
tp = tp1;
}
else // cmValue
{
TYPE *tp1;
tp = basetype(tp);
if (isref(tp))
{
tp = tp->btp;
}
tp = basetype(tp);
if (!lambdas->isMutable)
{
tp1 = Alloc(sizeof(TYPE));
tp1->type = bt_const;
tp1->size = tp->size;
tp1->btp = tp;
tp = tp1;
}
}
return tp;
}
BOOLEAN isref(TYPE *tp)
{
tp = basetype(tp);
switch(tp->type)
{
case bt_lref:
return TRUE;
case bt_rref:
return TRUE;
case bt_templateparam:
if (tp->templateParam->p->type == kw_int)
return isref(tp->templateParam->p->byNonType.tp);
return FALSE;
default:
return FALSE;
}
}
static EXPRESSION *createLambda(BOOLEAN noinline)
{
EXPRESSION *rv = NULL, **cur = &rv;
HASHREC *hr;
EXPRESSION *clsThs, *parentThs;
SYMBOL *cls = makeID(lambdas->enclosingFunc ? sc_auto : sc_localstatic, lambdas->cls->tp, NULL, AnonymousName());
SetLinkerNames(cls, lk_cdecl);
cls->allocate = TRUE;
if (lambdas->enclosingFunc)
{
insert(cls, localNameSpace->syms);
clsThs = varNode(en_auto, cls); // this ptr
}
else
{
insert(cls, globalNameSpace->syms); // well if we could put this as an auto in the init func that would be good but there is no way to do that here...
clsThs = varNode(en_label, cls); // this ptr
cls->label = nextLabel++;
insertInitSym(cls);
}
{
INITIALIZER *init = NULL;
EXPRESSION *exp = clsThs;
callDestructor(cls, NULL, &exp, NULL, TRUE, FALSE, FALSE);
initInsert(&init, cls->tp, exp, 0, TRUE);
if (cls->storage_class != sc_auto)
{
insertDynamicDestructor(cls, init);
}
else
{
cls->dest = init;
}
}
parentThs = varNode(en_auto, (SYMBOL *)basetype(lambdas->func->tp)->syms->table[0]->p); // this ptr
hr = lambdas->cls->tp->syms->table[0];
while (hr)
{
SYMBOL *sp = (SYMBOL *)hr->p;
EXPRESSION *en = NULL, *en1 = NULL;
if (!strcmp(sp->name, "$self"))
{
en1 = clsThs;
en = varNode(en_label, sp);
deref(&stdpointer, &en);
en = exprNode(en_assign, en, en1);
}
else if (!strcmp(sp->name, "$parent"))
{
en1 = parentThs; // get parent from function call
deref(&stdpointer, &en1);
en = exprNode(en_add, clsThs, intNode(en_c_i, sp->offset)) ;
deref(&stdpointer, &en);
en = exprNode(en_assign, en, en1);
}
else if (!strcmp(sp->name, "$this"))
{
if (!lambdas->next || !lambdas->captureThis)
{
en1 = parentThs; // get parent from function call
}
else
{
SYMBOL *parent = search("$parent", lambdas->cls->tp->syms);
en1 = varNode(en_auto, cls);
deref(&stdpointer, &en1);
en1 = exprNode(en_add, en1, intNode(en_c_i, parent->offset));
}
deref(&stdpointer, &en1);
en = exprNode(en_add, clsThs, intNode(en_c_i, sp->offset)) ;
deref(&stdpointer, &en);
en = exprNode(en_assign, en, en1);
}
else if (sp->lambdaMode)
{
LAMBDASP *lsp = (LAMBDASP *)search(sp->name, lambdas->captured);
if (lsp)
{
en1 = exprNode(en_add, clsThs, intNode(en_c_i, sp->offset));
if (sp->lambdaMode == cmRef)
{
SYMBOL *capture = lsp->parent;
deref(&stdpointer, &en1);
if (capture->lambdaMode)
{
en = parentThs;
deref(&stdpointer, &en);
en = exprNode(en_add, en, intNode(en_c_i, capture->offset));
}
else // must be an sc_auto
{
en = varNode(en_auto, capture);
}
if (isref(capture->tp))
{
deref(&stdpointer, &en);
}
en = exprNode(en_assign, en1, en);
}
else // cmValue
{
SYMBOL *capture = lsp->parent;
TYPE *ctp = capture->tp;
if (capture->lambdaMode)
{
en = parentThs;
deref(&stdpointer, &en);
en = exprNode(en_add, en, intNode(en_c_i, capture->offset));
}
else // must be an sc_auto
{
en = varNode(en_auto, capture);
}
if (isref(ctp))
{
ctp = basetype(ctp)->btp;
deref(&stdpointer, &en);
}
if (isstructured(ctp))
{
FUNCTIONCALL *params = (FUNCTIONCALL *)Alloc(sizeof(FUNCTIONCALL));
params->arguments = (INITLIST *)Alloc(sizeof(INITLIST));
params->arguments->tp = ctp;
params->arguments->exp = en;
if (!callConstructor(&ctp, &en1, params, FALSE, NULL, TRUE, FALSE, TRUE, FALSE, FALSE))
errorsym(ERR_NO_APPROPRIATE_CONSTRUCTOR, lsp->sym);
en = en1;
}
else
{
deref(ctp, &en1);
deref(ctp, &en);
en = exprNode(en_assign, en1, en);
}
}
}
else
{
diag("createLambda: no capture var");
}
}
if (en)
{
*cur = exprNode(en_void, en, NULL);
cur = &(*cur)->right;
}
hr = hr->next;
}
*cur = clsThs; // this expression will be used in copy constructors, or discarded if unneeded
return rv;
}
BOOL comparetypes(TYPE *typ1, TYPE *typ2, int exact)
{
if (typ1->type == bt_any || typ2->type == bt_any)
return TRUE;
if (typ1->type == bt_typedef)
typ1 = basetype(typ1);
if (typ2->type == bt_typedef)
typ2 = basetype(typ2);
if (isref(typ1))
typ1 = basetype(typ1)->btp;
if (isref(typ2))
typ2 = basetype(typ2)->btp;
if (ispointer(typ1) && ispointer(typ2))
if (exact)
{
int arr = FALSE;
int first = TRUE;
while (ispointer(typ1) && ispointer(typ2))
{
if (!first && (exact == 1))
if (isconst(typ2) && !isconst(typ1) || isvolatile(typ2) && !isvolatile(typ1))
return FALSE;
first = FALSE;
typ1 = basetype(typ1);
typ2 = basetype(typ2);
if (typ1->type != typ2->type)
return FALSE;
if (arr && typ1->array != typ2->array)
return FALSE;
if (arr && typ1->size != typ2->size)
return FALSE;
arr |= typ1->array | typ2->array;
typ1 = typ1->btp;
typ2 = typ2->btp;
}
if ((exact == 1) && (isconst(typ2) && !isconst(typ1) || isvolatile(typ2) && !isvolatile(typ1)))
return FALSE;
return comparetypes(typ1, typ2, TRUE);
}
else
return TRUE;
typ1 = basetype(typ1);
typ2 = basetype(typ2);
if (exact && (isfunction(typ1) || isfuncptr(typ1)) && (isfunction(typ2) || isfuncptr(typ2)))
{
HASHREC *hr1;
HASHREC *hr2;
typ1 = basetype(typ1);
typ2 = basetype(typ2);
if (ispointer(typ1))
typ1 = basetype(typ1->btp);
if (ispointer(typ2))
typ2 = basetype(typ2->btp);
if (!comparetypes(typ1->btp, typ2->btp, exact))
return FALSE;
hr1 = typ1->syms->table[0];
hr2 = typ2->syms->table[0];
while (hr1 && hr2)
{
SYMBOL *sp1 = (SYMBOL *)hr1->p;
SYMBOL *sp2 = (SYMBOL *)hr2->p;
if (!comparetypes(sp1->tp, sp2->tp, exact))
return FALSE;
hr1 = hr1->next;
hr2 = hr2->next;
}
if (hr1 || hr2)
return FALSE;
return TRUE;
}
if (cparams.prm_cplusplus)
{
if (typ1->scoped != typ2->scoped)
return FALSE;
if (typ1->type == bt_enum)
{
if (typ2->type == bt_enum)
return typ1->sp == typ2->sp;
else
return isint(typ2);
}
else if (typ2->type == bt_enum)
{
return isint(typ1);
}
if (typ1->type == typ2->type && typ1->type == bt_memberptr)
{
if (typ1->sp != typ2->sp)
{
if (classRefCount(typ2->sp, typ1->sp) != 1)
return FALSE;
}
return comparetypes(typ1->btp, typ2->btp, exact);
}
}
if (typ1->type == typ2->type && (isstructured(typ1) || exact && typ1->type == bt_enum))
return typ1->sp == typ2->sp;
if (typ1->type == typ2->type || !exact && isarithmetic(typ2) && isarithmetic(typ1))
return TRUE;
if (isfunction(typ1) && isfunction(typ2) &&
typ1->sp->linkage == typ2->sp->linkage)
return TRUE;
else if (!exact && (ispointer(typ1) && (isfuncptr(typ2) || isfunction(typ2) || isint(typ2))
|| ispointer(typ2) && (isfuncptr(typ1) || isfunction(typ1) || isint(typ1))))
return (TRUE);
else if (typ1->type == bt_enum && isint(typ2))
{
return TRUE;
}
else if (typ2->type == bt_enum && isint(typ1))
{
return TRUE;
}
return FALSE;
}
static int see_also(FILE *fp, char *refs, int flags)
{
int err= 0;
char *buf= strdup(refs);
#define isref(c) ( ('A'<=(c) && (c)<='Z') || \
('a'<=(c) && (c)<='z') || \
('0'<=(c) && (c)<='9') || ((c)=='_') || ((c)=='-') || ((c)=='/') || ((c)=='.') )
if(buf)
{
/* make `s' the working pointer in `buf' */
char *s= buf;
/*
* former revisions of ADOC used to indent the parsed references
* by the same amount of white space as the first. Actually we
* do not indent them amymore, so out it goes....
*/
/* indentation string of the first reference */
#if 0
char *indent= (char *)0;
#endif
int num_refs= 0;
while( *s && (err==0) )
{
char *l, *r;
/* move `l' and `r' to the left and right end of a reference in `s' */
for(l=s; *l && !isref(*l); l++) ;
for(r=l; *r && isref(*r); r++) ;
/* terminate the reference string with a '\0' */
if(*r) *r++= '\0';
/* save the indentation of the first reference */
#if 0
if(num_refs == 0)
{
if( (indent= strdup(s)) )
{
char *t= indent;
while(*t==' ' || *t=='\t')
++t;
*t= '\0';
}
else err= __LINE__;
}
#endif
/* move `s' behind the reference */
s= r;
if( *l && (err==0) )
{
/* look for a function `l' and initialize `fun' to it's name */
char *fun= (char *)0;
/*fprintf(stderr,"--> @ref{%s} ?\n",l);*/
if( getfun(l) )
fun= strdup(l);
else if( !strchr(l,'/') )
{
if( islib(l) )
fun= strdup(l);
else
{
/*
* Okay, we tried it the easy way but perhaps this is a reference
* into the library without the library name in front of it.
* Let's try appending `l' to the the current library name...
*/
char *f= getfun( (char *)0 );
if(f)
{
char *x, *xl, *xr;
if( (x= chapsec(f, &xl, &xr)) )
{
size_t len= strlen(xl) + 1 + strlen(l) + 1;
char *y= (char *)malloc( len * sizeof(char) );
if(y)
{
sprintf(y,"%s/%s",xl,l);
/*fprintf(stderr,"--> @ref{%s} ?\n",y);*/
if( getfun(y) )
fun= strdup(y);
free(y);
}
else err= __LINE__;
free(x);
}
else err= __LINE__;
}
else /* no current function? */
err= __LINE__;
}
}
if(err == 0)
{
/* print the reference */
if( fun )
{
char *cs, *chapter, *section;
if( (cs= chapsec(fun, &chapter, §ion)) )
{
if(flags & TEXI_ITEMIZE_REFERENCES)
{
if(num_refs==0)
fprintf(fp,"@itemize\n");
if(section) fprintf(fp,"@item\n@xref{%s%s%s}.\n",chapter,CHAPSEC,section);
else fprintf(fp,"@item\n@xref{%s}.\n",chapter);
}
else /* not itemized */
{
if( (num_refs==0) && (flags & TEXI_GROUP_SECTIONS) )
fprintf(fp,"@group\n");
fprintf(fp,"%s",(num_refs==0) ? "@*@xref" : "@ref");
if(section) fprintf(fp,"{%s%s%s},\n",chapter,CHAPSEC,section);
else fprintf(fp,"{%s},\n",chapter);
}
free(cs);
}
else err= __LINE__;
free(fun);
}
else /* !fun */
{
if(flags & TEXI_ITEMIZE_REFERENCES)
{
if(num_refs==0)
fprintf(fp,"@itemize\n");
fprintf(fp,"@item\nSee @file{%s}\n",l);
}
else /* not itemized */
{
if( (num_refs==0) && (flags & TEXI_GROUP_SECTIONS) )
fprintf(fp,"@group\n");
fprintf(fp,"%s{%s},\n",((num_refs==0) ? "@*See @file":"@file"),l);
}
}
/* now at least one reference is printed */
++num_refs;
}
}
}
if(num_refs > 0)
{
if(flags & TEXI_ITEMIZE_REFERENCES)
fprintf(fp,"@end itemize\n");
else /* not itemized */
{
if(flags & TEXI_GROUP_SECTIONS)
fprintf(fp,"@end group\n");
fprintf(fp,"for more information.\n");
}
}
#if 0
if(indent)
free(indent);
#endif
free(buf);
}
else err= __LINE__;
#undef isref
return err;
}
/*-----------------------------------------------------------------------------*/
int GetColumn()
{
struct Cursor *cur = (struct Cursor *)ptoc_int(2);
int ColCurNum = ptoc_int(3);
Cell op1;
Cell op = ptoc_tag(4);
UDWORD len;
if (ColCurNum < 0 || ColCurNum >= cur->NumCols) {
/* no more columns in the result row*/
ctop_int(5,1);
return TRUE;
}
ctop_int(5,0);
/* get the data*/
if (cur->OutLen[ColCurNum] == SQL_NULL_DATA) {
/* column value is NULL*/
return unify(op,nullStrAtom);
}
/* convert the string to either integer, float or string*/
/* according to the column type and pass it back to XSB*/
switch (ODBCToXSBType(cur->ColTypes[ColCurNum])) {
case SQL_C_CHAR:
/* convert the column string to a C string */
len = ((cur->ColLen[ColCurNum] < cur->OutLen[ColCurNum])?
cur->ColLen[ColCurNum]:cur->OutLen[ColCurNum]);
*(cur->Data[ColCurNum]+len) = '\0';
/* compare strings here, so don't intern strings unnecessarily*/
XSB_Deref(op);
if (isref(op))
return unify(op, makestring(string_find(cur->Data[ColCurNum],1)));
if (isconstr(op) && get_arity(get_str_psc(op)) == 1) {
STRFILE strfile;
op1 = cell(clref_val(op)+1);
XSB_Deref(op1);
strfile.strcnt = strlen(cur->Data[ColCurNum]);
strfile.strptr = strfile.strbase = cur->Data[ColCurNum];
read_canonical_term(NULL,&strfile,op1); /* terminating '.'? */
return TRUE;
}
if (!isstring(op)) return FALSE;
if (strcmp(string_val(op),cur->Data[ColCurNum])) return FALSE;
return TRUE;
case SQL_C_BINARY:
/* convert the column string to a C string */
len = ((cur->ColLen[ColCurNum] < cur->OutLen[ColCurNum])?
cur->ColLen[ColCurNum]:cur->OutLen[ColCurNum]);
*(cur->Data[ColCurNum]+len) = '\0';
/* compare strings here, so don't intern strings unnecessarily*/
XSB_Deref(op);
if (isref(op))
return unify(op, makestring(string_find(cur->Data[ColCurNum],1)));
if (isconstr(op) && get_arity(get_str_psc(op)) == 1) {
STRFILE strfile;
op1 = cell(clref_val(op)+1);
XSB_Deref(op1);
strfile.strcnt = strlen(cur->Data[ColCurNum]);
strfile.strptr = strfile.strbase = cur->Data[ColCurNum];
read_canonical_term(NULL,&strfile,op1); /* terminating '.'? */
return TRUE;
}
if (!isstring(op)) return FALSE;
if (strcmp(string_val(op),cur->Data[ColCurNum])) return FALSE;
return TRUE;
case SQL_C_SLONG:
return unify(op,makeint(*(long *)(cur->Data[ColCurNum])));
case SQL_C_FLOAT:
return unify(op,makefloat(*(float *)(cur->Data[ColCurNum])));
}
return FALSE;
}
/* XSB string substitution entry point
In:
Arg1: string
Arg2: beginning offset
Arg3: ending offset. `_' or -1: end of string, -2: char before last, etc.
Out:
Arg4: new (output) string
Always succeeds, unless error.
*/
xsbBool substring(CTXTdecl)
{
/* Prolog args are first assigned to these, so we could examine the types
of these objects to determine if we got strings or atoms. */
prolog_term input_term, output_term;
prolog_term beg_offset_term, end_offset_term;
char *input_string=NULL; /* string where matches are to be found */
Integer beg_offset=0, end_offset=0, input_len=0, substring_len=0;
int conversion_required=FALSE;
XSB_StrSet(&output_buffer,"");
input_term = reg_term(CTXTc 1); /* Arg1: string to find matches in */
if (isatom(input_term)) /* check it */
input_string = string_val(input_term);
else if (islist(input_term)) {
input_string = p_charlist_to_c_string(CTXTc input_term, &input_buffer,
"SUBSTRING", "input string");
conversion_required = TRUE;
} else
xsb_abort("[SUBSTRING] Arg 1 (the input string) must be an atom or a character list");
input_len = strlen(input_string);
/* arg 2: beginning offset */
beg_offset_term = reg_term(CTXTc 2);
if (! (isointeger(beg_offset_term)))
xsb_abort("[SUBSTRING] Arg 2 (the beginning offset) must be an integer");
beg_offset = oint_val(beg_offset_term);
if (beg_offset < 0)
beg_offset = 0;
else if (beg_offset > input_len)
beg_offset = input_len;
/* arg 3: ending offset */
end_offset_term = reg_term(CTXTc 3);
if (isref(end_offset_term))
end_offset = input_len;
else if (! (isointeger(end_offset_term)))
xsb_abort("[SUBSTRING] Arg 3 (the end offset) must be integer or _");
else end_offset = oint_val(end_offset_term);
if (end_offset < 0)
end_offset = input_len + 1 + end_offset;
else if (end_offset > input_len)
end_offset = input_len;
else if (end_offset < beg_offset)
end_offset = beg_offset;
output_term = reg_term(CTXTc 4);
if (! isref(output_term))
xsb_abort("[SUBSTRING] Arg 4 (the output string) must be an unbound variable");
/* do the actual replacement */
substring_len = end_offset-beg_offset;
XSB_StrAppendBlk(&output_buffer, input_string+beg_offset, (int)substring_len);
XSB_StrNullTerminate(&output_buffer);
/* get result out */
if (conversion_required)
c_string_to_p_charlist(CTXTc output_buffer.string, output_term,
4, "SUBSTRING", "Arg 4");
else
c2p_string(CTXTc output_buffer.string, output_term);
return(TRUE);
}
static void renameToTemps(SYMBOL *funcsp)
{
HASHTABLE *temp = funcsp->inlineFunc.syms;
if (!cparams.prm_optimize || functionHasAssembly)
return;
/* if there is a setjmp in the function, no variable gets moved into a reg */
if (setjmp_used)
return;
while (temp)
{
HASHREC *hr = temp->table[0];
while (hr)
{
SYMBOL *sp = (SYMBOL *)hr->p;
TYPE *tp;
/* needed for pointer aliasing */
if (!sp->imvalue && basetype(sp->tp)->type != bt_memberptr && !isstructured(sp->tp) && sp->tp->type != bt_ellipse && sp->tp->type != bt_aggregate)
{
if (sp->storage_class != sc_auto && sp->storage_class !=
sc_register)
{
IncGlobalFlag();
}
if (sp->imaddress)
{
IMODE *im = Alloc(sizeof(IMODE));
*im = *sp->imaddress;
im->size = sizeFromType(sp->tp);
im->mode = i_direct;
sp->imvalue = im;
}
else if (sp->imind)
{
IMODE *im = Alloc(sizeof(IMODE));
*im = *sp->imind->im;
im-> size = ISZ_ADDR;
im->mode = i_direct;
sp->imvalue = im;
}
else
sp->imvalue = tempreg(sizeFromType(sp->tp), FALSE);
if (sp->storage_class != sc_auto && sp->storage_class !=
sc_register)
{
DecGlobalFlag();
}
}
tp = sp->tp;
if (tp->type == bt_typedef)
tp = tp->btp;
if (!sp->pushedtotemp && sp->storage_class != sc_parameter && !sp->imaddress && !sp->inasm
&& ((chosenAssembler->arch->hasFloatRegs || tp->type < bt_float) && tp->type < bt_void || basetype(tp)->type == bt_pointer && basetype(tp)->btp->type != bt_func
|| isref(tp))
&& (sp->storage_class == sc_auto || sp->storage_class == sc_register)
&& !sp->usedasbit)
{
/* this works because all IMODES refering to the same
* variable are the same, at least until this point
* that will change when we start inserting temps
*/
EXPRESSION *ep = tempenode();
ep->v.sp->tp = sp->tp;
ep->right = (EXPRESSION *)sp;
/* marking both the orignal var and the new temp as pushed to temp*/
sp->pushedtotemp = TRUE ;
ep->v.sp->pushedtotemp = TRUE;
sp->allocate = FALSE;
if (sp->imvalue)
{
ep->isvolatile = sp->imvalue->offset->isvolatile;
ep->isrestrict = sp->imvalue->offset->isrestrict;
sp->imvalue->offset = ep ;
}
if (sp->imind)
{
IMODELIST *iml = sp->imind;
ep->isvolatile = sp->imind->im->offset->isvolatile;
ep->isrestrict = sp->imind->im->offset->isrestrict;
while (iml)
{
iml->im->offset = ep;
iml = iml->next;
}
}
ep->v.sp->imvalue = sp->imvalue;
}
hr = hr->next;
}
temp = temp->next;
}
}
BOOLEAN comparetypes(TYPE *typ1, TYPE *typ2, int exact)
{
if (typ1->type == bt_any || typ2->type == bt_any)
return TRUE;
while (typ1->type == bt_typedef)
typ1 = basetype(typ1);
while (typ2->type == bt_typedef)
typ2 = basetype(typ2);
typ1 = replaceTemplateSelector(typ1);
typ2 = replaceTemplateSelector(typ2);
if (isDerivedFromTemplate(typ1))
typ1 = typ1->btp;
if (isDerivedFromTemplate(typ2))
typ2 = typ2->btp;
while (isref(typ1))
typ1 = basetype(typ1)->btp;
while (isref(typ2))
typ2 = basetype(typ2)->btp;
while (typ1->type == bt_typedef)
typ1 = basetype(typ1);
while (typ2->type == bt_typedef)
typ2 = basetype(typ2);
if (typ1->type == bt_templateselector && typ2->type == bt_templateselector)
return templateselectorcompare(typ1->sp->templateSelector, typ2->sp->templateSelector);
if (typ1->type == bt_templatedecltype && typ2->type == bt_templatedecltype)
return templatecompareexpressions(typ1->templateDeclType, typ2->templateDeclType);
if (ispointer(typ1) && ispointer(typ2))
{
if (exact)
{
int arr = FALSE;
int first = TRUE;
while (ispointer(typ1) && ispointer(typ2))
{
if (!first && (exact == 1))
if ((isconst(typ2) && !isconst(typ1)) || (isvolatile(typ2) && !isvolatile(typ1)))
return FALSE;
first = FALSE;
typ1 = basetype(typ1);
typ2 = basetype(typ2);
if (typ1->type != typ2->type)
return FALSE;
if (arr && typ1->array != typ2->array)
return FALSE;
if (arr && typ1->size != typ2->size)
return FALSE;
arr |= typ1->array | typ2->array;
typ1 = typ1->btp;
typ2 = typ2->btp;
}
if (exact == 1 && ((isconst(typ2) && !isconst(typ1)) || (isvolatile(typ2) && !isvolatile(typ1))))
return FALSE;
return comparetypes(typ1, typ2, TRUE);
}
else
return TRUE;
}
typ1 = basetype(typ1);
typ2 = basetype(typ2);
if (exact && (isfunction(typ1) || isfuncptr(typ1)) && (isfunction(typ2) || isfuncptr(typ2)))
{
HASHREC *hr1;
HASHREC *hr2;
typ1 = basetype(typ1);
typ2 = basetype(typ2);
if (ispointer(typ1))
typ1 = basetype(typ1)->btp;
if (ispointer(typ2))
typ2 = basetype(typ2)->btp;
if (!comparetypes(typ1->btp, typ2->btp, exact))
return FALSE;
if (!matchOverload(typ1, typ2, TRUE))
return FALSE;
return TRUE;
}
if (cparams.prm_cplusplus)
{
if (typ1->scoped != typ2->scoped)
return FALSE;
if (typ1->type == bt_enum)
{
if (typ2->type == bt_enum)
return typ1->sp == typ2->sp;
else
return isint(typ2);
}
else if (typ2->type == bt_enum)
{
return isint(typ1);
}
if (typ1->type == typ2->type && typ1->type == bt_memberptr)
{
if (typ1->sp != typ2->sp)
{
if (classRefCount(typ1->sp, typ2->sp) != 1)
return FALSE;
}
return comparetypes(typ1->btp, typ2->btp, exact);
}
}
if (typ1->type == typ2->type && (isstructured(typ1) || (exact && typ1->type == bt_enum)))
return typ1->sp == typ2->sp;
if (typ1->type == typ2->type || (!exact && isarithmetic(typ2) && isarithmetic(typ1)))
return TRUE;
if (isfunction(typ1) && isfunction(typ2) &&
typ1->sp->linkage == typ2->sp->linkage)
return TRUE;
else if (!exact && ((ispointer(typ1) && (isfuncptr(typ2) || isfunction(typ2) || isint(typ2)))
|| (ispointer(typ2) && (isfuncptr(typ1) || isfunction(typ1) || isint(typ1)))))
return (TRUE);
else if (typ1->type == bt_enum && isint(typ2))
{
return TRUE;
}
else if (typ2->type == bt_enum && isint(typ1))
{
return TRUE;
}
return FALSE;
}
static BOOLEAN is_convertible_to(LEXEME **lex, SYMBOL *funcsp, SYMBOL *sym, TYPE **tp, EXPRESSION **exp)
{
BOOLEAN rv = TRUE;
FUNCTIONCALL funcparams;
memset(&funcparams, 0, sizeof(funcparams));
funcparams.sp = sym;
*lex = getTypeList(*lex, funcsp, &funcparams.arguments);
if (funcparams.arguments && funcparams.arguments->next && !funcparams.arguments->next->next)
{
TYPE *from = funcparams.arguments->tp;
TYPE *to = funcparams.arguments->next->tp;
if (isref(from) && isref(to))
{
if (basetype(to)->type == bt_lref)
{
if (basetype(from)->type == bt_rref)
rv = FALSE;
}
}
else if (isref(from))
rv = FALSE;
if (isfunction(from))
from = basetype(from)->btp;
if (rv)
{
while (isref(from))
from = basetype(from)->btp;
while (isref(to))
to = basetype(to)->btp;
rv = comparetypes(to, from, FALSE);
if (!rv && isstructured(from) && isstructured(to))
{
if (classRefCount(basetype(to)->sp, basetype(from)->sp) == 1)
rv = TRUE;
}
if (!rv && isstructured(from))
{
SYMBOL *sp = search("$bcall", basetype(from)->syms);
if (sp)
{
HASHREC *hr = sp->tp->syms->table[0];
while (hr)
{
if (comparetypes(basetype(((SYMBOL *)hr->p)->tp)->btp, to, FALSE))
{
rv= TRUE;
break;
}
hr = hr->next;
}
}
}
}
}
else
{
rv = FALSE;
}
*exp = intNode(en_c_i, rv);
*tp = &stdint;
return TRUE;
}
static BOOLEAN is_constructible(LEXEME **lex, SYMBOL *funcsp, SYMBOL *sym, TYPE **tp, EXPRESSION **exp)
{
INITLIST *lst;
BOOLEAN rv = FALSE;
FUNCTIONCALL funcparams;
memset(&funcparams, 0, sizeof(funcparams));
funcparams.sp = sym;
*lex = getTypeList(*lex, funcsp, &funcparams.arguments);
lst = funcparams.arguments;
while (lst)
{
lst->tp = PerformDeferredInitialization(lst->tp, NULL);
lst = lst->next;
}
if (funcparams.arguments)
{
TYPE *tp2 = funcparams.arguments->tp;
if (isarray(tp2))
{
while (isarray(tp2) && tp2->size != 0)
tp2 = tp2->btp;
if (isarray(tp2))
{
tp2 = FALSE;
}
}
if (tp2)
{
if (isarithmetic(tp2) || ispointer(tp2) || basetype(tp2)->type == bt_enum)
{
if (!funcparams.arguments->next)
{
rv = TRUE;
}
else if (!funcparams.arguments->next->next)
{
rv = comparetypes(tp2, funcparams.arguments->next->tp, TRUE);
}
}
else if (isref(tp2))
{
if (funcparams.arguments->next && !funcparams.arguments->next->next)
{
rv = comparetypes(tp2, funcparams.arguments->next->tp, TRUE);
}
}
else if (isstructured(tp2))
{
TYPE *ctp = tp2;
EXPRESSION *cexp = NULL;
SYMBOL *cons = search(overloadNameTab[CI_CONSTRUCTOR], basetype(tp2)->syms);
funcparams.thisptr = intNode(en_c_i, 0);
funcparams.thistp = Alloc(sizeof(TYPE));
funcparams.thistp->type = bt_pointer;
funcparams.thistp->btp = basetype(tp2);
funcparams.thistp->size = getSize(bt_pointer);
funcparams.ascall = TRUE;
funcparams.arguments = funcparams.arguments->next;
rv = GetOverloadedFunction(tp, &funcparams.fcall, cons, &funcparams, NULL, FALSE,
FALSE, FALSE, _F_SIZEOF) != NULL;
}
}
}
*exp = intNode(en_c_i, rv);
*tp = &stdint;
return TRUE;
}
/* XSB string substitution entry point: replace substrings specified in Arg2
with strings in Arg3.
In:
Arg1: string
Arg2: substring specification, a list [s(B1,E1),s(B2,E2),...]
Arg3: list of replacement strings
Out:
Arg4: new (output) string
Always succeeds, unless error.
*/
xsbBool string_substitute(CTXTdecl)
{
/* Prolog args are first assigned to these, so we could examine the types
of these objects to determine if we got strings or atoms. */
prolog_term input_term, output_term;
prolog_term subst_reg_term, subst_spec_list_term, subst_spec_list_term1;
prolog_term subst_str_term=(prolog_term)0,
subst_str_list_term, subst_str_list_term1;
char *input_string=NULL; /* string where matches are to be found */
char *subst_string=NULL;
prolog_term beg_term, end_term;
Integer beg_offset=0, end_offset=0, input_len;
Integer last_pos = 0; /* last scanned pos in input string */
/* the output buffer is made large enough to include the input string and the
substitution string. */
int conversion_required=FALSE; /* from C string to Prolog char list */
XSB_StrSet(&output_buffer,"");
input_term = reg_term(CTXTc 1); /* Arg1: string to find matches in */
if (isatom(input_term)) /* check it */
input_string = string_val(input_term);
else if (islist(input_term)) {
input_string = p_charlist_to_c_string(CTXTc input_term, &input_buffer,
"STRING_SUBSTITUTE", "input string");
conversion_required = TRUE;
} else
xsb_abort("[STRING_SUBSTITUTE] Arg 1 (the input string) must be an atom or a character list");
input_len = strlen(input_string);
/* arg 2: substring specification */
subst_spec_list_term = reg_term(CTXTc 2);
if (!islist(subst_spec_list_term) && !isnil(subst_spec_list_term))
xsb_abort("[STRING_SUBSTITUTE] Arg 2 must be a list [s(B1,E1),s(B2,E2),...]");
/* handle substitution string */
subst_str_list_term = reg_term(CTXTc 3);
if (! islist(subst_str_list_term))
xsb_abort("[STRING_SUBSTITUTE] Arg 3 must be a list of strings");
output_term = reg_term(CTXTc 4);
if (! isref(output_term))
xsb_abort("[STRING_SUBSTITUTE] Arg 4 (the output) must be an unbound variable");
subst_spec_list_term1 = subst_spec_list_term;
subst_str_list_term1 = subst_str_list_term;
if (isnil(subst_spec_list_term1)) {
XSB_StrSet(&output_buffer, input_string);
goto EXIT;
}
if (isnil(subst_str_list_term1))
xsb_abort("[STRING_SUBSTITUTE] Arg 3 must not be an empty list");
do {
subst_reg_term = p2p_car(subst_spec_list_term1);
subst_spec_list_term1 = p2p_cdr(subst_spec_list_term1);
if (!isnil(subst_str_list_term1)) {
subst_str_term = p2p_car(subst_str_list_term1);
subst_str_list_term1 = p2p_cdr(subst_str_list_term1);
if (isatom(subst_str_term)) {
subst_string = string_val(subst_str_term);
} else if (islist(subst_str_term)) {
subst_string = p_charlist_to_c_string(CTXTc subst_str_term, &subst_buf,
"STRING_SUBSTITUTE",
"substitution string");
} else
xsb_abort("[STRING_SUBSTITUTE] Arg 3 must be a list of strings");
}
beg_term = p2p_arg(subst_reg_term,1);
end_term = p2p_arg(subst_reg_term,2);
if (!(isointeger(beg_term)) ||
!(isointeger(end_term)))
xsb_abort("[STRING_SUBSTITUTE] Non-integer in Arg 2");
else {
beg_offset = oint_val(beg_term);
end_offset = oint_val(end_term);
}
/* -1 means end of string */
if (end_offset < 0)
end_offset = input_len;
if ((end_offset < beg_offset) || (beg_offset < last_pos))
xsb_abort("[STRING_SUBSTITUTE] Substitution regions in Arg 2 not sorted");
/* do the actual replacement */
XSB_StrAppendBlk(&output_buffer,input_string+last_pos,(int)(beg_offset-last_pos));
XSB_StrAppend(&output_buffer, subst_string);
last_pos = end_offset;
} while (!isnil(subst_spec_list_term1));
XSB_StrAppend(&output_buffer, input_string+end_offset);
EXIT:
/* get result out */
if (conversion_required)
c_string_to_p_charlist(CTXTc output_buffer.string, output_term,
4, "STRING_SUBSTITUTE", "Arg 4");
else
c2p_string(CTXTc output_buffer.string, output_term);
return(TRUE);
}
/* TLS: making a conservative guess at which system calls need to be
mutexed. I'm doing it whenever I see the process table altered or
affected, so this is the data structure that its protecting.
At some point, the SET_FILEPTRs should be protected against other
threads closing that stream. Perhaps for such things a
thread-specific stream table should be used.
*/
xsbBool sys_system(CTXTdeclc int callno)
{
// int pid;
Integer pid;
switch (callno) {
case PLAIN_SYSTEM_CALL: /* dumb system call: no communication with XSB */
/* this call is superseded by shell and isn't used */
ctop_int(CTXTc 3, system(ptoc_string(CTXTc 2)));
return TRUE;
case SLEEP_FOR_SECS:
#ifdef WIN_NT
Sleep((int)iso_ptoc_int_arg(CTXTc 2,"sleep/1",1) * 1000);
#else
sleep(iso_ptoc_int_arg(CTXTc 2,"sleep/1",1));
#endif
return TRUE;
case GET_TMP_FILENAME:
ctop_string(CTXTc 2,tempnam(NULL,NULL));
return TRUE;
case IS_PLAIN_FILE:
case IS_DIRECTORY:
case STAT_FILE_TIME:
case STAT_FILE_SIZE:
return file_stat(CTXTc callno, ptoc_longstring(CTXTc 2));
case EXEC: {
#ifdef HAVE_EXECVP
/* execs a new process in place of XSB */
char *params[MAX_SUBPROC_PARAMS+2];
prolog_term cmdspec_term;
int index = 0;
cmdspec_term = reg_term(CTXTc 2);
if (islist(cmdspec_term)) {
prolog_term temp, head;
char *string_head=NULL;
if (isnil(cmdspec_term))
xsb_abort("[exec] Arg 1 must not be an empty list.");
temp = cmdspec_term;
do {
head = p2p_car(temp);
temp = p2p_cdr(temp);
if (isstring(head))
string_head = string_val(head);
else
xsb_abort("[exec] non-string argument passed in list.");
params[index++] = string_head;
if (index > MAX_SUBPROC_PARAMS)
xsb_abort("[exec] Too many arguments.");
} while (!isnil(temp));
params[index] = NULL;
} else if (isstring(cmdspec_term)) {
char *string = string_val(cmdspec_term);
split_command_arguments(string, params, "exec");
} else
xsb_abort("[exec] 1st argument should be term or list of strings.");
if (execvp(params[0], params))
xsb_abort("[exec] Exec call failed.");
#else
xsb_abort("[exec] builtin not supported in this architecture.");
#endif
}
case SHELL: /* smart system call: like SPAWN_PROCESS, but returns error code
instead of PID. Uses system() rather than execvp.
Advantage: can pass arbitrary shell command. */
case SPAWN_PROCESS: { /* spawn new process, reroute stdin/out/err to XSB */
/* +CallNo=2, +ProcAndArgsList,
-StreamToProc, -StreamFromProc, -StreamFromProcStderr,
-Pid */
static int pipe_to_proc[2], pipe_from_proc[2], pipe_from_stderr[2];
int toproc_stream=-1, fromproc_stream=-1, fromproc_stderr_stream=-1;
int pid_or_status;
FILE *toprocess_fptr=NULL,
*fromprocess_fptr=NULL, *fromproc_stderr_fptr=NULL;
char *params[MAX_SUBPROC_PARAMS+2]; /* one for progname--0th member,
one for NULL termination*/
prolog_term cmdspec_term, cmdlist_temp_term;
prolog_term cmd_or_arg_term;
xsbBool toproc_needed=FALSE, fromproc_needed=FALSE, fromstderr_needed=FALSE;
char *cmd_or_arg=NULL, *shell_cmd=NULL;
int idx = 0, tbl_pos;
char *callname=NULL;
xsbBool params_are_in_a_list=FALSE;
SYS_MUTEX_LOCK( MUTEX_SYS_SYSTEM );
init_process_table();
if (callno == SPAWN_PROCESS)
callname = "spawn_process/5";
else
callname = "shell/[1,2,5]";
cmdspec_term = reg_term(CTXTc 2);
if (islist(cmdspec_term))
params_are_in_a_list = TRUE;
else if (isstring(cmdspec_term))
shell_cmd = string_val(cmdspec_term);
else if (isref(cmdspec_term))
xsb_instantiation_error(CTXTc callname,1);
else
xsb_type_error(CTXTc "atom or list e.g. [command, arg, ...]",cmdspec_term,callname,1);
// xsb_abort("[%s] Arg 1 must be an atom or a list [command, arg, ...]",
// callname);
/* the user can indicate that he doesn't want either of the streams created
by putting an atom in the corresponding argument position */
if (isref(reg_term(CTXTc 3)))
toproc_needed = TRUE;
if (isref(reg_term(CTXTc 4)))
fromproc_needed = TRUE;
if (isref(reg_term(CTXTc 5)))
fromstderr_needed = TRUE;
/* if any of the arg streams is already used by XSB, then don't create
pipes --- use these streams instead. */
if (isointeger(reg_term(CTXTc 3))) {
SET_FILEPTR(toprocess_fptr, oint_val(reg_term(CTXTc 3)));
}
if (isointeger(reg_term(CTXTc 4))) {
SET_FILEPTR(fromprocess_fptr, oint_val(reg_term(CTXTc 4)));
}
if (isointeger(reg_term(CTXTc 5))) {
SET_FILEPTR(fromproc_stderr_fptr, oint_val(reg_term(CTXTc 5)));
}
if (!isref(reg_term(CTXTc 6)))
xsb_type_error(CTXTc "variable (to return process id)",reg_term(CTXTc 6),callname,5);
// xsb_abort("[%s] Arg 5 (process id) must be a variable", callname);
if (params_are_in_a_list) {
/* fill in the params[] array */
if (isnil(cmdspec_term))
xsb_abort("[%s] Arg 1 must not be an empty list", callname);
cmdlist_temp_term = cmdspec_term;
do {
cmd_or_arg_term = p2p_car(cmdlist_temp_term);
cmdlist_temp_term = p2p_cdr(cmdlist_temp_term);
if (isstring(cmd_or_arg_term)) {
cmd_or_arg = string_val(cmd_or_arg_term);
}
else
xsb_abort("[%s] Non string list member in the Arg",
callname);
params[idx++] = cmd_or_arg;
if (idx > MAX_SUBPROC_PARAMS)
xsb_abort("[%s] Too many arguments passed to subprocess",
callname);
} while (!isnil(cmdlist_temp_term));
params[idx] = NULL; /* null termination */
} else { /* params are in a string */
if (callno == SPAWN_PROCESS)
split_command_arguments(shell_cmd, params, callname);
else {
/* if callno==SHELL => call system() => don't split shell_cmd */
params[0] = shell_cmd;
params[1] = NULL;
}
}
/* -1 means: no space left */
if ((tbl_pos = get_free_process_cell()) < 0) {
xsb_warn(CTXTc "Can't create subprocess because XSB process table is full");
SYS_MUTEX_UNLOCK( MUTEX_SYS_SYSTEM );
return FALSE;
}
/* params[0] is the progname */
pid_or_status = xsb_spawn(CTXTc params[0], params, callno,
(toproc_needed ? pipe_to_proc : NULL),
(fromproc_needed ? pipe_from_proc : NULL),
(fromstderr_needed ? pipe_from_stderr : NULL),
toprocess_fptr, fromprocess_fptr,
fromproc_stderr_fptr);
if (pid_or_status < 0) {
xsb_warn(CTXTc "[%s] Subprocess creation failed, Error: %d, errno: %d, Cmd: %s", callname,pid_or_status,errno,params[0]);
SYS_MUTEX_UNLOCK( MUTEX_SYS_SYSTEM );
return FALSE;
}
if (toproc_needed) {
toprocess_fptr = fdopen(pipe_to_proc[1], "w");
toproc_stream = xsb_intern_fileptr(CTXTc toprocess_fptr,callname,"pipe","w",CURRENT_CHARSET);
ctop_int(CTXTc 3, toproc_stream);
}
if (fromproc_needed) {
fromprocess_fptr = fdopen(pipe_from_proc[0], "r");
fromproc_stream = xsb_intern_fileptr(CTXTc fromprocess_fptr,callname,"pipe","r",CURRENT_CHARSET);
ctop_int(CTXTc 4, fromproc_stream);
}
if (fromstderr_needed) {
fromproc_stderr_fptr = fdopen(pipe_from_stderr[0], "r");
fromproc_stderr_stream
= xsb_intern_fileptr(CTXTc fromproc_stderr_fptr,callname,"pipe","r",CURRENT_CHARSET);
ctop_int(CTXTc 5, fromproc_stderr_stream);
}
ctop_int(CTXTc 6, pid_or_status);
xsb_process_table.process[tbl_pos].pid = pid_or_status;
xsb_process_table.process[tbl_pos].to_stream = toproc_stream;
xsb_process_table.process[tbl_pos].from_stream = fromproc_stream;
xsb_process_table.process[tbl_pos].stderr_stream = fromproc_stderr_stream;
concat_array(CTXTc params, " ",
xsb_process_table.process[tbl_pos].cmdline,MAX_CMD_LEN);
SYS_MUTEX_UNLOCK( MUTEX_SYS_SYSTEM );
return TRUE;
}
case GET_PROCESS_TABLE: { /* sys_system(3, X). X is bound to the list
of the form [process(Pid,To,From,Stderr,Cmdline), ...] */
int i;
prolog_term table_term_tail, listHead;
prolog_term table_term=reg_term(CTXTc 2);
SYS_MUTEX_LOCK( MUTEX_SYS_SYSTEM );
init_process_table();
if (!isref(table_term))
xsb_abort("[GET_PROCESS_TABLE] Arg 1 must be a variable");
table_term_tail = table_term;
for (i=0; i<MAX_SUBPROC_NUMBER; i++) {
if (!FREE_PROC_TABLE_CELL(xsb_process_table.process[i].pid)) {
c2p_list(CTXTc table_term_tail); /* make it into a list */
listHead = p2p_car(table_term_tail);
c2p_functor(CTXTc "process", 5, listHead);
c2p_int(CTXTc xsb_process_table.process[i].pid, p2p_arg(listHead,1));
c2p_int(CTXTc xsb_process_table.process[i].to_stream, p2p_arg(listHead,2));
c2p_int(CTXTc xsb_process_table.process[i].from_stream, p2p_arg(listHead,3));
c2p_int(CTXTc xsb_process_table.process[i].stderr_stream,
p2p_arg(listHead,4));
c2p_string(CTXTc xsb_process_table.process[i].cmdline, p2p_arg(listHead,5));
table_term_tail = p2p_cdr(table_term_tail);
}
}
c2p_nil(CTXTc table_term_tail); /* bind tail to nil */
SYS_MUTEX_UNLOCK( MUTEX_SYS_SYSTEM );
return p2p_unify(CTXTc table_term, reg_term(CTXTc 2));
}
case PROCESS_STATUS: {
prolog_term pid_term=reg_term(CTXTc 2), status_term=reg_term(CTXTc 3);
SYS_MUTEX_LOCK( MUTEX_SYS_SYSTEM );
init_process_table();
if (!(isointeger(pid_term)))
xsb_abort("[PROCESS_STATUS] Arg 1 (process id) must be an integer");
pid = (int)oint_val(pid_term);
if (!isref(status_term))
xsb_abort("[PROCESS_STATUS] Arg 2 (process status) must be a variable");
switch (process_status(pid)) {
case RUNNING:
c2p_string(CTXTc "running", status_term);
break;
case STOPPED:
c2p_string(CTXTc "stopped", status_term);
break;
case EXITED_NORMALLY:
c2p_string(CTXTc "exited_normally", status_term);
break;
case EXITED_ABNORMALLY:
c2p_string(CTXTc "exited_abnormally", status_term);
break;
case ABORTED:
c2p_string(CTXTc "aborted", status_term);
break;
case INVALID:
c2p_string(CTXTc "invalid", status_term);
break;
default:
c2p_string(CTXTc "unknown", status_term);
}
SYS_MUTEX_UNLOCK( MUTEX_SYS_SYSTEM );
return TRUE;
}
case PROCESS_CONTROL: {
/* sys_system(PROCESS_CONTROL, +Pid, +Signal). Signal: wait, kill */
int status;
prolog_term pid_term=reg_term(CTXTc 2), signal_term=reg_term(CTXTc 3);
SYS_MUTEX_LOCK( MUTEX_SYS_SYSTEM );
init_process_table();
if (!(isointeger(pid_term)))
xsb_abort("[PROCESS_CONTROL] Arg 1 (process id) must be an integer");
pid = (int)oint_val(pid_term);
if (isstring(signal_term) && strcmp(string_val(signal_term), "kill")==0) {
if (KILL_FAILED(pid)) {
SYS_MUTEX_UNLOCK( MUTEX_SYS_SYSTEM );
return FALSE;
}
#ifdef WIN_NT
CloseHandle((HANDLE) pid);
#endif
SYS_MUTEX_UNLOCK( MUTEX_SYS_SYSTEM );
return TRUE;
}
if (isconstr(signal_term)
&& strcmp(p2c_functor(signal_term),"wait") == 0
&& p2c_arity(signal_term)==1) {
int exit_status;
if (WAIT(pid, status) < 0) {
SYS_MUTEX_UNLOCK( MUTEX_SYS_SYSTEM );
return FALSE;
}
#ifdef WIN_NT
exit_status = status;
#else
if (WIFEXITED(status))
exit_status = WEXITSTATUS(status);
else
exit_status = -1;
#endif
p2p_unify(CTXTc p2p_arg(signal_term,1), makeint(exit_status));
SYS_MUTEX_UNLOCK( MUTEX_SYS_SYSTEM );
return TRUE;
}
xsb_warn(CTXTc "[PROCESS_CONTROL] Arg 2: Invalid signal specification. Must be `kill' or `wait(Var)'");
return FALSE;
}
case LIST_DIRECTORY: {
/* assume all type- and mode-checking is done in Prolog */
prolog_term handle = reg_term(CTXTc 2); /* ref for handle */
char *dir_name = ptoc_longstring(CTXTc 3); /* +directory name */
prolog_term filename = reg_term(CTXTc 4); /* reference for name of file */
if (is_var(handle))
return xsb_find_first_file(CTXTc handle,dir_name,filename);
else
return xsb_find_next_file(CTXTc handle,dir_name,filename);
}
default:
xsb_abort("[SYS_SYSTEM] Wrong call number (an XSB bug)");
} /* end case */
return TRUE;
}
TYPE *destSize(TYPE *tp1, TYPE *tp2, EXPRESSION **exp1, EXPRESSION **exp2, BOOLEAN minimizeInt, TYPE *atp)
/*
* compare two types and determine if they are compatible for purposes
* of the current operation. Return an appropriate type. Also checks for
* dangerous pointer conversions...
*/
{
int isctp1, isctp2;
if (tp1->type == bt_any)
return tp1;
if (tp2->type == bt_any)
return tp2;
if (isvoid(tp1) || isvoid(tp2))
{
error(ERR_NOT_AN_ALLOWED_TYPE);
return tp1;
}
if (isref(tp1))
tp1 = basetype(tp1)->btp;
if (isref(tp2))
tp2 = basetype(tp2)->btp;
tp1 = basetype(tp1);
tp2 = basetype(tp2);
isctp1 = isarithmetic(tp1);
isctp2 = isarithmetic(tp2);
/* if (isctp1 && isctp2 && tp1->type == tp2->type)
return tp1 ;
*/
if (tp1->type >= bt_float || tp2->type >= bt_float) {
int isim1 = tp1->type >= bt_float_imaginary && tp1->type <= bt_long_double_imaginary;
int isim2 = tp2->type >= bt_float_imaginary && tp2->type <= bt_long_double_imaginary;
if (isim1 && !isim2 && tp2->type < bt_float_imaginary)
{
TYPE *tp ;
if (tp1->type == bt_long_double_imaginary || tp2->type == bt_long_double)
tp = &stdlongdoublecomplex;
else if (tp1->type == bt_double_imaginary || tp2->type == bt_double
|| tp1->type == bt_long_long || tp1->type == bt_unsigned_long_long)
tp = &stddoublecomplex;
else
tp = &stdfloatcomplex;
if (exp1)
cast(tp, exp1);
if (exp2)
cast(tp, exp2);
return tp;
}
else if (isim2 && !isim1 && tp1->type < bt_float_imaginary)
{
TYPE *tp ;
if (tp2->type == bt_long_double_imaginary || tp1->type == bt_long_double)
tp = &stdlongdoublecomplex;
else if (tp2->type == bt_double_imaginary || tp1->type == bt_double
|| tp1->type == bt_long_long || tp1->type == bt_unsigned_long_long)
tp = &stddoublecomplex;
else
tp = &stdfloatcomplex;
if (exp1)
cast(tp, exp1);
if (exp2)
cast(tp, exp2);
return tp;
}
else if (tp1->type > tp2->type)
{
if (exp2)
cast(tp1, exp2);
}
else if (tp1->type < tp2->type)
{
if (exp1)
cast(tp2, exp1);
}
if (tp1->type == bt_long_double_complex && isctp2)
return tp1;
if (tp2->type == bt_long_double_complex && isctp1)
return tp2;
if (tp1->type == bt_long_double_imaginary && isim2)
return tp1;
if (tp2->type == bt_long_double_imaginary && isim1)
return tp2;
if (tp1->type == bt_long_double && isctp2)
return tp1;
if (tp2->type == bt_long_double && isctp1)
return tp2;
if (tp1->type == bt_double_complex && isctp2)
return tp1;
if (tp2->type == bt_double_complex && isctp1)
return tp2;
if (tp1->type == bt_double_imaginary && isim2)
return tp1;
if (tp2->type == bt_double_imaginary && isim1)
return tp2;
if (tp1->type == bt_double && isctp2)
return tp1;
if (tp2->type == bt_double && isctp1)
return tp2;
if (tp1->type == bt_float_complex && isctp2)
return tp1;
if (tp2->type == bt_float_complex && isctp1)
return tp2;
if (tp1->type == bt_float_imaginary && isim2)
return tp1;
if (tp2->type == bt_float_imaginary && isim1)
return tp2;
if (tp1->type == bt_float && isctp2)
return tp1;
if (tp2->type == bt_float && isctp1)
return tp2;
}
if (isctp1 && isctp2) {
TYPE *rv ;
enum e_bt t1, t2;
t1 = tp1->type;
t2 = tp2->type;
/*
if (cparams.prm_cplusplus && (t1 == bt_enum || t2 == bt_enum))
{
if (t1 == t2)
{
if (tp1->sp->mainsym == tp2->sp->mainsym)
{
return tp1;
}
genmismatcherror(ERR_ENUMMISMATCH, tp1, tp2);
}
}
*/
if (t1 == bt_enum)
t1= bt_int;
if (t2 == bt_enum)
t2= bt_int;
if (t1 == bt_wchar_t)
t1 = bt_unsigned;
if (t2 == bt_wchar_t)
t2 = bt_unsigned;
if (t1 < bt_int)
t1= bt_int;
if (t2 < bt_int)
t2= bt_int;
t1 = imax(t1, t2);
rv = inttype(t1);
if (rv->type != tp1->type && exp1)
cast(rv, exp1);
if (rv->type != tp2->type && exp2)
cast(rv,exp2);
return rv;
} else { /* have a pointer or other exceptional case*/
if (tp1->type == bt_void && tp2->type == bt_void)
return tp1;
if (tp1->type <= bt_unsigned_long_long && ispointer(tp2))
{
if (!ispointer(tp1))
cast(tp2, exp1);
return tp2;
}
if (tp2->type <= bt_unsigned_long_long && ispointer(tp1))
{
if (!ispointer(tp2))
cast(tp1, exp2);
return tp1;
}
if (isstructured(tp1)) {
return tp2;
/*
if (comparetypes(tp1, tp2, FALSE))
return tp1;
if (cparams.prm_cplusplus) {
cppcast(tp2, tp1, exp1, FALSE, ERR_CPPMISMATCH);
} else
error(ERR_ILL_STRUCTURE_OPERATION);
return tp2;
*/
}
if (isstructured(tp2)) {
return tp1;
/*
if (comparetypes(tp1, tp2, FALSE))
return tp2;
if (cparams.prm_cplusplus) {
cppcast(tp1, tp2, exp1, FALSE, ERR_CPPMISMATCH);
} else
error(ERR_ILL_STRUCTURE_OPERATION);
return tp1;
*/
}
if (isfunction(tp1))
if (isfunction(tp2) || ispointer(tp2))
return tp1;
if (isfunction(tp2))
if (isfunction(tp1) || ispointer(tp1))
return tp2;
if (ispointer(tp1))
if (ispointer(tp2))
{
/* if (tp1->type != tp2->type || !comparetypes(tp1->btp, tp2->btp, TRUE))
generror(ERR_SUSPICIOUS, 0, 0);
*/
return tp1;
}
}
return tp1;
}
int compare(CTXTdeclc const void * v1, const void * v2)
{
int comp;
CPtr cptr1, cptr2;
Cell val1 = (Cell) v1 ;
Cell val2 = (Cell) v2 ;
XSB_Deref(val2); /* val2 is not in register! */
XSB_Deref(val1); /* val1 is not in register! */
if (val1 == val2) return 0;
switch(cell_tag(val1)) {
case XSB_FREE:
case XSB_REF1:
if (isattv(val2))
return vptr(val1) - (CPtr)dec_addr(val2);
else if (isnonvar(val2)) return -1;
else { /* in case there exist local stack variables in the */
/* comparison, globalize them to guarantee that their */
/* order is retained as long as nobody "touches" them */
/* in the future -- without copying garbage collection */
if ((top_of_localstk <= vptr(val1)) &&
(vptr(val1) <= (CPtr)glstack.high-1)) {
bld_free(hreg);
bind_ref(vptr(val1), hreg);
hreg++;
val1 = follow(val1); /* deref again */
}
if ((top_of_localstk <= vptr(val2)) &&
(vptr(val2) <= (CPtr)glstack.high-1)) {
bld_free(hreg);
bind_ref(vptr(val2), hreg);
hreg++;
val2 = follow(val2); /* deref again */
}
return vptr(val1) - vptr(val2);
}
case XSB_FLOAT:
if (isref(val2) || isattv(val2)) return 1;
else if (isofloat(val2))
return sign(float_val(val1) - ofloat_val(val2));
else return -1;
case XSB_INT:
if (isref(val2) || isofloat(val2) || isattv(val2)) return 1;
else if (isinteger(val2))
return int_val(val1) - int_val(val2);
else if (isboxedinteger(val2))
return int_val(val1) - boxedint_val(val2);
else return -1;
case XSB_STRING:
if (isref(val2) || isofloat(val2) || isinteger(val2) || isattv(val2))
return 1;
else if (isstring(val2)) {
return strcmp(string_val(val1), string_val(val2));
}
else return -1;
case XSB_STRUCT:
// below, first 2 if-checks test to see if this struct is actually a number representation,
// (boxed float or boxed int) and if so, does what the number case would do, only with boxed_val
// macros.
if (isboxedinteger(val1)) {
if (isref(val2) || isofloat(val2) || isattv(val2)) return 1;
else if (isinteger(val2))
return boxedint_val(val1) - int_val(val2);
else if (isboxedinteger(val2))
return boxedint_val(val1) - boxedint_val(val2);
else return -1;
} else if (isboxedfloat(val1)) {
if (isref(val2) || isattv(val2)) return 1;
else if (isofloat(val2))
return sign(boxedfloat_val(val1) - ofloat_val(val2));
else return -1;
} else if (cell_tag(val2) != XSB_STRUCT && cell_tag(val2) != XSB_LIST) return 1;
else {
int arity1, arity2;
Psc ptr1 = get_str_psc(val1);
Psc ptr2 = get_str_psc(val2);
arity1 = get_arity(ptr1);
if (islist(val2)) arity2 = 2;
else arity2 = get_arity(ptr2);
if (arity1 != arity2) return arity1-arity2;
if (islist(val2)) comp = strcmp(get_name(ptr1), ".");
else comp = strcmp(get_name(ptr1), get_name(ptr2));
if (comp || (arity1 == 0)) return comp;
cptr1 = clref_val(val1);
cptr2 = clref_val(val2);
for (arity2 = 1; arity2 <= arity1; arity2++) {
if (islist(val2))
comp = compare(CTXTc (void*)cell(cptr1+arity2), (void*)cell(cptr2+arity2-1));
else
comp = compare(CTXTc (void*)cell(cptr1+arity2), (void*)cell(cptr2+arity2));
if (comp) break;
}
return comp;
}
break;
case XSB_LIST:
if (cell_tag(val2) != XSB_STRUCT && cell_tag(val2) != XSB_LIST) return 1;
else if (isconstr(val2)) return -(compare(CTXTc (void*)val2, (void*)val1));
else { /* Here we are comparing two list structures. */
cptr1 = clref_val(val1);
cptr2 = clref_val(val2);
comp = compare(CTXTc (void*)cell(cptr1), (void*)cell(cptr2));
if (comp) return comp;
return compare(CTXTc (void*)cell(cptr1+1), (void*)cell(cptr2+1));
}
break;
case XSB_ATTV:
if (isattv(val2))
return (CPtr)dec_addr(val1) - (CPtr)dec_addr(val2);
else if (isref(val2))
return (CPtr)dec_addr(val1) - vptr(val2);
else
return -1;
default:
xsb_abort("Compare (unknown tag %ld); returning 0", cell_tag(val1));
return 0;
}
}
/*-----------------------------------------------------------------------------*/
void ODBCDataSources()
{
static SQLCHAR DSN[SQL_MAX_DSN_LENGTH+1];
static SQLCHAR Description[SQL_MAX_DSN_LENGTH+1];
RETCODE rc;
int seq;
SWORD dsn_size, descr_size;
Cell op2 = ptoc_tag(3);
Cell op3 = ptoc_tag(4);
if (!henv) {
/* allocate environment handler*/
rc = SQLAllocEnv(&henv);
if (rc != SQL_SUCCESS && rc != SQL_SUCCESS_WITH_INFO) {
xsb_error("Environment allocation failed");
ctop_int(5,1);
return;
}
LCursor = FCursor = NULL;
FCurNum = NULL;
nullStrAtom = makestring(string_find("NULL",1));
}
seq = ptoc_int(2);
if (seq == 1) {
rc = SQLDataSources(henv,SQL_FETCH_FIRST,DSN,
SQL_MAX_DSN_LENGTH,&dsn_size,
Description,SQL_MAX_DSN_LENGTH,
&descr_size);
if (rc == SQL_NO_DATA_FOUND) {
ctop_int(5,2);
return;
}
if (rc != SQL_SUCCESS && rc != SQL_SUCCESS_WITH_INFO) {
xsb_error("Environment allocation failed");
ctop_int(5,1);
return;
}
} else {
rc = SQLDataSources(henv,SQL_FETCH_NEXT,DSN,
SQL_MAX_DSN_LENGTH,&dsn_size,
Description,SQL_MAX_DSN_LENGTH,
&descr_size);
if (rc == SQL_NO_DATA_FOUND) {
ctop_int(5,2);
return;
}
if (rc != SQL_SUCCESS && rc != SQL_SUCCESS_WITH_INFO) {
xsb_error("Environment allocation failed");
ctop_int(5,1);
return;
}
}
XSB_Deref(op2);
if (isref(op2))
unify(op2, makestring(string_find(DSN,1)));
else {
xsb_error("[ODBCDataSources] Param 2 should be a free variable.");
ctop_int(5,1);
return;
}
XSB_Deref(op3);
if (isref(op3))
unify(op3, makestring(string_find(Description,1)));
else {
xsb_error("[ODBCDataSources] Param 3 should be a free variable.");
ctop_int(5,1);
return;
}
ctop_int(5,0);
return;
}
