#ifndef lint
static char *RCSid = "$Id: variable.c,v 1.14 1993/05/10 06:16:49 anders Exp anders $";
#endif

/*
 *  The Regina Rexx Interpreter
 *  Copyright (C) 1992  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.
 */

/* 
 * Concept: Each REXX procedure (the top - or main - by default) has
 *  an array of hash-pointers. Routines that don't keep local
 *  variables (i.e hasn't seen a PROCEDURE) are using the hashpointers
 *  of the routine above them. The size of the array is HASHTABLENGTH.
 *
 * Each cell in this array is a pointer to a single-linked list of
 *  boxes. In common for all these boxes is that their name returns
 *  the same value when given as parameter to the hashfunc() function.
 *  
 * Each of these boxes contains five variables: name, value, index,
 *  realbox and next. 'next' points to next box in the list. 
 * 
 * 'name' is the name of the variable, and 'value' is the value it
 *  contains. However, if 'realbox' is set, it points to another
 *  box which contains the real value of the variable. This mechanism
 *  gives support for EXPOSE'ing variables in PROCEDUREs. 
 *
 * The 'index' is a pointer to another hashtable, and gives support
 *  for compound variables. If a variable is compound, its 'index' is
 *  set to point at the hashtable, each entry in this table do also
 *  point at the start of a single linked list of variable boxes, but
 *  these boxes has the 'after-the-period' part of the compound name
 *  as 'name'. The 'realbox', but not the 'index' may be set in these
 *  boxes. 
 *
 * A variable is set when it exists in the datastructures, and the
 *  relevant 'value' pointer is non-NULL. When dropping a variable
 *  that is EXPOSE'ed, the 'value' is set to NULL. 
 *
 * The 'test' and the 'test.' variables have two different
 *  variableboxes, and 'index' is only set in the box for 'test.'. A
 *  'realbox' existing for 'test' makes it exposed. A 'realbox'
 *  'test.' make the whole "array" exposed. 
 * 
 * A 'value' existing for 'test.' denotes the default value. 
 *
 * Yet to do:
 *
 *    o the datastructure for the variables should be local, not global
 *    o must implement the code for dropping variables.
 *    o dont always handle ptr->value==NULL correct
 *    o tracing is incorrect
 */

#include "rexx.h"
#include <string.h>
#include <ctype.h>
#include <assert.h>
#include <stdio.h>   /* f*ck sun, they can't write a proper assert!!! */

static int foundflag=FALSE ;
static variable *thespot=NULL ;
static int current_valid=1 ;

#define SAFTYBELTS
#define QUICK_N_DIRTY

#define GET_REAL_BOX(ptr) {for(;(ptr->realbox);ptr=ptr->realbox);}
#define REPLACE_VALUE(val,p) {if(p->value) \
     Free_string(p->value);p->value=val;p->guard=0;\
     p->flag=(val)?VFLAG_STR:VFLAG_NONE;}

#define REPLACE_NUMBER(val,p) {if(p->num) \
     {Free(p->num->num);Free(p->num);};p->num=val;p->guard=0;\
     p->flag=(val)?VFLAG_NUM:VFLAG_NONE;}


static int subst=0 ;


/*
 * Allocates and initializes a hashtable for the variables. Can be used 
 * both for the main variable hash table, or for an compound variable. 
 */
static variableptr *make_hash_table( void )
{
   variableptr *optr=NULL, *ptr=NULL, *eptr=NULL ;

   optr = ptr = Malloc( HASHTABLENGTH*sizeof(variableptr) ) ;
   for (eptr=ptr+HASHTABLENGTH; ptr<eptr; *(ptr++)=NULL) ;

   return optr ;
}

#ifdef TRACEMEM
static variableptr first_invalid=NULL ;
#endif


void detach( variableptr ptr )
{
   assert( ptr->hwired>0 ) ;

/*
#ifdef TRACEMEM
   if (ptr->valid)
   {
      if (ptr->value)
         Free_string( ptr->value ) ;
      if (ptr->name)
         Free_string( ptr->name ) ;
      if (ptr->num)
      {  
         Free( ptr->num->num ) ;
         Free( ptr->num ) ;
      }
      ptr->value = ptr->name = ptr->num = NULL ;
      ptr->flag = VFLAG_NONE ;
      ptr->valid = 0 ;
   }

   if (--ptr->hwired == 0)
   {
      if (ptr->prev)
         ptr->prev->next = ptr->next ;
      if (ptr->next)
         ptr->next->prev = ptr->prev ;
      else
         first_invalid = ptr->prev ;

      Free( ptr ) ;
   }
#endif
 */

   ptr->hwired-- ;
}



#ifdef TRACEMEM

void *indeks_ptr=NULL ;


void markvariables( proclevel procptr )
{
   variableptr vvptr=NULL, vptr=NULL ;
   paramboxptr pptr=NULL ;
   int i=0, j=0 ;
   
   if (indeks_ptr)
      markmemory( indeks_ptr, TRC_VARBOX ) ;

   for(;procptr;procptr=procptr->next) 
   {
      if (procptr->environment)
         markmemory( procptr->environment, TRC_VARBOX ) ;
      if (procptr->prev_env)
         markmemory( procptr->prev_env, TRC_VARBOX ) ;
      if (procptr->sig)
      {
         markmemory( procptr->sig, TRC_VARBOX ) ;
         if (procptr->sig->info)
            markmemory( procptr->sig->info, TRC_VARBOX ) ;
         if (procptr->sig->descr)
            markmemory( procptr->sig->descr, TRC_VARBOX ) ;
      }
      if (procptr->buf ) markmemory( procptr->buf, TRC_VARBOX ) ;
      if (procptr->traps ) 
      {
         markmemory( procptr->traps, TRC_VARBOX ) ;
         for (i=0; i<SIGNALS; i++)
            if (procptr->traps[i].name)
               markmemory( procptr->traps[i].name, TRC_VARBOX ) ;
      }
      
      for(i=0;i<HASHTABLENGTH;i++) 
         for(vptr=(procptr->vars)[i];vptr;vptr=vptr->next) 
         {
            markmemory((char*)vptr,TRC_VARBOX) ;
            if (vptr->name)
               markmemory((char*)vptr->name,TRC_VARNAME) ;
            if (vptr->num)
            {
               markmemory( vptr->num, TRC_VARVALUE ) ;
               markmemory( vptr->num->num, TRC_VARVALUE ) ;
            }
            if (vptr->value)
               markmemory((char*)vptr->value,TRC_VARVALUE) ; 
            if (vptr->index)
            {
               markmemory( vptr->index, TRC_VARNAME) ;
               for (j=0; j<HASHTABLENGTH; j++)
                  for(vvptr=(vptr->index)[j];vvptr;vvptr=vvptr->next) 
                  {
                     markmemory((char*)vvptr,TRC_VARBOX) ;
                     if (vvptr->name)
                        markmemory((char*)vvptr->name,TRC_VARNAME) ;
                     if (vvptr->num)
                     {
                         markmemory( vvptr->num, TRC_VARVALUE ) ;
                         markmemory( vvptr->num->num, TRC_VARVALUE ) ;
                     }
                     if (vvptr->value)
                        markmemory((char*)vvptr->value,TRC_VARVALUE) ; 
                  }
            }
         }
      markmemory((char*)procptr,TRC_PROCBOX) ;
/*      for (lptr=procptr->first; lptr; lptr=lptr->next)
	 markmemory((char*)lptr, TRC_LABEL) ; */
      
      markmemory((char*)procptr->vars,TRC_HASHTAB) ; 
      if (procptr->args) 
      {
         for (pptr=procptr->args; pptr; pptr=pptr->next) {
            markmemory((char*) pptr, TRC_PROCARG) ;
            if (pptr->value) 
               markmemory((char*) pptr->value, TRC_PROCARG) ;
         }
      }
   }

   for (vptr=first_invalid; vptr; vptr=vptr->prev)
      markmemory( vptr, TRC_VARBOX ) ;
}
#endif /* TRACEMEM */



