summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog90
-rw-r--r--Makefile2
-rw-r--r--dep.mk1
-rw-r--r--eval.c589
-rw-r--r--eval.h38
-rw-r--r--gc.c7
-rw-r--r--hash.c29
-rw-r--r--hash.h2
-rw-r--r--lib.c571
-rw-r--r--lib.h70
-rw-r--r--match.c97
-rw-r--r--parser.l12
-rw-r--r--stream.c5
-rw-r--r--txr.vim10
-rw-r--r--unwind.c2
-rw-r--r--unwind.h4
16 files changed, 1360 insertions, 169 deletions
diff --git a/ChangeLog b/ChangeLog
index 73ec56fd..4b8e6c3e 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,93 @@
+2011-11-26 Kaz Kylheku <kaz@kylheku.com>
+
+ Task #11436
+
+ Lisp interpreter added.
+
+ * gc.c (finalize, mark_obj): Handle ENV objects.
+
+ * hash.c (struct hash): acons_new_l_fun function
+ pointer order of arguments change.
+ (equal_hash): Handle ENV.
+ (make_hash, gethash_l): Use cobj_handle for
+ type safety. Follow change in acons_new_l.
+ (gethash, gethash_f, remhash, hash_count,
+ hash_get_userdata, hash_set_userdata, hash_next): Use cobj_handle.
+ (gethash_n): New function.
+
+ * hash.h (gethash_n): Declared.
+
+ * lib.c (env_s): New symbol variable.
+ (code2type, equal): Handle ENV. (plusv, minusv, mul, mulv, trunc, mod,
+ gtv, ltv, gev, lev, maxv, minv, int_str): New functions.
+ (rehome_sym): New static function.
+ (func_f0, func_f1, func_f2, func_f3, func_f4, func_n0, func_n1,
+ func_n2, func_n3, func_n4): Initialize new fields of struct func.
+ (func_f0v, func_f1v, func_f2v, func_f3v, func_f4v,
+ func_n0v, func_n1v, func_n2v, func_n3v, func_n4v,
+ func_interp): New functions.
+ (apply): Function removed: sanely re-implemented in new eval.c file.
+ (funcall, funcall1, funcall2, funcall3, funcall4): Handle
+ variadic and interpreted functions.
+ (acons, acons_new, acons_new_l, aconsq_new, aconsq_new_l): Reordered
+ arguments for compatibility with Common Lisp acons.
+ (obj_init): Special hack to prepare hash_s symbol, which is
+ needed for type checking inside the hash table funtions invoked
+ by make_package, at a time when the symbol is not yet interned.
+ Initialize new env_s variable.
+ (obj_print, obj_pprint): Handle ENV. Fix confusing rendering of
+ of function type.
+ (init): Call new function eval_init.
+
+ * lib.h (enum type): New enumeration member ENV.
+ (struct func): functype member changed to bitfield.
+ New bitfied members minparam and variadic.
+ New members in f union: f0v, f1v, f2v, f3v,
+ f4v, n0v, n1v, n2v, n3v, n4v.
+ (struct env): New type.
+ (union obj): New member e of type struct env.
+ (env_s): Variable declared.
+ (plusv, minusv, mul, mulv, trunc, mod, gtv, ltv, gev, lev, maxv, minv,
+ int_str): New functions declared.
+ (func_f0v, func_f1v, func_f2v, func_f3v, func_f4v,
+ func_n0v, func_n1v, func_n2v, func_n3v, func_n4v,
+ func_interp): Likewise.
+ (apply): Declaration removed, and re-introduced in eval.h.
+ (acons, acons_new, acons_new_l, aconsq_new, aconsq_new_l): Declarations
+ updated to new argument order.
+
+ * match.c (bindable): static function moved to eval.c, where
+ it becomes external.
+ (h_var, h_coll, h_parallel, h_fun, v_parallel, v_gather,
+ v_collect, v_merge, v_fun): Follows argument order change in
+ acons functions.
+ (subst_vars): Print atoms other than strings.
+ (eval_form): Support @(...) syntax for evaluating Lisp forms.
+ (v_do, h_do): New functions.
+ (dir_tables_init): Insert v_do and h_do into tables.
+
+ * parser.l: Token syntax for numbers and symbols merged.
+ Symbols in a nested context can consist of various additional
+ characters. Useless code removed from action for '('/METAPAR.
+
+ * stream.c (format): Bugfix in type checking, in the
+ case that the stream argument is nil and defaults to a string stream.
+
+ * txr.vim: Updated for new token syntax. Fixed uses of
+ unescaped + operator.
+
+ * unwind.c (uw_set_func)
+ * unwind.h (numeric_assert, range_bug_unless): Missing
+ whitespace in message added.
+
+ * Makefile (OBJS): eval.o added.
+
+ * dep.mk: Updated.
+
+ * eval.c: New file.
+
+ * eval.h: New file.
+
2011-11-24 Kaz Kylheku <kaz@kylheku.com>
* lib.c (getplist_f): New function.
diff --git a/Makefile b/Makefile
index db6c3c13..3f74ec64 100644
--- a/Makefile
+++ b/Makefile
@@ -37,7 +37,7 @@ CFLAGS := $(filter-out -Wmissing-prototypes -Wstrict-prototypes,$(CFLAGS))
endif
OBJS := txr.o lex.yy.o y.tab.o match.o lib.o regex.o gc.o unwind.o stream.o
-OBJS += hash.o utf8.o filter.o debug.o
+OBJS += hash.o utf8.o filter.o debug.o eval.o
PROG := ./txr
diff --git a/dep.mk b/dep.mk
index ea77d1c2..3b5cc922 100644
--- a/dep.mk
+++ b/dep.mk
@@ -11,3 +11,4 @@ hash.o: config.h $(top_srcdir)/lib.h $(top_srcdir)/gc.h $(top_srcdir)/unwind.h $
utf8.o: config.h $(top_srcdir)/lib.h $(top_srcdir)/unwind.h $(top_srcdir)/utf8.h
filter.o: config.h $(top_srcdir)/lib.h $(top_srcdir)/hash.h $(top_srcdir)/unwind.h $(top_srcdir)/match.h $(top_srcdir)/filter.h $(top_srcdir)/gc.h
debug.o: config.h $(top_srcdir)/lib.h $(top_srcdir)/debug.h $(top_srcdir)/gc.h $(top_srcdir)/unwind.h $(top_srcdir)/stream.h $(top_srcdir)/parser.h
+eval.o: $(top_srcdir)/lib.h config.h $(top_srcdir)/lib.h $(top_srcdir)/gc.h $(top_srcdir)/unwind.h
diff --git a/eval.c b/eval.c
new file mode 100644
index 00000000..d97e9ae6
--- /dev/null
+++ b/eval.c
@@ -0,0 +1,589 @@
+/* Copyright 2011
+ * Kaz Kylheku <kaz@kylheku.com>
+ * Vancouver, Canada
+ * All rights reserved.
+ *
+ * BSD License:
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in
+ * the documentation and/or other materials provided with the
+ * distribution.
+ * 3. The name of the author may not be used to endorse or promote
+ * products derived from this software without specific prior
+ * written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
+ * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
+ * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+ */
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <errno.h>
+#include <dirent.h>
+#include <setjmp.h>
+#include <stdarg.h>
+#include <wchar.h>
+#include "config.h"
+#include "lib.h"
+#include "gc.h"
+#include "unwind.h"
+#include "regex.h"
+#include "stream.h"
+#include "parser.h"
+#include "hash.h"
+#include "debug.h"
+#include "eval.h"
+
+typedef val (*opfun_t)(val, val);
+
+val eval_error_s;
+
+val inc_s, dec_s, push_s, pop_s;
+val gethash_s;
+
+val top_vb, top_fb;
+val op_table;
+
+val make_env(val vbindings, val fbindings, val up_env)
+{
+ val env = make_obj();
+ env->e.type = ENV;
+ env->e.fbindings = fbindings;
+ env->e.vbindings = vbindings;
+ env->e.up_env = up_env;
+ return env;
+}
+
+val env_fbind(val env, val sym, val fun)
+{
+ type_check(env, ENV);
+ env->e.fbindings = acons_new(sym, fun, env->e.fbindings);
+ return sym;
+}
+
+val env_vbind(val env, val sym, val obj)
+{
+ type_check(env, ENV);
+ env->e.vbindings = acons_new(sym, obj, env->e.vbindings);
+ return sym;
+}
+
+static val eval_error(val form, val fmt, ...)
+{
+ va_list vl;
+ val stream = make_string_output_stream();
+
+ va_start (vl, fmt);
+ if (form)
+ format(stream, lit("(~a:~a) "), spec_file_str, source_loc(form), nao);
+ (void) vformat(stream, fmt, vl);
+ va_end (vl);
+
+ uw_throw(eval_error_s, get_string_from_stream(stream));
+ abort();
+}
+
+val lookup_var(val env, val sym)
+{
+ if (nullp(env)) {
+ return gethash(top_vb, sym);
+ } else {
+ type_check(env, ENV);
+
+ {
+ val binding = assoc(env->e.vbindings, sym);
+ if (binding)
+ return binding;
+ return lookup_var(env->e.up_env, sym);
+ }
+ }
+}
+
+val lookup_fun(val env, val sym)
+{
+ if (nullp(env)) {
+ return gethash(top_fb, sym);
+ } else {
+ type_check(env, ENV);
+
+ {
+ val binding = assoc(env->e.fbindings, sym);
+ if (binding)
+ return binding;
+ return lookup_fun(env->e.up_env, sym);
+ }
+ }
+}
+
+static val bind_args(val env, val params, val args, val ctx_form)
+{
+ val new_bindings = nil;
+
+ for (; args && consp(params); args = cdr(args), params = cdr(params)) {
+ val arg = car(args);
+ val param = car(params);
+
+ if (!bindable(param))
+ eval_error(ctx_form, lit("~a: ~s is not a bindable sybol"),
+ car(ctx_form), param, nao);
+
+ new_bindings = acons(param, arg, new_bindings);
+ }
+
+ if (bindable(params)) {
+ val param = params;
+ if (!bindable(param)) {
+ eval_error(ctx_form, lit("~a: ~s is not a bindable sybol"),
+ car(ctx_form), param, nao);
+ } else {
+ new_bindings = acons(param, args, new_bindings);
+ }
+ } else if (consp(params)) {
+ eval_error(ctx_form, lit("~s: too few arguments"), car(ctx_form), nao);
+ } else if (args) {
+ eval_error(ctx_form, lit("~s: too many arguments"), car(ctx_form), nao);
+ }
+
+ return make_env(new_bindings, 0, env);
+}
+
+val apply(val fun, val arglist, val ctx_form)
+{
+ val arg[32], *p = arg;
+ int variadic, minparam, nargs;
+
+ type_check (fun, FUN);
+
+ type_assert (listp(arglist),
+ (lit("apply arglist ~s is not a list"), arglist, nao));
+
+ variadic = fun->f.variadic;
+ minparam = fun->f.minparam;
+
+ if (!variadic) {
+ for (; arglist; arglist = cdr(arglist))
+ *p++ = car(arglist);
+
+ nargs = p - arg;
+
+ if (nargs != minparam)
+ eval_error(ctx_form, lit("apply: wrong number of arguments"), nao);
+
+ switch (fun->f.functype) {
+ case F0:
+ return fun->f.f.f0(fun->f.env);
+ case F1:
+ return fun->f.f.f1(fun->f.env, arg[0]);
+ case F2:
+ return fun->f.f.f2(fun->f.env, arg[0], arg[1]);
+ case F3:
+ return fun->f.f.f3(fun->f.env, arg[0], arg[1], arg[2]);
+ case F4:
+ return fun->f.f.f4(fun->f.env, arg[0], arg[1], arg[2], arg[3]);
+ case N0:
+ return fun->f.f.n0();
+ case N1:
+ return fun->f.f.n1(arg[0]);
+ case N2:
+ return fun->f.f.n2(arg[0], arg[1]);
+ case N3:
+ return fun->f.f.n3(arg[0], arg[1], arg[2]);
+ case N4:
+ return fun->f.f.n4(arg[0], arg[1], arg[2], arg[3]);
+ case FINTERP:
+ internal_error("unsupported function type");
+ }
+ } else {
+ for (; arglist && p - arg < minparam; arglist = cdr(arglist))
+ *p++ = car(arglist);
+
+ nargs = p - arg;
+
+ if (nargs < minparam)
+ eval_error(ctx_form, lit("apply: too few arguments"), nao);
+
+ switch (fun->f.functype) {
+ case FINTERP:
+ return interp_fun(fun->f.env, fun->f.f.interp_fun, arglist);
+ case F0:
+ return fun->f.f.f0v(fun->f.env, arglist);
+ case F1:
+ return fun->f.f.f1v(fun->f.env, arg[0], arglist);
+ case F2:
+ return fun->f.f.f2v(fun->f.env, arg[0], arg[1], arglist);
+ case F3:
+ return fun->f.f.f3v(fun->f.env, arg[0], arg[1], arg[2], arglist);
+ case F4:
+ return fun->f.f.f4v(fun->f.env, arg[0], arg[1], arg[2], arg[3], arglist);
+ case N0:
+ return fun->f.f.n0v(arglist);
+ case N1:
+ return fun->f.f.n1v(arg[0], arglist);
+ case N2:
+ return fun->f.f.n2v(arg[0], arg[1], arglist);
+ case N3:
+ return fun->f.f.n3v(arg[0], arg[1], arg[2], arglist);
+ case N4:
+ return fun->f.f.n4v(arg[0], arg[1], arg[2], arg[3], arglist);
+ }
+ }
+
+ internal_error("corrupt function type field");
+}
+
+static val eval_args(val form, val env, val ctx_form)
+{
+ list_collect_decl (values, ptail);
+ for (; form; form = cdr(form))
+ list_collect(ptail, eval(car(form), env, ctx_form));
+ return values;
+}
+
+val interp_fun(val env, val fun, val args)
+{
+ val def = cdr(fun);
+ val params = car(def);
+ val body = cdr(def);
+ val ev_args = eval_args(args, env, args);
+ val fun_env = bind_args(env, params, ev_args, fun);
+ return eval_progn(body, fun_env, body);
+}
+
+val eval(val form, val env, val ctx_form)
+{
+ type_check(env, ENV);
+ debug_check(consp(form) ? form : ctx_form, env->e.vbindings, nil, nil, nil);
+
+ if (nullp(form)) {
+ return nil;
+ } else if (symbolp(form)) {
+ if (!bindable(form)) {
+ return form;
+ } else {
+ val binding = lookup_var(env, form);
+ if (binding)
+ return cdr(binding);
+ eval_error(ctx_form, lit("unbound variable ~s"), form, nao);
+ abort();
+ }
+ } else if (consp(form)) {
+ val oper = car(form);
+
+ if (regexp(oper))
+ return oper;
+
+ {
+ val fbinding = lookup_fun(env, oper);
+
+ if (fbinding) {
+ return apply(cdr(fbinding),
+ eval_args(rest(form), env, form),
+ form);
+ } else {
+ val entry = gethash(op_table, oper);
+
+ if (!entry) {
+ eval_error(form, lit("no such function or operator: ~s"), oper, nao);
+ abort();
+ } else {
+ opfun_t fp = (opfun_t) cptr_get(entry);
+ return fp(form, env);
+ }
+ }
+ }
+ } else {
+ return form;
+ }
+}
+
+val bindable(val obj)
+{
+ return (obj && symbolp(obj) && obj != t && !keywordp(obj)) ? t : nil;
+}
+
+val eval_progn(val forms, val env, val ctx_form)
+{
+ val retval = nil;
+
+ for (; forms; forms = cdr(forms))
+ retval = eval(car(forms), env, ctx_form);
+
+ return retval;
+}
+
+static val op_let(val form, val env)
+{
+ val args = rest(form);
+ val vars = first(args);
+ val body = rest(args);
+ val iter;
+ list_collect_decl (new_bindings, ptail);
+
+ for (iter = vars; iter; iter = cdr(iter)) {
+ val item = car(iter);
+ val var, val = nil;
+
+ if (consp(item)) {
+ if (!consp(cdr(item)))
+ eval_error(form, lit("let: invalid syntax: ~s"), item, nao);
+ var = first(item);
+ val = second(item);
+ }
+
+ if (symbolp(var)) {
+ if (!bindable(var))
+ eval_error(form, lit("let: ~s is not a bindable sybol"), var, nao);
+ }
+
+ list_collect (ptail, cons(var, val));
+ }
+
+ return eval_progn(body, make_env(new_bindings, 0, env), form);
+}
+
+static val op_lambda(val form, val env)
+{
+ return func_interp(env, form);
+}
+
+static val op_call(val form, val env)
+{
+ val args = rest(form);
+ val func_form = first(args);
+ val func = eval(func_form, env, form);
+
+ if (functionp(func)) {
+ return apply(func, eval_args(rest(args), env, form), form);
+ } else if (symbolp(func)) {
+ val binding = gethash(top_vb, func);
+ if (binding)
+ return apply(cdr(binding), eval_args(rest(args), env, form), form);
+ eval_error(form, lit("call: no such function ~s"), form, nao);
+ } else {
+ eval_error(form, lit("call: ~s is not a funcallable object"), form, nao);
+ }
+ abort();
+}
+
+static val op_cond(val form, val env)
+{
+ val iter = rest(form);
+
+ for (; iter; iter = cdr(iter)) {
+ val pair = car(iter);
+ if (eval(first(pair), env, form))
+ return eval_progn(rest(pair), env, pair);
+ }
+
+ return nil;
+}
+
+static val op_if(val form, val env)
+{
+ val args = rest(form);
+
+ return if3(eval(first(args), env, form),
+ eval(second(args), env, form),
+ eval(third(args), env, form));
+}
+
+static val op_and(val form, val env)
+{
+ val args = rest(form);
+ val result = t;
+
+ for (; args; args = cdr(args))
+ if (!(result = eval(first(args), env, form)))
+ return nil;
+
+ return result;
+}
+
+static val op_or(val form, val env)
+{
+ val args = rest(form);
+
+ for (; args; args = cdr(args)) {
+ val result;
+ if ((result = eval(first(args), env, form)))
+ return result;
+ }
+
+ return nil;
+}
+
+static val op_defvar(val form, val env)
+{
+ val args = rest(form);
+ val sym = first(args);
+
+ if (!bindable(sym))
+ eval_error(form, lit("let: ~s is not a bindable sybol"), sym, nao);
+
+ {
+ val value = eval(second(args), env, form);
+ val existing = gethash(top_vb, sym);
+
+ if (existing)
+ *cdr_l(existing) = value;
+ else
+ sethash(top_vb, sym, cons(sym, value));
+ }
+
+ return sym;
+}
+
+static val op_defun(val form, val env)
+{
+ val args = rest(form);
+ val name = first(args);
+ val params = second(args);
+
+ if (!bindable(name))
+ eval_error(form, lit("defun: ~s is not a bindable sybol"), name, nao);
+
+ if (!all_satisfy(params, func_n1(bindable), nil))
+ eval_error(form, lit("defun: arguments must be bindable symbols"), nao);
+
+ /* defun captures lexical environment, so env is passed */
+ sethash(top_fb, name, cons(name, func_interp(env, args)));
+ return name;
+}
+
+static val op_modplace(val form, val env)
+{
+ val op = first(form);
+ val place = second(form);
+ val inc = or2(eval(third(form), env, form), num(1));
+ val *loc = 0;
+ val binding = nil;
+
+ if (symbolp(place)) {
+ if (!bindable(place))
+ eval_error(form, lit("~a: ~s is not a bindable sybol"), op, place, nao);
+ binding = lookup_var(env, place);
+ if (!binding)
+ eval_error(form, lit("unbound variable ~s"), place, nao);
+ loc = cdr_l(binding);
+ } else if (consp(place)) {
+ if (first(place) == gethash_s) {
+ val hash = eval(second(place), env, form);
+ val key = eval(third(place), env, form);
+ val new_p;
+ loc = gethash_l(hash, key, &new_p);
+ if (new_p)
+ *loc = eval(fourth(place), env, form);
+ } else {
+ eval_error(form, lit("~a: ~s is not a recognized place form"),
+ op, place, nao);
+ }
+ } else {
+ eval_error(form, lit("~a: ~s is not a place"), op, place, nao);
+ }
+
+ if (!loc)
+ eval_error(form, lit("~a: place ~s doesn't exist"), op, place, nao);
+
+ if (op == set_s) {
+ return *loc = inc;
+ } else if (op == inc_s) {
+ return *loc = plus(*loc, inc);
+ } else if (op == dec_s) {
+ return *loc = plus(*loc, inc);
+ } else if (op == push_s) {
+ return push(inc, loc);
+ } else if (op == pop_s) {
+ return pop(loc);
+ }
+
+ internal_error("unrecognized operator");
+}
+
+static void reg_fun(val sym, val fun)
+{
+ sethash(top_fb, sym, cons(sym, fun));
+}
+
+void eval_init(void)
+{
+ protect(&top_vb, &top_fb, &op_table, (val *) 0);
+ top_fb = make_hash(t, nil, nil);
+ top_vb = make_hash(t, nil, nil);
+ op_table = make_hash(nil, nil, nil);
+
+ inc_s = intern(lit("inc"), user_package);
+ dec_s = intern(lit("dec"), user_package);
+ push_s = intern(lit("push"), user_package);
+ pop_s = intern(lit("pop"), user_package);
+ gethash_s = intern(lit("gethash"), user_package);
+
+ sethash(op_table, intern(lit("let"), user_package), cptr((mem_t *) op_let));
+ sethash(op_table, intern(lit("lambda"), user_package), cptr((mem_t *) op_lambda));
+ sethash(op_table, intern(lit("call"), user_package), cptr((mem_t *) op_call));
+ sethash(op_table, intern(lit("cond"), user_package), cptr((mem_t *) op_cond));
+ sethash(op_table, intern(lit("if"), user_package), cptr((mem_t *) op_if));
+ sethash(op_table, intern(lit("and"), user_package), cptr((mem_t *) op_and));
+ sethash(op_table, intern(lit("or"), user_package), cptr((mem_t *) op_or));
+ sethash(op_table, intern(lit("defvar"), user_package), cptr((mem_t *) op_defvar));
+ sethash(op_table, intern(lit("defun"), user_package), cptr((mem_t *) op_defun));
+
+ sethash(op_table, inc_s, cptr((mem_t *) op_modplace));
+ sethash(op_table, dec_s, cptr((mem_t *) op_modplace));
+ sethash(op_table, set_s, cptr((mem_t *) op_modplace));
+ sethash(op_table, push_s, cptr((mem_t *) op_modplace));
+ sethash(op_table, pop_s, cptr((mem_t *) op_modplace));
+
+ reg_fun(cons_s, func_n2(cons));
+ reg_fun(intern(lit("car"), user_package), func_n1(car));
+ reg_fun(intern(lit("cdr"), user_package), func_n1(car));
+ reg_fun(intern(lit("first"), user_package), func_n1(car));
+ reg_fun(intern(lit("rest"), user_package), func_n1(cdr));
+
+ reg_fun(intern(lit("atom"), user_package), func_n1(atom));
+ reg_fun(intern(lit("null"), user_package), func_n1(nullp));
+ reg_fun(intern(lit("consp"), user_package), func_n1(consp));
+ reg_fun(intern(lit("listp"), user_package), func_n1(listp));
+ reg_fun(intern(lit("proper-listp"), user_package), func_n1(proper_listp));
+ reg_fun(intern(lit("length"), user_package), func_n1(length));
+
+ reg_fun(intern(lit("+"), user_package), func_n0v(plusv));
+ reg_fun(intern(lit("-"), user_package), func_n1v(minusv));
+ reg_fun(intern(lit("*"), user_package), func_n0v(mulv));
+ reg_fun(intern(lit("trunc"), user_package), func_n2(trunc));
+ reg_fun(intern(lit("mod"), user_package), func_n2(mod));
+ reg_fun(intern(lit("numberp"), user_package), func_n1(nump));
+
+ reg_fun(intern(lit(">"), user_package), func_n1v(gtv));
+ reg_fun(intern(lit("<"), user_package), func_n1v(ltv));
+ reg_fun(intern(lit(">="), user_package), func_n1v(gev));
+ reg_fun(intern(lit("<="), user_package), func_n1v(lev));
+ reg_fun(intern(lit("max"), user_package), func_n1v(maxv));
+ reg_fun(intern(lit("min"), user_package), func_n1v(minv));
+ reg_fun(intern(lit("int-str"), user_package), func_n2(int_str));
+
+ reg_fun(intern(lit("search-regex"), user_package), func_n4(search_regex));
+ reg_fun(intern(lit("match-regex"), user_package), func_n3(match_regex));
+
+ reg_fun(intern(lit("make-hash"), user_package), func_n3(make_hash));
+ reg_fun(intern(lit("gethash"), user_package), func_n3(gethash_n));
+ reg_fun(intern(lit("sethash"), user_package), func_n3(sethash));
+ reg_fun(intern(lit("pushhash"), user_package), func_n3(pushhash));
+ reg_fun(intern(lit("remhash"), user_package), func_n2(remhash));
+ reg_fun(intern(lit("hash-count"), user_package), func_n1(hash_count));
+ reg_fun(intern(lit("get-hash-userdata"), user_package),
+ func_n1(get_hash_userdata));
+ reg_fun(intern(lit("set-hash-userdata"), user_package),
+ func_n2(set_hash_userdata));
+
+ eval_error_s = intern(lit("eval-error"), user_package);
+ uw_register_subtype(eval_error_s, error_s);
+}
diff --git a/eval.h b/eval.h
new file mode 100644
index 00000000..edea999f
--- /dev/null
+++ b/eval.h
@@ -0,0 +1,38 @@
+/* Copyright 2011
+ * Kaz Kylheku <kaz@kylheku.com>
+ * Vancouver, Canada
+ * All rights reserved.
+ *
+ * BSD License:
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in
+ * the documentation and/or other materials provided with the
+ * distribution.
+ * 3. The name of the author may not be used to endorse or promote
+ * products derived from this software without specific prior
+ * written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
+ * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
+ * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+ */
+
+val make_env(val fbindings, val vbindings, val up_env);
+val env_fbind(val env, val sym, val fun);
+val env_vbind(val env, val sym, val obj);
+val lookup_var(val env, val sym);
+val lookup_fun(val env, val sym);
+val interp_fun(val env, val fun, val args);
+val apply(val fun, val arglist, val ctx_form);
+val eval_progn(val forms, val env, val ctx_form);
+val eval(val form, val env, val ctx_form);
+val bindable(val obj);
+
+void eval_init(void);
diff --git a/gc.c b/gc.c
index 1f31cf54..4f8c41bc 100644
--- a/gc.c
+++ b/gc.c
@@ -39,6 +39,7 @@
#include "stream.h"
#include "hash.h"
#include "txr.h"
+#include "eval.h"
#include "gc.h"
#define PROT_STACK_SIZE 1024
@@ -202,6 +203,8 @@ static void finalize(val obj)
case COBJ:
obj->co.ops->destroy(obj);
return;
+ case ENV:
+ return;
}
assert (0 && "corrupt type field");
@@ -287,6 +290,10 @@ tail_call:
case COBJ:
obj->co.ops->mark(obj);
mark_obj_tail(obj->co.cls);
+ case ENV:
+ mark_obj(obj->e.vbindings);
+ mark_obj(obj->e.fbindings);
+ mark_obj_tail(obj->e.up_env);
}
assert (0 && "corrupt type field");
diff --git a/hash.c b/hash.c
index 86b7a2f5..010cfbf6 100644
--- a/hash.c
+++ b/hash.c
@@ -54,7 +54,7 @@ struct hash {
val userdata;
cnum (*hash_fun)(val);
val (*assoc_fun)(val list, val key);
- val *(*acons_new_l_fun)(val *list, val key, val *new_p);
+ val *(*acons_new_l_fun)(val key, val *new_p, val *list);
};
struct hash_iter {
@@ -105,6 +105,7 @@ static cnum equal_hash(val obj)
return c_num(obj) & NUM_MAX;
case SYM:
case PKG:
+ case ENV:
switch (sizeof (mem_t *)) {
case 4:
return (((cnum) obj) & NUM_MAX) >> 4;
@@ -268,10 +269,10 @@ val make_hash(val weak_keys, val weak_vals, val equal_based)
val *gethash_l(val hash, val key, val *new_p)
{
- struct hash *h = (struct hash *) hash->co.handle;
+ struct hash *h = (struct hash *) cobj_handle(hash, hash_s);
val *pchain = vecref_l(h->table, num(h->hash_fun(key) % h->modulus));
val old = *pchain;
- val *place = h->acons_new_l_fun(pchain, key, new_p);
+ val *place = h->acons_new_l_fun(key, new_p, pchain);
if (old != *pchain && ++h->count > 2 * h->modulus)
hash_grow(h);
return place;
@@ -279,7 +280,7 @@ val *gethash_l(val hash, val key, val *new_p)
val gethash(val hash, val key)
{
- struct hash *h = (struct hash *) hash->co.handle;
+ struct hash *h = (struct hash *) cobj_handle(hash, hash_s);
val chain = *vecref_l(h->table, num(h->hash_fun(key) % h->modulus));
val found = h->assoc_fun(chain, key);
return cdr(found);
@@ -287,12 +288,20 @@ val gethash(val hash, val key)
val gethash_f(val hash, val key, val *found)
{
- struct hash *h = (struct hash *) hash->co.handle;
+ struct hash *h = (struct hash *) cobj_handle(hash, hash_s);
val chain = *vecref_l(h->table, num(h->hash_fun(key) % h->modulus));
*found = h->assoc_fun(chain, key);
return cdr(*found);
}
+val gethash_n(val hash, val key, val notfound_val)
+{
+ struct hash *h = (struct hash *) cobj_handle(hash, hash_s);
+ val chain = *vecref_l(h->table, num(h->hash_fun(key) % h->modulus));
+ val existing = h->assoc_fun(chain, key);
+ return if3(existing, cdr(existing), notfound_val);
+}
+
val sethash(val hash, val key, val value)
{
val new_p;
@@ -309,7 +318,7 @@ val pushhash(val hash, val key, val value)
val remhash(val hash, val key)
{
- struct hash *h = (struct hash *) hash->co.handle;
+ struct hash *h = (struct hash *) cobj_handle(hash, hash_s);
val *pchain = vecref_l(h->table, num(h->hash_fun(key) % h->modulus));
*pchain = alist_remove1(*pchain, key);
h->count--;
@@ -319,19 +328,19 @@ val remhash(val hash, val key)
val hash_count(val hash)
{
- struct hash *h = (struct hash *) hash->co.handle;
+ struct hash *h = (struct hash *) cobj_handle(hash, hash_s);
return num(h->count);
}
val get_hash_userdata(val hash)
{
- struct hash *h = (struct hash *) hash->co.handle;
+ struct hash *h = (struct hash *) cobj_handle(hash, hash_s);
return h->userdata;
}
val set_hash_userdata(val hash, val data)
{
- struct hash *h = (struct hash *) hash->co.handle;
+ struct hash *h = (struct hash *) cobj_handle(hash, hash_s);
val olddata = h->userdata;
h->userdata = data;
return olddata;
@@ -371,7 +380,7 @@ val hash_begin(val hash)
val hash_next(val *iter)
{
- struct hash_iter *hi = (struct hash_iter *) (*iter)->co.handle;
+ struct hash_iter *hi = (struct hash_iter *) cobj_handle(*iter, hash_iter_s);
val hash = hi->hash;
struct hash *h = (struct hash *) hash->co.handle;
if (hi->cons)
diff --git a/hash.h b/hash.h
index 3f4cd2d0..7526b746 100644
--- a/hash.h
+++ b/hash.h
@@ -28,6 +28,7 @@ val hash_obj(val);
val make_hash(val weak_keys, val weak_vals, val equal_based);
val *gethash_l(val hash, val key, val *new_p);
val gethash(val hash, val key);
+val gethash_n(val hash, val key, val notfound_val);
val gethash_f(val hash, val key, val *found);
val sethash(val hash, val key, val value);
val pushhash(val hash, val key, val value);
@@ -38,6 +39,7 @@ val set_hash_userdata(val hash, val data);
val hashp(val obj);
val hash_begin(val hash);
val hash_next(val *iter);
+
void hash_process_weak(void);
void hash_init(void);
diff --git a/lib.c b/lib.c
index 440b258e..76abc8cc 100644
--- a/lib.c
+++ b/lib.c
@@ -46,6 +46,7 @@
#include "stream.h"
#include "utf8.h"
#include "filter.h"
+#include "eval.h"
#define max(a, b) ((a) > (b) ? (a) : (b))
#define min(a, b) ((a) < (b) ? (a) : (b))
@@ -56,6 +57,7 @@ val system_package, keyword_package, user_package;
val null, t, cons_s, str_s, chr_s, num_s, sym_s, pkg_s, fun_s, vec_s;
val stream_s, hash_s, hash_iter_s, lcons_s, lstr_s, cobj_s, cptr_s;
+val env_s;
val var_s, expr_s, regex_s, chset_s, set_s, cset_s, wild_s, oneplus_s;
val nongreedy_s, compiled_regex_s;
val quote_s, qquote_s, unquote_s, splice_s;
@@ -105,6 +107,7 @@ static val code2type(int code)
case LCONS: return lcons_s;
case LSTR: return lstr_s;
case COBJ: return cobj_s;
+ case ENV: return env_s;
}
return nil;
}
@@ -502,6 +505,7 @@ val equal(val left, val right)
return nil;
case SYM:
case PKG:
+ case ENV:
return right == left ? t : nil;
case FUN:
if (type(right) == FUN &&
@@ -752,6 +756,11 @@ val plus(val anum, val bnum)
return num(a + b);
}
+val plusv(val nlist)
+{
+ return reduce_left(func_n2(plus), nlist, num(0), nil);
+}
+
val minus(val anum, val bnum)
{
cnum a = c_num(anum);
@@ -770,6 +779,76 @@ val neg(val anum)
return num(-n);
}
+val minusv(val minuend, val nlist)
+{
+ if (nlist)
+ return reduce_left(func_n2(minus), nlist, minuend, nil);
+ return neg(minuend);
+}
+
+val mul(val anum, val bnum)
+{
+ cnum a = c_num(anum);
+ cnum b = c_num(bnum);
+
+#ifdef HAVE_LONGLONG_T
+ if (sizeof (longlong_t) >= 2 * sizeof (cnum)) {
+ longlong_t product = a * b;
+ numeric_assert (product >= NUM_MIN && product <= NUM_MAX);
+ return num(product);
+ } else
+#endif
+ {
+ if (a > 0){
+ if (b > 0) {
+ numeric_assert (a <= (NUM_MAX / b));
+ } else {
+ numeric_assert (b >= (NUM_MIN / a));
+ }
+ } else {
+ if (b > 0) {
+ numeric_assert (a >= (NUM_MIN / b));
+ } else {
+ numeric_assert ((a == 0) || (b >= (NUM_MIN / a)));
+ }
+ }
+
+ return num(a * b);
+ }
+}
+
+val mulv(val nlist)
+{
+ return reduce_left(func_n2(mul), nlist, num(1), nil);
+}
+
+val trunc(val anum, val bnum)
+{
+ cnum a = c_num(anum);
+ cnum b = c_num(bnum);
+
+ numeric_assert (b != 0);
+
+ {
+ cnum result = a / b;
+ numeric_assert (result <= NUM_MAX);
+ return num(result);
+ }
+}
+
+val mod(val anum, val bnum)
+{
+ cnum a = c_num(anum);
+ cnum b = c_num(bnum);
+
+ numeric_assert (b != 0);
+
+ {
+ cnum result = a % b;
+ return num(result);
+ }
+}
+
val zerop(val num)
{
return c_num(num) == 0 ? t : nil;
@@ -795,6 +874,62 @@ val le(val anum, val bnum)
return c_num(anum) <= c_num(bnum) ? t : nil;
}
+val gtv(val first, val rest)
+{
+ val iter;
+
+ for (iter = rest; iter; iter = cdr(iter)) {
+ val elem = car(iter);
+ if (!gt(first, elem))
+ return nil;
+ first = elem;
+ }
+
+ return t;
+}
+
+val ltv(val first, val rest)
+{
+ val iter;
+
+ for (iter = rest; iter; iter = cdr(iter)) {
+ val elem = car(iter);
+ if (!lt(first, elem))
+ return nil;
+ first = elem;
+ }
+
+ return t;
+}
+
+val gev(val first, val rest)
+{
+ val iter;
+
+ for (iter = rest; iter; iter = cdr(iter)) {
+ val elem = car(iter);
+ if (!ge(first, elem))
+ return nil;
+ first = elem;
+ }
+
+ return t;
+}
+
+val lev(val first, val rest)
+{
+ val iter;
+
+ for (iter = rest; iter; iter = cdr(iter)) {
+ val elem = car(iter);
+ if (!le(first, elem))
+ return nil;
+ first = elem;
+ }
+
+ return t;
+}
+
val numeq(val anum, val bnum)
{
return c_num(anum) == c_num(bnum) ? t : nil;
@@ -810,6 +945,16 @@ val min2(val anum, val bnum)
return c_num(anum) < c_num(bnum) ? anum : bnum;
}
+val maxv(val first, val rest)
+{
+ return reduce_left(func_n2(max2), rest, first, nil);
+}
+
+val minv(val first, val rest)
+{
+ return reduce_left(func_n2(min2), rest, first, nil);
+}
+
val string_own(wchar_t *str)
{
val obj = make_obj();
@@ -1226,6 +1371,16 @@ val string_lt(val astr, val bstr)
return cmp == -1 ? t : nil;
}
+val int_str(val str, val base)
+{
+ const wchar_t *wcs = c_str(str);
+ cnum b = c_num(base);
+ /* TODO: detect if we have wcstoll */
+ long val = wcstol(wcs, 0, b);
+ numeric_assert (val >= NUM_MIN && val <= NUM_MAX);
+ return num(val);
+}
+
val chrp(val chr)
{
return (is_chr(chr)) ? t : nil;
@@ -1361,6 +1516,20 @@ val intern(val str, val package)
}
}
+static val rehome_sym(val sym, val package)
+{
+ if (!sym)
+ return nil;
+ type_check (package, PKG);
+ type_check (sym, SYM);
+
+ if (sym->s.package)
+ remhash(sym->s.package->pk.symhash, symbol_name(sym));
+ sym->s.package = package;
+ sethash(package->pk.symhash, symbol_name(sym), sym);
+ return sym;
+}
+
val symbolp(val sym)
{
return (sym == nil || (is_ptr(sym) && sym->s.type == SYM)) ? t : nil;
@@ -1378,6 +1547,8 @@ val func_f0(val env, val (*fun)(val))
obj->f.functype = F0;
obj->f.env = env;
obj->f.f.f0 = fun;
+ obj->f.variadic = 0;
+ obj->f.minparam = 0;
return obj;
}
@@ -1388,6 +1559,8 @@ val func_f1(val env, val (*fun)(val, val))
obj->f.functype = F1;
obj->f.env = env;
obj->f.f.f1 = fun;
+ obj->f.variadic = 0;
+ obj->f.minparam = 1;
return obj;
}
@@ -1398,6 +1571,8 @@ val func_f2(val env, val (*fun)(val, val, val))
obj->f.functype = F2;
obj->f.env = env;
obj->f.f.f2 = fun;
+ obj->f.variadic = 0;
+ obj->f.minparam = 2;
return obj;
}
@@ -1408,6 +1583,8 @@ val func_f3(val env, val (*fun)(val, val, val, val))
obj->f.functype = F3;
obj->f.env = env;
obj->f.f.f3 = fun;
+ obj->f.variadic = 0;
+ obj->f.minparam = 3;
return obj;
}
@@ -1418,6 +1595,8 @@ val func_f4(val env, val (*fun)(val, val, val, val, val))
obj->f.functype = F4;
obj->f.env = env;
obj->f.f.f4 = fun;
+ obj->f.variadic = 0;
+ obj->f.minparam = 4;
return obj;
}
@@ -1428,6 +1607,8 @@ val func_n0(val (*fun)(void))
obj->f.functype = N0;
obj->f.env = nil;
obj->f.f.n0 = fun;
+ obj->f.variadic = 0;
+ obj->f.minparam = 0;
return obj;
}
@@ -1438,6 +1619,8 @@ val func_n1(val (*fun)(val))
obj->f.functype = N1;
obj->f.env = nil;
obj->f.f.n1 = fun;
+ obj->f.variadic = 0;
+ obj->f.minparam = 1;
return obj;
}
@@ -1448,6 +1631,8 @@ val func_n2(val (*fun)(val, val))
obj->f.functype = N2;
obj->f.env = nil;
obj->f.f.n2 = fun;
+ obj->f.variadic = 0;
+ obj->f.minparam = 2;
return obj;
}
@@ -1458,6 +1643,8 @@ val func_n3(val (*fun)(val, val, val))
obj->f.functype = N3;
obj->f.env = nil;
obj->f.f.n3 = fun;
+ obj->f.variadic = 0;
+ obj->f.minparam = 3;
return obj;
}
@@ -1468,136 +1655,337 @@ val func_n4(val (*fun)(val, val, val, val))
obj->f.functype = N4;
obj->f.env = nil;
obj->f.f.n4 = fun;
+ obj->f.variadic = 0;
+ obj->f.minparam = 4;
return obj;
}
-val functionp(val obj)
+val func_f0v(val env, val (*fun)(val, val))
{
- if (!obj) {
- return nil;
- } else {
- type_t ty = type(obj);
- return (ty == FUN) ? t : nil;
- }
+ val obj = make_obj();
+ obj->f.type = FUN;
+ obj->f.functype = F0;
+ obj->f.env = env;
+ obj->f.f.f0v = fun;
+ obj->f.variadic = 1;
+ obj->f.minparam = 0;
+ return obj;
}
-val apply(val fun, val arglist)
+val func_f1v(val env, val (*fun)(val env, val, val rest))
{
- val arg[4], *p = arg;
+ val obj = make_obj();
+ obj->f.type = FUN;
+ obj->f.functype = F1;
+ obj->f.env = env;
+ obj->f.f.f1v = fun;
+ obj->f.variadic = 1;
+ obj->f.minparam = 1;
+ return obj;
+}
- internal_error("apply is broken crap: fix before using");
+val func_f2v(val env, val (*fun)(val env, val, val, val rest))
+{
+ val obj = make_obj();
+ obj->f.type = FUN;
+ obj->f.functype = F2;
+ obj->f.env = env;
+ obj->f.f.f2v = fun;
+ obj->f.variadic = 1;
+ obj->f.minparam = 2;
+ return obj;
+}
- type_check (fun, FUN);
+val func_f3v(val env, val (*fun)(val env, val, val, val, val rest))
+{
+ val obj = make_obj();
+ obj->f.type = FUN;
+ obj->f.functype = F3;
+ obj->f.env = env;
+ obj->f.f.f3v = fun;
+ obj->f.variadic = 1;
+ obj->f.minparam = 3;
+ return obj;
+}
- type_assert (listp(arglist),
- (lit("apply arglist ~s is not a list"), arglist, nao));
+val func_f4v(val env, val (*fun)(val env, val, val, val, val, val rest))
+{
+ val obj = make_obj();
+ obj->f.type = FUN;
+ obj->f.functype = F4;
+ obj->f.env = env;
+ obj->f.f.f4v = fun;
+ obj->f.variadic = 1;
+ obj->f.minparam = 4;
+ return obj;
+}
- *p++ = car(arglist); arglist = cdr(arglist);
- *p++ = car(arglist); arglist = cdr(arglist);
- *p++ = car(arglist); arglist = cdr(arglist);
- *p++ = car(arglist); arglist = cdr(arglist);
+val func_n0v(val (*fun)(val rest))
+{
+ val obj = make_obj();
+ obj->f.type = FUN;
+ obj->f.functype = N0;
+ obj->f.env = nil;
+ obj->f.f.n0v = fun;
+ obj->f.variadic = 1;
+ obj->f.minparam = 0;
+ return obj;
+}
- switch (fun->f.functype) {
- case F0:
- return fun->f.f.f0(fun);
- case F1:
- return fun->f.f.f1(fun, arg[0]);
- case F2:
- return fun->f.f.f2(fun, arg[0], arg[1]);
- case F3:
- return fun->f.f.f3(fun, arg[0], arg[1], arg[2]);
- case F4:
- return fun->f.f.f4(fun, arg[0], arg[1], arg[2], arg[3]);
- case N0:
- return fun->f.f.n0();
- case N1:
- return fun->f.f.n1(arg[0]);
- case N2:
- return fun->f.f.n2(arg[0], arg[1]);
- case N3:
- return fun->f.f.n3(arg[0], arg[1], arg[2]);
- case N4:
- return fun->f.f.n4(arg[0], arg[1], arg[2], arg[3]);
- case FINTERP:
- internal_error("unsupported function type");
- }
+val func_n1v(val (*fun)(val, val rest))
+{
+ val obj = make_obj();
+ obj->f.type = FUN;
+ obj->f.functype = N1;
+ obj->f.env = nil;
+ obj->f.f.n1v = fun;
+ obj->f.variadic = 1;
+ obj->f.minparam = 1;
+ return obj;
+}
+
+val func_n2v(val (*fun)(val, val, val rest))
+{
+ val obj = make_obj();
+ obj->f.type = FUN;
+ obj->f.functype = N2;
+ obj->f.env = nil;
+ obj->f.f.n2v = fun;
+ obj->f.variadic = 1;
+ obj->f.minparam = 2;
+ return obj;
+}
+
+val func_n3v(val (*fun)(val, val, val, val rest))
+{
+ val obj = make_obj();
+ obj->f.type = FUN;
+ obj->f.functype = N3;
+ obj->f.env = nil;
+ obj->f.f.n3v = fun;
+ obj->f.variadic = 1;
+ obj->f.minparam = 3;
+ return obj;
+}
+
+val func_n4v(val (*fun)(val, val, val, val, val rest))
+{
+ val obj = make_obj();
+ obj->f.type = FUN;
+ obj->f.functype = N4;
+ obj->f.env = nil;
+ obj->f.f.n4v = fun;
+ obj->f.variadic = 1;
+ obj->f.minparam = 4;
+ return obj;
+}
+
+val func_interp(val env, val form)
+{
+ val obj = make_obj();
+ obj->f.type = FUN;
+ obj->f.functype = FINTERP;
+ obj->f.env = env;
+ obj->f.f.interp_fun = form;
+ obj->f.variadic = 1;
+ obj->f.minparam = 0;
+ return obj;
+}
- internal_error("corrupt function type field");
+val functionp(val obj)
+{
+ if (!obj) {
+ return nil;
+ } else {
+ type_t ty = type(obj);
+ return (ty == FUN) ? t : nil;
+ }
}
val funcall(val fun)
{
type_check(fun, FUN);
- switch (fun->f.functype) {
- case F0:
- return fun->f.f.f0(fun->f.env);
- case N0:
- return fun->f.f.n0();
- default:
- uw_throwf(error_s, lit("funcall: wrong number of arguments"));
+ if (fun->f.variadic) {
+ switch (fun->f.functype) {
+ case FINTERP:
+ return interp_fun(fun->f.env, fun->f.f.interp_fun, nil);
+ case F0:
+ return fun->f.f.f0v(fun->f.env, nil);
+ case N0:
+ return fun->f.f.n0v(nil);
+ default:
+ break;
+ }
+ } else {
+ switch (fun->f.functype) {
+ case F0:
+ return fun->f.f.f0(fun->f.env);
+ case N0:
+ return fun->f.f.n0();
+ default:
+ break;
+ }
}
+ uw_throwf(error_s, lit("funcall: wrong number of arguments"));
}
val funcall1(val fun, val arg)
{
type_check(fun, FUN);
- switch (fun->f.functype) {
- case F1:
- return fun->f.f.f1(fun->f.env, arg);
- case N1:
- return fun->f.f.n1(arg);
- default:
- uw_throw(error_s, lit("funcall1: wrong number of arguments"));
+ if (fun->f.variadic) {
+ switch (fun->f.functype) {
+ case FINTERP:
+ return interp_fun(fun->f.env, fun->f.f.interp_fun, cons(arg, nil));
+ case F0:
+ return fun->f.f.f0v(fun->f.env, cons(arg, nil));
+ case N0:
+ return fun->f.f.n0v(cons(arg, nil));
+ case F1:
+ return fun->f.f.f1v(fun->f.env, arg, nil);
+ case N1:
+ return fun->f.f.n1v(arg, nil);
+ default:
+ break;
+ }
+ } else {
+ switch (fun->f.functype) {
+ case F1:
+ return fun->f.f.f1(fun->f.env, arg);
+ case N1:
+ return fun->f.f.n1(arg);
+ default:
+ break;
+ }
}
+ uw_throw(error_s, lit("funcall1: wrong number of arguments"));
}
val funcall2(val fun, val arg1, val arg2)
{
type_check(fun, FUN);
- switch (fun->f.functype) {
- case F2:
- return fun->f.f.f2(fun->f.env, arg1, arg2);
- case N2:
- return fun->f.f.n2(arg1, arg2);
- default:
- uw_throw(error_s, lit("funcall2: wrong number of arguments"));
+ if (fun->f.variadic) {
+ switch (fun->f.functype) {
+ case FINTERP:
+ return interp_fun(fun->f.env, fun->f.f.interp_fun,
+ cons(arg1, cons(arg2, nil)));
+ case F0:
+ return fun->f.f.f0v(fun->f.env, cons(arg1, cons(arg2, nil)));
+ case N0:
+ return fun->f.f.n0v(cons(arg1, cons(arg2, nil)));
+ case F1:
+ return fun->f.f.f1v(fun->f.env, arg1, cons(arg2, nil));
+ case N1:
+ return fun->f.f.n1v(arg1, cons(arg2, nil));
+ case F2:
+ return fun->f.f.f2v(fun->f.env, arg1, arg2, nil);
+ case N2:
+ return fun->f.f.n2v(arg1, arg2, nil);
+ default:
+ break;
+ }
+ } else {
+ switch (fun->f.functype) {
+ case F2:
+ return fun->f.f.f2(fun->f.env, arg1, arg2);
+ case N2:
+ return fun->f.f.n2(arg1, arg2);
+ default:
+ break;
+ }
}
+ uw_throw(error_s, lit("funcall2: wrong number of arguments"));
}
val funcall3(val fun, val arg1, val arg2, val arg3)
{
type_check(fun, FUN);
- switch (fun->f.functype) {
- case F3:
- return fun->f.f.f3(fun->f.env, arg1, arg2, arg3);
- case N3:
- return fun->f.f.n3(arg1, arg2, arg3);
- default:
- uw_throw(error_s, lit("funcall3: wrong number of arguments"));
+ if (fun->f.variadic) {
+ switch (fun->f.functype) {
+ case FINTERP:
+ return interp_fun(fun->f.env, fun->f.f.interp_fun,
+ cons(arg1, cons(arg2, cons(arg3, nil))));
+ case F0:
+ return fun->f.f.f0v(fun->f.env, cons(arg1, cons(arg2, cons(arg3, nil))));
+ case N0:
+ return fun->f.f.n0v(cons(arg1, cons(arg2, cons(arg3, nil))));
+ case F1:
+ return fun->f.f.f1v(fun->f.env, arg1, cons(arg2, cons(arg3, nil)));
+ case N1:
+ return fun->f.f.n1v(arg1, cons(arg2, cons(arg3, nil)));
+ case F2:
+ return fun->f.f.f2v(fun->f.env, arg1, arg2, cons(arg3, nil));
+ case N2:
+ return fun->f.f.n2v(arg1, arg2, cons(arg3, nil));
+ case F3:
+ return fun->f.f.f3v(fun->f.env, arg1, arg2, arg3, nil);
+ case N3:
+ return fun->f.f.n3v(arg1, arg2, arg3, nil);
+ default:
+ break;
+ }
+ } else {
+ switch (fun->f.functype) {
+ case F3:
+ return fun->f.f.f3(fun->f.env, arg1, arg2, arg3);
+ case N3:
+ return fun->f.f.n3(arg1, arg2, arg3);
+ default:
+ break;
+ }
}
+ uw_throw(error_s, lit("funcall3: wrong number of arguments"));
}
val funcall4(val fun, val arg1, val arg2, val arg3, val arg4)
{
type_check(fun, FUN);
- switch (fun->f.functype) {
- case F4:
- return fun->f.f.f4(fun->f.env, arg1, arg2, arg3, arg4);
- case N4:
- return fun->f.f.n4(arg1, arg2, arg3, arg4);
- default:
- uw_throw(error_s, lit("funcall4: wrong number of arguments"));
+ if (fun->f.variadic) {
+ switch (fun->f.functype) {
+ case FINTERP:
+ return interp_fun(fun->f.env, fun->f.f.interp_fun,
+ cons(arg1, cons(arg2, cons(arg3, cons(arg4, nil)))));
+ case F0:
+ return fun->f.f.f0v(fun->f.env, cons(arg1, cons(arg2, cons(arg3, cons(arg4, nil)))));
+ case N0:
+ return fun->f.f.n0v(cons(arg1, cons(arg2, cons(arg3, cons(arg4, nil)))));
+ case F1:
+ return fun->f.f.f1v(fun->f.env, arg1, cons(arg2, cons(arg3, cons(arg4, nil))));
+ case N1:
+ return fun->f.f.n1v(arg1, cons(arg2, cons(arg3, cons(arg4, nil))));
+ case F2:
+ return fun->f.f.f2v(fun->f.env, arg1, arg2, cons(arg3, cons(arg4, nil)));
+ case N2:
+ return fun->f.f.n2v(arg1, arg2, cons(arg3, cons(arg4, nil)));
+ case F3:
+ return fun->f.f.f3v(fun->f.env, arg1, arg2, arg3, cons(arg4, nil));
+ case N3:
+ return fun->f.f.n3v(arg1, arg2, arg3, cons(arg4, nil));
+ case F4:
+ return fun->f.f.f4v(fun->f.env, arg1, arg2, arg3, arg4, nil);
+ case N4:
+ return fun->f.f.n4v(arg1, arg2, arg3, arg4, nil);
+ default:
+ break;
+ }
+ } else {
+ switch (fun->f.functype) {
+ case F4:
+ return fun->f.f.f4(fun->f.env, arg1, arg2, arg3, arg4);
+ case N4:
+ return fun->f.f.n4(arg1, arg2, arg3, arg4);
+ default:
+ break;
+ }
}
+ uw_throw(error_s, lit("funcall4: wrong number of arguments"));
}
-
-
val reduce_left(val fun, val list, val init, val key)
{
if (!key)
@@ -2140,12 +2528,12 @@ val assq(val list, val key)
return nil;
}
-val acons(val list, val car, val cdr)
+val acons(val car, val cdr, val list)
{
return cons(cons(car, cdr), list);
}
-val acons_new(val list, val key, val value)
+val acons_new(val key, val value, val list)
{
val existing = assoc(list, key);
@@ -2157,7 +2545,7 @@ val acons_new(val list, val key, val value)
}
}
-val *acons_new_l(val *list, val key, val *new_p)
+val *acons_new_l(val key, val *new_p, val *list)
{
val existing = assoc(*list, key);
@@ -2174,7 +2562,7 @@ val *acons_new_l(val *list, val key, val *new_p)
}
}
-val aconsq_new(val list, val key, val value)
+val aconsq_new(val key, val value, val list)
{
val existing = assq(list, key);
@@ -2186,7 +2574,7 @@ val aconsq_new(val list, val key, val value)
}
}
-val *aconsq_new_l(val *list, val key, val *new_p)
+val *aconsq_new_l(val key, val *new_p, val *list)
{
val existing = assq(*list, key);
@@ -2451,10 +2839,13 @@ static void obj_init(void)
null_string = lit("");
null_list = cons(nil, nil);
+ hash_s = make_sym(lit("hash"));
system_package = make_package(lit("sys"));
keyword_package = make_package(lit("keyword"));
user_package = make_package(lit("usr"));
+ rehome_sym(hash_s, user_package);
+
/* nil can't be interned because it's not a SYM object;
it works as a symbol because the nil case is handled by
symbol-manipulating function. */
@@ -2480,6 +2871,7 @@ static void obj_init(void)
lstr_s = intern(lit("lstr"), user_package);
cobj_s = intern(lit("cobj"), user_package);
cptr_s = intern(lit("cptr"), user_package);
+ env_s = intern(lit("env"), user_package);
var_s = intern(lit("var"), system_package);
expr_s = intern(lit("expr"), system_package);
regex_s = intern(lit("regex"), system_package);
@@ -2654,7 +3046,7 @@ void obj_print(val obj, val out)
format(out, lit("#<package: ~s>"), obj->pk.name, nao);
return;
case FUN:
- format(out, lit("#<function: f~a>"), num(obj->f.functype), nao);
+ format(out, lit("#<function: type ~a>"), num(obj->f.functype), nao);
return;
case VEC:
{
@@ -2675,6 +3067,9 @@ void obj_print(val obj, val out)
case COBJ:
obj->co.ops->print(obj, out);
return;
+ case ENV:
+ format(out, lit("#<environment: ~p>"), (void *) obj, nao);
+ return;
}
format(out, lit("#<garbage: ~p>"), (void *) obj, nao);
@@ -2724,7 +3119,7 @@ void obj_pprint(val obj, val out)
format(out, lit("#<package: ~s>"), obj->pk.name, nao);
return;
case FUN:
- format(out, lit("#<function: f~a>"), num(obj->f.functype), nao);
+ format(out, lit("#<function: type ~a>"), num(obj->f.functype), nao);
return;
case VEC:
{
@@ -2745,6 +3140,9 @@ void obj_pprint(val obj, val out)
case COBJ:
obj->co.ops->print(obj, out);
return;
+ case ENV:
+ format(out, lit("#<environment: ~p>"), (void *) obj, nao);
+ return;
}
format(out, lit("#<garbage: ~p>"), (void *) obj, nao);
@@ -2761,6 +3159,7 @@ void init(const wchar_t *pn, mem_t *(*oom)(mem_t *, size_t),
gc_init(stack_bottom);
obj_init();
uw_init();
+ eval_init();
stream_init();
filter_init();
diff --git a/lib.h b/lib.h
index e6677a51..c78464a6 100644
--- a/lib.h
+++ b/lib.h
@@ -37,7 +37,7 @@ typedef int_ptr_t cnum;
typedef enum type {
NUM = TAG_NUM, CHR = TAG_CHR, LIT = TAG_LIT, CONS,
- STR, SYM, PKG, FUN, VEC, LCONS, LSTR, COBJ
+ STR, SYM, PKG, FUN, VEC, LCONS, LSTR, COBJ, ENV
} type_t;
typedef enum functype
@@ -86,7 +86,9 @@ struct package {
struct func {
type_t type;
- functype_t functype;
+ unsigned minparam : 15;
+ unsigned variadic : 1;
+ functype_t functype : 16;
val env;
union {
val interp_fun;
@@ -100,6 +102,16 @@ struct func {
val (*n2)(val, val);
val (*n3)(val, val, val);
val (*n4)(val, val, val, val);
+ val (*f0v)(val, val);
+ val (*f1v)(val, val, val);
+ val (*f2v)(val, val, val, val);
+ val (*f3v)(val, val, val, val, val);
+ val (*f4v)(val, val, val, val, val, val);
+ val (*n0v)(val);
+ val (*n1v)(val, val);
+ val (*n2v)(val, val, val);
+ val (*n3v)(val, val, val, val);
+ val (*n4v)(val, val, val, val, val);
} f;
};
@@ -164,6 +176,13 @@ void cobj_destroy_free_op(val);
void cobj_mark_op(val);
cnum cobj_hash_op(val);
+struct env {
+ type_t type;
+ val vbindings;
+ val fbindings;
+ val up_env;
+};
+
union obj {
struct any t;
struct cons c;
@@ -175,6 +194,7 @@ union obj {
struct lazy_cons lc;
struct lazy_string ls;
struct cobj co;
+ struct env e;
};
INLINE cnum tag(val obj) { return ((cnum) obj) & TAG_MASK; }
@@ -241,6 +261,7 @@ INLINE val chr(wchar_t ch)
extern val keyword_package, system_package, user_package;
extern val null, t, cons_s, str_s, chr_s, num_s, sym_s, pkg_s, fun_s, vec_s;
extern val stream_s, hash_s, hash_iter_s, lcons_s, lstr_s, cobj_s, cptr_s;
+extern val env_s;
extern val var_s, expr_s, regex_s, chset_s, set_s, cset_s, wild_s, oneplus_s;
extern val nongreedy_s, compiled_regex_s;
extern val quote_s, qquote_s, unquote_s, splice_s;
@@ -322,16 +343,28 @@ val num(cnum val);
cnum c_num(val num);
val nump(val num);
val plus(val anum, val bnum);
+val plusv(val nlist);
val minus(val anum, val bnum);
+val minusv(val minuend, val nlist);
val neg(val num);
+val mul(val anum, val bnum);
+val mulv(val nlist);
+val trunc(val anum, val bnum);
+val mod(val anum, val bnum);
val zerop(val num);
val gt(val anum, val bnum);
val lt(val anum, val bnum);
val ge(val anum, val bnum);
val le(val anum, val bnum);
+val gtv(val first, val rest);
+val ltv(val first, val rest);
+val gev(val first, val rest);
+val lev(val first, val rest);
val numeq(val anum, val bnum);
val max2(val anum, val bnum);
val min2(val anum, val bnum);
+val maxv(val first, val rest);
+val minv(val first, val rest);
val string_own(wchar_t *str);
val string(const wchar_t *str);
val string_utf8(const char *str);
@@ -354,6 +387,7 @@ val split_str(val str, val sep);
val split_str_set(val str, val set);
val trim_str(val str);
val string_lt(val astr, val bstr);
+val int_str(val str, val base);
val chrp(val chr);
wchar_t c_chr(val chr);
val chr_str(val str, val index);
@@ -370,18 +404,28 @@ val symbolp(val sym);
val symbol_name(val sym);
val symbol_package(val sym);
val keywordp(val sym);
-val func_f0(val, val (*fun)(val));
-val func_f1(val, val (*fun)(val, val));
-val func_f2(val, val (*fun)(val, val, val));
-val func_f3(val, val (*fun)(val, val, val, val));
-val func_f4(val, val (*fun)(val, val, val, val, val));
+val func_f0(val, val (*fun)(val env));
+val func_f1(val, val (*fun)(val env, val));
+val func_f2(val, val (*fun)(val env, val, val));
+val func_f3(val, val (*fun)(val env, val, val, val));
+val func_f4(val, val (*fun)(val env, val, val, val, val));
val func_n0(val (*fun)(void));
val func_n1(val (*fun)(val));
val func_n2(val (*fun)(val, val));
val func_n3(val (*fun)(val, val, val));
val func_n4(val (*fun)(val, val, val, val));
+val func_f0v(val, val (*fun)(val env, val rest));
+val func_f1v(val, val (*fun)(val env, val, val rest));
+val func_f2v(val, val (*fun)(val env, val, val, val rest));
+val func_f3v(val, val (*fun)(val env, val, val, val, val rest));
+val func_f4v(val, val (*fun)(val env, val, val, val, val, val rest));
+val func_n0v(val (*fun)(val rest));
+val func_n1v(val (*fun)(val, val rest));
+val func_n2v(val (*fun)(val, val, val rest));
+val func_n3v(val (*fun)(val, val, val, val rest));
+val func_n4v(val (*fun)(val, val, val, val, val rest));
+val func_interp(val env, val form);
val functionp(val);
-val apply(val fun, val arglist);
val funcall(val fun);
val funcall1(val fun, val arg);
val funcall2(val fun, val arg1, val arg2);
@@ -424,11 +468,11 @@ val cptr(mem_t *ptr);
mem_t *cptr_get(val cptr);
val assoc(val list, val key);
val assq(val list, val key);
-val acons(val list, val car, val cdr);
-val acons_new(val list, val key, val value);
-val *acons_new_l(val *list, val key, val *new_p);
-val aconsq_new(val list, val key, val value);
-val *aconsq_new_l(val *list, val key, val *new_p);
+val acons(val car, val cdr, val list);
+val acons_new(val key, val value, val list);
+val *acons_new_l(val key, val *new_p, val *list);
+val aconsq_new(val key, val value, val list);
+val *aconsq_new_l(val key, val *new_p, val *list);
val alist_remove(val list, val keys);
val alist_remove1(val list, val key);
val alist_nremove(val list, val keys);
diff --git a/match.c b/match.c
index 6d5fb413..4210474f 100644
--- a/match.c
+++ b/match.c
@@ -44,6 +44,7 @@
#include "filter.h"
#include "hash.h"
#include "debug.h"
+#include "eval.h"
#include "match.h"
int output_produced;
@@ -226,11 +227,6 @@ static val weird_merge(val left, val right)
return append2(left, right);
}
-static val bindable(val obj)
-{
- return (obj && symbolp(obj) && obj != t && !keywordp(obj)) ? t : nil;
-}
-
static val dest_set(val spec, val bindings, val pattern, val value)
{
if (symbolp(pattern)) {
@@ -501,7 +497,7 @@ static val h_var(match_line_ctx c, match_line_ctx *cout)
}
LOG_MATCH("var spanning form", new_pos);
- c.bindings = acons(new_bindings, sym, sub_str(c.dataline, c.pos, new_pos));
+ c.bindings = acons(sym, sub_str(c.dataline, c.pos, new_pos), new_bindings);
c.pos = new_pos;
/* This may have another variable attached */
if (pat) {
@@ -518,7 +514,7 @@ static val h_var(match_line_ctx c, match_line_ctx *cout)
return nil;
}
LOG_MATCH("count based var", past);
- c.bindings = acons(c.bindings, sym, trim_str(sub_str(c.dataline, c.pos, past)));
+ c.bindings = acons(sym, trim_str(sub_str(c.dataline, c.pos, past)), c.bindings);
c.pos = past;
/* This may have another variable attached */
if (pat) {
@@ -529,7 +525,7 @@ static val h_var(match_line_ctx c, match_line_ctx *cout)
sem_error(elem, lit("invalid modifier ~s on variable ~s"),
modifier, sym, nao);
} else if (pat == nil) { /* no modifier, no elem -> to end of line */
- c.bindings = acons(c.bindings, sym, sub_str(c.dataline, c.pos, nil));
+ c.bindings = acons(sym, sub_str(c.dataline, c.pos, nil), c.bindings);
c.pos = length_str(c.dataline);
} else if (type(pat) == STR) {
val find = search_str(c.dataline, pat, c.pos, modifier);
@@ -538,7 +534,7 @@ static val h_var(match_line_ctx c, match_line_ctx *cout)
return nil;
}
LOG_MATCH("var delimiting string", find);
- c.bindings = acons(c.bindings, sym, sub_str(c.dataline, c.pos, find));
+ c.bindings = acons(sym, sub_str(c.dataline, c.pos, find), c.bindings);
c.pos = plus(find, length_str(pat));
} else if (consp(pat) && first(pat) != var_s) {
val find = search_form(&c, pat, modifier);
@@ -549,7 +545,7 @@ static val h_var(match_line_ctx c, match_line_ctx *cout)
return nil;
}
LOG_MATCH("var delimiting form", fpos);
- c.bindings = acons(c.bindings, sym, sub_str(c.dataline, c.pos, fpos));
+ c.bindings = acons(sym, sub_str(c.dataline, c.pos, fpos), c.bindings);
c.pos = plus(fpos, flen);
} else if (consp(pat)) {
/* Unbound var followed by var: the following one must either
@@ -577,10 +573,10 @@ static val h_var(match_line_ctx c, match_line_ctx *cout)
/* Text from here to start of regex match goes to this
variable. */
- c.bindings = acons(c.bindings, sym, sub_str(c.dataline, c.pos, fpos));
+ c.bindings = acons(sym, sub_str(c.dataline, c.pos, fpos), c.bindings);
/* Text from start of regex match to end goes to the
second variable */
- c.bindings = acons(c.bindings, second_sym, sub_str(c.dataline, fpos, plus(fpos, flen)));
+ c.bindings = acons(second_sym, sub_str(c.dataline, fpos, plus(fpos, flen)), c.bindings);
LOG_MATCH("double var regex (first var)", fpos);
c.pos = fpos;
LOG_MATCH("double var regex (second var)", plus(fpos, flen));
@@ -610,7 +606,7 @@ static val h_var(match_line_ctx c, match_line_ctx *cout)
LOG_MISMATCH("string");
return nil;
}
- c.bindings = acons(c.bindings, sym, sub_str(c.dataline, c.pos, find));
+ c.bindings = acons(sym, sub_str(c.dataline, c.pos, find), c.bindings);
c.pos = plus(find, len);
} else {
sem_error(elem, lit("variable followed by invalid element"), nao);
@@ -771,8 +767,7 @@ static val h_coll(match_line_ctx c, match_line_ctx *cout)
if (dfl == noval_s)
list_collect (ptail, var);
else
- strictly_new_bindings = acons(strictly_new_bindings,
- var, dfl);
+ strictly_new_bindings = acons(var, dfl, strictly_new_bindings);
}
}
@@ -787,8 +782,9 @@ static val h_coll(match_line_ctx c, match_line_ctx *cout)
if (!have_vars || vars_binding) {
val existing = assoc(bindings_coll, car(binding));
- bindings_coll = acons_new(bindings_coll, car(binding),
- cons(cdr(binding), cdr(existing)));
+ bindings_coll = acons_new(car(binding),
+ cons(cdr(binding), cdr(existing)),
+ bindings_coll);
}
}
}
@@ -844,7 +840,7 @@ next_coll:
val sym = car(car(iter));
val exists = assoc(c.bindings, sym);
if (!exists)
- c.bindings = acons(c.bindings, sym, nil);
+ c.bindings = acons(sym, nil, c.bindings);
}
}
@@ -900,7 +896,7 @@ static val h_parallel(match_line_ctx c, match_line_ctx *cout)
val exists = assoc(new_bindings, ubvar);
if (exists)
- resolve_bindings = acons_new(resolve_bindings, ubvar, cdr(exists));
+ resolve_bindings = acons_new(ubvar, cdr(exists), resolve_bindings);
}
new_bindings = alist_remove(new_bindings, resolve_ub_vars);
@@ -1010,16 +1006,14 @@ static val h_fun(match_line_ctx c, match_line_ctx *cout)
if (arg && bindable(arg)) {
val val = assoc(c.bindings, arg);
if (val) {
- bindings_cp = acons_new(bindings_cp,
- param,
- cdr(val));
+ bindings_cp = acons_new(param, cdr(val), bindings_cp);
} else {
bindings_cp = alist_nremove1(bindings_cp, param);
ub_p_a_pairs = cons(cons(param, arg), ub_p_a_pairs);
}
} else {
val val = eval_form(elem, arg, c.bindings);
- bindings_cp = acons_new(bindings_cp, param, cdr(val));
+ bindings_cp = acons_new(param, cdr(val), bindings_cp);
}
}
@@ -1281,12 +1275,17 @@ static val subst_vars(val spec, val bindings, val filter)
val pair = assoc(bindings, sym);
if (pair) {
+ val str = cdr(pair);
+
+ if (!stringp(str) && !listp(str))
+ str = format(nil, lit("~a"), str, nao);
+
if (pat)
- spec = cons(filter_string(filter, cdr(pair)), cons(pat, rest(spec)));
+ spec = cons(filter_string(filter, str), cons(pat, rest(spec)));
else if (modifiers)
- spec = cons(format_field(cdr(pair), modifiers, filter), rest(spec));
+ spec = cons(format_field(str, modifiers, filter), rest(spec));
else
- spec = cons(filter_string(filter, cdr(pair)), rest(spec));
+ spec = cons(filter_string(filter, str), rest(spec));
continue;
}
uw_throwf(query_error_s, lit("unbound variable ~a"),
@@ -1330,8 +1329,7 @@ static val eval_form(val spec, val form, val bindings)
sem_error(spec, lit("metavariable @~a syntax cannot be used here"),
second(form), nao);
} else if (first(form) == expr_s) {
- sem_error(spec, lit("the @~s syntax cannot be used here"),
- rest(form), nao);
+ ret = cons(t, eval(rest(form), make_env(bindings, nil, nil), form));
} else {
val subforms = mapcar(curry_123_2(func_n3(eval_form),
spec, bindings), form);
@@ -2076,7 +2074,7 @@ static val v_parallel(match_files_ctx *c)
val exists = assoc(new_bindings, ubvar);
if (exists)
- resolve_bindings = acons_new(resolve_bindings, ubvar, cdr(exists));
+ resolve_bindings = acons_new(ubvar, cdr(exists), resolve_bindings);
}
new_bindings = alist_remove(new_bindings, resolve_ub_vars);
@@ -2229,7 +2227,7 @@ static val v_gather(match_files_ctx *c)
debuglf(specline, lit("gather failed to match some required vars"), nao);
return nil;
} else {
- c->bindings = acons(c->bindings, var, dfl_val);
+ c->bindings = acons(var, dfl_val, c->bindings);
}
}
}
@@ -2344,8 +2342,7 @@ static val v_collect(match_files_ctx *c)
if (dfl == noval_s)
list_collect (ptail, var);
else
- strictly_new_bindings = acons(strictly_new_bindings,
- var, dfl);
+ strictly_new_bindings = acons(var, dfl, strictly_new_bindings);
}
}
@@ -2361,8 +2358,7 @@ static val v_collect(match_files_ctx *c)
if (!have_vars || vars_binding) {
val existing = assoc(bindings_coll, car(binding));
- bindings_coll = acons_new(bindings_coll, car(binding),
- cons(cdr(binding), cdr(existing)));
+ bindings_coll = acons_new(car(binding), cons(cdr(binding), cdr(existing)), bindings_coll);
}
}
}
@@ -2442,7 +2438,7 @@ next_collect:
val sym = car(car(iter));
val exists = assoc(c->bindings, sym);
if (!exists)
- c->bindings = acons(c->bindings, sym, nil);
+ c->bindings = acons(sym, nil, c->bindings);
}
}
@@ -2503,7 +2499,7 @@ static val v_merge(match_files_ctx *c)
}
}
- c->bindings = acons_new(c->bindings, target, merged);
+ c->bindings = acons_new(target, merged, c->bindings);
return next_spec_k;
}
@@ -2685,7 +2681,7 @@ static val v_output(match_files_ctx *c)
*cdr_l(existing) = list_out;
}
} else {
- c->bindings = acons(c->bindings, into_var, list_out);
+ c->bindings = acons(into_var, list_out, c->bindings);
}
}
return next_spec_k;
@@ -3021,16 +3017,14 @@ static val v_fun(match_files_ctx *c)
if (arg && bindable(arg)) {
val val = assoc(c->bindings, arg);
if (val) {
- bindings_cp = acons_new(bindings_cp,
- param,
- cdr(val));
+ bindings_cp = acons_new(param, cdr(val), bindings_cp);
} else {
bindings_cp = alist_nremove1(bindings_cp, param);
ub_p_a_pairs = cons(cons(param, arg), ub_p_a_pairs);
}
} else {
val val = eval_form(specline, arg, c->bindings);
- bindings_cp = acons_new(bindings_cp, param, cdr(val));
+ bindings_cp = acons_new(param, cdr(val), bindings_cp);
}
}
@@ -3092,6 +3086,23 @@ static val v_fun(match_files_ctx *c)
return decline_k;
}
+static val v_do(match_files_ctx *c)
+{
+ spec_bind (specline, first_spec, c->spec);
+ val args = rest(first_spec);
+ (void) eval_progn(args, make_env(c->bindings, nil, nil), specline);
+ return next_spec_k;
+}
+
+static val h_do(match_line_ctx c, match_line_ctx *cout)
+{
+ val elem = first(c.specline);
+ val args = rest(elem);
+ (void) eval_progn(args, make_env(c.bindings, nil, nil), elem);
+ *cout = c;
+ return next_spec_k;
+}
+
static val match_files(match_files_ctx c)
{
gc_hint(c.data);
@@ -3325,6 +3336,8 @@ static void dir_tables_init(void)
sethash(v_directive_table, deffilter_s, cptr((mem_t *) v_deffilter));
sethash(v_directive_table, filter_s, cptr((mem_t *) v_filter));
sethash(v_directive_table, eof_s, cptr((mem_t *) v_eof));
+ sethash(v_directive_table, intern(lit("do"), user_package),
+ cptr((mem_t *) v_do));
sethash(h_directive_table, text_s, cptr((mem_t *) h_text));
sethash(h_directive_table, var_s, cptr((mem_t *) h_var));
@@ -3347,6 +3360,8 @@ static void dir_tables_init(void)
sethash(h_directive_table, trailer_s, cptr((mem_t *) h_trailer));
sethash(h_directive_table, define_s, cptr((mem_t *) h_define));
sethash(h_directive_table, eol_s, cptr((mem_t *) h_eol));
+ sethash(h_directive_table, intern(lit("do"), user_package),
+ cptr((mem_t *) h_do));
}
void match_init(void)
diff --git a/parser.l b/parser.l
index d6be1239..a4649473 100644
--- a/parser.l
+++ b/parser.l
@@ -146,10 +146,11 @@ static wchar_t num_esc(char *num)
%option nounput
%option noinput
-SYM [a-zA-Z_][a-zA-Z0-9_]*
-NUM [+-]?[0-9]+
-TOK :?{SYM}|{NUM}
-NTOK [:@]?{SYM}|{NUM}
+SYM [a-zA-Z0-9_]+
+NSCHR [a-zA-Z0-9!$%&*+\-<=>?\\^_~]
+NSYM {NSCHR}({NSCHR}|#)*
+TOK :?{SYM}
+NTOK [:@]?{NSYM}
ID_END [^a-zA-Z0-9_]
WS [\t ]*
HEX [0-9A-Fa-f]
@@ -360,9 +361,6 @@ UONLY {U2}{U}|{U3}{U}{U}|{U4}{U}{U}{U}
<NESTED>@\( |
<SPECIAL,NESTED>\{|\( {
yy_push_state(NESTED);
- if (yy_top_state() == INITIAL
- || yy_top_state() == QSILIT)
- yy_pop_state();
if (yytext[0] == '@') {
yylval.chr = '(';
return METAPAR;
diff --git a/stream.c b/stream.c
index 88ea5b49..3e71b53e 100644
--- a/stream.c
+++ b/stream.c
@@ -1019,9 +1019,8 @@ val vformat_to_string(val fmtstr, va_list vl)
val format(val stream, val str, ...)
{
val st = or2(stream, make_string_output_stream());
- type_check (stream, COBJ);
- type_assert (stream->co.cls == stream_s, (lit("~a is not a stream"),
- stream, nao));
+ type_check (st, COBJ);
+ type_assert (st->co.cls == stream_s, (lit("~a is not a stream"), st, nao));
{
va_list vl;
diff --git a/txr.vim b/txr.vim
index 1e8ec92f..63875c5c 100644
--- a/txr.vim
+++ b/txr.vim
@@ -32,19 +32,19 @@ syn match txr_char "@[ \t]*\\."
syn match txr_char "@[ \t]*\\x[0-9A-Fa-f]\+"
syn match txr_char "@[ \t]*\\[0-9]\+"
syn match txr_variable "@[ \t]*[*]\?[A-Za-z_][A-Za-z0-9_]*"
-syn match txr_chr "#\\x[A-Fa-f0-9]+"
+syn match txr_chr "#\\x[A-Fa-f0-9]\+"
syn match txr_chr "#\\[a-zA-Z_][a-zA-Z0-9_]*"
-syn match txr_ident ":\?[A-Za-z_][A-Za-z0-9_]*" contained
+syn match txr_ident "[a-zA-Z0-9!$%&*+\-<=>?\\^_~]\+" contained
syn match txr_num "[+-]\?[0-9]\+" contained
-syn region txr_bracevar matchgroup=Delimiter start="@[ \t]*[*]\?{" matchgroup=Delimiter end="}" contains=txr_ident,txr_num,txr_string,txr_list,txr_regex,txr_quasilit,txr_chr
+syn region txr_bracevar matchgroup=Delimiter start="@[ \t]*[*]\?{" matchgroup=Delimiter end="}" contains=txr_num,txr_ident,xr_string,txr_list,txr_regex,txr_quasilit,txr_chr
syn region txr_directive matchgroup=Delimiter start="@[ \t]*(" matchgroup=Delimiter end=")" contains=txr_keyword,txr_string,txr_list,txr_meta,txr_quasilit,txr_num,txr_ident,txr_regex,txr_string,txr_variable,txr_chr
-syn region txr_list contained matchgroup=Delimiter start="(" matchgroup=Delimiter end=")" contains=txr_string,txr_regex,txr_ident,txr_num,txr_variable,txr_meta,txr_list,txr_quasilit,txr_chr
+syn region txr_list contained matchgroup=Delimiter start="(" matchgroup=Delimiter end=")" contains=txr_string,txr_regex,txr_num,txr_ident,txr_variable,txr_meta,txr_list,txr_quasilit,txr_chr
-syn region txr_meta contained matchgroup=Delimiter start="@[ \t]*(" matchgroup=Delimiter end=")" contains=txr_string,txr_regex,txr_ident,txr_num,txr_variable,txr_quasilit,txr_chr
+syn region txr_meta contained matchgroup=Delimiter start="@[ \t]*(" matchgroup=Delimiter end=")" contains=txr_string,txr_regex,txr_num,txr_ident,txr_variable,txr_quasilit,txr_chr
syn region txr_string contained oneline start=+"+ skip=+\\\\\|\\"+ end=+"+
syn region txr_quasilit contained oneline start=+`+ skip=+\\\\\|\\`+ end=+`+ contains=txr_directive,txr_variable,txr_bracevar
diff --git a/unwind.c b/unwind.c
index 4bb6646c..33acfb79 100644
--- a/unwind.c
+++ b/unwind.c
@@ -149,7 +149,7 @@ val uw_get_func(val sym)
val uw_set_func(val sym, val value)
{
uw_frame_t *env = uw_find_env();
- env->ev.func_bindings = acons_new(env->ev.func_bindings, sym, value);
+ env->ev.func_bindings = acons_new(sym, value, env->ev.func_bindings);
return value;
}
diff --git a/unwind.h b/unwind.h
index 1ccdbaee..4dea9469 100644
--- a/unwind.h
+++ b/unwind.h
@@ -190,11 +190,11 @@ noreturn val type_mismatch(val, ...);
if (!(EXPR)) \
uw_throwf(numeric_error_s, \
lit("assertion " #EXPR \
- "failed"), nao)
+ " failed"), nao)
#define range_bug_unless(EXPR) \
if (!(EXPR)) \
uw_throwf(range_error_s, \
lit("assertion " #EXPR \
- "failed"), nao)
+ " failed"), nao)
generated by cgit v1.2.3 (git 2.25.1) at 2025-03-10 13:28:08 +0000