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