gistfile1.6pl

#!/usr/bin/env perl6

module AST {
    class Call {
        has $.callee;

        method new($callee) {
            Call.bless(:$callee);
        }
    }

    class PushNumber {
        has $.value;

        method new($value) {
            PushNumber.bless(:$value);
        }
    }

    class PushString {
        has $.value;

        method new($value) {
            PushString.bless(:$value);
        }
    }

    class PushLambda {
        has $.instructions;

        method new($instructions) {
            PushLambda.bless(:$instructions);
        }
    }
}

module Parse {
    grammar Grammar {
        rule TOP { $<terms>=<term>* }

        token identifier { $<name>=[<identifier1> <identifierN>*] }
        token identifier1 { <-[\s\[\]\"]> }
        token identifierN { <identifier1> | \d }

        token number { $<value>=\d+ }

        token string { \"$<value>=[.*?]\" }

        rule lambda { '[' $<terms>=<term>* ']' }

        rule term { $<term>=[<identifier> | <number> | <string> | <lambda>] }
    }

    class Actions {
        method TOP($/) {
            make $<terms>>>.ast;
        }

        method identifier($/) {
            make AST::Call.new(~$<name>);
        }

        method number($/) {
            make AST::PushNumber.new($<value>.Int);
        }

        method string($/) {
            make AST::PushString.new(~$<value>);
        }

        method lambda($/) {
            make AST::PushLambda.new($<terms>>>.ast);
        }

        method term($/) {
            make $/{*}[0].ast;
        }
    }

    our sub parse(Str $code) {
        Grammar.parse($code, :actions(Actions.new)).ast;
    }
}

my $match = Parse::parse(q:to/END/);
main
def "main" [say μ list 4 yas yas yas yas]
def "μ" [/ $2 [Σ] [#]]
END

my @stack;
my %defs =
    'def' => {
        my $name = pop @stack;
        my $value = pop @stack;
        %defs{$name} = $value;
    },
    'list' => {
        my $n = pop @stack;
        my @result;
        for (1..$n) {
            push @result, pop(@stack);
        }
        push @stack, reverse($@result);
    },
    'say' => { say pop @stack },
    'yas' => { push @stack, get },
    '/' => {
        my $x = pop(@stack);
        my $y = pop(@stack);
        push @stack, $x R/ $y;
    },
    '#' => { push @stack, pop(@stack).elems },
    'Σ' => { push @stack, [+] pop(@stack).list },
    '$2' => {
        my &f = pop @stack;
        my &g = pop @stack;
        my $value = pop @stack;
        push @stack, $value;
        push @stack, &f();
        push @stack, $value;
        push @stack, &g();
    };
sub interpret($code) {
    for reverse(@$code) {
        when AST::Call { my &f = %defs{$_.callee}; &f() }
        when AST::PushNumber { push @stack, $_.value; }
        when AST::PushString { push @stack, $_.value; }
        when AST::PushLambda { push @stack, { interpret($_.instructions) }; }
    }
}
interpret($match);