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;
}
// returns either an expression or a thunk
jl_value_t *jl_expand(jl_value_t *expr)
{
int np = jl_gc_n_preserved_values();
value_t arg = julia_to_scm(expr);
value_t e = fl_applyn(1, symbol_value(symbol("jl-expand-to-thunk")), arg);
jl_value_t *result = scm_to_julia(e,0);
while (jl_gc_n_preserved_values() > np) {
jl_gc_unpreserve();
}
return result;
}
DLLEXPORT jl_value_t *jl_macroexpand(jl_value_t *expr)
{
int np = jl_gc_n_preserved_values();
value_t arg = julia_to_scm(expr);
value_t e = fl_applyn(1, symbol_value(symbol("jl-macroexpand")), arg);
jl_value_t *result;
result = scm_to_julia(e);
while (jl_gc_n_preserved_values() > np) {
jl_gc_unpreserve();
}
return result;
}
// returns either an expression or a thunk
jl_value_t *jl_call_scm_on_ast(const char *funcname, jl_value_t *expr, jl_module_t *inmodule)
{
jl_ast_context_t *ctx = jl_ast_ctx_enter();
fl_context_t *fl_ctx = &ctx->fl;
JL_AST_PRESERVE_PUSH(ctx, old_roots, inmodule);
value_t arg = julia_to_scm(fl_ctx, expr);
value_t e = fl_applyn(fl_ctx, 1, symbol_value(symbol(fl_ctx, funcname)), arg);
jl_value_t *result = scm_to_julia(fl_ctx, e, inmodule);
JL_AST_PRESERVE_POP(ctx, old_roots);
jl_ast_ctx_leave(ctx);
return result;
}
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 array_to_list(jl_array_t *a)
{
long i;
value_t lst=FL_NIL, temp=FL_NIL;
fl_gc_handle(&lst);
fl_gc_handle(&temp);
for(i=jl_array_len(a)-1; i >= 0; i--) {
temp = julia_to_scm(jl_cellref(a,i));
lst = fl_cons(temp, lst);
}
fl_free_gc_handles(2);
return lst;
}
static value_t array_to_list(jl_array_t *a)
{
if (jl_array_len(a) > 300000)
jl_error("expression too large");
value_t lst=FL_NIL, temp=FL_NIL;
fl_gc_handle(&lst);
fl_gc_handle(&temp);
for(long i=jl_array_len(a)-1; i >= 0; i--) {
temp = julia_to_scm(jl_cellref(a,i));
lst = fl_cons(temp, lst);
}
fl_free_gc_handles(2);
return lst;
}
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;
}
static value_t julia_to_scm(jl_value_t *v)
{
if (jl_is_symbol(v)) {
return symbol(((jl_sym_t*)v)->name);
}
if (v == jl_true) {
return FL_T;
}
if (v == jl_false) {
return FL_F;
}
if (v == jl_nothing) {
return fl_cons(symbol("null"), FL_NIL);
}
if (jl_is_expr(v)) {
jl_expr_t *ex = (jl_expr_t*)v;
value_t args = array_to_list(ex->args);
fl_gc_handle(&args);
value_t hd = julia_to_scm((jl_value_t*)ex->head);
value_t scmv = fl_cons(hd, args);
fl_free_gc_handles(1);
return scmv;
}
if (jl_typeis(v, jl_linenumbernode_type)) {
return julia_to_list2((jl_value_t*)line_sym, jl_fieldref(v,0));
}
if (jl_typeis(v, jl_labelnode_type)) {
return julia_to_list2((jl_value_t*)label_sym, jl_fieldref(v,0));
}
if (jl_typeis(v, jl_gotonode_type)) {
return julia_to_list2((jl_value_t*)goto_sym, jl_fieldref(v,0));
}
if (jl_typeis(v, jl_quotenode_type)) {
return julia_to_list2((jl_value_t*)quote_sym, jl_fieldref(v,0));
}
if (jl_typeis(v, jl_newvarnode_type)) {
return julia_to_list2((jl_value_t*)newvar_sym, jl_fieldref(v,0));
}
if (jl_typeis(v, jl_topnode_type)) {
return julia_to_list2((jl_value_t*)top_sym, jl_fieldref(v,0));
}
if (jl_is_long(v) && fits_fixnum(jl_unbox_long(v))) {
return fixnum(jl_unbox_long(v));
}
value_t opaque = cvalue(jvtype, sizeof(void*));
*(jl_value_t**)cv_data((cvalue_t*)ptr(opaque)) = v;
return opaque;
}
// returns either an expression or a thunk
jl_value_t *jl_expand(jl_value_t *expr)
{
int np = jl_gc_n_preserved_values();
value_t arg = julia_to_scm(expr);
value_t e = fl_applyn(1, symbol_value(symbol("jl-expand-to-thunk")), arg);
jl_value_t *result;
if (e == FL_T || e == FL_F || e == FL_EOF) {
result = NULL;
}
else {
result = scm_to_julia(e);
}
while (jl_gc_n_preserved_values() > np) {
jl_gc_unpreserve();
}
return result;
}
value_t fl_invoke_julia_macro(value_t *args, uint32_t nargs)
{
if (nargs < 1)
argcount("invoke-julia-macro", nargs, 1);
(void)tosymbol(args[0], "invoke-julia-macro");
jl_sym_t *name = jl_symbol(symbol_name(args[0]));
jl_function_t *f = jl_get_expander(jl_current_module, name);
if (f == NULL)
return FL_F;
jl_value_t **margs;
int na = nargs-1;
if (na > 0)
margs = alloca(na * sizeof(jl_value_t*));
else
margs = NULL;
int i;
for(i=0; i < na; i++) margs[i] = NULL;
JL_GC_PUSHARGS(margs, na);
for(i=0; i < na; i++) margs[i] = scm_to_julia(args[i+1]);
jl_value_t *result;
JL_TRY {
result = jl_apply(f, margs, na);
}
JL_CATCH {
JL_GC_POP();
jl_show(jl_exception_in_transit);
ios_putc('\n', jl_current_output_stream());
return fl_cons(symbol("error"), FL_NIL);
}
// 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);
JL_GC_POP();
return scm;
}
// 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;
}
