value_t fl_invoke_julia_macro(fl_context_t *fl_ctx, value_t *args, uint32_t nargs) { if (nargs < 1) argcount(fl_ctx, "invoke-julia-macro", nargs, 1); jl_lambda_info_t *mfunc = NULL; jl_value_t **margs; // Reserve one more slot for the result JL_GC_PUSHARGS(margs, nargs + 1); int i; for(i=1; i < nargs; i++) margs[i] = scm_to_julia(fl_ctx, args[i], 1); jl_value_t *result = NULL; JL_TRY { margs[0] = scm_to_julia(fl_ctx, args[0], 1); margs[0] = jl_toplevel_eval(margs[0]); mfunc = jl_method_lookup(jl_gf_mtable(margs[0]), margs, nargs, 1); if (mfunc == NULL) { JL_GC_POP(); jl_method_error((jl_function_t*)margs[0], margs, nargs); // unreachable } margs[nargs] = result = jl_call_method_internal(mfunc, margs, nargs); } JL_CATCH { JL_GC_POP(); value_t opaque = cvalue(fl_ctx, jl_ast_ctx(fl_ctx)->jvtype, sizeof(void*)); *(jl_value_t**)cv_data((cvalue_t*)ptr(opaque)) = jl_exception_in_transit; return fl_list2(fl_ctx, jl_ast_ctx(fl_ctx)->error_sym, opaque); } // protect result from GC, otherwise it could be freed during future // macro expansions, since it will be referenced only from scheme and // not julia. // all calls to invoke-julia-macro happen under `jl_macroexpand`, // `jl_expand` or `jl_parse_eval_all` so the preserved array is rooted there. assert(result != NULL); jl_ast_preserve(fl_ctx, result); value_t scm = julia_to_scm(fl_ctx, result); fl_gc_handle(fl_ctx, &scm); value_t scmresult; jl_module_t *defmod = mfunc->def->module; if (defmod == NULL || defmod == jl_current_module) { scmresult = fl_cons(fl_ctx, scm, fl_ctx->F); } else { value_t opaque = cvalue(fl_ctx, jl_ast_ctx(fl_ctx)->jvtype, sizeof(void*)); *(jl_value_t**)cv_data((cvalue_t*)ptr(opaque)) = (jl_value_t*)defmod; scmresult = fl_cons(fl_ctx, scm, opaque); } fl_free_gc_handles(fl_ctx, 1); JL_GC_POP(); return scmresult; }
static value_t julia_to_scm_(fl_context_t *fl_ctx, jl_value_t *v) { if (jl_is_symbol(v)) return symbol(fl_ctx, jl_symbol_name((jl_sym_t*)v)); if (v == jl_true) return jl_ast_ctx(fl_ctx)->true_sym; if (v == jl_false) return jl_ast_ctx(fl_ctx)->false_sym; if (v == jl_nothing) return fl_cons(fl_ctx, jl_ast_ctx(fl_ctx)->null_sym, fl_ctx->NIL); if (jl_is_expr(v)) { jl_expr_t *ex = (jl_expr_t*)v; value_t args = fl_ctx->NIL; fl_gc_handle(fl_ctx, &args); array_to_list(fl_ctx, ex->args, &args); value_t hd = julia_to_scm_(fl_ctx, (jl_value_t*)ex->head); if (ex->head == lambda_sym && jl_expr_nargs(ex)>0 && jl_is_array(jl_exprarg(ex,0))) { value_t llist = fl_ctx->NIL; fl_gc_handle(fl_ctx, &llist); array_to_list(fl_ctx, (jl_array_t*)jl_exprarg(ex,0), &llist); car_(args) = llist; fl_free_gc_handles(fl_ctx, 1); } value_t scmv = fl_cons(fl_ctx, hd, args); fl_free_gc_handles(fl_ctx, 1); return scmv; } // GC Note: jl_fieldref(v, 0) allocate for LabelNode, GotoNode // but we don't need a GC root here because julia_to_list2 // shouldn't allocate in this case. if (jl_typeis(v, jl_labelnode_type)) return julia_to_list2(fl_ctx, (jl_value_t*)label_sym, jl_fieldref(v,0)); if (jl_typeis(v, jl_linenumbernode_type)) return julia_to_list2(fl_ctx, (jl_value_t*)line_sym, jl_fieldref(v,0)); if (jl_typeis(v, jl_gotonode_type)) return julia_to_list2(fl_ctx, (jl_value_t*)goto_sym, jl_fieldref(v,0)); if (jl_typeis(v, jl_quotenode_type)) return julia_to_list2(fl_ctx, (jl_value_t*)inert_sym, jl_fieldref(v,0)); if (jl_typeis(v, jl_newvarnode_type)) return julia_to_list2(fl_ctx, (jl_value_t*)newvar_sym, jl_fieldref(v,0)); if (jl_is_long(v) && fits_fixnum(jl_unbox_long(v))) return fixnum(jl_unbox_long(v)); if (jl_is_ssavalue(v)) jl_error("SSAValue objects should not occur in an AST"); if (jl_is_slot(v)) jl_error("Slot objects should not occur in an AST"); value_t opaque = cvalue(fl_ctx, jl_ast_ctx(fl_ctx)->jvtype, sizeof(void*)); *(jl_value_t**)cv_data((cvalue_t*)ptr(opaque)) = v; return opaque; }
static void jl_init_ast_ctx(jl_ast_context_t *ast_ctx) { fl_context_t *fl_ctx = &ast_ctx->fl; fl_init(fl_ctx, 4*1024*1024); if (fl_load_system_image_str(fl_ctx, (char*)flisp_system_image, sizeof(flisp_system_image))) { jl_error("fatal error loading system image"); } fl_applyn(fl_ctx, 0, symbol_value(symbol(fl_ctx, "__init_globals"))); jl_ast_context_t *ctx = jl_ast_ctx(fl_ctx); ctx->jvtype = define_opaque_type(fl_ctx->jl_sym, sizeof(void*), NULL, NULL); assign_global_builtins(fl_ctx, julia_flisp_ast_ext); ctx->true_sym = symbol(fl_ctx, "true"); ctx->false_sym = symbol(fl_ctx, "false"); ctx->error_sym = symbol(fl_ctx, "error"); ctx->null_sym = symbol(fl_ctx, "null"); ctx->ssavalue_sym = symbol(fl_ctx, "ssavalue"); ctx->slot_sym = symbol(fl_ctx, "slot"); ctx->task = NULL; ctx->module = NULL; set(symbol(fl_ctx, "*depwarn-opt*"), fixnum(jl_options.depwarn)); }
static void jl_init_ast_ctx(jl_ast_context_t *ast_ctx) { fl_context_t *fl_ctx = &ast_ctx->fl; fl_init(fl_ctx, 4*1024*1024); if (fl_load_system_image_str(fl_ctx, (char*)flisp_system_image, sizeof(flisp_system_image))) { jl_error("fatal error loading system image"); } fl_applyn(fl_ctx, 0, symbol_value(symbol(fl_ctx, "__init_globals"))); jl_ast_ctx(fl_ctx)->jvtype = define_opaque_type(fl_ctx->jl_sym, sizeof(void*), NULL, NULL); assign_global_builtins(fl_ctx, julia_flisp_ast_ext); jl_ast_ctx(fl_ctx)->true_sym = symbol(fl_ctx, "true"); jl_ast_ctx(fl_ctx)->false_sym = symbol(fl_ctx, "false"); jl_ast_ctx(fl_ctx)->error_sym = symbol(fl_ctx, "error"); jl_ast_ctx(fl_ctx)->null_sym = symbol(fl_ctx, "null"); jl_ast_ctx(fl_ctx)->ssavalue_sym = symbol(fl_ctx, "ssavalue"); jl_ast_ctx(fl_ctx)->slot_sym = symbol(fl_ctx, "slot"); // Enable / disable syntax deprecation warnings if (jl_options.depwarn == JL_OPTIONS_DEPWARN_ERROR) jl_parse_deperror(fl_ctx, 1); else jl_parse_depwarn_(fl_ctx, (int)jl_options.depwarn); }
static value_t julia_to_scm(fl_context_t *fl_ctx, jl_value_t *v) { value_t temp; // need try/catch to reset GC handle stack in case of error FL_TRY_EXTERN(fl_ctx) { temp = julia_to_scm_(fl_ctx, v); } FL_CATCH_EXTERN(fl_ctx) { temp = fl_list2(fl_ctx, jl_ast_ctx(fl_ctx)->error_sym, cvalue_static_cstring(fl_ctx, "expression too large")); } return temp; }
static void jl_ast_preserve(fl_context_t *fl_ctx, jl_value_t *obj) { jl_ast_context_t *ctx = jl_ast_ctx(fl_ctx); assert(ctx->roots); jl_array_t *roots = *ctx->roots; if (!roots) { roots = *ctx->roots = jl_alloc_vec_any(1); jl_array_ptr_set(roots, 0, obj); } else { jl_array_ptr_1d_push(roots, obj); } }
value_t fl_defined_julia_global(fl_context_t *fl_ctx, value_t *args, uint32_t nargs) { jl_ast_context_t *ctx = jl_ast_ctx(fl_ctx); // tells whether a var is defined in and *by* the current module argcount(fl_ctx, "defined-julia-global", nargs, 1); jl_module_t *mod = ctx->module; jl_sym_t *sym = (jl_sym_t*)scm_to_julia(fl_ctx, args[0], mod); if (jl_is_globalref(sym)) { mod = jl_globalref_mod(sym); sym = jl_globalref_name(sym); } if (!jl_is_symbol(sym)) type_error(fl_ctx, "defined-julia-global", "symbol", args[0]); if (!mod) return fl_ctx->F; jl_binding_t *b = (jl_binding_t*)ptrhash_get(&mod->bindings, sym); return (b != HT_NOTFOUND && b->owner == mod) ? fl_ctx->T : fl_ctx->F; }
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"); }
value_t fl_current_module_counter(fl_context_t *fl_ctx, value_t *args, uint32_t nargs) { jl_ast_context_t *ctx = jl_ast_ctx(fl_ctx); assert(ctx->module); return fixnum(jl_module_next_counter(ctx->module)); }
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; }
value_t fl_current_julia_module(fl_context_t *fl_ctx, value_t *args, uint32_t nargs) { value_t opaque = cvalue(fl_ctx, jl_ast_ctx(fl_ctx)->jvtype, sizeof(void*)); *(jl_value_t**)cv_data((cvalue_t*)ptr(opaque)) = (jl_value_t*)jl_current_module; return opaque; }