moving to lexical bindings; mostly implemented, but doesn't work yet (46e77db0) · Commits · lisp / lis.pl

Builtin.pm

+28 −8

Original line number	Diff line number	Diff line
		@@ -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

+5 −40

Original line number	Diff line number	Diff line
		@@ -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

+17 −0

Original line number	Diff line number	Diff line
		@@ -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

+10 −0

Original line number	Diff line number	Diff line
		@@ -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

+107 −10

Original line number	Diff line number	Diff line
		@@ -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,20 +308,38 @@ 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};
		}
		}

		sub symbol_function {
		my ($ob) = @_;
		return $ob->{func};
		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};
		}
		}

		$Nil = intern("nil");
		set($Nil, $Nil);
		return undef;
		}

		$T = intern("t");
		set($T, $T);
		sub symbol_function {
		my ($ob) = @_;
		return $ob->{func};
		}

		$Kappa = intern("kappa");
		$Lambda = intern("lambda");
		@@ -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;