Skip to content

L
lis.pl
Commit 9a957690 authored by Juergen Nickelsen's avatar Juergen Nickelsen
Browse files
Options

unified saving of symbol bindings for let, let*, and call_form()

parent 30fbe65c
Hide whitespace changes
Inline Side-by-side
Showing with 216 additions and 129 deletions
Builtin.pm
View file @ 9a957690
......@@ -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,40 +305,36 @@ sub Blabels {
sub Blet_star {
my ($arglist) = @_;
my ($defs, @body) = checkargs($arglist, 'lR');
my @bind_symbols = ();
my @saved_values = ();
while (consp($defs)) {
my $def = car($defs);
my $var;
my $value;
if (symbolp($def)) {
$var = $def;
$value = $Nil;
} elsif (consp($def)) {
$var = is_sym(car($def));
$value = Eval(is_def(cadr($def)));
} else {
error("malformed let* bindings: %s", $defs);
my $n_bindings = 0;
#debug("Blet_star %s", $defs);
my $result = eval {
my $result;
while (consp($defs)) {
my $def = car($defs);
my $var;
my $value;
if (symbolp($def)) {
$var = $def;
$value = $Nil;
} elsif (consp($def)) {
$var = is_sym(car($def));
$value = Eval(is_def(cadr($def)));
} else {
error("malformed let* binding: %s", $def);
}
$n_bindings += save_bindings($var);
set($var, $value);
#debug("bind symbol %s to %s", $var, $value);
$defs = cdr($defs);
}
push(@bind_symbols, $var);
push(@saved_values, symbol_value($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);
}
# evaluate body forms
while (@body) {
$result = Eval(shift(@body));
}
return $result;
};
restore_bindings($n_bindings);
unless (defined($result)) {
say("let*: ", princs(car($arglist))) unless in_errset();
return error($@);
......@@ -345,49 +346,43 @@ sub Blet {
my ($arglist) = @_;
my ($defs, @body) = checkargs($arglist, 'lR');
my @bind_symbols = ();
my @saved_values = ();
my @new_values = ();
while (consp($defs)) {
my $def = car($defs);
my $var;
my $value;
if (symbolp($def)) {
$var = $def;
$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($@);
my $n_bindings = 0;
#debug("Blet enter %s", $defs);
my $result = eval {
my $result;
while (consp($defs)) {
my $def = car($defs);
my $var;
my $value;
if (symbolp($def)) {
$var = $def;
$value = $Nil;
} elsif (consp($def)) {
$var = is_sym(car($def));
$value = Eval(is_def(cadr($def)));
} else {
error("malformed let binding: %s", $def);
}
} else {
error("malformed let bindings: %s", $defs);
push(@bind_symbols, $var);
push(@new_values, $value);
#debug("bind symbol %s to %s", $var, $value);
$defs = cdr($defs);
}
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);
}
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);
}
$n_bindings += save_bindings(@bind_symbols);
for my $sym (@bind_symbols) {
set($sym, shift(@new_values));
}
# evaluate body forms
while (@body) {
$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
View file @ 9a957690
......@@ -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,66 +114,63 @@ 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
while (consp($params)) {
my $param = is_sym(car($params));
$params = cdr($params);
if ($param == $andRest) {
$inrest = 1;
next;
}
if ($param == $andOptional) {
$optional = 1;
next;
}
my $result = eval {
my $result;
# save previous bindings (possibly undef) and bind argument
# values to parameters
while (consp($params)) {
my $param;
($param, $params) = cxr($params);
unless (symbolp($param)) {
error("param of function %s not a symbol: %s",
function_name($func), $param);
}
my $value = symbol_value($param);
# debugl("save %s as %s", $param, $value);
$save{$param} = $value;
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));
last;
} else {
return error("too few arguments for function %s",
function_name($func))
unless $optional || consp($args);
if ($param == $andRest) {
$inrest = 1;
next;
}
if ($param == $andOptional) {
$optional = 1;
next;
}
$n_bindings += save_bindings($param);
if ($inrest) {
#debugl("bind rest (set %s %s)", $param, $args);
set($param, $args);
$args = $Nil;
if (consp($params)) {
error("too many params for function %s"
." after &rest: %s",
function_name($func), $params);
}
last;
}
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);
}
}
return error("too many arguments for function %s", function_name($func))
if consp($args);
my $result;
# evaluate body forms
while (consp($body)) {
$result = eval { Eval(car($body)); };
last unless defined($result);
$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);
}
if (consp($args)) {
error("too many arguments for function %s",
function_name($func));
}
# finally, evaluate body forms
while (consp($body)) {
$result = Eval(car($body));
$body = cdr($body);
}
return $result;
};
restore_bindings($n_bindings);
# return error after restoring bindungs
unless (defined($result)) {
say("$eval_depth: ", princs(cons(function_name($func),
......
TODO
View file @ 9a957690
......@@ -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
View file @ 9a957690
;; 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)
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