root/trunk/orca/context.c

/*============================================================================
    ORCA Interpreter
    Copyright (C) 2005-2006  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 <assert.h>
#include "os.h"
#include "ovalue.h"
#include "internal.h"
#include "orca_atoms.h"


typedef struct
{
    uint16_t nameIndex;     // Index into BIN_ATOM_NAMES ptr.c
    uint16_t nameLen;
}
AtomRec;


/**
  Appends atom name to string.
*/
void orAtomStr( OAtom atom, OString* str )
{
    OBinary* names;
    AtomRec* rec;

    rec = ((AtomRec*) orEnv->atoms.buf) + atom;
    names = orStringPtr( BIN_ATOM_NAMES );

    orArrayReserve( str, sizeof(char), str->used + rec->nameLen );
    memCpy( str->charArray + str->used,
            names->charArray + rec->nameIndex,
            rec->nameLen );
    str->used += rec->nameLen;
}


const char* orAtomCString( OAtom atom )
{
    static char buf[ MAX_WORD_LEN + 1 ];
    OBinary* names;
    AtomRec* rec;

    rec = ((AtomRec*) orEnv->atoms.buf) + atom;
    names = orStringPtr( BIN_ATOM_NAMES );

    memCpy( buf, names->charArray + rec->nameIndex, rec->nameLen );
    buf[ rec->nameLen ] = '\0';
    return buf;
}


/**
  Add atom to environment.

  \param str  Name of atom.
  \param len  Number of characters.  Str will be truncated if greater than 32.

  \returns Atom
*/
OAtom orInternAtom( const char* str, int len )
{
    char* cp;
    const char* ep;
    const char* sp;
    OArray* atoms;
    OString* names;
    AtomRec* rec;
    AtomRec* end;
    char buf[ MAX_WORD_LEN ];


    assert( len > 0 );

    if( len > MAX_WORD_LEN )
        len = MAX_WORD_LEN;

    // Make lowercase.

    cp = buf;
    ep = buf + len;
    while( cp != ep )
    {
        int c = *str++;
        if( c >= 'A' && c <= 'Z' )
            c -= 'A' - 'a';
        *cp++ = c;
    }

    // Check if atom already exists.

    atoms = &orEnv->atoms;
    rec = (AtomRec*) atoms->buf;
    end = rec + atoms->used;

    names = orStringPtr( BIN_ATOM_NAMES );

    while( rec != end )
    {
        if( rec->nameLen == len )
        {
            sp = names->charArray + rec->nameIndex;
            cp = buf;
            while( cp != ep )
            {
                if( *sp++ != *cp )
                    break;
                ++cp;
            }

            if( cp == ep )
                goto done;
        }
        ++rec;
    }


    // Nope, add new atom.

    OA_EXPAND1( AtomRec, atoms, rec );
    rec->nameIndex = names->used;
    rec->nameLen   = len;

    orArrayReserve( names, sizeof(char), names->used + len );
    memCpy( names->charArray + names->used, buf, len );
    names->used += len;

done:

    return rec - ((AtomRec*) atoms->buf);
}


OIndex orInternA( OBlock* wordBlk, OAtom atom )
{
    OValue* it;
    OValue* end;

    it  = wordBlk->values;
    end = it + wordBlk->used;

    while( it != end )
    {
        if( orAtom(it) == atom )
            return it - wordBlk->values;
        ++it;
    }

    // Add new word.

    OA_EXPAND1( OValue, wordBlk, it );
    orSetTF( it, OT_WORD );
    orSetWord( it, GLOBAL_WORDS_BLKN, GLOBAL_CTXN, 0, atom );

    return it - wordBlk->values;
}


/**
  Add word to context and return pointer to value.
  If the word did not already exist then the value is initialied as unset.
  If wordV is non-zero then wordV->word is bound to the new value.
*/
OValue* orIntern( OContext* ctx, const char* str, int len, OValue* wordV )
{
    OAtom  atom;
    OIndex n;
    int    count;
    OValue* val;
    OBlock* wblk = orBlockPtr( ctx->wblkN );
    OBlock* vblk = orBlockPtr( ctx->vblkN );

    atom = orInternAtom( str, len );
    n    = orInternA( wblk, atom );
    count = n + 1;

    if( vblk->used < count )
    {
        orArrayReserve( vblk, sizeof(OValue), count );
        vblk->used = count;

        val = vblk->values + n;
        orSetTF( val, OT_UNSET );
    }

    if( wordV )
    {
        orSetWord( wordV, ctx->wblkN, ctx->vblkN, n, atom );
    }

    return vblk->values + n;
}