static variableptr newbox( streng *name, streng *value, variableptr *oldptr ) 
{
   variableptr newptr=NULL ;
   
   newptr = Malloc(sizeof(variable)) ;
   newptr->next = *oldptr ;
   newptr->prev = NULL ;
   newptr->realbox = NULL ;
   newptr->index = NULL ;
   newptr->stem = NULL ;
   newptr->num = NULL ;
   newptr->flag = value ? VFLAG_STR : VFLAG_NONE ;
   newptr->guard = 0 ;
   newptr->hwired = 0 ;
   newptr->valid = current_valid ;

   *oldptr = newptr ;
   newptr->value = value ;
   if (name)
      newptr->name = Str_dup(name) ;
   else
      newptr->name = NULL ;

   return newptr ;
}


static variableptr make_stem( streng *name, streng *value, 
                                    variableptr *oldptr, int len )
{
   variableptr ptr=NULL ;

   ptr = newbox( NULL, value, oldptr ) ; 
   ptr->index = make_hash_table() ;
   ptr->name = Str_ndup(name, len) ;
   return ptr ;
}




#define RXISDIGIT(a) (char_types[(unsigned char)(a)]&0x01)
#define RXISUPPER(a) (char_types[(unsigned char)(a)]&0x02)
#define RXISLOWER(a) (char_types[(unsigned char)(a)]&0x04)
#define RXISEXTRA(a) (char_types[(unsigned char)(a)]&0x08)
#define RXISCOMMA(a) (char_types[(unsigned char)(a)]&0x10)

char char_types[256] = {
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,   /* nul - bel */
   0x00, 0x20, 0x20, 0x00, 0x20, 0x00, 0x00, 0x20,   /* bs  - si  */
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,   /* dle - etb */
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,   /* can - us  */
   0x20, 0x08, 0x00, 0x08, 0x08, 0x00, 0x00, 0x00,   /* sp  -  '  */
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x10, 0x00,   /*  (  -  /  */
   0x01, 0x01, 0x01, 0x01, 0x01, 0x01, 0x01, 0x01,   /*  0  -  7  */
   0x01, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x08,   /*  8  -  ?  */
   0x08, 0x02, 0x02, 0x02, 0x02, 0x02, 0x02, 0x02,   /*  @  -  G  */
   0x02, 0x02, 0x02, 0x02, 0x02, 0x02, 0x02, 0x02,   /*  H  -  O  */
   0x02, 0x02, 0x02, 0x02, 0x02, 0x02, 0x02, 0x02,   /*  P  -  W  */
   0x02, 0x02, 0x02, 0x00, 0x00, 0x00, 0x00, 0x08,   /*  X  -  _  */
   0x00, 0x04, 0x04, 0x04, 0x04, 0x04, 0x04, 0x04,   /*  `  -  g  */
   0x04, 0x04, 0x04, 0x04, 0x04, 0x04, 0x04, 0x04,   /*  h  -  o  */
   0x04, 0x04, 0x04, 0x04, 0x04, 0x04, 0x04, 0x04,   /*  p  -  w  */
   0x04, 0x04, 0x04, 0x00, 0x00, 0x00, 0x00, 0x00,   /*  x  - del */
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00
} ;

/*
int valid_var_name( streng *name ) 
{
   char *cptr=NULL, *eptr=NULL ;
   int stem=0 ;

   cptr = name->value ;
   eptr = cptr + name->len ;

   if (cptr==eptr || (char_types[*cptr++] & (~0x0a)))
      return 0 ;

   stem = 0 ;
   for (; cptr<eptr; cptr++)
   {
      if (char_types[*cptr] & 0x0b)
         continue ;
      else if (*cptr=='.')
         return 1 ;
      else
         return 0 ;
   }
   return 1 ;    
}
*/


/*
 * Sigh ... this is kind of troublesome, in particular since '-' and '+' 
 * can be embedded in a symbol name in certain conditions. 
 */
int valid_var_symbol( streng *name ) 
{
   char *cptr=NULL ;
   char *eptr=NULL, *types=NULL, ch=' ' ;
   int stem=0, nums=0 ;

   types = char_types ;
   cptr = name->value ;
   eptr = cptr + name->len ;

   if (cptr==eptr || (types[ch=*(cptr++)]==0))
      return SYMBOL_BAD ;

   /* Lets check whether it is a constant symbol */
   if (types[ch] & 0x11)
   {
      for (;cptr<eptr && types[*cptr]; cptr++) ;
      if (cptr<eptr)
      {
         if (*cptr!='-' && *cptr!='+')
            return SYMBOL_BAD ;

         /* the characters [-+] may occur in a constant symbol ... */
         for (cptr=name->value; cptr<eptr && RXISDIGIT(*cptr); cptr++) ;
         nums = cptr - name->value ;
         if (cptr<eptr && *cptr=='.')
            for (cptr++; cptr<eptr && RXISDIGIT(*cptr); cptr++, nums++) ;

         if (cptr<eptr && (*cptr=='e' || *cptr=='E'))
         {
            if (nums==0)
               return SYMBOL_BAD ;

            cptr++ ;
            nums = 0 ;
            if (cptr<eptr && (*cptr=='+' || *cptr=='-'))
               for (;cptr<eptr && RXISDIGIT(*cptr); cptr++, nums++) ;

            if (nums==0)
               return SYMBOL_BAD ;
         }
         if (cptr<eptr)
            return SYMBOL_BAD ;
         else
            return SYMBOL_CONSTANT ;
      }
      else
         return SYMBOL_CONSTANT ;
   }

   /* OK, we know that the start was a valid symbol */
   stem = 0 ;
   for (; cptr<eptr; cptr++)
   {
      if (types[*cptr] & 0x0f)
         continue ;
      else if (*cptr=='.')
         stem++ ;
      else 
         if (!stem)
             return SYMBOL_BAD ;
   }

   if (stem==0)
      return SYMBOL_SIMPLE ;

   if (stem==1 && *(eptr-1))
      return SYMBOL_STEM ;

   return SYMBOL_COMPOUND ;
}


