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); } #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); return (jl_value_t*)jl_box_int32((int32_t)i64); #endif } 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(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,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)); } } 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),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; }
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"); }
// parse and eval a whole file, possibly reading from a string (`content`) jl_value_t *jl_parse_eval_all(const char *fname, const char *content, size_t contentlen, jl_module_t *inmodule) { jl_ptls_t ptls = jl_get_ptls_states(); if (ptls->in_pure_callback) jl_error("cannot use include inside a generated function"); jl_ast_context_t *ctx = jl_ast_ctx_enter(); fl_context_t *fl_ctx = &ctx->fl; value_t f, ast, expression; size_t len = strlen(fname); f = cvalue_static_cstrn(fl_ctx, fname, len); fl_gc_handle(fl_ctx, &f); if (content != NULL) { JL_TIMING(PARSING); value_t t = cvalue_static_cstrn(fl_ctx, content, contentlen); fl_gc_handle(fl_ctx, &t); ast = fl_applyn(fl_ctx, 2, symbol_value(symbol(fl_ctx, "jl-parse-string-stream")), t, f); fl_free_gc_handles(fl_ctx, 1); } else { JL_TIMING(PARSING); assert(memchr(fname, 0, len) == NULL); // was checked already in jl_load ast = fl_applyn(fl_ctx, 1, symbol_value(symbol(fl_ctx, "jl-parse-file")), f); } fl_free_gc_handles(fl_ctx, 1); if (ast == fl_ctx->F) { jl_ast_ctx_leave(ctx); jl_errorf("could not open file %s", fname); } fl_gc_handle(fl_ctx, &ast); fl_gc_handle(fl_ctx, &expression); int last_lineno = jl_lineno; const char *last_filename = jl_filename; size_t last_age = jl_get_ptls_states()->world_age; jl_lineno = 0; jl_filename = fname; jl_module_t *old_module = ctx->module; ctx->module = inmodule; jl_value_t *form = NULL; jl_value_t *result = jl_nothing; int err = 0; JL_GC_PUSH2(&form, &result); JL_TRY { assert(iscons(ast) && car_(ast) == symbol(fl_ctx, "toplevel")); ast = cdr_(ast); while (iscons(ast)) { expression = car_(ast); { JL_TIMING(LOWERING); if (fl_ctx->T == fl_applyn(fl_ctx, 1, symbol_value(symbol(fl_ctx, "contains-macrocall")), expression)) { form = scm_to_julia(fl_ctx, expression, inmodule); form = jl_expand_macros(form, inmodule, NULL, 0); expression = julia_to_scm(fl_ctx, form); } // expand non-final expressions in statement position (value unused) expression = fl_applyn(fl_ctx, 1, symbol_value(symbol(fl_ctx, iscons(cdr_(ast)) ? "jl-expand-to-thunk-stmt" : "jl-expand-to-thunk")), expression); } jl_get_ptls_states()->world_age = jl_world_counter; form = scm_to_julia(fl_ctx, expression, inmodule); JL_SIGATOMIC_END(); jl_get_ptls_states()->world_age = jl_world_counter; if (jl_is_linenode(form)) jl_lineno = jl_linenode_line(form); else result = jl_toplevel_eval_flex(inmodule, form, 1, 1); JL_SIGATOMIC_BEGIN(); ast = cdr_(ast); } } JL_CATCH { form = jl_pchar_to_string(fname, len); result = jl_box_long(jl_lineno); err = 1; } jl_get_ptls_states()->world_age = last_age; jl_lineno = last_lineno; jl_filename = last_filename; fl_free_gc_handles(fl_ctx, 2); ctx->module = old_module; jl_ast_ctx_leave(ctx); if (err) { if (jl_loaderror_type == NULL) jl_rethrow(); else jl_rethrow_other(jl_new_struct(jl_loaderror_type, form, result, ptls->exception_in_transit)); } JL_GC_POP(); return result; }
static int indentafter2(value_t head, value_t v) { // for certain X always indent (X a b) after a return ((head == definesym || head == defmacrosym) && !allsmallp(cdr_(v))); }
static void print_pair(ios_t *f, value_t v) { value_t cd; char *op = NULL; if (iscons(cdr_(v)) && cdr_(cdr_(v)) == NIL && !ptrhash_has(&printconses, (void*)cdr_(v)) && (((car_(v) == QUOTE) && (op = "'")) || ((car_(v) == BACKQUOTE) && (op = "`")) || ((car_(v) == COMMA) && (op = ",")) || ((car_(v) == COMMAAT) && (op = ",@")) || ((car_(v) == COMMADOT) && (op = ",.")))) { // special prefix syntax unmark_cons(v); unmark_cons(cdr_(v)); outs(op, f); fl_print_child(f, car_(cdr_(v))); return; } int startpos = HPOS; outc('(', f); int newindent=HPOS, blk=blockindent(v); int lastv, n=0, si, ind=0, est, always=0, nextsmall, thistiny; if (!blk) always = indentevery(v); value_t head = car_(v); int after3 = indentafter3(head, v); int after2 = indentafter2(head, v); int n_unindented = 1; while (1) { cd = cdr_(v); if (print_length >= 0 && n >= print_length && cd!=NIL) { outsn("...)", f, 4); break; } lastv = VPOS; unmark_cons(v); fl_print_child(f, car_(v)); if (!iscons(cd) || ptrhash_has(&printconses, (void*)cd)) { if (cd != NIL) { outsn(" . ", f, 3); fl_print_child(f, cd); } outc(')', f); break; } if (!print_pretty || ((head == LAMBDA) && n == 0)) { // never break line before lambda-list ind = 0; } else { est = lengthestimate(car_(cd)); nextsmall = smallp(car_(cd)); thistiny = tinyp(car_(v)); ind = (((VPOS > lastv) || (HPOS>SCR_WIDTH/2 && !nextsmall && !thistiny && n>0)) || (HPOS > SCR_WIDTH-4) || (est!=-1 && (HPOS+est > SCR_WIDTH-2)) || ((head == LAMBDA) && !nextsmall) || (n > 0 && always) || (n == 2 && after3) || (n == 1 && after2) || (n_unindented >= 3 && !nextsmall) || (n == 0 && !smallp(head))); } if (ind) { newindent = outindent(newindent, f); n_unindented = 1; } else { n_unindented++; outc(' ', f); if (n==0) { // set indent level after printing head si = specialindent(head); if (si != -1) newindent = startpos + si; else if (!blk) newindent = HPOS; } } n++; v = cd; } }
value_t eval_sexpr(value_t e, value_t *penv) { value_t f, v, bind, headsym, asym, labl=0, *pv, *argsyms, *body, *lenv; value_t *rest; cons_t *c; symbol_t *sym; u_int32_t saveSP; int i, nargs, noeval=0; number_t s, n; eval_top: if (issymbol(e)) { sym = (symbol_t*)ptr(e); if (sym->constant != UNBOUND) return sym->constant; v = *penv; while (iscons(v)) { bind = car_(v); if (iscons(bind) && car_(bind) == e) return cdr_(bind); v = cdr_(v); } if ((v = sym->binding) == UNBOUND) lerror("eval: error: variable %s has no value\n", sym->name); return v; } if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100)) lerror("eval: error: stack overflow\n"); saveSP = SP; PUSH(e); PUSH(*penv); f = eval(car_(e), penv); *penv = Stack[saveSP+1]; if (isbuiltin(f)) { // handle builtin function if (!isspecial(f)) { // evaluate argument list, placing arguments on stack v = Stack[saveSP] = cdr_(Stack[saveSP]); while (iscons(v)) { v = eval(car_(v), penv); *penv = Stack[saveSP+1]; PUSH(v); v = Stack[saveSP] = cdr_(Stack[saveSP]); } } apply_builtin: nargs = SP - saveSP - 2; switch (intval(f)) { // special forms case F_QUOTE: v = cdr_(Stack[saveSP]); if (!iscons(v)) lerror("quote: error: expected argument\n"); v = car_(v); break; case F_MACRO: case F_LAMBDA: v = Stack[saveSP]; if (*penv != NIL) { // build a closure (lambda args body . env) v = cdr_(v); PUSH(car(v)); argsyms = &Stack[SP-1]; PUSH(car(cdr_(v))); body = &Stack[SP-1]; v = cons_(intval(f)==F_LAMBDA ? &LAMBDA : &MACRO, cons(argsyms, cons(body, penv))); } break; case F_LABEL: v = Stack[saveSP]; if (*penv != NIL) { v = cdr_(v); PUSH(car(v)); // name pv = &Stack[SP-1]; PUSH(car(cdr_(v))); // function body = &Stack[SP-1]; *body = eval(*body, penv); // evaluate lambda v = cons_(&LABEL, cons(pv, cons(body, &NIL))); } break; case F_IF: v = car(cdr_(Stack[saveSP])); if (eval(v, penv) != NIL) v = car(cdr_(cdr_(Stack[saveSP]))); else v = car(cdr(cdr_(cdr_(Stack[saveSP])))); tail_eval(v, Stack[saveSP+1]); break; case F_COND: Stack[saveSP] = cdr_(Stack[saveSP]); pv = &Stack[saveSP]; v = NIL; while (iscons(*pv)) { c = tocons(car_(*pv), "cond"); v = eval(c->car, penv); *penv = Stack[saveSP+1]; if (v != NIL) { *pv = cdr_(car_(*pv)); // evaluate body forms if (iscons(*pv)) { while (iscons(cdr_(*pv))) { v = eval(car_(*pv), penv); *penv = Stack[saveSP+1]; *pv = cdr_(*pv); } tail_eval(car_(*pv), *penv); } break; } *pv = cdr_(*pv); } break; case F_AND: Stack[saveSP] = cdr_(Stack[saveSP]); pv = &Stack[saveSP]; v = T; if (iscons(*pv)) { while (iscons(cdr_(*pv))) { if ((v=eval(car_(*pv), penv)) == NIL) { SP = saveSP; return NIL; } *penv = Stack[saveSP+1]; *pv = cdr_(*pv); } tail_eval(car_(*pv), *penv); } break; case F_OR: Stack[saveSP] = cdr_(Stack[saveSP]); pv = &Stack[saveSP]; v = NIL; if (iscons(*pv)) { while (iscons(cdr_(*pv))) { if ((v=eval(car_(*pv), penv)) != NIL) { SP = saveSP; return v; } *penv = Stack[saveSP+1]; *pv = cdr_(*pv); } tail_eval(car_(*pv), *penv); } break; case F_WHILE: PUSH(cdr(cdr_(Stack[saveSP]))); body = &Stack[SP-1]; PUSH(*body); Stack[saveSP] = car_(cdr_(Stack[saveSP])); value_t *cond = &Stack[saveSP]; PUSH(NIL); pv = &Stack[SP-1]; while (eval(*cond, penv) != NIL) { *penv = Stack[saveSP+1]; *body = Stack[SP-2]; while (iscons(*body)) { *pv = eval(car_(*body), penv); *penv = Stack[saveSP+1]; *body = cdr_(*body); } } v = *pv; break; case F_PROGN: // return last arg Stack[saveSP] = cdr_(Stack[saveSP]); pv = &Stack[saveSP]; v = NIL; if (iscons(*pv)) { while (iscons(cdr_(*pv))) { v = eval(car_(*pv), penv); *penv = Stack[saveSP+1]; *pv = cdr_(*pv); } tail_eval(car_(*pv), *penv); } break; // ordinary functions case F_SET: argcount("set", nargs, 2); e = Stack[SP-2]; v = *penv; while (iscons(v)) { bind = car_(v); if (iscons(bind) && car_(bind) == e) { cdr_(bind) = (v=Stack[SP-1]); SP=saveSP; return v; } v = cdr_(v); } tosymbol(e, "set")->binding = (v=Stack[SP-1]); break; case F_BOUNDP: argcount("boundp", nargs, 1); sym = tosymbol(Stack[SP-1], "boundp"); if (sym->binding == UNBOUND && sym->constant == UNBOUND) v = NIL; else v = T; break; case F_EQ: argcount("eq", nargs, 2); v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL); break; case F_CONS: argcount("cons", nargs, 2); v = mk_cons(); car_(v) = Stack[SP-2]; cdr_(v) = Stack[SP-1]; break; case F_CAR: argcount("car", nargs, 1); v = car(Stack[SP-1]); break; case F_CDR: argcount("cdr", nargs, 1); v = cdr(Stack[SP-1]); break; case F_RPLACA: argcount("rplaca", nargs, 2); car(v=Stack[SP-2]) = Stack[SP-1]; break; case F_RPLACD: argcount("rplacd", nargs, 2); cdr(v=Stack[SP-2]) = Stack[SP-1]; break; case F_ATOM: argcount("atom", nargs, 1); v = ((!iscons(Stack[SP-1])) ? T : NIL); break; case F_SYMBOLP: argcount("symbolp", nargs, 1); v = ((issymbol(Stack[SP-1])) ? T : NIL); break; case F_NUMBERP: argcount("numberp", nargs, 1); v = ((isnumber(Stack[SP-1])) ? T : NIL); break; case F_ADD: s = 0; for (i=saveSP+2; i < (int)SP; i++) { n = tonumber(Stack[i], "+"); s += n; } v = number(s); break; case F_SUB: if (nargs < 1) lerror("-: error: too few arguments\n"); i = saveSP+2; s = (nargs==1) ? 0 : tonumber(Stack[i++], "-"); for (; i < (int)SP; i++) { n = tonumber(Stack[i], "-"); s -= n; } v = number(s); break; case F_MUL: s = 1; for (i=saveSP+2; i < (int)SP; i++) { n = tonumber(Stack[i], "*"); s *= n; } v = number(s); break; case F_DIV: if (nargs < 1) lerror("/: error: too few arguments\n"); i = saveSP+2; s = (nargs==1) ? 1 : tonumber(Stack[i++], "/"); for (; i < (int)SP; i++) { n = tonumber(Stack[i], "/"); if (n == 0) lerror("/: error: division by zero\n"); s /= n; } v = number(s); break; case F_LT: argcount("<", nargs, 2); if (tonumber(Stack[SP-2],"<") < tonumber(Stack[SP-1],"<")) v = T; else v = NIL; break; case F_NOT: argcount("not", nargs, 1); v = ((Stack[SP-1] == NIL) ? T : NIL); break; case F_EVAL: argcount("eval", nargs, 1); v = Stack[SP-1]; tail_eval(v, NIL); break; case F_PRINT: for (i=saveSP+2; i < (int)SP; i++) print(stdout, v=Stack[i]); break; case F_READ: argcount("read", nargs, 0); v = read_sexpr(stdin); break; case F_LOAD: argcount("load", nargs, 1); v = load_file(tosymbol(Stack[SP-1], "load")->name); break; case F_PROG1: // return first arg if (nargs < 1) lerror("prog1: error: too few arguments\n"); v = Stack[saveSP+2]; break; case F_APPLY: argcount("apply", nargs, 2); v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist f = Stack[SP-2]; // first arg is new function POPN(2); // pop apply's args if (isbuiltin(f)) { if (isspecial(f)) lerror("apply: error: cannot apply special operator " "%s\n", builtin_names[intval(f)]); // unpack arglist onto the stack while (iscons(v)) { PUSH(car_(v)); v = cdr_(v); } goto apply_builtin; } noeval = 1; goto apply_lambda; } SP = saveSP; return v; } else { v = Stack[saveSP] = cdr_(Stack[saveSP]); } apply_lambda: if (iscons(f)) { headsym = car_(f); if (headsym == LABEL) { // (label name (lambda ...)) behaves the same as the lambda // alone, except with name bound to the whole label expression labl = f; f = car(cdr(cdr_(labl))); headsym = car(f); } // apply lambda or macro expression PUSH(cdr(cdr(cdr_(f)))); lenv = &Stack[SP-1]; PUSH(car_(cdr_(f))); argsyms = &Stack[SP-1]; PUSH(car_(cdr_(cdr_(f)))); body = &Stack[SP-1]; if (labl) { // add label binding to environment PUSH(labl); PUSH(car_(cdr_(labl))); *lenv = cons_(cons(&Stack[SP-1], &Stack[SP-2]), lenv); POPN(3); v = Stack[saveSP]; // refetch arglist } if (headsym == MACRO) noeval = 1; else if (headsym != LAMBDA) lerror("apply: error: head must be lambda, macro, or label\n"); // build a calling environment for the lambda // the environment is the argument binds on top of the captured // environment while (iscons(v)) { // bind args if (!iscons(*argsyms)) { if (*argsyms == NIL) lerror("apply: error: too many arguments\n"); break; } asym = car_(*argsyms); if (!issymbol(asym)) lerror("apply: error: formal argument not a symbol\n"); v = car_(v); if (!noeval) { v = eval(v, penv); *penv = Stack[saveSP+1]; } PUSH(v); *lenv = cons_(cons(&asym, &Stack[SP-1]), lenv); POPN(2); *argsyms = cdr_(*argsyms); v = Stack[saveSP] = cdr_(Stack[saveSP]); } if (*argsyms != NIL) { if (issymbol(*argsyms)) { if (noeval) { *lenv = cons_(cons(argsyms, &Stack[saveSP]), lenv); } else { PUSH(NIL); PUSH(NIL); rest = &Stack[SP-1]; // build list of rest arguments // we have to build it forwards, which is tricky while (iscons(v)) { v = eval(car_(v), penv); *penv = Stack[saveSP+1]; PUSH(v); v = cons_(&Stack[SP-1], &NIL); POP(); if (iscons(*rest)) cdr_(*rest) = v; else Stack[SP-2] = v; *rest = v; v = Stack[saveSP] = cdr_(Stack[saveSP]); } *lenv = cons_(cons(argsyms, &Stack[SP-2]), lenv); } } else if (iscons(*argsyms)) { lerror("apply: error: too few arguments\n"); } } noeval = 0; // macro: evaluate expansion in the calling environment if (headsym == MACRO) { SP = saveSP; PUSH(*lenv); lenv = &Stack[SP-1]; v = eval(*body, lenv); tail_eval(v, *penv); } else { tail_eval(*body, *lenv); } // not reached } type_error("apply", "function", f); return NIL; }
static int indentafter3(value_t head, value_t v) { // for certain X always indent (X a b c) after b return ((head == forsym) && !allsmallp(cdr_(v))); }
// *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; }
// 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); }
static int indentafter2(fl_context_t *fl_ctx, value_t head, value_t v) { // for certain X always indent (X a b) after a return ((head == fl_ctx->definesym || head == fl_ctx->defmacrosym) && !allsmallp(fl_ctx, cdr_(v))); }
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 int indentafter3(fl_context_t *fl_ctx, value_t head, value_t v) { // for certain X always indent (X a b c) after b return ((head == fl_ctx->forsym) && !allsmallp(fl_ctx, cdr_(v))); }
int32 length(List *l) { int32 i = 0; for (; l != NULL; l = cdr_(l)) i++; return i; }
// 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: #ifdef MEMDEBUG2 v = fl_list2(*head, NIL); #else v = cons_reserve(2); car_(v) = *head; cdr_(v) = tagptr(((cons_t*)ptr(v))+1, TAG_CONS); car_(cdr_(v)) = cdr_(cdr_(v)) = NIL; #endif 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; }
// parse and eval a whole file, possibly reading from a string (`content`) jl_value_t *jl_parse_eval_all(const char *fname, const char *content, size_t contentlen) { if (in_pure_callback) jl_error("cannot use include inside a generated function"); jl_ast_context_t *ctx = jl_ast_ctx_enter(); fl_context_t *fl_ctx = &ctx->fl; value_t f, ast; size_t len = strlen(fname); f = cvalue_static_cstrn(fl_ctx, fname, len); fl_gc_handle(fl_ctx, &f); if (content != NULL) { value_t t = cvalue_static_cstrn(fl_ctx, content, contentlen); fl_gc_handle(fl_ctx, &t); ast = fl_applyn(fl_ctx, 2, symbol_value(symbol(fl_ctx, "jl-parse-string-stream")), t, f); fl_free_gc_handles(fl_ctx, 1); } else { assert(memchr(fname, 0, len) == NULL); // was checked already in jl_load ast = fl_applyn(fl_ctx, 1, symbol_value(symbol(fl_ctx, "jl-parse-file")), f); } fl_free_gc_handles(fl_ctx, 1); if (ast == fl_ctx->F) { jl_ast_ctx_leave(ctx); jl_errorf("could not open file %s", fname); } fl_gc_handle(fl_ctx, &ast); int last_lineno = jl_lineno; const char *last_filename = jl_filename; jl_lineno = 0; jl_filename = fname; jl_array_t *roots = NULL; jl_array_t **old_roots = ctx->roots; ctx->roots = &roots; jl_value_t *form=NULL, *result=jl_nothing; int err = 0; JL_GC_PUSH3(&roots, &form, &result); JL_TRY { assert(iscons(ast) && car_(ast) == symbol(fl_ctx,"toplevel")); ast = cdr_(ast); while (iscons(ast)) { value_t expansion = fl_applyn(fl_ctx, 1, symbol_value(symbol(fl_ctx, "jl-expand-to-thunk")), car_(ast)); form = scm_to_julia(fl_ctx, expansion, 0); jl_sym_t *head = NULL; if (jl_is_expr(form)) head = ((jl_expr_t*)form)->head; JL_SIGATOMIC_END(); if (head == jl_incomplete_sym) jl_errorf("syntax: %s", jl_string_data(jl_exprarg(form,0))); else if (head == error_sym) jl_interpret_toplevel_expr(form); else if (head == line_sym) jl_lineno = jl_unbox_long(jl_exprarg(form,0)); else if (jl_is_linenode(form)) jl_lineno = jl_linenode_line(form); else result = jl_toplevel_eval_flex(form, 1, 1); JL_SIGATOMIC_BEGIN(); ast = cdr_(ast); } } JL_CATCH { form = jl_pchar_to_string(fname, len); result = jl_box_long(jl_lineno); err = 1; } jl_lineno = last_lineno; jl_filename = last_filename; fl_free_gc_handles(fl_ctx, 1); ctx->roots = old_roots; jl_ast_ctx_leave(ctx); if (err) { if (jl_loaderror_type == NULL) jl_rethrow(); else jl_rethrow_other(jl_new_struct(jl_loaderror_type, form, result, jl_exception_in_transit)); } JL_GC_POP(); return result; }
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; }