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
vmbiftad.cpp - TADS built-in function set for T3 VM
20
04/05/99 MJRoberts - Creation
53
/* ------------------------------------------------------------------------ */
58
#ifdef VMBIFTADS_RNG_ISAAC
59
static void isaac_init(isaacctx *ctx, int flag);
60
#endif /* VMBIFTADS_RNG_ISAAC */
63
/* ------------------------------------------------------------------------ */
65
* Initialize the TADS intrinsics global state
67
CVmBifTADSGlobals::CVmBifTADSGlobals(VMG0_)
69
/* allocate our regular expression parser */
70
rex_parser = new CRegexParser();
71
rex_searcher = new CRegexSearcherSimple(rex_parser);
74
* Allocate a global variable to hold the most recent regular
75
* expression search string. We need this in a global so that the last
76
* search string is always protected from garbage collection; we must
77
* keep the string because we might need it to extract a group-match
80
last_rex_str = G_obj_table->create_global_var();
82
#ifdef VMBIFTADS_RNG_LCG
84
* Set the random number seed to a fixed starting value (this value
85
* is arbitrary; we chose it by throwing dice). If the program
86
* wants another sequence, it can manually change this by calling
87
* the randomize() intrinsic in our function set, which seeds the
88
* generator with an OS-dependent starting value (usually based on
89
* the system's real-time clock, to ensure that each run will use a
90
* different starting value).
92
rand_seed = 024136543305;
95
#ifdef VMBIFTADS_RNG_ISAAC
96
/* create the ISAAC context structure */
97
isaac_ctx = (struct isaacctx *)t3malloc(sizeof(struct isaacctx));
99
/* initialize with a fixed seed vector */
100
isaac_init(isaac_ctx, FALSE);
105
* delete the TADS intrinsics global state
107
CVmBifTADSGlobals::~CVmBifTADSGlobals()
109
/* delete our regular expression searcher and parser */
114
* note that we leave our last_rex_str global variable undeleted here,
115
* as we don't have access to G_obj_table (as there's no VMG_ to a
116
* destructor); this is okay, since the object table will take care of
117
* deleting the variable for us when the object table itself is deleted
120
#ifdef VMBIFTADS_RNG_ISAAC
121
/* delete the ISAAC context */
126
/* ------------------------------------------------------------------------ */
128
* datatype - get the datatype of a given value
130
void CVmBifTADS::datatype(VMG_ uint argc)
135
/* check arguments */
136
check_argc(vmg_ argc, 1);
141
/* return the appropriate value for this type */
142
retval.set_datatype(vmg_ &val);
143
retval_int(vmg_ retval.val.intval);
146
/* ------------------------------------------------------------------------ */
148
* getarg - get the given argument to the current procedure
150
void CVmBifTADS::getarg(VMG_ uint argc)
154
/* check arguments */
155
check_argc(vmg_ argc, 1);
157
/* get the argument index value */
158
idx = pop_int_val(vmg0_);
160
/* if the argument index is out of range, throw an error */
161
if (idx < 1 || idx > G_interpreter->get_cur_argc(vmg0_))
162
err_throw(VMERR_BAD_VAL_BIF);
164
/* push the parameter value */
165
*G_interpreter->get_r0() = *G_interpreter->get_param(vmg_ idx - 1);
168
/* ------------------------------------------------------------------------ */
170
* firstobj - get the first object instance
172
void CVmBifTADS::firstobj(VMG_ uint argc)
174
/* check arguments */
175
check_argc_range(vmg_ argc, 0, 2);
177
/* enumerate objects starting with object 1 in the master object table */
178
enum_objects(vmg_ argc, (vm_obj_id_t)1);
182
* nextobj - get the next object instance after a given object
184
void CVmBifTADS::nextobj(VMG_ uint argc)
189
/* check arguments */
190
check_argc_range(vmg_ argc, 1, 3);
192
/* get the previous object */
193
G_interpreter->pop_obj(vmg_ &val);
194
prv_obj = val.val.obj;
197
* Enumerate objects starting with the next object in the master
198
* object table after the given object. Reduce the argument count by
199
* one, since we've removed the preceding object.
201
enum_objects(vmg_ argc - 1, prv_obj + 1);
204
/* enum_objects flags */
205
#define VMBIFTADS_ENUM_INSTANCES 0x0001
206
#define VMBIFTADS_ENUM_CLASSES 0x0002
209
* Common handler for firstobj/nextobj object iteration
211
void CVmBifTADS::enum_objects(VMG_ uint argc, vm_obj_id_t start_obj)
218
/* presume no superclass filter will be specified */
221
/* presume we're enumerating instances only */
222
flags = VMBIFTADS_ENUM_INSTANCES;
225
* check arguments - we can optionally have two more arguments: a
226
* superclass whose instances/subclasses we are to enumerate, and an
227
* integer giving flag bits
232
G_interpreter->pop_obj(vmg_ &val);
236
flags = pop_long_val(vmg0_);
240
/* check to see if it's an object or the flags integer */
241
switch (G_stk->get(0)->typ)
245
flags = pop_long_val(vmg0_);
249
/* it's the superclass filter */
250
G_interpreter->pop_obj(vmg_ &val);
255
/* invalid argument type */
256
err_throw(VMERR_BAD_TYPE_BIF);
260
/* presume we won't find anything */
264
* starting with the given object, scan objects until we find one
265
* that's valid and matches our superclass, if one was provided
267
for (obj = start_obj ; obj < G_obj_table->get_max_used_obj_id() ; ++obj)
270
* If it's valid, and it's not an intrinsic class modifier object,
271
* consider it further. Skip intrinsic class modifiers, since
272
* they're not really separate objects; they're really part of the
273
* intrinsic class they modify, and all of the properties and
274
* methods of a modifier object are reachable through the base
277
if (G_obj_table->is_obj_id_valid(obj)
278
&& !CVmObjIntClsMod::is_intcls_mod_obj(vmg_ obj))
281
* if it's a class, skip it if the flags indicate classes are
282
* not wanted; if it's an instance, skip it if the flags
283
* indicate that instances are not wanted
285
if (vm_objp(vmg_ obj)->is_class_object(vmg_ obj))
287
/* it's a class - skip it if classes are not wanted */
288
if ((flags & VMBIFTADS_ENUM_CLASSES) == 0)
293
/* it's an instance - skip it if instances are not wanted */
294
if ((flags & VMBIFTADS_ENUM_INSTANCES) == 0)
299
* if a superclass was specified, and it matches, we have a
302
if (sc != VM_INVALID_OBJ)
304
/* if the object matches, return it */
305
if (vm_objp(vmg_ obj)->is_instance_of(vmg_ sc))
307
retval_obj(vmg_ obj);
314
* We're enumerating all objects - but skip List and String
315
* object, as we expose these are special types.
317
if (vm_objp(vmg_ obj)->get_as_list() == 0
318
&& vm_objp(vmg_ obj)->get_as_string(vmg0_) == 0)
320
retval_obj(vmg_ obj);
328
/* ------------------------------------------------------------------------ */
330
* Random number generators. Define one of the following configuration
331
* variables to select a random number generation algorithm:
333
* VMBIFTADS_RNG_LCG - linear congruential generator
334
*. VMBIFTADS_RNG_ISAAC - ISAAC (cryptographic hash generator)
337
/* ------------------------------------------------------------------------ */
339
* Linear Congruential Random-Number Generator. This generator uses an
340
* algorithm from Knuth, The Art of Computer Programming, Volume 2, p.
341
* 170, with parameters chosen from the same book for their good
342
* statistical properties and efficiency on 32-bit hardware.
344
#ifdef VMBIFTADS_RNG_LCG
346
* randomize - seed the random-number generator
348
void CVmBifTADS::randomize(VMG_ uint argc)
350
/* check arguments */
351
check_argc(vmg_ argc, 0);
353
/* seed the generator */
354
os_rand(&G_bif_tads_globals->rand_seed);
358
* generate the next random number - linear congruential generator
360
static ulong rng_next(VMG0_)
362
const ulong a = 1664525L;
366
* Generate the next random value using the linear congruential
367
* method described in Knuth, The Art of Computer Programming,
370
* Use 2^32 as m, hence (n mod m) == (n & 0xFFFFFFFF). This is
371
* efficient and is well-suited to 32-bit machines, works fine on
372
* larger machines, and will even work on 16-bit machines as long as
373
* the compiler can provide us with 32-bit arithmetic (which we
374
* assume extensively elsewhere anyway).
376
* We use a = 1664525, a multiplier which has very good results with
377
* the Spectral Test (see Knuth p102) with our choice of m.
379
* Use c = 1, since this trivially satisfies Knuth's requirements
380
* about common factors.
382
* Note that the result of the multiplication might overflow a
383
* 32-bit ulong for values of rand_seed that are not small. This
384
* doesn't matter, since if it does, the machine will naturally
385
* truncate high-order bits to yield the result mod 2^32. So, on a
386
* 32-bit machine, the (&0xFFFFFFFF) part is superfluous, but it's
387
* harmless and is needed for machines with a larger word size.
389
G_bif_tads_globals->rand_seed =
390
(long)(((a * (ulong)G_bif_tads_globals->rand_seed) + 1) & 0xFFFFFFFF);
391
return (ulong)G_bif_tads_globals->rand_seed;
393
#endif /* VMBIFTADS_RNG_LCG */
395
/* ------------------------------------------------------------------------ */
397
* ISAAC random number generator.
400
#ifdef VMBIFTADS_RNG_ISAAC
402
/* service macros for ISAAC random number generator */
403
#define isaac_ind(mm,x) ((mm)[(x>>2)&(ISAAC_RANDSIZ-1)])
404
#define isaac_step(mix,a,b,mm,m,m2,r,x) \
407
a = ((a^(mix)) + *(m2++)) & 0xffffffff; \
408
*(m++) = y = (isaac_ind(mm,x) + a + b) & 0xffffffff; \
409
*(r++) = b = (isaac_ind(mm,y>>ISAAC_RANDSIZL) + x) & 0xffffffff; \
411
#define isaac_rand(r) \
413
(isaac_gen_group(r), (r)->cnt=ISAAC_RANDSIZ-1, (r)->rsl[(r)->cnt]) : \
416
#define isaac_mix(a,b,c,d,e,f,g,h) \
418
a^=b<<11; d+=a; b+=c; \
419
b^=c>>2; e+=b; c+=d; \
420
c^=d<<8; f+=c; d+=e; \
421
d^=e>>16; g+=d; e+=f; \
422
e^=f<<10; h+=e; f+=g; \
423
f^=g>>4; a+=f; g+=h; \
424
g^=h<<8; b+=g; h+=a; \
425
h^=a>>9; c+=h; a+=b; \
428
/* generate the group of numbers */
429
static void isaac_gen_group(isaacctx *ctx)
444
b = (ctx->b + (++ctx->c)) & 0xffffffff;
445
for (m = mm, mend = m2 = m + (ISAAC_RANDSIZ/2) ; m<mend ; )
447
isaac_step(a<<13, a, b, mm, m, m2, r, x);
448
isaac_step(a>>6, a, b, mm, m, m2, r, x);
449
isaac_step(a<<2, a, b, mm, m, m2, r, x);
450
isaac_step(a>>16, a, b, mm, m, m2, r, x);
452
for (m2 = mm; m2<mend; )
454
isaac_step(a<<13, a, b, mm, m, m2, r, x);
455
isaac_step(a>>6, a, b, mm, m, m2, r, x);
456
isaac_step(a<<2, a, b, mm, m, m2, r, x);
457
isaac_step(a>>16, a, b, mm, m, m2, r, x);
464
* Initialize. If flag is true, then use the contents of ctx->rsl[] to
465
* initialize ctx->mm[]; otherwise, we'll use a fixed starting
468
static void isaac_init(isaacctx *ctx, int flag)
482
ctx->a = ctx->b = ctx->c = 0;
485
a = b = c = d = e = f = g = h = 0x9e3779b9; /* the golden ratio */
487
/* scramble the initial settings */
488
for (i = 0 ; i < 4 ; ++i)
490
isaac_mix(a, b, c, d, e, f, g, h);
495
/* initialize using the contents of ctx->rsl[] as the seed */
496
for (i = 0 ; i < ISAAC_RANDSIZ ; i += 8)
498
a += r[i]; b += r[i+1]; c += r[i+2]; d += r[i+3];
499
e += r[i+4]; f += r[i+5]; g += r[i+6]; h += r[i+7];
500
isaac_mix(a, b, c, d, e, f, g, h);
501
m[i] = a; m[i+1] = b; m[i+2] = c; m[i+3] = d;
502
m[i+4] = e; m[i+5] = f; m[i+6] = g; m[i+7] = h;
505
/* do a second pass to make all of the seed affect all of m */
506
for (i = 0 ; i < ISAAC_RANDSIZ ; i += 8)
508
a += m[i]; b += m[i+1]; c += m[i+2]; d += m[i+3];
509
e += m[i+4]; f += m[i+5]; g += m[i+6]; h += m[i+7];
510
isaac_mix(a, b, c, d, e, f, g, h);
511
m[i] = a; m[i+1] = b; m[i+2] = c; m[i+3] = d;
512
m[i+4] = e; m[i+5] = f; m[i+6] = g; m[i+7] = h;
517
/* initialize using fixed initial settings */
518
for (i = 0 ; i < ISAAC_RANDSIZ ; i += 8)
520
isaac_mix(a, b, c, d, e, f, g, h);
521
m[i] = a; m[i+1] = b; m[i+2] = c; m[i+3] = d;
522
m[i+4] = e; m[i+5] = f; m[i+6] = g; m[i+7] = h;
526
/* fill in the first set of results */
527
isaac_gen_group(ctx);
529
/* prepare to use the first set of results */
530
ctx->cnt = ISAAC_RANDSIZ;
536
void CVmBifTADS::randomize(VMG_ uint argc)
541
/* check arguments */
542
check_argc(vmg_ argc, 0);
544
/* seed the generator */
548
* Fill in rsl[] with the seed. It doesn't do a lot of good to call
549
* os_rand() repeatedly, since this function might simply return the
550
* real-time clock value. So, use the os_rand() seed value as the
551
* first rsl[] value, then use a simple linear congruential
552
* generator to fill in the rest of rsl[].
554
for (i = 0 ; i < ISAAC_RANDSIZ ; ++i)
556
const ulong a = 1664525L;
558
/* fill in this value from the previous seed value */
559
G_bif_tads_globals->isaac_ctx->rsl[i] = (ulong)seed;
561
/* generate the next lcg value */
562
seed = (long)(((a * (ulong)seed) + 1) & 0xFFFFFFFF);
565
/* initialize with this rsl[] array */
566
isaac_init(G_bif_tads_globals->isaac_ctx, TRUE);
571
* generate the next random number - ISAAC (by Bob Jenkins,
572
* http://ourworld.compuserve.com/homepages/bob_jenkins/isaacafa.htm)
574
static ulong rng_next(VMG0_)
576
/* return the next number */
577
return isaac_rand(G_bif_tads_globals->isaac_ctx);
579
#endif /* VMBIFTADS_RNG_ISAAC */
581
/* ------------------------------------------------------------------------ */
583
* rand - generate a random number, or choose an element randomly from a
584
* list of values or from our list of arguments.
586
* With one integer argument N, we choose a random number from 0 to N-1.
588
* With one list argument, we choose a random element of the list.
590
* With multiple arguments, we choose one argument at random and return
591
* its value. Note that, because this is an ordinary built-in function,
592
* all of our arguments will be fully evaluated.
594
void CVmBifTADS::rand(VMG_ uint argc)
601
CVmObjVector *vec = 0;
602
vm_obj_id_t vecid = VM_INVALID_OBJ;
604
/* presume we're not going to choose from our arguments or from a list */
605
choose_an_arg = FALSE;
608
/* determine the desired range of values based on the arguments */
612
* if no argument is given, produce a random number in our full
613
* range - clear the 'use_range' flag to so indicate
617
else if (argc == 1 && G_stk->get(0)->typ == VM_INT)
619
/* we're returning a number in the range 0..(arg-1) */
620
range = G_stk->get(0)->val.intval;
623
/* discard the argument */
628
/* check for a vector or a list */
629
if (G_stk->get(0)->typ == VM_OBJ
630
&& CVmObjVector::is_vector_obj(vmg_ G_stk->get(0)->val.obj))
633
* it's a vector - get the object pointer, but leave it on the
634
* stack for GC protection for now
636
vecid = G_stk->get(0)->val.obj;
637
vec = (CVmObjVector *)vm_objp(vmg_ vecid);
639
/* the range is 0..(vector_length-1) */
640
range = vec->get_element_count();
645
/* it must be a list - pop the list value */
646
listp = pop_list_val(vmg0_);
648
/* our range is 0..(list_element_count-1) */
649
range = vmb_get_len(listp);
656
* produce a random number in the range 0..(argc-1) so that we
657
* can select one of our arguments
662
/* note that we should choose an argument value */
663
choose_an_arg = TRUE;
666
/* get the next random number */
667
rand_val = rng_next(vmg0_);
670
* Calculate our random value in the range 0..(range-1). If range
671
* == 0, simply choose a value across our full range.
679
* A range was specified, so choose in our range. As Knuth
680
* suggests, don't simply take the low-order bits from the value,
681
* since these are the least random part. Instead, use the method
682
* Knuth describes in TAOCP Vol 2 section 3.4.2.
684
* Avoid floating point arithmetic - use an integer calculation
685
* instead. This code performs a 64-bit fixed-point calculation
686
* using 32-bit values.
688
* The calculation we're really performing is this:
690
* rand_val = (ulong)((((double)rand_val) / 4294967296.0)
694
/* calculate the high-order 32 bits of (rand_val / 2^32 * range) */
695
hi = (((rand_val >> 16) & 0xffff) * ((range >> 16) & 0xffff))
696
+ ((((rand_val >> 16) & 0xffff) * (range & 0xffff)) >> 16)
697
+ (((rand_val & 0xffff) * ((range >> 16) & 0xffff)) >> 16);
699
/* calculate the low-order 32 bits */
700
lo = ((((rand_val >> 16) & 0xffff) * (range & 0xffff)) & 0xffff)
701
+ (((rand_val & 0xffff) * ((range >> 16) & 0xffff)) & 0xffff)
702
+ ((((rand_val & 0xffff) * (range & 0xffff)) >> 16) & 0xffff);
705
* add the carry from the low part into the high part to get the
708
rand_val = hi + (lo >> 16);
712
* Return the appropriate value, depending on our argument list
716
/* return the selected argument */
717
retval(vmg_ G_stk->get((int)rand_val));
719
/* discard all of the arguments */
720
G_stk->discard(argc);
726
/* get the selected element */
729
/* there are no elements to choose from, so return nil */
736
/* get the selected vector element */
737
idxval.set_int(rand_val + 1);
738
vec->index_val(vmg_ &val, vecid, &idxval);
744
/* discard our gc protection */
751
/* as a special case, if the list has zero elements, return nil */
752
if (vmb_get_len(listp) == 0)
754
/* there are no elements to choose from, so return nil */
759
/* get the selected list element */
760
vmb_get_dh(listp + VMB_LEN
761
+ (size_t)((rand_val * VMB_DATAHOLDER)), &val);
769
/* simply return the random number */
770
retval_int(vmg_ (long)rand_val);
774
/* ------------------------------------------------------------------------ */
776
* Bit-shift generator. This is from Knuth, The Art of Computer
777
* Programming, volume 2. This generator is designed to produce random
778
* strings of bits and is not suitable for use as a general-purpose RNG.
780
* Linear congruential generators are not ideal for generating random
781
* bits; their statistical properties seem better suited for generating
782
* values over a wider range. This generator is specially designed to
783
* produce random bits, so it could be a useful complement to an LCG RNG.
785
* This code should not be enabled in its present state; it's retained
786
* in case we want in the future to implement a generator exclusively
787
* for random bits. The ISAAC generator seems to be a good source of
788
* random bits as well as random numbers, so it seems unlikely that
789
* we'll need a separate random bit generator.
792
#ifdef VMBIFTADS_RNG_BITSHIFT
793
void CVmBifTADS::randbit(VMG_ uint argc)
797
/* check arguments */
798
check_argc(vmg_ argc, 0);
800
top_bit = (G_bif_tads_globals->rand_seed & 0x8000000);
801
G_bif_tads_globals->rand_seed <<= 1;
803
G_bif_tads_globals->rand_seed ^= 035604231625;
805
retval_int(vmg_ (long)(G_bif_tads_globals->rand_seed & 1));
807
#endif /* VMBIFTADS_RNG_BITSHIFT */
810
/* ------------------------------------------------------------------------ */
812
* cvtstr (toString) - convert to string
814
void CVmBifTADS::cvtstr(VMG_ uint argc)
822
/* check arguments */
823
check_argc_range(vmg_ argc, 1, 2);
825
/* pop the argument */
828
/* if there's a radix specified, pop it as well */
831
/* get the radix from the stack */
832
radix = pop_int_val(vmg0_);
836
/* use decimal by default */
840
/* convert the value */
841
p = CVmObjString::cvt_to_str(vmg_ &new_str,
842
buf, sizeof(buf), &val, radix);
844
/* save the new string on the stack to protect from garbage collection */
845
G_stk->push(&new_str);
847
/* create and return a string from our new value */
848
retval_obj(vmg_ CVmObjString::create(vmg_ FALSE,
849
p + VMB_LEN, vmb_get_len(p)));
851
/* done with the new string */
856
* cvtnum (toInteger) - convert to an integer
858
void CVmBifTADS::cvtnum(VMG_ uint argc)
865
/* check arguments */
866
check_argc_range(vmg_ argc, 1, 2);
869
* check for a BigNumber and convert it (not very object-oriented,
870
* but this is a type-conversion routine, so special awareness of
871
* individual types isn't that weird)
873
valp = G_stk->get(0);
874
if (valp->typ == VM_OBJ
875
&& CVmObjBigNum::is_bignum_obj(vmg_ valp->val.obj))
879
/* convert it as a BigNumber */
880
intval = ((CVmObjBigNum *)vm_objp(vmg_ valp->val.obj))
883
/* discard arguments (ignore the radix in this case) */
884
G_stk->discard(argc);
886
/* return the integer value */
887
retval_int(vmg_ intval);
891
/* if it's already an integer, just return the same value */
892
if (valp->typ == VM_INT)
894
/* just return the argument value */
895
retval_int(vmg_ valp->val.intval);
897
/* discard arguments (ignore the radix in this case) */
898
G_stk->discard(argc);
904
/* otherwise, it must be a string */
905
strp = pop_str_val(vmg0_);
906
len = vmb_get_len(strp);
908
/* if there's a radix specified, pop it as well */
911
/* get the radix from the stack */
912
radix = pop_int_val(vmg0_);
914
/* make sure the radix is valid */
921
/* it's okay - proceed */
925
/* other radix values are invalid */
926
err_throw(VMERR_BAD_VAL_BIF);
931
/* the default radix is decimal */
935
/* parse the value */
936
if (len == 3 && memcmp(strp + VMB_LEN, "nil", 3) == 0)
938
/* the value is the constant 'nil' */
941
else if (len == 4 && memcmp(strp + VMB_LEN, "true", 3) == 0)
943
/* the value is the constant 'true' */
953
/* scan past leading spaces */
954
for (p.set((char *)strp + VMB_LEN), rem = len ;
955
rem != 0 && is_space(p.getch()) ; p.inc(&rem)) ;
957
/* presume it's positive */
960
/* if the radix is 10, check for a leading + or - */
961
if (radix == 10 && rem != 0)
963
if (p.getch() == '-')
965
/* note the sign and skip the character */
969
else if (p.getch() == '+')
971
/* skip the character */
976
/* clear the accumulator */
979
/* scan the digits */
983
for ( ; rem != 0 && (p.getch() == '0' || p.getch() == '1') ;
987
if (p.getch() == '1')
993
for ( ; rem != 0 && is_odigit(p.getch()) ; p.inc(&rem))
996
acc += value_of_odigit(p.getch());
1001
for ( ; rem != 0 && is_digit(p.getch()) ; p.inc(&rem))
1004
acc += value_of_digit(p.getch());
1009
for ( ; rem != 0 && is_xdigit(p.getch()) ; p.inc(&rem))
1012
acc += value_of_xdigit(p.getch());
1017
/* apply the sign, if appropriate, and set the return value */
1019
retval_int(vmg_ -(long)acc);
1021
retval_int(vmg_ (long)acc);
1025
/* ------------------------------------------------------------------------ */
1027
* put an integer value in a constant list, advancing the list write
1030
static void put_list_int(char **dstp, long intval)
1034
/* set up the integer value */
1035
val.set_int(intval);
1037
/* write it to the list */
1038
vmb_put_dh(*dstp, &val);
1040
/* advance the output pointer */
1041
*dstp += VMB_DATAHOLDER;
1045
* put an object value in a constant list, advancing the list write
1048
static void put_list_obj(char **dstp, vm_obj_id_t objval)
1052
/* set up the integer value */
1053
val.set_obj(objval);
1055
/* write it to the list */
1056
vmb_put_dh(*dstp, &val);
1058
/* advance the output pointer */
1059
*dstp += VMB_DATAHOLDER;
1064
* get the current time
1066
void CVmBifTADS::gettime(VMG_ uint argc)
1074
/* check arguments */
1075
check_argc_range(vmg_ argc, 0, 1);
1077
/* if there's an argument, get the type of time value to return */
1080
/* get the time type code */
1081
typ = pop_int_val(vmg0_);
1085
/* use the default type */
1089
/* check the type */
1094
* default information - return the current time and date
1097
/* make sure the time zone is set up properly */
1100
/* get the local time information */
1102
tblock = localtime(&timer);
1104
/* adjust values for return format */
1105
tblock->tm_year += 1900;
1111
* build the return list: [year, month, day, day-of-week,
1112
* day-of-year, hour, minute, second, seconds-since-1970]
1114
vmb_put_len(buf, 9);
1115
dst = buf + VMB_LEN;
1117
/* build return list value */
1118
put_list_int(&dst, tblock->tm_year);
1119
put_list_int(&dst, tblock->tm_mon);
1120
put_list_int(&dst, tblock->tm_mday);
1121
put_list_int(&dst, tblock->tm_wday);
1122
put_list_int(&dst, tblock->tm_yday);
1123
put_list_int(&dst, tblock->tm_hour);
1124
put_list_int(&dst, tblock->tm_min);
1125
put_list_int(&dst, tblock->tm_sec);
1126
put_list_int(&dst, (long)timer);
1128
/* allocate and return the list value */
1129
retval_obj(vmg_ CVmObjList::create(vmg_ FALSE, buf));
1136
* They want the high-precision system timer value, which returns
1137
* the time in milliseconds from an arbitrary zero point.
1141
static unsigned long t_zero;
1142
static int t_zero_set = FALSE;
1144
/* retrieve the raw time from the operating system */
1145
t = os_get_sys_clock_ms();
1148
* We only have 31 bits of precision in our result (since we
1149
* must fit the value into a signed integer), so we can only
1150
* represent time differences of about 23 days. Now, the
1151
* value from the OS could be at any arbitrary point in our
1152
* 23-day range, so there's a nontrivial probability that the
1153
* raw OS value is near enough to the wrapping point that a
1154
* future call to this same function during the current
1155
* session could encounter the wrap condition. The caller is
1156
* likely to be confused by this, because the time difference
1157
* from this call to that future call would appear to be
1160
* There's obviously no way we can eliminate the possibility
1161
* of a negative time difference if the current program
1162
* session lasts more than 23 days of continuous execution.
1163
* Fortunately, it seems unlikely that most sessions will be
1164
* so long, which gives us a way to reduce the likelihood that
1165
* the program will encounter a wrapped timer: we can adjust
1166
* the zero point of the timer to the time of the first call
1167
* to this function. That way, the timer will wrap only if
1168
* the program session runs continuously until the timer's
1169
* range is exhausted.
1173
/* this is the first call - remember the zero point */
1179
* Adjust the time by subtracting the zero point from the raw
1180
* OS timer. This will give us the number of milliseconds
1181
* from our zero point.
1183
* If the system timer has wrapped since our zero point, we'll
1184
* get what looks like a negative number; but what we really
1185
* have is a large positive number with a borrow from an
1186
* unrepresented higher-precision portion, so the fact that
1187
* this value is negative doesn't matter - it will still be
1188
* sequential when treated as unsigned.
1193
* whatever we got, keep only the low-order 31 bits, since we
1194
* only have 31 bits in which to represent an unsigned value
1198
/* return the value we've calculated */
1204
err_throw(VMERR_BAD_VAL_BIF);
1208
/* ------------------------------------------------------------------------ */
1210
* re_match - match a regular expression to a string
1212
void CVmBifTADS::re_match(VMG_ uint argc)
1218
vm_val_t *v1, *v2, *v3;
1220
CVmObjPattern *pat_obj = 0;
1221
const char *pat_str = 0;
1223
/* check arguments */
1224
check_argc_range(vmg_ argc, 2, 3);
1227
* make copies of the arguments, so we can pop the values without
1228
* actually removing them from the stack - leave the originals on the
1229
* stack for gc protection
1233
v3 = (argc >= 3 ? G_stk->get(2) : 0);
1237
/* note the starting index, if given */
1241
/* check the type */
1242
if (v3->typ != VM_INT)
1243
err_throw(VMERR_BAD_TYPE_BIF);
1246
start_idx = (int)v3->val.intval - 1;
1248
/* make sure it's in range */
1253
/* remember the last search string (the second argument) */
1254
G_bif_tads_globals->last_rex_str->val = *v2;
1257
* check what we have for the pattern - we could have either a string
1258
* giving the regular expression, or a RexPattern object with the
1261
if (G_stk->get(0)->typ == VM_OBJ
1262
&& CVmObjPattern::is_pattern_obj(vmg_ G_stk->get(0)->val.obj))
1266
/* get the pattern object */
1267
G_stk->pop(&pat_val);
1268
pat_obj = (CVmObjPattern *)vm_objp(vmg_ pat_val.val.obj);
1272
/* get the pattern string */
1273
pat_str = pop_str_val(vmg0_);
1276
/* get the string to match */
1277
str = pop_str_val(vmg0_);
1278
len = vmb_get_len(str);
1279
p.set((char *)str + VMB_LEN);
1281
/* skip to the starting index */
1282
for ( ; start_idx > 0 && len != 0 ; --start_idx, p.inc(&len)) ;
1284
/* match the pattern */
1287
/* match the compiled pattern object */
1288
match_len = G_bif_tads_globals->rex_searcher->
1289
match_pattern(pat_obj->get_pattern(vmg0_),
1290
str + VMB_LEN, p.getptr(), len);
1294
/* match the pattern to the regular expression string */
1295
match_len = G_bif_tads_globals->rex_searcher->
1296
compile_and_match(pat_str + VMB_LEN, vmb_get_len(pat_str),
1297
str + VMB_LEN, p.getptr(), len);
1300
/* check for a match */
1303
/* we got a match - calculate the character length of the match */
1304
retval_int(vmg_ (long)p.len(match_len));
1308
/* no match - return nil */
1312
/* discard the arguments */
1313
G_stk->discard(argc);
1317
* re_search - search for a substring matching a regular expression
1320
void CVmBifTADS::re_search(VMG_ uint argc)
1327
vm_val_t *v1, *v2, *v3;
1330
CVmObjPattern *pat_obj = 0;
1331
const char *pat_str = 0;
1333
/* check arguments */
1334
check_argc_range(vmg_ argc, 2, 3);
1337
* make copies of the arguments, so we can pop the values without
1338
* actually removing them from the stack - leave the originals on the
1339
* stack for gc protection
1343
v3 = (argc >= 3 ? G_stk->get(2) : 0);
1347
/* note the starting index, if given */
1351
/* check the type */
1352
if (v3->typ != VM_INT)
1353
err_throw(VMERR_BAD_TYPE_BIF);
1356
start_idx = (int)v3->val.intval - 1;
1358
/* make sure it's in range */
1363
/* remember the last search string (the second argument) */
1364
G_bif_tads_globals->last_rex_str->val = *v2;
1366
/* check to see if we have a RexPattern object or an uncompiled string */
1367
if (G_stk->get(0)->typ == VM_OBJ
1368
&& CVmObjPattern::is_pattern_obj(vmg_ G_stk->get(0)->val.obj))
1372
/* get the pattern object */
1373
G_stk->pop(&pat_val);
1374
pat_obj = (CVmObjPattern *)vm_objp(vmg_ pat_val.val.obj);
1378
/* get the pattern string */
1379
pat_str = pop_str_val(vmg0_);
1382
/* get the string to search for the pattern */
1383
str = pop_str_val(vmg0_);
1384
p.set((char *)str + VMB_LEN);
1385
len = vmb_get_len(str);
1387
/* skip to the starting index */
1388
for (i = start_idx ; i > 0 && len != 0 ; --i, p.inc(&len)) ;
1390
/* search for the pattern */
1393
/* try finding the compiled pattern */
1394
match_idx = G_bif_tads_globals->rex_searcher->search_for_pattern(
1395
pat_obj->get_pattern(vmg0_),
1396
str + VMB_LEN, p.getptr(), len, &match_len);
1400
/* try finding the regular expression string pattern */
1401
match_idx = G_bif_tads_globals->rex_searcher->compile_and_search(
1402
pat_str + VMB_LEN, vmb_get_len(pat_str),
1403
str + VMB_LEN, p.getptr(), len, &match_len);
1406
/* check for a match */
1412
vm_obj_id_t match_str_obj;
1414
char buf[VMB_LEN + VMB_DATAHOLDER * 3];
1417
* We got a match - calculate the character index of the match
1418
* offset, adjusted to a 1-base. The character index is simply the
1419
* number of characters in the part of the string up to the match
1420
* index. Note that we have to add the starting index to get the
1421
* actual index in the overall string, since 'p' points to the
1422
* character at the starting index.
1424
char_idx = p.len(match_idx) + start_idx + 1;
1426
/* calculate the character length of the match */
1427
matchp.set(p.getptr() + match_idx);
1428
char_len = matchp.len(match_len);
1430
/* allocate a string containing the match */
1432
CVmObjString::create(vmg_ FALSE, matchp.getptr(), match_len);
1434
/* push it momentarily as protection against garbage collection */
1435
G_stk->push()->set_obj(match_str_obj);
1438
* set up a 3-element list to contain the return value:
1439
* [match_start_index, match_length, match_string]
1441
vmb_put_len(buf, 3);
1442
dst = buf + VMB_LEN;
1443
put_list_int(&dst, (long)char_idx);
1444
put_list_int(&dst, (long)char_len);
1445
put_list_obj(&dst, match_str_obj);
1447
/* allocate and return the list */
1448
retval_obj(vmg_ CVmObjList::create(vmg_ FALSE, buf));
1450
/* we no longer need the garbage collection protection */
1455
/* no match - return nil */
1459
/* discard the arguments */
1460
G_stk->discard(argc);
1464
* re_group - get the string matching a group in the most recent regular
1465
* expression search or match
1467
void CVmBifTADS::re_group(VMG_ uint argc)
1470
const re_group_register *reg;
1471
char buf[VMB_LEN + 3*VMB_DATAHOLDER];
1475
const char *last_str;
1478
/* check arguments */
1479
check_argc(vmg_ argc, 1);
1481
/* get the group number to retrieve */
1482
groupno = pop_int_val(vmg0_);
1484
/* make sure it's in range */
1485
if (groupno < 1 || groupno > RE_GROUP_REG_CNT)
1486
err_throw(VMERR_BAD_VAL_BIF);
1488
/* adjust from a 1-base to a 0-base */
1491
/* if the group doesn't exist in the pattern, return nil */
1492
if (groupno >= G_bif_tads_globals->rex_searcher->get_group_cnt())
1499
* get the previous search string - get a pointer directly to the
1500
* contents of the string
1502
last_str = G_bif_tads_globals->last_rex_str->val.get_as_string(vmg0_);
1504
/* get the register */
1505
reg = G_bif_tads_globals->rex_searcher->get_group_reg(groupno);
1507
/* if the group wasn't set, or there's no last string, return nil */
1508
if (last_str == 0 || reg->start_ofs == -1 || reg->end_ofs == -1)
1514
/* set up for a list with three elements */
1515
vmb_put_len(buf, 3);
1516
dst = buf + VMB_LEN;
1518
/* get the starting offset from the group register */
1519
start_byte_ofs = reg->start_ofs;
1522
* The first element is the character index of the group text in the
1523
* source string. Calculate the character index by adding 1 to the
1524
* character length of the text preceding the group; calculate the
1525
* character length from the byte length of that string. Note that the
1526
* starting in the group register is stored from the starting point of
1527
* the search, not the start of the string, so we need to add in the
1528
* starting point in the search.
1530
p.set((char *)last_str + VMB_LEN);
1531
put_list_int(&dst, p.len(start_byte_ofs) + 1);
1534
* The second element is the character length of the group text.
1535
* Calculate the character length from the byte length.
1537
p.set(p.getptr() + start_byte_ofs);
1538
put_list_int(&dst, p.len(reg->end_ofs - reg->start_ofs));
1541
* The third element is the string itself. Create a new string
1542
* containing the matching substring.
1544
strobj = CVmObjString::create(vmg_ FALSE, p.getptr(),
1545
reg->end_ofs - reg->start_ofs);
1546
put_list_obj(&dst, strobj);
1548
/* save the string on the stack momentarily to protect against GC */
1549
G_stk->push()->set_obj(strobj);
1551
/* create and return the list value */
1552
retval_obj(vmg_ CVmObjList::create(vmg_ FALSE, buf));
1554
/* we no longer need the garbage collector protection */
1561
#define VMBIFTADS_REPLACE_ALL 0x0001
1564
* re_replace - search for a pattern in a string, and apply a
1565
* replacement pattern
1567
void CVmBifTADS::re_replace(VMG_ uint argc)
1569
vm_val_t patval, rplval;
1573
vm_val_t search_val;
1580
const re_group_register *reg;
1581
vm_obj_id_t ret_obj;
1585
re_compiled_pattern *cpat;
1591
/* check arguments */
1592
check_argc_range(vmg_ argc, 4, 5);
1594
/* remember the pattern and replacement string values */
1595
patval = *G_stk->get(0);
1596
rplval = *G_stk->get(2);
1598
/* retrieve the compiled RexPattern or uncompiled pattern string */
1599
if (G_stk->get(0)->typ == VM_OBJ
1600
&& CVmObjPattern::is_pattern_obj(vmg_ G_stk->get(0)->val.obj))
1605
/* get the pattern object */
1606
G_stk->pop(&pat_val);
1607
pat = (CVmObjPattern *)vm_objp(vmg_ pat_val.val.obj);
1609
/* get the compiled pattern structure */
1610
cpat = pat->get_pattern(vmg0_);
1612
/* the pattern isn't ours, so we don't need to delete it */
1613
cpat_is_ours = FALSE;
1618
const char *pat_str;
1620
/* pop the pattern string */
1621
pat_str = pop_str_val(vmg0_);
1623
/* since we'll need it multiple times, compile it */
1624
stat = G_bif_tads_globals->rex_parser->compile_pattern(
1625
pat_str + VMB_LEN, vmb_get_len(pat_str), &cpat);
1627
/* if that failed, we don't have a pattern */
1628
if (stat != RE_STATUS_SUCCESS)
1631
/* note that we allocated the pattern, so we have to delete it */
1632
cpat_is_ours = TRUE;
1636
* Pop the search string and the replacement string. Note that we want
1637
* to retain the original value information for the search string,
1638
* since we'll end up returning it unchanged if we don't find the
1641
G_stk->pop(&search_val);
1642
rpl = pop_str_val(vmg0_);
1644
/* remember the last search string */
1645
G_bif_tads_globals->last_rex_str->val = search_val;
1648
flags = pop_long_val(vmg0_);
1650
/* pop the starting index if given */
1651
start_char_idx = (argc >= 5 ? pop_int_val(vmg0_) - 1 : 0);
1653
/* make sure it's in range */
1654
if (start_char_idx < 0)
1658
* put the pattern, replacement string, and search string values back
1659
* on the stack as protection against garbage collection
1661
G_stk->push(&patval);
1662
G_stk->push(&rplval);
1663
G_stk->push(&search_val);
1665
/* make sure the search string is indeed a string */
1666
str = search_val.get_as_string(vmg0_);
1668
err_throw(VMERR_STRING_VAL_REQD);
1671
* figure out how many bytes at the start of the string to skip before
1672
* our first replacement
1674
for (p.set((char *)str + VMB_LEN), rem = vmb_get_len(str) ;
1675
start_char_idx > 0 && rem != 0 ; --start_char_idx, p.inc(&rem)) ;
1677
/* the current offset in the string is the byte skip offset */
1678
skip_bytes = p.getptr() - (str + VMB_LEN);
1681
* if we don't have a compiled pattern at this point, we're not going
1682
* to be able to match anything, so we can just stop now and return the
1683
* original string unchanged
1687
/* return the original search string */
1688
retval(vmg_ &search_val);
1692
/* note the group count in the compiled pattern */
1693
group_cnt = cpat->group_cnt;
1696
* First, determine how long the result string will be. Search
1697
* repeatedly if the REPLACE_ALL flag (0x0001) is set.
1699
for (new_len = skip_bytes, match_cnt = 0, start_idx = skip_bytes ;
1700
(size_t)start_idx < vmb_get_len(str) ; ++match_cnt)
1702
const char *last_str;
1704
/* figure out where the next search starts */
1705
last_str = str + VMB_LEN + start_idx;
1707
/* search for the pattern in the search string */
1708
match_idx = G_bif_tads_globals->rex_searcher->search_for_pattern(
1709
cpat, str + VMB_LEN, last_str, vmb_get_len(str) - start_idx,
1712
/* if there was no match, there is no more replacing to do */
1713
if (match_idx == -1)
1716
* if we haven't found a match before, there's no
1717
* replacement at all to do -- just return the original
1722
/* no replacement - return the original search string */
1723
retval(vmg_ &search_val);
1728
/* we've found all of our matches - stop searching */
1734
* We've found a match to replace. Determine how much space we
1735
* need for the replacement pattern with its substitution
1736
* parameters replaced with the original string's matching text.
1738
* First, add in the length of the part from the start of this
1739
* segment of the search to the matched substring.
1741
new_len += match_idx;
1744
* now, scan the replacement string and add in its length and
1745
* the lengths of substitution parameters
1747
for (p.set((char *)rpl + VMB_LEN), rem = vmb_get_len(rpl) ;
1748
rem != 0 ; p.inc(&rem))
1750
/* check for '%' sequences */
1751
if (p.getch() == '%')
1756
/* if there's anything left, see what we have */
1770
/* get the group number */
1771
groupno = value_of_digit(p.getch()) - 1;
1773
/* if this group is valid, add its length */
1774
if (groupno < group_cnt)
1776
/* get the register */
1777
reg = G_bif_tads_globals->rex_searcher
1778
->get_group_reg(groupno);
1780
/* if it's been set, add its length */
1781
if (reg->start_ofs != -1 && reg->end_ofs != -1)
1782
new_len += reg->end_ofs - reg->start_ofs;
1787
/* add the entire match size */
1788
new_len += match_len;
1792
/* add a single '%' */
1797
/* add the entire sequence unchanged */
1805
/* count this character literally */
1806
new_len += p.charsize();
1810
/* start the next search after the end of this match */
1811
start_idx += match_idx + match_len;
1814
* if the match length was zero, skip one more character - a zero
1815
* length match will just match again at the same spot forever, so
1816
* once we replace it once we need to move on to avoid an infinite
1821
/* move past the input */
1824
/* we'll copy this character to the output, so make room for it */
1829
* if we're only replacing a single match, stop now; otherwise,
1832
if (!(flags & VMBIFTADS_REPLACE_ALL))
1836
/* add in the size of the remainder of the string after the last match */
1837
new_len += vmb_get_len(str) - start_idx;
1839
/* allocate the result string */
1840
ret_obj = CVmObjString::create(vmg_ FALSE, new_len);
1842
/* get a pointer to the result buffer */
1843
dstp.set(((CVmObjString *)vm_objp(vmg_ ret_obj))->cons_get_buf());
1845
/* copy the initial part that we're skipping */
1846
if (skip_bytes != 0)
1848
memcpy(dstp.getptr(), str + VMB_LEN, skip_bytes);
1849
dstp.set(dstp.getptr() + skip_bytes);
1853
* Once again, start searching from the beginning of the string.
1854
* This time, build the result string as we go.
1856
for (start_idx = skip_bytes ; (size_t)start_idx < vmb_get_len(str) ; )
1858
const char *last_str;
1860
/* figure out where the next search starts */
1861
last_str = str + VMB_LEN + start_idx;
1863
/* search for the pattern */
1864
match_idx = G_bif_tads_globals->rex_searcher->search_for_pattern(
1865
cpat, str + VMB_LEN, last_str, vmb_get_len(str) - start_idx,
1868
/* stop if we can't find another match */
1872
/* copy the part up to the start of the matched text, if any */
1875
/* copy the part from the last match to this match */
1876
memcpy(dstp.getptr(), last_str, match_idx);
1878
/* advance the output pointer */
1879
dstp.set(dstp.getptr() + match_idx);
1883
* Scan the replacement string again, and this time actually
1886
for (p.set((char *)rpl + VMB_LEN), rem = vmb_get_len(rpl) ;
1887
rem != 0 ; p.inc(&rem))
1889
/* check for '%' sequences */
1890
if (p.getch() == '%')
1895
/* if there's anything left, see what we have */
1909
/* get the group number */
1910
groupno = value_of_digit(p.getch()) - 1;
1912
/* if this group is valid, add its length */
1913
if (groupno < group_cnt)
1915
/* get the register */
1916
reg = G_bif_tads_globals->rex_searcher
1917
->get_group_reg(groupno);
1919
/* if it's been set, add its text */
1920
if (reg->start_ofs != -1 && reg->end_ofs != -1)
1924
/* get the group length */
1925
glen = reg->end_ofs - reg->start_ofs;
1928
memcpy(dstp.getptr(),
1929
str + VMB_LEN + reg->start_ofs, glen);
1931
/* advance past it */
1932
dstp.set(dstp.getptr() + glen);
1938
/* add the entire matched string */
1939
memcpy(dstp.getptr(), last_str + match_idx,
1941
dstp.set(dstp.getptr() + match_len);
1945
/* add a single '%' */
1950
/* add the entire sequence unchanged */
1952
dstp.setch(p.getch());
1959
/* copy this character literally */
1960
dstp.setch(p.getch());
1964
/* advance past this matched string for the next search */
1965
start_idx += match_idx + match_len;
1967
/* skip to the next character if it was a zero-length match */
1970
/* copy the character we're skipping to the output */
1971
p.set((char *)str + VMB_LEN + start_idx);
1972
dstp.setch(p.getch());
1974
/* move on to the next character */
1978
/* if we're only performing a single replacement, stop now */
1979
if (!(flags & VMBIFTADS_REPLACE_ALL))
1983
/* add the part after the end of the matched text */
1984
if ((size_t)start_idx < vmb_get_len(str))
1985
memcpy(dstp.getptr(), str + VMB_LEN + start_idx,
1986
vmb_get_len(str) - start_idx);
1988
/* return the string */
1989
retval_obj(vmg_ ret_obj);
1992
/* discard the garbage collection protection references */
1995
/* if we created the pattern string, delete it */
1996
if (cpat != 0 && cpat_is_ours)
1997
CRegexParser::free_pattern(cpat);
2000
/* ------------------------------------------------------------------------ */
2002
* savepoint - establish an undo savepoint
2004
void CVmBifTADS::savepoint(VMG_ uint argc)
2006
/* check arguments */
2007
check_argc(vmg_ argc, 0);
2009
/* establish the savepoint */
2010
G_undo->create_savept(vmg0_);
2014
* undo - undo changes to most recent savepoint
2016
void CVmBifTADS::undo(VMG_ uint argc)
2018
/* check arguments */
2019
check_argc(vmg_ argc, 0);
2021
/* if no undo is available, return nil to indicate that we can't undo */
2022
if (G_undo->get_savept_cnt() == 0)
2029
/* undo to the savepoint */
2030
G_undo->undo_to_savept(vmg0_);
2032
/* tell the caller that we succeeded */
2037
/* ------------------------------------------------------------------------ */
2041
void CVmBifTADS::save(VMG_ uint argc)
2043
char fname[OSFNMAX];
2047
/* check arguments */
2048
check_argc(vmg_ argc, 1);
2050
/* get the filename as a null-terminated string */
2051
pop_str_val_fname(vmg_ fname, sizeof(fname));
2054
fp = osfoprwtb(fname, OSFTT3SAV);
2056
err_throw(VMERR_CREATE_FILE);
2058
/* set up the file writer */
2059
file = new CVmFile();
2060
file->set_file(fp, 0);
2064
/* save the state */
2065
CVmSaveFile::save(vmg_ file);
2069
/* close the file */
2078
void CVmBifTADS::restore(VMG_ uint argc)
2080
char fname[OSFNMAX];
2085
/* check arguments */
2086
check_argc(vmg_ argc, 1);
2088
/* get the filename as a null-terminated string */
2089
pop_str_val_fname(vmg_ fname, sizeof(fname));
2092
fp = osfoprb(fname, OSFTT3SAV);
2094
err_throw(VMERR_FILE_NOT_FOUND);
2096
/* set up the file reader */
2097
file = new CVmFile();
2098
file->set_file(fp, 0);
2102
/* restore the state */
2103
err = CVmSaveFile::restore(vmg_ file);
2107
/* close the file */
2112
/* if an error occurred, throw an exception */
2120
void CVmBifTADS::restart(VMG_ uint argc)
2122
/* check arguments */
2123
check_argc(vmg_ argc, 0);
2125
/* reset the VM to the image file's initial state */
2126
CVmSaveFile::reset(vmg0_);
2130
/* ------------------------------------------------------------------------ */
2132
* Get the maximum value from a set of argument
2134
void CVmBifTADS::get_max(VMG_ uint argc)
2139
/* make sure we have at least one argument */
2141
err_throw(VMERR_WRONG_NUM_OF_ARGS);
2143
/* start with the first argument as the presumptive maximum */
2144
cur_max = *G_stk->get(0);
2146
/* compare each argument in turn */
2147
for (i = 1 ; i < argc ; ++i)
2150
* compare this value to the maximum so far; if this value is
2151
* greater, it becomes the new maximum so far
2153
if (G_stk->get(i)->compare_to(vmg_ &cur_max) > 0)
2154
cur_max = *G_stk->get(i);
2157
/* discard the arguments */
2158
G_stk->discard(argc);
2160
/* return the maximum value */
2161
retval(vmg_ &cur_max);
2165
* Get the minimum value from a set of argument
2167
void CVmBifTADS::get_min(VMG_ uint argc)
2172
/* make sure we have at least one argument */
2174
err_throw(VMERR_WRONG_NUM_OF_ARGS);
2176
/* start with the first argument as the presumptive minimum */
2177
cur_min = *G_stk->get(0);
2179
/* compare each argument in turn */
2180
for (i = 1 ; i < argc ; ++i)
2183
* compare this value to the minimum so far; if this value is
2184
* less, it becomes the new minimum so far
2186
if (G_stk->get(i)->compare_to(vmg_ &cur_min) < 0)
2187
cur_min = *G_stk->get(i);
2190
/* discard the arguments */
2191
G_stk->discard(argc);
2193
/* return the minimum value */
2194
retval(vmg_ &cur_min);
2197
/* ------------------------------------------------------------------------ */
2199
* makeString - construct a string by repeating a character; by
2200
* converting a unicode code point to a string; or by converting a list
2201
* of unicode code points to a string
2203
void CVmBifTADS::make_string(VMG_ uint argc)
2207
vm_obj_id_t new_str_obj;
2208
CVmObjString *new_str;
2211
const char *lstp = 0;
2212
const char *strp = 0;
2217
/* check arguments */
2218
check_argc_range(vmg_ argc, 1, 2);
2220
/* get the base value */
2223
/* if there's a repeat count, get it */
2224
rpt = (argc >= 2 ? pop_long_val(vmg0_) : 1);
2226
/* if the repeat count is less than or equal to zero, make it 1 */
2230
/* leave the original value on the stack to protect it from GC */
2234
* see what we have, and calculate how much space we'll need for the
2240
/* it's a list of integers giving unicode character values */
2241
lstp = G_const_pool->get_ptr(val.val.ofs);
2244
/* get the list count */
2245
len = vmb_get_len(lstp);
2248
* Run through the list and get the size of each character, so
2249
* we can determine how long the string will have to be.
2251
for (new_str_len = 0, i = 1 ; i <= len ; ++i)
2255
/* get this element */
2256
CVmObjList::index_list(vmg_ &ele_val, lstp, i);
2258
/* if it's not an integer, it's an error */
2259
if (ele_val.typ != VM_INT)
2260
err_throw(VMERR_INT_VAL_REQD);
2262
/* add this character's byte size to the string size */
2264
utf8_ptr::s_wchar_size((wchar_t)ele_val.val.intval);
2269
/* get the string pointer */
2270
strp = G_const_pool->get_ptr(val.val.ofs);
2274
* it's a string - the output length is the same as the input
2277
new_str_len = vmb_get_len(strp);
2282
* it's an integer giving a unicode character value - we just
2283
* need enough space to store this particular character
2285
new_str_len = utf8_ptr::s_wchar_size((wchar_t)val.val.intval);
2289
/* check to see if it's a string */
2290
if ((strp = val.get_as_string(vmg0_)) != 0)
2293
/* check to see if it's a list */
2294
if ((lstp = val.get_as_list(vmg0_)) != 0)
2298
err_throw(VMERR_BAD_TYPE_BIF);
2302
/* other types are invalid */
2303
err_throw(VMERR_BAD_TYPE_BIF);
2308
* if the length times the repeat count would be over the maximum
2309
* 16-bit string length, it's an error
2311
if (new_str_len * rpt > 0xffffL - VMB_LEN)
2312
err_throw(VMERR_BAD_VAL_BIF);
2314
/* multiply the length by the repeat count */
2317
/* allocate the string and gets its buffer */
2318
new_str_obj = CVmObjString::create(vmg_ FALSE, new_str_len);
2319
new_str = (CVmObjString *)vm_objp(vmg_ new_str_obj);
2320
new_strp = new_str->cons_get_buf();
2322
/* set up the destination pointer */
2325
/* run through the number of iterations requested */
2326
for ( ; rpt != 0 ; --rpt)
2328
/* build one iteration of the string, according to the type */
2331
/* run through the list */
2332
for (i = 1 ; i <= len ; ++i)
2336
/* get this element */
2337
CVmObjList::index_list(vmg_ &ele_val, lstp, i);
2339
/* add this character to the string */
2340
dst.setch((wchar_t)ele_val.val.intval);
2345
/* copy the string's contents into the output string */
2346
memcpy(dst.getptr(), strp + VMB_LEN, vmb_get_len(strp));
2348
/* advance past the bytes we copied */
2349
dst.set(dst.getptr() + vmb_get_len(strp));
2353
/* set this int value */
2354
dst.setch((wchar_t)val.val.intval);
2358
/* return the new string */
2359
retval_obj(vmg_ new_str_obj);
2361
/* discard the GC protection */
2365
/* ------------------------------------------------------------------------ */
2369
void CVmBifTADS::get_func_params(VMG_ uint argc)
2374
vm_obj_id_t lst_obj;
2377
/* check arguments */
2378
check_argc(vmg_ argc, 1);
2380
/* the argument can be an anonymous function object or function pointer */
2381
if (G_stk->get(0)->typ == VM_OBJ
2382
&& G_predef->obj_call_prop != VM_INVALID_PROP)
2387
/* it's an anonymous function - get the object */
2388
G_interpreter->pop_obj(vmg_ &func);
2390
/* retrieve its ObjectCallProp value, and make sure it's a function */
2391
if (!vm_objp(vmg_ func.val.obj)->get_prop(
2392
vmg_ G_predef->obj_call_prop, &func, func.val.obj, &srcobj, &argc)
2393
|| func.typ != VM_FUNCPTR)
2394
err_throw(VMERR_FUNCPTR_VAL_REQD);
2398
/* it's a simple function pointer - retrieve it */
2399
G_interpreter->pop_funcptr(vmg_ &func);
2402
/* set up a pointer to the function header */
2403
hdr.set((const uchar *)G_code_pool->get_ptr(func.val.ofs));
2406
* Allocate our return list. We need three elements: [minArgs,
2407
* optionalArgs, isVarargs].
2409
lst_obj = CVmObjList::create(vmg_ FALSE, 3);
2411
/* get the list object, properly cast */
2412
lst = (CVmObjList *)vm_objp(vmg_ lst_obj);
2414
/* set the minimum argument count */
2415
val.set_int(hdr.get_min_argc());
2416
lst->cons_set_element(0, &val);
2419
* set the optional argument count (which is always zero for a
2420
* function, since there is no way to specify named optional arguments
2424
lst->cons_set_element(1, &val);
2426
/* set the varargs flag */
2427
val.set_logical(hdr.is_varargs());
2428
lst->cons_set_element(2, &val);
2430
/* return the list */
2431
retval_obj(vmg_ lst_obj);
2434
* re-touch the currently executing method's code page to make sure
2435
* it's the most recently used item in the cache, to avoid swapping it
2438
G_interpreter->touch_entry_ptr_page(vmg0_);
added
removed
tads/tads3/vmbiftad.cpp