/**
  Find word in context by atom.
  Returns word index or -1 if not found.
*/
int orLookup( const OContext* ctx, int atom )
{
    OBlock* wblk;
    OValue* it;
    OValue* end;

    /* There is unused space in wblk->values which could be used to speed
       up word search.  Some ideas:
        - Min/max atom to fail early.
        - Hash.
        - Also store atoms in order and use binary search.
     */

    wblk = orBlockPtr( ctx->wblkN );
    it  = wblk->values;
    end = it + wblk->used;

    while( it != end )
    {
        if( orAtom(it) == atom )
            return it - wblk->values;
        ++it;
    }
    return -1;
}


/**
*/
void orMakeContext( OContext* ctx, int size )
{
    ctx->wblkN = orBlockN( orMakeBlock( size ) );

    // Assuming caller checks orRefAvail.
    orRefPush( OT_BLOCK, ctx->wblkN );
    ctx->vblkN = orBlockN( orMakeBlock( size ) );
    orRefPop( 1 );
}


static void internSetWords( OContext* ctx, OValue* it, OValue* end )
{
    int wrdN;
    OBlock* wordBlk = orBlockPtr( ctx->wblkN );

    while( it != end )
    {
        if( it->type == OT_SETWORD )
        {
            // Word might be redefined mulitple times so we have to
            // orLookup() first.
            wrdN = orLookup( ctx, orAtom(it) );
            if( wrdN < 0 )
                wrdN = orInternA( wordBlk, orAtom(it) );
        }
        ++it;
    }
}


static void unsetValues( OValue* it, OValue* end )
{
    while( it != end )
    {
        orSetTF( it, OT_UNSET );
        ++it;
    }
}


/**
  Returns 0 if fails.
*/
int orMakeObject( OBlock* pblk, int blkI, OContext* ctx )
{
    OBlock* wblk;
    OBlock* vblk;
    OValue* it;
    OValue* end;
    OIndex blkN;
    int wcount;


    if( ! orRefAvail( 4 ) )
        return 0;

    wcount = 0;
    it  = pblk->values + blkI;
    end = pblk->values + pblk->used;
    while( it != end )
    {
        // This could be optimized to not count duplicate words.
        if( it->type == OT_SETWORD )
            ++wcount;
        ++it;
    }

    blkN = orBlockN( pblk );
    orRefPush( OT_BLOCK, blkN );
    orMakeContext( ctx, wcount + 1 );

    // re-acquire
    wblk = orBlockPtr( ctx->wblkN );
    vblk = orBlockPtr( ctx->vblkN );
    pblk = orBlockPtr( blkN );

    // Intern words.
    it = pblk->values + blkI;
    orInternA( wblk, OR_ATOM_SELF );
    internSetWords( ctx, it, end );

    vblk->used = wblk->used;
    it = vblk->values;
    orSetTF( it, OT_OBJECT );
    it->ctx = *ctx;
    unsetValues( it + 1, it + vblk->used );

    orRefPush( OT_BLOCK, ctx->wblkN );
    orRefPush( OT_BLOCK, ctx->vblkN );

    // Bind prototype block.
    orBind( pblk, ctx );

    pblk = orBlockPtr( blkN );  // re-acquire
    orEvalBlock( pblk, blkI );

    orRefPop( 3 );

    if( orErrorThrown )
        return 0;
    return 1;
}


