(       Title:  Extra Stack Basic and Defining Words
         File:  xstacks.fs
       Author:  David N. Williams
      License:  LGPL
      Version:  0.6.6
Last revision:  October 25, 2009
)
\ Copyright (C) 1996, 2001, 2002, 2004, 2006, 2009 by David N. Williams
(
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or at your option any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU Lesser General Public License for more details.

Please see the file POLITENESS included with this distribution.

This Forth code is written for ANS Forth, up to case sensitivity
and [UNDEFINED].  The current pfe version, which uses more
efficient C primitives, is in the file xstacks-pfe.fs.
)

decimal

(
The following KLUDGE is for the purpose of testing the pfe
implementation of the words in the BASIC XSTACK WORDS section.
)
  [UNDEFINED] PFE [IF] false constant PFE [THEN]

\ *** WORDS
(
  xstack structure:
  >XS-PTR  >XS-PTR0  >XS-BREAK  MAKE-XSTACK

  basic xstack words:
  >X  @>X  X>  X>!  X@  XDROP  XDUP  XOVER  XSWAP
  2>X  2X>  2X@  2@>X  2X>!  X2DROP  X2DUP  X2OVER  X2SWAP
  XDEPTH  XSP!  XSP0!  XSP@

  xstack defining words:
  >X:  @>X:  X>:  X>!:  X@:  XDROP:  XDUP:  XOVER:  XSWAP:
  2>X:  2X>:  2X@:  2@>X:  2X>!:  X2DROP:  X2DUP:  X2OVER:  X2SWAP:
  XDEPTH:  XSP!:  XSP0!:  XSP@:
)

\ *** PLAINSTRUCT

[DEFINED] +field [IF]
  : +field  ( offset size -- offset+size )    \ 200x
    create over , +
  DOES>  ( struc -- struc+offset )  @ + ;
[THEN]

\ *** XSTACK STRUCTURE
(
In stack comments, "xstack" is the address of an instance of the
following xstack structure.
)
  0               \ in lieu of STRUCT
  1 cells +field >xs-ptr
  1 cells +field >xs-ptr0
  1 cells +field >xs-break
  ( offset) drop  \ in lieu of /STRUCT:

