( Title: Test xstacks.fs File: xstacks-test.fs Author: David N. Williams License: Public Domain Version: 0.6.5 Revised: December 20, 2006 ) \ Uncomment one of the following to select the implementation of \ the "basic" xstack words: \ true constant PFE \ pfe version false constant PFE \ xstacks.fs version PFE 0= [IF] cr .( Using ANS Forth version of basic xstack words.) true constant XSTACK-DEFINING-WORDS [ELSE] loadm xstacks cr .( Using pfe version of basic xstack words.) [THEN] s" xstacks.fs" included s" twx.fs" included [UNDEFINED] -cell [IF] -1 cells constant -cell [THEN] [UNDEFINED] cell- [IF] : cell- ( addr -- [addr - cell.size] ) -cell + ; [THEN] [UNDEFINED] \\ [IF] : \\ -1 parse 2drop BEGIN refill 0= UNTIL ; [THEN] 6 make-xstack constant jim jim to xstack \ used by twx.fs \ We occasionally used the following until we got everything working. : .xs ( -- ) xstack-depth 0 ?DO xstack >xs-ptr @ i cells + @ cr . LOOP ; jim >x: >jim jim x>: jim> jim x@: jim@ jim @>x: @>jim jim x>!: jim>! jim xdrop: jimdrop jim xdup: jimdup jim xover: jimover jim xswap: jimswap jim xdepth: jimdepth jim xsp!: jimsp! jim xsp0!: jimsp0! jim xsp@: jimsp@ jim 2>x: 2>jim jim 2x>: 2jim> jim 2x@: 2jim@ jim 2@>x: 2@>jim jim 2x>!: 2jim>! jim x2drop: jim2drop jim x2dup: jim2dup jim x2over: jim2over jim x2swap: jim2swap : cr-.jimdepth ( -- ) cr ." jimdepth is " jimdepth . ; variable 1item 2variable 2items \ >jim jim> jim@ jimdepth jimsp! jimsp0! jimsp@ \ @>jim jim>! jimdrop jimdup jimover jimswap { jimsp@ jim >xs-ptr @ - -> 0 } { 1 >jim jimsp@ jimsp0! jimsp@ - -> -cell } { jimsp0! jimdepth -> 0 } { 2 >jim jimdrop jimsp@ cell- jimsp! jimdepth -> 1 2 >jim } { 1 >jim jimdepth -> 1 1 >jim } { 2 >jim jim@ jimdepth -> 2 1 2 >jim } { 3 >jim jim> -> 3 } { 5 1item ! 1item @>jim -> 5 >jim } { 5 1item ! 3 >jim 1item jim>! 1item @ -> 3 } { 2 >jim jimdrop -> } { 2 >jim jimdup -> 2 >jim 2 >jim } { 1 >jim 2 >jim jimover -> 1 >jim 2 >jim 1 >jim } { 1 >jim 2 >jim jimswap -> 2 >jim 1 >jim } \ 2>jim 2jim> 2jim@ 2@>jim 2jim>! \ jim2drop jim2dup jim2over jim2swap { 1 2 2>jim -> 1 >jim 2 >jim } { 1 2 2>jim 2jim> -> 1 2 } { 1 2 2>jim 2jim@ -> 1 2 1 >jim 2 >jim } { 1 2 2items 2! 2items 2@>jim -> 1 >jim 2 >jim } { 3 4 2>jim 2items 2jim>! 2items 2@ -> 3 4 } { 1 2 2>jim jim2drop -> } { 1 2 2>jim jim2dup -> 1 2 2>jim 1 2 2>jim } { 1 2 2>jim 3 4 2>jim jim2over -> 1 2 2>jim 3 4 2>jim 1 2 2>jim } { 1 2 2>jim 3 4 2>jim jim2swap -> 3 4 2>jim 1 2 2>jim } \ The above implicitly validates the following message, if underflow \ checking is used in the relevant basic words. cr .( No underflow aborts for legal operations at bottom boundary.) \ Check overflow for legal operations at the top boundary (xstack \ break). 1 >jim 2 >jim 3 >jim 4 >jim 5 >jim 6 >jim jimdrop jimdup jimdrop 1item @>jim jimdrop jimover jim2drop 5 6 2>jim jim2drop jim2dup jim2drop 2items 2@>jim jim2drop jim2over cr .( No overflow aborts for legal operations at top boundary.) \ When individually uncommented, the lines below should abort, \ except for the underflow errors marked with *, for which \ exceptions are not implemented in xstacks.fs. For the pfe \ xstacks module, options can be set to activate all exceptions. \ Check overflow for illegal operations at the top boundary. \ The first group works on a full stack: cr-.jimdepth \ 7 >jim \ Error: ">jim": stack overflow \ jimdup \ Error: "jimdup": stack overflow \ 1item @>jim \ Error: "@>jim": stack overflow \ jimover \ Error: "jimover": stack overflow \ 7 8 2>jim \ Error: "2>jim": stack overflow \ jim2dup \ Error: "jim2dup": stack overflow \ 2items 2@>jim \ Error: "2@>jim": stack overflow \ jim2over \ Error: "jim2over": stack overflow \ The next group works on a stack with one cell available. jimdrop cr-.jimdepth \ 7 8 2>jim \ Error: "2>jim": stack overflow \ jim2dup \ Error: "jim2dup": stack overflow \ 2items 2@>jim \ Error: "2@>jim": stack overflow \ jim2over \ Error: "jim2over": stack overflow \ Check underflow for illegal operations at the bottom boundary. \ The first group works on an empty stack: jimsp0! cr-.jimdepth \ jim> \ Error: "jim>": stack underflow \ jim@ \ *Error: "jim@": stack underflow \ 1item jim>! \ Error: "jim>!": stack underflow \ jimdrop \ Error: "jimdrop": stack underflow \ jimdup \ *Error: "jimdup": stack underflow \ jimover \ *Error: "jimover": stack underflow \ jimswap \ *Error: "jimswap": stack underflow \ 2jim> \ Error: "2jim>": stack underflow \ 2jim@ \ *Error: "2jim@": stack underflow \ 2items 2jim>! \ Error: "2jim>!": stack underflow \ jim2drop \ Error: "jim2drop": stack underflow \ jim2dup \ *Error: "jim2dup": stack underflow \ jim2over \ *Error: "jim2over": stack underflow \ jim2swap \ *Error: "jim2swap": stack underflow \ The next group works on a stack with one cell used: 1 >jim cr-.jimdepth \ jimover \ *Error: "jimover": stack underflow \ jimswap \ *Error: "jimswap": stack underflow \ 2jim> \ Error: "2jim>": stack underflow \ 2jim@ \ *Error: "2jim@": stack underflow \ 2items 2jim>! \ Error: "2jim>!": stack underflow \ jim2drop \ Error: "jim2drop": stack underflow \ jim2dup \ *Error: "jim2dup": stack underflow \ jim2over \ *Error: "jim2over": stack underflow \ jim2swap \ *Error: "jim2swap": stack underflow \ The next group works on a stack with two cells used: 2 >jim cr-.jimdepth \ jim2over \ *Error: "jim2over": stack underflow \ jim2swap \ *Error: "jim2swap": stack underflow \ The next group works on a stack with three cells used: 3 >jim cr-.jimdepth \ jim2over \ *Error: "jim2over": stack underflow \ jim2swap \ Error: "jim2swap": stack underflow