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

Implement tagbody and go macros

Browse source
This commit is contained in:
madmaurice 2021-04-10 21:42:44 +02:00
parent 44468958b6
commit e6342eda24
2 changed files with 98 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

70
lib/Minilisp.pm
View file

@ -479,6 +479,10 @@ sub parser_prog {
{
die "Uncaught exception $1";
}
elsif ($type eq "goto")
{
die "Target $@->{section} of go statement not found";
}
}
die "$@";
}
@ -1191,6 +1195,72 @@ sub macro_dolist {
}
$macros{dolist} = \&macro_dolist;
sub macro_tagbody {
my $ts = shift;
my $init_symbol = bless({},"init");
my $parse_section = $init_symbol;
my %schedule;
my %sections;
$sections{$parse_section} = [];
while (!peek_token($ts, RPAREN))
{
if (peek_token($ts, IDENT))
{
my $next_parse_section = slurp_token($ts, IDENT)->{value};
$schedule{$parse_section} = $next_parse_section;
$parse_section = $next_parse_section;
$sections{$parse_section} = [];
}
else
{
push @{$sections{$parse_section}}, parser_expr($ts);
}
}
return sub {
my $octx = shift;
my $ictx = ctx_create($octx);
my $current_section = $init_symbol;
do {
eval {
$_->($ictx) foreach @{$sections{$current_section}};
1;
};
if ($@)
{
if (ref($@) eq "goto" && exists($sections{$@->{section}}))
{
$current_section = $@->{section}
}
else
{
die $@;
}
}
else
{
$current_section = $schedule{$current_section};
}
} while($current_section);
};
}
$macros{tagbody} = \&macro_tagbody;
sub macro_go {
my $ts = shift;
my $ident = slurp_token($ts, IDENT, "Expected identifier after go")->{value};
return sub {
die bless({ section => $ident }, "goto");
};
}
$macros{go} = \&macro_go;
sub compile {
my ($term) = @_;
my @tokens = tokenize($term);

28
t/tagbody.t Normal file
View file

@ -0,0 +1,28 @@
(plan 2)
(defun inc (n) (+ n 1))
(expect "dotimes - sections are evaluated in order"
(equal 'ok
(catch 'test
(let ((i 0))
(tagbody
(set i 's0)
section-a
(unless (equal i 's0) (throw 'test 'fail))
(set i 's1)
section-b
(unless (equal i 's1) (throw 'test 'fail))
(set i 's2))
(unless (equal i 's2) (throw 'test 'fail)))
'ok)))
(expect "dotimes - go works"
(equal 'ok
(catch 'test
(tagbody
(go section-b)
section-a
(throw 'test 'fail)
section-b)
'ok)))