Permalink
Browse files

[Yapsi] removed from this project

Added it as a dependency instead.
  • Loading branch information...
1 parent f9a37bb commit b598605e5af3b5faf96dbf6d39e0d37706fae6e5 @masak committed Apr 1, 2010
Showing with 1 addition and 545 deletions.
  1. +1 −0 deps.proto
  2. +0 −260 lib/Yapsi.pm
  3. +0 −55 t/yapsi/parse.t
  4. +0 −230 yapsi-prototype
View
1 deps.proto
@@ -0,0 +1 @@
+yapsi
View
260 lib/Yapsi.pm
@@ -1,260 +0,0 @@
-use v6;
-
-grammar Yapsi::Perl6::Grammar {
- regex TOP { ^ <statement> ** ';' $ }
- token statement { <expression> || '' }
- token expression { <assignment> || <binding> || <variable> || <literal>
- || <declaration> || <saycall> }
- token lvalue { <declaration> || <variable> }
- token variable { '$' \w+ }
- token literal { \d+ }
- rule declaration { 'my' <variable> }
- rule assignment { <lvalue> '=' <expression> }
- rule binding { <lvalue> ':=' <expression> }
- rule saycall { 'say' <expression> } # very temporary solution
-}
-
-my %d; # a variable gets an entry in %d when it's declared
-
-multi sub find-vars(Match $/, 'statement') {
- if $<expression> -> $e {
- find-vars($e, 'expression');
- }
-}
-
-multi sub find-vars(Match $/, 'expression') {
- for <assignment binding variable declaration saycall> -> $subrule {
- if $/{$subrule} -> $e {
- find-vars($e, $subrule);
- }
- }
-}
-
-multi sub find-vars(Match $/, 'lvalue') {
- for <variable declaration> -> $subrule {
- if $/{$subrule} -> $e {
- find-vars($e, $subrule);
- }
- }
-}
-
-multi sub find-vars(Match $/, 'variable') {
- if !%d.exists( ~$/ ) {
- die "Invalid. $/ not declared before use";
- }
-}
-
-multi sub find-vars(Match $/, 'literal') {
- die "This multi variant should never be called";
-}
-
-multi sub find-vars(Match $/, 'declaration') {
- my $name = ~$<variable>;
- if %d{$name}++ {
- $*ERR.say: "Useless redeclaration of variable $name";
- }
-}
-
-multi sub find-vars(Match $/, 'assignment') {
- find-vars($<lvalue>, 'lvalue');
- find-vars($<expression>, 'expression');
-}
-
-multi sub find-vars(Match $/, 'binding') {
- find-vars($<lvalue>, 'lvalue');
- find-vars($<expression>, 'expression');
-}
-
-multi sub find-vars(Match $/, 'saycall') {
- find-vars($<expression>, 'expression');
-}
-
-multi sub find-vars($/, $node) {
- die "Don't know what to do with a $node";
-}
-
-my $c;
-sub unique-register {
- return '$' ~ $c++;
-}
-
-my @sic;
-
-multi sub sicify(Match $/, 'statement') {
- if $<expression> -> $e {
- return sicify($e, 'expression');
- }
-}
-
-multi sub sicify(Match $/, 'expression') {
- for <variable literal declaration assignment binding saycall> -> $subrule {
- if $/{$subrule} -> $e {
- return sicify($e, $subrule);
- }
- }
-}
-
-multi sub sicify(Match $/, 'lvalue') {
- for <variable declaration> -> $subrule {
- if $/{$subrule} -> $e {
- return sicify($e, $subrule);
- }
- }
-}
-
-multi sub sicify(Match $/, 'variable') {
- my $register = unique-register;
- my $variable = "'$/'";
- push @sic, "$register = fetch $variable";
- return ($register, $variable);
-}
-
-multi sub sicify(Match $/, 'literal') {
- my $register = unique-register;
- my $literal = ~$/;
- push @sic, "$register = $literal";
- return ($register, $literal);
-}
-
-multi sub sicify(Match $/, 'declaration') {
- return sicify($<variable>, 'variable');
-}
-
-multi sub sicify(Match $/, 'assignment') {
- my ($register, $) = sicify($<expression>, 'expression');
- my ($, $variable) = sicify($<lvalue>, 'lvalue');
- push @sic, "store $variable, $register";
- return ($register, $variable);
-}
-
-multi sub sicify(Match $/, 'binding') {
- my ($register, $rightvar) = sicify($<expression>, 'expression');
- my ($, $leftvar) = sicify($<lvalue>, 'lvalue');
- if $rightvar ~~ / ^ \d+ $ / { # hm. this is brittle and suboptimal.
- $rightvar = $register;
- }
- push @sic, "bind $leftvar, $rightvar";
- return ($register, $leftvar);
-}
-
-multi sub sicify(Match $/, 'saycall') {
- my ($register, $) = sicify($<expression>, 'expression');
- my $result = unique-register;
- push @sic, "say $register";
- push @sic, "$result = 1";
- return ($result, 1);
-}
-
-multi sub sicify(Match $/, $node) {
- die "Don't know what to do with a $node";
-}
-
-sub declutter(@instructions) {
- my @decluttered;
- for @instructions.kv -> $i, $line {
- if $line !~~ / ^ ('$' \d+) ' =' / {
- push @decluttered, $line;
- }
- else {
- my $varname = ~$0;
- my Bool $usages-later = False;
- for $i+1 ..^ @instructions -> $j {
- ++$usages-later if defined index(@instructions[$j], $varname);
- }
- if $usages-later {
- push @decluttered, $line;
- }
- }
- }
- return @decluttered;
-}
-
-sub renumber(@instructions) {
- my $number = 0;
- my %mapping;
- return @instructions.map: {
- .subst( :global, / ('$' \d+) /, {
- my $varname = ~$0;
- if !%mapping.exists($varname) {
- %mapping{$varname} = '$' ~ $number++;
- }
- %mapping{$varname}
- } );
- };
-}
-
-class Yapsi::Compiler {
- method compile($program) {
- die "Could not parse"
- unless Yapsi::Perl6::Grammar.parse($program);
- %d = ();
- for $<statement> -> $statement {
- find-vars($statement, 'statement');
- }
- $c = 0;
- @sic = '`lexicals: <' ~ (join ' ', %d.keys) ~ '>';
- for $<statement> -> $statement {
- sicify($statement, 'statement');
- }
- @sic = renumber(declutter(@sic));
- return @sic;
- }
-}
-
-class Yapsi::Runtime {
- method run(@sic) {
- my @r;
- my %pad;
- my @containers;
- for @sic {
- when /^ '`lexicals: <' (\S+ ** \s) '>' $ / {
- for $0.comb(/\S+/) -> $var {
- %pad{$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];
- }
- 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];
- }
- else { # immadiate
- @r[+$0] = $thing<value>;
- }
- }
- when /^ 'bind ' \'(<-[']>+)\' ', ' \'(<-[']>+)\' $/ {
- %pad{~$0} = %pad{~$1};
- }
- when /^ 'say $'(\d+) $/ {
- say @r[+$0]
- }
- default { die "Couldn't handle instruction `$_`" }
- }
- }
-}
-
-my Yapsi::Compiler $compiler .= new;
-my Yapsi::Runtime $runtime .= new;
-loop {
- my $program = prompt('> ') // last;
- try {
- my @sic = $compiler.compile($program);
- $runtime.run(@sic);
- }
- say $! if $!;
-}
-say '';
View
55 t/yapsi/parse.t
@@ -1,55 +0,0 @@
-use v6;
-
-use Test;
-plan *;
-
-use Yapsi;
-my Yapsi::Compiler $c .= new;
-
-my @programs-that-parse =
- '',
- ';',
- '42',
- '42;',
- 'my $a',
- 'my $a;',
- 'say 42',
- 'my $a = 42;',
- 'my $a; $a = 42;',
- 'my $a; my $a; my $a',
- 'my $a := 42; my $b = $a;',
- 'my $a; my $b := $a; $a = 42',
- 'my $a; say $a',
-;
-
-for @programs-that-parse -> $program {
- my $can-parse = False;
- try {
- $c.compile($program);
- $can-parse = True;
- }
- ok $can-parse, "will parse '$program'";
-}
-
-my @programs-that-don't-parse = # '
- '$a',
- 'my',
- '$a; my $a',
- 'my $a =',
- '$a = 42',
- '42 = my $a',
- '42 := my $a',
- 'say $a',
- 'say $a; my $a',
-;
-
-for @programs-that-don't-parse -> $program { # '
- my $can-parse = False;
- try {
- $c.compile($program);
- $can-parse = True;
- }
- ok !$can-parse, "will not parse '$program'";
-}
-
-done_testing;
View
230 yapsi-prototype
@@ -1,230 +0,0 @@
-#!/opt/perl/bin/perl -w
-use strict;
-use v5.010;
-
-# The program forms a simple eval-compile-serialize loop. Here are the kinds
-# of programs recognized.
-#
-# ;
-# 42;
-# my $a;
-# my $a = 42;
-# my $a = $a;
-# my $a; my $b;
-# my $a = my $b = 42;
-# my $a; my $a; my $a;
-# my $a := 42; my $b = $a;
-# my $a; my $b := $a; $a = 42;
-
-my $p6program;
-
-{
- use Regexp::Grammars;
-
- $p6program = qr{
- ^ <[Statement]> ** (;) $
-
- <objrule: AST::Statement>
- <Expression> | (?:)
-
- <objrule: AST::Expression>
- <Variable> | <Literal> | <Declaration> | <Assignment> | <Binding>
-
- <objrule: AST::Lvalue>
- <Variable> | <Declaration>
-
- <objrule: AST::Variable>
- \$\w+
-
- <objrule: AST::Literal>
- \d+
-
- <objrule: AST::Declaration>
- my <Variable>
-
- <objrule: AST::Assignment>
- <Lvalue> = <Expression>
-
- <objrule: AST::Binding>
- <Lvalue> := <Expression>
- }xms;
-}
-
-my %d;
-sub findvars {
- my ($node) = @_;
- given (ref($node)) {
- when ('AST::Statement') {
- if (exists $node->{Expression}) {
- findvars($node->{Expression});
- }
- }
- when ('AST::Expression') {
- for my $subrule (<Variable Declaration Assignment Binding>) {
- if (exists $node->{$subrule}) {
- findvars($node->{$subrule});
- }
- }
- }
- when ('AST::Lvalue') {
- for my $subrule (<Variable Declaration>) {
- if (exists $node->{$subrule}) {
- findvars($node->{$subrule});
- }
- }
- }
- when ('AST::Variable') {
- if (!exists $d{ $node->{''} }) {
- die 'Invalid. ', $node->{''}, " not declared before use.\n";
- }
- }
- when ('AST::Declaration') {
- my $name = $node->{Variable}{''};
- if ($d{$name}++) {
- warn "Useless redeclaration of variable $name\n";
- }
- }
- when ('AST::Assignment') {
- findvars($node->{Lvalue});
- findvars($node->{Expression});
- }
- when ('AST::Binding') {
- findvars($node->{Lvalue});
- findvars($node->{Expression});
- }
- default {
- die "Don't know what to do with an ", ref($node);
- }
- }
-}
-
-my $c = 0;
-sub unique_register {
- return '$' . $c++;
-}
-
-my @s;
-sub sicify {
- my ($node) = @_;
- given (ref($node)) {
- when ('AST::Statement') {
- if (exists $node->{Expression}) {
- return sicify($node->{Expression});
- }
- }
- when ('AST::Expression') {
- for my $subrule (<Variable Literal Declaration Assignment Binding>) {
- if (exists $node->{$subrule}) {
- return sicify($node->{$subrule});
- }
- }
- }
- when ('AST::Lvalue') {
- for my $subrule (<Variable Declaration>) {
- if (exists $node->{$subrule}) {
- return sicify($node->{$subrule});
- }
- }
- }
- when ('AST::Variable') {
- my $register = unique_register;
- my $variable = "'" . $node->{''} . "'";
- push @s, "$register = fetch $variable";
- return ($register, $variable);
- }
- when ('AST::Literal') {
- my $register = unique_register;
- my $literal = $node->{''};
- push @s, "$register = $literal";
- return ($register, $literal);
- }
- when ('AST::Declaration') {
- my ($register, $variable) = sicify($node->{Variable});
- return ($register, $variable);
- }
- when ('AST::Assignment') {
- my ($register) = sicify($node->{Expression});
- my (undef, $variable) = sicify($node->{Lvalue});
- push @s, "store $variable, $register";
- return ($register, $variable);
- }
- when ('AST::Binding') {
- my ($register, $rightvar) = sicify($node->{Expression});
- my (undef, $leftvar) = sicify($node->{Lvalue});
- if ($rightvar =~ / ^ \d+ $ /x) {
- $rightvar = $register;
- }
- push @s, "bind $leftvar, $rightvar";
- return ($register, $leftvar);
- }
- default {
- die "Don't know what to do with an ", ref($node);
- }
- }
- return;
-}
-
-sub declutter {
- my ($instructions) = @_;
- my $i = 0;
- while ($i < @$instructions) {
- my $line = $instructions->[$i];
- if ($line =~ / ^ (\$ \d+) \s = /x) {
- my $varname = $1;
- my $usages_later = 0;
- for my $j ($i+1..@$instructions-1) {
- ++$usages_later if index($instructions->[$j], $varname) >= 0;
- }
- if (!$usages_later) {
- splice(@$instructions, $i, 1);
- --$i;
- }
- }
- ++$i;
- }
-}
-
-sub renumber {
- my ($instructions) = @_;
- my $next_number = 0;
- my %mapping;
- for my $line (@$instructions) {
- while ($line =~ / (\$ \d+) /xg) {
- my $varname = $1;
- if (!exists $mapping{$varname}) {
- # '&' rather than '$' to avoid infinite substitution loops
- $mapping{$varname} = '&' . $next_number++;
- }
- $line =~ s[\Q$varname\E][$mapping{$varname}]ge;
- }
- $line =~ s[\&][\$]g;
- }
-}
-
-while (<>) {
- unless (/$p6program/) {
- warn "Doesn't parse.\n";
- next;
- }
-
- %d = ();
- eval {
- for my $statement (@{ $/{Statement} }) {
- findvars($statement);
- }
- };
- if ($@) {
- warn $@;
- next;
- }
- $c = 0;
- @s = ();
- for my $statement (@{ $/{Statement} }) {
- sicify($statement);
- }
- declutter(\@s);
- renumber(\@s);
- for my $s (@s) {
- say "\x09", $s;
- }
-}

0 comments on commit b598605

Please sign in to comment.