#ifndef lint
static char *RCSid = "$Id: interpret.c,v 1.16 1993/05/10 06:17:35 anders Exp anders $";
#endif

/*
 *  The Regina Rexx Interpreter
 *  Copyright (C) 1992-1994  Anders Christensen <anders@pvv.unit.no>
 *
 *  This library is free software; you can redistribute it and/or
 *  modify it under the terms of the GNU Library General Public
 *  License as published by the Free Software Foundation; either
 *  version 2 of the License, or (at your option) any later version.
 *
 *  This library is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 *  Library General Public License for more details.
 *
 *  You should have received a copy of the GNU Library General Public
 *  License along with this library; if not, write to the Free
 *  Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 */

#include "rexx.h"
#include <stdio.h>
#include <ctype.h>
#include <string.h>
#ifndef VMS
# ifdef HAVE_UNISTD_H
#  include <unistd.h>
# endif
#endif
#ifdef HAVE_ASSERT_H
# include <assert.h>
#endif

#if defined(CRAY)
FILE *popen( char *command, char *access ) ;
#endif

#define XOR(a,b) (( (a) && (!(b)) )||( (!(a)) && (b) ))

#define OPTIMIZE

#define TRACELINE(a) if (trace_stat!='O' && trace_stat!='N') traceline(a,trace_stat,0)
#define TRACEVALUE(a,b) if (trace_stat=='I') tracevalue(a,b) 
#define TRACENUMBER(a,b) if (trace_stat=='I') tracenumber(a,b)

char default_action[SIGNALS] = { 1, 1, 0, 1, 1, 0 } ;
char default_ignore[SIGNALS] = { 1, 1, 0, 0, 1, 0 } ;


void expose_indir( streng *list ) ;
void do_options( streng *options, int ) ;

int totals=0 ;
streng *var_result=NULL ;
nodeptr nvar_rc=NULL, nvar_sigl=NULL ;
/* streng *command=NULL ; */
int trace_stat ;


typedef short *xxx ;

int xstrncasecmp( char *one, char *two, int length )
{
   for (; length>0; length-- ) 
   {
      if (toupper(*one) != toupper(*two))
         return (toupper(*one)-toupper(*two)) ;
      one++ ;
      two++ ;
   }
   return 0 ;
}

#ifdef TRACEMEM
void mark_spec_vars()
{
   markmemory( nvar_rc, TRC_SPCV_BOX ) ;
   markmemory( nvar_rc->name, TRC_SPCV_NAME ) ;

   markmemory( nvar_sigl, TRC_SPCV_BOX ) ;
   markmemory( nvar_sigl->name, TRC_SPCV_NAME ) ;

   markmemory( var_result, TRC_SPCV_NAME ) ;
}
#endif /* TRACEMEM */


void init_spec_vars( void )
{
   nvar_sigl = Malloc(sizeof(*nvar_sigl)) ;
   nvar_sigl->u.varbx = NULL ;
   nvar_sigl->name = Str_cre( "SIGL" ) ;
   nvar_sigl->type = X_SIM_SYMBOL ;

   nvar_rc = Malloc(sizeof(*nvar_rc)) ;
   nvar_rc->u.varbx = NULL ;
   nvar_rc->name = Str_cre( "RC" ) ;
   nvar_rc->type = X_SIM_SYMBOL ;

   var_result = Str_cre( "RESULT" ) ;

#ifdef TRACEMEM
   regmarker( mark_spec_vars ) ;
#endif
}


void update_envirs( proclevel level )
{
   proclevel lptr=NULL ;

   if (!level->environment)
      for (lptr=level->prev; lptr; lptr=lptr->prev)
         if (lptr->environment)
         {
            level->environment = Str_dup(lptr->environment) ;
            break ;
         }

   if (!level->prev_env)
      for (lptr=level->prev; lptr; lptr=lptr->prev)
         if (lptr->prev_env)
         {
            level->prev_env = Str_dup(lptr->prev_env) ;
            break ;
         }

   assert( level->environment ) ;
   assert( level->prev_env ) ;
}



nodeptr getlabel( streng *name ) ;
int hepp=0 ;
/*   
 * This routine is a huge beast, the best thing to say about it is that
 * it is nearly as bad as interpret()
 */


int guardnumber=1 ;


