3
"$Header: d:/cvsroot/tads/tads3/VMBIFTAD.CPP,v 1.3 1999/07/11 00:46:58 MJRoberts Exp $";
7
* Copyright (c) 1999, 2002 Michael J. Roberts. All Rights Reserved.
9
* Please see the accompanying license file, LICENSE.TXT, for information
10
* on using and copying this software.
14
vmbift3.cpp - T3 VM system interface function set
20
04/05/99 MJRoberts - Creation
48
* run the garbage collector
50
void CVmBifT3::run_gc(VMG_ uint argc)
52
/* no arguments are allowed */
53
check_argc(vmg_ argc, 0);
55
/* run the garbage collector */
56
G_obj_table->gc_full(vmg0_);
60
* set the SAY instruction's handler function
62
#define SETSAY_NO_FUNC 1
63
#define SETSAY_NO_METHOD 2
64
void CVmBifT3::set_say(VMG_ uint argc)
66
vm_val_t *arg = G_stk->get(0);
69
/* one argument is required */
70
check_argc(vmg_ argc, 1);
72
/* check to see if we're setting the default display method */
73
if (arg->typ == VM_PROP
74
|| (arg->typ == VM_INT && arg->val.intval == SETSAY_NO_METHOD))
79
* the return value is the old property pointer (or
80
* SETSAY_NO_METHOD if there was no valid property set previously)
82
prop = G_interpreter->get_say_method();
83
if (prop != VM_INVALID_PROP)
84
retval_prop(vmg_ prop);
86
retval_int(vmg_ SETSAY_NO_METHOD);
88
/* get the new value */
91
/* if it's SETSAY_NO_METHOD, set it to the invalid prop ID */
92
if (val.typ == VM_INT)
93
val.set_propid(VM_INVALID_PROP);
96
G_interpreter->set_say_method(val.val.prop);
98
else if (arg->typ == VM_FUNCPTR
100
|| (arg->typ == VM_INT && arg->val.intval == SETSAY_NO_FUNC))
103
* the return value is the old function (or SETSAY_NO_FUNC if the
104
* old function was nil)
106
G_interpreter->get_say_func(&val);
107
if (val.typ != VM_NIL)
110
retval_int(vmg_ SETSAY_NO_FUNC);
112
/* get the new function value */
115
/* if it's SETSAY_NO_FUNC, set the function to nil */
116
if (val.typ == VM_INT)
119
/* set the new function */
120
G_interpreter->set_say_func(vmg_ &val);
125
err_throw(VMERR_BAD_TYPE_BIF);
130
* get the VM version number
132
void CVmBifT3::get_vm_vsn(VMG_ uint argc)
134
/* no arguments are allowed */
135
check_argc(vmg_ argc, 0);
137
/* set the integer return value */
138
retval_int(vmg_ T3VM_VSN_NUMBER);
142
* get the VM identification string
144
void CVmBifT3::get_vm_id(VMG_ uint argc)
146
/* no arguments are allowed */
147
check_argc(vmg_ argc, 0);
149
/* set the integer return value */
150
retval_str(vmg_ T3VM_IDENTIFICATION);
155
* get the VM banner string
157
void CVmBifT3::get_vm_banner(VMG_ uint argc)
159
/* no arguments are allowed */
160
check_argc(vmg_ argc, 0);
162
/* return the string */
163
retval_str(vmg_ T3VM_BANNER_STRING);
167
* get the 'preinit' status - true if preinit, nil if normal
169
void CVmBifT3::get_vm_preinit_mode(VMG_ uint argc)
171
/* no arguments allowed */
172
check_argc(vmg_ argc, 0);
174
/* return the preinit mode */
175
retval_int(vmg_ G_preinit_mode);
179
* get the runtime symbol table
181
void CVmBifT3::get_global_symtab(VMG_ uint argc)
183
/* check arguments */
184
check_argc(vmg_ argc, 0);
186
/* return the loader's symbol table object, if any */
187
retval_obj(vmg_ G_image_loader->get_reflection_symtab());
191
* allocate a new property ID
193
void CVmBifT3::alloc_new_prop(VMG_ uint argc)
195
/* check arguments */
196
check_argc(vmg_ argc, 0);
198
/* allocate and return a new property ID */
199
retval_prop(vmg_ G_image_loader->alloc_new_prop(vmg0_));
205
void CVmBifT3::get_stack_trace(VMG_ uint argc)
212
pool_ofs_t entry_addr;
214
vm_val_t stack_info_cls;
216
/* check arguments */
217
check_argc_range(vmg_ argc, 0, 1);
219
/* get the imported stack information class */
220
stack_info_cls.set_obj(G_predef->stack_info_cls);
221
if (stack_info_cls.val.obj == VM_INVALID_OBJ)
224
* there's no stack information class - we can't return any
225
* meaningful information, so just return nil
231
/* check to see if we're fetching a single level or the full trace */
234
/* get the single level, and adjust to a 0 base */
235
single_level = pop_int_val(vmg0_) - 1;
237
/* make sure it's in range */
238
if (single_level < 0)
239
err_throw(VMERR_BAD_VAL_BIF);
241
/* we won't need a return list */
248
* We're returning a full list, so we need to allocate the list for
249
* the return value. First, count stack levels to see how big a
253
/* start at the current function */
254
fp = G_interpreter->get_frame_ptr();
256
/* traverse the stack to determine the frame depth */
257
for (level = 0 ; fp != 0 ;
258
fp = G_interpreter->get_enclosing_frame_ptr(vmg_ fp), ++level) ;
260
/* create the list */
261
lst_val.set_obj(CVmObjList::create(vmg_ FALSE, level));
262
lst = (CVmObjList *)vm_objp(vmg_ lst_val.val.obj);
264
/* protect the list from garbage collection while we work */
265
G_stk->push(&lst_val);
267
/* flag that we're doing the whole stack */
271
/* set up at the current function */
272
fp = G_interpreter->get_frame_ptr();
273
entry_addr = G_interpreter->get_entry_ptr();
274
method_ofs = G_interpreter->get_method_ofs();
276
/* traverse the frames */
277
for (level = 0 ; fp != 0 ;
278
fp = G_interpreter->get_enclosing_frame_ptr(vmg_ fp), ++level)
288
vm_val_t info_srcloc;
293
/* if we're looking for a single level, and this isn't it, skip it */
294
if (single_level >= 0 && level != single_level)
295
goto done_with_level;
298
* start with the information values to nil - we'll set the
299
* appropriate ones when we find out what we have
306
/* get the number of arguments to the function in this frame */
307
fr_argc = G_interpreter->get_argc_from_frame(vmg_ fp);
309
/* set up a function pointer for the method's entry address */
310
func_ptr.set((const uchar *)G_code_pool->get_ptr(entry_addr));
313
* to ensure we don't flush the caller out of the code pool cache,
314
* resolve the current entrypoint address immediately - we always
315
* have room for at least two code pages in the cache, so we know
316
* resolving just one won't throw the previous one out, so we
317
* simply need to make the current one most recently used by
320
G_code_pool->get_ptr(G_interpreter->get_entry_ptr());
322
/* get the current frame's defining object */
323
def_obj = G_interpreter->get_defining_obj_from_frame(vmg_ fp);
325
/* determine whether it's an object.prop or a function call */
329
* a zero method offset indicates a recursive VM invocation
330
* from a native function, so we have no information on the
335
else if (def_obj == VM_INVALID_OBJ)
337
/* it's a function call */
338
info_func.set_fnptr(entry_addr);
342
/* it's an object.prop invocation */
343
info_obj.set_obj(def_obj); // $$$ walk up to base modified obj?
344
info_prop.set_propid(
345
G_interpreter->get_target_prop_from_frame(vmg_ fp));
347
/* get the 'self' in this frame */
348
info_self.set_obj(G_interpreter->get_self_from_frame(vmg_ fp));
352
* build the argument list and source location, except for system
357
/* allocate a list object to store the argument list */
358
info_args.set_obj(CVmObjList::create(vmg_ FALSE, fr_argc));
359
arglst = (CVmObjList *)vm_objp(vmg_ info_args.val.obj);
361
/* push the argument list for gc protection */
362
G_stk->push(&info_args);
364
/* build the argument list */
365
for (i = 0 ; i < fr_argc ; ++i)
367
/* add this element to the argument list */
368
arglst->cons_set_element(
369
i, G_interpreter->get_param_from_frame(vmg_ fp, i));
372
/* get the source location */
373
get_source_info(vmg_ entry_addr, method_ofs, &info_srcloc);
378
* it's a system routine - no argument information is
379
* available, so return nil rather than an empty list to to
380
* indicate the absence
384
/* there's obviously no source location for system code */
385
info_srcloc.set_nil();
389
* We have all of the information on this level now, so create the
390
* information object for the level. This is an object of the
391
* exported stack-info class, which is a TadsObject type.
393
G_stk->push(&info_srcloc);
394
G_stk->push(&info_args);
395
G_stk->push(&info_self);
396
G_stk->push(&info_prop);
397
G_stk->push(&info_obj);
398
G_stk->push(&info_func);
399
G_stk->push(&stack_info_cls);
400
ele.set_obj(CVmObjTads::create_from_stack(vmg_ 0, 7));
403
* the argument list is safely stashed away in the stack info
404
* object, so we can discard our gc protection for it now
410
* if we're fetching a single level, this is it - return the new
411
* stack info object and we're done
413
if (single_level >= 0)
415
/* return the single level object */
416
retval_obj(vmg_ ele.val.obj);
422
/* add the new element to our list */
423
lst->cons_set_element(level, &ele);
426
/* move on to the enclosing frame */
428
G_interpreter->get_enclosing_entry_ptr_from_frame(vmg_ fp);
429
method_ofs = G_interpreter->get_return_ofs_from_frame(vmg_ fp);
432
/* return the list */
433
retval_obj(vmg_ lst_val.val.obj);
435
/* discard our gc protection */
440
* Get the source file information for a given code pool offset. If debug
441
* records aren't available for the given location, returns nil. Returns
442
* a list containing the source file information: the first element is a
443
* string giving the name of the file, and the second element is an
444
* integer giving the line number in the file. Returns nil if no source
445
* information is available for the given byte code location.
447
void CVmBifT3::get_source_info(VMG_ ulong entry_addr, ulong method_ofs,
451
CVmDbgLinePtr line_ptr;
461
/* presume we won't be able to find source information for the location */
464
/* set up a debug table pointer for the function or method */
465
func_ptr.set((const uchar *)G_code_pool->get_ptr(entry_addr));
468
* resolve the current caller's entry code page to ensure it isn't
469
* flushed out of the code pool cache
471
G_code_pool->get_ptr(G_interpreter->get_entry_ptr());
473
/* get the debug information for the given location */
474
if (!CVmRun::get_stm_bounds(vmg_ &func_ptr, method_ofs,
475
&line_ptr, &stm_start, &stm_end))
477
/* no source information available - return failure */
481
/* get the source file record - if we can't find it, return failure */
482
srcf = (G_srcf_table != 0
483
? G_srcf_table->get_entry(line_ptr.get_source_id()) : 0);
488
* Create a list for the return value. The return list has two
489
* elements: the name of the source file containing this code, and the
490
* line number in the file.
492
retval->set_obj(CVmObjList::create(vmg_ FALSE, 2));
493
lst = (CVmObjList *)vm_objp(vmg_ retval->val.obj);
495
/* push the list for gc protection */
498
/* get the filename string */
499
fname = srcf->get_name();
502
* determine how long the string will be when translated to utf8 from
503
* the local filename character set
505
map_len = G_cmap_from_fname->map_str(0, 0, fname);
508
* create a string value to hold the filename, and store it in the
509
* first element of the return list (note that this automatically
510
* protects the new string from garbage collection, by virtue of the
511
* list referencing the string and the list itself being protected)
513
ele.set_obj(CVmObjString::create(vmg_ FALSE, map_len));
514
lst->cons_set_element(0, &ele);
516
/* map the string into the buffer we allocated for it */
517
str = (CVmObjString *)vm_objp(vmg_ ele.val.obj);
518
G_cmap_from_fname->map_str(str->cons_get_buf(), map_len, fname);
520
/* set the second element of the list to the source line number */
521
ele.set_int(line_ptr.get_source_line());
522
lst->cons_set_element(1, &ele);
524
/* discard our gc protection */
530
/* ------------------------------------------------------------------------ */
532
* T3 VM Test function set. This function set contains internal test
533
* and debug functions. These functions are not meant for use by
534
* "normal" programs - they provide internal access to certain VM state
535
* that is not useful or meaningful except for testing and debugging the
540
* Get an object's internal ID. Takes an object instance and returns an
541
* integer giving the object's VM ID number. This is effectively an
542
* address that can be used to refer to the object. Because this value
543
* is returned as an integer, it is NOT a reference to the object for
544
* the purposes of garbage collection or finalization.
546
void CVmBifT3Test::get_obj_id(VMG_ uint argc)
550
/* one argument required */
551
check_argc(vmg_ argc, 1);
553
/* get the object value */
554
G_interpreter->pop_obj(vmg_ &val);
556
/* return the object ID as an integer */
557
retval_int(vmg_ (long)val.val.obj);
561
* Get an object's garbage collection state. Takes an object ID (NOT an
562
* object reference -- this is the integer value returned by get_obj_id)
563
* and returns a bit mask with the garbage collector state.
565
* (retval & 0x000F) gives the free state. 0 is free, 1 is in use.
567
* (retval & 0x00F0) gives the reachable state. 0x00 is unreachable,
568
* 0x10 is finalizer-reachable, and 0x20 is fully reachable.
570
* (retval & 0x0F00) gives the finalizer state. 0x000 is unfinalizable,
571
* 0x100 is finalizable, and 0x200 is finalized.
573
* (retval & 0xF000) gives the object ID validity. 0 is valid, 0xF000
576
void CVmBifT3Test::get_obj_gc_state(VMG_ uint argc)
580
/* one argument required */
581
check_argc(vmg_ argc, 1);
584
G_interpreter->pop_int(vmg_ &val);
586
/* return the internal garbage collector state of the object */
588
(long)G_obj_table->get_obj_internal_state(val.val.intval));
592
* Get the Unicode character code of the first character of a string
594
void CVmBifT3Test::get_charcode(VMG_ uint argc)
598
/* one argument required */
599
check_argc(vmg_ argc, 1);
601
/* get the object ID as an integer */
602
str = pop_str_val(vmg0_);
605
* if the string is empty, return nil; otherwise, return the Unicode
606
* character code of the first character
608
if (vmb_get_len(str) == 0)
610
/* empty string - return nil */
616
* get the character code of the first character and return it
619
retval_int(vmg_ (int)utf8_ptr::s_getch(str + VMB_LEN));
added
removed
tads/tads3/vmbift3.cpp
