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 { ...@@ -439,7 +439,7 @@ sub Bdoc {
my $special = specialp($func); my $special = specialp($func);
my $desc = ($type eq 'expr' ? '' : 'builtin ') my $desc = ($type eq 'expr' ? '' : 'builtin ')
. ($special ? 'special form' : 'function'); . ($special ? 'special form' : 'function');
my $args = princs(function_args($func)); my $args = princs(function_params($func));
my $result = "$desc: $name"; my $result = "$desc: $name";
$result .= " " . $args if $args; $result .= " " . $args if $args;
$result .= "\n" . $doc if $doc && is_nil($brief); $result .= "\n" . $doc if $doc && is_nil($brief);
......
...@@ -74,12 +74,12 @@ sub Read { ...@@ -74,12 +74,12 @@ sub Read {
$t = Read($in); $t = Read($in);
return read_error($in, "EOF in quote") return read_error($in, "EOF in quote")
unless defined($t); unless defined($t);
return list(intern($n_Quote), $t); return cons(intern($n_Quote), cons($t, $Nil));
} elsif ($t eq '#\'') { } elsif ($t eq '#\'') {
$t = Read($in); $t = Read($in);
return read_error($in, "EOF in #quote") return read_error($in, "EOF in #quote")
unless defined($t); unless defined($t);
return list(intern($n_function), $t); return cons(intern($n_function), cons($t, $Nil));
} elsif ($t eq '.') { } elsif ($t eq '.') {
return read_error($in, "found . when expecting sexpr"); return read_error($in, "found . when expecting sexpr");
} elsif (symbolp($t)) { } 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; package Sexp;
...@@ -17,77 +20,104 @@ use Exporter (); ...@@ -17,77 +20,104 @@ use Exporter ();
BEGIN { BEGIN {
@ISA = qw(Exporter); @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 consp symbol_name symbol_function functionp cxr type_of
rplaca rplacd fset function put get symbol_plist rplaca rplacd fset function put get symbol_plist
specialp cadr cddr function_type function_code specialp cadr cddr function_type function_code
symbol_value set function_name is_nil all_symbols remprop 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 enter_environment backto_environment bind defvar
environmentp function_env the_environment environmentp function_env the_environment
symbol_value_in_env env_vars symbol_value_in_env env_vars
); );
} }
my %symbols = (); ######## Variables
my $cons_counter = 0;
my %symbols = (); # table of all symbols
my $cons_counter = 0; # for eval statistics
my $root_Env; # the global environment my $root_Env; # the global environment
my $Env; # the current 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 { ######## Symbols
return $Env; # 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 { # return the symbol with the specified name; create it, if necessary
my ($parent) = @_; sub intern {
return bless({ $n_parentenv => $parent }, $n_Environment); my ($name) = @_;
return $symbols{$name} //= bless({ name => $name }, $n_Symbol);
} }
sub enter_environment { # create a variable in the root environment; set its value if it hasn't existed
my ($parent) = @_; # before
my $newenv = new_environment($parent // $Env); sub defvar {
my $save_env = $Env; my ($sym, $initial, $docstring) = @_;
$Env = $newenv; $sym->{doc} = $docstring // '';
return $save_env; my $name = symbol_name($sym);
$root_Env->{$name} = $initial unless exists($root_Env->{$name});
return $sym;
} }
sub backto_environment { # bind a value to a symbol in (only) the current environment
$Env = $_[0]; sub bind {
# warn("back to environment ", &$f_Princs($Env)); my ($sym, $value) = @_;
my $name = symbol_name($sym);
$Env->{$name} = $value;
} }
sub env_vars { # set the variable value of a symbol; the variable's bindingis looked up in the
my ($env, $noparents) = @_; # current environment including its parents; throw an error if the variable is
my %vars = (); # not bound, except if the value is undef (need this for makunbound, even if the
for ( ; $env != $Nil; $env = $env->{$n_parentenv}) { # variable is not bound already)
@vars{keys(%$env)} = 1; sub set {
last if $noparents; 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 { sub put {
my ($ob, $name, $value) = @_; my ($ob, $name, $value) = @_;
return $ob->{symbol_name($name)} = $value; return $ob->{symbol_name($name)} = $value;
} }
# get a property value of a symbol
sub get { sub get {
my ($ob, $name, $default) = @_; my ($ob, $name, $default) = @_;
return $ob->{symbol_name($name)} // $default; return $ob->{symbol_name($name)} // $default;
} }
# remove a property value of a symbol
sub remprop { sub remprop {
my ($ob, $name) = @_; my ($ob, $name) = @_;
return delete($ob->{symbol_name($name)}); return delete($ob->{symbol_name($name)});
} }
# return the property list of a symbol
sub symbol_plist { sub symbol_plist {
my ($ob) = @_; my ($ob) = @_;
my $result = $Nil; my $result = $Nil;
...@@ -97,38 +127,104 @@ sub symbol_plist { ...@@ -97,38 +127,104 @@ sub symbol_plist {
return $result; 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 { sub all_symbols {
my ($env) = @_; my ($env) = @_;
my @vals = values(%symbols); my @vals = values(%symbols);
return @vals; 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) = @_; my ($ob) = @_;
# we may compare directly with $Nil only once we *know* this is not a return $ob->{cdr}->{car} // $Nil;
# string, as that would trigger a Perl error
return $T if symbolp($ob) && $ob == $Nil;
return 0;
} }
sub is_t { sub cddr {
my ($ob) = @_; my ($ob) = @_;
return $T if symbolp($ob) && $ob == $T; return $ob->{cdr}->{cdr} // $Nil;
return 0;
} }
sub function_documentation { sub car {
my ($ob) = @_; my ($ob) = @_;
return $ob->{doc}; return $ob->{car} // $Nil;
} }
sub type_of { sub cdr {
my ($ob) = @_; my ($ob) = @_;
return "undef" unless defined($ob); return $ob->{cdr} // $Nil;
return ref($ob) || "scalar"; }
sub cxr {
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;
} }
######## 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 { sub function {
my ($func, $is_special, $doc, $name, $env) = @_; my ($func, $is_special, $doc, $name, $env) = @_;
my $type; my $type;
...@@ -147,129 +243,123 @@ sub function { ...@@ -147,129 +243,123 @@ sub function {
$n_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 { sub function_name {
my ($ob) = @_; my ($ob) = @_;
return $ob->{name} // $Nil; return $ob->{name} // $Nil;
} }
# return the type of a function, expr or subr
sub function_type { sub function_type {
my ($ob) = @_; my ($ob) = @_;
return $ob->{type}; return $ob->{type};
} }
# return the code of a function (subr or lambda)
sub function_code { sub function_code {
my ($ob) = @_; my ($ob) = @_;
return $ob->{func}; return $ob->{func};
} }
sub function_args { # return the parameter list of a function
sub function_params {
my ($ob) = @_; my ($ob) = @_;
return function_type($ob) eq 'expr' ? car($ob->{func}) : ''; return function_type($ob) eq 'expr' ? car($ob->{func}) : '';
} }
# return the environment of a function
sub function_env { sub function_env {
my ($ob) = @_; my ($ob) = @_;
return $ob->{env}; return $ob->{env};
} }
sub defvar { # return the docstring of a function
my ($sym, $initial, $docstring) = @_; sub function_documentation {
$sym->{doc} = $docstring // ''; my ($ob) = @_;
my $name = symbol_name($sym); return $ob->{doc};
$root_Env->{$name} = $initial unless exists($root_Env->{$name});
return $sym;
}
sub bind {
my ($sym, $value) = @_;
my $name = symbol_name($sym);
$Env->{$name} = $value;
}
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
} }
sub intern { ######## Environments
my ($name) = @_; # well, yes, a hash: { *parent-environment* => $parent, var1 => ... }
return $symbols{$name} //= bless({ name => $name }, $n_Symbol); # 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 fset { # create a new environment with specified parent, needed separately from
my ($ob, $func) = @_; # enter_environment() to create the root environment
$ob->{func} = $func; sub new_environment {
#print(Dumper($ob)); my ($parent) = @_;
return bless({ $n_parentenv => $parent }, $n_Environment);
} }
sub cons { # be called for a lambda or let etc., creates a new environment with the
my ($car, $cdr) = @_; # previous (let/let*) or explicitly specified (lambda) environment as the parent
$cons_counter++; # and sets this as the current environment; returns the previous environment to
return bless({ car => $car, cdr => $cdr }, $n_Pair); # 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_count { # ends the current environment and goes back to the previously saved one (end of
my ($new) = @_; # let/let*/dolist/lambda context)
my $count = $cons_counter; sub backto_environment {
$cons_counter = $new if defined($new); $Env = $_[0];
return $count; # warn("back to environment ", &$f_Princs($Env));
} }
sub list { # return a list of the symbols bound as variables in the current environment;
my @obs = @_; # with optional $noparents, only in the actual current environment without its
return $Nil unless @obs; # parents
my $car = shift(@obs); sub env_vars {
return cons($car, list(@obs)); 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 cadr { ######## Predicates
my ($ob) = @_;
return $ob->{cdr}->{car} // $Nil;
}
sub cddr { sub is_nil {
my ($ob) = @_; my ($ob) = @_;
return $ob->{cdr}->{cdr} // $Nil; # we may compare directly with $Nil only once we *know* this is not a
# string, as that would trigger a Perl error
return $T if symbolp($ob) && $ob == $Nil;
return 0;
} }
sub car { sub is_t {
my ($ob) = @_; my ($ob) = @_;
return $ob->{car} // $Nil; return $T if symbolp($ob) && $ob == $T;
return 0;
} }
sub cdr { ######## Type function and predicates
my ($ob) = @_;
return $ob->{cdr} // $Nil;
}
sub cxr { sub type_of {
my ($ob) = @_; my ($ob) = @_;
return ($ob->{car}, $ob->{cdr}); return "undef" unless defined($ob);
} return ref($ob) || "scalar";
sub rplaca {
my ($ob, $newcar) = @_;
return $ob->{car} = $newcar;
}
sub rplacd {
my ($ob, $newcdr) = @_;
return $ob->{cdr} = $newcdr;
} }
sub listp { sub listp {
...@@ -312,33 +402,9 @@ sub consp { ...@@ -312,33 +402,9 @@ sub consp {
return ref($ob) eq $n_Pair; return ref($ob) eq $n_Pair;
} }
sub symbol_exists { ######## Initialization
my ($name) = @_; # we do a lots of Global's initialization here, because we need intern() and
return exists($symbols{$name}); # defvar() and want to keep the dependency graph acyclic
}
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};
}
sub init { 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!