(       Title:  Extra Stack Defining Words
         File:  xstacks-defwords.fs
       Author:  David N. Williams
      License:  LGPL
      Version:  0.7.0
Last revision:  August 21, 2021
)
\ Copyright (C) 1996, 2001, 2002, 2004, 2006, 2009, 2021
\ 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
[UNDEFINED] >x [IF] CR
.( ***xstacks-defwords.fs:  Either xstacks.fs or the PFE) CR
.(                          xstacks module must be loaded.) CR ABORT [THEN] 

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

  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

[UNDEFINED] +FIELD [IF]
  : +FIELD  ( offset size -- offset+size )    \ 2012
    create over , +
  DOES>  ( struc -- struc+offset )  @ + ;
[THEN]

\ *** XSTACK STRUCTURE
(
In stack comments, "xstack" is the address of an instance of the
following xstack structure.
)
[UNDEFINED] make-xstack [IF]
  0               \ in lieu of BEGIN-STRUCTURE
  1 cells +field >xs-ptr
  1 cells +field >xs-ptr0
  1 cells +field >xs-break
  ( offset) drop  \ in lieu of END-STRUCTURE

: 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) ;
[THEN]

\ *** XSTACK DEFINING WORDS
(
See the file xstack-test.fs for sample usage of these defining words and
words they define.
)
: >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 ;