streng *interpret(treenode *this) 
{
   int i=0 ;
   int number=0 ;
   int stackmark=0 ;
   extern proclevel currlevel ;
   paramboxptr args=NULL ;
   extern nodeptr currentnode ;
   proclevel oldlevel=NULL ;
   void *increment=NULL, *stopval=NULL ;
   int incrdir=0 ;
   streng *result=NULL ;
   treenode *iptr=NULL, *entry=NULL, *ptr=NULL ;
   char *rexxaddstr() ;
   streng *chptr=NULL, *source=NULL ;
   static nodeptr tmpptr=NULL ;
   streng *retval=NULL ;
   streng *tmpstr=NULL ;
   streng *origfile=NULL, *inpfile=NULL ;
   int stackptr=0, no_next_interactive=0 ;
   stackbox stack[STACKSIZE] ;
   nodeptr othis=NULL, nstack[STACKSIZE] ;
   int nstackptr=0 ;
   nodeptr innerloop=NULL ;
   int whereto=0 ;
   void *tdescr=NULL ;
   volatile nodeptr secure_this=NULL ;
   extern sysinfo systeminfo ;
   streng *stringen=NULL ;

#ifdef lint 
   number = 0 ;
   incrdir = 0 ; 
#endif

if ( currlevel->buf == NULL )
{
   currlevel->buf = Malloc( sizeof(jmp_buf) ) ;

   assert( parseroot==NULL ) ;
   secure_this = this ;
   if (setjmp( *(currlevel->buf) ))
   {
      incrdir = 0 ;
      number = 0 ;
      tdescr = NULL ;
      stopval = NULL ;  /* take care, may loose these values */
      innerloop = NULL ;
      increment = NULL ;

      if (parseroot)
         destroytree( parseroot ) ;
      this = secure_this ;
      nstackptr = stackptr = no_next_interactive = 0 ;

      /*   stackptr = no_next_interactive = 0 ; */
      /*   increment = stopval = NULL ;  */
      /* oppps, we have experienced an SIGNAL, I believe */
      /* just go on right in, only have to reinitiate initiated vars */
      /* PLEASE, REMEMBER TO DO THAT !!! */

      goto fakerecurse ;
   }
   this = secure_this ;
}
nstackptr = stackptr = no_next_interactive = 0 ;
incrdir = 0 ;
tdescr = NULL ;
number = 0 ;
increment = NULL ;
stopval = NULL ;
innerloop = NULL ;
   
reinterpret:

   if (this==NULL)
      goto fakereturn ;

   currentnode = this ;
   if (trace_stat!='O' && trace_stat!='N') 
   {
      if (this->type != X_DO)  /* let do-stats trace themselves */
         traceline(this,trace_stat,0) ;
   }

   if (this->now) 
      this->now = this->unow = this->sec = this->usec = 0 ;

   this->called = 0;

   whereto = 0 ;   
   switch ( /*(unsigned char)*/ (this->type) ) {

      case X_PROGRAM:
      case X_STATS:       

      case X_WHENS:
      case X_OTHERWISE:
         this = this->p[0] ;
         goto reinterpret ;
    

      case 0:
      case 255:
      case X_DO:
/*         if (nstackptr>0 && this==nstack[nstackptr-1]) */

         if (innerloop==this)
         {
            assert( this->p[3] ) ;
            if (trace_stat!='O' && trace_stat!='N') 
            {
               traceline(this->p[3],trace_stat,-1) ;
               traceline(this,trace_stat,-1) ;
            }
            goto one ;
         }
         else 
            TRACELINE(this) ;  

         if (!((this->p[0])||(this->p[1]))) 
         {
            nstack[nstackptr++] = this->next ;
            this = this->p[2] ;
            goto fakerecurse ; 
         }

         nstack[nstackptr++] = this->next ; /* for use with leave */

         if (innerloop)
         {
            if (stackptr>=STACKSIZE)
                exiterror( ERR_FULL_CTRL_STACK, 0 )  ;
            stack[stackptr].incrdir = incrdir ;
/*            stack[stackptr].oldcnt = oldcnt ;
            stack[stackptr].guard = guard ;
            stack[stackptr].tdescr = tdescr ; */
            stack[stackptr].increment = increment ;
            stack[stackptr].stopval = stopval ;
            stack[stackptr].this = innerloop ;
            stack[stackptr].number = number ;
            stack[stackptr++].whereto = whereto ;
            increment = stopval = NULL ;
         }

         increment = stopval = tdescr = NULL ;
         tdescr = tmpstr = NULL ;
         if ((this->p[0])&&(this->p[0]->name))  
            tmpstr = evaluate( this->p[0]->p[0], NULL ) ;

         incrdir = 1 ;
         number = -1 ;
         for (i=1;i<4;i++)
            if ((this->p[0])&&(this->p[0]->p[i]))
               switch( this->p[0]->p[i]->type ) {
                  case X_DO_TO:
                     tmpptr = this->p[0]->p[i]->p[0] ;
                     stopval = calcul(tmpptr,NULL) ;
                     break ;
                 
                  case X_DO_BY:
                     tmpptr = this->p[0]->p[i]->p[0] ;
                     increment = calcul(tmpptr,NULL) ;
                     incrdir = descr_sign( increment ) ;
                     break ;

                  case X_DO_FOR:
                  {
                     int *iptr ;
                     tmpptr = this->p[0]->p[i]->p[0] ;
                     iptr = streng_to_int(chptr=evaluate(tmpptr,NULL)) ; 
                     if (!iptr)  exiterror( ERR_INVALID_INTEGER, 0 )  ;
                     if (*iptr<0)  exiterror( ERR_INVALID_RESULT, 0 )  ;
                     number = *iptr ;
                     Free_string( chptr ) ;
                     break ;
                  }}

         if (tmpstr)
         {
            setshortcut( this->p[0], str_normalize(tmpstr)) ;
            tdescr = shortcutnum( this->p[0] ) ;
            Free_string( tmpstr ) ;
         }

/*
         if (increment==NULL)
            increment = get_a_descr( &def_incr ) ;
 */
         if (systeminfo->interactive)
            if (intertrace())
            {
               nstackptr-- ;
               if (increment) free_a_descr( increment ) ;
               if (stopval) free_a_descr( stopval ) ;
               goto fakerecurse ;
            }

startloop:
         if (this->p[0]) 
         {
            if (stopval)
            {
               int tsign ;

               tsign = string_test( tdescr, stopval ) ;
               if (!(tsign ^ incrdir))
                  goto endloop ; 
            }

            if ((number>=0) && (number--<=0))
               goto endloop ; 
         }

         if ((this->p[1])&&((this->p[1]->type)==X_WHILE))
            if (!isboolean(this->p[1]->p[0]))
               goto endloop ; 

         if (this->p[2])
         {
            nstack[nstackptr++] = this ;
            pushcallstack(NULL) ;

            innerloop = this ;
            this = this->p[2] ;
            goto fakerecurse ;

one:
            popcallstack(-1) ;
         }
         if ((this->p[1])&&((this->p[1]->type)==X_UNTIL)) 
         {
            if (isboolean(this->p[1]->p[0]))
               goto endloop ; 
         }

         if ((this->p[0])&&(this->p[0]->name)) 
         {
#ifdef OPTIMIZE
            tdescr = shortcutnum( this->p[0] ) ;
            assert( tdescr ) ;
/*          
            if ((this->p[0]->u.varbx) && ( this->p[0]->u.varbx->valid ))
            {
               tdescr = this->p[0]->u.varbx->num ;
               this->p[0]->u.varbx->num = NULL ;
            }
            else
            {
               this->p[0]->u.varbx = NULL ;
               if (!(tdescr=get_a_descr(shortcut(this->p[0]))))
                   exiterror( ERR_BAD_ARITHMETIC, 0 )  ;
               try = NULL ;
            }
 */
            
            if (increment)   
               string_add( tdescr, increment, tdescr ) ;
            else
               string_incr( tdescr ) ;

            if (this->p[0]->u.varbx)
            {
/*
               if (this->p[0]->u.varbx->num)
               {
                  Free( this->p[0]->u.varbx->num->num ) ;
                  Free( this->p[0]->u.varbx->num ) ;
               }
 */
               this->p[0]->u.varbx->num = tdescr ;
               this->p[0]->u.varbx->flag = VFLAG_NUM ;
               TRACENUMBER( tdescr, 'V' ) ;
            }
            else
               setshortcut( this->p[0], str_norm( tdescr, NULL )) ;
 
#else   
            setshortcut(this->p[0], scutvar=
                                   str_add2(increment, shortcut(this->p[0])));
#endif
         }

         if (nextsig)
            goto fakerecurse ;

         goto startloop ;

endloop: if (increment) free_a_descr(increment) ;
         if (stopval) free_a_descr(stopval) ;
/*          if (tdescr) free_a_descr( tdescr ) ; */
         increment = stopval = NULL ;
         no_next_interactive = 1 ;
         nstackptr-- ;

         if (stackptr)
         {
            stackptr-- ;
            whereto = stack[stackptr].whereto ;
            number = stack[stackptr].number ;
/*            tdescr = stack[stackptr].tdescr ;
            oldcnt = stack[stackptr].oldcnt ; */
            innerloop = stack[stackptr].this ; 
/*            guard = stack[stackptr].guard ; */
            stopval = stack[stackptr].stopval ;
            increment = stack[stackptr].increment ;
            incrdir = stack[stackptr].incrdir ;
         }
         else
            innerloop = NULL ;

         break ;

       case X_IF:
         nstack[nstackptr++] = this->next ;
         this = (othis=this)->p[isboolean(this->p[0]) ? 1 : 2];
         if (systeminfo->interactive)
            if (intertrace())
               this = othis ;

         goto fakerecurse ;
         

      case X_NASSIGN:
      {
         num_descr *ntmp ;

         ntmp = calcul(this->p[1],NULL) ;
         assert( ntmp->size ) ; 
         if (this->p[0]->type==X_HEAD_SYMBOL)
         {
            fix_compoundnum( this->p[0], ntmp ) ;
         }
         else
         {
            setshortcutnum( this->p[0], ntmp ) ;
         }
      }
      break ;

      case X_ASSIGN:
         {
/* This is a CMS-ism; CMS allows the expression in an assignment to
 * be omitted, while TRL does _not_. If a CMS mode is implemented, the 
 * code below should be changed to allow p[0] to be null only iff 
 * CMS mode is active.
 */
            streng *value ;

            value = this->p[1] ? evaluate(this->p[1],NULL) : nullstringptr() ;
            if (this->p[0]->type==X_HEAD_SYMBOL)
               fix_compound( this->p[0], value ) ;
            else
               setshortcut( this->p[0], value ) ;
         }
         break ;
 
      case X_IPRET:
      {
         streng *tptr = evaluate(this->p[0],NULL) ;
         dointerpret( tptr ) ;
         break ;        
      }

      case X_NO_OTHERWISE:
          exiterror( ERR_WHEN_EXPECTED, 0 )  ;
         break ; 
                  
      case X_SELECT:
         nstack[nstackptr++] = this->next ;
         nstack[nstackptr++] = this->p[1] ; 
         this = this->p[0] ;
         goto fakerecurse ;

      case X_WHEN:
      {
         if (isboolean(this->p[0]))
         {
            nstackptr-- ; /* kill the OTHERWISE on the stack */
            this = this->p[1] ;
            goto fakerecurse ;
         }
         break ;
      }

      case X_SAY:
      {
         int ok=HOOK_GO_ON ;

         if (this->p[0])
            stringen = evaluate(this->p[0],NULL) ;
         else
            stringen = NULL ;

         if (systeminfo->hooks & HOOK_MASK(HOOK_STDOUT))
            ok = hookup( HOOK_STDOUT, stringen ) ;

         if (ok==HOOK_GO_ON)
         {
            if (stringen)
               write( fileno(stdout), stringen->value, Str_len(stringen) ) ;
            
            putchar( 0x0a ) ;
            fflush( stdout ) ; 
         }

         if (stringen)
            Free_string(stringen) ; 

         break ;
      }

      case X_TRACE:
      {
         streng *tptr ;

         if (this->name)
            set_trace( this->name ) ;
         else if (this->p[0])
         {
            set_trace( tptr=evaluate(this->p[0],NULL) ) ;
            Free_string( tptr ) ;
         }
         else
             exiterror( ERR_INTERPRETER_FAILURE, 0 )  ;

         break ; 
      }     

      case X_EXIT:
      {
#ifdef TRACEMEM
         extern int listleakedmemory ;
#endif
         int rc ;
         
         if (systeminfo->panic)
         {
            extern int there_is_no_error ;
            if (this->p[0])
               systeminfo->result = evaluate(this->p[0],NULL) ;
            else 
               systeminfo->result = NULL ;

            there_is_no_error = 1 ;
            longjmp( *(systeminfo->panic), 1 ) ;
         }

         if (this->p[0]==NULL)
            rc = EXIT_SUCCESS ;
         else
            rc = myatol(evaluate(this->p[0],NULL)) ;

#if defined(FLISTS) && defined(NEW_FLISTS)
         free_flists();
#endif

#ifdef TRACEMEM
         if (listleakedmemory)
            listleaked( MEMTRC_LEAKED ) ;
#endif
         CloseOpenFiles( ) ;
         exit( rc ) ;
         break ;
      }

      case X_COMMAND:
      {
         streng *stmp ;

         update_envirs( currlevel ) ;
         if (this->p[0]) {
            /* bja - added Free_string() around perform() */
            Free_string(perform(stmp=evaluate(this->p[0],NULL),currlevel->environment, this)) ;
            Free_string(stmp) ;
            break ; }
      }

      case X_ADDR_N:   /* ADDRESS environment [expr] */
      {
         streng *envir, *tmp ;

         update_envirs( currlevel ) ;
         envir = this->name ;
         if (this->p[0])
         {
            /* bja - added Free_string() around perform() */
            Free_string(perform(tmp=evaluate(this->p[0],NULL), envir, this)) ;
            Free_string( tmp ) ;
         }
         else
         {
            Free_string( currlevel->prev_env ) ;
            currlevel->prev_env = currlevel->environment ;
            currlevel->environment = Str_dup(envir) ;
         }
         break ;
      }

         
      case X_ADDR_V:   /* ADDRESS [VALUE] expr */
      {
         streng *cptr ;

         update_envirs( currlevel ) ;
         cptr = evaluate(this->p[0],NULL) ;
         Free_string( currlevel->prev_env ) ;
         currlevel->prev_env = currlevel->environment ;
         currlevel->environment = cptr ;
         break ;
      }


      case X_ADDR_S:   /* ADDRESS */
      {
         streng *tptr ;

         update_envirs( currlevel ) ;
         tptr = currlevel->environment ;
         currlevel->environment = currlevel->prev_env ;
         currlevel->prev_env = tptr ;
         break ;
      }         


      case X_DROP:
      {
         nodeptr nptr ;
         for (nptr=this->p[0]; nptr; nptr=nptr->p[0] ) 
            if (nptr->name)
               if (nptr->type == X_SIM_SYMBOL)
                  drop_var( nptr->name ) ;
               else if (nptr->type == X_IND_SYMBOL)
               {
                  char *start, *stop, *end ;
                  streng *name, *value ;
                 
                  value = shortcut( nptr ) ;
/*                value = getvalue( nptr->name, 0 ) ; */
                  end = Str_end( value ) ;
                  start = value->value ;
                  for (;;)
                  {
                     for (; start<end && isspace(*start); start++) ;
                     for (stop=start; stop<end && !isspace(*stop); stop++) ;
                     if (stop==start)
                        break ;

                     name = Str_make( stop - start ) ;
                     Str_ncatstr( name, start, stop-start ) ;
                     for (; start<stop; start++)
                        if (islower(*start))
                           *start = toupper(*start) ;

                     drop_var( name ) ;
                     Free_string( name ) ;
                  }
               }                   
         break ;
      }

      case X_SIG_SET:
      case X_CALL_SET:
      {
         int type ;
         trap *traps = gettraps( currlevel ) ;

         /* which kind of condition is this? */
         type = identify_trap( this->p[1]->type ) ;
 
         /* We always set this */
         traps[type].invoked = (this->type == X_SIG_SET) ;
         traps[type].delayed = 0 ;         
         traps[type].on_off = (this->p[0]->type == X_ON ) ;

         /* set the name of the variable to work on */
         FREE_IF_DEFINED( traps[type].name ) ;
         if (this->name)
            traps[type].name = Str_dup( this->name ) ;
         else if (this->p[0]->type == X_ON)
            traps[type].name = Str_cre( signalnames[type] ) ;

         break ;
      }

      case X_SIG_VAL:
      case X_SIG_LAB:
      {
         streng *cptr, *kill=NULL ;

         cptr = (this->name) ? this->name : evaluate( this->p[0], &kill ) ;
         nstackptr = 0 ;
         for (;stackptr>0;stackptr--) 
         {
            if (stack[stackptr-1].increment) 
                 free_a_descr(stack[stackptr-1].increment) ;

            if (stack[stackptr-1].stopval) 
                 free_a_descr(stack[stackptr-1].stopval) ;
         }

         setshortcut( nvar_sigl, int_to_streng( this->lineno )) ;
         entry = getlabel( cptr ) ;

         if (kill)
            Free_string( kill ) ;

         if ((entry)==NULL)  exiterror( ERR_UNEXISTENT_LABEL, 0 )  ;
         this = entry->next ;
         goto fakerecurse ;
         break ;
      }
      case X_PROC: 
         if (currlevel->varflag) 
             exiterror( ERR_UNEXPECTED_PROC, 0 )  ;

         for (ptr=this->p[0];(ptr);ptr=ptr->p[0])
            if (ptr->name) 
            {
               expose_var(ptr->name) ;
               if (ptr->type==X_IND_SYMBOL)
                  expose_indir(getvalue(ptr->name,0)) ;
               else
                  assert( ptr->type==X_SIM_SYMBOL) ;
            }
            else
                exiterror( ERR_INTERPRETER_FAILURE, 0 )  ;

         expose_var(NULL) ;
         break ; 

      case X_CALL:
      {
         this->u.node = getlabel(this->name) ;
         this->type = (this->u.node) ? X_IS_INTERNAL : X_IS_BUILTIN ;
         this->called = 1;
      }

      case X_IS_INTERNAL: 
      {
         paramboxptr targs ;

         if ( this->u.node ) 
         {
            setshortcut( nvar_sigl, int_to_streng( this->lineno )) ;

            no_next_interactive = 1 ;
            targs = initplist( this ) ;
            oldlevel = currlevel ;
            currlevel = newlevel( currlevel ) ;
            currlevel->args = targs ; 
            stackmark = pushcallstack( this ) ;

            result = interpret( this->u.node ) ;

            popcallstack( stackmark ) ;
            removelevel( currlevel ) ;
            currlevel = oldlevel ; 
            currlevel->next = NULL ;
            trace_stat = currlevel->tracestat ;

            if (result)
               setvalue( var_result, result ) ;
            else
               drop_var( var_result ) ;
         
            break ;
        }
     }
   
     case X_EX_FUNC:
     case X_IS_BUILTIN: 
     {
        if (&nofunc==(result = buildtinfunc( this )))
        {
           this->type = X_IS_EXTERNAL ;
        }
        else
        {
           if (result)
              setvalue( var_result, result ) ;
           else
              drop_var( var_result ) ;

           break ;
        }
      }

      case X_IS_EXTERNAL:
      {
         streng *ptr, *command ;
         int stackmark ;
         paramboxptr args, targs ;

         update_envirs( currlevel ) ;

         args = targs = initplist( this ) ;
#if 0
         command = Str_make( 1000 ) ;
         command = Str_cat(command,this->name ) ;
         for (;targs;targs=targs->next) 
            if (targs->value) 
            {
               command = Str_catstr(command," ") ; 
               command = Str_cat(command,targs->value) ; 
            }
         stackmark = pushcallstack( currentnode ) ;
         ptr = execute_external(command,args,systeminfo->environment,
                                NULL,0, INVO_SUBROUTINE);
         popcallstack( stackmark ) ;
         deallocplink( args ) ;

         if (ptr==command)
         {
            drop_var( var_result ) ;
            ptr = NULL ;
         }
         if (!ptr) 
         {
            ptr = run_popen( command, currlevel->environment ) ;

            if (!ptr)
            {
                exiterror( ERR_ROUTINE_NOT_FOUND, 0 )  ;
               ptr = nullstringptr() ;
            }
            setvalue( var_result, ptr ) ;
         }
   
         Free_string( command ) ;
#else
         stackmark = pushcallstack( currentnode ) ;
         ptr = execute_external(this->name,args,systeminfo->environment,
                                NULL,0, INVO_SUBROUTINE);
         popcallstack( stackmark ) ;

         if (ptr==this->name) /* MH no idea what this does */
         {
            drop_var( var_result ) ;
            ptr = NULL ;
         }

         if (!ptr) 
         {
            /* 
             * "this->name" wasn't an external Rexx program, so
             * see if it is an OS command
             */
            command = Str_make( 1000 ) ;
            command = Str_cat(command,this->name ) ;
            for (;targs;targs=targs->next) 
            {
               if (targs->value) 
               {
                  command = Str_catstr(command," ") ; 
                  command = Str_cat(command,targs->value) ; 
               }
            }
            ptr = run_popen( command, currlevel->environment ) ;
            Free_string( command ) ;

            if (!ptr)
            {
                exiterror( ERR_ROUTINE_NOT_FOUND, 0 )  ;
               ptr = nullstringptr() ;
            }
         }
         if (ptr)
            setvalue( var_result, ptr ) ;
         deallocplink( args ) ;
   
#endif
         break ;
      }


      case X_PARSE_ARG:
      case X_PARSE_ARG_U:
         args = currlevel->args ;
         parseargtree( args, this->p[0], this->type!=X_PARSE_ARG ) ;
         break ;

      case X_PARSE_U:
      case X_PARSE:
      {
         int killit ;
         
         killit = 1 ;
         source = NULL ;
         switch (this->p[0]->type) {
             case X_PARSE_VAR:
                /* must duplicate, parsing may have side effects */
                /* else, we must have locking of variables */
                source = Str_dup( shortcut( this->p[0] )) ;
/*              source = Str_dup(getvalue( this->p[0]->name, 1 )) ; */
                break ; 

             case X_PARSE_VAL:
                source = evaluate(this->p[0]->p[0],NULL);
                break ;

             case X_PARSE_PULL:
                source = popline() ;
                break ;

             case X_PARSE_VER:
                source = Str_cre(PARSE_VERSION_STRING) ;
                break ;

             case X_PARSE_EXT:
                source = readkbdline() ;
                break ; 

             case X_PARSE_SRC:
             {
                char *stype ;

                stype = system_type() ;
                origfile = systeminfo->called_as ;
                inpfile = systeminfo->input_file ;
                source = Str_make(strlen(stype)+4+
                         strlen(invo_strings[systeminfo->invoked])+
                         Str_len(origfile)+Str_len(inpfile)) ;
                source->len = 0 ;

                Str_catstr(source,stype) ;
                Str_catstr(source," ") ;
                Str_catstr(source,invo_strings[systeminfo->invoked]) ;
                Str_catstr(source," ") ;
                Str_cat(source,inpfile) ;
                Str_catstr(source," ") ;
                Str_cat(source,origfile) ;
                break ;      
             } 
          }

        if (this->type==X_PARSE_U) 
        {
           if (!killit)
              source = Str_dup(source) ;

           (void)upcase(source) ;
        }

        /* Use parseargtree() instead, that's more efficient */
        doparse( source, this->p[1], 0, 0 ) ;
        if (killit)
           Free_string( source ) ;

        break ;
      }

      case X_PULL:
      {
        streng *stmp ;

        doparse(stmp=upcase(popline()),this->p[0],0,0) ;
        Free_string( stmp ) ;
        break ;
      }

      case X_PUSH:
        stack_lifo( (this->p[0]) ? evaluate(this->p[0],NULL) : nullstringptr() ) ; 
        break ;

      case X_QUEUE:
        stack_fifo( (this->p[0]) ? evaluate(this->p[0],NULL) : nullstringptr() ) ;
        break ; 


      case X_OPTIONS:
        do_options(evaluate(this->p[0],NULL),0) ;
        break ;

      case X_RETURN:
         /* buggy, need to deallocate procbox and vars ... */
        if (this->p[0])
           retval = evaluate(this->p[0],NULL) ;
        else 
           retval = NULL ;
#if 1
/* bja - trying to avoid storage leak */
        if ( increment )
           free_a_descr( increment );
        if ( stopval )
           free_a_descr( stopval );
        for ( ; stackptr>0; stackptr--)
        {
           if ( stack[stackptr-1].increment )
              free_a_descr( stack[stackptr-1].increment );
           if ( stack[stackptr-1].stopval )
              free_a_descr( stack[stackptr-1].stopval );
        }
/* bja - end trying to avoid storage leak */
#endif
        return( retval ) ;
        break ;

      case X_LEAVE:
      case X_ITERATE:
         i = stackptr ;

         if (innerloop)
         {
            stack[i].this = innerloop ;
            stack[i].increment = increment ;
            stack[i].incrdir = incrdir ;
/*            stack[i].oldcnt = oldcnt ;
            stack[i].tdescr = tdescr ;
            stack[i].guard = guard ; */
            stack[i].number = number ;
            stack[i].stopval = stopval ;
            stack[i++].whereto = whereto ;
         }

         foobar1:
            if (i<=0)  exiterror( ERR_INVALID_LEAVE, 0 )  ;
            iptr = stack[i-1].this ;
            if (this->name==NULL) goto foobar2 ;
            if ((iptr->p[0]==NULL)||(iptr->p[0]->name==NULL)) goto foobar666 ;
            if (Str_cmp(this->name,iptr->p[0]->name)==0) goto foobar2 ;

            foobar666:
            popcallstack(-1) ;
            i -= 1 ;
            if (stack[i].stopval)
                free_a_descr( stack[i].stopval ) ;
            if (stack[i].increment)
                free_a_descr( stack[i].increment ) ;
            goto foobar1 ;

         foobar2:
         for (; iptr!=nstack[nstackptr-1] && nstackptr>0; nstackptr--) ;

         if (i<=0)  exiterror( ERR_INVALID_LEAVE, 0 )  ;
         if (this->type==X_LEAVE) {
            i -= 1 ;
            if (stack[i].stopval)
                free_a_descr( stack[i].stopval ) ;
            if (stack[i].increment)
                free_a_descr( stack[i].increment ) ;
            nstackptr-- ;
            popcallstack(-1) ; }
         TRACELINE(iptr) ;
         stackptr = i ;

         if (systeminfo->interactive)
            if (intertrace())
               goto fakerecurse ;
               
         this = nstack[--nstackptr] ;

         if (stackptr)
         {
            innerloop = stack[--stackptr].this ;
            increment = stack[stackptr].increment ;
            incrdir = stack[stackptr].incrdir ;
/*            guard = stack[stackptr].guard ;
            tdescr = stack[stackptr].tdescr ;
            oldcnt = stack[stackptr].oldcnt ; */
            number = stack[stackptr].number ;
            stopval = stack[stackptr].stopval ;
            whereto = stack[stackptr].whereto ;
         }

         goto fakereturn ;
         break ;

      case X_NUM_D:
      {
         int *tmp ;
         streng *cptr = evaluate( this->p[0],NULL ) ;
         tmp = streng_to_int( cptr ) ;
         Free_string( cptr ) ;
         if (!tmp)  exiterror( ERR_INVALID_INTEGER, 0 )  ;
         if (currlevel->numfuzz >= *tmp || *tmp<=0)
             exiterror( ERR_INVALID_RESULT, 0 )  ;
         currlevel->currnumsize = *tmp ;
         break ;
      }
 
      case X_NUM_DDEF:
         if (currlevel->numfuzz >= DEFAULT_NUMERIC_SIZE)
             exiterror( ERR_INVALID_RESULT, 0 )  ;
         currlevel->currnumsize = DEFAULT_NUMERIC_SIZE ;
         break ;
 
      case X_NUM_FDEF:
         if (currlevel->currnumsize <= DEFAULT_NUMERIC_FUZZ)
             exiterror( ERR_INVALID_RESULT, 0 )  ;
         currlevel->numfuzz = DEFAULT_NUMERIC_FUZZ ;
         break ;

      case X_NUM_FRMDEF:
         currlevel->numfuzz = DEFAULT_NUMFORM ;
         break ;

      case X_NUM_FUZZ:
      {
         int *tmp ;
         streng *cptr = evaluate( this->p[0],NULL ) ;
         tmp = streng_to_int( cptr ) ; 
         if (!tmp)  exiterror( ERR_INVALID_INTEGER, 0 )  ;
         if (currlevel->currnumsize <= *tmp || *tmp<0)
             exiterror( ERR_INVALID_RESULT, 0 )  ;
         Free_string( cptr ) ;
         currlevel->numfuzz = *tmp ;
         break ;
      }

      case X_NUM_F:
      {
         if (this->p[0]->type == X_NUM_SCI)
            currlevel->numform = NUM_FORM_SCI ;
         else if (this->p[0]->type == X_NUM_ENG)
            currlevel->numform = NUM_FORM_ENG ;
         else 
            assert( 0 ) ;
         break ;
      }

      case X_NUM_V:
      {
         streng *tmpstr ;
         tmpstr = evaluate( this->p[0], NULL ) ;
         if (tmpstr->len==10 && 
             !xstrncasecmp(tmpstr->value,"SCIENTIFIC",10))
            currlevel->numform = NUM_FORM_SCI ;
         else if (tmpstr->len==11 &&
             !xstrncasecmp(tmpstr->value,"ENGINEERING",11))
            currlevel->numform = NUM_FORM_ENG ;
         else
             exiterror( ERR_INVALID_RESULT, 0 )  ;
         break ;
      }

      case X_LABEL:
      case X_NULL:
         break ;

      default:
          exiterror( ERR_INTERPRETER_FAILURE, 0 )  ;
         break ;
   }

   if ((systeminfo->interactive)&&(!no_next_interactive))
      if (intertrace())
         goto fakerecurse ;

   no_next_interactive = 0 ;

   if (this)
      this = this->next ;

fakereturn:
   if (!this)
   {
      if (nstackptr<1) 
         return NULL ;
      else 
         this = nstack[--nstackptr] ;
   }

fakerecurse:

   /* check if there is any traps to process */   
   while (nextsig) 
   {
      trap *traps = gettraps( currlevel ) ;

      i = nextsig->type ;

      if (i == SIGNAL_NOTREADY)
         fixup_file( nextsig->descr ) ;
      
      /* if this condition is in delayed mode, ignore it for now */
      if (traps[i].delayed)
         goto aftersignals ;

      /* if this condition is no begin trapped, use default action */
      if (traps[i].on_off == 0)
         if (traps[i].def_act)
            goto aftersignals ;   /* default==1 ==> ignore it */
         else
            exiterror( nextsig->rc, 0 ) ;
     
      if (traps[i].invoked)  /* invoke as SIGNAL */
      {
         /* simulate a SIGNAL, first empty the stack */
/* Sorry, not safe to operate on these at this point, we just have to 
   accept that some memory is lost ... "can't make omelette without..." */
/*       if (stackptr)
 *          for (stackptr--;stackptr;stackptr--) 
 *          {
 *             FREE_IF_DEFINED(stack[stackptr].increment) ;
 *             FREE_IF_DEFINED(stack[stackptr].stopval) ;
 *          }
 */  /* hey, this should really be ok, .... must be a BUG */

         stackptr = 0 ;

         /* turn off the condition */
         traps[i].on_off = 0 ;
         traps[i].delayed = 0 ;
/*       traps[i].trapped = 0 ; */

         /* set the current condition information */
         if (currlevel->sig)
         {
            FREE_IF_DEFINED( currlevel->sig->info ) ;
            FREE_IF_DEFINED( currlevel->sig->descr ) ;
            Free( currlevel->sig ) ;
         }
         currlevel->sig = nextsig ;
         nextsig = NULL ;

         /* simulate the SIGNAL statement */
         entry = getlabel( traps[i].name ) ;
         setshortcut( nvar_sigl, int_to_streng( currlevel->sig->lineno )) ;
         if (currlevel->sig->type == SIGNAL_SYNTAX )
            setshortcut( nvar_rc, int_to_streng( currlevel->sig->rc )) ;

         if ((entry)==NULL)  exiterror( ERR_UNEXISTENT_LABEL, 0 )  ;
         this = entry ; 
         nstackptr = stackptr = 0 ;
         goto reinterpret ;
      }
      else /*if ((i<SIGNALS))*/ /* invoke as CALL */
      {
         if ((entry=getlabel( traps[i].name ))==NULL) 
             exiterror( ERR_UNEXISTENT_LABEL, 0 )  ;

         traps[i].delayed = 1 ;

         setshortcut( nvar_sigl, int_to_streng( nextsig->lineno )) ;
         oldlevel = currlevel ;
         currlevel = newlevel( currlevel ) ;
         currlevel->sig = nextsig ;
         nextsig = NULL ;

         stackmark = pushcallstack( this ) ;
         TRACELINE(entry) ;

         result = interpret( entry->next ) ;

         traps[i].delayed = 0 ;
         popcallstack( stackmark ) ;
         removelevel( currlevel ) ;
         currlevel = oldlevel ; 
         currlevel->next = NULL ;
         trace_stat = currlevel->tracestat ;
      }

   }

aftersignals:

   goto reinterpret ;

}


