finally suppress stack trace output when in errset (30fbe65c) · Commits · lisp / lis.pl

Builtin.pm

+17 −13

Original line number	Diff line number	Diff line
		@@ -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)) {

Eval.pm

+23 −7

Original line number	Diff line number	Diff line
		@@ -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;
		}

TODO

+1 −1

Original line number	Diff line number	Diff line
		@@ -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