ref: 7d02e382d314d5bdde7978ccb7a64ea9201d03db
dir: 9ficl/stack.c
/*******************************************************************
** s t a c k . c
** Forth Inspired Command Language
** Author: John Sadler (john_sadler@alum.mit.edu)
** Created: 16 Oct 1997
** $Id: stack.c,v 1.15 2010/12/04 21:38:47 asau Exp $
*******************************************************************/
/*
** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
** All rights reserved.
**
** Get the latest Ficl release at http://ficl.sourceforge.net
**
** I am interested in hearing from anyone who uses Ficl. If you have
** a problem, a success story, a defect, an enhancement request, or
** if you would like to contribute to the Ficl release, please
** contact me by email at the address above.
**
** L I C E N S E and D I S C L A I M E R
**
** Redistribution and use in source and binary forms, with or without
** modification, are permitted provided that the following conditions
** are met:
** 1. Redistributions of source code must retain the above copyright
** notice, this list of conditions and the following disclaimer.
** 2. Redistributions in binary form must reproduce the above copyright
** notice, this list of conditions and the following disclaimer in the
** documentation and/or other materials provided with the distribution.
**
** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
** SUCH DAMAGE.
*/
#include <stdlib.h>
#include "ficl.h"
/*
** N O T E: Stack convention:
**
** THIS CHANGED IN FICL 4.0!
**
** top points to the *current* top data value
** push: increment top, store value at top
** pop: fetch value at top, decrement top
** Stack grows from low to high memory
*/
/*******************************************************************
v m C h e c k S t a c k
** Check the parameter stack for underflow or overflow.
** size controls the type of check: if size is zero,
** the function checks the stack state for underflow and overflow.
** If size > 0, checks to see that the stack has room to push
** that many cells. If less than zero, checks to see that the
** stack has room to pop that many cells. If any test fails,
** the function throws (via vmThrow) a VM_ERREXIT exception.
*******************************************************************/
void ficlStackCheck(ficlStack *stack, int popCells, int pushCells)
#if FICL_ROBUST >= 1
{
int depth = ficlStackDepth(stack);
int nFree = stack->size - depth;
if (popCells > depth)
{
ficlVmThrowError(stack->vm, "Error: %s stack underflow", stack->name);
}
if (nFree < pushCells - popCells)
{
ficlVmThrowError(stack->vm, "Error: %s stack overflow", stack->name);
}
return;
}
#else /* FICL_ROBUST >= 1 */
{
FICL_IGNORE(stack);
FICL_IGNORE(popCells);
FICL_IGNORE(pushCells);
}
#endif /* FICL_ROBUST >= 1 */
/*******************************************************************
s t a c k C r e a t e
**
*******************************************************************/
ficlStack *ficlStackCreate(ficlVm *vm, char *name, unsigned size)
{
ficlCell *base = (ficlCell*)ficlMalloc(size * sizeof (ficlCell));
ficlStack *stack = (ficlStack*)ficlMalloc(sizeof (ficlStack));
FICL_VM_ASSERT(vm, size != 0);
FICL_VM_ASSERT(vm, base != NULL);
FICL_VM_ASSERT(vm, stack != NULL);
stack->size = size;
stack->base = base;
stack->frame = NULL;
stack->vm = vm;
stack->name = name;
ficlStackReset(stack);
return stack;
}
/*******************************************************************
s t a c k D e l e t e
**
*******************************************************************/
void ficlStackDestroy(ficlStack *stack)
{
if (stack != NULL) {
if (stack->base != NULL)
ficlFree(stack->base);
ficlFree(stack);
}
return;
}
/*******************************************************************
s t a c k D e p t h
**
*******************************************************************/
int ficlStackDepth(ficlStack *stack)
{
return (stack->top - stack->base) + 1;
}
/*******************************************************************
s t a c k D r o p
**
*******************************************************************/
void ficlStackDrop(ficlStack *stack, int n)
{
FICL_VM_ASSERT(stack->vm, n > 0);
stack->top -= n;
return;
}
/*******************************************************************
s t a c k F e t c h
**
*******************************************************************/
ficlCell ficlStackFetch(ficlStack *stack, int n)
{
return stack->top[-n];
}
void ficlStackStore(ficlStack *stack, int n, ficlCell c)
{
stack->top[-n] = c;
return;
}
/*******************************************************************
s t a c k G e t T o p
**
*******************************************************************/
ficlCell ficlStackGetTop(ficlStack *stack)
{
return stack->top[0];
}
#if FICL_WANT_LOCALS
/*******************************************************************
s t a c k L i n k
** Link a frame using the stack's frame pointer. Allot space for
** size cells in the frame
** 1) Push frame
** 2) frame = top
** 3) top += size
*******************************************************************/
void ficlStackLink(ficlStack *stack, int size)
{
ficlStackPushPointer(stack, stack->frame);
stack->frame = stack->top + 1;
stack->top += size;
return;
}
/*******************************************************************
s t a c k U n l i n k
** Unink a stack frame previously created by stackLink
** 1) top = frame
** 2) frame = pop()
*******************************************************************/
void ficlStackUnlink(ficlStack *stack)
{
stack->top = stack->frame - 1;
stack->frame = (ficlCell*)ficlStackPopPointer(stack);
return;
}
#endif /* FICL_WANT_LOCALS */
/*******************************************************************
s t a c k P i c k
**
*******************************************************************/
void ficlStackPick(ficlStack *stack, int n)
{
ficlStackPush(stack, ficlStackFetch(stack, n));
return;
}
/*******************************************************************
s t a c k P o p
**
*******************************************************************/
ficlCell ficlStackPop(ficlStack *stack)
{
return *stack->top--;
}
void *ficlStackPopPointer(ficlStack *stack)
{
return (*stack->top--).p;
}
ficlUnsigned ficlStackPopUnsigned(ficlStack *stack)
{
return (*stack->top--).u;
}
ficlInteger ficlStackPopInteger(ficlStack *stack)
{
return (*stack->top--).i;
}
ficl2Integer ficlStackPop2Integer(ficlStack *stack)
{
ficl2Integer ret;
ficlInteger high = ficlStackPopInteger(stack);
ficlInteger low = ficlStackPopInteger(stack);
FICL_2INTEGER_SET(high, low, ret);
return ret;
}
ficl2Unsigned ficlStackPop2Unsigned(ficlStack *stack)
{
ficl2Unsigned ret;
ficlUnsigned high = ficlStackPopUnsigned(stack);
ficlUnsigned low = ficlStackPopUnsigned(stack);
FICL_2UNSIGNED_SET(high, low, ret);
return ret;
}
#if (FICL_WANT_FLOAT)
ficlFloat ficlStackPopFloat(ficlStack *stack)
{
return (*stack->top--).f;
}
#endif
/*******************************************************************
s t a c k P u s h
**
*******************************************************************/
void ficlStackPush(ficlStack *stack, ficlCell c)
{
*++stack->top = c;
}
void ficlStackPushPointer(ficlStack *stack, void *ptr)
{
*++stack->top = FICL_LVALUE_TO_CELL(ptr);
}
void ficlStackPushInteger(ficlStack *stack, ficlInteger i)
{
*++stack->top = FICL_LVALUE_TO_CELL(i);
}
void ficlStackPushUnsigned(ficlStack *stack, ficlUnsigned u)
{
*++stack->top = FICL_LVALUE_TO_CELL(u);
}
void ficlStackPush2Unsigned(ficlStack *stack, ficl2Unsigned du)
{
ficlStackPushUnsigned(stack, FICL_2UNSIGNED_GET_LOW(du));
ficlStackPushUnsigned(stack, FICL_2UNSIGNED_GET_HIGH(du));
return;
}
void ficlStackPush2Integer(ficlStack *stack, ficl2Integer di)
{
ficlStackPush2Unsigned(stack, FICL_2INTEGER_TO_2UNSIGNED(di));
return;
}
#if (FICL_WANT_FLOAT)
void ficlStackPushFloat(ficlStack *stack, ficlFloat f)
{
*++stack->top = FICL_LVALUE_TO_CELL(f);
}
#endif
/*******************************************************************
s t a c k R e s e t
**
*******************************************************************/
void ficlStackReset(ficlStack *stack)
{
stack->top = stack->base - 1;
return;
}
/*******************************************************************
s t a c k R o l l
** Roll nth stack entry to the top (counting from zero), if n is
** >= 0. Drop other entries as needed to fill the hole.
** If n < 0, roll top-of-stack to nth entry, pushing others
** upward as needed to fill the hole.
*******************************************************************/
void ficlStackRoll(ficlStack *stack, int n)
{
ficlCell c;
ficlCell *cell;
if (n == 0)
return;
else if (n > 0)
{
cell = stack->top - n;
c = *cell;
for (;n > 0; --n, cell++)
{
*cell = cell[1];
}
*cell = c;
}
else
{
cell = stack->top;
c = *cell;
for (; n < 0; ++n, cell--)
{
*cell = cell[-1];
}
*cell = c;
}
return;
}
/*******************************************************************
s t a c k S e t T o p
**
*******************************************************************/
void ficlStackSetTop(ficlStack *stack, ficlCell c)
{
FICL_STACK_CHECK(stack, 1, 1);
stack->top[0] = c;
return;
}
void ficlStackWalk(ficlStack *stack, ficlStackWalkFunction callback, void *context, ficlInteger bottomToTop)
{
int i;
int depth;
ficlCell *cell;
FICL_STACK_CHECK(stack, 0, 0);
depth = ficlStackDepth(stack);
cell = bottomToTop ? stack->base : stack->top;
for (i = 0; i < depth; i++)
{
if (callback(context, cell) == FICL_FALSE)
break;
cell += bottomToTop ? 1 : -1;
}
return;
}