/*** if
* Conditional form. Accepts exactly three arguments. First feeds its input
* to the first argument. If the result is boolean True, it feeds the input to
* its second argument, if False then it feeds it to its third argument,
* otherwise it just returns Bottom.
*
* if{ f, g, h } : x = if f : x then g : x else h : x
*/
struct value *iff(struct list *args, struct value *in)
{
struct value *test = value_copy(in);
struct value *out = NULL;
// Checking for correct number of arguments
if(args->count != 3)
{
value_delete(test);
value_delete(in);
return value_new();
}
// Testing input with first argument
test = function_exec(list_get(args, 0), test);
if(test->type == BOOL_VAL)
{
if(test->data.bool_val)
{
value_delete(test);
return function_exec(list_get(args, 1), in);
}
else
{
value_delete(test);
return function_exec(list_get(args, 2), in);
}
}
else
{
value_delete(in);
return value_new();
}
}
/*** map
* Mapping functional form. Accepts a single function argument. Input to the
* form should always be in the form of a list, and the return value will be
* the result of applying the argument function to each element in the list.
*
* map{ f } : < x, y, z > = < f : x, f : y, f : z >
*/
struct value *map(struct list *args, struct value *in)
{
struct value *out = NULL;
struct function *f = list_get(args, 0);
struct list *l = NULL;
struct cursor *c;
// First ensure valid input
if(args->count != 1 || in->type != SEQ_VAL)
{
value_delete(in);
return value_new();
}
// Otherwise create an output list by applying f to each element of in
out = value_new();
out->type = SEQ_VAL;
out->data.seq_val = list_new();
l = in->data.seq_val;
for(c = cursor_new_front(l); cursor_valid(c); cursor_next(c))
list_push_back(out->data.seq_val,
function_exec(f, value_copy(cursor_get(c))));
value_delete(in);
cursor_delete(c);
return out;
}
static void value_delete (struct value *v)
{
if (v->parent) {
switch (v->parent->type) {
case NCDVALUE_LIST: {
value_list_remove(v->parent, v);
} break;
case NCDVALUE_MAP: {
value_map_remove(v->parent, v);
} break;
default: ASSERT(0);
}
}
LinkedList0Node *ln;
while (ln = LinkedList0_GetFirst(&v->refs_list)) {
struct instance *inst = UPPER_OBJECT(ln, struct instance, refs_list_node);
ASSERT(inst->v == v)
LinkedList0_Remove(&v->refs_list, &inst->refs_list_node);
inst->v = NULL;
}
switch (v->type) {
case NCDVALUE_STRING: {
free(v->string.string);
} break;
case NCDVALUE_LIST: {
while (value_list_len(v) > 0) {
struct value *ev = value_list_at(v, 0);
value_delete(ev);
}
} break;
case NCDVALUE_MAP: {
while (value_map_len(v) > 0) {
struct value *ev = value_map_at(v, 0);
value_delete(ev);
}
} break;
default: ASSERT(0);
}
free(v);
}
// Deletes every value in a list
void clear_value_list(struct list *args)
{
struct cursor *c = NULL;
for(c = cursor_new_front(args); cursor_valid(c); cursor_next(c))
if(cursor_get(c))
value_delete(cursor_get(c));
list_delete(args);
cursor_delete(c);
}
/*** reduce
* Reducing functional form. Accepts a single function argument. Expects
* input in the form of a list, return value is the result of first applying
* the argument function to a pair formed from the first two elements of the
* input list, then forming a new pair from that result and the next
* right-most element, and so on until the list is exhausted.
*
* reduce{ f } : < x, y, z > = f : < f : < x, y>, z >
*/
struct value *reduce(struct list *args, struct value *in)
{
struct value *out = value_new();
struct value *v = NULL;
struct function *f = list_get(args, 0);
int i = 0;
// Check for valid input
if (args->count != 1 || in->type != SEQ_VAL || in->data.seq_val->count < 2)
{
value_delete(in);
return out;
}
// Setting up initial pair
out->type = SEQ_VAL;
out->data.seq_val = list_new();
list_push_back(out->data.seq_val,
value_copy(list_get(in->data.seq_val, 0)));
list_push_back(out->data.seq_val,
value_copy(list_get(in->data.seq_val, 1)));
// Pairing up elements and feeding them to f
for (i = 2; i <= in->data.seq_val->count; i++)
{
out = function_exec(f, out);
if (i < in->data.seq_val->count)
{
v = value_new();
v->type = SEQ_VAL;
v->data.seq_val = list_new();
list_push_back(v->data.seq_val, out);
list_push_back(v->data.seq_val,
value_copy(list_get(in->data.seq_val, i)));
out = v;
}
}
value_delete(in);
return out;
}
/*** construct
* Sequence construction. Feeds its input to each of its argument functions,
* and generate a sequence where each element is the output of one of the
* argument functions.
*
* construct{ f, g } : x = < f : x, g : x >
*/
struct value *construct(struct list *args, struct value *in)
{
struct value *out = value_new();
struct cursor *c = NULL;
out->type = SEQ_VAL;
out->data.seq_val = list_new();
for(c = cursor_new_front(args); cursor_valid(c); cursor_next(c))
{
list_push_back(out->data.seq_val,
function_exec(cursor_get(c), value_copy(in)));
}
value_delete(in);
cursor_delete(c);
return out;
}
// Parses a constant
struct value *parse_constant(struct lexer_state *lexer)
{
struct value *arg = value_new();
// First grab the next token
lex(lexer);
if(lexer->error == END_OF_INPUT)
{
print_error(lexer, UNEXPECTED_END);
value_delete(arg);
return NULL;
}
if(lexer->error == UNRECOGNIZED_TOKEN)
{
print_error(lexer, LEX_ERROR);
value_delete(arg);
return NULL;
}
switch(lexer->type)
{
case BOTTOM:
arg->type = BOTTOM_VAL;
break;
case INT:
arg->type = INT_VAL;
arg->data.int_val = lexer->value.ival;
break;
case FLOAT:
arg->type = FLOAT_VAL;
arg->data.float_val = lexer->value.fval;
break;
case TRUE:
arg->type = BOOL_VAL;
arg->data.bool_val = 1;
break;
case FALSE:
arg->type = BOOL_VAL;
arg->data.bool_val = 0;
break;
case CHAR:
arg->type = CHAR_VAL;
arg->data.char_val = lexer->value.cval;
break;
case STRING:
arg->type = STRING_VAL;
arg->data.str_val = strdup(lexer->value.sval);
break;
case OPEN_SEQ:
arg->type = SEQ_VAL;
arg->data.seq_val = parse_constant_args(lexer, CLOSE_SEQ);
if(!arg->data.seq_val)
{
value_delete(arg);
return NULL;
}
break;
default:
print_error(lexer, EXPECTED_CONST);
value_delete(arg);
return NULL;
}
return arg;
}
/* Invoke the argument FTL function with <addr> <buf> arguments for each of
the ELF file's program segments */
static const value_t *
elf_load_with_fn(const value_t *this_fn, parser_state_t *state,
const char *filename, int binfd,
Elf *e, GElf_Ehdr *ehdr, void *arg)
{
elf_loadfn_args_t *fnarg = (elf_loadfn_args_t *)arg;
const value_t *hdrcheckfn = fnarg->hdrcheckfn;
const value_t *memwrfn = fnarg->memwrfn;
const value_t *resval = value_false;
size_t n;
if (elf_getphdrnum(e, &n) != 0)
parser_report(state, "ELF file has unknown number of segments - %s\n",
elf_errmsg(-1));
else {
size_t i;
bool ok = FALSE;
if (hdrcheckfn != NULL) {
const value_t *ehdrval = elf_get_ehdr(this_fn, state, filename, binfd,
e, ehdr, /*arg*/NULL);
if (ehdrval != NULL) {
const value_t *code = value_closure_bind(hdrcheckfn, ehdrval);
if (code == NULL) {
parser_error(state, "couldn't apply "
"header argument to check function\n");
} else {
const value_t *fnres = invoke(code, state);
/* we expect this to return a TRUE/FALSE value */
ok = (fnres == value_true);
/*if (!ok) printf("%s: check fn returns non-TRUE\n", codeid());*/
}
}
} else
ok = TRUE;
resval = ok? value_true: value_false;
if (ok && memwrfn != NULL) {
for (i = 0; ok && i < n; i++) {
GElf_Phdr phdr;
if (gelf_getphdr(e, i, &phdr) != &phdr)
parser_report(state, "ELF segment %d unretrievable - %s\n",
i, elf_errmsg(-1));
else {
long offset = (long)phdr.p_offset;
if (phdr.p_offset != (Elf64_Off)offset)
parser_report(state, "ELF segment %d - "
"offset does not fit in 32-bits\n", i);
else
if (-1 == fe_lseek(binfd, offset))
parser_report(state, "ELF segment %d - "
"offset 0X%lX is outside file\n",
i, offset);
else
if (phdr.p_memsz < phdr.p_filesz)
parser_report(state,
"ELF segment %d - smaller size in memory (%d)"
"than on file (%d) - corrupt header?\n",
i, phdr.p_memsz, phdr.p_filesz);
else {
number_t addr = phdr.p_vaddr; /* where to load segment */
char *buf = NULL;
size_t buflen = (size_t)phdr.p_memsz;
value_t *addrval = value_int_new(addr);
value_t *dataval = value_string_alloc_new(buflen, &buf);
if (phdr.p_memsz != (Elf64_Xword)buflen)
parser_report(state, "ELF segment %d - "
"size does not fit in 32-bits\n", i);
else
if (dataval == NULL)
parser_report(state,
"ELF segment %d - no memory for "
"next %d bytes\n",
i, buflen);
else {
ssize_t readbytes = fe_read(binfd, buf, buflen);
if (readbytes < buflen)
parser_report(state,
"ELF segment %d - "
"only %d bytes of %d read\n",
i, readbytes);
else {
const value_t *code;
ok = TRUE;
/* zero any uninitialized area */
if (phdr.p_memsz > phdr.p_filesz) {
size_t extra_bytes = (size_t)
(phdr.p_memsz - phdr.p_filesz);
if ((Elf64_Xword)extra_bytes !=
phdr.p_memsz-phdr.p_filesz) {
ok = FALSE;
parser_report(state, "ELF segment %d - "
"BSS area larger than 32-bits\n",
i);
} else
memset(&buf[phdr.p_filesz], '\0', extra_bytes);
}
code = value_closure_bind_2(state, memwrfn,
"address", addrval,
"data", dataval);
if (NULL != code) {
const value_t *fnres = invoke(code, state);
/* we expect this to return a TRUE/FALSE value */
if (fnres != value_true) {
/*printf("%s: seg fn returns non-TRUE\n",
codeid());*/
ok = FALSE;
}
/* we rely on garbage collection to collect the data
* buffer */
} else
value_delete(&dataval);
}
}
}
}
}
if (!ok)
resval = value_false;
}
}
return resval;
}
