#!/usr/local/bin/perl -w

=head1 pforth3.pl  (V0.2.1) - Introduction

For-fun Forth interpreter/compiler in Perl.

See "PForth3 Internals" section below for implementation details,
and a walkthrough of the PForth compilation process.

Features:

 - Subroutine-threaded: The Forth definitions compile directly to
   compiled Perl subroutines.
 - Interactive access to Perl from Forth.
 - Not much else :)  It doesn't actually DO very much, but it was
   a fun hack.

A design goal was to implement the working Forth kernel in a mininal
amount of Perl code, then bootstrap the remainder of the language
in the context of the working interpreter/compiler.
Note that much of this bootstrap code is Perl "assembly code";
but just being able to compile it on the Forth side seemed to me
a worthwhile distinction.

Named pforth3 after two radical changes the in design caused
the pforth and pforth2 files to be abandoned during implementation.  :-)

Known issues & oddities:

 - Not ANS standard (or '83 standard, or '79, or FIG, or...)
 - No C@ C! W@ W!  (could be added)
 - "CELL" is 1     (should be 4 (or 8?) if C@ et al. are added)
 - Strings are scalar objects on the stack (perhaps a feature)
 - "." (dot) prints integers, floats, strings.
 - Integer arithmetic operators also work with floats.
 - Number system uses Perl-builtin conversion, not BASE
 - An empty string (e.g. " ") is not parsed properly :(

The pforth3 (V0.1) kernel was designed, coded and debugged Nov 26, 1999
between 3:00 AM and 6:00 PM.  However, 15 hours was somewhat longer than
expected: It just FEELS like there I<has> to be a way to do this all as
a Perl one-liner. :)
(Also it was my first Forth programming in about ten years, making me
a little rusty on the language internals.  At one point I even called
my dad with questions about CREATE DOES>  =)

And, in the neighborhood of one-liners, here's a fun one for a "Forth-like"
interactive Perl:

   perl -e 'while(<>){eval;print(($@ eq "")? " ok\n" : $@);}'

History:

   BWK 26 Nov 99 -- Created; Bill Kelly <billk@cts.com>
   BWK 28 Nov 99 -- Added documentation and lots more Forth words;
                    bumped version to V0.2.
   BWK  5 Dec 99 -- A few documentation tweaks; added holiday banner;
                    added help listings with sample words;
                    bumped version to V0.2.1.
   BWK 23 Dec 99 -- Added additional documentation.


Std. Disclaimer:

   This software is not copyrighted and is released into the public domain.
   It is hoped it will be useful, but please understand you use it at your own risk.
   THIS SOFTWARE IS PROVIDED "AS IS", WITHOUT ANY EXPRESS OR IMPLIED 
   WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF 
   MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.

=head1 Download PForth

http://tastyspleen.net/~billk/pforth/pforth3.pl

=cut

use strict;
# require LWP::Simple;  # uncomment if you want words like HTTP-GET to work

#
# See "PForth Internals" section below for implementation details.
#

# Language globals
my @DICT;               # The dictionary holds data only, no code or headers
my %HEADERS;            # Headers are, of course, hashed in this implementation ;)
my $STATE = 0;          # FALSE if interpreting, TRUE(-1) if compiling
my $IN = "";            # Line-input buffer (holds only unparsed input)
my @STK;                # Data stack
my @RSTK;               # Return stack (not actually used for return addresses)
my $LATEST = [];        # Ref to header data of most recent definition
my $DEFNUM = 0;         # Definition counter, increments with each definition
my $DEFACCUM = "";      # Perl code accumulates here as forth word is compiled
my $CREATEOPEN = 0;     # Flag telling semicolon to finish up CREATE if no DOES>
my $BYE = 0;            # Outer interpreter (_pforth) exits when true
my $DEBUG = 0;          # Enable debug printouts when true

# Constants
my ($kH_DEFNUM, $kH_BODY, $kH_PREVDEF, $kH_FLAGS) = (0, 1, 2, 3);  # Header struct indicies
my ($kHFLG_NONE, $kHFLG_IMMED, $kHFLG_CONLY, $kHFLG_HIDDEN) = (1, 2, 4, 8);  # Header flag bits

# Perl-side, manually create the one dictionary entry needed to bootstrap the system
_create("PCODE"); _compile('_pcode;'); _compile_semicolon();

# "PForth, compile thyself!"
_pforth();


##############################################################################
# Subroutines
#

=head1 Perl-side Kernel

The following eighteen subroutines comprise the Forth compiler/interpreter,
with which the remainder of the language is compiled on the "Forth side".
(Note that Perl "assembly code" definitions are still allowed on the Forth side,
and indded the majority of the Forth primitives, although compiled on the Forth
side, are implemented using inline Perl statements.)


=head2 _bye ()

Cause exit from outer _pforth interpreter.  (Uses die to throw the exception.)

=cut
    sub _bye {
        $BYE = 1;  # set flag for exit from outer parser
        die;
    }


=head2 _quit (string $msg)

Abort to outer _pforth interpreter, causing parser state to be reset.
(Uses die to throw the exception.)

=cut
    sub _quit {
        my ($msg) = @_;
        die($msg . "<<END>>");  # throw exception to reset parser
    }


=head2 _prompt ()

Ah, the ubiquitous ' ok'.  Suppressed when compiling.

=cut
    sub _prompt {
        # Don't print if compiling
        unless ($STATE) {
            print " ok";
            print ("(", scalar @STK, ")") if (scalar @STK);  # Print stack depth
            print "\n";
        }
    }


=head2 _inputLine ()

Read line of input into $IN, quit program when all input runs out.
Input is reading using <>, so can be either STDIN or from one or more
files if filenames specified on the Perl command line.

=cut
    sub _inputLine {
        my $line;
        _bye unless (defined($line = <>));
        $line =~ tr/\t\n\r\f/ /;  # convert any form of whitespace to space
        $IN .= $line;
    }


=head2 _word (string $delim)

Parse regexp-delimited word from $IN, and advance $IN past what was parsed.

=cut
    sub _word {
        my ($delim) = @_;
        for ( ; ; _prompt, _inputLine ) {
            $IN = $' if ($IN =~ /^($delim)+/);  # gobble leading delimiter
            next unless ($IN =~ /^(.*?)$delim/);  # parse word, or read more input
            $IN = $';  # advance input past parsed token
      print "_word($1) " if $DEBUG; # DEBUG
            return $1;  # return word (not including trailing $delim)
        }
    }


