Commit 27cf4c8e authored by Juergen Nickelsen's avatar Juergen Nickelsen

a few renamings; fixes in env init; still not ok tho

parent 2e3c797a
......@@ -22,7 +22,7 @@ use Interp;
sub Benv_vars {
my ($environment, $noparent) = checkargs($_[0], ':Et');
$environment = $Environment if is_nil($environment);
$environment = $Env if is_nil($environment);
return array2list(env_vars($environment, !is_nil($noparent)));
}
......@@ -322,7 +322,7 @@ sub Blet_star {
my $n_bindings = 0;
#debug("Blet_star %s", $defs);
new_environment();
enter_environment();
my $result = eval {
my $result = $Nil;
while (consp($defs)) {
......@@ -349,7 +349,7 @@ sub Blet_star {
}
return $result;
};
pop_environment();
leave_environment();
unless (defined($result)) {
say("let*: ", princs(car($arglist))) unless in_errset();
return error($@);
......@@ -365,7 +365,7 @@ sub Blet {
my $n_bindings = 0;
#debug("Blet enter %s", $defs);
new_environment();
enter_environment();
my $result = eval {
my $result = $Nil;
while (consp($defs)) {
......@@ -396,7 +396,7 @@ sub Blet {
}
return $result;
};
pop_environment();
leave_environment();
unless (defined($result)) {
say("let: ", princs(car($arglist))) unless in_errset();
return error($@);
......
......@@ -84,7 +84,7 @@ sub call_form {
my $optional = 0;
my $n_bindings = 0;
new_environment();
enter_environment();
my $result = eval {
my $result;
# save previous bindings (possibly undef) and bind argument
......@@ -137,7 +137,7 @@ sub call_form {
}
return $result;
};
pop_environment();
leave_environment();
# return error after restoring bindungs
unless (defined($result)) {
say("$eval_depth: ", princs(cons(function_name($func),
......
......@@ -21,7 +21,7 @@ BEGIN {
$t_Function
ftrace $andOptional $Kappa
$the_environment $n_the_environment $n_Environment
$n_parentenv $Environment $root_Environment
$n_parentenv $Env $root_Env
stacktrace $n_root_environment $root_environment
$n_environment_level
);
......@@ -64,9 +64,9 @@ our $n_environment_level = '*environment-level*';
our $n_parentenv = '*parent-environment*';
our $Environment; # the real environment, value of
our $Env; # the real environment, value of
# *the-environment*
our $root_Environment; # the mother of all environments
our $root_Env; # the mother of all environments
our $Quote = 'quote';
......
......@@ -83,9 +83,11 @@ sub printob {
sub print_environment {
my ($ob) = @_;
return sprintf("#<Environment[%d]%x>",
$ob->{$n_environment_level},
refaddr($ob));
my $result = sprintf("#<Environment[%d]%x:",
$ob->{$n_environment_level},
refaddr($ob));
$result .= join(',', keys(%$ob));
return $result;
}
sub print_function {
......
......@@ -22,7 +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
new_environment pop_environment bind defvar environmentp
enter_environment leave_environment bind defvar
environmentp
symbol_value_in_env env_vars
);
}
......@@ -41,20 +42,25 @@ my $env_level = 0;
sub new_environment {
my (@vars) = @_;
my $env = bless({ $n_parentenv => $Environment,
my $env = bless({ $n_parentenv => $Env,
$n_environment_level => $env_level++,
@vars }, $n_Environment);
$Environment = $env;
warn("new environment[", $Env->{$n_environment_level}, "] ",
$env);
return $env;
}
sub enter_environment {
my $env = new_environment(@_);
$Env = $env;
set($the_environment, $env);
warn("new environment[", $Environment->{$n_environment_level}, "] ",
$Environment);
return $env;
}
sub pop_environment {
$Environment = $Environment->{$n_parentenv};
set($the_environment, $Environment);
warn("back to environment ", &$Princs($Environment));
sub leave_environment {
$Env = $Env->{$n_parentenv};
set($the_environment, $Env);
warn("back to environment ", &$Princs($Env));
$env_level--;
}
......@@ -162,31 +168,34 @@ sub defvar {
my ($sym, $initial, $docstring) = @_;
$sym->{docstring} = $docstring;
my $name = symbol_name($sym);
return $root_Environment->{$name} = $initial;
return $root_Env->{$name} = $initial;
}
sub bind {
my ($sym, $value) = @_;
my $name = symbol_name($sym);
if (exists($Environment->{$name})) {
if (exists($Env->{$name})) {
...
}
$Environment->{$name} = $value;
$Env->{$name} = $value;
}
sub set {
my ($sym, $value) = @_;
my ($sym, $value, $env) = @_;
stacktrace() unless defined($sym);
my $name = symbol_name($sym);
for (my $env = $Environment;
$env->{$name} = $value if $env;
for (my $env = $Env;
defined($env);
$env = $env->{$n_parentenv}) {
if (exists($env->{$name})) {
warn("set $name in ", $env);
return $env->{$name} = $value;
}
}
return $root_Environment->{$sym} = $value;
warn("set $name in root ", $root_Env);
return $root_Env->{$sym} = $value;
}
sub intern {
......@@ -309,7 +318,7 @@ sub symbol_name {
sub symbol_value {
my ($ob) = @_;
my $name = symbol_name($ob);
for (my $env = $Environment;
for (my $env = $Env;
defined($env);
$env = $env->{$n_parentenv}) {
warn(sprintf("sv search %s in env %s", $ob, $env));
......@@ -324,7 +333,7 @@ sub symbol_value {
sub symbol_value_in_env {
my ($ob, $env, $noparents) = @_;
my $name = symbol_name($ob);
for (my $env = $Environment;
for (my $env = $Env;
defined($env);
$env = $noparents ? undef : $env->{$n_parentenv}) {
warn(sprintf("svie search %s in env %s", $ob, $env));
......@@ -357,15 +366,16 @@ $t_Number = intern("number");
$t_Pair = intern("pair");
$t_Function = intern("function");
$root_Environment = new_environment();
$Environment = $root_Environment;
set($root_environment, $root_Environment);
$root_Env = new_environment(); # cannot use enter_environment() here,
# as we don't yet have a $Env
$Env = $root_Env;
set($root_environment, $root_Env, $root_Env);
set($the_environment, $root_Env, $root_Env);
$Nil = intern("nil");
set($Nil, $Nil);
set($Nil, $Nil, $root_Env);
$T = intern("t");
set($T, $T);
set($T, $T, $root_Env);
1;
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