tads-3.0.8/tads3/vmbift3.cpp

#ifdef RCSID
static char RCSid[] =
"$Header: d:/cvsroot/tads/tads3/VMBIFTAD.CPP,v 1.3 1999/07/11 00:46:58 MJRoberts Exp $";
#endif

/*
 *   Copyright (c) 1999, 2002 Michael J. Roberts.  All Rights Reserved.
 *
 *   Please see the accompanying license file, LICENSE.TXT, for information
 *   on using and copying this software.
 */
/*
Name
  vmbift3.cpp - T3 VM system interface function set
Function

Notes

Modified
  04/05/99 MJRoberts  - Creation
*/

#include <stdio.h>
#include <string.h>

#include "utf8.h"
#include "vmbif.h"
#include "vmbift3.h"
#include "vmstack.h"
#include "vmerr.h"
#include "vmerrnum.h"
#include "vmglob.h"
#include "vmpool.h"
#include "vmobj.h"
#include "vmrun.h"
#include "vmstr.h"
#include "vmvsn.h"
#include "vmimage.h"
#include "vmlst.h"
#include "vmtobj.h"
#include "vmfunc.h"
#include "vmpredef.h"
#include "vmsrcf.h"
#include "charmap.h"


/*
 *   run the garbage collector
 */
void CVmBifT3::run_gc(VMG_ uint argc)
{
    /* no arguments are allowed */
    check_argc(vmg_ argc, 0);

    /* run the garbage collector */
    G_obj_table->gc_full(vmg0_);
}

/*
 *   set the SAY instruction's handler function
 */
#define SETSAY_NO_FUNC    1
#define SETSAY_NO_METHOD  2
void CVmBifT3::set_say(VMG_ uint argc)
{
    vm_val_t *arg = G_stk->get(0);
    vm_val_t val;

    /* one argument is required */
    check_argc(vmg_ argc, 1);

    /* check to see if we're setting the default display method */
    if (arg->typ == VM_PROP
        || (arg->typ == VM_INT && arg->val.intval == SETSAY_NO_METHOD))
    {
        vm_prop_id_t prop;

        /*
         *   the return value is the old property pointer (or
         *   SETSAY_NO_METHOD if there was no valid property set previously)
         */
        prop = G_interpreter->get_say_method();
        if (prop != VM_INVALID_PROP)
            retval_prop(vmg_ prop);
        else
            retval_int(vmg_ SETSAY_NO_METHOD);

        /* get the new value */
        G_stk->pop(&val);

        /* if it's SETSAY_NO_METHOD, set it to the invalid prop ID */
        if (val.typ == VM_INT)
            val.set_propid(VM_INVALID_PROP);

        /* set the method */
        G_interpreter->set_say_method(val.val.prop);
    }
    else if (arg->typ == VM_FUNCPTR
             || arg->typ == VM_OBJ
             || (arg->typ == VM_INT && arg->val.intval == SETSAY_NO_FUNC))
    {
        /*
         *   the return value is the old function (or SETSAY_NO_FUNC if the
         *   old function was nil)
         */
        G_interpreter->get_say_func(&val);
        if (val.typ != VM_NIL)
            retval(vmg_ &val);
        else
            retval_int(vmg_ SETSAY_NO_FUNC);

        /* get the new function value */
        G_stk->pop(&val);

        /* if it's SETSAY_NO_FUNC, set the function to nil */
        if (val.typ == VM_INT)
            val.set_nil();

        /* set the new function */
        G_interpreter->set_say_func(vmg_ &val);
    }
    else
    {
        /* invalid type */
        err_throw(VMERR_BAD_TYPE_BIF);
    }
}

/*
 *   get the VM version number
 */
void CVmBifT3::get_vm_vsn(VMG_ uint argc)
{
    /* no arguments are allowed */
    check_argc(vmg_ argc, 0);

    /* set the integer return value */
    retval_int(vmg_ T3VM_VSN_NUMBER);
}

/*
 *   get the VM identification string
 */
void CVmBifT3::get_vm_id(VMG_ uint argc)
{
    /* no arguments are allowed */
    check_argc(vmg_ argc, 0);

    /* set the integer return value */
    retval_str(vmg_ T3VM_IDENTIFICATION);
}


/*
 *   get the VM banner string
 */
