/* PUBLIC */
Fpa_chunk flist_insert(Fpa_chunk f, Term x)
{
if (f == NULL) {
f = get_fpa_chunk();
FLAST(f) = x;
f->n = 1;
}
else if (f->n == FMAX) {
if (FLT(x,FLAST(f)))
f->next = flist_insert(f->next, x);
else if (x == FLAST(f))
fprintf(stderr, "WARNING: flist_insert, item %p already here (1)!\n", x);
else if (FGT(x,FFIRST(f))) {
/*
This special case isn't necessary. It is to improve performance.
The application for which I'm writing this inserts items in
increasing order (most of the time), and this prevents a lot of
half-empty chunks in that case.
*/
Fpa_chunk f2 = flist_insert(NULL, x);
f2->next = f;
f = f2;
}
else {
/* split this chunk in half */
Fpa_chunk f2 = get_fpa_chunk();
int move = FMAX / 2;
int i, j;
for (i = 0, j = FMAX-move; i < move; i++, j++) {
f2->d[j] = f->d[i];
f->d[i] = NULL;
}
f2->n = move;
f->n = FMAX - move;
f2->next = f;
f = flist_insert(f2, x);
}
}
else {
if (f->next && FLE(x,FFIRST(f->next)))
f->next = flist_insert(f->next, x);
else {
/* insert into this pa_chunk */
int n = f->n;
int i = FMAX - n;
while (i < FMAX && FLT(x,f->d[i]))
i++;
if (i < FMAX && x == f->d[i])
fprintf(stderr, "WARNING: flist_insert, item %p already here (2)!\n", x);
else if (i == FMAX - n) {
f->d[i-1] = x;
f->n = n+1;
}
else {
/* insert at i-1, shifting the rest */
int j;
for (j = FMAX-n; j < i; j++)
f->d[j-1] = f->d[j];
f->d[i-1] = x;
f->n = n+1;
}
}
}
return f;
} /* flist_insert */
/*
* dooper() will execute a constant operation in a node and return
* the node to be the result of the operation.
*/
static EXPR *dooper P1 (EXPR *, ep)
{
EXPRTYPE type = ep->nodetype;
ep->nodetype = ep->v.p[0]->nodetype;
switch (ep->v.p[0]->nodetype) {
#ifdef FLOAT_SUPPORT
#ifndef FLOAT_BOOTSTRAP
RVAL f;
#endif /* FLOAT_BOOTSTRAP */
case en_fcon:
#ifndef FLOAT_BOOTSTRAP
FASSIGN (f, ep->v.p[0]->v.f);
switch (type) {
case en_uminus:
FASSIGN (ep->v.f, f);
FNEG (ep->v.f);
break;
case en_test:
ep->v.i = FTST (f) ? (IVAL) 1 : (IVAL) 0;
ep->nodetype = en_icon;
break;
case en_not:
ep->v.i = FTST (f) ? (IVAL) 0 : (IVAL) 1;
ep->nodetype = en_icon;
break;
case en_cast:
if (is_real_floating_type (ep->etp)) {
ep->v.f = f;
} else if (is_bool (ep->etp)) {
ep->v.u = (UVAL) (f ? 1 : 0);
ep->nodetype = en_icon;
} else {
FTOL (ep->v.i, f);
ep->v.i = strip_icon (ep->v.i, ep->etp);
ep->nodetype = en_icon;
}
break;
case en_add:
FADD3 (ep->v.f, f, ep->v.p[1]->v.f);
break;
case en_sub:
FSUB3 (ep->v.f, f, ep->v.p[1]->v.f);
break;
case en_mul:
FMUL3 (ep->v.f, f, ep->v.p[1]->v.f);
break;
case en_div:
if (FTST (ep->v.p[1]->v.f)) {
FDIV3 (ep->v.f, f, ep->v.p[1]->v.f);
} else {
ep->nodetype = en_div;
}
break;
case en_eq:
ep->v.i = (IVAL) FEQ (f, ep->v.p[1]->v.f);
ep->nodetype = en_icon;
break;
case en_ne:
ep->v.i = (IVAL) FNE (f, ep->v.p[1]->v.f);
ep->nodetype = en_icon;
break;
case en_land:
ep->v.i = (IVAL) (FTST (f) && FTST (ep->v.p[1]->v.f));
ep->nodetype = en_icon;
break;
case en_lor:
ep->v.i = (IVAL) (FTST (f) || FTST (ep->v.p[1]->v.f));
ep->nodetype = en_icon;
break;
case en_lt:
ep->v.i = (IVAL) FLT (f, ep->v.p[1]->v.f);
ep->nodetype = en_icon;
break;
case en_le:
ep->v.i = (IVAL) FLE (f, ep->v.p[1]->v.f);
ep->nodetype = en_icon;
break;
case en_gt:
ep->v.i = (IVAL) FGT (f, ep->v.p[1]->v.f);
ep->nodetype = en_icon;
break;
case en_ge:
ep->v.i = (IVAL) FGE (f, ep->v.p[1]->v.f);
ep->nodetype = en_icon;
break;
default:
CANNOT_REACH_HERE ();
break;
}
break;
#endif /* FLOAT_BOOTSTRAP */
#endif /* FLOAT_SUPPORT */
case en_icon:
if (is_unsigned_type (ep->v.p[0]->etp)) {
UVAL u = ep->v.p[0]->v.u;
switch (type) {
case en_uminus:
/*
* unary minus on an unsigned is normally a mistake so we must
* fool the compiler into not giving a warning.
*/
ep->v.u = (UVAL) (-(IVAL) u);
break;
case en_test:
ep->v.u = (u ? (UVAL) 1 : (UVAL) 0);
break;
case en_not:
ep->v.u = (u ? (UVAL) 0 : (UVAL) 1);
break;
case en_compl:
ep->v.u = (UVAL) strip_icon ((IVAL) ~u, ep->etp);
break;
case en_cast:
if (is_bool (ep->etp)) {
ep->v.u = (UVAL) (u ? 1 : 0);
#ifdef FLOAT_SUPPORT
} else if (is_real_floating_type (ep->etp)) {
ep->nodetype = en_fcon;
UTOF (ep->v.f, u);
break;
#endif /* FLOAT_SUPPORT */
} else {
ep->v.u = (UVAL) strip_icon ((IVAL) u, ep->etp);
}
break;
case en_add:
ep->v.u = u + ep->v.p[1]->v.u;
break;
case en_sub:
ep->v.u = u - ep->v.p[1]->v.u;
break;
case en_mul:
ep->v.u = u * ep->v.p[1]->v.u;
break;
case en_div:
if (ep->v.p[1]->v.u == (UVAL) 0) {
ep->nodetype = en_div;
} else {
ep->v.u = u / ep->v.p[1]->v.u;
}
break;
case en_mod:
if (ep->v.p[1]->v.u == (UVAL) 0) {
ep->nodetype = en_mod;
} else {
ep->v.u = u % ep->v.p[1]->v.u;
}
break;
case en_and:
ep->v.u = u & ep->v.p[1]->v.u;
break;
case en_or:
ep->v.u = u | ep->v.p[1]->v.u;
break;
case en_xor:
ep->v.u = u ^ ep->v.p[1]->v.u;
break;
case en_eq:
ep->v.u = (UVAL) (u == ep->v.p[1]->v.u);
break;
case en_ne:
ep->v.u = (UVAL) (u != ep->v.p[1]->v.u);
break;
case en_land:
ep->v.u = (UVAL) (u && ep->v.p[1]->v.u);
break;
case en_lor:
ep->v.u = (UVAL) (u || ep->v.p[1]->v.u);
break;
case en_lt:
ep->v.u = (UVAL) (u < ep->v.p[1]->v.u);
break;
case en_le:
ep->v.u = (UVAL) (u <= ep->v.p[1]->v.u);
break;
case en_gt:
ep->v.u = (UVAL) (u > ep->v.p[1]->v.u);
break;
case en_ge:
ep->v.u = (UVAL) (u >= ep->v.p[1]->v.u);
break;
case en_lsh:
ep->v.u = u << ep->v.p[1]->v.u;
break;
case en_rsh:
ep->v.u = u >> ep->v.p[1]->v.u;
break;
default:
CANNOT_REACH_HERE ();
break;
}
} else {