static int hashval=0 ;

static int hashfunc( streng *name, int start, int *stop ) 
{
   register int sum=0, idx=0 ;
   register char *ch=NULL, *ech=NULL ;
   
   ch = name->value ;
   ech = Str_end( name ) ;

   ch += start ;      
   sum = idx = 0 ;
   for (; (ch<ech);ch++)
   {
#if 0
      if (*ch == '.')
         if (stop)
            break ;
         else
            continue ;
     
      sum = sum + RXTOLOW(*ch) ;
#else
      if (*ch == '.')
      {
         if (stop)
            break ;
         else
            continue ;
      }
      if (RXISDIGIT(*ch))
	 idx = idx*10 + (*ch - '0') ;
      else
      {
         if (idx)
         {
            sum = (sum) + RXTOLOW(*ch) + idx ;
            idx = 0 ;
         }
         else 
            sum = (sum) + RXTOLOW(*ch) ;
      }
#endif
   }

   if (stop)
      *stop = ch - name->value ;
  
   return( hashval = (sum + idx) & (HASHTABLENGTH-1) ) ;
   
}


variableptr *create_new_varpool( void ) 
{
   current_valid++ ;
   return make_hash_table() ;
}


int ignore_novalue=0 ;

void set_ignore_novalue( void )
{
   assert( !ignore_novalue ) ;
   ignore_novalue = 1 ;
}

void clear_ignore_novalue( void )
{  
   assert( ignore_novalue ) ;
   ignore_novalue = 0 ;
}


static int notrace=0 ;
streng *get_it_anyway( streng *str )
{
   streng *ptr=NULL ;

   notrace = 1 ;
   ignore_novalue = 1 ;
   ptr = getvalue(str,FALSE) ;
   ignore_novalue = 0 ;
   notrace = 0 ;

   if (!ptr)
       exiterror( ERR_SYMBOL_EXPECTED, 0 )  ;

   return ptr ;
}


int var_was_found( void )
{
   return foundflag ;
}

streng *isvariable( streng *str )
{
   streng *ptr=NULL ;

   ignore_novalue = 1 ;
   ptr = getvalue(str,FALSE) ;
   ignore_novalue = 0 ;
   if (foundflag)
      return ptr ;

   return NULL ;
}


static streng *tmpindex=NULL ;
static streng *ovalue=NULL ;
static streng *xvalue=NULL ;

static num_descr *odescr=NULL ;

#ifdef TRACEMEM
static void mark_variables( void ) 
{
   markmemory( tmpindex, TRC_STATIC ) ;
   if (ovalue) 
      markmemory( ovalue, TRC_STATIC ) ;
   if (xvalue) 
      markmemory( xvalue, TRC_STATIC ) ;
   if (odescr)
   {
      markmemory( odescr, TRC_STATIC ) ;
      markmemory( odescr->num, TRC_STATIC ) ;
   }
}
#endif

void init_vars( void ) 
{
   assert( tmpindex==NULL ) ;
#ifdef TRACEMEM
   regmarker( mark_variables ) ;
#endif
   tmpindex = Str_make( MAX_INDEX_LENGTH ) ; 
}



/*
 * This routine takes a ptr to a linked list of nodes, each describing 
 * one element in a tail of a compound variable. Each of the elements 
 * will eventually be cached, since they are retrieved through the 
 * shortcut() routine. 
 */
static streng *fix_index( nodeptr this ) 
{
   char *cptr=NULL ;
   streng *value=NULL ;
   int osetting=0 ;
#ifdef SAFTYBELTS
   int freespc=0 ;
   streng *large=NULL ;
#endif

   assert( this ) ;
   osetting = ignore_novalue ;
   ignore_novalue = 1 ;

   freespc = tmpindex->max ; 
   cptr = tmpindex->value ;

#ifdef FANCY
   if (!this->p[0])
   {
      assert( this->type==X_CTAIL_SYMBOL || this->type==X_VTAIL_SYMBOL) ;
      if (this->type == X_CTAIL_SYMBOL)
         value = this->name ;
      else
      {
         subst = 1 ;
         value = shortcut( this ) ;
      }

      ignore_novalue = osetting ;
      return value ;
   }
#endif

   while (1)
   {
      assert( this->type==X_CTAIL_SYMBOL || this->type==X_VTAIL_SYMBOL) ;
      if (this->type == X_CTAIL_SYMBOL)
         value = this->name ;
      else 
      {
         subst = 1 ;
         value = shortcut( this ) ;
      }

      freespc -= value->len;
      if (freespc-- <= 0)
      {
         large = Str_make( tmpindex->max * 2 + value->len ) ;
         memcpy( large->value, tmpindex->value, (cptr-tmpindex->value)) ;
         cptr = large->value + (cptr-tmpindex->value) ;
         freespc += (large->max - tmpindex->max) ; 
         Free_string( tmpindex ) ;
         tmpindex = large ;

         assert( freespc >= 0 ) ;
      }

      memcpy( cptr, value->value, value->len ) ;
      cptr += value->len ;
      this = this->p[0] ;
      if (this)
         *(cptr++) = '.' ;
      else
         break ;
   } 
   tmpindex->len = cptr - tmpindex->value ;
   assert( tmpindex->len <= tmpindex->max ) ;
   ignore_novalue = osetting ;
   return tmpindex ;
}



void expand_to_str( variableptr ptr ) 
{
   int flag=0 ;

   flag = ptr->flag ;

   if (flag & VFLAG_STR)
      return ;

   if (flag & VFLAG_NUM)
   {
      assert( ptr->num ) ;
      ptr->value = str_norm( ptr->num, ptr->value ) ;
      ptr->flag |= VFLAG_STR ;
   }
}


static streng *subst_index( streng *name, int start, variableptr *vars ) 
{
   int i=0, length=0 ;
   variableptr nptr=NULL ;
   int stop=0 ;
   char *cptr=NULL ;

   assert( start < name->len ) ;
  
   tmpindex->len = 0 ;
   subst = 0 ;

   for ( ;; )
   {
      nptr = vars[ hashfunc( name, start, &stop ) ] ;

      length = stop - start ;
      for (; nptr; nptr=nptr->next )
      {
         if (nptr->name->len != length)  /* lengths differ */
            continue ;  

         if (Str_cnocmp(nptr->name,name,length,start))  /* contents differ */
            continue ;

         break ;
      }
      
      if (nptr)
        for (;nptr->realbox; nptr=nptr->realbox) ;

      if (nptr)
         expand_to_str(nptr) ;

      if ((nptr) && (nptr->value))
      {
         Str_cat( tmpindex, nptr->value ) ;
         subst = 1 ;
      }
      else
      {
         cptr = tmpindex->value + tmpindex->len ;
         for (i=start ;i<stop; i++)
            *(cptr++) = toupper( name->value[i] ) ;
         tmpindex->len = cptr - tmpindex->value ;
      }

      if (stop>=Str_len(name))
         break ;

      start = stop + 1 ;
      tmpindex->value[tmpindex->len++] = '.' ;
   }

   return tmpindex ;
}