void CVmBifT3::get_vm_banner(VMG_ uint argc)
{
    /* no arguments are allowed */
    check_argc(vmg_ argc, 0);

    /* return the string */
    retval_str(vmg_ T3VM_BANNER_STRING);
}

/*
 *   get the 'preinit' status - true if preinit, nil if normal
 */
void CVmBifT3::get_vm_preinit_mode(VMG_ uint argc)
{
    /* no arguments allowed */
    check_argc(vmg_ argc, 0);

    /* return the preinit mode */
    retval_int(vmg_ G_preinit_mode);
}

/*
 *   get the runtime symbol table
 */
void CVmBifT3::get_global_symtab(VMG_ uint argc)
{
    /* check arguments */
    check_argc(vmg_ argc, 0);

    /* return the loader's symbol table object, if any */
    retval_obj(vmg_ G_image_loader->get_reflection_symtab());
}

/*
 *   allocate a new property ID
 */
void CVmBifT3::alloc_new_prop(VMG_ uint argc)
{
    /* check arguments */
    check_argc(vmg_ argc, 0);

    /* allocate and return a new property ID */
    retval_prop(vmg_ G_image_loader->alloc_new_prop(vmg0_));
}

/*
 *   get a stack trace
 */
void CVmBifT3::get_stack_trace(VMG_ uint argc)
{
    int level;
    vm_val_t *fp;
    vm_val_t lst_val;
    CVmObjList *lst;
    pool_ofs_t entry_addr;
    ulong method_ofs;
    vm_val_t stack_info_cls;

    /* check arguments */
    check_argc(vmg_ argc, 0);

    /* get the imported stack information class */
    stack_info_cls.set_obj(G_predef->stack_info_cls);
    if (stack_info_cls.val.obj == VM_INVALID_OBJ)
    {
        /*
         *   there's no stack information class - we can't return any
         *   meaningful information, so just return nil
         */
        retval_nil(vmg0_);
        return;
    }

    /* start at the current function */
    fp = G_interpreter->get_frame_ptr();

    /* traverse the stack to determine the frame depth */
    for (level = 0 ; fp != 0 ;
         fp = G_interpreter->get_enclosing_frame_ptr(vmg_ fp), ++level) ;

    /* allocate a list to hold the result */
    lst_val.set_obj(CVmObjList::create(vmg_ FALSE, level));
    lst = (CVmObjList *)vm_objp(vmg_ lst_val.val.obj);

    /* push the list to protect it from garbage collection wihle working */
    G_stk->push(&lst_val);

    /* set up at the current function */
    fp = G_interpreter->get_frame_ptr();
    entry_addr = G_interpreter->get_entry_ptr();
    method_ofs = G_interpreter->get_method_ofs();

    /* traverse the frames */
    for (level = 0 ; fp != 0 ;
         fp = G_interpreter->get_enclosing_frame_ptr(vmg_ fp), ++level)
    {
        int fr_argc;
        int i;
        vm_obj_id_t def_obj;
        vm_val_t info_self;
        vm_val_t info_func;
        vm_val_t info_obj;
        vm_val_t info_prop;
        vm_val_t info_args;
        vm_val_t info_srcloc;
        CVmObjList *arglst;
        vm_val_t ele;
        CVmFuncPtr func_ptr;

        /*
         *   start with the information values to nil - we'll set the
         *   appropriate ones when we find out what we have
         */
        info_func.set_nil();
        info_obj.set_nil();
        info_prop.set_nil();
        info_self.set_nil();

        /* get the number of arguments to the function in this frame */
        fr_argc = G_interpreter->get_argc_from_frame(vmg_ fp);

        /* set up a function pointer for the method's entry address */
        func_ptr.set((const uchar *)G_code_pool->get_ptr(entry_addr));

        /*
         *   to ensure we don't flush the caller out of the code pool cache,
         *   resolve the current entrypoint address immediately - we always
         *   have room for at least two code pages in the cache, so we know
         *   resolving just one won't throw the previous one out, so we
         *   simply need to make the current one most recently used by
         *   resolving it
         */
        G_code_pool->get_ptr(G_interpreter->get_entry_ptr());

        /* get the current frame's defining object */
        def_obj = G_interpreter->get_defining_obj_from_frame(vmg_ fp);

        /* determine whether it's an object.prop or a function call */
        if (method_ofs == 0)
        {
            /*
             *   a zero method offset indicates a recursive VM invocation
             *   from a native function, so we have no information on the
             *   call at all
             */
            fr_argc = 0;
        }
        else if (def_obj == VM_INVALID_OBJ)
        {
            /* it's a function call */
            info_func.set_fnptr(entry_addr);
        }
        else
        {
            /* it's an object.prop invocation */
            info_obj.set_obj(def_obj); // $$$ walk up to base modified obj?
            info_prop.set_propid(
                G_interpreter->get_target_prop_from_frame(vmg_ fp));

            /* get the 'self' in this frame */
            info_self.set_obj(G_interpreter->get_self_from_frame(vmg_ fp));
        }

        /*
         *   build the argument list and source location, except for system
         *   routines
         */
        if (method_ofs != 0)
        {
            /* allocate a list object to store the argument list */
            info_args.set_obj(CVmObjList::create(vmg_ FALSE, fr_argc));
            arglst = (CVmObjList *)vm_objp(vmg_ info_args.val.obj);

            /* push the argument list for gc protection */
            G_stk->push(&info_args);

            /* build the argument list */
            for (i = 0 ; i < fr_argc ; ++i)
            {
                /* add this element to the argument list */
                arglst->cons_set_element(
                    i, G_interpreter->get_param_from_frame(vmg_ fp, i));
            }

            /* get the source location */
            get_source_info(vmg_ entry_addr, method_ofs, &info_srcloc);
        }
        else
        {
            /*
             *   it's a system routine - no argument information is
             *   available, so return nil rather than an empty list to to
             *   indicate the absence
             */
            info_args.set_nil();

            /* there's obviously no source location for system code */
            info_srcloc.set_nil();
        }

        /*
         *   We have all of the information on this level now, so create the
         *   information object for the level.  This is an object of the
         *   exported stack-info class, which is a TadsObject type.
         */
        G_stk->push(&info_srcloc);
        G_stk->push(&info_args);
        G_stk->push(&info_self);
        G_stk->push(&info_prop);
        G_stk->push(&info_obj);
        G_stk->push(&info_func);
        G_stk->push(&stack_info_cls);
        ele.set_obj(CVmObjTads::create_from_stack(vmg_ 0, 7));

        /*
         *   the argument list is safely stashed away in the stack info
         *   object, so we can discard our gc protection for it now
         */
        if (method_ofs != 0)
            G_stk->discard();

        /* add the new element to our list */
        lst->cons_set_element(level, &ele);

        /* move on to the enclosing frame */
        entry_addr =
            G_interpreter->get_enclosing_entry_ptr_from_frame(vmg_ fp);
        method_ofs = G_interpreter->get_return_ofs_from_frame(vmg_ fp);
    }

    /* return the list */
    retval_obj(vmg_ lst_val.val.obj);

    /* discard our gc protection */
    G_stk->discard();
}

