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