diff --git a/lib/Minilisp.pm b/lib/Minilisp.pm index bcc7076..57c5f4b 100644 --- a/lib/Minilisp.pm +++ b/lib/Minilisp.pm @@ -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} = \¯o_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} = \¯o_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} = \¯o_go; + sub compile { my ($term) = @_; my @tokens = tokenize($term); diff --git a/t/tagbody.t b/t/tagbody.t new file mode 100644 index 0000000..b2a64e3 --- /dev/null +++ b/t/tagbody.t @@ -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)))