root/trunk/thune/eval.c

/*
    Thune Interpreter
    Copyright (C) 2005-2007  Karl Robillard

    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.

    You should have received a copy of the GNU Lesser General Public
    License along with this library; if not, write to the Free Software
    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
*/


#include "internal.h"
#include "urlan_atoms.h"
#include "bignum.h"


extern UContext ur_thrGlobal;
extern UContext ur_envGlobal;

extern void uc_console_out( UThread*, UCell* );


#ifdef DEBUG
void ur_dumpBlock( UThread* ut, UIndex blkN )
{
    UCell* cell;
    UCell blk;
    UString str;

    ur_arrayInit( &str, 1, 0 );

    cell = &blk;
    ur_initType( cell, UT_BLOCK );
    ur_setSeries( cell, blkN, 0 );

    ur_toStr( cell, &str, 0 );

    if( str.used )
    {
        UString* sp = &str;
        ur_termCStr( sp );

        dprint( str.ptr.c );
        dprint( "\n" );
    }

    ur_arrayFree( &str );
}
#endif


void ur_infuseOpcodes( UThread* ut, UIndex blkN )
{
    UBlock* blk;
    UContext* global;
    const UCell* ctx;
    int wrdN;

    global = (ut->env->blocks.arr.used) ? &ur_envGlobal : &ur_thrGlobal;

    wrdN = ur_lookup( global, UR_ATOM_KERNEL_OPS );
    assert( wrdN > -1 );
    //if( wrdN > -1 )
    {
        blk = ur_blockPtr( global->ctx.valBlk );
        ctx = blk->ptr.cells + wrdN;

        assert( ur_is(ctx, UT_CONTEXT) );

        blk = ur_blockPtr( blkN );
        ur_infuse( ut, blk, ctx );
    }
}


/*
   Returns length of series from current iterator position.
   If cell is not a series or beyond the tail then a negative number is
   returned.
*/
static int ur_itLen( UThread* ut, UCell* cell )
{
    int len = ur_seriesEnd( cell );
    if( len > -1 )
        len -= cell->series.it;
    return len;
}


typedef int (*UDatatypeCmpFunc)( UThread*, const UCell*, const UCell*, int );
typedef int (*UDatatypeSelFunc)( UThread*, UCell*, const UCell*, UCell* );

/**
  Returns non-zero if successful.
  Res may be the same as sel.
*/
int ur_getSelector( UThread* ut, const UCell* sel, UCell* res )
{
#define ATOM_OFF(val,atm)   (((unsigned int) val) - atm)
    UBlock* blk;
    UCell* val;

    val = ur_wordCell( ut, sel );
    if( ! val )
        return 0;

    if( ur_selIsAtom(sel) )
    {
        switch( ur_type(val) )
        {
            case UT_CALL:
                // TODO: Avoid copying call cell here. Maybe we should
                //       move ur_wordCell() outside of ur_getSelector()?
                ur_copyCell( res, *val );
                return 1;

            case UT_CONTEXT:
            case UT_PORT:
#ifdef UR_CONFIG_DATAFLOW
            case UT_COMPONENT:
#endif
            {
                int wrdN = ur_lookup( val, ur_sel(sel) );
                if( wrdN > -1 )
                {
                    blk = ur_blockPtr( val->ctx.valBlk );
                    ur_copyCell( res, blk->ptr.cells[ wrdN ] );
                    return 1;
                }
            }
                break;

            case UT_COORD:
            {
                unsigned int n;
                n = ATOM_OFF( ur_sel(sel), UR_ATOM_R );
                if( (n < 4) && (n < val->coord.len) )
                {
                    ur_initInt( res, val->coord.elem[ n ] );
                    return 1;
                }
            }
                goto set_none;

            case UT_VEC3:
            {
                unsigned int n;
                n = ATOM_OFF( ur_sel(sel), UR_ATOM_X );
                if( n < 3 )
                {
                    ur_initDecimal( res, (double) val->vec3.xyz[ n ] );
                    return 1;
                }
            }
                goto set_none;

            default:
                if( ur_type(val) >= UT_BI_COUNT )
                {
                    UDatatypeSelFunc func = CUSTOM_DT(ur_type(val)).selectAtom;
                    if( func )
                        return func( ut, val, sel, res );
                }
                goto set_none;
        }
        ur_throwErr( UR_ERR_SCRIPT, "Invalid select!" );
        return 0;
    }
    else
    {
        int n = ur_sel(sel);
        if( n )
        {
            if( n > 0 )
                --n;
            if( ur_pick( ut, val, n, res ) )
                return 1;
        }
    }

set_none:

    ur_setNone( res );
    return 1;
}


