1 /* stt.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995, 1997 Free Software Foundation, Inc.
3 Contributed by James Craig Burley.
4
5 This file is part of GNU Fortran.
6
7 GNU Fortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
10 any later version.
11
12 GNU Fortran is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with GNU Fortran; see the file COPYING. If not, write to
19 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
20 02111-1307, USA.
21
22 Related Modules:
23 None
24
25 Description:
26 Manages lists of tokens and related info for parsing.
27
28 Modifications:
29 */
30
31 /* Include files. */
32
33 #include "proj.h"
34 #include "stt.h"
35 #include "bld.h"
36 #include "expr.h"
37 #include "info.h"
38 #include "lex.h"
39 #include "malloc.h"
40 #include "sta.h"
41 #include "stp.h"
42
43 /* Externals defined here. */
44
45
46 /* Simple definitions and enumerations. */
47
48
49 /* Internal typedefs. */
50
51
52 /* Private include files. */
53
54
55 /* Internal structure definitions. */
56
57
58 /* Static objects accessed by functions in this module. */
59
60
61 /* Static functions (internal). */
62
63
64 /* Internal macros. */
65
66
67 /* ffestt_caselist_append -- Append case to list of cases
68
69 ffesttCaseList list;
70 ffelexToken t;
71 ffestt_caselist_append(list,range,case1,case2,t);
72
73 list must have already been created by ffestt_caselist_create. The
74 list is allocated out of the scratch pool. The token is consumed. */
75
76 void
ffestt_caselist_append(ffesttCaseList list,bool range,ffebld case1,ffebld case2,ffelexToken t)77 ffestt_caselist_append (ffesttCaseList list, bool range, ffebld case1,
78 ffebld case2, ffelexToken t)
79 {
80 ffesttCaseList new;
81
82 new = (ffesttCaseList) malloc_new_kp (ffesta_scratch_pool,
83 "FFEST case list", sizeof (*new));
84 new->next = list->previous->next;
85 new->previous = list->previous;
86 new->next->previous = new;
87 new->previous->next = new;
88 new->expr1 = case1;
89 new->expr2 = case2;
90 new->range = range;
91 new->t = t;
92 }
93
94 /* ffestt_caselist_create -- Create new list of cases
95
96 ffesttCaseList list;
97 list = ffestt_caselist_create();
98
99 The list is allocated out of the scratch pool. */
100
101 ffesttCaseList
ffestt_caselist_create()102 ffestt_caselist_create ()
103 {
104 ffesttCaseList new;
105
106 new = (ffesttCaseList) malloc_new_kp (ffesta_scratch_pool,
107 "FFEST case list root",
108 sizeof (*new));
109 new->next = new->previous = new;
110 new->t = NULL;
111 new->expr1 = NULL;
112 new->expr2 = NULL;
113 new->range = FALSE;
114 return new;
115 }
116
117 /* ffestt_caselist_kill -- Kill list of cases
118
119 ffesttCaseList list;
120 ffestt_caselist_kill(list);
121
122 The tokens on the list are killed.
123
124 02-Mar-90 JCB 1.1
125 Don't kill the list itself or change it, since it will be trashed when
126 ffesta_scratch_pool is killed anyway, so kill only the lex tokens. */
127
128 void
ffestt_caselist_kill(ffesttCaseList list)129 ffestt_caselist_kill (ffesttCaseList list)
130 {
131 ffesttCaseList next;
132
133 for (next = list->next; next != list; next = next->next)
134 {
135 ffelex_token_kill (next->t);
136 }
137 }
138
139 /* ffestt_dimlist_append -- Append dim to list of dims
140
141 ffesttDimList list;
142 ffelexToken t;
143 ffestt_dimlist_append(list,lower,upper,t);
144
145 list must have already been created by ffestt_dimlist_create. The
146 list is allocated out of the scratch pool. The token is consumed. */
147
148 void
ffestt_dimlist_append(ffesttDimList list,ffebld lower,ffebld upper,ffelexToken t)149 ffestt_dimlist_append (ffesttDimList list, ffebld lower, ffebld upper,
150 ffelexToken t)
151 {
152 ffesttDimList new;
153
154 new = (ffesttDimList) malloc_new_kp (ffesta_scratch_pool,
155 "FFEST dim list", sizeof (*new));
156 new->next = list->previous->next;
157 new->previous = list->previous;
158 new->next->previous = new;
159 new->previous->next = new;
160 new->lower = lower;
161 new->upper = upper;
162 new->t = t;
163 }
164
165 /* Convert list of dims into ffebld format.
166
167 ffesttDimList list;
168 ffeinfoRank rank;
169 ffebld array_size;
170 ffebld extents;
171 ffestt_dimlist_as_expr (list, &rank, &array_size, &extents);
172
173 The dims in the list are converted to a list of ITEMs; the rank of the
174 array, an expression representing the array size, a list of extent
175 expressions, and the list of ITEMs are returned.
176
177 If is_ugly_assumed, treat a final dimension with no lower bound
178 and an upper bound of 1 as a * bound. */
179
180 ffebld
ffestt_dimlist_as_expr(ffesttDimList list,ffeinfoRank * rank,ffebld * array_size,ffebld * extents,bool is_ugly_assumed)181 ffestt_dimlist_as_expr (ffesttDimList list, ffeinfoRank *rank,
182 ffebld *array_size, ffebld *extents,
183 bool is_ugly_assumed)
184 {
185 ffesttDimList next;
186 ffebld expr;
187 ffebld as;
188 ffebld ex; /* List of extents. */
189 ffebld ext; /* Extent of a given dimension. */
190 ffebldListBottom bottom;
191 ffeinfoRank r;
192 ffeinfoKindtype nkt;
193 ffetargetIntegerDefault low;
194 ffetargetIntegerDefault high;
195 bool zero = FALSE; /* Zero-size array. */
196 bool any = FALSE;
197 bool star = FALSE; /* Adjustable array. */
198
199 assert (list != NULL);
200
201 r = 0;
202 ffebld_init_list (&expr, &bottom);
203 for (next = list->next; next != list; next = next->next)
204 {
205 ++r;
206 if (((next->lower == NULL)
207 || (ffebld_op (next->lower) == FFEBLD_opCONTER))
208 && (ffebld_op (next->upper) == FFEBLD_opCONTER))
209 {
210 if (next->lower == NULL)
211 low = 1;
212 else
213 low = ffebld_constant_integerdefault (ffebld_conter (next->lower));
214 high = ffebld_constant_integerdefault (ffebld_conter (next->upper));
215 if (low
216 > high)
217 zero = TRUE;
218 if ((next->next == list)
219 && is_ugly_assumed
220 && (next->lower == NULL)
221 && (high == 1)
222 && (ffebld_conter_orig (next->upper) == NULL))
223 {
224 star = TRUE;
225 ffebld_append_item (&bottom,
226 ffebld_new_bounds (NULL, ffebld_new_star ()));
227 continue;
228 }
229 }
230 else if (((next->lower != NULL)
231 && (ffebld_op (next->lower) == FFEBLD_opANY))
232 || (ffebld_op (next->upper) == FFEBLD_opANY))
233 any = TRUE;
234 else if (ffebld_op (next->upper) == FFEBLD_opSTAR)
235 star = TRUE;
236 ffebld_append_item (&bottom,
237 ffebld_new_bounds (next->lower, next->upper));
238 }
239 ffebld_end_list (&bottom);
240
241 if (zero)
242 {
243 as = ffebld_new_conter (ffebld_constant_new_integerdefault_val (0));
244 ffebld_set_info (as, ffeinfo_new
245 (FFEINFO_basictypeINTEGER,
246 FFEINFO_kindtypeINTEGERDEFAULT,
247 0,
248 FFEINFO_kindENTITY,
249 FFEINFO_whereCONSTANT,
250 FFETARGET_charactersizeNONE));
251 ex = NULL;
252 }
253 else if (any)
254 {
255 as = ffebld_new_any ();
256 ffebld_set_info (as, ffeinfo_new_any ());
257 ex = ffebld_copy (as);
258 }
259 else if (star)
260 {
261 as = ffebld_new_star ();
262 ex = ffebld_new_star (); /* ~~Should really be list as below. */
263 }
264 else
265 {
266 as = NULL;
267 ffebld_init_list (&ex, &bottom);
268 for (next = list->next; next != list; next = next->next)
269 {
270 if ((next->lower == NULL)
271 || ((ffebld_op (next->lower) == FFEBLD_opCONTER)
272 && (ffebld_constant_integerdefault (ffebld_conter
273 (next->lower)) == 1)))
274 ext = ffebld_copy (next->upper);
275 else
276 {
277 ext = ffebld_new_subtract (next->upper, next->lower);
278 nkt
279 = ffeinfo_kindtype_max (FFEINFO_basictypeINTEGER,
280 ffeinfo_kindtype (ffebld_info
281 (next->lower)),
282 ffeinfo_kindtype (ffebld_info
283 (next->upper)));
284 ffebld_set_info (ext,
285 ffeinfo_new (FFEINFO_basictypeINTEGER,
286 nkt,
287 0,
288 FFEINFO_kindENTITY,
289 ((ffebld_op (ffebld_left (ext))
290 == FFEBLD_opCONTER)
291 && (ffebld_op (ffebld_right
292 (ext))
293 == FFEBLD_opCONTER))
294 ? FFEINFO_whereCONSTANT
295 : FFEINFO_whereFLEETING,
296 FFETARGET_charactersizeNONE));
297 ffebld_set_left (ext,
298 ffeexpr_convert_expr (ffebld_left (ext),
299 next->t, ext, next->t,
300 FFEEXPR_contextLET));
301 ffebld_set_right (ext,
302 ffeexpr_convert_expr (ffebld_right (ext),
303 next->t, ext,
304 next->t,
305 FFEEXPR_contextLET));
306 ext = ffeexpr_collapse_subtract (ext, next->t);
307
308 nkt
309 = ffeinfo_kindtype_max (FFEINFO_basictypeINTEGER,
310 ffeinfo_kindtype (ffebld_info (ext)),
311 FFEINFO_kindtypeINTEGERDEFAULT);
312 ext
313 = ffebld_new_add (ext,
314 ffebld_new_conter
315 (ffebld_constant_new_integerdefault_val
316 (1)));
317 ffebld_set_info (ffebld_right (ext), ffeinfo_new
318 (FFEINFO_basictypeINTEGER,
319 FFEINFO_kindtypeINTEGERDEFAULT,
320 0,
321 FFEINFO_kindENTITY,
322 FFEINFO_whereCONSTANT,
323 FFETARGET_charactersizeNONE));
324 ffebld_set_info (ext,
325 ffeinfo_new (FFEINFO_basictypeINTEGER,
326 nkt, 0, FFEINFO_kindENTITY,
327 (ffebld_op (ffebld_left (ext))
328 == FFEBLD_opCONTER)
329 ? FFEINFO_whereCONSTANT
330 : FFEINFO_whereFLEETING,
331 FFETARGET_charactersizeNONE));
332 ffebld_set_left (ext,
333 ffeexpr_convert_expr (ffebld_left (ext),
334 next->t, ext,
335 next->t,
336 FFEEXPR_contextLET));
337 ffebld_set_right (ext,
338 ffeexpr_convert_expr (ffebld_right (ext),
339 next->t, ext,
340 next->t,
341 FFEEXPR_contextLET));
342 ext = ffeexpr_collapse_add (ext, next->t);
343 }
344 ffebld_append_item (&bottom, ext);
345 if (as == NULL)
346 as = ext;
347 else
348 {
349 nkt
350 = ffeinfo_kindtype_max (FFEINFO_basictypeINTEGER,
351 ffeinfo_kindtype (ffebld_info (as)),
352 ffeinfo_kindtype (ffebld_info (ext)));
353 as = ffebld_new_multiply (as, ext);
354 ffebld_set_info (as,
355 ffeinfo_new (FFEINFO_basictypeINTEGER,
356 nkt, 0, FFEINFO_kindENTITY,
357 ((ffebld_op (ffebld_left (as))
358 == FFEBLD_opCONTER)
359 && (ffebld_op (ffebld_right
360 (as))
361 == FFEBLD_opCONTER))
362 ? FFEINFO_whereCONSTANT
363 : FFEINFO_whereFLEETING,
364 FFETARGET_charactersizeNONE));
365 ffebld_set_left (as,
366 ffeexpr_convert_expr (ffebld_left (as),
367 next->t, as, next->t,
368 FFEEXPR_contextLET));
369 ffebld_set_right (as,
370 ffeexpr_convert_expr (ffebld_right (as),
371 next->t, as,
372 next->t,
373 FFEEXPR_contextLET));
374 as = ffeexpr_collapse_multiply (as, next->t);
375 }
376 }
377 ffebld_end_list (&bottom);
378 as = ffeexpr_convert (as, list->next->t, NULL,
379 FFEINFO_basictypeINTEGER,
380 FFEINFO_kindtypeINTEGERDEFAULT, 0,
381 FFETARGET_charactersizeNONE,
382 FFEEXPR_contextLET);
383 }
384
385 *rank = r;
386 *array_size = as;
387 *extents = ex;
388 return expr;
389 }
390
391 /* ffestt_dimlist_create -- Create new list of dims
392
393 ffesttDimList list;
394 list = ffestt_dimlist_create();
395
396 The list is allocated out of the scratch pool. */
397
398 ffesttDimList
ffestt_dimlist_create()399 ffestt_dimlist_create ()
400 {
401 ffesttDimList new;
402
403 new = (ffesttDimList) malloc_new_kp (ffesta_scratch_pool,
404 "FFEST dim list root", sizeof (*new));
405 new->next = new->previous = new;
406 new->t = NULL;
407 new->lower = NULL;
408 new->upper = NULL;
409 return new;
410 }
411
412 /* ffestt_dimlist_kill -- Kill list of dims
413
414 ffesttDimList list;
415 ffestt_dimlist_kill(list);
416
417 The tokens on the list are killed. */
418
419 void
ffestt_dimlist_kill(ffesttDimList list)420 ffestt_dimlist_kill (ffesttDimList list)
421 {
422 ffesttDimList next;
423
424 for (next = list->next; next != list; next = next->next)
425 {
426 ffelex_token_kill (next->t);
427 }
428 }
429
430 /* Determine type of list of dimensions.
431
432 Return KNOWN for all-constant bounds, ADJUSTABLE for constant
433 and variable but no * bounds, ASSUMED for constant and * but
434 not variable bounds, ADJUSTABLEASSUMED for constant and variable
435 and * bounds.
436
437 If is_ugly_assumed, treat a final dimension with no lower bound
438 and an upper bound of 1 as a * bound. */
439
440 ffestpDimtype
ffestt_dimlist_type(ffesttDimList list,bool is_ugly_assumed)441 ffestt_dimlist_type (ffesttDimList list, bool is_ugly_assumed)
442 {
443 ffesttDimList next;
444 ffestpDimtype type;
445
446 if (list == NULL)
447 return FFESTP_dimtypeNONE;
448
449 type = FFESTP_dimtypeKNOWN;
450 for (next = list->next; next != list; next = next->next)
451 {
452 bool ugly_assumed = FALSE;
453
454 if ((next->next == list)
455 && is_ugly_assumed
456 && (next->lower == NULL)
457 && (next->upper != NULL)
458 && (ffebld_op (next->upper) == FFEBLD_opCONTER)
459 && (ffebld_constant_integerdefault (ffebld_conter (next->upper))
460 == 1)
461 && (ffebld_conter_orig (next->upper) == NULL))
462 ugly_assumed = TRUE;
463
464 if (next->lower != NULL)
465 {
466 if (ffebld_op (next->lower) != FFEBLD_opCONTER)
467 {
468 if (type == FFESTP_dimtypeASSUMED)
469 type = FFESTP_dimtypeADJUSTABLEASSUMED;
470 else
471 type = FFESTP_dimtypeADJUSTABLE;
472 }
473 }
474 if (next->upper != NULL)
475 {
476 if (ugly_assumed
477 || (ffebld_op (next->upper) == FFEBLD_opSTAR))
478 {
479 if (type == FFESTP_dimtypeADJUSTABLE)
480 type = FFESTP_dimtypeADJUSTABLEASSUMED;
481 else
482 type = FFESTP_dimtypeASSUMED;
483 }
484 else if (ffebld_op (next->upper) != FFEBLD_opCONTER)
485 type = FFESTP_dimtypeADJUSTABLE;
486 }
487 }
488
489 return type;
490 }
491
492 /* ffestt_exprlist_append -- Append expr to list of exprs
493
494 ffesttExprList list;
495 ffelexToken t;
496 ffestt_exprlist_append(list,expr,t);
497
498 list must have already been created by ffestt_exprlist_create. The
499 list is allocated out of the scratch pool. The token is consumed. */
500
501 void
ffestt_exprlist_append(ffesttExprList list,ffebld expr,ffelexToken t)502 ffestt_exprlist_append (ffesttExprList list, ffebld expr, ffelexToken t)
503 {
504 ffesttExprList new;
505
506 new = (ffesttExprList) malloc_new_kp (ffesta_scratch_pool,
507 "FFEST expr list", sizeof (*new));
508 new->next = list->previous->next;
509 new->previous = list->previous;
510 new->next->previous = new;
511 new->previous->next = new;
512 new->expr = expr;
513 new->t = t;
514 }
515
516 /* ffestt_exprlist_create -- Create new list of exprs
517
518 ffesttExprList list;
519 list = ffestt_exprlist_create();
520
521 The list is allocated out of the scratch pool. */
522
523 ffesttExprList
ffestt_exprlist_create()524 ffestt_exprlist_create ()
525 {
526 ffesttExprList new;
527
528 new = (ffesttExprList) malloc_new_kp (ffesta_scratch_pool,
529 "FFEST expr list root", sizeof (*new));
530 new->next = new->previous = new;
531 new->expr = NULL;
532 new->t = NULL;
533 return new;
534 }
535
536 /* ffestt_exprlist_drive -- Drive list of token pairs into function
537
538 ffesttExprList list;
539 void fn(ffebld expr,ffelexToken t);
540 ffestt_exprlist_drive(list,fn);
541
542 The expr/token pairs in the list are passed to the function one pair
543 at a time. */
544
545 void
ffestt_exprlist_drive(ffesttExprList list,void (* fn)(ffebld,ffelexToken))546 ffestt_exprlist_drive (ffesttExprList list, void (*fn) (ffebld, ffelexToken))
547 {
548 ffesttExprList next;
549
550 if (list == NULL)
551 return;
552
553 for (next = list->next; next != list; next = next->next)
554 {
555 (*fn) (next->expr, next->t);
556 }
557 }
558
559 /* ffestt_exprlist_kill -- Kill list of exprs
560
561 ffesttExprList list;
562 ffestt_exprlist_kill(list);
563
564 The tokens on the list are killed.
565
566 02-Mar-90 JCB 1.1
567 Don't kill the list itself or change it, since it will be trashed when
568 ffesta_scratch_pool is killed anyway, so kill only the lex tokens. */
569
570 void
ffestt_exprlist_kill(ffesttExprList list)571 ffestt_exprlist_kill (ffesttExprList list)
572 {
573 ffesttExprList next;
574
575 for (next = list->next; next != list; next = next->next)
576 {
577 ffelex_token_kill (next->t);
578 }
579 }
580
581 /* ffestt_formatlist_append -- Append null format to list of formats
582
583 ffesttFormatList list, new;
584 new = ffestt_formatlist_append(list);
585
586 list must have already been created by ffestt_formatlist_create. The
587 new item is allocated out of the scratch pool. The caller must initialize
588 it appropriately. */
589
590 ffesttFormatList
ffestt_formatlist_append(ffesttFormatList list)591 ffestt_formatlist_append (ffesttFormatList list)
592 {
593 ffesttFormatList new;
594
595 new = (ffesttFormatList) malloc_new_kp (ffesta_scratch_pool,
596 "FFEST format list", sizeof (*new));
597 new->next = list->previous->next;
598 new->previous = list->previous;
599 new->next->previous = new;
600 new->previous->next = new;
601 return new;
602 }
603
604 /* ffestt_formatlist_create -- Create new list of formats
605
606 ffesttFormatList list;
607 list = ffestt_formatlist_create(NULL);
608
609 The list is allocated out of the scratch pool. */
610
611 ffesttFormatList
ffestt_formatlist_create(ffesttFormatList parent,ffelexToken t)612 ffestt_formatlist_create (ffesttFormatList parent, ffelexToken t)
613 {
614 ffesttFormatList new;
615
616 new = (ffesttFormatList) malloc_new_kp (ffesta_scratch_pool,
617 "FFEST format list root", sizeof (*new));
618 new->next = new->previous = new;
619 new->type = FFESTP_formattypeNone;
620 new->t = t;
621 new->u.root.parent = parent;
622 return new;
623 }
624
625 /* ffestt_formatlist_kill -- Kill tokens on list of formats
626
627 ffesttFormatList list;
628 ffestt_formatlist_kill(list);
629
630 The tokens on the list are killed. */
631
632 void
ffestt_formatlist_kill(ffesttFormatList list)633 ffestt_formatlist_kill (ffesttFormatList list)
634 {
635 ffesttFormatList next;
636
637 /* Always kill from the very top on down. */
638
639 while (list->u.root.parent != NULL)
640 list = list->u.root.parent->next;
641
642 /* Kill first token for this list. */
643
644 if (list->t != NULL)
645 ffelex_token_kill (list->t);
646
647 /* Kill each item in this list. */
648
649 for (next = list->next; next != list; next = next->next)
650 {
651 ffelex_token_kill (next->t);
652 switch (next->type)
653 {
654 case FFESTP_formattypeI:
655 case FFESTP_formattypeB:
656 case FFESTP_formattypeO:
657 case FFESTP_formattypeZ:
658 case FFESTP_formattypeF:
659 case FFESTP_formattypeE:
660 case FFESTP_formattypeEN:
661 case FFESTP_formattypeG:
662 case FFESTP_formattypeL:
663 case FFESTP_formattypeA:
664 case FFESTP_formattypeD:
665 if (next->u.R1005.R1004.t != NULL)
666 ffelex_token_kill (next->u.R1005.R1004.t);
667 if (next->u.R1005.R1006.t != NULL)
668 ffelex_token_kill (next->u.R1005.R1006.t);
669 if (next->u.R1005.R1007_or_R1008.t != NULL)
670 ffelex_token_kill (next->u.R1005.R1007_or_R1008.t);
671 if (next->u.R1005.R1009.t != NULL)
672 ffelex_token_kill (next->u.R1005.R1009.t);
673 break;
674
675 case FFESTP_formattypeQ:
676 case FFESTP_formattypeDOLLAR:
677 case FFESTP_formattypeP:
678 case FFESTP_formattypeT:
679 case FFESTP_formattypeTL:
680 case FFESTP_formattypeTR:
681 case FFESTP_formattypeX:
682 case FFESTP_formattypeS:
683 case FFESTP_formattypeSP:
684 case FFESTP_formattypeSS:
685 case FFESTP_formattypeBN:
686 case FFESTP_formattypeBZ:
687 case FFESTP_formattypeSLASH:
688 case FFESTP_formattypeCOLON:
689 if (next->u.R1010.val.t != NULL)
690 ffelex_token_kill (next->u.R1010.val.t);
691 break;
692
693 case FFESTP_formattypeR1016:
694 break; /* Nothing more to do. */
695
696 case FFESTP_formattypeFORMAT:
697 if (next->u.R1003D.R1004.t != NULL)
698 ffelex_token_kill (next->u.R1003D.R1004.t);
699 next->u.R1003D.format->u.root.parent = NULL; /* Parent already dying. */
700 ffestt_formatlist_kill (next->u.R1003D.format);
701 break;
702
703 default:
704 assert (FALSE);
705 }
706 }
707 }
708
709 /* ffestt_implist_append -- Append token pair to list of token pairs
710
711 ffesttImpList list;
712 ffelexToken t;
713 ffestt_implist_append(list,start_token,end_token);
714
715 list must have already been created by ffestt_implist_create. The
716 list is allocated out of the scratch pool. The tokens are consumed. */
717
718 void
ffestt_implist_append(ffesttImpList list,ffelexToken first,ffelexToken last)719 ffestt_implist_append (ffesttImpList list, ffelexToken first, ffelexToken last)
720 {
721 ffesttImpList new;
722
723 new = (ffesttImpList) malloc_new_kp (ffesta_scratch_pool,
724 "FFEST token list", sizeof (*new));
725 new->next = list->previous->next;
726 new->previous = list->previous;
727 new->next->previous = new;
728 new->previous->next = new;
729 new->first = first;
730 new->last = last;
731 }
732
733 /* ffestt_implist_create -- Create new list of token pairs
734
735 ffesttImpList list;
736 list = ffestt_implist_create();
737
738 The list is allocated out of the scratch pool. */
739
740 ffesttImpList
ffestt_implist_create()741 ffestt_implist_create ()
742 {
743 ffesttImpList new;
744
745 new = (ffesttImpList) malloc_new_kp (ffesta_scratch_pool,
746 "FFEST token list root",
747 sizeof (*new));
748 new->next = new->previous = new;
749 new->first = NULL;
750 new->last = NULL;
751 return new;
752 }
753
754 /* ffestt_implist_drive -- Drive list of token pairs into function
755
756 ffesttImpList list;
757 void fn(ffelexToken first,ffelexToken last);
758 ffestt_implist_drive(list,fn);
759
760 The token pairs in the list are passed to the function one pair at a time. */
761
762 void
ffestt_implist_drive(ffesttImpList list,void (* fn)(ffelexToken,ffelexToken))763 ffestt_implist_drive (ffesttImpList list, void (*fn) (ffelexToken, ffelexToken))
764 {
765 ffesttImpList next;
766
767 if (list == NULL)
768 return;
769
770 for (next = list->next; next != list; next = next->next)
771 {
772 (*fn) (next->first, next->last);
773 }
774 }
775
776 /* ffestt_implist_kill -- Kill list of token pairs
777
778 ffesttImpList list;
779 ffestt_implist_kill(list);
780
781 The tokens on the list are killed. */
782
783 void
ffestt_implist_kill(ffesttImpList list)784 ffestt_implist_kill (ffesttImpList list)
785 {
786 ffesttImpList next;
787
788 for (next = list->next; next != list; next = next->next)
789 {
790 ffelex_token_kill (next->first);
791 if (next->last != NULL)
792 ffelex_token_kill (next->last);
793 }
794 }
795
796 /* ffestt_tokenlist_append -- Append token to list of tokens
797
798 ffesttTokenList tl;
799 ffelexToken t;
800 ffestt_tokenlist_append(tl,t);
801
802 tl must have already been created by ffestt_tokenlist_create. The
803 list is allocated out of the scratch pool. The token is consumed. */
804
805 void
ffestt_tokenlist_append(ffesttTokenList tl,ffelexToken t)806 ffestt_tokenlist_append (ffesttTokenList tl, ffelexToken t)
807 {
808 ffesttTokenItem ti;
809
810 ti = (ffesttTokenItem) malloc_new_kp (ffesta_scratch_pool,
811 "FFEST token item", sizeof (*ti));
812 ti->next = (ffesttTokenItem) &tl->first;
813 ti->previous = tl->last;
814 ti->next->previous = ti;
815 ti->previous->next = ti;
816 ti->t = t;
817 ++tl->count;
818 }
819
820 /* ffestt_tokenlist_create -- Create new list of tokens
821
822 ffesttTokenList tl;
823 tl = ffestt_tokenlist_create();
824
825 The list is allocated out of the scratch pool. */
826
827 ffesttTokenList
ffestt_tokenlist_create()828 ffestt_tokenlist_create ()
829 {
830 ffesttTokenList tl;
831
832 tl = (ffesttTokenList) malloc_new_kp (ffesta_scratch_pool,
833 "FFEST token list", sizeof (*tl));
834 tl->first = tl->last = (ffesttTokenItem) &tl->first;
835 tl->count = 0;
836 return tl;
837 }
838
839 /* ffestt_tokenlist_drive -- Drive list of tokens
840
841 ffesttTokenList tl;
842 void fn(ffelexToken t);
843 ffestt_tokenlist_drive(tl,fn);
844
845 The tokens in the list are passed to the given function. */
846
847 void
ffestt_tokenlist_drive(ffesttTokenList tl,void (* fn)(ffelexToken))848 ffestt_tokenlist_drive (ffesttTokenList tl, void (*fn) (ffelexToken))
849 {
850 ffesttTokenItem ti;
851
852 if (tl == NULL)
853 return;
854
855 for (ti = tl->first; ti != (ffesttTokenItem) &tl->first; ti = ti->next)
856 {
857 (*fn) (ti->t);
858 }
859 }
860
861 /* ffestt_tokenlist_handle -- Handle list of tokens
862
863 ffesttTokenList tl;
864 ffelexHandler handler;
865 handler = ffestt_tokenlist_handle(tl,handler);
866
867 The tokens in the list are passed to the handler(s). */
868
869 ffelexHandler
ffestt_tokenlist_handle(ffesttTokenList tl,ffelexHandler handler)870 ffestt_tokenlist_handle (ffesttTokenList tl, ffelexHandler handler)
871 {
872 ffesttTokenItem ti;
873
874 for (ti = tl->first; ti != (ffesttTokenItem) &tl->first; ti = ti->next)
875 handler = (ffelexHandler) (*handler) (ti->t);
876
877 return (ffelexHandler) handler;
878 }
879
880 /* ffestt_tokenlist_kill -- Kill list of tokens
881
882 ffesttTokenList tl;
883 ffestt_tokenlist_kill(tl);
884
885 The tokens on the list are killed.
886
887 02-Mar-90 JCB 1.1
888 Don't kill the list itself or change it, since it will be trashed when
889 ffesta_scratch_pool is killed anyway, so kill only the lex tokens. */
890
891 void
ffestt_tokenlist_kill(ffesttTokenList tl)892 ffestt_tokenlist_kill (ffesttTokenList tl)
893 {
894 ffesttTokenItem ti;
895
896 for (ti = tl->first; ti != (ffesttTokenItem) &tl->first; ti = ti->next)
897 {
898 ffelex_token_kill (ti->t);
899 }
900 }
901