(       Title:  Stack Defining Words
         File:  xstacks-pfe.fs
       Author:  David N. Williams
      License:  LGPL
      Version:  0.6.5
Last revision:  December 20, 2006
)
\ Copyright (C) 1996, 2001, 2002, 2004, 2006 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 pfe.
)

decimal
loadm execution  \ CREATE-EXEC (execution-ext.c)
loadm xstacks    \ extra-stack primitives (xstacks-ext.c)


\ *** WORDS
(
  plainstruct:
  FIELD:

  xstack structure:
  >XS-PTR  >XS-PTR0  >XS-BREAK  MAKE-XSTACK  CREATE-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 )
    create over , +
  DOES>  ( struc -- struc+offset )  @ + ;
[THEN]


\ *** XSTACK STRUCTURE
(
This structure has to coincide with that used by primitive
xstack words.
)

  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) ;

: create-xstack  ( "stackname" max#cells -- )
(
Allot space for a named xstack with max#cells.
)
  create make-xstack ( xstack) drop ;


\ *** XSTACK DEFINING WORDS
(
These defining words use the nonstandard word CREATE-EXEC and a
set of nonportable primitives designed to create relatively
efficient words for operating on a particular xstack instance,
like one made by MAKE-XSTACK.  The primitives have the same
names as the defining words, but without a trailing colon.  Each
defining word compiles a primitive plus a data field, where the
address of the xstack instance is stored for use by the
primitive.

See execution-ext.c for a pfe implementation of CREATE-EXEC, and
xstacks-ext.c for a pfe implementation of the primitives.  The
primitives cannot be executed like normal Forth words because
they return to the caller of the defined word into which they
are compiled, rather than to the caller of themselves.

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

\ CREATE-EXEC		( "name" -- )
(
Create a named word in the current word list without alloting a
parameter field, just like CREATE does.  The run-time semantics
of the created word, instead of leaving the DFA, executes the
Forth word subsequently compiled there.
)

: >x:  ( "name" xstack -- )
\ does  ( a -- x: a)
(
Define a word that pops a off the data stack and pushes it onto
the xstack.
)
  create-exec postpone [>x] ( xstack) , ;

: x>:  ( "name" xstack -- )
\ does  (x: a -- s: a)
(
Define a word that pops a off the xstack and pushes it onto the
data stack.
)
  create-exec postpone [x>] ( xstack) , ;

: x@:  ( "name" xstack -- )
\ does  (x: a -- a s: a )
(
Define a word that leaves a copy of a on the data stack.
)
  create-exec postpone [x@] , ;

: @>x:  ( "name" xstack -- )
\ does  ( addr -- )  (x: -- a )
(
Define a word that fetches a from addr and leaves it on the
xstack.
)
  create-exec postpone [@>x] , ;

: x>!:  ( "name" xstack -- )
\ does  ( addr x: a -- )
(
Define a word that stores a from the xstack into the addr on the
data stack.
)
  create-exec postpone [x>!] , ;

: xdrop:  ( "name" xstack -- )
\ does  (x: a -- ) 
(
Define a word that DROPs the top of the xstack.
)
  create-exec postpone [xdrop] , ;

: xdup:  ( "name" xstack -- )
\ does  (x: a -- a a )
(
Define a word that DUPs the top of the xstack.
)
  create-exec postpone [xdup] , ;

: xover:  ( "name" xstack -- )
\ does  ( -- )  (x: a b -- a b a )
(
Define a word that does OVER on the xstack.
)
  create-exec postpone [xover] , ;

: xswap:  ( "name" xstack -- )
\ does  (x: a b -- b a )
(
Define a word that SWAPs the top two cells of the xstack.
)
  create-exec postpone [xswap] , ;

: xdepth:  ( "name" xstack -- )
\ does  ( -- depth )
(
Define a word that leaves the depth of the xstack.
)
  create-exec postpone [xdepth] , ;

: xsp!:  ( "name" xstack -- )
\ does  ( addr -- )
(
Define a word that sets the xstack pointer to addr.
)
  create-exec postpone [xsp!] , ;

: xsp0!:  ( "name" xstack -- )
\ does  (x: -- )
(
Define a word that clears the xstack.
)
  create-exec postpone [xsp0!] , ;

: xsp@:  ( "name" xstack -- )
\ does  ( -- addr )
(
Define a word that leaves the xstack pointer.
)
  create-exec postpone [xsp@] , ;

: 2>x:  ( "name" xstack -- )
\ does  ( a b -- x: a b )
(
Define a word that pops 2 cells off the data stack and pushes
them onto the xstack.
)
  create-exec postpone [2>x] ( xstack) , ;

: 2x>:  ( "name" xstack -- )
\ does  (x: a b -- s: a b )
(
Define a word that pops two cells off the xstack and pushes them
onto the data stack.
)
  create-exec postpone [2x>] ( xstack) , ;

: 2x@:  ( "name" xstack -- )
\ does  (x: a b  -- a b s: a b )
(
Define a word that leaves a copy of the top two cells of the
xstack on the data stack.
)
 create-exec postpone [2x@] , ;

: 2@>x:  ( "name" xstack -- )
\ does  ( addr -- x: a b )
(
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-exec postpone [2@>x] , ;

: 2x>!:  ( "name" xstack -- )
\ does  ( addr x: a b -- )
(
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-exec postpone [2x>!] , ;

: x2drop:  ( "name" xstack -- )
\ does  (x: a b -- ) 
(
Define a word that 2DROP's the top of the xstack.
)
  create-exec postpone [x2drop] , ;

: x2dup:  ( "name" xstack -- )
\ does  (x: a b -- a b a b )
(
Define a word does 2DUP on the xstack.
)
  create-exec postpone [x2dup] , ;

: x2over:  ( "name" xstack -- )
\ does  (x: a b c d -- a b c d a b )
(
Define a word that does 2OVER on the xstack.
)
  create-exec postpone [x2over] , ;

: x2swap:  ( "name" xstack -- )
\ does  (x: a b c d -- c d a b )
(
Define a word that swaps the top two double cells of the xstack.
)
  create-exec postpone [x2swap] , ;