nodeptr getlabel( streng *name ) 
{
   extern sysinfo systeminfo ;
   labelboxptr lptr=NULL ;

   for (lptr=systeminfo->first;
      (lptr!=NULL)&&(Str_cmp(lptr->entry->name,name)!=0);
      lptr=lptr->next) ;

   return (lptr==NULL) ? NULL : lptr->entry ;
}


void removelevel( proclevel level ) 
{
   int i=0 ;

   if ( level->next )
   {
      removelevel( level->next ) ;
/*      level->next = NULL; */
   }

   if (level->varflag==1) /* does not belong *here* !!! */
      kill_variables( level->vars ) ;
 
   if (level->args)
      deallocplink( level->args ) ;

   if (level->environment)
      Free_string( level->environment ) ;

   if (level->prev_env)
      Free_string( level->prev_env ) ;

   if (level->prev) 
      level->prev->next = NULL ;

   FREE_IF_DEFINED(level->buf) ;

   if (level->sig)
   {
      FREE_IF_DEFINED( level->sig->info ) ;   
      FREE_IF_DEFINED( level->sig->descr ) ;   
      Free( level->sig ) ;
   }

   if (level->traps)
   {
      for (i=0; i<SIGNALS; i++)
         FREE_IF_DEFINED( level->traps[i].name ) ;

      Free( level->traps ) ;
   }

   Free(level) ; 
}


