/ellc.c
C | 1830 lines | 1527 code | 201 blank | 102 comment | 239 complexity | 167fbd4c44282f590b3d01cc3980e7ce MD5 | raw file
Large files files are truncated, but you can click here to view the full file
- /***** Executable and Linkable Lisp Compiler *****/
- //////////////////////////////////////////////////////////////////
- // //
- // _| _| _|_| _| _| _| //
- // _|_|_| _|_|_| _| _| _|_|_| _|_|_|_| //
- // _| _| _| _| _| _|_|_|_| _| _| _| _| //
- // _| _| _| _| _| _| _| _| _| _| //
- // _| _| _|_|_| _| _| _|_|_| _| _|_| //
- // //
- // //
- //////////////////////////////////////////////////////////////////
- #include <stdio.h>
- #include <dlfcn.h>
- #include "ellc.h"
- struct ell_obj *
- ellc_eval(struct ell_obj *stx_lst);
- /**** AST Utilities ****/
- static struct ellc_id *
- ellc_make_id_cx(struct ell_obj *sym, enum ellc_ns ns, struct ell_cx *cx)
- {
- ell_assert_wrapper(sym, ELL_WRAPPER(sym));
- struct ellc_id *id = (struct ellc_id *) ell_alloc(sizeof(*id));
- id->sym = sym;
- id->ns = ns;
- id->cx = cx;
- return id;
- }
- static struct ellc_id *
- ellc_make_id(struct ell_obj *sym, enum ellc_ns ns)
- {
- return ellc_make_id_cx(sym, ns, NULL);
- }
- static bool
- ellc_id_equal(struct ellc_id *a, struct ellc_id *b)
- {
- return (a->sym == b->sym) && (a->ns == b->ns) && (ell_cx_equal(a->cx, b->cx));
- }
- static int
- ellc_id_cmp(struct ellc_id *a, struct ellc_id *b)
- {
- int sym_cmp = ell_sym_cmp(a->sym, b->sym);
- if (sym_cmp != 0) {
- return sym_cmp;
- } else {
- int ns_cmp = a->ns - b->ns;
- if (ns_cmp != 0) {
- return ns_cmp;
- } else {
- return ell_cx_cmp(a->cx, b->cx);
- }
- }
- }
- static struct ellc_ast_seq *
- ellc_make_ast_seq()
- {
- struct ellc_ast_seq *ast_seq = ell_alloc(sizeof(*ast_seq));
- ast_seq->exprs = ell_util_make_list();
- return ast_seq;
- }
- static void
- ellc_ast_seq_add(struct ellc_ast_seq *ast_seq, struct ellc_ast *expr)
- {
- ell_util_list_add(ast_seq->exprs, expr);
- }
- static struct ellc_ast *
- ellc_make_ast(enum ellc_ast_type type)
- {
- struct ellc_ast *ast = (struct ellc_ast *) ell_alloc(sizeof(*ast));
- ast->type = type;
- return ast;
- }
- static int
- ellc_param_boxed(struct ellc_param *p)
- {
- return (p->closed && p->mutable);
- }
- /**** Lexical Contour Utilities ****/
- static struct ellc_param *
- ellc_params_list_lookup(list_t *list, struct ellc_id *id)
- {
- for (lnode_t *n = list_first(list); n; n = list_next(list, n)) {
- struct ellc_param *p = (struct ellc_param *) lnode_get(n);
- if (ellc_id_equal(p->id, id))
- return p;
- }
- return NULL;
- }
- static struct ellc_param *
- ellc_params_lookup(struct ellc_params *params, struct ellc_id *id)
- {
- struct ellc_param *p;
- if ((p = ellc_params_list_lookup(params->req, id))) return p;
- if ((p = ellc_params_list_lookup(params->opt, id))) return p;
- if ((p = ellc_params_list_lookup(params->key, id))) return p;
- if (params->rest && ellc_id_equal(params->rest->id, id)) return params->rest;
- if (params->all_keys && ellc_id_equal(params->all_keys->id, id)) return params->all_keys;
- return NULL;
- }
- // Returns the contour containing a parameter with the given ID,
- // from the contour C upwards, or NULL if there is no countour
- // containing that parameter. If found, sets OUT to the parameter.
- static struct ellc_contour *
- ellc_contour_lookup(struct ellc_contour *c, struct ellc_id *id, struct ellc_param **out)
- {
- if (!c) return NULL;
- struct ellc_param *p = ellc_params_lookup(c->lam->params, id);
- if (p) {
- if (out) *out = p;
- return c;
- } else {
- return ellc_contour_lookup(c->up, id, out);
- }
- }
- /**** Normalization: Syntax Objects -> AST ****/
- /* Table of normalization functions. */
- static dict_t ellc_norm_tab; // sym -> norm_fun
- static struct ellc_ast *
- ellc_norm_stx(struct ellc_st *st, struct ell_obj *stx);
- typedef struct ellc_ast *
- (ellc_norm_fun)(struct ellc_st *st, struct ell_obj *stx_lst);
- /* (Simple Forms) */
- static struct ellc_ast *
- ellc_make_ref(struct ellc_st *st, struct ell_obj *stx_sym, enum ellc_ns ns)
- {
- struct ellc_ast *ast = ellc_make_ast(ELLC_AST_REF);
- ast->ref.id = ellc_make_id_cx(ell_stx_sym_sym(stx_sym), ns, ell_stx_sym_cx(stx_sym));
- return ast;
- }
- static struct ellc_ast *
- ellc_norm_ref(struct ellc_st *st, struct ell_obj *stx_sym)
- {
- return ellc_make_ref(st, stx_sym, ELLC_NS_VAR);
- }
- static struct ellc_ast *
- ellc_norm_fref(struct ellc_st *st, struct ell_obj *stx_lst)
- {
- ell_assert_stx_lst_len(stx_lst, 2);
- struct ell_obj *stx_sym = ELL_SEND(stx_lst, second);
- return ellc_make_ref(st, stx_sym, ELLC_NS_FUN);
- }
- static struct ellc_ast *
- ellc_make_def(struct ellc_st *st, struct ell_obj *stx_lst, enum ellc_ns ns)
- {
- ell_assert_stx_lst_len(stx_lst, 3);
- struct ellc_ast *ast = ellc_make_ast(ELLC_AST_DEF);
- struct ell_obj *stx_sym = ELL_SEND(stx_lst, second);
- ast->def.id = ellc_make_id_cx(ell_stx_sym_sym(stx_sym), ns, ell_stx_sym_cx(stx_sym));
- ast->def.val = ellc_norm_stx(st, ELL_SEND(stx_lst, third));
- ell_util_set_add(st->defined_globals, ast->def.id, (dict_comp_t) &ellc_id_cmp);
- return ast;
- }
- static struct ellc_ast *
- ellc_norm_def(struct ellc_st *st, struct ell_obj *stx_lst)
- {
- return ellc_make_def(st, stx_lst, ELLC_NS_VAR);
- }
- static struct ellc_ast *
- ellc_norm_fdef(struct ellc_st *st, struct ell_obj *stx_lst)
- {
- return ellc_make_def(st, stx_lst, ELLC_NS_FUN);
- }
- static struct ellc_ast *
- ellc_make_defp(struct ellc_st *st, struct ell_obj *stx_lst, enum ellc_ns ns)
- {
- ell_assert_stx_lst_len(stx_lst, 2);
- struct ellc_ast *ast = ellc_make_ast(ELLC_AST_DEFP);
- struct ell_obj *stx_sym = ELL_SEND(stx_lst, second);
- ast->defp.id = ellc_make_id_cx(ell_stx_sym_sym(stx_sym), ns, ell_stx_sym_cx(stx_sym));
- return ast;
- }
- static struct ellc_ast *
- ellc_norm_defp(struct ellc_st *st, struct ell_obj *stx_lst)
- {
- return ellc_make_defp(st, stx_lst, ELLC_NS_VAR);
- }
- static struct ellc_ast *
- ellc_norm_fdefp(struct ellc_st *st, struct ell_obj *stx_lst)
- {
- return ellc_make_defp(st, stx_lst, ELLC_NS_FUN);
- }
- static struct ellc_ast *
- ellc_make_set(struct ellc_st *st, struct ell_obj *stx_lst, enum ellc_ns ns)
- {
- ell_assert_stx_lst_len(stx_lst, 3);
- struct ellc_ast *ast = ellc_make_ast(ELLC_AST_SET);
- struct ell_obj *stx_sym = ELL_SEND(stx_lst, second);
- ast->set.id = ellc_make_id_cx(ell_stx_sym_sym(stx_sym), ns, ell_stx_sym_cx(stx_sym));
- ast->set.val = ellc_norm_stx(st, ELL_SEND(stx_lst, third));
- return ast;
- }
- static struct ellc_ast *
- ellc_norm_set(struct ellc_st *st, struct ell_obj *stx_lst)
- {
- return ellc_make_set(st, stx_lst, ELLC_NS_VAR);
- }
- static struct ellc_ast *
- ellc_norm_fset(struct ellc_st *st, struct ell_obj *stx_lst)
- {
- return ellc_make_set(st, stx_lst, ELLC_NS_FUN);
- }
- static struct ellc_ast *
- ellc_norm_cond(struct ellc_st *st, struct ell_obj *stx_lst)
- {
- ell_assert_stx_lst_len(stx_lst, 4);
- struct ellc_ast *ast = ellc_make_ast(ELLC_AST_COND);
- ast->cond.test = ellc_norm_stx(st, ELL_SEND(stx_lst, second));
- ast->cond.consequent = ellc_norm_stx(st, ELL_SEND(stx_lst, third));
- ast->cond.alternative = ellc_norm_stx(st, ELL_SEND(stx_lst, fourth));
- return ast;
- }
- static struct ellc_ast *
- ellc_norm_seq(struct ellc_st *st, struct ell_obj *stx_lst)
- {
- ell_assert_stx_lst_len_min(stx_lst, 1);
- struct ellc_ast *ast = ellc_make_ast(ELLC_AST_SEQ);
- ast->seq.exprs = ell_util_make_list();
- list_t *elts_stx = ell_util_sublist(ell_stx_lst_elts(stx_lst), 1);
- for (lnode_t *n = list_first(elts_stx); n; n = list_next(elts_stx, n)) {
- struct ell_obj *stx = (struct ell_obj *) lnode_get(n);
- ellc_ast_seq_add(&ast->seq, ellc_norm_stx(st, stx));
- }
- return ast;
- }
- /* (Application and Arguments Dissection) */
- static bool
- ellc_is_key_arg_sym(struct ell_obj *sym)
- {
- struct ell_obj *name_str = ell_sym_name(sym);
- size_t len = ell_str_len(name_str);
- return (len > 1) && (ell_str_char_at(name_str, len - 1) == ':');
- }
- static struct ell_obj *
- ellc_clean_key_arg_sym(struct ell_obj *sym)
- {
- ell_assert_wrapper(sym, ELL_WRAPPER(sym));
- struct ell_obj *name_str = ell_sym_name(sym);
- return ell_intern(ell_str_poplast(name_str));
- }
- static struct ellc_args *
- ellc_make_args()
- {
- struct ellc_args *args = (struct ellc_args *) ell_alloc(sizeof(*args));
- list_init(&args->pos, LISTCOUNT_T_MAX);
- dict_init(&args->key, DICTCOUNT_T_MAX, (dict_comp_t) &ell_sym_cmp);
- return args;
- }
- static struct ellc_args *
- ellc_dissect_args(struct ellc_st *st, list_t *args_stx)
- {
- struct ellc_args *args = ellc_make_args();
- for (lnode_t *n = list_first(args_stx); n; n = list_next(args_stx, n)) {
- struct ell_obj *arg_stx = lnode_get(n);
- if ((arg_stx->wrapper == ELL_WRAPPER(stx_sym)) &&
- ellc_is_key_arg_sym(ell_stx_sym_sym(arg_stx)))
- {
- n = list_next(args_stx, n);
- if (!n) {
- ell_fail("missing value for keyword argument\n");
- }
- struct ell_obj *key_arg_sym =
- ellc_clean_key_arg_sym(ell_stx_sym_sym(arg_stx));
- struct ellc_ast *key_arg_val_ast =
- ellc_norm_stx(st, (struct ell_obj *) lnode_get(n));
- ell_util_dict_put(&args->key, key_arg_sym, key_arg_val_ast);
- } else {
- ell_util_list_add(&args->pos, ellc_norm_stx(st, arg_stx));
- }
- }
- return args;
- }
- static struct ellc_ast *
- ellc_make_app(struct ellc_st *st, struct ellc_ast *op, list_t *arg_stx_list)
- {
- struct ellc_ast *ast = ellc_make_ast(ELLC_AST_APP);
- ast->app.op = op;
- ast->app.args = ellc_dissect_args(st, arg_stx_list);
- return ast;
- }
- static struct ellc_ast *
- ellc_norm_app(struct ellc_st *st, struct ell_obj *stx_lst)
- {
- ell_assert_stx_lst_len_min(stx_lst, 2);
- return ellc_make_app(st, ellc_norm_stx(st, ELL_SEND(stx_lst, second)),
- ell_util_sublist(ell_stx_lst_elts(stx_lst), 2));
- }
- /* Takes a syntax list containing operator symbol and arguments and
- normalizes it to an application AST, with a reference to the
- operator function. */
- static struct ellc_ast *
- ellc_norm_ordinary_app(struct ellc_st *st, struct ell_obj *stx_lst)
- {
- ell_assert_stx_lst_len_min(stx_lst, 1);
- struct ell_obj *op_sym_stx = ELL_SEND(stx_lst, first);
- ell_assert_wrapper(op_sym_stx, ELL_WRAPPER(stx_sym));
- struct ellc_ast *op_ast = ellc_make_ast(ELLC_AST_REF);
- op_ast->ref.id = ellc_make_id_cx(ell_stx_sym_sym(op_sym_stx), ELLC_NS_FUN,
- ell_stx_sym_cx(op_sym_stx));
- return ellc_make_app(st, op_ast,
- ell_util_sublist(ell_stx_lst_elts(stx_lst), 1));
- }
- /* (Lambda and Parameters Dissection) */
- static struct ellc_param *
- ellc_dissect_param(struct ellc_st *st, struct ell_obj *p_stx, dict_t *deferred_inits)
- {
- struct ellc_param *p = (struct ellc_param *) ell_alloc(sizeof(*p));
- if (p_stx->wrapper == ELL_WRAPPER(stx_sym)) {
- p->id = ellc_make_id_cx(ell_stx_sym_sym(p_stx), ELLC_NS_VAR,
- ell_stx_sym_cx(p_stx));
- } else if (p_stx->wrapper == ELL_WRAPPER(stx_lst)) {
- ell_assert_stx_lst_len(p_stx, 2);
- struct ell_obj *name_stx = ELL_SEND(p_stx, first);
- struct ell_obj *init_stx = ELL_SEND(p_stx, second);
- p->id = ellc_make_id_cx(ell_stx_sym_sym(name_stx), ELLC_NS_VAR,
- ell_stx_sym_cx(name_stx));
- ell_util_dict_put(deferred_inits, p, init_stx);
- }
- return p;
- }
- static struct ellc_params *
- ellc_dissect_params(struct ellc_st *st, list_t *params_stx, dict_t *deferred_inits)
- {
- struct ellc_params *params =
- (struct ellc_params *) ell_alloc(sizeof(*params));
- list_t *req = ell_util_make_list();
- list_t *opt = ell_util_make_list();
- list_t *key = ell_util_make_list();
- list_t *rest = ell_util_make_list();
- list_t *all_keys = ell_util_make_list();
-
- list_t *cur = req;
- for (lnode_t *n = list_first(params_stx); n; n = list_next(params_stx, n)) {
- struct ell_obj *p_stx = lnode_get(n);
- if (p_stx->wrapper == ELL_WRAPPER(stx_sym)) {
- struct ell_obj *p_sym = ell_stx_sym_sym(p_stx);
- if (p_sym == ELL_SYM(param_optional)) {
- cur = opt;
- continue;
- } else if (p_sym == ELL_SYM(param_key)) {
- cur = key;
- continue;
- } else if (p_sym == ELL_SYM(param_rest)) {
- cur = rest;
- continue;
- } else if (p_sym == ELL_SYM(param_all_keys)) {
- cur = all_keys;
- continue;
- }
- }
- ell_util_list_add(cur, ellc_dissect_param(st, p_stx, deferred_inits));
- }
- if ((list_count(rest) > 1) || (list_count(all_keys) > 1)) {
- ell_fail("more than one rest or all-keys parameter\n");
- }
- params->req = req;
- params->opt = opt;
- params->key = key;
- if (list_count(rest) == 1)
- params->rest = lnode_get(list_first(rest));
- if (list_count(all_keys) == 1)
- params->all_keys = lnode_get(list_first(all_keys));
- return params;
- }
- static struct ellc_ast *
- ellc_norm_lam(struct ellc_st *st, struct ell_obj *stx_lst)
- {
- ell_assert_stx_lst_len(stx_lst, 3);
- struct ell_obj *params_stx = ELL_SEND(stx_lst, second);
- ell_assert_wrapper(params_stx, ELL_WRAPPER(stx_lst));
- struct ellc_ast *ast = ellc_make_ast(ELLC_AST_LAM);
- struct ellc_contour *c = (struct ellc_contour *) ell_alloc(sizeof(*c));
- c->lam = &ast->lam;
- c->up = st->bottom_contour;
- st->bottom_contour = c;
- /* We have to defer normalization of parameter init forms until
- after all parameters have been seen, and have been added to the
- current lambda, so that local variable references work correctly. */
- dict_t *deferred_inits = ell_util_make_dict((dict_comp_t) &ell_ptr_cmp); // param -> init_stx
- ast->lam.params = ellc_dissect_params(st, ell_stx_lst_elts(params_stx), deferred_inits);
- for (dnode_t *dn = dict_first(deferred_inits); dn; dn = dict_next(deferred_inits, dn)) {
- struct ellc_param *param = (struct ellc_param *) dnode_getkey(dn);
- struct ell_obj *init_stx = (struct ell_obj *) dnode_get(dn);
- param->init = ellc_norm_stx(st, init_stx);
- }
- ast->lam.body = ellc_norm_stx(st, ELL_SEND(stx_lst, third));
- ast->lam.env = ell_util_make_dict((dict_comp_t) &ellc_id_cmp); // unused during norm.
- st->bottom_contour = c->up;
- return ast;
- }
- static struct ellc_ast *
- ellc_quote(struct ellc_st *st, struct ell_obj *stx_sym)
- {
- struct ellc_ast *ast = ellc_make_ast(ELLC_AST_LIT_SYM);
- ast->lit_sym.sym = stx_sym;
- return ast;
- }
- static struct ellc_ast *
- ellc_norm_quote(struct ellc_st *st, struct ell_obj *stx_lst)
- {
- ell_assert_stx_lst_len(stx_lst, 2);
- return ellc_quote(st, ell_stx_sym_sym(ELL_SEND(stx_lst, second)));
- }
- static struct ellc_ast *
- ellc_norm_loop(struct ellc_st *st, struct ell_obj *stx_lst)
- {
- ell_assert_stx_lst_len(stx_lst, 2);
- struct ellc_ast *ast = ellc_make_ast(ELLC_AST_LOOP);
- ast->loop.body = ellc_norm_stx(st, ELL_SEND(stx_lst, second));
- return ast;
- }
- /* (Quasisyntax) */
- static struct ellc_ast *
- ellc_norm_qs(struct ellc_st *st, struct ell_obj *arg_stx, unsigned depth);
- static struct ellc_ast *
- ellc_build_syntax(struct ellc_st *st, struct ell_obj *stx)
- {
- struct ellc_ast *ast = ellc_make_ast(ELLC_AST_LIT_STX);
- if (!((stx->wrapper == ELL_WRAPPER(stx_sym))
- || (stx->wrapper == ELL_WRAPPER(stx_str)))) {
- ell_fail("can't build syntax AST from non-syntax object\n");
- }
- ast->lit_stx.stx = stx;
- return ast;
- }
- static struct ellc_ast *
- ellc_build_syntax_list(struct ellc_st *st, list_t *asts)
- {
- struct ellc_args *args = ellc_make_args();
- list_transfer(&args->pos, asts, list_first(asts));
- struct ellc_ast *ast = ellc_make_ast(ELLC_AST_APP);
- ast->app.op = ellc_make_ref(st, ell_make_stx_sym(ELL_SYM(core_syntax_list)), ELLC_NS_FUN);
- ast->app.args = args;
- return ast;
- }
- static struct ellc_ast *
- ellc_build_append_syntax_lists(struct ellc_st *st, list_t *asts)
- {
- struct ellc_args *args = ellc_make_args();
- list_transfer(&args->pos, asts, list_first(asts));
- struct ellc_ast *ast = ellc_make_ast(ELLC_AST_APP);
- ast->app.op = ellc_make_ref(st, ell_make_stx_sym(ELL_SYM(core_append_syntax_lists)), ELLC_NS_FUN);
- ast->app.args = args;
- return ast;
- }
- static struct ellc_ast *
- ellc_build_quasisyntax(struct ellc_st *st, struct ell_obj *stx, unsigned depth)
- {
- list_t *asts = ell_util_make_list();
- ell_util_list_add(asts, ellc_build_syntax(st, ell_make_stx_sym(ELL_SYM(core_quasisyntax))));
- ell_util_list_add(asts, ellc_norm_qs(st, stx, depth));
- return ellc_build_syntax_list(st, asts);
- }
- static struct ellc_ast *
- ellc_build_unsyntax(struct ellc_st *st, struct ell_obj *stx, unsigned depth)
- {
- list_t *asts = ell_util_make_list();
- ell_util_list_add(asts, ellc_build_syntax(st, ell_make_stx_sym(ELL_SYM(core_unsyntax))));
- ell_util_list_add(asts, ellc_norm_qs(st, stx, depth));
- return ellc_build_syntax_list(st, asts);
- }
- static struct ellc_ast *
- ellc_build_unsyntax_splicing(struct ellc_st *st, struct ell_obj *stx, unsigned depth)
- {
- list_t *asts = ell_util_make_list();
- ell_util_list_add(asts, ellc_build_syntax(st, ell_make_stx_sym(ELL_SYM(core_unsyntax_splicing))));
- ell_util_list_add(asts, ellc_norm_qs(st, stx, depth));
- return ellc_build_syntax_list(st, asts);
- }
- static bool
- ellc_is_unsyntax_splicing_list(struct ellc_st *st, struct ell_obj *stx)
- {
- if (stx->wrapper != ELL_WRAPPER(stx_lst)) return 0;
- if (ell_stx_lst_len(stx) != 2) return 0;
- struct ell_obj *op_stx = ELL_SEND(stx, first);
- return ((op_stx->wrapper == ELL_WRAPPER(stx_sym))
- && (ell_stx_sym_sym(op_stx) == ELL_SYM(core_unsyntax_splicing)));
- }
- static bool
- ellc_is_unsyntax(struct ellc_st *st, struct ell_obj *op_stx)
- {
- return ((op_stx->wrapper == ELL_WRAPPER(stx_sym))
- && (ell_stx_sym_sym(op_stx) == ELL_SYM(core_unsyntax)));
- }
- static bool
- ellc_is_quasisyntax(struct ellc_st *st, struct ell_obj *op_stx)
- {
- return ((op_stx->wrapper == ELL_WRAPPER(stx_sym))
- && (ell_stx_sym_sym(op_stx) == ELL_SYM(core_quasisyntax)));
- }
- /* Unfortunately, this code is very hard to understand. If you want
- to make sense of it, first understand Alan Bawden's implementation
- in appendix B of his paper "Quasiquotation in Lisp". Ha. */
- static struct ellc_ast *
- ellc_norm_qs_lst_helper(struct ellc_st *st, struct ell_obj *stx_lst, unsigned depth)
- {
- list_t *in_elts = ell_stx_lst_elts(stx_lst);
- list_t *lsts = ell_util_make_list();
- list_t *cur_elts = ell_util_make_list();
-
- for (lnode_t *n = list_first(in_elts); n; n = list_next(in_elts, n)) {
- struct ell_obj *sub = (struct ell_obj *) lnode_get(n);
- if (ellc_is_unsyntax_splicing_list(st, sub)) {
- if (list_count(cur_elts) > 0) {
- ell_util_list_add(lsts, ellc_build_syntax_list(st, cur_elts));
- cur_elts = ell_util_make_list();
- }
- if (depth == 0) {
- ell_util_list_add(lsts, ellc_norm_stx(st, ELL_SEND(sub, second)));
- } else {
- ell_util_list_add(lsts, ellc_build_unsyntax_splicing(st, ELL_SEND(sub, second), depth - 1));
- }
- } else {
- ell_util_list_add(cur_elts, ellc_norm_qs(st, sub, depth));
- }
- }
- if (list_count(cur_elts) > 0)
- ell_util_list_add(lsts, ellc_build_syntax_list(st, cur_elts));
- return ellc_build_append_syntax_lists(st, lsts);
- }
- static struct ellc_ast *
- ellc_norm_qs_lst(struct ellc_st *st, struct ell_obj *stx_lst, unsigned depth)
- {
- if (ell_stx_lst_len(stx_lst) == 0) {
- return ellc_build_syntax_list(st, ell_stx_lst_elts(stx_lst));
- } else {
- struct ell_obj *op_stx = ELL_SEND(stx_lst, first);
- if (ellc_is_unsyntax(st, op_stx)) {
- ell_assert_stx_lst_len(stx_lst, 2);
- struct ell_obj *arg_stx = ELL_SEND(stx_lst, second);
- if (depth == 0) {
- return ellc_norm_stx(st, arg_stx);
- } else {
- return ellc_build_unsyntax(st, arg_stx, depth - 1);
- }
- } else if (ellc_is_quasisyntax(st, op_stx)) {
- ell_assert_stx_lst_len(stx_lst, 2);
- struct ell_obj *arg_stx = ELL_SEND(stx_lst, second);
- return ellc_build_quasisyntax(st, arg_stx, depth + 1);
- } else {
- return ellc_norm_qs_lst_helper(st, stx_lst, depth);
- }
- }
- }
- static struct ellc_ast *
- ellc_norm_qs(struct ellc_st *st, struct ell_obj *arg_stx, unsigned depth)
- {
- if (depth < 0) {
- ell_fail("negative quasiquotation depth\n");
- }
- if ((arg_stx->wrapper == ELL_WRAPPER(stx_str)) ||
- (arg_stx->wrapper == ELL_WRAPPER(stx_sym))) {
- return ellc_build_syntax(st, arg_stx);
- } else if (arg_stx->wrapper == ELL_WRAPPER(stx_lst)) {
- return ellc_norm_qs_lst(st, arg_stx, depth);
- } else {
- ell_fail("bad quasiquoted syntax object\n");
- }
- }
- static struct ellc_ast *
- ellc_norm_quasisyntax(struct ellc_st *st, struct ell_obj *stx_lst)
- {
- ell_assert_stx_lst_len(stx_lst, 2);
- struct ell_obj *arg_stx = ELL_SEND(stx_lst, second);
- struct ellc_ast *body = ellc_norm_qs(st, arg_stx, 0);
-
- struct ellc_ast *cx_ast = ellc_make_ast(ELLC_AST_CX);
- cx_ast->cx.body = body;
- return cx_ast;
- }
- /* (Macroexpansion) */
- static bool
- ellc_is_seq(struct ell_obj *stx)
- {
- if (stx->wrapper != ELL_WRAPPER(stx_lst)) return 0;
- if (list_count(ell_stx_lst_elts(stx)) < 2) return 0; // todo: handle better
- struct ell_obj *op_stx = ELL_SEND(stx, first);
- return ((op_stx->wrapper == ELL_WRAPPER(stx_sym))
- && (ell_stx_sym_sym(op_stx) == ELL_SYM(core_seq)));
- }
- static bool
- ellc_is_mdef(struct ell_obj *stx)
- {
- if (stx->wrapper != ELL_WRAPPER(stx_lst)) return 0;
- if (list_count(ell_stx_lst_elts(stx)) != 3) return 0; // todo: handle better
- struct ell_obj *op_stx = ELL_SEND(stx, first);
- return ((op_stx->wrapper == ELL_WRAPPER(stx_sym))
- && (ell_stx_sym_sym(op_stx) == ELL_SYM(core_mdef)));
- }
- static struct ellc_ast *
- ellc_norm_mdef(struct ellc_st *st, struct ell_obj *mdef_stx)
- {
- ell_assert_stx_lst_len(mdef_stx, 3);
- struct ell_obj *name_stx = ELL_SEND(mdef_stx, second);
- ell_assert_wrapper(name_stx, ELL_WRAPPER(stx_sym));
- struct ell_obj *expander_stx = ELL_SEND(mdef_stx, third);
- ell_util_dict_put(st->defined_macros, ell_stx_sym_sym(name_stx), expander_stx);
- // Right now, eval requires a syntax list as input, so we need to
- // wrap the expander expression in one.
- struct ell_obj *stx_lst = ell_make_stx_lst();
- ELL_SEND(stx_lst, add, expander_stx);
- ell_util_dict_put(&ellc_mac_tab, ell_stx_sym_sym(name_stx), ellc_eval(stx_lst));
- return NULL; // runtime noop
- }
- /* (Inline C) */
- static struct ellc_ast *
- ellc_norm_snip(struct ellc_st *st, struct ell_obj *stx_lst)
- {
- struct ellc_ast *ast = ellc_make_ast(ELLC_AST_SNIP);
- ast->snip.body = ellc_norm_seq(st, stx_lst);
- return ast;
- }
- static struct ellc_ast *
- ellc_norm_stmt(struct ellc_st *st, struct ell_obj *stx_lst)
- {
- struct ellc_ast *ast = ellc_make_ast(ELLC_AST_STMT);
- ast->stmt.body = ellc_norm_seq(st, stx_lst);
- return ast;
- }
- /* (Putting it All Together) */
- // This belongs somewhere else
- /* (compiler-put-expander symbol function) -> unspecified */
- struct ell_obj *__ell_g_compilerDputDexpander_2_;
- struct ell_obj *
- ellc_compiler_put_expander_code(struct ell_obj *clo, ell_arg_ct npos,
- ell_arg_ct nkey, struct ell_obj **args)
- {
- ell_check_npos(npos, 2);
- struct ell_obj *symbol = args[0];
- struct ell_obj *function = args[1];
- ell_assert_wrapper(symbol, ELL_WRAPPER(sym));
- ell_assert_wrapper(function, ELL_WRAPPER(clo));
- ell_util_dict_put(&ellc_mac_tab, symbol, function);
- }
- __attribute__((constructor(300))) static void
- ellc_init()
- {
- // Constant table of normalization functions
- dict_init(&ellc_norm_tab, DICTCOUNT_T_MAX, (dict_comp_t) &ell_sym_cmp);
- ell_util_dict_put(&ellc_norm_tab, ELL_SYM(core_fref), &ellc_norm_fref);
- ell_util_dict_put(&ellc_norm_tab, ELL_SYM(core_def), &ellc_norm_def);
- ell_util_dict_put(&ellc_norm_tab, ELL_SYM(core_fdef), &ellc_norm_fdef);
- ell_util_dict_put(&ellc_norm_tab, ELL_SYM(core_defp), &ellc_norm_defp);
- ell_util_dict_put(&ellc_norm_tab, ELL_SYM(core_fdefp), &ellc_norm_fdefp);
- ell_util_dict_put(&ellc_norm_tab, ELL_SYM(core_set), &ellc_norm_set);
- ell_util_dict_put(&ellc_norm_tab, ELL_SYM(core_fset), &ellc_norm_fset);
- ell_util_dict_put(&ellc_norm_tab, ELL_SYM(core_cond), &ellc_norm_cond);
- ell_util_dict_put(&ellc_norm_tab, ELL_SYM(core_seq), &ellc_norm_seq);
- ell_util_dict_put(&ellc_norm_tab, ELL_SYM(core_app), &ellc_norm_app);
- ell_util_dict_put(&ellc_norm_tab, ELL_SYM(core_lam), &ellc_norm_lam);
- ell_util_dict_put(&ellc_norm_tab, ELL_SYM(core_loop), &ellc_norm_loop);
- ell_util_dict_put(&ellc_norm_tab, ELL_SYM(core_quote), &ellc_norm_quote);
- ell_util_dict_put(&ellc_norm_tab, ELL_SYM(core_quasisyntax), &ellc_norm_quasisyntax);
- ell_util_dict_put(&ellc_norm_tab, ELL_SYM(core_syntax), &ellc_norm_quasisyntax);
- ell_util_dict_put(&ellc_norm_tab, ELL_SYM(core_mdef), &ellc_norm_mdef);
- ell_util_dict_put(&ellc_norm_tab, ELL_SYM(core_snip), &ellc_norm_snip);
- ell_util_dict_put(&ellc_norm_tab, ELL_SYM(core_stmt), &ellc_norm_stmt);
- // Compiler state
- dict_init(&ellc_mac_tab, DICTCOUNT_T_MAX, (dict_comp_t) &ell_sym_cmp);
- __ell_g_compilerDputDexpander_2_ =
- ell_make_clo(&ellc_compiler_put_expander_code, NULL);
- }
- static struct ellc_ast *
- ellc_norm_lst(struct ellc_st *st, struct ell_obj *stx_lst)
- {
- ell_assert_wrapper(stx_lst, ELL_WRAPPER(stx_lst));
- struct ell_obj *op_stx = ELL_SEND(stx_lst, first);
- ell_assert_wrapper(op_stx, ELL_WRAPPER(stx_sym));
- struct ell_obj *op_sym = ell_stx_sym_sym(op_stx);
- struct ell_cx *cx = ell_stx_sym_cx(op_stx);
- struct ellc_id *id = ellc_make_id_cx(op_sym, ELLC_NS_FUN, cx);
- if (ellc_contour_lookup(st->bottom_contour, id, NULL)) {
- // operator is lexically fbound
- return ellc_norm_ordinary_app(st, stx_lst);
- } else {
- dnode_t *exp_node = dict_lookup(&ellc_mac_tab, op_sym);
- if (exp_node) {
- // operator is a macro
- struct ell_obj *expander = (struct ell_obj *) dnode_get(exp_node);
- struct ell_obj *expansion_stx = ELL_CALL(expander, stx_lst);
- return ellc_norm_stx(st, expansion_stx);
- } else {
- dnode_t *norm_node = dict_lookup(&ellc_norm_tab, op_sym);
- if (norm_node) {
- // operator is a special form
- ellc_norm_fun *norm_fun = (ellc_norm_fun *) dnode_get(norm_node);
- return norm_fun(st, stx_lst);
- } else {
- // operator is assumed to be global function
- return ellc_norm_ordinary_app(st, stx_lst);
- }
- }
- }
- }
- static struct ellc_ast *
- ellc_norm_lit_str(struct ellc_st *st, struct ell_obj *stx)
- {
- struct ellc_ast *ast = ellc_make_ast(ELLC_AST_LIT_STR);
- ast->lit_str.str = ell_stx_str_str(stx);
- return ast;
- }
- static struct ellc_ast *
- ellc_norm_lit_num(struct ellc_st *st, struct ell_obj *stx)
- {
- struct ellc_ast *ast = ellc_make_ast(ELLC_AST_LIT_NUM);
- ast->lit_num.num = ell_stx_num_num(stx);
- return ast;
- }
- /* Main normalization function. Takes syntax object as input, and
- returns AST. Special handling for classic Lisp evaluation rules:
- symbols evaluate to the variables they name; lists evaluate to
- function calls, special forms (taken from `ellc_norm_tab'), or
- macro calls (taken from `ellc_mac_tab'); literals evaluate to
- themselves. */
- static struct ellc_ast *
- ellc_norm_stx(struct ellc_st *st, struct ell_obj *stx)
- {
- if (stx->wrapper == ELL_WRAPPER(stx_sym)) {
- return ellc_norm_ref(st, stx);
- } else if (stx->wrapper == ELL_WRAPPER(stx_lst)) {
- return ellc_norm_lst(st, stx);
- } else if (stx->wrapper == ELL_WRAPPER(stx_str)) {
- return ellc_norm_lit_str(st, stx);
- } else if (stx->wrapper == ELL_WRAPPER(stx_num)) {
- return ellc_norm_lit_num(st, stx);
- } else {
- ell_fail("syntax normalization failure\n");
- }
- }
- static list_t *
- ellc_norm_macro_pass(struct ellc_st *st, list_t *stx_elts, list_t *deferred)
- {
- for (lnode_t *n = list_first(stx_elts); n; n = list_next(stx_elts, n)) {
- struct ell_obj *stx = (struct ell_obj *) lnode_get(n);
- if (ellc_is_seq(stx)) {
- ellc_norm_macro_pass(st, ell_util_sublist(ell_stx_lst_elts(stx), 1), deferred);
- } else if (ellc_is_mdef(stx)) {
- ellc_norm_mdef(st, stx);
- } else {
- ell_util_list_add(deferred, stx);
- }
- }
- }
- static struct ellc_ast_seq *
- ellc_norm(struct ellc_st *st, struct ell_obj *stx_lst)
- {
- ell_assert_wrapper(stx_lst, ELL_WRAPPER(stx_lst));
- list_t *deferred = ell_util_make_list();
- ellc_norm_macro_pass(st, ell_stx_lst_elts(stx_lst), deferred);
- struct ellc_ast_seq *ast_seq = ellc_make_ast_seq();
- for (lnode_t *n = list_first(deferred); n; n = list_next(deferred, n)) {
- struct ell_obj *stx = (struct ell_obj *) lnode_get(n);
- struct ellc_ast *res = ellc_norm_stx(st, stx);
- if (res) // no-ops return NULL
- ellc_ast_seq_add(ast_seq, res);
- }
- return ast_seq;
- }
- /**** Closure Conversion ****/
- static void
- ellc_conv_ast(struct ellc_st *st, struct ellc_ast *ast);
- static bool
- ellc_defined_at_toplevel(struct ellc_st *st, struct ellc_id *id)
- {
- return ell_util_list_contains(st->defined_globals, id, (dict_comp_t) &ellc_id_cmp);
- }
- static void
- ellc_env_add_ref(struct ellc_ast_lam *lam, struct ellc_id *id)
- {
- if (!dict_lookup(lam->env, id)) {
- struct ellc_ast *ref = ellc_make_ast(ELLC_AST_REF);
- ref->ref.id = id;
- ell_util_dict_put(lam->env, id, ref);
- }
- }
- static void
- ellc_conv_ref(struct ellc_st *st, struct ellc_ast *ast)
- {
- struct ellc_param *p = NULL;
- struct ellc_contour *c = ellc_contour_lookup(st->bottom_contour, ast->ref.id, &p);
- if (!c) {
- /* The identifier isn't lexically bound. Now, we still need
- to check whether it's defined at the top-level in the
- current unit, before we follow the rule that all variables
- are considered implicitly bound at the top-level. For such
- implicitly bound variables we need to ignore the hygiene
- context. */
- if (!ellc_defined_at_toplevel(st, ast->ref.id)) {
- ast->ref.id->cx = NULL;
- }
- struct ellc_id *tmp_id = ast->ref.id;
- ast->type = ELLC_AST_GLO_REF;
- ast->glo_ref.id = tmp_id;
- ell_util_set_add(st->globals, tmp_id, (dict_comp_t) &ellc_id_cmp);
- } else if (c == st->bottom_contour) {
- ast->type = ELLC_AST_ARG_REF;
- ast->arg_ref.param = p;
- } else {
- ast->type = ELLC_AST_ENV_REF;
- ast->env_ref.param = p;
- p->closed = 1;
- ellc_env_add_ref(st->bottom_contour->lam, p->id);
- }
- }
- static void
- ellc_conv_def(struct ellc_st *st, struct ellc_ast *ast)
- {
- ell_util_set_add(st->globals, ast->def.id, (dict_comp_t) &ellc_id_cmp);
- ellc_conv_ast(st, ast->def.val);
- }
- static void
- ellc_conv_defp(struct ellc_st *st, struct ellc_ast *ast)
- {
- /* See comment in ellc_conv_ref. */
- if (!ellc_defined_at_toplevel(st, ast->defp.id)) {
- ast->defp.id->cx = NULL;
- }
- ell_util_set_add(st->globals, ast->defp.id, (dict_comp_t) &ellc_id_cmp);
- }
- static void
- ellc_conv_set(struct ellc_st *st, struct ellc_ast *ast)
- {
- ellc_conv_ast(st, ast->set.val);
- struct ellc_param *p;
- struct ellc_contour *c = ellc_contour_lookup(st->bottom_contour, ast->set.id, &p);
- if (!c) {
- /* See comment in ellc_conv_ref. */
- if (!ellc_defined_at_toplevel(st, ast->ref.id)) {
- ast->set.id->cx = NULL;
- }
- struct ellc_id *tmp_id = ast->set.id;
- ast->type = ELLC_AST_GLO_SET;
- ast->glo_set.id = tmp_id;
- ell_util_set_add(st->globals, tmp_id, (dict_comp_t) &ellc_id_cmp);
- } else if (c == st->bottom_contour) {
- struct ellc_ast *tmp_val = ast->set.val;
- ast->type = ELLC_AST_ARG_SET;
- ast->arg_set.param = p;
- ast->arg_set.val = tmp_val;
- p->mutable = 1;
- } else {
- struct ellc_ast *tmp_val = ast->set.val;
- ast->type = ELLC_AST_ENV_SET;
- ast->env_set.param = p;
- ast->env_set.val = tmp_val;
- p->closed = 1;
- p->mutable = 1;
- ellc_env_add_ref(st->bottom_contour->lam, p->id);
- }
- }
- static void
- ellc_conv_cond(struct ellc_st *st, struct ellc_ast *ast)
- {
- ellc_conv_ast(st, ast->cond.test);
- ellc_conv_ast(st, ast->cond.consequent);
- ellc_conv_ast(st, ast->cond.alternative);
- }
- static void
- ellc_conv_seq(struct ellc_st *st, struct ellc_ast *ast)
- {
- for (lnode_t *n = list_first(ast->seq.exprs); n; n = list_next(ast->seq.exprs, n))
- ellc_conv_ast(st, (struct ellc_ast *) lnode_get(n));
- }
- static void
- ellc_conv_args(struct ellc_st *st, struct ellc_args *args)
- {
- for (lnode_t *n = list_first(&args->pos); n; n = list_next(&args->pos, n))
- ellc_conv_ast(st, (struct ellc_ast *) lnode_get(n));
- for (dnode_t *n = dict_first(&args->key); n; n = dict_next(&args->key, n))
- ellc_conv_ast(st, (struct ellc_ast *) dnode_get(n));
- }
- static void
- ellc_conv_app(struct ellc_st *st, struct ellc_ast *ast)
- {
- ellc_conv_ast(st, ast->app.op);
- ellc_conv_args(st, ast->app.args);
- }
- static void
- ellc_conv_params_list_inits(struct ellc_st *st, list_t *params)
- {
- for (lnode_t *n = list_first(params); n; n = list_next(params, n)) {
- struct ellc_param *p = (struct ellc_param *) lnode_get(n);
- if (p->init)
- ellc_conv_ast(st, p->init);
- }
- }
- static void
- ellc_conv_param_inits(struct ellc_st *st, struct ellc_params *params)
- {
- ellc_conv_params_list_inits(st, params->opt);
- ellc_conv_params_list_inits(st, params->key);
- }
- static void
- ellc_conv_lam(struct ellc_st *st, struct ellc_ast *ast)
- {
- struct ellc_contour *c = (struct ellc_contour *) ell_alloc(sizeof(*c));
- c->lam = &ast->lam;
- c->up = st->bottom_contour;
- st->bottom_contour = c;
- ellc_conv_param_inits(st, ast->lam.params);
- ellc_conv_ast(st, ast->lam.body);
- st->bottom_contour = c->up;
- for (dnode_t *n = dict_first(ast->lam.env); n; n = dict_next(ast->lam.env, n))
- ellc_conv_ast(st, (struct ellc_ast *) dnode_get(n));
- ast->lam.code_id = list_count(st->lambdas);
- ell_util_list_add(st->lambdas, &ast->lam);
- }
- static void
- ellc_conv_loop(struct ellc_st *st, struct ellc_ast *ast)
- {
- ellc_conv_ast(st, ast->loop.body);
- }
- static void
- ellc_conv_cx(struct ellc_st *st, struct ellc_ast *ast)
- {
- ellc_conv_ast(st, ast->cx.body);
- }
- static void
- ellc_conv_snip(struct ellc_st *st, struct ellc_ast *ast)
- {
- ellc_conv_ast(st, ast->snip.body);
- }
- static void
- ellc_conv_stmt(struct ellc_st *st, struct ellc_ast *ast)
- {
- ellc_conv_ast(st, ast->stmt.body);
- ell_util_list_add(st->stmts, ast);
- }
- static void
- ellc_conv_ast(struct ellc_st *st, struct ellc_ast *ast)
- {
- switch(ast->type) {
- case ELLC_AST_REF: ellc_conv_ref(st, ast); break;
- case ELLC_AST_DEF: ellc_conv_def(st, ast); break;
- case ELLC_AST_DEFP: ellc_conv_defp(st, ast); break;
- case ELLC_AST_SET: ellc_conv_set(st, ast); break;
- case ELLC_AST_COND: ellc_conv_cond(st, ast); break;
- case ELLC_AST_SEQ: ellc_conv_seq(st, ast); break;
- case ELLC_AST_APP: ellc_conv_app(st, ast); break;
- case ELLC_AST_LAM: ellc_conv_lam(st, ast); break;
- case ELLC_AST_LOOP: ellc_conv_loop(st, ast); break;
- case ELLC_AST_CX: ellc_conv_cx(st, ast); break;
- case ELLC_AST_SNIP: ellc_conv_snip(st, ast); break;
- case ELLC_AST_STMT: ellc_conv_stmt(st, ast); break;
- case ELLC_AST_LIT_SYM: break;
- case ELLC_AST_LIT_STR: break;
- case ELLC_AST_LIT_NUM: break;
- case ELLC_AST_LIT_STX: break;
- default:
- ell_fail("conversion error: %d\n", ast->type);
- }
- }
- static void
- ellc_conv(struct ellc_st *st, struct ellc_ast_seq *ast_seq)
- {
- if (st->bottom_contour != NULL) {
- ell_fail("contour tracking bug or error in compilation unit\n");
- }
- for (lnode_t *n = list_first(ast_seq->exprs); n; n = list_next(ast_seq->exprs, n))
- ellc_conv_ast(st, (struct ellc_ast *) lnode_get(n));
- }
- /**** Emission ****/
- static void
- ellc_emit_ast(struct ellc_st *st, struct ellc_ast *ast);
- static char
- ellc_mangle_char(char c)
- {
- // Needs to be kept in sync with sym-char in 'grammar.leg'.
- switch (c) {
- case '&': return 'A';
- case '_': return 'U';
- case '-': return 'D';
- case '#': return 'O';
- case '/': return 'F';
- case '<': return 'L';
- case '>': return 'G';
- case '*': return 'Z';
- case '+': return 'P';
- case '?': return 'Q';
- default: return c;
- }
- }
- static char *
- ellc_mangle_str(char *s)
- {
- size_t len = strlen(s);
- char *out = (char *) ell_alloc(len + 1);
- for (int i = 0; i < len; i++) {
- out[i] = ellc_mangle_char(s[i]);
- }
- out[len] = '\0';
- return out;
- }
- static char *ELLC_NO_CX = "";
- static char *
- ellc_mangle_cx(struct ell_cx *cx)
- {
- if (cx->uuid != NULL) {
- char *out = (char *) ell_alloc(37);
- uuid_unparse(cx->uuid, out);
- return ellc_mangle_str(out);
- } else {
- return ELLC_NO_CX;
- }
- }
- static char *
- ellc_mangle_id(char *prefix, struct ellc_id *id)
- {
- char *std = "__ell";
- char *name = ellc_mangle_str(ell_str_chars(ell_sym_name(id->sym)));
- char *cx = ellc_mangle_cx(id->cx);
- size_t prefix_len = strlen(prefix);
- size_t std_len = strlen(std);
- size_t name_len = strlen(name);
- size_t cx_len = strlen(cx);
- size_t len = std_len + prefix_len + name_len + cx_len
- + 4 // separators
- + 1 // ns (single digit, lest this become a Lisp-10)
- + 1; // zero
- char *out = (char *) ell_alloc(len);
- snprintf(out, len, "%s_%s_%s_%u_%s", std, prefix, name, id->ns, cx);
- return out;
- }
- static char *
- ellc_mangle_glo_id(struct ellc_id *id)
- {
- return ellc_mangle_id("g", id);
- }
- static char *
- ellc_mangle_param_id(struct ellc_id *id)
- {
- return ellc_mangle_id("p", id);
- }
- static char *
- ellc_mangle_env_id(struct ellc_id *id)
- {
- return ellc_mangle_id("e", id);
- }
- static void
- ellc_emit_glo_ref(struct ellc_st *st, struct ellc_ast *ast)
- {
- struct ellc_id *id = ast->glo_ref.id;
- char *sid = ell_str_chars(ell_sym_name(id->sym));
- char *mid = ellc_mangle_glo_id(id);
- switch(id->ns) {
- case ELLC_NS_VAR:
- fprintf(st->f, "ELL_GEN_GLO_REF(%s, \"%s\")", mid, sid);
- break;
- case ELLC_NS_FUN:
- fprintf(st->f, "ELL_GEN_GLO_FREF(%s, \"%s\")", mid, sid);
- break;
- default:
- ell_fail("unknown namespace\n");
- }
- }
- static void
- ellc_emit_arg_ref_plain(struct ellc_st *st, struct ellc_ast *ast)
- {
- fprintf(st->f, "ELL_GEN_ARG_REF_PLAIN(%s)", ellc_mangle_param_id(ast->arg_ref.param->id));
- }
- static void
- ellc_emit_env_ref_plain(struct ellc_st *st, struct ellc_ast *ast)
- {
- fprintf(st->f, "ELL_GEN_ENV_REF_PLAIN(%s)", ellc_mangle_env_id(ast->env_ref.param->id));
- }
- static void
- ellc_emit_arg_ref(struct ellc_st *st, struct ellc_ast *ast)
- {
- if (ellc_param_boxed(ast->arg_ref.param)) {
- fprintf(st->f, "ELL_GEN_ARG_REF_BOXED(%s)", ellc_mangle_param_id(ast->arg_ref.param->id));
- } else {
- ellc_emit_arg_ref_plain(st, ast);
- }
- }
- static void
- ellc_emit_env_ref(struct ellc_st *st, struct ellc_ast *ast)
- {
- if (ellc_param_boxed(ast->env_ref.param)) {
- fprintf(st->f, "ELL_GEN_ENV_REF_BOXED(%s)", ellc_mangle_env_id(ast->env_ref.param->id));
- } else {
- ellc_emit_env_ref_plain(st, ast);
- }
- }
- static void
- ellc_emit_def(struct ellc_st *st, struct ellc_ast *ast)
- {
- fprintf(st->f, "ELL_GEN_DEF(%s, ", ellc_mangle_glo_id(ast->def.id));
- ellc_emit_ast(st, ast->def.val);
- fprintf(st->f, ")");
- }
- static void
- ellc_emit_defp(struct ellc_st *st, struct ellc_ast *ast)
- {
- fprintf(st->f, "ELL_GEN_DEFP(%s)", ellc_mangle_glo_id(ast->defp.id));
- }
- static void
- ellc_emit_glo_set(struct ellc_st *st, struct ellc_ast *ast)
- {
- char *sid = ell_str_chars(ell_sym_name(ast->glo_set.id->sym));
- char *mid = ellc_mangle_glo_id(ast->glo_set.id);
- fprintf(st->f, "ELL_GEN_GLO_SET(%s, \"%s\", ", mid, sid);
- ellc_emit_ast(st, ast->glo_set.val);
- fprintf(st->f, ")");
- }
- static void
- ellc_emit_arg_set(struct ellc_st *st, struct ellc_ast *ast)
- {
- struct ellc_ast_arg_set *arg_set = &ast->arg_set;
- if (ellc_param_boxed(arg_set->param)) {
- fprintf(st->f, "ELL_GEN_ARG_SET_BOXED(%s, ", ellc_mangle_param_id(arg_set->param->id));
- ellc_emit_ast(st, arg_set->val);
- fprintf(st->f, ")");
- } else {
- fprintf(st->f, "ELL_GEN_ARG_SET_PLAIN(%s, ", ellc_mangle_param_id(arg_set->param->id));
- ellc_emit_ast(st, arg_set->val);
- fprintf(st->f, ")");
- }
- }
- static void
- ellc_emit_env_set(struct ellc_st *st, struct ellc_ast *ast)
- {
- struct ellc_ast_env_set *env_set = &ast->env_set;
- if (ellc_param_boxed(env_set->param)) {
- fprintf(st->f, "ELL_GEN_ENV_SET_BOXED(%s, ", ellc_mangle_env_id(env_set->param->id));
- ellc_emit_ast(st, env_set->val);
- fprintf(st->f, ")");
- } else {
- fprintf(st->f, "ELL_GEN_ENV_SET_PLAIN(%s, ", ellc_mangle_env_id(env_set->param->id));
- ellc_emit_ast(st, env_set->val);
- fprintf(st->f, ")");
- }
- }
- static void
- ellc_emit_cond(struct ellc_st *st, struct ellc_ast *ast)
- {
- fprintf(st->f, "ELL_GEN_COND(");
- ellc_emit_ast(st, ast->cond.test);
- fprintf(st->f, ", ");
- ellc_emit_ast(st, ast->cond.consequent);
- fprintf(st->f, ", ");
- ellc_emit_ast(st, ast->cond.alternative);
- fprintf(st->f, ")");
- }
- static void
- ellc_emit_seq(struct ellc_st *st, struct ellc_ast *ast)
- {
- fprintf(st->f, "({ ");
- for (lnode_t *n = list_first(ast->seq.exprs); n; n = list_next(ast->seq.exprs, n)) {
- ellc_emit_ast(st, (struct ellc_ast *) lnode_get(n));
- fprintf(st->f, "; ");
- }
- fprintf(st->f, " })");
- }
- static void
- ellc_emit_app(struct ellc_st *st, struct ellc_ast *ast)
- {
- struct ellc_ast_app *app = &ast->app;
- listcount_t npos = list_count(&app->args->pos);
- dictcount_t nkey = dict_count(&app->args->key);
- fprintf(st->f, "({");
- if (npos || nkey) {
- // evaluate arguments
- unsigned ipos = 0;
- for (lnode_t *n = list_first(&app->args->pos); n; n = list_next(&app->args->pos, n)) {
- struct ellc_ast *arg_ast = (struct ellc_ast *) lnode_get(n);
- fprintf(st->f, "struct ell_obj *__ell_pos_arg_%u = ", ipos);
- ellc_emit_ast(st, arg_ast);
- fprintf(st->f, "; ");
- ipos++;
- }
- unsigned kpos = 0;
- for (dnode_t *n = dict_first(&app->args->key); n; n = dict_next(&app->args->key, n)) {
- struct ellc_ast *arg_ast = (struct ellc_ast *) dnode_get(n);
- fprintf(st->f, "struct ell_obj *__ell_key_arg_%u = ", kpos);
- ellc_emit_ast(st, arg_ast);
- fprintf(st->f, "; ");
- kpos++;
- }
- // fill arguments array
- fprintf(st->f, "struct ell_obj *__ell_args[] = {");
- ipos = 0;
- for (lnode_t *n = list_first(&app->args->pos); n; n = list_next(&app->args->pos, n)) {
- fprintf(st->f, "__ell_pos_arg_%u, ", ipos);
- ipos++;
- }
- kpos = 0;
- for (dnode_t *n = dict_first(&app->args->key); n; n = dict_next(&app->args->key, n)) {
- struct ell_obj *arg_key_sym = (struct ell_obj *) dnode_getkey(n);
- // enh: this can be done more efficiently (intern symbols
- // used as keyword argument names at load-time)
- fprintf(st->f, "ell_intern(ell_make_str(\"%s\")), ", ell_str_chars(ell_sym_name(arg_key_sym)));
- fprintf(st->f, "__ell_key_arg_%u, ", kpos);
- kpos++;
- }
- fprintf(st->f, "}; ");
- }
- fprintf(st->f, "ell_call(");
- ellc_emit_ast(st, app->op);
- fprintf(st->f, ", %lu, %lu, %s);", npos, nkey, ((npos || nkey) ? "__ell_args" : "NULL"));
- fprintf(st->f, "})");
- }
- static void
- ellc_emit_lam(struct ellc_st *st, struct ellc_ast *ast)
- {
- /* Inside a lambda, the enclosing hygiene context is not visible,
- because it's a C local variable. Thus, setting it to off
- inside the lambda's body is needed so that the code does the
- right thing, namely, generate a new context when a new
- quasisyntax is encountered. */
- bool in_quasisyntax_tmp = st->in_quasisyntax;
- st->in_quasisyntax = 0;
- struct ellc_ast_lam *lam = &ast->lam;
- fprintf(st->f, "({ ");
- // populate env
- if (dict_count(lam->env) > 0) {
- fprintf(st->f, "struct __ell_env_%u *__lam_env = ell_alloc(sizeof(struct __ell_env_%u));",
- lam->code_id, lam->code_id);
- for (dnode_t *n = dict_first(lam->env); n; n = dict_next(lam->env, n)) {
- struct ellc_id *env_id = (struct ellc_id *) dnode_getkey(n);
- fprintf(st->f, "__lam_env->%s = ", ellc_mangle_env_id(env_id));
- struct ellc_ast *ref_ast = (struct ellc_ast *) dnode_get(n);
- /* Tricky: if a variable is boxed, the closure environment
- needs to contain the box, not the box's contents. This
- means we need to emit references specially here, so
- that they always act as if the variable was unboxed,
- even for boxed ones. */
- switch(ref_ast->type) {
- case ELLC_AST_ENV_REF:
- ellc_emit_env_ref_plain(st, ref_ast); break;
- case ELLC_AST_ARG_REF:
- ellc_emit_arg_ref_plain(st, ref_ast); break;
- default:
- ell_fail("bad closure environment reference\n");
- }
- fprintf(st->f, "; ");
- }
- }
- // create closure
- if (dict_count(lam->env) > 0) {
- fprintf(st->f, "ell_make_clo(&__ell_code_%u, __lam_env);",
- lam->code_id);
- } else {
- fprintf(st->f, "ell_make_clo(&__ell_code_%u, NULL);",
- lam->code_id);
- }
- fprintf(st->f, "})");
- st->in_quasisyntax = in_quasisyntax_tmp;
- }
- static void
- ellc_emit_loop(struct ellc_st *st, struct ellc_ast *ast)
- {
- fprintf(st->f, "ELL_GEN_LOOP(");
- ellc_emit_ast(st, ast->loop.body);
- fprintf(st->f, ")");
- }
- static void
- ellc_emit_lit_sym(struct ellc_st *st, struct ellc_ast *ast)
- {
- // kludge
- fprintf(st->f, "ell_intern(ell_make_str(\"%s\"))",
- ell_str_chars(ell_sym_name(ast->lit_sym.sym)));
- }
- static void
- ellc_emit_lit_str(struct ellc_st *st, struct ellc_ast *ast)
- {
- // kludge
- fprintf(st->f, "ell_make_str(\"%s\")",
- ell_str_chars(ast->lit_str.str));
- }
- static void
- ellc_emit_lit_num(struct ellc_st *st, struct ellc_ast *ast)
- {
- // kludge
- fprintf(st->f, "ell_make_num(\"%d\")",
- ell_num_int(ast->lit_num.num));
- }
- static void
- ellc_emit_lit_stx(struct ellc_st *st, struct ellc_ast *ast)
- {
- struct ell_obj *stx = ast->lit_stx.stx;
- if (stx->wrapper == ELL_WRAPPER(stx_sym)) {
- fprintf(st->f, "ell_make_stx_sym_cx(ell_intern(ell_make_str(\"%s\")), __ell_cur_cx)",
- ell_str_chars(ell_sym_name(ell_stx_sym_sym(stx))));
- } else if (stx->wrapper == ELL_WRAPPER(stx_str)) {
- fprintf(st->f, "ell_make_stx_str(ell_make_str(\"%s\"))",
- ell_str_chars(ell_stx_str_str(stx)));
- } else {
- ell_fail("literal syntax error\n");
- }
- }
- static void
- ellc_emit_cx(struct ellc_st *st, struct ellc_ast *ast)
- {
- if (st->in_quasisyntax) {
- ellc_emit_ast(st, ast->cx.body);
- } else {
- /* Shadow the global current hygiene context, which is always
- NULL. The trick here is that only syntax forms that are
- statically enclosed in this form will pick up this new
- context, that's shadowing the global context, since the new
- context is a C local variable. */
- st->in_quasisyntax = 1;
- fprintf(st->f, "({ struct ell_cx *__ell_cur_cx = ell_make_cx(); ");
- ellc_emit_ast(st, ast->cx.body);
- fprintf(st->f, "; })");
- st->in_quasisyntax = 0;
- }
- }
- /* Emits a body sequence containing literal strings and other
- expressions by emitting the literal strings at the top-level of the
- sequence as-is to the C output. */
- static void
- ellc_direct_emit_c_sequence(struct ellc_st *st, struct ellc_ast *body_seq)
- {
- if(body_seq->type != ELLC_AST_SEQ) {
- ell_fail("C output error\n");
- }
- list_t *exprs = body_seq->seq.exprs;
- for (lnode_t *n = list_first(exprs); n; n = list_next(exprs, n)) {
- struct ellc_ast *expr = (struct ellc_ast *) lnode_get(n);
- if (expr->type == ELLC_AST_LIT_STR) {
- fprintf(st->f, "%s", ell_str_chars(expr->lit_str.str));
- } else {
- ellc_emit_ast(st, expr);
- }
- }
- }
- static void
- ellc_emit_snip(struct ellc_st *st, struct ellc_ast *ast)
- {
- struct ellc_ast *body_seq = ast->snip.body;
- ellc_direct_emit_c_sequence(st, body_seq);
- }
- static void
- ellc_emit_stmt(struct ellc_st *st, struct ellc_ast *ast)
- {
- /* Do nothing, statements get emitted specially before everything
- else. However return something so that REPL etc is happy. */
- fprintf(st->f, "ell_unspecified");
- }
- static void
- ellc_emit_ast(struct ellc_st *st, struct ellc_ast *ast)
- {
- switch(ast->type) {
- case ELLC_AST_GLO_REF: ellc_emit_glo_ref(st, ast); break;
- case ELLC_AST_ARG_REF: ellc_emit_arg_ref(st, ast); break;
- case ELLC_AST_ENV_REF: ellc_emit_env_ref(st, ast); br…
Large files files are truncated, but you can click here to view the full file