static void print_pair(ios_t *f, value_t v) { value_t cd; char *op = NULL; if (iscons(cdr_(v)) && cdr_(cdr_(v)) == NIL && !ptrhash_has(&printconses, (void*)cdr_(v)) && (((car_(v) == QUOTE) && (op = "'")) || ((car_(v) == BACKQUOTE) && (op = "`")) || ((car_(v) == COMMA) && (op = ",")) || ((car_(v) == COMMAAT) && (op = ",@")) || ((car_(v) == COMMADOT) && (op = ",.")))) { // special prefix syntax unmark_cons(v); unmark_cons(cdr_(v)); outs(op, f); fl_print_child(f, car_(cdr_(v))); return; } int startpos = HPOS; outc('(', f); int newindent=HPOS, blk=blockindent(v); int lastv, n=0, si, ind=0, est, always=0, nextsmall, thistiny; if (!blk) always = indentevery(v); value_t head = car_(v); int after3 = indentafter3(head, v); int after2 = indentafter2(head, v); int n_unindented = 1; while (1) { cd = cdr_(v); if (print_length >= 0 && n >= print_length && cd!=NIL) { outsn("...)", f, 4); break; } lastv = VPOS; unmark_cons(v); fl_print_child(f, car_(v)); if (!iscons(cd) || ptrhash_has(&printconses, (void*)cd)) { if (cd != NIL) { outsn(" . ", f, 3); fl_print_child(f, cd); } outc(')', f); break; } if (!print_pretty || ((head == LAMBDA) && n == 0)) { // never break line before lambda-list ind = 0; } else { est = lengthestimate(car_(cd)); nextsmall = smallp(car_(cd)); thistiny = tinyp(car_(v)); ind = (((VPOS > lastv) || (HPOS>SCR_WIDTH/2 && !nextsmall && !thistiny && n>0)) || (HPOS > SCR_WIDTH-4) || (est!=-1 && (HPOS+est > SCR_WIDTH-2)) || ((head == LAMBDA) && !nextsmall) || (n > 0 && always) || (n == 2 && after3) || (n == 1 && after2) || (n_unindented >= 3 && !nextsmall) || (n == 0 && !smallp(head))); } if (ind) { newindent = outindent(newindent, f); n_unindented = 1; } else { n_unindented++; outc(' ', f); if (n==0) { // set indent level after printing head si = specialindent(head); if (si != -1) newindent = startpos + si; else if (!blk) newindent = HPOS; } } n++; v = cd; } }
// 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 = , 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; }
// TODO: add locks around global state mutation operations jl_value_t *jl_eval_module_expr(jl_module_t *parent_module, jl_expr_t *ex) { jl_ptls_t ptls = jl_get_ptls_states(); assert(ex->head == module_sym); if (jl_array_len(ex->args) != 3 || !jl_is_expr(jl_exprarg(ex, 2))) { jl_error("syntax: malformed module expression"); } int std_imports = (jl_exprarg(ex, 0) == jl_true); jl_sym_t *name = (jl_sym_t*)jl_exprarg(ex, 1); if (!jl_is_symbol(name)) { jl_type_error("module", (jl_value_t*)jl_sym_type, (jl_value_t*)name); } jl_module_t *newm = jl_new_module(name); jl_value_t *form = (jl_value_t*)newm; JL_GC_PUSH1(&form); ptrhash_put(&jl_current_modules, (void*)newm, (void*)((uintptr_t)HT_NOTFOUND + 1)); // copy parent environment info into submodule newm->uuid = parent_module->uuid; if (jl_base_module && (jl_value_t*)parent_module == jl_get_global(jl_base_module, jl_symbol("__toplevel__"))) { newm->parent = newm; jl_register_root_module(newm); } else { jl_binding_t *b = jl_get_binding_wr(parent_module, name, 1); jl_declare_constant(b); if (b->value != NULL) { if (!jl_is_module(b->value)) { jl_errorf("invalid redefinition of constant %s", jl_symbol_name(name)); } if (jl_generating_output()) { jl_errorf("cannot replace module %s during compilation", jl_symbol_name(name)); } jl_printf(JL_STDERR, "WARNING: replacing module %s.\n", jl_symbol_name(name)); // create a hidden gc root for the old module uintptr_t *refcnt = (uintptr_t*)ptrhash_bp(&jl_current_modules, (void*)b->value); *refcnt += 1; } newm->parent = parent_module; b->value = (jl_value_t*)newm; jl_gc_wb_binding(b, newm); } if (parent_module == jl_main_module && name == jl_symbol("Base")) { // pick up Base module during bootstrap jl_base_module = newm; } size_t last_age = ptls->world_age; // add standard imports unless baremodule if (std_imports) { if (jl_base_module != NULL) { jl_add_standard_imports(newm); } // add `eval` function form = jl_call_scm_on_ast("module-default-defs", (jl_value_t*)ex, newm); ptls->world_age = jl_world_counter; jl_toplevel_eval_flex(newm, form, 0, 1); form = NULL; } jl_array_t *exprs = ((jl_expr_t*)jl_exprarg(ex, 2))->args; for (int i = 0; i < jl_array_len(exprs); i++) { // process toplevel form ptls->world_age = jl_world_counter; form = jl_expand_stmt(jl_array_ptr_ref(exprs, i), newm); ptls->world_age = jl_world_counter; (void)jl_toplevel_eval_flex(newm, form, 1, 1); } ptls->world_age = last_age; #if 0 // some optional post-processing steps size_t i; void **table = newm->bindings.table; for(i=1; i < newm->bindings.size; i+=2) { if (table[i] != HT_NOTFOUND) { jl_binding_t *b = (jl_binding_t*)table[i]; // remove non-exported macros if (jl_symbol_name(b->name)[0]=='@' && !b->exportp && b->owner == newm) b->value = NULL; // error for unassigned exports /* if (b->exportp && b->owner==newm && b->value==NULL) jl_errorf("identifier %s exported from %s is not initialized", jl_symbol_name(b->name), jl_symbol_name(newm->name)); */ } } #endif uintptr_t *refcnt = (uintptr_t*)ptrhash_bp(&jl_current_modules, (void*)newm); assert(*refcnt > (uintptr_t)HT_NOTFOUND); *refcnt -= 1; // newm should be reachable from somewhere else by now if (jl_module_init_order == NULL) jl_module_init_order = jl_alloc_vec_any(0); jl_array_ptr_1d_push(jl_module_init_order, (jl_value_t*)newm); // defer init of children until parent is done being defined // then initialize all in definition-finished order // at build time, don't run them at all (defer for runtime) if (!jl_generating_output()) { if (!ptrhash_has(&jl_current_modules, (void*)newm->parent)) { size_t i, l = jl_array_len(jl_module_init_order); size_t ns = 0; form = (jl_value_t*)jl_alloc_vec_any(0); for (i = 0; i < l; i++) { jl_module_t *m = (jl_module_t*)jl_array_ptr_ref(jl_module_init_order, i); if (jl_is_submodule(m, newm)) { jl_array_ptr_1d_push((jl_array_t*)form, (jl_value_t*)m); } else if (ns++ != i) { jl_array_ptr_set(jl_module_init_order, ns - 1, (jl_value_t*)m); } } if (ns < l) jl_array_del_end(jl_module_init_order, l - ns); l = jl_array_len(form); for (i = 0; i < l; i++) { jl_module_t *m = (jl_module_t*)jl_array_ptr_ref(form, i); JL_GC_PROMISE_ROOTED(m); jl_module_run_initializer(m); } } } JL_GC_POP(); return (jl_value_t*)newm; }