static int equality_test(value_t *l, value_t *r)
{
int result;
switch (l->type) {
default:
case v_unused:
if (*(int *)NULL) {
printf("should crash.\n");
}
break;
case v_bool:
result = bool_val(l) == bool_val(r);
break;
case v_char:
result = char_val(l) == char_val(r);
break;
case v_datacons:
if (strcmp(datacons_tag(l), datacons_tag(r)) == 0) {
result = 1;
list_zip_with(datacons_params(l),
datacons_params(r),
equality_test_i, &result);
} else {
result = 0;
}
break;
case v_num:
result = num_val(l) == num_val(r);
break;
case v_tuple:
result = 1;
list_zip_with(tuple_val(l),
tuple_val(r),
equality_test_i, &result);
break;
}
return result;
}
/*****************************************
* hex string to binary data
* output must be pre allocated
*****************************************/
int gw_hex2bin(uint8_t *out, const char *in, unsigned int len) {
const char *in_end= in + len;
if (len == 0 || in == NULL) {
return 1;
}
while (in < in_end) {
register unsigned char b1 = char_val(*in);
uint8_t b2 = 0;
in++;
b2 = (b1 << 4) | char_val(*in);
*out++ = b2;
in++;
}
return 0;
}
void get_salt_from_password_323(ulong *res, const char *password)
{
res[0]= res[1]= 0;
if (password)
{
while (*password)
{
ulong val=0;
uint i;
for (i=0 ; i < 8 ; i++)
val=(val << 4)+char_val(*password++);
*res++=val;
}
}
}
char *str2int(register const char *src, register int radix, long int lower,
long int upper, long int *val)
{
int sign; /* is number negative (+1) or positive (-1) */
int n; /* number of digits yet to be converted */
long limit; /* "largest" possible valid input */
long scale; /* the amount to multiply next digit by */
long sofar; /* the running value */
register int d; /* (negative of) next digit */
char *start;
int digits[32]; /* Room for numbers */
/* Make sure *val is sensible in case of error */
*val = 0;
/* Check that the radix is in the range 2..36 */
#ifndef DBUG_OFF
if (radix < 2 || radix > 36) {
errno=EDOM;
return NullS;
}
#endif
/* The basic problem is: how do we handle the conversion of
a number without resorting to machine-specific code to
check for overflow? Obviously, we have to ensure that
no calculation can overflow. We are guaranteed that the
"lower" and "upper" arguments are valid machine integers.
On sign-and-magnitude, twos-complement, and ones-complement
machines all, if +|n| is representable, so is -|n|, but on
twos complement machines the converse is not true. So the
"maximum" representable number has a negative representative.
Limit is set to min(-|lower|,-|upper|); this is the "largest"
number we are concerned with. */
/* Calculate Limit using Scale as a scratch variable */
if ((limit = lower) > 0) limit = -limit;
if ((scale = upper) > 0) scale = -scale;
if (scale < limit) limit = scale;
/* Skip leading spaces and check for a sign.
Note: because on a 2s complement machine MinLong is a valid
integer but |MinLong| is not, we have to keep the current
converted value (and the scale!) as *negative* numbers,
so the sign is the opposite of what you might expect.
*/
while (my_isspace(&my_charset_latin1,*src)) src++;
sign = -1;
if (*src == '+') src++; else
if (*src == '-') src++, sign = 1;
/* Skip leading zeros so that we never compute a power of radix
in scale that we won't have a need for. Otherwise sticking
enough 0s in front of a number could cause the multiplication
to overflow when it neededn't.
*/
start=(char*) src;
while (*src == '0') src++;
/* Move over the remaining digits. We have to convert from left
to left in order to avoid overflow. Answer is after last digit.
*/
for (n = 0; (digits[n]=char_val(*src)) < radix && n < 20; n++,src++) ;
/* Check that there is at least one digit */
if (start == src) {
errno=EDOM;
return NullS;
}
/* The invariant we want to maintain is that src is just
to the right of n digits, we've converted k digits to
sofar, scale = -radix**k, and scale < sofar < 0. Now
if the final number is to be within the original
Limit, we must have (to the left)*scale+sofar >= Limit,
or (to the left)*scale >= Limit-sofar, i.e. the digits
to the left of src must form an integer <= (Limit-sofar)/(scale).
In particular, this is true of the next digit. In our
incremental calculation of Limit,
IT IS VITAL that (-|N|)/(-|D|) = |N|/|D|
*/
for (sofar = 0, scale = -1; --n >= 1;)
{
if ((long) -(d=digits[n]) < limit) {
errno=ERANGE;
return NullS;
}
limit = (limit+d)/radix, sofar += d*scale; scale *= radix;
}
if (n == 0)
{
if ((long) -(d=digits[n]) < limit) /* get last digit */
{
errno=ERANGE;
return NullS;
}
sofar+=d*scale;
}
/* Now it might still happen that sofar = -32768 or its equivalent,
so we can't just multiply by the sign and check that the result
is in the range lower..upper. All of this caution is a right
pain in the neck. If only there were a standard routine which
says generate thus and such a signal on integer overflow...
But not enough machines can do it *SIGH*.
*/
if (sign < 0)
{
if (sofar < -LONG_MAX || (sofar= -sofar) > upper)
{
errno=ERANGE;
return NullS;
}
}
else if (sofar < lower)
{
errno=ERANGE;
return NullS;
}
*val = sofar;
errno=0; /* indicate that all went well */
return (char*) src;
}
static value_t *e_expr(env_t *env, expr_t *expr)
{
value_t *result;
switch (expr->type) {
default: // This is to handle invalid tags.
case p_unused:
if (*(int *)NULL) {
printf("should crash.\n");
}
return NULL;
case p_and:
{
value_t *l = e_expr(env, binary_left(expr));
if (bool_val(l)) {
result = e_expr(env, binary_right(expr));
} else {
result = l;
}
}
break;
case p_or:
{
value_t *l = e_expr(env, binary_left(expr));
if (bool_val(l)) {
result = l;
} else {
result = e_expr(env, binary_right(expr));
}
}
break;
case p_add:
case p_div:
case p_ge:
case p_gt:
case p_le:
case p_lt:
case p_mod:
case p_mul:
case p_sub:
result = e_binary_op(env, expr);
break;
case p_bconst:
result = alloc_value(v_bool);
bool_val(result) = bool_val(expr);
break;
case p_cconst:
result = alloc_value(v_char);
char_val(result) = char_val(expr);
break;
case p_datacons:
result = e_datacons(env, expr);
break;
case p_eqop:
result = e_equals(env, binary_left(expr), binary_right(expr));
break;
case p_fncall:
result = e_fncall(env, fncall_fn(expr), fncall_args(expr));
break;
case p_nconst:
result = alloc_value(v_num);
num_val(result) = num_val(expr);
break;
case p_ite:
result = e_ite(env, expr);
break;
case p_let:
result = e_let(env, expr);
break;
case p_listcons:
result = e_listcons(env, expr);
break;
case p_listlit:
result = e_listlit(env, expr);
break;
case p_listempty:
result = e_listempty();
break;
case p_match:
result = e_match(env, expr);
break;
case p_ne:
result = e_equals(env, binary_left(expr), binary_right(expr));
bool_val(result) = !bool_val(result);
break;
case p_negate:
result = e_expr(env, unary_expr(expr));
bool_val(result) = !bool_val(result);
break;
case p_tuple:
result = e_tuple(env, expr);
break;
case p_var:
result = env_lookup(env, var_name(expr));
if (result == NULL) {
error("e_expr: variable '%s' not in scope on line %d.\n", var_name(expr), expr->line_num);
}
result = thunk_force(result);
break;
}
return result;
}
// Mapped over the clauses in a "match" expression.
static int e_match_pat_i(void *data, void *info)
{
pm_closure_t *pmc = (pm_closure_t *)info;
clause_t *c = (clause_t *)data;
// The style of pattern matching depends on the type of the pattern:
// - constants match literally
// - variables match anything (and extend the environment)
// - tuples always match (and extend the environment)
// - data constructors are more complex.
///
switch (c->pattern->type) {
// Constants: match literally, no binding.
case p_bconst:
if (bool_val(c->pattern) == bool_val(pmc->val)) {
pmc->match_body = c->body;
}
break;
case p_cconst:
if (char_val(c->pattern) == char_val(pmc->val)) {
pmc->match_body = c->body;
}
break;
case p_nconst:
if (num_val(c->pattern) == num_val(pmc->val)) {
pmc->match_body = c->body;
}
break;
case p_listempty:
if (pmc->val->type == v_datacons && strcmp(datacons_tag(pmc->val), listEmptyTag) == 0) {
pmc->match_body = c->body;
}
break;
case p_var:
// Matches anything. Bind it.
env_add_binding(pmc->env, var_name(c->pattern), pmc->val);
pmc->match_body = c->body;
break;
case p_listcons:
// Check the list contains at least one element, then bind variables.
if (pmc->val->type == v_datacons && strcmp(datacons_tag(pmc->val), listConsTag) == 0) {
value_t *head;
value_t *tail;
head = list_nth(datacons_params(pmc->val), 0);
tail = list_nth(datacons_params(pmc->val), 1);
env_add_binding(pmc->env, listcons_hvar(c->pattern), head);
env_add_binding(pmc->env, listcons_tvar(c->pattern), tail);
pmc->match_body = c->body;
}
break;
case p_datacons:
// Check the tag matches, then bind the arguments (if any).
if (strcmp(datacons_tag(c->pattern), datacons_tag(pmc->val)) == 0) {
list_zip_with(datacons_params(c->pattern),
datacons_params(pmc->val),
e_bind_params_i, pmc->env);
pmc->match_body = c->body;
}
break;
case p_tuple:
// Always matches (assuming the program type checks). Bind the variables.
list_zip_with(tuple_val(c->pattern),
tuple_val(pmc->val),
e_bind_params_i, pmc->env);
pmc->match_body = c->body;
break;
default:
error("INTERNAL pattern match: invalid pattern.\n");
}
return pmc->match_body == NULL;
}
int val(char a, char b, char c) {
return char_val(a) * 4 + char_val(b) * 2 + char_val(c);
}