static void kill_index( variableptr *array, int kill, int prop, streng *val ) 
{
   register variableptr ptr=NULL, tptr=NULL, *eptr=NULL, *aptr=NULL ;

   aptr = array ;
   eptr = aptr + HASHTABLENGTH ;
   for ( ; aptr<eptr; aptr++ ) 
      if (*aptr)
      {
         tptr = *aptr ;
         for (;(ptr=tptr);) 
         {
            tptr = tptr->next ;
            if (prop && ptr->realbox)
            {
               variableptr tttptr ;
               for (tttptr=ptr; tttptr->realbox; tttptr=tttptr->realbox ) ;
               if (val)
               {  
                  streng *tmpval = Str_dup(val) ;
                  REPLACE_VALUE( tmpval, tttptr ) ;
               }
               else if (tttptr->value)
               {
                  Free_string( tttptr->value ) ;
                  tttptr->value = NULL ;
               }
            }
            Free_string(ptr->name) ;
            if (ptr->value)
               Free_string(ptr->value) ;

            if (ptr->index)
            {
               assert( prop==0 ) ;
               kill_index( ptr->index, kill, 0, NULL ) ;
            }

            if (ptr->num)
            {
               Free( ptr->num->num ) ;
               Free( ptr->num ) ;
            }

            if (ptr->hwired)
            {
               ptr->valid = 0 ;
#ifdef TRACEMEM
               ptr->prev = first_invalid ;
               ptr->next = NULL ;
               if (first_invalid)
                  first_invalid->next = ptr ;
               first_invalid = ptr ;
#endif
            }
            else
               Free(ptr) ; 
         }
         *aptr = NULL ;
      }
   if (kill)
      Free( array ) ;
}



variableptr findsimple( streng *name )
{
   extern proclevel currlevel ;
   variableptr ptr=NULL ;

   ptr = currlevel->vars[hashfunc(name,0,NULL)] ;
   for (;(ptr)&&(Str_ccmp(ptr->name,name));ptr=ptr->next) ;
   if ((thespot=ptr))
      for (;ptr->realbox; ptr=ptr->realbox) ;

   return ptr ;
}
 

static void setvalue_simple( streng *name, streng *value ) 
{
   extern proclevel currlevel ;
   variableptr ptr=NULL ;

   ptr = findsimple( name ) ;
   if (ptr) 
   {
      foundflag = (ptr->flag & VFLAG_BOTH) ;
      REPLACE_VALUE(value,ptr) ; 
   }
   else 
   {
      foundflag = 0 ;
      thespot = newbox( name, value, &((currlevel->vars)[hashval]) ) ; 
   }
}




static streng *getvalue_simple( streng *name ) 
{
   variableptr ptr=NULL ;
   streng *value=NULL ;

   ptr = findsimple(name) ;

   foundflag = ((ptr)&&(ptr->flag & VFLAG_BOTH)) ;

   if (ptr)
      expand_to_str( ptr ) ;

   if (foundflag)
      value = ptr->value ;
   else 
   {
      value = name ;
      thespot = NULL ;
      if (!ignore_novalue)
         condition_hook( SIGNAL_NOVALUE, 0, -1, Str_dup(value) ) ;
   }

   if (!notrace)
      tracevalue(value,((ptr) ? 'V' : 'L')) ; 

   return value ;
}




static void setvalue_stem( streng *name, streng *value ) 
{
   extern proclevel currlevel ;
   variableptr ptr=NULL ;

   ptr = findsimple( name ) ;

   if (ptr) 
   {
      foundflag = ( ptr->flag & VFLAG_BOTH) ;
      REPLACE_VALUE( value, ptr ) ;
      if (ptr->index)
         kill_index( ptr->index, 0, 1, value ) ; 
   }
   else 
   {
      foundflag = 0 ;
      make_stem( name, value, &(currlevel->vars[hashval]), name->len ) ;
   }
   thespot = NULL ;
}  


static void setvalue_compound( streng *name, streng *value ) 
{
   extern proclevel currlevel ;
   variableptr ptr=NULL, nptr=NULL, *nnptr=NULL, *pptr=NULL ;
   int stop=0 ;
   streng *indexstr=NULL ;

   foundflag = 0 ;
   pptr = &(currlevel->vars[hashfunc(name,0,&stop)]) ;
   stop++ ;
   for (ptr=*pptr;(ptr)&&(Str_ncmp(ptr->name,name,stop));ptr=ptr->next) ;

   if (!ptr)
      ptr = make_stem( name, NULL, pptr, stop ) ;

   for (;(ptr->realbox);ptr=ptr->realbox) ;
   indexstr = subst_index( name, stop, currlevel->vars ) ;

   if (subst)   /* trace it */
      tracecompound(name,stop-1,indexstr,'C') ;

   nnptr = &((ptr->index)[hashfunc(indexstr,0,NULL)]) ;
   for (nptr=*nnptr;(nptr)&&(Str_cmp(nptr->name,indexstr));nptr=nptr->next) ;

   if (nptr) 
   {
      for (;(nptr->realbox);nptr=nptr->realbox) ;
      foundflag = ( nptr && (nptr->flag & VFLAG_BOTH)) ;
      REPLACE_VALUE(value,nptr) ; 
   }
   else 
   {
      newbox(indexstr,value,nnptr) ; 
      (*nnptr)->stem = ptr ;
   }
   
   thespot = NULL ;
}


static void expose_simple( variableptr *table, streng *name ) 
{
   extern proclevel currlevel ;
   int hashv=0 ;  /* unnecessary: can use hashval */
   variableptr ptr=NULL ;

   ptr = table[hashv=hashfunc(name,0,NULL)] ;
   for (;(ptr)&&(Str_ccmp(ptr->name,name));ptr=ptr->next) ;
   if (ptr)  /* hey, you just exposed that one! */
      return ;   

   ptr = currlevel->vars[hashv] ;
   for (;(ptr)&&(Str_ccmp(ptr->name,name));ptr=ptr->next) ;
   for (;(ptr)&&(ptr->realbox);ptr=ptr->realbox) ;

   if (!ptr) 
   {
/*    condition_hook( SIGNAL_NOVALUE, 0, -1, Str_dup(name) ) ; */
      newbox(name,NULL,&currlevel->vars[hashv]) ;
   }

   newbox(name,NULL,&table[hashv]) ;
   table[hashv]->realbox = ((ptr) ? (ptr) : currlevel->vars[hashv]) ; 
   (table[hashv]->realbox)->valid = current_valid+1 ;
}



