]> gcc.gnu.org Git - gcc.git/blame - gcc/f/std.c
git://gcc.gnu.org / gcc.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
�
[gcc.git] / gcc / f / std.c
CommitLineData
5ff904cd
JL		 1/* std.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995, 1996 Free Software Foundation, Inc.
3 Contributed by James Craig Burley (burley@gnu.ai.mit.edu).
4
5This file is part of GNU Fortran.
6
7GNU Fortran is free software; you can redistribute it and/or modify
8it under the terms of the GNU General Public License as published by
9the Free Software Foundation; either version 2, or (at your option)
10any later version.
11
12GNU Fortran is distributed in the hope that it will be useful,
13but WITHOUT ANY WARRANTY; without even the implied warranty of
14MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15GNU General Public License for more details.
16
17You should have received a copy of the GNU General Public License
18along with GNU Fortran; see the file COPYING. If not, write to
19the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
2002111-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
63typedef 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#if FFECOM_TWOPASS
73typedef enum
74 {
75 FFESTD_stmtidENDDOLOOP_,
76 FFESTD_stmtidENDLOGIF_,
77 FFESTD_stmtidEXECLABEL_,
78 FFESTD_stmtidFORMATLABEL_,
79 FFESTD_stmtidR737A_, /* let */
80 FFESTD_stmtidR803_, /* IF-block */
81 FFESTD_stmtidR804_, /* ELSE IF */
82 FFESTD_stmtidR805_, /* ELSE */
83 FFESTD_stmtidR806_, /* END IF */
84 FFESTD_stmtidR807_, /* IF-logical */
85 FFESTD_stmtidR809_, /* SELECT CASE */
86 FFESTD_stmtidR810_, /* CASE */
87 FFESTD_stmtidR811_, /* END SELECT */
88 FFESTD_stmtidR819A_, /* DO-iterative */
89 FFESTD_stmtidR819B_, /* DO WHILE */
90 FFESTD_stmtidR825_, /* END DO */
91 FFESTD_stmtidR834_, /* CYCLE */
92 FFESTD_stmtidR835_, /* EXIT */
93 FFESTD_stmtidR836_, /* GOTO */
94 FFESTD_stmtidR837_, /* GOTO-computed */
95 FFESTD_stmtidR838_, /* ASSIGN */
96 FFESTD_stmtidR839_, /* GOTO-assigned */
97 FFESTD_stmtidR840_, /* IF-arithmetic */
98 FFESTD_stmtidR841_, /* CONTINUE */
99 FFESTD_stmtidR842_, /* STOP */
100 FFESTD_stmtidR843_, /* PAUSE */
101 FFESTD_stmtidR904_, /* OPEN */
102 FFESTD_stmtidR907_, /* CLOSE */
103 FFESTD_stmtidR909_, /* READ */
104 FFESTD_stmtidR910_, /* WRITE */
105 FFESTD_stmtidR911_, /* PRINT */
106 FFESTD_stmtidR919_, /* BACKSPACE */
107 FFESTD_stmtidR920_, /* ENDFILE */
108 FFESTD_stmtidR921_, /* REWIND */
109 FFESTD_stmtidR923A_, /* INQUIRE */
110 FFESTD_stmtidR923B_, /* INQUIRE-iolength */
111 FFESTD_stmtidR1001_, /* FORMAT */
112 FFESTD_stmtidR1103_, /* END_PROGRAM */
113 FFESTD_stmtidR1112_, /* END_BLOCK_DATA */
114 FFESTD_stmtidR1212_, /* CALL */
115 FFESTD_stmtidR1221_, /* END_FUNCTION */
116 FFESTD_stmtidR1225_, /* END_SUBROUTINE */
117 FFESTD_stmtidR1226_, /* ENTRY */
118 FFESTD_stmtidR1227_, /* RETURN */
119#if FFESTR_VXT
120 FFESTD_stmtidV018_, /* REWRITE */
121 FFESTD_stmtidV019_, /* ACCEPT */
122#endif
123 FFESTD_stmtidV020_, /* TYPE */
124#if FFESTR_VXT
125 FFESTD_stmtidV021_, /* DELETE */
126 FFESTD_stmtidV022_, /* UNLOCK */
127 FFESTD_stmtidV023_, /* ENCODE */
128 FFESTD_stmtidV024_, /* DECODE */
129 FFESTD_stmtidV025start_, /* DEFINEFILE (start) */
130 FFESTD_stmtidV025item_, /* (DEFINEFILE item) */
131 FFESTD_stmtidV025finish_, /* (DEFINEFILE finish) */
132 FFESTD_stmtidV026_, /* FIND */
133#endif
134 FFESTD_stmtid_,
135 } ffestdStmtId_;
136
137#endif
138
139/* Internal typedefs. */
140
141typedef struct _ffestd_expr_item_ *ffestdExprItem_;
142#if FFECOM_TWOPASS
143typedef struct _ffestd_stmt_ *ffestdStmt_;
144#endif
145
146/* Private include files. */
147
148
149/* Internal structure definitions. */
150
151struct _ffestd_expr_item_
152 {
153 ffestdExprItem_ next;
154 ffebld expr;
155 ffelexToken token;
156 };
157
158#if FFECOM_TWOPASS
159struct _ffestd_stmt_
160 {
161 ffestdStmt_ next;
162 ffestdStmt_ previous;
163 ffestdStmtId_ id;
164#if FFECOM_targetCURRENT == FFECOM_targetGCC
165 char *filename;
166 int filelinenum;
167#endif
168 union
169 {
170 struct
171 {
172 ffestw block;
173 }
174 enddoloop;
175 struct
176 {
177 ffelab label;
178 }
179 execlabel;
180 struct
181 {
182 ffelab label;
183 }
184 formatlabel;
185 struct
186 {
187 mallocPool pool;
188 ffebld dest;
189 ffebld source;
190 }
191 R737A;
192 struct
193 {
194 mallocPool pool;
195 ffebld expr;
196 }
197 R803;
198 struct
199 {
200 mallocPool pool;
201 ffebld expr;
202 }
203 R804;
204 struct
205 {
206 mallocPool pool;
207 ffebld expr;
208 }
209 R807;
210 struct
211 {
212 mallocPool pool;
213 ffestw block;
214 ffebld expr;
215 }
216 R809;
217 struct
218 {
219 mallocPool pool;
220 ffestw block;
221 unsigned long casenum;
222 }
223 R810;
224 struct
225 {
226 ffestw block;
227 }
228 R811;
229 struct
230 {
231 mallocPool pool;
232 ffestw block;
233 ffelab label;
234 ffebld var;
235 ffebld start;
236 ffelexToken start_token;
237 ffebld end;
238 ffelexToken end_token;
239 ffebld incr;
240 ffelexToken incr_token;
241 }
242 R819A;
243 struct
244 {
245 mallocPool pool;
246 ffestw block;
247 ffelab label;
248 ffebld expr;
249 }
250 R819B;
251 struct
252 {
253 ffestw block;
254 }
255 R834;
256 struct
257 {
258 ffestw block;
259 }
260 R835;
261 struct
262 {
263 ffelab label;
264 }
265 R836;
266 struct
267 {
268 mallocPool pool;
269 ffelab *labels;
270 int count;
271 ffebld expr;
272 }
273 R837;
274 struct
275 {
276 mallocPool pool;
277 ffelab label;
278 ffebld target;
279 }
280 R838;
281 struct
282 {
283 mallocPool pool;
284 ffebld target;
285 }
286 R839;
287 struct
288 {
289 mallocPool pool;
290 ffebld expr;
291 ffelab neg;
292 ffelab zero;
293 ffelab pos;
294 }
295 R840;
296 struct
297 {
298 mallocPool pool;
299 ffebld expr;
300 }
301 R842;
302 struct
303 {
304 mallocPool pool;
305 ffebld expr;
306 }
307 R843;
308 struct
309 {
310 mallocPool pool;
311 ffestpOpenStmt *params;
312 }
313 R904;
314 struct
315 {
316 mallocPool pool;
317 ffestpCloseStmt *params;
318 }
319 R907;
320 struct
321 {
322 mallocPool pool;
323 ffestpReadStmt *params;
324 bool only_format;
325 ffestvUnit unit;
326 ffestvFormat format;
327 bool rec;
328 bool key;
329 ffestdExprItem_ list;
330 }
331 R909;
332 struct
333 {
334 mallocPool pool;
335 ffestpWriteStmt *params;
336 ffestvUnit unit;
337 ffestvFormat format;
338 bool rec;
339 ffestdExprItem_ list;
340 }
341 R910;
342 struct
343 {
344 mallocPool pool;
345 ffestpPrintStmt *params;
346 ffestvFormat format;
347 ffestdExprItem_ list;
348 }
349 R911;
350 struct
351 {
352 mallocPool pool;
353 ffestpBeruStmt *params;
354 }
355 R919;
356 struct
357 {
358 mallocPool pool;
359 ffestpBeruStmt *params;
360 }
361 R920;
362 struct
363 {
364 mallocPool pool;
365 ffestpBeruStmt *params;
366 }
367 R921;
368 struct
369 {
370 mallocPool pool;
371 ffestpInquireStmt *params;
372 bool by_file;
373 }
374 R923A;
375 struct
376 {
377 mallocPool pool;
378 ffestpInquireStmt *params;
379 ffestdExprItem_ list;
380 }
381 R923B;
382 struct
383 {
384 ffestsHolder str;
385 }
386 R1001;
387 struct
388 {
389 mallocPool pool;
390 ffebld expr;
391 }
392 R1212;
393 struct
394 {
395 ffesymbol entry;
396 int entrynum;
397 }
398 R1226;
399 struct
400 {
401 mallocPool pool;
402 ffestw block;
403 ffebld expr;
404 }
405 R1227;
406#if FFESTR_VXT
407 struct
408 {
409 mallocPool pool;
410 ffestpRewriteStmt *params;
411 ffestvFormat format;
412 ffestdExprItem_ list;
413 }
414 V018;
415 struct
416 {
417 mallocPool pool;
418 ffestpAcceptStmt *params;
419 ffestvFormat format;
420 ffestdExprItem_ list;
421 }
422 V019;
423#endif
424 struct
425 {
426 mallocPool pool;
427 ffestpTypeStmt *params;
428 ffestvFormat format;
429 ffestdExprItem_ list;
430 }
431 V020;
432#if FFESTR_VXT
433 struct
434 {
435 mallocPool pool;
436 ffestpDeleteStmt *params;
437 }
438 V021;
439 struct
440 {
441 mallocPool pool;
442 ffestpBeruStmt *params;
443 }
444 V022;
445 struct
446 {
447 mallocPool pool;
448 ffestpVxtcodeStmt *params;
449 ffestdExprItem_ list;
450 }
451 V023;
452 struct
453 {
454 mallocPool pool;
455 ffestpVxtcodeStmt *params;
456 ffestdExprItem_ list;
457 }
458 V024;
459 struct
460 {
461 ffebld u;
462 ffebld m;
463 ffebld n;
464 ffebld asv;
465 }
466 V025item;
467 struct
468 {
469 mallocPool pool;
470 } V025finish;
471 struct
472 {
473 mallocPool pool;
474 ffestpFindStmt *params;
475 }
476 V026;
477#endif
478 }
479 u;
480 };
481
482#endif
483
484/* Static objects accessed by functions in this module. */
485
486static ffestdStatelet_ ffestd_statelet_ = FFESTD_stateletSIMPLE_;
487static int ffestd_block_level_ = 0; /* Block level for reachableness. */
488static bool ffestd_is_reachable_; /* Is the current stmt reachable? */
489static ffelab ffestd_label_formatdef_ = NULL;
490#if FFECOM_TWOPASS
491static ffestdExprItem_ *ffestd_expr_list_;
492static struct
493 {
494 ffestdStmt_ first;
495 ffestdStmt_ last;
496 }
497
498ffestd_stmt_list_
499=
500{
501 NULL, NULL
502};
503
504#endif
505#if FFECOM_targetCURRENT == FFECOM_targetGCC
506static int ffestd_2pass_entrypoints_ = 0; /* # ENTRY statements
507 pending. */
508#endif
509
510/* Static functions (internal). */
511
512#if FFECOM_TWOPASS
513static void ffestd_stmt_append_ (ffestdStmt_ stmt);
514static ffestdStmt_ ffestd_stmt_new_ (ffestdStmtId_ id);
515static void ffestd_stmt_pass_ (void);
516#endif
517#if FFESTD_COPY_EASY_ && FFECOM_TWOPASS
518static ffestpInquireStmt *ffestd_subr_copy_easy_ (ffestpInquireIx max);
519#endif
520#if FFECOM_targetCURRENT == FFECOM_targetGCC
521static void ffestd_subr_vxt_ (void);
522#endif
523#if FFESTR_F90
524static void ffestd_subr_f90_ (void);
525#endif
526static void ffestd_subr_labels_ (bool unexpected);
527static void ffestd_R1001dump_ (ffests s, ffesttFormatList list);
528static void ffestd_R1001dump_1005_1_ (ffests s, ffesttFormatList f,
529 char *string);
530static void ffestd_R1001dump_1005_2_ (ffests s, ffesttFormatList f,
531 char *string);
532static void ffestd_R1001dump_1005_3_ (ffests s, ffesttFormatList f,
533 char *string);
534static void ffestd_R1001dump_1005_4_ (ffests s, ffesttFormatList f,
535 char *string);
536static void ffestd_R1001dump_1005_5_ (ffests s, ffesttFormatList f,
537 char *string);
538static void ffestd_R1001dump_1010_1_ (ffests s, ffesttFormatList f,
539 char *string);
540static void ffestd_R1001dump_1010_2_ (ffests s, ffesttFormatList f,
541 char *string);
542static void ffestd_R1001dump_1010_3_ (ffests s, ffesttFormatList f,
543 char *string);
544static void ffestd_R1001dump_1010_4_ (ffests s, ffesttFormatList f,
545 char *string);
546static void ffestd_R1001dump_1010_5_ (ffests s, ffesttFormatList f,
547 char *string);
548static void ffestd_R1001error_ (ffesttFormatList f);
549
550/* Internal macros. */
551
552#if FFECOM_targetCURRENT == FFECOM_targetGCC
553#define ffestd_subr_line_now_() \
554 ffeste_set_line (ffelex_token_where_filename (ffesta_tokens[0]), \
555 ffelex_token_where_filelinenum (ffesta_tokens[0]))
556#define ffestd_subr_line_restore_(s) \
557 ffeste_set_line ((s)->filename, (s)->filelinenum)
558#define ffestd_subr_line_save_(s) \
559 ((s)->filename = ffelex_token_where_filename (ffesta_tokens[0]), \
560 (s)->filelinenum = ffelex_token_where_filelinenum (ffesta_tokens[0]))
561#else
562#define ffestd_subr_line_now_()
563#if FFECOM_TWOPASS
564#define ffestd_subr_line_restore_(s)
565#define ffestd_subr_line_save_(s)
566#endif /* FFECOM_TWOPASS */
567#endif /* FFECOM_targetCURRENT != FFECOM_targetGCC */
568#define ffestd_check_simple_() \
569 assert(ffestd_statelet_ == FFESTD_stateletSIMPLE_)
570#define ffestd_check_start_() \
571 assert(ffestd_statelet_ == FFESTD_stateletSIMPLE_); \
572 ffestd_statelet_ = FFESTD_stateletATTRIB_
573#define ffestd_check_attrib_() \
574 assert(ffestd_statelet_ == FFESTD_stateletATTRIB_)
575#define ffestd_check_item_() \
576 assert(ffestd_statelet_ == FFESTD_stateletATTRIB_ \
577 || ffestd_statelet_ == FFESTD_stateletITEM_); \
578 ffestd_statelet_ = FFESTD_stateletITEM_
579#define ffestd_check_item_startvals_() \
580 assert(ffestd_statelet_ == FFESTD_stateletATTRIB_ \
581 || ffestd_statelet_ == FFESTD_stateletITEM_); \
582 ffestd_statelet_ = FFESTD_stateletITEMVALS_
583#define ffestd_check_item_value_() \
584 assert(ffestd_statelet_ == FFESTD_stateletITEMVALS_)
585#define ffestd_check_item_endvals_() \
586 assert(ffestd_statelet_ == FFESTD_stateletITEMVALS_); \
587 ffestd_statelet_ = FFESTD_stateletITEM_
588#define ffestd_check_finish_() \
589 assert(ffestd_statelet_ == FFESTD_stateletATTRIB_ \
590 || ffestd_statelet_ == FFESTD_stateletITEM_); \
591 ffestd_statelet_ = FFESTD_stateletSIMPLE_
592
593#if FFESTD_COPY_EASY_ && FFECOM_TWOPASS
594#define ffestd_subr_copy_accept_() (ffestpAcceptStmt *) \
595 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_acceptix)
596#define ffestd_subr_copy_beru_() (ffestpBeruStmt *) \
597 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_beruix)
598#define ffestd_subr_copy_close_() (ffestpCloseStmt *) \
599 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_closeix)
600#define ffestd_subr_copy_delete_() (ffestpDeleteStmt *) \
601 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_deleteix)
602#define ffestd_subr_copy_find_() (ffestpFindStmt *) \
603 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_findix)
604#define ffestd_subr_copy_inquire_() (ffestpInquireStmt *) \
605 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_inquireix)
606#define ffestd_subr_copy_open_() (ffestpOpenStmt *) \
607 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_openix)
608#define ffestd_subr_copy_print_() (ffestpPrintStmt *) \
609 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_printix)
610#define ffestd_subr_copy_read_() (ffestpReadStmt *) \
611 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_readix)
612#define ffestd_subr_copy_rewrite_() (ffestpRewriteStmt *) \
613 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_rewriteix)
614#define ffestd_subr_copy_type_() (ffestpTypeStmt *) \
615 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_typeix)
616#define ffestd_subr_copy_vxtcode_() (ffestpVxtcodeStmt *) \
617 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_vxtcodeix)
618#define ffestd_subr_copy_write_() (ffestpWriteStmt *) \
619 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_writeix)
620#endif
621\f
622/* ffestd_stmt_append_ -- Append statement to end of stmt list
623
624 ffestd_stmt_append_(ffestd_stmt_new_(FFESTD_stmtidR737A_)); */
625
626#if FFECOM_TWOPASS
627static void
628ffestd_stmt_append_ (ffestdStmt_ stmt)
629{
630 stmt->next = (ffestdStmt_) &ffestd_stmt_list_.first;
631 stmt->previous = ffestd_stmt_list_.last;
632 stmt->next->previous = stmt;
633 stmt->previous->next = stmt;
634}
635
636#endif
637/* ffestd_stmt_new_ -- Make new statement with given id
638
639 ffestdStmt_ stmt;
640 stmt = ffestd_stmt_new_(FFESTD_stmtidR737A_); */
641
642#if FFECOM_TWOPASS
643static ffestdStmt_
644ffestd_stmt_new_ (ffestdStmtId_ id)
645{
646 ffestdStmt_ stmt;
647
648 stmt = malloc_new_kp (ffe_pool_any_unit (), "ffestdStmt_", sizeof (*stmt));
649 stmt->id = id;
650 return stmt;
651}
652
653#endif
654/* ffestd_stmt_pass_ -- Pass all statements on list to ffeste
655
656 ffestd_stmt_pass_(); */
657
658#if FFECOM_TWOPASS
659static void
660ffestd_stmt_pass_ ()
661{
662 ffestdStmt_ stmt;
663 ffestdExprItem_ expr; /* For traversing lists. */
664
665#if FFECOM_targetCURRENT == FFECOM_targetGCC
666 if (ffestd_2pass_entrypoints_ != 0)
667 {
668 tree which = ffecom_which_entrypoint_decl ();
669 tree value;
670 tree label;
671 int pushok;
672 int ents = ffestd_2pass_entrypoints_;
673 tree duplicate;
674
675 expand_start_case (0, which, TREE_TYPE (which), "entrypoint dispatch");
676 push_momentary ();
677
678 stmt = ffestd_stmt_list_.first;
679 do
680 {
681 while (stmt->id != FFESTD_stmtidR1226_)
682 stmt = stmt->next;
683
684 if (stmt->u.R1226.entry != NULL)
685 {
686 value = build_int_2 (stmt->u.R1226.entrynum, 0);
687 /* Yes, we really want to build a null LABEL_DECL here and not
688 put it on any list. That's what pushcase wants, so that's
689 what it gets! */
690 label = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
691
692 pushok = pushcase (value, convert, label, &duplicate);
693 assert (pushok == 0);
694
695 label = ffecom_temp_label ();
696 TREE_USED (label) = 1;
697 expand_goto (label);
698 clear_momentary ();
699
700 ffesymbol_hook (stmt->u.R1226.entry).length_tree = label;
701 }
702 stmt = stmt->next;
703 }
704 while (--ents != 0);
705
706 pop_momentary ();
707 expand_end_case (which);
708 clear_momentary ();
709 }
710#endif
711
712 for (stmt = ffestd_stmt_list_.first;
713 stmt != (ffestdStmt_) &ffestd_stmt_list_.first;
714 stmt = stmt->next)
715 {
716 switch (stmt->id)
717 {
718 case FFESTD_stmtidENDDOLOOP_:
719 ffestd_subr_line_restore_ (stmt);
720 ffeste_do (stmt->u.enddoloop.block);
721 ffestw_kill (stmt->u.enddoloop.block);
722 break;
723
724 case FFESTD_stmtidENDLOGIF_:
725 ffestd_subr_line_restore_ (stmt);
726 ffeste_end_R807 ();
727 break;
728
729 case FFESTD_stmtidEXECLABEL_:
730 ffeste_labeldef_branch (stmt->u.execlabel.label);
731 break;
732
733 case FFESTD_stmtidFORMATLABEL_:
734 ffeste_labeldef_format (stmt->u.formatlabel.label);
735 break;
736
737 case FFESTD_stmtidR737A_:
738 ffestd_subr_line_restore_ (stmt);
739 ffeste_R737A (stmt->u.R737A.dest, stmt->u.R737A.source);
740 malloc_pool_kill (stmt->u.R737A.pool);
741 break;
742
743 case FFESTD_stmtidR803_:
744 ffestd_subr_line_restore_ (stmt);
745 ffeste_R803 (stmt->u.R803.expr);
746 malloc_pool_kill (stmt->u.R803.pool);
747 break;
748
749 case FFESTD_stmtidR804_:
750 ffestd_subr_line_restore_ (stmt);
751 ffeste_R804 (stmt->u.R804.expr);
752 malloc_pool_kill (stmt->u.R804.pool);
753 break;
754
755 case FFESTD_stmtidR805_:
756 ffestd_subr_line_restore_ (stmt);
757 ffeste_R805 ();
758 break;
759
760 case FFESTD_stmtidR806_:
761 ffestd_subr_line_restore_ (stmt);
762 ffeste_R806 ();
763 break;
764
765 case FFESTD_stmtidR807_:
766 ffestd_subr_line_restore_ (stmt);
767 ffeste_R807 (stmt->u.R807.expr);
768 malloc_pool_kill (stmt->u.R807.pool);
769 break;
770
771 case FFESTD_stmtidR809_:
772 ffestd_subr_line_restore_ (stmt);
773 ffeste_R809 (stmt->u.R809.block, stmt->u.R809.expr);
774 malloc_pool_kill (stmt->u.R809.pool);
775 break;
776
777 case FFESTD_stmtidR810_:
778 ffestd_subr_line_restore_ (stmt);
779 ffeste_R810 (stmt->u.R810.block, stmt->u.R810.casenum);
780 malloc_pool_kill (stmt->u.R810.pool);
781 break;
782
783 case FFESTD_stmtidR811_:
784 ffestd_subr_line_restore_ (stmt);
785 ffeste_R811 (stmt->u.R811.block);
786 malloc_pool_kill (ffestw_select (stmt->u.R811.block)->pool);
787 ffestw_kill (stmt->u.R811.block);
788 break;
789
790 case FFESTD_stmtidR819A_:
791 ffestd_subr_line_restore_ (stmt);
792 ffeste_R819A (stmt->u.R819A.block, stmt->u.R819A.label,
793 stmt->u.R819A.var,
794 stmt->u.R819A.start, stmt->u.R819A.start_token,
795 stmt->u.R819A.end, stmt->u.R819A.end_token,
796 stmt->u.R819A.incr, stmt->u.R819A.incr_token);
797 ffelex_token_kill (stmt->u.R819A.start_token);
798 ffelex_token_kill (stmt->u.R819A.end_token);
799 if (stmt->u.R819A.incr_token != NULL)
800 ffelex_token_kill (stmt->u.R819A.incr_token);
801 malloc_pool_kill (stmt->u.R819A.pool);
802 break;
803
804 case FFESTD_stmtidR819B_:
805 ffestd_subr_line_restore_ (stmt);
806 ffeste_R819B (stmt->u.R819B.block, stmt->u.R819B.label,
807 stmt->u.R819B.expr);
808 malloc_pool_kill (stmt->u.R819B.pool);
809 break;
810
811 case FFESTD_stmtidR825_:
812 ffestd_subr_line_restore_ (stmt);
813 ffeste_R825 ();
814 break;
815
816 case FFESTD_stmtidR834_:
817 ffestd_subr_line_restore_ (stmt);
818 ffeste_R834 (stmt->u.R834.block);
819 break;
820
821 case FFESTD_stmtidR835_:
822 ffestd_subr_line_restore_ (stmt);
823 ffeste_R835 (stmt->u.R835.block);
824 break;
825
826 case FFESTD_stmtidR836_:
827 ffestd_subr_line_restore_ (stmt);
828 ffeste_R836 (stmt->u.R836.label);
829 break;
830
831 case FFESTD_stmtidR837_:
832 ffestd_subr_line_restore_ (stmt);
833 ffeste_R837 (stmt->u.R837.labels, stmt->u.R837.count,
834 stmt->u.R837.expr);
835 malloc_pool_kill (stmt->u.R837.pool);
836 break;
837
838 case FFESTD_stmtidR838_:
839 ffestd_subr_line_restore_ (stmt);
840 ffeste_R838 (stmt->u.R838.label, stmt->u.R838.target);
841 malloc_pool_kill (stmt->u.R838.pool);
842 break;
843
844 case FFESTD_stmtidR839_:
845 ffestd_subr_line_restore_ (stmt);
846 ffeste_R839 (stmt->u.R839.target);
847 malloc_pool_kill (stmt->u.R839.pool);
848 break;
849
850 case FFESTD_stmtidR840_:
851 ffestd_subr_line_restore_ (stmt);
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 ffeste_R841 ();
860 break;
861
862 case FFESTD_stmtidR842_:
863 ffestd_subr_line_restore_ (stmt);
864 ffeste_R842 (stmt->u.R842.expr);
865 malloc_pool_kill (stmt->u.R842.pool);
866 break;
867
868 case FFESTD_stmtidR843_:
869 ffestd_subr_line_restore_ (stmt);
870 ffeste_R843 (stmt->u.R843.expr);
871 malloc_pool_kill (stmt->u.R843.pool);
872 break;
873
874 case FFESTD_stmtidR904_:
875 ffestd_subr_line_restore_ (stmt);
876 ffeste_R904 (stmt->u.R904.params);
877 malloc_pool_kill (stmt->u.R904.pool);
878 break;
879
880 case FFESTD_stmtidR907_:
881 ffestd_subr_line_restore_ (stmt);
882 ffeste_R907 (stmt->u.R907.params);
883 malloc_pool_kill (stmt->u.R907.pool);
884 break;
885
886 case FFESTD_stmtidR909_:
887 ffestd_subr_line_restore_ (stmt);
888 ffeste_R909_start (stmt->u.R909.params, stmt->u.R909.only_format,
889 stmt->u.R909.unit, stmt->u.R909.format,
890 stmt->u.R909.rec, stmt->u.R909.key);
891 for (expr = stmt->u.R909.list; expr != NULL; expr = expr->next)
892 {
893 ffeste_R909_item (expr->expr, expr->token);
894 ffelex_token_kill (expr->token);
895 }
896 ffeste_R909_finish ();
897 malloc_pool_kill (stmt->u.R909.pool);
898 break;
899
900 case FFESTD_stmtidR910_:
901 ffestd_subr_line_restore_ (stmt);
902 ffeste_R910_start (stmt->u.R910.params, stmt->u.R910.unit,
903 stmt->u.R910.format, stmt->u.R910.rec);
904 for (expr = stmt->u.R910.list; expr != NULL; expr = expr->next)
905 {
906 ffeste_R910_item (expr->expr, expr->token);
907 ffelex_token_kill (expr->token);
908 }
909 ffeste_R910_finish ();
910 malloc_pool_kill (stmt->u.R910.pool);
911 break;
912
913 case FFESTD_stmtidR911_:
914 ffestd_subr_line_restore_ (stmt);
915 ffeste_R911_start (stmt->u.R911.params, stmt->u.R911.format);
916 for (expr = stmt->u.R911.list; expr != NULL; expr = expr->next)
917 {
918 ffeste_R911_item (expr->expr, expr->token);
919 ffelex_token_kill (expr->token);
920 }
921 ffeste_R911_finish ();
922 malloc_pool_kill (stmt->u.R911.pool);
923 break;
924
925 case FFESTD_stmtidR919_:
926 ffestd_subr_line_restore_ (stmt);
927 ffeste_R919 (stmt->u.R919.params);
928 malloc_pool_kill (stmt->u.R919.pool);
929 break;
930
931 case FFESTD_stmtidR920_:
932 ffestd_subr_line_restore_ (stmt);
933 ffeste_R920 (stmt->u.R920.params);
934 malloc_pool_kill (stmt->u.R920.pool);
935 break;
936
937 case FFESTD_stmtidR921_:
938 ffestd_subr_line_restore_ (stmt);
939 ffeste_R921 (stmt->u.R921.params);
940 malloc_pool_kill (stmt->u.R921.pool);
941 break;
942
943 case FFESTD_stmtidR923A_:
944 ffestd_subr_line_restore_ (stmt);
945 ffeste_R923A (stmt->u.R923A.params, stmt->u.R923A.by_file);
946 malloc_pool_kill (stmt->u.R923A.pool);
947 break;
948
949 case FFESTD_stmtidR923B_:
950 ffestd_subr_line_restore_ (stmt);
951 ffeste_R923B_start (stmt->u.R923B.params);
952 for (expr = stmt->u.R923B.list; expr != NULL; expr = expr->next)
953 ffeste_R923B_item (expr->expr);
954 ffeste_R923B_finish ();
955 malloc_pool_kill (stmt->u.R923B.pool);
956 break;
957
958 case FFESTD_stmtidR1001_:
959 ffeste_R1001 (&stmt->u.R1001.str);
960 ffests_kill (&stmt->u.R1001.str);
961 break;
962
963 case FFESTD_stmtidR1103_:
964 ffeste_R1103 ();
965 break;
966
967 case FFESTD_stmtidR1112_:
968 ffeste_R1112 ();
969 break;
970
971 case FFESTD_stmtidR1212_:
972 ffestd_subr_line_restore_ (stmt);
973 ffeste_R1212 (stmt->u.R1212.expr);
974 malloc_pool_kill (stmt->u.R1212.pool);
975 break;
976
977 case FFESTD_stmtidR1221_:
978 ffeste_R1221 ();
979 break;
980
981 case FFESTD_stmtidR1225_:
982 ffeste_R1225 ();
983 break;
984
985 case FFESTD_stmtidR1226_:
986 ffestd_subr_line_restore_ (stmt);
987 if (stmt->u.R1226.entry != NULL)
988 ffeste_R1226 (stmt->u.R1226.entry);
989 break;
990
991 case FFESTD_stmtidR1227_:
992 ffestd_subr_line_restore_ (stmt);
993 ffeste_R1227 (stmt->u.R1227.block, stmt->u.R1227.expr);
994 malloc_pool_kill (stmt->u.R1227.pool);
995 break;
996
997#if FFESTR_VXT
998 case FFESTD_stmtidV018_:
999 ffestd_subr_line_restore_ (stmt);
1000 ffeste_V018_start (stmt->u.V018.params, stmt->u.V018.format);
1001 for (expr = stmt->u.V018.list; expr != NULL; expr = expr->next)
1002 ffeste_V018_item (expr->expr);
1003 ffeste_V018_finish ();
1004 malloc_pool_kill (stmt->u.V018.pool);
1005 break;
1006
1007 case FFESTD_stmtidV019_:
1008 ffestd_subr_line_restore_ (stmt);
1009 ffeste_V019_start (stmt->u.V019.params, stmt->u.V019.format);
1010 for (expr = stmt->u.V019.list; expr != NULL; expr = expr->next)
1011 ffeste_V019_item (expr->expr);
1012 ffeste_V019_finish ();
1013 malloc_pool_kill (stmt->u.V019.pool);
1014 break;
1015#endif
1016
1017 case FFESTD_stmtidV020_:
1018 ffestd_subr_line_restore_ (stmt);
1019 ffeste_V020_start (stmt->u.V020.params, stmt->u.V020.format);
1020 for (expr = stmt->u.V020.list; expr != NULL; expr = expr->next)
1021 ffeste_V020_item (expr->expr);
1022 ffeste_V020_finish ();
1023 malloc_pool_kill (stmt->u.V020.pool);
1024 break;
1025
1026#if FFESTR_VXT
1027 case FFESTD_stmtidV021_:
1028 ffestd_subr_line_restore_ (stmt);
1029 ffeste_V021 (stmt->u.V021.params);
1030 malloc_pool_kill (stmt->u.V021.pool);
1031 break;
1032
1033 case FFESTD_stmtidV023_:
1034 ffestd_subr_line_restore_ (stmt);
1035 ffeste_V023_start (stmt->u.V023.params);
1036 for (expr = stmt->u.V023.list; expr != NULL; expr = expr->next)
1037 ffeste_V023_item (expr->expr);
1038 ffeste_V023_finish ();
1039 malloc_pool_kill (stmt->u.V023.pool);
1040 break;
1041
1042 case FFESTD_stmtidV024_:
1043 ffestd_subr_line_restore_ (stmt);
1044 ffeste_V024_start (stmt->u.V024.params);
1045 for (expr = stmt->u.V024.list; expr != NULL; expr = expr->next)
1046 ffeste_V024_item (expr->expr);
1047 ffeste_V024_finish ();
1048 malloc_pool_kill (stmt->u.V024.pool);
1049 break;
1050
1051 case FFESTD_stmtidV025start_:
1052 ffestd_subr_line_restore_ (stmt);
1053 ffeste_V025_start ();
1054 break;
1055
1056 case FFESTD_stmtidV025item_:
1057 ffeste_V025_item (stmt->u.V025item.u, stmt->u.V025item.m,
1058 stmt->u.V025item.n, stmt->u.V025item.asv);
1059 break;
1060
1061 case FFESTD_stmtidV025finish_:
1062 ffeste_V025_finish ();
1063 malloc_pool_kill (stmt->u.V025finish.pool);
1064 break;
1065
1066 case FFESTD_stmtidV026_:
1067 ffestd_subr_line_restore_ (stmt);
1068 ffeste_V026 (stmt->u.V026.params);
1069 malloc_pool_kill (stmt->u.V026.pool);
1070 break;
1071#endif
1072
1073 default:
1074 assert ("bad stmt->id" == NULL);
1075 break;
1076 }
1077 }
1078}
1079
1080#endif
1081/* ffestd_subr_copy_easy_ -- Copy I/O statement data structure
1082
1083 ffestd_subr_copy_easy_();
1084
1085 Copies all data except tokens in the I/O data structure into a new
1086 structure that lasts as long as the output pool for the current
1087 statement. Assumes that they are
1088 overlaid with each other (union) in stp.h and the typing
1089 and structure references assume (though not necessarily dangerous if
1090 FALSE) that INQUIRE has the most file elements. */
1091
1092#if FFESTD_COPY_EASY_ && FFECOM_TWOPASS
1093static ffestpInquireStmt *
1094ffestd_subr_copy_easy_ (ffestpInquireIx max)
1095{
1096 ffestpInquireStmt *stmt;
1097 ffestpInquireIx ix;
1098
1099 stmt = (ffestpInquireStmt *) malloc_new_kp (ffesta_output_pool,
1100 "FFESTD easy", sizeof (ffestpFile) * max);
1101
1102 for (ix = 0; ix < max; ++ix)
1103 {
1104 if ((stmt->inquire_spec[ix].kw_or_val_present
1105 = ffestp_file.inquire.inquire_spec[ix].kw_or_val_present)
1106 && (stmt->inquire_spec[ix].value_present
1107 = ffestp_file.inquire.inquire_spec[ix].value_present))
1108 if ((stmt->inquire_spec[ix].value_is_label
1109 = ffestp_file.inquire.inquire_spec[ix].value_is_label))
1110 stmt->inquire_spec[ix].u.label
1111 = ffestp_file.inquire.inquire_spec[ix].u.label;
1112 else
1113 stmt->inquire_spec[ix].u.expr
1114 = ffestp_file.inquire.inquire_spec[ix].u.expr;
1115 }
1116
1117 return stmt;
1118}
1119
1120#endif
1121/* ffestd_subr_labels_ -- Handle any undefined labels
1122
1123 ffestd_subr_labels_(FALSE);
1124
1125 For every undefined label, generate an error message and either define
1126 label as a FORMAT() statement (for FORMAT labels) or as a STOP statement
1127 (for all other labels). */
1128
1129static void
1130ffestd_subr_labels_ (bool unexpected)
1131{
1132 ffelab l;
1133 ffelabHandle h;
1134 ffelabNumber undef;
1135 ffesttFormatList f;
1136
1137 undef = ffelab_number () - ffestv_num_label_defines_;
1138
1139 for (h = ffelab_handle_first (); h != NULL; h = ffelab_handle_next (h))
1140 {
1141 l = ffelab_handle_target (h);
1142 if (ffewhere_line_is_unknown (ffelab_definition_line (l)))
1143 { /* Undefined label. */
1144 assert (!unexpected);
1145 assert (undef > 0);
1146 undef--;
1147 ffebad_start (FFEBAD_UNDEF_LABEL);
1148 if (ffelab_type (l) == FFELAB_typeLOOPEND)
1149 ffebad_here (0, ffelab_doref_line (l), ffelab_doref_column (l));
1150 else if (ffelab_type (l) != FFELAB_typeANY)
1151 ffebad_here (0, ffelab_firstref_line (l), ffelab_firstref_column (l));
1152 else if (!ffewhere_line_is_unknown (ffelab_firstref_line (l)))
1153 ffebad_here (0, ffelab_firstref_line (l), ffelab_firstref_column (l));
1154 else if (!ffewhere_line_is_unknown (ffelab_doref_line (l)))
1155 ffebad_here (0, ffelab_doref_line (l), ffelab_doref_column (l));
1156 else
1157 ffebad_here (0, ffelab_definition_line (l), ffelab_definition_column (l));
1158 ffebad_finish ();
1159
1160 switch (ffelab_type (l))
1161 {
1162 case FFELAB_typeFORMAT:
1163 ffelab_set_definition_line (l,
1164 ffewhere_line_use (ffelab_firstref_line (l)));
1165 ffelab_set_definition_column (l,
1166 ffewhere_column_use (ffelab_firstref_column (l)));
1167 ffestv_num_label_defines_++;
1168 f = ffestt_formatlist_create (NULL, NULL);
1169 ffestd_labeldef_format (l);
1170 ffestd_R1001 (f);
1171 ffestt_formatlist_kill (f);
1172 break;
1173
1174 case FFELAB_typeASSIGNABLE:
1175 ffelab_set_definition_line (l,
1176 ffewhere_line_use (ffelab_firstref_line (l)));
1177 ffelab_set_definition_column (l,
1178 ffewhere_column_use (ffelab_firstref_column (l)));
1179 ffestv_num_label_defines_++;
1180 ffelab_set_type (l, FFELAB_typeNOTLOOP);
1181 ffelab_set_blocknum (l, ffestw_blocknum (ffestw_stack_top ()));
1182 ffestd_labeldef_notloop (l);
1183 ffestd_R842 (NULL);
1184 break;
1185
1186 case FFELAB_typeNOTLOOP:
1187 ffelab_set_definition_line (l,
1188 ffewhere_line_use (ffelab_firstref_line (l)));
1189 ffelab_set_definition_column (l,
1190 ffewhere_column_use (ffelab_firstref_column (l)));
1191 ffestv_num_label_defines_++;
1192 ffelab_set_blocknum (l, ffestw_blocknum (ffestw_stack_top ()));
1193 ffestd_labeldef_notloop (l);
1194 ffestd_R842 (NULL);
1195 break;
1196
1197 default:
1198 assert ("bad label type" == NULL);
1199 /* Fall through. */
1200 case FFELAB_typeUNKNOWN:
1201 case FFELAB_typeANY:
1202 break;
1203 }
1204 }
1205 }
1206 ffelab_handle_done (h);
1207 assert (undef == 0);
1208}
1209
1210/* ffestd_subr_f90_ -- Report error about lack of full F90 support
1211
1212 ffestd_subr_f90_(); */
1213
1214#if FFESTR_F90
1215static void
1216ffestd_subr_f90_ ()
1217{
1218 ffebad_start (FFEBAD_F90);
1219 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
1220 ffelex_token_where_column (ffesta_tokens[0]));
1221 ffebad_finish ();
1222}
1223
1224#endif
1225/* ffestd_subr_vxt_ -- Report error about lack of full VXT support
1226
1227 ffestd_subr_vxt_(); */
1228
1229#if FFECOM_targetCURRENT == FFECOM_targetGCC
1230static void
1231ffestd_subr_vxt_ ()
1232{
1233 ffebad_start (FFEBAD_VXT_UNSUPPORTED);
1234 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
1235 ffelex_token_where_column (ffesta_tokens[0]));
1236 ffebad_finish ();
1237}
1238
1239#endif
1240/* ffestd_begin_uses -- Start a bunch of USE statements
1241
1242 ffestd_begin_uses();
1243
1244 Invoked before handling the first USE statement in a block of one or
1245 more USE statements. _end_uses_(bool ok) is invoked before handling
1246 the first statement after the block (there are no BEGIN USE and END USE
1247 statements, but the semantics of USE statements effectively requires
1248 handling them as a single block rather than one statement at a time). */
1249
1250void
1251ffestd_begin_uses ()
1252{
1253#if FFECOM_targetCURRENT == FFECOM_targetFFE
1254 fputs ("; begin_uses\n", dmpout);
1255#elif FFECOM_targetCURRENT == FFECOM_targetGCC
1256#else
1257#error
1258#endif
1259}
1260
1261/* ffestd_do -- End of statement following DO-term-stmt etc
1262
1263 ffestd_do(TRUE);
1264
1265 Also invoked by _labeldef_branch_finish_ (or, in cases
1266 of errors, other _labeldef_ functions) when the label definition is
1267 for a DO-target (LOOPEND) label, once per matching/outstanding DO
1268 block on the stack. These cases invoke this function with ok==TRUE, so
1269 only forced stack popping (via ffestd_eof_()) invokes it with ok==FALSE. */
1270
1271void
1272ffestd_do (bool ok UNUSED)
1273{
1274#if FFECOM_ONEPASS
1275 ffestd_subr_line_now_ ();
1276 ffeste_do (ffestw_stack_top ());
1277#else
1278 {
1279 ffestdStmt_ stmt;
1280
1281 stmt = ffestd_stmt_new_ (FFESTD_stmtidENDDOLOOP_);
1282 ffestd_stmt_append_ (stmt);
1283 ffestd_subr_line_save_ (stmt);
1284 stmt->u.enddoloop.block = ffestw_stack_top ();
1285 }
1286#endif
1287
1288 --ffestd_block_level_;
1289 assert (ffestd_block_level_ >= 0);
1290}
1291
1292/* ffestd_end_uses -- End a bunch of USE statements
1293
1294 ffestd_end_uses(TRUE);
1295
1296 ok==TRUE means simply not popping due to ffestd_eof_()
1297 being called, because there is no formal END USES statement in Fortran. */
1298
1299#if FFESTR_F90
1300void
1301ffestd_end_uses (bool ok)
1302{
1303#if FFECOM_targetCURRENT == FFECOM_targetFFE
1304 fputs ("; end_uses\n", dmpout);
1305#elif FFECOM_targetCURRENT == FFECOM_targetGCC
1306#else
1307#error
1308#endif
1309}
1310
1311/* ffestd_end_R740 -- End a WHERE(-THEN)
1312
1313 ffestd_end_R740(TRUE); */
1314
1315void
1316ffestd_end_R740 (bool ok)
1317{
1318 return; /* F90. */
1319}
1320
1321#endif
1322/* ffestd_end_R807 -- End of statement following logical IF
1323
1324 ffestd_end_R807(TRUE);
1325
1326 Applies ONLY to logical IF, not to IF-THEN. For example, does not
1327 ffelex_token_kill the construct name for an IF-THEN block (the name
1328 field is invalid for logical IF). ok==TRUE iff statement following
1329 logical IF (substatement) is valid; else, statement is invalid or
1330 stack forcibly popped due to ffestd_eof_(). */
1331
1332void
1333ffestd_end_R807 (bool ok UNUSED)
1334{
1335#if FFECOM_ONEPASS
1336 ffestd_subr_line_now_ ();
1337 ffeste_end_R807 ();
1338#else
1339 {
1340 ffestdStmt_ stmt;
1341
1342 stmt = ffestd_stmt_new_ (FFESTD_stmtidENDLOGIF_);
1343 ffestd_stmt_append_ (stmt);
1344 ffestd_subr_line_save_ (stmt);
1345 }
1346#endif
1347
1348 --ffestd_block_level_;
1349 assert (ffestd_block_level_ >= 0);
1350}
1351
1352/* ffestd_exec_begin -- Executable statements can start coming in now
1353
1354 ffestd_exec_begin(); */
1355
1356void
1357ffestd_exec_begin ()
1358{
1359 ffecom_exec_transition ();
1360
1361#if FFECOM_targetCURRENT == FFECOM_targetFFE
1362 fputs ("{ begin_exec\n", dmpout);
1363#endif
1364
1365#if FFECOM_targetCURRENT == FFECOM_targetGCC
1366 if (ffestd_2pass_entrypoints_ != 0)
1367 { /* Process pending ENTRY statements now that
1368 info filled in. */
1369 ffestdStmt_ stmt;
1370 int ents = ffestd_2pass_entrypoints_;
1371
1372 stmt = ffestd_stmt_list_.first;
1373 do
1374 {
1375 while (stmt->id != FFESTD_stmtidR1226_)
1376 stmt = stmt->next;
1377
1378 if (!ffecom_2pass_advise_entrypoint (stmt->u.R1226.entry))
1379 {
1380 stmt->u.R1226.entry = NULL;
1381 --ffestd_2pass_entrypoints_;
1382 }
1383 stmt = stmt->next;
1384 }
1385 while (--ents != 0);
1386 }
1387#endif
1388}
1389
1390/* ffestd_exec_end -- Executable statements can no longer come in now
1391
1392 ffestd_exec_end(); */
1393
1394void
1395ffestd_exec_end ()
1396{
1397#if FFECOM_targetCURRENT == FFECOM_targetGCC
1398 int old_lineno = lineno;
1399 char *old_input_filename = input_filename;
1400#endif
1401
1402 ffecom_end_transition ();
1403
1404#if FFECOM_TWOPASS
1405 ffestd_stmt_pass_ ();
1406#endif
1407
1408#if FFECOM_targetCURRENT == FFECOM_targetFFE
1409 fputs ("} end_exec\n", dmpout);
1410 fputs ("> end_unit\n", dmpout);
1411#endif
1412
1413#if FFECOM_targetCURRENT == FFECOM_targetGCC
1414 ffecom_finish_progunit ();
1415
1416 if (ffestd_2pass_entrypoints_ != 0)
1417 {
1418 int ents = ffestd_2pass_entrypoints_;
1419 ffestdStmt_ stmt = ffestd_stmt_list_.first;
1420
1421 do
1422 {
1423 while (stmt->id != FFESTD_stmtidR1226_)
1424 stmt = stmt->next;
1425
1426 if (stmt->u.R1226.entry != NULL)
1427 {
1428 ffestd_subr_line_restore_ (stmt);
1429 ffecom_2pass_do_entrypoint (stmt->u.R1226.entry);
1430 }
1431 stmt = stmt->next;
1432 }
1433 while (--ents != 0);
1434 }
1435
1436 ffestd_stmt_list_.first = NULL;
1437 ffestd_stmt_list_.last = NULL;
1438 ffestd_2pass_entrypoints_ = 0;
1439
1440 lineno = old_lineno;
1441 input_filename = old_input_filename;
1442#endif
1443}
1444
1445/* ffestd_init_3 -- Initialize for any program unit
1446
1447 ffestd_init_3(); */
1448
1449void
1450ffestd_init_3 ()
1451{
1452#if FFECOM_TWOPASS
1453 ffestd_stmt_list_.first = (ffestdStmt_) &ffestd_stmt_list_.first;
1454 ffestd_stmt_list_.last = (ffestdStmt_) &ffestd_stmt_list_.first;
1455#endif
1456}
1457
1458/* Generate "code" for "any" label def. */
1459
1460void
1461ffestd_labeldef_any (ffelab label UNUSED)
1462{
1463#if FFECOM_targetCURRENT == FFECOM_targetFFE
1464 fprintf (dmpout, "; any_label_def %lu\n", ffelab_value (label));
1465#elif FFECOM_targetCURRENT == FFECOM_targetGCC
1466#else
1467#error
1468#endif
1469}
1470
1471/* ffestd_labeldef_branch -- Generate "code" for branch label def
1472
1473 ffestd_labeldef_branch(label); */
1474
1475void
1476ffestd_labeldef_branch (ffelab label)
1477{
1478#if FFECOM_ONEPASS
1479 ffeste_labeldef_branch (label);
1480#else
1481 {
1482 ffestdStmt_ stmt;
1483
1484 stmt = ffestd_stmt_new_ (FFESTD_stmtidEXECLABEL_);
1485 ffestd_stmt_append_ (stmt);
1486 stmt->u.execlabel.label = label;
1487 }
1488#endif
1489
1490 ffestd_is_reachable_ = TRUE;
1491}
1492
1493/* ffestd_labeldef_format -- Generate "code" for FORMAT label def
1494
1495 ffestd_labeldef_format(label); */
1496
1497void
1498ffestd_labeldef_format (ffelab label)
1499{
1500 ffestd_label_formatdef_ = label;
1501
1502#if FFECOM_ONEPASS
1503 ffeste_labeldef_format (label);
1504#else
1505 {
1506 ffestdStmt_ stmt;
1507
1508 stmt = ffestd_stmt_new_ (FFESTD_stmtidFORMATLABEL_);
1509 ffestd_stmt_append_ (stmt);
1510 stmt->u.formatlabel.label = label;
1511 }
1512#endif
1513}
1514
1515/* ffestd_labeldef_useless -- Generate "code" for useless label def
1516
1517 ffestd_labeldef_useless(label); */
1518
1519void
1520ffestd_labeldef_useless (ffelab label UNUSED)
1521{
1522#if FFECOM_targetCURRENT == FFECOM_targetFFE
1523 fprintf (dmpout, "; useless_label_def %lu\n", ffelab_value (label));
1524#elif FFECOM_targetCURRENT == FFECOM_targetGCC
1525#else
1526#error
1527#endif
1528}
1529
1530/* ffestd_R423A -- PRIVATE statement (in R422 derived-type statement)
1531
1532 ffestd_R423A(); */
1533
1534#if FFESTR_F90
1535void
1536ffestd_R423A ()
1537{
1538 ffestd_check_simple_ ();
1539
1540#if FFECOM_targetCURRENT == FFECOM_targetFFE
1541 fputs ("* PRIVATE_derived_type\n", dmpout);
1542#elif FFECOM_targetCURRENT == FFECOM_targetGCC
1543#else
1544#error
1545#endif
1546}
1547
1548/* ffestd_R423B -- SEQUENCE statement (in R422 derived-type-stmt)
1549
1550 ffestd_R423B(); */
1551
1552void
1553ffestd_R423B ()
1554{
1555 ffestd_check_simple_ ();
1556
1557#if FFECOM_targetCURRENT == FFECOM_targetFFE
1558 fputs ("* SEQUENCE_derived_type\n", dmpout);
1559#elif FFECOM_targetCURRENT == FFECOM_targetGCC
1560#else
1561#error
1562#endif
1563}
1564
1565/* ffestd_R424 -- derived-TYPE-def statement
1566
1567 ffestd_R424(access_token,access_kw,name_token);
1568
1569 Handle a derived-type definition. */
1570
1571void
1572ffestd_R424 (ffelexToken access, ffestrOther access_kw, ffelexToken name)
1573{
1574 ffestd_check_simple_ ();
1575
1576 ffestd_subr_f90_ ();
1577 return;
1578
1579#ifdef FFESTD_F90
1580 char *a;
1581
1582 if (access == NULL)
1583 fprintf (dmpout, "* TYPE %s\n", ffelex_token_text (name));
1584 else
1585 {
1586 switch (access_kw)
1587 {
1588 case FFESTR_otherPUBLIC:
1589 a = "PUBLIC";
1590 break;
1591
1592 case FFESTR_otherPRIVATE:
1593 a = "PRIVATE";
1594 break;
1595
1596 default:
1597 assert (FALSE);
1598 }
1599 fprintf (dmpout, "* TYPE,%s: %s\n", a, ffelex_token_text (name));
1600 }
1601#endif
1602}
1603
1604/* ffestd_R425 -- End a TYPE
1605
1606 ffestd_R425(TRUE); */
1607
1608void
1609ffestd_R425 (bool ok)
1610{
1611#if FFECOM_targetCURRENT == FFECOM_targetFFE
1612 fprintf (dmpout, "* END_TYPE %s\n", ffelex_token_text (ffestw_name (ffestw_stack_top ())));
1613#elif FFECOM_targetCURRENT == FFECOM_targetGCC
1614#else
1615#error
1616#endif
1617}
1618
1619/* ffestd_R519_start -- INTENT statement list begin
1620
1621 ffestd_R519_start();
1622
1623 Verify that INTENT is valid here, and begin accepting items in the list. */
1624
1625void
1626ffestd_R519_start (ffestrOther intent_kw)
1627{
1628 ffestd_check_start_ ();
1629
1630 ffestd_subr_f90_ ();
1631 return;
1632
1633#ifdef FFESTD_F90
1634 char *a;
1635
1636 switch (intent_kw)
1637 {
1638 case FFESTR_otherIN:
1639 a = "IN";
1640 break;
1641
1642 case FFESTR_otherOUT:
1643 a = "OUT";
1644 break;
1645
1646 case FFESTR_otherINOUT:
1647 a = "INOUT";
1648 break;
1649
1650 default:
1651 assert (FALSE);
1652 }
1653 fprintf (dmpout, "* INTENT (%s) ", a);
1654#endif
1655}
1656
1657/* ffestd_R519_item -- INTENT statement for name
1658
1659 ffestd_R519_item(name_token);
1660
1661 Make sure name_token identifies a valid object to be INTENTed. */
1662
1663void
1664ffestd_R519_item (ffelexToken name)
1665{
1666 ffestd_check_item_ ();
1667
1668 return; /* F90. */
1669
1670#ifdef FFESTD_F90
1671 fprintf (dmpout, "%s,", ffelex_token_text (name));
1672#endif
1673}
1674
1675/* ffestd_R519_finish -- INTENT statement list complete
1676
1677 ffestd_R519_finish();
1678
1679 Just wrap up any local activities. */
1680
1681void
1682ffestd_R519_finish ()
1683{
1684 ffestd_check_finish_ ();
1685
1686 return; /* F90. */
1687
1688#ifdef FFESTD_F90
1689 fputc ('\n', dmpout);
1690#endif
1691}
1692
1693/* ffestd_R520_start -- OPTIONAL statement list begin
1694
1695 ffestd_R520_start();
1696
1697 Verify that OPTIONAL is valid here, and begin accepting items in the list. */
1698
1699void
1700ffestd_R520_start ()
1701{
1702 ffestd_check_start_ ();
1703
1704 ffestd_subr_f90_ ();
1705 return;
1706
1707#ifdef FFESTD_F90
1708 fputs ("* OPTIONAL ", dmpout);
1709#endif
1710}
1711
1712/* ffestd_R520_item -- OPTIONAL statement for name
1713
1714 ffestd_R520_item(name_token);
1715
1716 Make sure name_token identifies a valid object to be OPTIONALed. */
1717
1718void
1719ffestd_R520_item (ffelexToken name)
1720{
1721 ffestd_check_item_ ();
1722
1723 return; /* F90. */
1724
1725#ifdef FFESTD_F90
1726 fprintf (dmpout, "%s,", ffelex_token_text (name));
1727#endif
1728}
1729
1730/* ffestd_R520_finish -- OPTIONAL statement list complete
1731
1732 ffestd_R520_finish();
1733
1734 Just wrap up any local activities. */
1735
1736void
1737ffestd_R520_finish ()
1738{
1739 ffestd_check_finish_ ();
1740
1741 return; /* F90. */
1742
1743#ifdef FFESTD_F90
1744 fputc ('\n', dmpout);
1745#endif
1746}
1747
1748/* ffestd_R521A -- PUBLIC statement
1749
1750 ffestd_R521A();
1751
1752 Verify that PUBLIC is valid here. */
1753
1754void
1755ffestd_R521A ()
1756{
1757 ffestd_check_simple_ ();
1758
1759 ffestd_subr_f90_ ();
1760 return;
1761
1762#ifdef FFESTD_F90
1763 fputs ("* PUBLIC\n", dmpout);
1764#endif
1765}
1766
1767/* ffestd_R521Astart -- PUBLIC statement list begin
1768
1769 ffestd_R521Astart();
1770
1771 Verify that PUBLIC is valid here, and begin accepting items in the list. */
1772
1773void
1774ffestd_R521Astart ()
1775{
1776 ffestd_check_start_ ();
1777
1778 ffestd_subr_f90_ ();
1779 return;
1780
1781#ifdef FFESTD_F90
1782 fputs ("* PUBLIC ", dmpout);
1783#endif
1784}
1785
1786/* ffestd_R521Aitem -- PUBLIC statement for name
1787
1788 ffestd_R521Aitem(name_token);
1789
1790 Make sure name_token identifies a valid object to be PUBLICed. */
1791
1792void
1793ffestd_R521Aitem (ffelexToken name)
1794{
1795 ffestd_check_item_ ();
1796
1797 return; /* F90. */
1798
1799#ifdef FFESTD_F90
1800 fprintf (dmpout, "%s,", ffelex_token_text (name));
1801#endif
1802}
1803
1804/* ffestd_R521Afinish -- PUBLIC statement list complete
1805
1806 ffestd_R521Afinish();
1807
1808 Just wrap up any local activities. */
1809
1810void
1811ffestd_R521Afinish ()
1812{
1813 ffestd_check_finish_ ();
1814
1815 return; /* F90. */
1816
1817#ifdef FFESTD_F90
1818 fputc ('\n', dmpout);
1819#endif
1820}
1821
1822/* ffestd_R521B -- PRIVATE statement
1823
1824 ffestd_R521B();
1825
1826 Verify that PRIVATE is valid here (outside a derived-type statement). */
1827
1828void
1829ffestd_R521B ()
1830{
1831 ffestd_check_simple_ ();
1832
1833 ffestd_subr_f90_ ();
1834 return;
1835
1836#ifdef FFESTD_F90
1837 fputs ("* PRIVATE_outside_of_R422_derived_type_def\n", dmpout);
1838#endif
1839}
1840
1841/* ffestd_R521Bstart -- PRIVATE statement list begin
1842
1843 ffestd_R521Bstart();
1844
1845 Verify that PRIVATE is valid here, and begin accepting items in the list. */
1846
1847void
1848ffestd_R521Bstart ()
1849{
1850 ffestd_check_start_ ();
1851
1852 ffestd_subr_f90_ ();
1853 return;
1854
1855#ifdef FFESTD_F90
1856 fputs ("* PRIVATE ", dmpout);
1857#endif
1858}
1859
1860/* ffestd_R521Bitem -- PRIVATE statement for name
1861
1862 ffestd_R521Bitem(name_token);
1863
1864 Make sure name_token identifies a valid object to be PRIVATEed. */
1865
1866void
1867ffestd_R521Bitem (ffelexToken name)
1868{
1869 ffestd_check_item_ ();
1870
1871 return; /* F90. */
1872
1873#ifdef FFESTD_F90
1874 fprintf (dmpout, "%s,", ffelex_token_text (name));
1875#endif
1876}
1877
1878/* ffestd_R521Bfinish -- PRIVATE statement list complete
1879
1880 ffestd_R521Bfinish();
1881
1882 Just wrap up any local activities. */
1883
1884void
1885ffestd_R521Bfinish ()
1886{
1887 ffestd_check_finish_ ();
1888
1889 return; /* F90. */
1890
1891#ifdef FFESTD_F90
1892 fputc ('\n', dmpout);
1893#endif
1894}
1895
1896#endif
1897/* ffestd_R522 -- SAVE statement with no list
1898
1899 ffestd_R522();
1900
1901 Verify that SAVE is valid here, and flag everything as SAVEd. */
1902
1903void
1904ffestd_R522 ()
1905{
1906 ffestd_check_simple_ ();
1907
1908#if FFECOM_targetCURRENT == FFECOM_targetFFE
1909 fputs ("* SAVE_all\n", dmpout);
1910#elif FFECOM_targetCURRENT == FFECOM_targetGCC
1911#else
1912#error
1913#endif
1914}
1915
1916/* ffestd_R522start -- SAVE statement list begin
1917
1918 ffestd_R522start();
1919
1920 Verify that SAVE is valid here, and begin accepting items in the list. */
1921
1922void
1923ffestd_R522start ()
1924{
1925 ffestd_check_start_ ();
1926
1927#if FFECOM_targetCURRENT == FFECOM_targetFFE
1928 fputs ("* SAVE ", dmpout);
1929#elif FFECOM_targetCURRENT == FFECOM_targetGCC
1930#else
1931#error
1932#endif
1933}
1934
1935/* ffestd_R522item_object -- SAVE statement for object-name
1936
1937 ffestd_R522item_object(name_token);
1938
1939 Make sure name_token identifies a valid object to be SAVEd. */
1940
1941void
1942ffestd_R522item_object (ffelexToken name UNUSED)
1943{
1944 ffestd_check_item_ ();
1945
1946#if FFECOM_targetCURRENT == FFECOM_targetFFE
1947 fprintf (dmpout, "%s,", ffelex_token_text (name));
1948#elif FFECOM_targetCURRENT == FFECOM_targetGCC
1949#else
1950#error
1951#endif
1952}
1953
1954/* ffestd_R522item_cblock -- SAVE statement for common-block-name
1955
1956 ffestd_R522item_cblock(name_token);
1957
1958 Make sure name_token identifies a valid common block to be SAVEd. */
1959
1960void
1961ffestd_R522item_cblock (ffelexToken name UNUSED)
1962{
1963 ffestd_check_item_ ();
1964
1965#if FFECOM_targetCURRENT == FFECOM_targetFFE
1966 fprintf (dmpout, "/%s/,", ffelex_token_text (name));
1967#elif FFECOM_targetCURRENT == FFECOM_targetGCC
1968#else
1969#error
1970#endif
1971}
1972
1973/* ffestd_R522finish -- SAVE statement list complete
1974
1975 ffestd_R522finish();
1976
1977 Just wrap up any local activities. */
1978
1979void
1980ffestd_R522finish ()
1981{
1982 ffestd_check_finish_ ();
1983
1984#if FFECOM_targetCURRENT == FFECOM_targetFFE
1985 fputc ('\n', dmpout);
1986#elif FFECOM_targetCURRENT == FFECOM_targetGCC
1987#else
1988#error
1989#endif
1990}
1991
1992/* ffestd_R524_start -- DIMENSION statement list begin
1993
1994 ffestd_R524_start(bool virtual);
1995
1996 Verify that DIMENSION is valid here, and begin accepting items in the list. */
1997
1998void
1999ffestd_R524_start (bool virtual UNUSED)
2000{
2001 ffestd_check_start_ ();
2002
2003#if FFECOM_targetCURRENT == FFECOM_targetFFE
2004 if (virtual)
2005 fputs ("* VIRTUAL ", dmpout); /* V028. */
2006 else
2007 fputs ("* DIMENSION ", dmpout);
2008#elif FFECOM_targetCURRENT == FFECOM_targetGCC
2009#else
2010#error
2011#endif
2012}
2013
2014/* ffestd_R524_item -- DIMENSION statement for object-name
2015
2016 ffestd_R524_item(name_token,dim_list);
2017
2018 Make sure name_token identifies a valid object to be DIMENSIONd. */
2019
2020void
2021ffestd_R524_item (ffelexToken name UNUSED, ffesttDimList dims UNUSED)
2022{
2023 ffestd_check_item_ ();
2024
2025#if FFECOM_targetCURRENT == FFECOM_targetFFE
2026 fputs (ffelex_token_text (name), dmpout);
2027 fputc ('(', dmpout);
2028 ffestt_dimlist_dump (dims);
2029 fputs ("),", dmpout);
2030#elif FFECOM_targetCURRENT == FFECOM_targetGCC
2031#else
2032#error
2033#endif
2034}
2035
2036/* ffestd_R524_finish -- DIMENSION statement list complete
2037
2038 ffestd_R524_finish();
2039
2040 Just wrap up any local activities. */
2041
2042void
2043ffestd_R524_finish ()
2044{
2045 ffestd_check_finish_ ();
2046
2047#if FFECOM_targetCURRENT == FFECOM_targetFFE
2048 fputc ('\n', dmpout);
2049#elif FFECOM_targetCURRENT == FFECOM_targetGCC
2050#else
2051#error
2052#endif
2053}
2054
2055/* ffestd_R525_start -- ALLOCATABLE statement list begin
2056
2057 ffestd_R525_start();
2058
2059 Verify that ALLOCATABLE is valid here, and begin accepting items in the
2060 list. */
2061
2062#if FFESTR_F90
2063void
2064ffestd_R525_start ()
2065{
2066 ffestd_check_start_ ();
2067
2068 ffestd_subr_f90_ ();
2069 return;
2070
2071#ifdef FFESTD_F90
2072 fputs ("* ALLOCATABLE ", dmpout);
2073#endif
2074}
2075
2076/* ffestd_R525_item -- ALLOCATABLE statement for object-name
2077
2078 ffestd_R525_item(name_token,dim_list);
2079
2080 Make sure name_token identifies a valid object to be ALLOCATABLEd. */
2081
2082void
2083ffestd_R525_item (ffelexToken name, ffesttDimList dims)
2084{
2085 ffestd_check_item_ ();
2086
2087 return; /* F90. */
2088
2089#ifdef FFESTD_F90
2090 fputs (ffelex_token_text (name), dmpout);
2091 if (dims != NULL)
2092 {
2093 fputc ('(', dmpout);
2094 ffestt_dimlist_dump (dims);
2095 fputc (')', dmpout);
2096 }
2097 fputc (',', dmpout);
2098#endif
2099}
2100
2101/* ffestd_R525_finish -- ALLOCATABLE statement list complete
2102
2103 ffestd_R525_finish();
2104
2105 Just wrap up any local activities. */
2106
2107void
2108ffestd_R525_finish ()
2109{
2110 ffestd_check_finish_ ();
2111
2112 return; /* F90. */
2113
2114#ifdef FFESTD_F90
2115 fputc ('\n', dmpout);
2116#endif
2117}
2118
2119/* ffestd_R526_start -- POINTER statement list begin
2120
2121 ffestd_R526_start();
2122
2123 Verify that POINTER is valid here, and begin accepting items in the
2124 list. */
2125
2126void
2127ffestd_R526_start ()
2128{
2129 ffestd_check_start_ ();
2130
2131 ffestd_subr_f90_ ();
2132 return;
2133
2134#ifdef FFESTD_F90
2135 fputs ("* POINTER ", dmpout);
2136#endif
2137}
2138
2139/* ffestd_R526_item -- POINTER statement for object-name
2140
2141 ffestd_R526_item(name_token,dim_list);
2142
2143 Make sure name_token identifies a valid object to be POINTERd. */
2144
2145void
2146ffestd_R526_item (ffelexToken name, ffesttDimList dims)
2147{
2148 ffestd_check_item_ ();
2149
2150 return; /* F90. */
2151
2152#ifdef FFESTD_F90
2153 fputs (ffelex_token_text (name), dmpout);
2154 if (dims != NULL)
2155 {
2156 fputc ('(', dmpout);
2157 ffestt_dimlist_dump (dims);
2158 fputc (')', dmpout);
2159 }
2160 fputc (',', dmpout);
2161#endif
2162}
2163
2164/* ffestd_R526_finish -- POINTER statement list complete
2165
2166 ffestd_R526_finish();
2167
2168 Just wrap up any local activities. */
2169
2170void
2171ffestd_R526_finish ()
2172{
2173 ffestd_check_finish_ ();
2174
2175 return; /* F90. */
2176
2177#ifdef FFESTD_F90
2178 fputc ('\n', dmpout);
2179#endif
2180}
2181
2182/* ffestd_R527_start -- TARGET statement list begin
2183
2184 ffestd_R527_start();
2185
2186 Verify that TARGET is valid here, and begin accepting items in the
2187 list. */
2188
2189void
2190ffestd_R527_start ()
2191{
2192 ffestd_check_start_ ();
2193
2194 ffestd_subr_f90_ ();
2195 return;
2196
2197#ifdef FFESTD_F90
2198 fputs ("* TARGET ", dmpout);
2199#endif
2200}
2201
2202/* ffestd_R527_item -- TARGET statement for object-name
2203
2204 ffestd_R527_item(name_token,dim_list);
2205
2206 Make sure name_token identifies a valid object to be TARGETd. */
2207
2208void
2209ffestd_R527_item (ffelexToken name, ffesttDimList dims)
2210{
2211 ffestd_check_item_ ();
2212
2213 return; /* F90. */
2214
2215#ifdef FFESTD_F90
2216 fputs (ffelex_token_text (name), dmpout);
2217 if (dims != NULL)
2218 {
2219 fputc ('(', dmpout);
2220 ffestt_dimlist_dump (dims);
2221 fputc (')', dmpout);
2222 }
2223 fputc (',', dmpout);
2224#endif
2225}
2226
2227/* ffestd_R527_finish -- TARGET statement list complete
2228
2229 ffestd_R527_finish();
2230
2231 Just wrap up any local activities. */
2232
2233void
2234ffestd_R527_finish ()
2235{
2236 ffestd_check_finish_ ();
2237
2238 return; /* F90. */
2239
2240#ifdef FFESTD_F90
2241 fputc ('\n', dmpout);
2242#endif
2243}
2244
2245#endif
2246/* ffestd_R537_start -- PARAMETER statement list begin
2247
2248 ffestd_R537_start();
2249
2250 Verify that PARAMETER is valid here, and begin accepting items in the list. */
2251
2252void
2253ffestd_R537_start ()
2254{
2255 ffestd_check_start_ ();
2256
2257#if FFECOM_targetCURRENT == FFECOM_targetFFE
2258 fputs ("* PARAMETER (", dmpout);
2259#elif FFECOM_targetCURRENT == FFECOM_targetGCC
2260#else
2261#error
2262#endif
2263}
2264
2265/* ffestd_R537_item -- PARAMETER statement assignment
2266
2267 ffestd_R537_item(dest,dest_token,source,source_token);
2268
2269 Make sure the source is a valid source for the destination; make the
2270 assignment. */
2271
2272void
2273ffestd_R537_item (ffebld dest UNUSED, ffebld source UNUSED)
2274{
2275 ffestd_check_item_ ();
2276
2277#if FFECOM_targetCURRENT == FFECOM_targetFFE
2278 ffebld_dump (dest);
2279 fputc ('=', dmpout);
2280 ffebld_dump (source);
2281 fputc (',', dmpout);
2282#elif FFECOM_targetCURRENT == FFECOM_targetGCC
2283#else
2284#error
2285#endif
2286}
2287
2288/* ffestd_R537_finish -- PARAMETER statement list complete
2289
2290 ffestd_R537_finish();
2291
2292 Just wrap up any local activities. */
2293
2294void
2295ffestd_R537_finish ()
2296{
2297 ffestd_check_finish_ ();
2298
2299#if FFECOM_targetCURRENT == FFECOM_targetFFE
2300 fputs (")\n", dmpout);
2301#elif FFECOM_targetCURRENT == FFECOM_targetGCC
2302#else
2303#error
2304#endif
2305}
2306
2307/* ffestd_R539 -- IMPLICIT NONE statement
2308
2309 ffestd_R539();
2310
2311 Verify that the IMPLICIT NONE statement is ok here and implement. */
2312
2313void
2314ffestd_R539 ()
2315{
2316 ffestd_check_simple_ ();
2317
2318#if FFECOM_targetCURRENT == FFECOM_targetFFE
2319 fputs ("* IMPLICIT_NONE\n", dmpout);
2320#elif FFECOM_targetCURRENT == FFECOM_targetGCC
2321#else
2322#error
2323#endif
2324}
2325
2326/* ffestd_R539start -- IMPLICIT statement
2327
2328 ffestd_R539start();
2329
2330 Verify that the IMPLICIT statement is ok here and implement. */
2331
2332void
2333ffestd_R539start ()
2334{
2335 ffestd_check_start_ ();
2336
2337#if FFECOM_targetCURRENT == FFECOM_targetFFE
2338 fputs ("* IMPLICIT ", dmpout);
2339#elif FFECOM_targetCURRENT == FFECOM_targetGCC
2340#else
2341#error
2342#endif
2343}
2344
2345/* ffestd_R539item -- IMPLICIT statement specification (R540)
2346
2347 ffestd_R539item(...);
2348
2349 Verify that the type and letter list are all ok and implement. */
2350
2351void
2352ffestd_R539item (ffestpType type UNUSED, ffebld kind UNUSED,
2353 ffelexToken kindt UNUSED, ffebld len UNUSED,
2354 ffelexToken lent UNUSED, ffesttImpList letters UNUSED)
2355{
2356#if FFECOM_targetCURRENT == FFECOM_targetFFE
2357 char *a;
2358#endif
2359
2360 ffestd_check_item_ ();
2361
2362#if FFECOM_targetCURRENT == FFECOM_targetFFE
2363 switch (type)
2364 {
2365 case FFESTP_typeINTEGER:
2366 a = "INTEGER";
2367 break;
2368
2369 case FFESTP_typeBYTE:
2370 a = "BYTE";
2371 break;
2372
2373 case FFESTP_typeWORD:
2374 a = "WORD";
2375 break;
2376
2377 case FFESTP_typeREAL:
2378 a = "REAL";
2379 break;
2380
2381 case FFESTP_typeCOMPLEX:
2382 a = "COMPLEX";
2383 break;
2384
2385 case FFESTP_typeLOGICAL:
2386 a = "LOGICAL";
2387 break;
2388
2389 case FFESTP_typeCHARACTER:
2390 a = "CHARACTER";
2391 break;
2392
2393 case FFESTP_typeDBLPRCSN:
2394 a = "DOUBLE PRECISION";
2395 break;
2396
2397 case FFESTP_typeDBLCMPLX:
2398 a = "DOUBLE COMPLEX";
2399 break;
2400
2401#if FFESTR_F90
2402 case FFESTP_typeTYPE:
2403 a = "TYPE";
2404 break;
2405#endif
2406
2407 default:
2408 assert (FALSE);
2409 a = "?";
2410 break;
2411 }
2412 fprintf (dmpout, "%s(", a);
2413 if (kindt != NULL)
2414 {
2415 fputs ("kind=", dmpout);
2416 if (kind == NULL)
2417 fputs (ffelex_token_text (kindt), dmpout);
2418 else
2419 ffebld_dump (kind);
2420 if (lent != NULL)
2421 fputc (',', dmpout);
2422 }
2423 if (lent != NULL)
2424 {
2425 fputs ("len=", dmpout);
2426 if (len == NULL)
2427 fputs (ffelex_token_text (lent), dmpout);
2428 else
2429 ffebld_dump (len);
2430 }
2431 fputs (")(", dmpout);
2432 ffestt_implist_dump (letters);
2433 fputs ("),", dmpout);
2434#elif FFECOM_targetCURRENT == FFECOM_targetGCC
2435#else
2436#error
2437#endif
2438}
2439
2440/* ffestd_R539finish -- IMPLICIT statement
2441
2442 ffestd_R539finish();
2443
2444 Finish up any local activities. */
2445
2446void
2447ffestd_R539finish ()
2448{
2449 ffestd_check_finish_ ();
2450
2451#if FFECOM_targetCURRENT == FFECOM_targetFFE
2452 fputc ('\n', dmpout);
2453#elif FFECOM_targetCURRENT == FFECOM_targetGCC
2454#else
2455#error
2456#endif
2457}
2458
2459/* ffestd_R542_start -- NAMELIST statement list begin
2460
2461 ffestd_R542_start();
2462
2463 Verify that NAMELIST is valid here, and begin accepting items in the list. */
2464
2465void
2466ffestd_R542_start ()
2467{
2468 ffestd_check_start_ ();
2469
2470#if FFECOM_targetCURRENT == FFECOM_targetFFE
2471 fputs ("* NAMELIST ", dmpout);
2472#elif FFECOM_targetCURRENT == FFECOM_targetGCC
2473#else
2474#error
2475#endif
2476}
2477
2478/* ffestd_R542_item_nlist -- NAMELIST statement for group-name
2479
2480 ffestd_R542_item_nlist(groupname_token);
2481
2482 Make sure name_token identifies a valid object to be NAMELISTd. */
2483
2484void
2485ffestd_R542_item_nlist (ffelexToken name UNUSED)
2486{
2487 ffestd_check_item_ ();
2488
2489#if FFECOM_targetCURRENT == FFECOM_targetFFE
2490 fprintf (dmpout, "/%s/", ffelex_token_text (name));
2491#elif FFECOM_targetCURRENT == FFECOM_targetGCC
2492#else
2493#error
2494#endif
2495}
2496
2497/* ffestd_R542_item_nitem -- NAMELIST statement for variable-name
2498
2499 ffestd_R542_item_nitem(name_token);
2500
2501 Make sure name_token identifies a valid object to be NAMELISTd. */
2502
2503void
2504ffestd_R542_item_nitem (ffelexToken name UNUSED)
2505{
2506 ffestd_check_item_ ();
2507
2508#if FFECOM_targetCURRENT == FFECOM_targetFFE
2509 fprintf (dmpout, "%s,", ffelex_token_text (name));
2510#elif FFECOM_targetCURRENT == FFECOM_targetGCC
2511#else
2512#error
2513#endif
2514}
2515
2516/* ffestd_R542_finish -- NAMELIST statement list complete
2517
2518 ffestd_R542_finish();
2519
2520 Just wrap up any local activities. */
2521
2522void
2523ffestd_R542_finish ()
2524{
2525 ffestd_check_finish_ ();
2526
2527#if FFECOM_targetCURRENT == FFECOM_targetFFE
2528 fputc ('\n', dmpout);
2529#elif FFECOM_targetCURRENT == FFECOM_targetGCC
2530#else
2531#error
2532#endif
2533}
2534
2535/* ffestd_R544_start -- EQUIVALENCE statement list begin
2536
2537 ffestd_R544_start();
2538
2539 Verify that EQUIVALENCE is valid here, and begin accepting items in the
2540 list. */
2541
2542#if 0
2543void
2544ffestd_R544_start ()
2545{
2546 ffestd_check_start_ ();
2547
2548#if FFECOM_targetCURRENT == FFECOM_targetFFE
2549 fputs ("* EQUIVALENCE (", dmpout);
2550#elif FFECOM_targetCURRENT == FFECOM_targetGCC
2551#else
2552#error
2553#endif
2554}
2555
2556#endif
2557/* ffestd_R544_item -- EQUIVALENCE statement assignment
2558
2559 ffestd_R544_item(exprlist);
2560
2561 Make sure the equivalence is valid, then implement it. */
2562
2563#if 0
2564void
2565ffestd_R544_item (ffesttExprList exprlist)
2566{
2567 ffestd_check_item_ ();
2568
2569#if FFECOM_targetCURRENT == FFECOM_targetFFE
2570 ffestt_exprlist_dump (exprlist);
2571 fputs ("),", dmpout);
2572#elif FFECOM_targetCURRENT == FFECOM_targetGCC
2573#else
2574#error
2575#endif
2576}
2577
2578#endif
2579/* ffestd_R544_finish -- EQUIVALENCE statement list complete
2580
2581 ffestd_R544_finish();
2582
2583 Just wrap up any local activities. */
2584
2585#if 0
2586void
2587ffestd_R544_finish ()
2588{
2589 ffestd_check_finish_ ();
2590
2591#if FFECOM_targetCURRENT == FFECOM_targetFFE
2592 fputs (")\n", dmpout);
2593#elif FFECOM_targetCURRENT == FFECOM_targetGCC
2594#else
2595#error
2596#endif
2597}
2598
2599#endif
2600/* ffestd_R547_start -- COMMON statement list begin
2601
2602 ffestd_R547_start();
2603
2604 Verify that COMMON is valid here, and begin accepting items in the list. */
2605
2606void
2607ffestd_R547_start ()
2608{
2609 ffestd_check_start_ ();
2610
2611#if FFECOM_targetCURRENT == FFECOM_targetFFE
2612 fputs ("* COMMON ", dmpout);
2613#elif FFECOM_targetCURRENT == FFECOM_targetGCC
2614#else
2615#error
2616#endif
2617}
2618
2619/* ffestd_R547_item_object -- COMMON statement for object-name
2620
2621 ffestd_R547_item_object(name_token,dim_list);
2622
2623 Make sure name_token identifies a valid object to be COMMONd. */
2624
2625void
2626ffestd_R547_item_object (ffelexToken name UNUSED,
2627 ffesttDimList dims UNUSED)
2628{
2629 ffestd_check_item_ ();
2630
2631#if FFECOM_targetCURRENT == FFECOM_targetFFE
2632 fputs (ffelex_token_text (name), dmpout);
2633 if (dims != NULL)
2634 {
2635 fputc ('(', dmpout);
2636 ffestt_dimlist_dump (dims);
2637 fputc (')', dmpout);
2638 }
2639 fputc (',', dmpout);
2640#elif FFECOM_targetCURRENT == FFECOM_targetGCC
2641#else
2642#error
2643#endif
2644}
2645
2646/* ffestd_R547_item_cblock -- COMMON statement for common-block-name
2647
2648 ffestd_R547_item_cblock(name_token);
2649
2650 Make sure name_token identifies a valid common block to be COMMONd. */
2651
2652void
2653ffestd_R547_item_cblock (ffelexToken name UNUSED)
2654{
2655 ffestd_check_item_ ();
2656
2657#if FFECOM_targetCURRENT == FFECOM_targetFFE
2658 if (name == NULL)
2659 fputs ("//,", dmpout);
2660 else
2661 fprintf (dmpout, "/%s/,", ffelex_token_text (name));
2662#elif FFECOM_targetCURRENT == FFECOM_targetGCC
2663#else
2664#error
2665#endif
2666}
2667
2668/* ffestd_R547_finish -- COMMON statement list complete
2669
2670 ffestd_R547_finish();
2671
2672 Just wrap up any local activities. */
2673
2674void
2675ffestd_R547_finish ()
2676{
2677 ffestd_check_finish_ ();
2678
2679#if FFECOM_targetCURRENT == FFECOM_targetFFE
2680 fputc ('\n', dmpout);
2681#elif FFECOM_targetCURRENT == FFECOM_targetGCC
2682#else
2683#error
2684#endif
2685}
2686
2687/* ffestd_R620 -- ALLOCATE statement
2688
2689 ffestd_R620(exprlist,stat,stat_token);
2690
2691 Make sure the expression list is valid, then implement it. */
2692
2693#if FFESTR_F90
2694void
2695ffestd_R620 (ffesttExprList exprlist, ffebld stat)
2696{
2697 ffestd_check_simple_ ();
2698
2699 ffestd_subr_f90_ ();
2700 return;
2701
2702#ifdef FFESTD_F90
2703 fputs ("+ ALLOCATE (", dmpout);
2704 ffestt_exprlist_dump (exprlist);
2705 if (stat != NULL)
2706 {
2707 fputs (",stat=", dmpout);
2708 ffebld_dump (stat);
2709 }
2710 fputs (")\n", dmpout);
2711#endif
2712}
2713
2714/* ffestd_R624 -- NULLIFY statement
2715
2716 ffestd_R624(pointer_name_list);
2717
2718 Make sure pointer_name_list identifies valid pointers for a NULLIFY. */
2719
2720void
2721ffestd_R624 (ffesttExprList pointers)
2722{
2723 ffestd_check_simple_ ();
2724
2725 ffestd_subr_f90_ ();
2726 return;
2727
2728#ifdef FFESTD_F90
2729 fputs ("+ NULLIFY (", dmpout);
2730 assert (pointers != NULL);
2731 ffestt_exprlist_dump (pointers);
2732 fputs (")\n", dmpout);
2733#endif
2734}
2735
2736/* ffestd_R625 -- DEALLOCATE statement
2737
2738 ffestd_R625(exprlist,stat,stat_token);
2739
2740 Make sure the equivalence is valid, then implement it. */
2741
2742void
2743ffestd_R625 (ffesttExprList exprlist, ffebld stat)
2744{
2745 ffestd_check_simple_ ();
2746
2747 ffestd_subr_f90_ ();
2748 return;
2749
2750#ifdef FFESTD_F90
2751 fputs ("+ DEALLOCATE (", dmpout);
2752 ffestt_exprlist_dump (exprlist);
2753 if (stat != NULL)
2754 {
2755 fputs (",stat=", dmpout);
2756 ffebld_dump (stat);
2757 }
2758 fputs (")\n", dmpout);
2759#endif
2760}
2761
2762#endif
2763/* ffestd_R737A -- Assignment statement outside of WHERE
2764
2765 ffestd_R737A(dest_expr,source_expr); */
2766
2767void
2768ffestd_R737A (ffebld dest, ffebld source)
2769{
2770 ffestd_check_simple_ ();
2771
2772#if FFECOM_ONEPASS
2773 ffestd_subr_line_now_ ();
2774 ffeste_R737A (dest, source);
2775#else
2776 {
2777 ffestdStmt_ stmt;
2778
2779 stmt = ffestd_stmt_new_ (FFESTD_stmtidR737A_);
2780 ffestd_stmt_append_ (stmt);
2781 ffestd_subr_line_save_ (stmt);
2782 stmt->u.R737A.pool = ffesta_output_pool;
2783 stmt->u.R737A.dest = dest;
2784 stmt->u.R737A.source = source;
2785 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2786 }
2787#endif
2788}
2789
2790/* ffestd_R737B -- Assignment statement inside of WHERE
2791
2792 ffestd_R737B(dest_expr,source_expr); */
2793
2794#if FFESTR_F90
2795void
2796ffestd_R737B (ffebld dest, ffebld source)
2797{
2798 ffestd_check_simple_ ();
2799
2800 return; /* F90. */
2801
2802#ifdef FFESTD_F90
2803 fputs ("+ let_inside_where ", dmpout);
2804 ffebld_dump (dest);
2805 fputs ("=", dmpout);
2806 ffebld_dump (source);
2807 fputc ('\n', dmpout);
2808#endif
2809}
2810
2811/* ffestd_R738 -- Pointer assignment statement
2812
2813 ffestd_R738(dest_expr,source_expr,source_token);
2814
2815 Make sure the assignment is valid. */
2816
2817void
2818ffestd_R738 (ffebld dest, ffebld source)
2819{
2820 ffestd_check_simple_ ();
2821
2822 ffestd_subr_f90_ ();
2823 return;
2824
2825#ifdef FFESTD_F90
2826 fputs ("+ let_pointer ", dmpout);
2827 ffebld_dump (dest);
2828 fputs ("=>", dmpout);
2829 ffebld_dump (source);
2830 fputc ('\n', dmpout);
2831#endif
2832}
2833
2834/* ffestd_R740 -- WHERE statement
2835
2836 ffestd_R740(expr,expr_token);
2837
2838 Make sure statement is valid here; implement. */
2839
2840void
2841ffestd_R740 (ffebld expr)
2842{
2843 ffestd_check_simple_ ();
2844
2845 ffestd_subr_f90_ ();
2846 return;
2847
2848#ifdef FFESTD_F90
2849 fputs ("+ WHERE (", dmpout);
2850 ffebld_dump (expr);
2851 fputs (")\n", dmpout);
2852
2853 ++ffestd_block_level_;
2854 assert (ffestd_block_level_ > 0);
2855#endif
2856}
2857
2858/* ffestd_R742 -- WHERE-construct statement
2859
2860 ffestd_R742(expr,expr_token);
2861
2862 Make sure statement is valid here; implement. */
2863
2864void
2865ffestd_R742 (ffebld expr)
2866{
2867 ffestd_check_simple_ ();
2868
2869 ffestd_subr_f90_ ();
2870 return;
2871
2872#ifdef FFESTD_F90
2873 fputs ("+ WHERE_construct (", dmpout);
2874 ffebld_dump (expr);
2875 fputs (")\n", dmpout);
2876
2877 ++ffestd_block_level_;
2878 assert (ffestd_block_level_ > 0);
2879#endif
2880}
2881
2882/* ffestd_R744 -- ELSE WHERE statement
2883
2884 ffestd_R744();
2885
2886 Make sure ffestd_kind_ identifies a WHERE block.
2887 Implement the ELSE of the current WHERE block. */
2888
2889void
2890ffestd_R744 ()
2891{
2892 ffestd_check_simple_ ();
2893
2894 return; /* F90. */
2895
2896#ifdef FFESTD_F90
2897 fputs ("+ ELSE_WHERE\n", dmpout);
2898#endif
2899}
2900
2901/* ffestd_R745 -- Implicit END WHERE statement
2902
2903 ffestd_R745(TRUE);
2904
2905 Implement the end of the current WHERE "block". ok==TRUE iff statement
2906 following WHERE (substatement) is valid; else, statement is invalid
2907 or stack forcibly popped due to ffestd_eof_(). */
2908
2909void
2910ffestd_R745 (bool ok)
2911{
2912 return; /* F90. */
2913
2914#ifdef FFESTD_F90
2915 fputs ("+ END_WHERE\n", dmpout); /* Also see ffestd_R745. */
2916
2917 --ffestd_block_level_;
2918 assert (ffestd_block_level_ >= 0);
2919#endif
2920}
2921
2922#endif
2923/* ffestd_R803 -- Block IF (IF-THEN) statement
2924
2925 ffestd_R803(construct_name,expr,expr_token);
2926
2927 Make sure statement is valid here; implement. */
2928
2929void
2930ffestd_R803 (ffelexToken construct_name UNUSED, ffebld expr)
2931{
2932 ffestd_check_simple_ ();
2933
2934#if FFECOM_ONEPASS
2935 ffestd_subr_line_now_ ();
2936 ffeste_R803 (expr); /* Don't bother with name. */
2937#else
2938 {
2939 ffestdStmt_ stmt;
2940
2941 stmt = ffestd_stmt_new_ (FFESTD_stmtidR803_);
2942 ffestd_stmt_append_ (stmt);
2943 ffestd_subr_line_save_ (stmt);
2944 stmt->u.R803.pool = ffesta_output_pool;
2945 stmt->u.R803.expr = expr;
2946 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2947 }
2948#endif
2949
2950 ++ffestd_block_level_;
2951 assert (ffestd_block_level_ > 0);
2952}
2953
2954/* ffestd_R804 -- ELSE IF statement
2955
2956 ffestd_R804(expr,expr_token,name_token);
2957
2958 Make sure ffestd_kind_ identifies an IF block. If not
2959 NULL, make sure name_token gives the correct name. Implement the else
2960 of the IF block. */
2961
2962void
2963ffestd_R804 (ffebld expr, ffelexToken name UNUSED)
2964{
2965 ffestd_check_simple_ ();
2966
2967#if FFECOM_ONEPASS
2968 ffestd_subr_line_now_ ();
2969 ffeste_R804 (expr); /* Don't bother with name. */
2970#else
2971 {
2972 ffestdStmt_ stmt;
2973
2974 stmt = ffestd_stmt_new_ (FFESTD_stmtidR804_);
2975 ffestd_stmt_append_ (stmt);
2976 ffestd_subr_line_save_ (stmt);
2977 stmt->u.R804.pool = ffesta_output_pool;
2978 stmt->u.R804.expr = expr;
2979 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2980 }
2981#endif
2982}
2983
2984/* ffestd_R805 -- ELSE statement
2985
2986 ffestd_R805(name_token);
2987
2988 Make sure ffestd_kind_ identifies an IF block. If not
2989 NULL, make sure name_token gives the correct name. Implement the ELSE
2990 of the IF block. */
2991
2992void
2993ffestd_R805 (ffelexToken name UNUSED)
2994{
2995 ffestd_check_simple_ ();
2996
2997#if FFECOM_ONEPASS
2998 ffestd_subr_line_now_ ();
2999 ffeste_R805 (); /* Don't bother with name. */
3000#else
3001 {
3002 ffestdStmt_ stmt;
3003
3004 stmt = ffestd_stmt_new_ (FFESTD_stmtidR805_);
3005 ffestd_stmt_append_ (stmt);
3006 ffestd_subr_line_save_ (stmt);
3007 }
3008#endif
3009}
3010
3011/* ffestd_R806 -- End an IF-THEN
3012
3013 ffestd_R806(TRUE); */
3014
3015void
3016ffestd_R806 (bool ok UNUSED)
3017{
3018#if FFECOM_ONEPASS
3019 ffestd_subr_line_now_ ();
3020 ffeste_R806 ();
3021#else
3022 {
3023 ffestdStmt_ stmt;
3024
3025 stmt = ffestd_stmt_new_ (FFESTD_stmtidR806_);
3026 ffestd_stmt_append_ (stmt);
3027 ffestd_subr_line_save_ (stmt);
3028 }
3029#endif
3030
3031 --ffestd_block_level_;
3032 assert (ffestd_block_level_ >= 0);
3033}
3034
3035/* ffestd_R807 -- Logical IF statement
3036
3037 ffestd_R807(expr,expr_token);
3038
3039 Make sure statement is valid here; implement. */
3040
3041void
3042ffestd_R807 (ffebld expr)
3043{
3044 ffestd_check_simple_ ();
3045
3046#if FFECOM_ONEPASS
3047 ffestd_subr_line_now_ ();
3048 ffeste_R807 (expr);
3049#else
3050 {
3051 ffestdStmt_ stmt;
3052
3053 stmt = ffestd_stmt_new_ (FFESTD_stmtidR807_);
3054 ffestd_stmt_append_ (stmt);
3055 ffestd_subr_line_save_ (stmt);
3056 stmt->u.R807.pool = ffesta_output_pool;
3057 stmt->u.R807.expr = expr;
3058 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3059 }
3060#endif
3061
3062 ++ffestd_block_level_;
3063 assert (ffestd_block_level_ > 0);
3064}
3065
3066/* ffestd_R809 -- SELECT CASE statement
3067
3068 ffestd_R809(construct_name,expr,expr_token);
3069
3070 Make sure statement is valid here; implement. */
3071
3072void
3073ffestd_R809 (ffelexToken construct_name UNUSED, ffebld expr)
3074{
3075 ffestd_check_simple_ ();
3076
3077#if FFECOM_ONEPASS
3078 ffestd_subr_line_now_ ();
3079 ffeste_R809 (ffestw_stack_top (), expr);
3080#else
3081 {
3082 ffestdStmt_ stmt;
3083
3084 stmt = ffestd_stmt_new_ (FFESTD_stmtidR809_);
3085 ffestd_stmt_append_ (stmt);
3086 ffestd_subr_line_save_ (stmt);
3087 stmt->u.R809.pool = ffesta_output_pool;
3088 stmt->u.R809.block = ffestw_use (ffestw_stack_top ());
3089 stmt->u.R809.expr = expr;
3090 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3091 malloc_pool_use (ffestw_select (ffestw_stack_top ())->pool);
3092 }
3093#endif
3094
3095 ++ffestd_block_level_;
3096 assert (ffestd_block_level_ > 0);
3097}
3098
3099/* ffestd_R810 -- CASE statement
3100
3101 ffestd_R810(case_value_range_list,name);
3102
3103 If casenum is 0, it's CASE DEFAULT. Else it's the case ranges at
3104 the start of the first_stmt list in the select object at the top of
3105 the stack that match casenum. */
3106
3107void
3108ffestd_R810 (unsigned long casenum)
3109{
3110 ffestd_check_simple_ ();
3111
3112#if FFECOM_ONEPASS
3113 ffestd_subr_line_now_ ();
3114 ffeste_R810 (ffestw_stack_top (), casenum);
3115#else
3116 {
3117 ffestdStmt_ stmt;
3118
3119 stmt = ffestd_stmt_new_ (FFESTD_stmtidR810_);
3120 ffestd_stmt_append_ (stmt);
3121 ffestd_subr_line_save_ (stmt);
3122 stmt->u.R810.pool = ffesta_output_pool;
3123 stmt->u.R810.block = ffestw_stack_top ();
3124 stmt->u.R810.casenum = casenum;
3125 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3126 }
3127#endif
3128}
3129
3130/* ffestd_R811 -- End a SELECT
3131
3132 ffestd_R811(TRUE); */
3133
3134void
3135ffestd_R811 (bool ok UNUSED)
3136{
3137#if FFECOM_ONEPASS
3138 ffestd_subr_line_now_ ();
3139 ffeste_R811 (ffestw_stack_top ());
3140#else
3141 {
3142 ffestdStmt_ stmt;
3143
3144 stmt = ffestd_stmt_new_ (FFESTD_stmtidR811_);
3145 ffestd_stmt_append_ (stmt);
3146 ffestd_subr_line_save_ (stmt);
3147 stmt->u.R811.block = ffestw_stack_top ();
3148 }
3149#endif
3150
3151 --ffestd_block_level_;
3152 assert (ffestd_block_level_ >= 0);
3153}
3154
3155/* ffestd_R819A -- Iterative DO statement
3156
3157 ffestd_R819A(construct_name,label_token,expr,expr_token);
3158
3159 Make sure statement is valid here; implement. */
3160
3161void
3162ffestd_R819A (ffelexToken construct_name UNUSED, ffelab label,
3163 ffebld var, ffebld start, ffelexToken start_token,
3164 ffebld end, ffelexToken end_token,
3165 ffebld incr, ffelexToken incr_token)
3166{
3167 ffestd_check_simple_ ();
3168
3169#if FFECOM_ONEPASS
3170 ffestd_subr_line_now_ ();
3171 ffeste_R819A (ffestw_stack_top (), label, var, start, end, incr,
3172 incr_token);
3173#else
3174 {
3175 ffestdStmt_ stmt;
3176
3177 stmt = ffestd_stmt_new_ (FFESTD_stmtidR819A_);
3178 ffestd_stmt_append_ (stmt);
3179 ffestd_subr_line_save_ (stmt);
3180 stmt->u.R819A.pool = ffesta_output_pool;
3181 stmt->u.R819A.block = ffestw_use (ffestw_stack_top ());
3182 stmt->u.R819A.label = label;
3183 stmt->u.R819A.var = var;
3184 stmt->u.R819A.start = start;
3185 stmt->u.R819A.start_token = ffelex_token_use (start_token);
3186 stmt->u.R819A.end = end;
3187 stmt->u.R819A.end_token = ffelex_token_use (end_token);
3188 stmt->u.R819A.incr = incr;
3189 stmt->u.R819A.incr_token = (incr_token == NULL) ? NULL
3190 : ffelex_token_use (incr_token);
3191 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3192 }
3193#endif
3194
3195 ++ffestd_block_level_;
3196 assert (ffestd_block_level_ > 0);
3197}
3198
3199/* ffestd_R819B -- DO WHILE statement
3200
3201 ffestd_R819B(construct_name,label_token,expr,expr_token);
3202
3203 Make sure statement is valid here; implement. */
3204
3205void
3206ffestd_R819B (ffelexToken construct_name UNUSED, ffelab label,
3207 ffebld expr)
3208{
3209 ffestd_check_simple_ ();
3210
3211#if FFECOM_ONEPASS
3212 ffestd_subr_line_now_ ();
3213 ffeste_R819B (ffestw_stack_top (), label, expr);
3214#else
3215 {
3216 ffestdStmt_ stmt;
3217
3218 stmt = ffestd_stmt_new_ (FFESTD_stmtidR819B_);
3219 ffestd_stmt_append_ (stmt);
3220 ffestd_subr_line_save_ (stmt);
3221 stmt->u.R819B.pool = ffesta_output_pool;
3222 stmt->u.R819B.block = ffestw_use (ffestw_stack_top ());
3223 stmt->u.R819B.label = label;
3224 stmt->u.R819B.expr = expr;
3225 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3226 }
3227#endif
3228
3229 ++ffestd_block_level_;
3230 assert (ffestd_block_level_ > 0);
3231}
3232
3233/* ffestd_R825 -- END DO statement
3234
3235 ffestd_R825(name_token);
3236
3237 Make sure ffestd_kind_ identifies a DO block. If not
3238 NULL, make sure name_token gives the correct name. Do whatever
3239 is specific to seeing END DO with a DO-target label definition on it,
3240 where the END DO is really treated as a CONTINUE (i.e. generate th
3241 same code you would for CONTINUE). ffestd_do handles the actual
3242 generation of end-loop code. */
3243
3244void
3245ffestd_R825 (ffelexToken name UNUSED)
3246{
3247 ffestd_check_simple_ ();
3248
3249#if FFECOM_ONEPASS
3250 ffestd_subr_line_now_ ();
3251 ffeste_R825 ();
3252#else
3253 {
3254 ffestdStmt_ stmt;
3255
3256 stmt = ffestd_stmt_new_ (FFESTD_stmtidR825_);
3257 ffestd_stmt_append_ (stmt);
3258 ffestd_subr_line_save_ (stmt);
3259 }
3260#endif
3261}
3262
3263/* ffestd_R834 -- CYCLE statement
3264
3265 ffestd_R834(name_token);
3266
3267 Handle a CYCLE within a loop. */
3268
3269void
3270ffestd_R834 (ffestw block)
3271{
3272 ffestd_check_simple_ ();
3273
3274#if FFECOM_ONEPASS
3275 ffestd_subr_line_now_ ();
3276 ffeste_R834 (block);
3277#else
3278 {
3279 ffestdStmt_ stmt;
3280
3281 stmt = ffestd_stmt_new_ (FFESTD_stmtidR834_);
3282 ffestd_stmt_append_ (stmt);
3283 ffestd_subr_line_save_ (stmt);
3284 stmt->u.R834.block = block;
3285 }
3286#endif
3287}
3288
3289/* ffestd_R835 -- EXIT statement
3290
3291 ffestd_R835(name_token);
3292
3293 Handle a EXIT within a loop. */
3294
3295void
3296ffestd_R835 (ffestw block)
3297{
3298 ffestd_check_simple_ ();
3299
3300#if FFECOM_ONEPASS
3301 ffestd_subr_line_now_ ();
3302 ffeste_R835 (block);
3303#else
3304 {
3305 ffestdStmt_ stmt;
3306
3307 stmt = ffestd_stmt_new_ (FFESTD_stmtidR835_);
3308 ffestd_stmt_append_ (stmt);
3309 ffestd_subr_line_save_ (stmt);
3310 stmt->u.R835.block = block;
3311 }
3312#endif
3313}
3314
3315/* ffestd_R836 -- GOTO statement
3316
3317 ffestd_R836(label);
3318
3319 Make sure label_token identifies a valid label for a GOTO. Update
3320 that label's info to indicate it is the target of a GOTO. */
3321
3322void
3323ffestd_R836 (ffelab label)
3324{
3325 ffestd_check_simple_ ();
3326
3327#if FFECOM_ONEPASS
3328 ffestd_subr_line_now_ ();
3329 ffeste_R836 (label);
3330#else
3331 {
3332 ffestdStmt_ stmt;
3333
3334 stmt = ffestd_stmt_new_ (FFESTD_stmtidR836_);
3335 ffestd_stmt_append_ (stmt);
3336 ffestd_subr_line_save_ (stmt);
3337 stmt->u.R836.label = label;
3338 }
3339#endif
3340
3341 if (ffestd_block_level_ == 0)
3342 ffestd_is_reachable_ = FALSE;
3343}
3344
3345/* ffestd_R837 -- Computed GOTO statement
3346
3347 ffestd_R837(labels,expr);
3348
3349 Make sure label_list identifies valid labels for a GOTO. Update
3350 each label's info to indicate it is the target of a GOTO. */
3351
3352void
3353ffestd_R837 (ffelab *labels, int count, ffebld expr)
3354{
3355 ffestd_check_simple_ ();
3356
3357#if FFECOM_ONEPASS
3358 ffestd_subr_line_now_ ();
3359 ffeste_R837 (labels, count, expr);
3360#else
3361 {
3362 ffestdStmt_ stmt;
3363
3364 stmt = ffestd_stmt_new_ (FFESTD_stmtidR837_);
3365 ffestd_stmt_append_ (stmt);
3366 ffestd_subr_line_save_ (stmt);
3367 stmt->u.R837.pool = ffesta_output_pool;
3368 stmt->u.R837.labels = labels;
3369 stmt->u.R837.count = count;
3370 stmt->u.R837.expr = expr;
3371 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3372 }
3373#endif
3374}
3375
3376/* ffestd_R838 -- ASSIGN statement
3377
3378 ffestd_R838(label_token,target_variable,target_token);
3379
3380 Make sure label_token identifies a valid label for an assignment. Update
3381 that label's info to indicate it is the source of an assignment. Update
3382 target_variable's info to indicate it is the target the assignment of that
3383 label. */
3384
3385void
3386ffestd_R838 (ffelab label, ffebld target)
3387{
3388 ffestd_check_simple_ ();
3389
3390#if FFECOM_ONEPASS
3391 ffestd_subr_line_now_ ();
3392 ffeste_R838 (label, target);
3393#else
3394 {
3395 ffestdStmt_ stmt;
3396
3397 stmt = ffestd_stmt_new_ (FFESTD_stmtidR838_);
3398 ffestd_stmt_append_ (stmt);
3399 ffestd_subr_line_save_ (stmt);
3400 stmt->u.R838.pool = ffesta_output_pool;
3401 stmt->u.R838.label = label;
3402 stmt->u.R838.target = target;
3403 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3404 }
3405#endif
3406}
3407
3408/* ffestd_R839 -- Assigned GOTO statement
3409
3410 ffestd_R839(target,labels);
3411
3412 Make sure label_list identifies valid labels for a GOTO. Update
3413 each label's info to indicate it is the target of a GOTO. */
3414
3415void
3416ffestd_R839 (ffebld target, ffelab *labels UNUSED, int count UNUSED)
3417{
3418 ffestd_check_simple_ ();
3419
3420#if FFECOM_ONEPASS
3421 ffestd_subr_line_now_ ();
3422 ffeste_R839 (target);
3423#else
3424 {
3425 ffestdStmt_ stmt;
3426
3427 stmt = ffestd_stmt_new_ (FFESTD_stmtidR839_);
3428 ffestd_stmt_append_ (stmt);
3429 ffestd_subr_line_save_ (stmt);
3430 stmt->u.R839.pool = ffesta_output_pool;
3431 stmt->u.R839.target = target;
3432 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3433 }
3434#endif
3435
3436 if (ffestd_block_level_ == 0)
3437 ffestd_is_reachable_ = FALSE;
3438}
3439
3440/* ffestd_R840 -- Arithmetic IF statement
3441
3442 ffestd_R840(expr,expr_token,neg,zero,pos);
3443
3444 Make sure the labels are valid; implement. */
3445
3446void
3447ffestd_R840 (ffebld expr, ffelab neg, ffelab zero, ffelab pos)
3448{
3449 ffestd_check_simple_ ();
3450
3451#if FFECOM_ONEPASS
3452 ffestd_subr_line_now_ ();
3453 ffeste_R840 (expr, neg, zero, pos);
3454#else
3455 {
3456 ffestdStmt_ stmt;
3457
3458 stmt = ffestd_stmt_new_ (FFESTD_stmtidR840_);
3459 ffestd_stmt_append_ (stmt);
3460 ffestd_subr_line_save_ (stmt);
3461 stmt->u.R840.pool = ffesta_output_pool;
3462 stmt->u.R840.expr = expr;
3463 stmt->u.R840.neg = neg;
3464 stmt->u.R840.zero = zero;
3465 stmt->u.R840.pos = pos;
3466 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3467 }
3468#endif
3469
3470 if (ffestd_block_level_ == 0)
3471 ffestd_is_reachable_ = FALSE;
3472}
3473
3474/* ffestd_R841 -- CONTINUE statement
3475
3476 ffestd_R841(); */
3477
3478void
3479ffestd_R841 (bool in_where UNUSED)
3480{
3481 ffestd_check_simple_ ();
3482
3483#if FFECOM_ONEPASS
3484 ffestd_subr_line_now_ ();
3485 ffeste_R841 ();
3486#else
3487 {
3488 ffestdStmt_ stmt;
3489
3490 stmt = ffestd_stmt_new_ (FFESTD_stmtidR841_);
3491 ffestd_stmt_append_ (stmt);
3492 ffestd_subr_line_save_ (stmt);
3493 }
3494#endif
3495}
3496
3497/* ffestd_R842 -- STOP statement
3498
3499 ffestd_R842(expr); */
3500
3501void
3502ffestd_R842 (ffebld expr)
3503{
3504 ffestd_check_simple_ ();
3505
3506#if FFECOM_ONEPASS
3507 ffestd_subr_line_now_ ();
3508 ffeste_R842 (expr);
3509#else
3510 {
3511 ffestdStmt_ stmt;
3512
3513 stmt = ffestd_stmt_new_ (FFESTD_stmtidR842_);
3514 ffestd_stmt_append_ (stmt);
3515 ffestd_subr_line_save_ (stmt);
3516 stmt->u.R842.pool = ffesta_output_pool;
3517 stmt->u.R842.expr = expr;
3518 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3519 }
3520#endif
3521
3522 if (ffestd_block_level_ == 0)
3523 ffestd_is_reachable_ = FALSE;
3524}
3525
3526/* ffestd_R843 -- PAUSE statement
3527
3528 ffestd_R843(expr,expr_token);
3529
3530 Make sure statement is valid here; implement. expr and expr_token are
3531 both NULL if there was no expression. */
3532
3533void
3534ffestd_R843 (ffebld expr)
3535{
3536 ffestd_check_simple_ ();
3537
3538#if FFECOM_ONEPASS
3539 ffestd_subr_line_now_ ();
3540 ffeste_R843 (expr);
3541#else
3542 {
3543 ffestdStmt_ stmt;
3544
3545 stmt = ffestd_stmt_new_ (FFESTD_stmtidR843_);
3546 ffestd_stmt_append_ (stmt);
3547 ffestd_subr_line_save_ (stmt);
3548 stmt->u.R843.pool = ffesta_output_pool;
3549 stmt->u.R843.expr = expr;
3550 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3551 }
3552#endif
3553}
3554
3555/* ffestd_R904 -- OPEN statement
3556
3557 ffestd_R904();
3558
3559 Make sure an OPEN is valid in the current context, and implement it. */
3560
3561void
3562ffestd_R904 ()
3563{
3564 ffestd_check_simple_ ();
3565
3566#if FFECOM_targetCURRENT == FFECOM_targetGCC
3567#define specified(something) \
3568 (ffestp_file.open.open_spec[something].kw_or_val_present)
3569
3570 /* Warn if there are any thing we don't handle via f2c libraries. */
3571
3572 if (specified (FFESTP_openixACTION)
3573 || specified (FFESTP_openixASSOCIATEVARIABLE)
3574 || specified (FFESTP_openixBLOCKSIZE)
3575 || specified (FFESTP_openixBUFFERCOUNT)
3576 || specified (FFESTP_openixCARRIAGECONTROL)
3577 || specified (FFESTP_openixDEFAULTFILE)
3578 || specified (FFESTP_openixDELIM)
3579 || specified (FFESTP_openixDISPOSE)
3580 || specified (FFESTP_openixEXTENDSIZE)
3581 || specified (FFESTP_openixINITIALSIZE)
3582 || specified (FFESTP_openixKEY)
3583 || specified (FFESTP_openixMAXREC)
3584 || specified (FFESTP_openixNOSPANBLOCKS)
3585 || specified (FFESTP_openixORGANIZATION)
3586 || specified (FFESTP_openixPAD)
3587 || specified (FFESTP_openixPOSITION)
3588 || specified (FFESTP_openixREADONLY)
3589 || specified (FFESTP_openixRECORDTYPE)
3590 || specified (FFESTP_openixSHARED)
3591 || specified (FFESTP_openixUSEROPEN))
3592 {
3593 ffebad_start (FFEBAD_OPEN_UNSUPPORTED);
3594 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
3595 ffelex_token_where_column (ffesta_tokens[0]));
3596 ffebad_finish ();
3597 }
3598
3599#undef specified
3600#endif
3601
3602#if FFECOM_ONEPASS
3603 ffestd_subr_line_now_ ();
3604 ffeste_R904 (&ffestp_file.open);
3605#else
3606 {
3607 ffestdStmt_ stmt;
3608
3609 stmt = ffestd_stmt_new_ (FFESTD_stmtidR904_);
3610 ffestd_stmt_append_ (stmt);
3611 ffestd_subr_line_save_ (stmt);
3612 stmt->u.R904.pool = ffesta_output_pool;
3613 stmt->u.R904.params = ffestd_subr_copy_open_ ();
3614 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3615 }
3616#endif
3617}
3618
3619/* ffestd_R907 -- CLOSE statement
3620
3621 ffestd_R907();
3622
3623 Make sure a CLOSE is valid in the current context, and implement it. */
3624
3625void
3626ffestd_R907 ()
3627{
3628 ffestd_check_simple_ ();
3629
3630#if FFECOM_ONEPASS
3631 ffestd_subr_line_now_ ();
3632 ffeste_R907 (&ffestp_file.close);
3633#else
3634 {
3635 ffestdStmt_ stmt;
3636
3637 stmt = ffestd_stmt_new_ (FFESTD_stmtidR907_);
3638 ffestd_stmt_append_ (stmt);
3639 ffestd_subr_line_save_ (stmt);
3640 stmt->u.R907.pool = ffesta_output_pool;
3641 stmt->u.R907.params = ffestd_subr_copy_close_ ();
3642 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3643 }
3644#endif
3645}
3646
3647/* ffestd_R909_start -- READ(...) statement list begin
3648
3649 ffestd_R909_start(FALSE);
3650
3651 Verify that READ is valid here, and begin accepting items in the
3652 list. */
3653
3654void
3655ffestd_R909_start (bool only_format, ffestvUnit unit,
3656 ffestvFormat format, bool rec, bool key)
3657{
3658 ffestd_check_start_ ();
3659
3660#if FFECOM_targetCURRENT == FFECOM_targetGCC
3661#define specified(something) \
3662 (ffestp_file.read.read_spec[something].kw_or_val_present)
3663
3664 /* Warn if there are any thing we don't handle via f2c libraries. */
3665 if (specified (FFESTP_readixADVANCE)
3666 || specified (FFESTP_readixEOR)
3667 || specified (FFESTP_readixKEYEQ)
3668 || specified (FFESTP_readixKEYGE)
3669 || specified (FFESTP_readixKEYGT)
3670 || specified (FFESTP_readixKEYID)
3671 || specified (FFESTP_readixNULLS)
3672 || specified (FFESTP_readixSIZE))
3673 {
3674 ffebad_start (FFEBAD_READ_UNSUPPORTED);
3675 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
3676 ffelex_token_where_column (ffesta_tokens[0]));
3677 ffebad_finish ();
3678 }
3679
3680#undef specified
3681#endif
3682
3683#if FFECOM_ONEPASS
3684 ffestd_subr_line_now_ ();
3685 ffeste_R909_start (&ffestp_file.read, only_format, unit, format, rec, key);
3686#else
3687 {
3688 ffestdStmt_ stmt;
3689
3690 stmt = ffestd_stmt_new_ (FFESTD_stmtidR909_);
3691 ffestd_stmt_append_ (stmt);
3692 ffestd_subr_line_save_ (stmt);
3693 stmt->u.R909.pool = ffesta_output_pool;
3694 stmt->u.R909.params = ffestd_subr_copy_read_ ();
3695 stmt->u.R909.only_format = only_format;
3696 stmt->u.R909.unit = unit;
3697 stmt->u.R909.format = format;
3698 stmt->u.R909.rec = rec;
3699 stmt->u.R909.key = key;
3700 stmt->u.R909.list = NULL;
3701 ffestd_expr_list_ = &stmt->u.R909.list;
3702 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3703 }
3704#endif
3705}
3706
3707/* ffestd_R909_item -- READ statement i/o item
3708
3709 ffestd_R909_item(expr,expr_token);
3710
3711 Implement output-list expression. */
3712
3713void
3714ffestd_R909_item (ffebld expr, ffelexToken expr_token)
3715{
3716 ffestd_check_item_ ();
3717
3718#if FFECOM_ONEPASS
3719 ffeste_R909_item (expr);
3720#else
3721 {
3722 ffestdExprItem_ item
3723 = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, "ffestdExprItem_",
3724 sizeof (*item));
3725
3726 item->next = NULL;
3727 item->expr = expr;
3728 item->token = ffelex_token_use (expr_token);
3729 *ffestd_expr_list_ = item;
3730 ffestd_expr_list_ = &item->next;
3731 }
3732#endif
3733}
3734
3735/* ffestd_R909_finish -- READ statement list complete
3736
3737 ffestd_R909_finish();
3738
3739 Just wrap up any local activities. */
3740
3741void
3742ffestd_R909_finish ()
3743{
3744 ffestd_check_finish_ ();
3745
3746#if FFECOM_ONEPASS
3747 ffeste_R909_finish ();
3748#else
3749 /* Nothing to do, it's implicit. */
3750#endif
3751}
3752
3753/* ffestd_R910_start -- WRITE(...) statement list begin
3754
3755 ffestd_R910_start();
3756
3757 Verify that WRITE is valid here, and begin accepting items in the
3758 list. */
3759
3760void
3761ffestd_R910_start (ffestvUnit unit, ffestvFormat format, bool rec)
3762{
3763 ffestd_check_start_ ();
3764
3765#if FFECOM_targetCURRENT == FFECOM_targetGCC
3766#define specified(something) \
3767 (ffestp_file.write.write_spec[something].kw_or_val_present)
3768
3769 /* Warn if there are any thing we don't handle via f2c libraries. */
3770 if (specified (FFESTP_writeixADVANCE)
3771 || specified (FFESTP_writeixEOR))
3772 {
3773 ffebad_start (FFEBAD_WRITE_UNSUPPORTED);
3774 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
3775 ffelex_token_where_column (ffesta_tokens[0]));
3776 ffebad_finish ();
3777 }
3778
3779#undef specified
3780#endif
3781
3782#if FFECOM_ONEPASS
3783 ffestd_subr_line_now_ ();
3784 ffeste_R910_start (&ffestp_file.write, unit, format, rec);
3785#else
3786 {
3787 ffestdStmt_ stmt;
3788
3789 stmt = ffestd_stmt_new_ (FFESTD_stmtidR910_);
3790 ffestd_stmt_append_ (stmt);
3791 ffestd_subr_line_save_ (stmt);
3792 stmt->u.R910.pool = ffesta_output_pool;
3793 stmt->u.R910.params = ffestd_subr_copy_write_ ();
3794 stmt->u.R910.unit = unit;
3795 stmt->u.R910.format = format;
3796 stmt->u.R910.rec = rec;
3797 stmt->u.R910.list = NULL;
3798 ffestd_expr_list_ = &stmt->u.R910.list;
3799 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3800 }
3801#endif
3802}
3803
3804/* ffestd_R910_item -- WRITE statement i/o item
3805
3806 ffestd_R910_item(expr,expr_token);
3807
3808 Implement output-list expression. */
3809
3810void
3811ffestd_R910_item (ffebld expr, ffelexToken expr_token)
3812{
3813 ffestd_check_item_ ();
3814
3815#if FFECOM_ONEPASS
3816 ffeste_R910_item (expr);
3817#else
3818 {
3819 ffestdExprItem_ item
3820 = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, "ffestdExprItem_",
3821 sizeof (*item));
3822
3823 item->next = NULL;
3824 item->expr = expr;
3825 item->token = ffelex_token_use (expr_token);
3826 *ffestd_expr_list_ = item;
3827 ffestd_expr_list_ = &item->next;
3828 }
3829#endif
3830}
3831
3832/* ffestd_R910_finish -- WRITE statement list complete
3833
3834 ffestd_R910_finish();
3835
3836 Just wrap up any local activities. */
3837
3838void
3839ffestd_R910_finish ()
3840{
3841 ffestd_check_finish_ ();
3842
3843#if FFECOM_ONEPASS
3844 ffeste_R910_finish ();
3845#else
3846 /* Nothing to do, it's implicit. */
3847#endif
3848}
3849
3850/* ffestd_R911_start -- PRINT statement list begin
3851
3852 ffestd_R911_start();
3853
3854 Verify that PRINT is valid here, and begin accepting items in the
3855 list. */
3856
3857void
3858ffestd_R911_start (ffestvFormat format)
3859{
3860 ffestd_check_start_ ();
3861
3862#if FFECOM_ONEPASS
3863 ffestd_subr_line_now_ ();
3864 ffeste_R911_start (&ffestp_file.print, format);
3865#else
3866 {
3867 ffestdStmt_ stmt;
3868
3869 stmt = ffestd_stmt_new_ (FFESTD_stmtidR911_);
3870 ffestd_stmt_append_ (stmt);
3871 ffestd_subr_line_save_ (stmt);
3872 stmt->u.R911.pool = ffesta_output_pool;
3873 stmt->u.R911.params = ffestd_subr_copy_print_ ();
3874 stmt->u.R911.format = format;
3875 stmt->u.R911.list = NULL;
3876 ffestd_expr_list_ = &stmt->u.R911.list;
3877 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3878 }
3879#endif
3880}
3881
3882/* ffestd_R911_item -- PRINT statement i/o item
3883
3884 ffestd_R911_item(expr,expr_token);
3885
3886 Implement output-list expression. */
3887
3888void
3889ffestd_R911_item (ffebld expr, ffelexToken expr_token)
3890{
3891 ffestd_check_item_ ();
3892
3893#if FFECOM_ONEPASS
3894 ffeste_R911_item (expr);
3895#else
3896 {
3897 ffestdExprItem_ item
3898 = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, "ffestdExprItem_",
3899 sizeof (*item));
3900
3901 item->next = NULL;
3902 item->expr = expr;
3903 item->token = ffelex_token_use (expr_token);
3904 *ffestd_expr_list_ = item;
3905 ffestd_expr_list_ = &item->next;
3906 }
3907#endif
3908}
3909
3910/* ffestd_R911_finish -- PRINT statement list complete
3911
3912 ffestd_R911_finish();
3913
3914 Just wrap up any local activities. */
3915
3916void
3917ffestd_R911_finish ()
3918{
3919 ffestd_check_finish_ ();
3920
3921#if FFECOM_ONEPASS
3922 ffeste_R911_finish ();
3923#else
3924 /* Nothing to do, it's implicit. */
3925#endif
3926}
3927
3928/* ffestd_R919 -- BACKSPACE statement
3929
3930 ffestd_R919();
3931
3932 Make sure a BACKSPACE is valid in the current context, and implement it. */
3933
3934void
3935ffestd_R919 ()
3936{
3937 ffestd_check_simple_ ();
3938
3939#if FFECOM_ONEPASS
3940 ffestd_subr_line_now_ ();
3941 ffeste_R919 (&ffestp_file.beru);
3942#else
3943 {
3944 ffestdStmt_ stmt;
3945
3946 stmt = ffestd_stmt_new_ (FFESTD_stmtidR919_);
3947 ffestd_stmt_append_ (stmt);
3948 ffestd_subr_line_save_ (stmt);
3949 stmt->u.R919.pool = ffesta_output_pool;
3950 stmt->u.R919.params = ffestd_subr_copy_beru_ ();
3951 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3952 }
3953#endif
3954}
3955
3956/* ffestd_R920 -- ENDFILE statement
3957
3958 ffestd_R920();
3959
3960 Make sure a ENDFILE is valid in the current context, and implement it. */
3961
3962void
3963ffestd_R920 ()
3964{
3965 ffestd_check_simple_ ();
3966
3967#if FFECOM_ONEPASS
3968 ffestd_subr_line_now_ ();
3969 ffeste_R920 (&ffestp_file.beru);
3970#else
3971 {
3972 ffestdStmt_ stmt;
3973
3974 stmt = ffestd_stmt_new_ (FFESTD_stmtidR920_);
3975 ffestd_stmt_append_ (stmt);
3976 ffestd_subr_line_save_ (stmt);
3977 stmt->u.R920.pool = ffesta_output_pool;
3978 stmt->u.R920.params = ffestd_subr_copy_beru_ ();
3979 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3980 }
3981#endif
3982}
3983
3984/* ffestd_R921 -- REWIND statement
3985
3986 ffestd_R921();
3987
3988 Make sure a REWIND is valid in the current context, and implement it. */
3989
3990void
3991ffestd_R921 ()
3992{
3993 ffestd_check_simple_ ();
3994
3995#if FFECOM_ONEPASS
3996 ffestd_subr_line_now_ ();
3997 ffeste_R921 (&ffestp_file.beru);
3998#else
3999 {
4000 ffestdStmt_ stmt;
4001
4002 stmt = ffestd_stmt_new_ (FFESTD_stmtidR921_);
4003 ffestd_stmt_append_ (stmt);
4004 ffestd_subr_line_save_ (stmt);
4005 stmt->u.R921.pool = ffesta_output_pool;
4006 stmt->u.R921.params = ffestd_subr_copy_beru_ ();
4007 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
4008 }
4009#endif
4010}
4011
4012/* ffestd_R923A -- INQUIRE statement (non-IOLENGTH version)
4013
4014 ffestd_R923A(bool by_file);
4015
4016 Make sure an INQUIRE is valid in the current context, and implement it. */
4017
4018void
4019ffestd_R923A (bool by_file)
4020{
4021 ffestd_check_simple_ ();
4022
4023#if FFECOM_targetCURRENT == FFECOM_targetGCC
4024#define specified(something) \
4025 (ffestp_file.inquire.inquire_spec[something].kw_or_val_present)
4026
4027 /* Warn if there are any thing we don't handle via f2c libraries. */
4028 if (specified (FFESTP_inquireixACTION)
4029 || specified (FFESTP_inquireixCARRIAGECONTROL)
4030 || specified (FFESTP_inquireixDEFAULTFILE)
4031 || specified (FFESTP_inquireixDELIM)
4032 || specified (FFESTP_inquireixKEYED)
4033 || specified (FFESTP_inquireixORGANIZATION)
4034 || specified (FFESTP_inquireixPAD)
4035 || specified (FFESTP_inquireixPOSITION)
4036 || specified (FFESTP_inquireixREAD)
4037 || specified (FFESTP_inquireixREADWRITE)
4038 || specified (FFESTP_inquireixRECORDTYPE)
4039 || specified (FFESTP_inquireixWRITE))
4040 {
4041 ffebad_start (FFEBAD_INQUIRE_UNSUPPORTED);
4042 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
4043 ffelex_token_where_column (ffesta_tokens[0]));
4044 ffebad_finish ();
4045 }
4046
4047#undef specified
4048#endif
4049
4050#if FFECOM_ONEPASS
4051 ffestd_subr_line_now_ ();
4052 ffeste_R923A (&ffestp_file.inquire, by_file);
4053#else
4054 {
4055 ffestdStmt_ stmt;
4056
4057 stmt = ffestd_stmt_new_ (FFESTD_stmtidR923A_);
4058 ffestd_stmt_append_ (stmt);
4059 ffestd_subr_line_save_ (stmt);
4060 stmt->u.R923A.pool = ffesta_output_pool;
4061 stmt->u.R923A.params = ffestd_subr_copy_inquire_ ();
4062 stmt->u.R923A.by_file = by_file;
4063 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
4064 }
4065#endif
4066}
4067
4068/* ffestd_R923B_start -- INQUIRE(IOLENGTH=expr) statement list begin
4069
4070 ffestd_R923B_start();
4071
4072 Verify that INQUIRE is valid here, and begin accepting items in the
4073 list. */
4074
4075void
4076ffestd_R923B_start ()
4077{
4078 ffestd_check_start_ ();
4079
4080#if FFECOM_ONEPASS
4081 ffestd_subr_line_now_ ();
4082 ffeste_R923B_start (&ffestp_file.inquire);
4083#else
4084 {
4085 ffestdStmt_ stmt;
4086
4087 stmt = ffestd_stmt_new_ (FFESTD_stmtidR923B_);
4088 ffestd_stmt_append_ (stmt);
4089 ffestd_subr_line_save_ (stmt);
4090 stmt->u.R923B.pool = ffesta_output_pool;
4091 stmt->u.R923B.params = ffestd_subr_copy_inquire_ ();
4092 stmt->u.R923B.list = NULL;
4093 ffestd_expr_list_ = &stmt->u.R923B.list;
4094 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
4095 }
4096#endif
4097}
4098
4099/* ffestd_R923B_item -- INQUIRE statement i/o item
4100
4101 ffestd_R923B_item(expr,expr_token);
4102
4103 Implement output-list expression. */
4104
4105void
4106ffestd_R923B_item (ffebld expr)
4107{
4108 ffestd_check_item_ ();
4109
4110#if FFECOM_ONEPASS
4111 ffeste_R923B_item (expr);
4112#else
4113 {
4114 ffestdExprItem_ item
4115 = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, "ffestdExprItem_",
4116 sizeof (*item));
4117
4118 item->next = NULL;
4119 item->expr = expr;
4120 *ffestd_expr_list_ = item;
4121 ffestd_expr_list_ = &item->next;
4122 }
4123#endif
4124}
4125
4126/* ffestd_R923B_finish -- INQUIRE statement list complete
4127
4128 ffestd_R923B_finish();
4129
4130 Just wrap up any local activities. */
4131
4132void
4133ffestd_R923B_finish ()
4134{
4135 ffestd_check_finish_ ();
4136
4137#if FFECOM_ONEPASS
4138 ffeste_R923B_finish ();
4139#else
4140 /* Nothing to do, it's implicit. */
4141#endif
4142}
4143
4144/* ffestd_R1001 -- FORMAT statement
4145
4146 ffestd_R1001(format_list); */
4147
4148void
4149ffestd_R1001 (ffesttFormatList f)
4150{
4151 ffestsHolder str;
4152 ffests s = &str;
4153
4154 ffestd_check_simple_ ();
4155
4156 if (ffestd_label_formatdef_ == NULL)
4157 return; /* Nothing to hook it up to (no label def). */
4158
4159 ffests_new (s, malloc_pool_image (), 80);
4160 ffests_putc (s, '(');
4161 ffestd_R1001dump_ (s, f); /* Build the string in s. */
4162 ffests_putc (s, ')');
4163
4164#if FFECOM_ONEPASS
4165 ffeste_R1001 (s);
4166 ffests_kill (s); /* Kill the string in s. */
4167#else
4168 {
4169 ffestdStmt_ stmt;
4170
4171 stmt = ffestd_stmt_new_ (FFESTD_stmtidR1001_);
4172 ffestd_stmt_append_ (stmt);
4173 stmt->u.R1001.str = str;
4174 }
4175#endif
4176
4177 ffestd_label_formatdef_ = NULL;
4178}
4179
4180/* ffestd_R1001dump_ -- Dump list of formats
4181
4182 ffesttFormatList list;
4183 ffestd_R1001dump_(list,0);
4184
4185 The formats in the list are dumped. */
4186
4187static void
4188ffestd_R1001dump_ (ffests s, ffesttFormatList list)
4189{
4190 ffesttFormatList next;
4191
4192 for (next = list->next; next != list; next = next->next)
4193 {
4194 if (next != list->next)
4195 ffests_putc (s, ',');
4196 switch (next->type)
4197 {
4198 case FFESTP_formattypeI:
4199 ffestd_R1001dump_1005_3_ (s, next, "I");
4200 break;
4201
4202 case FFESTP_formattypeB:
4203#if FFECOM_targetCURRENT == FFECOM_targetFFE
4204 ffestd_R1001dump_1005_3_ (s, next, "B");
4205#elif FFECOM_targetCURRENT == FFECOM_targetGCC
4206 ffestd_R1001error_ (next);
4207#else
4208#error
4209#endif
4210 break;
4211
4212 case FFESTP_formattypeO:
4213 ffestd_R1001dump_1005_3_ (s, next, "O");
4214 break;
4215
4216 case FFESTP_formattypeZ:
4217 ffestd_R1001dump_1005_3_ (s, next, "Z");
4218 break;
4219
4220 case FFESTP_formattypeF:
4221 ffestd_R1001dump_1005_4_ (s, next, "F");
4222 break;
4223
4224 case FFESTP_formattypeE:
4225 ffestd_R1001dump_1005_5_ (s, next, "E");
4226 break;
4227
4228 case FFESTP_formattypeEN:
4229#if FFECOM_targetCURRENT == FFECOM_targetFFE
4230 ffestd_R1001dump_1005_5_ (s, next, "EN");
4231#elif FFECOM_targetCURRENT == FFECOM_targetGCC
4232 ffestd_R1001error_ (next);
4233#else
4234#error
4235#endif
4236 break;
4237
4238 case FFESTP_formattypeG:
4239 ffestd_R1001dump_1005_5_ (s, next, "G");
4240 break;
4241
4242 case FFESTP_formattypeL:
4243 ffestd_R1001dump_1005_2_ (s, next, "L");
4244 break;
4245
4246 case FFESTP_formattypeA:
4247 ffestd_R1001dump_1005_1_ (s, next, "A");
4248 break;
4249
4250 case FFESTP_formattypeD:
4251 ffestd_R1001dump_1005_4_ (s, next, "D");
4252 break;
4253
4254 case FFESTP_formattypeQ:
4255#if FFECOM_targetCURRENT == FFECOM_targetFFE
4256 ffestd_R1001dump_1010_1_ (s, next, "Q");
4257#elif FFECOM_targetCURRENT == FFECOM_targetGCC
4258 ffestd_R1001error_ (next);
4259#else
4260#error
4261#endif
4262 break;
4263
4264 case FFESTP_formattypeDOLLAR:
4265 ffestd_R1001dump_1010_1_ (s, next, "$");
4266 break;
4267
4268 case FFESTP_formattypeP:
4269 ffestd_R1001dump_1010_4_ (s, next, "P");
4270 break;
4271
4272 case FFESTP_formattypeT:
4273 ffestd_R1001dump_1010_5_ (s, next, "T");
4274 break;
4275
4276 case FFESTP_formattypeTL:
4277 ffestd_R1001dump_1010_5_ (s, next, "TL");
4278 break;
4279
4280 case FFESTP_formattypeTR:
4281 ffestd_R1001dump_1010_5_ (s, next, "TR");
4282 break;
4283
4284 case FFESTP_formattypeX:
4285 ffestd_R1001dump_1010_3_ (s, next, "X");
4286 break;
4287
4288 case FFESTP_formattypeS:
4289 ffestd_R1001dump_1010_1_ (s, next, "S");
4290 break;
4291
4292 case FFESTP_formattypeSP:
4293 ffestd_R1001dump_1010_1_ (s, next, "SP");
4294 break;
4295
4296 case FFESTP_formattypeSS:
4297 ffestd_R1001dump_1010_1_ (s, next, "SS");
4298 break;
4299
4300 case FFESTP_formattypeBN:
4301 ffestd_R1001dump_1010_1_ (s, next, "BN");
4302 break;
4303
4304 case FFESTP_formattypeBZ:
4305 ffestd_R1001dump_1010_1_ (s, next, "BZ");
4306 break;
4307
4308 case FFESTP_formattypeSLASH:
4309 ffestd_R1001dump_1010_2_ (s, next, "/");
4310 break;
4311
4312 case FFESTP_formattypeCOLON:
4313 ffestd_R1001dump_1010_1_ (s, next, ":");
4314 break;
4315
4316 case FFESTP_formattypeR1016:
4317 switch (ffelex_token_type (next->t))
4318 {
4319 case FFELEX_typeCHARACTER:
4320 {
4321 char *p = ffelex_token_text (next->t);
4322 ffeTokenLength i = ffelex_token_length (next->t);
4323
4324 ffests_putc (s, '\002');
4325 while (i-- != 0)
4326 {
4327 if (*p == '\002')
4328 ffests_putc (s, '\002');
4329 ffests_putc (s, *p);
4330 ++p;
4331 }
4332 ffests_putc (s, '\002');
4333 }
4334 break;
4335
4336 case FFELEX_typeHOLLERITH:
4337 {
4338 char *p = ffelex_token_text (next->t);
4339 ffeTokenLength i = ffelex_token_length (next->t);
4340
4341 ffests_printf_1U (s,
4342 "%" ffeTokenLength_f "uH",
4343 i);
4344 while (i-- != 0)
4345 {
4346 ffests_putc (s, *p);
4347 ++p;
4348 }
4349 }
4350 break;
4351
4352 default:
4353 assert (FALSE);
4354 }
4355 break;
4356
4357 case FFESTP_formattypeFORMAT:
4358 if (next->u.R1003D.R1004.present)
4359 if (next->u.R1003D.R1004.rtexpr)
4360 ffestd_R1001error_ (next);
4361 else
4362 ffests_printf_1U (s, "%lu",
4363 next->u.R1003D.R1004.u.unsigned_val);
4364
4365 ffests_putc (s, '(');
4366 ffestd_R1001dump_ (s, next->u.R1003D.format);
4367 ffests_putc (s, ')');
4368 break;
4369
4370 default:
4371 assert (FALSE);
4372 }
4373 }
4374}
4375
4376/* ffestd_R1001dump_1005_1_ -- Dump a particular format
4377
4378 ffesttFormatList f;
4379 ffestd_R1001dump_1005_1_(f,"I");
4380
4381 The format is dumped with form [r]X[w]. */
4382
4383static void
4384ffestd_R1001dump_1005_1_ (ffests s, ffesttFormatList f, char *string)
4385{
4386 assert (!f->u.R1005.R1007_or_R1008.present);
4387 assert (!f->u.R1005.R1009.present);
4388
4389 if (f->u.R1005.R1004.present)
4390 if (f->u.R1005.R1004.rtexpr)
4391 ffestd_R1001error_ (f);
4392 else
4393 ffests_printf_1U (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
4394
4395 ffests_puts (s, string);
4396
4397 if (f->u.R1005.R1006.present)
4398 if (f->u.R1005.R1006.rtexpr)
4399 ffestd_R1001error_ (f);
4400 else
4401 ffests_printf_1U (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
4402}
4403
4404/* ffestd_R1001dump_1005_2_ -- Dump a particular format
4405
4406 ffesttFormatList f;
4407 ffestd_R1001dump_1005_2_(f,"I");
4408
4409 The format is dumped with form [r]Xw. */
4410
4411static void
4412ffestd_R1001dump_1005_2_ (ffests s, ffesttFormatList f, char *string)
4413{
4414 assert (!f->u.R1005.R1007_or_R1008.present);
4415 assert (!f->u.R1005.R1009.present);
4416 assert (f->u.R1005.R1006.present);
4417
4418 if (f->u.R1005.R1004.present)
4419 if (f->u.R1005.R1004.rtexpr)
4420 ffestd_R1001error_ (f);
4421 else
4422 ffests_printf_1U (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
4423
4424 ffests_puts (s, string);
4425
4426 if (f->u.R1005.R1006.rtexpr)
4427 ffestd_R1001error_ (f);
4428 else
4429 ffests_printf_1U (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
4430}
4431
4432/* ffestd_R1001dump_1005_3_ -- Dump a particular format
4433
4434 ffesttFormatList f;
4435 ffestd_R1001dump_1005_3_(f,"I");
4436
4437 The format is dumped with form [r]Xw[.m]. */
4438
4439static void
4440ffestd_R1001dump_1005_3_ (ffests s, ffesttFormatList f, char *string)
4441{
4442 assert (!f->u.R1005.R1009.present);
4443 assert (f->u.R1005.R1006.present);
4444
4445 if (f->u.R1005.R1004.present)
4446 if (f->u.R1005.R1004.rtexpr)
4447 ffestd_R1001error_ (f);
4448 else
4449 ffests_printf_1U (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
4450
4451 ffests_puts (s, string);
4452
4453 if (f->u.R1005.R1006.rtexpr)
4454 ffestd_R1001error_ (f);
4455 else
4456 ffests_printf_1U (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
4457
4458 if (f->u.R1005.R1007_or_R1008.present)
4459 {
4460 ffests_putc (s, '.');
4461 if (f->u.R1005.R1007_or_R1008.rtexpr)
4462 ffestd_R1001error_ (f);
4463 else
4464 ffests_printf_1U (s, "%lu",
4465 f->u.R1005.R1007_or_R1008.u.unsigned_val);
4466 }
4467}
4468
4469/* ffestd_R1001dump_1005_4_ -- Dump a particular format
4470
4471 ffesttFormatList f;
4472 ffestd_R1001dump_1005_4_(f,"I");
4473
4474 The format is dumped with form [r]Xw.d. */
4475
4476static void
4477ffestd_R1001dump_1005_4_ (ffests s, ffesttFormatList f, char *string)
4478{
4479 assert (!f->u.R1005.R1009.present);
4480 assert (f->u.R1005.R1007_or_R1008.present);
4481 assert (f->u.R1005.R1006.present);
4482
4483 if (f->u.R1005.R1004.present)
4484 if (f->u.R1005.R1004.rtexpr)
4485 ffestd_R1001error_ (f);
4486 else
4487 ffests_printf_1U (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
4488
4489 ffests_puts (s, string);
4490
4491 if (f->u.R1005.R1006.rtexpr)
4492 ffestd_R1001error_ (f);
4493 else
4494 ffests_printf_1U (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
4495
4496 ffests_putc (s, '.');
4497 if (f->u.R1005.R1007_or_R1008.rtexpr)
4498 ffestd_R1001error_ (f);
4499 else
4500 ffests_printf_1U (s, "%lu", f->u.R1005.R1007_or_R1008.u.unsigned_val);
4501}
4502
4503/* ffestd_R1001dump_1005_5_ -- Dump a particular format
4504
4505 ffesttFormatList f;
4506 ffestd_R1001dump_1005_5_(f,"I");
4507
4508 The format is dumped with form [r]Xw.d[Ee]. */
4509
4510static void
4511ffestd_R1001dump_1005_5_ (ffests s, ffesttFormatList f, char *string)
4512{
4513 assert (f->u.R1005.R1007_or_R1008.present);
4514 assert (f->u.R1005.R1006.present);
4515
4516 if (f->u.R1005.R1004.present)
4517 if (f->u.R1005.R1004.rtexpr)
4518 ffestd_R1001error_ (f);
4519 else
4520 ffests_printf_1U (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
4521
4522 ffests_puts (s, string);
4523
4524 if (f->u.R1005.R1006.rtexpr)
4525 ffestd_R1001error_ (f);
4526 else
4527 ffests_printf_1U (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
4528
4529 ffests_putc (s, '.');
4530 if (f->u.R1005.R1007_or_R1008.rtexpr)
4531 ffestd_R1001error_ (f);
4532 else
4533 ffests_printf_1U (s, "%lu", f->u.R1005.R1007_or_R1008.u.unsigned_val);
4534
4535 if (f->u.R1005.R1009.present)
4536 {
4537 ffests_putc (s, 'E');
4538 if (f->u.R1005.R1009.rtexpr)
4539 ffestd_R1001error_ (f);
4540 else
4541 ffests_printf_1U (s, "%lu", f->u.R1005.R1009.u.unsigned_val);
4542 }
4543}
4544
4545/* ffestd_R1001dump_1010_1_ -- Dump a particular format
4546
4547 ffesttFormatList f;
4548 ffestd_R1001dump_1010_1_(f,"I");
4549
4550 The format is dumped with form X. */
4551
4552static void
4553ffestd_R1001dump_1010_1_ (ffests s, ffesttFormatList f, char *string)
4554{
4555 assert (!f->u.R1010.val.present);
4556
4557 ffests_puts (s, string);
4558}
4559
4560/* ffestd_R1001dump_1010_2_ -- Dump a particular format
4561
4562 ffesttFormatList f;
4563 ffestd_R1001dump_1010_2_(f,"I");
4564
4565 The format is dumped with form [r]X. */
4566
4567static void
4568ffestd_R1001dump_1010_2_ (ffests s, ffesttFormatList f, char *string)
4569{
4570 if (f->u.R1010.val.present)
4571 if (f->u.R1010.val.rtexpr)
4572 ffestd_R1001error_ (f);
4573 else
4574 ffests_printf_1U (s, "%lu", f->u.R1010.val.u.unsigned_val);
4575
4576 ffests_puts (s, string);
4577}
4578
4579/* ffestd_R1001dump_1010_3_ -- Dump a particular format
4580
4581 ffesttFormatList f;
4582 ffestd_R1001dump_1010_3_(f,"I");
4583
4584 The format is dumped with form nX. */
4585
4586static void
4587ffestd_R1001dump_1010_3_ (ffests s, ffesttFormatList f, char *string)
4588{
4589 assert (f->u.R1010.val.present);
4590
4591 if (f->u.R1010.val.rtexpr)
4592 ffestd_R1001error_ (f);
4593 else
4594 ffests_printf_1U (s, "%lu", f->u.R1010.val.u.unsigned_val);
4595
4596 ffests_puts (s, string);
4597}
4598
4599/* ffestd_R1001dump_1010_4_ -- Dump a particular format
4600
4601 ffesttFormatList f;
4602 ffestd_R1001dump_1010_4_(f,"I");
4603
4604 The format is dumped with form kX. Note that k is signed. */
4605
4606static void
4607ffestd_R1001dump_1010_4_ (ffests s, ffesttFormatList f, char *string)
4608{
4609 assert (f->u.R1010.val.present);
4610
4611 if (f->u.R1010.val.rtexpr)
4612 ffestd_R1001error_ (f);
4613 else
4614 ffests_printf_1D (s, "%ld", f->u.R1010.val.u.signed_val);
4615
4616 ffests_puts (s, string);
4617}
4618
4619/* ffestd_R1001dump_1010_5_ -- Dump a particular format
4620
4621 ffesttFormatList f;
4622 ffestd_R1001dump_1010_5_(f,"I");
4623
4624 The format is dumped with form Xn. */
4625
4626static void
4627ffestd_R1001dump_1010_5_ (ffests s, ffesttFormatList f, char *string)
4628{
4629 assert (f->u.R1010.val.present);
4630
4631 ffests_puts (s, string);
4632
4633 if (f->u.R1010.val.rtexpr)
4634 ffestd_R1001error_ (f);
4635 else
4636 ffests_printf_1U (s, "%lu", f->u.R1010.val.u.unsigned_val);
4637}
4638
4639/* ffestd_R1001error_ -- Complain about FORMAT specification not supported
4640
4641 ffesttFormatList f;
4642 ffestd_R1001error_(f);
4643
4644 An error message is produced. */
4645
4646static void
4647ffestd_R1001error_ (ffesttFormatList f)
4648{
4649 ffebad_start (FFEBAD_FORMAT_UNSUPPORTED);
4650 ffebad_here (0, ffelex_token_where_line (f->t), ffelex_token_where_column (f->t));
4651 ffebad_finish ();
4652}
4653
4654/* ffestd_R1102 -- PROGRAM statement
4655
4656 ffestd_R1102(name_token);
4657
4658 Make sure ffestd_kind_ identifies an empty block. Make sure name_token
4659 gives a valid name. Implement the beginning of a main program. */
4660
4661void
4662ffestd_R1102 (ffesymbol s, ffelexToken name UNUSED)
4663{
4664 ffestd_check_simple_ ();
4665
4666 assert (ffestd_block_level_ == 0);
4667 ffestd_is_reachable_ = TRUE;
4668
4669 ffecom_notify_primary_entry (s);
4670 ffe_set_is_mainprog (TRUE); /* Is a main program. */
4671 ffe_set_is_saveall (TRUE); /* Main program always has implicit SAVE. */
4672
4673 ffestw_set_sym (ffestw_stack_top (), s);
4674
4675#if FFECOM_targetCURRENT == FFECOM_targetFFE
4676 if (name == NULL)
4677 fputs ("< PROGRAM_unnamed\n", dmpout);
4678 else
4679 fprintf (dmpout, "< PROGRAM %s\n", ffelex_token_text (name));
4680#elif FFECOM_targetCURRENT == FFECOM_targetGCC
4681#else
4682#error
4683#endif
4684}
4685
4686/* ffestd_R1103 -- End a PROGRAM
4687
4688 ffestd_R1103(); */
4689
4690void
4691ffestd_R1103 (bool ok UNUSED)
4692{
4693 assert (ffestd_block_level_ == 0);
4694
4695 if (FFESTD_IS_END_OPTIMIZED_ && ffestd_is_reachable_)
4696 ffestd_R842 (NULL); /* Generate STOP. */
4697
4698 if (ffestw_state (ffestw_stack_top ()) != FFESTV_statePROGRAM5)
4699 ffestd_subr_labels_ (FALSE);/* Handle any undefined labels. */
4700
4701#if FFECOM_ONEPASS
4702 ffeste_R1103 ();
4703#else
4704 {
4705 ffestdStmt_ stmt;
4706
4707 stmt = ffestd_stmt_new_ (FFESTD_stmtidR1103_);
4708 ffestd_stmt_append_ (stmt);
4709 }
4710#endif
4711}
4712
4713/* ffestd_R1105 -- MODULE statement
4714
4715 ffestd_R1105(name_token);
4716
4717 Make sure ffestd_kind_ identifies an empty block. Make sure name_token
4718 gives a valid name. Implement the beginning of a module. */
4719
4720#if FFESTR_F90
4721void
4722ffestd_R1105 (ffelexToken name)
4723{
4724 assert (ffestd_block_level_ == 0);
4725
4726 ffestd_check_simple_ ();
4727
4728 ffestd_subr_f90_ ();
4729 return;
4730
4731#ifdef FFESTD_F90
4732 fprintf (dmpout, "* MODULE %s\n", ffelex_token_text (name));
4733#endif
4734}
4735
4736/* ffestd_R1106 -- End a MODULE
4737
4738 ffestd_R1106(TRUE); */
4739
4740void
4741ffestd_R1106 (bool ok)
4742{
4743 assert (ffestd_block_level_ == 0);
4744
4745 /* Generate any wrap-up code here (unlikely in MODULE!). */
4746
4747 if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateMODULE5)
4748 ffestd_subr_labels_ (TRUE); /* Handle any undefined labels (unlikely). */
4749
4750 return; /* F90. */
4751
4752#ifdef FFESTD_F90
4753 fprintf (dmpout, "< END_MODULE %s\n",
4754 ffelex_token_text (ffestw_name (ffestw_stack_top ())));
4755#endif
4756}
4757
4758/* ffestd_R1107_start -- USE statement list begin
4759
4760 ffestd_R1107_start();
4761
4762 Verify that USE is valid here, and begin accepting items in the list. */
4763
4764void
4765ffestd_R1107_start (ffelexToken name, bool only)
4766{
4767 ffestd_check_start_ ();
4768
4769 ffestd_subr_f90_ ();
4770 return;
4771
4772#ifdef FFESTD_F90
4773 fprintf (dmpout, "* USE %s,", ffelex_token_text (name)); /* NB
4774 _shriek_begin_uses_. */
4775 if (only)
4776 fputs ("only: ", dmpout);
4777#endif
4778}
4779
4780/* ffestd_R1107_item -- USE statement for name
4781
4782 ffestd_R1107_item(local_token,use_token);
4783
4784 Make sure name_token identifies a valid object to be USEed. local_token
4785 may be NULL if _start_ was called with only==TRUE. */
4786
4787void
4788ffestd_R1107_item (ffelexToken local, ffelexToken use)
4789{
4790 ffestd_check_item_ ();
4791 assert (use != NULL);
4792
4793 return; /* F90. */
4794
4795#ifdef FFESTD_F90
4796 if (local != NULL)
4797 fprintf (dmpout, "%s=>", ffelex_token_text (local));
4798 fprintf (dmpout, "%s,", ffelex_token_text (use));
4799#endif
4800}
4801
4802/* ffestd_R1107_finish -- USE statement list complete
4803
4804 ffestd_R1107_finish();
4805
4806 Just wrap up any local activities. */
4807
4808void
4809ffestd_R1107_finish ()
4810{
4811 ffestd_check_finish_ ();
4812
4813 return; /* F90. */
4814
4815#ifdef FFESTD_F90
4816 fputc ('\n', dmpout);
4817#endif
4818}
4819
4820#endif
4821/* ffestd_R1111 -- BLOCK DATA statement
4822
4823 ffestd_R1111(name_token);
4824
4825 Make sure ffestd_kind_ identifies no current program unit. If not
4826 NULL, make sure name_token gives a valid name. Implement the beginning
4827 of a block data program unit. */
4828
4829void
4830ffestd_R1111 (ffesymbol s, ffelexToken name UNUSED)
4831{
4832 assert (ffestd_block_level_ == 0);
4833 ffestd_is_reachable_ = TRUE;
4834
4835 ffestd_check_simple_ ();
4836
4837 ffecom_notify_primary_entry (s);
4838 ffestw_set_sym (ffestw_stack_top (), s);
4839
4840#if FFECOM_targetCURRENT == FFECOM_targetFFE
4841 if (name == NULL)
4842 fputs ("< BLOCK_DATA_unnamed\n", dmpout);
4843 else
4844 fprintf (dmpout, "< BLOCK_DATA %s\n", ffelex_token_text (name));
4845#elif FFECOM_targetCURRENT == FFECOM_targetGCC
4846#else
4847#error
4848#endif
4849}
4850
4851/* ffestd_R1112 -- End a BLOCK DATA
4852
4853 ffestd_R1112(TRUE); */
4854
4855void
4856ffestd_R1112 (bool ok UNUSED)
4857{
4858 assert (ffestd_block_level_ == 0);
4859
4860 /* Generate any return-like code here (not likely for BLOCK DATA!). */
4861
4862 if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateBLOCKDATA5)
4863 ffestd_subr_labels_ (TRUE); /* Handle any undefined labels. */
4864
4865#if FFECOM_ONEPASS
4866 ffeste_R1112 ();
4867#else
4868 {
4869 ffestdStmt_ stmt;
4870
4871 stmt = ffestd_stmt_new_ (FFESTD_stmtidR1112_);
4872 ffestd_stmt_append_ (stmt);
4873 }
4874#endif
4875}
4876
4877/* ffestd_R1202 -- INTERFACE statement
4878
4879 ffestd_R1202(operator,defined_name);
4880
4881 Make sure ffestd_kind_ identifies an INTERFACE block.
4882 Implement the end of the current interface.
4883
4884 06-Jun-90 JCB 1.1
4885 Allow no operator or name to mean INTERFACE by itself; missed this
4886 valid form when originally doing syntactic analysis code. */
4887
4888#if FFESTR_F90
4889void
4890ffestd_R1202 (ffestpDefinedOperator operator, ffelexToken name)
4891{
4892 ffestd_check_simple_ ();
4893
4894 ffestd_subr_f90_ ();
4895 return;
4896
4897#ifdef FFESTD_F90
4898 switch (operator)
4899 {
4900 case FFESTP_definedoperatorNone:
4901 if (name == NULL)
4902 fputs ("* INTERFACE_unnamed\n", dmpout);
4903 else
4904 fprintf (dmpout, "* INTERFACE %s\n", ffelex_token_text (name));
4905 break;
4906
4907 case FFESTP_definedoperatorOPERATOR:
4908 fprintf (dmpout, "* INTERFACE_OPERATOR (.%s.)\n", ffelex_token_text (name));
4909 break;
4910
4911 case FFESTP_definedoperatorASSIGNMENT:
4912 fputs ("* INTERFACE_ASSIGNMENT (=)\n", dmpout);
4913 break;
4914
4915 case FFESTP_definedoperatorPOWER:
4916 fputs ("* INTERFACE_OPERATOR (**)\n", dmpout);
4917 break;
4918
4919 case FFESTP_definedoperatorMULT:
4920 fputs ("* INTERFACE_OPERATOR (*)\n", dmpout);
4921 break;
4922
4923 case FFESTP_definedoperatorADD:
4924 fputs ("* INTERFACE_OPERATOR (+)\n", dmpout);
4925 break;
4926
4927 case FFESTP_definedoperatorCONCAT:
4928 fputs ("* INTERFACE_OPERATOR (//)\n", dmpout);
4929 break;
4930
4931 case FFESTP_definedoperatorDIVIDE:
4932 fputs ("* INTERFACE_OPERATOR (/)\n", dmpout);
4933 break;
4934
4935 case FFESTP_definedoperatorSUBTRACT:
4936 fputs ("* INTERFACE_OPERATOR (-)\n", dmpout);
4937 break;
4938
4939 case FFESTP_definedoperatorNOT:
4940 fputs ("* INTERFACE_OPERATOR (.not.)\n", dmpout);
4941 break;
4942
4943 case FFESTP_definedoperatorAND:
4944 fputs ("* INTERFACE_OPERATOR (.and.)\n", dmpout);
4945 break;
4946
4947 case FFESTP_definedoperatorOR:
4948 fputs ("* INTERFACE_OPERATOR (.or.)\n", dmpout);
4949 break;
4950
4951 case FFESTP_definedoperatorEQV:
4952 fputs ("* INTERFACE_OPERATOR (.eqv.)\n", dmpout);
4953 break;
4954
4955 case FFESTP_definedoperatorNEQV:
4956 fputs ("* INTERFACE_OPERATOR (.neqv.)\n", dmpout);
4957 break;
4958
4959 case FFESTP_definedoperatorEQ:
4960 fputs ("* INTERFACE_OPERATOR (==)\n", dmpout);
4961 break;
4962
4963 case FFESTP_definedoperatorNE:
4964 fputs ("* INTERFACE_OPERATOR (/=)\n", dmpout);
4965 break;
4966
4967 case FFESTP_definedoperatorLT:
4968 fputs ("* INTERFACE_OPERATOR (<)\n", dmpout);
4969 break;
4970
4971 case FFESTP_definedoperatorLE:
4972 fputs ("* INTERFACE_OPERATOR (<=)\n", dmpout);
4973 break;
4974
4975 case FFESTP_definedoperatorGT:
4976 fputs ("* INTERFACE_OPERATOR (>)\n", dmpout);
4977 break;
4978
4979 case FFESTP_definedoperatorGE:
4980 fputs ("* INTERFACE_OPERATOR (>=)\n", dmpout);
4981 break;
4982
4983 default:
4984 assert (FALSE);
4985 break;
4986 }
4987#endif
4988}
4989
4990/* ffestd_R1203 -- End an INTERFACE
4991
4992 ffestd_R1203(TRUE); */
4993
4994void
4995ffestd_R1203 (bool ok)
4996{
4997 return; /* F90. */
4998
4999#ifdef FFESTD_F90
5000 fputs ("* END_INTERFACE\n", dmpout);
5001#endif
5002}
5003
5004/* ffestd_R1205_start -- MODULE PROCEDURE statement list begin
5005
5006 ffestd_R1205_start();
5007
5008 Verify that MODULE PROCEDURE is valid here, and begin accepting items in
5009 the list. */
5010
5011void
5012ffestd_R1205_start ()
5013{
5014 ffestd_check_start_ ();
5015
5016 return; /* F90. */
5017
5018#ifdef FFESTD_F90
5019 fputs ("* MODULE_PROCEDURE ", dmpout);
5020#endif
5021}
5022
5023/* ffestd_R1205_item -- MODULE PROCEDURE statement for name
5024
5025 ffestd_R1205_item(name_token);
5026
5027 Make sure name_token identifies a valid object to be MODULE PROCEDUREed. */
5028
5029void
5030ffestd_R1205_item (ffelexToken name)
5031{
5032 ffestd_check_item_ ();
5033 assert (name != NULL);
5034
5035 return; /* F90. */
5036
5037#ifdef FFESTD_F90
5038 fprintf (dmpout, "%s,", ffelex_token_text (name));
5039#endif
5040}
5041
5042/* ffestd_R1205_finish -- MODULE PROCEDURE statement list complete
5043
5044 ffestd_R1205_finish();
5045
5046 Just wrap up any local activities. */
5047
5048void
5049ffestd_R1205_finish ()
5050{
5051 ffestd_check_finish_ ();
5052
5053 return; /* F90. */
5054
5055#ifdef FFESTD_F90
5056 fputc ('\n', dmpout);
5057#endif
5058}
5059
5060#endif
5061/* ffestd_R1207_start -- EXTERNAL statement list begin
5062
5063 ffestd_R1207_start();
5064
5065 Verify that EXTERNAL is valid here, and begin accepting items in the list. */
5066
5067void
5068ffestd_R1207_start ()
5069{
5070 ffestd_check_start_ ();
5071
5072#if FFECOM_targetCURRENT == FFECOM_targetFFE
5073 fputs ("* EXTERNAL (", dmpout);
5074#elif FFECOM_targetCURRENT == FFECOM_targetGCC
5075#else
5076#error
5077#endif
5078}
5079
5080/* ffestd_R1207_item -- EXTERNAL statement for name
5081
5082 ffestd_R1207_item(name_token);
5083
5084 Make sure name_token identifies a valid object to be EXTERNALd. */
5085
5086void
5087ffestd_R1207_item (ffelexToken name)
5088{
5089 ffestd_check_item_ ();
5090 assert (name != NULL);
5091
5092#if FFECOM_targetCURRENT == FFECOM_targetFFE
5093 fprintf (dmpout, "%s,", ffelex_token_text (name));
5094#elif FFECOM_targetCURRENT == FFECOM_targetGCC
5095#else
5096#error
5097#endif
5098}
5099
5100/* ffestd_R1207_finish -- EXTERNAL statement list complete
5101
5102 ffestd_R1207_finish();
5103
5104 Just wrap up any local activities. */
5105
5106void
5107ffestd_R1207_finish ()
5108{
5109 ffestd_check_finish_ ();
5110
5111#if FFECOM_targetCURRENT == FFECOM_targetFFE
5112 fputs (")\n", dmpout);
5113#elif FFECOM_targetCURRENT == FFECOM_targetGCC
5114#else
5115#error
5116#endif
5117}
5118
5119/* ffestd_R1208_start -- INTRINSIC statement list begin
5120
5121 ffestd_R1208_start();
5122
5123 Verify that INTRINSIC is valid here, and begin accepting items in the list. */
5124
5125void
5126ffestd_R1208_start ()
5127{
5128 ffestd_check_start_ ();
5129
5130#if FFECOM_targetCURRENT == FFECOM_targetFFE
5131 fputs ("* INTRINSIC (", dmpout);
5132#elif FFECOM_targetCURRENT == FFECOM_targetGCC
5133#else
5134#error
5135#endif
5136}
5137
5138/* ffestd_R1208_item -- INTRINSIC statement for name
5139
5140 ffestd_R1208_item(name_token);
5141
5142 Make sure name_token identifies a valid object to be INTRINSICd. */
5143
5144void
5145ffestd_R1208_item (ffelexToken name)
5146{
5147 ffestd_check_item_ ();
5148 assert (name != NULL);
5149
5150#if FFECOM_targetCURRENT == FFECOM_targetFFE
5151 fprintf (dmpout, "%s,", ffelex_token_text (name));
5152#elif FFECOM_targetCURRENT == FFECOM_targetGCC
5153#else
5154#error
5155#endif
5156}
5157
5158/* ffestd_R1208_finish -- INTRINSIC statement list complete
5159
5160 ffestd_R1208_finish();
5161
5162 Just wrap up any local activities. */
5163
5164void
5165ffestd_R1208_finish ()
5166{
5167 ffestd_check_finish_ ();
5168
5169#if FFECOM_targetCURRENT == FFECOM_targetFFE
5170 fputs (")\n", dmpout);
5171#elif FFECOM_targetCURRENT == FFECOM_targetGCC
5172#else
5173#error
5174#endif
5175}
5176
5177/* ffestd_R1212 -- CALL statement
5178
5179 ffestd_R1212(expr,expr_token);
5180
5181 Make sure statement is valid here; implement. */
5182
5183void
5184ffestd_R1212 (ffebld expr)
5185{
5186 ffestd_check_simple_ ();
5187
5188#if FFECOM_ONEPASS
5189 ffestd_subr_line_now_ ();
5190 ffeste_R1212 (expr);
5191#else
5192 {
5193 ffestdStmt_ stmt;
5194
5195 stmt = ffestd_stmt_new_ (FFESTD_stmtidR1212_);
5196 ffestd_stmt_append_ (stmt);
5197 ffestd_subr_line_save_ (stmt);
5198 stmt->u.R1212.pool = ffesta_output_pool;
5199 stmt->u.R1212.expr = expr;
5200 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
5201 }
5202#endif
5203}
5204
5205/* ffestd_R1213 -- Defined assignment statement
5206
5207 ffestd_R1213(dest_expr,source_expr,source_token);
5208
5209 Make sure the assignment is valid. */
5210
5211#if FFESTR_F90
5212void
5213ffestd_R1213 (ffebld dest, ffebld source)
5214{
5215 ffestd_check_simple_ ();
5216
5217 ffestd_subr_f90_ ();
5218 return;
5219
5220#ifdef FFESTD_F90
5221 fputs ("+ let_defined ", dmpout);
5222 ffebld_dump (dest);
5223 fputs ("=", dmpout);
5224 ffebld_dump (source);
5225 fputc ('\n', dmpout);
5226#endif
5227}
5228
5229#endif
5230/* ffestd_R1219 -- FUNCTION statement
5231
5232 ffestd_R1219(funcname,arglist,ending_token,kind,kindt,len,lent,
5233 recursive);
5234
5235 Make sure statement is valid here, register arguments for the
5236 function name, and so on.
5237
5238 06-Jun-90 JCB 2.0
5239 Added the kind, len, and recursive arguments. */
5240
5241void
5242ffestd_R1219 (ffesymbol s, ffelexToken funcname UNUSED,
5243 ffesttTokenList args UNUSED, ffestpType type UNUSED,
5244 ffebld kind UNUSED, ffelexToken kindt UNUSED,
5245 ffebld len UNUSED, ffelexToken lent UNUSED,
5246 bool recursive UNUSED, ffelexToken result UNUSED,
5247 bool separate_result UNUSED)
5248{
5249#if FFECOM_targetCURRENT == FFECOM_targetFFE
5250 char *a;
5251#endif
5252
5253 assert (ffestd_block_level_ == 0);
5254 ffestd_is_reachable_ = TRUE;
5255
5256 ffestd_check_simple_ ();
5257
5258 ffecom_notify_primary_entry (s);
5259 ffestw_set_sym (ffestw_stack_top (), s);
5260
5261#if FFECOM_targetCURRENT == FFECOM_targetFFE
5262 switch (type)
5263 {
5264 case FFESTP_typeINTEGER:
5265 a = "INTEGER";
5266 break;
5267
5268 case FFESTP_typeBYTE:
5269 a = "BYTE";
5270 break;
5271
5272 case FFESTP_typeWORD:
5273 a = "WORD";
5274 break;
5275
5276 case FFESTP_typeREAL:
5277 a = "REAL";
5278 break;
5279
5280 case FFESTP_typeCOMPLEX:
5281 a = "COMPLEX";
5282 break;
5283
5284 case FFESTP_typeLOGICAL:
5285 a = "LOGICAL";
5286 break;
5287
5288 case FFESTP_typeCHARACTER:
5289 a = "CHARACTER";
5290 break;
5291
5292 case FFESTP_typeDBLPRCSN:
5293 a = "DOUBLE PRECISION";
5294 break;
5295
5296 case FFESTP_typeDBLCMPLX:
5297 a = "DOUBLE COMPLEX";
5298 break;
5299
5300#if FFESTR_F90
5301 case FFESTP_typeTYPE:
5302 a = "TYPE";
5303 break;
5304#endif
5305
5306 case FFESTP_typeNone:
5307 a = "";
5308 break;
5309
5310 default:
5311 assert (FALSE);
5312 a = "?";
5313 break;
5314 }
5315 fprintf (dmpout, "< FUNCTION %s ", ffelex_token_text (funcname));
5316 if (recursive)
5317 fputs ("RECURSIVE ", dmpout);
5318 fprintf (dmpout, "%s(", a);
5319 if (kindt != NULL)
5320 {
5321 fputs ("kind=", dmpout);
5322 if (kind == NULL)
5323 fputs (ffelex_token_text (kindt), dmpout);
5324 else
5325 ffebld_dump (kind);
5326 if (lent != NULL)
5327 fputc (',', dmpout);
5328 }
5329 if (lent != NULL)
5330 {
5331 fputs ("len=", dmpout);
5332 if (len == NULL)
5333 fputs (ffelex_token_text (lent), dmpout);
5334 else
5335 ffebld_dump (len);
5336 }
5337 fprintf (dmpout, ")");
5338 if (args != NULL)
5339 {
5340 fputs (" (", dmpout);
5341 ffestt_tokenlist_dump (args);
5342 fputc (')', dmpout);
5343 }
5344 if (result != NULL)
5345 fprintf (dmpout, " result(%s)", ffelex_token_text (result));
5346 fputc ('\n', dmpout);
5347#elif FFECOM_targetCURRENT == FFECOM_targetGCC
5348#else
5349#error
5350#endif
5351}
5352
5353/* ffestd_R1221 -- End a FUNCTION
5354
5355 ffestd_R1221(TRUE); */
5356
5357void
5358ffestd_R1221 (bool ok UNUSED)
5359{
5360 assert (ffestd_block_level_ == 0);
5361
5362 if (FFESTD_IS_END_OPTIMIZED_ && ffestd_is_reachable_)
5363 ffestd_R1227 (NULL); /* Generate RETURN. */
5364
5365 if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateFUNCTION5)
5366 ffestd_subr_labels_ (FALSE);/* Handle any undefined labels. */
5367
5368#if FFECOM_ONEPASS
5369 ffeste_R1221 ();
5370#else
5371 {
5372 ffestdStmt_ stmt;
5373
5374 stmt = ffestd_stmt_new_ (FFESTD_stmtidR1221_);
5375 ffestd_stmt_append_ (stmt);
5376 }
5377#endif
5378}
5379
5380/* ffestd_R1223 -- SUBROUTINE statement
5381
5382 ffestd_R1223(subrname,arglist,ending_token,recursive_token);
5383
5384 Make sure statement is valid here, register arguments for the
5385 subroutine name, and so on.
5386
5387 06-Jun-90 JCB 2.0
5388 Added the recursive argument. */
5389
5390void
5391ffestd_R1223 (ffesymbol s, ffelexToken subrname UNUSED,
5392 ffesttTokenList args UNUSED, ffelexToken final UNUSED,
5393 bool recursive UNUSED)
5394{
5395 assert (ffestd_block_level_ == 0);
5396 ffestd_is_reachable_ = TRUE;
5397
5398 ffestd_check_simple_ ();
5399
5400 ffecom_notify_primary_entry (s);
5401 ffestw_set_sym (ffestw_stack_top (), s);
5402
5403#if FFECOM_targetCURRENT == FFECOM_targetFFE
5404 fprintf (dmpout, "< SUBROUTINE %s ", ffelex_token_text (subrname));
5405 if (recursive)
5406 fputs ("recursive ", dmpout);
5407 if (args != NULL)
5408 {
5409 fputc ('(', dmpout);
5410 ffestt_tokenlist_dump (args);
5411 fputc (')', dmpout);
5412 }
5413 fputc ('\n', dmpout);
5414#elif FFECOM_targetCURRENT == FFECOM_targetGCC
5415#else
5416#error
5417#endif
5418}
5419
5420/* ffestd_R1225 -- End a SUBROUTINE
5421
5422 ffestd_R1225(TRUE); */
5423
5424void
5425ffestd_R1225 (bool ok UNUSED)
5426{
5427 assert (ffestd_block_level_ == 0);
5428
5429 if (FFESTD_IS_END_OPTIMIZED_ && ffestd_is_reachable_)
5430 ffestd_R1227 (NULL); /* Generate RETURN. */
5431
5432 if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateSUBROUTINE5)
5433 ffestd_subr_labels_ (FALSE);/* Handle any undefined labels. */
5434
5435#if FFECOM_ONEPASS
5436 ffeste_R1225 ();
5437#else
5438 {
5439 ffestdStmt_ stmt;
5440
5441 stmt = ffestd_stmt_new_ (FFESTD_stmtidR1225_);
5442 ffestd_stmt_append_ (stmt);
5443 }
5444#endif
5445}
5446
5447/* ffestd_R1226 -- ENTRY statement
5448
5449 ffestd_R1226(entryname,arglist,ending_token);
5450
5451 Make sure we're in a SUBROUTINE or FUNCTION, register arguments for the
5452 entry point name, and so on. */
5453
5454void
5455ffestd_R1226 (ffesymbol entry)
5456{
5457 ffestd_check_simple_ ();
5458
5459#if (FFECOM_targetCURRENT == FFECOM_targetFFE) || FFECOM_ONEPASS
5460 ffestd_subr_line_now_ ();
5461 ffeste_R1226 (entry);
5462#else
5463 if (!ffesta_seen_first_exec || ffecom_2pass_advise_entrypoint (entry))
5464 {
5465 ffestdStmt_ stmt;
5466
5467 stmt = ffestd_stmt_new_ (FFESTD_stmtidR1226_);
5468 ffestd_stmt_append_ (stmt);
5469 ffestd_subr_line_save_ (stmt);
5470 stmt->u.R1226.entry = entry;
5471 stmt->u.R1226.entrynum = ++ffestd_2pass_entrypoints_;
5472 }
5473#endif
5474
5475 ffestd_is_reachable_ = TRUE;
5476}
5477
5478/* ffestd_R1227 -- RETURN statement
5479
5480 ffestd_R1227(expr);
5481
5482 Make sure statement is valid here; implement. expr and expr_token are
5483 both NULL if there was no expression. */
5484
5485void
5486ffestd_R1227 (ffebld expr)
5487{
5488 ffestd_check_simple_ ();
5489
5490#if FFECOM_ONEPASS
5491 ffestd_subr_line_now_ ();
5492 ffeste_R1227 (ffestw_stack_top (), expr);
5493#else
5494 {
5495 ffestdStmt_ stmt;
5496
5497 stmt = ffestd_stmt_new_ (FFESTD_stmtidR1227_);
5498 ffestd_stmt_append_ (stmt);
5499 ffestd_subr_line_save_ (stmt);
5500 stmt->u.R1227.pool = ffesta_output_pool;
5501 stmt->u.R1227.block = ffestw_stack_top ();
5502 stmt->u.R1227.expr = expr;
5503 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
5504 }
5505#endif
5506
5507 if (ffestd_block_level_ == 0)
5508 ffestd_is_reachable_ = FALSE;
5509}
5510
5511/* ffestd_R1228 -- CONTAINS statement
5512
5513 ffestd_R1228(); */
5514
5515#if FFESTR_F90
5516void
5517ffestd_R1228 ()
5518{
5519 assert (ffestd_block_level_ == 0);
5520
5521 ffestd_check_simple_ ();
5522
5523 /* Generate RETURN/STOP code here */
5524
5525 ffestd_subr_labels_ (ffestw_state (ffestw_stack_top ())
5526 == FFESTV_stateMODULE5); /* Handle any undefined
5527 labels. */
5528
5529 ffestd_subr_f90_ ();
5530 return;
5531
5532#ifdef FFESTD_F90
5533 fputs ("- CONTAINS\n", dmpout);
5534#endif
5535}
5536
5537#endif
5538/* ffestd_R1229_start -- STMTFUNCTION statement begin
5539
5540 ffestd_R1229_start(func_name,func_arg_list,close_paren);
5541
5542 This function does not really need to do anything, since _finish_
5543 gets all the info needed, and ffestc_R1229_start has already
5544 done all the stuff that makes a two-phase operation (start and
5545 finish) for handling statement functions necessary.
5546
5547 03-Jan-91 JCB 2.0
5548 Do nothing, now that _finish_ does everything. */
5549
5550void
5551ffestd_R1229_start (ffelexToken name UNUSED, ffesttTokenList args UNUSED)
5552{
5553 ffestd_check_start_ ();
5554
5555#if FFECOM_targetCURRENT == FFECOM_targetFFE
5556#elif FFECOM_targetCURRENT == FFECOM_targetGCC
5557#else
5558#error
5559#endif
5560}
5561
5562/* ffestd_R1229_finish -- STMTFUNCTION statement list complete
5563
5564 ffestd_R1229_finish(s);
5565
5566 The statement function's symbol is passed. Its list of dummy args is
5567 accessed via ffesymbol_dummyargs and its expansion expression (expr)
5568 is accessed via ffesymbol_sfexpr.
5569
5570 If sfexpr is NULL, an error occurred parsing the expansion expression, so
5571 just cancel the effects of ffestd_R1229_start and pretend nothing
5572 happened. Otherwise, install the expression as the expansion for the
5573 statement function, then clean up.
5574
5575 03-Jan-91 JCB 2.0
5576 Takes sfunc sym instead of just the expansion expression as an
5577 argument, so this function can do all the work, and _start_ is just
5578 a nicety than can do nothing in a back end. */
5579
5580void
5581ffestd_R1229_finish (ffesymbol s)
5582{
5583#if FFECOM_targetCURRENT == FFECOM_targetFFE
5584 ffebld args = ffesymbol_dummyargs (s);
5585#endif
5586 ffebld expr = ffesymbol_sfexpr (s);
5587
5588 ffestd_check_finish_ ();
5589
5590 if (expr == NULL)
5591 return; /* Nothing to do, definition didn't work. */
5592
5593#if FFECOM_targetCURRENT == FFECOM_targetFFE
5594 fprintf (dmpout, "* stmtfunction %s(", ffesymbol_text (s));
5595 for (; args != NULL; args = ffebld_trail (args))
5596 fprintf (dmpout, "%s,", ffesymbol_text (ffebld_symter (ffebld_head (args))));
5597 fputs (")=", dmpout);
5598 ffebld_dump (expr);
5599 fputc ('\n', dmpout);
5600#if 0 /* Normally no need to preserve the
5601 expression. */
5602 ffesymbol_set_sfexpr (s, NULL); /* Except expr.c sees NULL
5603 as recursive reference!
5604 So until we can use something
5605 convenient, like a "permanent"
5606 expression, don't worry about
5607 wasting some memory in the
5608 stand-alone FFE. */
5609#else
5610 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
5611#endif
5612#elif FFECOM_targetCURRENT == FFECOM_targetGCC
5613 /* With gcc, cannot do anything here, because the backend hasn't even
5614 (necessarily) been notified that we're compiling a program unit! */
5615
5616#if 0 /* Must preserve the expression for gcc. */
5617 ffesymbol_set_sfexpr (s, NULL);
5618#else
5619 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
5620#endif
5621#else
5622#error
5623#endif
5624}
5625
5626/* ffestd_S3P4 -- INCLUDE line
5627
5628 ffestd_S3P4(filename,filename_token);
5629
5630 Make sure INCLUDE not preceded by any semicolons or a label def; implement. */
5631
5632void
5633ffestd_S3P4 (ffebld filename)
5634{
5635 FILE *fi;
5636 ffetargetCharacterDefault buildname;
5637 ffewhereFile wf;
5638
5639 ffestd_check_simple_ ();
5640
5641 assert (filename != NULL);
5642 if (ffebld_op (filename) != FFEBLD_opANY)
5643 {
5644 assert (ffebld_op (filename) == FFEBLD_opCONTER);
5645 assert (ffeinfo_basictype (ffebld_info (filename))
5646 == FFEINFO_basictypeCHARACTER);
5647 assert (ffeinfo_kindtype (ffebld_info (filename))
5648 == FFEINFO_kindtypeCHARACTERDEFAULT);
5649 buildname = ffebld_constant_characterdefault (ffebld_conter (filename));
5650 wf = ffewhere_file_new (ffetarget_text_characterdefault (buildname),
5651 ffetarget_length_characterdefault (buildname));
5652 fi = ffecom_open_include (ffewhere_file_name (wf),
5653 ffelex_token_where_line (ffesta_tokens[0]),
5654 ffelex_token_where_column (ffesta_tokens[0]));
5655 if (fi == NULL)
5656 ffewhere_file_kill (wf);
5657 else
5658 ffelex_set_include (wf, (ffelex_token_type (ffesta_tokens[0])
5659 == FFELEX_typeNAME), fi);
5660 }
5661}
5662
5663/* ffestd_V003_start -- STRUCTURE statement list begin
5664
5665 ffestd_V003_start(structure_name);
5666
5667 Verify that STRUCTURE is valid here, and begin accepting items in the list. */
5668
5669#if FFESTR_VXT
5670void
5671ffestd_V003_start (ffelexToken structure_name)
5672{
5673 ffestd_check_start_ ();
5674
5675#if FFECOM_targetCURRENT == FFECOM_targetFFE
5676 if (structure_name == NULL)
5677 fputs ("* STRUCTURE_unnamed ", dmpout);
5678 else
5679 fprintf (dmpout, "* STRUCTURE %s ", ffelex_token_text (structure_name));
5680#elif FFECOM_targetCURRENT == FFECOM_targetGCC
5681 ffestd_subr_vxt_ ();
5682#else
5683#error
5684#endif
5685}
5686
5687/* ffestd_V003_item -- STRUCTURE statement for object-name
5688
5689 ffestd_V003_item(name_token,dim_list);
5690
5691 Make sure name_token identifies a valid object to be STRUCTUREd. */
5692
5693void
5694ffestd_V003_item (ffelexToken name, ffesttDimList dims)
5695{
5696 ffestd_check_item_ ();
5697
5698#if FFECOM_targetCURRENT == FFECOM_targetFFE
5699 fputs (ffelex_token_text (name), dmpout);
5700 if (dims != NULL)
5701 {
5702 fputc ('(', dmpout);
5703 ffestt_dimlist_dump (dims);
5704 fputc (')', dmpout);
5705 }
5706 fputc (',', dmpout);
5707#elif FFECOM_targetCURRENT == FFECOM_targetGCC
5708#else
5709#error
5710#endif
5711}
5712
5713/* ffestd_V003_finish -- STRUCTURE statement list complete
5714
5715 ffestd_V003_finish();
5716
5717 Just wrap up any local activities. */
5718
5719void
5720ffestd_V003_finish ()
5721{
5722 ffestd_check_finish_ ();
5723
5724#if FFECOM_targetCURRENT == FFECOM_targetFFE
5725 fputc ('\n', dmpout);
5726#elif FFECOM_targetCURRENT == FFECOM_targetGCC
5727#else
5728#error
5729#endif
5730}
5731
5732/* ffestd_V004 -- End a STRUCTURE
5733
5734 ffestd_V004(TRUE); */
5735
5736void
5737ffestd_V004 (bool ok)
5738{
5739#if FFECOM_targetCURRENT == FFECOM_targetFFE
5740 fputs ("* END_STRUCTURE\n", dmpout);
5741#elif FFECOM_targetCURRENT == FFECOM_targetGCC
5742#else
5743#error
5744#endif
5745}
5746
5747/* ffestd_V009 -- UNION statement
5748
5749 ffestd_V009(); */
5750
5751void
5752ffestd_V009 ()
5753{
5754 ffestd_check_simple_ ();
5755
5756#if FFECOM_targetCURRENT == FFECOM_targetFFE
5757 fputs ("* UNION\n", dmpout);
5758#elif FFECOM_targetCURRENT == FFECOM_targetGCC
5759#else
5760#error
5761#endif
5762}
5763
5764/* ffestd_V010 -- End a UNION
5765
5766 ffestd_V010(TRUE); */
5767
5768void
5769ffestd_V010 (bool ok)
5770{
5771#if FFECOM_targetCURRENT == FFECOM_targetFFE
5772 fputs ("* END_UNION\n", dmpout);
5773#elif FFECOM_targetCURRENT == FFECOM_targetGCC
5774#else
5775#error
5776#endif
5777}
5778
5779/* ffestd_V012 -- MAP statement
5780
5781 ffestd_V012(); */
5782
5783void
5784ffestd_V012 ()
5785{
5786 ffestd_check_simple_ ();
5787
5788#if FFECOM_targetCURRENT == FFECOM_targetFFE
5789 fputs ("* MAP\n", dmpout);
5790#elif FFECOM_targetCURRENT == FFECOM_targetGCC
5791#else
5792#error
5793#endif
5794}
5795
5796/* ffestd_V013 -- End a MAP
5797
5798 ffestd_V013(TRUE); */
5799
5800void
5801ffestd_V013 (bool ok)
5802{
5803#if FFECOM_targetCURRENT == FFECOM_targetFFE
5804 fputs ("* END_MAP\n", dmpout);
5805#elif FFECOM_targetCURRENT == FFECOM_targetGCC
5806#else
5807#error
5808#endif
5809}
5810
5811#endif
5812/* ffestd_V014_start -- VOLATILE statement list begin
5813
5814 ffestd_V014_start();
5815
5816 Verify that VOLATILE is valid here, and begin accepting items in the list. */
5817
5818void
5819ffestd_V014_start ()
5820{
5821 ffestd_check_start_ ();
5822
5823#if FFECOM_targetCURRENT == FFECOM_targetFFE
5824 fputs ("* VOLATILE (", dmpout);
5825#elif FFECOM_targetCURRENT == FFECOM_targetGCC
5826 ffestd_subr_vxt_ ();
5827#else
5828#error
5829#endif
5830}
5831
5832/* ffestd_V014_item_object -- VOLATILE statement for object-name
5833
5834 ffestd_V014_item_object(name_token);
5835
5836 Make sure name_token identifies a valid object to be VOLATILEd. */
5837
5838void
5839ffestd_V014_item_object (ffelexToken name UNUSED)
5840{
5841 ffestd_check_item_ ();
5842
5843#if FFECOM_targetCURRENT == FFECOM_targetFFE
5844 fprintf (dmpout, "%s,", ffelex_token_text (name));
5845#elif FFECOM_targetCURRENT == FFECOM_targetGCC
5846#else
5847#error
5848#endif
5849}
5850
5851/* ffestd_V014_item_cblock -- VOLATILE statement for common-block-name
5852
5853 ffestd_V014_item_cblock(name_token);
5854
5855 Make sure name_token identifies a valid common block to be VOLATILEd. */
5856
5857void
5858ffestd_V014_item_cblock (ffelexToken name UNUSED)
5859{
5860 ffestd_check_item_ ();
5861
5862#if FFECOM_targetCURRENT == FFECOM_targetFFE
5863 fprintf (dmpout, "/%s/,", ffelex_token_text (name));
5864#elif FFECOM_targetCURRENT == FFECOM_targetGCC
5865#else
5866#error
5867#endif
5868}
5869
5870/* ffestd_V014_finish -- VOLATILE statement list complete
5871
5872 ffestd_V014_finish();
5873
5874 Just wrap up any local activities. */
5875
5876void
5877ffestd_V014_finish ()
5878{
5879 ffestd_check_finish_ ();
5880
5881#if FFECOM_targetCURRENT == FFECOM_targetFFE
5882 fputs (")\n", dmpout);
5883#elif FFECOM_targetCURRENT == FFECOM_targetGCC
5884#else
5885#error
5886#endif
5887}
5888
5889/* ffestd_V016_start -- RECORD statement list begin
5890
5891 ffestd_V016_start();
5892
5893 Verify that RECORD is valid here, and begin accepting items in the list. */
5894
5895#if FFESTR_VXT
5896void
5897ffestd_V016_start ()
5898{
5899 ffestd_check_start_ ();
5900
5901#if FFECOM_targetCURRENT == FFECOM_targetFFE
5902 fputs ("* RECORD ", dmpout);
5903#elif FFECOM_targetCURRENT == FFECOM_targetGCC
5904 ffestd_subr_vxt_ ();
5905#else
5906#error
5907#endif
5908}
5909
5910/* ffestd_V016_item_structure -- RECORD statement for common-block-name
5911
5912 ffestd_V016_item_structure(name_token);
5913
5914 Make sure name_token identifies a valid structure to be RECORDed. */
5915
5916void
5917ffestd_V016_item_structure (ffelexToken name)
5918{
5919 ffestd_check_item_ ();
5920
5921#if FFECOM_targetCURRENT == FFECOM_targetFFE
5922 fprintf (dmpout, "/%s/,", ffelex_token_text (name));
5923#elif FFECOM_targetCURRENT == FFECOM_targetGCC
5924#else
5925#error
5926#endif
5927}
5928
5929/* ffestd_V016_item_object -- RECORD statement for object-name
5930
5931 ffestd_V016_item_object(name_token,dim_list);
5932
5933 Make sure name_token identifies a valid object to be RECORDd. */
5934
5935void
5936ffestd_V016_item_object (ffelexToken name, ffesttDimList dims)
5937{
5938 ffestd_check_item_ ();
5939
5940#if FFECOM_targetCURRENT == FFECOM_targetFFE
5941 fputs (ffelex_token_text (name), dmpout);
5942 if (dims != NULL)
5943 {
5944 fputc ('(', dmpout);
5945 ffestt_dimlist_dump (dims);
5946 fputc (')', dmpout);
5947 }
5948 fputc (',', dmpout);
5949#elif FFECOM_targetCURRENT == FFECOM_targetGCC
5950#else
5951#error
5952#endif
5953}
5954
5955/* ffestd_V016_finish -- RECORD statement list complete
5956
5957 ffestd_V016_finish();
5958
5959 Just wrap up any local activities. */
5960
5961void
5962ffestd_V016_finish ()
5963{
5964 ffestd_check_finish_ ();
5965
5966#if FFECOM_targetCURRENT == FFECOM_targetFFE
5967 fputc ('\n', dmpout);
5968#elif FFECOM_targetCURRENT == FFECOM_targetGCC
5969#else
5970#error
5971#endif
5972}
5973
5974/* ffestd_V018_start -- REWRITE(...) statement list begin
5975
5976 ffestd_V018_start();
5977
5978 Verify that REWRITE is valid here, and begin accepting items in the
5979 list. */
5980
5981void
5982ffestd_V018_start (ffestvFormat format)
5983{
5984 ffestd_check_start_ ();
5985
5986#if FFECOM_targetCURRENT == FFECOM_targetFFE
5987
5988#if FFECOM_ONEPASS
5989 ffestd_subr_line_now_ ();
5990 ffeste_V018_start (&ffestp_file.rewrite, format);
5991#else
5992 {
5993 ffestdStmt_ stmt;
5994
5995 stmt = ffestd_stmt_new_ (FFESTD_stmtidV018_);
5996 ffestd_stmt_append_ (stmt);
5997 ffestd_subr_line_save_ (stmt);
5998 stmt->u.V018.pool = ffesta_output_pool;
5999 stmt->u.V018.params = ffestd_subr_copy_rewrite_ ();
6000 stmt->u.V018.format = format;
6001 stmt->u.V018.list = NULL;
6002 ffestd_expr_list_ = &stmt->u.V018.list;
6003 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
6004 }
6005#endif
6006
6007#endif
6008#if FFECOM_targetCURRENT == FFECOM_targetGCC
6009 ffestd_subr_vxt_ ();
6010#endif
6011}
6012
6013/* ffestd_V018_item -- REWRITE statement i/o item
6014
6015 ffestd_V018_item(expr,expr_token);
6016
6017 Implement output-list expression. */
6018
6019void
6020ffestd_V018_item (ffebld expr)
6021{
6022 ffestd_check_item_ ();
6023
6024#if FFECOM_targetCURRENT == FFECOM_targetFFE
6025
6026#if FFECOM_ONEPASS
6027 ffeste_V018_item (expr);
6028#else
6029 {
6030 ffestdExprItem_ item
6031 = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, "ffestdExprItem_",
6032 sizeof (*item));
6033
6034 item->next = NULL;
6035 item->expr = expr;
6036 *ffestd_expr_list_ = item;
6037 ffestd_expr_list_ = &item->next;
6038 }
6039#endif
6040
6041#endif
6042#if FFECOM_targetCURRENT == FFECOM_targetGCC
6043#endif
6044}
6045
6046/* ffestd_V018_finish -- REWRITE statement list complete
6047
6048 ffestd_V018_finish();
6049
6050 Just wrap up any local activities. */
6051
6052void
6053ffestd_V018_finish ()
6054{
6055 ffestd_check_finish_ ();
6056
6057#if FFECOM_targetCURRENT == FFECOM_targetFFE
6058
6059#if FFECOM_ONEPASS
6060 ffeste_V018_finish ();
6061#else
6062 /* Nothing to do, it's implicit. */
6063#endif
6064
6065#endif
6066#if FFECOM_targetCURRENT == FFECOM_targetGCC
6067#endif
6068}
6069
6070/* ffestd_V019_start -- ACCEPT statement list begin
6071
6072 ffestd_V019_start();
6073
6074 Verify that ACCEPT is valid here, and begin accepting items in the
6075 list. */
6076
6077void
6078ffestd_V019_start (ffestvFormat format)
6079{
6080 ffestd_check_start_ ();
6081
6082#if FFECOM_targetCURRENT == FFECOM_targetFFE
6083
6084#if FFECOM_ONEPASS
6085 ffestd_subr_line_now_ ();
6086 ffeste_V019_start (&ffestp_file.accept, format);
6087#else
6088 {
6089 ffestdStmt_ stmt;
6090
6091 stmt = ffestd_stmt_new_ (FFESTD_stmtidV019_);
6092 ffestd_stmt_append_ (stmt);
6093 ffestd_subr_line_save_ (stmt);
6094 stmt->u.V019.pool = ffesta_output_pool;
6095 stmt->u.V019.params = ffestd_subr_copy_accept_ ();
6096 stmt->u.V019.format = format;
6097 stmt->u.V019.list = NULL;
6098 ffestd_expr_list_ = &stmt->u.V019.list;
6099 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
6100 }
6101#endif
6102
6103#endif
6104#if FFECOM_targetCURRENT == FFECOM_targetGCC
6105 ffestd_subr_vxt_ ();
6106#endif
6107}
6108
6109/* ffestd_V019_item -- ACCEPT statement i/o item
6110
6111 ffestd_V019_item(expr,expr_token);
6112
6113 Implement output-list expression. */
6114
6115void
6116ffestd_V019_item (ffebld expr)
6117{
6118 ffestd_check_item_ ();
6119
6120#if FFECOM_targetCURRENT == FFECOM_targetFFE
6121
6122#if FFECOM_ONEPASS
6123 ffeste_V019_item (expr);
6124#else
6125 {
6126 ffestdExprItem_ item
6127 = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, "ffestdExprItem_",
6128 sizeof (*item));
6129
6130 item->next = NULL;
6131 item->expr = expr;
6132 *ffestd_expr_list_ = item;
6133 ffestd_expr_list_ = &item->next;
6134 }
6135#endif
6136
6137#endif
6138#if FFECOM_targetCURRENT == FFECOM_targetGCC
6139#endif
6140}
6141
6142/* ffestd_V019_finish -- ACCEPT statement list complete
6143
6144 ffestd_V019_finish();
6145
6146 Just wrap up any local activities. */
6147
6148void
6149ffestd_V019_finish ()
6150{
6151 ffestd_check_finish_ ();
6152
6153#if FFECOM_targetCURRENT == FFECOM_targetFFE
6154
6155#if FFECOM_ONEPASS
6156 ffeste_V019_finish ();
6157#else
6158 /* Nothing to do, it's implicit. */
6159#endif
6160
6161#endif
6162#if FFECOM_targetCURRENT == FFECOM_targetGCC
6163#endif
6164}
6165
6166#endif
6167/* ffestd_V020_start -- TYPE statement list begin
6168
6169 ffestd_V020_start();
6170
6171 Verify that TYPE is valid here, and begin accepting items in the
6172 list. */
6173
6174void
6175ffestd_V020_start (ffestvFormat format UNUSED)
6176{
6177 ffestd_check_start_ ();
6178
6179#if FFECOM_targetCURRENT == FFECOM_targetFFE
6180
6181#if FFECOM_ONEPASS
6182 ffestd_subr_line_now_ ();
6183 ffeste_V020_start (&ffestp_file.type, format);
6184#else
6185 {
6186 ffestdStmt_ stmt;
6187
6188 stmt = ffestd_stmt_new_ (FFESTD_stmtidV020_);
6189 ffestd_stmt_append_ (stmt);
6190 ffestd_subr_line_save_ (stmt);
6191 stmt->u.V020.pool = ffesta_output_pool;
6192 stmt->u.V020.params = ffestd_subr_copy_type_ ();
6193 stmt->u.V020.format = format;
6194 stmt->u.V020.list = NULL;
6195 ffestd_expr_list_ = &stmt->u.V020.list;
6196 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
6197 }
6198#endif
6199
6200#endif
6201#if FFECOM_targetCURRENT == FFECOM_targetGCC
6202 ffestd_subr_vxt_ ();
6203#endif
6204}
6205
6206/* ffestd_V020_item -- TYPE statement i/o item
6207
6208 ffestd_V020_item(expr,expr_token);
6209
6210 Implement output-list expression. */
6211
6212void
6213ffestd_V020_item (ffebld expr UNUSED)
6214{
6215 ffestd_check_item_ ();
6216
6217#if FFECOM_targetCURRENT == FFECOM_targetFFE
6218
6219#if FFECOM_ONEPASS
6220 ffeste_V020_item (expr);
6221#else
6222 {
6223 ffestdExprItem_ item
6224 = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, "ffestdExprItem_",
6225 sizeof (*item));
6226
6227 item->next = NULL;
6228 item->expr = expr;
6229 *ffestd_expr_list_ = item;
6230 ffestd_expr_list_ = &item->next;
6231 }
6232#endif
6233
6234#endif
6235#if FFECOM_targetCURRENT == FFECOM_targetGCC
6236#endif
6237}
6238
6239/* ffestd_V020_finish -- TYPE statement list complete
6240
6241 ffestd_V020_finish();
6242
6243 Just wrap up any local activities. */
6244
6245void
6246ffestd_V020_finish ()
6247{
6248 ffestd_check_finish_ ();
6249
6250#if FFECOM_targetCURRENT == FFECOM_targetFFE
6251
6252#if FFECOM_ONEPASS
6253 ffeste_V020_finish ();
6254#else
6255 /* Nothing to do, it's implicit. */
6256#endif
6257
6258#endif
6259#if FFECOM_targetCURRENT == FFECOM_targetGCC
6260#endif
6261}
6262
6263/* ffestd_V021 -- DELETE statement
6264
6265 ffestd_V021();
6266
6267 Make sure a DELETE is valid in the current context, and implement it. */
6268
6269#if FFESTR_VXT
6270void
6271ffestd_V021 ()
6272{
6273 ffestd_check_simple_ ();
6274
6275#if FFECOM_targetCURRENT == FFECOM_targetFFE
6276
6277#if FFECOM_ONEPASS
6278 ffestd_subr_line_now_ ();
6279 ffeste_V021 (&ffestp_file.delete);
6280#else
6281 {
6282 ffestdStmt_ stmt;
6283
6284 stmt = ffestd_stmt_new_ (FFESTD_stmtidV021_);
6285 ffestd_stmt_append_ (stmt);
6286 ffestd_subr_line_save_ (stmt);
6287 stmt->u.V021.pool = ffesta_output_pool;
6288 stmt->u.V021.params = ffestd_subr_copy_delete_ ();
6289 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
6290 }
6291#endif
6292
6293#endif
6294#if FFECOM_targetCURRENT == FFECOM_targetGCC
6295 ffestd_subr_vxt_ ();
6296#endif
6297}
6298
6299/* ffestd_V022 -- UNLOCK statement
6300
6301 ffestd_V022();
6302
6303 Make sure a UNLOCK is valid in the current context, and implement it. */
6304
6305void
6306ffestd_V022 ()
6307{
6308 ffestd_check_simple_ ();
6309
6310#if FFECOM_targetCURRENT == FFECOM_targetFFE
6311
6312#if FFECOM_ONEPASS
6313 ffestd_subr_line_now_ ();
6314 ffeste_V022 (&ffestp_file.beru);
6315#else
6316 {
6317 ffestdStmt_ stmt;
6318
6319 stmt = ffestd_stmt_new_ (FFESTD_stmtidV022_);
6320 ffestd_stmt_append_ (stmt);
6321 ffestd_subr_line_save_ (stmt);
6322 stmt->u.V022.pool = ffesta_output_pool;
6323 stmt->u.V022.params = ffestd_subr_copy_beru_ ();
6324 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
6325 }
6326#endif
6327
6328#endif
6329#if FFECOM_targetCURRENT == FFECOM_targetGCC
6330 ffestd_subr_vxt_ ();
6331#endif
6332}
6333
6334/* ffestd_V023_start -- ENCODE(...) statement list begin
6335
6336 ffestd_V023_start();
6337
6338 Verify that ENCODE is valid here, and begin accepting items in the
6339 list. */
6340
6341void
6342ffestd_V023_start ()
6343{
6344 ffestd_check_start_ ();
6345
6346#if FFECOM_targetCURRENT == FFECOM_targetFFE
6347
6348#if FFECOM_ONEPASS
6349 ffestd_subr_line_now_ ();
6350 ffeste_V023_start (&ffestp_file.vxtcode);
6351#else
6352 {
6353 ffestdStmt_ stmt;
6354
6355 stmt = ffestd_stmt_new_ (FFESTD_stmtidV023_);
6356 ffestd_stmt_append_ (stmt);
6357 ffestd_subr_line_save_ (stmt);
6358 stmt->u.V023.pool = ffesta_output_pool;
6359 stmt->u.V023.params = ffestd_subr_copy_vxtcode_ ();
6360 stmt->u.V023.list = NULL;
6361 ffestd_expr_list_ = &stmt->u.V023.list;
6362 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
6363 }
6364#endif
6365
6366#endif
6367#if FFECOM_targetCURRENT == FFECOM_targetGCC
6368 ffestd_subr_vxt_ ();
6369#endif
6370}
6371
6372/* ffestd_V023_item -- ENCODE statement i/o item
6373
6374 ffestd_V023_item(expr,expr_token);
6375
6376 Implement output-list expression. */
6377
6378void
6379ffestd_V023_item (ffebld expr)
6380{
6381 ffestd_check_item_ ();
6382
6383#if FFECOM_targetCURRENT == FFECOM_targetFFE
6384
6385#if FFECOM_ONEPASS
6386 ffeste_V023_item (expr);
6387#else
6388 {
6389 ffestdExprItem_ item
6390 = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, "ffestdExprItem_",
6391 sizeof (*item));
6392
6393 item->next = NULL;
6394 item->expr = expr;
6395 *ffestd_expr_list_ = item;
6396 ffestd_expr_list_ = &item->next;
6397 }
6398#endif
6399
6400#endif
6401#if FFECOM_targetCURRENT == FFECOM_targetGCC
6402#endif
6403}
6404
6405/* ffestd_V023_finish -- ENCODE statement list complete
6406
6407 ffestd_V023_finish();
6408
6409 Just wrap up any local activities. */
6410
6411void
6412ffestd_V023_finish ()
6413{
6414 ffestd_check_finish_ ();
6415
6416#if FFECOM_targetCURRENT == FFECOM_targetFFE
6417
6418#if FFECOM_ONEPASS
6419 ffeste_V023_finish ();
6420#else
6421 /* Nothing to do, it's implicit. */
6422#endif
6423
6424#endif
6425#if FFECOM_targetCURRENT == FFECOM_targetGCC
6426#endif
6427}
6428
6429/* ffestd_V024_start -- DECODE(...) statement list begin
6430
6431 ffestd_V024_start();
6432
6433 Verify that DECODE is valid here, and begin accepting items in the
6434 list. */
6435
6436void
6437ffestd_V024_start ()
6438{
6439 ffestd_check_start_ ();
6440
6441#if FFECOM_targetCURRENT == FFECOM_targetFFE
6442
6443#if FFECOM_ONEPASS
6444 ffestd_subr_line_now_ ();
6445 ffeste_V024_start (&ffestp_file.vxtcode);
6446#else
6447 {
6448 ffestdStmt_ stmt;
6449
6450 stmt = ffestd_stmt_new_ (FFESTD_stmtidV024_);
6451 ffestd_stmt_append_ (stmt);
6452 ffestd_subr_line_save_ (stmt);
6453 stmt->u.V024.pool = ffesta_output_pool;
6454 stmt->u.V024.params = ffestd_subr_copy_vxtcode_ ();
6455 stmt->u.V024.list = NULL;
6456 ffestd_expr_list_ = &stmt->u.V024.list;
6457 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
6458 }
6459#endif
6460
6461#endif
6462#if FFECOM_targetCURRENT == FFECOM_targetGCC
6463 ffestd_subr_vxt_ ();
6464#endif
6465}
6466
6467/* ffestd_V024_item -- DECODE statement i/o item
6468
6469 ffestd_V024_item(expr,expr_token);
6470
6471 Implement output-list expression. */
6472
6473void
6474ffestd_V024_item (ffebld expr)
6475{
6476 ffestd_check_item_ ();
6477
6478#if FFECOM_targetCURRENT == FFECOM_targetFFE
6479
6480#if FFECOM_ONEPASS
6481 ffeste_V024_item (expr);
6482#else
6483 {
6484 ffestdExprItem_ item
6485 = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, "ffestdExprItem_",
6486 sizeof (*item));
6487
6488 item->next = NULL;
6489 item->expr = expr;
6490 *ffestd_expr_list_ = item;
6491 ffestd_expr_list_ = &item->next;
6492 }
6493#endif
6494
6495#endif
6496#if FFECOM_targetCURRENT == FFECOM_targetGCC
6497#endif
6498}
6499
6500/* ffestd_V024_finish -- DECODE statement list complete
6501
6502 ffestd_V024_finish();
6503
6504 Just wrap up any local activities. */
6505
6506void
6507ffestd_V024_finish ()
6508{
6509 ffestd_check_finish_ ();
6510
6511#if FFECOM_targetCURRENT == FFECOM_targetFFE
6512
6513#if FFECOM_ONEPASS
6514 ffeste_V024_finish ();
6515#else
6516 /* Nothing to do, it's implicit. */
6517#endif
6518
6519#endif
6520#if FFECOM_targetCURRENT == FFECOM_targetGCC
6521#endif
6522}
6523
6524/* ffestd_V025_start -- DEFINEFILE statement list begin
6525
6526 ffestd_V025_start();
6527
6528 Verify that DEFINEFILE is valid here, and begin accepting items in the
6529 list. */
6530
6531void
6532ffestd_V025_start ()
6533{
6534 ffestd_check_start_ ();
6535
6536#if FFECOM_targetCURRENT == FFECOM_targetFFE
6537
6538#if FFECOM_ONEPASS
6539 ffestd_subr_line_now_ ();
6540 ffeste_V025_start ();
6541#else
6542 {
6543 ffestdStmt_ stmt;
6544
6545 stmt = ffestd_stmt_new_ (FFESTD_stmtidV025start_);
6546 ffestd_stmt_append_ (stmt);
6547 ffestd_subr_line_save_ (stmt);
6548 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
6549 }
6550#endif
6551
6552#endif
6553#if FFECOM_targetCURRENT == FFECOM_targetGCC
6554 ffestd_subr_vxt_ ();
6555#endif
6556}
6557
6558/* ffestd_V025_item -- DEFINE FILE statement item
6559
6560 ffestd_V025_item(u,ut,m,mt,n,nt,asv,asvt);
6561
6562 Implement item. Treat each item kind of like a separate statement,
6563 since there's really no need to treat them as an aggregate. */
6564
6565void
6566ffestd_V025_item (ffebld u, ffebld m, ffebld n, ffebld asv)
6567{
6568 ffestd_check_item_ ();
6569
6570#if FFECOM_targetCURRENT == FFECOM_targetFFE
6571
6572#if FFECOM_ONEPASS
6573 ffeste_V025_item (u, m, n, asv);
6574#else
6575 {
6576 ffestdStmt_ stmt;
6577
6578 stmt = ffestd_stmt_new_ (FFESTD_stmtidV025item_);
6579 ffestd_stmt_append_ (stmt);
6580 stmt->u.V025item.u = u;
6581 stmt->u.V025item.m = m;
6582 stmt->u.V025item.n = n;
6583 stmt->u.V025item.asv = asv;
6584 }
6585#endif
6586
6587#endif
6588#if FFECOM_targetCURRENT == FFECOM_targetGCC
6589#endif
6590}
6591
6592/* ffestd_V025_finish -- DEFINE FILE statement list complete
6593
6594 ffestd_V025_finish();
6595
6596 Just wrap up any local activities. */
6597
6598void
6599ffestd_V025_finish ()
6600{
6601 ffestd_check_finish_ ();
6602
6603#if FFECOM_targetCURRENT == FFECOM_targetFFE
6604
6605#if FFECOM_ONEPASS
6606 ffeste_V025_finish ();
6607#else
6608 {
6609 ffestdStmt_ stmt;
6610
6611 stmt = ffestd_stmt_new_ (FFESTD_stmtidV025finish_);
6612 stmt->u.V025finish.pool = ffesta_output_pool;
6613 ffestd_stmt_append_ (stmt);
6614 }
6615#endif
6616
6617#endif
6618#if FFECOM_targetCURRENT == FFECOM_targetGCC
6619#endif
6620}
6621
6622/* ffestd_V026 -- FIND statement
6623
6624 ffestd_V026();
6625
6626 Make sure a FIND is valid in the current context, and implement it. */
6627
6628void
6629ffestd_V026 ()
6630{
6631 ffestd_check_simple_ ();
6632
6633#if FFECOM_targetCURRENT == FFECOM_targetFFE
6634
6635#if FFECOM_ONEPASS
6636 ffestd_subr_line_now_ ();
6637 ffeste_V026 (&ffestp_file.find);
6638#else
6639 {
6640 ffestdStmt_ stmt;
6641
6642 stmt = ffestd_stmt_new_ (FFESTD_stmtidV026_);
6643 ffestd_stmt_append_ (stmt);
6644 ffestd_subr_line_save_ (stmt);
6645 stmt->u.V026.pool = ffesta_output_pool;
6646 stmt->u.V026.params = ffestd_subr_copy_find_ ();
6647 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
6648 }
6649#endif
6650
6651#endif
6652#if FFECOM_targetCURRENT == FFECOM_targetGCC
6653 ffestd_subr_vxt_ ();
6654#endif
6655}
6656
6657#endif
6658/* ffestd_V027_start -- VXT PARAMETER statement list begin
6659
6660 ffestd_V027_start();
6661
6662 Verify that PARAMETER is valid here, and begin accepting items in the list. */
6663
6664void
6665ffestd_V027_start ()
6666{
6667 ffestd_check_start_ ();
6668
6669#if FFECOM_targetCURRENT == FFECOM_targetFFE
6670 fputs ("* PARAMETER_vxt ", dmpout);
6671#else
6672#if FFECOM_targetCURRENT == FFECOM_targetGCC
6673 ffestd_subr_vxt_ ();
6674#endif
6675#endif
6676}
6677
6678/* ffestd_V027_item -- VXT PARAMETER statement assignment
6679
6680 ffestd_V027_item(dest,dest_token,source,source_token);
6681
6682 Make sure the source is a valid source for the destination; make the
6683 assignment. */
6684
6685void
6686ffestd_V027_item (ffelexToken dest_token UNUSED, ffebld source UNUSED)
6687{
6688 ffestd_check_item_ ();
6689
6690#if FFECOM_targetCURRENT == FFECOM_targetFFE
6691 fputs (ffelex_token_text (dest_token), dmpout);
6692 fputc ('=', dmpout);
6693 ffebld_dump (source);
6694 fputc (',', dmpout);
6695#elif FFECOM_targetCURRENT == FFECOM_targetGCC
6696#else
6697#error
6698#endif
6699}
6700
6701/* ffestd_V027_finish -- VXT PARAMETER statement list complete
6702
6703 ffestd_V027_finish();
6704
6705 Just wrap up any local activities. */
6706
6707void
6708ffestd_V027_finish ()
6709{
6710 ffestd_check_finish_ ();
6711
6712#if FFECOM_targetCURRENT == FFECOM_targetFFE
6713 fputc ('\n', dmpout);
6714#elif FFECOM_targetCURRENT == FFECOM_targetGCC
6715#else
6716#error
6717#endif
6718}
6719
6720/* Any executable statement. */
6721
6722void
6723ffestd_any ()
6724{
6725 ffestd_check_simple_ ();
6726
6727#if FFECOM_ONEPASS
6728 ffestd_subr_line_now_ ();
6729 ffeste_R841 ();
6730#else
6731 {
6732 ffestdStmt_ stmt;
6733
6734 stmt = ffestd_stmt_new_ (FFESTD_stmtidR841_);
6735 ffestd_stmt_append_ (stmt);
6736 ffestd_subr_line_save_ (stmt);
6737 }
6738#endif
6739}
GNU Compiler Collection
This page took 0.696379 seconds and 5 git commands to generate.