/*
   Similar to deep orCopyBlock() but OT_FUNCTION bodies are also copied.
*/
static void copyObjectValues( OValue* copy, OValue* it, int n )
{
    OValue* end = it + n;
    while( it != end )
    {
        orCopyV( copy, *it );

        if( (it->type == OT_BLOCK) || (it->type == OT_PAREN) )
        {
            OBlock* blk = orCopyBlock( it->index, it->series.it, 1 );
            orSetSeries( copy, orBlockN(blk), 0 ); 
        }
        else if( it->type == OT_FUNCTION )
        {
            OBlock* blk = orCopyBlock( it->func.bodyBlk, 0, 1 );
            copy->func.bodyBlk = orBlockN(blk);
        }

        ++copy;
        ++it;
    }
}


/**
  Orig & clone must not point to the same OContext.
*/
void orCloneObject( const OContext* orig, OContext* clone )
{
    int size;
    OBlock* cblk;
    OBlock* vblk;
    OValue* val;


    vblk = orBlockPtr( orig->vblkN );
    size = vblk->used;
    cblk = orMakeBlock( size );
    cblk->used = size;

    clone->wblkN = orig->wblkN;
    clone->vblkN = orBlockN( cblk );

    // Point self to the new object.
    assert( cblk->avail );
    val = cblk->values;
    orSetTF( val, OT_OBJECT );
    val->ctx = *clone;

    // Must set cblk->used and clear values in case GC called in
    // copyObjectValues().
    unsetValues( val + 1, val + size );

    orRefPush( OT_BLOCK, clone->vblkN );
    vblk = orBlockPtr( orig->vblkN );   // re-acquire
    copyObjectValues( cblk->values + 1, vblk->values + 1, size - 1 );
    orRefPop( 1 );

    cblk = orBlockPtr( clone->vblkN );  // re-acquire
    orBind( cblk, clone );
}


/**
  Clones the orig context if no new members are added in the block.
  Returns new context number or -1 if fails.
*/
int orMakeClone( const OContext* orig, OContext* clone,
                 OIndex blkN, OIndex blkI )
{
    OBlock* pblk;
    OBlock* vblk;
    OBlock* cblk;
    OValue* it;
    OValue* end;
    int wcount;
    int origUsed;


    if( ! orRefAvail( 3 ) )
        return -1;

    orRefPush( OT_BLOCK, blkN );

    vblk = orBlockPtr( orig->vblkN );
    wcount = origUsed = vblk->used;

    pblk = orBlockPtr( blkN );
    it  = pblk->values + blkI;
    end = pblk->values + pblk->used;
    while( it != end )
    {
        if( it->type == OT_SETWORD )
        {
            if( orLookup( orig, orAtom(it) ) < 0 )
                ++wcount;
        }
        ++it;
    }

    if( wcount == origUsed )
    {
        orCloneObject( orig, clone );
    }
    else
    {
        orMakeContext( clone, wcount );

        // Re-acquire.
        pblk = orBlockPtr( blkN );
        cblk = orBlockPtr( clone->wblkN );
        vblk = orBlockPtr( orig->wblkN );

        assert( cblk->avail );
        memCpy( cblk->values, vblk->values, sizeof(OValue) * origUsed );
        cblk->used = origUsed;
        internSetWords( clone, pblk->values + blkI, end );
        wcount = cblk->used;


        vblk = orBlockPtr( orig->vblkN );
        cblk = orBlockPtr( clone->vblkN );
        cblk->used = wcount;

        // Point self to the new object.
        it = cblk->values;
        orSetTF( it, OT_OBJECT );
        it->ctx = *clone;

        unsetValues( it + 1, it + wcount );

        orRefPush( OT_BLOCK, clone->wblkN );
        orRefPush( OT_BLOCK, clone->vblkN );
        copyObjectValues( it + 1, vblk->values + 1, origUsed - 1 );
        orRefPop( 2 );
    }

    orBind( orBlockPtr( blkN ), clone );

    orRefPop( 1 );

    orRefPush( OT_BLOCK, clone->wblkN );
    orRefPush( OT_BLOCK, clone->vblkN );
    orEvalBlock( orBlockPtr( blkN ), blkI );
    orRefPop( 2 );

    if( orErrorThrown )
        return 0;

    return 1;
}


static void orBindWordVal( OValue* val, OContext* ctx )
{
    int wrdN;
    wrdN = orLookup( ctx, orAtom(val) );
    if( wrdN > -1 )
    {
        val->word.context = ctx->vblkN;
        val->word.wordBlk = ctx->wblkN;
        val->word.index   = wrdN;
        // Atom remains the same.
    }
}


