http://www.perlmonks.org?node_id=766784

A discussion of Forth in the CB today led me to wondering how much effort would be required to implement a rudimentary Forth interpreter in Perl. The answer is: about an hours worth.

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]; }

Note that there is very little error checking. In particular there is essentially no checking for stack underflow!

Adding a few more primitive words would make many things easier and there is important stuff just plain missing. However, there is enough in that primitive kernel to make quite a start along to road to conquering the world. Now to write an Ook! interpreter using it. ;)


True laziness is hard work