root/trunk/orca/error.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 "os.h"
#include "ovalue.h"
#include "internal.h"
#include "orca_atoms.h"


/**
  orLookupPath is provided as a fast but still convenient method of resolving
  paths from C code.

  Pass a sequence of datatype (OT_*) / value (atom/index) pairs terminated
  by OR_LPATH_END to specify the path.

  Returns zero if the path is not valid.

  Using a string argument rather than a tag list would be more convenient
  but not as quick.
*/
OValue* orLookupPath( int first_tag, ... )
{
    va_list args;
    int tag;
    int data;
    OIndex wrd;
    OContext ctx;
    OValue* val;
    OBlock* blk;

    orGlobalCtx( ctx );
    blk = 0;
    val = 0;

    va_start(args, first_tag);
    tag = first_tag;

    while( tag != OR_LPATH_END )
    {
        data = va_arg(args, int);
        switch( tag )
        {
            case OT_WORD:
                wrd = orLookup( &ctx, data );
                if( wrd < 0 )
                {
                    val = 0;
                    goto abort;
                }
                {
                OBlock* vblk = orBlockPtr( ctx.vblkN );
                val = vblk->values + wrd;
                if( orIs(val, OT_OBJECT) )
                {
                    ctx = val->ctx;
                    blk = 0;
                }
                else if( orIs(val, OT_BLOCK) )
                {
                    orGlobalCtx( ctx );
                    blk = orBLOCKS + val->index;
                }
                }
                break;

            case OT_INTEGER:
                if( ! blk )
                {
                    val = 0;
                    goto abort;
                }
                val = blk->values + data;
                break;

            default:
                val = 0;
                goto abort;
                break;
        }
        tag = va_arg(args, int);
    }

abort:

    va_end(args);

    return val;
}


/**
  Convert error! to object!.
*/
OR_NATIVE_PUB( orDisarmNative )
{
    if( orIs(a1, OT_ERROR) )
    {
        OValue* val;
        OValue* tval;

        val = orLookupPath( OT_WORD, OR_ATOM_SYSTEM,
                            OT_WORD, OR_ATOM_ERROR,
                            OR_LPATH_END );
        if( val && orIs(val, OT_OBJECT) )
        {
            int errType;
            OContext ctx;
            OBlock* vblk;

            // self msg: type: id: near: none

            orCloneObject( &val->ctx, &ctx );
            vblk = orBlockPtr( ctx.vblkN );

            val = vblk->values + 1;

            errType = orErrorType(a1);

            if( errType == OR_ERROR_THROW )
            {
                OContext gctx;
                orGlobalCtx( gctx );

                orSetTF( val, OT_WORD );
                orSetWord( val, GLOBAL_WORDS_BLKN, GLOBAL_CTXN,
                           orLookup( &gctx, a1->error.msg ),
                           a1->error.msg );
            }
            else
            {
                orSetTF( val, OT_STRING );
                orSetSeries( val, a1->error.msg, 0 );
            }


            tval = orLookupPath( OT_WORD, OR_ATOM_SYSTEM,
                                 OT_WORD, OR_ATOM_ERROR_TYPES,
                                 OR_LPATH_END );
            ++val;
            if( tval && orIs(tval, OT_BLOCK) )
            {
                OBlock* blk = orBLOCK(tval);
                if( errType < blk->used )
                {
                    *val = blk->values[ errType ];
                    goto end_type;
                }
            }
            orSetTF( val, OT_INTEGER );
            orInt(val) = errType;
end_type:

            /* id
            ++val;
            orSetTF( val, OT_INTEGER );
            orInt(val) = a1->error.msg;
            */

            orSetTF( a1, OT_OBJECT );
            a1->ctx = ctx;
            return;
        }
    }
    orResultNONE
}


/*EOF*/