unified saving of symbol bindings for let, let*, and call_form() (9a957690) · Commits · lisp / lis.pl

Builtin.pm

+69 −73

Original line number	Diff line number	Diff line
		@@ -20,6 +20,11 @@ use Interp;
		# Builtins get their arguments directly as a Lisp list, have names
		# beginning with 'B', and are defined here (except for, well, exceptions)

		sub Bbindings_depth {
		checkargs($_[0], '');
		return bindings_depth();
		}

		sub Bshell {
		my ($command, $return_output) = checkargs($_[0], 'S:e');
		my $result;
		@@ -300,9 +305,11 @@ sub Blabels {
		sub Blet_star {
		my ($arglist) = @_;
		my ($defs, @body) = checkargs($arglist, 'lR');
		my @bind_symbols = ();
		my @saved_values = ();
		my $n_bindings = 0;

		#debug("Blet_star %s", $defs);
		my $result = eval {
		my $result;
		while (consp($defs)) {
		my $def = car($defs);
		my $var;
		@@ -314,26 +321,20 @@ sub Blet_star {
		$var = is_sym(car($def));
		$value = Eval(is_def(cadr($def)));
		} else {
		error("malformed let* bindings: %s", $defs);
		error("malformed let* binding: %s", $def);
		}
		push(@bind_symbols, $var);
		push(@saved_values, symbol_value($var));
		$n_bindings += save_bindings($var);
		set($var, $value);
		#debug("bind symbol %s to %s", $var, $value);
		$defs = cdr($defs);
		}
		my $result;
		# evaluate body forms
		while (@body) {
		$result = eval { Eval(shift(@body)); };
		last unless defined($result);
		}
		# restore bindings before throwing error
		for my $sym (@bind_symbols) {
		my $value = shift(@saved_values);
		#debug("restore symbol %s to %s", $sym, $value);
		set($sym, $value);
		$result = Eval(shift(@body));
		}
		return $result;
		};
		restore_bindings($n_bindings);
		unless (defined($result)) {
		say("let*: ", princs(car($arglist))) unless in_errset();
		return error($@);
		@@ -345,9 +346,12 @@ sub Blet {
		my ($arglist) = @_;
		my ($defs, @body) = checkargs($arglist, 'lR');
		my @bind_symbols = ();
		my @saved_values = ();
		my @new_values = ();
		my $n_bindings = 0;

		#debug("Blet enter %s", $defs);
		my $result = eval {
		my $result;
		while (consp($defs)) {
		my $def = car($defs);
		my $var;
		@@ -357,37 +361,28 @@ sub Blet {
		$value = $Nil;
		} elsif (consp($def)) {
		$var = is_sym(car($def));
		$value = eval { Eval(is_def(cadr($def))) };
		unless (defined($value)) {
		say("let binding: ",
		princs(is_def(cadr($def))))
		unless in_errset();
		return error($@);
		}
		$value = Eval(is_def(cadr($def)));
		} else {
		error("malformed let bindings: %s", $defs);
		error("malformed let binding: %s", $def);
		}
		push(@bind_symbols, $var);
		push(@saved_values, symbol_value($var));
		push(@new_values, $value);
		#debug("bind symbol %s to %s", $var, $value);
		$defs = cdr($defs);
		}
		$n_bindings += save_bindings(@bind_symbols);
		for my $sym (@bind_symbols) {
		set($sym, shift(@new_values));
		}
		my $result;
		# evaluate body forms
		while (@body) {
		$result = eval { Eval(shift(@body)); };
		last unless defined($result);
		}
		# restore bindings before throwing error
		for my $sym (@bind_symbols) {
		my $value = shift(@saved_values);
		#debug("restore symbol %s to %s", $sym, $value);
		set($sym, $value);
		$result = Eval(shift(@body));
		}
		return $result;
		};
		my $n = $n_bindings;
		restore_bindings($n_bindings);
		#debug("Blet leave %d bindings", $n);
		unless (defined($result)) {
		say("let: ", princs(car($arglist))) unless in_errset();
		return error($@);
		@@ -1001,6 +996,7 @@ my @builtins = # [name, func, is_special, doc]
		"evaluate the ARG string as Perl code and return the result"],
		["shell", \&Bshell,
		"run COMMAND as a shell command; &optional RETURN-OUTPUT"],
		["bindings-depth", \&Bbindings_depth, 0, "return depth of bindings stack"],
		);

		for my $b (@builtins) {

Eval.pm

+85 −53

Original line number	Diff line number	Diff line
		@@ -21,10 +21,45 @@ use Exporter ();
		BEGIN {
		@ISA = qw(Exporter);
		@EXPORT = qw( Eval evalfun funcall eval_count eval_level
		enter_errset leave_errset in_errset
		enter_errset leave_errset in_errset save_bindings
		restore_bindings bindings_depth
		);
		}

		# bindings stack
		my @saved_bindings = (); # saved bindings; symbol and value, in
		# that order

		sub save_bindings {
		my (@symbols) = @_;
		my $count = 0;
		for my $symbol (@symbols) {
		my $value = symbol_value($symbol);
		# debug("%sbindings: %d save symbol %s value %s",
		# " " x @saved_bindings,
		# @saved_bindings / 2, $symbol, $value);
		push(@saved_bindings, $symbol, $value);
		$count++;
		}
		return $count;
		}

		sub restore_bindings {
		my ($n) = @_;
		while ($n--) {
		my $value = pop(@saved_bindings);
		my $symbol = pop(@saved_bindings);
		# debug("%srestore sym %s value %s, bindings: %d",
		# " " x @saved_bindings,
		# $symbol, $value, @saved_bindings / 2);
		set($symbol, $value);
		}
		}

		sub bindings_depth {
		return @saved_bindings / 2;
		}

		my $eval_depth = 0;
		my $eval_counter = 0;
		my $errset_level = 0;
		@@ -79,15 +114,21 @@ sub call_form {
		my $form = function_code($func);
		my $params = car($form);
		my $body = cdr($form);
		my %save = ();
		my $inrest = 0;
		my $optional = 0;
		my $n_bindings = 0;

		# save previous bindings (possibly undef) and bind argument values to
		# parameters
		my $result = eval {
		my $result;
		# save previous bindings (possibly undef) and bind argument
		# values to parameters
		while (consp($params)) {
		my $param = is_sym(car($params));
		$params = cdr($params);
		my $param;
		($param, $params) = cxr($params);
		unless (symbolp($param)) {
		error("param of function %s not a symbol: %s",
		function_name($func), $param);
		}

		if ($param == $andRest) {
		$inrest = 1;
		@@ -98,47 +139,38 @@ sub call_form {
		next;
		}

		my $value = symbol_value($param);
		# debugl("save %s as %s", $param, $value);
		$save{$param} = $value;
		$n_bindings += save_bindings($param);
		if ($inrest) {
		#debugl("bind rest (set %s %s)", $param, $args);
		set($param, $args);
		$args = $Nil;
		return error("too many parameters after &rest: %s",
		$params)
		if (consp($params));
		if (consp($params)) {
		error("too many params for function %s"
		." after &rest: %s",
		function_name($func), $params);
		}
		last;
		} else {
		return error("too few arguments for function %s",
		function_name($func))
		unless $optional \|\| consp($args);
		}
		unless ($optional \|\| consp($args)) {
		error("too few args for function %s",
		function_name($func));
		}
		#debugl("bind param (set %s %s)", $param, car($args));
		set($param, car($args));
		$args = cdr($args);
		}
		if (consp($args)) {
		error("too many arguments for function %s",
		function_name($func));
		}
		return error("too many arguments for function %s", function_name($func))
		if consp($args);

		my $result;
		# evaluate body forms
		# finally, evaluate body forms
		while (consp($body)) {
		$result = eval { Eval(car($body)); };
		last unless defined($result);
		$result = Eval(car($body));
		$body = cdr($body);
		}

		# restore previous bindings
		$params = car($form);
		while (consp($params)) {
		my $sym = car($params);
		$params = cdr($params);
		next if $sym == $andRest;
		my $value = $save{$sym};
		#debugl("restore: (set %s %s)", $sym, $value);
		set($sym, $value);
		}
		return $result;
		};
		restore_bindings($n_bindings);
		# return error after restoring bindungs
		unless (defined($result)) {
		say("$eval_depth: ", princs(cons(function_name($func),

TODO

+3 −3

Original line number	Diff line number	Diff line
		@@ -6,15 +6,15 @@

		* comment out debug calls (they do cost...)

		* Bperl (perl "\%Sexp::symbols" 'dump)

		* idea: have a stack for bound symbols, saved values, and number
		@ idea: have a stack for bound symbols, saved values, and number
		of saved bindings each, to be accessed by something like a
		(local-bindings n) function, with n being the number of levels
		to look at. And lo!, together with a stack of the bind contexts
		(lambda, let, etc.) this could give us a nice stack trace.
		Investigate; to do not before the existing regtests are done.

		+ Bperl (perl "\%Sexp::symbols" 'dump)

		+ suppress stack trace output when in errset

		+ fix existing regtests

tests/035-restore-bindings.lisp

0 → 100644

+59 −0

Original line number	Diff line number	Diff line
		;; restore binding after let* malformed binding error
		(setq a 315)
		(testcmp "restore let* 1" '(errset (let* ((a 23)
		(b 112)
		119)
		"throws error due to malformed binding"))
		nil)
		(testcmp "really restored? 1" 'a 315)

		;; restore binding after let* undefined value error
		(setq a 316)
		(makunbound 'c)
		(testcmp "restore let* 2" '(errset (let* ((a 24)
		(b c)
		(d 119))
		"throws error due to undef c"))
		nil)
		(testcmp "really restored? 2" 'a 316)


		;; restore binding after let malformed binding error
		(setq a 317)
		(testcmp "restore let 1" '(errset (let ((a 23)
		(b 'd)
		119)
		"throws error due to malformed binding"))
		nil)
		(testcmp "really restored? 3" 'a 317)


		;; restore binding after let undefined value error
		(setq a 318)
		(makunbound 'c)
		(testcmp "restore let 2" '(errset (let ((a 24)
		(b c)
		(d 119))
		"throws error due to undef c"))
		nil)
		(testcmp "really restored? 4" 'a 318)

		;;===========

		;; restore binding after regular let*
		(setq a 319)
		(testcmp "restore let* 3" '(let* ((a 23)
		(b 2)
		(d 119))
		64927)
		64927)
		(testcmp "really restored? 5" 'a 319)

		;; restore binding after regular let
		(setq a 320)
		(testcmp "restore let 3" '(let ((a 23)
		(b 2)
		(d 119))
		64928)
		64928)
		(testcmp "really restored? 6" 'a 320)