Commit 0528cbbb authored by Juergen Nickelsen's avatar Juergen Nickelsen
Browse files

performance gain through leaner environments and related cleanup

parent e925bc38
......@@ -20,10 +20,15 @@ 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 Bthe_environment {
checkargs($_[0], '');
return the_environment();
}
sub Benvironment {
my ($env, $noparents) = checkargs($_[0], ':Ee');
my %vars = ();
$env = $Env if is_nil($env);
$env = the_environment() if is_nil($env);
while (defined($env)) {
while (my ($key, $value) = each(%$env)) {
$vars{$key} //= $value;
......@@ -215,14 +220,14 @@ sub Bfunction_environment {
}
sub Benv_vars {
my ($environment, $noparent) = checkargs($_[0], ':Ee');
$environment = $Env if is_nil($environment);
return array2list(env_vars($environment, !is_nil($noparent)));
my ($env, $noparent) = checkargs($_[0], ':Ee');
$env = the_environment() if is_nil($env);
return array2list(env_vars($env, !is_nil($noparent)));
}
sub Benv_ref {
my ($environment, $symbol, $noparents) = checkargs($_[0], 'Ey:e');
return symbol_value($symbol, $environment, !is_nil($noparents));
my ($env, $symbol, $noparents) = checkargs($_[0], 'Ey:e');
return symbol_value($symbol, $env, !is_nil($noparents));
}
sub Bdefvar {
......@@ -665,7 +670,7 @@ sub make_lambda {
} else {
$doc = '';
}
return function(cons($params, $body), 0, $doc, $name, $Env);
return function(cons($params, $body), 0, $doc, $name);
}
sub Bdefun {
......@@ -1176,6 +1181,8 @@ my @builtins = # [name, func, is_special, doc]
"bindings of ENVIRON (or current) as list of pairs, &optional NOPARENTS"],
["substr", \&Bsubstr, 0,
"return the substring of STRING from START to &optional END"],
["the-environment", \&Bthe_environment, 0,
"return the current environment object"],
);
sub init {
......
......@@ -19,25 +19,20 @@ BEGIN {
$Quote error $Leval $andRest $Lambda $Princs $n_last_error
$n_ARGS our $t_Symbol $t_Number $t_String $t_Pair
$t_Function $opt_stacktraces
ftrace $andOptional $Kappa
$the_environment $n_the_environment $n_Environment
$n_parentenv $Env
ftrace $andOptional $n_Environment $n_parentenv
stacktrace $n_root_environment $root_environment
$n_environment_level $n_env_name
);
}
# some symbols
our $Nil; # the nil symbol
our $T; # the t symbol
our $andRest; # the &rest token symbol
our $andOptional; # the &optional token symbol
our $Lambda; # the lambda symbol
our $Kappa; # the kappa symbol
our $special;
our $Nil; # the nil symbol
our $T; # the t symbol
our $andRest; # the &rest token symbol
our $andOptional; # the &optional token symbol
our $Lambda; # the lambda symbol
our $builtin;
our $function;
our $the_environment; # symbol *the-environment*
our $root_environment; # symbol *root-environment*
# object types, all Symbols
......@@ -57,15 +52,11 @@ our $n_last_error = '*last-error*';
our $n_last_eval_stats = '*last-eval-stats*';
our $n_ARGS = '*ARGS*';
our $n_Environment = 'Environment';
our $n_the_environment = '*the-environment*';
our $n_root_environment = '*root-environment*';
our $n_environment_level = '*environment-level*';
our $n_env_name = '*env-name*';
our $n_parentenv = '*parent-environment*';
our $Env; # the real environment, value of
# *the-environment*
our $Quote = 'quote';
our $Princs; # the printer function
......
......@@ -83,8 +83,7 @@ sub printob {
sub print_environment {
my ($ob) = @_;
my $result = sprintf("#<Env-%d:%x",
$ob->{$n_environment_level}, refaddr($ob));
my $result = sprintf("#<Env-%x", refaddr($ob));
# $result .= ':';
# $result .= join(',', keys(%$ob));
$result .= '>';
......@@ -102,8 +101,7 @@ sub print_function {
my $spectag = $special ? 'f' : '';
return "#<$special$type:$name:$code>";
} elsif ($type eq 'expr') {
my $type = specialp($ob) ? $Kappa : $Lambda;
return "#'" . printob(cons($type, $code));
return "#'" . printob(cons($Lambda, $code));
}
}
......
......@@ -23,14 +23,15 @@ BEGIN {
symbol_value set function_name is_nil all_symbols remprop
function_documentation is_t cons_count function_args
enter_environment backto_environment bind defvar
environmentp function_env
environmentp function_env the_environment
symbol_value_in_env env_vars
);
}
my %symbols = ();
my $cons_counter = 0;
my $root_Env;
my $root_Env; # the global environment
my $Env; # the current environment
# types of sexprs:
# - literal string or number
......@@ -39,27 +40,25 @@ my $root_Env;
# - function { type => 'expr|subr', spec => $is_special, func => $func,
# doc => $doc, env => $Env }
sub the_environment {
return $Env;
}
sub new_environment {
my ($parent) = @_;
my $env_level =
$parent == $Nil ? 0 : $parent->{$n_environment_level} + 1;
return bless({ $n_parentenv => $parent,
$n_environment_level => $env_level,
}, $n_Environment);
return bless({ $n_parentenv => $parent }, $n_Environment);
}
sub enter_environment {
my ($parent) = @_;
my $env = new_environment($parent // $Env);
my $newenv = new_environment($parent // $Env);
my $save_env = $Env;
$Env = $env;
set($the_environment, $env, $env);
$Env = $newenv;
return $save_env;
}
sub backto_environment {
$Env = $_[0];
set($the_environment, $Env);
# warn("back to environment ", &$Princs($Env));
}
......@@ -139,6 +138,7 @@ sub function {
} else {
return error('function not subr or expr: %s', $func);
}
$env //= $Env;
return error('function: is_special undef: %s', $func)
unless defined($is_special);
return bless({ func => $func, type => $type, spec => $is_special,
......@@ -341,14 +341,12 @@ sub symbol_function {
sub init {
$Kappa = intern("kappa");
$Lambda = intern("lambda");
$andRest = intern("&rest");
$andOptional = intern("&optional");
$special = intern("special");
$builtin = intern("builtin");
$function = intern($n_function);
$the_environment = intern($n_the_environment);
$root_environment = intern($n_root_environment);
$t_Symbol = intern("symbol");
......@@ -367,7 +365,6 @@ sub init {
# only now we can begin to set variable values
defvar($root_environment, $root_Env);
defvar($the_environment, $root_Env);
defvar($Nil, $Nil);
defvar($T, $T);
......
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