/* 
 * NOTE: The ->buf variable is not set here, It must be set. When 
 *    an old level is duplicated, the old ->buf is also duplicated,
 *    but DO_NO_USE_IT, since it will point to the reentring point
 *    of the mother-routine
 */
proclevel newlevel( proclevel oldlevel )
{
   extern sysinfo systeminfo ;
   proclevel level=NULL ;
   int i=0 ;

   level = (proclevel)Malloc(sizeof(proclevbox)) ;

   if (!oldlevel) 
   {
      level->numfuzz = DEFAULT_NUMERIC_FUZZ ;
      level->currnumsize = DEFAULT_NUMERIC_SIZE ;
      level->numform = DEFAULT_NUMFORM ;
      level->sec = 0 ;
      level->usec = 0 ;
      level->mathtype = DEFAULT_MATH_TYPE ;
      level->prev = NULL ;
      level->next = NULL ;
      level->args = NULL ;
      level->u.options.lineouttrunc = DEFAULT_LINEOUTTRUNC ;
      level->u.options.flushstack = DEFAULT_FLUSHSTACK ;
      level->u.options.close_bif = DEFAULT_CLOSE_BIF ;
      level->u.options.open_bif = DEFAULT_OPEN_BIF ;
      level->u.options.makebuf_bif = DEFAULT_MAKEBUF_BIF ;
      level->u.options.dropbuf_bif = DEFAULT_DROPBUF_BIF ;
      level->u.options.desbuf_bif = DEFAULT_DESBUF_BIF ;
      level->u.options.buftype_bif = DEFAULT_BUFTYPE_BIF ;
      level->u.options.cacheext = DEFAULT_CACHEEXT ;
      level->u.options.find_bif = DEFAULT_FIND_BIF ;
      level->u.options.prune_trace = DEFAULT_PRUNE_TRACE ;
      level->varflag = 1 ; 
      level->tracestat = systeminfo->tracing ;
      level->environment = Str_dup( systeminfo->environment ) ;
      level->prev_env = Str_dup( systeminfo->environment ) ;
      level->vars = create_new_varpool() ; 
      level->buf = NULL ;
      level->sig = NULL ;
      level->traps = Malloc( sizeof(trap) * SIGNALS ) ;
      for (i=0; i<SIGNALS; i++)
      {
         level->traps[i].name = NULL ;
         level->traps[i].on_off = 0 ;
         level->traps[i].delayed = 0 ;
         level->traps[i].def_act = default_action[i] ;
         level->traps[i].ignored = default_ignore[i] ;
         level->traps[i].invoked = 0 ;
      }
   }
   else 
   {
      /* Stupid SunOS acc gives incorrect warning for the next line */
      memcpy(level,oldlevel,sizeof(proclevbox)) ;
#ifdef DONT_DO_THIS
      level->prev_env = NULL ;
      level->environment = NULL ;
#else
      level->prev_env = Str_dup( oldlevel->prev_env ) ;
      level->environment = Str_dup( oldlevel->environment ) ;
#endif
      level->prev = oldlevel ;
      level->varflag = 0 ;
      oldlevel->next = level ; 
      level->buf = NULL ;
      level->args = NULL ;
/*    level->next = NULL ;*/
      level->sig = NULL ;
      level->traps = NULL ;
   }
   
   trace_stat = level->tracestat ;
   return( level ) ;
}