#ifdef UR_CONFIG_DATAFLOW
void ur_setPlug( UThread*, UBlock* cblk, UIndex wrdN, const UCell* nval );
#endif


/**
  Returns non-zero if successful.
*/
int ur_setSelector( UThread* ut, const UCell* sel, const UCell* nval )
{
    UBlock* blk;
    UCell* val;

    val = ur_wordCell( ut, sel );
    if( ! val )
        return 0;

    switch( ur_type(val) )
    {
        case UT_CONTEXT:
            if( ur_selIsAtom(sel) )
            {
                int wrdN;
                wrdN = ur_lookup( val, ur_sel(sel) );
                if( wrdN > -1 )
                {
                    blk = ur_blockPtr( val->ctx.valBlk );
                    ur_copyCell( blk->ptr.cells + wrdN, *nval );
                    return 1;
                }
            }
            break;

        case UT_COORD:
        {
            unsigned int n;
            n = ur_sel(sel) - (ur_selIsAtom(sel) ? UR_ATOM_X : 1);
            if( n < val->coord.len )
            {
                if( ur_is(nval, UT_DECIMAL) )
                    val->coord.elem[ n ] = (int) ur_decimal(nval);
                else if( ur_is(nval, UT_INT) )
                    val->coord.elem[ n ] = ur_int(nval);
            }
            return 1;
        }
            break;

        case UT_VEC3:
        {
            unsigned int n;
            n = ur_sel(sel) - (ur_selIsAtom(sel) ? UR_ATOM_X : 1);
            if( n < 3 )
            {
                if( ur_is(nval, UT_DECIMAL) )
                    val->vec3.xyz[ n ] = (float) ur_decimal(nval);
                else if( ur_is(nval, UT_INT) )
                    val->vec3.xyz[ n ] = (float) ur_int(nval);
            }
            return 1;
        }
            break;

#ifdef UR_CONFIG_DATAFLOW
        case UT_COMPONENT:
            if( ur_selIsAtom(sel) )
            {
                int wrdN;
                wrdN = ur_lookup( val, ur_sel(sel) );
                ur_setPlug( ut, tBlockPtr(val->ctx.valBlk), wrdN, nval );
                return 1;
            }
            break;
#endif

        default:
            if( ! ur_selIsAtom(sel) )
            {
                if( ur_poke( ut, val, ur_sel(sel) - 1, nval ) )
                    return 1;
            }
            break;
    }

    ur_throwErr( UR_ERR_SCRIPT, "Invalid select!" );
    return 0;
}


// (val do-true do-false -- )
UR_CALL( uc_either )
{
    UCell* res = ur_s_backN(tos, 2);

    if( ur_is(res, UT_NONE) ||
        (ur_is(res, UT_LOGIC) && ! ur_logic(res)) )
    {
        ur_copyCell( res, *tos );
    }
    else
    {
        ur_copyCell( res, *(ur_s_prev(tos)) );
    }

    UR_S_DROPN(2);
    UR_CALL_OP = OP_DO;
}


// (value -- result)
UR_CALL( uc_reduce )
{
    if( ur_is(tos, UT_BLOCK) || ur_is(tos, UT_PAREN) )
    {
        UR_CALL_OP = OP_REDUCE;
    }
    else if( ur_is(tos, UT_WORD) )
    {
        UCell* val;
        val = ur_wordCell( ut, tos );
        if( val )
        {
            ur_copyCell( tos, *val );
        }
    }
    else if( ur_is(tos, UT_LITWORD) )
    {
        ur_type(tos) = UT_WORD;
    }
    else if( ur_is(tos, UT_LITSELECT) )
    {
        ur_type(tos) = UT_SELECT;
    }
    // else leave tos unchanged...
}


