1 /* stc.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995, 1996, 1997, 2003 Free Software Foundation, Inc.
3 Contributed by James Craig Burley.
4
5 This file is part of GNU Fortran.
6
7 GNU Fortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
10 any later version.
11
12 GNU Fortran is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with GNU Fortran; see the file COPYING. If not, write to
19 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
20 02111-1307, USA.
21
22 Related Modules:
23 st.c
24
25 Description:
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.
29
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.
37
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.
50
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.
63
64 Modifications:
65 */
66
67 /* Include files. */
68
69 #include "proj.h"
70 #include "stc.h"
71 #include "bad.h"
72 #include "bld.h"
73 #include "data.h"
74 #include "expr.h"
75 #include "global.h"
76 #include "implic.h"
77 #include "lex.h"
78 #include "malloc.h"
79 #include "src.h"
80 #include "sta.h"
81 #include "std.h"
82 #include "stp.h"
83 #include "str.h"
84 #include "stt.h"
85 #include "stw.h"
86
87 /* Externals defined here. */
88
89 ffeexprContext ffestc_iolist_context_ = FFEEXPR_contextIOLIST;
90 /* Valid only from READ/WRITE start to finish. */
91
92 /* Simple definitions and enumerations. */
93
94 typedef enum
95 {
96 FFESTC_orderOK_, /* Statement ok in this context, process. */
97 FFESTC_orderBAD_, /* Statement not ok in this context, don't
98 process. */
99 FFESTC_orderBADOK_, /* Don't process but push block if
100 applicable. */
101 FFESTC
102 } ffestcOrder_;
103
104 typedef enum
105 {
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. */
110 FFESTC_
111 } ffestcStatelet_;
112
113 /* Internal typedefs. */
114
115
116 /* Private include files. */
117
118
119 /* Internal structure definitions. */
120
121 union ffestc_local_u_
122 {
123 struct
124 {
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. */
133 }
134 decl;
135 struct
136 {
137 ffebld objlist; /* For list of target objects. */
138 ffebldListBottom list_bottom; /* For building lists. */
139 }
140 data;
141 struct
142 {
143 ffebldListBottom list_bottom; /* For building lists. */
144 int entry_num;
145 }
146 dummy;
147 struct
148 {
149 ffesymbol symbol; /* NML symbol. */
150 }
151 namelist;
152 struct
153 {
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
159 processed. */
160 bool save; /* TRUE if any var in list is SAVEd. */
161 }
162 equiv;
163 struct
164 {
165 ffesymbol symbol; /* BCB/NCB symbol. */
166 }
167 common;
168 struct
169 {
170 ffesymbol symbol; /* SFN symbol. */
171 }
172 sfunc;
173 #if FFESTR_VXT
174 struct
175 {
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. */
179 }
180 V003;
181 #endif
182 }; /* Merge with the one in ffestc later. */
183
184 /* Static objects accessed by functions in this module. */
185
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_;
197
198 /* Static functions (internal). */
199
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,
222 ffelab *label);
223 static bool ffestc_labelref_is_branch_ (ffelexToken label_token,
224 ffelab *label);
225 static bool ffestc_labelref_is_format_ (ffelexToken label_token,
226 ffelab *label);
227 static bool ffestc_labelref_is_loopend_ (ffelexToken label_token,
228 ffelab *label);
229 #if FFESTR_F90
230 static ffestcOrder_ ffestc_order_access_ (void);
231 #endif
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);
239 #if FFESTR_F90
240 static ffestcOrder_ ffestc_order_component_ (void);
241 #endif
242 #if FFESTR_F90
243 static ffestcOrder_ ffestc_order_contains_ (void);
244 #endif
245 static ffestcOrder_ ffestc_order_data_ (void);
246 static ffestcOrder_ ffestc_order_data77_ (void);
247 #if FFESTR_F90
248 static ffestcOrder_ ffestc_order_derivedtype_ (void);
249 #endif
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);
259 #if FFESTR_F90
260 static ffestcOrder_ ffestc_order_interface_ (void);
261 #endif
262 #if FFESTR_F90
263 static ffestcOrder_ ffestc_order_map_ (void);
264 #endif
265 #if FFESTR_F90
266 static ffestcOrder_ ffestc_order_module_ (void);
267 #endif
268 static ffestcOrder_ ffestc_order_parameter_ (void);
269 static ffestcOrder_ ffestc_order_program_ (void);
270 static ffestcOrder_ ffestc_order_progspec_ (void);
271 #if FFESTR_F90
272 static ffestcOrder_ ffestc_order_record_ (void);
273 #endif
274 static ffestcOrder_ ffestc_order_selectcase_ (void);
275 static ffestcOrder_ ffestc_order_sfunc_ (void);
276 #if FFESTR_F90
277 static ffestcOrder_ ffestc_order_spec_ (void);
278 #endif
279 #if FFESTR_VXT
280 static ffestcOrder_ ffestc_order_structure_ (void);
281 #endif
282 static ffestcOrder_ ffestc_order_subroutine_ (void);
283 #if FFESTR_F90
284 static ffestcOrder_ ffestc_order_type_ (void);
285 #endif
286 static ffestcOrder_ ffestc_order_typedecl_ (void);
287 #if FFESTR_VXT
288 static ffestcOrder_ ffestc_order_union_ (void);
289 #endif
290 static ffestcOrder_ ffestc_order_unit_ (void);
291 #if FFESTR_F90
292 static ffestcOrder_ ffestc_order_use_ (void);
293 #endif
294 #if FFESTR_VXT
295 static ffestcOrder_ ffestc_order_vxtstructure_ (void);
296 #endif
297 #if FFESTR_F90
298 static ffestcOrder_ ffestc_order_where_ (void);
299 #endif
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);
304 #if FFESTR_F90
305 static void ffestc_shriek_begin_uses_ (void);
306 #endif
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);
310 #if FFESTR_F90
311 static void ffestc_shriek_end_uses_ (bool ok);
312 #endif
313 static void ffestc_shriek_function_ (bool ok);
314 static void ffestc_shriek_if_ (bool ok);
315 static void ffestc_shriek_ifthen_ (bool ok);
316 #if FFESTR_F90
317 static void ffestc_shriek_interface_ (bool ok);
318 #endif
319 #if FFESTR_F90
320 static void ffestc_shriek_map_ (bool ok);
321 #endif
322 #if FFESTR_F90
323 static void ffestc_shriek_module_ (bool ok);
324 #endif
325 static void ffestc_shriek_select_ (bool ok);
326 #if FFESTR_VXT
327 static void ffestc_shriek_structure_ (bool ok);
328 #endif
329 static void ffestc_shriek_subroutine_ (bool ok);
330 #if FFESTR_F90
331 static void ffestc_shriek_type_ (bool ok);
332 #endif
333 #if FFESTR_VXT
334 static void ffestc_shriek_union_ (bool ok);
335 #endif
336 #if FFESTR_F90
337 static void ffestc_shriek_where_ (bool ok);
338 #endif
339 #if FFESTR_F90
340 static void ffestc_shriek_wherethen_ (bool ok);
341 #endif
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);
352
353 /* Internal macros. */
354
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_()
380 #if FFESTR_F90
381 #define ffestc_order_interfacespec_() ffestc_order_derivedtype_()
382 #endif
383 #define ffestc_shriek_if_lost_ ffestc_shriek_if_
384 #if FFESTR_F90
385 #define ffestc_shriek_where_lost_ ffestc_shriek_where_
386 #endif
387
388 /* ffestc_establish_declinfo_ -- Determine specific type/params info for entity
389
390 ffestc_establish_declinfo_(kind,kind_token,len,len_token);
391
392 Must be called after _declstmt_ called to establish base type. */
393
394 static void
ffestc_establish_declinfo_(ffebld kind,ffelexToken kindt,ffebld len,ffelexToken lent)395 ffestc_establish_declinfo_ (ffebld kind, ffelexToken kindt, ffebld len,
396 ffelexToken lent)
397 {
398 ffeinfoBasictype bt = ffestc_local_.decl.basic_type;
399 ffeinfoKindtype kt;
400 ffetargetCharacterSize val;
401
402 if (kindt == NULL)
403 kt = ffestc_local_.decl.stmt_kind_type;
404 else if (!ffestc_local_.decl.per_var_kind_ok)
405 {
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]));
411 ffebad_finish ();
412 kt = ffestc_local_.decl.stmt_kind_type;
413 }
414 else
415 {
416 if (kind == NULL)
417 {
418 assert (ffelex_token_type (kindt) == FFELEX_typeNUMBER);
419 val = atol (ffelex_token_text (kindt));
420 kt = ffestc_kindtype_star_ (bt, val);
421 }
422 else if (ffebld_op (kind) == FFEBLD_opANY)
423 kt = ffestc_local_.decl.stmt_kind_type;
424 else
425 {
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);
433 }
434
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]));
442 ffebad_finish ();
443 kt = ffestc_local_.decl.stmt_kind_type;
444 }
445 }
446
447 ffestc_local_.decl.kind_type = kt;
448
449 /* Now check length specification for CHARACTER data type. */
450
451 if (((len == NULL) && (lent == NULL))
452 || (bt != FFEINFO_basictypeCHARACTER))
453 val = ffestc_local_.decl.stmt_size;
454 else
455 {
456 if (len == NULL)
457 {
458 assert (ffelex_token_type (lent) == FFELEX_typeNUMBER);
459 val = atol (ffelex_token_text (lent));
460 }
461 else if (ffebld_op (len) == FFEBLD_opSTAR)
462 val = FFETARGET_charactersizeNONE;
463 else if (ffebld_op (len) == FFEBLD_opANY)
464 val = FFETARGET_charactersizeNONE;
465 else
466 {
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));
473 }
474 }
475
476 if ((val == 0) && !(0 && ffe_is_90 ()))
477 {
478 val = 1;
479 ffebad_start (FFEBAD_ZERO_SIZE);
480 ffebad_here (0, ffelex_token_where_line (lent), ffelex_token_where_column (lent));
481 ffebad_finish ();
482 }
483 ffestc_local_.decl.size = val;
484 }
485
486 /* ffestc_establish_declstmt_ -- Establish host-specific type/params info
487
488 ffestc_establish_declstmt_(type,type_token,kind,kind_token,len,
489 len_token); */
490
491 static void
ffestc_establish_declstmt_(ffestpType type,ffelexToken typet,ffebld kind,ffelexToken kindt,ffebld len,ffelexToken lent)492 ffestc_establish_declstmt_ (ffestpType type, ffelexToken typet, ffebld kind,
493 ffelexToken kindt, ffebld len, ffelexToken lent)
494 {
495 ffeinfoBasictype bt;
496 ffeinfoKindtype ktd; /* Default kindtype. */
497 ffeinfoKindtype kt;
498 ffetargetCharacterSize val;
499 bool per_var_kind_ok = TRUE;
500
501 /* Determine basictype and default kindtype. */
502
503 switch (type)
504 {
505 case FFESTP_typeINTEGER:
506 bt = FFEINFO_basictypeINTEGER;
507 ktd = FFEINFO_kindtypeINTEGERDEFAULT;
508 break;
509
510 case FFESTP_typeBYTE:
511 bt = FFEINFO_basictypeINTEGER;
512 ktd = FFEINFO_kindtypeINTEGER2;
513 break;
514
515 case FFESTP_typeWORD:
516 bt = FFEINFO_basictypeINTEGER;
517 ktd = FFEINFO_kindtypeINTEGER3;
518 break;
519
520 case FFESTP_typeREAL:
521 bt = FFEINFO_basictypeREAL;
522 ktd = FFEINFO_kindtypeREALDEFAULT;
523 break;
524
525 case FFESTP_typeCOMPLEX:
526 bt = FFEINFO_basictypeCOMPLEX;
527 ktd = FFEINFO_kindtypeREALDEFAULT;
528 break;
529
530 case FFESTP_typeLOGICAL:
531 bt = FFEINFO_basictypeLOGICAL;
532 ktd = FFEINFO_kindtypeLOGICALDEFAULT;
533 break;
534
535 case FFESTP_typeCHARACTER:
536 bt = FFEINFO_basictypeCHARACTER;
537 ktd = FFEINFO_kindtypeCHARACTERDEFAULT;
538 break;
539
540 case FFESTP_typeDBLPRCSN:
541 bt = FFEINFO_basictypeREAL;
542 ktd = FFEINFO_kindtypeREALDOUBLE;
543 per_var_kind_ok = FALSE;
544 break;
545
546 case FFESTP_typeDBLCMPLX:
547 bt = FFEINFO_basictypeCOMPLEX;
548 #if FFETARGET_okCOMPLEX2
549 ktd = FFEINFO_kindtypeREALDOUBLE;
550 #else
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]));
555 ffebad_finish ();
556 #endif
557 per_var_kind_ok = FALSE;
558 break;
559
560 default:
561 assert ("Unexpected type (F90 TYPE?)!" == NULL);
562 bt = FFEINFO_basictypeNONE;
563 ktd = FFEINFO_kindtypeNONE;
564 break;
565 }
566
567 if (kindt == NULL)
568 kt = ktd;
569 else
570 { /* Not necessarily default kind type. */
571 if (kind == NULL)
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);
576 }
577 else if (ffebld_op (kind) == FFEBLD_opANY)
578 kt = ktd;
579 else
580 {
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);
588 }
589
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));
597 ffebad_finish ();
598 kt = ktd;
599 }
600 }
601
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;
605
606 /* Now check length specification for CHARACTER data type. */
607
608 if (((len == NULL) && (lent == NULL))
609 || (type != FFESTP_typeCHARACTER))
610 val = (type == FFESTP_typeCHARACTER) ? 1 : FFETARGET_charactersizeNONE;
611 else
612 {
613 if (len == NULL)
614 {
615 assert (ffelex_token_type (lent) == FFELEX_typeNUMBER);
616 val = atol (ffelex_token_text (lent));
617 }
618 else if (ffebld_op (len) == FFEBLD_opSTAR)
619 val = FFETARGET_charactersizeNONE;
620 else if (ffebld_op (len) == FFEBLD_opANY)
621 val = FFETARGET_charactersizeNONE;
622 else
623 {
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));
630 }
631 }
632
633 if ((val == 0) && !(0 && ffe_is_90 ()))
634 {
635 val = 1;
636 ffebad_start (FFEBAD_ZERO_SIZE);
637 ffebad_here (0, ffelex_token_where_line (lent), ffelex_token_where_column (lent));
638 ffebad_finish ();
639 }
640 ffestc_local_.decl.stmt_size = val;
641 }
642
643 /* ffestc_establish_impletter_ -- Establish type/params for IMPLICIT letter(s)
644
645 ffestc_establish_impletter_(first_letter_token,last_letter_token); */
646
647 static void
ffestc_establish_impletter_(ffelexToken first,ffelexToken last)648 ffestc_establish_impletter_ (ffelexToken first, ffelexToken last)
649 {
650 bool ok = FALSE; /* Stays FALSE if first letter > last. */
651 char c;
652
653 if (last == NULL)
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);
658 else
659 {
660 for (c = *(ffelex_token_text (first));
661 c <= *(ffelex_token_text (last));
662 c++)
663 {
664 ok = ffeimplic_establish_initial (c,
665 ffestc_local_.decl.basic_type,
666 ffestc_local_.decl.kind_type,
667 ffestc_local_.decl.size);
668 if (!ok)
669 break;
670 }
671 }
672
673 if (!ok)
674 {
675 char cs[2];
676
677 cs[0] = c;
678 cs[1] = '\0';
679
680 ffebad_start (FFEBAD_BAD_IMPLICIT);
681 ffebad_here (0, ffelex_token_where_line (first), ffelex_token_where_column (first));
682 ffebad_string (cs);
683 ffebad_finish ();
684 }
685 }
686
687 /* ffestc_init_3 -- Initialize ffestc for new program unit
688
689 ffestc_init_3(); */
690
691 void
ffestc_init_3()692 ffestc_init_3 ()
693 {
694 ffestv_save_state_ = FFESTV_savestateNONE;
695 ffestc_entry_num_ = 0;
696 ffestv_num_label_defines_ = 0;
697 }
698
699 /* ffestc_init_4 -- Initialize ffestc for new scoping unit
700
701 ffestc_init_4();
702
703 For SUBROUTINEs/FUNCTIONs within INTERFACE/END INTERFACE, derived-TYPE-
704 defs, and statement function defs. */
705
706 void
ffestc_init_4()707 ffestc_init_4 ()
708 {
709 ffestc_saved_entry_num_ = ffestc_entry_num_;
710 ffestc_entry_num_ = 0;
711 }
712
713 /* ffestc_kindtype_kind_ -- Determine kindtype from basictype and KIND= value
714
715 ffeinfoKindtype kt;
716 ffeinfoBasictype bt;
717 ffetargetCharacterSize val;
718 kt = ffestc_kindtype_kind_(bt,val);
719 if (kt == FFEINFO_kindtypeNONE)
720 // unsupported/invalid KIND= value for type */
721
722 static ffeinfoKindtype
ffestc_kindtype_kind_(ffeinfoBasictype bt,ffetargetCharacterSize val)723 ffestc_kindtype_kind_ (ffeinfoBasictype bt, ffetargetCharacterSize val)
724 {
725 ffetype type;
726 ffetype base_type;
727 ffeinfoKindtype kt;
728
729 base_type = ffeinfo_type (bt, 1); /* ~~ */
730 assert (base_type != NULL);
731
732 type = ffetype_lookup_kind (base_type, (int) val);
733 if (type == NULL)
734 return FFEINFO_kindtypeNONE;
735
736 for (kt = 1; kt < FFEINFO_kindtype; ++kt)
737 if (ffeinfo_type (bt, kt) == type)
738 return kt;
739
740 return FFEINFO_kindtypeNONE;
741 }
742
743 /* ffestc_kindtype_star_ -- Determine kindtype from basictype and * value
744
745 ffeinfoKindtype kt;
746 ffeinfoBasictype bt;
747 ffetargetCharacterSize val;
748 kt = ffestc_kindtype_star_(bt,val);
749 if (kt == FFEINFO_kindtypeNONE)
750 // unsupported/invalid * value for type */
751
752 static ffeinfoKindtype
ffestc_kindtype_star_(ffeinfoBasictype bt,ffetargetCharacterSize val)753 ffestc_kindtype_star_ (ffeinfoBasictype bt, ffetargetCharacterSize val)
754 {
755 ffetype type;
756 ffetype base_type;
757 ffeinfoKindtype kt;
758
759 base_type = ffeinfo_type (bt, 1); /* ~~ */
760 assert (base_type != NULL);
761
762 type = ffetype_lookup_star (base_type, (int) val);
763 if (type == NULL)
764 return FFEINFO_kindtypeNONE;
765
766 for (kt = 1; kt < FFEINFO_kindtype; ++kt)
767 if (ffeinfo_type (bt, kt) == type)
768 return kt;
769
770 return FFEINFO_kindtypeNONE;
771 }
772
773 /* Define label as usable for anything without complaint. */
774
775 static void
ffestc_labeldef_any_()776 ffestc_labeldef_any_ ()
777 {
778 if ((ffesta_label_token == NULL)
779 || !ffestc_labeldef_begin_ ())
780 return;
781
782 ffelab_set_type (ffestc_label_, FFELAB_typeANY);
783 ffestd_labeldef_any (ffestc_label_);
784
785 ffestc_labeldef_branch_end_ ();
786 }
787
788 /* ffestc_labeldef_begin_ -- Define label as unknown, initially
789
790 ffestc_labeldef_begin_(); */
791
792 static bool
ffestc_labeldef_begin_()793 ffestc_labeldef_begin_ ()
794 {
795 ffelabValue label_value;
796 ffelab label;
797
798 label_value = (ffelabValue) atol (ffelex_token_text (ffesta_label_token));
799 if ((label_value == 0) || (label_value > FFELAB_valueMAX))
800 {
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));
804 ffebad_finish ();
805 }
806
807 label = ffelab_find (label_value);
808 if (label == NULL)
809 {
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)));
816
817 return TRUE;
818 }
819
820 if (ffewhere_line_is_unknown (ffelab_definition_line (label)))
821 {
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)));
828
829 return TRUE;
830 }
831
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));
838 ffebad_finish ();
839
840 ffelex_token_kill (ffesta_label_token);
841 ffesta_label_token = NULL;
842 return FALSE;
843 }
844
845 /* ffestc_labeldef_branch_begin_ -- Define label as a branch target one
846
847 ffestc_labeldef_branch_begin_(); */
848
849 static void
ffestc_labeldef_branch_begin_()850 ffestc_labeldef_branch_begin_ ()
851 {
852 if ((ffesta_label_token == NULL)
853 || (ffestc_shriek_after1_ != NULL)
854 || !ffestc_labeldef_begin_ ())
855 return;
856
857 switch (ffelab_type (ffestc_label_))
858 {
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_);
865 break;
866
867 case FFELAB_typeNOTLOOP:
868 if (ffelab_blocknum (ffestc_label_)
869 < ffestw_blocknum (ffestw_stack_top ()))
870 {
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_));
876 ffebad_finish ();
877 }
878 ffelab_set_blocknum (ffestc_label_,
879 ffestw_blocknum (ffestw_stack_top ()));
880 ffestd_labeldef_branch (ffestc_label_);
881 break;
882
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_);
889
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));
896 ffebad_finish ();
897 break;
898 }
899 ffestd_labeldef_branch (ffestc_label_);
900 /* Leave something around for _branch_end_() to handle. */
901 return;
902
903 case FFELAB_typeFORMAT:
904 ffelab_set_type (ffestc_label_, FFELAB_typeANY);
905 ffestd_labeldef_any (ffestc_label_);
906
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_));
912 ffebad_finish ();
913 break;
914
915 default:
916 assert ("bad label" == NULL);
917 /* Fall through. */
918 case FFELAB_typeANY:
919 break;
920 }
921
922 ffestc_try_shriek_do_ ();
923
924 ffelex_token_kill (ffesta_label_token);
925 ffesta_label_token = NULL;
926 }
927
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). */
932
933 static void
ffestc_labeldef_branch_end_()934 ffestc_labeldef_branch_end_ ()
935 {
936 if (ffesta_label_token == NULL)
937 return;
938
939 assert (ffestc_label_ != NULL);
940 assert ((ffelab_type (ffestc_label_) == FFELAB_typeLOOPEND)
941 || (ffelab_type (ffestc_label_) == FFELAB_typeANY));
942
943 while ((ffestw_state (ffestw_stack_top ()) == FFESTV_stateDO)
944 && (ffestw_label (ffestw_stack_top ()) == ffestc_label_))
945 ffestc_shriek_do_ (TRUE);
946
947 ffestc_try_shriek_do_ ();
948
949 ffelex_token_kill (ffesta_label_token);
950 ffesta_label_token = NULL;
951 }
952
953 /* ffestc_labeldef_endif_ -- Define label as an END IF one
954
955 ffestc_labeldef_endif_(); */
956
957 static void
ffestc_labeldef_endif_()958 ffestc_labeldef_endif_ ()
959 {
960 if ((ffesta_label_token == NULL)
961 || (ffestc_shriek_after1_ != NULL)
962 || !ffestc_labeldef_begin_ ())
963 return;
964
965 switch (ffelab_type (ffestc_label_))
966 {
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_);
973 break;
974
975 case FFELAB_typeNOTLOOP:
976 if (ffelab_blocknum (ffestc_label_)
977 < ffestw_blocknum (ffestw_previous (ffestw_stack_top ())))
978 {
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_));
984 ffebad_finish ();
985 }
986 ffelab_set_blocknum (ffestc_label_,
987 ffestw_blocknum (ffestw_previous (ffestw_stack_top ())));
988 ffestd_labeldef_endif (ffestc_label_);
989 break;
990
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_);
997
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));
1004 ffebad_finish ();
1005 break;
1006 }
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_));
1013 ffebad_finish ();
1014 ffestc_labeldef_branch_end_ ();
1015 return;
1016
1017 case FFELAB_typeFORMAT:
1018 ffelab_set_type (ffestc_label_, FFELAB_typeANY);
1019 ffestd_labeldef_any (ffestc_label_);
1020
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_));
1026 ffebad_finish ();
1027 break;
1028
1029 default:
1030 assert ("bad label" == NULL);
1031 /* Fall through. */
1032 case FFELAB_typeANY:
1033 break;
1034 }
1035
1036 ffestc_try_shriek_do_ ();
1037
1038 ffelex_token_kill (ffesta_label_token);
1039 ffesta_label_token = NULL;
1040 }
1041
1042 /* ffestc_labeldef_format_ -- Define label as a FORMAT one
1043
1044 ffestc_labeldef_format_(); */
1045
1046 static void
ffestc_labeldef_format_()1047 ffestc_labeldef_format_ ()
1048 {
1049 if ((ffesta_label_token == NULL)
1050 || (ffestc_shriek_after1_ != NULL))
1051 {
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]));
1055 ffebad_finish ();
1056 return;
1057 }
1058
1059 if (!ffestc_labeldef_begin_ ())
1060 return;
1061
1062 switch (ffelab_type (ffestc_label_))
1063 {
1064 case FFELAB_typeUNKNOWN:
1065 case FFELAB_typeASSIGNABLE:
1066 ffelab_set_type (ffestc_label_, FFELAB_typeFORMAT);
1067 ffestd_labeldef_format (ffestc_label_);
1068 break;
1069
1070 case FFELAB_typeFORMAT:
1071 ffestd_labeldef_format (ffestc_label_);
1072 break;
1073
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_);
1080
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));
1087 ffebad_finish ();
1088 break;
1089 }
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_));
1096 ffebad_finish ();
1097 ffestc_labeldef_branch_end_ ();
1098 return;
1099
1100 case FFELAB_typeNOTLOOP:
1101 ffelab_set_type (ffestc_label_, FFELAB_typeANY);
1102 ffestd_labeldef_any (ffestc_label_);
1103
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_));
1109 ffebad_finish ();
1110 break;
1111
1112 default:
1113 assert ("bad label" == NULL);
1114 /* Fall through. */
1115 case FFELAB_typeANY:
1116 break;
1117 }
1118
1119 ffestc_try_shriek_do_ ();
1120
1121 ffelex_token_kill (ffesta_label_token);
1122 ffesta_label_token = NULL;
1123 }
1124
1125 /* ffestc_labeldef_invalid_ -- Label definition invalid, complain if present
1126
1127 ffestc_labeldef_invalid_(); */
1128
1129 static void
ffestc_labeldef_invalid_()1130 ffestc_labeldef_invalid_ ()
1131 {
1132 if ((ffesta_label_token == NULL)
1133 || (ffestc_shriek_after1_ != NULL)
1134 || !ffestc_labeldef_begin_ ())
1135 return;
1136
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));
1140 ffebad_finish ();
1141
1142 ffelab_set_type (ffestc_label_, FFELAB_typeANY);
1143 ffestd_labeldef_any (ffestc_label_);
1144
1145 ffestc_try_shriek_do_ ();
1146
1147 ffelex_token_kill (ffesta_label_token);
1148 ffesta_label_token = NULL;
1149 }
1150
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. */
1153
1154 static void
ffestc_labeldef_notloop_()1155 ffestc_labeldef_notloop_ ()
1156 {
1157 if (ffesta_label_token == NULL)
1158 return;
1159
1160 assert (ffestc_shriek_after1_ == NULL);
1161
1162 if (!ffestc_labeldef_begin_ ())
1163 return;
1164
1165 switch (ffelab_type (ffestc_label_))
1166 {
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_);
1173 break;
1174
1175 case FFELAB_typeNOTLOOP:
1176 if (ffelab_blocknum (ffestc_label_)
1177 < ffestw_blocknum (ffestw_stack_top ()))
1178 {
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_));
1184 ffebad_finish ();
1185 }
1186 ffelab_set_blocknum (ffestc_label_,
1187 ffestw_blocknum (ffestw_stack_top ()));
1188 ffestd_labeldef_notloop (ffestc_label_);
1189 break;
1190
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_);
1197
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));
1204 ffebad_finish ();
1205 break;
1206 }
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_));
1213 ffebad_finish ();
1214 ffestc_labeldef_branch_end_ ();
1215 return;
1216
1217 case FFELAB_typeFORMAT:
1218 ffelab_set_type (ffestc_label_, FFELAB_typeANY);
1219 ffestd_labeldef_any (ffestc_label_);
1220
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_));
1226 ffebad_finish ();
1227 break;
1228
1229 default:
1230 assert ("bad label" == NULL);
1231 /* Fall through. */
1232 case FFELAB_typeANY:
1233 break;
1234 }
1235
1236 ffestc_try_shriek_do_ ();
1237
1238 ffelex_token_kill (ffesta_label_token);
1239 ffesta_label_token = NULL;
1240 }
1241
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. */
1247
1248 static void
ffestc_labeldef_notloop_begin_()1249 ffestc_labeldef_notloop_begin_ ()
1250 {
1251 if ((ffesta_label_token == NULL)
1252 || (ffestc_shriek_after1_ != NULL)
1253 || !ffestc_labeldef_begin_ ())
1254 return;
1255
1256 switch (ffelab_type (ffestc_label_))
1257 {
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_);
1264 break;
1265
1266 case FFELAB_typeNOTLOOP:
1267 if (ffelab_blocknum (ffestc_label_)
1268 < ffestw_blocknum (ffestw_stack_top ()))
1269 {
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_));
1275 ffebad_finish ();
1276 }
1277 ffelab_set_blocknum (ffestc_label_,
1278 ffestw_blocknum (ffestw_stack_top ()));
1279 ffestd_labeldef_notloop (ffestc_label_);
1280 break;
1281
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_);
1288
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));
1295 ffebad_finish ();
1296 break;
1297 }
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_));
1304 ffebad_finish ();
1305 return;
1306
1307 case FFELAB_typeFORMAT:
1308 ffelab_set_type (ffestc_label_, FFELAB_typeANY);
1309 ffestd_labeldef_any (ffestc_label_);
1310
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_));
1316 ffebad_finish ();
1317 break;
1318
1319 default:
1320 assert ("bad label" == NULL);
1321 /* Fall through. */
1322 case FFELAB_typeANY:
1323 break;
1324 }
1325
1326 ffestc_try_shriek_do_ ();
1327
1328 ffelex_token_kill (ffesta_label_token);
1329 ffesta_label_token = NULL;
1330 }
1331
1332 /* ffestc_labeldef_useless_ -- Define label as a useless one
1333
1334 ffestc_labeldef_useless_(); */
1335
1336 static void
ffestc_labeldef_useless_()1337 ffestc_labeldef_useless_ ()
1338 {
1339 if ((ffesta_label_token == NULL)
1340 || (ffestc_shriek_after1_ != NULL)
1341 || !ffestc_labeldef_begin_ ())
1342 return;
1343
1344 switch (ffelab_type (ffestc_label_))
1345 {
1346 case FFELAB_typeUNKNOWN:
1347 ffelab_set_type (ffestc_label_, FFELAB_typeUSELESS);
1348 ffestd_labeldef_useless (ffestc_label_);
1349 break;
1350
1351 case FFELAB_typeLOOPEND:
1352 ffelab_set_type (ffestc_label_, FFELAB_typeANY);
1353 ffestd_labeldef_any (ffestc_label_);
1354
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));
1364 ffebad_finish ();
1365 break;
1366 }
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_));
1372 ffebad_finish ();
1373 ffestc_labeldef_branch_end_ ();
1374 return;
1375
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_);
1381
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_));
1387 ffebad_finish ();
1388 break;
1389
1390 default:
1391 assert ("bad label" == NULL);
1392 /* Fall through. */
1393 case FFELAB_typeANY:
1394 break;
1395 }
1396
1397 ffestc_try_shriek_do_ ();
1398
1399 ffelex_token_kill (ffesta_label_token);
1400 ffesta_label_token = NULL;
1401 }
1402
1403 /* ffestc_labelref_is_assignable_ -- Reference to label in ASSIGN stmt
1404
1405 if (ffestc_labelref_is_assignable_(label_token,&label))
1406 // label ref is ok, label is filled in with ffelab object */
1407
1408 static bool
ffestc_labelref_is_assignable_(ffelexToken label_token,ffelab * x_label)1409 ffestc_labelref_is_assignable_ (ffelexToken label_token, ffelab *x_label)
1410 {
1411 ffelab label;
1412 ffelabValue label_value;
1413
1414 label_value = (ffelabValue) atol (ffelex_token_text (label_token));
1415 if ((label_value == 0) || (label_value > FFELAB_valueMAX))
1416 {
1417 ffebad_start (FFEBAD_LABEL_NUMBER_INVALID);
1418 ffebad_here (0, ffelex_token_where_line (label_token),
1419 ffelex_token_where_column (label_token));
1420 ffebad_finish ();
1421 return FALSE;
1422 }
1423
1424 label = ffelab_find (label_value);
1425 if (label == NULL)
1426 {
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)));
1432 }
1433
1434 switch (ffelab_type (label))
1435 {
1436 case FFELAB_typeUNKNOWN:
1437 ffelab_set_type (label, FFELAB_typeASSIGNABLE);
1438 break;
1439
1440 case FFELAB_typeASSIGNABLE:
1441 case FFELAB_typeLOOPEND:
1442 case FFELAB_typeFORMAT:
1443 case FFELAB_typeNOTLOOP:
1444 case FFELAB_typeENDIF:
1445 break;
1446
1447 case FFELAB_typeUSELESS:
1448 ffelab_set_type (label, FFELAB_typeANY);
1449 ffestd_labeldef_any (label);
1450
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));
1455 ffebad_finish ();
1456
1457 ffestc_try_shriek_do_ ();
1458
1459 return FALSE;
1460
1461 default:
1462 assert ("bad label" == NULL);
1463 /* Fall through. */
1464 case FFELAB_typeANY:
1465 break;
1466 }
1467
1468 *x_label = label;
1469 return TRUE;
1470 }
1471
1472 /* ffestc_labelref_is_branch_ -- Reference to label in branch stmt
1473
1474 if (ffestc_labelref_is_branch_(label_token,&label))
1475 // label ref is ok, label is filled in with ffelab object */
1476
1477 static bool
ffestc_labelref_is_branch_(ffelexToken label_token,ffelab * x_label)1478 ffestc_labelref_is_branch_ (ffelexToken label_token, ffelab *x_label)
1479 {
1480 ffelab label;
1481 ffelabValue label_value;
1482 ffestw block;
1483 unsigned long blocknum;
1484
1485 label_value = (ffelabValue) atol (ffelex_token_text (label_token));
1486 if ((label_value == 0) || (label_value > FFELAB_valueMAX))
1487 {
1488 ffebad_start (FFEBAD_LABEL_NUMBER_INVALID);
1489 ffebad_here (0, ffelex_token_where_line (label_token),
1490 ffelex_token_where_column (label_token));
1491 ffebad_finish ();
1492 return FALSE;
1493 }
1494
1495 label = ffelab_find (label_value);
1496 if (label == NULL)
1497 {
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)));
1503 }
1504
1505 switch (ffelab_type (label))
1506 {
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 ()));
1511 break;
1512
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. */
1520 if (block == NULL)
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));
1527 ffebad_finish ();
1528 break;
1529 }
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)));
1535 break;
1536
1537 case FFELAB_typeNOTLOOP:
1538 case FFELAB_typeENDIF:
1539 if (ffelab_blocknum (label) == ffestw_blocknum (ffestw_stack_top ()))
1540 break;
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));
1555 ffebad_finish ();
1556 break;
1557 }
1558 ffelab_set_blocknum (label, ffestw_blocknum (block));
1559 break;
1560
1561 case FFELAB_typeFORMAT:
1562 if (ffewhere_line_is_unknown (ffelab_definition_line (label)))
1563 {
1564 ffelab_set_type (label, FFELAB_typeANY);
1565 ffestd_labeldef_any (label);
1566
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));
1571 ffebad_finish ();
1572
1573 ffestc_try_shriek_do_ ();
1574
1575 return FALSE;
1576 }
1577 /* Fall through. */
1578 case FFELAB_typeUSELESS:
1579 ffelab_set_type (label, FFELAB_typeANY);
1580 ffestd_labeldef_any (label);
1581
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));
1586 ffebad_finish ();
1587
1588 ffestc_try_shriek_do_ ();
1589
1590 return FALSE;
1591
1592 default:
1593 assert ("bad label" == NULL);
1594 /* Fall through. */
1595 case FFELAB_typeANY:
1596 break;
1597 }
1598
1599 *x_label = label;
1600 return TRUE;
1601 }
1602
1603 /* ffestc_labelref_is_format_ -- Reference to label in [FMT=] specification
1604
1605 if (ffestc_labelref_is_format_(label_token,&label))
1606 // label ref is ok, label is filled in with ffelab object */
1607
1608 static bool
ffestc_labelref_is_format_(ffelexToken label_token,ffelab * x_label)1609 ffestc_labelref_is_format_ (ffelexToken label_token, ffelab *x_label)
1610 {
1611 ffelab label;
1612 ffelabValue label_value;
1613
1614 label_value = (ffelabValue) atol (ffelex_token_text (label_token));
1615 if ((label_value == 0) || (label_value > FFELAB_valueMAX))
1616 {
1617 ffebad_start (FFEBAD_LABEL_NUMBER_INVALID);
1618 ffebad_here (0, ffelex_token_where_line (label_token),
1619 ffelex_token_where_column (label_token));
1620 ffebad_finish ();
1621 return FALSE;
1622 }
1623
1624 label = ffelab_find (label_value);
1625 if (label == NULL)
1626 {
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)));
1632 }
1633
1634 switch (ffelab_type (label))
1635 {
1636 case FFELAB_typeUNKNOWN:
1637 case FFELAB_typeASSIGNABLE:
1638 ffelab_set_type (label, FFELAB_typeFORMAT);
1639 break;
1640
1641 case FFELAB_typeFORMAT:
1642 break;
1643
1644 case FFELAB_typeLOOPEND:
1645 case FFELAB_typeNOTLOOP:
1646 if (ffewhere_line_is_unknown (ffelab_definition_line (label)))
1647 {
1648 ffelab_set_type (label, FFELAB_typeANY);
1649 ffestd_labeldef_any (label);
1650
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));
1655 ffebad_finish ();
1656
1657 ffestc_try_shriek_do_ ();
1658
1659 return FALSE;
1660 }
1661 /* Fall through. */
1662 case FFELAB_typeUSELESS:
1663 case FFELAB_typeENDIF:
1664 ffelab_set_type (label, FFELAB_typeANY);
1665 ffestd_labeldef_any (label);
1666
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));
1671 ffebad_finish ();
1672
1673 ffestc_try_shriek_do_ ();
1674
1675 return FALSE;
1676
1677 default:
1678 assert ("bad label" == NULL);
1679 /* Fall through. */
1680 case FFELAB_typeANY:
1681 break;
1682 }
1683
1684 ffestc_try_shriek_do_ ();
1685
1686 *x_label = label;
1687 return TRUE;
1688 }
1689
1690 /* ffestc_labelref_is_loopend_ -- Reference to label in DO stmt
1691
1692 if (ffestc_labelref_is_loopend_(label_token,&label))
1693 // label ref is ok, label is filled in with ffelab object */
1694
1695 static bool
ffestc_labelref_is_loopend_(ffelexToken label_token,ffelab * x_label)1696 ffestc_labelref_is_loopend_ (ffelexToken label_token, ffelab *x_label)
1697 {
1698 ffelab label;
1699 ffelabValue label_value;
1700
1701 label_value = (ffelabValue) atol (ffelex_token_text (label_token));
1702 if ((label_value == 0) || (label_value > FFELAB_valueMAX))
1703 {
1704 ffebad_start (FFEBAD_LABEL_NUMBER_INVALID);
1705 ffebad_here (0, ffelex_token_where_line (label_token),
1706 ffelex_token_where_column (label_token));
1707 ffebad_finish ();
1708 return FALSE;
1709 }
1710
1711 label = ffelab_find (label_value);
1712 if (label == NULL)
1713 {
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)));
1719 }
1720
1721 switch (ffelab_type (label))
1722 {
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 ());
1732 /* Fall through. */
1733 case FFELAB_typeUNKNOWN:
1734 ffelab_set_type (label, FFELAB_typeLOOPEND);
1735 ffelab_set_blocknum (label, 0);
1736 break;
1737
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);
1743
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));
1749 ffebad_finish ();
1750
1751 ffestc_try_shriek_do_ ();
1752
1753 return FALSE;
1754 }
1755 if (ffelab_blocknum (label) != 0)
1756 { /* Had a branch ref earlier, can't go inside
1757 this new block! */
1758 ffelab_set_type (label, FFELAB_typeANY);
1759 ffestd_labeldef_any (label);
1760
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));
1766 ffebad_finish ();
1767
1768 ffestc_try_shriek_do_ ();
1769
1770 return FALSE;
1771 }
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);
1778
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));
1785 ffebad_finish ();
1786
1787 ffestc_try_shriek_do_ ();
1788
1789 return FALSE;
1790 }
1791 break;
1792
1793 case FFELAB_typeNOTLOOP:
1794 case FFELAB_typeFORMAT:
1795 if (ffewhere_line_is_unknown (ffelab_definition_line (label)))
1796 {
1797 ffelab_set_type (label, FFELAB_typeANY);
1798 ffestd_labeldef_any (label);
1799
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));
1804 ffebad_finish ();
1805
1806 ffestc_try_shriek_do_ ();
1807
1808 return FALSE;
1809 }
1810 /* Fall through. */
1811 case FFELAB_typeUSELESS:
1812 case FFELAB_typeENDIF:
1813 ffelab_set_type (label, FFELAB_typeANY);
1814 ffestd_labeldef_any (label);
1815
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));
1820 ffebad_finish ();
1821
1822 ffestc_try_shriek_do_ ();
1823
1824 return FALSE;
1825
1826 default:
1827 assert ("bad label" == NULL);
1828 /* Fall through. */
1829 case FFELAB_typeANY:
1830 break;
1831 }
1832
1833 *x_label = label;
1834 return TRUE;
1835 }
1836
1837 /* ffestc_order_access_ -- Check ordering on <access> statement
1838
1839 if (ffestc_order_access_() != FFESTC_orderOK_)
1840 return; */
1841
1842 #if FFESTR_F90
1843 static ffestcOrder_
ffestc_order_access_()1844 ffestc_order_access_ ()
1845 {
1846 recurse:
1847
1848 switch (ffestw_state (ffestw_stack_top ()))
1849 {
1850 case FFESTV_stateNIL:
1851 ffestc_shriek_begin_program_ ();
1852 goto recurse; /* :::::::::::::::::::: */
1853
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_;
1860
1861 case FFESTV_stateMODULE3:
1862 return FFESTC_orderOK_;
1863
1864 case FFESTV_stateUSE:
1865 #if FFESTR_F90
1866 ffestc_shriek_end_uses_ (TRUE);
1867 #endif
1868 goto recurse; /* :::::::::::::::::::: */
1869
1870 case FFESTV_stateWHERE:
1871 ffestc_order_bad_ ();
1872 #if FFESTR_F90
1873 ffestc_shriek_where_ (FALSE);
1874 #endif
1875 return FFESTC_orderBAD_;
1876
1877 case FFESTV_stateIF:
1878 ffestc_order_bad_ ();
1879 ffestc_shriek_if_ (FALSE);
1880 return FFESTC_orderBAD_;
1881
1882 default:
1883 ffestc_order_bad_ ();
1884 return FFESTC_orderBAD_;
1885 }
1886 }
1887
1888 #endif
1889 /* ffestc_order_actiondo_ -- Check ordering on <actiondo> statement
1890
1891 if (ffestc_order_actiondo_() != FFESTC_orderOK_)
1892 return; */
1893
1894 static ffestcOrder_
ffestc_order_actiondo_()1895 ffestc_order_actiondo_ ()
1896 {
1897 recurse:
1898
1899 switch (ffestw_state (ffestw_stack_top ()))
1900 {
1901 case FFESTV_stateNIL:
1902 ffestc_shriek_begin_program_ ();
1903 goto recurse; /* :::::::::::::::::::: */
1904
1905 case FFESTV_stateDO:
1906 return FFESTC_orderOK_;
1907
1908 case FFESTV_stateIFTHEN:
1909 case FFESTV_stateSELECT1:
1910 if (ffestw_top_do (ffestw_stack_top ()) == NULL)
1911 break;
1912 return FFESTC_orderOK_;
1913
1914 case FFESTV_stateIF:
1915 if (ffestw_top_do (ffestw_stack_top ()) == NULL)
1916 break;
1917 ffestc_shriek_after1_ = ffestc_shriek_if_;
1918 return FFESTC_orderOK_;
1919
1920 case FFESTV_stateUSE:
1921 #if FFESTR_F90
1922 ffestc_shriek_end_uses_ (TRUE);
1923 #endif
1924 goto recurse; /* :::::::::::::::::::: */
1925
1926 case FFESTV_stateWHERE:
1927 ffestc_order_bad_ ();
1928 #if FFESTR_F90
1929 ffestc_shriek_where_ (FALSE);
1930 #endif
1931 return FFESTC_orderBAD_;
1932
1933 default:
1934 break;
1935 }
1936 ffestc_order_bad_ ();
1937 return FFESTC_orderBAD_;
1938 }
1939
1940 /* ffestc_order_actionif_ -- Check ordering on <actionif> statement
1941
1942 if (ffestc_order_actionif_() != FFESTC_orderOK_)
1943 return; */
1944
1945 static ffestcOrder_
ffestc_order_actionif_()1946 ffestc_order_actionif_ ()
1947 {
1948 bool update;
1949
1950 recurse:
1951
1952 switch (ffestw_state (ffestw_stack_top ()))
1953 {
1954 case FFESTV_stateNIL:
1955 ffestc_shriek_begin_program_ ();
1956 goto recurse; /* :::::::::::::::::::: */
1957
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);
1963 update = TRUE;
1964 break;
1965
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);
1971 update = TRUE;
1972 break;
1973
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);
1979 update = TRUE;
1980 break;
1981
1982 case FFESTV_statePROGRAM4:
1983 case FFESTV_stateSUBROUTINE4:
1984 case FFESTV_stateFUNCTION4:
1985 update = FALSE;
1986 break;
1987
1988 case FFESTV_stateIFTHEN:
1989 case FFESTV_stateDO:
1990 case FFESTV_stateSELECT1:
1991 return FFESTC_orderOK_;
1992
1993 case FFESTV_stateIF:
1994 ffestc_shriek_after1_ = ffestc_shriek_if_;
1995 return FFESTC_orderOK_;
1996
1997 case FFESTV_stateUSE:
1998 #if FFESTR_F90
1999 ffestc_shriek_end_uses_ (TRUE);
2000 #endif
2001 goto recurse; /* :::::::::::::::::::: */
2002
2003 case FFESTV_stateWHERE:
2004 ffestc_order_bad_ ();
2005 #if FFESTR_F90
2006 ffestc_shriek_where_ (FALSE);
2007 #endif
2008 return FFESTC_orderBAD_;
2009
2010 default:
2011 ffestc_order_bad_ ();
2012 return FFESTC_orderBAD_;
2013 }
2014
2015 switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
2016 {
2017 case FFESTV_stateINTERFACE0:
2018 ffestc_order_bad_ ();
2019 if (update)
2020 ffestw_update (NULL);
2021 return FFESTC_orderBAD_;
2022
2023 default:
2024 if (update)
2025 ffestw_update (NULL);
2026 return FFESTC_orderOK_;
2027 }
2028 }
2029
2030 /* ffestc_order_actionwhere_ -- Check ordering on <actionwhere> statement
2031
2032 if (ffestc_order_actionwhere_() != FFESTC_orderOK_)
2033 return; */
2034
2035 static ffestcOrder_
ffestc_order_actionwhere_()2036 ffestc_order_actionwhere_ ()
2037 {
2038 bool update;
2039
2040 recurse:
2041
2042 switch (ffestw_state (ffestw_stack_top ()))
2043 {
2044 case FFESTV_stateNIL:
2045 ffestc_shriek_begin_program_ ();
2046 goto recurse; /* :::::::::::::::::::: */
2047
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);
2053 update = TRUE;
2054 break;
2055
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);
2061 update = TRUE;
2062 break;
2063
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);
2069 update = TRUE;
2070 break;
2071
2072 case FFESTV_statePROGRAM4:
2073 case FFESTV_stateSUBROUTINE4:
2074 case FFESTV_stateFUNCTION4:
2075 update = FALSE;
2076 break;
2077
2078 case FFESTV_stateWHERETHEN:
2079 case FFESTV_stateIFTHEN:
2080 case FFESTV_stateDO:
2081 case FFESTV_stateSELECT1:
2082 return FFESTC_orderOK_;
2083
2084 case FFESTV_stateWHERE:
2085 #if FFESTR_F90
2086 ffestc_shriek_after1_ = ffestc_shriek_where_;
2087 #endif
2088 return FFESTC_orderOK_;
2089
2090 case FFESTV_stateIF:
2091 ffestc_shriek_after1_ = ffestc_shriek_if_;
2092 return FFESTC_orderOK_;
2093
2094 case FFESTV_stateUSE:
2095 #if FFESTR_F90
2096 ffestc_shriek_end_uses_ (TRUE);
2097 #endif
2098 goto recurse; /* :::::::::::::::::::: */
2099
2100 default:
2101 ffestc_order_bad_ ();
2102 return FFESTC_orderBAD_;
2103 }
2104
2105 switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
2106 {
2107 case FFESTV_stateINTERFACE0:
2108 ffestc_order_bad_ ();
2109 if (update)
2110 ffestw_update (NULL);
2111 return FFESTC_orderBAD_;
2112
2113 default:
2114 if (update)
2115 ffestw_update (NULL);
2116 return FFESTC_orderOK_;
2117 }
2118 }
2119
2120 /* Check ordering on "any" statement. Like _actionwhere_, but
2121 doesn't produce any diagnostics. */
2122
2123 static void
ffestc_order_any_()2124 ffestc_order_any_ ()
2125 {
2126 bool update;
2127
2128 recurse:
2129
2130 switch (ffestw_state (ffestw_stack_top ()))
2131 {
2132 case FFESTV_stateNIL:
2133 ffestc_shriek_begin_program_ ();
2134 goto recurse; /* :::::::::::::::::::: */
2135
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);
2141 update = TRUE;
2142 break;
2143
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);
2149 update = TRUE;
2150 break;
2151
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);
2157 update = TRUE;
2158 break;
2159
2160 case FFESTV_statePROGRAM4:
2161 case FFESTV_stateSUBROUTINE4:
2162 case FFESTV_stateFUNCTION4:
2163 update = FALSE;
2164 break;
2165
2166 case FFESTV_stateWHERETHEN:
2167 case FFESTV_stateIFTHEN:
2168 case FFESTV_stateDO:
2169 case FFESTV_stateSELECT1:
2170 return;
2171
2172 case FFESTV_stateWHERE:
2173 #if FFESTR_F90
2174 ffestc_shriek_after1_ = ffestc_shriek_where_;
2175 #endif
2176 return;
2177
2178 case FFESTV_stateIF:
2179 ffestc_shriek_after1_ = ffestc_shriek_if_;
2180 return;
2181
2182 case FFESTV_stateUSE:
2183 #if FFESTR_F90
2184 ffestc_shriek_end_uses_ (TRUE);
2185 #endif
2186 goto recurse; /* :::::::::::::::::::: */
2187
2188 default:
2189 return;
2190 }
2191
2192 switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
2193 {
2194 case FFESTV_stateINTERFACE0:
2195 if (update)
2196 ffestw_update (NULL);
2197 return;
2198
2199 default:
2200 if (update)
2201 ffestw_update (NULL);
2202 return;
2203 }
2204 }
2205
2206 /* ffestc_order_bad_ -- Whine about statement ordering violation
2207
2208 ffestc_order_bad_();
2209
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
2213 now. */
2214
2215 static void
ffestc_order_bad_()2216 ffestc_order_bad_ ()
2217 {
2218 if (ffewhere_line_is_unknown (ffestw_line (ffestw_stack_top ())))
2219 {
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]));
2223 ffebad_finish ();
2224 }
2225 else
2226 {
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 ()));
2231 ffebad_finish ();
2232 }
2233 ffestc_labeldef_useless_ (); /* Any label definition is useless. */
2234 }
2235
2236 /* ffestc_order_blockdata_ -- Check ordering on <blockdata> statement
2237
2238 if (ffestc_order_blockdata_() != FFESTC_orderOK_)
2239 return; */
2240
2241 static ffestcOrder_
ffestc_order_blockdata_()2242 ffestc_order_blockdata_ ()
2243 {
2244 recurse:
2245
2246 switch (ffestw_state (ffestw_stack_top ()))
2247 {
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_;
2255
2256 case FFESTV_stateUSE:
2257 #if FFESTR_F90
2258 ffestc_shriek_end_uses_ (TRUE);
2259 #endif
2260 goto recurse; /* :::::::::::::::::::: */
2261
2262 case FFESTV_stateWHERE:
2263 ffestc_order_bad_ ();
2264 #if FFESTR_F90
2265 ffestc_shriek_where_ (FALSE);
2266 #endif
2267 return FFESTC_orderBAD_;
2268
2269 case FFESTV_stateIF:
2270 ffestc_order_bad_ ();
2271 ffestc_shriek_if_ (FALSE);
2272 return FFESTC_orderBAD_;
2273
2274 default:
2275 ffestc_order_bad_ ();
2276 return FFESTC_orderBAD_;
2277 }
2278 }
2279
2280 /* ffestc_order_blockspec_ -- Check ordering on <blockspec> statement
2281
2282 if (ffestc_order_blockspec_() != FFESTC_orderOK_)
2283 return; */
2284
2285 static ffestcOrder_
ffestc_order_blockspec_()2286 ffestc_order_blockspec_ ()
2287 {
2288 recurse:
2289
2290 switch (ffestw_state (ffestw_stack_top ()))
2291 {
2292 case FFESTV_stateNIL:
2293 ffestc_shriek_begin_program_ ();
2294 goto recurse; /* :::::::::::::::::::: */
2295
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_;
2302
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_;
2309
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_;
2316
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_;
2323
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_;
2330
2331 case FFESTV_statePROGRAM3:
2332 case FFESTV_stateSUBROUTINE3:
2333 case FFESTV_stateFUNCTION3:
2334 case FFESTV_stateMODULE3:
2335 case FFESTV_stateBLOCKDATA3:
2336 return FFESTC_orderOK_;
2337
2338 case FFESTV_stateUSE:
2339 #if FFESTR_F90
2340 ffestc_shriek_end_uses_ (TRUE);
2341 #endif
2342 goto recurse; /* :::::::::::::::::::: */
2343
2344 case FFESTV_stateWHERE:
2345 ffestc_order_bad_ ();
2346 #if FFESTR_F90
2347 ffestc_shriek_where_ (FALSE);
2348 #endif
2349 return FFESTC_orderBAD_;
2350
2351 case FFESTV_stateIF:
2352 ffestc_order_bad_ ();
2353 ffestc_shriek_if_ (FALSE);
2354 return FFESTC_orderBAD_;
2355
2356 default:
2357 ffestc_order_bad_ ();
2358 return FFESTC_orderBAD_;
2359 }
2360 }
2361
2362 /* ffestc_order_component_ -- Check ordering on <component-decl> statement
2363
2364 if (ffestc_order_component_() != FFESTC_orderOK_)
2365 return; */
2366
2367 #if FFESTR_F90
2368 static ffestcOrder_
ffestc_order_component_()2369 ffestc_order_component_ ()
2370 {
2371 switch (ffestw_state (ffestw_stack_top ()))
2372 {
2373 case FFESTV_stateTYPE:
2374 case FFESTV_stateSTRUCTURE:
2375 case FFESTV_stateMAP:
2376 return FFESTC_orderOK_;
2377
2378 case FFESTV_stateWHERE:
2379 ffestc_order_bad_ ();
2380 ffestc_shriek_where_ (FALSE);
2381 return FFESTC_orderBAD_;
2382
2383 case FFESTV_stateIF:
2384 ffestc_order_bad_ ();
2385 ffestc_shriek_if_ (FALSE);
2386 return FFESTC_orderBAD_;
2387
2388 default:
2389 ffestc_order_bad_ ();
2390 return FFESTC_orderBAD_;
2391 }
2392 }
2393
2394 #endif
2395 /* ffestc_order_contains_ -- Check ordering on CONTAINS statement
2396
2397 if (ffestc_order_contains_() != FFESTC_orderOK_)
2398 return; */
2399
2400 #if FFESTR_F90
2401 static ffestcOrder_
ffestc_order_contains_()2402 ffestc_order_contains_ ()
2403 {
2404 recurse:
2405
2406 switch (ffestw_state (ffestw_stack_top ()))
2407 {
2408 case FFESTV_stateNIL:
2409 ffestc_shriek_begin_program_ ();
2410 goto recurse; /* :::::::::::::::::::: */
2411
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);
2418 break;
2419
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);
2426 break;
2427
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);
2434 break;
2435
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);
2442 break;
2443
2444 case FFESTV_stateUSE:
2445 ffestc_shriek_end_uses_ (TRUE);
2446 goto recurse; /* :::::::::::::::::::: */
2447
2448 case FFESTV_stateWHERE:
2449 ffestc_order_bad_ ();
2450 ffestc_shriek_where_ (FALSE);
2451 return FFESTC_orderBAD_;
2452
2453 case FFESTV_stateIF:
2454 ffestc_order_bad_ ();
2455 ffestc_shriek_if_ (FALSE);
2456 return FFESTC_orderBAD_;
2457
2458 default:
2459 ffestc_order_bad_ ();
2460 return FFESTC_orderBAD_;
2461 }
2462
2463 switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
2464 {
2465 case FFESTV_stateNIL:
2466 ffestw_update (NULL);
2467 return FFESTC_orderOK_;
2468
2469 default:
2470 ffestc_order_bad_ ();
2471 ffestw_update (NULL);
2472 return FFESTC_orderBAD_;
2473 }
2474 }
2475
2476 #endif
2477 /* ffestc_order_data_ -- Check ordering on DATA statement
2478
2479 if (ffestc_order_data_() != FFESTC_orderOK_)
2480 return; */
2481
2482 static ffestcOrder_
ffestc_order_data_()2483 ffestc_order_data_ ()
2484 {
2485 recurse:
2486
2487 switch (ffestw_state (ffestw_stack_top ()))
2488 {
2489 case FFESTV_stateNIL:
2490 ffestc_shriek_begin_program_ ();
2491 goto recurse; /* :::::::::::::::::::: */
2492
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_;
2498
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_;
2504
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_;
2510
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_;
2516
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_;
2535
2536 case FFESTV_stateUSE:
2537 #if FFESTR_F90
2538 ffestc_shriek_end_uses_ (TRUE);
2539 #endif
2540 goto recurse; /* :::::::::::::::::::: */
2541
2542 case FFESTV_stateWHERE:
2543 ffestc_order_bad_ ();
2544 #if FFESTR_F90
2545 ffestc_shriek_where_ (FALSE);
2546 #endif
2547 return FFESTC_orderBAD_;
2548
2549 case FFESTV_stateIF:
2550 ffestc_order_bad_ ();
2551 ffestc_shriek_if_ (FALSE);
2552 return FFESTC_orderBAD_;
2553
2554 default:
2555 ffestc_order_bad_ ();
2556 return FFESTC_orderBAD_;
2557 }
2558 }
2559
2560 /* ffestc_order_data77_ -- Check ordering on pedantic-F77 DATA statement
2561
2562 if (ffestc_order_data77_() != FFESTC_orderOK_)
2563 return; */
2564
2565 static ffestcOrder_
ffestc_order_data77_()2566 ffestc_order_data77_ ()
2567 {
2568 recurse:
2569
2570 switch (ffestw_state (ffestw_stack_top ()))
2571 {
2572 case FFESTV_stateNIL:
2573 ffestc_shriek_begin_program_ ();
2574 goto recurse; /* :::::::::::::::::::: */
2575
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_;
2583
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_;
2591
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_;
2599
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_;
2607
2608 case FFESTV_statePROGRAM4:
2609 case FFESTV_stateSUBROUTINE4:
2610 case FFESTV_stateFUNCTION4:
2611 case FFESTV_stateBLOCKDATA4:
2612 return FFESTC_orderOK_;
2613
2614 case FFESTV_stateWHERETHEN:
2615 case FFESTV_stateIFTHEN:
2616 case FFESTV_stateDO:
2617 case FFESTV_stateSELECT0:
2618 case FFESTV_stateSELECT1:
2619 return FFESTC_orderOK_;
2620
2621 case FFESTV_stateUSE:
2622 #if FFESTR_F90
2623 ffestc_shriek_end_uses_ (TRUE);
2624 #endif
2625 goto recurse; /* :::::::::::::::::::: */
2626
2627 case FFESTV_stateWHERE:
2628 ffestc_order_bad_ ();
2629 #if FFESTR_F90
2630 ffestc_shriek_where_ (FALSE);
2631 #endif
2632 return FFESTC_orderBAD_;
2633
2634 case FFESTV_stateIF:
2635 ffestc_order_bad_ ();
2636 ffestc_shriek_if_ (FALSE);
2637 return FFESTC_orderBAD_;
2638
2639 default:
2640 ffestc_order_bad_ ();
2641 return FFESTC_orderBAD_;
2642 }
2643 }
2644
2645 /* ffestc_order_derivedtype_ -- Check ordering on derived TYPE statement
2646
2647 if (ffestc_order_derivedtype_() != FFESTC_orderOK_)
2648 return; */
2649
2650 #if FFESTR_F90
2651 static ffestcOrder_
ffestc_order_derivedtype_()2652 ffestc_order_derivedtype_ ()
2653 {
2654 recurse:
2655
2656 switch (ffestw_state (ffestw_stack_top ()))
2657 {
2658 case FFESTV_stateNIL:
2659 ffestc_shriek_begin_program_ ();
2660 goto recurse; /* :::::::::::::::::::: */
2661
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_;
2668
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_;
2675
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_;
2682
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_;
2689
2690 case FFESTV_statePROGRAM3:
2691 case FFESTV_stateSUBROUTINE3:
2692 case FFESTV_stateFUNCTION3:
2693 case FFESTV_stateMODULE3:
2694 return FFESTC_orderOK_;
2695
2696 case FFESTV_stateUSE:
2697 ffestc_shriek_end_uses_ (TRUE);
2698 goto recurse; /* :::::::::::::::::::: */
2699
2700 case FFESTV_stateWHERE:
2701 ffestc_order_bad_ ();
2702 ffestc_shriek_where_ (FALSE);
2703 return FFESTC_orderBAD_;
2704
2705 case FFESTV_stateIF:
2706 ffestc_order_bad_ ();
2707 ffestc_shriek_if_ (FALSE);
2708 return FFESTC_orderBAD_;
2709
2710 default:
2711 ffestc_order_bad_ ();
2712 return FFESTC_orderBAD_;
2713 }
2714 }
2715
2716 #endif
2717 /* ffestc_order_do_ -- Check ordering on <do> statement
2718
2719 if (ffestc_order_do_() != FFESTC_orderOK_)
2720 return; */
2721
2722 static ffestcOrder_
ffestc_order_do_()2723 ffestc_order_do_ ()
2724 {
2725 switch (ffestw_state (ffestw_stack_top ()))
2726 {
2727 case FFESTV_stateDO:
2728 return FFESTC_orderOK_;
2729
2730 case FFESTV_stateWHERE:
2731 ffestc_order_bad_ ();
2732 #if FFESTR_F90
2733 ffestc_shriek_where_ (FALSE);
2734 #endif
2735 return FFESTC_orderBAD_;
2736
2737 case FFESTV_stateIF:
2738 ffestc_order_bad_ ();
2739 ffestc_shriek_if_ (FALSE);
2740 return FFESTC_orderBAD_;
2741
2742 default:
2743 ffestc_order_bad_ ();
2744 return FFESTC_orderBAD_;
2745 }
2746 }
2747
2748 /* ffestc_order_entry_ -- Check ordering on ENTRY statement
2749
2750 if (ffestc_order_entry_() != FFESTC_orderOK_)
2751 return; */
2752
2753 static ffestcOrder_
ffestc_order_entry_()2754 ffestc_order_entry_ ()
2755 {
2756 recurse:
2757
2758 switch (ffestw_state (ffestw_stack_top ()))
2759 {
2760 case FFESTV_stateNIL:
2761 ffestc_shriek_begin_program_ ();
2762 goto recurse; /* :::::::::::::::::::: */
2763
2764 case FFESTV_stateSUBROUTINE0:
2765 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE1);
2766 break;
2767
2768 case FFESTV_stateFUNCTION0:
2769 ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION1);
2770 break;
2771
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:
2780 break;
2781
2782 case FFESTV_stateUSE:
2783 #if FFESTR_F90
2784 ffestc_shriek_end_uses_ (TRUE);
2785 #endif
2786 goto recurse; /* :::::::::::::::::::: */
2787
2788 case FFESTV_stateWHERE:
2789 ffestc_order_bad_ ();
2790 #if FFESTR_F90
2791 ffestc_shriek_where_ (FALSE);
2792 #endif
2793 return FFESTC_orderBAD_;
2794
2795 case FFESTV_stateIF:
2796 ffestc_order_bad_ ();
2797 ffestc_shriek_if_ (FALSE);
2798 return FFESTC_orderBAD_;
2799
2800 default:
2801 ffestc_order_bad_ ();
2802 return FFESTC_orderBAD_;
2803 }
2804
2805 switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
2806 {
2807 case FFESTV_stateNIL:
2808 case FFESTV_stateMODULE5:
2809 ffestw_update (NULL);
2810 return FFESTC_orderOK_;
2811
2812 default:
2813 ffestc_order_bad_ ();
2814 ffestw_update (NULL);
2815 return FFESTC_orderBAD_;
2816 }
2817 }
2818
2819 /* ffestc_order_exec_ -- Check ordering on <exec> statement
2820
2821 if (ffestc_order_exec_() != FFESTC_orderOK_)
2822 return; */
2823
2824 static ffestcOrder_
ffestc_order_exec_()2825 ffestc_order_exec_ ()
2826 {
2827 bool update;
2828
2829 recurse:
2830
2831 switch (ffestw_state (ffestw_stack_top ()))
2832 {
2833 case FFESTV_stateNIL:
2834 ffestc_shriek_begin_program_ ();
2835 goto recurse; /* :::::::::::::::::::: */
2836
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);
2842 update = TRUE;
2843 break;
2844
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);
2850 update = TRUE;
2851 break;
2852
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);
2858 update = TRUE;
2859 break;
2860
2861 case FFESTV_statePROGRAM4:
2862 case FFESTV_stateSUBROUTINE4:
2863 case FFESTV_stateFUNCTION4:
2864 update = FALSE;
2865 break;
2866
2867 case FFESTV_stateIFTHEN:
2868 case FFESTV_stateDO:
2869 case FFESTV_stateSELECT1:
2870 return FFESTC_orderOK_;
2871
2872 case FFESTV_stateUSE:
2873 #if FFESTR_F90
2874 ffestc_shriek_end_uses_ (TRUE);
2875 #endif
2876 goto recurse; /* :::::::::::::::::::: */
2877
2878 case FFESTV_stateWHERE:
2879 ffestc_order_bad_ ();
2880 #if FFESTR_F90
2881 ffestc_shriek_where_ (FALSE);
2882 #endif
2883 return FFESTC_orderBAD_;
2884
2885 case FFESTV_stateIF:
2886 ffestc_order_bad_ ();
2887 ffestc_shriek_if_ (FALSE);
2888 return FFESTC_orderBAD_;
2889
2890 default:
2891 ffestc_order_bad_ ();
2892 return FFESTC_orderBAD_;
2893 }
2894
2895 switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
2896 {
2897 case FFESTV_stateINTERFACE0:
2898 ffestc_order_bad_ ();
2899 if (update)
2900 ffestw_update (NULL);
2901 return FFESTC_orderBAD_;
2902
2903 default:
2904 if (update)
2905 ffestw_update (NULL);
2906 return FFESTC_orderOK_;
2907 }
2908 }
2909
2910 /* ffestc_order_format_ -- Check ordering on FORMAT statement
2911
2912 if (ffestc_order_format_() != FFESTC_orderOK_)
2913 return; */
2914
2915 static ffestcOrder_
ffestc_order_format_()2916 ffestc_order_format_ ()
2917 {
2918 recurse:
2919
2920 switch (ffestw_state (ffestw_stack_top ()))
2921 {
2922 case FFESTV_stateNIL:
2923 ffestc_shriek_begin_program_ ();
2924 goto recurse; /* :::::::::::::::::::: */
2925
2926 case FFESTV_statePROGRAM0:
2927 ffestw_update (NULL);
2928 ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM1);
2929 return FFESTC_orderOK_;
2930
2931 case FFESTV_stateSUBROUTINE0:
2932 ffestw_update (NULL);
2933 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE1);
2934 return FFESTC_orderOK_;
2935
2936 case FFESTV_stateFUNCTION0:
2937 ffestw_update (NULL);
2938 ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION1);
2939 return FFESTC_orderOK_;
2940
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_;
2959
2960 case FFESTV_stateUSE:
2961 #if FFESTR_F90
2962 ffestc_shriek_end_uses_ (TRUE);
2963 #endif
2964 goto recurse; /* :::::::::::::::::::: */
2965
2966 case FFESTV_stateWHERE:
2967 ffestc_order_bad_ ();
2968 #if FFESTR_F90
2969 ffestc_shriek_where_ (FALSE);
2970 #endif
2971 return FFESTC_orderBAD_;
2972
2973 case FFESTV_stateIF:
2974 ffestc_order_bad_ ();
2975 ffestc_shriek_if_ (FALSE);
2976 return FFESTC_orderBAD_;
2977
2978 default:
2979 ffestc_order_bad_ ();
2980 return FFESTC_orderBAD_;
2981 }
2982 }
2983
2984 /* ffestc_order_function_ -- Check ordering on <function> statement
2985
2986 if (ffestc_order_function_() != FFESTC_orderOK_)
2987 return; */
2988
2989 static ffestcOrder_
ffestc_order_function_()2990 ffestc_order_function_ ()
2991 {
2992 recurse:
2993
2994 switch (ffestw_state (ffestw_stack_top ()))
2995 {
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_;
3003
3004 case FFESTV_stateUSE:
3005 #if FFESTR_F90
3006 ffestc_shriek_end_uses_ (TRUE);
3007 #endif
3008 goto recurse; /* :::::::::::::::::::: */
3009
3010 case FFESTV_stateWHERE:
3011 ffestc_order_bad_ ();
3012 #if FFESTR_F90
3013 ffestc_shriek_where_ (FALSE);
3014 #endif
3015 return FFESTC_orderBAD_;
3016
3017 case FFESTV_stateIF:
3018 ffestc_order_bad_ ();
3019 ffestc_shriek_if_ (FALSE);
3020 return FFESTC_orderBAD_;
3021
3022 default:
3023 ffestc_order_bad_ ();
3024 return FFESTC_orderBAD_;
3025 }
3026 }
3027
3028 /* ffestc_order_iface_ -- Check ordering on <iface> statement
3029
3030 if (ffestc_order_iface_() != FFESTC_orderOK_)
3031 return; */
3032
3033 static ffestcOrder_
ffestc_order_iface_()3034 ffestc_order_iface_ ()
3035 {
3036 switch (ffestw_state (ffestw_stack_top ()))
3037 {
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_;
3045
3046 case FFESTV_stateWHERE:
3047 ffestc_order_bad_ ();
3048 #if FFESTR_F90
3049 ffestc_shriek_where_ (FALSE);
3050 #endif
3051 return FFESTC_orderBAD_;
3052
3053 case FFESTV_stateIF:
3054 ffestc_order_bad_ ();
3055 ffestc_shriek_if_ (FALSE);
3056 return FFESTC_orderBAD_;
3057
3058 default:
3059 ffestc_order_bad_ ();
3060 return FFESTC_orderBAD_;
3061 }
3062 }
3063
3064 /* ffestc_order_ifthen_ -- Check ordering on <ifthen> statement
3065
3066 if (ffestc_order_ifthen_() != FFESTC_orderOK_)
3067 return; */
3068
3069 static ffestcOrder_
ffestc_order_ifthen_()3070 ffestc_order_ifthen_ ()
3071 {
3072 switch (ffestw_state (ffestw_stack_top ()))
3073 {
3074 case FFESTV_stateIFTHEN:
3075 return FFESTC_orderOK_;
3076
3077 case FFESTV_stateWHERE:
3078 ffestc_order_bad_ ();
3079 #if FFESTR_F90
3080 ffestc_shriek_where_ (FALSE);
3081 #endif
3082 return FFESTC_orderBAD_;
3083
3084 case FFESTV_stateIF:
3085 ffestc_order_bad_ ();
3086 ffestc_shriek_if_ (FALSE);
3087 return FFESTC_orderBAD_;
3088
3089 default:
3090 ffestc_order_bad_ ();
3091 return FFESTC_orderBAD_;
3092 }
3093 }
3094
3095 /* ffestc_order_implicit_ -- Check ordering on IMPLICIT statement
3096
3097 if (ffestc_order_implicit_() != FFESTC_orderOK_)
3098 return; */
3099
3100 static ffestcOrder_
ffestc_order_implicit_()3101 ffestc_order_implicit_ ()
3102 {
3103 recurse:
3104
3105 switch (ffestw_state (ffestw_stack_top ()))
3106 {
3107 case FFESTV_stateNIL:
3108 ffestc_shriek_begin_program_ ();
3109 goto recurse; /* :::::::::::::::::::: */
3110
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_;
3116
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_;
3122
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_;
3128
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_;
3134
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_;
3140
3141 case FFESTV_statePROGRAM2:
3142 case FFESTV_stateSUBROUTINE2:
3143 case FFESTV_stateFUNCTION2:
3144 case FFESTV_stateMODULE2:
3145 case FFESTV_stateBLOCKDATA2:
3146 return FFESTC_orderOK_;
3147
3148 case FFESTV_stateUSE:
3149 #if FFESTR_F90
3150 ffestc_shriek_end_uses_ (TRUE);
3151 #endif
3152 goto recurse; /* :::::::::::::::::::: */
3153
3154 case FFESTV_stateWHERE:
3155 ffestc_order_bad_ ();
3156 #if FFESTR_F90
3157 ffestc_shriek_where_ (FALSE);
3158 #endif
3159 return FFESTC_orderBAD_;
3160
3161 case FFESTV_stateIF:
3162 ffestc_order_bad_ ();
3163 ffestc_shriek_if_ (FALSE);
3164 return FFESTC_orderBAD_;
3165
3166 default:
3167 ffestc_order_bad_ ();
3168 return FFESTC_orderBAD_;
3169 }
3170 }
3171
3172 /* ffestc_order_implicitnone_ -- Check ordering on IMPLICIT NONE statement
3173
3174 if (ffestc_order_implicitnone_() != FFESTC_orderOK_)
3175 return; */
3176
3177 static ffestcOrder_
ffestc_order_implicitnone_()3178 ffestc_order_implicitnone_ ()
3179 {
3180 recurse:
3181
3182 switch (ffestw_state (ffestw_stack_top ()))
3183 {
3184 case FFESTV_stateNIL:
3185 ffestc_shriek_begin_program_ ();
3186 goto recurse; /* :::::::::::::::::::: */
3187
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_;
3193
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_;
3199
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_;
3205
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_;
3211
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_;
3217
3218 case FFESTV_stateUSE:
3219 #if FFESTR_F90
3220 ffestc_shriek_end_uses_ (TRUE);
3221 #endif
3222 goto recurse; /* :::::::::::::::::::: */
3223
3224 case FFESTV_stateWHERE:
3225 ffestc_order_bad_ ();
3226 #if FFESTR_F90
3227 ffestc_shriek_where_ (FALSE);
3228 #endif
3229 return FFESTC_orderBAD_;
3230
3231 case FFESTV_stateIF:
3232 ffestc_order_bad_ ();
3233 ffestc_shriek_if_ (FALSE);
3234 return FFESTC_orderBAD_;
3235
3236 default:
3237 ffestc_order_bad_ ();
3238 return FFESTC_orderBAD_;
3239 }
3240 }
3241
3242 /* ffestc_order_interface_ -- Check ordering on <interface> statement
3243
3244 if (ffestc_order_interface_() != FFESTC_orderOK_)
3245 return; */
3246
3247 #if FFESTR_F90
3248 static ffestcOrder_
ffestc_order_interface_()3249 ffestc_order_interface_ ()
3250 {
3251 switch (ffestw_state (ffestw_stack_top ()))
3252 {
3253 case FFESTV_stateINTERFACE0:
3254 case FFESTV_stateINTERFACE1:
3255 return FFESTC_orderOK_;
3256
3257 case FFESTV_stateWHERE:
3258 ffestc_order_bad_ ();
3259 ffestc_shriek_where_ (FALSE);
3260 return FFESTC_orderBAD_;
3261
3262 case FFESTV_stateIF:
3263 ffestc_order_bad_ ();
3264 ffestc_shriek_if_ (FALSE);
3265 return FFESTC_orderBAD_;
3266
3267 default:
3268 ffestc_order_bad_ ();
3269 return FFESTC_orderBAD_;
3270 }
3271 }
3272
3273 #endif
3274 /* ffestc_order_map_ -- Check ordering on <map> statement
3275
3276 if (ffestc_order_map_() != FFESTC_orderOK_)
3277 return; */
3278
3279 #if FFESTR_VXT
3280 static ffestcOrder_
ffestc_order_map_()3281 ffestc_order_map_ ()
3282 {
3283 switch (ffestw_state (ffestw_stack_top ()))
3284 {
3285 case FFESTV_stateMAP:
3286 return FFESTC_orderOK_;
3287
3288 case FFESTV_stateWHERE:
3289 ffestc_order_bad_ ();
3290 ffestc_shriek_where_ (FALSE);
3291 return FFESTC_orderBAD_;
3292
3293 case FFESTV_stateIF:
3294 ffestc_order_bad_ ();
3295 ffestc_shriek_if_ (FALSE);
3296 return FFESTC_orderBAD_;
3297
3298 default:
3299 ffestc_order_bad_ ();
3300 return FFESTC_orderBAD_;
3301 }
3302 }
3303
3304 #endif
3305 /* ffestc_order_module_ -- Check ordering on <module> statement
3306
3307 if (ffestc_order_module_() != FFESTC_orderOK_)
3308 return; */
3309
3310 #if FFESTR_F90
3311 static ffestcOrder_
ffestc_order_module_()3312 ffestc_order_module_ ()
3313 {
3314 recurse:
3315
3316 switch (ffestw_state (ffestw_stack_top ()))
3317 {
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_;
3325
3326 case FFESTV_stateUSE:
3327 ffestc_shriek_end_uses_ (TRUE);
3328 goto recurse; /* :::::::::::::::::::: */
3329
3330 case FFESTV_stateWHERE:
3331 ffestc_order_bad_ ();
3332 ffestc_shriek_where_ (FALSE);
3333 return FFESTC_orderBAD_;
3334
3335 case FFESTV_stateIF:
3336 ffestc_order_bad_ ();
3337 ffestc_shriek_if_ (FALSE);
3338 return FFESTC_orderBAD_;
3339
3340 default:
3341 ffestc_order_bad_ ();
3342 return FFESTC_orderBAD_;
3343 }
3344 }
3345
3346 #endif
3347 /* ffestc_order_parameter_ -- Check ordering on <parameter> statement
3348
3349 if (ffestc_order_parameter_() != FFESTC_orderOK_)
3350 return; */
3351
3352 static ffestcOrder_
ffestc_order_parameter_()3353 ffestc_order_parameter_ ()
3354 {
3355 recurse:
3356
3357 switch (ffestw_state (ffestw_stack_top ()))
3358 {
3359 case FFESTV_stateNIL:
3360 ffestc_shriek_begin_program_ ();
3361 goto recurse; /* :::::::::::::::::::: */
3362
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_;
3368
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_;
3374
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_;
3380
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_;
3386
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_;
3392
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_;
3408
3409 case FFESTV_stateUSE:
3410 #if FFESTR_F90
3411 ffestc_shriek_end_uses_ (TRUE);
3412 #endif
3413 goto recurse; /* :::::::::::::::::::: */
3414
3415 case FFESTV_stateWHERE:
3416 ffestc_order_bad_ ();
3417 #if FFESTR_F90
3418 ffestc_shriek_where_ (FALSE);
3419 #endif
3420 return FFESTC_orderBAD_;
3421
3422 case FFESTV_stateIF:
3423 ffestc_order_bad_ ();
3424 ffestc_shriek_if_ (FALSE);
3425 return FFESTC_orderBAD_;
3426
3427 default:
3428 ffestc_order_bad_ ();
3429 return FFESTC_orderBAD_;
3430 }
3431 }
3432
3433 /* ffestc_order_program_ -- Check ordering on <program> statement
3434
3435 if (ffestc_order_program_() != FFESTC_orderOK_)
3436 return; */
3437
3438 static ffestcOrder_
ffestc_order_program_()3439 ffestc_order_program_ ()
3440 {
3441 recurse:
3442
3443 switch (ffestw_state (ffestw_stack_top ()))
3444 {
3445 case FFESTV_stateNIL:
3446 ffestc_shriek_begin_program_ ();
3447 goto recurse; /* :::::::::::::::::::: */
3448
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_;
3456
3457 case FFESTV_stateUSE:
3458 #if FFESTR_F90
3459 ffestc_shriek_end_uses_ (TRUE);
3460 #endif
3461 goto recurse; /* :::::::::::::::::::: */
3462
3463 case FFESTV_stateWHERE:
3464 ffestc_order_bad_ ();
3465 #if FFESTR_F90
3466 ffestc_shriek_where_ (FALSE);
3467 #endif
3468 return FFESTC_orderBAD_;
3469
3470 case FFESTV_stateIF:
3471 ffestc_order_bad_ ();
3472 ffestc_shriek_if_ (FALSE);
3473 return FFESTC_orderBAD_;
3474
3475 default:
3476 ffestc_order_bad_ ();
3477 return FFESTC_orderBAD_;
3478 }
3479 }
3480
3481 /* ffestc_order_progspec_ -- Check ordering on <progspec> statement
3482
3483 if (ffestc_order_progspec_() != FFESTC_orderOK_)
3484 return; */
3485
3486 static ffestcOrder_
ffestc_order_progspec_()3487 ffestc_order_progspec_ ()
3488 {
3489 recurse:
3490
3491 switch (ffestw_state (ffestw_stack_top ()))
3492 {
3493 case FFESTV_stateNIL:
3494 ffestc_shriek_begin_program_ ();
3495 goto recurse; /* :::::::::::::::::::: */
3496
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_;
3503
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_;
3510
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_;
3517
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_;
3524
3525 case FFESTV_statePROGRAM3:
3526 case FFESTV_stateSUBROUTINE3:
3527 case FFESTV_stateFUNCTION3:
3528 case FFESTV_stateMODULE3:
3529 return FFESTC_orderOK_;
3530
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 ())
3537 {
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 ()));
3542 ffebad_finish ();
3543 }
3544 return FFESTC_orderOK_;
3545
3546 case FFESTV_stateUSE:
3547 #if FFESTR_F90
3548 ffestc_shriek_end_uses_ (TRUE);
3549 #endif
3550 goto recurse; /* :::::::::::::::::::: */
3551
3552 case FFESTV_stateWHERE:
3553 ffestc_order_bad_ ();
3554 #if FFESTR_F90
3555 ffestc_shriek_where_ (FALSE);
3556 #endif
3557 return FFESTC_orderBAD_;
3558
3559 case FFESTV_stateIF:
3560 ffestc_order_bad_ ();
3561 ffestc_shriek_if_ (FALSE);
3562 return FFESTC_orderBAD_;
3563
3564 default:
3565 ffestc_order_bad_ ();
3566 return FFESTC_orderBAD_;
3567 }
3568 }
3569
3570 /* ffestc_order_record_ -- Check ordering on RECORD statement
3571
3572 if (ffestc_order_record_() != FFESTC_orderOK_)
3573 return; */
3574
3575 #if FFESTR_VXT
3576 static ffestcOrder_
ffestc_order_record_()3577 ffestc_order_record_ ()
3578 {
3579 recurse:
3580
3581 switch (ffestw_state (ffestw_stack_top ()))
3582 {
3583 case FFESTV_stateNIL:
3584 ffestc_shriek_begin_program_ ();
3585 goto recurse; /* :::::::::::::::::::: */
3586
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_;
3593
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_;
3600
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_;
3607
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_;
3614
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_;
3621
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_;
3630
3631 case FFESTV_stateUSE:
3632 #if FFESTR_F90
3633 ffestc_shriek_end_uses_ (TRUE);
3634 #endif
3635 goto recurse; /* :::::::::::::::::::: */
3636
3637 case FFESTV_stateWHERE:
3638 ffestc_order_bad_ ();
3639 #if FFESTR_F90
3640 ffestc_shriek_where_ (FALSE);
3641 #endif
3642 return FFESTC_orderBAD_;
3643
3644 case FFESTV_stateIF:
3645 ffestc_order_bad_ ();
3646 ffestc_shriek_if_ (FALSE);
3647 return FFESTC_orderBAD_;
3648
3649 default:
3650 ffestc_order_bad_ ();
3651 return FFESTC_orderBAD_;
3652 }
3653 }
3654
3655 #endif
3656 /* ffestc_order_selectcase_ -- Check ordering on <selectcase> statement
3657
3658 if (ffestc_order_selectcase_() != FFESTC_orderOK_)
3659 return; */
3660
3661 static ffestcOrder_
ffestc_order_selectcase_()3662 ffestc_order_selectcase_ ()
3663 {
3664 switch (ffestw_state (ffestw_stack_top ()))
3665 {
3666 case FFESTV_stateSELECT0:
3667 case FFESTV_stateSELECT1:
3668 return FFESTC_orderOK_;
3669
3670 case FFESTV_stateWHERE:
3671 ffestc_order_bad_ ();
3672 #if FFESTR_F90
3673 ffestc_shriek_where_ (FALSE);
3674 #endif
3675 return FFESTC_orderBAD_;
3676
3677 case FFESTV_stateIF:
3678 ffestc_order_bad_ ();
3679 ffestc_shriek_if_ (FALSE);
3680 return FFESTC_orderBAD_;
3681
3682 default:
3683 ffestc_order_bad_ ();
3684 return FFESTC_orderBAD_;
3685 }
3686 }
3687
3688 /* ffestc_order_sfunc_ -- Check ordering on statement-function definition
3689
3690 if (ffestc_order_sfunc_() != FFESTC_orderOK_)
3691 return; */
3692
3693 static ffestcOrder_
ffestc_order_sfunc_()3694 ffestc_order_sfunc_ ()
3695 {
3696 recurse:
3697
3698 switch (ffestw_state (ffestw_stack_top ()))
3699 {
3700 case FFESTV_stateNIL:
3701 ffestc_shriek_begin_program_ ();
3702 goto recurse; /* :::::::::::::::::::: */
3703
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_;
3710
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_;
3717
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_;
3724
3725 case FFESTV_statePROGRAM3:
3726 case FFESTV_stateSUBROUTINE3:
3727 case FFESTV_stateFUNCTION3:
3728 return FFESTC_orderOK_;
3729
3730 case FFESTV_stateUSE:
3731 #if FFESTR_F90
3732 ffestc_shriek_end_uses_ (TRUE);
3733 #endif
3734 goto recurse; /* :::::::::::::::::::: */
3735
3736 case FFESTV_stateWHERE:
3737 ffestc_order_bad_ ();
3738 #if FFESTR_F90
3739 ffestc_shriek_where_ (FALSE);
3740 #endif
3741 return FFESTC_orderBAD_;
3742
3743 case FFESTV_stateIF:
3744 ffestc_order_bad_ ();
3745 ffestc_shriek_if_ (FALSE);
3746 return FFESTC_orderBAD_;
3747
3748 default:
3749 ffestc_order_bad_ ();
3750 return FFESTC_orderBAD_;
3751 }
3752 }
3753
3754 /* ffestc_order_spec_ -- Check ordering on <spec> statement
3755
3756 if (ffestc_order_spec_() != FFESTC_orderOK_)
3757 return; */
3758
3759 #if FFESTR_F90
3760 static ffestcOrder_
ffestc_order_spec_()3761 ffestc_order_spec_ ()
3762 {
3763 recurse:
3764
3765 switch (ffestw_state (ffestw_stack_top ()))
3766 {
3767 case FFESTV_stateNIL:
3768 ffestc_shriek_begin_program_ ();
3769 goto recurse; /* :::::::::::::::::::: */
3770
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_;
3777
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_;
3784
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_;
3791
3792 case FFESTV_stateSUBROUTINE3:
3793 case FFESTV_stateFUNCTION3:
3794 case FFESTV_stateMODULE3:
3795 return FFESTC_orderOK_;
3796
3797 case FFESTV_stateUSE:
3798 #if FFESTR_F90
3799 ffestc_shriek_end_uses_ (TRUE);
3800 #endif
3801 goto recurse; /* :::::::::::::::::::: */
3802
3803 case FFESTV_stateWHERE:
3804 ffestc_order_bad_ ();
3805 #if FFESTR_F90
3806 ffestc_shriek_where_ (FALSE);
3807 #endif
3808 return FFESTC_orderBAD_;
3809
3810 case FFESTV_stateIF:
3811 ffestc_order_bad_ ();
3812 ffestc_shriek_if_ (FALSE);
3813 return FFESTC_orderBAD_;
3814
3815 default:
3816 ffestc_order_bad_ ();
3817 return FFESTC_orderBAD_;
3818 }
3819 }
3820
3821 #endif
3822 /* ffestc_order_structure_ -- Check ordering on <structure> statement
3823
3824 if (ffestc_order_structure_() != FFESTC_orderOK_)
3825 return; */
3826
3827 #if FFESTR_VXT
3828 static ffestcOrder_
ffestc_order_structure_()3829 ffestc_order_structure_ ()
3830 {
3831 switch (ffestw_state (ffestw_stack_top ()))
3832 {
3833 case FFESTV_stateSTRUCTURE:
3834 return FFESTC_orderOK_;
3835
3836 case FFESTV_stateWHERE:
3837 ffestc_order_bad_ ();
3838 #if FFESTR_F90
3839 ffestc_shriek_where_ (FALSE);
3840 #endif
3841 return FFESTC_orderBAD_;
3842
3843 case FFESTV_stateIF:
3844 ffestc_order_bad_ ();
3845 ffestc_shriek_if_ (FALSE);
3846 return FFESTC_orderBAD_;
3847
3848 default:
3849 ffestc_order_bad_ ();
3850 return FFESTC_orderBAD_;
3851 }
3852 }
3853
3854 #endif
3855 /* ffestc_order_subroutine_ -- Check ordering on <subroutine> statement
3856
3857 if (ffestc_order_subroutine_() != FFESTC_orderOK_)
3858 return; */
3859
3860 static ffestcOrder_
ffestc_order_subroutine_()3861 ffestc_order_subroutine_ ()
3862 {
3863 recurse:
3864
3865 switch (ffestw_state (ffestw_stack_top ()))
3866 {
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_;
3874
3875 case FFESTV_stateUSE:
3876 #if FFESTR_F90
3877 ffestc_shriek_end_uses_ (TRUE);
3878 #endif
3879 goto recurse; /* :::::::::::::::::::: */
3880
3881 case FFESTV_stateWHERE:
3882 ffestc_order_bad_ ();
3883 #if FFESTR_F90
3884 ffestc_shriek_where_ (FALSE);
3885 #endif
3886 return FFESTC_orderBAD_;
3887
3888 case FFESTV_stateIF:
3889 ffestc_order_bad_ ();
3890 ffestc_shriek_if_ (FALSE);
3891 return FFESTC_orderBAD_;
3892
3893 default:
3894 ffestc_order_bad_ ();
3895 return FFESTC_orderBAD_;
3896 }
3897 }
3898
3899 /* ffestc_order_type_ -- Check ordering on <type> statement
3900
3901 if (ffestc_order_type_() != FFESTC_orderOK_)
3902 return; */
3903
3904 #if FFESTR_F90
3905 static ffestcOrder_
ffestc_order_type_()3906 ffestc_order_type_ ()
3907 {
3908 switch (ffestw_state (ffestw_stack_top ()))
3909 {
3910 case FFESTV_stateTYPE:
3911 return FFESTC_orderOK_;
3912
3913 case FFESTV_stateWHERE:
3914 ffestc_order_bad_ ();
3915 ffestc_shriek_where_ (FALSE);
3916 return FFESTC_orderBAD_;
3917
3918 case FFESTV_stateIF:
3919 ffestc_order_bad_ ();
3920 ffestc_shriek_if_ (FALSE);
3921 return FFESTC_orderBAD_;
3922
3923 default:
3924 ffestc_order_bad_ ();
3925 return FFESTC_orderBAD_;
3926 }
3927 }
3928
3929 #endif
3930 /* ffestc_order_typedecl_ -- Check ordering on <typedecl> statement
3931
3932 if (ffestc_order_typedecl_() != FFESTC_orderOK_)
3933 return; */
3934
3935 static ffestcOrder_
ffestc_order_typedecl_()3936 ffestc_order_typedecl_ ()
3937 {
3938 recurse:
3939
3940 switch (ffestw_state (ffestw_stack_top ()))
3941 {
3942 case FFESTV_stateNIL:
3943 ffestc_shriek_begin_program_ ();
3944 goto recurse; /* :::::::::::::::::::: */
3945
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_;
3952
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_;
3959
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_;
3966
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_;
3973
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_;
3980
3981 case FFESTV_statePROGRAM3:
3982 case FFESTV_stateSUBROUTINE3:
3983 case FFESTV_stateFUNCTION3:
3984 case FFESTV_stateMODULE3:
3985 case FFESTV_stateBLOCKDATA3:
3986 return FFESTC_orderOK_;
3987
3988 case FFESTV_stateUSE:
3989 #if FFESTR_F90
3990 ffestc_shriek_end_uses_ (TRUE);
3991 #endif
3992 goto recurse; /* :::::::::::::::::::: */
3993
3994 case FFESTV_stateWHERE:
3995 ffestc_order_bad_ ();
3996 #if FFESTR_F90
3997 ffestc_shriek_where_ (FALSE);
3998 #endif
3999 return FFESTC_orderBAD_;
4000
4001 case FFESTV_stateIF:
4002 ffestc_order_bad_ ();
4003 ffestc_shriek_if_ (FALSE);
4004 return FFESTC_orderBAD_;
4005
4006 default:
4007 ffestc_order_bad_ ();
4008 return FFESTC_orderBAD_;
4009 }
4010 }
4011
4012 /* ffestc_order_union_ -- Check ordering on <union> statement
4013
4014 if (ffestc_order_union_() != FFESTC_orderOK_)
4015 return; */
4016
4017 #if FFESTR_VXT
4018 static ffestcOrder_
ffestc_order_union_()4019 ffestc_order_union_ ()
4020 {
4021 switch (ffestw_state (ffestw_stack_top ()))
4022 {
4023 case FFESTV_stateUNION:
4024 return FFESTC_orderOK_;
4025
4026 case FFESTV_stateWHERE:
4027 ffestc_order_bad_ ();
4028 #if FFESTR_F90
4029 ffestc_shriek_where_ (FALSE);
4030 #endif
4031 return FFESTC_orderBAD_;
4032
4033 case FFESTV_stateIF:
4034 ffestc_order_bad_ ();
4035 ffestc_shriek_if_ (FALSE);
4036 return FFESTC_orderBAD_;
4037
4038 default:
4039 ffestc_order_bad_ ();
4040 return FFESTC_orderBAD_;
4041 }
4042 }
4043
4044 #endif
4045 /* ffestc_order_unit_ -- Check ordering on <unit> statement
4046
4047 if (ffestc_order_unit_() != FFESTC_orderOK_)
4048 return; */
4049
4050 static ffestcOrder_
ffestc_order_unit_()4051 ffestc_order_unit_ ()
4052 {
4053 switch (ffestw_state (ffestw_stack_top ()))
4054 {
4055 case FFESTV_stateNIL:
4056 return FFESTC_orderOK_;
4057
4058 case FFESTV_stateWHERE:
4059 ffestc_order_bad_ ();
4060 #if FFESTR_F90
4061 ffestc_shriek_where_ (FALSE);
4062 #endif
4063 return FFESTC_orderBAD_;
4064
4065 case FFESTV_stateIF:
4066 ffestc_order_bad_ ();
4067 ffestc_shriek_if_ (FALSE);
4068 return FFESTC_orderBAD_;
4069
4070 default:
4071 ffestc_order_bad_ ();
4072 return FFESTC_orderBAD_;
4073 }
4074 }
4075
4076 /* ffestc_order_use_ -- Check ordering on USE statement
4077
4078 if (ffestc_order_use_() != FFESTC_orderOK_)
4079 return; */
4080
4081 #if FFESTR_F90
4082 static ffestcOrder_
ffestc_order_use_()4083 ffestc_order_use_ ()
4084 {
4085 recurse:
4086
4087 switch (ffestw_state (ffestw_stack_top ()))
4088 {
4089 case FFESTV_stateNIL:
4090 ffestc_shriek_begin_program_ ();
4091 goto recurse; /* :::::::::::::::::::: */
4092
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; /* :::::::::::::::::::: */
4098
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; /* :::::::::::::::::::: */
4104
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; /* :::::::::::::::::::: */
4110
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; /* :::::::::::::::::::: */
4116
4117 case FFESTV_stateUSE:
4118 return FFESTC_orderOK_;
4119
4120 case FFESTV_stateWHERE:
4121 ffestc_order_bad_ ();
4122 ffestc_shriek_where_ (FALSE);
4123 return FFESTC_orderBAD_;
4124
4125 case FFESTV_stateIF:
4126 ffestc_order_bad_ ();
4127 ffestc_shriek_if_ (FALSE);
4128 return FFESTC_orderBAD_;
4129
4130 default:
4131 ffestc_order_bad_ ();
4132 return FFESTC_orderBAD_;
4133 }
4134 }
4135
4136 #endif
4137 /* ffestc_order_vxtstructure_ -- Check ordering on STRUCTURE statement
4138
4139 if (ffestc_order_vxtstructure_() != FFESTC_orderOK_)
4140 return; */
4141
4142 #if FFESTR_VXT
4143 static ffestcOrder_
ffestc_order_vxtstructure_()4144 ffestc_order_vxtstructure_ ()
4145 {
4146 recurse:
4147
4148 switch (ffestw_state (ffestw_stack_top ()))
4149 {
4150 case FFESTV_stateNIL:
4151 ffestc_shriek_begin_program_ ();
4152 goto recurse; /* :::::::::::::::::::: */
4153
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_;
4160
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_;
4167
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_;
4174
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_;
4181
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_;
4188
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_;
4197
4198 case FFESTV_stateUSE:
4199 #if FFESTR_F90
4200 ffestc_shriek_end_uses_ (TRUE);
4201 #endif
4202 goto recurse; /* :::::::::::::::::::: */
4203
4204 case FFESTV_stateWHERE:
4205 ffestc_order_bad_ ();
4206 #if FFESTR_F90
4207 ffestc_shriek_where_ (FALSE);
4208 #endif
4209 return FFESTC_orderBAD_;
4210
4211 case FFESTV_stateIF:
4212 ffestc_order_bad_ ();
4213 ffestc_shriek_if_ (FALSE);
4214 return FFESTC_orderBAD_;
4215
4216 default:
4217 ffestc_order_bad_ ();
4218 return FFESTC_orderBAD_;
4219 }
4220 }
4221
4222 #endif
4223 /* ffestc_order_where_ -- Check ordering on <where> statement
4224
4225 if (ffestc_order_where_() != FFESTC_orderOK_)
4226 return; */
4227
4228 #if FFESTR_F90
4229 static ffestcOrder_
ffestc_order_where_()4230 ffestc_order_where_ ()
4231 {
4232 switch (ffestw_state (ffestw_stack_top ()))
4233 {
4234 case FFESTV_stateWHERETHEN:
4235 return FFESTC_orderOK_;
4236
4237 case FFESTV_stateWHERE:
4238 ffestc_order_bad_ ();
4239 ffestc_shriek_where_ (FALSE);
4240 return FFESTC_orderBAD_;
4241
4242 case FFESTV_stateIF:
4243 ffestc_order_bad_ ();
4244 ffestc_shriek_if_ (FALSE);
4245 return FFESTC_orderBAD_;
4246
4247 default:
4248 ffestc_order_bad_ ();
4249 return FFESTC_orderBAD_;
4250 }
4251 }
4252
4253 #endif
4254 /* Invoked for each token in dummy arg list of FUNCTION, SUBROUTINE, and
4255 ENTRY (prior to the first executable statement). */
4256
4257 static void
ffestc_promote_dummy_(ffelexToken t)4258 ffestc_promote_dummy_ (ffelexToken t)
4259 {
4260 ffesymbol s;
4261 ffesymbolAttrs sa;
4262 ffesymbolAttrs na;
4263 ffebld e;
4264 bool sfref_ok;
4265
4266 assert (t != NULL);
4267
4268 if (ffelex_token_type (t) == FFELEX_typeASTERISK)
4269 {
4270 ffebld_append_item (&ffestc_local_.dummy.list_bottom,
4271 ffebld_new_star ());
4272 return; /* Don't bother with alternate returns! */
4273 }
4274
4275 s = ffesymbol_declare_local (t, FALSE);
4276 sa = ffesymbol_attrs (s);
4277
4278 /* Figure out what kind of object we've got based on previous declarations
4279 of or references to the object. */
4280
4281 sfref_ok = FALSE;
4282
4283 if (sa & FFESYMBOL_attrsANY)
4284 na = sa;
4285 else if (sa & FFESYMBOL_attrsDUMMY)
4286 {
4287 if (ffestc_entry_num_ == ffesymbol_maxentrynum (s))
4288 { /* Seen this one twice in this list! */
4289 na = FFESYMBOL_attrsetNONE;
4290 }
4291 else
4292 na = sa;
4293 sfref_ok = TRUE; /* Ok for sym to be ref'd in sfuncdef
4294 previously, since already declared as a
4295 dummy arg. */
4296 }
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;
4308 else
4309 na = FFESYMBOL_attrsetNONE;
4310
4311 if (!ffesymbol_is_specable (s)
4312 && (!sfref_ok
4313 || (ffesymbol_where (s) != FFEINFO_whereDUMMY)))
4314 na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
4315
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. */
4319
4320 if (na == FFESYMBOL_attrsetNONE)
4321 ffesymbol_error (s, t);
4322 else if (!(na & FFESYMBOL_attrsANY))
4323 {
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,
4330 FFEINTRIN_impNONE);
4331 ffebld_set_info (e,
4332 ffeinfo_new (FFEINFO_basictypeNONE,
4333 FFEINFO_kindtypeNONE,
4334 0,
4335 FFEINFO_kindNONE,
4336 FFEINFO_whereNONE,
4337 FFETARGET_charactersizeNONE));
4338 ffebld_append_item (&ffestc_local_.dummy.list_bottom, e);
4339 ffesymbol_signal_unreported (s);
4340 }
4341 }
4342
4343 /* ffestc_promote_execdummy_ -- Declare token as dummy variable in exec context
4344
4345 ffestc_promote_execdummy_(t);
4346
4347 Invoked for each token in dummy arg list of ENTRY when the statement
4348 follows the first executable statement. */
4349
4350 static void
ffestc_promote_execdummy_(ffelexToken t)4351 ffestc_promote_execdummy_ (ffelexToken t)
4352 {
4353 ffesymbol s;
4354 ffesymbolAttrs sa;
4355 ffesymbolAttrs na;
4356 ffesymbolState ss;
4357 ffesymbolState ns;
4358 ffeinfoKind kind;
4359 ffeinfoWhere where;
4360 ffebld e;
4361
4362 assert (t != NULL);
4363
4364 if (ffelex_token_type (t) == FFELEX_typeASTERISK)
4365 {
4366 ffebld_append_item (&ffestc_local_.dummy.list_bottom,
4367 ffebld_new_star ());
4368 return; /* Don't bother with alternate returns! */
4369 }
4370
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);
4376
4377 if (ffestc_entry_num_ == ffesymbol_maxentrynum (s))
4378 { /* Seen this one twice in this list! */
4379 na = FFESYMBOL_attrsetNONE;
4380 }
4381
4382 /* Figure out what kind of object we've got based on previous declarations
4383 of or references to the object. */
4384
4385 ns = FFESYMBOL_stateUNDERSTOOD; /* Assume we know it all know. */
4386
4387 switch (kind)
4388 {
4389 case FFEINFO_kindENTITY:
4390 case FFEINFO_kindFUNCTION:
4391 case FFEINFO_kindSUBROUTINE:
4392 break; /* These are fine, as far as we know. */
4393
4394 case FFEINFO_kindNONE:
4395 if (sa & FFESYMBOL_attrsDUMMY)
4396 ns = FFESYMBOL_stateUNCERTAIN; /* Learned nothing new. */
4397 else if (sa & FFESYMBOL_attrsANYLEN)
4398 {
4399 kind = FFEINFO_kindENTITY;
4400 where = FFEINFO_whereDUMMY;
4401 }
4402 else if (sa & FFESYMBOL_attrsACTUALARG)
4403 na = FFESYMBOL_attrsetNONE;
4404 else
4405 {
4406 na = sa | FFESYMBOL_attrsDUMMY;
4407 ns = FFESYMBOL_stateUNCERTAIN;
4408 }
4409 break;
4410
4411 default:
4412 na = FFESYMBOL_attrsetNONE; /* Error. */
4413 break;
4414 }
4415
4416 switch (where)
4417 {
4418 case FFEINFO_whereDUMMY:
4419 break; /* This is fine. */
4420
4421 case FFEINFO_whereNONE:
4422 where = FFEINFO_whereDUMMY;
4423 break;
4424
4425 default:
4426 na = FFESYMBOL_attrsetNONE; /* Error. */
4427 break;
4428 }
4429
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. */
4433
4434 if (na == FFESYMBOL_attrsetNONE)
4435 ffesymbol_error (s, t);
4436 else if (!(na & FFESYMBOL_attrsANY))
4437 {
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))
4445 {
4446 ffesymbol_error (s, t);
4447 return;
4448 }
4449 ffesymbol_set_info (s,
4450 ffeinfo_new (ffesymbol_basictype (s),
4451 ffesymbol_kindtype (s),
4452 ffesymbol_rank (s),
4453 kind,
4454 where,
4455 ffesymbol_size (s)));
4456 e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
4457 FFEINTRIN_impNONE);
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);
4462 }
4463 }
4464
4465 /* ffestc_promote_sfdummy_ -- Declare token as stmt-func dummy variable
4466
4467 ffestc_promote_sfdummy_(t);
4468
4469 Invoked for each token in dummy arg list of statement function.
4470
4471 22-Oct-91 JCB 1.1
4472 Reject arg if CHARACTER*(*). */
4473
4474 static void
ffestc_promote_sfdummy_(ffelexToken t)4475 ffestc_promote_sfdummy_ (ffelexToken t)
4476 {
4477 ffesymbol s;
4478 ffesymbol sp; /* Parent symbol. */
4479 ffesymbolAttrs sa;
4480 ffesymbolAttrs na;
4481 ffebld e;
4482
4483 assert (t != NULL);
4484
4485 s = ffesymbol_declare_sfdummy (t); /* Sets maxentrynum to 0 for new obj;
4486 also sets sfa_dummy_parent to
4487 parent symbol. */
4488 if (ffesymbol_state (s) != FFESYMBOL_stateNONE)
4489 {
4490 ffesymbol_error (s, t); /* Dummy already in list. */
4491 return;
4492 }
4493
4494 sp = ffesymbol_sfdummyparent (s); /* Now flag dummy's parent as used
4495 for dummy. */
4496 sa = ffesymbol_attrs (sp);
4497
4498 /* Figure out what kind of object we've got based on previous declarations
4499 of or references to the object. */
4500
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)
4509 na = sa;
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;
4521 else
4522 na = FFESYMBOL_attrsetNONE;
4523
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. */
4527
4528 if (na == FFESYMBOL_attrsetNONE)
4529 {
4530 ffesymbol_error (sp, t);
4531 ffesymbol_set_info (s, ffeinfo_new_any ());
4532 }
4533 else if (!(na & FFESYMBOL_attrsANY))
4534 {
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);
4541 else
4542 ffesymbol_set_info (s,
4543 ffeinfo_new (ffesymbol_basictype (sp),
4544 ffesymbol_kindtype (sp),
4545 0,
4546 FFEINFO_kindENTITY,
4547 FFEINFO_whereDUMMY,
4548 ffesymbol_size (sp)));
4549
4550 ffesymbol_signal_unreported (sp);
4551 }
4552
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,
4557 FFEINTRIN_impNONE);
4558 ffebld_set_info (e, ffeinfo_use (ffesymbol_info (s)));
4559 ffebld_append_item (&ffestc_local_.dummy.list_bottom, e);
4560 }
4561
4562 /* ffestc_shriek_begin_program_ -- Implicit PROGRAM statement
4563
4564 ffestc_shriek_begin_program_();
4565
4566 Invoked only when a PROGRAM statement is NOT present at the beginning
4567 of a main program unit. */
4568
4569 static void
ffestc_shriek_begin_program_()4570 ffestc_shriek_begin_program_ ()
4571 {
4572 ffestw b;
4573 ffesymbol s;
4574
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);
4582
4583 s = ffesymbol_declare_programunit (NULL,
4584 ffelex_token_where_line (ffesta_tokens[0]),
4585 ffelex_token_where_column (ffesta_tokens[0]));
4586
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). */
4593
4594 ffesymbol_set_info (s,
4595 ffeinfo_new (FFEINFO_basictypeNONE,
4596 FFEINFO_kindtypeNONE,
4597 0,
4598 FFEINFO_kindPROGRAM,
4599 FFEINFO_whereLOCAL,
4600 FFETARGET_charactersizeNONE));
4601 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
4602
4603 ffesymbol_signal_unreported (s);
4604
4605 ffestd_R1102 (s, NULL);
4606 }
4607
4608 /* ffestc_shriek_begin_uses_ -- Start a bunch of USE statements
4609
4610 ffestc_shriek_begin_uses_();
4611
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). */
4617
4618 #if FFESTR_F90
4619 static void
ffestc_shriek_begin_uses_()4620 ffestc_shriek_begin_uses_ ()
4621 {
4622 ffestw b;
4623
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_);
4629
4630 ffestd_begin_uses ();
4631 }
4632
4633 #endif
4634 /* ffestc_shriek_blockdata_ -- End a BLOCK DATA
4635
4636 ffestc_shriek_blockdata_(TRUE); */
4637
4638 static void
ffestc_shriek_blockdata_(bool ok)4639 ffestc_shriek_blockdata_ (bool ok)
4640 {
4641 if (!ffesta_seen_first_exec)
4642 {
4643 ffesta_seen_first_exec = TRUE;
4644 ffestd_exec_begin ();
4645 }
4646
4647 ffestd_R1112 (ok);
4648
4649 ffestd_exec_end ();
4650
4651 if (ffestw_name (ffestw_stack_top ()) != NULL)
4652 ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
4653 ffestw_kill (ffestw_pop ());
4654
4655 ffe_terminate_2 ();
4656 ffe_init_2 ();
4657 }
4658
4659 /* ffestc_shriek_do_ -- End of statement following DO-term-stmt etc
4660
4661 ffestc_shriek_do_(TRUE);
4662
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. */
4668
4669 static void
ffestc_shriek_do_(bool ok)4670 ffestc_shriek_do_ (bool ok)
4671 {
4672 ffelab l;
4673
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
4677 undefined. */
4678 assert ((ffelab_type (l) == FFELAB_typeLOOPEND)
4679 || (ffelab_type (l) == FFELAB_typeANY));
4680 if (ffelab_type (l) != FFELAB_typeANY)
4681 {
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_++;
4687 }
4688 ffestd_labeldef_branch (l);
4689 }
4690
4691 ffestd_do (ok);
4692
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 ());
4700 }
4701
4702 /* ffestc_shriek_end_program_ -- End a PROGRAM
4703
4704 ffestc_shriek_end_program_(); */
4705
4706 static void
ffestc_shriek_end_program_(bool ok)4707 ffestc_shriek_end_program_ (bool ok)
4708 {
4709 if (!ffesta_seen_first_exec)
4710 {
4711 ffesta_seen_first_exec = TRUE;
4712 ffestd_exec_begin ();
4713 }
4714
4715 ffestd_R1103 (ok);
4716
4717 ffestd_exec_end ();
4718
4719 if (ffestw_name (ffestw_stack_top ()) != NULL)
4720 ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
4721 ffestw_kill (ffestw_pop ());
4722
4723 ffe_terminate_2 ();
4724 ffe_init_2 ();
4725 }
4726
4727 /* ffestc_shriek_end_uses_ -- End a bunch of USE statements
4728
4729 ffestc_shriek_end_uses_(TRUE);
4730
4731 ok==TRUE means simply not popping due to ffestc_eof()
4732 being called, because there is no formal END USES statement in Fortran. */
4733
4734 #if FFESTR_F90
4735 static void
ffestc_shriek_end_uses_(bool ok)4736 ffestc_shriek_end_uses_ (bool ok)
4737 {
4738 ffestd_end_uses (ok);
4739
4740 ffestw_kill (ffestw_pop ());
4741 }
4742
4743 #endif
4744 /* ffestc_shriek_function_ -- End a FUNCTION
4745
4746 ffestc_shriek_function_(TRUE); */
4747
4748 static void
ffestc_shriek_function_(bool ok)4749 ffestc_shriek_function_ (bool ok)
4750 {
4751 if (!ffesta_seen_first_exec)
4752 {
4753 ffesta_seen_first_exec = TRUE;
4754 ffestd_exec_begin ();
4755 }
4756
4757 ffestd_R1221 (ok);
4758
4759 ffestd_exec_end ();
4760
4761 ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
4762 ffestw_kill (ffestw_pop ());
4763 ffesta_is_entry_valid = FALSE;
4764
4765 switch (ffestw_state (ffestw_stack_top ()))
4766 {
4767 case FFESTV_stateNIL:
4768 ffe_terminate_2 ();
4769 ffe_init_2 ();
4770 break;
4771
4772 default:
4773 ffe_terminate_3 ();
4774 ffe_init_3 ();
4775 break;
4776
4777 case FFESTV_stateINTERFACE0:
4778 ffe_terminate_4 ();
4779 ffe_init_4 ();
4780 break;
4781 }
4782 }
4783
4784 /* ffestc_shriek_if_ -- End of statement following logical IF
4785
4786 ffestc_shriek_if_(TRUE);
4787
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(). */
4793
4794 static void
ffestc_shriek_if_(bool ok)4795 ffestc_shriek_if_ (bool ok)
4796 {
4797 ffestd_end_R807 (ok);
4798
4799 ffestw_kill (ffestw_pop ());
4800 ffestc_shriek_after1_ = NULL;
4801
4802 ffestc_try_shriek_do_ ();
4803 }
4804
4805 /* ffestc_shriek_ifthen_ -- End an IF-THEN
4806
4807 ffestc_shriek_ifthen_(TRUE); */
4808
4809 static void
ffestc_shriek_ifthen_(bool ok)4810 ffestc_shriek_ifthen_ (bool ok)
4811 {
4812 ffestd_R806 (ok);
4813
4814 if (ffestw_name (ffestw_stack_top ()) != NULL)
4815 ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
4816 ffestw_kill (ffestw_pop ());
4817
4818 ffestc_try_shriek_do_ ();
4819 }
4820
4821 /* ffestc_shriek_interface_ -- End an INTERFACE
4822
4823 ffestc_shriek_interface_(TRUE); */
4824
4825 #if FFESTR_F90
4826 static void
ffestc_shriek_interface_(bool ok)4827 ffestc_shriek_interface_ (bool ok)
4828 {
4829 ffestd_R1203 (ok);
4830
4831 ffestw_kill (ffestw_pop ());
4832
4833 ffestc_try_shriek_do_ ();
4834 }
4835
4836 #endif
4837 /* ffestc_shriek_map_ -- End a MAP
4838
4839 ffestc_shriek_map_(TRUE); */
4840
4841 #if FFESTR_VXT
4842 static void
ffestc_shriek_map_(bool ok)4843 ffestc_shriek_map_ (bool ok)
4844 {
4845 ffestd_V013 (ok);
4846
4847 ffestw_kill (ffestw_pop ());
4848
4849 ffestc_try_shriek_do_ ();
4850 }
4851
4852 #endif
4853 /* ffestc_shriek_module_ -- End a MODULE
4854
4855 ffestc_shriek_module_(TRUE); */
4856
4857 #if FFESTR_F90
4858 static void
ffestc_shriek_module_(bool ok)4859 ffestc_shriek_module_ (bool ok)
4860 {
4861 if (!ffesta_seen_first_exec)
4862 {
4863 ffesta_seen_first_exec = TRUE;
4864 ffestd_exec_begin ();
4865 }
4866
4867 ffestd_R1106 (ok);
4868
4869 ffestd_exec_end ();
4870
4871 ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
4872 ffestw_kill (ffestw_pop ());
4873
4874 ffe_terminate_2 ();
4875 ffe_init_2 ();
4876 }
4877
4878 #endif
4879 /* ffestc_shriek_select_ -- End a SELECT
4880
4881 ffestc_shriek_select_(TRUE); */
4882
4883 static void
ffestc_shriek_select_(bool ok)4884 ffestc_shriek_select_ (bool ok)
4885 {
4886 ffestwSelect s;
4887 ffestwCase c;
4888
4889 ffestd_R811 (ok);
4890
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);
4898
4899 ffestw_kill (ffestw_pop ());
4900
4901 ffestc_try_shriek_do_ ();
4902 }
4903
4904 /* ffestc_shriek_structure_ -- End a STRUCTURE
4905
4906 ffestc_shriek_structure_(TRUE); */
4907
4908 #if FFESTR_VXT
4909 static void
ffestc_shriek_structure_(bool ok)4910 ffestc_shriek_structure_ (bool ok)
4911 {
4912 ffestd_V004 (ok);
4913
4914 ffestw_kill (ffestw_pop ());
4915
4916 ffestc_try_shriek_do_ ();
4917 }
4918
4919 #endif
4920 /* ffestc_shriek_subroutine_ -- End a SUBROUTINE
4921
4922 ffestc_shriek_subroutine_(TRUE); */
4923
4924 static void
ffestc_shriek_subroutine_(bool ok)4925 ffestc_shriek_subroutine_ (bool ok)
4926 {
4927 if (!ffesta_seen_first_exec)
4928 {
4929 ffesta_seen_first_exec = TRUE;
4930 ffestd_exec_begin ();
4931 }
4932
4933 ffestd_R1225 (ok);
4934
4935 ffestd_exec_end ();
4936
4937 ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
4938 ffestw_kill (ffestw_pop ());
4939 ffesta_is_entry_valid = FALSE;
4940
4941 switch (ffestw_state (ffestw_stack_top ()))
4942 {
4943 case FFESTV_stateNIL:
4944 ffe_terminate_2 ();
4945 ffe_init_2 ();
4946 break;
4947
4948 default:
4949 ffe_terminate_3 ();
4950 ffe_init_3 ();
4951 break;
4952
4953 case FFESTV_stateINTERFACE0:
4954 ffe_terminate_4 ();
4955 ffe_init_4 ();
4956 break;
4957 }
4958 }
4959
4960 /* ffestc_shriek_type_ -- End a TYPE
4961
4962 ffestc_shriek_type_(TRUE); */
4963
4964 #if FFESTR_F90
4965 static void
ffestc_shriek_type_(bool ok)4966 ffestc_shriek_type_ (bool ok)
4967 {
4968 ffestd_R425 (ok);
4969
4970 ffe_terminate_4 ();
4971
4972 ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
4973 ffestw_kill (ffestw_pop ());
4974
4975 ffestc_try_shriek_do_ ();
4976 }
4977
4978 #endif
4979 /* ffestc_shriek_union_ -- End a UNION
4980
4981 ffestc_shriek_union_(TRUE); */
4982
4983 #if FFESTR_VXT
4984 static void
ffestc_shriek_union_(bool ok)4985 ffestc_shriek_union_ (bool ok)
4986 {
4987 ffestd_V010 (ok);
4988
4989 ffestw_kill (ffestw_pop ());
4990
4991 ffestc_try_shriek_do_ ();
4992 }
4993
4994 #endif
4995 /* ffestc_shriek_where_ -- Implicit END WHERE statement
4996
4997 ffestc_shriek_where_(TRUE);
4998
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(). */
5002
5003 #if FFESTR_F90
5004 static void
ffestc_shriek_where_(bool ok)5005 ffestc_shriek_where_ (bool ok)
5006 {
5007 ffestd_R745 (ok);
5008
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
5013 case. */
5014
5015 ffestc_try_shriek_do_ ();
5016 }
5017
5018 #endif
5019 /* ffestc_shriek_wherethen_ -- End a WHERE(-THEN)
5020
5021 ffestc_shriek_wherethen_(TRUE); */
5022
5023 #if FFESTR_F90
5024 static void
ffestc_shriek_wherethen_(bool ok)5025 ffestc_shriek_wherethen_ (bool ok)
5026 {
5027 ffestd_end_R740 (ok);
5028
5029 ffestw_kill (ffestw_pop ());
5030
5031 ffestc_try_shriek_do_ ();
5032 }
5033
5034 #endif
5035 /* ffestc_subr_binsrch_ -- Binary search of char const in list of strings
5036
5037 i = ffestc_subr_binsrch_(search_list,search_list_size,&spec,"etc");
5038
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. */
5045
5046 static int
ffestc_subr_binsrch_(const char * const * list,int size,ffestpFile * spec,const char * whine)5047 ffestc_subr_binsrch_ (const char *const *list, int size, ffestpFile *spec,
5048 const char *whine)
5049 {
5050 int lowest_tested;
5051 int highest_tested;
5052 int halfway;
5053 int offset;
5054 int c;
5055 const char *str;
5056 int len;
5057
5058 if (size == 0)
5059 return 0; /* Nobody should pass size == 0, but for
5060 elegance.... */
5061
5062 lowest_tested = -1;
5063 highest_tested = size;
5064 halfway = size >> 1;
5065
5066 list += halfway;
5067
5068 c = ffestc_subr_speccmp_ (*list, spec, &str, &len);
5069 if (c == 2)
5070 return 0;
5071 c = -c; /* Sigh. */
5072
5073 next: /* :::::::::::::::::::: */
5074 switch (c)
5075 {
5076 case -1:
5077 offset = (halfway - lowest_tested) >> 1;
5078 if (offset == 0)
5079 goto nope; /* :::::::::::::::::::: */
5080 highest_tested = halfway;
5081 list -= offset;
5082 halfway -= offset;
5083 c = ffesrc_strcmp_1ns2i (ffe_case_match (), str, len, *list);
5084 goto next; /* :::::::::::::::::::: */
5085
5086 case 0:
5087 return halfway + 1;
5088
5089 case 1:
5090 offset = (highest_tested - halfway) >> 1;
5091 if (offset == 0)
5092 goto nope; /* :::::::::::::::::::: */
5093 lowest_tested = halfway;
5094 list += offset;
5095 halfway += offset;
5096 c = ffesrc_strcmp_1ns2i (ffe_case_match (), str, len, *list);
5097 goto next; /* :::::::::::::::::::: */
5098
5099 default:
5100 assert ("unexpected return from ffesrc_strcmp_1ns2i" == NULL);
5101 break;
5102 }
5103
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);
5109 ffebad_finish ();
5110 return 0;
5111 }
5112
5113 /* ffestc_subr_format_ -- Return summary of format specifier
5114
5115 ffestc_subr_format_(&specifier); */
5116
5117 static ffestvFormat
ffestc_subr_format_(ffestpFile * spec)5118 ffestc_subr_format_ (ffestpFile *spec)
5119 {
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. */
5125
5126 assert (spec->value != NULL);
5127 if (ffebld_op (spec->u.expr) == FFEBLD_opSTAR)
5128 return FFESTV_formatASTERISK;
5129
5130 if (ffeinfo_kind (ffebld_info (spec->u.expr)) == FFEINFO_kindNAMELIST)
5131 return FFESTV_formatNAMELIST;
5132
5133 if (ffeinfo_rank (ffebld_info (spec->u.expr)) != 0)
5134 return FFESTV_formatCHAREXPR; /* F77 C5. */
5135
5136 switch (ffeinfo_basictype (ffebld_info (spec->u.expr)))
5137 {
5138 case FFEINFO_basictypeINTEGER:
5139 return FFESTV_formatINTEXPR;
5140
5141 case FFEINFO_basictypeCHARACTER:
5142 return FFESTV_formatCHAREXPR;
5143
5144 case FFEINFO_basictypeANY:
5145 return FFESTV_formatASTERISK;
5146
5147 default:
5148 assert ("bad basictype" == NULL);
5149 return FFESTV_formatINTEXPR;
5150 }
5151 }
5152
5153 /* ffestc_subr_is_branch_ -- Handle specifier as branch target label
5154
5155 ffestc_subr_is_branch_(&specifier); */
5156
5157 static bool
ffestc_subr_is_branch_(ffestpFile * spec)5158 ffestc_subr_is_branch_ (ffestpFile *spec)
5159 {
5160 if (!spec->kw_or_val_present)
5161 return TRUE;
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);
5166 }
5167
5168 /* ffestc_subr_is_format_ -- Handle specifier as format target label
5169
5170 ffestc_subr_is_format_(&specifier); */
5171
5172 static bool
ffestc_subr_is_format_(ffestpFile * spec)5173 ffestc_subr_is_format_ (ffestpFile *spec)
5174 {
5175 if (!spec->kw_or_val_present)
5176 return TRUE;
5177 assert (spec->value_present);
5178 if (!spec->value_is_label)
5179 return TRUE; /* Ok if not a label. */
5180
5181 spec->value_is_label++; /* For checking purposes only; 1=>2. */
5182 return ffestc_labelref_is_format_ (spec->value, &spec->u.label);
5183 }
5184
5185 /* ffestc_subr_is_present_ -- Ensure specifier is present, else error
5186
5187 ffestc_subr_is_present_("SPECIFIER",&specifier); */
5188
5189 static bool
ffestc_subr_is_present_(const char * name,ffestpFile * spec)5190 ffestc_subr_is_present_ (const char *name, ffestpFile *spec)
5191 {
5192 if (spec->kw_or_val_present)
5193 {
5194 assert (spec->value_present);
5195 return TRUE;
5196 }
5197
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);
5202 ffebad_finish ();
5203 return FALSE;
5204 }
5205
5206 /* ffestc_subr_speccmp_ -- Compare string to constant expression, if present
5207
5208 if (ffestc_subr_speccmp_("Constant",&specifier,NULL,NULL) == 0)
5209 // specifier value is present and is a char constant "CONSTANT"
5210
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.
5216
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. */
5221
5222 static int
ffestc_subr_speccmp_(const char * string,ffestpFile * spec,const char ** target,int * length)5223 ffestc_subr_speccmp_ (const char *string, ffestpFile *spec, const char **target,
5224 int *length)
5225 {
5226 ffebldConstant c;
5227 int i;
5228
5229 if (!spec->kw_or_val_present || !spec->value_present
5230 || (spec->u.expr == NULL)
5231 || (ffebld_op (spec->u.expr) != FFEBLD_opCONTER))
5232 {
5233 if (target != NULL)
5234 *target = NULL;
5235 if (length != NULL)
5236 *length = 0;
5237 return 2;
5238 }
5239
5240 if (ffebld_constant_type (c = ffebld_conter (spec->u.expr))
5241 != FFEBLD_constCHARACTERDEFAULT)
5242 {
5243 if (target != NULL)
5244 *target = NULL;
5245 if (length != NULL)
5246 *length = 0;
5247 return 2;
5248 }
5249
5250 if (target != NULL)
5251 *target = ffebld_constant_characterdefault (c).text;
5252 if (length != NULL)
5253 *length = ffebld_constant_characterdefault (c).length;
5254
5255 i = ffesrc_strcmp_1ns2i (ffe_case_match (),
5256 ffebld_constant_characterdefault (c).text,
5257 ffebld_constant_characterdefault (c).length,
5258 string);
5259 if (i == 0)
5260 return 0;
5261 if (i > 0)
5262 return -1; /* Yes indeed, we reverse the strings to
5263 _strcmpin_. */
5264 return 1;
5265 }
5266
5267 /* ffestc_subr_unit_ -- Return summary of unit specifier
5268
5269 ffestc_subr_unit_(&specifier); */
5270
5271 static ffestvUnit
ffestc_subr_unit_(ffestpFile * spec)5272 ffestc_subr_unit_ (ffestpFile *spec)
5273 {
5274 if (!spec->kw_or_val_present)
5275 return FFESTV_unitNONE;
5276 assert (spec->value_present);
5277 assert (spec->value != NULL);
5278
5279 if (ffebld_op (spec->u.expr) == FFEBLD_opSTAR)
5280 return FFESTV_unitASTERISK;
5281
5282 switch (ffeinfo_basictype (ffebld_info (spec->u.expr)))
5283 {
5284 case FFEINFO_basictypeINTEGER:
5285 return FFESTV_unitINTEXPR;
5286
5287 case FFEINFO_basictypeCHARACTER:
5288 return FFESTV_unitCHAREXPR;
5289
5290 case FFEINFO_basictypeANY:
5291 return FFESTV_unitASTERISK;
5292
5293 default:
5294 assert ("bad basictype" == NULL);
5295 return FFESTV_unitINTEXPR;
5296 }
5297 }
5298
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". */
5304
5305 static void
ffestc_try_shriek_do_()5306 ffestc_try_shriek_do_ ()
5307 {
5308 ffelab lab;
5309 ffelabType ty;
5310
5311 while ((ffestw_state (ffestw_stack_top ()) == FFESTV_stateDO)
5312 && ((lab = (ffestw_label (ffestw_stack_top ()))) != NULL)
5313 && (((ty = (ffelab_type (lab)))
5314 == FFELAB_typeANY)
5315 || (ty == FFELAB_typeUSELESS)
5316 || (ty == FFELAB_typeFORMAT)
5317 || (ty == FFELAB_typeNOTLOOP)
5318 || (ty == FFELAB_typeENDIF)))
5319 ffestc_shriek_do_ (FALSE);
5320 }
5321
5322 /* ffestc_decl_start -- R426 or R501
5323
5324 ffestc_decl_start(...);
5325
5326 Verify that R426 component-def-stmt or R501 type-declaration-stmt are
5327 valid here, figure out which one, and implement. */
5328
5329 void
ffestc_decl_start(ffestpType type,ffelexToken typet,ffebld kind,ffelexToken kindt,ffebld len,ffelexToken lent)5330 ffestc_decl_start (ffestpType type, ffelexToken typet, ffebld kind,
5331 ffelexToken kindt, ffebld len, ffelexToken lent)
5332 {
5333 switch (ffestw_state (ffestw_stack_top ()))
5334 {
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;
5358 break;
5359
5360 case FFESTV_stateTYPE:
5361 case FFESTV_stateSTRUCTURE:
5362 case FFESTV_stateMAP:
5363 ffestc_local_.decl.is_R426 = 1;
5364 break;
5365
5366 default:
5367 ffestc_order_bad_ ();
5368 ffestc_labeldef_useless_ ();
5369 ffestc_local_.decl.is_R426 = 0;
5370 return;
5371 }
5372
5373 switch (ffestc_local_.decl.is_R426)
5374 {
5375 #if FFESTR_F90
5376 case 1:
5377 ffestc_R426_start (type, typet, kind, kindt, len, lent);
5378 break;
5379 #endif
5380
5381 case 2:
5382 ffestc_R501_start (type, typet, kind, kindt, len, lent);
5383 break;
5384
5385 default:
5386 ffestc_labeldef_useless_ ();
5387 break;
5388 }
5389 }
5390
5391 /* ffestc_decl_attrib -- R426 or R501 type attribute
5392
5393 ffestc_decl_attrib(...);
5394
5395 Verify that R426 component-def-stmt or R501 type-declaration-stmt attribute
5396 is valid here and implement. */
5397
5398 void
ffestc_decl_attrib(ffestpAttrib attrib UNUSED,ffelexToken attribt UNUSED,ffestrOther intent_kw UNUSED,ffesttDimList dims UNUSED)5399 ffestc_decl_attrib (ffestpAttrib attrib UNUSED,
5400 ffelexToken attribt UNUSED,
5401 ffestrOther intent_kw UNUSED,
5402 ffesttDimList dims UNUSED)
5403 {
5404 #if FFESTR_F90
5405 switch (ffestc_local_.decl.is_R426)
5406 {
5407 case 1:
5408 ffestc_R426_attrib (attrib, attribt, intent_kw, dims);
5409 break;
5410
5411 case 2:
5412 ffestc_R501_attrib (attrib, attribt, intent_kw, dims);
5413 break;
5414
5415 default:
5416 break;
5417 }
5418 #else
5419 ffebad_start (FFEBAD_F90);
5420 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
5421 ffelex_token_where_column (ffesta_tokens[0]));
5422 ffebad_finish ();
5423 return;
5424 #endif
5425 }
5426
5427 /* ffestc_decl_item -- R426 or R501
5428
5429 ffestc_decl_item(...);
5430
5431 Establish type for a particular object. */
5432
5433 void
ffestc_decl_item(ffelexToken name,ffebld kind,ffelexToken kindt,ffesttDimList dims,ffebld len,ffelexToken lent,ffebld init,ffelexToken initt,bool clist)5434 ffestc_decl_item (ffelexToken name, ffebld kind, ffelexToken kindt,
5435 ffesttDimList dims, ffebld len, ffelexToken lent, ffebld init,
5436 ffelexToken initt, bool clist)
5437 {
5438 switch (ffestc_local_.decl.is_R426)
5439 {
5440 #if FFESTR_F90
5441 case 1:
5442 ffestc_R426_item (name, kind, kindt, dims, len, lent, init, initt,
5443 clist);
5444 break;
5445 #endif
5446
5447 case 2:
5448 ffestc_R501_item (name, kind, kindt, dims, len, lent, init, initt,
5449 clist);
5450 break;
5451
5452 default:
5453 break;
5454 }
5455 }
5456
5457 /* ffestc_decl_itemstartvals -- R426 or R501 start list of values
5458
5459 ffestc_decl_itemstartvals();
5460
5461 Gonna specify values for the object now. */
5462
5463 void
ffestc_decl_itemstartvals()5464 ffestc_decl_itemstartvals ()
5465 {
5466 switch (ffestc_local_.decl.is_R426)
5467 {
5468 #if FFESTR_F90
5469 case 1:
5470 ffestc_R426_itemstartvals ();
5471 break;
5472 #endif
5473
5474 case 2:
5475 ffestc_R501_itemstartvals ();
5476 break;
5477
5478 default:
5479 break;
5480 }
5481 }
5482
5483 /* ffestc_decl_itemvalue -- R426 or R501 source value
5484
5485 ffestc_decl_itemvalue(repeat,repeat_token,value,value_token);
5486
5487 Make sure repeat and value are valid for the object being initialized. */
5488
5489 void
ffestc_decl_itemvalue(ffebld repeat,ffelexToken repeat_token,ffebld value,ffelexToken value_token)5490 ffestc_decl_itemvalue (ffebld repeat, ffelexToken repeat_token,
5491 ffebld value, ffelexToken value_token)
5492 {
5493 switch (ffestc_local_.decl.is_R426)
5494 {
5495 #if FFESTR_F90
5496 case 1:
5497 ffestc_R426_itemvalue (repeat, repeat_token, value, value_token);
5498 break;
5499 #endif
5500
5501 case 2:
5502 ffestc_R501_itemvalue (repeat, repeat_token, value, value_token);
5503 break;
5504
5505 default:
5506 break;
5507 }
5508 }
5509
5510 /* ffestc_decl_itemendvals -- R426 or R501 end list of values
5511
5512 ffelexToken t; // the SLASH token that ends the list.
5513 ffestc_decl_itemendvals(t);
5514
5515 No more values, might specify more objects now. */
5516
5517 void
ffestc_decl_itemendvals(ffelexToken t)5518 ffestc_decl_itemendvals (ffelexToken t)
5519 {
5520 switch (ffestc_local_.decl.is_R426)
5521 {
5522 #if FFESTR_F90
5523 case 1:
5524 ffestc_R426_itemendvals (t);
5525 break;
5526 #endif
5527
5528 case 2:
5529 ffestc_R501_itemendvals (t);
5530 break;
5531
5532 default:
5533 break;
5534 }
5535 }
5536
5537 /* ffestc_decl_finish -- R426 or R501
5538
5539 ffestc_decl_finish();
5540
5541 Just wrap up any local activities. */
5542
5543 void
ffestc_decl_finish()5544 ffestc_decl_finish ()
5545 {
5546 switch (ffestc_local_.decl.is_R426)
5547 {
5548 #if FFESTR_F90
5549 case 1:
5550 ffestc_R426_finish ();
5551 break;
5552 #endif
5553
5554 case 2:
5555 ffestc_R501_finish ();
5556 break;
5557
5558 default:
5559 break;
5560 }
5561 }
5562
5563 /* ffestc_elsewhere -- Generic ELSE WHERE statement
5564
5565 ffestc_end();
5566
5567 Decide whether ELSEWHERE or ELSE w/if-construct-name=="WHERE" is meant. */
5568
5569 void
ffestc_elsewhere(ffelexToken where)5570 ffestc_elsewhere (ffelexToken where)
5571 {
5572 switch (ffestw_state (ffestw_stack_top ()))
5573 {
5574 case FFESTV_stateIFTHEN:
5575 ffestc_R805 (where);
5576 break;
5577
5578 default:
5579 #if FFESTR_F90
5580 ffestc_R744 ();
5581 #endif
5582 break;
5583 }
5584 }
5585
5586 /* ffestc_end -- Generic END statement
5587
5588 ffestc_end();
5589
5590 Make sure a generic END is valid in the current context, and implement
5591 it. */
5592
5593 void
ffestc_end()5594 ffestc_end ()
5595 {
5596 ffestw b;
5597
5598 b = ffestw_stack_top ();
5599
5600 recurse:
5601
5602 switch (ffestw_state (b))
5603 {
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);
5611 break;
5612
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))
5621 {
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");
5627 ffebad_finish ();
5628 }
5629 ffestc_R1221 (NULL);
5630 break;
5631
5632 case FFESTV_stateMODULE0:
5633 case FFESTV_stateMODULE1:
5634 case FFESTV_stateMODULE2:
5635 case FFESTV_stateMODULE3:
5636 case FFESTV_stateMODULE4:
5637 case FFESTV_stateMODULE5:
5638 #if FFESTR_F90
5639 ffestc_R1106 (NULL);
5640 #endif
5641 break;
5642
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))
5651 {
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");
5657 ffebad_finish ();
5658 }
5659 ffestc_R1225 (NULL);
5660 break;
5661
5662 case FFESTV_stateUSE:
5663 b = ffestw_previous (ffestw_stack_top ());
5664 goto recurse; /* :::::::::::::::::::: */
5665
5666 default:
5667 ffestc_R1103 (NULL);
5668 break;
5669 }
5670 }
5671
5672 /* ffestc_eof -- Generic EOF
5673
5674 ffestc_eof();
5675
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. */
5678
5679 void
ffestc_eof()5680 ffestc_eof ()
5681 {
5682 if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateNIL)
5683 {
5684 ffebad_start (FFEBAD_EOF_BEFORE_BLOCK_END);
5685 ffebad_here (0, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
5686 ffebad_finish ();
5687 do
5688 (*ffestw_shriek (ffestw_stack_top ()))(FALSE);
5689 while (ffestw_state (ffestw_stack_top ()) != FFESTV_stateNIL);
5690 }
5691 }
5692
5693 /* ffestc_exec_transition -- Check if ok and move stmt state to executable
5694
5695 if (ffestc_exec_transition())
5696 // Transition successful (kind of like a CONTINUE stmt was seen).
5697
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
5702 return FALSE.
5703
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). */
5713
5714 bool
ffestc_exec_transition()5715 ffestc_exec_transition ()
5716 {
5717 bool update;
5718
5719 recurse:
5720
5721 switch (ffestw_state (ffestw_stack_top ()))
5722 {
5723 case FFESTV_stateNIL:
5724 ffestc_shriek_begin_program_ ();
5725 goto recurse; /* :::::::::::::::::::: */
5726
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. */
5732 update = TRUE;
5733 break;
5734
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. */
5740 update = TRUE;
5741 break;
5742
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. */
5748 update = TRUE;
5749 break;
5750
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. */
5756 update = TRUE;
5757 break;
5758
5759 case FFESTV_stateUSE:
5760 #if FFESTR_F90
5761 ffestc_shriek_end_uses_ (TRUE);
5762 #endif
5763 goto recurse; /* :::::::::::::::::::: */
5764
5765 default:
5766 return FALSE;
5767 }
5768
5769 if (update)
5770 ffestw_update (NULL); /* Update state line/col info. */
5771
5772 ffesta_seen_first_exec = TRUE;
5773 ffestd_exec_begin ();
5774
5775 return TRUE;
5776 }
5777
5778 /* ffestc_ffebad_here_doiter -- Calls ffebad_here with ptr to DO iter var
5779
5780 ffesymbol s;
5781 // call ffebad_start first, of course.
5782 ffestc_ffebad_here_doiter(0,s);
5783 // call ffebad_finish afterwards, naturally.
5784
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
5788 can't be found. */
5789
5790 void
ffestc_ffebad_here_doiter(ffebadIndex i,ffesymbol s)5791 ffestc_ffebad_here_doiter (ffebadIndex i, ffesymbol s)
5792 {
5793 ffestw block;
5794
5795 for (block = ffestw_top_do (ffestw_stack_top ());
5796 (block != NULL) && (ffestw_blocknum (block) != 0);
5797 block = ffestw_top_do (ffestw_previous (block)))
5798 {
5799 if (ffestw_do_iter_var (block) == s)
5800 {
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)));
5803 return;
5804 }
5805 }
5806 assert ("no do block found" == NULL);
5807 }
5808
5809 /* ffestc_is_decl_not_R1219 -- Context information for FFESTB
5810
5811 if (ffestc_is_decl_not_R1219()) ...
5812
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). */
5820
5821 bool
ffestc_is_decl_not_R1219()5822 ffestc_is_decl_not_R1219 ()
5823 {
5824 switch (ffestw_state (ffestw_stack_top ()))
5825 {
5826 case FFESTV_stateNIL:
5827 case FFESTV_statePROGRAM5:
5828 case FFESTV_stateSUBROUTINE5:
5829 case FFESTV_stateFUNCTION5:
5830 case FFESTV_stateMODULE5:
5831 case FFESTV_stateINTERFACE0:
5832 return FALSE;
5833
5834 default:
5835 return TRUE;
5836 }
5837 }
5838
5839 /* ffestc_is_entry_in_subr -- Context information for FFESTB
5840
5841 if (ffestc_is_entry_in_subr()) ...
5842
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. */
5850
5851 bool
ffestc_is_entry_in_subr()5852 ffestc_is_entry_in_subr ()
5853 {
5854 ffestvState s;
5855
5856 s = ffestw_state (ffestw_stack_top ());
5857
5858 recurse:
5859
5860 switch (s)
5861 {
5862 case FFESTV_stateFUNCTION0:
5863 case FFESTV_stateFUNCTION1:
5864 case FFESTV_stateFUNCTION2:
5865 case FFESTV_stateFUNCTION3:
5866 case FFESTV_stateFUNCTION4:
5867 return FALSE;
5868
5869 case FFESTV_stateUSE:
5870 s = ffestw_state (ffestw_previous (ffestw_stack_top ()));
5871 goto recurse; /* :::::::::::::::::::: */
5872
5873 default:
5874 return TRUE;
5875 }
5876 }
5877
5878 /* ffestc_is_let_not_V027 -- Context information for FFESTB
5879
5880 if (ffestc_is_let_not_V027()) ...
5881
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. */
5889
5890 bool
ffestc_is_let_not_V027()5891 ffestc_is_let_not_V027 ()
5892 {
5893 switch (ffestw_state (ffestw_stack_top ()))
5894 {
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:
5905 return TRUE;
5906
5907 default:
5908 return FALSE;
5909 }
5910 }
5911
5912 /* ffestc_module -- MODULE or MODULE PROCEDURE statement
5913
5914 ffestc_module(module_name_token,procedure_name_token);
5915
5916 Decide which is intended, and implement it by calling _R1105_ or
5917 _R1205_. */
5918
5919 #if FFESTR_F90
5920 void
ffestc_module(ffelexToken module,ffelexToken procedure)5921 ffestc_module (ffelexToken module, ffelexToken procedure)
5922 {
5923 switch (ffestw_state (ffestw_stack_top ()))
5924 {
5925 case FFESTV_stateINTERFACE0:
5926 case FFESTV_stateINTERFACE1:
5927 ffestc_R1205_start ();
5928 ffestc_R1205_item (procedure);
5929 ffestc_R1205_finish ();
5930 break;
5931
5932 default:
5933 ffestc_R1105 (module);
5934 break;
5935 }
5936 }
5937
5938 #endif
5939 /* ffestc_private -- Generic PRIVATE statement
5940
5941 ffestc_end();
5942
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. */
5946
5947 #if FFESTR_F90
5948 void
ffestc_private()5949 ffestc_private ()
5950 {
5951 switch (ffestw_state (ffestw_stack_top ()))
5952 {
5953 case FFESTV_stateTYPE:
5954 ffestc_R423A ();
5955 break;
5956
5957 default:
5958 ffestc_R521B ();
5959 break;
5960 }
5961 }
5962
5963 #endif
5964 /* ffestc_terminate_4 -- Terminate ffestc after scoping unit
5965
5966 ffestc_terminate_4();
5967
5968 For SUBROUTINEs/FUNCTIONs within INTERFACE/END INTERFACE, derived-TYPE-
5969 defs, and statement function defs. */
5970
5971 void
ffestc_terminate_4()5972 ffestc_terminate_4 ()
5973 {
5974 ffestc_entry_num_ = ffestc_saved_entry_num_;
5975 }
5976
5977 /* ffestc_R423A -- PRIVATE statement (in R422 derived-type statement)
5978
5979 ffestc_R423A(); */
5980
5981 #if FFESTR_F90
5982 void
ffestc_R423A()5983 ffestc_R423A ()
5984 {
5985 ffestc_check_simple_ ();
5986 if (ffestc_order_type_ () != FFESTC_orderOK_)
5987 return;
5988 ffestc_labeldef_useless_ ();
5989
5990 if (ffestw_substate (ffestw_stack_top ()) != 0)
5991 {
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 ()));
5996 ffebad_finish ();
5997 return;
5998 }
5999
6000 if (ffestw_state (ffestw_previous (ffestw_stack_top ())) != FFESTV_stateMODULE3)
6001 {
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]));
6005 ffebad_finish ();
6006 return;
6007 }
6008
6009 ffestw_set_substate (ffestw_stack_top (), 1); /* Seen
6010 private-sequence-stmt. */
6011
6012 ffestd_R423A ();
6013 }
6014
6015 /* ffestc_R423B -- SEQUENCE statement (in R422 derived-type-stmt)
6016
6017 ffestc_R423B(); */
6018
6019 void
ffestc_R423B()6020 ffestc_R423B ()
6021 {
6022 ffestc_check_simple_ ();
6023 if (ffestc_order_type_ () != FFESTC_orderOK_)
6024 return;
6025 ffestc_labeldef_useless_ ();
6026
6027 if (ffestw_substate (ffestw_stack_top ()) != 0)
6028 {
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 ()));
6033 ffebad_finish ();
6034 return;
6035 }
6036
6037 ffestw_set_substate (ffestw_stack_top (), 1); /* Seen
6038 private-sequence-stmt. */
6039
6040 ffestd_R423B ();
6041 }
6042
6043 /* ffestc_R424 -- derived-TYPE-def statement
6044
6045 ffestc_R424(access_token,access_kw,name_token);
6046
6047 Handle a derived-type definition. */
6048
6049 void
ffestc_R424(ffelexToken access,ffestrOther access_kw,ffelexToken name)6050 ffestc_R424 (ffelexToken access, ffestrOther access_kw, ffelexToken name)
6051 {
6052 ffestw b;
6053
6054 assert (name != NULL);
6055
6056 ffestc_check_simple_ ();
6057 if (ffestc_order_derivedtype_ () != FFESTC_orderOK_)
6058 return;
6059 ffestc_labeldef_useless_ ();
6060
6061 if ((access != NULL)
6062 && (ffestw_state (ffestw_stack_top ()) != FFESTV_stateMODULE3))
6063 {
6064 ffebad_start (FFEBAD_DERIVTYP_ACCESS);
6065 ffebad_here (0, ffelex_token_where_line (access),
6066 ffelex_token_where_column (access));
6067 ffebad_finish ();
6068 access = NULL;
6069 }
6070
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. */
6079
6080 ffestd_R424 (access, access_kw, name);
6081
6082 ffe_init_4 ();
6083 }
6084
6085 /* ffestc_R425 -- END TYPE statement
6086
6087 ffestc_R425(name_token);
6088
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. */
6092
6093 void
ffestc_R425(ffelexToken name)6094 ffestc_R425 (ffelexToken name)
6095 {
6096 ffestc_check_simple_ ();
6097 if (ffestc_order_type_ () != FFESTC_orderOK_)
6098 return;
6099 ffestc_labeldef_useless_ ();
6100
6101 if (ffestw_substate (ffestw_stack_top ()) != 2)
6102 {
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 ()));
6107 ffebad_finish ();
6108 }
6109
6110 if ((name != NULL)
6111 && (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0))
6112 {
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 ())));
6118 ffebad_finish ();
6119 }
6120
6121 ffestc_shriek_type_ (TRUE);
6122 }
6123
6124 /* ffestc_R426_start -- component-declaration-stmt
6125
6126 ffestc_R426_start(...);
6127
6128 Verify that R426 component-declaration-stmt is
6129 valid here and implement. */
6130
6131 void
ffestc_R426_start(ffestpType type,ffelexToken typet,ffebld kind,ffelexToken kindt,ffebld len,ffelexToken lent)6132 ffestc_R426_start (ffestpType type, ffelexToken typet, ffebld kind,
6133 ffelexToken kindt, ffebld len, ffelexToken lent)
6134 {
6135 ffestc_check_start_ ();
6136 if (ffestc_order_component_ () != FFESTC_orderOK_)
6137 {
6138 ffestc_local_.decl.is_R426 = 0;
6139 return;
6140 }
6141 ffestc_labeldef_useless_ ();
6142
6143 switch (ffestw_state (ffestw_stack_top ()))
6144 {
6145 case FFESTV_stateSTRUCTURE:
6146 case FFESTV_stateMAP:
6147 ffestw_set_substate (ffestw_stack_top (), 1); /* Seen at least one
6148 member. */
6149 break;
6150
6151 case FFESTV_stateTYPE:
6152 ffestw_set_substate (ffestw_stack_top (), 2);
6153 break;
6154
6155 default:
6156 assert ("Component parent state invalid" == NULL);
6157 break;
6158 }
6159 }
6160
6161 /* ffestc_R426_attrib -- type attribute
6162
6163 ffestc_R426_attrib(...);
6164
6165 Verify that R426 component-declaration-stmt attribute
6166 is valid here and implement. */
6167
6168 void
ffestc_R426_attrib(ffestpAttrib attrib,ffelexToken attribt,ffestrOther intent_kw,ffesttDimList dims)6169 ffestc_R426_attrib (ffestpAttrib attrib, ffelexToken attribt,
6170 ffestrOther intent_kw, ffesttDimList dims)
6171 {
6172 ffestc_check_attrib_ ();
6173 }
6174
6175 /* ffestc_R426_item -- declared object
6176
6177 ffestc_R426_item(...);
6178
6179 Establish type for a particular object. */
6180
6181 void
ffestc_R426_item(ffelexToken name,ffebld kind,ffelexToken kindt,ffesttDimList dims,ffebld len,ffelexToken lent,ffebld init,ffelexToken initt,bool clist)6182 ffestc_R426_item (ffelexToken name, ffebld kind, ffelexToken kindt,
6183 ffesttDimList dims, ffebld len, ffelexToken lent, ffebld init,
6184 ffelexToken initt, bool clist)
6185 {
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. */
6190
6191 if ((dims != NULL) || (init != NULL) || clist)
6192 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
6193 }
6194
6195 /* ffestc_R426_itemstartvals -- Start list of values
6196
6197 ffestc_R426_itemstartvals();
6198
6199 Gonna specify values for the object now. */
6200
6201 void
ffestc_R426_itemstartvals()6202 ffestc_R426_itemstartvals ()
6203 {
6204 ffestc_check_item_startvals_ ();
6205 }
6206
6207 /* ffestc_R426_itemvalue -- Source value
6208
6209 ffestc_R426_itemvalue(repeat,repeat_token,value,value_token);
6210
6211 Make sure repeat and value are valid for the object being initialized. */
6212
6213 void
ffestc_R426_itemvalue(ffebld repeat,ffelexToken repeat_token,ffebld value,ffelexToken value_token)6214 ffestc_R426_itemvalue (ffebld repeat, ffelexToken repeat_token,
6215 ffebld value, ffelexToken value_token)
6216 {
6217 ffestc_check_item_value_ ();
6218 }
6219
6220 /* ffestc_R426_itemendvals -- End list of values
6221
6222 ffelexToken t; // the SLASH token that ends the list.
6223 ffestc_R426_itemendvals(t);
6224
6225 No more values, might specify more objects now. */
6226
6227 void
ffestc_R426_itemendvals(ffelexToken t)6228 ffestc_R426_itemendvals (ffelexToken t)
6229 {
6230 ffestc_check_item_endvals_ ();
6231 }
6232
6233 /* ffestc_R426_finish -- Done
6234
6235 ffestc_R426_finish();
6236
6237 Just wrap up any local activities. */
6238
6239 void
ffestc_R426_finish()6240 ffestc_R426_finish ()
6241 {
6242 ffestc_check_finish_ ();
6243 }
6244
6245 #endif
6246 /* ffestc_R501_start -- type-declaration-stmt
6247
6248 ffestc_R501_start(...);
6249
6250 Verify that R501 type-declaration-stmt is
6251 valid here and implement. */
6252
6253 void
ffestc_R501_start(ffestpType type,ffelexToken typet,ffebld kind,ffelexToken kindt,ffebld len,ffelexToken lent)6254 ffestc_R501_start (ffestpType type, ffelexToken typet, ffebld kind,
6255 ffelexToken kindt, ffebld len, ffelexToken lent)
6256 {
6257 ffestc_check_start_ ();
6258 if (ffestc_order_typedecl_ () != FFESTC_orderOK_)
6259 {
6260 ffestc_local_.decl.is_R426 = 0;
6261 return;
6262 }
6263 ffestc_labeldef_useless_ ();
6264
6265 ffestc_establish_declstmt_ (type, typet, kind, kindt, len, lent);
6266 }
6267
6268 /* ffestc_R501_attrib -- type attribute
6269
6270 ffestc_R501_attrib(...);
6271
6272 Verify that R501 type-declaration-stmt attribute
6273 is valid here and implement. */
6274
6275 void
ffestc_R501_attrib(ffestpAttrib attrib,ffelexToken attribt,ffestrOther intent_kw UNUSED,ffesttDimList dims UNUSED)6276 ffestc_R501_attrib (ffestpAttrib attrib, ffelexToken attribt,
6277 ffestrOther intent_kw UNUSED,
6278 ffesttDimList dims UNUSED)
6279 {
6280 ffestc_check_attrib_ ();
6281
6282 switch (attrib)
6283 {
6284 #if FFESTR_F90
6285 case FFESTP_attribALLOCATABLE:
6286 break;
6287 #endif
6288
6289 case FFESTP_attribDIMENSION:
6290 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
6291 break;
6292
6293 case FFESTP_attribEXTERNAL:
6294 break;
6295
6296 #if FFESTR_F90
6297 case FFESTP_attribINTENT:
6298 break;
6299 #endif
6300
6301 case FFESTP_attribINTRINSIC:
6302 break;
6303
6304 #if FFESTR_F90
6305 case FFESTP_attribOPTIONAL:
6306 break;
6307 #endif
6308
6309 case FFESTP_attribPARAMETER:
6310 break;
6311
6312 #if FFESTR_F90
6313 case FFESTP_attribPOINTER:
6314 break;
6315 #endif
6316
6317 #if FFESTR_F90
6318 case FFESTP_attribPRIVATE:
6319 break;
6320
6321 case FFESTP_attribPUBLIC:
6322 break;
6323 #endif
6324
6325 case FFESTP_attribSAVE:
6326 switch (ffestv_save_state_)
6327 {
6328 case FFESTV_savestateNONE:
6329 ffestv_save_state_ = FFESTV_savestateSPECIFIC;
6330 ffestv_save_line_
6331 = ffewhere_line_use (ffelex_token_where_line (attribt));
6332 ffestv_save_col_
6333 = ffewhere_column_use (ffelex_token_where_column (attribt));
6334 break;
6335
6336 case FFESTV_savestateSPECIFIC:
6337 case FFESTV_savestateANY:
6338 break;
6339
6340 case FFESTV_savestateALL:
6341 if (ffe_is_pedantic ())
6342 {
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));
6347 ffebad_finish ();
6348 }
6349 ffestv_save_state_ = FFESTV_savestateANY;
6350 break;
6351
6352 default:
6353 assert ("unexpected save state" == NULL);
6354 break;
6355 }
6356 break;
6357
6358 #if FFESTR_F90
6359 case FFESTP_attribTARGET:
6360 break;
6361 #endif
6362
6363 default:
6364 assert ("unexpected attribute" == NULL);
6365 break;
6366 }
6367 }
6368
6369 /* ffestc_R501_item -- declared object
6370
6371 ffestc_R501_item(...);
6372
6373 Establish type for a particular object. */
6374
6375 void
ffestc_R501_item(ffelexToken name,ffebld kind,ffelexToken kindt,ffesttDimList dims,ffebld len,ffelexToken lent,ffebld init,ffelexToken initt,bool clist)6376 ffestc_R501_item (ffelexToken name, ffebld kind, ffelexToken kindt,
6377 ffesttDimList dims, ffebld len, ffelexToken lent,
6378 ffebld init, ffelexToken initt, bool clist)
6379 {
6380 ffesymbol s;
6381 ffesymbol sfn; /* FUNCTION symbol. */
6382 ffebld array_size;
6383 ffebld extents;
6384 ffesymbolAttrs sa;
6385 ffesymbolAttrs na;
6386 ffestpDimtype nd;
6387 bool is_init = (init != NULL) || clist;
6388 bool is_assumed;
6389 bool is_ugly_assumed;
6390 ffeinfoRank rank;
6391
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. */
6396
6397 ffestc_establish_declinfo_ (kind, kindt, len, lent);
6398
6399 is_assumed = (ffestc_local_.decl.basic_type == FFEINFO_basictypeCHARACTER)
6400 && (ffestc_local_.decl.size == FFETARGET_charactersizeNONE);
6401
6402 if ((dims != NULL) || is_init)
6403 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
6404
6405 s = ffesymbol_declare_local (name, TRUE);
6406 sa = ffesymbol_attrs (s);
6407
6408 /* First figure out what kind of object this is based solely on the current
6409 object situation (type params, dimension list, and initialization). */
6410
6411 na = FFESYMBOL_attrsTYPE;
6412
6413 if (is_assumed)
6414 na |= FFESYMBOL_attrsANYLEN;
6415
6416 is_ugly_assumed = (ffe_is_ugly_assumed ()
6417 && ((sa & FFESYMBOL_attrsDUMMY)
6418 || (ffesymbol_where (s) == FFEINFO_whereDUMMY)));
6419
6420 nd = ffestt_dimlist_type (dims, is_ugly_assumed);
6421 switch (nd)
6422 {
6423 case FFESTP_dimtypeNONE:
6424 break;
6425
6426 case FFESTP_dimtypeKNOWN:
6427 na |= FFESYMBOL_attrsARRAY;
6428 break;
6429
6430 case FFESTP_dimtypeADJUSTABLE:
6431 na |= FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE;
6432 break;
6433
6434 case FFESTP_dimtypeASSUMED:
6435 na |= FFESYMBOL_attrsARRAY | FFESYMBOL_attrsANYSIZE;
6436 break;
6437
6438 case FFESTP_dimtypeADJUSTABLEASSUMED:
6439 na |= FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE
6440 | FFESYMBOL_attrsANYSIZE;
6441 break;
6442
6443 default:
6444 assert ("unexpected dimtype" == NULL);
6445 na = FFESYMBOL_attrsetNONE;
6446 break;
6447 }
6448
6449 if (!ffesta_is_entry_valid
6450 && (((na & (FFESYMBOL_attrsANYLEN | FFESYMBOL_attrsARRAY))
6451 == (FFESYMBOL_attrsANYLEN | FFESYMBOL_attrsARRAY))))
6452 na = FFESYMBOL_attrsetNONE;
6453
6454 if (is_init)
6455 {
6456 if (na == FFESYMBOL_attrsetNONE)
6457 ;
6458 else if (na & (FFESYMBOL_attrsANYLEN
6459 | FFESYMBOL_attrsADJUSTABLE
6460 | FFESYMBOL_attrsANYSIZE))
6461 na = FFESYMBOL_attrsetNONE;
6462 else
6463 na |= FFESYMBOL_attrsINIT;
6464 }
6465
6466 /* Now figure out what kind of object we've got based on previous
6467 declarations of or references to the object. */
6468
6469 if (na == FFESYMBOL_attrsetNONE)
6470 ;
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)
6478 na = sa;
6479 else if ((sa & na)
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));
6516 }
6517 else
6518 na |= sa;
6519
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. */
6523
6524 if (na == FFESYMBOL_attrsetNONE)
6525 {
6526 ffesymbol_error (s, name);
6527 ffestc_parent_ok_ = FALSE;
6528 }
6529 else if (na & FFESYMBOL_attrsANY)
6530 ffestc_parent_ok_ = FALSE;
6531 else
6532 {
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);
6537 if (dims != NULL)
6538 {
6539 ffesymbol_set_dims (s, ffestt_dimlist_as_expr (dims, &rank,
6540 &array_size,
6541 &extents,
6542 is_ugly_assumed));
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))
6548 == 0))
6549 {
6550 ffebad_start (FFEBAD_ZERO_ARRAY);
6551 ffebad_here (0, ffelex_token_where_line (name),
6552 ffelex_token_where_column (name));
6553 ffebad_finish ();
6554 }
6555 }
6556 if (init != NULL)
6557 {
6558 ffesymbol_set_init (s,
6559 ffeexpr_convert (init, initt, name,
6560 ffestc_local_.decl.basic_type,
6561 ffestc_local_.decl.kind_type,
6562 rank,
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);
6570 #endif
6571 }
6572 else if (clist)
6573 {
6574 ffebld symter;
6575
6576 symter = ffebld_new_symter (s, FFEINTRIN_genNONE,
6577 FFEINTRIN_specNONE,
6578 FFEINTRIN_impNONE);
6579
6580 ffebld_set_info (symter,
6581 ffeinfo_new (ffestc_local_.decl.basic_type,
6582 ffestc_local_.decl.kind_type,
6583 rank,
6584 FFEINFO_kindNONE,
6585 FFEINFO_whereNONE,
6586 ffestc_local_.decl.size));
6587 ffestc_local_.decl.initlist = ffebld_new_item (symter, NULL);
6588 }
6589 if (ffesymbol_basictype (s) == FFEINFO_basictypeNONE)
6590 {
6591 ffesymbol_set_info (s,
6592 ffeinfo_new (ffestc_local_.decl.basic_type,
6593 ffestc_local_.decl.kind_type,
6594 rank,
6595 ffesymbol_kind (s),
6596 ffesymbol_where (s),
6597 ffestc_local_.decl.size));
6598 if ((na & FFESYMBOL_attrsRESULT)
6599 && ((sfn = ffesymbol_funcresult (s)) != NULL))
6600 {
6601 ffesymbol_set_info (sfn,
6602 ffeinfo_new (ffestc_local_.decl.basic_type,
6603 ffestc_local_.decl.kind_type,
6604 rank,
6605 ffesymbol_kind (sfn),
6606 ffesymbol_where (sfn),
6607 ffestc_local_.decl.size));
6608 ffesymbol_signal_unreported (sfn);
6609 }
6610 }
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
6617 implicit type. */
6618 ffesymbol_error (s, name);
6619 }
6620
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);
6625
6626 ffesymbol_signal_unreported (s);
6627 ffestc_parent_ok_ = TRUE;
6628 }
6629 }
6630
6631 /* ffestc_R501_itemstartvals -- Start list of values
6632
6633 ffestc_R501_itemstartvals();
6634
6635 Gonna specify values for the object now. */
6636
6637 void
ffestc_R501_itemstartvals()6638 ffestc_R501_itemstartvals ()
6639 {
6640 ffestc_check_item_startvals_ ();
6641
6642 if (ffestc_parent_ok_)
6643 ffedata_begin (ffestc_local_.decl.initlist);
6644 }
6645
6646 /* ffestc_R501_itemvalue -- Source value
6647
6648 ffestc_R501_itemvalue(repeat,repeat_token,value,value_token);
6649
6650 Make sure repeat and value are valid for the object being initialized. */
6651
6652 void
ffestc_R501_itemvalue(ffebld repeat,ffelexToken repeat_token,ffebld value,ffelexToken value_token)6653 ffestc_R501_itemvalue (ffebld repeat, ffelexToken repeat_token,
6654 ffebld value, ffelexToken value_token)
6655 {
6656 ffetargetIntegerDefault rpt;
6657
6658 ffestc_check_item_value_ ();
6659
6660 if (!ffestc_parent_ok_)
6661 return;
6662
6663 if (repeat == NULL)
6664 rpt = 1;
6665 else if (ffebld_op (repeat) == FFEBLD_opCONTER)
6666 rpt = ffebld_constant_integerdefault (ffebld_conter (repeat));
6667 else
6668 {
6669 ffestc_parent_ok_ = FALSE;
6670 ffedata_end (TRUE, NULL);
6671 return;
6672 }
6673
6674 if (!(ffestc_parent_ok_ = ffedata_value (rpt, value,
6675 (repeat_token == NULL) ? value_token : repeat_token)))
6676 ffedata_end (TRUE, NULL);
6677 }
6678
6679 /* ffestc_R501_itemendvals -- End list of values
6680
6681 ffelexToken t; // the SLASH token that ends the list.
6682 ffestc_R501_itemendvals(t);
6683
6684 No more values, might specify more objects now. */
6685
6686 void
ffestc_R501_itemendvals(ffelexToken t)6687 ffestc_R501_itemendvals (ffelexToken t)
6688 {
6689 ffestc_check_item_endvals_ ();
6690
6691 if (ffestc_parent_ok_)
6692 ffestc_parent_ok_ = ffedata_end (FALSE, t);
6693
6694 if (ffestc_parent_ok_)
6695 ffesymbol_signal_unreported (ffebld_symter (ffebld_head
6696 (ffestc_local_.decl.initlist)));
6697 }
6698
6699 /* ffestc_R501_finish -- Done
6700
6701 ffestc_R501_finish();
6702
6703 Just wrap up any local activities. */
6704
6705 void
ffestc_R501_finish()6706 ffestc_R501_finish ()
6707 {
6708 ffestc_check_finish_ ();
6709 }
6710
6711 /* ffestc_R519_start -- INTENT statement list begin
6712
6713 ffestc_R519_start();
6714
6715 Verify that INTENT is valid here, and begin accepting items in the list. */
6716
6717 #if FFESTR_F90
6718 void
ffestc_R519_start(ffelexToken intent,ffestrOther intent_kw)6719 ffestc_R519_start (ffelexToken intent, ffestrOther intent_kw)
6720 {
6721 ffestc_check_start_ ();
6722 if (ffestc_order_spec_ () != FFESTC_orderOK_)
6723 {
6724 ffestc_ok_ = FALSE;
6725 return;
6726 }
6727 ffestc_labeldef_useless_ ();
6728
6729 ffestd_R519_start (intent_kw);
6730
6731 ffestc_ok_ = TRUE;
6732 }
6733
6734 /* ffestc_R519_item -- INTENT statement for name
6735
6736 ffestc_R519_item(name_token);
6737
6738 Make sure name_token identifies a valid object to be INTENTed. */
6739
6740 void
ffestc_R519_item(ffelexToken name)6741 ffestc_R519_item (ffelexToken name)
6742 {
6743 ffestc_check_item_ ();
6744 assert (name != NULL);
6745 if (!ffestc_ok_)
6746 return;
6747
6748 ffestd_R519_item (name);
6749 }
6750
6751 /* ffestc_R519_finish -- INTENT statement list complete
6752
6753 ffestc_R519_finish();
6754
6755 Just wrap up any local activities. */
6756
6757 void
ffestc_R519_finish()6758 ffestc_R519_finish ()
6759 {
6760 ffestc_check_finish_ ();
6761 if (!ffestc_ok_)
6762 return;
6763
6764 ffestd_R519_finish ();
6765 }
6766
6767 /* ffestc_R520_start -- OPTIONAL statement list begin
6768
6769 ffestc_R520_start();
6770
6771 Verify that OPTIONAL is valid here, and begin accepting items in the list. */
6772
6773 void
ffestc_R520_start()6774 ffestc_R520_start ()
6775 {
6776 ffestc_check_start_ ();
6777 if (ffestc_order_spec_ () != FFESTC_orderOK_)
6778 {
6779 ffestc_ok_ = FALSE;
6780 return;
6781 }
6782 ffestc_labeldef_useless_ ();
6783
6784 ffestd_R520_start ();
6785
6786 ffestc_ok_ = TRUE;
6787 }
6788
6789 /* ffestc_R520_item -- OPTIONAL statement for name
6790
6791 ffestc_R520_item(name_token);
6792
6793 Make sure name_token identifies a valid object to be OPTIONALed. */
6794
6795 void
ffestc_R520_item(ffelexToken name)6796 ffestc_R520_item (ffelexToken name)
6797 {
6798 ffestc_check_item_ ();
6799 assert (name != NULL);
6800 if (!ffestc_ok_)
6801 return;
6802
6803 ffestd_R520_item (name);
6804 }
6805
6806 /* ffestc_R520_finish -- OPTIONAL statement list complete
6807
6808 ffestc_R520_finish();
6809
6810 Just wrap up any local activities. */
6811
6812 void
ffestc_R520_finish()6813 ffestc_R520_finish ()
6814 {
6815 ffestc_check_finish_ ();
6816 if (!ffestc_ok_)
6817 return;
6818
6819 ffestd_R520_finish ();
6820 }
6821
6822 /* ffestc_R521A -- PUBLIC statement
6823
6824 ffestc_R521A();
6825
6826 Verify that PUBLIC is valid here. */
6827
6828 void
ffestc_R521A()6829 ffestc_R521A ()
6830 {
6831 ffestc_check_simple_ ();
6832 if (ffestc_order_access_ () != FFESTC_orderOK_)
6833 return;
6834 ffestc_labeldef_useless_ ();
6835
6836 switch (ffestv_access_state_)
6837 {
6838 case FFESTV_accessstateNONE:
6839 ffestv_access_state_ = FFESTV_accessstatePUBLIC;
6840 ffestv_access_line_
6841 = ffewhere_line_use (ffelex_token_where_line (ffesta_tokens[0]));
6842 ffestv_access_col_
6843 = ffewhere_column_use (ffelex_token_where_column (ffesta_tokens[0]));
6844 break;
6845
6846 case FFESTV_accessstateANY:
6847 break;
6848
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]));
6855 ffebad_finish ();
6856 ffestv_access_state_ = FFESTV_accessstateANY;
6857 break;
6858
6859 default:
6860 assert ("unexpected access state" == NULL);
6861 break;
6862 }
6863
6864 ffestd_R521A ();
6865 }
6866
6867 /* ffestc_R521Astart -- PUBLIC statement list begin
6868
6869 ffestc_R521Astart();
6870
6871 Verify that PUBLIC is valid here, and begin accepting items in the list. */
6872
6873 void
ffestc_R521Astart()6874 ffestc_R521Astart ()
6875 {
6876 ffestc_check_start_ ();
6877 if (ffestc_order_access_ () != FFESTC_orderOK_)
6878 {
6879 ffestc_ok_ = FALSE;
6880 return;
6881 }
6882 ffestc_labeldef_useless_ ();
6883
6884 ffestd_R521Astart ();
6885
6886 ffestc_ok_ = TRUE;
6887 }
6888
6889 /* ffestc_R521Aitem -- PUBLIC statement for name
6890
6891 ffestc_R521Aitem(name_token);
6892
6893 Make sure name_token identifies a valid object to be PUBLICed. */
6894
6895 void
ffestc_R521Aitem(ffelexToken name)6896 ffestc_R521Aitem (ffelexToken name)
6897 {
6898 ffestc_check_item_ ();
6899 assert (name != NULL);
6900 if (!ffestc_ok_)
6901 return;
6902
6903 ffestd_R521Aitem (name);
6904 }
6905
6906 /* ffestc_R521Afinish -- PUBLIC statement list complete
6907
6908 ffestc_R521Afinish();
6909
6910 Just wrap up any local activities. */
6911
6912 void
ffestc_R521Afinish()6913 ffestc_R521Afinish ()
6914 {
6915 ffestc_check_finish_ ();
6916 if (!ffestc_ok_)
6917 return;
6918
6919 ffestd_R521Afinish ();
6920 }
6921
6922 /* ffestc_R521B -- PRIVATE statement
6923
6924 ffestc_R521B();
6925
6926 Verify that PRIVATE is valid here (outside a derived-type statement). */
6927
6928 void
ffestc_R521B()6929 ffestc_R521B ()
6930 {
6931 ffestc_check_simple_ ();
6932 if (ffestc_order_access_ () != FFESTC_orderOK_)
6933 return;
6934 ffestc_labeldef_useless_ ();
6935
6936 switch (ffestv_access_state_)
6937 {
6938 case FFESTV_accessstateNONE:
6939 ffestv_access_state_ = FFESTV_accessstatePRIVATE;
6940 ffestv_access_line_
6941 = ffewhere_line_use (ffelex_token_where_line (ffesta_tokens[0]));
6942 ffestv_access_col_
6943 = ffewhere_column_use (ffelex_token_where_column (ffesta_tokens[0]));
6944 break;
6945
6946 case FFESTV_accessstateANY:
6947 break;
6948
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]));
6955 ffebad_finish ();
6956 ffestv_access_state_ = FFESTV_accessstateANY;
6957 break;
6958
6959 default:
6960 assert ("unexpected access state" == NULL);
6961 break;
6962 }
6963
6964 ffestd_R521B ();
6965 }
6966
6967 /* ffestc_R521Bstart -- PRIVATE statement list begin
6968
6969 ffestc_R521Bstart();
6970
6971 Verify that PRIVATE is valid here, and begin accepting items in the list. */
6972
6973 void
ffestc_R521Bstart()6974 ffestc_R521Bstart ()
6975 {
6976 ffestc_check_start_ ();
6977 if (ffestc_order_access_ () != FFESTC_orderOK_)
6978 {
6979 ffestc_ok_ = FALSE;
6980 return;
6981 }
6982 ffestc_labeldef_useless_ ();
6983
6984 ffestd_R521Bstart ();
6985
6986 ffestc_ok_ = TRUE;
6987 }
6988
6989 /* ffestc_R521Bitem -- PRIVATE statement for name
6990
6991 ffestc_R521Bitem(name_token);
6992
6993 Make sure name_token identifies a valid object to be PRIVATEed. */
6994
6995 void
ffestc_R521Bitem(ffelexToken name)6996 ffestc_R521Bitem (ffelexToken name)
6997 {
6998 ffestc_check_item_ ();
6999 assert (name != NULL);
7000 if (!ffestc_ok_)
7001 return;
7002
7003 ffestd_R521Bitem (name);
7004 }
7005
7006 /* ffestc_R521Bfinish -- PRIVATE statement list complete
7007
7008 ffestc_R521Bfinish();
7009
7010 Just wrap up any local activities. */
7011
7012 void
ffestc_R521Bfinish()7013 ffestc_R521Bfinish ()
7014 {
7015 ffestc_check_finish_ ();
7016 if (!ffestc_ok_)
7017 return;
7018
7019 ffestd_R521Bfinish ();
7020 }
7021
7022 #endif
7023 /* ffestc_R522 -- SAVE statement with no list
7024
7025 ffestc_R522();
7026
7027 Verify that SAVE is valid here, and flag everything as SAVEd. */
7028
7029 void
ffestc_R522()7030 ffestc_R522 ()
7031 {
7032 ffestc_check_simple_ ();
7033 if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
7034 return;
7035 ffestc_labeldef_useless_ ();
7036
7037 switch (ffestv_save_state_)
7038 {
7039 case FFESTV_savestateNONE:
7040 ffestv_save_state_ = FFESTV_savestateALL;
7041 ffestv_save_line_
7042 = ffewhere_line_use (ffelex_token_where_line (ffesta_tokens[0]));
7043 ffestv_save_col_
7044 = ffewhere_column_use (ffelex_token_where_column (ffesta_tokens[0]));
7045 break;
7046
7047 case FFESTV_savestateANY:
7048 break;
7049
7050 case FFESTV_savestateSPECIFIC:
7051 case FFESTV_savestateALL:
7052 if (ffe_is_pedantic ())
7053 {
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]));
7058 ffebad_finish ();
7059 }
7060 ffestv_save_state_ = FFESTV_savestateALL;
7061 break;
7062
7063 default:
7064 assert ("unexpected save state" == NULL);
7065 break;
7066 }
7067
7068 ffe_set_is_saveall (TRUE);
7069
7070 ffestd_R522 ();
7071 }
7072
7073 /* ffestc_R522start -- SAVE statement list begin
7074
7075 ffestc_R522start();
7076
7077 Verify that SAVE is valid here, and begin accepting items in the list. */
7078
7079 void
ffestc_R522start()7080 ffestc_R522start ()
7081 {
7082 ffestc_check_start_ ();
7083 if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
7084 {
7085 ffestc_ok_ = FALSE;
7086 return;
7087 }
7088 ffestc_labeldef_useless_ ();
7089
7090 switch (ffestv_save_state_)
7091 {
7092 case FFESTV_savestateNONE:
7093 ffestv_save_state_ = FFESTV_savestateSPECIFIC;
7094 ffestv_save_line_
7095 = ffewhere_line_use (ffelex_token_where_line (ffesta_tokens[0]));
7096 ffestv_save_col_
7097 = ffewhere_column_use (ffelex_token_where_column (ffesta_tokens[0]));
7098 break;
7099
7100 case FFESTV_savestateSPECIFIC:
7101 case FFESTV_savestateANY:
7102 break;
7103
7104 case FFESTV_savestateALL:
7105 if (ffe_is_pedantic ())
7106 {
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]));
7111 ffebad_finish ();
7112 }
7113 ffestv_save_state_ = FFESTV_savestateANY;
7114 break;
7115
7116 default:
7117 assert ("unexpected save state" == NULL);
7118 break;
7119 }
7120
7121 ffestd_R522start ();
7122
7123 ffestc_ok_ = TRUE;
7124 }
7125
7126 /* ffestc_R522item_object -- SAVE statement for object-name
7127
7128 ffestc_R522item_object(name_token);
7129
7130 Make sure name_token identifies a valid object to be SAVEd. */
7131
7132 void
ffestc_R522item_object(ffelexToken name)7133 ffestc_R522item_object (ffelexToken name)
7134 {
7135 ffesymbol s;
7136 ffesymbolAttrs sa;
7137 ffesymbolAttrs na;
7138
7139 ffestc_check_item_ ();
7140 assert (name != NULL);
7141 if (!ffestc_ok_)
7142 return;
7143
7144 s = ffesymbol_declare_local (name, FALSE);
7145 sa = ffesymbol_attrs (s);
7146
7147 /* Figure out what kind of object we've got based on previous declarations
7148 of or references to the object. */
7149
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)
7155 na = sa;
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;
7163 else
7164 na = FFESYMBOL_attrsetNONE;
7165
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. */
7169
7170 if (na == FFESYMBOL_attrsetNONE)
7171 ffesymbol_error (s, name);
7172 else if (!(na & FFESYMBOL_attrsANY))
7173 {
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);
7179 }
7180
7181 ffestd_R522item_object (name);
7182 }
7183
7184 /* ffestc_R522item_cblock -- SAVE statement for common-block-name
7185
7186 ffestc_R522item_cblock(name_token);
7187
7188 Make sure name_token identifies a valid common block to be SAVEd. */
7189
7190 void
ffestc_R522item_cblock(ffelexToken name)7191 ffestc_R522item_cblock (ffelexToken name)
7192 {
7193 ffesymbol s;
7194 ffesymbolAttrs sa;
7195 ffesymbolAttrs na;
7196
7197 ffestc_check_item_ ();
7198 assert (name != NULL);
7199 if (!ffestc_ok_)
7200 return;
7201
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);
7205
7206 /* Figure out what kind of object we've got based on previous declarations
7207 of or references to the object. */
7208
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;
7215 else
7216 na = FFESYMBOL_attrsetNONE;
7217
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. */
7221
7222 if (na == FFESYMBOL_attrsetNONE)
7223 ffesymbol_error (s, (name == NULL) ? ffesta_tokens[0] : name);
7224 else if (!(na & FFESYMBOL_attrsANY))
7225 {
7226 ffesymbol_set_attrs (s, na);
7227 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
7228 ffesymbol_update_save (s);
7229 ffesymbol_signal_unreported (s);
7230 }
7231
7232 ffestd_R522item_cblock (name);
7233 }
7234
7235 /* ffestc_R522finish -- SAVE statement list complete
7236
7237 ffestc_R522finish();
7238
7239 Just wrap up any local activities. */
7240
7241 void
ffestc_R522finish()7242 ffestc_R522finish ()
7243 {
7244 ffestc_check_finish_ ();
7245 if (!ffestc_ok_)
7246 return;
7247
7248 ffestd_R522finish ();
7249 }
7250
7251 /* ffestc_R524_start -- DIMENSION statement list begin
7252
7253 ffestc_R524_start(bool virtual);
7254
7255 Verify that DIMENSION is valid here, and begin accepting items in the
7256 list. */
7257
7258 void
ffestc_R524_start(bool virtual)7259 ffestc_R524_start (bool virtual)
7260 {
7261 ffestc_check_start_ ();
7262 if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
7263 {
7264 ffestc_ok_ = FALSE;
7265 return;
7266 }
7267 ffestc_labeldef_useless_ ();
7268
7269 ffestd_R524_start (virtual);
7270
7271 ffestc_ok_ = TRUE;
7272 }
7273
7274 /* ffestc_R524_item -- DIMENSION statement for object-name
7275
7276 ffestc_R524_item(name_token,dim_list);
7277
7278 Make sure name_token identifies a valid object to be DIMENSIONd. */
7279
7280 void
ffestc_R524_item(ffelexToken name,ffesttDimList dims)7281 ffestc_R524_item (ffelexToken name, ffesttDimList dims)
7282 {
7283 ffesymbol s;
7284 ffebld array_size;
7285 ffebld extents;
7286 ffesymbolAttrs sa;
7287 ffesymbolAttrs na;
7288 ffestpDimtype nd;
7289 ffeinfoRank rank;
7290 bool is_ugly_assumed;
7291
7292 ffestc_check_item_ ();
7293 assert (name != NULL);
7294 assert (dims != NULL);
7295 if (!ffestc_ok_)
7296 return;
7297
7298 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
7299
7300 s = ffesymbol_declare_local (name, FALSE);
7301 sa = ffesymbol_attrs (s);
7302
7303 /* First figure out what kind of object this is based solely on the current
7304 object situation (dimension list). */
7305
7306 is_ugly_assumed = (ffe_is_ugly_assumed ()
7307 && ((sa & FFESYMBOL_attrsDUMMY)
7308 || (ffesymbol_where (s) == FFEINFO_whereDUMMY)));
7309
7310 nd = ffestt_dimlist_type (dims, is_ugly_assumed);
7311 switch (nd)
7312 {
7313 case FFESTP_dimtypeKNOWN:
7314 na = FFESYMBOL_attrsARRAY;
7315 break;
7316
7317 case FFESTP_dimtypeADJUSTABLE:
7318 na = FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE;
7319 break;
7320
7321 case FFESTP_dimtypeASSUMED:
7322 na = FFESYMBOL_attrsARRAY | FFESYMBOL_attrsANYSIZE;
7323 break;
7324
7325 case FFESTP_dimtypeADJUSTABLEASSUMED:
7326 na = FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE
7327 | FFESYMBOL_attrsANYSIZE;
7328 break;
7329
7330 default:
7331 assert ("Unexpected dims type" == NULL);
7332 na = FFESYMBOL_attrsetNONE;
7333 break;
7334 }
7335
7336 /* Now figure out what kind of object we've got based on previous
7337 declarations of or references to the object. */
7338
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)))
7363 na |= sa;
7364 else
7365 na = FFESYMBOL_attrsetNONE;
7366
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. */
7370
7371 if (na == FFESYMBOL_attrsetNONE)
7372 ffesymbol_error (s, name);
7373 else if (!(na & FFESYMBOL_attrsANY))
7374 {
7375 ffesymbol_set_attrs (s, na);
7376 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
7377 ffesymbol_set_dims (s, ffestt_dimlist_as_expr (dims, &rank,
7378 &array_size,
7379 &extents,
7380 is_ugly_assumed));
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))
7386 == 0))
7387 {
7388 ffebad_start (FFEBAD_ZERO_ARRAY);
7389 ffebad_here (0, ffelex_token_where_line (name),
7390 ffelex_token_where_column (name));
7391 ffebad_finish ();
7392 }
7393 ffesymbol_set_info (s,
7394 ffeinfo_new (ffesymbol_basictype (s),
7395 ffesymbol_kindtype (s),
7396 rank,
7397 ffesymbol_kind (s),
7398 ffesymbol_where (s),
7399 ffesymbol_size (s)));
7400 }
7401
7402 ffesymbol_signal_unreported (s);
7403
7404 ffestd_R524_item (name, dims);
7405 }
7406
7407 /* ffestc_R524_finish -- DIMENSION statement list complete
7408
7409 ffestc_R524_finish();
7410
7411 Just wrap up any local activities. */
7412
7413 void
ffestc_R524_finish()7414 ffestc_R524_finish ()
7415 {
7416 ffestc_check_finish_ ();
7417 if (!ffestc_ok_)
7418 return;
7419
7420 ffestd_R524_finish ();
7421 }
7422
7423 /* ffestc_R525_start -- ALLOCATABLE statement list begin
7424
7425 ffestc_R525_start();
7426
7427 Verify that ALLOCATABLE is valid here, and begin accepting items in the
7428 list. */
7429
7430 #if FFESTR_F90
7431 void
ffestc_R525_start()7432 ffestc_R525_start ()
7433 {
7434 ffestc_check_start_ ();
7435 if (ffestc_order_progspec_ () != FFESTC_orderOK_)
7436 {
7437 ffestc_ok_ = FALSE;
7438 return;
7439 }
7440 ffestc_labeldef_useless_ ();
7441
7442 ffestd_R525_start ();
7443
7444 ffestc_ok_ = TRUE;
7445 }
7446
7447 /* ffestc_R525_item -- ALLOCATABLE statement for object-name
7448
7449 ffestc_R525_item(name_token,dim_list);
7450
7451 Make sure name_token identifies a valid object to be ALLOCATABLEd. */
7452
7453 void
ffestc_R525_item(ffelexToken name,ffesttDimList dims)7454 ffestc_R525_item (ffelexToken name, ffesttDimList dims)
7455 {
7456 ffestc_check_item_ ();
7457 assert (name != NULL);
7458 if (!ffestc_ok_)
7459 return;
7460
7461 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
7462
7463 ffestd_R525_item (name, dims);
7464 }
7465
7466 /* ffestc_R525_finish -- ALLOCATABLE statement list complete
7467
7468 ffestc_R525_finish();
7469
7470 Just wrap up any local activities. */
7471
7472 void
ffestc_R525_finish()7473 ffestc_R525_finish ()
7474 {
7475 ffestc_check_finish_ ();
7476 if (!ffestc_ok_)
7477 return;
7478
7479 ffestd_R525_finish ();
7480 }
7481
7482 /* ffestc_R526_start -- POINTER statement list begin
7483
7484 ffestc_R526_start();
7485
7486 Verify that POINTER is valid here, and begin accepting items in the
7487 list. */
7488
7489 void
ffestc_R526_start()7490 ffestc_R526_start ()
7491 {
7492 ffestc_check_start_ ();
7493 if (ffestc_order_progspec_ () != FFESTC_orderOK_)
7494 {
7495 ffestc_ok_ = FALSE;
7496 return;
7497 }
7498 ffestc_labeldef_useless_ ();
7499
7500 ffestd_R526_start ();
7501
7502 ffestc_ok_ = TRUE;
7503 }
7504
7505 /* ffestc_R526_item -- POINTER statement for object-name
7506
7507 ffestc_R526_item(name_token,dim_list);
7508
7509 Make sure name_token identifies a valid object to be POINTERd. */
7510
7511 void
ffestc_R526_item(ffelexToken name,ffesttDimList dims)7512 ffestc_R526_item (ffelexToken name, ffesttDimList dims)
7513 {
7514 ffestc_check_item_ ();
7515 assert (name != NULL);
7516 if (!ffestc_ok_)
7517 return;
7518
7519 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
7520
7521 ffestd_R526_item (name, dims);
7522 }
7523
7524 /* ffestc_R526_finish -- POINTER statement list complete
7525
7526 ffestc_R526_finish();
7527
7528 Just wrap up any local activities. */
7529
7530 void
ffestc_R526_finish()7531 ffestc_R526_finish ()
7532 {
7533 ffestc_check_finish_ ();
7534 if (!ffestc_ok_)
7535 return;
7536
7537 ffestd_R526_finish ();
7538 }
7539
7540 /* ffestc_R527_start -- TARGET statement list begin
7541
7542 ffestc_R527_start();
7543
7544 Verify that TARGET is valid here, and begin accepting items in the
7545 list. */
7546
7547 void
ffestc_R527_start()7548 ffestc_R527_start ()
7549 {
7550 ffestc_check_start_ ();
7551 if (ffestc_order_progspec_ () != FFESTC_orderOK_)
7552 {
7553 ffestc_ok_ = FALSE;
7554 return;
7555 }
7556 ffestc_labeldef_useless_ ();
7557
7558 ffestd_R527_start ();
7559
7560 ffestc_ok_ = TRUE;
7561 }
7562
7563 /* ffestc_R527_item -- TARGET statement for object-name
7564
7565 ffestc_R527_item(name_token,dim_list);
7566
7567 Make sure name_token identifies a valid object to be TARGETd. */
7568
7569 void
ffestc_R527_item(ffelexToken name,ffesttDimList dims)7570 ffestc_R527_item (ffelexToken name, ffesttDimList dims)
7571 {
7572 ffestc_check_item_ ();
7573 assert (name != NULL);
7574 if (!ffestc_ok_)
7575 return;
7576
7577 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
7578
7579 ffestd_R527_item (name, dims);
7580 }
7581
7582 /* ffestc_R527_finish -- TARGET statement list complete
7583
7584 ffestc_R527_finish();
7585
7586 Just wrap up any local activities. */
7587
7588 void
ffestc_R527_finish()7589 ffestc_R527_finish ()
7590 {
7591 ffestc_check_finish_ ();
7592 if (!ffestc_ok_)
7593 return;
7594
7595 ffestd_R527_finish ();
7596 }
7597
7598 #endif
7599 /* ffestc_R528_start -- DATA statement list begin
7600
7601 ffestc_R528_start();
7602
7603 Verify that DATA is valid here, and begin accepting items in the list. */
7604
7605 void
ffestc_R528_start()7606 ffestc_R528_start ()
7607 {
7608 ffestcOrder_ order;
7609
7610 ffestc_check_start_ ();
7611 if (ffe_is_pedantic_not_90 ())
7612 order = ffestc_order_data77_ ();
7613 else
7614 order = ffestc_order_data_ ();
7615 if (order != FFESTC_orderOK_)
7616 {
7617 ffestc_ok_ = FALSE;
7618 return;
7619 }
7620 ffestc_labeldef_useless_ ();
7621
7622 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
7623
7624 #if 1
7625 ffestc_local_.data.objlist = NULL;
7626 #else
7627 ffestd_R528_start_ ();
7628 #endif
7629
7630 ffestc_ok_ = TRUE;
7631 }
7632
7633 /* ffestc_R528_item_object -- DATA statement target object
7634
7635 ffestc_R528_item_object(object,object_token);
7636
7637 Make sure object is valid to be DATAd. */
7638
7639 void
ffestc_R528_item_object(ffebld expr,ffelexToken expr_token UNUSED)7640 ffestc_R528_item_object (ffebld expr, ffelexToken expr_token UNUSED)
7641 {
7642 ffestc_check_item_ ();
7643 if (!ffestc_ok_)
7644 return;
7645
7646 #if 1
7647 if (ffestc_local_.data.objlist == NULL)
7648 ffebld_init_list (&ffestc_local_.data.objlist,
7649 &ffestc_local_.data.list_bottom);
7650
7651 ffebld_append_item (&ffestc_local_.data.list_bottom, expr);
7652 #else
7653 ffestd_R528_item_object_ (expr, expr_token);
7654 #endif
7655 }
7656
7657 /* ffestc_R528_item_startvals -- DATA statement start list of values
7658
7659 ffestc_R528_item_startvals();
7660
7661 No more objects, gonna specify values for the list of objects now. */
7662
7663 void
ffestc_R528_item_startvals()7664 ffestc_R528_item_startvals ()
7665 {
7666 ffestc_check_item_startvals_ ();
7667 if (!ffestc_ok_)
7668 return;
7669
7670 #if 1
7671 assert (ffestc_local_.data.objlist != NULL);
7672 ffebld_end_list (&ffestc_local_.data.list_bottom);
7673 ffedata_begin (ffestc_local_.data.objlist);
7674 #else
7675 ffestd_R528_item_startvals_ ();
7676 #endif
7677 }
7678
7679 /* ffestc_R528_item_value -- DATA statement source value
7680
7681 ffestc_R528_item_value(repeat,repeat_token,value,value_token);
7682
7683 Make sure repeat and value are valid for the objects being initialized. */
7684
7685 void
ffestc_R528_item_value(ffebld repeat,ffelexToken repeat_token,ffebld value,ffelexToken value_token)7686 ffestc_R528_item_value (ffebld repeat, ffelexToken repeat_token,
7687 ffebld value, ffelexToken value_token)
7688 {
7689 ffetargetIntegerDefault rpt;
7690
7691 ffestc_check_item_value_ ();
7692 if (!ffestc_ok_)
7693 return;
7694
7695 #if 1
7696 if (repeat == NULL)
7697 rpt = 1;
7698 else if (ffebld_op (repeat) == FFEBLD_opCONTER)
7699 rpt = ffebld_constant_integerdefault (ffebld_conter (repeat));
7700 else
7701 {
7702 ffestc_ok_ = FALSE;
7703 ffedata_end (TRUE, NULL);
7704 return;
7705 }
7706
7707 if (!(ffestc_ok_ = ffedata_value (rpt, value,
7708 (repeat_token == NULL)
7709 ? value_token
7710 : repeat_token)))
7711 ffedata_end (TRUE, NULL);
7712
7713 #else
7714 ffestd_R528_item_value_ (repeat, value);
7715 #endif
7716 }
7717
7718 /* ffestc_R528_item_endvals -- DATA statement start list of values
7719
7720 ffelexToken t; // the SLASH token that ends the list.
7721 ffestc_R528_item_endvals(t);
7722
7723 No more values, might specify more objects now. */
7724
7725 void
ffestc_R528_item_endvals(ffelexToken t)7726 ffestc_R528_item_endvals (ffelexToken t)
7727 {
7728 ffestc_check_item_endvals_ ();
7729 if (!ffestc_ok_)
7730 return;
7731
7732 #if 1
7733 ffedata_end (!ffestc_ok_, t);
7734 ffestc_local_.data.objlist = NULL;
7735 #else
7736 ffestd_R528_item_endvals_ (t);
7737 #endif
7738 }
7739
7740 /* ffestc_R528_finish -- DATA statement list complete
7741
7742 ffestc_R528_finish();
7743
7744 Just wrap up any local activities. */
7745
7746 void
ffestc_R528_finish()7747 ffestc_R528_finish ()
7748 {
7749 ffestc_check_finish_ ();
7750
7751 #if 1
7752 #else
7753 ffestd_R528_finish_ ();
7754 #endif
7755 }
7756
7757 /* ffestc_R537_start -- PARAMETER statement list begin
7758
7759 ffestc_R537_start();
7760
7761 Verify that PARAMETER is valid here, and begin accepting items in the
7762 list. */
7763
7764 void
ffestc_R537_start()7765 ffestc_R537_start ()
7766 {
7767 ffestc_check_start_ ();
7768 if (ffestc_order_parameter_ () != FFESTC_orderOK_)
7769 {
7770 ffestc_ok_ = FALSE;
7771 return;
7772 }
7773 ffestc_labeldef_useless_ ();
7774
7775 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
7776
7777 ffestd_R537_start ();
7778
7779 ffestc_ok_ = TRUE;
7780 }
7781
7782 /* ffestc_R537_item -- PARAMETER statement assignment
7783
7784 ffestc_R537_item(dest,dest_token,source,source_token);
7785
7786 Make sure the source is a valid source for the destination; make the
7787 assignment. */
7788
7789 void
ffestc_R537_item(ffebld dest,ffelexToken dest_token,ffebld source,ffelexToken source_token)7790 ffestc_R537_item (ffebld dest, ffelexToken dest_token, ffebld source,
7791 ffelexToken source_token)
7792 {
7793 ffesymbol s;
7794
7795 ffestc_check_item_ ();
7796 if (!ffestc_ok_)
7797 return;
7798
7799 if ((ffebld_op (dest) == FFEBLD_opANY)
7800 || (ffebld_op (source) == FFEBLD_opANY))
7801 {
7802 if (ffebld_op (dest) == FFEBLD_opSYMTER)
7803 {
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);
7808 }
7809 ffestd_R537_item (dest, source);
7810 return;
7811 }
7812
7813 assert (ffebld_op (dest) == FFEBLD_opSYMTER);
7814 assert (ffebld_op (source) == FFEBLD_opCONTER);
7815
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),
7824 0,
7825 ffesymbol_kind (s),
7826 ffesymbol_where (s),
7827 ffebld_size (source)));
7828 ffebld_set_info (dest, ffeinfo_use (ffesymbol_info (s)));
7829 }
7830
7831 source = ffeexpr_convert_expr (source, source_token, dest, dest_token,
7832 FFEEXPR_contextDATA);
7833
7834 ffesymbol_set_init (s, source);
7835
7836 ffesymbol_signal_unreported (s);
7837
7838 ffestd_R537_item (dest, source);
7839 }
7840
7841 /* ffestc_R537_finish -- PARAMETER statement list complete
7842
7843 ffestc_R537_finish();
7844
7845 Just wrap up any local activities. */
7846
7847 void
ffestc_R537_finish()7848 ffestc_R537_finish ()
7849 {
7850 ffestc_check_finish_ ();
7851 if (!ffestc_ok_)
7852 return;
7853
7854 ffestd_R537_finish ();
7855 }
7856
7857 /* ffestc_R539 -- IMPLICIT NONE statement
7858
7859 ffestc_R539();
7860
7861 Verify that the IMPLICIT NONE statement is ok here and implement. */
7862
7863 void
ffestc_R539()7864 ffestc_R539 ()
7865 {
7866 ffestc_check_simple_ ();
7867 if (ffestc_order_implicitnone_ () != FFESTC_orderOK_)
7868 return;
7869 ffestc_labeldef_useless_ ();
7870
7871 ffeimplic_none ();
7872
7873 ffestd_R539 ();
7874 }
7875
7876 /* ffestc_R539start -- IMPLICIT statement
7877
7878 ffestc_R539start();
7879
7880 Verify that the IMPLICIT statement is ok here and implement. */
7881
7882 void
ffestc_R539start()7883 ffestc_R539start ()
7884 {
7885 ffestc_check_start_ ();
7886 if (ffestc_order_implicit_ () != FFESTC_orderOK_)
7887 {
7888 ffestc_ok_ = FALSE;
7889 return;
7890 }
7891 ffestc_labeldef_useless_ ();
7892
7893 ffestd_R539start ();
7894
7895 ffestc_ok_ = TRUE;
7896 }
7897
7898 /* ffestc_R539item -- IMPLICIT statement specification (R540)
7899
7900 ffestc_R539item(...);
7901
7902 Verify that the type and letter list are all ok and implement. */
7903
7904 void
ffestc_R539item(ffestpType type,ffebld kind,ffelexToken kindt,ffebld len,ffelexToken lent,ffesttImpList letters)7905 ffestc_R539item (ffestpType type, ffebld kind, ffelexToken kindt,
7906 ffebld len, ffelexToken lent, ffesttImpList letters)
7907 {
7908 ffestc_check_item_ ();
7909 if (!ffestc_ok_)
7910 return;
7911
7912 if ((type == FFESTP_typeCHARACTER) && (len != NULL)
7913 && (ffebld_op (len) == FFEBLD_opSTAR))
7914 { /* Complain and pretend they're CHARACTER
7915 [*1]. */
7916 ffebad_start (FFEBAD_IMPLICIT_ADJLEN);
7917 ffebad_here (0, ffelex_token_where_line (lent),
7918 ffelex_token_where_column (lent));
7919 ffebad_finish ();
7920 len = NULL;
7921 lent = NULL;
7922 }
7923 ffestc_establish_declstmt_ (type, ffesta_tokens[0], kind, kindt, len, lent);
7924 ffestc_establish_declinfo_ (NULL, NULL, NULL, NULL);
7925
7926 ffestt_implist_drive (letters, ffestc_establish_impletter_);
7927
7928 ffestd_R539item (type, kind, kindt, len, lent, letters);
7929 }
7930
7931 /* ffestc_R539finish -- IMPLICIT statement
7932
7933 ffestc_R539finish();
7934
7935 Finish up any local activities. */
7936
7937 void
ffestc_R539finish()7938 ffestc_R539finish ()
7939 {
7940 ffestc_check_finish_ ();
7941 if (!ffestc_ok_)
7942 return;
7943
7944 ffestd_R539finish ();
7945 }
7946
7947 /* ffestc_R542_start -- NAMELIST statement list begin
7948
7949 ffestc_R542_start();
7950
7951 Verify that NAMELIST is valid here, and begin accepting items in the
7952 list. */
7953
7954 void
ffestc_R542_start()7955 ffestc_R542_start ()
7956 {
7957 ffestc_check_start_ ();
7958 if (ffestc_order_progspec_ () != FFESTC_orderOK_)
7959 {
7960 ffestc_ok_ = FALSE;
7961 return;
7962 }
7963 ffestc_labeldef_useless_ ();
7964
7965 if (ffe_is_f2c_library ()
7966 && (ffe_case_source () == FFE_caseNONE))
7967 {
7968 ffebad_start (FFEBAD_NAMELIST_CASE);
7969 ffesta_ffebad_here_current_stmt (0);
7970 ffebad_finish ();
7971 }
7972
7973 ffestd_R542_start ();
7974
7975 ffestc_local_.namelist.symbol = NULL;
7976
7977 ffestc_ok_ = TRUE;
7978 }
7979
7980 /* ffestc_R542_item_nlist -- NAMELIST statement for group-name
7981
7982 ffestc_R542_item_nlist(groupname_token);
7983
7984 Make sure name_token identifies a valid object to be NAMELISTd. */
7985
7986 void
ffestc_R542_item_nlist(ffelexToken name)7987 ffestc_R542_item_nlist (ffelexToken name)
7988 {
7989 ffesymbol s;
7990
7991 ffestc_check_item_ ();
7992 assert (name != NULL);
7993 if (!ffestc_ok_)
7994 return;
7995
7996 if (ffestc_local_.namelist.symbol != NULL)
7997 ffesymbol_signal_unreported (ffestc_local_.namelist.symbol);
7998
7999 s = ffesymbol_declare_local (name, FALSE);
8000
8001 if ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
8002 || ((ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
8003 && (ffesymbol_kind (s) == FFEINFO_kindNAMELIST)))
8004 {
8005 ffestc_parent_ok_ = TRUE;
8006 if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
8007 {
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,
8014 0,
8015 FFEINFO_kindNAMELIST,
8016 FFEINFO_whereLOCAL,
8017 FFETARGET_charactersizeNONE));
8018 }
8019 }
8020 else
8021 {
8022 if (ffesymbol_kind (s) != FFEINFO_kindANY)
8023 ffesymbol_error (s, name);
8024 ffestc_parent_ok_ = FALSE;
8025 }
8026
8027 ffestc_local_.namelist.symbol = s;
8028
8029 ffestd_R542_item_nlist (name);
8030 }
8031
8032 /* ffestc_R542_item_nitem -- NAMELIST statement for variable-name
8033
8034 ffestc_R542_item_nitem(name_token);
8035
8036 Make sure name_token identifies a valid object to be NAMELISTd. */
8037
8038 void
ffestc_R542_item_nitem(ffelexToken name)8039 ffestc_R542_item_nitem (ffelexToken name)
8040 {
8041 ffesymbol s;
8042 ffesymbolAttrs sa;
8043 ffesymbolAttrs na;
8044 ffebld e;
8045
8046 ffestc_check_item_ ();
8047 assert (name != NULL);
8048 if (!ffestc_ok_)
8049 return;
8050
8051 s = ffesymbol_declare_local (name, FALSE);
8052 sa = ffesymbol_attrs (s);
8053
8054 /* Figure out what kind of object we've got based on previous declarations
8055 of or references to the object. */
8056
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;
8074 else
8075 na = FFESYMBOL_attrsetNONE;
8076
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. */
8080
8081 if (na == FFESYMBOL_attrsetNONE)
8082 ffesymbol_error (s, name);
8083 else if (!(na & FFESYMBOL_attrsANY))
8084 {
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);
8093 #endif
8094 }
8095
8096 if (ffestc_parent_ok_)
8097 {
8098 e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
8099 FFEINTRIN_impNONE);
8100 ffebld_set_info (e,
8101 ffeinfo_new (FFEINFO_basictypeNONE,
8102 FFEINFO_kindtypeNONE, 0,
8103 FFEINFO_kindNONE,
8104 FFEINFO_whereNONE,
8105 FFETARGET_charactersizeNONE));
8106 ffebld_append_item
8107 (ffesymbol_ptr_to_listbottom (ffestc_local_.namelist.symbol), e);
8108 }
8109
8110 ffestd_R542_item_nitem (name);
8111 }
8112
8113 /* ffestc_R542_finish -- NAMELIST statement list complete
8114
8115 ffestc_R542_finish();
8116
8117 Just wrap up any local activities. */
8118
8119 void
ffestc_R542_finish()8120 ffestc_R542_finish ()
8121 {
8122 ffestc_check_finish_ ();
8123 if (!ffestc_ok_)
8124 return;
8125
8126 ffesymbol_signal_unreported (ffestc_local_.namelist.symbol);
8127
8128 ffestd_R542_finish ();
8129 }
8130
8131 /* ffestc_R544_start -- EQUIVALENCE statement list begin
8132
8133 ffestc_R544_start();
8134
8135 Verify that EQUIVALENCE is valid here, and begin accepting items in the
8136 list. */
8137
8138 void
ffestc_R544_start()8139 ffestc_R544_start ()
8140 {
8141 ffestc_check_start_ ();
8142 if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
8143 {
8144 ffestc_ok_ = FALSE;
8145 return;
8146 }
8147 ffestc_labeldef_useless_ ();
8148
8149 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
8150
8151 ffestc_ok_ = TRUE;
8152 }
8153
8154 /* ffestc_R544_item -- EQUIVALENCE statement assignment
8155
8156 ffestc_R544_item(exprlist);
8157
8158 Make sure the equivalence is valid, then implement it. */
8159
8160 void
ffestc_R544_item(ffesttExprList exprlist)8161 ffestc_R544_item (ffesttExprList exprlist)
8162 {
8163 ffestc_check_item_ ();
8164 if (!ffestc_ok_)
8165 return;
8166
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. */
8173
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. */
8178
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);
8182
8183 if (!ffestc_local_.equiv.ok)
8184 return; /* Something went wrong, stop bothering with
8185 this stuff. */
8186
8187 if (ffestc_local_.equiv.eq == NULL)
8188 ffestc_local_.equiv.eq = ffeequiv_new (); /* Make local equivalence. */
8189
8190 /* Append this list of equivalences to list of such lists for this
8191 equivalence. */
8192
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);
8197 }
8198
8199 /* ffestc_R544_equiv_ -- EQUIVALENCE statement handler for item in list
8200
8201 ffebld expr;
8202 ffelexToken t;
8203 ffestc_R544_equiv_(expr,t);
8204
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. */
8208
8209 static void
ffestc_R544_equiv_(ffebld expr,ffelexToken t)8210 ffestc_R544_equiv_ (ffebld expr, ffelexToken t)
8211 {
8212 ffesymbol s;
8213
8214 if (!ffestc_local_.equiv.ok)
8215 return;
8216
8217 if (ffestc_local_.equiv.t == NULL)
8218 ffestc_local_.equiv.t = t;
8219
8220 switch (ffebld_op (expr))
8221 {
8222 case FFEBLD_opANY:
8223 return; /* Don't put this on the list. */
8224
8225 case FFEBLD_opSYMTER:
8226 case FFEBLD_opARRAYREF:
8227 case FFEBLD_opSUBSTR:
8228 break; /* All of these are ok. */
8229
8230 default:
8231 assert ("ffestc_R544_equiv_ bad op" == NULL);
8232 return;
8233 }
8234
8235 ffebld_append_item (&ffestc_local_.equiv.bottom, expr);
8236
8237 s = ffeequiv_symbol (expr);
8238
8239 /* See if symbol has an equivalence object already. */
8240
8241 if (ffesymbol_equiv (s) != NULL)
8242 {
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))
8246 {
8247 ffestc_local_.equiv.eq = ffeequiv_merge (ffesymbol_equiv (s),
8248 ffestc_local_.equiv.eq,
8249 t);
8250 if (ffestc_local_.equiv.eq == NULL)
8251 ffestc_local_.equiv.ok = FALSE; /* Couldn't merge. */
8252 }
8253 }
8254
8255 if (ffesymbol_is_save (s))
8256 ffestc_local_.equiv.save = TRUE;
8257 }
8258
8259 /* ffestc_R544_finish -- EQUIVALENCE statement list complete
8260
8261 ffestc_R544_finish();
8262
8263 Just wrap up any local activities. */
8264
8265 void
ffestc_R544_finish()8266 ffestc_R544_finish ()
8267 {
8268 ffestc_check_finish_ ();
8269 }
8270
8271 /* ffestc_R547_start -- COMMON statement list begin
8272
8273 ffestc_R547_start();
8274
8275 Verify that COMMON is valid here, and begin accepting items in the list. */
8276
8277 void
ffestc_R547_start()8278 ffestc_R547_start ()
8279 {
8280 ffestc_check_start_ ();
8281 if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
8282 {
8283 ffestc_ok_ = FALSE;
8284 return;
8285 }
8286 ffestc_labeldef_useless_ ();
8287
8288 ffestc_local_.common.symbol = NULL; /* Blank common is the default. */
8289 ffestc_parent_ok_ = TRUE;
8290
8291 ffestd_R547_start ();
8292
8293 ffestc_ok_ = TRUE;
8294 }
8295
8296 /* ffestc_R547_item_object -- COMMON statement for object-name
8297
8298 ffestc_R547_item_object(name_token,dim_list);
8299
8300 Make sure name_token identifies a valid object to be COMMONd. */
8301
8302 void
ffestc_R547_item_object(ffelexToken name,ffesttDimList dims)8303 ffestc_R547_item_object (ffelexToken name, ffesttDimList dims)
8304 {
8305 ffesymbol s;
8306 ffebld array_size;
8307 ffebld extents;
8308 ffesymbolAttrs sa;
8309 ffesymbolAttrs na;
8310 ffestpDimtype nd;
8311 ffebld e;
8312 ffeinfoRank rank;
8313 bool is_ugly_assumed;
8314
8315 if (ffestc_parent_ok_ && (ffestc_local_.common.symbol == NULL))
8316 ffestc_R547_item_cblock (NULL); /* As if "COMMON [//] ...". */
8317
8318 ffestc_check_item_ ();
8319 assert (name != NULL);
8320 if (!ffestc_ok_)
8321 return;
8322
8323 if (dims != NULL)
8324 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
8325
8326 s = ffesymbol_declare_local (name, FALSE);
8327 sa = ffesymbol_attrs (s);
8328
8329 /* First figure out what kind of object this is based solely on the current
8330 object situation (dimension list). */
8331
8332 is_ugly_assumed = (ffe_is_ugly_assumed ()
8333 && ((sa & FFESYMBOL_attrsDUMMY)
8334 || (ffesymbol_where (s) == FFEINFO_whereDUMMY)));
8335
8336 nd = ffestt_dimlist_type (dims, is_ugly_assumed);
8337 switch (nd)
8338 {
8339 case FFESTP_dimtypeNONE:
8340 na = FFESYMBOL_attrsCOMMON;
8341 break;
8342
8343 case FFESTP_dimtypeKNOWN:
8344 na = FFESYMBOL_attrsCOMMON | FFESYMBOL_attrsARRAY;
8345 break;
8346
8347 default:
8348 na = FFESYMBOL_attrsetNONE;
8349 break;
8350 }
8351
8352 /* Figure out what kind of object we've got based on previous declarations
8353 of or references to the object. */
8354
8355 if (na == FFESYMBOL_attrsetNONE)
8356 ;
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)))
8374 na |= sa;
8375 else
8376 na = FFESYMBOL_attrsetNONE;
8377
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. */
8381
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))
8388 {
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))));
8395 ffebad_finish ();
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);
8400 }
8401 else if (!(na & FFESYMBOL_attrsANY))
8402 {
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);
8409 #endif
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
8414 an equivalence? */
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);
8421 #endif
8422 if (ffesymbol_is_save (ffestc_local_.common.symbol))
8423 ffeequiv_update_save (ffesymbol_equiv (s));
8424 }
8425 if (dims != NULL)
8426 {
8427 ffesymbol_set_dims (s, ffestt_dimlist_as_expr (dims, &rank,
8428 &array_size,
8429 &extents,
8430 is_ugly_assumed));
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))
8436 == 0))
8437 {
8438 ffebad_start (FFEBAD_ZERO_ARRAY);
8439 ffebad_here (0, ffelex_token_where_line (name),
8440 ffelex_token_where_column (name));
8441 ffebad_finish ();
8442 }
8443 ffesymbol_set_info (s,
8444 ffeinfo_new (ffesymbol_basictype (s),
8445 ffesymbol_kindtype (s),
8446 rank,
8447 ffesymbol_kind (s),
8448 ffesymbol_where (s),
8449 ffesymbol_size (s)));
8450 }
8451 ffesymbol_signal_unreported (s);
8452 }
8453
8454 if (ffestc_parent_ok_)
8455 {
8456 e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
8457 FFEINTRIN_impNONE);
8458 ffebld_set_info (e,
8459 ffeinfo_new (FFEINFO_basictypeNONE,
8460 FFEINFO_kindtypeNONE,
8461 0,
8462 FFEINFO_kindNONE,
8463 FFEINFO_whereNONE,
8464 FFETARGET_charactersizeNONE));
8465 ffebld_append_item
8466 (ffesymbol_ptr_to_listbottom (ffestc_local_.common.symbol), e);
8467 }
8468
8469 ffestd_R547_item_object (name, dims);
8470 }
8471
8472 /* ffestc_R547_item_cblock -- COMMON statement for common-block-name
8473
8474 ffestc_R547_item_cblock(name_token);
8475
8476 Make sure name_token identifies a valid common block to be COMMONd. */
8477
8478 void
ffestc_R547_item_cblock(ffelexToken name)8479 ffestc_R547_item_cblock (ffelexToken name)
8480 {
8481 ffesymbol s;
8482 ffesymbolAttrs sa;
8483 ffesymbolAttrs na;
8484
8485 ffestc_check_item_ ();
8486 if (!ffestc_ok_)
8487 return;
8488
8489 if (ffestc_local_.common.symbol != NULL)
8490 ffesymbol_signal_unreported (ffestc_local_.common.symbol);
8491
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);
8496
8497 /* Figure out what kind of object we've got based on previous declarations
8498 of or references to the object. */
8499
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)))
8506 {
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;
8511 }
8512 else
8513 na = FFESYMBOL_attrsetNONE;
8514
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. */
8518
8519 if (na == FFESYMBOL_attrsetNONE)
8520 {
8521 ffesymbol_error (s, name == NULL ? ffesta_tokens[0] : name);
8522 ffestc_parent_ok_ = FALSE;
8523 }
8524 else if (na & FFESYMBOL_attrsANY)
8525 ffestc_parent_ok_ = FALSE;
8526 else
8527 {
8528 ffesymbol_set_attrs (s, na);
8529 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
8530 if (name == NULL)
8531 ffesymbol_update_save (s);
8532 ffestc_parent_ok_ = TRUE;
8533 }
8534
8535 ffestc_local_.common.symbol = s;
8536
8537 ffestd_R547_item_cblock (name);
8538 }
8539
8540 /* ffestc_R547_finish -- COMMON statement list complete
8541
8542 ffestc_R547_finish();
8543
8544 Just wrap up any local activities. */
8545
8546 void
ffestc_R547_finish()8547 ffestc_R547_finish ()
8548 {
8549 ffestc_check_finish_ ();
8550 if (!ffestc_ok_)
8551 return;
8552
8553 if (ffestc_local_.common.symbol != NULL)
8554 ffesymbol_signal_unreported (ffestc_local_.common.symbol);
8555
8556 ffestd_R547_finish ();
8557 }
8558
8559 /* ffestc_R620 -- ALLOCATE statement
8560
8561 ffestc_R620(exprlist,stat,stat_token);
8562
8563 Make sure the expression list is valid, then implement it. */
8564
8565 #if FFESTR_F90
8566 void
ffestc_R620(ffesttExprList exprlist,ffebld stat,ffelexToken stat_token)8567 ffestc_R620 (ffesttExprList exprlist, ffebld stat, ffelexToken stat_token)
8568 {
8569 ffestc_check_simple_ ();
8570 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
8571 return;
8572 ffestc_labeldef_branch_begin_ ();
8573
8574 ffestd_R620 (exprlist, stat);
8575
8576 if (ffestc_shriek_after1_ != NULL)
8577 (*ffestc_shriek_after1_) (TRUE);
8578 ffestc_labeldef_branch_end_ ();
8579 }
8580
8581 /* ffestc_R624 -- NULLIFY statement
8582
8583 ffestc_R624(pointer_name_list);
8584
8585 Make sure pointer_name_list identifies valid pointers for a NULLIFY. */
8586
8587 void
ffestc_R624(ffesttExprList pointers)8588 ffestc_R624 (ffesttExprList pointers)
8589 {
8590 ffestc_check_simple_ ();
8591 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
8592 return;
8593 ffestc_labeldef_branch_begin_ ();
8594
8595 ffestd_R624 (pointers);
8596
8597 if (ffestc_shriek_after1_ != NULL)
8598 (*ffestc_shriek_after1_) (TRUE);
8599 ffestc_labeldef_branch_end_ ();
8600 }
8601
8602 /* ffestc_R625 -- DEALLOCATE statement
8603
8604 ffestc_R625(exprlist,stat,stat_token);
8605
8606 Make sure the equivalence is valid, then implement it. */
8607
8608 void
ffestc_R625(ffesttExprList exprlist,ffebld stat,ffelexToken stat_token)8609 ffestc_R625 (ffesttExprList exprlist, ffebld stat, ffelexToken stat_token)
8610 {
8611 ffestc_check_simple_ ();
8612 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
8613 return;
8614 ffestc_labeldef_branch_begin_ ();
8615
8616 ffestd_R625 (exprlist, stat);
8617
8618 if (ffestc_shriek_after1_ != NULL)
8619 (*ffestc_shriek_after1_) (TRUE);
8620 ffestc_labeldef_branch_end_ ();
8621 }
8622
8623 #endif
8624 /* ffestc_let -- R1213 or R737
8625
8626 ffestc_let(...);
8627
8628 Verify that R1213 defined-assignment or R737 assignment-stmt are
8629 valid here, figure out which one, and implement. */
8630
8631 #if FFESTR_F90
8632 void
ffestc_let(ffebld dest,ffebld source,ffelexToken source_token)8633 ffestc_let (ffebld dest, ffebld source, ffelexToken source_token)
8634 {
8635 ffestc_R737 (dest, source, source_token);
8636 }
8637
8638 #endif
8639 /* ffestc_R737 -- Assignment statement
8640
8641 ffestc_R737(dest_expr,source_expr,source_token);
8642
8643 Make sure the assignment is valid. */
8644
8645 void
ffestc_R737(ffebld dest,ffebld source,ffelexToken source_token)8646 ffestc_R737 (ffebld dest, ffebld source, ffelexToken source_token)
8647 {
8648 ffestc_check_simple_ ();
8649
8650 switch (ffestw_state (ffestw_stack_top ()))
8651 {
8652 #if FFESTR_F90
8653 case FFESTV_stateWHERE:
8654 case FFESTV_stateWHERETHEN:
8655 if (ffestc_order_actionwhere_ () != FFESTC_orderOK_)
8656 return;
8657 ffestc_labeldef_useless_ ();
8658
8659 ffestd_R737B (dest, source);
8660
8661 if (ffestc_shriek_after1_ != NULL)
8662 (*ffestc_shriek_after1_) (TRUE);
8663 return;
8664 #endif
8665
8666 default:
8667 break;
8668 }
8669
8670 if (ffestc_order_actionwhere_ () != FFESTC_orderOK_)
8671 return;
8672 ffestc_labeldef_branch_begin_ ();
8673
8674 source = ffeexpr_convert_expr (source, source_token, dest, ffesta_tokens[0],
8675 FFEEXPR_contextLET);
8676
8677 ffestd_R737A (dest, source);
8678
8679 if (ffestc_shriek_after1_ != NULL)
8680 (*ffestc_shriek_after1_) (TRUE);
8681 ffestc_labeldef_branch_end_ ();
8682 }
8683
8684 /* ffestc_R738 -- Pointer assignment statement
8685
8686 ffestc_R738(dest_expr,source_expr,source_token);
8687
8688 Make sure the assignment is valid. */
8689
8690 #if FFESTR_F90
8691 void
ffestc_R738(ffebld dest,ffebld source,ffelexToken source_token)8692 ffestc_R738 (ffebld dest, ffebld source, ffelexToken source_token)
8693 {
8694 ffestc_check_simple_ ();
8695 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
8696 return;
8697 ffestc_labeldef_branch_begin_ ();
8698
8699 ffestd_R738 (dest, source);
8700
8701 if (ffestc_shriek_after1_ != NULL)
8702 (*ffestc_shriek_after1_) (TRUE);
8703 ffestc_labeldef_branch_end_ ();
8704 }
8705
8706 /* ffestc_R740 -- WHERE statement
8707
8708 ffestc_R740(expr,expr_token);
8709
8710 Make sure statement is valid here; implement. */
8711
8712 void
ffestc_R740(ffebld expr,ffelexToken expr_token)8713 ffestc_R740 (ffebld expr, ffelexToken expr_token)
8714 {
8715 ffestw b;
8716
8717 ffestc_check_simple_ ();
8718 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
8719 return;
8720 ffestc_labeldef_branch_begin_ ();
8721
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_);
8727
8728 ffestd_R740 (expr);
8729
8730 /* Leave label finishing to next statement. */
8731
8732 }
8733
8734 /* ffestc_R742 -- WHERE-construct statement
8735
8736 ffestc_R742(expr,expr_token);
8737
8738 Make sure statement is valid here; implement. */
8739
8740 void
ffestc_R742(ffebld expr,ffelexToken expr_token)8741 ffestc_R742 (ffebld expr, ffelexToken expr_token)
8742 {
8743 ffestw b;
8744
8745 ffestc_check_simple_ ();
8746 if (ffestc_order_exec_ () != FFESTC_orderOK_)
8747 return;
8748 ffestc_labeldef_notloop_probably_this_wont_work_ ();
8749
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. */
8756
8757 ffestd_R742 (expr);
8758 }
8759
8760 /* ffestc_R744 -- ELSE WHERE statement
8761
8762 ffestc_R744();
8763
8764 Make sure ffestc_kind_ identifies a WHERE block.
8765 Implement the ELSE of the current WHERE block. */
8766
8767 void
ffestc_R744()8768 ffestc_R744 ()
8769 {
8770 ffestc_check_simple_ ();
8771 if (ffestc_order_where_ () != FFESTC_orderOK_)
8772 return;
8773 ffestc_labeldef_useless_ ();
8774
8775 if (ffestw_substate (ffestw_stack_top ()) != 0)
8776 {
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 ()));
8781 ffebad_finish ();
8782 }
8783
8784 ffestw_set_substate (ffestw_stack_top (), 1); /* Saw ELSEWHERE. */
8785
8786 ffestd_R744 ();
8787 }
8788
8789 /* ffestc_R745 -- END WHERE statement
8790
8791 ffestc_R745();
8792
8793 Make sure ffestc_kind_ identifies a WHERE block.
8794 Implement the end of the current WHERE block. */
8795
8796 void
ffestc_R745()8797 ffestc_R745 ()
8798 {
8799 ffestc_check_simple_ ();
8800 if (ffestc_order_where_ () != FFESTC_orderOK_)
8801 return;
8802 ffestc_labeldef_useless_ ();
8803
8804 ffestc_shriek_wherethen_ (TRUE);
8805 }
8806
8807 #endif
8808 /* ffestc_R803 -- Block IF (IF-THEN) statement
8809
8810 ffestc_R803(construct_name,expr,expr_token);
8811
8812 Make sure statement is valid here; implement. */
8813
8814 void
ffestc_R803(ffelexToken construct_name,ffebld expr,ffelexToken expr_token UNUSED)8815 ffestc_R803 (ffelexToken construct_name, ffebld expr,
8816 ffelexToken expr_token UNUSED)
8817 {
8818 ffestw b;
8819 ffesymbol s;
8820
8821 ffestc_check_simple_ ();
8822 if (ffestc_order_exec_ () != FFESTC_orderOK_)
8823 return;
8824 ffestc_labeldef_notloop_ ();
8825
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. */
8832
8833 if (construct_name == NULL)
8834 ffestw_set_name (b, NULL);
8835 else
8836 {
8837 ffestw_set_name (b, ffelex_token_use (construct_name));
8838
8839 s = ffesymbol_declare_local (construct_name, FALSE);
8840
8841 if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
8842 {
8843 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
8844 ffesymbol_set_info (s,
8845 ffeinfo_new (FFEINFO_basictypeNONE,
8846 FFEINFO_kindtypeNONE,
8847 0,
8848 FFEINFO_kindCONSTRUCT,
8849 FFEINFO_whereLOCAL,
8850 FFETARGET_charactersizeNONE));
8851 s = ffecom_sym_learned (s);
8852 ffesymbol_signal_unreported (s);
8853 }
8854 else
8855 ffesymbol_error (s, construct_name);
8856 }
8857
8858 ffestd_R803 (construct_name, expr);
8859 }
8860
8861 /* ffestc_R804 -- ELSE IF statement
8862
8863 ffestc_R804(expr,expr_token,name_token);
8864
8865 Make sure ffestc_kind_ identifies an IF block. If not
8866 NULL, make sure name_token gives the correct name. Implement the else
8867 of the IF block. */
8868
8869 void
ffestc_R804(ffebld expr,ffelexToken expr_token UNUSED,ffelexToken name)8870 ffestc_R804 (ffebld expr, ffelexToken expr_token UNUSED,
8871 ffelexToken name)
8872 {
8873 ffestc_check_simple_ ();
8874 if (ffestc_order_ifthen_ () != FFESTC_orderOK_)
8875 return;
8876 ffestc_labeldef_useless_ ();
8877
8878 if (name != NULL)
8879 {
8880 if (ffestw_name (ffestw_stack_top ()) == NULL)
8881 {
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 ()));
8886 ffebad_finish ();
8887 }
8888 else if (ffelex_token_strcmp (name,
8889 ffestw_name (ffestw_stack_top ()))
8890 != 0)
8891 {
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 ())));
8897 ffebad_finish ();
8898 }
8899 }
8900
8901 if (ffestw_substate (ffestw_stack_top ()) != 0)
8902 {
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 ()));
8907 ffebad_finish ();
8908 return; /* Don't upset back end with ELSEIF
8909 after ELSE. */
8910 }
8911
8912 ffestd_R804 (expr, name);
8913 }
8914
8915 /* ffestc_R805 -- ELSE statement
8916
8917 ffestc_R805(name_token);
8918
8919 Make sure ffestc_kind_ identifies an IF block. If not
8920 NULL, make sure name_token gives the correct name. Implement the ELSE
8921 of the IF block. */
8922
8923 void
ffestc_R805(ffelexToken name)8924 ffestc_R805 (ffelexToken name)
8925 {
8926 ffestc_check_simple_ ();
8927 if (ffestc_order_ifthen_ () != FFESTC_orderOK_)
8928 return;
8929 ffestc_labeldef_useless_ ();
8930
8931 if (name != NULL)
8932 {
8933 if (ffestw_name (ffestw_stack_top ()) == NULL)
8934 {
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 ()));
8939 ffebad_finish ();
8940 }
8941 else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)
8942 {
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 ())));
8948 ffebad_finish ();
8949 }
8950 }
8951
8952 if (ffestw_substate (ffestw_stack_top ()) != 0)
8953 {
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 ()));
8958 ffebad_finish ();
8959 return; /* Tell back end about only one ELSE. */
8960 }
8961
8962 ffestw_set_substate (ffestw_stack_top (), 1); /* Saw ELSE. */
8963
8964 ffestd_R805 (name);
8965 }
8966
8967 /* ffestc_R806 -- END IF statement
8968
8969 ffestc_R806(name_token);
8970
8971 Make sure ffestc_kind_ identifies an IF block. If not
8972 NULL, make sure name_token gives the correct name. Implement the end
8973 of the IF block. */
8974
8975 void
ffestc_R806(ffelexToken name)8976 ffestc_R806 (ffelexToken name)
8977 {
8978 ffestc_check_simple_ ();
8979 if (ffestc_order_ifthen_ () != FFESTC_orderOK_)
8980 return;
8981 ffestc_labeldef_endif_ ();
8982
8983 if (name == NULL)
8984 {
8985 if (ffestw_name (ffestw_stack_top ()) != NULL)
8986 {
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 ()));
8991 ffebad_finish ();
8992 }
8993 }
8994 else
8995 {
8996 if (ffestw_name (ffestw_stack_top ()) == NULL)
8997 {
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 ()));
9002 ffebad_finish ();
9003 }
9004 else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)
9005 {
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 ())));
9011 ffebad_finish ();
9012 }
9013 }
9014
9015 ffestc_shriek_ifthen_ (TRUE);
9016 }
9017
9018 /* ffestc_R807 -- Logical IF statement
9019
9020 ffestc_R807(expr,expr_token);
9021
9022 Make sure statement is valid here; implement. */
9023
9024 void
ffestc_R807(ffebld expr,ffelexToken expr_token UNUSED)9025 ffestc_R807 (ffebld expr, ffelexToken expr_token UNUSED)
9026 {
9027 ffestw b;
9028
9029 ffestc_check_simple_ ();
9030 if (ffestc_order_action_ () != FFESTC_orderOK_)
9031 return;
9032 ffestc_labeldef_branch_begin_ ();
9033
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_);
9039
9040 ffestd_R807 (expr);
9041
9042 /* Do the label finishing in the next statement. */
9043
9044 }
9045
9046 /* ffestc_R809 -- SELECT CASE statement
9047
9048 ffestc_R809(construct_name,expr,expr_token);
9049
9050 Make sure statement is valid here; implement. */
9051
9052 void
ffestc_R809(ffelexToken construct_name,ffebld expr,ffelexToken expr_token)9053 ffestc_R809 (ffelexToken construct_name, ffebld expr, ffelexToken expr_token)
9054 {
9055 ffestw b;
9056 mallocPool pool;
9057 ffestwSelect s;
9058 ffesymbol sym;
9059
9060 ffestc_check_simple_ ();
9061 if (ffestc_order_exec_ () != FFESTC_orderOK_)
9062 return;
9063 ffestc_labeldef_notloop_ ();
9064
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. */
9071
9072 /* Init block to manage CASE list. */
9073
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;
9080 s->pool = pool;
9081 s->cases = 1;
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);
9086
9087 if (construct_name == NULL)
9088 ffestw_set_name (b, NULL);
9089 else
9090 {
9091 ffestw_set_name (b, ffelex_token_use (construct_name));
9092
9093 sym = ffesymbol_declare_local (construct_name, FALSE);
9094
9095 if (ffesymbol_state (sym) == FFESYMBOL_stateNONE)
9096 {
9097 ffesymbol_set_state (sym, FFESYMBOL_stateUNDERSTOOD);
9098 ffesymbol_set_info (sym,
9099 ffeinfo_new (FFEINFO_basictypeNONE,
9100 FFEINFO_kindtypeNONE, 0,
9101 FFEINFO_kindCONSTRUCT,
9102 FFEINFO_whereLOCAL,
9103 FFETARGET_charactersizeNONE));
9104 sym = ffecom_sym_learned (sym);
9105 ffesymbol_signal_unreported (sym);
9106 }
9107 else
9108 ffesymbol_error (sym, construct_name);
9109 }
9110
9111 ffestd_R809 (construct_name, expr);
9112 }
9113
9114 /* ffestc_R810 -- CASE statement
9115
9116 ffestc_R810(case_value_range_list,name);
9117
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. */
9122
9123 void
ffestc_R810(ffesttCaseList cases,ffelexToken name)9124 ffestc_R810 (ffesttCaseList cases, ffelexToken name)
9125 {
9126 ffesttCaseList caseobj;
9127 ffestwSelect s;
9128 ffestwCase c, nc;
9129 ffebldConstant expr1c, expr2c;
9130
9131 ffestc_check_simple_ ();
9132 if (ffestc_order_selectcase_ () != FFESTC_orderOK_)
9133 return;
9134 ffestc_labeldef_useless_ ();
9135
9136 s = ffestw_select (ffestw_stack_top ());
9137
9138 if (ffestw_state (ffestw_stack_top ()) == FFESTV_stateSELECT0)
9139 {
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. */
9143 #endif
9144 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSELECT1);
9145 }
9146
9147 if (name != NULL)
9148 {
9149 if (ffestw_name (ffestw_stack_top ()) == NULL)
9150 {
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 ()));
9155 ffebad_finish ();
9156 }
9157 else if (ffelex_token_strcmp (name,
9158 ffestw_name (ffestw_stack_top ()))
9159 != 0)
9160 {
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 ())));
9166 ffebad_finish ();
9167 }
9168 }
9169
9170 if (cases == NULL)
9171 {
9172 if (ffestw_substate (ffestw_stack_top ()) != 0)
9173 {
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 ()));
9178 ffebad_finish ();
9179 }
9180
9181 ffestw_set_substate (ffestw_stack_top (), 1); /* Saw ELSE. */
9182 }
9183 else
9184 { /* For each case, try to fit into sorted list
9185 of ranges. */
9186 for (caseobj = cases->next; caseobj != cases; caseobj = caseobj->next)
9187 {
9188 if ((caseobj->expr1 == NULL)
9189 && (!caseobj->range
9190 || (caseobj->expr2 == NULL)))
9191 { /* "CASE (:)". */
9192 ffebad_start (FFEBAD_CASE_BAD_RANGE);
9193 ffebad_here (0, ffelex_token_where_line (caseobj->t),
9194 ffelex_token_where_column (caseobj->t));
9195 ffebad_finish ();
9196 continue;
9197 }
9198 if (((caseobj->expr1 != NULL)
9199 && ((ffeinfo_basictype (ffebld_info (caseobj->expr1))
9200 != s->type)
9201 || ((ffeinfo_kindtype (ffebld_info (caseobj->expr1))
9202 != s->kindtype)
9203 && (ffeinfo_kindtype (ffebld_info (caseobj->expr1)) != FFEINFO_kindtypeINTEGER1 ))
9204 || ((caseobj->range)
9205 && (caseobj->expr2 != NULL)
9206 && ((ffeinfo_basictype (ffebld_info (caseobj->expr2))
9207 != s->type)
9208 || ((ffeinfo_kindtype (ffebld_info (caseobj->expr2))
9209 != s->kindtype)
9210 && (ffeinfo_kindtype (ffebld_info (caseobj->expr2)) != FFEINFO_kindtypeINTEGER1)))))))
9211 {
9212 ffebad_start (FFEBAD_CASE_TYPE_DISAGREE);
9213 ffebad_here (0, ffelex_token_where_line (caseobj->t),
9214 ffelex_token_where_column (caseobj->t));
9215 ffebad_here (1, ffelex_token_where_line (s->t),
9216 ffelex_token_where_column (s->t));
9217 ffebad_finish ();
9218 continue;
9219 }
9220
9221
9222
9223 if ((s->type == FFEINFO_basictypeLOGICAL) && (caseobj->range))
9224 {
9225 ffebad_start (FFEBAD_CASE_LOGICAL_RANGE);
9226 ffebad_here (0, ffelex_token_where_line (caseobj->t),
9227 ffelex_token_where_column (caseobj->t));
9228 ffebad_finish ();
9229 continue;
9230 }
9231
9232 if (caseobj->expr1 == NULL)
9233 expr1c = NULL;
9234 else if (ffebld_op (caseobj->expr1) != FFEBLD_opCONTER)
9235 continue; /* opANY. */
9236 else
9237 expr1c = ffebld_conter (caseobj->expr1);
9238
9239 if (!caseobj->range)
9240 expr2c = expr1c; /* expr1c and expr2c are NOT NULL in this
9241 case. */
9242 else if (caseobj->expr2 == NULL)
9243 expr2c = NULL;
9244 else if (ffebld_op (caseobj->expr2) != FFEBLD_opCONTER)
9245 continue; /* opANY. */
9246 else
9247 expr2c = ffebld_conter (caseobj->expr2);
9248
9249 if (expr1c == NULL)
9250 { /* "CASE (:high)", must be first in list. */
9251 c = s->first_rel;
9252 if ((c != (ffestwCase) &s->first_rel)
9253 && ((c->low == NULL)
9254 || (ffebld_constant_cmp (expr2c, c->low) >= 0)))
9255 { /* Other "CASE (:high)" or lowest "CASE
9256 (low[:high])" low. */
9257 ffebad_start (FFEBAD_CASE_DUPLICATE);
9258 ffebad_here (0, ffelex_token_where_line (caseobj->t),
9259 ffelex_token_where_column (caseobj->t));
9260 ffebad_here (1, ffelex_token_where_line (c->t),
9261 ffelex_token_where_column (c->t));
9262 ffebad_finish ();
9263 continue;
9264 }
9265 }
9266 else if (expr2c == NULL)
9267 { /* "CASE (low:)", must be last in list. */
9268 c = s->last_rel;
9269 if ((c != (ffestwCase) &s->first_rel)
9270 && ((c->high == NULL)
9271 || (ffebld_constant_cmp (expr1c, c->high) <= 0)))
9272 { /* Other "CASE (low:)" or lowest "CASE
9273 ([low:]high)" high. */
9274 ffebad_start (FFEBAD_CASE_DUPLICATE);
9275 ffebad_here (0, ffelex_token_where_line (caseobj->t),
9276 ffelex_token_where_column (caseobj->t));
9277 ffebad_here (1, ffelex_token_where_line (c->t),
9278 ffelex_token_where_column (c->t));
9279 ffebad_finish ();
9280 continue;
9281 }
9282 c = c->next_rel; /* Same as c = (ffestwCase) &s->first;. */
9283 }
9284 else
9285 { /* (expr1c != NULL) && (expr2c != NULL). */
9286 if (ffebld_constant_cmp (expr1c, expr2c) > 0)
9287 { /* Such as "CASE (3:1)" or "CASE ('B':'A')". */
9288 ffebad_start (FFEBAD_CASE_RANGE_USELESS); /* Warn/inform only. */
9289 ffebad_here (0, ffelex_token_where_line (caseobj->t),
9290 ffelex_token_where_column (caseobj->t));
9291 ffebad_finish ();
9292 continue;
9293 }
9294 for (c = s->first_rel;
9295 (c != (ffestwCase) &s->first_rel)
9296 && ((c->low == NULL)
9297 || (ffebld_constant_cmp (expr1c, c->low) > 0));
9298 c = c->next_rel)
9299 ;
9300 nc = c; /* Which one to report? */
9301 if (((c != (ffestwCase) &s->first_rel)
9302 && (ffebld_constant_cmp (expr2c, c->low) >= 0))
9303 || (((nc = c->previous_rel) != (ffestwCase) &s->first_rel)
9304 && (ffebld_constant_cmp (expr1c, nc->high) <= 0)))
9305 { /* Interference with range in case nc. */
9306 ffebad_start (FFEBAD_CASE_DUPLICATE);
9307 ffebad_here (0, ffelex_token_where_line (caseobj->t),
9308 ffelex_token_where_column (caseobj->t));
9309 ffebad_here (1, ffelex_token_where_line (nc->t),
9310 ffelex_token_where_column (nc->t));
9311 ffebad_finish ();
9312 continue;
9313 }
9314 }
9315
9316 /* If we reach here for this case range/value, it's ok (sorts into
9317 the list of ranges/values) so we give it its own case object
9318 sorted into the list of case statements. */
9319
9320 nc = malloc_new_kp (s->pool, "Case range", sizeof (*nc));
9321 nc->next_rel = c;
9322 nc->previous_rel = c->previous_rel;
9323 nc->next_stmt = (ffestwCase) &s->first_rel;
9324 nc->previous_stmt = s->last_stmt;
9325 nc->low = expr1c;
9326 nc->high = expr2c;
9327 nc->casenum = s->cases;
9328 nc->t = ffelex_token_use (caseobj->t);
9329 nc->next_rel->previous_rel = nc;
9330 nc->previous_rel->next_rel = nc;
9331 nc->next_stmt->previous_stmt = nc;
9332 nc->previous_stmt->next_stmt = nc;
9333 }
9334 }
9335
9336 ffestd_R810 ((cases == NULL) ? 0 : s->cases);
9337
9338 s->cases++; /* Increment # of cases. */
9339 }
9340
9341 /* ffestc_R811 -- END SELECT statement
9342
9343 ffestc_R811(name_token);
9344
9345 Make sure ffestc_kind_ identifies a SELECT block. If not
9346 NULL, make sure name_token gives the correct name. Implement the end
9347 of the SELECT block. */
9348
9349 void
ffestc_R811(ffelexToken name)9350 ffestc_R811 (ffelexToken name)
9351 {
9352 ffestc_check_simple_ ();
9353 if (ffestc_order_selectcase_ () != FFESTC_orderOK_)
9354 return;
9355 ffestc_labeldef_notloop_ ();
9356
9357 if (name == NULL)
9358 {
9359 if (ffestw_name (ffestw_stack_top ()) != NULL)
9360 {
9361 ffebad_start (FFEBAD_CONSTRUCT_NAMED);
9362 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
9363 ffelex_token_where_column (ffesta_tokens[0]));
9364 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
9365 ffebad_finish ();
9366 }
9367 }
9368 else
9369 {
9370 if (ffestw_name (ffestw_stack_top ()) == NULL)
9371 {
9372 ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
9373 ffebad_here (0, ffelex_token_where_line (name),
9374 ffelex_token_where_column (name));
9375 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
9376 ffebad_finish ();
9377 }
9378 else if (ffelex_token_strcmp (name,
9379 ffestw_name (ffestw_stack_top ()))
9380 != 0)
9381 {
9382 ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
9383 ffebad_here (0, ffelex_token_where_line (name),
9384 ffelex_token_where_column (name));
9385 ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
9386 ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
9387 ffebad_finish ();
9388 }
9389 }
9390
9391 ffestc_shriek_select_ (TRUE);
9392 }
9393
9394 /* ffestc_R819A -- Iterative labeled DO statement
9395
9396 ffestc_R819A(construct_name,label_token,expr,expr_token);
9397
9398 Make sure statement is valid here; implement. */
9399
9400 void
ffestc_R819A(ffelexToken construct_name,ffelexToken label_token,ffebld var,ffelexToken var_token,ffebld start,ffelexToken start_token,ffebld end,ffelexToken end_token,ffebld incr,ffelexToken incr_token)9401 ffestc_R819A (ffelexToken construct_name, ffelexToken label_token, ffebld var,
9402 ffelexToken var_token, ffebld start, ffelexToken start_token, ffebld end,
9403 ffelexToken end_token, ffebld incr, ffelexToken incr_token)
9404 {
9405 ffestw b;
9406 ffelab label;
9407 ffesymbol s;
9408 ffesymbol varsym;
9409
9410 ffestc_check_simple_ ();
9411 if (ffestc_order_exec_ () != FFESTC_orderOK_)
9412 return;
9413 ffestc_labeldef_notloop_ ();
9414
9415 if (!ffestc_labelref_is_loopend_ (label_token, &label))
9416 return;
9417
9418 b = ffestw_update (ffestw_push (NULL));
9419 ffestw_set_top_do (b, b);
9420 ffestw_set_state (b, FFESTV_stateDO);
9421 ffestw_set_blocknum (b, ffestc_blocknum_++);
9422 ffestw_set_shriek (b, ffestc_shriek_do_);
9423 ffestw_set_label (b, label);
9424 switch (ffebld_op (var))
9425 {
9426 case FFEBLD_opSYMTER:
9427 if ((ffeinfo_basictype (ffebld_info (var)) == FFEINFO_basictypeREAL)
9428 && ffe_is_warn_surprising ())
9429 {
9430 ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */
9431 ffebad_here (0, ffelex_token_where_line (var_token),
9432 ffelex_token_where_column (var_token));
9433 ffebad_string (ffesymbol_text (ffebld_symter (var)));
9434 ffebad_finish ();
9435 }
9436 if (!ffesymbol_is_doiter (varsym = ffebld_symter (var)))
9437 { /* Presumably already complained about by
9438 ffeexpr_lhs_. */
9439 ffesymbol_set_is_doiter (varsym, TRUE);
9440 ffestw_set_do_iter_var (b, varsym);
9441 ffestw_set_do_iter_var_t (b, ffelex_token_use (var_token));
9442 break;
9443 }
9444 /* Fall through. */
9445 case FFEBLD_opANY:
9446 ffestw_set_do_iter_var (b, NULL);
9447 ffestw_set_do_iter_var_t (b, NULL);
9448 break;
9449
9450 default:
9451 assert ("bad iter var" == NULL);
9452 break;
9453 }
9454
9455 if (construct_name == NULL)
9456 ffestw_set_name (b, NULL);
9457 else
9458 {
9459 ffestw_set_name (b, ffelex_token_use (construct_name));
9460
9461 s = ffesymbol_declare_local (construct_name, FALSE);
9462
9463 if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
9464 {
9465 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
9466 ffesymbol_set_info (s,
9467 ffeinfo_new (FFEINFO_basictypeNONE,
9468 FFEINFO_kindtypeNONE,
9469 0,
9470 FFEINFO_kindCONSTRUCT,
9471 FFEINFO_whereLOCAL,
9472 FFETARGET_charactersizeNONE));
9473 s = ffecom_sym_learned (s);
9474 ffesymbol_signal_unreported (s);
9475 }
9476 else
9477 ffesymbol_error (s, construct_name);
9478 }
9479
9480 if (incr == NULL)
9481 {
9482 incr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
9483 ffebld_set_info (incr, ffeinfo_new
9484 (FFEINFO_basictypeINTEGER,
9485 FFEINFO_kindtypeINTEGERDEFAULT,
9486 0,
9487 FFEINFO_kindENTITY,
9488 FFEINFO_whereCONSTANT,
9489 FFETARGET_charactersizeNONE));
9490 }
9491
9492 start = ffeexpr_convert_expr (start, start_token, var, var_token,
9493 FFEEXPR_contextLET);
9494 end = ffeexpr_convert_expr (end, end_token, var, var_token,
9495 FFEEXPR_contextLET);
9496 incr = ffeexpr_convert_expr (incr, incr_token, var, var_token,
9497 FFEEXPR_contextLET);
9498
9499 ffestd_R819A (construct_name, label, var,
9500 start, start_token,
9501 end, end_token,
9502 incr, incr_token);
9503 }
9504
9505 /* ffestc_R819B -- Labeled DO WHILE statement
9506
9507 ffestc_R819B(construct_name,label_token,expr,expr_token);
9508
9509 Make sure statement is valid here; implement. */
9510
9511 void
ffestc_R819B(ffelexToken construct_name,ffelexToken label_token,ffebld expr,ffelexToken expr_token UNUSED)9512 ffestc_R819B (ffelexToken construct_name, ffelexToken label_token,
9513 ffebld expr, ffelexToken expr_token UNUSED)
9514 {
9515 ffestw b;
9516 ffelab label;
9517 ffesymbol s;
9518
9519 ffestc_check_simple_ ();
9520 if (ffestc_order_exec_ () != FFESTC_orderOK_)
9521 return;
9522 ffestc_labeldef_notloop_ ();
9523
9524 if (!ffestc_labelref_is_loopend_ (label_token, &label))
9525 return;
9526
9527 b = ffestw_update (ffestw_push (NULL));
9528 ffestw_set_top_do (b, b);
9529 ffestw_set_state (b, FFESTV_stateDO);
9530 ffestw_set_blocknum (b, ffestc_blocknum_++);
9531 ffestw_set_shriek (b, ffestc_shriek_do_);
9532 ffestw_set_label (b, label);
9533 ffestw_set_do_iter_var (b, NULL);
9534 ffestw_set_do_iter_var_t (b, NULL);
9535
9536 if (construct_name == NULL)
9537 ffestw_set_name (b, NULL);
9538 else
9539 {
9540 ffestw_set_name (b, ffelex_token_use (construct_name));
9541
9542 s = ffesymbol_declare_local (construct_name, FALSE);
9543
9544 if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
9545 {
9546 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
9547 ffesymbol_set_info (s,
9548 ffeinfo_new (FFEINFO_basictypeNONE,
9549 FFEINFO_kindtypeNONE,
9550 0,
9551 FFEINFO_kindCONSTRUCT,
9552 FFEINFO_whereLOCAL,
9553 FFETARGET_charactersizeNONE));
9554 s = ffecom_sym_learned (s);
9555 ffesymbol_signal_unreported (s);
9556 }
9557 else
9558 ffesymbol_error (s, construct_name);
9559 }
9560
9561 ffestd_R819B (construct_name, label, expr);
9562 }
9563
9564 /* ffestc_R820A -- Iterative nonlabeled DO statement
9565
9566 ffestc_R820A(construct_name,expr,expr_token);
9567
9568 Make sure statement is valid here; implement. */
9569
9570 void
ffestc_R820A(ffelexToken construct_name,ffebld var,ffelexToken var_token,ffebld start,ffelexToken start_token,ffebld end,ffelexToken end_token,ffebld incr,ffelexToken incr_token)9571 ffestc_R820A (ffelexToken construct_name, ffebld var, ffelexToken var_token,
9572 ffebld start, ffelexToken start_token, ffebld end, ffelexToken end_token,
9573 ffebld incr, ffelexToken incr_token)
9574 {
9575 ffestw b;
9576 ffesymbol s;
9577 ffesymbol varsym;
9578
9579 ffestc_check_simple_ ();
9580 if (ffestc_order_exec_ () != FFESTC_orderOK_)
9581 return;
9582 ffestc_labeldef_notloop_ ();
9583
9584 b = ffestw_update (ffestw_push (NULL));
9585 ffestw_set_top_do (b, b);
9586 ffestw_set_state (b, FFESTV_stateDO);
9587 ffestw_set_blocknum (b, ffestc_blocknum_++);
9588 ffestw_set_shriek (b, ffestc_shriek_do_);
9589 ffestw_set_label (b, NULL);
9590 switch (ffebld_op (var))
9591 {
9592 case FFEBLD_opSYMTER:
9593 if ((ffeinfo_basictype (ffebld_info (var)) == FFEINFO_basictypeREAL)
9594 && ffe_is_warn_surprising ())
9595 {
9596 ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */
9597 ffebad_here (0, ffelex_token_where_line (var_token),
9598 ffelex_token_where_column (var_token));
9599 ffebad_string (ffesymbol_text (ffebld_symter (var)));
9600 ffebad_finish ();
9601 }
9602 if (!ffesymbol_is_doiter (varsym = ffebld_symter (var)))
9603 { /* Presumably already complained about by
9604 ffeexpr_lhs_. */
9605 ffesymbol_set_is_doiter (varsym, TRUE);
9606 ffestw_set_do_iter_var (b, varsym);
9607 ffestw_set_do_iter_var_t (b, ffelex_token_use (var_token));
9608 break;
9609 }
9610 /* Fall through. */
9611 case FFEBLD_opANY:
9612 ffestw_set_do_iter_var (b, NULL);
9613 ffestw_set_do_iter_var_t (b, NULL);
9614 break;
9615
9616 default:
9617 assert ("bad iter var" == NULL);
9618 break;
9619 }
9620
9621 if (construct_name == NULL)
9622 ffestw_set_name (b, NULL);
9623 else
9624 {
9625 ffestw_set_name (b, ffelex_token_use (construct_name));
9626
9627 s = ffesymbol_declare_local (construct_name, FALSE);
9628
9629 if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
9630 {
9631 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
9632 ffesymbol_set_info (s,
9633 ffeinfo_new (FFEINFO_basictypeNONE,
9634 FFEINFO_kindtypeNONE,
9635 0,
9636 FFEINFO_kindCONSTRUCT,
9637 FFEINFO_whereLOCAL,
9638 FFETARGET_charactersizeNONE));
9639 s = ffecom_sym_learned (s);
9640 ffesymbol_signal_unreported (s);
9641 }
9642 else
9643 ffesymbol_error (s, construct_name);
9644 }
9645
9646 if (incr == NULL)
9647 {
9648 incr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
9649 ffebld_set_info (incr, ffeinfo_new
9650 (FFEINFO_basictypeINTEGER,
9651 FFEINFO_kindtypeINTEGERDEFAULT,
9652 0,
9653 FFEINFO_kindENTITY,
9654 FFEINFO_whereCONSTANT,
9655 FFETARGET_charactersizeNONE));
9656 }
9657
9658 start = ffeexpr_convert_expr (start, start_token, var, var_token,
9659 FFEEXPR_contextLET);
9660 end = ffeexpr_convert_expr (end, end_token, var, var_token,
9661 FFEEXPR_contextLET);
9662 incr = ffeexpr_convert_expr (incr, incr_token, var, var_token,
9663 FFEEXPR_contextLET);
9664
9665 #if 0
9666 if ((ffebld_op (incr) == FFEBLD_opCONTER)
9667 && (ffebld_constant_is_zero (ffebld_conter (incr))))
9668 {
9669 ffebad_start (FFEBAD_DO_STEP_ZERO);
9670 ffebad_here (0, ffelex_token_where_line (incr_token),
9671 ffelex_token_where_column (incr_token));
9672 ffebad_string ("Iterative DO loop");
9673 ffebad_finish ();
9674 }
9675 #endif
9676
9677 ffestd_R819A (construct_name, NULL, var,
9678 start, start_token,
9679 end, end_token,
9680 incr, incr_token);
9681 }
9682
9683 /* ffestc_R820B -- Nonlabeled DO WHILE statement
9684
9685 ffestc_R820B(construct_name,expr,expr_token);
9686
9687 Make sure statement is valid here; implement. */
9688
9689 void
ffestc_R820B(ffelexToken construct_name,ffebld expr,ffelexToken expr_token UNUSED)9690 ffestc_R820B (ffelexToken construct_name, ffebld expr,
9691 ffelexToken expr_token UNUSED)
9692 {
9693 ffestw b;
9694 ffesymbol s;
9695
9696 ffestc_check_simple_ ();
9697 if (ffestc_order_exec_ () != FFESTC_orderOK_)
9698 return;
9699 ffestc_labeldef_notloop_ ();
9700
9701 b = ffestw_update (ffestw_push (NULL));
9702 ffestw_set_top_do (b, b);
9703 ffestw_set_state (b, FFESTV_stateDO);
9704 ffestw_set_blocknum (b, ffestc_blocknum_++);
9705 ffestw_set_shriek (b, ffestc_shriek_do_);
9706 ffestw_set_label (b, NULL);
9707 ffestw_set_do_iter_var (b, NULL);
9708 ffestw_set_do_iter_var_t (b, NULL);
9709
9710 if (construct_name == NULL)
9711 ffestw_set_name (b, NULL);
9712 else
9713 {
9714 ffestw_set_name (b, ffelex_token_use (construct_name));
9715
9716 s = ffesymbol_declare_local (construct_name, FALSE);
9717
9718 if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
9719 {
9720 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
9721 ffesymbol_set_info (s,
9722 ffeinfo_new (FFEINFO_basictypeNONE,
9723 FFEINFO_kindtypeNONE,
9724 0,
9725 FFEINFO_kindCONSTRUCT,
9726 FFEINFO_whereLOCAL,
9727 FFETARGET_charactersizeNONE));
9728 s = ffecom_sym_learned (s);
9729 ffesymbol_signal_unreported (s);
9730 }
9731 else
9732 ffesymbol_error (s, construct_name);
9733 }
9734
9735 ffestd_R819B (construct_name, NULL, expr);
9736 }
9737
9738 /* ffestc_R825 -- END DO statement
9739
9740 ffestc_R825(name_token);
9741
9742 Make sure ffestc_kind_ identifies a DO block. If not
9743 NULL, make sure name_token gives the correct name. Implement the end
9744 of the DO block. */
9745
9746 void
ffestc_R825(ffelexToken name)9747 ffestc_R825 (ffelexToken name)
9748 {
9749 ffestc_check_simple_ ();
9750 if (ffestc_order_do_ () != FFESTC_orderOK_)
9751 return;
9752 ffestc_labeldef_branch_begin_ ();
9753
9754 if (name == NULL)
9755 {
9756 if (ffestw_name (ffestw_stack_top ()) != NULL)
9757 {
9758 ffebad_start (FFEBAD_CONSTRUCT_NAMED);
9759 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
9760 ffelex_token_where_column (ffesta_tokens[0]));
9761 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
9762 ffebad_finish ();
9763 }
9764 }
9765 else
9766 {
9767 if (ffestw_name (ffestw_stack_top ()) == NULL)
9768 {
9769 ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
9770 ffebad_here (0, ffelex_token_where_line (name),
9771 ffelex_token_where_column (name));
9772 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
9773 ffebad_finish ();
9774 }
9775 else if (ffelex_token_strcmp (name,
9776 ffestw_name (ffestw_stack_top ()))
9777 != 0)
9778 {
9779 ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
9780 ffebad_here (0, ffelex_token_where_line (name),
9781 ffelex_token_where_column (name));
9782 ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
9783 ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
9784 ffebad_finish ();
9785 }
9786 }
9787
9788 if (ffesta_label_token == NULL)
9789 { /* If top of stack has label, its an error! */
9790 if (ffestw_label (ffestw_stack_top ()) != NULL)
9791 {
9792 ffebad_start (FFEBAD_DO_HAD_LABEL);
9793 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
9794 ffelex_token_where_column (ffesta_tokens[0]));
9795 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
9796 ffebad_finish ();
9797 }
9798
9799 ffestc_shriek_do_ (TRUE);
9800
9801 ffestc_try_shriek_do_ ();
9802
9803 return;
9804 }
9805
9806 ffestd_R825 (name);
9807
9808 ffestc_labeldef_branch_end_ ();
9809 }
9810
9811 /* ffestc_R834 -- CYCLE statement
9812
9813 ffestc_R834(name_token);
9814
9815 Handle a CYCLE within a loop. */
9816
9817 void
ffestc_R834(ffelexToken name)9818 ffestc_R834 (ffelexToken name)
9819 {
9820 ffestw block;
9821
9822 ffestc_check_simple_ ();
9823 if (ffestc_order_actiondo_ () != FFESTC_orderOK_)
9824 return;
9825 ffestc_labeldef_notloop_begin_ ();
9826
9827 if (name == NULL)
9828 block = ffestw_top_do (ffestw_stack_top ());
9829 else
9830 { /* Search for name. */
9831 for (block = ffestw_top_do (ffestw_stack_top ());
9832 (block != NULL) && (ffestw_blocknum (block) != 0);
9833 block = ffestw_top_do (ffestw_previous (block)))
9834 {
9835 if ((ffestw_name (block) != NULL)
9836 && (ffelex_token_strcmp (name, ffestw_name (block)) == 0))
9837 break;
9838 }
9839 if ((block == NULL) || (ffestw_blocknum (block) == 0))
9840 {
9841 block = ffestw_top_do (ffestw_stack_top ());
9842 ffebad_start (FFEBAD_CONSTRUCT_NO_DO_NAME);
9843 ffebad_here (0, ffelex_token_where_line (name),
9844 ffelex_token_where_column (name));
9845 ffebad_finish ();
9846 }
9847 }
9848
9849 ffestd_R834 (block);
9850
9851 if (ffestc_shriek_after1_ != NULL)
9852 (*ffestc_shriek_after1_) (TRUE);
9853
9854 /* notloop's that are actionif's can be the target of a loop-end
9855 statement if they're in the "then" part of a logical IF, as
9856 in "DO 10", "10 IF (...) CYCLE". */
9857
9858 ffestc_labeldef_branch_end_ ();
9859 }
9860
9861 /* ffestc_R835 -- EXIT statement
9862
9863 ffestc_R835(name_token);
9864
9865 Handle a EXIT within a loop. */
9866
9867 void
ffestc_R835(ffelexToken name)9868 ffestc_R835 (ffelexToken name)
9869 {
9870 ffestw block;
9871
9872 ffestc_check_simple_ ();
9873 if (ffestc_order_actiondo_ () != FFESTC_orderOK_)
9874 return;
9875 ffestc_labeldef_notloop_begin_ ();
9876
9877 if (name == NULL)
9878 block = ffestw_top_do (ffestw_stack_top ());
9879 else
9880 { /* Search for name. */
9881 for (block = ffestw_top_do (ffestw_stack_top ());
9882 (block != NULL) && (ffestw_blocknum (block) != 0);
9883 block = ffestw_top_do (ffestw_previous (block)))
9884 {
9885 if ((ffestw_name (block) != NULL)
9886 && (ffelex_token_strcmp (name, ffestw_name (block)) == 0))
9887 break;
9888 }
9889 if ((block == NULL) || (ffestw_blocknum (block) == 0))
9890 {
9891 block = ffestw_top_do (ffestw_stack_top ());
9892 ffebad_start (FFEBAD_CONSTRUCT_NO_DO_NAME);
9893 ffebad_here (0, ffelex_token_where_line (name),
9894 ffelex_token_where_column (name));
9895 ffebad_finish ();
9896 }
9897 }
9898
9899 ffestd_R835 (block);
9900
9901 if (ffestc_shriek_after1_ != NULL)
9902 (*ffestc_shriek_after1_) (TRUE);
9903
9904 /* notloop's that are actionif's can be the target of a loop-end
9905 statement if they're in the "then" part of a logical IF, as
9906 in "DO 10", "10 IF (...) EXIT". */
9907
9908 ffestc_labeldef_branch_end_ ();
9909 }
9910
9911 /* ffestc_R836 -- GOTO statement
9912
9913 ffestc_R836(label_token);
9914
9915 Make sure label_token identifies a valid label for a GOTO. Update
9916 that label's info to indicate it is the target of a GOTO. */
9917
9918 void
ffestc_R836(ffelexToken label_token)9919 ffestc_R836 (ffelexToken label_token)
9920 {
9921 ffelab label;
9922
9923 ffestc_check_simple_ ();
9924 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
9925 return;
9926 ffestc_labeldef_notloop_begin_ ();
9927
9928 if (ffestc_labelref_is_branch_ (label_token, &label))
9929 ffestd_R836 (label);
9930
9931 if (ffestc_shriek_after1_ != NULL)
9932 (*ffestc_shriek_after1_) (TRUE);
9933
9934 /* notloop's that are actionif's can be the target of a loop-end
9935 statement if they're in the "then" part of a logical IF, as
9936 in "DO 10", "10 IF (...) GOTO 100". */
9937
9938 ffestc_labeldef_branch_end_ ();
9939 }
9940
9941 /* ffestc_R837 -- Computed GOTO statement
9942
9943 ffestc_R837(label_list,expr,expr_token);
9944
9945 Make sure label_list identifies valid labels for a GOTO. Update
9946 each label's info to indicate it is the target of a GOTO. */
9947
9948 void
ffestc_R837(ffesttTokenList label_toks,ffebld expr,ffelexToken expr_token UNUSED)9949 ffestc_R837 (ffesttTokenList label_toks, ffebld expr,
9950 ffelexToken expr_token UNUSED)
9951 {
9952 ffesttTokenItem ti;
9953 bool ok = TRUE;
9954 int i;
9955 ffelab *labels;
9956
9957 assert (label_toks != NULL);
9958
9959 ffestc_check_simple_ ();
9960 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
9961 return;
9962 ffestc_labeldef_branch_begin_ ();
9963
9964 labels = malloc_new_kp (ffesta_output_pool, "FFESTC labels",
9965 sizeof (*labels)
9966 * ffestt_tokenlist_count (label_toks));
9967
9968 for (ti = label_toks->first, i = 0;
9969 ti != (ffesttTokenItem) &label_toks->first;
9970 ti = ti->next, ++i)
9971 {
9972 if (!ffestc_labelref_is_branch_ (ti->t, &labels[i]))
9973 {
9974 ok = FALSE;
9975 break;
9976 }
9977 }
9978
9979 if (ok)
9980 ffestd_R837 (labels, ffestt_tokenlist_count (label_toks), expr);
9981
9982 if (ffestc_shriek_after1_ != NULL)
9983 (*ffestc_shriek_after1_) (TRUE);
9984 ffestc_labeldef_branch_end_ ();
9985 }
9986
9987 /* ffestc_R838 -- ASSIGN statement
9988
9989 ffestc_R838(label_token,target_variable,target_token);
9990
9991 Make sure label_token identifies a valid label for an assignment. Update
9992 that label's info to indicate it is the source of an assignment. Update
9993 target_variable's info to indicate it is the target the assignment of that
9994 label. */
9995
9996 void
ffestc_R838(ffelexToken label_token,ffebld target,ffelexToken target_token UNUSED)9997 ffestc_R838 (ffelexToken label_token, ffebld target,
9998 ffelexToken target_token UNUSED)
9999 {
10000 ffelab label;
10001
10002 ffestc_check_simple_ ();
10003 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
10004 return;
10005 ffestc_labeldef_branch_begin_ ();
10006
10007 /* Mark target symbol as target of an ASSIGN. */
10008 if (ffebld_op (target) == FFEBLD_opSYMTER)
10009 ffesymbol_set_assigned (ffebld_symter (target), TRUE);
10010
10011 if (ffestc_labelref_is_assignable_ (label_token, &label))
10012 ffestd_R838 (label, target);
10013
10014 if (ffestc_shriek_after1_ != NULL)
10015 (*ffestc_shriek_after1_) (TRUE);
10016 ffestc_labeldef_branch_end_ ();
10017 }
10018
10019 /* ffestc_R839 -- Assigned GOTO statement
10020
10021 ffestc_R839(target,target_token,label_list);
10022
10023 Make sure label_list identifies valid labels for a GOTO. Update
10024 each label's info to indicate it is the target of a GOTO. */
10025
10026 void
ffestc_R839(ffebld target,ffelexToken target_token UNUSED,ffesttTokenList label_toks)10027 ffestc_R839 (ffebld target, ffelexToken target_token UNUSED,
10028 ffesttTokenList label_toks)
10029 {
10030 ffesttTokenItem ti;
10031 bool ok = TRUE;
10032 int i;
10033 ffelab *labels;
10034
10035 ffestc_check_simple_ ();
10036 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
10037 return;
10038 ffestc_labeldef_notloop_begin_ ();
10039
10040 if (label_toks == NULL)
10041 {
10042 labels = NULL;
10043 i = 0;
10044 }
10045 else
10046 {
10047 labels = malloc_new_kp (ffesta_output_pool, "FFESTC labels",
10048 sizeof (*labels) * ffestt_tokenlist_count (label_toks));
10049
10050 for (ti = label_toks->first, i = 0;
10051 ti != (ffesttTokenItem) &label_toks->first;
10052 ti = ti->next, ++i)
10053 {
10054 if (!ffestc_labelref_is_branch_ (ti->t, &labels[i]))
10055 {
10056 ok = FALSE;
10057 break;
10058 }
10059 }
10060 }
10061
10062 if (ok)
10063 ffestd_R839 (target, labels, i);
10064
10065 if (ffestc_shriek_after1_ != NULL)
10066 (*ffestc_shriek_after1_) (TRUE);
10067
10068 /* notloop's that are actionif's can be the target of a loop-end
10069 statement if they're in the "then" part of a logical IF, as
10070 in "DO 10", "10 IF (...) GOTO I". */
10071
10072 ffestc_labeldef_branch_end_ ();
10073 }
10074
10075 /* ffestc_R840 -- Arithmetic IF statement
10076
10077 ffestc_R840(expr,expr_token,neg,zero,pos);
10078
10079 Make sure the labels are valid; implement. */
10080
10081 void
ffestc_R840(ffebld expr,ffelexToken expr_token UNUSED,ffelexToken neg_token,ffelexToken zero_token,ffelexToken pos_token)10082 ffestc_R840 (ffebld expr, ffelexToken expr_token UNUSED,
10083 ffelexToken neg_token, ffelexToken zero_token,
10084 ffelexToken pos_token)
10085 {
10086 ffelab neg;
10087 ffelab zero;
10088 ffelab pos;
10089
10090 ffestc_check_simple_ ();
10091 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
10092 return;
10093 ffestc_labeldef_notloop_begin_ ();
10094
10095 if (ffestc_labelref_is_branch_ (neg_token, &neg)
10096 && ffestc_labelref_is_branch_ (zero_token, &zero)
10097 && ffestc_labelref_is_branch_ (pos_token, &pos))
10098 ffestd_R840 (expr, neg, zero, pos);
10099
10100 if (ffestc_shriek_after1_ != NULL)
10101 (*ffestc_shriek_after1_) (TRUE);
10102
10103 /* notloop's that are actionif's can be the target of a loop-end
10104 statement if they're in the "then" part of a logical IF, as
10105 in "DO 10", "10 IF (...) GOTO (100,200,300), I". */
10106
10107 ffestc_labeldef_branch_end_ ();
10108 }
10109
10110 /* ffestc_R841 -- CONTINUE statement
10111
10112 ffestc_R841(); */
10113
10114 void
ffestc_R841()10115 ffestc_R841 ()
10116 {
10117 ffestc_check_simple_ ();
10118
10119 if (ffestc_order_actionwhere_ () != FFESTC_orderOK_)
10120 return;
10121
10122 switch (ffestw_state (ffestw_stack_top ()))
10123 {
10124 #if FFESTR_F90
10125 case FFESTV_stateWHERE:
10126 case FFESTV_stateWHERETHEN:
10127 ffestc_labeldef_useless_ ();
10128
10129 ffestd_R841 (TRUE);
10130
10131 /* It's okay that we call ffestc_labeldef_branch_end_ () below,
10132 since that will be a no-op after calling _useless_ () above. */
10133 break;
10134 #endif
10135
10136 default:
10137 ffestc_labeldef_branch_begin_ ();
10138
10139 ffestd_R841 (FALSE);
10140
10141 break;
10142 }
10143
10144 if (ffestc_shriek_after1_ != NULL)
10145 (*ffestc_shriek_after1_) (TRUE);
10146 ffestc_labeldef_branch_end_ ();
10147 }
10148
10149 /* ffestc_R842 -- STOP statement
10150
10151 ffestc_R842(expr,expr_token);
10152
10153 Make sure statement is valid here; implement. expr and expr_token are
10154 both NULL if there was no expression. */
10155
10156 void
ffestc_R842(ffebld expr,ffelexToken expr_token UNUSED)10157 ffestc_R842 (ffebld expr, ffelexToken expr_token UNUSED)
10158 {
10159 ffestc_check_simple_ ();
10160 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
10161 return;
10162 ffestc_labeldef_notloop_begin_ ();
10163
10164 ffestd_R842 (expr);
10165
10166 if (ffestc_shriek_after1_ != NULL)
10167 (*ffestc_shriek_after1_) (TRUE);
10168
10169 /* notloop's that are actionif's can be the target of a loop-end
10170 statement if they're in the "then" part of a logical IF, as
10171 in "DO 10", "10 IF (...) STOP". */
10172
10173 ffestc_labeldef_branch_end_ ();
10174 }
10175
10176 /* ffestc_R843 -- PAUSE statement
10177
10178 ffestc_R843(expr,expr_token);
10179
10180 Make sure statement is valid here; implement. expr and expr_token are
10181 both NULL if there was no expression. */
10182
10183 void
ffestc_R843(ffebld expr,ffelexToken expr_token UNUSED)10184 ffestc_R843 (ffebld expr, ffelexToken expr_token UNUSED)
10185 {
10186 ffestc_check_simple_ ();
10187 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
10188 return;
10189 ffestc_labeldef_branch_begin_ ();
10190
10191 ffestd_R843 (expr);
10192
10193 if (ffestc_shriek_after1_ != NULL)
10194 (*ffestc_shriek_after1_) (TRUE);
10195 ffestc_labeldef_branch_end_ ();
10196 }
10197
10198 /* ffestc_R904 -- OPEN statement
10199
10200 ffestc_R904();
10201
10202 Make sure an OPEN is valid in the current context, and implement it. */
10203
10204 void
ffestc_R904()10205 ffestc_R904 ()
10206 {
10207 int i;
10208 int expect_file;
10209 static const char *const status_strs[] =
10210 {
10211 "New",
10212 "Old",
10213 "Replace",
10214 "Scratch",
10215 "Unknown"
10216 };
10217 static const char *const access_strs[] =
10218 {
10219 "Append",
10220 "Direct",
10221 "Keyed",
10222 "Sequential"
10223 };
10224 static const char *const blank_strs[] =
10225 {
10226 "Null",
10227 "Zero"
10228 };
10229 static const char *const carriagecontrol_strs[] =
10230 {
10231 "Fortran",
10232 "List",
10233 "None"
10234 };
10235 static const char *const dispose_strs[] =
10236 {
10237 "Delete",
10238 "Keep",
10239 "Print",
10240 "Print/Delete",
10241 "Save",
10242 "Submit",
10243 "Submit/Delete"
10244 };
10245 static const char *const form_strs[] =
10246 {
10247 "Formatted",
10248 "Unformatted"
10249 };
10250 static const char *const organization_strs[] =
10251 {
10252 "Indexed",
10253 "Relative",
10254 "Sequential"
10255 };
10256 static const char *const position_strs[] =
10257 {
10258 "Append",
10259 "AsIs",
10260 "Rewind"
10261 };
10262 static const char *const action_strs[] =
10263 {
10264 "Read",
10265 "ReadWrite",
10266 "Write"
10267 };
10268 static const char *const delim_strs[] =
10269 {
10270 "Apostrophe",
10271 "None",
10272 "Quote"
10273 };
10274 static const char *const recordtype_strs[] =
10275 {
10276 "Fixed",
10277 "Segmented",
10278 "Stream",
10279 "Stream_CR",
10280 "Stream_LF",
10281 "Variable"
10282 };
10283 static const char *const pad_strs[] =
10284 {
10285 "No",
10286 "Yes"
10287 };
10288
10289 ffestc_check_simple_ ();
10290 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
10291 return;
10292 ffestc_labeldef_branch_begin_ ();
10293
10294 if (ffestc_subr_is_branch_
10295 (&ffestp_file.open.open_spec[FFESTP_openixERR])
10296 && ffestc_subr_is_present_ ("UNIT",
10297 &ffestp_file.open.open_spec[FFESTP_openixUNIT]))
10298 {
10299 i = ffestc_subr_binsrch_ (status_strs,
10300 ARRAY_SIZE (status_strs),
10301 &ffestp_file.open.open_spec[FFESTP_openixSTATUS],
10302 "NEW, OLD, REPLACE, SCRATCH, or UNKNOWN");
10303 switch (i)
10304 {
10305 case 0: /* Unknown. */
10306 case 5: /* UNKNOWN. */
10307 expect_file = 2; /* Unknown, don't care about FILE=. */
10308 break;
10309
10310 case 1: /* NEW. */
10311 case 2: /* OLD. */
10312 if (ffe_is_pedantic ())
10313 expect_file = 1; /* Yes, need FILE=. */
10314 else
10315 expect_file = 2; /* f2clib doesn't care about FILE=. */
10316 break;
10317
10318 case 3: /* REPLACE. */
10319 expect_file = 1; /* Yes, need FILE=. */
10320 break;
10321
10322 case 4: /* SCRATCH. */
10323 expect_file = 0; /* No, disallow FILE=. */
10324 break;
10325
10326 default:
10327 assert ("invalid _binsrch_ result" == NULL);
10328 expect_file = 0;
10329 break;
10330 }
10331 if ((expect_file == 0)
10332 && ffestp_file.open.open_spec[FFESTP_openixFILE].kw_or_val_present)
10333 {
10334 ffebad_start (FFEBAD_CONFLICTING_SPECS);
10335 assert (ffestp_file.open.open_spec[FFESTP_openixFILE].kw_or_val_present);
10336 if (ffestp_file.open.open_spec[FFESTP_openixFILE].kw_present)
10337 {
10338 ffebad_here (0, ffelex_token_where_line
10339 (ffestp_file.open.open_spec[FFESTP_openixFILE].kw),
10340 ffelex_token_where_column
10341 (ffestp_file.open.open_spec[FFESTP_openixFILE].kw));
10342 }
10343 else
10344 {
10345 ffebad_here (0, ffelex_token_where_line
10346 (ffestp_file.open.open_spec[FFESTP_openixFILE].value),
10347 ffelex_token_where_column
10348 (ffestp_file.open.open_spec[FFESTP_openixFILE].value));
10349 }
10350 assert (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_or_val_present);
10351 if (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_present)
10352 {
10353 ffebad_here (1, ffelex_token_where_line
10354 (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw),
10355 ffelex_token_where_column
10356 (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw));
10357 }
10358 else
10359 {
10360 ffebad_here (1, ffelex_token_where_line
10361 (ffestp_file.open.open_spec[FFESTP_openixSTATUS].value),
10362 ffelex_token_where_column
10363 (ffestp_file.open.open_spec[FFESTP_openixSTATUS].value));
10364 }
10365 ffebad_finish ();
10366 }
10367 else if ((expect_file == 1)
10368 && !ffestp_file.open.open_spec[FFESTP_openixFILE].kw_or_val_present)
10369 {
10370 ffebad_start (FFEBAD_MISSING_SPECIFIER);
10371 assert (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_or_val_present);
10372 if (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_present)
10373 {
10374 ffebad_here (0, ffelex_token_where_line
10375 (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw),
10376 ffelex_token_where_column
10377 (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw));
10378 }
10379 else
10380 {
10381 ffebad_here (0, ffelex_token_where_line
10382 (ffestp_file.open.open_spec[FFESTP_openixSTATUS].value),
10383 ffelex_token_where_column
10384 (ffestp_file.open.open_spec[FFESTP_openixSTATUS].value));
10385 }
10386 ffebad_string ("FILE=");
10387 ffebad_finish ();
10388 }
10389
10390 ffestc_subr_binsrch_ (access_strs, ARRAY_SIZE (access_strs),
10391 &ffestp_file.open.open_spec[FFESTP_openixACCESS],
10392 "APPEND, DIRECT, KEYED, or SEQUENTIAL");
10393
10394 ffestc_subr_binsrch_ (blank_strs, ARRAY_SIZE (blank_strs),
10395 &ffestp_file.open.open_spec[FFESTP_openixBLANK],
10396 "NULL or ZERO");
10397
10398 ffestc_subr_binsrch_ (carriagecontrol_strs,
10399 ARRAY_SIZE (carriagecontrol_strs),
10400 &ffestp_file.open.open_spec[FFESTP_openixCARRIAGECONTROL],
10401 "FORTRAN, LIST, or NONE");
10402
10403 ffestc_subr_binsrch_ (dispose_strs, ARRAY_SIZE (dispose_strs),
10404 &ffestp_file.open.open_spec[FFESTP_openixDISPOSE],
10405 "DELETE, KEEP, PRINT, PRINT/DELETE, SAVE, SUBMIT, or SUBMIT/DELETE");
10406
10407 ffestc_subr_binsrch_ (form_strs, ARRAY_SIZE (form_strs),
10408 &ffestp_file.open.open_spec[FFESTP_openixFORM],
10409 "FORMATTED or UNFORMATTED");
10410
10411 ffestc_subr_binsrch_ (organization_strs, ARRAY_SIZE (organization_strs),
10412 &ffestp_file.open.open_spec[FFESTP_openixORGANIZATION],
10413 "INDEXED, RELATIVE, or SEQUENTIAL");
10414
10415 ffestc_subr_binsrch_ (position_strs, ARRAY_SIZE (position_strs),
10416 &ffestp_file.open.open_spec[FFESTP_openixPOSITION],
10417 "APPEND, ASIS, or REWIND");
10418
10419 ffestc_subr_binsrch_ (action_strs, ARRAY_SIZE (action_strs),
10420 &ffestp_file.open.open_spec[FFESTP_openixACTION],
10421 "READ, READWRITE, or WRITE");
10422
10423 ffestc_subr_binsrch_ (delim_strs, ARRAY_SIZE (delim_strs),
10424 &ffestp_file.open.open_spec[FFESTP_openixDELIM],
10425 "APOSTROPHE, NONE, or QUOTE");
10426
10427 ffestc_subr_binsrch_ (recordtype_strs, ARRAY_SIZE (recordtype_strs),
10428 &ffestp_file.open.open_spec[FFESTP_openixRECORDTYPE],
10429 "FIXED, SEGMENTED, STREAM, STREAM_CR, STREAM_LF, or VARIABLE");
10430
10431 ffestc_subr_binsrch_ (pad_strs, ARRAY_SIZE (pad_strs),
10432 &ffestp_file.open.open_spec[FFESTP_openixPAD],
10433 "NO or YES");
10434
10435 ffestd_R904 ();
10436 }
10437
10438 if (ffestc_shriek_after1_ != NULL)
10439 (*ffestc_shriek_after1_) (TRUE);
10440 ffestc_labeldef_branch_end_ ();
10441 }
10442
10443 /* ffestc_R907 -- CLOSE statement
10444
10445 ffestc_R907();
10446
10447 Make sure a CLOSE is valid in the current context, and implement it. */
10448
10449 void
ffestc_R907()10450 ffestc_R907 ()
10451 {
10452 static const char *const status_strs[] =
10453 {
10454 "Delete",
10455 "Keep",
10456 "Print",
10457 "Print/Delete",
10458 "Save",
10459 "Submit",
10460 "Submit/Delete"
10461 };
10462
10463 ffestc_check_simple_ ();
10464 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
10465 return;
10466 ffestc_labeldef_branch_begin_ ();
10467
10468 if (ffestc_subr_is_branch_
10469 (&ffestp_file.close.close_spec[FFESTP_closeixERR])
10470 && ffestc_subr_is_present_ ("UNIT",
10471 &ffestp_file.close.close_spec[FFESTP_closeixUNIT]))
10472 {
10473 ffestc_subr_binsrch_ (status_strs, ARRAY_SIZE (status_strs),
10474 &ffestp_file.close.close_spec[FFESTP_closeixSTATUS],
10475 "DELETE, KEEP, PRINT, PRINT/DELETE, SAVE, SUBMIT, or SUBMIT/DELETE");
10476
10477 ffestd_R907 ();
10478 }
10479
10480 if (ffestc_shriek_after1_ != NULL)
10481 (*ffestc_shriek_after1_) (TRUE);
10482 ffestc_labeldef_branch_end_ ();
10483 }
10484
10485 /* ffestc_R909_start -- READ(...) statement list begin
10486
10487 ffestc_R909_start(FALSE);
10488
10489 Verify that READ is valid here, and begin accepting items in the
10490 list. */
10491
10492 void
ffestc_R909_start(bool only_format)10493 ffestc_R909_start (bool only_format)
10494 {
10495 ffestvUnit unit;
10496 ffestvFormat format;
10497 bool rec;
10498 bool key;
10499 ffestpReadIx keyn;
10500 ffestpReadIx spec1;
10501 ffestpReadIx spec2;
10502
10503 ffestc_check_start_ ();
10504 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
10505 {
10506 ffestc_ok_ = FALSE;
10507 return;
10508 }
10509 ffestc_labeldef_branch_begin_ ();
10510
10511 if (!ffestc_subr_is_format_
10512 (&ffestp_file.read.read_spec[FFESTP_readixFORMAT]))
10513 {
10514 ffestc_ok_ = FALSE;
10515 return;
10516 }
10517
10518 format = ffestc_subr_format_
10519 (&ffestp_file.read.read_spec[FFESTP_readixFORMAT]);
10520 ffestc_namelist_ = (format == FFESTV_formatNAMELIST);
10521
10522 if (only_format)
10523 {
10524 ffestd_R909_start (TRUE, FFESTV_unitNONE, format, FALSE, FALSE);
10525
10526 ffestc_ok_ = TRUE;
10527 return;
10528 }
10529
10530 if (!ffestc_subr_is_branch_
10531 (&ffestp_file.read.read_spec[FFESTP_readixEOR])
10532 || !ffestc_subr_is_branch_
10533 (&ffestp_file.read.read_spec[FFESTP_readixERR])
10534 || !ffestc_subr_is_branch_
10535 (&ffestp_file.read.read_spec[FFESTP_readixEND]))
10536 {
10537 ffestc_ok_ = FALSE;
10538 return;
10539 }
10540
10541 unit = ffestc_subr_unit_
10542 (&ffestp_file.read.read_spec[FFESTP_readixUNIT]);
10543 if (unit == FFESTV_unitNONE)
10544 {
10545 ffebad_start (FFEBAD_NO_UNIT_SPEC);
10546 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
10547 ffelex_token_where_column (ffesta_tokens[0]));
10548 ffebad_finish ();
10549 ffestc_ok_ = FALSE;
10550 return;
10551 }
10552
10553 rec = ffestp_file.read.read_spec[FFESTP_readixREC].kw_or_val_present;
10554
10555 if (ffestp_file.read.read_spec[FFESTP_readixKEYEQ].kw_or_val_present)
10556 {
10557 key = TRUE;
10558 keyn = spec1 = FFESTP_readixKEYEQ;
10559 }
10560 else
10561 {
10562 key = FALSE;
10563 keyn = spec1 = FFESTP_readix;
10564 }
10565
10566 if (ffestp_file.read.read_spec[FFESTP_readixKEYGT].kw_or_val_present)
10567 {
10568 if (key)
10569 {
10570 spec2 = FFESTP_readixKEYGT;
10571 whine: /* :::::::::::::::::::: */
10572 ffebad_start (FFEBAD_CONFLICTING_SPECS);
10573 assert (ffestp_file.read.read_spec[spec1].kw_or_val_present);
10574 if (ffestp_file.read.read_spec[spec1].kw_present)
10575 {
10576 ffebad_here (0, ffelex_token_where_line
10577 (ffestp_file.read.read_spec[spec1].kw),
10578 ffelex_token_where_column
10579 (ffestp_file.read.read_spec[spec1].kw));
10580 }
10581 else
10582 {
10583 ffebad_here (0, ffelex_token_where_line
10584 (ffestp_file.read.read_spec[spec1].value),
10585 ffelex_token_where_column
10586 (ffestp_file.read.read_spec[spec1].value));
10587 }
10588 assert (ffestp_file.read.read_spec[spec2].kw_or_val_present);
10589 if (ffestp_file.read.read_spec[spec2].kw_present)
10590 {
10591 ffebad_here (1, ffelex_token_where_line
10592 (ffestp_file.read.read_spec[spec2].kw),
10593 ffelex_token_where_column
10594 (ffestp_file.read.read_spec[spec2].kw));
10595 }
10596 else
10597 {
10598 ffebad_here (1, ffelex_token_where_line
10599 (ffestp_file.read.read_spec[spec2].value),
10600 ffelex_token_where_column
10601 (ffestp_file.read.read_spec[spec2].value));
10602 }
10603 ffebad_finish ();
10604 ffestc_ok_ = FALSE;
10605 return;
10606 }
10607 key = TRUE;
10608 keyn = spec1 = FFESTP_readixKEYGT;
10609 }
10610
10611 if (ffestp_file.read.read_spec[FFESTP_readixKEYGE].kw_or_val_present)
10612 {
10613 if (key)
10614 {
10615 spec2 = FFESTP_readixKEYGT;
10616 goto whine; /* :::::::::::::::::::: */
10617 }
10618 key = TRUE;
10619 keyn = FFESTP_readixKEYGT;
10620 }
10621
10622 if (rec)
10623 {
10624 spec1 = FFESTP_readixREC;
10625 if (key)
10626 {
10627 spec2 = keyn;
10628 goto whine; /* :::::::::::::::::::: */
10629 }
10630 if (unit == FFESTV_unitCHAREXPR)
10631 {
10632 spec2 = FFESTP_readixUNIT;
10633 goto whine; /* :::::::::::::::::::: */
10634 }
10635 if ((format == FFESTV_formatASTERISK)
10636 || (format == FFESTV_formatNAMELIST))
10637 {
10638 spec2 = FFESTP_readixFORMAT;
10639 goto whine; /* :::::::::::::::::::: */
10640 }
10641 if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present)
10642 {
10643 spec2 = FFESTP_readixADVANCE;
10644 goto whine; /* :::::::::::::::::::: */
10645 }
10646 if (ffestp_file.read.read_spec[FFESTP_readixEND].kw_or_val_present)
10647 {
10648 spec2 = FFESTP_readixEND;
10649 goto whine; /* :::::::::::::::::::: */
10650 }
10651 if (ffestp_file.read.read_spec[FFESTP_readixNULLS].kw_or_val_present)
10652 {
10653 spec2 = FFESTP_readixNULLS;
10654 goto whine; /* :::::::::::::::::::: */
10655 }
10656 }
10657 else if (key)
10658 {
10659 spec1 = keyn;
10660 if (unit == FFESTV_unitCHAREXPR)
10661 {
10662 spec2 = FFESTP_readixUNIT;
10663 goto whine; /* :::::::::::::::::::: */
10664 }
10665 if ((format == FFESTV_formatASTERISK)
10666 || (format == FFESTV_formatNAMELIST))
10667 {
10668 spec2 = FFESTP_readixFORMAT;
10669 goto whine; /* :::::::::::::::::::: */
10670 }
10671 if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present)
10672 {
10673 spec2 = FFESTP_readixADVANCE;
10674 goto whine; /* :::::::::::::::::::: */
10675 }
10676 if (ffestp_file.read.read_spec[FFESTP_readixEND].kw_or_val_present)
10677 {
10678 spec2 = FFESTP_readixEND;
10679 goto whine; /* :::::::::::::::::::: */
10680 }
10681 if (ffestp_file.read.read_spec[FFESTP_readixEOR].kw_or_val_present)
10682 {
10683 spec2 = FFESTP_readixEOR;
10684 goto whine; /* :::::::::::::::::::: */
10685 }
10686 if (ffestp_file.read.read_spec[FFESTP_readixNULLS].kw_or_val_present)
10687 {
10688 spec2 = FFESTP_readixNULLS;
10689 goto whine; /* :::::::::::::::::::: */
10690 }
10691 if (ffestp_file.read.read_spec[FFESTP_readixREC].kw_or_val_present)
10692 {
10693 spec2 = FFESTP_readixREC;
10694 goto whine; /* :::::::::::::::::::: */
10695 }
10696 if (ffestp_file.read.read_spec[FFESTP_readixSIZE].kw_or_val_present)
10697 {
10698 spec2 = FFESTP_readixSIZE;
10699 goto whine; /* :::::::::::::::::::: */
10700 }
10701 }
10702 else
10703 { /* Sequential/Internal. */
10704 if (unit == FFESTV_unitCHAREXPR)
10705 { /* Internal file. */
10706 spec1 = FFESTP_readixUNIT;
10707 if (format == FFESTV_formatNAMELIST)
10708 {
10709 spec2 = FFESTP_readixFORMAT;
10710 goto whine; /* :::::::::::::::::::: */
10711 }
10712 if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present)
10713 {
10714 spec2 = FFESTP_readixADVANCE;
10715 goto whine; /* :::::::::::::::::::: */
10716 }
10717 }
10718 if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present)
10719 { /* ADVANCE= specified. */
10720 spec1 = FFESTP_readixADVANCE;
10721 if (format == FFESTV_formatNONE)
10722 {
10723 ffebad_start (FFEBAD_MISSING_FORMAT_SPEC);
10724 ffebad_here (0, ffelex_token_where_line
10725 (ffestp_file.read.read_spec[spec1].kw),
10726 ffelex_token_where_column
10727 (ffestp_file.read.read_spec[spec1].kw));
10728 ffebad_finish ();
10729
10730 ffestc_ok_ = FALSE;
10731 return;
10732 }
10733 if (format == FFESTV_formatNAMELIST)
10734 {
10735 spec2 = FFESTP_readixFORMAT;
10736 goto whine; /* :::::::::::::::::::: */
10737 }
10738 }
10739 if (ffestp_file.read.read_spec[FFESTP_readixEOR].kw_or_val_present)
10740 { /* EOR= specified. */
10741 spec1 = FFESTP_readixEOR;
10742 if (ffestc_subr_speccmp_ ("No",
10743 &ffestp_file.read.read_spec[FFESTP_readixADVANCE],
10744 NULL, NULL) != 0)
10745 {
10746 goto whine_advance; /* :::::::::::::::::::: */
10747 }
10748 }
10749 if (ffestp_file.read.read_spec[FFESTP_readixNULLS].kw_or_val_present)
10750 { /* NULLS= specified. */
10751 spec1 = FFESTP_readixNULLS;
10752 if (format != FFESTV_formatASTERISK)
10753 {
10754 spec2 = FFESTP_readixFORMAT;
10755 goto whine; /* :::::::::::::::::::: */
10756 }
10757 }
10758 if (ffestp_file.read.read_spec[FFESTP_readixSIZE].kw_or_val_present)
10759 { /* SIZE= specified. */
10760 spec1 = FFESTP_readixSIZE;
10761 if (ffestc_subr_speccmp_ ("No",
10762 &ffestp_file.read.read_spec[FFESTP_readixADVANCE],
10763 NULL, NULL) != 0)
10764 {
10765 whine_advance: /* :::::::::::::::::::: */
10766 if (ffestp_file.read.read_spec[FFESTP_readixADVANCE]
10767 .kw_or_val_present)
10768 {
10769 ffebad_start (FFEBAD_CONFLICTING_SPECS);
10770 ffebad_here (0, ffelex_token_where_line
10771 (ffestp_file.read.read_spec[spec1].kw),
10772 ffelex_token_where_column
10773 (ffestp_file.read.read_spec[spec1].kw));
10774 ffebad_here (1, ffelex_token_where_line
10775 (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw),
10776 ffelex_token_where_column
10777 (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw));
10778 ffebad_finish ();
10779 }
10780 else
10781 {
10782 ffebad_start (FFEBAD_MISSING_ADVANCE_SPEC);
10783 ffebad_here (0, ffelex_token_where_line
10784 (ffestp_file.read.read_spec[spec1].kw),
10785 ffelex_token_where_column
10786 (ffestp_file.read.read_spec[spec1].kw));
10787 ffebad_finish ();
10788 }
10789
10790 ffestc_ok_ = FALSE;
10791 return;
10792 }
10793 }
10794 }
10795
10796 if (unit == FFESTV_unitCHAREXPR)
10797 ffestc_iolist_context_ = FFEEXPR_contextIOLISTDF;
10798 else
10799 ffestc_iolist_context_ = FFEEXPR_contextIOLIST;
10800
10801 ffestd_R909_start (FALSE, unit, format, rec, key);
10802
10803 ffestc_ok_ = TRUE;
10804 }
10805
10806 /* ffestc_R909_item -- READ statement i/o item
10807
10808 ffestc_R909_item(expr,expr_token);
10809
10810 Implement output-list expression. */
10811
10812 void
ffestc_R909_item(ffebld expr,ffelexToken expr_token)10813 ffestc_R909_item (ffebld expr, ffelexToken expr_token)
10814 {
10815 ffestc_check_item_ ();
10816 if (!ffestc_ok_)
10817 return;
10818
10819 if (ffestc_namelist_ != 0)
10820 {
10821 if (ffestc_namelist_ == 1)
10822 {
10823 ffestc_namelist_ = 2;
10824 ffebad_start (FFEBAD_NAMELIST_ITEMS);
10825 ffebad_here (0, ffelex_token_where_line (expr_token),
10826 ffelex_token_where_column (expr_token));
10827 ffebad_finish ();
10828 }
10829 return;
10830 }
10831
10832 ffestd_R909_item (expr, expr_token);
10833 }
10834
10835 /* ffestc_R909_finish -- READ statement list complete
10836
10837 ffestc_R909_finish();
10838
10839 Just wrap up any local activities. */
10840
10841 void
ffestc_R909_finish()10842 ffestc_R909_finish ()
10843 {
10844 ffestc_check_finish_ ();
10845 if (!ffestc_ok_)
10846 return;
10847
10848 ffestd_R909_finish ();
10849
10850 if (ffestc_shriek_after1_ != NULL)
10851 (*ffestc_shriek_after1_) (TRUE);
10852 ffestc_labeldef_branch_end_ ();
10853 }
10854
10855 /* ffestc_R910_start -- WRITE(...) statement list begin
10856
10857 ffestc_R910_start();
10858
10859 Verify that WRITE is valid here, and begin accepting items in the
10860 list. */
10861
10862 void
ffestc_R910_start()10863 ffestc_R910_start ()
10864 {
10865 ffestvUnit unit;
10866 ffestvFormat format;
10867 bool rec;
10868 ffestpWriteIx spec1;
10869 ffestpWriteIx spec2;
10870
10871 ffestc_check_start_ ();
10872 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
10873 {
10874 ffestc_ok_ = FALSE;
10875 return;
10876 }
10877 ffestc_labeldef_branch_begin_ ();
10878
10879 if (!ffestc_subr_is_branch_
10880 (&ffestp_file.write.write_spec[FFESTP_writeixEOR])
10881 || !ffestc_subr_is_branch_
10882 (&ffestp_file.write.write_spec[FFESTP_writeixERR])
10883 || !ffestc_subr_is_format_
10884 (&ffestp_file.write.write_spec[FFESTP_writeixFORMAT]))
10885 {
10886 ffestc_ok_ = FALSE;
10887 return;
10888 }
10889
10890 format = ffestc_subr_format_
10891 (&ffestp_file.write.write_spec[FFESTP_writeixFORMAT]);
10892 ffestc_namelist_ = (format == FFESTV_formatNAMELIST);
10893
10894 unit = ffestc_subr_unit_
10895 (&ffestp_file.write.write_spec[FFESTP_writeixUNIT]);
10896 if (unit == FFESTV_unitNONE)
10897 {
10898 ffebad_start (FFEBAD_NO_UNIT_SPEC);
10899 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
10900 ffelex_token_where_column (ffesta_tokens[0]));
10901 ffebad_finish ();
10902 ffestc_ok_ = FALSE;
10903 return;
10904 }
10905
10906 rec = ffestp_file.write.write_spec[FFESTP_writeixREC].kw_or_val_present;
10907
10908 if (rec)
10909 {
10910 spec1 = FFESTP_writeixREC;
10911 if (unit == FFESTV_unitCHAREXPR)
10912 {
10913 spec2 = FFESTP_writeixUNIT;
10914 whine: /* :::::::::::::::::::: */
10915 ffebad_start (FFEBAD_CONFLICTING_SPECS);
10916 assert (ffestp_file.write.write_spec[spec1].kw_or_val_present);
10917 if (ffestp_file.write.write_spec[spec1].kw_present)
10918 {
10919 ffebad_here (0, ffelex_token_where_line
10920 (ffestp_file.write.write_spec[spec1].kw),
10921 ffelex_token_where_column
10922 (ffestp_file.write.write_spec[spec1].kw));
10923 }
10924 else
10925 {
10926 ffebad_here (0, ffelex_token_where_line
10927 (ffestp_file.write.write_spec[spec1].value),
10928 ffelex_token_where_column
10929 (ffestp_file.write.write_spec[spec1].value));
10930 }
10931 assert (ffestp_file.write.write_spec[spec2].kw_or_val_present);
10932 if (ffestp_file.write.write_spec[spec2].kw_present)
10933 {
10934 ffebad_here (1, ffelex_token_where_line
10935 (ffestp_file.write.write_spec[spec2].kw),
10936 ffelex_token_where_column
10937 (ffestp_file.write.write_spec[spec2].kw));
10938 }
10939 else
10940 {
10941 ffebad_here (1, ffelex_token_where_line
10942 (ffestp_file.write.write_spec[spec2].value),
10943 ffelex_token_where_column
10944 (ffestp_file.write.write_spec[spec2].value));
10945 }
10946 ffebad_finish ();
10947 ffestc_ok_ = FALSE;
10948 return;
10949 }
10950 if ((format == FFESTV_formatASTERISK)
10951 || (format == FFESTV_formatNAMELIST))
10952 {
10953 spec2 = FFESTP_writeixFORMAT;
10954 goto whine; /* :::::::::::::::::::: */
10955 }
10956 if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw_or_val_present)
10957 {
10958 spec2 = FFESTP_writeixADVANCE;
10959 goto whine; /* :::::::::::::::::::: */
10960 }
10961 }
10962 else
10963 { /* Sequential/Indexed/Internal. */
10964 if (unit == FFESTV_unitCHAREXPR)
10965 { /* Internal file. */
10966 spec1 = FFESTP_writeixUNIT;
10967 if (format == FFESTV_formatNAMELIST)
10968 {
10969 spec2 = FFESTP_writeixFORMAT;
10970 goto whine; /* :::::::::::::::::::: */
10971 }
10972 if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw_or_val_present)
10973 {
10974 spec2 = FFESTP_writeixADVANCE;
10975 goto whine; /* :::::::::::::::::::: */
10976 }
10977 }
10978 if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw_or_val_present)
10979 { /* ADVANCE= specified. */
10980 spec1 = FFESTP_writeixADVANCE;
10981 if (format == FFESTV_formatNONE)
10982 {
10983 ffebad_start (FFEBAD_MISSING_FORMAT_SPEC);
10984 ffebad_here (0, ffelex_token_where_line
10985 (ffestp_file.write.write_spec[spec1].kw),
10986 ffelex_token_where_column
10987 (ffestp_file.write.write_spec[spec1].kw));
10988 ffebad_finish ();
10989
10990 ffestc_ok_ = FALSE;
10991 return;
10992 }
10993 if (format == FFESTV_formatNAMELIST)
10994 {
10995 spec2 = FFESTP_writeixFORMAT;
10996 goto whine; /* :::::::::::::::::::: */
10997 }
10998 }
10999 if (ffestp_file.write.write_spec[FFESTP_writeixEOR].kw_or_val_present)
11000 { /* EOR= specified. */
11001 spec1 = FFESTP_writeixEOR;
11002 if (ffestc_subr_speccmp_ ("No",
11003 &ffestp_file.write.write_spec[FFESTP_writeixADVANCE],
11004 NULL, NULL) != 0)
11005 {
11006 if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE]
11007 .kw_or_val_present)
11008 {
11009 ffebad_start (FFEBAD_CONFLICTING_SPECS);
11010 ffebad_here (0, ffelex_token_where_line
11011 (ffestp_file.write.write_spec[spec1].kw),
11012 ffelex_token_where_column
11013 (ffestp_file.write.write_spec[spec1].kw));
11014 ffebad_here (1, ffelex_token_where_line
11015 (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw),
11016 ffelex_token_where_column
11017 (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw));
11018 ffebad_finish ();
11019 }
11020 else
11021 {
11022 ffebad_start (FFEBAD_MISSING_ADVANCE_SPEC);
11023 ffebad_here (0, ffelex_token_where_line
11024 (ffestp_file.write.write_spec[spec1].kw),
11025 ffelex_token_where_column
11026 (ffestp_file.write.write_spec[spec1].kw));
11027 ffebad_finish ();
11028 }
11029
11030 ffestc_ok_ = FALSE;
11031 return;
11032 }
11033 }
11034 }
11035
11036 if (unit == FFESTV_unitCHAREXPR)
11037 ffestc_iolist_context_ = FFEEXPR_contextIOLISTDF;
11038 else
11039 ffestc_iolist_context_ = FFEEXPR_contextIOLIST;
11040
11041 ffestd_R910_start (unit, format, rec);
11042
11043 ffestc_ok_ = TRUE;
11044 }
11045
11046 /* ffestc_R910_item -- WRITE statement i/o item
11047
11048 ffestc_R910_item(expr,expr_token);
11049
11050 Implement output-list expression. */
11051
11052 void
ffestc_R910_item(ffebld expr,ffelexToken expr_token)11053 ffestc_R910_item (ffebld expr, ffelexToken expr_token)
11054 {
11055 ffestc_check_item_ ();
11056 if (!ffestc_ok_)
11057 return;
11058
11059 if (ffestc_namelist_ != 0)
11060 {
11061 if (ffestc_namelist_ == 1)
11062 {
11063 ffestc_namelist_ = 2;
11064 ffebad_start (FFEBAD_NAMELIST_ITEMS);
11065 ffebad_here (0, ffelex_token_where_line (expr_token),
11066 ffelex_token_where_column (expr_token));
11067 ffebad_finish ();
11068 }
11069 return;
11070 }
11071
11072 ffestd_R910_item (expr, expr_token);
11073 }
11074
11075 /* ffestc_R910_finish -- WRITE statement list complete
11076
11077 ffestc_R910_finish();
11078
11079 Just wrap up any local activities. */
11080
11081 void
ffestc_R910_finish()11082 ffestc_R910_finish ()
11083 {
11084 ffestc_check_finish_ ();
11085 if (!ffestc_ok_)
11086 return;
11087
11088 ffestd_R910_finish ();
11089
11090 if (ffestc_shriek_after1_ != NULL)
11091 (*ffestc_shriek_after1_) (TRUE);
11092 ffestc_labeldef_branch_end_ ();
11093 }
11094
11095 /* ffestc_R911_start -- PRINT(...) statement list begin
11096
11097 ffestc_R911_start();
11098
11099 Verify that PRINT is valid here, and begin accepting items in the
11100 list. */
11101
11102 void
ffestc_R911_start()11103 ffestc_R911_start ()
11104 {
11105 ffestvFormat format;
11106
11107 ffestc_check_start_ ();
11108 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
11109 {
11110 ffestc_ok_ = FALSE;
11111 return;
11112 }
11113 ffestc_labeldef_branch_begin_ ();
11114
11115 if (!ffestc_subr_is_format_
11116 (&ffestp_file.print.print_spec[FFESTP_printixFORMAT]))
11117 {
11118 ffestc_ok_ = FALSE;
11119 return;
11120 }
11121
11122 format = ffestc_subr_format_
11123 (&ffestp_file.print.print_spec[FFESTP_printixFORMAT]);
11124 ffestc_namelist_ = (format == FFESTV_formatNAMELIST);
11125
11126 ffestd_R911_start (format);
11127
11128 ffestc_ok_ = TRUE;
11129 }
11130
11131 /* ffestc_R911_item -- PRINT statement i/o item
11132
11133 ffestc_R911_item(expr,expr_token);
11134
11135 Implement output-list expression. */
11136
11137 void
ffestc_R911_item(ffebld expr,ffelexToken expr_token)11138 ffestc_R911_item (ffebld expr, ffelexToken expr_token)
11139 {
11140 ffestc_check_item_ ();
11141 if (!ffestc_ok_)
11142 return;
11143
11144 if (ffestc_namelist_ != 0)
11145 {
11146 if (ffestc_namelist_ == 1)
11147 {
11148 ffestc_namelist_ = 2;
11149 ffebad_start (FFEBAD_NAMELIST_ITEMS);
11150 ffebad_here (0, ffelex_token_where_line (expr_token),
11151 ffelex_token_where_column (expr_token));
11152 ffebad_finish ();
11153 }
11154 return;
11155 }
11156
11157 ffestd_R911_item (expr, expr_token);
11158 }
11159
11160 /* ffestc_R911_finish -- PRINT statement list complete
11161
11162 ffestc_R911_finish();
11163
11164 Just wrap up any local activities. */
11165
11166 void
ffestc_R911_finish()11167 ffestc_R911_finish ()
11168 {
11169 ffestc_check_finish_ ();
11170 if (!ffestc_ok_)
11171 return;
11172
11173 ffestd_R911_finish ();
11174
11175 if (ffestc_shriek_after1_ != NULL)
11176 (*ffestc_shriek_after1_) (TRUE);
11177 ffestc_labeldef_branch_end_ ();
11178 }
11179
11180 /* ffestc_R919 -- BACKSPACE statement
11181
11182 ffestc_R919();
11183
11184 Make sure a BACKSPACE is valid in the current context, and implement it. */
11185
11186 void
ffestc_R919()11187 ffestc_R919 ()
11188 {
11189 ffestc_check_simple_ ();
11190 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
11191 return;
11192 ffestc_labeldef_branch_begin_ ();
11193
11194 if (ffestc_subr_is_branch_
11195 (&ffestp_file.beru.beru_spec[FFESTP_beruixERR])
11196 && ffestc_subr_is_present_ ("UNIT",
11197 &ffestp_file.beru.beru_spec[FFESTP_beruixUNIT]))
11198 ffestd_R919 ();
11199
11200 if (ffestc_shriek_after1_ != NULL)
11201 (*ffestc_shriek_after1_) (TRUE);
11202 ffestc_labeldef_branch_end_ ();
11203 }
11204
11205 /* ffestc_R920 -- ENDFILE statement
11206
11207 ffestc_R920();
11208
11209 Make sure a ENDFILE is valid in the current context, and implement it. */
11210
11211 void
ffestc_R920()11212 ffestc_R920 ()
11213 {
11214 ffestc_check_simple_ ();
11215 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
11216 return;
11217 ffestc_labeldef_branch_begin_ ();
11218
11219 if (ffestc_subr_is_branch_
11220 (&ffestp_file.beru.beru_spec[FFESTP_beruixERR])
11221 && ffestc_subr_is_present_ ("UNIT",
11222 &ffestp_file.beru.beru_spec[FFESTP_beruixUNIT]))
11223 ffestd_R920 ();
11224
11225 if (ffestc_shriek_after1_ != NULL)
11226 (*ffestc_shriek_after1_) (TRUE);
11227 ffestc_labeldef_branch_end_ ();
11228 }
11229
11230 /* ffestc_R921 -- REWIND statement
11231
11232 ffestc_R921();
11233
11234 Make sure a REWIND is valid in the current context, and implement it. */
11235
11236 void
ffestc_R921()11237 ffestc_R921 ()
11238 {
11239 ffestc_check_simple_ ();
11240 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
11241 return;
11242 ffestc_labeldef_branch_begin_ ();
11243
11244 if (ffestc_subr_is_branch_
11245 (&ffestp_file.beru.beru_spec[FFESTP_beruixERR])
11246 && ffestc_subr_is_present_ ("UNIT",
11247 &ffestp_file.beru.beru_spec[FFESTP_beruixUNIT]))
11248 ffestd_R921 ();
11249
11250 if (ffestc_shriek_after1_ != NULL)
11251 (*ffestc_shriek_after1_) (TRUE);
11252 ffestc_labeldef_branch_end_ ();
11253 }
11254
11255 /* ffestc_R923A -- INQUIRE statement (non-IOLENGTH version)
11256
11257 ffestc_R923A();
11258
11259 Make sure an INQUIRE is valid in the current context, and implement it. */
11260
11261 void
ffestc_R923A()11262 ffestc_R923A ()
11263 {
11264 bool by_file;
11265 bool by_unit;
11266
11267 ffestc_check_simple_ ();
11268 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
11269 return;
11270 ffestc_labeldef_branch_begin_ ();
11271
11272 if (ffestc_subr_is_branch_
11273 (&ffestp_file.inquire.inquire_spec[FFESTP_inquireixERR]))
11274 {
11275 by_file = ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE]
11276 .kw_or_val_present;
11277 by_unit = ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT]
11278 .kw_or_val_present;
11279 if (by_file && by_unit)
11280 {
11281 ffebad_start (FFEBAD_CONFLICTING_SPECS);
11282 assert (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw_or_val_present);
11283 if (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw_present)
11284 {
11285 ffebad_here (0, ffelex_token_where_line
11286 (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw),
11287 ffelex_token_where_column
11288 (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw));
11289 }
11290 else
11291 {
11292 ffebad_here (0, ffelex_token_where_line
11293 (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].value),
11294 ffelex_token_where_column
11295 (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].value));
11296 }
11297 assert (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw_or_val_present);
11298 if (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw_present)
11299 {
11300 ffebad_here (1, ffelex_token_where_line
11301 (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw),
11302 ffelex_token_where_column
11303 (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw));
11304 }
11305 else
11306 {
11307 ffebad_here (1, ffelex_token_where_line
11308 (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].value),
11309 ffelex_token_where_column
11310 (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].value));
11311 }
11312 ffebad_finish ();
11313 }
11314 else if (!by_file && !by_unit)
11315 {
11316 ffebad_start (FFEBAD_MISSING_SPECIFIER);
11317 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
11318 ffelex_token_where_column (ffesta_tokens[0]));
11319 ffebad_string ("UNIT= or FILE=");
11320 ffebad_finish ();
11321 }
11322 else
11323 ffestd_R923A (by_file);
11324 }
11325
11326 if (ffestc_shriek_after1_ != NULL)
11327 (*ffestc_shriek_after1_) (TRUE);
11328 ffestc_labeldef_branch_end_ ();
11329 }
11330
11331 /* ffestc_R923B_start -- INQUIRE(IOLENGTH=expr) statement list begin
11332
11333 ffestc_R923B_start();
11334
11335 Verify that INQUIRE is valid here, and begin accepting items in the
11336 list. */
11337
11338 void
ffestc_R923B_start()11339 ffestc_R923B_start ()
11340 {
11341 ffestc_check_start_ ();
11342 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
11343 {
11344 ffestc_ok_ = FALSE;
11345 return;
11346 }
11347 ffestc_labeldef_branch_begin_ ();
11348
11349 ffestd_R923B_start ();
11350
11351 ffestc_ok_ = TRUE;
11352 }
11353
11354 /* ffestc_R923B_item -- INQUIRE statement i/o item
11355
11356 ffestc_R923B_item(expr,expr_token);
11357
11358 Implement output-list expression. */
11359
11360 void
ffestc_R923B_item(ffebld expr,ffelexToken expr_token UNUSED)11361 ffestc_R923B_item (ffebld expr, ffelexToken expr_token UNUSED)
11362 {
11363 ffestc_check_item_ ();
11364 if (!ffestc_ok_)
11365 return;
11366
11367 ffestd_R923B_item (expr);
11368 }
11369
11370 /* ffestc_R923B_finish -- INQUIRE statement list complete
11371
11372 ffestc_R923B_finish();
11373
11374 Just wrap up any local activities. */
11375
11376 void
ffestc_R923B_finish()11377 ffestc_R923B_finish ()
11378 {
11379 ffestc_check_finish_ ();
11380 if (!ffestc_ok_)
11381 return;
11382
11383 ffestd_R923B_finish ();
11384
11385 if (ffestc_shriek_after1_ != NULL)
11386 (*ffestc_shriek_after1_) (TRUE);
11387 ffestc_labeldef_branch_end_ ();
11388 }
11389
11390 /* ffestc_R1001 -- FORMAT statement
11391
11392 ffestc_R1001(format_list);
11393
11394 Make sure format_list is valid. Update label's info to indicate it is a
11395 FORMAT label, and (perhaps) warn if there is no label! */
11396
11397 void
ffestc_R1001(ffesttFormatList f)11398 ffestc_R1001 (ffesttFormatList f)
11399 {
11400 ffestc_check_simple_ ();
11401 if (ffestc_order_format_ () != FFESTC_orderOK_)
11402 return;
11403 ffestc_labeldef_format_ ();
11404
11405 ffestd_R1001 (f);
11406 }
11407
11408 /* ffestc_R1102 -- PROGRAM statement
11409
11410 ffestc_R1102(name_token);
11411
11412 Make sure ffestc_kind_ identifies an empty block. Make sure name_token
11413 gives a valid name. Implement the beginning of a main program. */
11414
11415 void
ffestc_R1102(ffelexToken name)11416 ffestc_R1102 (ffelexToken name)
11417 {
11418 ffestw b;
11419 ffesymbol s;
11420
11421 assert (name != NULL);
11422
11423 ffestc_check_simple_ ();
11424 if (ffestc_order_unit_ () != FFESTC_orderOK_)
11425 return;
11426 ffestc_labeldef_useless_ ();
11427
11428 ffestc_blocknum_ = 0;
11429 b = ffestw_update (ffestw_push (NULL));
11430 ffestw_set_top_do (b, NULL);
11431 ffestw_set_state (b, FFESTV_statePROGRAM0);
11432 ffestw_set_blocknum (b, ffestc_blocknum_++);
11433 ffestw_set_shriek (b, ffestc_shriek_end_program_);
11434
11435 ffestw_set_name (b, ffelex_token_use (name));
11436
11437 s = ffesymbol_declare_programunit (name,
11438 ffelex_token_where_line (ffesta_tokens[0]),
11439 ffelex_token_where_column (ffesta_tokens[0]));
11440
11441 if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
11442 {
11443 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
11444 ffesymbol_set_info (s,
11445 ffeinfo_new (FFEINFO_basictypeNONE,
11446 FFEINFO_kindtypeNONE,
11447 0,
11448 FFEINFO_kindPROGRAM,
11449 FFEINFO_whereLOCAL,
11450 FFETARGET_charactersizeNONE));
11451 ffesymbol_signal_unreported (s);
11452 }
11453 else
11454 ffesymbol_error (s, name);
11455
11456 ffestd_R1102 (s, name);
11457 }
11458
11459 /* ffestc_R1103 -- END PROGRAM statement
11460
11461 ffestc_R1103(name_token);
11462
11463 Make sure ffestc_kind_ identifies the current kind of program unit. If not
11464 NULL, make sure name_token gives the correct name. Implement the end
11465 of the current program unit. */
11466
11467 void
ffestc_R1103(ffelexToken name)11468 ffestc_R1103 (ffelexToken name)
11469 {
11470 ffestc_check_simple_ ();
11471 if (ffestc_order_program_ () != FFESTC_orderOK_)
11472 return;
11473 ffestc_labeldef_notloop_ ();
11474
11475 if (name != NULL)
11476 {
11477 if (ffestw_name (ffestw_stack_top ()) == NULL)
11478 {
11479 ffebad_start (FFEBAD_PROGRAM_NOT_NAMED);
11480 ffebad_here (0, ffelex_token_where_line (name),
11481 ffelex_token_where_column (name));
11482 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
11483 ffebad_finish ();
11484 }
11485 else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)
11486 {
11487 ffebad_start (FFEBAD_UNIT_WRONG_NAME);
11488 ffebad_here (0, ffelex_token_where_line (name),
11489 ffelex_token_where_column (name));
11490 ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
11491 ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
11492 ffebad_finish ();
11493 }
11494 }
11495
11496 ffestc_shriek_end_program_ (TRUE);
11497 }
11498
11499 /* ffestc_R1105 -- MODULE statement
11500
11501 ffestc_R1105(name_token);
11502
11503 Make sure ffestc_kind_ identifies an empty block. Make sure name_token
11504 gives a valid name. Implement the beginning of a module. */
11505
11506 #if FFESTR_F90
11507 void
ffestc_R1105(ffelexToken name)11508 ffestc_R1105 (ffelexToken name)
11509 {
11510 ffestw b;
11511
11512 assert (name != NULL);
11513
11514 ffestc_check_simple_ ();
11515 if (ffestc_order_unit_ () != FFESTC_orderOK_)
11516 return;
11517 ffestc_labeldef_useless_ ();
11518
11519 ffestc_blocknum_ = 0;
11520 b = ffestw_update (ffestw_push (NULL));
11521 ffestw_set_top_do (b, NULL);
11522 ffestw_set_state (b, FFESTV_stateMODULE0);
11523 ffestw_set_blocknum (b, ffestc_blocknum_++);
11524 ffestw_set_shriek (b, ffestc_shriek_module_);
11525 ffestw_set_name (b, ffelex_token_use (name));
11526
11527 ffestd_R1105 (name);
11528 }
11529
11530 /* ffestc_R1106 -- END MODULE statement
11531
11532 ffestc_R1106(name_token);
11533
11534 Make sure ffestc_kind_ identifies the current kind of program unit. If not
11535 NULL, make sure name_token gives the correct name. Implement the end
11536 of the current program unit. */
11537
11538 void
ffestc_R1106(ffelexToken name)11539 ffestc_R1106 (ffelexToken name)
11540 {
11541 ffestc_check_simple_ ();
11542 if (ffestc_order_module_ () != FFESTC_orderOK_)
11543 return;
11544 ffestc_labeldef_useless_ ();
11545
11546 if ((name != NULL)
11547 && (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0))
11548 {
11549 ffebad_start (FFEBAD_UNIT_WRONG_NAME);
11550 ffebad_here (0, ffelex_token_where_line (name),
11551 ffelex_token_where_column (name));
11552 ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
11553 ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
11554 ffebad_finish ();
11555 }
11556
11557 ffestc_shriek_module_ (TRUE);
11558 }
11559
11560 /* ffestc_R1107_start -- USE statement list begin
11561
11562 ffestc_R1107_start();
11563
11564 Verify that USE is valid here, and begin accepting items in the list. */
11565
11566 void
ffestc_R1107_start(ffelexToken name,bool only)11567 ffestc_R1107_start (ffelexToken name, bool only)
11568 {
11569 ffestc_check_start_ ();
11570 if (ffestc_order_use_ () != FFESTC_orderOK_)
11571 {
11572 ffestc_ok_ = FALSE;
11573 return;
11574 }
11575 ffestc_labeldef_useless_ ();
11576
11577 ffestd_R1107_start (name, only);
11578
11579 ffestc_ok_ = TRUE;
11580 }
11581
11582 /* ffestc_R1107_item -- USE statement for name
11583
11584 ffestc_R1107_item(local_token,use_token);
11585
11586 Make sure name_token identifies a valid object to be USEed. local_token
11587 may be NULL if _start_ was called with only==TRUE. */
11588
11589 void
ffestc_R1107_item(ffelexToken local,ffelexToken use)11590 ffestc_R1107_item (ffelexToken local, ffelexToken use)
11591 {
11592 ffestc_check_item_ ();
11593 assert (use != NULL);
11594 if (!ffestc_ok_)
11595 return;
11596
11597 ffestd_R1107_item (local, use);
11598 }
11599
11600 /* ffestc_R1107_finish -- USE statement list complete
11601
11602 ffestc_R1107_finish();
11603
11604 Just wrap up any local activities. */
11605
11606 void
ffestc_R1107_finish()11607 ffestc_R1107_finish ()
11608 {
11609 ffestc_check_finish_ ();
11610 if (!ffestc_ok_)
11611 return;
11612
11613 ffestd_R1107_finish ();
11614 }
11615
11616 #endif
11617 /* ffestc_R1111 -- BLOCK DATA statement
11618
11619 ffestc_R1111(name_token);
11620
11621 Make sure ffestc_kind_ identifies no current program unit. If not
11622 NULL, make sure name_token gives a valid name. Implement the beginning
11623 of a block data program unit. */
11624
11625 void
ffestc_R1111(ffelexToken name)11626 ffestc_R1111 (ffelexToken name)
11627 {
11628 ffestw b;
11629 ffesymbol s;
11630
11631 ffestc_check_simple_ ();
11632 if (ffestc_order_unit_ () != FFESTC_orderOK_)
11633 return;
11634 ffestc_labeldef_useless_ ();
11635
11636 ffestc_blocknum_ = 0;
11637 b = ffestw_update (ffestw_push (NULL));
11638 ffestw_set_top_do (b, NULL);
11639 ffestw_set_state (b, FFESTV_stateBLOCKDATA0);
11640 ffestw_set_blocknum (b, ffestc_blocknum_++);
11641 ffestw_set_shriek (b, ffestc_shriek_blockdata_);
11642
11643 if (name == NULL)
11644 ffestw_set_name (b, NULL);
11645 else
11646 ffestw_set_name (b, ffelex_token_use (name));
11647
11648 s = ffesymbol_declare_blockdataunit (name,
11649 ffelex_token_where_line (ffesta_tokens[0]),
11650 ffelex_token_where_column (ffesta_tokens[0]));
11651
11652 if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
11653 {
11654 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
11655 ffesymbol_set_info (s,
11656 ffeinfo_new (FFEINFO_basictypeNONE,
11657 FFEINFO_kindtypeNONE,
11658 0,
11659 FFEINFO_kindBLOCKDATA,
11660 FFEINFO_whereLOCAL,
11661 FFETARGET_charactersizeNONE));
11662 ffesymbol_signal_unreported (s);
11663 }
11664 else
11665 ffesymbol_error (s, name);
11666
11667 ffestd_R1111 (s, name);
11668 }
11669
11670 /* ffestc_R1112 -- END BLOCK DATA statement
11671
11672 ffestc_R1112(name_token);
11673
11674 Make sure ffestc_kind_ identifies the current kind of program unit. If not
11675 NULL, make sure name_token gives the correct name. Implement the end
11676 of the current program unit. */
11677
11678 void
ffestc_R1112(ffelexToken name)11679 ffestc_R1112 (ffelexToken name)
11680 {
11681 ffestc_check_simple_ ();
11682 if (ffestc_order_blockdata_ () != FFESTC_orderOK_)
11683 return;
11684 ffestc_labeldef_useless_ ();
11685
11686 if (name != NULL)
11687 {
11688 if (ffestw_name (ffestw_stack_top ()) == NULL)
11689 {
11690 ffebad_start (FFEBAD_BLOCKDATA_NOT_NAMED);
11691 ffebad_here (0, ffelex_token_where_line (name),
11692 ffelex_token_where_column (name));
11693 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
11694 ffebad_finish ();
11695 }
11696 else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)
11697 {
11698 ffebad_start (FFEBAD_UNIT_WRONG_NAME);
11699 ffebad_here (0, ffelex_token_where_line (name),
11700 ffelex_token_where_column (name));
11701 ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
11702 ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
11703 ffebad_finish ();
11704 }
11705 }
11706
11707 ffestc_shriek_blockdata_ (TRUE);
11708 }
11709
11710 /* ffestc_R1202 -- INTERFACE statement
11711
11712 ffestc_R1202(operator,defined_name);
11713
11714 Make sure ffestc_kind_ identifies an INTERFACE block.
11715 Implement the end of the current interface.
11716
11717 15-May-90 JCB 1.1
11718 Allow no operator or name to mean INTERFACE by itself; missed this
11719 valid form when originally doing syntactic analysis code. */
11720
11721 #if FFESTR_F90
11722 void
ffestc_R1202(ffestpDefinedOperator operator,ffelexToken name)11723 ffestc_R1202 (ffestpDefinedOperator operator, ffelexToken name)
11724 {
11725 ffestw b;
11726
11727 ffestc_check_simple_ ();
11728 if (ffestc_order_interfacespec_ () != FFESTC_orderOK_)
11729 return;
11730 ffestc_labeldef_useless_ ();
11731
11732 b = ffestw_update (ffestw_push (NULL));
11733 ffestw_set_top_do (b, NULL);
11734 ffestw_set_state (b, FFESTV_stateINTERFACE0);
11735 ffestw_set_blocknum (b, 0);
11736 ffestw_set_shriek (b, ffestc_shriek_interface_);
11737
11738 if ((operator == FFESTP_definedoperatorNone) && (name == NULL))
11739 ffestw_set_substate (b, 0); /* No generic-spec, so disallow MODULE
11740 PROCEDURE. */
11741 else
11742 ffestw_set_substate (b, 1); /* MODULE PROCEDURE ok. */
11743
11744 ffestd_R1202 (operator, name);
11745
11746 ffe_init_4 ();
11747 }
11748
11749 /* ffestc_R1203 -- END INTERFACE statement
11750
11751 ffestc_R1203();
11752
11753 Make sure ffestc_kind_ identifies an INTERFACE block.
11754 Implement the end of the current interface. */
11755
11756 void
ffestc_R1203()11757 ffestc_R1203 ()
11758 {
11759 ffestc_check_simple_ ();
11760 if (ffestc_order_interface_ () != FFESTC_orderOK_)
11761 return;
11762 ffestc_labeldef_useless_ ();
11763
11764 ffestc_shriek_interface_ (TRUE);
11765
11766 ffe_terminate_4 ();
11767 }
11768
11769 /* ffestc_R1205_start -- MODULE PROCEDURE statement list begin
11770
11771 ffestc_R1205_start();
11772
11773 Verify that MODULE PROCEDURE is valid here, and begin accepting items in
11774 the list. */
11775
11776 void
ffestc_R1205_start()11777 ffestc_R1205_start ()
11778 {
11779 ffestc_check_start_ ();
11780 if (ffestc_order_interface_ () != FFESTC_orderOK_)
11781 {
11782 ffestc_ok_ = FALSE;
11783 return;
11784 }
11785 ffestc_labeldef_useless_ ();
11786
11787 if (ffestw_substate (ffestw_stack_top ()) == 0)
11788 {
11789 ffebad_start (FFEBAD_INVALID_MODULE_PROCEDURE);
11790 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
11791 ffelex_token_where_column (ffesta_tokens[0]));
11792 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
11793 ffebad_finish ();
11794 ffestc_ok_ = FALSE;
11795 return;
11796 }
11797
11798 if (ffestw_state (ffestw_stack_top ()) == FFESTV_stateINTERFACE0)
11799 {
11800 ffestw_update (NULL); /* Update state line/col info. */
11801 ffestw_set_state (ffestw_stack_top (), FFESTV_stateINTERFACE1);
11802 }
11803
11804 ffestd_R1205_start ();
11805
11806 ffestc_ok_ = TRUE;
11807 }
11808
11809 /* ffestc_R1205_item -- MODULE PROCEDURE statement for name
11810
11811 ffestc_R1205_item(name_token);
11812
11813 Make sure name_token identifies a valid object to be MODULE PROCEDUREed. */
11814
11815 void
ffestc_R1205_item(ffelexToken name)11816 ffestc_R1205_item (ffelexToken name)
11817 {
11818 ffestc_check_item_ ();
11819 assert (name != NULL);
11820 if (!ffestc_ok_)
11821 return;
11822
11823 ffestd_R1205_item (name);
11824 }
11825
11826 /* ffestc_R1205_finish -- MODULE PROCEDURE statement list complete
11827
11828 ffestc_R1205_finish();
11829
11830 Just wrap up any local activities. */
11831
11832 void
ffestc_R1205_finish()11833 ffestc_R1205_finish ()
11834 {
11835 ffestc_check_finish_ ();
11836 if (!ffestc_ok_)
11837 return;
11838
11839 ffestd_R1205_finish ();
11840 }
11841
11842 #endif
11843 /* ffestc_R1207_start -- EXTERNAL statement list begin
11844
11845 ffestc_R1207_start();
11846
11847 Verify that EXTERNAL is valid here, and begin accepting items in the list. */
11848
11849 void
ffestc_R1207_start()11850 ffestc_R1207_start ()
11851 {
11852 ffestc_check_start_ ();
11853 if (ffestc_order_progspec_ () != FFESTC_orderOK_)
11854 {
11855 ffestc_ok_ = FALSE;
11856 return;
11857 }
11858 ffestc_labeldef_useless_ ();
11859
11860 ffestd_R1207_start ();
11861
11862 ffestc_ok_ = TRUE;
11863 }
11864
11865 /* ffestc_R1207_item -- EXTERNAL statement for name
11866
11867 ffestc_R1207_item(name_token);
11868
11869 Make sure name_token identifies a valid object to be EXTERNALd. */
11870
11871 void
ffestc_R1207_item(ffelexToken name)11872 ffestc_R1207_item (ffelexToken name)
11873 {
11874 ffesymbol s;
11875 ffesymbolAttrs sa;
11876 ffesymbolAttrs na;
11877
11878 ffestc_check_item_ ();
11879 assert (name != NULL);
11880 if (!ffestc_ok_)
11881 return;
11882
11883 s = ffesymbol_declare_local (name, FALSE);
11884 sa = ffesymbol_attrs (s);
11885
11886 /* Figure out what kind of object we've got based on previous declarations
11887 of or references to the object. */
11888
11889 if (!ffesymbol_is_specable (s))
11890 na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
11891 else if (sa & FFESYMBOL_attrsANY)
11892 na = FFESYMBOL_attrsANY;
11893 else if (!(sa & ~(FFESYMBOL_attrsDUMMY
11894 | FFESYMBOL_attrsTYPE)))
11895 na = sa | FFESYMBOL_attrsEXTERNAL;
11896 else
11897 na = FFESYMBOL_attrsetNONE;
11898
11899 /* Now see what we've got for a new object: NONE means a new error cropped
11900 up; ANY means an old error to be ignored; otherwise, everything's ok,
11901 update the object (symbol) and continue on. */
11902
11903 if (na == FFESYMBOL_attrsetNONE)
11904 ffesymbol_error (s, name);
11905 else if (!(na & FFESYMBOL_attrsANY))
11906 {
11907 ffesymbol_set_attrs (s, na);
11908 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
11909 ffesymbol_set_explicitwhere (s, TRUE);
11910 ffesymbol_reference (s, name, FALSE);
11911 ffesymbol_signal_unreported (s);
11912 }
11913
11914 ffestd_R1207_item (name);
11915 }
11916
11917 /* ffestc_R1207_finish -- EXTERNAL statement list complete
11918
11919 ffestc_R1207_finish();
11920
11921 Just wrap up any local activities. */
11922
11923 void
ffestc_R1207_finish()11924 ffestc_R1207_finish ()
11925 {
11926 ffestc_check_finish_ ();
11927 if (!ffestc_ok_)
11928 return;
11929
11930 ffestd_R1207_finish ();
11931 }
11932
11933 /* ffestc_R1208_start -- INTRINSIC statement list begin
11934
11935 ffestc_R1208_start();
11936
11937 Verify that INTRINSIC is valid here, and begin accepting items in the list. */
11938
11939 void
ffestc_R1208_start()11940 ffestc_R1208_start ()
11941 {
11942 ffestc_check_start_ ();
11943 if (ffestc_order_progspec_ () != FFESTC_orderOK_)
11944 {
11945 ffestc_ok_ = FALSE;
11946 return;
11947 }
11948 ffestc_labeldef_useless_ ();
11949
11950 ffestd_R1208_start ();
11951
11952 ffestc_ok_ = TRUE;
11953 }
11954
11955 /* ffestc_R1208_item -- INTRINSIC statement for name
11956
11957 ffestc_R1208_item(name_token);
11958
11959 Make sure name_token identifies a valid object to be INTRINSICd. */
11960
11961 void
ffestc_R1208_item(ffelexToken name)11962 ffestc_R1208_item (ffelexToken name)
11963 {
11964 ffesymbol s;
11965 ffesymbolAttrs sa;
11966 ffesymbolAttrs na;
11967 ffeintrinGen gen;
11968 ffeintrinSpec spec;
11969 ffeintrinImp imp;
11970
11971 ffestc_check_item_ ();
11972 assert (name != NULL);
11973 if (!ffestc_ok_)
11974 return;
11975
11976 s = ffesymbol_declare_local (name, TRUE);
11977 sa = ffesymbol_attrs (s);
11978
11979 /* Figure out what kind of object we've got based on previous declarations
11980 of or references to the object. */
11981
11982 if (!ffesymbol_is_specable (s))
11983 na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
11984 else if (sa & FFESYMBOL_attrsANY)
11985 na = sa;
11986 else if (!(sa & ~FFESYMBOL_attrsTYPE))
11987 {
11988 if (ffeintrin_is_intrinsic (ffelex_token_text (name), name, TRUE,
11989 &gen, &spec, &imp)
11990 && ((imp == FFEINTRIN_impNONE)
11991 #if 0 /* Don't bother with this for now. */
11992 || ((ffeintrin_basictype (spec)
11993 == ffesymbol_basictype (s))
11994 && (ffeintrin_kindtype (spec)
11995 == ffesymbol_kindtype (s)))
11996 #else
11997 || 1
11998 #endif
11999 || !(sa & FFESYMBOL_attrsTYPE)))
12000 na = sa | FFESYMBOL_attrsINTRINSIC;
12001 else
12002 na = FFESYMBOL_attrsetNONE;
12003 }
12004 else
12005 na = FFESYMBOL_attrsetNONE;
12006
12007 /* Now see what we've got for a new object: NONE means a new error cropped
12008 up; ANY means an old error to be ignored; otherwise, everything's ok,
12009 update the object (symbol) and continue on. */
12010
12011 if (na == FFESYMBOL_attrsetNONE)
12012 ffesymbol_error (s, name);
12013 else if (!(na & FFESYMBOL_attrsANY))
12014 {
12015 ffesymbol_set_attrs (s, na);
12016 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
12017 ffesymbol_set_generic (s, gen);
12018 ffesymbol_set_specific (s, spec);
12019 ffesymbol_set_implementation (s, imp);
12020 ffesymbol_set_info (s,
12021 ffeinfo_new (ffesymbol_basictype (s),
12022 ffesymbol_kindtype (s),
12023 0,
12024 FFEINFO_kindNONE,
12025 FFEINFO_whereINTRINSIC,
12026 ffesymbol_size (s)));
12027 ffesymbol_set_explicitwhere (s, TRUE);
12028 ffesymbol_reference (s, name, TRUE);
12029 }
12030
12031 ffesymbol_signal_unreported (s);
12032
12033 ffestd_R1208_item (name);
12034 }
12035
12036 /* ffestc_R1208_finish -- INTRINSIC statement list complete
12037
12038 ffestc_R1208_finish();
12039
12040 Just wrap up any local activities. */
12041
12042 void
ffestc_R1208_finish()12043 ffestc_R1208_finish ()
12044 {
12045 ffestc_check_finish_ ();
12046 if (!ffestc_ok_)
12047 return;
12048
12049 ffestd_R1208_finish ();
12050 }
12051
12052 /* ffestc_R1212 -- CALL statement
12053
12054 ffestc_R1212(expr,expr_token);
12055
12056 Make sure statement is valid here; implement. */
12057
12058 void
ffestc_R1212(ffebld expr,ffelexToken expr_token UNUSED)12059 ffestc_R1212 (ffebld expr, ffelexToken expr_token UNUSED)
12060 {
12061 ffebld item; /* ITEM. */
12062 ffebld labexpr; /* LABTOK=>LABTER. */
12063 ffelab label;
12064 bool ok; /* TRUE if all LABTOKs were ok. */
12065 bool ok1; /* TRUE if a particular LABTOK is ok. */
12066
12067 ffestc_check_simple_ ();
12068 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
12069 return;
12070 ffestc_labeldef_branch_begin_ ();
12071
12072 if (ffebld_op (expr) != FFEBLD_opSUBRREF)
12073 ffestd_R841 (FALSE); /* CONTINUE. */
12074 else
12075 {
12076 ok = TRUE;
12077
12078 for (item = ffebld_right (expr);
12079 item != NULL;
12080 item = ffebld_trail (item))
12081 {
12082 if (((labexpr = ffebld_head (item)) != NULL)
12083 && (ffebld_op (labexpr) == FFEBLD_opLABTOK))
12084 {
12085 ok1 = ffestc_labelref_is_branch_ (ffebld_labtok (labexpr),
12086 &label);
12087 ffelex_token_kill (ffebld_labtok (labexpr));
12088 if (!ok1)
12089 {
12090 label = NULL;
12091 ok = FALSE;
12092 }
12093 ffebld_set_op (labexpr, FFEBLD_opLABTER);
12094 ffebld_set_labter (labexpr, label);
12095 }
12096 }
12097
12098 if (ok)
12099 ffestd_R1212 (expr);
12100 }
12101
12102 if (ffestc_shriek_after1_ != NULL)
12103 (*ffestc_shriek_after1_) (TRUE);
12104 ffestc_labeldef_branch_end_ ();
12105 }
12106
12107 /* ffestc_R1213 -- Defined assignment statement
12108
12109 ffestc_R1213(dest_expr,source_expr,source_token);
12110
12111 Make sure the assignment is valid. */
12112
12113 #if FFESTR_F90
12114 void
ffestc_R1213(ffebld dest,ffebld source,ffelexToken source_token)12115 ffestc_R1213 (ffebld dest, ffebld source, ffelexToken source_token)
12116 {
12117 ffestc_check_simple_ ();
12118 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
12119 return;
12120 ffestc_labeldef_branch_begin_ ();
12121
12122 ffestd_R1213 (dest, source);
12123
12124 if (ffestc_shriek_after1_ != NULL)
12125 (*ffestc_shriek_after1_) (TRUE);
12126 ffestc_labeldef_branch_end_ ();
12127 }
12128
12129 #endif
12130 /* ffestc_R1219 -- FUNCTION statement
12131
12132 ffestc_R1219(funcname,arglist,ending_token,kind,kindt,len,lent,
12133 recursive);
12134
12135 Make sure statement is valid here, register arguments for the
12136 function name, and so on.
12137
12138 06-Apr-90 JCB 2.0
12139 Added the kind, len, and recursive arguments. */
12140
12141 void
ffestc_R1219(ffelexToken funcname,ffesttTokenList args,ffelexToken final UNUSED,ffestpType type,ffebld kind,ffelexToken kindt,ffebld len,ffelexToken lent,ffelexToken recursive,ffelexToken result)12142 ffestc_R1219 (ffelexToken funcname, ffesttTokenList args,
12143 ffelexToken final UNUSED, ffestpType type, ffebld kind,
12144 ffelexToken kindt, ffebld len, ffelexToken lent,
12145 ffelexToken recursive, ffelexToken result)
12146 {
12147 ffestw b;
12148 ffesymbol s;
12149 ffesymbol fs; /* FUNCTION symbol when dealing with RESULT
12150 symbol. */
12151 ffesymbolAttrs sa;
12152 ffesymbolAttrs na;
12153 ffelexToken res;
12154 bool separate_result;
12155
12156 assert ((funcname != NULL)
12157 && (ffelex_token_type (funcname) == FFELEX_typeNAME));
12158
12159 ffestc_check_simple_ ();
12160 if (ffestc_order_iface_ () != FFESTC_orderOK_)
12161 return;
12162 ffestc_labeldef_useless_ ();
12163
12164 ffestc_blocknum_ = 0;
12165 ffesta_is_entry_valid =
12166 (ffestw_state (ffestw_stack_top ()) == FFESTV_stateNIL);
12167 b = ffestw_update (ffestw_push (NULL));
12168 ffestw_set_top_do (b, NULL);
12169 ffestw_set_state (b, FFESTV_stateFUNCTION0);
12170 ffestw_set_blocknum (b, ffestc_blocknum_++);
12171 ffestw_set_shriek (b, ffestc_shriek_function_);
12172 ffestw_set_name (b, ffelex_token_use (funcname));
12173
12174 if (type == FFESTP_typeNone)
12175 {
12176 ffestc_local_.decl.basic_type = FFEINFO_basictypeNONE;
12177 ffestc_local_.decl.kind_type = FFEINFO_kindtypeNONE;
12178 ffestc_local_.decl.size = FFETARGET_charactersizeNONE;
12179 }
12180 else
12181 {
12182 ffestc_establish_declstmt_ (type, ffesta_tokens[0],
12183 kind, kindt, len, lent);
12184 ffestc_establish_declinfo_ (NULL, NULL, NULL, NULL);
12185 }
12186
12187 separate_result = (result != NULL)
12188 && (ffelex_token_strcmp (funcname, result) != 0);
12189
12190 if (separate_result)
12191 fs = ffesymbol_declare_funcnotresunit (funcname); /* Global/local. */
12192 else
12193 fs = ffesymbol_declare_funcunit (funcname); /* Global only. */
12194
12195 if (ffesymbol_state (fs) == FFESYMBOL_stateNONE)
12196 {
12197 ffesymbol_set_state (fs, FFESYMBOL_stateUNDERSTOOD);
12198 ffesymbol_signal_unreported (fs);
12199
12200 /* Note that .basic_type and .kind_type might be NONE here. */
12201
12202 ffesymbol_set_info (fs,
12203 ffeinfo_new (ffestc_local_.decl.basic_type,
12204 ffestc_local_.decl.kind_type,
12205 0,
12206 FFEINFO_kindFUNCTION,
12207 FFEINFO_whereLOCAL,
12208 ffestc_local_.decl.size));
12209
12210 /* Check whether the type info fits the filewide expectations;
12211 set ok flag accordingly. */
12212
12213 ffesymbol_reference (fs, funcname, FALSE);
12214 if (ffesymbol_attrs (fs) & FFESYMBOL_attrsANY)
12215 ffestc_parent_ok_ = FALSE;
12216 else
12217 ffestc_parent_ok_ = TRUE;
12218 }
12219 else
12220 {
12221 if (ffesymbol_kind (fs) != FFEINFO_kindANY)
12222 ffesymbol_error (fs, funcname);
12223 ffestc_parent_ok_ = FALSE;
12224 }
12225
12226 if (ffestc_parent_ok_)
12227 {
12228 ffebld_init_list (&fs->dummy_args, &ffestc_local_.dummy.list_bottom);
12229 ffestt_tokenlist_drive (args, ffestc_promote_dummy_);
12230 ffebld_end_list (&ffestc_local_.dummy.list_bottom);
12231 }
12232
12233 if (result == NULL)
12234 res = funcname;
12235 else
12236 res = result;
12237
12238 s = ffesymbol_declare_funcresult (res);
12239 sa = ffesymbol_attrs (s);
12240
12241 /* Figure out what kind of object we've got based on previous declarations
12242 of or references to the object. */
12243
12244 if (sa & FFESYMBOL_attrsANY)
12245 na = FFESYMBOL_attrsANY;
12246 else if (ffesymbol_state (s) != FFESYMBOL_stateNONE)
12247 na = FFESYMBOL_attrsetNONE;
12248 else
12249 {
12250 na = FFESYMBOL_attrsRESULT;
12251 if (ffestc_local_.decl.basic_type != FFEINFO_basictypeNONE)
12252 {
12253 na |= FFESYMBOL_attrsTYPE;
12254 if ((ffestc_local_.decl.basic_type == FFEINFO_basictypeCHARACTER)
12255 && (ffestc_local_.decl.size == FFETARGET_charactersizeNONE))
12256 na |= FFESYMBOL_attrsANYLEN;
12257 }
12258 }
12259
12260 /* Now see what we've got for a new object: NONE means a new error cropped
12261 up; ANY means an old error to be ignored; otherwise, everything's ok,
12262 update the object (symbol) and continue on. */
12263
12264 if ((na & ~FFESYMBOL_attrsANY) == FFESYMBOL_attrsetNONE)
12265 {
12266 if (!(na & FFESYMBOL_attrsANY))
12267 ffesymbol_error (s, res);
12268 ffesymbol_set_funcresult (fs, NULL);
12269 ffesymbol_set_funcresult (s, NULL);
12270 ffestc_parent_ok_ = FALSE;
12271 }
12272 else
12273 {
12274 ffesymbol_set_attrs (s, na);
12275 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
12276 ffesymbol_set_funcresult (fs, s);
12277 ffesymbol_set_funcresult (s, fs);
12278 if (ffestc_local_.decl.basic_type != FFEINFO_basictypeNONE)
12279 {
12280 ffesymbol_set_info (s,
12281 ffeinfo_new (ffestc_local_.decl.basic_type,
12282 ffestc_local_.decl.kind_type,
12283 0,
12284 FFEINFO_kindNONE,
12285 FFEINFO_whereNONE,
12286 ffestc_local_.decl.size));
12287 }
12288 }
12289
12290 ffesymbol_signal_unreported (fs);
12291
12292 ffestd_R1219 (fs, funcname, args, type, kind, kindt, len, lent,
12293 (recursive != NULL), result, separate_result);
12294 }
12295
12296 /* ffestc_R1221 -- END FUNCTION statement
12297
12298 ffestc_R1221(name_token);
12299
12300 Make sure ffestc_kind_ identifies the current kind of program unit. If
12301 not NULL, make sure name_token gives the correct name. Implement the end
12302 of the current program unit. */
12303
12304 void
ffestc_R1221(ffelexToken name)12305 ffestc_R1221 (ffelexToken name)
12306 {
12307 ffestc_check_simple_ ();
12308 if (ffestc_order_function_ () != FFESTC_orderOK_)
12309 return;
12310 ffestc_labeldef_notloop_ ();
12311
12312 if ((name != NULL)
12313 && (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0))
12314 {
12315 ffebad_start (FFEBAD_UNIT_WRONG_NAME);
12316 ffebad_here (0, ffelex_token_where_line (name),
12317 ffelex_token_where_column (name));
12318 ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
12319 ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
12320 ffebad_finish ();
12321 }
12322
12323 ffestc_shriek_function_ (TRUE);
12324 }
12325
12326 /* ffestc_R1223 -- SUBROUTINE statement
12327
12328 ffestc_R1223(subrname,arglist,ending_token,recursive_token);
12329
12330 Make sure statement is valid here, register arguments for the
12331 subroutine name, and so on.
12332
12333 06-Apr-90 JCB 2.0
12334 Added the recursive argument. */
12335
12336 void
ffestc_R1223(ffelexToken subrname,ffesttTokenList args,ffelexToken final,ffelexToken recursive)12337 ffestc_R1223 (ffelexToken subrname, ffesttTokenList args,
12338 ffelexToken final, ffelexToken recursive)
12339 {
12340 ffestw b;
12341 ffesymbol s;
12342
12343 assert ((subrname != NULL)
12344 && (ffelex_token_type (subrname) == FFELEX_typeNAME));
12345
12346 ffestc_check_simple_ ();
12347 if (ffestc_order_iface_ () != FFESTC_orderOK_)
12348 return;
12349 ffestc_labeldef_useless_ ();
12350
12351 ffestc_blocknum_ = 0;
12352 ffesta_is_entry_valid
12353 = (ffestw_state (ffestw_stack_top ()) == FFESTV_stateNIL);
12354 b = ffestw_update (ffestw_push (NULL));
12355 ffestw_set_top_do (b, NULL);
12356 ffestw_set_state (b, FFESTV_stateSUBROUTINE0);
12357 ffestw_set_blocknum (b, ffestc_blocknum_++);
12358 ffestw_set_shriek (b, ffestc_shriek_subroutine_);
12359 ffestw_set_name (b, ffelex_token_use (subrname));
12360
12361 s = ffesymbol_declare_subrunit (subrname);
12362 if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
12363 {
12364 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
12365 ffesymbol_set_info (s,
12366 ffeinfo_new (FFEINFO_basictypeNONE,
12367 FFEINFO_kindtypeNONE,
12368 0,
12369 FFEINFO_kindSUBROUTINE,
12370 FFEINFO_whereLOCAL,
12371 FFETARGET_charactersizeNONE));
12372 ffestc_parent_ok_ = TRUE;
12373 }
12374 else
12375 {
12376 if (ffesymbol_kind (s) != FFEINFO_kindANY)
12377 ffesymbol_error (s, subrname);
12378 ffestc_parent_ok_ = FALSE;
12379 }
12380
12381 if (ffestc_parent_ok_)
12382 {
12383 ffebld_init_list (&s->dummy_args, &ffestc_local_.dummy.list_bottom);
12384 ffestt_tokenlist_drive (args, ffestc_promote_dummy_);
12385 ffebld_end_list (&ffestc_local_.dummy.list_bottom);
12386 }
12387
12388 ffesymbol_signal_unreported (s);
12389
12390 ffestd_R1223 (s, subrname, args, final, (recursive != NULL));
12391 }
12392
12393 /* ffestc_R1225 -- END SUBROUTINE statement
12394
12395 ffestc_R1225(name_token);
12396
12397 Make sure ffestc_kind_ identifies the current kind of program unit. If
12398 not NULL, make sure name_token gives the correct name. Implement the end
12399 of the current program unit. */
12400
12401 void
ffestc_R1225(ffelexToken name)12402 ffestc_R1225 (ffelexToken name)
12403 {
12404 ffestc_check_simple_ ();
12405 if (ffestc_order_subroutine_ () != FFESTC_orderOK_)
12406 return;
12407 ffestc_labeldef_notloop_ ();
12408
12409 if ((name != NULL)
12410 && (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0))
12411 {
12412 ffebad_start (FFEBAD_UNIT_WRONG_NAME);
12413 ffebad_here (0, ffelex_token_where_line (name),
12414 ffelex_token_where_column (name));
12415 ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
12416 ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
12417 ffebad_finish ();
12418 }
12419
12420 ffestc_shriek_subroutine_ (TRUE);
12421 }
12422
12423 /* ffestc_R1226 -- ENTRY statement
12424
12425 ffestc_R1226(entryname,arglist,ending_token);
12426
12427 Make sure we're in a SUBROUTINE or FUNCTION, register arguments for the
12428 entry point name, and so on. */
12429
12430 void
ffestc_R1226(ffelexToken entryname,ffesttTokenList args,ffelexToken final UNUSED)12431 ffestc_R1226 (ffelexToken entryname, ffesttTokenList args,
12432 ffelexToken final UNUSED)
12433 {
12434 ffesymbol s;
12435 ffesymbol fs;
12436 ffesymbolAttrs sa;
12437 ffesymbolAttrs na;
12438 bool in_spec; /* TRUE if further specification statements
12439 may follow, FALSE if executable stmts. */
12440 bool in_func; /* TRUE if ENTRY is a FUNCTION, not
12441 SUBROUTINE. */
12442
12443 assert ((entryname != NULL)
12444 && (ffelex_token_type (entryname) == FFELEX_typeNAME));
12445
12446 ffestc_check_simple_ ();
12447 if (ffestc_order_entry_ () != FFESTC_orderOK_)
12448 return;
12449 ffestc_labeldef_useless_ ();
12450
12451 switch (ffestw_state (ffestw_stack_top ()))
12452 {
12453 case FFESTV_stateFUNCTION1:
12454 case FFESTV_stateFUNCTION2:
12455 case FFESTV_stateFUNCTION3:
12456 in_func = TRUE;
12457 in_spec = TRUE;
12458 break;
12459
12460 case FFESTV_stateFUNCTION4:
12461 in_func = TRUE;
12462 in_spec = FALSE;
12463 break;
12464
12465 case FFESTV_stateSUBROUTINE1:
12466 case FFESTV_stateSUBROUTINE2:
12467 case FFESTV_stateSUBROUTINE3:
12468 in_func = FALSE;
12469 in_spec = TRUE;
12470 break;
12471
12472 case FFESTV_stateSUBROUTINE4:
12473 in_func = FALSE;
12474 in_spec = FALSE;
12475 break;
12476
12477 default:
12478 assert ("ENTRY not in FUNCTION or SUBROUTINE?" == NULL);
12479 in_func = FALSE;
12480 in_spec = FALSE;
12481 break;
12482 }
12483
12484 if (in_func)
12485 fs = ffesymbol_declare_funcunit (entryname);
12486 else
12487 fs = ffesymbol_declare_subrunit (entryname);
12488
12489 if (ffesymbol_state (fs) == FFESYMBOL_stateNONE)
12490 ffesymbol_set_state (fs, FFESYMBOL_stateUNDERSTOOD);
12491 else
12492 {
12493 if (ffesymbol_kind (fs) != FFEINFO_kindANY)
12494 ffesymbol_error (fs, entryname);
12495 }
12496
12497 ++ffestc_entry_num_;
12498
12499 ffebld_init_list (&fs->dummy_args, &ffestc_local_.dummy.list_bottom);
12500 if (in_spec)
12501 ffestt_tokenlist_drive (args, ffestc_promote_dummy_);
12502 else
12503 ffestt_tokenlist_drive (args, ffestc_promote_execdummy_);
12504 ffebld_end_list (&ffestc_local_.dummy.list_bottom);
12505
12506 if (in_func)
12507 {
12508 s = ffesymbol_declare_funcresult (entryname);
12509 ffesymbol_set_funcresult (fs, s);
12510 ffesymbol_set_funcresult (s, fs);
12511 sa = ffesymbol_attrs (s);
12512
12513 /* Figure out what kind of object we've got based on previous
12514 declarations of or references to the object. */
12515
12516 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
12517 na = FFESYMBOL_attrsetNONE;
12518 else if (sa & FFESYMBOL_attrsANY)
12519 na = FFESYMBOL_attrsANY;
12520 else if (!(sa & ~(FFESYMBOL_attrsANYLEN
12521 | FFESYMBOL_attrsTYPE)))
12522 na = sa | FFESYMBOL_attrsRESULT;
12523 else
12524 na = FFESYMBOL_attrsetNONE;
12525
12526 /* Now see what we've got for a new object: NONE means a new error
12527 cropped up; ANY means an old error to be ignored; otherwise,
12528 everything's ok, update the object (symbol) and continue on. */
12529
12530 if (na == FFESYMBOL_attrsetNONE)
12531 {
12532 ffesymbol_error (s, entryname);
12533 ffestc_parent_ok_ = FALSE;
12534 }
12535 else if (na & FFESYMBOL_attrsANY)
12536 {
12537 ffestc_parent_ok_ = FALSE;
12538 }
12539 else
12540 {
12541 ffesymbol_set_attrs (s, na);
12542 if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
12543 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
12544 else if (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN)
12545 {
12546 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
12547 ffesymbol_set_info (s,
12548 ffeinfo_new (ffesymbol_basictype (s),
12549 ffesymbol_kindtype (s),
12550 0,
12551 FFEINFO_kindENTITY,
12552 FFEINFO_whereRESULT,
12553 ffesymbol_size (s)));
12554 ffesymbol_resolve_intrin (s);
12555 ffestorag_exec_layout (s);
12556 }
12557 }
12558
12559 /* Since ENTRY might appear after executable stmts, do what would have
12560 been done if it hadn't -- give symbol implicit type and
12561 exec-transition it. */
12562
12563 if (!in_spec && ffesymbol_is_specable (s))
12564 {
12565 if (!ffeimplic_establish_symbol (s)) /* Do implicit typing. */
12566 ffesymbol_error (s, entryname);
12567 s = ffecom_sym_exec_transition (s);
12568 }
12569
12570 /* Use whatever type info is available for ENTRY to set up type for its
12571 global-name-space function symbol relative. */
12572
12573 ffesymbol_set_info (fs,
12574 ffeinfo_new (ffesymbol_basictype (s),
12575 ffesymbol_kindtype (s),
12576 0,
12577 FFEINFO_kindFUNCTION,
12578 FFEINFO_whereLOCAL,
12579 ffesymbol_size (s)));
12580
12581
12582 /* Check whether the type info fits the filewide expectations;
12583 set ok flag accordingly. */
12584
12585 ffesymbol_reference (fs, entryname, FALSE);
12586
12587 /* ~~Question??:
12588 When ENTRY FOO() RESULT(IBAR) is supported, what will the typing be
12589 if FOO and IBAR would normally end up with different types? I think
12590 the answer is that FOO is always given whatever type would be chosen
12591 for IBAR, rather than the other way around, and I think it ends up
12592 working that way for FUNCTION FOO() RESULT(IBAR), but this should be
12593 checked out in all its different combos. Related question is, is
12594 there any way that FOO in either case ends up without type info
12595 filled in? Does anyone care? */
12596
12597 ffesymbol_signal_unreported (s);
12598 }
12599 else
12600 {
12601 ffesymbol_set_info (fs,
12602 ffeinfo_new (FFEINFO_basictypeNONE,
12603 FFEINFO_kindtypeNONE,
12604 0,
12605 FFEINFO_kindSUBROUTINE,
12606 FFEINFO_whereLOCAL,
12607 FFETARGET_charactersizeNONE));
12608 }
12609
12610 if (!in_spec)
12611 fs = ffecom_sym_exec_transition (fs);
12612
12613 ffesymbol_signal_unreported (fs);
12614
12615 ffestd_R1226 (fs);
12616 }
12617
12618 /* ffestc_R1227 -- RETURN statement
12619
12620 ffestc_R1227(expr,expr_token);
12621
12622 Make sure statement is valid here; implement. expr and expr_token are
12623 both NULL if there was no expression. */
12624
12625 void
ffestc_R1227(ffebld expr,ffelexToken expr_token)12626 ffestc_R1227 (ffebld expr, ffelexToken expr_token)
12627 {
12628 ffestw b;
12629
12630 ffestc_check_simple_ ();
12631 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
12632 return;
12633 ffestc_labeldef_notloop_begin_ ();
12634
12635 for (b = ffestw_stack_top (); ; b = ffestw_previous (b))
12636 {
12637 switch (ffestw_state (b))
12638 {
12639 case FFESTV_statePROGRAM4:
12640 case FFESTV_stateSUBROUTINE4:
12641 case FFESTV_stateFUNCTION4:
12642 goto base; /* :::::::::::::::::::: */
12643
12644 case FFESTV_stateNIL:
12645 assert ("bad state" == NULL);
12646 break;
12647
12648 default:
12649 break;
12650 }
12651 }
12652
12653 base:
12654 switch (ffestw_state (b))
12655 {
12656 case FFESTV_statePROGRAM4:
12657 if (ffe_is_pedantic ())
12658 {
12659 ffebad_start (FFEBAD_RETURN_IN_MAIN);
12660 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
12661 ffelex_token_where_column (ffesta_tokens[0]));
12662 ffebad_finish ();
12663 }
12664 if (expr != NULL)
12665 {
12666 ffebad_start (FFEBAD_ALTRETURN_IN_PROGRAM);
12667 ffebad_here (0, ffelex_token_where_line (expr_token),
12668 ffelex_token_where_column (expr_token));
12669 ffebad_finish ();
12670 expr = NULL;
12671 }
12672 break;
12673
12674 case FFESTV_stateSUBROUTINE4:
12675 break;
12676
12677 case FFESTV_stateFUNCTION4:
12678 if (expr != NULL)
12679 {
12680 ffebad_start (FFEBAD_ALTRETURN_IN_FUNCTION);
12681 ffebad_here (0, ffelex_token_where_line (expr_token),
12682 ffelex_token_where_column (expr_token));
12683 ffebad_finish ();
12684 expr = NULL;
12685 }
12686 break;
12687
12688 default:
12689 assert ("bad state #2" == NULL);
12690 break;
12691 }
12692
12693 ffestd_R1227 (expr);
12694
12695 if (ffestc_shriek_after1_ != NULL)
12696 (*ffestc_shriek_after1_) (TRUE);
12697
12698 /* notloop's that are actionif's can be the target of a loop-end
12699 statement if they're in the "then" part of a logical IF, as
12700 in "DO 10", "10 IF (...) RETURN". */
12701
12702 ffestc_labeldef_branch_end_ ();
12703 }
12704
12705 /* ffestc_R1228 -- CONTAINS statement
12706
12707 ffestc_R1228(); */
12708
12709 #if FFESTR_F90
12710 void
ffestc_R1228()12711 ffestc_R1228 ()
12712 {
12713 ffestc_check_simple_ ();
12714 if (ffestc_order_contains_ () != FFESTC_orderOK_)
12715 return;
12716 ffestc_labeldef_useless_ ();
12717
12718 ffestd_R1228 ();
12719
12720 ffe_terminate_3 ();
12721 ffe_init_3 ();
12722 }
12723
12724 #endif
12725 /* ffestc_R1229_start -- STMTFUNCTION statement begin
12726
12727 ffestc_R1229_start(func_name,func_arg_list,close_paren);
12728
12729 Verify that STMTFUNCTION is valid here, establish func_arg_list in a new
12730 "live" scope within the current scope, and expect the actual expression
12731 (or NULL) in ffestc_R1229_finish. The reason there are two ffestc
12732 functions to handle this is so the scope can be established, allowing
12733 ffeexpr to assign proper characteristics to references to the dummy
12734 arguments. */
12735
12736 void
ffestc_R1229_start(ffelexToken name,ffesttTokenList args,ffelexToken final UNUSED)12737 ffestc_R1229_start (ffelexToken name, ffesttTokenList args,
12738 ffelexToken final UNUSED)
12739 {
12740 ffesymbol s;
12741 ffesymbolAttrs sa;
12742 ffesymbolAttrs na;
12743
12744 ffestc_check_start_ ();
12745 if (ffestc_order_sfunc_ () != FFESTC_orderOK_)
12746 {
12747 ffestc_ok_ = FALSE;
12748 return;
12749 }
12750 ffestc_labeldef_useless_ ();
12751
12752 assert (name != NULL);
12753 assert (args != NULL);
12754
12755 s = ffesymbol_declare_local (name, FALSE);
12756 sa = ffesymbol_attrs (s);
12757
12758 /* Figure out what kind of object we've got based on previous declarations
12759 of or references to the object. */
12760
12761 if (!ffesymbol_is_specable (s))
12762 na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
12763 else if (sa & FFESYMBOL_attrsANY)
12764 na = FFESYMBOL_attrsANY;
12765 else if (!(sa & ~FFESYMBOL_attrsTYPE))
12766 na = sa | FFESYMBOL_attrsSFUNC;
12767 else
12768 na = FFESYMBOL_attrsetNONE;
12769
12770 /* Now see what we've got for a new object: NONE means a new error cropped
12771 up; ANY means an old error to be ignored; otherwise, everything's ok,
12772 update the object (symbol) and continue on. */
12773
12774 if (na == FFESYMBOL_attrsetNONE)
12775 {
12776 ffesymbol_error (s, name);
12777 ffestc_parent_ok_ = FALSE;
12778 }
12779 else if (na & FFESYMBOL_attrsANY)
12780 ffestc_parent_ok_ = FALSE;
12781 else
12782 {
12783 ffesymbol_set_attrs (s, na);
12784 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
12785 if (!ffeimplic_establish_symbol (s)
12786 || ((ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
12787 && (ffesymbol_size (s) == FFETARGET_charactersizeNONE)))
12788 {
12789 ffesymbol_error (s, ffesta_tokens[0]);
12790 ffestc_parent_ok_ = FALSE;
12791 }
12792 else
12793 {
12794 /* Tell ffeexpr that sfunc def is in progress. */
12795 ffesymbol_set_sfexpr (s, ffebld_new_any ());
12796 ffebld_set_info (ffesymbol_sfexpr (s), ffeinfo_new_any ());
12797 ffestc_parent_ok_ = TRUE;
12798 }
12799 }
12800
12801 ffe_init_4 ();
12802
12803 if (ffestc_parent_ok_)
12804 {
12805 ffebld_init_list (&s->dummy_args, &ffestc_local_.dummy.list_bottom);
12806 ffestc_sfdummy_argno_ = 0;
12807 ffestt_tokenlist_drive (args, ffestc_promote_sfdummy_);
12808 ffebld_end_list (&ffestc_local_.dummy.list_bottom);
12809 }
12810
12811 ffestc_local_.sfunc.symbol = s;
12812
12813 ffestd_R1229_start (name, args);
12814
12815 ffestc_ok_ = TRUE;
12816 }
12817
12818 /* ffestc_R1229_finish -- STMTFUNCTION statement list complete
12819
12820 ffestc_R1229_finish(expr,expr_token);
12821
12822 If expr is NULL, an error occurred parsing the expansion expression, so
12823 just cancel the effects of ffestc_R1229_start and pretend nothing
12824 happened. Otherwise, install the expression as the expansion for the
12825 statement function named in _start_, then clean up. */
12826
12827 void
ffestc_R1229_finish(ffebld expr,ffelexToken expr_token)12828 ffestc_R1229_finish (ffebld expr, ffelexToken expr_token)
12829 {
12830 ffestc_check_finish_ ();
12831 if (!ffestc_ok_)
12832 return;
12833
12834 if (ffestc_parent_ok_ && (expr != NULL))
12835 ffesymbol_set_sfexpr (ffestc_local_.sfunc.symbol,
12836 ffeexpr_convert_to_sym (expr,
12837 expr_token,
12838 ffestc_local_.sfunc.symbol,
12839 ffesta_tokens[0]));
12840
12841 ffestd_R1229_finish (ffestc_local_.sfunc.symbol);
12842
12843 ffesymbol_signal_unreported (ffestc_local_.sfunc.symbol);
12844
12845 ffe_terminate_4 ();
12846 }
12847
12848 /* ffestc_S3P4 -- INCLUDE line
12849
12850 ffestc_S3P4(filename,filename_token);
12851
12852 Make sure INCLUDE not preceded by any semicolons or a label def; implement. */
12853
12854 void
ffestc_S3P4(ffebld filename,ffelexToken filename_token UNUSED)12855 ffestc_S3P4 (ffebld filename, ffelexToken filename_token UNUSED)
12856 {
12857 ffestc_check_simple_ ();
12858 ffestc_labeldef_invalid_ ();
12859
12860 ffestd_S3P4 (filename);
12861 }
12862
12863 /* ffestc_V003_start -- STRUCTURE statement list begin
12864
12865 ffestc_V003_start(structure_name);
12866
12867 Verify that STRUCTURE is valid here, and begin accepting items in the list. */
12868
12869 #if FFESTR_VXT
12870 void
ffestc_V003_start(ffelexToken structure_name)12871 ffestc_V003_start (ffelexToken structure_name)
12872 {
12873 ffestw b;
12874
12875 ffestc_check_start_ ();
12876 if (ffestc_order_vxtstructure_ () != FFESTC_orderOK_)
12877 {
12878 ffestc_ok_ = FALSE;
12879 return;
12880 }
12881 ffestc_labeldef_useless_ ();
12882
12883 switch (ffestw_state (ffestw_stack_top ()))
12884 {
12885 case FFESTV_stateSTRUCTURE:
12886 case FFESTV_stateMAP:
12887 ffestc_local_.V003.list_state = 2; /* Require at least one field
12888 name. */
12889 ffestw_set_substate (ffestw_stack_top (), 1); /* Seen at least one
12890 member. */
12891 break;
12892
12893 default:
12894 ffestc_local_.V003.list_state = 0; /* No field names required. */
12895 if (structure_name == NULL)
12896 {
12897 ffebad_start (FFEBAD_STRUCT_MISSING_NAME);
12898 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
12899 ffelex_token_where_column (ffesta_tokens[0]));
12900 ffebad_finish ();
12901 }
12902 break;
12903 }
12904
12905 b = ffestw_update (ffestw_push (NULL));
12906 ffestw_set_top_do (b, NULL);
12907 ffestw_set_state (b, FFESTV_stateSTRUCTURE);
12908 ffestw_set_blocknum (b, 0);
12909 ffestw_set_shriek (b, ffestc_shriek_structure_);
12910 ffestw_set_substate (b, 0); /* No field-declarations seen yet. */
12911
12912 ffestd_V003_start (structure_name);
12913
12914 ffestc_ok_ = TRUE;
12915 }
12916
12917 /* ffestc_V003_item -- STRUCTURE statement for object-name
12918
12919 ffestc_V003_item(name_token,dim_list);
12920
12921 Make sure name_token identifies a valid object to be STRUCTUREd. */
12922
12923 void
ffestc_V003_item(ffelexToken name,ffesttDimList dims)12924 ffestc_V003_item (ffelexToken name, ffesttDimList dims)
12925 {
12926 ffestc_check_item_ ();
12927 assert (name != NULL);
12928 if (!ffestc_ok_)
12929 return;
12930
12931 if (ffestc_local_.V003.list_state < 2)
12932 {
12933 if (ffestc_local_.V003.list_state == 0)
12934 {
12935 ffestc_local_.V003.list_state = 1;
12936 ffebad_start (FFEBAD_STRUCT_IGNORING_FIELD);
12937 ffebad_here (0, ffelex_token_where_line (name),
12938 ffelex_token_where_column (name));
12939 ffebad_finish ();
12940 }
12941 return;
12942 }
12943 ffestc_local_.V003.list_state = 3; /* Have at least one field name. */
12944
12945 if (dims != NULL)
12946 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
12947
12948 ffestd_V003_item (name, dims);
12949 }
12950
12951 /* ffestc_V003_finish -- STRUCTURE statement list complete
12952
12953 ffestc_V003_finish();
12954
12955 Just wrap up any local activities. */
12956
12957 void
ffestc_V003_finish()12958 ffestc_V003_finish ()
12959 {
12960 ffestc_check_finish_ ();
12961 if (!ffestc_ok_)
12962 return;
12963
12964 if (ffestc_local_.V003.list_state == 2)
12965 {
12966 ffebad_start (FFEBAD_STRUCT_MISSING_FIELD);
12967 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
12968 ffelex_token_where_column (ffesta_tokens[0]));
12969 ffebad_here (1, ffestw_line (ffestw_previous (ffestw_stack_top ())),
12970 ffestw_col (ffestw_previous (ffestw_stack_top ())));
12971 ffebad_finish ();
12972 }
12973
12974 ffestd_V003_finish ();
12975 }
12976
12977 /* ffestc_V004 -- END STRUCTURE statement
12978
12979 ffestc_V004();
12980
12981 Make sure ffestc_kind_ identifies a STRUCTURE block.
12982 Implement the end of the current STRUCTURE block. */
12983
12984 void
ffestc_V004()12985 ffestc_V004 ()
12986 {
12987 ffestc_check_simple_ ();
12988 if (ffestc_order_structure_ () != FFESTC_orderOK_)
12989 return;
12990 ffestc_labeldef_useless_ ();
12991
12992 if (ffestw_substate (ffestw_stack_top ()) != 1)
12993 {
12994 ffebad_start (FFEBAD_STRUCT_NO_COMPONENTS);
12995 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
12996 ffelex_token_where_column (ffesta_tokens[0]));
12997 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
12998 ffebad_finish ();
12999 }
13000
13001 ffestc_shriek_structure_ (TRUE);
13002 }
13003
13004 /* ffestc_V009 -- UNION statement
13005
13006 ffestc_V009(); */
13007
13008 void
ffestc_V009()13009 ffestc_V009 ()
13010 {
13011 ffestw b;
13012
13013 ffestc_check_simple_ ();
13014 if (ffestc_order_structure_ () != FFESTC_orderOK_)
13015 return;
13016 ffestc_labeldef_useless_ ();
13017
13018 ffestw_set_substate (ffestw_stack_top (), 1); /* Seen at least one member. */
13019
13020 b = ffestw_update (ffestw_push (NULL));
13021 ffestw_set_top_do (b, NULL);
13022 ffestw_set_state (b, FFESTV_stateUNION);
13023 ffestw_set_blocknum (b, 0);
13024 ffestw_set_shriek (b, ffestc_shriek_union_);
13025 ffestw_set_substate (b, 0); /* No map decls seen yet. */
13026
13027 ffestd_V009 ();
13028 }
13029
13030 /* ffestc_V010 -- END UNION statement
13031
13032 ffestc_V010();
13033
13034 Make sure ffestc_kind_ identifies a UNION block.
13035 Implement the end of the current UNION block. */
13036
13037 void
ffestc_V010()13038 ffestc_V010 ()
13039 {
13040 ffestc_check_simple_ ();
13041 if (ffestc_order_union_ () != FFESTC_orderOK_)
13042 return;
13043 ffestc_labeldef_useless_ ();
13044
13045 if (ffestw_substate (ffestw_stack_top ()) != 2)
13046 {
13047 ffebad_start (FFEBAD_UNION_NO_TWO_MAPS);
13048 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
13049 ffelex_token_where_column (ffesta_tokens[0]));
13050 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
13051 ffebad_finish ();
13052 }
13053
13054 ffestc_shriek_union_ (TRUE);
13055 }
13056
13057 /* ffestc_V012 -- MAP statement
13058
13059 ffestc_V012(); */
13060
13061 void
ffestc_V012()13062 ffestc_V012 ()
13063 {
13064 ffestw b;
13065
13066 ffestc_check_simple_ ();
13067 if (ffestc_order_union_ () != FFESTC_orderOK_)
13068 return;
13069 ffestc_labeldef_useless_ ();
13070
13071 if (ffestw_substate (ffestw_stack_top ()) != 2)
13072 ffestw_substate (ffestw_stack_top ())++; /* 0=>1, 1=>2. */
13073
13074 b = ffestw_update (ffestw_push (NULL));
13075 ffestw_set_top_do (b, NULL);
13076 ffestw_set_state (b, FFESTV_stateMAP);
13077 ffestw_set_blocknum (b, 0);
13078 ffestw_set_shriek (b, ffestc_shriek_map_);
13079 ffestw_set_substate (b, 0); /* No field-declarations seen yet. */
13080
13081 ffestd_V012 ();
13082 }
13083
13084 /* ffestc_V013 -- END MAP statement
13085
13086 ffestc_V013();
13087
13088 Make sure ffestc_kind_ identifies a MAP block.
13089 Implement the end of the current MAP block. */
13090
13091 void
ffestc_V013()13092 ffestc_V013 ()
13093 {
13094 ffestc_check_simple_ ();
13095 if (ffestc_order_map_ () != FFESTC_orderOK_)
13096 return;
13097 ffestc_labeldef_useless_ ();
13098
13099 if (ffestw_substate (ffestw_stack_top ()) != 1)
13100 {
13101 ffebad_start (FFEBAD_MAP_NO_COMPONENTS);
13102 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
13103 ffelex_token_where_column (ffesta_tokens[0]));
13104 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
13105 ffebad_finish ();
13106 }
13107
13108 ffestc_shriek_map_ (TRUE);
13109 }
13110
13111 #endif
13112 /* ffestc_V014_start -- VOLATILE statement list begin
13113
13114 ffestc_V014_start();
13115
13116 Verify that VOLATILE is valid here, and begin accepting items in the
13117 list. */
13118
13119 void
ffestc_V014_start()13120 ffestc_V014_start ()
13121 {
13122 ffestc_check_start_ ();
13123 if (ffestc_order_progspec_ () != FFESTC_orderOK_)
13124 {
13125 ffestc_ok_ = FALSE;
13126 return;
13127 }
13128 ffestc_labeldef_useless_ ();
13129
13130 ffestd_V014_start ();
13131
13132 ffestc_ok_ = TRUE;
13133 }
13134
13135 /* ffestc_V014_item_object -- VOLATILE statement for object-name
13136
13137 ffestc_V014_item_object(name_token);
13138
13139 Make sure name_token identifies a valid object to be VOLATILEd. */
13140
13141 void
ffestc_V014_item_object(ffelexToken name)13142 ffestc_V014_item_object (ffelexToken name)
13143 {
13144 ffestc_check_item_ ();
13145 assert (name != NULL);
13146 if (!ffestc_ok_)
13147 return;
13148
13149 ffestd_V014_item_object (name);
13150 }
13151
13152 /* ffestc_V014_item_cblock -- VOLATILE statement for common-block-name
13153
13154 ffestc_V014_item_cblock(name_token);
13155
13156 Make sure name_token identifies a valid common block to be VOLATILEd. */
13157
13158 void
ffestc_V014_item_cblock(ffelexToken name)13159 ffestc_V014_item_cblock (ffelexToken name)
13160 {
13161 ffestc_check_item_ ();
13162 assert (name != NULL);
13163 if (!ffestc_ok_)
13164 return;
13165
13166 ffestd_V014_item_cblock (name);
13167 }
13168
13169 /* ffestc_V014_finish -- VOLATILE statement list complete
13170
13171 ffestc_V014_finish();
13172
13173 Just wrap up any local activities. */
13174
13175 void
ffestc_V014_finish()13176 ffestc_V014_finish ()
13177 {
13178 ffestc_check_finish_ ();
13179 if (!ffestc_ok_)
13180 return;
13181
13182 ffestd_V014_finish ();
13183 }
13184
13185 /* ffestc_V016_start -- RECORD statement list begin
13186
13187 ffestc_V016_start();
13188
13189 Verify that RECORD is valid here, and begin accepting items in the list. */
13190
13191 #if FFESTR_VXT
13192 void
ffestc_V016_start()13193 ffestc_V016_start ()
13194 {
13195 ffestc_check_start_ ();
13196 if (ffestc_order_record_ () != FFESTC_orderOK_)
13197 {
13198 ffestc_ok_ = FALSE;
13199 return;
13200 }
13201 ffestc_labeldef_useless_ ();
13202
13203 switch (ffestw_state (ffestw_stack_top ()))
13204 {
13205 case FFESTV_stateSTRUCTURE:
13206 case FFESTV_stateMAP:
13207 ffestw_set_substate (ffestw_stack_top (), 1); /* Seen at least one
13208 member. */
13209 break;
13210
13211 default:
13212 break;
13213 }
13214
13215 ffestd_V016_start ();
13216
13217 ffestc_ok_ = TRUE;
13218 }
13219
13220 /* ffestc_V016_item_structure -- RECORD statement for common-block-name
13221
13222 ffestc_V016_item_structure(name_token);
13223
13224 Make sure name_token identifies a valid structure to be RECORDed. */
13225
13226 void
ffestc_V016_item_structure(ffelexToken name)13227 ffestc_V016_item_structure (ffelexToken name)
13228 {
13229 ffestc_check_item_ ();
13230 assert (name != NULL);
13231 if (!ffestc_ok_)
13232 return;
13233
13234 ffestd_V016_item_structure (name);
13235 }
13236
13237 /* ffestc_V016_item_object -- RECORD statement for object-name
13238
13239 ffestc_V016_item_object(name_token,dim_list);
13240
13241 Make sure name_token identifies a valid object to be RECORDd. */
13242
13243 void
ffestc_V016_item_object(ffelexToken name,ffesttDimList dims)13244 ffestc_V016_item_object (ffelexToken name, ffesttDimList dims)
13245 {
13246 ffestc_check_item_ ();
13247 assert (name != NULL);
13248 if (!ffestc_ok_)
13249 return;
13250
13251 if (dims != NULL)
13252 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
13253
13254 ffestd_V016_item_object (name, dims);
13255 }
13256
13257 /* ffestc_V016_finish -- RECORD statement list complete
13258
13259 ffestc_V016_finish();
13260
13261 Just wrap up any local activities. */
13262
13263 void
ffestc_V016_finish()13264 ffestc_V016_finish ()
13265 {
13266 ffestc_check_finish_ ();
13267 if (!ffestc_ok_)
13268 return;
13269
13270 ffestd_V016_finish ();
13271 }
13272
13273 /* ffestc_V018_start -- REWRITE(...) statement list begin
13274
13275 ffestc_V018_start();
13276
13277 Verify that REWRITE is valid here, and begin accepting items in the
13278 list. */
13279
13280 void
ffestc_V018_start()13281 ffestc_V018_start ()
13282 {
13283 ffestvFormat format;
13284
13285 ffestc_check_start_ ();
13286 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
13287 {
13288 ffestc_ok_ = FALSE;
13289 return;
13290 }
13291 ffestc_labeldef_branch_begin_ ();
13292
13293 if (!ffestc_subr_is_branch_
13294 (&ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixERR])
13295 || !ffestc_subr_is_format_
13296 (&ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT])
13297 || !ffestc_subr_is_present_ ("UNIT",
13298 &ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixUNIT]))
13299 {
13300 ffestc_ok_ = FALSE;
13301 return;
13302 }
13303
13304 format = ffestc_subr_format_
13305 (&ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT]);
13306 switch (format)
13307 {
13308 case FFESTV_formatNAMELIST:
13309 case FFESTV_formatASTERISK:
13310 ffebad_start (FFEBAD_CONFLICTING_SPECS);
13311 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
13312 ffelex_token_where_column (ffesta_tokens[0]));
13313 assert (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].kw_or_val_present);
13314 if (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].kw_present)
13315 {
13316 ffebad_here (0, ffelex_token_where_line
13317 (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].kw),
13318 ffelex_token_where_column
13319 (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].kw));
13320 }
13321 else
13322 {
13323 ffebad_here (1, ffelex_token_where_line
13324 (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].value),
13325 ffelex_token_where_column
13326 (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].value));
13327 }
13328 ffebad_finish ();
13329 ffestc_ok_ = FALSE;
13330 return;
13331
13332 default:
13333 break;
13334 }
13335
13336 ffestd_V018_start (format);
13337
13338 ffestc_ok_ = TRUE;
13339 }
13340
13341 /* ffestc_V018_item -- REWRITE statement i/o item
13342
13343 ffestc_V018_item(expr,expr_token);
13344
13345 Implement output-list expression. */
13346
13347 void
ffestc_V018_item(ffebld expr,ffelexToken expr_token)13348 ffestc_V018_item (ffebld expr, ffelexToken expr_token)
13349 {
13350 ffestc_check_item_ ();
13351 if (!ffestc_ok_)
13352 return;
13353
13354 ffestd_V018_item (expr);
13355 }
13356
13357 /* ffestc_V018_finish -- REWRITE statement list complete
13358
13359 ffestc_V018_finish();
13360
13361 Just wrap up any local activities. */
13362
13363 void
ffestc_V018_finish()13364 ffestc_V018_finish ()
13365 {
13366 ffestc_check_finish_ ();
13367 if (!ffestc_ok_)
13368 return;
13369
13370 ffestd_V018_finish ();
13371
13372 if (ffestc_shriek_after1_ != NULL)
13373 (*ffestc_shriek_after1_) (TRUE);
13374 ffestc_labeldef_branch_end_ ();
13375 }
13376
13377 /* ffestc_V019_start -- ACCEPT statement list begin
13378
13379 ffestc_V019_start();
13380
13381 Verify that ACCEPT is valid here, and begin accepting items in the
13382 list. */
13383
13384 void
ffestc_V019_start()13385 ffestc_V019_start ()
13386 {
13387 ffestvFormat format;
13388
13389 ffestc_check_start_ ();
13390 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
13391 {
13392 ffestc_ok_ = FALSE;
13393 return;
13394 }
13395 ffestc_labeldef_branch_begin_ ();
13396
13397 if (!ffestc_subr_is_format_
13398 (&ffestp_file.accept.accept_spec[FFESTP_acceptixFORMAT]))
13399 {
13400 ffestc_ok_ = FALSE;
13401 return;
13402 }
13403
13404 format = ffestc_subr_format_
13405 (&ffestp_file.accept.accept_spec[FFESTP_acceptixFORMAT]);
13406 ffestc_namelist_ = (format == FFESTV_formatNAMELIST);
13407
13408 ffestd_V019_start (format);
13409
13410 ffestc_ok_ = TRUE;
13411 }
13412
13413 /* ffestc_V019_item -- ACCEPT statement i/o item
13414
13415 ffestc_V019_item(expr,expr_token);
13416
13417 Implement output-list expression. */
13418
13419 void
ffestc_V019_item(ffebld expr,ffelexToken expr_token)13420 ffestc_V019_item (ffebld expr, ffelexToken expr_token)
13421 {
13422 ffestc_check_item_ ();
13423 if (!ffestc_ok_)
13424 return;
13425
13426 if (ffestc_namelist_ != 0)
13427 {
13428 if (ffestc_namelist_ == 1)
13429 {
13430 ffestc_namelist_ = 2;
13431 ffebad_start (FFEBAD_NAMELIST_ITEMS);
13432 ffebad_here (0, ffelex_token_where_line (expr_token),
13433 ffelex_token_where_column (expr_token));
13434 ffebad_finish ();
13435 }
13436 return;
13437 }
13438
13439 ffestd_V019_item (expr);
13440 }
13441
13442 /* ffestc_V019_finish -- ACCEPT statement list complete
13443
13444 ffestc_V019_finish();
13445
13446 Just wrap up any local activities. */
13447
13448 void
ffestc_V019_finish()13449 ffestc_V019_finish ()
13450 {
13451 ffestc_check_finish_ ();
13452 if (!ffestc_ok_)
13453 return;
13454
13455 ffestd_V019_finish ();
13456
13457 if (ffestc_shriek_after1_ != NULL)
13458 (*ffestc_shriek_after1_) (TRUE);
13459 ffestc_labeldef_branch_end_ ();
13460 }
13461
13462 #endif
13463 /* ffestc_V020_start -- TYPE statement list begin
13464
13465 ffestc_V020_start();
13466
13467 Verify that TYPE is valid here, and begin accepting items in the
13468 list. */
13469
13470 void
ffestc_V020_start()13471 ffestc_V020_start ()
13472 {
13473 ffestvFormat format;
13474
13475 ffestc_check_start_ ();
13476 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
13477 {
13478 ffestc_ok_ = FALSE;
13479 return;
13480 }
13481 ffestc_labeldef_branch_begin_ ();
13482
13483 if (!ffestc_subr_is_format_
13484 (&ffestp_file.type.type_spec[FFESTP_typeixFORMAT]))
13485 {
13486 ffestc_ok_ = FALSE;
13487 return;
13488 }
13489
13490 format = ffestc_subr_format_
13491 (&ffestp_file.type.type_spec[FFESTP_typeixFORMAT]);
13492 ffestc_namelist_ = (format == FFESTV_formatNAMELIST);
13493
13494 ffestd_V020_start (format);
13495
13496 ffestc_ok_ = TRUE;
13497 }
13498
13499 /* ffestc_V020_item -- TYPE statement i/o item
13500
13501 ffestc_V020_item(expr,expr_token);
13502
13503 Implement output-list expression. */
13504
13505 void
ffestc_V020_item(ffebld expr,ffelexToken expr_token)13506 ffestc_V020_item (ffebld expr, ffelexToken expr_token)
13507 {
13508 ffestc_check_item_ ();
13509 if (!ffestc_ok_)
13510 return;
13511
13512 if (ffestc_namelist_ != 0)
13513 {
13514 if (ffestc_namelist_ == 1)
13515 {
13516 ffestc_namelist_ = 2;
13517 ffebad_start (FFEBAD_NAMELIST_ITEMS);
13518 ffebad_here (0, ffelex_token_where_line (expr_token),
13519 ffelex_token_where_column (expr_token));
13520 ffebad_finish ();
13521 }
13522 return;
13523 }
13524
13525 ffestd_V020_item (expr);
13526 }
13527
13528 /* ffestc_V020_finish -- TYPE statement list complete
13529
13530 ffestc_V020_finish();
13531
13532 Just wrap up any local activities. */
13533
13534 void
ffestc_V020_finish()13535 ffestc_V020_finish ()
13536 {
13537 ffestc_check_finish_ ();
13538 if (!ffestc_ok_)
13539 return;
13540
13541 ffestd_V020_finish ();
13542
13543 if (ffestc_shriek_after1_ != NULL)
13544 (*ffestc_shriek_after1_) (TRUE);
13545 ffestc_labeldef_branch_end_ ();
13546 }
13547
13548 /* ffestc_V021 -- DELETE statement
13549
13550 ffestc_V021();
13551
13552 Make sure a DELETE is valid in the current context, and implement it. */
13553
13554 #if FFESTR_VXT
13555 void
ffestc_V021()13556 ffestc_V021 ()
13557 {
13558 ffestc_check_simple_ ();
13559 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
13560 return;
13561 ffestc_labeldef_branch_begin_ ();
13562
13563 if (ffestc_subr_is_branch_
13564 (&ffestp_file.delete.delete_spec[FFESTP_deleteixERR])
13565 && ffestc_subr_is_present_ ("UNIT",
13566 &ffestp_file.delete.delete_spec[FFESTP_deleteixUNIT]))
13567 ffestd_V021 ();
13568
13569 if (ffestc_shriek_after1_ != NULL)
13570 (*ffestc_shriek_after1_) (TRUE);
13571 ffestc_labeldef_branch_end_ ();
13572 }
13573
13574 /* ffestc_V022 -- UNLOCK statement
13575
13576 ffestc_V022();
13577
13578 Make sure a UNLOCK is valid in the current context, and implement it. */
13579
13580 void
ffestc_V022()13581 ffestc_V022 ()
13582 {
13583 ffestc_check_simple_ ();
13584 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
13585 return;
13586 ffestc_labeldef_branch_begin_ ();
13587
13588 if (ffestc_subr_is_branch_
13589 (&ffestp_file.beru.beru_spec[FFESTP_beruixERR])
13590 && ffestc_subr_is_present_ ("UNIT",
13591 &ffestp_file.beru.beru_spec[FFESTP_beruixUNIT]))
13592 ffestd_V022 ();
13593
13594 if (ffestc_shriek_after1_ != NULL)
13595 (*ffestc_shriek_after1_) (TRUE);
13596 ffestc_labeldef_branch_end_ ();
13597 }
13598
13599 /* ffestc_V023_start -- ENCODE(...) statement list begin
13600
13601 ffestc_V023_start();
13602
13603 Verify that ENCODE is valid here, and begin accepting items in the
13604 list. */
13605
13606 void
ffestc_V023_start()13607 ffestc_V023_start ()
13608 {
13609 ffestc_check_start_ ();
13610 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
13611 {
13612 ffestc_ok_ = FALSE;
13613 return;
13614 }
13615 ffestc_labeldef_branch_begin_ ();
13616
13617 if (!ffestc_subr_is_branch_
13618 (&ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixERR]))
13619 {
13620 ffestc_ok_ = FALSE;
13621 return;
13622 }
13623
13624 ffestd_V023_start ();
13625
13626 ffestc_ok_ = TRUE;
13627 }
13628
13629 /* ffestc_V023_item -- ENCODE statement i/o item
13630
13631 ffestc_V023_item(expr,expr_token);
13632
13633 Implement output-list expression. */
13634
13635 void
ffestc_V023_item(ffebld expr,ffelexToken expr_token)13636 ffestc_V023_item (ffebld expr, ffelexToken expr_token)
13637 {
13638 ffestc_check_item_ ();
13639 if (!ffestc_ok_)
13640 return;
13641
13642 ffestd_V023_item (expr);
13643 }
13644
13645 /* ffestc_V023_finish -- ENCODE statement list complete
13646
13647 ffestc_V023_finish();
13648
13649 Just wrap up any local activities. */
13650
13651 void
ffestc_V023_finish()13652 ffestc_V023_finish ()
13653 {
13654 ffestc_check_finish_ ();
13655 if (!ffestc_ok_)
13656 return;
13657
13658 ffestd_V023_finish ();
13659
13660 if (ffestc_shriek_after1_ != NULL)
13661 (*ffestc_shriek_after1_) (TRUE);
13662 ffestc_labeldef_branch_end_ ();
13663 }
13664
13665 /* ffestc_V024_start -- DECODE(...) statement list begin
13666
13667 ffestc_V024_start();
13668
13669 Verify that DECODE is valid here, and begin accepting items in the
13670 list. */
13671
13672 void
ffestc_V024_start()13673 ffestc_V024_start ()
13674 {
13675 ffestc_check_start_ ();
13676 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
13677 {
13678 ffestc_ok_ = FALSE;
13679 return;
13680 }
13681 ffestc_labeldef_branch_begin_ ();
13682
13683 if (!ffestc_subr_is_branch_
13684 (&ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixERR]))
13685 {
13686 ffestc_ok_ = FALSE;
13687 return;
13688 }
13689
13690 ffestd_V024_start ();
13691
13692 ffestc_ok_ = TRUE;
13693 }
13694
13695 /* ffestc_V024_item -- DECODE statement i/o item
13696
13697 ffestc_V024_item(expr,expr_token);
13698
13699 Implement output-list expression. */
13700
13701 void
ffestc_V024_item(ffebld expr,ffelexToken expr_token)13702 ffestc_V024_item (ffebld expr, ffelexToken expr_token)
13703 {
13704 ffestc_check_item_ ();
13705 if (!ffestc_ok_)
13706 return;
13707
13708 ffestd_V024_item (expr);
13709 }
13710
13711 /* ffestc_V024_finish -- DECODE statement list complete
13712
13713 ffestc_V024_finish();
13714
13715 Just wrap up any local activities. */
13716
13717 void
ffestc_V024_finish()13718 ffestc_V024_finish ()
13719 {
13720 ffestc_check_finish_ ();
13721 if (!ffestc_ok_)
13722 return;
13723
13724 ffestd_V024_finish ();
13725
13726 if (ffestc_shriek_after1_ != NULL)
13727 (*ffestc_shriek_after1_) (TRUE);
13728 ffestc_labeldef_branch_end_ ();
13729 }
13730
13731 /* ffestc_V025_start -- DEFINEFILE statement list begin
13732
13733 ffestc_V025_start();
13734
13735 Verify that DEFINEFILE is valid here, and begin accepting items in the
13736 list. */
13737
13738 void
ffestc_V025_start()13739 ffestc_V025_start ()
13740 {
13741 ffestc_check_start_ ();
13742 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
13743 {
13744 ffestc_ok_ = FALSE;
13745 return;
13746 }
13747 ffestc_labeldef_branch_begin_ ();
13748
13749 ffestd_V025_start ();
13750
13751 ffestc_ok_ = TRUE;
13752 }
13753
13754 /* ffestc_V025_item -- DEFINE FILE statement item
13755
13756 ffestc_V025_item(u,ut,m,mt,n,nt,asv,asvt);
13757
13758 Implement item. */
13759
13760 void
ffestc_V025_item(ffebld u,ffelexToken ut,ffebld m,ffelexToken mt,ffebld n,ffelexToken nt,ffebld asv,ffelexToken asvt)13761 ffestc_V025_item (ffebld u, ffelexToken ut, ffebld m, ffelexToken mt,
13762 ffebld n, ffelexToken nt, ffebld asv, ffelexToken asvt)
13763 {
13764 ffestc_check_item_ ();
13765 if (!ffestc_ok_)
13766 return;
13767
13768 ffestd_V025_item (u, m, n, asv);
13769 }
13770
13771 /* ffestc_V025_finish -- DEFINE FILE statement list complete
13772
13773 ffestc_V025_finish();
13774
13775 Just wrap up any local activities. */
13776
13777 void
ffestc_V025_finish()13778 ffestc_V025_finish ()
13779 {
13780 ffestc_check_finish_ ();
13781 if (!ffestc_ok_)
13782 return;
13783
13784 ffestd_V025_finish ();
13785
13786 if (ffestc_shriek_after1_ != NULL)
13787 (*ffestc_shriek_after1_) (TRUE);
13788 ffestc_labeldef_branch_end_ ();
13789 }
13790
13791 /* ffestc_V026 -- FIND statement
13792
13793 ffestc_V026();
13794
13795 Make sure a FIND is valid in the current context, and implement it. */
13796
13797 void
ffestc_V026()13798 ffestc_V026 ()
13799 {
13800 ffestc_check_simple_ ();
13801 if (ffestc_order_actionif_ () != FFESTC_orderOK_)
13802 return;
13803 ffestc_labeldef_branch_begin_ ();
13804
13805 if (ffestc_subr_is_branch_
13806 (&ffestp_file.find.find_spec[FFESTP_findixERR])
13807 && ffestc_subr_is_present_ ("UNIT",
13808 &ffestp_file.find.find_spec[FFESTP_findixUNIT])
13809 && ffestc_subr_is_present_ ("REC",
13810 &ffestp_file.find.find_spec[FFESTP_findixREC]))
13811 ffestd_V026 ();
13812
13813 if (ffestc_shriek_after1_ != NULL)
13814 (*ffestc_shriek_after1_) (TRUE);
13815 ffestc_labeldef_branch_end_ ();
13816 }
13817
13818 #endif
13819 /* ffestc_V027_start -- VXT PARAMETER statement list begin
13820
13821 ffestc_V027_start();
13822
13823 Verify that PARAMETER is valid here, and begin accepting items in the list. */
13824
13825 void
ffestc_V027_start()13826 ffestc_V027_start ()
13827 {
13828 ffestc_check_start_ ();
13829 if (ffestc_order_parameter_ () != FFESTC_orderOK_)
13830 {
13831 ffestc_ok_ = FALSE;
13832 return;
13833 }
13834 ffestc_labeldef_useless_ ();
13835
13836 ffestd_V027_start ();
13837
13838 ffestc_ok_ = TRUE;
13839 }
13840
13841 /* ffestc_V027_item -- VXT PARAMETER statement assignment
13842
13843 ffestc_V027_item(dest,dest_token,source,source_token);
13844
13845 Make sure the source is a valid source for the destination; make the
13846 assignment. */
13847
13848 void
ffestc_V027_item(ffelexToken dest_token,ffebld source,ffelexToken source_token UNUSED)13849 ffestc_V027_item (ffelexToken dest_token, ffebld source,
13850 ffelexToken source_token UNUSED)
13851 {
13852 ffestc_check_item_ ();
13853 if (!ffestc_ok_)
13854 return;
13855
13856 ffestd_V027_item (dest_token, source);
13857 }
13858
13859 /* ffestc_V027_finish -- VXT PARAMETER statement list complete
13860
13861 ffestc_V027_finish();
13862
13863 Just wrap up any local activities. */
13864
13865 void
ffestc_V027_finish()13866 ffestc_V027_finish ()
13867 {
13868 ffestc_check_finish_ ();
13869 if (!ffestc_ok_)
13870 return;
13871
13872 ffestd_V027_finish ();
13873 }
13874
13875 /* Any executable statement. Mainly make sure that one-shot things
13876 like the statement for a logical IF are reset. */
13877
13878 void
ffestc_any()13879 ffestc_any ()
13880 {
13881 ffestc_check_simple_ ();
13882
13883 ffestc_order_any_ ();
13884
13885 ffestc_labeldef_any_ ();
13886
13887 if (ffestc_shriek_after1_ == NULL)
13888 return;
13889
13890 ffestd_any ();
13891
13892 (*ffestc_shriek_after1_) (TRUE);
13893 }
13894