void orBind( OBlock* blk, OContext* ctx )
{
    OValue* it  = blk->values;
    OValue* end = it + blk->used;

    while( it != end )
    {
        if( (it->type == OT_WORD) ||
            (it->type == OT_SETWORD) ||
            (it->type == OT_LITWORD) ||
            (it->type == OT_GETWORD) )
        {
            orBindWordVal( it, ctx );
        }
        else if( (it->type == OT_PATH) || (it->type == OT_SETPATH) )
        {
            OValue* path1 = orBLOCK( it )->values;
            if( (path1->type == OT_WORD) ||
                (path1->type == OT_SETWORD) ||
                (path1->type == OT_GETWORD) )
                orBindWordVal( path1, ctx );
        }
        else if( (it->type == OT_BLOCK) || (it->type == OT_PAREN) )
        {
            orBind( orBLOCK( it ), ctx );
        }
        else if( it->type == OT_FUNCTION )
        {
            orBind( orBlockPtr( it->func.bodyBlk ), ctx );

            // NOTE: Will probably need to rebind to local func context in
            // case ctx contains the same words. 
            //orBind( orBlockPtr( it->func.bodyBlk ), it->func.context );
        }

        ++it;
    }
}


#if 0
/*
   Returns true if block contains does or func.
*/
int orClosureRequired( OIndex blkN )
{
    OBlock* blk = orBlockPtr( blkN );
    OValue* it  = blk->values;
    OValue* end = it + blk->used;

    while( it != end )
    {
        if( (it->type == OT_WORD) ||
            (it->type == OT_SETWORD) ||
            (it->type == OT_GETWORD) )
        {
            if( (orAtom(it) == OR_ATOM_FUNC) ||
                (orAtom(it) == OR_ATOM_DOES) )
                return 1;
        }
        else if( (it->type == OT_BLOCK) || (it->type == OT_PAREN) )
        {
            if( orClosureRequired( it->index ) )
                return 1;
        }

        ++it;
    }
    return 0;
}


void orRebind( OIndex blkN, OIndex from, OIndex to )
{
    OBlock* blk = orBlockPtr( blkN );
    OValue* it  = blk->values;
    OValue* end = it + blk->used;

    while( it != end )
    {
        if( (it->type == OT_WORD) ||
            (it->type == OT_SETWORD) ||
            (it->type == OT_GETWORD) )
        {
            if( it->word.context == from )
                it->word.context = to;
        }
#if 0
        else if( (it->type == OT_PATH) || (it->type == OT_SETPATH) )
        {
            OValue* path1 = orBLOCK( it )->values;
            if( (path1->type == OT_WORD) ||
                (path1->type == OT_SETWORD) ||
                (path1->type == OT_GETWORD) )
            {
                if( path1->word.context == from )
                    path1->word.context = to;
            }
        }
#endif
        else if( (it->type == OT_BLOCK) || (it->type == OT_PAREN) )
        {
            orRebind( it->index, from, to );
        }

        ++it;
    }
}
#endif


/*
   words      [block! word!]
   known-word [word! object!]
   /copy
*/
OR_NATIVE_PUB( orBindNative )
{
#define REF_BIND_COPY   a1 + 2

    OValue* a2 = a1 + 1;
    OContext ctx;

    if( a2->type == OT_WORD )
    {
        ctx.wblkN = a2->word.wordBlk;
        ctx.vblkN = a2->word.context;
    }
    else
    {
        ctx = a2->ctx;
    }

    if( a1->type == OT_BLOCK )
    {
        OBlock* blk;

        if( orRefineSet(REF_BIND_COPY) )
            blk = orCopyBlock( a1->index, 0, 1 );
        else
            blk = orBLOCK( a1 );

        orResult( OT_BLOCK, orBlockN(blk) );

        orBind( blk, &ctx );
    }
    /*
    else if( a1->type == OT_WORD )
    {
    }
    */
    else
    {
        orError( "Invalid bind values" );
    }
}


