fltype_t *get_array_type(value_t eltype) { fltype_t *et = get_type(eltype); if (et->artype != NULL) return et->artype; return get_type(fl_list2(arraysym, eltype)); }
static value_t fl_top_level_value(value_t *args, u_int32_t nargs) { argcount("top-level-value", nargs, 1); symbol_t *sym = tosymbol(args[0], "top-level-value"); if (sym->binding == UNBOUND) fl_raise(fl_list2(UnboundError, args[0])); return sym->binding; }
static value_t julia_to_list2(jl_value_t *a, jl_value_t *b) { value_t sa = julia_to_scm(a); fl_gc_handle(&sa); value_t sb = julia_to_scm(b); value_t l = fl_list2(sa, sb); fl_free_gc_handles(1); return l; }
static value_t julia_to_list2(fl_context_t *fl_ctx, jl_value_t *a, jl_value_t *b) { value_t sa = julia_to_scm_(fl_ctx, a); fl_gc_handle(fl_ctx, &sa); value_t sb = julia_to_scm_(fl_ctx, b); value_t l = fl_list2(fl_ctx, sa, sb); fl_free_gc_handles(fl_ctx, 1); return l; }
static value_t julia_to_scm(jl_value_t *v) { value_t temp; // need try/catch to reset GC handle stack in case of error FL_TRY_EXTERN { temp = julia_to_scm_(v); } FL_CATCH_EXTERN { temp = fl_list2(fl_error_sym, cvalue_static_cstring("expression too large")); } return temp; }
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; }
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; }
value_t fl_invoke_julia_macro(value_t *args, uint32_t nargs) { if (nargs < 1) argcount("invoke-julia-macro", nargs, 1); jl_function_t *f = NULL; jl_value_t **margs = alloca(nargs * sizeof(jl_value_t*)); int i; for(i=0; i < nargs; i++) margs[i] = NULL; JL_GC_PUSHARGS(margs, nargs); for(i=1; i < nargs; i++) margs[i] = scm_to_julia(args[i]); jl_value_t *result; JL_TRY { jl_register_toplevel_eh(); margs[0] = scm_to_julia(args[0]); f = (jl_function_t*)jl_toplevel_eval(margs[0]); result = jl_apply(f, &margs[1], nargs-1); } JL_CATCH { JL_GC_POP(); value_t opaque = cvalue(jvtype, sizeof(void*)); *(jl_value_t**)cv_data((cvalue_t*)ptr(opaque)) = jl_exception_in_transit; return fl_list2(symbol("error"), 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 a single call to jl_expand, // so the preserved value stack is popped there. jl_gc_preserve(result); value_t scm = julia_to_scm(result); fl_gc_handle(&scm); value_t scmresult; jl_module_t *defmod = f->linfo->module; if (defmod == jl_current_module) { scmresult = fl_cons(scm, FL_F); } else { value_t opaque = cvalue(jvtype, sizeof(void*)); *(jl_value_t**)cv_data((cvalue_t*)ptr(opaque)) = (jl_value_t*)defmod; scmresult = fl_cons(scm, opaque); } fl_free_gc_handles(1); JL_GC_POP(); return scmresult; }
// 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; }