projects / gcc.git / blob
? search:


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