Skip to content

Commit

Permalink
[Yapsi] first shot at blocks and scopes
Browse files Browse the repository at this point in the history 
There's no stack yet, and thus no proper block exit back to surrounding blocks.
But calling a block from another block works, and each block has its own
lexical pad.
  • Loading branch information
Carl Masak committed Apr 26, 2010
1 parent eb85d72 commit ca681fc
Show file tree
Hide file tree
Showing 2 changed files with 163 additions and 66 deletions.
228 changes: 162 additions & 66 deletions lib/Yapsi.pm
View file
@@ -1,5 +1,7 @@
use v6;

my $VERSION = '2010.05';

grammar Yapsi::Perl6::Grammar {
regex TOP { ^ <statementlist> <.ws> $ }
regex statementlist { <statement> ** <eat_terminator> }
Expand All @@ -24,31 +26,54 @@ grammar Yapsi::Perl6::Grammar {
class Yapsi::Compiler {
has @.warnings;

has %!d; # a variable gets an entry in %!d when it's declared
has $!c; # unique register counter; increases with each new register
has @!sic; # SIC statements generated by the compiler
has %!pads; # maps lexical blocks to the variables they declare
has $!c; # unique register counter; increases with each new register

has @!block-order;
has %!blocks;
has $!current-block;

method compile($program) {
@!warnings = ();
die "Could not parse"
unless Yapsi::Perl6::Grammar.parse($program);
%!d = ();
%!pads = ();
$!current-block = Mu;
self.find-vars($/, 'block');
$!c = 0;
@!sic = '`lexicals: <' ~ (join ' ', %!d.keys) ~ '>';
@!block-order = ();
%!blocks = ();
$!current-block = Mu;
self.sicify($/, 'block');
return renumber(declutter(@!sic));
my @sic = "This is SIC v$VERSION";
for @!block-order -> $block {
push @sic, '';
push @sic, "block '$block':";
for renumber(declutter(%!blocks{$block})) {
push @sic, ' ' ~ $_;
}
}
return @sic;
}

multi method find-vars(Match $/, 'statement') {
if $<expression> -> $e {
if $<expression><block> -> $e {
my $remember-block = $!current-block;
self.find-vars($e, 'block');
$!current-block = $remember-block;
}
elsif $<expression> -> $e {
self.find-vars($e, 'expression');
}
}

multi method find-vars(Match $/, 'expression') {
# XXX: This warning doesn't have much to do with finding vars
if $/<block> {
die "Can not handle non-immediate blocks yet. Sorry. :/";
}
for <assignment binding variable declaration saycall
increment block> -> $subrule {
increment> -> $subrule {
if $/{$subrule} -> $e {
self.find-vars($e, $subrule);
}
Expand All @@ -71,10 +96,14 @@ class Yapsi::Compiler {
}
}

multi method find-vars(Match $/, 'variable') {
unless %!d.exists( ~$/ ) {
die "Invalid. $/ not declared before use";
multi method find-vars(Match $name, 'variable') {
my $block = $!current-block;
loop {
return if %!pads{$block}.exists( ~$name );
last unless $block ~~ / _\d+ $/;
$block.=substr(0, $block.chars - $/.chars);
}
die "Invalid. $name not declared before use";
}

multi method find-vars(Match $/, 'literal') {
Expand All @@ -83,7 +112,7 @@ class Yapsi::Compiler {

multi method find-vars(Match $/, 'declaration') {
my $name = ~$<variable>;
if %!d{$name}++ {
if %!pads{$!current-block}{$name}++ {
@!warnings.push: "Useless redeclaration of variable $name";
}
}
Expand All @@ -107,6 +136,13 @@ class Yapsi::Compiler {
}

multi method find-vars(Match $/, 'block') {
if defined $!current-block {
$!current-block ~= '_1'; # XXX wrong for same-level blocks
}
else {
$!current-block = 'main';
}
%!pads{$!current-block} = {};
for $<statementlist><statement> -> $statement {
self.find-vars($statement, 'statement');
}
Expand All @@ -120,15 +156,27 @@ class Yapsi::Compiler {
return '$' ~ $!c++;
}

method add-code($line) {
%!blocks{$!current-block}.push($line);
}

multi method sicify(Match $/, 'statement') {
if $<expression> -> $e {
if $<expression><block> -> $e {
my $remember-block = $!current-block;
my $block = self.sicify($e, 'block');
my $register = self.unique-register;
$!current-block = $remember-block;
self.add-code: "$register = fetch-block '$block'";
self.add-code: "call $register";
}
elsif $<expression> -> $e {
return self.sicify($e, 'expression');
}
}

multi method sicify(Match $/, 'expression') {
for <variable literal declaration assignment binding saycall
increment block> -> $subrule {
increment> -> $subrule {
if $/{$subrule} -> $e {
return self.sicify($e, $subrule);
}
Expand All @@ -154,14 +202,14 @@ class Yapsi::Compiler {
multi method sicify(Match $/, 'variable') {
my $register = self.unique-register;
my $variable = "'$/'";
push @!sic, "$register = fetch $variable";
self.add-code: "$register = fetch $variable";
return ($register, $variable);
}

multi method sicify(Match $/, 'literal') {
my $register = self.unique-register;
my $literal = ~$/;
push @!sic, "$register = $literal";
self.add-code: "$register = $literal";
return ($register, '<constant>');
}

Expand All @@ -172,7 +220,7 @@ class Yapsi::Compiler {
multi method sicify(Match $/, 'assignment') {
my ($register, $) = self.sicify($<expression>, 'expression');
my ($, $variable) = self.sicify($<lvalue>, 'lvalue');
push @!sic, "store $variable, $register";
self.add-code: "store $variable, $register";
return ($register, $variable);
}

Expand All @@ -182,33 +230,41 @@ class Yapsi::Compiler {
if $rightvar ~~ / ^ \d+ $ / { # hm. this is brittle and suboptimal.
$rightvar = $register;
}
push @!sic, "bind $leftvar, $rightvar";
self.add-code: "bind $leftvar, $rightvar";
return ($register, $leftvar);
}

multi method sicify(Match $/, 'saycall') {
my ($register, $) = self.sicify($<expression>, 'expression');
my $result = self.unique-register;
push @!sic, "say $register";
push @!sic, "$result = 1";
self.add-code: "say $register";
self.add-code: "$result = 1";
return ($result, 1);
}

multi method sicify(Match $/, 'increment') {
my ($register, $variable) = self.sicify($<value>, 'value');
die "Can't increment a constant"
if $variable eq '<constant>';
push @!sic, "inc $register";
push @!sic, "store $variable, $register";
self.add-code: "inc $register";
self.add-code: "store $variable, $register";
return ($register, $variable);
}

multi method sicify(Match $/, 'block') {
my ($register, $variable);
if defined $!current-block {
$!current-block ~= '_1'; # XXX wrong for same-level blocks
}
else {
$!current-block = 'main';
}
@!block-order.push($!current-block);
%!blocks{$!current-block}
= ['`lexicals: <' ~ (join ' ', %!pads{$!current-block}.keys) ~ '>'];
for $<statementlist><statement> -> $statement {
($register, $variable) = self.sicify($statement, 'statement');
self.sicify($statement, 'statement');
}
return ($register, $variable);
return $!current-block;
}

multi method sicify(Match $/, $node) {
Expand Down Expand Up @@ -257,57 +313,97 @@ class Yapsi::Runtime {
has Yapsi::IO $!io = $*OUT;

method run(@sic) {
if @sic[0] !~~ /^ 'This is SIC v'(\d\d\d\d\.\d\d) $/ {
die "Incompatible SIC version line";
}
elsif ~$0 ne $VERSION {
die "SIC is $0 but this is $VERSION -- cannot run";
}
my @r;
my %pad;
my %pads;
my @containers;
for @sic {
when /^ '`lexicals: <' ('' || \S+ ** \s) '>' $ / {
for $0.comb(/\S+/) -> $var {
%pad{$var} = { :type<container>, :n(+@containers) };
push @containers, 'Any()';
my $current-block = 'main';
my $ip = find-block(@sic, $current-block) + 1;
loop {
return if $ip >= @sic || @sic[$ip] eq '';
given @sic[$ip++].substr(4) {
when /^ '`lexicals: <' ('' || \S+ ** \s) '>' $ / {
%pads{$current-block} = {};
for $0.comb(/\S+/) -> $var {
%pads{$current-block}{$var}
= { :type<container>, :n(+@containers) };
push @containers, 'Any()';
}
}
}
when /^ '$'(\d+) ' = ' (\d+) $/ {
@r[+$0] = +$1
}
when /^ 'store ' \'(<-[']>+)\' ', $'(\d+) $/ {
my $thing = %pad{~$0};
if $thing<type> eq 'container' {
my $n = $thing<n>;
@containers[$n] = @r[+$1];
when /^ '$'(\d+) ' = ' (\d+) $/ {
@r[+$0] = +$1
}
else {
die "Cannot store something in readonly symbol ~$0";
when /^ 'store ' \'(<-[']>+)\' ', $'(\d+) $/ {
my $thing = locate-variable(%pads, $current-block, ~$0);
if $thing<type> eq 'container' {
my $n = $thing<n>;
@containers[$n] = @r[+$1];
}
else {
die "Cannot store something in readonly symbol ~$0";
}
}
}
when /^ '$'(\d+) ' = fetch '\'(<-[']>+)\' $/ {
my $thing = %pad{~$1};
if $thing<type> eq 'container' {
my $n = $thing<n>;
@r[+$0] = @containers[$n];
when /^ '$'(\d+) ' = fetch '\'(<-[']>+)\' $/ {
my $thing = locate-variable(%pads, $current-block, ~$1);
if $thing<type> eq 'container' {
my $n = $thing<n>;
@r[+$0] = @containers[$n];
}
else { # immadiate
@r[+$0] = $thing<value>;
}
}
else { # immadiate
@r[+$0] = $thing<value>;
when /^ 'bind ' \'(<-[']>+)\' ', ' \'(<-[']>+)\' $/ {
%pads{$current-block}{~$0} = %pads{$current-block}{~$1};
}
}
when /^ 'bind ' \'(<-[']>+)\' ', ' \'(<-[']>+)\' $/ {
%pad{~$0} = %pad{~$1};
}
when /^ 'bind ' \'(<-[']>+)\' ', $'(\d+) $/ {
%pad{~$0} = { :type<immediate>, :value(+$1) };
}
when /^ 'say $'(\d+) $/ {
$!io.say: @r[+$0];
}
when /^ 'inc $'(\d+) $/ {
if @r[+$0] eq 'Any()' {
@r[+$0] = 1;
when /^ 'bind ' \'(<-[']>+)\' ', $'(\d+) $/ {
%pads{$current-block}{~$0}
= { :type<immediate>, :value(+$1) };
}
when /^ 'say $'(\d+) $/ {
$!io.say: @r[+$0];
}
when /^ 'inc $'(\d+) $/ {
if @r[+$0] eq 'Any()' {
@r[+$0] = 1;
}
else {
++@r[+$0];
}
}
else {
++@r[+$0];
when /^ '$'(\d+) ' = fetch-block '\'(<-[']>+)\' $/ {
@r[+$0] = ~$1;
}
when /^ 'call $'(\d+) $/ {
$ip = find-block(@sic, @r[+$0]) + 1;
$current-block = @r[+$0];
}
default { die "Couldn't handle instruction `$_`" }
}
}
}

sub find-block(@sic, Str $block-sought) {
for ^@sic {
if @sic[$_] ~~ /^'block ' \'(<-[']>+)\'/ && ~$0 eq $block-sought {
return $_;
}
default { die "Couldn't handle instruction `$_`" }
}
die "Could not find block '$block-sought'";
}

sub locate-variable(%pads, $block is copy, Str $name) {
loop {
return %pads{$block}{$name}
if %pads{$block}.exists($name);
last unless $block ~~ / _\d+ $/;
$block.=substr(0, $block.chars - $/.chars);
}
die "Runtime panic -- could not find variable $name";
}
}
1 change: 1 addition & 0 deletions t/runtime.t
View file
Expand Up @@ -23,6 +23,7 @@ my @tests =
'my $a = 42; say ++$a', "43\n", 'prefix increment',
'my $a; say ++$a', "1\n", 'increment undefined',
'my $a = 42; { say $a }', "42\n", 'variable in a block',
'my $a = 42; { say my $a }', "Any()\n", 'new variable in a block',
;

for @tests -> $program, $expected, $message {
Expand Down

0 comments on commit ca681fc

Please sign in to comment.