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