1 /* std.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995, 1996, 2000, 2002 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 */
119 FFESTD_stmtidV018_
, /* REWRITE */
120 FFESTD_stmtidV019_
, /* ACCEPT */
122 FFESTD_stmtidV020_
, /* TYPE */
124 FFESTD_stmtidV021_
, /* DELETE */
125 FFESTD_stmtidV022_
, /* UNLOCK */
126 FFESTD_stmtidV023_
, /* ENCODE */
127 FFESTD_stmtidV024_
, /* DECODE */
128 FFESTD_stmtidV025start_
, /* DEFINEFILE (start) */
129 FFESTD_stmtidV025item_
, /* (DEFINEFILE item) */
130 FFESTD_stmtidV025finish_
, /* (DEFINEFILE finish) */
131 FFESTD_stmtidV026_
, /* FIND */
136 /* Internal typedefs. */
138 typedef struct _ffestd_expr_item_
*ffestdExprItem_
;
139 typedef struct _ffestd_stmt_
*ffestdStmt_
;
141 /* Private include files. */
144 /* Internal structure definitions. */
146 struct _ffestd_expr_item_
148 ffestdExprItem_ next
;
156 ffestdStmt_ previous
;
225 unsigned long casenum
;
240 ffelexToken start_token
;
242 ffelexToken end_token
;
244 ffelexToken incr_token
;
315 ffestpOpenStmt
*params
;
321 ffestpCloseStmt
*params
;
327 ffestpReadStmt
*params
;
333 ffestdExprItem_ list
;
339 ffestpWriteStmt
*params
;
343 ffestdExprItem_ list
;
349 ffestpPrintStmt
*params
;
351 ffestdExprItem_ list
;
357 ffestpBeruStmt
*params
;
363 ffestpBeruStmt
*params
;
369 ffestpBeruStmt
*params
;
375 ffestpInquireStmt
*params
;
382 ffestpInquireStmt
*params
;
383 ffestdExprItem_ list
;
414 ffestpRewriteStmt
*params
;
416 ffestdExprItem_ list
;
422 ffestpAcceptStmt
*params
;
424 ffestdExprItem_ list
;
431 ffestpTypeStmt
*params
;
433 ffestdExprItem_ list
;
440 ffestpDeleteStmt
*params
;
446 ffestpBeruStmt
*params
;
452 ffestpVxtcodeStmt
*params
;
453 ffestdExprItem_ list
;
459 ffestpVxtcodeStmt
*params
;
460 ffestdExprItem_ list
;
478 ffestpFindStmt
*params
;
486 /* Static objects accessed by functions in this module. */
488 static ffestdStatelet_ ffestd_statelet_
= FFESTD_stateletSIMPLE_
;
489 static int ffestd_block_level_
= 0; /* Block level for reachableness. */
490 static bool ffestd_is_reachable_
; /* Is the current stmt reachable? */
491 static ffelab ffestd_label_formatdef_
= NULL
;
492 static ffestdExprItem_
*ffestd_expr_list_
;
504 /* # ENTRY statements pending. */
505 static int ffestd_2pass_entrypoints_
= 0;
507 /* Static functions (internal). */
509 static void ffestd_stmt_append_ (ffestdStmt_ stmt
);
510 static ffestdStmt_
ffestd_stmt_new_ (ffestdStmtId_ id
);
511 static void ffestd_stmt_pass_ (void);
512 #if FFESTD_COPY_EASY_
513 static ffestpInquireStmt
*ffestd_subr_copy_easy_ (ffestpInquireIx max
);
515 static void ffestd_subr_vxt_ (void);
517 static void ffestd_subr_f90_ (void);
519 static void ffestd_subr_labels_ (bool unexpected
);
520 static void ffestd_R1001dump_ (ffests s
, ffesttFormatList list
);
521 static void ffestd_R1001dump_1005_1_ (ffests s
, ffesttFormatList f
,
523 static void ffestd_R1001dump_1005_2_ (ffests s
, ffesttFormatList f
,
525 static void ffestd_R1001dump_1005_3_ (ffests s
, ffesttFormatList f
,
527 static void ffestd_R1001dump_1005_4_ (ffests s
, ffesttFormatList f
,
529 static void ffestd_R1001dump_1005_5_ (ffests s
, ffesttFormatList f
,
531 static void ffestd_R1001dump_1010_1_ (ffests s
, ffesttFormatList f
,
533 static void ffestd_R1001dump_1010_2_ (ffests s
, ffesttFormatList f
,
535 static void ffestd_R1001dump_1010_3_ (ffests s
, ffesttFormatList f
,
537 static void ffestd_R1001dump_1010_4_ (ffests s
, ffesttFormatList f
,
539 static void ffestd_R1001dump_1010_5_ (ffests s
, ffesttFormatList f
,
541 static void ffestd_R1001error_ (ffesttFormatList f
);
542 static void ffestd_R1001rtexpr_ (ffests s
, ffesttFormatList f
, ffebld expr
);
544 /* Internal macros. */
546 #define ffestd_subr_line_now_() \
547 ffeste_set_line (ffelex_token_where_filename (ffesta_tokens[0]), \
548 ffelex_token_where_filelinenum (ffesta_tokens[0]))
549 #define ffestd_subr_line_restore_(s) \
550 ffeste_set_line ((s)->filename, (s)->filelinenum)
551 #define ffestd_subr_line_save_(s) \
552 ((s)->filename = ffelex_token_where_filename (ffesta_tokens[0]), \
553 (s)->filelinenum = ffelex_token_where_filelinenum (ffesta_tokens[0]))
554 #define ffestd_check_simple_() \
555 assert(ffestd_statelet_ == FFESTD_stateletSIMPLE_)
556 #define ffestd_check_start_() \
557 assert(ffestd_statelet_ == FFESTD_stateletSIMPLE_); \
558 ffestd_statelet_ = FFESTD_stateletATTRIB_
559 #define ffestd_check_attrib_() \
560 assert(ffestd_statelet_ == FFESTD_stateletATTRIB_)
561 #define ffestd_check_item_() \
562 assert(ffestd_statelet_ == FFESTD_stateletATTRIB_ \
563 || ffestd_statelet_ == FFESTD_stateletITEM_); \
564 ffestd_statelet_ = FFESTD_stateletITEM_
565 #define ffestd_check_item_startvals_() \
566 assert(ffestd_statelet_ == FFESTD_stateletATTRIB_ \
567 || ffestd_statelet_ == FFESTD_stateletITEM_); \
568 ffestd_statelet_ = FFESTD_stateletITEMVALS_
569 #define ffestd_check_item_value_() \
570 assert(ffestd_statelet_ == FFESTD_stateletITEMVALS_)
571 #define ffestd_check_item_endvals_() \
572 assert(ffestd_statelet_ == FFESTD_stateletITEMVALS_); \
573 ffestd_statelet_ = FFESTD_stateletITEM_
574 #define ffestd_check_finish_() \
575 assert(ffestd_statelet_ == FFESTD_stateletATTRIB_ \
576 || ffestd_statelet_ == FFESTD_stateletITEM_); \
577 ffestd_statelet_ = FFESTD_stateletSIMPLE_
579 #if FFESTD_COPY_EASY_
580 #define ffestd_subr_copy_accept_() (ffestpAcceptStmt *) \
581 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_acceptix)
582 #define ffestd_subr_copy_beru_() (ffestpBeruStmt *) \
583 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_beruix)
584 #define ffestd_subr_copy_close_() (ffestpCloseStmt *) \
585 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_closeix)
586 #define ffestd_subr_copy_delete_() (ffestpDeleteStmt *) \
587 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_deleteix)
588 #define ffestd_subr_copy_find_() (ffestpFindStmt *) \
589 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_findix)
590 #define ffestd_subr_copy_inquire_() (ffestpInquireStmt *) \
591 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_inquireix)
592 #define ffestd_subr_copy_open_() (ffestpOpenStmt *) \
593 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_openix)
594 #define ffestd_subr_copy_print_() (ffestpPrintStmt *) \
595 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_printix)
596 #define ffestd_subr_copy_read_() (ffestpReadStmt *) \
597 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_readix)
598 #define ffestd_subr_copy_rewrite_() (ffestpRewriteStmt *) \
599 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_rewriteix)
600 #define ffestd_subr_copy_type_() (ffestpTypeStmt *) \
601 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_typeix)
602 #define ffestd_subr_copy_vxtcode_() (ffestpVxtcodeStmt *) \
603 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_vxtcodeix)
604 #define ffestd_subr_copy_write_() (ffestpWriteStmt *) \
605 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_writeix)
608 /* ffestd_stmt_append_ -- Append statement to end of stmt list
610 ffestd_stmt_append_(ffestd_stmt_new_(FFESTD_stmtidR737A_)); */
613 ffestd_stmt_append_ (ffestdStmt_ stmt
)
615 stmt
->next
= (ffestdStmt_
) &ffestd_stmt_list_
.first
;
616 stmt
->previous
= ffestd_stmt_list_
.last
;
617 stmt
->next
->previous
= stmt
;
618 stmt
->previous
->next
= stmt
;
621 /* ffestd_stmt_new_ -- Make new statement with given id
624 stmt = ffestd_stmt_new_(FFESTD_stmtidR737A_); */
627 ffestd_stmt_new_ (ffestdStmtId_ id
)
631 stmt
= malloc_new_kp (ffe_pool_any_unit (), "ffestdStmt_", sizeof (*stmt
));
636 /* ffestd_stmt_pass_ -- Pass all statements on list to ffeste
638 ffestd_stmt_pass_(); */
644 ffestdExprItem_ expr
; /* For traversing lists. */
645 bool okay
= (TREE_CODE (current_function_decl
) != ERROR_MARK
);
647 if ((ffestd_2pass_entrypoints_
!= 0) && okay
)
649 tree which
= ffecom_which_entrypoint_decl ();
653 int ents
= ffestd_2pass_entrypoints_
;
656 expand_start_case (0, which
, TREE_TYPE (which
), "entrypoint dispatch");
658 stmt
= ffestd_stmt_list_
.first
;
661 while (stmt
->id
!= FFESTD_stmtidR1226_
)
664 if (stmt
->u
.R1226
.entry
!= NULL
)
666 value
= build_int_2 (stmt
->u
.R1226
.entrynum
, 0);
667 /* Yes, we really want to build a null LABEL_DECL here and not
668 put it on any list. That's what pushcase wants, so that's
670 label
= build_decl (LABEL_DECL
, NULL_TREE
, NULL_TREE
);
672 pushok
= pushcase (value
, convert
, label
, &duplicate
);
673 assert (pushok
== 0);
675 label
= ffecom_temp_label ();
676 TREE_USED (label
) = 1;
679 ffesymbol_hook (stmt
->u
.R1226
.entry
).length_tree
= label
;
685 expand_end_case (which
);
688 for (stmt
= ffestd_stmt_list_
.first
;
689 stmt
!= (ffestdStmt_
) &ffestd_stmt_list_
.first
;
694 case FFESTD_stmtidENDDOLOOP_
:
695 ffestd_subr_line_restore_ (stmt
);
697 ffeste_do (stmt
->u
.enddoloop
.block
);
698 ffestw_kill (stmt
->u
.enddoloop
.block
);
701 case FFESTD_stmtidENDLOGIF_
:
702 ffestd_subr_line_restore_ (stmt
);
707 case FFESTD_stmtidEXECLABEL_
:
709 ffeste_labeldef_branch (stmt
->u
.execlabel
.label
);
712 case FFESTD_stmtidFORMATLABEL_
:
714 ffeste_labeldef_format (stmt
->u
.formatlabel
.label
);
717 case FFESTD_stmtidR737A_
:
718 ffestd_subr_line_restore_ (stmt
);
720 ffeste_R737A (stmt
->u
.R737A
.dest
, stmt
->u
.R737A
.source
);
721 malloc_pool_kill (stmt
->u
.R737A
.pool
);
724 case FFESTD_stmtidR803_
:
725 ffestd_subr_line_restore_ (stmt
);
727 ffeste_R803 (stmt
->u
.R803
.block
, stmt
->u
.R803
.expr
);
728 malloc_pool_kill (stmt
->u
.R803
.pool
);
731 case FFESTD_stmtidR804_
:
732 ffestd_subr_line_restore_ (stmt
);
734 ffeste_R804 (stmt
->u
.R803
.block
, stmt
->u
.R804
.expr
);
735 malloc_pool_kill (stmt
->u
.R804
.pool
);
738 case FFESTD_stmtidR805_
:
739 ffestd_subr_line_restore_ (stmt
);
741 ffeste_R805 (stmt
->u
.R803
.block
);
744 case FFESTD_stmtidR806_
:
745 ffestd_subr_line_restore_ (stmt
);
747 ffeste_R806 (stmt
->u
.R806
.block
);
748 ffestw_kill (stmt
->u
.R806
.block
);
751 case FFESTD_stmtidR807_
:
752 ffestd_subr_line_restore_ (stmt
);
754 ffeste_R807 (stmt
->u
.R807
.expr
);
755 malloc_pool_kill (stmt
->u
.R807
.pool
);
758 case FFESTD_stmtidR809_
:
759 ffestd_subr_line_restore_ (stmt
);
761 ffeste_R809 (stmt
->u
.R809
.block
, stmt
->u
.R809
.expr
);
762 malloc_pool_kill (stmt
->u
.R809
.pool
);
765 case FFESTD_stmtidR810_
:
766 ffestd_subr_line_restore_ (stmt
);
768 ffeste_R810 (stmt
->u
.R810
.block
, stmt
->u
.R810
.casenum
);
769 malloc_pool_kill (stmt
->u
.R810
.pool
);
772 case FFESTD_stmtidR811_
:
773 ffestd_subr_line_restore_ (stmt
);
775 ffeste_R811 (stmt
->u
.R811
.block
);
776 malloc_pool_kill (ffestw_select (stmt
->u
.R811
.block
)->pool
);
777 ffestw_kill (stmt
->u
.R811
.block
);
780 case FFESTD_stmtidR819A_
:
781 ffestd_subr_line_restore_ (stmt
);
783 ffeste_R819A (stmt
->u
.R819A
.block
, stmt
->u
.R819A
.label
,
785 stmt
->u
.R819A
.start
, stmt
->u
.R819A
.start_token
,
786 stmt
->u
.R819A
.end
, stmt
->u
.R819A
.end_token
,
787 stmt
->u
.R819A
.incr
, stmt
->u
.R819A
.incr_token
);
788 ffelex_token_kill (stmt
->u
.R819A
.start_token
);
789 ffelex_token_kill (stmt
->u
.R819A
.end_token
);
790 if (stmt
->u
.R819A
.incr_token
!= NULL
)
791 ffelex_token_kill (stmt
->u
.R819A
.incr_token
);
792 malloc_pool_kill (stmt
->u
.R819A
.pool
);
795 case FFESTD_stmtidR819B_
:
796 ffestd_subr_line_restore_ (stmt
);
798 ffeste_R819B (stmt
->u
.R819B
.block
, stmt
->u
.R819B
.label
,
800 malloc_pool_kill (stmt
->u
.R819B
.pool
);
803 case FFESTD_stmtidR825_
:
804 ffestd_subr_line_restore_ (stmt
);
809 case FFESTD_stmtidR834_
:
810 ffestd_subr_line_restore_ (stmt
);
812 ffeste_R834 (stmt
->u
.R834
.block
);
815 case FFESTD_stmtidR835_
:
816 ffestd_subr_line_restore_ (stmt
);
818 ffeste_R835 (stmt
->u
.R835
.block
);
821 case FFESTD_stmtidR836_
:
822 ffestd_subr_line_restore_ (stmt
);
824 ffeste_R836 (stmt
->u
.R836
.label
);
827 case FFESTD_stmtidR837_
:
828 ffestd_subr_line_restore_ (stmt
);
830 ffeste_R837 (stmt
->u
.R837
.labels
, stmt
->u
.R837
.count
,
832 malloc_pool_kill (stmt
->u
.R837
.pool
);
835 case FFESTD_stmtidR838_
:
836 ffestd_subr_line_restore_ (stmt
);
838 ffeste_R838 (stmt
->u
.R838
.label
, stmt
->u
.R838
.target
);
839 malloc_pool_kill (stmt
->u
.R838
.pool
);
842 case FFESTD_stmtidR839_
:
843 ffestd_subr_line_restore_ (stmt
);
845 ffeste_R839 (stmt
->u
.R839
.target
);
846 malloc_pool_kill (stmt
->u
.R839
.pool
);
849 case FFESTD_stmtidR840_
:
850 ffestd_subr_line_restore_ (stmt
);
852 ffeste_R840 (stmt
->u
.R840
.expr
, stmt
->u
.R840
.neg
, stmt
->u
.R840
.zero
,
854 malloc_pool_kill (stmt
->u
.R840
.pool
);
857 case FFESTD_stmtidR841_
:
858 ffestd_subr_line_restore_ (stmt
);
863 case FFESTD_stmtidR842_
:
864 ffestd_subr_line_restore_ (stmt
);
866 ffeste_R842 (stmt
->u
.R842
.expr
);
867 if (stmt
->u
.R842
.pool
!= NULL
)
868 malloc_pool_kill (stmt
->u
.R842
.pool
);
871 case FFESTD_stmtidR843_
:
872 ffestd_subr_line_restore_ (stmt
);
874 ffeste_R843 (stmt
->u
.R843
.expr
);
875 malloc_pool_kill (stmt
->u
.R843
.pool
);
878 case FFESTD_stmtidR904_
:
879 ffestd_subr_line_restore_ (stmt
);
881 ffeste_R904 (stmt
->u
.R904
.params
);
882 malloc_pool_kill (stmt
->u
.R904
.pool
);
885 case FFESTD_stmtidR907_
:
886 ffestd_subr_line_restore_ (stmt
);
888 ffeste_R907 (stmt
->u
.R907
.params
);
889 malloc_pool_kill (stmt
->u
.R907
.pool
);
892 case FFESTD_stmtidR909_
:
893 ffestd_subr_line_restore_ (stmt
);
895 ffeste_R909_start (stmt
->u
.R909
.params
, stmt
->u
.R909
.only_format
,
896 stmt
->u
.R909
.unit
, stmt
->u
.R909
.format
,
897 stmt
->u
.R909
.rec
, stmt
->u
.R909
.key
);
898 for (expr
= stmt
->u
.R909
.list
; expr
!= NULL
; expr
= expr
->next
)
901 ffeste_R909_item (expr
->expr
, expr
->token
);
902 ffelex_token_kill (expr
->token
);
905 ffeste_R909_finish ();
906 malloc_pool_kill (stmt
->u
.R909
.pool
);
909 case FFESTD_stmtidR910_
:
910 ffestd_subr_line_restore_ (stmt
);
912 ffeste_R910_start (stmt
->u
.R910
.params
, stmt
->u
.R910
.unit
,
913 stmt
->u
.R910
.format
, stmt
->u
.R910
.rec
);
914 for (expr
= stmt
->u
.R910
.list
; expr
!= NULL
; expr
= expr
->next
)
917 ffeste_R910_item (expr
->expr
, expr
->token
);
918 ffelex_token_kill (expr
->token
);
921 ffeste_R910_finish ();
922 malloc_pool_kill (stmt
->u
.R910
.pool
);
925 case FFESTD_stmtidR911_
:
926 ffestd_subr_line_restore_ (stmt
);
928 ffeste_R911_start (stmt
->u
.R911
.params
, stmt
->u
.R911
.format
);
929 for (expr
= stmt
->u
.R911
.list
; expr
!= NULL
; expr
= expr
->next
)
932 ffeste_R911_item (expr
->expr
, expr
->token
);
933 ffelex_token_kill (expr
->token
);
936 ffeste_R911_finish ();
937 malloc_pool_kill (stmt
->u
.R911
.pool
);
940 case FFESTD_stmtidR919_
:
941 ffestd_subr_line_restore_ (stmt
);
943 ffeste_R919 (stmt
->u
.R919
.params
);
944 malloc_pool_kill (stmt
->u
.R919
.pool
);
947 case FFESTD_stmtidR920_
:
948 ffestd_subr_line_restore_ (stmt
);
950 ffeste_R920 (stmt
->u
.R920
.params
);
951 malloc_pool_kill (stmt
->u
.R920
.pool
);
954 case FFESTD_stmtidR921_
:
955 ffestd_subr_line_restore_ (stmt
);
957 ffeste_R921 (stmt
->u
.R921
.params
);
958 malloc_pool_kill (stmt
->u
.R921
.pool
);
961 case FFESTD_stmtidR923A_
:
962 ffestd_subr_line_restore_ (stmt
);
964 ffeste_R923A (stmt
->u
.R923A
.params
, stmt
->u
.R923A
.by_file
);
965 malloc_pool_kill (stmt
->u
.R923A
.pool
);
968 case FFESTD_stmtidR923B_
:
969 ffestd_subr_line_restore_ (stmt
);
971 ffeste_R923B_start (stmt
->u
.R923B
.params
);
972 for (expr
= stmt
->u
.R923B
.list
; expr
!= NULL
; expr
= expr
->next
)
975 ffeste_R923B_item (expr
->expr
);
978 ffeste_R923B_finish ();
979 malloc_pool_kill (stmt
->u
.R923B
.pool
);
982 case FFESTD_stmtidR1001_
:
984 ffeste_R1001 (&stmt
->u
.R1001
.str
);
985 ffests_kill (&stmt
->u
.R1001
.str
);
988 case FFESTD_stmtidR1103_
:
993 case FFESTD_stmtidR1112_
:
998 case FFESTD_stmtidR1212_
:
999 ffestd_subr_line_restore_ (stmt
);
1001 ffeste_R1212 (stmt
->u
.R1212
.expr
);
1002 malloc_pool_kill (stmt
->u
.R1212
.pool
);
1005 case FFESTD_stmtidR1221_
:
1010 case FFESTD_stmtidR1225_
:
1015 case FFESTD_stmtidR1226_
:
1016 ffestd_subr_line_restore_ (stmt
);
1017 if (stmt
->u
.R1226
.entry
!= NULL
)
1020 ffeste_R1226 (stmt
->u
.R1226
.entry
);
1024 case FFESTD_stmtidR1227_
:
1025 ffestd_subr_line_restore_ (stmt
);
1027 ffeste_R1227 (stmt
->u
.R1227
.block
, stmt
->u
.R1227
.expr
);
1028 malloc_pool_kill (stmt
->u
.R1227
.pool
);
1032 case FFESTD_stmtidV018_
:
1033 ffestd_subr_line_restore_ (stmt
);
1035 ffeste_V018_start (stmt
->u
.V018
.params
, stmt
->u
.V018
.format
);
1036 for (expr
= stmt
->u
.V018
.list
; expr
!= NULL
; expr
= expr
->next
)
1039 ffeste_V018_item (expr
->expr
);
1042 ffeste_V018_finish ();
1043 malloc_pool_kill (stmt
->u
.V018
.pool
);
1046 case FFESTD_stmtidV019_
:
1047 ffestd_subr_line_restore_ (stmt
);
1049 ffeste_V019_start (stmt
->u
.V019
.params
, stmt
->u
.V019
.format
);
1050 for (expr
= stmt
->u
.V019
.list
; expr
!= NULL
; expr
= expr
->next
)
1053 ffeste_V019_item (expr
->expr
);
1056 ffeste_V019_finish ();
1057 malloc_pool_kill (stmt
->u
.V019
.pool
);
1061 case FFESTD_stmtidV020_
:
1062 ffestd_subr_line_restore_ (stmt
);
1064 ffeste_V020_start (stmt
->u
.V020
.params
, stmt
->u
.V020
.format
);
1065 for (expr
= stmt
->u
.V020
.list
; expr
!= NULL
; expr
= expr
->next
)
1068 ffeste_V020_item (expr
->expr
);
1071 ffeste_V020_finish ();
1072 malloc_pool_kill (stmt
->u
.V020
.pool
);
1076 case FFESTD_stmtidV021_
:
1077 ffestd_subr_line_restore_ (stmt
);
1079 ffeste_V021 (stmt
->u
.V021
.params
);
1080 malloc_pool_kill (stmt
->u
.V021
.pool
);
1083 case FFESTD_stmtidV023_
:
1084 ffestd_subr_line_restore_ (stmt
);
1086 ffeste_V023_start (stmt
->u
.V023
.params
);
1087 for (expr
= stmt
->u
.V023
.list
; expr
!= NULL
; expr
= expr
->next
)
1090 ffeste_V023_item (expr
->expr
);
1093 ffeste_V023_finish ();
1094 malloc_pool_kill (stmt
->u
.V023
.pool
);
1097 case FFESTD_stmtidV024_
:
1098 ffestd_subr_line_restore_ (stmt
);
1100 ffeste_V024_start (stmt
->u
.V024
.params
);
1101 for (expr
= stmt
->u
.V024
.list
; expr
!= NULL
; expr
= expr
->next
)
1104 ffeste_V024_item (expr
->expr
);
1107 ffeste_V024_finish ();
1108 malloc_pool_kill (stmt
->u
.V024
.pool
);
1111 case FFESTD_stmtidV025start_
:
1112 ffestd_subr_line_restore_ (stmt
);
1114 ffeste_V025_start ();
1117 case FFESTD_stmtidV025item_
:
1119 ffeste_V025_item (stmt
->u
.V025item
.u
, stmt
->u
.V025item
.m
,
1120 stmt
->u
.V025item
.n
, stmt
->u
.V025item
.asv
);
1123 case FFESTD_stmtidV025finish_
:
1125 ffeste_V025_finish ();
1126 malloc_pool_kill (stmt
->u
.V025finish
.pool
);
1129 case FFESTD_stmtidV026_
:
1130 ffestd_subr_line_restore_ (stmt
);
1132 ffeste_V026 (stmt
->u
.V026
.params
);
1133 malloc_pool_kill (stmt
->u
.V026
.pool
);
1138 assert ("bad stmt->id" == NULL
);
1144 /* ffestd_subr_copy_easy_ -- Copy I/O statement data structure
1146 ffestd_subr_copy_easy_();
1148 Copies all data except tokens in the I/O data structure into a new
1149 structure that lasts as long as the output pool for the current
1150 statement. Assumes that they are
1151 overlaid with each other (union) in stp.h and the typing
1152 and structure references assume (though not necessarily dangerous if
1153 FALSE) that INQUIRE has the most file elements. */
1155 #if FFESTD_COPY_EASY_
1156 static ffestpInquireStmt
*
1157 ffestd_subr_copy_easy_ (ffestpInquireIx max
)
1159 ffestpInquireStmt
*stmt
;
1162 stmt
= (ffestpInquireStmt
*) malloc_new_kp (ffesta_output_pool
,
1163 "FFESTD easy", sizeof (ffestpFile
) * max
);
1165 for (ix
= 0; ix
< max
; ++ix
)
1167 if ((stmt
->inquire_spec
[ix
].kw_or_val_present
1168 = ffestp_file
.inquire
.inquire_spec
[ix
].kw_or_val_present
)
1169 && (stmt
->inquire_spec
[ix
].value_present
1170 = ffestp_file
.inquire
.inquire_spec
[ix
].value_present
))
1172 if ((stmt
->inquire_spec
[ix
].value_is_label
1173 = ffestp_file
.inquire
.inquire_spec
[ix
].value_is_label
))
1174 stmt
->inquire_spec
[ix
].u
.label
1175 = ffestp_file
.inquire
.inquire_spec
[ix
].u
.label
;
1177 stmt
->inquire_spec
[ix
].u
.expr
1178 = ffestp_file
.inquire
.inquire_spec
[ix
].u
.expr
;
1186 /* ffestd_subr_labels_ -- Handle any undefined labels
1188 ffestd_subr_labels_(FALSE);
1190 For every undefined label, generate an error message and either define
1191 label as a FORMAT() statement (for FORMAT labels) or as a STOP statement
1192 (for all other labels). */
1195 ffestd_subr_labels_ (bool unexpected
)
1202 undef
= ffelab_number () - ffestv_num_label_defines_
;
1204 for (h
= ffelab_handle_first (); h
!= NULL
; h
= ffelab_handle_next (h
))
1206 l
= ffelab_handle_target (h
);
1207 if (ffewhere_line_is_unknown (ffelab_definition_line (l
)))
1208 { /* Undefined label. */
1209 assert (!unexpected
);
1212 ffebad_start (FFEBAD_UNDEF_LABEL
);
1213 if (ffelab_type (l
) == FFELAB_typeLOOPEND
)
1214 ffebad_here (0, ffelab_doref_line (l
), ffelab_doref_column (l
));
1215 else if (ffelab_type (l
) != FFELAB_typeANY
)
1216 ffebad_here (0, ffelab_firstref_line (l
), ffelab_firstref_column (l
));
1217 else if (!ffewhere_line_is_unknown (ffelab_firstref_line (l
)))
1218 ffebad_here (0, ffelab_firstref_line (l
), ffelab_firstref_column (l
));
1219 else if (!ffewhere_line_is_unknown (ffelab_doref_line (l
)))
1220 ffebad_here (0, ffelab_doref_line (l
), ffelab_doref_column (l
));
1222 ffebad_here (0, ffelab_definition_line (l
), ffelab_definition_column (l
));
1225 switch (ffelab_type (l
))
1227 case FFELAB_typeFORMAT
:
1228 ffelab_set_definition_line (l
,
1229 ffewhere_line_use (ffelab_firstref_line (l
)));
1230 ffelab_set_definition_column (l
,
1231 ffewhere_column_use (ffelab_firstref_column (l
)));
1232 ffestv_num_label_defines_
++;
1233 f
= ffestt_formatlist_create (NULL
, NULL
);
1234 ffestd_labeldef_format (l
);
1236 ffestt_formatlist_kill (f
);
1239 case FFELAB_typeASSIGNABLE
:
1240 ffelab_set_definition_line (l
,
1241 ffewhere_line_use (ffelab_firstref_line (l
)));
1242 ffelab_set_definition_column (l
,
1243 ffewhere_column_use (ffelab_firstref_column (l
)));
1244 ffestv_num_label_defines_
++;
1245 ffelab_set_type (l
, FFELAB_typeNOTLOOP
);
1246 ffelab_set_blocknum (l
, ffestw_blocknum (ffestw_stack_top ()));
1247 ffestd_labeldef_notloop (l
);
1251 case FFELAB_typeNOTLOOP
:
1252 ffelab_set_definition_line (l
,
1253 ffewhere_line_use (ffelab_firstref_line (l
)));
1254 ffelab_set_definition_column (l
,
1255 ffewhere_column_use (ffelab_firstref_column (l
)));
1256 ffestv_num_label_defines_
++;
1257 ffelab_set_blocknum (l
, ffestw_blocknum (ffestw_stack_top ()));
1258 ffestd_labeldef_notloop (l
);
1263 assert ("bad label type" == NULL
);
1265 case FFELAB_typeUNKNOWN
:
1266 case FFELAB_typeANY
:
1271 ffelab_handle_done (h
);
1272 assert (undef
== 0);
1275 /* ffestd_subr_f90_ -- Report error about lack of full F90 support
1277 ffestd_subr_f90_(); */
1283 ffebad_start (FFEBAD_F90
);
1284 ffebad_here (0, ffelex_token_where_line (ffesta_tokens
[0]),
1285 ffelex_token_where_column (ffesta_tokens
[0]));
1290 /* ffestd_subr_vxt_ -- Report error about lack of full VXT support
1292 ffestd_subr_vxt_(); */
1297 ffebad_start (FFEBAD_VXT_UNSUPPORTED
);
1298 ffebad_here (0, ffelex_token_where_line (ffesta_tokens
[0]),
1299 ffelex_token_where_column (ffesta_tokens
[0]));
1303 /* ffestd_begin_uses -- Start a bunch of USE statements
1305 ffestd_begin_uses();
1307 Invoked before handling the first USE statement in a block of one or
1308 more USE statements. _end_uses_(bool ok) is invoked before handling
1309 the first statement after the block (there are no BEGIN USE and END USE
1310 statements, but the semantics of USE statements effectively requires
1311 handling them as a single block rather than one statement at a time). */
1314 ffestd_begin_uses ()
1318 /* ffestd_do -- End of statement following DO-term-stmt etc
1322 Also invoked by _labeldef_branch_finish_ (or, in cases
1323 of errors, other _labeldef_ functions) when the label definition is
1324 for a DO-target (LOOPEND) label, once per matching/outstanding DO
1325 block on the stack. These cases invoke this function with ok==TRUE, so
1326 only forced stack popping (via ffestd_eof_()) invokes it with ok==FALSE. */
1329 ffestd_do (bool ok UNUSED
)
1333 stmt
= ffestd_stmt_new_ (FFESTD_stmtidENDDOLOOP_
);
1334 ffestd_stmt_append_ (stmt
);
1335 ffestd_subr_line_save_ (stmt
);
1336 stmt
->u
.enddoloop
.block
= ffestw_stack_top ();
1338 --ffestd_block_level_
;
1339 assert (ffestd_block_level_
>= 0);
1342 /* ffestd_end_uses -- End a bunch of USE statements
1344 ffestd_end_uses(TRUE);
1346 ok==TRUE means simply not popping due to ffestd_eof_()
1347 being called, because there is no formal END USES statement in Fortran. */
1351 ffestd_end_uses (bool ok
)
1355 /* ffestd_end_R740 -- End a WHERE(-THEN)
1357 ffestd_end_R740(TRUE); */
1360 ffestd_end_R740 (bool ok
)
1366 /* ffestd_end_R807 -- End of statement following logical IF
1368 ffestd_end_R807(TRUE);
1370 Applies ONLY to logical IF, not to IF-THEN. For example, does not
1371 ffelex_token_kill the construct name for an IF-THEN block (the name
1372 field is invalid for logical IF). ok==TRUE iff statement following
1373 logical IF (substatement) is valid; else, statement is invalid or
1374 stack forcibly popped due to ffestd_eof_(). */
1377 ffestd_end_R807 (bool ok UNUSED
)
1381 stmt
= ffestd_stmt_new_ (FFESTD_stmtidENDLOGIF_
);
1382 ffestd_stmt_append_ (stmt
);
1383 ffestd_subr_line_save_ (stmt
);
1385 --ffestd_block_level_
;
1386 assert (ffestd_block_level_
>= 0);
1389 /* ffestd_exec_begin -- Executable statements can start coming in now
1391 ffestd_exec_begin(); */
1394 ffestd_exec_begin ()
1396 ffecom_exec_transition ();
1398 if (ffestd_2pass_entrypoints_
!= 0)
1399 { /* Process pending ENTRY statements now that
1402 int ents
= ffestd_2pass_entrypoints_
;
1404 stmt
= ffestd_stmt_list_
.first
;
1407 while (stmt
->id
!= FFESTD_stmtidR1226_
)
1410 if (!ffecom_2pass_advise_entrypoint (stmt
->u
.R1226
.entry
))
1412 stmt
->u
.R1226
.entry
= NULL
;
1413 --ffestd_2pass_entrypoints_
;
1417 while (--ents
!= 0);
1421 /* ffestd_exec_end -- Executable statements can no longer come in now
1423 ffestd_exec_end(); */
1428 int old_lineno
= lineno
;
1429 const char *old_input_filename
= input_filename
;
1431 ffecom_end_transition ();
1433 ffestd_stmt_pass_ ();
1435 ffecom_finish_progunit ();
1437 if (ffestd_2pass_entrypoints_
!= 0)
1439 int ents
= ffestd_2pass_entrypoints_
;
1440 ffestdStmt_ stmt
= ffestd_stmt_list_
.first
;
1444 while (stmt
->id
!= FFESTD_stmtidR1226_
)
1447 if (stmt
->u
.R1226
.entry
!= NULL
)
1449 ffestd_subr_line_restore_ (stmt
);
1450 ffecom_2pass_do_entrypoint (stmt
->u
.R1226
.entry
);
1454 while (--ents
!= 0);
1457 ffestd_stmt_list_
.first
= NULL
;
1458 ffestd_stmt_list_
.last
= NULL
;
1459 ffestd_2pass_entrypoints_
= 0;
1461 lineno
= old_lineno
;
1462 input_filename
= old_input_filename
;
1465 /* ffestd_init_3 -- Initialize for any program unit
1472 ffestd_stmt_list_
.first
= (ffestdStmt_
) &ffestd_stmt_list_
.first
;
1473 ffestd_stmt_list_
.last
= (ffestdStmt_
) &ffestd_stmt_list_
.first
;
1476 /* Generate "code" for "any" label def. */
1479 ffestd_labeldef_any (ffelab label UNUSED
)
1483 /* ffestd_labeldef_branch -- Generate "code" for branch label def
1485 ffestd_labeldef_branch(label); */
1488 ffestd_labeldef_branch (ffelab label
)
1492 stmt
= ffestd_stmt_new_ (FFESTD_stmtidEXECLABEL_
);
1493 ffestd_stmt_append_ (stmt
);
1494 stmt
->u
.execlabel
.label
= label
;
1496 ffestd_is_reachable_
= TRUE
;
1499 /* ffestd_labeldef_format -- Generate "code" for FORMAT label def
1501 ffestd_labeldef_format(label); */
1504 ffestd_labeldef_format (ffelab label
)
1508 ffestd_label_formatdef_
= label
;
1510 stmt
= ffestd_stmt_new_ (FFESTD_stmtidFORMATLABEL_
);
1511 ffestd_stmt_append_ (stmt
);
1512 stmt
->u
.formatlabel
.label
= label
;
1515 /* ffestd_labeldef_useless -- Generate "code" for useless label def
1517 ffestd_labeldef_useless(label); */
1520 ffestd_labeldef_useless (ffelab label UNUSED
)
1524 /* ffestd_R423A -- PRIVATE statement (in R422 derived-type statement)
1532 ffestd_check_simple_ ();
1535 /* ffestd_R423B -- SEQUENCE statement (in R422 derived-type-stmt)
1542 ffestd_check_simple_ ();
1545 /* ffestd_R424 -- derived-TYPE-def statement
1547 ffestd_R424(access_token,access_kw,name_token);
1549 Handle a derived-type definition. */
1552 ffestd_R424 (ffelexToken access
, ffestrOther access_kw
, ffelexToken name
)
1554 ffestd_check_simple_ ();
1556 ffestd_subr_f90_ ();
1563 fprintf (dmpout
, "* TYPE %s\n", ffelex_token_text (name
));
1568 case FFESTR_otherPUBLIC
:
1572 case FFESTR_otherPRIVATE
:
1579 fprintf (dmpout
, "* TYPE,%s: %s\n", a
, ffelex_token_text (name
));
1584 /* ffestd_R425 -- End a TYPE
1586 ffestd_R425(TRUE); */
1589 ffestd_R425 (bool ok
)
1593 /* ffestd_R519_start -- INTENT statement list begin
1595 ffestd_R519_start();
1597 Verify that INTENT is valid here, and begin accepting items in the list. */
1600 ffestd_R519_start (ffestrOther intent_kw
)
1602 ffestd_check_start_ ();
1604 ffestd_subr_f90_ ();
1612 case FFESTR_otherIN
:
1616 case FFESTR_otherOUT
:
1620 case FFESTR_otherINOUT
:
1627 fprintf (dmpout
, "* INTENT (%s) ", a
);
1631 /* ffestd_R519_item -- INTENT statement for name
1633 ffestd_R519_item(name_token);
1635 Make sure name_token identifies a valid object to be INTENTed. */
1638 ffestd_R519_item (ffelexToken name
)
1640 ffestd_check_item_ ();
1645 fprintf (dmpout
, "%s,", ffelex_token_text (name
));
1649 /* ffestd_R519_finish -- INTENT statement list complete
1651 ffestd_R519_finish();
1653 Just wrap up any local activities. */
1656 ffestd_R519_finish ()
1658 ffestd_check_finish_ ();
1663 fputc ('\n', dmpout
);
1667 /* ffestd_R520_start -- OPTIONAL statement list begin
1669 ffestd_R520_start();
1671 Verify that OPTIONAL is valid here, and begin accepting items in the list. */
1674 ffestd_R520_start ()
1676 ffestd_check_start_ ();
1678 ffestd_subr_f90_ ();
1682 fputs ("* OPTIONAL ", dmpout
);
1686 /* ffestd_R520_item -- OPTIONAL statement for name
1688 ffestd_R520_item(name_token);
1690 Make sure name_token identifies a valid object to be OPTIONALed. */
1693 ffestd_R520_item (ffelexToken name
)
1695 ffestd_check_item_ ();
1700 fprintf (dmpout
, "%s,", ffelex_token_text (name
));
1704 /* ffestd_R520_finish -- OPTIONAL statement list complete
1706 ffestd_R520_finish();
1708 Just wrap up any local activities. */
1711 ffestd_R520_finish ()
1713 ffestd_check_finish_ ();
1718 fputc ('\n', dmpout
);
1722 /* ffestd_R521A -- PUBLIC statement
1726 Verify that PUBLIC is valid here. */
1731 ffestd_check_simple_ ();
1733 ffestd_subr_f90_ ();
1737 fputs ("* PUBLIC\n", dmpout
);
1741 /* ffestd_R521Astart -- PUBLIC statement list begin
1743 ffestd_R521Astart();
1745 Verify that PUBLIC is valid here, and begin accepting items in the list. */
1748 ffestd_R521Astart ()
1750 ffestd_check_start_ ();
1752 ffestd_subr_f90_ ();
1756 fputs ("* PUBLIC ", dmpout
);
1760 /* ffestd_R521Aitem -- PUBLIC statement for name
1762 ffestd_R521Aitem(name_token);
1764 Make sure name_token identifies a valid object to be PUBLICed. */
1767 ffestd_R521Aitem (ffelexToken name
)
1769 ffestd_check_item_ ();
1774 fprintf (dmpout
, "%s,", ffelex_token_text (name
));
1778 /* ffestd_R521Afinish -- PUBLIC statement list complete
1780 ffestd_R521Afinish();
1782 Just wrap up any local activities. */
1785 ffestd_R521Afinish ()
1787 ffestd_check_finish_ ();
1792 fputc ('\n', dmpout
);
1796 /* ffestd_R521B -- PRIVATE statement
1800 Verify that PRIVATE is valid here (outside a derived-type statement). */
1805 ffestd_check_simple_ ();
1807 ffestd_subr_f90_ ();
1811 fputs ("* PRIVATE_outside_of_R422_derived_type_def\n", dmpout
);
1815 /* ffestd_R521Bstart -- PRIVATE statement list begin
1817 ffestd_R521Bstart();
1819 Verify that PRIVATE is valid here, and begin accepting items in the list. */
1822 ffestd_R521Bstart ()
1824 ffestd_check_start_ ();
1826 ffestd_subr_f90_ ();
1830 fputs ("* PRIVATE ", dmpout
);
1834 /* ffestd_R521Bitem -- PRIVATE statement for name
1836 ffestd_R521Bitem(name_token);
1838 Make sure name_token identifies a valid object to be PRIVATEed. */
1841 ffestd_R521Bitem (ffelexToken name
)
1843 ffestd_check_item_ ();
1848 fprintf (dmpout
, "%s,", ffelex_token_text (name
));
1852 /* ffestd_R521Bfinish -- PRIVATE statement list complete
1854 ffestd_R521Bfinish();
1856 Just wrap up any local activities. */
1859 ffestd_R521Bfinish ()
1861 ffestd_check_finish_ ();
1866 fputc ('\n', dmpout
);
1871 /* ffestd_R522 -- SAVE statement with no list
1875 Verify that SAVE is valid here, and flag everything as SAVEd. */
1880 ffestd_check_simple_ ();
1883 /* ffestd_R522start -- SAVE statement list begin
1887 Verify that SAVE is valid here, and begin accepting items in the list. */
1892 ffestd_check_start_ ();
1895 /* ffestd_R522item_object -- SAVE statement for object-name
1897 ffestd_R522item_object(name_token);
1899 Make sure name_token identifies a valid object to be SAVEd. */
1902 ffestd_R522item_object (ffelexToken name UNUSED
)
1904 ffestd_check_item_ ();
1907 /* ffestd_R522item_cblock -- SAVE statement for common-block-name
1909 ffestd_R522item_cblock(name_token);
1911 Make sure name_token identifies a valid common block to be SAVEd. */
1914 ffestd_R522item_cblock (ffelexToken name UNUSED
)
1916 ffestd_check_item_ ();
1919 /* ffestd_R522finish -- SAVE statement list complete
1921 ffestd_R522finish();
1923 Just wrap up any local activities. */
1926 ffestd_R522finish ()
1928 ffestd_check_finish_ ();
1931 /* ffestd_R524_start -- DIMENSION statement list begin
1933 ffestd_R524_start(bool virtual);
1935 Verify that DIMENSION is valid here, and begin accepting items in the list. */
1938 ffestd_R524_start (bool virtual UNUSED
)
1940 ffestd_check_start_ ();
1943 /* ffestd_R524_item -- DIMENSION statement for object-name
1945 ffestd_R524_item(name_token,dim_list);
1947 Make sure name_token identifies a valid object to be DIMENSIONd. */
1950 ffestd_R524_item (ffelexToken name UNUSED
, ffesttDimList dims UNUSED
)
1952 ffestd_check_item_ ();
1955 /* ffestd_R524_finish -- DIMENSION statement list complete
1957 ffestd_R524_finish();
1959 Just wrap up any local activities. */
1962 ffestd_R524_finish ()
1964 ffestd_check_finish_ ();
1967 /* ffestd_R525_start -- ALLOCATABLE statement list begin
1969 ffestd_R525_start();
1971 Verify that ALLOCATABLE is valid here, and begin accepting items in the
1976 ffestd_R525_start ()
1978 ffestd_check_start_ ();
1980 ffestd_subr_f90_ ();
1984 fputs ("* ALLOCATABLE ", dmpout
);
1988 /* ffestd_R525_item -- ALLOCATABLE statement for object-name
1990 ffestd_R525_item(name_token,dim_list);
1992 Make sure name_token identifies a valid object to be ALLOCATABLEd. */
1995 ffestd_R525_item (ffelexToken name
, ffesttDimList dims
)
1997 ffestd_check_item_ ();
2002 fputs (ffelex_token_text (name
), dmpout
);
2005 fputc ('(', dmpout
);
2006 ffestt_dimlist_dump (dims
);
2007 fputc (')', dmpout
);
2009 fputc (',', dmpout
);
2013 /* ffestd_R525_finish -- ALLOCATABLE statement list complete
2015 ffestd_R525_finish();
2017 Just wrap up any local activities. */
2020 ffestd_R525_finish ()
2022 ffestd_check_finish_ ();
2027 fputc ('\n', dmpout
);
2031 /* ffestd_R526_start -- POINTER statement list begin
2033 ffestd_R526_start();
2035 Verify that POINTER is valid here, and begin accepting items in the
2039 ffestd_R526_start ()
2041 ffestd_check_start_ ();
2043 ffestd_subr_f90_ ();
2047 fputs ("* POINTER ", dmpout
);
2051 /* ffestd_R526_item -- POINTER statement for object-name
2053 ffestd_R526_item(name_token,dim_list);
2055 Make sure name_token identifies a valid object to be POINTERd. */
2058 ffestd_R526_item (ffelexToken name
, ffesttDimList dims
)
2060 ffestd_check_item_ ();
2065 fputs (ffelex_token_text (name
), dmpout
);
2068 fputc ('(', dmpout
);
2069 ffestt_dimlist_dump (dims
);
2070 fputc (')', dmpout
);
2072 fputc (',', dmpout
);
2076 /* ffestd_R526_finish -- POINTER statement list complete
2078 ffestd_R526_finish();
2080 Just wrap up any local activities. */
2083 ffestd_R526_finish ()
2085 ffestd_check_finish_ ();
2090 fputc ('\n', dmpout
);
2094 /* ffestd_R527_start -- TARGET statement list begin
2096 ffestd_R527_start();
2098 Verify that TARGET is valid here, and begin accepting items in the
2102 ffestd_R527_start ()
2104 ffestd_check_start_ ();
2106 ffestd_subr_f90_ ();
2110 fputs ("* TARGET ", dmpout
);
2114 /* ffestd_R527_item -- TARGET statement for object-name
2116 ffestd_R527_item(name_token,dim_list);
2118 Make sure name_token identifies a valid object to be TARGETd. */
2121 ffestd_R527_item (ffelexToken name
, ffesttDimList dims
)
2123 ffestd_check_item_ ();
2128 fputs (ffelex_token_text (name
), dmpout
);
2131 fputc ('(', dmpout
);
2132 ffestt_dimlist_dump (dims
);
2133 fputc (')', dmpout
);
2135 fputc (',', dmpout
);
2139 /* ffestd_R527_finish -- TARGET statement list complete
2141 ffestd_R527_finish();
2143 Just wrap up any local activities. */
2146 ffestd_R527_finish ()
2148 ffestd_check_finish_ ();
2153 fputc ('\n', dmpout
);
2158 /* ffestd_R537_start -- PARAMETER statement list begin
2160 ffestd_R537_start();
2162 Verify that PARAMETER is valid here, and begin accepting items in the list. */
2165 ffestd_R537_start ()
2167 ffestd_check_start_ ();
2170 /* ffestd_R537_item -- PARAMETER statement assignment
2172 ffestd_R537_item(dest,dest_token,source,source_token);
2174 Make sure the source is a valid source for the destination; make the
2178 ffestd_R537_item (ffebld dest UNUSED
, ffebld source UNUSED
)
2180 ffestd_check_item_ ();
2183 /* ffestd_R537_finish -- PARAMETER statement list complete
2185 ffestd_R537_finish();
2187 Just wrap up any local activities. */
2190 ffestd_R537_finish ()
2192 ffestd_check_finish_ ();
2195 /* ffestd_R539 -- IMPLICIT NONE statement
2199 Verify that the IMPLICIT NONE statement is ok here and implement. */
2204 ffestd_check_simple_ ();
2207 /* ffestd_R539start -- IMPLICIT statement
2211 Verify that the IMPLICIT statement is ok here and implement. */
2216 ffestd_check_start_ ();
2219 /* ffestd_R539item -- IMPLICIT statement specification (R540)
2221 ffestd_R539item(...);
2223 Verify that the type and letter list are all ok and implement. */
2226 ffestd_R539item (ffestpType type UNUSED
, ffebld kind UNUSED
,
2227 ffelexToken kindt UNUSED
, ffebld len UNUSED
,
2228 ffelexToken lent UNUSED
, ffesttImpList letters UNUSED
)
2230 ffestd_check_item_ ();
2233 /* ffestd_R539finish -- IMPLICIT statement
2235 ffestd_R539finish();
2237 Finish up any local activities. */
2240 ffestd_R539finish ()
2242 ffestd_check_finish_ ();
2245 /* ffestd_R542_start -- NAMELIST statement list begin
2247 ffestd_R542_start();
2249 Verify that NAMELIST is valid here, and begin accepting items in the list. */
2252 ffestd_R542_start ()
2254 ffestd_check_start_ ();
2257 /* ffestd_R542_item_nlist -- NAMELIST statement for group-name
2259 ffestd_R542_item_nlist(groupname_token);
2261 Make sure name_token identifies a valid object to be NAMELISTd. */
2264 ffestd_R542_item_nlist (ffelexToken name UNUSED
)
2266 ffestd_check_item_ ();
2269 /* ffestd_R542_item_nitem -- NAMELIST statement for variable-name
2271 ffestd_R542_item_nitem(name_token);
2273 Make sure name_token identifies a valid object to be NAMELISTd. */
2276 ffestd_R542_item_nitem (ffelexToken name UNUSED
)
2278 ffestd_check_item_ ();
2281 /* ffestd_R542_finish -- NAMELIST statement list complete
2283 ffestd_R542_finish();
2285 Just wrap up any local activities. */
2288 ffestd_R542_finish ()
2290 ffestd_check_finish_ ();
2293 /* ffestd_R544_start -- EQUIVALENCE statement list begin
2295 ffestd_R544_start();
2297 Verify that EQUIVALENCE is valid here, and begin accepting items in the
2302 ffestd_R544_start ()
2304 ffestd_check_start_ ();
2308 /* ffestd_R544_item -- EQUIVALENCE statement assignment
2310 ffestd_R544_item(exprlist);
2312 Make sure the equivalence is valid, then implement it. */
2316 ffestd_R544_item (ffesttExprList exprlist
)
2318 ffestd_check_item_ ();
2322 /* ffestd_R544_finish -- EQUIVALENCE statement list complete
2324 ffestd_R544_finish();
2326 Just wrap up any local activities. */
2330 ffestd_R544_finish ()
2332 ffestd_check_finish_ ();
2336 /* ffestd_R547_start -- COMMON statement list begin
2338 ffestd_R547_start();
2340 Verify that COMMON is valid here, and begin accepting items in the list. */
2343 ffestd_R547_start ()
2345 ffestd_check_start_ ();
2348 /* ffestd_R547_item_object -- COMMON statement for object-name
2350 ffestd_R547_item_object(name_token,dim_list);
2352 Make sure name_token identifies a valid object to be COMMONd. */
2355 ffestd_R547_item_object (ffelexToken name UNUSED
,
2356 ffesttDimList dims UNUSED
)
2358 ffestd_check_item_ ();
2361 /* ffestd_R547_item_cblock -- COMMON statement for common-block-name
2363 ffestd_R547_item_cblock(name_token);
2365 Make sure name_token identifies a valid common block to be COMMONd. */
2368 ffestd_R547_item_cblock (ffelexToken name UNUSED
)
2370 ffestd_check_item_ ();
2373 /* ffestd_R547_finish -- COMMON statement list complete
2375 ffestd_R547_finish();
2377 Just wrap up any local activities. */
2380 ffestd_R547_finish ()
2382 ffestd_check_finish_ ();
2385 /* ffestd_R620 -- ALLOCATE statement
2387 ffestd_R620(exprlist,stat,stat_token);
2389 Make sure the expression list is valid, then implement it. */
2393 ffestd_R620 (ffesttExprList exprlist
, ffebld stat
)
2395 ffestd_check_simple_ ();
2397 ffestd_subr_f90_ ();
2400 /* ffestd_R624 -- NULLIFY statement
2402 ffestd_R624(pointer_name_list);
2404 Make sure pointer_name_list identifies valid pointers for a NULLIFY. */
2407 ffestd_R624 (ffesttExprList pointers
)
2409 ffestd_check_simple_ ();
2411 ffestd_subr_f90_ ();
2415 fputs ("+ NULLIFY (", dmpout
);
2416 assert (pointers
!= NULL
);
2417 ffestt_exprlist_dump (pointers
);
2418 fputs (")\n", dmpout
);
2422 /* ffestd_R625 -- DEALLOCATE statement
2424 ffestd_R625(exprlist,stat,stat_token);
2426 Make sure the equivalence is valid, then implement it. */
2429 ffestd_R625 (ffesttExprList exprlist
, ffebld stat
)
2431 ffestd_check_simple_ ();
2433 ffestd_subr_f90_ ();
2437 /* ffestd_R737A -- Assignment statement outside of WHERE
2439 ffestd_R737A(dest_expr,source_expr); */
2442 ffestd_R737A (ffebld dest
, ffebld source
)
2446 ffestd_check_simple_ ();
2448 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR737A_
);
2449 ffestd_stmt_append_ (stmt
);
2450 ffestd_subr_line_save_ (stmt
);
2451 stmt
->u
.R737A
.pool
= ffesta_output_pool
;
2452 stmt
->u
.R737A
.dest
= dest
;
2453 stmt
->u
.R737A
.source
= source
;
2454 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE
);
2457 /* ffestd_R737B -- Assignment statement inside of WHERE
2459 ffestd_R737B(dest_expr,source_expr); */
2463 ffestd_R737B (ffebld dest
, ffebld source
)
2465 ffestd_check_simple_ ();
2468 /* ffestd_R738 -- Pointer assignment statement
2470 ffestd_R738(dest_expr,source_expr,source_token);
2472 Make sure the assignment is valid. */
2475 ffestd_R738 (ffebld dest
, ffebld source
)
2477 ffestd_check_simple_ ();
2479 ffestd_subr_f90_ ();
2482 /* ffestd_R740 -- WHERE statement
2484 ffestd_R740(expr,expr_token);
2486 Make sure statement is valid here; implement. */
2489 ffestd_R740 (ffebld expr
)
2491 ffestd_check_simple_ ();
2493 ffestd_subr_f90_ ();
2496 /* ffestd_R742 -- WHERE-construct statement
2498 ffestd_R742(expr,expr_token);
2500 Make sure statement is valid here; implement. */
2503 ffestd_R742 (ffebld expr
)
2505 ffestd_check_simple_ ();
2507 ffestd_subr_f90_ ();
2510 /* ffestd_R744 -- ELSE WHERE statement
2514 Make sure ffestd_kind_ identifies a WHERE block.
2515 Implement the ELSE of the current WHERE block. */
2520 ffestd_check_simple_ ();
2525 fputs ("+ ELSE_WHERE\n", dmpout
);
2529 /* ffestd_R745 -- Implicit END WHERE statement. */
2532 ffestd_R745 (bool ok
)
2537 fputs ("+ END_WHERE\n", dmpout
); /* Also see ffestd_R745. */
2539 --ffestd_block_level_
;
2540 assert (ffestd_block_level_
>= 0);
2546 /* Block IF (IF-THEN) statement. */
2549 ffestd_R803 (ffelexToken construct_name UNUSED
, ffebld expr
)
2553 ffestd_check_simple_ ();
2555 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR803_
);
2556 ffestd_stmt_append_ (stmt
);
2557 ffestd_subr_line_save_ (stmt
);
2558 stmt
->u
.R803
.pool
= ffesta_output_pool
;
2559 stmt
->u
.R803
.block
= ffestw_use (ffestw_stack_top ());
2560 stmt
->u
.R803
.expr
= expr
;
2561 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE
);
2563 ++ffestd_block_level_
;
2564 assert (ffestd_block_level_
> 0);
2567 /* ELSE IF statement. */
2570 ffestd_R804 (ffebld expr
, ffelexToken name UNUSED
)
2574 ffestd_check_simple_ ();
2576 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR804_
);
2577 ffestd_stmt_append_ (stmt
);
2578 ffestd_subr_line_save_ (stmt
);
2579 stmt
->u
.R804
.pool
= ffesta_output_pool
;
2580 stmt
->u
.R804
.block
= ffestw_use (ffestw_stack_top ());
2581 stmt
->u
.R804
.expr
= expr
;
2582 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE
);
2585 /* ELSE statement. */
2588 ffestd_R805 (ffelexToken name UNUSED
)
2592 ffestd_check_simple_ ();
2594 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR805_
);
2595 ffestd_stmt_append_ (stmt
);
2596 ffestd_subr_line_save_ (stmt
);
2597 stmt
->u
.R805
.block
= ffestw_use (ffestw_stack_top ());
2600 /* END IF statement. */
2603 ffestd_R806 (bool ok UNUSED
)
2607 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR806_
);
2608 ffestd_stmt_append_ (stmt
);
2609 ffestd_subr_line_save_ (stmt
);
2610 stmt
->u
.R806
.block
= ffestw_use (ffestw_stack_top ());
2612 --ffestd_block_level_
;
2613 assert (ffestd_block_level_
>= 0);
2616 /* ffestd_R807 -- Logical IF statement
2618 ffestd_R807(expr,expr_token);
2620 Make sure statement is valid here; implement. */
2623 ffestd_R807 (ffebld expr
)
2627 ffestd_check_simple_ ();
2629 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR807_
);
2630 ffestd_stmt_append_ (stmt
);
2631 ffestd_subr_line_save_ (stmt
);
2632 stmt
->u
.R807
.pool
= ffesta_output_pool
;
2633 stmt
->u
.R807
.expr
= expr
;
2634 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE
);
2636 ++ffestd_block_level_
;
2637 assert (ffestd_block_level_
> 0);
2640 /* ffestd_R809 -- SELECT CASE statement
2642 ffestd_R809(construct_name,expr,expr_token);
2644 Make sure statement is valid here; implement. */
2647 ffestd_R809 (ffelexToken construct_name UNUSED
, ffebld expr
)
2651 ffestd_check_simple_ ();
2653 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR809_
);
2654 ffestd_stmt_append_ (stmt
);
2655 ffestd_subr_line_save_ (stmt
);
2656 stmt
->u
.R809
.pool
= ffesta_output_pool
;
2657 stmt
->u
.R809
.block
= ffestw_use (ffestw_stack_top ());
2658 stmt
->u
.R809
.expr
= expr
;
2659 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE
);
2660 malloc_pool_use (ffestw_select (ffestw_stack_top ())->pool
);
2662 ++ffestd_block_level_
;
2663 assert (ffestd_block_level_
> 0);
2666 /* ffestd_R810 -- CASE statement
2668 ffestd_R810(case_value_range_list,name);
2670 If casenum is 0, it's CASE DEFAULT. Else it's the case ranges at
2671 the start of the first_stmt list in the select object at the top of
2672 the stack that match casenum. */
2675 ffestd_R810 (unsigned long casenum
)
2679 ffestd_check_simple_ ();
2681 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR810_
);
2682 ffestd_stmt_append_ (stmt
);
2683 ffestd_subr_line_save_ (stmt
);
2684 stmt
->u
.R810
.pool
= ffesta_output_pool
;
2685 stmt
->u
.R810
.block
= ffestw_stack_top ();
2686 stmt
->u
.R810
.casenum
= casenum
;
2687 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE
);
2690 /* ffestd_R811 -- End a SELECT
2692 ffestd_R811(TRUE); */
2695 ffestd_R811 (bool ok UNUSED
)
2699 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR811_
);
2700 ffestd_stmt_append_ (stmt
);
2701 ffestd_subr_line_save_ (stmt
);
2702 stmt
->u
.R811
.block
= ffestw_stack_top ();
2704 --ffestd_block_level_
;
2705 assert (ffestd_block_level_
>= 0);
2708 /* ffestd_R819A -- Iterative DO statement
2710 ffestd_R819A(construct_name,label_token,expr,expr_token);
2712 Make sure statement is valid here; implement. */
2715 ffestd_R819A (ffelexToken construct_name UNUSED
, ffelab label
,
2716 ffebld var
, ffebld start
, ffelexToken start_token
,
2717 ffebld end
, ffelexToken end_token
,
2718 ffebld incr
, ffelexToken incr_token
)
2722 ffestd_check_simple_ ();
2724 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR819A_
);
2725 ffestd_stmt_append_ (stmt
);
2726 ffestd_subr_line_save_ (stmt
);
2727 stmt
->u
.R819A
.pool
= ffesta_output_pool
;
2728 stmt
->u
.R819A
.block
= ffestw_use (ffestw_stack_top ());
2729 stmt
->u
.R819A
.label
= label
;
2730 stmt
->u
.R819A
.var
= var
;
2731 stmt
->u
.R819A
.start
= start
;
2732 stmt
->u
.R819A
.start_token
= ffelex_token_use (start_token
);
2733 stmt
->u
.R819A
.end
= end
;
2734 stmt
->u
.R819A
.end_token
= ffelex_token_use (end_token
);
2735 stmt
->u
.R819A
.incr
= incr
;
2736 stmt
->u
.R819A
.incr_token
= (incr_token
== NULL
) ? NULL
2737 : ffelex_token_use (incr_token
);
2738 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE
);
2740 ++ffestd_block_level_
;
2741 assert (ffestd_block_level_
> 0);
2744 /* ffestd_R819B -- DO WHILE statement
2746 ffestd_R819B(construct_name,label_token,expr,expr_token);
2748 Make sure statement is valid here; implement. */
2751 ffestd_R819B (ffelexToken construct_name UNUSED
, ffelab label
,
2756 ffestd_check_simple_ ();
2758 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR819B_
);
2759 ffestd_stmt_append_ (stmt
);
2760 ffestd_subr_line_save_ (stmt
);
2761 stmt
->u
.R819B
.pool
= ffesta_output_pool
;
2762 stmt
->u
.R819B
.block
= ffestw_use (ffestw_stack_top ());
2763 stmt
->u
.R819B
.label
= label
;
2764 stmt
->u
.R819B
.expr
= expr
;
2765 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE
);
2767 ++ffestd_block_level_
;
2768 assert (ffestd_block_level_
> 0);
2771 /* ffestd_R825 -- END DO statement
2773 ffestd_R825(name_token);
2775 Make sure ffestd_kind_ identifies a DO block. If not
2776 NULL, make sure name_token gives the correct name. Do whatever
2777 is specific to seeing END DO with a DO-target label definition on it,
2778 where the END DO is really treated as a CONTINUE (i.e. generate th
2779 same code you would for CONTINUE). ffestd_do handles the actual
2780 generation of end-loop code. */
2783 ffestd_R825 (ffelexToken name UNUSED
)
2787 ffestd_check_simple_ ();
2789 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR825_
);
2790 ffestd_stmt_append_ (stmt
);
2791 ffestd_subr_line_save_ (stmt
);
2794 /* ffestd_R834 -- CYCLE statement
2796 ffestd_R834(name_token);
2798 Handle a CYCLE within a loop. */
2801 ffestd_R834 (ffestw block
)
2805 ffestd_check_simple_ ();
2807 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR834_
);
2808 ffestd_stmt_append_ (stmt
);
2809 ffestd_subr_line_save_ (stmt
);
2810 stmt
->u
.R834
.block
= block
;
2813 /* ffestd_R835 -- EXIT statement
2815 ffestd_R835(name_token);
2817 Handle a EXIT within a loop. */
2820 ffestd_R835 (ffestw block
)
2824 ffestd_check_simple_ ();
2826 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR835_
);
2827 ffestd_stmt_append_ (stmt
);
2828 ffestd_subr_line_save_ (stmt
);
2829 stmt
->u
.R835
.block
= block
;
2832 /* ffestd_R836 -- GOTO statement
2836 Make sure label_token identifies a valid label for a GOTO. Update
2837 that label's info to indicate it is the target of a GOTO. */
2840 ffestd_R836 (ffelab label
)
2844 ffestd_check_simple_ ();
2846 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR836_
);
2847 ffestd_stmt_append_ (stmt
);
2848 ffestd_subr_line_save_ (stmt
);
2849 stmt
->u
.R836
.label
= label
;
2851 if (ffestd_block_level_
== 0)
2852 ffestd_is_reachable_
= FALSE
;
2855 /* ffestd_R837 -- Computed GOTO statement
2857 ffestd_R837(labels,expr);
2859 Make sure label_list identifies valid labels for a GOTO. Update
2860 each label's info to indicate it is the target of a GOTO. */
2863 ffestd_R837 (ffelab
*labels
, int count
, ffebld expr
)
2867 ffestd_check_simple_ ();
2869 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR837_
);
2870 ffestd_stmt_append_ (stmt
);
2871 ffestd_subr_line_save_ (stmt
);
2872 stmt
->u
.R837
.pool
= ffesta_output_pool
;
2873 stmt
->u
.R837
.labels
= labels
;
2874 stmt
->u
.R837
.count
= count
;
2875 stmt
->u
.R837
.expr
= expr
;
2876 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE
);
2879 /* ffestd_R838 -- ASSIGN statement
2881 ffestd_R838(label_token,target_variable,target_token);
2883 Make sure label_token identifies a valid label for an assignment. Update
2884 that label's info to indicate it is the source of an assignment. Update
2885 target_variable's info to indicate it is the target the assignment of that
2889 ffestd_R838 (ffelab label
, ffebld target
)
2893 ffestd_check_simple_ ();
2895 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR838_
);
2896 ffestd_stmt_append_ (stmt
);
2897 ffestd_subr_line_save_ (stmt
);
2898 stmt
->u
.R838
.pool
= ffesta_output_pool
;
2899 stmt
->u
.R838
.label
= label
;
2900 stmt
->u
.R838
.target
= target
;
2901 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE
);
2904 /* ffestd_R839 -- Assigned GOTO statement
2906 ffestd_R839(target,labels);
2908 Make sure label_list identifies valid labels for a GOTO. Update
2909 each label's info to indicate it is the target of a GOTO. */
2912 ffestd_R839 (ffebld target
, ffelab
*labels UNUSED
, int count UNUSED
)
2916 ffestd_check_simple_ ();
2918 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR839_
);
2919 ffestd_stmt_append_ (stmt
);
2920 ffestd_subr_line_save_ (stmt
);
2921 stmt
->u
.R839
.pool
= ffesta_output_pool
;
2922 stmt
->u
.R839
.target
= target
;
2923 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE
);
2925 if (ffestd_block_level_
== 0)
2926 ffestd_is_reachable_
= FALSE
;
2929 /* ffestd_R840 -- Arithmetic IF statement
2931 ffestd_R840(expr,expr_token,neg,zero,pos);
2933 Make sure the labels are valid; implement. */
2936 ffestd_R840 (ffebld expr
, ffelab neg
, ffelab zero
, ffelab pos
)
2940 ffestd_check_simple_ ();
2942 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR840_
);
2943 ffestd_stmt_append_ (stmt
);
2944 ffestd_subr_line_save_ (stmt
);
2945 stmt
->u
.R840
.pool
= ffesta_output_pool
;
2946 stmt
->u
.R840
.expr
= expr
;
2947 stmt
->u
.R840
.neg
= neg
;
2948 stmt
->u
.R840
.zero
= zero
;
2949 stmt
->u
.R840
.pos
= pos
;
2950 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE
);
2952 if (ffestd_block_level_
== 0)
2953 ffestd_is_reachable_
= FALSE
;
2956 /* ffestd_R841 -- CONTINUE statement
2961 ffestd_R841 (bool in_where UNUSED
)
2965 ffestd_check_simple_ ();
2967 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR841_
);
2968 ffestd_stmt_append_ (stmt
);
2969 ffestd_subr_line_save_ (stmt
);
2972 /* ffestd_R842 -- STOP statement
2974 ffestd_R842(expr); */
2977 ffestd_R842 (ffebld expr
)
2981 ffestd_check_simple_ ();
2983 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR842_
);
2984 ffestd_stmt_append_ (stmt
);
2985 ffestd_subr_line_save_ (stmt
);
2986 if (ffesta_outpooldisp () == FFESTA_pooldispPRESERVE
)
2988 /* This is a "spurious" (automatically-generated) STOP
2989 that follows a previous STOP or other statement.
2990 Make sure we don't have an expression in the pool,
2991 and then mark that the pool has already been killed. */
2992 assert (expr
== NULL
);
2993 stmt
->u
.R842
.pool
= NULL
;
2994 stmt
->u
.R842
.expr
= NULL
;
2998 stmt
->u
.R842
.pool
= ffesta_output_pool
;
2999 stmt
->u
.R842
.expr
= expr
;
3000 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE
);
3003 if (ffestd_block_level_
== 0)
3004 ffestd_is_reachable_
= FALSE
;
3007 /* ffestd_R843 -- PAUSE statement
3009 ffestd_R843(expr,expr_token);
3011 Make sure statement is valid here; implement. expr and expr_token are
3012 both NULL if there was no expression. */
3015 ffestd_R843 (ffebld expr
)
3019 ffestd_check_simple_ ();
3021 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR843_
);
3022 ffestd_stmt_append_ (stmt
);
3023 ffestd_subr_line_save_ (stmt
);
3024 stmt
->u
.R843
.pool
= ffesta_output_pool
;
3025 stmt
->u
.R843
.expr
= expr
;
3026 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE
);
3029 /* ffestd_R904 -- OPEN statement
3033 Make sure an OPEN is valid in the current context, and implement it. */
3040 ffestd_check_simple_ ();
3042 #define specified(something) \
3043 (ffestp_file.open.open_spec[something].kw_or_val_present)
3045 /* Warn if there are any thing we don't handle via f2c libraries. */
3047 if (specified (FFESTP_openixACTION
)
3048 || specified (FFESTP_openixASSOCIATEVARIABLE
)
3049 || specified (FFESTP_openixBLOCKSIZE
)
3050 || specified (FFESTP_openixBUFFERCOUNT
)
3051 || specified (FFESTP_openixCARRIAGECONTROL
)
3052 || specified (FFESTP_openixDEFAULTFILE
)
3053 || specified (FFESTP_openixDELIM
)
3054 || specified (FFESTP_openixDISPOSE
)
3055 || specified (FFESTP_openixEXTENDSIZE
)
3056 || specified (FFESTP_openixINITIALSIZE
)
3057 || specified (FFESTP_openixKEY
)
3058 || specified (FFESTP_openixMAXREC
)
3059 || specified (FFESTP_openixNOSPANBLOCKS
)
3060 || specified (FFESTP_openixORGANIZATION
)
3061 || specified (FFESTP_openixPAD
)
3062 || specified (FFESTP_openixPOSITION
)
3063 || specified (FFESTP_openixREADONLY
)
3064 || specified (FFESTP_openixRECORDTYPE
)
3065 || specified (FFESTP_openixSHARED
)
3066 || specified (FFESTP_openixUSEROPEN
))
3068 ffebad_start (FFEBAD_OPEN_UNSUPPORTED
);
3069 ffebad_here (0, ffelex_token_where_line (ffesta_tokens
[0]),
3070 ffelex_token_where_column (ffesta_tokens
[0]));
3076 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR904_
);
3077 ffestd_stmt_append_ (stmt
);
3078 ffestd_subr_line_save_ (stmt
);
3079 stmt
->u
.R904
.pool
= ffesta_output_pool
;
3080 stmt
->u
.R904
.params
= ffestd_subr_copy_open_ ();
3081 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE
);
3084 /* ffestd_R907 -- CLOSE statement
3088 Make sure a CLOSE is valid in the current context, and implement it. */
3095 ffestd_check_simple_ ();
3097 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR907_
);
3098 ffestd_stmt_append_ (stmt
);
3099 ffestd_subr_line_save_ (stmt
);
3100 stmt
->u
.R907
.pool
= ffesta_output_pool
;
3101 stmt
->u
.R907
.params
= ffestd_subr_copy_close_ ();
3102 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE
);
3105 /* ffestd_R909_start -- READ(...) statement list begin
3107 ffestd_R909_start(FALSE);
3109 Verify that READ is valid here, and begin accepting items in the
3113 ffestd_R909_start (bool only_format
, ffestvUnit unit
,
3114 ffestvFormat format
, bool rec
, bool key
)
3118 ffestd_check_start_ ();
3120 #define specified(something) \
3121 (ffestp_file.read.read_spec[something].kw_or_val_present)
3123 /* Warn if there are any thing we don't handle via f2c libraries. */
3124 if (specified (FFESTP_readixADVANCE
)
3125 || specified (FFESTP_readixEOR
)
3126 || specified (FFESTP_readixKEYEQ
)
3127 || specified (FFESTP_readixKEYGE
)
3128 || specified (FFESTP_readixKEYGT
)
3129 || specified (FFESTP_readixKEYID
)
3130 || specified (FFESTP_readixNULLS
)
3131 || specified (FFESTP_readixSIZE
))
3133 ffebad_start (FFEBAD_READ_UNSUPPORTED
);
3134 ffebad_here (0, ffelex_token_where_line (ffesta_tokens
[0]),
3135 ffelex_token_where_column (ffesta_tokens
[0]));
3141 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR909_
);
3142 ffestd_stmt_append_ (stmt
);
3143 ffestd_subr_line_save_ (stmt
);
3144 stmt
->u
.R909
.pool
= ffesta_output_pool
;
3145 stmt
->u
.R909
.params
= ffestd_subr_copy_read_ ();
3146 stmt
->u
.R909
.only_format
= only_format
;
3147 stmt
->u
.R909
.unit
= unit
;
3148 stmt
->u
.R909
.format
= format
;
3149 stmt
->u
.R909
.rec
= rec
;
3150 stmt
->u
.R909
.key
= key
;
3151 stmt
->u
.R909
.list
= NULL
;
3152 ffestd_expr_list_
= &stmt
->u
.R909
.list
;
3153 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE
);
3156 /* ffestd_R909_item -- READ statement i/o item
3158 ffestd_R909_item(expr,expr_token);
3160 Implement output-list expression. */
3163 ffestd_R909_item (ffebld expr
, ffelexToken expr_token
)
3165 ffestdExprItem_ item
;
3167 ffestd_check_item_ ();
3169 item
= (ffestdExprItem_
) malloc_new_kp (ffesta_output_pool
,
3170 "ffestdExprItem_", sizeof (*item
));
3174 item
->token
= ffelex_token_use (expr_token
);
3175 *ffestd_expr_list_
= item
;
3176 ffestd_expr_list_
= &item
->next
;
3179 /* ffestd_R909_finish -- READ statement list complete
3181 ffestd_R909_finish();
3183 Just wrap up any local activities. */
3186 ffestd_R909_finish ()
3188 ffestd_check_finish_ ();
3191 /* ffestd_R910_start -- WRITE(...) statement list begin
3193 ffestd_R910_start();
3195 Verify that WRITE is valid here, and begin accepting items in the
3199 ffestd_R910_start (ffestvUnit unit
, ffestvFormat format
, bool rec
)
3203 ffestd_check_start_ ();
3205 #define specified(something) \
3206 (ffestp_file.write.write_spec[something].kw_or_val_present)
3208 /* Warn if there are any thing we don't handle via f2c libraries. */
3209 if (specified (FFESTP_writeixADVANCE
)
3210 || specified (FFESTP_writeixEOR
))
3212 ffebad_start (FFEBAD_WRITE_UNSUPPORTED
);
3213 ffebad_here (0, ffelex_token_where_line (ffesta_tokens
[0]),
3214 ffelex_token_where_column (ffesta_tokens
[0]));
3220 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR910_
);
3221 ffestd_stmt_append_ (stmt
);
3222 ffestd_subr_line_save_ (stmt
);
3223 stmt
->u
.R910
.pool
= ffesta_output_pool
;
3224 stmt
->u
.R910
.params
= ffestd_subr_copy_write_ ();
3225 stmt
->u
.R910
.unit
= unit
;
3226 stmt
->u
.R910
.format
= format
;
3227 stmt
->u
.R910
.rec
= rec
;
3228 stmt
->u
.R910
.list
= NULL
;
3229 ffestd_expr_list_
= &stmt
->u
.R910
.list
;
3230 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE
);
3233 /* ffestd_R910_item -- WRITE statement i/o item
3235 ffestd_R910_item(expr,expr_token);
3237 Implement output-list expression. */
3240 ffestd_R910_item (ffebld expr
, ffelexToken expr_token
)
3242 ffestdExprItem_ item
;
3244 ffestd_check_item_ ();
3246 item
= (ffestdExprItem_
) malloc_new_kp (ffesta_output_pool
,
3247 "ffestdExprItem_", sizeof (*item
));
3251 item
->token
= ffelex_token_use (expr_token
);
3252 *ffestd_expr_list_
= item
;
3253 ffestd_expr_list_
= &item
->next
;
3256 /* ffestd_R910_finish -- WRITE statement list complete
3258 ffestd_R910_finish();
3260 Just wrap up any local activities. */
3263 ffestd_R910_finish ()
3265 ffestd_check_finish_ ();
3268 /* ffestd_R911_start -- PRINT statement list begin
3270 ffestd_R911_start();
3272 Verify that PRINT is valid here, and begin accepting items in the
3276 ffestd_R911_start (ffestvFormat format
)
3280 ffestd_check_start_ ();
3282 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR911_
);
3283 ffestd_stmt_append_ (stmt
);
3284 ffestd_subr_line_save_ (stmt
);
3285 stmt
->u
.R911
.pool
= ffesta_output_pool
;
3286 stmt
->u
.R911
.params
= ffestd_subr_copy_print_ ();
3287 stmt
->u
.R911
.format
= format
;
3288 stmt
->u
.R911
.list
= NULL
;
3289 ffestd_expr_list_
= &stmt
->u
.R911
.list
;
3290 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE
);
3293 /* ffestd_R911_item -- PRINT statement i/o item
3295 ffestd_R911_item(expr,expr_token);
3297 Implement output-list expression. */
3300 ffestd_R911_item (ffebld expr
, ffelexToken expr_token
)
3302 ffestdExprItem_ item
;
3304 ffestd_check_item_ ();
3306 item
= (ffestdExprItem_
) malloc_new_kp (ffesta_output_pool
,
3307 "ffestdExprItem_", sizeof (*item
));
3311 item
->token
= ffelex_token_use (expr_token
);
3312 *ffestd_expr_list_
= item
;
3313 ffestd_expr_list_
= &item
->next
;
3316 /* ffestd_R911_finish -- PRINT statement list complete
3318 ffestd_R911_finish();
3320 Just wrap up any local activities. */
3323 ffestd_R911_finish ()
3325 ffestd_check_finish_ ();
3328 /* ffestd_R919 -- BACKSPACE statement
3332 Make sure a BACKSPACE is valid in the current context, and implement it. */
3339 ffestd_check_simple_ ();
3341 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR919_
);
3342 ffestd_stmt_append_ (stmt
);
3343 ffestd_subr_line_save_ (stmt
);
3344 stmt
->u
.R919
.pool
= ffesta_output_pool
;
3345 stmt
->u
.R919
.params
= ffestd_subr_copy_beru_ ();
3346 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE
);
3349 /* ffestd_R920 -- ENDFILE statement
3353 Make sure a ENDFILE is valid in the current context, and implement it. */
3360 ffestd_check_simple_ ();
3362 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR920_
);
3363 ffestd_stmt_append_ (stmt
);
3364 ffestd_subr_line_save_ (stmt
);
3365 stmt
->u
.R920
.pool
= ffesta_output_pool
;
3366 stmt
->u
.R920
.params
= ffestd_subr_copy_beru_ ();
3367 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE
);
3370 /* ffestd_R921 -- REWIND statement
3374 Make sure a REWIND is valid in the current context, and implement it. */
3381 ffestd_check_simple_ ();
3383 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR921_
);
3384 ffestd_stmt_append_ (stmt
);
3385 ffestd_subr_line_save_ (stmt
);
3386 stmt
->u
.R921
.pool
= ffesta_output_pool
;
3387 stmt
->u
.R921
.params
= ffestd_subr_copy_beru_ ();
3388 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE
);
3391 /* ffestd_R923A -- INQUIRE statement (non-IOLENGTH version)
3393 ffestd_R923A(bool by_file);
3395 Make sure an INQUIRE is valid in the current context, and implement it. */
3398 ffestd_R923A (bool by_file
)
3402 ffestd_check_simple_ ();
3404 #define specified(something) \
3405 (ffestp_file.inquire.inquire_spec[something].kw_or_val_present)
3407 /* Warn if there are any thing we don't handle via f2c libraries. */
3408 if (specified (FFESTP_inquireixACTION
)
3409 || specified (FFESTP_inquireixCARRIAGECONTROL
)
3410 || specified (FFESTP_inquireixDEFAULTFILE
)
3411 || specified (FFESTP_inquireixDELIM
)
3412 || specified (FFESTP_inquireixKEYED
)
3413 || specified (FFESTP_inquireixORGANIZATION
)
3414 || specified (FFESTP_inquireixPAD
)
3415 || specified (FFESTP_inquireixPOSITION
)
3416 || specified (FFESTP_inquireixREAD
)
3417 || specified (FFESTP_inquireixREADWRITE
)
3418 || specified (FFESTP_inquireixRECORDTYPE
)
3419 || specified (FFESTP_inquireixWRITE
))
3421 ffebad_start (FFEBAD_INQUIRE_UNSUPPORTED
);
3422 ffebad_here (0, ffelex_token_where_line (ffesta_tokens
[0]),
3423 ffelex_token_where_column (ffesta_tokens
[0]));
3429 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR923A_
);
3430 ffestd_stmt_append_ (stmt
);
3431 ffestd_subr_line_save_ (stmt
);
3432 stmt
->u
.R923A
.pool
= ffesta_output_pool
;
3433 stmt
->u
.R923A
.params
= ffestd_subr_copy_inquire_ ();
3434 stmt
->u
.R923A
.by_file
= by_file
;
3435 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE
);
3438 /* ffestd_R923B_start -- INQUIRE(IOLENGTH=expr) statement list begin
3440 ffestd_R923B_start();
3442 Verify that INQUIRE is valid here, and begin accepting items in the
3446 ffestd_R923B_start ()
3450 ffestd_check_start_ ();
3452 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR923B_
);
3453 ffestd_stmt_append_ (stmt
);
3454 ffestd_subr_line_save_ (stmt
);
3455 stmt
->u
.R923B
.pool
= ffesta_output_pool
;
3456 stmt
->u
.R923B
.params
= ffestd_subr_copy_inquire_ ();
3457 stmt
->u
.R923B
.list
= NULL
;
3458 ffestd_expr_list_
= &stmt
->u
.R923B
.list
;
3459 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE
);
3462 /* ffestd_R923B_item -- INQUIRE statement i/o item
3464 ffestd_R923B_item(expr,expr_token);
3466 Implement output-list expression. */
3469 ffestd_R923B_item (ffebld expr
)
3471 ffestdExprItem_ item
;
3473 ffestd_check_item_ ();
3475 item
= (ffestdExprItem_
) malloc_new_kp (ffesta_output_pool
,
3476 "ffestdExprItem_", sizeof (*item
));
3480 *ffestd_expr_list_
= item
;
3481 ffestd_expr_list_
= &item
->next
;
3484 /* ffestd_R923B_finish -- INQUIRE statement list complete
3486 ffestd_R923B_finish();
3488 Just wrap up any local activities. */
3491 ffestd_R923B_finish ()
3493 ffestd_check_finish_ ();
3496 /* ffestd_R1001 -- FORMAT statement
3498 ffestd_R1001(format_list); */
3501 ffestd_R1001 (ffesttFormatList f
)
3507 ffestd_check_simple_ ();
3509 if (ffestd_label_formatdef_
== NULL
)
3510 return; /* Nothing to hook it up to (no label def). */
3512 ffests_new (s
, malloc_pool_image (), 80);
3513 ffests_putc (s
, '(');
3514 ffestd_R1001dump_ (s
, f
); /* Build the string in s. */
3515 ffests_putc (s
, ')');
3517 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR1001_
);
3518 ffestd_stmt_append_ (stmt
);
3519 stmt
->u
.R1001
.str
= str
;
3521 ffestd_label_formatdef_
= NULL
;
3524 /* ffestd_R1001dump_ -- Dump list of formats
3526 ffesttFormatList list;
3527 ffestd_R1001dump_(list,0);
3529 The formats in the list are dumped. */
3532 ffestd_R1001dump_ (ffests s
, ffesttFormatList list
)
3534 ffesttFormatList next
;
3536 for (next
= list
->next
; next
!= list
; next
= next
->next
)
3538 if (next
!= list
->next
)
3539 ffests_putc (s
, ',');
3542 case FFESTP_formattypeI
:
3543 ffestd_R1001dump_1005_3_ (s
, next
, "I");
3546 case FFESTP_formattypeB
:
3547 ffestd_R1001error_ (next
);
3550 case FFESTP_formattypeO
:
3551 ffestd_R1001dump_1005_3_ (s
, next
, "O");
3554 case FFESTP_formattypeZ
:
3555 ffestd_R1001dump_1005_3_ (s
, next
, "Z");
3558 case FFESTP_formattypeF
:
3559 ffestd_R1001dump_1005_4_ (s
, next
, "F");
3562 case FFESTP_formattypeE
:
3563 ffestd_R1001dump_1005_5_ (s
, next
, "E");
3566 case FFESTP_formattypeEN
:
3567 ffestd_R1001error_ (next
);
3570 case FFESTP_formattypeG
:
3571 ffestd_R1001dump_1005_5_ (s
, next
, "G");
3574 case FFESTP_formattypeL
:
3575 ffestd_R1001dump_1005_2_ (s
, next
, "L");
3578 case FFESTP_formattypeA
:
3579 ffestd_R1001dump_1005_1_ (s
, next
, "A");
3582 case FFESTP_formattypeD
:
3583 ffestd_R1001dump_1005_4_ (s
, next
, "D");
3586 case FFESTP_formattypeQ
:
3587 ffestd_R1001error_ (next
);
3590 case FFESTP_formattypeDOLLAR
:
3591 ffestd_R1001dump_1010_1_ (s
, next
, "$");
3594 case FFESTP_formattypeP
:
3595 ffestd_R1001dump_1010_4_ (s
, next
, "P");
3598 case FFESTP_formattypeT
:
3599 ffestd_R1001dump_1010_5_ (s
, next
, "T");
3602 case FFESTP_formattypeTL
:
3603 ffestd_R1001dump_1010_5_ (s
, next
, "TL");
3606 case FFESTP_formattypeTR
:
3607 ffestd_R1001dump_1010_5_ (s
, next
, "TR");
3610 case FFESTP_formattypeX
:
3611 ffestd_R1001dump_1010_3_ (s
, next
, "X");
3614 case FFESTP_formattypeS
:
3615 ffestd_R1001dump_1010_1_ (s
, next
, "S");
3618 case FFESTP_formattypeSP
:
3619 ffestd_R1001dump_1010_1_ (s
, next
, "SP");
3622 case FFESTP_formattypeSS
:
3623 ffestd_R1001dump_1010_1_ (s
, next
, "SS");
3626 case FFESTP_formattypeBN
:
3627 ffestd_R1001dump_1010_1_ (s
, next
, "BN");
3630 case FFESTP_formattypeBZ
:
3631 ffestd_R1001dump_1010_1_ (s
, next
, "BZ");
3634 case FFESTP_formattypeSLASH
:
3635 ffestd_R1001dump_1010_2_ (s
, next
, "/");
3638 case FFESTP_formattypeCOLON
:
3639 ffestd_R1001dump_1010_1_ (s
, next
, ":");
3642 case FFESTP_formattypeR1016
:
3643 switch (ffelex_token_type (next
->t
))
3645 case FFELEX_typeCHARACTER
:
3647 char *p
= ffelex_token_text (next
->t
);
3648 ffeTokenLength i
= ffelex_token_length (next
->t
);
3650 ffests_putc (s
, '\002');
3654 ffests_putc (s
, '\002');
3655 ffests_putc (s
, *p
);
3658 ffests_putc (s
, '\002');
3662 case FFELEX_typeHOLLERITH
:
3664 char *p
= ffelex_token_text (next
->t
);
3665 ffeTokenLength i
= ffelex_token_length (next
->t
);
3667 ffests_printf (s
, "%" ffeTokenLength_f
"uH", i
);
3670 ffests_putc (s
, *p
);
3681 case FFESTP_formattypeFORMAT
:
3682 if (next
->u
.R1003D
.R1004
.present
)
3684 if (next
->u
.R1003D
.R1004
.rtexpr
)
3685 ffestd_R1001rtexpr_ (s
, next
, next
->u
.R1003D
.R1004
.u
.expr
);
3687 ffests_printf (s
, "%lu", next
->u
.R1003D
.R1004
.u
.unsigned_val
);
3690 ffests_putc (s
, '(');
3691 ffestd_R1001dump_ (s
, next
->u
.R1003D
.format
);
3692 ffests_putc (s
, ')');
3701 /* ffestd_R1001dump_1005_1_ -- Dump a particular format
3704 ffestd_R1001dump_1005_1_(f,"I");
3706 The format is dumped with form [r]X[w]. */
3709 ffestd_R1001dump_1005_1_ (ffests s
, ffesttFormatList f
, const char *string
)
3711 assert (!f
->u
.R1005
.R1007_or_R1008
.present
);
3712 assert (!f
->u
.R1005
.R1009
.present
);
3714 if (f
->u
.R1005
.R1004
.present
)
3716 if (f
->u
.R1005
.R1004
.rtexpr
)
3717 ffestd_R1001rtexpr_ (s
, f
, f
->u
.R1005
.R1004
.u
.expr
);
3719 ffests_printf (s
, "%lu", f
->u
.R1005
.R1004
.u
.unsigned_val
);
3722 ffests_puts (s
, string
);
3724 if (f
->u
.R1005
.R1006
.present
)
3726 if (f
->u
.R1005
.R1006
.rtexpr
)
3727 ffestd_R1001rtexpr_ (s
, f
, f
->u
.R1005
.R1006
.u
.expr
);
3729 ffests_printf (s
, "%lu", f
->u
.R1005
.R1006
.u
.unsigned_val
);
3733 /* ffestd_R1001dump_1005_2_ -- Dump a particular format
3736 ffestd_R1001dump_1005_2_(f,"I");
3738 The format is dumped with form [r]Xw. */
3741 ffestd_R1001dump_1005_2_ (ffests s
, ffesttFormatList f
, const char *string
)
3743 assert (!f
->u
.R1005
.R1007_or_R1008
.present
);
3744 assert (!f
->u
.R1005
.R1009
.present
);
3745 assert (f
->u
.R1005
.R1006
.present
);
3747 if (f
->u
.R1005
.R1004
.present
)
3749 if (f
->u
.R1005
.R1004
.rtexpr
)
3750 ffestd_R1001rtexpr_ (s
, f
, f
->u
.R1005
.R1004
.u
.expr
);
3752 ffests_printf (s
, "%lu", f
->u
.R1005
.R1004
.u
.unsigned_val
);
3755 ffests_puts (s
, string
);
3757 if (f
->u
.R1005
.R1006
.rtexpr
)
3758 ffestd_R1001rtexpr_ (s
, f
, f
->u
.R1005
.R1006
.u
.expr
);
3760 ffests_printf (s
, "%lu", f
->u
.R1005
.R1006
.u
.unsigned_val
);
3763 /* ffestd_R1001dump_1005_3_ -- Dump a particular format
3766 ffestd_R1001dump_1005_3_(f,"I");
3768 The format is dumped with form [r]Xw[.m]. */
3771 ffestd_R1001dump_1005_3_ (ffests s
, ffesttFormatList f
, const char *string
)
3773 assert (!f
->u
.R1005
.R1009
.present
);
3774 assert (f
->u
.R1005
.R1006
.present
);
3776 if (f
->u
.R1005
.R1004
.present
)
3778 if (f
->u
.R1005
.R1004
.rtexpr
)
3779 ffestd_R1001rtexpr_ (s
, f
, f
->u
.R1005
.R1004
.u
.expr
);
3781 ffests_printf (s
, "%lu", f
->u
.R1005
.R1004
.u
.unsigned_val
);
3784 ffests_puts (s
, string
);
3786 if (f
->u
.R1005
.R1006
.rtexpr
)
3787 ffestd_R1001rtexpr_ (s
, f
, f
->u
.R1005
.R1006
.u
.expr
);
3789 ffests_printf (s
, "%lu", f
->u
.R1005
.R1006
.u
.unsigned_val
);
3791 if (f
->u
.R1005
.R1007_or_R1008
.present
)
3793 ffests_putc (s
, '.');
3794 if (f
->u
.R1005
.R1007_or_R1008
.rtexpr
)
3795 ffestd_R1001rtexpr_ (s
, f
, f
->u
.R1005
.R1007_or_R1008
.u
.expr
);
3797 ffests_printf (s
, "%lu", f
->u
.R1005
.R1007_or_R1008
.u
.unsigned_val
);
3801 /* ffestd_R1001dump_1005_4_ -- Dump a particular format
3804 ffestd_R1001dump_1005_4_(f,"I");
3806 The format is dumped with form [r]Xw.d. */
3809 ffestd_R1001dump_1005_4_ (ffests s
, ffesttFormatList f
, const char *string
)
3811 assert (!f
->u
.R1005
.R1009
.present
);
3812 assert (f
->u
.R1005
.R1007_or_R1008
.present
);
3813 assert (f
->u
.R1005
.R1006
.present
);
3815 if (f
->u
.R1005
.R1004
.present
)
3817 if (f
->u
.R1005
.R1004
.rtexpr
)
3818 ffestd_R1001rtexpr_ (s
, f
, f
->u
.R1005
.R1004
.u
.expr
);
3820 ffests_printf (s
, "%lu", f
->u
.R1005
.R1004
.u
.unsigned_val
);
3823 ffests_puts (s
, string
);
3825 if (f
->u
.R1005
.R1006
.rtexpr
)
3826 ffestd_R1001rtexpr_ (s
, f
, f
->u
.R1005
.R1006
.u
.expr
);
3828 ffests_printf (s
, "%lu", f
->u
.R1005
.R1006
.u
.unsigned_val
);
3830 ffests_putc (s
, '.');
3831 if (f
->u
.R1005
.R1007_or_R1008
.rtexpr
)
3832 ffestd_R1001rtexpr_ (s
, f
, f
->u
.R1005
.R1007_or_R1008
.u
.expr
);
3834 ffests_printf (s
, "%lu", f
->u
.R1005
.R1007_or_R1008
.u
.unsigned_val
);
3837 /* ffestd_R1001dump_1005_5_ -- Dump a particular format
3840 ffestd_R1001dump_1005_5_(f,"I");
3842 The format is dumped with form [r]Xw.d[Ee]. */
3845 ffestd_R1001dump_1005_5_ (ffests s
, ffesttFormatList f
, const char *string
)
3847 assert (f
->u
.R1005
.R1007_or_R1008
.present
);
3848 assert (f
->u
.R1005
.R1006
.present
);
3850 if (f
->u
.R1005
.R1004
.present
)
3852 if (f
->u
.R1005
.R1004
.rtexpr
)
3853 ffestd_R1001rtexpr_ (s
, f
, f
->u
.R1005
.R1004
.u
.expr
);
3855 ffests_printf (s
, "%lu", f
->u
.R1005
.R1004
.u
.unsigned_val
);
3858 ffests_puts (s
, string
);
3860 if (f
->u
.R1005
.R1006
.rtexpr
)
3861 ffestd_R1001rtexpr_ (s
, f
, f
->u
.R1005
.R1006
.u
.expr
);
3863 ffests_printf (s
, "%lu", f
->u
.R1005
.R1006
.u
.unsigned_val
);
3865 ffests_putc (s
, '.');
3866 if (f
->u
.R1005
.R1007_or_R1008
.rtexpr
)
3867 ffestd_R1001rtexpr_ (s
, f
, f
->u
.R1005
.R1007_or_R1008
.u
.expr
);
3869 ffests_printf (s
, "%lu", f
->u
.R1005
.R1007_or_R1008
.u
.unsigned_val
);
3871 if (f
->u
.R1005
.R1009
.present
)
3873 ffests_putc (s
, 'E');
3874 if (f
->u
.R1005
.R1009
.rtexpr
)
3875 ffestd_R1001rtexpr_ (s
, f
, f
->u
.R1005
.R1009
.u
.expr
);
3877 ffests_printf (s
, "%lu", f
->u
.R1005
.R1009
.u
.unsigned_val
);
3881 /* ffestd_R1001dump_1010_1_ -- Dump a particular format
3884 ffestd_R1001dump_1010_1_(f,"I");
3886 The format is dumped with form X. */
3889 ffestd_R1001dump_1010_1_ (ffests s
, ffesttFormatList f
, const char *string
)
3891 assert (!f
->u
.R1010
.val
.present
);
3893 ffests_puts (s
, string
);
3896 /* ffestd_R1001dump_1010_2_ -- Dump a particular format
3899 ffestd_R1001dump_1010_2_(f,"I");
3901 The format is dumped with form [r]X. */
3904 ffestd_R1001dump_1010_2_ (ffests s
, ffesttFormatList f
, const char *string
)
3906 if (f
->u
.R1010
.val
.present
)
3908 if (f
->u
.R1010
.val
.rtexpr
)
3909 ffestd_R1001rtexpr_ (s
, f
, f
->u
.R1010
.val
.u
.expr
);
3911 ffests_printf (s
, "%lu", f
->u
.R1010
.val
.u
.unsigned_val
);
3914 ffests_puts (s
, string
);
3917 /* ffestd_R1001dump_1010_3_ -- Dump a particular format
3920 ffestd_R1001dump_1010_3_(f,"I");
3922 The format is dumped with form nX. */
3925 ffestd_R1001dump_1010_3_ (ffests s
, ffesttFormatList f
, const char *string
)
3927 assert (f
->u
.R1010
.val
.present
);
3929 if (f
->u
.R1010
.val
.rtexpr
)
3930 ffestd_R1001rtexpr_ (s
, f
, f
->u
.R1010
.val
.u
.expr
);
3932 ffests_printf (s
, "%lu", f
->u
.R1010
.val
.u
.unsigned_val
);
3934 ffests_puts (s
, string
);
3937 /* ffestd_R1001dump_1010_4_ -- Dump a particular format
3940 ffestd_R1001dump_1010_4_(f,"I");
3942 The format is dumped with form kX. Note that k is signed. */
3945 ffestd_R1001dump_1010_4_ (ffests s
, ffesttFormatList f
, const char *string
)
3947 assert (f
->u
.R1010
.val
.present
);
3949 if (f
->u
.R1010
.val
.rtexpr
)
3950 ffestd_R1001rtexpr_ (s
, f
, f
->u
.R1010
.val
.u
.expr
);
3952 ffests_printf (s
, "%ld", f
->u
.R1010
.val
.u
.signed_val
);
3954 ffests_puts (s
, string
);
3957 /* ffestd_R1001dump_1010_5_ -- Dump a particular format
3960 ffestd_R1001dump_1010_5_(f,"I");
3962 The format is dumped with form Xn. */
3965 ffestd_R1001dump_1010_5_ (ffests s
, ffesttFormatList f
, const char *string
)
3967 assert (f
->u
.R1010
.val
.present
);
3969 ffests_puts (s
, string
);
3971 if (f
->u
.R1010
.val
.rtexpr
)
3972 ffestd_R1001rtexpr_ (s
, f
, f
->u
.R1010
.val
.u
.expr
);
3974 ffests_printf (s
, "%lu", f
->u
.R1010
.val
.u
.unsigned_val
);
3977 /* ffestd_R1001error_ -- Complain about FORMAT specification not supported
3980 ffestd_R1001error_(f);
3982 An error message is produced. */
3985 ffestd_R1001error_ (ffesttFormatList f
)
3987 ffebad_start (FFEBAD_FORMAT_UNSUPPORTED
);
3988 ffebad_here (0, ffelex_token_where_line (f
->t
), ffelex_token_where_column (f
->t
));
3993 ffestd_R1001rtexpr_ (ffests s
, ffesttFormatList f
, ffebld expr
)
3996 || (ffebld_op (expr
) != FFEBLD_opCONTER
)
3997 || (ffeinfo_basictype (ffebld_info (expr
)) != FFEINFO_basictypeINTEGER
)
3998 || (ffeinfo_kindtype (ffebld_info (expr
)) == FFEINFO_kindtypeINTEGER4
))
4000 ffebad_start (FFEBAD_FORMAT_VARIABLE
);
4001 ffebad_here (0, ffelex_token_where_line (f
->t
), ffelex_token_where_column (f
->t
));
4008 switch (ffeinfo_kindtype (ffebld_info (expr
)))
4010 #if FFETARGET_okINTEGER1
4011 case FFEINFO_kindtypeINTEGER1
:
4012 val
= ffebld_constant_integer1 (ffebld_conter (expr
));
4016 #if FFETARGET_okINTEGER2
4017 case FFEINFO_kindtypeINTEGER2
:
4018 val
= ffebld_constant_integer2 (ffebld_conter (expr
));
4022 #if FFETARGET_okINTEGER3
4023 case FFEINFO_kindtypeINTEGER3
:
4024 val
= ffebld_constant_integer3 (ffebld_conter (expr
));
4029 assert ("bad INTEGER constant kind type" == NULL
);
4031 case FFEINFO_kindtypeANY
:
4034 ffests_printf (s
, "%ld", (long) val
);
4038 /* ffestd_R1102 -- PROGRAM statement
4040 ffestd_R1102(name_token);
4042 Make sure ffestd_kind_ identifies an empty block. Make sure name_token
4043 gives a valid name. Implement the beginning of a main program. */
4046 ffestd_R1102 (ffesymbol s
, ffelexToken name UNUSED
)
4048 ffestd_check_simple_ ();
4050 assert (ffestd_block_level_
== 0);
4051 ffestd_is_reachable_
= TRUE
;
4053 ffecom_notify_primary_entry (s
);
4054 ffe_set_is_mainprog (TRUE
); /* Is a main program. */
4055 ffe_set_is_saveall (TRUE
); /* Main program always has implicit SAVE. */
4057 ffestw_set_sym (ffestw_stack_top (), s
);
4060 /* ffestd_R1103 -- End a PROGRAM
4065 ffestd_R1103 (bool ok UNUSED
)
4069 assert (ffestd_block_level_
== 0);
4071 if (FFESTD_IS_END_OPTIMIZED_
&& ffestd_is_reachable_
)
4072 ffestd_R842 (NULL
); /* Generate STOP. */
4074 if (ffestw_state (ffestw_stack_top ()) != FFESTV_statePROGRAM5
)
4075 ffestd_subr_labels_ (FALSE
);/* Handle any undefined labels. */
4077 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR1103_
);
4078 ffestd_stmt_append_ (stmt
);
4081 /* ffestd_R1105 -- MODULE statement
4083 ffestd_R1105(name_token);
4085 Make sure ffestd_kind_ identifies an empty block. Make sure name_token
4086 gives a valid name. Implement the beginning of a module. */
4090 ffestd_R1105 (ffelexToken name
)
4092 assert (ffestd_block_level_
== 0);
4094 ffestd_check_simple_ ();
4096 ffestd_subr_f90_ ();
4100 fprintf (dmpout
, "* MODULE %s\n", ffelex_token_text (name
));
4104 /* ffestd_R1106 -- End a MODULE
4106 ffestd_R1106(TRUE); */
4109 ffestd_R1106 (bool ok
)
4111 assert (ffestd_block_level_
== 0);
4113 /* Generate any wrap-up code here (unlikely in MODULE!). */
4115 if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateMODULE5
)
4116 ffestd_subr_labels_ (TRUE
); /* Handle any undefined labels (unlikely). */
4121 fprintf (dmpout
, "< END_MODULE %s\n",
4122 ffelex_token_text (ffestw_name (ffestw_stack_top ())));
4126 /* ffestd_R1107_start -- USE statement list begin
4128 ffestd_R1107_start();
4130 Verify that USE is valid here, and begin accepting items in the list. */
4133 ffestd_R1107_start (ffelexToken name
, bool only
)
4135 ffestd_check_start_ ();
4137 ffestd_subr_f90_ ();
4141 fprintf (dmpout
, "* USE %s,", ffelex_token_text (name
)); /* NB
4142 _shriek_begin_uses_. */
4144 fputs ("only: ", dmpout
);
4148 /* ffestd_R1107_item -- USE statement for name
4150 ffestd_R1107_item(local_token,use_token);
4152 Make sure name_token identifies a valid object to be USEed. local_token
4153 may be NULL if _start_ was called with only==TRUE. */
4156 ffestd_R1107_item (ffelexToken local
, ffelexToken use
)
4158 ffestd_check_item_ ();
4159 assert (use
!= NULL
);
4165 fprintf (dmpout
, "%s=>", ffelex_token_text (local
));
4166 fprintf (dmpout
, "%s,", ffelex_token_text (use
));
4170 /* ffestd_R1107_finish -- USE statement list complete
4172 ffestd_R1107_finish();
4174 Just wrap up any local activities. */
4177 ffestd_R1107_finish ()
4179 ffestd_check_finish_ ();
4184 fputc ('\n', dmpout
);
4189 /* ffestd_R1111 -- BLOCK DATA statement
4191 ffestd_R1111(name_token);
4193 Make sure ffestd_kind_ identifies no current program unit. If not
4194 NULL, make sure name_token gives a valid name. Implement the beginning
4195 of a block data program unit. */
4198 ffestd_R1111 (ffesymbol s
, ffelexToken name UNUSED
)
4200 assert (ffestd_block_level_
== 0);
4201 ffestd_is_reachable_
= TRUE
;
4203 ffestd_check_simple_ ();
4205 ffecom_notify_primary_entry (s
);
4206 ffestw_set_sym (ffestw_stack_top (), s
);
4209 /* ffestd_R1112 -- End a BLOCK DATA
4211 ffestd_R1112(TRUE); */
4214 ffestd_R1112 (bool ok UNUSED
)
4218 assert (ffestd_block_level_
== 0);
4220 /* Generate any return-like code here (not likely for BLOCK DATA!). */
4222 if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateBLOCKDATA5
)
4223 ffestd_subr_labels_ (TRUE
); /* Handle any undefined labels. */
4225 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR1112_
);
4226 ffestd_stmt_append_ (stmt
);
4229 /* ffestd_R1202 -- INTERFACE statement
4231 ffestd_R1202(operator,defined_name);
4233 Make sure ffestd_kind_ identifies an INTERFACE block.
4234 Implement the end of the current interface.
4237 Allow no operator or name to mean INTERFACE by itself; missed this
4238 valid form when originally doing syntactic analysis code. */
4242 ffestd_R1202 (ffestpDefinedOperator
operator, ffelexToken name
)
4244 ffestd_check_simple_ ();
4246 ffestd_subr_f90_ ();
4252 case FFESTP_definedoperatorNone
:
4254 fputs ("* INTERFACE_unnamed\n", dmpout
);
4256 fprintf (dmpout
, "* INTERFACE %s\n", ffelex_token_text (name
));
4259 case FFESTP_definedoperatorOPERATOR
:
4260 fprintf (dmpout
, "* INTERFACE_OPERATOR (.%s.)\n", ffelex_token_text (name
));
4263 case FFESTP_definedoperatorASSIGNMENT
:
4264 fputs ("* INTERFACE_ASSIGNMENT (=)\n", dmpout
);
4267 case FFESTP_definedoperatorPOWER
:
4268 fputs ("* INTERFACE_OPERATOR (**)\n", dmpout
);
4271 case FFESTP_definedoperatorMULT
:
4272 fputs ("* INTERFACE_OPERATOR (*)\n", dmpout
);
4275 case FFESTP_definedoperatorADD
:
4276 fputs ("* INTERFACE_OPERATOR (+)\n", dmpout
);
4279 case FFESTP_definedoperatorCONCAT
:
4280 fputs ("* INTERFACE_OPERATOR (//)\n", dmpout
);
4283 case FFESTP_definedoperatorDIVIDE
:
4284 fputs ("* INTERFACE_OPERATOR (/)\n", dmpout
);
4287 case FFESTP_definedoperatorSUBTRACT
:
4288 fputs ("* INTERFACE_OPERATOR (-)\n", dmpout
);
4291 case FFESTP_definedoperatorNOT
:
4292 fputs ("* INTERFACE_OPERATOR (.not.)\n", dmpout
);
4295 case FFESTP_definedoperatorAND
:
4296 fputs ("* INTERFACE_OPERATOR (.and.)\n", dmpout
);
4299 case FFESTP_definedoperatorOR
:
4300 fputs ("* INTERFACE_OPERATOR (.or.)\n", dmpout
);
4303 case FFESTP_definedoperatorEQV
:
4304 fputs ("* INTERFACE_OPERATOR (.eqv.)\n", dmpout
);
4307 case FFESTP_definedoperatorNEQV
:
4308 fputs ("* INTERFACE_OPERATOR (.neqv.)\n", dmpout
);
4311 case FFESTP_definedoperatorEQ
:
4312 fputs ("* INTERFACE_OPERATOR (==)\n", dmpout
);
4315 case FFESTP_definedoperatorNE
:
4316 fputs ("* INTERFACE_OPERATOR (/=)\n", dmpout
);
4319 case FFESTP_definedoperatorLT
:
4320 fputs ("* INTERFACE_OPERATOR (<)\n", dmpout
);
4323 case FFESTP_definedoperatorLE
:
4324 fputs ("* INTERFACE_OPERATOR (<=)\n", dmpout
);
4327 case FFESTP_definedoperatorGT
:
4328 fputs ("* INTERFACE_OPERATOR (>)\n", dmpout
);
4331 case FFESTP_definedoperatorGE
:
4332 fputs ("* INTERFACE_OPERATOR (>=)\n", dmpout
);
4342 /* ffestd_R1203 -- End an INTERFACE
4344 ffestd_R1203(TRUE); */
4347 ffestd_R1203 (bool ok
)
4352 fputs ("* END_INTERFACE\n", dmpout
);
4356 /* ffestd_R1205_start -- MODULE PROCEDURE statement list begin
4358 ffestd_R1205_start();
4360 Verify that MODULE PROCEDURE is valid here, and begin accepting items in
4364 ffestd_R1205_start ()
4366 ffestd_check_start_ ();
4371 fputs ("* MODULE_PROCEDURE ", dmpout
);
4375 /* ffestd_R1205_item -- MODULE PROCEDURE statement for name
4377 ffestd_R1205_item(name_token);
4379 Make sure name_token identifies a valid object to be MODULE PROCEDUREed. */
4382 ffestd_R1205_item (ffelexToken name
)
4384 ffestd_check_item_ ();
4385 assert (name
!= NULL
);
4390 fprintf (dmpout
, "%s,", ffelex_token_text (name
));
4394 /* ffestd_R1205_finish -- MODULE PROCEDURE statement list complete
4396 ffestd_R1205_finish();
4398 Just wrap up any local activities. */
4401 ffestd_R1205_finish ()
4403 ffestd_check_finish_ ();
4408 fputc ('\n', dmpout
);
4413 /* ffestd_R1207_start -- EXTERNAL statement list begin
4415 ffestd_R1207_start();
4417 Verify that EXTERNAL is valid here, and begin accepting items in the list. */
4420 ffestd_R1207_start ()
4422 ffestd_check_start_ ();
4425 /* ffestd_R1207_item -- EXTERNAL statement for name
4427 ffestd_R1207_item(name_token);
4429 Make sure name_token identifies a valid object to be EXTERNALd. */
4432 ffestd_R1207_item (ffelexToken name
)
4434 ffestd_check_item_ ();
4435 assert (name
!= NULL
);
4438 /* ffestd_R1207_finish -- EXTERNAL statement list complete
4440 ffestd_R1207_finish();
4442 Just wrap up any local activities. */
4445 ffestd_R1207_finish ()
4447 ffestd_check_finish_ ();
4450 /* ffestd_R1208_start -- INTRINSIC statement list begin
4452 ffestd_R1208_start();
4454 Verify that INTRINSIC is valid here, and begin accepting items in the list. */
4457 ffestd_R1208_start ()
4459 ffestd_check_start_ ();
4462 /* ffestd_R1208_item -- INTRINSIC statement for name
4464 ffestd_R1208_item(name_token);
4466 Make sure name_token identifies a valid object to be INTRINSICd. */
4469 ffestd_R1208_item (ffelexToken name
)
4471 ffestd_check_item_ ();
4472 assert (name
!= NULL
);
4475 /* ffestd_R1208_finish -- INTRINSIC statement list complete
4477 ffestd_R1208_finish();
4479 Just wrap up any local activities. */
4482 ffestd_R1208_finish ()
4484 ffestd_check_finish_ ();
4487 /* ffestd_R1212 -- CALL statement
4489 ffestd_R1212(expr,expr_token);
4491 Make sure statement is valid here; implement. */
4494 ffestd_R1212 (ffebld expr
)
4498 ffestd_check_simple_ ();
4500 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR1212_
);
4501 ffestd_stmt_append_ (stmt
);
4502 ffestd_subr_line_save_ (stmt
);
4503 stmt
->u
.R1212
.pool
= ffesta_output_pool
;
4504 stmt
->u
.R1212
.expr
= expr
;
4505 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE
);
4508 /* ffestd_R1213 -- Defined assignment statement
4510 ffestd_R1213(dest_expr,source_expr,source_token);
4512 Make sure the assignment is valid. */
4516 ffestd_R1213 (ffebld dest
, ffebld source
)
4518 ffestd_check_simple_ ();
4520 ffestd_subr_f90_ ();
4524 /* ffestd_R1219 -- FUNCTION statement
4526 ffestd_R1219(funcname,arglist,ending_token,kind,kindt,len,lent,
4529 Make sure statement is valid here, register arguments for the
4530 function name, and so on.
4533 Added the kind, len, and recursive arguments. */
4536 ffestd_R1219 (ffesymbol s
, ffelexToken funcname UNUSED
,
4537 ffesttTokenList args UNUSED
, ffestpType type UNUSED
,
4538 ffebld kind UNUSED
, ffelexToken kindt UNUSED
,
4539 ffebld len UNUSED
, ffelexToken lent UNUSED
,
4540 bool recursive UNUSED
, ffelexToken result UNUSED
,
4541 bool separate_result UNUSED
)
4543 assert (ffestd_block_level_
== 0);
4544 ffestd_is_reachable_
= TRUE
;
4546 ffestd_check_simple_ ();
4548 ffecom_notify_primary_entry (s
);
4549 ffestw_set_sym (ffestw_stack_top (), s
);
4552 /* ffestd_R1221 -- End a FUNCTION
4554 ffestd_R1221(TRUE); */
4557 ffestd_R1221 (bool ok UNUSED
)
4561 assert (ffestd_block_level_
== 0);
4563 if (FFESTD_IS_END_OPTIMIZED_
&& ffestd_is_reachable_
)
4564 ffestd_R1227 (NULL
); /* Generate RETURN. */
4566 if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateFUNCTION5
)
4567 ffestd_subr_labels_ (FALSE
);/* Handle any undefined labels. */
4569 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR1221_
);
4570 ffestd_stmt_append_ (stmt
);
4573 /* ffestd_R1223 -- SUBROUTINE statement
4575 ffestd_R1223(subrname,arglist,ending_token,recursive_token);
4577 Make sure statement is valid here, register arguments for the
4578 subroutine name, and so on.
4581 Added the recursive argument. */
4584 ffestd_R1223 (ffesymbol s
, ffelexToken subrname UNUSED
,
4585 ffesttTokenList args UNUSED
, ffelexToken final UNUSED
,
4586 bool recursive UNUSED
)
4588 assert (ffestd_block_level_
== 0);
4589 ffestd_is_reachable_
= TRUE
;
4591 ffestd_check_simple_ ();
4593 ffecom_notify_primary_entry (s
);
4594 ffestw_set_sym (ffestw_stack_top (), s
);
4597 /* ffestd_R1225 -- End a SUBROUTINE
4599 ffestd_R1225(TRUE); */
4602 ffestd_R1225 (bool ok UNUSED
)
4606 assert (ffestd_block_level_
== 0);
4608 if (FFESTD_IS_END_OPTIMIZED_
&& ffestd_is_reachable_
)
4609 ffestd_R1227 (NULL
); /* Generate RETURN. */
4611 if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateSUBROUTINE5
)
4612 ffestd_subr_labels_ (FALSE
);/* Handle any undefined labels. */
4614 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR1225_
);
4615 ffestd_stmt_append_ (stmt
);
4618 /* ffestd_R1226 -- ENTRY statement
4620 ffestd_R1226(entryname,arglist,ending_token);
4622 Make sure we're in a SUBROUTINE or FUNCTION, register arguments for the
4623 entry point name, and so on. */
4626 ffestd_R1226 (ffesymbol entry
)
4628 ffestd_check_simple_ ();
4630 if (!ffesta_seen_first_exec
|| ffecom_2pass_advise_entrypoint (entry
))
4634 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR1226_
);
4635 ffestd_stmt_append_ (stmt
);
4636 ffestd_subr_line_save_ (stmt
);
4637 stmt
->u
.R1226
.entry
= entry
;
4638 stmt
->u
.R1226
.entrynum
= ++ffestd_2pass_entrypoints_
;
4641 ffestd_is_reachable_
= TRUE
;
4644 /* ffestd_R1227 -- RETURN statement
4648 Make sure statement is valid here; implement. expr and expr_token are
4649 both NULL if there was no expression. */
4652 ffestd_R1227 (ffebld expr
)
4656 ffestd_check_simple_ ();
4658 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR1227_
);
4659 ffestd_stmt_append_ (stmt
);
4660 ffestd_subr_line_save_ (stmt
);
4661 stmt
->u
.R1227
.pool
= ffesta_output_pool
;
4662 stmt
->u
.R1227
.block
= ffestw_stack_top ();
4663 stmt
->u
.R1227
.expr
= expr
;
4664 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE
);
4666 if (ffestd_block_level_
== 0)
4667 ffestd_is_reachable_
= FALSE
;
4670 /* ffestd_R1228 -- CONTAINS statement
4678 assert (ffestd_block_level_
== 0);
4680 ffestd_check_simple_ ();
4682 /* Generate RETURN/STOP code here */
4684 ffestd_subr_labels_ (ffestw_state (ffestw_stack_top ())
4685 == FFESTV_stateMODULE5
); /* Handle any undefined
4688 ffestd_subr_f90_ ();
4692 fputs ("- CONTAINS\n", dmpout
);
4697 /* ffestd_R1229_start -- STMTFUNCTION statement begin
4699 ffestd_R1229_start(func_name,func_arg_list,close_paren);
4701 This function does not really need to do anything, since _finish_
4702 gets all the info needed, and ffestc_R1229_start has already
4703 done all the stuff that makes a two-phase operation (start and
4704 finish) for handling statement functions necessary.
4707 Do nothing, now that _finish_ does everything. */
4710 ffestd_R1229_start (ffelexToken name UNUSED
, ffesttTokenList args UNUSED
)
4712 ffestd_check_start_ ();
4715 /* ffestd_R1229_finish -- STMTFUNCTION statement list complete
4717 ffestd_R1229_finish(s);
4719 The statement function's symbol is passed. Its list of dummy args is
4720 accessed via ffesymbol_dummyargs and its expansion expression (expr)
4721 is accessed via ffesymbol_sfexpr.
4723 If sfexpr is NULL, an error occurred parsing the expansion expression, so
4724 just cancel the effects of ffestd_R1229_start and pretend nothing
4725 happened. Otherwise, install the expression as the expansion for the
4726 statement function, then clean up.
4729 Takes sfunc sym instead of just the expansion expression as an
4730 argument, so this function can do all the work, and _start_ is just
4731 a nicety than can do nothing in a back end. */
4734 ffestd_R1229_finish (ffesymbol s
)
4736 ffebld expr
= ffesymbol_sfexpr (s
);
4738 ffestd_check_finish_ ();
4741 return; /* Nothing to do, definition didn't work. */
4743 /* With gcc, cannot do anything here, because the backend hasn't even
4744 (necessarily) been notified that we're compiling a program unit! */
4745 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE
);
4748 /* ffestd_S3P4 -- INCLUDE line
4750 ffestd_S3P4(filename,filename_token);
4752 Make sure INCLUDE not preceded by any semicolons or a label def; implement. */
4755 ffestd_S3P4 (ffebld filename
)
4758 ffetargetCharacterDefault buildname
;
4761 ffestd_check_simple_ ();
4763 assert (filename
!= NULL
);
4764 if (ffebld_op (filename
) != FFEBLD_opANY
)
4766 assert (ffebld_op (filename
) == FFEBLD_opCONTER
);
4767 assert (ffeinfo_basictype (ffebld_info (filename
))
4768 == FFEINFO_basictypeCHARACTER
);
4769 assert (ffeinfo_kindtype (ffebld_info (filename
))
4770 == FFEINFO_kindtypeCHARACTERDEFAULT
);
4771 buildname
= ffebld_constant_characterdefault (ffebld_conter (filename
));
4772 wf
= ffewhere_file_new (ffetarget_text_characterdefault (buildname
),
4773 ffetarget_length_characterdefault (buildname
));
4774 fi
= ffecom_open_include (ffewhere_file_name (wf
),
4775 ffelex_token_where_line (ffesta_tokens
[0]),
4776 ffelex_token_where_column (ffesta_tokens
[0]));
4778 ffelex_set_include (wf
, (ffelex_token_type (ffesta_tokens
[0])
4779 == FFELEX_typeNAME
), fi
);
4783 /* ffestd_V003_start -- STRUCTURE statement list begin
4785 ffestd_V003_start(structure_name);
4787 Verify that STRUCTURE is valid here, and begin accepting items in the list. */
4791 ffestd_V003_start (ffelexToken structure_name
)
4793 ffestd_check_start_ ();
4794 ffestd_subr_vxt_ ();
4797 /* ffestd_V003_item -- STRUCTURE statement for object-name
4799 ffestd_V003_item(name_token,dim_list);
4801 Make sure name_token identifies a valid object to be STRUCTUREd. */
4804 ffestd_V003_item (ffelexToken name
, ffesttDimList dims
)
4806 ffestd_check_item_ ();
4809 /* ffestd_V003_finish -- STRUCTURE statement list complete
4811 ffestd_V003_finish();
4813 Just wrap up any local activities. */
4816 ffestd_V003_finish ()
4818 ffestd_check_finish_ ();
4821 /* ffestd_V004 -- End a STRUCTURE
4823 ffestd_V004(TRUE); */
4826 ffestd_V004 (bool ok
)
4830 /* ffestd_V009 -- UNION statement
4837 ffestd_check_simple_ ();
4840 /* ffestd_V010 -- End a UNION
4842 ffestd_V010(TRUE); */
4845 ffestd_V010 (bool ok
)
4849 /* ffestd_V012 -- MAP statement
4856 ffestd_check_simple_ ();
4859 /* ffestd_V013 -- End a MAP
4861 ffestd_V013(TRUE); */
4864 ffestd_V013 (bool ok
)
4869 /* ffestd_V014_start -- VOLATILE statement list begin
4871 ffestd_V014_start();
4873 Verify that VOLATILE is valid here, and begin accepting items in the list. */
4876 ffestd_V014_start ()
4878 ffestd_check_start_ ();
4881 /* ffestd_V014_item_object -- VOLATILE statement for object-name
4883 ffestd_V014_item_object(name_token);
4885 Make sure name_token identifies a valid object to be VOLATILEd. */
4888 ffestd_V014_item_object (ffelexToken name UNUSED
)
4890 ffestd_check_item_ ();
4893 /* ffestd_V014_item_cblock -- VOLATILE statement for common-block-name
4895 ffestd_V014_item_cblock(name_token);
4897 Make sure name_token identifies a valid common block to be VOLATILEd. */
4900 ffestd_V014_item_cblock (ffelexToken name UNUSED
)
4902 ffestd_check_item_ ();
4905 /* ffestd_V014_finish -- VOLATILE statement list complete
4907 ffestd_V014_finish();
4909 Just wrap up any local activities. */
4912 ffestd_V014_finish ()
4914 ffestd_check_finish_ ();
4917 /* ffestd_V016_start -- RECORD statement list begin
4919 ffestd_V016_start();
4921 Verify that RECORD is valid here, and begin accepting items in the list. */
4925 ffestd_V016_start ()
4927 ffestd_check_start_ ();
4930 /* ffestd_V016_item_structure -- RECORD statement for common-block-name
4932 ffestd_V016_item_structure(name_token);
4934 Make sure name_token identifies a valid structure to be RECORDed. */
4937 ffestd_V016_item_structure (ffelexToken name
)
4939 ffestd_check_item_ ();
4942 /* ffestd_V016_item_object -- RECORD statement for object-name
4944 ffestd_V016_item_object(name_token,dim_list);
4946 Make sure name_token identifies a valid object to be RECORDd. */
4949 ffestd_V016_item_object (ffelexToken name
, ffesttDimList dims
)
4951 ffestd_check_item_ ();
4954 /* ffestd_V016_finish -- RECORD statement list complete
4956 ffestd_V016_finish();
4958 Just wrap up any local activities. */
4961 ffestd_V016_finish ()
4963 ffestd_check_finish_ ();
4966 /* ffestd_V018_start -- REWRITE(...) statement list begin
4968 ffestd_V018_start();
4970 Verify that REWRITE is valid here, and begin accepting items in the
4974 ffestd_V018_start (ffestvFormat format
)
4976 ffestd_check_start_ ();
4977 ffestd_subr_vxt_ ();
4980 /* ffestd_V018_item -- REWRITE statement i/o item
4982 ffestd_V018_item(expr,expr_token);
4984 Implement output-list expression. */
4987 ffestd_V018_item (ffebld expr
)
4989 ffestd_check_item_ ();
4992 /* ffestd_V018_finish -- REWRITE statement list complete
4994 ffestd_V018_finish();
4996 Just wrap up any local activities. */
4999 ffestd_V018_finish ()
5001 ffestd_check_finish_ ();
5004 /* ffestd_V019_start -- ACCEPT statement list begin
5006 ffestd_V019_start();
5008 Verify that ACCEPT is valid here, and begin accepting items in the
5012 ffestd_V019_start (ffestvFormat format
)
5014 ffestd_check_start_ ();
5015 ffestd_subr_vxt_ ();
5018 /* ffestd_V019_item -- ACCEPT statement i/o item
5020 ffestd_V019_item(expr,expr_token);
5022 Implement output-list expression. */
5025 ffestd_V019_item (ffebld expr
)
5027 ffestd_check_item_ ();
5030 /* ffestd_V019_finish -- ACCEPT statement list complete
5032 ffestd_V019_finish();
5034 Just wrap up any local activities. */
5037 ffestd_V019_finish ()
5039 ffestd_check_finish_ ();
5043 /* ffestd_V020_start -- TYPE statement list begin
5045 ffestd_V020_start();
5047 Verify that TYPE is valid here, and begin accepting items in the
5051 ffestd_V020_start (ffestvFormat format UNUSED
)
5053 ffestd_check_start_ ();
5054 ffestd_subr_vxt_ ();
5057 /* ffestd_V020_item -- TYPE statement i/o item
5059 ffestd_V020_item(expr,expr_token);
5061 Implement output-list expression. */
5064 ffestd_V020_item (ffebld expr UNUSED
)
5066 ffestd_check_item_ ();
5069 /* ffestd_V020_finish -- TYPE statement list complete
5071 ffestd_V020_finish();
5073 Just wrap up any local activities. */
5076 ffestd_V020_finish ()
5078 ffestd_check_finish_ ();
5081 /* ffestd_V021 -- DELETE statement
5085 Make sure a DELETE is valid in the current context, and implement it. */
5091 ffestd_check_simple_ ();
5092 ffestd_subr_vxt_ ();
5095 /* ffestd_V022 -- UNLOCK statement
5099 Make sure a UNLOCK is valid in the current context, and implement it. */
5104 ffestd_check_simple_ ();
5105 ffestd_subr_vxt_ ();
5108 /* ffestd_V023_start -- ENCODE(...) statement list begin
5110 ffestd_V023_start();
5112 Verify that ENCODE is valid here, and begin accepting items in the
5116 ffestd_V023_start ()
5118 ffestd_check_start_ ();
5119 ffestd_subr_vxt_ ();
5122 /* ffestd_V023_item -- ENCODE statement i/o item
5124 ffestd_V023_item(expr,expr_token);
5126 Implement output-list expression. */
5129 ffestd_V023_item (ffebld expr
)
5131 ffestd_check_item_ ();
5134 /* ffestd_V023_finish -- ENCODE statement list complete
5136 ffestd_V023_finish();
5138 Just wrap up any local activities. */
5141 ffestd_V023_finish ()
5143 ffestd_check_finish_ ();
5146 /* ffestd_V024_start -- DECODE(...) statement list begin
5148 ffestd_V024_start();
5150 Verify that DECODE is valid here, and begin accepting items in the
5154 ffestd_V024_start ()
5156 ffestd_check_start_ ();
5157 ffestd_subr_vxt_ ();
5160 /* ffestd_V024_item -- DECODE statement i/o item
5162 ffestd_V024_item(expr,expr_token);
5164 Implement output-list expression. */
5167 ffestd_V024_item (ffebld expr
)
5169 ffestd_check_item_ ();
5172 /* ffestd_V024_finish -- DECODE statement list complete
5174 ffestd_V024_finish();
5176 Just wrap up any local activities. */
5179 ffestd_V024_finish ()
5181 ffestd_check_finish_ ();
5184 /* ffestd_V025_start -- DEFINEFILE statement list begin
5186 ffestd_V025_start();
5188 Verify that DEFINEFILE is valid here, and begin accepting items in the
5192 ffestd_V025_start ()
5194 ffestd_check_start_ ();
5195 ffestd_subr_vxt_ ();
5198 /* ffestd_V025_item -- DEFINE FILE statement item
5200 ffestd_V025_item(u,ut,m,mt,n,nt,asv,asvt);
5202 Implement item. Treat each item kind of like a separate statement,
5203 since there's really no need to treat them as an aggregate. */
5206 ffestd_V025_item (ffebld u
, ffebld m
, ffebld n
, ffebld asv
)
5208 ffestd_check_item_ ();
5211 /* ffestd_V025_finish -- DEFINE FILE statement list complete
5213 ffestd_V025_finish();
5215 Just wrap up any local activities. */
5218 ffestd_V025_finish ()
5220 ffestd_check_finish_ ();
5223 /* ffestd_V026 -- FIND statement
5227 Make sure a FIND is valid in the current context, and implement it. */
5232 ffestd_check_simple_ ();
5233 ffestd_subr_vxt_ ();
5237 /* ffestd_V027_start -- VXT PARAMETER statement list begin
5239 ffestd_V027_start();
5241 Verify that PARAMETER is valid here, and begin accepting items in the list. */
5244 ffestd_V027_start ()
5246 ffestd_check_start_ ();
5247 ffestd_subr_vxt_ ();
5250 /* ffestd_V027_item -- VXT PARAMETER statement assignment
5252 ffestd_V027_item(dest,dest_token,source,source_token);
5254 Make sure the source is a valid source for the destination; make the
5258 ffestd_V027_item (ffelexToken dest_token UNUSED
, ffebld source UNUSED
)
5260 ffestd_check_item_ ();
5263 /* ffestd_V027_finish -- VXT PARAMETER statement list complete
5265 ffestd_V027_finish();
5267 Just wrap up any local activities. */
5270 ffestd_V027_finish ()
5272 ffestd_check_finish_ ();
5275 /* Any executable statement. */
5282 ffestd_check_simple_ ();
5284 stmt
= ffestd_stmt_new_ (FFESTD_stmtidR841_
);
5285 ffestd_stmt_append_ (stmt
);
5286 ffestd_subr_line_save_ (stmt
);