static void expose_stem( variableptr *table, streng *name ) 
{
   extern proclevel currlevel ;
   variableptr ptr=NULL, tptr=NULL ;
   int hashv=0, junk=0 ;

   ptr = table[hashv=hashfunc(name,0,&junk)] ;
   for (;(ptr)&&(Str_ccmp(ptr->name,name));ptr=ptr->next) ;
   if ((ptr)&&(ptr->realbox))
      return ; /* once is enough !!! */

   tptr = currlevel->vars[hashv] ;
   for (;(tptr)&&(Str_ccmp(tptr->name,name));tptr=tptr->next) ;
   for (; tptr && tptr->realbox; tptr=tptr->realbox ) ;

   if (!tptr) 
   {
/*    condition_hook( SIGNAL_NOVALUE, 0, -1, Str_dup(name) ) ; */
      newbox(name,NULL,&currlevel->vars[hashv]) ;
      (tptr=currlevel->vars[hashv])->index = make_hash_table() ; 
   }

   if (ptr) 
   {
      kill_index(ptr->index, 1, 0, NULL) ; 
      ptr->index = NULL ;
      assert(( ptr->realbox==NULL) || (ptr->realbox==tptr )) ;
      ptr->realbox = tptr ;
   }
   else 
   {
      newbox(name,NULL,&table[hashv]) ;
      table[hashv]->realbox = tptr ; /* dont need ->index */
   }  
}



static void expose_compound( variableptr *table, streng *name ) 
{
   extern proclevel currlevel ;
   int hashv=0, length=0, hashval2=0 ;
   variableptr ptr=NULL, nptr=NULL, tptr=NULL ;
   int cptr=0 ;
   streng *indexstr=NULL ;

   ptr = table[hashv=hashfunc(name,0,&cptr)] ;
   length = ++cptr ;
   for (;(ptr)&&(Str_cncmp(ptr->name,name,length));ptr=ptr->next) ;
   if ((ptr)&&(ptr->realbox))
      return ; /* whole array already exposed */

   if (!ptr) /* array does not exist */
   {
/*    condition_hook( SIGNAL_NOVALUE, 0, -1, Str_dup(name) ) ; */
      make_stem(name,NULL,&table[hashv],length) ;
      ptr = table[hashv] ; 
   }

   indexstr = subst_index( name, cptr, table ) ;

   if (subst)   /* trace it */
      tracecompound(name,cptr-1,indexstr,'C') ;

   nptr = (ptr->index)[hashval2=hashfunc(indexstr,0,NULL)] ;
   for (;(nptr)&&(Str_cmp(nptr->name,indexstr));nptr=nptr->next) ;
   if ((nptr)&&(nptr->realbox))
      return ; /* can't your remember *anything* !!! */
   else {
      newbox(indexstr,NULL,&ptr->index[hashval2]) ;
      nptr = ptr->index[hashval2] ; }

   tptr = currlevel->vars[hashv] ;
   for (;(tptr)&&(Str_cncmp(tptr->name,name,length));tptr=tptr->next) ;
   for (;(tptr)&&(tptr->realbox);tptr=tptr->realbox) ;
   if (!tptr) 
   {
/*    condition_hook( SIGNAL_NOVALUE, 0, -1, Str_dup(name) ) ; */
      make_stem(name,NULL,&currlevel->vars[hashv],length) ;
      tptr = currlevel->vars[hashv] ;
   }

   tptr = tptr->index[hashval2] ;
   for (; tptr && Str_cmp(tptr->name,indexstr); tptr=tptr->next) ;
   for (; tptr && tptr->realbox; tptr=tptr->realbox ) ;
   if (!tptr)
   {
      newbox(indexstr,NULL,&currlevel->vars[hashv]->index[hashval2]) ;
      tptr = currlevel->vars[hashv]->index[hashval2] ; 
      tptr->stem = currlevel->vars[hashv] ;
   }

   nptr->realbox = tptr /*currlevel->vars[hashv]->index[hashval2] */; 
}



static streng *getvalue_compound( streng *name ) 
{
   int hashv=0, baselength=0 ;
   variableptr ptr=NULL, nptr=NULL ;
   streng *value=NULL ;
   streng *indexstr=NULL ;
   extern proclevel currlevel ;
   int stop=0 ;

   ptr = currlevel->vars[hashv=hashfunc(name,0,&stop)] ;
   baselength = ++stop ;
   for (;(ptr)&&(Str_cncmp(ptr->name,name,baselength));ptr=ptr->next) ; 
   for (;(ptr)&&(ptr->realbox);ptr=ptr->realbox) ;
   indexstr = subst_index( name, stop, currlevel->vars ) ;
   hashv = hashfunc(indexstr,0,NULL) ;

   if (subst && !notrace)   /* trace it */
      tracecompound(name,baselength-1,indexstr,'C') ;

   if (ptr) {   /* find spesific value */
      nptr = ((variableptr *)(ptr->index))[hashv] ;
      for (;(nptr)&&(Str_cmp(nptr->name,indexstr));nptr=nptr->next) ; 
      for (;(nptr)&&(nptr->realbox);nptr=nptr->realbox) ; }
#ifdef lint
   else 
      nptr = NULL ;
#endif

   if ((ptr)&&(!nptr))   /* find default value */
      nptr = ptr ;

   foundflag = (ptr)&&(nptr)&&(nptr->flag & VFLAG_BOTH) ;
   if (ptr && nptr)
      expand_to_str( nptr ) ;

   if (foundflag)
      value = (nptr)->value ;
   else
   {
      if (!ignore_novalue)
         condition_hook( SIGNAL_NOVALUE, 0, -1, Str_dup(name) ) ;

      if (ovalue)
         Free_string( ovalue ) ;

      ovalue = value = Str_make( stop + 1 + Str_len(indexstr) ) ;
      Str_ncat( value, name, stop ) ;
      Str_cat( value, indexstr ) ;
   }

   thespot = NULL ;
   return( value ) ;
} 



/* 
 * This is the entry-level routine that will take the parameters,
 *  decide what kind of variable it is (simple, stem or compound) and
 *  call the appropriate routine to do the dirty work
 */
void setvalue( streng *name, streng *value )
{
   int i=0 ;

   assert( value->len <= value->max ) ;
/*   value = Str_dup(value ) ; */
   for (i=0;(i<Str_len(name))&&(name->value[i]!='.');i++) ;

   if (i==Str_len(name)) 
      setvalue_simple(name,value) ;
   else if ((i+1)==Str_len(name))
      setvalue_stem(name,value) ;
   else
      setvalue_compound(name,value) ;
}




     
void expose_var( streng* name )
{
   int i=0 ;
   static variableptr *table=NULL ;
   extern proclevel currlevel ;
   
   if (!table)
      table = create_new_varpool() ;

   if (!name) {
      currlevel->vars = table ;
      currlevel->varflag = 1 ;
      table = NULL ; 
/*      current_valid++ ; */
      return ; }

   for (i=0;(Str_in(name,i))&&(name->value[i]!='.');i++) ;

   if (i>=name->len) 
      expose_simple(table,name) ;
   else if (i==name->len-1)
      expose_stem(table,name) ;
   else
      expose_compound(table,name) ;
}   


