?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* sh.c (prepare_move_operand): Check if operand 0 is an invalid
[official-gcc.git] / gcc / f / std.c
blobd225d1c97243ea4b05708b1e71c804586d277bd7
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_ ()
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 = (ffestpInquireStmt *) malloc_new_kp (ffesta_output_pool,
988 "FFESTD easy", 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_ ()
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 ()
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 ()
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 ()
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 ()
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 ()
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 ()
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 ()
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 ()
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 ()
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 ()
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 ()
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 ()
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 ()
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 ()
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 ()
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 ()
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 ()
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 ()
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 ()
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 = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool,
2233 "ffestdExprItem_", sizeof (*item));
2234
2235 item->next = NULL;
2236 item->expr = expr;
2237 item->token = ffelex_token_use (expr_token);
2238 *ffestd_expr_list_ = item;
2239 ffestd_expr_list_ = &item->next;
2240 }
2241
2242 /* ffestd_R909_finish -- READ statement list complete
2243
2244 ffestd_R909_finish();
2245
2246 Just wrap up any local activities. */
2247
2248 void
2249 ffestd_R909_finish ()
2250 {
2251 ffestd_check_finish_ ();
2252 }
2253
2254 /* ffestd_R910_start -- WRITE(...) statement list begin
2255
2256 ffestd_R910_start();
2257
2258 Verify that WRITE is valid here, and begin accepting items in the
2259 list. */
2260
2261 void
2262 ffestd_R910_start (ffestvUnit unit, ffestvFormat format, bool rec)
2263 {
2264 ffestdStmt_ stmt;
2265
2266 ffestd_check_start_ ();
2267
2268 #define specified(something) \
2269 (ffestp_file.write.write_spec[something].kw_or_val_present)
2270
2271 /* Warn if there are any thing we don't handle via f2c libraries. */
2272 if (specified (FFESTP_writeixADVANCE)
2273 || specified (FFESTP_writeixEOR))
2274 {
2275 ffebad_start (FFEBAD_WRITE_UNSUPPORTED);
2276 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
2277 ffelex_token_where_column (ffesta_tokens[0]));
2278 ffebad_finish ();
2279 }
2280
2281 #undef specified
2282
2283 stmt = ffestd_stmt_new_ (FFESTD_stmtidR910_);
2284 ffestd_stmt_append_ (stmt);
2285 ffestd_subr_line_save_ (stmt);
2286 stmt->u.R910.pool = ffesta_output_pool;
2287 stmt->u.R910.params = ffestd_subr_copy_write_ ();
2288 stmt->u.R910.unit = unit;
2289 stmt->u.R910.format = format;
2290 stmt->u.R910.rec = rec;
2291 stmt->u.R910.list = NULL;
2292 ffestd_expr_list_ = &stmt->u.R910.list;
2293 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2294 }
2295
2296 /* ffestd_R910_item -- WRITE statement i/o item
2297
2298 ffestd_R910_item(expr,expr_token);
2299
2300 Implement output-list expression. */
2301
2302 void
2303 ffestd_R910_item (ffebld expr, ffelexToken expr_token)
2304 {
2305 ffestdExprItem_ item;
2306
2307 ffestd_check_item_ ();
2308
2309 item = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool,
2310 "ffestdExprItem_", sizeof (*item));
2311
2312 item->next = NULL;
2313 item->expr = expr;
2314 item->token = ffelex_token_use (expr_token);
2315 *ffestd_expr_list_ = item;
2316 ffestd_expr_list_ = &item->next;
2317 }
2318
2319 /* ffestd_R910_finish -- WRITE statement list complete
2320
2321 ffestd_R910_finish();
2322
2323 Just wrap up any local activities. */
2324
2325 void
2326 ffestd_R910_finish ()
2327 {
2328 ffestd_check_finish_ ();
2329 }
2330
2331 /* ffestd_R911_start -- PRINT statement list begin
2332
2333 ffestd_R911_start();
2334
2335 Verify that PRINT is valid here, and begin accepting items in the
2336 list. */
2337
2338 void
2339 ffestd_R911_start (ffestvFormat format)
2340 {
2341 ffestdStmt_ stmt;
2342
2343 ffestd_check_start_ ();
2344
2345 stmt = ffestd_stmt_new_ (FFESTD_stmtidR911_);
2346 ffestd_stmt_append_ (stmt);
2347 ffestd_subr_line_save_ (stmt);
2348 stmt->u.R911.pool = ffesta_output_pool;
2349 stmt->u.R911.params = ffestd_subr_copy_print_ ();
2350 stmt->u.R911.format = format;
2351 stmt->u.R911.list = NULL;
2352 ffestd_expr_list_ = &stmt->u.R911.list;
2353 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2354 }
2355
2356 /* ffestd_R911_item -- PRINT statement i/o item
2357
2358 ffestd_R911_item(expr,expr_token);
2359
2360 Implement output-list expression. */
2361
2362 void
2363 ffestd_R911_item (ffebld expr, ffelexToken expr_token)
2364 {
2365 ffestdExprItem_ item;
2366
2367 ffestd_check_item_ ();
2368
2369 item = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool,
2370 "ffestdExprItem_", sizeof (*item));
2371
2372 item->next = NULL;
2373 item->expr = expr;
2374 item->token = ffelex_token_use (expr_token);
2375 *ffestd_expr_list_ = item;
2376 ffestd_expr_list_ = &item->next;
2377 }
2378
2379 /* ffestd_R911_finish -- PRINT statement list complete
2380
2381 ffestd_R911_finish();
2382
2383 Just wrap up any local activities. */
2384
2385 void
2386 ffestd_R911_finish ()
2387 {
2388 ffestd_check_finish_ ();
2389 }
2390
2391 /* ffestd_R919 -- BACKSPACE statement
2392
2393 ffestd_R919();
2394
2395 Make sure a BACKSPACE is valid in the current context, and implement it. */
2396
2397 void
2398 ffestd_R919 ()
2399 {
2400 ffestdStmt_ stmt;
2401
2402 ffestd_check_simple_ ();
2403
2404 stmt = ffestd_stmt_new_ (FFESTD_stmtidR919_);
2405 ffestd_stmt_append_ (stmt);
2406 ffestd_subr_line_save_ (stmt);
2407 stmt->u.R919.pool = ffesta_output_pool;
2408 stmt->u.R919.params = ffestd_subr_copy_beru_ ();
2409 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2410 }
2411
2412 /* ffestd_R920 -- ENDFILE statement
2413
2414 ffestd_R920();
2415
2416 Make sure a ENDFILE is valid in the current context, and implement it. */
2417
2418 void
2419 ffestd_R920 ()
2420 {
2421 ffestdStmt_ stmt;
2422
2423 ffestd_check_simple_ ();
2424
2425 stmt = ffestd_stmt_new_ (FFESTD_stmtidR920_);
2426 ffestd_stmt_append_ (stmt);
2427 ffestd_subr_line_save_ (stmt);
2428 stmt->u.R920.pool = ffesta_output_pool;
2429 stmt->u.R920.params = ffestd_subr_copy_beru_ ();
2430 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2431 }
2432
2433 /* ffestd_R921 -- REWIND statement
2434
2435 ffestd_R921();
2436
2437 Make sure a REWIND is valid in the current context, and implement it. */
2438
2439 void
2440 ffestd_R921 ()
2441 {
2442 ffestdStmt_ stmt;
2443
2444 ffestd_check_simple_ ();
2445
2446 stmt = ffestd_stmt_new_ (FFESTD_stmtidR921_);
2447 ffestd_stmt_append_ (stmt);
2448 ffestd_subr_line_save_ (stmt);
2449 stmt->u.R921.pool = ffesta_output_pool;
2450 stmt->u.R921.params = ffestd_subr_copy_beru_ ();
2451 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2452 }
2453
2454 /* ffestd_R923A -- INQUIRE statement (non-IOLENGTH version)
2455
2456 ffestd_R923A(bool by_file);
2457
2458 Make sure an INQUIRE is valid in the current context, and implement it. */
2459
2460 void
2461 ffestd_R923A (bool by_file)
2462 {
2463 ffestdStmt_ stmt;
2464
2465 ffestd_check_simple_ ();
2466
2467 #define specified(something) \
2468 (ffestp_file.inquire.inquire_spec[something].kw_or_val_present)
2469
2470 /* Warn if there are any thing we don't handle via f2c libraries. */
2471 if (specified (FFESTP_inquireixACTION)
2472 || specified (FFESTP_inquireixCARRIAGECONTROL)
2473 || specified (FFESTP_inquireixDEFAULTFILE)
2474 || specified (FFESTP_inquireixDELIM)
2475 || specified (FFESTP_inquireixKEYED)
2476 || specified (FFESTP_inquireixORGANIZATION)
2477 || specified (FFESTP_inquireixPAD)
2478 || specified (FFESTP_inquireixPOSITION)
2479 || specified (FFESTP_inquireixREAD)
2480 || specified (FFESTP_inquireixREADWRITE)
2481 || specified (FFESTP_inquireixRECORDTYPE)
2482 || specified (FFESTP_inquireixWRITE))
2483 {
2484 ffebad_start (FFEBAD_INQUIRE_UNSUPPORTED);
2485 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
2486 ffelex_token_where_column (ffesta_tokens[0]));
2487 ffebad_finish ();
2488 }
2489
2490 #undef specified
2491
2492 stmt = ffestd_stmt_new_ (FFESTD_stmtidR923A_);
2493 ffestd_stmt_append_ (stmt);
2494 ffestd_subr_line_save_ (stmt);
2495 stmt->u.R923A.pool = ffesta_output_pool;
2496 stmt->u.R923A.params = ffestd_subr_copy_inquire_ ();
2497 stmt->u.R923A.by_file = by_file;
2498 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2499 }
2500
2501 /* ffestd_R923B_start -- INQUIRE(IOLENGTH=expr) statement list begin
2502
2503 ffestd_R923B_start();
2504
2505 Verify that INQUIRE is valid here, and begin accepting items in the
2506 list. */
2507
2508 void
2509 ffestd_R923B_start ()
2510 {
2511 ffestdStmt_ stmt;
2512
2513 ffestd_check_start_ ();
2514
2515 stmt = ffestd_stmt_new_ (FFESTD_stmtidR923B_);
2516 ffestd_stmt_append_ (stmt);
2517 ffestd_subr_line_save_ (stmt);
2518 stmt->u.R923B.pool = ffesta_output_pool;
2519 stmt->u.R923B.params = ffestd_subr_copy_inquire_ ();
2520 stmt->u.R923B.list = NULL;
2521 ffestd_expr_list_ = &stmt->u.R923B.list;
2522 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2523 }
2524
2525 /* ffestd_R923B_item -- INQUIRE statement i/o item
2526
2527 ffestd_R923B_item(expr,expr_token);
2528
2529 Implement output-list expression. */
2530
2531 void
2532 ffestd_R923B_item (ffebld expr)
2533 {
2534 ffestdExprItem_ item;
2535
2536 ffestd_check_item_ ();
2537
2538 item = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool,
2539 "ffestdExprItem_", sizeof (*item));
2540
2541 item->next = NULL;
2542 item->expr = expr;
2543 *ffestd_expr_list_ = item;
2544 ffestd_expr_list_ = &item->next;
2545 }
2546
2547 /* ffestd_R923B_finish -- INQUIRE statement list complete
2548
2549 ffestd_R923B_finish();
2550
2551 Just wrap up any local activities. */
2552
2553 void
2554 ffestd_R923B_finish ()
2555 {
2556 ffestd_check_finish_ ();
2557 }
2558
2559 /* ffestd_R1001 -- FORMAT statement
2560
2561 ffestd_R1001(format_list); */
2562
2563 void
2564 ffestd_R1001 (ffesttFormatList f)
2565 {
2566 ffestsHolder str;
2567 ffests s = &str;
2568 ffestdStmt_ stmt;
2569
2570 ffestd_check_simple_ ();
2571
2572 if (ffestd_label_formatdef_ == NULL)
2573 return; /* Nothing to hook it up to (no label def). */
2574
2575 ffests_new (s, malloc_pool_image (), 80);
2576 ffests_putc (s, '(');
2577 ffestd_R1001dump_ (s, f); /* Build the string in s. */
2578 ffests_putc (s, ')');
2579
2580 stmt = ffestd_stmt_new_ (FFESTD_stmtidR1001_);
2581 ffestd_stmt_append_ (stmt);
2582 stmt->u.R1001.str = str;
2583
2584 ffestd_label_formatdef_ = NULL;
2585 }
2586
2587 /* ffestd_R1001dump_ -- Dump list of formats
2588
2589 ffesttFormatList list;
2590 ffestd_R1001dump_(list,0);
2591
2592 The formats in the list are dumped. */
2593
2594 static void
2595 ffestd_R1001dump_ (ffests s, ffesttFormatList list)
2596 {
2597 ffesttFormatList next;
2598
2599 for (next = list->next; next != list; next = next->next)
2600 {
2601 if (next != list->next)
2602 ffests_putc (s, ',');
2603 switch (next->type)
2604 {
2605 case FFESTP_formattypeI:
2606 ffestd_R1001dump_1005_3_ (s, next, "I");
2607 break;
2608
2609 case FFESTP_formattypeB:
2610 ffestd_R1001error_ (next);
2611 break;
2612
2613 case FFESTP_formattypeO:
2614 ffestd_R1001dump_1005_3_ (s, next, "O");
2615 break;
2616
2617 case FFESTP_formattypeZ:
2618 ffestd_R1001dump_1005_3_ (s, next, "Z");
2619 break;
2620
2621 case FFESTP_formattypeF:
2622 ffestd_R1001dump_1005_4_ (s, next, "F");
2623 break;
2624
2625 case FFESTP_formattypeE:
2626 ffestd_R1001dump_1005_5_ (s, next, "E");
2627 break;
2628
2629 case FFESTP_formattypeEN:
2630 ffestd_R1001error_ (next);
2631 break;
2632
2633 case FFESTP_formattypeG:
2634 ffestd_R1001dump_1005_5_ (s, next, "G");
2635 break;
2636
2637 case FFESTP_formattypeL:
2638 ffestd_R1001dump_1005_2_ (s, next, "L");
2639 break;
2640
2641 case FFESTP_formattypeA:
2642 ffestd_R1001dump_1005_1_ (s, next, "A");
2643 break;
2644
2645 case FFESTP_formattypeD:
2646 ffestd_R1001dump_1005_4_ (s, next, "D");
2647 break;
2648
2649 case FFESTP_formattypeQ:
2650 ffestd_R1001error_ (next);
2651 break;
2652
2653 case FFESTP_formattypeDOLLAR:
2654 ffestd_R1001dump_1010_1_ (s, next, "$");
2655 break;
2656
2657 case FFESTP_formattypeP:
2658 ffestd_R1001dump_1010_4_ (s, next, "P");
2659 break;
2660
2661 case FFESTP_formattypeT:
2662 ffestd_R1001dump_1010_5_ (s, next, "T");
2663 break;
2664
2665 case FFESTP_formattypeTL:
2666 ffestd_R1001dump_1010_5_ (s, next, "TL");
2667 break;
2668
2669 case FFESTP_formattypeTR:
2670 ffestd_R1001dump_1010_5_ (s, next, "TR");
2671 break;
2672
2673 case FFESTP_formattypeX:
2674 ffestd_R1001dump_1010_2_ (s, next, "X");
2675 break;
2676
2677 case FFESTP_formattypeS:
2678 ffestd_R1001dump_1010_1_ (s, next, "S");
2679 break;
2680
2681 case FFESTP_formattypeSP:
2682 ffestd_R1001dump_1010_1_ (s, next, "SP");
2683 break;
2684
2685 case FFESTP_formattypeSS:
2686 ffestd_R1001dump_1010_1_ (s, next, "SS");
2687 break;
2688
2689 case FFESTP_formattypeBN:
2690 ffestd_R1001dump_1010_1_ (s, next, "BN");
2691 break;
2692
2693 case FFESTP_formattypeBZ:
2694 ffestd_R1001dump_1010_1_ (s, next, "BZ");
2695 break;
2696
2697 case FFESTP_formattypeSLASH:
2698 ffestd_R1001dump_1010_2_ (s, next, "/");
2699 break;
2700
2701 case FFESTP_formattypeCOLON:
2702 ffestd_R1001dump_1010_1_ (s, next, ":");
2703 break;
2704
2705 case FFESTP_formattypeR1016:
2706 switch (ffelex_token_type (next->t))
2707 {
2708 case FFELEX_typeCHARACTER:
2709 {
2710 char *p = ffelex_token_text (next->t);
2711 ffeTokenLength i = ffelex_token_length (next->t);
2712
2713 ffests_putc (s, '\002');
2714 while (i-- != 0)
2715 {
2716 if (*p == '\002')
2717 ffests_putc (s, '\002');
2718 ffests_putc (s, *p);
2719 ++p;
2720 }
2721 ffests_putc (s, '\002');
2722 }
2723 break;
2724
2725 case FFELEX_typeHOLLERITH:
2726 {
2727 char *p = ffelex_token_text (next->t);
2728 ffeTokenLength i = ffelex_token_length (next->t);
2729
2730 ffests_printf (s, "%" ffeTokenLength_f "uH", i);
2731 while (i-- != 0)
2732 {
2733 ffests_putc (s, *p);
2734 ++p;
2735 }
2736 }
2737 break;
2738
2739 default:
2740 assert (FALSE);
2741 }
2742 break;
2743
2744 case FFESTP_formattypeFORMAT:
2745 if (next->u.R1003D.R1004.present)
2746 {
2747 if (next->u.R1003D.R1004.rtexpr)
2748 ffestd_R1001rtexpr_ (s, next, next->u.R1003D.R1004.u.expr);
2749 else
2750 ffests_printf (s, "%lu", next->u.R1003D.R1004.u.unsigned_val);
2751 }
2752
2753 ffests_putc (s, '(');
2754 ffestd_R1001dump_ (s, next->u.R1003D.format);
2755 ffests_putc (s, ')');
2756 break;
2757
2758 default:
2759 assert (FALSE);
2760 }
2761 }
2762 }
2763
2764 /* ffestd_R1001dump_1005_1_ -- Dump a particular format
2765
2766 ffesttFormatList f;
2767 ffestd_R1001dump_1005_1_(f,"I");
2768
2769 The format is dumped with form [r]X[w]. */
2770
2771 static void
2772 ffestd_R1001dump_1005_1_ (ffests s, ffesttFormatList f, const char *string)
2773 {
2774 assert (!f->u.R1005.R1007_or_R1008.present);
2775 assert (!f->u.R1005.R1009.present);
2776
2777 if (f->u.R1005.R1004.present)
2778 {
2779 if (f->u.R1005.R1004.rtexpr)
2780 ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr);
2781 else
2782 ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
2783 }
2784
2785 ffests_puts (s, string);
2786
2787 if (f->u.R1005.R1006.present)
2788 {
2789 if (f->u.R1005.R1006.rtexpr)
2790 ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr);
2791 else
2792 ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
2793 }
2794 }
2795
2796 /* ffestd_R1001dump_1005_2_ -- Dump a particular format
2797
2798 ffesttFormatList f;
2799 ffestd_R1001dump_1005_2_(f,"I");
2800
2801 The format is dumped with form [r]Xw. */
2802
2803 static void
2804 ffestd_R1001dump_1005_2_ (ffests s, ffesttFormatList f, const char *string)
2805 {
2806 assert (!f->u.R1005.R1007_or_R1008.present);
2807 assert (!f->u.R1005.R1009.present);
2808 assert (f->u.R1005.R1006.present);
2809
2810 if (f->u.R1005.R1004.present)
2811 {
2812 if (f->u.R1005.R1004.rtexpr)
2813 ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr);
2814 else
2815 ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
2816 }
2817
2818 ffests_puts (s, string);
2819
2820 if (f->u.R1005.R1006.rtexpr)
2821 ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr);
2822 else
2823 ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
2824 }
2825
2826 /* ffestd_R1001dump_1005_3_ -- Dump a particular format
2827
2828 ffesttFormatList f;
2829 ffestd_R1001dump_1005_3_(f,"I");
2830
2831 The format is dumped with form [r]Xw[.m]. */
2832
2833 static void
2834 ffestd_R1001dump_1005_3_ (ffests s, ffesttFormatList f, const char *string)
2835 {
2836 assert (!f->u.R1005.R1009.present);
2837 assert (f->u.R1005.R1006.present);
2838
2839 if (f->u.R1005.R1004.present)
2840 {
2841 if (f->u.R1005.R1004.rtexpr)
2842 ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr);
2843 else
2844 ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
2845 }
2846
2847 ffests_puts (s, string);
2848
2849 if (f->u.R1005.R1006.rtexpr)
2850 ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr);
2851 else
2852 ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
2853
2854 if (f->u.R1005.R1007_or_R1008.present)
2855 {
2856 ffests_putc (s, '.');
2857 if (f->u.R1005.R1007_or_R1008.rtexpr)
2858 ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1007_or_R1008.u.expr);
2859 else
2860 ffests_printf (s, "%lu", f->u.R1005.R1007_or_R1008.u.unsigned_val);
2861 }
2862 }
2863
2864 /* ffestd_R1001dump_1005_4_ -- Dump a particular format
2865
2866 ffesttFormatList f;
2867 ffestd_R1001dump_1005_4_(f,"I");
2868
2869 The format is dumped with form [r]Xw.d. */
2870
2871 static void
2872 ffestd_R1001dump_1005_4_ (ffests s, ffesttFormatList f, const char *string)
2873 {
2874 assert (!f->u.R1005.R1009.present);
2875 assert (f->u.R1005.R1007_or_R1008.present);
2876 assert (f->u.R1005.R1006.present);
2877
2878 if (f->u.R1005.R1004.present)
2879 {
2880 if (f->u.R1005.R1004.rtexpr)
2881 ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr);
2882 else
2883 ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
2884 }
2885
2886 ffests_puts (s, string);
2887
2888 if (f->u.R1005.R1006.rtexpr)
2889 ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr);
2890 else
2891 ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
2892
2893 ffests_putc (s, '.');
2894 if (f->u.R1005.R1007_or_R1008.rtexpr)
2895 ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1007_or_R1008.u.expr);
2896 else
2897 ffests_printf (s, "%lu", f->u.R1005.R1007_or_R1008.u.unsigned_val);
2898 }
2899
2900 /* ffestd_R1001dump_1005_5_ -- Dump a particular format
2901
2902 ffesttFormatList f;
2903 ffestd_R1001dump_1005_5_(f,"I");
2904
2905 The format is dumped with form [r]Xw.d[Ee]. */
2906
2907 static void
2908 ffestd_R1001dump_1005_5_ (ffests s, ffesttFormatList f, const char *string)
2909 {
2910 assert (f->u.R1005.R1007_or_R1008.present);
2911 assert (f->u.R1005.R1006.present);
2912
2913 if (f->u.R1005.R1004.present)
2914 {
2915 if (f->u.R1005.R1004.rtexpr)
2916 ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr);
2917 else
2918 ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
2919 }
2920
2921 ffests_puts (s, string);
2922
2923 if (f->u.R1005.R1006.rtexpr)
2924 ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr);
2925 else
2926 ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
2927
2928 ffests_putc (s, '.');
2929 if (f->u.R1005.R1007_or_R1008.rtexpr)
2930 ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1007_or_R1008.u.expr);
2931 else
2932 ffests_printf (s, "%lu", f->u.R1005.R1007_or_R1008.u.unsigned_val);
2933
2934 if (f->u.R1005.R1009.present)
2935 {
2936 ffests_putc (s, 'E');
2937 if (f->u.R1005.R1009.rtexpr)
2938 ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1009.u.expr);
2939 else
2940 ffests_printf (s, "%lu", f->u.R1005.R1009.u.unsigned_val);
2941 }
2942 }
2943
2944 /* ffestd_R1001dump_1010_1_ -- Dump a particular format
2945
2946 ffesttFormatList f;
2947 ffestd_R1001dump_1010_1_(f,"I");
2948
2949 The format is dumped with form X. */
2950
2951 static void
2952 ffestd_R1001dump_1010_1_ (ffests s, ffesttFormatList f, const char *string)
2953 {
2954 assert (!f->u.R1010.val.present);
2955
2956 ffests_puts (s, string);
2957 }
2958
2959 /* ffestd_R1001dump_1010_2_ -- Dump a particular format
2960
2961 ffesttFormatList f;
2962 ffestd_R1001dump_1010_2_(f,"I");
2963
2964 The format is dumped with form [r]X. */
2965
2966 static void
2967 ffestd_R1001dump_1010_2_ (ffests s, ffesttFormatList f, const char *string)
2968 {
2969 if (f->u.R1010.val.present)
2970 {
2971 if (f->u.R1010.val.rtexpr)
2972 ffestd_R1001rtexpr_ (s, f, f->u.R1010.val.u.expr);
2973 else
2974 ffests_printf (s, "%lu", f->u.R1010.val.u.unsigned_val);
2975 }
2976
2977 ffests_puts (s, string);
2978 }
2979
2980 /* ffestd_R1001dump_1010_4_ -- Dump a particular format
2981
2982 ffesttFormatList f;
2983 ffestd_R1001dump_1010_4_(f,"I");
2984
2985 The format is dumped with form kX. Note that k is signed. */
2986
2987 static void
2988 ffestd_R1001dump_1010_4_ (ffests s, ffesttFormatList f, const char *string)
2989 {
2990 assert (f->u.R1010.val.present);
2991
2992 if (f->u.R1010.val.rtexpr)
2993 ffestd_R1001rtexpr_ (s, f, f->u.R1010.val.u.expr);
2994 else
2995 ffests_printf (s, "%ld", f->u.R1010.val.u.signed_val);
2996
2997 ffests_puts (s, string);
2998 }
2999
3000 /* ffestd_R1001dump_1010_5_ -- Dump a particular format
3001
3002 ffesttFormatList f;
3003 ffestd_R1001dump_1010_5_(f,"I");
3004
3005 The format is dumped with form Xn. */
3006
3007 static void
3008 ffestd_R1001dump_1010_5_ (ffests s, ffesttFormatList f, const char *string)
3009 {
3010 assert (f->u.R1010.val.present);
3011
3012 ffests_puts (s, string);
3013
3014 if (f->u.R1010.val.rtexpr)
3015 ffestd_R1001rtexpr_ (s, f, f->u.R1010.val.u.expr);
3016 else
3017 ffests_printf (s, "%lu", f->u.R1010.val.u.unsigned_val);
3018 }
3019
3020 /* ffestd_R1001error_ -- Complain about FORMAT specification not supported
3021
3022 ffesttFormatList f;
3023 ffestd_R1001error_(f);
3024
3025 An error message is produced. */
3026
3027 static void
3028 ffestd_R1001error_ (ffesttFormatList f)
3029 {
3030 ffebad_start (FFEBAD_FORMAT_UNSUPPORTED);
3031 ffebad_here (0, ffelex_token_where_line (f->t), ffelex_token_where_column (f->t));
3032 ffebad_finish ();
3033 }
3034
3035 static void
3036 ffestd_R1001rtexpr_ (ffests s, ffesttFormatList f, ffebld expr)
3037 {
3038 if ((expr == NULL)
3039 || (ffebld_op (expr) != FFEBLD_opCONTER)
3040 || (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeINTEGER)
3041 || (ffeinfo_kindtype (ffebld_info (expr)) == FFEINFO_kindtypeINTEGER4))
3042 {
3043 ffebad_start (FFEBAD_FORMAT_VARIABLE);
3044 ffebad_here (0, ffelex_token_where_line (f->t), ffelex_token_where_column (f->t));
3045 ffebad_finish ();
3046 }
3047 else
3048 {
3049 int val;
3050
3051 switch (ffeinfo_kindtype (ffebld_info (expr)))
3052 {
3053 #if FFETARGET_okINTEGER1
3054 case FFEINFO_kindtypeINTEGER1:
3055 val = ffebld_constant_integer1 (ffebld_conter (expr));
3056 break;
3057 #endif
3058
3059 #if FFETARGET_okINTEGER2
3060 case FFEINFO_kindtypeINTEGER2:
3061 val = ffebld_constant_integer2 (ffebld_conter (expr));
3062 break;
3063 #endif
3064
3065 #if FFETARGET_okINTEGER3
3066 case FFEINFO_kindtypeINTEGER3:
3067 val = ffebld_constant_integer3 (ffebld_conter (expr));
3068 break;
3069 #endif
3070
3071 default:
3072 assert ("bad INTEGER constant kind type" == NULL);
3073 /* Fall through. */
3074 case FFEINFO_kindtypeANY:
3075 return;
3076 }
3077 ffests_printf (s, "%ld", (long) val);
3078 }
3079 }
3080
3081 /* ffestd_R1102 -- PROGRAM statement
3082
3083 ffestd_R1102(name_token);
3084
3085 Make sure ffestd_kind_ identifies an empty block. Make sure name_token
3086 gives a valid name. Implement the beginning of a main program. */
3087
3088 void
3089 ffestd_R1102 (ffesymbol s, ffelexToken name UNUSED)
3090 {
3091 ffestd_check_simple_ ();
3092
3093 assert (ffestd_block_level_ == 0);
3094 ffestd_is_reachable_ = TRUE;
3095
3096 ffecom_notify_primary_entry (s);
3097 ffe_set_is_mainprog (TRUE); /* Is a main program. */
3098 ffe_set_is_saveall (TRUE); /* Main program always has implicit SAVE. */
3099
3100 ffestw_set_sym (ffestw_stack_top (), s);
3101 }
3102
3103 /* ffestd_R1103 -- End a PROGRAM
3104
3105 ffestd_R1103(); */
3106
3107 void
3108 ffestd_R1103 (bool ok UNUSED)
3109 {
3110 ffestdStmt_ stmt;
3111
3112 assert (ffestd_block_level_ == 0);
3113
3114 if (FFESTD_IS_END_OPTIMIZED_ && ffestd_is_reachable_)
3115 ffestd_R842 (NULL); /* Generate STOP. */
3116
3117 if (ffestw_state (ffestw_stack_top ()) != FFESTV_statePROGRAM5)
3118 ffestd_subr_labels_ (FALSE);/* Handle any undefined labels. */
3119
3120 stmt = ffestd_stmt_new_ (FFESTD_stmtidR1103_);
3121 ffestd_stmt_append_ (stmt);
3122 }
3123
3124 /* ffestd_R1111 -- BLOCK DATA statement
3125
3126 ffestd_R1111(name_token);
3127
3128 Make sure ffestd_kind_ identifies no current program unit. If not
3129 NULL, make sure name_token gives a valid name. Implement the beginning
3130 of a block data program unit. */
3131
3132 void
3133 ffestd_R1111 (ffesymbol s, ffelexToken name UNUSED)
3134 {
3135 assert (ffestd_block_level_ == 0);
3136 ffestd_is_reachable_ = TRUE;
3137
3138 ffestd_check_simple_ ();
3139
3140 ffecom_notify_primary_entry (s);
3141 ffestw_set_sym (ffestw_stack_top (), s);
3142 }
3143
3144 /* ffestd_R1112 -- End a BLOCK DATA
3145
3146 ffestd_R1112(TRUE); */
3147
3148 void
3149 ffestd_R1112 (bool ok UNUSED)
3150 {
3151 ffestdStmt_ stmt;
3152
3153 assert (ffestd_block_level_ == 0);
3154
3155 /* Generate any return-like code here (not likely for BLOCK DATA!). */
3156
3157 if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateBLOCKDATA5)
3158 ffestd_subr_labels_ (TRUE); /* Handle any undefined labels. */
3159
3160 stmt = ffestd_stmt_new_ (FFESTD_stmtidR1112_);
3161 ffestd_stmt_append_ (stmt);
3162 }
3163
3164 /* ffestd_R1207_start -- EXTERNAL statement list begin
3165
3166 ffestd_R1207_start();
3167
3168 Verify that EXTERNAL is valid here, and begin accepting items in the list. */
3169
3170 void
3171 ffestd_R1207_start ()
3172 {
3173 ffestd_check_start_ ();
3174 }
3175
3176 /* ffestd_R1207_item -- EXTERNAL statement for name
3177
3178 ffestd_R1207_item(name_token);
3179
3180 Make sure name_token identifies a valid object to be EXTERNALd. */
3181
3182 void
3183 ffestd_R1207_item (ffelexToken name)
3184 {
3185 ffestd_check_item_ ();
3186 assert (name != NULL);
3187 }
3188
3189 /* ffestd_R1207_finish -- EXTERNAL statement list complete
3190
3191 ffestd_R1207_finish();
3192
3193 Just wrap up any local activities. */
3194
3195 void
3196 ffestd_R1207_finish ()
3197 {
3198 ffestd_check_finish_ ();
3199 }
3200
3201 /* ffestd_R1208_start -- INTRINSIC statement list begin
3202
3203 ffestd_R1208_start();
3204
3205 Verify that INTRINSIC is valid here, and begin accepting items in the list. */
3206
3207 void
3208 ffestd_R1208_start ()
3209 {
3210 ffestd_check_start_ ();
3211 }
3212
3213 /* ffestd_R1208_item -- INTRINSIC statement for name
3214
3215 ffestd_R1208_item(name_token);
3216
3217 Make sure name_token identifies a valid object to be INTRINSICd. */
3218
3219 void
3220 ffestd_R1208_item (ffelexToken name)
3221 {
3222 ffestd_check_item_ ();
3223 assert (name != NULL);
3224 }
3225
3226 /* ffestd_R1208_finish -- INTRINSIC statement list complete
3227
3228 ffestd_R1208_finish();
3229
3230 Just wrap up any local activities. */
3231
3232 void
3233 ffestd_R1208_finish ()
3234 {
3235 ffestd_check_finish_ ();
3236 }
3237
3238 /* ffestd_R1212 -- CALL statement
3239
3240 ffestd_R1212(expr,expr_token);
3241
3242 Make sure statement is valid here; implement. */
3243
3244 void
3245 ffestd_R1212 (ffebld expr)
3246 {
3247 ffestdStmt_ stmt;
3248
3249 ffestd_check_simple_ ();
3250
3251 stmt = ffestd_stmt_new_ (FFESTD_stmtidR1212_);
3252 ffestd_stmt_append_ (stmt);
3253 ffestd_subr_line_save_ (stmt);
3254 stmt->u.R1212.pool = ffesta_output_pool;
3255 stmt->u.R1212.expr = expr;
3256 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3257 }
3258
3259 /* ffestd_R1219 -- FUNCTION statement
3260
3261 ffestd_R1219(funcname,arglist,ending_token,kind,kindt,len,lent,
3262 recursive);
3263
3264 Make sure statement is valid here, register arguments for the
3265 function name, and so on.
3266
3267 06-Jun-90 JCB 2.0
3268 Added the kind, len, and recursive arguments. */
3269
3270 void
3271 ffestd_R1219 (ffesymbol s, ffelexToken funcname UNUSED,
3272 ffesttTokenList args UNUSED, ffestpType type UNUSED,
3273 ffebld kind UNUSED, ffelexToken kindt UNUSED,
3274 ffebld len UNUSED, ffelexToken lent UNUSED,
3275 bool recursive UNUSED, ffelexToken result UNUSED,
3276 bool separate_result UNUSED)
3277 {
3278 assert (ffestd_block_level_ == 0);
3279 ffestd_is_reachable_ = TRUE;
3280
3281 ffestd_check_simple_ ();
3282
3283 ffecom_notify_primary_entry (s);
3284 ffestw_set_sym (ffestw_stack_top (), s);
3285 }
3286
3287 /* ffestd_R1221 -- End a FUNCTION
3288
3289 ffestd_R1221(TRUE); */
3290
3291 void
3292 ffestd_R1221 (bool ok UNUSED)
3293 {
3294 ffestdStmt_ stmt;
3295
3296 assert (ffestd_block_level_ == 0);
3297
3298 if (FFESTD_IS_END_OPTIMIZED_ && ffestd_is_reachable_)
3299 ffestd_R1227 (NULL); /* Generate RETURN. */
3300
3301 if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateFUNCTION5)
3302 ffestd_subr_labels_ (FALSE);/* Handle any undefined labels. */
3303
3304 stmt = ffestd_stmt_new_ (FFESTD_stmtidR1221_);
3305 ffestd_stmt_append_ (stmt);
3306 }
3307
3308 /* ffestd_R1223 -- SUBROUTINE statement
3309
3310 ffestd_R1223(subrname,arglist,ending_token,recursive_token);
3311
3312 Make sure statement is valid here, register arguments for the
3313 subroutine name, and so on.
3314
3315 06-Jun-90 JCB 2.0
3316 Added the recursive argument. */
3317
3318 void
3319 ffestd_R1223 (ffesymbol s, ffelexToken subrname UNUSED,
3320 ffesttTokenList args UNUSED, ffelexToken final UNUSED,
3321 bool recursive UNUSED)
3322 {
3323 assert (ffestd_block_level_ == 0);
3324 ffestd_is_reachable_ = TRUE;
3325
3326 ffestd_check_simple_ ();
3327
3328 ffecom_notify_primary_entry (s);
3329 ffestw_set_sym (ffestw_stack_top (), s);
3330 }
3331
3332 /* ffestd_R1225 -- End a SUBROUTINE
3333
3334 ffestd_R1225(TRUE); */
3335
3336 void
3337 ffestd_R1225 (bool ok UNUSED)
3338 {
3339 ffestdStmt_ stmt;
3340
3341 assert (ffestd_block_level_ == 0);
3342
3343 if (FFESTD_IS_END_OPTIMIZED_ && ffestd_is_reachable_)
3344 ffestd_R1227 (NULL); /* Generate RETURN. */
3345
3346 if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateSUBROUTINE5)
3347 ffestd_subr_labels_ (FALSE);/* Handle any undefined labels. */
3348
3349 stmt = ffestd_stmt_new_ (FFESTD_stmtidR1225_);
3350 ffestd_stmt_append_ (stmt);
3351 }
3352
3353 /* ffestd_R1226 -- ENTRY statement
3354
3355 ffestd_R1226(entryname,arglist,ending_token);
3356
3357 Make sure we're in a SUBROUTINE or FUNCTION, register arguments for the
3358 entry point name, and so on. */
3359
3360 void
3361 ffestd_R1226 (ffesymbol entry)
3362 {
3363 ffestd_check_simple_ ();
3364
3365 if (!ffesta_seen_first_exec || ffecom_2pass_advise_entrypoint (entry))
3366 {
3367 ffestdStmt_ stmt;
3368
3369 stmt = ffestd_stmt_new_ (FFESTD_stmtidR1226_);
3370 ffestd_stmt_append_ (stmt);
3371 ffestd_subr_line_save_ (stmt);
3372 stmt->u.R1226.entry = entry;
3373 stmt->u.R1226.entrynum = ++ffestd_2pass_entrypoints_;
3374 }
3375
3376 ffestd_is_reachable_ = TRUE;
3377 }
3378
3379 /* ffestd_R1227 -- RETURN statement
3380
3381 ffestd_R1227(expr);
3382
3383 Make sure statement is valid here; implement. expr and expr_token are
3384 both NULL if there was no expression. */
3385
3386 void
3387 ffestd_R1227 (ffebld expr)
3388 {
3389 ffestdStmt_ stmt;
3390
3391 ffestd_check_simple_ ();
3392
3393 stmt = ffestd_stmt_new_ (FFESTD_stmtidR1227_);
3394 ffestd_stmt_append_ (stmt);
3395 ffestd_subr_line_save_ (stmt);
3396 stmt->u.R1227.pool = ffesta_output_pool;
3397 stmt->u.R1227.block = ffestw_stack_top ();
3398 stmt->u.R1227.expr = expr;
3399 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3400
3401 if (ffestd_block_level_ == 0)
3402 ffestd_is_reachable_ = FALSE;
3403 }
3404
3405 /* ffestd_R1229_start -- STMTFUNCTION statement begin
3406
3407 ffestd_R1229_start(func_name,func_arg_list,close_paren);
3408
3409 This function does not really need to do anything, since _finish_
3410 gets all the info needed, and ffestc_R1229_start has already
3411 done all the stuff that makes a two-phase operation (start and
3412 finish) for handling statement functions necessary.
3413
3414 03-Jan-91 JCB 2.0
3415 Do nothing, now that _finish_ does everything. */
3416
3417 void
3418 ffestd_R1229_start (ffelexToken name UNUSED, ffesttTokenList args UNUSED)
3419 {
3420 ffestd_check_start_ ();
3421 }
3422
3423 /* ffestd_R1229_finish -- STMTFUNCTION statement list complete
3424
3425 ffestd_R1229_finish(s);
3426
3427 The statement function's symbol is passed. Its list of dummy args is
3428 accessed via ffesymbol_dummyargs and its expansion expression (expr)
3429 is accessed via ffesymbol_sfexpr.
3430
3431 If sfexpr is NULL, an error occurred parsing the expansion expression, so
3432 just cancel the effects of ffestd_R1229_start and pretend nothing
3433 happened. Otherwise, install the expression as the expansion for the
3434 statement function, then clean up.
3435
3436 03-Jan-91 JCB 2.0
3437 Takes sfunc sym instead of just the expansion expression as an
3438 argument, so this function can do all the work, and _start_ is just
3439 a nicety than can do nothing in a back end. */
3440
3441 void
3442 ffestd_R1229_finish (ffesymbol s)
3443 {
3444 ffebld expr = ffesymbol_sfexpr (s);
3445
3446 ffestd_check_finish_ ();
3447
3448 if (expr == NULL)
3449 return; /* Nothing to do, definition didn't work. */
3450
3451 /* With gcc, cannot do anything here, because the backend hasn't even
3452 (necessarily) been notified that we're compiling a program unit! */
3453 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3454 }
3455
3456 /* ffestd_S3P4 -- INCLUDE line
3457
3458 ffestd_S3P4(filename,filename_token);
3459
3460 Make sure INCLUDE not preceded by any semicolons or a label def; implement. */
3461
3462 void
3463 ffestd_S3P4 (ffebld filename)
3464 {
3465 FILE *fi;
3466 ffetargetCharacterDefault buildname;
3467 ffewhereFile wf;
3468
3469 ffestd_check_simple_ ();
3470
3471 assert (filename != NULL);
3472 if (ffebld_op (filename) != FFEBLD_opANY)
3473 {
3474 assert (ffebld_op (filename) == FFEBLD_opCONTER);
3475 assert (ffeinfo_basictype (ffebld_info (filename))
3476 == FFEINFO_basictypeCHARACTER);
3477 assert (ffeinfo_kindtype (ffebld_info (filename))
3478 == FFEINFO_kindtypeCHARACTERDEFAULT);
3479 buildname = ffebld_constant_characterdefault (ffebld_conter (filename));
3480 wf = ffewhere_file_new (ffetarget_text_characterdefault (buildname),
3481 ffetarget_length_characterdefault (buildname));
3482 fi = ffecom_open_include (ffewhere_file_name (wf),
3483 ffelex_token_where_line (ffesta_tokens[0]),
3484 ffelex_token_where_column (ffesta_tokens[0]));
3485 if (fi != NULL)
3486 ffelex_set_include (wf, (ffelex_token_type (ffesta_tokens[0])
3487 == FFELEX_typeNAME), fi);
3488 }
3489 }
3490
3491 /* ffestd_V014_start -- VOLATILE statement list begin
3492
3493 ffestd_V014_start();
3494
3495 Verify that VOLATILE is valid here, and begin accepting items in the list. */
3496
3497 void
3498 ffestd_V014_start ()
3499 {
3500 ffestd_check_start_ ();
3501 }
3502
3503 /* ffestd_V014_item_object -- VOLATILE statement for object-name
3504
3505 ffestd_V014_item_object(name_token);
3506
3507 Make sure name_token identifies a valid object to be VOLATILEd. */
3508
3509 void
3510 ffestd_V014_item_object (ffelexToken name UNUSED)
3511 {
3512 ffestd_check_item_ ();
3513 }
3514
3515 /* ffestd_V014_item_cblock -- VOLATILE statement for common-block-name
3516
3517 ffestd_V014_item_cblock(name_token);
3518
3519 Make sure name_token identifies a valid common block to be VOLATILEd. */
3520
3521 void
3522 ffestd_V014_item_cblock (ffelexToken name UNUSED)
3523 {
3524 ffestd_check_item_ ();
3525 }
3526
3527 /* ffestd_V014_finish -- VOLATILE statement list complete
3528
3529 ffestd_V014_finish();
3530
3531 Just wrap up any local activities. */
3532
3533 void
3534 ffestd_V014_finish ()
3535 {
3536 ffestd_check_finish_ ();
3537 }
3538
3539 /* ffestd_V020_start -- TYPE statement list begin
3540
3541 ffestd_V020_start();
3542
3543 Verify that TYPE is valid here, and begin accepting items in the
3544 list. */
3545
3546 void
3547 ffestd_V020_start (ffestvFormat format UNUSED)
3548 {
3549 ffestd_check_start_ ();
3550 ffestd_subr_vxt_ ();
3551 }
3552
3553 /* ffestd_V020_item -- TYPE statement i/o item
3554
3555 ffestd_V020_item(expr,expr_token);
3556
3557 Implement output-list expression. */
3558
3559 void
3560 ffestd_V020_item (ffebld expr UNUSED)
3561 {
3562 ffestd_check_item_ ();
3563 }
3564
3565 /* ffestd_V020_finish -- TYPE statement list complete
3566
3567 ffestd_V020_finish();
3568
3569 Just wrap up any local activities. */
3570
3571 void
3572 ffestd_V020_finish ()
3573 {
3574 ffestd_check_finish_ ();
3575 }
3576
3577 /* ffestd_V027_start -- VXT PARAMETER statement list begin
3578
3579 ffestd_V027_start();
3580
3581 Verify that PARAMETER is valid here, and begin accepting items in the list. */
3582
3583 void
3584 ffestd_V027_start ()
3585 {
3586 ffestd_check_start_ ();
3587 ffestd_subr_vxt_ ();
3588 }
3589
3590 /* ffestd_V027_item -- VXT PARAMETER statement assignment
3591
3592 ffestd_V027_item(dest,dest_token,source,source_token);
3593
3594 Make sure the source is a valid source for the destination; make the
3595 assignment. */
3596
3597 void
3598 ffestd_V027_item (ffelexToken dest_token UNUSED, ffebld source UNUSED)
3599 {
3600 ffestd_check_item_ ();
3601 }
3602
3603 /* ffestd_V027_finish -- VXT PARAMETER statement list complete
3604
3605 ffestd_V027_finish();
3606
3607 Just wrap up any local activities. */
3608
3609 void
3610 ffestd_V027_finish ()
3611 {
3612 ffestd_check_finish_ ();
3613 }
3614
3615 /* Any executable statement. */
3616
3617 void
3618 ffestd_any ()
3619 {
3620 ffestdStmt_ stmt;
3621
3622 ffestd_check_simple_ ();
3623
3624 stmt = ffestd_stmt_new_ (FFESTD_stmtidR841_);
3625 ffestd_stmt_append_ (stmt);
3626 ffestd_subr_line_save_ (stmt);
3627 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org