OR_NATIVE_PUB( orProtectNative )
{
    OBlock* vblk;
    OContext ctx;
    int wrdN;

    orGlobalCtx( ctx );
    vblk = orBlockPtr( ctx.wblkN );

    if( orIs(a1, OT_WORD) )
    {
        wrdN = orLookup( &ctx, orAtom(a1) );
        if( wrdN > -1 )
        {
            vblk->values[ wrdN ].flags |= OR_WORD_PROT;
        }
    }
    else if( orIs(a1, OT_BLOCK) )
    {
        OBlock* blk = orBLOCK( a1 );
        OValue* it  = blk->values;
        OValue* end = it + blk->used;
        while( it != end )
        {
            if( orIs(it, OT_WORD) )
            {
                wrdN = orLookup( &ctx, orAtom(a1) );
                if( wrdN > -1 )
                {
                    vblk->values[ wrdN ].flags |= OR_WORD_PROT;
                }
            }
            ++it;
        }
    }
    orResultUNSET;
}


/*
   object [object!]
   word   [word!]
*/
OR_NATIVE_PUB( orInNative )
{
    OValue* a2 = a1 + 1;
    OIndex wrdN;

    wrdN = orLookup( &a1->ctx, orAtom(a2) );
    if( wrdN < 0 )
    {
        orResultNONE;
    }
    else
    {
        orSetTF( a1, OT_WORD );
        // a1->context remains unchanged.
        a1->word.index = wrdN;
        orAtom(a1)     = orAtom(a2);
    }
}


/*
   words [block! word!]
   body  [block!]
*/
OR_NATIVE_PUB( orUseNative )
{
    OContext ctx;
    OBlock* blk;
    OValue* it;
    OValue* end;
    OValue* a2 = a1 + 1;


    orRefAvailErr( 2 )
    orRefPush( OT_BLOCK, a2->index );

    if( a1->type == OT_WORD )
    {
        orMakeContext( &ctx, 1 );
        orInternA( orBlockPtr( ctx.wblkN ), orAtom(a1) );
    }
    else
    {
        orRefPush( OT_BLOCK, a1->index );

        blk = orBLOCK( a1 );
        it  = blk->values + a1->series.it;
        end = blk->values + blk->used;

        orMakeContext( &ctx, end - it );
        blk = orBlockPtr( ctx.wblkN );

        while( it != end )
        {
            if( it->type == OT_WORD )
                orInternA( blk, orAtom(it) );
            ++it;
        }

        orRefPop( 1 );
    }

    blk = orBlockPtr( ctx.vblkN );
    it  = blk->values;
    end = it + blk->used;
    while( it != end )
    {
        orSetTF( it, OT_UNSET );
        ++it;
    }

    orBind( orBlockPtr( a2->index ), &ctx );

    orRefPop( 1 );

    orEvalBlock( orBlockPtr( a2->index ), a2->series.it );
}


