1 #ifdef RCSID
2 static char RCSid[] =
3 "$Header: d:/cvsroot/tads/tads3/VMBIFTAD.CPP,v 1.3 1999/07/11 00:46:58 MJRoberts Exp $";
4 #endif
5
6 /*
7 * Copyright (c) 1999, 2002 Michael J. Roberts. All Rights Reserved.
8 *
9 * Please see the accompanying license file, LICENSE.TXT, for information
10 * on using and copying this software.
11 */
12 /*
13 Name
14 vmbift3.cpp - T3 VM system interface function set
15 Function
16
17 Notes
18
19 Modified
20 04/05/99 MJRoberts - Creation
21 */
22
23 #include <stdio.h>
24 #include <string.h>
25
26 #include "utf8.h"
27 #include "vmbif.h"
28 #include "vmbift3.h"
29 #include "vmstack.h"
30 #include "vmerr.h"
31 #include "vmerrnum.h"
32 #include "vmglob.h"
33 #include "vmpool.h"
34 #include "vmobj.h"
35 #include "vmrun.h"
36 #include "vmstr.h"
37 #include "vmvsn.h"
38 #include "vmimage.h"
39 #include "vmlst.h"
40 #include "vmtobj.h"
41 #include "vmfunc.h"
42 #include "vmpredef.h"
43 #include "vmsrcf.h"
44 #include "charmap.h"
45
46
47 /*
48 * run the garbage collector
49 */
run_gc(VMG_ uint argc)50 void CVmBifT3::run_gc(VMG_ uint argc)
51 {
52 /* no arguments are allowed */
53 check_argc(vmg_ argc, 0);
54
55 /* run the garbage collector */
56 G_obj_table->gc_full(vmg0_);
57 }
58
59 /*
60 * set the SAY instruction's handler function
61 */
62 #define SETSAY_NO_FUNC 1
63 #define SETSAY_NO_METHOD 2
set_say(VMG_ uint argc)64 void CVmBifT3::set_say(VMG_ uint argc)
65 {
66 vm_val_t *arg = G_stk->get(0);
67 vm_val_t val;
68
69 /* one argument is required */
70 check_argc(vmg_ argc, 1);
71
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))
75 {
76 vm_prop_id_t prop;
77
78 /*
79 * the return value is the old property pointer (or
80 * SETSAY_NO_METHOD if there was no valid property set previously)
81 */
82 prop = G_interpreter->get_say_method();
83 if (prop != VM_INVALID_PROP)
84 retval_prop(vmg_ prop);
85 else
86 retval_int(vmg_ SETSAY_NO_METHOD);
87
88 /* get the new value */
89 G_stk->pop(&val);
90
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);
94
95 /* set the method */
96 G_interpreter->set_say_method(val.val.prop);
97 }
98 else if (arg->typ == VM_FUNCPTR
99 || arg->typ == VM_OBJ
100 || (arg->typ == VM_INT && arg->val.intval == SETSAY_NO_FUNC))
101 {
102 /*
103 * the return value is the old function (or SETSAY_NO_FUNC if the
104 * old function was nil)
105 */
106 G_interpreter->get_say_func(&val);
107 if (val.typ != VM_NIL)
108 retval(vmg_ &val);
109 else
110 retval_int(vmg_ SETSAY_NO_FUNC);
111
112 /* get the new function value */
113 G_stk->pop(&val);
114
115 /* if it's SETSAY_NO_FUNC, set the function to nil */
116 if (val.typ == VM_INT)
117 val.set_nil();
118
119 /* set the new function */
120 G_interpreter->set_say_func(vmg_ &val);
121 }
122 else
123 {
124 /* invalid type */
125 err_throw(VMERR_BAD_TYPE_BIF);
126 }
127 }
128
129 /*
130 * get the VM version number
131 */
get_vm_vsn(VMG_ uint argc)132 void CVmBifT3::get_vm_vsn(VMG_ uint argc)
133 {
134 /* no arguments are allowed */
135 check_argc(vmg_ argc, 0);
136
137 /* set the integer return value */
138 retval_int(vmg_ T3VM_VSN_NUMBER);
139 }
140
141 /*
142 * get the VM identification string
143 */
get_vm_id(VMG_ uint argc)144 void CVmBifT3::get_vm_id(VMG_ uint argc)
145 {
146 /* no arguments are allowed */
147 check_argc(vmg_ argc, 0);
148
149 /* set the integer return value */
150 retval_str(vmg_ T3VM_IDENTIFICATION);
151 }
152
153
154 /*
155 * get the VM banner string
156 */
get_vm_banner(VMG_ uint argc)157 void CVmBifT3::get_vm_banner(VMG_ uint argc)
158 {
159 /* no arguments are allowed */
160 check_argc(vmg_ argc, 0);
161
162 /* return the string */
163 retval_str(vmg_ T3VM_BANNER_STRING);
164 }
165
166 /*
167 * get the 'preinit' status - true if preinit, nil if normal
168 */
get_vm_preinit_mode(VMG_ uint argc)169 void CVmBifT3::get_vm_preinit_mode(VMG_ uint argc)
170 {
171 /* no arguments allowed */
172 check_argc(vmg_ argc, 0);
173
174 /* return the preinit mode */
175 retval_int(vmg_ G_preinit_mode);
176 }
177
178 /*
179 * get the runtime symbol table
180 */
get_global_symtab(VMG_ uint argc)181 void CVmBifT3::get_global_symtab(VMG_ uint argc)
182 {
183 /* check arguments */
184 check_argc(vmg_ argc, 0);
185
186 /* return the loader's symbol table object, if any */
187 retval_obj(vmg_ G_image_loader->get_reflection_symtab());
188 }
189
190 /*
191 * allocate a new property ID
192 */
alloc_new_prop(VMG_ uint argc)193 void CVmBifT3::alloc_new_prop(VMG_ uint argc)
194 {
195 /* check arguments */
196 check_argc(vmg_ argc, 0);
197
198 /* allocate and return a new property ID */
199 retval_prop(vmg_ G_image_loader->alloc_new_prop(vmg0_));
200 }
201
202 /*
203 * get a stack trace
204 */
get_stack_trace(VMG_ uint argc)205 void CVmBifT3::get_stack_trace(VMG_ uint argc)
206 {
207 int level;
208 vm_val_t *fp;
209 vm_val_t lst_val;
210 CVmObjList *lst;
211 pool_ofs_t entry_addr;
212 ulong method_ofs;
213 vm_val_t stack_info_cls;
214
215 /* check arguments */
216 check_argc(vmg_ argc, 0);
217
218 /* get the imported stack information class */
219 stack_info_cls.set_obj(G_predef->stack_info_cls);
220 if (stack_info_cls.val.obj == VM_INVALID_OBJ)
221 {
222 /*
223 * there's no stack information class - we can't return any
224 * meaningful information, so just return nil
225 */
226 retval_nil(vmg0_);
227 return;
228 }
229
230 /* start at the current function */
231 fp = G_interpreter->get_frame_ptr();
232
233 /* traverse the stack to determine the frame depth */
234 for (level = 0 ; fp != 0 ;
235 fp = G_interpreter->get_enclosing_frame_ptr(vmg_ fp), ++level) ;
236
237 /* allocate a list to hold the result */
238 lst_val.set_obj(CVmObjList::create(vmg_ FALSE, level));
239 lst = (CVmObjList *)vm_objp(vmg_ lst_val.val.obj);
240
241 /* push the list to protect it from garbage collection wihle working */
242 G_stk->push(&lst_val);
243
244 /* set up at the current function */
245 fp = G_interpreter->get_frame_ptr();
246 entry_addr = G_interpreter->get_entry_ptr();
247 method_ofs = G_interpreter->get_method_ofs();
248
249 /* traverse the frames */
250 for (level = 0 ; fp != 0 ;
251 fp = G_interpreter->get_enclosing_frame_ptr(vmg_ fp), ++level)
252 {
253 int fr_argc;
254 int i;
255 vm_obj_id_t def_obj;
256 vm_val_t info_self;
257 vm_val_t info_func;
258 vm_val_t info_obj;
259 vm_val_t info_prop;
260 vm_val_t info_args;
261 vm_val_t info_srcloc;
262 CVmObjList *arglst;
263 vm_val_t ele;
264 CVmFuncPtr func_ptr;
265
266 /*
267 * start with the information values to nil - we'll set the
268 * appropriate ones when we find out what we have
269 */
270 info_func.set_nil();
271 info_obj.set_nil();
272 info_prop.set_nil();
273 info_self.set_nil();
274
275 /* get the number of arguments to the function in this frame */
276 fr_argc = G_interpreter->get_argc_from_frame(vmg_ fp);
277
278 /* set up a function pointer for the method's entry address */
279 func_ptr.set((const uchar *)G_code_pool->get_ptr(entry_addr));
280
281 /*
282 * to ensure we don't flush the caller out of the code pool cache,
283 * resolve the current entrypoint address immediately - we always
284 * have room for at least two code pages in the cache, so we know
285 * resolving just one won't throw the previous one out, so we
286 * simply need to make the current one most recently used by
287 * resolving it
288 */
289 G_code_pool->get_ptr(G_interpreter->get_entry_ptr());
290
291 /* get the current frame's defining object */
292 def_obj = G_interpreter->get_defining_obj_from_frame(vmg_ fp);
293
294 /* determine whether it's an object.prop or a function call */
295 if (method_ofs == 0)
296 {
297 /*
298 * a zero method offset indicates a recursive VM invocation
299 * from a native function, so we have no information on the
300 * call at all
301 */
302 fr_argc = 0;
303 }
304 else if (def_obj == VM_INVALID_OBJ)
305 {
306 /* it's a function call */
307 info_func.set_fnptr(entry_addr);
308 }
309 else
310 {
311 /* it's an object.prop invocation */
312 info_obj.set_obj(def_obj); // $$$ walk up to base modified obj?
313 info_prop.set_propid(
314 G_interpreter->get_target_prop_from_frame(vmg_ fp));
315
316 /* get the 'self' in this frame */
317 info_self.set_obj(G_interpreter->get_self_from_frame(vmg_ fp));
318 }
319
320 /*
321 * build the argument list and source location, except for system
322 * routines
323 */
324 if (method_ofs != 0)
325 {
326 /* allocate a list object to store the argument list */
327 info_args.set_obj(CVmObjList::create(vmg_ FALSE, fr_argc));
328 arglst = (CVmObjList *)vm_objp(vmg_ info_args.val.obj);
329
330 /* push the argument list for gc protection */
331 G_stk->push(&info_args);
332
333 /* build the argument list */
334 for (i = 0 ; i < fr_argc ; ++i)
335 {
336 /* add this element to the argument list */
337 arglst->cons_set_element(
338 i, G_interpreter->get_param_from_frame(vmg_ fp, i));
339 }
340
341 /* get the source location */
342 get_source_info(vmg_ entry_addr, method_ofs, &info_srcloc);
343 }
344 else
345 {
346 /*
347 * it's a system routine - no argument information is
348 * available, so return nil rather than an empty list to to
349 * indicate the absence
350 */
351 info_args.set_nil();
352
353 /* there's obviously no source location for system code */
354 info_srcloc.set_nil();
355 }
356
357 /*
358 * We have all of the information on this level now, so create the
359 * information object for the level. This is an object of the
360 * exported stack-info class, which is a TadsObject type.
361 */
362 G_stk->push(&info_srcloc);
363 G_stk->push(&info_args);
364 G_stk->push(&info_self);
365 G_stk->push(&info_prop);
366 G_stk->push(&info_obj);
367 G_stk->push(&info_func);
368 G_stk->push(&stack_info_cls);
369 ele.set_obj(CVmObjTads::create_from_stack(vmg_ 0, 7));
370
371 /*
372 * the argument list is safely stashed away in the stack info
373 * object, so we can discard our gc protection for it now
374 */
375 if (method_ofs != 0)
376 G_stk->discard();
377
378 /* add the new element to our list */
379 lst->cons_set_element(level, &ele);
380
381 /* move on to the enclosing frame */
382 entry_addr =
383 G_interpreter->get_enclosing_entry_ptr_from_frame(vmg_ fp);
384 method_ofs = G_interpreter->get_return_ofs_from_frame(vmg_ fp);
385 }
386
387 /* return the list */
388 retval_obj(vmg_ lst_val.val.obj);
389
390 /* discard our gc protection */
391 G_stk->discard();
392 }
393
394 /*
395 * Get the source file information for a given code pool offset. If debug
396 * records aren't available for the given location, returns nil. Returns
397 * a list containing the source file information: the first element is a
398 * string giving the name of the file, and the second element is an
399 * integer giving the line number in the file. Returns nil if no source
400 * information is available for the given byte code location.
401 */
get_source_info(VMG_ ulong entry_addr,ulong method_ofs,vm_val_t * retval)402 void CVmBifT3::get_source_info(VMG_ ulong entry_addr, ulong method_ofs,
403 vm_val_t *retval)
404 {
405 CVmFuncPtr func_ptr;
406 CVmDbgLinePtr line_ptr;
407 ulong stm_start;
408 ulong stm_end;
409 CVmObjList *lst;
410 vm_val_t ele;
411 CVmSrcfEntry *srcf;
412 CVmObjString *str;
413 const char *fname;
414 size_t map_len;
415
416 /* presume we won't be able to find source information for the location */
417 retval->set_nil();
418
419 /* set up a debug table pointer for the function or method */
420 func_ptr.set((const uchar *)G_code_pool->get_ptr(entry_addr));
421
422 /*
423 * resolve the current caller's entry code page to ensure it isn't
424 * flushed out of the code pool cache
425 */
426 G_code_pool->get_ptr(G_interpreter->get_entry_ptr());
427
428 /* get the debug information for the given location */
429 if (!CVmRun::get_stm_bounds(vmg_ &func_ptr, method_ofs,
430 &line_ptr, &stm_start, &stm_end))
431 {
432 /* no source information available - return failure */
433 return;
434 }
435
436 /* get the source file record - if we can't find it, return failure */
437 srcf = (G_srcf_table != 0
438 ? G_srcf_table->get_entry(line_ptr.get_source_id()) : 0);
439 if (srcf == 0)
440 return;
441
442 /*
443 * Create a list for the return value. The return list has two
444 * elements: the name of the source file containing this code, and the
445 * line number in the file.
446 */
447 retval->set_obj(CVmObjList::create(vmg_ FALSE, 2));
448 lst = (CVmObjList *)vm_objp(vmg_ retval->val.obj);
449
450 /* push the list for gc protection */
451 G_stk->push(retval);
452
453 /* get the filename string */
454 fname = srcf->get_name();
455
456 /*
457 * determine how long the string will be when translated to utf8 from
458 * the local filename character set
459 */
460 map_len = G_cmap_from_fname->map_str(0, 0, fname);
461
462 /*
463 * create a string value to hold the filename, and store it in the
464 * first element of the return list (note that this automatically
465 * protects the new string from garbage collection, by virtue of the
466 * list referencing the string and the list itself being protected)
467 */
468 ele.set_obj(CVmObjString::create(vmg_ FALSE, map_len));
469 lst->cons_set_element(0, &ele);
470
471 /* map the string into the buffer we allocated for it */
472 str = (CVmObjString *)vm_objp(vmg_ ele.val.obj);
473 G_cmap_from_fname->map_str(str->cons_get_buf(), map_len, fname);
474
475 /* set the second element of the list to the source line number */
476 ele.set_int(line_ptr.get_source_line());
477 lst->cons_set_element(1, &ele);
478
479 /* discard our gc protection */
480 G_stk->discard();
481 }
482
483
484
485 /* ------------------------------------------------------------------------ */
486 /*
487 * T3 VM Test function set. This function set contains internal test
488 * and debug functions. These functions are not meant for use by
489 * "normal" programs - they provide internal access to certain VM state
490 * that is not useful or meaningful except for testing and debugging the
491 * VM itself.
492 */
493
494 /*
495 * Get an object's internal ID. Takes an object instance and returns an
496 * integer giving the object's VM ID number. This is effectively an
497 * address that can be used to refer to the object. Because this value
498 * is returned as an integer, it is NOT a reference to the object for
499 * the purposes of garbage collection or finalization.
500 */
get_obj_id(VMG_ uint argc)501 void CVmBifT3Test::get_obj_id(VMG_ uint argc)
502 {
503 vm_val_t val;
504
505 /* one argument required */
506 check_argc(vmg_ argc, 1);
507
508 /* get the object value */
509 G_interpreter->pop_obj(vmg_ &val);
510
511 /* return the object ID as an integer */
512 retval_int(vmg_ (long)val.val.obj);
513 }
514
515 /*
516 * Get an object's garbage collection state. Takes an object ID (NOT an
517 * object reference -- this is the integer value returned by get_obj_id)
518 * and returns a bit mask with the garbage collector state.
519 *
520 * (retval & 0x000F) gives the free state. 0 is free, 1 is in use.
521 *
522 * (retval & 0x00F0) gives the reachable state. 0x00 is unreachable,
523 * 0x10 is finalizer-reachable, and 0x20 is fully reachable.
524 *
525 * (retval & 0x0F00) gives the finalizer state. 0x000 is unfinalizable,
526 * 0x100 is finalizable, and 0x200 is finalized.
527 *
528 * (retval & 0xF000) gives the object ID validity. 0 is valid, 0xF000
529 * is invalid.
530 */
get_obj_gc_state(VMG_ uint argc)531 void CVmBifT3Test::get_obj_gc_state(VMG_ uint argc)
532 {
533 vm_val_t val;
534
535 /* one argument required */
536 check_argc(vmg_ argc, 1);
537
538 /* pop the string */
539 G_interpreter->pop_int(vmg_ &val);
540
541 /* return the internal garbage collector state of the object */
542 retval_int(vmg_
543 (long)G_obj_table->get_obj_internal_state(val.val.intval));
544 }
545
546 /*
547 * Get the Unicode character code of the first character of a string
548 */
get_charcode(VMG_ uint argc)549 void CVmBifT3Test::get_charcode(VMG_ uint argc)
550 {
551 const char *str;
552
553 /* one argument required */
554 check_argc(vmg_ argc, 1);
555
556 /* get the object ID as an integer */
557 str = pop_str_val(vmg0_);
558
559 /*
560 * if the string is empty, return nil; otherwise, return the Unicode
561 * character code of the first character
562 */
563 if (vmb_get_len(str) == 0)
564 {
565 /* empty string - return nil */
566 retval_nil(vmg0_);
567 }
568 else
569 {
570 /*
571 * get the character code of the first character and return it
572 * as an integer
573 */
574 retval_int(vmg_ (int)utf8_ptr::s_getch(str + VMB_LEN));
575 }
576 }
577