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 (burley@gnu.org).
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_dump -- Dump list of cases
120 ffestt_caselist_dump(list);
122 The cases in the list are dumped with commas separating them. */
124 #if FFECOM_targetCURRENT == FFECOM_targetFFE
126 ffestt_caselist_dump (ffesttCaseList list)
130 for (next = list->next; next != list; next = next->next)
132 if (next != list->next)
134 if (next->expr1 != NULL)
135 ffebld_dump (next->expr1);
139 if (next->expr2 != NULL)
140 ffebld_dump (next->expr2);
146 /* ffestt_caselist_kill -- Kill list of cases
149 ffestt_caselist_kill(list);
151 The tokens on the list are killed.
154 Don't kill the list itself or change it, since it will be trashed when
155 ffesta_scratch_pool is killed anyway, so kill only the lex tokens. */
158 ffestt_caselist_kill (ffesttCaseList list)
162 for (next = list->next; next != list; next = next->next)
164 ffelex_token_kill (next->t);
168 /* ffestt_dimlist_append -- Append dim to list of dims
172 ffestt_dimlist_append(list,lower,upper,t);
174 list must have already been created by ffestt_dimlist_create. The
175 list is allocated out of the scratch pool. The token is consumed. */
178 ffestt_dimlist_append (ffesttDimList list, ffebld lower, ffebld upper,
183 new = (ffesttDimList) malloc_new_kp (ffesta_scratch_pool,
184 "FFEST dim list", sizeof (*new));
185 new->next = list->previous->next;
186 new->previous = list->previous;
187 new->next->previous = new;
188 new->previous->next = new;
194 /* Convert list of dims into ffebld format.
200 ffestt_dimlist_as_expr (list, &rank, &array_size, &extents);
202 The dims in the list are converted to a list of ITEMs; the rank of the
203 array, an expression representing the array size, a list of extent
204 expressions, and the list of ITEMs are returned.
206 If is_ugly_assumed, treat a final dimension with no lower bound
207 and an upper bound of 1 as a * bound. */
210 ffestt_dimlist_as_expr (ffesttDimList list, ffeinfoRank *rank,
211 ffebld *array_size, ffebld *extents,
212 bool is_ugly_assumed)
217 ffebld ex; /* List of extents. */
218 ffebld ext; /* Extent of a given dimension. */
219 ffebldListBottom bottom;
222 ffetargetIntegerDefault low;
223 ffetargetIntegerDefault high;
224 bool zero = FALSE; /* Zero-size array. */
226 bool star = FALSE; /* Adjustable array. */
228 assert (list != NULL);
231 ffebld_init_list (&expr, &bottom);
232 for (next = list->next; next != list; next = next->next)
235 if (((next->lower == NULL)
236 || (ffebld_op (next->lower) == FFEBLD_opCONTER))
237 && (ffebld_op (next->upper) == FFEBLD_opCONTER))
239 if (next->lower == NULL)
242 low = ffebld_constant_integerdefault (ffebld_conter (next->lower));
243 high = ffebld_constant_integerdefault (ffebld_conter (next->upper));
247 if ((next->next == list)
249 && (next->lower == NULL)
251 && (ffebld_conter_orig (next->upper) == NULL))
254 ffebld_append_item (&bottom,
255 ffebld_new_bounds (NULL, ffebld_new_star ()));
259 else if (((next->lower != NULL)
260 && (ffebld_op (next->lower) == FFEBLD_opANY))
261 || (ffebld_op (next->upper) == FFEBLD_opANY))
263 else if (ffebld_op (next->upper) == FFEBLD_opSTAR)
265 ffebld_append_item (&bottom,
266 ffebld_new_bounds (next->lower, next->upper));
268 ffebld_end_list (&bottom);
272 as = ffebld_new_conter (ffebld_constant_new_integerdefault_val (0));
273 ffebld_set_info (as, ffeinfo_new
274 (FFEINFO_basictypeINTEGER,
275 FFEINFO_kindtypeINTEGERDEFAULT,
278 FFEINFO_whereCONSTANT,
279 FFETARGET_charactersizeNONE));
284 as = ffebld_new_any ();
285 ffebld_set_info (as, ffeinfo_new_any ());
286 ex = ffebld_copy (as);
290 as = ffebld_new_star ();
291 ex = ffebld_new_star (); /* ~~Should really be list as below. */
296 ffebld_init_list (&ex, &bottom);
297 for (next = list->next; next != list; next = next->next)
299 if ((next->lower == NULL)
300 || ((ffebld_op (next->lower) == FFEBLD_opCONTER)
301 && (ffebld_constant_integerdefault (ffebld_conter
302 (next->lower)) == 1)))
303 ext = ffebld_copy (next->upper);
306 ext = ffebld_new_subtract (next->upper, next->lower);
308 = ffeinfo_kindtype_max (FFEINFO_basictypeINTEGER,
309 ffeinfo_kindtype (ffebld_info
311 ffeinfo_kindtype (ffebld_info
313 ffebld_set_info (ext,
314 ffeinfo_new (FFEINFO_basictypeINTEGER,
318 ((ffebld_op (ffebld_left (ext))
320 && (ffebld_op (ffebld_right
323 ? FFEINFO_whereCONSTANT
324 : FFEINFO_whereFLEETING,
325 FFETARGET_charactersizeNONE));
326 ffebld_set_left (ext,
327 ffeexpr_convert_expr (ffebld_left (ext),
328 next->t, ext, next->t,
329 FFEEXPR_contextLET));
330 ffebld_set_right (ext,
331 ffeexpr_convert_expr (ffebld_right (ext),
334 FFEEXPR_contextLET));
335 ext = ffeexpr_collapse_subtract (ext, next->t);
338 = ffeinfo_kindtype_max (FFEINFO_basictypeINTEGER,
339 ffeinfo_kindtype (ffebld_info (ext)),
340 FFEINFO_kindtypeINTEGERDEFAULT);
342 = ffebld_new_add (ext,
344 (ffebld_constant_new_integerdefault_val
346 ffebld_set_info (ffebld_right (ext), ffeinfo_new
347 (FFEINFO_basictypeINTEGER,
348 FFEINFO_kindtypeINTEGERDEFAULT,
351 FFEINFO_whereCONSTANT,
352 FFETARGET_charactersizeNONE));
353 ffebld_set_info (ext,
354 ffeinfo_new (FFEINFO_basictypeINTEGER,
355 nkt, 0, FFEINFO_kindENTITY,
356 (ffebld_op (ffebld_left (ext))
358 ? FFEINFO_whereCONSTANT
359 : FFEINFO_whereFLEETING,
360 FFETARGET_charactersizeNONE));
361 ffebld_set_left (ext,
362 ffeexpr_convert_expr (ffebld_left (ext),
365 FFEEXPR_contextLET));
366 ffebld_set_right (ext,
367 ffeexpr_convert_expr (ffebld_right (ext),
370 FFEEXPR_contextLET));
371 ext = ffeexpr_collapse_add (ext, next->t);
373 ffebld_append_item (&bottom, ext);
379 = ffeinfo_kindtype_max (FFEINFO_basictypeINTEGER,
380 ffeinfo_kindtype (ffebld_info (as)),
381 ffeinfo_kindtype (ffebld_info (ext)));
382 as = ffebld_new_multiply (as, ext);
384 ffeinfo_new (FFEINFO_basictypeINTEGER,
385 nkt, 0, FFEINFO_kindENTITY,
386 ((ffebld_op (ffebld_left (as))
388 && (ffebld_op (ffebld_right
391 ? FFEINFO_whereCONSTANT
392 : FFEINFO_whereFLEETING,
393 FFETARGET_charactersizeNONE));
395 ffeexpr_convert_expr (ffebld_left (as),
396 next->t, as, next->t,
397 FFEEXPR_contextLET));
398 ffebld_set_right (as,
399 ffeexpr_convert_expr (ffebld_right (as),
402 FFEEXPR_contextLET));
403 as = ffeexpr_collapse_multiply (as, next->t);
406 ffebld_end_list (&bottom);
407 as = ffeexpr_convert (as, list->next->t, NULL,
408 FFEINFO_basictypeINTEGER,
409 FFEINFO_kindtypeINTEGERDEFAULT, 0,
410 FFETARGET_charactersizeNONE,
420 /* ffestt_dimlist_create -- Create new list of dims
423 list = ffestt_dimlist_create();
425 The list is allocated out of the scratch pool. */
428 ffestt_dimlist_create ()
432 new = (ffesttDimList) malloc_new_kp (ffesta_scratch_pool,
433 "FFEST dim list root", sizeof (*new));
434 new->next = new->previous = new;
441 /* ffestt_dimlist_dump -- Dump list of dims
444 ffestt_dimlist_dump(list);
446 The dims in the list are dumped with commas separating them. */
448 #if FFECOM_targetCURRENT == FFECOM_targetFFE
450 ffestt_dimlist_dump (ffesttDimList list)
454 for (next = list->next; next != list; next = next->next)
456 if (next != list->next)
458 if (next->lower != NULL)
459 ffebld_dump (next->lower);
461 if (next->upper != NULL)
462 ffebld_dump (next->upper);
467 /* ffestt_dimlist_kill -- Kill list of dims
470 ffestt_dimlist_kill(list);
472 The tokens on the list are killed. */
475 ffestt_dimlist_kill (ffesttDimList list)
479 for (next = list->next; next != list; next = next->next)
481 ffelex_token_kill (next->t);
485 /* Determine type of list of dimensions.
487 Return KNOWN for all-constant bounds, ADJUSTABLE for constant
488 and variable but no * bounds, ASSUMED for constant and * but
489 not variable bounds, ADJUSTABLEASSUMED for constant and variable
492 If is_ugly_assumed, treat a final dimension with no lower bound
493 and an upper bound of 1 as a * bound. */
496 ffestt_dimlist_type (ffesttDimList list, bool is_ugly_assumed)
502 return FFESTP_dimtypeNONE;
504 type = FFESTP_dimtypeKNOWN;
505 for (next = list->next; next != list; next = next->next)
507 bool ugly_assumed = FALSE;
509 if ((next->next == list)
511 && (next->lower == NULL)
512 && (next->upper != NULL)
513 && (ffebld_op (next->upper) == FFEBLD_opCONTER)
514 && (ffebld_constant_integerdefault (ffebld_conter (next->upper))
516 && (ffebld_conter_orig (next->upper) == NULL))
519 if (next->lower != NULL)
521 if (ffebld_op (next->lower) != FFEBLD_opCONTER)
523 if (type == FFESTP_dimtypeASSUMED)
524 type = FFESTP_dimtypeADJUSTABLEASSUMED;
526 type = FFESTP_dimtypeADJUSTABLE;
529 if (next->upper != NULL)
532 || (ffebld_op (next->upper) == FFEBLD_opSTAR))
534 if (type == FFESTP_dimtypeADJUSTABLE)
535 type = FFESTP_dimtypeADJUSTABLEASSUMED;
537 type = FFESTP_dimtypeASSUMED;
539 else if (ffebld_op (next->upper) != FFEBLD_opCONTER)
540 type = FFESTP_dimtypeADJUSTABLE;
547 /* ffestt_exprlist_append -- Append expr to list of exprs
551 ffestt_exprlist_append(list,expr,t);
553 list must have already been created by ffestt_exprlist_create. The
554 list is allocated out of the scratch pool. The token is consumed. */
557 ffestt_exprlist_append (ffesttExprList list, ffebld expr, ffelexToken t)
561 new = (ffesttExprList) malloc_new_kp (ffesta_scratch_pool,
562 "FFEST expr list", sizeof (*new));
563 new->next = list->previous->next;
564 new->previous = list->previous;
565 new->next->previous = new;
566 new->previous->next = new;
571 /* ffestt_exprlist_create -- Create new list of exprs
574 list = ffestt_exprlist_create();
576 The list is allocated out of the scratch pool. */
579 ffestt_exprlist_create ()
583 new = (ffesttExprList) malloc_new_kp (ffesta_scratch_pool,
584 "FFEST expr list root", sizeof (*new));
585 new->next = new->previous = new;
591 /* ffestt_exprlist_drive -- Drive list of token pairs into function
594 void fn(ffebld expr,ffelexToken t);
595 ffestt_exprlist_drive(list,fn);
597 The expr/token pairs in the list are passed to the function one pair
601 ffestt_exprlist_drive (ffesttExprList list, void (*fn) ())
608 for (next = list->next; next != list; next = next->next)
610 (*fn) (next->expr, next->t);
614 /* ffestt_exprlist_dump -- Dump list of exprs
617 ffestt_exprlist_dump(list);
619 The exprs in the list are dumped with commas separating them. */
621 #if FFECOM_targetCURRENT == FFECOM_targetFFE
623 ffestt_exprlist_dump (ffesttExprList list)
627 for (next = list->next; next != list; next = next->next)
629 if (next != list->next)
631 ffebld_dump (next->expr);
636 /* ffestt_exprlist_kill -- Kill list of exprs
639 ffestt_exprlist_kill(list);
641 The tokens on the list are killed.
644 Don't kill the list itself or change it, since it will be trashed when
645 ffesta_scratch_pool is killed anyway, so kill only the lex tokens. */
648 ffestt_exprlist_kill (ffesttExprList list)
652 for (next = list->next; next != list; next = next->next)
654 ffelex_token_kill (next->t);
658 /* ffestt_formatlist_append -- Append null format to list of formats
660 ffesttFormatList list, new;
661 new = ffestt_formatlist_append(list);
663 list must have already been created by ffestt_formatlist_create. The
664 new item is allocated out of the scratch pool. The caller must initialize
668 ffestt_formatlist_append (ffesttFormatList list)
670 ffesttFormatList new;
672 new = (ffesttFormatList) malloc_new_kp (ffesta_scratch_pool,
673 "FFEST format list", sizeof (*new));
674 new->next = list->previous->next;
675 new->previous = list->previous;
676 new->next->previous = new;
677 new->previous->next = new;
681 /* ffestt_formatlist_create -- Create new list of formats
683 ffesttFormatList list;
684 list = ffestt_formatlist_create(NULL);
686 The list is allocated out of the scratch pool. */
689 ffestt_formatlist_create (ffesttFormatList parent, ffelexToken t)
691 ffesttFormatList new;
693 new = (ffesttFormatList) malloc_new_kp (ffesta_scratch_pool,
694 "FFEST format list root", sizeof (*new));
695 new->next = new->previous = new;
696 new->type = FFESTP_formattypeNone;
698 new->u.root.parent = parent;
702 /* ffestt_formatlist_kill -- Kill tokens on list of formats
704 ffesttFormatList list;
705 ffestt_formatlist_kill(list);
707 The tokens on the list are killed. */
710 ffestt_formatlist_kill (ffesttFormatList list)
712 ffesttFormatList next;
714 /* Always kill from the very top on down. */
716 while (list->u.root.parent != NULL)
717 list = list->u.root.parent->next;
719 /* Kill first token for this list. */
722 ffelex_token_kill (list->t);
724 /* Kill each item in this list. */
726 for (next = list->next; next != list; next = next->next)
728 ffelex_token_kill (next->t);
731 case FFESTP_formattypeI:
732 case FFESTP_formattypeB:
733 case FFESTP_formattypeO:
734 case FFESTP_formattypeZ:
735 case FFESTP_formattypeF:
736 case FFESTP_formattypeE:
737 case FFESTP_formattypeEN:
738 case FFESTP_formattypeG:
739 case FFESTP_formattypeL:
740 case FFESTP_formattypeA:
741 case FFESTP_formattypeD:
742 if (next->u.R1005.R1004.t != NULL)
743 ffelex_token_kill (next->u.R1005.R1004.t);
744 if (next->u.R1005.R1006.t != NULL)
745 ffelex_token_kill (next->u.R1005.R1006.t);
746 if (next->u.R1005.R1007_or_R1008.t != NULL)
747 ffelex_token_kill (next->u.R1005.R1007_or_R1008.t);
748 if (next->u.R1005.R1009.t != NULL)
749 ffelex_token_kill (next->u.R1005.R1009.t);
752 case FFESTP_formattypeQ:
753 case FFESTP_formattypeDOLLAR:
754 case FFESTP_formattypeP:
755 case FFESTP_formattypeT:
756 case FFESTP_formattypeTL:
757 case FFESTP_formattypeTR:
758 case FFESTP_formattypeX:
759 case FFESTP_formattypeS:
760 case FFESTP_formattypeSP:
761 case FFESTP_formattypeSS:
762 case FFESTP_formattypeBN:
763 case FFESTP_formattypeBZ:
764 case FFESTP_formattypeSLASH:
765 case FFESTP_formattypeCOLON:
766 if (next->u.R1010.val.t != NULL)
767 ffelex_token_kill (next->u.R1010.val.t);
770 case FFESTP_formattypeR1016:
771 break; /* Nothing more to do. */
773 case FFESTP_formattypeFORMAT:
774 if (next->u.R1003D.R1004.t != NULL)
775 ffelex_token_kill (next->u.R1003D.R1004.t);
776 next->u.R1003D.format->u.root.parent = NULL; /* Parent already dying. */
777 ffestt_formatlist_kill (next->u.R1003D.format);
786 /* ffestt_implist_append -- Append token pair to list of token pairs
790 ffestt_implist_append(list,start_token,end_token);
792 list must have already been created by ffestt_implist_create. The
793 list is allocated out of the scratch pool. The tokens are consumed. */
796 ffestt_implist_append (ffesttImpList list, ffelexToken first, ffelexToken last)
800 new = (ffesttImpList) malloc_new_kp (ffesta_scratch_pool,
801 "FFEST token list", sizeof (*new));
802 new->next = list->previous->next;
803 new->previous = list->previous;
804 new->next->previous = new;
805 new->previous->next = new;
810 /* ffestt_implist_create -- Create new list of token pairs
813 list = ffestt_implist_create();
815 The list is allocated out of the scratch pool. */
818 ffestt_implist_create ()
822 new = (ffesttImpList) malloc_new_kp (ffesta_scratch_pool,
823 "FFEST token list root",
825 new->next = new->previous = new;
831 /* ffestt_implist_drive -- Drive list of token pairs into function
834 void fn(ffelexToken first,ffelexToken last);
835 ffestt_implist_drive(list,fn);
837 The token pairs in the list are passed to the function one pair at a time. */
840 ffestt_implist_drive (ffesttImpList list, void (*fn) ())
847 for (next = list->next; next != list; next = next->next)
849 (*fn) (next->first, next->last);
853 /* ffestt_implist_dump -- Dump list of token pairs
856 ffestt_implist_dump(list);
858 The token pairs in the list are dumped with commas separating them. */
860 #if FFECOM_targetCURRENT == FFECOM_targetFFE
862 ffestt_implist_dump (ffesttImpList list)
866 for (next = list->next; next != list; next = next->next)
868 if (next != list->next)
870 assert (ffelex_token_type (next->first) == FFELEX_typeNAME);
871 fputs (ffelex_token_text (next->first), dmpout);
872 if (next->last != NULL)
875 assert (ffelex_token_type (next->last) == FFELEX_typeNAME);
876 fputs (ffelex_token_text (next->last), dmpout);
882 /* ffestt_implist_kill -- Kill list of token pairs
885 ffestt_implist_kill(list);
887 The tokens on the list are killed. */
890 ffestt_implist_kill (ffesttImpList list)
894 for (next = list->next; next != list; next = next->next)
896 ffelex_token_kill (next->first);
897 if (next->last != NULL)
898 ffelex_token_kill (next->last);
902 /* ffestt_tokenlist_append -- Append token to list of tokens
906 ffestt_tokenlist_append(tl,t);
908 tl must have already been created by ffestt_tokenlist_create. The
909 list is allocated out of the scratch pool. The token is consumed. */
912 ffestt_tokenlist_append (ffesttTokenList tl, ffelexToken t)
916 ti = (ffesttTokenItem) malloc_new_kp (ffesta_scratch_pool,
917 "FFEST token item", sizeof (*ti));
918 ti->next = (ffesttTokenItem) &tl->first;
919 ti->previous = tl->last;
920 ti->next->previous = ti;
921 ti->previous->next = ti;
926 /* ffestt_tokenlist_create -- Create new list of tokens
929 tl = ffestt_tokenlist_create();
931 The list is allocated out of the scratch pool. */
934 ffestt_tokenlist_create ()
938 tl = (ffesttTokenList) malloc_new_kp (ffesta_scratch_pool,
939 "FFEST token list", sizeof (*tl));
940 tl->first = tl->last = (ffesttTokenItem) &tl->first;
945 /* ffestt_tokenlist_drive -- Drive list of tokens
948 void fn(ffelexToken t);
949 ffestt_tokenlist_drive(tl,fn);
951 The tokens in the list are passed to the given function. */
954 ffestt_tokenlist_drive (ffesttTokenList tl, void (*fn) ())
961 for (ti = tl->first; ti != (ffesttTokenItem) &tl->first; ti = ti->next)
967 /* ffestt_tokenlist_dump -- Dump list of tokens
970 ffestt_tokenlist_dump(tl);
972 The tokens in the list are dumped with commas separating them. */
974 #if FFECOM_targetCURRENT == FFECOM_targetFFE
976 ffestt_tokenlist_dump (ffesttTokenList tl)
980 for (ti = tl->first; ti != (ffesttTokenItem) &tl->first; ti = ti->next)
984 switch (ffelex_token_type (ti->t))
986 case FFELEX_typeNUMBER:
987 case FFELEX_typeNAME:
988 case FFELEX_typeNAMES:
989 fputs (ffelex_token_text (ti->t), dmpout);
992 case FFELEX_typeASTERISK:
1005 /* ffestt_tokenlist_handle -- Handle list of tokens
1008 ffelexHandler handler;
1009 handler = ffestt_tokenlist_handle(tl,handler);
1011 The tokens in the list are passed to the handler(s). */
1014 ffestt_tokenlist_handle (ffesttTokenList tl, ffelexHandler handler)
1018 for (ti = tl->first; ti != (ffesttTokenItem) &tl->first; ti = ti->next)
1019 handler = (ffelexHandler) (*handler) (ti->t);
1021 return (ffelexHandler) handler;
1024 /* ffestt_tokenlist_kill -- Kill list of tokens
1027 ffestt_tokenlist_kill(tl);
1029 The tokens on the list are killed.
1032 Don't kill the list itself or change it, since it will be trashed when
1033 ffesta_scratch_pool is killed anyway, so kill only the lex tokens. */
1036 ffestt_tokenlist_kill (ffesttTokenList tl)
1040 for (ti = tl->first; ti != (ffesttTokenItem) &tl->first; ti = ti->next)
1042 ffelex_token_kill (ti->t);