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