static value_t argv_list(int argc, char *argv[])
{
int i;
value_t lst=FL_NIL, temp;
fl_gc_handle(&lst);
fl_gc_handle(&temp);
for(i=argc-1; i >= 0; i--) {
temp = cvalue_static_cstring(argv[i]);
lst = fl_cons(temp, lst);
}
fl_free_gc_handles(2);
return lst;
}
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 argv_list(fl_context_t *fl_ctx, int argc, char *argv[])
{
int i;
value_t lst=fl_ctx->NIL, temp;
fl_gc_handle(fl_ctx, &lst);
fl_gc_handle(fl_ctx, &temp);
for(i=argc-1; i >= 0; i--) {
temp = cvalue_static_cstring(fl_ctx, argv[i]);
lst = fl_cons(fl_ctx, temp, lst);
}
fl_free_gc_handles(fl_ctx, 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;
}
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 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;
}
value_t fl_global_env(value_t *args, u_int32_t nargs)
{
(void)args;
argcount("environment", nargs, 0);
value_t lst = FL_NIL;
fl_gc_handle(&lst);
global_env_list(symtab, &lst);
fl_free_gc_handles(1);
return lst;
}
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 (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 fl_cons(julia_to_scm((jl_value_t*)line_sym),
fl_cons(julia_to_scm(jl_fieldref(v,0)),
FL_NIL));
}
if (jl_typeis(v, jl_labelnode_type)) {
return fl_cons(julia_to_scm((jl_value_t*)label_sym),
fl_cons(julia_to_scm(jl_fieldref(v,0)),
FL_NIL));
}
if (jl_typeis(v, jl_gotonode_type)) {
return fl_cons(julia_to_scm((jl_value_t*)goto_sym),
fl_cons(julia_to_scm(jl_fieldref(v,0)),
FL_NIL));
}
if (jl_typeis(v, jl_quotenode_type)) {
return fl_cons(julia_to_scm((jl_value_t*)quote_sym),
fl_cons(julia_to_scm(jl_fieldref(v,0)),
FL_NIL));
}
if (jl_typeis(v, jl_topnode_type)) {
return fl_cons(julia_to_scm((jl_value_t*)top_sym),
fl_cons(julia_to_scm(jl_fieldref(v,0)),
FL_NIL));
}
if (jl_is_long(v) && fits_fixnum(jl_unbox_long(v))) {
return fixnum(jl_unbox_long(v));
}
if (jl_typeis(v,jl_array_any_type)) {
return array_to_list((jl_array_t*)v);
}
value_t opaque = cvalue(jvtype, sizeof(void*));
*(jl_value_t**)cv_data((cvalue_t*)ptr(opaque)) = v;
return opaque;
}
jl_value_t *jl_load_file_string(const char *text, char *filename)
{
value_t t, f;
t = cvalue_static_cstring(text);
fl_gc_handle(&t);
f = cvalue_static_cstring(filename);
fl_applyn(2, symbol_value(symbol("jl-parse-string-stream")),
t, f);
fl_free_gc_handles(1);
return jl_parse_eval_all(filename);
}
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;
}
int main(int argc, char *argv[])
{
char fname_buf[1024];
fl_context_t *fl_ctx = &fl_global_ctx;
fl_init(fl_ctx, 512*1024);
fname_buf[0] = '\0';
value_t str = symbol_value(symbol(fl_ctx, "*install-dir*"));
char *exedir = (char*)(str == UNBOUND ? NULL : cvalue_data(str));
if (exedir != NULL) {
strcat(fname_buf, exedir);
strcat(fname_buf, PATHSEPSTRING);
}
strcat(fname_buf, "flisp.boot");
value_t args[2];
fl_gc_handle(fl_ctx, &args[0]);
fl_gc_handle(fl_ctx, &args[1]);
FL_TRY_EXTERN(fl_ctx) {
args[0] = cvalue_static_cstring(fl_ctx, fname_buf);
args[1] = symbol(fl_ctx, ":read");
value_t f = fl_file(fl_ctx, &args[0], 2);
fl_free_gc_handles(fl_ctx, 2);
if (fl_load_system_image(fl_ctx, f))
return 1;
(void)fl_applyn(fl_ctx, 1, symbol_value(symbol(fl_ctx, "__start")),
argv_list(fl_ctx, argc, argv));
}
FL_CATCH_EXTERN(fl_ctx) {
ios_puts("fatal error:\n", ios_stderr);
fl_print(fl_ctx, ios_stderr, fl_ctx->lasterror);
ios_putc('\n', ios_stderr);
return 1;
}
return 0;
}
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;
}
value_t fl_read_sexpr(value_t f)
{
value_t v;
fl_readstate_t state;
state.prev = readstate;
htable_new(&state.backrefs, 8);
htable_new(&state.gensyms, 8);
state.source = f;
readstate = &state;
assert(toktype == TOK_NONE);
fl_gc_handle(&tokval);
v = do_read_sexpr(UNBOUND);
fl_free_gc_handles(1);
readstate = state.prev;
free_readstate(&state);
return v;
}
// 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;
}