/**
  Returns zero if cell type does not match datatype.
*/
int ur_verifyDatatype( const UCell* cell, const UCell* datatype )
{
    uint32_t dt = ur_type(cell);
    if( dt < 32 )
    {
        if( datatype->dt.mask0 & (1 << dt) )
            return 1;
    }
    else
    {
        if( datatype->dt.mask1 & (1 << (dt - 32)) )
            return 1;
    }
    return 0;
}


void ur_appendTraceT( UThread* ut, UCellError* err, UIndex blkN, UIndex it )
{
    if( err->traceBlk )
    {
        UCell* cell;
        UBlock* blk;

        blk = ur_blockPtr( err->traceBlk );
        cell = ur_appendCell( blk, UT_BLOCK );
        ur_setSeries( cell, blkN, it );
    }
}


#define _throwUnset(th,cell)    _throwUnsetF(th,cell,"is unset")
#define _throwUnbound(th,cell)  _throwUnsetF(th,cell,"is unbound")

static void _throwUnsetF( UThread* ut, const UCell* wcell, const char* umsg )
{
    UString* str;
    str = ur_threadTmp( ut );
    str->used = 0;
    ur_atomStr( ur_atom(wcell), str );
    ur_termCStr( str );
    ur_throwErr( UR_ERR_SCRIPT, "word '%s %s", str->ptr.c, umsg );
}


/**
   Returns cell pointer or zero if word does not reference a valid cell.
*/
UCell* ur_wordCell( UThread* ut, const UCell* pc )
{
    UBlock* blk;
    int wrdN;

    wrdN = pc->word.index;
    if( wrdN < 0 )
    {
        _throwUnbound( ut, pc);     // UR_UNBOUND
        return 0;
    }

    switch( pc->word.flags & UR_FLAG_BIND_MASK )
    {
        case UR_BIND_THREAD:
#ifdef UR_CONFIG_DATAFLOW
        case UR_BIND_PLUG:      // Each component has its own body for now.
#endif
            // ur_blockPtr( pc->word.valBlk )
            blk = (((UBlock*) ut->blocks.arr.ptr.v) + pc->word.valBlk);
            return blk->ptr.cells + wrdN;

        case UR_BIND_GLOBAL:
            // ur_blockPtr( pc->word.valBlk )
            blk = (((UBlock*) ut->env->blocks.arr.ptr.v) - pc->word.valBlk);
            return blk->ptr.cells + wrdN;

        case UR_BIND_LOCAL:
#if 1
        {
            LocalFrame* it  = UR_LF_BEG;
            LocalFrame* end = UR_LF_END;
            while( it != end )
            {
                if( it->n == pc->word.wordBlk )
                    return it->cell + wrdN;
                ++it;
            }
            _throwUnsetF( ut, pc, "is out-of-scope local" );
            return 0;
        }
#else
            if( pc->word.wordBlk != ut->localWordBlk )
            {
                _throwUnsetF( ut, pc, "is out-of-scope local" );
                return 0;
            }
#if 0
            blk = ((UBlock*) ut->blocks.arr.ptr.v) + BLK_DSTACK;
            return blk->ptr.cells + wrdN + ut->localIdx;
#else
            return ut->localPos + wrdN;
#endif
#endif
    }

    _throwUnsetF( ut, pc, "has invalid bind mask" );
    return 0;
}


