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.
5 This file is part of GNU Fortran.
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)
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.
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
26 Manages lists of tokens and related info for parsing.
43 /* Externals defined here. */
46 /* Simple definitions and enumerations. */
49 /* Internal typedefs. */
52 /* Private include files. */
55 /* Internal structure definitions. */
58 /* Static objects accessed by functions in this module. */
61 /* Static functions (internal). */
64 /* Internal macros. */
67 /* ffestt_caselist_append -- Append case to list of cases
71 ffestt_caselist_append(list,range,case1,case2,t);
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. */
77 ffestt_caselist_append (ffesttCaseList list, bool range, ffebld case1,
78 ffebld case2, ffelexToken t)
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;
94 /* ffestt_caselist_create -- Create new list of cases
97 list = ffestt_caselist_create();
99 The list is allocated out of the scratch pool. */
102 ffestt_caselist_create ()
106 new = (ffesttCaseList) malloc_new_kp (ffesta_scratch_pool,
107 "FFEST case list root",
109 new->next = new->previous = new;
117 /* ffestt_caselist_kill -- Kill list of cases
120 ffestt_caselist_kill(list);
122 The tokens on the list are killed.
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. */
129 ffestt_caselist_kill (ffesttCaseList list)
133 for (next = list->next; next != list; next = next->next)
135 ffelex_token_kill (next->t);
139 /* ffestt_dimlist_append -- Append dim to list of dims
143 ffestt_dimlist_append(list,lower,upper,t);
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. */
149 ffestt_dimlist_append (ffesttDimList list, ffebld lower, ffebld upper,
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;
165 /* Convert list of dims into ffebld format.
171 ffestt_dimlist_as_expr (list, &rank, &array_size, &extents);
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.
177 If is_ugly_assumed, treat a final dimension with no lower bound
178 and an upper bound of 1 as a * bound. */
181 ffestt_dimlist_as_expr (ffesttDimList list, ffeinfoRank *rank,
182 ffebld *array_size, ffebld *extents,
183 bool is_ugly_assumed)
188 ffebld ex; /* List of extents. */
189 ffebld ext; /* Extent of a given dimension. */
190 ffebldListBottom bottom;
193 ffetargetIntegerDefault low;
194 ffetargetIntegerDefault high;
195 bool zero = FALSE; /* Zero-size array. */
197 bool star = FALSE; /* Adjustable array. */
199 assert (list != NULL);
202 ffebld_init_list (&expr, &bottom);
203 for (next = list->next; next != list; next = next->next)
206 if (((next->lower == NULL)
207 || (ffebld_op (next->lower) == FFEBLD_opCONTER))
208 && (ffebld_op (next->upper) == FFEBLD_opCONTER))
210 if (next->lower == NULL)
213 low = ffebld_constant_integerdefault (ffebld_conter (next->lower));
214 high = ffebld_constant_integerdefault (ffebld_conter (next->upper));
218 if ((next->next == list)
220 && (next->lower == NULL)
222 && (ffebld_conter_orig (next->upper) == NULL))
225 ffebld_append_item (&bottom,
226 ffebld_new_bounds (NULL, ffebld_new_star ()));
230 else if (((next->lower != NULL)
231 && (ffebld_op (next->lower) == FFEBLD_opANY))
232 || (ffebld_op (next->upper) == FFEBLD_opANY))
234 else if (ffebld_op (next->upper) == FFEBLD_opSTAR)
236 ffebld_append_item (&bottom,
237 ffebld_new_bounds (next->lower, next->upper));
239 ffebld_end_list (&bottom);
243 as = ffebld_new_conter (ffebld_constant_new_integerdefault_val (0));
244 ffebld_set_info (as, ffeinfo_new
245 (FFEINFO_basictypeINTEGER,
246 FFEINFO_kindtypeINTEGERDEFAULT,
249 FFEINFO_whereCONSTANT,
250 FFETARGET_charactersizeNONE));
255 as = ffebld_new_any ();
256 ffebld_set_info (as, ffeinfo_new_any ());
257 ex = ffebld_copy (as);
261 as = ffebld_new_star ();
262 ex = ffebld_new_star (); /* ~~Should really be list as below. */
267 ffebld_init_list (&ex, &bottom);
268 for (next = list->next; next != list; next = next->next)
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);
277 ext = ffebld_new_subtract (next->upper, next->lower);
279 = ffeinfo_kindtype_max (FFEINFO_basictypeINTEGER,
280 ffeinfo_kindtype (ffebld_info
282 ffeinfo_kindtype (ffebld_info
284 ffebld_set_info (ext,
285 ffeinfo_new (FFEINFO_basictypeINTEGER,
289 ((ffebld_op (ffebld_left (ext))
291 && (ffebld_op (ffebld_right
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),
305 FFEEXPR_contextLET));
306 ext = ffeexpr_collapse_subtract (ext, next->t);
309 = ffeinfo_kindtype_max (FFEINFO_basictypeINTEGER,
310 ffeinfo_kindtype (ffebld_info (ext)),
311 FFEINFO_kindtypeINTEGERDEFAULT);
313 = ffebld_new_add (ext,
315 (ffebld_constant_new_integerdefault_val
317 ffebld_set_info (ffebld_right (ext), ffeinfo_new
318 (FFEINFO_basictypeINTEGER,
319 FFEINFO_kindtypeINTEGERDEFAULT,
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))
329 ? FFEINFO_whereCONSTANT
330 : FFEINFO_whereFLEETING,
331 FFETARGET_charactersizeNONE));
332 ffebld_set_left (ext,
333 ffeexpr_convert_expr (ffebld_left (ext),
336 FFEEXPR_contextLET));
337 ffebld_set_right (ext,
338 ffeexpr_convert_expr (ffebld_right (ext),
341 FFEEXPR_contextLET));
342 ext = ffeexpr_collapse_add (ext, next->t);
344 ffebld_append_item (&bottom, ext);
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);
355 ffeinfo_new (FFEINFO_basictypeINTEGER,
356 nkt, 0, FFEINFO_kindENTITY,
357 ((ffebld_op (ffebld_left (as))
359 && (ffebld_op (ffebld_right
362 ? FFEINFO_whereCONSTANT
363 : FFEINFO_whereFLEETING,
364 FFETARGET_charactersizeNONE));
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),
373 FFEEXPR_contextLET));
374 as = ffeexpr_collapse_multiply (as, next->t);
377 ffebld_end_list (&bottom);
378 as = ffeexpr_convert (as, list->next->t, NULL,
379 FFEINFO_basictypeINTEGER,
380 FFEINFO_kindtypeINTEGERDEFAULT, 0,
381 FFETARGET_charactersizeNONE,
391 /* ffestt_dimlist_create -- Create new list of dims
394 list = ffestt_dimlist_create();
396 The list is allocated out of the scratch pool. */
399 ffestt_dimlist_create ()
403 new = (ffesttDimList) malloc_new_kp (ffesta_scratch_pool,
404 "FFEST dim list root", sizeof (*new));
405 new->next = new->previous = new;
412 /* ffestt_dimlist_kill -- Kill list of dims
415 ffestt_dimlist_kill(list);
417 The tokens on the list are killed. */
420 ffestt_dimlist_kill (ffesttDimList list)
424 for (next = list->next; next != list; next = next->next)
426 ffelex_token_kill (next->t);
430 /* Determine type of list of dimensions.
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
437 If is_ugly_assumed, treat a final dimension with no lower bound
438 and an upper bound of 1 as a * bound. */
441 ffestt_dimlist_type (ffesttDimList list, bool is_ugly_assumed)
447 return FFESTP_dimtypeNONE;
449 type = FFESTP_dimtypeKNOWN;
450 for (next = list->next; next != list; next = next->next)
452 bool ugly_assumed = FALSE;
454 if ((next->next == list)
456 && (next->lower == NULL)
457 && (next->upper != NULL)
458 && (ffebld_op (next->upper) == FFEBLD_opCONTER)
459 && (ffebld_constant_integerdefault (ffebld_conter (next->upper))
461 && (ffebld_conter_orig (next->upper) == NULL))
464 if (next->lower != NULL)
466 if (ffebld_op (next->lower) != FFEBLD_opCONTER)
468 if (type == FFESTP_dimtypeASSUMED)
469 type = FFESTP_dimtypeADJUSTABLEASSUMED;
471 type = FFESTP_dimtypeADJUSTABLE;
474 if (next->upper != NULL)
477 || (ffebld_op (next->upper) == FFEBLD_opSTAR))
479 if (type == FFESTP_dimtypeADJUSTABLE)
480 type = FFESTP_dimtypeADJUSTABLEASSUMED;
482 type = FFESTP_dimtypeASSUMED;
484 else if (ffebld_op (next->upper) != FFEBLD_opCONTER)
485 type = FFESTP_dimtypeADJUSTABLE;
492 /* ffestt_exprlist_append -- Append expr to list of exprs
496 ffestt_exprlist_append(list,expr,t);
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. */
502 ffestt_exprlist_append (ffesttExprList list, ffebld expr, ffelexToken t)
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;
516 /* ffestt_exprlist_create -- Create new list of exprs
519 list = ffestt_exprlist_create();
521 The list is allocated out of the scratch pool. */
524 ffestt_exprlist_create ()
528 new = (ffesttExprList) malloc_new_kp (ffesta_scratch_pool,
529 "FFEST expr list root", sizeof (*new));
530 new->next = new->previous = new;
536 /* ffestt_exprlist_drive -- Drive list of token pairs into function
539 void fn(ffebld expr,ffelexToken t);
540 ffestt_exprlist_drive(list,fn);
542 The expr/token pairs in the list are passed to the function one pair
546 ffestt_exprlist_drive (ffesttExprList list, void (*fn) (ffebld, ffelexToken))
553 for (next = list->next; next != list; next = next->next)
555 (*fn) (next->expr, next->t);
559 /* ffestt_exprlist_kill -- Kill list of exprs
562 ffestt_exprlist_kill(list);
564 The tokens on the list are killed.
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. */
571 ffestt_exprlist_kill (ffesttExprList list)
575 for (next = list->next; next != list; next = next->next)
577 ffelex_token_kill (next->t);
581 /* ffestt_formatlist_append -- Append null format to list of formats
583 ffesttFormatList list, new;
584 new = ffestt_formatlist_append(list);
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
591 ffestt_formatlist_append (ffesttFormatList list)
593 ffesttFormatList new;
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;
604 /* ffestt_formatlist_create -- Create new list of formats
606 ffesttFormatList list;
607 list = ffestt_formatlist_create(NULL);
609 The list is allocated out of the scratch pool. */
612 ffestt_formatlist_create (ffesttFormatList parent, ffelexToken t)
614 ffesttFormatList new;
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;
621 new->u.root.parent = parent;
625 /* ffestt_formatlist_kill -- Kill tokens on list of formats
627 ffesttFormatList list;
628 ffestt_formatlist_kill(list);
630 The tokens on the list are killed. */
633 ffestt_formatlist_kill (ffesttFormatList list)
635 ffesttFormatList next;
637 /* Always kill from the very top on down. */
639 while (list->u.root.parent != NULL)
640 list = list->u.root.parent->next;
642 /* Kill first token for this list. */
645 ffelex_token_kill (list->t);
647 /* Kill each item in this list. */
649 for (next = list->next; next != list; next = next->next)
651 ffelex_token_kill (next->t);
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);
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);
693 case FFESTP_formattypeR1016:
694 break; /* Nothing more to do. */
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);
709 /* ffestt_implist_append -- Append token pair to list of token pairs
713 ffestt_implist_append(list,start_token,end_token);
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. */
719 ffestt_implist_append (ffesttImpList list, ffelexToken first, ffelexToken last)
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;
733 /* ffestt_implist_create -- Create new list of token pairs
736 list = ffestt_implist_create();
738 The list is allocated out of the scratch pool. */
741 ffestt_implist_create ()
745 new = (ffesttImpList) malloc_new_kp (ffesta_scratch_pool,
746 "FFEST token list root",
748 new->next = new->previous = new;
754 /* ffestt_implist_drive -- Drive list of token pairs into function
757 void fn(ffelexToken first,ffelexToken last);
758 ffestt_implist_drive(list,fn);
760 The token pairs in the list are passed to the function one pair at a time. */
763 ffestt_implist_drive (ffesttImpList list, void (*fn) (ffelexToken, ffelexToken))
770 for (next = list->next; next != list; next = next->next)
772 (*fn) (next->first, next->last);
776 /* ffestt_implist_kill -- Kill list of token pairs
779 ffestt_implist_kill(list);
781 The tokens on the list are killed. */
784 ffestt_implist_kill (ffesttImpList list)
788 for (next = list->next; next != list; next = next->next)
790 ffelex_token_kill (next->first);
791 if (next->last != NULL)
792 ffelex_token_kill (next->last);
796 /* ffestt_tokenlist_append -- Append token to list of tokens
800 ffestt_tokenlist_append(tl,t);
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. */
806 ffestt_tokenlist_append (ffesttTokenList tl, ffelexToken t)
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;
820 /* ffestt_tokenlist_create -- Create new list of tokens
823 tl = ffestt_tokenlist_create();
825 The list is allocated out of the scratch pool. */
828 ffestt_tokenlist_create ()
832 tl = (ffesttTokenList) malloc_new_kp (ffesta_scratch_pool,
833 "FFEST token list", sizeof (*tl));
834 tl->first = tl->last = (ffesttTokenItem) &tl->first;
839 /* ffestt_tokenlist_drive -- Drive list of tokens
842 void fn(ffelexToken t);
843 ffestt_tokenlist_drive(tl,fn);
845 The tokens in the list are passed to the given function. */
848 ffestt_tokenlist_drive (ffesttTokenList tl, void (*fn) (ffelexToken))
855 for (ti = tl->first; ti != (ffesttTokenItem) &tl->first; ti = ti->next)
861 /* ffestt_tokenlist_handle -- Handle list of tokens
864 ffelexHandler handler;
865 handler = ffestt_tokenlist_handle(tl,handler);
867 The tokens in the list are passed to the handler(s). */
870 ffestt_tokenlist_handle (ffesttTokenList tl, ffelexHandler handler)
874 for (ti = tl->first; ti != (ffesttTokenItem) &tl->first; ti = ti->next)
875 handler = (ffelexHandler) (*handler) (ti->t);
877 return (ffelexHandler) handler;
880 /* ffestt_tokenlist_kill -- Kill list of tokens
883 ffestt_tokenlist_kill(tl);
885 The tokens on the list are killed.
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. */
892 ffestt_tokenlist_kill (ffesttTokenList tl)
896 for (ti = tl->first; ti != (ffesttTokenItem) &tl->first; ti = ti->next)
898 ffelex_token_kill (ti->t);