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 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(fl_null_sym, FL_NIL);
}
if (jl_is_expr(v)) {
jl_expr_t *ex = (jl_expr_t*)v;
value_t args = FL_NIL;
fl_gc_handle(&args);
array_to_list(ex->args, &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;
}
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 void global_env_list(symbol_t *root, value_t *pv)
{
while (root != NULL) {
if (root->name[0] != ':' && (root->binding != UNBOUND)) {
*pv = fl_cons(tagptr(root,TAG_SYM), *pv);
}
global_env_list(root->left, pv);
root = root->right;
}
}
static void array_to_list(fl_context_t *fl_ctx, jl_array_t *a, value_t *pv)
{
if (jl_array_len(a) > 300000)
lerror(fl_ctx, symbol(fl_ctx, "error"), "expression too large");
value_t temp;
for(long i=jl_array_len(a)-1; i >= 0; i--) {
*pv = fl_cons(fl_ctx, fl_ctx->NIL, *pv);
temp = julia_to_scm_(fl_ctx, jl_array_ptr_ref(a,i));
// note: must be separate statement
car_(*pv) = temp;
}
}
static void array_to_list(jl_array_t *a, value_t *pv)
{
if (jl_array_len(a) > 300000)
lerror(MemoryError, "expression too large");
value_t temp;
for(long i=jl_array_len(a)-1; i >= 0; i--) {
*pv = fl_cons(FL_NIL, *pv);
temp = julia_to_scm_(jl_cellref(a,i));
// note: must be separate statement
car_(*pv) = temp;
}
}
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;
}
JL_DLLEXPORT void jl_lisp_prompt(void)
{
// Make `--lisp` sigatomic in order to avoid triggering the sigint safepoint.
// We don't have our signal handler registered in that case anyway...
JL_SIGATOMIC_BEGIN();
jl_init_frontend();
jl_ast_context_t *ctx = jl_ast_ctx_enter();
JL_AST_PRESERVE_PUSH(ctx, old_roots, jl_main_module);
fl_context_t *fl_ctx = &ctx->fl;
fl_applyn(fl_ctx, 1, symbol_value(symbol(fl_ctx, "__start")), fl_cons(fl_ctx, fl_ctx->NIL,fl_ctx->NIL));
JL_AST_PRESERVE_POP(ctx, old_roots);
jl_ast_ctx_leave(ctx);
}
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;
}
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;
}
// 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;
}
DLLEXPORT void jl_lisp_prompt(void)
{
fl_applyn(1, symbol_value(symbol("__start")), fl_cons(FL_NIL,FL_NIL));
}
DLLEXPORT void jl_lisp_prompt(void)
{
if (jvtype==NULL) jl_init_frontend();
fl_applyn(1, symbol_value(symbol("__start")), fl_cons(FL_NIL,FL_NIL));
}
