static HRESULT sort_cmp(script_ctx_t *ctx, jsdisp_t *cmp_func, VARIANT *v1, VARIANT *v2, jsexcept_t *ei, INT *cmp)
{
HRESULT hres;
if(cmp_func) {
VARIANTARG args[2];
DISPPARAMS dp = {args, NULL, 2, 0};
double n;
VARIANT res;
args[0] = *v2;
args[1] = *v1;
hres = jsdisp_call_value(cmp_func, DISPATCH_METHOD, &dp, &res, ei);
if(FAILED(hres))
return hres;
hres = to_number(ctx, &res, ei, &n);
VariantClear(&res);
if(FAILED(hres))
return hres;
if(n == 0)
*cmp = 0;
*cmp = n > 0.0 ? 1 : -1;
}else if(V_VT(v1) == VT_EMPTY) {
*cmp = V_VT(v2) == VT_EMPTY ? 0 : 1;
}else if(V_VT(v2) == VT_EMPTY) {
*cmp = -1;
}else if(is_num_vt(V_VT(v1)) && is_num_vt(V_VT(v2))) {
DOUBLE d = num_val(v1)-num_val(v2);
if(d > 0.0)
*cmp = 1;
else
*cmp = d < -0.0 ? -1 : 0;
}else {
BSTR x, y;
hres = to_string(ctx, v1, ei, &x);
if(FAILED(hres))
return hres;
hres = to_string(ctx, v2, ei, &y);
if(SUCCEEDED(hres)) {
*cmp = strcmpW(x, y);
SysFreeString(y);
}
SysFreeString(x);
if(FAILED(hres))
return hres;
}
return S_OK;
}
int alm_print_term(ATERM t) {
int count = 0;
if (is_num(t))
count += printf("%.1lf", num_val(t));
else if (is_nil(t))
count += printf("[]");
else if (is_cons(t)) {
count += printf("[");
ATERM tmp = t;
while (is_cons(tmp)) {
count += alm_print_term(CAR(tmp));
if (is_cons(CDR(tmp))) {
count += printf(",");
} else if (!is_nil(CDR(tmp))) {
count += printf("|");
count += alm_print_term(CDR(tmp));
}
tmp = CDR(tmp);
}
count += printf("]");
} else if (is_boxed(t)) {
ATERM *box = boxed_ptr(t);
if (is_atom(*box))
count += printf("%.*s", (int) box[1].bin, (char*) (box + 2));
} else if (is_frame(t)) {
count += printf("<frame/0x%.3llX>",frame_val(t));
}
return count;
}
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;
}
BUILTIN("socket-recv") socket_recv(Context &c, Value sock, Value max_len_) {
VERIFY_ARG_SOCKET(sock, 1);
VERIFY_ARG_NUM(max_len_, 2);
String *str = string_alloc(num_val(max_len_));
int res = recv(fd_of(sock), str->data, str->len, 0);
if (res < 0)
return c.error("recv() error");
if (res == 0) {
free(str);
return c.str_empty();
}
string_realloc(&str, res);
return c.str(str);
}
uint64_t alm_dump_heap_item(ATERM t, int stack) {
if (is_num(t))
printf("%18.1lf ", num_val(t));
else if (is_nil(t))
printf(" [] ");
else if (is_cons(t)) {
printf("<cons/0x%.3llX> ", (uint64_t)cons_ptr(t));
} else if (is_boxed(t)) {
ATERM *box = boxed_ptr(t);
if (is_atom(*box))
printf("<atom/0x%.3llX> ", (uint64_t)box);
} else if (is_header(t)) {
if (stack)
printf("<fram/0x%.3llX> ",(uint64_t)frame_val(t));
else if (is_atom(t)) {
printf("<atom/0x%.3llX> ",boxed_arity(t));
return boxed_arity(t)+1;
} else
printf("<frwd/0x%.3llX> ",(uint64_t)frame_val(t));
}
return 1;
}
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;
}
// Strict binary operators.
static value_t *e_binary_op(env_t *env, expr_t *expr)
{
value_t *result;
value_t *l;
value_t *r;
l = e_expr(env, binary_left(expr));
r = e_expr(env, binary_right(expr));
result = alloc_value(v_unused);
switch (expr->type) {
case p_add:
result->type = v_num;
num_val(result) = num_val(l) + num_val(r);
break;
case p_div:
result->type = v_num;
num_val(result) = num_val(l) / num_val(r);
break;
case p_ge:
result->type = v_bool;
bool_val(result) = num_val(l) >= num_val(r);
break;
case p_gt:
result->type = v_bool;
bool_val(result) = num_val(l) > num_val(r);
break;
case p_le:
result->type = v_bool;
bool_val(result) = num_val(l) <= num_val(r);
break;
case p_lt:
result->type = v_bool;
bool_val(result) = num_val(l) < num_val(r);
break;
case p_mod:
result->type = v_num;
num_val(result) = (long)num_val(l) % (long)num_val(r);
break;
case p_mul:
result->type = v_num;
num_val(result) = num_val(l) * num_val(r);
break;
case p_sub:
result->type = v_num;
num_val(result) = num_val(l) - num_val(r);
break;
default:
error("Not a strict binary operator.");
return NULL; // gcc dataflow
}
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;
}
