//
// Flatten the valid iolist to the buffer of
// appropriate size pointed to by ptr
//
uint8_t *iolist_flatten(term_t l, uint8_t *ptr)
{
if (is_nil(l))
return ptr;
if (is_cons(l))
{
do {
uint32_t *term_data = peel_cons(l);
term_t e = term_data[0];
if (is_int(e))
*ptr++ = int_value(e);
else
{
assert(is_list(e) || (is_boxed(e) && is_binary(peel_boxed(e))));
ptr = iolist_flatten(e, ptr);
}
l = term_data[1];
if (is_boxed(l) && is_binary(peel_boxed(l)))
return iolist_flatten(l, ptr);
} while (is_cons(l));
assert(is_nil(l));
}
else // is_binary()
{
bits_t bs, to;
bits_get_real(peel_boxed(l), &bs);
bits_init_buf(ptr, (bs.ends +7) /8, &to);
ptr += (bs.ends - bs.starts) /8;
bits_copy(&bs, &to);
assert(bs.starts == bs.ends);
}
return ptr;
}
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 term_t compile_pattern(term_t pat, heap_t *hp)
{
term_t result = nil;
if (is_cons(pat))
{
term_t l = pat;
do {
term_t *cons = peel_cons(l);
if (!is_boxed_binary(cons[0]))
return A_BADARG;
term_t ctx = do_compile_pattern(cons[0], hp);
if (is_atom(ctx))
return ctx;
result = heap_cons(hp, ctx, result);
l = cons[1];
} while (is_cons(l));
if (l != nil)
return A_BADARG;
}
else if is_boxed_binary(pat)
{
term_t ctx = do_compile_pattern(pat, hp);
if (is_atom(ctx))
return ctx;
result = heap_cons(hp, ctx, result);
}
else
return A_BADARG;
static void gc_traverse(pobject env)
{
pobject object;
while (is_cons(env)) {
gc_flag_set(env, GC_FLAG_ON);
object = cons_car(env);
if (object && (gc_flag_get(object) == 0)) {
/*
printf("%p\n", object);
*/
gc_flag_set(object, GC_FLAG_ON);
/* XXX: dotted list support??? */
if (is_cons(object)) {
gc_traverse(object);
} else if (is_closure(object)) {
gc_traverse(object->data.closure.env);
gc_traverse(object->data.closure.code);
} else if (is_macro(object)) {
gc_traverse(object->data.macro.env);
gc_traverse(object->data.macro.code);
}
}
env = cons_cdr(env);
}
}
static int64_t iolist_size2(int depth, term_t l)
{
if (depth > IOLIST_MAX_DEPTH)
return -TOO_DEEP;
if (is_nil(l))
return 0;
if (is_cons(l))
{
int64_t size = 0;
do {
uint32_t *term_data = peel_cons(l);
term_t e = term_data[0];
if (is_int(e))
{
if (int_value(e) < 0 || int_value(e) > 255)
return -BAD_ARG;
size++;
}
else
{
if (!is_list(e) && (!is_boxed(e) || !is_binary(peel_boxed(e))))
return -BAD_ARG;
int64_t s = iolist_size2(depth+1, e);
if (s < 0)
return s;
size += s;
}
l = term_data[1];
if (is_boxed(l) && is_binary(peel_boxed(l)))
{
// odd list with binary tail allowed
int64_t s = iolist_size2(depth+1, l);
if (s < 0)
return s;
return size +s;
}
} while (is_cons(l));
if (!is_nil(l))
return -BAD_ARG;
return size;
}
else if (is_boxed_binary(l))
{
bits_t bs;
bits_get_real(peel_boxed(l), &bs);
int64_t bit_size = bit_size = bs.ends - bs.starts;
if ((bit_size & 7) != 0)
return -1;
return bit_size /8;
}
else
return -BAD_ARG;
}
static int64_t bits_list_size2(int depth, term_t l)
{
if (depth > BITS_LIST_MAX_DEPTH)
return -TOO_DEEP;
if (is_nil(l))
return 0;
if (is_cons(l))
{
int64_t size = 0;
do {
uint32_t *term_data = peel_cons(l);
term_t e = term_data[0];
if (is_int(e))
{
if (int_value(e) < 0 || int_value(e) > 255)
return -BAD_ARG;
size += 8;
}
else
{
if (!is_list(e) && (!is_boxed(e) || !is_binary(peel_boxed(e))))
return -BAD_ARG;
int64_t s = bits_list_size2(depth+1, e);
if (s < 0)
return s;
size += s;
}
l = term_data[1];
if (is_boxed(l) && is_binary(peel_boxed(l)))
{
// odd list with binary tail allowed
int64_t s = bits_list_size2(depth+1, l);
if (s < 0)
return s;
size += s;
if (size > MAX_BIT_SIZE)
return -TOO_LONG;
return size;
}
} while (is_cons(l));
if (!is_nil(l))
return -BAD_ARG;
if (size > MAX_BIT_SIZE)
return -TOO_LONG;
return size;
}
else // is_binary()
{
bits_t bs;
bits_get_real(peel_boxed(l), &bs);
if (bs.ends - bs.starts > MAX_BIT_SIZE)
return -TOO_LONG;
return bs.ends - bs.starts;
}
}
static void print_list(FILE *stream, Value v)
{
fprintf(stream, "(");
while (is_cons(v)) {
print(stream, car(v));
v = cdr(v);
if (is_cons(v))
fprintf(stream, " ");
}
fprintf(stream, ")");
}
static pobject cond(pobject env, pobject params)
{
while (is_cons(params)) {
pobject entry = cons_car(params);
if (is_cons(entry)) {
if (eval(env, cons_car(entry)))
return eval(env, object_prepend_begin( cons_cdr( entry ) ) );
} else {
return eval(env, entry);
}
params = cons_cdr(params);
}
return NIL;
}
int main(int argc, char *argv[]) {
secd_t secd;
cell_t *heap = (cell_t *)malloc(sizeof(cell_t) * N_CELLS);
init_secd(&secd, heap, N_CELLS);
#if ((CTRLDEBUG) || (MEMDEBUG))
secd_setport(&secd, SECD_STDDBG, secd_fopen(&secd, "secd.log", "w"));
#endif
cell_t *cmdport = SECD_NIL;
if (argc == 2)
cmdport = secd_fopen(&secd, argv[1], "r");
cell_t *inp = sexp_parse(&secd, cmdport); // cmdport is dropped after
if (is_nil(inp) || !is_cons(inp)) {
secd_errorf(&secd, "list of commands expected\n");
dbg_printc(&secd, inp);
return 1;
}
cell_t *ret;
ret = run_secd(&secd, inp);
return (is_error(ret) ? EXIT_FAILURE : EXIT_SUCCESS);
}
apr_array_header_t *source_line_blocks(term_t info, apr_pool_t *pool)
{
apr_array_header_t *refs = apr_array_make(pool, 64, sizeof(source_ref_t));
term_t cons = info;
while (is_cons(cons))
{
term_box_t *cb = peel(cons);
term_t t = cb->cons.head;
//{F,L,S,E}
if (is_tuple(t))
{
term_box_t *tb = peel(t);
if (tb->tuple.size == 4)
{
source_ref_t *ref = &APR_ARRAY_PUSH(refs, source_ref_t);
ref->file_index = int_value(tb->tuple.elts[0]);
ref->source_line = int_value(tb->tuple.elts[1]);
ref->off_starts = int_value(tb->tuple.elts[2]);
ref->off_ends = int_value(tb->tuple.elts[3]);
}
}
cons = cb->cons.tail;
}
return refs;
}
void free_list(list *l) {
while (is_cons(l)) {
free(l);
l = l->tail;
}
free(l->tail);
}
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#";
}
void print_list(list *l) {
do {
printf("%d :: ", l->head);
l = l->tail;
} while(is_cons(l));
printf("nil\n");
}
static int is_term_smaller_1(term_t l1, term_t l2)
{
assert(is_cons(l1) && is_cons(l2));
do {
term_t *cons1 = peel_cons(l1);
term_t *cons2 = peel_cons(l2);
if (is_term_smaller(cons1[0], cons2[0]))
return 1;
if (is_term_smaller(cons2[0], cons1[0]))
return 0;
l1 = cons1[1];
l2 = cons2[1];
} while (is_cons(l1) && is_cons(l2));
return is_term_smaller(l1, l2);
}
static pobject div(pobject env, pobject params)
{
float result = 0;
pobject o = eval(env, cons_car(params));
if (is_number(o)) {
result = number_value(o);
params = cons_cdr(params);
if (is_cons(params)) {
while (is_cons(params)) {
pobject o = eval(env, cons_car(params));
if (is_number(o))
result /= number_value(o); /* TODO: division by zero error handling */
params = cons_cdr(params);
}
}
}
return gc_add(number_new(result));
}
static pobject begin(pobject env, pobject params)
{
pobject result = NIL;
while (is_cons(params)) {
result = eval(env, cons_car(params));
params = cons_cdr(params);
}
return result;
}
apr_array_header_t *source_files_names(term_t info, apr_pool_t *pool)
{
apr_array_header_t *files = apr_array_make(pool, 1, sizeof(const char *));
term_t cons = info;
while (is_cons(cons))
{
term_box_t *cb = peel(cons);
APR_ARRAY_PUSH(files, const char *) = ltoz(cb->cons.head, pool);
cons = cb->cons.tail;
}
return files;
}
term_t list_rev(term_t t, heap_t *hp)
{
term_t r = nil;
while (is_cons(t))
{
term_t *cons = peel_cons(t);
r = heap_cons(hp, cons[0], r);
t = cons[1];
}
assert(is_nil(t));
return r;
}
static pobject defmacro(pobject env, pobject params)
{
pobject p = cons_car(params);
if (is_cons(p)) {
return env_define(env,
cons_car(p),
gc_add(macro_new(env, cons_cdr(p), cons_cdr(params))));
}
return NIL;
}
static pobject mult(pobject env, pobject params)
{
float result = 1;
while (is_cons(params)) {
pobject o = eval(env, cons_car(params));
if (is_number(o))
result *= number_value(o);
params = cons_cdr(params);
}
return gc_add(number_new(result));
}
static pobject minus(pobject env, pobject params)
{
float result = 0;
pobject o = eval(env, cons_car(params));
if (is_number(o)) {
result = number_value(o);
params = cons_cdr(params);
if (is_cons(params)) {
while (is_cons(params)) {
pobject o = eval(env, cons_car(params));
if (is_number(o))
result -= number_value(o);
params = cons_cdr(params);
}
} else {
result = -result;
}
}
return gc_add(number_new(result));
}
static pobject builtin_macro_expand(pobject env, pobject params)
{
pobject p = cons_car(params);
if (is_cons(p)) {
pobject macro = eval(env, cons_car(p));
if (is_macro(macro))
return macro_expand(env, macro, cons_cdr(p));
}
return NIL;
}
void byte_list_flatten(term_t t, uint8_t *data)
{
assert(is_list(t));
uint8_t *ptr = data;
while (is_cons(t))
{
term_t *cons = peel_cons(t);
assert(is_int(cons[0]));
*ptr++ = int_value(cons[0]);
t = cons[1];
}
assert(is_nil(t));
}
//
// Flatten the valid bits list to the bits_t context
//
void bits_list_flatten(term_t l, bits_t *bs)
{
if (is_nil(l))
return;
if (is_cons(l))
{
do {
uint32_t *term_data = peel_cons(l);
term_t e = term_data[0];
if (is_int(e))
{
int o = int_value(e);
assert(o >= 0 && o < 256);
bits_put_octet(bs, (uint8_t)o);
}
else
{
assert(is_list(e) || (is_boxed(e) && is_binary(peel_boxed(e))));
bits_list_flatten(e, bs);
}
l = term_data[1];
if (is_boxed(l) && is_binary(peel_boxed(l)))
{
bits_list_flatten(l, bs);
return;
}
} while (is_cons(l));
assert(is_nil(l));
}
else // is_binary()
{
bits_t source;
bits_get_real(peel_boxed(l), &source);
bits_copy(&source, bs);
}
}
void dbg_print_list(secd_t *secd, cell_t *list) {
printf(" -= ");
while (not_nil(list)) {
assertv(is_cons(list),
"Not a cons at [%ld]\n", cell_index(secd, list));
printf("[%ld]:%ld\t",
cell_index(secd, list),
cell_index(secd, get_car(list)));
dbg_print_cell(secd, get_car(list));
printf(" -> ");
list = list_next(secd, list);
}
printf("NIL\n");
}
void Printer::print_cons(LispObjRef obj) {
print(car(obj));
LispObjRef next(cdr(obj));
if (is_cons(next)) {
output_ << " ";
print_cons(next);
return;
}
if (is_nil(next)) {
return;
}
output_ << " . ";
print(next);
}
static pobject set(pobject env, pobject params)
{
pobject symbol = cons_car(params);
if (is_symbol(symbol)) {
pobject value = eval(env, cons_nth(params, 2));
pobject cons = env_lookup(env, symbol);
if (is_cons(cons)) {
cons_car_set(cons, value);
return value;
}
}
return NIL;
}
static int term_order(term_t t)
{
if (is_cons(t))
return TERM_ORDER_CONS;
if (is_tuple(t))
return TERM_ORDER_TUPLE;
if (is_nil(t))
return TERM_ORDER_NIL;
if (is_int(t))
return TERM_ORDER_NUMBER;
if (is_atom(t))
return TERM_ORDER_ATOM;
if (is_short_pid(t))
return TERM_ORDER_PID;
if (is_short_oid(t))
return TERM_ORDER_OID;
assert(is_boxed(t));
switch (boxed_tag(peel_boxed(t)))
{
case SUBTAG_POS_BIGNUM:
case SUBTAG_NEG_BIGNUM:
case SUBTAG_FLOAT:
return TERM_ORDER_NUMBER;
case SUBTAG_FUN:
return TERM_ORDER_FUN;
case SUBTAG_EXPORT:
return TERM_ORDER_EXPORT;
case SUBTAG_PID:
return TERM_ORDER_PID;
case SUBTAG_OID:
return TERM_ORDER_OID;
case SUBTAG_REF:
return TERM_ORDER_REF;
case SUBTAG_PROC_BIN:
case SUBTAG_HEAP_BIN:
case SUBTAG_MATCH_CTX:
case SUBTAG_SUB_BIN:
return TERM_ORDER_BINARY;
default:
fatal_error("subtag");
}
}
static pobject define(pobject env, pobject params)
{
pobject p = cons_car(params);
if (is_symbol(p)) {
return env_define(env,
cons_car(params),
eval(env, cons_car(cons_cdr(params))));
} else if (is_cons(p)) {
return env_define(env,
cons_car(p),
gc_add(closure_new(env, cons_cdr(p), cons_cdr(params))));
}
return NIL;
}
int list_len(term_t t)
{
assert(is_list(t));
int len = 0;
while (is_cons(t))
{
term_t *cons = peel_cons(t);
len++;
t = cons[1];
}
if (!is_nil(t))
return -BAD_ARG; // odd list
return len;
}
