Commit 30fbe65c authored by Juergen Nickelsen's avatar Juergen Nickelsen

finally suppress stack trace output when in errset

parent 61497880
......@@ -151,7 +151,9 @@ sub Bformat {
sub Berrset {
my ($expr) = checkargs($_[0], 'e');
enter_errset();
my $result = eval { Eval($expr) };
leave_errset();
if (defined($result)) {
return cons($result, $Nil);
} else {
......@@ -289,7 +291,7 @@ sub Blabels {
set($sym, $func);
}
unless (defined($result)) {
say("labels: ", princs($arglist));
say("labels: ", princs($arglist)) unless in_errset();
return error($@);
}
return $result;
......@@ -333,7 +335,7 @@ sub Blet_star {
set($sym, $value);
}
unless (defined($result)) {
say("let*: ", princs(car($arglist)));
say("let*: ", princs(car($arglist))) unless in_errset();
return error($@);
}
return $result;
......@@ -358,7 +360,8 @@ sub Blet {
$value = eval { Eval(is_def(cadr($def))) };
unless (defined($value)) {
say("let binding: ",
princs(is_def(cadr($def))));
princs(is_def(cadr($def))))
unless in_errset();
return error($@);
}
} else {
......@@ -386,7 +389,7 @@ sub Blet {
set($sym, $value);
}
unless (defined($result)) {
say("let: ", princs(car($arglist)));
say("let: ", princs(car($arglist))) unless in_errset();
return error($@);
}
return $result;
......@@ -438,7 +441,7 @@ sub Bif {
my ($condexpr, $thenclause, @elseclauses) = checkargs($_[0], 'eeR');
my $cond = eval { Eval($condexpr) };
unless (defined($cond)) {
say("if cond: ", princs($condexpr));
say("if cond: ", princs($condexpr)) unless in_errset();
return error($@);
}
my $result = $Nil;
......@@ -457,7 +460,7 @@ sub Bif {
}
#debug("if returns %s", $result);
unless (defined($result)) {
say("if clause: ", princs($clause));
say("if clause: ", princs($clause)) unless in_errset();
return error($@);
}
return $result;
......@@ -652,7 +655,7 @@ sub Band {
while (consp($arglist)) {
my $value = Eval(car($arglist));
unless (defined($value)) {
say("and: ", princs(car($arglist)));
say("and: ", princs(car($arglist))) unless in_errset();
return error($@);
}
return $Nil if is_nil($value);
......@@ -667,7 +670,7 @@ sub Bor {
while (consp($arglist)) {
my $value = Eval(car($arglist));
unless (defined($value)) {
say("or: ", princs(car($arglist)));
say("or: ", princs(car($arglist))) unless in_errset();
return error($@);
}
return $value if !is_nil($value);
......@@ -732,7 +735,7 @@ sub Bwhile {
while (1) {
my $cval = Eval($cond);
unless (defined($cval)) {
say("while cond: ", princs($cond));
say("while cond: ", princs($cond)) unless in_errset();
return error($@);
}
last if is_nil($cval);
......@@ -741,7 +744,8 @@ sub Bwhile {
while (consp($body)) {
my $value = Eval(car($body));
unless (defined($value)) {
say("while clause: ", princs(car($body)));
say("while clause: ", princs(car($body)))
unless in_errset();
return error($@);
}
$body = cdr($body);
......@@ -759,7 +763,7 @@ sub Bsetq {
my ($symbol, $value) = checkargs($_[0], 'ye');
my $evalue = Eval($value);
unless (defined($evalue)) {
say("setq value: ", princs($value));
say("setq value: ", princs($value)) unless in_errset();
return error($@);
}
return set($symbol, $evalue);
......@@ -805,7 +809,7 @@ sub Beval {
my ($expr) = checkargs($_[0], 'e');
my $evalue = Eval($expr);
unless (defined($evalue)) {
say("lisp eval: ", princs($expr));
say("lisp eval: ", princs($expr)) unless in_errset();
return error($@);
}
return $evalue;
......@@ -856,7 +860,7 @@ sub Bfmakunbound {
sub Btype_of {
my ($ob) = checkargs($_[0], 'e');
if (symbolp($ob)) {
return $t_Symbol;;
return $t_Symbol;
} elsif (consp($ob)) {
return $t_Pair;
} elsif (functionp($ob)) {
......
......@@ -21,21 +21,35 @@ use Exporter ();
BEGIN {
@ISA = qw(Exporter);
@EXPORT = qw( Eval evalfun funcall eval_count eval_level
enter_errset leave_errset in_errset
);
}
my $level = 0;
my $eval_depth = 0;
my $eval_counter = 0;
my $errset_level = 0;
sub enter_errset {
$errset_level++;
}
sub leave_errset {
$errset_level--;
}
sub in_errset {
return !!$errset_level;
}
sub eval_level {
my ($new) = @_;
my $l = $level;
$level = $new if defined($new);
my $l = $eval_depth;
$eval_depth = $new if defined($new);
return $l;
}
sub debugl {
debug(" " x $level, @_);
debug(" " x $eval_depth, @_);
}
......@@ -127,7 +141,9 @@ sub call_form {
}
# return error after restoring bindungs
unless (defined($result)) {
say("$level: ", princs(cons(function_name($func), $orig_args)));
say("$eval_depth: ", princs(cons(function_name($func),
$orig_args)))
unless in_errset();
return error($@);
}
return $result;
......@@ -202,7 +218,7 @@ sub Eval {
my ($ob) = @_;
#debugl("eval expr: %s", $ob);
$level++;
$eval_depth++;
$eval_counter++;
my $result;
if (symbolp($ob)) {
......@@ -221,7 +237,7 @@ sub Eval {
} else {
$result = $ob;
}
$level--;
$eval_depth--;
#debugl("eval expr: %s, returns %s", $ob, $result);
return $result;
}
......
......@@ -15,7 +15,7 @@
(lambda, let, etc.) this could give us a *nice* stack trace.
Investigate; to do not before the existing regtests are done.
* suppress stack trace output when in errset
+ suppress stack trace output when in errset
+ fix existing regtests
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment