1 /* stc.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995, 1996, 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 Verifies the proper semantics for statements, checking expressions already
27 semantically analyzed individually, collectively, checking label defs and
28 refs, and so on. Uses ffebad to indicate errors in semantics.
30 In many cases, both a token and a keyword (ffestrFirst, ffestrSecond,
31 or ffestrOther) is provided. ONLY USE THE TOKEN as a pointer to the
32 source-code location for an error message or similar; use the keyword
33 as the semantic matching for the token, since the token's text might
34 not match the keyword's code. For example, INTENT(IN OUT) A in free
35 source form passes to ffestc_R519_start the token "IN" but the keyword
36 FFESTR_otherINOUT, and the latter is correct.
38 Generally, either a single ffestc function handles an entire statement,
39 in which case its name is ffestc_xyz_, or more than one function is
40 needed, in which case its names are ffestc_xyz_start_,
41 ffestc_xyz_item_ or ffestc_xyz_item_abc_, and ffestc_xyz_finish_.
42 The caller must call _start_ before calling any _item_ functions, and
43 must call _finish_ afterwards. If it is clearly a syntactic matter as
44 to restrictions on the number and variety of _item_ calls, then the caller
45 should report any errors and ffestc_ should presume it has been taken
46 care of and handle any semantic problems with grace and no error messages.
47 If the permitted number and variety of _item_ calls has some basis in
48 semantics, then the caller should not generate any messages and ffestc
49 should do all the checking.
51 A few ffestc functions have names rather than grammar numbers, like
52 ffestc_elsewhere and ffestc_end. These are cases where the actual
53 statement depends on its context rather than just its form; ELSE WHERE
54 may be the obvious (WHERE...ELSE WHERE...END WHERE) or something a little
55 more subtle (WHERE: IF THEN...ELSE WHERE...END IF WHERE). The actual
56 ffestc functions do exist and do work, but may or may not be invoked
57 by ffestb depending on whether some form of resolution is possible.
58 For example, ffestc_R1103 end-program-stmt is reachable directly when
59 END PROGRAM [name] is specified, or via ffestc_end when END is specified
60 and the context is a main program. So ffestc_xyz_ should make a quick
61 determination of the context and pick the appropriate ffestc_Nxyz_
62 function to invoke, without a lot of ceremony.
87 /* Externals defined here. */
89 ffeexprContext ffestc_iolist_context_ = FFEEXPR_contextIOLIST;
90 /* Valid only from READ/WRITE start to finish. */
92 /* Simple definitions and enumerations. */
96 FFESTC_orderOK_, /* Statement ok in this context, process. */
97 FFESTC_orderBAD_, /* Statement not ok in this context, don't
99 FFESTC_orderBADOK_, /* Don't process but push block if
106 FFESTC_stateletSIMPLE_, /* Expecting simple/start. */
107 FFESTC_stateletATTRIB_, /* Expecting attrib/item/itemstart. */
108 FFESTC_stateletITEM_, /* Expecting item/itemstart/finish. */
109 FFESTC_stateletITEMVALS_, /* Expecting itemvalue/itemendvals. */
113 /* Internal typedefs. */
116 /* Private include files. */
119 /* Internal structure definitions. */
121 union ffestc_local_u_
125 ffebld initlist; /* For list of one sym in INTEGER I/3/ case. */
126 ffetargetCharacterSize stmt_size;
127 ffetargetCharacterSize size;
128 ffeinfoBasictype basic_type;
129 ffeinfoKindtype stmt_kind_type;
130 ffeinfoKindtype kind_type;
131 bool per_var_kind_ok;
132 char is_R426; /* 1=R426, 2=R501. */
137 ffebld objlist; /* For list of target objects. */
138 ffebldListBottom list_bottom; /* For building lists. */
143 ffebldListBottom list_bottom; /* For building lists. */
149 ffesymbol symbol; /* NML symbol. */
154 ffelexToken t; /* First token in list. */
155 ffeequiv eq; /* Current equivalence being built up. */
156 ffebld list; /* List of expressions in equivalence. */
157 ffebldListBottom bottom;
158 bool ok; /* TRUE while current list still being
160 bool save; /* TRUE if any var in list is SAVEd. */
165 ffesymbol symbol; /* BCB/NCB symbol. */
170 ffesymbol symbol; /* SFN symbol. */
176 char list_state; /* 0=>no field names allowed, 1=>error
177 reported already, 2=>field names req'd,
178 3=>have a field name. */
182 }; /* Merge with the one in ffestc later. */
184 /* Static objects accessed by functions in this module. */
186 static bool ffestc_ok_; /* _start_ fn's send this to _xyz_ fn's. */
187 static bool ffestc_parent_ok_; /* Parent sym for baby sym fn's ok. */
188 static char ffestc_namelist_; /* 0=>not namelist, 1=>namelist, 2=>error. */
189 static union ffestc_local_u_ ffestc_local_;
190 static ffestcStatelet_ ffestc_statelet_ = FFESTC_stateletSIMPLE_;
191 static ffestwShriek ffestc_shriek_after1_ = NULL;
192 static unsigned long ffestc_blocknum_ = 0; /* Next block# to assign. */
193 static int ffestc_entry_num_;
194 static int ffestc_sfdummy_argno_;
195 static int ffestc_saved_entry_num_;
196 static ffelab ffestc_label_;
198 /* Static functions (internal). */
200 static void ffestc_R544_equiv_ (ffebld expr, ffelexToken t);
201 static void ffestc_establish_declinfo_ (ffebld kind, ffelexToken kindt,
202 ffebld len, ffelexToken lent);
203 static void ffestc_establish_declstmt_ (ffestpType type, ffelexToken typet,
204 ffebld kind, ffelexToken kindt,
205 ffebld len, ffelexToken lent);
206 static void ffestc_establish_impletter_ (ffelexToken first, ffelexToken last);
207 static ffeinfoKindtype ffestc_kindtype_kind_ (ffeinfoBasictype bt,
208 ffetargetCharacterSize val);
209 static ffeinfoKindtype ffestc_kindtype_star_ (ffeinfoBasictype bt,
210 ffetargetCharacterSize val);
211 static void ffestc_labeldef_any_ (void);
212 static bool ffestc_labeldef_begin_ (void);
213 static void ffestc_labeldef_branch_begin_ (void);
214 static void ffestc_labeldef_branch_end_ (void);
215 static void ffestc_labeldef_endif_ (void);
216 static void ffestc_labeldef_format_ (void);
217 static void ffestc_labeldef_invalid_ (void);
218 static void ffestc_labeldef_notloop_ (void);
219 static void ffestc_labeldef_notloop_begin_ (void);
220 static void ffestc_labeldef_useless_ (void);
221 static bool ffestc_labelref_is_assignable_ (ffelexToken label_token,
223 static bool ffestc_labelref_is_branch_ (ffelexToken label_token,
225 static bool ffestc_labelref_is_format_ (ffelexToken label_token,
227 static bool ffestc_labelref_is_loopend_ (ffelexToken label_token,
230 static ffestcOrder_ ffestc_order_access_ (void);
232 static ffestcOrder_ ffestc_order_actiondo_ (void);
233 static ffestcOrder_ ffestc_order_actionif_ (void);
234 static ffestcOrder_ ffestc_order_actionwhere_ (void);
235 static void ffestc_order_any_ (void);
236 static void ffestc_order_bad_ (void);
237 static ffestcOrder_ ffestc_order_blockdata_ (void);
238 static ffestcOrder_ ffestc_order_blockspec_ (void);
240 static ffestcOrder_ ffestc_order_component_ (void);
243 static ffestcOrder_ ffestc_order_contains_ (void);
245 static ffestcOrder_ ffestc_order_data_ (void);
246 static ffestcOrder_ ffestc_order_data77_ (void);
248 static ffestcOrder_ ffestc_order_derivedtype_ (void);
250 static ffestcOrder_ ffestc_order_do_ (void);
251 static ffestcOrder_ ffestc_order_entry_ (void);
252 static ffestcOrder_ ffestc_order_exec_ (void);
253 static ffestcOrder_ ffestc_order_format_ (void);
254 static ffestcOrder_ ffestc_order_function_ (void);
255 static ffestcOrder_ ffestc_order_iface_ (void);
256 static ffestcOrder_ ffestc_order_ifthen_ (void);
257 static ffestcOrder_ ffestc_order_implicit_ (void);
258 static ffestcOrder_ ffestc_order_implicitnone_ (void);
260 static ffestcOrder_ ffestc_order_interface_ (void);
263 static ffestcOrder_ ffestc_order_map_ (void);
266 static ffestcOrder_ ffestc_order_module_ (void);
268 static ffestcOrder_ ffestc_order_parameter_ (void);
269 static ffestcOrder_ ffestc_order_program_ (void);
270 static ffestcOrder_ ffestc_order_progspec_ (void);
272 static ffestcOrder_ ffestc_order_record_ (void);
274 static ffestcOrder_ ffestc_order_selectcase_ (void);
275 static ffestcOrder_ ffestc_order_sfunc_ (void);
277 static ffestcOrder_ ffestc_order_spec_ (void);
280 static ffestcOrder_ ffestc_order_structure_ (void);
282 static ffestcOrder_ ffestc_order_subroutine_ (void);
284 static ffestcOrder_ ffestc_order_type_ (void);
286 static ffestcOrder_ ffestc_order_typedecl_ (void);
288 static ffestcOrder_ ffestc_order_union_ (void);
290 static ffestcOrder_ ffestc_order_unit_ (void);
292 static ffestcOrder_ ffestc_order_use_ (void);
295 static ffestcOrder_ ffestc_order_vxtstructure_ (void);
298 static ffestcOrder_ ffestc_order_where_ (void);
300 static void ffestc_promote_dummy_ (ffelexToken t);
301 static void ffestc_promote_execdummy_ (ffelexToken t);
302 static void ffestc_promote_sfdummy_ (ffelexToken t);
303 static void ffestc_shriek_begin_program_ (void);
305 static void ffestc_shriek_begin_uses_ (void);
307 static void ffestc_shriek_blockdata_ (bool ok);
308 static void ffestc_shriek_do_ (bool ok);
309 static void ffestc_shriek_end_program_ (bool ok);
311 static void ffestc_shriek_end_uses_ (bool ok);
313 static void ffestc_shriek_function_ (bool ok);
314 static void ffestc_shriek_if_ (bool ok);
315 static void ffestc_shriek_ifthen_ (bool ok);
317 static void ffestc_shriek_interface_ (bool ok);
320 static void ffestc_shriek_map_ (bool ok);
323 static void ffestc_shriek_module_ (bool ok);
325 static void ffestc_shriek_select_ (bool ok);
327 static void ffestc_shriek_structure_ (bool ok);
329 static void ffestc_shriek_subroutine_ (bool ok);
331 static void ffestc_shriek_type_ (bool ok);
334 static void ffestc_shriek_union_ (bool ok);
337 static void ffestc_shriek_where_ (bool ok);
340 static void ffestc_shriek_wherethen_ (bool ok);
342 static int ffestc_subr_binsrch_ (const char *const *list, int size,
343 ffestpFile *spec, const char *whine);
344 static ffestvFormat ffestc_subr_format_ (ffestpFile *spec);
345 static bool ffestc_subr_is_branch_ (ffestpFile *spec);
346 static bool ffestc_subr_is_format_ (ffestpFile *spec);
347 static bool ffestc_subr_is_present_ (const char *name, ffestpFile *spec);
348 static int ffestc_subr_speccmp_ (const char *string, ffestpFile *spec,
349 const char **target, int *length);
350 static ffestvUnit ffestc_subr_unit_ (ffestpFile *spec);
351 static void ffestc_try_shriek_do_ (void);
353 /* Internal macros. */
355 #define ffestc_check_simple_() \
356 assert(ffestc_statelet_ == FFESTC_stateletSIMPLE_)
357 #define ffestc_check_start_() \
358 assert(ffestc_statelet_ == FFESTC_stateletSIMPLE_); \
359 ffestc_statelet_ = FFESTC_stateletATTRIB_
360 #define ffestc_check_attrib_() \
361 assert(ffestc_statelet_ == FFESTC_stateletATTRIB_)
362 #define ffestc_check_item_() \
363 assert(ffestc_statelet_ == FFESTC_stateletATTRIB_ \
364 || ffestc_statelet_ == FFESTC_stateletITEM_); \
365 ffestc_statelet_ = FFESTC_stateletITEM_
366 #define ffestc_check_item_startvals_() \
367 assert(ffestc_statelet_ == FFESTC_stateletATTRIB_ \
368 || ffestc_statelet_ == FFESTC_stateletITEM_); \
369 ffestc_statelet_ = FFESTC_stateletITEMVALS_
370 #define ffestc_check_item_value_() \
371 assert(ffestc_statelet_ == FFESTC_stateletITEMVALS_)
372 #define ffestc_check_item_endvals_() \
373 assert(ffestc_statelet_ == FFESTC_stateletITEMVALS_); \
374 ffestc_statelet_ = FFESTC_stateletITEM_
375 #define ffestc_check_finish_() \
376 assert(ffestc_statelet_ == FFESTC_stateletATTRIB_ \
377 || ffestc_statelet_ == FFESTC_stateletITEM_); \
378 ffestc_statelet_ = FFESTC_stateletSIMPLE_
379 #define ffestc_order_action_() ffestc_order_exec_()
381 #define ffestc_order_interfacespec_() ffestc_order_derivedtype_()
383 #define ffestc_shriek_if_lost_ ffestc_shriek_if_
385 #define ffestc_shriek_where_lost_ ffestc_shriek_where_
388 /* ffestc_establish_declinfo_ -- Determine specific type/params info for entity
390 ffestc_establish_declinfo_(kind,kind_token,len,len_token);
392 Must be called after _declstmt_ called to establish base type. */
395 ffestc_establish_declinfo_ (ffebld kind, ffelexToken kindt, ffebld len,
398 ffeinfoBasictype bt = ffestc_local_.decl.basic_type;
400 ffetargetCharacterSize val;
403 kt = ffestc_local_.decl.stmt_kind_type;
404 else if (!ffestc_local_.decl.per_var_kind_ok)
406 ffebad_start (FFEBAD_KINDTYPE);
407 ffebad_here (0, ffelex_token_where_line (kindt),
408 ffelex_token_where_column (kindt));
409 ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]),
410 ffelex_token_where_column (ffesta_tokens[0]));
412 kt = ffestc_local_.decl.stmt_kind_type;
418 assert (ffelex_token_type (kindt) == FFELEX_typeNUMBER);
419 val = atol (ffelex_token_text (kindt));
420 kt = ffestc_kindtype_star_ (bt, val);
422 else if (ffebld_op (kind) == FFEBLD_opANY)
423 kt = ffestc_local_.decl.stmt_kind_type;
426 assert (ffebld_op (kind) == FFEBLD_opCONTER);
427 assert (ffeinfo_basictype (ffebld_info (kind))
428 == FFEINFO_basictypeINTEGER);
429 assert (ffeinfo_kindtype (ffebld_info (kind))
430 == FFEINFO_kindtypeINTEGERDEFAULT);
431 val = ffebld_constant_integerdefault (ffebld_conter (kind));
432 kt = ffestc_kindtype_kind_ (bt, val);
435 if (kt == FFEINFO_kindtypeNONE)
436 { /* Not valid kind type. */
437 ffebad_start (FFEBAD_KINDTYPE);
438 ffebad_here (0, ffelex_token_where_line (kindt),
439 ffelex_token_where_column (kindt));
440 ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]),
441 ffelex_token_where_column (ffesta_tokens[0]));
443 kt = ffestc_local_.decl.stmt_kind_type;
447 ffestc_local_.decl.kind_type = kt;
449 /* Now check length specification for CHARACTER data type. */
451 if (((len == NULL) && (lent == NULL))
452 || (bt != FFEINFO_basictypeCHARACTER))
453 val = ffestc_local_.decl.stmt_size;
458 assert (ffelex_token_type (lent) == FFELEX_typeNUMBER);
459 val = atol (ffelex_token_text (lent));
461 else if (ffebld_op (len) == FFEBLD_opSTAR)
462 val = FFETARGET_charactersizeNONE;
463 else if (ffebld_op (len) == FFEBLD_opANY)
464 val = FFETARGET_charactersizeNONE;
467 assert (ffebld_op (len) == FFEBLD_opCONTER);
468 assert (ffeinfo_basictype (ffebld_info (len))
469 == FFEINFO_basictypeINTEGER);
470 assert (ffeinfo_kindtype (ffebld_info (len))
471 == FFEINFO_kindtypeINTEGERDEFAULT);
472 val = ffebld_constant_integerdefault (ffebld_conter (len));
476 if ((val == 0) && !(0 && ffe_is_90 ()))
479 ffebad_start (FFEBAD_ZERO_SIZE);
480 ffebad_here (0, ffelex_token_where_line (lent), ffelex_token_where_column (lent));
483 ffestc_local_.decl.size = val;
486 /* ffestc_establish_declstmt_ -- Establish host-specific type/params info
488 ffestc_establish_declstmt_(type,type_token,kind,kind_token,len,
492 ffestc_establish_declstmt_ (ffestpType type, ffelexToken typet, ffebld kind,
493 ffelexToken kindt, ffebld len, ffelexToken lent)
496 ffeinfoKindtype ktd; /* Default kindtype. */
498 ffetargetCharacterSize val;
499 bool per_var_kind_ok = TRUE;
501 /* Determine basictype and default kindtype. */
505 case FFESTP_typeINTEGER:
506 bt = FFEINFO_basictypeINTEGER;
507 ktd = FFEINFO_kindtypeINTEGERDEFAULT;
510 case FFESTP_typeBYTE:
511 bt = FFEINFO_basictypeINTEGER;
512 ktd = FFEINFO_kindtypeINTEGER2;
515 case FFESTP_typeWORD:
516 bt = FFEINFO_basictypeINTEGER;
517 ktd = FFEINFO_kindtypeINTEGER3;
520 case FFESTP_typeREAL:
521 bt = FFEINFO_basictypeREAL;
522 ktd = FFEINFO_kindtypeREALDEFAULT;
525 case FFESTP_typeCOMPLEX:
526 bt = FFEINFO_basictypeCOMPLEX;
527 ktd = FFEINFO_kindtypeREALDEFAULT;
530 case FFESTP_typeLOGICAL:
531 bt = FFEINFO_basictypeLOGICAL;
532 ktd = FFEINFO_kindtypeLOGICALDEFAULT;
535 case FFESTP_typeCHARACTER:
536 bt = FFEINFO_basictypeCHARACTER;
537 ktd = FFEINFO_kindtypeCHARACTERDEFAULT;
540 case FFESTP_typeDBLPRCSN:
541 bt = FFEINFO_basictypeREAL;
542 ktd = FFEINFO_kindtypeREALDOUBLE;
543 per_var_kind_ok = FALSE;
546 case FFESTP_typeDBLCMPLX:
547 bt = FFEINFO_basictypeCOMPLEX;
548 #if FFETARGET_okCOMPLEX2
549 ktd = FFEINFO_kindtypeREALDOUBLE;
551 ktd = FFEINFO_kindtypeREALDEFAULT;
552 ffebad_start (FFEBAD_BAD_DBLCMPLX);
553 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
554 ffelex_token_where_column (ffesta_tokens[0]));
557 per_var_kind_ok = FALSE;
561 assert ("Unexpected type (F90 TYPE?)!" == NULL);
562 bt = FFEINFO_basictypeNONE;
563 ktd = FFEINFO_kindtypeNONE;
570 { /* Not necessarily default kind type. */
572 { /* Shouldn't happen for CHARACTER. */
573 assert (ffelex_token_type (kindt) == FFELEX_typeNUMBER);
574 val = atol (ffelex_token_text (kindt));
575 kt = ffestc_kindtype_star_ (bt, val);
577 else if (ffebld_op (kind) == FFEBLD_opANY)
581 assert (ffebld_op (kind) == FFEBLD_opCONTER);
582 assert (ffeinfo_basictype (ffebld_info (kind))
583 == FFEINFO_basictypeINTEGER);
584 assert (ffeinfo_kindtype (ffebld_info (kind))
585 == FFEINFO_kindtypeINTEGERDEFAULT);
586 val = ffebld_constant_integerdefault (ffebld_conter (kind));
587 kt = ffestc_kindtype_kind_ (bt, val);
590 if (kt == FFEINFO_kindtypeNONE)
591 { /* Not valid kind type. */
592 ffebad_start (FFEBAD_KINDTYPE);
593 ffebad_here (0, ffelex_token_where_line (kindt),
594 ffelex_token_where_column (kindt));
595 ffebad_here (1, ffelex_token_where_line (typet),
596 ffelex_token_where_column (typet));
602 ffestc_local_.decl.basic_type = bt;
603 ffestc_local_.decl.stmt_kind_type = kt;
604 ffestc_local_.decl.per_var_kind_ok = per_var_kind_ok;
606 /* Now check length specification for CHARACTER data type. */
608 if (((len == NULL) && (lent == NULL))
609 || (type != FFESTP_typeCHARACTER))
610 val = (type == FFESTP_typeCHARACTER) ? 1 : FFETARGET_charactersizeNONE;
615 assert (ffelex_token_type (lent) == FFELEX_typeNUMBER);
616 val = atol (ffelex_token_text (lent));
618 else if (ffebld_op (len) == FFEBLD_opSTAR)
619 val = FFETARGET_charactersizeNONE;
620 else if (ffebld_op (len) == FFEBLD_opANY)
621 val = FFETARGET_charactersizeNONE;
624 assert (ffebld_op (len) == FFEBLD_opCONTER);
625 assert (ffeinfo_basictype (ffebld_info (len))
626 == FFEINFO_basictypeINTEGER);
627 assert (ffeinfo_kindtype (ffebld_info (len))
628 == FFEINFO_kindtypeINTEGERDEFAULT);
629 val = ffebld_constant_integerdefault (ffebld_conter (len));
633 if ((val == 0) && !(0 && ffe_is_90 ()))
636 ffebad_start (FFEBAD_ZERO_SIZE);
637 ffebad_here (0, ffelex_token_where_line (lent), ffelex_token_where_column (lent));
640 ffestc_local_.decl.stmt_size = val;
643 /* ffestc_establish_impletter_ -- Establish type/params for IMPLICIT letter(s)
645 ffestc_establish_impletter_(first_letter_token,last_letter_token); */
648 ffestc_establish_impletter_ (ffelexToken first, ffelexToken last)
650 bool ok = FALSE; /* Stays FALSE if first letter > last. */
654 ok = ffeimplic_establish_initial (c = *(ffelex_token_text (first)),
655 ffestc_local_.decl.basic_type,
656 ffestc_local_.decl.kind_type,
657 ffestc_local_.decl.size);
660 for (c = *(ffelex_token_text (first));
661 c <= *(ffelex_token_text (last));
664 ok = ffeimplic_establish_initial (c,
665 ffestc_local_.decl.basic_type,
666 ffestc_local_.decl.kind_type,
667 ffestc_local_.decl.size);
680 ffebad_start (FFEBAD_BAD_IMPLICIT);
681 ffebad_here (0, ffelex_token_where_line (first), ffelex_token_where_column (first));
687 /* ffestc_init_3 -- Initialize ffestc for new program unit
694 ffestv_save_state_ = FFESTV_savestateNONE;
695 ffestc_entry_num_ = 0;
696 ffestv_num_label_defines_ = 0;
699 /* ffestc_init_4 -- Initialize ffestc for new scoping unit
703 For SUBROUTINEs/FUNCTIONs within INTERFACE/END INTERFACE, derived-TYPE-
704 defs, and statement function defs. */
709 ffestc_saved_entry_num_ = ffestc_entry_num_;
710 ffestc_entry_num_ = 0;
713 /* ffestc_kindtype_kind_ -- Determine kindtype from basictype and KIND= value
717 ffetargetCharacterSize val;
718 kt = ffestc_kindtype_kind_(bt,val);
719 if (kt == FFEINFO_kindtypeNONE)
720 // unsupported/invalid KIND= value for type */
722 static ffeinfoKindtype
723 ffestc_kindtype_kind_ (ffeinfoBasictype bt, ffetargetCharacterSize val)
729 base_type = ffeinfo_type (bt, 1); /* ~~ */
730 assert (base_type != NULL);
732 type = ffetype_lookup_kind (base_type, (int) val);
734 return FFEINFO_kindtypeNONE;
736 for (kt = 1; kt < FFEINFO_kindtype; ++kt)
737 if (ffeinfo_type (bt, kt) == type)
740 return FFEINFO_kindtypeNONE;
743 /* ffestc_kindtype_star_ -- Determine kindtype from basictype and * value
747 ffetargetCharacterSize val;
748 kt = ffestc_kindtype_star_(bt,val);
749 if (kt == FFEINFO_kindtypeNONE)
750 // unsupported/invalid * value for type */
752 static ffeinfoKindtype
753 ffestc_kindtype_star_ (ffeinfoBasictype bt, ffetargetCharacterSize val)
759 base_type = ffeinfo_type (bt, 1); /* ~~ */
760 assert (base_type != NULL);
762 type = ffetype_lookup_star (base_type, (int) val);
764 return FFEINFO_kindtypeNONE;
766 for (kt = 1; kt < FFEINFO_kindtype; ++kt)
767 if (ffeinfo_type (bt, kt) == type)
770 return FFEINFO_kindtypeNONE;
773 /* Define label as usable for anything without complaint. */
776 ffestc_labeldef_any_ ()
778 if ((ffesta_label_token == NULL)
779 || !ffestc_labeldef_begin_ ())
782 ffelab_set_type (ffestc_label_, FFELAB_typeANY);
783 ffestd_labeldef_any (ffestc_label_);
785 ffestc_labeldef_branch_end_ ();
788 /* ffestc_labeldef_begin_ -- Define label as unknown, initially
790 ffestc_labeldef_begin_(); */
793 ffestc_labeldef_begin_ ()
795 ffelabValue label_value;
798 label_value = (ffelabValue) atol (ffelex_token_text (ffesta_label_token));
799 if ((label_value == 0) || (label_value > FFELAB_valueMAX))
801 ffebad_start (FFEBAD_LABEL_NUMBER_INVALID);
802 ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
803 ffelex_token_where_column (ffesta_label_token));
807 label = ffelab_find (label_value);
810 label = ffestc_label_ = ffelab_new (label_value);
811 ffestv_num_label_defines_++;
812 ffelab_set_definition_line (label,
813 ffewhere_line_use (ffelex_token_where_line (ffesta_label_token)));
814 ffelab_set_definition_column (label,
815 ffewhere_column_use (ffelex_token_where_column (ffesta_label_token)));
820 if (ffewhere_line_is_unknown (ffelab_definition_line (label)))
822 ffestv_num_label_defines_++;
823 ffestc_label_ = label;
824 ffelab_set_definition_line (label,
825 ffewhere_line_use (ffelex_token_where_line (ffesta_label_token)));
826 ffelab_set_definition_column (label,
827 ffewhere_column_use (ffelex_token_where_column (ffesta_label_token)));
832 ffebad_start (FFEBAD_LABEL_ALREADY_DEFINED);
833 ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
834 ffelex_token_where_column (ffesta_label_token));
835 ffebad_here (1, ffelab_definition_line (label),
836 ffelab_definition_column (label));
837 ffebad_string (ffelex_token_text (ffesta_label_token));
840 ffelex_token_kill (ffesta_label_token);
841 ffesta_label_token = NULL;
845 /* ffestc_labeldef_branch_begin_ -- Define label as a branch target one
847 ffestc_labeldef_branch_begin_(); */
850 ffestc_labeldef_branch_begin_ ()
852 if ((ffesta_label_token == NULL)
853 || (ffestc_shriek_after1_ != NULL)
854 || !ffestc_labeldef_begin_ ())
857 switch (ffelab_type (ffestc_label_))
859 case FFELAB_typeUNKNOWN:
860 case FFELAB_typeASSIGNABLE:
861 ffelab_set_type (ffestc_label_, FFELAB_typeNOTLOOP);
862 ffelab_set_blocknum (ffestc_label_,
863 ffestw_blocknum (ffestw_stack_top ()));
864 ffestd_labeldef_branch (ffestc_label_);
867 case FFELAB_typeNOTLOOP:
868 if (ffelab_blocknum (ffestc_label_)
869 < ffestw_blocknum (ffestw_stack_top ()))
871 ffebad_start (FFEBAD_LABEL_BLOCK);
872 ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
873 ffelex_token_where_column (ffesta_label_token));
874 ffebad_here (1, ffelab_firstref_line (ffestc_label_),
875 ffelab_firstref_column (ffestc_label_));
878 ffelab_set_blocknum (ffestc_label_,
879 ffestw_blocknum (ffestw_stack_top ()));
880 ffestd_labeldef_branch (ffestc_label_);
883 case FFELAB_typeLOOPEND:
884 if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO)
885 || (ffestw_label (ffestw_stack_top ()) != ffestc_label_))
886 { /* Unterminated block. */
887 ffelab_set_type (ffestc_label_, FFELAB_typeANY);
888 ffestd_labeldef_any (ffestc_label_);
890 ffebad_start (FFEBAD_LABEL_DO_BLOCK_END);
891 ffebad_here (0, ffelab_doref_line (ffestc_label_),
892 ffelab_doref_column (ffestc_label_));
893 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
894 ffebad_here (2, ffelex_token_where_line (ffesta_label_token),
895 ffelex_token_where_column (ffesta_label_token));
899 ffestd_labeldef_branch (ffestc_label_);
900 /* Leave something around for _branch_end_() to handle. */
903 case FFELAB_typeFORMAT:
904 ffelab_set_type (ffestc_label_, FFELAB_typeANY);
905 ffestd_labeldef_any (ffestc_label_);
907 ffebad_start (FFEBAD_LABEL_USE_DEF);
908 ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
909 ffelex_token_where_column (ffesta_label_token));
910 ffebad_here (1, ffelab_firstref_line (ffestc_label_),
911 ffelab_firstref_column (ffestc_label_));
916 assert ("bad label" == NULL);
922 ffestc_try_shriek_do_ ();
924 ffelex_token_kill (ffesta_label_token);
925 ffesta_label_token = NULL;
928 /* Define possible end of labeled-DO-loop. Call only after calling
929 ffestc_labeldef_branch_begin_, or when other branch_* functions
930 recognize that a label might also be serving as a branch end (in
931 which case they must issue a diagnostic). */
934 ffestc_labeldef_branch_end_ ()
936 if (ffesta_label_token == NULL)
939 assert (ffestc_label_ != NULL);
940 assert ((ffelab_type (ffestc_label_) == FFELAB_typeLOOPEND)
941 || (ffelab_type (ffestc_label_) == FFELAB_typeANY));
943 while ((ffestw_state (ffestw_stack_top ()) == FFESTV_stateDO)
944 && (ffestw_label (ffestw_stack_top ()) == ffestc_label_))
945 ffestc_shriek_do_ (TRUE);
947 ffestc_try_shriek_do_ ();
949 ffelex_token_kill (ffesta_label_token);
950 ffesta_label_token = NULL;
953 /* ffestc_labeldef_endif_ -- Define label as an END IF one
955 ffestc_labeldef_endif_(); */
958 ffestc_labeldef_endif_ ()
960 if ((ffesta_label_token == NULL)
961 || (ffestc_shriek_after1_ != NULL)
962 || !ffestc_labeldef_begin_ ())
965 switch (ffelab_type (ffestc_label_))
967 case FFELAB_typeUNKNOWN:
968 case FFELAB_typeASSIGNABLE:
969 ffelab_set_type (ffestc_label_, FFELAB_typeENDIF);
970 ffelab_set_blocknum (ffestc_label_,
971 ffestw_blocknum (ffestw_previous (ffestw_stack_top ())));
972 ffestd_labeldef_endif (ffestc_label_);
975 case FFELAB_typeNOTLOOP:
976 if (ffelab_blocknum (ffestc_label_)
977 < ffestw_blocknum (ffestw_previous (ffestw_stack_top ())))
979 ffebad_start (FFEBAD_LABEL_BLOCK);
980 ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
981 ffelex_token_where_column (ffesta_label_token));
982 ffebad_here (1, ffelab_firstref_line (ffestc_label_),
983 ffelab_firstref_column (ffestc_label_));
986 ffelab_set_blocknum (ffestc_label_,
987 ffestw_blocknum (ffestw_previous (ffestw_stack_top ())));
988 ffestd_labeldef_endif (ffestc_label_);
991 case FFELAB_typeLOOPEND:
992 if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO)
993 || (ffestw_label (ffestw_stack_top ()) != ffestc_label_))
994 { /* Unterminated block. */
995 ffelab_set_type (ffestc_label_, FFELAB_typeANY);
996 ffestd_labeldef_any (ffestc_label_);
998 ffebad_start (FFEBAD_LABEL_DO_BLOCK_END);
999 ffebad_here (0, ffelab_doref_line (ffestc_label_),
1000 ffelab_doref_column (ffestc_label_));
1001 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
1002 ffebad_here (2, ffelex_token_where_line (ffesta_label_token),
1003 ffelex_token_where_column (ffesta_label_token));
1007 ffestd_labeldef_endif (ffestc_label_);
1008 ffebad_start (FFEBAD_LABEL_USE_DEF);
1009 ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
1010 ffelex_token_where_column (ffesta_label_token));
1011 ffebad_here (1, ffelab_doref_line (ffestc_label_),
1012 ffelab_doref_column (ffestc_label_));
1014 ffestc_labeldef_branch_end_ ();
1017 case FFELAB_typeFORMAT:
1018 ffelab_set_type (ffestc_label_, FFELAB_typeANY);
1019 ffestd_labeldef_any (ffestc_label_);
1021 ffebad_start (FFEBAD_LABEL_USE_DEF);
1022 ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
1023 ffelex_token_where_column (ffesta_label_token));
1024 ffebad_here (1, ffelab_firstref_line (ffestc_label_),
1025 ffelab_firstref_column (ffestc_label_));
1030 assert ("bad label" == NULL);
1032 case FFELAB_typeANY:
1036 ffestc_try_shriek_do_ ();
1038 ffelex_token_kill (ffesta_label_token);
1039 ffesta_label_token = NULL;
1042 /* ffestc_labeldef_format_ -- Define label as a FORMAT one
1044 ffestc_labeldef_format_(); */
1047 ffestc_labeldef_format_ ()
1049 if ((ffesta_label_token == NULL)
1050 || (ffestc_shriek_after1_ != NULL))
1052 ffebad_start (FFEBAD_FORMAT_NO_LABEL_DEF);
1053 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
1054 ffelex_token_where_column (ffesta_tokens[0]));
1059 if (!ffestc_labeldef_begin_ ())
1062 switch (ffelab_type (ffestc_label_))
1064 case FFELAB_typeUNKNOWN:
1065 case FFELAB_typeASSIGNABLE:
1066 ffelab_set_type (ffestc_label_, FFELAB_typeFORMAT);
1067 ffestd_labeldef_format (ffestc_label_);
1070 case FFELAB_typeFORMAT:
1071 ffestd_labeldef_format (ffestc_label_);
1074 case FFELAB_typeLOOPEND:
1075 if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO)
1076 || (ffestw_label (ffestw_stack_top ()) != ffestc_label_))
1077 { /* Unterminated block. */
1078 ffelab_set_type (ffestc_label_, FFELAB_typeANY);
1079 ffestd_labeldef_any (ffestc_label_);
1081 ffebad_start (FFEBAD_LABEL_DO_BLOCK_END);
1082 ffebad_here (0, ffelab_doref_line (ffestc_label_),
1083 ffelab_doref_column (ffestc_label_));
1084 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
1085 ffebad_here (2, ffelex_token_where_line (ffesta_label_token),
1086 ffelex_token_where_column (ffesta_label_token));
1090 ffestd_labeldef_format (ffestc_label_);
1091 ffebad_start (FFEBAD_LABEL_USE_DEF);
1092 ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
1093 ffelex_token_where_column (ffesta_label_token));
1094 ffebad_here (1, ffelab_doref_line (ffestc_label_),
1095 ffelab_doref_column (ffestc_label_));
1097 ffestc_labeldef_branch_end_ ();
1100 case FFELAB_typeNOTLOOP:
1101 ffelab_set_type (ffestc_label_, FFELAB_typeANY);
1102 ffestd_labeldef_any (ffestc_label_);
1104 ffebad_start (FFEBAD_LABEL_USE_DEF);
1105 ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
1106 ffelex_token_where_column (ffesta_label_token));
1107 ffebad_here (1, ffelab_firstref_line (ffestc_label_),
1108 ffelab_firstref_column (ffestc_label_));
1113 assert ("bad label" == NULL);
1115 case FFELAB_typeANY:
1119 ffestc_try_shriek_do_ ();
1121 ffelex_token_kill (ffesta_label_token);
1122 ffesta_label_token = NULL;
1125 /* ffestc_labeldef_invalid_ -- Label definition invalid, complain if present
1127 ffestc_labeldef_invalid_(); */
1130 ffestc_labeldef_invalid_ ()
1132 if ((ffesta_label_token == NULL)
1133 || (ffestc_shriek_after1_ != NULL)
1134 || !ffestc_labeldef_begin_ ())
1137 ffebad_start (FFEBAD_INVALID_LABEL_DEF);
1138 ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
1139 ffelex_token_where_column (ffesta_label_token));
1142 ffelab_set_type (ffestc_label_, FFELAB_typeANY);
1143 ffestd_labeldef_any (ffestc_label_);
1145 ffestc_try_shriek_do_ ();
1147 ffelex_token_kill (ffesta_label_token);
1148 ffesta_label_token = NULL;
1151 /* Define label as a non-loop-ending one on a statement that can't
1152 be in the "then" part of a logical IF, such as a block-IF statement. */
1155 ffestc_labeldef_notloop_ ()
1157 if (ffesta_label_token == NULL)
1160 assert (ffestc_shriek_after1_ == NULL);
1162 if (!ffestc_labeldef_begin_ ())
1165 switch (ffelab_type (ffestc_label_))
1167 case FFELAB_typeUNKNOWN:
1168 case FFELAB_typeASSIGNABLE:
1169 ffelab_set_type (ffestc_label_, FFELAB_typeNOTLOOP);
1170 ffelab_set_blocknum (ffestc_label_,
1171 ffestw_blocknum (ffestw_stack_top ()));
1172 ffestd_labeldef_notloop (ffestc_label_);
1175 case FFELAB_typeNOTLOOP:
1176 if (ffelab_blocknum (ffestc_label_)
1177 < ffestw_blocknum (ffestw_stack_top ()))
1179 ffebad_start (FFEBAD_LABEL_BLOCK);
1180 ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
1181 ffelex_token_where_column (ffesta_label_token));
1182 ffebad_here (1, ffelab_firstref_line (ffestc_label_),
1183 ffelab_firstref_column (ffestc_label_));
1186 ffelab_set_blocknum (ffestc_label_,
1187 ffestw_blocknum (ffestw_stack_top ()));
1188 ffestd_labeldef_notloop (ffestc_label_);
1191 case FFELAB_typeLOOPEND:
1192 if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO)
1193 || (ffestw_label (ffestw_stack_top ()) != ffestc_label_))
1194 { /* Unterminated block. */
1195 ffelab_set_type (ffestc_label_, FFELAB_typeANY);
1196 ffestd_labeldef_any (ffestc_label_);
1198 ffebad_start (FFEBAD_LABEL_DO_BLOCK_END);
1199 ffebad_here (0, ffelab_doref_line (ffestc_label_),
1200 ffelab_doref_column (ffestc_label_));
1201 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
1202 ffebad_here (2, ffelex_token_where_line (ffesta_label_token),
1203 ffelex_token_where_column (ffesta_label_token));
1207 ffestd_labeldef_notloop (ffestc_label_);
1208 ffebad_start (FFEBAD_LABEL_USE_DEF);
1209 ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
1210 ffelex_token_where_column (ffesta_label_token));
1211 ffebad_here (1, ffelab_doref_line (ffestc_label_),
1212 ffelab_doref_column (ffestc_label_));
1214 ffestc_labeldef_branch_end_ ();
1217 case FFELAB_typeFORMAT:
1218 ffelab_set_type (ffestc_label_, FFELAB_typeANY);
1219 ffestd_labeldef_any (ffestc_label_);
1221 ffebad_start (FFEBAD_LABEL_USE_DEF);
1222 ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
1223 ffelex_token_where_column (ffesta_label_token));
1224 ffebad_here (1, ffelab_firstref_line (ffestc_label_),
1225 ffelab_firstref_column (ffestc_label_));
1230 assert ("bad label" == NULL);
1232 case FFELAB_typeANY:
1236 ffestc_try_shriek_do_ ();
1238 ffelex_token_kill (ffesta_label_token);
1239 ffesta_label_token = NULL;
1242 /* Define label as a non-loop-ending one. Use this when it is
1243 possible that the pending label is inhibited because we're in
1244 the midst of a logical-IF, and thus _branch_end_ is going to
1245 be called after the current statement to resolve a potential
1246 loop-ending label. */
1249 ffestc_labeldef_notloop_begin_ ()
1251 if ((ffesta_label_token == NULL)
1252 || (ffestc_shriek_after1_ != NULL)
1253 || !ffestc_labeldef_begin_ ())
1256 switch (ffelab_type (ffestc_label_))
1258 case FFELAB_typeUNKNOWN:
1259 case FFELAB_typeASSIGNABLE:
1260 ffelab_set_type (ffestc_label_, FFELAB_typeNOTLOOP);
1261 ffelab_set_blocknum (ffestc_label_,
1262 ffestw_blocknum (ffestw_stack_top ()));
1263 ffestd_labeldef_notloop (ffestc_label_);
1266 case FFELAB_typeNOTLOOP:
1267 if (ffelab_blocknum (ffestc_label_)
1268 < ffestw_blocknum (ffestw_stack_top ()))
1270 ffebad_start (FFEBAD_LABEL_BLOCK);
1271 ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
1272 ffelex_token_where_column (ffesta_label_token));
1273 ffebad_here (1, ffelab_firstref_line (ffestc_label_),
1274 ffelab_firstref_column (ffestc_label_));
1277 ffelab_set_blocknum (ffestc_label_,
1278 ffestw_blocknum (ffestw_stack_top ()));
1279 ffestd_labeldef_notloop (ffestc_label_);
1282 case FFELAB_typeLOOPEND:
1283 if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO)
1284 || (ffestw_label (ffestw_stack_top ()) != ffestc_label_))
1285 { /* Unterminated block. */
1286 ffelab_set_type (ffestc_label_, FFELAB_typeANY);
1287 ffestd_labeldef_any (ffestc_label_);
1289 ffebad_start (FFEBAD_LABEL_DO_BLOCK_END);
1290 ffebad_here (0, ffelab_doref_line (ffestc_label_),
1291 ffelab_doref_column (ffestc_label_));
1292 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
1293 ffebad_here (2, ffelex_token_where_line (ffesta_label_token),
1294 ffelex_token_where_column (ffesta_label_token));
1298 ffestd_labeldef_branch (ffestc_label_);
1299 ffebad_start (FFEBAD_LABEL_USE_DEF);
1300 ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
1301 ffelex_token_where_column (ffesta_label_token));
1302 ffebad_here (1, ffelab_doref_line (ffestc_label_),
1303 ffelab_doref_column (ffestc_label_));
1307 case FFELAB_typeFORMAT:
1308 ffelab_set_type (ffestc_label_, FFELAB_typeANY);
1309 ffestd_labeldef_any (ffestc_label_);
1311 ffebad_start (FFEBAD_LABEL_USE_DEF);
1312 ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
1313 ffelex_token_where_column (ffesta_label_token));
1314 ffebad_here (1, ffelab_firstref_line (ffestc_label_),
1315 ffelab_firstref_column (ffestc_label_));
1320 assert ("bad label" == NULL);
1322 case FFELAB_typeANY:
1326 ffestc_try_shriek_do_ ();
1328 ffelex_token_kill (ffesta_label_token);
1329 ffesta_label_token = NULL;
1332 /* ffestc_labeldef_useless_ -- Define label as a useless one
1334 ffestc_labeldef_useless_(); */
1337 ffestc_labeldef_useless_ ()
1339 if ((ffesta_label_token == NULL)
1340 || (ffestc_shriek_after1_ != NULL)
1341 || !ffestc_labeldef_begin_ ())
1344 switch (ffelab_type (ffestc_label_))
1346 case FFELAB_typeUNKNOWN:
1347 ffelab_set_type (ffestc_label_, FFELAB_typeUSELESS);
1348 ffestd_labeldef_useless (ffestc_label_);
1351 case FFELAB_typeLOOPEND:
1352 ffelab_set_type (ffestc_label_, FFELAB_typeANY);
1353 ffestd_labeldef_any (ffestc_label_);
1355 if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO)
1356 || (ffestw_label (ffestw_stack_top ()) != ffestc_label_))
1357 { /* Unterminated block. */
1358 ffebad_start (FFEBAD_LABEL_DO_BLOCK_END);
1359 ffebad_here (0, ffelab_doref_line (ffestc_label_),
1360 ffelab_doref_column (ffestc_label_));
1361 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
1362 ffebad_here (2, ffelex_token_where_line (ffesta_label_token),
1363 ffelex_token_where_column (ffesta_label_token));
1367 ffebad_start (FFEBAD_LABEL_USE_DEF);
1368 ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
1369 ffelex_token_where_column (ffesta_label_token));
1370 ffebad_here (1, ffelab_doref_line (ffestc_label_),
1371 ffelab_doref_column (ffestc_label_));
1373 ffestc_labeldef_branch_end_ ();
1376 case FFELAB_typeASSIGNABLE:
1377 case FFELAB_typeFORMAT:
1378 case FFELAB_typeNOTLOOP:
1379 ffelab_set_type (ffestc_label_, FFELAB_typeANY);
1380 ffestd_labeldef_any (ffestc_label_);
1382 ffebad_start (FFEBAD_LABEL_USE_DEF);
1383 ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
1384 ffelex_token_where_column (ffesta_label_token));
1385 ffebad_here (1, ffelab_firstref_line (ffestc_label_),
1386 ffelab_firstref_column (ffestc_label_));
1391 assert ("bad label" == NULL);
1393 case FFELAB_typeANY:
1397 ffestc_try_shriek_do_ ();
1399 ffelex_token_kill (ffesta_label_token);
1400 ffesta_label_token = NULL;
1403 /* ffestc_labelref_is_assignable_ -- Reference to label in ASSIGN stmt
1405 if (ffestc_labelref_is_assignable_(label_token,&label))
1406 // label ref is ok, label is filled in with ffelab object */
1409 ffestc_labelref_is_assignable_ (ffelexToken label_token, ffelab *x_label)
1412 ffelabValue label_value;
1414 label_value = (ffelabValue) atol (ffelex_token_text (label_token));
1415 if ((label_value == 0) || (label_value > FFELAB_valueMAX))
1417 ffebad_start (FFEBAD_LABEL_NUMBER_INVALID);
1418 ffebad_here (0, ffelex_token_where_line (label_token),
1419 ffelex_token_where_column (label_token));
1424 label = ffelab_find (label_value);
1427 label = ffelab_new (label_value);
1428 ffelab_set_firstref_line (label,
1429 ffewhere_line_use (ffelex_token_where_line (label_token)));
1430 ffelab_set_firstref_column (label,
1431 ffewhere_column_use (ffelex_token_where_column (label_token)));
1434 switch (ffelab_type (label))
1436 case FFELAB_typeUNKNOWN:
1437 ffelab_set_type (label, FFELAB_typeASSIGNABLE);
1440 case FFELAB_typeASSIGNABLE:
1441 case FFELAB_typeLOOPEND:
1442 case FFELAB_typeFORMAT:
1443 case FFELAB_typeNOTLOOP:
1444 case FFELAB_typeENDIF:
1447 case FFELAB_typeUSELESS:
1448 ffelab_set_type (label, FFELAB_typeANY);
1449 ffestd_labeldef_any (label);
1451 ffebad_start (FFEBAD_LABEL_USE_DEF);
1452 ffebad_here (0, ffelab_firstref_line (label), ffelab_firstref_column (label));
1453 ffebad_here (1, ffelex_token_where_line (label_token),
1454 ffelex_token_where_column (label_token));
1457 ffestc_try_shriek_do_ ();
1462 assert ("bad label" == NULL);
1464 case FFELAB_typeANY:
1472 /* ffestc_labelref_is_branch_ -- Reference to label in branch stmt
1474 if (ffestc_labelref_is_branch_(label_token,&label))
1475 // label ref is ok, label is filled in with ffelab object */
1478 ffestc_labelref_is_branch_ (ffelexToken label_token, ffelab *x_label)
1481 ffelabValue label_value;
1483 unsigned long blocknum;
1485 label_value = (ffelabValue) atol (ffelex_token_text (label_token));
1486 if ((label_value == 0) || (label_value > FFELAB_valueMAX))
1488 ffebad_start (FFEBAD_LABEL_NUMBER_INVALID);
1489 ffebad_here (0, ffelex_token_where_line (label_token),
1490 ffelex_token_where_column (label_token));
1495 label = ffelab_find (label_value);
1498 label = ffelab_new (label_value);
1499 ffelab_set_firstref_line (label,
1500 ffewhere_line_use (ffelex_token_where_line (label_token)));
1501 ffelab_set_firstref_column (label,
1502 ffewhere_column_use (ffelex_token_where_column (label_token)));
1505 switch (ffelab_type (label))
1507 case FFELAB_typeUNKNOWN:
1508 case FFELAB_typeASSIGNABLE:
1509 ffelab_set_type (label, FFELAB_typeNOTLOOP);
1510 ffelab_set_blocknum (label, ffestw_blocknum (ffestw_stack_top ()));
1513 case FFELAB_typeLOOPEND:
1514 if (ffelab_blocknum (label) != 0)
1515 break; /* Already taken care of. */
1516 for (block = ffestw_top_do (ffestw_stack_top ());
1517 (block != NULL) && (ffestw_label (block) != label);
1518 block = ffestw_top_do (ffestw_previous (block)))
1519 ; /* Find most recent DO <label> ancestor. */
1521 { /* Reference to within a (dead) block. */
1522 ffebad_start (FFEBAD_LABEL_BLOCK);
1523 ffebad_here (0, ffelab_definition_line (label),
1524 ffelab_definition_column (label));
1525 ffebad_here (1, ffelex_token_where_line (label_token),
1526 ffelex_token_where_column (label_token));
1530 ffelab_set_blocknum (label, ffestw_blocknum (block));
1531 ffelab_set_firstref_line (label,
1532 ffewhere_line_use (ffelex_token_where_line (label_token)));
1533 ffelab_set_firstref_column (label,
1534 ffewhere_column_use (ffelex_token_where_column (label_token)));
1537 case FFELAB_typeNOTLOOP:
1538 case FFELAB_typeENDIF:
1539 if (ffelab_blocknum (label) == ffestw_blocknum (ffestw_stack_top ()))
1541 blocknum = ffelab_blocknum (label);
1542 for (block = ffestw_stack_top ();
1543 ffestw_blocknum (block) > blocknum;
1544 block = ffestw_previous (block))
1545 ; /* Find most recent common ancestor. */
1546 if (ffelab_blocknum (label) == ffestw_blocknum (block))
1547 break; /* Check again. */
1548 if (!ffewhere_line_is_unknown (ffelab_definition_line (label)))
1549 { /* Reference to within a (dead) block. */
1550 ffebad_start (FFEBAD_LABEL_BLOCK);
1551 ffebad_here (0, ffelab_definition_line (label),
1552 ffelab_definition_column (label));
1553 ffebad_here (1, ffelex_token_where_line (label_token),
1554 ffelex_token_where_column (label_token));
1558 ffelab_set_blocknum (label, ffestw_blocknum (block));
1561 case FFELAB_typeFORMAT:
1562 if (ffewhere_line_is_unknown (ffelab_definition_line (label)))
1564 ffelab_set_type (label, FFELAB_typeANY);
1565 ffestd_labeldef_any (label);
1567 ffebad_start (FFEBAD_LABEL_USE_USE);
1568 ffebad_here (0, ffelab_firstref_line (label), ffelab_firstref_column (label));
1569 ffebad_here (1, ffelex_token_where_line (label_token),
1570 ffelex_token_where_column (label_token));
1573 ffestc_try_shriek_do_ ();
1578 case FFELAB_typeUSELESS:
1579 ffelab_set_type (label, FFELAB_typeANY);
1580 ffestd_labeldef_any (label);
1582 ffebad_start (FFEBAD_LABEL_USE_DEF);
1583 ffebad_here (0, ffelab_definition_line (label), ffelab_definition_column (label));
1584 ffebad_here (1, ffelex_token_where_line (label_token),
1585 ffelex_token_where_column (label_token));
1588 ffestc_try_shriek_do_ ();
1593 assert ("bad label" == NULL);
1595 case FFELAB_typeANY:
1603 /* ffestc_labelref_is_format_ -- Reference to label in [FMT=] specification
1605 if (ffestc_labelref_is_format_(label_token,&label))
1606 // label ref is ok, label is filled in with ffelab object */
1609 ffestc_labelref_is_format_ (ffelexToken label_token, ffelab *x_label)
1612 ffelabValue label_value;
1614 label_value = (ffelabValue) atol (ffelex_token_text (label_token));
1615 if ((label_value == 0) || (label_value > FFELAB_valueMAX))
1617 ffebad_start (FFEBAD_LABEL_NUMBER_INVALID);
1618 ffebad_here (0, ffelex_token_where_line (label_token),
1619 ffelex_token_where_column (label_token));
1624 label = ffelab_find (label_value);
1627 label = ffelab_new (label_value);
1628 ffelab_set_firstref_line (label,
1629 ffewhere_line_use (ffelex_token_where_line (label_token)));
1630 ffelab_set_firstref_column (label,
1631 ffewhere_column_use (ffelex_token_where_column (label_token)));
1634 switch (ffelab_type (label))
1636 case FFELAB_typeUNKNOWN:
1637 case FFELAB_typeASSIGNABLE:
1638 ffelab_set_type (label, FFELAB_typeFORMAT);
1641 case FFELAB_typeFORMAT:
1644 case FFELAB_typeLOOPEND:
1645 case FFELAB_typeNOTLOOP:
1646 if (ffewhere_line_is_unknown (ffelab_definition_line (label)))
1648 ffelab_set_type (label, FFELAB_typeANY);
1649 ffestd_labeldef_any (label);
1651 ffebad_start (FFEBAD_LABEL_USE_USE);
1652 ffebad_here (0, ffelab_firstref_line (label), ffelab_firstref_column (label));
1653 ffebad_here (1, ffelex_token_where_line (label_token),
1654 ffelex_token_where_column (label_token));
1657 ffestc_try_shriek_do_ ();
1662 case FFELAB_typeUSELESS:
1663 case FFELAB_typeENDIF:
1664 ffelab_set_type (label, FFELAB_typeANY);
1665 ffestd_labeldef_any (label);
1667 ffebad_start (FFEBAD_LABEL_USE_DEF);
1668 ffebad_here (0, ffelab_definition_line (label), ffelab_definition_column (label));
1669 ffebad_here (1, ffelex_token_where_line (label_token),
1670 ffelex_token_where_column (label_token));
1673 ffestc_try_shriek_do_ ();
1678 assert ("bad label" == NULL);
1680 case FFELAB_typeANY:
1684 ffestc_try_shriek_do_ ();
1690 /* ffestc_labelref_is_loopend_ -- Reference to label in DO stmt
1692 if (ffestc_labelref_is_loopend_(label_token,&label))
1693 // label ref is ok, label is filled in with ffelab object */
1696 ffestc_labelref_is_loopend_ (ffelexToken label_token, ffelab *x_label)
1699 ffelabValue label_value;
1701 label_value = (ffelabValue) atol (ffelex_token_text (label_token));
1702 if ((label_value == 0) || (label_value > FFELAB_valueMAX))
1704 ffebad_start (FFEBAD_LABEL_NUMBER_INVALID);
1705 ffebad_here (0, ffelex_token_where_line (label_token),
1706 ffelex_token_where_column (label_token));
1711 label = ffelab_find (label_value);
1714 label = ffelab_new (label_value);
1715 ffelab_set_doref_line (label,
1716 ffewhere_line_use (ffelex_token_where_line (label_token)));
1717 ffelab_set_doref_column (label,
1718 ffewhere_column_use (ffelex_token_where_column (label_token)));
1721 switch (ffelab_type (label))
1723 case FFELAB_typeASSIGNABLE:
1724 ffelab_set_doref_line (label,
1725 ffewhere_line_use (ffelex_token_where_line (label_token)));
1726 ffelab_set_doref_column (label,
1727 ffewhere_column_use (ffelex_token_where_column (label_token)));
1728 ffewhere_line_kill (ffelab_firstref_line (label));
1729 ffelab_set_firstref_line (label, ffewhere_line_unknown ());
1730 ffewhere_column_kill (ffelab_firstref_column (label));
1731 ffelab_set_firstref_column (label, ffewhere_column_unknown ());
1733 case FFELAB_typeUNKNOWN:
1734 ffelab_set_type (label, FFELAB_typeLOOPEND);
1735 ffelab_set_blocknum (label, 0);
1738 case FFELAB_typeLOOPEND:
1739 if (!ffewhere_line_is_unknown (ffelab_definition_line (label)))
1740 { /* Def must follow all refs. */
1741 ffelab_set_type (label, FFELAB_typeANY);
1742 ffestd_labeldef_any (label);
1744 ffebad_start (FFEBAD_LABEL_DEF_DO);
1745 ffebad_here (0, ffelab_definition_line (label),
1746 ffelab_definition_column (label));
1747 ffebad_here (1, ffelex_token_where_line (label_token),
1748 ffelex_token_where_column (label_token));
1751 ffestc_try_shriek_do_ ();
1755 if (ffelab_blocknum (label) != 0)
1756 { /* Had a branch ref earlier, can't go inside
1758 ffelab_set_type (label, FFELAB_typeANY);
1759 ffestd_labeldef_any (label);
1761 ffebad_start (FFEBAD_LABEL_USE_USE);
1762 ffebad_here (0, ffelab_firstref_line (label),
1763 ffelab_firstref_column (label));
1764 ffebad_here (1, ffelex_token_where_line (label_token),
1765 ffelex_token_where_column (label_token));
1768 ffestc_try_shriek_do_ ();
1772 if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO)
1773 || (ffestw_label (ffestw_stack_top ()) != label))
1774 { /* Top of stack interrupts flow between two
1775 DOs specifying label. */
1776 ffelab_set_type (label, FFELAB_typeANY);
1777 ffestd_labeldef_any (label);
1779 ffebad_start (FFEBAD_LABEL_DO_BLOCK_DO);
1780 ffebad_here (0, ffelab_doref_line (label),
1781 ffelab_doref_column (label));
1782 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
1783 ffebad_here (2, ffelex_token_where_line (label_token),
1784 ffelex_token_where_column (label_token));
1787 ffestc_try_shriek_do_ ();
1793 case FFELAB_typeNOTLOOP:
1794 case FFELAB_typeFORMAT:
1795 if (ffewhere_line_is_unknown (ffelab_definition_line (label)))
1797 ffelab_set_type (label, FFELAB_typeANY);
1798 ffestd_labeldef_any (label);
1800 ffebad_start (FFEBAD_LABEL_USE_USE);
1801 ffebad_here (0, ffelab_firstref_line (label), ffelab_firstref_column (label));
1802 ffebad_here (1, ffelex_token_where_line (label_token),
1803 ffelex_token_where_column (label_token));
1806 ffestc_try_shriek_do_ ();
1811 case FFELAB_typeUSELESS:
1812 case FFELAB_typeENDIF:
1813 ffelab_set_type (label, FFELAB_typeANY);
1814 ffestd_labeldef_any (label);
1816 ffebad_start (FFEBAD_LABEL_USE_DEF);
1817 ffebad_here (0, ffelab_definition_line (label), ffelab_definition_column (label));
1818 ffebad_here (1, ffelex_token_where_line (label_token),
1819 ffelex_token_where_column (label_token));
1822 ffestc_try_shriek_do_ ();
1827 assert ("bad label" == NULL);
1829 case FFELAB_typeANY:
1837 /* ffestc_order_access_ -- Check ordering on <access> statement
1839 if (ffestc_order_access_() != FFESTC_orderOK_)
1844 ffestc_order_access_ ()
1848 switch (ffestw_state (ffestw_stack_top ()))
1850 case FFESTV_stateNIL:
1851 ffestc_shriek_begin_program_ ();
1852 goto recurse; /* :::::::::::::::::::: */
1854 case FFESTV_stateMODULE0:
1855 case FFESTV_stateMODULE1:
1856 case FFESTV_stateMODULE2:
1857 ffestw_update (NULL);
1858 ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
1859 return FFESTC_orderOK_;
1861 case FFESTV_stateMODULE3:
1862 return FFESTC_orderOK_;
1864 case FFESTV_stateUSE:
1866 ffestc_shriek_end_uses_ (TRUE);
1868 goto recurse; /* :::::::::::::::::::: */
1870 case FFESTV_stateWHERE:
1871 ffestc_order_bad_ ();
1873 ffestc_shriek_where_ (FALSE);
1875 return FFESTC_orderBAD_;
1877 case FFESTV_stateIF:
1878 ffestc_order_bad_ ();
1879 ffestc_shriek_if_ (FALSE);
1880 return FFESTC_orderBAD_;
1883 ffestc_order_bad_ ();
1884 return FFESTC_orderBAD_;
1889 /* ffestc_order_actiondo_ -- Check ordering on <actiondo> statement
1891 if (ffestc_order_actiondo_() != FFESTC_orderOK_)
1895 ffestc_order_actiondo_ ()
1899 switch (ffestw_state (ffestw_stack_top ()))
1901 case FFESTV_stateNIL:
1902 ffestc_shriek_begin_program_ ();
1903 goto recurse; /* :::::::::::::::::::: */
1905 case FFESTV_stateDO:
1906 return FFESTC_orderOK_;
1908 case FFESTV_stateIFTHEN:
1909 case FFESTV_stateSELECT1:
1910 if (ffestw_top_do (ffestw_stack_top ()) == NULL)
1912 return FFESTC_orderOK_;
1914 case FFESTV_stateIF:
1915 if (ffestw_top_do (ffestw_stack_top ()) == NULL)
1917 ffestc_shriek_after1_ = ffestc_shriek_if_;
1918 return FFESTC_orderOK_;
1920 case FFESTV_stateUSE:
1922 ffestc_shriek_end_uses_ (TRUE);
1924 goto recurse; /* :::::::::::::::::::: */
1926 case FFESTV_stateWHERE:
1927 ffestc_order_bad_ ();
1929 ffestc_shriek_where_ (FALSE);
1931 return FFESTC_orderBAD_;
1936 ffestc_order_bad_ ();
1937 return FFESTC_orderBAD_;
1940 /* ffestc_order_actionif_ -- Check ordering on <actionif> statement
1942 if (ffestc_order_actionif_() != FFESTC_orderOK_)
1946 ffestc_order_actionif_ ()
1952 switch (ffestw_state (ffestw_stack_top ()))
1954 case FFESTV_stateNIL:
1955 ffestc_shriek_begin_program_ ();
1956 goto recurse; /* :::::::::::::::::::: */
1958 case FFESTV_statePROGRAM0:
1959 case FFESTV_statePROGRAM1:
1960 case FFESTV_statePROGRAM2:
1961 case FFESTV_statePROGRAM3:
1962 ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM4);
1966 case FFESTV_stateSUBROUTINE0:
1967 case FFESTV_stateSUBROUTINE1:
1968 case FFESTV_stateSUBROUTINE2:
1969 case FFESTV_stateSUBROUTINE3:
1970 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE4);
1974 case FFESTV_stateFUNCTION0:
1975 case FFESTV_stateFUNCTION1:
1976 case FFESTV_stateFUNCTION2:
1977 case FFESTV_stateFUNCTION3:
1978 ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION4);
1982 case FFESTV_statePROGRAM4:
1983 case FFESTV_stateSUBROUTINE4:
1984 case FFESTV_stateFUNCTION4:
1988 case FFESTV_stateIFTHEN:
1989 case FFESTV_stateDO:
1990 case FFESTV_stateSELECT1:
1991 return FFESTC_orderOK_;
1993 case FFESTV_stateIF:
1994 ffestc_shriek_after1_ = ffestc_shriek_if_;
1995 return FFESTC_orderOK_;
1997 case FFESTV_stateUSE:
1999 ffestc_shriek_end_uses_ (TRUE);
2001 goto recurse; /* :::::::::::::::::::: */
2003 case FFESTV_stateWHERE:
2004 ffestc_order_bad_ ();
2006 ffestc_shriek_where_ (FALSE);
2008 return FFESTC_orderBAD_;
2011 ffestc_order_bad_ ();
2012 return FFESTC_orderBAD_;
2015 switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
2017 case FFESTV_stateINTERFACE0:
2018 ffestc_order_bad_ ();
2020 ffestw_update (NULL);
2021 return FFESTC_orderBAD_;
2025 ffestw_update (NULL);
2026 return FFESTC_orderOK_;
2030 /* ffestc_order_actionwhere_ -- Check ordering on <actionwhere> statement
2032 if (ffestc_order_actionwhere_() != FFESTC_orderOK_)
2036 ffestc_order_actionwhere_ ()
2042 switch (ffestw_state (ffestw_stack_top ()))
2044 case FFESTV_stateNIL:
2045 ffestc_shriek_begin_program_ ();
2046 goto recurse; /* :::::::::::::::::::: */
2048 case FFESTV_statePROGRAM0:
2049 case FFESTV_statePROGRAM1:
2050 case FFESTV_statePROGRAM2:
2051 case FFESTV_statePROGRAM3:
2052 ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM4);
2056 case FFESTV_stateSUBROUTINE0:
2057 case FFESTV_stateSUBROUTINE1:
2058 case FFESTV_stateSUBROUTINE2:
2059 case FFESTV_stateSUBROUTINE3:
2060 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE4);
2064 case FFESTV_stateFUNCTION0:
2065 case FFESTV_stateFUNCTION1:
2066 case FFESTV_stateFUNCTION2:
2067 case FFESTV_stateFUNCTION3:
2068 ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION4);
2072 case FFESTV_statePROGRAM4:
2073 case FFESTV_stateSUBROUTINE4:
2074 case FFESTV_stateFUNCTION4:
2078 case FFESTV_stateWHERETHEN:
2079 case FFESTV_stateIFTHEN:
2080 case FFESTV_stateDO:
2081 case FFESTV_stateSELECT1:
2082 return FFESTC_orderOK_;
2084 case FFESTV_stateWHERE:
2086 ffestc_shriek_after1_ = ffestc_shriek_where_;
2088 return FFESTC_orderOK_;
2090 case FFESTV_stateIF:
2091 ffestc_shriek_after1_ = ffestc_shriek_if_;
2092 return FFESTC_orderOK_;
2094 case FFESTV_stateUSE:
2096 ffestc_shriek_end_uses_ (TRUE);
2098 goto recurse; /* :::::::::::::::::::: */
2101 ffestc_order_bad_ ();
2102 return FFESTC_orderBAD_;
2105 switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
2107 case FFESTV_stateINTERFACE0:
2108 ffestc_order_bad_ ();
2110 ffestw_update (NULL);
2111 return FFESTC_orderBAD_;
2115 ffestw_update (NULL);
2116 return FFESTC_orderOK_;
2120 /* Check ordering on "any" statement. Like _actionwhere_, but
2121 doesn't produce any diagnostics. */
2124 ffestc_order_any_ ()
2130 switch (ffestw_state (ffestw_stack_top ()))
2132 case FFESTV_stateNIL:
2133 ffestc_shriek_begin_program_ ();
2134 goto recurse; /* :::::::::::::::::::: */
2136 case FFESTV_statePROGRAM0:
2137 case FFESTV_statePROGRAM1:
2138 case FFESTV_statePROGRAM2:
2139 case FFESTV_statePROGRAM3:
2140 ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM4);
2144 case FFESTV_stateSUBROUTINE0:
2145 case FFESTV_stateSUBROUTINE1:
2146 case FFESTV_stateSUBROUTINE2:
2147 case FFESTV_stateSUBROUTINE3:
2148 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE4);
2152 case FFESTV_stateFUNCTION0:
2153 case FFESTV_stateFUNCTION1:
2154 case FFESTV_stateFUNCTION2:
2155 case FFESTV_stateFUNCTION3:
2156 ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION4);
2160 case FFESTV_statePROGRAM4:
2161 case FFESTV_stateSUBROUTINE4:
2162 case FFESTV_stateFUNCTION4:
2166 case FFESTV_stateWHERETHEN:
2167 case FFESTV_stateIFTHEN:
2168 case FFESTV_stateDO:
2169 case FFESTV_stateSELECT1:
2172 case FFESTV_stateWHERE:
2174 ffestc_shriek_after1_ = ffestc_shriek_where_;
2178 case FFESTV_stateIF:
2179 ffestc_shriek_after1_ = ffestc_shriek_if_;
2182 case FFESTV_stateUSE:
2184 ffestc_shriek_end_uses_ (TRUE);
2186 goto recurse; /* :::::::::::::::::::: */
2192 switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
2194 case FFESTV_stateINTERFACE0:
2196 ffestw_update (NULL);
2201 ffestw_update (NULL);
2206 /* ffestc_order_bad_ -- Whine about statement ordering violation
2208 ffestc_order_bad_();
2210 Uses current ffesta_tokens[0] and, if available, info on where current
2211 state started to produce generic message. Someday we should do
2212 fancier things than this, but this just gets things creaking along for
2216 ffestc_order_bad_ ()
2218 if (ffewhere_line_is_unknown (ffestw_line (ffestw_stack_top ())))
2220 ffebad_start (FFEBAD_ORDER_1);
2221 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
2222 ffelex_token_where_column (ffesta_tokens[0]));
2227 ffebad_start (FFEBAD_ORDER_2);
2228 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
2229 ffelex_token_where_column (ffesta_tokens[0]));
2230 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
2233 ffestc_labeldef_useless_ (); /* Any label definition is useless. */
2236 /* ffestc_order_blockdata_ -- Check ordering on <blockdata> statement
2238 if (ffestc_order_blockdata_() != FFESTC_orderOK_)
2242 ffestc_order_blockdata_ ()
2246 switch (ffestw_state (ffestw_stack_top ()))
2248 case FFESTV_stateBLOCKDATA0:
2249 case FFESTV_stateBLOCKDATA1:
2250 case FFESTV_stateBLOCKDATA2:
2251 case FFESTV_stateBLOCKDATA3:
2252 case FFESTV_stateBLOCKDATA4:
2253 case FFESTV_stateBLOCKDATA5:
2254 return FFESTC_orderOK_;
2256 case FFESTV_stateUSE:
2258 ffestc_shriek_end_uses_ (TRUE);
2260 goto recurse; /* :::::::::::::::::::: */
2262 case FFESTV_stateWHERE:
2263 ffestc_order_bad_ ();
2265 ffestc_shriek_where_ (FALSE);
2267 return FFESTC_orderBAD_;
2269 case FFESTV_stateIF:
2270 ffestc_order_bad_ ();
2271 ffestc_shriek_if_ (FALSE);
2272 return FFESTC_orderBAD_;
2275 ffestc_order_bad_ ();
2276 return FFESTC_orderBAD_;
2280 /* ffestc_order_blockspec_ -- Check ordering on <blockspec> statement
2282 if (ffestc_order_blockspec_() != FFESTC_orderOK_)
2286 ffestc_order_blockspec_ ()
2290 switch (ffestw_state (ffestw_stack_top ()))
2292 case FFESTV_stateNIL:
2293 ffestc_shriek_begin_program_ ();
2294 goto recurse; /* :::::::::::::::::::: */
2296 case FFESTV_statePROGRAM0:
2297 case FFESTV_statePROGRAM1:
2298 case FFESTV_statePROGRAM2:
2299 ffestw_update (NULL);
2300 ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
2301 return FFESTC_orderOK_;
2303 case FFESTV_stateSUBROUTINE0:
2304 case FFESTV_stateSUBROUTINE1:
2305 case FFESTV_stateSUBROUTINE2:
2306 ffestw_update (NULL);
2307 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
2308 return FFESTC_orderOK_;
2310 case FFESTV_stateFUNCTION0:
2311 case FFESTV_stateFUNCTION1:
2312 case FFESTV_stateFUNCTION2:
2313 ffestw_update (NULL);
2314 ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
2315 return FFESTC_orderOK_;
2317 case FFESTV_stateMODULE0:
2318 case FFESTV_stateMODULE1:
2319 case FFESTV_stateMODULE2:
2320 ffestw_update (NULL);
2321 ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
2322 return FFESTC_orderOK_;
2324 case FFESTV_stateBLOCKDATA0:
2325 case FFESTV_stateBLOCKDATA1:
2326 case FFESTV_stateBLOCKDATA2:
2327 ffestw_update (NULL);
2328 ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA3);
2329 return FFESTC_orderOK_;
2331 case FFESTV_statePROGRAM3:
2332 case FFESTV_stateSUBROUTINE3:
2333 case FFESTV_stateFUNCTION3:
2334 case FFESTV_stateMODULE3:
2335 case FFESTV_stateBLOCKDATA3:
2336 return FFESTC_orderOK_;
2338 case FFESTV_stateUSE:
2340 ffestc_shriek_end_uses_ (TRUE);
2342 goto recurse; /* :::::::::::::::::::: */
2344 case FFESTV_stateWHERE:
2345 ffestc_order_bad_ ();
2347 ffestc_shriek_where_ (FALSE);
2349 return FFESTC_orderBAD_;
2351 case FFESTV_stateIF:
2352 ffestc_order_bad_ ();
2353 ffestc_shriek_if_ (FALSE);
2354 return FFESTC_orderBAD_;
2357 ffestc_order_bad_ ();
2358 return FFESTC_orderBAD_;
2362 /* ffestc_order_component_ -- Check ordering on <component-decl> statement
2364 if (ffestc_order_component_() != FFESTC_orderOK_)
2369 ffestc_order_component_ ()
2371 switch (ffestw_state (ffestw_stack_top ()))
2373 case FFESTV_stateTYPE:
2374 case FFESTV_stateSTRUCTURE:
2375 case FFESTV_stateMAP:
2376 return FFESTC_orderOK_;
2378 case FFESTV_stateWHERE:
2379 ffestc_order_bad_ ();
2380 ffestc_shriek_where_ (FALSE);
2381 return FFESTC_orderBAD_;
2383 case FFESTV_stateIF:
2384 ffestc_order_bad_ ();
2385 ffestc_shriek_if_ (FALSE);
2386 return FFESTC_orderBAD_;
2389 ffestc_order_bad_ ();
2390 return FFESTC_orderBAD_;
2395 /* ffestc_order_contains_ -- Check ordering on CONTAINS statement
2397 if (ffestc_order_contains_() != FFESTC_orderOK_)
2402 ffestc_order_contains_ ()
2406 switch (ffestw_state (ffestw_stack_top ()))
2408 case FFESTV_stateNIL:
2409 ffestc_shriek_begin_program_ ();
2410 goto recurse; /* :::::::::::::::::::: */
2412 case FFESTV_statePROGRAM0:
2413 case FFESTV_statePROGRAM1:
2414 case FFESTV_statePROGRAM2:
2415 case FFESTV_statePROGRAM3:
2416 case FFESTV_statePROGRAM4:
2417 ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM5);
2420 case FFESTV_stateSUBROUTINE0:
2421 case FFESTV_stateSUBROUTINE1:
2422 case FFESTV_stateSUBROUTINE2:
2423 case FFESTV_stateSUBROUTINE3:
2424 case FFESTV_stateSUBROUTINE4:
2425 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE5);
2428 case FFESTV_stateFUNCTION0:
2429 case FFESTV_stateFUNCTION1:
2430 case FFESTV_stateFUNCTION2:
2431 case FFESTV_stateFUNCTION3:
2432 case FFESTV_stateFUNCTION4:
2433 ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION5);
2436 case FFESTV_stateMODULE0:
2437 case FFESTV_stateMODULE1:
2438 case FFESTV_stateMODULE2:
2439 case FFESTV_stateMODULE3:
2440 case FFESTV_stateMODULE4:
2441 ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE5);
2444 case FFESTV_stateUSE:
2445 ffestc_shriek_end_uses_ (TRUE);
2446 goto recurse; /* :::::::::::::::::::: */
2448 case FFESTV_stateWHERE:
2449 ffestc_order_bad_ ();
2450 ffestc_shriek_where_ (FALSE);
2451 return FFESTC_orderBAD_;
2453 case FFESTV_stateIF:
2454 ffestc_order_bad_ ();
2455 ffestc_shriek_if_ (FALSE);
2456 return FFESTC_orderBAD_;
2459 ffestc_order_bad_ ();
2460 return FFESTC_orderBAD_;
2463 switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
2465 case FFESTV_stateNIL:
2466 ffestw_update (NULL);
2467 return FFESTC_orderOK_;
2470 ffestc_order_bad_ ();
2471 ffestw_update (NULL);
2472 return FFESTC_orderBAD_;
2477 /* ffestc_order_data_ -- Check ordering on DATA statement
2479 if (ffestc_order_data_() != FFESTC_orderOK_)
2483 ffestc_order_data_ ()
2487 switch (ffestw_state (ffestw_stack_top ()))
2489 case FFESTV_stateNIL:
2490 ffestc_shriek_begin_program_ ();
2491 goto recurse; /* :::::::::::::::::::: */
2493 case FFESTV_statePROGRAM0:
2494 case FFESTV_statePROGRAM1:
2495 ffestw_update (NULL);
2496 ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM2);
2497 return FFESTC_orderOK_;
2499 case FFESTV_stateSUBROUTINE0:
2500 case FFESTV_stateSUBROUTINE1:
2501 ffestw_update (NULL);
2502 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE2);
2503 return FFESTC_orderOK_;
2505 case FFESTV_stateFUNCTION0:
2506 case FFESTV_stateFUNCTION1:
2507 ffestw_update (NULL);
2508 ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION2);
2509 return FFESTC_orderOK_;
2511 case FFESTV_stateBLOCKDATA0:
2512 case FFESTV_stateBLOCKDATA1:
2513 ffestw_update (NULL);
2514 ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA2);
2515 return FFESTC_orderOK_;
2517 case FFESTV_statePROGRAM2:
2518 case FFESTV_stateSUBROUTINE2:
2519 case FFESTV_stateFUNCTION2:
2520 case FFESTV_stateBLOCKDATA2:
2521 case FFESTV_statePROGRAM3:
2522 case FFESTV_stateSUBROUTINE3:
2523 case FFESTV_stateFUNCTION3:
2524 case FFESTV_stateBLOCKDATA3:
2525 case FFESTV_statePROGRAM4:
2526 case FFESTV_stateSUBROUTINE4:
2527 case FFESTV_stateFUNCTION4:
2528 case FFESTV_stateBLOCKDATA4:
2529 case FFESTV_stateWHERETHEN:
2530 case FFESTV_stateIFTHEN:
2531 case FFESTV_stateDO:
2532 case FFESTV_stateSELECT0:
2533 case FFESTV_stateSELECT1:
2534 return FFESTC_orderOK_;
2536 case FFESTV_stateUSE:
2538 ffestc_shriek_end_uses_ (TRUE);
2540 goto recurse; /* :::::::::::::::::::: */
2542 case FFESTV_stateWHERE:
2543 ffestc_order_bad_ ();
2545 ffestc_shriek_where_ (FALSE);
2547 return FFESTC_orderBAD_;
2549 case FFESTV_stateIF:
2550 ffestc_order_bad_ ();
2551 ffestc_shriek_if_ (FALSE);
2552 return FFESTC_orderBAD_;
2555 ffestc_order_bad_ ();
2556 return FFESTC_orderBAD_;
2560 /* ffestc_order_data77_ -- Check ordering on pedantic-F77 DATA statement
2562 if (ffestc_order_data77_() != FFESTC_orderOK_)
2566 ffestc_order_data77_ ()
2570 switch (ffestw_state (ffestw_stack_top ()))
2572 case FFESTV_stateNIL:
2573 ffestc_shriek_begin_program_ ();
2574 goto recurse; /* :::::::::::::::::::: */
2576 case FFESTV_statePROGRAM0:
2577 case FFESTV_statePROGRAM1:
2578 case FFESTV_statePROGRAM2:
2579 case FFESTV_statePROGRAM3:
2580 ffestw_update (NULL);
2581 ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM4);
2582 return FFESTC_orderOK_;
2584 case FFESTV_stateSUBROUTINE0:
2585 case FFESTV_stateSUBROUTINE1:
2586 case FFESTV_stateSUBROUTINE2:
2587 case FFESTV_stateSUBROUTINE3:
2588 ffestw_update (NULL);
2589 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE4);
2590 return FFESTC_orderOK_;
2592 case FFESTV_stateFUNCTION0:
2593 case FFESTV_stateFUNCTION1:
2594 case FFESTV_stateFUNCTION2:
2595 case FFESTV_stateFUNCTION3:
2596 ffestw_update (NULL);
2597 ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION4);
2598 return FFESTC_orderOK_;
2600 case FFESTV_stateBLOCKDATA0:
2601 case FFESTV_stateBLOCKDATA1:
2602 case FFESTV_stateBLOCKDATA2:
2603 case FFESTV_stateBLOCKDATA3:
2604 ffestw_update (NULL);
2605 ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA4);
2606 return FFESTC_orderOK_;
2608 case FFESTV_statePROGRAM4:
2609 case FFESTV_stateSUBROUTINE4:
2610 case FFESTV_stateFUNCTION4:
2611 case FFESTV_stateBLOCKDATA4:
2612 return FFESTC_orderOK_;
2614 case FFESTV_stateWHERETHEN:
2615 case FFESTV_stateIFTHEN:
2616 case FFESTV_stateDO:
2617 case FFESTV_stateSELECT0:
2618 case FFESTV_stateSELECT1:
2619 return FFESTC_orderOK_;
2621 case FFESTV_stateUSE:
2623 ffestc_shriek_end_uses_ (TRUE);
2625 goto recurse; /* :::::::::::::::::::: */
2627 case FFESTV_stateWHERE:
2628 ffestc_order_bad_ ();
2630 ffestc_shriek_where_ (FALSE);
2632 return FFESTC_orderBAD_;
2634 case FFESTV_stateIF:
2635 ffestc_order_bad_ ();
2636 ffestc_shriek_if_ (FALSE);
2637 return FFESTC_orderBAD_;
2640 ffestc_order_bad_ ();
2641 return FFESTC_orderBAD_;
2645 /* ffestc_order_derivedtype_ -- Check ordering on derived TYPE statement
2647 if (ffestc_order_derivedtype_() != FFESTC_orderOK_)
2652 ffestc_order_derivedtype_ ()
2656 switch (ffestw_state (ffestw_stack_top ()))
2658 case FFESTV_stateNIL:
2659 ffestc_shriek_begin_program_ ();
2660 goto recurse; /* :::::::::::::::::::: */
2662 case FFESTV_statePROGRAM0:
2663 case FFESTV_statePROGRAM1:
2664 case FFESTV_statePROGRAM2:
2665 ffestw_update (NULL);
2666 ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
2667 return FFESTC_orderOK_;
2669 case FFESTV_stateSUBROUTINE0:
2670 case FFESTV_stateSUBROUTINE1:
2671 case FFESTV_stateSUBROUTINE2:
2672 ffestw_update (NULL);
2673 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
2674 return FFESTC_orderOK_;
2676 case FFESTV_stateFUNCTION0:
2677 case FFESTV_stateFUNCTION1:
2678 case FFESTV_stateFUNCTION2:
2679 ffestw_update (NULL);
2680 ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
2681 return FFESTC_orderOK_;
2683 case FFESTV_stateMODULE0:
2684 case FFESTV_stateMODULE1:
2685 case FFESTV_stateMODULE2:
2686 ffestw_update (NULL);
2687 ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
2688 return FFESTC_orderOK_;
2690 case FFESTV_statePROGRAM3:
2691 case FFESTV_stateSUBROUTINE3:
2692 case FFESTV_stateFUNCTION3:
2693 case FFESTV_stateMODULE3:
2694 return FFESTC_orderOK_;
2696 case FFESTV_stateUSE:
2697 ffestc_shriek_end_uses_ (TRUE);
2698 goto recurse; /* :::::::::::::::::::: */
2700 case FFESTV_stateWHERE:
2701 ffestc_order_bad_ ();
2702 ffestc_shriek_where_ (FALSE);
2703 return FFESTC_orderBAD_;
2705 case FFESTV_stateIF:
2706 ffestc_order_bad_ ();
2707 ffestc_shriek_if_ (FALSE);
2708 return FFESTC_orderBAD_;
2711 ffestc_order_bad_ ();
2712 return FFESTC_orderBAD_;
2717 /* ffestc_order_do_ -- Check ordering on <do> statement
2719 if (ffestc_order_do_() != FFESTC_orderOK_)
2725 switch (ffestw_state (ffestw_stack_top ()))
2727 case FFESTV_stateDO:
2728 return FFESTC_orderOK_;
2730 case FFESTV_stateWHERE:
2731 ffestc_order_bad_ ();
2733 ffestc_shriek_where_ (FALSE);
2735 return FFESTC_orderBAD_;
2737 case FFESTV_stateIF:
2738 ffestc_order_bad_ ();
2739 ffestc_shriek_if_ (FALSE);
2740 return FFESTC_orderBAD_;
2743 ffestc_order_bad_ ();
2744 return FFESTC_orderBAD_;
2748 /* ffestc_order_entry_ -- Check ordering on ENTRY statement
2750 if (ffestc_order_entry_() != FFESTC_orderOK_)
2754 ffestc_order_entry_ ()
2758 switch (ffestw_state (ffestw_stack_top ()))
2760 case FFESTV_stateNIL:
2761 ffestc_shriek_begin_program_ ();
2762 goto recurse; /* :::::::::::::::::::: */
2764 case FFESTV_stateSUBROUTINE0:
2765 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE1);
2768 case FFESTV_stateFUNCTION0:
2769 ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION1);
2772 case FFESTV_stateSUBROUTINE1:
2773 case FFESTV_stateSUBROUTINE2:
2774 case FFESTV_stateFUNCTION1:
2775 case FFESTV_stateFUNCTION2:
2776 case FFESTV_stateSUBROUTINE3:
2777 case FFESTV_stateFUNCTION3:
2778 case FFESTV_stateSUBROUTINE4:
2779 case FFESTV_stateFUNCTION4:
2782 case FFESTV_stateUSE:
2784 ffestc_shriek_end_uses_ (TRUE);
2786 goto recurse; /* :::::::::::::::::::: */
2788 case FFESTV_stateWHERE:
2789 ffestc_order_bad_ ();
2791 ffestc_shriek_where_ (FALSE);
2793 return FFESTC_orderBAD_;
2795 case FFESTV_stateIF:
2796 ffestc_order_bad_ ();
2797 ffestc_shriek_if_ (FALSE);
2798 return FFESTC_orderBAD_;
2801 ffestc_order_bad_ ();
2802 return FFESTC_orderBAD_;
2805 switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
2807 case FFESTV_stateNIL:
2808 case FFESTV_stateMODULE5:
2809 ffestw_update (NULL);
2810 return FFESTC_orderOK_;
2813 ffestc_order_bad_ ();
2814 ffestw_update (NULL);
2815 return FFESTC_orderBAD_;
2819 /* ffestc_order_exec_ -- Check ordering on <exec> statement
2821 if (ffestc_order_exec_() != FFESTC_orderOK_)
2825 ffestc_order_exec_ ()
2831 switch (ffestw_state (ffestw_stack_top ()))
2833 case FFESTV_stateNIL:
2834 ffestc_shriek_begin_program_ ();
2835 goto recurse; /* :::::::::::::::::::: */
2837 case FFESTV_statePROGRAM0:
2838 case FFESTV_statePROGRAM1:
2839 case FFESTV_statePROGRAM2:
2840 case FFESTV_statePROGRAM3:
2841 ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM4);
2845 case FFESTV_stateSUBROUTINE0:
2846 case FFESTV_stateSUBROUTINE1:
2847 case FFESTV_stateSUBROUTINE2:
2848 case FFESTV_stateSUBROUTINE3:
2849 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE4);
2853 case FFESTV_stateFUNCTION0:
2854 case FFESTV_stateFUNCTION1:
2855 case FFESTV_stateFUNCTION2:
2856 case FFESTV_stateFUNCTION3:
2857 ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION4);
2861 case FFESTV_statePROGRAM4:
2862 case FFESTV_stateSUBROUTINE4:
2863 case FFESTV_stateFUNCTION4:
2867 case FFESTV_stateIFTHEN:
2868 case FFESTV_stateDO:
2869 case FFESTV_stateSELECT1:
2870 return FFESTC_orderOK_;
2872 case FFESTV_stateUSE:
2874 ffestc_shriek_end_uses_ (TRUE);
2876 goto recurse; /* :::::::::::::::::::: */
2878 case FFESTV_stateWHERE:
2879 ffestc_order_bad_ ();
2881 ffestc_shriek_where_ (FALSE);
2883 return FFESTC_orderBAD_;
2885 case FFESTV_stateIF:
2886 ffestc_order_bad_ ();
2887 ffestc_shriek_if_ (FALSE);
2888 return FFESTC_orderBAD_;
2891 ffestc_order_bad_ ();
2892 return FFESTC_orderBAD_;
2895 switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
2897 case FFESTV_stateINTERFACE0:
2898 ffestc_order_bad_ ();
2900 ffestw_update (NULL);
2901 return FFESTC_orderBAD_;
2905 ffestw_update (NULL);
2906 return FFESTC_orderOK_;
2910 /* ffestc_order_format_ -- Check ordering on FORMAT statement
2912 if (ffestc_order_format_() != FFESTC_orderOK_)
2916 ffestc_order_format_ ()
2920 switch (ffestw_state (ffestw_stack_top ()))
2922 case FFESTV_stateNIL:
2923 ffestc_shriek_begin_program_ ();
2924 goto recurse; /* :::::::::::::::::::: */
2926 case FFESTV_statePROGRAM0:
2927 ffestw_update (NULL);
2928 ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM1);
2929 return FFESTC_orderOK_;
2931 case FFESTV_stateSUBROUTINE0:
2932 ffestw_update (NULL);
2933 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE1);
2934 return FFESTC_orderOK_;
2936 case FFESTV_stateFUNCTION0:
2937 ffestw_update (NULL);
2938 ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION1);
2939 return FFESTC_orderOK_;
2941 case FFESTV_statePROGRAM1:
2942 case FFESTV_statePROGRAM2:
2943 case FFESTV_stateSUBROUTINE1:
2944 case FFESTV_stateSUBROUTINE2:
2945 case FFESTV_stateFUNCTION1:
2946 case FFESTV_stateFUNCTION2:
2947 case FFESTV_statePROGRAM3:
2948 case FFESTV_stateSUBROUTINE3:
2949 case FFESTV_stateFUNCTION3:
2950 case FFESTV_statePROGRAM4:
2951 case FFESTV_stateSUBROUTINE4:
2952 case FFESTV_stateFUNCTION4:
2953 case FFESTV_stateWHERETHEN:
2954 case FFESTV_stateIFTHEN:
2955 case FFESTV_stateDO:
2956 case FFESTV_stateSELECT0:
2957 case FFESTV_stateSELECT1:
2958 return FFESTC_orderOK_;
2960 case FFESTV_stateUSE:
2962 ffestc_shriek_end_uses_ (TRUE);
2964 goto recurse; /* :::::::::::::::::::: */
2966 case FFESTV_stateWHERE:
2967 ffestc_order_bad_ ();
2969 ffestc_shriek_where_ (FALSE);
2971 return FFESTC_orderBAD_;
2973 case FFESTV_stateIF:
2974 ffestc_order_bad_ ();
2975 ffestc_shriek_if_ (FALSE);
2976 return FFESTC_orderBAD_;
2979 ffestc_order_bad_ ();
2980 return FFESTC_orderBAD_;
2984 /* ffestc_order_function_ -- Check ordering on <function> statement
2986 if (ffestc_order_function_() != FFESTC_orderOK_)
2990 ffestc_order_function_ ()
2994 switch (ffestw_state (ffestw_stack_top ()))
2996 case FFESTV_stateFUNCTION0:
2997 case FFESTV_stateFUNCTION1:
2998 case FFESTV_stateFUNCTION2:
2999 case FFESTV_stateFUNCTION3:
3000 case FFESTV_stateFUNCTION4:
3001 case FFESTV_stateFUNCTION5:
3002 return FFESTC_orderOK_;
3004 case FFESTV_stateUSE:
3006 ffestc_shriek_end_uses_ (TRUE);
3008 goto recurse; /* :::::::::::::::::::: */
3010 case FFESTV_stateWHERE:
3011 ffestc_order_bad_ ();
3013 ffestc_shriek_where_ (FALSE);
3015 return FFESTC_orderBAD_;
3017 case FFESTV_stateIF:
3018 ffestc_order_bad_ ();
3019 ffestc_shriek_if_ (FALSE);
3020 return FFESTC_orderBAD_;
3023 ffestc_order_bad_ ();
3024 return FFESTC_orderBAD_;
3028 /* ffestc_order_iface_ -- Check ordering on <iface> statement
3030 if (ffestc_order_iface_() != FFESTC_orderOK_)
3034 ffestc_order_iface_ ()
3036 switch (ffestw_state (ffestw_stack_top ()))
3038 case FFESTV_stateNIL:
3039 case FFESTV_statePROGRAM5:
3040 case FFESTV_stateSUBROUTINE5:
3041 case FFESTV_stateFUNCTION5:
3042 case FFESTV_stateMODULE5:
3043 case FFESTV_stateINTERFACE0:
3044 return FFESTC_orderOK_;
3046 case FFESTV_stateWHERE:
3047 ffestc_order_bad_ ();
3049 ffestc_shriek_where_ (FALSE);
3051 return FFESTC_orderBAD_;
3053 case FFESTV_stateIF:
3054 ffestc_order_bad_ ();
3055 ffestc_shriek_if_ (FALSE);
3056 return FFESTC_orderBAD_;
3059 ffestc_order_bad_ ();
3060 return FFESTC_orderBAD_;
3064 /* ffestc_order_ifthen_ -- Check ordering on <ifthen> statement
3066 if (ffestc_order_ifthen_() != FFESTC_orderOK_)
3070 ffestc_order_ifthen_ ()
3072 switch (ffestw_state (ffestw_stack_top ()))
3074 case FFESTV_stateIFTHEN:
3075 return FFESTC_orderOK_;
3077 case FFESTV_stateWHERE:
3078 ffestc_order_bad_ ();
3080 ffestc_shriek_where_ (FALSE);
3082 return FFESTC_orderBAD_;
3084 case FFESTV_stateIF:
3085 ffestc_order_bad_ ();
3086 ffestc_shriek_if_ (FALSE);
3087 return FFESTC_orderBAD_;
3090 ffestc_order_bad_ ();
3091 return FFESTC_orderBAD_;
3095 /* ffestc_order_implicit_ -- Check ordering on IMPLICIT statement
3097 if (ffestc_order_implicit_() != FFESTC_orderOK_)
3101 ffestc_order_implicit_ ()
3105 switch (ffestw_state (ffestw_stack_top ()))
3107 case FFESTV_stateNIL:
3108 ffestc_shriek_begin_program_ ();
3109 goto recurse; /* :::::::::::::::::::: */
3111 case FFESTV_statePROGRAM0:
3112 case FFESTV_statePROGRAM1:
3113 ffestw_update (NULL);
3114 ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM2);
3115 return FFESTC_orderOK_;
3117 case FFESTV_stateSUBROUTINE0:
3118 case FFESTV_stateSUBROUTINE1:
3119 ffestw_update (NULL);
3120 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE2);
3121 return FFESTC_orderOK_;
3123 case FFESTV_stateFUNCTION0:
3124 case FFESTV_stateFUNCTION1:
3125 ffestw_update (NULL);
3126 ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION2);
3127 return FFESTC_orderOK_;
3129 case FFESTV_stateMODULE0:
3130 case FFESTV_stateMODULE1:
3131 ffestw_update (NULL);
3132 ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE2);
3133 return FFESTC_orderOK_;
3135 case FFESTV_stateBLOCKDATA0:
3136 case FFESTV_stateBLOCKDATA1:
3137 ffestw_update (NULL);
3138 ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA2);
3139 return FFESTC_orderOK_;
3141 case FFESTV_statePROGRAM2:
3142 case FFESTV_stateSUBROUTINE2:
3143 case FFESTV_stateFUNCTION2:
3144 case FFESTV_stateMODULE2:
3145 case FFESTV_stateBLOCKDATA2:
3146 return FFESTC_orderOK_;
3148 case FFESTV_stateUSE:
3150 ffestc_shriek_end_uses_ (TRUE);
3152 goto recurse; /* :::::::::::::::::::: */
3154 case FFESTV_stateWHERE:
3155 ffestc_order_bad_ ();
3157 ffestc_shriek_where_ (FALSE);
3159 return FFESTC_orderBAD_;
3161 case FFESTV_stateIF:
3162 ffestc_order_bad_ ();
3163 ffestc_shriek_if_ (FALSE);
3164 return FFESTC_orderBAD_;
3167 ffestc_order_bad_ ();
3168 return FFESTC_orderBAD_;
3172 /* ffestc_order_implicitnone_ -- Check ordering on IMPLICIT NONE statement
3174 if (ffestc_order_implicitnone_() != FFESTC_orderOK_)
3178 ffestc_order_implicitnone_ ()
3182 switch (ffestw_state (ffestw_stack_top ()))
3184 case FFESTV_stateNIL:
3185 ffestc_shriek_begin_program_ ();
3186 goto recurse; /* :::::::::::::::::::: */
3188 case FFESTV_statePROGRAM0:
3189 case FFESTV_statePROGRAM1:
3190 ffestw_update (NULL);
3191 ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
3192 return FFESTC_orderOK_;
3194 case FFESTV_stateSUBROUTINE0:
3195 case FFESTV_stateSUBROUTINE1:
3196 ffestw_update (NULL);
3197 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
3198 return FFESTC_orderOK_;
3200 case FFESTV_stateFUNCTION0:
3201 case FFESTV_stateFUNCTION1:
3202 ffestw_update (NULL);
3203 ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
3204 return FFESTC_orderOK_;
3206 case FFESTV_stateMODULE0:
3207 case FFESTV_stateMODULE1:
3208 ffestw_update (NULL);
3209 ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
3210 return FFESTC_orderOK_;
3212 case FFESTV_stateBLOCKDATA0:
3213 case FFESTV_stateBLOCKDATA1:
3214 ffestw_update (NULL);
3215 ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA3);
3216 return FFESTC_orderOK_;
3218 case FFESTV_stateUSE:
3220 ffestc_shriek_end_uses_ (TRUE);
3222 goto recurse; /* :::::::::::::::::::: */
3224 case FFESTV_stateWHERE:
3225 ffestc_order_bad_ ();
3227 ffestc_shriek_where_ (FALSE);
3229 return FFESTC_orderBAD_;
3231 case FFESTV_stateIF:
3232 ffestc_order_bad_ ();
3233 ffestc_shriek_if_ (FALSE);
3234 return FFESTC_orderBAD_;
3237 ffestc_order_bad_ ();
3238 return FFESTC_orderBAD_;
3242 /* ffestc_order_interface_ -- Check ordering on <interface> statement
3244 if (ffestc_order_interface_() != FFESTC_orderOK_)
3249 ffestc_order_interface_ ()
3251 switch (ffestw_state (ffestw_stack_top ()))
3253 case FFESTV_stateINTERFACE0:
3254 case FFESTV_stateINTERFACE1:
3255 return FFESTC_orderOK_;
3257 case FFESTV_stateWHERE:
3258 ffestc_order_bad_ ();
3259 ffestc_shriek_where_ (FALSE);
3260 return FFESTC_orderBAD_;
3262 case FFESTV_stateIF:
3263 ffestc_order_bad_ ();
3264 ffestc_shriek_if_ (FALSE);
3265 return FFESTC_orderBAD_;
3268 ffestc_order_bad_ ();
3269 return FFESTC_orderBAD_;
3274 /* ffestc_order_map_ -- Check ordering on <map> statement
3276 if (ffestc_order_map_() != FFESTC_orderOK_)
3281 ffestc_order_map_ ()
3283 switch (ffestw_state (ffestw_stack_top ()))
3285 case FFESTV_stateMAP:
3286 return FFESTC_orderOK_;
3288 case FFESTV_stateWHERE:
3289 ffestc_order_bad_ ();
3290 ffestc_shriek_where_ (FALSE);
3291 return FFESTC_orderBAD_;
3293 case FFESTV_stateIF:
3294 ffestc_order_bad_ ();
3295 ffestc_shriek_if_ (FALSE);
3296 return FFESTC_orderBAD_;
3299 ffestc_order_bad_ ();
3300 return FFESTC_orderBAD_;
3305 /* ffestc_order_module_ -- Check ordering on <module> statement
3307 if (ffestc_order_module_() != FFESTC_orderOK_)
3312 ffestc_order_module_ ()
3316 switch (ffestw_state (ffestw_stack_top ()))
3318 case FFESTV_stateMODULE0:
3319 case FFESTV_stateMODULE1:
3320 case FFESTV_stateMODULE2:
3321 case FFESTV_stateMODULE3:
3322 case FFESTV_stateMODULE4:
3323 case FFESTV_stateMODULE5:
3324 return FFESTC_orderOK_;
3326 case FFESTV_stateUSE:
3327 ffestc_shriek_end_uses_ (TRUE);
3328 goto recurse; /* :::::::::::::::::::: */
3330 case FFESTV_stateWHERE:
3331 ffestc_order_bad_ ();
3332 ffestc_shriek_where_ (FALSE);
3333 return FFESTC_orderBAD_;
3335 case FFESTV_stateIF:
3336 ffestc_order_bad_ ();
3337 ffestc_shriek_if_ (FALSE);
3338 return FFESTC_orderBAD_;
3341 ffestc_order_bad_ ();
3342 return FFESTC_orderBAD_;
3347 /* ffestc_order_parameter_ -- Check ordering on <parameter> statement
3349 if (ffestc_order_parameter_() != FFESTC_orderOK_)
3353 ffestc_order_parameter_ ()
3357 switch (ffestw_state (ffestw_stack_top ()))
3359 case FFESTV_stateNIL:
3360 ffestc_shriek_begin_program_ ();
3361 goto recurse; /* :::::::::::::::::::: */
3363 case FFESTV_statePROGRAM0:
3364 case FFESTV_statePROGRAM1:
3365 ffestw_update (NULL);
3366 ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM2);
3367 return FFESTC_orderOK_;
3369 case FFESTV_stateSUBROUTINE0:
3370 case FFESTV_stateSUBROUTINE1:
3371 ffestw_update (NULL);
3372 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE2);
3373 return FFESTC_orderOK_;
3375 case FFESTV_stateFUNCTION0:
3376 case FFESTV_stateFUNCTION1:
3377 ffestw_update (NULL);
3378 ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION2);
3379 return FFESTC_orderOK_;
3381 case FFESTV_stateMODULE0:
3382 case FFESTV_stateMODULE1:
3383 ffestw_update (NULL);
3384 ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE2);
3385 return FFESTC_orderOK_;
3387 case FFESTV_stateBLOCKDATA0:
3388 case FFESTV_stateBLOCKDATA1:
3389 ffestw_update (NULL);
3390 ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA2);
3391 return FFESTC_orderOK_;
3393 case FFESTV_statePROGRAM2:
3394 case FFESTV_stateSUBROUTINE2:
3395 case FFESTV_stateFUNCTION2:
3396 case FFESTV_stateMODULE2:
3397 case FFESTV_stateBLOCKDATA2:
3398 case FFESTV_statePROGRAM3:
3399 case FFESTV_stateSUBROUTINE3:
3400 case FFESTV_stateFUNCTION3:
3401 case FFESTV_stateMODULE3:
3402 case FFESTV_stateBLOCKDATA3:
3403 case FFESTV_stateTYPE: /* GNU extension here! */
3404 case FFESTV_stateSTRUCTURE:
3405 case FFESTV_stateUNION:
3406 case FFESTV_stateMAP:
3407 return FFESTC_orderOK_;
3409 case FFESTV_stateUSE:
3411 ffestc_shriek_end_uses_ (TRUE);
3413 goto recurse; /* :::::::::::::::::::: */
3415 case FFESTV_stateWHERE:
3416 ffestc_order_bad_ ();
3418 ffestc_shriek_where_ (FALSE);
3420 return FFESTC_orderBAD_;
3422 case FFESTV_stateIF:
3423 ffestc_order_bad_ ();
3424 ffestc_shriek_if_ (FALSE);
3425 return FFESTC_orderBAD_;
3428 ffestc_order_bad_ ();
3429 return FFESTC_orderBAD_;
3433 /* ffestc_order_program_ -- Check ordering on <program> statement
3435 if (ffestc_order_program_() != FFESTC_orderOK_)
3439 ffestc_order_program_ ()
3443 switch (ffestw_state (ffestw_stack_top ()))
3445 case FFESTV_stateNIL:
3446 ffestc_shriek_begin_program_ ();
3447 goto recurse; /* :::::::::::::::::::: */
3449 case FFESTV_statePROGRAM0:
3450 case FFESTV_statePROGRAM1:
3451 case FFESTV_statePROGRAM2:
3452 case FFESTV_statePROGRAM3:
3453 case FFESTV_statePROGRAM4:
3454 case FFESTV_statePROGRAM5:
3455 return FFESTC_orderOK_;
3457 case FFESTV_stateUSE:
3459 ffestc_shriek_end_uses_ (TRUE);
3461 goto recurse; /* :::::::::::::::::::: */
3463 case FFESTV_stateWHERE:
3464 ffestc_order_bad_ ();
3466 ffestc_shriek_where_ (FALSE);
3468 return FFESTC_orderBAD_;
3470 case FFESTV_stateIF:
3471 ffestc_order_bad_ ();
3472 ffestc_shriek_if_ (FALSE);
3473 return FFESTC_orderBAD_;
3476 ffestc_order_bad_ ();
3477 return FFESTC_orderBAD_;
3481 /* ffestc_order_progspec_ -- Check ordering on <progspec> statement
3483 if (ffestc_order_progspec_() != FFESTC_orderOK_)
3487 ffestc_order_progspec_ ()
3491 switch (ffestw_state (ffestw_stack_top ()))
3493 case FFESTV_stateNIL:
3494 ffestc_shriek_begin_program_ ();
3495 goto recurse; /* :::::::::::::::::::: */
3497 case FFESTV_statePROGRAM0:
3498 case FFESTV_statePROGRAM1:
3499 case FFESTV_statePROGRAM2:
3500 ffestw_update (NULL);
3501 ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
3502 return FFESTC_orderOK_;
3504 case FFESTV_stateSUBROUTINE0:
3505 case FFESTV_stateSUBROUTINE1:
3506 case FFESTV_stateSUBROUTINE2:
3507 ffestw_update (NULL);
3508 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
3509 return FFESTC_orderOK_;
3511 case FFESTV_stateFUNCTION0:
3512 case FFESTV_stateFUNCTION1:
3513 case FFESTV_stateFUNCTION2:
3514 ffestw_update (NULL);
3515 ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
3516 return FFESTC_orderOK_;
3518 case FFESTV_stateMODULE0:
3519 case FFESTV_stateMODULE1:
3520 case FFESTV_stateMODULE2:
3521 ffestw_update (NULL);
3522 ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
3523 return FFESTC_orderOK_;
3525 case FFESTV_statePROGRAM3:
3526 case FFESTV_stateSUBROUTINE3:
3527 case FFESTV_stateFUNCTION3:
3528 case FFESTV_stateMODULE3:
3529 return FFESTC_orderOK_;
3531 case FFESTV_stateBLOCKDATA0:
3532 case FFESTV_stateBLOCKDATA1:
3533 case FFESTV_stateBLOCKDATA2:
3534 ffestw_update (NULL);
3535 ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA2);
3536 if (ffe_is_pedantic ())
3538 ffebad_start (FFEBAD_BLOCKDATA_STMT);
3539 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
3540 ffelex_token_where_column (ffesta_tokens[0]));
3541 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
3544 return FFESTC_orderOK_;
3546 case FFESTV_stateUSE:
3548 ffestc_shriek_end_uses_ (TRUE);
3550 goto recurse; /* :::::::::::::::::::: */
3552 case FFESTV_stateWHERE:
3553 ffestc_order_bad_ ();
3555 ffestc_shriek_where_ (FALSE);
3557 return FFESTC_orderBAD_;
3559 case FFESTV_stateIF:
3560 ffestc_order_bad_ ();
3561 ffestc_shriek_if_ (FALSE);
3562 return FFESTC_orderBAD_;
3565 ffestc_order_bad_ ();
3566 return FFESTC_orderBAD_;
3570 /* ffestc_order_record_ -- Check ordering on RECORD statement
3572 if (ffestc_order_record_() != FFESTC_orderOK_)
3577 ffestc_order_record_ ()
3581 switch (ffestw_state (ffestw_stack_top ()))
3583 case FFESTV_stateNIL:
3584 ffestc_shriek_begin_program_ ();
3585 goto recurse; /* :::::::::::::::::::: */
3587 case FFESTV_statePROGRAM0:
3588 case FFESTV_statePROGRAM1:
3589 case FFESTV_statePROGRAM2:
3590 ffestw_update (NULL);
3591 ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
3592 return FFESTC_orderOK_;
3594 case FFESTV_stateSUBROUTINE0:
3595 case FFESTV_stateSUBROUTINE1:
3596 case FFESTV_stateSUBROUTINE2:
3597 ffestw_update (NULL);
3598 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
3599 return FFESTC_orderOK_;
3601 case FFESTV_stateFUNCTION0:
3602 case FFESTV_stateFUNCTION1:
3603 case FFESTV_stateFUNCTION2:
3604 ffestw_update (NULL);
3605 ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
3606 return FFESTC_orderOK_;
3608 case FFESTV_stateMODULE0:
3609 case FFESTV_stateMODULE1:
3610 case FFESTV_stateMODULE2:
3611 ffestw_update (NULL);
3612 ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
3613 return FFESTC_orderOK_;
3615 case FFESTV_stateBLOCKDATA0:
3616 case FFESTV_stateBLOCKDATA1:
3617 case FFESTV_stateBLOCKDATA2:
3618 ffestw_update (NULL);
3619 ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA3);
3620 return FFESTC_orderOK_;
3622 case FFESTV_statePROGRAM3:
3623 case FFESTV_stateSUBROUTINE3:
3624 case FFESTV_stateFUNCTION3:
3625 case FFESTV_stateMODULE3:
3626 case FFESTV_stateBLOCKDATA3:
3627 case FFESTV_stateSTRUCTURE:
3628 case FFESTV_stateMAP:
3629 return FFESTC_orderOK_;
3631 case FFESTV_stateUSE:
3633 ffestc_shriek_end_uses_ (TRUE);
3635 goto recurse; /* :::::::::::::::::::: */
3637 case FFESTV_stateWHERE:
3638 ffestc_order_bad_ ();
3640 ffestc_shriek_where_ (FALSE);
3642 return FFESTC_orderBAD_;
3644 case FFESTV_stateIF:
3645 ffestc_order_bad_ ();
3646 ffestc_shriek_if_ (FALSE);
3647 return FFESTC_orderBAD_;
3650 ffestc_order_bad_ ();
3651 return FFESTC_orderBAD_;
3656 /* ffestc_order_selectcase_ -- Check ordering on <selectcase> statement
3658 if (ffestc_order_selectcase_() != FFESTC_orderOK_)
3662 ffestc_order_selectcase_ ()
3664 switch (ffestw_state (ffestw_stack_top ()))
3666 case FFESTV_stateSELECT0:
3667 case FFESTV_stateSELECT1:
3668 return FFESTC_orderOK_;
3670 case FFESTV_stateWHERE:
3671 ffestc_order_bad_ ();
3673 ffestc_shriek_where_ (FALSE);
3675 return FFESTC_orderBAD_;
3677 case FFESTV_stateIF:
3678 ffestc_order_bad_ ();
3679 ffestc_shriek_if_ (FALSE);
3680 return FFESTC_orderBAD_;
3683 ffestc_order_bad_ ();
3684 return FFESTC_orderBAD_;
3688 /* ffestc_order_sfunc_ -- Check ordering on statement-function definition
3690 if (ffestc_order_sfunc_() != FFESTC_orderOK_)
3694 ffestc_order_sfunc_ ()
3698 switch (ffestw_state (ffestw_stack_top ()))
3700 case FFESTV_stateNIL:
3701 ffestc_shriek_begin_program_ ();
3702 goto recurse; /* :::::::::::::::::::: */
3704 case FFESTV_statePROGRAM0:
3705 case FFESTV_statePROGRAM1:
3706 case FFESTV_statePROGRAM2:
3707 ffestw_update (NULL);
3708 ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
3709 return FFESTC_orderOK_;
3711 case FFESTV_stateSUBROUTINE0:
3712 case FFESTV_stateSUBROUTINE1:
3713 case FFESTV_stateSUBROUTINE2:
3714 ffestw_update (NULL);
3715 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
3716 return FFESTC_orderOK_;
3718 case FFESTV_stateFUNCTION0:
3719 case FFESTV_stateFUNCTION1:
3720 case FFESTV_stateFUNCTION2:
3721 ffestw_update (NULL);
3722 ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
3723 return FFESTC_orderOK_;
3725 case FFESTV_statePROGRAM3:
3726 case FFESTV_stateSUBROUTINE3:
3727 case FFESTV_stateFUNCTION3:
3728 return FFESTC_orderOK_;
3730 case FFESTV_stateUSE:
3732 ffestc_shriek_end_uses_ (TRUE);
3734 goto recurse; /* :::::::::::::::::::: */
3736 case FFESTV_stateWHERE:
3737 ffestc_order_bad_ ();
3739 ffestc_shriek_where_ (FALSE);
3741 return FFESTC_orderBAD_;
3743 case FFESTV_stateIF:
3744 ffestc_order_bad_ ();
3745 ffestc_shriek_if_ (FALSE);
3746 return FFESTC_orderBAD_;
3749 ffestc_order_bad_ ();
3750 return FFESTC_orderBAD_;
3754 /* ffestc_order_spec_ -- Check ordering on <spec> statement
3756 if (ffestc_order_spec_() != FFESTC_orderOK_)
3761 ffestc_order_spec_ ()
3765 switch (ffestw_state (ffestw_stack_top ()))
3767 case FFESTV_stateNIL:
3768 ffestc_shriek_begin_program_ ();
3769 goto recurse; /* :::::::::::::::::::: */
3771 case FFESTV_stateSUBROUTINE0:
3772 case FFESTV_stateSUBROUTINE1:
3773 case FFESTV_stateSUBROUTINE2:
3774 ffestw_update (NULL);
3775 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
3776 return FFESTC_orderOK_;
3778 case FFESTV_stateFUNCTION0:
3779 case FFESTV_stateFUNCTION1:
3780 case FFESTV_stateFUNCTION2:
3781 ffestw_update (NULL);
3782 ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
3783 return FFESTC_orderOK_;
3785 case FFESTV_stateMODULE0:
3786 case FFESTV_stateMODULE1:
3787 case FFESTV_stateMODULE2:
3788 ffestw_update (NULL);
3789 ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
3790 return FFESTC_orderOK_;
3792 case FFESTV_stateSUBROUTINE3:
3793 case FFESTV_stateFUNCTION3:
3794 case FFESTV_stateMODULE3:
3795 return FFESTC_orderOK_;
3797 case FFESTV_stateUSE:
3799 ffestc_shriek_end_uses_ (TRUE);
3801 goto recurse; /* :::::::::::::::::::: */
3803 case FFESTV_stateWHERE:
3804 ffestc_order_bad_ ();
3806 ffestc_shriek_where_ (FALSE);
3808 return FFESTC_orderBAD_;
3810 case FFESTV_stateIF:
3811 ffestc_order_bad_ ();
3812 ffestc_shriek_if_ (FALSE);
3813 return FFESTC_orderBAD_;
3816 ffestc_order_bad_ ();
3817 return FFESTC_orderBAD_;
3822 /* ffestc_order_structure_ -- Check ordering on <structure> statement
3824 if (ffestc_order_structure_() != FFESTC_orderOK_)
3829 ffestc_order_structure_ ()
3831 switch (ffestw_state (ffestw_stack_top ()))
3833 case FFESTV_stateSTRUCTURE:
3834 return FFESTC_orderOK_;
3836 case FFESTV_stateWHERE:
3837 ffestc_order_bad_ ();
3839 ffestc_shriek_where_ (FALSE);
3841 return FFESTC_orderBAD_;
3843 case FFESTV_stateIF:
3844 ffestc_order_bad_ ();
3845 ffestc_shriek_if_ (FALSE);
3846 return FFESTC_orderBAD_;
3849 ffestc_order_bad_ ();
3850 return FFESTC_orderBAD_;
3855 /* ffestc_order_subroutine_ -- Check ordering on <subroutine> statement
3857 if (ffestc_order_subroutine_() != FFESTC_orderOK_)
3861 ffestc_order_subroutine_ ()
3865 switch (ffestw_state (ffestw_stack_top ()))
3867 case FFESTV_stateSUBROUTINE0:
3868 case FFESTV_stateSUBROUTINE1:
3869 case FFESTV_stateSUBROUTINE2:
3870 case FFESTV_stateSUBROUTINE3:
3871 case FFESTV_stateSUBROUTINE4:
3872 case FFESTV_stateSUBROUTINE5:
3873 return FFESTC_orderOK_;
3875 case FFESTV_stateUSE:
3877 ffestc_shriek_end_uses_ (TRUE);
3879 goto recurse; /* :::::::::::::::::::: */
3881 case FFESTV_stateWHERE:
3882 ffestc_order_bad_ ();
3884 ffestc_shriek_where_ (FALSE);
3886 return FFESTC_orderBAD_;
3888 case FFESTV_stateIF:
3889 ffestc_order_bad_ ();
3890 ffestc_shriek_if_ (FALSE);
3891 return FFESTC_orderBAD_;
3894 ffestc_order_bad_ ();
3895 return FFESTC_orderBAD_;
3899 /* ffestc_order_type_ -- Check ordering on <type> statement
3901 if (ffestc_order_type_() != FFESTC_orderOK_)
3906 ffestc_order_type_ ()
3908 switch (ffestw_state (ffestw_stack_top ()))
3910 case FFESTV_stateTYPE:
3911 return FFESTC_orderOK_;
3913 case FFESTV_stateWHERE:
3914 ffestc_order_bad_ ();
3915 ffestc_shriek_where_ (FALSE);
3916 return FFESTC_orderBAD_;
3918 case FFESTV_stateIF:
3919 ffestc_order_bad_ ();
3920 ffestc_shriek_if_ (FALSE);
3921 return FFESTC_orderBAD_;
3924 ffestc_order_bad_ ();
3925 return FFESTC_orderBAD_;
3930 /* ffestc_order_typedecl_ -- Check ordering on <typedecl> statement
3932 if (ffestc_order_typedecl_() != FFESTC_orderOK_)
3936 ffestc_order_typedecl_ ()
3940 switch (ffestw_state (ffestw_stack_top ()))
3942 case FFESTV_stateNIL:
3943 ffestc_shriek_begin_program_ ();
3944 goto recurse; /* :::::::::::::::::::: */
3946 case FFESTV_statePROGRAM0:
3947 case FFESTV_statePROGRAM1:
3948 case FFESTV_statePROGRAM2:
3949 ffestw_update (NULL);
3950 ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
3951 return FFESTC_orderOK_;
3953 case FFESTV_stateSUBROUTINE0:
3954 case FFESTV_stateSUBROUTINE1:
3955 case FFESTV_stateSUBROUTINE2:
3956 ffestw_update (NULL);
3957 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
3958 return FFESTC_orderOK_;
3960 case FFESTV_stateFUNCTION0:
3961 case FFESTV_stateFUNCTION1:
3962 case FFESTV_stateFUNCTION2:
3963 ffestw_update (NULL);
3964 ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
3965 return FFESTC_orderOK_;
3967 case FFESTV_stateMODULE0:
3968 case FFESTV_stateMODULE1:
3969 case FFESTV_stateMODULE2:
3970 ffestw_update (NULL);
3971 ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
3972 return FFESTC_orderOK_;
3974 case FFESTV_stateBLOCKDATA0:
3975 case FFESTV_stateBLOCKDATA1:
3976 case FFESTV_stateBLOCKDATA2:
3977 ffestw_update (NULL);
3978 ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA3);
3979 return FFESTC_orderOK_;
3981 case FFESTV_statePROGRAM3:
3982 case FFESTV_stateSUBROUTINE3:
3983 case FFESTV_stateFUNCTION3:
3984 case FFESTV_stateMODULE3:
3985 case FFESTV_stateBLOCKDATA3:
3986 return FFESTC_orderOK_;
3988 case FFESTV_stateUSE:
3990 ffestc_shriek_end_uses_ (TRUE);
3992 goto recurse; /* :::::::::::::::::::: */
3994 case FFESTV_stateWHERE:
3995 ffestc_order_bad_ ();
3997 ffestc_shriek_where_ (FALSE);
3999 return FFESTC_orderBAD_;
4001 case FFESTV_stateIF:
4002 ffestc_order_bad_ ();
4003 ffestc_shriek_if_ (FALSE);
4004 return FFESTC_orderBAD_;
4007 ffestc_order_bad_ ();
4008 return FFESTC_orderBAD_;
4012 /* ffestc_order_union_ -- Check ordering on <union> statement
4014 if (ffestc_order_union_() != FFESTC_orderOK_)
4019 ffestc_order_union_ ()
4021 switch (ffestw_state (ffestw_stack_top ()))
4023 case FFESTV_stateUNION:
4024 return FFESTC_orderOK_;
4026 case FFESTV_stateWHERE:
4027 ffestc_order_bad_ ();
4029 ffestc_shriek_where_ (FALSE);
4031 return FFESTC_orderBAD_;
4033 case FFESTV_stateIF:
4034 ffestc_order_bad_ ();
4035 ffestc_shriek_if_ (FALSE);
4036 return FFESTC_orderBAD_;
4039 ffestc_order_bad_ ();
4040 return FFESTC_orderBAD_;
4045 /* ffestc_order_unit_ -- Check ordering on <unit> statement
4047 if (ffestc_order_unit_() != FFESTC_orderOK_)
4051 ffestc_order_unit_ ()
4053 switch (ffestw_state (ffestw_stack_top ()))
4055 case FFESTV_stateNIL:
4056 return FFESTC_orderOK_;
4058 case FFESTV_stateWHERE:
4059 ffestc_order_bad_ ();
4061 ffestc_shriek_where_ (FALSE);
4063 return FFESTC_orderBAD_;
4065 case FFESTV_stateIF:
4066 ffestc_order_bad_ ();
4067 ffestc_shriek_if_ (FALSE);
4068 return FFESTC_orderBAD_;
4071 ffestc_order_bad_ ();
4072 return FFESTC_orderBAD_;
4076 /* ffestc_order_use_ -- Check ordering on USE statement
4078 if (ffestc_order_use_() != FFESTC_orderOK_)
4083 ffestc_order_use_ ()
4087 switch (ffestw_state (ffestw_stack_top ()))
4089 case FFESTV_stateNIL:
4090 ffestc_shriek_begin_program_ ();
4091 goto recurse; /* :::::::::::::::::::: */
4093 case FFESTV_statePROGRAM0:
4094 ffestw_update (NULL);
4095 ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM1);
4096 ffestc_shriek_begin_uses_ ();
4097 goto recurse; /* :::::::::::::::::::: */
4099 case FFESTV_stateSUBROUTINE0:
4100 ffestw_update (NULL);
4101 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE1);
4102 ffestc_shriek_begin_uses_ ();
4103 goto recurse; /* :::::::::::::::::::: */
4105 case FFESTV_stateFUNCTION0:
4106 ffestw_update (NULL);
4107 ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION1);
4108 ffestc_shriek_begin_uses_ ();
4109 goto recurse; /* :::::::::::::::::::: */
4111 case FFESTV_stateMODULE0:
4112 ffestw_update (NULL);
4113 ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE1);
4114 ffestc_shriek_begin_uses_ ();
4115 goto recurse; /* :::::::::::::::::::: */
4117 case FFESTV_stateUSE:
4118 return FFESTC_orderOK_;
4120 case FFESTV_stateWHERE:
4121 ffestc_order_bad_ ();
4122 ffestc_shriek_where_ (FALSE);
4123 return FFESTC_orderBAD_;
4125 case FFESTV_stateIF:
4126 ffestc_order_bad_ ();
4127 ffestc_shriek_if_ (FALSE);
4128 return FFESTC_orderBAD_;
4131 ffestc_order_bad_ ();
4132 return FFESTC_orderBAD_;
4137 /* ffestc_order_vxtstructure_ -- Check ordering on STRUCTURE statement
4139 if (ffestc_order_vxtstructure_() != FFESTC_orderOK_)
4144 ffestc_order_vxtstructure_ ()
4148 switch (ffestw_state (ffestw_stack_top ()))
4150 case FFESTV_stateNIL:
4151 ffestc_shriek_begin_program_ ();
4152 goto recurse; /* :::::::::::::::::::: */
4154 case FFESTV_statePROGRAM0:
4155 case FFESTV_statePROGRAM1:
4156 case FFESTV_statePROGRAM2:
4157 ffestw_update (NULL);
4158 ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
4159 return FFESTC_orderOK_;
4161 case FFESTV_stateSUBROUTINE0:
4162 case FFESTV_stateSUBROUTINE1:
4163 case FFESTV_stateSUBROUTINE2:
4164 ffestw_update (NULL);
4165 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
4166 return FFESTC_orderOK_;
4168 case FFESTV_stateFUNCTION0:
4169 case FFESTV_stateFUNCTION1:
4170 case FFESTV_stateFUNCTION2:
4171 ffestw_update (NULL);
4172 ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
4173 return FFESTC_orderOK_;
4175 case FFESTV_stateMODULE0:
4176 case FFESTV_stateMODULE1:
4177 case FFESTV_stateMODULE2:
4178 ffestw_update (NULL);
4179 ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
4180 return FFESTC_orderOK_;
4182 case FFESTV_stateBLOCKDATA0:
4183 case FFESTV_stateBLOCKDATA1:
4184 case FFESTV_stateBLOCKDATA2:
4185 ffestw_update (NULL);
4186 ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA3);
4187 return FFESTC_orderOK_;
4189 case FFESTV_statePROGRAM3:
4190 case FFESTV_stateSUBROUTINE3:
4191 case FFESTV_stateFUNCTION3:
4192 case FFESTV_stateMODULE3:
4193 case FFESTV_stateBLOCKDATA3:
4194 case FFESTV_stateSTRUCTURE:
4195 case FFESTV_stateMAP:
4196 return FFESTC_orderOK_;
4198 case FFESTV_stateUSE:
4200 ffestc_shriek_end_uses_ (TRUE);
4202 goto recurse; /* :::::::::::::::::::: */
4204 case FFESTV_stateWHERE:
4205 ffestc_order_bad_ ();
4207 ffestc_shriek_where_ (FALSE);
4209 return FFESTC_orderBAD_;
4211 case FFESTV_stateIF:
4212 ffestc_order_bad_ ();
4213 ffestc_shriek_if_ (FALSE);
4214 return FFESTC_orderBAD_;
4217 ffestc_order_bad_ ();
4218 return FFESTC_orderBAD_;
4223 /* ffestc_order_where_ -- Check ordering on <where> statement
4225 if (ffestc_order_where_() != FFESTC_orderOK_)
4230 ffestc_order_where_ ()
4232 switch (ffestw_state (ffestw_stack_top ()))
4234 case FFESTV_stateWHERETHEN:
4235 return FFESTC_orderOK_;
4237 case FFESTV_stateWHERE:
4238 ffestc_order_bad_ ();
4239 ffestc_shriek_where_ (FALSE);
4240 return FFESTC_orderBAD_;
4242 case FFESTV_stateIF:
4243 ffestc_order_bad_ ();
4244 ffestc_shriek_if_ (FALSE);
4245 return FFESTC_orderBAD_;
4248 ffestc_order_bad_ ();
4249 return FFESTC_orderBAD_;
4254 /* Invoked for each token in dummy arg list of FUNCTION, SUBROUTINE, and
4255 ENTRY (prior to the first executable statement). */
4258 ffestc_promote_dummy_ (ffelexToken t)
4268 if (ffelex_token_type (t) == FFELEX_typeASTERISK)
4270 ffebld_append_item (&ffestc_local_.dummy.list_bottom,
4271 ffebld_new_star ());
4272 return; /* Don't bother with alternate returns! */
4275 s = ffesymbol_declare_local (t, FALSE);
4276 sa = ffesymbol_attrs (s);
4278 /* Figure out what kind of object we've got based on previous declarations
4279 of or references to the object. */
4283 if (sa & FFESYMBOL_attrsANY)
4285 else if (sa & FFESYMBOL_attrsDUMMY)
4287 if (ffestc_entry_num_ == ffesymbol_maxentrynum (s))
4288 { /* Seen this one twice in this list! */
4289 na = FFESYMBOL_attrsetNONE;
4293 sfref_ok = TRUE; /* Ok for sym to be ref'd in sfuncdef
4294 previously, since already declared as a
4297 else if (!(sa & ~(FFESYMBOL_attrsADJUSTABLE
4298 | FFESYMBOL_attrsADJUSTS
4299 | FFESYMBOL_attrsANY
4300 | FFESYMBOL_attrsANYLEN
4301 | FFESYMBOL_attrsANYSIZE
4302 | FFESYMBOL_attrsARRAY
4303 | FFESYMBOL_attrsDUMMY
4304 | FFESYMBOL_attrsEXTERNAL
4305 | FFESYMBOL_attrsSFARG
4306 | FFESYMBOL_attrsTYPE)))
4307 na = sa | FFESYMBOL_attrsDUMMY;
4309 na = FFESYMBOL_attrsetNONE;
4311 if (!ffesymbol_is_specable (s)
4313 || (ffesymbol_where (s) != FFEINFO_whereDUMMY)))
4314 na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
4316 /* Now see what we've got for a new object: NONE means a new error cropped
4317 up; ANY means an old error to be ignored; otherwise, everything's ok,
4318 update the object (symbol) and continue on. */
4320 if (na == FFESYMBOL_attrsetNONE)
4321 ffesymbol_error (s, t);
4322 else if (!(na & FFESYMBOL_attrsANY))
4324 ffesymbol_set_attrs (s, na);
4325 if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
4326 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
4327 ffesymbol_set_maxentrynum (s, ffestc_entry_num_);
4328 ffesymbol_set_numentries (s, ffesymbol_numentries (s) + 1);
4329 e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
4332 ffeinfo_new (FFEINFO_basictypeNONE,
4333 FFEINFO_kindtypeNONE,
4337 FFETARGET_charactersizeNONE));
4338 ffebld_append_item (&ffestc_local_.dummy.list_bottom, e);
4339 ffesymbol_signal_unreported (s);
4343 /* ffestc_promote_execdummy_ -- Declare token as dummy variable in exec context
4345 ffestc_promote_execdummy_(t);
4347 Invoked for each token in dummy arg list of ENTRY when the statement
4348 follows the first executable statement. */
4351 ffestc_promote_execdummy_ (ffelexToken t)
4364 if (ffelex_token_type (t) == FFELEX_typeASTERISK)
4366 ffebld_append_item (&ffestc_local_.dummy.list_bottom,
4367 ffebld_new_star ());
4368 return; /* Don't bother with alternate returns! */
4371 s = ffesymbol_declare_local (t, FALSE);
4372 na = sa = ffesymbol_attrs (s);
4373 ss = ffesymbol_state (s);
4374 kind = ffesymbol_kind (s);
4375 where = ffesymbol_where (s);
4377 if (ffestc_entry_num_ == ffesymbol_maxentrynum (s))
4378 { /* Seen this one twice in this list! */
4379 na = FFESYMBOL_attrsetNONE;
4382 /* Figure out what kind of object we've got based on previous declarations
4383 of or references to the object. */
4385 ns = FFESYMBOL_stateUNDERSTOOD; /* Assume we know it all know. */
4389 case FFEINFO_kindENTITY:
4390 case FFEINFO_kindFUNCTION:
4391 case FFEINFO_kindSUBROUTINE:
4392 break; /* These are fine, as far as we know. */
4394 case FFEINFO_kindNONE:
4395 if (sa & FFESYMBOL_attrsDUMMY)
4396 ns = FFESYMBOL_stateUNCERTAIN; /* Learned nothing new. */
4397 else if (sa & FFESYMBOL_attrsANYLEN)
4399 kind = FFEINFO_kindENTITY;
4400 where = FFEINFO_whereDUMMY;
4402 else if (sa & FFESYMBOL_attrsACTUALARG)
4403 na = FFESYMBOL_attrsetNONE;
4406 na = sa | FFESYMBOL_attrsDUMMY;
4407 ns = FFESYMBOL_stateUNCERTAIN;
4412 na = FFESYMBOL_attrsetNONE; /* Error. */
4418 case FFEINFO_whereDUMMY:
4419 break; /* This is fine. */
4421 case FFEINFO_whereNONE:
4422 where = FFEINFO_whereDUMMY;
4426 na = FFESYMBOL_attrsetNONE; /* Error. */
4430 /* Now see what we've got for a new object: NONE means a new error cropped
4431 up; ANY means an old error to be ignored; otherwise, everything's ok,
4432 update the object (symbol) and continue on. */
4434 if (na == FFESYMBOL_attrsetNONE)
4435 ffesymbol_error (s, t);
4436 else if (!(na & FFESYMBOL_attrsANY))
4438 ffesymbol_set_attrs (s, na);
4439 ffesymbol_set_state (s, ns);
4440 ffesymbol_set_maxentrynum (s, ffestc_entry_num_);
4441 ffesymbol_set_numentries (s, ffesymbol_numentries (s) + 1);
4442 if ((ns == FFESYMBOL_stateUNDERSTOOD)
4443 && (kind != FFEINFO_kindSUBROUTINE)
4444 && !ffeimplic_establish_symbol (s))
4446 ffesymbol_error (s, t);
4449 ffesymbol_set_info (s,
4450 ffeinfo_new (ffesymbol_basictype (s),
4451 ffesymbol_kindtype (s),
4455 ffesymbol_size (s)));
4456 e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
4458 ffebld_set_info (e, ffeinfo_use (ffesymbol_info (s)));
4459 ffebld_append_item (&ffestc_local_.dummy.list_bottom, e);
4460 s = ffecom_sym_learned (s);
4461 ffesymbol_signal_unreported (s);
4465 /* ffestc_promote_sfdummy_ -- Declare token as stmt-func dummy variable
4467 ffestc_promote_sfdummy_(t);
4469 Invoked for each token in dummy arg list of statement function.
4472 Reject arg if CHARACTER*(*). */
4475 ffestc_promote_sfdummy_ (ffelexToken t)
4478 ffesymbol sp; /* Parent symbol. */
4485 s = ffesymbol_declare_sfdummy (t); /* Sets maxentrynum to 0 for new obj;
4486 also sets sfa_dummy_parent to
4488 if (ffesymbol_state (s) != FFESYMBOL_stateNONE)
4490 ffesymbol_error (s, t); /* Dummy already in list. */
4494 sp = ffesymbol_sfdummyparent (s); /* Now flag dummy's parent as used
4496 sa = ffesymbol_attrs (sp);
4498 /* Figure out what kind of object we've got based on previous declarations
4499 of or references to the object. */
4501 if (!ffesymbol_is_specable (sp)
4502 && ((ffesymbol_kind (sp) != FFEINFO_kindENTITY)
4503 || ((ffesymbol_where (sp) != FFEINFO_whereLOCAL)
4504 && (ffesymbol_where (sp) != FFEINFO_whereCOMMON)
4505 && (ffesymbol_where (sp) != FFEINFO_whereDUMMY)
4506 && (ffesymbol_where (sp) != FFEINFO_whereNONE))))
4507 na = FFESYMBOL_attrsetNONE; /* Can't be PARAMETER etc., must be a var. */
4508 else if (sa & FFESYMBOL_attrsANY)
4510 else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
4511 | FFESYMBOL_attrsCOMMON
4512 | FFESYMBOL_attrsDUMMY
4513 | FFESYMBOL_attrsEQUIV
4514 | FFESYMBOL_attrsINIT
4515 | FFESYMBOL_attrsNAMELIST
4516 | FFESYMBOL_attrsRESULT
4517 | FFESYMBOL_attrsSAVE
4518 | FFESYMBOL_attrsSFARG
4519 | FFESYMBOL_attrsTYPE)))
4520 na = sa | FFESYMBOL_attrsSFARG;
4522 na = FFESYMBOL_attrsetNONE;
4524 /* Now see what we've got for a new object: NONE means a new error cropped
4525 up; ANY means an old error to be ignored; otherwise, everything's ok,
4526 update the object (symbol) and continue on. */
4528 if (na == FFESYMBOL_attrsetNONE)
4530 ffesymbol_error (sp, t);
4531 ffesymbol_set_info (s, ffeinfo_new_any ());
4533 else if (!(na & FFESYMBOL_attrsANY))
4535 ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
4536 ffesymbol_set_attrs (sp, na);
4537 if (!ffeimplic_establish_symbol (sp)
4538 || ((ffesymbol_basictype (sp) == FFEINFO_basictypeCHARACTER)
4539 && (ffesymbol_size (sp) == FFETARGET_charactersizeNONE)))
4540 ffesymbol_error (sp, t);
4542 ffesymbol_set_info (s,
4543 ffeinfo_new (ffesymbol_basictype (sp),
4544 ffesymbol_kindtype (sp),
4548 ffesymbol_size (sp)));
4550 ffesymbol_signal_unreported (sp);
4553 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
4554 ffesymbol_set_maxentrynum (s, ffestc_sfdummy_argno_++);
4555 ffesymbol_signal_unreported (s);
4556 e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
4558 ffebld_set_info (e, ffeinfo_use (ffesymbol_info (s)));
4559 ffebld_append_item (&ffestc_local_.dummy.list_bottom, e);
4562 /* ffestc_shriek_begin_program_ -- Implicit PROGRAM statement
4564 ffestc_shriek_begin_program_();
4566 Invoked only when a PROGRAM statement is NOT present at the beginning
4567 of a main program unit. */
4570 ffestc_shriek_begin_program_ ()
4575 ffestc_blocknum_ = 0;
4576 b = ffestw_update (ffestw_push (NULL));
4577 ffestw_set_top_do (b, NULL);
4578 ffestw_set_state (b, FFESTV_statePROGRAM0);
4579 ffestw_set_blocknum (b, ffestc_blocknum_++);
4580 ffestw_set_shriek (b, ffestc_shriek_end_program_);
4581 ffestw_set_name (b, NULL);
4583 s = ffesymbol_declare_programunit (NULL,
4584 ffelex_token_where_line (ffesta_tokens[0]),
4585 ffelex_token_where_column (ffesta_tokens[0]));
4587 /* Special case: this is one symbol that won't go through
4588 ffestu_exec_transition_ when the first statement in a main program is
4589 executable, because the transition happens in ffest before ffestc is
4590 reached and triggers the implicit generation of a main program. So we
4591 do the exec transition for the implicit main program right here, just
4592 for cleanliness' sake (at the very least). */
4594 ffesymbol_set_info (s,
4595 ffeinfo_new (FFEINFO_basictypeNONE,
4596 FFEINFO_kindtypeNONE,
4598 FFEINFO_kindPROGRAM,
4600 FFETARGET_charactersizeNONE));
4601 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
4603 ffesymbol_signal_unreported (s);
4605 ffestd_R1102 (s, NULL);
4608 /* ffestc_shriek_begin_uses_ -- Start a bunch of USE statements
4610 ffestc_shriek_begin_uses_();
4612 Invoked before handling the first USE statement in a block of one or
4613 more USE statements. _end_uses_(bool ok) is invoked before handling
4614 the first statement after the block (there are no BEGIN USE and END USE
4615 statements, but the semantics of USE statements effectively requires
4616 handling them as a single block rather than one statement at a time). */
4620 ffestc_shriek_begin_uses_ ()
4624 b = ffestw_update (ffestw_push (NULL));
4625 ffestw_set_top_do (b, NULL);
4626 ffestw_set_state (b, FFESTV_stateUSE);
4627 ffestw_set_blocknum (b, 0);
4628 ffestw_set_shriek (b, ffestc_shriek_end_uses_);
4630 ffestd_begin_uses ();
4634 /* ffestc_shriek_blockdata_ -- End a BLOCK DATA
4636 ffestc_shriek_blockdata_(TRUE); */
4639 ffestc_shriek_blockdata_ (bool ok)
4641 if (!ffesta_seen_first_exec)
4643 ffesta_seen_first_exec = TRUE;
4644 ffestd_exec_begin ();
4651 if (ffestw_name (ffestw_stack_top ()) != NULL)
4652 ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
4653 ffestw_kill (ffestw_pop ());
4659 /* ffestc_shriek_do_ -- End of statement following DO-term-stmt etc
4661 ffestc_shriek_do_(TRUE);
4663 Also invoked by _labeldef_branch_end_ (or, in cases
4664 of errors, other _labeldef_ functions) when the label definition is
4665 for a DO-target (LOOPEND) label, once per matching/outstanding DO
4666 block on the stack. These cases invoke this function with ok==TRUE, so
4667 only forced stack popping (via ffestc_eof()) invokes it with ok==FALSE. */
4670 ffestc_shriek_do_ (bool ok)
4674 if (((l = ffestw_label (ffestw_stack_top ())) != NULL)
4675 && (ffewhere_line_is_unknown (ffelab_definition_line (l))))
4676 { /* DO target is label that is still
4678 assert ((ffelab_type (l) == FFELAB_typeLOOPEND)
4679 || (ffelab_type (l) == FFELAB_typeANY));
4680 if (ffelab_type (l) != FFELAB_typeANY)
4682 ffelab_set_definition_line (l,
4683 ffewhere_line_use (ffelab_doref_line (l)));
4684 ffelab_set_definition_column (l,
4685 ffewhere_column_use (ffelab_doref_column (l)));
4686 ffestv_num_label_defines_++;
4688 ffestd_labeldef_branch (l);
4693 if (ffestw_name (ffestw_stack_top ()) != NULL)
4694 ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
4695 if (ffestw_do_iter_var_t (ffestw_stack_top ()) != NULL)
4696 ffelex_token_kill (ffestw_do_iter_var_t (ffestw_stack_top ()));
4697 if (ffestw_do_iter_var (ffestw_stack_top ()) != NULL)
4698 ffesymbol_set_is_doiter (ffestw_do_iter_var (ffestw_stack_top ()), FALSE);
4699 ffestw_kill (ffestw_pop ());
4702 /* ffestc_shriek_end_program_ -- End a PROGRAM
4704 ffestc_shriek_end_program_(); */
4707 ffestc_shriek_end_program_ (bool ok)
4709 if (!ffesta_seen_first_exec)
4711 ffesta_seen_first_exec = TRUE;
4712 ffestd_exec_begin ();
4719 if (ffestw_name (ffestw_stack_top ()) != NULL)
4720 ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
4721 ffestw_kill (ffestw_pop ());
4727 /* ffestc_shriek_end_uses_ -- End a bunch of USE statements
4729 ffestc_shriek_end_uses_(TRUE);
4731 ok==TRUE means simply not popping due to ffestc_eof()
4732 being called, because there is no formal END USES statement in Fortran. */
4736 ffestc_shriek_end_uses_ (bool ok)
4738 ffestd_end_uses (ok);
4740 ffestw_kill (ffestw_pop ());
4744 /* ffestc_shriek_function_ -- End a FUNCTION
4746 ffestc_shriek_function_(TRUE); */
4749 ffestc_shriek_function_ (bool ok)
4751 if (!ffesta_seen_first_exec)
4753 ffesta_seen_first_exec = TRUE;
4754 ffestd_exec_begin ();
4761 ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
4762 ffestw_kill (ffestw_pop ());
4763 ffesta_is_entry_valid = FALSE;
4765 switch (ffestw_state (ffestw_stack_top ()))
4767 case FFESTV_stateNIL:
4777 case FFESTV_stateINTERFACE0:
4784 /* ffestc_shriek_if_ -- End of statement following logical IF
4786 ffestc_shriek_if_(TRUE);
4788 Applies ONLY to logical IF, not to IF-THEN. For example, does not
4789 ffelex_token_kill the construct name for an IF-THEN block (the name
4790 field is invalid for logical IF). ok==TRUE iff statement following
4791 logical IF (substatement) is valid; else, statement is invalid or
4792 stack forcibly popped due to ffestc_eof(). */
4795 ffestc_shriek_if_ (bool ok)
4797 ffestd_end_R807 (ok);
4799 ffestw_kill (ffestw_pop ());
4800 ffestc_shriek_after1_ = NULL;
4802 ffestc_try_shriek_do_ ();
4805 /* ffestc_shriek_ifthen_ -- End an IF-THEN
4807 ffestc_shriek_ifthen_(TRUE); */
4810 ffestc_shriek_ifthen_ (bool ok)
4814 if (ffestw_name (ffestw_stack_top ()) != NULL)
4815 ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
4816 ffestw_kill (ffestw_pop ());
4818 ffestc_try_shriek_do_ ();
4821 /* ffestc_shriek_interface_ -- End an INTERFACE
4823 ffestc_shriek_interface_(TRUE); */
4827 ffestc_shriek_interface_ (bool ok)
4831 ffestw_kill (ffestw_pop ());
4833 ffestc_try_shriek_do_ ();
4837 /* ffestc_shriek_map_ -- End a MAP
4839 ffestc_shriek_map_(TRUE); */
4843 ffestc_shriek_map_ (bool ok)
4847 ffestw_kill (ffestw_pop ());
4849 ffestc_try_shriek_do_ ();
4853 /* ffestc_shriek_module_ -- End a MODULE
4855 ffestc_shriek_module_(TRUE); */
4859 ffestc_shriek_module_ (bool ok)
4861 if (!ffesta_seen_first_exec)
4863 ffesta_seen_first_exec = TRUE;
4864 ffestd_exec_begin ();
4871 ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
4872 ffestw_kill (ffestw_pop ());
4879 /* ffestc_shriek_select_ -- End a SELECT
4881 ffestc_shriek_select_(TRUE); */
4884 ffestc_shriek_select_ (bool ok)
4891 if (ffestw_name (ffestw_stack_top ()) != NULL)
4892 ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
4893 s = ffestw_select (ffestw_stack_top ());
4894 ffelex_token_kill (s->t);
4895 for (c = s->first_rel; c != (ffestwCase) &s->first_rel; c = c->next_rel)
4896 ffelex_token_kill (c->t);
4897 malloc_pool_kill (s->pool);
4899 ffestw_kill (ffestw_pop ());
4901 ffestc_try_shriek_do_ ();
4904 /* ffestc_shriek_structure_ -- End a STRUCTURE
4906 ffestc_shriek_structure_(TRUE); */
4910 ffestc_shriek_structure_ (bool ok)
4914 ffestw_kill (ffestw_pop ());
4916 ffestc_try_shriek_do_ ();
4920 /* ffestc_shriek_subroutine_ -- End a SUBROUTINE
4922 ffestc_shriek_subroutine_(TRUE); */
4925 ffestc_shriek_subroutine_ (bool ok)
4927 if (!ffesta_seen_first_exec)
4929 ffesta_seen_first_exec = TRUE;
4930 ffestd_exec_begin ();
4937 ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
4938 ffestw_kill (ffestw_pop ());
4939 ffesta_is_entry_valid = FALSE;
4941 switch (ffestw_state (ffestw_stack_top ()))
4943 case FFESTV_stateNIL:
4953 case FFESTV_stateINTERFACE0:
4960 /* ffestc_shriek_type_ -- End a TYPE
4962 ffestc_shriek_type_(TRUE); */
4966 ffestc_shriek_type_ (bool ok)
4972 ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
4973 ffestw_kill (ffestw_pop ());
4975 ffestc_try_shriek_do_ ();
4979 /* ffestc_shriek_union_ -- End a UNION
4981 ffestc_shriek_union_(TRUE); */
4985 ffestc_shriek_union_ (bool ok)
4989 ffestw_kill (ffestw_pop ());
4991 ffestc_try_shriek_do_ ();
4995 /* ffestc_shriek_where_ -- Implicit END WHERE statement
4997 ffestc_shriek_where_(TRUE);
4999 Implement the end of the current WHERE "block". ok==TRUE iff statement
5000 following WHERE (substatement) is valid; else, statement is invalid
5001 or stack forcibly popped due to ffestc_eof(). */
5005 ffestc_shriek_where_ (bool ok)
5009 ffestw_kill (ffestw_pop ());
5010 ffestc_shriek_after1_ = NULL;
5011 if (ffestw_state (ffestw_stack_top ()) == FFESTV_stateIF)
5012 ffestc_shriek_if_ (TRUE); /* "IF (x) WHERE (y) stmt" is only valid
5015 ffestc_try_shriek_do_ ();
5019 /* ffestc_shriek_wherethen_ -- End a WHERE(-THEN)
5021 ffestc_shriek_wherethen_(TRUE); */
5025 ffestc_shriek_wherethen_ (bool ok)
5027 ffestd_end_R740 (ok);
5029 ffestw_kill (ffestw_pop ());
5031 ffestc_try_shriek_do_ ();
5035 /* ffestc_subr_binsrch_ -- Binary search of char const in list of strings
5037 i = ffestc_subr_binsrch_(search_list,search_list_size,&spec,"etc");
5039 search_list contains search_list_size char *'s, spec is checked to see
5040 if it is a char constant and, if so, is binary-searched against the list.
5041 0 is returned if not found, else the "classic" index (beginning with 1)
5042 is returned. Before returning 0 where the search was performed but
5043 fruitless, if "etc" is a non-NULL char *, an error message is displayed
5044 using "etc" as the pick-one-of-these string. */
5047 ffestc_subr_binsrch_ (const char *const *list, int size, ffestpFile *spec,
5059 return 0; /* Nobody should pass size == 0, but for
5063 highest_tested = size;
5064 halfway = size >> 1;
5068 c = ffestc_subr_speccmp_ (*list, spec, &str, &len);
5073 next: /* :::::::::::::::::::: */
5077 offset = (halfway - lowest_tested) >> 1;
5079 goto nope; /* :::::::::::::::::::: */
5080 highest_tested = halfway;
5083 c = ffesrc_strcmp_1ns2i (ffe_case_match (), str, len, *list);
5084 goto next; /* :::::::::::::::::::: */
5090 offset = (highest_tested - halfway) >> 1;
5092 goto nope; /* :::::::::::::::::::: */
5093 lowest_tested = halfway;
5096 c = ffesrc_strcmp_1ns2i (ffe_case_match (), str, len, *list);
5097 goto next; /* :::::::::::::::::::: */
5100 assert ("unexpected return from ffesrc_strcmp_1ns2i" == NULL);
5104 nope: /* :::::::::::::::::::: */
5105 ffebad_start (FFEBAD_SPEC_VALUE);
5106 ffebad_here (0, ffelex_token_where_line (spec->value),
5107 ffelex_token_where_column (spec->value));
5108 ffebad_string (whine);
5113 /* ffestc_subr_format_ -- Return summary of format specifier
5115 ffestc_subr_format_(&specifier); */
5118 ffestc_subr_format_ (ffestpFile *spec)
5120 if (!spec->kw_or_val_present)
5121 return FFESTV_formatNONE;
5122 assert (spec->value_present);
5123 if (spec->value_is_label)
5124 return FFESTV_formatLABEL; /* Ok if not a label. */
5126 assert (spec->value != NULL);
5127 if (ffebld_op (spec->u.expr) == FFEBLD_opSTAR)
5128 return FFESTV_formatASTERISK;
5130 if (ffeinfo_kind (ffebld_info (spec->u.expr)) == FFEINFO_kindNAMELIST)
5131 return FFESTV_formatNAMELIST;
5133 if (ffeinfo_rank (ffebld_info (spec->u.expr)) != 0)
5134 return FFESTV_formatCHAREXPR; /* F77 C5. */
5136 switch (ffeinfo_basictype (ffebld_info (spec->u.expr)))
5138 case FFEINFO_basictypeINTEGER:
5139 return FFESTV_formatINTEXPR;
5141 case FFEINFO_basictypeCHARACTER:
5142 return FFESTV_formatCHAREXPR;
5144 case FFEINFO_basictypeANY:
5145 return FFESTV_formatASTERISK;
5148 assert ("bad basictype" == NULL);
5149 return FFESTV_formatINTEXPR;
5153 /* ffestc_subr_is_branch_ -- Handle specifier as branch target label
5155 ffestc_subr_is_branch_(&specifier); */
5158 ffestc_subr_is_branch_ (ffestpFile *spec)
5160 if (!spec->kw_or_val_present)
5162 assert (spec->value_present);
5163 assert (spec->value_is_label);
5164 spec->value_is_label++; /* For checking purposes only; 1=>2. */
5165 return ffestc_labelref_is_branch_ (spec->value, &spec->u.label);
5168 /* ffestc_subr_is_format_ -- Handle specifier as format target label
5170 ffestc_subr_is_format_(&specifier); */
5173 ffestc_subr_is_format_ (ffestpFile *spec)
5175 if (!spec->kw_or_val_present)
5177 assert (spec->value_present);
5178 if (!spec->value_is_label)
5179 return TRUE; /* Ok if not a label. */
5181 spec->value_is_label++; /* For checking purposes only; 1=>2. */
5182 return ffestc_labelref_is_format_ (spec->value, &spec->u.label);
5185 /* ffestc_subr_is_present_ -- Ensure specifier is present, else error
5187 ffestc_subr_is_present_("SPECIFIER",&specifier); */
5190 ffestc_subr_is_present_ (const char *name, ffestpFile *spec)
5192 if (spec->kw_or_val_present)
5194 assert (spec->value_present);
5198 ffebad_start (FFEBAD_MISSING_SPECIFIER);
5199 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
5200 ffelex_token_where_column (ffesta_tokens[0]));
5201 ffebad_string (name);
5206 /* ffestc_subr_speccmp_ -- Compare string to constant expression, if present
5208 if (ffestc_subr_speccmp_("Constant",&specifier,NULL,NULL) == 0)
5209 // specifier value is present and is a char constant "CONSTANT"
5211 Like strcmp, except the return values are defined as: -1 returned in place
5212 of strcmp's generic negative value, 1 in place of it's generic positive
5213 value, and 2 when there is no character constant string to compare. Also,
5214 a case-insensitive comparison is performed, where string is assumed to
5215 already be in InitialCaps form.
5217 If a non-NULL pointer is provided as the char **target, then *target is
5218 written with NULL if 2 is returned, a pointer to the constant string
5219 value of the specifier otherwise. Similarly, length is written with
5220 0 if 2 is returned, the length of the constant string value otherwise. */
5223 ffestc_subr_speccmp_ (const char *string, ffestpFile *spec, const char **target,
5229 if (!spec->kw_or_val_present || !spec->value_present
5230 || (spec->u.expr == NULL)
5231 || (ffebld_op (spec->u.expr) != FFEBLD_opCONTER))
5240 if (ffebld_constant_type (c = ffebld_conter (spec->u.expr))
5241 != FFEBLD_constCHARACTERDEFAULT)
5251 *target = ffebld_constant_characterdefault (c).text;
5253 *length = ffebld_constant_characterdefault (c).length;
5255 i = ffesrc_strcmp_1ns2i (ffe_case_match (),
5256 ffebld_constant_characterdefault (c).text,
5257 ffebld_constant_characterdefault (c).length,
5262 return -1; /* Yes indeed, we reverse the strings to
5267 /* ffestc_subr_unit_ -- Return summary of unit specifier
5269 ffestc_subr_unit_(&specifier); */
5272 ffestc_subr_unit_ (ffestpFile *spec)
5274 if (!spec->kw_or_val_present)
5275 return FFESTV_unitNONE;
5276 assert (spec->value_present);
5277 assert (spec->value != NULL);
5279 if (ffebld_op (spec->u.expr) == FFEBLD_opSTAR)
5280 return FFESTV_unitASTERISK;
5282 switch (ffeinfo_basictype (ffebld_info (spec->u.expr)))
5284 case FFEINFO_basictypeINTEGER:
5285 return FFESTV_unitINTEXPR;
5287 case FFEINFO_basictypeCHARACTER:
5288 return FFESTV_unitCHAREXPR;
5290 case FFEINFO_basictypeANY:
5291 return FFESTV_unitASTERISK;
5294 assert ("bad basictype" == NULL);
5295 return FFESTV_unitINTEXPR;
5299 /* Call this function whenever it's possible that one or more top
5300 stack items are label-targeting DO blocks that have had their
5301 labels defined, but at a time when they weren't at the top of the
5302 stack. This prevents uninformative diagnostics for programs
5303 like "DO 10", "IF (...) THEN", "10 ELSE", "END IF", "END". */
5306 ffestc_try_shriek_do_ ()
5311 while ((ffestw_state (ffestw_stack_top ()) == FFESTV_stateDO)
5312 && ((lab = (ffestw_label (ffestw_stack_top ()))) != NULL)
5313 && (((ty = (ffelab_type (lab)))
5315 || (ty == FFELAB_typeUSELESS)
5316 || (ty == FFELAB_typeFORMAT)
5317 || (ty == FFELAB_typeNOTLOOP)
5318 || (ty == FFELAB_typeENDIF)))
5319 ffestc_shriek_do_ (FALSE);
5322 /* ffestc_decl_start -- R426 or R501
5324 ffestc_decl_start(...);
5326 Verify that R426 component-def-stmt or R501 type-declaration-stmt are
5327 valid here, figure out which one, and implement. */
5330 ffestc_decl_start (ffestpType type, ffelexToken typet, ffebld kind,
5331 ffelexToken kindt, ffebld len, ffelexToken lent)
5333 switch (ffestw_state (ffestw_stack_top ()))
5335 case FFESTV_stateNIL:
5336 case FFESTV_statePROGRAM0:
5337 case FFESTV_stateSUBROUTINE0:
5338 case FFESTV_stateFUNCTION0:
5339 case FFESTV_stateMODULE0:
5340 case FFESTV_stateBLOCKDATA0:
5341 case FFESTV_statePROGRAM1:
5342 case FFESTV_stateSUBROUTINE1:
5343 case FFESTV_stateFUNCTION1:
5344 case FFESTV_stateMODULE1:
5345 case FFESTV_stateBLOCKDATA1:
5346 case FFESTV_statePROGRAM2:
5347 case FFESTV_stateSUBROUTINE2:
5348 case FFESTV_stateFUNCTION2:
5349 case FFESTV_stateMODULE2:
5350 case FFESTV_stateBLOCKDATA2:
5351 case FFESTV_statePROGRAM3:
5352 case FFESTV_stateSUBROUTINE3:
5353 case FFESTV_stateFUNCTION3:
5354 case FFESTV_stateMODULE3:
5355 case FFESTV_stateBLOCKDATA3:
5356 case FFESTV_stateUSE:
5357 ffestc_local_.decl.is_R426 = 2;
5360 case FFESTV_stateTYPE:
5361 case FFESTV_stateSTRUCTURE:
5362 case FFESTV_stateMAP:
5363 ffestc_local_.decl.is_R426 = 1;
5367 ffestc_order_bad_ ();
5368 ffestc_labeldef_useless_ ();
5369 ffestc_local_.decl.is_R426 = 0;
5373 switch (ffestc_local_.decl.is_R426)
5377 ffestc_R426_start (type, typet, kind, kindt, len, lent);
5382 ffestc_R501_start (type, typet, kind, kindt, len, lent);
5386 ffestc_labeldef_useless_ ();
5391 /* ffestc_decl_attrib -- R426 or R501 type attribute
5393 ffestc_decl_attrib(...);
5395 Verify that R426 component-def-stmt or R501 type-declaration-stmt attribute
5396 is valid here and implement. */
5399 ffestc_decl_attrib (ffestpAttrib attrib UNUSED,
5400 ffelexToken attribt UNUSED,
5401 ffestrOther intent_kw UNUSED,
5402 ffesttDimList dims UNUSED)
5405 switch (ffestc_local_.decl.is_R426)
5408 ffestc_R426_attrib (attrib, attribt, intent_kw, dims);
5412 ffestc_R501_attrib (attrib, attribt, intent_kw, dims);
5419 ffebad_start (FFEBAD_F90);
5420 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
5421 ffelex_token_where_column (ffesta_tokens[0]));
5427 /* ffestc_decl_item -- R426 or R501
5429 ffestc_decl_item(...);
5431 Establish type for a particular object. */
5434 ffestc_decl_item (ffelexToken name, ffebld kind, ffelexToken kindt,
5435 ffesttDimList dims, ffebld len, ffelexToken lent, ffebld init,
5436 ffelexToken initt, bool clist)
5438 switch (ffestc_local_.decl.is_R426)
5442 ffestc_R426_item (name, kind, kindt, dims, len, lent, init, initt,
5448 ffestc_R501_item (name, kind, kindt, dims, len, lent, init, initt,
5457 /* ffestc_decl_itemstartvals -- R426 or R501 start list of values
5459 ffestc_decl_itemstartvals();
5461 Gonna specify values for the object now. */
5464 ffestc_decl_itemstartvals ()
5466 switch (ffestc_local_.decl.is_R426)
5470 ffestc_R426_itemstartvals ();
5475 ffestc_R501_itemstartvals ();
5483 /* ffestc_decl_itemvalue -- R426 or R501 source value
5485 ffestc_decl_itemvalue(repeat,repeat_token,value,value_token);
5487 Make sure repeat and value are valid for the object being initialized. */
5490 ffestc_decl_itemvalue (ffebld repeat, ffelexToken repeat_token,
5491 ffebld value, ffelexToken value_token)
5493 switch (ffestc_local_.decl.is_R426)
5497 ffestc_R426_itemvalue (repeat, repeat_token, value, value_token);
5502 ffestc_R501_itemvalue (repeat, repeat_token, value, value_token);
5510 /* ffestc_decl_itemendvals -- R426 or R501 end list of values
5512 ffelexToken t; // the SLASH token that ends the list.
5513 ffestc_decl_itemendvals(t);
5515 No more values, might specify more objects now. */
5518 ffestc_decl_itemendvals (ffelexToken t)
5520 switch (ffestc_local_.decl.is_R426)
5524 ffestc_R426_itemendvals (t);
5529 ffestc_R501_itemendvals (t);
5537 /* ffestc_decl_finish -- R426 or R501
5539 ffestc_decl_finish();
5541 Just wrap up any local activities. */
5544 ffestc_decl_finish ()
5546 switch (ffestc_local_.decl.is_R426)
5550 ffestc_R426_finish ();
5555 ffestc_R501_finish ();
5563 /* ffestc_elsewhere -- Generic ELSE WHERE statement
5567 Decide whether ELSEWHERE or ELSE w/if-construct-name=="WHERE" is meant. */
5570 ffestc_elsewhere (ffelexToken where)
5572 switch (ffestw_state (ffestw_stack_top ()))
5574 case FFESTV_stateIFTHEN:
5575 ffestc_R805 (where);
5586 /* ffestc_end -- Generic END statement
5590 Make sure a generic END is valid in the current context, and implement
5598 b = ffestw_stack_top ();
5602 switch (ffestw_state (b))
5604 case FFESTV_stateBLOCKDATA0:
5605 case FFESTV_stateBLOCKDATA1:
5606 case FFESTV_stateBLOCKDATA2:
5607 case FFESTV_stateBLOCKDATA3:
5608 case FFESTV_stateBLOCKDATA4:
5609 case FFESTV_stateBLOCKDATA5:
5610 ffestc_R1112 (NULL);
5613 case FFESTV_stateFUNCTION0:
5614 case FFESTV_stateFUNCTION1:
5615 case FFESTV_stateFUNCTION2:
5616 case FFESTV_stateFUNCTION3:
5617 case FFESTV_stateFUNCTION4:
5618 case FFESTV_stateFUNCTION5:
5619 if ((ffestw_state (ffestw_previous (b)) != FFESTV_stateNIL)
5620 && (ffestw_state (ffestw_previous (b)) != FFESTV_stateINTERFACE0))
5622 ffebad_start (FFEBAD_END_WO);
5623 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
5624 ffelex_token_where_column (ffesta_tokens[0]));
5625 ffebad_here (1, ffestw_line (ffestw_previous (b)), ffestw_col (ffestw_previous (b)));
5626 ffebad_string ("FUNCTION");
5629 ffestc_R1221 (NULL);
5632 case FFESTV_stateMODULE0:
5633 case FFESTV_stateMODULE1:
5634 case FFESTV_stateMODULE2:
5635 case FFESTV_stateMODULE3:
5636 case FFESTV_stateMODULE4:
5637 case FFESTV_stateMODULE5:
5639 ffestc_R1106 (NULL);
5643 case FFESTV_stateSUBROUTINE0:
5644 case FFESTV_stateSUBROUTINE1:
5645 case FFESTV_stateSUBROUTINE2:
5646 case FFESTV_stateSUBROUTINE3:
5647 case FFESTV_stateSUBROUTINE4:
5648 case FFESTV_stateSUBROUTINE5:
5649 if ((ffestw_state (ffestw_previous (b)) != FFESTV_stateNIL)
5650 && (ffestw_state (ffestw_previous (b)) != FFESTV_stateINTERFACE0))
5652 ffebad_start (FFEBAD_END_WO);
5653 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
5654 ffelex_token_where_column (ffesta_tokens[0]));
5655 ffebad_here (1, ffestw_line (ffestw_previous (b)), ffestw_col (ffestw_previous (b)));
5656 ffebad_string ("SUBROUTINE");
5659 ffestc_R1225 (NULL);
5662 case FFESTV_stateUSE:
5663 b = ffestw_previous (ffestw_stack_top ());
5664 goto recurse; /* :::::::::::::::::::: */
5667 ffestc_R1103 (NULL);
5672 /* ffestc_eof -- Generic EOF
5676 Make sure we're at state NIL, or issue an error message and use each
5677 block's shriek function to clean up to state NIL. */
5682 if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateNIL)
5684 ffebad_start (FFEBAD_EOF_BEFORE_BLOCK_END);
5685 ffebad_here (0, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
5688 (*ffestw_shriek (ffestw_stack_top ()))(FALSE);
5689 while (ffestw_state (ffestw_stack_top ()) != FFESTV_stateNIL);
5693 /* ffestc_exec_transition -- Check if ok and move stmt state to executable
5695 if (ffestc_exec_transition())
5696 // Transition successful (kind of like a CONTINUE stmt was seen).
5698 If the current statement state is a non-nested specification state in
5699 which, say, a CONTINUE statement would be valid, then enter the state
5700 we'd be in after seeing CONTINUE (without, of course, generating any
5701 CONTINUE code), call ffestd_exec_begin, and return TRUE. Otherwise
5704 This function cannot be invoked once the first executable statement
5705 is seen. This function may choose to always return TRUE by shrieking
5706 away any interceding state stack entries to reach the base level of
5707 specification state, but right now it doesn't, and it is (or should
5708 be) purely an issue of how one wishes errors to be handled (for example,
5709 an unrecognized statement in the middle of a STRUCTURE construct: after
5710 the error message, should subsequent statements still be interpreted as
5711 being within the construct, or should the construct be terminated upon
5712 seeing the unrecognized statement? we do the former at the moment). */
5715 ffestc_exec_transition ()
5721 switch (ffestw_state (ffestw_stack_top ()))
5723 case FFESTV_stateNIL:
5724 ffestc_shriek_begin_program_ ();
5725 goto recurse; /* :::::::::::::::::::: */
5727 case FFESTV_statePROGRAM0:
5728 case FFESTV_stateSUBROUTINE0:
5729 case FFESTV_stateFUNCTION0:
5730 case FFESTV_stateBLOCKDATA0:
5731 ffestw_state (ffestw_stack_top ()) += 4; /* To state UNIT4. */
5735 case FFESTV_statePROGRAM1:
5736 case FFESTV_stateSUBROUTINE1:
5737 case FFESTV_stateFUNCTION1:
5738 case FFESTV_stateBLOCKDATA1:
5739 ffestw_state (ffestw_stack_top ()) += 3; /* To state UNIT4. */
5743 case FFESTV_statePROGRAM2:
5744 case FFESTV_stateSUBROUTINE2:
5745 case FFESTV_stateFUNCTION2:
5746 case FFESTV_stateBLOCKDATA2:
5747 ffestw_state (ffestw_stack_top ()) += 2; /* To state UNIT4. */
5751 case FFESTV_statePROGRAM3:
5752 case FFESTV_stateSUBROUTINE3:
5753 case FFESTV_stateFUNCTION3:
5754 case FFESTV_stateBLOCKDATA3:
5755 ffestw_state (ffestw_stack_top ()) += 1; /* To state UNIT4. */
5759 case FFESTV_stateUSE:
5761 ffestc_shriek_end_uses_ (TRUE);
5763 goto recurse; /* :::::::::::::::::::: */
5770 ffestw_update (NULL); /* Update state line/col info. */
5772 ffesta_seen_first_exec = TRUE;
5773 ffestd_exec_begin ();
5778 /* ffestc_ffebad_here_doiter -- Calls ffebad_here with ptr to DO iter var
5781 // call ffebad_start first, of course.
5782 ffestc_ffebad_here_doiter(0,s);
5783 // call ffebad_finish afterwards, naturally.
5785 Searches the stack of blocks backwards for a DO loop that has s
5786 as its iteration variable, then calls ffebad_here with pointers to
5787 that particular reference to the variable. Crashes if the DO loop
5791 ffestc_ffebad_here_doiter (ffebadIndex i, ffesymbol s)
5795 for (block = ffestw_top_do (ffestw_stack_top ());
5796 (block != NULL) && (ffestw_blocknum (block) != 0);
5797 block = ffestw_top_do (ffestw_previous (block)))
5799 if (ffestw_do_iter_var (block) == s)
5801 ffebad_here (i, ffelex_token_where_line (ffestw_do_iter_var_t (block)),
5802 ffelex_token_where_column (ffestw_do_iter_var_t (block)));
5806 assert ("no do block found" == NULL);
5809 /* ffestc_is_decl_not_R1219 -- Context information for FFESTB
5811 if (ffestc_is_decl_not_R1219()) ...
5813 When a statement with the form "type[RECURSIVE]FUNCTIONname(name-list)"
5814 is seen, call this function. It returns TRUE if the statement's context
5815 is such that it is a declaration of an object named
5816 "[RECURSIVE]FUNCTIONname" with an array-decl spec of "name-list", FALSE
5817 if the statement's context is such that it begins the definition of a
5818 function named "name" havin the dummy argument list "name-list" (this
5819 is the R1219 function-stmt case). */
5822 ffestc_is_decl_not_R1219 ()
5824 switch (ffestw_state (ffestw_stack_top ()))
5826 case FFESTV_stateNIL:
5827 case FFESTV_statePROGRAM5:
5828 case FFESTV_stateSUBROUTINE5:
5829 case FFESTV_stateFUNCTION5:
5830 case FFESTV_stateMODULE5:
5831 case FFESTV_stateINTERFACE0:
5839 /* ffestc_is_entry_in_subr -- Context information for FFESTB
5841 if (ffestc_is_entry_in_subr()) ...
5843 When a statement with the form "ENTRY name(name-list)"
5844 is seen, call this function. It returns TRUE if the statement's context
5845 is such that it may have "*", meaning alternate return, in place of
5846 names in the name list (i.e. if the ENTRY is in a subroutine context).
5847 It also returns TRUE if the ENTRY is not in a function context (invalid
5848 but prevents extra complaints about "*", if present). It returns FALSE
5849 if the ENTRY is in a function context. */
5852 ffestc_is_entry_in_subr ()
5856 s = ffestw_state (ffestw_stack_top ());
5862 case FFESTV_stateFUNCTION0:
5863 case FFESTV_stateFUNCTION1:
5864 case FFESTV_stateFUNCTION2:
5865 case FFESTV_stateFUNCTION3:
5866 case FFESTV_stateFUNCTION4:
5869 case FFESTV_stateUSE:
5870 s = ffestw_state (ffestw_previous (ffestw_stack_top ()));
5871 goto recurse; /* :::::::::::::::::::: */
5878 /* ffestc_is_let_not_V027 -- Context information for FFESTB
5880 if (ffestc_is_let_not_V027()) ...
5882 When a statement with the form "PARAMETERname=expr"
5883 is seen, call this function. It returns TRUE if the statement's context
5884 is such that it is an assignment to an object named "PARAMETERname", FALSE
5885 if the statement's context is such that it is a V-extension PARAMETER
5886 statement that is like a PARAMETER(name=expr) statement except that the
5887 type of name is determined by the type of expr, not the implicit or
5888 explicit typing of name. */
5891 ffestc_is_let_not_V027 ()
5893 switch (ffestw_state (ffestw_stack_top ()))
5895 case FFESTV_statePROGRAM4:
5896 case FFESTV_stateSUBROUTINE4:
5897 case FFESTV_stateFUNCTION4:
5898 case FFESTV_stateWHERETHEN:
5899 case FFESTV_stateIFTHEN:
5900 case FFESTV_stateDO:
5901 case FFESTV_stateSELECT0:
5902 case FFESTV_stateSELECT1:
5903 case FFESTV_stateWHERE:
5904 case FFESTV_stateIF:
5912 /* ffestc_module -- MODULE or MODULE PROCEDURE statement
5914 ffestc_module(module_name_token,procedure_name_token);
5916 Decide which is intended, and implement it by calling _R1105_ or
5921 ffestc_module (ffelexToken module, ffelexToken procedure)
5923 switch (ffestw_state (ffestw_stack_top ()))
5925 case FFESTV_stateINTERFACE0:
5926 case FFESTV_stateINTERFACE1:
5927 ffestc_R1205_start ();
5928 ffestc_R1205_item (procedure);
5929 ffestc_R1205_finish ();
5933 ffestc_R1105 (module);
5939 /* ffestc_private -- Generic PRIVATE statement
5943 This is either a PRIVATE within R422 derived-type statement or an
5944 R521 PRIVATE statement. Figure it out based on context and implement
5945 it, or produce an error. */
5951 switch (ffestw_state (ffestw_stack_top ()))
5953 case FFESTV_stateTYPE:
5964 /* ffestc_terminate_4 -- Terminate ffestc after scoping unit
5966 ffestc_terminate_4();
5968 For SUBROUTINEs/FUNCTIONs within INTERFACE/END INTERFACE, derived-TYPE-
5969 defs, and statement function defs. */
5972 ffestc_terminate_4 ()
5974 ffestc_entry_num_ = ffestc_saved_entry_num_;
5977 /* ffestc_R423A -- PRIVATE statement (in R422 derived-type statement)
5985 ffestc_check_simple_ ();
5986 if (ffestc_order_type_ () != FFESTC_orderOK_)
5988 ffestc_labeldef_useless_ ();
5990 if (ffestw_substate (ffestw_stack_top ()) != 0)
5992 ffebad_start (FFEBAD_DERIVTYP_ACCESS_FIRST);
5993 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
5994 ffelex_token_where_column (ffesta_tokens[0]));
5995 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
6000 if (ffestw_state (ffestw_previous (ffestw_stack_top ())) != FFESTV_stateMODULE3)
6002 ffebad_start (FFEBAD_DERIVTYP_ACCESS);
6003 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
6004 ffelex_token_where_column (ffesta_tokens[0]));
6009 ffestw_set_substate (ffestw_stack_top (), 1); /* Seen
6010 private-sequence-stmt. */
6015 /* ffestc_R423B -- SEQUENCE statement (in R422 derived-type-stmt)
6022 ffestc_check_simple_ ();
6023 if (ffestc_order_type_ () != FFESTC_orderOK_)
6025 ffestc_labeldef_useless_ ();
6027 if (ffestw_substate (ffestw_stack_top ()) != 0)
6029 ffebad_start (FFEBAD_DERIVTYP_ACCESS_FIRST);
6030 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
6031 ffelex_token_where_column (ffesta_tokens[0]));
6032 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
6037 ffestw_set_substate (ffestw_stack_top (), 1); /* Seen
6038 private-sequence-stmt. */
6043 /* ffestc_R424 -- derived-TYPE-def statement
6045 ffestc_R424(access_token,access_kw,name_token);
6047 Handle a derived-type definition. */
6050 ffestc_R424 (ffelexToken access, ffestrOther access_kw, ffelexToken name)
6054 assert (name != NULL);
6056 ffestc_check_simple_ ();
6057 if (ffestc_order_derivedtype_ () != FFESTC_orderOK_)
6059 ffestc_labeldef_useless_ ();
6061 if ((access != NULL)
6062 && (ffestw_state (ffestw_stack_top ()) != FFESTV_stateMODULE3))
6064 ffebad_start (FFEBAD_DERIVTYP_ACCESS);
6065 ffebad_here (0, ffelex_token_where_line (access),
6066 ffelex_token_where_column (access));
6071 b = ffestw_update (ffestw_push (NULL));
6072 ffestw_set_top_do (b, NULL);
6073 ffestw_set_state (b, FFESTV_stateTYPE);
6074 ffestw_set_blocknum (b, 0);
6075 ffestw_set_shriek (b, ffestc_shriek_type_);
6076 ffestw_set_name (b, ffelex_token_use (name));
6077 ffestw_set_substate (b, 0); /* Awaiting private-sequence-stmt and one
6078 component-def-stmt. */
6080 ffestd_R424 (access, access_kw, name);
6085 /* ffestc_R425 -- END TYPE statement
6087 ffestc_R425(name_token);
6089 Make sure ffestc_kind_ identifies a TYPE definition. If not
6090 NULL, make sure name_token gives the correct name. Implement the end
6091 of the type definition. */
6094 ffestc_R425 (ffelexToken name)
6096 ffestc_check_simple_ ();
6097 if (ffestc_order_type_ () != FFESTC_orderOK_)
6099 ffestc_labeldef_useless_ ();
6101 if (ffestw_substate (ffestw_stack_top ()) != 2)
6103 ffebad_start (FFEBAD_DERIVTYP_NO_COMPONENTS);
6104 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
6105 ffelex_token_where_column (ffesta_tokens[0]));
6106 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
6111 && (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0))
6113 ffebad_start (FFEBAD_TYPE_WRONG_NAME);
6114 ffebad_here (0, ffelex_token_where_line (name),
6115 ffelex_token_where_column (name));
6116 ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
6117 ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
6121 ffestc_shriek_type_ (TRUE);
6124 /* ffestc_R426_start -- component-declaration-stmt
6126 ffestc_R426_start(...);
6128 Verify that R426 component-declaration-stmt is
6129 valid here and implement. */
6132 ffestc_R426_start (ffestpType type, ffelexToken typet, ffebld kind,
6133 ffelexToken kindt, ffebld len, ffelexToken lent)
6135 ffestc_check_start_ ();
6136 if (ffestc_order_component_ () != FFESTC_orderOK_)
6138 ffestc_local_.decl.is_R426 = 0;
6141 ffestc_labeldef_useless_ ();
6143 switch (ffestw_state (ffestw_stack_top ()))
6145 case FFESTV_stateSTRUCTURE:
6146 case FFESTV_stateMAP:
6147 ffestw_set_substate (ffestw_stack_top (), 1); /* Seen at least one
6151 case FFESTV_stateTYPE:
6152 ffestw_set_substate (ffestw_stack_top (), 2);
6156 assert ("Component parent state invalid" == NULL);
6161 /* ffestc_R426_attrib -- type attribute
6163 ffestc_R426_attrib(...);
6165 Verify that R426 component-declaration-stmt attribute
6166 is valid here and implement. */
6169 ffestc_R426_attrib (ffestpAttrib attrib, ffelexToken attribt,
6170 ffestrOther intent_kw, ffesttDimList dims)
6172 ffestc_check_attrib_ ();
6175 /* ffestc_R426_item -- declared object
6177 ffestc_R426_item(...);
6179 Establish type for a particular object. */
6182 ffestc_R426_item (ffelexToken name, ffebld kind, ffelexToken kindt,
6183 ffesttDimList dims, ffebld len, ffelexToken lent, ffebld init,
6184 ffelexToken initt, bool clist)
6186 ffestc_check_item_ ();
6187 assert (name != NULL);
6188 assert (ffelex_token_type (name) == FFELEX_typeNAME); /* Not NAMES. */
6189 assert (kind == NULL); /* No way an expression should get here. */
6191 if ((dims != NULL) || (init != NULL) || clist)
6192 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
6195 /* ffestc_R426_itemstartvals -- Start list of values
6197 ffestc_R426_itemstartvals();
6199 Gonna specify values for the object now. */
6202 ffestc_R426_itemstartvals ()
6204 ffestc_check_item_startvals_ ();
6207 /* ffestc_R426_itemvalue -- Source value
6209 ffestc_R426_itemvalue(repeat,repeat_token,value,value_token);
6211 Make sure repeat and value are valid for the object being initialized. */
6214 ffestc_R426_itemvalue (ffebld repeat, ffelexToken repeat_token,
6215 ffebld value, ffelexToken value_token)
6217 ffestc_check_item_value_ ();
6220 /* ffestc_R426_itemendvals -- End list of values
6222 ffelexToken t; // the SLASH token that ends the list.
6223 ffestc_R426_itemendvals(t);
6225 No more values, might specify more objects now. */
6228 ffestc_R426_itemendvals (ffelexToken t)
6230 ffestc_check_item_endvals_ ();
6233 /* ffestc_R426_finish -- Done
6235 ffestc_R426_finish();
6237 Just wrap up any local activities. */
6240 ffestc_R426_finish ()
6242 ffestc_check_finish_ ();
6246 /* ffestc_R501_start -- type-declaration-stmt
6248 ffestc_R501_start(...);
6250 Verify that R501 type-declaration-stmt is
6251 valid here and implement. */
6254 ffestc_R501_start (ffestpType type, ffelexToken typet, ffebld kind,
6255 ffelexToken kindt, ffebld len, ffelexToken lent)
6257 ffestc_check_start_ ();
6258 if (ffestc_order_typedecl_ () != FFESTC_orderOK_)
6260 ffestc_local_.decl.is_R426 = 0;
6263 ffestc_labeldef_useless_ ();
6265 ffestc_establish_declstmt_ (type, typet, kind, kindt, len, lent);
6268 /* ffestc_R501_attrib -- type attribute
6270 ffestc_R501_attrib(...);
6272 Verify that R501 type-declaration-stmt attribute
6273 is valid here and implement. */
6276 ffestc_R501_attrib (ffestpAttrib attrib, ffelexToken attribt,
6277 ffestrOther intent_kw UNUSED,
6278 ffesttDimList dims UNUSED)
6280 ffestc_check_attrib_ ();
6285 case FFESTP_attribALLOCATABLE:
6289 case FFESTP_attribDIMENSION:
6290 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
6293 case FFESTP_attribEXTERNAL:
6297 case FFESTP_attribINTENT:
6301 case FFESTP_attribINTRINSIC:
6305 case FFESTP_attribOPTIONAL:
6309 case FFESTP_attribPARAMETER:
6313 case FFESTP_attribPOINTER:
6318 case FFESTP_attribPRIVATE:
6321 case FFESTP_attribPUBLIC:
6325 case FFESTP_attribSAVE:
6326 switch (ffestv_save_state_)
6328 case FFESTV_savestateNONE:
6329 ffestv_save_state_ = FFESTV_savestateSPECIFIC;
6331 = ffewhere_line_use (ffelex_token_where_line (attribt));
6333 = ffewhere_column_use (ffelex_token_where_column (attribt));
6336 case FFESTV_savestateSPECIFIC:
6337 case FFESTV_savestateANY:
6340 case FFESTV_savestateALL:
6341 if (ffe_is_pedantic ())
6343 ffebad_start (FFEBAD_CONFLICTING_SAVES);
6344 ffebad_here (0, ffestv_save_line_, ffestv_save_col_);
6345 ffebad_here (1, ffelex_token_where_line (attribt),
6346 ffelex_token_where_column (attribt));
6349 ffestv_save_state_ = FFESTV_savestateANY;
6353 assert ("unexpected save state" == NULL);
6359 case FFESTP_attribTARGET:
6364 assert ("unexpected attribute" == NULL);
6369 /* ffestc_R501_item -- declared object
6371 ffestc_R501_item(...);
6373 Establish type for a particular object. */
6376 ffestc_R501_item (ffelexToken name, ffebld kind, ffelexToken kindt,
6377 ffesttDimList dims, ffebld len, ffelexToken lent,
6378 ffebld init, ffelexToken initt, bool clist)
6381 ffesymbol sfn; /* FUNCTION symbol. */
6387 bool is_init = (init != NULL) || clist;
6389 bool is_ugly_assumed;
6392 ffestc_check_item_ ();
6393 assert (name != NULL);
6394 assert (ffelex_token_type (name) == FFELEX_typeNAME); /* Not NAMES. */
6395 assert (kind == NULL); /* No way an expression should get here. */
6397 ffestc_establish_declinfo_ (kind, kindt, len, lent);
6399 is_assumed = (ffestc_local_.decl.basic_type == FFEINFO_basictypeCHARACTER)
6400 && (ffestc_local_.decl.size == FFETARGET_charactersizeNONE);
6402 if ((dims != NULL) || is_init)
6403 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
6405 s = ffesymbol_declare_local (name, TRUE);
6406 sa = ffesymbol_attrs (s);
6408 /* First figure out what kind of object this is based solely on the current
6409 object situation (type params, dimension list, and initialization). */
6411 na = FFESYMBOL_attrsTYPE;
6414 na |= FFESYMBOL_attrsANYLEN;
6416 is_ugly_assumed = (ffe_is_ugly_assumed ()
6417 && ((sa & FFESYMBOL_attrsDUMMY)
6418 || (ffesymbol_where (s) == FFEINFO_whereDUMMY)));
6420 nd = ffestt_dimlist_type (dims, is_ugly_assumed);
6423 case FFESTP_dimtypeNONE:
6426 case FFESTP_dimtypeKNOWN:
6427 na |= FFESYMBOL_attrsARRAY;
6430 case FFESTP_dimtypeADJUSTABLE:
6431 na |= FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE;
6434 case FFESTP_dimtypeASSUMED:
6435 na |= FFESYMBOL_attrsARRAY | FFESYMBOL_attrsANYSIZE;
6438 case FFESTP_dimtypeADJUSTABLEASSUMED:
6439 na |= FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE
6440 | FFESYMBOL_attrsANYSIZE;
6444 assert ("unexpected dimtype" == NULL);
6445 na = FFESYMBOL_attrsetNONE;
6449 if (!ffesta_is_entry_valid
6450 && (((na & (FFESYMBOL_attrsANYLEN | FFESYMBOL_attrsARRAY))
6451 == (FFESYMBOL_attrsANYLEN | FFESYMBOL_attrsARRAY))))
6452 na = FFESYMBOL_attrsetNONE;
6456 if (na == FFESYMBOL_attrsetNONE)
6458 else if (na & (FFESYMBOL_attrsANYLEN
6459 | FFESYMBOL_attrsADJUSTABLE
6460 | FFESYMBOL_attrsANYSIZE))
6461 na = FFESYMBOL_attrsetNONE;
6463 na |= FFESYMBOL_attrsINIT;
6466 /* Now figure out what kind of object we've got based on previous
6467 declarations of or references to the object. */
6469 if (na == FFESYMBOL_attrsetNONE)
6471 else if (!ffesymbol_is_specable (s)
6472 && (((ffesymbol_where (s) != FFEINFO_whereCONSTANT)
6473 && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))
6474 || (na & (FFESYMBOL_attrsARRAY | FFESYMBOL_attrsINIT))))
6475 na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef, and can't
6476 dimension/init UNDERSTOODs. */
6477 else if (sa & FFESYMBOL_attrsANY)
6480 || ((sa & (FFESYMBOL_attrsSFARG
6481 | FFESYMBOL_attrsADJUSTS))
6482 && (na & (FFESYMBOL_attrsARRAY
6483 | FFESYMBOL_attrsANYLEN)))
6484 || ((sa & FFESYMBOL_attrsRESULT)
6485 && (na & (FFESYMBOL_attrsARRAY
6486 | FFESYMBOL_attrsINIT)))
6487 || ((sa & (FFESYMBOL_attrsSFUNC
6488 | FFESYMBOL_attrsEXTERNAL
6489 | FFESYMBOL_attrsINTRINSIC
6490 | FFESYMBOL_attrsINIT))
6491 && (na & (FFESYMBOL_attrsARRAY
6492 | FFESYMBOL_attrsANYLEN
6493 | FFESYMBOL_attrsINIT)))
6494 || ((sa & FFESYMBOL_attrsARRAY)
6495 && !ffesta_is_entry_valid
6496 && (na & FFESYMBOL_attrsANYLEN))
6497 || ((sa & (FFESYMBOL_attrsADJUSTABLE
6498 | FFESYMBOL_attrsANYLEN
6499 | FFESYMBOL_attrsANYSIZE
6500 | FFESYMBOL_attrsDUMMY))
6501 && (na & FFESYMBOL_attrsINIT))
6502 || ((sa & (FFESYMBOL_attrsSAVE
6503 | FFESYMBOL_attrsNAMELIST
6504 | FFESYMBOL_attrsCOMMON
6505 | FFESYMBOL_attrsEQUIV))
6506 && (na & (FFESYMBOL_attrsADJUSTABLE
6507 | FFESYMBOL_attrsANYLEN
6508 | FFESYMBOL_attrsANYSIZE))))
6509 na = FFESYMBOL_attrsetNONE;
6510 else if ((ffesymbol_kind (s) == FFEINFO_kindENTITY)
6511 && (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
6512 && (na & FFESYMBOL_attrsANYLEN))
6513 { /* If CHARACTER*(*) FOO after PARAMETER FOO. */
6514 na |= FFESYMBOL_attrsTYPE;
6515 ffestc_local_.decl.size = ffebld_size (ffesymbol_init (s));
6520 /* Now see what we've got for a new object: NONE means a new error cropped
6521 up; ANY means an old error to be ignored; otherwise, everything's ok,
6522 update the object (symbol) and continue on. */
6524 if (na == FFESYMBOL_attrsetNONE)
6526 ffesymbol_error (s, name);
6527 ffestc_parent_ok_ = FALSE;
6529 else if (na & FFESYMBOL_attrsANY)
6530 ffestc_parent_ok_ = FALSE;
6533 ffesymbol_set_attrs (s, na);
6534 if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
6535 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
6536 rank = ffesymbol_rank (s);
6539 ffesymbol_set_dims (s, ffestt_dimlist_as_expr (dims, &rank,
6543 ffesymbol_set_arraysize (s, array_size);
6544 ffesymbol_set_extents (s, extents);
6545 if (!(0 && ffe_is_90 ())
6546 && (ffebld_op (array_size) == FFEBLD_opCONTER)
6547 && (ffebld_constant_integerdefault (ffebld_conter (array_size))
6550 ffebad_start (FFEBAD_ZERO_ARRAY);
6551 ffebad_here (0, ffelex_token_where_line (name),
6552 ffelex_token_where_column (name));
6558 ffesymbol_set_init (s,
6559 ffeexpr_convert (init, initt, name,
6560 ffestc_local_.decl.basic_type,
6561 ffestc_local_.decl.kind_type,
6563 ffestc_local_.decl.size,
6564 FFEEXPR_contextDATA));
6565 ffecom_notify_init_symbol (s);
6566 ffesymbol_update_init (s);
6567 #if FFEGLOBAL_ENABLED
6568 if (ffesymbol_common (s) != NULL)
6569 ffeglobal_init_common (ffesymbol_common (s), initt);
6576 symter = ffebld_new_symter (s, FFEINTRIN_genNONE,
6580 ffebld_set_info (symter,
6581 ffeinfo_new (ffestc_local_.decl.basic_type,
6582 ffestc_local_.decl.kind_type,
6586 ffestc_local_.decl.size));
6587 ffestc_local_.decl.initlist = ffebld_new_item (symter, NULL);
6589 if (ffesymbol_basictype (s) == FFEINFO_basictypeNONE)
6591 ffesymbol_set_info (s,
6592 ffeinfo_new (ffestc_local_.decl.basic_type,
6593 ffestc_local_.decl.kind_type,
6596 ffesymbol_where (s),
6597 ffestc_local_.decl.size));
6598 if ((na & FFESYMBOL_attrsRESULT)
6599 && ((sfn = ffesymbol_funcresult (s)) != NULL))
6601 ffesymbol_set_info (sfn,
6602 ffeinfo_new (ffestc_local_.decl.basic_type,
6603 ffestc_local_.decl.kind_type,
6605 ffesymbol_kind (sfn),
6606 ffesymbol_where (sfn),
6607 ffestc_local_.decl.size));
6608 ffesymbol_signal_unreported (sfn);
6611 else if ((ffestc_local_.decl.basic_type != ffesymbol_basictype (s))
6612 || (ffestc_local_.decl.kind_type != ffesymbol_kindtype (s))
6613 || ((ffestc_local_.decl.basic_type
6614 == FFEINFO_basictypeCHARACTER)
6615 && (ffestc_local_.decl.size != ffesymbol_size (s))))
6616 { /* Explicit type disagrees with established
6618 ffesymbol_error (s, name);
6621 if ((na & FFESYMBOL_attrsADJUSTS)
6622 && ((ffestc_local_.decl.basic_type != FFEINFO_basictypeINTEGER)
6623 || (ffestc_local_.decl.kind_type != FFEINFO_kindtypeINTEGER1)))
6624 ffesymbol_error (s, name);
6626 ffesymbol_signal_unreported (s);
6627 ffestc_parent_ok_ = TRUE;
6631 /* ffestc_R501_itemstartvals -- Start list of values
6633 ffestc_R501_itemstartvals();
6635 Gonna specify values for the object now. */
6638 ffestc_R501_itemstartvals ()
6640 ffestc_check_item_startvals_ ();
6642 if (ffestc_parent_ok_)
6643 ffedata_begin (ffestc_local_.decl.initlist);
6646 /* ffestc_R501_itemvalue -- Source value
6648 ffestc_R501_itemvalue(repeat,repeat_token,value,value_token);
6650 Make sure repeat and value are valid for the object being initialized. */
6653 ffestc_R501_itemvalue (ffebld repeat, ffelexToken repeat_token,
6654 ffebld value, ffelexToken value_token)
6656 ffetargetIntegerDefault rpt;
6658 ffestc_check_item_value_ ();
6660 if (!ffestc_parent_ok_)
6665 else if (ffebld_op (repeat) == FFEBLD_opCONTER)
6666 rpt = ffebld_constant_integerdefault (ffebld_conter (repeat));
6669 ffestc_parent_ok_ = FALSE;
6670 ffedata_end (TRUE, NULL);
6674 if (!(ffestc_parent_ok_ = ffedata_value (rpt, value,
6675 (repeat_token == NULL) ? value_token : repeat_token)))
6676 ffedata_end (TRUE, NULL);
6679 /* ffestc_R501_itemendvals -- End list of values
6681 ffelexToken t; // the SLASH token that ends the list.
6682 ffestc_R501_itemendvals(t);
6684 No more values, might specify more objects now. */
6687 ffestc_R501_itemendvals (ffelexToken t)
6689 ffestc_check_item_endvals_ ();
6691 if (ffestc_parent_ok_)
6692 ffestc_parent_ok_ = ffedata_end (FALSE, t);
6694 if (ffestc_parent_ok_)
6695 ffesymbol_signal_unreported (ffebld_symter (ffebld_head
6696 (ffestc_local_.decl.initlist)));
6699 /* ffestc_R501_finish -- Done
6701 ffestc_R501_finish();
6703 Just wrap up any local activities. */
6706 ffestc_R501_finish ()
6708 ffestc_check_finish_ ();
6711 /* ffestc_R519_start -- INTENT statement list begin
6713 ffestc_R519_start();
6715 Verify that INTENT is valid here, and begin accepting items in the list. */
6719 ffestc_R519_start (ffelexToken intent, ffestrOther intent_kw)
6721 ffestc_check_start_ ();
6722 if (ffestc_order_spec_ () != FFESTC_orderOK_)
6727 ffestc_labeldef_useless_ ();
6729 ffestd_R519_start (intent_kw);
6734 /* ffestc_R519_item -- INTENT statement for name
6736 ffestc_R519_item(name_token);
6738 Make sure name_token identifies a valid object to be INTENTed. */
6741 ffestc_R519_item (ffelexToken name)
6743 ffestc_check_item_ ();
6744 assert (name != NULL);
6748 ffestd_R519_item (name);
6751 /* ffestc_R519_finish -- INTENT statement list complete
6753 ffestc_R519_finish();
6755 Just wrap up any local activities. */
6758 ffestc_R519_finish ()
6760 ffestc_check_finish_ ();
6764 ffestd_R519_finish ();
6767 /* ffestc_R520_start -- OPTIONAL statement list begin
6769 ffestc_R520_start();
6771 Verify that OPTIONAL is valid here, and begin accepting items in the list. */
6774 ffestc_R520_start ()
6776 ffestc_check_start_ ();
6777 if (ffestc_order_spec_ () != FFESTC_orderOK_)
6782 ffestc_labeldef_useless_ ();
6784 ffestd_R520_start ();
6789 /* ffestc_R520_item -- OPTIONAL statement for name
6791 ffestc_R520_item(name_token);
6793 Make sure name_token identifies a valid object to be OPTIONALed. */
6796 ffestc_R520_item (ffelexToken name)
6798 ffestc_check_item_ ();
6799 assert (name != NULL);
6803 ffestd_R520_item (name);
6806 /* ffestc_R520_finish -- OPTIONAL statement list complete
6808 ffestc_R520_finish();
6810 Just wrap up any local activities. */
6813 ffestc_R520_finish ()
6815 ffestc_check_finish_ ();
6819 ffestd_R520_finish ();
6822 /* ffestc_R521A -- PUBLIC statement
6826 Verify that PUBLIC is valid here. */
6831 ffestc_check_simple_ ();
6832 if (ffestc_order_access_ () != FFESTC_orderOK_)
6834 ffestc_labeldef_useless_ ();
6836 switch (ffestv_access_state_)
6838 case FFESTV_accessstateNONE:
6839 ffestv_access_state_ = FFESTV_accessstatePUBLIC;
6841 = ffewhere_line_use (ffelex_token_where_line (ffesta_tokens[0]));
6843 = ffewhere_column_use (ffelex_token_where_column (ffesta_tokens[0]));
6846 case FFESTV_accessstateANY:
6849 case FFESTV_accessstatePUBLIC:
6850 case FFESTV_accessstatePRIVATE:
6851 ffebad_start (FFEBAD_CONFLICTING_ACCESSES);
6852 ffebad_here (0, ffestv_access_line_, ffestv_access_col_);
6853 ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]),
6854 ffelex_token_where_column (ffesta_tokens[0]));
6856 ffestv_access_state_ = FFESTV_accessstateANY;
6860 assert ("unexpected access state" == NULL);
6867 /* ffestc_R521Astart -- PUBLIC statement list begin
6869 ffestc_R521Astart();
6871 Verify that PUBLIC is valid here, and begin accepting items in the list. */
6874 ffestc_R521Astart ()
6876 ffestc_check_start_ ();
6877 if (ffestc_order_access_ () != FFESTC_orderOK_)
6882 ffestc_labeldef_useless_ ();
6884 ffestd_R521Astart ();
6889 /* ffestc_R521Aitem -- PUBLIC statement for name
6891 ffestc_R521Aitem(name_token);
6893 Make sure name_token identifies a valid object to be PUBLICed. */
6896 ffestc_R521Aitem (ffelexToken name)
6898 ffestc_check_item_ ();
6899 assert (name != NULL);
6903 ffestd_R521Aitem (name);
6906 /* ffestc_R521Afinish -- PUBLIC statement list complete
6908 ffestc_R521Afinish();
6910 Just wrap up any local activities. */
6913 ffestc_R521Afinish ()
6915 ffestc_check_finish_ ();
6919 ffestd_R521Afinish ();
6922 /* ffestc_R521B -- PRIVATE statement
6926 Verify that PRIVATE is valid here (outside a derived-type statement). */
6931 ffestc_check_simple_ ();
6932 if (ffestc_order_access_ () != FFESTC_orderOK_)
6934 ffestc_labeldef_useless_ ();
6936 switch (ffestv_access_state_)
6938 case FFESTV_accessstateNONE:
6939 ffestv_access_state_ = FFESTV_accessstatePRIVATE;
6941 = ffewhere_line_use (ffelex_token_where_line (ffesta_tokens[0]));
6943 = ffewhere_column_use (ffelex_token_where_column (ffesta_tokens[0]));
6946 case FFESTV_accessstateANY:
6949 case FFESTV_accessstatePUBLIC:
6950 case FFESTV_accessstatePRIVATE:
6951 ffebad_start (FFEBAD_CONFLICTING_ACCESSES);
6952 ffebad_here (0, ffestv_access_line_, ffestv_access_col_);
6953 ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]),
6954 ffelex_token_where_column (ffesta_tokens[0]));
6956 ffestv_access_state_ = FFESTV_accessstateANY;
6960 assert ("unexpected access state" == NULL);
6967 /* ffestc_R521Bstart -- PRIVATE statement list begin
6969 ffestc_R521Bstart();
6971 Verify that PRIVATE is valid here, and begin accepting items in the list. */
6974 ffestc_R521Bstart ()
6976 ffestc_check_start_ ();
6977 if (ffestc_order_access_ () != FFESTC_orderOK_)
6982 ffestc_labeldef_useless_ ();
6984 ffestd_R521Bstart ();
6989 /* ffestc_R521Bitem -- PRIVATE statement for name
6991 ffestc_R521Bitem(name_token);
6993 Make sure name_token identifies a valid object to be PRIVATEed. */
6996 ffestc_R521Bitem (ffelexToken name)
6998 ffestc_check_item_ ();
6999 assert (name != NULL);
7003 ffestd_R521Bitem (name);
7006 /* ffestc_R521Bfinish -- PRIVATE statement list complete
7008 ffestc_R521Bfinish();
7010 Just wrap up any local activities. */
7013 ffestc_R521Bfinish ()
7015 ffestc_check_finish_ ();
7019 ffestd_R521Bfinish ();
7023 /* ffestc_R522 -- SAVE statement with no list
7027 Verify that SAVE is valid here, and flag everything as SAVEd. */
7032 ffestc_check_simple_ ();
7033 if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
7035 ffestc_labeldef_useless_ ();
7037 switch (ffestv_save_state_)
7039 case FFESTV_savestateNONE:
7040 ffestv_save_state_ = FFESTV_savestateALL;
7042 = ffewhere_line_use (ffelex_token_where_line (ffesta_tokens[0]));
7044 = ffewhere_column_use (ffelex_token_where_column (ffesta_tokens[0]));
7047 case FFESTV_savestateANY:
7050 case FFESTV_savestateSPECIFIC:
7051 case FFESTV_savestateALL:
7052 if (ffe_is_pedantic ())
7054 ffebad_start (FFEBAD_CONFLICTING_SAVES);
7055 ffebad_here (0, ffestv_save_line_, ffestv_save_col_);
7056 ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]),
7057 ffelex_token_where_column (ffesta_tokens[0]));
7060 ffestv_save_state_ = FFESTV_savestateALL;
7064 assert ("unexpected save state" == NULL);
7068 ffe_set_is_saveall (TRUE);
7073 /* ffestc_R522start -- SAVE statement list begin
7077 Verify that SAVE is valid here, and begin accepting items in the list. */
7082 ffestc_check_start_ ();
7083 if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
7088 ffestc_labeldef_useless_ ();
7090 switch (ffestv_save_state_)
7092 case FFESTV_savestateNONE:
7093 ffestv_save_state_ = FFESTV_savestateSPECIFIC;
7095 = ffewhere_line_use (ffelex_token_where_line (ffesta_tokens[0]));
7097 = ffewhere_column_use (ffelex_token_where_column (ffesta_tokens[0]));
7100 case FFESTV_savestateSPECIFIC:
7101 case FFESTV_savestateANY:
7104 case FFESTV_savestateALL:
7105 if (ffe_is_pedantic ())
7107 ffebad_start (FFEBAD_CONFLICTING_SAVES);
7108 ffebad_here (0, ffestv_save_line_, ffestv_save_col_);
7109 ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]),
7110 ffelex_token_where_column (ffesta_tokens[0]));
7113 ffestv_save_state_ = FFESTV_savestateANY;
7117 assert ("unexpected save state" == NULL);
7121 ffestd_R522start ();
7126 /* ffestc_R522item_object -- SAVE statement for object-name
7128 ffestc_R522item_object(name_token);
7130 Make sure name_token identifies a valid object to be SAVEd. */
7133 ffestc_R522item_object (ffelexToken name)
7139 ffestc_check_item_ ();
7140 assert (name != NULL);
7144 s = ffesymbol_declare_local (name, FALSE);
7145 sa = ffesymbol_attrs (s);
7147 /* Figure out what kind of object we've got based on previous declarations
7148 of or references to the object. */
7150 if (!ffesymbol_is_specable (s)
7151 && ((ffesymbol_kind (s) != FFEINFO_kindENTITY)
7152 || (ffesymbol_where (s) != FFEINFO_whereLOCAL)))
7153 na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
7154 else if (sa & FFESYMBOL_attrsANY)
7156 else if (!(sa & ~(FFESYMBOL_attrsARRAY
7157 | FFESYMBOL_attrsEQUIV
7158 | FFESYMBOL_attrsINIT
7159 | FFESYMBOL_attrsNAMELIST
7160 | FFESYMBOL_attrsSFARG
7161 | FFESYMBOL_attrsTYPE)))
7162 na = sa | FFESYMBOL_attrsSAVE;
7164 na = FFESYMBOL_attrsetNONE;
7166 /* Now see what we've got for a new object: NONE means a new error cropped
7167 up; ANY means an old error to be ignored; otherwise, everything's ok,
7168 update the object (symbol) and continue on. */
7170 if (na == FFESYMBOL_attrsetNONE)
7171 ffesymbol_error (s, name);
7172 else if (!(na & FFESYMBOL_attrsANY))
7174 ffesymbol_set_attrs (s, na);
7175 if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
7176 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
7177 ffesymbol_update_save (s);
7178 ffesymbol_signal_unreported (s);
7181 ffestd_R522item_object (name);
7184 /* ffestc_R522item_cblock -- SAVE statement for common-block-name
7186 ffestc_R522item_cblock(name_token);
7188 Make sure name_token identifies a valid common block to be SAVEd. */
7191 ffestc_R522item_cblock (ffelexToken name)
7197 ffestc_check_item_ ();
7198 assert (name != NULL);
7202 s = ffesymbol_declare_cblock (name, ffelex_token_where_line (ffesta_tokens[0]),
7203 ffelex_token_where_column (ffesta_tokens[0]));
7204 sa = ffesymbol_attrs (s);
7206 /* Figure out what kind of object we've got based on previous declarations
7207 of or references to the object. */
7209 if (!ffesymbol_is_specable (s))
7210 na = FFESYMBOL_attrsetNONE;
7211 else if (sa & FFESYMBOL_attrsANY)
7212 na = sa; /* Already have an error here, say nothing. */
7213 else if (!(sa & ~(FFESYMBOL_attrsCBLOCK)))
7214 na = sa | FFESYMBOL_attrsSAVECBLOCK;
7216 na = FFESYMBOL_attrsetNONE;
7218 /* Now see what we've got for a new object: NONE means a new error cropped
7219 up; ANY means an old error to be ignored; otherwise, everything's ok,
7220 update the object (symbol) and continue on. */
7222 if (na == FFESYMBOL_attrsetNONE)
7223 ffesymbol_error (s, (name == NULL) ? ffesta_tokens[0] : name);
7224 else if (!(na & FFESYMBOL_attrsANY))
7226 ffesymbol_set_attrs (s, na);
7227 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
7228 ffesymbol_update_save (s);
7229 ffesymbol_signal_unreported (s);
7232 ffestd_R522item_cblock (name);
7235 /* ffestc_R522finish -- SAVE statement list complete
7237 ffestc_R522finish();
7239 Just wrap up any local activities. */
7242 ffestc_R522finish ()
7244 ffestc_check_finish_ ();
7248 ffestd_R522finish ();
7251 /* ffestc_R524_start -- DIMENSION statement list begin
7253 ffestc_R524_start(bool virtual);
7255 Verify that DIMENSION is valid here, and begin accepting items in the
7259 ffestc_R524_start (bool virtual)
7261 ffestc_check_start_ ();
7262 if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
7267 ffestc_labeldef_useless_ ();
7269 ffestd_R524_start (virtual);
7274 /* ffestc_R524_item -- DIMENSION statement for object-name
7276 ffestc_R524_item(name_token,dim_list);
7278 Make sure name_token identifies a valid object to be DIMENSIONd. */
7281 ffestc_R524_item (ffelexToken name, ffesttDimList dims)
7290 bool is_ugly_assumed;
7292 ffestc_check_item_ ();
7293 assert (name != NULL);
7294 assert (dims != NULL);
7298 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
7300 s = ffesymbol_declare_local (name, FALSE);
7301 sa = ffesymbol_attrs (s);
7303 /* First figure out what kind of object this is based solely on the current
7304 object situation (dimension list). */
7306 is_ugly_assumed = (ffe_is_ugly_assumed ()
7307 && ((sa & FFESYMBOL_attrsDUMMY)
7308 || (ffesymbol_where (s) == FFEINFO_whereDUMMY)));
7310 nd = ffestt_dimlist_type (dims, is_ugly_assumed);
7313 case FFESTP_dimtypeKNOWN:
7314 na = FFESYMBOL_attrsARRAY;
7317 case FFESTP_dimtypeADJUSTABLE:
7318 na = FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE;
7321 case FFESTP_dimtypeASSUMED:
7322 na = FFESYMBOL_attrsARRAY | FFESYMBOL_attrsANYSIZE;
7325 case FFESTP_dimtypeADJUSTABLEASSUMED:
7326 na = FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE
7327 | FFESYMBOL_attrsANYSIZE;
7331 assert ("Unexpected dims type" == NULL);
7332 na = FFESYMBOL_attrsetNONE;
7336 /* Now figure out what kind of object we've got based on previous
7337 declarations of or references to the object. */
7339 if (!ffesymbol_is_specable (s))
7340 na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
7341 else if (sa & FFESYMBOL_attrsANY)
7342 na = FFESYMBOL_attrsANY;
7343 else if (!ffesta_is_entry_valid
7344 && (sa & FFESYMBOL_attrsANYLEN))
7345 na = FFESYMBOL_attrsetNONE;
7346 else if ((sa & FFESYMBOL_attrsARRAY)
7347 || ((sa & (FFESYMBOL_attrsCOMMON
7348 | FFESYMBOL_attrsEQUIV
7349 | FFESYMBOL_attrsNAMELIST
7350 | FFESYMBOL_attrsSAVE))
7351 && (na & (FFESYMBOL_attrsADJUSTABLE
7352 | FFESYMBOL_attrsANYSIZE))))
7353 na = FFESYMBOL_attrsetNONE;
7354 else if (!(sa & ~(FFESYMBOL_attrsADJUSTABLE
7355 | FFESYMBOL_attrsANYLEN
7356 | FFESYMBOL_attrsANYSIZE
7357 | FFESYMBOL_attrsCOMMON
7358 | FFESYMBOL_attrsDUMMY
7359 | FFESYMBOL_attrsEQUIV
7360 | FFESYMBOL_attrsNAMELIST
7361 | FFESYMBOL_attrsSAVE
7362 | FFESYMBOL_attrsTYPE)))
7365 na = FFESYMBOL_attrsetNONE;
7367 /* Now see what we've got for a new object: NONE means a new error cropped
7368 up; ANY means an old error to be ignored; otherwise, everything's ok,
7369 update the object (symbol) and continue on. */
7371 if (na == FFESYMBOL_attrsetNONE)
7372 ffesymbol_error (s, name);
7373 else if (!(na & FFESYMBOL_attrsANY))
7375 ffesymbol_set_attrs (s, na);
7376 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
7377 ffesymbol_set_dims (s, ffestt_dimlist_as_expr (dims, &rank,
7381 ffesymbol_set_arraysize (s, array_size);
7382 ffesymbol_set_extents (s, extents);
7383 if (!(0 && ffe_is_90 ())
7384 && (ffebld_op (array_size) == FFEBLD_opCONTER)
7385 && (ffebld_constant_integerdefault (ffebld_conter (array_size))
7388 ffebad_start (FFEBAD_ZERO_ARRAY);
7389 ffebad_here (0, ffelex_token_where_line (name),
7390 ffelex_token_where_column (name));
7393 ffesymbol_set_info (s,
7394 ffeinfo_new (ffesymbol_basictype (s),
7395 ffesymbol_kindtype (s),
7398 ffesymbol_where (s),
7399 ffesymbol_size (s)));
7402 ffesymbol_signal_unreported (s);
7404 ffestd_R524_item (name, dims);
7407 /* ffestc_R524_finish -- DIMENSION statement list complete
7409 ffestc_R524_finish();
7411 Just wrap up any local activities. */
7414 ffestc_R524_finish ()
7416 ffestc_check_finish_ ();
7420 ffestd_R524_finish ();
7423 /* ffestc_R525_start -- ALLOCATABLE statement list begin
7425 ffestc_R525_start();
7427 Verify that ALLOCATABLE is valid here, and begin accepting items in the
7432 ffestc_R525_start ()
7434 ffestc_check_start_ ();
7435 if (ffestc_order_progspec_ () != FFESTC_orderOK_)
7440 ffestc_labeldef_useless_ ();
7442 ffestd_R525_start ();
7447 /* ffestc_R525_item -- ALLOCATABLE statement for object-name
7449 ffestc_R525_item(name_token,dim_list);
7451 Make sure name_token identifies a valid object to be ALLOCATABLEd. */
7454 ffestc_R525_item (ffelexToken name, ffesttDimList dims)
7456 ffestc_check_item_ ();
7457 assert (name != NULL);
7461 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
7463 ffestd_R525_item (name, dims);
7466 /* ffestc_R525_finish -- ALLOCATABLE statement list complete
7468 ffestc_R525_finish();
7470 Just wrap up any local activities. */
7473 ffestc_R525_finish ()
7475 ffestc_check_finish_ ();
7479 ffestd_R525_finish ();
7482 /* ffestc_R526_start -- POINTER statement list begin
7484 ffestc_R526_start();
7486 Verify that POINTER is valid here, and begin accepting items in the
7490 ffestc_R526_start ()
7492 ffestc_check_start_ ();
7493 if (ffestc_order_progspec_ () != FFESTC_orderOK_)
7498 ffestc_labeldef_useless_ ();
7500 ffestd_R526_start ();
7505 /* ffestc_R526_item -- POINTER statement for object-name
7507 ffestc_R526_item(name_token,dim_list);
7509 Make sure name_token identifies a valid object to be POINTERd. */
7512 ffestc_R526_item (ffelexToken name, ffesttDimList dims)
7514 ffestc_check_item_ ();
7515 assert (name != NULL);
7519 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
7521 ffestd_R526_item (name, dims);
7524 /* ffestc_R526_finish -- POINTER statement list complete
7526 ffestc_R526_finish();
7528 Just wrap up any local activities. */
7531 ffestc_R526_finish ()
7533 ffestc_check_finish_ ();
7537 ffestd_R526_finish ();
7540 /* ffestc_R527_start -- TARGET statement list begin
7542 ffestc_R527_start();
7544 Verify that TARGET is valid here, and begin accepting items in the
7548 ffestc_R527_start ()
7550 ffestc_check_start_ ();
7551 if (ffestc_order_progspec_ () != FFESTC_orderOK_)
7556 ffestc_labeldef_useless_ ();
7558 ffestd_R527_start ();
7563 /* ffestc_R527_item -- TARGET statement for object-name
7565 ffestc_R527_item(name_token,dim_list);
7567 Make sure name_token identifies a valid object to be TARGETd. */
7570 ffestc_R527_item (ffelexToken name, ffesttDimList dims)
7572 ffestc_check_item_ ();
7573 assert (name != NULL);
7577 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
7579 ffestd_R527_item (name, dims);
7582 /* ffestc_R527_finish -- TARGET statement list complete
7584 ffestc_R527_finish();
7586 Just wrap up any local activities. */
7589 ffestc_R527_finish ()
7591 ffestc_check_finish_ ();
7595 ffestd_R527_finish ();
7599 /* ffestc_R528_start -- DATA statement list begin
7601 ffestc_R528_start();
7603 Verify that DATA is valid here, and begin accepting items in the list. */
7606 ffestc_R528_start ()
7610 ffestc_check_start_ ();
7611 if (ffe_is_pedantic_not_90 ())
7612 order = ffestc_order_data77_ ();
7614 order = ffestc_order_data_ ();
7615 if (order != FFESTC_orderOK_)
7620 ffestc_labeldef_useless_ ();
7622 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
7625 ffestc_local_.data.objlist = NULL;
7627 ffestd_R528_start_ ();
7633 /* ffestc_R528_item_object -- DATA statement target object
7635 ffestc_R528_item_object(object,object_token);
7637 Make sure object is valid to be DATAd. */
7640 ffestc_R528_item_object (ffebld expr, ffelexToken expr_token UNUSED)
7642 ffestc_check_item_ ();
7647 if (ffestc_local_.data.objlist == NULL)
7648 ffebld_init_list (&ffestc_local_.data.objlist,
7649 &ffestc_local_.data.list_bottom);
7651 ffebld_append_item (&ffestc_local_.data.list_bottom, expr);
7653 ffestd_R528_item_object_ (expr, expr_token);
7657 /* ffestc_R528_item_startvals -- DATA statement start list of values
7659 ffestc_R528_item_startvals();
7661 No more objects, gonna specify values for the list of objects now. */
7664 ffestc_R528_item_startvals ()
7666 ffestc_check_item_startvals_ ();
7671 assert (ffestc_local_.data.objlist != NULL);
7672 ffebld_end_list (&ffestc_local_.data.list_bottom);
7673 ffedata_begin (ffestc_local_.data.objlist);
7675 ffestd_R528_item_startvals_ ();
7679 /* ffestc_R528_item_value -- DATA statement source value
7681 ffestc_R528_item_value(repeat,repeat_token,value,value_token);
7683 Make sure repeat and value are valid for the objects being initialized. */
7686 ffestc_R528_item_value (ffebld repeat, ffelexToken repeat_token,
7687 ffebld value, ffelexToken value_token)
7689 ffetargetIntegerDefault rpt;
7691 ffestc_check_item_value_ ();
7698 else if (ffebld_op (repeat) == FFEBLD_opCONTER)
7699 rpt = ffebld_constant_integerdefault (ffebld_conter (repeat));
7703 ffedata_end (TRUE, NULL);
7707 if (!(ffestc_ok_ = ffedata_value (rpt, value,
7708 (repeat_token == NULL)
7711 ffedata_end (TRUE, NULL);
7714 ffestd_R528_item_value_ (repeat, value);
7718 /* ffestc_R528_item_endvals -- DATA statement start list of values
7720 ffelexToken t; // the SLASH token that ends the list.
7721 ffestc_R528_item_endvals(t);
7723 No more values, might specify more objects now. */
7726 ffestc_R528_item_endvals (ffelexToken t)
7728 ffestc_check_item_endvals_ ();
7733 ffedata_end (!ffestc_ok_, t);
7734 ffestc_local_.data.objlist = NULL;
7736 ffestd_R528_item_endvals_ (t);
7740 /* ffestc_R528_finish -- DATA statement list complete
7742 ffestc_R528_finish();
7744 Just wrap up any local activities. */
7747 ffestc_R528_finish ()
7749 ffestc_check_finish_ ();
7753 ffestd_R528_finish_ ();
7757 /* ffestc_R537_start -- PARAMETER statement list begin
7759 ffestc_R537_start();
7761 Verify that PARAMETER is valid here, and begin accepting items in the
7765 ffestc_R537_start ()
7767 ffestc_check_start_ ();
7768 if (ffestc_order_parameter_ () != FFESTC_orderOK_)
7773 ffestc_labeldef_useless_ ();
7775 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
7777 ffestd_R537_start ();
7782 /* ffestc_R537_item -- PARAMETER statement assignment
7784 ffestc_R537_item(dest,dest_token,source,source_token);
7786 Make sure the source is a valid source for the destination; make the
7790 ffestc_R537_item (ffebld dest, ffelexToken dest_token, ffebld source,
7791 ffelexToken source_token)
7795 ffestc_check_item_ ();
7799 if ((ffebld_op (dest) == FFEBLD_opANY)
7800 || (ffebld_op (source) == FFEBLD_opANY))
7802 if (ffebld_op (dest) == FFEBLD_opSYMTER)
7804 s = ffebld_symter (dest);
7805 ffesymbol_set_init (s, ffebld_new_any ());
7806 ffebld_set_info (ffesymbol_init (s), ffeinfo_new_any ());
7807 ffesymbol_signal_unreported (s);
7809 ffestd_R537_item (dest, source);
7813 assert (ffebld_op (dest) == FFEBLD_opSYMTER);
7814 assert (ffebld_op (source) == FFEBLD_opCONTER);
7816 s = ffebld_symter (dest);
7817 if ((ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
7818 && (ffesymbol_size (s) == FFETARGET_charactersizeNONE))
7819 { /* Destination has explicit/implicit
7820 CHARACTER*(*) type; set length. */
7821 ffesymbol_set_info (s,
7822 ffeinfo_new (ffesymbol_basictype (s),
7823 ffesymbol_kindtype (s),
7826 ffesymbol_where (s),
7827 ffebld_size (source)));
7828 ffebld_set_info (dest, ffeinfo_use (ffesymbol_info (s)));
7831 source = ffeexpr_convert_expr (source, source_token, dest, dest_token,
7832 FFEEXPR_contextDATA);
7834 ffesymbol_set_init (s, source);
7836 ffesymbol_signal_unreported (s);
7838 ffestd_R537_item (dest, source);
7841 /* ffestc_R537_finish -- PARAMETER statement list complete
7843 ffestc_R537_finish();
7845 Just wrap up any local activities. */
7848 ffestc_R537_finish ()
7850 ffestc_check_finish_ ();
7854 ffestd_R537_finish ();
7857 /* ffestc_R539 -- IMPLICIT NONE statement
7861 Verify that the IMPLICIT NONE statement is ok here and implement. */
7866 ffestc_check_simple_ ();
7867 if (ffestc_order_implicitnone_ () != FFESTC_orderOK_)
7869 ffestc_labeldef_useless_ ();
7876 /* ffestc_R539start -- IMPLICIT statement
7880 Verify that the IMPLICIT statement is ok here and implement. */
7885 ffestc_check_start_ ();
7886 if (ffestc_order_implicit_ () != FFESTC_orderOK_)
7891 ffestc_labeldef_useless_ ();
7893 ffestd_R539start ();
7898 /* ffestc_R539item -- IMPLICIT statement specification (R540)
7900 ffestc_R539item(...);
7902 Verify that the type and letter list are all ok and implement. */
7905 ffestc_R539item (ffestpType type, ffebld kind, ffelexToken kindt,
7906 ffebld len, ffelexToken lent, ffesttImpList letters)
7908 ffestc_check_item_ ();
7912 if ((type == FFESTP_typeCHARACTER) && (len != NULL)
7913 && (ffebld_op (len) == FFEBLD_opSTAR))
7914 { /* Complain and pretend they're CHARACTER
7916 ffebad_start (FFEBAD_IMPLICIT_ADJLEN);
7917 ffebad_here (0, ffelex_token_where_line (lent),
7918 ffelex_token_where_column (lent));
7923 ffestc_establish_declstmt_ (type, ffesta_tokens[0], kind, kindt, len, lent);
7924 ffestc_establish_declinfo_ (NULL, NULL, NULL, NULL);
7926 ffestt_implist_drive (letters, ffestc_establish_impletter_);
7928 ffestd_R539item (type, kind, kindt, len, lent, letters);
7931 /* ffestc_R539finish -- IMPLICIT statement
7933 ffestc_R539finish();
7935 Finish up any local activities. */
7938 ffestc_R539finish ()
7940 ffestc_check_finish_ ();
7944 ffestd_R539finish ();
7947 /* ffestc_R542_start -- NAMELIST statement list begin
7949 ffestc_R542_start();
7951 Verify that NAMELIST is valid here, and begin accepting items in the
7955 ffestc_R542_start ()
7957 ffestc_check_start_ ();
7958 if (ffestc_order_progspec_ () != FFESTC_orderOK_)
7963 ffestc_labeldef_useless_ ();
7965 if (ffe_is_f2c_library ()
7966 && (ffe_case_source () == FFE_caseNONE))
7968 ffebad_start (FFEBAD_NAMELIST_CASE);
7969 ffesta_ffebad_here_current_stmt (0);
7973 ffestd_R542_start ();
7975 ffestc_local_.namelist.symbol = NULL;
7980 /* ffestc_R542_item_nlist -- NAMELIST statement for group-name
7982 ffestc_R542_item_nlist(groupname_token);
7984 Make sure name_token identifies a valid object to be NAMELISTd. */
7987 ffestc_R542_item_nlist (ffelexToken name)
7991 ffestc_check_item_ ();
7992 assert (name != NULL);
7996 if (ffestc_local_.namelist.symbol != NULL)
7997 ffesymbol_signal_unreported (ffestc_local_.namelist.symbol);
7999 s = ffesymbol_declare_local (name, FALSE);
8001 if ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
8002 || ((ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
8003 && (ffesymbol_kind (s) == FFEINFO_kindNAMELIST)))
8005 ffestc_parent_ok_ = TRUE;
8006 if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
8008 ffebld_init_list (ffesymbol_ptr_to_namelist (s),
8009 ffesymbol_ptr_to_listbottom (s));
8010 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
8011 ffesymbol_set_info (s,
8012 ffeinfo_new (FFEINFO_basictypeNONE,
8013 FFEINFO_kindtypeNONE,
8015 FFEINFO_kindNAMELIST,
8017 FFETARGET_charactersizeNONE));
8022 if (ffesymbol_kind (s) != FFEINFO_kindANY)
8023 ffesymbol_error (s, name);
8024 ffestc_parent_ok_ = FALSE;
8027 ffestc_local_.namelist.symbol = s;
8029 ffestd_R542_item_nlist (name);
8032 /* ffestc_R542_item_nitem -- NAMELIST statement for variable-name
8034 ffestc_R542_item_nitem(name_token);
8036 Make sure name_token identifies a valid object to be NAMELISTd. */
8039 ffestc_R542_item_nitem (ffelexToken name)
8046 ffestc_check_item_ ();
8047 assert (name != NULL);
8051 s = ffesymbol_declare_local (name, FALSE);
8052 sa = ffesymbol_attrs (s);
8054 /* Figure out what kind of object we've got based on previous declarations
8055 of or references to the object. */
8057 if (!ffesymbol_is_specable (s)
8058 && ((ffesymbol_kind (s) != FFEINFO_kindENTITY)
8059 || ((ffesymbol_where (s) != FFEINFO_whereLOCAL)
8060 && (ffesymbol_where (s) != FFEINFO_whereCOMMON))))
8061 na = FFESYMBOL_attrsetNONE;
8062 else if (sa & FFESYMBOL_attrsANY)
8063 na = FFESYMBOL_attrsANY;
8064 else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
8065 | FFESYMBOL_attrsARRAY
8066 | FFESYMBOL_attrsCOMMON
8067 | FFESYMBOL_attrsEQUIV
8068 | FFESYMBOL_attrsINIT
8069 | FFESYMBOL_attrsNAMELIST
8070 | FFESYMBOL_attrsSAVE
8071 | FFESYMBOL_attrsSFARG
8072 | FFESYMBOL_attrsTYPE)))
8073 na = sa | FFESYMBOL_attrsNAMELIST;
8075 na = FFESYMBOL_attrsetNONE;
8077 /* Now see what we've got for a new object: NONE means a new error cropped
8078 up; ANY means an old error to be ignored; otherwise, everything's ok,
8079 update the object (symbol) and continue on. */
8081 if (na == FFESYMBOL_attrsetNONE)
8082 ffesymbol_error (s, name);
8083 else if (!(na & FFESYMBOL_attrsANY))
8085 ffesymbol_set_attrs (s, na);
8086 if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
8087 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
8088 ffesymbol_set_namelisted (s, TRUE);
8089 ffesymbol_signal_unreported (s);
8090 #if 0 /* No need to establish type yet! */
8091 if (!ffeimplic_establish_symbol (s))
8092 ffesymbol_error (s, name);
8096 if (ffestc_parent_ok_)
8098 e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
8101 ffeinfo_new (FFEINFO_basictypeNONE,
8102 FFEINFO_kindtypeNONE, 0,
8105 FFETARGET_charactersizeNONE));
8107 (ffesymbol_ptr_to_listbottom (ffestc_local_.namelist.symbol), e);
8110 ffestd_R542_item_nitem (name);
8113 /* ffestc_R542_finish -- NAMELIST statement list complete
8115 ffestc_R542_finish();
8117 Just wrap up any local activities. */
8120 ffestc_R542_finish ()
8122 ffestc_check_finish_ ();
8126 ffesymbol_signal_unreported (ffestc_local_.namelist.symbol);
8128 ffestd_R542_finish ();
8131 /* ffestc_R544_start -- EQUIVALENCE statement list begin
8133 ffestc_R544_start();
8135 Verify that EQUIVALENCE is valid here, and begin accepting items in the
8139 ffestc_R544_start ()
8141 ffestc_check_start_ ();
8142 if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
8147 ffestc_labeldef_useless_ ();
8149 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
8154 /* ffestc_R544_item -- EQUIVALENCE statement assignment
8156 ffestc_R544_item(exprlist);
8158 Make sure the equivalence is valid, then implement it. */
8161 ffestc_R544_item (ffesttExprList exprlist)
8163 ffestc_check_item_ ();
8167 /* First we go through the list and come up with one ffeequiv object that
8168 will describe all items in the list. When an ffeequiv object is first
8169 found, it is used (else we create one as a "local equiv" for the time
8170 being). If subsequent ffeequiv objects are found, they are merged with
8171 the first so we end up with one. However, if more than one COMMON
8172 variable is involved, then an error condition occurs. */
8174 ffestc_local_.equiv.ok = TRUE;
8175 ffestc_local_.equiv.t = NULL; /* No token yet. */
8176 ffestc_local_.equiv.eq = NULL;/* No equiv yet. */
8177 ffestc_local_.equiv.save = FALSE; /* No SAVEd variables yet. */
8179 ffebld_init_list (&ffestc_local_.equiv.list, &ffestc_local_.equiv.bottom);
8180 ffestt_exprlist_drive (exprlist, ffestc_R544_equiv_); /* Get one equiv. */
8181 ffebld_end_list (&ffestc_local_.equiv.bottom);
8183 if (!ffestc_local_.equiv.ok)
8184 return; /* Something went wrong, stop bothering with
8187 if (ffestc_local_.equiv.eq == NULL)
8188 ffestc_local_.equiv.eq = ffeequiv_new (); /* Make local equivalence. */
8190 /* Append this list of equivalences to list of such lists for this
8193 ffeequiv_add (ffestc_local_.equiv.eq, ffestc_local_.equiv.list,
8194 ffestc_local_.equiv.t);
8195 if (ffestc_local_.equiv.save)
8196 ffeequiv_update_save (ffestc_local_.equiv.eq);
8199 /* ffestc_R544_equiv_ -- EQUIVALENCE statement handler for item in list
8203 ffestc_R544_equiv_(expr,t);
8205 Record information, if any, on symbol in expr; if symbol has equivalence
8206 object already, merge with outstanding object if present or make it
8207 the outstanding object. */
8210 ffestc_R544_equiv_ (ffebld expr, ffelexToken t)
8214 if (!ffestc_local_.equiv.ok)
8217 if (ffestc_local_.equiv.t == NULL)
8218 ffestc_local_.equiv.t = t;
8220 switch (ffebld_op (expr))
8223 return; /* Don't put this on the list. */
8225 case FFEBLD_opSYMTER:
8226 case FFEBLD_opARRAYREF:
8227 case FFEBLD_opSUBSTR:
8228 break; /* All of these are ok. */
8231 assert ("ffestc_R544_equiv_ bad op" == NULL);
8235 ffebld_append_item (&ffestc_local_.equiv.bottom, expr);
8237 s = ffeequiv_symbol (expr);
8239 /* See if symbol has an equivalence object already. */
8241 if (ffesymbol_equiv (s) != NULL)
8243 if (ffestc_local_.equiv.eq == NULL)
8244 ffestc_local_.equiv.eq = ffesymbol_equiv (s); /* New equiv obj. */
8245 else if (ffestc_local_.equiv.eq != ffesymbol_equiv (s))
8247 ffestc_local_.equiv.eq = ffeequiv_merge (ffesymbol_equiv (s),
8248 ffestc_local_.equiv.eq,
8250 if (ffestc_local_.equiv.eq == NULL)
8251 ffestc_local_.equiv.ok = FALSE; /* Couldn't merge. */
8255 if (ffesymbol_is_save (s))
8256 ffestc_local_.equiv.save = TRUE;
8259 /* ffestc_R544_finish -- EQUIVALENCE statement list complete
8261 ffestc_R544_finish();
8263 Just wrap up any local activities. */
8266 ffestc_R544_finish ()
8268 ffestc_check_finish_ ();
8271 /* ffestc_R547_start -- COMMON statement list begin
8273 ffestc_R547_start();
8275 Verify that COMMON is valid here, and begin accepting items in the list. */
8278 ffestc_R547_start ()
8280 ffestc_check_start_ ();
8281 if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
8286 ffestc_labeldef_useless_ ();
8288 ffestc_local_.common.symbol = NULL; /* Blank common is the default. */
8289 ffestc_parent_ok_ = TRUE;
8291 ffestd_R547_start ();
8296 /* ffestc_R547_item_object -- COMMON statement for object-name
8298 ffestc_R547_item_object(name_token,dim_list);
8300 Make sure name_token identifies a valid object to be COMMONd. */
8303 ffestc_R547_item_object (ffelexToken name, ffesttDimList dims)
8313 bool is_ugly_assumed;
8315 if (ffestc_parent_ok_ && (ffestc_local_.common.symbol == NULL))
8316 ffestc_R547_item_cblock (NULL); /* As if "COMMON [//] ...". */
8318 ffestc_check_item_ ();
8319 assert (name != NULL);
8324 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
8326 s = ffesymbol_declare_local (name, FALSE);
8327 sa = ffesymbol_attrs (s);
8329 /* First figure out what kind of object this is based solely on the current
8330 object situation (dimension list). */
8332 is_ugly_assumed = (ffe_is_ugly_assumed ()
8333 && ((sa & FFESYMBOL_attrsDUMMY)
8334 || (ffesymbol_where (s) == FFEINFO_whereDUMMY)));
8336 nd = ffestt_dimlist_type (dims, is_ugly_assumed);
8339 case FFESTP_dimtypeNONE:
8340 na = FFESYMBOL_attrsCOMMON;
8343 case FFESTP_dimtypeKNOWN:
8344 na = FFESYMBOL_attrsCOMMON | FFESYMBOL_attrsARRAY;
8348 na = FFESYMBOL_attrsetNONE;
8352 /* Figure out what kind of object we've got based on previous declarations
8353 of or references to the object. */
8355 if (na == FFESYMBOL_attrsetNONE)
8357 else if (!ffesymbol_is_specable (s))
8358 na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
8359 else if (sa & FFESYMBOL_attrsANY)
8360 na = FFESYMBOL_attrsANY;
8361 else if ((sa & (FFESYMBOL_attrsADJUSTS
8362 | FFESYMBOL_attrsARRAY
8363 | FFESYMBOL_attrsINIT
8364 | FFESYMBOL_attrsSFARG))
8365 && (na & FFESYMBOL_attrsARRAY))
8366 na = FFESYMBOL_attrsetNONE;
8367 else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
8368 | FFESYMBOL_attrsARRAY
8369 | FFESYMBOL_attrsEQUIV
8370 | FFESYMBOL_attrsINIT
8371 | FFESYMBOL_attrsNAMELIST
8372 | FFESYMBOL_attrsSFARG
8373 | FFESYMBOL_attrsTYPE)))
8376 na = FFESYMBOL_attrsetNONE;
8378 /* Now see what we've got for a new object: NONE means a new error cropped
8379 up; ANY means an old error to be ignored; otherwise, everything's ok,
8380 update the object (symbol) and continue on. */
8382 if (na == FFESYMBOL_attrsetNONE)
8383 ffesymbol_error (s, name);
8384 else if ((ffesymbol_equiv (s) != NULL)
8385 && (ffeequiv_common (ffesymbol_equiv (s)) != NULL)
8386 && (ffeequiv_common (ffesymbol_equiv (s))
8387 != ffestc_local_.common.symbol))
8389 /* Oops, just COMMONed a symbol to a different area (via equiv). */
8390 ffebad_start (FFEBAD_EQUIV_COMMON);
8391 ffebad_here (0, ffelex_token_where_line (name),
8392 ffelex_token_where_column (name));
8393 ffebad_string (ffesymbol_text (ffestc_local_.common.symbol));
8394 ffebad_string (ffesymbol_text (ffeequiv_common (ffesymbol_equiv (s))));
8396 ffesymbol_set_attr (s, na | FFESYMBOL_attrANY);
8397 ffesymbol_set_info (s, ffeinfo_new_any ());
8398 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
8399 ffesymbol_signal_unreported (s);
8401 else if (!(na & FFESYMBOL_attrsANY))
8403 ffesymbol_set_attrs (s, na);
8404 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
8405 ffesymbol_set_common (s, ffestc_local_.common.symbol);
8406 #if FFEGLOBAL_ENABLED
8407 if (ffesymbol_is_init (s))
8408 ffeglobal_init_common (ffestc_local_.common.symbol, name);
8410 if (ffesymbol_is_save (ffestc_local_.common.symbol))
8411 ffesymbol_update_save (s);
8412 if (ffesymbol_equiv (s) != NULL)
8413 { /* Is this newly COMMONed symbol involved in
8415 if (ffeequiv_common (ffesymbol_equiv (s)) == NULL)
8416 ffeequiv_set_common (ffesymbol_equiv (s), /* Yes, tell equiv obj. */
8417 ffestc_local_.common.symbol);
8418 #if FFEGLOBAL_ENABLED
8419 if (ffeequiv_is_init (ffesymbol_equiv (s)))
8420 ffeglobal_init_common (ffestc_local_.common.symbol, name);
8422 if (ffesymbol_is_save (ffestc_local_.common.symbol))
8423 ffeequiv_update_save (ffesymbol_equiv (s));
8427 ffesymbol_set_dims (s, ffestt_dimlist_as_expr (dims, &rank,
8431 ffesymbol_set_arraysize (s, array_size);
8432 ffesymbol_set_extents (s, extents);
8433 if (!(0 && ffe_is_90 ())
8434 && (ffebld_op (array_size) == FFEBLD_opCONTER)
8435 && (ffebld_constant_integerdefault (ffebld_conter (array_size))
8438 ffebad_start (FFEBAD_ZERO_ARRAY);
8439 ffebad_here (0, ffelex_token_where_line (name),
8440 ffelex_token_where_column (name));
8443 ffesymbol_set_info (s,
8444 ffeinfo_new (ffesymbol_basictype (s),
8445 ffesymbol_kindtype (s),
8448 ffesymbol_where (s),
8449 ffesymbol_size (s)));
8451 ffesymbol_signal_unreported (s);
8454 if (ffestc_parent_ok_)
8456 e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
8459 ffeinfo_new (FFEINFO_basictypeNONE,
8460 FFEINFO_kindtypeNONE,
8464 FFETARGET_charactersizeNONE));
8466 (ffesymbol_ptr_to_listbottom (ffestc_local_.common.symbol), e);
8469 ffestd_R547_item_object (name, dims);
8472 /* ffestc_R547_item_cblock -- COMMON statement for common-block-name
8474 ffestc_R547_item_cblock(name_token);
8476 Make sure name_token identifies a valid common block to be COMMONd. */
8479 ffestc_R547_item_cblock (ffelexToken name)
8485 ffestc_check_item_ ();
8489 if (ffestc_local_.common.symbol != NULL)
8490 ffesymbol_signal_unreported (ffestc_local_.common.symbol);
8492 s = ffesymbol_declare_cblock (name,
8493 ffelex_token_where_line (ffesta_tokens[0]),
8494 ffelex_token_where_column (ffesta_tokens[0]));
8495 sa = ffesymbol_attrs (s);
8497 /* Figure out what kind of object we've got based on previous declarations
8498 of or references to the object. */
8500 if (!ffesymbol_is_specable (s))
8501 na = FFESYMBOL_attrsetNONE;
8502 else if (sa & FFESYMBOL_attrsANY)
8503 na = FFESYMBOL_attrsANY; /* Already have an error here, say nothing. */
8504 else if (!(sa & ~(FFESYMBOL_attrsCBLOCK
8505 | FFESYMBOL_attrsSAVECBLOCK)))
8507 if (!(sa & FFESYMBOL_attrsCBLOCK))
8508 ffebld_init_list (ffesymbol_ptr_to_commonlist (s),
8509 ffesymbol_ptr_to_listbottom (s));
8510 na = sa | FFESYMBOL_attrsCBLOCK;
8513 na = FFESYMBOL_attrsetNONE;
8515 /* Now see what we've got for a new object: NONE means a new error cropped
8516 up; ANY means an old error to be ignored; otherwise, everything's ok,
8517 update the object (symbol) and continue on. */
8519 if (na == FFESYMBOL_attrsetNONE)
8521 ffesymbol_error (s, name == NULL ? ffesta_tokens[0] : name);
8522 ffestc_parent_ok_ = FALSE;
8524 else if (na & FFESYMBOL_attrsANY)
8525 ffestc_parent_ok_ = FALSE;
8528 ffesymbol_set_attrs (s, na);
8529 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
8531 ffesymbol_update_save (s);
8532 ffestc_parent_ok_ = TRUE;
8535 ffestc_local_.common.symbol = s;
8537 ffestd_R547_item_cblock (name);
8540 /* ffestc_R547_finish -- COMMON statement list complete
8542 ffestc_R547_finish();
8544 Just wrap up any local activities. */
8547 ffestc_R547_finish ()
8549 ffestc_check_finish_ ();
8553 if (ffestc_local_.common.symbol != NULL)
8554 ffesymbol_signal_unreported (ffestc_local_.common.symbol);
8556 ffestd_R547_finish ();
8559 /* ffestc_R620 -- ALLOCATE statement
8561 ffestc_R620(exprlist,stat,stat_token);
8563 Make sure the expression list is valid, then implement it. */
8567 ffestc_R620 (ffesttExprList exprlist, ffebld stat, ffelexToken stat_token)
8569 ffestc_check_simple_ ();
8570 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
8572 ffestc_labeldef_branch_begin_ ();
8574 ffestd_R620 (exprlist, stat);
8576 if (ffestc_shriek_after1_ != NULL)
8577 (*ffestc_shriek_after1_) (TRUE);
8578 ffestc_labeldef_branch_end_ ();
8581 /* ffestc_R624 -- NULLIFY statement
8583 ffestc_R624(pointer_name_list);
8585 Make sure pointer_name_list identifies valid pointers for a NULLIFY. */
8588 ffestc_R624 (ffesttExprList pointers)
8590 ffestc_check_simple_ ();
8591 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
8593 ffestc_labeldef_branch_begin_ ();
8595 ffestd_R624 (pointers);
8597 if (ffestc_shriek_after1_ != NULL)
8598 (*ffestc_shriek_after1_) (TRUE);
8599 ffestc_labeldef_branch_end_ ();
8602 /* ffestc_R625 -- DEALLOCATE statement
8604 ffestc_R625(exprlist,stat,stat_token);
8606 Make sure the equivalence is valid, then implement it. */
8609 ffestc_R625 (ffesttExprList exprlist, ffebld stat, ffelexToken stat_token)
8611 ffestc_check_simple_ ();
8612 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
8614 ffestc_labeldef_branch_begin_ ();
8616 ffestd_R625 (exprlist, stat);
8618 if (ffestc_shriek_after1_ != NULL)
8619 (*ffestc_shriek_after1_) (TRUE);
8620 ffestc_labeldef_branch_end_ ();
8624 /* ffestc_let -- R1213 or R737
8628 Verify that R1213 defined-assignment or R737 assignment-stmt are
8629 valid here, figure out which one, and implement. */
8633 ffestc_let (ffebld dest, ffebld source, ffelexToken source_token)
8635 ffestc_R737 (dest, source, source_token);
8639 /* ffestc_R737 -- Assignment statement
8641 ffestc_R737(dest_expr,source_expr,source_token);
8643 Make sure the assignment is valid. */
8646 ffestc_R737 (ffebld dest, ffebld source, ffelexToken source_token)
8648 ffestc_check_simple_ ();
8650 switch (ffestw_state (ffestw_stack_top ()))
8653 case FFESTV_stateWHERE:
8654 case FFESTV_stateWHERETHEN:
8655 if (ffestc_order_actionwhere_ () != FFESTC_orderOK_)
8657 ffestc_labeldef_useless_ ();
8659 ffestd_R737B (dest, source);
8661 if (ffestc_shriek_after1_ != NULL)
8662 (*ffestc_shriek_after1_) (TRUE);
8670 if (ffestc_order_actionwhere_ () != FFESTC_orderOK_)
8672 ffestc_labeldef_branch_begin_ ();
8674 source = ffeexpr_convert_expr (source, source_token, dest, ffesta_tokens[0],
8675 FFEEXPR_contextLET);
8677 ffestd_R737A (dest, source);
8679 if (ffestc_shriek_after1_ != NULL)
8680 (*ffestc_shriek_after1_) (TRUE);
8681 ffestc_labeldef_branch_end_ ();
8684 /* ffestc_R738 -- Pointer assignment statement
8686 ffestc_R738(dest_expr,source_expr,source_token);
8688 Make sure the assignment is valid. */
8692 ffestc_R738 (ffebld dest, ffebld source, ffelexToken source_token)
8694 ffestc_check_simple_ ();
8695 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
8697 ffestc_labeldef_branch_begin_ ();
8699 ffestd_R738 (dest, source);
8701 if (ffestc_shriek_after1_ != NULL)
8702 (*ffestc_shriek_after1_) (TRUE);
8703 ffestc_labeldef_branch_end_ ();
8706 /* ffestc_R740 -- WHERE statement
8708 ffestc_R740(expr,expr_token);
8710 Make sure statement is valid here; implement. */
8713 ffestc_R740 (ffebld expr, ffelexToken expr_token)
8717 ffestc_check_simple_ ();
8718 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
8720 ffestc_labeldef_branch_begin_ ();
8722 b = ffestw_update (ffestw_push (NULL));
8723 ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b)));
8724 ffestw_set_state (b, FFESTV_stateWHERE);
8725 ffestw_set_blocknum (b, ffestc_blocknum_++);
8726 ffestw_set_shriek (b, ffestc_shriek_where_lost_);
8730 /* Leave label finishing to next statement. */
8734 /* ffestc_R742 -- WHERE-construct statement
8736 ffestc_R742(expr,expr_token);
8738 Make sure statement is valid here; implement. */
8741 ffestc_R742 (ffebld expr, ffelexToken expr_token)
8745 ffestc_check_simple_ ();
8746 if (ffestc_order_exec_ () != FFESTC_orderOK_)
8748 ffestc_labeldef_notloop_probably_this_wont_work_ ();
8750 b = ffestw_update (ffestw_push (NULL));
8751 ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b)));
8752 ffestw_set_state (b, FFESTV_stateWHERETHEN);
8753 ffestw_set_blocknum (b, ffestc_blocknum_++);
8754 ffestw_set_shriek (b, ffestc_shriek_wherethen_);
8755 ffestw_set_substate (b, 0); /* Haven't seen ELSEWHERE yet. */
8760 /* ffestc_R744 -- ELSE WHERE statement
8764 Make sure ffestc_kind_ identifies a WHERE block.
8765 Implement the ELSE of the current WHERE block. */
8770 ffestc_check_simple_ ();
8771 if (ffestc_order_where_ () != FFESTC_orderOK_)
8773 ffestc_labeldef_useless_ ();
8775 if (ffestw_substate (ffestw_stack_top ()) != 0)
8777 ffebad_start (FFEBAD_SECOND_ELSE_WHERE);
8778 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
8779 ffelex_token_where_column (ffesta_tokens[0]));
8780 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
8784 ffestw_set_substate (ffestw_stack_top (), 1); /* Saw ELSEWHERE. */
8789 /* ffestc_R745 -- END WHERE statement
8793 Make sure ffestc_kind_ identifies a WHERE block.
8794 Implement the end of the current WHERE block. */
8799 ffestc_check_simple_ ();
8800 if (ffestc_order_where_ () != FFESTC_orderOK_)
8802 ffestc_labeldef_useless_ ();
8804 ffestc_shriek_wherethen_ (TRUE);
8808 /* ffestc_R803 -- Block IF (IF-THEN) statement
8810 ffestc_R803(construct_name,expr,expr_token);
8812 Make sure statement is valid here; implement. */
8815 ffestc_R803 (ffelexToken construct_name, ffebld expr,
8816 ffelexToken expr_token UNUSED)
8821 ffestc_check_simple_ ();
8822 if (ffestc_order_exec_ () != FFESTC_orderOK_)
8824 ffestc_labeldef_notloop_ ();
8826 b = ffestw_update (ffestw_push (NULL));
8827 ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b)));
8828 ffestw_set_state (b, FFESTV_stateIFTHEN);
8829 ffestw_set_blocknum (b, ffestc_blocknum_++);
8830 ffestw_set_shriek (b, ffestc_shriek_ifthen_);
8831 ffestw_set_substate (b, 0); /* Haven't seen ELSE yet. */
8833 if (construct_name == NULL)
8834 ffestw_set_name (b, NULL);
8837 ffestw_set_name (b, ffelex_token_use (construct_name));
8839 s = ffesymbol_declare_local (construct_name, FALSE);
8841 if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
8843 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
8844 ffesymbol_set_info (s,
8845 ffeinfo_new (FFEINFO_basictypeNONE,
8846 FFEINFO_kindtypeNONE,
8848 FFEINFO_kindCONSTRUCT,
8850 FFETARGET_charactersizeNONE));
8851 s = ffecom_sym_learned (s);
8852 ffesymbol_signal_unreported (s);
8855 ffesymbol_error (s, construct_name);
8858 ffestd_R803 (construct_name, expr);
8861 /* ffestc_R804 -- ELSE IF statement
8863 ffestc_R804(expr,expr_token,name_token);
8865 Make sure ffestc_kind_ identifies an IF block. If not
8866 NULL, make sure name_token gives the correct name. Implement the else
8870 ffestc_R804 (ffebld expr, ffelexToken expr_token UNUSED,
8873 ffestc_check_simple_ ();
8874 if (ffestc_order_ifthen_ () != FFESTC_orderOK_)
8876 ffestc_labeldef_useless_ ();
8880 if (ffestw_name (ffestw_stack_top ()) == NULL)
8882 ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
8883 ffebad_here (0, ffelex_token_where_line (name),
8884 ffelex_token_where_column (name));
8885 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
8888 else if (ffelex_token_strcmp (name,
8889 ffestw_name (ffestw_stack_top ()))
8892 ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
8893 ffebad_here (0, ffelex_token_where_line (name),
8894 ffelex_token_where_column (name));
8895 ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
8896 ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
8901 if (ffestw_substate (ffestw_stack_top ()) != 0)
8903 ffebad_start (FFEBAD_AFTER_ELSE);
8904 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
8905 ffelex_token_where_column (ffesta_tokens[0]));
8906 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
8908 return; /* Don't upset back end with ELSEIF
8912 ffestd_R804 (expr, name);
8915 /* ffestc_R805 -- ELSE statement
8917 ffestc_R805(name_token);
8919 Make sure ffestc_kind_ identifies an IF block. If not
8920 NULL, make sure name_token gives the correct name. Implement the ELSE
8924 ffestc_R805 (ffelexToken name)
8926 ffestc_check_simple_ ();
8927 if (ffestc_order_ifthen_ () != FFESTC_orderOK_)
8929 ffestc_labeldef_useless_ ();
8933 if (ffestw_name (ffestw_stack_top ()) == NULL)
8935 ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
8936 ffebad_here (0, ffelex_token_where_line (name),
8937 ffelex_token_where_column (name));
8938 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
8941 else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)
8943 ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
8944 ffebad_here (0, ffelex_token_where_line (name),
8945 ffelex_token_where_column (name));
8946 ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
8947 ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
8952 if (ffestw_substate (ffestw_stack_top ()) != 0)
8954 ffebad_start (FFEBAD_AFTER_ELSE);
8955 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
8956 ffelex_token_where_column (ffesta_tokens[0]));
8957 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
8959 return; /* Tell back end about only one ELSE. */
8962 ffestw_set_substate (ffestw_stack_top (), 1); /* Saw ELSE. */
8967 /* ffestc_R806 -- END IF statement
8969 ffestc_R806(name_token);
8971 Make sure ffestc_kind_ identifies an IF block. If not
8972 NULL, make sure name_token gives the correct name. Implement the end
8976 ffestc_R806 (ffelexToken name)
8978 ffestc_check_simple_ ();
8979 if (ffestc_order_ifthen_ () != FFESTC_orderOK_)
8981 ffestc_labeldef_endif_ ();
8985 if (ffestw_name (ffestw_stack_top ()) != NULL)
8987 ffebad_start (FFEBAD_CONSTRUCT_NAMED);
8988 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
8989 ffelex_token_where_column (ffesta_tokens[0]));
8990 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
8996 if (ffestw_name (ffestw_stack_top ()) == NULL)
8998 ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
8999 ffebad_here (0, ffelex_token_where_line (name),
9000 ffelex_token_where_column (name));
9001 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
9004 else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)
9006 ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
9007 ffebad_here (0, ffelex_token_where_line (name),
9008 ffelex_token_where_column (name));
9009 ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
9010 ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
9015 ffestc_shriek_ifthen_ (TRUE);
9018 /* ffestc_R807 -- Logical IF statement
9020 ffestc_R807(expr,expr_token);
9022 Make sure statement is valid here; implement. */
9025 ffestc_R807 (ffebld expr, ffelexToken expr_token UNUSED)
9029 ffestc_check_simple_ ();
9030 if (ffestc_order_action_ () != FFESTC_orderOK_)
9032 ffestc_labeldef_branch_begin_ ();
9034 b = ffestw_update (ffestw_push (NULL));
9035 ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b)));
9036 ffestw_set_state (b, FFESTV_stateIF);
9037 ffestw_set_blocknum (b, ffestc_blocknum_++);
9038 ffestw_set_shriek (b, ffestc_shriek_if_lost_);
9042 /* Do the label finishing in the next statement. */
9046 /* ffestc_R809 -- SELECT CASE statement
9048 ffestc_R809(construct_name,expr,expr_token);
9050 Make sure statement is valid here; implement. */
9053 ffestc_R809 (ffelexToken construct_name, ffebld expr, ffelexToken expr_token)
9060 ffestc_check_simple_ ();
9061 if (ffestc_order_exec_ () != FFESTC_orderOK_)
9063 ffestc_labeldef_notloop_ ();
9065 b = ffestw_update (ffestw_push (NULL));
9066 ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b)));
9067 ffestw_set_state (b, FFESTV_stateSELECT0);
9068 ffestw_set_blocknum (b, ffestc_blocknum_++);
9069 ffestw_set_shriek (b, ffestc_shriek_select_);
9070 ffestw_set_substate (b, 0); /* Haven't seen CASE DEFAULT yet. */
9072 /* Init block to manage CASE list. */
9074 pool = malloc_pool_new ("Select", ffe_pool_any_unit (), 1024);
9075 s = (ffestwSelect) malloc_new_kp (pool, "Select", sizeof (*s));
9076 s->first_rel = (ffestwCase) &s->first_rel;
9077 s->last_rel = (ffestwCase) &s->first_rel;
9078 s->first_stmt = (ffestwCase) &s->first_rel;
9079 s->last_stmt = (ffestwCase) &s->first_rel;
9082 s->t = ffelex_token_use (expr_token);
9083 s->type = ffeinfo_basictype (ffebld_info (expr));
9084 s->kindtype = ffeinfo_kindtype (ffebld_info (expr));
9085 ffestw_set_select (b, s);
9087 if (construct_name == NULL)
9088 ffestw_set_name (b, NULL);
9091 ffestw_set_name (b, ffelex_token_use (construct_name));
9093 sym = ffesymbol_declare_local (construct_name, FALSE);
9095 if (ffesymbol_state (sym) == FFESYMBOL_stateNONE)
9097 ffesymbol_set_state (sym, FFESYMBOL_stateUNDERSTOOD);
9098 ffesymbol_set_info (sym,
9099 ffeinfo_new (FFEINFO_basictypeNONE,
9100 FFEINFO_kindtypeNONE, 0,
9101 FFEINFO_kindCONSTRUCT,
9103 FFETARGET_charactersizeNONE));
9104 sym = ffecom_sym_learned (sym);
9105 ffesymbol_signal_unreported (sym);
9108 ffesymbol_error (sym, construct_name);
9111 ffestd_R809 (construct_name, expr);
9114 /* ffestc_R810 -- CASE statement
9116 ffestc_R810(case_value_range_list,name);
9118 If case_value_range_list is NULL, it's CASE DEFAULT. name is the case-
9119 construct-name. Make sure no more than one CASE DEFAULT is present for
9120 a given case-construct and that there aren't any overlapping ranges or
9121 duplicate case values. */
9124 ffestc_R810 (ffesttCaseList cases, ffelexToken name)
9126 ffesttCaseList caseobj;
9129 ffebldConstant expr1c, expr2c;
9131 ffestc_check_simple_ ();
9132 if (ffestc_order_selectcase_ () != FFESTC_orderOK_)
9134 ffestc_labeldef_useless_ ();
9136 s = ffestw_select (ffestw_stack_top ());
9138 if (ffestw_state (ffestw_stack_top ()) == FFESTV_stateSELECT0)
9140 #if 0 /* Not sure we want to have msgs point here
9141 instead of SELECT CASE. */
9142 ffestw_update (NULL); /* Update state line/col info. */
9144 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSELECT1);
9149 if (ffestw_name (ffestw_stack_top ()) == NULL)
9151 ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
9152 ffebad_here (0, ffelex_token_where_line (name),
9153 ffelex_token_where_column (name));
9154 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
9157 else if (ffelex_token_strcmp (name,
9158 ffestw_name (ffestw_stack_top ()))
9161 ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
9162 ffebad_here (0, ffelex_token_where_line (name),
9163 ffelex_token_where_column (name));
9164 ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
9165 ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
9172 if (ffestw_substate (ffestw_stack_top ()) != 0)
9174 ffebad_start (FFEBAD_CASE_SECOND_DEFAULT);
9175 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
9176 ffelex_token_where_column (ffesta_tokens[0]));
9177 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
9181 ffestw_set_substate (ffestw_stack_top (), 1); /* Saw ELSE. */
9184 { /* For each case, try to fit into sorted list
9186 for (caseobj = cases->next; caseobj != cases; caseobj = caseobj->next)
9188 if ((caseobj->expr1 == NULL)
9190 || (caseobj->expr2 == NULL)))
9192 ffebad_start (FFEBAD_CASE_BAD_RANGE);
9193 ffebad_here (0, ffelex_token_where_line (caseobj->t),
9194 ffelex_token_where_column (caseobj->t));
9199 if (((caseobj->expr1 != NULL)
9200 && ((ffeinfo_basictype (ffebld_info (caseobj->expr1))
9202 || (ffeinfo_kindtype (ffebld_info (caseobj->expr1))
9204 || ((caseobj->range)
9205 && (caseobj->expr2 != NULL)
9206 && ((ffeinfo_basictype (ffebld_info (caseobj->expr2))
9208 || (ffeinfo_kindtype (ffebld_info (caseobj->expr2))
9211 ffebad_start (FFEBAD_CASE_TYPE_DISAGREE);
9212 ffebad_here (0, ffelex_token_where_line (caseobj->t),
9213 ffelex_token_where_column (caseobj->t));
9214 ffebad_here (1, ffelex_token_where_line (s->t),
9215 ffelex_token_where_column (s->t));
9220 if ((s->type == FFEINFO_basictypeLOGICAL) && (caseobj->range))
9222 ffebad_start (FFEBAD_CASE_LOGICAL_RANGE);
9223 ffebad_here (0, ffelex_token_where_line (caseobj->t),
9224 ffelex_token_where_column (caseobj->t));
9229 if (caseobj->expr1 == NULL)
9231 else if (ffebld_op (caseobj->expr1) != FFEBLD_opCONTER)
9232 continue; /* opANY. */
9234 expr1c = ffebld_conter (caseobj->expr1);
9236 if (!caseobj->range)
9237 expr2c = expr1c; /* expr1c and expr2c are NOT NULL in this
9239 else if (caseobj->expr2 == NULL)
9241 else if (ffebld_op (caseobj->expr2) != FFEBLD_opCONTER)
9242 continue; /* opANY. */
9244 expr2c = ffebld_conter (caseobj->expr2);
9247 { /* "CASE (:high)", must be first in list. */
9249 if ((c != (ffestwCase) &s->first_rel)
9250 && ((c->low == NULL)
9251 || (ffebld_constant_cmp (expr2c, c->low) >= 0)))
9252 { /* Other "CASE (:high)" or lowest "CASE
9253 (low[:high])" low. */
9254 ffebad_start (FFEBAD_CASE_DUPLICATE);
9255 ffebad_here (0, ffelex_token_where_line (caseobj->t),
9256 ffelex_token_where_column (caseobj->t));
9257 ffebad_here (1, ffelex_token_where_line (c->t),
9258 ffelex_token_where_column (c->t));
9263 else if (expr2c == NULL)
9264 { /* "CASE (low:)", must be last in list. */
9266 if ((c != (ffestwCase) &s->first_rel)
9267 && ((c->high == NULL)
9268 || (ffebld_constant_cmp (expr1c, c->high) <= 0)))
9269 { /* Other "CASE (low:)" or lowest "CASE
9270 ([low:]high)" high. */
9271 ffebad_start (FFEBAD_CASE_DUPLICATE);
9272 ffebad_here (0, ffelex_token_where_line (caseobj->t),
9273 ffelex_token_where_column (caseobj->t));
9274 ffebad_here (1, ffelex_token_where_line (c->t),
9275 ffelex_token_where_column (c->t));
9279 c = c->next_rel; /* Same as c = (ffestwCase) &s->first;. */
9282 { /* (expr1c != NULL) && (expr2c != NULL). */
9283 if (ffebld_constant_cmp (expr1c, expr2c) > 0)
9284 { /* Such as "CASE (3:1)" or "CASE ('B':'A')". */
9285 ffebad_start (FFEBAD_CASE_RANGE_USELESS); /* Warn/inform only. */
9286 ffebad_here (0, ffelex_token_where_line (caseobj->t),
9287 ffelex_token_where_column (caseobj->t));
9291 for (c = s->first_rel;
9292 (c != (ffestwCase) &s->first_rel)
9293 && ((c->low == NULL)
9294 || (ffebld_constant_cmp (expr1c, c->low) > 0));
9297 nc = c; /* Which one to report? */
9298 if (((c != (ffestwCase) &s->first_rel)
9299 && (ffebld_constant_cmp (expr2c, c->low) >= 0))
9300 || (((nc = c->previous_rel) != (ffestwCase) &s->first_rel)
9301 && (ffebld_constant_cmp (expr1c, nc->high) <= 0)))
9302 { /* Interference with range in case nc. */
9303 ffebad_start (FFEBAD_CASE_DUPLICATE);
9304 ffebad_here (0, ffelex_token_where_line (caseobj->t),
9305 ffelex_token_where_column (caseobj->t));
9306 ffebad_here (1, ffelex_token_where_line (nc->t),
9307 ffelex_token_where_column (nc->t));
9313 /* If we reach here for this case range/value, it's ok (sorts into
9314 the list of ranges/values) so we give it its own case object
9315 sorted into the list of case statements. */
9317 nc = malloc_new_kp (s->pool, "Case range", sizeof (*nc));
9319 nc->previous_rel = c->previous_rel;
9320 nc->next_stmt = (ffestwCase) &s->first_rel;
9321 nc->previous_stmt = s->last_stmt;
9324 nc->casenum = s->cases;
9325 nc->t = ffelex_token_use (caseobj->t);
9326 nc->next_rel->previous_rel = nc;
9327 nc->previous_rel->next_rel = nc;
9328 nc->next_stmt->previous_stmt = nc;
9329 nc->previous_stmt->next_stmt = nc;
9333 ffestd_R810 ((cases == NULL) ? 0 : s->cases);
9335 s->cases++; /* Increment # of cases. */
9338 /* ffestc_R811 -- END SELECT statement
9340 ffestc_R811(name_token);
9342 Make sure ffestc_kind_ identifies a SELECT block. If not
9343 NULL, make sure name_token gives the correct name. Implement the end
9344 of the SELECT block. */
9347 ffestc_R811 (ffelexToken name)
9349 ffestc_check_simple_ ();
9350 if (ffestc_order_selectcase_ () != FFESTC_orderOK_)
9352 ffestc_labeldef_notloop_ ();
9356 if (ffestw_name (ffestw_stack_top ()) != NULL)
9358 ffebad_start (FFEBAD_CONSTRUCT_NAMED);
9359 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
9360 ffelex_token_where_column (ffesta_tokens[0]));
9361 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
9367 if (ffestw_name (ffestw_stack_top ()) == NULL)
9369 ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
9370 ffebad_here (0, ffelex_token_where_line (name),
9371 ffelex_token_where_column (name));
9372 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
9375 else if (ffelex_token_strcmp (name,
9376 ffestw_name (ffestw_stack_top ()))
9379 ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
9380 ffebad_here (0, ffelex_token_where_line (name),
9381 ffelex_token_where_column (name));
9382 ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
9383 ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
9388 ffestc_shriek_select_ (TRUE);
9391 /* ffestc_R819A -- Iterative labeled DO statement
9393 ffestc_R819A(construct_name,label_token,expr,expr_token);
9395 Make sure statement is valid here; implement. */
9398 ffestc_R819A (ffelexToken construct_name, ffelexToken label_token, ffebld var,
9399 ffelexToken var_token, ffebld start, ffelexToken start_token, ffebld end,
9400 ffelexToken end_token, ffebld incr, ffelexToken incr_token)
9407 ffestc_check_simple_ ();
9408 if (ffestc_order_exec_ () != FFESTC_orderOK_)
9410 ffestc_labeldef_notloop_ ();
9412 if (!ffestc_labelref_is_loopend_ (label_token, &label))
9415 b = ffestw_update (ffestw_push (NULL));
9416 ffestw_set_top_do (b, b);
9417 ffestw_set_state (b, FFESTV_stateDO);
9418 ffestw_set_blocknum (b, ffestc_blocknum_++);
9419 ffestw_set_shriek (b, ffestc_shriek_do_);
9420 ffestw_set_label (b, label);
9421 switch (ffebld_op (var))
9423 case FFEBLD_opSYMTER:
9424 if ((ffeinfo_basictype (ffebld_info (var)) == FFEINFO_basictypeREAL)
9425 && ffe_is_warn_surprising ())
9427 ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */
9428 ffebad_here (0, ffelex_token_where_line (var_token),
9429 ffelex_token_where_column (var_token));
9430 ffebad_string (ffesymbol_text (ffebld_symter (var)));
9433 if (!ffesymbol_is_doiter (varsym = ffebld_symter (var)))
9434 { /* Presumably already complained about by
9436 ffesymbol_set_is_doiter (varsym, TRUE);
9437 ffestw_set_do_iter_var (b, varsym);
9438 ffestw_set_do_iter_var_t (b, ffelex_token_use (var_token));
9443 ffestw_set_do_iter_var (b, NULL);
9444 ffestw_set_do_iter_var_t (b, NULL);
9448 assert ("bad iter var" == NULL);
9452 if (construct_name == NULL)
9453 ffestw_set_name (b, NULL);
9456 ffestw_set_name (b, ffelex_token_use (construct_name));
9458 s = ffesymbol_declare_local (construct_name, FALSE);
9460 if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
9462 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
9463 ffesymbol_set_info (s,
9464 ffeinfo_new (FFEINFO_basictypeNONE,
9465 FFEINFO_kindtypeNONE,
9467 FFEINFO_kindCONSTRUCT,
9469 FFETARGET_charactersizeNONE));
9470 s = ffecom_sym_learned (s);
9471 ffesymbol_signal_unreported (s);
9474 ffesymbol_error (s, construct_name);
9479 incr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
9480 ffebld_set_info (incr, ffeinfo_new
9481 (FFEINFO_basictypeINTEGER,
9482 FFEINFO_kindtypeINTEGERDEFAULT,
9485 FFEINFO_whereCONSTANT,
9486 FFETARGET_charactersizeNONE));
9489 start = ffeexpr_convert_expr (start, start_token, var, var_token,
9490 FFEEXPR_contextLET);
9491 end = ffeexpr_convert_expr (end, end_token, var, var_token,
9492 FFEEXPR_contextLET);
9493 incr = ffeexpr_convert_expr (incr, incr_token, var, var_token,
9494 FFEEXPR_contextLET);
9496 ffestd_R819A (construct_name, label, var,
9502 /* ffestc_R819B -- Labeled DO WHILE statement
9504 ffestc_R819B(construct_name,label_token,expr,expr_token);
9506 Make sure statement is valid here; implement. */
9509 ffestc_R819B (ffelexToken construct_name, ffelexToken label_token,
9510 ffebld expr, ffelexToken expr_token UNUSED)
9516 ffestc_check_simple_ ();
9517 if (ffestc_order_exec_ () != FFESTC_orderOK_)
9519 ffestc_labeldef_notloop_ ();
9521 if (!ffestc_labelref_is_loopend_ (label_token, &label))
9524 b = ffestw_update (ffestw_push (NULL));
9525 ffestw_set_top_do (b, b);
9526 ffestw_set_state (b, FFESTV_stateDO);
9527 ffestw_set_blocknum (b, ffestc_blocknum_++);
9528 ffestw_set_shriek (b, ffestc_shriek_do_);
9529 ffestw_set_label (b, label);
9530 ffestw_set_do_iter_var (b, NULL);
9531 ffestw_set_do_iter_var_t (b, NULL);
9533 if (construct_name == NULL)
9534 ffestw_set_name (b, NULL);
9537 ffestw_set_name (b, ffelex_token_use (construct_name));
9539 s = ffesymbol_declare_local (construct_name, FALSE);
9541 if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
9543 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
9544 ffesymbol_set_info (s,
9545 ffeinfo_new (FFEINFO_basictypeNONE,
9546 FFEINFO_kindtypeNONE,
9548 FFEINFO_kindCONSTRUCT,
9550 FFETARGET_charactersizeNONE));
9551 s = ffecom_sym_learned (s);
9552 ffesymbol_signal_unreported (s);
9555 ffesymbol_error (s, construct_name);
9558 ffestd_R819B (construct_name, label, expr);
9561 /* ffestc_R820A -- Iterative nonlabeled DO statement
9563 ffestc_R820A(construct_name,expr,expr_token);
9565 Make sure statement is valid here; implement. */
9568 ffestc_R820A (ffelexToken construct_name, ffebld var, ffelexToken var_token,
9569 ffebld start, ffelexToken start_token, ffebld end, ffelexToken end_token,
9570 ffebld incr, ffelexToken incr_token)
9576 ffestc_check_simple_ ();
9577 if (ffestc_order_exec_ () != FFESTC_orderOK_)
9579 ffestc_labeldef_notloop_ ();
9581 b = ffestw_update (ffestw_push (NULL));
9582 ffestw_set_top_do (b, b);
9583 ffestw_set_state (b, FFESTV_stateDO);
9584 ffestw_set_blocknum (b, ffestc_blocknum_++);
9585 ffestw_set_shriek (b, ffestc_shriek_do_);
9586 ffestw_set_label (b, NULL);
9587 switch (ffebld_op (var))
9589 case FFEBLD_opSYMTER:
9590 if ((ffeinfo_basictype (ffebld_info (var)) == FFEINFO_basictypeREAL)
9591 && ffe_is_warn_surprising ())
9593 ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */
9594 ffebad_here (0, ffelex_token_where_line (var_token),
9595 ffelex_token_where_column (var_token));
9596 ffebad_string (ffesymbol_text (ffebld_symter (var)));
9599 if (!ffesymbol_is_doiter (varsym = ffebld_symter (var)))
9600 { /* Presumably already complained about by
9602 ffesymbol_set_is_doiter (varsym, TRUE);
9603 ffestw_set_do_iter_var (b, varsym);
9604 ffestw_set_do_iter_var_t (b, ffelex_token_use (var_token));
9609 ffestw_set_do_iter_var (b, NULL);
9610 ffestw_set_do_iter_var_t (b, NULL);
9614 assert ("bad iter var" == NULL);
9618 if (construct_name == NULL)
9619 ffestw_set_name (b, NULL);
9622 ffestw_set_name (b, ffelex_token_use (construct_name));
9624 s = ffesymbol_declare_local (construct_name, FALSE);
9626 if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
9628 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
9629 ffesymbol_set_info (s,
9630 ffeinfo_new (FFEINFO_basictypeNONE,
9631 FFEINFO_kindtypeNONE,
9633 FFEINFO_kindCONSTRUCT,
9635 FFETARGET_charactersizeNONE));
9636 s = ffecom_sym_learned (s);
9637 ffesymbol_signal_unreported (s);
9640 ffesymbol_error (s, construct_name);
9645 incr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
9646 ffebld_set_info (incr, ffeinfo_new
9647 (FFEINFO_basictypeINTEGER,
9648 FFEINFO_kindtypeINTEGERDEFAULT,
9651 FFEINFO_whereCONSTANT,
9652 FFETARGET_charactersizeNONE));
9655 start = ffeexpr_convert_expr (start, start_token, var, var_token,
9656 FFEEXPR_contextLET);
9657 end = ffeexpr_convert_expr (end, end_token, var, var_token,
9658 FFEEXPR_contextLET);
9659 incr = ffeexpr_convert_expr (incr, incr_token, var, var_token,
9660 FFEEXPR_contextLET);
9663 if ((ffebld_op (incr) == FFEBLD_opCONTER)
9664 && (ffebld_constant_is_zero (ffebld_conter (incr))))
9666 ffebad_start (FFEBAD_DO_STEP_ZERO);
9667 ffebad_here (0, ffelex_token_where_line (incr_token),
9668 ffelex_token_where_column (incr_token));
9669 ffebad_string ("Iterative DO loop");
9674 ffestd_R819A (construct_name, NULL, var,
9680 /* ffestc_R820B -- Nonlabeled DO WHILE statement
9682 ffestc_R820B(construct_name,expr,expr_token);
9684 Make sure statement is valid here; implement. */
9687 ffestc_R820B (ffelexToken construct_name, ffebld expr,
9688 ffelexToken expr_token UNUSED)
9693 ffestc_check_simple_ ();
9694 if (ffestc_order_exec_ () != FFESTC_orderOK_)
9696 ffestc_labeldef_notloop_ ();
9698 b = ffestw_update (ffestw_push (NULL));
9699 ffestw_set_top_do (b, b);
9700 ffestw_set_state (b, FFESTV_stateDO);
9701 ffestw_set_blocknum (b, ffestc_blocknum_++);
9702 ffestw_set_shriek (b, ffestc_shriek_do_);
9703 ffestw_set_label (b, NULL);
9704 ffestw_set_do_iter_var (b, NULL);
9705 ffestw_set_do_iter_var_t (b, NULL);
9707 if (construct_name == NULL)
9708 ffestw_set_name (b, NULL);
9711 ffestw_set_name (b, ffelex_token_use (construct_name));
9713 s = ffesymbol_declare_local (construct_name, FALSE);
9715 if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
9717 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
9718 ffesymbol_set_info (s,
9719 ffeinfo_new (FFEINFO_basictypeNONE,
9720 FFEINFO_kindtypeNONE,
9722 FFEINFO_kindCONSTRUCT,
9724 FFETARGET_charactersizeNONE));
9725 s = ffecom_sym_learned (s);
9726 ffesymbol_signal_unreported (s);
9729 ffesymbol_error (s, construct_name);
9732 ffestd_R819B (construct_name, NULL, expr);
9735 /* ffestc_R825 -- END DO statement
9737 ffestc_R825(name_token);
9739 Make sure ffestc_kind_ identifies a DO block. If not
9740 NULL, make sure name_token gives the correct name. Implement the end
9744 ffestc_R825 (ffelexToken name)
9746 ffestc_check_simple_ ();
9747 if (ffestc_order_do_ () != FFESTC_orderOK_)
9749 ffestc_labeldef_branch_begin_ ();
9753 if (ffestw_name (ffestw_stack_top ()) != NULL)
9755 ffebad_start (FFEBAD_CONSTRUCT_NAMED);
9756 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
9757 ffelex_token_where_column (ffesta_tokens[0]));
9758 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
9764 if (ffestw_name (ffestw_stack_top ()) == NULL)
9766 ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
9767 ffebad_here (0, ffelex_token_where_line (name),
9768 ffelex_token_where_column (name));
9769 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
9772 else if (ffelex_token_strcmp (name,
9773 ffestw_name (ffestw_stack_top ()))
9776 ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
9777 ffebad_here (0, ffelex_token_where_line (name),
9778 ffelex_token_where_column (name));
9779 ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
9780 ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
9785 if (ffesta_label_token == NULL)
9786 { /* If top of stack has label, its an error! */
9787 if (ffestw_label (ffestw_stack_top ()) != NULL)
9789 ffebad_start (FFEBAD_DO_HAD_LABEL);
9790 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
9791 ffelex_token_where_column (ffesta_tokens[0]));
9792 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
9796 ffestc_shriek_do_ (TRUE);
9798 ffestc_try_shriek_do_ ();
9805 ffestc_labeldef_branch_end_ ();
9808 /* ffestc_R834 -- CYCLE statement
9810 ffestc_R834(name_token);
9812 Handle a CYCLE within a loop. */
9815 ffestc_R834 (ffelexToken name)
9819 ffestc_check_simple_ ();
9820 if (ffestc_order_actiondo_ () != FFESTC_orderOK_)
9822 ffestc_labeldef_notloop_begin_ ();
9825 block = ffestw_top_do (ffestw_stack_top ());
9827 { /* Search for name. */
9828 for (block = ffestw_top_do (ffestw_stack_top ());
9829 (block != NULL) && (ffestw_blocknum (block) != 0);
9830 block = ffestw_top_do (ffestw_previous (block)))
9832 if ((ffestw_name (block) != NULL)
9833 && (ffelex_token_strcmp (name, ffestw_name (block)) == 0))
9836 if ((block == NULL) || (ffestw_blocknum (block) == 0))
9838 block = ffestw_top_do (ffestw_stack_top ());
9839 ffebad_start (FFEBAD_CONSTRUCT_NO_DO_NAME);
9840 ffebad_here (0, ffelex_token_where_line (name),
9841 ffelex_token_where_column (name));
9846 ffestd_R834 (block);
9848 if (ffestc_shriek_after1_ != NULL)
9849 (*ffestc_shriek_after1_) (TRUE);
9851 /* notloop's that are actionif's can be the target of a loop-end
9852 statement if they're in the "then" part of a logical IF, as
9853 in "DO 10", "10 IF (...) CYCLE". */
9855 ffestc_labeldef_branch_end_ ();
9858 /* ffestc_R835 -- EXIT statement
9860 ffestc_R835(name_token);
9862 Handle a EXIT within a loop. */
9865 ffestc_R835 (ffelexToken name)
9869 ffestc_check_simple_ ();
9870 if (ffestc_order_actiondo_ () != FFESTC_orderOK_)
9872 ffestc_labeldef_notloop_begin_ ();
9875 block = ffestw_top_do (ffestw_stack_top ());
9877 { /* Search for name. */
9878 for (block = ffestw_top_do (ffestw_stack_top ());
9879 (block != NULL) && (ffestw_blocknum (block) != 0);
9880 block = ffestw_top_do (ffestw_previous (block)))
9882 if ((ffestw_name (block) != NULL)
9883 && (ffelex_token_strcmp (name, ffestw_name (block)) == 0))
9886 if ((block == NULL) || (ffestw_blocknum (block) == 0))
9888 block = ffestw_top_do (ffestw_stack_top ());
9889 ffebad_start (FFEBAD_CONSTRUCT_NO_DO_NAME);
9890 ffebad_here (0, ffelex_token_where_line (name),
9891 ffelex_token_where_column (name));
9896 ffestd_R835 (block);
9898 if (ffestc_shriek_after1_ != NULL)
9899 (*ffestc_shriek_after1_) (TRUE);
9901 /* notloop's that are actionif's can be the target of a loop-end
9902 statement if they're in the "then" part of a logical IF, as
9903 in "DO 10", "10 IF (...) EXIT". */
9905 ffestc_labeldef_branch_end_ ();
9908 /* ffestc_R836 -- GOTO statement
9910 ffestc_R836(label_token);
9912 Make sure label_token identifies a valid label for a GOTO. Update
9913 that label's info to indicate it is the target of a GOTO. */
9916 ffestc_R836 (ffelexToken label_token)
9920 ffestc_check_simple_ ();
9921 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
9923 ffestc_labeldef_notloop_begin_ ();
9925 if (ffestc_labelref_is_branch_ (label_token, &label))
9926 ffestd_R836 (label);
9928 if (ffestc_shriek_after1_ != NULL)
9929 (*ffestc_shriek_after1_) (TRUE);
9931 /* notloop's that are actionif's can be the target of a loop-end
9932 statement if they're in the "then" part of a logical IF, as
9933 in "DO 10", "10 IF (...) GOTO 100". */
9935 ffestc_labeldef_branch_end_ ();
9938 /* ffestc_R837 -- Computed GOTO statement
9940 ffestc_R837(label_list,expr,expr_token);
9942 Make sure label_list identifies valid labels for a GOTO. Update
9943 each label's info to indicate it is the target of a GOTO. */
9946 ffestc_R837 (ffesttTokenList label_toks, ffebld expr,
9947 ffelexToken expr_token UNUSED)
9954 assert (label_toks != NULL);
9956 ffestc_check_simple_ ();
9957 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
9959 ffestc_labeldef_branch_begin_ ();
9961 labels = malloc_new_kp (ffesta_output_pool, "FFESTC labels",
9963 * ffestt_tokenlist_count (label_toks));
9965 for (ti = label_toks->first, i = 0;
9966 ti != (ffesttTokenItem) &label_toks->first;
9969 if (!ffestc_labelref_is_branch_ (ti->t, &labels[i]))
9977 ffestd_R837 (labels, ffestt_tokenlist_count (label_toks), expr);
9979 if (ffestc_shriek_after1_ != NULL)
9980 (*ffestc_shriek_after1_) (TRUE);
9981 ffestc_labeldef_branch_end_ ();
9984 /* ffestc_R838 -- ASSIGN statement
9986 ffestc_R838(label_token,target_variable,target_token);
9988 Make sure label_token identifies a valid label for an assignment. Update
9989 that label's info to indicate it is the source of an assignment. Update
9990 target_variable's info to indicate it is the target the assignment of that
9994 ffestc_R838 (ffelexToken label_token, ffebld target,
9995 ffelexToken target_token UNUSED)
9999 ffestc_check_simple_ ();
10000 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
10002 ffestc_labeldef_branch_begin_ ();
10004 /* Mark target symbol as target of an ASSIGN. */
10005 if (ffebld_op (target) == FFEBLD_opSYMTER)
10006 ffesymbol_set_assigned (ffebld_symter (target), TRUE);
10008 if (ffestc_labelref_is_assignable_ (label_token, &label))
10009 ffestd_R838 (label, target);
10011 if (ffestc_shriek_after1_ != NULL)
10012 (*ffestc_shriek_after1_) (TRUE);
10013 ffestc_labeldef_branch_end_ ();
10016 /* ffestc_R839 -- Assigned GOTO statement
10018 ffestc_R839(target,target_token,label_list);
10020 Make sure label_list identifies valid labels for a GOTO. Update
10021 each label's info to indicate it is the target of a GOTO. */
10024 ffestc_R839 (ffebld target, ffelexToken target_token UNUSED,
10025 ffesttTokenList label_toks)
10027 ffesttTokenItem ti;
10032 ffestc_check_simple_ ();
10033 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
10035 ffestc_labeldef_notloop_begin_ ();
10037 if (label_toks == NULL)
10044 labels = malloc_new_kp (ffesta_output_pool, "FFESTC labels",
10045 sizeof (*labels) * ffestt_tokenlist_count (label_toks));
10047 for (ti = label_toks->first, i = 0;
10048 ti != (ffesttTokenItem) &label_toks->first;
10049 ti = ti->next, ++i)
10051 if (!ffestc_labelref_is_branch_ (ti->t, &labels[i]))
10060 ffestd_R839 (target, labels, i);
10062 if (ffestc_shriek_after1_ != NULL)
10063 (*ffestc_shriek_after1_) (TRUE);
10065 /* notloop's that are actionif's can be the target of a loop-end
10066 statement if they're in the "then" part of a logical IF, as
10067 in "DO 10", "10 IF (...) GOTO I". */
10069 ffestc_labeldef_branch_end_ ();
10072 /* ffestc_R840 -- Arithmetic IF statement
10074 ffestc_R840(expr,expr_token,neg,zero,pos);
10076 Make sure the labels are valid; implement. */
10079 ffestc_R840 (ffebld expr, ffelexToken expr_token UNUSED,
10080 ffelexToken neg_token, ffelexToken zero_token,
10081 ffelexToken pos_token)
10087 ffestc_check_simple_ ();
10088 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
10090 ffestc_labeldef_notloop_begin_ ();
10092 if (ffestc_labelref_is_branch_ (neg_token, &neg)
10093 && ffestc_labelref_is_branch_ (zero_token, &zero)
10094 && ffestc_labelref_is_branch_ (pos_token, &pos))
10095 ffestd_R840 (expr, neg, zero, pos);
10097 if (ffestc_shriek_after1_ != NULL)
10098 (*ffestc_shriek_after1_) (TRUE);
10100 /* notloop's that are actionif's can be the target of a loop-end
10101 statement if they're in the "then" part of a logical IF, as
10102 in "DO 10", "10 IF (...) GOTO (100,200,300), I". */
10104 ffestc_labeldef_branch_end_ ();
10107 /* ffestc_R841 -- CONTINUE statement
10114 ffestc_check_simple_ ();
10116 if (ffestc_order_actionwhere_ () != FFESTC_orderOK_)
10119 switch (ffestw_state (ffestw_stack_top ()))
10122 case FFESTV_stateWHERE:
10123 case FFESTV_stateWHERETHEN:
10124 ffestc_labeldef_useless_ ();
10126 ffestd_R841 (TRUE);
10128 /* It's okay that we call ffestc_labeldef_branch_end_ () below,
10129 since that will be a no-op after calling _useless_ () above. */
10134 ffestc_labeldef_branch_begin_ ();
10136 ffestd_R841 (FALSE);
10141 if (ffestc_shriek_after1_ != NULL)
10142 (*ffestc_shriek_after1_) (TRUE);
10143 ffestc_labeldef_branch_end_ ();
10146 /* ffestc_R842 -- STOP statement
10148 ffestc_R842(expr,expr_token);
10150 Make sure statement is valid here; implement. expr and expr_token are
10151 both NULL if there was no expression. */
10154 ffestc_R842 (ffebld expr, ffelexToken expr_token UNUSED)
10156 ffestc_check_simple_ ();
10157 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
10159 ffestc_labeldef_notloop_begin_ ();
10161 ffestd_R842 (expr);
10163 if (ffestc_shriek_after1_ != NULL)
10164 (*ffestc_shriek_after1_) (TRUE);
10166 /* notloop's that are actionif's can be the target of a loop-end
10167 statement if they're in the "then" part of a logical IF, as
10168 in "DO 10", "10 IF (...) STOP". */
10170 ffestc_labeldef_branch_end_ ();
10173 /* ffestc_R843 -- PAUSE statement
10175 ffestc_R843(expr,expr_token);
10177 Make sure statement is valid here; implement. expr and expr_token are
10178 both NULL if there was no expression. */
10181 ffestc_R843 (ffebld expr, ffelexToken expr_token UNUSED)
10183 ffestc_check_simple_ ();
10184 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
10186 ffestc_labeldef_branch_begin_ ();
10188 ffestd_R843 (expr);
10190 if (ffestc_shriek_after1_ != NULL)
10191 (*ffestc_shriek_after1_) (TRUE);
10192 ffestc_labeldef_branch_end_ ();
10195 /* ffestc_R904 -- OPEN statement
10199 Make sure an OPEN is valid in the current context, and implement it. */
10206 static const char *const status_strs[] =
10214 static const char *const access_strs[] =
10221 static const char *const blank_strs[] =
10226 static const char *const carriagecontrol_strs[] =
10232 static const char *const dispose_strs[] =
10242 static const char *const form_strs[] =
10247 static const char *const organization_strs[] =
10253 static const char *const position_strs[] =
10259 static const char *const action_strs[] =
10265 static const char *const delim_strs[] =
10271 static const char *const recordtype_strs[] =
10280 static const char *const pad_strs[] =
10286 ffestc_check_simple_ ();
10287 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
10289 ffestc_labeldef_branch_begin_ ();
10291 if (ffestc_subr_is_branch_
10292 (&ffestp_file.open.open_spec[FFESTP_openixERR])
10293 && ffestc_subr_is_present_ ("UNIT",
10294 &ffestp_file.open.open_spec[FFESTP_openixUNIT]))
10296 i = ffestc_subr_binsrch_ (status_strs,
10297 ARRAY_SIZE (status_strs),
10298 &ffestp_file.open.open_spec[FFESTP_openixSTATUS],
10299 "NEW, OLD, REPLACE, SCRATCH, or UNKNOWN");
10302 case 0: /* Unknown. */
10303 case 5: /* UNKNOWN. */
10304 expect_file = 2; /* Unknown, don't care about FILE=. */
10309 if (ffe_is_pedantic ())
10310 expect_file = 1; /* Yes, need FILE=. */
10312 expect_file = 2; /* f2clib doesn't care about FILE=. */
10315 case 3: /* REPLACE. */
10316 expect_file = 1; /* Yes, need FILE=. */
10319 case 4: /* SCRATCH. */
10320 expect_file = 0; /* No, disallow FILE=. */
10324 assert ("invalid _binsrch_ result" == NULL);
10328 if ((expect_file == 0)
10329 && ffestp_file.open.open_spec[FFESTP_openixFILE].kw_or_val_present)
10331 ffebad_start (FFEBAD_CONFLICTING_SPECS);
10332 assert (ffestp_file.open.open_spec[FFESTP_openixFILE].kw_or_val_present);
10333 if (ffestp_file.open.open_spec[FFESTP_openixFILE].kw_present)
10335 ffebad_here (0, ffelex_token_where_line
10336 (ffestp_file.open.open_spec[FFESTP_openixFILE].kw),
10337 ffelex_token_where_column
10338 (ffestp_file.open.open_spec[FFESTP_openixFILE].kw));
10342 ffebad_here (0, ffelex_token_where_line
10343 (ffestp_file.open.open_spec[FFESTP_openixFILE].value),
10344 ffelex_token_where_column
10345 (ffestp_file.open.open_spec[FFESTP_openixFILE].value));
10347 assert (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_or_val_present);
10348 if (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_present)
10350 ffebad_here (1, ffelex_token_where_line
10351 (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw),
10352 ffelex_token_where_column
10353 (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw));
10357 ffebad_here (1, ffelex_token_where_line
10358 (ffestp_file.open.open_spec[FFESTP_openixSTATUS].value),
10359 ffelex_token_where_column
10360 (ffestp_file.open.open_spec[FFESTP_openixSTATUS].value));
10364 else if ((expect_file == 1)
10365 && !ffestp_file.open.open_spec[FFESTP_openixFILE].kw_or_val_present)
10367 ffebad_start (FFEBAD_MISSING_SPECIFIER);
10368 assert (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_or_val_present);
10369 if (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_present)
10371 ffebad_here (0, ffelex_token_where_line
10372 (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw),
10373 ffelex_token_where_column
10374 (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw));
10378 ffebad_here (0, ffelex_token_where_line
10379 (ffestp_file.open.open_spec[FFESTP_openixSTATUS].value),
10380 ffelex_token_where_column
10381 (ffestp_file.open.open_spec[FFESTP_openixSTATUS].value));
10383 ffebad_string ("FILE=");
10387 ffestc_subr_binsrch_ (access_strs, ARRAY_SIZE (access_strs),
10388 &ffestp_file.open.open_spec[FFESTP_openixACCESS],
10389 "APPEND, DIRECT, KEYED, or SEQUENTIAL");
10391 ffestc_subr_binsrch_ (blank_strs, ARRAY_SIZE (blank_strs),
10392 &ffestp_file.open.open_spec[FFESTP_openixBLANK],
10395 ffestc_subr_binsrch_ (carriagecontrol_strs,
10396 ARRAY_SIZE (carriagecontrol_strs),
10397 &ffestp_file.open.open_spec[FFESTP_openixCARRIAGECONTROL],
10398 "FORTRAN, LIST, or NONE");
10400 ffestc_subr_binsrch_ (dispose_strs, ARRAY_SIZE (dispose_strs),
10401 &ffestp_file.open.open_spec[FFESTP_openixDISPOSE],
10402 "DELETE, KEEP, PRINT, PRINT/DELETE, SAVE, SUBMIT, or SUBMIT/DELETE");
10404 ffestc_subr_binsrch_ (form_strs, ARRAY_SIZE (form_strs),
10405 &ffestp_file.open.open_spec[FFESTP_openixFORM],
10406 "FORMATTED or UNFORMATTED");
10408 ffestc_subr_binsrch_ (organization_strs, ARRAY_SIZE (organization_strs),
10409 &ffestp_file.open.open_spec[FFESTP_openixORGANIZATION],
10410 "INDEXED, RELATIVE, or SEQUENTIAL");
10412 ffestc_subr_binsrch_ (position_strs, ARRAY_SIZE (position_strs),
10413 &ffestp_file.open.open_spec[FFESTP_openixPOSITION],
10414 "APPEND, ASIS, or REWIND");
10416 ffestc_subr_binsrch_ (action_strs, ARRAY_SIZE (action_strs),
10417 &ffestp_file.open.open_spec[FFESTP_openixACTION],
10418 "READ, READWRITE, or WRITE");
10420 ffestc_subr_binsrch_ (delim_strs, ARRAY_SIZE (delim_strs),
10421 &ffestp_file.open.open_spec[FFESTP_openixDELIM],
10422 "APOSTROPHE, NONE, or QUOTE");
10424 ffestc_subr_binsrch_ (recordtype_strs, ARRAY_SIZE (recordtype_strs),
10425 &ffestp_file.open.open_spec[FFESTP_openixRECORDTYPE],
10426 "FIXED, SEGMENTED, STREAM, STREAM_CR, STREAM_LF, or VARIABLE");
10428 ffestc_subr_binsrch_ (pad_strs, ARRAY_SIZE (pad_strs),
10429 &ffestp_file.open.open_spec[FFESTP_openixPAD],
10435 if (ffestc_shriek_after1_ != NULL)
10436 (*ffestc_shriek_after1_) (TRUE);
10437 ffestc_labeldef_branch_end_ ();
10440 /* ffestc_R907 -- CLOSE statement
10444 Make sure a CLOSE is valid in the current context, and implement it. */
10449 static const char *const status_strs[] =
10460 ffestc_check_simple_ ();
10461 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
10463 ffestc_labeldef_branch_begin_ ();
10465 if (ffestc_subr_is_branch_
10466 (&ffestp_file.close.close_spec[FFESTP_closeixERR])
10467 && ffestc_subr_is_present_ ("UNIT",
10468 &ffestp_file.close.close_spec[FFESTP_closeixUNIT]))
10470 ffestc_subr_binsrch_ (status_strs, ARRAY_SIZE (status_strs),
10471 &ffestp_file.close.close_spec[FFESTP_closeixSTATUS],
10472 "DELETE, KEEP, PRINT, PRINT/DELETE, SAVE, SUBMIT, or SUBMIT/DELETE");
10477 if (ffestc_shriek_after1_ != NULL)
10478 (*ffestc_shriek_after1_) (TRUE);
10479 ffestc_labeldef_branch_end_ ();
10482 /* ffestc_R909_start -- READ(...) statement list begin
10484 ffestc_R909_start(FALSE);
10486 Verify that READ is valid here, and begin accepting items in the
10490 ffestc_R909_start (bool only_format)
10493 ffestvFormat format;
10497 ffestpReadIx spec1;
10498 ffestpReadIx spec2;
10500 ffestc_check_start_ ();
10501 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
10503 ffestc_ok_ = FALSE;
10506 ffestc_labeldef_branch_begin_ ();
10508 if (!ffestc_subr_is_format_
10509 (&ffestp_file.read.read_spec[FFESTP_readixFORMAT]))
10511 ffestc_ok_ = FALSE;
10515 format = ffestc_subr_format_
10516 (&ffestp_file.read.read_spec[FFESTP_readixFORMAT]);
10517 ffestc_namelist_ = (format == FFESTV_formatNAMELIST);
10521 ffestd_R909_start (TRUE, FFESTV_unitNONE, format, FALSE, FALSE);
10527 if (!ffestc_subr_is_branch_
10528 (&ffestp_file.read.read_spec[FFESTP_readixEOR])
10529 || !ffestc_subr_is_branch_
10530 (&ffestp_file.read.read_spec[FFESTP_readixERR])
10531 || !ffestc_subr_is_branch_
10532 (&ffestp_file.read.read_spec[FFESTP_readixEND]))
10534 ffestc_ok_ = FALSE;
10538 unit = ffestc_subr_unit_
10539 (&ffestp_file.read.read_spec[FFESTP_readixUNIT]);
10540 if (unit == FFESTV_unitNONE)
10542 ffebad_start (FFEBAD_NO_UNIT_SPEC);
10543 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
10544 ffelex_token_where_column (ffesta_tokens[0]));
10546 ffestc_ok_ = FALSE;
10550 rec = ffestp_file.read.read_spec[FFESTP_readixREC].kw_or_val_present;
10552 if (ffestp_file.read.read_spec[FFESTP_readixKEYEQ].kw_or_val_present)
10555 keyn = spec1 = FFESTP_readixKEYEQ;
10560 keyn = spec1 = FFESTP_readix;
10563 if (ffestp_file.read.read_spec[FFESTP_readixKEYGT].kw_or_val_present)
10567 spec2 = FFESTP_readixKEYGT;
10568 whine: /* :::::::::::::::::::: */
10569 ffebad_start (FFEBAD_CONFLICTING_SPECS);
10570 assert (ffestp_file.read.read_spec[spec1].kw_or_val_present);
10571 if (ffestp_file.read.read_spec[spec1].kw_present)
10573 ffebad_here (0, ffelex_token_where_line
10574 (ffestp_file.read.read_spec[spec1].kw),
10575 ffelex_token_where_column
10576 (ffestp_file.read.read_spec[spec1].kw));
10580 ffebad_here (0, ffelex_token_where_line
10581 (ffestp_file.read.read_spec[spec1].value),
10582 ffelex_token_where_column
10583 (ffestp_file.read.read_spec[spec1].value));
10585 assert (ffestp_file.read.read_spec[spec2].kw_or_val_present);
10586 if (ffestp_file.read.read_spec[spec2].kw_present)
10588 ffebad_here (1, ffelex_token_where_line
10589 (ffestp_file.read.read_spec[spec2].kw),
10590 ffelex_token_where_column
10591 (ffestp_file.read.read_spec[spec2].kw));
10595 ffebad_here (1, ffelex_token_where_line
10596 (ffestp_file.read.read_spec[spec2].value),
10597 ffelex_token_where_column
10598 (ffestp_file.read.read_spec[spec2].value));
10601 ffestc_ok_ = FALSE;
10605 keyn = spec1 = FFESTP_readixKEYGT;
10608 if (ffestp_file.read.read_spec[FFESTP_readixKEYGE].kw_or_val_present)
10612 spec2 = FFESTP_readixKEYGT;
10613 goto whine; /* :::::::::::::::::::: */
10616 keyn = FFESTP_readixKEYGT;
10621 spec1 = FFESTP_readixREC;
10625 goto whine; /* :::::::::::::::::::: */
10627 if (unit == FFESTV_unitCHAREXPR)
10629 spec2 = FFESTP_readixUNIT;
10630 goto whine; /* :::::::::::::::::::: */
10632 if ((format == FFESTV_formatASTERISK)
10633 || (format == FFESTV_formatNAMELIST))
10635 spec2 = FFESTP_readixFORMAT;
10636 goto whine; /* :::::::::::::::::::: */
10638 if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present)
10640 spec2 = FFESTP_readixADVANCE;
10641 goto whine; /* :::::::::::::::::::: */
10643 if (ffestp_file.read.read_spec[FFESTP_readixEND].kw_or_val_present)
10645 spec2 = FFESTP_readixEND;
10646 goto whine; /* :::::::::::::::::::: */
10648 if (ffestp_file.read.read_spec[FFESTP_readixNULLS].kw_or_val_present)
10650 spec2 = FFESTP_readixNULLS;
10651 goto whine; /* :::::::::::::::::::: */
10657 if (unit == FFESTV_unitCHAREXPR)
10659 spec2 = FFESTP_readixUNIT;
10660 goto whine; /* :::::::::::::::::::: */
10662 if ((format == FFESTV_formatASTERISK)
10663 || (format == FFESTV_formatNAMELIST))
10665 spec2 = FFESTP_readixFORMAT;
10666 goto whine; /* :::::::::::::::::::: */
10668 if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present)
10670 spec2 = FFESTP_readixADVANCE;
10671 goto whine; /* :::::::::::::::::::: */
10673 if (ffestp_file.read.read_spec[FFESTP_readixEND].kw_or_val_present)
10675 spec2 = FFESTP_readixEND;
10676 goto whine; /* :::::::::::::::::::: */
10678 if (ffestp_file.read.read_spec[FFESTP_readixEOR].kw_or_val_present)
10680 spec2 = FFESTP_readixEOR;
10681 goto whine; /* :::::::::::::::::::: */
10683 if (ffestp_file.read.read_spec[FFESTP_readixNULLS].kw_or_val_present)
10685 spec2 = FFESTP_readixNULLS;
10686 goto whine; /* :::::::::::::::::::: */
10688 if (ffestp_file.read.read_spec[FFESTP_readixREC].kw_or_val_present)
10690 spec2 = FFESTP_readixREC;
10691 goto whine; /* :::::::::::::::::::: */
10693 if (ffestp_file.read.read_spec[FFESTP_readixSIZE].kw_or_val_present)
10695 spec2 = FFESTP_readixSIZE;
10696 goto whine; /* :::::::::::::::::::: */
10700 { /* Sequential/Internal. */
10701 if (unit == FFESTV_unitCHAREXPR)
10702 { /* Internal file. */
10703 spec1 = FFESTP_readixUNIT;
10704 if (format == FFESTV_formatNAMELIST)
10706 spec2 = FFESTP_readixFORMAT;
10707 goto whine; /* :::::::::::::::::::: */
10709 if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present)
10711 spec2 = FFESTP_readixADVANCE;
10712 goto whine; /* :::::::::::::::::::: */
10715 if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present)
10716 { /* ADVANCE= specified. */
10717 spec1 = FFESTP_readixADVANCE;
10718 if (format == FFESTV_formatNONE)
10720 ffebad_start (FFEBAD_MISSING_FORMAT_SPEC);
10721 ffebad_here (0, ffelex_token_where_line
10722 (ffestp_file.read.read_spec[spec1].kw),
10723 ffelex_token_where_column
10724 (ffestp_file.read.read_spec[spec1].kw));
10727 ffestc_ok_ = FALSE;
10730 if (format == FFESTV_formatNAMELIST)
10732 spec2 = FFESTP_readixFORMAT;
10733 goto whine; /* :::::::::::::::::::: */
10736 if (ffestp_file.read.read_spec[FFESTP_readixEOR].kw_or_val_present)
10737 { /* EOR= specified. */
10738 spec1 = FFESTP_readixEOR;
10739 if (ffestc_subr_speccmp_ ("No",
10740 &ffestp_file.read.read_spec[FFESTP_readixADVANCE],
10743 goto whine_advance; /* :::::::::::::::::::: */
10746 if (ffestp_file.read.read_spec[FFESTP_readixNULLS].kw_or_val_present)
10747 { /* NULLS= specified. */
10748 spec1 = FFESTP_readixNULLS;
10749 if (format != FFESTV_formatASTERISK)
10751 spec2 = FFESTP_readixFORMAT;
10752 goto whine; /* :::::::::::::::::::: */
10755 if (ffestp_file.read.read_spec[FFESTP_readixSIZE].kw_or_val_present)
10756 { /* SIZE= specified. */
10757 spec1 = FFESTP_readixSIZE;
10758 if (ffestc_subr_speccmp_ ("No",
10759 &ffestp_file.read.read_spec[FFESTP_readixADVANCE],
10762 whine_advance: /* :::::::::::::::::::: */
10763 if (ffestp_file.read.read_spec[FFESTP_readixADVANCE]
10764 .kw_or_val_present)
10766 ffebad_start (FFEBAD_CONFLICTING_SPECS);
10767 ffebad_here (0, ffelex_token_where_line
10768 (ffestp_file.read.read_spec[spec1].kw),
10769 ffelex_token_where_column
10770 (ffestp_file.read.read_spec[spec1].kw));
10771 ffebad_here (1, ffelex_token_where_line
10772 (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw),
10773 ffelex_token_where_column
10774 (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw));
10779 ffebad_start (FFEBAD_MISSING_ADVANCE_SPEC);
10780 ffebad_here (0, ffelex_token_where_line
10781 (ffestp_file.read.read_spec[spec1].kw),
10782 ffelex_token_where_column
10783 (ffestp_file.read.read_spec[spec1].kw));
10787 ffestc_ok_ = FALSE;
10793 if (unit == FFESTV_unitCHAREXPR)
10794 ffestc_iolist_context_ = FFEEXPR_contextIOLISTDF;
10796 ffestc_iolist_context_ = FFEEXPR_contextIOLIST;
10798 ffestd_R909_start (FALSE, unit, format, rec, key);
10803 /* ffestc_R909_item -- READ statement i/o item
10805 ffestc_R909_item(expr,expr_token);
10807 Implement output-list expression. */
10810 ffestc_R909_item (ffebld expr, ffelexToken expr_token)
10812 ffestc_check_item_ ();
10816 if (ffestc_namelist_ != 0)
10818 if (ffestc_namelist_ == 1)
10820 ffestc_namelist_ = 2;
10821 ffebad_start (FFEBAD_NAMELIST_ITEMS);
10822 ffebad_here (0, ffelex_token_where_line (expr_token),
10823 ffelex_token_where_column (expr_token));
10829 ffestd_R909_item (expr, expr_token);
10832 /* ffestc_R909_finish -- READ statement list complete
10834 ffestc_R909_finish();
10836 Just wrap up any local activities. */
10839 ffestc_R909_finish ()
10841 ffestc_check_finish_ ();
10845 ffestd_R909_finish ();
10847 if (ffestc_shriek_after1_ != NULL)
10848 (*ffestc_shriek_after1_) (TRUE);
10849 ffestc_labeldef_branch_end_ ();
10852 /* ffestc_R910_start -- WRITE(...) statement list begin
10854 ffestc_R910_start();
10856 Verify that WRITE is valid here, and begin accepting items in the
10860 ffestc_R910_start ()
10863 ffestvFormat format;
10865 ffestpWriteIx spec1;
10866 ffestpWriteIx spec2;
10868 ffestc_check_start_ ();
10869 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
10871 ffestc_ok_ = FALSE;
10874 ffestc_labeldef_branch_begin_ ();
10876 if (!ffestc_subr_is_branch_
10877 (&ffestp_file.write.write_spec[FFESTP_writeixEOR])
10878 || !ffestc_subr_is_branch_
10879 (&ffestp_file.write.write_spec[FFESTP_writeixERR])
10880 || !ffestc_subr_is_format_
10881 (&ffestp_file.write.write_spec[FFESTP_writeixFORMAT]))
10883 ffestc_ok_ = FALSE;
10887 format = ffestc_subr_format_
10888 (&ffestp_file.write.write_spec[FFESTP_writeixFORMAT]);
10889 ffestc_namelist_ = (format == FFESTV_formatNAMELIST);
10891 unit = ffestc_subr_unit_
10892 (&ffestp_file.write.write_spec[FFESTP_writeixUNIT]);
10893 if (unit == FFESTV_unitNONE)
10895 ffebad_start (FFEBAD_NO_UNIT_SPEC);
10896 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
10897 ffelex_token_where_column (ffesta_tokens[0]));
10899 ffestc_ok_ = FALSE;
10903 rec = ffestp_file.write.write_spec[FFESTP_writeixREC].kw_or_val_present;
10907 spec1 = FFESTP_writeixREC;
10908 if (unit == FFESTV_unitCHAREXPR)
10910 spec2 = FFESTP_writeixUNIT;
10911 whine: /* :::::::::::::::::::: */
10912 ffebad_start (FFEBAD_CONFLICTING_SPECS);
10913 assert (ffestp_file.write.write_spec[spec1].kw_or_val_present);
10914 if (ffestp_file.write.write_spec[spec1].kw_present)
10916 ffebad_here (0, ffelex_token_where_line
10917 (ffestp_file.write.write_spec[spec1].kw),
10918 ffelex_token_where_column
10919 (ffestp_file.write.write_spec[spec1].kw));
10923 ffebad_here (0, ffelex_token_where_line
10924 (ffestp_file.write.write_spec[spec1].value),
10925 ffelex_token_where_column
10926 (ffestp_file.write.write_spec[spec1].value));
10928 assert (ffestp_file.write.write_spec[spec2].kw_or_val_present);
10929 if (ffestp_file.write.write_spec[spec2].kw_present)
10931 ffebad_here (1, ffelex_token_where_line
10932 (ffestp_file.write.write_spec[spec2].kw),
10933 ffelex_token_where_column
10934 (ffestp_file.write.write_spec[spec2].kw));
10938 ffebad_here (1, ffelex_token_where_line
10939 (ffestp_file.write.write_spec[spec2].value),
10940 ffelex_token_where_column
10941 (ffestp_file.write.write_spec[spec2].value));
10944 ffestc_ok_ = FALSE;
10947 if ((format == FFESTV_formatASTERISK)
10948 || (format == FFESTV_formatNAMELIST))
10950 spec2 = FFESTP_writeixFORMAT;
10951 goto whine; /* :::::::::::::::::::: */
10953 if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw_or_val_present)
10955 spec2 = FFESTP_writeixADVANCE;
10956 goto whine; /* :::::::::::::::::::: */
10960 { /* Sequential/Indexed/Internal. */
10961 if (unit == FFESTV_unitCHAREXPR)
10962 { /* Internal file. */
10963 spec1 = FFESTP_writeixUNIT;
10964 if (format == FFESTV_formatNAMELIST)
10966 spec2 = FFESTP_writeixFORMAT;
10967 goto whine; /* :::::::::::::::::::: */
10969 if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw_or_val_present)
10971 spec2 = FFESTP_writeixADVANCE;
10972 goto whine; /* :::::::::::::::::::: */
10975 if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw_or_val_present)
10976 { /* ADVANCE= specified. */
10977 spec1 = FFESTP_writeixADVANCE;
10978 if (format == FFESTV_formatNONE)
10980 ffebad_start (FFEBAD_MISSING_FORMAT_SPEC);
10981 ffebad_here (0, ffelex_token_where_line
10982 (ffestp_file.write.write_spec[spec1].kw),
10983 ffelex_token_where_column
10984 (ffestp_file.write.write_spec[spec1].kw));
10987 ffestc_ok_ = FALSE;
10990 if (format == FFESTV_formatNAMELIST)
10992 spec2 = FFESTP_writeixFORMAT;
10993 goto whine; /* :::::::::::::::::::: */
10996 if (ffestp_file.write.write_spec[FFESTP_writeixEOR].kw_or_val_present)
10997 { /* EOR= specified. */
10998 spec1 = FFESTP_writeixEOR;
10999 if (ffestc_subr_speccmp_ ("No",
11000 &ffestp_file.write.write_spec[FFESTP_writeixADVANCE],
11003 if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE]
11004 .kw_or_val_present)
11006 ffebad_start (FFEBAD_CONFLICTING_SPECS);
11007 ffebad_here (0, ffelex_token_where_line
11008 (ffestp_file.write.write_spec[spec1].kw),
11009 ffelex_token_where_column
11010 (ffestp_file.write.write_spec[spec1].kw));
11011 ffebad_here (1, ffelex_token_where_line
11012 (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw),
11013 ffelex_token_where_column
11014 (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw));
11019 ffebad_start (FFEBAD_MISSING_ADVANCE_SPEC);
11020 ffebad_here (0, ffelex_token_where_line
11021 (ffestp_file.write.write_spec[spec1].kw),
11022 ffelex_token_where_column
11023 (ffestp_file.write.write_spec[spec1].kw));
11027 ffestc_ok_ = FALSE;
11033 if (unit == FFESTV_unitCHAREXPR)
11034 ffestc_iolist_context_ = FFEEXPR_contextIOLISTDF;
11036 ffestc_iolist_context_ = FFEEXPR_contextIOLIST;
11038 ffestd_R910_start (unit, format, rec);
11043 /* ffestc_R910_item -- WRITE statement i/o item
11045 ffestc_R910_item(expr,expr_token);
11047 Implement output-list expression. */
11050 ffestc_R910_item (ffebld expr, ffelexToken expr_token)
11052 ffestc_check_item_ ();
11056 if (ffestc_namelist_ != 0)
11058 if (ffestc_namelist_ == 1)
11060 ffestc_namelist_ = 2;
11061 ffebad_start (FFEBAD_NAMELIST_ITEMS);
11062 ffebad_here (0, ffelex_token_where_line (expr_token),
11063 ffelex_token_where_column (expr_token));
11069 ffestd_R910_item (expr, expr_token);
11072 /* ffestc_R910_finish -- WRITE statement list complete
11074 ffestc_R910_finish();
11076 Just wrap up any local activities. */
11079 ffestc_R910_finish ()
11081 ffestc_check_finish_ ();
11085 ffestd_R910_finish ();
11087 if (ffestc_shriek_after1_ != NULL)
11088 (*ffestc_shriek_after1_) (TRUE);
11089 ffestc_labeldef_branch_end_ ();
11092 /* ffestc_R911_start -- PRINT(...) statement list begin
11094 ffestc_R911_start();
11096 Verify that PRINT is valid here, and begin accepting items in the
11100 ffestc_R911_start ()
11102 ffestvFormat format;
11104 ffestc_check_start_ ();
11105 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
11107 ffestc_ok_ = FALSE;
11110 ffestc_labeldef_branch_begin_ ();
11112 if (!ffestc_subr_is_format_
11113 (&ffestp_file.print.print_spec[FFESTP_printixFORMAT]))
11115 ffestc_ok_ = FALSE;
11119 format = ffestc_subr_format_
11120 (&ffestp_file.print.print_spec[FFESTP_printixFORMAT]);
11121 ffestc_namelist_ = (format == FFESTV_formatNAMELIST);
11123 ffestd_R911_start (format);
11128 /* ffestc_R911_item -- PRINT statement i/o item
11130 ffestc_R911_item(expr,expr_token);
11132 Implement output-list expression. */
11135 ffestc_R911_item (ffebld expr, ffelexToken expr_token)
11137 ffestc_check_item_ ();
11141 if (ffestc_namelist_ != 0)
11143 if (ffestc_namelist_ == 1)
11145 ffestc_namelist_ = 2;
11146 ffebad_start (FFEBAD_NAMELIST_ITEMS);
11147 ffebad_here (0, ffelex_token_where_line (expr_token),
11148 ffelex_token_where_column (expr_token));
11154 ffestd_R911_item (expr, expr_token);
11157 /* ffestc_R911_finish -- PRINT statement list complete
11159 ffestc_R911_finish();
11161 Just wrap up any local activities. */
11164 ffestc_R911_finish ()
11166 ffestc_check_finish_ ();
11170 ffestd_R911_finish ();
11172 if (ffestc_shriek_after1_ != NULL)
11173 (*ffestc_shriek_after1_) (TRUE);
11174 ffestc_labeldef_branch_end_ ();
11177 /* ffestc_R919 -- BACKSPACE statement
11181 Make sure a BACKSPACE is valid in the current context, and implement it. */
11186 ffestc_check_simple_ ();
11187 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
11189 ffestc_labeldef_branch_begin_ ();
11191 if (ffestc_subr_is_branch_
11192 (&ffestp_file.beru.beru_spec[FFESTP_beruixERR])
11193 && ffestc_subr_is_present_ ("UNIT",
11194 &ffestp_file.beru.beru_spec[FFESTP_beruixUNIT]))
11197 if (ffestc_shriek_after1_ != NULL)
11198 (*ffestc_shriek_after1_) (TRUE);
11199 ffestc_labeldef_branch_end_ ();
11202 /* ffestc_R920 -- ENDFILE statement
11206 Make sure a ENDFILE is valid in the current context, and implement it. */
11211 ffestc_check_simple_ ();
11212 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
11214 ffestc_labeldef_branch_begin_ ();
11216 if (ffestc_subr_is_branch_
11217 (&ffestp_file.beru.beru_spec[FFESTP_beruixERR])
11218 && ffestc_subr_is_present_ ("UNIT",
11219 &ffestp_file.beru.beru_spec[FFESTP_beruixUNIT]))
11222 if (ffestc_shriek_after1_ != NULL)
11223 (*ffestc_shriek_after1_) (TRUE);
11224 ffestc_labeldef_branch_end_ ();
11227 /* ffestc_R921 -- REWIND statement
11231 Make sure a REWIND is valid in the current context, and implement it. */
11236 ffestc_check_simple_ ();
11237 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
11239 ffestc_labeldef_branch_begin_ ();
11241 if (ffestc_subr_is_branch_
11242 (&ffestp_file.beru.beru_spec[FFESTP_beruixERR])
11243 && ffestc_subr_is_present_ ("UNIT",
11244 &ffestp_file.beru.beru_spec[FFESTP_beruixUNIT]))
11247 if (ffestc_shriek_after1_ != NULL)
11248 (*ffestc_shriek_after1_) (TRUE);
11249 ffestc_labeldef_branch_end_ ();
11252 /* ffestc_R923A -- INQUIRE statement (non-IOLENGTH version)
11256 Make sure an INQUIRE is valid in the current context, and implement it. */
11264 ffestc_check_simple_ ();
11265 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
11267 ffestc_labeldef_branch_begin_ ();
11269 if (ffestc_subr_is_branch_
11270 (&ffestp_file.inquire.inquire_spec[FFESTP_inquireixERR]))
11272 by_file = ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE]
11273 .kw_or_val_present;
11274 by_unit = ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT]
11275 .kw_or_val_present;
11276 if (by_file && by_unit)
11278 ffebad_start (FFEBAD_CONFLICTING_SPECS);
11279 assert (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw_or_val_present);
11280 if (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw_present)
11282 ffebad_here (0, ffelex_token_where_line
11283 (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw),
11284 ffelex_token_where_column
11285 (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw));
11289 ffebad_here (0, ffelex_token_where_line
11290 (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].value),
11291 ffelex_token_where_column
11292 (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].value));
11294 assert (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw_or_val_present);
11295 if (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw_present)
11297 ffebad_here (1, ffelex_token_where_line
11298 (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw),
11299 ffelex_token_where_column
11300 (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw));
11304 ffebad_here (1, ffelex_token_where_line
11305 (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].value),
11306 ffelex_token_where_column
11307 (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].value));
11311 else if (!by_file && !by_unit)
11313 ffebad_start (FFEBAD_MISSING_SPECIFIER);
11314 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
11315 ffelex_token_where_column (ffesta_tokens[0]));
11316 ffebad_string ("UNIT= or FILE=");
11320 ffestd_R923A (by_file);
11323 if (ffestc_shriek_after1_ != NULL)
11324 (*ffestc_shriek_after1_) (TRUE);
11325 ffestc_labeldef_branch_end_ ();
11328 /* ffestc_R923B_start -- INQUIRE(IOLENGTH=expr) statement list begin
11330 ffestc_R923B_start();
11332 Verify that INQUIRE is valid here, and begin accepting items in the
11336 ffestc_R923B_start ()
11338 ffestc_check_start_ ();
11339 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
11341 ffestc_ok_ = FALSE;
11344 ffestc_labeldef_branch_begin_ ();
11346 ffestd_R923B_start ();
11351 /* ffestc_R923B_item -- INQUIRE statement i/o item
11353 ffestc_R923B_item(expr,expr_token);
11355 Implement output-list expression. */
11358 ffestc_R923B_item (ffebld expr, ffelexToken expr_token UNUSED)
11360 ffestc_check_item_ ();
11364 ffestd_R923B_item (expr);
11367 /* ffestc_R923B_finish -- INQUIRE statement list complete
11369 ffestc_R923B_finish();
11371 Just wrap up any local activities. */
11374 ffestc_R923B_finish ()
11376 ffestc_check_finish_ ();
11380 ffestd_R923B_finish ();
11382 if (ffestc_shriek_after1_ != NULL)
11383 (*ffestc_shriek_after1_) (TRUE);
11384 ffestc_labeldef_branch_end_ ();
11387 /* ffestc_R1001 -- FORMAT statement
11389 ffestc_R1001(format_list);
11391 Make sure format_list is valid. Update label's info to indicate it is a
11392 FORMAT label, and (perhaps) warn if there is no label! */
11395 ffestc_R1001 (ffesttFormatList f)
11397 ffestc_check_simple_ ();
11398 if (ffestc_order_format_ () != FFESTC_orderOK_)
11400 ffestc_labeldef_format_ ();
11405 /* ffestc_R1102 -- PROGRAM statement
11407 ffestc_R1102(name_token);
11409 Make sure ffestc_kind_ identifies an empty block. Make sure name_token
11410 gives a valid name. Implement the beginning of a main program. */
11413 ffestc_R1102 (ffelexToken name)
11418 assert (name != NULL);
11420 ffestc_check_simple_ ();
11421 if (ffestc_order_unit_ () != FFESTC_orderOK_)
11423 ffestc_labeldef_useless_ ();
11425 ffestc_blocknum_ = 0;
11426 b = ffestw_update (ffestw_push (NULL));
11427 ffestw_set_top_do (b, NULL);
11428 ffestw_set_state (b, FFESTV_statePROGRAM0);
11429 ffestw_set_blocknum (b, ffestc_blocknum_++);
11430 ffestw_set_shriek (b, ffestc_shriek_end_program_);
11432 ffestw_set_name (b, ffelex_token_use (name));
11434 s = ffesymbol_declare_programunit (name,
11435 ffelex_token_where_line (ffesta_tokens[0]),
11436 ffelex_token_where_column (ffesta_tokens[0]));
11438 if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
11440 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
11441 ffesymbol_set_info (s,
11442 ffeinfo_new (FFEINFO_basictypeNONE,
11443 FFEINFO_kindtypeNONE,
11445 FFEINFO_kindPROGRAM,
11446 FFEINFO_whereLOCAL,
11447 FFETARGET_charactersizeNONE));
11448 ffesymbol_signal_unreported (s);
11451 ffesymbol_error (s, name);
11453 ffestd_R1102 (s, name);
11456 /* ffestc_R1103 -- END PROGRAM statement
11458 ffestc_R1103(name_token);
11460 Make sure ffestc_kind_ identifies the current kind of program unit. If not
11461 NULL, make sure name_token gives the correct name. Implement the end
11462 of the current program unit. */
11465 ffestc_R1103 (ffelexToken name)
11467 ffestc_check_simple_ ();
11468 if (ffestc_order_program_ () != FFESTC_orderOK_)
11470 ffestc_labeldef_notloop_ ();
11474 if (ffestw_name (ffestw_stack_top ()) == NULL)
11476 ffebad_start (FFEBAD_PROGRAM_NOT_NAMED);
11477 ffebad_here (0, ffelex_token_where_line (name),
11478 ffelex_token_where_column (name));
11479 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
11482 else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)
11484 ffebad_start (FFEBAD_UNIT_WRONG_NAME);
11485 ffebad_here (0, ffelex_token_where_line (name),
11486 ffelex_token_where_column (name));
11487 ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
11488 ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
11493 ffestc_shriek_end_program_ (TRUE);
11496 /* ffestc_R1105 -- MODULE statement
11498 ffestc_R1105(name_token);
11500 Make sure ffestc_kind_ identifies an empty block. Make sure name_token
11501 gives a valid name. Implement the beginning of a module. */
11505 ffestc_R1105 (ffelexToken name)
11509 assert (name != NULL);
11511 ffestc_check_simple_ ();
11512 if (ffestc_order_unit_ () != FFESTC_orderOK_)
11514 ffestc_labeldef_useless_ ();
11516 ffestc_blocknum_ = 0;
11517 b = ffestw_update (ffestw_push (NULL));
11518 ffestw_set_top_do (b, NULL);
11519 ffestw_set_state (b, FFESTV_stateMODULE0);
11520 ffestw_set_blocknum (b, ffestc_blocknum_++);
11521 ffestw_set_shriek (b, ffestc_shriek_module_);
11522 ffestw_set_name (b, ffelex_token_use (name));
11524 ffestd_R1105 (name);
11527 /* ffestc_R1106 -- END MODULE statement
11529 ffestc_R1106(name_token);
11531 Make sure ffestc_kind_ identifies the current kind of program unit. If not
11532 NULL, make sure name_token gives the correct name. Implement the end
11533 of the current program unit. */
11536 ffestc_R1106 (ffelexToken name)
11538 ffestc_check_simple_ ();
11539 if (ffestc_order_module_ () != FFESTC_orderOK_)
11541 ffestc_labeldef_useless_ ();
11544 && (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0))
11546 ffebad_start (FFEBAD_UNIT_WRONG_NAME);
11547 ffebad_here (0, ffelex_token_where_line (name),
11548 ffelex_token_where_column (name));
11549 ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
11550 ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
11554 ffestc_shriek_module_ (TRUE);
11557 /* ffestc_R1107_start -- USE statement list begin
11559 ffestc_R1107_start();
11561 Verify that USE is valid here, and begin accepting items in the list. */
11564 ffestc_R1107_start (ffelexToken name, bool only)
11566 ffestc_check_start_ ();
11567 if (ffestc_order_use_ () != FFESTC_orderOK_)
11569 ffestc_ok_ = FALSE;
11572 ffestc_labeldef_useless_ ();
11574 ffestd_R1107_start (name, only);
11579 /* ffestc_R1107_item -- USE statement for name
11581 ffestc_R1107_item(local_token,use_token);
11583 Make sure name_token identifies a valid object to be USEed. local_token
11584 may be NULL if _start_ was called with only==TRUE. */
11587 ffestc_R1107_item (ffelexToken local, ffelexToken use)
11589 ffestc_check_item_ ();
11590 assert (use != NULL);
11594 ffestd_R1107_item (local, use);
11597 /* ffestc_R1107_finish -- USE statement list complete
11599 ffestc_R1107_finish();
11601 Just wrap up any local activities. */
11604 ffestc_R1107_finish ()
11606 ffestc_check_finish_ ();
11610 ffestd_R1107_finish ();
11614 /* ffestc_R1111 -- BLOCK DATA statement
11616 ffestc_R1111(name_token);
11618 Make sure ffestc_kind_ identifies no current program unit. If not
11619 NULL, make sure name_token gives a valid name. Implement the beginning
11620 of a block data program unit. */
11623 ffestc_R1111 (ffelexToken name)
11628 ffestc_check_simple_ ();
11629 if (ffestc_order_unit_ () != FFESTC_orderOK_)
11631 ffestc_labeldef_useless_ ();
11633 ffestc_blocknum_ = 0;
11634 b = ffestw_update (ffestw_push (NULL));
11635 ffestw_set_top_do (b, NULL);
11636 ffestw_set_state (b, FFESTV_stateBLOCKDATA0);
11637 ffestw_set_blocknum (b, ffestc_blocknum_++);
11638 ffestw_set_shriek (b, ffestc_shriek_blockdata_);
11641 ffestw_set_name (b, NULL);
11643 ffestw_set_name (b, ffelex_token_use (name));
11645 s = ffesymbol_declare_blockdataunit (name,
11646 ffelex_token_where_line (ffesta_tokens[0]),
11647 ffelex_token_where_column (ffesta_tokens[0]));
11649 if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
11651 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
11652 ffesymbol_set_info (s,
11653 ffeinfo_new (FFEINFO_basictypeNONE,
11654 FFEINFO_kindtypeNONE,
11656 FFEINFO_kindBLOCKDATA,
11657 FFEINFO_whereLOCAL,
11658 FFETARGET_charactersizeNONE));
11659 ffesymbol_signal_unreported (s);
11662 ffesymbol_error (s, name);
11664 ffestd_R1111 (s, name);
11667 /* ffestc_R1112 -- END BLOCK DATA statement
11669 ffestc_R1112(name_token);
11671 Make sure ffestc_kind_ identifies the current kind of program unit. If not
11672 NULL, make sure name_token gives the correct name. Implement the end
11673 of the current program unit. */
11676 ffestc_R1112 (ffelexToken name)
11678 ffestc_check_simple_ ();
11679 if (ffestc_order_blockdata_ () != FFESTC_orderOK_)
11681 ffestc_labeldef_useless_ ();
11685 if (ffestw_name (ffestw_stack_top ()) == NULL)
11687 ffebad_start (FFEBAD_BLOCKDATA_NOT_NAMED);
11688 ffebad_here (0, ffelex_token_where_line (name),
11689 ffelex_token_where_column (name));
11690 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
11693 else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)
11695 ffebad_start (FFEBAD_UNIT_WRONG_NAME);
11696 ffebad_here (0, ffelex_token_where_line (name),
11697 ffelex_token_where_column (name));
11698 ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
11699 ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
11704 ffestc_shriek_blockdata_ (TRUE);
11707 /* ffestc_R1202 -- INTERFACE statement
11709 ffestc_R1202(operator,defined_name);
11711 Make sure ffestc_kind_ identifies an INTERFACE block.
11712 Implement the end of the current interface.
11715 Allow no operator or name to mean INTERFACE by itself; missed this
11716 valid form when originally doing syntactic analysis code. */
11720 ffestc_R1202 (ffestpDefinedOperator operator, ffelexToken name)
11724 ffestc_check_simple_ ();
11725 if (ffestc_order_interfacespec_ () != FFESTC_orderOK_)
11727 ffestc_labeldef_useless_ ();
11729 b = ffestw_update (ffestw_push (NULL));
11730 ffestw_set_top_do (b, NULL);
11731 ffestw_set_state (b, FFESTV_stateINTERFACE0);
11732 ffestw_set_blocknum (b, 0);
11733 ffestw_set_shriek (b, ffestc_shriek_interface_);
11735 if ((operator == FFESTP_definedoperatorNone) && (name == NULL))
11736 ffestw_set_substate (b, 0); /* No generic-spec, so disallow MODULE
11739 ffestw_set_substate (b, 1); /* MODULE PROCEDURE ok. */
11741 ffestd_R1202 (operator, name);
11746 /* ffestc_R1203 -- END INTERFACE statement
11750 Make sure ffestc_kind_ identifies an INTERFACE block.
11751 Implement the end of the current interface. */
11756 ffestc_check_simple_ ();
11757 if (ffestc_order_interface_ () != FFESTC_orderOK_)
11759 ffestc_labeldef_useless_ ();
11761 ffestc_shriek_interface_ (TRUE);
11763 ffe_terminate_4 ();
11766 /* ffestc_R1205_start -- MODULE PROCEDURE statement list begin
11768 ffestc_R1205_start();
11770 Verify that MODULE PROCEDURE is valid here, and begin accepting items in
11774 ffestc_R1205_start ()
11776 ffestc_check_start_ ();
11777 if (ffestc_order_interface_ () != FFESTC_orderOK_)
11779 ffestc_ok_ = FALSE;
11782 ffestc_labeldef_useless_ ();
11784 if (ffestw_substate (ffestw_stack_top ()) == 0)
11786 ffebad_start (FFEBAD_INVALID_MODULE_PROCEDURE);
11787 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
11788 ffelex_token_where_column (ffesta_tokens[0]));
11789 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
11791 ffestc_ok_ = FALSE;
11795 if (ffestw_state (ffestw_stack_top ()) == FFESTV_stateINTERFACE0)
11797 ffestw_update (NULL); /* Update state line/col info. */
11798 ffestw_set_state (ffestw_stack_top (), FFESTV_stateINTERFACE1);
11801 ffestd_R1205_start ();
11806 /* ffestc_R1205_item -- MODULE PROCEDURE statement for name
11808 ffestc_R1205_item(name_token);
11810 Make sure name_token identifies a valid object to be MODULE PROCEDUREed. */
11813 ffestc_R1205_item (ffelexToken name)
11815 ffestc_check_item_ ();
11816 assert (name != NULL);
11820 ffestd_R1205_item (name);
11823 /* ffestc_R1205_finish -- MODULE PROCEDURE statement list complete
11825 ffestc_R1205_finish();
11827 Just wrap up any local activities. */
11830 ffestc_R1205_finish ()
11832 ffestc_check_finish_ ();
11836 ffestd_R1205_finish ();
11840 /* ffestc_R1207_start -- EXTERNAL statement list begin
11842 ffestc_R1207_start();
11844 Verify that EXTERNAL is valid here, and begin accepting items in the list. */
11847 ffestc_R1207_start ()
11849 ffestc_check_start_ ();
11850 if (ffestc_order_progspec_ () != FFESTC_orderOK_)
11852 ffestc_ok_ = FALSE;
11855 ffestc_labeldef_useless_ ();
11857 ffestd_R1207_start ();
11862 /* ffestc_R1207_item -- EXTERNAL statement for name
11864 ffestc_R1207_item(name_token);
11866 Make sure name_token identifies a valid object to be EXTERNALd. */
11869 ffestc_R1207_item (ffelexToken name)
11875 ffestc_check_item_ ();
11876 assert (name != NULL);
11880 s = ffesymbol_declare_local (name, FALSE);
11881 sa = ffesymbol_attrs (s);
11883 /* Figure out what kind of object we've got based on previous declarations
11884 of or references to the object. */
11886 if (!ffesymbol_is_specable (s))
11887 na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
11888 else if (sa & FFESYMBOL_attrsANY)
11889 na = FFESYMBOL_attrsANY;
11890 else if (!(sa & ~(FFESYMBOL_attrsDUMMY
11891 | FFESYMBOL_attrsTYPE)))
11892 na = sa | FFESYMBOL_attrsEXTERNAL;
11894 na = FFESYMBOL_attrsetNONE;
11896 /* Now see what we've got for a new object: NONE means a new error cropped
11897 up; ANY means an old error to be ignored; otherwise, everything's ok,
11898 update the object (symbol) and continue on. */
11900 if (na == FFESYMBOL_attrsetNONE)
11901 ffesymbol_error (s, name);
11902 else if (!(na & FFESYMBOL_attrsANY))
11904 ffesymbol_set_attrs (s, na);
11905 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
11906 ffesymbol_set_explicitwhere (s, TRUE);
11907 ffesymbol_reference (s, name, FALSE);
11908 ffesymbol_signal_unreported (s);
11911 ffestd_R1207_item (name);
11914 /* ffestc_R1207_finish -- EXTERNAL statement list complete
11916 ffestc_R1207_finish();
11918 Just wrap up any local activities. */
11921 ffestc_R1207_finish ()
11923 ffestc_check_finish_ ();
11927 ffestd_R1207_finish ();
11930 /* ffestc_R1208_start -- INTRINSIC statement list begin
11932 ffestc_R1208_start();
11934 Verify that INTRINSIC is valid here, and begin accepting items in the list. */
11937 ffestc_R1208_start ()
11939 ffestc_check_start_ ();
11940 if (ffestc_order_progspec_ () != FFESTC_orderOK_)
11942 ffestc_ok_ = FALSE;
11945 ffestc_labeldef_useless_ ();
11947 ffestd_R1208_start ();
11952 /* ffestc_R1208_item -- INTRINSIC statement for name
11954 ffestc_R1208_item(name_token);
11956 Make sure name_token identifies a valid object to be INTRINSICd. */
11959 ffestc_R1208_item (ffelexToken name)
11965 ffeintrinSpec spec;
11968 ffestc_check_item_ ();
11969 assert (name != NULL);
11973 s = ffesymbol_declare_local (name, TRUE);
11974 sa = ffesymbol_attrs (s);
11976 /* Figure out what kind of object we've got based on previous declarations
11977 of or references to the object. */
11979 if (!ffesymbol_is_specable (s))
11980 na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
11981 else if (sa & FFESYMBOL_attrsANY)
11983 else if (!(sa & ~FFESYMBOL_attrsTYPE))
11985 if (ffeintrin_is_intrinsic (ffelex_token_text (name), name, TRUE,
11987 && ((imp == FFEINTRIN_impNONE)
11988 #if 0 /* Don't bother with this for now. */
11989 || ((ffeintrin_basictype (spec)
11990 == ffesymbol_basictype (s))
11991 && (ffeintrin_kindtype (spec)
11992 == ffesymbol_kindtype (s)))
11996 || !(sa & FFESYMBOL_attrsTYPE)))
11997 na = sa | FFESYMBOL_attrsINTRINSIC;
11999 na = FFESYMBOL_attrsetNONE;
12002 na = FFESYMBOL_attrsetNONE;
12004 /* Now see what we've got for a new object: NONE means a new error cropped
12005 up; ANY means an old error to be ignored; otherwise, everything's ok,
12006 update the object (symbol) and continue on. */
12008 if (na == FFESYMBOL_attrsetNONE)
12009 ffesymbol_error (s, name);
12010 else if (!(na & FFESYMBOL_attrsANY))
12012 ffesymbol_set_attrs (s, na);
12013 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
12014 ffesymbol_set_generic (s, gen);
12015 ffesymbol_set_specific (s, spec);
12016 ffesymbol_set_implementation (s, imp);
12017 ffesymbol_set_info (s,
12018 ffeinfo_new (ffesymbol_basictype (s),
12019 ffesymbol_kindtype (s),
12022 FFEINFO_whereINTRINSIC,
12023 ffesymbol_size (s)));
12024 ffesymbol_set_explicitwhere (s, TRUE);
12025 ffesymbol_reference (s, name, TRUE);
12028 ffesymbol_signal_unreported (s);
12030 ffestd_R1208_item (name);
12033 /* ffestc_R1208_finish -- INTRINSIC statement list complete
12035 ffestc_R1208_finish();
12037 Just wrap up any local activities. */
12040 ffestc_R1208_finish ()
12042 ffestc_check_finish_ ();
12046 ffestd_R1208_finish ();
12049 /* ffestc_R1212 -- CALL statement
12051 ffestc_R1212(expr,expr_token);
12053 Make sure statement is valid here; implement. */
12056 ffestc_R1212 (ffebld expr, ffelexToken expr_token UNUSED)
12058 ffebld item; /* ITEM. */
12059 ffebld labexpr; /* LABTOK=>LABTER. */
12061 bool ok; /* TRUE if all LABTOKs were ok. */
12062 bool ok1; /* TRUE if a particular LABTOK is ok. */
12064 ffestc_check_simple_ ();
12065 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
12067 ffestc_labeldef_branch_begin_ ();
12069 if (ffebld_op (expr) != FFEBLD_opSUBRREF)
12070 ffestd_R841 (FALSE); /* CONTINUE. */
12075 for (item = ffebld_right (expr);
12077 item = ffebld_trail (item))
12079 if (((labexpr = ffebld_head (item)) != NULL)
12080 && (ffebld_op (labexpr) == FFEBLD_opLABTOK))
12082 ok1 = ffestc_labelref_is_branch_ (ffebld_labtok (labexpr),
12084 ffelex_token_kill (ffebld_labtok (labexpr));
12090 ffebld_set_op (labexpr, FFEBLD_opLABTER);
12091 ffebld_set_labter (labexpr, label);
12096 ffestd_R1212 (expr);
12099 if (ffestc_shriek_after1_ != NULL)
12100 (*ffestc_shriek_after1_) (TRUE);
12101 ffestc_labeldef_branch_end_ ();
12104 /* ffestc_R1213 -- Defined assignment statement
12106 ffestc_R1213(dest_expr,source_expr,source_token);
12108 Make sure the assignment is valid. */
12112 ffestc_R1213 (ffebld dest, ffebld source, ffelexToken source_token)
12114 ffestc_check_simple_ ();
12115 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
12117 ffestc_labeldef_branch_begin_ ();
12119 ffestd_R1213 (dest, source);
12121 if (ffestc_shriek_after1_ != NULL)
12122 (*ffestc_shriek_after1_) (TRUE);
12123 ffestc_labeldef_branch_end_ ();
12127 /* ffestc_R1219 -- FUNCTION statement
12129 ffestc_R1219(funcname,arglist,ending_token,kind,kindt,len,lent,
12132 Make sure statement is valid here, register arguments for the
12133 function name, and so on.
12136 Added the kind, len, and recursive arguments. */
12139 ffestc_R1219 (ffelexToken funcname, ffesttTokenList args,
12140 ffelexToken final UNUSED, ffestpType type, ffebld kind,
12141 ffelexToken kindt, ffebld len, ffelexToken lent,
12142 ffelexToken recursive, ffelexToken result)
12146 ffesymbol fs; /* FUNCTION symbol when dealing with RESULT
12151 bool separate_result;
12153 assert ((funcname != NULL)
12154 && (ffelex_token_type (funcname) == FFELEX_typeNAME));
12156 ffestc_check_simple_ ();
12157 if (ffestc_order_iface_ () != FFESTC_orderOK_)
12159 ffestc_labeldef_useless_ ();
12161 ffestc_blocknum_ = 0;
12162 ffesta_is_entry_valid =
12163 (ffestw_state (ffestw_stack_top ()) == FFESTV_stateNIL);
12164 b = ffestw_update (ffestw_push (NULL));
12165 ffestw_set_top_do (b, NULL);
12166 ffestw_set_state (b, FFESTV_stateFUNCTION0);
12167 ffestw_set_blocknum (b, ffestc_blocknum_++);
12168 ffestw_set_shriek (b, ffestc_shriek_function_);
12169 ffestw_set_name (b, ffelex_token_use (funcname));
12171 if (type == FFESTP_typeNone)
12173 ffestc_local_.decl.basic_type = FFEINFO_basictypeNONE;
12174 ffestc_local_.decl.kind_type = FFEINFO_kindtypeNONE;
12175 ffestc_local_.decl.size = FFETARGET_charactersizeNONE;
12179 ffestc_establish_declstmt_ (type, ffesta_tokens[0],
12180 kind, kindt, len, lent);
12181 ffestc_establish_declinfo_ (NULL, NULL, NULL, NULL);
12184 separate_result = (result != NULL)
12185 && (ffelex_token_strcmp (funcname, result) != 0);
12187 if (separate_result)
12188 fs = ffesymbol_declare_funcnotresunit (funcname); /* Global/local. */
12190 fs = ffesymbol_declare_funcunit (funcname); /* Global only. */
12192 if (ffesymbol_state (fs) == FFESYMBOL_stateNONE)
12194 ffesymbol_set_state (fs, FFESYMBOL_stateUNDERSTOOD);
12195 ffesymbol_signal_unreported (fs);
12197 /* Note that .basic_type and .kind_type might be NONE here. */
12199 ffesymbol_set_info (fs,
12200 ffeinfo_new (ffestc_local_.decl.basic_type,
12201 ffestc_local_.decl.kind_type,
12203 FFEINFO_kindFUNCTION,
12204 FFEINFO_whereLOCAL,
12205 ffestc_local_.decl.size));
12207 /* Check whether the type info fits the filewide expectations;
12208 set ok flag accordingly. */
12210 ffesymbol_reference (fs, funcname, FALSE);
12211 if (ffesymbol_attrs (fs) & FFESYMBOL_attrsANY)
12212 ffestc_parent_ok_ = FALSE;
12214 ffestc_parent_ok_ = TRUE;
12218 if (ffesymbol_kind (fs) != FFEINFO_kindANY)
12219 ffesymbol_error (fs, funcname);
12220 ffestc_parent_ok_ = FALSE;
12223 if (ffestc_parent_ok_)
12225 ffebld_init_list (&fs->dummy_args, &ffestc_local_.dummy.list_bottom);
12226 ffestt_tokenlist_drive (args, ffestc_promote_dummy_);
12227 ffebld_end_list (&ffestc_local_.dummy.list_bottom);
12230 if (result == NULL)
12235 s = ffesymbol_declare_funcresult (res);
12236 sa = ffesymbol_attrs (s);
12238 /* Figure out what kind of object we've got based on previous declarations
12239 of or references to the object. */
12241 if (sa & FFESYMBOL_attrsANY)
12242 na = FFESYMBOL_attrsANY;
12243 else if (ffesymbol_state (s) != FFESYMBOL_stateNONE)
12244 na = FFESYMBOL_attrsetNONE;
12247 na = FFESYMBOL_attrsRESULT;
12248 if (ffestc_local_.decl.basic_type != FFEINFO_basictypeNONE)
12250 na |= FFESYMBOL_attrsTYPE;
12251 if ((ffestc_local_.decl.basic_type == FFEINFO_basictypeCHARACTER)
12252 && (ffestc_local_.decl.size == FFETARGET_charactersizeNONE))
12253 na |= FFESYMBOL_attrsANYLEN;
12257 /* Now see what we've got for a new object: NONE means a new error cropped
12258 up; ANY means an old error to be ignored; otherwise, everything's ok,
12259 update the object (symbol) and continue on. */
12261 if ((na & ~FFESYMBOL_attrsANY) == FFESYMBOL_attrsetNONE)
12263 if (!(na & FFESYMBOL_attrsANY))
12264 ffesymbol_error (s, res);
12265 ffesymbol_set_funcresult (fs, NULL);
12266 ffesymbol_set_funcresult (s, NULL);
12267 ffestc_parent_ok_ = FALSE;
12271 ffesymbol_set_attrs (s, na);
12272 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
12273 ffesymbol_set_funcresult (fs, s);
12274 ffesymbol_set_funcresult (s, fs);
12275 if (ffestc_local_.decl.basic_type != FFEINFO_basictypeNONE)
12277 ffesymbol_set_info (s,
12278 ffeinfo_new (ffestc_local_.decl.basic_type,
12279 ffestc_local_.decl.kind_type,
12283 ffestc_local_.decl.size));
12287 ffesymbol_signal_unreported (fs);
12289 ffestd_R1219 (fs, funcname, args, type, kind, kindt, len, lent,
12290 (recursive != NULL), result, separate_result);
12293 /* ffestc_R1221 -- END FUNCTION statement
12295 ffestc_R1221(name_token);
12297 Make sure ffestc_kind_ identifies the current kind of program unit. If
12298 not NULL, make sure name_token gives the correct name. Implement the end
12299 of the current program unit. */
12302 ffestc_R1221 (ffelexToken name)
12304 ffestc_check_simple_ ();
12305 if (ffestc_order_function_ () != FFESTC_orderOK_)
12307 ffestc_labeldef_notloop_ ();
12310 && (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0))
12312 ffebad_start (FFEBAD_UNIT_WRONG_NAME);
12313 ffebad_here (0, ffelex_token_where_line (name),
12314 ffelex_token_where_column (name));
12315 ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
12316 ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
12320 ffestc_shriek_function_ (TRUE);
12323 /* ffestc_R1223 -- SUBROUTINE statement
12325 ffestc_R1223(subrname,arglist,ending_token,recursive_token);
12327 Make sure statement is valid here, register arguments for the
12328 subroutine name, and so on.
12331 Added the recursive argument. */
12334 ffestc_R1223 (ffelexToken subrname, ffesttTokenList args,
12335 ffelexToken final, ffelexToken recursive)
12340 assert ((subrname != NULL)
12341 && (ffelex_token_type (subrname) == FFELEX_typeNAME));
12343 ffestc_check_simple_ ();
12344 if (ffestc_order_iface_ () != FFESTC_orderOK_)
12346 ffestc_labeldef_useless_ ();
12348 ffestc_blocknum_ = 0;
12349 ffesta_is_entry_valid
12350 = (ffestw_state (ffestw_stack_top ()) == FFESTV_stateNIL);
12351 b = ffestw_update (ffestw_push (NULL));
12352 ffestw_set_top_do (b, NULL);
12353 ffestw_set_state (b, FFESTV_stateSUBROUTINE0);
12354 ffestw_set_blocknum (b, ffestc_blocknum_++);
12355 ffestw_set_shriek (b, ffestc_shriek_subroutine_);
12356 ffestw_set_name (b, ffelex_token_use (subrname));
12358 s = ffesymbol_declare_subrunit (subrname);
12359 if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
12361 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
12362 ffesymbol_set_info (s,
12363 ffeinfo_new (FFEINFO_basictypeNONE,
12364 FFEINFO_kindtypeNONE,
12366 FFEINFO_kindSUBROUTINE,
12367 FFEINFO_whereLOCAL,
12368 FFETARGET_charactersizeNONE));
12369 ffestc_parent_ok_ = TRUE;
12373 if (ffesymbol_kind (s) != FFEINFO_kindANY)
12374 ffesymbol_error (s, subrname);
12375 ffestc_parent_ok_ = FALSE;
12378 if (ffestc_parent_ok_)
12380 ffebld_init_list (&s->dummy_args, &ffestc_local_.dummy.list_bottom);
12381 ffestt_tokenlist_drive (args, ffestc_promote_dummy_);
12382 ffebld_end_list (&ffestc_local_.dummy.list_bottom);
12385 ffesymbol_signal_unreported (s);
12387 ffestd_R1223 (s, subrname, args, final, (recursive != NULL));
12390 /* ffestc_R1225 -- END SUBROUTINE statement
12392 ffestc_R1225(name_token);
12394 Make sure ffestc_kind_ identifies the current kind of program unit. If
12395 not NULL, make sure name_token gives the correct name. Implement the end
12396 of the current program unit. */
12399 ffestc_R1225 (ffelexToken name)
12401 ffestc_check_simple_ ();
12402 if (ffestc_order_subroutine_ () != FFESTC_orderOK_)
12404 ffestc_labeldef_notloop_ ();
12407 && (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0))
12409 ffebad_start (FFEBAD_UNIT_WRONG_NAME);
12410 ffebad_here (0, ffelex_token_where_line (name),
12411 ffelex_token_where_column (name));
12412 ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
12413 ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
12417 ffestc_shriek_subroutine_ (TRUE);
12420 /* ffestc_R1226 -- ENTRY statement
12422 ffestc_R1226(entryname,arglist,ending_token);
12424 Make sure we're in a SUBROUTINE or FUNCTION, register arguments for the
12425 entry point name, and so on. */
12428 ffestc_R1226 (ffelexToken entryname, ffesttTokenList args,
12429 ffelexToken final UNUSED)
12435 bool in_spec; /* TRUE if further specification statements
12436 may follow, FALSE if executable stmts. */
12437 bool in_func; /* TRUE if ENTRY is a FUNCTION, not
12440 assert ((entryname != NULL)
12441 && (ffelex_token_type (entryname) == FFELEX_typeNAME));
12443 ffestc_check_simple_ ();
12444 if (ffestc_order_entry_ () != FFESTC_orderOK_)
12446 ffestc_labeldef_useless_ ();
12448 switch (ffestw_state (ffestw_stack_top ()))
12450 case FFESTV_stateFUNCTION1:
12451 case FFESTV_stateFUNCTION2:
12452 case FFESTV_stateFUNCTION3:
12457 case FFESTV_stateFUNCTION4:
12462 case FFESTV_stateSUBROUTINE1:
12463 case FFESTV_stateSUBROUTINE2:
12464 case FFESTV_stateSUBROUTINE3:
12469 case FFESTV_stateSUBROUTINE4:
12475 assert ("ENTRY not in FUNCTION or SUBROUTINE?" == NULL);
12482 fs = ffesymbol_declare_funcunit (entryname);
12484 fs = ffesymbol_declare_subrunit (entryname);
12486 if (ffesymbol_state (fs) == FFESYMBOL_stateNONE)
12487 ffesymbol_set_state (fs, FFESYMBOL_stateUNDERSTOOD);
12490 if (ffesymbol_kind (fs) != FFEINFO_kindANY)
12491 ffesymbol_error (fs, entryname);
12494 ++ffestc_entry_num_;
12496 ffebld_init_list (&fs->dummy_args, &ffestc_local_.dummy.list_bottom);
12498 ffestt_tokenlist_drive (args, ffestc_promote_dummy_);
12500 ffestt_tokenlist_drive (args, ffestc_promote_execdummy_);
12501 ffebld_end_list (&ffestc_local_.dummy.list_bottom);
12505 s = ffesymbol_declare_funcresult (entryname);
12506 ffesymbol_set_funcresult (fs, s);
12507 ffesymbol_set_funcresult (s, fs);
12508 sa = ffesymbol_attrs (s);
12510 /* Figure out what kind of object we've got based on previous
12511 declarations of or references to the object. */
12513 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
12514 na = FFESYMBOL_attrsetNONE;
12515 else if (sa & FFESYMBOL_attrsANY)
12516 na = FFESYMBOL_attrsANY;
12517 else if (!(sa & ~(FFESYMBOL_attrsANYLEN
12518 | FFESYMBOL_attrsTYPE)))
12519 na = sa | FFESYMBOL_attrsRESULT;
12521 na = FFESYMBOL_attrsetNONE;
12523 /* Now see what we've got for a new object: NONE means a new error
12524 cropped up; ANY means an old error to be ignored; otherwise,
12525 everything's ok, update the object (symbol) and continue on. */
12527 if (na == FFESYMBOL_attrsetNONE)
12529 ffesymbol_error (s, entryname);
12530 ffestc_parent_ok_ = FALSE;
12532 else if (na & FFESYMBOL_attrsANY)
12534 ffestc_parent_ok_ = FALSE;
12538 ffesymbol_set_attrs (s, na);
12539 if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
12540 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
12541 else if (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN)
12543 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
12544 ffesymbol_set_info (s,
12545 ffeinfo_new (ffesymbol_basictype (s),
12546 ffesymbol_kindtype (s),
12548 FFEINFO_kindENTITY,
12549 FFEINFO_whereRESULT,
12550 ffesymbol_size (s)));
12551 ffesymbol_resolve_intrin (s);
12552 ffestorag_exec_layout (s);
12556 /* Since ENTRY might appear after executable stmts, do what would have
12557 been done if it hadn't -- give symbol implicit type and
12558 exec-transition it. */
12560 if (!in_spec && ffesymbol_is_specable (s))
12562 if (!ffeimplic_establish_symbol (s)) /* Do implicit typing. */
12563 ffesymbol_error (s, entryname);
12564 s = ffecom_sym_exec_transition (s);
12567 /* Use whatever type info is available for ENTRY to set up type for its
12568 global-name-space function symbol relative. */
12570 ffesymbol_set_info (fs,
12571 ffeinfo_new (ffesymbol_basictype (s),
12572 ffesymbol_kindtype (s),
12574 FFEINFO_kindFUNCTION,
12575 FFEINFO_whereLOCAL,
12576 ffesymbol_size (s)));
12579 /* Check whether the type info fits the filewide expectations;
12580 set ok flag accordingly. */
12582 ffesymbol_reference (fs, entryname, FALSE);
12585 When ENTRY FOO() RESULT(IBAR) is supported, what will the typing be
12586 if FOO and IBAR would normally end up with different types? I think
12587 the answer is that FOO is always given whatever type would be chosen
12588 for IBAR, rather than the other way around, and I think it ends up
12589 working that way for FUNCTION FOO() RESULT(IBAR), but this should be
12590 checked out in all its different combos. Related question is, is
12591 there any way that FOO in either case ends up without type info
12592 filled in? Does anyone care? */
12594 ffesymbol_signal_unreported (s);
12598 ffesymbol_set_info (fs,
12599 ffeinfo_new (FFEINFO_basictypeNONE,
12600 FFEINFO_kindtypeNONE,
12602 FFEINFO_kindSUBROUTINE,
12603 FFEINFO_whereLOCAL,
12604 FFETARGET_charactersizeNONE));
12608 fs = ffecom_sym_exec_transition (fs);
12610 ffesymbol_signal_unreported (fs);
12615 /* ffestc_R1227 -- RETURN statement
12617 ffestc_R1227(expr,expr_token);
12619 Make sure statement is valid here; implement. expr and expr_token are
12620 both NULL if there was no expression. */
12623 ffestc_R1227 (ffebld expr, ffelexToken expr_token)
12627 ffestc_check_simple_ ();
12628 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
12630 ffestc_labeldef_notloop_begin_ ();
12632 for (b = ffestw_stack_top (); ; b = ffestw_previous (b))
12634 switch (ffestw_state (b))
12636 case FFESTV_statePROGRAM4:
12637 case FFESTV_stateSUBROUTINE4:
12638 case FFESTV_stateFUNCTION4:
12639 goto base; /* :::::::::::::::::::: */
12641 case FFESTV_stateNIL:
12642 assert ("bad state" == NULL);
12651 switch (ffestw_state (b))
12653 case FFESTV_statePROGRAM4:
12654 if (ffe_is_pedantic ())
12656 ffebad_start (FFEBAD_RETURN_IN_MAIN);
12657 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
12658 ffelex_token_where_column (ffesta_tokens[0]));
12663 ffebad_start (FFEBAD_ALTRETURN_IN_PROGRAM);
12664 ffebad_here (0, ffelex_token_where_line (expr_token),
12665 ffelex_token_where_column (expr_token));
12671 case FFESTV_stateSUBROUTINE4:
12674 case FFESTV_stateFUNCTION4:
12677 ffebad_start (FFEBAD_ALTRETURN_IN_FUNCTION);
12678 ffebad_here (0, ffelex_token_where_line (expr_token),
12679 ffelex_token_where_column (expr_token));
12686 assert ("bad state #2" == NULL);
12690 ffestd_R1227 (expr);
12692 if (ffestc_shriek_after1_ != NULL)
12693 (*ffestc_shriek_after1_) (TRUE);
12695 /* notloop's that are actionif's can be the target of a loop-end
12696 statement if they're in the "then" part of a logical IF, as
12697 in "DO 10", "10 IF (...) RETURN". */
12699 ffestc_labeldef_branch_end_ ();
12702 /* ffestc_R1228 -- CONTAINS statement
12710 ffestc_check_simple_ ();
12711 if (ffestc_order_contains_ () != FFESTC_orderOK_)
12713 ffestc_labeldef_useless_ ();
12717 ffe_terminate_3 ();
12722 /* ffestc_R1229_start -- STMTFUNCTION statement begin
12724 ffestc_R1229_start(func_name,func_arg_list,close_paren);
12726 Verify that STMTFUNCTION is valid here, establish func_arg_list in a new
12727 "live" scope within the current scope, and expect the actual expression
12728 (or NULL) in ffestc_R1229_finish. The reason there are two ffestc
12729 functions to handle this is so the scope can be established, allowing
12730 ffeexpr to assign proper characteristics to references to the dummy
12734 ffestc_R1229_start (ffelexToken name, ffesttTokenList args,
12735 ffelexToken final UNUSED)
12741 ffestc_check_start_ ();
12742 if (ffestc_order_sfunc_ () != FFESTC_orderOK_)
12744 ffestc_ok_ = FALSE;
12747 ffestc_labeldef_useless_ ();
12749 assert (name != NULL);
12750 assert (args != NULL);
12752 s = ffesymbol_declare_local (name, FALSE);
12753 sa = ffesymbol_attrs (s);
12755 /* Figure out what kind of object we've got based on previous declarations
12756 of or references to the object. */
12758 if (!ffesymbol_is_specable (s))
12759 na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
12760 else if (sa & FFESYMBOL_attrsANY)
12761 na = FFESYMBOL_attrsANY;
12762 else if (!(sa & ~FFESYMBOL_attrsTYPE))
12763 na = sa | FFESYMBOL_attrsSFUNC;
12765 na = FFESYMBOL_attrsetNONE;
12767 /* Now see what we've got for a new object: NONE means a new error cropped
12768 up; ANY means an old error to be ignored; otherwise, everything's ok,
12769 update the object (symbol) and continue on. */
12771 if (na == FFESYMBOL_attrsetNONE)
12773 ffesymbol_error (s, name);
12774 ffestc_parent_ok_ = FALSE;
12776 else if (na & FFESYMBOL_attrsANY)
12777 ffestc_parent_ok_ = FALSE;
12780 ffesymbol_set_attrs (s, na);
12781 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
12782 if (!ffeimplic_establish_symbol (s)
12783 || ((ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
12784 && (ffesymbol_size (s) == FFETARGET_charactersizeNONE)))
12786 ffesymbol_error (s, ffesta_tokens[0]);
12787 ffestc_parent_ok_ = FALSE;
12791 /* Tell ffeexpr that sfunc def is in progress. */
12792 ffesymbol_set_sfexpr (s, ffebld_new_any ());
12793 ffebld_set_info (ffesymbol_sfexpr (s), ffeinfo_new_any ());
12794 ffestc_parent_ok_ = TRUE;
12800 if (ffestc_parent_ok_)
12802 ffebld_init_list (&s->dummy_args, &ffestc_local_.dummy.list_bottom);
12803 ffestc_sfdummy_argno_ = 0;
12804 ffestt_tokenlist_drive (args, ffestc_promote_sfdummy_);
12805 ffebld_end_list (&ffestc_local_.dummy.list_bottom);
12808 ffestc_local_.sfunc.symbol = s;
12810 ffestd_R1229_start (name, args);
12815 /* ffestc_R1229_finish -- STMTFUNCTION statement list complete
12817 ffestc_R1229_finish(expr,expr_token);
12819 If expr is NULL, an error occurred parsing the expansion expression, so
12820 just cancel the effects of ffestc_R1229_start and pretend nothing
12821 happened. Otherwise, install the expression as the expansion for the
12822 statement function named in _start_, then clean up. */
12825 ffestc_R1229_finish (ffebld expr, ffelexToken expr_token)
12827 ffestc_check_finish_ ();
12831 if (ffestc_parent_ok_ && (expr != NULL))
12832 ffesymbol_set_sfexpr (ffestc_local_.sfunc.symbol,
12833 ffeexpr_convert_to_sym (expr,
12835 ffestc_local_.sfunc.symbol,
12836 ffesta_tokens[0]));
12838 ffestd_R1229_finish (ffestc_local_.sfunc.symbol);
12840 ffesymbol_signal_unreported (ffestc_local_.sfunc.symbol);
12842 ffe_terminate_4 ();
12845 /* ffestc_S3P4 -- INCLUDE line
12847 ffestc_S3P4(filename,filename_token);
12849 Make sure INCLUDE not preceded by any semicolons or a label def; implement. */
12852 ffestc_S3P4 (ffebld filename, ffelexToken filename_token UNUSED)
12854 ffestc_check_simple_ ();
12855 ffestc_labeldef_invalid_ ();
12857 ffestd_S3P4 (filename);
12860 /* ffestc_V003_start -- STRUCTURE statement list begin
12862 ffestc_V003_start(structure_name);
12864 Verify that STRUCTURE is valid here, and begin accepting items in the list. */
12868 ffestc_V003_start (ffelexToken structure_name)
12872 ffestc_check_start_ ();
12873 if (ffestc_order_vxtstructure_ () != FFESTC_orderOK_)
12875 ffestc_ok_ = FALSE;
12878 ffestc_labeldef_useless_ ();
12880 switch (ffestw_state (ffestw_stack_top ()))
12882 case FFESTV_stateSTRUCTURE:
12883 case FFESTV_stateMAP:
12884 ffestc_local_.V003.list_state = 2; /* Require at least one field
12886 ffestw_set_substate (ffestw_stack_top (), 1); /* Seen at least one
12891 ffestc_local_.V003.list_state = 0; /* No field names required. */
12892 if (structure_name == NULL)
12894 ffebad_start (FFEBAD_STRUCT_MISSING_NAME);
12895 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
12896 ffelex_token_where_column (ffesta_tokens[0]));
12902 b = ffestw_update (ffestw_push (NULL));
12903 ffestw_set_top_do (b, NULL);
12904 ffestw_set_state (b, FFESTV_stateSTRUCTURE);
12905 ffestw_set_blocknum (b, 0);
12906 ffestw_set_shriek (b, ffestc_shriek_structure_);
12907 ffestw_set_substate (b, 0); /* No field-declarations seen yet. */
12909 ffestd_V003_start (structure_name);
12914 /* ffestc_V003_item -- STRUCTURE statement for object-name
12916 ffestc_V003_item(name_token,dim_list);
12918 Make sure name_token identifies a valid object to be STRUCTUREd. */
12921 ffestc_V003_item (ffelexToken name, ffesttDimList dims)
12923 ffestc_check_item_ ();
12924 assert (name != NULL);
12928 if (ffestc_local_.V003.list_state < 2)
12930 if (ffestc_local_.V003.list_state == 0)
12932 ffestc_local_.V003.list_state = 1;
12933 ffebad_start (FFEBAD_STRUCT_IGNORING_FIELD);
12934 ffebad_here (0, ffelex_token_where_line (name),
12935 ffelex_token_where_column (name));
12940 ffestc_local_.V003.list_state = 3; /* Have at least one field name. */
12943 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
12945 ffestd_V003_item (name, dims);
12948 /* ffestc_V003_finish -- STRUCTURE statement list complete
12950 ffestc_V003_finish();
12952 Just wrap up any local activities. */
12955 ffestc_V003_finish ()
12957 ffestc_check_finish_ ();
12961 if (ffestc_local_.V003.list_state == 2)
12963 ffebad_start (FFEBAD_STRUCT_MISSING_FIELD);
12964 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
12965 ffelex_token_where_column (ffesta_tokens[0]));
12966 ffebad_here (1, ffestw_line (ffestw_previous (ffestw_stack_top ())),
12967 ffestw_col (ffestw_previous (ffestw_stack_top ())));
12971 ffestd_V003_finish ();
12974 /* ffestc_V004 -- END STRUCTURE statement
12978 Make sure ffestc_kind_ identifies a STRUCTURE block.
12979 Implement the end of the current STRUCTURE block. */
12984 ffestc_check_simple_ ();
12985 if (ffestc_order_structure_ () != FFESTC_orderOK_)
12987 ffestc_labeldef_useless_ ();
12989 if (ffestw_substate (ffestw_stack_top ()) != 1)
12991 ffebad_start (FFEBAD_STRUCT_NO_COMPONENTS);
12992 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
12993 ffelex_token_where_column (ffesta_tokens[0]));
12994 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
12998 ffestc_shriek_structure_ (TRUE);
13001 /* ffestc_V009 -- UNION statement
13010 ffestc_check_simple_ ();
13011 if (ffestc_order_structure_ () != FFESTC_orderOK_)
13013 ffestc_labeldef_useless_ ();
13015 ffestw_set_substate (ffestw_stack_top (), 1); /* Seen at least one member. */
13017 b = ffestw_update (ffestw_push (NULL));
13018 ffestw_set_top_do (b, NULL);
13019 ffestw_set_state (b, FFESTV_stateUNION);
13020 ffestw_set_blocknum (b, 0);
13021 ffestw_set_shriek (b, ffestc_shriek_union_);
13022 ffestw_set_substate (b, 0); /* No map decls seen yet. */
13027 /* ffestc_V010 -- END UNION statement
13031 Make sure ffestc_kind_ identifies a UNION block.
13032 Implement the end of the current UNION block. */
13037 ffestc_check_simple_ ();
13038 if (ffestc_order_union_ () != FFESTC_orderOK_)
13040 ffestc_labeldef_useless_ ();
13042 if (ffestw_substate (ffestw_stack_top ()) != 2)
13044 ffebad_start (FFEBAD_UNION_NO_TWO_MAPS);
13045 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
13046 ffelex_token_where_column (ffesta_tokens[0]));
13047 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
13051 ffestc_shriek_union_ (TRUE);
13054 /* ffestc_V012 -- MAP statement
13063 ffestc_check_simple_ ();
13064 if (ffestc_order_union_ () != FFESTC_orderOK_)
13066 ffestc_labeldef_useless_ ();
13068 if (ffestw_substate (ffestw_stack_top ()) != 2)
13069 ffestw_substate (ffestw_stack_top ())++; /* 0=>1, 1=>2. */
13071 b = ffestw_update (ffestw_push (NULL));
13072 ffestw_set_top_do (b, NULL);
13073 ffestw_set_state (b, FFESTV_stateMAP);
13074 ffestw_set_blocknum (b, 0);
13075 ffestw_set_shriek (b, ffestc_shriek_map_);
13076 ffestw_set_substate (b, 0); /* No field-declarations seen yet. */
13081 /* ffestc_V013 -- END MAP statement
13085 Make sure ffestc_kind_ identifies a MAP block.
13086 Implement the end of the current MAP block. */
13091 ffestc_check_simple_ ();
13092 if (ffestc_order_map_ () != FFESTC_orderOK_)
13094 ffestc_labeldef_useless_ ();
13096 if (ffestw_substate (ffestw_stack_top ()) != 1)
13098 ffebad_start (FFEBAD_MAP_NO_COMPONENTS);
13099 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
13100 ffelex_token_where_column (ffesta_tokens[0]));
13101 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
13105 ffestc_shriek_map_ (TRUE);
13109 /* ffestc_V014_start -- VOLATILE statement list begin
13111 ffestc_V014_start();
13113 Verify that VOLATILE is valid here, and begin accepting items in the
13117 ffestc_V014_start ()
13119 ffestc_check_start_ ();
13120 if (ffestc_order_progspec_ () != FFESTC_orderOK_)
13122 ffestc_ok_ = FALSE;
13125 ffestc_labeldef_useless_ ();
13127 ffestd_V014_start ();
13132 /* ffestc_V014_item_object -- VOLATILE statement for object-name
13134 ffestc_V014_item_object(name_token);
13136 Make sure name_token identifies a valid object to be VOLATILEd. */
13139 ffestc_V014_item_object (ffelexToken name)
13141 ffestc_check_item_ ();
13142 assert (name != NULL);
13146 ffestd_V014_item_object (name);
13149 /* ffestc_V014_item_cblock -- VOLATILE statement for common-block-name
13151 ffestc_V014_item_cblock(name_token);
13153 Make sure name_token identifies a valid common block to be VOLATILEd. */
13156 ffestc_V014_item_cblock (ffelexToken name)
13158 ffestc_check_item_ ();
13159 assert (name != NULL);
13163 ffestd_V014_item_cblock (name);
13166 /* ffestc_V014_finish -- VOLATILE statement list complete
13168 ffestc_V014_finish();
13170 Just wrap up any local activities. */
13173 ffestc_V014_finish ()
13175 ffestc_check_finish_ ();
13179 ffestd_V014_finish ();
13182 /* ffestc_V016_start -- RECORD statement list begin
13184 ffestc_V016_start();
13186 Verify that RECORD is valid here, and begin accepting items in the list. */
13190 ffestc_V016_start ()
13192 ffestc_check_start_ ();
13193 if (ffestc_order_record_ () != FFESTC_orderOK_)
13195 ffestc_ok_ = FALSE;
13198 ffestc_labeldef_useless_ ();
13200 switch (ffestw_state (ffestw_stack_top ()))
13202 case FFESTV_stateSTRUCTURE:
13203 case FFESTV_stateMAP:
13204 ffestw_set_substate (ffestw_stack_top (), 1); /* Seen at least one
13212 ffestd_V016_start ();
13217 /* ffestc_V016_item_structure -- RECORD statement for common-block-name
13219 ffestc_V016_item_structure(name_token);
13221 Make sure name_token identifies a valid structure to be RECORDed. */
13224 ffestc_V016_item_structure (ffelexToken name)
13226 ffestc_check_item_ ();
13227 assert (name != NULL);
13231 ffestd_V016_item_structure (name);
13234 /* ffestc_V016_item_object -- RECORD statement for object-name
13236 ffestc_V016_item_object(name_token,dim_list);
13238 Make sure name_token identifies a valid object to be RECORDd. */
13241 ffestc_V016_item_object (ffelexToken name, ffesttDimList dims)
13243 ffestc_check_item_ ();
13244 assert (name != NULL);
13249 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
13251 ffestd_V016_item_object (name, dims);
13254 /* ffestc_V016_finish -- RECORD statement list complete
13256 ffestc_V016_finish();
13258 Just wrap up any local activities. */
13261 ffestc_V016_finish ()
13263 ffestc_check_finish_ ();
13267 ffestd_V016_finish ();
13270 /* ffestc_V018_start -- REWRITE(...) statement list begin
13272 ffestc_V018_start();
13274 Verify that REWRITE is valid here, and begin accepting items in the
13278 ffestc_V018_start ()
13280 ffestvFormat format;
13282 ffestc_check_start_ ();
13283 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
13285 ffestc_ok_ = FALSE;
13288 ffestc_labeldef_branch_begin_ ();
13290 if (!ffestc_subr_is_branch_
13291 (&ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixERR])
13292 || !ffestc_subr_is_format_
13293 (&ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT])
13294 || !ffestc_subr_is_present_ ("UNIT",
13295 &ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixUNIT]))
13297 ffestc_ok_ = FALSE;
13301 format = ffestc_subr_format_
13302 (&ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT]);
13305 case FFESTV_formatNAMELIST:
13306 case FFESTV_formatASTERISK:
13307 ffebad_start (FFEBAD_CONFLICTING_SPECS);
13308 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
13309 ffelex_token_where_column (ffesta_tokens[0]));
13310 assert (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].kw_or_val_present);
13311 if (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].kw_present)
13313 ffebad_here (0, ffelex_token_where_line
13314 (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].kw),
13315 ffelex_token_where_column
13316 (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].kw));
13320 ffebad_here (1, ffelex_token_where_line
13321 (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].value),
13322 ffelex_token_where_column
13323 (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].value));
13326 ffestc_ok_ = FALSE;
13333 ffestd_V018_start (format);
13338 /* ffestc_V018_item -- REWRITE statement i/o item
13340 ffestc_V018_item(expr,expr_token);
13342 Implement output-list expression. */
13345 ffestc_V018_item (ffebld expr, ffelexToken expr_token)
13347 ffestc_check_item_ ();
13351 ffestd_V018_item (expr);
13354 /* ffestc_V018_finish -- REWRITE statement list complete
13356 ffestc_V018_finish();
13358 Just wrap up any local activities. */
13361 ffestc_V018_finish ()
13363 ffestc_check_finish_ ();
13367 ffestd_V018_finish ();
13369 if (ffestc_shriek_after1_ != NULL)
13370 (*ffestc_shriek_after1_) (TRUE);
13371 ffestc_labeldef_branch_end_ ();
13374 /* ffestc_V019_start -- ACCEPT statement list begin
13376 ffestc_V019_start();
13378 Verify that ACCEPT is valid here, and begin accepting items in the
13382 ffestc_V019_start ()
13384 ffestvFormat format;
13386 ffestc_check_start_ ();
13387 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
13389 ffestc_ok_ = FALSE;
13392 ffestc_labeldef_branch_begin_ ();
13394 if (!ffestc_subr_is_format_
13395 (&ffestp_file.accept.accept_spec[FFESTP_acceptixFORMAT]))
13397 ffestc_ok_ = FALSE;
13401 format = ffestc_subr_format_
13402 (&ffestp_file.accept.accept_spec[FFESTP_acceptixFORMAT]);
13403 ffestc_namelist_ = (format == FFESTV_formatNAMELIST);
13405 ffestd_V019_start (format);
13410 /* ffestc_V019_item -- ACCEPT statement i/o item
13412 ffestc_V019_item(expr,expr_token);
13414 Implement output-list expression. */
13417 ffestc_V019_item (ffebld expr, ffelexToken expr_token)
13419 ffestc_check_item_ ();
13423 if (ffestc_namelist_ != 0)
13425 if (ffestc_namelist_ == 1)
13427 ffestc_namelist_ = 2;
13428 ffebad_start (FFEBAD_NAMELIST_ITEMS);
13429 ffebad_here (0, ffelex_token_where_line (expr_token),
13430 ffelex_token_where_column (expr_token));
13436 ffestd_V019_item (expr);
13439 /* ffestc_V019_finish -- ACCEPT statement list complete
13441 ffestc_V019_finish();
13443 Just wrap up any local activities. */
13446 ffestc_V019_finish ()
13448 ffestc_check_finish_ ();
13452 ffestd_V019_finish ();
13454 if (ffestc_shriek_after1_ != NULL)
13455 (*ffestc_shriek_after1_) (TRUE);
13456 ffestc_labeldef_branch_end_ ();
13460 /* ffestc_V020_start -- TYPE statement list begin
13462 ffestc_V020_start();
13464 Verify that TYPE is valid here, and begin accepting items in the
13468 ffestc_V020_start ()
13470 ffestvFormat format;
13472 ffestc_check_start_ ();
13473 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
13475 ffestc_ok_ = FALSE;
13478 ffestc_labeldef_branch_begin_ ();
13480 if (!ffestc_subr_is_format_
13481 (&ffestp_file.type.type_spec[FFESTP_typeixFORMAT]))
13483 ffestc_ok_ = FALSE;
13487 format = ffestc_subr_format_
13488 (&ffestp_file.type.type_spec[FFESTP_typeixFORMAT]);
13489 ffestc_namelist_ = (format == FFESTV_formatNAMELIST);
13491 ffestd_V020_start (format);
13496 /* ffestc_V020_item -- TYPE statement i/o item
13498 ffestc_V020_item(expr,expr_token);
13500 Implement output-list expression. */
13503 ffestc_V020_item (ffebld expr, ffelexToken expr_token)
13505 ffestc_check_item_ ();
13509 if (ffestc_namelist_ != 0)
13511 if (ffestc_namelist_ == 1)
13513 ffestc_namelist_ = 2;
13514 ffebad_start (FFEBAD_NAMELIST_ITEMS);
13515 ffebad_here (0, ffelex_token_where_line (expr_token),
13516 ffelex_token_where_column (expr_token));
13522 ffestd_V020_item (expr);
13525 /* ffestc_V020_finish -- TYPE statement list complete
13527 ffestc_V020_finish();
13529 Just wrap up any local activities. */
13532 ffestc_V020_finish ()
13534 ffestc_check_finish_ ();
13538 ffestd_V020_finish ();
13540 if (ffestc_shriek_after1_ != NULL)
13541 (*ffestc_shriek_after1_) (TRUE);
13542 ffestc_labeldef_branch_end_ ();
13545 /* ffestc_V021 -- DELETE statement
13549 Make sure a DELETE is valid in the current context, and implement it. */
13555 ffestc_check_simple_ ();
13556 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
13558 ffestc_labeldef_branch_begin_ ();
13560 if (ffestc_subr_is_branch_
13561 (&ffestp_file.delete.delete_spec[FFESTP_deleteixERR])
13562 && ffestc_subr_is_present_ ("UNIT",
13563 &ffestp_file.delete.delete_spec[FFESTP_deleteixUNIT]))
13566 if (ffestc_shriek_after1_ != NULL)
13567 (*ffestc_shriek_after1_) (TRUE);
13568 ffestc_labeldef_branch_end_ ();
13571 /* ffestc_V022 -- UNLOCK statement
13575 Make sure a UNLOCK is valid in the current context, and implement it. */
13580 ffestc_check_simple_ ();
13581 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
13583 ffestc_labeldef_branch_begin_ ();
13585 if (ffestc_subr_is_branch_
13586 (&ffestp_file.beru.beru_spec[FFESTP_beruixERR])
13587 && ffestc_subr_is_present_ ("UNIT",
13588 &ffestp_file.beru.beru_spec[FFESTP_beruixUNIT]))
13591 if (ffestc_shriek_after1_ != NULL)
13592 (*ffestc_shriek_after1_) (TRUE);
13593 ffestc_labeldef_branch_end_ ();
13596 /* ffestc_V023_start -- ENCODE(...) statement list begin
13598 ffestc_V023_start();
13600 Verify that ENCODE is valid here, and begin accepting items in the
13604 ffestc_V023_start ()
13606 ffestc_check_start_ ();
13607 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
13609 ffestc_ok_ = FALSE;
13612 ffestc_labeldef_branch_begin_ ();
13614 if (!ffestc_subr_is_branch_
13615 (&ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixERR]))
13617 ffestc_ok_ = FALSE;
13621 ffestd_V023_start ();
13626 /* ffestc_V023_item -- ENCODE statement i/o item
13628 ffestc_V023_item(expr,expr_token);
13630 Implement output-list expression. */
13633 ffestc_V023_item (ffebld expr, ffelexToken expr_token)
13635 ffestc_check_item_ ();
13639 ffestd_V023_item (expr);
13642 /* ffestc_V023_finish -- ENCODE statement list complete
13644 ffestc_V023_finish();
13646 Just wrap up any local activities. */
13649 ffestc_V023_finish ()
13651 ffestc_check_finish_ ();
13655 ffestd_V023_finish ();
13657 if (ffestc_shriek_after1_ != NULL)
13658 (*ffestc_shriek_after1_) (TRUE);
13659 ffestc_labeldef_branch_end_ ();
13662 /* ffestc_V024_start -- DECODE(...) statement list begin
13664 ffestc_V024_start();
13666 Verify that DECODE is valid here, and begin accepting items in the
13670 ffestc_V024_start ()
13672 ffestc_check_start_ ();
13673 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
13675 ffestc_ok_ = FALSE;
13678 ffestc_labeldef_branch_begin_ ();
13680 if (!ffestc_subr_is_branch_
13681 (&ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixERR]))
13683 ffestc_ok_ = FALSE;
13687 ffestd_V024_start ();
13692 /* ffestc_V024_item -- DECODE statement i/o item
13694 ffestc_V024_item(expr,expr_token);
13696 Implement output-list expression. */
13699 ffestc_V024_item (ffebld expr, ffelexToken expr_token)
13701 ffestc_check_item_ ();
13705 ffestd_V024_item (expr);
13708 /* ffestc_V024_finish -- DECODE statement list complete
13710 ffestc_V024_finish();
13712 Just wrap up any local activities. */
13715 ffestc_V024_finish ()
13717 ffestc_check_finish_ ();
13721 ffestd_V024_finish ();
13723 if (ffestc_shriek_after1_ != NULL)
13724 (*ffestc_shriek_after1_) (TRUE);
13725 ffestc_labeldef_branch_end_ ();
13728 /* ffestc_V025_start -- DEFINEFILE statement list begin
13730 ffestc_V025_start();
13732 Verify that DEFINEFILE is valid here, and begin accepting items in the
13736 ffestc_V025_start ()
13738 ffestc_check_start_ ();
13739 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
13741 ffestc_ok_ = FALSE;
13744 ffestc_labeldef_branch_begin_ ();
13746 ffestd_V025_start ();
13751 /* ffestc_V025_item -- DEFINE FILE statement item
13753 ffestc_V025_item(u,ut,m,mt,n,nt,asv,asvt);
13758 ffestc_V025_item (ffebld u, ffelexToken ut, ffebld m, ffelexToken mt,
13759 ffebld n, ffelexToken nt, ffebld asv, ffelexToken asvt)
13761 ffestc_check_item_ ();
13765 ffestd_V025_item (u, m, n, asv);
13768 /* ffestc_V025_finish -- DEFINE FILE statement list complete
13770 ffestc_V025_finish();
13772 Just wrap up any local activities. */
13775 ffestc_V025_finish ()
13777 ffestc_check_finish_ ();
13781 ffestd_V025_finish ();
13783 if (ffestc_shriek_after1_ != NULL)
13784 (*ffestc_shriek_after1_) (TRUE);
13785 ffestc_labeldef_branch_end_ ();
13788 /* ffestc_V026 -- FIND statement
13792 Make sure a FIND is valid in the current context, and implement it. */
13797 ffestc_check_simple_ ();
13798 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
13800 ffestc_labeldef_branch_begin_ ();
13802 if (ffestc_subr_is_branch_
13803 (&ffestp_file.find.find_spec[FFESTP_findixERR])
13804 && ffestc_subr_is_present_ ("UNIT",
13805 &ffestp_file.find.find_spec[FFESTP_findixUNIT])
13806 && ffestc_subr_is_present_ ("REC",
13807 &ffestp_file.find.find_spec[FFESTP_findixREC]))
13810 if (ffestc_shriek_after1_ != NULL)
13811 (*ffestc_shriek_after1_) (TRUE);
13812 ffestc_labeldef_branch_end_ ();
13816 /* ffestc_V027_start -- VXT PARAMETER statement list begin
13818 ffestc_V027_start();
13820 Verify that PARAMETER is valid here, and begin accepting items in the list. */
13823 ffestc_V027_start ()
13825 ffestc_check_start_ ();
13826 if (ffestc_order_parameter_ () != FFESTC_orderOK_)
13828 ffestc_ok_ = FALSE;
13831 ffestc_labeldef_useless_ ();
13833 ffestd_V027_start ();
13838 /* ffestc_V027_item -- VXT PARAMETER statement assignment
13840 ffestc_V027_item(dest,dest_token,source,source_token);
13842 Make sure the source is a valid source for the destination; make the
13846 ffestc_V027_item (ffelexToken dest_token, ffebld source,
13847 ffelexToken source_token UNUSED)
13849 ffestc_check_item_ ();
13853 ffestd_V027_item (dest_token, source);
13856 /* ffestc_V027_finish -- VXT PARAMETER statement list complete
13858 ffestc_V027_finish();
13860 Just wrap up any local activities. */
13863 ffestc_V027_finish ()
13865 ffestc_check_finish_ ();
13869 ffestd_V027_finish ();
13872 /* Any executable statement. Mainly make sure that one-shot things
13873 like the statement for a logical IF are reset. */
13878 ffestc_check_simple_ ();
13880 ffestc_order_any_ ();
13882 ffestc_labeldef_any_ ();
13884 if (ffestc_shriek_after1_ == NULL)
13889 (*ffestc_shriek_after1_) (TRUE);