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  */
dumpvarcontent(const tsd_t * TSD,FILE * fp,cvariableptr v,int exposed)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  */
get_realbox(cvariableptr p,int * exposed)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 or stdout in case of STDOUT_FOR_STDERR.
96  */
dumpvars(const tsd_t * TSD)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->elements,
115                 TSD->currlevel->vars->size,
116                 TSD->currlevel->vars->reads,
117                 TSD->currlevel->vars->writes,
118                 TSD->currlevel->vars->collisions);
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->elements,
145                       rb->index->size,
146                       rb->index->reads,
147                       rb->index->writes,
148                       rb->index->collisions);
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 
dumptree(const tsd_t * TSD,const treenode * thisNode,int level,int newline)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
marksource(clineboxptr ptr)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 
sourceline(int line,const internal_parser_type * ipt,unsigned * size)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 
getsourceline(const tsd_t * TSD,int line,int charnr,const internal_parser_type * ipt)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 
436