void secd_print_env(secd_t *secd) {
cell_t *env = secd->env;
int i = 0;
secd_printf(secd, ";;Environment:\n");
while (not_nil(env)) {
secd_printf(secd, ";; Frame #%d:\n", i++);
cell_t *frame = get_car(env);
cell_t *symlist = get_car(frame);
cell_t *vallist = get_cdr(frame);
while (not_nil(symlist)) {
if (is_symbol(symlist)) {
secd_printf(secd, ";; . %s\t=>\t", symname(symlist));
dbg_print_cell(secd, vallist);
break;
}
cell_t *sym = get_car(symlist);
cell_t *val = get_car(vallist);
if (!is_symbol(sym)) {
errorf("print_env: not a symbol at *%p in symlist\n", sym);
dbg_printc(secd, sym);
}
secd_printf(secd, ";; %s\t=>\t", symname(sym));
dbg_print_cell(secd, val);
symlist = list_next(secd, symlist);
vallist = list_next(secd, vallist);
}
env = list_next(secd, env);
}
}
/* bind a parallel list of symbols and arguments */
void bind_argument_list(interp_core_type *interp, object_type *sym_list,
object_type *value_list) {
/* we have a list of symbols */
while(!is_empty_list(interp, sym_list) && !is_empty_list(interp, value_list)
&& !is_symbol(interp, sym_list)) {
bind_symbol(interp, car(sym_list), car(value_list), &interp->cur_env);
sym_list=cdr(sym_list);
value_list=cdr(value_list);
}
/* handle single, variadic argument lists */
if(is_symbol(interp, sym_list)) {
bind_symbol(interp, sym_list, value_list, &interp->cur_env);
return;
}
/* make sure that we have the same number of arguments
as we have symbols */
if(!is_empty_list(interp, sym_list) &&
!is_empty_list(interp, value_list)) {
interp->error=1;
}
}
cell_t *lookup_env(secd_t *secd, const char *symbol, cell_t **symc) {
cell_t *env = secd->env;
assert(cell_type(env) == CELL_CONS,
"lookup_env: environment is not a list");
cell_t *res = lookup_fake_variables(secd, symbol);
if (not_nil(res))
return res;
hash_t symh = secd_strhash(symbol);
while (not_nil(env)) { // walk through frames
cell_t *frame = get_car(env);
if (is_nil(frame)) {
/* skip omega-frame */
env = list_next(secd, env);
continue;
}
cell_t *symlist = get_car(frame);
cell_t *vallist = get_cdr(frame);
while (not_nil(symlist)) { // walk through symbols
if (is_symbol(symlist)) {
if (symh == symhash(symlist) && str_eq(symbol, symname(symlist))) {
if (symc != NULL) *symc = symlist;
return vallist;
}
break;
}
cell_t *curc = get_car(symlist);
assert(is_symbol(curc),
"lookup_env: variable at [%ld] is not a symbol\n",
cell_index(secd, curc));
if (symh == symhash(curc) && str_eq(symbol, symname(curc))) {
if (symc != NULL) *symc = curc;
return get_car(vallist);
}
symlist = list_next(secd, symlist);
vallist = list_next(secd, vallist);
}
env = list_next(secd, env);
}
//errorf(";; error in lookup_env(): %s not found\n", symbol);
return new_error(secd, SECD_NIL, "Lookup failed for: '%s'", symbol);
}
void simple_format
( MPL *mpl,
SET *set, /* not changed */
MEMBER *memb, /* modified */
SLICE *slice /* not changed */
)
{ TUPLE *tuple;
SLICE *temp;
SYMBOL *sym, *with = NULL;
insist(set != NULL);
insist(memb != NULL);
insist(slice != NULL);
insist(set->dimen == slice_dimen(mpl, slice));
insist(memb->value.set->dim == set->dimen);
if (slice_arity(mpl, slice) > 0) insist(is_symbol(mpl));
/* read symbols and construct complete n-tuple */
tuple = create_tuple(mpl);
for (temp = slice; temp != NULL; temp = temp->next)
{ if (temp->sym == NULL)
{ /* substitution is needed; read symbol */
if (!is_symbol(mpl))
{ int lack = slice_arity(mpl, temp);
/* with cannot be null due to assertion above */
insist(with != NULL);
if (lack == 1)
error(mpl, "one item missing in data group beginning "
"with %s", format_symbol(mpl, with));
else
error(mpl, "%d items missing in data group beginning "
"with %s", lack, format_symbol(mpl, with));
}
sym = read_symbol(mpl);
if (with == NULL) with = sym;
}
else
{ /* copy symbol from the slice */
sym = copy_symbol(mpl, temp->sym);
}
/* append the symbol to the n-tuple */
tuple = expand_tuple(mpl, tuple, sym);
/* skip optional comma *between* <symbols> */
if (temp->next != NULL && mpl->token == T_COMMA)
get_token(mpl /* , */);
}
/* add constructed n-tuple to elemental set */
check_then_add(mpl, memb->value.set, tuple);
return;
}
/* Returns true when the sym is selectable
*/
bool idepsym(struct symbol *sym)
{
if (!sym->name || strlen(sym->name) == 0)
return true;
if (sym->searched)
return sym->depends;
if (strcmp(sym->name, "y") == 0)
return true;
else if (strcmp(sym->name, "m") == 0)
return true;
else if (strcmp(sym->name, "n") == 0)
return true;
if (sym->dir_dep.expr == NULL && sym->rev_dep.expr == NULL
&& is_symbol(sym)) {
sym->searched = true;
sym->depends = true;
return sym->depends;
}
sym->searched = true;
sym->depends = false;
if (sym->dir_dep.expr) {
sym->depends = sym->depends || idepsym_expr(sym->dir_dep.expr);
}
if (sym->rev_dep.expr) {
sym->depends = sym->depends || idepsym_expr(sym->rev_dep.expr);
}
return sym->depends;
}
object *lookup_variable_value(object *var, object *env) {
object *frame;
object *vars;
object *vals;
if (debug)
{
fprintf(stderr, "entering lookup_variable_value searching for %s\n", var->data.symbol.value);
}
while (!is_the_empty_list(env)) {
frame = first_frame(env);
vars = frame_variables(frame);
vals = frame_values(frame);
if (debug)
{
fprintf(stderr, "1 searching symbol %s\n", var->data.symbol.value);
fprintf(stderr, "1 vars %p\n", vars);
}
while (!is_the_empty_list(vars)) {
if (is_pair(vars)) {
if (var == car(vars)) {
if (debug)
{
fprintf(stderr, "vals---\n");
write(stdout, is_pair(vals) ? car(vals) : the_empty_list);
fflush(stdout);
fprintf(stderr, "\nend---\n");
}
return is_pair(vals) ? car(vals) : the_empty_list;
}
}
else if(is_symbol(vars)) {
if (debug)
{
fprintf(stderr, "2 searched symbol %s\n", var->data.symbol.value);
fprintf(stderr, "last cdr symbol %s\n", vars->data.symbol.value);
}
if (var == vars) {
if (debug)
{
fprintf(stderr, "vals---\n");
write(stdout, vals);
fflush(stdout);
fprintf(stderr, "\nend---\n");
}
return vals;
}
else
{
break;
}
}
vars = cdr(vars);
vals = cdr(vals);
}
env = enclosing_environment(env);
}
fprintf(stderr, "unbound variable, %s\n", var->data.symbol.value);
exit(1);
}
void Printer::print(LispObjRef obj) {
if (is_nil(obj))
output_ << "NIL";
else if (is_fixnum(obj))
output_ << get_ctype<FixnumType>(obj); // (CFixnum)(boost::get<FixnumType>(*obj));
else if (is_floatnum(obj))
output_ << get_ctype<FloatnumType>(obj); //(CFloatnum)(boost::get<FloatnumType>(*obj));
else if (is_string(obj))
output_ << "\"" << get_ctype<StringType>(obj) << "\""; // ""(CString)(boost::get<StringType>(*obj)) << "\"";
else if (is_symbol(obj))
output_ << get_ctype<SymbolType>(obj).name; // static_cast<LispSymbol>(boost::get<SymbolType>(*obj)).first;
else if (is_cons(obj)) {
output_ << "(";
print_cons(obj);
output_ << ")";
} else if (is_char(obj)) {
CChar c = get_ctype<CharType>(obj);
if (isprint(c)) {
output_ << c;
} else {
output_ << "#" << std::hex << (int) c << std::dec;
}
}
else
output_ << "#UNPRINTABLE#";
}
static void function_setup_context(SnFunction* func, SnContext* context)
{
ASSERT(context);
if (!sym_it)
sym_it = snow_vsymbol("it");
VALUE it = context->args ? snow_arguments_get_by_index(context->args, 0) : NULL;
snow_context_set_local_local(context, value_to_symbol(sym_it), it ? it : SN_NIL);
if (context->self == NULL && func->declaration_context)
context->self = func->declaration_context->self;
// TODO: Optimize this
SnArray* arg_names = func->desc->argument_names;
if (arg_names)
{
for (intx i = 0; i < snow_array_size(arg_names); ++i)
{
VALUE vsym = snow_array_get(arg_names, i);
ASSERT(is_symbol(vsym));
SnSymbol sym = value_to_symbol(vsym);
intx idx = snow_arguments_add_name(context->args, sym);
VALUE arg = snow_arguments_get_by_index(context->args, idx);
snow_context_set_local_local(context, sym, arg ? arg : SN_NIL);
}
}
}
/* check arity;
* possibly rewrite dot-lists into regular arguments;
* look for overriden *stdin*|*stdout* */
static cell_t *
walk_through_arguments(secd_t *secd, cell_t *frame, cell_t **args_io) {
cell_t *symlist = get_car(frame);
cell_t *vallist = get_cdr(frame);
size_t valcount = 0;
while (not_nil(symlist)) {
if (is_symbol(symlist)) {
break;
}
if (is_nil(vallist)) {
errorf(";; arity mismatch: %zd argument(s) is not enough\n", valcount);
return new_error(secd, SECD_NIL,
"arity mismatch: %zd argument(s) is not enough", valcount);
}
cell_t *sym = get_car(symlist);
check_io_args(secd, sym, get_car(vallist), args_io);
cell_t *nextsyms = list_next(secd, symlist);
cell_t *nextvals = list_next(secd, vallist);
++valcount;
symlist = nextsyms;
vallist = nextvals;
}
return SECD_NIL;
}
extern cv_t c_eval(obj_t cont, obj_t values)
{
assert(is_cont4(cont));
obj_t expr = cont4_arg(cont);
EVAL_LOG("expr=%O", expr);
COULD_RETRY();
if (is_self_evaluating(expr))
return cv(cont_cont(cont), CONS(expr, values));
else if (is_symbol(expr)) {
obj_t env = cont_env(cont);
obj_t val = env_lookup(env, expr);
return cv(cont_cont(cont), CONS(val, values));
#if !OLD_ENV
} else if (is_env_ref(expr)) {
return cv(cont_cont(cont),
CONS(env_ref_lookup(cont_env(cont), expr), values));
#endif
} else if (is_application(expr)) {
obj_t operator = application_operator(expr);
obj_t env = cont_env(cont);
obj_t second = make_cont4(c_eval_operator,
cont_cont(cont),
env,
expr);
obj_t first = make_cont4(c_eval, second, env, operator);
return cv(first, values);
}
SYNTAX_ERROR(expr, expr, "must be expression");
}
//one arg: exp
static cellpoint definition_value(void)
{
if (is_true(is_null(cdr(cdr(args_ref(1)))))){
printf("define: bad syntax in: ");
write(args_ref(1));
newline();
error_handler();
}
reg = car(cdr(args_ref(1)));
if (is_true(is_symbol(reg))){
reg = car(cdr(cdr(args_ref(1))));
}else {
//get formal arguments list
reg = cdr(reg);
stack_push(&vars_stack, reg);
//get body
reg = cdr(cdr(args_ref(1)));
//make a lambda expression
args_push(reg);
args_push(stack_pop(&vars_stack));
reg = make_lambda();
}
args_pop(1);
return reg;
}
obj_t symbol_name(obj_t symbol)
{
CHECK_OBJ(symbol);
CHECK(is_symbol(symbol), "must be symbol", symbol);
obj_t name = fixvec1_get_ptr(symbol, 0);
if (is_uninitialized(name)) {
size_t max_len = 12;
ssize_t name_len;
wchar_t name_buf[max_len];
while (true) {
name_len = swprintf(name_buf, max_len,
L"g%04d", ++gen_name_counter);
assert(0 <= name_len && name_len < max_len);
name = make_string_from_chars(name_buf, name_len);
if (!is_null(find_symbol(name)))
continue;
/* with lock */ {
/* verify symbol still absent */
fixvec1_set_ptr(symbol, 0, name);
all_symbols_list = make_pair(symbol, all_symbols_list);
}
break;
}
}
return name;
}
int symbolTableEntry::length() {
if (is_symbol()) return 1;
if (!get_link()) return 0;
int count = 0;
for (symbolTableLink* l = get_link(); l; l = l->next) count ++;
return count;
}
static bool file_source_is_filesystem_backed(Value* file_source)
{
return is_list(file_source)
&& (list_length(file_source) >= 1)
&& (is_symbol(list_get(file_source, 0)))
&& (as_symbol(list_get(file_source, 0)) == s_Filesystem);
}
static char* read_word(char* buf, long int *pos)
{
int allocated=50, len=0;
char *b;
b = (char*)malloc(allocated);
if (! b) return NULL;
while (buf[*pos] && (! is_cspace(buf, pos)) && (! is_symbol(buf[*pos])))
{
if (len + 3 > allocated)
{
char *s = (char*)realloc(b, allocated+=20);
if (! s)
{
free(b);
return NULL;
}
b = s;
}
b[len++] = buf[*pos];
(*pos)++;
}
if (! len)
{
free(b);
return NULL;
}
b[len] = 0;
return b;
}
static void explode_function(RfReference &ref)
{
RfListItem *temp = ref->GetFirst();
if (!is_symbol(temp) || temp->next)
throw IntelibX_refal_failure(ref);
ref = new RfExpression(temp->symb_val->TextRepresentation().c_str());
}
void print(Value x)
{
if (is_nil(x))
prints("nil");
else if (is_eof(x))
printf("#eof");
else if (is_fixnum(x))
printf("%d", as_fixnum(x));
else if (is_bool(x))
printf("%s", as_bool(x) ? "true" : "false");
else if (is_char(x))
printf("'%c'", as_char(x));
else if (is_pair(x))
print_list(x);
else if (is_symbol(x))
prints(as_symbol(x)->value);
else if (is_string(x))
print_string(as_string(x));
else if (is_procedure(x))
printf("#<procedure %s>", as_procedure(x)->name->value);
else if (is_module(x))
printf("#<module>");
else if (is_type(x))
printf("#<type %s>", as_type(x)->name->value);
else if (is_ptr(x))
printf("#<object %p>", as_ptr(x));
else if (is_undefined(x))
printf("#undefined");
else
printf("#ufo");
}
static bool file_source_is_tarball_backed(Value* file_source)
{
return is_list(file_source)
&& (list_length(file_source) >= 1)
&& (is_symbol(list_get(file_source, 0)))
&& (as_symbol(list_get(file_source, 0)) == s_Tarball);
}
MEMBER *read_value
( MPL *mpl,
PARAMETER *par, /* not changed */
TUPLE *tuple /* destroyed */
)
{ MEMBER *memb;
insist(par != NULL);
insist(is_symbol(mpl));
/* there must be no member with the same n-tuple */
if (find_member(mpl, par->array, tuple) != NULL)
error(mpl, "%s%s already defined",
par->name, format_tuple(mpl, '[', tuple));
/* create new parameter member with given n-tuple */
memb = add_member(mpl, par->array, tuple);
/* read value and assigns it to the new parameter member */
switch (par->type)
{ case A_NUMERIC:
case A_INTEGER:
case A_BINARY:
if (!is_number(mpl))
error(mpl, "%s requires numeric data", par->name);
memb->value.num = read_number(mpl);
break;
case A_SYMBOLIC:
memb->value.sym = read_symbol(mpl);
break;
default:
insist(par != par);
}
return memb;
}
/*
====================================================================
This function splits a string into tokens using the characters
found in symbols as breakpoints. If the first symbol is ' ' all
whitespaces are used as breakpoints though NOT added as a token
(thus removed from string).
====================================================================
*/
List* parser_split_string( const char *string, const char *symbols )
{
int pos;
char *token = 0;
List *list = list_create( LIST_AUTO_DELETE, LIST_NO_CALLBACK );
while ( string[0] != 0 ) {
if ( symbols[0] == ' ' )
string = string_ignore_whitespace( string );
if ( string[0] == 0 ) break;
pos = 1; /* 'read in' first character */
while ( string[pos - 1] != 0 && !is_symbol( string[pos - 1], symbols ) && string[pos - 1] != '"' ) pos++;
if ( pos > 1 )
pos--;
else
if ( string[pos - 1] == '"' ) {
/* read a string */
string++; pos = 0;
while ( string[pos] != 0 && string[pos] != '"' ) pos++;
token = calloc( pos + 1, sizeof( char ) );
strncpy( token, string, pos ); token[pos] = 0;
list_add( list, token );
string += pos + (string[pos] != 0);
continue;
}
token = calloc( pos + 1, sizeof( char ) );
strncpy( token, string, pos); token[pos] = 0;
list_add( list, token );
string += pos;
}
return list;
}
static inline int is_tagged_list(object *exp, object *tag)
{
if (is_list(exp)) {
return is_symbol(car(exp)) && car(exp) == tag;
} else {
return 0;
}
}
guint object_hash(gconstpointer gp) {
pointer p = (pointer)gp;
if(is_symbol(p)) {
return g_direct_hash(gp);
}
// TODO: call other hash functions based on type
return g_direct_hash(gp);
}
// A tagged list is a pair whose car is a specified symbol. The value of
// the tagged list is the cdr of the pair
bool is_tagged_list(object *expression, object *tag) {
object *the_car;
if (!is_pair(expression))
return false;
the_car = car(expression);
return is_symbol(the_car) && (the_car == tag);
}
Symbol first_symbol(caValue* value)
{
if (is_symbol(value))
return as_symbol(value);
if (is_list(value))
return first_symbol(list_get(value, 0));
return sym_None;
}
pobject gc_add(pobject object)
{
if (object && !is_symbol(object) && !(object->flags & 0x20)) {
gc_list = cons_new(object, gc_list);
object->flags |= 0x20;
++gc_objects;
}
return object;
}
CFSWString DealWithText(CFSWString text) {
/* Proovin kogu sõnniku minema loopida */
CFSWString res;
text.Trim();
text.Replace(L"\n\n", L"\n", 1);
text.Replace(L"‘", L"'", 1);
text.Replace(L"`", L"'", 1);
text.Replace(L"´", L"'", 1);
text.Replace(L"’", L"'", 1);
for (INTPTR i = 0; i < text.GetLength(); i++) {
CFSWString c = text.GetAt(i);
CFSWString pc = res.GetAt(res.GetLength() - 1);
CFSWString nc = text.GetAt(i + 1);
if (c == L"'") {
if (is_vowel(pc))
res += L"q";
else
res += c;
}
else
if (is_char(c)) res += c;
else
if (is_digit(c)) res += c;
else
if (is_hyphen(c) && is_char(pc) && is_char(nc)) res += sp;
else
if (is_symbol(c)) res += c;
else
if (is_colon(c) && !is_colon(pc)) res += c;
else
if (is_bbracket(c) && !is_bbracket(pc)) res += c;
else
if (is_ebracket(c) && is_ending(nc)) res += L"";
else
if (is_ebracket(c) && !is_ebracket(pc)) res += c;
else
if (is_comma(c) && !is_comma(pc)) res += c;
else
if (is_fchar(c)) res += replace_fchar(c);
else
if (is_space(c) && !is_whitespace(pc)) res += c;
else
if (is_break(c) && !is_break(pc)) {
res += c;
} //kahtlane
else
if (is_tab(c) && !is_whitespace(pc)) res += c;
else
if (is_ending(c) && !is_ending(pc) && !is_whitespace(pc)) res += c;
}
res.Trim();
return res;
}
/* PUBLIC */
BOOL end_of_commands_term(Term t)
{
if (t == NULL)
return FALSE;
else if (!CONSTANT(t))
return FALSE;
else
return is_symbol(SYMNUM(t), "end_of_commands", 0);
} /* end_of_commands_term */
void plain_format
( MPL *mpl,
PARAMETER *par, /* not changed */
SLICE *slice /* not changed */
)
{ TUPLE *tuple;
SLICE *temp;
SYMBOL *sym, *with = NULL;
insist(par != NULL);
insist(par->dim == slice_dimen(mpl, slice));
insist(is_symbol(mpl));
/* read symbols and construct complete subscript list */
tuple = create_tuple(mpl);
for (temp = slice; temp != NULL; temp = temp->next)
{ if (temp->sym == NULL)
{ /* substitution is needed; read symbol */
if (!is_symbol(mpl))
{ int lack = slice_arity(mpl, temp) + 1;
insist(with != NULL);
insist(lack > 1);
error(mpl, "%d items missing in data group beginning wit"
"h %s", lack, format_symbol(mpl, with));
}
sym = read_symbol(mpl);
if (with == NULL) with = sym;
}
else
{ /* copy symbol from the slice */
sym = copy_symbol(mpl, temp->sym);
}
/* append the symbol to the subscript list */
tuple = expand_tuple(mpl, tuple, sym);
/* skip optional comma */
if (mpl->token == T_COMMA) get_token(mpl /* , */);
}
/* read value and assign it to new parameter member */
if (!is_symbol(mpl))
{ insist(with != NULL);
error(mpl, "one item missing in data group beginning with %s",
format_symbol(mpl, with));
}
read_value(mpl, par, tuple);
return;
}
void obj_at_put(int which, oop contents, bool cs = true) {
assert(which > 0 && which <= length(), "index out of bounds");
assert(!is_symbol(), "shouldn't be modifying a canonical string");
assert(contents->verify(), "check contents");
if (cs) {
STORE_OOP(objs(which), contents);
} else {
*objs(which) = contents;
}
}
SYMBOL *read_symbol(MPL *mpl)
{ SYMBOL *sym;
insist(is_symbol(mpl));
if (is_number(mpl))
sym = create_symbol_num(mpl, mpl->value);
else
sym = create_symbol_str(mpl, create_string(mpl, mpl->image));
get_token(mpl /* <symbol> */);
return sym;
}
