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;
}
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);
}
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;
}
// this is for parsing one expression out of a string, keeping track of
// the current position.
JL_DLLEXPORT jl_value_t *jl_parse_string(const char *str, size_t len,
int pos0, int greedy)
{
JL_TIMING(PARSING);
if (pos0 < 0 || pos0 > len) {
jl_array_t *buf = jl_pchar_to_array(str, len);
JL_GC_PUSH1(&buf);
// jl_bounds_error roots the arguments.
jl_bounds_error((jl_value_t*)buf, jl_box_long(pos0));
}
jl_ast_context_t *ctx = jl_ast_ctx_enter();
fl_context_t *fl_ctx = &ctx->fl;
value_t s = cvalue_static_cstrn(fl_ctx, str, len);
value_t p = fl_applyn(fl_ctx, 3, symbol_value(symbol(fl_ctx, "jl-parse-one-string")),
s, fixnum(pos0), greedy?fl_ctx->T:fl_ctx->F);
jl_value_t *expr=NULL, *pos1=NULL;
JL_GC_PUSH2(&expr, &pos1);
value_t e = car_(p);
if (e == fl_ctx->FL_EOF)
expr = jl_nothing;
else
expr = scm_to_julia(fl_ctx, e, NULL);
pos1 = jl_box_long(tosize(fl_ctx, cdr_(p), "parse"));
jl_ast_ctx_leave(ctx);
jl_value_t *result = (jl_value_t*)jl_svec2(expr, pos1);
JL_GC_POP();
return result;
}
// this is used to parse a line of repl input
DLLEXPORT jl_value_t *jl_parse_input_line(const char *str)
{
value_t e = fl_applyn(1, symbol_value(symbol("jl-parse-string")),
cvalue_static_cstring(str));
if (e == FL_T || e == FL_F || e == FL_EOF)
return jl_nothing;
return scm_to_julia(e);
}
// this is used to parse a line of repl input
JL_DLLEXPORT jl_value_t *jl_parse_input_line(const char *str, size_t len, const char *filename, size_t filename_len)
{
jl_ast_context_t *ctx = jl_ast_ctx_enter();
fl_context_t *fl_ctx = &ctx->fl;
value_t s = cvalue_static_cstrn(fl_ctx, str, len);
value_t files = cvalue_static_cstrn(fl_ctx, filename, filename_len);
value_t e = fl_applyn(fl_ctx, 2, symbol_value(symbol(fl_ctx, "jl-parse-string")), s, files);
jl_value_t *res = e == fl_ctx->FL_EOF ? jl_nothing : scm_to_julia(fl_ctx, e, 0);
jl_ast_ctx_leave(ctx);
return res;
}
// 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;
}
// 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_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;
}
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);
}
// this is for parsing one expression out of a string, keeping track of
// the current position.
DLLEXPORT jl_value_t *jl_parse_string(const char *str, int pos0, int greedy)
{
value_t s = cvalue_static_cstring(str);
value_t p = fl_applyn(3, symbol_value(symbol("jl-parse-one-string")),
s, fixnum(pos0), greedy?FL_T:FL_F);
jl_value_t *expr=NULL, *pos1=NULL;
JL_GC_PUSH(&expr, &pos1);
value_t e = car_(p);
if (e == FL_T || e == FL_F || e == FL_EOF) {
expr = (jl_value_t*)jl_null;
}
else {
expr = scm_to_julia(e);
}
pos1 = jl_box_long(toulong(cdr_(p),"parse"));
jl_value_t *result = (jl_value_t*)jl_tuple2(expr, pos1);
JL_GC_POP();
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;
}
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;
}
// 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;
}
// 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;
}
