regina/debug.c

   1 /*
   2  *  The Regina Rexx Interpreter
   3  *  Copyright (C) 1992-1994  Anders Christensen <anders@pvv.unit.no>
   4  *
   5  *  This library is free software; you can redistribute it and/or
   6  *  modify it under the terms of the GNU Library General Public
   7  *  License as published by the Free Software Foundation; either
   8  *  version 2 of the License, or (at your option) any later version.
   9  *
  10  *  This library is distributed in the hope that it will be useful,
  11  *  but WITHOUT ANY WARRANTY; without even the implied warranty of
  12  *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13  *  Library General Public License for more details.
  14  *
  15  *  You should have received a copy of the GNU Library General Public
  16  *  License along with this library; if not, write to the Free
  17  *  Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  18  */
  19
  20 #include <stdio.h>
  21 #include <string.h>
  22 #include <assert.h>
  23 #include "rexx.h"
  24
  25 #ifndef NDEBUG
  26
  27 /*
  28  * Prints the value of v to fp. ", number ???" may be appended if v is a number.
  29  * In addition, the helper fields are printed and the line is terminated.
  30  */
  31 void dumpvarcontent( const tsd_t *TSD, FILE *fp, cvariableptr v, int exposed )
  32 {
  33    const streng *s;
  34    const num_descr *n;
  35
  36    s = v->value;
  37    if ( s )
  38    {
  39       fprintf( fp, "\"%.*s\"", s->len, s->value );
  40    }
  41    else
  42    {
  43       fprintf( fp, "<none>" );
  44    }
  45
  46    n = v->num;
  47    fprintf( fp, ",\tnumber " );
  48    if ( n ) /* variable is a number */
  49    {
  50       fprintf( fp, "%s0.%.*sE%+d",
  51                ( n->negative ) ? "-" : "",
  52                n->size, n->num, n->exp );
  53    }
  54    else
  55    {
  56       fprintf( fp, "<none>" );
  57    }
  58
  59    switch ( v->flag )
  60    {
  61       case VFLAG_NONE: fprintf( fp, ",\tflag NONE, " ); break;
  62       case VFLAG_STR:  fprintf( fp, ",\tflag STR,  " );  break;
  63       case VFLAG_NUM:  fprintf( fp, ",\tflag NUM,  " );  break;
  64       case VFLAG_BOTH: fprintf( fp, ",\tflag BOTH, " ); break;
  65       default:         fprintf( fp, ",\tflag %d, ", v->flag );
  66    }
  67    fprintf( fp, "hwired %ld, valid %ld, guard %d%s%s\n",
  68                 v->hwired, v->valid, v->guard,
  69                 ( exposed ) ? ", exposed" : "",
  70                 ( v->flag == VFLAG_NONE ) ? ", dropped" : "" );
  71 }
  72
  73 /*
  74  * get_realbox returns either p or the realbox associated with p if it exists.
  75  * This function is NULL-pointer safe.
  76  * *exposed is set to 0 if p is set in the current frame, it is set to 1 if p
  77  * is an exposed value from one of the upper frames.
  78  */
  79 static cvariableptr get_realbox( cvariableptr p, int *exposed )
  80 {
  81    *exposed = 0;
  82    if ( p == NULL )
  83       return p;
  84    if ( p->realbox == NULL )
  85       return p;
  86
  87    *exposed = 1;
  88    for ( p = p->realbox; p->realbox; p = p->realbox )
  89       ;
  90    return p;
  91 }
  92
  93 /*
  94  * dumpvars dumps the set of valid variables of the current PROCEDURE frame.
  95  * The destination is stderr of stdout in case of STDOUT_FOR_STDERR.
  96  */
  97 void dumpvars( const tsd_t *TSD )
  98 {
  99    cvariableptr ptr,tptr,rb,trb;
 100    int isstem,isexposed;
 101    unsigned i,j;
 102    FILE *fp;
 103    streng *s;
 104    cvariableptr *hashptr;
 105
 106    fp = stderr;
 107    if ( get_options_flag( TSD->currlevel, EXT_STDOUT_FOR_STDERR ) )
 108       fp = stdout;
 109
 110    hashptr = (cvariableptr *) TSD->currlevel->vars->tbl;
 111
 112    fprintf( fp, "\nDumping variables, 1. no after \">>>\" is the bin number\n" );
 113    fprintf( fp, "[ %u elements in %u buckets, %u reads, %u writes, %u collisions ]\n",
 114                 TSD->currlevel->vars->e,
 115                 TSD->currlevel->vars->size,
 116                 TSD->currlevel->vars->r,
 117                 TSD->currlevel->vars->w,
 118                 TSD->currlevel->vars->c);
 119    for ( i = 0; i < TSD->currlevel->vars->size; i++ )
 120    {
 121       if ( hashptr[i] == NULL )
 122          continue;
 123
 124       /*
 125        * One bin of same hashvalues may have several vars connected by a
 126        * simple linked list.
 127        */
 128       for ( ptr = hashptr[i]; ptr != NULL; ptr = ptr->next )
 129       {
 130          rb = get_realbox( ptr, &isexposed );
 131          s = rb->name;
 132          isstem = s->value[s->len - 1] == '.';
 133
 134          fprintf( fp, "   >>> %3d %s \"%.*s\",\tvalue ",
 135                       i, ( isstem ) ? "    Stem" : "Variable",
 136                       s->len, s->value );
 137
 138          dumpvarcontent( TSD, fp, rb, isexposed );
 139
 140          if ( !isstem )
 141             continue;
 142
 143          fprintf( fp, "   [ %u elements in %u buckets, %u reads, %u writes, %u collisions ]\n",
 144                       rb->index->e,
 145                       rb->index->size,
 146                       rb->index->r,
 147                       rb->index->w,
 148                       rb->index->c);
 149          for ( j = 0; j < rb->index->size; j++ )
 150          {
 151             /*
 152              * The variables of a stem are organized as a normal variable
 153              * bunch. We have to iterate as for the level's variable set.
 154              * Keep in mind that a variable "a.b." isn't a stem, we can't
 155              * iterate once more.
 156              */
 157             if ( ( tptr = rb->index->tbl[j] ) != NULL )
 158             {
 159                for ( ; tptr; tptr = tptr->next )
 160                {
 161                   trb = get_realbox( tptr, &isexposed );
 162                   s = trb->name;
 163                   if ( s )
 164                   {
 165                      fprintf( fp, "      >>> %3d  Tail \"%.*s\",\tvalue ",
 166                                   j, s->len, s->value );
 167                      dumpvarcontent( TSD, fp, trb, isexposed );
 168                   }
 169                }
 170             }
 171          }
 172       }
 173    }
 174
 175    return;
 176 }
 177
 178 void dumptree(const tsd_t *TSD, const treenode *thisNode, int level, int newline)
 179 {
 180    unsigned i;
 181    streng *ptr;
 182    FILE *fp=stderr;
 183
 184    if ( get_options_flag( TSD->currlevel, EXT_STDOUT_FOR_STDERR ) )
 185       fp = stdout;
 186
 187    while ( thisNode ) {
 188       if ( newline )
 189          fprintf( fp, "\n%*s", 2 * level, "" );
 190
 191       fprintf( fp, "%s (type %d)\n",
 192                    getsym( thisNode->type ), thisNode->type );
 193
 194       if ( thisNode->name )
 195       {
 196          fprintf( fp, "%*sName: [%.*s]\n",
 197                       2 * level, "",
 198                       thisNode->name->len, thisNode->name->value );
 199       }
 200
 201       if ( ( thisNode->charnr != 0 ) && (thisNode->charnr != -1 ) )
 202       {
 203          fprintf( fp, "%*sLineno: %d   Charno: %d",
 204                       2 * level, "",
 205                       thisNode->lineno, thisNode->charnr );
 206          if ( newline )
 207          {
 208             ptr = getsourceline( TSD, thisNode->lineno, thisNode->charnr,
 209                                 &TSD->systeminfo->tree );
 210             fprintf( fp, ", Sourceline: [%.*s]", ptr->len, ptr->value );
 211          }
 212          putc( '\n', fp );
 213       }
 214
 215       /*
 216        * See also several places in instore.c where thisNode switch list must be
 217        * changed. Seek for X_CEXPRLIST.
 218        */
 219       switch ( thisNode->type )
 220       {
 221          case X_EQUAL:
 222          case X_DIFF:
 223          case X_GT:
 224          case X_GTE:
 225          case X_LT:
 226          case X_LTE:
 227             fprintf( fp, "%*sFlags: lnum %d, rnum %d, lsvar %d, rsvar %d, lcvar %d, rcvar %d\n",
 228                          2 * level, "",
 229                          thisNode->u.flags.lnum,
 230                          thisNode->u.flags.rnum,
 231                          thisNode->u.flags.lsvar,
 232                          thisNode->u.flags.rsvar,
 233                          thisNode->u.flags.lcvar,
 234                          thisNode->u.flags.rcvar );
 235             break;
 236
 237          case X_ADDR_V:
 238             fprintf( fp, "%*sFlags: %sANSI version\n",
 239                          2 * level, "",
 240                          ( thisNode->u.nonansi ) ? "non-" : "" );
 241             break;
 242
 243          case X_CEXPRLIST:
 244             if ( thisNode->u.strng == NULL )
 245                fprintf( fp, "%*sValue: <null>\n",
 246                             2 * level, "" );
 247             else
 248                fprintf( fp, "%*sValue: [%.*s]\n",
 249                             2 * level, "",
 250                             thisNode->u.strng->len, thisNode->u.strng->value );
 251             break;
 252
 253          case X_LABEL:
 254             fprintf( fp, "%*sFlags: %s\n",
 255                          2 * level, "",
 256                          ( thisNode->u.trace_only ) ? "trace-only" :
 257                                                   "is target" );
 258             break;
 259
 260          case X_PARSE:
 261             /*
 262              * similar to bug 972850, fixed in parallel
 263              */
 264             fprintf( fp, "%*sFlags: %s\n",
 265                          2 * level, "",
 266                          ( thisNode->u.parseflags == PARSE_UPPER) ? "UPPER" :
 267                          ( thisNode->u.parseflags == PARSE_LOWER) ? "LOWER" :
 268                          ( thisNode->u.parseflags == PARSE_CASELESS) ? "CASELESS" :
 269                          ( thisNode->u.parseflags == (PARSE_CASELESS | PARSE_LOWER)) ? "CASELESS LOWER" :
 270                          ( thisNode->u.parseflags == (PARSE_CASELESS | PARSE_UPPER)) ? "CASELESS UPPER" :
 271                                                                  "(normal)" );
 272             break;
 273
 274          case X_ADDR_WITH:
 275             if ( !thisNode->p[0] && !thisNode->p[1] && !thisNode->p[2] )
 276                fprintf( fp, "%*sFlags: append %d, awt %s, ant %s\n",
 277                             2 * level, "",
 278                             thisNode->u.of.append,
 279                             ( thisNode->u.of.awt == awtUNKNOWN ) ? "unknown" :
 280                             ( thisNode->u.of.awt == awtSTREAM ) ?  "STREAM" :
 281                             ( thisNode->u.of.awt == awtSTEM ) ?    "STEM" :
 282                             ( thisNode->u.of.awt == awtLIFO ) ?    "LIFO" :
 283                             ( thisNode->u.of.awt == awtFIFO ) ?    "FIFO" :
 284                                                                "<error>",
 285                             ( thisNode->u.of.ant == antUNKNOWN )   ? "unknown" :
 286                             ( thisNode->u.of.ant == antSTRING )    ? "STRING" :
 287                             ( thisNode->u.of.ant == antSIMSYMBOL ) ? "SYMBOL" :
 288                                                                  "<error>" );
 289             break;
 290
 291          default:
 292             break;
 293       }
 294
 295       for ( i = 0; i < sizeof( thisNode->p ) / sizeof( thisNode->p[0] ); i++ )
 296          if ( thisNode->p[i] != NULL )
 297          {
 298             fprintf( fp, "%*s%d>",
 299                          2 * level, "",
 300                          i + 1 );
 301             dumptree( TSD, thisNode->p[i], level + 1, 0 );
 302          }
 303
 304       thisNode = thisNode->next;
 305       newline = 1;
 306    }
 307 }
 308
 309 #endif /* !NDEBUG */
 310
 311
 312 #ifdef TRACEMEM
 313 void marksource( clineboxptr ptr )
 314 {
 315    for (;ptr;ptr=ptr->next) {
 316       markmemory( ptr->line,TRC_SOURCEL ) ;
 317       markmemory( (char *)ptr, TRC_SOURCE ) ; }
 318 }
 319 #endif
 320
 321
 322 static const char *sourceline( int line, const internal_parser_type *ipt, unsigned *size)
 323 {
 324    clineboxptr first;
 325    const otree *otp;
 326
 327    if (ipt->first_source_line == NULL)
 328    { /* must be incore_source but that value may be NULL because of a failed
 329       * instore[0] of RexxStart!
 330       */
 331       otp = ipt->srclines; /* NULL if incore_source==NULL */
 332       while (otp && (otp->num < (unsigned long) line)) {
 333          line -= otp->num;
 334          otp = otp->next;
 335       }
 336       if (otp == NULL)
 337       {
 338          *size = 0 ;
 339          return NULL ;
 340       }
 341       line--;
 342       *size = otp->elems[line].length ;
 343       return ipt->incore_source + otp->elems[line].offset ;
 344    }
 345    first = ipt->first_source_line;
 346    for (;first;)
 347    {
 348       if (first->lineno==line)
 349       {
 350          *size = first->line->len ;
 351          return first->line->value ;
 352       }
 353       else
 354          first = (first->lineno<line) ? first->next : first->prev ;
 355    }
 356
 357    *size = 0 ;
 358    return NULL ;
 359 }
 360
 361
 362
 363 streng *getsourceline( const tsd_t *TSD, int line, int charnr, const internal_parser_type *ipt )
 364 {
 365    int dquote=0, squote=0 ;
 366    unsigned len ;
 367    streng *string ;
 368    const char *ptr, *chptr, *chend, *tmptr ;
 369    char *outptr ;
 370    char *STR_VAL_LIMIT ;
 371
 372    assert( charnr>=0 ) ;
 373    if (!charnr)
 374      charnr++ ;
 375
 376    ptr = sourceline(line,ipt,&len) ;
 377 /*   assert( ptr ) ; */
 378    if (!ptr || (charnr >= (int) len))
 379       return nullstringptr() ;
 380
 381    chptr = ptr + --charnr ;
 382    chend = ptr + len ;
 383    for (; (chptr < chend) && rx_isspace(*chptr); chptr++) ;
 384    string = Str_makeTSD(BUFFERSIZE+1) ;
 385    outptr = string->value ;
 386    STR_VAL_LIMIT = BUFFERSIZE + outptr ;
 387
 388    for (;;)
 389    {
 390 restart:
 391       if (chptr>=chend || outptr >= STR_VAL_LIMIT)
 392          break ;
 393
 394       if (!squote && *chptr=='\"')
 395          dquote = !dquote ;
 396
 397       else if (!dquote && *chptr=='\'')
 398          squote = !squote ;
 399
 400       else if (!(dquote || squote))
 401       {
 402          switch (*chptr)
 403          {
 404             case ',':
 405                for(tmptr=chptr+1; tmptr<chend && rx_isspace(*tmptr); tmptr++ ) ;
 406                assert( tmptr<=chend ) ;
 407                if (tmptr==chend)
 408                {
 409                   *(outptr++) = ' ' ;
 410                   chptr = sourceline(++line,ipt,&len) ;
 411                   chend = chptr + len ;
 412                   for(; chptr<chend && rx_isspace(*chptr); chptr++) ;
 413                   goto restart;
 414                }
 415                break ;
 416
 417             case ':':
 418                *(outptr++) = *chptr ;
 419
 420             case ';':
 421                goto endloop ;
 422
 423          }
 424       }
 425
 426       *(outptr++) = *(chptr++) ;
 427    }
 428
 429 endloop:
 430    assert( outptr - string->value <= BUFFERSIZE ) ;
 431    *outptr = '\0'; /* needs to be 0-terminated */
 432    string->len = outptr - string->value ;
 433    return string ;
 434 }
 435