summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorKaz Kylheku <kaz@kylheku.com>2015-05-06 06:47:30 -0700
committerKaz Kylheku <kaz@kylheku.com>2015-05-06 06:47:30 -0700
commit209e731429a0fd890ec6d922c1efc6f02d81a032 (patch)
tree55302eeaaaf8ee7e0fdc7add129f2e6c68756f27
parentf7aaccf9231081e840987be9b1e5922592b147e6 (diff)
downloadtxr-209e731429a0fd890ec6d922c1efc6f02d81a032.tar.gz
txr-209e731429a0fd890ec6d922c1efc6f02d81a032.tar.bz2
txr-209e731429a0fd890ec6d922c1efc6f02d81a032.zip
New macro-based framework for assignment places.
The operators set, inc, dec, pop and others are now macros which generate code, rather than built-in special forms that use "C magic". Moreover, new such macros are easy to write, and several new ones are already available. Moreover, new kinds of assignable places are easy to create. * place.tl: New file. * lisplib.c, lisplib.h: New files. * Makefile (OBJS): New target, lisplib.o. (GEN_HDRS): New variable. (LISP_TO_C_STRING): New recipe macro, with rule. (clean): Remove generated headers named in $(GEN_HDRS). * eval.c (dec_s, push_s, pop_s, flip_s, del_s): Variables removed. (setq_s): New variable. (lookup_var, lokup_sym_lisp_1, lookup_var_l, lookup_fun, lookup_mac, lookup_symac, lookup_symac_lisp1): Trigger the delayed loading of libraries for undefined global symbols, and re-try the lookup. (op_modplace, dwim_loc, force_l): Static functions removed. (op_setq): New static function. (eval_init): Initialize setq_s; remove initializations of removed variables; remove registrations for op_modplace; add registration for sys:setq, sys:rplaca, sys:rplacd, sys:dwim-set and sys:dwim-del intrinsics. Call lisplib_init to initialize the dynamic library loading module. * lib.c (sys_rplaca, sys_rplacd): New functions, differing in return value from rplaca and rplacd. (ref, refset): Handle hash table. (dwim_set, dwim_del): New functions. * lib.h (sys_rplaca, sys_rplacd, dwim_set, dwim_del): Declared. * genvim.txr: Include place.tl in scan. * tests/010/seq.txr: The del operator test case no longer throws at run-time but at macro-expansion time, so the test case is simply removed. * tests/010/seq.expected: Updated output. * tests/011/macros-2.txr: Reset *gensym-counter* to zero, because the textual output of the test case includes gensyms, whose numberings fluctuate with the content of the new Lisp library material. * tests/011/macros-2.expected: Updated output.
-rw-r--r--ChangeLog53
-rw-r--r--Makefile20
-rw-r--r--eval.c367
-rw-r--r--genvim.txr4
-rw-r--r--hash.c1
-rw-r--r--lib.c51
-rw-r--r--lib.h4
-rw-r--r--lisplib.c83
-rw-r--r--lisplib.h28
-rw-r--r--place.tl416
-rw-r--r--tests/010/seq.expected1
-rw-r--r--tests/010/seq.txr1
-rw-r--r--tests/011/macros-2.expected2
-rw-r--r--tests/011/macros-2.txr2
14 files changed, 715 insertions, 318 deletions
diff --git a/ChangeLog b/ChangeLog
index 90a5304b..758ad8f0 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,58 @@
2015-05-06 Kaz Kylheku <kaz@kylheku.com>
+ New macro-based framework for assignment places.
+
+ The operators set, inc, dec, pop and others are now macros
+ which generate code, rather than built-in special forms
+ that use "C magic". Moreover, new such macros are easy to write, and
+ several new ones are already available. Moreover, new kinds of
+ assignable places are easy to create.
+
+ * place.tl: New file.
+
+ * lisplib.c, lisplib.h: New files.
+
+ * Makefile (OBJS): New target, lisplib.o.
+ (GEN_HDRS): New variable.
+ (LISP_TO_C_STRING): New recipe macro, with rule.
+ (clean): Remove generated headers named in $(GEN_HDRS).
+
+ * eval.c (dec_s, push_s, pop_s, flip_s, del_s): Variables removed.
+ (setq_s): New variable.
+ (lookup_var, lokup_sym_lisp_1, lookup_var_l, lookup_fun, lookup_mac,
+ lookup_symac, lookup_symac_lisp1): Trigger the delayed loading of
+ libraries for undefined global symbols, and re-try the lookup.
+ (op_modplace, dwim_loc, force_l): Static functions removed.
+ (op_setq): New static function.
+ (eval_init): Initialize setq_s; remove initializations of
+ removed variables; remove registrations for op_modplace;
+ add registration for sys:setq, sys:rplaca, sys:rplacd,
+ sys:dwim-set and sys:dwim-del intrinsics.
+ Call lisplib_init to initialize the dynamic library loading module.
+
+ * lib.c (sys_rplaca, sys_rplacd): New functions, differing
+ in return value from rplaca and rplacd.
+ (ref, refset): Handle hash table.
+ (dwim_set, dwim_del): New functions.
+
+ * lib.h (sys_rplaca, sys_rplacd, dwim_set, dwim_del): Declared.
+
+ * genvim.txr: Include place.tl in scan.
+
+ * tests/010/seq.txr: The del operator test
+ case no longer throws at run-time but at macro-expansion time, so the
+ test case is simply removed.
+
+ * tests/010/seq.expected: Updated output.
+
+ * tests/011/macros-2.txr: Reset *gensym-counter* to zero, because
+ the textual output of the test case includes gensyms, whose numberings
+ fluctuate with the content of the new Lisp library material.
+
+ * tests/011/macros-2.expected: Updated output.
+
+2015-05-06 Kaz Kylheku <kaz@kylheku.com>
+
* gc.c (make_obj, gc): Move resetting of prev_malloc_bytes
out of make_obj into gc.
diff --git a/Makefile b/Makefile
index 215aed6c..faa3b37a 100644
--- a/Makefile
+++ b/Makefile
@@ -46,11 +46,13 @@ EXTRA_OBJS-y :=
OBJS := txr.o lex.yy.o y.tab.o match.o lib.o regex.o gc.o unwind.o stream.o
OBJS += arith.o hash.o utf8.o filter.o eval.o parser.o rand.o combi.o sysif.o
+OBJS += lisplib.o
OBJS-$(debug_support) += debug.o
OBJS-$(have_syslog) += syslog.o
OBJS-$(have_glob) += glob.o
OBJS-$(have_posix_sigs) += signal.o
EXTRA_OBJS-$(add_win_res) += win/txr.res
+GEN_HDRS := place.h
ifneq ($(have_git),)
SRCS := $(addprefix $(top_srcdir)/,\
@@ -106,6 +108,14 @@ $(call ABBREV,LINK)
$(V)$(CC) $(1) $(CFLAGS) -o $@ $^ -lm
endef
+define LISP_TO_C_STRING
+$(call ABBREV,L2C)
+$(V)echo "const wchli_t *${@:.h=}_code = wli(" > $@
+$(V)sed -n -e '/^(/,$$p' $< | \
+ sed -e 's/["\\]/\\&/g' -e 's/$$/\\n/' -e 's/.*/"&"/' >> $@
+$(V)echo ");" >> $@
+endef
+
define WINDRES
$(call ABBREV,RES)
$(V)mkdir -p $(dir $@)
@@ -130,6 +140,9 @@ opt/%.res: win/%.rc
%.res: %.rc
$(call WINDRES)
+%.h: %.tl
+ $(call LISP_TO_C_STRING)
+
# The following pattern rule is used for test targets built by configure
%.o: %.c
$(call COMPILE_C)
@@ -156,6 +169,10 @@ $(PROG)-win: $(patsubst %/txr.o,%/txr-win.o,$(OPT_OBJS)) $(EXTRA_OBJS-y)
$(PROG)-win-dbg: $(patsubst %/txr.o,%/txr-win.o,$(DBG_OBJS)) $(EXTRA_OBJS-y)
$(call LINK_PROG,-mwindows)
+$(call ADD_CONF,dbg,lisplib.o): $(GEN_HDRS)
+
+$(call ADD_CONF,opt,lisplib.o): $(GEN_HDRS)
+
VPATH := $(top_srcdir)
# Newline constant
@@ -226,12 +243,13 @@ distclean:
rm -rf config
rm -rf config.*
rm -rf mpi-1.?.?
+ rm -rf $(GEN_HDRS)
else
rebuild: clean repatch $(PROG)
clean: conftest.clean tests.clean
rm -f $(PROG)$(EXE) $(PROG)-dbg$(EXE) y.tab.c lex.yy.c y.tab.h y.output
- rm -rf opt dbg $(EXTRA_OBJS-y)
+ rm -rf opt dbg $(EXTRA_OBJS-y) $(GEN_HDRS)
distclean: clean
rm -rf $(conf_dir)
diff --git a/eval.c b/eval.c
index 1e880122..2ff257cc 100644
--- a/eval.c
+++ b/eval.c
@@ -48,6 +48,7 @@
#include "rand.h"
#include "txr.h"
#include "combi.h"
+#include "lisplib.h"
#include "eval.h"
#define APPLY_ARGS 32
@@ -71,8 +72,8 @@ val defvar_s, defun_s, defmacro_s, tree_case_s, tree_bind_s;
val caseq_s, caseql_s, casequal_s;
val memq_s, memql_s, memqual_s;
val eq_s, eql_s, equal_s;
-val inc_s, dec_s, push_s, pop_s, flip_s, zap_s, gethash_s, car_s, cdr_s, not_s;
-val del_s, vecref_s;
+val gethash_s, car_s, cdr_s, not_s, vecref_s;
+val setq_s, inc_s, zap_s;
val for_s, for_star_s, each_s, each_star_s, collect_each_s, collect_each_star_s;
val append_each_s, append_each_star_s, while_s, while_star_s, until_star_s;
val dohash_s;
@@ -163,6 +164,8 @@ noreturn static val eval_error(val form, val fmt, ...)
val lookup_var(val env, val sym)
{
+ uses_or2;
+
if (env) {
type_check(env, ENV);
@@ -179,7 +182,8 @@ val lookup_var(val env, val sym)
return binding;
}
- return(gethash(top_vb, sym));
+ return or2(gethash(top_vb, sym),
+ if2(lisplib_try_load(sym), gethash(top_vb, sym)));
}
static val lookup_sym_lisp1(val env, val sym)
@@ -204,7 +208,10 @@ static val lookup_sym_lisp1(val env, val sym)
return binding;
}
- return or2(gethash(top_vb, sym), gethash(top_fb, sym));
+ return or3(gethash(top_vb, sym),
+ if2(lisplib_try_load(sym),
+ gethash(top_vb, sym)),
+ gethash(top_fb, sym));
}
loc lookup_var_l(val env, val sym)
@@ -227,14 +234,23 @@ loc lookup_var_l(val env, val sym)
{
val binding = gethash(top_vb, sym);
- return (binding) ? cdr_l(binding) : nulloc;
+ if (binding)
+ return cdr_l(binding);
+ lisplib_try_load(sym);
+ binding = gethash(top_vb, sym);
+ if (binding)
+ return cdr_l(binding);
+ return nulloc;
}
}
val lookup_fun(val env, val sym)
{
+ uses_or2;
+
if (nilp(env)) {
- return gethash(top_fb, sym);
+ return or2(gethash(top_fb, sym),
+ if2(lisplib_try_load(sym), gethash(top_fb, sym)));
} else {
type_check(env, ENV);
@@ -249,8 +265,11 @@ val lookup_fun(val env, val sym)
static val lookup_mac(val menv, val sym)
{
+ uses_or2;
+
if (nilp(menv)) {
- return gethash(top_mb, sym);
+ return or2(gethash(top_mb, sym),
+ if2(lisplib_try_load(sym), gethash(top_mb, sym)));
} else {
type_check(menv, ENV);
@@ -265,8 +284,11 @@ static val lookup_mac(val menv, val sym)
static val lookup_symac(val menv, val sym)
{
+ uses_or2;
+
if (nilp(menv)) {
- return gethash(top_smb, sym);
+ return or2(gethash(top_smb, sym),
+ if2(lisplib_try_load(sym), gethash(top_smb, sym)));
} else {
type_check(menv, ENV);
@@ -281,8 +303,11 @@ static val lookup_symac(val menv, val sym)
static val lookup_symac_lisp1(val menv, val sym)
{
+ uses_or2;
+
if (nilp(menv)) {
- return gethash(top_smb, sym);
+ return or2(gethash(top_smb, sym),
+ if2(lisplib_try_load(sym), gethash(top_smb, sym)));
} else {
type_check(menv, ENV);
@@ -371,7 +396,9 @@ static void mark_special(val sym)
static val special_p(val sym)
{
- return gethash(special, sym);
+ uses_or2;
+ return or2(gethash(special, sym),
+ if2(lisplib_try_load(sym), gethash(special, sym)));
}
static val env_vbind_special(val env, val sym, val obj,
@@ -1631,287 +1658,20 @@ static val op_tree_bind(val form, val env)
return eval_progn(body, new_env, body);
}
-static val op_modplace(val form, val env);
-
-static loc dwim_loc(val form, val env, val op, val newform, val *retval)
+static val op_setq(val form, val env)
{
- val evargs = eval_args_lisp1(rest(form), env, form);
- val obj = first(evargs);
- val args = rest(evargs);
-
- switch (type(obj)) {
- case LIT:
- case STR:
- case LSTR:
- if (rest(args))
- eval_error(form, lit("[~s ...]: string indexing needs one arg"),
- obj, nao);
- {
- val index = first(args);
-
- if (consp(index)) {
- cons_bind (from, to, index);
-
- if (listp(to)) {
- from = index;
- to = colon_k;
- }
-
- if (op == set_s) {
- val newval = eval(newform, env, form);
- replace_str(obj, newval, from, to);
- *retval = newval;
- } else if (op == del_s) {
- *retval = sub_str(obj, from, to);
- replace_str(obj, nil, from, to);
- } else {
- eval_error(form, lit("[~s ~s]: ranges and index lists allow only set and del operators"),
- obj, index, nao);
- }
-
- return nulloc;
- } else {
- uses_or2;
-
- if (op == set_s) {
- val newval = eval(newform, env, form);
- chr_str_set(obj, index, eval(newform, env, form));
- *retval = newval;
- } else if (op == inc_s) {
- val newval = plus(chr_str(obj, index),
- or2(eval(newform, env, form), one));
- chr_str_set(obj, index, newval);
- *retval = newval;
- } else if (op == dec_s) {
- val newval = minus(chr_str(obj, index),
- or2(eval(newform, env, form), one));
- chr_str_set(obj, index, newval);
- *retval = newval;
- } else if (op == del_s) {
- *retval = chr_str(obj, index);
- replace_str(obj, nil, index, plus(index, one));
- } else {
- eval_error(form, lit("[~s ~s]: only set, inc, dec and del can be "
- "used for string indices"), obj, index, nao);
- }
- return nulloc;
- }
- }
- case SYM:
- case FUN:
- eval_error(form, lit("[~s ...]: assigning through function not implemented!"),
- obj, nao);
- case VEC:
- if (rest(args))
- eval_error(form, lit("[~s ...]: vector indexing needs one arg"),
- obj, nao);
- {
- val index = first(args);
-
- if (consp(index)) {
- cons_bind (from, to, index);
-
- if (listp(to)) {
- from = index;
- to = colon_k;
- }
-
- if (op == set_s) {
- val newval = eval(newform, env, form);
- replace_vec(obj, newval, from, to);
- *retval = newval;
- } else if (op == del_s) {
- *retval = sub_vec(obj, from, to);
- replace_vec(obj, nil, from, to);
- } else {
- eval_error(form, lit("[~s ~s]: ranges allow only set and del operators"),
- obj, index, nao);
- }
- return nulloc;
- } else {
- if (op == del_s) {
- *retval = vecref(obj, index);
- replace_vec(obj, nil, index, plus(index, one));
- return nulloc;
- }
- return vecref_l(obj, index);
- }
- }
- case NIL:
- case CONS:
- case LCONS:
- if (rest(args))
- eval_error(form, lit("[~s ...]: list indexing needs one arg"),
- obj, nao);
- {
- val index = first(args);
- val cell = obj;
- if (bignump(index) || fixnump(index)) {
- if (op == del_s) {
- *retval = vecref(obj, index);
- replace_list(obj, nil, index, plus(index, one));
- return nulloc;
- }
- return listref_l(obj, index);
- } else if (consp(index)) {
- val newlist;
- val tempform;
- cons_bind (from, to, index);
-
- if (listp(to)) {
- from = index;
- to = colon_k;
- }
-
- if (op == set_s) {
- val newval = eval(newform, env, form);
- newlist = replace_list(obj, newval, from, to);
- tempform = list(op, second(form),
- cons(quote_s, cons(newlist, nil)), nao);
- op_modplace(tempform, env);
- *retval = newval;
- } else if (op == del_s) {
- *retval = sub_list(obj, from, to);
- newlist = replace_list(obj, nil, from, to);
- tempform = list(op, second(form),
- cons(quote_s, cons(newlist, nil)), nao);
- op_modplace(tempform, env);
- } else {
- eval_error(form, lit("[~s ~s]: ranges allow only set and del operators"),
- obj, index, nao);
- }
- return nulloc;
- } else {
- eval_error(form, lit("[~s ~s]: index must be integer, or pair"),
- cell, index, nao);
- }
- }
- case COBJ:
- {
- if (hashp(obj)) {
- val new_p;
- loc place;
- if (lt(length(args), one))
- eval_error(form, lit("[~s ...]: hash indexing needs at least one arg"),
- obj, nao);
-
- if (op == del_s) {
- *retval = gethash(obj, first(args));
- remhash(obj, first(args));
- return nulloc;
- }
-
- place = gethash_l(obj, first(args), mkcloc(new_p));
- if (new_p)
- set(place, second(args));
- return place;
- }
- }
- default:
- eval_error(form, lit("object ~s not supported by [] notation"), obj, nao);
- }
-
- return nulloc;
-}
-
-static loc force_l(val promise);
-
-static val op_modplace(val form, val env)
-{
- uses_or2;
- val op = first(form);
- val place = second(form);
- val third_arg_p = rest(rest(form));
- val newform = if3(car(third_arg_p), third(form), nil);
- val newval = nil;
- loc ptr = nulloc;
-
- if (op == push_s) {
- val tmp = place;
- if (!third_arg_p)
- eval_error(form, lit("~s: missing argument"), op, place, nao);
- place = third(form);
- newform = tmp;
- newval = eval(newform, env, form);
- }
+ val args = rest(form);
+ val var = pop(&args);
+ val newval = pop(&args);
- if (symbolp(place)) {
- if (!bindable(place))
- eval_error(form, lit("~s: ~s is not a bindable symbol"), op, place, nao);
- ptr = lookup_var_l(env, place);
- if (nullocp(ptr))
- eval_error(form, lit("unbound variable ~s"), place, nao);
- } else if (consp(place)) {
- /* TODO: dispatch these with hash table. */
- val sym = car(place);
- if (sym == dwim_s) {
- val ret = nil;
- ptr = dwim_loc(place, env, op, newform, &ret);
- if (nullocp(ptr))
- return ret;
- } else if (sym == gethash_s) {
- val hash = eval(second(place), env, form);
- val key = eval(third(place), env, form);
- val new_p;
- if (op == del_s) {
- val ret = gethash(hash, key);
- remhash(hash, key);
- return ret;
- }
- ptr = gethash_l(hash, key, mkcloc(new_p));
- if (new_p)
- set(ptr, eval(fourth(place), env, form));
- } else if (sym == car_s) {
- val cons = eval(second(place), env, form);
- ptr = car_l(cons);
- } else if (sym == cdr_s) {
- val cons = eval(second(place), env, form);
- ptr = cdr_l(cons);
- } else if (sym == vecref_s) {
- val vec = eval(second(place), env, form);
- val ind = eval(third(place), env, form);
- ptr = vecref_l(vec, ind);
- } else if (sym == force_s) {
- val promise = eval(second(place), env, form);
- ptr = force_l(promise);
- } else {
- eval_error(form, lit("~s: ~s is not a recognized place form"),
- op, place, nao);
- }
+ if (!bindable(var)) {
+ eval_error(form, lit("setvar: ~s is not a bindable symbol"), var, nao);
} else {
- eval_error(form, lit("~s: ~s is not a place"), op, place, nao);
- }
-
- if (nullocp(ptr))
- eval_error(form, lit("~s: place ~s doesn't exist"), op, place, nao);
-
- if (op == set_s) {
- if (!third_arg_p)
- eval_error(form, lit("~s: missing argument"), op, nao);
- return set(ptr, eval(newform, env, form));
- } else if (op == inc_s) {
- val inc = or2(eval(newform, env, form), one);
- return set(ptr, plus(deref(ptr), inc));
- } else if (op == dec_s) {
- val inc = or2(eval(newform, env, form), one);
- return set(ptr, minus(deref(ptr), inc));
- } else if (op == push_s) {
- return mpush(newval, ptr);
- } else if (op == pop_s) {
- if (third_arg_p)
- eval_error(form, lit("~s: superfluous argument"), op, nao);
- return pop(valptr(ptr));
- } else if (op == flip_s) {
- return deref(ptr) = null(deref(ptr));
- } else if (op == zap_s) {
- val oldval = deref(ptr);
- set(ptr, eval(newform, env, form));
- return oldval;
- } else if (op == del_s) {
- eval_error(form, lit("~s: cannot delete ~a"), op, place, nao);
+ loc ptr = lookup_var_l(env, var);
+ if (nullocp(ptr))
+ eval_error(form, lit("unbound variable ~s"), var, nao);
+ return set(ptr, eval(newval, env, form));
}
-
- internal_error("unhandled place modifier");
}
static val op_for(val form, val env)
@@ -3787,18 +3547,6 @@ static val force(val promise)
}
}
-static loc force_l(val promise)
-{
- loc pstate = car_l(promise);
- val cd = cdr(promise);
- loc pval = car_l(cd);
-
- if (deref(pstate) != promise_forced_s)
- force(promise);
-
- return pval;
-}
-
static void reg_op(val sym, opfun_t fun)
{
assert (sym != 0);
@@ -4021,13 +3769,9 @@ void eval_init(void)
defsymacro_s = intern(lit("defsymacro"), user_package);
tree_case_s = intern(lit("tree-case"), user_package);
tree_bind_s = intern(lit("tree-bind"), user_package);
+ setq_s = intern(lit("setq"), system_package);
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);
- flip_s = intern(lit("flip"), user_package);
zap_s = intern(lit("zap"), user_package);
- del_s = intern(lit("del"), user_package);
for_s = intern(lit("for"), user_package);
for_star_s = intern(lit("for*"), user_package);
each_s = intern(lit("each"), user_package);
@@ -4117,14 +3861,7 @@ void eval_init(void)
reg_op(defsymacro_s, op_defsymacro);
reg_op(tree_case_s, op_tree_case);
reg_op(tree_bind_s, op_tree_bind);
- reg_op(inc_s, op_modplace);
- reg_op(dec_s, op_modplace);
- reg_op(set_s, op_modplace);
- reg_op(push_s, op_modplace);
- reg_op(pop_s, op_modplace);
- reg_op(flip_s, op_modplace);
- reg_op(zap_s, op_modplace);
- reg_op(del_s, op_modplace);
+ reg_op(setq_s, op_setq);
reg_op(for_s, op_for);
reg_op(for_star_s, op_for);
reg_op(dohash_s, op_dohash);
@@ -4183,6 +3920,8 @@ void eval_init(void)
reg_fun(cdr_s, cdr_f);
reg_fun(intern(lit("rplaca"), user_package), func_n2(rplaca));
reg_fun(intern(lit("rplacd"), user_package), func_n2(rplacd));
+ reg_fun(intern(lit("rplaca"), system_package), func_n2(sys_rplaca));
+ reg_fun(intern(lit("rplacd"), system_package), func_n2(sys_rplacd));
reg_fun(intern(lit("first"), user_package), func_n1(car));
reg_fun(rest_s, func_n1(cdr));
reg_fun(intern(lit("sub-list"), user_package), func_n3o(sub_list, 1));
@@ -4576,6 +4315,8 @@ void eval_init(void)
reg_fun(intern(lit("ref"), user_package), func_n2(ref));
reg_fun(intern(lit("refset"), user_package), func_n3(refset));
reg_fun(intern(lit("replace"), user_package), func_n4o(replace, 2));
+ reg_fun(intern(lit("dwim-set"), system_package), func_n3(dwim_set));
+ reg_fun(intern(lit("dwim-del"), system_package), func_n2(dwim_del));
reg_fun(intern(lit("update"), user_package), func_n2(update));
reg_fun(intern(lit("search"), user_package), func_n4o(search, 2));
reg_fun(intern(lit("where"), user_package), func_n2(where));
@@ -4634,4 +4375,6 @@ void eval_init(void)
eval_error_s = intern(lit("eval-error"), user_package);
uw_register_subtype(eval_error_s, error_s);
+
+ lisplib_init();
}
diff --git a/genvim.txr b/genvim.txr
index df4006c6..cd0c7cde 100644
--- a/genvim.txr
+++ b/genvim.txr
@@ -9,7 +9,7 @@ static void dir_tables_init(void)
@(end)
@(next @(open-files '("eval.c" "rand.c" "signal.c" "stream.c" "gc.c" "glob.c"
"syslog.c" "filter.c" "txr.c" "arith.c" "unwind.c"
- "sysif.c")))
+ "sysif.c" "place.tl")))
@(collect)
@ (block)
@ (cases)
@@ -31,6 +31,8 @@ static void dir_tables_init(void)
@ (bind txl-sym `*@{txl-sym-special}*`)
@ (or)
@/ */reg_var(@(skip)intern(lit("@{txl-sym}")@(skip)
+@ (or)
+ (@/defun|defvar|defmacro/ @{txl-sym} @(skip)
@ (end)
@ (set txl-sym @(regsub #/_/ #\- txl-sym))
@ (end)
diff --git a/hash.c b/hash.c
index 65f56adf..f5130e73 100644
--- a/hash.c
+++ b/hash.c
@@ -613,6 +613,7 @@ val remhash(val hash, val key)
set(pchain, nappend2(ldiff(deref(pchain), cell), cdr(cell)));
h->count--;
bug_unless (h->count >= 0);
+ return cdr(existing);
}
return nil;
diff --git a/lib.c b/lib.c
index 0503d615..e9f4b630 100644
--- a/lib.c
+++ b/lib.c
@@ -288,7 +288,6 @@ val rplaca(val cons, val new_car)
}
}
-
val rplacd(val cons, val new_cdr)
{
switch (type(cons)) {
@@ -303,6 +302,18 @@ val rplacd(val cons, val new_cdr)
}
}
+val sys_rplaca(val cons, val new_car)
+{
+ (void) rplaca(cons, new_car);
+ return new_car;
+}
+
+val sys_rplacd(val cons, val new_car)
+{
+ (void) rplacd(cons, new_car);
+ return new_car;
+}
+
loc car_l(val cons)
{
switch (type(cons)) {
@@ -6269,6 +6280,9 @@ val ref(val seq, val ind)
return chr_str(seq, ind);
case VEC:
return vecref(seq, ind);
+ case COBJ:
+ if (seq->co.cls == hash_s)
+ return gethash(seq, ind);
default:
type_mismatch(lit("ref: ~s is not a sequence"), seq, nao);
}
@@ -6287,6 +6301,9 @@ val refset(val seq, val ind, val newval)
return chr_str_set(seq, ind, newval);
case VEC:
return set(vecref_l(seq, ind), newval);
+ case COBJ:
+ if (seq->co.cls == hash_s)
+ return sethash(seq, ind, newval);
default:
type_mismatch(lit("ref: ~s is not a sequence"), seq, nao);
}
@@ -6311,6 +6328,38 @@ val replace(val seq, val items, val from, val to)
}
}
+val dwim_set(val seq, val ind_range, val newval)
+{
+ if (consp(ind_range)) {
+ cons_bind (x, y, ind_range);
+
+ if (atom(y))
+ return replace(seq, newval, x, y);
+ return replace(seq, newval, ind_range, colon_k);
+ } else if (vectorp(ind_range)) {
+ return replace(seq, newval, ind_range, colon_k);
+ } else{
+ (void) refset(seq, ind_range, newval);
+ return seq;
+ }
+
+ return newval;
+}
+
+val dwim_del(val seq, val ind_range)
+{
+ if (consp(ind_range)) {
+ return replace(seq, nil, car(ind_range), cdr(ind_range));
+ } else {
+ if (hashp(seq)) {
+ (void) remhash(seq, ind_range);
+ return seq;
+ } else {
+ return replace(seq, nil, ind_range, succ(ind_range));
+ }
+ }
+}
+
val update(val seq, val fun)
{
switch (type(seq)) {
diff --git a/lib.h b/lib.h
index 052b46a8..4c644984 100644
--- a/lib.h
+++ b/lib.h
@@ -434,6 +434,8 @@ val car(val cons);
val cdr(val cons);
val rplaca(val cons, val new_car);
val rplacd(val cons, val new_car);
+val sys_rplaca(val cons, val new_car);
+val sys_rplacd(val cons, val new_car);
loc car_l(val cons);
loc cdr_l(val cons);
val first(val cons);
@@ -838,6 +840,8 @@ val empty(val seq);
val sub(val seq, val from, val to);
val ref(val seq, val ind);
val refset(val seq, val ind, val newval);
+val dwim_set(val seq, val ind_range, val newval);
+val dwim_del(val seq, val ind_range);
val replace(val seq, val items, val from, val to);
val update(val seq, val fun);
val search(val seq, val key, val from, val to);
diff --git a/lisplib.c b/lisplib.c
new file mode 100644
index 00000000..d6b7876a
--- /dev/null
+++ b/lisplib.c
@@ -0,0 +1,83 @@
+/* Copyright 2015
+ * Kaz Kylheku <kaz@kylheku.com>
+ * Vancouver, Canada
+ * All rights reserved.
+ *
+ * Redistribution of this software in source and binary forms, with or without
+ * modification, is permitted provided that the following two conditions are met.
+ *
+ * Use of this software in any manner constitutes agreement with the disclaimer
+ * which follows the two conditions.
+ *
+ * 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.
+ *
+ * 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. IN NO EVENT SHALL THE
+ * COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DAMAGES, HOWEVER CAUSED,
+ * AND UNDER ANY THEORY OF LIABILITY, ARISING IN ANY WAY OUT OF THE USE OF THIS
+ * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ */
+
+#include <stdio.h>
+#include <wchar.h>
+#include <dirent.h>
+#include <stdarg.h>
+#include "config.h"
+#include "lib.h"
+#include "eval.h"
+#include "parser.h"
+#include "stream.h"
+#include "hash.h"
+#include "gc.h"
+#include "place.h"
+#include "lisplib.h"
+
+static val dl_table;
+
+static void set_place_dlt_entries(val dlt, val fun)
+{
+ int i;
+ val dl_sym[] = {
+ lit("*place-clobber-expander*"), lit("*place-update-expander*"),
+ lit("*place-delete-expander*"),
+ lit("get-update-expander"), lit("get-clobber-expander"),
+ lit("get-delete-expander"),
+ lit("rlet"), lit("with-gensyms"),
+ lit("call-update-expander"), lit("call-clobber-expander"),
+ lit("call-delete-expander)"),
+ lit("with-update-expander"), lit("with-clobber-expander"),
+ lit("with-delete-expander"),
+ lit("set"), lit("zap"), lit("flip"), lit("inc"), lit("dec"),
+ lit("push"), lit("pop"), lit("swap"), lit("shift"), lit("rotate"),
+ lit("del"),
+ nil
+ };
+
+ for (i = 0; dl_sym[i]; i++)
+ sethash(dlt, intern(dl_sym[i], user_package), fun);
+}
+
+static val place_instantiate(val dlt)
+{
+ set_place_dlt_entries(dlt, nil);
+ return eval_intrinsic(lisp_parse(static_str(place_code), std_error, nil), nil);
+}
+
+void lisplib_init(void)
+{
+ prot1(&dl_table);
+ dl_table = make_hash(nil, nil, nil);
+ set_place_dlt_entries(dl_table, func_f0(dl_table, place_instantiate));
+}
+
+val lisplib_try_load(val sym)
+{
+ val fun = gethash(dl_table, sym);
+ return if3(fun, (funcall(fun), t), nil);
+}
diff --git a/lisplib.h b/lisplib.h
new file mode 100644
index 00000000..e947296e
--- /dev/null
+++ b/lisplib.h
@@ -0,0 +1,28 @@
+/* Copyright 2015
+ * Kaz Kylheku <kaz@kylheku.com>
+ * Vancouver, Canada
+ * All rights reserved.
+ *
+ * Redistribution of this software in source and binary forms, with or without
+ * modification, is permitted provided that the following two conditions are met.
+ *
+ * Use of this software in any manner constitutes agreement with the disclaimer
+ * which follows the two conditions.
+ *
+ * 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.
+ *
+ * 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. IN NO EVENT SHALL THE
+ * COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DAMAGES, HOWEVER CAUSED,
+ * AND UNDER ANY THEORY OF LIABILITY, ARISING IN ANY WAY OUT OF THE USE OF THIS
+ * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ */
+
+void lisplib_init(void);
+val lisplib_try_load(val sym);
diff --git a/place.tl b/place.tl
new file mode 100644
index 00000000..d74b1f62
--- /dev/null
+++ b/place.tl
@@ -0,0 +1,416 @@
+;; Copyright 2015
+;; Kaz Kylheku <kaz@kylheku.com>
+;; Vancouver, Canada
+;; All rights reserved.
+;;
+;; Redistribution of this software in source and binary forms, with or without
+;; modification, is permitted provided that the following two conditions are met.
+;;
+;; Use of this software in any manner constitutes agreement with the disclaimer
+;; which follows the two conditions.
+;;
+;; 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.
+;;
+;; 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. IN NO EVENT SHALL THE
+;; COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DAMAGES, HOWEVER CAUSED,
+;; AND UNDER ANY THEORY OF LIABILITY, ARISING IN ANY WAY OUT OF THE USE OF THIS
+;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(progn
+ (macro-time
+ (defvar *place-clobber-expander* (hash))
+ (defvar *place-update-expander* (hash))
+ (defvar *place-delete-expander* (hash))
+
+ (defun sys:eval-err (. params)
+ (throwf 'eval-error . params))
+
+ (defun sys:sym-update-expander (getter-name setter-name
+ place-expr . op-body)
+ ^(macrolet ((,getter-name () ',place-expr)
+ (,setter-name (val-expr) ^(sys:setq ,',place-expr ,val-expr)))
+ ,*op-body))
+
+ (defun sys:sym-clobber-expander (simple-setter-name
+ place-expr . op-body)
+ ^(macrolet ((,simple-setter-name (val-expr) ^(sys:setq ,',place-expr
+ ,val-expr)))
+ ,*op-body))
+
+ (defun get-update-expander (place)
+ (cond
+ ((symbolp place) (fun sys:sym-update-expander))
+ ((consp place) (or [*place-update-expander* (car place)]
+ (sys:eval-err "~s is not an assignable place" place)))
+ (t (sys:eval-err "form ~s is not syntax denoting an assignable place" place))))
+
+ (defun get-clobber-expander (place)
+ (cond
+ ((symbolp place) (fun sys:sym-clobber-expander))
+ ((consp place) (or [*place-clobber-expander* (car place)]
+ (iflet ((fun [*place-update-expander* (car place)]))
+ (op apply fun (gensym) @1 @2 @rest))
+ (sys:eval-err "~s is not an assignable place" place)))
+ (t (sys:eval-err "form ~s is not syntax denoting an assignable place" place))))
+
+ (defun get-delete-expander (place)
+ (if (consp place)
+ (or [*place-delete-expander* (car place)]
+ (sys:eval-err "~s is not a deletable place" place))
+ (sys:eval-err "form ~s is not syntax denoting a deletable place" place))))
+
+ (defmacro rlet (bindings :env e . body)
+ (let ((exp-bindings (mapcar (aret ^(,@1 ,(macroexpand @2 e))) bindings)))
+ (let ((renames [keep-if [orf symbolp constantp] exp-bindings second])
+ (regular [remove-if [orf symbolp constantp] exp-bindings second]))
+ (cond ((and renames regular)
+ ^(symacrolet ,renames
+ (let ,regular ,*body)))
+ (renames ^(symacrolet ,renames ,*body))
+ (regular ^(let ,regular ,*body))
+ (t ^(progn ,*body))))))
+
+ (defmacro with-gensyms (syms . body)
+ ^(let ,(zip syms (repeat '((gensym)))) ,*body))
+
+ (macro-time
+ (defun call-update-expander (getter setter unex-place env . body)
+ (let* ((place (sys:expand unex-place env))
+ (expander (get-update-expander place)))
+ [expander getter setter place . body]))
+
+ (defun call-clobber-expander (ssetter unex-place env . body)
+ (let* ((place (sys:expand unex-place env))
+ (expander (get-clobber-expander place)))
+ [expander ssetter place . body]))
+
+ (defun call-delete-expander (deleter unex-place env . body)
+ (let* ((place (sys:expand unex-place env))
+ (expander (get-delete-expander place)))
+ [expander deleter place . body])))
+
+ (defmacro with-update-expander ((getter setter) unex-place env . body)
+ ^(with-gensyms (,getter ,setter)
+ (call-update-expander ,getter ,setter ,unex-place ,env . ,body)))
+
+ (defmacro with-clobber-expander ((ssetter) unex-place env . body)
+ ^(with-gensyms (,ssetter)
+ (call-clobber-expander ,ssetter ,unex-place ,env . ,body)))
+
+ (defmacro with-delete-expander ((deleter) unex-place env . body)
+ ^(with-gensyms (,deleter)
+ (call-delete-expander ,deleter ,unex-place ,env . ,body)))
+
+ (defmacro set (place value :env env)
+ (with-clobber-expander (ssetter) place env
+ ^(,ssetter ,value)))
+
+ (defmacro zap (place :env env)
+ (with-update-expander (getter setter) place env
+ ^(prog1 (,getter) (,setter nil))))
+
+ (defmacro flip (place :env env)
+ (with-update-expander (getter setter) place env
+ ^(,setter (not (,getter)))))
+
+ (defmacro inc (place : (delta 1) :env env)
+ (with-update-expander (getter setter) place env
+ (caseql delta
+ (0 ^(,setter (,getter)))
+ (1 ^(,setter (succ (,getter))))
+ (2 ^(,setter (ssucc (,getter))))
+ (3 ^(,setter (sssucc (,getter))))
+ (t ^(,setter (+ (,getter) ,delta))))))
+
+ (defmacro dec (place : (delta 1) :env env)
+ (with-update-expander (getter setter) place env
+ (caseql delta
+ (0 ^(,setter (,getter)))
+ (1 ^(,setter (pred (,getter))))
+ (2 ^(,setter (ppred (,getter))))
+ (3 ^(,setter (pppred (,getter))))
+ (t ^(,setter (- (,getter) ,delta))))))
+
+ (defmacro swap (place-0 place-1 :env env)
+ (with-gensyms (tmp)
+ (with-update-expander (getter-0 setter-0) place-0 env
+ (with-update-expander (getter-1 setter-1) place-1 env
+ ^(let ((,tmp (,getter-0)))
+ (,setter-0 (,getter-1))
+ (,setter-1 ,tmp))))))
+
+ (defmacro push (new-item place :env env)
+ (with-update-expander (getter setter) place env
+ ^(,setter (cons ,new-item (,getter)))))
+
+ (defmacro pop (place :env env)
+ (with-gensyms (tmp)
+ (with-update-expander (getter setter) place env
+ ^(let ((,tmp (,getter)))
+ (prog1 (car ,tmp) (,setter (cdr ,tmp)))))))
+
+ (defmacro shift (:env env . places)
+ (tree-case places
+ (() (sys:eval-err "shift: need at least two arguments"))
+ ((place) (sys:eval-err "shift: need at least two arguments"))
+ ((place newvalue)
+ (with-update-expander (getter setter) place env
+ ^(prog1 (,getter) (,setter ,newvalue))))
+ ((place . others)
+ (with-update-expander (getter setter) place env
+ ^(prog1 (,getter) (,setter (shift ,*others)))))))
+
+ (defmacro rotate (:env env . places)
+ (tree-case places
+ (() ())
+ ((fplace) fplace)
+ ((fplace . rplaces)
+ (with-gensyms (tmp)
+ (with-update-expander (getter-f setter-f) fplace env
+ ^(let ((,tmp (,getter-f)))
+ (,setter-f (shift ,*rplaces ,tmp))
+ ,tmp))))))
+
+ (defmacro del (place :env env)
+ (with-delete-expander (deleter) place env
+ ^(,deleter)))
+
+ (defmacro defplace (place-destructuring-args body-sym
+ (getter-sym setter-sym . update-body) :
+ ((ssetter-sym . clobber-body))
+ ((deleter-sym . delete-body)))
+ (symacrolet ((name (car place-destructuring-args))
+ (args (cdr place-destructuring-args)))
+ (unless (and name
+ (symbolp name)
+ (not (keywordp name))
+ (not (eq t name)))
+ (sys:eval-err "~s: ~s cannot be used as a place name"
+ 'defplace name))
+ (with-gensyms (place)
+ ^(macro-time
+ (sethash *place-update-expander* ',name
+ (lambda (,getter-sym ,setter-sym ,place . ,body-sym)
+ (tree-bind ,args (cdr ,place)
+ ,*update-body)))
+ ,*(if ssetter-sym
+ ^((sethash *place-clobber-expander* ',name
+ (lambda (,ssetter-sym ,place . ,body-sym)
+ (tree-bind ,args (cdr ,place)
+ ,*clobber-body)))))
+ ,*(if deleter-sym
+ ^((sethash *place-delete-expander* ',name
+ (lambda (,deleter-sym ,place . ,body-sym)
+ (tree-bind ,args (cdr ,place)
+ ,*delete-body)))))))))
+
+ (defplace (car cell) body
+ (getter setter
+ (with-gensyms (cell-sym)
+ ^(rlet ((,cell-sym ,cell))
+ (macrolet ((,getter () ^(car ,',cell-sym))
+ (,setter (val) ^(sys:rplaca ,',cell-sym ,val)))
+ ,*body))))
+ (ssetter
+ ^(macrolet ((,ssetter (val) ^(sys:rplaca ,',cell ,val)))
+ ,*body))
+ (deleter
+ ^(macrolet ((,deleter () ^(pop ,',cell)))
+ ,*body)))
+
+ (defplace (cdr cell) body
+ (getter setter
+ (with-gensyms (cell-sym)
+ ^(rlet ((,cell-sym ,cell))
+ (macrolet ((,getter () ^(cdr ,',cell-sym))
+ (,setter (val) ^(sys:rplacd ,',cell-sym ,val)))
+ ,*body))))
+ (ssetter
+ ^(macrolet ((,ssetter (val) ^(sys:rplacd ,',cell ,val)))
+ ,*body))
+ (deleter
+ ^(macrolet ((,deleter () ^(zap (cdr ,',cell))))
+ ,*body)))
+
+ (defplace (vecref vector index :whole args) body
+ (getter setter
+ (with-gensyms (vec-sym ind-sym)
+ ^(rlet ((,vec-sym ,vector)
+ (,ind-sym ,index))
+ (macrolet ((,getter () ^(vecref ,',vec-sym ,',ind-sym))
+ (,setter (val) ^(refset ,',vec-sym ,',ind-sym ,val)))
+ ,*body))))
+ (ssetter
+ ^(macrolet ((,ssetter (val) ^(refset ,*',args ,val)))
+ ,*body))
+ (deleter
+ (with-gensyms (vec-sym ind-sym)
+ ^(rlet ((,vec-sym ,vector)
+ (,ind-sym ,index))
+ (macrolet ((,deleter ()
+ ^(prog1 (vecref ,',vec-sym ,',ind-sym)
+ (replace-vec ,',vec-sym nil
+ ,',ind-sym (succ ,',ind-sym)))))
+ ,*body)))))
+
+ (defplace (chr-str string index :whole args) body
+ (getter setter
+ (with-gensyms (str-sym ind-sym)
+ ^(rlet ((,str-sym ,string)
+ (,ind-sym ,index))
+ (macrolet ((,getter () ^(chr-str ,',str-sym ,',ind-sym))
+ (,setter (val) ^(chr-str-set ,',str-sym ,',ind-sym ,val)))
+ ,*body))))
+ (ssetter
+ ^(macrolet ((,ssetter (val) ^(chr-str-set ,*',args ,val)))
+ ,*body))
+ (deleter
+ (with-gensyms (str-sym ind-sym)
+ ^(rlet ((,str-sym ,string)
+ (,ind-sym ,index))
+ (macrolet ((,deleter ()
+ ^(prog1 (chr-str ,',str-sym ,',ind-sym)
+ (replace-str ,',str-sym nil
+ ,',ind-sym (succ ,',ind-sym)))))
+ ,*body)))))
+
+ (defplace (ref seq index :whole args) body
+ (getter setter
+ (with-gensyms (seq-sym ind-sym)
+ ^(rlet ((,seq-sym ,seq)
+ (,ind-sym ,index))
+ (macrolet ((,getter () ^(ref ,',seq-sym ,',ind-sym))
+ (,setter (val) ^(refset ,',seq-sym ,',ind-sym ,val)))
+ ,*body))))
+ (ssetter
+ ^(macrolet ((,ssetter (val) ^(refset ,*',args ,val)))
+ ,*body))
+ (deleter
+ (with-gensyms (seq-sym ind-sym)
+ ^(rlet ((,seq-sym ,seq)
+ (,ind-sym ,index))
+ (macrolet ((,deleter ()
+ ^(prog1 (ref ,',seq-sym ,',ind-sym)
+ (replace ,',seq-sym nil
+ ,',ind-sym (succ ,',ind-sym)))))
+ ,*body)))))
+
+ (defplace (gethash hash key : (default nil have-default-p)) body
+ (getter setter
+ (with-gensyms (entry-sym)
+ ^(let ((,entry-sym (inhash ,hash ,key ,default)))
+ (macrolet ((,getter () ^(cdr ,',entry-sym))
+ (,setter (val) ^(sys:rplacd ,',entry-sym ,val)))
+ ,*body))))
+ :
+ (deleter
+ ^(macrolet ((,deleter ()
+ (if ,have-default-p
+ (with-gensyms (entry-sym
+ dfl-sym)
+ ^(rlet ((,entry-sym (inhash ,',hash ,',key))
+ (,dfl-sym ,',default))
+ (if ,entry-sym
+ (remhash ,',hash ,',key)
+ ,dfl-sym)))
+ ^(remhash ,',hash ,',key))))
+ ,*body)))
+
+ (defplace (dwim obj-place index : (default nil have-default-p)) body
+ (getter setter
+ (with-gensyms (ogetter-sym osetter-sym obj-sym
+ oldval-sym newval-sym
+ index-sym index-sym
+ oldval-sym dflval-sym)
+ (with-update-expander (ogetter-sym osetter-sym) obj-place nil
+ ^(rlet ((,obj-sym (,ogetter-sym))
+ (,index-sym ,index)
+ ,*(if have-default-p
+ ^((,dflval-sym ,default))))
+ (let ((,oldval-sym [,obj-sym
+ ,index-sym
+ ,*(if have-default-p ^(,dflval-sym))]))
+ (macrolet ((,getter () ',oldval-sym)
+ (,setter (val)
+ ^(rlet ((,',newval-sym ,val))
+ (,',osetter-sym
+ (sys:dwim-set ,',obj-sym
+ ,',index-sym ,',newval-sym))
+ ,',newval-sym)))
+ ,*body))))))
+ (ssetter
+ (with-gensyms (osetter-sym ogetter-sym
+ obj-sym newval-sym index-sym)
+ (with-update-expander (ogetter-sym osetter-sym) obj-place nil
+ ^(macrolet ((,ssetter (val)
+ ^(rlet ((,',obj-sym (,',ogetter-sym))
+ (,',index-sym ,',index)
+ (,',newval-sym ,val))
+ (,',osetter-sym
+ (sys:dwim-set ,',obj-sym
+ ,*(if ,have-default-p
+ ^((prog1 ,',index-sym ,',default))
+ ^(,',index-sym))
+ ,',newval-sym))
+ ,',newval-sym)))
+ ,*body))))
+
+ (deleter
+ (with-gensyms (osetter-sym ogetter-sym
+ obj-sym index-sym oldval-sym
+ dflval-sym)
+ (with-update-expander (ogetter-sym osetter-sym) obj-place nil
+ ^(macrolet ((,deleter () ;; todo: place must not have optional val
+ ^(rlet ((,',obj-sym (,',ogetter-sym)))
+ (let* ((,',index-sym ,',index)
+ (,',oldval-sym [,',obj-sym
+ ,',index-sym
+ ,*(if ,have-default-p
+ ^(,',default))]))
+ (progn
+ (,',osetter-sym
+ (sys:dwim-del ,',obj-sym ,',index-sym))
+ ,',oldval-sym)))))
+ ,*body)))))
+
+ (defplace (force promise) body
+ (getter setter
+ (with-gensyms (promise-sym)
+ ^(rlet ((,promise-sym ,promise))
+ (macrolet ((,getter ()
+ ^(force ,',promise-sym))
+ (,setter (val)
+ ^(set (car (cdr ,',promise-sym)) ,val)))
+ ,*body))))
+ (ssetter
+ (with-gensyms (promise-sym)
+ ^(rlet ((,promise-sym ,promise))
+ (macrolet ((,ssetter (val)
+ ^(prog1
+ (set (car (cdr ,',promise-sym)) ,val)
+ (set (car ,',promise-sym) 'sys:promise-forced))))
+ ,*body)))))
+
+ (defplace (errno) body
+ (getter setter
+ ^(macrolet ((,getter () '(errno))
+ (,setter (val-expr)
+ (with-gensyms (val-sym)
+ ^(rlet ((,val-sym ,val-expr))
+ (progn (errno ,val-sym) ,val-sym)))))
+ ,*body)))
+
+ (macro-time
+ (each ((from '(car cdr))
+ (to '(first rest)))
+ (each ((table (list *place-update-expander*
+ *place-clobber-expander*
+ *place-delete-expander*)))
+ (set [table to] [table from])))))
diff --git a/tests/010/seq.expected b/tests/010/seq.expected
index 73009319..5d589d40 100644
--- a/tests/010/seq.expected
+++ b/tests/010/seq.expected
@@ -5,7 +5,6 @@ nil
#\b "acd"
#\d "ac"
exception!
-exception!
#(8 7 6 5 4 3 2 1)
#((7 . #\h) (8 . #\g) (6 . #\f) (5 . #\e) (4 . #\d) (3 . #\c) (2 . #\b) (1 . #\a))
(100 99 98 97 96 95 94 93 92 91 90 89 88 87 86 85 84 83 82 81 80 79 78 77 76 75 74 73 72 71 70 69 68 67 66 65 64 63 62 61 60 59 58 57 56 55 54 53 52 51 50 49 48 47 46 45 44 43 42 41 40 39 38 37 36 35 34 33 32 31 30 29 28 27 26 25 24 23 22 21 20 19 18 17 16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1)
diff --git a/tests/010/seq.txr b/tests/010/seq.txr
index 2983447d..080b01ad 100644
--- a/tests/010/seq.txr
+++ b/tests/010/seq.txr
@@ -14,7 +14,6 @@
(format t "~s ~s\n" (del [*s* 1]) *s*)
(format t "~s ~s\n" (del [*s* -1]) *s*)
(catch (pr (del [*s* 3]) *s*) (t (x) (caught x)))
- (catch (del *h*) (t (x) (caught x)))
(pr [sort *v* >])
(pr [sort *v2* > cdr])
(pr [sort (range 1 100) >])
diff --git a/tests/011/macros-2.expected b/tests/011/macros-2.expected
index a1334a6f..24310618 100644
--- a/tests/011/macros-2.expected
+++ b/tests/011/macros-2.expected
@@ -9,7 +9,7 @@
28
29
30
-(block #:brk-blk-0006 (for nil ((< i 100) nil) nil (block #:cnt-blk-0005 (if (< (inc i) 20) (return-from #:cnt-blk-0005)) (if (> i 30) (return-from #:brk-blk-0006)) (prinl i))))
+(block #:brk-blk-0002 (for nil ((< i 100) nil) nil (block #:cnt-blk-0001 (if (< (sys:setq i (+ i 1)) 20) (return-from #:cnt-blk-0001)) (if (> i 30) (return-from #:brk-blk-0002)) (prinl i))))
(while break)
(while break)
(while break)
diff --git a/tests/011/macros-2.txr b/tests/011/macros-2.txr
index 12f957df..9a53f115 100644
--- a/tests/011/macros-2.txr
+++ b/tests/011/macros-2.txr
@@ -1,4 +1,6 @@
@(do
+ (set *gensym-counter* 0)
+
(defmacro while ((condition : result) . body)
(let ((cblk (gensym "cnt-blk-"))
(bblk (gensym "brk-blk-")))