xref: /openbsd/gnu/usr.bin/gcc/gcc/f/std.c (revision c87b03e5)
1 /* std.c -- Implementation File (module.c template V1.0)
2    Copyright (C) 1995, 1996, 2000, 2002 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       Implements the various statements and such like.
27 
28    Modifications:
29       21-Nov-91	 JCB  2.0
30 	 Split out actual code generation to ffeste.
31 */
32 
33 /* Include files. */
34 
35 #include "proj.h"
36 #include "std.h"
37 #include "bld.h"
38 #include "com.h"
39 #include "lab.h"
40 #include "lex.h"
41 #include "malloc.h"
42 #include "sta.h"
43 #include "ste.h"
44 #include "stp.h"
45 #include "str.h"
46 #include "sts.h"
47 #include "stt.h"
48 #include "stv.h"
49 #include "stw.h"
50 #include "symbol.h"
51 #include "target.h"
52 
53 /* Externals defined here. */
54 
55 
56 /* Simple definitions and enumerations. */
57 
58 #define FFESTD_COPY_EASY_ 1	/* 1 for only one _subr_copy_xyz_ fn. */
59 
60 #define FFESTD_IS_END_OPTIMIZED_ 1	/* 0=always gen STOP/RETURN before
61 					   END. */
62 
63 typedef enum
64   {
65     FFESTD_stateletSIMPLE_,	/* Expecting simple/start. */
66     FFESTD_stateletATTRIB_,	/* Expecting attrib/item/itemstart. */
67     FFESTD_stateletITEM_,	/* Expecting item/itemstart/finish. */
68     FFESTD_stateletITEMVALS_,	/* Expecting itemvalue/itemendvals. */
69     FFESTD_
70   } ffestdStatelet_;
71 
72 typedef enum
73   {
74     FFESTD_stmtidENDDOLOOP_,
75     FFESTD_stmtidENDLOGIF_,
76     FFESTD_stmtidEXECLABEL_,
77     FFESTD_stmtidFORMATLABEL_,
78     FFESTD_stmtidR737A_,	/* let */
79     FFESTD_stmtidR803_,		/* IF-block */
80     FFESTD_stmtidR804_,		/* ELSE IF */
81     FFESTD_stmtidR805_,		/* ELSE */
82     FFESTD_stmtidR806_,		/* END IF */
83     FFESTD_stmtidR807_,		/* IF-logical */
84     FFESTD_stmtidR809_,		/* SELECT CASE */
85     FFESTD_stmtidR810_,		/* CASE */
86     FFESTD_stmtidR811_,		/* END SELECT */
87     FFESTD_stmtidR819A_,	/* DO-iterative */
88     FFESTD_stmtidR819B_,	/* DO WHILE */
89     FFESTD_stmtidR825_,		/* END DO */
90     FFESTD_stmtidR834_,		/* CYCLE */
91     FFESTD_stmtidR835_,		/* EXIT */
92     FFESTD_stmtidR836_,		/* GOTO */
93     FFESTD_stmtidR837_,		/* GOTO-computed */
94     FFESTD_stmtidR838_,		/* ASSIGN */
95     FFESTD_stmtidR839_,		/* GOTO-assigned */
96     FFESTD_stmtidR840_,		/* IF-arithmetic */
97     FFESTD_stmtidR841_,		/* CONTINUE */
98     FFESTD_stmtidR842_,		/* STOP */
99     FFESTD_stmtidR843_,		/* PAUSE */
100     FFESTD_stmtidR904_,		/* OPEN */
101     FFESTD_stmtidR907_,		/* CLOSE */
102     FFESTD_stmtidR909_,		/* READ */
103     FFESTD_stmtidR910_,		/* WRITE */
104     FFESTD_stmtidR911_,		/* PRINT */
105     FFESTD_stmtidR919_,		/* BACKSPACE */
106     FFESTD_stmtidR920_,		/* ENDFILE */
107     FFESTD_stmtidR921_,		/* REWIND */
108     FFESTD_stmtidR923A_,	/* INQUIRE */
109     FFESTD_stmtidR923B_,	/* INQUIRE-iolength */
110     FFESTD_stmtidR1001_,	/* FORMAT */
111     FFESTD_stmtidR1103_,	/* END_PROGRAM */
112     FFESTD_stmtidR1112_,	/* END_BLOCK_DATA */
113     FFESTD_stmtidR1212_,	/* CALL */
114     FFESTD_stmtidR1221_,	/* END_FUNCTION */
115     FFESTD_stmtidR1225_,	/* END_SUBROUTINE */
116     FFESTD_stmtidR1226_,	/* ENTRY */
117     FFESTD_stmtidR1227_,	/* RETURN */
118 #if FFESTR_VXT
119     FFESTD_stmtidV018_,		/* REWRITE */
120     FFESTD_stmtidV019_,		/* ACCEPT */
121 #endif
122     FFESTD_stmtidV020_,		/* TYPE */
123 #if FFESTR_VXT
124     FFESTD_stmtidV021_,		/* DELETE */
125     FFESTD_stmtidV022_,		/* UNLOCK */
126     FFESTD_stmtidV023_,		/* ENCODE */
127     FFESTD_stmtidV024_,		/* DECODE */
128     FFESTD_stmtidV025start_,	/* DEFINEFILE (start) */
129     FFESTD_stmtidV025item_,	/* (DEFINEFILE item) */
130     FFESTD_stmtidV025finish_,	/* (DEFINEFILE finish) */
131     FFESTD_stmtidV026_,		/* FIND */
132 #endif
133     FFESTD_stmtid_,
134   } ffestdStmtId_;
135 
136 /* Internal typedefs. */
137 
138 typedef struct _ffestd_expr_item_ *ffestdExprItem_;
139 typedef struct _ffestd_stmt_ *ffestdStmt_;
140 
141 /* Private include files. */
142 
143 
144 /* Internal structure definitions. */
145 
146 struct _ffestd_expr_item_
147   {
148     ffestdExprItem_ next;
149     ffebld expr;
150     ffelexToken token;
151   };
152 
153 struct _ffestd_stmt_
154   {
155     ffestdStmt_ next;
156     ffestdStmt_ previous;
157     ffestdStmtId_ id;
158     char *filename;
159     int filelinenum;
160     union
161       {
162 	struct
163 	  {
164 	    ffestw block;
165 	  }
166 	enddoloop;
167 	struct
168 	  {
169 	    ffelab label;
170 	  }
171 	execlabel;
172 	struct
173 	  {
174 	    ffelab label;
175 	  }
176 	formatlabel;
177 	struct
178 	  {
179 	    mallocPool pool;
180 	    ffebld dest;
181 	    ffebld source;
182 	  }
183 	R737A;
184 	struct
185 	  {
186 	    mallocPool pool;
187 	    ffestw block;
188 	    ffebld expr;
189 	  }
190 	R803;
191 	struct
192 	  {
193 	    mallocPool pool;
194 	    ffestw block;
195 	    ffebld expr;
196 	  }
197 	R804;
198 	struct
199 	  {
200 	    ffestw block;
201 	  }
202 	R805;
203 	struct
204 	  {
205 	    ffestw block;
206 	  }
207 	R806;
208 	struct
209 	  {
210 	    mallocPool pool;
211 	    ffebld expr;
212 	  }
213 	R807;
214 	struct
215 	  {
216 	    mallocPool pool;
217 	    ffestw block;
218 	    ffebld expr;
219 	  }
220 	R809;
221 	struct
222 	  {
223 	    mallocPool pool;
224 	    ffestw block;
225 	    unsigned long casenum;
226 	  }
227 	R810;
228 	struct
229 	  {
230 	    ffestw block;
231 	  }
232 	R811;
233 	struct
234 	  {
235 	    mallocPool pool;
236 	    ffestw block;
237 	    ffelab label;
238 	    ffebld var;
239 	    ffebld start;
240 	    ffelexToken start_token;
241 	    ffebld end;
242 	    ffelexToken end_token;
243 	    ffebld incr;
244 	    ffelexToken incr_token;
245 	  }
246 	R819A;
247 	struct
248 	  {
249 	    mallocPool pool;
250 	    ffestw block;
251 	    ffelab label;
252 	    ffebld expr;
253 	  }
254 	R819B;
255 	struct
256 	  {
257 	    ffestw block;
258 	  }
259 	R834;
260 	struct
261 	  {
262 	    ffestw block;
263 	  }
264 	R835;
265 	struct
266 	  {
267 	    ffelab label;
268 	  }
269 	R836;
270 	struct
271 	  {
272 	    mallocPool pool;
273 	    ffelab *labels;
274 	    int count;
275 	    ffebld expr;
276 	  }
277 	R837;
278 	struct
279 	  {
280 	    mallocPool pool;
281 	    ffelab label;
282 	    ffebld target;
283 	  }
284 	R838;
285 	struct
286 	  {
287 	    mallocPool pool;
288 	    ffebld target;
289 	  }
290 	R839;
291 	struct
292 	  {
293 	    mallocPool pool;
294 	    ffebld expr;
295 	    ffelab neg;
296 	    ffelab zero;
297 	    ffelab pos;
298 	  }
299 	R840;
300 	struct
301 	  {
302 	    mallocPool pool;
303 	    ffebld expr;
304 	  }
305 	R842;
306 	struct
307 	  {
308 	    mallocPool pool;
309 	    ffebld expr;
310 	  }
311 	R843;
312 	struct
313 	  {
314 	    mallocPool pool;
315 	    ffestpOpenStmt *params;
316 	  }
317 	R904;
318 	struct
319 	  {
320 	    mallocPool pool;
321 	    ffestpCloseStmt *params;
322 	  }
323 	R907;
324 	struct
325 	  {
326 	    mallocPool pool;
327 	    ffestpReadStmt *params;
328 	    bool only_format;
329 	    ffestvUnit unit;
330 	    ffestvFormat format;
331 	    bool rec;
332 	    bool key;
333 	    ffestdExprItem_ list;
334 	  }
335 	R909;
336 	struct
337 	  {
338 	    mallocPool pool;
339 	    ffestpWriteStmt *params;
340 	    ffestvUnit unit;
341 	    ffestvFormat format;
342 	    bool rec;
343 	    ffestdExprItem_ list;
344 	  }
345 	R910;
346 	struct
347 	  {
348 	    mallocPool pool;
349 	    ffestpPrintStmt *params;
350 	    ffestvFormat format;
351 	    ffestdExprItem_ list;
352 	  }
353 	R911;
354 	struct
355 	  {
356 	    mallocPool pool;
357 	    ffestpBeruStmt *params;
358 	  }
359 	R919;
360 	struct
361 	  {
362 	    mallocPool pool;
363 	    ffestpBeruStmt *params;
364 	  }
365 	R920;
366 	struct
367 	  {
368 	    mallocPool pool;
369 	    ffestpBeruStmt *params;
370 	  }
371 	R921;
372 	struct
373 	  {
374 	    mallocPool pool;
375 	    ffestpInquireStmt *params;
376 	    bool by_file;
377 	  }
378 	R923A;
379 	struct
380 	  {
381 	    mallocPool pool;
382 	    ffestpInquireStmt *params;
383 	    ffestdExprItem_ list;
384 	  }
385 	R923B;
386 	struct
387 	  {
388 	    ffestsHolder str;
389 	  }
390 	R1001;
391 	struct
392 	  {
393 	    mallocPool pool;
394 	    ffebld expr;
395 	  }
396 	R1212;
397 	struct
398 	  {
399 	    ffesymbol entry;
400 	    int entrynum;
401 	  }
402 	R1226;
403 	struct
404 	  {
405 	    mallocPool pool;
406 	    ffestw block;
407 	    ffebld expr;
408 	  }
409 	R1227;
410 #if FFESTR_VXT
411 	struct
412 	  {
413 	    mallocPool pool;
414 	    ffestpRewriteStmt *params;
415 	    ffestvFormat format;
416 	    ffestdExprItem_ list;
417 	  }
418 	V018;
419 	struct
420 	  {
421 	    mallocPool pool;
422 	    ffestpAcceptStmt *params;
423 	    ffestvFormat format;
424 	    ffestdExprItem_ list;
425 	  }
426 	V019;
427 #endif
428 	struct
429 	  {
430 	    mallocPool pool;
431 	    ffestpTypeStmt *params;
432 	    ffestvFormat format;
433 	    ffestdExprItem_ list;
434 	  }
435 	V020;
436 #if FFESTR_VXT
437 	struct
438 	  {
439 	    mallocPool pool;
440 	    ffestpDeleteStmt *params;
441 	  }
442 	V021;
443 	struct
444 	  {
445 	    mallocPool pool;
446 	    ffestpBeruStmt *params;
447 	  }
448 	V022;
449 	struct
450 	  {
451 	    mallocPool pool;
452 	    ffestpVxtcodeStmt *params;
453 	    ffestdExprItem_ list;
454 	  }
455 	V023;
456 	struct
457 	  {
458 	    mallocPool pool;
459 	    ffestpVxtcodeStmt *params;
460 	    ffestdExprItem_ list;
461 	  }
462 	V024;
463 	struct
464 	  {
465 	    ffebld u;
466 	    ffebld m;
467 	    ffebld n;
468 	    ffebld asv;
469 	  }
470 	V025item;
471 	struct
472 	  {
473 	    mallocPool pool;
474 	  } V025finish;
475 	struct
476 	  {
477 	    mallocPool pool;
478 	    ffestpFindStmt *params;
479 	  }
480 	V026;
481 #endif
482       }
483     u;
484   };
485 
486 /* Static objects accessed by functions in this module. */
487 
488 static ffestdStatelet_ ffestd_statelet_ = FFESTD_stateletSIMPLE_;
489 static int ffestd_block_level_ = 0;	/* Block level for reachableness. */
490 static bool ffestd_is_reachable_;	/* Is the current stmt reachable?  */
491 static ffelab ffestd_label_formatdef_ = NULL;
492 static ffestdExprItem_ *ffestd_expr_list_;
493 static struct
494   {
495     ffestdStmt_ first;
496     ffestdStmt_ last;
497   }
498 ffestd_stmt_list_ =
499 {
500   NULL, NULL
501 };
502 
503 
504 /* # ENTRY statements pending. */
505 static int ffestd_2pass_entrypoints_ = 0;
506 
507 /* Static functions (internal). */
508 
509 static void ffestd_stmt_append_ (ffestdStmt_ stmt);
510 static ffestdStmt_ ffestd_stmt_new_ (ffestdStmtId_ id);
511 static void ffestd_stmt_pass_ (void);
512 #if FFESTD_COPY_EASY_
513 static ffestpInquireStmt *ffestd_subr_copy_easy_ (ffestpInquireIx max);
514 #endif
515 static void ffestd_subr_vxt_ (void);
516 #if FFESTR_F90
517 static void ffestd_subr_f90_ (void);
518 #endif
519 static void ffestd_subr_labels_ (bool unexpected);
520 static void ffestd_R1001dump_ (ffests s, ffesttFormatList list);
521 static void ffestd_R1001dump_1005_1_ (ffests s, ffesttFormatList f,
522 				      const char *string);
523 static void ffestd_R1001dump_1005_2_ (ffests s, ffesttFormatList f,
524 				      const char *string);
525 static void ffestd_R1001dump_1005_3_ (ffests s, ffesttFormatList f,
526 				      const char *string);
527 static void ffestd_R1001dump_1005_4_ (ffests s, ffesttFormatList f,
528 				      const char *string);
529 static void ffestd_R1001dump_1005_5_ (ffests s, ffesttFormatList f,
530 				      const char *string);
531 static void ffestd_R1001dump_1010_1_ (ffests s, ffesttFormatList f,
532 				      const char *string);
533 static void ffestd_R1001dump_1010_2_ (ffests s, ffesttFormatList f,
534 				      const char *string);
535 static void ffestd_R1001dump_1010_3_ (ffests s, ffesttFormatList f,
536 				      const char *string);
537 static void ffestd_R1001dump_1010_4_ (ffests s, ffesttFormatList f,
538 				      const char *string);
539 static void ffestd_R1001dump_1010_5_ (ffests s, ffesttFormatList f,
540 				      const char *string);
541 static void ffestd_R1001error_ (ffesttFormatList f);
542 static void ffestd_R1001rtexpr_ (ffests s, ffesttFormatList f, ffebld expr);
543 
544 /* Internal macros. */
545 
546 #define ffestd_subr_line_now_()					       \
547   ffeste_set_line (ffelex_token_where_filename (ffesta_tokens[0]), \
548 		   ffelex_token_where_filelinenum (ffesta_tokens[0]))
549 #define ffestd_subr_line_restore_(s) \
550   ffeste_set_line ((s)->filename, (s)->filelinenum)
551 #define ffestd_subr_line_save_(s)					   \
552   ((s)->filename = ffelex_token_where_filename (ffesta_tokens[0]),	   \
553    (s)->filelinenum = ffelex_token_where_filelinenum (ffesta_tokens[0]))
554 #define ffestd_check_simple_() \
555       assert(ffestd_statelet_ == FFESTD_stateletSIMPLE_)
556 #define ffestd_check_start_() \
557       assert(ffestd_statelet_ == FFESTD_stateletSIMPLE_); \
558       ffestd_statelet_ = FFESTD_stateletATTRIB_
559 #define ffestd_check_attrib_() \
560       assert(ffestd_statelet_ == FFESTD_stateletATTRIB_)
561 #define ffestd_check_item_() \
562       assert(ffestd_statelet_ == FFESTD_stateletATTRIB_	 \
563 	    || ffestd_statelet_ == FFESTD_stateletITEM_); \
564       ffestd_statelet_ = FFESTD_stateletITEM_
565 #define ffestd_check_item_startvals_() \
566       assert(ffestd_statelet_ == FFESTD_stateletATTRIB_	 \
567 	    || ffestd_statelet_ == FFESTD_stateletITEM_); \
568       ffestd_statelet_ = FFESTD_stateletITEMVALS_
569 #define ffestd_check_item_value_() \
570       assert(ffestd_statelet_ == FFESTD_stateletITEMVALS_)
571 #define ffestd_check_item_endvals_() \
572       assert(ffestd_statelet_ == FFESTD_stateletITEMVALS_); \
573       ffestd_statelet_ = FFESTD_stateletITEM_
574 #define ffestd_check_finish_() \
575       assert(ffestd_statelet_ == FFESTD_stateletATTRIB_	 \
576 	    || ffestd_statelet_ == FFESTD_stateletITEM_); \
577       ffestd_statelet_ = FFESTD_stateletSIMPLE_
578 
579 #if FFESTD_COPY_EASY_
580 #define ffestd_subr_copy_accept_() (ffestpAcceptStmt *) \
581       ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_acceptix)
582 #define ffestd_subr_copy_beru_() (ffestpBeruStmt *) \
583       ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_beruix)
584 #define ffestd_subr_copy_close_() (ffestpCloseStmt *) \
585       ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_closeix)
586 #define ffestd_subr_copy_delete_() (ffestpDeleteStmt *) \
587       ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_deleteix)
588 #define ffestd_subr_copy_find_() (ffestpFindStmt *) \
589       ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_findix)
590 #define ffestd_subr_copy_inquire_() (ffestpInquireStmt *) \
591       ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_inquireix)
592 #define ffestd_subr_copy_open_() (ffestpOpenStmt *) \
593       ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_openix)
594 #define ffestd_subr_copy_print_() (ffestpPrintStmt *) \
595       ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_printix)
596 #define ffestd_subr_copy_read_() (ffestpReadStmt *) \
597       ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_readix)
598 #define ffestd_subr_copy_rewrite_() (ffestpRewriteStmt *) \
599       ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_rewriteix)
600 #define ffestd_subr_copy_type_() (ffestpTypeStmt *) \
601       ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_typeix)
602 #define ffestd_subr_copy_vxtcode_() (ffestpVxtcodeStmt *) \
603       ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_vxtcodeix)
604 #define ffestd_subr_copy_write_() (ffestpWriteStmt *) \
605       ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_writeix)
606 #endif
607 
608 /* ffestd_stmt_append_ -- Append statement to end of stmt list
609 
610    ffestd_stmt_append_(ffestd_stmt_new_(FFESTD_stmtidR737A_));	*/
611 
612 static void
ffestd_stmt_append_(ffestdStmt_ stmt)613 ffestd_stmt_append_ (ffestdStmt_ stmt)
614 {
615   stmt->next = (ffestdStmt_) &ffestd_stmt_list_.first;
616   stmt->previous = ffestd_stmt_list_.last;
617   stmt->next->previous = stmt;
618   stmt->previous->next = stmt;
619 }
620 
621 /* ffestd_stmt_new_ -- Make new statement with given id
622 
623    ffestdStmt_ stmt;
624    stmt = ffestd_stmt_new_(FFESTD_stmtidR737A_);  */
625 
626 static ffestdStmt_
ffestd_stmt_new_(ffestdStmtId_ id)627 ffestd_stmt_new_ (ffestdStmtId_ id)
628 {
629   ffestdStmt_ stmt;
630 
631   stmt = malloc_new_kp (ffe_pool_any_unit (), "ffestdStmt_", sizeof (*stmt));
632   stmt->id = id;
633   return stmt;
634 }
635 
636 /* ffestd_stmt_pass_ -- Pass all statements on list to ffeste
637 
638    ffestd_stmt_pass_();	 */
639 
640 static void
ffestd_stmt_pass_()641 ffestd_stmt_pass_ ()
642 {
643   ffestdStmt_ stmt;
644   ffestdExprItem_ expr;		/* For traversing lists. */
645   bool okay = (TREE_CODE (current_function_decl) != ERROR_MARK);
646 
647   if ((ffestd_2pass_entrypoints_ != 0) && okay)
648     {
649       tree which = ffecom_which_entrypoint_decl ();
650       tree value;
651       tree label;
652       int pushok;
653       int ents = ffestd_2pass_entrypoints_;
654       tree duplicate;
655 
656       expand_start_case (0, which, TREE_TYPE (which), "entrypoint dispatch");
657 
658       stmt = ffestd_stmt_list_.first;
659       do
660 	{
661 	  while (stmt->id != FFESTD_stmtidR1226_)
662 	    stmt = stmt->next;
663 
664 	  if (stmt->u.R1226.entry != NULL)
665 	    {
666 	      value = build_int_2 (stmt->u.R1226.entrynum, 0);
667 	      /* Yes, we really want to build a null LABEL_DECL here and not
668 		 put it on any list.  That's what pushcase wants, so that's
669 		 what it gets!  */
670 	      label = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
671 
672 	      pushok = pushcase (value, convert, label, &duplicate);
673 	      assert (pushok == 0);
674 
675 	      label = ffecom_temp_label ();
676 	      TREE_USED (label) = 1;
677 	      expand_goto (label);
678 
679 	      ffesymbol_hook (stmt->u.R1226.entry).length_tree = label;
680 	    }
681 	  stmt = stmt->next;
682 	}
683       while (--ents != 0);
684 
685       expand_end_case (which);
686     }
687 
688   for (stmt = ffestd_stmt_list_.first;
689        stmt != (ffestdStmt_) &ffestd_stmt_list_.first;
690        stmt = stmt->next)
691     {
692       switch (stmt->id)
693 	{
694 	case FFESTD_stmtidENDDOLOOP_:
695 	  ffestd_subr_line_restore_ (stmt);
696 	  if (okay)
697 	    ffeste_do (stmt->u.enddoloop.block);
698 	  ffestw_kill (stmt->u.enddoloop.block);
699 	  break;
700 
701 	case FFESTD_stmtidENDLOGIF_:
702 	  ffestd_subr_line_restore_ (stmt);
703 	  if (okay)
704 	    ffeste_end_R807 ();
705 	  break;
706 
707 	case FFESTD_stmtidEXECLABEL_:
708 	  if (okay)
709 	    ffeste_labeldef_branch (stmt->u.execlabel.label);
710 	  break;
711 
712 	case FFESTD_stmtidFORMATLABEL_:
713 	  if (okay)
714 	    ffeste_labeldef_format (stmt->u.formatlabel.label);
715 	  break;
716 
717 	case FFESTD_stmtidR737A_:
718 	  ffestd_subr_line_restore_ (stmt);
719 	  if (okay)
720 	    ffeste_R737A (stmt->u.R737A.dest, stmt->u.R737A.source);
721 	  malloc_pool_kill (stmt->u.R737A.pool);
722 	  break;
723 
724 	case FFESTD_stmtidR803_:
725 	  ffestd_subr_line_restore_ (stmt);
726 	  if (okay)
727 	    ffeste_R803 (stmt->u.R803.block, stmt->u.R803.expr);
728 	  malloc_pool_kill (stmt->u.R803.pool);
729 	  break;
730 
731 	case FFESTD_stmtidR804_:
732 	  ffestd_subr_line_restore_ (stmt);
733 	  if (okay)
734 	    ffeste_R804 (stmt->u.R803.block, stmt->u.R804.expr);
735 	  malloc_pool_kill (stmt->u.R804.pool);
736 	  break;
737 
738 	case FFESTD_stmtidR805_:
739 	  ffestd_subr_line_restore_ (stmt);
740 	  if (okay)
741 	    ffeste_R805 (stmt->u.R803.block);
742 	  break;
743 
744 	case FFESTD_stmtidR806_:
745 	  ffestd_subr_line_restore_ (stmt);
746 	  if (okay)
747 	    ffeste_R806 (stmt->u.R806.block);
748 	  ffestw_kill (stmt->u.R806.block);
749 	  break;
750 
751 	case FFESTD_stmtidR807_:
752 	  ffestd_subr_line_restore_ (stmt);
753 	  if (okay)
754 	    ffeste_R807 (stmt->u.R807.expr);
755 	  malloc_pool_kill (stmt->u.R807.pool);
756 	  break;
757 
758 	case FFESTD_stmtidR809_:
759 	  ffestd_subr_line_restore_ (stmt);
760 	  if (okay)
761 	    ffeste_R809 (stmt->u.R809.block, stmt->u.R809.expr);
762 	  malloc_pool_kill (stmt->u.R809.pool);
763 	  break;
764 
765 	case FFESTD_stmtidR810_:
766 	  ffestd_subr_line_restore_ (stmt);
767 	  if (okay)
768 	    ffeste_R810 (stmt->u.R810.block, stmt->u.R810.casenum);
769 	  malloc_pool_kill (stmt->u.R810.pool);
770 	  break;
771 
772 	case FFESTD_stmtidR811_:
773 	  ffestd_subr_line_restore_ (stmt);
774 	  if (okay)
775 	    ffeste_R811 (stmt->u.R811.block);
776 	  malloc_pool_kill (ffestw_select (stmt->u.R811.block)->pool);
777 	  ffestw_kill (stmt->u.R811.block);
778 	  break;
779 
780 	case FFESTD_stmtidR819A_:
781 	  ffestd_subr_line_restore_ (stmt);
782 	  if (okay)
783 	    ffeste_R819A (stmt->u.R819A.block, stmt->u.R819A.label,
784 			  stmt->u.R819A.var,
785 			  stmt->u.R819A.start, stmt->u.R819A.start_token,
786 			  stmt->u.R819A.end, stmt->u.R819A.end_token,
787 			  stmt->u.R819A.incr, stmt->u.R819A.incr_token);
788 	  ffelex_token_kill (stmt->u.R819A.start_token);
789 	  ffelex_token_kill (stmt->u.R819A.end_token);
790 	  if (stmt->u.R819A.incr_token != NULL)
791 	    ffelex_token_kill (stmt->u.R819A.incr_token);
792 	  malloc_pool_kill (stmt->u.R819A.pool);
793 	  break;
794 
795 	case FFESTD_stmtidR819B_:
796 	  ffestd_subr_line_restore_ (stmt);
797 	  if (okay)
798 	    ffeste_R819B (stmt->u.R819B.block, stmt->u.R819B.label,
799 			  stmt->u.R819B.expr);
800 	  malloc_pool_kill (stmt->u.R819B.pool);
801 	  break;
802 
803 	case FFESTD_stmtidR825_:
804 	  ffestd_subr_line_restore_ (stmt);
805 	  if (okay)
806 	    ffeste_R825 ();
807 	  break;
808 
809 	case FFESTD_stmtidR834_:
810 	  ffestd_subr_line_restore_ (stmt);
811 	  if (okay)
812 	    ffeste_R834 (stmt->u.R834.block);
813 	  break;
814 
815 	case FFESTD_stmtidR835_:
816 	  ffestd_subr_line_restore_ (stmt);
817 	  if (okay)
818 	    ffeste_R835 (stmt->u.R835.block);
819 	  break;
820 
821 	case FFESTD_stmtidR836_:
822 	  ffestd_subr_line_restore_ (stmt);
823 	  if (okay)
824 	    ffeste_R836 (stmt->u.R836.label);
825 	  break;
826 
827 	case FFESTD_stmtidR837_:
828 	  ffestd_subr_line_restore_ (stmt);
829 	  if (okay)
830 	    ffeste_R837 (stmt->u.R837.labels, stmt->u.R837.count,
831 			 stmt->u.R837.expr);
832 	  malloc_pool_kill (stmt->u.R837.pool);
833 	  break;
834 
835 	case FFESTD_stmtidR838_:
836 	  ffestd_subr_line_restore_ (stmt);
837 	  if (okay)
838 	    ffeste_R838 (stmt->u.R838.label, stmt->u.R838.target);
839 	  malloc_pool_kill (stmt->u.R838.pool);
840 	  break;
841 
842 	case FFESTD_stmtidR839_:
843 	  ffestd_subr_line_restore_ (stmt);
844 	  if (okay)
845 	    ffeste_R839 (stmt->u.R839.target);
846 	  malloc_pool_kill (stmt->u.R839.pool);
847 	  break;
848 
849 	case FFESTD_stmtidR840_:
850 	  ffestd_subr_line_restore_ (stmt);
851 	  if (okay)
852 	    ffeste_R840 (stmt->u.R840.expr, stmt->u.R840.neg, stmt->u.R840.zero,
853 			 stmt->u.R840.pos);
854 	  malloc_pool_kill (stmt->u.R840.pool);
855 	  break;
856 
857 	case FFESTD_stmtidR841_:
858 	  ffestd_subr_line_restore_ (stmt);
859 	  if (okay)
860 	    ffeste_R841 ();
861 	  break;
862 
863 	case FFESTD_stmtidR842_:
864 	  ffestd_subr_line_restore_ (stmt);
865 	  if (okay)
866 	    ffeste_R842 (stmt->u.R842.expr);
867 	  if (stmt->u.R842.pool != NULL)
868 	    malloc_pool_kill (stmt->u.R842.pool);
869 	  break;
870 
871 	case FFESTD_stmtidR843_:
872 	  ffestd_subr_line_restore_ (stmt);
873 	  if (okay)
874 	    ffeste_R843 (stmt->u.R843.expr);
875 	  malloc_pool_kill (stmt->u.R843.pool);
876 	  break;
877 
878 	case FFESTD_stmtidR904_:
879 	  ffestd_subr_line_restore_ (stmt);
880 	  if (okay)
881 	    ffeste_R904 (stmt->u.R904.params);
882 	  malloc_pool_kill (stmt->u.R904.pool);
883 	  break;
884 
885 	case FFESTD_stmtidR907_:
886 	  ffestd_subr_line_restore_ (stmt);
887 	  if (okay)
888 	    ffeste_R907 (stmt->u.R907.params);
889 	  malloc_pool_kill (stmt->u.R907.pool);
890 	  break;
891 
892 	case FFESTD_stmtidR909_:
893 	  ffestd_subr_line_restore_ (stmt);
894 	  if (okay)
895 	    ffeste_R909_start (stmt->u.R909.params, stmt->u.R909.only_format,
896 			       stmt->u.R909.unit, stmt->u.R909.format,
897 			       stmt->u.R909.rec, stmt->u.R909.key);
898 	  for (expr = stmt->u.R909.list; expr != NULL; expr = expr->next)
899 	    {
900 	      if (okay)
901 		ffeste_R909_item (expr->expr, expr->token);
902 	      ffelex_token_kill (expr->token);
903 	    }
904 	  if (okay)
905 	    ffeste_R909_finish ();
906 	  malloc_pool_kill (stmt->u.R909.pool);
907 	  break;
908 
909 	case FFESTD_stmtidR910_:
910 	  ffestd_subr_line_restore_ (stmt);
911 	  if (okay)
912 	    ffeste_R910_start (stmt->u.R910.params, stmt->u.R910.unit,
913 			       stmt->u.R910.format, stmt->u.R910.rec);
914 	  for (expr = stmt->u.R910.list; expr != NULL; expr = expr->next)
915 	    {
916 	      if (okay)
917 		ffeste_R910_item (expr->expr, expr->token);
918 	      ffelex_token_kill (expr->token);
919 	    }
920 	  if (okay)
921 	    ffeste_R910_finish ();
922 	  malloc_pool_kill (stmt->u.R910.pool);
923 	  break;
924 
925 	case FFESTD_stmtidR911_:
926 	  ffestd_subr_line_restore_ (stmt);
927 	  if (okay)
928 	    ffeste_R911_start (stmt->u.R911.params, stmt->u.R911.format);
929 	  for (expr = stmt->u.R911.list; expr != NULL; expr = expr->next)
930 	    {
931 	      if (okay)
932 		ffeste_R911_item (expr->expr, expr->token);
933 	      ffelex_token_kill (expr->token);
934 	    }
935 	  if (okay)
936 	    ffeste_R911_finish ();
937 	  malloc_pool_kill (stmt->u.R911.pool);
938 	  break;
939 
940 	case FFESTD_stmtidR919_:
941 	  ffestd_subr_line_restore_ (stmt);
942 	  if (okay)
943 	    ffeste_R919 (stmt->u.R919.params);
944 	  malloc_pool_kill (stmt->u.R919.pool);
945 	  break;
946 
947 	case FFESTD_stmtidR920_:
948 	  ffestd_subr_line_restore_ (stmt);
949 	  if (okay)
950 	    ffeste_R920 (stmt->u.R920.params);
951 	  malloc_pool_kill (stmt->u.R920.pool);
952 	  break;
953 
954 	case FFESTD_stmtidR921_:
955 	  ffestd_subr_line_restore_ (stmt);
956 	  if (okay)
957 	    ffeste_R921 (stmt->u.R921.params);
958 	  malloc_pool_kill (stmt->u.R921.pool);
959 	  break;
960 
961 	case FFESTD_stmtidR923A_:
962 	  ffestd_subr_line_restore_ (stmt);
963 	  if (okay)
964 	    ffeste_R923A (stmt->u.R923A.params, stmt->u.R923A.by_file);
965 	  malloc_pool_kill (stmt->u.R923A.pool);
966 	  break;
967 
968 	case FFESTD_stmtidR923B_:
969 	  ffestd_subr_line_restore_ (stmt);
970 	  if (okay)
971 	    ffeste_R923B_start (stmt->u.R923B.params);
972 	  for (expr = stmt->u.R923B.list; expr != NULL; expr = expr->next)
973 	    {
974 	      if (okay)
975 		ffeste_R923B_item (expr->expr);
976 	    }
977 	  if (okay)
978 	    ffeste_R923B_finish ();
979 	  malloc_pool_kill (stmt->u.R923B.pool);
980 	  break;
981 
982 	case FFESTD_stmtidR1001_:
983 	  if (okay)
984 	    ffeste_R1001 (&stmt->u.R1001.str);
985 	  ffests_kill (&stmt->u.R1001.str);
986 	  break;
987 
988 	case FFESTD_stmtidR1103_:
989 	  if (okay)
990 	    ffeste_R1103 ();
991 	  break;
992 
993 	case FFESTD_stmtidR1112_:
994 	  if (okay)
995 	    ffeste_R1112 ();
996 	  break;
997 
998 	case FFESTD_stmtidR1212_:
999 	  ffestd_subr_line_restore_ (stmt);
1000 	  if (okay)
1001 	    ffeste_R1212 (stmt->u.R1212.expr);
1002 	  malloc_pool_kill (stmt->u.R1212.pool);
1003 	  break;
1004 
1005 	case FFESTD_stmtidR1221_:
1006 	  if (okay)
1007 	    ffeste_R1221 ();
1008 	  break;
1009 
1010 	case FFESTD_stmtidR1225_:
1011 	  if (okay)
1012 	    ffeste_R1225 ();
1013 	  break;
1014 
1015 	case FFESTD_stmtidR1226_:
1016 	  ffestd_subr_line_restore_ (stmt);
1017 	  if (stmt->u.R1226.entry != NULL)
1018 	    {
1019 	      if (okay)
1020 		ffeste_R1226 (stmt->u.R1226.entry);
1021 	    }
1022 	  break;
1023 
1024 	case FFESTD_stmtidR1227_:
1025 	  ffestd_subr_line_restore_ (stmt);
1026 	  if (okay)
1027 	    ffeste_R1227 (stmt->u.R1227.block, stmt->u.R1227.expr);
1028 	  malloc_pool_kill (stmt->u.R1227.pool);
1029 	  break;
1030 
1031 #if FFESTR_VXT
1032 	case FFESTD_stmtidV018_:
1033 	  ffestd_subr_line_restore_ (stmt);
1034 	  if (okay)
1035 	    ffeste_V018_start (stmt->u.V018.params, stmt->u.V018.format);
1036 	  for (expr = stmt->u.V018.list; expr != NULL; expr = expr->next)
1037 	    {
1038 	      if (okay)
1039 		ffeste_V018_item (expr->expr);
1040 	    }
1041 	  if (okay)
1042 	    ffeste_V018_finish ();
1043 	  malloc_pool_kill (stmt->u.V018.pool);
1044 	  break;
1045 
1046 	case FFESTD_stmtidV019_:
1047 	  ffestd_subr_line_restore_ (stmt);
1048 	  if (okay)
1049 	    ffeste_V019_start (stmt->u.V019.params, stmt->u.V019.format);
1050 	  for (expr = stmt->u.V019.list; expr != NULL; expr = expr->next)
1051 	    {
1052 	      if (okay)
1053 		ffeste_V019_item (expr->expr);
1054 	    }
1055 	  if (okay)
1056 	    ffeste_V019_finish ();
1057 	  malloc_pool_kill (stmt->u.V019.pool);
1058 	  break;
1059 #endif
1060 
1061 	case FFESTD_stmtidV020_:
1062 	  ffestd_subr_line_restore_ (stmt);
1063 	  if (okay)
1064 	    ffeste_V020_start (stmt->u.V020.params, stmt->u.V020.format);
1065 	  for (expr = stmt->u.V020.list; expr != NULL; expr = expr->next)
1066 	    {
1067 	      if (okay)
1068 		ffeste_V020_item (expr->expr);
1069 	    }
1070 	  if (okay)
1071 	    ffeste_V020_finish ();
1072 	  malloc_pool_kill (stmt->u.V020.pool);
1073 	  break;
1074 
1075 #if FFESTR_VXT
1076 	case FFESTD_stmtidV021_:
1077 	  ffestd_subr_line_restore_ (stmt);
1078 	  if (okay)
1079 	    ffeste_V021 (stmt->u.V021.params);
1080 	  malloc_pool_kill (stmt->u.V021.pool);
1081 	  break;
1082 
1083 	case FFESTD_stmtidV023_:
1084 	  ffestd_subr_line_restore_ (stmt);
1085 	  if (okay)
1086 	    ffeste_V023_start (stmt->u.V023.params);
1087 	  for (expr = stmt->u.V023.list; expr != NULL; expr = expr->next)
1088 	    {
1089 	      if (okay)
1090 		ffeste_V023_item (expr->expr);
1091 	    }
1092 	  if (okay)
1093 	    ffeste_V023_finish ();
1094 	  malloc_pool_kill (stmt->u.V023.pool);
1095 	  break;
1096 
1097 	case FFESTD_stmtidV024_:
1098 	  ffestd_subr_line_restore_ (stmt);
1099 	  if (okay)
1100 	    ffeste_V024_start (stmt->u.V024.params);
1101 	  for (expr = stmt->u.V024.list; expr != NULL; expr = expr->next)
1102 	    {
1103 	      if (okay)
1104 		ffeste_V024_item (expr->expr);
1105 	    }
1106 	  if (okay)
1107 	    ffeste_V024_finish ();
1108 	  malloc_pool_kill (stmt->u.V024.pool);
1109 	  break;
1110 
1111 	case FFESTD_stmtidV025start_:
1112 	  ffestd_subr_line_restore_ (stmt);
1113 	  if (okay)
1114 	    ffeste_V025_start ();
1115 	  break;
1116 
1117 	case FFESTD_stmtidV025item_:
1118 	  if (okay)
1119 	    ffeste_V025_item (stmt->u.V025item.u, stmt->u.V025item.m,
1120 			      stmt->u.V025item.n, stmt->u.V025item.asv);
1121 	  break;
1122 
1123 	case FFESTD_stmtidV025finish_:
1124 	  if (okay)
1125 	    ffeste_V025_finish ();
1126 	  malloc_pool_kill (stmt->u.V025finish.pool);
1127 	  break;
1128 
1129 	case FFESTD_stmtidV026_:
1130 	  ffestd_subr_line_restore_ (stmt);
1131 	  if (okay)
1132 	    ffeste_V026 (stmt->u.V026.params);
1133 	  malloc_pool_kill (stmt->u.V026.pool);
1134 	  break;
1135 #endif
1136 
1137 	default:
1138 	  assert ("bad stmt->id" == NULL);
1139 	  break;
1140 	}
1141     }
1142 }
1143 
1144 /* ffestd_subr_copy_easy_ -- Copy I/O statement data structure
1145 
1146    ffestd_subr_copy_easy_();
1147 
1148    Copies all data except tokens in the I/O data structure into a new
1149    structure that lasts as long as the output pool for the current
1150    statement.  Assumes that they are
1151    overlaid with each other (union) in stp.h and the typing
1152    and structure references assume (though not necessarily dangerous if
1153    FALSE) that INQUIRE has the most file elements.  */
1154 
1155 #if FFESTD_COPY_EASY_
1156 static ffestpInquireStmt *
ffestd_subr_copy_easy_(ffestpInquireIx max)1157 ffestd_subr_copy_easy_ (ffestpInquireIx max)
1158 {
1159   ffestpInquireStmt *stmt;
1160   ffestpInquireIx ix;
1161 
1162   stmt = (ffestpInquireStmt *) malloc_new_kp (ffesta_output_pool,
1163 				  "FFESTD easy", sizeof (ffestpFile) * max);
1164 
1165   for (ix = 0; ix < max; ++ix)
1166     {
1167       if ((stmt->inquire_spec[ix].kw_or_val_present
1168 	   = ffestp_file.inquire.inquire_spec[ix].kw_or_val_present)
1169 	  && (stmt->inquire_spec[ix].value_present
1170 	      = ffestp_file.inquire.inquire_spec[ix].value_present))
1171 	{
1172 	  if ((stmt->inquire_spec[ix].value_is_label
1173 	       = ffestp_file.inquire.inquire_spec[ix].value_is_label))
1174 	    stmt->inquire_spec[ix].u.label
1175 	      = ffestp_file.inquire.inquire_spec[ix].u.label;
1176 	  else
1177 	    stmt->inquire_spec[ix].u.expr
1178 	      = ffestp_file.inquire.inquire_spec[ix].u.expr;
1179 	}
1180     }
1181 
1182   return stmt;
1183 }
1184 
1185 #endif
1186 /* ffestd_subr_labels_ -- Handle any undefined labels
1187 
1188    ffestd_subr_labels_(FALSE);
1189 
1190    For every undefined label, generate an error message and either define
1191    label as a FORMAT() statement (for FORMAT labels) or as a STOP statement
1192    (for all other labels).  */
1193 
1194 static void
ffestd_subr_labels_(bool unexpected)1195 ffestd_subr_labels_ (bool unexpected)
1196 {
1197   ffelab l;
1198   ffelabHandle h;
1199   ffelabNumber undef;
1200   ffesttFormatList f;
1201 
1202   undef = ffelab_number () - ffestv_num_label_defines_;
1203 
1204   for (h = ffelab_handle_first (); h != NULL; h = ffelab_handle_next (h))
1205     {
1206       l = ffelab_handle_target (h);
1207       if (ffewhere_line_is_unknown (ffelab_definition_line (l)))
1208 	{			/* Undefined label. */
1209 	  assert (!unexpected);
1210 	  assert (undef > 0);
1211 	  undef--;
1212 	  ffebad_start (FFEBAD_UNDEF_LABEL);
1213 	  if (ffelab_type (l) == FFELAB_typeLOOPEND)
1214 	    ffebad_here (0, ffelab_doref_line (l), ffelab_doref_column (l));
1215 	  else if (ffelab_type (l) != FFELAB_typeANY)
1216 	    ffebad_here (0, ffelab_firstref_line (l), ffelab_firstref_column (l));
1217 	  else if (!ffewhere_line_is_unknown (ffelab_firstref_line (l)))
1218 	    ffebad_here (0, ffelab_firstref_line (l), ffelab_firstref_column (l));
1219 	  else if (!ffewhere_line_is_unknown (ffelab_doref_line (l)))
1220 	    ffebad_here (0, ffelab_doref_line (l), ffelab_doref_column (l));
1221 	  else
1222 	    ffebad_here (0, ffelab_definition_line (l), ffelab_definition_column (l));
1223 	  ffebad_finish ();
1224 
1225 	  switch (ffelab_type (l))
1226 	    {
1227 	    case FFELAB_typeFORMAT:
1228 	      ffelab_set_definition_line (l,
1229 			      ffewhere_line_use (ffelab_firstref_line (l)));
1230 	      ffelab_set_definition_column (l,
1231 			  ffewhere_column_use (ffelab_firstref_column (l)));
1232 	      ffestv_num_label_defines_++;
1233 	      f = ffestt_formatlist_create (NULL, NULL);
1234 	      ffestd_labeldef_format (l);
1235 	      ffestd_R1001 (f);
1236 	      ffestt_formatlist_kill (f);
1237 	      break;
1238 
1239 	    case FFELAB_typeASSIGNABLE:
1240 	      ffelab_set_definition_line (l,
1241 			      ffewhere_line_use (ffelab_firstref_line (l)));
1242 	      ffelab_set_definition_column (l,
1243 			  ffewhere_column_use (ffelab_firstref_column (l)));
1244 	      ffestv_num_label_defines_++;
1245 	      ffelab_set_type (l, FFELAB_typeNOTLOOP);
1246 	      ffelab_set_blocknum (l, ffestw_blocknum (ffestw_stack_top ()));
1247 	      ffestd_labeldef_notloop (l);
1248 	      ffestd_R842 (NULL);
1249 	      break;
1250 
1251 	    case FFELAB_typeNOTLOOP:
1252 	      ffelab_set_definition_line (l,
1253 			      ffewhere_line_use (ffelab_firstref_line (l)));
1254 	      ffelab_set_definition_column (l,
1255 			  ffewhere_column_use (ffelab_firstref_column (l)));
1256 	      ffestv_num_label_defines_++;
1257 	      ffelab_set_blocknum (l, ffestw_blocknum (ffestw_stack_top ()));
1258 	      ffestd_labeldef_notloop (l);
1259 	      ffestd_R842 (NULL);
1260 	      break;
1261 
1262 	    default:
1263 	      assert ("bad label type" == NULL);
1264 	      /* Fall through. */
1265 	    case FFELAB_typeUNKNOWN:
1266 	    case FFELAB_typeANY:
1267 	      break;
1268 	    }
1269 	}
1270     }
1271   ffelab_handle_done (h);
1272   assert (undef == 0);
1273 }
1274 
1275 /* ffestd_subr_f90_ -- Report error about lack of full F90 support
1276 
1277    ffestd_subr_f90_();	*/
1278 
1279 #if FFESTR_F90
1280 static void
ffestd_subr_f90_()1281 ffestd_subr_f90_ ()
1282 {
1283   ffebad_start (FFEBAD_F90);
1284   ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
1285 	       ffelex_token_where_column (ffesta_tokens[0]));
1286   ffebad_finish ();
1287 }
1288 
1289 #endif
1290 /* ffestd_subr_vxt_ -- Report error about lack of full VXT support
1291 
1292    ffestd_subr_vxt_();	*/
1293 
1294 static void
ffestd_subr_vxt_()1295 ffestd_subr_vxt_ ()
1296 {
1297   ffebad_start (FFEBAD_VXT_UNSUPPORTED);
1298   ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
1299 	       ffelex_token_where_column (ffesta_tokens[0]));
1300   ffebad_finish ();
1301 }
1302 
1303 /* ffestd_begin_uses -- Start a bunch of USE statements
1304 
1305    ffestd_begin_uses();
1306 
1307    Invoked before handling the first USE statement in a block of one or
1308    more USE statements.	 _end_uses_(bool ok) is invoked before handling
1309    the first statement after the block (there are no BEGIN USE and END USE
1310    statements, but the semantics of USE statements effectively requires
1311    handling them as a single block rather than one statement at a time).  */
1312 
1313 void
ffestd_begin_uses()1314 ffestd_begin_uses ()
1315 {
1316 }
1317 
1318 /* ffestd_do -- End of statement following DO-term-stmt etc
1319 
1320    ffestd_do(TRUE);
1321 
1322    Also invoked by _labeldef_branch_finish_ (or, in cases
1323    of errors, other _labeldef_ functions) when the label definition is
1324    for a DO-target (LOOPEND) label, once per matching/outstanding DO
1325    block on the stack.	These cases invoke this function with ok==TRUE, so
1326    only forced stack popping (via ffestd_eof_()) invokes it with ok==FALSE.  */
1327 
1328 void
ffestd_do(bool ok UNUSED)1329 ffestd_do (bool ok UNUSED)
1330 {
1331   ffestdStmt_ stmt;
1332 
1333   stmt = ffestd_stmt_new_ (FFESTD_stmtidENDDOLOOP_);
1334   ffestd_stmt_append_ (stmt);
1335   ffestd_subr_line_save_ (stmt);
1336   stmt->u.enddoloop.block = ffestw_stack_top ();
1337 
1338   --ffestd_block_level_;
1339   assert (ffestd_block_level_ >= 0);
1340 }
1341 
1342 /* ffestd_end_uses -- End a bunch of USE statements
1343 
1344    ffestd_end_uses(TRUE);
1345 
1346    ok==TRUE means simply not popping due to ffestd_eof_()
1347    being called, because there is no formal END USES statement in Fortran.  */
1348 
1349 #if FFESTR_F90
1350 void
ffestd_end_uses(bool ok)1351 ffestd_end_uses (bool ok)
1352 {
1353 }
1354 
1355 /* ffestd_end_R740 -- End a WHERE(-THEN)
1356 
1357    ffestd_end_R740(TRUE);  */
1358 
1359 void
ffestd_end_R740(bool ok)1360 ffestd_end_R740 (bool ok)
1361 {
1362   return;			/* F90. */
1363 }
1364 
1365 #endif
1366 /* ffestd_end_R807 -- End of statement following logical IF
1367 
1368    ffestd_end_R807(TRUE);
1369 
1370    Applies ONLY to logical IF, not to IF-THEN.	For example, does not
1371    ffelex_token_kill the construct name for an IF-THEN block (the name
1372    field is invalid for logical IF).  ok==TRUE iff statement following
1373    logical IF (substatement) is valid; else, statement is invalid or
1374    stack forcibly popped due to ffestd_eof_().	*/
1375 
1376 void
ffestd_end_R807(bool ok UNUSED)1377 ffestd_end_R807 (bool ok UNUSED)
1378 {
1379   ffestdStmt_ stmt;
1380 
1381   stmt = ffestd_stmt_new_ (FFESTD_stmtidENDLOGIF_);
1382   ffestd_stmt_append_ (stmt);
1383   ffestd_subr_line_save_ (stmt);
1384 
1385   --ffestd_block_level_;
1386   assert (ffestd_block_level_ >= 0);
1387 }
1388 
1389 /* ffestd_exec_begin -- Executable statements can start coming in now
1390 
1391    ffestd_exec_begin();	 */
1392 
1393 void
ffestd_exec_begin()1394 ffestd_exec_begin ()
1395 {
1396   ffecom_exec_transition ();
1397 
1398   if (ffestd_2pass_entrypoints_ != 0)
1399     {				/* Process pending ENTRY statements now that
1400 				   info filled in. */
1401       ffestdStmt_ stmt;
1402       int ents = ffestd_2pass_entrypoints_;
1403 
1404       stmt = ffestd_stmt_list_.first;
1405       do
1406 	{
1407 	  while (stmt->id != FFESTD_stmtidR1226_)
1408 	    stmt = stmt->next;
1409 
1410 	  if (!ffecom_2pass_advise_entrypoint (stmt->u.R1226.entry))
1411 	    {
1412 	      stmt->u.R1226.entry = NULL;
1413 	      --ffestd_2pass_entrypoints_;
1414 	    }
1415 	  stmt = stmt->next;
1416 	}
1417       while (--ents != 0);
1418     }
1419 }
1420 
1421 /* ffestd_exec_end -- Executable statements can no longer come in now
1422 
1423    ffestd_exec_end();  */
1424 
1425 void
ffestd_exec_end()1426 ffestd_exec_end ()
1427 {
1428   int old_lineno = lineno;
1429   const char *old_input_filename = input_filename;
1430 
1431   ffecom_end_transition ();
1432 
1433   ffestd_stmt_pass_ ();
1434 
1435   ffecom_finish_progunit ();
1436 
1437   if (ffestd_2pass_entrypoints_ != 0)
1438     {
1439       int ents = ffestd_2pass_entrypoints_;
1440       ffestdStmt_ stmt = ffestd_stmt_list_.first;
1441 
1442       do
1443 	{
1444 	  while (stmt->id != FFESTD_stmtidR1226_)
1445 	    stmt = stmt->next;
1446 
1447 	  if (stmt->u.R1226.entry != NULL)
1448 	    {
1449 	      ffestd_subr_line_restore_ (stmt);
1450 	      ffecom_2pass_do_entrypoint (stmt->u.R1226.entry);
1451 	    }
1452 	  stmt = stmt->next;
1453 	}
1454       while (--ents != 0);
1455     }
1456 
1457   ffestd_stmt_list_.first = NULL;
1458   ffestd_stmt_list_.last = NULL;
1459   ffestd_2pass_entrypoints_ = 0;
1460 
1461   lineno = old_lineno;
1462   input_filename = old_input_filename;
1463 }
1464 
1465 /* ffestd_init_3 -- Initialize for any program unit
1466 
1467    ffestd_init_3();  */
1468 
1469 void
ffestd_init_3()1470 ffestd_init_3 ()
1471 {
1472   ffestd_stmt_list_.first = (ffestdStmt_) &ffestd_stmt_list_.first;
1473   ffestd_stmt_list_.last = (ffestdStmt_) &ffestd_stmt_list_.first;
1474 }
1475 
1476 /* Generate "code" for "any" label def.  */
1477 
1478 void
ffestd_labeldef_any(ffelab label UNUSED)1479 ffestd_labeldef_any (ffelab label UNUSED)
1480 {
1481 }
1482 
1483 /* ffestd_labeldef_branch -- Generate "code" for branch label def
1484 
1485    ffestd_labeldef_branch(label);  */
1486 
1487 void
ffestd_labeldef_branch(ffelab label)1488 ffestd_labeldef_branch (ffelab label)
1489 {
1490   ffestdStmt_ stmt;
1491 
1492   stmt = ffestd_stmt_new_ (FFESTD_stmtidEXECLABEL_);
1493   ffestd_stmt_append_ (stmt);
1494   stmt->u.execlabel.label = label;
1495 
1496   ffestd_is_reachable_ = TRUE;
1497 }
1498 
1499 /* ffestd_labeldef_format -- Generate "code" for FORMAT label def
1500 
1501    ffestd_labeldef_format(label);  */
1502 
1503 void
ffestd_labeldef_format(ffelab label)1504 ffestd_labeldef_format (ffelab label)
1505 {
1506   ffestdStmt_ stmt;
1507 
1508   ffestd_label_formatdef_ = label;
1509 
1510   stmt = ffestd_stmt_new_ (FFESTD_stmtidFORMATLABEL_);
1511   ffestd_stmt_append_ (stmt);
1512   stmt->u.formatlabel.label = label;
1513 }
1514 
1515 /* ffestd_labeldef_useless -- Generate "code" for useless label def
1516 
1517    ffestd_labeldef_useless(label);  */
1518 
1519 void
ffestd_labeldef_useless(ffelab label UNUSED)1520 ffestd_labeldef_useless (ffelab label UNUSED)
1521 {
1522 }
1523 
1524 /* ffestd_R423A -- PRIVATE statement (in R422 derived-type statement)
1525 
1526    ffestd_R423A();  */
1527 
1528 #if FFESTR_F90
1529 void
ffestd_R423A()1530 ffestd_R423A ()
1531 {
1532   ffestd_check_simple_ ();
1533 }
1534 
1535 /* ffestd_R423B -- SEQUENCE statement (in R422 derived-type-stmt)
1536 
1537    ffestd_R423B();  */
1538 
1539 void
ffestd_R423B()1540 ffestd_R423B ()
1541 {
1542   ffestd_check_simple_ ();
1543 }
1544 
1545 /* ffestd_R424 -- derived-TYPE-def statement
1546 
1547    ffestd_R424(access_token,access_kw,name_token);
1548 
1549    Handle a derived-type definition.  */
1550 
1551 void
ffestd_R424(ffelexToken access,ffestrOther access_kw,ffelexToken name)1552 ffestd_R424 (ffelexToken access, ffestrOther access_kw, ffelexToken name)
1553 {
1554   ffestd_check_simple_ ();
1555 
1556   ffestd_subr_f90_ ();
1557   return;
1558 
1559 #ifdef FFESTD_F90
1560   char *a;
1561 
1562   if (access == NULL)
1563     fprintf (dmpout, "* TYPE %s\n", ffelex_token_text (name));
1564   else
1565     {
1566       switch (access_kw)
1567 	{
1568 	case FFESTR_otherPUBLIC:
1569 	  a = "PUBLIC";
1570 	  break;
1571 
1572 	case FFESTR_otherPRIVATE:
1573 	  a = "PRIVATE";
1574 	  break;
1575 
1576 	default:
1577 	  assert (FALSE);
1578 	}
1579       fprintf (dmpout, "* TYPE,%s: %s\n", a, ffelex_token_text (name));
1580     }
1581 #endif
1582 }
1583 
1584 /* ffestd_R425 -- End a TYPE
1585 
1586    ffestd_R425(TRUE);  */
1587 
1588 void
ffestd_R425(bool ok)1589 ffestd_R425 (bool ok)
1590 {
1591 }
1592 
1593 /* ffestd_R519_start -- INTENT statement list begin
1594 
1595    ffestd_R519_start();
1596 
1597    Verify that INTENT is valid here, and begin accepting items in the list.  */
1598 
1599 void
ffestd_R519_start(ffestrOther intent_kw)1600 ffestd_R519_start (ffestrOther intent_kw)
1601 {
1602   ffestd_check_start_ ();
1603 
1604   ffestd_subr_f90_ ();
1605   return;
1606 
1607 #ifdef FFESTD_F90
1608   char *a;
1609 
1610   switch (intent_kw)
1611     {
1612     case FFESTR_otherIN:
1613       a = "IN";
1614       break;
1615 
1616     case FFESTR_otherOUT:
1617       a = "OUT";
1618       break;
1619 
1620     case FFESTR_otherINOUT:
1621       a = "INOUT";
1622       break;
1623 
1624     default:
1625       assert (FALSE);
1626     }
1627   fprintf (dmpout, "* INTENT (%s) ", a);
1628 #endif
1629 }
1630 
1631 /* ffestd_R519_item -- INTENT statement for name
1632 
1633    ffestd_R519_item(name_token);
1634 
1635    Make sure name_token identifies a valid object to be INTENTed.  */
1636 
1637 void
ffestd_R519_item(ffelexToken name)1638 ffestd_R519_item (ffelexToken name)
1639 {
1640   ffestd_check_item_ ();
1641 
1642   return;			/* F90. */
1643 
1644 #ifdef FFESTD_F90
1645   fprintf (dmpout, "%s,", ffelex_token_text (name));
1646 #endif
1647 }
1648 
1649 /* ffestd_R519_finish -- INTENT statement list complete
1650 
1651    ffestd_R519_finish();
1652 
1653    Just wrap up any local activities.  */
1654 
1655 void
ffestd_R519_finish()1656 ffestd_R519_finish ()
1657 {
1658   ffestd_check_finish_ ();
1659 
1660   return;			/* F90. */
1661 
1662 #ifdef FFESTD_F90
1663   fputc ('\n', dmpout);
1664 #endif
1665 }
1666 
1667 /* ffestd_R520_start -- OPTIONAL statement list begin
1668 
1669    ffestd_R520_start();
1670 
1671    Verify that OPTIONAL is valid here, and begin accepting items in the list.  */
1672 
1673 void
ffestd_R520_start()1674 ffestd_R520_start ()
1675 {
1676   ffestd_check_start_ ();
1677 
1678   ffestd_subr_f90_ ();
1679   return;
1680 
1681 #ifdef FFESTD_F90
1682   fputs ("* OPTIONAL ", dmpout);
1683 #endif
1684 }
1685 
1686 /* ffestd_R520_item -- OPTIONAL statement for name
1687 
1688    ffestd_R520_item(name_token);
1689 
1690    Make sure name_token identifies a valid object to be OPTIONALed.  */
1691 
1692 void
ffestd_R520_item(ffelexToken name)1693 ffestd_R520_item (ffelexToken name)
1694 {
1695   ffestd_check_item_ ();
1696 
1697   return;			/* F90. */
1698 
1699 #ifdef FFESTD_F90
1700   fprintf (dmpout, "%s,", ffelex_token_text (name));
1701 #endif
1702 }
1703 
1704 /* ffestd_R520_finish -- OPTIONAL statement list complete
1705 
1706    ffestd_R520_finish();
1707 
1708    Just wrap up any local activities.  */
1709 
1710 void
ffestd_R520_finish()1711 ffestd_R520_finish ()
1712 {
1713   ffestd_check_finish_ ();
1714 
1715   return;			/* F90. */
1716 
1717 #ifdef FFESTD_F90
1718   fputc ('\n', dmpout);
1719 #endif
1720 }
1721 
1722 /* ffestd_R521A -- PUBLIC statement
1723 
1724    ffestd_R521A();
1725 
1726    Verify that PUBLIC is valid here.  */
1727 
1728 void
ffestd_R521A()1729 ffestd_R521A ()
1730 {
1731   ffestd_check_simple_ ();
1732 
1733   ffestd_subr_f90_ ();
1734   return;
1735 
1736 #ifdef FFESTD_F90
1737   fputs ("* PUBLIC\n", dmpout);
1738 #endif
1739 }
1740 
1741 /* ffestd_R521Astart -- PUBLIC statement list begin
1742 
1743    ffestd_R521Astart();
1744 
1745    Verify that PUBLIC is valid here, and begin accepting items in the list.  */
1746 
1747 void
ffestd_R521Astart()1748 ffestd_R521Astart ()
1749 {
1750   ffestd_check_start_ ();
1751 
1752   ffestd_subr_f90_ ();
1753   return;
1754 
1755 #ifdef FFESTD_F90
1756   fputs ("* PUBLIC ", dmpout);
1757 #endif
1758 }
1759 
1760 /* ffestd_R521Aitem -- PUBLIC statement for name
1761 
1762    ffestd_R521Aitem(name_token);
1763 
1764    Make sure name_token identifies a valid object to be PUBLICed.  */
1765 
1766 void
ffestd_R521Aitem(ffelexToken name)1767 ffestd_R521Aitem (ffelexToken name)
1768 {
1769   ffestd_check_item_ ();
1770 
1771   return;			/* F90. */
1772 
1773 #ifdef FFESTD_F90
1774   fprintf (dmpout, "%s,", ffelex_token_text (name));
1775 #endif
1776 }
1777 
1778 /* ffestd_R521Afinish -- PUBLIC statement list complete
1779 
1780    ffestd_R521Afinish();
1781 
1782    Just wrap up any local activities.  */
1783 
1784 void
ffestd_R521Afinish()1785 ffestd_R521Afinish ()
1786 {
1787   ffestd_check_finish_ ();
1788 
1789   return;			/* F90. */
1790 
1791 #ifdef FFESTD_F90
1792   fputc ('\n', dmpout);
1793 #endif
1794 }
1795 
1796 /* ffestd_R521B -- PRIVATE statement
1797 
1798    ffestd_R521B();
1799 
1800    Verify that PRIVATE is valid here (outside a derived-type statement).  */
1801 
1802 void
ffestd_R521B()1803 ffestd_R521B ()
1804 {
1805   ffestd_check_simple_ ();
1806 
1807   ffestd_subr_f90_ ();
1808   return;
1809 
1810 #ifdef FFESTD_F90
1811   fputs ("* PRIVATE_outside_of_R422_derived_type_def\n", dmpout);
1812 #endif
1813 }
1814 
1815 /* ffestd_R521Bstart -- PRIVATE statement list begin
1816 
1817    ffestd_R521Bstart();
1818 
1819    Verify that PRIVATE is valid here, and begin accepting items in the list.  */
1820 
1821 void
ffestd_R521Bstart()1822 ffestd_R521Bstart ()
1823 {
1824   ffestd_check_start_ ();
1825 
1826   ffestd_subr_f90_ ();
1827   return;
1828 
1829 #ifdef FFESTD_F90
1830   fputs ("* PRIVATE ", dmpout);
1831 #endif
1832 }
1833 
1834 /* ffestd_R521Bitem -- PRIVATE statement for name
1835 
1836    ffestd_R521Bitem(name_token);
1837 
1838    Make sure name_token identifies a valid object to be PRIVATEed.  */
1839 
1840 void
ffestd_R521Bitem(ffelexToken name)1841 ffestd_R521Bitem (ffelexToken name)
1842 {
1843   ffestd_check_item_ ();
1844 
1845   return;			/* F90. */
1846 
1847 #ifdef FFESTD_F90
1848   fprintf (dmpout, "%s,", ffelex_token_text (name));
1849 #endif
1850 }
1851 
1852 /* ffestd_R521Bfinish -- PRIVATE statement list complete
1853 
1854    ffestd_R521Bfinish();
1855 
1856    Just wrap up any local activities.  */
1857 
1858 void
ffestd_R521Bfinish()1859 ffestd_R521Bfinish ()
1860 {
1861   ffestd_check_finish_ ();
1862 
1863   return;			/* F90. */
1864 
1865 #ifdef FFESTD_F90
1866   fputc ('\n', dmpout);
1867 #endif
1868 }
1869 
1870 #endif
1871 /* ffestd_R522 -- SAVE statement with no list
1872 
1873    ffestd_R522();
1874 
1875    Verify that SAVE is valid here, and flag everything as SAVEd.  */
1876 
1877 void
ffestd_R522()1878 ffestd_R522 ()
1879 {
1880   ffestd_check_simple_ ();
1881 }
1882 
1883 /* ffestd_R522start -- SAVE statement list begin
1884 
1885    ffestd_R522start();
1886 
1887    Verify that SAVE is valid here, and begin accepting items in the list.  */
1888 
1889 void
ffestd_R522start()1890 ffestd_R522start ()
1891 {
1892   ffestd_check_start_ ();
1893 }
1894 
1895 /* ffestd_R522item_object -- SAVE statement for object-name
1896 
1897    ffestd_R522item_object(name_token);
1898 
1899    Make sure name_token identifies a valid object to be SAVEd.	*/
1900 
1901 void
ffestd_R522item_object(ffelexToken name UNUSED)1902 ffestd_R522item_object (ffelexToken name UNUSED)
1903 {
1904   ffestd_check_item_ ();
1905 }
1906 
1907 /* ffestd_R522item_cblock -- SAVE statement for common-block-name
1908 
1909    ffestd_R522item_cblock(name_token);
1910 
1911    Make sure name_token identifies a valid common block to be SAVEd.  */
1912 
1913 void
ffestd_R522item_cblock(ffelexToken name UNUSED)1914 ffestd_R522item_cblock (ffelexToken name UNUSED)
1915 {
1916   ffestd_check_item_ ();
1917 }
1918 
1919 /* ffestd_R522finish -- SAVE statement list complete
1920 
1921    ffestd_R522finish();
1922 
1923    Just wrap up any local activities.  */
1924 
1925 void
ffestd_R522finish()1926 ffestd_R522finish ()
1927 {
1928   ffestd_check_finish_ ();
1929 }
1930 
1931 /* ffestd_R524_start -- DIMENSION statement list begin
1932 
1933    ffestd_R524_start(bool virtual);
1934 
1935    Verify that DIMENSION is valid here, and begin accepting items in the list.	*/
1936 
1937 void
ffestd_R524_start(bool virtual UNUSED)1938 ffestd_R524_start (bool virtual UNUSED)
1939 {
1940   ffestd_check_start_ ();
1941 }
1942 
1943 /* ffestd_R524_item -- DIMENSION statement for object-name
1944 
1945    ffestd_R524_item(name_token,dim_list);
1946 
1947    Make sure name_token identifies a valid object to be DIMENSIONd.  */
1948 
1949 void
ffestd_R524_item(ffelexToken name UNUSED,ffesttDimList dims UNUSED)1950 ffestd_R524_item (ffelexToken name UNUSED, ffesttDimList dims UNUSED)
1951 {
1952   ffestd_check_item_ ();
1953 }
1954 
1955 /* ffestd_R524_finish -- DIMENSION statement list complete
1956 
1957    ffestd_R524_finish();
1958 
1959    Just wrap up any local activities.  */
1960 
1961 void
ffestd_R524_finish()1962 ffestd_R524_finish ()
1963 {
1964   ffestd_check_finish_ ();
1965 }
1966 
1967 /* ffestd_R525_start -- ALLOCATABLE statement list begin
1968 
1969    ffestd_R525_start();
1970 
1971    Verify that ALLOCATABLE is valid here, and begin accepting items in the
1972    list.  */
1973 
1974 #if FFESTR_F90
1975 void
ffestd_R525_start()1976 ffestd_R525_start ()
1977 {
1978   ffestd_check_start_ ();
1979 
1980   ffestd_subr_f90_ ();
1981   return;
1982 
1983 #ifdef FFESTD_F90
1984   fputs ("* ALLOCATABLE ", dmpout);
1985 #endif
1986 }
1987 
1988 /* ffestd_R525_item -- ALLOCATABLE statement for object-name
1989 
1990    ffestd_R525_item(name_token,dim_list);
1991 
1992    Make sure name_token identifies a valid object to be ALLOCATABLEd.  */
1993 
1994 void
ffestd_R525_item(ffelexToken name,ffesttDimList dims)1995 ffestd_R525_item (ffelexToken name, ffesttDimList dims)
1996 {
1997   ffestd_check_item_ ();
1998 
1999   return;			/* F90. */
2000 
2001 #ifdef FFESTD_F90
2002   fputs (ffelex_token_text (name), dmpout);
2003   if (dims != NULL)
2004     {
2005       fputc ('(', dmpout);
2006       ffestt_dimlist_dump (dims);
2007       fputc (')', dmpout);
2008     }
2009   fputc (',', dmpout);
2010 #endif
2011 }
2012 
2013 /* ffestd_R525_finish -- ALLOCATABLE statement list complete
2014 
2015    ffestd_R525_finish();
2016 
2017    Just wrap up any local activities.  */
2018 
2019 void
ffestd_R525_finish()2020 ffestd_R525_finish ()
2021 {
2022   ffestd_check_finish_ ();
2023 
2024   return;			/* F90. */
2025 
2026 #ifdef FFESTD_F90
2027   fputc ('\n', dmpout);
2028 #endif
2029 }
2030 
2031 /* ffestd_R526_start -- POINTER statement list begin
2032 
2033    ffestd_R526_start();
2034 
2035    Verify that POINTER is valid here, and begin accepting items in the
2036    list.  */
2037 
2038 void
ffestd_R526_start()2039 ffestd_R526_start ()
2040 {
2041   ffestd_check_start_ ();
2042 
2043   ffestd_subr_f90_ ();
2044   return;
2045 
2046 #ifdef FFESTD_F90
2047   fputs ("* POINTER ", dmpout);
2048 #endif
2049 }
2050 
2051 /* ffestd_R526_item -- POINTER statement for object-name
2052 
2053    ffestd_R526_item(name_token,dim_list);
2054 
2055    Make sure name_token identifies a valid object to be POINTERd.  */
2056 
2057 void
ffestd_R526_item(ffelexToken name,ffesttDimList dims)2058 ffestd_R526_item (ffelexToken name, ffesttDimList dims)
2059 {
2060   ffestd_check_item_ ();
2061 
2062   return;			/* F90. */
2063 
2064 #ifdef FFESTD_F90
2065   fputs (ffelex_token_text (name), dmpout);
2066   if (dims != NULL)
2067     {
2068       fputc ('(', dmpout);
2069       ffestt_dimlist_dump (dims);
2070       fputc (')', dmpout);
2071     }
2072   fputc (',', dmpout);
2073 #endif
2074 }
2075 
2076 /* ffestd_R526_finish -- POINTER statement list complete
2077 
2078    ffestd_R526_finish();
2079 
2080    Just wrap up any local activities.  */
2081 
2082 void
ffestd_R526_finish()2083 ffestd_R526_finish ()
2084 {
2085   ffestd_check_finish_ ();
2086 
2087   return;			/* F90. */
2088 
2089 #ifdef FFESTD_F90
2090   fputc ('\n', dmpout);
2091 #endif
2092 }
2093 
2094 /* ffestd_R527_start -- TARGET statement list begin
2095 
2096    ffestd_R527_start();
2097 
2098    Verify that TARGET is valid here, and begin accepting items in the
2099    list.  */
2100 
2101 void
ffestd_R527_start()2102 ffestd_R527_start ()
2103 {
2104   ffestd_check_start_ ();
2105 
2106   ffestd_subr_f90_ ();
2107   return;
2108 
2109 #ifdef FFESTD_F90
2110   fputs ("* TARGET ", dmpout);
2111 #endif
2112 }
2113 
2114 /* ffestd_R527_item -- TARGET statement for object-name
2115 
2116    ffestd_R527_item(name_token,dim_list);
2117 
2118    Make sure name_token identifies a valid object to be TARGETd.  */
2119 
2120 void
ffestd_R527_item(ffelexToken name,ffesttDimList dims)2121 ffestd_R527_item (ffelexToken name, ffesttDimList dims)
2122 {
2123   ffestd_check_item_ ();
2124 
2125   return;			/* F90. */
2126 
2127 #ifdef FFESTD_F90
2128   fputs (ffelex_token_text (name), dmpout);
2129   if (dims != NULL)
2130     {
2131       fputc ('(', dmpout);
2132       ffestt_dimlist_dump (dims);
2133       fputc (')', dmpout);
2134     }
2135   fputc (',', dmpout);
2136 #endif
2137 }
2138 
2139 /* ffestd_R527_finish -- TARGET statement list complete
2140 
2141    ffestd_R527_finish();
2142 
2143    Just wrap up any local activities.  */
2144 
2145 void
ffestd_R527_finish()2146 ffestd_R527_finish ()
2147 {
2148   ffestd_check_finish_ ();
2149 
2150   return;			/* F90. */
2151 
2152 #ifdef FFESTD_F90
2153   fputc ('\n', dmpout);
2154 #endif
2155 }
2156 
2157 #endif
2158 /* ffestd_R537_start -- PARAMETER statement list begin
2159 
2160    ffestd_R537_start();
2161 
2162    Verify that PARAMETER is valid here, and begin accepting items in the list.	*/
2163 
2164 void
ffestd_R537_start()2165 ffestd_R537_start ()
2166 {
2167   ffestd_check_start_ ();
2168 }
2169 
2170 /* ffestd_R537_item -- PARAMETER statement assignment
2171 
2172    ffestd_R537_item(dest,dest_token,source,source_token);
2173 
2174    Make sure the source is a valid source for the destination; make the
2175    assignment.	*/
2176 
2177 void
ffestd_R537_item(ffebld dest UNUSED,ffebld source UNUSED)2178 ffestd_R537_item (ffebld dest UNUSED, ffebld source UNUSED)
2179 {
2180   ffestd_check_item_ ();
2181 }
2182 
2183 /* ffestd_R537_finish -- PARAMETER statement list complete
2184 
2185    ffestd_R537_finish();
2186 
2187    Just wrap up any local activities.  */
2188 
2189 void
ffestd_R537_finish()2190 ffestd_R537_finish ()
2191 {
2192   ffestd_check_finish_ ();
2193 }
2194 
2195 /* ffestd_R539 -- IMPLICIT NONE statement
2196 
2197    ffestd_R539();
2198 
2199    Verify that the IMPLICIT NONE statement is ok here and implement.  */
2200 
2201 void
ffestd_R539()2202 ffestd_R539 ()
2203 {
2204   ffestd_check_simple_ ();
2205 }
2206 
2207 /* ffestd_R539start -- IMPLICIT statement
2208 
2209    ffestd_R539start();
2210 
2211    Verify that the IMPLICIT statement is ok here and implement.	 */
2212 
2213 void
ffestd_R539start()2214 ffestd_R539start ()
2215 {
2216   ffestd_check_start_ ();
2217 }
2218 
2219 /* ffestd_R539item -- IMPLICIT statement specification (R540)
2220 
2221    ffestd_R539item(...);
2222 
2223    Verify that the type and letter list are all ok and implement.  */
2224 
2225 void
ffestd_R539item(ffestpType type UNUSED,ffebld kind UNUSED,ffelexToken kindt UNUSED,ffebld len UNUSED,ffelexToken lent UNUSED,ffesttImpList letters UNUSED)2226 ffestd_R539item (ffestpType type UNUSED, ffebld kind UNUSED,
2227 		 ffelexToken kindt UNUSED, ffebld len UNUSED,
2228 		 ffelexToken lent UNUSED, ffesttImpList letters UNUSED)
2229 {
2230   ffestd_check_item_ ();
2231 }
2232 
2233 /* ffestd_R539finish -- IMPLICIT statement
2234 
2235    ffestd_R539finish();
2236 
2237    Finish up any local activities.  */
2238 
2239 void
ffestd_R539finish()2240 ffestd_R539finish ()
2241 {
2242   ffestd_check_finish_ ();
2243 }
2244 
2245 /* ffestd_R542_start -- NAMELIST statement list begin
2246 
2247    ffestd_R542_start();
2248 
2249    Verify that NAMELIST is valid here, and begin accepting items in the list.  */
2250 
2251 void
ffestd_R542_start()2252 ffestd_R542_start ()
2253 {
2254   ffestd_check_start_ ();
2255 }
2256 
2257 /* ffestd_R542_item_nlist -- NAMELIST statement for group-name
2258 
2259    ffestd_R542_item_nlist(groupname_token);
2260 
2261    Make sure name_token identifies a valid object to be NAMELISTd.  */
2262 
2263 void
ffestd_R542_item_nlist(ffelexToken name UNUSED)2264 ffestd_R542_item_nlist (ffelexToken name UNUSED)
2265 {
2266   ffestd_check_item_ ();
2267 }
2268 
2269 /* ffestd_R542_item_nitem -- NAMELIST statement for variable-name
2270 
2271    ffestd_R542_item_nitem(name_token);
2272 
2273    Make sure name_token identifies a valid object to be NAMELISTd.  */
2274 
2275 void
ffestd_R542_item_nitem(ffelexToken name UNUSED)2276 ffestd_R542_item_nitem (ffelexToken name UNUSED)
2277 {
2278   ffestd_check_item_ ();
2279 }
2280 
2281 /* ffestd_R542_finish -- NAMELIST statement list complete
2282 
2283    ffestd_R542_finish();
2284 
2285    Just wrap up any local activities.  */
2286 
2287 void
ffestd_R542_finish()2288 ffestd_R542_finish ()
2289 {
2290   ffestd_check_finish_ ();
2291 }
2292 
2293 /* ffestd_R544_start -- EQUIVALENCE statement list begin
2294 
2295    ffestd_R544_start();
2296 
2297    Verify that EQUIVALENCE is valid here, and begin accepting items in the
2298    list.  */
2299 
2300 #if 0
2301 void
2302 ffestd_R544_start ()
2303 {
2304   ffestd_check_start_ ();
2305 }
2306 
2307 #endif
2308 /* ffestd_R544_item -- EQUIVALENCE statement assignment
2309 
2310    ffestd_R544_item(exprlist);
2311 
2312    Make sure the equivalence is valid, then implement it.  */
2313 
2314 #if 0
2315 void
2316 ffestd_R544_item (ffesttExprList exprlist)
2317 {
2318   ffestd_check_item_ ();
2319 }
2320 
2321 #endif
2322 /* ffestd_R544_finish -- EQUIVALENCE statement list complete
2323 
2324    ffestd_R544_finish();
2325 
2326    Just wrap up any local activities.  */
2327 
2328 #if 0
2329 void
2330 ffestd_R544_finish ()
2331 {
2332   ffestd_check_finish_ ();
2333 }
2334 
2335 #endif
2336 /* ffestd_R547_start -- COMMON statement list begin
2337 
2338    ffestd_R547_start();
2339 
2340    Verify that COMMON is valid here, and begin accepting items in the list.  */
2341 
2342 void
ffestd_R547_start()2343 ffestd_R547_start ()
2344 {
2345   ffestd_check_start_ ();
2346 }
2347 
2348 /* ffestd_R547_item_object -- COMMON statement for object-name
2349 
2350    ffestd_R547_item_object(name_token,dim_list);
2351 
2352    Make sure name_token identifies a valid object to be COMMONd.  */
2353 
2354 void
ffestd_R547_item_object(ffelexToken name UNUSED,ffesttDimList dims UNUSED)2355 ffestd_R547_item_object (ffelexToken name UNUSED,
2356 			 ffesttDimList dims UNUSED)
2357 {
2358   ffestd_check_item_ ();
2359 }
2360 
2361 /* ffestd_R547_item_cblock -- COMMON statement for common-block-name
2362 
2363    ffestd_R547_item_cblock(name_token);
2364 
2365    Make sure name_token identifies a valid common block to be COMMONd.	*/
2366 
2367 void
ffestd_R547_item_cblock(ffelexToken name UNUSED)2368 ffestd_R547_item_cblock (ffelexToken name UNUSED)
2369 {
2370   ffestd_check_item_ ();
2371 }
2372 
2373 /* ffestd_R547_finish -- COMMON statement list complete
2374 
2375    ffestd_R547_finish();
2376 
2377    Just wrap up any local activities.  */
2378 
2379 void
ffestd_R547_finish()2380 ffestd_R547_finish ()
2381 {
2382   ffestd_check_finish_ ();
2383 }
2384 
2385 /* ffestd_R620 -- ALLOCATE statement
2386 
2387    ffestd_R620(exprlist,stat,stat_token);
2388 
2389    Make sure the expression list is valid, then implement it.  */
2390 
2391 #if FFESTR_F90
2392 void
ffestd_R620(ffesttExprList exprlist,ffebld stat)2393 ffestd_R620 (ffesttExprList exprlist, ffebld stat)
2394 {
2395   ffestd_check_simple_ ();
2396 
2397   ffestd_subr_f90_ ();
2398 }
2399 
2400 /* ffestd_R624 -- NULLIFY statement
2401 
2402    ffestd_R624(pointer_name_list);
2403 
2404    Make sure pointer_name_list identifies valid pointers for a NULLIFY.	 */
2405 
2406 void
ffestd_R624(ffesttExprList pointers)2407 ffestd_R624 (ffesttExprList pointers)
2408 {
2409   ffestd_check_simple_ ();
2410 
2411   ffestd_subr_f90_ ();
2412   return;
2413 
2414 #ifdef FFESTD_F90
2415   fputs ("+ NULLIFY (", dmpout);
2416   assert (pointers != NULL);
2417   ffestt_exprlist_dump (pointers);
2418   fputs (")\n", dmpout);
2419 #endif
2420 }
2421 
2422 /* ffestd_R625 -- DEALLOCATE statement
2423 
2424    ffestd_R625(exprlist,stat,stat_token);
2425 
2426    Make sure the equivalence is valid, then implement it.  */
2427 
2428 void
ffestd_R625(ffesttExprList exprlist,ffebld stat)2429 ffestd_R625 (ffesttExprList exprlist, ffebld stat)
2430 {
2431   ffestd_check_simple_ ();
2432 
2433   ffestd_subr_f90_ ();
2434 }
2435 
2436 #endif
2437 /* ffestd_R737A -- Assignment statement outside of WHERE
2438 
2439    ffestd_R737A(dest_expr,source_expr);	 */
2440 
2441 void
ffestd_R737A(ffebld dest,ffebld source)2442 ffestd_R737A (ffebld dest, ffebld source)
2443 {
2444   ffestdStmt_ stmt;
2445 
2446   ffestd_check_simple_ ();
2447 
2448   stmt = ffestd_stmt_new_ (FFESTD_stmtidR737A_);
2449   ffestd_stmt_append_ (stmt);
2450   ffestd_subr_line_save_ (stmt);
2451   stmt->u.R737A.pool = ffesta_output_pool;
2452   stmt->u.R737A.dest = dest;
2453   stmt->u.R737A.source = source;
2454   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2455 }
2456 
2457 /* ffestd_R737B -- Assignment statement inside of WHERE
2458 
2459    ffestd_R737B(dest_expr,source_expr);	 */
2460 
2461 #if FFESTR_F90
2462 void
ffestd_R737B(ffebld dest,ffebld source)2463 ffestd_R737B (ffebld dest, ffebld source)
2464 {
2465   ffestd_check_simple_ ();
2466 }
2467 
2468 /* ffestd_R738 -- Pointer assignment statement
2469 
2470    ffestd_R738(dest_expr,source_expr,source_token);
2471 
2472    Make sure the assignment is valid.  */
2473 
2474 void
ffestd_R738(ffebld dest,ffebld source)2475 ffestd_R738 (ffebld dest, ffebld source)
2476 {
2477   ffestd_check_simple_ ();
2478 
2479   ffestd_subr_f90_ ();
2480 }
2481 
2482 /* ffestd_R740 -- WHERE statement
2483 
2484    ffestd_R740(expr,expr_token);
2485 
2486    Make sure statement is valid here; implement.  */
2487 
2488 void
ffestd_R740(ffebld expr)2489 ffestd_R740 (ffebld expr)
2490 {
2491   ffestd_check_simple_ ();
2492 
2493   ffestd_subr_f90_ ();
2494 }
2495 
2496 /* ffestd_R742 -- WHERE-construct statement
2497 
2498    ffestd_R742(expr,expr_token);
2499 
2500    Make sure statement is valid here; implement.  */
2501 
2502 void
ffestd_R742(ffebld expr)2503 ffestd_R742 (ffebld expr)
2504 {
2505   ffestd_check_simple_ ();
2506 
2507   ffestd_subr_f90_ ();
2508 }
2509 
2510 /* ffestd_R744 -- ELSE WHERE statement
2511 
2512    ffestd_R744();
2513 
2514    Make sure ffestd_kind_ identifies a WHERE block.
2515    Implement the ELSE of the current WHERE block.  */
2516 
2517 void
ffestd_R744()2518 ffestd_R744 ()
2519 {
2520   ffestd_check_simple_ ();
2521 
2522   return;			/* F90. */
2523 
2524 #ifdef FFESTD_F90
2525   fputs ("+ ELSE_WHERE\n", dmpout);
2526 #endif
2527 }
2528 
2529 /* ffestd_R745 -- Implicit END WHERE statement.  */
2530 
2531 void
ffestd_R745(bool ok)2532 ffestd_R745 (bool ok)
2533 {
2534   return;			/* F90. */
2535 
2536 #ifdef FFESTD_F90
2537   fputs ("+ END_WHERE\n", dmpout);	/* Also see ffestd_R745. */
2538 
2539   --ffestd_block_level_;
2540   assert (ffestd_block_level_ >= 0);
2541 #endif
2542 }
2543 
2544 #endif
2545 
2546 /* Block IF (IF-THEN) statement.  */
2547 
2548 void
ffestd_R803(ffelexToken construct_name UNUSED,ffebld expr)2549 ffestd_R803 (ffelexToken construct_name UNUSED, ffebld expr)
2550 {
2551   ffestdStmt_ stmt;
2552 
2553   ffestd_check_simple_ ();
2554 
2555   stmt = ffestd_stmt_new_ (FFESTD_stmtidR803_);
2556   ffestd_stmt_append_ (stmt);
2557   ffestd_subr_line_save_ (stmt);
2558   stmt->u.R803.pool = ffesta_output_pool;
2559   stmt->u.R803.block = ffestw_use (ffestw_stack_top ());
2560   stmt->u.R803.expr = expr;
2561   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2562 
2563   ++ffestd_block_level_;
2564   assert (ffestd_block_level_ > 0);
2565 }
2566 
2567 /* ELSE IF statement.  */
2568 
2569 void
ffestd_R804(ffebld expr,ffelexToken name UNUSED)2570 ffestd_R804 (ffebld expr, ffelexToken name UNUSED)
2571 {
2572   ffestdStmt_ stmt;
2573 
2574   ffestd_check_simple_ ();
2575 
2576   stmt = ffestd_stmt_new_ (FFESTD_stmtidR804_);
2577   ffestd_stmt_append_ (stmt);
2578   ffestd_subr_line_save_ (stmt);
2579   stmt->u.R804.pool = ffesta_output_pool;
2580   stmt->u.R804.block = ffestw_use (ffestw_stack_top ());
2581   stmt->u.R804.expr = expr;
2582   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2583 }
2584 
2585 /* ELSE statement.  */
2586 
2587 void
ffestd_R805(ffelexToken name UNUSED)2588 ffestd_R805 (ffelexToken name UNUSED)
2589 {
2590   ffestdStmt_ stmt;
2591 
2592   ffestd_check_simple_ ();
2593 
2594   stmt = ffestd_stmt_new_ (FFESTD_stmtidR805_);
2595   ffestd_stmt_append_ (stmt);
2596   ffestd_subr_line_save_ (stmt);
2597   stmt->u.R805.block = ffestw_use (ffestw_stack_top ());
2598 }
2599 
2600 /* END IF statement.  */
2601 
2602 void
ffestd_R806(bool ok UNUSED)2603 ffestd_R806 (bool ok UNUSED)
2604 {
2605   ffestdStmt_ stmt;
2606 
2607   stmt = ffestd_stmt_new_ (FFESTD_stmtidR806_);
2608   ffestd_stmt_append_ (stmt);
2609   ffestd_subr_line_save_ (stmt);
2610   stmt->u.R806.block = ffestw_use (ffestw_stack_top ());
2611 
2612   --ffestd_block_level_;
2613   assert (ffestd_block_level_ >= 0);
2614 }
2615 
2616 /* ffestd_R807 -- Logical IF statement
2617 
2618    ffestd_R807(expr,expr_token);
2619 
2620    Make sure statement is valid here; implement.  */
2621 
2622 void
ffestd_R807(ffebld expr)2623 ffestd_R807 (ffebld expr)
2624 {
2625   ffestdStmt_ stmt;
2626 
2627   ffestd_check_simple_ ();
2628 
2629   stmt = ffestd_stmt_new_ (FFESTD_stmtidR807_);
2630   ffestd_stmt_append_ (stmt);
2631   ffestd_subr_line_save_ (stmt);
2632   stmt->u.R807.pool = ffesta_output_pool;
2633   stmt->u.R807.expr = expr;
2634   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2635 
2636   ++ffestd_block_level_;
2637   assert (ffestd_block_level_ > 0);
2638 }
2639 
2640 /* ffestd_R809 -- SELECT CASE statement
2641 
2642    ffestd_R809(construct_name,expr,expr_token);
2643 
2644    Make sure statement is valid here; implement.  */
2645 
2646 void
ffestd_R809(ffelexToken construct_name UNUSED,ffebld expr)2647 ffestd_R809 (ffelexToken construct_name UNUSED, ffebld expr)
2648 {
2649   ffestdStmt_ stmt;
2650 
2651   ffestd_check_simple_ ();
2652 
2653   stmt = ffestd_stmt_new_ (FFESTD_stmtidR809_);
2654   ffestd_stmt_append_ (stmt);
2655   ffestd_subr_line_save_ (stmt);
2656   stmt->u.R809.pool = ffesta_output_pool;
2657   stmt->u.R809.block = ffestw_use (ffestw_stack_top ());
2658   stmt->u.R809.expr = expr;
2659   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2660   malloc_pool_use (ffestw_select (ffestw_stack_top ())->pool);
2661 
2662   ++ffestd_block_level_;
2663   assert (ffestd_block_level_ > 0);
2664 }
2665 
2666 /* ffestd_R810 -- CASE statement
2667 
2668    ffestd_R810(case_value_range_list,name);
2669 
2670    If casenum is 0, it's CASE DEFAULT.	Else it's the case ranges at
2671    the start of the first_stmt list in the select object at the top of
2672    the stack that match casenum.  */
2673 
2674 void
ffestd_R810(unsigned long casenum)2675 ffestd_R810 (unsigned long casenum)
2676 {
2677   ffestdStmt_ stmt;
2678 
2679   ffestd_check_simple_ ();
2680 
2681   stmt = ffestd_stmt_new_ (FFESTD_stmtidR810_);
2682   ffestd_stmt_append_ (stmt);
2683   ffestd_subr_line_save_ (stmt);
2684   stmt->u.R810.pool = ffesta_output_pool;
2685   stmt->u.R810.block = ffestw_stack_top ();
2686   stmt->u.R810.casenum = casenum;
2687   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2688 }
2689 
2690 /* ffestd_R811 -- End a SELECT
2691 
2692    ffestd_R811(TRUE);  */
2693 
2694 void
ffestd_R811(bool ok UNUSED)2695 ffestd_R811 (bool ok UNUSED)
2696 {
2697   ffestdStmt_ stmt;
2698 
2699   stmt = ffestd_stmt_new_ (FFESTD_stmtidR811_);
2700   ffestd_stmt_append_ (stmt);
2701   ffestd_subr_line_save_ (stmt);
2702   stmt->u.R811.block = ffestw_stack_top ();
2703 
2704   --ffestd_block_level_;
2705   assert (ffestd_block_level_ >= 0);
2706 }
2707 
2708 /* ffestd_R819A -- Iterative DO statement
2709 
2710    ffestd_R819A(construct_name,label_token,expr,expr_token);
2711 
2712    Make sure statement is valid here; implement.  */
2713 
2714 void
ffestd_R819A(ffelexToken construct_name UNUSED,ffelab label,ffebld var,ffebld start,ffelexToken start_token,ffebld end,ffelexToken end_token,ffebld incr,ffelexToken incr_token)2715 ffestd_R819A (ffelexToken construct_name UNUSED, ffelab label,
2716 	      ffebld var, ffebld start, ffelexToken start_token,
2717 	      ffebld end, ffelexToken end_token,
2718 	      ffebld incr, ffelexToken incr_token)
2719 {
2720   ffestdStmt_ stmt;
2721 
2722   ffestd_check_simple_ ();
2723 
2724   stmt = ffestd_stmt_new_ (FFESTD_stmtidR819A_);
2725   ffestd_stmt_append_ (stmt);
2726   ffestd_subr_line_save_ (stmt);
2727   stmt->u.R819A.pool = ffesta_output_pool;
2728   stmt->u.R819A.block = ffestw_use (ffestw_stack_top ());
2729   stmt->u.R819A.label = label;
2730   stmt->u.R819A.var = var;
2731   stmt->u.R819A.start = start;
2732   stmt->u.R819A.start_token = ffelex_token_use (start_token);
2733   stmt->u.R819A.end = end;
2734   stmt->u.R819A.end_token = ffelex_token_use (end_token);
2735   stmt->u.R819A.incr = incr;
2736   stmt->u.R819A.incr_token = (incr_token == NULL) ? NULL
2737     : ffelex_token_use (incr_token);
2738   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2739 
2740   ++ffestd_block_level_;
2741   assert (ffestd_block_level_ > 0);
2742 }
2743 
2744 /* ffestd_R819B -- DO WHILE statement
2745 
2746    ffestd_R819B(construct_name,label_token,expr,expr_token);
2747 
2748    Make sure statement is valid here; implement.  */
2749 
2750 void
ffestd_R819B(ffelexToken construct_name UNUSED,ffelab label,ffebld expr)2751 ffestd_R819B (ffelexToken construct_name UNUSED, ffelab label,
2752 	      ffebld expr)
2753 {
2754   ffestdStmt_ stmt;
2755 
2756   ffestd_check_simple_ ();
2757 
2758   stmt = ffestd_stmt_new_ (FFESTD_stmtidR819B_);
2759   ffestd_stmt_append_ (stmt);
2760   ffestd_subr_line_save_ (stmt);
2761   stmt->u.R819B.pool = ffesta_output_pool;
2762   stmt->u.R819B.block = ffestw_use (ffestw_stack_top ());
2763   stmt->u.R819B.label = label;
2764   stmt->u.R819B.expr = expr;
2765   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2766 
2767   ++ffestd_block_level_;
2768   assert (ffestd_block_level_ > 0);
2769 }
2770 
2771 /* ffestd_R825 -- END DO statement
2772 
2773    ffestd_R825(name_token);
2774 
2775    Make sure ffestd_kind_ identifies a DO block.  If not
2776    NULL, make sure name_token gives the correct name.  Do whatever
2777    is specific to seeing END DO with a DO-target label definition on it,
2778    where the END DO is really treated as a CONTINUE (i.e. generate th
2779    same code you would for CONTINUE).  ffestd_do handles the actual
2780    generation of end-loop code.	 */
2781 
2782 void
ffestd_R825(ffelexToken name UNUSED)2783 ffestd_R825 (ffelexToken name UNUSED)
2784 {
2785   ffestdStmt_ stmt;
2786 
2787   ffestd_check_simple_ ();
2788 
2789   stmt = ffestd_stmt_new_ (FFESTD_stmtidR825_);
2790   ffestd_stmt_append_ (stmt);
2791   ffestd_subr_line_save_ (stmt);
2792 }
2793 
2794 /* ffestd_R834 -- CYCLE statement
2795 
2796    ffestd_R834(name_token);
2797 
2798    Handle a CYCLE within a loop.  */
2799 
2800 void
ffestd_R834(ffestw block)2801 ffestd_R834 (ffestw block)
2802 {
2803   ffestdStmt_ stmt;
2804 
2805   ffestd_check_simple_ ();
2806 
2807   stmt = ffestd_stmt_new_ (FFESTD_stmtidR834_);
2808   ffestd_stmt_append_ (stmt);
2809   ffestd_subr_line_save_ (stmt);
2810   stmt->u.R834.block = block;
2811 }
2812 
2813 /* ffestd_R835 -- EXIT statement
2814 
2815    ffestd_R835(name_token);
2816 
2817    Handle a EXIT within a loop.	 */
2818 
2819 void
ffestd_R835(ffestw block)2820 ffestd_R835 (ffestw block)
2821 {
2822   ffestdStmt_ stmt;
2823 
2824   ffestd_check_simple_ ();
2825 
2826   stmt = ffestd_stmt_new_ (FFESTD_stmtidR835_);
2827   ffestd_stmt_append_ (stmt);
2828   ffestd_subr_line_save_ (stmt);
2829   stmt->u.R835.block = block;
2830 }
2831 
2832 /* ffestd_R836 -- GOTO statement
2833 
2834    ffestd_R836(label);
2835 
2836    Make sure label_token identifies a valid label for a GOTO.  Update
2837    that label's info to indicate it is the target of a GOTO.  */
2838 
2839 void
ffestd_R836(ffelab label)2840 ffestd_R836 (ffelab label)
2841 {
2842   ffestdStmt_ stmt;
2843 
2844   ffestd_check_simple_ ();
2845 
2846   stmt = ffestd_stmt_new_ (FFESTD_stmtidR836_);
2847   ffestd_stmt_append_ (stmt);
2848   ffestd_subr_line_save_ (stmt);
2849   stmt->u.R836.label = label;
2850 
2851   if (ffestd_block_level_ == 0)
2852     ffestd_is_reachable_ = FALSE;
2853 }
2854 
2855 /* ffestd_R837 -- Computed GOTO statement
2856 
2857    ffestd_R837(labels,expr);
2858 
2859    Make sure label_list identifies valid labels for a GOTO.  Update
2860    each label's info to indicate it is the target of a GOTO.  */
2861 
2862 void
ffestd_R837(ffelab * labels,int count,ffebld expr)2863 ffestd_R837 (ffelab *labels, int count, ffebld expr)
2864 {
2865   ffestdStmt_ stmt;
2866 
2867   ffestd_check_simple_ ();
2868 
2869   stmt = ffestd_stmt_new_ (FFESTD_stmtidR837_);
2870   ffestd_stmt_append_ (stmt);
2871   ffestd_subr_line_save_ (stmt);
2872   stmt->u.R837.pool = ffesta_output_pool;
2873   stmt->u.R837.labels = labels;
2874   stmt->u.R837.count = count;
2875   stmt->u.R837.expr = expr;
2876   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2877 }
2878 
2879 /* ffestd_R838 -- ASSIGN statement
2880 
2881    ffestd_R838(label_token,target_variable,target_token);
2882 
2883    Make sure label_token identifies a valid label for an assignment.  Update
2884    that label's info to indicate it is the source of an assignment.  Update
2885    target_variable's info to indicate it is the target the assignment of that
2886    label.  */
2887 
2888 void
ffestd_R838(ffelab label,ffebld target)2889 ffestd_R838 (ffelab label, ffebld target)
2890 {
2891   ffestdStmt_ stmt;
2892 
2893   ffestd_check_simple_ ();
2894 
2895   stmt = ffestd_stmt_new_ (FFESTD_stmtidR838_);
2896   ffestd_stmt_append_ (stmt);
2897   ffestd_subr_line_save_ (stmt);
2898   stmt->u.R838.pool = ffesta_output_pool;
2899   stmt->u.R838.label = label;
2900   stmt->u.R838.target = target;
2901   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2902 }
2903 
2904 /* ffestd_R839 -- Assigned GOTO statement
2905 
2906    ffestd_R839(target,labels);
2907 
2908    Make sure label_list identifies valid labels for a GOTO.  Update
2909    each label's info to indicate it is the target of a GOTO.  */
2910 
2911 void
ffestd_R839(ffebld target,ffelab * labels UNUSED,int count UNUSED)2912 ffestd_R839 (ffebld target, ffelab *labels UNUSED, int count UNUSED)
2913 {
2914   ffestdStmt_ stmt;
2915 
2916   ffestd_check_simple_ ();
2917 
2918   stmt = ffestd_stmt_new_ (FFESTD_stmtidR839_);
2919   ffestd_stmt_append_ (stmt);
2920   ffestd_subr_line_save_ (stmt);
2921   stmt->u.R839.pool = ffesta_output_pool;
2922   stmt->u.R839.target = target;
2923   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2924 
2925   if (ffestd_block_level_ == 0)
2926     ffestd_is_reachable_ = FALSE;
2927 }
2928 
2929 /* ffestd_R840 -- Arithmetic IF statement
2930 
2931    ffestd_R840(expr,expr_token,neg,zero,pos);
2932 
2933    Make sure the labels are valid; implement.  */
2934 
2935 void
ffestd_R840(ffebld expr,ffelab neg,ffelab zero,ffelab pos)2936 ffestd_R840 (ffebld expr, ffelab neg, ffelab zero, ffelab pos)
2937 {
2938   ffestdStmt_ stmt;
2939 
2940   ffestd_check_simple_ ();
2941 
2942   stmt = ffestd_stmt_new_ (FFESTD_stmtidR840_);
2943   ffestd_stmt_append_ (stmt);
2944   ffestd_subr_line_save_ (stmt);
2945   stmt->u.R840.pool = ffesta_output_pool;
2946   stmt->u.R840.expr = expr;
2947   stmt->u.R840.neg = neg;
2948   stmt->u.R840.zero = zero;
2949   stmt->u.R840.pos = pos;
2950   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2951 
2952   if (ffestd_block_level_ == 0)
2953     ffestd_is_reachable_ = FALSE;
2954 }
2955 
2956 /* ffestd_R841 -- CONTINUE statement
2957 
2958    ffestd_R841();  */
2959 
2960 void
ffestd_R841(bool in_where UNUSED)2961 ffestd_R841 (bool in_where UNUSED)
2962 {
2963   ffestdStmt_ stmt;
2964 
2965   ffestd_check_simple_ ();
2966 
2967   stmt = ffestd_stmt_new_ (FFESTD_stmtidR841_);
2968   ffestd_stmt_append_ (stmt);
2969   ffestd_subr_line_save_ (stmt);
2970 }
2971 
2972 /* ffestd_R842 -- STOP statement
2973 
2974    ffestd_R842(expr);  */
2975 
2976 void
ffestd_R842(ffebld expr)2977 ffestd_R842 (ffebld expr)
2978 {
2979   ffestdStmt_ stmt;
2980 
2981   ffestd_check_simple_ ();
2982 
2983   stmt = ffestd_stmt_new_ (FFESTD_stmtidR842_);
2984   ffestd_stmt_append_ (stmt);
2985   ffestd_subr_line_save_ (stmt);
2986   if (ffesta_outpooldisp () == FFESTA_pooldispPRESERVE)
2987     {
2988       /* This is a "spurious" (automatically-generated) STOP
2989 	 that follows a previous STOP or other statement.
2990 	 Make sure we don't have an expression in the pool,
2991 	 and then mark that the pool has already been killed.  */
2992       assert (expr == NULL);
2993       stmt->u.R842.pool = NULL;
2994       stmt->u.R842.expr = NULL;
2995     }
2996   else
2997     {
2998       stmt->u.R842.pool = ffesta_output_pool;
2999       stmt->u.R842.expr = expr;
3000       ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3001     }
3002 
3003   if (ffestd_block_level_ == 0)
3004     ffestd_is_reachable_ = FALSE;
3005 }
3006 
3007 /* ffestd_R843 -- PAUSE statement
3008 
3009    ffestd_R843(expr,expr_token);
3010 
3011    Make sure statement is valid here; implement.  expr and expr_token are
3012    both NULL if there was no expression.  */
3013 
3014 void
ffestd_R843(ffebld expr)3015 ffestd_R843 (ffebld expr)
3016 {
3017   ffestdStmt_ stmt;
3018 
3019   ffestd_check_simple_ ();
3020 
3021   stmt = ffestd_stmt_new_ (FFESTD_stmtidR843_);
3022   ffestd_stmt_append_ (stmt);
3023   ffestd_subr_line_save_ (stmt);
3024   stmt->u.R843.pool = ffesta_output_pool;
3025   stmt->u.R843.expr = expr;
3026   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3027 }
3028 
3029 /* ffestd_R904 -- OPEN statement
3030 
3031    ffestd_R904();
3032 
3033    Make sure an OPEN is valid in the current context, and implement it.	 */
3034 
3035 void
ffestd_R904()3036 ffestd_R904 ()
3037 {
3038   ffestdStmt_ stmt;
3039 
3040   ffestd_check_simple_ ();
3041 
3042 #define specified(something) \
3043       (ffestp_file.open.open_spec[something].kw_or_val_present)
3044 
3045   /* Warn if there are any thing we don't handle via f2c libraries. */
3046 
3047   if (specified (FFESTP_openixACTION)
3048       || specified (FFESTP_openixASSOCIATEVARIABLE)
3049       || specified (FFESTP_openixBLOCKSIZE)
3050       || specified (FFESTP_openixBUFFERCOUNT)
3051       || specified (FFESTP_openixCARRIAGECONTROL)
3052       || specified (FFESTP_openixDEFAULTFILE)
3053       || specified (FFESTP_openixDELIM)
3054       || specified (FFESTP_openixDISPOSE)
3055       || specified (FFESTP_openixEXTENDSIZE)
3056       || specified (FFESTP_openixINITIALSIZE)
3057       || specified (FFESTP_openixKEY)
3058       || specified (FFESTP_openixMAXREC)
3059       || specified (FFESTP_openixNOSPANBLOCKS)
3060       || specified (FFESTP_openixORGANIZATION)
3061       || specified (FFESTP_openixPAD)
3062       || specified (FFESTP_openixPOSITION)
3063       || specified (FFESTP_openixREADONLY)
3064       || specified (FFESTP_openixRECORDTYPE)
3065       || specified (FFESTP_openixSHARED)
3066       || specified (FFESTP_openixUSEROPEN))
3067     {
3068       ffebad_start (FFEBAD_OPEN_UNSUPPORTED);
3069       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
3070 		   ffelex_token_where_column (ffesta_tokens[0]));
3071       ffebad_finish ();
3072     }
3073 
3074 #undef specified
3075 
3076   stmt = ffestd_stmt_new_ (FFESTD_stmtidR904_);
3077   ffestd_stmt_append_ (stmt);
3078   ffestd_subr_line_save_ (stmt);
3079   stmt->u.R904.pool = ffesta_output_pool;
3080   stmt->u.R904.params = ffestd_subr_copy_open_ ();
3081   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3082 }
3083 
3084 /* ffestd_R907 -- CLOSE statement
3085 
3086    ffestd_R907();
3087 
3088    Make sure a CLOSE is valid in the current context, and implement it.	 */
3089 
3090 void
ffestd_R907()3091 ffestd_R907 ()
3092 {
3093   ffestdStmt_ stmt;
3094 
3095   ffestd_check_simple_ ();
3096 
3097   stmt = ffestd_stmt_new_ (FFESTD_stmtidR907_);
3098   ffestd_stmt_append_ (stmt);
3099   ffestd_subr_line_save_ (stmt);
3100   stmt->u.R907.pool = ffesta_output_pool;
3101   stmt->u.R907.params = ffestd_subr_copy_close_ ();
3102   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3103 }
3104 
3105 /* ffestd_R909_start -- READ(...) statement list begin
3106 
3107    ffestd_R909_start(FALSE);
3108 
3109    Verify that READ is valid here, and begin accepting items in the
3110    list.  */
3111 
3112 void
ffestd_R909_start(bool only_format,ffestvUnit unit,ffestvFormat format,bool rec,bool key)3113 ffestd_R909_start (bool only_format, ffestvUnit unit,
3114 		   ffestvFormat format, bool rec, bool key)
3115 {
3116   ffestdStmt_ stmt;
3117 
3118   ffestd_check_start_ ();
3119 
3120 #define specified(something) \
3121       (ffestp_file.read.read_spec[something].kw_or_val_present)
3122 
3123   /* Warn if there are any thing we don't handle via f2c libraries. */
3124   if (specified (FFESTP_readixADVANCE)
3125       || specified (FFESTP_readixEOR)
3126       || specified (FFESTP_readixKEYEQ)
3127       || specified (FFESTP_readixKEYGE)
3128       || specified (FFESTP_readixKEYGT)
3129       || specified (FFESTP_readixKEYID)
3130       || specified (FFESTP_readixNULLS)
3131       || specified (FFESTP_readixSIZE))
3132     {
3133       ffebad_start (FFEBAD_READ_UNSUPPORTED);
3134       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
3135 		   ffelex_token_where_column (ffesta_tokens[0]));
3136       ffebad_finish ();
3137     }
3138 
3139 #undef specified
3140 
3141   stmt = ffestd_stmt_new_ (FFESTD_stmtidR909_);
3142   ffestd_stmt_append_ (stmt);
3143   ffestd_subr_line_save_ (stmt);
3144   stmt->u.R909.pool = ffesta_output_pool;
3145   stmt->u.R909.params = ffestd_subr_copy_read_ ();
3146   stmt->u.R909.only_format = only_format;
3147   stmt->u.R909.unit = unit;
3148   stmt->u.R909.format = format;
3149   stmt->u.R909.rec = rec;
3150   stmt->u.R909.key = key;
3151   stmt->u.R909.list = NULL;
3152   ffestd_expr_list_ = &stmt->u.R909.list;
3153   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3154 }
3155 
3156 /* ffestd_R909_item -- READ statement i/o item
3157 
3158    ffestd_R909_item(expr,expr_token);
3159 
3160    Implement output-list expression.  */
3161 
3162 void
ffestd_R909_item(ffebld expr,ffelexToken expr_token)3163 ffestd_R909_item (ffebld expr, ffelexToken expr_token)
3164 {
3165   ffestdExprItem_ item;
3166 
3167   ffestd_check_item_ ();
3168 
3169   item = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool,
3170 					  "ffestdExprItem_", sizeof (*item));
3171 
3172   item->next = NULL;
3173   item->expr = expr;
3174   item->token = ffelex_token_use (expr_token);
3175   *ffestd_expr_list_ = item;
3176   ffestd_expr_list_ = &item->next;
3177 }
3178 
3179 /* ffestd_R909_finish -- READ statement list complete
3180 
3181    ffestd_R909_finish();
3182 
3183    Just wrap up any local activities.  */
3184 
3185 void
ffestd_R909_finish()3186 ffestd_R909_finish ()
3187 {
3188   ffestd_check_finish_ ();
3189 }
3190 
3191 /* ffestd_R910_start -- WRITE(...) statement list begin
3192 
3193    ffestd_R910_start();
3194 
3195    Verify that WRITE is valid here, and begin accepting items in the
3196    list.  */
3197 
3198 void
ffestd_R910_start(ffestvUnit unit,ffestvFormat format,bool rec)3199 ffestd_R910_start (ffestvUnit unit, ffestvFormat format, bool rec)
3200 {
3201   ffestdStmt_ stmt;
3202 
3203   ffestd_check_start_ ();
3204 
3205 #define specified(something) \
3206       (ffestp_file.write.write_spec[something].kw_or_val_present)
3207 
3208   /* Warn if there are any thing we don't handle via f2c libraries. */
3209   if (specified (FFESTP_writeixADVANCE)
3210       || specified (FFESTP_writeixEOR))
3211     {
3212       ffebad_start (FFEBAD_WRITE_UNSUPPORTED);
3213       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
3214 		   ffelex_token_where_column (ffesta_tokens[0]));
3215       ffebad_finish ();
3216     }
3217 
3218 #undef specified
3219 
3220   stmt = ffestd_stmt_new_ (FFESTD_stmtidR910_);
3221   ffestd_stmt_append_ (stmt);
3222   ffestd_subr_line_save_ (stmt);
3223   stmt->u.R910.pool = ffesta_output_pool;
3224   stmt->u.R910.params = ffestd_subr_copy_write_ ();
3225   stmt->u.R910.unit = unit;
3226   stmt->u.R910.format = format;
3227   stmt->u.R910.rec = rec;
3228   stmt->u.R910.list = NULL;
3229   ffestd_expr_list_ = &stmt->u.R910.list;
3230   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3231 }
3232 
3233 /* ffestd_R910_item -- WRITE statement i/o item
3234 
3235    ffestd_R910_item(expr,expr_token);
3236 
3237    Implement output-list expression.  */
3238 
3239 void
ffestd_R910_item(ffebld expr,ffelexToken expr_token)3240 ffestd_R910_item (ffebld expr, ffelexToken expr_token)
3241 {
3242   ffestdExprItem_ item;
3243 
3244   ffestd_check_item_ ();
3245 
3246   item = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool,
3247 					  "ffestdExprItem_", sizeof (*item));
3248 
3249   item->next = NULL;
3250   item->expr = expr;
3251   item->token = ffelex_token_use (expr_token);
3252   *ffestd_expr_list_ = item;
3253   ffestd_expr_list_ = &item->next;
3254 }
3255 
3256 /* ffestd_R910_finish -- WRITE statement list complete
3257 
3258    ffestd_R910_finish();
3259 
3260    Just wrap up any local activities.  */
3261 
3262 void
ffestd_R910_finish()3263 ffestd_R910_finish ()
3264 {
3265   ffestd_check_finish_ ();
3266 }
3267 
3268 /* ffestd_R911_start -- PRINT statement list begin
3269 
3270    ffestd_R911_start();
3271 
3272    Verify that PRINT is valid here, and begin accepting items in the
3273    list.  */
3274 
3275 void
ffestd_R911_start(ffestvFormat format)3276 ffestd_R911_start (ffestvFormat format)
3277 {
3278   ffestdStmt_ stmt;
3279 
3280   ffestd_check_start_ ();
3281 
3282   stmt = ffestd_stmt_new_ (FFESTD_stmtidR911_);
3283   ffestd_stmt_append_ (stmt);
3284   ffestd_subr_line_save_ (stmt);
3285   stmt->u.R911.pool = ffesta_output_pool;
3286   stmt->u.R911.params = ffestd_subr_copy_print_ ();
3287   stmt->u.R911.format = format;
3288   stmt->u.R911.list = NULL;
3289   ffestd_expr_list_ = &stmt->u.R911.list;
3290   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3291 }
3292 
3293 /* ffestd_R911_item -- PRINT statement i/o item
3294 
3295    ffestd_R911_item(expr,expr_token);
3296 
3297    Implement output-list expression.  */
3298 
3299 void
ffestd_R911_item(ffebld expr,ffelexToken expr_token)3300 ffestd_R911_item (ffebld expr, ffelexToken expr_token)
3301 {
3302   ffestdExprItem_ item;
3303 
3304   ffestd_check_item_ ();
3305 
3306   item = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool,
3307 					  "ffestdExprItem_", sizeof (*item));
3308 
3309   item->next = NULL;
3310   item->expr = expr;
3311   item->token = ffelex_token_use (expr_token);
3312   *ffestd_expr_list_ = item;
3313   ffestd_expr_list_ = &item->next;
3314 }
3315 
3316 /* ffestd_R911_finish -- PRINT statement list complete
3317 
3318    ffestd_R911_finish();
3319 
3320    Just wrap up any local activities.  */
3321 
3322 void
ffestd_R911_finish()3323 ffestd_R911_finish ()
3324 {
3325   ffestd_check_finish_ ();
3326 }
3327 
3328 /* ffestd_R919 -- BACKSPACE statement
3329 
3330    ffestd_R919();
3331 
3332    Make sure a BACKSPACE is valid in the current context, and implement it.  */
3333 
3334 void
ffestd_R919()3335 ffestd_R919 ()
3336 {
3337   ffestdStmt_ stmt;
3338 
3339   ffestd_check_simple_ ();
3340 
3341   stmt = ffestd_stmt_new_ (FFESTD_stmtidR919_);
3342   ffestd_stmt_append_ (stmt);
3343   ffestd_subr_line_save_ (stmt);
3344   stmt->u.R919.pool = ffesta_output_pool;
3345   stmt->u.R919.params = ffestd_subr_copy_beru_ ();
3346   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3347 }
3348 
3349 /* ffestd_R920 -- ENDFILE statement
3350 
3351    ffestd_R920();
3352 
3353    Make sure a ENDFILE is valid in the current context, and implement it.  */
3354 
3355 void
ffestd_R920()3356 ffestd_R920 ()
3357 {
3358   ffestdStmt_ stmt;
3359 
3360   ffestd_check_simple_ ();
3361 
3362   stmt = ffestd_stmt_new_ (FFESTD_stmtidR920_);
3363   ffestd_stmt_append_ (stmt);
3364   ffestd_subr_line_save_ (stmt);
3365   stmt->u.R920.pool = ffesta_output_pool;
3366   stmt->u.R920.params = ffestd_subr_copy_beru_ ();
3367   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3368 }
3369 
3370 /* ffestd_R921 -- REWIND statement
3371 
3372    ffestd_R921();
3373 
3374    Make sure a REWIND is valid in the current context, and implement it.  */
3375 
3376 void
ffestd_R921()3377 ffestd_R921 ()
3378 {
3379   ffestdStmt_ stmt;
3380 
3381   ffestd_check_simple_ ();
3382 
3383   stmt = ffestd_stmt_new_ (FFESTD_stmtidR921_);
3384   ffestd_stmt_append_ (stmt);
3385   ffestd_subr_line_save_ (stmt);
3386   stmt->u.R921.pool = ffesta_output_pool;
3387   stmt->u.R921.params = ffestd_subr_copy_beru_ ();
3388   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3389 }
3390 
3391 /* ffestd_R923A -- INQUIRE statement (non-IOLENGTH version)
3392 
3393    ffestd_R923A(bool by_file);
3394 
3395    Make sure an INQUIRE is valid in the current context, and implement it.  */
3396 
3397 void
ffestd_R923A(bool by_file)3398 ffestd_R923A (bool by_file)
3399 {
3400   ffestdStmt_ stmt;
3401 
3402   ffestd_check_simple_ ();
3403 
3404 #define specified(something) \
3405       (ffestp_file.inquire.inquire_spec[something].kw_or_val_present)
3406 
3407   /* Warn if there are any thing we don't handle via f2c libraries. */
3408   if (specified (FFESTP_inquireixACTION)
3409       || specified (FFESTP_inquireixCARRIAGECONTROL)
3410       || specified (FFESTP_inquireixDEFAULTFILE)
3411       || specified (FFESTP_inquireixDELIM)
3412       || specified (FFESTP_inquireixKEYED)
3413       || specified (FFESTP_inquireixORGANIZATION)
3414       || specified (FFESTP_inquireixPAD)
3415       || specified (FFESTP_inquireixPOSITION)
3416       || specified (FFESTP_inquireixREAD)
3417       || specified (FFESTP_inquireixREADWRITE)
3418       || specified (FFESTP_inquireixRECORDTYPE)
3419       || specified (FFESTP_inquireixWRITE))
3420     {
3421       ffebad_start (FFEBAD_INQUIRE_UNSUPPORTED);
3422       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
3423 		   ffelex_token_where_column (ffesta_tokens[0]));
3424       ffebad_finish ();
3425     }
3426 
3427 #undef specified
3428 
3429   stmt = ffestd_stmt_new_ (FFESTD_stmtidR923A_);
3430   ffestd_stmt_append_ (stmt);
3431   ffestd_subr_line_save_ (stmt);
3432   stmt->u.R923A.pool = ffesta_output_pool;
3433   stmt->u.R923A.params = ffestd_subr_copy_inquire_ ();
3434   stmt->u.R923A.by_file = by_file;
3435   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3436 }
3437 
3438 /* ffestd_R923B_start -- INQUIRE(IOLENGTH=expr) statement list begin
3439 
3440    ffestd_R923B_start();
3441 
3442    Verify that INQUIRE is valid here, and begin accepting items in the
3443    list.  */
3444 
3445 void
ffestd_R923B_start()3446 ffestd_R923B_start ()
3447 {
3448   ffestdStmt_ stmt;
3449 
3450   ffestd_check_start_ ();
3451 
3452   stmt = ffestd_stmt_new_ (FFESTD_stmtidR923B_);
3453   ffestd_stmt_append_ (stmt);
3454   ffestd_subr_line_save_ (stmt);
3455   stmt->u.R923B.pool = ffesta_output_pool;
3456   stmt->u.R923B.params = ffestd_subr_copy_inquire_ ();
3457   stmt->u.R923B.list = NULL;
3458   ffestd_expr_list_ = &stmt->u.R923B.list;
3459   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3460 }
3461 
3462 /* ffestd_R923B_item -- INQUIRE statement i/o item
3463 
3464    ffestd_R923B_item(expr,expr_token);
3465 
3466    Implement output-list expression.  */
3467 
3468 void
ffestd_R923B_item(ffebld expr)3469 ffestd_R923B_item (ffebld expr)
3470 {
3471   ffestdExprItem_ item;
3472 
3473   ffestd_check_item_ ();
3474 
3475   item = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool,
3476 					  "ffestdExprItem_", sizeof (*item));
3477 
3478   item->next = NULL;
3479   item->expr = expr;
3480   *ffestd_expr_list_ = item;
3481   ffestd_expr_list_ = &item->next;
3482 }
3483 
3484 /* ffestd_R923B_finish -- INQUIRE statement list complete
3485 
3486    ffestd_R923B_finish();
3487 
3488    Just wrap up any local activities.  */
3489 
3490 void
ffestd_R923B_finish()3491 ffestd_R923B_finish ()
3492 {
3493   ffestd_check_finish_ ();
3494 }
3495 
3496 /* ffestd_R1001 -- FORMAT statement
3497 
3498    ffestd_R1001(format_list);  */
3499 
3500 void
ffestd_R1001(ffesttFormatList f)3501 ffestd_R1001 (ffesttFormatList f)
3502 {
3503   ffestsHolder str;
3504   ffests s = &str;
3505   ffestdStmt_ stmt;
3506 
3507   ffestd_check_simple_ ();
3508 
3509   if (ffestd_label_formatdef_ == NULL)
3510     return;			/* Nothing to hook it up to (no label def). */
3511 
3512   ffests_new (s, malloc_pool_image (), 80);
3513   ffests_putc (s, '(');
3514   ffestd_R1001dump_ (s, f);	/* Build the string in s. */
3515   ffests_putc (s, ')');
3516 
3517   stmt = ffestd_stmt_new_ (FFESTD_stmtidR1001_);
3518   ffestd_stmt_append_ (stmt);
3519   stmt->u.R1001.str = str;
3520 
3521   ffestd_label_formatdef_ = NULL;
3522 }
3523 
3524 /* ffestd_R1001dump_ -- Dump list of formats
3525 
3526    ffesttFormatList list;
3527    ffestd_R1001dump_(list,0);
3528 
3529    The formats in the list are dumped.	*/
3530 
3531 static void
ffestd_R1001dump_(ffests s,ffesttFormatList list)3532 ffestd_R1001dump_ (ffests s, ffesttFormatList list)
3533 {
3534   ffesttFormatList next;
3535 
3536   for (next = list->next; next != list; next = next->next)
3537     {
3538       if (next != list->next)
3539 	ffests_putc (s, ',');
3540       switch (next->type)
3541 	{
3542 	case FFESTP_formattypeI:
3543 	  ffestd_R1001dump_1005_3_ (s, next, "I");
3544 	  break;
3545 
3546 	case FFESTP_formattypeB:
3547 	  ffestd_R1001error_ (next);
3548 	  break;
3549 
3550 	case FFESTP_formattypeO:
3551 	  ffestd_R1001dump_1005_3_ (s, next, "O");
3552 	  break;
3553 
3554 	case FFESTP_formattypeZ:
3555 	  ffestd_R1001dump_1005_3_ (s, next, "Z");
3556 	  break;
3557 
3558 	case FFESTP_formattypeF:
3559 	  ffestd_R1001dump_1005_4_ (s, next, "F");
3560 	  break;
3561 
3562 	case FFESTP_formattypeE:
3563 	  ffestd_R1001dump_1005_5_ (s, next, "E");
3564 	  break;
3565 
3566 	case FFESTP_formattypeEN:
3567 	  ffestd_R1001error_ (next);
3568 	  break;
3569 
3570 	case FFESTP_formattypeG:
3571 	  ffestd_R1001dump_1005_5_ (s, next, "G");
3572 	  break;
3573 
3574 	case FFESTP_formattypeL:
3575 	  ffestd_R1001dump_1005_2_ (s, next, "L");
3576 	  break;
3577 
3578 	case FFESTP_formattypeA:
3579 	  ffestd_R1001dump_1005_1_ (s, next, "A");
3580 	  break;
3581 
3582 	case FFESTP_formattypeD:
3583 	  ffestd_R1001dump_1005_4_ (s, next, "D");
3584 	  break;
3585 
3586 	case FFESTP_formattypeQ:
3587 	  ffestd_R1001error_ (next);
3588 	  break;
3589 
3590 	case FFESTP_formattypeDOLLAR:
3591 	  ffestd_R1001dump_1010_1_ (s, next, "$");
3592 	  break;
3593 
3594 	case FFESTP_formattypeP:
3595 	  ffestd_R1001dump_1010_4_ (s, next, "P");
3596 	  break;
3597 
3598 	case FFESTP_formattypeT:
3599 	  ffestd_R1001dump_1010_5_ (s, next, "T");
3600 	  break;
3601 
3602 	case FFESTP_formattypeTL:
3603 	  ffestd_R1001dump_1010_5_ (s, next, "TL");
3604 	  break;
3605 
3606 	case FFESTP_formattypeTR:
3607 	  ffestd_R1001dump_1010_5_ (s, next, "TR");
3608 	  break;
3609 
3610 	case FFESTP_formattypeX:
3611 	  ffestd_R1001dump_1010_3_ (s, next, "X");
3612 	  break;
3613 
3614 	case FFESTP_formattypeS:
3615 	  ffestd_R1001dump_1010_1_ (s, next, "S");
3616 	  break;
3617 
3618 	case FFESTP_formattypeSP:
3619 	  ffestd_R1001dump_1010_1_ (s, next, "SP");
3620 	  break;
3621 
3622 	case FFESTP_formattypeSS:
3623 	  ffestd_R1001dump_1010_1_ (s, next, "SS");
3624 	  break;
3625 
3626 	case FFESTP_formattypeBN:
3627 	  ffestd_R1001dump_1010_1_ (s, next, "BN");
3628 	  break;
3629 
3630 	case FFESTP_formattypeBZ:
3631 	  ffestd_R1001dump_1010_1_ (s, next, "BZ");
3632 	  break;
3633 
3634 	case FFESTP_formattypeSLASH:
3635 	  ffestd_R1001dump_1010_2_ (s, next, "/");
3636 	  break;
3637 
3638 	case FFESTP_formattypeCOLON:
3639 	  ffestd_R1001dump_1010_1_ (s, next, ":");
3640 	  break;
3641 
3642 	case FFESTP_formattypeR1016:
3643 	  switch (ffelex_token_type (next->t))
3644 	    {
3645 	    case FFELEX_typeCHARACTER:
3646 	      {
3647 		char *p = ffelex_token_text (next->t);
3648 		ffeTokenLength i = ffelex_token_length (next->t);
3649 
3650 		ffests_putc (s, '\002');
3651 		while (i-- != 0)
3652 		  {
3653 		    if (*p == '\002')
3654 		      ffests_putc (s, '\002');
3655 		    ffests_putc (s, *p);
3656 		    ++p;
3657 		  }
3658 		ffests_putc (s, '\002');
3659 	      }
3660 	      break;
3661 
3662 	    case FFELEX_typeHOLLERITH:
3663 	      {
3664 		char *p = ffelex_token_text (next->t);
3665 		ffeTokenLength i = ffelex_token_length (next->t);
3666 
3667 		ffests_printf (s, "%" ffeTokenLength_f "uH", i);
3668 		while (i-- != 0)
3669 		  {
3670 		    ffests_putc (s, *p);
3671 		    ++p;
3672 		  }
3673 	      }
3674 	      break;
3675 
3676 	    default:
3677 	      assert (FALSE);
3678 	    }
3679 	  break;
3680 
3681 	case FFESTP_formattypeFORMAT:
3682 	  if (next->u.R1003D.R1004.present)
3683 	    {
3684 	      if (next->u.R1003D.R1004.rtexpr)
3685 		ffestd_R1001rtexpr_ (s, next, next->u.R1003D.R1004.u.expr);
3686 	      else
3687 		ffests_printf (s, "%lu", next->u.R1003D.R1004.u.unsigned_val);
3688 	    }
3689 
3690 	  ffests_putc (s, '(');
3691 	  ffestd_R1001dump_ (s, next->u.R1003D.format);
3692 	  ffests_putc (s, ')');
3693 	  break;
3694 
3695 	default:
3696 	  assert (FALSE);
3697 	}
3698     }
3699 }
3700 
3701 /* ffestd_R1001dump_1005_1_ -- Dump a particular format
3702 
3703    ffesttFormatList f;
3704    ffestd_R1001dump_1005_1_(f,"I");
3705 
3706    The format is dumped with form [r]X[w].  */
3707 
3708 static void
ffestd_R1001dump_1005_1_(ffests s,ffesttFormatList f,const char * string)3709 ffestd_R1001dump_1005_1_ (ffests s, ffesttFormatList f, const char *string)
3710 {
3711   assert (!f->u.R1005.R1007_or_R1008.present);
3712   assert (!f->u.R1005.R1009.present);
3713 
3714   if (f->u.R1005.R1004.present)
3715     {
3716       if (f->u.R1005.R1004.rtexpr)
3717 	ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr);
3718       else
3719 	ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
3720     }
3721 
3722   ffests_puts (s, string);
3723 
3724   if (f->u.R1005.R1006.present)
3725     {
3726       if (f->u.R1005.R1006.rtexpr)
3727 	ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr);
3728       else
3729 	ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
3730     }
3731 }
3732 
3733 /* ffestd_R1001dump_1005_2_ -- Dump a particular format
3734 
3735    ffesttFormatList f;
3736    ffestd_R1001dump_1005_2_(f,"I");
3737 
3738    The format is dumped with form [r]Xw.  */
3739 
3740 static void
ffestd_R1001dump_1005_2_(ffests s,ffesttFormatList f,const char * string)3741 ffestd_R1001dump_1005_2_ (ffests s, ffesttFormatList f, const char *string)
3742 {
3743   assert (!f->u.R1005.R1007_or_R1008.present);
3744   assert (!f->u.R1005.R1009.present);
3745   assert (f->u.R1005.R1006.present);
3746 
3747   if (f->u.R1005.R1004.present)
3748     {
3749       if (f->u.R1005.R1004.rtexpr)
3750 	ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr);
3751       else
3752 	ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
3753     }
3754 
3755   ffests_puts (s, string);
3756 
3757   if (f->u.R1005.R1006.rtexpr)
3758     ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr);
3759   else
3760     ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
3761 }
3762 
3763 /* ffestd_R1001dump_1005_3_ -- Dump a particular format
3764 
3765    ffesttFormatList f;
3766    ffestd_R1001dump_1005_3_(f,"I");
3767 
3768    The format is dumped with form [r]Xw[.m].  */
3769 
3770 static void
ffestd_R1001dump_1005_3_(ffests s,ffesttFormatList f,const char * string)3771 ffestd_R1001dump_1005_3_ (ffests s, ffesttFormatList f, const char *string)
3772 {
3773   assert (!f->u.R1005.R1009.present);
3774   assert (f->u.R1005.R1006.present);
3775 
3776   if (f->u.R1005.R1004.present)
3777     {
3778       if (f->u.R1005.R1004.rtexpr)
3779 	ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr);
3780       else
3781 	ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
3782     }
3783 
3784   ffests_puts (s, string);
3785 
3786   if (f->u.R1005.R1006.rtexpr)
3787     ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr);
3788   else
3789     ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
3790 
3791   if (f->u.R1005.R1007_or_R1008.present)
3792     {
3793       ffests_putc (s, '.');
3794       if (f->u.R1005.R1007_or_R1008.rtexpr)
3795 	ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1007_or_R1008.u.expr);
3796       else
3797 	ffests_printf (s, "%lu", f->u.R1005.R1007_or_R1008.u.unsigned_val);
3798     }
3799 }
3800 
3801 /* ffestd_R1001dump_1005_4_ -- Dump a particular format
3802 
3803    ffesttFormatList f;
3804    ffestd_R1001dump_1005_4_(f,"I");
3805 
3806    The format is dumped with form [r]Xw.d.  */
3807 
3808 static void
ffestd_R1001dump_1005_4_(ffests s,ffesttFormatList f,const char * string)3809 ffestd_R1001dump_1005_4_ (ffests s, ffesttFormatList f, const char *string)
3810 {
3811   assert (!f->u.R1005.R1009.present);
3812   assert (f->u.R1005.R1007_or_R1008.present);
3813   assert (f->u.R1005.R1006.present);
3814 
3815   if (f->u.R1005.R1004.present)
3816     {
3817       if (f->u.R1005.R1004.rtexpr)
3818 	ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr);
3819       else
3820 	ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
3821     }
3822 
3823   ffests_puts (s, string);
3824 
3825   if (f->u.R1005.R1006.rtexpr)
3826     ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr);
3827   else
3828     ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
3829 
3830   ffests_putc (s, '.');
3831   if (f->u.R1005.R1007_or_R1008.rtexpr)
3832     ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1007_or_R1008.u.expr);
3833   else
3834     ffests_printf (s, "%lu", f->u.R1005.R1007_or_R1008.u.unsigned_val);
3835 }
3836 
3837 /* ffestd_R1001dump_1005_5_ -- Dump a particular format
3838 
3839    ffesttFormatList f;
3840    ffestd_R1001dump_1005_5_(f,"I");
3841 
3842    The format is dumped with form [r]Xw.d[Ee].	*/
3843 
3844 static void
ffestd_R1001dump_1005_5_(ffests s,ffesttFormatList f,const char * string)3845 ffestd_R1001dump_1005_5_ (ffests s, ffesttFormatList f, const char *string)
3846 {
3847   assert (f->u.R1005.R1007_or_R1008.present);
3848   assert (f->u.R1005.R1006.present);
3849 
3850   if (f->u.R1005.R1004.present)
3851     {
3852       if (f->u.R1005.R1004.rtexpr)
3853 	ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr);
3854       else
3855 	ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
3856     }
3857 
3858   ffests_puts (s, string);
3859 
3860   if (f->u.R1005.R1006.rtexpr)
3861     ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr);
3862   else
3863     ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
3864 
3865   ffests_putc (s, '.');
3866   if (f->u.R1005.R1007_or_R1008.rtexpr)
3867     ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1007_or_R1008.u.expr);
3868   else
3869     ffests_printf (s, "%lu", f->u.R1005.R1007_or_R1008.u.unsigned_val);
3870 
3871   if (f->u.R1005.R1009.present)
3872     {
3873       ffests_putc (s, 'E');
3874       if (f->u.R1005.R1009.rtexpr)
3875 	ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1009.u.expr);
3876       else
3877 	ffests_printf (s, "%lu", f->u.R1005.R1009.u.unsigned_val);
3878     }
3879 }
3880 
3881 /* ffestd_R1001dump_1010_1_ -- Dump a particular format
3882 
3883    ffesttFormatList f;
3884    ffestd_R1001dump_1010_1_(f,"I");
3885 
3886    The format is dumped with form X.  */
3887 
3888 static void
ffestd_R1001dump_1010_1_(ffests s,ffesttFormatList f,const char * string)3889 ffestd_R1001dump_1010_1_ (ffests s, ffesttFormatList f, const char *string)
3890 {
3891   assert (!f->u.R1010.val.present);
3892 
3893   ffests_puts (s, string);
3894 }
3895 
3896 /* ffestd_R1001dump_1010_2_ -- Dump a particular format
3897 
3898    ffesttFormatList f;
3899    ffestd_R1001dump_1010_2_(f,"I");
3900 
3901    The format is dumped with form [r]X.	 */
3902 
3903 static void
ffestd_R1001dump_1010_2_(ffests s,ffesttFormatList f,const char * string)3904 ffestd_R1001dump_1010_2_ (ffests s, ffesttFormatList f, const char *string)
3905 {
3906   if (f->u.R1010.val.present)
3907     {
3908       if (f->u.R1010.val.rtexpr)
3909 	ffestd_R1001rtexpr_ (s, f, f->u.R1010.val.u.expr);
3910       else
3911 	ffests_printf (s, "%lu", f->u.R1010.val.u.unsigned_val);
3912     }
3913 
3914   ffests_puts (s, string);
3915 }
3916 
3917 /* ffestd_R1001dump_1010_3_ -- Dump a particular format
3918 
3919    ffesttFormatList f;
3920    ffestd_R1001dump_1010_3_(f,"I");
3921 
3922    The format is dumped with form nX.  */
3923 
3924 static void
ffestd_R1001dump_1010_3_(ffests s,ffesttFormatList f,const char * string)3925 ffestd_R1001dump_1010_3_ (ffests s, ffesttFormatList f, const char *string)
3926 {
3927   assert (f->u.R1010.val.present);
3928 
3929   if (f->u.R1010.val.rtexpr)
3930     ffestd_R1001rtexpr_ (s, f, f->u.R1010.val.u.expr);
3931   else
3932     ffests_printf (s, "%lu", f->u.R1010.val.u.unsigned_val);
3933 
3934   ffests_puts (s, string);
3935 }
3936 
3937 /* ffestd_R1001dump_1010_4_ -- Dump a particular format
3938 
3939    ffesttFormatList f;
3940    ffestd_R1001dump_1010_4_(f,"I");
3941 
3942    The format is dumped with form kX.  Note that k is signed.  */
3943 
3944 static void
ffestd_R1001dump_1010_4_(ffests s,ffesttFormatList f,const char * string)3945 ffestd_R1001dump_1010_4_ (ffests s, ffesttFormatList f, const char *string)
3946 {
3947   assert (f->u.R1010.val.present);
3948 
3949   if (f->u.R1010.val.rtexpr)
3950     ffestd_R1001rtexpr_ (s, f, f->u.R1010.val.u.expr);
3951   else
3952     ffests_printf (s, "%ld", f->u.R1010.val.u.signed_val);
3953 
3954   ffests_puts (s, string);
3955 }
3956 
3957 /* ffestd_R1001dump_1010_5_ -- Dump a particular format
3958 
3959    ffesttFormatList f;
3960    ffestd_R1001dump_1010_5_(f,"I");
3961 
3962    The format is dumped with form Xn.  */
3963 
3964 static void
ffestd_R1001dump_1010_5_(ffests s,ffesttFormatList f,const char * string)3965 ffestd_R1001dump_1010_5_ (ffests s, ffesttFormatList f, const char *string)
3966 {
3967   assert (f->u.R1010.val.present);
3968 
3969   ffests_puts (s, string);
3970 
3971   if (f->u.R1010.val.rtexpr)
3972     ffestd_R1001rtexpr_ (s, f, f->u.R1010.val.u.expr);
3973   else
3974     ffests_printf (s, "%lu", f->u.R1010.val.u.unsigned_val);
3975 }
3976 
3977 /* ffestd_R1001error_ -- Complain about FORMAT specification not supported
3978 
3979    ffesttFormatList f;
3980    ffestd_R1001error_(f);
3981 
3982    An error message is produced.  */
3983 
3984 static void
ffestd_R1001error_(ffesttFormatList f)3985 ffestd_R1001error_ (ffesttFormatList f)
3986 {
3987   ffebad_start (FFEBAD_FORMAT_UNSUPPORTED);
3988   ffebad_here (0, ffelex_token_where_line (f->t), ffelex_token_where_column (f->t));
3989   ffebad_finish ();
3990 }
3991 
3992 static void
ffestd_R1001rtexpr_(ffests s,ffesttFormatList f,ffebld expr)3993 ffestd_R1001rtexpr_ (ffests s, ffesttFormatList f, ffebld expr)
3994 {
3995   if ((expr == NULL)
3996       || (ffebld_op (expr) != FFEBLD_opCONTER)
3997       || (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeINTEGER)
3998       || (ffeinfo_kindtype (ffebld_info (expr)) == FFEINFO_kindtypeINTEGER4))
3999     {
4000       ffebad_start (FFEBAD_FORMAT_VARIABLE);
4001       ffebad_here (0, ffelex_token_where_line (f->t), ffelex_token_where_column (f->t));
4002       ffebad_finish ();
4003     }
4004   else
4005     {
4006       int val;
4007 
4008       switch (ffeinfo_kindtype (ffebld_info (expr)))
4009 	{
4010 #if FFETARGET_okINTEGER1
4011 	case FFEINFO_kindtypeINTEGER1:
4012 	  val = ffebld_constant_integer1 (ffebld_conter (expr));
4013 	  break;
4014 #endif
4015 
4016 #if FFETARGET_okINTEGER2
4017 	case FFEINFO_kindtypeINTEGER2:
4018 	  val = ffebld_constant_integer2 (ffebld_conter (expr));
4019 	  break;
4020 #endif
4021 
4022 #if FFETARGET_okINTEGER3
4023 	case FFEINFO_kindtypeINTEGER3:
4024 	  val = ffebld_constant_integer3 (ffebld_conter (expr));
4025 	  break;
4026 #endif
4027 
4028 	default:
4029 	  assert ("bad INTEGER constant kind type" == NULL);
4030 	  /* Fall through. */
4031 	case FFEINFO_kindtypeANY:
4032 	  return;
4033 	}
4034       ffests_printf (s, "%ld", (long) val);
4035     }
4036 }
4037 
4038 /* ffestd_R1102 -- PROGRAM statement
4039 
4040    ffestd_R1102(name_token);
4041 
4042    Make sure ffestd_kind_ identifies an empty block.  Make sure name_token
4043    gives a valid name.	Implement the beginning of a main program.  */
4044 
4045 void
ffestd_R1102(ffesymbol s,ffelexToken name UNUSED)4046 ffestd_R1102 (ffesymbol s, ffelexToken name UNUSED)
4047 {
4048   ffestd_check_simple_ ();
4049 
4050   assert (ffestd_block_level_ == 0);
4051   ffestd_is_reachable_ = TRUE;
4052 
4053   ffecom_notify_primary_entry (s);
4054   ffe_set_is_mainprog (TRUE);	/* Is a main program. */
4055   ffe_set_is_saveall (TRUE);	/* Main program always has implicit SAVE. */
4056 
4057   ffestw_set_sym (ffestw_stack_top (), s);
4058 }
4059 
4060 /* ffestd_R1103 -- End a PROGRAM
4061 
4062    ffestd_R1103();  */
4063 
4064 void
ffestd_R1103(bool ok UNUSED)4065 ffestd_R1103 (bool ok UNUSED)
4066 {
4067   ffestdStmt_ stmt;
4068 
4069   assert (ffestd_block_level_ == 0);
4070 
4071   if (FFESTD_IS_END_OPTIMIZED_ && ffestd_is_reachable_)
4072     ffestd_R842 (NULL);		/* Generate STOP. */
4073 
4074   if (ffestw_state (ffestw_stack_top ()) != FFESTV_statePROGRAM5)
4075     ffestd_subr_labels_ (FALSE);/* Handle any undefined labels. */
4076 
4077   stmt = ffestd_stmt_new_ (FFESTD_stmtidR1103_);
4078   ffestd_stmt_append_ (stmt);
4079 }
4080 
4081 /* ffestd_R1105 -- MODULE statement
4082 
4083    ffestd_R1105(name_token);
4084 
4085    Make sure ffestd_kind_ identifies an empty block.  Make sure name_token
4086    gives a valid name.	Implement the beginning of a module.  */
4087 
4088 #if FFESTR_F90
4089 void
ffestd_R1105(ffelexToken name)4090 ffestd_R1105 (ffelexToken name)
4091 {
4092   assert (ffestd_block_level_ == 0);
4093 
4094   ffestd_check_simple_ ();
4095 
4096   ffestd_subr_f90_ ();
4097   return;
4098 
4099 #ifdef FFESTD_F90
4100   fprintf (dmpout, "* MODULE %s\n", ffelex_token_text (name));
4101 #endif
4102 }
4103 
4104 /* ffestd_R1106 -- End a MODULE
4105 
4106    ffestd_R1106(TRUE);	*/
4107 
4108 void
ffestd_R1106(bool ok)4109 ffestd_R1106 (bool ok)
4110 {
4111   assert (ffestd_block_level_ == 0);
4112 
4113   /* Generate any wrap-up code here (unlikely in MODULE!). */
4114 
4115   if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateMODULE5)
4116     ffestd_subr_labels_ (TRUE);	/* Handle any undefined labels (unlikely). */
4117 
4118   return;			/* F90. */
4119 
4120 #ifdef FFESTD_F90
4121   fprintf (dmpout, "< END_MODULE %s\n",
4122 	   ffelex_token_text (ffestw_name (ffestw_stack_top ())));
4123 #endif
4124 }
4125 
4126 /* ffestd_R1107_start -- USE statement list begin
4127 
4128    ffestd_R1107_start();
4129 
4130    Verify that USE is valid here, and begin accepting items in the list.  */
4131 
4132 void
ffestd_R1107_start(ffelexToken name,bool only)4133 ffestd_R1107_start (ffelexToken name, bool only)
4134 {
4135   ffestd_check_start_ ();
4136 
4137   ffestd_subr_f90_ ();
4138   return;
4139 
4140 #ifdef FFESTD_F90
4141   fprintf (dmpout, "* USE %s,", ffelex_token_text (name));	/* NB
4142 								   _shriek_begin_uses_. */
4143   if (only)
4144     fputs ("only: ", dmpout);
4145 #endif
4146 }
4147 
4148 /* ffestd_R1107_item -- USE statement for name
4149 
4150    ffestd_R1107_item(local_token,use_token);
4151 
4152    Make sure name_token identifies a valid object to be USEed.	local_token
4153    may be NULL if _start_ was called with only==TRUE.  */
4154 
4155 void
ffestd_R1107_item(ffelexToken local,ffelexToken use)4156 ffestd_R1107_item (ffelexToken local, ffelexToken use)
4157 {
4158   ffestd_check_item_ ();
4159   assert (use != NULL);
4160 
4161   return;			/* F90. */
4162 
4163 #ifdef FFESTD_F90
4164   if (local != NULL)
4165     fprintf (dmpout, "%s=>", ffelex_token_text (local));
4166   fprintf (dmpout, "%s,", ffelex_token_text (use));
4167 #endif
4168 }
4169 
4170 /* ffestd_R1107_finish -- USE statement list complete
4171 
4172    ffestd_R1107_finish();
4173 
4174    Just wrap up any local activities.  */
4175 
4176 void
ffestd_R1107_finish()4177 ffestd_R1107_finish ()
4178 {
4179   ffestd_check_finish_ ();
4180 
4181   return;			/* F90. */
4182 
4183 #ifdef FFESTD_F90
4184   fputc ('\n', dmpout);
4185 #endif
4186 }
4187 
4188 #endif
4189 /* ffestd_R1111 -- BLOCK DATA statement
4190 
4191    ffestd_R1111(name_token);
4192 
4193    Make sure ffestd_kind_ identifies no current program unit.  If not
4194    NULL, make sure name_token gives a valid name.  Implement the beginning
4195    of a block data program unit.  */
4196 
4197 void
ffestd_R1111(ffesymbol s,ffelexToken name UNUSED)4198 ffestd_R1111 (ffesymbol s, ffelexToken name UNUSED)
4199 {
4200   assert (ffestd_block_level_ == 0);
4201   ffestd_is_reachable_ = TRUE;
4202 
4203   ffestd_check_simple_ ();
4204 
4205   ffecom_notify_primary_entry (s);
4206   ffestw_set_sym (ffestw_stack_top (), s);
4207 }
4208 
4209 /* ffestd_R1112 -- End a BLOCK DATA
4210 
4211    ffestd_R1112(TRUE);	*/
4212 
4213 void
ffestd_R1112(bool ok UNUSED)4214 ffestd_R1112 (bool ok UNUSED)
4215 {
4216   ffestdStmt_ stmt;
4217 
4218   assert (ffestd_block_level_ == 0);
4219 
4220   /* Generate any return-like code here (not likely for BLOCK DATA!). */
4221 
4222   if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateBLOCKDATA5)
4223     ffestd_subr_labels_ (TRUE);	/* Handle any undefined labels. */
4224 
4225   stmt = ffestd_stmt_new_ (FFESTD_stmtidR1112_);
4226   ffestd_stmt_append_ (stmt);
4227 }
4228 
4229 /* ffestd_R1202 -- INTERFACE statement
4230 
4231    ffestd_R1202(operator,defined_name);
4232 
4233    Make sure ffestd_kind_ identifies an INTERFACE block.
4234    Implement the end of the current interface.
4235 
4236    06-Jun-90  JCB  1.1
4237       Allow no operator or name to mean INTERFACE by itself; missed this
4238       valid form when originally doing syntactic analysis code.	 */
4239 
4240 #if FFESTR_F90
4241 void
ffestd_R1202(ffestpDefinedOperator operator,ffelexToken name)4242 ffestd_R1202 (ffestpDefinedOperator operator, ffelexToken name)
4243 {
4244   ffestd_check_simple_ ();
4245 
4246   ffestd_subr_f90_ ();
4247   return;
4248 
4249 #ifdef FFESTD_F90
4250   switch (operator)
4251     {
4252     case FFESTP_definedoperatorNone:
4253       if (name == NULL)
4254 	fputs ("* INTERFACE_unnamed\n", dmpout);
4255       else
4256 	fprintf (dmpout, "* INTERFACE %s\n", ffelex_token_text (name));
4257       break;
4258 
4259     case FFESTP_definedoperatorOPERATOR:
4260       fprintf (dmpout, "* INTERFACE_OPERATOR (.%s.)\n", ffelex_token_text (name));
4261       break;
4262 
4263     case FFESTP_definedoperatorASSIGNMENT:
4264       fputs ("* INTERFACE_ASSIGNMENT (=)\n", dmpout);
4265       break;
4266 
4267     case FFESTP_definedoperatorPOWER:
4268       fputs ("* INTERFACE_OPERATOR (**)\n", dmpout);
4269       break;
4270 
4271     case FFESTP_definedoperatorMULT:
4272       fputs ("* INTERFACE_OPERATOR (*)\n", dmpout);
4273       break;
4274 
4275     case FFESTP_definedoperatorADD:
4276       fputs ("* INTERFACE_OPERATOR (+)\n", dmpout);
4277       break;
4278 
4279     case FFESTP_definedoperatorCONCAT:
4280       fputs ("* INTERFACE_OPERATOR (//)\n", dmpout);
4281       break;
4282 
4283     case FFESTP_definedoperatorDIVIDE:
4284       fputs ("* INTERFACE_OPERATOR (/)\n", dmpout);
4285       break;
4286 
4287     case FFESTP_definedoperatorSUBTRACT:
4288       fputs ("* INTERFACE_OPERATOR (-)\n", dmpout);
4289       break;
4290 
4291     case FFESTP_definedoperatorNOT:
4292       fputs ("* INTERFACE_OPERATOR (.not.)\n", dmpout);
4293       break;
4294 
4295     case FFESTP_definedoperatorAND:
4296       fputs ("* INTERFACE_OPERATOR (.and.)\n", dmpout);
4297       break;
4298 
4299     case FFESTP_definedoperatorOR:
4300       fputs ("* INTERFACE_OPERATOR (.or.)\n", dmpout);
4301       break;
4302 
4303     case FFESTP_definedoperatorEQV:
4304       fputs ("* INTERFACE_OPERATOR (.eqv.)\n", dmpout);
4305       break;
4306 
4307     case FFESTP_definedoperatorNEQV:
4308       fputs ("* INTERFACE_OPERATOR (.neqv.)\n", dmpout);
4309       break;
4310 
4311     case FFESTP_definedoperatorEQ:
4312       fputs ("* INTERFACE_OPERATOR (==)\n", dmpout);
4313       break;
4314 
4315     case FFESTP_definedoperatorNE:
4316       fputs ("* INTERFACE_OPERATOR (/=)\n", dmpout);
4317       break;
4318 
4319     case FFESTP_definedoperatorLT:
4320       fputs ("* INTERFACE_OPERATOR (<)\n", dmpout);
4321       break;
4322 
4323     case FFESTP_definedoperatorLE:
4324       fputs ("* INTERFACE_OPERATOR (<=)\n", dmpout);
4325       break;
4326 
4327     case FFESTP_definedoperatorGT:
4328       fputs ("* INTERFACE_OPERATOR (>)\n", dmpout);
4329       break;
4330 
4331     case FFESTP_definedoperatorGE:
4332       fputs ("* INTERFACE_OPERATOR (>=)\n", dmpout);
4333       break;
4334 
4335     default:
4336       assert (FALSE);
4337       break;
4338     }
4339 #endif
4340 }
4341 
4342 /* ffestd_R1203 -- End an INTERFACE
4343 
4344    ffestd_R1203(TRUE);	*/
4345 
4346 void
ffestd_R1203(bool ok)4347 ffestd_R1203 (bool ok)
4348 {
4349   return;			/* F90. */
4350 
4351 #ifdef FFESTD_F90
4352   fputs ("* END_INTERFACE\n", dmpout);
4353 #endif
4354 }
4355 
4356 /* ffestd_R1205_start -- MODULE PROCEDURE statement list begin
4357 
4358    ffestd_R1205_start();
4359 
4360    Verify that MODULE PROCEDURE is valid here, and begin accepting items in
4361    the list.  */
4362 
4363 void
ffestd_R1205_start()4364 ffestd_R1205_start ()
4365 {
4366   ffestd_check_start_ ();
4367 
4368   return;			/* F90. */
4369 
4370 #ifdef FFESTD_F90
4371   fputs ("* MODULE_PROCEDURE ", dmpout);
4372 #endif
4373 }
4374 
4375 /* ffestd_R1205_item -- MODULE PROCEDURE statement for name
4376 
4377    ffestd_R1205_item(name_token);
4378 
4379    Make sure name_token identifies a valid object to be MODULE PROCEDUREed.  */
4380 
4381 void
ffestd_R1205_item(ffelexToken name)4382 ffestd_R1205_item (ffelexToken name)
4383 {
4384   ffestd_check_item_ ();
4385   assert (name != NULL);
4386 
4387   return;			/* F90. */
4388 
4389 #ifdef FFESTD_F90
4390   fprintf (dmpout, "%s,", ffelex_token_text (name));
4391 #endif
4392 }
4393 
4394 /* ffestd_R1205_finish -- MODULE PROCEDURE statement list complete
4395 
4396    ffestd_R1205_finish();
4397 
4398    Just wrap up any local activities.  */
4399 
4400 void
ffestd_R1205_finish()4401 ffestd_R1205_finish ()
4402 {
4403   ffestd_check_finish_ ();
4404 
4405   return;			/* F90. */
4406 
4407 #ifdef FFESTD_F90
4408   fputc ('\n', dmpout);
4409 #endif
4410 }
4411 
4412 #endif
4413 /* ffestd_R1207_start -- EXTERNAL statement list begin
4414 
4415    ffestd_R1207_start();
4416 
4417    Verify that EXTERNAL is valid here, and begin accepting items in the list.  */
4418 
4419 void
ffestd_R1207_start()4420 ffestd_R1207_start ()
4421 {
4422   ffestd_check_start_ ();
4423 }
4424 
4425 /* ffestd_R1207_item -- EXTERNAL statement for name
4426 
4427    ffestd_R1207_item(name_token);
4428 
4429    Make sure name_token identifies a valid object to be EXTERNALd.  */
4430 
4431 void
ffestd_R1207_item(ffelexToken name)4432 ffestd_R1207_item (ffelexToken name)
4433 {
4434   ffestd_check_item_ ();
4435   assert (name != NULL);
4436 }
4437 
4438 /* ffestd_R1207_finish -- EXTERNAL statement list complete
4439 
4440    ffestd_R1207_finish();
4441 
4442    Just wrap up any local activities.  */
4443 
4444 void
ffestd_R1207_finish()4445 ffestd_R1207_finish ()
4446 {
4447   ffestd_check_finish_ ();
4448 }
4449 
4450 /* ffestd_R1208_start -- INTRINSIC statement list begin
4451 
4452    ffestd_R1208_start();
4453 
4454    Verify that INTRINSIC is valid here, and begin accepting items in the list.	*/
4455 
4456 void
ffestd_R1208_start()4457 ffestd_R1208_start ()
4458 {
4459   ffestd_check_start_ ();
4460 }
4461 
4462 /* ffestd_R1208_item -- INTRINSIC statement for name
4463 
4464    ffestd_R1208_item(name_token);
4465 
4466    Make sure name_token identifies a valid object to be INTRINSICd.  */
4467 
4468 void
ffestd_R1208_item(ffelexToken name)4469 ffestd_R1208_item (ffelexToken name)
4470 {
4471   ffestd_check_item_ ();
4472   assert (name != NULL);
4473 }
4474 
4475 /* ffestd_R1208_finish -- INTRINSIC statement list complete
4476 
4477    ffestd_R1208_finish();
4478 
4479    Just wrap up any local activities.  */
4480 
4481 void
ffestd_R1208_finish()4482 ffestd_R1208_finish ()
4483 {
4484   ffestd_check_finish_ ();
4485 }
4486 
4487 /* ffestd_R1212 -- CALL statement
4488 
4489    ffestd_R1212(expr,expr_token);
4490 
4491    Make sure statement is valid here; implement.  */
4492 
4493 void
ffestd_R1212(ffebld expr)4494 ffestd_R1212 (ffebld expr)
4495 {
4496   ffestdStmt_ stmt;
4497 
4498   ffestd_check_simple_ ();
4499 
4500   stmt = ffestd_stmt_new_ (FFESTD_stmtidR1212_);
4501   ffestd_stmt_append_ (stmt);
4502   ffestd_subr_line_save_ (stmt);
4503   stmt->u.R1212.pool = ffesta_output_pool;
4504   stmt->u.R1212.expr = expr;
4505   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
4506 }
4507 
4508 /* ffestd_R1213 -- Defined assignment statement
4509 
4510    ffestd_R1213(dest_expr,source_expr,source_token);
4511 
4512    Make sure the assignment is valid.  */
4513 
4514 #if FFESTR_F90
4515 void
ffestd_R1213(ffebld dest,ffebld source)4516 ffestd_R1213 (ffebld dest, ffebld source)
4517 {
4518   ffestd_check_simple_ ();
4519 
4520   ffestd_subr_f90_ ();
4521 }
4522 
4523 #endif
4524 /* ffestd_R1219 -- FUNCTION statement
4525 
4526    ffestd_R1219(funcname,arglist,ending_token,kind,kindt,len,lent,
4527 	 recursive);
4528 
4529    Make sure statement is valid here, register arguments for the
4530    function name, and so on.
4531 
4532    06-Jun-90  JCB  2.0
4533       Added the kind, len, and recursive arguments.  */
4534 
4535 void
ffestd_R1219(ffesymbol s,ffelexToken funcname UNUSED,ffesttTokenList args UNUSED,ffestpType type UNUSED,ffebld kind UNUSED,ffelexToken kindt UNUSED,ffebld len UNUSED,ffelexToken lent UNUSED,bool recursive UNUSED,ffelexToken result UNUSED,bool separate_result UNUSED)4536 ffestd_R1219 (ffesymbol s, ffelexToken funcname UNUSED,
4537 	      ffesttTokenList args UNUSED, ffestpType type UNUSED,
4538 	      ffebld kind UNUSED, ffelexToken kindt UNUSED,
4539 	      ffebld len UNUSED, ffelexToken lent UNUSED,
4540 	      bool recursive UNUSED, ffelexToken result UNUSED,
4541 	      bool separate_result UNUSED)
4542 {
4543   assert (ffestd_block_level_ == 0);
4544   ffestd_is_reachable_ = TRUE;
4545 
4546   ffestd_check_simple_ ();
4547 
4548   ffecom_notify_primary_entry (s);
4549   ffestw_set_sym (ffestw_stack_top (), s);
4550 }
4551 
4552 /* ffestd_R1221 -- End a FUNCTION
4553 
4554    ffestd_R1221(TRUE);	*/
4555 
4556 void
ffestd_R1221(bool ok UNUSED)4557 ffestd_R1221 (bool ok UNUSED)
4558 {
4559   ffestdStmt_ stmt;
4560 
4561   assert (ffestd_block_level_ == 0);
4562 
4563   if (FFESTD_IS_END_OPTIMIZED_ && ffestd_is_reachable_)
4564     ffestd_R1227 (NULL);	/* Generate RETURN. */
4565 
4566   if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateFUNCTION5)
4567     ffestd_subr_labels_ (FALSE);/* Handle any undefined labels. */
4568 
4569   stmt = ffestd_stmt_new_ (FFESTD_stmtidR1221_);
4570   ffestd_stmt_append_ (stmt);
4571 }
4572 
4573 /* ffestd_R1223 -- SUBROUTINE statement
4574 
4575    ffestd_R1223(subrname,arglist,ending_token,recursive_token);
4576 
4577    Make sure statement is valid here, register arguments for the
4578    subroutine name, and so on.
4579 
4580    06-Jun-90  JCB  2.0
4581       Added the recursive argument.  */
4582 
4583 void
ffestd_R1223(ffesymbol s,ffelexToken subrname UNUSED,ffesttTokenList args UNUSED,ffelexToken final UNUSED,bool recursive UNUSED)4584 ffestd_R1223 (ffesymbol s, ffelexToken subrname UNUSED,
4585 	      ffesttTokenList args UNUSED, ffelexToken final UNUSED,
4586 	      bool recursive UNUSED)
4587 {
4588   assert (ffestd_block_level_ == 0);
4589   ffestd_is_reachable_ = TRUE;
4590 
4591   ffestd_check_simple_ ();
4592 
4593   ffecom_notify_primary_entry (s);
4594   ffestw_set_sym (ffestw_stack_top (), s);
4595 }
4596 
4597 /* ffestd_R1225 -- End a SUBROUTINE
4598 
4599    ffestd_R1225(TRUE);	*/
4600 
4601 void
ffestd_R1225(bool ok UNUSED)4602 ffestd_R1225 (bool ok UNUSED)
4603 {
4604   ffestdStmt_ stmt;
4605 
4606   assert (ffestd_block_level_ == 0);
4607 
4608   if (FFESTD_IS_END_OPTIMIZED_ && ffestd_is_reachable_)
4609     ffestd_R1227 (NULL);	/* Generate RETURN. */
4610 
4611   if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateSUBROUTINE5)
4612     ffestd_subr_labels_ (FALSE);/* Handle any undefined labels. */
4613 
4614   stmt = ffestd_stmt_new_ (FFESTD_stmtidR1225_);
4615   ffestd_stmt_append_ (stmt);
4616 }
4617 
4618 /* ffestd_R1226 -- ENTRY statement
4619 
4620    ffestd_R1226(entryname,arglist,ending_token);
4621 
4622    Make sure we're in a SUBROUTINE or FUNCTION, register arguments for the
4623    entry point name, and so on.	 */
4624 
4625 void
ffestd_R1226(ffesymbol entry)4626 ffestd_R1226 (ffesymbol entry)
4627 {
4628   ffestd_check_simple_ ();
4629 
4630   if (!ffesta_seen_first_exec || ffecom_2pass_advise_entrypoint (entry))
4631     {
4632       ffestdStmt_ stmt;
4633 
4634       stmt = ffestd_stmt_new_ (FFESTD_stmtidR1226_);
4635       ffestd_stmt_append_ (stmt);
4636       ffestd_subr_line_save_ (stmt);
4637       stmt->u.R1226.entry = entry;
4638       stmt->u.R1226.entrynum = ++ffestd_2pass_entrypoints_;
4639     }
4640 
4641   ffestd_is_reachable_ = TRUE;
4642 }
4643 
4644 /* ffestd_R1227 -- RETURN statement
4645 
4646    ffestd_R1227(expr);
4647 
4648    Make sure statement is valid here; implement.  expr and expr_token are
4649    both NULL if there was no expression.  */
4650 
4651 void
ffestd_R1227(ffebld expr)4652 ffestd_R1227 (ffebld expr)
4653 {
4654   ffestdStmt_ stmt;
4655 
4656   ffestd_check_simple_ ();
4657 
4658   stmt = ffestd_stmt_new_ (FFESTD_stmtidR1227_);
4659   ffestd_stmt_append_ (stmt);
4660   ffestd_subr_line_save_ (stmt);
4661   stmt->u.R1227.pool = ffesta_output_pool;
4662   stmt->u.R1227.block = ffestw_stack_top ();
4663   stmt->u.R1227.expr = expr;
4664   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
4665 
4666   if (ffestd_block_level_ == 0)
4667     ffestd_is_reachable_ = FALSE;
4668 }
4669 
4670 /* ffestd_R1228 -- CONTAINS statement
4671 
4672    ffestd_R1228();  */
4673 
4674 #if FFESTR_F90
4675 void
ffestd_R1228()4676 ffestd_R1228 ()
4677 {
4678   assert (ffestd_block_level_ == 0);
4679 
4680   ffestd_check_simple_ ();
4681 
4682   /* Generate RETURN/STOP code here */
4683 
4684   ffestd_subr_labels_ (ffestw_state (ffestw_stack_top ())
4685 		       == FFESTV_stateMODULE5);	/* Handle any undefined
4686 						   labels. */
4687 
4688   ffestd_subr_f90_ ();
4689   return;
4690 
4691 #ifdef FFESTD_F90
4692   fputs ("- CONTAINS\n", dmpout);
4693 #endif
4694 }
4695 
4696 #endif
4697 /* ffestd_R1229_start -- STMTFUNCTION statement begin
4698 
4699    ffestd_R1229_start(func_name,func_arg_list,close_paren);
4700 
4701    This function does not really need to do anything, since _finish_
4702    gets all the info needed, and ffestc_R1229_start has already
4703    done all the stuff that makes a two-phase operation (start and
4704    finish) for handling statement functions necessary.
4705 
4706    03-Jan-91  JCB  2.0
4707       Do nothing, now that _finish_ does everything.  */
4708 
4709 void
ffestd_R1229_start(ffelexToken name UNUSED,ffesttTokenList args UNUSED)4710 ffestd_R1229_start (ffelexToken name UNUSED, ffesttTokenList args UNUSED)
4711 {
4712   ffestd_check_start_ ();
4713 }
4714 
4715 /* ffestd_R1229_finish -- STMTFUNCTION statement list complete
4716 
4717    ffestd_R1229_finish(s);
4718 
4719    The statement function's symbol is passed.  Its list of dummy args is
4720    accessed via ffesymbol_dummyargs and its expansion expression (expr)
4721    is accessed via ffesymbol_sfexpr.
4722 
4723    If sfexpr is NULL, an error occurred parsing the expansion expression, so
4724    just cancel the effects of ffestd_R1229_start and pretend nothing
4725    happened.  Otherwise, install the expression as the expansion for the
4726    statement function, then clean up.
4727 
4728    03-Jan-91  JCB  2.0
4729       Takes sfunc sym instead of just the expansion expression as an
4730       argument, so this function can do all the work, and _start_ is just
4731       a nicety than can do nothing in a back end.  */
4732 
4733 void
ffestd_R1229_finish(ffesymbol s)4734 ffestd_R1229_finish (ffesymbol s)
4735 {
4736   ffebld expr = ffesymbol_sfexpr (s);
4737 
4738   ffestd_check_finish_ ();
4739 
4740   if (expr == NULL)
4741     return;			/* Nothing to do, definition didn't work. */
4742 
4743   /* With gcc, cannot do anything here, because the backend hasn't even
4744      (necessarily) been notified that we're compiling a program unit! */
4745   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
4746 }
4747 
4748 /* ffestd_S3P4 -- INCLUDE line
4749 
4750    ffestd_S3P4(filename,filename_token);
4751 
4752    Make sure INCLUDE not preceded by any semicolons or a label def; implement.	*/
4753 
4754 void
ffestd_S3P4(ffebld filename)4755 ffestd_S3P4 (ffebld filename)
4756 {
4757   FILE *fi;
4758   ffetargetCharacterDefault buildname;
4759   ffewhereFile wf;
4760 
4761   ffestd_check_simple_ ();
4762 
4763   assert (filename != NULL);
4764   if (ffebld_op (filename) != FFEBLD_opANY)
4765     {
4766       assert (ffebld_op (filename) == FFEBLD_opCONTER);
4767       assert (ffeinfo_basictype (ffebld_info (filename))
4768 	      == FFEINFO_basictypeCHARACTER);
4769       assert (ffeinfo_kindtype (ffebld_info (filename))
4770 	      == FFEINFO_kindtypeCHARACTERDEFAULT);
4771       buildname = ffebld_constant_characterdefault (ffebld_conter (filename));
4772       wf = ffewhere_file_new (ffetarget_text_characterdefault (buildname),
4773 			      ffetarget_length_characterdefault (buildname));
4774       fi = ffecom_open_include (ffewhere_file_name (wf),
4775 				ffelex_token_where_line (ffesta_tokens[0]),
4776 				ffelex_token_where_column (ffesta_tokens[0]));
4777       if (fi != NULL)
4778 	ffelex_set_include (wf, (ffelex_token_type (ffesta_tokens[0])
4779 				 == FFELEX_typeNAME), fi);
4780     }
4781 }
4782 
4783 /* ffestd_V003_start -- STRUCTURE statement list begin
4784 
4785    ffestd_V003_start(structure_name);
4786 
4787    Verify that STRUCTURE is valid here, and begin accepting items in the list.	*/
4788 
4789 #if FFESTR_VXT
4790 void
ffestd_V003_start(ffelexToken structure_name)4791 ffestd_V003_start (ffelexToken structure_name)
4792 {
4793   ffestd_check_start_ ();
4794   ffestd_subr_vxt_ ();
4795 }
4796 
4797 /* ffestd_V003_item -- STRUCTURE statement for object-name
4798 
4799    ffestd_V003_item(name_token,dim_list);
4800 
4801    Make sure name_token identifies a valid object to be STRUCTUREd.  */
4802 
4803 void
ffestd_V003_item(ffelexToken name,ffesttDimList dims)4804 ffestd_V003_item (ffelexToken name, ffesttDimList dims)
4805 {
4806   ffestd_check_item_ ();
4807 }
4808 
4809 /* ffestd_V003_finish -- STRUCTURE statement list complete
4810 
4811    ffestd_V003_finish();
4812 
4813    Just wrap up any local activities.  */
4814 
4815 void
ffestd_V003_finish()4816 ffestd_V003_finish ()
4817 {
4818   ffestd_check_finish_ ();
4819 }
4820 
4821 /* ffestd_V004 -- End a STRUCTURE
4822 
4823    ffestd_V004(TRUE);  */
4824 
4825 void
ffestd_V004(bool ok)4826 ffestd_V004 (bool ok)
4827 {
4828 }
4829 
4830 /* ffestd_V009 -- UNION statement
4831 
4832    ffestd_V009();  */
4833 
4834 void
ffestd_V009()4835 ffestd_V009 ()
4836 {
4837   ffestd_check_simple_ ();
4838 }
4839 
4840 /* ffestd_V010 -- End a UNION
4841 
4842    ffestd_V010(TRUE);  */
4843 
4844 void
ffestd_V010(bool ok)4845 ffestd_V010 (bool ok)
4846 {
4847 }
4848 
4849 /* ffestd_V012 -- MAP statement
4850 
4851    ffestd_V012();  */
4852 
4853 void
ffestd_V012()4854 ffestd_V012 ()
4855 {
4856   ffestd_check_simple_ ();
4857 }
4858 
4859 /* ffestd_V013 -- End a MAP
4860 
4861    ffestd_V013(TRUE);  */
4862 
4863 void
ffestd_V013(bool ok)4864 ffestd_V013 (bool ok)
4865 {
4866 }
4867 
4868 #endif
4869 /* ffestd_V014_start -- VOLATILE statement list begin
4870 
4871    ffestd_V014_start();
4872 
4873    Verify that VOLATILE is valid here, and begin accepting items in the list.  */
4874 
4875 void
ffestd_V014_start()4876 ffestd_V014_start ()
4877 {
4878   ffestd_check_start_ ();
4879 }
4880 
4881 /* ffestd_V014_item_object -- VOLATILE statement for object-name
4882 
4883    ffestd_V014_item_object(name_token);
4884 
4885    Make sure name_token identifies a valid object to be VOLATILEd.  */
4886 
4887 void
ffestd_V014_item_object(ffelexToken name UNUSED)4888 ffestd_V014_item_object (ffelexToken name UNUSED)
4889 {
4890   ffestd_check_item_ ();
4891 }
4892 
4893 /* ffestd_V014_item_cblock -- VOLATILE statement for common-block-name
4894 
4895    ffestd_V014_item_cblock(name_token);
4896 
4897    Make sure name_token identifies a valid common block to be VOLATILEd.  */
4898 
4899 void
ffestd_V014_item_cblock(ffelexToken name UNUSED)4900 ffestd_V014_item_cblock (ffelexToken name UNUSED)
4901 {
4902   ffestd_check_item_ ();
4903 }
4904 
4905 /* ffestd_V014_finish -- VOLATILE statement list complete
4906 
4907    ffestd_V014_finish();
4908 
4909    Just wrap up any local activities.  */
4910 
4911 void
ffestd_V014_finish()4912 ffestd_V014_finish ()
4913 {
4914   ffestd_check_finish_ ();
4915 }
4916 
4917 /* ffestd_V016_start -- RECORD statement list begin
4918 
4919    ffestd_V016_start();
4920 
4921    Verify that RECORD is valid here, and begin accepting items in the list.  */
4922 
4923 #if FFESTR_VXT
4924 void
ffestd_V016_start()4925 ffestd_V016_start ()
4926 {
4927   ffestd_check_start_ ();
4928 }
4929 
4930 /* ffestd_V016_item_structure -- RECORD statement for common-block-name
4931 
4932    ffestd_V016_item_structure(name_token);
4933 
4934    Make sure name_token identifies a valid structure to be RECORDed.  */
4935 
4936 void
ffestd_V016_item_structure(ffelexToken name)4937 ffestd_V016_item_structure (ffelexToken name)
4938 {
4939   ffestd_check_item_ ();
4940 }
4941 
4942 /* ffestd_V016_item_object -- RECORD statement for object-name
4943 
4944    ffestd_V016_item_object(name_token,dim_list);
4945 
4946    Make sure name_token identifies a valid object to be RECORDd.  */
4947 
4948 void
ffestd_V016_item_object(ffelexToken name,ffesttDimList dims)4949 ffestd_V016_item_object (ffelexToken name, ffesttDimList dims)
4950 {
4951   ffestd_check_item_ ();
4952 }
4953 
4954 /* ffestd_V016_finish -- RECORD statement list complete
4955 
4956    ffestd_V016_finish();
4957 
4958    Just wrap up any local activities.  */
4959 
4960 void
ffestd_V016_finish()4961 ffestd_V016_finish ()
4962 {
4963   ffestd_check_finish_ ();
4964 }
4965 
4966 /* ffestd_V018_start -- REWRITE(...) statement list begin
4967 
4968    ffestd_V018_start();
4969 
4970    Verify that REWRITE is valid here, and begin accepting items in the
4971    list.  */
4972 
4973 void
ffestd_V018_start(ffestvFormat format)4974 ffestd_V018_start (ffestvFormat format)
4975 {
4976   ffestd_check_start_ ();
4977   ffestd_subr_vxt_ ();
4978 }
4979 
4980 /* ffestd_V018_item -- REWRITE statement i/o item
4981 
4982    ffestd_V018_item(expr,expr_token);
4983 
4984    Implement output-list expression.  */
4985 
4986 void
ffestd_V018_item(ffebld expr)4987 ffestd_V018_item (ffebld expr)
4988 {
4989   ffestd_check_item_ ();
4990 }
4991 
4992 /* ffestd_V018_finish -- REWRITE statement list complete
4993 
4994    ffestd_V018_finish();
4995 
4996    Just wrap up any local activities.  */
4997 
4998 void
ffestd_V018_finish()4999 ffestd_V018_finish ()
5000 {
5001   ffestd_check_finish_ ();
5002 }
5003 
5004 /* ffestd_V019_start -- ACCEPT statement list begin
5005 
5006    ffestd_V019_start();
5007 
5008    Verify that ACCEPT is valid here, and begin accepting items in the
5009    list.  */
5010 
5011 void
ffestd_V019_start(ffestvFormat format)5012 ffestd_V019_start (ffestvFormat format)
5013 {
5014   ffestd_check_start_ ();
5015   ffestd_subr_vxt_ ();
5016 }
5017 
5018 /* ffestd_V019_item -- ACCEPT statement i/o item
5019 
5020    ffestd_V019_item(expr,expr_token);
5021 
5022    Implement output-list expression.  */
5023 
5024 void
ffestd_V019_item(ffebld expr)5025 ffestd_V019_item (ffebld expr)
5026 {
5027   ffestd_check_item_ ();
5028 }
5029 
5030 /* ffestd_V019_finish -- ACCEPT statement list complete
5031 
5032    ffestd_V019_finish();
5033 
5034    Just wrap up any local activities.  */
5035 
5036 void
ffestd_V019_finish()5037 ffestd_V019_finish ()
5038 {
5039   ffestd_check_finish_ ();
5040 }
5041 
5042 #endif
5043 /* ffestd_V020_start -- TYPE statement list begin
5044 
5045    ffestd_V020_start();
5046 
5047    Verify that TYPE is valid here, and begin accepting items in the
5048    list.  */
5049 
5050 void
ffestd_V020_start(ffestvFormat format UNUSED)5051 ffestd_V020_start (ffestvFormat format UNUSED)
5052 {
5053   ffestd_check_start_ ();
5054   ffestd_subr_vxt_ ();
5055 }
5056 
5057 /* ffestd_V020_item -- TYPE statement i/o item
5058 
5059    ffestd_V020_item(expr,expr_token);
5060 
5061    Implement output-list expression.  */
5062 
5063 void
ffestd_V020_item(ffebld expr UNUSED)5064 ffestd_V020_item (ffebld expr UNUSED)
5065 {
5066   ffestd_check_item_ ();
5067 }
5068 
5069 /* ffestd_V020_finish -- TYPE statement list complete
5070 
5071    ffestd_V020_finish();
5072 
5073    Just wrap up any local activities.  */
5074 
5075 void
ffestd_V020_finish()5076 ffestd_V020_finish ()
5077 {
5078   ffestd_check_finish_ ();
5079 }
5080 
5081 /* ffestd_V021 -- DELETE statement
5082 
5083    ffestd_V021();
5084 
5085    Make sure a DELETE is valid in the current context, and implement it.  */
5086 
5087 #if FFESTR_VXT
5088 void
ffestd_V021()5089 ffestd_V021 ()
5090 {
5091   ffestd_check_simple_ ();
5092   ffestd_subr_vxt_ ();
5093 }
5094 
5095 /* ffestd_V022 -- UNLOCK statement
5096 
5097    ffestd_V022();
5098 
5099    Make sure a UNLOCK is valid in the current context, and implement it.  */
5100 
5101 void
ffestd_V022()5102 ffestd_V022 ()
5103 {
5104   ffestd_check_simple_ ();
5105   ffestd_subr_vxt_ ();
5106 }
5107 
5108 /* ffestd_V023_start -- ENCODE(...) statement list begin
5109 
5110    ffestd_V023_start();
5111 
5112    Verify that ENCODE is valid here, and begin accepting items in the
5113    list.  */
5114 
5115 void
ffestd_V023_start()5116 ffestd_V023_start ()
5117 {
5118   ffestd_check_start_ ();
5119   ffestd_subr_vxt_ ();
5120 }
5121 
5122 /* ffestd_V023_item -- ENCODE statement i/o item
5123 
5124    ffestd_V023_item(expr,expr_token);
5125 
5126    Implement output-list expression.  */
5127 
5128 void
ffestd_V023_item(ffebld expr)5129 ffestd_V023_item (ffebld expr)
5130 {
5131   ffestd_check_item_ ();
5132 }
5133 
5134 /* ffestd_V023_finish -- ENCODE statement list complete
5135 
5136    ffestd_V023_finish();
5137 
5138    Just wrap up any local activities.  */
5139 
5140 void
ffestd_V023_finish()5141 ffestd_V023_finish ()
5142 {
5143   ffestd_check_finish_ ();
5144 }
5145 
5146 /* ffestd_V024_start -- DECODE(...) statement list begin
5147 
5148    ffestd_V024_start();
5149 
5150    Verify that DECODE is valid here, and begin accepting items in the
5151    list.  */
5152 
5153 void
ffestd_V024_start()5154 ffestd_V024_start ()
5155 {
5156   ffestd_check_start_ ();
5157   ffestd_subr_vxt_ ();
5158 }
5159 
5160 /* ffestd_V024_item -- DECODE statement i/o item
5161 
5162    ffestd_V024_item(expr,expr_token);
5163 
5164    Implement output-list expression.  */
5165 
5166 void
ffestd_V024_item(ffebld expr)5167 ffestd_V024_item (ffebld expr)
5168 {
5169   ffestd_check_item_ ();
5170 }
5171 
5172 /* ffestd_V024_finish -- DECODE statement list complete
5173 
5174    ffestd_V024_finish();
5175 
5176    Just wrap up any local activities.  */
5177 
5178 void
ffestd_V024_finish()5179 ffestd_V024_finish ()
5180 {
5181   ffestd_check_finish_ ();
5182 }
5183 
5184 /* ffestd_V025_start -- DEFINEFILE statement list begin
5185 
5186    ffestd_V025_start();
5187 
5188    Verify that DEFINEFILE is valid here, and begin accepting items in the
5189    list.  */
5190 
5191 void
ffestd_V025_start()5192 ffestd_V025_start ()
5193 {
5194   ffestd_check_start_ ();
5195   ffestd_subr_vxt_ ();
5196 }
5197 
5198 /* ffestd_V025_item -- DEFINE FILE statement item
5199 
5200    ffestd_V025_item(u,ut,m,mt,n,nt,asv,asvt);
5201 
5202    Implement item.  Treat each item kind of like a separate statement,
5203    since there's really no need to treat them as an aggregate.	*/
5204 
5205 void
ffestd_V025_item(ffebld u,ffebld m,ffebld n,ffebld asv)5206 ffestd_V025_item (ffebld u, ffebld m, ffebld n, ffebld asv)
5207 {
5208   ffestd_check_item_ ();
5209 }
5210 
5211 /* ffestd_V025_finish -- DEFINE FILE statement list complete
5212 
5213    ffestd_V025_finish();
5214 
5215    Just wrap up any local activities.  */
5216 
5217 void
ffestd_V025_finish()5218 ffestd_V025_finish ()
5219 {
5220   ffestd_check_finish_ ();
5221 }
5222 
5223 /* ffestd_V026 -- FIND statement
5224 
5225    ffestd_V026();
5226 
5227    Make sure a FIND is valid in the current context, and implement it.	*/
5228 
5229 void
ffestd_V026()5230 ffestd_V026 ()
5231 {
5232   ffestd_check_simple_ ();
5233   ffestd_subr_vxt_ ();
5234 }
5235 
5236 #endif
5237 /* ffestd_V027_start -- VXT PARAMETER statement list begin
5238 
5239    ffestd_V027_start();
5240 
5241    Verify that PARAMETER is valid here, and begin accepting items in the list.	*/
5242 
5243 void
ffestd_V027_start()5244 ffestd_V027_start ()
5245 {
5246   ffestd_check_start_ ();
5247   ffestd_subr_vxt_ ();
5248 }
5249 
5250 /* ffestd_V027_item -- VXT PARAMETER statement assignment
5251 
5252    ffestd_V027_item(dest,dest_token,source,source_token);
5253 
5254    Make sure the source is a valid source for the destination; make the
5255    assignment.	*/
5256 
5257 void
ffestd_V027_item(ffelexToken dest_token UNUSED,ffebld source UNUSED)5258 ffestd_V027_item (ffelexToken dest_token UNUSED, ffebld source UNUSED)
5259 {
5260   ffestd_check_item_ ();
5261 }
5262 
5263 /* ffestd_V027_finish -- VXT PARAMETER statement list complete
5264 
5265    ffestd_V027_finish();
5266 
5267    Just wrap up any local activities.  */
5268 
5269 void
ffestd_V027_finish()5270 ffestd_V027_finish ()
5271 {
5272   ffestd_check_finish_ ();
5273 }
5274 
5275 /* Any executable statement.  */
5276 
5277 void
ffestd_any()5278 ffestd_any ()
5279 {
5280   ffestdStmt_ stmt;
5281 
5282   ffestd_check_simple_ ();
5283 
5284   stmt = ffestd_stmt_new_ (FFESTD_stmtidR841_);
5285   ffestd_stmt_append_ (stmt);
5286   ffestd_subr_line_save_ (stmt);
5287 }
5288