void validate_number(char *s, Lisp_Object a, Lisp_Object b, Lisp_Object c)
{
int32_t la, w, msd;
if (!is_numbers(a)) return;
la = (length_of_header(numhdr(a))-CELL-4)/4;
if (la < 0)
{ trace_printf("%s: number with no digits (%.8x)\n", s, numhdr(a));
if (is_number(b)) prin_to_trace(b), trace_printf("\n");
if (is_number(c)) prin_to_trace(c), trace_printf("\n");
my_exit(EXIT_FAILURE);
}
if (la == 0)
{ msd = bignum_digits(a)[0];
w = msd & fix_mask;
if (w == 0 || w == fix_mask)
{ trace_printf("%s: %.8x should be fixnum\n", s, msd);
if (is_number(b)) prin_to_trace(b), trace_printf("\n");
if (is_number(c)) prin_to_trace(c), trace_printf("\n");
my_exit(EXIT_FAILURE);
}
if (signed_overflow(msd))
{ trace_printf("%s: %.8x should be two-word\n", s, msd);
if (is_number(b)) prin_to_trace(b), trace_printf("\n");
if (is_number(c)) prin_to_trace(c), trace_printf("\n");
my_exit(EXIT_FAILURE);
}
return;
}
msd = bignum_digits(a)[la];
if (signed_overflow(msd))
{ trace_printf("%s: %.8x should be longer\n", s, msd);
if (is_number(b)) prin_to_trace(b), trace_printf("\n");
if (is_number(c)) prin_to_trace(c), trace_printf("\n");
my_exit(EXIT_FAILURE);
}
if (msd == 0 && ((msd = bignum_digits(a)[la-1]) & 0x40000000) == 0)
{ trace_printf("%s: 0: %.8x should be shorter\n", s, msd);
if (is_number(b)) prin_to_trace(b), trace_printf("\n");
if (is_number(c)) prin_to_trace(c), trace_printf("\n");
my_exit(EXIT_FAILURE);
}
if (msd == -1 && ((msd = bignum_digits(a)[la-1]) & 0x40000000) != 0)
{ trace_printf("%s: -1: %.8x should be shorter\n", s, msd);
if (is_number(b)) prin_to_trace(b), trace_printf("\n");
if (is_number(c)) prin_to_trace(c), trace_printf("\n");
my_exit(EXIT_FAILURE);
}
}
char *look_in_lisp_variable(char *o, int prefix)
{
Lisp_Object nil, var;
/*
* I will start by tagging a '$' (or whatever) on in front of the
* parameter name.
*/
o[0] = (char)prefix;
var = make_undefined_symbol(o);
nil = C_nil;
/*
* make_undefined_symbol() could fail either if we had utterly run out
* of memory or if somebody generated an interrupt (eg ^C) around now. Ugh.
*/
if (exception_pending())
{ flip_exception();
return NULL;
}
/*
* If the variable $name was undefined then I use an empty replacement
* text for it. Otherwise I need to look harder at its value.
*/
if (qvalue(var) == unset_var) return o;
else
{ Header h;
intptr_t len;
var = qvalue(var);
/*
* Mostly I expect that the value will be a string or symbol.
*/
#ifdef COMMON
if (complex_stringp(var))
{ var = simplify_string(var);
nil = C_nil;
if (exception_pending())
{ flip_exception();
return NULL;
}
}
#endif /* COMMON */
if (symbolp(var))
{ var = get_pname(var);
nil = C_nil;
if (exception_pending())
{ flip_exception();
return NULL;
}
h = vechdr(var);
}
else if (!is_vector(var) ||
type_of_header(h = vechdr(var)) != TYPE_STRING)
return NULL;
len = length_of_header(h) - CELL;
/*
* Copy the characters from the string or from the name of the variable
* into the file-name buffer. There could at present be a crash here
* if the expansion was very very long and overflowed my buffer. Tough
* luck for now - people doing that (maybe) get what they (maybe) deserve.
*/
memcpy(o, (char *)var + (CELL - TAG_VECTOR), (size_t)len);
o = o + len;
return o;
}
}
double float_of_number(Lisp_Object a)
/*
* Return a (double precision) floating point value for the given Lisp
* number, or 0.0 in case of trouble. This is often called in circumstances
* where I already know the type of its argument and so its type-dispatch
* is unnecessary - in doing so I am trading off performance against
* code repetition.
*/
{
if (is_fixnum(a)) return (double)int_of_fixnum(a);
#ifdef COMMON
else if (is_sfloat(a))
{ Float_union w;
w.i = a - TAG_SFLOAT;
return (double)w.f;
}
#endif
else if (is_bfloat(a))
{ int32_t h = type_of_header(flthdr(a));
switch (h)
{
#ifdef COMMON
case TYPE_SINGLE_FLOAT:
return (double)single_float_val(a);
#endif
case TYPE_DOUBLE_FLOAT:
return double_float_val(a);
#ifdef COMMON
case TYPE_LONG_FLOAT:
return (double)long_float_val(a);
#endif
default:
return 0.0;
}
}
else
{ Header h = numhdr(a);
int x1;
double r1;
switch (type_of_header(h))
{
case TYPE_BIGNUM:
r1 = bignum_to_float(a, length_of_header(h), &x1);
return ldexp(r1, x1);
#ifdef COMMON
case TYPE_RATNUM:
{ int x2;
Lisp_Object na = numerator(a);
a = denominator(a);
if (is_fixnum(na)) r1 = float_of_number(na), x1 = 0;
else r1 = bignum_to_float(na,
length_of_header(numhdr(na)), &x1);
if (is_fixnum(a)) r1 = r1 / float_of_number(a), x2 = 0;
else r1 = r1 / bignum_to_float(a,
length_of_header(numhdr(a)), &x2);
/* Floating point overflow can only arise in this ldexp() */
return ldexp(r1, x1 - x2);
}
#endif
default:
/*
* If the value was non-numeric or a complex number I hand back 0.0,
* and since I am supposed to have checked the object type already
* this OUGHT not to arrive - bit raising an exception seems over-keen.
*/
return 0.0;
}
}
}