/*
 *   Get the source file information for a given code pool offset.  If debug
 *   records aren't available for the given location, returns nil.  Returns
 *   a list containing the source file information: the first element is a
 *   string giving the name of the file, and the second element is an
 *   integer giving the line number in the file.  Returns nil if no source
 *   information is available for the given byte code location.
 */
void CVmBifT3::get_source_info(VMG_ ulong entry_addr, ulong method_ofs,
                               vm_val_t *retval)
{
    CVmFuncPtr func_ptr;
    CVmDbgLinePtr line_ptr;
    ulong stm_start;
    ulong stm_end;
    CVmObjList *lst;
    vm_val_t ele;
    CVmSrcfEntry *srcf;
    CVmObjString *str;
    const char *fname;
    size_t map_len;

    /* presume we won't be able to find source information for the location */
    retval->set_nil();

    /* set up a debug table pointer for the function or method */
    func_ptr.set((const uchar *)G_code_pool->get_ptr(entry_addr));

    /*
     *   resolve the current caller's entry code page to ensure it isn't
     *   flushed out of the code pool cache
     */
    G_code_pool->get_ptr(G_interpreter->get_entry_ptr());

    /* get the debug information for the given location */
    if (!CVmRun::get_stm_bounds(vmg_ &func_ptr, method_ofs,
                                &line_ptr, &stm_start, &stm_end))
    {
        /* no source information available - return failure */
        return;
    }

    /* get the source file record - if we can't find it, return failure */
    srcf = (G_srcf_table != 0
            ? G_srcf_table->get_entry(line_ptr.get_source_id()) : 0);
    if (srcf == 0)
        return;

    /*
     *   Create a list for the return value.  The return list has two
     *   elements: the name of the source file containing this code, and the
     *   line number in the file.
     */
    retval->set_obj(CVmObjList::create(vmg_ FALSE, 2));
    lst = (CVmObjList *)vm_objp(vmg_ retval->val.obj);

    /* push the list for gc protection */
    G_stk->push(retval);

    /* get the filename string */
    fname = srcf->get_name();

    /*
     *   determine how long the string will be when translated to utf8 from
     *   the local filename character set
     */
    map_len = G_cmap_from_fname->map_str(0, 0, fname);

    /*
     *   create a string value to hold the filename, and store it in the
     *   first element of the return list (note that this automatically
     *   protects the new string from garbage collection, by virtue of the
     *   list referencing the string and the list itself being protected)
     */
    ele.set_obj(CVmObjString::create(vmg_ FALSE, map_len));
    lst->cons_set_element(0, &ele);

    /* map the string into the buffer we allocated for it */
    str = (CVmObjString *)vm_objp(vmg_ ele.val.obj);
    G_cmap_from_fname->map_str(str->cons_get_buf(), map_len, fname);

    /* set the second element of the list to the source line number */
    ele.set_int(line_ptr.get_source_line());
    lst->cons_set_element(1, &ele);

    /* discard our gc protection */
    G_stk->discard();
}


