summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorKaz Kylheku <kaz@kylheku.com>2012-01-01 18:33:48 -0800
committerKaz Kylheku <kaz@kylheku.com>2012-01-01 18:33:48 -0800
commit0e4caada3d016a6e10d695e98a1e2ee9a4a4b9d0 (patch)
treed2569f83775e64766cafaa588b6a4335ccc0b94f
parent82bd3f163894b91c7af377a91beb7a385f21ba55 (diff)
downloadtxr-0e4caada3d016a6e10d695e98a1e2ee9a4a4b9d0.tar.gz
txr-0e4caada3d016a6e10d695e98a1e2ee9a4a4b9d0.tar.bz2
txr-0e4caada3d016a6e10d695e98a1e2ee9a4a4b9d0.zip
Make C globals in TXR Lisp properly assignable, so that for instance
assigning *stdout*, it really overwrites the underlying C variable. * eval.c (lookup_var): Handle new kind of toplevel binding. If the hash value is a cptr, it points to a val storage location. (lookup_val_l): New function. (op_modplace): Get location of variable using lookup_val_l rather than assuming there is a cons-based binding. (reg_var): Argument changed to val * pointer. Register the variable as a cptr referencing the location. (eval_init): reg_var calls pass address of each global. * eval.h (lookup_var_l): Declared.
-rw-r--r--ChangeLog16
-rw-r--r--eval.c50
-rw-r--r--eval.h1
3 files changed, 53 insertions, 14 deletions
diff --git a/ChangeLog b/ChangeLog
index 56554371..87e53de9 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,21 @@
2012-01-01 Kaz Kylheku <kaz@kylheku.com>
+ Make C globals in TXR Lisp properly assignable, so that for instance
+ assigning *stdout*, it really overwrites the underlying C variable.
+
+ * eval.c (lookup_var): Handle new kind of toplevel binding.
+ If the hash value is a cptr, it points to a val storage location.
+ (lookup_val_l): New function.
+ (op_modplace): Get location of variable using lookup_val_l
+ rather than assuming there is a cons-based binding.
+ (reg_var): Argument changed to val * pointer.
+ Register the variable as a cptr referencing the location.
+ (eval_init): reg_var calls pass address of each global.
+
+ * eval.h (lookup_var_l): Declared.
+
+2012-01-01 Kaz Kylheku <kaz@kylheku.com>
+
* eval.c (eval_init): New gensym function registered.
* lib.c (gensym_counter): New variable.
diff --git a/eval.c b/eval.c
index 163f9135..b9ff8197 100644
--- a/eval.c
+++ b/eval.c
@@ -105,7 +105,10 @@ static val eval_error(val form, val fmt, ...)
val lookup_var(val env, val sym)
{
if (nullp(env)) {
- return gethash(top_vb, sym);
+ val bind = gethash(top_vb, sym);
+ if (cobjp(bind))
+ return *(val *) cptr_get(bind);
+ return bind;
} else {
type_check(env, ENV);
@@ -118,6 +121,27 @@ val lookup_var(val env, val sym)
}
}
+val *lookup_var_l(val env, val sym)
+{
+ if (nullp(env)) {
+ val bind = gethash(top_vb, sym);
+ if (cobjp(bind))
+ return (val *) cptr_get(bind);
+ if (bind)
+ return cdr_l(bind);
+ return 0;
+ } else {
+ type_check(env, ENV);
+
+ {
+ val binding = assoc(sym, env->e.vbindings);
+ if (binding)
+ return cdr_l(binding);
+ return lookup_var_l(env->e.up_env, sym);
+ }
+ }
+}
+
val lookup_fun(val env, val sym)
{
if (nullp(env)) {
@@ -539,7 +563,6 @@ static val op_modplace(val form, val env)
val third_arg_p = rest(rest(form));
val newval = if3(car(third_arg_p), third(form), nil);
val *loc = 0;
- val binding = nil;
if (op == push_s) {
val tmp = place;
@@ -554,10 +577,9 @@ static val op_modplace(val form, val env)
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)
+ loc = lookup_var_l(env, place);
+ if (!loc)
eval_error(form, lit("unbound variable ~s"), place, nao);
- loc = cdr_l(binding);
} else if (consp(place)) {
/* TODO: dispatch these with hash table. */
val sym = car(place);
@@ -1139,9 +1161,9 @@ static void reg_fun(val sym, val fun)
sethash(top_fb, sym, cons(sym, fun));
}
-static void reg_var(val sym, val obj)
+static void reg_var(val sym, val *obj)
{
- sethash(top_vb, sym, cons(sym, obj));
+ sethash(top_vb, sym, cptr((mem_t *) obj));
}
void eval_init(void)
@@ -1303,9 +1325,9 @@ void eval_init(void)
reg_fun(intern(lit("eval"), user_package), func_n2(eval_intrinsic));
- reg_var(intern(lit("*stdout*"), user_package), std_output);
- reg_var(intern(lit("*stdin*"), user_package), std_input);
- reg_var(intern(lit("*stderr*"), user_package), std_error);
+ reg_var(intern(lit("*stdout*"), user_package), &std_output);
+ reg_var(intern(lit("*stdin*"), user_package), &std_input);
+ reg_var(intern(lit("*stderr*"), user_package), &std_error);
reg_fun(intern(lit("format"), user_package), func_n2v(formatv));
reg_fun(intern(lit("print"), user_package), func_n2(obj_print));
reg_fun(intern(lit("pprint"), user_package), func_n2(obj_pprint));
@@ -1327,9 +1349,9 @@ void eval_init(void)
reg_fun(intern(lit("open-file"), user_package), func_n2(open_file));
reg_fun(intern(lit("open-pipe"), user_package), func_n2(open_pipe));
- reg_var(intern(lit("*user-package*"), user_package), user_package);
- reg_var(intern(lit("*keyword-package*"), user_package), keyword_package);
- reg_var(intern(lit("*system-package*"), user_package), system_package);
+ reg_var(intern(lit("*user-package*"), user_package), &user_package);
+ reg_var(intern(lit("*keyword-package*"), user_package), &keyword_package);
+ reg_var(intern(lit("*system-package*"), user_package), &system_package);
reg_fun(intern(lit("make-sym"), user_package), func_n1(make_sym));
reg_fun(intern(lit("gensym"), user_package), func_n0v(gensymv));
reg_fun(intern(lit("make-package"), user_package), func_n1(make_package));
@@ -1414,7 +1436,7 @@ void eval_init(void)
reg_fun(intern(lit("functionp"), user_package), func_n1(functionp));
reg_fun(intern(lit("interp-fun-p"), user_package), func_n1(interp_fun_p));
- reg_var(intern(lit("*random-state*"), user_package), random_state);
+ reg_var(intern(lit("*random-state*"), user_package), &random_state);
reg_fun(intern(lit("make-random-state"), user_package), func_n1(make_random_state));
reg_fun(intern(lit("random-state-p"), user_package), func_n1(random_state_p));
reg_fun(intern(lit("random-fixnum"), user_package), func_n1(random_fixnum));
diff --git a/eval.h b/eval.h
index 0c2fa80a..90eca613 100644
--- a/eval.h
+++ b/eval.h
@@ -28,6 +28,7 @@ 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_var_l(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);