madmaurice/Minilisp.pm
1
1
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Rework ctx system

Browse source
This commit is contained in:
madmaurice 2021-04-04 22:15:04 +02:00
parent 4a42695a27
commit 2d668371e2
1 changed files with 67 additions and 16 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

83
lib/Minilisp.pm
View file

@ -93,6 +93,53 @@ sub tokenize {
return @tokens;
}
sub ctx_create {
my $base = shift || undef;
my $vars = shift || {};
return {
base => $base,
vars => $vars
};
}
sub ctx_get {
my $ctx = shift;
my $identifier = shift;
while (defined $ctx && !exists($ctx->{vars}->{$identifier}))
{
$ctx = $ctx->{base};
}
die "Variable $identifier does not defined" unless defined $ctx;
return $ctx->{vars}->{$identifier};
}
sub ctx_set {
my $ctx = shift;
my $identifier = shift;
my $value = shift;
$ctx->{vars}->{$identifier} = $value;
}
sub ctx_assign {
my $ctx = shift;
my $identifier = shift;
my $value = shift;
while (defined $ctx && !exists($ctx->{vars}->{$identifier}))
{
$ctx = $ctx->{base};
}
die "Variable $identifier does not defined" unless defined $ctx;
$ctx->{vars}->{$identifier} = $value;
}
sub lisp_format {
my $e = shift;
if (ref($e) eq "ARRAY")
@ -330,12 +377,13 @@ my %stdctx = (
sub parser {
my @tokens = @_;
my $expr = parser_prog(\@tokens);
my $base_ctx = ctx_create(undef, \%stdctx);
return sub {
my $ctx = shift;
my $ictx = { %stdctx, %$ctx };
my $vars = shift;
my $ctx = ctx_create($base_ctx, $vars);
return $expr->($ictx);
return $expr->($ctx);
}
}
@ -373,9 +421,7 @@ sub parser_expr {
return sub {
my $ctx = shift;
my $name = $tok->{value};
die "Undefined identifier $name" unless
exists $ctx->{$name};
return $ctx->{$name};
return ctx_get($ctx, $name);
}
}
elsif($tok->{type} == KEYWORD)
@ -460,7 +506,7 @@ sub macro_let {
my $tok = shift @$ts;
die "Expected ( after let" unless $tok->{type} == LPAREN;
my $pctx = {};
my $variables = {};
while ($ts->[0]->{type} != RPAREN)
{
@ -483,7 +529,7 @@ sub macro_let {
$tok = shift @$ts;
die "Expected ) after parameter pair" unless $tok->{type} == RPAREN;
$pctx->{$ident->{value}} = $assignment;
$variables->{$ident->{value}} = $assignment;
}
die "Expected ) after parameter list in let" unless $ts->[0]->{type} == RPAREN;
@ -493,8 +539,8 @@ sub macro_let {
return sub {
my $octx = shift;
my $ictx = { %$octx };
$ictx->{$_} = $pctx->{$_}->($octx) foreach (keys %$pctx);
my $ictx = ctx_create($octx);
ctx_set($ictx, $_, $variables->{$_}->($octx)) foreach (keys %$variables);
return $inner->($ictx);
}
@ -525,12 +571,15 @@ sub macro_lambda {
return sub {
my $octx = shift;
return sub {
my $ictx = { %$octx };
my $ictx = ctx_create($octx);
my @pnames = @param_list;
my @pvals = @_;
while ( (my $name = shift @pnames) && (my $val = shift @pvals) )
while ( @pnames && @pvals )
{
$ictx->{$name} = $val;
my $name = shift @pnames;
my $val = shift @pvals;
ctx_set($ictx, $name, $val);
}
die "Too many arguments" if scalar(@pvals);
@ -602,9 +651,11 @@ sub macro_defun {
my $self = sub {
return $fn->(@_);
};
$ctx->{$ident->{value}} = $self;
$fn = $body->($ctx);
$ctx->{$ident->{value}} = $fn;
my $ictx = ctx_create($ctx, {
'$ident->{value}' => $self,
});
$fn = $body->($ictx);
ctx_set($ctx, $ident->{value}, $fn);
return $fn;
}
}