/* PUBLIC */
void sprint_term(String_buf sb, Term t)
{
if (t == NULL)
printf("sprint_term: NULL term\n");
else {
if (VARIABLE(t)) {
char s[MAX_NAME];
sprintf(s, "v%d", VARNUM(t));
sb_append(sb, s);
}
else {
sprint_sym(sb, SYMNUM(t));
if (COMPLEX(t)) {
int i;
sb_append(sb, "(");
for (i = 0; i < ARITY(t); i++) {
sprint_term(sb, ARG(t,i));
if (i < ARITY(t)-1)
sb_append(sb, ",");
}
sb_append(sb, ")");
}
}
}
} /* sprint_term */
void cheney(VM *vm) {
int i;
int ar;
char* scan = vm->heap.heap;
while(scan < vm->heap.next) {
size_t inc = *((size_t*)scan);
VAL heap_item = (VAL)(scan+sizeof(size_t));
// If it's a CON or STROFFSET, copy its arguments
switch(GETTY(heap_item)) {
case CON:
ar = ARITY(heap_item);
for(i = 0; i < ar; ++i) {
// printf("Copying %d %p\n", heap_item->info.c.tag, *argptr);
VAL newptr = copy(vm, heap_item->info.c.args[i]);
// printf("Got %p\t\t%p %p\n", newptr, scan, vm->heap_next);
heap_item->info.c.args[i] = newptr;
}
break;
case STROFFSET:
heap_item->info.str_offset->str
= copy(vm, heap_item->info.str_offset->str);
break;
default: // Nothing to copy
break;
}
scan += inc;
}
assert(scan == vm->heap.next);
}
static
void flatten_deref(Term t, Context tc,
Term *a, Context *ac, int *ip)
{
Term t1;
Context c1;
int sn, i;
sn = SYMNUM(t);
for (i = 0; i < ARITY(t); i++) {
t1 = ARG(t,i);
c1 = tc;
DEREFERENCE(t1, c1);
if (SYMNUM(t1) == sn)
flatten_deref(t1, c1, a, ac, ip);
else {
if (*ip >= MAX_ACU_ARGS) {
p_term(t1);
fatal_error("flatten_deref, too many arguments.");
}
else {
a[*ip] = t1;
ac[*ip] = c1;
}
(*ip)++;
}
}
} /* flatten_deref(t) */
static
Term vars_to_names(Term t)
{
if (VARIABLE(t)) {
Term a;
char *s1 = malloc(25);
char *s2 = malloc(25);
Variable_style v = variable_style();
s2 = int_to_str(VARNUM(t), s2, 25);
switch (v) {
case INTEGER_STYLE: s1 = strcpy(s1, ""); break;
case STANDARD_STYLE: s1 = strcpy(s1, "var_"); break;
case PROLOG_STYLE: s1 = strcpy(s1, "VAR_"); break;
}
s1 = strcat(s1, s2);
a = get_rigid_term(s1, 0);
free_term(t);
free(s1);
free(s2);
return a;
}
else {
int i;
for (i = 0; i < ARITY(t); i++)
ARG(t,i) = vars_to_names(ARG(t,i));
return t;
}
} /* vars_to_names */
static
Term trm_set_vars_recurse(Term t, char **varnames, int max_vars)
{
if (CONSTANT(t)) {
char *name = sn_to_str(SYMNUM(t));
if (variable_name(name)) {
int i = 0;
while (i < max_vars && varnames[i] != NULL && varnames[i] != name)
i++;
if (i == max_vars)
fatal_error("trm_set_vars_recurse: max_vars");
else {
if (varnames[i] == NULL)
varnames[i] = name;
free_term(t);
t = get_variable_term(i);
}
}
}
else {
int i;
for (i = 0; i < ARITY(t); i++)
ARG(t,i) = trm_set_vars_recurse(ARG(t,i), varnames, max_vars);
}
return t;
} /* trm_set_vars_recurse */
void import(Module *state, array_t *params)
{
size_t length = 0;
CORD input = NULL;
Module *target = NULL;
char in_file[MAX_LIB_NAME];
ARITY(import, 2);
REQUIRES(import, 0, STR);
REQUIRES(import, 1, STR);
if(tst_search(state->imports, ARG(1)->data)) {
// already loaded so just skip it
return;
}
if(Token_copy(ARG(0), in_file, MAX_LIB_NAME, TK_STR) == -1) {
die(state, "requested module name %s is too long, must be less than %d.",
in_file, MAX_LIB_NAME);
}
input = mmap_file(in_file, &length);
assert(input && "Failed to open the file you requested.");
// compile the other file using the code size specified by the parent
target = Module_create(in_file, state->max_code_size);
// have to add it here to prevent recursive loads from going in a loop
state->imports = tst_insert(state->imports, ARG(1)->start, ARG(1)->len, target);
assert(state->imports && "Error importing into the parent namespace.");
if(!Module_compile(target, input, length)) {
die(target, "error parsing imported module %s.", in_file);
}
}
void library_call(Module *state, array_t *params)
{
ARITY(library_call, 2);
REQUIRES(library, 0, STR);
REQUIRES(library, 1, STR);
Token *ident = ARG(0);
Token *as = ARG(1);
Library *lib = Library_create(state, ident);
if(lib) {
// came out alright, so now set the name in our list as the second parameter
lib->len = Token_copy(as, lib->name, MAX_LIB_NAME, TK_STR);
if(lib->len == -1) {
die(state, "requested module name %.*s is too long, must be less than %d.",
as->len, as->start, MAX_LIB_NAME);
}
// store in the global library list
state->libraries = tst_insert(state->libraries, lib->name, lib->len, lib);
} else {
exit(1);
}
}
/* PUBLIC */
Plist free_vars_term(Term t, Plist vars)
{
if (VARIABLE(t))
fatal_error("free_vars_term, VARIABLE term");
if (ARITY(t) == 0) {
if (variable_name(sn_to_str(SYMNUM(t))) && !tlist_member(t, vars))
vars = plist_append(vars, copy_term(t));
}
else {
int i;
for (i = 0; i < ARITY(t); i++)
vars = free_vars_term(ARG(t,i), vars);
}
return vars;
} /* free_vars_term */
/* PUBLIC */
void zap_term(Term t)
{
int i;
for (i = 0; i < ARITY(t); i++)
zap_term(ARG(t,i));
free_term(t);
} /* zap_term */
static
void process_op(FILE *fout, Term t, int prec, Term type_term, Term symb_term)
{
if (ARITY(symb_term) != 0) {
fwrite_term_nl(fout, t);
fwrite_term_nl(stderr, t);
fatal_error("symbols in op command must have no arguments");
}
else {
Parsetype pt = NOTHING_SPECIAL;
if (is_constant(type_term, "infix"))
pt = INFIX;
else if (is_constant(type_term, "infix_left"))
pt = INFIX_LEFT;
else if (is_constant(type_term, "infix_right"))
pt = INFIX_RIGHT;
else if (is_constant(type_term, "prefix"))
pt = PREFIX;
else if (is_constant(type_term, "prefix_paren"))
pt = PREFIX_PAREN;
else if (is_constant(type_term, "postfix"))
pt = POSTFIX;
else if (is_constant(type_term, "postfix_paren"))
pt = POSTFIX_PAREN;
else if (is_constant(type_term, "clear"))
pt = NOTHING_SPECIAL;
else {
fwrite_term_nl(fout, t);
fwrite_term_nl(stderr, t);
fatal_error("bad parse-type in op command");
}
set_parse_type(sn_to_str(SYMNUM(symb_term)), prec, pt);
}
} /* process_op */
/* PUBLIC */
int symbol_count(Term t)
{
int i;
int count = 0;
for (i = 0; i < ARITY(t); i++)
count += symbol_count(ARG(t,i));
return count+1;
} /* symbol_count */
/* PUBLIC */
Plist plist_of_subterms(Term t)
{
Plist subterms = NULL;
int i;
for (i = 0; i < ARITY(t); i++)
subterms = plist_append(subterms, ARG(t,i));
return subterms;
} /* plist_of_subterms */
/* PUBLIC */
int arg_position(Term parent, Term child)
{
int i;
for (i = 0; i < ARITY(parent); i++) {
if (ARG(parent,i) == child)
return i;
}
return -1;
} /* arg_position */
/* PUBLIC */
void upward_term_links(Term t, void *p)
{
int i;
if (!VARIABLE(t)) {
t->container = p;
for (i = 0; i < ARITY(t); i++)
upward_term_links(ARG(t,i), p);
}
} /* upward_term_links */
/* PUBLIC */
I2list symbols_in_term(Term t, I2list g)
{
if (!VARIABLE(t)) {
int i;
g = multiset_add(g, SYMNUM(t));
for (i = 0; i < ARITY(t); i++)
g = symbols_in_term(ARG(t,i), g);
}
return g;
} /* symbols_in_term */
/* PUBLIC */
Term term_at_pos(Term t, Ilist pos)
{
if (pos == NULL)
return t;
else {
if (pos->i > ARITY(t))
return NULL;
else
return term_at_pos(ARG(t,pos->i - 1), pos->next);
}
} /* term_at_pos */
/* PUBLIC */
I2list multiset_of_vars(Term t, I2list vars)
{
if (VARIABLE(t))
return multiset_add(vars, VARNUM(t));
else {
int i;
for (i = 0; i < ARITY(t); i++)
vars = multiset_of_vars(ARG(t,i), vars);
return vars;
}
} /* multiset_of_vars */
/* PUBLIC */
unsigned hash_term(Term t)
{
if (VARIABLE(t))
return VARNUM(t);
else {
int i;
unsigned x = SYMNUM(t);
for (i = 0; i < ARITY(t); i++)
x = (x << 3) ^ hash_term(ARG(t,i));
return x;
}
} /* hash_term */
/* PUBLIC */
BOOL all_args_vars(Term t)
{
if (VARIABLE(t))
return TRUE;
else {
int i;
for (i = 0; i < ARITY(t); i++)
if (!VARIABLE(ARG(t,i)))
return FALSE;
return TRUE;
}
} /* all_args_vars */
/* PUBLIC */
BOOL occurs_in(Term t1, Term t2)
{
if (term_ident(t1, t2))
return TRUE;
else {
int i;
for (i = 0; i < ARITY(t2); i++)
if (occurs_in(t1, ARG(t2,i)))
return TRUE;
return FALSE;
}
} /* occurs_in */
/* PUBLIC */
BOOL ground_term(Term t)
{
if (VARIABLE(t))
return FALSE;
else {
int i;
for (i = 0; i < ARITY(t); i++)
if (!ground_term(ARG(t,i)))
return FALSE;
return TRUE;
}
} /* ground_term */
/* PUBLIC */
int symbol_occurrences(Term t, int symnum)
{
if (VARIABLE(t))
return 0;
else {
int n = (SYMNUM(t) == symnum ? 1 : 0);
int i;
for (i = 0; i < ARITY(t); i++)
n += symbol_occurrences(ARG(t,i), symnum);
return n;
}
} /* symbol_occurrences */
/* PUBLIC */
BOOL term_ident(Term t1, Term t2)
{
if (t1->private_symbol != t2->private_symbol)
return 0;
else {
int i;
for (i = 0; i < ARITY(t1); i++)
if (!term_ident(ARG(t1,i), ARG(t2,i)))
return 0;
return 1;
}
} /* term_ident */
/* PUBLIC */
int occurrences(Term t, Term target)
{
if (term_ident(t, target))
return 1;
else {
int n = 0;
int i;
for (i = 0; i < ARITY(t); i++)
n += occurrences(ARG(t,i), target);
return n;
}
} /* occurrences */
/* PUBLIC */
BOOL args_distinct_vars(Term t)
{
#if 1
if (VARIABLE(t))
return FALSE;
else {
int i;
for (i = 0; i < ARITY(t); i++) {
if (!VARIABLE(ARG(t,i)))
return FALSE;
else {
int j;
for (j = 0; j < i; j++)
if (VARNUM(ARG(t,i)) == VARNUM(ARG(t,j)))
return FALSE;
}
}
return TRUE;
}
#else
if (VARIABLE(t))
return FALSE;
else {
int *p = calloc(ARITY(t), sizeof(int));
int i;
BOOL ok = TRUE;
for (i = 0; i < ARITY(t) && ok; i++) {
Term s = ARG(t,i);
if (!VARIABLE(s))
ok = FALSE;
else if (p[VARNUM(s)])
ok = FALSE;
else
p[VARNUM(s)] = TRUE;
}
free(p);
return ok;
}
#endif
} /* args_distinct_vars */
static te_expr *new_expr(const int type, const te_expr *parameters[]) {
const int arity = ARITY(type);
const int psize = sizeof(void*) * arity;
const int size = sizeof(te_expr) + psize + (IS_CLOSURE(type) ? sizeof(void*) : 0);
te_expr *ret = malloc(size);
memset(ret, 0, size);
if (arity && parameters) {
memcpy(ret->parameters, parameters, psize);
}
ret->type = type;
ret->bound = 0;
return ret;
}
double te_eval(const te_expr *n) {
if (!n) return NAN;
switch(TYPE_MASK(n->type)) {
case TE_CONSTANT: return n->value;
case TE_VARIABLE: return *n->bound;
case TE_FUNCTION0: case TE_FUNCTION1: case TE_FUNCTION2: case TE_FUNCTION3:
case TE_FUNCTION4: case TE_FUNCTION5: case TE_FUNCTION6: case TE_FUNCTION7:
switch(ARITY(n->type)) {
case 0: return TE_FUN(void)();
case 1: return TE_FUN(double)(M(0));
case 2: return TE_FUN(double, double)(M(0), M(1));
case 3: return TE_FUN(double, double, double)(M(0), M(1), M(2));
case 4: return TE_FUN(double, double, double, double)(M(0), M(1), M(2), M(3));
case 5: return TE_FUN(double, double, double, double, double)(M(0), M(1), M(2), M(3), M(4));
case 6: return TE_FUN(double, double, double, double, double, double)(M(0), M(1), M(2), M(3), M(4), M(5));
case 7: return TE_FUN(double, double, double, double, double, double, double)(M(0), M(1), M(2), M(3), M(4), M(5), M(6));
default: return NAN;
}
case TE_CLOSURE0: case TE_CLOSURE1: case TE_CLOSURE2: case TE_CLOSURE3:
case TE_CLOSURE4: case TE_CLOSURE5: case TE_CLOSURE6: case TE_CLOSURE7:
switch(ARITY(n->type)) {
case 0: return TE_FUN(void*)(n->parameters[0]);
case 1: return TE_FUN(void*, double)(n->parameters[1], M(0));
case 2: return TE_FUN(void*, double, double)(n->parameters[2], M(0), M(1));
case 3: return TE_FUN(void*, double, double, double)(n->parameters[3], M(0), M(1), M(2));
case 4: return TE_FUN(void*, double, double, double, double)(n->parameters[4], M(0), M(1), M(2), M(3));
case 5: return TE_FUN(void*, double, double, double, double, double)(n->parameters[5], M(0), M(1), M(2), M(3), M(4));
case 6: return TE_FUN(void*, double, double, double, double, double, double)(n->parameters[6], M(0), M(1), M(2), M(3), M(4), M(5));
case 7: return TE_FUN(void*, double, double, double, double, double, double, double)(n->parameters[7], M(0), M(1), M(2), M(3), M(4), M(5), M(6));
default: return NAN;
}
default: return NAN;
}
}
/* PUBLIC */
Term subst_term(Term t, Term target, Term replacement)
{
if (term_ident(t, target)) {
zap_term(t);
return copy_term(replacement);
}
else {
int i;
for (i = 0; i < ARITY(t); i++)
ARG(t,i) = subst_term(ARG(t,i), target, replacement);
return t;
}
} /* subst_term */
/* PUBLIC */
BOOL check_upward_term_links(Term t, void *p)
{
int i;
if (!VARIABLE(t)) {
if (t->container != p)
return FALSE;
for (i = 0; i < ARITY(t); i++) {
if (!check_upward_term_links(ARG(t,i), p))
return FALSE;
}
}
return TRUE;
} /* check_upward_term_links */
/* PUBLIC */
int greatest_variable(Term t)
{
if (VARIABLE(t))
return VARNUM(t);
else {
int i, max, v;
for (max = -1, i = 0; i < ARITY(t); i++) {
v = greatest_variable(ARG(t,i));
max = (v > max ? v : max);
}
return max;
}
} /* greatest_variable */
