summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--eval.c8
-rw-r--r--share/txr/stdlib/compiler.tl16
2 files changed, 14 insertions, 10 deletions
diff --git a/eval.c b/eval.c
index 71901251..07869c41 100644
--- a/eval.c
+++ b/eval.c
@@ -73,7 +73,7 @@ val op_table, pm_table;
val dyn_env;
val eval_error_s;
-val dwim_s, progn_s, prog1_s, prog2_s;
+val dwim_s, progn_s, prog1_s, prog2_s, sys_blk_s;
val let_s, let_star_s, lambda_s, call_s, dvbind_s;
val sys_catch_s, handler_bind_s, cond_s, if_s, iflet_s, when_s, usr_var_s;
val defvar_s, defvarl_s, defparm_s, defparml_s, defun_s, defmacro_s, macro_s;
@@ -2038,7 +2038,7 @@ static val op_defun(val form, val env)
trace_check(name);
if (!consp(name)) {
- val block = cons(block_s, cons(name, body));
+ val block = cons(sys_blk_s, cons(name, body));
val fun = rlcp(cons(name, cons(params, cons(block, nil))), form);
return rt_defun(name, func_interp(env, fun));
} else if (car(name) == meth_s) {
@@ -2053,7 +2053,7 @@ static val op_defun(val form, val env)
return funcall3(cdr(binding), type_sym, meth_name, func_interp(env, fun));
} else if (car(name) == macro_s) {
val sym = cadr(name);
- val block = cons(block_s, cons(sym, body));
+ val block = cons(sys_blk_s, cons(sym, body));
val fun = rlcp(cons(name, cons(params, cons(block, nil))), form);
if (!bindable(sym))
@@ -6303,6 +6303,7 @@ void eval_init(void)
progn_s = intern(lit("progn"), user_package);
prog1_s = intern(lit("prog1"), user_package);
prog2_s = intern(lit("prog2"), user_package);
+ sys_blk_s = intern(lit("blk"), system_package);
let_s = intern(lit("let"), user_package);
let_star_s = intern(lit("let*"), user_package);
lambda_s = intern(lit("lambda"), user_package);
@@ -6463,6 +6464,7 @@ void eval_init(void)
reg_op(uw_protect_s, op_unwind_protect);
reg_op(block_s, op_block);
reg_op(block_star_s, op_block_star);
+ reg_op(sys_blk_s, op_block);
reg_op(return_s, op_return);
reg_op(return_from_s, op_return_from);
reg_op(sys_abscond_from_s, op_abscond_from);
diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl
index f9f052dc..a735739b 100644
--- a/share/txr/stdlib/compiler.tl
+++ b/share/txr/stdlib/compiler.tl
@@ -389,7 +389,7 @@
(if me.(comp-if oreg env form))
(switch me.(comp-switch oreg env form))
(unwind-protect me.(comp-unwind-protect oreg env form))
- ((block block*) me.(comp-block oreg env form))
+ ((block block* sys:blk) me.(comp-block oreg env form))
((return-from sys:abscond-from) me.(comp-return-from oreg env form))
(return me.(comp-return oreg env form))
(handler-bind me.(comp-handler-bind oreg env form))
@@ -716,7 +716,9 @@
me.(maybe-free-treg treg oreg))
(if (and (not star)
(not binfo.used)
- [all bfrag.ffuns system-symbol-p]
+ (and (if (eq op 'sys:blk)
+ [all bfrag.ffuns [orf system-symbol-p (op eq name)]]
+ [all bfrag.ffuns system-symbol-p]))
[none bfrag.ffuns (op member @1 %block-using-funs%)])
bfrag
(new (frag oreg
@@ -1686,19 +1688,19 @@
(defun expand-defun (form)
(mac-param-bind form (op name args . body) form
- (flet ((mklambda (block-name)
- ^(lambda ,args (block ,block-name ,*body))))
+ (flet ((mklambda (block-name block-sym)
+ ^(lambda ,args (,block-sym ,block-name ,*body))))
(cond
((bindable name)
- ^(sys:rt-defun ',name ,(mklambda name)))
+ ^(sys:rt-defun ',name ,(mklambda name 'sys:blk)))
((consp name)
(caseq (car name)
(meth
(mac-param-bind form (meth type slot) name
- ^(sys:define-method ',type ',slot ,(mklambda slot))))
+ ^(sys:define-method ',type ',slot ,(mklambda slot 'block))))
(macro
(mac-param-bind form (macro sym) name
- ^(sys:rt-defmacro ',sym ',name ,(mklambda sym))))
+ ^(sys:rt-defmacro ',sym ',name ,(mklambda sym 'sys:blk))))
(t (compile-error form "~s isn't a valid compound function name"
name))))
(t (compile-error form "~s isn't a valid function name" name))))))