void expose_indir( streng *list ) 
{
   char *cptr=NULL, *eptr=NULL, *sptr=NULL ;
   streng *tmp=NULL ;
   int i=0;                                             /* MH 26/12/95 */

   cptr = list->value ;
   eptr = cptr + list->len ;
   tmp = Str_make( 64 ) ;
   for (;cptr<eptr;)
   {
      for (; cptr<eptr && isspace(*cptr); cptr++ ) ;
      for (sptr=cptr; cptr<eptr && !isspace(*cptr); cptr++ ) ;
      if (cptr-sptr >= 64) 
          exiterror( ERR_TOO_LONG_STRING, 0 )  ;
      if (cptr==sptr)
         continue;

      memcpy( tmp->value, sptr, cptr-sptr ) ;
      tmp->len = cptr-sptr ;
/* need to uppercase each variable in the list!! */     /* MH 26/12/95 */
      for (i=0 ;i<tmp->len; i++)                        /* MH 26/12/95 */
        {                                               /* MH 26/12/95 */
         if (islower(*(tmp->value+i)))                  /* MH 26/12/95 */
            *(tmp->value+i) = toupper(*(tmp->value+i)); /* MH 26/12/95 */
        }                                               /* MH 26/12/95 */
      expose_var( tmp ) ;
   }
   Free_string( tmp ) ;
}