/**
   Assign value to word.
   Returns non-zero if successful.  Upon failure, zero is returned and and
   error is thrown.
*/
int ur_setWord( UThread* ut, const UCell* wc, const UCell* val )
{
    UBlock* blk;
    UCell* dest;
    int wrdN;

    wrdN = wc->word.index;
    if( wrdN < 0 )
    {
        _throwUnbound( ut, wc);     // UR_UNBOUND
        return 0;
    }

    switch( wc->word.flags & UR_FLAG_BIND_MASK )
    {
        case UR_BIND_THREAD:
            blk = tBlockPtr( wc->word.valBlk );
            dest = blk->ptr.cells + wrdN;
            break;

        case UR_BIND_GLOBAL:
            _throwUnsetF( ut, wc, "is in shared global storage" );
            return 0;

        case UR_BIND_LOCAL:
        {
            LocalFrame* it  = UR_LF_BEG;
            LocalFrame* end = UR_LF_END;
            while( it != end )
            {
                if( it->n == wc->word.wordBlk )
                {
                    dest = it->cell + wrdN;
                    goto set_word;
                }
                ++it;
            }
            _throwUnsetF( ut, wc, "is out-of-scope local" );
            return 0;
        }

#ifdef UR_CONFIG_DATAFLOW
        case UR_BIND_PLUG:
            // Using tBlockPtr - assuming there are no global components.
            ur_setPlug( ut, tBlockPtr(wc->word.valBlk), wrdN, val );
            return 1;
#endif

        default:
            _throwUnsetF( ut, wc, "has invalid bind mask" );
            return 0;
    }

set_word:

    ur_copyCell(dest, *val);
    return 1;
}


/**
  Evaluate C string.

  \param cmd  String to evaluate.
  \param len  Length of cmd string.  May be -1 if cmd is null terminated.

  \return UR_EVAL_ code.
*/
int ur_evalCStr( UThread* ut, const char* cmd, int len )
{
    const char* end;
    UIndex blkN;

    if( ! cmd )
        return UR_EVAL_OK;

    if( len < 0 )
    {
        end = cmd;
        while( *end )
            ++end;
    }
    else
    {
        end = cmd + len;
    }

    if( end != cmd )
    {
        blkN = ur_tokenize( ut, cmd, end );
        if( blkN )
        {
            ur_infuseOpcodes( ut, blkN );
            return ur_eval( ut, blkN, 0 );
        }
        return UR_EVAL_ERROR;
    }
    return UR_EVAL_OK;
}


/*--------------------------------------------------------------------------*/


extern int memEqual( const char* a, const char* b, int len );