: make-xstack  ( #cells -- xstack )
(
Make and initialize an xstack instance with a capacity of #cells
entries, and leave its address.
)
  ( #cells) cells ( /xstack.data)
  align here ( xstack) >r
  r@ >xs-break over + dup
  ( xstack.ptr) , ( xstack.ptr0) ,
  ( /xstack.data) allot   r> ( xstack) ;

PFE 0= [IF]
\ *** BASIC XSTACK WORDS
(
Example syntax:

  20 cells make-xstack constant my-xstack
  3 my-xstack >x   \ mystack: 3
  my-xstack x@     \ mstack: 3 s: 3
  my-xstack xdepth \ s: 3 1

Xstack overflow and underflow are checked in this code only when
the number of items is increased or decreased.  Thus, for
example, MY-XSTACK X@ when the xstack is empty fetches an
invalid result with no warning.
)

: >x  ( n xstack -- x: n )
(
Drop n from the data stack and push it onto the xstack.  
)
  dup >xs-ptr >r >xs-break r@ @
  = ABORT" ***xstack overflow"
  [ -1 cells ] literal r@ +!
  r> @ ! ;

: x>  ( x: n s: xstack -- n  )
(
Drop n from the xstack and leave it on the data stack.
)
  dup >xs-ptr >r >xs-ptr0 @ r@ @  
  = ABORT" *** xstack underflow"
  r@ @ @
  [ 1 cells ] literal r> +! ;

: xdrop  ( x: s: xstack -- )
  dup >xs-ptr >r >xs-ptr0 @ r@ @  
  = ABORT" *** xstack underflow"
  [ 1 cells ] literal r> +! ;

: x@    ( xstack x: n -- n s: n )   >xs-ptr @ @ ;
: @>x   ( addr xstack -- x: a )     swap @ swap >x ;
: x>!   ( xstack -- x: a )          x> swap ! ;
: xdup  ( xstack x: n -- n n )      dup x@ swap >x ;
: xover ( xstack x: a b -- a b a )  dup >xs-ptr @ cell+ @ swap >x ;

: xswap ( xstack x: a b -- b a )
  >xs-ptr @ ( &x0) dup cell+ ( &x1) >r
  ( &x0) dup @ r@ @ ( b a) swap r> ( &x1) ! swap ( a &x0) ! ;

: xdepth  ( xstack -- depth )
  dup >xs-ptr0 @ swap >xs-ptr @ - [ 1 cells ] literal / ;

: xsp!   ( addr xstack -- )  >xs-ptr ! ;
: xsp0!  ( xstack -- )       dup >xs-ptr0 @ swap >xs-ptr ! ;
: xsp@  ( xstack -- addr )   >xs-ptr @ ;

: 2>x  ( a b xstack -- x: a b )
  dup >xs-ptr >r
  [ -2 cells ] literal r@ +!
  >xs-break r@ @
  u> ABORT" ***xstack overflow"
  r> @ 2! ;

: 2x>  ( xstack x: a b -- s: a b)
  dup >xs-ptr ( xsp) >r
  >xs-ptr0 @ r@ @ [ 2 cells ] literal +
  ( xsp0 xsp+2cells) u< ABORT" *** xstack underflow"
  r@ @ 2@ [ 2 cells ] literal r> +! ;
 
: 2x@   ( xstack x: a b -- a b s: a b )  >xs-ptr @ 2@ ;
: 2@>x  ( addr xstack -- x: a b )        >r 2@ r> 2>x ;
: 2x>!	( addr xstack x: a b -- )        2x> rot 2! ;

: x2drop  ( xstack x: a b -- )  
  dup >xs-ptr >r >xs-ptr0 @
  [ 2 cells ] literal r@ +!
  r> @ u< ABORT" *** xstack underflow" ;

: x2dup	 ( xstack x: a b -- a b a b )  dup 2x@ rot 2>x ;

: x2over  ( xstack x: a b c d -- a b c d a b )
  dup >xs-ptr @ [ 2 cells ] literal + 2@ rot 2>x ;

: x2swap  ( xstack x: a b c d -- c d a b )
  >xs-ptr @ ( &x0) dup [ 2 cells ] literal + ( &x3) >r
  ( &x0) dup 2@ r@ 2@ ( c d a b) 2swap r> ( &x3) 2!
  rot ( a b &x0) 2! ;
[THEN] \ PFE 0=

\ *** XSTACK DEFINING WORDS
(
The basic xstack words in the preceding section are already
functional, and pretty much as fast as xstack words made with
the defining words in this section.  They are included for
compatibility with the more efficient pfe implementation, and so
that we can also use some of the pfe tests to test the basic
words.  If you need any of them, just uncomment or copy and
paste.

For example, we need them to test the basic xstack words, those
implemented above, and their pfe versions.

See the file xstack-test.fs for sample usage of these defining
words and words they define.
)

[UNDEFINED] XSTACK-DEFINING-WORDS
[IF] false constant XSTACK-DEFINING-WORDS [THEN]

XSTACK-DEFINING-WORDS [IF]  \ DEFINING WORDS
: >x:  ( "name" xstack -- )
(
Define a word that pops an item off of the data stack and pushes
it onto the xstack.
)
  create ( xstack) , 
DOES>  ( n -- x: n )  @ >x ;
  
: x>:  ( "name" xstack -- )
(
Define a word that pops an item off of the xstack and pushes it
onto the data stack.
)
  create ( xstack) ,
DOES>  ( x: n -- s: n )  @ x> ;

: x@:  ( "name" xstack -- )
(
Define a word that leaves a copy of the top xstack item on the
data stack.
)
  create ,
DOES>  ( x: n -- n s: n )  @ x@ ;

: @>x:  ( "name" xstack -- )
(
Define a word that fetches a cell from memory and pushes it onto
the xstack.
)
  create ,
DOES>  ( addr -- x: n )  @ @>x ;

: x>!:  ( "name" xstack -- )
(
Define a word that pops a cell from the xstack and stores it
into the addr on the data stack.
)
  create ,
DOES>  ( addr x: n -- )  @ x>! ;

: xdrop:  ( "name" xstack -- )
(
Define a word that drops the top of the xstack.
)
  create ,
DOES>  ( x: n -- ) @ xdrop ;  

: xdup:  ( "name" xstack -- )
(
Define a word that DUPs the top of the xstack.
)
  create ,
DOES>  ( x: a -- a a )  @ xdup ;

: xover:  ( "name" xstack -- )
(
Define a word that does OVER on the xstack.
)
  create ,
DOES>  ( -- )  ( x: a b -- a b a )  @ xover ;

: xswap:  ( "name" xstack -- )
(
Define a word that SWAPs the top two cells of the xstack.
)
  create ,
DOES>  ( x: a b -- b a )  @ xswap ;

: xdepth:  ( "name" xstack -- )
(
Define a word that leaves the depth of the xstack.
)
  create ,
DOES> ( -- depth )  @ xdepth ;

: xsp!:  ( "name" xstack -- )
(
Define a word that sets the xstack pointer to addr.
)
  create ,
DOES>  ( addr -- )  @ xsp! ;

: xsp0!:  ( "name" xstack -- )
(
Define a word that clears the xstack.
)
  create ,
DOES>  ( -- )  @ xsp0! ;

: xsp@:  ( "name" xstack -- )
(
Define a word that leaves the xstack pointer.
)
  create ,
DOES>  ( -- addr )  @ xsp@ ;

: 2>x:  ( "name" xstack -- )
(
Define a word that pops 2 cells off the data stack and pushes
them onto the xstack.
)
  create ,
DOES>  ( a b -- x: a b )  @ 2>x ;

: 2x>:  ( "name" xstack -- )
(
Define a word that pops two cells off the xstack and pushes them
onto the data stack.
)
  create ,
DOES>  ( x: a b -- s: a b )  @ 2x> ;

: 2x@:  ( "name" xstack -- )
(
Define a word that leaves a copy of the top two cells of the
xstack on the data stack.
)
 create ,
DOES>  ( x: a b  -- a b s: a b )  @ 2x@ ;

: 2@>x:  ( "name" xstack -- )
(
Define a word that fetches b from addr and a from the cell
following addr, and leaves them on the xstack with b on top. 
This agrees with the ANS Forth standard for cell-pair types and
double-cell integers.
)
  create ,
DOES>  ( addr -- x: a b )  @ 2@>x ;

: 2x>!:  ( "name" xstack -- )
(
Define a word that stores b at addr and a at the cell following
addr.  This agrees with the ANS Forth standard for cell-pair
types and double-cell integers.
)
  create ,
DOES>  ( addr x: a b -- )  @ 2x>! ;

: x2drop:  ( "name" xstack -- )
(
Define a word that 2DROP's the top of the xstack.
)
  create ,
DOES>  ( x: a b -- )  @ x2drop ;

: x2dup:  ( "name" xstack -- )
(
Define a word does 2DUP on the xstack.
)
  create ,
DOES>  ( x: a b -- a b a b )  @ x2dup ;

: x2over:  ( "name" xstack -- )
(
Define a word that does 2OVER on the xstack.
)
  create ,
DOES>  ( x: a b c d -- a b c d a b )  @ x2over ;

: x2swap:  ( "name" xstack -- )
(
Define a word that swaps the top two double cells of the xstack.
)
  create ,
DOES>  ( x: a b c d -- c d a b )  @ x2swap ;
[THEN]  \ DEFINING WORDS