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 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.
http://tastyspleen.net/~billk/pforth/pforth3.pl
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.)
Cause exit from outer _pforth interpreter. (Uses die to throw the exception.)
Abort to outer _pforth interpreter, causing parser state to be reset. (Uses die to throw the exception.)
Ah, the ubiquitous ' ok'. Suppressed when compiling.
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.
Parse regexp-delimited word from $IN, and advance $IN past what was parsed.
Create new header, store a reference to it in $LATEST.
``Compile'' pcode fragment (by appending the string to $DEFACCUM pending eventual submission to Perl; see _commit).
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()'.)
Commit pcode string to Perl for immediate evaluation. (The pcode may contain any Perl code legal in an eval(), including subroutine declarations.)
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 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. :)
Push literal value on data stack. (In PForth, $val is typically an integer, float, or string constant.)
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.
Lookup $name in dictionary - return header-data ref if found, or undef if not found.
Try to convert string into a number, or return undef if not a number.
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)
Main loop (see PForth Internals section, below.)
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
' (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.
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.)
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), 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}
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 that point, until the next newer word is defined... and so on.) (See the discussion of the _create_builder() primitive for more detail on how some words use their ``data address'' indicies.)
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())
``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.
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 ;
: @ ( 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 ;
: + ( 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 ;
: $= ( $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 ;
: 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 ;
: [ ( -- ) 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
: 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 )
( ========================================================================= )
: 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 . ;
( ========================================================================= )
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 =)
( ========================================================================= )
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 )