static int print_circle_prefix(ios_t *f, value_t v)
{
value_t label;
char buf[64];
char *str;
if ((label=(value_t)ptrhash_get(&printconses, (void*)v)) !=
(value_t)HT_NOTFOUND) {
if (!ismarked(v)) {
//HPOS+=ios_printf(f, "#%ld#", numval(label));
outc('#', f);
str = uint2str(buf, sizeof(buf)-1, numval(label), 10);
outs(str, f);
outc('#', f);
return 1;
}
//HPOS+=ios_printf(f, "#%ld=", numval(label));
outc('#', f);
str = uint2str(buf, sizeof(buf)-1, numval(label), 10);
outs(str, f);
outc('=', f);
}
if (ismanaged(v))
unmark_cons(v);
return 0;
}
static cell_t *read_bytevector(secd_parser_t *p) {
secd_t *secd = p->secd;
assert(p->token == '(', "read_bytevector: '(' expected");
cell_t *tmplist = SECD_NIL;
cell_t *cur;
size_t len = 0;
while (lexnext(p) == TOK_NUM) {
assert((0 <= p->numtok) && (p->numtok < 256),
"read_bytevector: out of range");
cell_t *newc = new_cons(secd, new_number(secd, p->numtok), SECD_NIL);
if (not_nil(tmplist)) {
cur->as.cons.cdr = share_cell(secd, newc);
cur = newc;
} else {
tmplist = cur = newc;
}
++len;
}
cell_t *bvect = new_bytevector_of_size(secd, len);
assert_cell(bvect, "read_bytevector: failed to allocate");
unsigned char *mem = (unsigned char *)strmem(bvect);
cur = tmplist;
size_t i;
for (i = 0; i < len; ++i) {
mem[i] = (unsigned char)numval(list_head(cur));
cur = list_next(secd, cur);
}
free_cell(secd, tmplist);
return bvect;
}
/* machine printing, (write) */
void sexp_pprint(secd_t* secd, cell_t *port, const cell_t *cell) {
switch (cell_type(cell)) {
case CELL_UNDEF: secd_pprintf(secd, port, "#?"); break;
case CELL_INT: secd_pprintf(secd, port, "%d", cell->as.num); break;
case CELL_CHAR:
if (isprint(cell->as.num))
secd_pprintf(secd, port, "#\\%c", (char)cell->as.num);
else
secd_pprintf(secd, port, "#\\x%x", numval(cell));
break;
case CELL_OP: sexp_print_opcode(secd, port, cell->as.op); break;
case CELL_FUNC: secd_pprintf(secd, port, "##func*%p", cell->as.ptr); break;
case CELL_FRAME: secd_pprintf(secd, port,
"##frame@%ld ", cell_index(secd, cell)); break;
case CELL_KONT: secd_pprintf(secd, port,
"##kont@%ld ", cell_index(secd, cell)); break;
case CELL_CONS: sexp_print_list(secd, port, cell); break;
case CELL_ARRAY: sexp_print_array(secd, port, cell); break;
case CELL_STR: secd_pprintf(secd, port, "\"%s\"", strval(cell) + cell->as.str.offset); break;
case CELL_SYM: secd_pprintf(secd, port, "%s", symname(cell)); break;
case CELL_BYTES: sexp_print_bytes(secd, port, strval(cell), mem_size(cell)); break;
case CELL_ERROR: secd_pprintf(secd, port, "#!\"%s\"", errmsg(cell)); break;
case CELL_PORT: sexp_pprint_port(secd, port, cell); break;
case CELL_REF: sexp_pprint(secd, port, cell->as.ref); break;
default: errorf("sexp_print: unknown cell type %d", (int)cell_type(cell));
}
}
static value_t cyc_vector_compare(value_t a, value_t b, htable_t *table,
int eq)
{
size_t la = vector_size(a);
size_t lb = vector_size(b);
size_t m, i;
value_t d, xa, xb, ca, cb;
// first try to prove them different with no recursion
if (eq && (la!=lb)) return fixnum(1);
m = la < lb ? la : lb;
for (i = 0; i < m; i++) {
xa = vector_elt(a,i);
xb = vector_elt(b,i);
if (leafp(xa) || leafp(xb)) {
d = bounded_compare(xa, xb, 1, eq);
if (d!=NIL && numval(d)!=0) return d;
}
else if (tag(xa) < tag(xb)) {
return fixnum(-1);
}
else if (tag(xa) > tag(xb)) {
return fixnum(1);
}
}
ca = eq_class(table, a);
cb = eq_class(table, b);
if (ca!=NIL && ca==cb)
return fixnum(0);
eq_union(table, a, b, ca, cb);
for (i = 0; i < m; i++) {
xa = vector_elt(a,i);
xb = vector_elt(b,i);
if (!leafp(xa) || tag(xa)==TAG_FUNCTION) {
d = cyc_compare(xa, xb, table, eq);
if (numval(d)!=0)
return d;
}
}
if (la < lb) return fixnum(-1);
if (la > lb) return fixnum(1);
return fixnum(0);
}
JL_DLLEXPORT int jl_operator_precedence(char *sym)
{
jl_ast_context_t *ctx = jl_ast_ctx_enter();
fl_context_t *fl_ctx = &ctx->fl;
int res = numval(fl_applyn(fl_ctx, 1, symbol_value(symbol(fl_ctx, "operator-precedence")), symbol(fl_ctx, sym)));
jl_ast_ctx_leave(ctx);
return res;
}
jl_value_t *jl_parse_next(void)
{
value_t c = fl_applyn(0, symbol_value(symbol("jl-parser-next")));
if (c == FL_EOF)
return NULL;
if (iscons(c)) {
if (cdr_(c) == FL_EOF)
return NULL;
value_t a = car_(c);
if (isfixnum(a)) {
jl_lineno = numval(a);
//jl_printf(JL_STDERR, " on line %d\n", jl_lineno);
c = cdr_(c);
}
}
// for error, get most recent line number
if (iscons(c) && car_(c) == fl_error_sym)
jl_lineno = numval(fl_applyn(0, symbol_value(symbol("jl-parser-current-lineno"))));
return scm_to_julia(c,0);
}
static double todouble(value_t a, char *fname)
{
if (isfixnum(a))
return (double)numval(a);
if (iscprim(a)) {
cprim_t *cp = (cprim_t*)ptr(a);
numerictype_t nt = cp_numtype(cp);
return conv_to_double(cp_data(cp), nt);
}
type_error(fname, "number", a);
}
void _write_se(SE *e) {
char numbuf[23];
if(e==NIL) {
c_out("()");
return;
}
switch(type(e)) {
case NUM: sprintf(numbuf,"%d",numval(e));
c_out(numbuf); break;
case SYM: c_out(symval(e)); break;
case CONS: c_out("("); write_cdr(e); break;
}
}
jl_value_t *jl_parse_next(int *plineno)
{
value_t c = fl_applyn(0, symbol_value(symbol("jl-parser-next")));
if (c == FL_F)
return NULL;
if (iscons(c)) {
value_t a = car_(c);
if (isfixnum(a)) {
*plineno = numval(a);
return scm_to_julia(cdr_(c));
}
}
return scm_to_julia(c);
}
jl_value_t *jl_parse_next()
{
value_t c = fl_applyn(0, symbol_value(symbol("jl-parser-next")));
if (c == FL_F)
return NULL;
if (iscons(c)) {
value_t a = car_(c);
if (isfixnum(a)) {
jl_lineno = numval(a);
//jl_printf(JL_STDERR, " on line %d\n", jl_lineno);
return scm_to_julia(cdr_(c));
}
}
return scm_to_julia(c);
}
static value_t bounded_vector_compare(value_t a, value_t b, int bound, int eq)
{
size_t la = vector_size(a);
size_t lb = vector_size(b);
size_t m, i;
if (eq && (la!=lb)) return fixnum(1);
m = la < lb ? la : lb;
for (i = 0; i < m; i++) {
value_t d = bounded_compare(vector_elt(a,i), vector_elt(b,i),
bound-1, eq);
if (d==NIL || numval(d)!=0) return d;
}
if (la < lb) return fixnum(-1);
if (la > lb) return fixnum(1);
return fixnum(0);
}
nsresult txResultNumberComparator::createSortableValue(Expr* aExpr,
txIEvalContext* aContext,
txObject*& aResult) {
nsAutoPtr<NumberValue> numval(new NumberValue);
if (!numval) {
return NS_ERROR_OUT_OF_MEMORY;
}
RefPtr<txAExprResult> exprRes;
nsresult rv = aExpr->evaluate(aContext, getter_AddRefs(exprRes));
NS_ENSURE_SUCCESS(rv, rv);
numval->mVal = exprRes->numberValue();
aResult = numval.forget();
return NS_OK;
}
void putatom (LISP p, FILE *fd)
{
if (p == NIL) {
fputs ("()", fd);
return;
}
switch (mem[p].type) {
case TSYMBOL: fputs (symname (p), fd); break;
case TBOOL: fputs ("#t", fd); break;
case TINTEGER: fprintf (fd, "%ld", numval (p)); break;
case TREAL: fprintf (fd, "%#g", realval (p)); break;
case TSTRING: putstring (p, fd); break;
case TVECTOR: putvector (p, fd); break;
case TCHAR: putchr (charval (p), fd); break;
case THARDW: fprintf (fd, "<builtin-%lx>", (long) hardwval (p)); break;
case TCLOSURE: fprintf (fd, "<closure-%lx>", p); break;
default: fputs ("<?>", fd); break;
}
}
value_t fl_julia_logmsg(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
{
int kwargs_len = (int)nargs - 6;
if (nargs < 6 || kwargs_len % 2 != 0) {
lerror(fl_ctx, fl_ctx->ArgError, "julia-logmsg: bad argument list - expected "
"level (symbol) group (symbol) id file line msg . kwargs");
}
value_t arg_level = args[0];
value_t arg_group = args[1];
value_t arg_id = args[2];
value_t arg_file = args[3];
value_t arg_line = args[4];
value_t arg_msg = args[5];
value_t *arg_kwargs = args + 6;
if (!isfixnum(arg_level) || !issymbol(arg_group) || !issymbol(arg_id) ||
!issymbol(arg_file) || !isfixnum(arg_line) || !fl_isstring(fl_ctx, arg_msg)) {
lerror(fl_ctx, fl_ctx->ArgError,
"julia-logmsg: Unexpected type in argument list");
}
// Abuse scm_to_julia here to convert arguments. This is meant for `Expr`s
// but should be good enough provided we're only passing simple numbers,
// symbols and strings.
jl_value_t *group=NULL, *id=NULL, *file=NULL, *line=NULL, *msg=NULL;
jl_array_t *kwargs=NULL;
JL_GC_PUSH6(&group, &id, &file, &line, &msg, &kwargs);
group = scm_to_julia(fl_ctx, arg_group, NULL);
id = scm_to_julia(fl_ctx, arg_id, NULL);
file = scm_to_julia(fl_ctx, arg_file, NULL);
line = scm_to_julia(fl_ctx, arg_line, NULL);
msg = scm_to_julia(fl_ctx, arg_msg, NULL);
kwargs = jl_alloc_vec_any(kwargs_len);
for (int i = 0; i < kwargs_len; ++i) {
jl_array_ptr_set(kwargs, i, scm_to_julia(fl_ctx, arg_kwargs[i], NULL));
}
jl_log(numval(arg_level), NULL, group, id, file, line, (jl_value_t*)kwargs, msg);
JL_GC_POP();
return fl_ctx->T;
}
static int
fmt_handling(uint32_t value, const char *fmt, int fmtlen, char *buf, int buflen)
{
const char *t;
uint8_t flen = 0;
int fmttype = fmt[fmtlen-1];
int upper = 1;
if (fmttype - 'a' > 0)
upper = 0;
t = itohex(value, buf, buflen+1, upper);
if (*fmt != '0') { /* no leading zero char */
return t - buf;
}
t = buf;
if (is_num(fmt[1])) {
flen = numval(fmt[1]);
if (flen < buflen) {
t+= buflen - flen;
}
}
return t - buf;
}
static jl_value_t *scm_to_julia_(fl_context_t *fl_ctx, value_t e, jl_module_t *mod)
{
if (fl_isnumber(fl_ctx, e)) {
int64_t i64;
if (isfixnum(e)) {
i64 = numval(e);
}
else {
assert(iscprim(e));
cprim_t *cp = (cprim_t*)ptr(e);
numerictype_t nt = cp_numtype(cp);
switch (nt) {
case T_DOUBLE:
return (jl_value_t*)jl_box_float64(*(double*)cp_data(cp));
case T_FLOAT:
return (jl_value_t*)jl_box_float32(*(float*)cp_data(cp));
case T_UINT8:
return (jl_value_t*)jl_box_uint8(*(uint8_t*)cp_data(cp));
case T_UINT16:
return (jl_value_t*)jl_box_uint16(*(uint16_t*)cp_data(cp));
case T_UINT32:
return (jl_value_t*)jl_box_uint32(*(uint32_t*)cp_data(cp));
case T_UINT64:
return (jl_value_t*)jl_box_uint64(*(uint64_t*)cp_data(cp));
default:
;
}
i64 = conv_to_int64(cp_data(cp), nt);
}
#ifdef _P64
return (jl_value_t*)jl_box_int64(i64);
#else
if (i64 > (int64_t)S32_MAX || i64 < (int64_t)S32_MIN)
return (jl_value_t*)jl_box_int64(i64);
else
return (jl_value_t*)jl_box_int32((int32_t)i64);
#endif
}
if (issymbol(e)) {
if (e == jl_ast_ctx(fl_ctx)->true_sym)
return jl_true;
else if (e == jl_ast_ctx(fl_ctx)->false_sym)
return jl_false;
return (jl_value_t*)scmsym_to_julia(fl_ctx, e);
}
if (fl_isstring(fl_ctx, e))
return jl_pchar_to_string((char*)cvalue_data(e), cvalue_len(e));
if (iscons(e) || e == fl_ctx->NIL) {
value_t hd;
jl_sym_t *sym;
if (e == fl_ctx->NIL) {
hd = e;
}
else {
hd = car_(e);
if (hd == jl_ast_ctx(fl_ctx)->ssavalue_sym)
return jl_box_ssavalue(numval(car_(cdr_(e))));
else if (hd == jl_ast_ctx(fl_ctx)->slot_sym)
return jl_box_slotnumber(numval(car_(cdr_(e))));
else if (hd == jl_ast_ctx(fl_ctx)->null_sym && llength(e) == 1)
return jl_nothing;
}
if (issymbol(hd))
sym = scmsym_to_julia(fl_ctx, hd);
else
sym = list_sym;
size_t n = llength(e)-1;
if (issymbol(hd))
e = cdr_(e);
else
n++;
// nodes with special representations
jl_value_t *ex = NULL, *temp = NULL;
if (sym == line_sym && (n == 1 || n == 2)) {
jl_value_t *linenum = scm_to_julia_(fl_ctx, car_(e), mod);
jl_value_t *file = jl_nothing;
JL_GC_PUSH2(&linenum, &file);
if (n == 2)
file = scm_to_julia_(fl_ctx, car_(cdr_(e)), mod);
temp = jl_new_struct(jl_linenumbernode_type, linenum, file);
JL_GC_POP();
return temp;
}
JL_GC_PUSH1(&ex);
if (sym == label_sym) {
ex = scm_to_julia_(fl_ctx, car_(e), mod);
temp = jl_new_struct(jl_labelnode_type, ex);
}
else if (sym == goto_sym) {
ex = scm_to_julia_(fl_ctx, car_(e), mod);
temp = jl_new_struct(jl_gotonode_type, ex);
}
else if (sym == newvar_sym) {
ex = scm_to_julia_(fl_ctx, car_(e), mod);
temp = jl_new_struct(jl_newvarnode_type, ex);
}
else if (sym == globalref_sym) {
ex = scm_to_julia_(fl_ctx, car_(e), mod);
temp = scm_to_julia_(fl_ctx, car_(cdr_(e)), mod);
assert(jl_is_module(ex));
assert(jl_is_symbol(temp));
temp = jl_module_globalref((jl_module_t*)ex, (jl_sym_t*)temp);
}
else if (sym == top_sym) {
assert(mod && "top should not be generated by the parser");
ex = scm_to_julia_(fl_ctx, car_(e), mod);
assert(jl_is_symbol(ex));
temp = jl_module_globalref(jl_base_relative_to(mod), (jl_sym_t*)ex);
}
else if (sym == core_sym) {
ex = scm_to_julia_(fl_ctx, car_(e), mod);
assert(jl_is_symbol(ex));
temp = jl_module_globalref(jl_core_module, (jl_sym_t*)ex);
}
else if (sym == inert_sym || (sym == quote_sym && (!iscons(car_(e))))) {
ex = scm_to_julia_(fl_ctx, car_(e), mod);
temp = jl_new_struct(jl_quotenode_type, ex);
}
if (temp) {
JL_GC_POP();
return temp;
}
ex = (jl_value_t*)jl_exprn(sym, n);
size_t i;
for (i = 0; i < n; i++) {
assert(iscons(e));
jl_array_ptr_set(((jl_expr_t*)ex)->args, i, scm_to_julia_(fl_ctx, car_(e), mod));
e = cdr_(e);
}
if (sym == lambda_sym)
ex = (jl_value_t*)jl_new_code_info_from_ast((jl_expr_t*)ex);
JL_GC_POP();
if (sym == list_sym)
return (jl_value_t*)((jl_expr_t*)ex)->args;
return (jl_value_t*)ex;
}
if (iscprim(e) && cp_class((cprim_t*)ptr(e)) == fl_ctx->wchartype) {
uint32_t c, u = *(uint32_t*)cp_data((cprim_t*)ptr(e));
if (u < 0x80) {
c = u << 24;
} else {
c = ((u << 0) & 0x0000003f) | ((u << 2) & 0x00003f00) |
((u << 4) & 0x003f0000) | ((u << 6) & 0x3f000000);
c = u < 0x00000800 ? (c << 16) | 0xc0800000 :
u < 0x00010000 ? (c << 8) | 0xe0808000 :
(c << 0) | 0xf0808080 ;
}
return jl_box_char(c);
}
if (iscvalue(e) && cv_class((cvalue_t*)ptr(e)) == jl_ast_ctx(fl_ctx)->jvtype) {
return *(jl_value_t**)cv_data((cvalue_t*)ptr(e));
}
jl_error("malformed tree");
}
void fl_print_child(ios_t *f, value_t v)
{
char *name, *str;
char buf[64];
if (print_level >= 0 && P_LEVEL >= print_level &&
(iscons(v) || isvector(v) || isclosure(v))) {
outc('#', f);
return;
}
P_LEVEL++;
switch (tag(v)) {
case TAG_NUM :
case TAG_NUM1: //HPOS+=ios_printf(f, "%ld", numval(v)); break;
str = uint2str(&buf[1], sizeof(buf)-1, labs(numval(v)), 10);
if (numval(v)<0)
*(--str) = '-';
outs(str, f);
break;
case TAG_SYM:
name = symbol_name(v);
if (print_princ)
outs(name, f);
else if (ismanaged(v)) {
outsn("#:", f, 2);
outs(name, f);
}
else
print_symbol_name(f, name);
break;
case TAG_FUNCTION:
if (v == FL_T) {
outsn("#t", f, 2);
}
else if (v == FL_F) {
outsn("#f", f, 2);
}
else if (v == FL_NIL) {
outsn("()", f, 2);
}
else if (v == FL_EOF) {
outsn("#<eof>", f, 6);
}
else if (isbuiltin(v)) {
if (!print_princ)
outsn("#.", f, 2);
outs(builtin_names[uintval(v)], f);
}
else {
assert(isclosure(v));
if (!print_princ) {
if (print_circle_prefix(f, v)) break;
function_t *fn = (function_t*)ptr(v);
outs("#fn(", f);
char *data = cvalue_data(fn->bcode);
size_t i, sz = cvalue_len(fn->bcode);
for(i=0; i < sz; i++) data[i] += 48;
fl_print_child(f, fn->bcode);
for(i=0; i < sz; i++) data[i] -= 48;
outc(' ', f);
fl_print_child(f, fn->vals);
if (fn->env != NIL) {
outc(' ', f);
fl_print_child(f, fn->env);
}
if (fn->name != LAMBDA) {
outc(' ', f);
fl_print_child(f, fn->name);
}
outc(')', f);
}
else {
outs("#<function>", f);
}
}
break;
case TAG_CVALUE:
case TAG_CPRIM:
if (v == UNBOUND) { outs("#<undefined>", f); break; }
case TAG_VECTOR:
case TAG_CONS:
if (print_circle_prefix(f, v)) break;
if (isvector(v)) {
outc('[', f);
int newindent = HPOS, est;
int i, sz = vector_size(v);
for(i=0; i < sz; i++) {
if (print_length >= 0 && i >= print_length && i < sz-1) {
outsn("...", f, 3);
break;
}
fl_print_child(f, vector_elt(v,i));
if (i < sz-1) {
if (!print_pretty) {
outc(' ', f);
}
else {
est = lengthestimate(vector_elt(v,i+1));
if (HPOS > SCR_WIDTH-4 ||
(est!=-1 && (HPOS+est > SCR_WIDTH-2)) ||
(HPOS > SCR_WIDTH/2 &&
!smallp(vector_elt(v,i+1)) &&
!tinyp(vector_elt(v,i))))
newindent = outindent(newindent, f);
else
outc(' ', f);
}
}
}
outc(']', f);
break;
}
if (iscvalue(v) || iscprim(v))
cvalue_print(f, v);
else
print_pair(f, v);
break;
}
P_LEVEL--;
}
int main(int ac, char **av) {
FILE *codefile=stdin;
int mempoolsize=1024*1024;
int c;
SE *prog,*result;
silent=0;
if(ac<2) {
versioninfo(stderr,av[0]);
helpinfo(stderr,av[0]);
return 1;
}
while((c=getopt(ac,av,"svch?p:"))!=-1) {
switch(c) {
case 's':
silent=1;
break;
case 'c':
conscellinfo(stdout,av[0]);
return 0;
case 'v':
versioninfo(stdout,av[0]);
return 0;
case '?':
case 'h':
versioninfo(stdout,av[0]);
helpinfo(stdout,av[0]);
return 0;
case 'p':
mempoolsize=atoi(optarg);
break;
default:
// versioninfo(stderr,av[0]);
// helpinfo(stdout,av[0]);
return 1;
}
}
if((codefile=fopen(av[optind],"r"))) {
if(silent!=1) printf("Initializing mempool (%d cells)...\n",mempoolsize);
init_mempool(mempoolsize);
if(silent!=1) printf("Loading code from %s...\n",av[optind]);
prog=read_se(codefile);
if(silent!=1) printf("Allocating %d env-slot(s) for environments...\n",numval(car(prog)));
Dreg=(SE **)malloc(sizeof(SE *)*numval(car(prog)));
Rreg=NIL;
Creg=NIL;
C_push(cdr(prog));
if(silent!=1) printf("Running the machine.\n");
result=run();
if(silent!=1) printf("Result: ");
write_se(result,stdout);
printf("\n"); // ?
if(silent!=1) printf("\nAuf wiedersehen!\n");
return 0;
} else fprintf(stderr,"Could not open file %s.\n",av[optind]);
return 1;
}
// strange comparisons are resolved arbitrarily but consistently.
// ordering: number < cprim < function < vector < cvalue < symbol < cons
static value_t bounded_compare(value_t a, value_t b, int bound, int eq)
{
value_t d;
compare_top:
if (a == b) return fixnum(0);
if (bound <= 0)
return NIL;
int taga = tag(a);
int tagb = cmptag(b);
int c;
switch (taga) {
case TAG_NUM :
case TAG_NUM1:
if (isfixnum(b)) {
return (numval(a) < numval(b)) ? fixnum(-1) : fixnum(1);
}
if (iscprim(b)) {
if (cp_class((cprim_t*)ptr(b)) == wchartype)
return fixnum(1);
return fixnum(numeric_compare(a, b, eq, 1, NULL));
}
return fixnum(-1);
case TAG_SYM:
if (eq) return fixnum(1);
if (tagb < TAG_SYM) return fixnum(1);
if (tagb > TAG_SYM) return fixnum(-1);
return fixnum(strcmp(symbol_name(a), symbol_name(b)));
case TAG_VECTOR:
if (isvector(b))
return bounded_vector_compare(a, b, bound, eq);
break;
case TAG_CPRIM:
if (cp_class((cprim_t*)ptr(a)) == wchartype) {
if (!iscprim(b) || cp_class((cprim_t*)ptr(b)) != wchartype)
return fixnum(-1);
}
else if (iscprim(b) && cp_class((cprim_t*)ptr(b)) == wchartype) {
return fixnum(1);
}
c = numeric_compare(a, b, eq, 1, NULL);
if (c != 2)
return fixnum(c);
break;
case TAG_CVALUE:
if (iscvalue(b)) {
if (cv_isPOD((cvalue_t*)ptr(a)) && cv_isPOD((cvalue_t*)ptr(b)))
return cvalue_compare(a, b);
return fixnum(1);
}
break;
case TAG_FUNCTION:
if (tagb == TAG_FUNCTION) {
if (uintval(a) > N_BUILTINS && uintval(b) > N_BUILTINS) {
function_t *fa = (function_t*)ptr(a);
function_t *fb = (function_t*)ptr(b);
d = bounded_compare(fa->bcode, fb->bcode, bound-1, eq);
if (d==NIL || numval(d) != 0) return d;
d = bounded_compare(fa->vals, fb->vals, bound-1, eq);
if (d==NIL || numval(d) != 0) return d;
d = bounded_compare(fa->env, fb->env, bound-1, eq);
if (d==NIL || numval(d) != 0) return d;
return fixnum(0);
}
return (uintval(a) < uintval(b)) ? fixnum(-1) : fixnum(1);
}
break;
case TAG_CONS:
if (tagb < TAG_CONS) return fixnum(1);
d = bounded_compare(car_(a), car_(b), bound-1, eq);
if (d==NIL || numval(d) != 0) return d;
a = cdr_(a); b = cdr_(b);
bound--;
goto compare_top;
}
return (taga < tagb) ? fixnum(-1) : fixnum(1);
}
int equal_lispvalue(value_t a, value_t b)
{
if (eq_comparable(a, b))
return (a==b);
return (numval(compare_(a,b,1))==0);
}
// label is the backreference we'd like to fix up with this read
static value_t do_read_sexpr(value_t label)
{
value_t v, sym, oldtokval, *head;
value_t *pv;
u_int32_t t;
char c;
t = peek();
take();
switch (t) {
case TOK_CLOSE:
lerror(ParseError, "read: unexpected ')'");
case TOK_CLOSEB:
lerror(ParseError, "read: unexpected ']'");
case TOK_DOT:
lerror(ParseError, "read: unexpected '.'");
case TOK_SYM:
case TOK_NUM:
return tokval;
case TOK_COMMA:
head = &COMMA; goto listwith;
case TOK_COMMAAT:
head = &COMMAAT; goto listwith;
case TOK_COMMADOT:
head = &COMMADOT; goto listwith;
case TOK_BQ:
head = &BACKQUOTE; goto listwith;
case TOK_QUOTE:
head = "E;
listwith:
v = cons_reserve(2);
car_(v) = *head;
cdr_(v) = tagptr(((cons_t*)ptr(v))+1, TAG_CONS);
car_(cdr_(v)) = cdr_(cdr_(v)) = NIL;
PUSH(v);
if (label != UNBOUND)
ptrhash_put(&readstate->backrefs, (void*)label, (void*)v);
v = do_read_sexpr(UNBOUND);
car_(cdr_(Stack[SP-1])) = v;
return POP();
case TOK_SHARPQUOTE:
// femtoLisp doesn't need symbol-function, so #' does nothing
return do_read_sexpr(label);
case TOK_OPEN:
PUSH(NIL);
read_list(&Stack[SP-1], label);
return POP();
case TOK_SHARPSYM:
sym = tokval;
if (sym == tsym || sym == Tsym)
return FL_T;
else if (sym == fsym || sym == Fsym)
return FL_F;
// constructor notation
c = nextchar();
if (c != '(') {
take();
lerrorf(ParseError, "read: expected argument list for %s",
symbol_name(tokval));
}
PUSH(NIL);
read_list(&Stack[SP-1], UNBOUND);
if (sym == vu8sym) {
sym = arraysym;
Stack[SP-1] = fl_cons(uint8sym, Stack[SP-1]);
}
else if (sym == fnsym) {
sym = FUNCTION;
}
v = symbol_value(sym);
if (v == UNBOUND)
fl_raise(fl_list2(UnboundError, sym));
return fl_apply(v, POP());
case TOK_OPENB:
return read_vector(label, TOK_CLOSEB);
case TOK_SHARPOPEN:
return read_vector(label, TOK_CLOSE);
case TOK_SHARPDOT:
// eval-when-read
// evaluated expressions can refer to existing backreferences, but they
// cannot see pending labels. in other words:
// (... #2=#.#0# ... ) OK
// (... #2=#.(#2#) ... ) DO NOT WANT
sym = do_read_sexpr(UNBOUND);
if (issymbol(sym)) {
v = symbol_value(sym);
if (v == UNBOUND)
fl_raise(fl_list2(UnboundError, sym));
return v;
}
return fl_toplevel_eval(sym);
case TOK_LABEL:
// create backreference label
if (ptrhash_has(&readstate->backrefs, (void*)tokval))
lerrorf(ParseError, "read: label %ld redefined", numval(tokval));
oldtokval = tokval;
v = do_read_sexpr(tokval);
ptrhash_put(&readstate->backrefs, (void*)oldtokval, (void*)v);
return v;
case TOK_BACKREF:
// look up backreference
v = (value_t)ptrhash_get(&readstate->backrefs, (void*)tokval);
if (v == (value_t)HT_NOTFOUND)
lerrorf(ParseError, "read: undefined label %ld", numval(tokval));
return v;
case TOK_GENSYM:
pv = (value_t*)ptrhash_bp(&readstate->gensyms, (void*)tokval);
if (*pv == (value_t)HT_NOTFOUND)
*pv = fl_gensym(NULL, 0);
return *pv;
case TOK_DOUBLEQUOTE:
return read_string();
}
return FL_UNSPECIFIED;
}
static jl_value_t *scm_to_julia_(value_t e, int eo)
{
if (fl_isnumber(e)) {
int64_t i64;
if (isfixnum(e)) {
i64 = numval(e);
}
else {
assert(iscprim(e));
cprim_t *cp = (cprim_t*)ptr(e);
numerictype_t nt = cp_numtype(cp);
switch (nt) {
case T_DOUBLE:
return (jl_value_t*)jl_box_float64(*(double*)cp_data(cp));
case T_FLOAT:
return (jl_value_t*)jl_box_float32(*(float*)cp_data(cp));
case T_UINT8:
return (jl_value_t*)jl_box_uint8(*(uint8_t*)cp_data(cp));
case T_UINT16:
return (jl_value_t*)jl_box_uint16(*(uint16_t*)cp_data(cp));
case T_UINT32:
return (jl_value_t*)jl_box_uint32(*(uint32_t*)cp_data(cp));
case T_UINT64:
return (jl_value_t*)jl_box_uint64(*(uint64_t*)cp_data(cp));
default:
;
}
i64 = conv_to_int64(cp_data(cp), nt);
}
if (
#ifdef _P64
jl_compileropts.int_literals==32
#else
jl_compileropts.int_literals!=64
#endif
) {
if (i64 > (int64_t)S32_MAX || i64 < (int64_t)S32_MIN)
return (jl_value_t*)jl_box_int64(i64);
return (jl_value_t*)jl_box_int32((int32_t)i64);
}
else {
return (jl_value_t*)jl_box_int64(i64);
}
}
if (issymbol(e)) {
if (e == true_sym)
return jl_true;
else if (e == false_sym)
return jl_false;
return (jl_value_t*)scmsym_to_julia(e);
}
if (fl_isstring(e)) {
return jl_pchar_to_string((char*)cvalue_data(e), cvalue_len(e));
}
if (e == FL_F) {
return jl_false;
}
if (e == FL_T) {
return jl_true;
}
if (e == FL_NIL) {
return (jl_value_t*)jl_null;
}
if (iscons(e)) {
value_t hd = car_(e);
if (issymbol(hd)) {
jl_sym_t *sym = scmsym_to_julia(hd);
/* tree node types:
goto gotoifnot label return
lambda call = quote
null top method
body file new
line enter leave
*/
size_t n = llength(e)-1;
size_t i;
if (sym == null_sym && n == 0)
return jl_nothing;
if (sym == lambda_sym) {
jl_expr_t *ex = jl_exprn(lambda_sym, n);
e = cdr_(e);
value_t largs = car_(e);
jl_cellset(ex->args, 0, full_list(largs,eo));
e = cdr_(e);
value_t ee = car_(e);
jl_array_t *vinf = jl_alloc_cell_1d(3);
jl_cellset(vinf, 0, full_list(car_(ee),eo));
ee = cdr_(ee);
jl_cellset(vinf, 1, full_list_of_lists(car_(ee),eo));
ee = cdr_(ee);
jl_cellset(vinf, 2, full_list_of_lists(car_(ee),eo));
assert(!iscons(cdr_(ee)));
jl_cellset(ex->args, 1, vinf);
e = cdr_(e);
for(i=2; i < n; i++) {
assert(iscons(e));
jl_cellset(ex->args, i, scm_to_julia_(car_(e), eo));
e = cdr_(e);
}
return
(jl_value_t*)jl_new_lambda_info((jl_value_t*)ex, jl_null);
}
e = cdr_(e);
if (!eo) {
if (sym == line_sym && n==1) {
return jl_new_struct(jl_linenumbernode_type,
scm_to_julia_(car_(e),0));
}
if (sym == label_sym) {
return jl_new_struct(jl_labelnode_type,
scm_to_julia_(car_(e),0));
}
if (sym == goto_sym) {
return jl_new_struct(jl_gotonode_type,
scm_to_julia_(car_(e),0));
}
if (sym == quote_sym) {
return jl_new_struct(jl_quotenode_type,
scm_to_julia_(car_(e),0));
}
if (sym == top_sym) {
return jl_new_struct(jl_topnode_type,
scm_to_julia_(car_(e),0));
}
if (sym == newvar_sym) {
return jl_new_struct(jl_newvarnode_type,
scm_to_julia_(car_(e),0));
}
}
jl_expr_t *ex = jl_exprn(sym, n);
// allocate a fresh args array for empty exprs passed to macros
if (eo && n == 0)
ex->args = jl_alloc_cell_1d(0);
for(i=0; i < n; i++) {
assert(iscons(e));
jl_cellset(ex->args, i, scm_to_julia_(car_(e),eo));
e = cdr_(e);
}
return (jl_value_t*)ex;
}
else {
jl_error("malformed tree");
}
}
if (iscprim(e) && cp_class((cprim_t*)ptr(e))==wchartype) {
jl_value_t *wc =
jl_box32(jl_char_type, *(int32_t*)cp_data((cprim_t*)ptr(e)));
return wc;
}
if (iscvalue(e) && cv_class((cvalue_t*)ptr(e)) == jvtype) {
return *(jl_value_t**)cv_data((cvalue_t*)ptr(e));
}
jl_error("malformed tree");
return (jl_value_t*)jl_null;
}
DLLEXPORT int jl_operator_precedence(char *sym) {
return numval(fl_applyn(1, symbol_value(symbol("operator-precedence")),
symbol(sym)));
}
static jl_value_t *scm_to_julia_(value_t e)
{
if (fl_isnumber(e)) {
if (iscprim(e)) {
numerictype_t nt = cp_numtype((cprim_t*)ptr(e));
switch (nt) {
case T_DOUBLE:
return (jl_value_t*)jl_box_float64(*(double*)cp_data((cprim_t*)ptr(e)));
case T_FLOAT:
return (jl_value_t*)jl_box_float32(*(float*)cp_data((cprim_t*)ptr(e)));
case T_INT64:
return (jl_value_t*)jl_box_int64(*(int64_t*)cp_data((cprim_t*)ptr(e)));
case T_UINT8:
return (jl_value_t*)jl_box_uint8(*(uint8_t*)cp_data((cprim_t*)ptr(e)));
case T_UINT16:
return (jl_value_t*)jl_box_uint16(*(uint16_t*)cp_data((cprim_t*)ptr(e)));
case T_UINT32:
return (jl_value_t*)jl_box_uint32(*(uint32_t*)cp_data((cprim_t*)ptr(e)));
case T_UINT64:
return (jl_value_t*)jl_box_uint64(*(uint64_t*)cp_data((cprim_t*)ptr(e)));
default:
;
}
}
if (isfixnum(e)) {
int64_t ne = numval(e);
#ifdef __LP64__
return (jl_value_t*)jl_box_int64(ne);
#else
if (ne > S32_MAX || ne < S32_MIN)
return (jl_value_t*)jl_box_int64(ne);
return (jl_value_t*)jl_box_int32((int32_t)ne);
#endif
}
uint64_t n = toulong(e, "scm_to_julia");
#ifdef __LP64__
return (jl_value_t*)jl_box_int64((int64_t)n);
#else
if (n > S32_MAX)
return (jl_value_t*)jl_box_int64((int64_t)n);
return (jl_value_t*)jl_box_int32((int32_t)n);
#endif
}
if (issymbol(e)) {
if (!fl_isgensym(e)) {
char *sn = symbol_name(e);
if (!strcmp(sn, "true"))
return jl_true;
else if (!strcmp(sn, "false"))
return jl_false;
}
return (jl_value_t*)scmsym_to_julia(e);
}
if (fl_isstring(e)) {
return jl_pchar_to_string(cvalue_data(e), cvalue_len(e));
}
if (e == FL_F) {
return jl_false;
}
if (e == FL_T) {
return jl_true;
}
if (e == FL_NIL) {
return (jl_value_t*)jl_null;
}
if (iscons(e)) {
value_t hd = car_(e);
if (issymbol(hd)) {
jl_sym_t *sym = scmsym_to_julia(hd);
/* tree node types:
goto gotoifnot label return
lambda call = quote
null top method
body file new
line enter leave
*/
size_t n = llength(e)-1;
size_t i;
if (sym == lambda_sym) {
jl_expr_t *ex = jl_exprn(lambda_sym, n);
e = cdr_(e);
value_t largs = car_(e);
jl_cellset(ex->args, 0, full_list(largs));
e = cdr_(e);
value_t ee = car_(e);
jl_array_t *vinf = jl_alloc_cell_1d(3);
jl_cellset(vinf, 0, full_list(car_(ee)));
ee = cdr_(ee);
jl_cellset(vinf, 1, full_list_of_lists(car_(ee)));
ee = cdr_(ee);
jl_cellset(vinf, 2, full_list_of_lists(car_(ee)));
assert(!iscons(cdr_(ee)));
jl_cellset(ex->args, 1, vinf);
e = cdr_(e);
for(i=2; i < n; i++) {
assert(iscons(e));
jl_cellset(ex->args, i, scm_to_julia_(car_(e)));
e = cdr_(e);
}
return
(jl_value_t*)jl_new_lambda_info((jl_value_t*)ex, jl_null);
}
e = cdr_(e);
if (sym == line_sym && n==1) {
return jl_new_struct(jl_linenumbernode_type,
scm_to_julia_(car_(e)));
}
if (sym == label_sym) {
return jl_new_struct(jl_labelnode_type,
scm_to_julia_(car_(e)));
}
if (sym == goto_sym) {
return jl_new_struct(jl_gotonode_type,
scm_to_julia_(car_(e)));
}
if (sym == quote_sym) {
return jl_new_struct(jl_quotenode_type,
scm_to_julia_(car_(e)));
}
if (sym == top_sym) {
return jl_new_struct(jl_topnode_type,
scm_to_julia_(car_(e)));
}
jl_expr_t *ex = jl_exprn(sym, n);
for(i=0; i < n; i++) {
assert(iscons(e));
jl_cellset(ex->args, i, scm_to_julia_(car_(e)));
e = cdr_(e);
}
return (jl_value_t*)ex;
}
else {
jl_error("malformed tree");
}
}
if (iscprim(e) && cp_class((cprim_t*)ptr(e))==wchartype) {
jl_value_t *wc =
jl_box32(jl_char_type, *(int32_t*)cp_data((cprim_t*)ptr(e)));
return wc;
}
if (iscvalue(e) && cv_class((cvalue_t*)ptr(e)) == jvtype) {
return *(jl_value_t**)cv_data((cvalue_t*)ptr(e));
}
jl_error("malformed tree");
return (jl_value_t*)jl_null;
}
static value_t cyc_compare(value_t a, value_t b, htable_t *table, int eq)
{
value_t d, ca, cb;
cyc_compare_top:
if (a==b)
return fixnum(0);
if (iscons(a)) {
if (iscons(b)) {
value_t aa = car_(a); value_t da = cdr_(a);
value_t ab = car_(b); value_t db = cdr_(b);
int tagaa = tag(aa); int tagda = tag(da);
int tagab = tag(ab); int tagdb = tag(db);
if (leafp(aa) || leafp(ab)) {
d = bounded_compare(aa, ab, 1, eq);
if (d!=NIL && numval(d)!=0) return d;
}
else if (tagaa < tagab)
return fixnum(-1);
else if (tagaa > tagab)
return fixnum(1);
if (leafp(da) || leafp(db)) {
d = bounded_compare(da, db, 1, eq);
if (d!=NIL && numval(d)!=0) return d;
}
else if (tagda < tagdb)
return fixnum(-1);
else if (tagda > tagdb)
return fixnum(1);
ca = eq_class(table, a);
cb = eq_class(table, b);
if (ca!=NIL && ca==cb)
return fixnum(0);
eq_union(table, a, b, ca, cb);
d = cyc_compare(aa, ab, table, eq);
if (numval(d)!=0) return d;
a = da;
b = db;
goto cyc_compare_top;
}
else {
return fixnum(1);
}
}
else if (isvector(a) && isvector(b)) {
return cyc_vector_compare(a, b, table, eq);
}
else if (isclosure(a) && isclosure(b)) {
function_t *fa = (function_t*)ptr(a);
function_t *fb = (function_t*)ptr(b);
d = bounded_compare(fa->bcode, fb->bcode, 1, eq);
if (numval(d) != 0) return d;
ca = eq_class(table, a);
cb = eq_class(table, b);
if (ca!=NIL && ca==cb)
return fixnum(0);
eq_union(table, a, b, ca, cb);
d = cyc_compare(fa->vals, fb->vals, table, eq);
if (numval(d) != 0) return d;
a = fa->env;
b = fb->env;
goto cyc_compare_top;
}
return bounded_compare(a, b, 1, eq);
}
static u_int32_t peek(void)
{
char c, *end;
fixnum_t x;
int ch, base;
if (toktype != TOK_NONE)
return toktype;
c = nextchar();
if (ios_eof(F)) return TOK_NONE;
if (c == '(') {
toktype = TOK_OPEN;
}
else if (c == ')') {
toktype = TOK_CLOSE;
}
else if (c == '[') {
toktype = TOK_OPENB;
}
else if (c == ']') {
toktype = TOK_CLOSEB;
}
else if (c == '\'') {
toktype = TOK_QUOTE;
}
else if (c == '`') {
toktype = TOK_BQ;
}
else if (c == '"') {
toktype = TOK_DOUBLEQUOTE;
}
else if (c == '#') {
ch = ios_getc(F); c = (char)ch;
if (ch == IOS_EOF)
lerror(ParseError, "read: invalid read macro");
if (c == '.') {
toktype = TOK_SHARPDOT;
}
else if (c == '\'') {
toktype = TOK_SHARPQUOTE;
}
else if (c == '\\') {
uint32_t cval;
if (ios_getutf8(F, &cval) == IOS_EOF)
lerror(ParseError, "read: end of input in character constant");
if (cval == (uint32_t)'u' || cval == (uint32_t)'U' ||
cval == (uint32_t)'x') {
read_token('u', 0);
if (buf[1] != '\0') { // not a solitary 'u','U','x'
if (!read_numtok(&buf[1], &tokval, 16))
lerror(ParseError,
"read: invalid hex character constant");
cval = numval(tokval);
}
}
else if (cval >= 'a' && cval <= 'z') {
read_token((char)cval, 0);
tokval = symbol(buf);
if (buf[1] == '\0') /* one character */;
else if (tokval == nulsym) cval = 0x00;
else if (tokval == alarmsym) cval = 0x07;
else if (tokval == backspacesym) cval = 0x08;
else if (tokval == tabsym) cval = 0x09;
else if (tokval == linefeedsym) cval = 0x0A;
else if (tokval == newlinesym) cval = 0x0A;
else if (tokval == vtabsym) cval = 0x0B;
else if (tokval == pagesym) cval = 0x0C;
else if (tokval == returnsym) cval = 0x0D;
else if (tokval == escsym) cval = 0x1B;
else if (tokval == spacesym) cval = 0x20;
else if (tokval == deletesym) cval = 0x7F;
else
lerrorf(ParseError, "read: unknown character #\\%s", buf);
}
toktype = TOK_NUM;
tokval = mk_wchar(cval);
}
else if (c == '(') {
toktype = TOK_SHARPOPEN;
}
else if (c == '<') {
lerror(ParseError, "read: unreadable object");
}
else if (isdigit(c)) {
read_token(c, 1);
c = (char)ios_getc(F);
if (c == '#')
toktype = TOK_BACKREF;
else if (c == '=')
toktype = TOK_LABEL;
else
lerror(ParseError, "read: invalid label");
errno = 0;
x = strtol(buf, &end, 10);
if (*end != '\0' || errno)
lerror(ParseError, "read: invalid label");
tokval = fixnum(x);
}
else if (c == '!') {
// #! single line comment for shbang script support
do {
ch = ios_getc(F);
} while (ch != IOS_EOF && (char)ch != '\n');
return peek();
}
else if (c == '|') {
// multiline comment
int commentlevel=1;
while (1) {
ch = ios_getc(F);
hashpipe_gotc:
if (ch == IOS_EOF)
lerror(ParseError, "read: eof within comment");
if ((char)ch == '|') {
ch = ios_getc(F);
if ((char)ch == '#') {
commentlevel--;
if (commentlevel == 0)
break;
else
continue;
}
goto hashpipe_gotc;
}
else if ((char)ch == '#') {
ch = ios_getc(F);
if ((char)ch == '|')
commentlevel++;
else
goto hashpipe_gotc;
}
}
// this was whitespace, so keep peeking
return peek();
}
else if (c == ';') {
// datum comment
(void)do_read_sexpr(UNBOUND); // skip
return peek();
}
else if (c == ':') {
// gensym
ch = ios_getc(F);
if ((char)ch == 'g')
ch = ios_getc(F);
read_token((char)ch, 0);
errno = 0;
x = strtol(buf, &end, 10);
if (*end != '\0' || buf[0] == '\0' || errno)
lerror(ParseError, "read: invalid gensym label");
toktype = TOK_GENSYM;
tokval = fixnum(x);
}
else if (symchar(c)) {
read_token(ch, 0);
if (((c == 'b' && (base= 2)) ||
(c == 'o' && (base= 8)) ||
(c == 'd' && (base=10)) ||
(c == 'x' && (base=16))) &&
(isdigit_base(buf[1],base) ||
buf[1]=='-')) {
if (!read_numtok(&buf[1], &tokval, base))
lerrorf(ParseError, "read: invalid base %d constant", base);
return (toktype=TOK_NUM);
}
toktype = TOK_SHARPSYM;
tokval = symbol(buf);
}
else {
lerror(ParseError, "read: unknown read macro");
}
}
else if (c == ',') {
toktype = TOK_COMMA;
ch = ios_getc(F);
if (ch == IOS_EOF)
return toktype;
if ((char)ch == '@')
toktype = TOK_COMMAAT;
else if ((char)ch == '.')
toktype = TOK_COMMADOT;
else
ios_ungetc((char)ch, F);
}
else {
if (!read_token(c, 0)) {
if (buf[0]=='.' && buf[1]=='\0') {
return (toktype=TOK_DOT);
}
else {
if (read_numtok(buf, &tokval, 0))
return (toktype=TOK_NUM);
}
}
toktype = TOK_SYM;
tokval = symbol(buf);
}
return toktype;
}
value_t fl_equal(value_t a, value_t b)
{
if (eq_comparable(a, b))
return (a == b) ? FL_T : FL_F;
return (numval(compare_(a,b,1))==0 ? FL_T : FL_F);
}
// *oob: output argument, means we hit the limit specified by 'bound'
static uptrint_t bounded_hash(value_t a, int bound, int *oob)
{
*oob = 0;
union {
double d;
int64_t i64;
} u;
numerictype_t nt;
size_t i, len;
cvalue_t *cv;
cprim_t *cp;
void *data;
uptrint_t h = 0;
int oob2, tg = tag(a);
switch(tg) {
case TAG_NUM :
case TAG_NUM1:
u.d = (double)numval(a);
return doublehash(u.i64);
case TAG_FUNCTION:
if (uintval(a) > N_BUILTINS)
return bounded_hash(((function_t*)ptr(a))->bcode, bound, oob);
return inthash(a);
case TAG_SYM:
return ((symbol_t*)ptr(a))->hash;
case TAG_CPRIM:
cp = (cprim_t*)ptr(a);
data = cp_data(cp);
if (cp_class(cp) == wchartype)
return inthash(*(int32_t*)data);
nt = cp_numtype(cp);
u.d = conv_to_double(data, nt);
return doublehash(u.i64);
case TAG_CVALUE:
cv = (cvalue_t*)ptr(a);
data = cv_data(cv);
return memhash(data, cv_len(cv));
case TAG_VECTOR:
if (bound <= 0) {
*oob = 1;
return 1;
}
len = vector_size(a);
for(i=0; i < len; i++) {
h = MIX(h, bounded_hash(vector_elt(a,i), bound/2, &oob2)^1);
if (oob2)
bound/=2;
*oob = *oob || oob2;
}
return h;
case TAG_CONS:
do {
if (bound <= 0) {
*oob = 1;
return h;
}
h = MIX(h, bounded_hash(car_(a), bound/2, &oob2));
// bounds balancing: try to share the bounds efficiently
// so we can hash better when a list is cdr-deep (a common case)
if (oob2)
bound/=2;
else
bound--;
// recursive OOB propagation. otherwise this case is slow:
// (hash '#2=((#0=(#1=(#1#) . #0#)) . #2#))
*oob = *oob || oob2;
a = cdr_(a);
} while (iscons(a));
h = MIX(h, bounded_hash(a, bound-1, &oob2)^2);
*oob = *oob || oob2;
return h;
}
return 0;
}
static jl_value_t *scm_to_julia_(fl_context_t *fl_ctx, value_t e, int eo)
{
if (fl_isnumber(fl_ctx, e)) {
int64_t i64;
if (isfixnum(e)) {
i64 = numval(e);
}
else {
assert(iscprim(e));
cprim_t *cp = (cprim_t*)ptr(e);
numerictype_t nt = cp_numtype(cp);
switch (nt) {
case T_DOUBLE:
return (jl_value_t*)jl_box_float64(*(double*)cp_data(cp));
case T_FLOAT:
return (jl_value_t*)jl_box_float32(*(float*)cp_data(cp));
case T_UINT8:
return (jl_value_t*)jl_box_uint8(*(uint8_t*)cp_data(cp));
case T_UINT16:
return (jl_value_t*)jl_box_uint16(*(uint16_t*)cp_data(cp));
case T_UINT32:
return (jl_value_t*)jl_box_uint32(*(uint32_t*)cp_data(cp));
case T_UINT64:
return (jl_value_t*)jl_box_uint64(*(uint64_t*)cp_data(cp));
default:
;
}
i64 = conv_to_int64(cp_data(cp), nt);
}
#ifdef _P64
return (jl_value_t*)jl_box_int64(i64);
#else
if (i64 > (int64_t)S32_MAX || i64 < (int64_t)S32_MIN)
return (jl_value_t*)jl_box_int64(i64);
else
return (jl_value_t*)jl_box_int32((int32_t)i64);
#endif
}
if (issymbol(e)) {
if (e == jl_ast_ctx(fl_ctx)->true_sym)
return jl_true;
else if (e == jl_ast_ctx(fl_ctx)->false_sym)
return jl_false;
return (jl_value_t*)scmsym_to_julia(fl_ctx, e);
}
if (fl_isstring(fl_ctx, e))
return jl_pchar_to_string((char*)cvalue_data(e), cvalue_len(e));
if (iscons(e) || e == fl_ctx->NIL) {
value_t hd;
jl_sym_t *sym;
if (e == fl_ctx->NIL) {
hd = e;
}
else {
hd = car_(e);
if (hd == jl_ast_ctx(fl_ctx)->ssavalue_sym)
return jl_box_ssavalue(numval(car_(cdr_(e))));
else if (hd == jl_ast_ctx(fl_ctx)->slot_sym)
return jl_box_slotnumber(numval(car_(cdr_(e))));
else if (hd == jl_ast_ctx(fl_ctx)->null_sym && llength(e) == 1)
return jl_nothing;
}
if (issymbol(hd))
sym = scmsym_to_julia(fl_ctx, hd);
else
sym = list_sym;
size_t n = llength(e)-1;
if (issymbol(hd))
e = cdr_(e);
else
n++;
if (!eo) {
if (sym == line_sym && n==1) {
jl_value_t *linenum = scm_to_julia_(fl_ctx, car_(e), 0);
JL_GC_PUSH1(&linenum);
jl_value_t *temp = jl_new_struct(jl_linenumbernode_type, linenum);
JL_GC_POP();
return temp;
}
jl_value_t *scmv = NULL, *temp = NULL;
JL_GC_PUSH1(&scmv);
if (sym == label_sym) {
scmv = scm_to_julia_(fl_ctx,car_(e),0);
temp = jl_new_struct(jl_labelnode_type, scmv);
JL_GC_POP();
return temp;
}
if (sym == goto_sym) {
scmv = scm_to_julia_(fl_ctx,car_(e),0);
temp = jl_new_struct(jl_gotonode_type, scmv);
JL_GC_POP();
return temp;
}
if (sym == inert_sym || (sym == quote_sym && (!iscons(car_(e))))) {
scmv = scm_to_julia_(fl_ctx,car_(e),0);
temp = jl_new_struct(jl_quotenode_type, scmv);
JL_GC_POP();
return temp;
}
if (sym == top_sym) {
scmv = scm_to_julia_(fl_ctx,car_(e),0);
assert(jl_is_symbol(scmv));
temp = jl_module_globalref(jl_base_relative_to(jl_current_module), (jl_sym_t*)scmv);
JL_GC_POP();
return temp;
}
if (sym == core_sym) {
scmv = scm_to_julia_(fl_ctx,car_(e),0);
assert(jl_is_symbol(scmv));
temp = jl_module_globalref(jl_core_module, (jl_sym_t*)scmv);
JL_GC_POP();
return temp;
}
if (sym == globalref_sym) {
scmv = scm_to_julia_(fl_ctx,car_(e),0);
temp = scm_to_julia_(fl_ctx,car_(cdr_(e)),0);
assert(jl_is_module(scmv));
assert(jl_is_symbol(temp));
temp = jl_module_globalref((jl_module_t*)scmv, (jl_sym_t*)temp);
JL_GC_POP();
return temp;
}
if (sym == newvar_sym) {
scmv = scm_to_julia_(fl_ctx,car_(e),0);
temp = jl_new_struct(jl_newvarnode_type, scmv);
JL_GC_POP();
return temp;
}
JL_GC_POP();
}
else if (sym == inert_sym && !iscons(car_(e))) {
sym = quote_sym;
}
jl_value_t *ex = (jl_value_t*)jl_exprn(sym, n);
JL_GC_PUSH1(&ex);
// allocate a fresh args array for empty exprs passed to macros
if (eo && n == 0) {
((jl_expr_t*)ex)->args = jl_alloc_vec_any(0);
jl_gc_wb(ex, ((jl_expr_t*)ex)->args);
}
size_t i;
for(i=0; i < n; i++) {
assert(iscons(e));
jl_array_ptr_set(((jl_expr_t*)ex)->args, i, scm_to_julia_(fl_ctx, car_(e), eo));
e = cdr_(e);
}
if (sym == lambda_sym)
ex = (jl_value_t*)jl_new_lambda_info_from_ast((jl_expr_t*)ex);
JL_GC_POP();
if (sym == list_sym)
return (jl_value_t*)((jl_expr_t*)ex)->args;
return (jl_value_t*)ex;
}
if (iscprim(e) && cp_class((cprim_t*)ptr(e)) == fl_ctx->wchartype) {
return jl_box32(jl_char_type, *(int32_t*)cp_data((cprim_t*)ptr(e)));
}
if (iscvalue(e) && cv_class((cvalue_t*)ptr(e)) == jl_ast_ctx(fl_ctx)->jvtype) {
return *(jl_value_t**)cv_data((cvalue_t*)ptr(e));
}
jl_error("malformed tree");
return jl_nothing;
}