/* ------------------------------------------------------------------------ */
/*
 *   T3 VM Test function set.  This function set contains internal test
 *   and debug functions.  These functions are not meant for use by
 *   "normal" programs - they provide internal access to certain VM state
 *   that is not useful or meaningful except for testing and debugging the
 *   VM itself.
 */

/*
 *   Get an object's internal ID.  Takes an object instance and returns an
 *   integer giving the object's VM ID number.  This is effectively an
 *   address that can be used to refer to the object.  Because this value
 *   is returned as an integer, it is NOT a reference to the object for
 *   the purposes of garbage collection or finalization.
 */
void CVmBifT3Test::get_obj_id(VMG_ uint argc)
{
    vm_val_t val;

    /* one argument required */
    check_argc(vmg_ argc, 1);

    /* get the object value */
    G_interpreter->pop_obj(vmg_ &val);

    /* return the object ID as an integer */
    retval_int(vmg_ (long)val.val.obj);
}

/*
 *   Get an object's garbage collection state.  Takes an object ID (NOT an
 *   object reference -- this is the integer value returned by get_obj_id)
 *   and returns a bit mask with the garbage collector state.
 *
 *   (retval & 0x000F) gives the free state.  0 is free, 1 is in use.
 *
 *   (retval & 0x00F0) gives the reachable state.  0x00 is unreachable,
 *   0x10 is finalizer-reachable, and 0x20 is fully reachable.
 *
 *   (retval & 0x0F00) gives the finalizer state.  0x000 is unfinalizable,
 *   0x100 is finalizable, and 0x200 is finalized.
 *
 *   (retval & 0xF000) gives the object ID validity.  0 is valid, 0xF000
 *   is invalid.
 */
void CVmBifT3Test::get_obj_gc_state(VMG_ uint argc)
{
    vm_val_t val;

    /* one argument required */
    check_argc(vmg_ argc, 1);

    /* pop the string */
    G_interpreter->pop_int(vmg_ &val);

    /* return the internal garbage collector state of the object */
    retval_int(vmg_
               (long)G_obj_table->get_obj_internal_state(val.val.intval));
}

/*
 *   Get the Unicode character code of the first character of a string
 */
void CVmBifT3Test::get_charcode(VMG_ uint argc)
{
    const char *str;

    /* one argument required */
    check_argc(vmg_ argc, 1);

    /* get the object ID as an integer */
    str = pop_str_val(vmg0_);

    /*
     *   if the string is empty, return nil; otherwise, return the Unicode
     *   character code of the first character
     */
    if (vmb_get_len(str) == 0)
    {
        /* empty string - return nil */
        retval_nil(vmg0_);
    }
    else
    {
        /*
         *   get the character code of the first character and return it
         *   as an integer
         */
        retval_int(vmg_ (int)utf8_ptr::s_getch(str + VMB_LEN));
    }
}