?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* config.gcc <arm>: Add --with-abi=
[official-gcc.git] / gcc / f / std.c
blob09f04198f0a889bfba9920e650869820bc1acb21
1 /* std.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995, 1996, 2000, 2002, 2003 Free Software Foundation, Inc.
3 Contributed by James Craig Burley.
4
5 This file is part of GNU Fortran.
6
7 GNU Fortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
10 any later version.
11
12 GNU Fortran is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with GNU Fortran; see the file COPYING. If not, write to
19 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
20 02111-1307, USA.
21
22 Related Modules:
23 st.c
24
25 Description:
26 Implements the various statements and such like.
27
28 Modifications:
29 21-Nov-91 JCB 2.0
30 Split out actual code generation to ffeste.
31 */
32
33 /* Include files. */
34
35 #include "proj.h"
36 #include "std.h"
37 #include "bld.h"
38 #include "com.h"
39 #include "lab.h"
40 #include "lex.h"
41 #include "malloc.h"
42 #include "sta.h"
43 #include "ste.h"
44 #include "stp.h"
45 #include "str.h"
46 #include "sts.h"
47 #include "stt.h"
48 #include "stv.h"
49 #include "stw.h"
50 #include "symbol.h"
51 #include "target.h"
52
53 /* Externals defined here. */
54
55
56 /* Simple definitions and enumerations. */
57
58 #define FFESTD_COPY_EASY_ 1 /* 1 for only one _subr_copy_xyz_ fn. */
59
60 #define FFESTD_IS_END_OPTIMIZED_ 1 /* 0=always gen STOP/RETURN before
61 END. */
62
63 typedef enum
64 {
65 FFESTD_stateletSIMPLE_, /* Expecting simple/start. */
66 FFESTD_stateletATTRIB_, /* Expecting attrib/item/itemstart. */
67 FFESTD_stateletITEM_, /* Expecting item/itemstart/finish. */
68 FFESTD_stateletITEMVALS_, /* Expecting itemvalue/itemendvals. */
69 FFESTD_
70 } ffestdStatelet_;
71
72 typedef enum
73 {
74 FFESTD_stmtidENDDOLOOP_,
75 FFESTD_stmtidENDLOGIF_,
76 FFESTD_stmtidEXECLABEL_,
77 FFESTD_stmtidFORMATLABEL_,
78 FFESTD_stmtidR737A_, /* let */
79 FFESTD_stmtidR803_, /* IF-block */
80 FFESTD_stmtidR804_, /* ELSE IF */
81 FFESTD_stmtidR805_, /* ELSE */
82 FFESTD_stmtidR806_, /* END IF */
83 FFESTD_stmtidR807_, /* IF-logical */
84 FFESTD_stmtidR809_, /* SELECT CASE */
85 FFESTD_stmtidR810_, /* CASE */
86 FFESTD_stmtidR811_, /* END SELECT */
87 FFESTD_stmtidR819A_, /* DO-iterative */
88 FFESTD_stmtidR819B_, /* DO WHILE */
89 FFESTD_stmtidR825_, /* END DO */
90 FFESTD_stmtidR834_, /* CYCLE */
91 FFESTD_stmtidR835_, /* EXIT */
92 FFESTD_stmtidR836_, /* GOTO */
93 FFESTD_stmtidR837_, /* GOTO-computed */
94 FFESTD_stmtidR838_, /* ASSIGN */
95 FFESTD_stmtidR839_, /* GOTO-assigned */
96 FFESTD_stmtidR840_, /* IF-arithmetic */
97 FFESTD_stmtidR841_, /* CONTINUE */
98 FFESTD_stmtidR842_, /* STOP */
99 FFESTD_stmtidR843_, /* PAUSE */
100 FFESTD_stmtidR904_, /* OPEN */
101 FFESTD_stmtidR907_, /* CLOSE */
102 FFESTD_stmtidR909_, /* READ */
103 FFESTD_stmtidR910_, /* WRITE */
104 FFESTD_stmtidR911_, /* PRINT */
105 FFESTD_stmtidR919_, /* BACKSPACE */
106 FFESTD_stmtidR920_, /* ENDFILE */
107 FFESTD_stmtidR921_, /* REWIND */
108 FFESTD_stmtidR923A_, /* INQUIRE */
109 FFESTD_stmtidR923B_, /* INQUIRE-iolength */
110 FFESTD_stmtidR1001_, /* FORMAT */
111 FFESTD_stmtidR1103_, /* END_PROGRAM */
112 FFESTD_stmtidR1112_, /* END_BLOCK_DATA */
113 FFESTD_stmtidR1212_, /* CALL */
114 FFESTD_stmtidR1221_, /* END_FUNCTION */
115 FFESTD_stmtidR1225_, /* END_SUBROUTINE */
116 FFESTD_stmtidR1226_, /* ENTRY */
117 FFESTD_stmtidR1227_, /* RETURN */
118 FFESTD_stmtidV020_, /* TYPE */
119 FFESTD_stmtid_,
120 } ffestdStmtId_;
121
122 /* Internal typedefs. */
123
124 typedef struct _ffestd_expr_item_ *ffestdExprItem_;
125 typedef struct _ffestd_stmt_ *ffestdStmt_;
126
127 /* Private include files. */
128
129
130 /* Internal structure definitions. */
131
132 struct _ffestd_expr_item_
133 {
134 ffestdExprItem_ next;
135 ffebld expr;
136 ffelexToken token;
137 };
138
139 struct _ffestd_stmt_
140 {
141 ffestdStmt_ next;
142 ffestdStmt_ previous;
143 ffestdStmtId_ id;
144 char *filename;
145 int filelinenum;
146 union
147 {
148 struct
149 {
150 ffestw block;
151 }
152 enddoloop;
153 struct
154 {
155 ffelab label;
156 }
157 execlabel;
158 struct
159 {
160 ffelab label;
161 }
162 formatlabel;
163 struct
164 {
165 mallocPool pool;
166 ffebld dest;
167 ffebld source;
168 }
169 R737A;
170 struct
171 {
172 mallocPool pool;
173 ffestw block;
174 ffebld expr;
175 }
176 R803;
177 struct
178 {
179 mallocPool pool;
180 ffestw block;
181 ffebld expr;
182 }
183 R804;
184 struct
185 {
186 ffestw block;
187 }
188 R805;
189 struct
190 {
191 ffestw block;
192 }
193 R806;
194 struct
195 {
196 mallocPool pool;
197 ffebld expr;
198 }
199 R807;
200 struct
201 {
202 mallocPool pool;
203 ffestw block;
204 ffebld expr;
205 }
206 R809;
207 struct
208 {
209 mallocPool pool;
210 ffestw block;
211 unsigned long casenum;
212 }
213 R810;
214 struct
215 {
216 ffestw block;
217 }
218 R811;
219 struct
220 {
221 mallocPool pool;
222 ffestw block;
223 ffelab label;
224 ffebld var;
225 ffebld start;
226 ffelexToken start_token;
227 ffebld end;
228 ffelexToken end_token;
229 ffebld incr;
230 ffelexToken incr_token;
231 }
232 R819A;
233 struct
234 {
235 mallocPool pool;
236 ffestw block;
237 ffelab label;
238 ffebld expr;
239 }
240 R819B;
241 struct
242 {
243 ffestw block;
244 }
245 R834;
246 struct
247 {
248 ffestw block;
249 }
250 R835;
251 struct
252 {
253 ffelab label;
254 }
255 R836;
256 struct
257 {
258 mallocPool pool;
259 ffelab *labels;
260 int count;
261 ffebld expr;
262 }
263 R837;
264 struct
265 {
266 mallocPool pool;
267 ffelab label;
268 ffebld target;
269 }
270 R838;
271 struct
272 {
273 mallocPool pool;
274 ffebld target;
275 }
276 R839;
277 struct
278 {
279 mallocPool pool;
280 ffebld expr;
281 ffelab neg;
282 ffelab zero;
283 ffelab pos;
284 }
285 R840;
286 struct
287 {
288 mallocPool pool;
289 ffebld expr;
290 }
291 R842;
292 struct
293 {
294 mallocPool pool;
295 ffebld expr;
296 }
297 R843;
298 struct
299 {
300 mallocPool pool;
301 ffestpOpenStmt *params;
302 }
303 R904;
304 struct
305 {
306 mallocPool pool;
307 ffestpCloseStmt *params;
308 }
309 R907;
310 struct
311 {
312 mallocPool pool;
313 ffestpReadStmt *params;
314 bool only_format;
315 ffestvUnit unit;
316 ffestvFormat format;
317 bool rec;
318 bool key;
319 ffestdExprItem_ list;
320 }
321 R909;
322 struct
323 {
324 mallocPool pool;
325 ffestpWriteStmt *params;
326 ffestvUnit unit;
327 ffestvFormat format;
328 bool rec;
329 ffestdExprItem_ list;
330 }
331 R910;
332 struct
333 {
334 mallocPool pool;
335 ffestpPrintStmt *params;
336 ffestvFormat format;
337 ffestdExprItem_ list;
338 }
339 R911;
340 struct
341 {
342 mallocPool pool;
343 ffestpBeruStmt *params;
344 }
345 R919;
346 struct
347 {
348 mallocPool pool;
349 ffestpBeruStmt *params;
350 }
351 R920;
352 struct
353 {
354 mallocPool pool;
355 ffestpBeruStmt *params;
356 }
357 R921;
358 struct
359 {
360 mallocPool pool;
361 ffestpInquireStmt *params;
362 bool by_file;
363 }
364 R923A;
365 struct
366 {
367 mallocPool pool;
368 ffestpInquireStmt *params;
369 ffestdExprItem_ list;
370 }
371 R923B;
372 struct
373 {
374 ffestsHolder str;
375 }
376 R1001;
377 struct
378 {
379 mallocPool pool;
380 ffebld expr;
381 }
382 R1212;
383 struct
384 {
385 ffesymbol entry;
386 int entrynum;
387 }
388 R1226;
389 struct
390 {
391 mallocPool pool;
392 ffestw block;
393 ffebld expr;
394 }
395 R1227;
396 struct
397 {
398 mallocPool pool;
399 ffestpTypeStmt *params;
400 ffestvFormat format;
401 ffestdExprItem_ list;
402 }
403 V020;
404 }
405 u;
406 };
407
408 /* Static objects accessed by functions in this module. */
409
410 static ffestdStatelet_ ffestd_statelet_ = FFESTD_stateletSIMPLE_;
411 static int ffestd_block_level_ = 0; /* Block level for reachableness. */
412 static bool ffestd_is_reachable_; /* Is the current stmt reachable? */
413 static ffelab ffestd_label_formatdef_ = NULL;
414 static ffestdExprItem_ *ffestd_expr_list_;
415 static struct
416 {
417 ffestdStmt_ first;
418 ffestdStmt_ last;
419 }
420 ffestd_stmt_list_ =
421 {
422 NULL, NULL
423 };
424
425
426 /* # ENTRY statements pending. */
427 static int ffestd_2pass_entrypoints_ = 0;
428
429 /* Static functions (internal). */
430
431 static void ffestd_stmt_append_ (ffestdStmt_ stmt);
432 static ffestdStmt_ ffestd_stmt_new_ (ffestdStmtId_ id);
433 static void ffestd_stmt_pass_ (void);
434 #if FFESTD_COPY_EASY_
435 static ffestpInquireStmt *ffestd_subr_copy_easy_ (ffestpInquireIx max);
436 #endif
437 static void ffestd_subr_vxt_ (void);
438 static void ffestd_subr_labels_ (bool unexpected);
439 static void ffestd_R1001dump_ (ffests s, ffesttFormatList list);
440 static void ffestd_R1001dump_1005_1_ (ffests s, ffesttFormatList f,
441 const char *string);
442 static void ffestd_R1001dump_1005_2_ (ffests s, ffesttFormatList f,
443 const char *string);
444 static void ffestd_R1001dump_1005_3_ (ffests s, ffesttFormatList f,
445 const char *string);
446 static void ffestd_R1001dump_1005_4_ (ffests s, ffesttFormatList f,
447 const char *string);
448 static void ffestd_R1001dump_1005_5_ (ffests s, ffesttFormatList f,
449 const char *string);
450 static void ffestd_R1001dump_1010_1_ (ffests s, ffesttFormatList f,
451 const char *string);
452 static void ffestd_R1001dump_1010_2_ (ffests s, ffesttFormatList f,
453 const char *string);
454 static void ffestd_R1001dump_1010_4_ (ffests s, ffesttFormatList f,
455 const char *string);
456 static void ffestd_R1001dump_1010_5_ (ffests s, ffesttFormatList f,
457 const char *string);
458 static void ffestd_R1001error_ (ffesttFormatList f);
459 static void ffestd_R1001rtexpr_ (ffests s, ffesttFormatList f, ffebld expr);
460
461 /* Internal macros. */
462
463 #define ffestd_subr_line_now_() \
464 ffeste_set_line (ffelex_token_where_filename (ffesta_tokens[0]), \
465 ffelex_token_where_filelinenum (ffesta_tokens[0]))
466 #define ffestd_subr_line_restore_(s) \
467 ffeste_set_line ((s)->filename, (s)->filelinenum)
468 #define ffestd_subr_line_save_(s) \
469 ((s)->filename = ffelex_token_where_filename (ffesta_tokens[0]), \
470 (s)->filelinenum = ffelex_token_where_filelinenum (ffesta_tokens[0]))
471 #define ffestd_check_simple_() \
472 assert(ffestd_statelet_ == FFESTD_stateletSIMPLE_)
473 #define ffestd_check_start_() \
474 assert(ffestd_statelet_ == FFESTD_stateletSIMPLE_); \
475 ffestd_statelet_ = FFESTD_stateletATTRIB_
476 #define ffestd_check_attrib_() \
477 assert(ffestd_statelet_ == FFESTD_stateletATTRIB_)
478 #define ffestd_check_item_() \
479 assert(ffestd_statelet_ == FFESTD_stateletATTRIB_ \
480 || ffestd_statelet_ == FFESTD_stateletITEM_); \
481 ffestd_statelet_ = FFESTD_stateletITEM_
482 #define ffestd_check_item_startvals_() \
483 assert(ffestd_statelet_ == FFESTD_stateletATTRIB_ \
484 || ffestd_statelet_ == FFESTD_stateletITEM_); \
485 ffestd_statelet_ = FFESTD_stateletITEMVALS_
486 #define ffestd_check_item_value_() \
487 assert(ffestd_statelet_ == FFESTD_stateletITEMVALS_)
488 #define ffestd_check_item_endvals_() \
489 assert(ffestd_statelet_ == FFESTD_stateletITEMVALS_); \
490 ffestd_statelet_ = FFESTD_stateletITEM_
491 #define ffestd_check_finish_() \
492 assert(ffestd_statelet_ == FFESTD_stateletATTRIB_ \
493 || ffestd_statelet_ == FFESTD_stateletITEM_); \
494 ffestd_statelet_ = FFESTD_stateletSIMPLE_
495
496 #if FFESTD_COPY_EASY_
497 #define ffestd_subr_copy_accept_() (ffestpAcceptStmt *) \
498 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_acceptix)
499 #define ffestd_subr_copy_beru_() (ffestpBeruStmt *) \
500 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_beruix)
501 #define ffestd_subr_copy_close_() (ffestpCloseStmt *) \
502 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_closeix)
503 #define ffestd_subr_copy_delete_() (ffestpDeleteStmt *) \
504 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_deleteix)
505 #define ffestd_subr_copy_find_() (ffestpFindStmt *) \
506 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_findix)
507 #define ffestd_subr_copy_inquire_() (ffestpInquireStmt *) \
508 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_inquireix)
509 #define ffestd_subr_copy_open_() (ffestpOpenStmt *) \
510 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_openix)
511 #define ffestd_subr_copy_print_() (ffestpPrintStmt *) \
512 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_printix)
513 #define ffestd_subr_copy_read_() (ffestpReadStmt *) \
514 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_readix)
515 #define ffestd_subr_copy_rewrite_() (ffestpRewriteStmt *) \
516 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_rewriteix)
517 #define ffestd_subr_copy_type_() (ffestpTypeStmt *) \
518 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_typeix)
519 #define ffestd_subr_copy_vxtcode_() (ffestpVxtcodeStmt *) \
520 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_vxtcodeix)
521 #define ffestd_subr_copy_write_() (ffestpWriteStmt *) \
522 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_writeix)
523 #endif
524 \f
525 /* ffestd_stmt_append_ -- Append statement to end of stmt list
526
527 ffestd_stmt_append_(ffestd_stmt_new_(FFESTD_stmtidR737A_)); */
528
529 static void
530 ffestd_stmt_append_ (ffestdStmt_ stmt)
531 {
532 stmt->next = (ffestdStmt_) &ffestd_stmt_list_.first;
533 stmt->previous = ffestd_stmt_list_.last;
534 stmt->next->previous = stmt;
535 stmt->previous->next = stmt;
536 }
537
538 /* ffestd_stmt_new_ -- Make new statement with given id
539
540 ffestdStmt_ stmt;
541 stmt = ffestd_stmt_new_(FFESTD_stmtidR737A_); */
542
543 static ffestdStmt_
544 ffestd_stmt_new_ (ffestdStmtId_ id)
545 {
546 ffestdStmt_ stmt;
547
548 stmt = malloc_new_kp (ffe_pool_any_unit (), "ffestdStmt_", sizeof (*stmt));
549 stmt->id = id;
550 return stmt;
551 }
552
553 /* ffestd_stmt_pass_ -- Pass all statements on list to ffeste
554
555 ffestd_stmt_pass_(); */
556
557 static void
558 ffestd_stmt_pass_ (void)
559 {
560 ffestdStmt_ stmt;
561 ffestdExprItem_ expr; /* For traversing lists. */
562 bool okay = (TREE_CODE (current_function_decl) != ERROR_MARK);
563
564 if ((ffestd_2pass_entrypoints_ != 0) && okay)
565 {
566 tree which = ffecom_which_entrypoint_decl ();
567 tree value;
568 tree label;
569 int pushok;
570 int ents = ffestd_2pass_entrypoints_;
571 tree duplicate;
572
573 expand_start_case (0, which, TREE_TYPE (which), "entrypoint dispatch");
574
575 stmt = ffestd_stmt_list_.first;
576 do
577 {
578 while (stmt->id != FFESTD_stmtidR1226_)
579 stmt = stmt->next;
580
581 if (stmt->u.R1226.entry != NULL)
582 {
583 value = build_int_2 (stmt->u.R1226.entrynum, 0);
584 /* Yes, we really want to build a null LABEL_DECL here and not
585 put it on any list. That's what pushcase wants, so that's
586 what it gets! */
587 label = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
588
589 pushok = pushcase (value, convert, label, &duplicate);
590 assert (pushok == 0);
591
592 label = ffecom_temp_label ();
593 TREE_USED (label) = 1;
594 expand_goto (label);
595
596 ffesymbol_hook (stmt->u.R1226.entry).length_tree = label;
597 }
598 stmt = stmt->next;
599 }
600 while (--ents != 0);
601
602 expand_end_case (which);
603 }
604
605 for (stmt = ffestd_stmt_list_.first;
606 stmt != (ffestdStmt_) &ffestd_stmt_list_.first;
607 stmt = stmt->next)
608 {
609 switch (stmt->id)
610 {
611 case FFESTD_stmtidENDDOLOOP_:
612 ffestd_subr_line_restore_ (stmt);
613 if (okay)
614 ffeste_do (stmt->u.enddoloop.block);
615 ffestw_kill (stmt->u.enddoloop.block);
616 break;
617
618 case FFESTD_stmtidENDLOGIF_:
619 ffestd_subr_line_restore_ (stmt);
620 if (okay)
621 ffeste_end_R807 ();
622 break;
623
624 case FFESTD_stmtidEXECLABEL_:
625 if (okay)
626 ffeste_labeldef_branch (stmt->u.execlabel.label);
627 break;
628
629 case FFESTD_stmtidFORMATLABEL_:
630 if (okay)
631 ffeste_labeldef_format (stmt->u.formatlabel.label);
632 break;
633
634 case FFESTD_stmtidR737A_:
635 ffestd_subr_line_restore_ (stmt);
636 if (okay)
637 ffeste_R737A (stmt->u.R737A.dest, stmt->u.R737A.source);
638 malloc_pool_kill (stmt->u.R737A.pool);
639 break;
640
641 case FFESTD_stmtidR803_:
642 ffestd_subr_line_restore_ (stmt);
643 if (okay)
644 ffeste_R803 (stmt->u.R803.block, stmt->u.R803.expr);
645 malloc_pool_kill (stmt->u.R803.pool);
646 break;
647
648 case FFESTD_stmtidR804_:
649 ffestd_subr_line_restore_ (stmt);
650 if (okay)
651 ffeste_R804 (stmt->u.R803.block, stmt->u.R804.expr);
652 malloc_pool_kill (stmt->u.R804.pool);
653 break;
654
655 case FFESTD_stmtidR805_:
656 ffestd_subr_line_restore_ (stmt);
657 if (okay)
658 ffeste_R805 (stmt->u.R803.block);
659 break;
660
661 case FFESTD_stmtidR806_:
662 ffestd_subr_line_restore_ (stmt);
663 if (okay)
664 ffeste_R806 (stmt->u.R806.block);
665 ffestw_kill (stmt->u.R806.block);
666 break;
667
668 case FFESTD_stmtidR807_:
669 ffestd_subr_line_restore_ (stmt);
670 if (okay)
671 ffeste_R807 (stmt->u.R807.expr);
672 malloc_pool_kill (stmt->u.R807.pool);
673 break;
674
675 case FFESTD_stmtidR809_:
676 ffestd_subr_line_restore_ (stmt);
677 if (okay)
678 ffeste_R809 (stmt->u.R809.block, stmt->u.R809.expr);
679 malloc_pool_kill (stmt->u.R809.pool);
680 break;
681
682 case FFESTD_stmtidR810_:
683 ffestd_subr_line_restore_ (stmt);
684 if (okay)
685 ffeste_R810 (stmt->u.R810.block, stmt->u.R810.casenum);
686 malloc_pool_kill (stmt->u.R810.pool);
687 break;
688
689 case FFESTD_stmtidR811_:
690 ffestd_subr_line_restore_ (stmt);
691 if (okay)
692 ffeste_R811 (stmt->u.R811.block);
693 malloc_pool_kill (ffestw_select (stmt->u.R811.block)->pool);
694 ffestw_kill (stmt->u.R811.block);
695 break;
696
697 case FFESTD_stmtidR819A_:
698 ffestd_subr_line_restore_ (stmt);
699 if (okay)
700 ffeste_R819A (stmt->u.R819A.block, stmt->u.R819A.label,
701 stmt->u.R819A.var,
702 stmt->u.R819A.start, stmt->u.R819A.start_token,
703 stmt->u.R819A.end, stmt->u.R819A.end_token,
704 stmt->u.R819A.incr, stmt->u.R819A.incr_token);
705 ffelex_token_kill (stmt->u.R819A.start_token);
706 ffelex_token_kill (stmt->u.R819A.end_token);
707 if (stmt->u.R819A.incr_token != NULL)
708 ffelex_token_kill (stmt->u.R819A.incr_token);
709 malloc_pool_kill (stmt->u.R819A.pool);
710 break;
711
712 case FFESTD_stmtidR819B_:
713 ffestd_subr_line_restore_ (stmt);
714 if (okay)
715 ffeste_R819B (stmt->u.R819B.block, stmt->u.R819B.label,
716 stmt->u.R819B.expr);
717 malloc_pool_kill (stmt->u.R819B.pool);
718 break;
719
720 case FFESTD_stmtidR825_:
721 ffestd_subr_line_restore_ (stmt);
722 if (okay)
723 ffeste_R825 ();
724 break;
725
726 case FFESTD_stmtidR834_:
727 ffestd_subr_line_restore_ (stmt);
728 if (okay)
729 ffeste_R834 (stmt->u.R834.block);
730 break;
731
732 case FFESTD_stmtidR835_:
733 ffestd_subr_line_restore_ (stmt);
734 if (okay)
735 ffeste_R835 (stmt->u.R835.block);
736 break;
737
738 case FFESTD_stmtidR836_:
739 ffestd_subr_line_restore_ (stmt);
740 if (okay)
741 ffeste_R836 (stmt->u.R836.label);
742 break;
743
744 case FFESTD_stmtidR837_:
745 ffestd_subr_line_restore_ (stmt);
746 if (okay)
747 ffeste_R837 (stmt->u.R837.labels, stmt->u.R837.count,
748 stmt->u.R837.expr);
749 malloc_pool_kill (stmt->u.R837.pool);
750 break;
751
752 case FFESTD_stmtidR838_:
753 ffestd_subr_line_restore_ (stmt);
754 if (okay)
755 ffeste_R838 (stmt->u.R838.label, stmt->u.R838.target);
756 malloc_pool_kill (stmt->u.R838.pool);
757 break;
758
759 case FFESTD_stmtidR839_:
760 ffestd_subr_line_restore_ (stmt);
761 if (okay)
762 ffeste_R839 (stmt->u.R839.target);
763 malloc_pool_kill (stmt->u.R839.pool);
764 break;
765
766 case FFESTD_stmtidR840_:
767 ffestd_subr_line_restore_ (stmt);
768 if (okay)
769 ffeste_R840 (stmt->u.R840.expr, stmt->u.R840.neg, stmt->u.R840.zero,
770 stmt->u.R840.pos);
771 malloc_pool_kill (stmt->u.R840.pool);
772 break;
773
774 case FFESTD_stmtidR841_:
775 ffestd_subr_line_restore_ (stmt);
776 if (okay)
777 ffeste_R841 ();
778 break;
779
780 case FFESTD_stmtidR842_:
781 ffestd_subr_line_restore_ (stmt);
782 if (okay)
783 ffeste_R842 (stmt->u.R842.expr);
784 if (stmt->u.R842.pool != NULL)
785 malloc_pool_kill (stmt->u.R842.pool);
786 break;
787
788 case FFESTD_stmtidR843_:
789 ffestd_subr_line_restore_ (stmt);
790 if (okay)
791 ffeste_R843 (stmt->u.R843.expr);
792 malloc_pool_kill (stmt->u.R843.pool);
793 break;
794
795 case FFESTD_stmtidR904_:
796 ffestd_subr_line_restore_ (stmt);
797 if (okay)
798 ffeste_R904 (stmt->u.R904.params);
799 malloc_pool_kill (stmt->u.R904.pool);
800 break;
801
802 case FFESTD_stmtidR907_:
803 ffestd_subr_line_restore_ (stmt);
804 if (okay)
805 ffeste_R907 (stmt->u.R907.params);
806 malloc_pool_kill (stmt->u.R907.pool);
807 break;
808
809 case FFESTD_stmtidR909_:
810 ffestd_subr_line_restore_ (stmt);
811 if (okay)
812 ffeste_R909_start (stmt->u.R909.params, stmt->u.R909.only_format,
813 stmt->u.R909.unit, stmt->u.R909.format,
814 stmt->u.R909.rec, stmt->u.R909.key);
815 for (expr = stmt->u.R909.list; expr != NULL; expr = expr->next)
816 {
817 if (okay)
818 ffeste_R909_item (expr->expr, expr->token);
819 ffelex_token_kill (expr->token);
820 }
821 if (okay)
822 ffeste_R909_finish ();
823 malloc_pool_kill (stmt->u.R909.pool);
824 break;
825
826 case FFESTD_stmtidR910_:
827 ffestd_subr_line_restore_ (stmt);
828 if (okay)
829 ffeste_R910_start (stmt->u.R910.params, stmt->u.R910.unit,
830 stmt->u.R910.format, stmt->u.R910.rec);
831 for (expr = stmt->u.R910.list; expr != NULL; expr = expr->next)
832 {
833 if (okay)
834 ffeste_R910_item (expr->expr, expr->token);
835 ffelex_token_kill (expr->token);
836 }
837 if (okay)
838 ffeste_R910_finish ();
839 malloc_pool_kill (stmt->u.R910.pool);
840 break;
841
842 case FFESTD_stmtidR911_:
843 ffestd_subr_line_restore_ (stmt);
844 if (okay)
845 ffeste_R911_start (stmt->u.R911.params, stmt->u.R911.format);
846 for (expr = stmt->u.R911.list; expr != NULL; expr = expr->next)
847 {
848 if (okay)
849 ffeste_R911_item (expr->expr, expr->token);
850 ffelex_token_kill (expr->token);
851 }
852 if (okay)
853 ffeste_R911_finish ();
854 malloc_pool_kill (stmt->u.R911.pool);
855 break;
856
857 case FFESTD_stmtidR919_:
858 ffestd_subr_line_restore_ (stmt);
859 if (okay)
860 ffeste_R919 (stmt->u.R919.params);
861 malloc_pool_kill (stmt->u.R919.pool);
862 break;
863
864 case FFESTD_stmtidR920_:
865 ffestd_subr_line_restore_ (stmt);
866 if (okay)
867 ffeste_R920 (stmt->u.R920.params);
868 malloc_pool_kill (stmt->u.R920.pool);
869 break;
870
871 case FFESTD_stmtidR921_:
872 ffestd_subr_line_restore_ (stmt);
873 if (okay)
874 ffeste_R921 (stmt->u.R921.params);
875 malloc_pool_kill (stmt->u.R921.pool);
876 break;
877
878 case FFESTD_stmtidR923A_:
879 ffestd_subr_line_restore_ (stmt);
880 if (okay)
881 ffeste_R923A (stmt->u.R923A.params, stmt->u.R923A.by_file);
882 malloc_pool_kill (stmt->u.R923A.pool);
883 break;
884
885 case FFESTD_stmtidR923B_:
886 ffestd_subr_line_restore_ (stmt);
887 if (okay)
888 ffeste_R923B_start (stmt->u.R923B.params);
889 for (expr = stmt->u.R923B.list; expr != NULL; expr = expr->next)
890 {
891 if (okay)
892 ffeste_R923B_item (expr->expr);
893 }
894 if (okay)
895 ffeste_R923B_finish ();
896 malloc_pool_kill (stmt->u.R923B.pool);
897 break;
898
899 case FFESTD_stmtidR1001_:
900 if (okay)
901 ffeste_R1001 (&stmt->u.R1001.str);
902 ffests_kill (&stmt->u.R1001.str);
903 break;
904
905 case FFESTD_stmtidR1103_:
906 if (okay)
907 ffeste_R1103 ();
908 break;
909
910 case FFESTD_stmtidR1112_:
911 if (okay)
912 ffeste_R1112 ();
913 break;
914
915 case FFESTD_stmtidR1212_:
916 ffestd_subr_line_restore_ (stmt);
917 if (okay)
918 ffeste_R1212 (stmt->u.R1212.expr);
919 malloc_pool_kill (stmt->u.R1212.pool);
920 break;
921
922 case FFESTD_stmtidR1221_:
923 if (okay)
924 ffeste_R1221 ();
925 break;
926
927 case FFESTD_stmtidR1225_:
928 if (okay)
929 ffeste_R1225 ();
930 break;
931
932 case FFESTD_stmtidR1226_:
933 ffestd_subr_line_restore_ (stmt);
934 if (stmt->u.R1226.entry != NULL)
935 {
936 if (okay)
937 ffeste_R1226 (stmt->u.R1226.entry);
938 }
939 break;
940
941 case FFESTD_stmtidR1227_:
942 ffestd_subr_line_restore_ (stmt);
943 if (okay)
944 ffeste_R1227 (stmt->u.R1227.block, stmt->u.R1227.expr);
945 malloc_pool_kill (stmt->u.R1227.pool);
946 break;
947
948 case FFESTD_stmtidV020_:
949 ffestd_subr_line_restore_ (stmt);
950 if (okay)
951 ffeste_V020_start (stmt->u.V020.params, stmt->u.V020.format);
952 for (expr = stmt->u.V020.list; expr != NULL; expr = expr->next)
953 {
954 if (okay)
955 ffeste_V020_item (expr->expr);
956 }
957 if (okay)
958 ffeste_V020_finish ();
959 malloc_pool_kill (stmt->u.V020.pool);
960 break;
961
962 default:
963 assert ("bad stmt->id" == NULL);
964 break;
965 }
966 }
967 }
968
969 /* ffestd_subr_copy_easy_ -- Copy I/O statement data structure
970
971 ffestd_subr_copy_easy_();
972
973 Copies all data except tokens in the I/O data structure into a new
974 structure that lasts as long as the output pool for the current
975 statement. Assumes that they are
976 overlaid with each other (union) in stp.h and the typing
977 and structure references assume (though not necessarily dangerous if
978 FALSE) that INQUIRE has the most file elements. */
979
980 #if FFESTD_COPY_EASY_
981 static ffestpInquireStmt *
982 ffestd_subr_copy_easy_ (ffestpInquireIx max)
983 {
984 ffestpInquireStmt *stmt;
985 ffestpInquireIx ix;
986
987 stmt = malloc_new_kp (ffesta_output_pool, "FFESTD easy",
988 sizeof (ffestpFile) * max);
989
990 for (ix = 0; ix < max; ++ix)
991 {
992 if ((stmt->inquire_spec[ix].kw_or_val_present
993 = ffestp_file.inquire.inquire_spec[ix].kw_or_val_present)
994 && (stmt->inquire_spec[ix].value_present
995 = ffestp_file.inquire.inquire_spec[ix].value_present))
996 {
997 if ((stmt->inquire_spec[ix].value_is_label
998 = ffestp_file.inquire.inquire_spec[ix].value_is_label))
999 stmt->inquire_spec[ix].u.label
1000 = ffestp_file.inquire.inquire_spec[ix].u.label;
1001 else
1002 stmt->inquire_spec[ix].u.expr
1003 = ffestp_file.inquire.inquire_spec[ix].u.expr;
1004 }
1005 }
1006
1007 return stmt;
1008 }
1009
1010 #endif
1011 /* ffestd_subr_labels_ -- Handle any undefined labels
1012
1013 ffestd_subr_labels_(FALSE);
1014
1015 For every undefined label, generate an error message and either define
1016 label as a FORMAT() statement (for FORMAT labels) or as a STOP statement
1017 (for all other labels). */
1018
1019 static void
1020 ffestd_subr_labels_ (bool unexpected)
1021 {
1022 ffelab l;
1023 ffelabHandle h;
1024 ffelabNumber undef;
1025 ffesttFormatList f;
1026
1027 undef = ffelab_number () - ffestv_num_label_defines_;
1028
1029 for (h = ffelab_handle_first (); h != NULL; h = ffelab_handle_next (h))
1030 {
1031 l = ffelab_handle_target (h);
1032 if (ffewhere_line_is_unknown (ffelab_definition_line (l)))
1033 { /* Undefined label. */
1034 assert (!unexpected);
1035 assert (undef > 0);
1036 undef--;
1037 ffebad_start (FFEBAD_UNDEF_LABEL);
1038 if (ffelab_type (l) == FFELAB_typeLOOPEND)
1039 ffebad_here (0, ffelab_doref_line (l), ffelab_doref_column (l));
1040 else if (ffelab_type (l) != FFELAB_typeANY)
1041 ffebad_here (0, ffelab_firstref_line (l), ffelab_firstref_column (l));
1042 else if (!ffewhere_line_is_unknown (ffelab_firstref_line (l)))
1043 ffebad_here (0, ffelab_firstref_line (l), ffelab_firstref_column (l));
1044 else if (!ffewhere_line_is_unknown (ffelab_doref_line (l)))
1045 ffebad_here (0, ffelab_doref_line (l), ffelab_doref_column (l));
1046 else
1047 ffebad_here (0, ffelab_definition_line (l), ffelab_definition_column (l));
1048 ffebad_finish ();
1049
1050 switch (ffelab_type (l))
1051 {
1052 case FFELAB_typeFORMAT:
1053 ffelab_set_definition_line (l,
1054 ffewhere_line_use (ffelab_firstref_line (l)));
1055 ffelab_set_definition_column (l,
1056 ffewhere_column_use (ffelab_firstref_column (l)));
1057 ffestv_num_label_defines_++;
1058 f = ffestt_formatlist_create (NULL, NULL);
1059 ffestd_labeldef_format (l);
1060 ffestd_R1001 (f);
1061 ffestt_formatlist_kill (f);
1062 break;
1063
1064 case FFELAB_typeASSIGNABLE:
1065 ffelab_set_definition_line (l,
1066 ffewhere_line_use (ffelab_firstref_line (l)));
1067 ffelab_set_definition_column (l,
1068 ffewhere_column_use (ffelab_firstref_column (l)));
1069 ffestv_num_label_defines_++;
1070 ffelab_set_type (l, FFELAB_typeNOTLOOP);
1071 ffelab_set_blocknum (l, ffestw_blocknum (ffestw_stack_top ()));
1072 ffestd_labeldef_notloop (l);
1073 ffestd_R842 (NULL);
1074 break;
1075
1076 case FFELAB_typeNOTLOOP:
1077 ffelab_set_definition_line (l,
1078 ffewhere_line_use (ffelab_firstref_line (l)));
1079 ffelab_set_definition_column (l,
1080 ffewhere_column_use (ffelab_firstref_column (l)));
1081 ffestv_num_label_defines_++;
1082 ffelab_set_blocknum (l, ffestw_blocknum (ffestw_stack_top ()));
1083 ffestd_labeldef_notloop (l);
1084 ffestd_R842 (NULL);
1085 break;
1086
1087 default:
1088 assert ("bad label type" == NULL);
1089 /* Fall through. */
1090 case FFELAB_typeUNKNOWN:
1091 case FFELAB_typeANY:
1092 break;
1093 }
1094 }
1095 }
1096 ffelab_handle_done (h);
1097 assert (undef == 0);
1098 }
1099
1100 /* ffestd_subr_vxt_ -- Report error about lack of full VXT support
1101
1102 ffestd_subr_vxt_(); */
1103
1104 static void
1105 ffestd_subr_vxt_ (void)
1106 {
1107 ffebad_start (FFEBAD_VXT_UNSUPPORTED);
1108 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
1109 ffelex_token_where_column (ffesta_tokens[0]));
1110 ffebad_finish ();
1111 }
1112
1113 /* ffestd_begin_uses -- Start a bunch of USE statements
1114
1115 ffestd_begin_uses();
1116
1117 Invoked before handling the first USE statement in a block of one or
1118 more USE statements. _end_uses_(bool ok) is invoked before handling
1119 the first statement after the block (there are no BEGIN USE and END USE
1120 statements, but the semantics of USE statements effectively requires
1121 handling them as a single block rather than one statement at a time). */
1122
1123 void
1124 ffestd_begin_uses (void)
1125 {
1126 }
1127
1128 /* ffestd_do -- End of statement following DO-term-stmt etc
1129
1130 ffestd_do(TRUE);
1131
1132 Also invoked by _labeldef_branch_finish_ (or, in cases
1133 of errors, other _labeldef_ functions) when the label definition is
1134 for a DO-target (LOOPEND) label, once per matching/outstanding DO
1135 block on the stack. These cases invoke this function with ok==TRUE, so
1136 only forced stack popping (via ffestd_eof_()) invokes it with ok==FALSE. */
1137
1138 void
1139 ffestd_do (bool ok UNUSED)
1140 {
1141 ffestdStmt_ stmt;
1142
1143 stmt = ffestd_stmt_new_ (FFESTD_stmtidENDDOLOOP_);
1144 ffestd_stmt_append_ (stmt);
1145 ffestd_subr_line_save_ (stmt);
1146 stmt->u.enddoloop.block = ffestw_stack_top ();
1147
1148 --ffestd_block_level_;
1149 assert (ffestd_block_level_ >= 0);
1150 }
1151
1152 /* ffestd_end_R807 -- End of statement following logical IF
1153
1154 ffestd_end_R807(TRUE);
1155
1156 Applies ONLY to logical IF, not to IF-THEN. For example, does not
1157 ffelex_token_kill the construct name for an IF-THEN block (the name
1158 field is invalid for logical IF). ok==TRUE iff statement following
1159 logical IF (substatement) is valid; else, statement is invalid or
1160 stack forcibly popped due to ffestd_eof_(). */
1161
1162 void
1163 ffestd_end_R807 (bool ok UNUSED)
1164 {
1165 ffestdStmt_ stmt;
1166
1167 stmt = ffestd_stmt_new_ (FFESTD_stmtidENDLOGIF_);
1168 ffestd_stmt_append_ (stmt);
1169 ffestd_subr_line_save_ (stmt);
1170
1171 --ffestd_block_level_;
1172 assert (ffestd_block_level_ >= 0);
1173 }
1174
1175 /* ffestd_exec_begin -- Executable statements can start coming in now
1176
1177 ffestd_exec_begin(); */
1178
1179 void
1180 ffestd_exec_begin (void)
1181 {
1182 ffecom_exec_transition ();
1183
1184 if (ffestd_2pass_entrypoints_ != 0)
1185 { /* Process pending ENTRY statements now that
1186 info filled in. */
1187 ffestdStmt_ stmt;
1188 int ents = ffestd_2pass_entrypoints_;
1189
1190 stmt = ffestd_stmt_list_.first;
1191 do
1192 {
1193 while (stmt->id != FFESTD_stmtidR1226_)
1194 stmt = stmt->next;
1195
1196 if (!ffecom_2pass_advise_entrypoint (stmt->u.R1226.entry))
1197 {
1198 stmt->u.R1226.entry = NULL;
1199 --ffestd_2pass_entrypoints_;
1200 }
1201 stmt = stmt->next;
1202 }
1203 while (--ents != 0);
1204 }
1205 }
1206
1207 /* ffestd_exec_end -- Executable statements can no longer come in now
1208
1209 ffestd_exec_end(); */
1210
1211 void
1212 ffestd_exec_end (void)
1213 {
1214 location_t old_loc = input_location;
1215
1216 ffecom_end_transition ();
1217
1218 ffestd_stmt_pass_ ();
1219
1220 ffecom_finish_progunit ();
1221
1222 if (ffestd_2pass_entrypoints_ != 0)
1223 {
1224 int ents = ffestd_2pass_entrypoints_;
1225 ffestdStmt_ stmt = ffestd_stmt_list_.first;
1226
1227 do
1228 {
1229 while (stmt->id != FFESTD_stmtidR1226_)
1230 stmt = stmt->next;
1231
1232 if (stmt->u.R1226.entry != NULL)
1233 {
1234 ffestd_subr_line_restore_ (stmt);
1235 ffecom_2pass_do_entrypoint (stmt->u.R1226.entry);
1236 }
1237 stmt = stmt->next;
1238 }
1239 while (--ents != 0);
1240 }
1241
1242 ffestd_stmt_list_.first = NULL;
1243 ffestd_stmt_list_.last = NULL;
1244 ffestd_2pass_entrypoints_ = 0;
1245
1246 input_location = old_loc;
1247 }
1248
1249 /* ffestd_init_3 -- Initialize for any program unit
1250
1251 ffestd_init_3(); */
1252
1253 void
1254 ffestd_init_3 (void)
1255 {
1256 ffestd_stmt_list_.first = (ffestdStmt_) &ffestd_stmt_list_.first;
1257 ffestd_stmt_list_.last = (ffestdStmt_) &ffestd_stmt_list_.first;
1258 }
1259
1260 /* Generate "code" for "any" label def. */
1261
1262 void
1263 ffestd_labeldef_any (ffelab label UNUSED)
1264 {
1265 }
1266
1267 /* ffestd_labeldef_branch -- Generate "code" for branch label def
1268
1269 ffestd_labeldef_branch(label); */
1270
1271 void
1272 ffestd_labeldef_branch (ffelab label)
1273 {
1274 ffestdStmt_ stmt;
1275
1276 stmt = ffestd_stmt_new_ (FFESTD_stmtidEXECLABEL_);
1277 ffestd_stmt_append_ (stmt);
1278 stmt->u.execlabel.label = label;
1279
1280 ffestd_is_reachable_ = TRUE;
1281 }
1282
1283 /* ffestd_labeldef_format -- Generate "code" for FORMAT label def
1284
1285 ffestd_labeldef_format(label); */
1286
1287 void
1288 ffestd_labeldef_format (ffelab label)
1289 {
1290 ffestdStmt_ stmt;
1291
1292 ffestd_label_formatdef_ = label;
1293
1294 stmt = ffestd_stmt_new_ (FFESTD_stmtidFORMATLABEL_);
1295 ffestd_stmt_append_ (stmt);
1296 stmt->u.formatlabel.label = label;
1297 }
1298
1299 /* ffestd_labeldef_useless -- Generate "code" for useless label def
1300
1301 ffestd_labeldef_useless(label); */
1302
1303 void
1304 ffestd_labeldef_useless (ffelab label UNUSED)
1305 {
1306 }
1307
1308 /* ffestd_R522 -- SAVE statement with no list
1309
1310 ffestd_R522();
1311
1312 Verify that SAVE is valid here, and flag everything as SAVEd. */
1313
1314 void
1315 ffestd_R522 (void)
1316 {
1317 ffestd_check_simple_ ();
1318 }
1319
1320 /* ffestd_R522start -- SAVE statement list begin
1321
1322 ffestd_R522start();
1323
1324 Verify that SAVE is valid here, and begin accepting items in the list. */
1325
1326 void
1327 ffestd_R522start (void)
1328 {
1329 ffestd_check_start_ ();
1330 }
1331
1332 /* ffestd_R522item_object -- SAVE statement for object-name
1333
1334 ffestd_R522item_object(name_token);
1335
1336 Make sure name_token identifies a valid object to be SAVEd. */
1337
1338 void
1339 ffestd_R522item_object (ffelexToken name UNUSED)
1340 {
1341 ffestd_check_item_ ();
1342 }
1343
1344 /* ffestd_R522item_cblock -- SAVE statement for common-block-name
1345
1346 ffestd_R522item_cblock(name_token);
1347
1348 Make sure name_token identifies a valid common block to be SAVEd. */
1349
1350 void
1351 ffestd_R522item_cblock (ffelexToken name UNUSED)
1352 {
1353 ffestd_check_item_ ();
1354 }
1355
1356 /* ffestd_R522finish -- SAVE statement list complete
1357
1358 ffestd_R522finish();
1359
1360 Just wrap up any local activities. */
1361
1362 void
1363 ffestd_R522finish (void)
1364 {
1365 ffestd_check_finish_ ();
1366 }
1367
1368 /* ffestd_R524_start -- DIMENSION statement list begin
1369
1370 ffestd_R524_start(bool virtual);
1371
1372 Verify that DIMENSION is valid here, and begin accepting items in the list. */
1373
1374 void
1375 ffestd_R524_start (bool virtual UNUSED)
1376 {
1377 ffestd_check_start_ ();
1378 }
1379
1380 /* ffestd_R524_item -- DIMENSION statement for object-name
1381
1382 ffestd_R524_item(name_token,dim_list);
1383
1384 Make sure name_token identifies a valid object to be DIMENSIONd. */
1385
1386 void
1387 ffestd_R524_item (ffelexToken name UNUSED, ffesttDimList dims UNUSED)
1388 {
1389 ffestd_check_item_ ();
1390 }
1391
1392 /* ffestd_R524_finish -- DIMENSION statement list complete
1393
1394 ffestd_R524_finish();
1395
1396 Just wrap up any local activities. */
1397
1398 void
1399 ffestd_R524_finish (void)
1400 {
1401 ffestd_check_finish_ ();
1402 }
1403
1404 /* ffestd_R537_start -- PARAMETER statement list begin
1405
1406 ffestd_R537_start();
1407
1408 Verify that PARAMETER is valid here, and begin accepting items in the list. */
1409
1410 void
1411 ffestd_R537_start (void)
1412 {
1413 ffestd_check_start_ ();
1414 }
1415
1416 /* ffestd_R537_item -- PARAMETER statement assignment
1417
1418 ffestd_R537_item(dest,dest_token,source,source_token);
1419
1420 Make sure the source is a valid source for the destination; make the
1421 assignment. */
1422
1423 void
1424 ffestd_R537_item (ffebld dest UNUSED, ffebld source UNUSED)
1425 {
1426 ffestd_check_item_ ();
1427 }
1428
1429 /* ffestd_R537_finish -- PARAMETER statement list complete
1430
1431 ffestd_R537_finish();
1432
1433 Just wrap up any local activities. */
1434
1435 void
1436 ffestd_R537_finish (void)
1437 {
1438 ffestd_check_finish_ ();
1439 }
1440
1441 /* ffestd_R539 -- IMPLICIT NONE statement
1442
1443 ffestd_R539();
1444
1445 Verify that the IMPLICIT NONE statement is ok here and implement. */
1446
1447 void
1448 ffestd_R539 (void)
1449 {
1450 ffestd_check_simple_ ();
1451 }
1452
1453 /* ffestd_R539start -- IMPLICIT statement
1454
1455 ffestd_R539start();
1456
1457 Verify that the IMPLICIT statement is ok here and implement. */
1458
1459 void
1460 ffestd_R539start (void)
1461 {
1462 ffestd_check_start_ ();
1463 }
1464
1465 /* ffestd_R539item -- IMPLICIT statement specification (R540)
1466
1467 ffestd_R539item(...);
1468
1469 Verify that the type and letter list are all ok and implement. */
1470
1471 void
1472 ffestd_R539item (ffestpType type UNUSED, ffebld kind UNUSED,
1473 ffelexToken kindt UNUSED, ffebld len UNUSED,
1474 ffelexToken lent UNUSED, ffesttImpList letters UNUSED)
1475 {
1476 ffestd_check_item_ ();
1477 }
1478
1479 /* ffestd_R539finish -- IMPLICIT statement
1480
1481 ffestd_R539finish();
1482
1483 Finish up any local activities. */
1484
1485 void
1486 ffestd_R539finish (void)
1487 {
1488 ffestd_check_finish_ ();
1489 }
1490
1491 /* ffestd_R542_start -- NAMELIST statement list begin
1492
1493 ffestd_R542_start();
1494
1495 Verify that NAMELIST is valid here, and begin accepting items in the list. */
1496
1497 void
1498 ffestd_R542_start (void)
1499 {
1500 ffestd_check_start_ ();
1501 }
1502
1503 /* ffestd_R542_item_nlist -- NAMELIST statement for group-name
1504
1505 ffestd_R542_item_nlist(groupname_token);
1506
1507 Make sure name_token identifies a valid object to be NAMELISTd. */
1508
1509 void
1510 ffestd_R542_item_nlist (ffelexToken name UNUSED)
1511 {
1512 ffestd_check_item_ ();
1513 }
1514
1515 /* ffestd_R542_item_nitem -- NAMELIST statement for variable-name
1516
1517 ffestd_R542_item_nitem(name_token);
1518
1519 Make sure name_token identifies a valid object to be NAMELISTd. */
1520
1521 void
1522 ffestd_R542_item_nitem (ffelexToken name UNUSED)
1523 {
1524 ffestd_check_item_ ();
1525 }
1526
1527 /* ffestd_R542_finish -- NAMELIST statement list complete
1528
1529 ffestd_R542_finish();
1530
1531 Just wrap up any local activities. */
1532
1533 void
1534 ffestd_R542_finish (void)
1535 {
1536 ffestd_check_finish_ ();
1537 }
1538
1539 /* ffestd_R547_start -- COMMON statement list begin
1540
1541 ffestd_R547_start();
1542
1543 Verify that COMMON is valid here, and begin accepting items in the list. */
1544
1545 void
1546 ffestd_R547_start (void)
1547 {
1548 ffestd_check_start_ ();
1549 }
1550
1551 /* ffestd_R547_item_object -- COMMON statement for object-name
1552
1553 ffestd_R547_item_object(name_token,dim_list);
1554
1555 Make sure name_token identifies a valid object to be COMMONd. */
1556
1557 void
1558 ffestd_R547_item_object (ffelexToken name UNUSED,
1559 ffesttDimList dims UNUSED)
1560 {
1561 ffestd_check_item_ ();
1562 }
1563
1564 /* ffestd_R547_item_cblock -- COMMON statement for common-block-name
1565
1566 ffestd_R547_item_cblock(name_token);
1567
1568 Make sure name_token identifies a valid common block to be COMMONd. */
1569
1570 void
1571 ffestd_R547_item_cblock (ffelexToken name UNUSED)
1572 {
1573 ffestd_check_item_ ();
1574 }
1575
1576 /* ffestd_R547_finish -- COMMON statement list complete
1577
1578 ffestd_R547_finish();
1579
1580 Just wrap up any local activities. */
1581
1582 void
1583 ffestd_R547_finish (void)
1584 {
1585 ffestd_check_finish_ ();
1586 }
1587
1588 /* ffestd_R737A -- Assignment statement outside of WHERE
1589
1590 ffestd_R737A(dest_expr,source_expr); */
1591
1592 void
1593 ffestd_R737A (ffebld dest, ffebld source)
1594 {
1595 ffestdStmt_ stmt;
1596
1597 ffestd_check_simple_ ();
1598
1599 stmt = ffestd_stmt_new_ (FFESTD_stmtidR737A_);
1600 ffestd_stmt_append_ (stmt);
1601 ffestd_subr_line_save_ (stmt);
1602 stmt->u.R737A.pool = ffesta_output_pool;
1603 stmt->u.R737A.dest = dest;
1604 stmt->u.R737A.source = source;
1605 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
1606 }
1607
1608
1609 /* Block IF (IF-THEN) statement. */
1610
1611 void
1612 ffestd_R803 (ffelexToken construct_name UNUSED, ffebld expr)
1613 {
1614 ffestdStmt_ stmt;
1615
1616 ffestd_check_simple_ ();
1617
1618 stmt = ffestd_stmt_new_ (FFESTD_stmtidR803_);
1619 ffestd_stmt_append_ (stmt);
1620 ffestd_subr_line_save_ (stmt);
1621 stmt->u.R803.pool = ffesta_output_pool;
1622 stmt->u.R803.block = ffestw_use (ffestw_stack_top ());
1623 stmt->u.R803.expr = expr;
1624 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
1625
1626 ++ffestd_block_level_;
1627 assert (ffestd_block_level_ > 0);
1628 }
1629
1630 /* ELSE IF statement. */
1631
1632 void
1633 ffestd_R804 (ffebld expr, ffelexToken name UNUSED)
1634 {
1635 ffestdStmt_ stmt;
1636
1637 ffestd_check_simple_ ();
1638
1639 stmt = ffestd_stmt_new_ (FFESTD_stmtidR804_);
1640 ffestd_stmt_append_ (stmt);
1641 ffestd_subr_line_save_ (stmt);
1642 stmt->u.R804.pool = ffesta_output_pool;
1643 stmt->u.R804.block = ffestw_use (ffestw_stack_top ());
1644 stmt->u.R804.expr = expr;
1645 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
1646 }
1647
1648 /* ELSE statement. */
1649
1650 void
1651 ffestd_R805 (ffelexToken name UNUSED)
1652 {
1653 ffestdStmt_ stmt;
1654
1655 ffestd_check_simple_ ();
1656
1657 stmt = ffestd_stmt_new_ (FFESTD_stmtidR805_);
1658 ffestd_stmt_append_ (stmt);
1659 ffestd_subr_line_save_ (stmt);
1660 stmt->u.R805.block = ffestw_use (ffestw_stack_top ());
1661 }
1662
1663 /* END IF statement. */
1664
1665 void
1666 ffestd_R806 (bool ok UNUSED)
1667 {
1668 ffestdStmt_ stmt;
1669
1670 stmt = ffestd_stmt_new_ (FFESTD_stmtidR806_);
1671 ffestd_stmt_append_ (stmt);
1672 ffestd_subr_line_save_ (stmt);
1673 stmt->u.R806.block = ffestw_use (ffestw_stack_top ());
1674
1675 --ffestd_block_level_;
1676 assert (ffestd_block_level_ >= 0);
1677 }
1678
1679 /* ffestd_R807 -- Logical IF statement
1680
1681 ffestd_R807(expr,expr_token);
1682
1683 Make sure statement is valid here; implement. */
1684
1685 void
1686 ffestd_R807 (ffebld expr)
1687 {
1688 ffestdStmt_ stmt;
1689
1690 ffestd_check_simple_ ();
1691
1692 stmt = ffestd_stmt_new_ (FFESTD_stmtidR807_);
1693 ffestd_stmt_append_ (stmt);
1694 ffestd_subr_line_save_ (stmt);
1695 stmt->u.R807.pool = ffesta_output_pool;
1696 stmt->u.R807.expr = expr;
1697 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
1698
1699 ++ffestd_block_level_;
1700 assert (ffestd_block_level_ > 0);
1701 }
1702
1703 /* ffestd_R809 -- SELECT CASE statement
1704
1705 ffestd_R809(construct_name,expr,expr_token);
1706
1707 Make sure statement is valid here; implement. */
1708
1709 void
1710 ffestd_R809 (ffelexToken construct_name UNUSED, ffebld expr)
1711 {
1712 ffestdStmt_ stmt;
1713
1714 ffestd_check_simple_ ();
1715
1716 stmt = ffestd_stmt_new_ (FFESTD_stmtidR809_);
1717 ffestd_stmt_append_ (stmt);
1718 ffestd_subr_line_save_ (stmt);
1719 stmt->u.R809.pool = ffesta_output_pool;
1720 stmt->u.R809.block = ffestw_use (ffestw_stack_top ());
1721 stmt->u.R809.expr = expr;
1722 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
1723 malloc_pool_use (ffestw_select (ffestw_stack_top ())->pool);
1724
1725 ++ffestd_block_level_;
1726 assert (ffestd_block_level_ > 0);
1727 }
1728
1729 /* ffestd_R810 -- CASE statement
1730
1731 ffestd_R810(case_value_range_list,name);
1732
1733 If casenum is 0, it's CASE DEFAULT. Else it's the case ranges at
1734 the start of the first_stmt list in the select object at the top of
1735 the stack that match casenum. */
1736
1737 void
1738 ffestd_R810 (unsigned long casenum)
1739 {
1740 ffestdStmt_ stmt;
1741
1742 ffestd_check_simple_ ();
1743
1744 stmt = ffestd_stmt_new_ (FFESTD_stmtidR810_);
1745 ffestd_stmt_append_ (stmt);
1746 ffestd_subr_line_save_ (stmt);
1747 stmt->u.R810.pool = ffesta_output_pool;
1748 stmt->u.R810.block = ffestw_stack_top ();
1749 stmt->u.R810.casenum = casenum;
1750 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
1751 }
1752
1753 /* ffestd_R811 -- End a SELECT
1754
1755 ffestd_R811(TRUE); */
1756
1757 void
1758 ffestd_R811 (bool ok UNUSED)
1759 {
1760 ffestdStmt_ stmt;
1761
1762 stmt = ffestd_stmt_new_ (FFESTD_stmtidR811_);
1763 ffestd_stmt_append_ (stmt);
1764 ffestd_subr_line_save_ (stmt);
1765 stmt->u.R811.block = ffestw_stack_top ();
1766
1767 --ffestd_block_level_;
1768 assert (ffestd_block_level_ >= 0);
1769 }
1770
1771 /* ffestd_R819A -- Iterative DO statement
1772
1773 ffestd_R819A(construct_name,label_token,expr,expr_token);
1774
1775 Make sure statement is valid here; implement. */
1776
1777 void
1778 ffestd_R819A (ffelexToken construct_name UNUSED, ffelab label,
1779 ffebld var, ffebld start, ffelexToken start_token,
1780 ffebld end, ffelexToken end_token,
1781 ffebld incr, ffelexToken incr_token)
1782 {
1783 ffestdStmt_ stmt;
1784
1785 ffestd_check_simple_ ();
1786
1787 stmt = ffestd_stmt_new_ (FFESTD_stmtidR819A_);
1788 ffestd_stmt_append_ (stmt);
1789 ffestd_subr_line_save_ (stmt);
1790 stmt->u.R819A.pool = ffesta_output_pool;
1791 stmt->u.R819A.block = ffestw_use (ffestw_stack_top ());
1792 stmt->u.R819A.label = label;
1793 stmt->u.R819A.var = var;
1794 stmt->u.R819A.start = start;
1795 stmt->u.R819A.start_token = ffelex_token_use (start_token);
1796 stmt->u.R819A.end = end;
1797 stmt->u.R819A.end_token = ffelex_token_use (end_token);
1798 stmt->u.R819A.incr = incr;
1799 stmt->u.R819A.incr_token = (incr_token == NULL) ? NULL
1800 : ffelex_token_use (incr_token);
1801 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
1802
1803 ++ffestd_block_level_;
1804 assert (ffestd_block_level_ > 0);
1805 }
1806
1807 /* ffestd_R819B -- DO WHILE statement
1808
1809 ffestd_R819B(construct_name,label_token,expr,expr_token);
1810
1811 Make sure statement is valid here; implement. */
1812
1813 void
1814 ffestd_R819B (ffelexToken construct_name UNUSED, ffelab label,
1815 ffebld expr)
1816 {
1817 ffestdStmt_ stmt;
1818
1819 ffestd_check_simple_ ();
1820
1821 stmt = ffestd_stmt_new_ (FFESTD_stmtidR819B_);
1822 ffestd_stmt_append_ (stmt);
1823 ffestd_subr_line_save_ (stmt);
1824 stmt->u.R819B.pool = ffesta_output_pool;
1825 stmt->u.R819B.block = ffestw_use (ffestw_stack_top ());
1826 stmt->u.R819B.label = label;
1827 stmt->u.R819B.expr = expr;
1828 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
1829
1830 ++ffestd_block_level_;
1831 assert (ffestd_block_level_ > 0);
1832 }
1833
1834 /* ffestd_R825 -- END DO statement
1835
1836 ffestd_R825(name_token);
1837
1838 Make sure ffestd_kind_ identifies a DO block. If not
1839 NULL, make sure name_token gives the correct name. Do whatever
1840 is specific to seeing END DO with a DO-target label definition on it,
1841 where the END DO is really treated as a CONTINUE (i.e. generate th
1842 same code you would for CONTINUE). ffestd_do handles the actual
1843 generation of end-loop code. */
1844
1845 void
1846 ffestd_R825 (ffelexToken name UNUSED)
1847 {
1848 ffestdStmt_ stmt;
1849
1850 ffestd_check_simple_ ();
1851
1852 stmt = ffestd_stmt_new_ (FFESTD_stmtidR825_);
1853 ffestd_stmt_append_ (stmt);
1854 ffestd_subr_line_save_ (stmt);
1855 }
1856
1857 /* ffestd_R834 -- CYCLE statement
1858
1859 ffestd_R834(name_token);
1860
1861 Handle a CYCLE within a loop. */
1862
1863 void
1864 ffestd_R834 (ffestw block)
1865 {
1866 ffestdStmt_ stmt;
1867
1868 ffestd_check_simple_ ();
1869
1870 stmt = ffestd_stmt_new_ (FFESTD_stmtidR834_);
1871 ffestd_stmt_append_ (stmt);
1872 ffestd_subr_line_save_ (stmt);
1873 stmt->u.R834.block = block;
1874 }
1875
1876 /* ffestd_R835 -- EXIT statement
1877
1878 ffestd_R835(name_token);
1879
1880 Handle a EXIT within a loop. */
1881
1882 void
1883 ffestd_R835 (ffestw block)
1884 {
1885 ffestdStmt_ stmt;
1886
1887 ffestd_check_simple_ ();
1888
1889 stmt = ffestd_stmt_new_ (FFESTD_stmtidR835_);
1890 ffestd_stmt_append_ (stmt);
1891 ffestd_subr_line_save_ (stmt);
1892 stmt->u.R835.block = block;
1893 }
1894
1895 /* ffestd_R836 -- GOTO statement
1896
1897 ffestd_R836(label);
1898
1899 Make sure label_token identifies a valid label for a GOTO. Update
1900 that label's info to indicate it is the target of a GOTO. */
1901
1902 void
1903 ffestd_R836 (ffelab label)
1904 {
1905 ffestdStmt_ stmt;
1906
1907 ffestd_check_simple_ ();
1908
1909 stmt = ffestd_stmt_new_ (FFESTD_stmtidR836_);
1910 ffestd_stmt_append_ (stmt);
1911 ffestd_subr_line_save_ (stmt);
1912 stmt->u.R836.label = label;
1913
1914 if (ffestd_block_level_ == 0)
1915 ffestd_is_reachable_ = FALSE;
1916 }
1917
1918 /* ffestd_R837 -- Computed GOTO statement
1919
1920 ffestd_R837(labels,expr);
1921
1922 Make sure label_list identifies valid labels for a GOTO. Update
1923 each label's info to indicate it is the target of a GOTO. */
1924
1925 void
1926 ffestd_R837 (ffelab *labels, int count, ffebld expr)
1927 {
1928 ffestdStmt_ stmt;
1929
1930 ffestd_check_simple_ ();
1931
1932 stmt = ffestd_stmt_new_ (FFESTD_stmtidR837_);
1933 ffestd_stmt_append_ (stmt);
1934 ffestd_subr_line_save_ (stmt);
1935 stmt->u.R837.pool = ffesta_output_pool;
1936 stmt->u.R837.labels = labels;
1937 stmt->u.R837.count = count;
1938 stmt->u.R837.expr = expr;
1939 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
1940 }
1941
1942 /* ffestd_R838 -- ASSIGN statement
1943
1944 ffestd_R838(label_token,target_variable,target_token);
1945
1946 Make sure label_token identifies a valid label for an assignment. Update
1947 that label's info to indicate it is the source of an assignment. Update
1948 target_variable's info to indicate it is the target the assignment of that
1949 label. */
1950
1951 void
1952 ffestd_R838 (ffelab label, ffebld target)
1953 {
1954 ffestdStmt_ stmt;
1955
1956 ffestd_check_simple_ ();
1957
1958 stmt = ffestd_stmt_new_ (FFESTD_stmtidR838_);
1959 ffestd_stmt_append_ (stmt);
1960 ffestd_subr_line_save_ (stmt);
1961 stmt->u.R838.pool = ffesta_output_pool;
1962 stmt->u.R838.label = label;
1963 stmt->u.R838.target = target;
1964 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
1965 }
1966
1967 /* ffestd_R839 -- Assigned GOTO statement
1968
1969 ffestd_R839(target,labels);
1970
1971 Make sure label_list identifies valid labels for a GOTO. Update
1972 each label's info to indicate it is the target of a GOTO. */
1973
1974 void
1975 ffestd_R839 (ffebld target, ffelab *labels UNUSED, int count UNUSED)
1976 {
1977 ffestdStmt_ stmt;
1978
1979 ffestd_check_simple_ ();
1980
1981 stmt = ffestd_stmt_new_ (FFESTD_stmtidR839_);
1982 ffestd_stmt_append_ (stmt);
1983 ffestd_subr_line_save_ (stmt);
1984 stmt->u.R839.pool = ffesta_output_pool;
1985 stmt->u.R839.target = target;
1986 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
1987
1988 if (ffestd_block_level_ == 0)
1989 ffestd_is_reachable_ = FALSE;
1990 }
1991
1992 /* ffestd_R840 -- Arithmetic IF statement
1993
1994 ffestd_R840(expr,expr_token,neg,zero,pos);
1995
1996 Make sure the labels are valid; implement. */
1997
1998 void
1999 ffestd_R840 (ffebld expr, ffelab neg, ffelab zero, ffelab pos)
2000 {
2001 ffestdStmt_ stmt;
2002
2003 ffestd_check_simple_ ();
2004
2005 stmt = ffestd_stmt_new_ (FFESTD_stmtidR840_);
2006 ffestd_stmt_append_ (stmt);
2007 ffestd_subr_line_save_ (stmt);
2008 stmt->u.R840.pool = ffesta_output_pool;
2009 stmt->u.R840.expr = expr;
2010 stmt->u.R840.neg = neg;
2011 stmt->u.R840.zero = zero;
2012 stmt->u.R840.pos = pos;
2013 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2014
2015 if (ffestd_block_level_ == 0)
2016 ffestd_is_reachable_ = FALSE;
2017 }
2018
2019 /* ffestd_R841 -- CONTINUE statement
2020
2021 ffestd_R841(); */
2022
2023 void
2024 ffestd_R841 (bool in_where UNUSED)
2025 {
2026 ffestdStmt_ stmt;
2027
2028 ffestd_check_simple_ ();
2029
2030 stmt = ffestd_stmt_new_ (FFESTD_stmtidR841_);
2031 ffestd_stmt_append_ (stmt);
2032 ffestd_subr_line_save_ (stmt);
2033 }
2034
2035 /* ffestd_R842 -- STOP statement
2036
2037 ffestd_R842(expr); */
2038
2039 void
2040 ffestd_R842 (ffebld expr)
2041 {
2042 ffestdStmt_ stmt;
2043
2044 ffestd_check_simple_ ();
2045
2046 stmt = ffestd_stmt_new_ (FFESTD_stmtidR842_);
2047 ffestd_stmt_append_ (stmt);
2048 ffestd_subr_line_save_ (stmt);
2049 if (ffesta_outpooldisp () == FFESTA_pooldispPRESERVE)
2050 {
2051 /* This is a "spurious" (automatically-generated) STOP
2052 that follows a previous STOP or other statement.
2053 Make sure we don't have an expression in the pool,
2054 and then mark that the pool has already been killed. */
2055 assert (expr == NULL);
2056 stmt->u.R842.pool = NULL;
2057 stmt->u.R842.expr = NULL;
2058 }
2059 else
2060 {
2061 stmt->u.R842.pool = ffesta_output_pool;
2062 stmt->u.R842.expr = expr;
2063 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2064 }
2065
2066 if (ffestd_block_level_ == 0)
2067 ffestd_is_reachable_ = FALSE;
2068 }
2069
2070 /* ffestd_R843 -- PAUSE statement
2071
2072 ffestd_R843(expr,expr_token);
2073
2074 Make sure statement is valid here; implement. expr and expr_token are
2075 both NULL if there was no expression. */
2076
2077 void
2078 ffestd_R843 (ffebld expr)
2079 {
2080 ffestdStmt_ stmt;
2081
2082 ffestd_check_simple_ ();
2083
2084 stmt = ffestd_stmt_new_ (FFESTD_stmtidR843_);
2085 ffestd_stmt_append_ (stmt);
2086 ffestd_subr_line_save_ (stmt);
2087 stmt->u.R843.pool = ffesta_output_pool;
2088 stmt->u.R843.expr = expr;
2089 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2090 }
2091
2092 /* ffestd_R904 -- OPEN statement
2093
2094 ffestd_R904();
2095
2096 Make sure an OPEN is valid in the current context, and implement it. */
2097
2098 void
2099 ffestd_R904 (void)
2100 {
2101 ffestdStmt_ stmt;
2102
2103 ffestd_check_simple_ ();
2104
2105 #define specified(something) \
2106 (ffestp_file.open.open_spec[something].kw_or_val_present)
2107
2108 /* Warn if there are any thing we don't handle via f2c libraries. */
2109
2110 if (specified (FFESTP_openixACTION)
2111 || specified (FFESTP_openixASSOCIATEVARIABLE)
2112 || specified (FFESTP_openixBLOCKSIZE)
2113 || specified (FFESTP_openixBUFFERCOUNT)
2114 || specified (FFESTP_openixCARRIAGECONTROL)
2115 || specified (FFESTP_openixDEFAULTFILE)
2116 || specified (FFESTP_openixDELIM)
2117 || specified (FFESTP_openixDISPOSE)
2118 || specified (FFESTP_openixEXTENDSIZE)
2119 || specified (FFESTP_openixINITIALSIZE)
2120 || specified (FFESTP_openixKEY)
2121 || specified (FFESTP_openixMAXREC)
2122 || specified (FFESTP_openixNOSPANBLOCKS)
2123 || specified (FFESTP_openixORGANIZATION)
2124 || specified (FFESTP_openixPAD)
2125 || specified (FFESTP_openixPOSITION)
2126 || specified (FFESTP_openixREADONLY)
2127 || specified (FFESTP_openixRECORDTYPE)
2128 || specified (FFESTP_openixSHARED)
2129 || specified (FFESTP_openixUSEROPEN))
2130 {
2131 ffebad_start (FFEBAD_OPEN_UNSUPPORTED);
2132 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
2133 ffelex_token_where_column (ffesta_tokens[0]));
2134 ffebad_finish ();
2135 }
2136
2137 #undef specified
2138
2139 stmt = ffestd_stmt_new_ (FFESTD_stmtidR904_);
2140 ffestd_stmt_append_ (stmt);
2141 ffestd_subr_line_save_ (stmt);
2142 stmt->u.R904.pool = ffesta_output_pool;
2143 stmt->u.R904.params = ffestd_subr_copy_open_ ();
2144 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2145 }
2146
2147 /* ffestd_R907 -- CLOSE statement
2148
2149 ffestd_R907();
2150
2151 Make sure a CLOSE is valid in the current context, and implement it. */
2152
2153 void
2154 ffestd_R907 (void)
2155 {
2156 ffestdStmt_ stmt;
2157
2158 ffestd_check_simple_ ();
2159
2160 stmt = ffestd_stmt_new_ (FFESTD_stmtidR907_);
2161 ffestd_stmt_append_ (stmt);
2162 ffestd_subr_line_save_ (stmt);
2163 stmt->u.R907.pool = ffesta_output_pool;
2164 stmt->u.R907.params = ffestd_subr_copy_close_ ();
2165 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2166 }
2167
2168 /* ffestd_R909_start -- READ(...) statement list begin
2169
2170 ffestd_R909_start(FALSE);
2171
2172 Verify that READ is valid here, and begin accepting items in the
2173 list. */
2174
2175 void
2176 ffestd_R909_start (bool only_format, ffestvUnit unit,
2177 ffestvFormat format, bool rec, bool key)
2178 {
2179 ffestdStmt_ stmt;
2180
2181 ffestd_check_start_ ();
2182
2183 #define specified(something) \
2184 (ffestp_file.read.read_spec[something].kw_or_val_present)
2185
2186 /* Warn if there are any thing we don't handle via f2c libraries. */
2187 if (specified (FFESTP_readixADVANCE)
2188 || specified (FFESTP_readixEOR)
2189 || specified (FFESTP_readixKEYEQ)
2190 || specified (FFESTP_readixKEYGE)
2191 || specified (FFESTP_readixKEYGT)
2192 || specified (FFESTP_readixKEYID)
2193 || specified (FFESTP_readixNULLS)
2194 || specified (FFESTP_readixSIZE))
2195 {
2196 ffebad_start (FFEBAD_READ_UNSUPPORTED);
2197 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
2198 ffelex_token_where_column (ffesta_tokens[0]));
2199 ffebad_finish ();
2200 }
2201
2202 #undef specified
2203
2204 stmt = ffestd_stmt_new_ (FFESTD_stmtidR909_);
2205 ffestd_stmt_append_ (stmt);
2206 ffestd_subr_line_save_ (stmt);
2207 stmt->u.R909.pool = ffesta_output_pool;
2208 stmt->u.R909.params = ffestd_subr_copy_read_ ();
2209 stmt->u.R909.only_format = only_format;
2210 stmt->u.R909.unit = unit;
2211 stmt->u.R909.format = format;
2212 stmt->u.R909.rec = rec;
2213 stmt->u.R909.key = key;
2214 stmt->u.R909.list = NULL;
2215 ffestd_expr_list_ = &stmt->u.R909.list;
2216 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2217 }
2218
2219 /* ffestd_R909_item -- READ statement i/o item
2220
2221 ffestd_R909_item(expr,expr_token);
2222
2223 Implement output-list expression. */
2224
2225 void
2226 ffestd_R909_item (ffebld expr, ffelexToken expr_token)
2227 {
2228 ffestdExprItem_ item;
2229
2230 ffestd_check_item_ ();
2231
2232 item = malloc_new_kp (ffesta_output_pool, "ffestdExprItem_", sizeof (*item));
2233
2234 item->next = NULL;
2235 item->expr = expr;
2236 item->token = ffelex_token_use (expr_token);
2237 *ffestd_expr_list_ = item;
2238 ffestd_expr_list_ = &item->next;
2239 }
2240
2241 /* ffestd_R909_finish -- READ statement list complete
2242
2243 ffestd_R909_finish();
2244
2245 Just wrap up any local activities. */
2246
2247 void
2248 ffestd_R909_finish (void)
2249 {
2250 ffestd_check_finish_ ();
2251 }
2252
2253 /* ffestd_R910_start -- WRITE(...) statement list begin
2254
2255 ffestd_R910_start();
2256
2257 Verify that WRITE is valid here, and begin accepting items in the
2258 list. */
2259
2260 void
2261 ffestd_R910_start (ffestvUnit unit, ffestvFormat format, bool rec)
2262 {
2263 ffestdStmt_ stmt;
2264
2265 ffestd_check_start_ ();
2266
2267 #define specified(something) \
2268 (ffestp_file.write.write_spec[something].kw_or_val_present)
2269
2270 /* Warn if there are any thing we don't handle via f2c libraries. */
2271 if (specified (FFESTP_writeixADVANCE)
2272 || specified (FFESTP_writeixEOR))
2273 {
2274 ffebad_start (FFEBAD_WRITE_UNSUPPORTED);
2275 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
2276 ffelex_token_where_column (ffesta_tokens[0]));
2277 ffebad_finish ();
2278 }
2279
2280 #undef specified
2281
2282 stmt = ffestd_stmt_new_ (FFESTD_stmtidR910_);
2283 ffestd_stmt_append_ (stmt);
2284 ffestd_subr_line_save_ (stmt);
2285 stmt->u.R910.pool = ffesta_output_pool;
2286 stmt->u.R910.params = ffestd_subr_copy_write_ ();
2287 stmt->u.R910.unit = unit;
2288 stmt->u.R910.format = format;
2289 stmt->u.R910.rec = rec;
2290 stmt->u.R910.list = NULL;
2291 ffestd_expr_list_ = &stmt->u.R910.list;
2292 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2293 }
2294
2295 /* ffestd_R910_item -- WRITE statement i/o item
2296
2297 ffestd_R910_item(expr,expr_token);
2298
2299 Implement output-list expression. */
2300
2301 void
2302 ffestd_R910_item (ffebld expr, ffelexToken expr_token)
2303 {
2304 ffestdExprItem_ item;
2305
2306 ffestd_check_item_ ();
2307
2308 item = malloc_new_kp (ffesta_output_pool, "ffestdExprItem_", sizeof (*item));
2309
2310 item->next = NULL;
2311 item->expr = expr;
2312 item->token = ffelex_token_use (expr_token);
2313 *ffestd_expr_list_ = item;
2314 ffestd_expr_list_ = &item->next;
2315 }
2316
2317 /* ffestd_R910_finish -- WRITE statement list complete
2318
2319 ffestd_R910_finish();
2320
2321 Just wrap up any local activities. */
2322
2323 void
2324 ffestd_R910_finish (void)
2325 {
2326 ffestd_check_finish_ ();
2327 }
2328
2329 /* ffestd_R911_start -- PRINT statement list begin
2330
2331 ffestd_R911_start();
2332
2333 Verify that PRINT is valid here, and begin accepting items in the
2334 list. */
2335
2336 void
2337 ffestd_R911_start (ffestvFormat format)
2338 {
2339 ffestdStmt_ stmt;
2340
2341 ffestd_check_start_ ();
2342
2343 stmt = ffestd_stmt_new_ (FFESTD_stmtidR911_);
2344 ffestd_stmt_append_ (stmt);
2345 ffestd_subr_line_save_ (stmt);
2346 stmt->u.R911.pool = ffesta_output_pool;
2347 stmt->u.R911.params = ffestd_subr_copy_print_ ();
2348 stmt->u.R911.format = format;
2349 stmt->u.R911.list = NULL;
2350 ffestd_expr_list_ = &stmt->u.R911.list;
2351 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2352 }
2353
2354 /* ffestd_R911_item -- PRINT statement i/o item
2355
2356 ffestd_R911_item(expr,expr_token);
2357
2358 Implement output-list expression. */
2359
2360 void
2361 ffestd_R911_item (ffebld expr, ffelexToken expr_token)
2362 {
2363 ffestdExprItem_ item;
2364
2365 ffestd_check_item_ ();
2366
2367 item = malloc_new_kp (ffesta_output_pool, "ffestdExprItem_", sizeof (*item));
2368
2369 item->next = NULL;
2370 item->expr = expr;
2371 item->token = ffelex_token_use (expr_token);
2372 *ffestd_expr_list_ = item;
2373 ffestd_expr_list_ = &item->next;
2374 }
2375
2376 /* ffestd_R911_finish -- PRINT statement list complete
2377
2378 ffestd_R911_finish();
2379
2380 Just wrap up any local activities. */
2381
2382 void
2383 ffestd_R911_finish (void)
2384 {
2385 ffestd_check_finish_ ();
2386 }
2387
2388 /* ffestd_R919 -- BACKSPACE statement
2389
2390 ffestd_R919();
2391
2392 Make sure a BACKSPACE is valid in the current context, and implement it. */
2393
2394 void
2395 ffestd_R919 (void)
2396 {
2397 ffestdStmt_ stmt;
2398
2399 ffestd_check_simple_ ();
2400
2401 stmt = ffestd_stmt_new_ (FFESTD_stmtidR919_);
2402 ffestd_stmt_append_ (stmt);
2403 ffestd_subr_line_save_ (stmt);
2404 stmt->u.R919.pool = ffesta_output_pool;
2405 stmt->u.R919.params = ffestd_subr_copy_beru_ ();
2406 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2407 }
2408
2409 /* ffestd_R920 -- ENDFILE statement
2410
2411 ffestd_R920();
2412
2413 Make sure a ENDFILE is valid in the current context, and implement it. */
2414
2415 void
2416 ffestd_R920 (void)
2417 {
2418 ffestdStmt_ stmt;
2419
2420 ffestd_check_simple_ ();
2421
2422 stmt = ffestd_stmt_new_ (FFESTD_stmtidR920_);
2423 ffestd_stmt_append_ (stmt);
2424 ffestd_subr_line_save_ (stmt);
2425 stmt->u.R920.pool = ffesta_output_pool;
2426 stmt->u.R920.params = ffestd_subr_copy_beru_ ();
2427 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2428 }
2429
2430 /* ffestd_R921 -- REWIND statement
2431
2432 ffestd_R921();
2433
2434 Make sure a REWIND is valid in the current context, and implement it. */
2435
2436 void
2437 ffestd_R921 (void)
2438 {
2439 ffestdStmt_ stmt;
2440
2441 ffestd_check_simple_ ();
2442
2443 stmt = ffestd_stmt_new_ (FFESTD_stmtidR921_);
2444 ffestd_stmt_append_ (stmt);
2445 ffestd_subr_line_save_ (stmt);
2446 stmt->u.R921.pool = ffesta_output_pool;
2447 stmt->u.R921.params = ffestd_subr_copy_beru_ ();
2448 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2449 }
2450
2451 /* ffestd_R923A -- INQUIRE statement (non-IOLENGTH version)
2452
2453 ffestd_R923A(bool by_file);
2454
2455 Make sure an INQUIRE is valid in the current context, and implement it. */
2456
2457 void
2458 ffestd_R923A (bool by_file)
2459 {
2460 ffestdStmt_ stmt;
2461
2462 ffestd_check_simple_ ();
2463
2464 #define specified(something) \
2465 (ffestp_file.inquire.inquire_spec[something].kw_or_val_present)
2466
2467 /* Warn if there are any thing we don't handle via f2c libraries. */
2468 if (specified (FFESTP_inquireixACTION)
2469 || specified (FFESTP_inquireixCARRIAGECONTROL)
2470 || specified (FFESTP_inquireixDEFAULTFILE)
2471 || specified (FFESTP_inquireixDELIM)
2472 || specified (FFESTP_inquireixKEYED)
2473 || specified (FFESTP_inquireixORGANIZATION)
2474 || specified (FFESTP_inquireixPAD)
2475 || specified (FFESTP_inquireixPOSITION)
2476 || specified (FFESTP_inquireixREAD)
2477 || specified (FFESTP_inquireixREADWRITE)
2478 || specified (FFESTP_inquireixRECORDTYPE)
2479 || specified (FFESTP_inquireixWRITE))
2480 {
2481 ffebad_start (FFEBAD_INQUIRE_UNSUPPORTED);
2482 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
2483 ffelex_token_where_column (ffesta_tokens[0]));
2484 ffebad_finish ();
2485 }
2486
2487 #undef specified
2488
2489 stmt = ffestd_stmt_new_ (FFESTD_stmtidR923A_);
2490 ffestd_stmt_append_ (stmt);
2491 ffestd_subr_line_save_ (stmt);
2492 stmt->u.R923A.pool = ffesta_output_pool;
2493 stmt->u.R923A.params = ffestd_subr_copy_inquire_ ();
2494 stmt->u.R923A.by_file = by_file;
2495 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2496 }
2497
2498 /* ffestd_R923B_start -- INQUIRE(IOLENGTH=expr) statement list begin
2499
2500 ffestd_R923B_start();
2501
2502 Verify that INQUIRE is valid here, and begin accepting items in the
2503 list. */
2504
2505 void
2506 ffestd_R923B_start (void)
2507 {
2508 ffestdStmt_ stmt;
2509
2510 ffestd_check_start_ ();
2511
2512 stmt = ffestd_stmt_new_ (FFESTD_stmtidR923B_);
2513 ffestd_stmt_append_ (stmt);
2514 ffestd_subr_line_save_ (stmt);
2515 stmt->u.R923B.pool = ffesta_output_pool;
2516 stmt->u.R923B.params = ffestd_subr_copy_inquire_ ();
2517 stmt->u.R923B.list = NULL;
2518 ffestd_expr_list_ = &stmt->u.R923B.list;
2519 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2520 }
2521
2522 /* ffestd_R923B_item -- INQUIRE statement i/o item
2523
2524 ffestd_R923B_item(expr,expr_token);
2525
2526 Implement output-list expression. */
2527
2528 void
2529 ffestd_R923B_item (ffebld expr)
2530 {
2531 ffestdExprItem_ item;
2532
2533 ffestd_check_item_ ();
2534
2535 item = malloc_new_kp (ffesta_output_pool, "ffestdExprItem_", sizeof (*item));
2536
2537 item->next = NULL;
2538 item->expr = expr;
2539 *ffestd_expr_list_ = item;
2540 ffestd_expr_list_ = &item->next;
2541 }
2542
2543 /* ffestd_R923B_finish -- INQUIRE statement list complete
2544
2545 ffestd_R923B_finish();
2546
2547 Just wrap up any local activities. */
2548
2549 void
2550 ffestd_R923B_finish (void)
2551 {
2552 ffestd_check_finish_ ();
2553 }
2554
2555 /* ffestd_R1001 -- FORMAT statement
2556
2557 ffestd_R1001(format_list); */
2558
2559 void
2560 ffestd_R1001 (ffesttFormatList f)
2561 {
2562 ffestsHolder str;
2563 ffests s = &str;
2564 ffestdStmt_ stmt;
2565
2566 ffestd_check_simple_ ();
2567
2568 if (ffestd_label_formatdef_ == NULL)
2569 return; /* Nothing to hook it up to (no label def). */
2570
2571 ffests_new (s, malloc_pool_image (), 80);
2572 ffests_putc (s, '(');
2573 ffestd_R1001dump_ (s, f); /* Build the string in s. */
2574 ffests_putc (s, ')');
2575
2576 stmt = ffestd_stmt_new_ (FFESTD_stmtidR1001_);
2577 ffestd_stmt_append_ (stmt);
2578 stmt->u.R1001.str = str;
2579
2580 ffestd_label_formatdef_ = NULL;
2581 }
2582
2583 /* ffestd_R1001dump_ -- Dump list of formats
2584
2585 ffesttFormatList list;
2586 ffestd_R1001dump_(list,0);
2587
2588 The formats in the list are dumped. */
2589
2590 static void
2591 ffestd_R1001dump_ (ffests s, ffesttFormatList list)
2592 {
2593 ffesttFormatList next;
2594
2595 for (next = list->next; next != list; next = next->next)
2596 {
2597 if (next != list->next)
2598 ffests_putc (s, ',');
2599 switch (next->type)
2600 {
2601 case FFESTP_formattypeI:
2602 ffestd_R1001dump_1005_3_ (s, next, "I");
2603 break;
2604
2605 case FFESTP_formattypeB:
2606 ffestd_R1001error_ (next);
2607 break;
2608
2609 case FFESTP_formattypeO:
2610 ffestd_R1001dump_1005_3_ (s, next, "O");
2611 break;
2612
2613 case FFESTP_formattypeZ:
2614 ffestd_R1001dump_1005_3_ (s, next, "Z");
2615 break;
2616
2617 case FFESTP_formattypeF:
2618 ffestd_R1001dump_1005_4_ (s, next, "F");
2619 break;
2620
2621 case FFESTP_formattypeE:
2622 ffestd_R1001dump_1005_5_ (s, next, "E");
2623 break;
2624
2625 case FFESTP_formattypeEN:
2626 ffestd_R1001error_ (next);
2627 break;
2628
2629 case FFESTP_formattypeG:
2630 ffestd_R1001dump_1005_5_ (s, next, "G");
2631 break;
2632
2633 case FFESTP_formattypeL:
2634 ffestd_R1001dump_1005_2_ (s, next, "L");
2635 break;
2636
2637 case FFESTP_formattypeA:
2638 ffestd_R1001dump_1005_1_ (s, next, "A");
2639 break;
2640
2641 case FFESTP_formattypeD:
2642 ffestd_R1001dump_1005_4_ (s, next, "D");
2643 break;
2644
2645 case FFESTP_formattypeQ:
2646 ffestd_R1001error_ (next);
2647 break;
2648
2649 case FFESTP_formattypeDOLLAR:
2650 ffestd_R1001dump_1010_1_ (s, next, "$");
2651 break;
2652
2653 case FFESTP_formattypeP:
2654 ffestd_R1001dump_1010_4_ (s, next, "P");
2655 break;
2656
2657 case FFESTP_formattypeT:
2658 ffestd_R1001dump_1010_5_ (s, next, "T");
2659 break;
2660
2661 case FFESTP_formattypeTL:
2662 ffestd_R1001dump_1010_5_ (s, next, "TL");
2663 break;
2664
2665 case FFESTP_formattypeTR:
2666 ffestd_R1001dump_1010_5_ (s, next, "TR");
2667 break;
2668
2669 case FFESTP_formattypeX:
2670 ffestd_R1001dump_1010_2_ (s, next, "X");
2671 break;
2672
2673 case FFESTP_formattypeS:
2674 ffestd_R1001dump_1010_1_ (s, next, "S");
2675 break;
2676
2677 case FFESTP_formattypeSP:
2678 ffestd_R1001dump_1010_1_ (s, next, "SP");
2679 break;
2680
2681 case FFESTP_formattypeSS:
2682 ffestd_R1001dump_1010_1_ (s, next, "SS");
2683 break;
2684
2685 case FFESTP_formattypeBN:
2686 ffestd_R1001dump_1010_1_ (s, next, "BN");
2687 break;
2688
2689 case FFESTP_formattypeBZ:
2690 ffestd_R1001dump_1010_1_ (s, next, "BZ");
2691 break;
2692
2693 case FFESTP_formattypeSLASH:
2694 ffestd_R1001dump_1010_2_ (s, next, "/");
2695 break;
2696
2697 case FFESTP_formattypeCOLON:
2698 ffestd_R1001dump_1010_1_ (s, next, ":");
2699 break;
2700
2701 case FFESTP_formattypeR1016:
2702 switch (ffelex_token_type (next->t))
2703 {
2704 case FFELEX_typeCHARACTER:
2705 {
2706 char *p = ffelex_token_text (next->t);
2707 ffeTokenLength i = ffelex_token_length (next->t);
2708
2709 ffests_putc (s, '\002');
2710 while (i-- != 0)
2711 {
2712 if (*p == '\002')
2713 ffests_putc (s, '\002');
2714 ffests_putc (s, *p);
2715 ++p;
2716 }
2717 ffests_putc (s, '\002');
2718 }
2719 break;
2720
2721 case FFELEX_typeHOLLERITH:
2722 {
2723 char *p = ffelex_token_text (next->t);
2724 ffeTokenLength i = ffelex_token_length (next->t);
2725
2726 ffests_printf (s, "%" ffeTokenLength_f "uH", i);
2727 while (i-- != 0)
2728 {
2729 ffests_putc (s, *p);
2730 ++p;
2731 }
2732 }
2733 break;
2734
2735 default:
2736 assert (FALSE);
2737 }
2738 break;
2739
2740 case FFESTP_formattypeFORMAT:
2741 if (next->u.R1003D.R1004.present)
2742 {
2743 if (next->u.R1003D.R1004.rtexpr)
2744 ffestd_R1001rtexpr_ (s, next, next->u.R1003D.R1004.u.expr);
2745 else
2746 ffests_printf (s, "%lu", next->u.R1003D.R1004.u.unsigned_val);
2747 }
2748
2749 ffests_putc (s, '(');
2750 ffestd_R1001dump_ (s, next->u.R1003D.format);
2751 ffests_putc (s, ')');
2752 break;
2753
2754 default:
2755 assert (FALSE);
2756 }
2757 }
2758 }
2759
2760 /* ffestd_R1001dump_1005_1_ -- Dump a particular format
2761
2762 ffesttFormatList f;
2763 ffestd_R1001dump_1005_1_(f,"I");
2764
2765 The format is dumped with form [r]X[w]. */
2766
2767 static void
2768 ffestd_R1001dump_1005_1_ (ffests s, ffesttFormatList f, const char *string)
2769 {
2770 assert (!f->u.R1005.R1007_or_R1008.present);
2771 assert (!f->u.R1005.R1009.present);
2772
2773 if (f->u.R1005.R1004.present)
2774 {
2775 if (f->u.R1005.R1004.rtexpr)
2776 ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr);
2777 else
2778 ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
2779 }
2780
2781 ffests_puts (s, string);
2782
2783 if (f->u.R1005.R1006.present)
2784 {
2785 if (f->u.R1005.R1006.rtexpr)
2786 ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr);
2787 else
2788 ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
2789 }
2790 }
2791
2792 /* ffestd_R1001dump_1005_2_ -- Dump a particular format
2793
2794 ffesttFormatList f;
2795 ffestd_R1001dump_1005_2_(f,"I");
2796
2797 The format is dumped with form [r]Xw. */
2798
2799 static void
2800 ffestd_R1001dump_1005_2_ (ffests s, ffesttFormatList f, const char *string)
2801 {
2802 assert (!f->u.R1005.R1007_or_R1008.present);
2803 assert (!f->u.R1005.R1009.present);
2804 assert (f->u.R1005.R1006.present);
2805
2806 if (f->u.R1005.R1004.present)
2807 {
2808 if (f->u.R1005.R1004.rtexpr)
2809 ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr);
2810 else
2811 ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
2812 }
2813
2814 ffests_puts (s, string);
2815
2816 if (f->u.R1005.R1006.rtexpr)
2817 ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr);
2818 else
2819 ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
2820 }
2821
2822 /* ffestd_R1001dump_1005_3_ -- Dump a particular format
2823
2824 ffesttFormatList f;
2825 ffestd_R1001dump_1005_3_(f,"I");
2826
2827 The format is dumped with form [r]Xw[.m]. */
2828
2829 static void
2830 ffestd_R1001dump_1005_3_ (ffests s, ffesttFormatList f, const char *string)
2831 {
2832 assert (!f->u.R1005.R1009.present);
2833 assert (f->u.R1005.R1006.present);
2834
2835 if (f->u.R1005.R1004.present)
2836 {
2837 if (f->u.R1005.R1004.rtexpr)
2838 ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr);
2839 else
2840 ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
2841 }
2842
2843 ffests_puts (s, string);
2844
2845 if (f->u.R1005.R1006.rtexpr)
2846 ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr);
2847 else
2848 ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
2849
2850 if (f->u.R1005.R1007_or_R1008.present)
2851 {
2852 ffests_putc (s, '.');
2853 if (f->u.R1005.R1007_or_R1008.rtexpr)
2854 ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1007_or_R1008.u.expr);
2855 else
2856 ffests_printf (s, "%lu", f->u.R1005.R1007_or_R1008.u.unsigned_val);
2857 }
2858 }
2859
2860 /* ffestd_R1001dump_1005_4_ -- Dump a particular format
2861
2862 ffesttFormatList f;
2863 ffestd_R1001dump_1005_4_(f,"I");
2864
2865 The format is dumped with form [r]Xw.d. */
2866
2867 static void
2868 ffestd_R1001dump_1005_4_ (ffests s, ffesttFormatList f, const char *string)
2869 {
2870 assert (!f->u.R1005.R1009.present);
2871 assert (f->u.R1005.R1007_or_R1008.present);
2872 assert (f->u.R1005.R1006.present);
2873
2874 if (f->u.R1005.R1004.present)
2875 {
2876 if (f->u.R1005.R1004.rtexpr)
2877 ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr);
2878 else
2879 ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
2880 }
2881
2882 ffests_puts (s, string);
2883
2884 if (f->u.R1005.R1006.rtexpr)
2885 ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr);
2886 else
2887 ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
2888
2889 ffests_putc (s, '.');
2890 if (f->u.R1005.R1007_or_R1008.rtexpr)
2891 ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1007_or_R1008.u.expr);
2892 else
2893 ffests_printf (s, "%lu", f->u.R1005.R1007_or_R1008.u.unsigned_val);
2894 }
2895
2896 /* ffestd_R1001dump_1005_5_ -- Dump a particular format
2897
2898 ffesttFormatList f;
2899 ffestd_R1001dump_1005_5_(f,"I");
2900
2901 The format is dumped with form [r]Xw.d[Ee]. */
2902
2903 static void
2904 ffestd_R1001dump_1005_5_ (ffests s, ffesttFormatList f, const char *string)
2905 {
2906 assert (f->u.R1005.R1007_or_R1008.present);
2907 assert (f->u.R1005.R1006.present);
2908
2909 if (f->u.R1005.R1004.present)
2910 {
2911 if (f->u.R1005.R1004.rtexpr)
2912 ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr);
2913 else
2914 ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
2915 }
2916
2917 ffests_puts (s, string);
2918
2919 if (f->u.R1005.R1006.rtexpr)
2920 ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr);
2921 else
2922 ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
2923
2924 ffests_putc (s, '.');
2925 if (f->u.R1005.R1007_or_R1008.rtexpr)
2926 ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1007_or_R1008.u.expr);
2927 else
2928 ffests_printf (s, "%lu", f->u.R1005.R1007_or_R1008.u.unsigned_val);
2929
2930 if (f->u.R1005.R1009.present)
2931 {
2932 ffests_putc (s, 'E');
2933 if (f->u.R1005.R1009.rtexpr)
2934 ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1009.u.expr);
2935 else
2936 ffests_printf (s, "%lu", f->u.R1005.R1009.u.unsigned_val);
2937 }
2938 }
2939
2940 /* ffestd_R1001dump_1010_1_ -- Dump a particular format
2941
2942 ffesttFormatList f;
2943 ffestd_R1001dump_1010_1_(f,"I");
2944
2945 The format is dumped with form X. */
2946
2947 static void
2948 ffestd_R1001dump_1010_1_ (ffests s, ffesttFormatList f, const char *string)
2949 {
2950 assert (!f->u.R1010.val.present);
2951
2952 ffests_puts (s, string);
2953 }
2954
2955 /* ffestd_R1001dump_1010_2_ -- Dump a particular format
2956
2957 ffesttFormatList f;
2958 ffestd_R1001dump_1010_2_(f,"I");
2959
2960 The format is dumped with form [r]X. */
2961
2962 static void
2963 ffestd_R1001dump_1010_2_ (ffests s, ffesttFormatList f, const char *string)
2964 {
2965 if (f->u.R1010.val.present)
2966 {
2967 if (f->u.R1010.val.rtexpr)
2968 ffestd_R1001rtexpr_ (s, f, f->u.R1010.val.u.expr);
2969 else
2970 ffests_printf (s, "%lu", f->u.R1010.val.u.unsigned_val);
2971 }
2972
2973 ffests_puts (s, string);
2974 }
2975
2976 /* ffestd_R1001dump_1010_4_ -- Dump a particular format
2977
2978 ffesttFormatList f;
2979 ffestd_R1001dump_1010_4_(f,"I");
2980
2981 The format is dumped with form kX. Note that k is signed. */
2982
2983 static void
2984 ffestd_R1001dump_1010_4_ (ffests s, ffesttFormatList f, const char *string)
2985 {
2986 assert (f->u.R1010.val.present);
2987
2988 if (f->u.R1010.val.rtexpr)
2989 ffestd_R1001rtexpr_ (s, f, f->u.R1010.val.u.expr);
2990 else
2991 ffests_printf (s, "%ld", f->u.R1010.val.u.signed_val);
2992
2993 ffests_puts (s, string);
2994 }
2995
2996 /* ffestd_R1001dump_1010_5_ -- Dump a particular format
2997
2998 ffesttFormatList f;
2999 ffestd_R1001dump_1010_5_(f,"I");
3000
3001 The format is dumped with form Xn. */
3002
3003 static void
3004 ffestd_R1001dump_1010_5_ (ffests s, ffesttFormatList f, const char *string)
3005 {
3006 assert (f->u.R1010.val.present);
3007
3008 ffests_puts (s, string);
3009
3010 if (f->u.R1010.val.rtexpr)
3011 ffestd_R1001rtexpr_ (s, f, f->u.R1010.val.u.expr);
3012 else
3013 ffests_printf (s, "%lu", f->u.R1010.val.u.unsigned_val);
3014 }
3015
3016 /* ffestd_R1001error_ -- Complain about FORMAT specification not supported
3017
3018 ffesttFormatList f;
3019 ffestd_R1001error_(f);
3020
3021 An error message is produced. */
3022
3023 static void
3024 ffestd_R1001error_ (ffesttFormatList f)
3025 {
3026 ffebad_start (FFEBAD_FORMAT_UNSUPPORTED);
3027 ffebad_here (0, ffelex_token_where_line (f->t), ffelex_token_where_column (f->t));
3028 ffebad_finish ();
3029 }
3030
3031 static void
3032 ffestd_R1001rtexpr_ (ffests s, ffesttFormatList f, ffebld expr)
3033 {
3034 if ((expr == NULL)
3035 || (ffebld_op (expr) != FFEBLD_opCONTER)
3036 || (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeINTEGER)
3037 || (ffeinfo_kindtype (ffebld_info (expr)) == FFEINFO_kindtypeINTEGER4))
3038 {
3039 ffebad_start (FFEBAD_FORMAT_VARIABLE);
3040 ffebad_here (0, ffelex_token_where_line (f->t), ffelex_token_where_column (f->t));
3041 ffebad_finish ();
3042 }
3043 else
3044 {
3045 int val;
3046
3047 switch (ffeinfo_kindtype (ffebld_info (expr)))
3048 {
3049 #if FFETARGET_okINTEGER1
3050 case FFEINFO_kindtypeINTEGER1:
3051 val = ffebld_constant_integer1 (ffebld_conter (expr));
3052 break;
3053 #endif
3054
3055 #if FFETARGET_okINTEGER2
3056 case FFEINFO_kindtypeINTEGER2:
3057 val = ffebld_constant_integer2 (ffebld_conter (expr));
3058 break;
3059 #endif
3060
3061 #if FFETARGET_okINTEGER3
3062 case FFEINFO_kindtypeINTEGER3:
3063 val = ffebld_constant_integer3 (ffebld_conter (expr));
3064 break;
3065 #endif
3066
3067 default:
3068 assert ("bad INTEGER constant kind type" == NULL);
3069 /* Fall through. */
3070 case FFEINFO_kindtypeANY:
3071 return;
3072 }
3073 ffests_printf (s, "%ld", (long) val);
3074 }
3075 }
3076
3077 /* ffestd_R1102 -- PROGRAM statement
3078
3079 ffestd_R1102(name_token);
3080
3081 Make sure ffestd_kind_ identifies an empty block. Make sure name_token
3082 gives a valid name. Implement the beginning of a main program. */
3083
3084 void
3085 ffestd_R1102 (ffesymbol s, ffelexToken name UNUSED)
3086 {
3087 ffestd_check_simple_ ();
3088
3089 assert (ffestd_block_level_ == 0);
3090 ffestd_is_reachable_ = TRUE;
3091
3092 ffecom_notify_primary_entry (s);
3093 ffe_set_is_mainprog (TRUE); /* Is a main program. */
3094 ffe_set_is_saveall (TRUE); /* Main program always has implicit SAVE. */
3095
3096 ffestw_set_sym (ffestw_stack_top (), s);
3097 }
3098
3099 /* ffestd_R1103 -- End a PROGRAM
3100
3101 ffestd_R1103(); */
3102
3103 void
3104 ffestd_R1103 (bool ok UNUSED)
3105 {
3106 ffestdStmt_ stmt;
3107
3108 assert (ffestd_block_level_ == 0);
3109
3110 if (FFESTD_IS_END_OPTIMIZED_ && ffestd_is_reachable_)
3111 ffestd_R842 (NULL); /* Generate STOP. */
3112
3113 if (ffestw_state (ffestw_stack_top ()) != FFESTV_statePROGRAM5)
3114 ffestd_subr_labels_ (FALSE);/* Handle any undefined labels. */
3115
3116 stmt = ffestd_stmt_new_ (FFESTD_stmtidR1103_);
3117 ffestd_stmt_append_ (stmt);
3118 }
3119
3120 /* ffestd_R1111 -- BLOCK DATA statement
3121
3122 ffestd_R1111(name_token);
3123
3124 Make sure ffestd_kind_ identifies no current program unit. If not
3125 NULL, make sure name_token gives a valid name. Implement the beginning
3126 of a block data program unit. */
3127
3128 void
3129 ffestd_R1111 (ffesymbol s, ffelexToken name UNUSED)
3130 {
3131 assert (ffestd_block_level_ == 0);
3132 ffestd_is_reachable_ = TRUE;
3133
3134 ffestd_check_simple_ ();
3135
3136 ffecom_notify_primary_entry (s);
3137 ffestw_set_sym (ffestw_stack_top (), s);
3138 }
3139
3140 /* ffestd_R1112 -- End a BLOCK DATA
3141
3142 ffestd_R1112(TRUE); */
3143
3144 void
3145 ffestd_R1112 (bool ok UNUSED)
3146 {
3147 ffestdStmt_ stmt;
3148
3149 assert (ffestd_block_level_ == 0);
3150
3151 /* Generate any return-like code here (not likely for BLOCK DATA!). */
3152
3153 if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateBLOCKDATA5)
3154 ffestd_subr_labels_ (TRUE); /* Handle any undefined labels. */
3155
3156 stmt = ffestd_stmt_new_ (FFESTD_stmtidR1112_);
3157 ffestd_stmt_append_ (stmt);
3158 }
3159
3160 /* ffestd_R1207_start -- EXTERNAL statement list begin
3161
3162 ffestd_R1207_start();
3163
3164 Verify that EXTERNAL is valid here, and begin accepting items in the list. */
3165
3166 void
3167 ffestd_R1207_start (void)
3168 {
3169 ffestd_check_start_ ();
3170 }
3171
3172 /* ffestd_R1207_item -- EXTERNAL statement for name
3173
3174 ffestd_R1207_item(name_token);
3175
3176 Make sure name_token identifies a valid object to be EXTERNALd. */
3177
3178 void
3179 ffestd_R1207_item (ffelexToken name)
3180 {
3181 ffestd_check_item_ ();
3182 assert (name != NULL);
3183 }
3184
3185 /* ffestd_R1207_finish -- EXTERNAL statement list complete
3186
3187 ffestd_R1207_finish();
3188
3189 Just wrap up any local activities. */
3190
3191 void
3192 ffestd_R1207_finish (void)
3193 {
3194 ffestd_check_finish_ ();
3195 }
3196
3197 /* ffestd_R1208_start -- INTRINSIC statement list begin
3198
3199 ffestd_R1208_start();
3200
3201 Verify that INTRINSIC is valid here, and begin accepting items in the list. */
3202
3203 void
3204 ffestd_R1208_start (void)
3205 {
3206 ffestd_check_start_ ();
3207 }
3208
3209 /* ffestd_R1208_item -- INTRINSIC statement for name
3210
3211 ffestd_R1208_item(name_token);
3212
3213 Make sure name_token identifies a valid object to be INTRINSICd. */
3214
3215 void
3216 ffestd_R1208_item (ffelexToken name)
3217 {
3218 ffestd_check_item_ ();
3219 assert (name != NULL);
3220 }
3221
3222 /* ffestd_R1208_finish -- INTRINSIC statement list complete
3223
3224 ffestd_R1208_finish();
3225
3226 Just wrap up any local activities. */
3227
3228 void
3229 ffestd_R1208_finish (void)
3230 {
3231 ffestd_check_finish_ ();
3232 }
3233
3234 /* ffestd_R1212 -- CALL statement
3235
3236 ffestd_R1212(expr,expr_token);
3237
3238 Make sure statement is valid here; implement. */
3239
3240 void
3241 ffestd_R1212 (ffebld expr)
3242 {
3243 ffestdStmt_ stmt;
3244
3245 ffestd_check_simple_ ();
3246
3247 stmt = ffestd_stmt_new_ (FFESTD_stmtidR1212_);
3248 ffestd_stmt_append_ (stmt);
3249 ffestd_subr_line_save_ (stmt);
3250 stmt->u.R1212.pool = ffesta_output_pool;
3251 stmt->u.R1212.expr = expr;
3252 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3253 }
3254
3255 /* ffestd_R1219 -- FUNCTION statement
3256
3257 ffestd_R1219(funcname,arglist,ending_token,kind,kindt,len,lent,
3258 recursive);
3259
3260 Make sure statement is valid here, register arguments for the
3261 function name, and so on.
3262
3263 06-Jun-90 JCB 2.0
3264 Added the kind, len, and recursive arguments. */
3265
3266 void
3267 ffestd_R1219 (ffesymbol s, ffelexToken funcname UNUSED,
3268 ffesttTokenList args UNUSED, ffestpType type UNUSED,
3269 ffebld kind UNUSED, ffelexToken kindt UNUSED,
3270 ffebld len UNUSED, ffelexToken lent UNUSED,
3271 bool recursive UNUSED, ffelexToken result UNUSED,
3272 bool separate_result UNUSED)
3273 {
3274 assert (ffestd_block_level_ == 0);
3275 ffestd_is_reachable_ = TRUE;
3276
3277 ffestd_check_simple_ ();
3278
3279 ffecom_notify_primary_entry (s);
3280 ffestw_set_sym (ffestw_stack_top (), s);
3281 }
3282
3283 /* ffestd_R1221 -- End a FUNCTION
3284
3285 ffestd_R1221(TRUE); */
3286
3287 void
3288 ffestd_R1221 (bool ok UNUSED)
3289 {
3290 ffestdStmt_ stmt;
3291
3292 assert (ffestd_block_level_ == 0);
3293
3294 if (FFESTD_IS_END_OPTIMIZED_ && ffestd_is_reachable_)
3295 ffestd_R1227 (NULL); /* Generate RETURN. */
3296
3297 if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateFUNCTION5)
3298 ffestd_subr_labels_ (FALSE);/* Handle any undefined labels. */
3299
3300 stmt = ffestd_stmt_new_ (FFESTD_stmtidR1221_);
3301 ffestd_stmt_append_ (stmt);
3302 }
3303
3304 /* ffestd_R1223 -- SUBROUTINE statement
3305
3306 ffestd_R1223(subrname,arglist,ending_token,recursive_token);
3307
3308 Make sure statement is valid here, register arguments for the
3309 subroutine name, and so on.
3310
3311 06-Jun-90 JCB 2.0
3312 Added the recursive argument. */
3313
3314 void
3315 ffestd_R1223 (ffesymbol s, ffelexToken subrname UNUSED,
3316 ffesttTokenList args UNUSED, ffelexToken final UNUSED,
3317 bool recursive UNUSED)
3318 {
3319 assert (ffestd_block_level_ == 0);
3320 ffestd_is_reachable_ = TRUE;
3321
3322 ffestd_check_simple_ ();
3323
3324 ffecom_notify_primary_entry (s);
3325 ffestw_set_sym (ffestw_stack_top (), s);
3326 }
3327
3328 /* ffestd_R1225 -- End a SUBROUTINE
3329
3330 ffestd_R1225(TRUE); */
3331
3332 void
3333 ffestd_R1225 (bool ok UNUSED)
3334 {
3335 ffestdStmt_ stmt;
3336
3337 assert (ffestd_block_level_ == 0);
3338
3339 if (FFESTD_IS_END_OPTIMIZED_ && ffestd_is_reachable_)
3340 ffestd_R1227 (NULL); /* Generate RETURN. */
3341
3342 if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateSUBROUTINE5)
3343 ffestd_subr_labels_ (FALSE);/* Handle any undefined labels. */
3344
3345 stmt = ffestd_stmt_new_ (FFESTD_stmtidR1225_);
3346 ffestd_stmt_append_ (stmt);
3347 }
3348
3349 /* ffestd_R1226 -- ENTRY statement
3350
3351 ffestd_R1226(entryname,arglist,ending_token);
3352
3353 Make sure we're in a SUBROUTINE or FUNCTION, register arguments for the
3354 entry point name, and so on. */
3355
3356 void
3357 ffestd_R1226 (ffesymbol entry)
3358 {
3359 ffestd_check_simple_ ();
3360
3361 if (!ffesta_seen_first_exec || ffecom_2pass_advise_entrypoint (entry))
3362 {
3363 ffestdStmt_ stmt;
3364
3365 stmt = ffestd_stmt_new_ (FFESTD_stmtidR1226_);
3366 ffestd_stmt_append_ (stmt);
3367 ffestd_subr_line_save_ (stmt);
3368 stmt->u.R1226.entry = entry;
3369 stmt->u.R1226.entrynum = ++ffestd_2pass_entrypoints_;
3370 }
3371
3372 ffestd_is_reachable_ = TRUE;
3373 }
3374
3375 /* ffestd_R1227 -- RETURN statement
3376
3377 ffestd_R1227(expr);
3378
3379 Make sure statement is valid here; implement. expr and expr_token are
3380 both NULL if there was no expression. */
3381
3382 void
3383 ffestd_R1227 (ffebld expr)
3384 {
3385 ffestdStmt_ stmt;
3386
3387 ffestd_check_simple_ ();
3388
3389 stmt = ffestd_stmt_new_ (FFESTD_stmtidR1227_);
3390 ffestd_stmt_append_ (stmt);
3391 ffestd_subr_line_save_ (stmt);
3392 stmt->u.R1227.pool = ffesta_output_pool;
3393 stmt->u.R1227.block = ffestw_stack_top ();
3394 stmt->u.R1227.expr = expr;
3395 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3396
3397 if (ffestd_block_level_ == 0)
3398 ffestd_is_reachable_ = FALSE;
3399 }
3400
3401 /* ffestd_R1229_start -- STMTFUNCTION statement begin
3402
3403 ffestd_R1229_start(func_name,func_arg_list,close_paren);
3404
3405 This function does not really need to do anything, since _finish_
3406 gets all the info needed, and ffestc_R1229_start has already
3407 done all the stuff that makes a two-phase operation (start and
3408 finish) for handling statement functions necessary.
3409
3410 03-Jan-91 JCB 2.0
3411 Do nothing, now that _finish_ does everything. */
3412
3413 void
3414 ffestd_R1229_start (ffelexToken name UNUSED, ffesttTokenList args UNUSED)
3415 {
3416 ffestd_check_start_ ();
3417 }
3418
3419 /* ffestd_R1229_finish -- STMTFUNCTION statement list complete
3420
3421 ffestd_R1229_finish(s);
3422
3423 The statement function's symbol is passed. Its list of dummy args is
3424 accessed via ffesymbol_dummyargs and its expansion expression (expr)
3425 is accessed via ffesymbol_sfexpr.
3426
3427 If sfexpr is NULL, an error occurred parsing the expansion expression, so
3428 just cancel the effects of ffestd_R1229_start and pretend nothing
3429 happened. Otherwise, install the expression as the expansion for the
3430 statement function, then clean up.
3431
3432 03-Jan-91 JCB 2.0
3433 Takes sfunc sym instead of just the expansion expression as an
3434 argument, so this function can do all the work, and _start_ is just
3435 a nicety than can do nothing in a back end. */
3436
3437 void
3438 ffestd_R1229_finish (ffesymbol s)
3439 {
3440 ffebld expr = ffesymbol_sfexpr (s);
3441
3442 ffestd_check_finish_ ();
3443
3444 if (expr == NULL)
3445 return; /* Nothing to do, definition didn't work. */
3446
3447 /* With gcc, cannot do anything here, because the backend hasn't even
3448 (necessarily) been notified that we're compiling a program unit! */
3449 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3450 }
3451
3452 /* ffestd_S3P4 -- INCLUDE line
3453
3454 ffestd_S3P4(filename,filename_token);
3455
3456 Make sure INCLUDE not preceded by any semicolons or a label def; implement. */
3457
3458 void
3459 ffestd_S3P4 (ffebld filename)
3460 {
3461 FILE *fi;
3462 ffetargetCharacterDefault buildname;
3463 ffewhereFile wf;
3464
3465 ffestd_check_simple_ ();
3466
3467 assert (filename != NULL);
3468 if (ffebld_op (filename) != FFEBLD_opANY)
3469 {
3470 assert (ffebld_op (filename) == FFEBLD_opCONTER);
3471 assert (ffeinfo_basictype (ffebld_info (filename))
3472 == FFEINFO_basictypeCHARACTER);
3473 assert (ffeinfo_kindtype (ffebld_info (filename))
3474 == FFEINFO_kindtypeCHARACTERDEFAULT);
3475 buildname = ffebld_constant_characterdefault (ffebld_conter (filename));
3476 wf = ffewhere_file_new (ffetarget_text_characterdefault (buildname),
3477 ffetarget_length_characterdefault (buildname));
3478 fi = ffecom_open_include (ffewhere_file_name (wf),
3479 ffelex_token_where_line (ffesta_tokens[0]),
3480 ffelex_token_where_column (ffesta_tokens[0]));
3481 if (fi != NULL)
3482 ffelex_set_include (wf, (ffelex_token_type (ffesta_tokens[0])
3483 == FFELEX_typeNAME), fi);
3484 }
3485 }
3486
3487 /* ffestd_V014_start -- VOLATILE statement list begin
3488
3489 ffestd_V014_start();
3490
3491 Verify that VOLATILE is valid here, and begin accepting items in the list. */
3492
3493 void
3494 ffestd_V014_start (void)
3495 {
3496 ffestd_check_start_ ();
3497 }
3498
3499 /* ffestd_V014_item_object -- VOLATILE statement for object-name
3500
3501 ffestd_V014_item_object(name_token);
3502
3503 Make sure name_token identifies a valid object to be VOLATILEd. */
3504
3505 void
3506 ffestd_V014_item_object (ffelexToken name UNUSED)
3507 {
3508 ffestd_check_item_ ();
3509 }
3510
3511 /* ffestd_V014_item_cblock -- VOLATILE statement for common-block-name
3512
3513 ffestd_V014_item_cblock(name_token);
3514
3515 Make sure name_token identifies a valid common block to be VOLATILEd. */
3516
3517 void
3518 ffestd_V014_item_cblock (ffelexToken name UNUSED)
3519 {
3520 ffestd_check_item_ ();
3521 }
3522
3523 /* ffestd_V014_finish -- VOLATILE statement list complete
3524
3525 ffestd_V014_finish();
3526
3527 Just wrap up any local activities. */
3528
3529 void
3530 ffestd_V014_finish (void)
3531 {
3532 ffestd_check_finish_ ();
3533 }
3534
3535 /* ffestd_V020_start -- TYPE statement list begin
3536
3537 ffestd_V020_start();
3538
3539 Verify that TYPE is valid here, and begin accepting items in the
3540 list. */
3541
3542 void
3543 ffestd_V020_start (ffestvFormat format UNUSED)
3544 {
3545 ffestd_check_start_ ();
3546 ffestd_subr_vxt_ ();
3547 }
3548
3549 /* ffestd_V020_item -- TYPE statement i/o item
3550
3551 ffestd_V020_item(expr,expr_token);
3552
3553 Implement output-list expression. */
3554
3555 void
3556 ffestd_V020_item (ffebld expr UNUSED)
3557 {
3558 ffestd_check_item_ ();
3559 }
3560
3561 /* ffestd_V020_finish -- TYPE statement list complete
3562
3563 ffestd_V020_finish();
3564
3565 Just wrap up any local activities. */
3566
3567 void
3568 ffestd_V020_finish (void)
3569 {
3570 ffestd_check_finish_ ();
3571 }
3572
3573 /* ffestd_V027_start -- VXT PARAMETER statement list begin
3574
3575 ffestd_V027_start();
3576
3577 Verify that PARAMETER is valid here, and begin accepting items in the list. */
3578
3579 void
3580 ffestd_V027_start (void)
3581 {
3582 ffestd_check_start_ ();
3583 ffestd_subr_vxt_ ();
3584 }
3585
3586 /* ffestd_V027_item -- VXT PARAMETER statement assignment
3587
3588 ffestd_V027_item(dest,dest_token,source,source_token);
3589
3590 Make sure the source is a valid source for the destination; make the
3591 assignment. */
3592
3593 void
3594 ffestd_V027_item (ffelexToken dest_token UNUSED, ffebld source UNUSED)
3595 {
3596 ffestd_check_item_ ();
3597 }
3598
3599 /* ffestd_V027_finish -- VXT PARAMETER statement list complete
3600
3601 ffestd_V027_finish();
3602
3603 Just wrap up any local activities. */
3604
3605 void
3606 ffestd_V027_finish (void)
3607 {
3608 ffestd_check_finish_ ();
3609 }
3610
3611 /* Any executable statement. */
3612
3613 void
3614 ffestd_any (void)
3615 {
3616 ffestdStmt_ stmt;
3617
3618 ffestd_check_simple_ ();
3619
3620 stmt = ffestd_stmt_new_ (FFESTD_stmtidR841_);
3621 ffestd_stmt_append_ (stmt);
3622 ffestd_subr_line_save_ (stmt);
3623 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org