1 /*
2 * The Regina Rexx Interpreter
3 * Copyright (C) 1992-1994 Anders Christensen <anders@pvv.unit.no>
4 *
5 * This library is free software; you can redistribute it and/or
6 * modify it under the terms of the GNU Library General Public
7 * License as published by the Free Software Foundation; either
8 * version 2 of the License, or (at your option) any later version.
9 *
10 * This library is distributed in the hope that it will be useful,
11 * but WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 * Library General Public License for more details.
14 *
15 * You should have received a copy of the GNU Library General Public
16 * License along with this library; if not, write to the Free
17 * Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
18 */
19
20 #include "rexx.h"
21 #include <stdio.h>
22 #include <string.h>
23 #ifndef VMS
24 # ifdef HAVE_UNISTD_H
25 # include <unistd.h>
26 # endif
27 #endif
28 #ifdef HAVE_ASSERT_H
29 # include <assert.h>
30 #endif
31
32 #define XOR(a,b) (( (a) && (!(b)) )||( (!(a)) && (b) ))
33
34 #ifdef WIN32
35 /* Asynchroneous scheduled in another thread: */
36 volatile int __regina_Win32CtrlCRaised = 0;
37 #endif
38
39 static const char default_action[SIGNALS] = { 1, 1, 0, 1, 1, 0 } ;
40 static const char default_ignore[SIGNALS] = { 1, 1, 0, 0, 1, 0 } ;
41
42 #define NSTACKELEMS 32 /* nstack elements will be allocated in this size */
43 typedef struct _nstackbox {
44 struct _nstackbox *next;
45 struct _nstackbox *prev;
46 unsigned used;
47 unsigned sum; /* To provide safe triggers, never use ptrs */
48 nodeptr elems[NSTACKELEMS];
49 } nstackbox;
50
51 typedef struct _stackelem {
52 #ifdef OPT_DO
53 int strmath; /* 0 if we can do binary arithmetic for this DO loop */
54 /* DO ... FOR x: value of x */
55 num_descr * do_for_val;
56 rx_64 do_for_val_num ;
57 #else
58 int number;
59 #endif
60 int incrdir ;
61 num_descr * increment ;
62 /* DO ... TO x: value of x */
63 num_descr * stopval ;
64 #ifdef OPT_DO
65 rx_64 stopval_num;
66 #endif
67 nodeptr thisptr ;
68 cnodeptr incr_node;
69 struct _stackelem *prev ; /* needed for a look back */
70 } stackelem;
71
72 #define STACKELEMS 64 /* nstack elements will be allocated in this size */
73 typedef struct _stackbox {
74 struct _stackbox *next;
75 struct _stackbox *prev;
76 unsigned used;
77 unsigned sum; /* To provide safe triggers, never use ptrs */
78 stackelem elems[STACKELEMS];
79 } stackbox;
80
81 typedef struct { /* itp_tsd: static variables of this module (thread-safe) */
82 nstackbox nbox;
83 nstackbox *nbox_top;
84 stackbox sbox;
85 stackbox *stk_top;
86 unsigned long options;
87 int opts_set;
88 } itp_tsd_t; /* thread-specific but only needed by this module. see
89 * init_spec_vars
90 */
91
92
93
94 static void expose_indir( tsd_t *TSD, const streng *list ) ;
95
96 #ifdef TRACEMEM
mark_spec_vars(const tsd_t * TSD)97 static void mark_spec_vars(const tsd_t *TSD)
98 {
99 itp_tsd_t *it;
100
101 it = (itp_tsd_t *) TSD->itp_tsd;
102 }
103 #endif /* TRACEMEM */
104
105
106 /*
107 * The function returns 1 on success, 0 if memory is short.
108 */
init_spec_vars(tsd_t * TSD)109 int init_spec_vars( tsd_t *TSD )
110 {
111 itp_tsd_t *it;
112
113 if (TSD->itp_tsd != NULL)
114 return(1);
115
116 if ( ( TSD->itp_tsd = MallocTSD( sizeof(itp_tsd_t) ) ) == NULL )
117 return(0);
118 it = (itp_tsd_t *)TSD->itp_tsd;
119 memset(it,0,sizeof(itp_tsd_t));
120
121 it->nbox_top = &it->nbox;
122 it->stk_top = &it->sbox;
123
124 #ifdef TRACEMEM
125 regmarker( TSD, mark_spec_vars ) ;
126 #endif
127 return(1);
128 }
129
130
update_envirs(const tsd_t * TSD,proclevel level)131 void update_envirs( const tsd_t *TSD, proclevel level )
132 {
133 proclevel lptr=NULL ;
134
135 if (!level->environment)
136 {
137 for (lptr=level->prev; lptr; lptr=lptr->prev)
138 {
139 if (lptr->environment)
140 {
141 level->environment = Str_dupTSD(lptr->environment) ;
142 break ;
143 }
144 }
145 }
146 if (!level->prev_env)
147 {
148 for (lptr=level->prev; lptr; lptr=lptr->prev)
149 {
150 if (lptr->prev_env)
151 {
152 level->prev_env = Str_dupTSD(lptr->prev_env) ;
153 break ;
154 }
155 }
156 }
157
158 assert( level->environment ) ;
159 assert( level->prev_env ) ;
160 }
161
162 /* nstackpush pushes the arg pnode on the nstack. (copy, then increment)
163 */
nstackpush(const tsd_t * TSD,nodeptr pnode)164 static void nstackpush(const tsd_t *TSD,nodeptr pnode)
165 {
166 itp_tsd_t *it;
167 nstackbox *ns;
168
169 it = (itp_tsd_t *)TSD->itp_tsd;
170 ns = it->nbox_top;
171 ns->elems[ns->used++] = pnode;
172 if (ns->used >= NSTACKELEMS)
173 {
174 if (ns->next == NULL)
175 {
176 ns->next = (nstackbox *)MallocTSD(sizeof(nstackbox));
177 ns->next->prev = ns;
178 ns->next->next = NULL;
179 ns->next->used = 0;
180 ns->next->sum = ns->sum + NSTACKELEMS;
181 }
182 assert( ns->next->used == 0 ) ; /* be sure to have an empty block */
183 it->nbox_top = ns->next;
184 }
185 }
186
187 /* nstackpop pops an element from the nstack. (decrement, then copy)
188 * The return is the saved value formerly saved by a call to nstackpush.
189 * nstackpush/nstackpop calls may be nested.
190 * The return value is NULL in case of an empty stack.
191 * We use a delayed cleanup (one free nstackbox is available while popping).
192 */
nstackpop(const tsd_t * TSD)193 static nodeptr nstackpop(const tsd_t *TSD)
194 {
195 itp_tsd_t *it;
196 nstackbox *ns;
197
198 it = (itp_tsd_t *)TSD->itp_tsd;
199 ns = it->nbox_top;
200 if (ns->used == 0)
201 {
202 /* For a delayed deletion preserve this box and delete the next one */
203 if (ns->next)
204 {
205 FreeTSD(ns->next);
206 ns->next = NULL;
207 }
208 assert(ns->prev);
209 if (!ns->prev)
210 {
211 return(NULL);
212 }
213 it->nbox_top = ns = ns->prev;
214 }
215 ns->used--;
216 return(ns->elems[ns->used]);
217 }
218
219 /* nstacktrigger returns a stack descriptor which allow the caller to return
220 * to the current state by using nstackcleanup() later.
221 */
nstacktrigger(const tsd_t * TSD)222 static unsigned nstacktrigger(const tsd_t *TSD)
223 {
224 itp_tsd_t *it;
225 nstackbox *ns;
226
227 it = (itp_tsd_t *)TSD->itp_tsd;
228 ns = it->nbox_top;
229 return(ns->sum + ns->used);
230 }
231
232 /* nstackcleanup cleans up the stack until either the trigger from a
233 * nstacktrigger() is reached or the node encounters, whatever comes first.
234 * In the first case the state is as during the call to nstacktrigger().
235 * In the second case the matching node is NOT popped. To allow a search for
236 * NULL the matching pointer is indexed. Giving NULL means don't use the
237 * matching algorithm. Give
238 * "cnodeptr m=NULL; nstackcleanup(TSD,?,&m);" to match a NULL pointer.
239 * node may be NULL.
240 */
nstackcleanup(const tsd_t * TSD,unsigned trigger,const nodeptr * match)241 static void nstackcleanup(const tsd_t *TSD,
242 unsigned trigger,
243 const nodeptr *match)
244 {
245 itp_tsd_t *it;
246 nstackbox *ns;
247 cnodeptr m = NULL; /* Keep the compiler happy */
248
249 it = (itp_tsd_t *)TSD->itp_tsd;
250 ns = it->nbox_top;
251 if (match)
252 m = *match;
253 while (trigger < ns->sum) /* The complete block may be killed! */
254 {
255 if (match)
256 {
257 while (ns->used)
258 {
259 if (ns->elems[--ns->used] == m)
260 {
261 ns->used++;
262 return;
263 }
264 }
265 }
266 else
267 {
268 ns->used = 0 ;
269 }
270 /* For a delayed deletion preserve this box and delete the next one */
271 if (ns->next)
272 {
273 FreeTSD(ns->next);
274 ns->next = NULL;
275 }
276 assert(ns->prev);
277 if (!ns->prev)
278 {
279 ns->used = 0;
280 return;
281 }
282 it->nbox_top = ns = ns->prev;
283 }
284
285 /* The trigger is within the current box. Do an alignment to force
286 * trigger to be used in conjunction with ns->used.
287 */
288 trigger -= ns->sum;
289 if (trigger >= ns->used) /* Be safety. Imagine a wild trigger! */
290 return;
291
292 if (!match) /* Things may be simple */
293 {
294 ns->used = trigger;
295 return;
296 }
297
298 while (trigger != ns->used)
299 if (ns->elems[--ns->used] == m)
300 {
301 ns->used++;
302 return;
303 }
304 ns->used = trigger;
305 }
306
307 /* stackpush pushes the contents of the arg sbox on the stack. (copy, then
308 * increment)
309 */
stackpush(const tsd_t * TSD,const stackelem * sbox)310 static void stackpush(const tsd_t *TSD,const stackelem *sbox)
311 {
312 itp_tsd_t *it;
313 stackbox *sb;
314
315 it = (itp_tsd_t *)TSD->itp_tsd;
316 sb = it->stk_top;
317 sb->elems[sb->used] = *sbox;
318 if (sb->used)
319 sb->elems[sb->used].prev = sb->elems + sb->used - 1;
320 else if (sb->prev)
321 sb->elems[0].prev = sb->prev->elems + STACKELEMS - 1;
322 else
323 sb->elems[0].prev = NULL;
324 sb->used++;
325
326 if (sb->used >= STACKELEMS)
327 {
328 if (sb->next == NULL)
329 {
330 sb->next = (stackbox *)MallocTSD(sizeof(stackbox));
331 sb->next->prev = sb;
332 sb->next->next = NULL;
333 sb->next->sum = sb->sum + STACKELEMS; /* const to each block */
334 }
335 assert( sb->next->used == 0 ) ; /* be sure to have an empty block */
336 it->stk_top = sb->next;
337 }
338 }
339
340 /* stackpop pops an element from the stack. (decrement, then copy)
341 * The return is the saved value formerly saved by a call to stackpush.
342 * stackpush/stackpop calls may be nested.
343 * The return value is filled with 0 in case of an empty stack.
344 * We use a delayed cleanup (one free stackbox is available while popping).
345 */
stackpop(const tsd_t * TSD)346 static stackelem stackpop(const tsd_t *TSD)
347 {
348 itp_tsd_t *it;
349 stackbox *sb;
350 stackelem zero;
351
352 it = (itp_tsd_t *)TSD->itp_tsd;
353 sb = it->stk_top;
354 if (sb->used == 0)
355 {
356 /* For a delayed deletion preserve this box and delete the next one */
357 if (sb->next)
358 {
359 FreeTSD(sb->next);
360 sb->next = NULL;
361 }
362 assert(sb->prev);
363 if (!sb->prev)
364 {
365 memset(&zero,0,sizeof(zero));
366 return(zero);
367 }
368 it->stk_top = sb = sb->prev;
369 }
370 sb->used--;
371 return(sb->elems[sb->used]);
372 }
373
374 /* stacktrigger returns a stack descriptor which allow the caller to return
375 * to the current state by using stackcleanup() later. See also stacktop().
376 */
stacktrigger(const tsd_t * TSD)377 static unsigned stacktrigger(const tsd_t *TSD)
378 {
379 itp_tsd_t *it;
380 stackbox *sb;
381
382 it = (itp_tsd_t *)TSD->itp_tsd;
383 sb = it->stk_top;
384 return(sb->sum + sb->used);
385 }
386
387 /* stacktop returns a pointer to the top element of the stack. This may be
388 * useful to manipulate stack elements or have a look back. Be careful with
389 * the stack and don't use elements which were not pushed by the current
390 * incarnation of interpret(). See also stacktrigger().
391 * NULL is returned if the stack is empty.
392 */
stacktop(const tsd_t * TSD)393 static stackelem * stacktop(const tsd_t *TSD)
394 {
395 itp_tsd_t *it;
396 stackbox *sb;
397
398 it = (itp_tsd_t *)TSD->itp_tsd;
399 sb = it->stk_top;
400 if (sb->used)
401 return(sb->elems + sb->used - 1);
402 if (sb->prev)
403 return(sb->prev->elems + STACKELEMS - 1);
404 return(NULL);
405 }
406
407 /* stack_destroyelement kill the increment and stopval values of a stack
408 * elements if they exist. The values are reset to zero after the deletion.
409 */
stack_destroyelement(const tsd_t * TSD,stackelem * se)410 static void stack_destroyelement(const tsd_t *TSD,stackelem *se)
411 {
412 if (se->stopval)
413 {
414 free_a_descr(TSD,se->stopval);
415 se->stopval = NULL;
416 }
417 #ifdef OPT_DO
418 if (se->do_for_val)
419 {
420 free_a_descr(TSD,se->do_for_val);
421 se->do_for_val = NULL;
422 }
423 #endif
424 if (se->increment)
425 {
426 free_a_descr(TSD,se->increment);
427 se->increment = NULL;
428 }
429 }
430
431
432 /* stackcleanup cleans up the stack until the trigger from a
433 * stacktrigger() is reached. After the call the stack is in the same state as
434 * during the call to stacktrigger.
435 * Warning: The elements increment and stopval will be deleted for each
436 * deleted stack elements if they exist. Do a stacktop() and use the
437 * prev value of each entry for the appropriate count do set the
438 * values to NULL if you don't want this.
439 */
stackcleanup(const tsd_t * TSD,unsigned trigger)440 static void stackcleanup(const tsd_t *TSD,unsigned trigger)
441 {
442 itp_tsd_t *it;
443 stackbox *sb;
444 unsigned tokill = stacktrigger(TSD);
445
446 if (tokill <= trigger)
447 return;
448
449 tokill -= trigger;
450 it = (itp_tsd_t *)TSD->itp_tsd;
451 sb = it->stk_top;
452 while (tokill--)
453 {
454 if (sb->used == 0)
455 {
456 /* For a delayed deletion preserve this box and delete the next one */
457 if (sb->next)
458 {
459 FreeTSD(sb->next);
460 sb->next = NULL;
461 }
462 assert(sb->prev);
463 if (!sb->prev)
464 return;
465 it->stk_top = sb = sb->prev;
466 }
467 sb->used--;
468 stack_destroyelement(TSD,sb->elems + sb->used);
469 }
470 }
471
SaveInterpreterStatus(const tsd_t * TSD,unsigned * state)472 void SaveInterpreterStatus(const tsd_t *TSD,unsigned *state)
473 {
474 assert(IPRT_BUFSIZE >= 2);
475 state[0] = nstacktrigger(TSD);
476 state[1] = stacktrigger(TSD);
477 }
478
RestoreInterpreterStatus(const tsd_t * TSD,const unsigned * state)479 void RestoreInterpreterStatus(const tsd_t *TSD,const unsigned *state)
480 {
481 nstackcleanup(TSD,state[0],NULL);
482 stackcleanup(TSD,state[1]);
483 }
484
CallInternalFunction(tsd_t * TSD,nodeptr node,nodeptr thisptr,paramboxptr args)485 streng *CallInternalFunction( tsd_t *TSD, nodeptr node, nodeptr thisptr,
486 paramboxptr args )
487 {
488 int stackmark;
489 streng *result;
490 proclevel oldlevel;
491 nodeptr savecurrentnode;
492
493 oldlevel = TSD->currlevel;
494 TSD->currlevel = newlevel( TSD, TSD->currlevel );
495 TSD->currlevel->args = args;
496 stackmark = pushcallstack( TSD, thisptr );
497
498 savecurrentnode = TSD->currentnode;
499 result = interpret( TSD, node );
500 TSD->currentnode = savecurrentnode;
501
502 popcallstack( TSD, stackmark );
503 removelevel( TSD, TSD->currlevel );
504 TSD->currlevel = oldlevel;
505 TSD->currlevel->next = NULL;
506 TSD->trace_stat = TSD->currlevel->tracestat;
507
508 return result;
509 }
510
interpret(tsd_t * volatile TSD,treenode * volatile thisptr)511 streng *interpret(tsd_t * volatile TSD, treenode * volatile thisptr)
512 {
513 int i ;
514 int stackmark ;
515 proclevel oldlevel ;
516 treenode *entry=NULL ;
517 int no_next_interactive=0 ;
518 stackelem s;
519 volatile unsigned stktrigger ;
520 volatile unsigned nstktrigger ;
521 nodeptr innerloop=NULL ;
522 num_descr *doiterdescr=NULL ;
523 volatile nodeptr secure_this ;
524 tsd_t * volatile secure_TSD ;
525 itp_tsd_t * volatile it;
526
527 it = (itp_tsd_t *)TSD->itp_tsd;
528
529 nstktrigger = nstacktrigger(TSD);
530 stktrigger = stacktrigger(TSD);
531
532 secure_TSD = TSD; /* vars used until here */
533 secure_this = thisptr;
534
535 if ( TSD->currlevel->signal_continue == NULL )
536 {
537 TSD->currlevel->signal_continue = (jmp_buf *)MallocTSD( sizeof( jmp_buf ) );
538
539 assert( !TSD->in_protected );
540 if ( setjmp( *TSD->currlevel->signal_continue ) )
541 {
542 /* A signal arrived and a longjmp from anywhere jumps here.
543 * We can't believe in anything and have to rebuild it from
544 * scratch or volatile pointers. Even an unoptimized compiler
545 * may have optimized the access to values of any kind.
546 * We have to do the full reinitialization.
547 * prevents bugs like 592393
548 */
549 thisptr = secure_this ;
550 TSD = secure_TSD ;
551 it = (itp_tsd_t *)TSD->itp_tsd ;
552
553 doiterdescr = NULL ;
554 innerloop = NULL ;
555 memset(&s,0,sizeof(s));
556
557 nstackcleanup(TSD,nstktrigger,NULL);
558 stackcleanup(TSD,stktrigger);
559 no_next_interactive = 0 ;
560
561 goto fakerecurse ;
562 }
563 }
564 memset(&s,0,sizeof(s));
565 no_next_interactive = 0 ;
566 doiterdescr = NULL ;
567 innerloop = NULL ;
568
569 reinterpret:
570 #ifdef WIN32
571 /*
572 * Braindamaged Win32 systems raise ^C in a different thread. We catch the
573 * global flag set the thread's own halt-flag.
574 */
575 if ( __regina_Win32CtrlCRaised )
576 {
577 TSD->HaltRaised = __regina_Win32CtrlCRaised;
578 __regina_Win32CtrlCRaised = 0;
579 }
580 #endif
581 if ( TSD->HaltRaised )
582 halt_raised( TSD );
583
584 if (thisptr==NULL)
585 goto fakereturn ;
586
587 secure_this = thisptr;
588
589 TSD->currentnode = thisptr ;
590 if ( TSD->trace_stat != 'O' && TSD->trace_stat != 'N' && TSD->trace_stat != 'F' )
591 {
592 if (thisptr->type != X_DO) /* let do-stats trace themselves */
593 traceline( TSD, thisptr, TSD->trace_stat, 0 );
594 }
595
596 if (thisptr->now)
597 {
598 FreeTSD(thisptr->now);
599 thisptr->now = NULL;
600 }
601
602 thisptr->o.called = 0;
603
604 switch ( /*(unsigned char)*/ (thisptr->type) )
605 {
606 case X_PROGRAM:
607 case X_STATS:
608
609 case X_WHENS:
610 case X_OTHERWISE:
611 thisptr = thisptr->p[0] ;
612 goto reinterpret ;
613
614
615 case 0:
616 case 255:
617 case X_DO:
618 {
619 streng *tmpstr,*tmpkill=NULL;
620
621 if (innerloop==thisptr)
622 {
623 assert( thisptr->p[3] ) ;
624 if ( TSD->trace_stat != 'O' && TSD->trace_stat != 'N' && TSD->trace_stat != 'F' )
625 {
626 traceline( TSD, thisptr->p[3], TSD->trace_stat, -1 );
627 traceline( TSD, thisptr, TSD->trace_stat, -1 );
628 }
629 goto one ;
630 }
631 else
632 {
633 if ( TSD->trace_stat != 'O' && TSD->trace_stat != 'N' && TSD->trace_stat != 'F' )
634 traceline( TSD, thisptr, TSD->trace_stat, 0 );
635 }
636
637 if (!((thisptr->p[0])||(thisptr->p[1])))
638 {
639 nstackpush(TSD,thisptr->next);
640 thisptr = thisptr->p[2] ;
641 goto fakerecurse ;
642 }
643
644 nstackpush(TSD,thisptr->next); /* for use with leave */
645
646 if (innerloop)
647 {
648 s.thisptr = innerloop;
649 stackpush(TSD,&s);
650 }
651
652 s.incr_node = NULL;
653 #ifdef OPT_DO
654 s.increment = s.do_for_val = s.stopval = doiterdescr = NULL ;
655 s.do_for_val_num = -1 ;
656 s.strmath = 0; /* do numeric calculations by default */
657 #else
658 s.increment = s.stopval = doiterdescr = NULL ;
659 s.number = -1;
660 #endif
661 s.incrdir = 1 ;
662 tmpstr = NULL ;
663 /*
664 * If we have a named variable as the iterator, get itl its in tmpstr
665 */
666 if ((thisptr->p[0])&&(thisptr->p[0]->name))
667 tmpstr = evaluate( TSD, thisptr->p[0]->p[0], &tmpkill );
668 /*
669 * For each of the 4 types of options for the DO command that involve evaluation of a number
670 * at the start of the loop, evaluate the starting value of that expression
671 */
672 for (i=1;i<4;i++)
673 {
674 if ((thisptr->p[0])&&(thisptr->p[0]->p[i]))
675 {
676 nodeptr tmpptr ;
677 switch( thisptr->p[0]->p[i]->type )
678 {
679 case X_DO_TO:
680 {
681 #ifdef OPT_DO
682 int error ;
683 rx_64 iptr;
684 streng *chptr,*chkill;
685 num_descr *tmpnum;
686 #endif
687 /* DO ... TO x: s.stopval is the value of x; x evaluates to any decimal number */
688 tmpptr = thisptr->p[0]->p[i]->p[0] ;
689 #ifdef OPT_DO
690 chptr = evaluate(TSD, tmpptr, &chkill );
691 if ( !myiswnumber( TSD, chptr, &s.stopval, 1 ) )
692 exiterror( ERR_INVALID_INTEGER, (thisptr->p[0]->p[i]->type==X_DO_EXPR) ? 2 : 3, chptr->value );
693 s.stopval_num = streng_to_rx64(TSD, chptr, &error);
694 if ( error )
695 s.strmath = 1; /* have to use string math for this loop */
696 if ( chkill )
697 Free_stringTSD( chkill );
698 #else
699 s.stopval = calcul( TSD, tmpptr, NULL, SIDE_LEFT, X_DO_TO ) ;
700 #endif
701 break ;
702 }
703 case X_DO_BY:
704 /* DO ... BY x: s.increment is the value of x; x evaluates to any decimal number, s.incrdir is the "direction", +ve or -ve */
705 s.incr_node = thisptr->p[0]->p[i]->p[0] ;
706 tmpptr = thisptr->p[0]->p[i]->p[0] ;
707 s.increment = calcul( TSD, tmpptr, NULL, SIDE_LEFT, X_DO_BY ) ;
708 s.incrdir = descr_sign( s.increment ) ;
709 /*
710 fprintf(stderr,"%s %d: direction: %d increment %s neg %d exp %d\n",__FILE__,__LINE__, s.incrdir,
711 s.increment->num,
712 s.increment->negative ,
713 s.increment->exp
714 );
715 */
716 break ;
717
718 case X_DO_FOR:
719 case X_DO_EXPR:
720 {
721 /* DO x or DO .. FOR x: s.do_for_val_num is the value of x; x evaluates to any WHOLE number */
722 #ifdef OPT_DO
723 int error ;
724 rx_64 iptr;
725 #else
726 int iptr, error ;
727 #endif
728 streng *chptr,*chkill;
729 #ifdef OPT_DO
730 num_descr *tmpnum;
731 #endif
732
733 tmpptr = thisptr->p[0]->p[i]->p[0] ;
734 chptr = evaluate(TSD, tmpptr, &chkill );
735 #ifdef OPT_DO
736 if ( !myiswnumber( TSD, chptr, &tmpnum, 1 )
737 || tmpnum->negative )
738 exiterror( ERR_INVALID_INTEGER, (thisptr->p[0]->p[i]->type==X_DO_EXPR) ? 2 : 3, chptr->value );
739
740 s.do_for_val = calcul(TSD,tmpptr,NULL) ;
741 iptr = streng_to_rx64(TSD, chptr, &error);
742 #else
743 iptr = streng_to_int(TSD, chptr, &error);
744 #endif
745 if ( error )
746 #ifdef OPT_DO
747 s.strmath = 1; /* have to use string math for this loop */
748 s.do_for_val_num = iptr ;
749 #else
750 exiterror( ERR_INVALID_INTEGER, (thisptr->p[0]->p[i]->type==X_DO_EXPR) ? 2 : 3, chptr->value );
751 if ( iptr < 0 )
752 exiterror( ERR_INVALID_RESULT, 0 );
753 s.number = iptr;
754 #endif
755 if ( chkill )
756 Free_stringTSD( chkill );
757 break ;
758 }
759 }
760 }
761 }
762 if ( tmpstr )
763 {
764 /*
765 * Normalise the iterator for the DO loop; must be a number.
766 */
767 setshortcut( TSD, thisptr->p[0], str_normalize( TSD, tmpstr ) );
768 doiterdescr = shortcutnum( TSD, thisptr->p[0] );
769 if ( tmpkill )
770 Free_stringTSD( tmpkill );
771 /*
772 fprintf(stderr,"%s %d: After normalise: iter %s neg %d exp %d\n",__FILE__,__LINE__,
773 doiterdescr->num,
774 doiterdescr->negative ,
775 doiterdescr->exp
776 );
777 */
778 }
779 #ifdef OPT_DO
780 fprintf(stderr,"%s %d: Using %s arithmetic for DO\n",__FILE__,__LINE__,(s.strmath) ? "string" : "numeric" );
781 #endif
782 if (TSD->systeminfo->interactive)
783 {
784 if (intertrace(TSD))
785 {
786 nstackpop(TSD);
787 if (s.increment)
788 {
789 free_a_descr( TSD, s.increment ) ;
790 s.increment = NULL ;
791 }
792 if (s.stopval)
793 {
794 free_a_descr( TSD, s.stopval ) ;
795 s.stopval = NULL ;
796 }
797 #ifdef OPT_DO
798 if (s.do_for_val)
799 {
800 free_a_descr( TSD, s.do_for_val ) ;
801 s.do_for_val = NULL ;
802 }
803 #endif
804 goto fakerecurse ;
805 }
806 }
807 startloop:
808 if (thisptr->p[0])
809 {
810 /*
811 * If we have a TO value to terminate the loop, check if the value of the iterator (doiterdescr)
812 * ???
813 */
814 if (s.stopval)
815 {
816 int tsign ;
817
818 tsign = string_test( TSD, doiterdescr, s.stopval ) ;
819 /*
820 fprintf(stderr,"%s %d: tsign %d\n",__FILE__,__LINE__,tsign);
821 */
822 if (!(tsign ^ s.incrdir))
823 goto endloop ;
824 /*
825 fprintf(stderr,"%s %d\n",__FILE__,__LINE__);
826 */
827 }
828
829 /*
830 * If we have a FOR value to terminate the loop, check if it has decremented to less than
831 * or equal to zero
832 */
833 #ifdef OPT_DO
834 if ((s.do_for_val_num>=0) && (s.do_for_val_num--<=0))
835 #else
836 if ((s.number>=0) && (s.number--<=0))
837 #endif
838 goto endloop ;
839
840 }
841 /*
842 * If there is WHILE clause, check if the expression is false before execution of the DO block
843 */
844 if ((thisptr->p[1])&&((thisptr->p[1]->type)==X_WHILE))
845 {
846 if (!isboolean(TSD,thisptr->p[1]->p[0],3, NULL))
847 goto endloop ;
848 }
849 /*
850 * Execute the code in the DO block
851 */
852 if (thisptr->p[2])
853 {
854 nstackpush(TSD,thisptr);
855 pushcallstack(TSD,NULL) ;
856
857 innerloop = thisptr ;
858 thisptr = thisptr->p[2] ;
859 goto fakerecurse ;
860
861 one:
862 popcallstack(TSD,-1) ;
863 }
864 /*
865 * If there is an UNTIL clause, check if the expression is false after execution of the DO block
866 */
867 if ((thisptr->p[1])&&((thisptr->p[1]->type)==X_UNTIL))
868 {
869 if (isboolean(TSD,thisptr->p[1]->p[0],4, NULL))
870 goto endloop ;
871 }
872
873 if ((thisptr->p[0])&&(thisptr->p[0]->name))
874 {
875 doiterdescr = shortcutnum( TSD, thisptr->p[0] ) ;
876 /*
877 * Check if we still have a valid number. If not
878 * exit with arithmetic error.
879 */
880 if (!doiterdescr)
881 exiterror( ERR_BAD_ARITHMETIC, 0 ) ;
882
883 /*
884 * Increment our loop iterator
885 */
886 if (s.increment)
887 {
888 string_add( TSD, doiterdescr, s.increment, doiterdescr, thisptr->p[0], s.incr_node ) ;
889 /*
890 fprintf(stderr,"%s %d: After add: iter %s neg %d exp %d\n",__FILE__,__LINE__,
891 doiterdescr->num,
892 doiterdescr->negative ,
893 doiterdescr->exp
894 );
895 */
896 /* fixes bug 1109729: */
897 str_round( doiterdescr, TSD->currlevel->currnumsize ) ;
898 /*
899 fprintf(stderr,"%s %d: After round: iter %s neg %d exp %d\n",__FILE__,__LINE__,
900 doiterdescr->num,
901 doiterdescr->negative ,
902 doiterdescr->exp
903 );
904 */
905 }
906 else
907 string_incr( TSD, doiterdescr, thisptr->p[0] ) ;
908
909 if (thisptr->p[0]->u.varbx)
910 {
911 thisptr->p[0]->u.varbx->num = doiterdescr ;
912 thisptr->p[0]->u.varbx->flag = VFLAG_NUM ;
913 if ( TSD->trace_stat == 'I' )
914 tracenumber( TSD, doiterdescr, 'V');
915 }
916 else
917 setshortcut( TSD, thisptr->p[0], str_norm( TSD, doiterdescr, NULL )) ;
918 }
919
920 if (TSD->nextsig)
921 goto fakerecurse ;
922
923 /*
924 * Check for ^C before iterating. Fixes bug 882878.
925 */
926 #ifdef WIN32
927 if ( __regina_Win32CtrlCRaised )
928 {
929 TSD->HaltRaised = __regina_Win32CtrlCRaised;
930 __regina_Win32CtrlCRaised = 0;
931 }
932 #endif
933 if ( TSD->HaltRaised )
934 goto fakerecurse ;
935
936 goto startloop ;
937
938 endloop: if (s.increment)
939 {
940 free_a_descr( TSD, s.increment ) ;
941 s.increment = NULL ;
942 }
943 if (s.stopval)
944 {
945 free_a_descr( TSD, s.stopval ) ;
946 s.stopval = NULL ;
947 }
948 #ifdef OPT_DO
949 if (s.do_for_val)
950 {
951 free_a_descr( TSD, s.do_for_val ) ;
952 s.do_for_val = NULL ;
953 }
954 #endif
955 no_next_interactive = 1 ;
956 nstackpop(TSD);
957
958 if (stacktrigger(TSD) > stktrigger)
959 {
960 s = stackpop(TSD);
961 innerloop = s.thisptr;
962 }
963 else
964 innerloop = NULL ;
965
966 break ;
967 }
968 case X_IF:
969 {
970 treenode *othis = thisptr, *n;
971 int retval = isboolean( TSD, thisptr->p[0], 1, NULL );
972
973 if ( TSD->trace_stat != 'O' && TSD->trace_stat != 'N' && TSD->trace_stat != 'F' )
974 {
975 n = thisptr->p[0]->next;
976 while ( n != NULL ) {
977 traceline( TSD, n, TSD->trace_stat, 0 );
978 n = n->next;
979 }
980 }
981
982 nstackpush(TSD,thisptr->next);
983 thisptr = thisptr->p[retval ? 1 : 2];
984 if (TSD->systeminfo->interactive)
985 {
986 if (intertrace(TSD))
987 {
988 thisptr = othis ;
989 }
990 }
991
992 goto fakerecurse ;
993 }
994 case X_NASSIGN:
995 {
996 num_descr *ntmp;
997 streng *preferred_str;
998 int type;
999
1000 ntmp = calcul( TSD, thisptr->p[1], NULL, SIDE_LEFT, X_NASSIGN );
1001 assert( ntmp->size );
1002
1003 type = thisptr->p[1]->type;
1004 if ( ( type == X_STRING ) || ( type == X_CON_SYMBOL ) )
1005 preferred_str = Str_dupTSD( thisptr->p[1]->name );
1006 else
1007 preferred_str = NULL;
1008
1009 if (thisptr->p[0]->type==X_HEAD_SYMBOL)
1010 {
1011 fix_compoundnum( TSD, thisptr->p[0], ntmp, preferred_str );
1012 }
1013 else
1014 {
1015 setshortcutnum( TSD, thisptr->p[0], ntmp, preferred_str );
1016 }
1017 /* trace the result of assignment */
1018 if ( TSD->trace_stat == 'R' )
1019 {
1020 streng *ptr = str_norm( TSD, ntmp, NULL );
1021 tracevalue( TSD, ptr, '=' );
1022 FreeTSD( ptr );
1023 }
1024 break ;
1025 }
1026
1027 case X_ASSIGN:
1028 {
1029 /* This is a CMS-ism; CMS allows the expression in an assignment to
1030 * be omitted, while TRL does _not_. If a CMS mode is implemented, the
1031 * code below should be changed to allow p[0] to be null only iff
1032 * CMS mode is active.
1033 */
1034 streng *value ;
1035
1036 value = thisptr->p[1] ? evaluate(TSD,thisptr->p[1],NULL) : nullstringptr() ;
1037 if (thisptr->p[0]->type==X_HEAD_SYMBOL)
1038 fix_compound( TSD, thisptr->p[0], value ) ;
1039 else
1040 setshortcut( TSD, thisptr->p[0], value ) ;
1041 /* trace the result of assignment */
1042 if ( TSD->trace_stat == 'R' )
1043 {
1044 tracevalue( TSD, value, '=' );
1045 }
1046 break ;
1047 }
1048
1049 case X_PLUSASSIGN:
1050 {
1051 num_descr *ntmp;
1052
1053 if ( get_options_flag( TSD->currlevel, EXT_STRICT_ANSI ) )
1054 exiterror( ERR_NON_ANSI_FEATURE, 4, "+=" ) ;
1055
1056 ntmp = calcul( TSD, thisptr, NULL, SIDE_LEFT, X_PLUSASSIGN );
1057 assert( ntmp->size );
1058
1059 if (thisptr->p[0]->type==X_HEAD_SYMBOL)
1060 {
1061 fix_compoundnum( TSD, thisptr->p[0], ntmp, NULL );
1062 }
1063 else
1064 {
1065 setshortcutnum( TSD, thisptr->p[0], ntmp, NULL );
1066 }
1067 /* trace the result of assignment */
1068 if ( TSD->trace_stat == 'R' )
1069 {
1070 streng *ptr = str_norm( TSD, ntmp, NULL );
1071 tracevalue( TSD, ptr, '=' );
1072 FreeTSD( ptr );
1073 }
1074 break ;
1075 }
1076
1077 case X_MINUSASSIGN:
1078 {
1079 num_descr *ntmp;
1080
1081 if ( get_options_flag( TSD->currlevel, EXT_STRICT_ANSI ) )
1082 exiterror( ERR_NON_ANSI_FEATURE, 4, "-=" ) ;
1083
1084 ntmp = calcul( TSD, thisptr, NULL, SIDE_LEFT, X_MINUSASSIGN );
1085 assert( ntmp->size );
1086
1087 if (thisptr->p[0]->type==X_HEAD_SYMBOL)
1088 {
1089 fix_compoundnum( TSD, thisptr->p[0], ntmp, NULL );
1090 }
1091 else
1092 {
1093 setshortcutnum( TSD, thisptr->p[0], ntmp, NULL );
1094 }
1095 /* trace the result of assignment */
1096 if ( TSD->trace_stat == 'R' )
1097 {
1098 streng *ptr = str_norm( TSD, ntmp, NULL );
1099 tracevalue( TSD, ptr, '=' );
1100 FreeTSD( ptr );
1101 }
1102 break ;
1103 }
1104
1105 case X_MULTASSIGN:
1106 {
1107 num_descr *ntmp;
1108
1109 if ( get_options_flag( TSD->currlevel, EXT_STRICT_ANSI ) )
1110 exiterror( ERR_NON_ANSI_FEATURE, 4, "*=" ) ;
1111
1112 ntmp = calcul( TSD, thisptr, NULL, SIDE_LEFT, X_MULTASSIGN );
1113 assert( ntmp->size );
1114
1115 if (thisptr->p[0]->type==X_HEAD_SYMBOL)
1116 {
1117 fix_compoundnum( TSD, thisptr->p[0], ntmp, NULL );
1118 }
1119 else
1120 {
1121 setshortcutnum( TSD, thisptr->p[0], ntmp, NULL );
1122 }
1123 /* trace the result of assignment */
1124 if ( TSD->trace_stat == 'R' )
1125 {
1126 streng *ptr = str_norm( TSD, ntmp, NULL );
1127 tracevalue( TSD, ptr, '=' );
1128 FreeTSD( ptr );
1129 }
1130 break ;
1131 }
1132
1133 case X_DIVASSIGN:
1134 {
1135 num_descr *ntmp;
1136
1137 if ( get_options_flag( TSD->currlevel, EXT_STRICT_ANSI ) )
1138 exiterror( ERR_NON_ANSI_FEATURE, 4, "/=" ) ;
1139
1140 ntmp = calcul( TSD, thisptr, NULL, SIDE_LEFT, X_DIVASSIGN );
1141 assert( ntmp->size );
1142
1143 if (thisptr->p[0]->type==X_HEAD_SYMBOL)
1144 {
1145 fix_compoundnum( TSD, thisptr->p[0], ntmp, NULL );
1146 }
1147 else
1148 {
1149 setshortcutnum( TSD, thisptr->p[0], ntmp, NULL );
1150 }
1151 /* trace the result of assignment */
1152 if ( TSD->trace_stat == 'R' )
1153 {
1154 streng *ptr = str_norm( TSD, ntmp, NULL );
1155 tracevalue( TSD, ptr, '=' );
1156 FreeTSD( ptr );
1157 }
1158 break ;
1159 }
1160
1161 case X_INTDIVASSIGN:
1162 {
1163 num_descr *ntmp;
1164
1165 if ( get_options_flag( TSD->currlevel, EXT_STRICT_ANSI ) )
1166 exiterror( ERR_NON_ANSI_FEATURE, 4, "%=" ) ;
1167
1168 ntmp = calcul( TSD, thisptr, NULL, SIDE_LEFT, X_INTDIVASSIGN );
1169 assert( ntmp->size );
1170
1171 if (thisptr->p[0]->type==X_HEAD_SYMBOL)
1172 {
1173 fix_compoundnum( TSD, thisptr->p[0], ntmp, NULL );
1174 }
1175 else
1176 {
1177 setshortcutnum( TSD, thisptr->p[0], ntmp, NULL );
1178 }
1179 /* trace the result of assignment */
1180 if ( TSD->trace_stat == 'R' )
1181 {
1182 streng *ptr = str_norm( TSD, ntmp, NULL );
1183 tracevalue( TSD, ptr, '=' );
1184 FreeTSD( ptr );
1185 }
1186 break ;
1187 }
1188
1189 case X_MODULUSASSIGN:
1190 {
1191 num_descr *ntmp;
1192
1193 if ( get_options_flag( TSD->currlevel, EXT_STRICT_ANSI ) )
1194 exiterror( ERR_NON_ANSI_FEATURE, 4, "//=" ) ;
1195
1196 ntmp = calcul( TSD, thisptr, NULL, SIDE_LEFT, X_MODULUSASSIGN );
1197 assert( ntmp->size );
1198
1199 if (thisptr->p[0]->type==X_HEAD_SYMBOL)
1200 {
1201 fix_compoundnum( TSD, thisptr->p[0], ntmp, NULL );
1202 }
1203 else
1204 {
1205 setshortcutnum( TSD, thisptr->p[0], ntmp, NULL );
1206 }
1207 /* trace the result of assignment */
1208 if ( TSD->trace_stat == 'R' )
1209 {
1210 streng *ptr = str_norm( TSD, ntmp, NULL );
1211 tracevalue( TSD, ptr, '=' );
1212 FreeTSD( ptr );
1213 }
1214 break ;
1215 }
1216
1217 case X_ORASSIGN:
1218 {
1219 num_descr *ntmp;
1220
1221 if ( get_options_flag( TSD->currlevel, EXT_STRICT_ANSI ) )
1222 exiterror( ERR_NON_ANSI_FEATURE, 4, "|=" ) ;
1223
1224 ntmp = calcul( TSD, thisptr, NULL, SIDE_LEFT, X_ORASSIGN );
1225 assert( ntmp->size );
1226
1227 if (thisptr->p[0]->type==X_HEAD_SYMBOL)
1228 {
1229 fix_compoundnum( TSD, thisptr->p[0], ntmp, NULL );
1230 }
1231 else
1232 {
1233 setshortcutnum( TSD, thisptr->p[0], ntmp, NULL );
1234 }
1235 /* trace the result of assignment */
1236 if ( TSD->trace_stat == 'R' )
1237 {
1238 streng *ptr = str_norm( TSD, ntmp, NULL );
1239 tracevalue( TSD, ptr, '=' );
1240 FreeTSD( ptr );
1241 }
1242 break ;
1243 }
1244
1245 case X_XORASSIGN:
1246 {
1247 num_descr *ntmp;
1248
1249 if ( get_options_flag( TSD->currlevel, EXT_STRICT_ANSI ) )
1250 exiterror( ERR_NON_ANSI_FEATURE, 4, "&&=" ) ;
1251
1252 ntmp = calcul( TSD, thisptr, NULL, SIDE_LEFT, X_XORASSIGN );
1253 assert( ntmp->size );
1254
1255 if (thisptr->p[0]->type==X_HEAD_SYMBOL)
1256 {
1257 fix_compoundnum( TSD, thisptr->p[0], ntmp, NULL );
1258 }
1259 else
1260 {
1261 setshortcutnum( TSD, thisptr->p[0], ntmp, NULL );
1262 }
1263 /* trace the result of assignment */
1264 if ( TSD->trace_stat == 'R' )
1265 {
1266 streng *ptr = str_norm( TSD, ntmp, NULL );
1267 tracevalue( TSD, ptr, '=' );
1268 FreeTSD( ptr );
1269 }
1270 break ;
1271 }
1272
1273 case X_ANDASSIGN:
1274 {
1275 num_descr *ntmp;
1276
1277 if ( get_options_flag( TSD->currlevel, EXT_STRICT_ANSI ) )
1278 exiterror( ERR_NON_ANSI_FEATURE, 4, "&=" ) ;
1279
1280 ntmp = calcul( TSD, thisptr, NULL, SIDE_LEFT, X_ANDASSIGN );
1281 assert( ntmp->size );
1282
1283 if (thisptr->p[0]->type==X_HEAD_SYMBOL)
1284 {
1285 fix_compoundnum( TSD, thisptr->p[0], ntmp, NULL );
1286 }
1287 else
1288 {
1289 setshortcutnum( TSD, thisptr->p[0], ntmp, NULL );
1290 }
1291 /* trace the result of assignment */
1292 if ( TSD->trace_stat == 'R' )
1293 {
1294 streng *ptr = str_norm( TSD, ntmp, NULL );
1295 tracevalue( TSD, ptr, '=' );
1296 FreeTSD( ptr );
1297 }
1298 break ;
1299 }
1300
1301 case X_CONCATASSIGN:
1302 {
1303 streng *value ;
1304
1305 value = evaluate( TSD, thisptr, NULL ) ;
1306 if (thisptr->p[0]->type==X_HEAD_SYMBOL)
1307 fix_compound( TSD, thisptr->p[0], value ) ;
1308 else
1309 setshortcut( TSD, thisptr->p[0], value ) ;
1310 /* trace the result of assignment */
1311 if ( TSD->trace_stat == 'R' )
1312 {
1313 tracevalue( TSD, value, '=' );
1314 }
1315 break ;
1316 }
1317
1318 case X_IPRET:
1319 {
1320 streng *retval, *tptr = evaluate(TSD,thisptr->p[0],NULL) ;
1321 retval = dointerpret( TSD, tptr ) ;
1322 if (retval != NULL) /* we interpreted a RETURN WITH a value */
1323 {
1324 stackelem *top = stacktop(TSD);
1325 unsigned i;
1326 for (i = stacktrigger(TSD);i > stktrigger;i--,top = top->prev)
1327 {
1328 if (top->increment == s.increment)
1329 s.increment = NULL;
1330 if (top->stopval == s.stopval)
1331 s.stopval = NULL;
1332 #ifdef OPT_DO
1333 if (top->do_for_val == s.do_for_val)
1334 s.do_for_val = NULL;
1335 #endif
1336 }
1337
1338 stackcleanup(TSD,stktrigger);
1339 nstackcleanup(TSD,nstktrigger,NULL);
1340 return( retval ) ;
1341 }
1342 break ;
1343 }
1344
1345 case X_NO_OTHERWISE:
1346 exiterror( ERR_WHEN_EXPECTED, 0 ) ;
1347 break ;
1348
1349 case X_SELECT:
1350 nstackpush(TSD,thisptr->next);
1351 nstackpush(TSD,thisptr->p[1]);
1352 thisptr = thisptr->p[0] ;
1353 goto fakerecurse ;
1354
1355 case X_WHEN:
1356 {
1357 int retval = isboolean( TSD, thisptr->p[0], 2, NULL );
1358 nodeptr n;
1359 if ( TSD->trace_stat != 'O' && TSD->trace_stat != 'N' && TSD->trace_stat != 'F' )
1360 {
1361 n = thisptr->p[0]->next;
1362 while ( n != NULL ) {
1363 traceline( TSD, n, TSD->trace_stat, 0 );
1364 n = n->next;
1365 }
1366 }
1367 if ( retval )
1368 {
1369 nstackpop(TSD); /* kill the OTHERWISE on the stack */
1370 thisptr = thisptr->p[1] ;
1371 goto fakerecurse ;
1372 }
1373 break ;
1374 }
1375
1376 case X_SAY:
1377 {
1378 int ok=HOOK_GO_ON ;
1379 streng *stringen,*kill=NULL;
1380
1381 if (thisptr->p[0])
1382 stringen = evaluate( TSD, thisptr->p[0], &kill );
1383 else
1384 stringen = NULL ;
1385
1386 if (TSD->systeminfo->hooks & HOOK_MASK(HOOK_STDOUT))
1387 ok = hookup_output( TSD, HOOK_STDOUT, stringen ) ;
1388
1389 if (ok==HOOK_GO_ON)
1390 {
1391 if (stringen)
1392 {
1393 #ifdef WIN32
1394 /*
1395 * Due to a bug in Windows that gives an error
1396 * if you try to write too many characters to the
1397 * console in one attempt, split the output
1398 * up into chunks.
1399 * Bug: 1455211
1400 */
1401 char *buf = stringen->value;
1402 long done,chunk;
1403 long todo = Str_len(stringen);
1404 do
1405 {
1406 chunk = min( todo, 0x8000);
1407 done = fwrite( buf, chunk, 1, stdout ) ;
1408 buf += chunk ;
1409 todo -= chunk ;
1410 } while ( todo > 0 ) ;
1411 #else
1412 fwrite( stringen->value, Str_len(stringen), 1, stdout ) ;
1413 #endif
1414 }
1415 #if defined(DOS) || defined(OS2) || defined(WIN32)
1416 /*
1417 * stdout is open in binary mode, so we need to add the
1418 * extra CR to the end of the line.
1419 */
1420 fputc( REGINA_CR, stdout ) ;
1421 #endif
1422 fputc( REGINA_EOL, stdout ) ;
1423 fflush( stdout ) ;
1424 }
1425
1426 if (stringen && kill)
1427 Free_stringTSD( kill );
1428
1429 break ;
1430 }
1431
1432 case X_TRACE:
1433 {
1434 streng *tptr ;
1435
1436 if (!TSD->systeminfo->trace_override)
1437 {
1438 if (thisptr->name)
1439 {
1440 set_trace( TSD, thisptr->name ) ;
1441 }
1442 else if (thisptr->p[0])
1443 {
1444 set_trace( TSD, evaluate(TSD,thisptr->p[0], &tptr ) );
1445 if ( tptr )
1446 Free_stringTSD( tptr ) ;
1447 }
1448 else
1449 {
1450 /* default setting for TRACE with no arguments is "N" */
1451 streng *tmp = Str_ncre_TSD( TSD, "N", 1 );
1452 set_trace( TSD, tmp );
1453 Free_stringTSD( tmp );
1454 }
1455 }
1456
1457 break ;
1458 }
1459
1460 case X_EXIT:
1461 {
1462 streng *result;
1463
1464 if ( thisptr->p[0] )
1465 result = evaluate( TSD, thisptr->p[0], NULL );
1466 else
1467 result = NULL;
1468
1469 TSD->instore_is_errorfree = 1;
1470 jump_script_exit( TSD, result );
1471
1472 break;
1473 }
1474
1475 case X_COMMAND:
1476 {
1477 streng *stmp,*kill;
1478
1479 update_envirs( TSD, TSD->currlevel ) ;
1480 if (thisptr->p[0])
1481 {
1482 /* bja - added Free_stringTSD() around perform() */
1483 stmp = evaluate( TSD, thisptr->p[0], &kill );
1484 Free_stringTSD(perform(TSD, stmp, TSD->currlevel->environment, thisptr, NULL)) ;
1485 if ( kill )
1486 Free_stringTSD( kill );
1487 break ;
1488 }
1489 }
1490
1491 case X_ADDR_N: /* ADDRESS environment [expr] */
1492 {
1493 streng *envir,*tmp,*kill;
1494 update_envirs( TSD, TSD->currlevel ) ;
1495 envir = thisptr->name ;
1496 if (thisptr->p[0])
1497 {
1498 /*
1499 * This path is executed when the command is:
1500 * ADDRESS env [command] WITH [expr]
1501 * ie. executing a command
1502 */
1503 /* bja - added Free_stringTSD() around perform() */
1504 /* the IO-redirection is temporarily in this case. */
1505 tmp = evaluate( TSD, thisptr->p[0], &kill );
1506 Free_stringTSD(perform(TSD, tmp, envir, thisptr, thisptr->p[1]));
1507 if ( kill )
1508 Free_stringTSD( kill ) ;
1509 }
1510 else
1511 {
1512 /*
1513 * This path is executed when the command is:
1514 * ADDRESS env WITH [expr]
1515 * ie. setting the default address, but not executing anything
1516 */
1517 set_envir( TSD, envir, thisptr->p[1] ) ;
1518 Free_stringTSD( TSD->currlevel->prev_env ) ;
1519 TSD->currlevel->prev_env = TSD->currlevel->environment ;
1520 TSD->currlevel->environment = Str_dupTSD(envir) ;
1521 }
1522 break ;
1523 }
1524
1525
1526 case X_ADDR_V: /* ADDRESS [VALUE] expr */
1527 {
1528 streng *cptr ;
1529
1530 if ( thisptr->u.nonansi &&
1531 get_options_flag( TSD->currlevel, EXT_STRICT_ANSI ) )
1532 exiterror( ERR_NON_ANSI_FEATURE, 2, "ADDRESS \"(\"...\")\"") ;
1533
1534 update_envirs( TSD, TSD->currlevel ) ;
1535 cptr = evaluate(TSD,thisptr->p[0],NULL) ;
1536 set_envir( TSD, cptr, thisptr->p[1] ) ;
1537 Free_stringTSD( TSD->currlevel->prev_env ) ;
1538 TSD->currlevel->prev_env = TSD->currlevel->environment ;
1539 TSD->currlevel->environment = cptr ;
1540 break ;
1541 }
1542
1543
1544 case X_ADDR_S: /* ADDRESS */
1545 {
1546 streng *tptr ;
1547
1548 update_envirs( TSD, TSD->currlevel ) ;
1549 tptr = TSD->currlevel->environment ;
1550 TSD->currlevel->environment = TSD->currlevel->prev_env ;
1551 TSD->currlevel->prev_env = tptr ;
1552 break ;
1553 }
1554
1555
1556 case X_DROP:
1557 {
1558 nodeptr nptr ;
1559 for (nptr=thisptr->p[0]; nptr; nptr=nptr->p[0] )
1560 {
1561 if (nptr->name)
1562 {
1563 if (nptr->type == X_SIM_SYMBOL)
1564 {
1565 drop_var( TSD, nptr->name ) ;
1566 }
1567 else
1568 {
1569 if (nptr->type == X_IND_SYMBOL)
1570 {
1571 int begin,end;
1572 streng *name;
1573 const streng *value = shortcut(TSD,nptr) ;
1574
1575 /* Chop space separated words and drop them one by one */
1576 for (end = 0;;)
1577 {
1578 begin = end; /* end of last word processed + 1 */
1579 while ((begin < Str_len(value)) &&
1580 rx_isspace(value->value[begin]))
1581 begin++;
1582 if (begin == Str_len(value))
1583 break;
1584 end = begin + 1; /* find next separator */
1585 while ((end < Str_len(value)) &&
1586 !rx_isspace(value->value[end]))
1587 end++;
1588 /* end now on space after word or past end of string */
1589 name = Str_makeTSD(end - begin);
1590 name->len = end - begin;
1591 memcpy(name->value, value->value + begin, Str_len(name));
1592 Str_upper(name);
1593 drop_var( TSD, name ) ;
1594 Free_stringTSD( name ) ;
1595 }
1596 }
1597 }
1598 }
1599 }
1600 break ;
1601 }
1602
1603 case X_UPPER_VAR:
1604 {
1605 /*
1606 * If we are running in STRICT_ANSI mode, disallow this
1607 * keyword.
1608 * Copy the code above for DROP.
1609 * Need to cause error if stem variable is specified
1610 * Need to handle NOVALUE
1611 */
1612 nodeptr nptr ;
1613
1614 if ( get_options_flag( TSD->currlevel, EXT_STRICT_ANSI ) )
1615 exiterror( ERR_NON_ANSI_FEATURE, 2, "UPPER" ) ;
1616 for (nptr=thisptr->p[0]; nptr; nptr=nptr->p[0] )
1617 {
1618 if (nptr->name)
1619 {
1620 if (nptr->type == X_SIM_SYMBOL)
1621 {
1622 upper_var( TSD, nptr->name ) ;
1623 }
1624 else
1625 {
1626 if (nptr->type == X_IND_SYMBOL)
1627 {
1628 int begin,end;
1629 streng *name;
1630 const streng *value = shortcut(TSD,nptr) ;
1631
1632 /* Chop space separated words and drop them one by one */
1633 for (end = 0;;)
1634 {
1635 begin = end; /* end of last word processed + 1 */
1636 while ((begin < Str_len(value)) &&
1637 rx_isspace(value->value[begin]))
1638 begin++;
1639 if (begin == Str_len(value))
1640 break;
1641 end = begin + 1; /* find next separator */
1642 while ((end < Str_len(value)) &&
1643 !rx_isspace(value->value[end]))
1644 end++;
1645 /* end now on space after word or past end of string */
1646 name = Str_makeTSD(end - begin);
1647 name->len = end - begin;
1648 memcpy(name->value, value->value + begin, Str_len(name));
1649 Str_upper(name);
1650 upper_var( TSD, name ) ;
1651 Free_stringTSD( name ) ;
1652 }
1653 }
1654 }
1655 }
1656 }
1657 break ;
1658 }
1659
1660 case X_SIG_SET:
1661 case X_CALL_SET:
1662 {
1663 int type ;
1664 trap *traps = gettraps( TSD, TSD->currlevel ) ;
1665
1666 /* which kind of condition is this? */
1667 type = identify_trap( thisptr->p[1]->type ) ;
1668
1669 /* We always set this */
1670 traps[type].invoked = (thisptr->type == X_SIG_SET) ;
1671 traps[type].delayed = 0 ;
1672 traps[type].on_off = (thisptr->p[0]->type == X_ON ) ;
1673
1674 /* set the name of the variable to work on */
1675 FREE_IF_DEFINED( TSD, traps[type].name ) ;
1676 if (thisptr->name)
1677 traps[type].name = Str_dupTSD( thisptr->name ) ;
1678 else if (thisptr->p[0]->type == X_ON)
1679 traps[type].name = Str_creTSD( signalnames[type] ) ;
1680
1681 break ;
1682 }
1683
1684 case X_SIG_VAL:
1685 case X_SIG_LAB:
1686 {
1687 streng *cptr, *kill=NULL;
1688 volatile char *tmp_str;
1689 stackelem *top;
1690 unsigned i;
1691
1692 cptr = (thisptr->name) ? thisptr->name : evaluate( TSD, thisptr->p[0], &kill );
1693 nstackcleanup( TSD, nstktrigger, NULL );
1694 top = stacktop( TSD );
1695 for ( i = stacktrigger( TSD ); i > stktrigger; i--, top = top->prev )
1696 {
1697 if ( top->increment == s.increment )
1698 s.increment = NULL;
1699 if ( top->stopval == s.stopval )
1700 s.stopval = NULL;
1701 #ifdef OPT_DO
1702 if ( top->do_for_val == s.do_for_val )
1703 s.do_for_val = NULL;
1704 #endif
1705 }
1706
1707 stackcleanup( TSD, stktrigger );
1708 /*
1709 * Fixes bug 764458
1710 */
1711 innerloop = NULL;
1712
1713 set_reserved_value( TSD, POOL0_SIGL, NULL, thisptr->lineno, VFLAG_NUM );
1714 entry = getlabel( TSD, cptr );
1715 /*
1716 * We have to make a temporary copy of the label we are signalling
1717 * in case it doesn't exist because the "kill" processing will destroy
1718 * the value.
1719 */
1720 tmp_str = tmpstr_of( TSD, cptr );
1721
1722 if ( kill )
1723 Free_stringTSD( kill );
1724
1725 if ( entry == NULL )
1726 exiterror( ERR_UNEXISTENT_LABEL, 1, tmp_str );
1727 if ( entry->u.trace_only )
1728 exiterror( ERR_UNEXISTENT_LABEL, 2, tmpstr_of( TSD, entry->name) );
1729 thisptr = entry->next;
1730 goto fakerecurse;
1731 }
1732 case X_PROC:
1733 {
1734 treenode *ptr;
1735
1736 if (TSD->currlevel->varflag)
1737 exiterror( ERR_UNEXPECTED_PROC, 1 ) ;
1738
1739 for (ptr=thisptr->p[0];(ptr);ptr=ptr->p[0])
1740 {
1741 if (ptr->name)
1742 {
1743 expose_var(TSD,ptr->name) ;
1744 if (ptr->type==X_IND_SYMBOL)
1745 expose_indir( TSD, getvalue( TSD, ptr->name, -1 ) );
1746 else
1747 assert( ptr->type==X_SIM_SYMBOL) ;
1748 }
1749 else
1750 exiterror( ERR_INTERPRETER_FAILURE, 1, __FILE__, __LINE__, "" ) ;
1751 }
1752 expose_var(TSD,NULL) ;
1753 break ;
1754 }
1755 case X_CALL:
1756 {
1757 nodeptr n;
1758
1759 /*
1760 * Find an internal label matching the label on the CALL
1761 * statement, and determine if its in internal of external
1762 * subroutine call.
1763 */
1764 n = getlabel( TSD, thisptr->name );
1765 if ( n )
1766 {
1767 if ( n->u.trace_only )
1768 exiterror( ERR_UNEXISTENT_LABEL, 3, tmpstr_of( TSD, n->name ) );
1769 thisptr->type = X_IS_INTERNAL;
1770 }
1771 else
1772 thisptr->type = X_IS_BUILTIN;
1773 thisptr->u.node = n;
1774 thisptr->o.called = 1;
1775 }
1776 /* THIS IS MEANT TO FALL THROUGH! */
1777 case X_IS_INTERNAL:
1778 {
1779 paramboxptr args;
1780 streng *result;
1781
1782 if ( thisptr->u.node )
1783 {
1784 no_next_interactive = 1;
1785 args = initplist( TSD, thisptr );
1786 set_reserved_value( TSD, POOL0_SIGL, NULL, thisptr->lineno, VFLAG_NUM );
1787
1788 result = CallInternalFunction( TSD, thisptr->u.node, thisptr, args );
1789
1790 TSD->systeminfo->interactive = TSD->currlevel->traceint;
1791
1792 set_reserved_value( TSD, POOL0_RESULT, result, 0, ( result ) ? VFLAG_STR : VFLAG_NONE );
1793 break;
1794 }
1795 }
1796 /* THIS IS MEANT TO FALL THROUGH! */
1797 case X_EX_FUNC:
1798 case X_IS_BUILTIN:
1799 {
1800 streng *result ;
1801
1802 /*
1803 * Call a builtin procedure...
1804 */
1805 if ((result = buildtinfunc( TSD, thisptr )) == NOFUNC)
1806 {
1807 /*
1808 * ... and it wasn't a builtin procedure so assume its an external function
1809 */
1810 thisptr->type = X_IS_EXTERNAL ;
1811 }
1812 else
1813 {
1814 /*
1815 * ... and if it was a builtin procedure set RESULT and break
1816 */
1817 set_reserved_value( TSD, POOL0_RESULT, result, 0,
1818 ( result ) ? VFLAG_STR : VFLAG_NONE );
1819
1820 break ;
1821 }
1822 }
1823 /* THIS IS MEANT TO FALL THROUGH! */
1824 case X_IS_EXTERNAL:
1825 {
1826 streng *ptr, *command;
1827 paramboxptr args, targs;
1828 int len,err;
1829
1830 if ( TSD->restricted )
1831 exiterror( ERR_RESTRICTED, 5 );
1832
1833 update_envirs( TSD, TSD->currlevel );
1834
1835 args = targs = initplist( TSD, thisptr );
1836 stackmark = pushcallstack( TSD, TSD->currentnode );
1837 ptr = execute_external( TSD,
1838 thisptr->name,
1839 args,
1840 TSD->systeminfo->environment,
1841 &err,
1842 /* Fixes bug 604219 */
1843 TSD->systeminfo->hooks,
1844 INVO_SUBROUTINE );
1845 popcallstack( TSD, stackmark );
1846
1847 if ( ptr == thisptr->name )
1848 {
1849 /*
1850 * FIXME,MH: no idea what this does
1851 * FGC: agreed, added an assert. Remove this block in
1852 * complete in 2005 if nothing happens.
1853 */
1854 assert( ptr );
1855 ptr = NULL;
1856 }
1857
1858 if ( err == -ERR_PROG_UNREADABLE )
1859 {
1860 /*
1861 * "thisptr->name" wasn't an external Rexx program, so
1862 * see if it is an OS command
1863 * Only do this if the OPTIONS EXT_COMMANDS_AS_FUNCS is
1864 * set and STRICT_ANSI is NOT set.
1865 */
1866 if ( get_options_flag( TSD->currlevel, EXT_EXT_COMMANDS_AS_FUNCS )
1867 && !get_options_flag( TSD->currlevel, EXT_STRICT_ANSI ) )
1868 {
1869 len = Str_len( thisptr->name );
1870 for( targs = args; targs; targs = targs->next )
1871 {
1872 if ( targs->value )
1873 len += 1 + Str_len( targs->value );
1874 }
1875 command = Str_makeTSD( len );
1876 command = Str_catTSD( command, thisptr->name );
1877 for( targs = args; targs; targs = targs->next )
1878 {
1879 if ( targs->value )
1880 {
1881 command = Str_catstrTSD( command, " " );
1882 command = Str_catTSD( command, targs->value );
1883 }
1884 }
1885 ptr = run_popen( TSD, command, TSD->currlevel->environment );
1886 if ( ptr != NULL )
1887 err = 0;
1888 Free_stringTSD( command );
1889 }
1890 }
1891
1892 deallocplink( TSD, args );
1893
1894 if ( ptr && ( TSD->trace_stat == 'I' ) )
1895 tracevalue( TSD, ptr, 'F' );
1896
1897 if ( ptr )
1898 set_reserved_value( TSD, POOL0_RESULT, ptr, 0, VFLAG_STR );
1899 else
1900 set_reserved_value( TSD, POOL0_RESULT, NULL, 0, VFLAG_NONE );
1901
1902 if ( err == -ERR_PROG_UNREADABLE )
1903 {
1904 exiterror( ERR_ROUTINE_NOT_FOUND, 1, tmpstr_of( TSD, thisptr->name ) );
1905 }
1906 else if ( err )
1907 {
1908 post_process_system_call( TSD, thisptr->name, -err, NULL, thisptr );
1909 }
1910
1911 break;
1912 }
1913
1914 case X_PARSE:
1915 {
1916 /*
1917 * We always have to produce a duplicate of the content we have to
1918 * parse. We can't use variable locking and we can't assume that
1919 * the content doesn't contain variable names used in the template.
1920 * This fixes bug 688503.
1921 */
1922
1923 if ( thisptr->u.parseflags & ( PARSE_LOWER | PARSE_CASELESS ) )
1924 {
1925 if ( get_options_flag( TSD->currlevel, EXT_STRICT_ANSI ) )
1926 exiterror( ERR_NON_ANSI_FEATURE, 2,
1927 ( thisptr->u.parseflags & PARSE_LOWER ) ? "PARSE LOWER" :
1928 "PARSE CASELESS" ) ;
1929 }
1930 if ( thisptr->p[0]->type == X_PARSE_ARG )
1931 {
1932 parseargtree( TSD, TSD->currlevel->args, thisptr->p[1],
1933 thisptr->u.parseflags );
1934 }
1935 else
1936 {
1937 streng *source = NULL;
1938 nodeptr templ;
1939
1940 switch ( thisptr->p[0]->type )
1941 {
1942 case X_PARSE_VAR:
1943 /* must duplicate, parsing may have side effects */
1944 /* else, we must have locking of variables */
1945 source = Str_dupTSD( shortcut( TSD, thisptr->p[0] ) );
1946 break ;
1947
1948 case X_PARSE_VAL:
1949 {
1950 /*
1951 * Must duplicate, parsing may have side effects, we must
1952 * have locking of variables otherwise.
1953 * fixes bug ?
1954 */
1955 /*
1956 * Empty value allowed.
1957 * Fixes bug 952229
1958 */
1959 if ( thisptr->p[0]->p[0] )
1960 source = evaluate( TSD, thisptr->p[0]->p[0], NULL );
1961 else
1962 source = nullstringptr();
1963 break ;
1964 }
1965
1966 case X_PARSE_PULL:
1967 source = popline( TSD, NULL, NULL, 0 );
1968 break ;
1969
1970 case X_PARSE_VER:
1971 source = Str_creTSD( PARSE_VERSION_STRING );
1972 break ;
1973
1974 case X_PARSE_EXT:
1975 source = readkbdline( TSD );
1976 break ;
1977
1978 case X_PARSE_SRC:
1979 {
1980 const char *stype ;
1981 streng *inpfile;
1982
1983 stype = system_type();
1984 inpfile = TSD->systeminfo->input_file;
1985 source = Str_makeTSD( strlen( stype ) + 4 +
1986 strlen( invo_strings[TSD->systeminfo->invoked] ) +
1987 Str_len( inpfile ) );
1988 source->len = 0;
1989
1990 Str_catstrTSD( source, stype );
1991 Str_catstrTSD( source, " " );
1992 Str_catstrTSD( source, invo_strings[TSD->systeminfo->invoked] );
1993 Str_catstrTSD( source, " " );
1994 Str_catTSD( source, inpfile );
1995 break;
1996 }
1997 }
1998
1999 if ( thisptr->u.parseflags & PARSE_UPPER )
2000 {
2001 Str_upper( source );
2002 }
2003 if ( thisptr->u.parseflags & PARSE_LOWER )
2004 {
2005 Str_lower( source );
2006 }
2007
2008 doparse( TSD, source, thisptr->p[1],
2009 thisptr->u.parseflags & PARSE_CASELESS );
2010
2011 for ( templ = thisptr->p[1]->next; templ != NULL; templ = templ->next )
2012 {
2013 /*
2014 * This fixes bug 755801.
2015 * Actually, this will happen rarely, but we have to assign the
2016 * empty string to all template members of all comma-separated
2017 * lists of templates except of the first one.
2018 * We use the slow and long-term reliable code of doparse().
2019 */
2020 Str_len( source ) = 0;
2021 doparse( TSD, source, templ, 0 );
2022 }
2023
2024
2025 Free_stringTSD( source );
2026 }
2027 break;
2028 }
2029
2030 case X_PULL:
2031 {
2032 streng *stmp ;
2033
2034 doparse(TSD, stmp=Str_upper(popline( TSD, NULL, NULL, 0 )), thisptr->p[0], 0 ) ;
2035 Free_stringTSD( stmp ) ;
2036 break ;
2037 }
2038
2039 case X_PUSH:
2040 stack_lifo( TSD, (thisptr->p[0]) ? evaluate(TSD,thisptr->p[0],NULL) : nullstringptr(), NULL ) ;
2041 break ;
2042
2043 case X_QUEUE:
2044 stack_fifo( TSD, (thisptr->p[0]) ? evaluate(TSD,thisptr->p[0],NULL) : nullstringptr(), NULL ) ;
2045 break ;
2046
2047 case X_OPTIONS: /* fixes 1116894 */
2048 do_options(TSD, TSD->currlevel, (thisptr->p[0]) ? evaluate(TSD,thisptr->p[0],NULL) : nullstringptr(), 0) ;
2049 break ;
2050
2051 case X_RETURN:
2052 {
2053 stackelem *top;
2054 unsigned i;
2055 streng *retval;
2056
2057 /* buggy, need to deallocate procbox and vars ... */
2058 if (thisptr->p[0])
2059 retval = evaluate(TSD,thisptr->p[0],NULL) ;
2060 else
2061 retval = NULL ;
2062
2063 top = stacktop(TSD);
2064 for (i = stacktrigger(TSD);i > stktrigger;i--,top = top->prev)
2065 {
2066 if (top->increment == s.increment)
2067 s.increment = NULL;
2068 if (top->stopval == s.stopval)
2069 s.stopval = NULL;
2070 #ifdef OPT_DO
2071 if (top->do_for_val == s.do_for_val)
2072 s.do_for_val = NULL;
2073 #endif
2074 }
2075
2076 stackcleanup(TSD,stktrigger);
2077 nstackcleanup(TSD,nstktrigger,NULL);
2078 return( retval ) ;
2079 break ;
2080 }
2081 case X_LEAVE:
2082 case X_ITERATE:
2083 {
2084 int Stacked;
2085 stackelem *top;
2086 treenode *iptr;
2087
2088 Stacked = stacktrigger(TSD) - stktrigger;
2089
2090 if ( innerloop )
2091 { /* push the current count to let it been found below if "LEAVE name". */
2092 s.thisptr = innerloop;
2093 stackpush( TSD, &s );
2094 Stacked++;
2095 }
2096
2097 top = stacktop(TSD);
2098 for ( ;; ) /* while iteration counter name not found */
2099 {
2100 if ( Stacked <= 0 )
2101 {
2102 if ( innerloop )
2103 exiterror( ERR_INVALID_LEAVE, (thisptr->type==X_LEAVE)?3:4, tmpstr_of( TSD, thisptr->name ) );
2104 else
2105 exiterror( ERR_INVALID_LEAVE, (thisptr->type==X_LEAVE)?1:2 );
2106 }
2107
2108 iptr = top->thisptr;
2109
2110 if ( thisptr->name == NULL )
2111 {
2112 /*
2113 * LEAVE/ITERATE without any argument. Automatically pop one
2114 * stack element later.
2115 */
2116 break;
2117 }
2118
2119 /*
2120 * Backtrace all pending loops and compare the iterator name if
2121 * one exists. We have to keep care for unnamed loops like
2122 * "do 5 ; say fred ; end".
2123 */
2124 if ( ( iptr->p[0] != NULL ) &&
2125 ( iptr->p[0]->name != NULL ) &&
2126 ( Str_cmp( thisptr->name, iptr->p[0]->name ) == 0 ) )
2127 {
2128 /*
2129 * Iterator name equals our argument. Automatically pop one
2130 * stack element later.
2131 */
2132 break;
2133 }
2134
2135 /*
2136 * Unnamed loop or a loop with a nonmatching name, cleanup!
2137 * fixes bug 672864
2138 */
2139 popcallstack( TSD, -1 );
2140 if ( top->stopval == s.stopval )
2141 s.stopval = NULL;
2142 #ifdef OPT_DO
2143 if ( top->do_for_val == s.do_for_val )
2144 s.do_for_val = NULL;
2145 #endif
2146 if ( top->increment == s.increment )
2147 s.increment = NULL;
2148 stack_destroyelement( TSD, top );
2149
2150 Stacked--;
2151 top = top->prev;
2152 }
2153
2154 nstackcleanup(TSD,nstktrigger,&iptr);
2155
2156 if (Stacked<=0)
2157 exiterror( ERR_INVALID_LEAVE, 0 );
2158 if (thisptr->type==X_LEAVE)
2159 {
2160 popcallstack(TSD,-1) ;
2161 if (top->stopval == s.stopval )
2162 s.stopval = NULL ;
2163 #ifdef OPT_DO
2164 if (top->do_for_val == s.do_for_val )
2165 s.do_for_val = NULL ;
2166 #endif
2167 if ( top->increment == s.increment )
2168 s.increment = NULL ;
2169 stack_destroyelement(TSD,top);
2170 Stacked--;
2171 top = top->prev;
2172
2173 nstackpop(TSD);
2174 }
2175 if ( TSD->trace_stat != 'O' && TSD->trace_stat != 'N' && TSD->trace_stat != 'F' )
2176 traceline( TSD, iptr, TSD->trace_stat, 0 );
2177 stackcleanup(TSD,stktrigger + Stacked);
2178
2179 if (TSD->systeminfo->interactive)
2180 {
2181 if (intertrace(TSD))
2182 goto fakerecurse ;
2183 }
2184
2185 thisptr = nstackpop(TSD);
2186
2187 if (Stacked)
2188 {
2189 s = stackpop(TSD);
2190 innerloop = s.thisptr;
2191 }
2192 else
2193 innerloop = NULL;
2194 goto fakereturn ;
2195 break ;
2196 }
2197 case X_NUM_D:
2198 {
2199 int tmp, error ;
2200 streng *cptr,*kill;
2201 volatile char *err ;
2202
2203 cptr = evaluate( TSD, thisptr->p[0], &kill );
2204 tmp = streng_to_int( TSD, cptr, &error );
2205 if ( error || tmp <= 0 )
2206 {
2207 err = tmpstr_of( TSD, cptr );
2208 if ( kill )
2209 Free_stringTSD( kill );
2210 exiterror( ERR_INVALID_INTEGER, 5, err ) ;
2211 }
2212 if ( kill )
2213 Free_stringTSD( kill );
2214 if (TSD->currlevel->numfuzz >= tmp)
2215 exiterror( ERR_INVALID_RESULT, 1, tmp, TSD->currlevel->numfuzz );
2216 if (tmp > INT_MAX)
2217 exiterror( ERR_INVALID_RESULT, 2, tmp, INT_MAX ) ;
2218 TSD->currlevel->currnumsize = tmp ;
2219 break ;
2220 }
2221
2222 case X_NUM_DDEF:
2223 if (TSD->currlevel->numfuzz >= DEFAULT_NUMERIC_SIZE)
2224 exiterror( ERR_INVALID_RESULT, 1, DEFAULT_NUMERIC_SIZE, TSD->currlevel->numfuzz ) ;
2225 TSD->currlevel->currnumsize = DEFAULT_NUMERIC_SIZE ;
2226 break ;
2227
2228 case X_NUM_FDEF:
2229 if (TSD->currlevel->currnumsize <= DEFAULT_NUMERIC_FUZZ)
2230 exiterror( ERR_INVALID_RESULT, 1, TSD->currlevel->currnumsize, DEFAULT_NUMERIC_FUZZ ) ;
2231 TSD->currlevel->numfuzz = DEFAULT_NUMERIC_FUZZ ;
2232 break ;
2233
2234 case X_NUM_FRMDEF:
2235 TSD->currlevel->numfuzz = DEFAULT_NUMFORM ;
2236 break ;
2237
2238 case X_NUM_FUZZ:
2239 {
2240 int tmp, error ;
2241 streng *cptr,*kill;
2242 volatile char *err ;
2243
2244 cptr = evaluate( TSD, thisptr->p[0], &kill );
2245 tmp = streng_to_int( TSD, cptr, &error );
2246 if ( error || tmp < 0 )
2247 {
2248 err = tmpstr_of( TSD, cptr );
2249 if ( kill )
2250 Free_stringTSD( kill );
2251 exiterror( ERR_INVALID_INTEGER, 6, err ) ;
2252 }
2253 if ( kill )
2254 Free_stringTSD( kill );
2255 if (TSD->currlevel->currnumsize <= tmp)
2256 exiterror( ERR_INVALID_RESULT, 1, TSD->currlevel->currnumsize, tmp ) ;
2257 TSD->currlevel->numfuzz = tmp ;
2258 break ;
2259 }
2260
2261 case X_NUM_F:
2262 {
2263 if (thisptr->p[0]->type == X_NUM_SCI)
2264 TSD->currlevel->numform = NUM_FORM_SCI ;
2265 else if (thisptr->p[0]->type == X_NUM_ENG)
2266 TSD->currlevel->numform = NUM_FORM_ENG ;
2267 else
2268 assert( 0 ) ;
2269 break ;
2270 }
2271
2272 case X_NUM_V:
2273 {
2274 streng *tmpstr,*kill;
2275 int len;
2276 char *s;
2277
2278 tmpstr = evaluate( TSD, thisptr->p[0], &kill );
2279 len = tmpstr->len;
2280 s = tmpstr->value;
2281
2282 if ( ( len == 10 ) && ( mem_cmpic( s, "SCIENTIFIC", 10 ) == 0 ) )
2283 TSD->currlevel->numform = NUM_FORM_SCI ;
2284 else if ( ( len == 11 ) && ( mem_cmpic( s, "ENGINEERING", 11 ) == 0 ) )
2285 TSD->currlevel->numform = NUM_FORM_ENG ;
2286 else if ( ( len == 1 ) && ( rx_toupper( *s ) == 'S' ) )
2287 TSD->currlevel->numform = NUM_FORM_SCI ;
2288 else if ( ( len == 1 ) && ( rx_toupper( *s ) == 'E' ) )
2289 TSD->currlevel->numform = NUM_FORM_ENG ;
2290 else
2291 exiterror( ERR_INVALID_RESULT, 0 ) ;
2292 if ( kill )
2293 Free_stringTSD( kill );
2294 break ;
2295 }
2296
2297 case X_LABEL:
2298 case X_NULL:
2299 break ;
2300
2301 default:
2302 exiterror( ERR_INTERPRETER_FAILURE, 1, __FILE__, __LINE__, "" ) ;
2303 break ;
2304 }
2305
2306 if ((TSD->systeminfo->interactive)&&(!no_next_interactive))
2307 {
2308 if (intertrace(TSD))
2309 goto fakerecurse ;
2310 }
2311
2312 no_next_interactive = 0 ;
2313
2314 if (thisptr)
2315 thisptr = thisptr->next ;
2316
2317 fakereturn:
2318 if (!thisptr)
2319 {
2320 if (nstacktrigger(TSD) <= nstktrigger)
2321 {
2322 stackcleanup(TSD,stktrigger);
2323 return NULL ;
2324 }
2325 else
2326 thisptr = nstackpop(TSD);
2327 }
2328
2329 fakerecurse:
2330
2331 /* check if there is any traps to process */
2332 while (TSD->nextsig)
2333 {
2334 trap *traps = gettraps( TSD, TSD->currlevel ) ;
2335
2336 i = TSD->nextsig->type ;
2337
2338 if (i == SIGNAL_NOTREADY)
2339 fixup_file( TSD, TSD->nextsig->descr ) ;
2340
2341 /* if this condition is in delayed mode, ignore it for now */
2342 if (traps[i].delayed)
2343 goto aftersignals ;
2344
2345 /* if this condition is no begin trapped, use default action */
2346 if (traps[i].on_off == 0)
2347 {
2348 if (traps[i].def_act)
2349 goto aftersignals ; /* default==1 ==> ignore it */
2350 else
2351 exiterror( TSD->nextsig->rc, 0 ) ;
2352 }
2353 if (traps[i].invoked) /* invoke as SIGNAL */
2354 {
2355 /* simulate a SIGNAL, first empty the stack */
2356 /* Sorry, not safe to operate on these at this point, we just have to
2357 accept that some memory is lost ... "can't make omelette without..." */
2358 /* if (stkidx)
2359 * for (stkidx--;stkidx;stkidx--)
2360 * {
2361 * FREE_IF_DEFINED(TSD,stack[stkidx].increment) ;
2362 * FREE_IF_DEFINED(TSD,stack[stkidx].stopval) ;
2363 * }
2364 */ /* hey, this should really be ok, .... must be a BUG */
2365 stackcleanup(TSD,stktrigger); /* think it, too. stackcleanup
2366 * (re-)introduced Feb. 2000 */
2367
2368 /* turn off the condition */
2369 traps[i].on_off = 0 ;
2370 traps[i].delayed = 0 ;
2371 /* traps[i].trapped = 0 ; */
2372
2373 /* set the current condition information */
2374 if (TSD->currlevel->sig)
2375 {
2376 FREE_IF_DEFINED( TSD, TSD->currlevel->sig->info ) ;
2377 FREE_IF_DEFINED( TSD, TSD->currlevel->sig->descr ) ;
2378 FreeTSD( TSD->currlevel->sig ) ;
2379 }
2380 TSD->currlevel->sig = TSD->nextsig ;
2381 TSD->nextsig = NULL ;
2382
2383 /* simulate the SIGNAL statement */
2384 entry = getlabel( TSD, traps[i].name ) ;
2385 set_reserved_value( TSD, POOL0_SIGL, NULL,
2386 TSD->currlevel->sig->lineno, VFLAG_NUM );
2387 if (TSD->currlevel->sig->type == SIGNAL_SYNTAX )
2388 set_reserved_value( TSD, POOL0_RC, NULL, TSD->currlevel->sig->rc,
2389 VFLAG_NUM );
2390
2391 if ( entry == NULL )
2392 exiterror( ERR_UNEXISTENT_LABEL, 1, tmpstr_of( TSD, traps[i].name ) );
2393 if ( entry->u.trace_only )
2394 exiterror( ERR_UNEXISTENT_LABEL, 2, tmpstr_of( TSD, entry->name ) );
2395 thisptr = entry;
2396 nstackcleanup( TSD, nstktrigger, NULL );
2397 goto reinterpret;
2398 }
2399 else /*if ((i<SIGNALS))*/ /* invoke as CALL */
2400 {
2401 nodeptr savecurrentnode; /* pgb */
2402 streng *h;
2403
2404 if ( ( entry = getlabel( TSD, traps[i].name ) ) == NULL )
2405 exiterror( ERR_UNEXISTENT_LABEL, 1, tmpstr_of( TSD, traps[i].name ) );
2406 if ( entry->u.trace_only )
2407 exiterror( ERR_UNEXISTENT_LABEL, 3, tmpstr_of( TSD, entry->name ) );
2408
2409 traps[i].delayed = 1;
2410
2411 set_reserved_value( TSD, POOL0_SIGL, NULL, TSD->nextsig->lineno,
2412 VFLAG_NUM );
2413 oldlevel = TSD->currlevel;
2414 TSD->currlevel = newlevel( TSD, TSD->currlevel );
2415 TSD->currlevel->sig = TSD->nextsig;
2416 TSD->nextsig = NULL;
2417
2418 stackmark = pushcallstack( TSD, thisptr );
2419 if ( TSD->trace_stat != 'O' && TSD->trace_stat != 'N' && TSD->trace_stat != 'F' )
2420 traceline( TSD, entry, TSD->trace_stat, 0 );
2421
2422 savecurrentnode = TSD->currentnode; /* pgb */
2423 h = interpret( TSD, entry->next );
2424 if ( h != NULL )
2425 Free_stringTSD( h );
2426 TSD->currentnode = savecurrentnode; /* pgb */
2427
2428 traps[i].delayed = 0;
2429 popcallstack( TSD, stackmark );
2430 removelevel( TSD, TSD->currlevel );
2431 TSD->currlevel = oldlevel;
2432 TSD->currlevel->next = NULL;
2433 TSD->trace_stat = TSD->currlevel->tracestat;
2434 TSD->systeminfo->interactive = TSD->currlevel->traceint; /* MDW 30012002 */
2435 }
2436 }
2437
2438 aftersignals:
2439
2440 goto reinterpret;
2441
2442 }
2443
2444 /* getlabel searches for a label (procedure) in the current rexx program.
2445 * The label is case-insensitively searched. Its name must be name. The first
2446 * name found matches. The returned value is either NULL or the node of the
2447 * name.
2448 * This function uses a lazy evaluation mechanism and creates from the linked
2449 * list an array. The hash value of each entry is generated during the copy.
2450 * This function may become faster or much faster if the array is sorted
2451 * by the hashvalue which allows a bsearch() call. But, and this is the
2452 * problem, it is useful only if labels are search often and the number of
2453 * labels are more than a few. I think, external functions which are registered
2454 * in huge amounts are better candidates for this.
2455 */
getlabel(const tsd_t * TSD,const streng * name)2456 nodeptr getlabel( const tsd_t *TSD, const streng *name )
2457 {
2458 labelboxptr lptr, h;
2459 internal_parser_type *ipt = &TSD->systeminfo->tree;
2460 unsigned i, hash;
2461
2462 if (ipt->sort_labels == NULL)
2463 {
2464 if (ipt->first_label == NULL)
2465 return(NULL);
2466
2467 ipt->sort_labels = (labelboxptr)MallocTSD(ipt->numlabels * sizeof(ipt->sort_labels[0]));
2468 for (i = 0, lptr = ipt->first_label;i < ipt->numlabels;i++)
2469 {
2470 lptr->hash = hashvalue_ic(lptr->entry->name->value, lptr->entry->name->len);
2471 ipt->sort_labels[i] = *lptr;
2472 h = lptr->next;
2473 FreeTSD(lptr);
2474 lptr = h;
2475 }
2476 ipt->first_label = ipt->last_label = NULL;
2477 }
2478
2479 hash = hashvalue_ic(name->value, name->len);
2480 for (i = 0;i < ipt->numlabels;i++)
2481 {
2482 if (hash != ipt->sort_labels[i].hash)
2483 continue;
2484 if (Str_ccmp(ipt->sort_labels[i].entry->name, name) == 0)
2485 return(ipt->sort_labels[i].entry);
2486 }
2487 return(NULL);
2488 }
2489
2490
removelevel(tsd_t * TSD,proclevel level)2491 void removelevel( tsd_t *TSD, proclevel level )
2492 {
2493 int i=0 ;
2494
2495 if ( level->next )
2496 {
2497 removelevel( TSD, level->next ) ;
2498 /* level->next = NULL; */
2499 }
2500
2501 if (level->varflag==1) /* does not belong *here* !!! */
2502 kill_variables( TSD, level->vars ) ;
2503
2504 if (level->args)
2505 deallocplink( TSD, level->args ) ;
2506
2507 if (level->environment)
2508 Free_stringTSD( level->environment ) ;
2509
2510 if (level->prev_env)
2511 Free_stringTSD( level->prev_env ) ;
2512
2513 if (level->prev)
2514 level->prev->next = NULL ;
2515
2516 FREE_IF_DEFINED( TSD, level->signal_continue );
2517
2518 if (level->sig)
2519 {
2520 FREE_IF_DEFINED( TSD, level->sig->info ) ;
2521 FREE_IF_DEFINED( TSD, level->sig->descr ) ;
2522 FreeTSD( level->sig ) ;
2523 }
2524
2525 if (level->traps)
2526 {
2527 for (i=0; i<SIGNALS; i++)
2528 FREE_IF_DEFINED( TSD, level->traps[i].name ) ;
2529
2530 FreeTSD( level->traps ) ;
2531 }
2532
2533 FreeTSD(level) ;
2534 }
2535
2536
2537 /*
2538 * NOTE: The ->buf variable is not set here, It must be set. When
2539 * an old level is duplicated, the old ->buf is also duplicated,
2540 * but DO_NO_USE_IT, since it will point to the reentring point
2541 * of the mother-routine
2542 */
newlevel(tsd_t * TSD,proclevel oldlevel)2543 proclevel newlevel( tsd_t *TSD, proclevel oldlevel )
2544 {
2545 itp_tsd_t *it = (itp_tsd_t *)TSD->itp_tsd;
2546 proclevel level;
2547 int i;
2548 char *str;
2549 streng *opts;
2550
2551 level = (proclevel) MallocTSD( sizeof( proclevbox ) );
2552
2553 if ( oldlevel == NULL )
2554 {
2555 /*
2556 * This is executed only once on startup of the interpreter.
2557 */
2558 #ifdef __CHECKER__
2559 /* There is a memcpy below which Checker don't like. The reason
2560 * may be the aligned "char"s which will use one machine word
2561 * but are initialized simply by an assignment of one byte.
2562 * Checker sees 3 byte of uninitialized data --> error.
2563 * (Of course, this isn't an error.)
2564 * Always double-check the initializations below in case of
2565 * any changes.
2566 * FGC
2567 */
2568 memset( level, 0, sizeof( proclevbox ) );
2569 #endif
2570 level->numfuzz = DEFAULT_NUMERIC_FUZZ;
2571 level->currnumsize = DEFAULT_NUMERIC_SIZE;
2572 level->numform = DEFAULT_NUMFORM;
2573 level->rx_time.sec = 0;
2574 level->rx_time.usec = 0;
2575 level->mathtype = DEFAULT_MATH_TYPE;
2576 level->prev = NULL;
2577 level->next = NULL;
2578 level->args = NULL;
2579 level->options = 0;
2580
2581 if ( it->opts_set )
2582 level->options = it->options;
2583 else
2584 {
2585 /* never call set_options_flag() on MATAOP options */
2586 set_options_flag( level, EXT_LINEOUTTRUNC, DEFAULT_LINEOUTTRUNC );
2587 set_options_flag( level, EXT_FLUSHSTACK, DEFAULT_FLUSHSTACK );
2588 set_options_flag( level, EXT_MAKEBUF_BIF, DEFAULT_MAKEBUF_BIF );
2589 set_options_flag( level, EXT_DROPBUF_BIF, DEFAULT_DROPBUF_BIF );
2590 set_options_flag( level, EXT_DESBUF_BIF, DEFAULT_DESBUF_BIF );
2591 set_options_flag( level, EXT_BUFTYPE_BIF, DEFAULT_BUFTYPE_BIF );
2592 set_options_flag( level, EXT_CACHEEXT, DEFAULT_CACHEEXT );
2593 set_options_flag( level, EXT_PRUNE_TRACE, DEFAULT_PRUNE_TRACE );
2594 set_options_flag( level, EXT_EXT_COMMANDS_AS_FUNCS, DEFAULT_EXT_COMMANDS_AS_FUNCS );
2595 set_options_flag( level, EXT_STDOUT_FOR_STDERR, DEFAULT_STDOUT_FOR_STDERR );
2596 set_options_flag( level, EXT_TRACE_HTML, DEFAULT_TRACE_HTML );
2597 set_options_flag( level, EXT_FAST_LINES_BIF_DEFAULT, DEFAULT_FAST_LINES_BIF_DEFAULT );
2598 set_options_flag( level, EXT_STRICT_ANSI, DEFAULT_STRICT_ANSI );
2599 set_options_flag( level, EXT_INTERNAL_QUEUES, DEFAULT_INTERNAL_QUEUES );
2600 set_options_flag( level, EXT_REGINA_BIFS, DEFAULT_REGINA_BIFS );
2601 set_options_flag( level, EXT_STRICT_WHITE_SPACE_COMPARISONS, DEFAULT_STRICT_WHITE_SPACE_COMPARISONS );
2602 set_options_flag( level, EXT_AREXX_SEMANTICS, DEFAULT_AREXX_SEMANTICS );
2603 set_options_flag( level, EXT_AREXX_BIFS, DEFAULT_AREXX_BIFS );
2604 set_options_flag( level, EXT_BROKEN_ADDRESS_COMMAND, DEFAULT_BROKEN_ADDRESS_COMMAND );
2605 set_options_flag( level, EXT_CALLS_AS_FUNCS, DEFAULT_CALLS_AS_FUNCS );
2606 set_options_flag( level, EXT_QUEUES_301, DEFAULT_QUEUES_301 );
2607 set_options_flag( level, EXT_HALT_ON_EXT_CALL_FAIL, DEFAULT_HALT_ON_EXT_CALL_FAIL );
2608 set_options_flag( level, EXT_SINGLE_INTERPRETER, DEFAULT_SINGLE_INTERPRETER );
2609 set_options_flag( level, EXT_SINGLE_LINE_COMMENTS, DEFAULT_SINGLE_LINE_COMMENTS );
2610
2611 if ( ( str = mygetenv( TSD, "REGINA_OPTIONS", NULL, 0 ) ) != NULL )
2612 {
2613 opts = Str_creTSD( str );
2614 FreeTSD( str );
2615 do_options( TSD, level, opts, 0 );
2616 }
2617 it->opts_set = 1;
2618 it->options = level->options;
2619 }
2620
2621 level->varflag = 1;
2622 level->tracestat = (char) TSD->systeminfo->tracing;
2623 level->traceint = (char) TSD->systeminfo->interactive;
2624 level->environment = Str_dupTSD( TSD->systeminfo->environment );
2625 level->prev_env = Str_dupTSD( TSD->systeminfo->environment );
2626 level->vars = create_new_varpool( TSD, 0 );
2627 level->signal_continue = NULL;
2628 level->sig = NULL;
2629 level->traps = (trap *)MallocTSD( sizeof(trap) * SIGNALS );
2630 #ifdef __CHECKER__
2631 /* See above */
2632 memset( level->traps, 0, sizeof(trap) * SIGNALS );
2633 #endif
2634 for (i=0; i<SIGNALS; i++)
2635 {
2636 level->traps[i].name = NULL;
2637 level->traps[i].on_off = 0;
2638 level->traps[i].delayed = 0;
2639 level->traps[i].def_act = default_action[i];
2640 level->traps[i].ignored = default_ignore[i];
2641 level->traps[i].invoked = 0;
2642 }
2643 level->pool = 1;
2644 }
2645 else
2646 {
2647 /* Stupid SunOS acc gives incorrect warning for the next line */
2648 memcpy( level, oldlevel, sizeof( proclevbox ) );
2649 #ifdef DONT_DO_THIS
2650 level->prev_env = NULL;
2651 level->environment = NULL;
2652 #else
2653 level->prev_env = Str_dupTSD( oldlevel->prev_env );
2654 level->environment = Str_dupTSD( oldlevel->environment );
2655 #endif
2656 level->prev = oldlevel;
2657 level->varflag = 0;
2658 oldlevel->next = level;
2659 level->signal_continue = NULL;
2660 level->args = NULL;
2661 /* level->next = NULL;*/
2662 level->sig = NULL;
2663 level->traps = NULL;
2664 level->pool++;
2665 }
2666
2667 TSD->trace_stat = level->tracestat;
2668 return level;
2669 }
2670
2671
expose_indir(tsd_t * TSD,const streng * list)2672 static void expose_indir( tsd_t *TSD, const streng *list )
2673 {
2674 const char *cptr=NULL, *eptr=NULL, *sptr=NULL ;
2675 streng *tmp=NULL ;
2676
2677 cptr = list->value ;
2678 eptr = cptr + list->len ;
2679 tmp = Str_makeTSD( 64 ) ;
2680 for (;cptr<eptr;)
2681 {
2682 for (; cptr<eptr && rx_isspace(*cptr); cptr++ ) ;
2683 for (sptr=cptr; cptr<eptr && !rx_isspace(*cptr); cptr++ ) ;
2684 if (cptr-sptr >= 64)
2685 exiterror( ERR_TOO_LONG_STRING, 0 ) ;
2686 if (cptr==sptr)
2687 continue;
2688
2689 memcpy( tmp->value, sptr, cptr-sptr ) ;
2690 tmp->len = cptr-sptr ;
2691 /* need to uppercase each variable in the list!! */
2692 Str_upper( tmp );
2693 expose_var( TSD, tmp ) ;
2694 }
2695 Free_stringTSD( tmp ) ;
2696 }
2697
2698
2699 /*
2700 * jump_rexx_signal should be used when a "SIGNAL ON" condition happens.
2701 * This function jumps to the previously assigned handler. This function
2702 * ensures a proper cleanup if the global lock flag "in_protected" is set.
2703 */
jump_rexx_signal(tsd_t * TSD)2704 void jump_rexx_signal( tsd_t *TSD )
2705 {
2706 if ( TSD->in_protected )
2707 {
2708 /*
2709 * The lexer is running. We have to terminate him and let him do his
2710 * cleanup. After it, we'll be called again but without "in_protected".
2711 */
2712 TSD->delayed_error_type = PROTECTED_DelayedRexxSignal;
2713 longjmp( TSD->protect_return, 1 );
2714 }
2715 longjmp( *TSD->currlevel->signal_continue, 1 );
2716 }
2717
2718
2719 /*
2720 * jump_interpreter_exit should be used when the whole interpreter should
2721 * terminate. This usually happens in case of a hard error or when the main
2722 * script ends.
2723 *
2724 * processExitCode tells the interpreter what return code shall be used on the
2725 * last exit.
2726 *
2727 * DON'T GET CONFUSED WITH jump_script_exit!
2728 *
2729 * This function jumps to the previously assigned handler. This function
2730 * ensures a proper cleanup if the global lock flag "in_protected" is set.
2731 */
jump_interpreter_exit(tsd_t * TSD,int processExitCode)2732 void jump_interpreter_exit( tsd_t *TSD, int processExitCode )
2733 {
2734 if ( TSD->in_protected )
2735 {
2736 /*
2737 * The lexer is running. We have to terminate him and let him do his
2738 * cleanup. After it, we'll be called again but without "in_protected".
2739 */
2740 TSD->expected_exit_error = processExitCode;
2741 TSD->delayed_error_type = PROTECTED_DelayedInterpreterExit;
2742 longjmp( TSD->protect_return, 1 );
2743 }
2744 TSD->MTExit( processExitCode );
2745 }
2746
2747
2748 /*
2749 * jump_script_exit should be used when a script ends or enters an EXIT
2750 * instraction.
2751 *
2752 * result tells the interpreter what return string shall be returned to the
2753 * caller.
2754 *
2755 * DON'T GET CONFUSED WITH jump_interpreter_exit!
2756 *
2757 * This function jumps to the previously assigned handler. This function
2758 * ensures a proper cleanup if the global lock flag "in_protected" is set.
2759 */
jump_script_exit(tsd_t * TSD,streng * result)2760 void jump_script_exit( tsd_t *TSD, streng *result )
2761 {
2762 TSD->systeminfo->result = result;
2763
2764 if ( TSD->in_protected && TSD->systeminfo->script_exit )
2765 {
2766 /*
2767 * The lexer is running. We have to terminate him and let him do his
2768 * cleanup. After it, we'll be called again but without "in_protected".
2769 */
2770 TSD->delayed_error_type = PROTECTED_DelayedScriptExit;
2771 longjmp( TSD->protect_return, 1 );
2772 }
2773
2774 if ( !TSD->systeminfo->script_exit )
2775 exiterror( ERR_INTERPRETER_FAILURE, 1, __FILE__, __LINE__,
2776 "script EXIT not registered" );
2777
2778 longjmp( *TSD->systeminfo->script_exit, 1 );
2779 }
2780