diff options
Diffstat (limited to 'contrib/gcc/f/std.c')
| -rw-r--r-- | contrib/gcc/f/std.c | 3623 |
1 files changed, 0 insertions, 3623 deletions
diff --git a/contrib/gcc/f/std.c b/contrib/gcc/f/std.c deleted file mode 100644 index 09f04198f0a8..000000000000 --- a/contrib/gcc/f/std.c +++ /dev/null @@ -1,3623 +0,0 @@ -/* std.c -- Implementation File (module.c template V1.0) - Copyright (C) 1995, 1996, 2000, 2002, 2003 Free Software Foundation, Inc. - Contributed by James Craig Burley. - -This file is part of GNU Fortran. - -GNU Fortran is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2, or (at your option) -any later version. - -GNU Fortran is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU Fortran; see the file COPYING. If not, write to -the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA -02111-1307, USA. - - Related Modules: - st.c - - Description: - Implements the various statements and such like. - - Modifications: - 21-Nov-91 JCB 2.0 - Split out actual code generation to ffeste. -*/ - -/* Include files. */ - -#include "proj.h" -#include "std.h" -#include "bld.h" -#include "com.h" -#include "lab.h" -#include "lex.h" -#include "malloc.h" -#include "sta.h" -#include "ste.h" -#include "stp.h" -#include "str.h" -#include "sts.h" -#include "stt.h" -#include "stv.h" -#include "stw.h" -#include "symbol.h" -#include "target.h" - -/* Externals defined here. */ - - -/* Simple definitions and enumerations. */ - -#define FFESTD_COPY_EASY_ 1 /* 1 for only one _subr_copy_xyz_ fn. */ - -#define FFESTD_IS_END_OPTIMIZED_ 1 /* 0=always gen STOP/RETURN before - END. */ - -typedef enum - { - FFESTD_stateletSIMPLE_, /* Expecting simple/start. */ - FFESTD_stateletATTRIB_, /* Expecting attrib/item/itemstart. */ - FFESTD_stateletITEM_, /* Expecting item/itemstart/finish. */ - FFESTD_stateletITEMVALS_, /* Expecting itemvalue/itemendvals. */ - FFESTD_ - } ffestdStatelet_; - -typedef enum - { - FFESTD_stmtidENDDOLOOP_, - FFESTD_stmtidENDLOGIF_, - FFESTD_stmtidEXECLABEL_, - FFESTD_stmtidFORMATLABEL_, - FFESTD_stmtidR737A_, /* let */ - FFESTD_stmtidR803_, /* IF-block */ - FFESTD_stmtidR804_, /* ELSE IF */ - FFESTD_stmtidR805_, /* ELSE */ - FFESTD_stmtidR806_, /* END IF */ - FFESTD_stmtidR807_, /* IF-logical */ - FFESTD_stmtidR809_, /* SELECT CASE */ - FFESTD_stmtidR810_, /* CASE */ - FFESTD_stmtidR811_, /* END SELECT */ - FFESTD_stmtidR819A_, /* DO-iterative */ - FFESTD_stmtidR819B_, /* DO WHILE */ - FFESTD_stmtidR825_, /* END DO */ - FFESTD_stmtidR834_, /* CYCLE */ - FFESTD_stmtidR835_, /* EXIT */ - FFESTD_stmtidR836_, /* GOTO */ - FFESTD_stmtidR837_, /* GOTO-computed */ - FFESTD_stmtidR838_, /* ASSIGN */ - FFESTD_stmtidR839_, /* GOTO-assigned */ - FFESTD_stmtidR840_, /* IF-arithmetic */ - FFESTD_stmtidR841_, /* CONTINUE */ - FFESTD_stmtidR842_, /* STOP */ - FFESTD_stmtidR843_, /* PAUSE */ - FFESTD_stmtidR904_, /* OPEN */ - FFESTD_stmtidR907_, /* CLOSE */ - FFESTD_stmtidR909_, /* READ */ - FFESTD_stmtidR910_, /* WRITE */ - FFESTD_stmtidR911_, /* PRINT */ - FFESTD_stmtidR919_, /* BACKSPACE */ - FFESTD_stmtidR920_, /* ENDFILE */ - FFESTD_stmtidR921_, /* REWIND */ - FFESTD_stmtidR923A_, /* INQUIRE */ - FFESTD_stmtidR923B_, /* INQUIRE-iolength */ - FFESTD_stmtidR1001_, /* FORMAT */ - FFESTD_stmtidR1103_, /* END_PROGRAM */ - FFESTD_stmtidR1112_, /* END_BLOCK_DATA */ - FFESTD_stmtidR1212_, /* CALL */ - FFESTD_stmtidR1221_, /* END_FUNCTION */ - FFESTD_stmtidR1225_, /* END_SUBROUTINE */ - FFESTD_stmtidR1226_, /* ENTRY */ - FFESTD_stmtidR1227_, /* RETURN */ - FFESTD_stmtidV020_, /* TYPE */ - FFESTD_stmtid_, - } ffestdStmtId_; - -/* Internal typedefs. */ - -typedef struct _ffestd_expr_item_ *ffestdExprItem_; -typedef struct _ffestd_stmt_ *ffestdStmt_; - -/* Private include files. */ - - -/* Internal structure definitions. */ - -struct _ffestd_expr_item_ - { - ffestdExprItem_ next; - ffebld expr; - ffelexToken token; - }; - -struct _ffestd_stmt_ - { - ffestdStmt_ next; - ffestdStmt_ previous; - ffestdStmtId_ id; - char *filename; - int filelinenum; - union - { - struct - { - ffestw block; - } - enddoloop; - struct - { - ffelab label; - } - execlabel; - struct - { - ffelab label; - } - formatlabel; - struct - { - mallocPool pool; - ffebld dest; - ffebld source; - } - R737A; - struct - { - mallocPool pool; - ffestw block; - ffebld expr; - } - R803; - struct - { - mallocPool pool; - ffestw block; - ffebld expr; - } - R804; - struct - { - ffestw block; - } - R805; - struct - { - ffestw block; - } - R806; - struct - { - mallocPool pool; - ffebld expr; - } - R807; - struct - { - mallocPool pool; - ffestw block; - ffebld expr; - } - R809; - struct - { - mallocPool pool; - ffestw block; - unsigned long casenum; - } - R810; - struct - { - ffestw block; - } - R811; - struct - { - mallocPool pool; - ffestw block; - ffelab label; - ffebld var; - ffebld start; - ffelexToken start_token; - ffebld end; - ffelexToken end_token; - ffebld incr; - ffelexToken incr_token; - } - R819A; - struct - { - mallocPool pool; - ffestw block; - ffelab label; - ffebld expr; - } - R819B; - struct - { - ffestw block; - } - R834; - struct - { - ffestw block; - } - R835; - struct - { - ffelab label; - } - R836; - struct - { - mallocPool pool; - ffelab *labels; - int count; - ffebld expr; - } - R837; - struct - { - mallocPool pool; - ffelab label; - ffebld target; - } - R838; - struct - { - mallocPool pool; - ffebld target; - } - R839; - struct - { - mallocPool pool; - ffebld expr; - ffelab neg; - ffelab zero; - ffelab pos; - } - R840; - struct - { - mallocPool pool; - ffebld expr; - } - R842; - struct - { - mallocPool pool; - ffebld expr; - } - R843; - struct - { - mallocPool pool; - ffestpOpenStmt *params; - } - R904; - struct - { - mallocPool pool; - ffestpCloseStmt *params; - } - R907; - struct - { - mallocPool pool; - ffestpReadStmt *params; - bool only_format; - ffestvUnit unit; - ffestvFormat format; - bool rec; - bool key; - ffestdExprItem_ list; - } - R909; - struct - { - mallocPool pool; - ffestpWriteStmt *params; - ffestvUnit unit; - ffestvFormat format; - bool rec; - ffestdExprItem_ list; - } - R910; - struct - { - mallocPool pool; - ffestpPrintStmt *params; - ffestvFormat format; - ffestdExprItem_ list; - } - R911; - struct - { - mallocPool pool; - ffestpBeruStmt *params; - } - R919; - struct - { - mallocPool pool; - ffestpBeruStmt *params; - } - R920; - struct - { - mallocPool pool; - ffestpBeruStmt *params; - } - R921; - struct - { - mallocPool pool; - ffestpInquireStmt *params; - bool by_file; - } - R923A; - struct - { - mallocPool pool; - ffestpInquireStmt *params; - ffestdExprItem_ list; - } - R923B; - struct - { - ffestsHolder str; - } - R1001; - struct - { - mallocPool pool; - ffebld expr; - } - R1212; - struct - { - ffesymbol entry; - int entrynum; - } - R1226; - struct - { - mallocPool pool; - ffestw block; - ffebld expr; - } - R1227; - struct - { - mallocPool pool; - ffestpTypeStmt *params; - ffestvFormat format; - ffestdExprItem_ list; - } - V020; - } - u; - }; - -/* Static objects accessed by functions in this module. */ - -static ffestdStatelet_ ffestd_statelet_ = FFESTD_stateletSIMPLE_; -static int ffestd_block_level_ = 0; /* Block level for reachableness. */ -static bool ffestd_is_reachable_; /* Is the current stmt reachable? */ -static ffelab ffestd_label_formatdef_ = NULL; -static ffestdExprItem_ *ffestd_expr_list_; -static struct - { - ffestdStmt_ first; - ffestdStmt_ last; - } -ffestd_stmt_list_ = -{ - NULL, NULL -}; - - -/* # ENTRY statements pending. */ -static int ffestd_2pass_entrypoints_ = 0; - -/* Static functions (internal). */ - -static void ffestd_stmt_append_ (ffestdStmt_ stmt); -static ffestdStmt_ ffestd_stmt_new_ (ffestdStmtId_ id); -static void ffestd_stmt_pass_ (void); -#if FFESTD_COPY_EASY_ -static ffestpInquireStmt *ffestd_subr_copy_easy_ (ffestpInquireIx max); -#endif -static void ffestd_subr_vxt_ (void); -static void ffestd_subr_labels_ (bool unexpected); -static void ffestd_R1001dump_ (ffests s, ffesttFormatList list); -static void ffestd_R1001dump_1005_1_ (ffests s, ffesttFormatList f, - const char *string); -static void ffestd_R1001dump_1005_2_ (ffests s, ffesttFormatList f, - const char *string); -static void ffestd_R1001dump_1005_3_ (ffests s, ffesttFormatList f, - const char *string); -static void ffestd_R1001dump_1005_4_ (ffests s, ffesttFormatList f, - const char *string); -static void ffestd_R1001dump_1005_5_ (ffests s, ffesttFormatList f, - const char *string); -static void ffestd_R1001dump_1010_1_ (ffests s, ffesttFormatList f, - const char *string); -static void ffestd_R1001dump_1010_2_ (ffests s, ffesttFormatList f, - const char *string); -static void ffestd_R1001dump_1010_4_ (ffests s, ffesttFormatList f, - const char *string); -static void ffestd_R1001dump_1010_5_ (ffests s, ffesttFormatList f, - const char *string); -static void ffestd_R1001error_ (ffesttFormatList f); -static void ffestd_R1001rtexpr_ (ffests s, ffesttFormatList f, ffebld expr); - -/* Internal macros. */ - -#define ffestd_subr_line_now_() \ - ffeste_set_line (ffelex_token_where_filename (ffesta_tokens[0]), \ - ffelex_token_where_filelinenum (ffesta_tokens[0])) -#define ffestd_subr_line_restore_(s) \ - ffeste_set_line ((s)->filename, (s)->filelinenum) -#define ffestd_subr_line_save_(s) \ - ((s)->filename = ffelex_token_where_filename (ffesta_tokens[0]), \ - (s)->filelinenum = ffelex_token_where_filelinenum (ffesta_tokens[0])) -#define ffestd_check_simple_() \ - assert(ffestd_statelet_ == FFESTD_stateletSIMPLE_) -#define ffestd_check_start_() \ - assert(ffestd_statelet_ == FFESTD_stateletSIMPLE_); \ - ffestd_statelet_ = FFESTD_stateletATTRIB_ -#define ffestd_check_attrib_() \ - assert(ffestd_statelet_ == FFESTD_stateletATTRIB_) -#define ffestd_check_item_() \ - assert(ffestd_statelet_ == FFESTD_stateletATTRIB_ \ - || ffestd_statelet_ == FFESTD_stateletITEM_); \ - ffestd_statelet_ = FFESTD_stateletITEM_ -#define ffestd_check_item_startvals_() \ - assert(ffestd_statelet_ == FFESTD_stateletATTRIB_ \ - || ffestd_statelet_ == FFESTD_stateletITEM_); \ - ffestd_statelet_ = FFESTD_stateletITEMVALS_ -#define ffestd_check_item_value_() \ - assert(ffestd_statelet_ == FFESTD_stateletITEMVALS_) -#define ffestd_check_item_endvals_() \ - assert(ffestd_statelet_ == FFESTD_stateletITEMVALS_); \ - ffestd_statelet_ = FFESTD_stateletITEM_ -#define ffestd_check_finish_() \ - assert(ffestd_statelet_ == FFESTD_stateletATTRIB_ \ - || ffestd_statelet_ == FFESTD_stateletITEM_); \ - ffestd_statelet_ = FFESTD_stateletSIMPLE_ - -#if FFESTD_COPY_EASY_ -#define ffestd_subr_copy_accept_() (ffestpAcceptStmt *) \ - ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_acceptix) -#define ffestd_subr_copy_beru_() (ffestpBeruStmt *) \ - ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_beruix) -#define ffestd_subr_copy_close_() (ffestpCloseStmt *) \ - ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_closeix) -#define ffestd_subr_copy_delete_() (ffestpDeleteStmt *) \ - ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_deleteix) -#define ffestd_subr_copy_find_() (ffestpFindStmt *) \ - ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_findix) -#define ffestd_subr_copy_inquire_() (ffestpInquireStmt *) \ - ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_inquireix) -#define ffestd_subr_copy_open_() (ffestpOpenStmt *) \ - ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_openix) -#define ffestd_subr_copy_print_() (ffestpPrintStmt *) \ - ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_printix) -#define ffestd_subr_copy_read_() (ffestpReadStmt *) \ - ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_readix) -#define ffestd_subr_copy_rewrite_() (ffestpRewriteStmt *) \ - ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_rewriteix) -#define ffestd_subr_copy_type_() (ffestpTypeStmt *) \ - ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_typeix) -#define ffestd_subr_copy_vxtcode_() (ffestpVxtcodeStmt *) \ - ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_vxtcodeix) -#define ffestd_subr_copy_write_() (ffestpWriteStmt *) \ - ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_writeix) -#endif - -/* ffestd_stmt_append_ -- Append statement to end of stmt list - - ffestd_stmt_append_(ffestd_stmt_new_(FFESTD_stmtidR737A_)); */ - -static void -ffestd_stmt_append_ (ffestdStmt_ stmt) -{ - stmt->next = (ffestdStmt_) &ffestd_stmt_list_.first; - stmt->previous = ffestd_stmt_list_.last; - stmt->next->previous = stmt; - stmt->previous->next = stmt; -} - -/* ffestd_stmt_new_ -- Make new statement with given id - - ffestdStmt_ stmt; - stmt = ffestd_stmt_new_(FFESTD_stmtidR737A_); */ - -static ffestdStmt_ -ffestd_stmt_new_ (ffestdStmtId_ id) -{ - ffestdStmt_ stmt; - - stmt = malloc_new_kp (ffe_pool_any_unit (), "ffestdStmt_", sizeof (*stmt)); - stmt->id = id; - return stmt; -} - -/* ffestd_stmt_pass_ -- Pass all statements on list to ffeste - - ffestd_stmt_pass_(); */ - -static void -ffestd_stmt_pass_ (void) -{ - ffestdStmt_ stmt; - ffestdExprItem_ expr; /* For traversing lists. */ - bool okay = (TREE_CODE (current_function_decl) != ERROR_MARK); - - if ((ffestd_2pass_entrypoints_ != 0) && okay) - { - tree which = ffecom_which_entrypoint_decl (); - tree value; - tree label; - int pushok; - int ents = ffestd_2pass_entrypoints_; - tree duplicate; - - expand_start_case (0, which, TREE_TYPE (which), "entrypoint dispatch"); - - stmt = ffestd_stmt_list_.first; - do - { - while (stmt->id != FFESTD_stmtidR1226_) - stmt = stmt->next; - - if (stmt->u.R1226.entry != NULL) - { - value = build_int_2 (stmt->u.R1226.entrynum, 0); - /* Yes, we really want to build a null LABEL_DECL here and not - put it on any list. That's what pushcase wants, so that's - what it gets! */ - label = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE); - - pushok = pushcase (value, convert, label, &duplicate); - assert (pushok == 0); - - label = ffecom_temp_label (); - TREE_USED (label) = 1; - expand_goto (label); - - ffesymbol_hook (stmt->u.R1226.entry).length_tree = label; - } - stmt = stmt->next; - } - while (--ents != 0); - - expand_end_case (which); - } - - for (stmt = ffestd_stmt_list_.first; - stmt != (ffestdStmt_) &ffestd_stmt_list_.first; - stmt = stmt->next) - { - switch (stmt->id) - { - case FFESTD_stmtidENDDOLOOP_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_do (stmt->u.enddoloop.block); - ffestw_kill (stmt->u.enddoloop.block); - break; - - case FFESTD_stmtidENDLOGIF_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_end_R807 (); - break; - - case FFESTD_stmtidEXECLABEL_: - if (okay) - ffeste_labeldef_branch (stmt->u.execlabel.label); - break; - - case FFESTD_stmtidFORMATLABEL_: - if (okay) - ffeste_labeldef_format (stmt->u.formatlabel.label); - break; - - case FFESTD_stmtidR737A_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_R737A (stmt->u.R737A.dest, stmt->u.R737A.source); - malloc_pool_kill (stmt->u.R737A.pool); - break; - - case FFESTD_stmtidR803_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_R803 (stmt->u.R803.block, stmt->u.R803.expr); - malloc_pool_kill (stmt->u.R803.pool); - break; - - case FFESTD_stmtidR804_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_R804 (stmt->u.R803.block, stmt->u.R804.expr); - malloc_pool_kill (stmt->u.R804.pool); - break; - - case FFESTD_stmtidR805_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_R805 (stmt->u.R803.block); - break; - - case FFESTD_stmtidR806_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_R806 (stmt->u.R806.block); - ffestw_kill (stmt->u.R806.block); - break; - - case FFESTD_stmtidR807_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_R807 (stmt->u.R807.expr); - malloc_pool_kill (stmt->u.R807.pool); - break; - - case FFESTD_stmtidR809_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_R809 (stmt->u.R809.block, stmt->u.R809.expr); - malloc_pool_kill (stmt->u.R809.pool); - break; - - case FFESTD_stmtidR810_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_R810 (stmt->u.R810.block, stmt->u.R810.casenum); - malloc_pool_kill (stmt->u.R810.pool); - break; - - case FFESTD_stmtidR811_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_R811 (stmt->u.R811.block); - malloc_pool_kill (ffestw_select (stmt->u.R811.block)->pool); - ffestw_kill (stmt->u.R811.block); - break; - - case FFESTD_stmtidR819A_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_R819A (stmt->u.R819A.block, stmt->u.R819A.label, - stmt->u.R819A.var, - stmt->u.R819A.start, stmt->u.R819A.start_token, - stmt->u.R819A.end, stmt->u.R819A.end_token, - stmt->u.R819A.incr, stmt->u.R819A.incr_token); - ffelex_token_kill (stmt->u.R819A.start_token); - ffelex_token_kill (stmt->u.R819A.end_token); - if (stmt->u.R819A.incr_token != NULL) - ffelex_token_kill (stmt->u.R819A.incr_token); - malloc_pool_kill (stmt->u.R819A.pool); - break; - - case FFESTD_stmtidR819B_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_R819B (stmt->u.R819B.block, stmt->u.R819B.label, - stmt->u.R819B.expr); - malloc_pool_kill (stmt->u.R819B.pool); - break; - - case FFESTD_stmtidR825_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_R825 (); - break; - - case FFESTD_stmtidR834_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_R834 (stmt->u.R834.block); - break; - - case FFESTD_stmtidR835_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_R835 (stmt->u.R835.block); - break; - - case FFESTD_stmtidR836_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_R836 (stmt->u.R836.label); - break; - - case FFESTD_stmtidR837_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_R837 (stmt->u.R837.labels, stmt->u.R837.count, - stmt->u.R837.expr); - malloc_pool_kill (stmt->u.R837.pool); - break; - - case FFESTD_stmtidR838_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_R838 (stmt->u.R838.label, stmt->u.R838.target); - malloc_pool_kill (stmt->u.R838.pool); - break; - - case FFESTD_stmtidR839_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_R839 (stmt->u.R839.target); - malloc_pool_kill (stmt->u.R839.pool); - break; - - case FFESTD_stmtidR840_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_R840 (stmt->u.R840.expr, stmt->u.R840.neg, stmt->u.R840.zero, - stmt->u.R840.pos); - malloc_pool_kill (stmt->u.R840.pool); - break; - - case FFESTD_stmtidR841_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_R841 (); - break; - - case FFESTD_stmtidR842_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_R842 (stmt->u.R842.expr); - if (stmt->u.R842.pool != NULL) - malloc_pool_kill (stmt->u.R842.pool); - break; - - case FFESTD_stmtidR843_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_R843 (stmt->u.R843.expr); - malloc_pool_kill (stmt->u.R843.pool); - break; - - case FFESTD_stmtidR904_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_R904 (stmt->u.R904.params); - malloc_pool_kill (stmt->u.R904.pool); - break; - - case FFESTD_stmtidR907_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_R907 (stmt->u.R907.params); - malloc_pool_kill (stmt->u.R907.pool); - break; - - case FFESTD_stmtidR909_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_R909_start (stmt->u.R909.params, stmt->u.R909.only_format, - stmt->u.R909.unit, stmt->u.R909.format, - stmt->u.R909.rec, stmt->u.R909.key); - for (expr = stmt->u.R909.list; expr != NULL; expr = expr->next) - { - if (okay) - ffeste_R909_item (expr->expr, expr->token); - ffelex_token_kill (expr->token); - } - if (okay) - ffeste_R909_finish (); - malloc_pool_kill (stmt->u.R909.pool); - break; - - case FFESTD_stmtidR910_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_R910_start (stmt->u.R910.params, stmt->u.R910.unit, - stmt->u.R910.format, stmt->u.R910.rec); - for (expr = stmt->u.R910.list; expr != NULL; expr = expr->next) - { - if (okay) - ffeste_R910_item (expr->expr, expr->token); - ffelex_token_kill (expr->token); - } - if (okay) - ffeste_R910_finish (); - malloc_pool_kill (stmt->u.R910.pool); - break; - - case FFESTD_stmtidR911_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_R911_start (stmt->u.R911.params, stmt->u.R911.format); - for (expr = stmt->u.R911.list; expr != NULL; expr = expr->next) - { - if (okay) - ffeste_R911_item (expr->expr, expr->token); - ffelex_token_kill (expr->token); - } - if (okay) - ffeste_R911_finish (); - malloc_pool_kill (stmt->u.R911.pool); - break; - - case FFESTD_stmtidR919_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_R919 (stmt->u.R919.params); - malloc_pool_kill (stmt->u.R919.pool); - break; - - case FFESTD_stmtidR920_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_R920 (stmt->u.R920.params); - malloc_pool_kill (stmt->u.R920.pool); - break; - - case FFESTD_stmtidR921_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_R921 (stmt->u.R921.params); - malloc_pool_kill (stmt->u.R921.pool); - break; - - case FFESTD_stmtidR923A_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_R923A (stmt->u.R923A.params, stmt->u.R923A.by_file); - malloc_pool_kill (stmt->u.R923A.pool); - break; - - case FFESTD_stmtidR923B_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_R923B_start (stmt->u.R923B.params); - for (expr = stmt->u.R923B.list; expr != NULL; expr = expr->next) - { - if (okay) - ffeste_R923B_item (expr->expr); - } - if (okay) - ffeste_R923B_finish (); - malloc_pool_kill (stmt->u.R923B.pool); - break; - - case FFESTD_stmtidR1001_: - if (okay) - ffeste_R1001 (&stmt->u.R1001.str); - ffests_kill (&stmt->u.R1001.str); - break; - - case FFESTD_stmtidR1103_: - if (okay) - ffeste_R1103 (); - break; - - case FFESTD_stmtidR1112_: - if (okay) - ffeste_R1112 (); - break; - - case FFESTD_stmtidR1212_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_R1212 (stmt->u.R1212.expr); - malloc_pool_kill (stmt->u.R1212.pool); - break; - - case FFESTD_stmtidR1221_: - if (okay) - ffeste_R1221 (); - break; - - case FFESTD_stmtidR1225_: - if (okay) - ffeste_R1225 (); - break; - - case FFESTD_stmtidR1226_: - ffestd_subr_line_restore_ (stmt); - if (stmt->u.R1226.entry != NULL) - { - if (okay) - ffeste_R1226 (stmt->u.R1226.entry); - } - break; - - case FFESTD_stmtidR1227_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_R1227 (stmt->u.R1227.block, stmt->u.R1227.expr); - malloc_pool_kill (stmt->u.R1227.pool); - break; - - case FFESTD_stmtidV020_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_V020_start (stmt->u.V020.params, stmt->u.V020.format); - for (expr = stmt->u.V020.list; expr != NULL; expr = expr->next) - { - if (okay) - ffeste_V020_item (expr->expr); - } - if (okay) - ffeste_V020_finish (); - malloc_pool_kill (stmt->u.V020.pool); - break; - - default: - assert ("bad stmt->id" == NULL); - break; - } - } -} - -/* ffestd_subr_copy_easy_ -- Copy I/O statement data structure - - ffestd_subr_copy_easy_(); - - Copies all data except tokens in the I/O data structure into a new - structure that lasts as long as the output pool for the current - statement. Assumes that they are - overlaid with each other (union) in stp.h and the typing - and structure references assume (though not necessarily dangerous if - FALSE) that INQUIRE has the most file elements. */ - -#if FFESTD_COPY_EASY_ -static ffestpInquireStmt * -ffestd_subr_copy_easy_ (ffestpInquireIx max) -{ - ffestpInquireStmt *stmt; - ffestpInquireIx ix; - - stmt = malloc_new_kp (ffesta_output_pool, "FFESTD easy", - sizeof (ffestpFile) * max); - - for (ix = 0; ix < max; ++ix) - { - if ((stmt->inquire_spec[ix].kw_or_val_present - = ffestp_file.inquire.inquire_spec[ix].kw_or_val_present) - && (stmt->inquire_spec[ix].value_present - = ffestp_file.inquire.inquire_spec[ix].value_present)) - { - if ((stmt->inquire_spec[ix].value_is_label - = ffestp_file.inquire.inquire_spec[ix].value_is_label)) - stmt->inquire_spec[ix].u.label - = ffestp_file.inquire.inquire_spec[ix].u.label; - else - stmt->inquire_spec[ix].u.expr - = ffestp_file.inquire.inquire_spec[ix].u.expr; - } - } - - return stmt; -} - -#endif -/* ffestd_subr_labels_ -- Handle any undefined labels - - ffestd_subr_labels_(FALSE); - - For every undefined label, generate an error message and either define - label as a FORMAT() statement (for FORMAT labels) or as a STOP statement - (for all other labels). */ - -static void -ffestd_subr_labels_ (bool unexpected) -{ - ffelab l; - ffelabHandle h; - ffelabNumber undef; - ffesttFormatList f; - - undef = ffelab_number () - ffestv_num_label_defines_; - - for (h = ffelab_handle_first (); h != NULL; h = ffelab_handle_next (h)) - { - l = ffelab_handle_target (h); - if (ffewhere_line_is_unknown (ffelab_definition_line (l))) - { /* Undefined label. */ - assert (!unexpected); - assert (undef > 0); - undef--; - ffebad_start (FFEBAD_UNDEF_LABEL); - if (ffelab_type (l) == FFELAB_typeLOOPEND) - ffebad_here (0, ffelab_doref_line (l), ffelab_doref_column (l)); - else if (ffelab_type (l) != FFELAB_typeANY) - ffebad_here (0, ffelab_firstref_line (l), ffelab_firstref_column (l)); - else if (!ffewhere_line_is_unknown (ffelab_firstref_line (l))) - ffebad_here (0, ffelab_firstref_line (l), ffelab_firstref_column (l)); - else if (!ffewhere_line_is_unknown (ffelab_doref_line (l))) - ffebad_here (0, ffelab_doref_line (l), ffelab_doref_column (l)); - else - ffebad_here (0, ffelab_definition_line (l), ffelab_definition_column (l)); - ffebad_finish (); - - switch (ffelab_type (l)) - { - case FFELAB_typeFORMAT: - ffelab_set_definition_line (l, - ffewhere_line_use (ffelab_firstref_line (l))); - ffelab_set_definition_column (l, - ffewhere_column_use (ffelab_firstref_column (l))); - ffestv_num_label_defines_++; - f = ffestt_formatlist_create (NULL, NULL); - ffestd_labeldef_format (l); - ffestd_R1001 (f); - ffestt_formatlist_kill (f); - break; - - case FFELAB_typeASSIGNABLE: - ffelab_set_definition_line (l, - ffewhere_line_use (ffelab_firstref_line (l))); - ffelab_set_definition_column (l, - ffewhere_column_use (ffelab_firstref_column (l))); - ffestv_num_label_defines_++; - ffelab_set_type (l, FFELAB_typeNOTLOOP); - ffelab_set_blocknum (l, ffestw_blocknum (ffestw_stack_top ())); - ffestd_labeldef_notloop (l); - ffestd_R842 (NULL); - break; - - case FFELAB_typeNOTLOOP: - ffelab_set_definition_line (l, - ffewhere_line_use (ffelab_firstref_line (l))); - ffelab_set_definition_column (l, - ffewhere_column_use (ffelab_firstref_column (l))); - ffestv_num_label_defines_++; - ffelab_set_blocknum (l, ffestw_blocknum (ffestw_stack_top ())); - ffestd_labeldef_notloop (l); - ffestd_R842 (NULL); - break; - - default: - assert ("bad label type" == NULL); - /* Fall through. */ - case FFELAB_typeUNKNOWN: - case FFELAB_typeANY: - break; - } - } - } - ffelab_handle_done (h); - assert (undef == 0); -} - -/* ffestd_subr_vxt_ -- Report error about lack of full VXT support - - ffestd_subr_vxt_(); */ - -static void -ffestd_subr_vxt_ (void) -{ - ffebad_start (FFEBAD_VXT_UNSUPPORTED); - ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), - ffelex_token_where_column (ffesta_tokens[0])); - ffebad_finish (); -} - -/* ffestd_begin_uses -- Start a bunch of USE statements - - ffestd_begin_uses(); - - Invoked before handling the first USE statement in a block of one or - more USE statements. _end_uses_(bool ok) is invoked before handling - the first statement after the block (there are no BEGIN USE and END USE - statements, but the semantics of USE statements effectively requires - handling them as a single block rather than one statement at a time). */ - -void -ffestd_begin_uses (void) -{ -} - -/* ffestd_do -- End of statement following DO-term-stmt etc - - ffestd_do(TRUE); - - Also invoked by _labeldef_branch_finish_ (or, in cases - of errors, other _labeldef_ functions) when the label definition is - for a DO-target (LOOPEND) label, once per matching/outstanding DO - block on the stack. These cases invoke this function with ok==TRUE, so - only forced stack popping (via ffestd_eof_()) invokes it with ok==FALSE. */ - -void -ffestd_do (bool ok UNUSED) -{ - ffestdStmt_ stmt; - - stmt = ffestd_stmt_new_ (FFESTD_stmtidENDDOLOOP_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.enddoloop.block = ffestw_stack_top (); - - --ffestd_block_level_; - assert (ffestd_block_level_ >= 0); -} - -/* ffestd_end_R807 -- End of statement following logical IF - - ffestd_end_R807(TRUE); - - Applies ONLY to logical IF, not to IF-THEN. For example, does not - ffelex_token_kill the construct name for an IF-THEN block (the name - field is invalid for logical IF). ok==TRUE iff statement following - logical IF (substatement) is valid; else, statement is invalid or - stack forcibly popped due to ffestd_eof_(). */ - -void -ffestd_end_R807 (bool ok UNUSED) -{ - ffestdStmt_ stmt; - - stmt = ffestd_stmt_new_ (FFESTD_stmtidENDLOGIF_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - - --ffestd_block_level_; - assert (ffestd_block_level_ >= 0); -} - -/* ffestd_exec_begin -- Executable statements can start coming in now - - ffestd_exec_begin(); */ - -void -ffestd_exec_begin (void) -{ - ffecom_exec_transition (); - - if (ffestd_2pass_entrypoints_ != 0) - { /* Process pending ENTRY statements now that - info filled in. */ - ffestdStmt_ stmt; - int ents = ffestd_2pass_entrypoints_; - - stmt = ffestd_stmt_list_.first; - do - { - while (stmt->id != FFESTD_stmtidR1226_) - stmt = stmt->next; - - if (!ffecom_2pass_advise_entrypoint (stmt->u.R1226.entry)) - { - stmt->u.R1226.entry = NULL; - --ffestd_2pass_entrypoints_; - } - stmt = stmt->next; - } - while (--ents != 0); - } -} - -/* ffestd_exec_end -- Executable statements can no longer come in now - - ffestd_exec_end(); */ - -void -ffestd_exec_end (void) -{ - location_t old_loc = input_location; - - ffecom_end_transition (); - - ffestd_stmt_pass_ (); - - ffecom_finish_progunit (); - - if (ffestd_2pass_entrypoints_ != 0) - { - int ents = ffestd_2pass_entrypoints_; - ffestdStmt_ stmt = ffestd_stmt_list_.first; - - do - { - while (stmt->id != FFESTD_stmtidR1226_) - stmt = stmt->next; - - if (stmt->u.R1226.entry != NULL) - { - ffestd_subr_line_restore_ (stmt); - ffecom_2pass_do_entrypoint (stmt->u.R1226.entry); - } - stmt = stmt->next; - } - while (--ents != 0); - } - - ffestd_stmt_list_.first = NULL; - ffestd_stmt_list_.last = NULL; - ffestd_2pass_entrypoints_ = 0; - - input_location = old_loc; -} - -/* ffestd_init_3 -- Initialize for any program unit - - ffestd_init_3(); */ - -void -ffestd_init_3 (void) -{ - ffestd_stmt_list_.first = (ffestdStmt_) &ffestd_stmt_list_.first; - ffestd_stmt_list_.last = (ffestdStmt_) &ffestd_stmt_list_.first; -} - -/* Generate "code" for "any" label def. */ - -void -ffestd_labeldef_any (ffelab label UNUSED) -{ -} - -/* ffestd_labeldef_branch -- Generate "code" for branch label def - - ffestd_labeldef_branch(label); */ - -void -ffestd_labeldef_branch (ffelab label) -{ - ffestdStmt_ stmt; - - stmt = ffestd_stmt_new_ (FFESTD_stmtidEXECLABEL_); - ffestd_stmt_append_ (stmt); - stmt->u.execlabel.label = label; - - ffestd_is_reachable_ = TRUE; -} - -/* ffestd_labeldef_format -- Generate "code" for FORMAT label def - - ffestd_labeldef_format(label); */ - -void -ffestd_labeldef_format (ffelab label) -{ - ffestdStmt_ stmt; - - ffestd_label_formatdef_ = label; - - stmt = ffestd_stmt_new_ (FFESTD_stmtidFORMATLABEL_); - ffestd_stmt_append_ (stmt); - stmt->u.formatlabel.label = label; -} - -/* ffestd_labeldef_useless -- Generate "code" for useless label def - - ffestd_labeldef_useless(label); */ - -void -ffestd_labeldef_useless (ffelab label UNUSED) -{ -} - -/* ffestd_R522 -- SAVE statement with no list - - ffestd_R522(); - - Verify that SAVE is valid here, and flag everything as SAVEd. */ - -void -ffestd_R522 (void) -{ - ffestd_check_simple_ (); -} - -/* ffestd_R522start -- SAVE statement list begin - - ffestd_R522start(); - - Verify that SAVE is valid here, and begin accepting items in the list. */ - -void -ffestd_R522start (void) -{ - ffestd_check_start_ (); -} - -/* ffestd_R522item_object -- SAVE statement for object-name - - ffestd_R522item_object(name_token); - - Make sure name_token identifies a valid object to be SAVEd. */ - -void -ffestd_R522item_object (ffelexToken name UNUSED) -{ - ffestd_check_item_ (); -} - -/* ffestd_R522item_cblock -- SAVE statement for common-block-name - - ffestd_R522item_cblock(name_token); - - Make sure name_token identifies a valid common block to be SAVEd. */ - -void -ffestd_R522item_cblock (ffelexToken name UNUSED) -{ - ffestd_check_item_ (); -} - -/* ffestd_R522finish -- SAVE statement list complete - - ffestd_R522finish(); - - Just wrap up any local activities. */ - -void -ffestd_R522finish (void) -{ - ffestd_check_finish_ (); -} - -/* ffestd_R524_start -- DIMENSION statement list begin - - ffestd_R524_start(bool virtual); - - Verify that DIMENSION is valid here, and begin accepting items in the list. */ - -void -ffestd_R524_start (bool virtual UNUSED) -{ - ffestd_check_start_ (); -} - -/* ffestd_R524_item -- DIMENSION statement for object-name - - ffestd_R524_item(name_token,dim_list); - - Make sure name_token identifies a valid object to be DIMENSIONd. */ - -void -ffestd_R524_item (ffelexToken name UNUSED, ffesttDimList dims UNUSED) -{ - ffestd_check_item_ (); -} - -/* ffestd_R524_finish -- DIMENSION statement list complete - - ffestd_R524_finish(); - - Just wrap up any local activities. */ - -void -ffestd_R524_finish (void) -{ - ffestd_check_finish_ (); -} - -/* ffestd_R537_start -- PARAMETER statement list begin - - ffestd_R537_start(); - - Verify that PARAMETER is valid here, and begin accepting items in the list. */ - -void -ffestd_R537_start (void) -{ - ffestd_check_start_ (); -} - -/* ffestd_R537_item -- PARAMETER statement assignment - - ffestd_R537_item(dest,dest_token,source,source_token); - - Make sure the source is a valid source for the destination; make the - assignment. */ - -void -ffestd_R537_item (ffebld dest UNUSED, ffebld source UNUSED) -{ - ffestd_check_item_ (); -} - -/* ffestd_R537_finish -- PARAMETER statement list complete - - ffestd_R537_finish(); - - Just wrap up any local activities. */ - -void -ffestd_R537_finish (void) -{ - ffestd_check_finish_ (); -} - -/* ffestd_R539 -- IMPLICIT NONE statement - - ffestd_R539(); - - Verify that the IMPLICIT NONE statement is ok here and implement. */ - -void -ffestd_R539 (void) -{ - ffestd_check_simple_ (); -} - -/* ffestd_R539start -- IMPLICIT statement - - ffestd_R539start(); - - Verify that the IMPLICIT statement is ok here and implement. */ - -void -ffestd_R539start (void) -{ - ffestd_check_start_ (); -} - -/* ffestd_R539item -- IMPLICIT statement specification (R540) - - ffestd_R539item(...); - - Verify that the type and letter list are all ok and implement. */ - -void -ffestd_R539item (ffestpType type UNUSED, ffebld kind UNUSED, - ffelexToken kindt UNUSED, ffebld len UNUSED, - ffelexToken lent UNUSED, ffesttImpList letters UNUSED) -{ - ffestd_check_item_ (); -} - -/* ffestd_R539finish -- IMPLICIT statement - - ffestd_R539finish(); - - Finish up any local activities. */ - -void -ffestd_R539finish (void) -{ - ffestd_check_finish_ (); -} - -/* ffestd_R542_start -- NAMELIST statement list begin - - ffestd_R542_start(); - - Verify that NAMELIST is valid here, and begin accepting items in the list. */ - -void -ffestd_R542_start (void) -{ - ffestd_check_start_ (); -} - -/* ffestd_R542_item_nlist -- NAMELIST statement for group-name - - ffestd_R542_item_nlist(groupname_token); - - Make sure name_token identifies a valid object to be NAMELISTd. */ - -void -ffestd_R542_item_nlist (ffelexToken name UNUSED) -{ - ffestd_check_item_ (); -} - -/* ffestd_R542_item_nitem -- NAMELIST statement for variable-name - - ffestd_R542_item_nitem(name_token); - - Make sure name_token identifies a valid object to be NAMELISTd. */ - -void -ffestd_R542_item_nitem (ffelexToken name UNUSED) -{ - ffestd_check_item_ (); -} - -/* ffestd_R542_finish -- NAMELIST statement list complete - - ffestd_R542_finish(); - - Just wrap up any local activities. */ - -void -ffestd_R542_finish (void) -{ - ffestd_check_finish_ (); -} - -/* ffestd_R547_start -- COMMON statement list begin - - ffestd_R547_start(); - - Verify that COMMON is valid here, and begin accepting items in the list. */ - -void -ffestd_R547_start (void) -{ - ffestd_check_start_ (); -} - -/* ffestd_R547_item_object -- COMMON statement for object-name - - ffestd_R547_item_object(name_token,dim_list); - - Make sure name_token identifies a valid object to be COMMONd. */ - -void -ffestd_R547_item_object (ffelexToken name UNUSED, - ffesttDimList dims UNUSED) -{ - ffestd_check_item_ (); -} - -/* ffestd_R547_item_cblock -- COMMON statement for common-block-name - - ffestd_R547_item_cblock(name_token); - - Make sure name_token identifies a valid common block to be COMMONd. */ - -void -ffestd_R547_item_cblock (ffelexToken name UNUSED) -{ - ffestd_check_item_ (); -} - -/* ffestd_R547_finish -- COMMON statement list complete - - ffestd_R547_finish(); - - Just wrap up any local activities. */ - -void -ffestd_R547_finish (void) -{ - ffestd_check_finish_ (); -} - -/* ffestd_R737A -- Assignment statement outside of WHERE - - ffestd_R737A(dest_expr,source_expr); */ - -void -ffestd_R737A (ffebld dest, ffebld source) -{ - ffestdStmt_ stmt; - - ffestd_check_simple_ (); - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR737A_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R737A.pool = ffesta_output_pool; - stmt->u.R737A.dest = dest; - stmt->u.R737A.source = source; - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); -} - - -/* Block IF (IF-THEN) statement. */ - -void -ffestd_R803 (ffelexToken construct_name UNUSED, ffebld expr) -{ - ffestdStmt_ stmt; - - ffestd_check_simple_ (); - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR803_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R803.pool = ffesta_output_pool; - stmt->u.R803.block = ffestw_use (ffestw_stack_top ()); - stmt->u.R803.expr = expr; - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); - - ++ffestd_block_level_; - assert (ffestd_block_level_ > 0); -} - -/* ELSE IF statement. */ - -void -ffestd_R804 (ffebld expr, ffelexToken name UNUSED) -{ - ffestdStmt_ stmt; - - ffestd_check_simple_ (); - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR804_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R804.pool = ffesta_output_pool; - stmt->u.R804.block = ffestw_use (ffestw_stack_top ()); - stmt->u.R804.expr = expr; - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); -} - -/* ELSE statement. */ - -void -ffestd_R805 (ffelexToken name UNUSED) -{ - ffestdStmt_ stmt; - - ffestd_check_simple_ (); - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR805_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R805.block = ffestw_use (ffestw_stack_top ()); -} - -/* END IF statement. */ - -void -ffestd_R806 (bool ok UNUSED) -{ - ffestdStmt_ stmt; - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR806_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R806.block = ffestw_use (ffestw_stack_top ()); - - --ffestd_block_level_; - assert (ffestd_block_level_ >= 0); -} - -/* ffestd_R807 -- Logical IF statement - - ffestd_R807(expr,expr_token); - - Make sure statement is valid here; implement. */ - -void -ffestd_R807 (ffebld expr) -{ - ffestdStmt_ stmt; - - ffestd_check_simple_ (); - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR807_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R807.pool = ffesta_output_pool; - stmt->u.R807.expr = expr; - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); - - ++ffestd_block_level_; - assert (ffestd_block_level_ > 0); -} - -/* ffestd_R809 -- SELECT CASE statement - - ffestd_R809(construct_name,expr,expr_token); - - Make sure statement is valid here; implement. */ - -void -ffestd_R809 (ffelexToken construct_name UNUSED, ffebld expr) -{ - ffestdStmt_ stmt; - - ffestd_check_simple_ (); - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR809_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R809.pool = ffesta_output_pool; - stmt->u.R809.block = ffestw_use (ffestw_stack_top ()); - stmt->u.R809.expr = expr; - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); - malloc_pool_use (ffestw_select (ffestw_stack_top ())->pool); - - ++ffestd_block_level_; - assert (ffestd_block_level_ > 0); -} - -/* ffestd_R810 -- CASE statement - - ffestd_R810(case_value_range_list,name); - - If casenum is 0, it's CASE DEFAULT. Else it's the case ranges at - the start of the first_stmt list in the select object at the top of - the stack that match casenum. */ - -void -ffestd_R810 (unsigned long casenum) -{ - ffestdStmt_ stmt; - - ffestd_check_simple_ (); - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR810_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R810.pool = ffesta_output_pool; - stmt->u.R810.block = ffestw_stack_top (); - stmt->u.R810.casenum = casenum; - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); -} - -/* ffestd_R811 -- End a SELECT - - ffestd_R811(TRUE); */ - -void -ffestd_R811 (bool ok UNUSED) -{ - ffestdStmt_ stmt; - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR811_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R811.block = ffestw_stack_top (); - - --ffestd_block_level_; - assert (ffestd_block_level_ >= 0); -} - -/* ffestd_R819A -- Iterative DO statement - - ffestd_R819A(construct_name,label_token,expr,expr_token); - - Make sure statement is valid here; implement. */ - -void -ffestd_R819A (ffelexToken construct_name UNUSED, ffelab label, - ffebld var, ffebld start, ffelexToken start_token, - ffebld end, ffelexToken end_token, - ffebld incr, ffelexToken incr_token) -{ - ffestdStmt_ stmt; - - ffestd_check_simple_ (); - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR819A_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R819A.pool = ffesta_output_pool; - stmt->u.R819A.block = ffestw_use (ffestw_stack_top ()); - stmt->u.R819A.label = label; - stmt->u.R819A.var = var; - stmt->u.R819A.start = start; - stmt->u.R819A.start_token = ffelex_token_use (start_token); - stmt->u.R819A.end = end; - stmt->u.R819A.end_token = ffelex_token_use (end_token); - stmt->u.R819A.incr = incr; - stmt->u.R819A.incr_token = (incr_token == NULL) ? NULL - : ffelex_token_use (incr_token); - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); - - ++ffestd_block_level_; - assert (ffestd_block_level_ > 0); -} - -/* ffestd_R819B -- DO WHILE statement - - ffestd_R819B(construct_name,label_token,expr,expr_token); - - Make sure statement is valid here; implement. */ - -void -ffestd_R819B (ffelexToken construct_name UNUSED, ffelab label, - ffebld expr) -{ - ffestdStmt_ stmt; - - ffestd_check_simple_ (); - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR819B_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R819B.pool = ffesta_output_pool; - stmt->u.R819B.block = ffestw_use (ffestw_stack_top ()); - stmt->u.R819B.label = label; - stmt->u.R819B.expr = expr; - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); - - ++ffestd_block_level_; - assert (ffestd_block_level_ > 0); -} - -/* ffestd_R825 -- END DO statement - - ffestd_R825(name_token); - - Make sure ffestd_kind_ identifies a DO block. If not - NULL, make sure name_token gives the correct name. Do whatever - is specific to seeing END DO with a DO-target label definition on it, - where the END DO is really treated as a CONTINUE (i.e. generate th - same code you would for CONTINUE). ffestd_do handles the actual - generation of end-loop code. */ - -void -ffestd_R825 (ffelexToken name UNUSED) -{ - ffestdStmt_ stmt; - - ffestd_check_simple_ (); - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR825_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); -} - -/* ffestd_R834 -- CYCLE statement - - ffestd_R834(name_token); - - Handle a CYCLE within a loop. */ - -void -ffestd_R834 (ffestw block) -{ - ffestdStmt_ stmt; - - ffestd_check_simple_ (); - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR834_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R834.block = block; -} - -/* ffestd_R835 -- EXIT statement - - ffestd_R835(name_token); - - Handle a EXIT within a loop. */ - -void -ffestd_R835 (ffestw block) -{ - ffestdStmt_ stmt; - - ffestd_check_simple_ (); - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR835_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R835.block = block; -} - -/* ffestd_R836 -- GOTO statement - - ffestd_R836(label); - - Make sure label_token identifies a valid label for a GOTO. Update - that label's info to indicate it is the target of a GOTO. */ - -void -ffestd_R836 (ffelab label) -{ - ffestdStmt_ stmt; - - ffestd_check_simple_ (); - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR836_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R836.label = label; - - if (ffestd_block_level_ == 0) - ffestd_is_reachable_ = FALSE; -} - -/* ffestd_R837 -- Computed GOTO statement - - ffestd_R837(labels,expr); - - Make sure label_list identifies valid labels for a GOTO. Update - each label's info to indicate it is the target of a GOTO. */ - -void -ffestd_R837 (ffelab *labels, int count, ffebld expr) -{ - ffestdStmt_ stmt; - - ffestd_check_simple_ (); - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR837_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R837.pool = ffesta_output_pool; - stmt->u.R837.labels = labels; - stmt->u.R837.count = count; - stmt->u.R837.expr = expr; - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); -} - -/* ffestd_R838 -- ASSIGN statement - - ffestd_R838(label_token,target_variable,target_token); - - Make sure label_token identifies a valid label for an assignment. Update - that label's info to indicate it is the source of an assignment. Update - target_variable's info to indicate it is the target the assignment of that - label. */ - -void -ffestd_R838 (ffelab label, ffebld target) -{ - ffestdStmt_ stmt; - - ffestd_check_simple_ (); - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR838_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R838.pool = ffesta_output_pool; - stmt->u.R838.label = label; - stmt->u.R838.target = target; - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); -} - -/* ffestd_R839 -- Assigned GOTO statement - - ffestd_R839(target,labels); - - Make sure label_list identifies valid labels for a GOTO. Update - each label's info to indicate it is the target of a GOTO. */ - -void -ffestd_R839 (ffebld target, ffelab *labels UNUSED, int count UNUSED) -{ - ffestdStmt_ stmt; - - ffestd_check_simple_ (); - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR839_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R839.pool = ffesta_output_pool; - stmt->u.R839.target = target; - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); - - if (ffestd_block_level_ == 0) - ffestd_is_reachable_ = FALSE; -} - -/* ffestd_R840 -- Arithmetic IF statement - - ffestd_R840(expr,expr_token,neg,zero,pos); - - Make sure the labels are valid; implement. */ - -void -ffestd_R840 (ffebld expr, ffelab neg, ffelab zero, ffelab pos) -{ - ffestdStmt_ stmt; - - ffestd_check_simple_ (); - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR840_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R840.pool = ffesta_output_pool; - stmt->u.R840.expr = expr; - stmt->u.R840.neg = neg; - stmt->u.R840.zero = zero; - stmt->u.R840.pos = pos; - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); - - if (ffestd_block_level_ == 0) - ffestd_is_reachable_ = FALSE; -} - -/* ffestd_R841 -- CONTINUE statement - - ffestd_R841(); */ - -void -ffestd_R841 (bool in_where UNUSED) -{ - ffestdStmt_ stmt; - - ffestd_check_simple_ (); - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR841_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); -} - -/* ffestd_R842 -- STOP statement - - ffestd_R842(expr); */ - -void -ffestd_R842 (ffebld expr) -{ - ffestdStmt_ stmt; - - ffestd_check_simple_ (); - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR842_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - if (ffesta_outpooldisp () == FFESTA_pooldispPRESERVE) - { - /* This is a "spurious" (automatically-generated) STOP - that follows a previous STOP or other statement. - Make sure we don't have an expression in the pool, - and then mark that the pool has already been killed. */ - assert (expr == NULL); - stmt->u.R842.pool = NULL; - stmt->u.R842.expr = NULL; - } - else - { - stmt->u.R842.pool = ffesta_output_pool; - stmt->u.R842.expr = expr; - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); - } - - if (ffestd_block_level_ == 0) - ffestd_is_reachable_ = FALSE; -} - -/* ffestd_R843 -- PAUSE statement - - ffestd_R843(expr,expr_token); - - Make sure statement is valid here; implement. expr and expr_token are - both NULL if there was no expression. */ - -void -ffestd_R843 (ffebld expr) -{ - ffestdStmt_ stmt; - - ffestd_check_simple_ (); - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR843_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R843.pool = ffesta_output_pool; - stmt->u.R843.expr = expr; - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); -} - -/* ffestd_R904 -- OPEN statement - - ffestd_R904(); - - Make sure an OPEN is valid in the current context, and implement it. */ - -void -ffestd_R904 (void) -{ - ffestdStmt_ stmt; - - ffestd_check_simple_ (); - -#define specified(something) \ - (ffestp_file.open.open_spec[something].kw_or_val_present) - - /* Warn if there are any thing we don't handle via f2c libraries. */ - - if (specified (FFESTP_openixACTION) - || specified (FFESTP_openixASSOCIATEVARIABLE) - || specified (FFESTP_openixBLOCKSIZE) - || specified (FFESTP_openixBUFFERCOUNT) - || specified (FFESTP_openixCARRIAGECONTROL) - || specified (FFESTP_openixDEFAULTFILE) - || specified (FFESTP_openixDELIM) - || specified (FFESTP_openixDISPOSE) - || specified (FFESTP_openixEXTENDSIZE) - || specified (FFESTP_openixINITIALSIZE) - || specified (FFESTP_openixKEY) - || specified (FFESTP_openixMAXREC) - || specified (FFESTP_openixNOSPANBLOCKS) - || specified (FFESTP_openixORGANIZATION) - || specified (FFESTP_openixPAD) - || specified (FFESTP_openixPOSITION) - || specified (FFESTP_openixREADONLY) - || specified (FFESTP_openixRECORDTYPE) - || specified (FFESTP_openixSHARED) - || specified (FFESTP_openixUSEROPEN)) - { - ffebad_start (FFEBAD_OPEN_UNSUPPORTED); - ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), - ffelex_token_where_column (ffesta_tokens[0])); - ffebad_finish (); - } - -#undef specified - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR904_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R904.pool = ffesta_output_pool; - stmt->u.R904.params = ffestd_subr_copy_open_ (); - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); -} - -/* ffestd_R907 -- CLOSE statement - - ffestd_R907(); - - Make sure a CLOSE is valid in the current context, and implement it. */ - -void -ffestd_R907 (void) -{ - ffestdStmt_ stmt; - - ffestd_check_simple_ (); - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR907_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R907.pool = ffesta_output_pool; - stmt->u.R907.params = ffestd_subr_copy_close_ (); - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); -} - -/* ffestd_R909_start -- READ(...) statement list begin - - ffestd_R909_start(FALSE); - - Verify that READ is valid here, and begin accepting items in the - list. */ - -void -ffestd_R909_start (bool only_format, ffestvUnit unit, - ffestvFormat format, bool rec, bool key) -{ - ffestdStmt_ stmt; - - ffestd_check_start_ (); - -#define specified(something) \ - (ffestp_file.read.read_spec[something].kw_or_val_present) - - /* Warn if there are any thing we don't handle via f2c libraries. */ - if (specified (FFESTP_readixADVANCE) - || specified (FFESTP_readixEOR) - || specified (FFESTP_readixKEYEQ) - || specified (FFESTP_readixKEYGE) - || specified (FFESTP_readixKEYGT) - || specified (FFESTP_readixKEYID) - || specified (FFESTP_readixNULLS) - || specified (FFESTP_readixSIZE)) - { - ffebad_start (FFEBAD_READ_UNSUPPORTED); - ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), - ffelex_token_where_column (ffesta_tokens[0])); - ffebad_finish (); - } - -#undef specified - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR909_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R909.pool = ffesta_output_pool; - stmt->u.R909.params = ffestd_subr_copy_read_ (); - stmt->u.R909.only_format = only_format; - stmt->u.R909.unit = unit; - stmt->u.R909.format = format; - stmt->u.R909.rec = rec; - stmt->u.R909.key = key; - stmt->u.R909.list = NULL; - ffestd_expr_list_ = &stmt->u.R909.list; - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); -} - -/* ffestd_R909_item -- READ statement i/o item - - ffestd_R909_item(expr,expr_token); - - Implement output-list expression. */ - -void -ffestd_R909_item (ffebld expr, ffelexToken expr_token) -{ - ffestdExprItem_ item; - - ffestd_check_item_ (); - - item = malloc_new_kp (ffesta_output_pool, "ffestdExprItem_", sizeof (*item)); - - item->next = NULL; - item->expr = expr; - item->token = ffelex_token_use (expr_token); - *ffestd_expr_list_ = item; - ffestd_expr_list_ = &item->next; -} - -/* ffestd_R909_finish -- READ statement list complete - - ffestd_R909_finish(); - - Just wrap up any local activities. */ - -void -ffestd_R909_finish (void) -{ - ffestd_check_finish_ (); -} - -/* ffestd_R910_start -- WRITE(...) statement list begin - - ffestd_R910_start(); - - Verify that WRITE is valid here, and begin accepting items in the - list. */ - -void -ffestd_R910_start (ffestvUnit unit, ffestvFormat format, bool rec) -{ - ffestdStmt_ stmt; - - ffestd_check_start_ (); - -#define specified(something) \ - (ffestp_file.write.write_spec[something].kw_or_val_present) - - /* Warn if there are any thing we don't handle via f2c libraries. */ - if (specified (FFESTP_writeixADVANCE) - || specified (FFESTP_writeixEOR)) - { - ffebad_start (FFEBAD_WRITE_UNSUPPORTED); - ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), - ffelex_token_where_column (ffesta_tokens[0])); - ffebad_finish (); - } - -#undef specified - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR910_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R910.pool = ffesta_output_pool; - stmt->u.R910.params = ffestd_subr_copy_write_ (); - stmt->u.R910.unit = unit; - stmt->u.R910.format = format; - stmt->u.R910.rec = rec; - stmt->u.R910.list = NULL; - ffestd_expr_list_ = &stmt->u.R910.list; - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); -} - -/* ffestd_R910_item -- WRITE statement i/o item - - ffestd_R910_item(expr,expr_token); - - Implement output-list expression. */ - -void -ffestd_R910_item (ffebld expr, ffelexToken expr_token) -{ - ffestdExprItem_ item; - - ffestd_check_item_ (); - - item = malloc_new_kp (ffesta_output_pool, "ffestdExprItem_", sizeof (*item)); - - item->next = NULL; - item->expr = expr; - item->token = ffelex_token_use (expr_token); - *ffestd_expr_list_ = item; - ffestd_expr_list_ = &item->next; -} - -/* ffestd_R910_finish -- WRITE statement list complete - - ffestd_R910_finish(); - - Just wrap up any local activities. */ - -void -ffestd_R910_finish (void) -{ - ffestd_check_finish_ (); -} - -/* ffestd_R911_start -- PRINT statement list begin - - ffestd_R911_start(); - - Verify that PRINT is valid here, and begin accepting items in the - list. */ - -void -ffestd_R911_start (ffestvFormat format) -{ - ffestdStmt_ stmt; - - ffestd_check_start_ (); - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR911_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R911.pool = ffesta_output_pool; - stmt->u.R911.params = ffestd_subr_copy_print_ (); - stmt->u.R911.format = format; - stmt->u.R911.list = NULL; - ffestd_expr_list_ = &stmt->u.R911.list; - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); -} - -/* ffestd_R911_item -- PRINT statement i/o item - - ffestd_R911_item(expr,expr_token); - - Implement output-list expression. */ - -void -ffestd_R911_item (ffebld expr, ffelexToken expr_token) -{ - ffestdExprItem_ item; - - ffestd_check_item_ (); - - item = malloc_new_kp (ffesta_output_pool, "ffestdExprItem_", sizeof (*item)); - - item->next = NULL; - item->expr = expr; - item->token = ffelex_token_use (expr_token); - *ffestd_expr_list_ = item; - ffestd_expr_list_ = &item->next; -} - -/* ffestd_R911_finish -- PRINT statement list complete - - ffestd_R911_finish(); - - Just wrap up any local activities. */ - -void -ffestd_R911_finish (void) -{ - ffestd_check_finish_ (); -} - -/* ffestd_R919 -- BACKSPACE statement - - ffestd_R919(); - - Make sure a BACKSPACE is valid in the current context, and implement it. */ - -void -ffestd_R919 (void) -{ - ffestdStmt_ stmt; - - ffestd_check_simple_ (); - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR919_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R919.pool = ffesta_output_pool; - stmt->u.R919.params = ffestd_subr_copy_beru_ (); - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); -} - -/* ffestd_R920 -- ENDFILE statement - - ffestd_R920(); - - Make sure a ENDFILE is valid in the current context, and implement it. */ - -void -ffestd_R920 (void) -{ - ffestdStmt_ stmt; - - ffestd_check_simple_ (); - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR920_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R920.pool = ffesta_output_pool; - stmt->u.R920.params = ffestd_subr_copy_beru_ (); - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); -} - -/* ffestd_R921 -- REWIND statement - - ffestd_R921(); - - Make sure a REWIND is valid in the current context, and implement it. */ - -void -ffestd_R921 (void) -{ - ffestdStmt_ stmt; - - ffestd_check_simple_ (); - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR921_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R921.pool = ffesta_output_pool; - stmt->u.R921.params = ffestd_subr_copy_beru_ (); - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); -} - -/* ffestd_R923A -- INQUIRE statement (non-IOLENGTH version) - - ffestd_R923A(bool by_file); - - Make sure an INQUIRE is valid in the current context, and implement it. */ - -void -ffestd_R923A (bool by_file) -{ - ffestdStmt_ stmt; - - ffestd_check_simple_ (); - -#define specified(something) \ - (ffestp_file.inquire.inquire_spec[something].kw_or_val_present) - - /* Warn if there are any thing we don't handle via f2c libraries. */ - if (specified (FFESTP_inquireixACTION) - || specified (FFESTP_inquireixCARRIAGECONTROL) - || specified (FFESTP_inquireixDEFAULTFILE) - || specified (FFESTP_inquireixDELIM) - || specified (FFESTP_inquireixKEYED) - || specified (FFESTP_inquireixORGANIZATION) - || specified (FFESTP_inquireixPAD) - || specified (FFESTP_inquireixPOSITION) - || specified (FFESTP_inquireixREAD) - || specified (FFESTP_inquireixREADWRITE) - || specified (FFESTP_inquireixRECORDTYPE) - || specified (FFESTP_inquireixWRITE)) - { - ffebad_start (FFEBAD_INQUIRE_UNSUPPORTED); - ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), - ffelex_token_where_column (ffesta_tokens[0])); - ffebad_finish (); - } - -#undef specified - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR923A_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R923A.pool = ffesta_output_pool; - stmt->u.R923A.params = ffestd_subr_copy_inquire_ (); - stmt->u.R923A.by_file = by_file; - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); -} - -/* ffestd_R923B_start -- INQUIRE(IOLENGTH=expr) statement list begin - - ffestd_R923B_start(); - - Verify that INQUIRE is valid here, and begin accepting items in the - list. */ - -void -ffestd_R923B_start (void) -{ - ffestdStmt_ stmt; - - ffestd_check_start_ (); - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR923B_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R923B.pool = ffesta_output_pool; - stmt->u.R923B.params = ffestd_subr_copy_inquire_ (); - stmt->u.R923B.list = NULL; - ffestd_expr_list_ = &stmt->u.R923B.list; - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); -} - -/* ffestd_R923B_item -- INQUIRE statement i/o item - - ffestd_R923B_item(expr,expr_token); - - Implement output-list expression. */ - -void -ffestd_R923B_item (ffebld expr) -{ - ffestdExprItem_ item; - - ffestd_check_item_ (); - - item = malloc_new_kp (ffesta_output_pool, "ffestdExprItem_", sizeof (*item)); - - item->next = NULL; - item->expr = expr; - *ffestd_expr_list_ = item; - ffestd_expr_list_ = &item->next; -} - -/* ffestd_R923B_finish -- INQUIRE statement list complete - - ffestd_R923B_finish(); - - Just wrap up any local activities. */ - -void -ffestd_R923B_finish (void) -{ - ffestd_check_finish_ (); -} - -/* ffestd_R1001 -- FORMAT statement - - ffestd_R1001(format_list); */ - -void -ffestd_R1001 (ffesttFormatList f) -{ - ffestsHolder str; - ffests s = &str; - ffestdStmt_ stmt; - - ffestd_check_simple_ (); - - if (ffestd_label_formatdef_ == NULL) - return; /* Nothing to hook it up to (no label def). */ - - ffests_new (s, malloc_pool_image (), 80); - ffests_putc (s, '('); - ffestd_R1001dump_ (s, f); /* Build the string in s. */ - ffests_putc (s, ')'); - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR1001_); - ffestd_stmt_append_ (stmt); - stmt->u.R1001.str = str; - - ffestd_label_formatdef_ = NULL; -} - -/* ffestd_R1001dump_ -- Dump list of formats - - ffesttFormatList list; - ffestd_R1001dump_(list,0); - - The formats in the list are dumped. */ - -static void -ffestd_R1001dump_ (ffests s, ffesttFormatList list) -{ - ffesttFormatList next; - - for (next = list->next; next != list; next = next->next) - { - if (next != list->next) - ffests_putc (s, ','); - switch (next->type) - { - case FFESTP_formattypeI: - ffestd_R1001dump_1005_3_ (s, next, "I"); - break; - - case FFESTP_formattypeB: - ffestd_R1001error_ (next); - break; - - case FFESTP_formattypeO: - ffestd_R1001dump_1005_3_ (s, next, "O"); - break; - - case FFESTP_formattypeZ: - ffestd_R1001dump_1005_3_ (s, next, "Z"); - break; - - case FFESTP_formattypeF: - ffestd_R1001dump_1005_4_ (s, next, "F"); - break; - - case FFESTP_formattypeE: - ffestd_R1001dump_1005_5_ (s, next, "E"); - break; - - case FFESTP_formattypeEN: - ffestd_R1001error_ (next); - break; - - case FFESTP_formattypeG: - ffestd_R1001dump_1005_5_ (s, next, "G"); - break; - - case FFESTP_formattypeL: - ffestd_R1001dump_1005_2_ (s, next, "L"); - break; - - case FFESTP_formattypeA: - ffestd_R1001dump_1005_1_ (s, next, "A"); - break; - - case FFESTP_formattypeD: - ffestd_R1001dump_1005_4_ (s, next, "D"); - break; - - case FFESTP_formattypeQ: - ffestd_R1001error_ (next); - break; - - case FFESTP_formattypeDOLLAR: - ffestd_R1001dump_1010_1_ (s, next, "$"); - break; - - case FFESTP_formattypeP: - ffestd_R1001dump_1010_4_ (s, next, "P"); - break; - - case FFESTP_formattypeT: - ffestd_R1001dump_1010_5_ (s, next, "T"); - break; - - case FFESTP_formattypeTL: - ffestd_R1001dump_1010_5_ (s, next, "TL"); - break; - - case FFESTP_formattypeTR: - ffestd_R1001dump_1010_5_ (s, next, "TR"); - break; - - case FFESTP_formattypeX: - ffestd_R1001dump_1010_2_ (s, next, "X"); - break; - - case FFESTP_formattypeS: - ffestd_R1001dump_1010_1_ (s, next, "S"); - break; - - case FFESTP_formattypeSP: - ffestd_R1001dump_1010_1_ (s, next, "SP"); - break; - - case FFESTP_formattypeSS: - ffestd_R1001dump_1010_1_ (s, next, "SS"); - break; - - case FFESTP_formattypeBN: - ffestd_R1001dump_1010_1_ (s, next, "BN"); - break; - - case FFESTP_formattypeBZ: - ffestd_R1001dump_1010_1_ (s, next, "BZ"); - break; - - case FFESTP_formattypeSLASH: - ffestd_R1001dump_1010_2_ (s, next, "/"); - break; - - case FFESTP_formattypeCOLON: - ffestd_R1001dump_1010_1_ (s, next, ":"); - break; - - case FFESTP_formattypeR1016: - switch (ffelex_token_type (next->t)) - { - case FFELEX_typeCHARACTER: - { - char *p = ffelex_token_text (next->t); - ffeTokenLength i = ffelex_token_length (next->t); - - ffests_putc (s, '\002'); - while (i-- != 0) - { - if (*p == '\002') - ffests_putc (s, '\002'); - ffests_putc (s, *p); - ++p; - } - ffests_putc (s, '\002'); - } - break; - - case FFELEX_typeHOLLERITH: - { - char *p = ffelex_token_text (next->t); - ffeTokenLength i = ffelex_token_length (next->t); - - ffests_printf (s, "%" ffeTokenLength_f "uH", i); - while (i-- != 0) - { - ffests_putc (s, *p); - ++p; - } - } - break; - - default: - assert (FALSE); - } - break; - - case FFESTP_formattypeFORMAT: - if (next->u.R1003D.R1004.present) - { - if (next->u.R1003D.R1004.rtexpr) - ffestd_R1001rtexpr_ (s, next, next->u.R1003D.R1004.u.expr); - else - ffests_printf (s, "%lu", next->u.R1003D.R1004.u.unsigned_val); - } - - ffests_putc (s, '('); - ffestd_R1001dump_ (s, next->u.R1003D.format); - ffests_putc (s, ')'); - break; - - default: - assert (FALSE); - } - } -} - -/* ffestd_R1001dump_1005_1_ -- Dump a particular format - - ffesttFormatList f; - ffestd_R1001dump_1005_1_(f,"I"); - - The format is dumped with form [r]X[w]. */ - -static void -ffestd_R1001dump_1005_1_ (ffests s, ffesttFormatList f, const char *string) -{ - assert (!f->u.R1005.R1007_or_R1008.present); - assert (!f->u.R1005.R1009.present); - - if (f->u.R1005.R1004.present) - { - if (f->u.R1005.R1004.rtexpr) - ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr); - else - ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val); - } - - ffests_puts (s, string); - - if (f->u.R1005.R1006.present) - { - if (f->u.R1005.R1006.rtexpr) - ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr); - else - ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val); - } -} - -/* ffestd_R1001dump_1005_2_ -- Dump a particular format - - ffesttFormatList f; - ffestd_R1001dump_1005_2_(f,"I"); - - The format is dumped with form [r]Xw. */ - -static void -ffestd_R1001dump_1005_2_ (ffests s, ffesttFormatList f, const char *string) -{ - assert (!f->u.R1005.R1007_or_R1008.present); - assert (!f->u.R1005.R1009.present); - assert (f->u.R1005.R1006.present); - - if (f->u.R1005.R1004.present) - { - if (f->u.R1005.R1004.rtexpr) - ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr); - else - ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val); - } - - ffests_puts (s, string); - - if (f->u.R1005.R1006.rtexpr) - ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr); - else - ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val); -} - -/* ffestd_R1001dump_1005_3_ -- Dump a particular format - - ffesttFormatList f; - ffestd_R1001dump_1005_3_(f,"I"); - - The format is dumped with form [r]Xw[.m]. */ - -static void -ffestd_R1001dump_1005_3_ (ffests s, ffesttFormatList f, const char *string) -{ - assert (!f->u.R1005.R1009.present); - assert (f->u.R1005.R1006.present); - - if (f->u.R1005.R1004.present) - { - if (f->u.R1005.R1004.rtexpr) - ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr); - else - ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val); - } - - ffests_puts (s, string); - - if (f->u.R1005.R1006.rtexpr) - ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr); - else - ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val); - - if (f->u.R1005.R1007_or_R1008.present) - { - ffests_putc (s, '.'); - if (f->u.R1005.R1007_or_R1008.rtexpr) - ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1007_or_R1008.u.expr); - else - ffests_printf (s, "%lu", f->u.R1005.R1007_or_R1008.u.unsigned_val); - } -} - -/* ffestd_R1001dump_1005_4_ -- Dump a particular format - - ffesttFormatList f; - ffestd_R1001dump_1005_4_(f,"I"); - - The format is dumped with form [r]Xw.d. */ - -static void -ffestd_R1001dump_1005_4_ (ffests s, ffesttFormatList f, const char *string) -{ - assert (!f->u.R1005.R1009.present); - assert (f->u.R1005.R1007_or_R1008.present); - assert (f->u.R1005.R1006.present); - - if (f->u.R1005.R1004.present) - { - if (f->u.R1005.R1004.rtexpr) - ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr); - else - ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val); - } - - ffests_puts (s, string); - - if (f->u.R1005.R1006.rtexpr) - ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr); - else - ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val); - - ffests_putc (s, '.'); - if (f->u.R1005.R1007_or_R1008.rtexpr) - ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1007_or_R1008.u.expr); - else - ffests_printf (s, "%lu", f->u.R1005.R1007_or_R1008.u.unsigned_val); -} - -/* ffestd_R1001dump_1005_5_ -- Dump a particular format - - ffesttFormatList f; - ffestd_R1001dump_1005_5_(f,"I"); - - The format is dumped with form [r]Xw.d[Ee]. */ - -static void -ffestd_R1001dump_1005_5_ (ffests s, ffesttFormatList f, const char *string) -{ - assert (f->u.R1005.R1007_or_R1008.present); - assert (f->u.R1005.R1006.present); - - if (f->u.R1005.R1004.present) - { - if (f->u.R1005.R1004.rtexpr) - ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr); - else - ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val); - } - - ffests_puts (s, string); - - if (f->u.R1005.R1006.rtexpr) - ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr); - else - ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val); - - ffests_putc (s, '.'); - if (f->u.R1005.R1007_or_R1008.rtexpr) - ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1007_or_R1008.u.expr); - else - ffests_printf (s, "%lu", f->u.R1005.R1007_or_R1008.u.unsigned_val); - - if (f->u.R1005.R1009.present) - { - ffests_putc (s, 'E'); - if (f->u.R1005.R1009.rtexpr) - ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1009.u.expr); - else - ffests_printf (s, "%lu", f->u.R1005.R1009.u.unsigned_val); - } -} - -/* ffestd_R1001dump_1010_1_ -- Dump a particular format - - ffesttFormatList f; - ffestd_R1001dump_1010_1_(f,"I"); - - The format is dumped with form X. */ - -static void -ffestd_R1001dump_1010_1_ (ffests s, ffesttFormatList f, const char *string) -{ - assert (!f->u.R1010.val.present); - - ffests_puts (s, string); -} - -/* ffestd_R1001dump_1010_2_ -- Dump a particular format - - ffesttFormatList f; - ffestd_R1001dump_1010_2_(f,"I"); - - The format is dumped with form [r]X. */ - -static void -ffestd_R1001dump_1010_2_ (ffests s, ffesttFormatList f, const char *string) -{ - if (f->u.R1010.val.present) - { - if (f->u.R1010.val.rtexpr) - ffestd_R1001rtexpr_ (s, f, f->u.R1010.val.u.expr); - else - ffests_printf (s, "%lu", f->u.R1010.val.u.unsigned_val); - } - - ffests_puts (s, string); -} - -/* ffestd_R1001dump_1010_4_ -- Dump a particular format - - ffesttFormatList f; - ffestd_R1001dump_1010_4_(f,"I"); - - The format is dumped with form kX. Note that k is signed. */ - -static void -ffestd_R1001dump_1010_4_ (ffests s, ffesttFormatList f, const char *string) -{ - assert (f->u.R1010.val.present); - - if (f->u.R1010.val.rtexpr) - ffestd_R1001rtexpr_ (s, f, f->u.R1010.val.u.expr); - else - ffests_printf (s, "%ld", f->u.R1010.val.u.signed_val); - - ffests_puts (s, string); -} - -/* ffestd_R1001dump_1010_5_ -- Dump a particular format - - ffesttFormatList f; - ffestd_R1001dump_1010_5_(f,"I"); - - The format is dumped with form Xn. */ - -static void -ffestd_R1001dump_1010_5_ (ffests s, ffesttFormatList f, const char *string) -{ - assert (f->u.R1010.val.present); - - ffests_puts (s, string); - - if (f->u.R1010.val.rtexpr) - ffestd_R1001rtexpr_ (s, f, f->u.R1010.val.u.expr); - else - ffests_printf (s, "%lu", f->u.R1010.val.u.unsigned_val); -} - -/* ffestd_R1001error_ -- Complain about FORMAT specification not supported - - ffesttFormatList f; - ffestd_R1001error_(f); - - An error message is produced. */ - -static void -ffestd_R1001error_ (ffesttFormatList f) -{ - ffebad_start (FFEBAD_FORMAT_UNSUPPORTED); - ffebad_here (0, ffelex_token_where_line (f->t), ffelex_token_where_column (f->t)); - ffebad_finish (); -} - -static void -ffestd_R1001rtexpr_ (ffests s, ffesttFormatList f, ffebld expr) -{ - if ((expr == NULL) - || (ffebld_op (expr) != FFEBLD_opCONTER) - || (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeINTEGER) - || (ffeinfo_kindtype (ffebld_info (expr)) == FFEINFO_kindtypeINTEGER4)) - { - ffebad_start (FFEBAD_FORMAT_VARIABLE); - ffebad_here (0, ffelex_token_where_line (f->t), ffelex_token_where_column (f->t)); - ffebad_finish (); - } - else - { - int val; - - switch (ffeinfo_kindtype (ffebld_info (expr))) - { -#if FFETARGET_okINTEGER1 - case FFEINFO_kindtypeINTEGER1: - val = ffebld_constant_integer1 (ffebld_conter (expr)); - break; -#endif - -#if FFETARGET_okINTEGER2 - case FFEINFO_kindtypeINTEGER2: - val = ffebld_constant_integer2 (ffebld_conter (expr)); - break; -#endif - -#if FFETARGET_okINTEGER3 - case FFEINFO_kindtypeINTEGER3: - val = ffebld_constant_integer3 (ffebld_conter (expr)); - break; -#endif - - default: - assert ("bad INTEGER constant kind type" == NULL); - /* Fall through. */ - case FFEINFO_kindtypeANY: - return; - } - ffests_printf (s, "%ld", (long) val); - } -} - -/* ffestd_R1102 -- PROGRAM statement - - ffestd_R1102(name_token); - - Make sure ffestd_kind_ identifies an empty block. Make sure name_token - gives a valid name. Implement the beginning of a main program. */ - -void -ffestd_R1102 (ffesymbol s, ffelexToken name UNUSED) -{ - ffestd_check_simple_ (); - - assert (ffestd_block_level_ == 0); - ffestd_is_reachable_ = TRUE; - - ffecom_notify_primary_entry (s); - ffe_set_is_mainprog (TRUE); /* Is a main program. */ - ffe_set_is_saveall (TRUE); /* Main program always has implicit SAVE. */ - - ffestw_set_sym (ffestw_stack_top (), s); -} - -/* ffestd_R1103 -- End a PROGRAM - - ffestd_R1103(); */ - -void -ffestd_R1103 (bool ok UNUSED) -{ - ffestdStmt_ stmt; - - assert (ffestd_block_level_ == 0); - - if (FFESTD_IS_END_OPTIMIZED_ && ffestd_is_reachable_) - ffestd_R842 (NULL); /* Generate STOP. */ - - if (ffestw_state (ffestw_stack_top ()) != FFESTV_statePROGRAM5) - ffestd_subr_labels_ (FALSE);/* Handle any undefined labels. */ - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR1103_); - ffestd_stmt_append_ (stmt); -} - -/* ffestd_R1111 -- BLOCK DATA statement - - ffestd_R1111(name_token); - - Make sure ffestd_kind_ identifies no current program unit. If not - NULL, make sure name_token gives a valid name. Implement the beginning - of a block data program unit. */ - -void -ffestd_R1111 (ffesymbol s, ffelexToken name UNUSED) -{ - assert (ffestd_block_level_ == 0); - ffestd_is_reachable_ = TRUE; - - ffestd_check_simple_ (); - - ffecom_notify_primary_entry (s); - ffestw_set_sym (ffestw_stack_top (), s); -} - -/* ffestd_R1112 -- End a BLOCK DATA - - ffestd_R1112(TRUE); */ - -void -ffestd_R1112 (bool ok UNUSED) -{ - ffestdStmt_ stmt; - - assert (ffestd_block_level_ == 0); - - /* Generate any return-like code here (not likely for BLOCK DATA!). */ - - if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateBLOCKDATA5) - ffestd_subr_labels_ (TRUE); /* Handle any undefined labels. */ - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR1112_); - ffestd_stmt_append_ (stmt); -} - -/* ffestd_R1207_start -- EXTERNAL statement list begin - - ffestd_R1207_start(); - - Verify that EXTERNAL is valid here, and begin accepting items in the list. */ - -void -ffestd_R1207_start (void) -{ - ffestd_check_start_ (); -} - -/* ffestd_R1207_item -- EXTERNAL statement for name - - ffestd_R1207_item(name_token); - - Make sure name_token identifies a valid object to be EXTERNALd. */ - -void -ffestd_R1207_item (ffelexToken name) -{ - ffestd_check_item_ (); - assert (name != NULL); -} - -/* ffestd_R1207_finish -- EXTERNAL statement list complete - - ffestd_R1207_finish(); - - Just wrap up any local activities. */ - -void -ffestd_R1207_finish (void) -{ - ffestd_check_finish_ (); -} - -/* ffestd_R1208_start -- INTRINSIC statement list begin - - ffestd_R1208_start(); - - Verify that INTRINSIC is valid here, and begin accepting items in the list. */ - -void -ffestd_R1208_start (void) -{ - ffestd_check_start_ (); -} - -/* ffestd_R1208_item -- INTRINSIC statement for name - - ffestd_R1208_item(name_token); - - Make sure name_token identifies a valid object to be INTRINSICd. */ - -void -ffestd_R1208_item (ffelexToken name) -{ - ffestd_check_item_ (); - assert (name != NULL); -} - -/* ffestd_R1208_finish -- INTRINSIC statement list complete - - ffestd_R1208_finish(); - - Just wrap up any local activities. */ - -void -ffestd_R1208_finish (void) -{ - ffestd_check_finish_ (); -} - -/* ffestd_R1212 -- CALL statement - - ffestd_R1212(expr,expr_token); - - Make sure statement is valid here; implement. */ - -void -ffestd_R1212 (ffebld expr) -{ - ffestdStmt_ stmt; - - ffestd_check_simple_ (); - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR1212_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R1212.pool = ffesta_output_pool; - stmt->u.R1212.expr = expr; - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); -} - -/* ffestd_R1219 -- FUNCTION statement - - ffestd_R1219(funcname,arglist,ending_token,kind,kindt,len,lent, - recursive); - - Make sure statement is valid here, register arguments for the - function name, and so on. - - 06-Jun-90 JCB 2.0 - Added the kind, len, and recursive arguments. */ - -void -ffestd_R1219 (ffesymbol s, ffelexToken funcname UNUSED, - ffesttTokenList args UNUSED, ffestpType type UNUSED, - ffebld kind UNUSED, ffelexToken kindt UNUSED, - ffebld len UNUSED, ffelexToken lent UNUSED, - bool recursive UNUSED, ffelexToken result UNUSED, - bool separate_result UNUSED) -{ - assert (ffestd_block_level_ == 0); - ffestd_is_reachable_ = TRUE; - - ffestd_check_simple_ (); - - ffecom_notify_primary_entry (s); - ffestw_set_sym (ffestw_stack_top (), s); -} - -/* ffestd_R1221 -- End a FUNCTION - - ffestd_R1221(TRUE); */ - -void -ffestd_R1221 (bool ok UNUSED) -{ - ffestdStmt_ stmt; - - assert (ffestd_block_level_ == 0); - - if (FFESTD_IS_END_OPTIMIZED_ && ffestd_is_reachable_) - ffestd_R1227 (NULL); /* Generate RETURN. */ - - if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateFUNCTION5) - ffestd_subr_labels_ (FALSE);/* Handle any undefined labels. */ - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR1221_); - ffestd_stmt_append_ (stmt); -} - -/* ffestd_R1223 -- SUBROUTINE statement - - ffestd_R1223(subrname,arglist,ending_token,recursive_token); - - Make sure statement is valid here, register arguments for the - subroutine name, and so on. - - 06-Jun-90 JCB 2.0 - Added the recursive argument. */ - -void -ffestd_R1223 (ffesymbol s, ffelexToken subrname UNUSED, - ffesttTokenList args UNUSED, ffelexToken final UNUSED, - bool recursive UNUSED) -{ - assert (ffestd_block_level_ == 0); - ffestd_is_reachable_ = TRUE; - - ffestd_check_simple_ (); - - ffecom_notify_primary_entry (s); - ffestw_set_sym (ffestw_stack_top (), s); -} - -/* ffestd_R1225 -- End a SUBROUTINE - - ffestd_R1225(TRUE); */ - -void -ffestd_R1225 (bool ok UNUSED) -{ - ffestdStmt_ stmt; - - assert (ffestd_block_level_ == 0); - - if (FFESTD_IS_END_OPTIMIZED_ && ffestd_is_reachable_) - ffestd_R1227 (NULL); /* Generate RETURN. */ - - if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateSUBROUTINE5) - ffestd_subr_labels_ (FALSE);/* Handle any undefined labels. */ - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR1225_); - ffestd_stmt_append_ (stmt); -} - -/* ffestd_R1226 -- ENTRY statement - - ffestd_R1226(entryname,arglist,ending_token); - - Make sure we're in a SUBROUTINE or FUNCTION, register arguments for the - entry point name, and so on. */ - -void -ffestd_R1226 (ffesymbol entry) -{ - ffestd_check_simple_ (); - - if (!ffesta_seen_first_exec || ffecom_2pass_advise_entrypoint (entry)) - { - ffestdStmt_ stmt; - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR1226_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R1226.entry = entry; - stmt->u.R1226.entrynum = ++ffestd_2pass_entrypoints_; - } - - ffestd_is_reachable_ = TRUE; -} - -/* ffestd_R1227 -- RETURN statement - - ffestd_R1227(expr); - - Make sure statement is valid here; implement. expr and expr_token are - both NULL if there was no expression. */ - -void -ffestd_R1227 (ffebld expr) -{ - ffestdStmt_ stmt; - - ffestd_check_simple_ (); - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR1227_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R1227.pool = ffesta_output_pool; - stmt->u.R1227.block = ffestw_stack_top (); - stmt->u.R1227.expr = expr; - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); - - if (ffestd_block_level_ == 0) - ffestd_is_reachable_ = FALSE; -} - -/* ffestd_R1229_start -- STMTFUNCTION statement begin - - ffestd_R1229_start(func_name,func_arg_list,close_paren); - - This function does not really need to do anything, since _finish_ - gets all the info needed, and ffestc_R1229_start has already - done all the stuff that makes a two-phase operation (start and - finish) for handling statement functions necessary. - - 03-Jan-91 JCB 2.0 - Do nothing, now that _finish_ does everything. */ - -void -ffestd_R1229_start (ffelexToken name UNUSED, ffesttTokenList args UNUSED) -{ - ffestd_check_start_ (); -} - -/* ffestd_R1229_finish -- STMTFUNCTION statement list complete - - ffestd_R1229_finish(s); - - The statement function's symbol is passed. Its list of dummy args is - accessed via ffesymbol_dummyargs and its expansion expression (expr) - is accessed via ffesymbol_sfexpr. - - If sfexpr is NULL, an error occurred parsing the expansion expression, so - just cancel the effects of ffestd_R1229_start and pretend nothing - happened. Otherwise, install the expression as the expansion for the - statement function, then clean up. - - 03-Jan-91 JCB 2.0 - Takes sfunc sym instead of just the expansion expression as an - argument, so this function can do all the work, and _start_ is just - a nicety than can do nothing in a back end. */ - -void -ffestd_R1229_finish (ffesymbol s) -{ - ffebld expr = ffesymbol_sfexpr (s); - - ffestd_check_finish_ (); - - if (expr == NULL) - return; /* Nothing to do, definition didn't work. */ - - /* With gcc, cannot do anything here, because the backend hasn't even - (necessarily) been notified that we're compiling a program unit! */ - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); -} - -/* ffestd_S3P4 -- INCLUDE line - - ffestd_S3P4(filename,filename_token); - - Make sure INCLUDE not preceded by any semicolons or a label def; implement. */ - -void -ffestd_S3P4 (ffebld filename) -{ - FILE *fi; - ffetargetCharacterDefault buildname; - ffewhereFile wf; - - ffestd_check_simple_ (); - - assert (filename != NULL); - if (ffebld_op (filename) != FFEBLD_opANY) - { - assert (ffebld_op (filename) == FFEBLD_opCONTER); - assert (ffeinfo_basictype (ffebld_info (filename)) - == FFEINFO_basictypeCHARACTER); - assert (ffeinfo_kindtype (ffebld_info (filename)) - == FFEINFO_kindtypeCHARACTERDEFAULT); - buildname = ffebld_constant_characterdefault (ffebld_conter (filename)); - wf = ffewhere_file_new (ffetarget_text_characterdefault (buildname), - ffetarget_length_characterdefault (buildname)); - fi = ffecom_open_include (ffewhere_file_name (wf), - ffelex_token_where_line (ffesta_tokens[0]), - ffelex_token_where_column (ffesta_tokens[0])); - if (fi != NULL) - ffelex_set_include (wf, (ffelex_token_type (ffesta_tokens[0]) - == FFELEX_typeNAME), fi); - } -} - -/* ffestd_V014_start -- VOLATILE statement list begin - - ffestd_V014_start(); - - Verify that VOLATILE is valid here, and begin accepting items in the list. */ - -void -ffestd_V014_start (void) -{ - ffestd_check_start_ (); -} - -/* ffestd_V014_item_object -- VOLATILE statement for object-name - - ffestd_V014_item_object(name_token); - - Make sure name_token identifies a valid object to be VOLATILEd. */ - -void -ffestd_V014_item_object (ffelexToken name UNUSED) -{ - ffestd_check_item_ (); -} - -/* ffestd_V014_item_cblock -- VOLATILE statement for common-block-name - - ffestd_V014_item_cblock(name_token); - - Make sure name_token identifies a valid common block to be VOLATILEd. */ - -void -ffestd_V014_item_cblock (ffelexToken name UNUSED) -{ - ffestd_check_item_ (); -} - -/* ffestd_V014_finish -- VOLATILE statement list complete - - ffestd_V014_finish(); - - Just wrap up any local activities. */ - -void -ffestd_V014_finish (void) -{ - ffestd_check_finish_ (); -} - -/* ffestd_V020_start -- TYPE statement list begin - - ffestd_V020_start(); - - Verify that TYPE is valid here, and begin accepting items in the - list. */ - -void -ffestd_V020_start (ffestvFormat format UNUSED) -{ - ffestd_check_start_ (); - ffestd_subr_vxt_ (); -} - -/* ffestd_V020_item -- TYPE statement i/o item - - ffestd_V020_item(expr,expr_token); - - Implement output-list expression. */ - -void -ffestd_V020_item (ffebld expr UNUSED) -{ - ffestd_check_item_ (); -} - -/* ffestd_V020_finish -- TYPE statement list complete - - ffestd_V020_finish(); - - Just wrap up any local activities. */ - -void -ffestd_V020_finish (void) -{ - ffestd_check_finish_ (); -} - -/* ffestd_V027_start -- VXT PARAMETER statement list begin - - ffestd_V027_start(); - - Verify that PARAMETER is valid here, and begin accepting items in the list. */ - -void -ffestd_V027_start (void) -{ - ffestd_check_start_ (); - ffestd_subr_vxt_ (); -} - -/* ffestd_V027_item -- VXT PARAMETER statement assignment - - ffestd_V027_item(dest,dest_token,source,source_token); - - Make sure the source is a valid source for the destination; make the - assignment. */ - -void -ffestd_V027_item (ffelexToken dest_token UNUSED, ffebld source UNUSED) -{ - ffestd_check_item_ (); -} - -/* ffestd_V027_finish -- VXT PARAMETER statement list complete - - ffestd_V027_finish(); - - Just wrap up any local activities. */ - -void -ffestd_V027_finish (void) -{ - ffestd_check_finish_ (); -} - -/* Any executable statement. */ - -void -ffestd_any (void) -{ - ffestdStmt_ stmt; - - ffestd_check_simple_ (); - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR841_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); -} |