Skip to content

GitLab

L
lis.pl
Commit 46e77db0 authored by Juergen Nickelsen's avatar Juergen Nickelsen
Browse files
Options

moving to lexical bindings; mostly implemented, but doesn't work yet

parent e318584c
Hide whitespace changes
Inline Side-by-side
Showing with 171 additions and 58 deletions
Builtin.pm
View file @ 46e77db0
......@@ -20,6 +20,22 @@ 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 Benv_vars {
my ($environment, $noparent) = checkargs($_[0], ':Et');
$environment = $Environment if is_nil($environment);
return array2list(env_vars($environment, !is_nil($noparent)));
}
sub Benv_ref {
my ($environment, $symbol, $noparents) = checkargs($_[0], 'Ey:e');
return symbol_value_in_env($symbol, $environment, !is_nil($noparents));
}
sub Bdefvar {
my ($symbol, $initial, $docstring) = checkargs($_[0], 'y:es');
return defvar($symbol, Eval($initial), Eval($docstring));
}
sub Bbindings_depth {
checkargs($_[0], '');
return bindings_depth();
......@@ -306,6 +322,7 @@ sub Blet_star {
my $n_bindings = 0;
#debug("Blet_star %s", $defs);
new_environment();
my $result = eval {
my $result;
while (consp($defs)) {
......@@ -323,8 +340,7 @@ sub Blet_star {
} else {
error("malformed let* binding: %s", $def);
}
$n_bindings += save_bindings($var);
set($var, $value);
bind($var, $value);
#debug("bind symbol %s to %s", $var, $value);
}
# evaluate body forms
......@@ -333,7 +349,7 @@ sub Blet_star {
}
return $result;
};
restore_bindings($n_bindings);
pop_environment();
unless (defined($result)) {
say("let*: ", princs(car($arglist))) unless in_errset();
return error($@);
......@@ -349,6 +365,7 @@ sub Blet {
my $n_bindings = 0;
#debug("Blet enter %s", $defs);
new_environment();
my $result = eval {
my $result;
while (consp($defs)) {
......@@ -370,9 +387,8 @@ sub Blet {
push(@new_values, $value);
#debug("bind symbol %s to %s", $var, $value);
}
$n_bindings += save_bindings(@bind_symbols);
for my $sym (@bind_symbols) {
set($sym, shift(@new_values));
bind($sym, shift(@new_values));
}
# evaluate body forms
while (@body) {
......@@ -380,9 +396,7 @@ sub Blet {
}
return $result;
};
#my $n = $n_bindings;
restore_bindings($n_bindings);
#debug("Blet leave %d bindings", $n);
pop_environment();
unless (defined($result)) {
say("let: ", princs(car($arglist))) unless in_errset();
return error($@);
......@@ -844,6 +858,8 @@ sub Btype_of {
my @builtins = # [name, func, is_special, doc]
(
["defvar", \&Bdefvar, 1,
"Define global variable SYMBOL with optional INITVALUE and DOCSTRING"],
["truncate", \&Btruncate, 0,
"return NUMBER truncated to integer towards zero"],
["div", \&Bdiv, 0, "integer divide the first arg by all others"],
......@@ -973,6 +989,10 @@ my @builtins = # [name, func, is_special, doc]
["shell", \&Bshell,
"run COMMAND as a shell command; &optional RETURN-OUTPUT"],
["bindings-depth", \&Bbindings_depth, 0, "return depth of bindings stack"],
["env-ref", \&Benv_ref, 0,
"in ENV, look up SYMBOL, &optional not in NOPARENTS"],
["env-vars", \&Benv_vars, 0,
"show all vars in ENV, &optional not in NOPARENTS"],
);
for my $b (@builtins) {
......
Eval.pm
View file @ 46e77db0
......@@ -21,45 +21,10 @@ use Exporter ();
BEGIN {
@ISA = qw(Exporter);
@EXPORT = qw( Eval evalfun funcall eval_count eval_level
enter_errset leave_errset in_errset save_bindings
restore_bindings bindings_depth
enter_errset leave_errset in_errset
);
}
# 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;
......@@ -119,6 +84,7 @@ sub call_form {
my $optional = 0;
my $n_bindings = 0;
new_environment();
my $result = eval {
my $result;
# save previous bindings (possibly undef) and bind argument
......@@ -140,10 +106,9 @@ sub call_form {
next;
}
$n_bindings += save_bindings($param);
if ($inrest) {
#debugl("bind rest (set %s %s)", $param, $args);
set($param, $args);
bind($param, $args);
$args = $Nil;
if (consp($params)) {
error("too many params for function %s"
......@@ -157,7 +122,7 @@ sub call_form {
function_name($func));
}
#debugl("bind param (set %s %s)", $param, car($args));
set($param, car($args));
bind($param, car($args));
$args = cdr($args);
}
if (consp($args)) {
......@@ -172,7 +137,7 @@ sub call_form {
}
return $result;
};
restore_bindings($n_bindings);
pop_environment();
# return error after restoring bindungs
unless (defined($result)) {
say("$eval_depth: ", princs(cons(function_name($func),
......
Global.pm
View file @ 46e77db0
......@@ -20,6 +20,10 @@ BEGIN {
$n_ARGS our $t_Symbol $t_Number $t_String $t_Pair
$t_Function
ftrace $andOptional $Kappa
$the_environment $n_the_environment $n_Environment
$n_parentenv $Environment $root_Environment
stacktrace $n_root_environment $root_environment
$n_environment_level
);
}
......@@ -34,6 +38,8 @@ our $Princs; # the printer function
our $special;
our $builtin;
our $function;
our $the_environment;
our $root_environment;
# object types, all Symbols
our $t_Symbol;
......@@ -41,6 +47,7 @@ our $t_Number;
our $t_String;
our $t_Pair;
our $t_Function;
our $t_Environment;
# a few symbol names
our $n_Symbol = 'Symbol';
......@@ -50,6 +57,16 @@ our $n_function = 'function';
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_parentenv = '*parent-environment*';
our $Environment; # the real environment, value of
# *the-environment*
our $root_Environment; # the mother of all environments
our $Quote = 'quote';
......
Print.pm
View file @ 46e77db0
......@@ -5,6 +5,7 @@ package Print;
use warnings;
use strict;
use 5.010;
use Scalar::Util qw(refaddr);
use Global;
use Sexp;
......@@ -67,6 +68,8 @@ sub printob {
return print_list($ob);
} elsif (functionp($ob)) {
return print_function($ob);
} elsif (environmentp($ob)) {
return print_environment($ob);
} elsif (numberp($ob)) {
return "$ob";
} elsif ($quote) { # is a string
......@@ -78,6 +81,13 @@ sub printob {
}
}
sub print_environment {
my ($ob) = @_;
return sprintf("#<Environment[%d]%x>",
$ob->{$n_environment_level},
refaddr($ob));
}
sub print_function {
my ($ob) = @_;
my $type = function_type($ob);
......
Sexp.pm
View file @ 46e77db0
......@@ -22,6 +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
symbol_value_in_env env_vars
);
}
......@@ -30,11 +32,43 @@ my $cons_counter = 0;
# types of sexprs:
# - literal string or number
# - symbol { name => "name", value => $value, func => $function }
# - symbol { name => "name", func => $function }
# - pair { car => ..., cdr => ... }
# - function { type => 'expr|subr', spec => $is_special, func => $func,
# doc => $doc }
my $env_level = 0;
sub new_environment {
my (@vars) = @_;
my $env = bless({ $n_parentenv => $Environment,
$n_environment_level => $env_level++,
@vars }, $n_Environment);
$Environment = $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));
$env_level--;
}
sub env_vars {
my ($env, $noparents) = @_;
my %vars = ();
for (my $e = $env;
defined($e);
$e = $noparents ? undef : $e->{$n_parentenv}) {
@vars{keys(%$e)} = 1;
}
return map { intern($_) } keys(%vars);
}
sub put {
my ($ob, $name, $value) = @_;
return $ob->{symbol_name($name)} = $value;
......@@ -60,6 +94,7 @@ sub symbol_plist {
}
sub all_symbols {
my ($env) = @_;
my @vals = values(%symbols);
return @vals;
}
......@@ -123,9 +158,35 @@ sub function_args {
return function_type($ob) eq 'expr' ? car($ob->{func}) : '';
}
sub defvar {
my ($sym, $initial, $docstring) = @_;
$sym->{docstring} = $docstring;
my $name = symbol_name($sym);
return $root_Environment->{$name} = $initial;
}
sub bind {
my ($sym, $value) = @_;
my $name = symbol_name($sym);
if (exists($Environment->{$name})) {
...
}
$Environment->{$name} = $value;
}
sub set {
my ($sym, $value) = @_;
return $sym->{value} = $value;
stacktrace() unless defined($sym);
my $name = symbol_name($sym);
for (my $env = $Environment;
defined($env);
$env = $env->{$n_parentenv}) {
if (exists($env->{$name})) {
return $env->{$name} = $value;
}
}
return $root_Environment->{$sym} = $value;
}
sub intern {
......@@ -205,6 +266,11 @@ sub symbolp {
return ref($ob) eq $n_Symbol;
}
sub environmentp {
my ($ob) = @_;
return ref($ob) eq $n_Environment;
}
sub functionp {
my ($ob) = @_;
return ref($ob) eq $n_Function;
......@@ -242,7 +308,32 @@ sub symbol_name {
sub symbol_value {
my ($ob) = @_;
return $ob->{value};
my $name = symbol_name($ob);
for (my $env = $Environment;
defined($env);
$env = $env->{$n_parentenv}) {
warn(sprintf("sv search %s in env %s", $ob, $env));
if (exists($env->{$name})) {
return $env->{$name};
}
}
return undef;
}
sub symbol_value_in_env {
my ($ob, $env, $noparents) = @_;
my $name = symbol_name($ob);
for (my $env = $Environment;
defined($env);
$env = $noparents ? undef : $env->{$n_parentenv}) {
warn(sprintf("svie search %s in env %s", $ob, $env));
if (exists($env->{$name})) {
return $env->{$name};
}
}
return undef;
}
sub symbol_function {
......@@ -250,13 +341,6 @@ sub symbol_function {
return $ob->{func};
}
$Nil = intern("nil");
set($Nil, $Nil);
$T = intern("t");
set($T, $T);
$Kappa = intern("kappa");
$Lambda = intern("lambda");
$andRest = intern("&rest");
......@@ -264,6 +348,8 @@ $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");
$t_String = intern("string");
......@@ -271,4 +357,15 @@ $t_Number = intern("number");
$t_Pair = intern("pair");
$t_Function = intern("function");
$root_Environment = new_environment();
$Environment = $root_Environment;
set($root_environment, $root_Environment);
$Nil = intern("nil");
set($Nil, $Nil);
$T = intern("t");
set($T, $T);
1;
Util.pm
View file @ 46e77db0
......@@ -37,6 +37,7 @@ sub arg_type_error {
# check arguments; descriptor is string "xxx:xx" with mandatory args
# before the :, then optional args; x is:
# e: any expression
# E: environment
# y: symbol
# p: pair
# l: list (cons or nil)
......@@ -113,6 +114,9 @@ sub checkargs {
} elsif ($desc eq 's') {
arg_type_error($argno, "string", $arg)
unless stringp($arg);
} elsif ($desc eq 'E') {
arg_type_error($argno, "string", $arg)
unless environmentp($arg);
} else {
error("internal error, unknown arg descriptor %s",
$desc);
......
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