Commit fda1b281 authored by Juergen Nickelsen's avatar Juergen Nickelsen
Browse files

big cleanup in Sexp, and commenting (not yet finished)

parent 48e6057b
......@@ -439,7 +439,7 @@ sub Bdoc {
my $special = specialp($func);
my $desc = ($type eq 'expr' ? '' : 'builtin ')
. ($special ? 'special form' : 'function');
my $args = princs(function_args($func));
my $args = princs(function_params($func));
my $result = "$desc: $name";
$result .= " " . $args if $args;
$result .= "\n" . $doc if $doc && is_nil($brief);
......
......@@ -74,12 +74,12 @@ sub Read {
$t = Read($in);
return read_error($in, "EOF in quote")
unless defined($t);
return list(intern($n_Quote), $t);
return cons(intern($n_Quote), cons($t, $Nil));
} elsif ($t eq '#\'') {
$t = Read($in);
return read_error($in, "EOF in #quote")
unless defined($t);
return list(intern($n_function), $t);
return cons(intern($n_function), cons($t, $Nil));
} elsif ($t eq '.') {
return read_error($in, "found . when expecting sexpr");
} elsif (symbolp($t)) {
......
# Symbolic Expressions
## Symbolic Expressions -- actually, the low-level details of the objects, and
## create/set/get functions, also in parts for strings and numbers, although
## these are actually just Perl numbers and strings. (And as such, only
## partially distinguishable.)
package Sexp;
......@@ -17,77 +20,104 @@ use Exporter ();
BEGIN {
@ISA = qw(Exporter);
@EXPORT = qw( intern cons list car cdr listp symbolp numberp stringp
@EXPORT = qw( intern cons car cdr listp symbolp numberp stringp
consp symbol_name symbol_function functionp cxr type_of
rplaca rplacd fset function put get symbol_plist
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
function_documentation is_t cons_count function_params
enter_environment backto_environment bind defvar
environmentp function_env the_environment
symbol_value_in_env env_vars
);
}
my %symbols = ();
my $cons_counter = 0;
######## Variables
my %symbols = (); # table of all symbols
my $cons_counter = 0; # for eval statistics
my $root_Env; # the global environment
my $Env; # the current environment
# types of sexprs:
# - literal string or number
# - symbol { name => "name", func => $function }
# - pair { car => ..., cdr => ... }
# - function { type => 'expr|subr', spec => $is_special, func => $func,
# doc => $doc, env => $Env }
sub the_environment {
return $Env;
}
######## Symbols
# a symbol is a hash: { name => "name", func => $function, ... }
# the property list is actually the hash itself, so you can access all
# properties [sic] of a symbol from Lisp
sub new_environment {
my ($parent) = @_;
return bless({ $n_parentenv => $parent }, $n_Environment);
# return the symbol with the specified name; create it, if necessary
sub intern {
my ($name) = @_;
return $symbols{$name} //= bless({ name => $name }, $n_Symbol);
}
sub enter_environment {
my ($parent) = @_;
my $newenv = new_environment($parent // $Env);
my $save_env = $Env;
$Env = $newenv;
return $save_env;
# create a variable in the root environment; set its value if it hasn't existed
# before
sub defvar {
my ($sym, $initial, $docstring) = @_;
$sym->{doc} = $docstring // '';
my $name = symbol_name($sym);
$root_Env->{$name} = $initial unless exists($root_Env->{$name});
return $sym;
}
sub backto_environment {
$Env = $_[0];
# warn("back to environment ", &$f_Princs($Env));
# bind a value to a symbol in (only) the current environment
sub bind {
my ($sym, $value) = @_;
my $name = symbol_name($sym);
$Env->{$name} = $value;
}
sub env_vars {
my ($env, $noparents) = @_;
my %vars = ();
for ( ; $env != $Nil; $env = $env->{$n_parentenv}) {
@vars{keys(%$env)} = 1;
last if $noparents;
# set the variable value of a symbol; the variable's bindingis looked up in the
# current environment including its parents; throw an error if the variable is
# not bound, except if the value is undef (need this for makunbound, even if the
# variable is not bound already)
sub set {
my ($sym, $value, $env) = @_;
# confess("\$sym undefined") unless defined($sym);
my $name = symbol_name($sym);
return $env->{$name} = $value if $env;
for (my $env = $Env; $env != $Nil; $env = $env->{$n_parentenv}) {
# warn("search env ", $env->{$n_env_name}, " for ", $name);
if (exists($env->{$name})) {
# warn("set $name in ", $env->{$n_env_name});
return $env->{$name} = $value;
}
return map { intern($_) } keys(%vars);
}
error("set/setq for undefined variable %s", $sym)
if defined($value); # enable makunbound on undefined
# variables
}
# set the function value of a symbol
sub fset {
my ($ob, $func) = @_;
$ob->{func} = $func;
#print(Dumper($ob));
}
# set a property value of a symbol
sub put {
my ($ob, $name, $value) = @_;
return $ob->{symbol_name($name)} = $value;
}
# get a property value of a symbol
sub get {
my ($ob, $name, $default) = @_;
return $ob->{symbol_name($name)} // $default;
}
# remove a property value of a symbol
sub remprop {
my ($ob, $name) = @_;
return delete($ob->{symbol_name($name)});
}
# return the property list of a symbol
sub symbol_plist {
my ($ob) = @_;
my $result = $Nil;
......@@ -97,38 +127,104 @@ sub symbol_plist {
return $result;
}
# return true iff a symbol is already created
sub symbol_exists {
my ($name) = @_;
return exists($symbols{$name});
}
# return the name of a symbol as a string
sub symbol_name {
my ($ob) = @_;
return $ob->{name};
}
# return the value bound to a symbol, or undef if it isn't bound; this searches
# through the current environment and its parents
sub symbol_value {
my ($ob, $env, $noparents) = @_;
$env //= $Env;
my $name = symbol_name($ob);
for ( ; $env != $Nil; $env = $env->{$n_parentenv}) {
if (exists($env->{$name})) {
return $env->{$name};
}
last if $noparents;
}
return undef;
}
# return the function bound to a symbol
sub symbol_function {
my ($ob) = @_;
return $ob->{func};
}
# return an arry with all symbols
sub all_symbols {
my ($env) = @_;
my @vals = values(%symbols);
return @vals;
}
sub is_nil {
######## Pairs
# a pair is a hash, too: { car => ..., cdr => ... }
# there are no other fields in a hash
sub cons {
my ($car, $cdr) = @_;
$cons_counter++;
return bless({ car => $car, cdr => $cdr }, $n_Pair);
}
sub cons_count {
my ($new) = @_;
my $count = $cons_counter;
$cons_counter = $new if defined($new);
return $count;
}
sub cadr {
my ($ob) = @_;
# we may compare directly with $Nil only once we *know* this is not a
# string, as that would trigger a Perl error
return $ob->{cdr}->{car} // $Nil;
}
return $T if symbolp($ob) && $ob == $Nil;
return 0;
sub cddr {
my ($ob) = @_;
return $ob->{cdr}->{cdr} // $Nil;
}
sub is_t {
sub car {
my ($ob) = @_;
return $T if symbolp($ob) && $ob == $T;
return 0;
return $ob->{car} // $Nil;
}
sub function_documentation {
sub cdr {
my ($ob) = @_;
return $ob->{doc};
return $ob->{cdr} // $Nil;
}
sub type_of {
sub cxr {
my ($ob) = @_;
return "undef" unless defined($ob);
return ref($ob) || "scalar";
return ($ob->{car}, $ob->{cdr});
}
sub rplaca {
my ($ob, $newcar) = @_;
return $ob->{car} = $newcar;
}
sub rplacd {
my ($ob, $newcdr) = @_;
return $ob->{cdr} = $newcdr;
}
######## Functions
# a hash, too (surprise!): { type => 'expr|subr', spec => $is_special,
# func => $func, doc => $doc, env => $Env }
# create a new function of a Perl function or lambda, is-special flag,
# docstring, name (a symbol, for decoration in print only), and the function
# environment (optional (and currently unused)) or the current one
sub function {
my ($func, $is_special, $doc, $name, $env) = @_;
my $type;
......@@ -147,129 +243,123 @@ sub function {
$n_Function);
}
# return the name (symbol) of a function, the one it was defined with (but is
# not necessarily still bound to, for decorative purposes
sub function_name {
my ($ob) = @_;
return $ob->{name} // $Nil;
}
# return the type of a function, expr or subr
sub function_type {
my ($ob) = @_;
return $ob->{type};
}
# return the code of a function (subr or lambda)
sub function_code {
my ($ob) = @_;
return $ob->{func};
}
sub function_args {
# return the parameter list of a function
sub function_params {
my ($ob) = @_;
return function_type($ob) eq 'expr' ? car($ob->{func}) : '';
}
# return the environment of a function
sub function_env {
my ($ob) = @_;
return $ob->{env};
}
sub defvar {
my ($sym, $initial, $docstring) = @_;
$sym->{doc} = $docstring // '';
my $name = symbol_name($sym);
$root_Env->{$name} = $initial unless exists($root_Env->{$name});
return $sym;
}
sub bind {
my ($sym, $value) = @_;
my $name = symbol_name($sym);
$Env->{$name} = $value;
# return the docstring of a function
sub function_documentation {
my ($ob) = @_;
return $ob->{doc};
}
sub set {
my ($sym, $value, $env) = @_;
# confess("\$sym undefined") unless defined($sym);
my $name = symbol_name($sym);
return $env->{$name} = $value if $env;
for (my $env = $Env; $env != $Nil; $env = $env->{$n_parentenv}) {
# warn("search env ", $env->{$n_env_name}, " for ", $name);
if (exists($env->{$name})) {
# warn("set $name in ", $env->{$n_env_name});
return $env->{$name} = $value;
}
}
error("set/setq for undefined variable %s", $sym)
if defined($value); # enable makunbound on undefined
# variables
######## Environments
# well, yes, a hash: { *parent-environment* => $parent, var1 => ... }
# the root environment's parent is $Nil
#
# if we put the symbols themselves into the hash, they are converted to strings
# of the form "Symbol=HASH(0x7f8f89a64030)", so we cannot use keys() to iterate
# over them; instead we put the symbol names as strings into the hash, so we can
# iterate over these and intern() ourselves back to the symbol
#
# in a previous version, each environment held a level counter, a name, and a
# reference to itself, but this came at some performance cost, so out again it
# went
# return the current environment (for a Builtin)
sub the_environment {
return $Env;
}
sub intern {
my ($name) = @_;
return $symbols{$name} //= bless({ name => $name }, $n_Symbol);
# create a new environment with specified parent, needed separately from
# enter_environment() to create the root environment
sub new_environment {
my ($parent) = @_;
return bless({ $n_parentenv => $parent }, $n_Environment);
}
sub fset {
my ($ob, $func) = @_;
$ob->{func} = $func;
#print(Dumper($ob));
# be called for a lambda or let etc., creates a new environment with the
# previous (let/let*) or explicitly specified (lambda) environment as the parent
# and sets this as the current environment; returns the previous environment to
# be saved for the benefit of backto_environment()
sub enter_environment {
my ($parent) = @_;
my $newenv = new_environment($parent // $Env);
my $save_env = $Env;
$Env = $newenv;
return $save_env;
}
sub cons {
my ($car, $cdr) = @_;
$cons_counter++;
return bless({ car => $car, cdr => $cdr }, $n_Pair);
# ends the current environment and goes back to the previously saved one (end of
# let/let*/dolist/lambda context)
sub backto_environment {
$Env = $_[0];
# warn("back to environment ", &$f_Princs($Env));
}
sub cons_count {
my ($new) = @_;
my $count = $cons_counter;
$cons_counter = $new if defined($new);
return $count;
# return a list of the symbols bound as variables in the current environment;
# with optional $noparents, only in the actual current environment without its
# parents
sub env_vars {
my ($env, $noparents) = @_;
my %vars = ();
for ( ; $env != $Nil; $env = $env->{$n_parentenv}) {
@vars{keys(%$env)} = 1;
last if $noparents;
}
return map { intern($_) } keys(%vars);
}
sub list {
my @obs = @_;
return $Nil unless @obs;
my $car = shift(@obs);
return cons($car, list(@obs));
}
######## Predicates
sub cadr {
sub is_nil {
my ($ob) = @_;
return $ob->{cdr}->{car} // $Nil;
}
# we may compare directly with $Nil only once we *know* this is not a
# string, as that would trigger a Perl error
sub cddr {
my ($ob) = @_;
return $ob->{cdr}->{cdr} // $Nil;
return $T if symbolp($ob) && $ob == $Nil;
return 0;
}
sub car {
sub is_t {
my ($ob) = @_;
return $ob->{car} // $Nil;
return $T if symbolp($ob) && $ob == $T;
return 0;
}
sub cdr {
my ($ob) = @_;
return $ob->{cdr} // $Nil;
}
######## Type function and predicates
sub cxr {
sub type_of {
my ($ob) = @_;
return ($ob->{car}, $ob->{cdr});
}
sub rplaca {
my ($ob, $newcar) = @_;
return $ob->{car} = $newcar;
}
sub rplacd {
my ($ob, $newcdr) = @_;
return $ob->{cdr} = $newcdr;
return "undef" unless defined($ob);
return ref($ob) || "scalar";
}
sub listp {
......@@ -312,33 +402,9 @@ sub consp {
return ref($ob) eq $n_Pair;
}
sub symbol_exists {
my ($name) = @_;
return exists($symbols{$name});
}
sub symbol_name {
my ($ob) = @_;
return $ob->{name};
}
sub symbol_value {
my ($ob, $env, $noparents) = @_;
$env //= $Env;
my $name = symbol_name($ob);
for ( ; $env != $Nil; $env = $env->{$n_parentenv}) {
if (exists($env->{$name})) {
return $env->{$name};
}
last if $noparents;
}
return undef;
}
sub symbol_function {
my ($ob) = @_;
return $ob->{func};
}
######## Initialization
# we do a lots of Global's initialization here, because we need intern() and
# defvar() and want to keep the dependency graph acyclic
sub init {
......
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