Skip to content

L
lis.pl
Commit 11da44b2 authored by Juergen Nickelsen's avatar Juergen Nickelsen
Browse files
Options

lexical bindings work to some degree, just not with special funcs

parent ca1e9dd4
Hide whitespace changes
Inline Side-by-side
Showing with 71 additions and 37 deletions
Builtin.pm
View file @ 11da44b2
......@@ -20,6 +20,12 @@ 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 Bfunction_environment {
my ($func) = checkargs($_[0], 'e');
$func = evalfun($func);
return function_env($func);
}
sub Benv_vars {
my ($environment, $noparent) = checkargs($_[0], ':Et');
$environment = $Env if is_nil($environment);
......@@ -322,7 +328,7 @@ sub Blet_star {
my $n_bindings = 0;
#debug("Blet_star %s", $defs);
enter_environment();
my $saved_env = enter_environment();
my $result = eval {
my $result = $Nil;
while (consp($defs)) {
......@@ -349,7 +355,7 @@ sub Blet_star {
}
return $result;
};
leave_environment();
backto_environment($saved_env);
unless (defined($result)) {
say("let*: ", princs(car($arglist))) unless in_errset();
return error($@);
......@@ -365,7 +371,7 @@ sub Blet {
my $n_bindings = 0;
#debug("Blet enter %s", $defs);
enter_environment();
my $saved_env = enter_environment();
my $result = eval {
my $result = $Nil;
while (consp($defs)) {
......@@ -396,7 +402,7 @@ sub Blet {
}
return $result;
};
leave_environment();
backto_environment($saved_env);
unless (defined($result)) {
say("let: ", princs(car($arglist))) unless in_errset();
return error($@);
......@@ -479,7 +485,7 @@ sub make_lambda {
} else {
$doc = '';
}
return function(cons($params, $body), $is_special, $doc, $name);
return function(cons($params, $body), $is_special, $doc, $name, $Env);
}
sub make_named_function {
......@@ -993,6 +999,8 @@ my @builtins = # [name, func, is_special, doc]
"in ENV, look up SYMBOL, &optional not in NOPARENTS"],
["env-vars", \&Benv_vars, 0,
"show all vars in ENV, &optional not in NOPARENTS"],
["function-environment", \&Bfunction_environment, 0,
"return the environment of the specified FUNCTION"],
);
sub init {
......
Eval.pm
View file @ 11da44b2
......@@ -84,7 +84,7 @@ sub call_form {
my $optional = 0;
my $n_bindings = 0;
enter_environment();
my $saved_env = enter_environment(function_env($func));
my $result = eval {
my $result;
# save previous bindings (possibly undef) and bind argument
......@@ -137,7 +137,7 @@ sub call_form {
}
return $result;
};
leave_environment();
backto_environment($saved_env);
# return error after restoring bindungs
unless (defined($result)) {
say("$eval_depth: ", princs(cons(function_name($func),
......@@ -215,8 +215,9 @@ sub eval_count {
}
sub Eval {
my ($ob) = @_;
my ($ob, $env) = @_;
#debugl("eval expr: %s", $ob);
$env //= $Env;
$eval_depth++;
$eval_counter++;
......
Print.pm
View file @ 11da44b2
......@@ -83,9 +83,8 @@ sub printob {
sub print_environment {
my ($ob) = @_;
my $result = sprintf("#<Environment[%d]%x:",
$ob->{$n_environment_level},
refaddr($ob));
my $result = sprintf("#<Env-%d|%x:",
$ob->{$n_environment_level}, refaddr($ob));
$result .= join(',', keys(%$ob));
$result .= '>';
return $result;
......
Sexp.pm
View file @ 11da44b2
......@@ -22,8 +22,8 @@ BEGIN {
specialp cadr cddr function_type function_code
symbol_value set function_name is_nil all_symbols remprop
function_documentation is_t cons_count function_args
enter_environment leave_environment bind defvar
environmentp
enter_environment backto_environment bind defvar
environmentp function_env
symbol_value_in_env env_vars
);
}
......@@ -36,17 +36,17 @@ my $cons_counter = 0;
# - symbol { name => "name", func => $function }
# - pair { car => ..., cdr => ... }
# - function { type => 'expr|subr', spec => $is_special, func => $func,
# doc => $doc }
my $env_level = 0;
# doc => $doc, env => $Env }
sub new_environment {
my (@vars) = @_;
my $env = bless({ $n_parentenv => $Env,
my ($parent) = @_;
$parent //= $Env;
my $env_level = defined($parent)
? $parent->{$n_environment_level} + 1
: 0;
my $env = bless({ $n_parentenv => $parent // $Env,
$n_environment_level => $env_level,
$n_env_name => "Env-$env_level",
@vars }, $n_Environment);
$env_level++;
}, $n_Environment);
# warn("new environment[", $env->{$n_environment_level}, "] ",
# $env);
return $env;
......@@ -54,16 +54,16 @@ sub new_environment {
sub enter_environment {
my $env = new_environment(@_);
my $save_env = $Env;
$Env = $env;
set($the_environment, $env);
return $env;
return $save_env;
}
sub leave_environment {
$Env = $Env->{$n_parentenv};
sub backto_environment {
$Env = $_[0];
set($the_environment, $Env);
# warn("back to environment ", &$Princs($Env));
$env_level--;
}
sub env_vars {
......@@ -131,7 +131,7 @@ sub type_of {
}
sub function {
my ($func, $is_special, $doc, $name) = @_;
my ($func, $is_special, $doc, $name, $env) = @_;
my $type;
if (ref($func) eq 'CODE') {
$type = 'subr';
......@@ -143,7 +143,8 @@ sub function {
return error('function: is_special undef: %s', $func)
unless defined($is_special);
return bless({ func => $func, type => $type, spec => $is_special,
doc => $doc // '', name => $name }, $n_Function);
doc => $doc // '', name => $name, env => $env },
$n_Function);
}
sub function_name {
......@@ -166,6 +167,11 @@ sub function_args {
return function_type($ob) eq 'expr' ? car($ob->{func}) : '';
}
sub function_env {
my ($ob) = @_;
return $ob->{env};
}
sub defvar {
my ($sym, $initial, $docstring) = @_;
$sym->{docstring} = $docstring;
......@@ -318,18 +324,18 @@ sub symbol_name {
}
sub symbol_value {
my ($ob) = @_;
my ($ob, $envarg) = @_;
my $name = symbol_name($ob);
for (my $env = $Env;
for (my $env = $envarg // $Env;
defined($env);
$env = $env->{$n_parentenv}) {
# warn(sprintf("sv search %s in env %s",
# symbol_name($ob), $env->{$n_env_name}));
#warn(sprintf("sv search %s in env %s", $name, &$Princs($env)));
if (exists($env->{$name})) {
# warn(sprintf("sv found %s value %s",
# $name, &$Princs($env->{$name})));
return $env->{$name};
}
}
return undef;
}
......
l/factor.lisp
View file @ 11da44b2
......@@ -36,8 +36,7 @@
(setq next-p (cdr next-p))
this-one))
(defun factor (n &rest args)
(setq print-factor (car args))
(defun factor (n &optional print-factor)
(setq next-p *primes*)
(let ((limit (isqrt n))
(working t)
......
tests/038-scope.lisp
View file @ 11da44b2
......@@ -3,3 +3,22 @@
(let ((a 'dynamic))
(funcall f))))
'dynamic)
(defun make-counter (&optional init)
(let ((counter (or init 0)))
(lambda ()
(prog1
counter
(setq counter (1+ counter))))))
(setq a (make-counter))
(setq b (make-counter 119))
(testcmp "counter a 0" '(a) 0)
(testcmp "counter a 1" '(a) 1)
(testcmp "counter a 2" '(a) 2)
(testcmp "counter b 0" '(a) 119)
(testcmp "counter b 1" '(a) 120)
(testcmp "counter a 3" '(a) 3)
(testcmp "counter b 2" '(a) 121)
tests/run-tests.lisp
View file @ 11da44b2
......@@ -27,9 +27,11 @@ the evaluation of FORM and VALUE are equal."
(let ((files (or *ARGS* (glob-filenames (string-concat testdir
"/[0-9]*.lisp")))))
(format t "load files: %s\n" (princs files))
(dolist (test-file files)
(format out "\nloading %s\n" test-file)
(load test-file)))
(while files
(let ((test-file (car files)))
(setq files (cdr files))
(format out "\nloading %s\n" test-file)
(load test-file))))
(format t "%d tests, %d FAILS" ntests (length fails))
(dolist (err (reverse fails))
......
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