/**
  Returns 1 if equivalent or zero if not.
*/
int ur_equal( UThread* ut, const UCell* a, const UCell* b )
{
    switch( ur_type(a) )
    {
        case UT_DATATYPE:
            if( ur_is(b, UT_DATATYPE) )
            {
                if( (a->dt.mask0 == b->dt.mask0) &&
                    (a->dt.mask1 == b->dt.mask1) )
                    return 1;
            }
            break;

        case UT_NONE:
            if( ur_is(b, UT_NONE) )
            {
                return 1;
            }
            else if( ur_is(b, UT_LOGIC) )
            {
                if( ! ur_logic(b) )
                    return 1;
            }
            break;

        case UT_WORD:
        case UT_LITWORD:
        case UT_SETWORD:
        case UT_GETWORD:
            if( ur_isAWord(b) )
            {
                if( ur_atom(a) == ur_atom(b) )
                    return 1;
            }
            break;

        case UT_OPCODE:
            if( ur_is(b, UT_OPCODE) )
            {
                if( ur_atom(a) == ur_atom(b) )
                    return 1;
            }
            break;

        case UT_LOGIC:
            if( ur_is(b, UT_LOGIC) )
            {
                if( ur_logic(a) == ur_logic(b) )
                    return 1;
            }
            else if( ur_is(b, UT_NONE) )
            {
                if( ! ur_logic(a) )
                    return 1;
            }
            break;

        case UT_CHAR:
        case UT_INT:
            if( ur_is(b, UT_INT) || ur_is(b, UT_CHAR) )
            {
                if( ur_int(a) == ur_int(b) )
                    return 1;
            }
            else if( ur_is(b, UT_DECIMAL) )
            {
                if( ur_int(a) == (int) ur_decimal(b) )
                    return 1;
            }
            else if( ur_is(b, UT_BIGNUM) )
            {
                UCell big;
                bignum_seti( &big, ur_int(a) );
                if( bignum_equal( &big, b ) )
                    return 1;
            }
            break;

        case UT_DECIMAL:
            if( ur_is(b, UT_DECIMAL) )
            {
                if( ur_decimal(a) == ur_decimal(b) )
                    return 1;
            }
            else if( ur_is(b, UT_INT) )
            {
                if( ur_decimal(a) == (double) ur_int(b) )
                    return 1;
            }
            else if( ur_is(b, UT_BIGNUM) )
            {
                UCell big;
                bignum_setd( &big, ur_decimal(a) );
                if( bignum_equal( &big, b ) )
                    return 1;
            }
            break;

        case UT_BIGNUM:
            if( ur_is(b, UT_BIGNUM) )
            {
                if( bignum_equal( a, b ) )
                    return 1;
            }
            else if( ur_is(b, UT_INT) )
            {
                UCell big;
                bignum_seti( &big, ur_int(b) );
                if( bignum_equal( &big, b ) )
                    return 1;
            }
            else if( ur_is(b, UT_DECIMAL) )
            {
                UCell big;
                bignum_setd( &big, ur_decimal(b) );
                if( bignum_equal( &big, b ) )
                    return 1;
            }
            break;

        case UT_COORD:
            if( ur_is(b, UT_COORD) )
            {
                if( a->coord.len == b->coord.len )
                {
                    int i;
                    for( i = 0; i < a->coord.len; ++i )
                    {
                        if( a->coord.elem[i] != b->coord.elem[i] )
                            return 0;
                    }
                    return 1;
                }
            }
            break;

        case UT_VEC3:
            if( ur_is(b, UT_VEC3) )
            {
                if( (a->vec3.xyz[0] == b->vec3.xyz[0]) &&
                    (a->vec3.xyz[1] == b->vec3.xyz[1]) &&
                    (a->vec3.xyz[2] == b->vec3.xyz[2]) )
                    return 1;
            }
            break;

        case UT_BLOCK:
        case UT_PAREN:
        {
            UCell *cpA1, *cpA2;
            UCell *cpB1, *cpB2;
            int len;

            if( ur_blockSlice( ut, a, &cpA1, &cpA2 ) )
            {
                if( ur_blockSlice( ut, b, &cpB1, &cpB2 ) )
                {
                    len = cpB2 - cpB1;
                    if( len == (cpA2 - cpA1) )
                    {
                        if( cpA1 == cpB1 )
                            return 1;
                        while( cpA1 != cpA2 )
                        {
                            if( ! ur_equal( ut, cpA1++, cpB1++ ) )
                                return 0;
                        }
                        return 1;
                    }
                }
            }
        }
            break;

        case UT_BINARY:
        case UT_STRING:
        {
            uint8_t *cpA1, *cpA2;
            uint8_t *cpB1, *cpB2;
            int len;

            if( ur_stringSlice( ut, a, &cpA1, &cpA2 ) )
            {
                if( ur_stringSlice( ut, b, &cpB1, &cpB2 ) )
                {
                    // TODO: Handle different encodings.
eq_bin_slice:
                    len = cpB2 - cpB1;
                    if( len == (cpA2 - cpA1) )
                    {
                        if( len == 0 )
                            return 1;
                        if( cpA1 == cpB1 )
                            return 1;
                        if( memEqual( (char*) cpA1, (char*) cpB1, len ) )
                            return 1;
                    }
                }
            }
            else if( ur_binarySlice( ut, a, &cpA1, &cpA2 ) )
            {
                if( ur_binarySlice( ut, b, &cpB1, &cpB2 ) )
                    goto eq_bin_slice;
            }
        }
            break;

        case UT_CONTEXT:
            if( a->ctx.wordBlk == b->ctx.wordBlk )
                return 1;
            break;

        case UT_DATE:
        case UT_TIME:
            if( ur_is(b, UT_DATE) || ur_is(b, UT_TIME) )
            {
                if( ur_seconds(a) == ur_seconds(b) )
                    return 1;
            }
            break;
    }
    return 0;
}