streng *getvalue( streng *name, int foobar )
{
   char *cptr=NULL, *eptr=NULL ;

   cptr = name->value ;
   eptr = cptr + name->len ;
   for (; cptr<eptr && *cptr!='.'; cptr++) ;

   /* 
    * Setvalue_stem is equivalent to setvalue_simple 
    */
   if (cptr+1 >= eptr)
      return getvalue_simple(name) ;
   else
      return getvalue_compound(name) ;
}


void drop_var_simple( streng *name ) 
{
   variableptr ptr=NULL ;

   ptr = findsimple( name ) ;

   foundflag = 0 ;
   if (ptr)
   {
      foundflag = ptr->flag & VFLAG_BOTH ;
      ptr->flag = VFLAG_NONE ;
      if (ptr->value)
      {
         Free_string( ptr->value ) ;
         ptr->value = NULL ;
      }
      if (ptr->num)
      {
         Free( ptr->num->num ) ;
         Free( ptr->num ) ;
         ptr->num = NULL ;
      }
   }
}



void drop_var_stem( streng *name ) 
{
   variableptr ptr=NULL ;

   ptr = findsimple( name ) ;

   foundflag = 0 ;
   if (ptr)
   {
      foundflag = ptr->flag & VFLAG_BOTH ;
      ptr->flag = VFLAG_NONE ;
      if (ptr->value)
      {
         Free_string( ptr->value ) ;
         ptr->value = NULL ;
      }
      if (ptr->num)
      {
         Free( ptr->num->num ) ;
         Free( ptr->num ) ;
         ptr->num = NULL ;
      }

      assert(ptr->index) ;
      if (ptr->index)
         kill_index( ptr->index, 0, 1, NULL ) ;
   }
}



void drop_var_compound( streng *name ) 
{
   int hashv=0, baselength=1 ;
   variableptr ptr=NULL, nptr=NULL ;
   streng *indexstr=NULL ;
   extern proclevel currlevel ;
   int start=0 ;

   ptr = currlevel->vars[hashv=hashfunc(name,0,&start)] ;
   for (;(ptr)&&(Str_ncmp(ptr->name,name,Str_len(ptr->name)));ptr=ptr->next) ; 
   for (;(ptr)&&(ptr->realbox);ptr=ptr->realbox) ;
   indexstr = subst_index( name, ++start, currlevel->vars ) ;
   hashv = hashfunc( indexstr, 0, NULL ) ;

   if (subst)   /* trace it */
      tracecompound(name,baselength-1,indexstr, 'C') ;

   if (ptr) {   /* find spesific value */
      nptr = ((variableptr *)(ptr->index))[hashv] ;
      for (;(nptr)&&(Str_cmp(nptr->name,indexstr));nptr=nptr->next) ; 
      for (;(nptr)&&(nptr->realbox);nptr=nptr->realbox) ; }
#ifdef lint
   else
      nptr = NULL ;
#endif

   foundflag = ((ptr) && (nptr) && (nptr->flag & VFLAG_BOTH)) ;

   if ((ptr)&&(nptr))
   {
      nptr->flag = VFLAG_NONE ;
      if (nptr->value)
      {
         Free( nptr->value ) ;
         nptr->value = NULL ;
      }
      if (nptr->num)
      {
         Free( nptr->num->num ) ;
         Free( nptr->num ) ;
         nptr->num = NULL ;
      }
   }
   else
   {
      /* 
       * We are playing with the NULL-ptr ... take care !
       */
      setvalue_compound( name, NULL ) ;      
   }
}


void drop_var( streng *name ) 
{ 
   int i=0 ;

   for (i=0; (i<Str_len(name))&&(name->value[i]!='.'); i++ ) ;
   if (i==Str_len(name))
      drop_var_simple( name ) ;
   else if ((i+1)==Str_len(name))
      drop_var_stem( name ) ;
   else
      drop_var_compound( name ) ;   
}




void kill_variables( variableptr *array )
{
   current_valid-- ;
   assert(current_valid) ;

   kill_index( array, 1, 0, NULL ) ;
}




/* 
 * This is the shortcut method for retrieving the value of a variable. 
 * It requires you to have a nodeptr, which may contain a shortcut 
 * pointer into the variable pool. Unless, such a shortcut pointer is 
 * established, if possible.
 */
streng *shortcut( nodeptr this )  
{
   streng *result=NULL ;
   char ch=' ' ;
   variableptr vptr=NULL ;

   if ((vptr=this->u.varbx))
   { 
      if (vptr->valid==current_valid)
      {
         ch = 'V' ;
         for (;vptr && vptr->realbox; vptr=vptr->realbox) ;
         if (vptr->flag & VFLAG_STR)
            result = vptr->value ;
         else if (vptr->flag & VFLAG_NUM)
         {
            expand_to_str( vptr ) ;
            result = vptr->value ;
         }
         else
         {
            ch = 'L' ;
            result = vptr->name ;
            if (!ignore_novalue)
               condition_hook( SIGNAL_NOVALUE, 0, -1, Str_dup(result) ) ;
         }
         
         if (trace_stat=='I')
            tracevalue( result, ch ) ;

         assert( !result || result->len <= result->max ) ;
         return result ;
      }
      else
      {
         if (!--(vptr->hwired))
            if (!vptr->valid)
            {
#ifdef TRACEMEM
               if (vptr->prev)
                  vptr->prev->next = vptr->next ;
               if (vptr->next)
                  vptr->next->prev = vptr->prev ;
               else
                  first_invalid = vptr->prev ;
#endif
               Free( vptr ) ;
            }
         this->u.varbx = NULL ;
      }
   }

   result = getvalue( this->name, 1 ) ;
   if (thespot /*&& this->type==X_SIM_SYMBOL */)
   {
      thespot->hwired++ ;
      this->u.varbx = thespot ;
   }

   assert( !result || result->len <= result->max ) ;
   return result ;
}



