use strict;
use warnings;

my %dictionary = (
    '.' => \&doDot,
    '."' => \&doDotQuote,
    '+' => \&doAdd,
    '-' => \&doSub,
    '*' => \&doMul,
    '/' => \&doDiv,
    ':' => \&doDefine,
    '(' => \&doComment,
    'CR' => \&doCR,
    'DUP' => \&doDup,
    'DROP' => \&doDrop,
    '?BRANCH' => \&doFBranch,
    'BRANCH' => \&doBranch,
    'EMIT' => \&doEmit,
    );
my @stack;
my @rstack;
my $line;
my @words;
my $state = '';

while (defined (my $word = fetchWord ())) {
    
    next if dispatch ($word, \$state);
    
    if ($word !~ /^[+-]?\d+\.?\d*([eE][+-]?\d+)?$/) {
        print "I don't understand '$word' in line: $line\n";
        @words = ();
        next;
    }
    
    push @stack, $word;
}


sub fetchWord {
    while (! @words) {
        $line = <>;
        chomp $line;
        @words = split /\s+/, $line;
    }
    
    return shift @words;
}


sub dispatch {
    my ($word, $state) = @_;
    
    if ($$state eq 'quoting') {
        if ($word eq '"') {
            $$state = '';
            return 1;
        }

        $stack[-1] = join ' ', grep {defined} ($stack[-1], $word);
        return 1;
    }

    if ($$state eq 'comment') {
        $$state = '' if $word eq ')';
        return 1;
    }
    
    if ($$state eq 'new') {
        push @stack, $word;
        push @stack, undef;

        $$state = 'defining';
        return 1;
    }

    if ($$state eq 'defining') {
        if ($word eq ';') {
            my $code = pop @stack;
            my $word = pop @stack;
            
            $dictionary{$word} = $code;
            $$state = '';
            return 1;
        }

        $stack[-1] = join ' ', grep {defined} ($stack[-1], $word);
        return 1;
    }

    if ($$state =~ /^\d+/) {
        # Skipping for branch
        $$state = '' if ! --$$state;
        return 1;
    }

    return undef if ! exists $dictionary{$word};

    if (ref $dictionary{$word}) {
        $dictionary{$word}->($state);
        return 1;
    }
    
    my @words = split /\s+/, $dictionary{$word};
    
    while (@words) {
        return 0 if ! dispatch (shift @words, $state);
    }
    
    return 1;
}


sub doDot {
    print pop @stack;
}


sub doDotQuote {
    push @stack, undef;
    ${$_[0]} = 'quoting';
}


sub doAdd {
    return (pop @stack) + (pop @stack);
}


sub doSub {
    my $rh = pop @stack;
    my $lh = pop @stack;
    
    return $lh - $rh;
}


sub doMul {
    return (pop @stack) * (pop @stack);
}


sub doDiv {
    my $rh = pop @stack;
    my $lh = pop @stack;
    
    return $lh / $rh;
}


sub doDefine {
    ${$_[0]} = 'new';
}


sub doComment {
    ${$_[0]} = 'comment';
}


sub doCR {
    print "\n";
}


sub doDup {
    push @stack, $stack[-1] if @stack
}


sub doDrop {
    pop @stack;
}


sub doFBranch {
    my $skip = pop @stack;
    my $test = pop @stack;
    
    ${$_[0]} = $skip if ! $test;
}


sub doBranch {
    ${$_[0]} = pop @stack;
}


sub doEmit {
    print chr $_[0];
}
[download]