/*
   'variables   [word! block!]
   series       [series!]
   body         [block!]
*/
OR_NATIVE_PUB( orForeachNative )
{
#ifdef OR_CONFIG_REBOL
    int rlen;
    int vlen;
    OBlock* blk;
    OValue* wval;
    OContext ctx;
    OValue* a2 = a1 + 1;
    OIndex serN = a2->index;
    OIndex si   = a2->series.it;
    OIndex send;
    OIndex body = (a1 + 2)->index;
    OIndex bi   = (a1 + 2)->series.it;


    // Binding a copy of the body to a private context is horribly
    // expensive but what choice do we have?
    // Still, 'foreach is faster than 'forall (probably because using paths
    // is so slow).

    orRefAvailErr( 4 )

    // Must hold body & a2 in case orMakeContext() or orCopyBlock() trigger
    // recycle.
    orRefPush( OT_BLOCK, body );
    orRefPush( a2->type, a2->index );

    if( a1->type == OT_BLOCK )
    {
        OValue* it;
        OValue* end;

        blk = orBLOCK(a1);

        orRefPush( OT_BLOCK, a1->index );
        orMakeContext( &ctx, blk->used - a1->series.it );
        orRefPop( 1 );

        it  = blk->values + a1->series.it;
        end = blk->values + blk->used;

        blk = orBlockPtr( ctx.wblkN );
        while( it != end )
        {
            if( it->type == OT_WORD )
            {
                orInternA( blk, orAtom(it) );
            }
            else
            {
                orError( "Invalid foreach argument" );
                orRefPop( 2 );
                return;
            }
            ++it;
        }

    }
    else
    {
        orMakeContext( &ctx, 1 );
        orInternA( orBlockPtr( ctx.wblkN ), orAtom(a1) );
    }

    orRefPush( OT_BLOCK, ctx.wblkN );
    orRefPush( OT_BLOCK, ctx.vblkN );

    blk = orBlockPtr( ctx.vblkN );
    wval = blk->values;
    vlen = blk->avail;

    blk = orCopyBlock( body, bi, 1 );
    body = orBlockN( blk );
    bi   = 0;
    a1[2].series.n = body;      // Replace original on stack to keep from GC.
    orBind( blk, &ctx );


    switch( a2->type )
    {
        case OT_BLOCK:
        case OT_PAREN:
        case OT_PATH:
        {
            blk = orBlockPtr( serN );
            send = blk->used;

            if( vlen > 1 )
                send -= vlen - 1;

            while( si < send )
            {
                memCpy( wval, blk->values + si, vlen * sizeof(OValue) );
                si += vlen;

                orEvalBlock( orBlockPtr( body ), bi );
                if( orErrorThrown )
                    goto error;
                blk = orBlockPtr( serN );          // Reacquire.
            }

            if( si < blk->used )
            {
                rlen = blk->used - si;

                memCpy( wval, blk->values + si, rlen * sizeof(OValue) );
                wval += rlen;

                while( rlen < vlen )
                {
                    orSetTF( wval, OT_NONE );
                    ++wval;
                    ++rlen;
                }

                orEvalBlock( orBlockPtr( body ), bi );
                if( orErrorThrown )
                    goto error;
            }
        }
            break;

        case OT_STRING:
        case OT_FILE:
        case OT_ISSUE:
        case OT_TAG:
        {
            OString* str = orStringPtr( serN );
            send = str->used;

            orSetTF( wval, OT_CHAR );

            if( vlen > 1 )
            {
                send -= vlen - 1;

                for( rlen = 1; rlen < vlen; ++rlen )
                    orSetTF( (wval + rlen), OT_CHAR );
            }

            while( si < send )
            {
                for( rlen = 0; rlen < vlen; ++rlen )
                    orInt(wval + rlen) = str->charArray[ si++ ];

                orEvalBlock( orBlockPtr( body ), bi );
                if( orErrorThrown )
                    goto error;
                str = orStringPtr( serN );     // Reacquire.
            }

            if( si < str->used )
            {
                rlen = str->used - si;

                while( si < str->used )
                {
                    orInt(wval) = str->charArray[ si++ ];
                    ++wval;
                }

                while( rlen < vlen )
                {
                    orSetTF( wval, OT_NONE );
                    ++wval;
                    ++rlen;
                }

                orEvalBlock( orBlockPtr( body ), bi );
                if( orErrorThrown )
                    goto error;
            }
        }
            break;

        case OT_LIST:
            if( a1->type == OT_BLOCK )
            {
                orError( "foreach block! list! not implemented" );
                break;
            }

            orResultNONE;

            if( a2->series.it )
            {
                OValue* begin;
                OValue* it;

                blk = orBLOCK(a2);
                begin = blk->values;
                it    = begin + a2->series.it;

                while( it->LIST_NEXT > 0 )
                {
                    orCopyV( wval, it[1] );

                    orEvalBlock( orBlockPtr( body ), bi );
                    if( orErrorThrown )
                        goto error;

                    //blk = orBlockPtr( serN );          // Reacquire.
                    //orListNextNode( blk, it );
                    it = begin + it->LIST_NEXT;
                }
            }
            break;
    }

free_private:

    orFreeBlock( body );
    orFreeBlock( ctx.wblkN );
    orFreeBlock( ctx.vblkN );
    goto pop;

error:

    if( orErrorIsType(OR_ERROR_BREAK) )
    {
        orErrorClear;
        orSetTF( a1, OT_UNSET );
        goto free_private;
    }

    // Cannot free body block if error is thrown and orError->block == body.

pop:

    orRefPop( 4 );

#else  // --------------------------------------------------------------
    // Foreach without context creation overhead.
    // (Does not bind or allocate from heap).

    OBlock* blk;
    OBlock* cblk;
    OValue* val;
    OValue* wit;
    OValue* wval;
    OValue* wend;
    OValue* a2 = a1 + 1;
    OIndex serN = a2->index;
    OIndex si   = a2->series.it;
    OIndex send;
    OIndex body = (a1 + 2)->index;
    OIndex bi   = (a1 + 2)->series.it;
    OValue saveA1;


    orRefAvailErr( 2 )

    if( a1->type == OT_BLOCK )
    {
        blk = orBLOCK( a1 );
        wval = blk->values + a1->series.it;
        wend = blk->values + blk->used;

        orRefPush( OT_BLOCK, a1->index );
    }
    else
    {
        orCopyV( &saveA1, *a1 );
        wval = &saveA1;
        wend = wval + 1;

        orRefPush( OT_BLOCK, a1->word.context );
    }

    orRefPush( a2->type, a2->index );

    switch( a2->type )
    {
        case OT_BLOCK:
        case OT_PAREN:
        case OT_PATH:
        {
            blk = orBlockPtr( serN );
            send = blk->used;

            while( si < send )
            {
                wit = wval;
                while( wit != wend )
                {
                    if( orIs(wit, OT_WORD) )
                    {
                        orWordVal( wit, cblk, val );
                        if( si < send )
                        {
                            orCopyV( val, blk->values[si] );
                        }
                        else
                        {
                            orSetTF( val, OT_NONE );
                        }
                        ++si;
                    }
                    ++wit;
                }

                orEvalBlock( orBlockPtr( body ), bi );
                if( orErrorThrown )
                    goto error;
                blk = orBlockPtr( serN );          // Reacquire.
            }
        }
            break;

        case OT_STRING:
        case OT_FILE:
        case OT_ISSUE:
        case OT_TAG:
        {
            OString* str = orStringPtr( serN );
            send = str->used;

            while( si < send )
            {
                wit = wval;
                while( wit != wend )
                {
                    if( orIs(wit, OT_WORD) )
                    {
                        orWordVal( wit, cblk, val );
                        if( si < send )
                        {
                            orSetTF( val, OT_CHAR );
                            orInt(val) = str->charArray[ si ];
                        }
                        else
                        {
                            orSetTF( val, OT_NONE );
                        }
                        ++si;
                    }
                    ++wit;
                }

                orEvalBlock( orBlockPtr( body ), bi );
                if( orErrorThrown )
                    goto error;
                str = orStringPtr( serN );     // Reacquire.
            }
        }
            break;

        case OT_LIST:
            if( a1->type == OT_BLOCK )
            {
                orError( "foreach block! list! not implemented" );
                break;
            }

            orResultNONE;

            if( a2->series.it )
            {
                OValue* begin;
                OValue* it;

                orWordVal( a1, cblk, wval );

                blk = orBLOCK(a2);
                begin = blk->values;
                it    = begin + a2->series.it;

                while( it->LIST_NEXT > 0 )
                {
                    orCopyV( wval, it[1] );

                    orEvalBlock( orBlockPtr( body ), bi );
                    if( orErrorThrown )
                        goto error;

                    //blk = orBlockPtr( serN );          // Reacquire.
                    //orListNextNode( blk, it );
                    it = begin + it->LIST_NEXT;
                }
            }
            break;

#ifdef OR_CONFIG_NUMBER_ARRAYS
        // TODO
        case OT_DEC_ARRAY:
            break;
        case OT_INT_ARRAY:
            break;
#endif
    }
    goto pop;

error:

    if( orErrorIsType(OR_ERROR_BREAK) )
    {
        orErrorClear;
        orSetTF( a1, OT_UNSET );
    }

pop:

    orRefPop( 2 );
#endif
}


/*
  foreach: native [
    'variables   [word! block!]
    series       [series!]
    body         [block!]
  ]
*/
//see