int tellex=0 ;
num_descr *shortcutnum( nodeptr this )  
{
   variableptr vptr=NULL ;
   num_descr *result=NULL ;
   streng *resstr=NULL ;
   char ch=' ' ;

   if ((vptr=this->u.varbx))
   { 
      if (vptr->valid==current_valid)
      {
         for(; vptr && vptr->realbox; vptr=vptr->realbox) ;
         ch = 'V' ;
         if (vptr->flag & VFLAG_NUM)
         {
            result = vptr->num ;
            if (trace_stat=='I')
               tracenumber( result, 'V' ) ;
         }
         else if (vptr->flag & VFLAG_STR)
         {
            if (vptr->num) 
            {
               Free( vptr->num->num ) ;
               Free( vptr->num ) ;
            }
            if (trace_stat=='I')
               tracevalue( vptr->value, 'V' ) ;
            vptr->num = is_a_descr( vptr->value ) ;
            if (vptr->num)
               vptr->flag |= VFLAG_NUM ;
            result = vptr->num ;
         }
         else
         {
            result = NULL ;
            if (trace_stat=='I')
               tracevalue( this->name, 'L' ) ;
            if (!ignore_novalue)
               condition_hook( SIGNAL_NOVALUE, 0, -1, Str_dup(this->name) ) ;
         }
         return result ;
      }
      else
      {
         if (!--(vptr->hwired))
            if (!vptr->valid)
            {
#ifdef TRACEMEM
               if (vptr->prev)
                  vptr->prev->next = vptr->next ;
               if (vptr->next)
                  vptr->next->prev = vptr->prev ;
               else
                  first_invalid = vptr->prev ;
#endif
               Free( this->u.varbx ) ;
            }
         this->u.varbx = NULL ;
      }
   }

   resstr = getvalue( this->name, 1 ) ;
   if (thespot)
   {
      thespot->hwired++ ;
      this->u.varbx = thespot ;
      if (thespot->num)
      {
         if (thespot->flag & VFLAG_NUM)
            return thespot->num ;
         Free(thespot->num->num) ;
         Free(thespot->num) ;
         
      }
      thespot->num = is_a_descr( resstr ) ;
      if (thespot->num)
         thespot->flag |= VFLAG_NUM ;
   }
   else
   {
      if (odescr)
      {
         Free( odescr->num ) ;
         Free( odescr ) ;
      }
      return odescr = is_a_descr( resstr ) ;
   }

   return( thespot->num ) ;
}



void setshortcut( nodeptr this, streng *value ) 
{
   variableptr vptr=NULL ;

   assert( !value || value->len <= value->max ) ;
   if ((vptr=this->u.varbx))
   { 
      if (vptr->valid==current_valid)
      {
         for(; vptr && vptr->realbox; vptr=vptr->realbox) ;
         if (vptr->value)
            Free_string(vptr->value) ;
         if (vptr->num)
         {
            Free( vptr->num->num ) ;
            Free( vptr->num ) ;
            vptr->num = 0 ;
         }
         vptr->flag = value ? VFLAG_STR : VFLAG_NONE ;
         vptr->value = value ;
         return ;
      }
      else
      {
         if (!--(vptr->hwired))
            if (!vptr->valid)
            {
#ifdef TRACEMEM
               if (vptr->prev)
                  vptr->prev->next = vptr->next ;
               if (vptr->next)
                  vptr->next->prev = vptr->prev ;
               else
                  first_invalid = vptr->prev ;
#endif
               Free( this->u.varbx ) ;
            }
         this->u.varbx = NULL ;
      }
   }

   setvalue( this->name, value ) ;
   if (thespot)
   {
      thespot->hwired++ ;
      this->u.varbx = thespot ;
   }
   return ;
}



void setshortcutnum( nodeptr this, num_descr *value ) 
{
   variableptr vptr=NULL ;
   
   assert( value->size ) ;

   if ((vptr=this->u.varbx))
   { 
      if (vptr->valid==current_valid)
      {
         for(; vptr && vptr->realbox; vptr=vptr->realbox) ;
         if (vptr->num)
         {
            Free(vptr->num->num) ;
            Free(vptr->num ) ;
         }
         if (vptr->value)
         {
            Free_string( vptr->value ) ;
            vptr->value = NULL ;
         }
         vptr->flag = value ? VFLAG_NUM : VFLAG_NONE ;
         vptr->num = value ;
         return ;
      }
      else
      {
         if (!--(vptr->hwired))
            if (!vptr->valid)
            {
#ifdef TRACEMEM
               if (vptr->prev)
                  vptr->prev->next = vptr->next ;
               if (vptr->next)
                  vptr->next->prev = vptr->prev ;
               else
                  first_invalid = vptr->prev ;
#endif
               Free( this->u.varbx ) ;
             }
         this->u.varbx = NULL ;
      }
   }

   setvalue( this->name, str_norm(value,NULL)) ;
   if (thespot)
   {
      thespot->hwired++ ;
      if (value)
      {
         if (thespot->num)
         {
            Free( thespot->num->num ) ;
            Free( thespot->num ) ;
         }
         thespot->num = value ; 
         thespot->flag |= VFLAG_NUM ;
      }
      this->u.varbx = thespot ;
   }
   else
   {
      Free( value->num ) ;
      Free( value ) ;
   }
   return ;
}



streng *fix_compound( nodeptr this, streng *new )
{
   variableptr iptr=NULL, ptr=NULL ;
   extern proclevel currlevel ;
   streng *value=NULL ;
   streng *indeks=NULL ;
   int hhash=0, thash=0 ;

   value = NULL ;
   hhash = -400000 ;   /* Intentionally erroneous */

   assert( !new || new->len <= new->max ) ;

   iptr = this->u.varbx ;
   if (iptr)
   {
      if (iptr->valid!=current_valid)
      {
         if (!--iptr->hwired && !iptr->valid)
         {
#ifdef TRACEMEM
            if (iptr->prev)
               iptr->prev->next = iptr->next ;
            if (this->u.varbx->next)
               iptr->next->prev = iptr->prev ;
            else
               first_invalid = iptr->prev ;
#endif
            Free( iptr ) ;
         }
         iptr = this->u.varbx = NULL ;
      }
   }
    
   if (!iptr)
   {
      iptr = currlevel->vars[hhash=hashfunc(this->name,0,NULL)] ;
      for (;(iptr)&&(Str_cmp(iptr->name,this->name));iptr=iptr->next) ;
      for (;(iptr)&&(iptr->realbox);iptr=iptr->realbox) ;

      if (iptr)
      {
         this->u.varbx = iptr ;
         iptr->hwired++ ;
      }
      if (!iptr && new && this->p[0])
      {
         setvalue_simple( this->name, NULL ) ;
         iptr = thespot ;
         iptr->index = make_hash_table() ;
      }
   }
    
   assert( this->p[0] ) ;
   indeks = fix_index( this->p[0] ) ;
   
   if (subst)
      tracecompound( this->name, this->name->len-1, indeks, 'C' ) ;

   if (iptr)
   {
      ptr = iptr->index[thash=hashfunc(indeks,0,NULL)] ;
      for (;(ptr)&&(Str_cmp(ptr->name,indeks));ptr=ptr->next) ;
      for (;(ptr)&&(ptr->realbox);ptr=ptr->realbox) ;

      if (new)
      {
         foundflag = (ptr!=NULL) ;
         if (foundflag)
            REPLACE_VALUE( new, ptr ) 
         else
         {
            newbox( indeks, new, &iptr->index[thash]) ;
            iptr->index[thash]->stem = iptr ;
         }
      }
      else
      {
         foundflag = ptr && (ptr->flag & VFLAG_BOTH) ;
         if (ptr)
         {
            if (ptr->flag & VFLAG_STR)
               value = ptr->value ;
            else if (ptr->flag & VFLAG_NUM)
            {
               expand_to_str( ptr ) ;
               value = ptr->value ;
            }
            else 
               goto the_default ;
         }
         else if (iptr->flag & VFLAG_STR)
            value = iptr->value ;
         else if (iptr->flag & VFLAG_NUM)
         {
            expand_to_str( iptr ) ;
            value = ptr->value ;
         }
         else 
            goto the_default ;

         tracevalue( value, 'V' ) ;         
      }
   } 
   else
   {
      if (new)
      {
         iptr = newbox( this->name, NULL, &(currlevel->vars[hhash])) ;
         iptr->index = make_hash_table() ;
         thash = hashfunc(indeks,0,NULL) ;
         newbox( indeks, new, &(iptr->index[thash])) ;
         iptr->index[thash]->stem = iptr ;
      }
      else
      {
the_default:
         if (xvalue)
            Free_string( xvalue ) ;
         xvalue = Str_make( this->name->len + indeks->len ) ;
         xvalue = Str_cat( xvalue, this->name ) ;
         xvalue = Str_cat( xvalue, indeks ) ;
         tracevalue( xvalue, 'L' ) ;
         if (!ignore_novalue)
            condition_hook( SIGNAL_NOVALUE, 0, -1, Str_dup(xvalue) ) ;
         value = xvalue ;
      }
   }

   assert( !value || value->len <= value->max ) ;
   return value ;
}
   




