/* 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 */