=head2 _create (string $name)

Create new header, store a reference to it in $LATEST.

=cut
    sub _create {
        my ($name) = @_;
      print "_create($name) " if $DEBUG; # DEBUG
        my $prevDef = $HEADERS{$name};
        print "Redefining $name\n" if defined($prevDef);
        $DEFACCUM = "sub _DEF_$DEFNUM {";
        #                           ( $kH_DEFNUM, $kH_BODY, $kH_PREVDEF, $kH_FLAGS )
        $HEADERS{$name} = $LATEST = [ $DEFNUM++, $#DICT + 1, $prevDef, $kHFLG_NONE ];
    }


=head2 _compile (string $pcode)

"Compile" pcode fragment (by appending the string to $DEFACCUM pending eventual
submission to Perl; see _commit).

=cut
    sub _compile {
        my ($pcode) = @_;
      print "_compile($pcode) " if $DEBUG; # DEBUG
        $DEFACCUM .= $pcode;
    }


=head2 _compile_fcall (integer $defnum)

Compile a pcode fragment that will invoke Forth definition numbered $defnum.
(On the Perl side, Forth words become Perl subroutines named for their "definition
number", like: '_DEF_123()'.)

=cut
    sub _compile_fcall {
        my ($defnum) = @_;
        _compile("_DEF_$defnum;");
    }


=head2 _commit (string $pcode)

Commit pcode string to Perl for immediate evaluation.  (The pcode may contain
any Perl code legal in an eval(), including subroutine declarations.)

=cut
    sub _commit {
        my ($pcode) = @_;
     print "_commit($pcode) " if $DEBUG; # DEBUG
        eval($pcode);  # ask Perl to finally compile the definition
        _bye if ($BYE  &&  $@);
        _quit("\nInternal compile error: $@\npcode=($pcode)\n") if ($@);
    }


=head2 _create_builder ()

The CREATE primitive - creates a new header and compiles a pcode fragment for
pushing the dictionary DATA address associated with the new header, onto
the data stack.

The Forth word CREATE operates by essentially building a new Forth word
definition, whose behavior is to simply push a number onto the data stack.
This number is the dictionary DATA address belonging to the new Forth
word (which had been the address of the 'top' of the dictionary, or "HERE"
when the new word was created.)

Forth words which themselves embed calls to CREATE are known as "defining
words", because when these words are executed, their behavior is to
create I<new> Forth words!

The Forth word DOES> builds on this theme by being sortof CREATE's "other half".
DOES> is a way of supplying an additional body of code that these
newly-defined words are to "do" when executed.

That is, CREATE takes the first step of defining a new word and saying,
"at a minimum, you push your data address on the stack when you are executed."
(Sometimes that behavior in itself can be sufficient; so the use of
DOES> is not a requirement.)  But DOES> can add to what was begun by CREATE,
essentially saying, "oh, and in addition to pushing that number on the stack,
you'll also want to call this other code I have provided, here."

Thus, Forth words can define words, which when executed define new words that
do interesting things. :)

=cut
    sub _create_builder {
        _create(_word(' '));
        _compile("_lit($#DICT + 1);");  # Place word's dictionary DATA on stack at runtime (current HERE at compile time)
    }


=head2 _lit (scalar $val)

Push literal value on data stack.  (In PForth, $val is typically an integer, float,
or string constant.)

=cut
    sub _lit {
        my ($val) = @_;
        push(@STK, $val);
    }


=head2 _compile_semicolon ()

The semicolon primitive "wraps up" a colon definition (the Forth word
currently being compiled) and commits its pcode - which had been accumulating
as a string in $DEFACCUM - to Perl for compilation as a new subroutine.

=cut
    sub _compile_semicolon {
        _compile('};');  # Complete Perl subroutine started by _create
        _commit($DEFACCUM);
    }


=head2 _find ($name)

Lookup $name in dictionary - return header-data ref if found, or undef if not found.

=cut
    sub _find {
        my ($name) = @_;
        my $head = $HEADERS{$name};
        # Loop through chronologically linked (newest first) words having same name
        # (i.e. only applies to words that have been redefined), returning first
        # one found that is not HIDDEN.
        while (defined($head)) {
            return $head unless ($$head[$kH_FLAGS] & $kHFLG_HIDDEN);
            $head = $$head[$kH_PREVDEF];
        }
        return undef;
    }


=head2 _number ($str)

Try to convert string into a number, or return undef if not a number.

=cut
    sub _number {
        my ($str) = @_;
      print "_number($str) " if $DEBUG; # DEBUG
        # For now, using Perl built-in - float, dec, oct, or hex; not using BASE
        $str =~ s/^\s*(.*?)\s*$/$1/;  # Strip leading and trailing whitespace
        if ($str =~ /^-?((0+)|([1-9]\d*)|(\d*\.\d+)|(\d+\.\d*))$/) {
            return $str;  # decimal int or float
        }
        elsif ($str =~ /^(0\d+)|(0[xX][a-fA-F\d]+)$/) {
            my $val = oct($str);  # oct or hex int
            return $val;
        }
        else {
            return undef;
        }
    }


=head2 _get_compilable (string $tok, boolean $numOK)

Generate a "compilable" Perl code fragment to call a given Forth word (or to
push a given number on the data stack.)

Lookup token $tok in dictionary (or try to convert it to a number) and return a string
of pcode representing a Perl subroutine call to the word (or if a number, a call
to _lit to push the number on the data stack.)  Or, return undef if token was neither
in the dictionary nor a valid number.  For example:

    _get_compilable("CREATE")  might return "_DEF_7;"      (a call to the eighth word in the Forth dictionary)
    _get_compilable(12345)    should return "_lit(12345);" (code to push the number 12345 onto the data stack)

=cut
    sub _get_compilable {
        my ($tok, $numOK) = @_;
        my $head = _find($tok);
        if (defined($head)) {
            my ($defnum, $flags) = ($$head[$kH_DEFNUM], $$head[$kH_FLAGS]);
            return ("_DEF_$defnum;", $flags);  # pcode to call forth word
        }
        elsif ($numOK) {
            my $val = _number($tok);
            return ("_lit($val);", $kHFLG_NONE) if defined($val);  # pcode to push literal
        }
    
        return (undef, undef);
    }


=head2 _pforth ()

Main loop (see PForth Internals section, below.)

=cut
    sub _pforth {
        # Pull in data section as single string
        my $saveSep = $/;
        undef $/;
        $IN = <DATA>;
        $IN =~ s/\n=\w+.*?\n/\n/gs;  # strip POD commands (handles single lines only)
        $IN =~ tr/\t\n\r\f/ /;  # convert any form of whitespace to space
        $/ = $saveSep;
    
        while (! $BYE) {
            eval {
                my $tok = _word(' ');
                my ($pcode, $flags) = _get_compilable($tok, 1);  # Get pcode to call word or push number
                _quit("$tok not found in dictionary") unless defined($pcode);  # Complain and reset parser if word not recognized
                if ($STATE  &&  !($flags & $kHFLG_IMMED)) {
                    _compile($pcode);  # Accumulate pcode to $DEFACCUM
                }
                else {
                    if (! $STATE  &&  ($flags & $kHFLG_CONLY)) {
                        print "$tok is compile-only\n";
                    }
                    else {
                        _commit($pcode);  # Interpret pcode now!
                    }
                }
            };
            if ($@ ne "") {
                # Exception was thrown - reset parser
                $STATE = 0;
                $CREATEOPEN = 0;
                $IN = "";
                my $msg = $@;
                $msg =~ s/<<END>>.*//s;  # trim extra info appended by Perl
                print ("$msg\n") unless $BYE;
            }
        }
        print "Goodbye.\n";
    }


=head2 _pcode ()

Provides for compilation of Perl "assembler" (code-words) from within PForth.

This Perl-side primitive, appearing in the PForth dictionary as "PCODE",
is the single Forth word to be added "manually" to the Forth dictionary
from the Perl side.  All other Forth words are defined on the "Forth side"
using this PCODE primitive, and the functioning Forth compiler/interpreter.

Usage from within PForth is:

    PCODE MY-NEW-WORD-NAME  $some_perl_stuff = 123;  END-PCODE

=cut
    sub _pcode {
        $STATE = -1;
        my $name = _word(' ');
        _create($name);
        my $pcode = _word("END-PCODE");  # Grab the Perl code as a single string
        _compile($pcode);
        _compile_semicolon;
        $STATE = 0;
    }


=head2 _tick ()

' (apostrophe, referred to as 'tick' in Forth)

Parse a blank-delimited word from the input stream and lookup the word in
the dictionary.  If found, return the pcode fragment to call the word.
If not found, complain and reset PForth parser.

=cut
    sub _tick {
        my $tok = _word(' ');
        my ($pcode, $flags) = _get_compilable($tok, 0);  # Dict words only - disallow number conversion
        _quit(" $tok ?") unless defined($pcode);
        return $pcode;
    }

# That's it on the Perl side!


##############################################################################

=head1 PForth Internals

=head2 Dessert First

To kick things off, here's some Perl code that would be generated
for a simple PForth word!

   PForth=  : qq  1 2 + . ;  ( new word "qq" adds 1+2 and prints result to stdout)
     Perl=  eval "sub _DEF_40 {_lit(1);_lit(2);_DEF_17;_DEF_36;};"

So, PForth words are esentially translated into numbered Perl subroutines,
composed of calls to other such subroutines, and/or embedded primitive Perl code
(such as if() tests, for() loops, or in this case the literal integer
constants 1 and 2 being pushed on the stack.)


=head2 The Interpreter/Compiler

Here's an annotated view of the PForth implementation of the Forth
interpreter/compiler:

PForth uses a pretty standard Forth interpret/compile loop,
the outer logic of which is in _pforth().  The essentials are:

    _word()             # Parse whitespace-delimited token from input stream.
    _get_compilable()   # Try to find token in dictionary; failing that,
                        # try to convert it to a number.
    ..._quit()...       # If _get_compilable wasn't successful, complain and reset parser
    if ($STATE...)      # If compiling ($STATE=true), and the word isn't IMMEDIATE:
        _compile()      # Append get_compilable's generated Perl fragment to $DEFACCUM.
    else                # Else, we are interpreting:
        _commit()       # Send get_compilable's Perl code fragment straight to Perl
                        # for evaluation with an eval().

When PForth is compiling, (i.e., while $STATE is true) Perl code
fragments generated by _get_compilable are appended as strings to $DEFACCUM.
The code is finally submitted to Perl for compilation as a single
subroutine when the end of the Forth definition is reached.

When PForth is interpreting, (i.e. while $STATE is false) Perl code
fragments generated by _get_compilable are sent immediately to Perl
for evaluation.

"Special" Forth words like semicolon or other words flagged IMMEDIATE,
are executed immediately (i.e. interpreted), I<even when PForth is
compiling>.  (PForth is compiling when the variable $STATE is true).

This provides a mechanism for words like semicolon to be able to
"break out" of compile mode, and wrap-up the Forth word definition.
In PForth, semicolon's wrap-up includes appending a closing brace "};"
to $DEFACCUM, completing the Perl subroutine definition "sub _DEF_nn {"
begun by colon (when we started compiling the Forth word.)  Semicolon then
sends the complete $DEFACCUM string to Perl for compilation, via eval().

Here's the Perl code again for "qq" as it would be accumulated to $DEFACCUM
(same as above):

    : qq  1 2 + . ;
    $DEFACCUM eq "sub _DEF_40 {_lit(1);_lit(2);_DEF_17;_DEF_36;};"

The subroutine name _DEF_40 is a unique identifier generated for Perl, using
the current value of the internal variable $DEFNUM.  (The Perl subroutines
arent called by their Forth names directly to avoid possible conflicts with existing
Perl identifiers, and since fewer characters are legal in Perl names than in Forth
names.)

Here's an accounting of the salient interpreter/compiler events occurring as
the Forth word "qq" is being compiled:  (the underscored identifiers are
Perl-side PForth kernel words--the Perl subroutines declared above.)

    : qq  1 2 + . ;
    _word(:) _commit("_DEF_23;")                # ":" is parsed, found in the dictionary, and executed (_commit)
        _word(qq) _create(qq)  Redefining qq    # Colon parses "qq" and creates new header (redefining previous qq)
        $DEFACCUM = "sub _DEF_42 {"             # Colon (_create actually) initiates a new Perl subroutine
        $DEFNUM++                               # Colon (_create actually) advances the global definition counter
        $STATE = -1                             # Colon turns on compile mode
    _word(1) _number(1) _compile("_lit(1);")    # Number 1 is parsed and compiled as a literal value
    _word(2) _number(2) _compile("_lit(2);")    # Number 2 is parsed and compiled as a literal value
    _word(+) _compile("_DEF_17;")               # "+" is parsed, found in dictionary, and compiled
    _word(.) _compile("_DEF_36;")               # "." is parsed, found in dictionary, and compiled
    _word(;) _commit("_DEF_24;")                # ";" is parsed, found, is IMMEDIATE, and so is executed (now)!
        _compile("};")                          # Semicolon finalizes the Perl subroutine initiated by colon (_create)
        _commit("sub _DEF_42 {_lit(1);_lit(2);_DEF_17;_DEF_9;};") # Semicolon submits $DEFACCUM to Perl compiler
        $STATE = 0                              # Semicolon turns off compile mode (back to interpreting!)

That's the interpreter/compiler process in its entirety!  What's left are
a few global data structures, primarily: %HEADERS, @DICT, and $STK.
{Actually - ought to provide some detail on the CREATE DOES> implementation - TO-DO}

=head2 The Dictionary and Stacks

The dictionary and data stack, @DICT and @STK, are simply Perl lists which -
as usual in Perl - are also accessible as arrays.  The @RSTK (return stack)
while available for temporary storage, isn't actually used for return
addresses in PForth (since PForth words become subroutines executed
on the Perl side.)

In PForth, the dictionary contains only data (rather than the interleaved
code, headers, and data traditional of many Forth implementations.)
The dictionary is a heap, a repository for data that grows as information
is appended to it.  It is implemented using a Perl list in PForth,
called @DICT.

Each word defined in PForth receives, when it is created, an
array index value that corresponds to the current "top" of the dictionary
heap.  This index value is referred to as the word's "data address" in
this documentation.  Any data added to the dictionary after a new word
is defined, up until a subsequent word is defined, effectively "belongs"
to the new word.  (The subsequent word, on receipt of the new-current
index of the top of the dictionary, effectively owns all data added
from I<that> point, until the next I<newer> word is defined... and 
so on.)  I<(See the discussion of the _create_builder() primitive
for more detail on how some words use their "data address" indicies.)>

=head2 The Headers

The names of PForth words are stored as keys of a hash called %HEADERS.
Each HEADER key has as its value a four-element data structure, of
"header data".  (The data structure is an array; the HEADER key's value
is a reference to this.)  The elements of the header data are the following:

                     [ $kH_DEFNUM, $kH_BODY, $kH_PREVDEF, $kH_FLAGS ]
    $HEADERS{"qq"} = [         42,        ?,  \[head 40],         0 ]

H_DEFNUM is an integer, and was the value of $DEFNUM when the new word
was created.  The Perl subroutine name associated with this word can be
produced by appending this H_DEFNUM value to the string "_DEF_".
(E.g. _DEF_42)  See: _compile_fcall().

H_BODY is an integer offset into @DICT, and was the "top" of the
dictionary heap when the word was created.  Data for this word, entered by ","
or reserved by ALLOT, starts at this H_BODY offset into @DICT.

H_PREVDEF is usually 'undef', but is otherwise a link back to the header data
of a word that was redefined by (had the same name as) the current word.
Sometimes it can be necessary to be able to find a prior definition of a word
that would otherwise be obscured by a new word of the same name.
This can be the case if the current word is marked HIDDEN: prior definitions
are searched, reverse-chronologically, for one that is not hidden.
(In the case of our latest "qq" definition, _DEF_42, H_PREVDEF will have been
set to reference the header data of _DEF_40, which was our prior "qq" definition.)

H_FLAGS is an integer of flag bits, applicable to this Forth word.
Current flags are:

        $kHFLG_IMMED        ...word is IMMEDIATE
        $kHFLG_CONLY        ...word is COMPILE-ONLY
        $kHFLG_HIDDEN       ...word is HIDDEN (not seen by _find())

=cut


##############################################################################

=head1 Forth-side Code

I<"Now here's the part where the Forth compiles itself."> :)

