diff options
| -rw-r--r-- | eval.c | 3 | ||||
| -rw-r--r-- | eval.h | 4 | ||||
| -rw-r--r-- | parser.l | 5 | ||||
| -rw-r--r-- | parser.y | 44 | ||||
| -rw-r--r-- | protsym.c | 2 | ||||
| -rw-r--r-- | tree.c | 492 | ||||
| -rw-r--r-- | tree.h | 5 |
7 files changed, 549 insertions, 6 deletions
@@ -81,7 +81,7 @@ val sys_mark_special_s; val caseq_s, caseql_s, casequal_s; val caseq_star_s, caseql_star_s, casequal_star_s; val memq_s, memql_s, memqual_s; -val eq_s, eql_s, equal_s; +val eq_s, eql_s, equal_s, less_s; val car_s, cdr_s, not_s, vecref_s; val setq_s, setqf_s, sys_lisp1_value_s, sys_lisp1_setq_s; val sys_l1_val_s, sys_l1_setq_s; @@ -6165,6 +6165,7 @@ void eval_init(void) eq_s = intern(lit("eq"), user_package); eql_s = intern(lit("eql"), user_package); equal_s = intern(lit("equal"), user_package); + less_s = intern(lit("less"), user_package); if_s = intern(lit("if"), user_package); when_s = intern(lit("when"), user_package); usr_var_s = intern(lit("var"), user_package); @@ -27,8 +27,8 @@ extern val dwim_s, lambda_s, progn_s, vector_lit_s, vec_list_s, list_s; extern val hash_lit_s, hash_construct_s, struct_lit_s, qref_s, uref_s; -extern val eval_error_s, if_s, call_s; -extern val eq_s, eql_s, equal_s; +extern val eval_error_s, if_s, call_s, identity_s; +extern val eq_s, eql_s, equal_s, less_s; extern val car_s, cdr_s; extern val last_form_evaled; extern val load_path_s, load_recursive_s; @@ -739,6 +739,11 @@ UONLY {U2}{U}|{U3}{U}{U}|{U4}{U}{U}{U} return HASH_N; } +<NESTED,BRACED>#T { + yylval->lineno = yyextra->lineno; + return HASH_T; +} + <NESTED,BRACED>#; { yylval->lineno = yyextra->lineno; return HASH_SEMI; @@ -69,6 +69,7 @@ static val make_expr(parser_t *, val sym, val rest, val lineno); static val check_parse_time_action(val spec_rev); static void misplaced_consing_dot_check(scanner_t *scanner, val term_atom_cons); static val uref_helper(parser_t *, val expr); +static val fname_helper(parser_t *, val name); #if YYBISON union YYSTYPE; @@ -119,7 +120,7 @@ INLINE val expand_form_ver(val form, int ver) %token <lineno> MOD MODLAST DEFINE TRY CATCH FINALLY IF %token <lineno> ERRTOK /* deliberately not used in grammar */ %token <lineno> HASH_BACKSLASH HASH_SLASH DOTDOT HASH_H HASH_S HASH_R HASH_SEMI -%token <lineno> HASH_B_QUOTE HASH_N +%token <lineno> HASH_B_QUOTE HASH_N HASH_T %token <lineno> WORDS WSPLICE QWORDS QWSPLICE %token <lineno> SECRET_ESCAPE_R SECRET_ESCAPE_E SECRET_ESCAPE_I %token <lineno> OLD_DOTDOT @@ -138,7 +139,8 @@ INLINE val expand_form_ver(val form, int ver) %type <val> output_clause define_clause try_clause catch_clauses_opt %type <val> if_clause elif_clauses_opt else_clause_opt %type <val> line elems_opt elems clause_parts_h additional_parts_h -%type <val> text texts elem var var_op modifiers vector hash struct range tnode +%type <val> text texts elem var var_op modifiers +%type <val> vector hash struct range tnode tree %type <val> exprs exprs_opt n_exprs r_exprs i_expr i_dot_expr %type <val> n_expr n_exprs_opt n_dot_expr %type <val> list dwim meta compound @@ -866,6 +868,20 @@ tnode : HASH_N list { if (gt(length($2), three)) yybadtok(yychar, lit("tree node literal")); } ; +tree : HASH_T list { val opts = first($2); + val key_fn_name = pop(&opts); + val less_fn_name = pop(&opts); + val equal_fn_name = pop(&opts); + val key_fn = fname_helper(parser, key_fn_name); + val less_fn = fname_helper(parser, less_fn_name); + val equal_fn = fname_helper(parser, equal_fn_name); + val tr = tree(rest($2), key_fn, + less_fn, equal_fn); + $$ = rl(tr, num($1)); } + | HASH_T error { $$ = nil; + yybadtok(yychar, lit("tree node literal")); } + ; + list : '(' n_exprs ')' { $$ = rl($2, num($1)); } | '(' '.' n_exprs ')' { val a = car($3); val ur = uref_helper(parser, a); @@ -971,6 +987,7 @@ i_expr : SYMTOK { $$ = ifnign(symhlpr($1, t)); } | struct { $$ = $1; } | range { $$ = $1; } | tnode { $$ = $1; } + | tree { $$ = $1; } | lisp_regex { $$ = $1; } | chrlit { $$ = $1; } | strlit { $$ = $1; } @@ -1011,6 +1028,7 @@ n_expr : SYMTOK { $$ = ifnign(symhlpr($1, t)); } | struct { $$ = $1; } | range { $$ = $1; } | tnode { $$ = $1; } + | tree { $$ = $1; } | lisp_regex { $$ = $1; } | chrlit { $$ = $1; } | strlit { $$ = $1; } @@ -1768,6 +1786,27 @@ static val uref_helper(parser_t *parser, val expr) } } +static val fname_helper(parser_t *parser, val name) +{ + if (!name) { + return nil; + } else if (!bindable(name)) { + yyerrorf(parser->scanner, lit("#T: ~s isn't a function name"), + name, nao); + } else if (!memq(name, tree_fun_whitelist)) { + yyerrorf(parser->scanner, lit("#T: ~s not in *tree-fun-whitelist*"), + name, nao); + } else { + val fbinding = lookup_fun(nil, name); + if (fbinding) + return cdr(fbinding); + yyerrorf(parser->scanner, lit("#T: function named ~s doesn't exist"), + name, nao); + } + + return nil; +} + #ifndef YYEOF #define YYEOF 0 #endif @@ -1824,6 +1863,7 @@ void yybadtoken(parser_t *parser, int tok, val context) case HASH_S: problem = lit("#S"); break; case HASH_R: problem = lit("#R"); break; case HASH_N: problem = lit("#N"); break; + case HASH_T: problem = lit("#T"); break; case HASH_SEMI: problem = lit("#;"); break; case HASH_N_EQUALS: problem = lit("#<n>="); break; case HASH_N_HASH: problem = lit("#<n>#"); break; @@ -57,7 +57,7 @@ extern val dev_k, dev_s, digit_k, div_s, do_s; extern val dohash_s, double_s, downcase_k, dst_s, dvbind_s; extern val dwim_s, each_op_s, each_s, each_star_s, elemtype_s; extern val elif_s, else_s, empty_s, enum_s, enumed_s; -extern val env_k, env_s, eof_s, eol_s, eq_s; +extern val env_k, env_s, eof_s, eol_s, eq_s, less_s; extern val eql_based_k, eql_s, equal_based_k, equal_s, error_s; extern val eval_error_s, eval_only_s, evenp_s, exp_s, expr_s; extern val expt_s, exptmod_s, fail_s, fbind_s, fd_k; @@ -47,8 +47,39 @@ #include "eval.h" #include "itypes.h" #include "arith.h" +#include "hash.h" #include "tree.h" +#if SIZEOF_PTR == 4 +#define TREE_DEPTH_MAX 28 +#elif SIZEOF_PTR == 8 +#define TREE_DEPTH_MAX 60 +#else +#error portme +#endif + +struct tree { + val root; + ucnum size, max_size; + val key_fn, less_fn, equal_fn; + val key_fn_name, less_fn_name, equal_fn_name; +}; + +enum tree_iter_state { + tr_visited_nothing, + tr_visited_left +}; + +struct tree_iter { + int depth; + enum tree_iter_state state; + val path[TREE_DEPTH_MAX]; +}; + +#define tree_iter_init() { 0, tr_visited_nothing } + +val tree_s, tree_fun_whitelist_s; + val tnode(val key, val left, val right) { val obj = make_obj(); @@ -82,10 +113,471 @@ val key(val node) return node->tn.key; } +static ucnum tn_size(val node) +{ + return 1 + if3(node->tn.right, tn_size(node->tn.right), 0) + + if3(node->tn.left, tn_size(node->tn.left), 0); +} + +static ucnum tn_size_one_child(val node, val child, ucnum size) +{ + return 1 + size + if3(child == node->tn.left, + if3(node->tn.right, tn_size(node->tn.right), 0), + if3(node->tn.left, tn_size(node->tn.left), 0)); +} + +static val tn_lookup(struct tree *tr, val node, val key) +{ + val tn_key = if3(tr->key_fn, + funcall1(tr->key_fn, node->tn.key), + node->tn.key); + + if (if3(tr->less_fn, + funcall2(tr->less_fn, key, tn_key), + less(key, tn_key))) + { + return if2(node->tn.left, tn_lookup(tr, node->tn.left, key)); + } else if (if3(tr->equal_fn == nil, + equal(key, tn_key), + funcall2(tr->equal_fn, key, tn_key))) { + return node; + } else { + return if2(node->tn.left, tn_lookup(tr, node->tn.left, key)); + } +} + +static val tn_find_next(val node, struct tree_iter *trit) +{ + for (;;) { + switch (trit->state) { + case tr_visited_nothing: + if (!node) + return nil; + while (node->tn.left) { + bug_unless (trit->depth < TREE_DEPTH_MAX); + trit->path[trit->depth++] = node; + node = node->tn.left; + } + trit->state = tr_visited_left; + return node; + case tr_visited_left: + if (node->tn.right) { + trit->state = tr_visited_nothing; + node = node->tn.right; + continue; + } else { + while (trit->depth > 0) { + val parent = trit->path[--trit->depth]; + if (node == parent->tn.right) { + node = parent; + continue; + } + trit->state = tr_visited_left; + return parent; + } + return nil; + } + default: + internal_error("invalid tree iterator state"); + } + } +} + +static val tn_flatten(val x, val y) +{ + if (x == nil) + return y; + x->tn.right = tn_flatten(x->tn.right, y); + return tn_flatten(x->tn.left, x); +} + +static val tn_build_tree(ucnum n, val x) +{ + if (n == 0) { + x->tn.left = nil; + return x; + } else { + val r = tn_build_tree(n / 2, x); + val s = tn_build_tree((n - 1) / 2, r->tn.right); + + r->tn.right = s->tn.left; + s->tn.left = r; + + return s; + } +} + +static void tr_rebuild(struct tree *tr, val node, val parent, ucnum size) +{ + obj_t dummy = { { TNOD } }; + val flat = tn_flatten(node, &dummy); + val new_root = (tn_build_tree(size, flat), dummy.tn.left); + + if (parent) { + if (parent->tn.left == node) + parent->tn.left = new_root; + else + parent->tn.right = new_root; + } else { + tr->root = new_root; + } +} + +static void tr_find_rebuild_scapegoat(struct tree *tr, struct tree_iter *ti, + val child, ucnum child_size) +{ + val parent = ti->path[--ti->depth]; + ucnum parent_size = tn_size_one_child(parent, child, child_size); + ucnum sib_size = parent_size - child_size; + + if (2 * child_size > parent_size || 2 * sib_size > parent_size) + tr_rebuild(tr, parent, ti->path[ti->depth - 1], parent_size); + else + tr_find_rebuild_scapegoat(tr, ti, parent, parent_size); +} + +static void tr_insert(struct tree *tr, struct tree_iter *ti, + val subtree, val node) +{ + val key = node->tn.key; + val tn_key = if3(tr->key_fn, + funcall1(tr->key_fn, subtree->tn.key), + subtree->tn.key); + + if (if3(tr->less_fn, + funcall2(tr->less_fn, key, tn_key), + less(key, tn_key))) + { + if (subtree->tn.left) { + ti->path[ti->depth++] = subtree; + tr_insert(tr, ti, subtree->tn.left, node); + } else { + int dep = ti->depth + 1; + subtree->tn.left = node; + if (subtree->tn.right == nil && (((ucnum) 1) << dep) > tr->size) { + ti->path[ti->depth++] = subtree; + tr_find_rebuild_scapegoat(tr, ti, node, 1); + } + } + } else if (if3(tr->equal_fn == nil, + equal(key, tn_key), + funcall2(tr->equal_fn, key, tn_key))) { + val parent = ti->path[ti->depth - 1]; + node->tn.left = subtree->tn.left; + node->tn.right = subtree->tn.right; + + if (parent->tn.left == subtree) + parent->tn.left = node; + else + parent->tn.right = node; + } else { + if (subtree->tn.right) { + ti->path[ti->depth++] = subtree; + tr_insert(tr, ti, subtree->tn.right, node); + } else { + int dep = ti->depth + 1; + subtree->tn.right = node; + if (subtree->tn.left == nil && (((ucnum) 1) << dep) > tr->size) { + ti->path[ti->depth++] = subtree; + tr_find_rebuild_scapegoat(tr, ti, node, 1); + } + } + } +} + +static val tr_lookup(struct tree *tree, val key) +{ + return if2(tree->root, tn_lookup(tree, tree->root, key)); +} + +static val tr_do_delete(struct tree *tr, val subtree, val parent, val key) +{ + val tn_key = if3(tr->key_fn, + funcall1(tr->key_fn, subtree->tn.key), + subtree->tn.key); + + if (if3(tr->less_fn, + funcall2(tr->less_fn, key, tn_key), + less(key, tn_key))) + { + if (subtree->tn.left) + return tr_do_delete(tr, subtree->tn.left, subtree, key); + return nil; + } else if (if3(tr->equal_fn == nil, + equal(key, tn_key), + funcall2(tr->equal_fn, key, tn_key))) { + val le = subtree->tn.left; + val ri = subtree->tn.right; + + if (le && ri) { + struct tree_iter trit = tree_iter_init(); + val succ = tn_find_next(ri, &trit); + val succ_par = if3(trit.depth, trit.path[trit.depth - 1], subtree); + + if (succ_par == subtree) + succ_par->tn.right = succ->tn.right; + else + succ_par->tn.left = succ->tn.right; + + succ->tn.left = subtree->tn.left; + succ->tn.right = subtree->tn.right; + + if (parent) { + if (parent->tn.left == subtree) + parent->tn.left = succ; + else + parent->tn.right = succ; + } else { + tr->root = succ; + } + } else { + uses_or2; + val chld = or2(le, ri); + + if (parent) { + if (parent->tn.left == subtree) + parent->tn.left = chld; + else + parent->tn.right = chld; + } else { + tr->root = chld; + } + } + + subtree->tn.left = subtree->tn.right = nil; + return subtree; + } else { + if (subtree->tn.right) + return tr_do_delete(tr, subtree->tn.right, subtree, key); + return nil; + } +} + +static val tr_delete(struct tree *tr, val key) +{ + if (tr->root) { + val node = tr_do_delete(tr, tr->root, nil, key); + if (node) { + if (2 * --tr->size < tr->max_size) { + tr_rebuild(tr, tr->root, nil, tr->size); + tr->max_size = tr->size; + } + } + return node; + } + + return nil; +} + +static val tree_insert_node(val tree, val node) +{ + val self = lit("tree-insert-node"); + struct tree *tr = coerce(struct tree *, cobj_handle(self, tree, tree_s)); + + type_check(self, node, TNOD); + + if (tr->root == nil) { + tr->size = 1; + tr->max_size = 1; + tr->root = node; + } else { + struct tree_iter ti = tree_iter_init(); + if (++tr->size > tr->max_size) + tr->max_size = tr->size; + tr_insert(tr, &ti, tr->root, node); + } + + return node; +} + +static val tree_insert(val tree, val key) +{ + return tree_insert_node(tree, tnode(key, nil, nil)); +} + +static val tree_lookup_node(val tree, val key) +{ + val self = lit("tree-lookup-node"); + struct tree *tr = coerce(struct tree *, cobj_handle(self, tree, tree_s)); + return tr_lookup(tr, key); +} + +static val tree_lookup(val tree, val key) +{ + val node = tree_lookup_node(tree, key); + return if2(node, node->tn.key); +} + +static val tree_delete(val tree, val key) +{ + val self = lit("tree-delete"); + struct tree *tr = coerce(struct tree *, cobj_handle(self, tree, tree_s)); + return tr_delete(tr, key); +} + +static val tree_root(val tree) +{ + val self = lit("tree-root"); + struct tree *tr = coerce(struct tree *, cobj_handle(self, tree, tree_s)); + return tr->root; +} + +static val tree_equal_op(val left, val right) +{ + val self = lit("equal"); + struct tree *ltr = coerce(struct tree *, cobj_handle(self, left, tree_s)); + struct tree *rtr = coerce(struct tree *, cobj_handle(self, right, tree_s)); + + if (ltr->size != rtr->size) + return nil; + + if (ltr->key_fn != rtr->key_fn) + return nil; + + if (ltr->less_fn != rtr->less_fn) + return nil; + + if (ltr->equal_fn != rtr->equal_fn) + return nil; + + { + struct tree_iter liter = tree_iter_init(), riter = tree_iter_init(); + val lnode = ltr->root, rnode = rtr->root; + + while ((lnode = tn_find_next(lnode, &liter)) && + (rnode = tn_find_next(rnode, &riter))) + { + if (!equal(lnode->tn.key, rnode->tn.key)) + return nil; + } + + return t; + } +} + +static void tree_print_op(val tree, val out, val pretty, struct strm_ctx *ctx) +{ + struct tree *tr = coerce(struct tree *, tree->co.handle); + val save_mode = test_set_indent_mode(out, num_fast(indent_off), + num_fast(indent_data)); + val save_indent; + int force_br = 0; + + put_string(lit("#T("), out); + + save_indent = inc_indent(out, zero); + put_char(chr('('), out); + if (tr->key_fn_name || tr->less_fn_name || tr->equal_fn_name) { + obj_print_impl(tr->key_fn_name, out, pretty, ctx); + if (tr->less_fn_name || tr->equal_fn_name) { + put_char(chr(' '), out); + obj_print_impl(tr->less_fn_name, out, pretty, ctx); + if (tr->equal_fn_name) { + put_char(chr(' '), out); + obj_print_impl(tr->equal_fn_name, out, pretty, ctx); + } + } + } + put_char(chr(')'), out); + + { + struct tree_iter trit = tree_iter_init(); + val node = tr->root; + + while ((node = tn_find_next(node, &trit))) { + if (width_check(out, chr(' '))) + force_br = 1; + obj_print_impl(node->tn.key, out, pretty, ctx); + } + } + + put_char(chr(')'), out); + + if (force_br) + force_break(out); + + set_indent_mode(out, save_mode); + set_indent(out, save_indent); +} + +static void tree_mark(val tree) +{ + struct tree *ltr = coerce(struct tree *, tree->co.handle); + gc_mark(ltr->root); + gc_mark(ltr->key_fn); + gc_mark(ltr->less_fn); + gc_mark(ltr->equal_fn); + gc_mark(ltr->key_fn_name); + gc_mark(ltr->less_fn_name); + gc_mark(ltr->equal_fn_name); +} + +static ucnum tree_hash_op(val obj, int *count, ucnum seed) +{ + struct tree *tr = coerce(struct tree *, obj->co.handle); + ucnum hash = 0; + + if ((*count)-- <= 0) + return hash; + + hash += equal_hash(tr->key_fn, count, seed); + hash += equal_hash(tr->less_fn, count, seed); + hash += equal_hash(tr->equal_fn, count, seed); + + { + struct tree_iter trit = tree_iter_init(); + val node = tr->root; + + while ((node = tn_find_next(node, &trit)) && (*count)-- <= 0) + hash += equal_hash(node->tn.key, count, seed); + } + + return hash; +} + +static struct cobj_ops tree_ops = cobj_ops_init(tree_equal_op, + tree_print_op, + cobj_destroy_free_op, + tree_mark, + tree_hash_op); + +val tree(val keys_in, val key_fn, val less_fn, val equal_fn) +{ + struct tree *tr = coerce(struct tree *, chk_calloc(1, sizeof *tr)); + val keys = default_null_arg(keys_in), key; + val tree = cobj(coerce(mem_t *, tr), tree_s, &tree_ops); + seq_iter_t ki; + + tr->key_fn = default_null_arg(key_fn); + tr->less_fn = default_null_arg(less_fn); + tr->equal_fn = default_null_arg(equal_fn); + + tr->key_fn_name = if2(tr->key_fn, func_get_name(tr->key_fn, nil)); + tr->less_fn_name = if2(tr->less_fn, func_get_name(tr->less_fn, nil)); + tr->equal_fn_name = if2(tr->equal_fn, func_get_name(tr->equal_fn, nil)); + + seq_iter_init(tree_s, &ki, keys); + + while (seq_get(&ki, &key)) + tree_insert(tree, key); + + return tree; +} + void tree_init(void) { + tree_s = intern(lit("tree"), user_package); + tree_fun_whitelist_s = intern(lit("*tree-fun-whitelist*"), user_package); reg_fun(tnode_s, func_n3(tnode)); reg_fun(intern(lit("left"), user_package), func_n1(left)); reg_fun(intern(lit("right"), user_package), func_n1(right)); reg_fun(intern(lit("key"), user_package), func_n1(key)); + reg_fun(tree_s, func_n4o(tree, 0)); + reg_fun(intern(lit("tree-insert-node"), user_package), func_n2(tree_insert_node)); + reg_fun(intern(lit("tree-insert"), user_package), func_n2(tree_insert)); + reg_fun(intern(lit("tree-lookup-node"), user_package), func_n2(tree_lookup_node)); + reg_fun(intern(lit("tree-lookup"), user_package), func_n2(tree_lookup)); + reg_fun(intern(lit("tree-delete"), user_package), func_n2(tree_delete)); + reg_fun(intern(lit("tree-root"), user_package), func_n1(tree_root)); + reg_var(tree_fun_whitelist_s, list(identity_s, equal_s, less_s, nao)); } @@ -25,9 +25,14 @@ * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ +extern val tree_s, tree_fun_whitelist_s; + +#define tree_fun_whitelist (deref(lookup_var_l(nil, tree_fun_whitelist_s))) + val tnode(val key, val left, val right); val tnodep(val obj); val left(val node); val right(val node); val key(val node); +val tree(val keys, val key_fn, val less_fn, val equal_fn); void tree_init(void); |