/**
  Returns 1 if cells are of the same type and value or zero if not.
*/
int ur_same( UThread* ut, const UCell* a, const UCell* b )
{
    (void) ut;

    if( ur_type(a) != ur_type(b) )
        return 0;

    switch( ur_type(a) )
    {
        case UT_DATATYPE:
            if( (a->dt.mask0 == b->dt.mask0) &&
                (a->dt.mask1 == b->dt.mask1) )
                return 1;
            break;

        case UT_NONE:
            return 1;

        case UT_WORD:
        case UT_LITWORD:
        case UT_SETWORD:
        case UT_GETWORD:
            if( ur_atom(a) == ur_atom(b) )
                return 1;
            break;

        case UT_LOGIC:
            if( ur_logic(a) == ur_logic(b) )
                return 1;
            break;

        case UT_INT:
            if( ur_int(a) == ur_int(b) )
                return 1;
            break;

        case UT_DECIMAL:
            if( ur_decimal(a) == ur_decimal(b) )
                return 1;
            break;

        case UT_BIGNUM:
            if( bignum_equal( a, b ) )
                return 1;
            break;

        case UT_BINARY:
        case UT_STRING:
        case UT_BLOCK:
        case UT_PAREN:
        case UT_VECTOR:
        case UT_LIST:
            if( (a->series.n == b->series.n) &&
                (a->series.it == b->series.it) )
                return 1;
            break;

        case UT_CONTEXT:
            if( (a->ctx.wordBlk == b->ctx.wordBlk) &&
                (a->ctx.valBlk == b->ctx.valBlk) )
                return 1;
            break;

        case UT_DATE:
        case UT_TIME:
            if( ur_seconds(a) == ur_seconds(b) )
                return 1;
            break;

        default:
            if( ur_type(a) >= UT_BI_COUNT )
            {
                UDatatypeCmpFunc func = CUSTOM_DT( ur_type(a) ).compare;
                return func( ut, a, b, 1 );
            }
            break;
    }
    return 0;
}


// (val val -- logic)
UR_CALL( uc_equal )
{
    UR_S_DROP;
    ur_logic(UR_TOS) = ur_equal( ut, UR_TOS, tos );
    ur_initType( UR_TOS, UT_LOGIC );
}


// (val val -- logic)
UR_CALL( uc_sameQ )
{
    int same;
    UCell* res = ur_s_prev(tos);

    UR_S_DROP;

    same = ur_same( ut, res, tos );
    ur_initType( res, UT_LOGIC );
    ur_logic(res) = same;
}


// (val -- logic)
UR_CALL( uc_zeroQ )
{
    int n;
    UR_CALL_UNUSED_TH

    if( ur_is(tos, UT_INT) || ur_is(tos, UT_LOGIC) )
        n = ur_int(tos) ? 0 : 1;
    else if( ur_is(tos, UT_DECIMAL) )
        n = ur_decimal(tos) ? 0 : 1;
#ifdef UR_CONFIG_MATH3D
    else if( ur_is(tos, UT_VEC3) )
    {
        n = (tos->vec3.xyz[0] == 0.0 &&
             tos->vec3.xyz[1] == 0.0 &&
             tos->vec3.xyz[2] == 0.0) ? 1 : 0;
    }
#endif
    else
        n = 0;
    ur_initType(tos, UT_LOGIC);
    ur_logic(tos) = n;
}


// (val -- datatype)
UR_CALL( uc_typeQ )
{
    int t = ur_type(tos);
    UR_CALL_UNUSED_TH
    ur_initType(tos, UT_DATATYPE);
    ur_datatype(tos) = t;
    ur_setDatatypeMask(tos, t);
}


// (val -- word)
UR_CALL( uc_typeQ_word )
{
    int t = ur_type(tos);
    UR_CALL_UNUSED_TH
    ur_initType(tos, UT_WORD);
    tos->word.wordBlk = 0;
    tos->word.valBlk  = BLK_GLOBAL_VAL;
    tos->word.index   = t;
    tos->word.atom    = t;
}