num_descr *fix_compoundnum( nodeptr this, num_descr *new )
{
   variableptr iptr=NULL, ptr=NULL ;
   extern proclevel currlevel ;
   num_descr *value=NULL ;
   streng *indeks=NULL ;
   int hhash=0, thash=0 ;

   value = NULL ;
   hhash = -400000 ;   /* Intentionally erroneous */

   iptr = this->u.varbx ;
   if (iptr)
   {
      if (iptr->valid!=current_valid)
      {
         if (!--iptr->hwired && !iptr->valid)
         {
#ifdef TRACEMEM
            if (iptr->prev)
               iptr->prev->next = iptr->next ;
            if (this->u.varbx->next)
               iptr->next->prev = iptr->prev ;
            else
               first_invalid = iptr->prev ;
#endif
            Free( iptr ) ;
         }
         iptr = this->u.varbx = NULL ;
      }
   }
    
   if (!iptr)
   {
      iptr = currlevel->vars[hhash=hashfunc(this->name,0,NULL)] ;
      for (;(iptr)&&(Str_cmp(iptr->name,this->name));iptr=iptr->next) ;
      for (;(iptr)&&(iptr->realbox);iptr=iptr->realbox) ;

      if (iptr)
      {
         this->u.varbx = iptr ;
         iptr->hwired++ ;
      }
      if (!iptr && new && this->p[0])
      {
         setvalue_simple( this->name, NULL ) ;
         iptr = thespot ;
         iptr->index = make_hash_table() ;
      }
   }
    
   assert( this->p[0] ) ;
   indeks = fix_index( this->p[0] ) ;
   
   if (subst)
      tracecompound( this->name, this->name->len-1, indeks, 'C' ) ;

   if (iptr)
   {
      ptr = iptr->index[thash=hashfunc(indeks,0,NULL)] ;
      for (;(ptr)&&(Str_cmp(ptr->name,indeks));ptr=ptr->next) ;
      for (;(ptr)&&(ptr->realbox);ptr=ptr->realbox) ;

      if (new)
      {
         foundflag = (ptr!=NULL) ;
         if (foundflag)
            REPLACE_NUMBER( new, ptr ) 
         else
         {
            newbox( indeks, NULL, &iptr->index[thash]) ;
            iptr->index[thash]->stem = iptr ;
            iptr->index[thash]->num = new ;
            iptr->index[thash]->flag = VFLAG_NUM ;
         }
      }
      else
      {
         foundflag = ptr && (ptr->flag & VFLAG_BOTH) ;
         if (ptr)
         {
            if (ptr->flag & VFLAG_NUM)
            {
               value = ptr->num ;
               tracenumber( value, 'V' ) ;
            }
            else if (ptr->flag & VFLAG_STR)
            {
               if (ptr->num)
               {
                  Free( ptr->num->num ) ;
                  Free( ptr->num ) ;
               }
               ptr->num = is_a_descr( ptr->value ) ;
               if ((value=ptr->num))
               {
                  tracevalue( ptr->value, 'V' ) ;
                  ptr->flag |= VFLAG_NUM ;
               }
            }
            else 
               goto the_default ;
         }
         else if (iptr->flag & VFLAG_NUM)
         {
            value = iptr->num ;
            tracenumber( value, 'V' ) ;
         }
         else if (iptr->flag & VFLAG_STR)
         {
            if (iptr->num)
            {
               Free( iptr->num->num ) ;
               Free( iptr->num ) ;
            }
            iptr->num = is_a_descr( iptr->value ) ;
            if ((value=iptr->num))
            {
               iptr->flag |= VFLAG_NUM ;
               tracevalue( iptr->value, 'V' ) ;
            }
         }
         else 
            goto the_default ;
      }
         
   } 
   else
   {
      if (new)
      {
         iptr = newbox( this->name, NULL, &(currlevel->vars[hhash])) ;
         iptr->index = make_hash_table() ;
         thash = hashfunc(indeks,0,NULL) ;
         newbox( indeks, NULL, &(iptr->index[thash])) ;
         iptr->index[thash]->stem = iptr ;
         iptr->index[thash]->num = new ;
         iptr->index[thash]->flag = VFLAG_NUM ;
      }
      else
      {
the_default:
         tracecompound( this->name, this->name->len-1, indeks, 'L' ) ;
         return NULL ;
      }
   }


   return value ;
}
   



/* 
 * Yes, it does look kind of strange, basically it is sort of four for(;;)
 * loops having been reversed. 
 */

variableptr get_next_variable( int reset ) 
{
   static int stemidx=0, tailidx=0 ;
   static variableptr pstem=NULL, ptail=NULL ;
   extern proclevel currlevel ;
   variableptr retval=NULL ;

   if (reset)
   {
      pstem = ptail = NULL ;
      stemidx = tailidx = 0 ;
      return NULL ;
   }

   do {
      if (pstem)
      {
         if (pstem->index)
         {
            do {
               if (ptail)
               {
                  ptail = (retval=ptail)->next ;
                  return retval ;
               }
               if (tailidx<HASHTABLENGTH)
               {
                  ptail = pstem->index[tailidx] ;
               }
             } while (tailidx++ < HASHTABLENGTH) ;
         }

         ptail = NULL ;
         tailidx = 0 ;

         pstem = (retval=pstem)->next ; 
         return retval ;
      } 

      if (stemidx<HASHTABLENGTH)
      {
         pstem = currlevel->vars[stemidx] ;
         ptail = NULL ;
         tailidx = 0 ;
      }
   } while (stemidx++ < HASHTABLENGTH) ;

   return NULL ;
}

