/* 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 {