bool subtype(node s, node t){
if (ispos(s)) s = s->body.position.contents;
if (ispos(t)) t = t->body.position.contents;
assert(istype(s) && istype(t));
s = typeforward(s);
t = typeforward(t);
if (s == t) return TRUE;
if (s == bad_or_undefined_T || t == bad_or_undefined_T) return TRUE;
if (isortype(s) && isortype(t)) {
int i, j, slen, tlen;
s = typedeftail(s); slen = length(s);
t = typedeftail(t); tlen = length(t);
for (i=1; i<=slen; i++) {
for (j=1; j<=tlen; j++) {
if (subtype(nth(s,i),nth(t,j))) goto okay;
}
return FALSE;
okay:;
}
return TRUE;
}
if (isortype(s)) return FALSE;
if (isortype(t)) {
int j, tlen;
t = typedeftail(t); tlen = length(t);
for (j=1; j<=tlen; j++) {
if (subtype(s,nth(t,j))) return TRUE;
}
return FALSE;
}
return FALSE; /* for other types, we assume that totypesRec has worked and made equivalent types identical */
}
double
sqrt (double x)
{
double f, y;
int exp, i, odd;
/* Check for special values. */
switch (numtest (x))
{
case NAN:
errno = EDOM;
return (x);
case INF:
if (ispos (x))
{
errno = EDOM;
return (z_notanum.d);
}
else
{
errno = ERANGE;
return (z_infinity.d);
}
}
/* Initial checks are performed here. */
if (x == 0.0)
return (0.0);
if (x < 0)
{
errno = EDOM;
return (z_notanum.d);
}
/* Find the exponent and mantissa for the form x = f * 2^exp. */
f = frexp (x, &exp);
odd = exp & 1;
/* Get the initial approximation. */
y = 0.41731 + 0.59016 * f;
f /= 2.0;
/* Calculate the remaining iterations. */
for (i = 0; i < 3; ++i)
y = y / 2.0 + f / y;
/* Calculate the final value. */
if (odd)
{
y *= __SQRT_HALF;
exp++;
}
exp >>= 1;
y = ldexp (y, exp);
return (y);
}
bool israwtypeexpr(node e) {
while (ispos(e)) e = e->body.position.contents;
while (issym(e)) {
if (e->body.symbol.type != type__T) return FALSE;
e = e->body.symbol.value;
}
if (!istype(e)) return FALSE;
return israwtype(e);
}
bool istaggedarraytypeexpr(node e){
while (ispos(e)) e = e->body.position.contents;
while (issym(e)) {
if (e->body.symbol.type != type__T) return FALSE;
e = e->body.symbol.value;
}
if (istype(e)) return istaggedarraytype(e);
if (!iscons(e)) return FALSE;
return equal(car(e),tarray_K);
}
node chktypelist(node e,scope v) {
node l = NULL, m;
if (ispos(e)) e = e->body.position.contents;
while (e != NULL) {
push(l,chktype(CAR(e),v));
e = CDR(e);
}
m = reverse(l);
return m;
}
double
exp (double x)
{
int N;
double g, z, R, P, Q;
switch (numtest (x))
{
case NAN:
errno = EDOM;
return (x);
case INF:
errno = ERANGE;
if (ispos (x))
return (z_infinity.d);
else
return (0.0);
case 0:
return (1.0);
}
/* Check for out of bounds. */
if (x > BIGX || x < SMALLX)
{
errno = ERANGE;
return (x);
}
/* Check for a value too small to calculate. */
if (-z_rooteps < x && x < z_rooteps)
{
return (1.0);
}
/* Calculate the exponent. */
if (x < 0.0)
N = (int) (x * INV_LN2 - 0.5);
else
N = (int) (x * INV_LN2 + 0.5);
/* Construct the mantissa. */
g = x - N * LN2;
z = g * g;
P = g * ((p[2] * z + p[1]) * z + p[0]);
Q = ((q[3] * z + q[2]) * z + q[1]) * z + q[0];
R = 0.5 + P / (Q - P);
/* Return the floating point value. */
N++;
return (ldexp (R, N));
}
struct POS *pos(node n) {
struct POS *p;
while (iscons(n)) {
if (n->body.cons.pos.filename != NULL) return &n->body.cons.pos;
p = pos(CAR(n));
if (p != NULL) return p;
n = CDR(n);
}
return (
ispos(n) ? &n->body.position.pos
: issym(n) && n->body.symbol.pos.filename != NULL ? &n->body.symbol.pos
: istype(n) && n->body.type.name != NULL ? pos(n->body.type.name)
: NULL );
}
node membertype(node structtype, node membername) {
node m;
membername = unpos(membername);
if (membername == len_S) return int_T;
if (membername == type__S) return int_T;
if (istype(structtype)) m = typedeftail(structtype);
else m = CDR(structtype);
if (ispos(membername)) membername = membername->body.position.contents;
while (m != NULL) {
if (equal(CAAR(m),membername)) {
node t = typeforward(CADAR(m));
return t;
}
m = CDR(m);
}
return NULL;
}
char *ft_itoa(int n)
{
char *nb;
int i;
char *rnb;
i = 0;
nb = (char *)malloc(sizeof(char) * 12);
rnb = (char *)malloc(sizeof(char) * 12);
if (n == -2147483648)
return (ft_strdup("-2147483648"));
if (n >= 0 && n < 10)
{
nb[0] = n + 48;
nb[1] = '\0';
free(rnb);
return (nb);
}
if (n > 9)
return (ispos(n, nb, rnb));
if (n < 0)
return (isneg(n, nb, rnb));
return (NULL);
}
node unpos(node e){
while (ispos(e)) e = e->body.position.contents;
return e;
}
node ExpandType(node t, node *f) {
/* t should be a type expression that might need expanding. Its expanded
form gets returned, and also put on the top of the list f
unless it's already a type or basic type */
switch(t->tag) {
case position_tag: return ExpandType(t->body.position.contents,f);
case type_tag: return t;
case symbol_tag: {
if (t->body.symbol.type == type__T) {
assert(istype(t->body.symbol.value));
return t->body.symbol.value;
}
if (t == bad__K) return bad_or_undefined_T;
assert(FALSE); return NULL;
}
case cons_tag: {
node fun = CAR(t);
if (ispos(fun)) fun = fun->body.position.contents;
t = CDR(t);
if (fun == or_K) {
/* here we should sort! */
/* we should also merge sub-or's in, and eliminate
duplicates */
/* we really only handle (or null (object)) now! */
node newN = NULL;
node mems = NULL;
while (t != NULL) {
node u = ExpandType(CAR(t),f);
push(mems,u);
t = CDR(t);
}
apply(reverse,mems);
newN = newtype(cons(fun,mems),NULL,FALSE);
push(*f,newN);
return newN;
}
else if (fun == object__K || fun == tagged_object_K /* ? */ ) {
node newN = NULL;
while (t != NULL) {
node name = CAAR(t);
node u = CADAR(t);
push(newN, list(2, unpos(name), ExpandType(u,f)));
t = CDR(t);
}
apply(reverse,newN);
newN = newtype(cons(fun,newN),NULL,FALSE);
push(*f,newN);
return newN;
}
else if (fun == array_K || fun == tarray_K) {
node newN;
newN = cons(fun,cons(ExpandType(car(t),f),cdr(t)));
newN = newtype(newN,NULL,FALSE);
*f = cons(newN,*f);
return newN;
}
else if (fun == function_S) {
node argtypes = car(t);
node rettype = cadr(t);
node newargtypes = NULL;
node newN;
while (argtypes != NULL) {
newargtypes = cons(
ExpandType(car(argtypes),f), newargtypes);
argtypes = cdr(argtypes);
}
newargtypes = reverse(newargtypes);
rettype = ExpandType(rettype,f);
newN = list(3,fun,newargtypes,rettype);
newN = newtype(newN,NULL,FALSE);
*f = cons(newN,*f);
return newN;
}
else assert(FALSE); return NULL;
}
default: assert(FALSE); return NULL;
}
}
node type(node e){ /* assume e is checked previously */
/* this returns a unique TYPE */
if (e == NULL) return void_T;
again:
switch(e->tag) {
case position_tag: e = e->body.position.contents; goto again;
case symbol_tag: return e->body.symbol.type;
case string_const_tag: /* not implemented yet */ return bad_or_undefined_T;
case char_const_tag: return char_T;
case int_const_tag: return int_T;
case double_const_tag: return double_T;
case string_tag: assert(FALSE);
case unique_string_tag: assert(FALSE); /* was return bad_or_undefined_T; */
case cons_tag: {
node h, ht;
h = unpos(CAR(e));
if (h->tag == unique_string_tag) {
if (h == equalequal__S || h == unequal_S) return bool_T;
if (h == cast__S) {
assert(istype(CADR(e)));
return cadr(e);
}
if (h == function_S) return type__T;
if (h == funcall__S || h == prefix__S || h == infix__S) {
return functionrettype(type(CADR(e)));
}
if (h == take__S) {
return membertype(type(CADR(e)),CADDR(e));
}
if (h == array_take_S) {
return arrayElementType(type(CADR(e)));
}
if (h == return_S) return returns_T;
if (h == exits_S) return exits_T;
if (h == Ccode_S) return cadr(e);
assert(FALSE);
}
ht = type(h);
if (ht == type__T) return totype(h);
if (ht == keyword_T) {
node w = ispos(h) ? h->body.position.contents : h;
if (w == block__K) return void_T;
if (w == blockn__K) {
if (length(e) < 2) return void_T;
return type(last(e));
}
if ( w == object__K || w == tagged_object_K || w == array_K || w == tarray_K || w == or_K) {
return type__T;
}
if (w == label__S) return void_T;
if (w == goto__S) return void_T;
assert(FALSE); /* there must be some other keywords! */
}
ht = ht->body.type.definition;
if (iscons(ht)) {
if (equal(CAR(ht),function_S)) {
assert(FALSE);
return caddr(ht);
}
else assert(FALSE); return NULL;
}
assert(FALSE); return NULL;
}
case type_tag: return type__T;
}
assert(FALSE);
return NULL;
}
