2 * The Regina Rexx Interpreter
3 * Copyright (C) 1992-1994 Anders Christensen <anders@pvv.unit.no>
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.
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.
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.
32 #define XOR(a,b) (( (a) && (!(b)) )||( (!(a)) && (b) ))
35 /* Asynchroneous scheduled in another thread: */
36 volatile int __regina_Win32CtrlCRaised
= 0;
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 } ;
42 #define NSTACKELEMS 32 /* nstack elements will be allocated in this size */
43 typedef struct _nstackbox
{
44 struct _nstackbox
*next
;
45 struct _nstackbox
*prev
;
47 unsigned sum
; /* To provide safe triggers, never use ptrs */
48 nodeptr elems
[NSTACKELEMS
];
51 typedef struct _stackelem
{
54 num_descr
* increment
;
58 struct _stackelem
*prev
; /* needed for a look back */
61 #define STACKELEMS 64 /* nstack elements will be allocated in this size */
62 typedef struct _stackbox
{
63 struct _stackbox
*next
;
64 struct _stackbox
*prev
;
66 unsigned sum
; /* To provide safe triggers, never use ptrs */
67 stackelem elems
[STACKELEMS
];
70 typedef struct { /* itp_tsd: static variables of this module (thread-safe) */
75 unsigned long options
;
77 } itp_tsd_t
; /* thread-specific but only needed by this module. see
83 static void expose_indir( tsd_t
*TSD
, const streng
*list
) ;
86 static void mark_spec_vars(const tsd_t
*TSD
)
90 it
= (itp_tsd_t
*) TSD
->itp_tsd
;
96 * The function returns 1 on success, 0 if memory is short.
98 int init_spec_vars( tsd_t
*TSD
)
102 if (TSD
->itp_tsd
!= NULL
)
105 if ( ( TSD
->itp_tsd
= MallocTSD( sizeof(itp_tsd_t
) ) ) == NULL
)
107 it
= (itp_tsd_t
*)TSD
->itp_tsd
;
108 memset(it
,0,sizeof(itp_tsd_t
));
110 it
->nbox_top
= &it
->nbox
;
111 it
->stk_top
= &it
->sbox
;
114 regmarker( TSD
, mark_spec_vars
) ;
120 void update_envirs( const tsd_t
*TSD
, proclevel level
)
122 proclevel lptr
=NULL
;
124 if (!level
->environment
)
126 for (lptr
=level
->prev
; lptr
; lptr
=lptr
->prev
)
128 if (lptr
->environment
)
130 level
->environment
= Str_dupTSD(lptr
->environment
) ;
135 if (!level
->prev_env
)
137 for (lptr
=level
->prev
; lptr
; lptr
=lptr
->prev
)
141 level
->prev_env
= Str_dupTSD(lptr
->prev_env
) ;
147 assert( level
->environment
) ;
148 assert( level
->prev_env
) ;
151 /* nstackpush pushes the arg pnode on the nstack. (copy, then increment)
153 static void nstackpush(const tsd_t
*TSD
,nodeptr pnode
)
158 it
= (itp_tsd_t
*)TSD
->itp_tsd
;
160 ns
->elems
[ns
->used
++] = pnode
;
161 if (ns
->used
>= NSTACKELEMS
)
163 if (ns
->next
== NULL
)
165 ns
->next
= (nstackbox
*)MallocTSD(sizeof(nstackbox
));
167 ns
->next
->next
= NULL
;
169 ns
->next
->sum
= ns
->sum
+ NSTACKELEMS
;
171 assert( ns
->next
->used
== 0 ) ; /* be sure to have an empty block */
172 it
->nbox_top
= ns
->next
;
176 /* nstackpop pops an element from the nstack. (decrement, then copy)
177 * The return is the saved value formerly saved by a call to nstackpush.
178 * nstackpush/nstackpop calls may be nested.
179 * The return value is NULL in case of an empty stack.
180 * We use a delayed cleanup (one free nstackbox is available while popping).
182 static nodeptr
nstackpop(const tsd_t
*TSD
)
187 it
= (itp_tsd_t
*)TSD
->itp_tsd
;
191 /* For a delayed deletion preserve this box and delete the next one */
202 it
->nbox_top
= ns
= ns
->prev
;
205 return(ns
->elems
[ns
->used
]);
208 /* nstacktrigger returns a stack descriptor which allow the caller to return
209 * to the current state by using nstackcleanup() later.
211 static unsigned nstacktrigger(const tsd_t
*TSD
)
216 it
= (itp_tsd_t
*)TSD
->itp_tsd
;
218 return(ns
->sum
+ ns
->used
);
221 /* nstackcleanup cleans up the stack until either the trigger from a
222 * nstacktrigger() is reached or the node encounters, whatever comes first.
223 * In the first case the state is as during the call to nstacktrigger().
224 * In the second case the matching node is NOT popped. To allow a search for
225 * NULL the matching pointer is indexed. Giving NULL means don't use the
226 * matching algorithm. Give
227 * "cnodeptr m=NULL; nstackcleanup(TSD,?,&m);" to match a NULL pointer.
230 static void nstackcleanup(const tsd_t
*TSD
,
232 const nodeptr
*match
)
236 cnodeptr m
= NULL
; /* Keep the compiler happy */
238 it
= (itp_tsd_t
*)TSD
->itp_tsd
;
242 while (trigger
< ns
->sum
) /* The complete block may be killed! */
248 if (ns
->elems
[--ns
->used
] == m
)
259 /* For a delayed deletion preserve this box and delete the next one */
271 it
->nbox_top
= ns
= ns
->prev
;
274 /* The trigger is within the current box. Do an alignment to force
275 * trigger to be used in conjunction with ns->used.
278 if (trigger
>= ns
->used
) /* Be safety. Imagine a wild trigger! */
281 if (!match
) /* Things may be simple */
287 while (trigger
!= ns
->used
)
288 if (ns
->elems
[--ns
->used
] == m
)
296 /* stackpush pushes the contents of the arg sbox on the stack. (copy, then
299 static void stackpush(const tsd_t
*TSD
,const stackelem
*sbox
)
304 it
= (itp_tsd_t
*)TSD
->itp_tsd
;
306 sb
->elems
[sb
->used
] = *sbox
;
308 sb
->elems
[sb
->used
].prev
= sb
->elems
+ sb
->used
- 1;
310 sb
->elems
[0].prev
= sb
->prev
->elems
+ STACKELEMS
- 1;
312 sb
->elems
[0].prev
= NULL
;
315 if (sb
->used
>= STACKELEMS
)
317 if (sb
->next
== NULL
)
319 sb
->next
= (stackbox
*)MallocTSD(sizeof(stackbox
));
321 sb
->next
->next
= NULL
;
322 sb
->next
->sum
= sb
->sum
+ STACKELEMS
; /* const to each block */
324 assert( sb
->next
->used
== 0 ) ; /* be sure to have an empty block */
325 it
->stk_top
= sb
->next
;
329 /* stackpop pops an element from the stack. (decrement, then copy)
330 * The return is the saved value formerly saved by a call to stackpush.
331 * stackpush/stackpop calls may be nested.
332 * The return value is filled with 0 in case of an empty stack.
333 * We use a delayed cleanup (one free stackbox is available while popping).
335 static stackelem
stackpop(const tsd_t
*TSD
)
341 it
= (itp_tsd_t
*)TSD
->itp_tsd
;
345 /* For a delayed deletion preserve this box and delete the next one */
354 memset(&zero
,0,sizeof(zero
));
357 it
->stk_top
= sb
= sb
->prev
;
360 return(sb
->elems
[sb
->used
]);
363 /* stacktrigger returns a stack descriptor which allow the caller to return
364 * to the current state by using stackcleanup() later. See also stacktop().
366 static unsigned stacktrigger(const tsd_t
*TSD
)
371 it
= (itp_tsd_t
*)TSD
->itp_tsd
;
373 return(sb
->sum
+ sb
->used
);
376 /* stacktop returns a pointer to the top element of the stack. This may be
377 * useful to manipulate stack elements or have a look back. Be careful with
378 * the stack and don't use elements which were not pushed by the current
379 * incarnation of interpret(). See also stacktrigger().
380 * NULL is returned if the stack is empty.
382 static stackelem
* stacktop(const tsd_t
*TSD
)
387 it
= (itp_tsd_t
*)TSD
->itp_tsd
;
390 return(sb
->elems
+ sb
->used
- 1);
392 return(sb
->prev
->elems
+ STACKELEMS
- 1);
396 /* stack_destroyelement kill the increment and stopval values of a stack
397 * elements if they exist. The values are reset to zero after the deletion.
399 static void stack_destroyelement(const tsd_t
*TSD
,stackelem
*se
)
403 free_a_descr(TSD
,se
->stopval
);
408 free_a_descr(TSD
,se
->increment
);
409 se
->increment
= NULL
;
414 /* stackcleanup cleans up the stack until the trigger from a
415 * stacktrigger() is reached. After the call the stack is in the same state as
416 * during the call to stacktrigger.
417 * Warning: The elements increment and stopval will be deleted for each
418 * deleted stack elements if they exist. Do a stacktop() and use the
419 * prev value of each entry for the appropriate count do set the
420 * values to NULL if you don't want this.
422 static void stackcleanup(const tsd_t
*TSD
,unsigned trigger
)
426 unsigned tokill
= stacktrigger(TSD
);
428 if (tokill
<= trigger
)
432 it
= (itp_tsd_t
*)TSD
->itp_tsd
;
438 /* For a delayed deletion preserve this box and delete the next one */
447 it
->stk_top
= sb
= sb
->prev
;
450 stack_destroyelement(TSD
,sb
->elems
+ sb
->used
);
454 void SaveInterpreterStatus(const tsd_t
*TSD
,unsigned *state
)
456 assert(IPRT_BUFSIZE
>= 2);
457 state
[0] = nstacktrigger(TSD
);
458 state
[1] = stacktrigger(TSD
);
461 void RestoreInterpreterStatus(const tsd_t
*TSD
,const unsigned *state
)
463 nstackcleanup(TSD
,state
[0],NULL
);
464 stackcleanup(TSD
,state
[1]);
467 streng
*CallInternalFunction( tsd_t
*TSD
, nodeptr node
, nodeptr thisptr
,
473 nodeptr savecurrentnode
;
475 oldlevel
= TSD
->currlevel
;
476 TSD
->currlevel
= newlevel( TSD
, TSD
->currlevel
);
477 TSD
->currlevel
->args
= args
;
478 stackmark
= pushcallstack( TSD
, thisptr
);
480 savecurrentnode
= TSD
->currentnode
;
481 result
= interpret( TSD
, node
);
482 TSD
->currentnode
= savecurrentnode
;
484 popcallstack( TSD
, stackmark
);
485 removelevel( TSD
, TSD
->currlevel
);
486 TSD
->currlevel
= oldlevel
;
487 TSD
->currlevel
->next
= NULL
;
488 TSD
->trace_stat
= TSD
->currlevel
->tracestat
;
493 streng
*interpret(tsd_t
* volatile TSD
, treenode
* volatile thisptr
)
498 treenode
*entry
=NULL
;
499 int no_next_interactive
=0 ;
501 volatile unsigned stktrigger
;
502 volatile unsigned nstktrigger
;
503 nodeptr innerloop
=NULL
;
504 num_descr
*tdescr
=NULL
;
505 volatile nodeptr secure_this
;
506 tsd_t
* volatile secure_TSD
;
508 nstktrigger
= nstacktrigger(TSD
);
509 stktrigger
= stacktrigger(TSD
);
511 secure_TSD
= TSD
; /* vars used until here */
512 secure_this
= thisptr
;
514 if ( TSD
->currlevel
->signal_continue
== NULL
)
516 TSD
->currlevel
->signal_continue
= (jmp_buf *)MallocTSD( sizeof( jmp_buf ) );
518 assert( !TSD
->in_protected
);
519 if ( setjmp( *TSD
->currlevel
->signal_continue
) )
521 /* A signal arrived and a longjmp from anywhere jumps here.
522 * We can't believe in anything and have to rebuild it from
523 * scratch or volatile pointers. Even an unoptimized compiler
524 * may have optimized the access to values of any kind.
525 * We have to do the full reinitialization.
526 * prevents bugs like 592393
528 thisptr
= secure_this
;
533 memset(&s
,0,sizeof(s
));
535 nstackcleanup(TSD
,nstktrigger
,NULL
);
536 stackcleanup(TSD
,stktrigger
);
537 no_next_interactive
= 0 ;
542 memset(&s
,0,sizeof(s
));
543 no_next_interactive
= 0 ;
550 * Braindamaged Win32 systems raise ^C in a different thread. We catch the
551 * global flag set the thread's own halt-flag.
553 if ( __regina_Win32CtrlCRaised
)
555 TSD
->HaltRaised
= __regina_Win32CtrlCRaised
;
556 __regina_Win32CtrlCRaised
= 0;
559 if ( TSD
->HaltRaised
)
565 secure_this
= thisptr
;
567 TSD
->currentnode
= thisptr
;
568 if ( TSD
->trace_stat
!= 'O' && TSD
->trace_stat
!= 'N' && TSD
->trace_stat
!= 'F' )
570 if (thisptr
->type
!= X_DO
) /* let do-stats trace themselves */
571 traceline( TSD
, thisptr
, TSD
->trace_stat
, 0 );
576 FreeTSD(thisptr
->now
);
580 thisptr
->o
.called
= 0;
582 switch ( /*(unsigned char)*/ (thisptr
->type
) )
589 thisptr
= thisptr
->p
[0] ;
597 streng
*tmpstr
,*tmpkill
=NULL
;
599 if (innerloop
==thisptr
)
601 assert( thisptr
->p
[3] ) ;
602 if ( TSD
->trace_stat
!= 'O' && TSD
->trace_stat
!= 'N' && TSD
->trace_stat
!= 'F' )
604 traceline( TSD
, thisptr
->p
[3], TSD
->trace_stat
, -1 );
605 traceline( TSD
, thisptr
, TSD
->trace_stat
, -1 );
611 if ( TSD
->trace_stat
!= 'O' && TSD
->trace_stat
!= 'N' && TSD
->trace_stat
!= 'F' )
612 traceline( TSD
, thisptr
, TSD
->trace_stat
, 0 );
615 if (!((thisptr
->p
[0])||(thisptr
->p
[1])))
617 nstackpush(TSD
,thisptr
->next
);
618 thisptr
= thisptr
->p
[2] ;
622 nstackpush(TSD
,thisptr
->next
); /* for use with leave */
626 s
.thisptr
= innerloop
;
631 s
.increment
= s
.stopval
= tdescr
= NULL
;
636 if ((thisptr
->p
[0])&&(thisptr
->p
[0]->name
))
637 tmpstr
= evaluate( TSD
, thisptr
->p
[0]->p
[0], &tmpkill
);
641 if ((thisptr
->p
[0])&&(thisptr
->p
[0]->p
[i
]))
644 switch( thisptr
->p
[0]->p
[i
]->type
)
647 tmpptr
= thisptr
->p
[0]->p
[i
]->p
[0] ;
648 s
.stopval
= calcul(TSD
,tmpptr
,NULL
) ;
652 s
.incr_node
= thisptr
->p
[0]->p
[i
]->p
[0] ;
653 tmpptr
= thisptr
->p
[0]->p
[i
]->p
[0] ;
654 s
.increment
= calcul(TSD
,tmpptr
,NULL
) ;
655 s
.incrdir
= descr_sign( s
.increment
) ;
662 streng
*chptr
,*chkill
;
664 tmpptr
= thisptr
->p
[0]->p
[i
]->p
[0] ;
665 chptr
= evaluate(TSD
, tmpptr
, &chkill
);
666 iptr
= streng_to_int(TSD
, chptr
, &error
);
668 exiterror( ERR_INVALID_INTEGER
, (thisptr
->p
[0]->p
[i
]->type
==X_DO_EXPR
) ? 2 : 3, chptr
->value
);
670 exiterror( ERR_INVALID_RESULT
, 0 );
673 Free_stringTSD( chkill
);
682 * Normalise the iterator for the DO loop; must be a number.
684 setshortcut( TSD
, thisptr
->p
[0], str_normalize( TSD
, tmpstr
) );
685 tdescr
= shortcutnum( TSD
, thisptr
->p
[0] );
687 Free_stringTSD( tmpkill
);
690 if (TSD
->systeminfo
->interactive
)
697 free_a_descr( TSD
, s
.increment
) ;
702 free_a_descr( TSD
, s
.stopval
) ;
715 tsign
= string_test( TSD
, tdescr
, s
.stopval
) ;
716 if (!(tsign
^ s
.incrdir
))
720 if ((s
.number
>=0) && (s
.number
--<=0))
724 if ((thisptr
->p
[1])&&((thisptr
->p
[1]->type
)==X_WHILE
))
725 if (!isboolean(TSD
,thisptr
->p
[1]->p
[0],3, NULL
))
730 nstackpush(TSD
,thisptr
);
731 pushcallstack(TSD
,NULL
) ;
733 innerloop
= thisptr
;
734 thisptr
= thisptr
->p
[2] ;
738 popcallstack(TSD
,-1) ;
740 if ((thisptr
->p
[1])&&((thisptr
->p
[1]->type
)==X_UNTIL
))
742 if (isboolean(TSD
,thisptr
->p
[1]->p
[0],4, NULL
))
746 if ((thisptr
->p
[0])&&(thisptr
->p
[0]->name
))
748 tdescr
= shortcutnum( TSD
, thisptr
->p
[0] ) ;
750 * Check if we still have a valid number. If not
751 * exit with arithmetic error.
754 exiterror( ERR_BAD_ARITHMETIC
, 0 ) ;
758 string_add( TSD
, tdescr
, s
.increment
, tdescr
, thisptr
->p
[0],
760 /* fixes bug 1109729: */
761 str_round( tdescr
, TSD
->currlevel
->currnumsize
) ;
764 string_incr( TSD
, tdescr
, thisptr
->p
[0] ) ;
766 if (thisptr
->p
[0]->u
.varbx
)
768 thisptr
->p
[0]->u
.varbx
->num
= tdescr
;
769 thisptr
->p
[0]->u
.varbx
->flag
= VFLAG_NUM
;
770 if ( TSD
->trace_stat
== 'I' )
771 tracenumber( TSD
, tdescr
, 'V');
774 setshortcut( TSD
, thisptr
->p
[0], str_norm( TSD
, tdescr
, NULL
)) ;
781 * Check for ^C before iterating. Fixes bug 882878.
784 if ( __regina_Win32CtrlCRaised
)
786 TSD
->HaltRaised
= __regina_Win32CtrlCRaised
;
787 __regina_Win32CtrlCRaised
= 0;
790 if ( TSD
->HaltRaised
)
795 endloop
: if (s
.increment
)
797 free_a_descr( TSD
, s
.increment
) ;
802 free_a_descr( TSD
, s
.stopval
) ;
805 no_next_interactive
= 1 ;
808 if (stacktrigger(TSD
) > stktrigger
)
811 innerloop
= s
.thisptr
;
820 treenode
*othis
= thisptr
, *n
;
821 int retval
= isboolean( TSD
, thisptr
->p
[0], 1, NULL
);
823 if ( TSD
->trace_stat
!= 'O' && TSD
->trace_stat
!= 'N' && TSD
->trace_stat
!= 'F' )
825 n
= thisptr
->p
[0]->next
;
826 while ( n
!= NULL
) {
827 traceline( TSD
, n
, TSD
->trace_stat
, 0 );
832 nstackpush(TSD
,thisptr
->next
);
833 thisptr
= thisptr
->p
[retval
? 1 : 2];
834 if (TSD
->systeminfo
->interactive
)
847 streng
*preferred_str
;
850 ntmp
= calcul(TSD
,thisptr
->p
[1],NULL
);
851 assert( ntmp
->size
);
853 type
= thisptr
->p
[1]->type
;
854 if ( ( type
== X_STRING
) || ( type
== X_CON_SYMBOL
) )
855 preferred_str
= Str_dupTSD( thisptr
->p
[1]->name
);
857 preferred_str
= NULL
;
859 if (thisptr
->p
[0]->type
==X_HEAD_SYMBOL
)
861 fix_compoundnum( TSD
, thisptr
->p
[0], ntmp
, preferred_str
);
865 setshortcutnum( TSD
, thisptr
->p
[0], ntmp
, preferred_str
);
872 /* This is a CMS-ism; CMS allows the expression in an assignment to
873 * be omitted, while TRL does _not_. If a CMS mode is implemented, the
874 * code below should be changed to allow p[0] to be null only iff
875 * CMS mode is active.
879 value
= thisptr
->p
[1] ? evaluate(TSD
,thisptr
->p
[1],NULL
) : nullstringptr() ;
880 if (thisptr
->p
[0]->type
==X_HEAD_SYMBOL
)
881 fix_compound( TSD
, thisptr
->p
[0], value
) ;
883 setshortcut( TSD
, thisptr
->p
[0], value
) ;
889 streng
*retval
, *tptr
= evaluate(TSD
,thisptr
->p
[0],NULL
) ;
890 retval
= dointerpret( TSD
, tptr
) ;
891 if (retval
!= NULL
) /* we interpreted a RETURN WITH a value */
893 stackelem
*top
= stacktop(TSD
);
895 for (i
= stacktrigger(TSD
);i
> stktrigger
;i
--,top
= top
->prev
)
897 if (top
->increment
== s
.increment
)
899 if (top
->stopval
== s
.stopval
)
903 stackcleanup(TSD
,stktrigger
);
904 nstackcleanup(TSD
,nstktrigger
,NULL
);
911 exiterror( ERR_WHEN_EXPECTED
, 0 ) ;
915 nstackpush(TSD
,thisptr
->next
);
916 nstackpush(TSD
,thisptr
->p
[1]);
917 thisptr
= thisptr
->p
[0] ;
922 int retval
= isboolean( TSD
, thisptr
->p
[0], 2, NULL
);
924 if ( TSD
->trace_stat
!= 'O' && TSD
->trace_stat
!= 'N' && TSD
->trace_stat
!= 'F' )
926 n
= thisptr
->p
[0]->next
;
927 while ( n
!= NULL
) {
928 traceline( TSD
, n
, TSD
->trace_stat
, 0 );
934 nstackpop(TSD
); /* kill the OTHERWISE on the stack */
935 thisptr
= thisptr
->p
[1] ;
944 streng
*stringen
,*kill
=NULL
;
947 stringen
= evaluate( TSD
, thisptr
->p
[0], &kill
);
951 if (TSD
->systeminfo
->hooks
& HOOK_MASK(HOOK_STDOUT
))
952 ok
= hookup_output( TSD
, HOOK_STDOUT
, stringen
) ;
960 * Due to a bug in Windows that gives an error
961 * if you try to write too many characters to the
962 * console in one attempt, split the output
966 char *buf
= stringen
->value
;
968 long todo
= Str_len(stringen
);
971 chunk
= min( todo
, 0x8000);
972 done
= fwrite( buf
, chunk
, 1, stdout
) ;
975 } while ( todo
> 0 ) ;
977 fwrite( stringen
->value
, Str_len(stringen
), 1, stdout
) ;
980 #if defined(DOS) || defined(OS2) || defined(WIN32)
982 * stdout is open in binary mode, so we need to add the
983 * extra CR to the end of the line.
985 fputc( REGINA_CR
, stdout
) ;
987 fputc( REGINA_EOL
, stdout
) ;
991 if (stringen
&& kill
)
992 Free_stringTSD( kill
);
1001 if (!TSD
->systeminfo
->trace_override
)
1004 set_trace( TSD
, thisptr
->name
) ;
1005 else if (thisptr
->p
[0])
1007 set_trace( TSD
, evaluate(TSD
,thisptr
->p
[0], &tptr
) );
1009 Free_stringTSD( tptr
) ;
1012 exiterror( ERR_INTERPRETER_FAILURE
, 1, __FILE__
, __LINE__
, "" ) ;
1022 if ( thisptr
->p
[0] )
1023 result
= evaluate( TSD
, thisptr
->p
[0], NULL
);
1027 TSD
->instore_is_errorfree
= 1;
1028 jump_script_exit( TSD
, result
);
1037 update_envirs( TSD
, TSD
->currlevel
) ;
1040 /* bja - added Free_stringTSD() around perform() */
1041 stmp
= evaluate( TSD
, thisptr
->p
[0], &kill
);
1042 Free_stringTSD(perform(TSD
, stmp
, TSD
->currlevel
->environment
, thisptr
, NULL
)) ;
1044 Free_stringTSD( kill
);
1049 case X_ADDR_N
: /* ADDRESS environment [expr] */
1051 streng
*envir
,*tmp
,*kill
;
1052 update_envirs( TSD
, TSD
->currlevel
) ;
1053 envir
= thisptr
->name
;
1057 * This path is executed when the command is:
1058 * ADDRESS env [command] WITH [expr]
1059 * ie. executing a command
1061 /* bja - added Free_stringTSD() around perform() */
1062 /* the IO-redirection is temporarily in this case. */
1063 tmp
= evaluate( TSD
, thisptr
->p
[0], &kill
);
1064 Free_stringTSD(perform(TSD
, tmp
, envir
, thisptr
, thisptr
->p
[1]));
1066 Free_stringTSD( kill
) ;
1071 * This path is executed when the command is:
1072 * ADDRESS env WITH [expr]
1073 * ie. setting the default address, but not executing anything
1075 set_envir( TSD
, envir
, thisptr
->p
[1] ) ;
1076 Free_stringTSD( TSD
->currlevel
->prev_env
) ;
1077 TSD
->currlevel
->prev_env
= TSD
->currlevel
->environment
;
1078 TSD
->currlevel
->environment
= Str_dupTSD(envir
) ;
1084 case X_ADDR_V
: /* ADDRESS [VALUE] expr */
1088 if ( thisptr
->u
.nonansi
&&
1089 get_options_flag( TSD
->currlevel
, EXT_STRICT_ANSI
) )
1090 exiterror( ERR_NON_ANSI_FEATURE
, 2, "ADDRESS \"(\"...\")\"") ;
1092 update_envirs( TSD
, TSD
->currlevel
) ;
1093 cptr
= evaluate(TSD
,thisptr
->p
[0],NULL
) ;
1094 set_envir( TSD
, cptr
, thisptr
->p
[1] ) ;
1095 Free_stringTSD( TSD
->currlevel
->prev_env
) ;
1096 TSD
->currlevel
->prev_env
= TSD
->currlevel
->environment
;
1097 TSD
->currlevel
->environment
= cptr
;
1102 case X_ADDR_S
: /* ADDRESS */
1106 update_envirs( TSD
, TSD
->currlevel
) ;
1107 tptr
= TSD
->currlevel
->environment
;
1108 TSD
->currlevel
->environment
= TSD
->currlevel
->prev_env
;
1109 TSD
->currlevel
->prev_env
= tptr
;
1117 for (nptr
=thisptr
->p
[0]; nptr
; nptr
=nptr
->p
[0] )
1121 if (nptr
->type
== X_SIM_SYMBOL
)
1123 drop_var( TSD
, nptr
->name
) ;
1127 if (nptr
->type
== X_IND_SYMBOL
)
1131 const streng
*value
= shortcut(TSD
,nptr
) ;
1133 /* Chop space separated words and drop them one by one */
1136 begin
= end
; /* end of last word processed + 1 */
1137 while ((begin
< Str_len(value
)) &&
1138 rx_isspace(value
->value
[begin
]))
1140 if (begin
== Str_len(value
))
1142 end
= begin
+ 1; /* find next separator */
1143 while ((end
< Str_len(value
)) &&
1144 !rx_isspace(value
->value
[end
]))
1146 /* end now on space after word or past end of string */
1147 name
= Str_makeTSD(end
- begin
);
1148 name
->len
= end
- begin
;
1149 memcpy(name
->value
, value
->value
+ begin
, Str_len(name
));
1151 drop_var( TSD
, name
) ;
1152 Free_stringTSD( name
) ;
1164 * If we are running in STRICT_ANSI mode, disallow this
1166 * Copy the code above for DROP.
1167 * Need to cause error if stem variable is specified
1168 * Need to handle NOVALUE
1172 if ( get_options_flag( TSD
->currlevel
, EXT_STRICT_ANSI
) )
1173 exiterror( ERR_NON_ANSI_FEATURE
, 2, "UPPER" ) ;
1174 for (nptr
=thisptr
->p
[0]; nptr
; nptr
=nptr
->p
[0] )
1178 if (nptr
->type
== X_SIM_SYMBOL
)
1180 upper_var( TSD
, nptr
->name
) ;
1184 if (nptr
->type
== X_IND_SYMBOL
)
1188 const streng
*value
= shortcut(TSD
,nptr
) ;
1190 /* Chop space separated words and drop them one by one */
1193 begin
= end
; /* end of last word processed + 1 */
1194 while ((begin
< Str_len(value
)) &&
1195 rx_isspace(value
->value
[begin
]))
1197 if (begin
== Str_len(value
))
1199 end
= begin
+ 1; /* find next separator */
1200 while ((end
< Str_len(value
)) &&
1201 !rx_isspace(value
->value
[end
]))
1203 /* end now on space after word or past end of string */
1204 name
= Str_makeTSD(end
- begin
);
1205 name
->len
= end
- begin
;
1206 memcpy(name
->value
, value
->value
+ begin
, Str_len(name
));
1208 upper_var( TSD
, name
) ;
1209 Free_stringTSD( name
) ;
1222 trap
*traps
= gettraps( TSD
, TSD
->currlevel
) ;
1224 /* which kind of condition is this? */
1225 type
= identify_trap( thisptr
->p
[1]->type
) ;
1227 /* We always set this */
1228 traps
[type
].invoked
= (thisptr
->type
== X_SIG_SET
) ;
1229 traps
[type
].delayed
= 0 ;
1230 traps
[type
].on_off
= (thisptr
->p
[0]->type
== X_ON
) ;
1232 /* set the name of the variable to work on */
1233 FREE_IF_DEFINED( TSD
, traps
[type
].name
) ;
1235 traps
[type
].name
= Str_dupTSD( thisptr
->name
) ;
1236 else if (thisptr
->p
[0]->type
== X_ON
)
1237 traps
[type
].name
= Str_creTSD( signalnames
[type
] ) ;
1245 streng
*cptr
, *kill
=NULL
;
1246 volatile char *tmp_str
;
1250 cptr
= (thisptr
->name
) ? thisptr
->name
: evaluate( TSD
, thisptr
->p
[0], &kill
);
1251 nstackcleanup( TSD
, nstktrigger
, NULL
);
1252 top
= stacktop( TSD
);
1253 for ( i
= stacktrigger( TSD
); i
> stktrigger
; i
--, top
= top
->prev
)
1255 if ( top
->increment
== s
.increment
)
1257 if ( top
->stopval
== s
.stopval
)
1261 stackcleanup( TSD
, stktrigger
);
1267 set_reserved_value( TSD
, POOL0_SIGL
, NULL
, thisptr
->lineno
, VFLAG_NUM
);
1268 entry
= getlabel( TSD
, cptr
);
1270 * We have to make a temporary copy of the label we are signalling
1271 * in case it doesn't exist because the "kill" processing will destroy
1274 tmp_str
= tmpstr_of( TSD
, cptr
);
1277 Free_stringTSD( kill
);
1279 if ( entry
== NULL
)
1280 exiterror( ERR_UNEXISTENT_LABEL
, 1, tmp_str
);
1281 if ( entry
->u
.trace_only
)
1282 exiterror( ERR_UNEXISTENT_LABEL
, 2, tmpstr_of( TSD
, entry
->name
) );
1283 thisptr
= entry
->next
;
1290 if (TSD
->currlevel
->varflag
)
1291 exiterror( ERR_UNEXPECTED_PROC
, 1 ) ;
1293 for (ptr
=thisptr
->p
[0];(ptr
);ptr
=ptr
->p
[0])
1297 expose_var(TSD
,ptr
->name
) ;
1298 if (ptr
->type
==X_IND_SYMBOL
)
1299 expose_indir( TSD
, getvalue( TSD
, ptr
->name
, -1 ) );
1301 assert( ptr
->type
==X_SIM_SYMBOL
) ;
1304 exiterror( ERR_INTERPRETER_FAILURE
, 1, __FILE__
, __LINE__
, "" ) ;
1306 expose_var(TSD
,NULL
) ;
1314 * Find an internal label matching the label on the CALL
1315 * statement, and determine if its in internal of external
1318 n
= getlabel( TSD
, thisptr
->name
);
1321 if ( n
->u
.trace_only
)
1322 exiterror( ERR_UNEXISTENT_LABEL
, 3, tmpstr_of( TSD
, n
->name
) );
1323 thisptr
->type
= X_IS_INTERNAL
;
1326 thisptr
->type
= X_IS_BUILTIN
;
1327 thisptr
->u
.node
= n
;
1328 thisptr
->o
.called
= 1;
1330 /* THIS IS MEANT TO FALL THROUGH! */
1336 if ( thisptr
->u
.node
)
1338 no_next_interactive
= 1;
1339 args
= initplist( TSD
, thisptr
);
1340 set_reserved_value( TSD
, POOL0_SIGL
, NULL
, thisptr
->lineno
, VFLAG_NUM
);
1342 result
= CallInternalFunction( TSD
, thisptr
->u
.node
, thisptr
, args
);
1344 TSD
->systeminfo
->interactive
= TSD
->currlevel
->traceint
;
1346 set_reserved_value( TSD
, POOL0_RESULT
, result
, 0,
1347 ( result
) ? VFLAG_STR
: VFLAG_NONE
);
1351 /* THIS IS MEANT TO FALL THROUGH! */
1357 if ((result
= buildtinfunc( TSD
, thisptr
)) == NOFUNC
)
1359 thisptr
->type
= X_IS_EXTERNAL
;
1363 set_reserved_value( TSD
, POOL0_RESULT
, result
, 0,
1364 ( result
) ? VFLAG_STR
: VFLAG_NONE
);
1369 /* THIS IS MEANT TO FALL THROUGH! */
1372 streng
*ptr
, *command
;
1373 paramboxptr args
, targs
;
1376 if ( TSD
->restricted
)
1377 exiterror( ERR_RESTRICTED
, 5 );
1379 update_envirs( TSD
, TSD
->currlevel
);
1381 args
= targs
= initplist( TSD
, thisptr
);
1382 stackmark
= pushcallstack( TSD
, TSD
->currentnode
);
1383 ptr
= execute_external( TSD
,
1386 TSD
->systeminfo
->environment
,
1388 /* Fixes bug 604219 */
1389 TSD
->systeminfo
->hooks
,
1391 popcallstack( TSD
, stackmark
);
1393 if ( ptr
== thisptr
->name
)
1396 * FIXME,MH: no idea what this does
1397 * FGC: agreed, added an assert. Remove this block in
1398 * complete in 2005 if nothing happens.
1404 if ( err
== -ERR_PROG_UNREADABLE
)
1407 * "thisptr->name" wasn't an external Rexx program, so
1408 * see if it is an OS command
1409 * Only do this if the OPTIONS EXT_COMMANDS_AS_FUNCS is
1410 * set and STRICT_ANSI is NOT set.
1412 if ( get_options_flag( TSD
->currlevel
, EXT_EXT_COMMANDS_AS_FUNCS
)
1413 && !get_options_flag( TSD
->currlevel
, EXT_STRICT_ANSI
) )
1415 len
= Str_len( thisptr
->name
);
1416 for( targs
= args
; targs
; targs
= targs
->next
)
1419 len
+= 1 + Str_len( targs
->value
);
1421 command
= Str_makeTSD( len
);
1422 command
= Str_catTSD( command
, thisptr
->name
);
1423 for( targs
= args
; targs
; targs
= targs
->next
)
1427 command
= Str_catstrTSD( command
, " " );
1428 command
= Str_catTSD( command
, targs
->value
);
1431 ptr
= run_popen( TSD
, command
, TSD
->currlevel
->environment
);
1434 Free_stringTSD( command
);
1438 deallocplink( TSD
, args
);
1440 if ( ptr
&& ( TSD
->trace_stat
== 'I' ) )
1441 tracevalue( TSD
, ptr
, 'F' );
1444 set_reserved_value( TSD
, POOL0_RESULT
, ptr
, 0, VFLAG_STR
);
1446 set_reserved_value( TSD
, POOL0_RESULT
, NULL
, 0, VFLAG_NONE
);
1448 if ( err
== -ERR_PROG_UNREADABLE
)
1450 exiterror( ERR_ROUTINE_NOT_FOUND
, 1, tmpstr_of( TSD
, thisptr
->name
) );
1454 post_process_system_call( TSD
, thisptr
->name
, -err
, NULL
, thisptr
);
1463 * We always have to produce a duplicate of the content we have to
1464 * parse. We can't use variable locking and we can't assume that
1465 * the content doesn't contain variable names used in the template.
1466 * This fixes bug 688503.
1469 if ( thisptr
->u
.parseflags
& ( PARSE_LOWER
| PARSE_CASELESS
) )
1471 if ( get_options_flag( TSD
->currlevel
, EXT_STRICT_ANSI
) )
1472 exiterror( ERR_NON_ANSI_FEATURE
, 2,
1473 ( thisptr
->u
.parseflags
& PARSE_LOWER
) ? "PARSE LOWER" :
1474 "PARSE CASELESS" ) ;
1476 if ( thisptr
->p
[0]->type
== X_PARSE_ARG
)
1478 parseargtree( TSD
, TSD
->currlevel
->args
, thisptr
->p
[1],
1479 thisptr
->u
.parseflags
);
1483 streng
*source
= NULL
;
1486 switch ( thisptr
->p
[0]->type
)
1489 /* must duplicate, parsing may have side effects */
1490 /* else, we must have locking of variables */
1491 source
= Str_dupTSD( shortcut( TSD
, thisptr
->p
[0] ) );
1497 * Must duplicate, parsing may have side effects, we must
1498 * have locking of variables otherwise.
1502 * Empty value allowed.
1505 if ( thisptr
->p
[0]->p
[0] )
1506 source
= evaluate( TSD
, thisptr
->p
[0]->p
[0], NULL
);
1508 source
= nullstringptr();
1513 source
= popline( TSD
, NULL
, NULL
, 0 );
1517 source
= Str_creTSD( PARSE_VERSION_STRING
);
1521 source
= readkbdline( TSD
);
1529 stype
= system_type();
1530 inpfile
= TSD
->systeminfo
->input_file
;
1531 source
= Str_makeTSD( strlen( stype
) + 4 +
1532 strlen( invo_strings
[TSD
->systeminfo
->invoked
] ) +
1533 Str_len( inpfile
) );
1536 Str_catstrTSD( source
, stype
);
1537 Str_catstrTSD( source
, " " );
1538 Str_catstrTSD( source
, invo_strings
[TSD
->systeminfo
->invoked
] );
1539 Str_catstrTSD( source
, " " );
1540 Str_catTSD( source
, inpfile
);
1545 if ( thisptr
->u
.parseflags
& PARSE_UPPER
)
1547 Str_upper( source
);
1549 if ( thisptr
->u
.parseflags
& PARSE_LOWER
)
1551 Str_lower( source
);
1554 doparse( TSD
, source
, thisptr
->p
[1],
1555 thisptr
->u
.parseflags
& PARSE_CASELESS
);
1557 for ( templ
= thisptr
->p
[1]->next
; templ
!= NULL
; templ
= templ
->next
)
1560 * This fixes bug 755801.
1561 * Actually, this will happen rarely, but we have to assign the
1562 * empty string to all template members of all comma-separated
1563 * lists of templates except of the first one.
1564 * We use the slow and long-term reliable code of doparse().
1566 Str_len( source
) = 0;
1567 doparse( TSD
, source
, templ
, 0 );
1571 Free_stringTSD( source
);
1580 doparse(TSD
, stmp
=Str_upper(popline( TSD
, NULL
, NULL
, 0 )), thisptr
->p
[0], 0 ) ;
1581 Free_stringTSD( stmp
) ;
1586 stack_lifo( TSD
, (thisptr
->p
[0]) ? evaluate(TSD
,thisptr
->p
[0],NULL
) : nullstringptr(), NULL
) ;
1590 stack_fifo( TSD
, (thisptr
->p
[0]) ? evaluate(TSD
,thisptr
->p
[0],NULL
) : nullstringptr(), NULL
) ;
1593 case X_OPTIONS
: /* fixes 1116894 */
1594 do_options(TSD
, TSD
->currlevel
, (thisptr
->p
[0]) ? evaluate(TSD
,thisptr
->p
[0],NULL
) : nullstringptr(), 0) ;
1603 /* buggy, need to deallocate procbox and vars ... */
1605 retval
= evaluate(TSD
,thisptr
->p
[0],NULL
) ;
1609 top
= stacktop(TSD
);
1610 for (i
= stacktrigger(TSD
);i
> stktrigger
;i
--,top
= top
->prev
)
1612 if (top
->increment
== s
.increment
)
1614 if (top
->stopval
== s
.stopval
)
1618 stackcleanup(TSD
,stktrigger
);
1619 nstackcleanup(TSD
,nstktrigger
,NULL
);
1630 Stacked
= stacktrigger(TSD
) - stktrigger
;
1633 { /* push the current count to let it been found below if "LEAVE name". */
1634 s
.thisptr
= innerloop
;
1635 stackpush( TSD
, &s
);
1639 top
= stacktop(TSD
);
1640 for ( ;; ) /* while iteration counter name not found */
1645 exiterror( ERR_INVALID_LEAVE
, (thisptr
->type
==X_LEAVE
)?3:4, tmpstr_of( TSD
, thisptr
->name
) );
1647 exiterror( ERR_INVALID_LEAVE
, (thisptr
->type
==X_LEAVE
)?1:2 );
1650 iptr
= top
->thisptr
;
1652 if ( thisptr
->name
== NULL
)
1655 * LEAVE/ITERATE without any argument. Automatically pop one
1656 * stack element later.
1662 * Backtrace all pending loops and compare the iterator name if
1663 * one exists. We have to keep care for unnamed loops like
1664 * "do 5 ; say fred ; end".
1666 if ( ( iptr
->p
[0] != NULL
) &&
1667 ( iptr
->p
[0]->name
!= NULL
) &&
1668 ( Str_cmp( thisptr
->name
, iptr
->p
[0]->name
) == 0 ) )
1671 * Iterator name equals our argument. Automatically pop one
1672 * stack element later.
1678 * Unnamed loop or a loop with a nonmatching name, cleanup!
1681 popcallstack( TSD
, -1 );
1682 if ( top
->stopval
== s
.stopval
)
1684 if ( top
->increment
== s
.increment
)
1686 stack_destroyelement( TSD
, top
);
1692 nstackcleanup(TSD
,nstktrigger
,&iptr
);
1695 exiterror( ERR_INVALID_LEAVE
, 0 );
1696 if (thisptr
->type
==X_LEAVE
)
1698 popcallstack(TSD
,-1) ;
1699 if (top
->stopval
== s
.stopval
)
1701 if ( top
->increment
== s
.increment
)
1702 s
.increment
= NULL
;
1703 stack_destroyelement(TSD
,top
);
1709 if ( TSD
->trace_stat
!= 'O' && TSD
->trace_stat
!= 'N' && TSD
->trace_stat
!= 'F' )
1710 traceline( TSD
, iptr
, TSD
->trace_stat
, 0 );
1711 stackcleanup(TSD
,stktrigger
+ Stacked
);
1713 if (TSD
->systeminfo
->interactive
)
1715 if (intertrace(TSD
))
1719 thisptr
= nstackpop(TSD
);
1724 innerloop
= s
.thisptr
;
1735 volatile char *err
;
1737 cptr
= evaluate( TSD
, thisptr
->p
[0], &kill
);
1738 tmp
= streng_to_int( TSD
, cptr
, &error
);
1739 if ( error
|| tmp
< 0 )
1741 err
= tmpstr_of( TSD
, cptr
);
1743 Free_stringTSD( kill
);
1744 exiterror( ERR_INVALID_INTEGER
, 5, err
) ;
1747 Free_stringTSD( kill
);
1748 if (TSD
->currlevel
->numfuzz
>= tmp
)
1749 exiterror( ERR_INVALID_RESULT
, 1, tmp
, TSD
->currlevel
->numfuzz
);
1752 * Remove unneccessary limitaion on numeric digits as suggested by
1755 if (tmp
> MAXNUMERIC
)
1756 exiterror( ERR_INVALID_RESULT
, 2, tmp
, MAXNUMERIC
) ;
1758 TSD
->currlevel
->currnumsize
= tmp
;
1763 if (TSD
->currlevel
->numfuzz
>= DEFAULT_NUMERIC_SIZE
)
1764 exiterror( ERR_INVALID_RESULT
, 1, DEFAULT_NUMERIC_SIZE
, TSD
->currlevel
->numfuzz
) ;
1765 TSD
->currlevel
->currnumsize
= DEFAULT_NUMERIC_SIZE
;
1769 if (TSD
->currlevel
->currnumsize
<= DEFAULT_NUMERIC_FUZZ
)
1770 exiterror( ERR_INVALID_RESULT
, 1, TSD
->currlevel
->currnumsize
, DEFAULT_NUMERIC_FUZZ
) ;
1771 TSD
->currlevel
->numfuzz
= DEFAULT_NUMERIC_FUZZ
;
1775 TSD
->currlevel
->numfuzz
= DEFAULT_NUMFORM
;
1782 volatile char *err
;
1784 cptr
= evaluate( TSD
, thisptr
->p
[0], &kill
);
1785 tmp
= streng_to_int( TSD
, cptr
, &error
);
1786 if ( error
|| tmp
< 0 )
1788 err
= tmpstr_of( TSD
, cptr
);
1790 Free_stringTSD( kill
);
1791 exiterror( ERR_INVALID_INTEGER
, 6, err
) ;
1794 Free_stringTSD( kill
);
1795 if (TSD
->currlevel
->currnumsize
<= tmp
)
1796 exiterror( ERR_INVALID_RESULT
, 1, TSD
->currlevel
->currnumsize
, tmp
) ;
1797 TSD
->currlevel
->numfuzz
= tmp
;
1803 if (thisptr
->p
[0]->type
== X_NUM_SCI
)
1804 TSD
->currlevel
->numform
= NUM_FORM_SCI
;
1805 else if (thisptr
->p
[0]->type
== X_NUM_ENG
)
1806 TSD
->currlevel
->numform
= NUM_FORM_ENG
;
1814 streng
*tmpstr
,*kill
;
1818 tmpstr
= evaluate( TSD
, thisptr
->p
[0], &kill
);
1822 if ( ( len
== 10 ) && ( mem_cmpic( s
, "SCIENTIFIC", 10 ) == 0 ) )
1823 TSD
->currlevel
->numform
= NUM_FORM_SCI
;
1824 else if ( ( len
== 11 ) && ( mem_cmpic( s
, "ENGINEERING", 11 ) == 0 ) )
1825 TSD
->currlevel
->numform
= NUM_FORM_ENG
;
1826 else if ( ( len
== 1 ) && ( rx_toupper( *s
) == 'S' ) )
1827 TSD
->currlevel
->numform
= NUM_FORM_SCI
;
1828 else if ( ( len
== 1 ) && ( rx_toupper( *s
) == 'E' ) )
1829 TSD
->currlevel
->numform
= NUM_FORM_ENG
;
1831 exiterror( ERR_INVALID_RESULT
, 0 ) ;
1833 Free_stringTSD( kill
);
1842 exiterror( ERR_INTERPRETER_FAILURE
, 1, __FILE__
, __LINE__
, "" ) ;
1846 if ((TSD
->systeminfo
->interactive
)&&(!no_next_interactive
))
1848 if (intertrace(TSD
))
1852 no_next_interactive
= 0 ;
1855 thisptr
= thisptr
->next
;
1860 if (nstacktrigger(TSD
) <= nstktrigger
)
1862 stackcleanup(TSD
,stktrigger
);
1866 thisptr
= nstackpop(TSD
);
1871 /* check if there is any traps to process */
1872 while (TSD
->nextsig
)
1874 trap
*traps
= gettraps( TSD
, TSD
->currlevel
) ;
1876 i
= TSD
->nextsig
->type
;
1878 if (i
== SIGNAL_NOTREADY
)
1879 fixup_file( TSD
, TSD
->nextsig
->descr
) ;
1881 /* if this condition is in delayed mode, ignore it for now */
1882 if (traps
[i
].delayed
)
1885 /* if this condition is no begin trapped, use default action */
1886 if (traps
[i
].on_off
== 0)
1888 if (traps
[i
].def_act
)
1889 goto aftersignals
; /* default==1 ==> ignore it */
1891 exiterror( TSD
->nextsig
->rc
, 0 ) ;
1893 if (traps
[i
].invoked
) /* invoke as SIGNAL */
1895 /* simulate a SIGNAL, first empty the stack */
1896 /* Sorry, not safe to operate on these at this point, we just have to
1897 accept that some memory is lost ... "can't make omelette without..." */
1899 * for (stkidx--;stkidx;stkidx--)
1901 * FREE_IF_DEFINED(TSD,stack[stkidx].increment) ;
1902 * FREE_IF_DEFINED(TSD,stack[stkidx].stopval) ;
1904 */ /* hey, this should really be ok, .... must be a BUG */
1905 stackcleanup(TSD
,stktrigger
); /* think it, too. stackcleanup
1906 * (re-)introduced Feb. 2000 */
1908 /* turn off the condition */
1909 traps
[i
].on_off
= 0 ;
1910 traps
[i
].delayed
= 0 ;
1911 /* traps[i].trapped = 0 ; */
1913 /* set the current condition information */
1914 if (TSD
->currlevel
->sig
)
1916 FREE_IF_DEFINED( TSD
, TSD
->currlevel
->sig
->info
) ;
1917 FREE_IF_DEFINED( TSD
, TSD
->currlevel
->sig
->descr
) ;
1918 FreeTSD( TSD
->currlevel
->sig
) ;
1920 TSD
->currlevel
->sig
= TSD
->nextsig
;
1921 TSD
->nextsig
= NULL
;
1923 /* simulate the SIGNAL statement */
1924 entry
= getlabel( TSD
, traps
[i
].name
) ;
1925 set_reserved_value( TSD
, POOL0_SIGL
, NULL
,
1926 TSD
->currlevel
->sig
->lineno
, VFLAG_NUM
);
1927 if (TSD
->currlevel
->sig
->type
== SIGNAL_SYNTAX
)
1928 set_reserved_value( TSD
, POOL0_RC
, NULL
, TSD
->currlevel
->sig
->rc
,
1931 if ( entry
== NULL
)
1932 exiterror( ERR_UNEXISTENT_LABEL
, 1, tmpstr_of( TSD
, traps
[i
].name
) );
1933 if ( entry
->u
.trace_only
)
1934 exiterror( ERR_UNEXISTENT_LABEL
, 2, tmpstr_of( TSD
, entry
->name
) );
1936 nstackcleanup( TSD
, nstktrigger
, NULL
);
1939 else /*if ((i<SIGNALS))*/ /* invoke as CALL */
1941 nodeptr savecurrentnode
; /* pgb */
1944 if ( ( entry
= getlabel( TSD
, traps
[i
].name
) ) == NULL
)
1945 exiterror( ERR_UNEXISTENT_LABEL
, 1, tmpstr_of( TSD
, traps
[i
].name
) );
1946 if ( entry
->u
.trace_only
)
1947 exiterror( ERR_UNEXISTENT_LABEL
, 3, tmpstr_of( TSD
, entry
->name
) );
1949 traps
[i
].delayed
= 1;
1951 set_reserved_value( TSD
, POOL0_SIGL
, NULL
, TSD
->nextsig
->lineno
,
1953 oldlevel
= TSD
->currlevel
;
1954 TSD
->currlevel
= newlevel( TSD
, TSD
->currlevel
);
1955 TSD
->currlevel
->sig
= TSD
->nextsig
;
1956 TSD
->nextsig
= NULL
;
1958 stackmark
= pushcallstack( TSD
, thisptr
);
1959 if ( TSD
->trace_stat
!= 'O' && TSD
->trace_stat
!= 'N' && TSD
->trace_stat
!= 'F' )
1960 traceline( TSD
, entry
, TSD
->trace_stat
, 0 );
1962 savecurrentnode
= TSD
->currentnode
; /* pgb */
1963 h
= interpret( TSD
, entry
->next
);
1965 Free_stringTSD( h
);
1966 TSD
->currentnode
= savecurrentnode
; /* pgb */
1968 traps
[i
].delayed
= 0;
1969 popcallstack( TSD
, stackmark
);
1970 removelevel( TSD
, TSD
->currlevel
);
1971 TSD
->currlevel
= oldlevel
;
1972 TSD
->currlevel
->next
= NULL
;
1973 TSD
->trace_stat
= TSD
->currlevel
->tracestat
;
1974 TSD
->systeminfo
->interactive
= TSD
->currlevel
->traceint
; /* MDW 30012002 */
1984 /* getlabel searches for a label (procedure) in the current rexx program.
1985 * The label is case-insensitively searched. Its name must be name. The first
1986 * name found matches. The returned value is either NULL or the node of the
1988 * This function uses a lazy evaluation mechanism and creates from the linked
1989 * list an array. The hash value of each entry is generated during the copy.
1990 * This function may become faster or much faster if the array is sorted
1991 * by the hashvalue which allows a bsearch() call. But, and this is the
1992 * problem, it is useful only if labels are search often and the number of
1993 * labels are more than a few. I think, external functions which are registered
1994 * in huge amounts are better candidates for this.
1996 nodeptr
getlabel( const tsd_t
*TSD
, const streng
*name
)
1998 labelboxptr lptr
, h
;
1999 internal_parser_type
*ipt
= &TSD
->systeminfo
->tree
;
2002 if (ipt
->sort_labels
== NULL
)
2004 if (ipt
->first_label
== NULL
)
2007 ipt
->sort_labels
= (labelboxptr
)MallocTSD(ipt
->numlabels
* sizeof(ipt
->sort_labels
[0]));
2008 for (i
= 0, lptr
= ipt
->first_label
;i
< ipt
->numlabels
;i
++)
2010 lptr
->hash
= hashvalue_ic(lptr
->entry
->name
->value
, lptr
->entry
->name
->len
);
2011 ipt
->sort_labels
[i
] = *lptr
;
2016 ipt
->first_label
= ipt
->last_label
= NULL
;
2019 hash
= hashvalue_ic(name
->value
, name
->len
);
2020 for (i
= 0;i
< ipt
->numlabels
;i
++)
2022 if (hash
!= ipt
->sort_labels
[i
].hash
)
2024 if (Str_ccmp(ipt
->sort_labels
[i
].entry
->name
, name
) == 0)
2025 return(ipt
->sort_labels
[i
].entry
);
2031 void removelevel( tsd_t
*TSD
, proclevel level
)
2037 removelevel( TSD
, level
->next
) ;
2038 /* level->next = NULL; */
2041 if (level
->varflag
==1) /* does not belong *here* !!! */
2042 kill_variables( TSD
, level
->vars
) ;
2045 deallocplink( TSD
, level
->args
) ;
2047 if (level
->environment
)
2048 Free_stringTSD( level
->environment
) ;
2050 if (level
->prev_env
)
2051 Free_stringTSD( level
->prev_env
) ;
2054 level
->prev
->next
= NULL
;
2056 FREE_IF_DEFINED( TSD
, level
->signal_continue
);
2060 FREE_IF_DEFINED( TSD
, level
->sig
->info
) ;
2061 FREE_IF_DEFINED( TSD
, level
->sig
->descr
) ;
2062 FreeTSD( level
->sig
) ;
2067 for (i
=0; i
<SIGNALS
; i
++)
2068 FREE_IF_DEFINED( TSD
, level
->traps
[i
].name
) ;
2070 FreeTSD( level
->traps
) ;
2078 * NOTE: The ->buf variable is not set here, It must be set. When
2079 * an old level is duplicated, the old ->buf is also duplicated,
2080 * but DO_NO_USE_IT, since it will point to the reentring point
2081 * of the mother-routine
2083 proclevel
newlevel( tsd_t
*TSD
, proclevel oldlevel
)
2085 itp_tsd_t
*it
= (itp_tsd_t
*)TSD
->itp_tsd
;
2091 level
= (proclevel
) MallocTSD( sizeof( proclevbox
) );
2093 if ( oldlevel
== NULL
)
2096 /* There is a memcpy below which Checker don't like. The reason
2097 * may be the aligned "char"s which will use one machine word
2098 * but are initialized simply by an assignment of one byte.
2099 * Checker sees 3 byte of uninitialized data --> error.
2100 * (Of course, this isn't an error.)
2101 * Always double-check the initializations below in case of
2105 memset( level
, 0, sizeof( proclevbox
) );
2107 level
->numfuzz
= DEFAULT_NUMERIC_FUZZ
;
2108 level
->currnumsize
= DEFAULT_NUMERIC_SIZE
;
2109 level
->numform
= DEFAULT_NUMFORM
;
2110 level
->rx_time
.sec
= 0;
2111 level
->rx_time
.usec
= 0;
2112 level
->mathtype
= DEFAULT_MATH_TYPE
;
2119 level
->options
= it
->options
;
2122 set_options_flag( level
, EXT_LINEOUTTRUNC
, DEFAULT_LINEOUTTRUNC
);
2123 set_options_flag( level
, EXT_FLUSHSTACK
, DEFAULT_FLUSHSTACK
);
2124 set_options_flag( level
, EXT_MAKEBUF_BIF
, DEFAULT_MAKEBUF_BIF
);
2125 set_options_flag( level
, EXT_DROPBUF_BIF
, DEFAULT_DROPBUF_BIF
);
2126 set_options_flag( level
, EXT_DESBUF_BIF
, DEFAULT_DESBUF_BIF
);
2127 set_options_flag( level
, EXT_BUFTYPE_BIF
, DEFAULT_BUFTYPE_BIF
);
2128 set_options_flag( level
, EXT_CACHEEXT
, DEFAULT_CACHEEXT
);
2129 set_options_flag( level
, EXT_PRUNE_TRACE
, DEFAULT_PRUNE_TRACE
);
2130 set_options_flag( level
, EXT_EXT_COMMANDS_AS_FUNCS
, DEFAULT_EXT_COMMANDS_AS_FUNCS
);
2131 set_options_flag( level
, EXT_STDOUT_FOR_STDERR
, DEFAULT_STDOUT_FOR_STDERR
);
2132 set_options_flag( level
, EXT_TRACE_HTML
, DEFAULT_TRACE_HTML
);
2133 set_options_flag( level
, EXT_FAST_LINES_BIF_DEFAULT
, DEFAULT_FAST_LINES_BIF_DEFAULT
);
2134 set_options_flag( level
, EXT_STRICT_ANSI
, DEFAULT_STRICT_ANSI
);
2135 set_options_flag( level
, EXT_INTERNAL_QUEUES
, DEFAULT_INTERNAL_QUEUES
);
2136 set_options_flag( level
, EXT_REGINA_BIFS
, DEFAULT_REGINA_BIFS
);
2137 set_options_flag( level
, EXT_STRICT_WHITE_SPACE_COMPARISONS
, DEFAULT_STRICT_WHITE_SPACE_COMPARISONS
);
2138 set_options_flag( level
, EXT_AREXX_SEMANTICS
, DEFAULT_AREXX_SEMANTICS
);
2139 set_options_flag( level
, EXT_AREXX_BIFS
, DEFAULT_AREXX_BIFS
);
2140 set_options_flag( level
, EXT_BROKEN_ADDRESS_COMMAND
, DEFAULT_BROKEN_ADDRESS_COMMAND
);
2141 set_options_flag( level
, EXT_CALLS_AS_FUNCS
, DEFAULT_CALLS_AS_FUNCS
);
2142 set_options_flag( level
, EXT_QUEUES_301
, DEFAULT_QUEUES_301
);
2143 set_options_flag( level
, EXT_HALT_ON_EXT_CALL_FAIL
, DEFAULT_HALT_ON_EXT_CALL_FAIL
);
2144 set_options_flag( level
, EXT_SINGLE_INTERPRETER
, DEFAULT_SINGLE_INTERPRETER
);
2145 set_options_flag( level
, EXT_RESULTS
, DEFAULT_RESULTS
);
2147 if ( ( str
= mygetenv( TSD
, "REGINA_OPTIONS", NULL
, 0 ) ) != NULL
)
2149 opts
= Str_creTSD( str
);
2151 do_options( TSD
, level
, opts
, 0 );
2154 it
->options
= level
->options
;
2158 level
->tracestat
= (char) TSD
->systeminfo
->tracing
;
2159 level
->traceint
= (char) TSD
->systeminfo
->interactive
;
2160 level
->environment
= Str_dupTSD( TSD
->systeminfo
->environment
);
2161 level
->prev_env
= Str_dupTSD( TSD
->systeminfo
->environment
);
2162 level
->vars
= create_new_varpool( TSD
, 0 );
2163 level
->signal_continue
= NULL
;
2165 level
->traps
= (trap
*)MallocTSD( sizeof(trap
) * SIGNALS
);
2168 memset( level
->traps
, 0, sizeof(trap
) * SIGNALS
);
2170 for (i
=0; i
<SIGNALS
; i
++)
2172 level
->traps
[i
].name
= NULL
;
2173 level
->traps
[i
].on_off
= 0;
2174 level
->traps
[i
].delayed
= 0;
2175 level
->traps
[i
].def_act
= default_action
[i
];
2176 level
->traps
[i
].ignored
= default_ignore
[i
];
2177 level
->traps
[i
].invoked
= 0;
2183 /* Stupid SunOS acc gives incorrect warning for the next line */
2184 memcpy( level
, oldlevel
, sizeof( proclevbox
) );
2186 level
->prev_env
= NULL
;
2187 level
->environment
= NULL
;
2189 level
->prev_env
= Str_dupTSD( oldlevel
->prev_env
);
2190 level
->environment
= Str_dupTSD( oldlevel
->environment
);
2192 level
->prev
= oldlevel
;
2194 oldlevel
->next
= level
;
2195 level
->signal_continue
= NULL
;
2197 /* level->next = NULL;*/
2199 level
->traps
= NULL
;
2203 TSD
->trace_stat
= level
->tracestat
;
2208 static void expose_indir( tsd_t
*TSD
, const streng
*list
)
2210 const char *cptr
=NULL
, *eptr
=NULL
, *sptr
=NULL
;
2213 cptr
= list
->value
;
2214 eptr
= cptr
+ list
->len
;
2215 tmp
= Str_makeTSD( 64 ) ;
2218 for (; cptr
<eptr
&& rx_isspace(*cptr
); cptr
++ ) ;
2219 for (sptr
=cptr
; cptr
<eptr
&& !rx_isspace(*cptr
); cptr
++ ) ;
2220 if (cptr
-sptr
>= 64)
2221 exiterror( ERR_TOO_LONG_STRING
, 0 ) ;
2225 memcpy( tmp
->value
, sptr
, cptr
-sptr
) ;
2226 tmp
->len
= cptr
-sptr
;
2227 /* need to uppercase each variable in the list!! */
2229 expose_var( TSD
, tmp
) ;
2231 Free_stringTSD( tmp
) ;
2236 * jump_rexx_signal should be used when a "SIGNAL ON" condition happens.
2237 * This function jumps to the previously assigned handler. This function
2238 * ensures a proper cleanup if the global lock flag "in_protected" is set.
2240 void jump_rexx_signal( tsd_t
*TSD
)
2242 if ( TSD
->in_protected
)
2245 * The lexer is running. We have to terminate him and let him do his
2246 * cleanup. After it, we'll be called again but without "in_protected".
2248 TSD
->delayed_error_type
= PROTECTED_DelayedRexxSignal
;
2249 longjmp( TSD
->protect_return
, 1 );
2251 longjmp( *TSD
->currlevel
->signal_continue
, 1 );
2256 * jump_interpreter_exit should be used when the whole interpreter should
2257 * terminate. This usually happens in case of a hard error or when the main
2260 * processExitCode tells the interpreter what return code shall be used on the
2263 * DON'T GET CONFUSED WITH jump_script_exit!
2265 * This function jumps to the previously assigned handler. This function
2266 * ensures a proper cleanup if the global lock flag "in_protected" is set.
2268 void jump_interpreter_exit( tsd_t
*TSD
, int processExitCode
)
2270 if ( TSD
->in_protected
)
2273 * The lexer is running. We have to terminate him and let him do his
2274 * cleanup. After it, we'll be called again but without "in_protected".
2276 TSD
->expected_exit_error
= processExitCode
;
2277 TSD
->delayed_error_type
= PROTECTED_DelayedInterpreterExit
;
2278 longjmp( TSD
->protect_return
, 1 );
2280 TSD
->MTExit( processExitCode
);
2285 * jump_script_exit should be used when a script ends or enters an EXIT
2288 * result tells the interpreter what return string shall be returned to the
2291 * DON'T GET CONFUSED WITH jump_interpreter_exit!
2293 * This function jumps to the previously assigned handler. This function
2294 * ensures a proper cleanup if the global lock flag "in_protected" is set.
2296 void jump_script_exit( tsd_t
*TSD
, streng
*result
)
2298 TSD
->systeminfo
->result
= result
;
2300 if ( TSD
->in_protected
&& TSD
->systeminfo
->script_exit
)
2303 * The lexer is running. We have to terminate him and let him do his
2304 * cleanup. After it, we'll be called again but without "in_protected".
2306 TSD
->delayed_error_type
= PROTECTED_DelayedScriptExit
;
2307 longjmp( TSD
->protect_return
, 1 );
2310 if ( !TSD
->systeminfo
->script_exit
)
2311 exiterror( ERR_INTERPRETER_FAILURE
, 1, __FILE__
, __LINE__
,
2312 "script EXIT not registered" );
2314 longjmp( *TSD
->systeminfo
->script_exit
, 1 );