I apologize for the Forth-side code not being better documented.
If you're already accustomed to Forth, most of the PForth words
here should retain their usual meanings.

=cut

__END__

=head2 Bootstrap and Defining Words

 PCODE IMMEDIATE     $$LATEST[$kH_FLAGS] |= $kHFLG_IMMED;  END-PCODE
 PCODE COMPILE-ONLY  $$LATEST[$kH_FLAGS] |= $kHFLG_CONLY;  END-PCODE
 
 PCODE (  _word('[)]');  END-PCODE IMMEDIATE
 ( Comments available from this point, although not inside PCODE--END-PCODE )
 
 ( Interpret Perl code between p[  ]p )
 PCODE p[
     my $prevState = $STATE;
     $STATE = -1;
     my $pcode = _word('[\135]p');
     _commit($pcode);
     $STATE = $prevState;
 END-PCODE IMMEDIATE
 
 ( Compile Perl code between p{  }p )
 PCODE p{
     my $pcode = _word('[}]p');
     _compile($pcode);
 END-PCODE IMMEDIATE COMPILE-ONLY
 
 ( Create new header, whose runtime pushes its dict-data address. )
 PCODE CREATE
     if ($STATE) {
         _compile('_create_builder;');
         $CREATEOPEN = 1;
     }
     else {
         _create_builder;
         _compile_semicolon;
     }
 END-PCODE IMMEDIATE
 
 ( DOES> wraps-up the currently-compiling word {Perl subroutine} with an instruction
   to compile a call to the upcoming DOES> code, followed by an instruction to
   compile a 'semicolon' -- wrapping up the eventual definition created by
   the defining word now being compiled...  {need better explanation - TO-DO} )
 PCODE DOES>
     _compile("_compile_fcall($DEFNUM);_compile_semicolon;}; sub _DEF_$DEFNUM {");
     $DEFNUM++;
     $CREATEOPEN = 0;
 END-PCODE IMMEDIATE COMPILE-ONLY
 
 ( Hey it's the main Forth word defining word.  :)
 PCODE :
     _create(_word(' '));
     $$LATEST[$kH_FLAGS] |= $kHFLG_HIDDEN;
     $STATE = -1;
 END-PCODE
 
 PCODE ;
     if ($CREATEOPEN) {
         _compile('_compile_semicolon;');
         $CREATEOPEN = 0;
     }
     _compile_semicolon;
     $$LATEST[$kH_FLAGS] &= ~($kHFLG_HIDDEN);
     $STATE = 0;
 END-PCODE IMMEDIATE COMPILE-ONLY
 
 : BYE   ( -- )              p{ _bye; }p ;

=head2 Memory and Stack Words

 : @     ( addr -- val )     p{ $STK[-1] = $DICT[$STK[-1]];              }p ;
 : !     ( val addr -- )     p{ $DICT[$STK[-1]] = $STK[-2];  $#STK -= 2; }p ;
 
 : 2@    ( addr -- v1 v2 )   p{ push(@STK, $DICT[$STK[-1] + 1]);  $STK[-2] = $DICT[$STK[-2]];  }p ;
 : 2!    ( v1 v2 addr -- )   p{ $DICT[$STK[-1]] = $STK[-3];  $DICT[$STK[-1] + 1] = $STK[-2];  $#STK -= 3;  }p ;
 
 : HERE  ( -- addr )         p{ push(@STK, scalar @DICT);       }p ;
 : ALLOT ( num-bytes? -- )   p{ $#DICT += pop(@STK);            }p ;
 : ,     ( val -- )          p{ $DICT[$#DICT + 1] = pop(@STK);  }p ;
 
 : DROP  ( drop -- dro )     p{ pop(@STK);                          }p ;  
 : DUP   ( dup  -- dupp )    p{ push(@STK, $STK[-1]);               }p ;  
 : OVER  ( over -- overe )   p{ push(@STK, $STK[-2]);               }p ;  
 : ROT   ( rot  -- otr )     p{ push(@STK, splice(@STK, -3, 1));    }p ;  
 : -ROT  ( -rot -- -tro )    p{ splice(@STK, -2, 0, pop(@STK));     }p ;  
 : SWAP  ( swap -- swpa )    p{ splice(@STK, -1, 0, pop(@STK));     }p ;  
 : DEPTH ( -- n )            p{ push(@STK, scalar @STK);            }p ;
 
 : 2DUP  ( 2dup -- 2dupup )  OVER OVER ;
 : 2DROP ( 2drop -- 2dr )    DROP DROP ;
 
 : MIN   ( n1 n2 -- nmin )   p{ $STK[-2] = ($STK[-2] < $STK[-1]) ? $STK[-2] : $STK[-1];  pop(@STK);  }p ;
 : MAX   ( n1 n2 -- nmax )   p{ $STK[-2] = ($STK[-2] > $STK[-1]) ? $STK[-2] : $STK[-1];  pop(@STK);  }p ;
 
 : >R    ( n -- )            p{ push(@RSTK, pop(@STK));  }p ;
 : R>    ( -- n )            p{ push(@STK, pop(@RSTK));  }p ;
 : R@    ( -- n )            p{ push(@STK, $RSTK[-1]);   }p ;

=head2 Arithmetic Words

 : +     ( x y -- x+y )      p{ $STK[-2] += $STK[-1];  pop(@STK);   }p ;
 : -     ( x y -- x-y )      p{ $STK[-2] -= $STK[-1];  pop(@STK);   }p ;
 : *     ( x y -- x*y )      p{ $STK[-2] *= $STK[-1];  pop(@STK);   }p ;
 : /     ( x y -- x/y )      p{ $STK[-2] /= $STK[-1];  pop(@STK);   }p ;
 : MOD   ( x y -- x%y )      p{ $STK[-2] %= $STK[-1];  pop(@STK);   }p ;
 : /MOD  ( x y -- x/y x%y )  2DUP / -ROT MOD ;
 
 : =     ( x y -- x==y )     p{ $STK[-2] = ( ($STK[-2] == $STK[-1])? (-1) : (0) );  pop(@STK);  }p ;
 : <>    ( x y -- x!=y )     p{ $STK[-2] = ( ($STK[-2] != $STK[-1])? (-1) : (0) );  pop(@STK);  }p ;
 : >     ( x y -- x>y )      p{ $STK[-2] = ( ($STK[-2] >  $STK[-1])? (-1) : (0) );  pop(@STK);  }p ;
 : <     ( x y -- x>y )      p{ $STK[-2] = ( ($STK[-2] <  $STK[-1])? (-1) : (0) );  pop(@STK);  }p ;
 : >=    ( x y -- x>=y )     p{ $STK[-2] = ( ($STK[-2] >= $STK[-1])? (-1) : (0) );  pop(@STK);  }p ;
 : <=    ( x y -- x<=y )     p{ $STK[-2] = ( ($STK[-2] <= $STK[-1])? (-1) : (0) );  pop(@STK);  }p ;

=head2 String Words

 : $=  ( $x $y -- $x==$y )   p{ $STK[-2] = ( ($STK[-2] eq $STK[-1])? (-1) : (0) );  pop(@STK);  }p ;
 : $<> ( $x $y -- $x!=$y )   p{ $STK[-2] = ( ($STK[-2] ne $STK[-1])? (-1) : (0) );  pop(@STK);  }p ;
 : $>  ( $x $y -- $x>$y )    p{ $STK[-2] = ( ($STK[-2] gt $STK[-1])? (-1) : (0) );  pop(@STK);  }p ;
 : $<  ( $x $y -- $x<$y )    p{ $STK[-2] = ( ($STK[-2] lt $STK[-1])? (-1) : (0) );  pop(@STK);  }p ;
 : $>= ( $x $y -- $x>$y )    p{ $STK[-2] = ( ($STK[-2] ge $STK[-1])? (-1) : (0) );  pop(@STK);  }p ;
 : $<= ( $x $y -- $x<$y )    p{ $STK[-2] = ( ($STK[-2] le $STK[-1])? (-1) : (0) );  pop(@STK);  }p ;
 
 : $+  ( $x $y -- $xy )        p{ $STK[-2] .= $STK[-1];  pop(@STK);  }p ;
 : $-  ( $x ofst len -- $x' )  p{ substr($STK[-3], $STK[-2], $STK[-1]) = "";  $#STK -= 2;  }p ;
 : $C@ ( $x ofst -- char )     p{ $STK[-2] = ord(substr($STK[-2], $STK[-1], 1));  pop(@STK);  }p ;
 : $C! ( char $x ofst -- $x' ) p{ substr($STK[-2], $STK[-1], 1) = chr($STK[-3]);  $STK[-3] = $STK[-2];  $#STK -= 2;  }p ;
 : $@  ( $x ofst len -- $xs )  p{ $STK[-3] = substr($STK[-3], $STK[-2], $STK[-1]);  $#STK -= 2;  }p ;
 : $!  ( $y $x ofst -- $x'y )  p{ substr($STK[-2], $STK[-1], 0, $STK[-3]);  $STK[-3] = $STK[-2];  $#STK -= 2;  }p ;
 : $lc ( $x -- lc$x )          p{ $STK[-1] = lc($STK[-1]) }p ;
 : $UC ( $x -- UC$x )          p{ $STK[-1] = uc($STK[-1]) }p ;
 : $TYPE ( $x ofst len -- )    p{ print(substr($STK[-3], $STK[-2], $STK[-1]));  $#STK -= 3;  }p ;
 : $NREP ( $x ntimes -- $x^n ) p{ $STK[-2] = ($STK[-2] x $STK[-1]);  pop(@STK);  }p ;
 
 : $SUB   ( $x $matchre $subre -- $x' ) p{ my $x; $STK[-3] =~ s{$STK[-2]}{eval '$x="'."$STK[-1]\"";$x}se;   $#STK -= 2;  }p ;
 : $SUBI  ( $x $matchre $subre -- $x' ) p{ my $x; $STK[-3] =~ s{$STK[-2]}{eval '$x="'."$STK[-1]\"";$x}ise;  $#STK -= 2;  }p ;
 : $GSUB  ( $x $matchre $subre -- $x' ) p{ my $x; $STK[-3] =~ s{$STK[-2]}{eval '$x="'."$STK[-1]\"";$x}gse;  $#STK -= 2;  }p ;
 : $GSUBI ( $x $matchre $subre -- $x' ) p{ my $x; $STK[-3] =~ s{$STK[-2]}{eval '$x="'."$STK[-1]\"";$x}gise; $#STK -= 2;  }p ;
 
 : COUNT   ( $x -- $x strlen ) p{ push(@STK, length($STK[-1]));  }p ;
 : COMPARE ( $x $y -- strcmp ) p{ $STK[-2] = ($STK[-2] cmp $STK[-1]);  pop(@STK);  }p ;

=head2 Logical Operator Words

 : NOT     ( x -- bool )       p{ $STK[-1] = ( ($STK[-1])? (0) : (-1) );  }p ;
 : BIT-NOT ( x -- ~x )         p{ $STK[-1] = ~($STK[-1]); }p ;
 : NEGATE  ( x -- -x )         p{ $STK[-1] = -($STK[-1]); }p ;
 : AND     ( x y -- x&y )      p{ $STK[-2] &= $STK[-1];  pop(@STK);  }p ;
 : OR      ( x y -- x|y )      p{ $STK[-2] |= $STK[-1];  pop(@STK);  }p ;
 : XOR     ( x y -- x^y )      p{ $STK[-2] ^= $STK[-1];  pop(@STK);  }p ;
 : ABS     ( x -- |x| )        p{ $STK[-1] = abs($STK[-1]); }p ;
 : WITHIN  ( x lo hi -- bool ) ROT DUP >R SWAP <= SWAP R> SWAP >= AND ;

=head2 Looping and Branching Words

 : [     ( -- )              p{ $STATE = 0;  }p ; IMMEDIATE COMPILE-ONLY
 : ]     ( -- )              p{ $STATE = -1; }p ;
 
 :  COMPILE  ( -- ) p{ my $pcode = _tick; _compile("_compile($pcode);"); }p ; IMMEDIATE COMPILE-ONLY
 : [COMPILE] ( -- ) p{ my $pcode = _tick; _compile($pcode);              }p ; IMMEDIATE COMPILE-ONLY
 
 : [LIT]  ( n -- )  ( -- n ) p{ _compile("_lit(" . pop(@STK) . ");"); }p ; IMMEDIATE COMPILE-ONLY
 
 : IF   ( bool -- ) p{ _compile('if(pop(@STK)){'); }p ; IMMEDIATE COMPILE-ONLY
 : ELSE ( -- )      p{ _compile('}else{');         }p ; IMMEDIATE COMPILE-ONLY
 : THEN ( -- )      p{ _compile('}');              }p ; IMMEDIATE COMPILE-ONLY
 
 : FOR  ( max -- )  p{ _compile('{my ($__i, $__max) = (0, pop(@STK)); for ( ; $__i < $__max; $__i++){'); }p ; IMMEDIATE COMPILE-ONLY
 : NEXT ( -- )      p{ _compile('}}');                   }p ; IMMEDIATE COMPILE-ONLY
 : LEAVE ( -- )     p{ _compile('last;');                }p ; IMMEDIATE COMPILE-ONLY
 : I    ( -- )      p{ _compile('push(@STK, $__i);');    }p ; IMMEDIATE COMPILE-ONLY
 
 : BEGIN ( -- )     p{ _compile('for(;;){');             }p ; IMMEDIATE COMPILE-ONLY
 : AGAIN ( -- )     p{ _compile('}');                    }p ; IMMEDIATE COMPILE-ONLY
 : UNTIL ( bool-- ) p{ _compile('last if(pop(@STK));}'); }p ; IMMEDIATE COMPILE-ONLY
 : WHILE ( bool-- ) p{ _compile('last unless(pop(@STK));'); }p ; IMMEDIATE COMPILE-ONLY
 : REPEAT ( -- )    p{ _compile('}');                    }p ; IMMEDIATE COMPILE-ONLY
 
 : EXIT ( -- )      p{ _compile('return;');              }p ; IMMEDIATE COMPILE-ONLY

=head2 ...and The Rest!

 : 1+ ( n -- n' )   1 + ;
 : 1- ( n -- n' )   1 - ;
 : 2+ ( n -- n' )   2 + ;
 : 2- ( n -- n' )   2 - ;
 : 2* ( n -- n' )   2 * ;
 : 2/ ( n -- n' )   2 / ;
 : 0= ( x -- x==0 ) 0 = ;
 
 : " ( -- string-scalar )
  p{ my $str = _word('"');
     if ($STATE) {
         _compile("_lit(q\"$str\");");
     }
     else {
         push(@STK, $str);
     } }p
 ; IMMEDIATE
 
 : WORD ( ascii-delim-charval -- string-scalar )
  p{ my $asc = chr(pop(@STK));
     my $str = _word("\\$asc");
     push(@STK, $str); }p
 ;
 
 : $WORD ( string-regexp-scalar -- string-scalar )
  p{ my $str = _word(pop(@STK));
     push(@STK, $str); }p
 ;
 
 ( Whee some pure Forth! )
 : VARIABLE ( -- )      ( -- addr ) CREATE 0 , ;
 : CONSTANT ( val -- )  ( -- val )  CREATE , DOES> @ ;
 
 : 2VARIABLE ( -- )        ( -- addr )  CREATE 0 , 0 , ;
 : 2CONSTANT ( n1 n2 -- )  ( -- n1 n2 ) CREATE SWAP , , DOES> 2@ ;
 
  -1 CONSTANT TRUE
   0 CONSTANT FALSE
 
   1 CONSTANT CELL
 : CELL+ ( n -- n+cell ) CELL + ;
 : CELLS ( n -- n*cell ) CELL * ;
 
 ( List words in order defined by sorting by their defnum, which was incremented with
   each definition.  Headerless definitions are listed by their Perl function names. )
 : WORDS ( -- )
  p{ my @chronSort;
     my ($name, $head);
     while (($name, $head) = each %HEADERS) {
         my $defnum = $$head[$kH_DEFNUM];
         $chronSort[$defnum] = $name;
     }
     my $idx = $DEFNUM - 1;
     for ( ; $idx >= 0; $idx--) {
         $name = $chronSort[$idx];
         print ((defined($name)? "$name " : "{_DEF_$idx} "));
     } }p
 ;
 
 : STATE@ ( -- bool ) p{ push(@STK, $STATE);  }p ;
 : STATE! ( bool -- ) p{ $STATE = pop(@STK);  }p ;
 
 : RANDOM ( range -- rnd ) p{ $STK[-1] = abs(rand($STK[-1])); }p ;
 
  32 CONSTANT BL
  10 CONSTANT LF
 
 : ASCII  ( -- charval )   BL WORD 0 $C@  STATE@ IF  [COMPILE] [LIT]  THEN ; IMMEDIATE
 : EMIT   ( charval -- )   p{ print chr(pop(@STK));   }p ;
 : .      ( val -- )       p{ print (pop(@STK), " "); }p ;
 : .hex   ( val -- )       p{ printf ("%x ", pop(@STK)); }p ;
 : .s     ( -- )           p{ print ((scalar @STK) ? "\n@STK " : "empty");  }p ;
 : CR     ( -- )    LF EMIT ;
 : SPACE  ( -- )    BL EMIT ;
 : SPACES ( n -- )  FOR  SPACE  NEXT ;
 
 ( Anonymous compile-execute - hack to make IF THEN FOR NEXT etc. available more interactively.
   Should make the control structure words state smart instead.. )
 : [[ ( -- )  p{ $DEFACCUM = ""; $STATE = -1; }p ;
 : ]] ( -- )  p{ $STATE = 0; _commit($DEFACCUM); }p ; IMMEDIATE COMPILE-ONLY
 
 ( Print some info about the internal state )
 : .vars ( -- )
  p{ print "HERE         ", scalar @DICT, "\n";
     print "DEFNUM       ", $DEFNUM, "\n";
     print "DEFACCUM     ", "($DEFACCUM)", "\n";
     print "CREATEOPEN   ", $CREATEOPEN, "\n";
     print "STATE        ", $STATE, "\n";
     print "DEBUG        ", $DEBUG, "\n"; }p
 ;
 
 : DEBUG! ( bool -- ) p{ $DEBUG = pop(@STK);  }p ;   ( Enable/disable debug output )

 ( ========================================================================= )

=head2 Simple Web-access Words (uncomment require LWP::Simple at top of file)

 : HTTP-GET ( $url -- $data )
  p{ my $url = pop(@STK);
     my $doc = LWP::Simple::get($url);
     push(@STK, $doc);  }p
 ;
 
 : "" ( -- $null) p{ push(@STK, ""); }p ;  ( ack - KLUDGE/FIXME - " " is not currently parseable )
 
 : $FOLD-SPACES ( $x -- $x' ) " [ \t][ \t]+"  "  " $GSUB ;
 
 : $STRIP-HTML ( $html -- $text )
     " .*<\s*/HEAD\s*>"  "" $GSUBI  ( remove html header )
     " <.*?>" "" $GSUB               ( strip html tags )
     " [\s\r\n]+[\r\n]"  " \n" $GSUB  ( zap blank lines )
     $FOLD-SPACES ;
 
 ( Some fun web-search [almost]one-liners :)
 
 ( " http://britannica.com/cgi-bin/dictionary?va="  CONSTANT DictURLBase )
 " http://www.dictionary.com/cgi-bin/dict.pl?term=" CONSTANT DictURLBase
 " http://tesla.csuhayward.edu/cgi-bin/speak.cgi"   CONSTANT BabbleURL
 
 : GetDictURL ( searchword$ -- url$ ) DictURLBase SWAP $+ ;
 
 ( Lookup term [from stdin] in web dictionary, print result to stdout )
 : LOOKUP ( -- ) BL WORD $lc GetDictURL DUP . HTTP-GET CR
                 " .*<!--\s*resultListStart\s*-->"  "" $GSUBI
                 " <!--\s*resultListEnd\s*-->.*"  "" $GSUBI  $STRIP-HTML . ;
 
 ( Gets & prints random technomanagerial buzzwordspeak, like:
     "Look, that's just one cog in a very big wheel. We all have to turn the crank
      and set up weekly meetings on the total quality." )
 : BABBLE ( -- ) BabbleURL DUP . HTTP-GET CR
                 " .*<\s*P(>|\s+.*?>)"  "" $GSUBI $STRIP-HTML . ;
 
 ( ========================================================================= )

=head2 Tree Banner

 CR
 " ============================================================" . CR
 
 ( Print holiday banner )
 
 2VARIABLE banStr       ( Stores banner string and strlen )
 40 CONSTANT centerCol  ( Column about which to center banner )
 
 : .banChar ( idx -- idx )  DUP banStr 2@ ROT SWAP MOD $C@ EMIT ;
 : .banSpan ( idx count -- idx' )  FOR  .banChar 1+  NEXT ;
 : .banSpanCtr ( idx count -- idx' ) centerCol OVER 2/ - SPACES  .banSpan ;
 : .banTriCtr ( idx basewidth -- idx' )  2/ 1+ FOR  I 2* 1+ .banSpanCtr CR  NEXT ;
 : .banRectCtr ( idx wid hgt -- idx' ) SWAP >R FOR  R@ .banSpanCtr CR  NEXT R> DROP ;
 
 ( Draw tree - size is scaling factor for tree )
 : .ban ( $banstr size -- )
     SWAP COUNT banStr 2!
     ( size ) 1 MAX  centerCol MIN  0
     ( size idx ) OVER .banTriCtr  ( draw tree )
     ( size idx ) OVER DUP 8 / 1 MAX      SWAP 6 / 1 MAX .banRectCtr  ( draw trunk )
     ( size idx ) OVER DUP 8 / 1 MAX 3 *  SWAP 8 / 1 MAX .banRectCtr  ( draw base )
     2DROP ;
 
 : .ground ( -- ) " _,-^-._,-^-._,-^-._,-^-._,-^-._,-^-._,-^-._,-^-._,-^-._,-^-." . CR ;
 
 : DOBAN ( -- ) CR " *<+>happy*holiday*greetings*from*pforth3*and*billk@cts.com" 32 .ban .ground ;
 
 DOBAN
 ( " ...READY...READY...READY..." .  ( Uh, like the Boskonian comm-relay on the planet Zabriska =)


 ( ========================================================================= )

=head2 Help Words

 CR
 " ============================================================" . CR
 " PForth   (WORDS for known words; BYE to exit; HELP for help)" . CR
 " ------------------------------------------------------------" . CR

 : HELP ( -- )  CR
     " PForth" . CR
     " -" 60 $NREP . CR
     " WORDS         List all words in dictionary" . CR
     " HELP          This help text" . CR
     " BYE           Exit PForth" . CR
     CR
     " : xx  ...  ;  Define new Forth word called 'xx'" . CR
     "               E.g.  : xx  ASCII a 26 RANDOM + ;" . CR
     "                     : yy  IF xx 32 - EMIT THEN 8 RANDOM 1+ FOR xx EMIT NEXT ;" . CR
     "                     : zz  20 RANDOM 5 + FOR SPACE I 0= yy NEXT ASCII . EMIT ;" . CR
     "                     : aa  SPACE 5 RANDOM 2+ FOR zz SPACE NEXT CR CR ;" . CR
     "               Try: aa aa aa aa  ( return )" . CR
     CR
     " p{  ...  }p   Compile Perl code between p{ }p" . CR
     "               E.g.  : q3 p{ print(`finger johnc\@idsoftware.com`); }p ;" . CR
     "               Try: q3  ( return - NOTE, assumes internet connection )" . CR
     CR
     " p[  ...  ]p   Interpret Perl code between p[ ]p" . CR
     "               Try: p[ print scalar localtime; ]p  ( return )" . CR
     "               (" .   p{ print scalar localtime; }p "  )" . CR
     CR CR
     " HELP2 for next page..." . CR
     " -" 60 $NREP . CR
 ;
 
 ( Define HELP sample words so the 'Try:' examples work )

 : help ( -- ) " (PForth is case-sensitive; try HELP in all-caps)" . CR ;
 
 : q3 ( -- ) p{ print(`finger johnc\@idsoftware.com`); }p ;
 
 : xx ( -- charval ) ASCII a 26 RANDOM + ;
 : yy ( initial-cap-flag -- ) IF xx 32 - EMIT THEN 8 RANDOM 1+ FOR xx EMIT NEXT ;
 : zz ( -- ) 20 RANDOM 5 + FOR SPACE I 0= yy NEXT ASCII . EMIT ;
 : aa ( -- ) SPACE 5 RANDOM 2+ FOR zz SPACE NEXT CR CR ;
 
 ( End - HELP sample words )
 
 : HELP2 ( -- )  CR
     " PForth" . CR
     " -" 60 $NREP . CR
     " .ban          Draws ''tree'' banner, given banner string and tree size." . CR
     "               Try: " . ASCII " EMIT "  !hi" 0 4 $TYPE ASCII " EMIT "  35 .ban  ( return - giant size ) " . CR
     "                    " . ASCII " EMIT "  +*"  0 3 $TYPE ASCII " EMIT "    8 .ban  ( return - tiny size ) " . CR
     " DOBAN         Displays the tree banner seen when PForth loads." . CR 
     CR
     " Here's a cute word to try:" . CR
     CR
     "     : mystery ( n -- ) 1 MAX 39 MIN DUP >R 2* 1+" . CR
     "             FOR R@ I - ABS DUP *  R@ 2* 1+" . CR
     "               FOR  R@ I - ABS DUP * OVER +" . CR
     "                 R@ 1- DUP *  R@ DUP * WITHIN" . CR
     "                 IF ASCII * ELSE BL THEN EMIT" . CR
     "               NEXT CR DROP" . CR
     "             NEXT R> DROP ;" . CR
     CR
     "   Your shell may allow copying and pasting the mystery word into" . CR
     "   PForth.  Or if typing it, it's OK to put it all on one line," . CR
     "   provided spaces are preserved between words.  When trying it," . CR
     "   supply one integer between 1..39 - like:   15 mystery" . CR
     "   or   25 mystery   etc." . CR
     CR CR
     " HELP3 for next page..." . CR
     " -" 60 $NREP . CR
 ;
 
 : HELP3 ( -- )  CR
     " PForth" . CR
     " -" 60 $NREP . CR
     " LOOKUP        Requests the definition of a word from an internet" . CR
     "               dictionary (www.dictionary.com) and displays the result." . CR 
     "               Try: LOOKUP spleen ( return - NOTE, assumes internet connection )" . CR 
     " BABBLE        Requests Dilbertesque managerial babblespeak from the web" . CR
     "               and displays the result." . CR 
     "               Try: BABBLE ( return - NOTE, assumes internet connection )" . CR 
     " -" 60 $NREP . CR
 ;
 
 
 ( eof )

=head1 Run PForth with: perl -w pforth3.pl

