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.
5 This file is part of GNU Fortran.
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)
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.
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
26 Implements the various statements and such like.
30 Split out actual code generation to ffeste.
53 /* Externals defined here. */
56 /* Simple definitions and enumerations. */
58 #define FFESTD_COPY_EASY_ 1 /* 1 for only one _subr_copy_xyz_ fn. */
60 #define FFESTD_IS_END_OPTIMIZED_ 1 /* 0=always gen STOP/RETURN before
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. */
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 */
122 /* Internal typedefs. */
124 typedef struct _ffestd_expr_item_
*ffestdExprItem_
;
125 typedef struct _ffestd_stmt_
*ffestdStmt_
;
127 /* Private include files. */
130 /* Internal structure definitions. */
132 struct _ffestd_expr_item_
134 ffestdExprItem_ next
;
142 ffestdStmt_ previous
;
211 unsigned long casenum
;
226 ffelexToken start_token
;
228 ffelexToken end_token
;
230 ffelexToken incr_token
;
301 ffestpOpenStmt
*params
;
307 ffestpCloseStmt
*params
;
313 ffestpReadStmt
*params
;
319 ffestdExprItem_ list
;
325 ffestpWriteStmt
*params
;
329 ffestdExprItem_ list
;
335 ffestpPrintStmt
*params
;
337 ffestdExprItem_ list
;
343 ffestpBeruStmt
*params
;
349 ffestpBeruStmt
*params
;
355 ffestpBeruStmt
*params
;
361 ffestpInquireStmt
*params
;
368 ffestpInquireStmt
*params
;
369 ffestdExprItem_ list
;
399 ffestpTypeStmt
*params
;
401 ffestdExprItem_ list
;
408 /* Static objects accessed by functions in this module. */
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_
;
426 /* # ENTRY statements pending. */
427 static int ffestd_2pass_entrypoints_
= 0;
429 /* Static functions (internal). */
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
);
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
,
442 static void ffestd_R1001dump_1005_2_ (ffests s
, ffesttFormatList f
,
444 static void ffestd_R1001dump_1005_3_ (ffests s
, ffesttFormatList f
,
446 static void ffestd_R1001dump_1005_4_ (ffests s
, ffesttFormatList f
,
448 static void ffestd_R1001dump_1005_5_ (ffests s
, ffesttFormatList f
,
450 static void ffestd_R1001dump_1010_1_ (ffests s
, ffesttFormatList f
,
452 static void ffestd_R1001dump_1010_2_ (ffests s
, ffesttFormatList f
,
454 static void ffestd_R1001dump_1010_4_ (ffests s
, ffesttFormatList f
,
456 static void ffestd_R1001dump_1010_5_ (ffests s
, ffesttFormatList f
,
458 static void ffestd_R1001error_ (ffesttFormatList f
);
459 static void ffestd_R1001rtexpr_ (ffests s
, ffesttFormatList f
, ffebld expr
);
461 /* Internal macros. */
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_
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)
525 /* ffestd_stmt_append_ -- Append statement to end of stmt list
527 ffestd_stmt_append_(ffestd_stmt_new_(FFESTD_stmtidR737A_)); */
530 ffestd_stmt_append_ (ffestdStmt_ stmt
)
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
;
538 /* ffestd_stmt_new_ -- Make new statement with given id
541 stmt = ffestd_stmt_new_(FFESTD_stmtidR737A_); */
544 ffestd_stmt_new_ (ffestdStmtId_ id
)
548 stmt
= malloc_new_kp (ffe_pool_any_unit (), "ffestdStmt_", sizeof (*stmt
));
553 /* ffestd_stmt_pass_ -- Pass all statements on list to ffeste
555 ffestd_stmt_pass_(); */
558 ffestd_stmt_pass_ (void)
561 ffestdExprItem_ expr
; /* For traversing lists. */
562 bool okay
= (TREE_CODE (current_function_decl
) != ERROR_MARK
);
564 if ((ffestd_2pass_entrypoints_
!= 0) && okay
)
566 tree which
= ffecom_which_entrypoint_decl ();
570 int ents
= ffestd_2pass_entrypoints_
;
573 expand_start_case (0, which
, TREE_TYPE (which
), "entrypoint dispatch");
575 stmt
= ffestd_stmt_list_
.first
;
578 while (stmt
->id
!= FFESTD_stmtidR1226_
)
581 if (stmt
->u
.R1226
.entry
!= NULL
)
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
587 label
= build_decl (LABEL_DECL
, NULL_TREE
, NULL_TREE
);
589 pushok
= pushcase (value
, convert
, label
, &duplicate
);
590 assert (pushok
== 0);
592 label
= ffecom_temp_label ();
593 TREE_USED (label
) = 1;
596 ffesymbol_hook (stmt
->u
.R1226
.entry
).length_tree
= label
;
602 expand_end_case (which
);
605 for (stmt
= ffestd_stmt_list_
.first
;
606 stmt
!= (ffestdStmt_
) &ffestd_stmt_list_
.first
;
611 case FFESTD_stmtidENDDOLOOP_
:
612 ffestd_subr_line_restore_ (stmt
);
614 ffeste_do (stmt
->u
.enddoloop
.block
);
615 ffestw_kill (stmt
->u
.enddoloop
.block
);
618 case FFESTD_stmtidENDLOGIF_
:
619 ffestd_subr_line_restore_ (stmt
);
624 case FFESTD_stmtidEXECLABEL_
:
626 ffeste_labeldef_branch (stmt
->u
.execlabel
.label
);
629 case FFESTD_stmtidFORMATLABEL_
:
631 ffeste_labeldef_format (stmt
->u
.formatlabel
.label
);
634 case FFESTD_stmtidR737A_
:
635 ffestd_subr_line_restore_ (stmt
);
637 ffeste_R737A (stmt
->u
.R737A
.dest
, stmt
->u
.R737A
.source
);
638 malloc_pool_kill (stmt
->u
.R737A
.pool
);
641 case FFESTD_stmtidR803_
:
642 ffestd_subr_line_restore_ (stmt
);
644 ffeste_R803 (stmt
->u
.R803
.block
, stmt
->u
.R803
.expr
);
645 malloc_pool_kill (stmt
->u
.R803
.pool
);
648 case FFESTD_stmtidR804_
:
649 ffestd_subr_line_restore_ (stmt
);
651 ffeste_R804 (stmt
->u
.R803
.block
, stmt
->u
.R804
.expr
);
652 malloc_pool_kill (stmt
->u
.R804
.pool
);
655 case FFESTD_stmtidR805_
:
656 ffestd_subr_line_restore_ (stmt
);
658 ffeste_R805 (stmt
->u
.R803
.block
);
661 case FFESTD_stmtidR806_
:
662 ffestd_subr_line_restore_ (stmt
);
664 ffeste_R806 (stmt
->u
.R806
.block
);
665 ffestw_kill (stmt
->u
.R806
.block
);
668 case FFESTD_stmtidR807_
:
669 ffestd_subr_line_restore_ (stmt
);
671 ffeste_R807 (stmt
->u
.R807
.expr
);
672 malloc_pool_kill (stmt
->u
.R807
.pool
);
675 case FFESTD_stmtidR809_
:
676 ffestd_subr_line_restore_ (stmt
);
678 ffeste_R809 (stmt
->u
.R809
.block
, stmt
->u
.R809
.expr
);
679 malloc_pool_kill (stmt
->u
.R809
.pool
);
682 case FFESTD_stmtidR810_
:
683 ffestd_subr_line_restore_ (stmt
);
685 ffeste_R810 (stmt
->u
.R810
.block
, stmt
->u
.R810
.casenum
);
686 malloc_pool_kill (stmt
->u
.R810
.pool
);
689 case FFESTD_stmtidR811_
:
690 ffestd_subr_line_restore_ (stmt
);
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
);
697 case FFESTD_stmtidR819A_
:
698 ffestd_subr_line_restore_ (stmt
);
700 ffeste_R819A (stmt
->u
.R819A
.block
, stmt
->u
.R819A
.label
,
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
);
712 case FFESTD_stmtidR819B_
:
713 ffestd_subr_line_restore_ (stmt
);
715 ffeste_R819B (stmt
->u
.R819B
.block
, stmt
->u
.R819B
.label
,
717 malloc_pool_kill (stmt
->u
.R819B
.pool
);
720 case FFESTD_stmtidR825_
:
721 ffestd_subr_line_restore_ (stmt
);
726 case FFESTD_stmtidR834_
:
727 ffestd_subr_line_restore_ (stmt
);
729 ffeste_R834 (stmt
->u
.R834
.block
);
732 case FFESTD_stmtidR835_
:
733 ffestd_subr_line_restore_ (stmt
);
735 ffeste_R835 (stmt
->u
.R835
.block
);
738 case FFESTD_stmtidR836_
:
739 ffestd_subr_line_restore_ (stmt
);
741 ffeste_R836 (stmt
->u
.R836
.label
);
744 case FFESTD_stmtidR837_
:
745 ffestd_subr_line_restore_ (stmt
);
747 ffeste_R837 (stmt
->u
.R837
.labels
, stmt
->u
.R837
.count
,
749 malloc_pool_kill (stmt
->u
.R837
.pool
);
752 case FFESTD_stmtidR838_
:
753 ffestd_subr_line_restore_ (stmt
);
755 ffeste_R838 (stmt
->u
.R838
.label
, stmt
->u
.R838
.target
);
756 malloc_pool_kill (stmt
->u
.R838
.pool
);
759 case FFESTD_stmtidR839_
:
760 ffestd_subr_line_restore_ (stmt
);
762 ffeste_R839 (stmt
->u
.R839
.target
);
763 malloc_pool_kill (stmt
->u
.R839
.pool
);
766 case FFESTD_stmtidR840_
:
767 ffestd_subr_line_restore_ (stmt
);
769 ffeste_R840 (stmt
->u
.R840
.expr
, stmt
->u
.R840
.neg
, stmt
->u
.R840
.zero
,
771 malloc_pool_kill (stmt
->u
.R840
.pool
);
774 case FFESTD_stmtidR841_
:
775 ffestd_subr_line_restore_ (stmt
);
780 case FFESTD_stmtidR842_
:
781 ffestd_subr_line_restore_ (stmt
);
783 ffeste_R842 (stmt
->u
.R842
.expr
);
784 if (stmt
->u
.R842
.pool
!= NULL
)
785 malloc_pool_kill (stmt
->u
.R842
.pool
);
788 case FFESTD_stmtidR843_
:
789 ffestd_subr_line_restore_ (stmt
);
791 ffeste_R843 (stmt
->u
.R843
.expr
);
792 malloc_pool_kill (stmt
->u
.R843
.pool
);
795 case FFESTD_stmtidR904_
:
796 ffestd_subr_line_restore_ (stmt
);
798 ffeste_R904 (stmt
->u
.R904
.params
);
799 malloc_pool_kill (stmt
->u
.R904
.pool
);
802 case FFESTD_stmtidR907_
:
803 ffestd_subr_line_restore_ (stmt
);
805 ffeste_R907 (stmt
->u
.R907
.params
);
806 malloc_pool_kill (stmt
->u
.R907
.pool
);
809 case FFESTD_stmtidR909_
:
810 ffestd_subr_line_restore_ (stmt
);
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
)
818 ffeste_R909_item (expr
->expr
, expr
->token
);
819 ffelex_token_kill (expr
->token
);
822 ffeste_R909_finish ();
823 malloc_pool_kill (stmt
->u
.R909
.pool
);
826 case FFESTD_stmtidR910_
:
827 ffestd_subr_line_restore_ (stmt
);
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
)
834 ffeste_R910_item (expr
->expr
, expr
->token
);
835 ffelex_token_kill (expr
->token
);
838 ffeste_R910_finish ();
839 malloc_pool_kill (stmt
->u
.R910
.pool
);
842 case FFESTD_stmtidR911_
:
843 ffestd_subr_line_restore_ (stmt
);
845 ffeste_R911_start (stmt
->u
.R911
.params
, stmt
->u
.R911
.format
);
846 for (expr
= stmt
->u
.R911
.list
; expr
!= NULL
; expr
= expr
->next
)
849 ffeste_R911_item (expr
->expr
, expr
->token
);
850 ffelex_token_kill (expr
->token
);
853 ffeste_R911_finish ();
854 malloc_pool_kill (stmt
->u
.R911
.pool
);
857 case FFESTD_stmtidR919_
:
858 ffestd_subr_line_restore_ (stmt
);
860 ffeste_R919 (stmt
->u
.R919
.params
);
861 malloc_pool_kill (stmt
->u
.R919
.pool
);
864 case FFESTD_stmtidR920_
:
865 ffestd_subr_line_restore_ (stmt
);
867 ffeste_R920 (stmt
->u
.R920
.params
);
868 malloc_pool_kill (stmt
->u
.R920
.pool
);
871 case FFESTD_stmtidR921_
:
872 ffestd_subr_line_restore_ (stmt
);
874 ffeste_R921 (stmt
->u
.R921
.params
);
875 malloc_pool_kill (stmt
->u
.R921
.pool
);
878 case FFESTD_stmtidR923A_
:
879 ffestd_subr_line_restore_ (stmt
);
881 ffeste_R923A (stmt
->u
.R923A
.params
, stmt
->u
.R923A
.by_file
);
882 malloc_pool_kill (stmt
->u
.R923A
.pool
);
885 case FFESTD_stmtidR923B_
:
886 ffestd_subr_line_restore_ (stmt
);
888 ffeste_R923B_start (stmt
->u
.R923B
.params
);
889 for (expr
= stmt
->u
.R923B
.list
; expr
!= NULL
; expr
= expr
->next
)
892 ffeste_R923B_item (expr
->expr
);
895 ffeste_R923B_finish ();
896 malloc_pool_kill (stmt
->u
.R923B
.pool
);
899 case FFESTD_stmtidR1001_
:
901 ffeste_R1001 (&stmt
->u
.R1001
.str
);
902 ffests_kill (&stmt
->u
.R1001
.str
);
905 case FFESTD_stmtidR1103_
:
910 case FFESTD_stmtidR1112_
:
915 case FFESTD_stmtidR1212_
:
916 ffestd_subr_line_restore_ (stmt
);
918 ffeste_R1212 (stmt
->u
.R1212
.expr
);
919 malloc_pool_kill (stmt
->u
.R1212
.pool
);
922 case FFESTD_stmtidR1221_
:
927 case FFESTD_stmtidR1225_
:
932 case FFESTD_stmtidR1226_
:
933 ffestd_subr_line_restore_ (stmt
);
934 if (stmt
->u
.R1226
.entry
!= NULL
)
937 ffeste_R1226 (stmt
->u
.R1226
.entry
);
941 case FFESTD_stmtidR1227_
:
942 ffestd_subr_line_restore_ (stmt
);
944 ffeste_R1227 (stmt
->u
.R1227
.block
, stmt
->u
.R1227
.expr
);
945 malloc_pool_kill (stmt
->u
.R1227
.pool
);
948 case FFESTD_stmtidV020_
:
949 ffestd_subr_line_restore_ (stmt
);
951 ffeste_V020_start (stmt
->u
.V020
.params
, stmt
->u
.V020
.format
);
952 for (expr
= stmt
->u
.V020
.list
; expr
!= NULL
; expr
= expr
->next
)
955 ffeste_V020_item (expr
->expr
);
958 ffeste_V020_finish ();
959 malloc_pool_kill (stmt
->u
.V020
.pool
);
963 assert ("bad stmt->id" == NULL
);
969 /* ffestd_subr_copy_easy_ -- Copy I/O statement data structure
971 ffestd_subr_copy_easy_();
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. */
980 #if FFESTD_COPY_EASY_
981 static ffestpInquireStmt
*
982 ffestd_subr_copy_easy_ (ffestpInquireIx max
)
984 ffestpInquireStmt
*stmt
;
987 stmt
= malloc_new_kp (ffesta_output_pool
, "FFESTD easy",
988 sizeof (ffestpFile
) * max
);
990 for (ix
= 0; ix
< max
; ++ix
)
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
))
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
;
1002 stmt
->inquire_spec
[ix
].u
.expr
1003 = ffestp_file
.inquire
.inquire_spec
[ix
].u
.expr
;
1011 /* ffestd_subr_labels_ -- Handle any undefined labels
1013 ffestd_subr_labels_(FALSE);
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). */
1020 ffestd_subr_labels_ (bool unexpected
)
1027 undef
= ffelab_number () - ffestv_num_label_defines_
;
1029 for (h
= ffelab_handle_first (); h
!= NULL
; h
= ffelab_handle_next (h
))
1031 l
= ffelab_handle_target (h
);
1032 if (ffewhere_line_is_unknown (ffelab_definition_line (l
)))
1033 { /* Undefined label. */
1034 assert (!unexpected
);
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
));
1047 ffebad_here (0, ffelab_definition_line (l
), ffelab_definition_column (l
));
1050 switch (ffelab_type (l
))
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
);
1061 ffestt_formatlist_kill (f
);
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
);
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
);
1088 assert ("bad label type" == NULL
);
1090 case FFELAB_typeUNKNOWN
:
1091 case FFELAB_typeANY
:
1096 ffelab_handle_done (h
);
1097 assert (undef
== 0);
1100 /* ffestd_subr_vxt_ -- Report error about lack of full VXT support
1102 ffestd_subr_vxt_(); */
1105 ffestd_subr_vxt_ (void)
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]));
1113 /* ffestd_begin_uses -- Start a bunch of USE statements
1115 ffestd_begin_uses();
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). */
1124 ffestd_begin_uses (void)
1128 /* ffestd_do -- End of statement following DO-term-stmt etc
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. */
1139 ffestd_do (bool ok UNUSED
)
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 ();
1148 --ffestd_block_level_
;
1149 assert (ffestd_block_level_
>= 0);
1152 /* ffestd_end_R807 -- End of statement following logical IF
1154 ffestd_end_R807(TRUE);
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_(). */
1163 ffestd_end_R807 (bool ok UNUSED
)
1167 stmt
= ffestd_stmt_new_ (FFESTD_stmtidENDLOGIF_
);
1168 ffestd_stmt_append_ (stmt
);
1169 ffestd_subr_line_save_ (stmt
);
1171 --ffestd_block_level_
;
1172 assert (ffestd_block_level_
>= 0);
1175 /* ffestd_exec_begin -- Executable statements can start coming in now
1177 ffestd_exec_begin(); */
1180 ffestd_exec_begin (void)
1182 ffecom_exec_transition ();
1184 if (ffestd_2pass_entrypoints_
!= 0)
1185 { /* Process pending ENTRY statements now that
1188 int ents
= ffestd_2pass_entrypoints_
;
1190 stmt
= ffestd_stmt_list_
.first
;
1193 while (stmt
->id
!= FFESTD_stmtidR1226_
)
1196 if (!ffecom_2pass_advise_entrypoint (stmt
->u
.R1226
.entry
))
1198 stmt
->u
.R1226
.entry
= NULL
;
1199 --ffestd_2pass_entrypoints_
;
1203 while (--ents
!= 0);
1207 /* ffestd_exec_end -- Executable statements can no longer come in now
1209 ffestd_exec_end(); */
1212 ffestd_exec_end (void)
1214 location_t old_loc
= input_location
;
1216 ffecom_end_transition ();
1218 ffestd_stmt_pass_ ();
1220 ffecom_finish_progunit ();
1222 if (ffestd_2pass_entrypoints_
!= 0)
1224 int ents
= ffestd_2pass_entrypoints_
;
1225 ffestdStmt_ stmt
= ffestd_stmt_list_
.first
;
1229 while (stmt
->id
!= FFESTD_stmtidR1226_
)
1232 if (stmt
->u
.R1226
.entry
!= NULL
)
1234 ffestd_subr_line_restore_ (stmt
);
1235 ffecom_2pass_do_entrypoint (stmt
->u
.R1226
.entry
);
1239 while (--ents
!= 0);
1242 ffestd_stmt_list_
.first
= NULL
;
1243 ffestd_stmt_list_
.last
= NULL
;
1244 ffestd_2pass_entrypoints_
= 0;
1246 input_location
= old_loc
;
1249 /* ffestd_init_3 -- Initialize for any program unit
1254 ffestd_init_3 (void)
1256 ffestd_stmt_list_
.first
= (ffestdStmt_
) &ffestd_stmt_list_
.first
;
1257 ffestd_stmt_list_
.last
= (ffestdStmt_
) &ffestd_stmt_list_
.first
;
1260 /* Generate "code" for "any" label def. */
1263 ffestd_labeldef_any (ffelab label UNUSED
)
1267 /* ffestd_labeldef_branch -- Generate "code" for branch label def
1269 ffestd_labeldef_branch(label); */
1272 ffestd_labeldef_branch (ffelab label
)
1276 stmt
= ffestd_stmt_new_ (FFESTD_stmtidEXECLABEL_
);
1277 ffestd_stmt_append_ (stmt
);
1278 stmt
->u
.execlabel
.label
= label
;
1280 ffestd_is_reachable_
= TRUE
;
1283 /* ffestd_labeldef_format -- Generate "code" for FORMAT label def
1285 ffestd_labeldef_format(label); */
1288 ffestd_labeldef_format (ffelab label
)
1292 ffestd_label_formatdef_
= label
;
1294 stmt
= ffestd_stmt_new_ (FFESTD_stmtidFORMATLABEL_
);
1295 ffestd_stmt_append_ (stmt
);
1296 stmt
->u
.formatlabel
.label
= label
;
1299 /* ffestd_labeldef_useless -- Generate "code" for useless label def
1301 ffestd_labeldef_useless(label); */
1304 ffestd_labeldef_useless (ffelab label UNUSED
)
1308 /* ffestd_R522 -- SAVE statement with no list
1312 Verify that SAVE is valid here, and flag everything as SAVEd. */
1317 ffestd_check_simple_ ();
1320 /* ffestd_R522start -- SAVE statement list begin
1324 Verify that SAVE is valid here, and begin accepting items in the list. */
1327 ffestd_R522start (void)
1329 ffestd_check_start_ ();
1332 /* ffestd_R522item_object -- SAVE statement for object-name
1334 ffestd_R522item_object(name_token);
1336 Make sure name_token identifies a valid object to be SAVEd. */
1339 ffestd_R522item_object (ffelexToken name UNUSED
)
1341 ffestd_check_item_ ();
1344 /* ffestd_R522item_cblock -- SAVE statement for common-block-name
1346 ffestd_R522item_cblock(name_token);
1348 Make sure name_token identifies a valid common block to be SAVEd. */
1351 ffestd_R522item_cblock (ffelexToken name UNUSED
)
1353 ffestd_check_item_ ();
1356 /* ffestd_R522finish -- SAVE statement list complete
1358 ffestd_R522finish();
1360 Just wrap up any local activities. */
1363 ffestd_R522finish (void)
1365 ffestd_check_finish_ ();
1368 /* ffestd_R524_start -- DIMENSION statement list begin
1370 ffestd_R524_start(bool virtual);
1372 Verify that DIMENSION is valid here, and begin accepting items in the list. */
1375 ffestd_R524_start (bool virtual UNUSED
)
1377 ffestd_check_start_ ();
1380 /* ffestd_R524_item -- DIMENSION statement for object-name
1382 ffestd_R524_item(name_token,dim_list);
1384 Make sure name_token identifies a valid object to be DIMENSIONd. */
1387 ffestd_R524_item (ffelexToken name UNUSED
, ffesttDimList dims UNUSED
)
1389 ffestd_check_item_ ();
1392 /* ffestd_R524_finish -- DIMENSION statement list complete
1394 ffestd_R524_finish();
1396 Just wrap up any local activities. */
1399 ffestd_R524_finish (void)
1401 ffestd_check_finish_ ();
1404 /* ffestd_R537_start -- PARAMETER statement list begin
1406 ffestd_R537_start();
1408 Verify that PARAMETER is valid here, and begin accepting items in the list. */
1411 ffestd_R537_start (void)
1413 ffestd_check_start_ ();
1416 /* ffestd_R537_item -- PARAMETER statement assignment
1418 ffestd_R537_item(dest,dest_token,source,source_token);
1420 Make sure the source is a valid source for the destination; make the
1424 ffestd_R537_item (ffebld dest UNUSED
, ffebld source UNUSED
)
1426 ffestd_check_item_ ();
1429 /* ffestd_R537_finish -- PARAMETER statement list complete
1431 ffestd_R537_finish();
1433 Just wrap up any local activities. */
1436 ffestd_R537_finish (void)
1438 ffestd_check_finish_ ();
1441 /* ffestd_R539 -- IMPLICIT NONE statement
1445 Verify that the IMPLICIT NONE statement is ok here and implement. */
1450 ffestd_check_simple_ ();
1453 /* ffestd_R539start -- IMPLICIT statement
1457 Verify that the IMPLICIT statement is ok here and implement. */
1460 ffestd_R539start (void)
1462 ffestd_check_start_ ();
1465 /* ffestd_R539item -- IMPLICIT statement specification (R540)
1467 ffestd_R539item(...);
1469 Verify that the type and letter list are all ok and implement. */
1472 ffestd_R539item (ffestpType type UNUSED
, ffebld kind UNUSED
,
1473 ffelexToken kindt UNUSED
, ffebld len UNUSED
,
1474 ffelexToken lent UNUSED
, ffesttImpList letters UNUSED
)
1476 ffestd_check_item_ ();
1479 /* ffestd_R539finish -- IMPLICIT statement
1481 ffestd_R539finish();
1483 Finish up any local activities. */
1486 ffestd_R539finish (void)
1488 ffestd_check_finish_ ();
1491 /* ffestd_R542_start -- NAMELIST statement list begin
1493 ffestd_R542_start();
1495 Verify that NAMELIST is valid here, and begin accepting items in the list. */
1498 ffestd_R542_start (void)
1500 ffestd_check_start_ ();
1503 /* ffestd_R542_item_nlist -- NAMELIST statement for group-name
1505 ffestd_R542_item_nlist(groupname_token);
1507 Make sure name_token identifies a valid object to be NAMELISTd. */
1510 ffestd_R542_item_nlist (ffelexToken name UNUSED
)
1512 ffestd_check_item_ ();
1515 /* ffestd_R542_item_nitem -- NAMELIST statement for variable-name
1517 ffestd_R542_item_nitem(name_token);
1519 Make sure name_token identifies a valid object to be NAMELISTd. */
1522 ffestd_R542_item_nitem (ffelexToken name UNUSED
)
1524 ffestd_check_item_ ();
1527 /* ffestd_R542_finish -- NAMELIST statement list complete
1529 ffestd_R542_finish();
1531 Just wrap up any local activities. */
1534 ffestd_R542_finish (void)
1536 ffestd_check_finish_ ();
1539 /* ffestd_R547_start -- COMMON statement list begin
1541 ffestd_R547_start();
1543 Verify that COMMON is valid here, and begin accepting items in the list. */
1546 ffestd_R547_start (void)
1548 ffestd_check_start_ ();
1551 /* ffestd_R547_item_object -- COMMON statement for object-name
1553 ffestd_R547_item_object(name_token,dim_list);
1555 Make sure name_token identifies a valid object to be COMMONd. */
1558 ffestd_R547_item_object (ffelexToken name UNUSED
,
1559 ffesttDimList dims UNUSED
)
1561 ffestd_check_item_ ();
1564 /* ffestd_R547_item_cblock -- COMMON statement for common-block-name
1566 ffestd_R547_item_cblock(name_token);
1568 Make sure name_token identifies a valid common block to be COMMONd. */
1571 ffestd_R547_item_cblock (ffelexToken name UNUSED
)
1573 ffestd_check_item_ ();
1576 /* ffestd_R547_finish -- COMMON statement list complete
1578 ffestd_R547_finish();
1580 Just wrap up any local activities. */
1583 ffestd_R547_finish (void)
1585 ffestd_check_finish_ ();
1588 /* ffestd_R737A -- Assignment statement outside of WHERE
1590 ffestd_R737A(dest_expr,source_expr); */
1593 ffestd_R737A (ffebld dest
, ffebld source
)
1597 ffestd_check_simple_ ();
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
);
1609 /* Block IF (IF-THEN) statement. */
1612 ffestd_R803 (ffelexToken construct_name UNUSED
, ffebld expr
)
1616 ffestd_check_simple_ ();
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
);
1626 ++ffestd_block_level_
;
1627 assert (ffestd_block_level_
> 0);
1630 /* ELSE IF statement. */
1633 ffestd_R804 (ffebld expr
, ffelexToken name UNUSED
)
1637 ffestd_check_simple_ ();
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
);
1648 /* ELSE statement. */
1651 ffestd_R805 (ffelexToken name UNUSED
)
1655 ffestd_check_simple_ ();
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 ());
1663 /* END IF statement. */
1666 ffestd_R806 (bool ok UNUSED
)
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 ());
1675 --ffestd_block_level_
;
1676 assert (ffestd_block_level_
>= 0);
1679 /* ffestd_R807 -- Logical IF statement
1681 ffestd_R807(expr,expr_token);
1683 Make sure statement is valid here; implement. */
1686 ffestd_R807 (ffebld expr
)
1690 ffestd_check_simple_ ();
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
);
1699 ++ffestd_block_level_
;
1700 assert (ffestd_block_level_
> 0);
1703 /* ffestd_R809 -- SELECT CASE statement
1705 ffestd_R809(construct_name,expr,expr_token);
1707 Make sure statement is valid here; implement. */
1710 ffestd_R809 (ffelexToken construct_name UNUSED
, ffebld expr
)
1714 ffestd_check_simple_ ();
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
);
1725 ++ffestd_block_level_
;
1726 assert (ffestd_block_level_
> 0);
1729 /* ffestd_R810 -- CASE statement
1731 ffestd_R810(case_value_range_list,name);
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. */
1738 ffestd_R810 (unsigned long casenum
)
1742 ffestd_check_simple_ ();
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
);
1753 /* ffestd_R811 -- End a SELECT
1755 ffestd_R811(TRUE); */
1758 ffestd_R811 (bool ok UNUSED
)
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 ();
1767 --ffestd_block_level_
;
1768 assert (ffestd_block_level_
>= 0);
1771 /* ffestd_R819A -- Iterative DO statement
1773 ffestd_R819A(construct_name,label_token,expr,expr_token);
1775 Make sure statement is valid here; implement. */
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
)
1785 ffestd_check_simple_ ();
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
);
1803 ++ffestd_block_level_
;
1804 assert (ffestd_block_level_
> 0);
1807 /* ffestd_R819B -- DO WHILE statement
1809 ffestd_R819B(construct_name,label_token,expr,expr_token);
1811 Make sure statement is valid here; implement. */
1814 ffestd_R819B (ffelexToken construct_name UNUSED
, ffelab label
,
1819 ffestd_check_simple_ ();
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
);
1830 ++ffestd_block_level_
;
1831 assert (ffestd_block_level_
> 0);
1834 /* ffestd_R825 -- END DO statement
1836 ffestd_R825(name_token);
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. */
1846 ffestd_R825 (ffelexToken name UNUSED
)
1850 ffestd_check_simple_ ();
1852 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR825_
);
1853 ffestd_stmt_append_ (stmt
);
1854 ffestd_subr_line_save_ (stmt
);
1857 /* ffestd_R834 -- CYCLE statement
1859 ffestd_R834(name_token);
1861 Handle a CYCLE within a loop. */
1864 ffestd_R834 (ffestw block
)
1868 ffestd_check_simple_ ();
1870 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR834_
);
1871 ffestd_stmt_append_ (stmt
);
1872 ffestd_subr_line_save_ (stmt
);
1873 stmt
->u
.R834
.block
= block
;
1876 /* ffestd_R835 -- EXIT statement
1878 ffestd_R835(name_token);
1880 Handle a EXIT within a loop. */
1883 ffestd_R835 (ffestw block
)
1887 ffestd_check_simple_ ();
1889 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR835_
);
1890 ffestd_stmt_append_ (stmt
);
1891 ffestd_subr_line_save_ (stmt
);
1892 stmt
->u
.R835
.block
= block
;
1895 /* ffestd_R836 -- GOTO statement
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. */
1903 ffestd_R836 (ffelab label
)
1907 ffestd_check_simple_ ();
1909 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR836_
);
1910 ffestd_stmt_append_ (stmt
);
1911 ffestd_subr_line_save_ (stmt
);
1912 stmt
->u
.R836
.label
= label
;
1914 if (ffestd_block_level_
== 0)
1915 ffestd_is_reachable_
= FALSE
;
1918 /* ffestd_R837 -- Computed GOTO statement
1920 ffestd_R837(labels,expr);
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. */
1926 ffestd_R837 (ffelab
*labels
, int count
, ffebld expr
)
1930 ffestd_check_simple_ ();
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
);
1942 /* ffestd_R838 -- ASSIGN statement
1944 ffestd_R838(label_token,target_variable,target_token);
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
1952 ffestd_R838 (ffelab label
, ffebld target
)
1956 ffestd_check_simple_ ();
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
);
1967 /* ffestd_R839 -- Assigned GOTO statement
1969 ffestd_R839(target,labels);
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. */
1975 ffestd_R839 (ffebld target
, ffelab
*labels UNUSED
, int count UNUSED
)
1979 ffestd_check_simple_ ();
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
);
1988 if (ffestd_block_level_
== 0)
1989 ffestd_is_reachable_
= FALSE
;
1992 /* ffestd_R840 -- Arithmetic IF statement
1994 ffestd_R840(expr,expr_token,neg,zero,pos);
1996 Make sure the labels are valid; implement. */
1999 ffestd_R840 (ffebld expr
, ffelab neg
, ffelab zero
, ffelab pos
)
2003 ffestd_check_simple_ ();
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
);
2015 if (ffestd_block_level_
== 0)
2016 ffestd_is_reachable_
= FALSE
;
2019 /* ffestd_R841 -- CONTINUE statement
2024 ffestd_R841 (bool in_where UNUSED
)
2028 ffestd_check_simple_ ();
2030 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR841_
);
2031 ffestd_stmt_append_ (stmt
);
2032 ffestd_subr_line_save_ (stmt
);
2035 /* ffestd_R842 -- STOP statement
2037 ffestd_R842(expr); */
2040 ffestd_R842 (ffebld expr
)
2044 ffestd_check_simple_ ();
2046 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR842_
);
2047 ffestd_stmt_append_ (stmt
);
2048 ffestd_subr_line_save_ (stmt
);
2049 if (ffesta_outpooldisp () == FFESTA_pooldispPRESERVE
)
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
;
2061 stmt
->u
.R842
.pool
= ffesta_output_pool
;
2062 stmt
->u
.R842
.expr
= expr
;
2063 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE
);
2066 if (ffestd_block_level_
== 0)
2067 ffestd_is_reachable_
= FALSE
;
2070 /* ffestd_R843 -- PAUSE statement
2072 ffestd_R843(expr,expr_token);
2074 Make sure statement is valid here; implement. expr and expr_token are
2075 both NULL if there was no expression. */
2078 ffestd_R843 (ffebld expr
)
2082 ffestd_check_simple_ ();
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
);
2092 /* ffestd_R904 -- OPEN statement
2096 Make sure an OPEN is valid in the current context, and implement it. */
2103 ffestd_check_simple_ ();
2105 #define specified(something) \
2106 (ffestp_file.open.open_spec[something].kw_or_val_present)
2108 /* Warn if there are any thing we don't handle via f2c libraries. */
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
))
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]));
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
);
2147 /* ffestd_R907 -- CLOSE statement
2151 Make sure a CLOSE is valid in the current context, and implement it. */
2158 ffestd_check_simple_ ();
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
);
2168 /* ffestd_R909_start -- READ(...) statement list begin
2170 ffestd_R909_start(FALSE);
2172 Verify that READ is valid here, and begin accepting items in the
2176 ffestd_R909_start (bool only_format
, ffestvUnit unit
,
2177 ffestvFormat format
, bool rec
, bool key
)
2181 ffestd_check_start_ ();
2183 #define specified(something) \
2184 (ffestp_file.read.read_spec[something].kw_or_val_present)
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
))
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]));
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
);
2219 /* ffestd_R909_item -- READ statement i/o item
2221 ffestd_R909_item(expr,expr_token);
2223 Implement output-list expression. */
2226 ffestd_R909_item (ffebld expr
, ffelexToken expr_token
)
2228 ffestdExprItem_ item
;
2230 ffestd_check_item_ ();
2232 item
= malloc_new_kp (ffesta_output_pool
, "ffestdExprItem_", sizeof (*item
));
2236 item
->token
= ffelex_token_use (expr_token
);
2237 *ffestd_expr_list_
= item
;
2238 ffestd_expr_list_
= &item
->next
;
2241 /* ffestd_R909_finish -- READ statement list complete
2243 ffestd_R909_finish();
2245 Just wrap up any local activities. */
2248 ffestd_R909_finish (void)
2250 ffestd_check_finish_ ();
2253 /* ffestd_R910_start -- WRITE(...) statement list begin
2255 ffestd_R910_start();
2257 Verify that WRITE is valid here, and begin accepting items in the
2261 ffestd_R910_start (ffestvUnit unit
, ffestvFormat format
, bool rec
)
2265 ffestd_check_start_ ();
2267 #define specified(something) \
2268 (ffestp_file.write.write_spec[something].kw_or_val_present)
2270 /* Warn if there are any thing we don't handle via f2c libraries. */
2271 if (specified (FFESTP_writeixADVANCE
)
2272 || specified (FFESTP_writeixEOR
))
2274 ffebad_start (FFEBAD_WRITE_UNSUPPORTED
);
2275 ffebad_here (0, ffelex_token_where_line (ffesta_tokens
[0]),
2276 ffelex_token_where_column (ffesta_tokens
[0]));
2282 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR910_
);
2283 ffestd_stmt_append_ (stmt
);
2284 ffestd_subr_line_save_ (stmt
);
2285 stmt
->u
.R910
.pool
= ffesta_output_pool
;
2286 stmt
->u
.R910
.params
= ffestd_subr_copy_write_ ();
2287 stmt
->u
.R910
.unit
= unit
;
2288 stmt
->u
.R910
.format
= format
;
2289 stmt
->u
.R910
.rec
= rec
;
2290 stmt
->u
.R910
.list
= NULL
;
2291 ffestd_expr_list_
= &stmt
->u
.R910
.list
;
2292 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE
);
2295 /* ffestd_R910_item -- WRITE statement i/o item
2297 ffestd_R910_item(expr,expr_token);
2299 Implement output-list expression. */
2302 ffestd_R910_item (ffebld expr
, ffelexToken expr_token
)
2304 ffestdExprItem_ item
;
2306 ffestd_check_item_ ();
2308 item
= malloc_new_kp (ffesta_output_pool
, "ffestdExprItem_", sizeof (*item
));
2312 item
->token
= ffelex_token_use (expr_token
);
2313 *ffestd_expr_list_
= item
;
2314 ffestd_expr_list_
= &item
->next
;
2317 /* ffestd_R910_finish -- WRITE statement list complete
2319 ffestd_R910_finish();
2321 Just wrap up any local activities. */
2324 ffestd_R910_finish (void)
2326 ffestd_check_finish_ ();
2329 /* ffestd_R911_start -- PRINT statement list begin
2331 ffestd_R911_start();
2333 Verify that PRINT is valid here, and begin accepting items in the
2337 ffestd_R911_start (ffestvFormat format
)
2341 ffestd_check_start_ ();
2343 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR911_
);
2344 ffestd_stmt_append_ (stmt
);
2345 ffestd_subr_line_save_ (stmt
);
2346 stmt
->u
.R911
.pool
= ffesta_output_pool
;
2347 stmt
->u
.R911
.params
= ffestd_subr_copy_print_ ();
2348 stmt
->u
.R911
.format
= format
;
2349 stmt
->u
.R911
.list
= NULL
;
2350 ffestd_expr_list_
= &stmt
->u
.R911
.list
;
2351 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE
);
2354 /* ffestd_R911_item -- PRINT statement i/o item
2356 ffestd_R911_item(expr,expr_token);
2358 Implement output-list expression. */
2361 ffestd_R911_item (ffebld expr
, ffelexToken expr_token
)
2363 ffestdExprItem_ item
;
2365 ffestd_check_item_ ();
2367 item
= malloc_new_kp (ffesta_output_pool
, "ffestdExprItem_", sizeof (*item
));
2371 item
->token
= ffelex_token_use (expr_token
);
2372 *ffestd_expr_list_
= item
;
2373 ffestd_expr_list_
= &item
->next
;
2376 /* ffestd_R911_finish -- PRINT statement list complete
2378 ffestd_R911_finish();
2380 Just wrap up any local activities. */
2383 ffestd_R911_finish (void)
2385 ffestd_check_finish_ ();
2388 /* ffestd_R919 -- BACKSPACE statement
2392 Make sure a BACKSPACE is valid in the current context, and implement it. */
2399 ffestd_check_simple_ ();
2401 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR919_
);
2402 ffestd_stmt_append_ (stmt
);
2403 ffestd_subr_line_save_ (stmt
);
2404 stmt
->u
.R919
.pool
= ffesta_output_pool
;
2405 stmt
->u
.R919
.params
= ffestd_subr_copy_beru_ ();
2406 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE
);
2409 /* ffestd_R920 -- ENDFILE statement
2413 Make sure a ENDFILE is valid in the current context, and implement it. */
2420 ffestd_check_simple_ ();
2422 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR920_
);
2423 ffestd_stmt_append_ (stmt
);
2424 ffestd_subr_line_save_ (stmt
);
2425 stmt
->u
.R920
.pool
= ffesta_output_pool
;
2426 stmt
->u
.R920
.params
= ffestd_subr_copy_beru_ ();
2427 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE
);
2430 /* ffestd_R921 -- REWIND statement
2434 Make sure a REWIND is valid in the current context, and implement it. */
2441 ffestd_check_simple_ ();
2443 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR921_
);
2444 ffestd_stmt_append_ (stmt
);
2445 ffestd_subr_line_save_ (stmt
);
2446 stmt
->u
.R921
.pool
= ffesta_output_pool
;
2447 stmt
->u
.R921
.params
= ffestd_subr_copy_beru_ ();
2448 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE
);
2451 /* ffestd_R923A -- INQUIRE statement (non-IOLENGTH version)
2453 ffestd_R923A(bool by_file);
2455 Make sure an INQUIRE is valid in the current context, and implement it. */
2458 ffestd_R923A (bool by_file
)
2462 ffestd_check_simple_ ();
2464 #define specified(something) \
2465 (ffestp_file.inquire.inquire_spec[something].kw_or_val_present)
2467 /* Warn if there are any thing we don't handle via f2c libraries. */
2468 if (specified (FFESTP_inquireixACTION
)
2469 || specified (FFESTP_inquireixCARRIAGECONTROL
)
2470 || specified (FFESTP_inquireixDEFAULTFILE
)
2471 || specified (FFESTP_inquireixDELIM
)
2472 || specified (FFESTP_inquireixKEYED
)
2473 || specified (FFESTP_inquireixORGANIZATION
)
2474 || specified (FFESTP_inquireixPAD
)
2475 || specified (FFESTP_inquireixPOSITION
)
2476 || specified (FFESTP_inquireixREAD
)
2477 || specified (FFESTP_inquireixREADWRITE
)
2478 || specified (FFESTP_inquireixRECORDTYPE
)
2479 || specified (FFESTP_inquireixWRITE
))
2481 ffebad_start (FFEBAD_INQUIRE_UNSUPPORTED
);
2482 ffebad_here (0, ffelex_token_where_line (ffesta_tokens
[0]),
2483 ffelex_token_where_column (ffesta_tokens
[0]));
2489 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR923A_
);
2490 ffestd_stmt_append_ (stmt
);
2491 ffestd_subr_line_save_ (stmt
);
2492 stmt
->u
.R923A
.pool
= ffesta_output_pool
;
2493 stmt
->u
.R923A
.params
= ffestd_subr_copy_inquire_ ();
2494 stmt
->u
.R923A
.by_file
= by_file
;
2495 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE
);
2498 /* ffestd_R923B_start -- INQUIRE(IOLENGTH=expr) statement list begin
2500 ffestd_R923B_start();
2502 Verify that INQUIRE is valid here, and begin accepting items in the
2506 ffestd_R923B_start (void)
2510 ffestd_check_start_ ();
2512 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR923B_
);
2513 ffestd_stmt_append_ (stmt
);
2514 ffestd_subr_line_save_ (stmt
);
2515 stmt
->u
.R923B
.pool
= ffesta_output_pool
;
2516 stmt
->u
.R923B
.params
= ffestd_subr_copy_inquire_ ();
2517 stmt
->u
.R923B
.list
= NULL
;
2518 ffestd_expr_list_
= &stmt
->u
.R923B
.list
;
2519 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE
);
2522 /* ffestd_R923B_item -- INQUIRE statement i/o item
2524 ffestd_R923B_item(expr,expr_token);
2526 Implement output-list expression. */
2529 ffestd_R923B_item (ffebld expr
)
2531 ffestdExprItem_ item
;
2533 ffestd_check_item_ ();
2535 item
= malloc_new_kp (ffesta_output_pool
, "ffestdExprItem_", sizeof (*item
));
2539 *ffestd_expr_list_
= item
;
2540 ffestd_expr_list_
= &item
->next
;
2543 /* ffestd_R923B_finish -- INQUIRE statement list complete
2545 ffestd_R923B_finish();
2547 Just wrap up any local activities. */
2550 ffestd_R923B_finish (void)
2552 ffestd_check_finish_ ();
2555 /* ffestd_R1001 -- FORMAT statement
2557 ffestd_R1001(format_list); */
2560 ffestd_R1001 (ffesttFormatList f
)
2566 ffestd_check_simple_ ();
2568 if (ffestd_label_formatdef_
== NULL
)
2569 return; /* Nothing to hook it up to (no label def). */
2571 ffests_new (s
, malloc_pool_image (), 80);
2572 ffests_putc (s
, '(');
2573 ffestd_R1001dump_ (s
, f
); /* Build the string in s. */
2574 ffests_putc (s
, ')');
2576 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR1001_
);
2577 ffestd_stmt_append_ (stmt
);
2578 stmt
->u
.R1001
.str
= str
;
2580 ffestd_label_formatdef_
= NULL
;
2583 /* ffestd_R1001dump_ -- Dump list of formats
2585 ffesttFormatList list;
2586 ffestd_R1001dump_(list,0);
2588 The formats in the list are dumped. */
2591 ffestd_R1001dump_ (ffests s
, ffesttFormatList list
)
2593 ffesttFormatList next
;
2595 for (next
= list
->next
; next
!= list
; next
= next
->next
)
2597 if (next
!= list
->next
)
2598 ffests_putc (s
, ',');
2601 case FFESTP_formattypeI
:
2602 ffestd_R1001dump_1005_3_ (s
, next
, "I");
2605 case FFESTP_formattypeB
:
2606 ffestd_R1001error_ (next
);
2609 case FFESTP_formattypeO
:
2610 ffestd_R1001dump_1005_3_ (s
, next
, "O");
2613 case FFESTP_formattypeZ
:
2614 ffestd_R1001dump_1005_3_ (s
, next
, "Z");
2617 case FFESTP_formattypeF
:
2618 ffestd_R1001dump_1005_4_ (s
, next
, "F");
2621 case FFESTP_formattypeE
:
2622 ffestd_R1001dump_1005_5_ (s
, next
, "E");
2625 case FFESTP_formattypeEN
:
2626 ffestd_R1001error_ (next
);
2629 case FFESTP_formattypeG
:
2630 ffestd_R1001dump_1005_5_ (s
, next
, "G");
2633 case FFESTP_formattypeL
:
2634 ffestd_R1001dump_1005_2_ (s
, next
, "L");
2637 case FFESTP_formattypeA
:
2638 ffestd_R1001dump_1005_1_ (s
, next
, "A");
2641 case FFESTP_formattypeD
:
2642 ffestd_R1001dump_1005_4_ (s
, next
, "D");
2645 case FFESTP_formattypeQ
:
2646 ffestd_R1001error_ (next
);
2649 case FFESTP_formattypeDOLLAR
:
2650 ffestd_R1001dump_1010_1_ (s
, next
, "$");
2653 case FFESTP_formattypeP
:
2654 ffestd_R1001dump_1010_4_ (s
, next
, "P");
2657 case FFESTP_formattypeT
:
2658 ffestd_R1001dump_1010_5_ (s
, next
, "T");
2661 case FFESTP_formattypeTL
:
2662 ffestd_R1001dump_1010_5_ (s
, next
, "TL");
2665 case FFESTP_formattypeTR
:
2666 ffestd_R1001dump_1010_5_ (s
, next
, "TR");
2669 case FFESTP_formattypeX
:
2670 ffestd_R1001dump_1010_2_ (s
, next
, "X");
2673 case FFESTP_formattypeS
:
2674 ffestd_R1001dump_1010_1_ (s
, next
, "S");
2677 case FFESTP_formattypeSP
:
2678 ffestd_R1001dump_1010_1_ (s
, next
, "SP");
2681 case FFESTP_formattypeSS
:
2682 ffestd_R1001dump_1010_1_ (s
, next
, "SS");
2685 case FFESTP_formattypeBN
:
2686 ffestd_R1001dump_1010_1_ (s
, next
, "BN");
2689 case FFESTP_formattypeBZ
:
2690 ffestd_R1001dump_1010_1_ (s
, next
, "BZ");
2693 case FFESTP_formattypeSLASH
:
2694 ffestd_R1001dump_1010_2_ (s
, next
, "/");
2697 case FFESTP_formattypeCOLON
:
2698 ffestd_R1001dump_1010_1_ (s
, next
, ":");
2701 case FFESTP_formattypeR1016
:
2702 switch (ffelex_token_type (next
->t
))
2704 case FFELEX_typeCHARACTER
:
2706 char *p
= ffelex_token_text (next
->t
);
2707 ffeTokenLength i
= ffelex_token_length (next
->t
);
2709 ffests_putc (s
, '\002');
2713 ffests_putc (s
, '\002');
2714 ffests_putc (s
, *p
);
2717 ffests_putc (s
, '\002');
2721 case FFELEX_typeHOLLERITH
:
2723 char *p
= ffelex_token_text (next
->t
);
2724 ffeTokenLength i
= ffelex_token_length (next
->t
);
2726 ffests_printf (s
, "%" ffeTokenLength_f
"uH", i
);
2729 ffests_putc (s
, *p
);
2740 case FFESTP_formattypeFORMAT
:
2741 if (next
->u
.R1003D
.R1004
.present
)
2743 if (next
->u
.R1003D
.R1004
.rtexpr
)
2744 ffestd_R1001rtexpr_ (s
, next
, next
->u
.R1003D
.R1004
.u
.expr
);
2746 ffests_printf (s
, "%lu", next
->u
.R1003D
.R1004
.u
.unsigned_val
);
2749 ffests_putc (s
, '(');
2750 ffestd_R1001dump_ (s
, next
->u
.R1003D
.format
);
2751 ffests_putc (s
, ')');
2760 /* ffestd_R1001dump_1005_1_ -- Dump a particular format
2763 ffestd_R1001dump_1005_1_(f,"I");
2765 The format is dumped with form [r]X[w]. */
2768 ffestd_R1001dump_1005_1_ (ffests s
, ffesttFormatList f
, const char *string
)
2770 assert (!f
->u
.R1005
.R1007_or_R1008
.present
);
2771 assert (!f
->u
.R1005
.R1009
.present
);
2773 if (f
->u
.R1005
.R1004
.present
)
2775 if (f
->u
.R1005
.R1004
.rtexpr
)
2776 ffestd_R1001rtexpr_ (s
, f
, f
->u
.R1005
.R1004
.u
.expr
);
2778 ffests_printf (s
, "%lu", f
->u
.R1005
.R1004
.u
.unsigned_val
);
2781 ffests_puts (s
, string
);
2783 if (f
->u
.R1005
.R1006
.present
)
2785 if (f
->u
.R1005
.R1006
.rtexpr
)
2786 ffestd_R1001rtexpr_ (s
, f
, f
->u
.R1005
.R1006
.u
.expr
);
2788 ffests_printf (s
, "%lu", f
->u
.R1005
.R1006
.u
.unsigned_val
);
2792 /* ffestd_R1001dump_1005_2_ -- Dump a particular format
2795 ffestd_R1001dump_1005_2_(f,"I");
2797 The format is dumped with form [r]Xw. */
2800 ffestd_R1001dump_1005_2_ (ffests s
, ffesttFormatList f
, const char *string
)
2802 assert (!f
->u
.R1005
.R1007_or_R1008
.present
);
2803 assert (!f
->u
.R1005
.R1009
.present
);
2804 assert (f
->u
.R1005
.R1006
.present
);
2806 if (f
->u
.R1005
.R1004
.present
)
2808 if (f
->u
.R1005
.R1004
.rtexpr
)
2809 ffestd_R1001rtexpr_ (s
, f
, f
->u
.R1005
.R1004
.u
.expr
);
2811 ffests_printf (s
, "%lu", f
->u
.R1005
.R1004
.u
.unsigned_val
);
2814 ffests_puts (s
, string
);
2816 if (f
->u
.R1005
.R1006
.rtexpr
)
2817 ffestd_R1001rtexpr_ (s
, f
, f
->u
.R1005
.R1006
.u
.expr
);
2819 ffests_printf (s
, "%lu", f
->u
.R1005
.R1006
.u
.unsigned_val
);
2822 /* ffestd_R1001dump_1005_3_ -- Dump a particular format
2825 ffestd_R1001dump_1005_3_(f,"I");
2827 The format is dumped with form [r]Xw[.m]. */
2830 ffestd_R1001dump_1005_3_ (ffests s
, ffesttFormatList f
, const char *string
)
2832 assert (!f
->u
.R1005
.R1009
.present
);
2833 assert (f
->u
.R1005
.R1006
.present
);
2835 if (f
->u
.R1005
.R1004
.present
)
2837 if (f
->u
.R1005
.R1004
.rtexpr
)
2838 ffestd_R1001rtexpr_ (s
, f
, f
->u
.R1005
.R1004
.u
.expr
);
2840 ffests_printf (s
, "%lu", f
->u
.R1005
.R1004
.u
.unsigned_val
);
2843 ffests_puts (s
, string
);
2845 if (f
->u
.R1005
.R1006
.rtexpr
)
2846 ffestd_R1001rtexpr_ (s
, f
, f
->u
.R1005
.R1006
.u
.expr
);
2848 ffests_printf (s
, "%lu", f
->u
.R1005
.R1006
.u
.unsigned_val
);
2850 if (f
->u
.R1005
.R1007_or_R1008
.present
)
2852 ffests_putc (s
, '.');
2853 if (f
->u
.R1005
.R1007_or_R1008
.rtexpr
)
2854 ffestd_R1001rtexpr_ (s
, f
, f
->u
.R1005
.R1007_or_R1008
.u
.expr
);
2856 ffests_printf (s
, "%lu", f
->u
.R1005
.R1007_or_R1008
.u
.unsigned_val
);
2860 /* ffestd_R1001dump_1005_4_ -- Dump a particular format
2863 ffestd_R1001dump_1005_4_(f,"I");
2865 The format is dumped with form [r]Xw.d. */
2868 ffestd_R1001dump_1005_4_ (ffests s
, ffesttFormatList f
, const char *string
)
2870 assert (!f
->u
.R1005
.R1009
.present
);
2871 assert (f
->u
.R1005
.R1007_or_R1008
.present
);
2872 assert (f
->u
.R1005
.R1006
.present
);
2874 if (f
->u
.R1005
.R1004
.present
)
2876 if (f
->u
.R1005
.R1004
.rtexpr
)
2877 ffestd_R1001rtexpr_ (s
, f
, f
->u
.R1005
.R1004
.u
.expr
);
2879 ffests_printf (s
, "%lu", f
->u
.R1005
.R1004
.u
.unsigned_val
);
2882 ffests_puts (s
, string
);
2884 if (f
->u
.R1005
.R1006
.rtexpr
)
2885 ffestd_R1001rtexpr_ (s
, f
, f
->u
.R1005
.R1006
.u
.expr
);
2887 ffests_printf (s
, "%lu", f
->u
.R1005
.R1006
.u
.unsigned_val
);
2889 ffests_putc (s
, '.');
2890 if (f
->u
.R1005
.R1007_or_R1008
.rtexpr
)
2891 ffestd_R1001rtexpr_ (s
, f
, f
->u
.R1005
.R1007_or_R1008
.u
.expr
);
2893 ffests_printf (s
, "%lu", f
->u
.R1005
.R1007_or_R1008
.u
.unsigned_val
);
2896 /* ffestd_R1001dump_1005_5_ -- Dump a particular format
2899 ffestd_R1001dump_1005_5_(f,"I");
2901 The format is dumped with form [r]Xw.d[Ee]. */
2904 ffestd_R1001dump_1005_5_ (ffests s
, ffesttFormatList f
, const char *string
)
2906 assert (f
->u
.R1005
.R1007_or_R1008
.present
);
2907 assert (f
->u
.R1005
.R1006
.present
);
2909 if (f
->u
.R1005
.R1004
.present
)
2911 if (f
->u
.R1005
.R1004
.rtexpr
)
2912 ffestd_R1001rtexpr_ (s
, f
, f
->u
.R1005
.R1004
.u
.expr
);
2914 ffests_printf (s
, "%lu", f
->u
.R1005
.R1004
.u
.unsigned_val
);
2917 ffests_puts (s
, string
);
2919 if (f
->u
.R1005
.R1006
.rtexpr
)
2920 ffestd_R1001rtexpr_ (s
, f
, f
->u
.R1005
.R1006
.u
.expr
);
2922 ffests_printf (s
, "%lu", f
->u
.R1005
.R1006
.u
.unsigned_val
);
2924 ffests_putc (s
, '.');
2925 if (f
->u
.R1005
.R1007_or_R1008
.rtexpr
)
2926 ffestd_R1001rtexpr_ (s
, f
, f
->u
.R1005
.R1007_or_R1008
.u
.expr
);
2928 ffests_printf (s
, "%lu", f
->u
.R1005
.R1007_or_R1008
.u
.unsigned_val
);
2930 if (f
->u
.R1005
.R1009
.present
)
2932 ffests_putc (s
, 'E');
2933 if (f
->u
.R1005
.R1009
.rtexpr
)
2934 ffestd_R1001rtexpr_ (s
, f
, f
->u
.R1005
.R1009
.u
.expr
);
2936 ffests_printf (s
, "%lu", f
->u
.R1005
.R1009
.u
.unsigned_val
);
2940 /* ffestd_R1001dump_1010_1_ -- Dump a particular format
2943 ffestd_R1001dump_1010_1_(f,"I");
2945 The format is dumped with form X. */
2948 ffestd_R1001dump_1010_1_ (ffests s
, ffesttFormatList f
, const char *string
)
2950 assert (!f
->u
.R1010
.val
.present
);
2952 ffests_puts (s
, string
);
2955 /* ffestd_R1001dump_1010_2_ -- Dump a particular format
2958 ffestd_R1001dump_1010_2_(f,"I");
2960 The format is dumped with form [r]X. */
2963 ffestd_R1001dump_1010_2_ (ffests s
, ffesttFormatList f
, const char *string
)
2965 if (f
->u
.R1010
.val
.present
)
2967 if (f
->u
.R1010
.val
.rtexpr
)
2968 ffestd_R1001rtexpr_ (s
, f
, f
->u
.R1010
.val
.u
.expr
);
2970 ffests_printf (s
, "%lu", f
->u
.R1010
.val
.u
.unsigned_val
);
2973 ffests_puts (s
, string
);
2976 /* ffestd_R1001dump_1010_4_ -- Dump a particular format
2979 ffestd_R1001dump_1010_4_(f,"I");
2981 The format is dumped with form kX. Note that k is signed. */
2984 ffestd_R1001dump_1010_4_ (ffests s
, ffesttFormatList f
, const char *string
)
2986 assert (f
->u
.R1010
.val
.present
);
2988 if (f
->u
.R1010
.val
.rtexpr
)
2989 ffestd_R1001rtexpr_ (s
, f
, f
->u
.R1010
.val
.u
.expr
);
2991 ffests_printf (s
, "%ld", f
->u
.R1010
.val
.u
.signed_val
);
2993 ffests_puts (s
, string
);
2996 /* ffestd_R1001dump_1010_5_ -- Dump a particular format
2999 ffestd_R1001dump_1010_5_(f,"I");
3001 The format is dumped with form Xn. */
3004 ffestd_R1001dump_1010_5_ (ffests s
, ffesttFormatList f
, const char *string
)
3006 assert (f
->u
.R1010
.val
.present
);
3008 ffests_puts (s
, string
);
3010 if (f
->u
.R1010
.val
.rtexpr
)
3011 ffestd_R1001rtexpr_ (s
, f
, f
->u
.R1010
.val
.u
.expr
);
3013 ffests_printf (s
, "%lu", f
->u
.R1010
.val
.u
.unsigned_val
);
3016 /* ffestd_R1001error_ -- Complain about FORMAT specification not supported
3019 ffestd_R1001error_(f);
3021 An error message is produced. */
3024 ffestd_R1001error_ (ffesttFormatList f
)
3026 ffebad_start (FFEBAD_FORMAT_UNSUPPORTED
);
3027 ffebad_here (0, ffelex_token_where_line (f
->t
), ffelex_token_where_column (f
->t
));
3032 ffestd_R1001rtexpr_ (ffests s
, ffesttFormatList f
, ffebld expr
)
3035 || (ffebld_op (expr
) != FFEBLD_opCONTER
)
3036 || (ffeinfo_basictype (ffebld_info (expr
)) != FFEINFO_basictypeINTEGER
)
3037 || (ffeinfo_kindtype (ffebld_info (expr
)) == FFEINFO_kindtypeINTEGER4
))
3039 ffebad_start (FFEBAD_FORMAT_VARIABLE
);
3040 ffebad_here (0, ffelex_token_where_line (f
->t
), ffelex_token_where_column (f
->t
));
3047 switch (ffeinfo_kindtype (ffebld_info (expr
)))
3049 #if FFETARGET_okINTEGER1
3050 case FFEINFO_kindtypeINTEGER1
:
3051 val
= ffebld_constant_integer1 (ffebld_conter (expr
));
3055 #if FFETARGET_okINTEGER2
3056 case FFEINFO_kindtypeINTEGER2
:
3057 val
= ffebld_constant_integer2 (ffebld_conter (expr
));
3061 #if FFETARGET_okINTEGER3
3062 case FFEINFO_kindtypeINTEGER3
:
3063 val
= ffebld_constant_integer3 (ffebld_conter (expr
));
3068 assert ("bad INTEGER constant kind type" == NULL
);
3070 case FFEINFO_kindtypeANY
:
3073 ffests_printf (s
, "%ld", (long) val
);
3077 /* ffestd_R1102 -- PROGRAM statement
3079 ffestd_R1102(name_token);
3081 Make sure ffestd_kind_ identifies an empty block. Make sure name_token
3082 gives a valid name. Implement the beginning of a main program. */
3085 ffestd_R1102 (ffesymbol s
, ffelexToken name UNUSED
)
3087 ffestd_check_simple_ ();
3089 assert (ffestd_block_level_
== 0);
3090 ffestd_is_reachable_
= TRUE
;
3092 ffecom_notify_primary_entry (s
);
3093 ffe_set_is_mainprog (TRUE
); /* Is a main program. */
3094 ffe_set_is_saveall (TRUE
); /* Main program always has implicit SAVE. */
3096 ffestw_set_sym (ffestw_stack_top (), s
);
3099 /* ffestd_R1103 -- End a PROGRAM
3104 ffestd_R1103 (bool ok UNUSED
)
3108 assert (ffestd_block_level_
== 0);
3110 if (FFESTD_IS_END_OPTIMIZED_
&& ffestd_is_reachable_
)
3111 ffestd_R842 (NULL
); /* Generate STOP. */
3113 if (ffestw_state (ffestw_stack_top ()) != FFESTV_statePROGRAM5
)
3114 ffestd_subr_labels_ (FALSE
);/* Handle any undefined labels. */
3116 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR1103_
);
3117 ffestd_stmt_append_ (stmt
);
3120 /* ffestd_R1111 -- BLOCK DATA statement
3122 ffestd_R1111(name_token);
3124 Make sure ffestd_kind_ identifies no current program unit. If not
3125 NULL, make sure name_token gives a valid name. Implement the beginning
3126 of a block data program unit. */
3129 ffestd_R1111 (ffesymbol s
, ffelexToken name UNUSED
)
3131 assert (ffestd_block_level_
== 0);
3132 ffestd_is_reachable_
= TRUE
;
3134 ffestd_check_simple_ ();
3136 ffecom_notify_primary_entry (s
);
3137 ffestw_set_sym (ffestw_stack_top (), s
);
3140 /* ffestd_R1112 -- End a BLOCK DATA
3142 ffestd_R1112(TRUE); */
3145 ffestd_R1112 (bool ok UNUSED
)
3149 assert (ffestd_block_level_
== 0);
3151 /* Generate any return-like code here (not likely for BLOCK DATA!). */
3153 if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateBLOCKDATA5
)
3154 ffestd_subr_labels_ (TRUE
); /* Handle any undefined labels. */
3156 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR1112_
);
3157 ffestd_stmt_append_ (stmt
);
3160 /* ffestd_R1207_start -- EXTERNAL statement list begin
3162 ffestd_R1207_start();
3164 Verify that EXTERNAL is valid here, and begin accepting items in the list. */
3167 ffestd_R1207_start (void)
3169 ffestd_check_start_ ();
3172 /* ffestd_R1207_item -- EXTERNAL statement for name
3174 ffestd_R1207_item(name_token);
3176 Make sure name_token identifies a valid object to be EXTERNALd. */
3179 ffestd_R1207_item (ffelexToken name
)
3181 ffestd_check_item_ ();
3182 assert (name
!= NULL
);
3185 /* ffestd_R1207_finish -- EXTERNAL statement list complete
3187 ffestd_R1207_finish();
3189 Just wrap up any local activities. */
3192 ffestd_R1207_finish (void)
3194 ffestd_check_finish_ ();
3197 /* ffestd_R1208_start -- INTRINSIC statement list begin
3199 ffestd_R1208_start();
3201 Verify that INTRINSIC is valid here, and begin accepting items in the list. */
3204 ffestd_R1208_start (void)
3206 ffestd_check_start_ ();
3209 /* ffestd_R1208_item -- INTRINSIC statement for name
3211 ffestd_R1208_item(name_token);
3213 Make sure name_token identifies a valid object to be INTRINSICd. */
3216 ffestd_R1208_item (ffelexToken name
)
3218 ffestd_check_item_ ();
3219 assert (name
!= NULL
);
3222 /* ffestd_R1208_finish -- INTRINSIC statement list complete
3224 ffestd_R1208_finish();
3226 Just wrap up any local activities. */
3229 ffestd_R1208_finish (void)
3231 ffestd_check_finish_ ();
3234 /* ffestd_R1212 -- CALL statement
3236 ffestd_R1212(expr,expr_token);
3238 Make sure statement is valid here; implement. */
3241 ffestd_R1212 (ffebld expr
)
3245 ffestd_check_simple_ ();
3247 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR1212_
);
3248 ffestd_stmt_append_ (stmt
);
3249 ffestd_subr_line_save_ (stmt
);
3250 stmt
->u
.R1212
.pool
= ffesta_output_pool
;
3251 stmt
->u
.R1212
.expr
= expr
;
3252 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE
);
3255 /* ffestd_R1219 -- FUNCTION statement
3257 ffestd_R1219(funcname,arglist,ending_token,kind,kindt,len,lent,
3260 Make sure statement is valid here, register arguments for the
3261 function name, and so on.
3264 Added the kind, len, and recursive arguments. */
3267 ffestd_R1219 (ffesymbol s
, ffelexToken funcname UNUSED
,
3268 ffesttTokenList args UNUSED
, ffestpType type UNUSED
,
3269 ffebld kind UNUSED
, ffelexToken kindt UNUSED
,
3270 ffebld len UNUSED
, ffelexToken lent UNUSED
,
3271 bool recursive UNUSED
, ffelexToken result UNUSED
,
3272 bool separate_result UNUSED
)
3274 assert (ffestd_block_level_
== 0);
3275 ffestd_is_reachable_
= TRUE
;
3277 ffestd_check_simple_ ();
3279 ffecom_notify_primary_entry (s
);
3280 ffestw_set_sym (ffestw_stack_top (), s
);
3283 /* ffestd_R1221 -- End a FUNCTION
3285 ffestd_R1221(TRUE); */
3288 ffestd_R1221 (bool ok UNUSED
)
3292 assert (ffestd_block_level_
== 0);
3294 if (FFESTD_IS_END_OPTIMIZED_
&& ffestd_is_reachable_
)
3295 ffestd_R1227 (NULL
); /* Generate RETURN. */
3297 if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateFUNCTION5
)
3298 ffestd_subr_labels_ (FALSE
);/* Handle any undefined labels. */
3300 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR1221_
);
3301 ffestd_stmt_append_ (stmt
);
3304 /* ffestd_R1223 -- SUBROUTINE statement
3306 ffestd_R1223(subrname,arglist,ending_token,recursive_token);
3308 Make sure statement is valid here, register arguments for the
3309 subroutine name, and so on.
3312 Added the recursive argument. */
3315 ffestd_R1223 (ffesymbol s
, ffelexToken subrname UNUSED
,
3316 ffesttTokenList args UNUSED
, ffelexToken final UNUSED
,
3317 bool recursive UNUSED
)
3319 assert (ffestd_block_level_
== 0);
3320 ffestd_is_reachable_
= TRUE
;
3322 ffestd_check_simple_ ();
3324 ffecom_notify_primary_entry (s
);
3325 ffestw_set_sym (ffestw_stack_top (), s
);
3328 /* ffestd_R1225 -- End a SUBROUTINE
3330 ffestd_R1225(TRUE); */
3333 ffestd_R1225 (bool ok UNUSED
)
3337 assert (ffestd_block_level_
== 0);
3339 if (FFESTD_IS_END_OPTIMIZED_
&& ffestd_is_reachable_
)
3340 ffestd_R1227 (NULL
); /* Generate RETURN. */
3342 if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateSUBROUTINE5
)
3343 ffestd_subr_labels_ (FALSE
);/* Handle any undefined labels. */
3345 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR1225_
);
3346 ffestd_stmt_append_ (stmt
);
3349 /* ffestd_R1226 -- ENTRY statement
3351 ffestd_R1226(entryname,arglist,ending_token);
3353 Make sure we're in a SUBROUTINE or FUNCTION, register arguments for the
3354 entry point name, and so on. */
3357 ffestd_R1226 (ffesymbol entry
)
3359 ffestd_check_simple_ ();
3361 if (!ffesta_seen_first_exec
|| ffecom_2pass_advise_entrypoint (entry
))
3365 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR1226_
);
3366 ffestd_stmt_append_ (stmt
);
3367 ffestd_subr_line_save_ (stmt
);
3368 stmt
->u
.R1226
.entry
= entry
;
3369 stmt
->u
.R1226
.entrynum
= ++ffestd_2pass_entrypoints_
;
3372 ffestd_is_reachable_
= TRUE
;
3375 /* ffestd_R1227 -- RETURN statement
3379 Make sure statement is valid here; implement. expr and expr_token are
3380 both NULL if there was no expression. */
3383 ffestd_R1227 (ffebld expr
)
3387 ffestd_check_simple_ ();
3389 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR1227_
);
3390 ffestd_stmt_append_ (stmt
);
3391 ffestd_subr_line_save_ (stmt
);
3392 stmt
->u
.R1227
.pool
= ffesta_output_pool
;
3393 stmt
->u
.R1227
.block
= ffestw_stack_top ();
3394 stmt
->u
.R1227
.expr
= expr
;
3395 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE
);
3397 if (ffestd_block_level_
== 0)
3398 ffestd_is_reachable_
= FALSE
;
3401 /* ffestd_R1229_start -- STMTFUNCTION statement begin
3403 ffestd_R1229_start(func_name,func_arg_list,close_paren);
3405 This function does not really need to do anything, since _finish_
3406 gets all the info needed, and ffestc_R1229_start has already
3407 done all the stuff that makes a two-phase operation (start and
3408 finish) for handling statement functions necessary.
3411 Do nothing, now that _finish_ does everything. */
3414 ffestd_R1229_start (ffelexToken name UNUSED
, ffesttTokenList args UNUSED
)
3416 ffestd_check_start_ ();
3419 /* ffestd_R1229_finish -- STMTFUNCTION statement list complete
3421 ffestd_R1229_finish(s);
3423 The statement function's symbol is passed. Its list of dummy args is
3424 accessed via ffesymbol_dummyargs and its expansion expression (expr)
3425 is accessed via ffesymbol_sfexpr.
3427 If sfexpr is NULL, an error occurred parsing the expansion expression, so
3428 just cancel the effects of ffestd_R1229_start and pretend nothing
3429 happened. Otherwise, install the expression as the expansion for the
3430 statement function, then clean up.
3433 Takes sfunc sym instead of just the expansion expression as an
3434 argument, so this function can do all the work, and _start_ is just
3435 a nicety than can do nothing in a back end. */
3438 ffestd_R1229_finish (ffesymbol s
)
3440 ffebld expr
= ffesymbol_sfexpr (s
);
3442 ffestd_check_finish_ ();
3445 return; /* Nothing to do, definition didn't work. */
3447 /* With gcc, cannot do anything here, because the backend hasn't even
3448 (necessarily) been notified that we're compiling a program unit! */
3449 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE
);
3452 /* ffestd_S3P4 -- INCLUDE line
3454 ffestd_S3P4(filename,filename_token);
3456 Make sure INCLUDE not preceded by any semicolons or a label def; implement. */
3459 ffestd_S3P4 (ffebld filename
)
3462 ffetargetCharacterDefault buildname
;
3465 ffestd_check_simple_ ();
3467 assert (filename
!= NULL
);
3468 if (ffebld_op (filename
) != FFEBLD_opANY
)
3470 assert (ffebld_op (filename
) == FFEBLD_opCONTER
);
3471 assert (ffeinfo_basictype (ffebld_info (filename
))
3472 == FFEINFO_basictypeCHARACTER
);
3473 assert (ffeinfo_kindtype (ffebld_info (filename
))
3474 == FFEINFO_kindtypeCHARACTERDEFAULT
);
3475 buildname
= ffebld_constant_characterdefault (ffebld_conter (filename
));
3476 wf
= ffewhere_file_new (ffetarget_text_characterdefault (buildname
),
3477 ffetarget_length_characterdefault (buildname
));
3478 fi
= ffecom_open_include (ffewhere_file_name (wf
),
3479 ffelex_token_where_line (ffesta_tokens
[0]),
3480 ffelex_token_where_column (ffesta_tokens
[0]));
3482 ffelex_set_include (wf
, (ffelex_token_type (ffesta_tokens
[0])
3483 == FFELEX_typeNAME
), fi
);
3487 /* ffestd_V014_start -- VOLATILE statement list begin
3489 ffestd_V014_start();
3491 Verify that VOLATILE is valid here, and begin accepting items in the list. */
3494 ffestd_V014_start (void)
3496 ffestd_check_start_ ();
3499 /* ffestd_V014_item_object -- VOLATILE statement for object-name
3501 ffestd_V014_item_object(name_token);
3503 Make sure name_token identifies a valid object to be VOLATILEd. */
3506 ffestd_V014_item_object (ffelexToken name UNUSED
)
3508 ffestd_check_item_ ();
3511 /* ffestd_V014_item_cblock -- VOLATILE statement for common-block-name
3513 ffestd_V014_item_cblock(name_token);
3515 Make sure name_token identifies a valid common block to be VOLATILEd. */
3518 ffestd_V014_item_cblock (ffelexToken name UNUSED
)
3520 ffestd_check_item_ ();
3523 /* ffestd_V014_finish -- VOLATILE statement list complete
3525 ffestd_V014_finish();
3527 Just wrap up any local activities. */
3530 ffestd_V014_finish (void)
3532 ffestd_check_finish_ ();
3535 /* ffestd_V020_start -- TYPE statement list begin
3537 ffestd_V020_start();
3539 Verify that TYPE is valid here, and begin accepting items in the
3543 ffestd_V020_start (ffestvFormat format UNUSED
)
3545 ffestd_check_start_ ();
3546 ffestd_subr_vxt_ ();
3549 /* ffestd_V020_item -- TYPE statement i/o item
3551 ffestd_V020_item(expr,expr_token);
3553 Implement output-list expression. */
3556 ffestd_V020_item (ffebld expr UNUSED
)
3558 ffestd_check_item_ ();
3561 /* ffestd_V020_finish -- TYPE statement list complete
3563 ffestd_V020_finish();
3565 Just wrap up any local activities. */
3568 ffestd_V020_finish (void)
3570 ffestd_check_finish_ ();
3573 /* ffestd_V027_start -- VXT PARAMETER statement list begin
3575 ffestd_V027_start();
3577 Verify that PARAMETER is valid here, and begin accepting items in the list. */
3580 ffestd_V027_start (void)
3582 ffestd_check_start_ ();
3583 ffestd_subr_vxt_ ();
3586 /* ffestd_V027_item -- VXT PARAMETER statement assignment
3588 ffestd_V027_item(dest,dest_token,source,source_token);
3590 Make sure the source is a valid source for the destination; make the
3594 ffestd_V027_item (ffelexToken dest_token UNUSED
, ffebld source UNUSED
)
3596 ffestd_check_item_ ();
3599 /* ffestd_V027_finish -- VXT PARAMETER statement list complete
3601 ffestd_V027_finish();
3603 Just wrap up any local activities. */
3606 ffestd_V027_finish (void)
3608 ffestd_check_finish_ ();
3611 /* Any executable statement. */
3618 ffestd_check_simple_ ();
3620 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR841_
);
3621 ffestd_stmt_append_ (stmt
);
3622 ffestd_subr_line_save_ (stmt
);