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