UR_CALL( _probe )
{
    // The tos argument is NOT assumed to be on the stack here.
#if 1
    UString* str;
    str = ur_threadTmp( ut );
    str->used = 0;
    ur_toStr( tos, str, 0 );
    ur_arrayReserve( str, sizeof(char), str->used + 1 );
    str->ptr.c[ str->used++ ] = '\n';

    UR_S_GROW;
    tos = UR_TOS;
    ur_initType( tos, UT_STRING );
    ur_setSeries( tos, BIN_THREAD_TMP, 0 );
    uc_console_out( ut, tos );
#else
    UString str;

    ur_arrayInit( &str, 1, 0 );
    ur_toStr( tos, &str, 0 );
    if( str.used )
    {
        UString* sp = &str;
        ur_termCStr( sp );

        dprint( str.ptr.c );
        dprint( "\n" );
    }
    ur_arrayFree( &str );
#endif
}


#ifdef LANG_THUNE
// (val -- )
UR_CALL( uc_showTOS )
{
    _probe( ut, tos );
    UR_S_SAFE_DROP;
}


UR_CALL( uc_printTOS )
{
    _probe( ut, tos );
}


// ( -- n)
UR_CALL( uc_stack_level )
{
    UR_CALL_UNUSED_TOS;

    UR_S_GROW;
    ur_initType(UR_TOS, UT_INT);
    ur_int(UR_TOS) = UR_TOS - UR_BOS;
}
#endif


// ( -- )
UR_CALL( uc_showStack )
{
    UCell* it = tos;
    UCell* end = ut->dstack;

    if( it >= (end + UR_DSTACK_SIZE) )
    {
        dprint( "Stack overflow (%d)\n", (int) (it - end) );
        assert( 0 );
    }

    while( it != end )
    {
        _probe( ut, it );
        --it;
    }

#ifdef LANG_RUNE
    UR_S_GROW;
#endif
}


/*--------------------------------------------------------------------------*/


/*
  (val word -- )
  (val word context -- )    Add word to context.

  If val is a series and word is a block then the words are set to the
  first N elements of the series (where N is the number of words in word).
*/
UR_CALL( uc_set )
{
    UBlock* blk;
    UCell* cell;
    UCell* val;

    val = ur_s_prev( tos );

    if( ur_isAWord(tos) )
    {
        if( ur_wordIsUnbound(tos) )
        {
            if( tos->word.valBlk == BLK_GLOBAL_VAL )
            {
                tos->word.index = ur_internWord( &ur_thrGlobal, ur_atom(tos) );
            }
            else    
            {
                _throwUnbound( ut, tos );
                return;
            }
        }

        cell = ur_wordCell( ut, tos );
        if( ! cell )
            return;
        ur_copyCell( cell, *val );
    }
    else if( ur_is(tos, UT_BLOCK) )
    {
        UCell* it;
        UCell* end;

        blk = ur_block(tos);
        UR_ITER_BLOCK( it, end, blk, tos );

        if( ur_isASeries(val) )
        {
            int n = 0;
            while( it != end )
            {
                if( ur_isAWord(it) )
                {
                    cell = ur_wordCell( ut, it );
                    if( ! cell )
                        return;
                    ur_pick( ut, val, n++, cell );
                }
                ++it;
            }
        }
        else
        {
            while( it != end )
            {
                if( ur_isAWord(it) )
                {
                    cell = ur_wordCell( ut, it );
                    if( ! cell )
                        return;
                    ur_copyCell( cell, *val );
                }
                ++it;
            }
        }
    }
    else if( ur_is(tos, UT_CONTEXT) &&
             (ur_isAWord(val) || ur_is(val,UT_OPCODE)) )
    {
        int wrdN;
        wrdN = ur_internWord( tos, ur_atom(val) );
        cell = ur_blockPtr( tos->ctx.valBlk )->ptr.cells + wrdN;
        val = ur_s_prev(val);
        ur_copyCell( cell, *val );
        UR_S_DROP;
    }
    else
    {
        ur_throwErr( UR_ERR_DATATYPE, "set expected word!" );
        return;