===============================================================================
                          uCalc LB Forth implementation
                                By Daniel Corbier
                                  www.ucalc.com

The code below is to be loaded into the uCalc Language Builder interpreter, at
which point it becomes an interactive interpreter for the Forth programming
language.  To download the Windows version of the uCalc LB interpreter visit
www.ucalc.com/download.html .
===============================================================================

MainPrompt      = 'ucalc:FORTH> '
MultiLinePrompt = 'ucalc:FORTH>>'
ucVersion       = ucVersion + 'uCalc FORTH. May 2007 (beta)' + \cr + \cr
Print(ucVersion)

Dim x
Dim Forth_Stack As Stack
Dim WordList As Stack
Dim Output As String

RenameItem("Print", "_Print")

uCalc Define Func: ToLong(x) As Long = x
uCalc Define Pattern: ["]+ ~~ Properties: ucReducible

uCalc Prefix 'uCalc Syntax '
   Count         ::= uc_Count(Forth_Stack)
   Read          ::= uc_ReadNum(Forth_Stack, Count)
   Read({index}) ::= uc_ReadNum(Forth_Stack, {index})
   Push({item})  ::= uc_Push(Forth_Stack, ToLong({item}))
   Pop           ::= uc_PopNum(Forth_Stack)
   Pop({index})  ::= uc_PopNum(Forth_Stack, {index})
   
   Print({item}) ::= (Output = Output + {item})
   PrintCR       ::= Print(Chr(13)+Chr(10))

   DEF {word} {'-->'} {equiv} ::= _
      SetInput(\zuCalc Syntax FORTH {word} [{rest:\q .+\q}] _
         ::= {equiv} ::: FORTH {rest}\z)

   FORTH ::= SetInput_(\quCalc Output \q + Output, 1, 1) ::: _
             Output = \q\q ::: _
             Print(\qStack: \q) ::: _
             uc_For(x, 1, Count, 1, Print(ToStr(Read(x)) + \q \q)) ::: _
             SetInput_(\quCalc Output \q + Output, 1, 1) ::: Output = \q\q ::: \q\q
             

   FORTH : {PartialDef:'.*'} ::= SetInput(\q: {PartialDef}  _\q)

   FORTH __STOP ::=
   FORTH : {word:' +[^ ]+'} {def} ; ::= SetInput(\quCalc Syntax FORTH {word} ::= FORTH {def}\q)
   FORTH BEGIN [{x}] ::= SetInput(\qBEGIN {x}  _\q)
   FORTH BEGIN {x} UNTIL ::= uc_Loop(1, FORTH {x} __STOP, Pop == 0) ::: FORTH 
   FORTH BYE ::= Quit
   FORTH DO [{x}] ::= SetInput(\qDO {x}  _\q)
   FORTH DO {x} LOOP ::= uc_For(x, Pop, Pop-1, 1, (FORTH {x} __STOP)) ::: FORTH 
   FORTH IF [{x}] ::= SetInput(\qIF {x}  _\q)
   FORTH IF {x} THEN ::= iif(Pop, (FORTH {x}), 0) ::: FORTH 
   FORTH IF {x} ELSE [{y}] ::= SetInput(\qIF {x} ELSE {y}  _\q)
   FORTH IF {x} ELSE {y} THEN ::= _
       iif(Pop, (FORTH {x}), (FORTH {y})) ::: FORTH 
   FORTH INCLUDE  {filename} ::= SetInput(\quCalc Load \z{filename}\z\q)
   FORTH VARIABLE {varname}  ::= SetInput(\q: {varname} \q + Str(~Eval(uCalc(uc_DataAlloc, \q\q, Long))) + \q ;\q)
uCalc Prefix ''

uCalc Prefix 'DEF '
  {Operator:' +[\+\-\*\/\>\<]'} --> Push(Pop(Count-1) {Operator} Pop)
  {Operator:' +(AND|OR)'}       --> Push(Pop(Count-1) {Operator} Pop)
  {Operator:' +='}              --> Push(Pop(Count-1) == Pop)
  {number:' +-?[0-9]+'}         --> Push({number})
  {comment:' +\( [^)]+\)'}      --> 
  {comment:' +\\.*'}            --> 
  .                             --> Print(ToStr(Pop) + \q \q)
  ." {' '}{text:'[^\"]*'} "     --> Print(\q{text}\q)
  .S      --> uc_For(x, 1, Count, 1, Print(ToStr(Read(x)) + \q \q))
  +!      --> ValueAtAddr(Long, Read) = ValueAtAddr(Long, Pop) + Pop
  !       --> ValueAtAddr(Long, Pop) = Pop
  @       --> Push(ValueAtAddr(Long, Pop))
  -ROT    --> Push(Pop(Count-2)) ::: Push(Pop(Count-2))
  ?DUP    --> iif(Read <> 0, Push(Read), 0)
  /MOD    --> Push(Read(Count-1) mod Read) ::: Push(Pop(Count-2) \ Pop(Count-1))
  0Sp     --> uc_For(x, 1, Count, 1, Pop)
  2DROP   --> Pop ::: Pop
  2DUP    --> Push(Read(Count-1)) ::: Push(Read(Count-1))
  2SWAP   --> Push(Pop(Count-3))  ::: Push(Pop(Count-3))
  2OVER   --> Push(Read(Count-3)) ::: Push(Read(Count-3))
  ABS     --> Push(Abs(Pop))
  C!      --> ValueAtAddr(Byte, Pop) = Pop
  C@      --> Push(ValueAtAddr(Byte, Pop))
  CHAR {' +'}{ch:'.'} --> Push(Asc(\q{ch}\q))
  CR      --> Print(Chr(13)+Chr(10))
  DROP    --> Pop
  DUP     --> Push(Read)
  EMIT    --> Print(Chr(Pop))
  FALSE   --> Push(0)
  I       --> Push(x)
  KEY     --> Push(Asc((ReadConsole(StdIn, _lpText, 5, 0, 0) ::: _LpText)))
  LSHIFT  --> Push(Pop(Count-1) << Pop)
  MAX     --> Push(Max(Pop, Pop))
  MIN     --> Push(Min(Pop, Pop))
  NOT     --> Push(-Abs(Read) == Abs(Pop))
  MOD     --> Push(Pop(Count-1) mod Pop)
  NEGATE  --> Push(-Pop)
  NIP     --> Pop(Count-1)
  OVER    --> Push(Read(Count-1))
  PICK    --> Push(Read(Count-Pop-1))
  ROT     --> Push(Pop(Count-2))
  RSHIFT  --> Push(Pop(Count-1) >>> Pop)
  SPACE   --> Print(\q \q)
  SPACES  --> uc_For(x, 1, Pop, 1, Print(\q \q))
  SWAP    --> Push(Pop(Count-1))
  TRUE    --> Push(-1)
  TUCK    --> Push(Pop(Count-1)) ::: Push(Read(Count-1))
uCalc Prefix ''

uCalc Syntax FORTH {number:' +-?[0-9]+'}{op:'[\+\-\*\/\=\>\<]'} ::= FORTH {number} {op}

uCalc Prefix 'FORTH '
uCalc Define Pattern: [']+ ~~ Properties: ucReducible