/** * Title: Primitives for extra stacks * Version: 0.6.5 * File: xstacks-ext.c * Author: david.n.williams@umich.edu * License: LGPL * Last revision: December 20, 2006 * * Copyright (C) 2001, 2002, 2006 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 code is for an external pfe module, not part of the pfe * distribution. * * This word set contains primitives for extra stacks, which we * call "xstacks", ported from our ^Forth Motorola 680x0 stacks * package, last revised on March 21, 1998. There are * primitives for stack entries of both one and two cells. * * In versions up to 0.6.4, the words were designed not for * execution but strictly for compilation, with the help of a * special CREATE-EXEC word. Starting with version 0.6.5, the * names of those words have been surrounded by "["..."]", and * the old names are now used for executable words that take an * xstack structure instance as data stack input. There is an * ANS Forth implementation of the new words in xstacks.fs * * The file xstacks-pfe-test.fs still tests only the older * primitives. The newer words can be tested by setting the PFE * switch in xstacks-test.fs, which defaults to testing to ANS * version. */ #define _P4_SOURCE 1 #include #include #include /* p4_header() */ #include /* p4_colon_RT_ */ #include /* p4_PStr */ /* We use the prefix "dw_" to avoid possible label conflicts * with pfe prefixes. */ #include "xstacks-ext.h" /** * By default the words in this file test the validity of the * xstack when and only when they increase the number of items. * To remove that or add stack checking when the number of items * decreases, uncomment the appropriate one of the two lines * just below, or supply -DXS_NO_OVERFLOW_CHECK, respectively, * -DXS_UNDERFLOW_CHECK in the compilation command line, and * recompile. */ #ifndef XS_NO_OVERFLOW_CHECK #define Q_X1OVERFLOW if (XSP == XSBREAK) p4_throw (P4_ON_STACK_OVER) #define Q_X2OVERFLOW if (XSP < XSBREAK + 2) p4_throw (P4_ON_STACK_OVER) #else #define Q_X1OVERFLOW #define Q_X2OVERFLOW #endif // #define XS_UNDERFLOW_CHECK 1 #ifdef XS_UNDERFLOW_CHECK #define Q_X1UNDERFLOW if (XSP == XSP0) p4_throw (P4_ON_STACK_UNDER) #define Q_X2UNDERFLOW if (XSP > XSP0 - 2) p4_throw (P4_ON_STACK_UNDER) #define Q_X4UNDERFLOW if (XSP > XSP0 - 4) p4_throw (P4_ON_STACK_UNDER) #else #define Q_X1UNDERFLOW #define Q_X2UNDERFLOW #define Q_X4UNDERFLOW #endif /********************************* 1 XSTACK COMPILATION PRIMITIVES *********************************/ /** * The single-cell and double-cell word sections below contain * primitives for compilation by defining words for stack * operations on xstack instances. (See the file * xstacks-pfe.fs.) These words cannot be EXECUTEd because they * return to the caller of the defined word, rather than to the * caller of themselves. */ #define XSP (((dw_XStack *)(*IP))->xsp) #define XSP0 (((dw_XStack *)(*IP))->xsp0) #define XSBREAK (&((dw_XStack *)(*IP))->xsbreak) /**************************** 1.1 SINGLE-CELL PRIMITIVES ****************************/ /** [>X] ( a -- x: a ) */ FCode (dw_brak_to_x) { Q_X1OVERFLOW; *--XSP = *SP++; IP = *RP++; } /** [X>] (x: a -- s: a ) */ FCode (dw_brak_x_from) { Q_X1UNDERFLOW; *--SP = *XSP++; IP = *RP++; } /** [X@] (x: a -- a s: a ) */ FCode (dw_brak_x_fetch) { Q_X1UNDERFLOW; *--SP = *XSP; IP = *RP++; } /** [@>X] ( addr -- x: a ) */ FCode (dw_brak_fetch_to_x) { Q_X1OVERFLOW; *--XSP = *(p4ucell *) *SP++; IP = *RP++; } /** [X>!] ( addr x: a -- ) */ FCode (dw_brak_x_from_store) { Q_X1UNDERFLOW; *(p4ucell *) *SP++ = *XSP++; IP = *RP++; } /** [XDROP] (x: a -- ) */ FCode (dw_brak_x_drop) { Q_X1UNDERFLOW; XSP += 1; IP = *RP++; } /** [XDUP] (x: a -- a a ) */ FCode (dw_brak_x_dup) { Q_X1OVERFLOW; Q_X1UNDERFLOW; XSP -= 1; XSP[0] = XSP[1]; IP = *RP++; } /** [XOVER] (x: a b -- a b a ) */ FCode (dw_brak_x_over) { Q_X1OVERFLOW; Q_X2UNDERFLOW; XSP -= 1; XSP[0] = XSP[2]; IP = *RP++; } /** [XSWAP] (x: a b -- b a ) */ FCode (dw_brak_x_swap) { p4ucell a = *XSP; Q_X2UNDERFLOW; *XSP = XSP[1]; XSP[1] = a; IP = *RP++; } /** [XDEPTH] ( -- u ) */ FCode (dw_brak_x_depth) { *--SP = XSP0 - XSP; IP = *RP++; } /** [XSP!] ( addr -- ) */ FCode (dw_brak_xsp_store) { XSP = (p4ucell *) *SP++; IP = *RP++; } /** [XSP0!] ( -- ) */ FCode (dw_brak_xsp0_store) { XSP = XSP0; IP = *RP++; } /** [XSP@] ( -- addr ) */ FCode (dw_brak_xsp_fetch) { // (p4ucell *) *--SP = XSP; *--SP = (p4ucell) XSP; IP = *RP++; } /**************************** 1.2 DOUBLE-CELL PRIMITIVES ****************************/ /* This code often imitates pfe's core-ext.c. */ /** [2>X] ( a b -- x: a b ) */ FCode (dw_brak_two_to_x) { Q_X2OVERFLOW; XSP -= 2; *(p4dcell *) XSP = *(p4dcell *) SP; SP += 2; IP = *RP++; } /** [2X>] (x: a b -- s: a b) */ FCode (dw_brak_two_x_from) { Q_X2UNDERFLOW; SP -= 2; *(p4dcell *) SP = *(p4dcell *) XSP; XSP += 2; IP = *RP++; } /** [2X@] (x: a b -- a b s: a b ) */ FCode (dw_brak_two_x_fetch) { Q_X2UNDERFLOW; SP -= 2; *(p4dcell *) SP = *(p4dcell *) XSP; IP = *RP++; } /** [2@>X] ( addr -- x: a b ) */ FCode (dw_brak_two_fetch_to_x) { p4dcell *p = (p4dcell *) *SP++; Q_X2OVERFLOW; XSP -= 2; *(p4dcell *) XSP = *p; IP = *RP++; } /** [2X>!] ( addr x: a b -- ) */ FCode (dw_brak_two_x_from_store) { Q_X2UNDERFLOW; // *(p4dcell *) *SP++ = *((p4dcell *) XSP)++; *(p4dcell *) *SP++ = *(p4dcell *) XSP; XSP += 2; IP = *RP++; } /** [X2DROP] (x: a b -- ) */ FCode (dw_brak_x_two_drop) { Q_X2UNDERFLOW; XSP += 2; IP = *RP++; } /** [X2DUP] (x: a b -- a b a b ) */ FCode (dw_brak_x_two_dup) { Q_X2OVERFLOW; Q_X2UNDERFLOW; XSP -= 2; XSP[0] = XSP[2]; XSP[1] = XSP[3]; IP = *RP++; } /** [X2OVER] (x: a b c d -- a b c d a b ) */ FCode (dw_brak_x_two_over) { Q_X2OVERFLOW; Q_X4UNDERFLOW; XSP -= 2; XSP[0] = XSP[4]; XSP[1] = XSP[5]; IP = *RP++; } /** [X2SWAP] (x: a b c d -- c d a b ) */ FCode (dw_brak_x_two_swap) { p4cell h; Q_X4UNDERFLOW; h = XSP[0]; XSP[0] = XSP[2]; XSP[2] = h; h = XSP[1]; XSP[1] = XSP[3]; XSP[3] = h; IP = *RP++; } /********************** 2 BASIC XSTACK WORDS **********************/ /** * The basic xstack words can be executed. They all take an * xstack structure instance as input. */ #undef XSP #define XSP (xstack->xsp) #undef XSP0 #define XSP0 (xstack->xsp0) #undef XSBREAK #define XSBREAK (&xstack->xsbreak) /***************************** 2.1 SINGLE-CELL WORDS *****************************/ /** >X ( a xstack -- x: a ) */ FCode (dw_to_x) { dw_XStack* xstack = (dw_XStack*) *SP++; Q_X1OVERFLOW; *--XSP = *SP++; } /** X> (x: a xstack -- s: a ) */ FCode (dw_x_from) { dw_XStack* xstack = (dw_XStack*) *SP++; Q_X1UNDERFLOW; *--SP = *XSP++; } /** X@ ( xstack x: a -- a s: a ) */ FCode (dw_x_fetch) { dw_XStack* xstack = (dw_XStack*) *SP++; Q_X1UNDERFLOW; *--SP = *XSP; } /** @>X ( addr xstack -- x: a ) */ FCode (dw_fetch_to_x) { dw_XStack* xstack = (dw_XStack*) *SP++; Q_X1OVERFLOW; *--XSP = *(p4ucell *) *SP++; } /** X>! ( addr xstack x: a -- ) */ FCode (dw_x_from_store) { dw_XStack* xstack = (dw_XStack*) *SP++; Q_X1UNDERFLOW; *(p4ucell *) *SP++ = *XSP++; } /** XDROP ( xstack x: a -- ) */ FCode (dw_x_drop) { dw_XStack* xstack = (dw_XStack*) *SP++; Q_X1UNDERFLOW; XSP += 1; } /** XDUP ( xstack x: a -- a a ) */ FCode (dw_x_dup) { dw_XStack* xstack = (dw_XStack*) *SP++; Q_X1OVERFLOW; Q_X1UNDERFLOW; XSP -= 1; XSP[0] = XSP[1]; } /** XOVER ( xstack x: a b -- a b a ) */ FCode (dw_x_over) { dw_XStack* xstack = (dw_XStack*) *SP++; Q_X1OVERFLOW; Q_X2UNDERFLOW; XSP -= 1; XSP[0] = XSP[2]; } /** XSWAP ( xstack x: a b -- b a ) */ FCode (dw_x_swap) { dw_XStack* xstack = (dw_XStack*) *SP++; p4ucell a = *XSP; Q_X2UNDERFLOW; *XSP = XSP[1]; XSP[1] = a; } /** XDEPTH ( xstack -- u ) */ FCode (dw_x_depth) { dw_XStack* xstack = (dw_XStack*) *SP++; *--SP = XSP0 - XSP; } /** XSP! ( addr xstack -- ) */ FCode (dw_xsp_store) { dw_XStack* xstack = (dw_XStack*) *SP++; XSP = (p4ucell *) *SP++; } /** XSP0! ( xstack -- ) */ FCode (dw_xsp0_store) { dw_XStack* xstack = (dw_XStack*) *SP++; XSP = XSP0; } /** XSP@ ( xstack -- addr ) */ FCode (dw_xsp_fetch) { dw_XStack* xstack = (dw_XStack*) *SP++; *--SP = (p4ucell) XSP; } /*********************** 2.2 DOUBLE-CELL WORDS ***********************/ /** 2>X ( a b xstack -- x: a b ) */ FCode (dw_two_to_x) { dw_XStack* xstack = (dw_XStack*) *SP++; Q_X2OVERFLOW; XSP -= 2; *(p4dcell *) XSP = *(p4dcell *) SP; SP += 2; } /** 2X> ( xstack x: a b -- s: a b) */ FCode (dw_two_x_from) { dw_XStack* xstack = (dw_XStack*) *SP++; Q_X2UNDERFLOW; SP -= 2; *(p4dcell *) SP = *(p4dcell *) XSP; XSP += 2; } /** 2X@ ( xstack x: a b -- a b s: a b ) */ FCode (dw_two_x_fetch) { dw_XStack* xstack = (dw_XStack*) *SP++; Q_X2UNDERFLOW; SP -= 2; *(p4dcell *) SP = *(p4dcell *) XSP; } /** 2@>X ( addr xstack -- x: a b ) */ FCode (dw_two_fetch_to_x) { dw_XStack* xstack = (dw_XStack*) *SP++; p4dcell *p = (p4dcell *) *SP++; Q_X2OVERFLOW; XSP -= 2; *(p4dcell *) XSP = *p; } /** 2X>! ( addr xstack x: a b -- ) */ FCode (dw_two_x_from_store) { dw_XStack* xstack = (dw_XStack*) *SP++; Q_X2UNDERFLOW; *(p4dcell *) *SP++ = *(p4dcell *) XSP; XSP += 2; } /** X2DROP ( xstack x: a b -- ) */ FCode (dw_x_two_drop) { dw_XStack* xstack = (dw_XStack*) *SP++; Q_X2UNDERFLOW; XSP += 2; } /** X2DUP ( xstack x: a b -- a b a b ) */ FCode (dw_x_two_dup) { dw_XStack* xstack = (dw_XStack*) *SP++; Q_X2OVERFLOW; Q_X2UNDERFLOW; XSP -= 2; XSP[0] = XSP[2]; XSP[1] = XSP[3]; } /** X2OVER ( xstack x: a b c d -- a b c d a b ) */ FCode (dw_x_two_over) { dw_XStack* xstack = (dw_XStack*) *SP++; Q_X2OVERFLOW; Q_X4UNDERFLOW; XSP -= 2; XSP[0] = XSP[4]; XSP[1] = XSP[5]; } /** X2SWAP ( xstack x: a b c d -- c d a b ) */ FCode (dw_x_two_swap) { dw_XStack* xstack = (dw_XStack*) *SP++; p4cell h; Q_X4UNDERFLOW; h = XSP[0]; XSP[0] = XSP[2]; XSP[2] = h; h = XSP[1]; XSP[1] = XSP[3]; XSP[3] = h; } P4_LISTWORDS (xstacks) = { /* single-cell compilation primitives */ P4_FXco ("[>x]", dw_brak_to_x), P4_FXco ("[x>]", dw_brak_x_from), P4_FXco ("[x@]", dw_brak_x_fetch), P4_FXco ("[@>x]", dw_brak_fetch_to_x), P4_FXco ("[x>!]", dw_brak_x_from_store), P4_FXco ("[xdrop]", dw_brak_x_drop), P4_FXco ("[xdup]", dw_brak_x_dup), P4_FXco ("[xover]", dw_brak_x_over), P4_FXco ("[xswap]", dw_brak_x_swap), P4_FXco ("[xdepth]", dw_brak_x_depth), P4_FXco ("[xsp!]", dw_brak_xsp_store), P4_FXco ("[xsp0!]", dw_brak_xsp0_store), P4_FXco ("[xsp@]", dw_brak_xsp_fetch), /* double-cell compilation primitives */ P4_FXco ("[2>x]", dw_brak_two_to_x), P4_FXco ("[2x>]", dw_brak_two_x_from), P4_FXco ("[2x@]", dw_brak_two_x_fetch), P4_FXco ("[2@>x]", dw_brak_two_fetch_to_x), P4_FXco ("[2x>!]", dw_brak_two_x_from_store), P4_FXco ("[x2drop]", dw_brak_x_two_drop), P4_FXco ("[x2dup]", dw_brak_x_two_dup), P4_FXco ("[x2over]", dw_brak_x_two_over), P4_FXco ("[x2swap]", dw_brak_x_two_swap), /* single-cell words */ P4_FXco (">x", dw_to_x), P4_FXco ("x>", dw_x_from), P4_FXco ("x@", dw_x_fetch), P4_FXco ("@>x", dw_fetch_to_x), P4_FXco ("x>!", dw_x_from_store), P4_FXco ("xdrop", dw_x_drop), P4_FXco ("xdup", dw_x_dup), P4_FXco ("xover", dw_x_over), P4_FXco ("xswap", dw_x_swap), P4_FXco ("xdepth", dw_x_depth), P4_FXco ("xsp!", dw_xsp_store), P4_FXco ("xsp0!", dw_xsp0_store), P4_FXco ("xsp@", dw_xsp_fetch), /* double-cell words */ P4_FXco ("2>x", dw_two_to_x), P4_FXco ("2x>", dw_two_x_from), P4_FXco ("2x@", dw_two_x_fetch), P4_FXco ("2@>x", dw_two_fetch_to_x), P4_FXco ("2x>!", dw_two_x_from_store), P4_FXco ("x2drop", dw_x_two_drop), P4_FXco ("x2dup", dw_x_two_dup), P4_FXco ("x2over", dw_x_two_over), P4_FXco ("x2swap", dw_x_two_swap) }; P4_COUNTWORDS (xstacks, "extra stacks");