diff options
Diffstat (limited to 'contrib/gcc/f/std.c')
| -rw-r--r-- | contrib/gcc/f/std.c | 6928 |
1 files changed, 0 insertions, 6928 deletions
diff --git a/contrib/gcc/f/std.c b/contrib/gcc/f/std.c deleted file mode 100644 index 72037c13b2b1..000000000000 --- a/contrib/gcc/f/std.c +++ /dev/null @@ -1,6928 +0,0 @@ -/* std.c -- Implementation File (module.c template V1.0) - Copyright (C) 1995, 1996 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_; - -#if FFECOM_TWOPASS -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 */ -#if FFESTR_VXT - FFESTD_stmtidV018_, /* REWRITE */ - FFESTD_stmtidV019_, /* ACCEPT */ -#endif - FFESTD_stmtidV020_, /* TYPE */ -#if FFESTR_VXT - FFESTD_stmtidV021_, /* DELETE */ - FFESTD_stmtidV022_, /* UNLOCK */ - FFESTD_stmtidV023_, /* ENCODE */ - FFESTD_stmtidV024_, /* DECODE */ - FFESTD_stmtidV025start_, /* DEFINEFILE (start) */ - FFESTD_stmtidV025item_, /* (DEFINEFILE item) */ - FFESTD_stmtidV025finish_, /* (DEFINEFILE finish) */ - FFESTD_stmtidV026_, /* FIND */ -#endif - FFESTD_stmtid_, - } ffestdStmtId_; - -#endif - -/* Internal typedefs. */ - -typedef struct _ffestd_expr_item_ *ffestdExprItem_; -#if FFECOM_TWOPASS -typedef struct _ffestd_stmt_ *ffestdStmt_; -#endif - -/* Private include files. */ - - -/* Internal structure definitions. */ - -struct _ffestd_expr_item_ - { - ffestdExprItem_ next; - ffebld expr; - ffelexToken token; - }; - -#if FFECOM_TWOPASS -struct _ffestd_stmt_ - { - ffestdStmt_ next; - ffestdStmt_ previous; - ffestdStmtId_ id; -#if FFECOM_targetCURRENT == FFECOM_targetGCC - char *filename; - int filelinenum; -#endif - 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; -#if FFESTR_VXT - struct - { - mallocPool pool; - ffestpRewriteStmt *params; - ffestvFormat format; - ffestdExprItem_ list; - } - V018; - struct - { - mallocPool pool; - ffestpAcceptStmt *params; - ffestvFormat format; - ffestdExprItem_ list; - } - V019; -#endif - struct - { - mallocPool pool; - ffestpTypeStmt *params; - ffestvFormat format; - ffestdExprItem_ list; - } - V020; -#if FFESTR_VXT - struct - { - mallocPool pool; - ffestpDeleteStmt *params; - } - V021; - struct - { - mallocPool pool; - ffestpBeruStmt *params; - } - V022; - struct - { - mallocPool pool; - ffestpVxtcodeStmt *params; - ffestdExprItem_ list; - } - V023; - struct - { - mallocPool pool; - ffestpVxtcodeStmt *params; - ffestdExprItem_ list; - } - V024; - struct - { - ffebld u; - ffebld m; - ffebld n; - ffebld asv; - } - V025item; - struct - { - mallocPool pool; - } V025finish; - struct - { - mallocPool pool; - ffestpFindStmt *params; - } - V026; -#endif - } - u; - }; - -#endif - -/* 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; -#if FFECOM_TWOPASS -static ffestdExprItem_ *ffestd_expr_list_; -static struct - { - ffestdStmt_ first; - ffestdStmt_ last; - } - -ffestd_stmt_list_ -= -{ - NULL, NULL -}; - -#endif -#if FFECOM_targetCURRENT == FFECOM_targetGCC -static int ffestd_2pass_entrypoints_ = 0; /* # ENTRY statements - pending. */ -#endif - -/* Static functions (internal). */ - -#if FFECOM_TWOPASS -static void ffestd_stmt_append_ (ffestdStmt_ stmt); -static ffestdStmt_ ffestd_stmt_new_ (ffestdStmtId_ id); -static void ffestd_stmt_pass_ (void); -#endif -#if FFESTD_COPY_EASY_ && FFECOM_TWOPASS -static ffestpInquireStmt *ffestd_subr_copy_easy_ (ffestpInquireIx max); -#endif -#if FFECOM_targetCURRENT == FFECOM_targetGCC -static void ffestd_subr_vxt_ (void); -#endif -#if FFESTR_F90 -static void ffestd_subr_f90_ (void); -#endif -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_3_ (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. */ - -#if FFECOM_targetCURRENT == FFECOM_targetGCC -#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])) -#else -#define ffestd_subr_line_now_() -#if FFECOM_TWOPASS -#define ffestd_subr_line_restore_(s) -#define ffestd_subr_line_save_(s) -#endif /* FFECOM_TWOPASS */ -#endif /* FFECOM_targetCURRENT != FFECOM_targetGCC */ -#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_ && FFECOM_TWOPASS -#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_)); */ - -#if FFECOM_TWOPASS -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; -} - -#endif -/* ffestd_stmt_new_ -- Make new statement with given id - - ffestdStmt_ stmt; - stmt = ffestd_stmt_new_(FFESTD_stmtidR737A_); */ - -#if FFECOM_TWOPASS -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; -} - -#endif -/* ffestd_stmt_pass_ -- Pass all statements on list to ffeste - - ffestd_stmt_pass_(); */ - -#if FFECOM_TWOPASS -static void -ffestd_stmt_pass_ () -{ - ffestdStmt_ stmt; - ffestdExprItem_ expr; /* For traversing lists. */ - bool okay = (TREE_CODE (current_function_decl) != ERROR_MARK); - -#if FFECOM_targetCURRENT == FFECOM_targetGCC - 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"); - push_momentary (); - - 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); - clear_momentary (); - - ffesymbol_hook (stmt->u.R1226.entry).length_tree = label; - } - stmt = stmt->next; - } - while (--ents != 0); - - pop_momentary (); - expand_end_case (which); - clear_momentary (); - } -#endif - - 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; - -#if FFESTR_VXT - case FFESTD_stmtidV018_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_V018_start (stmt->u.V018.params, stmt->u.V018.format); - for (expr = stmt->u.V018.list; expr != NULL; expr = expr->next) - { - if (okay) - ffeste_V018_item (expr->expr); - } - if (okay) - ffeste_V018_finish (); - malloc_pool_kill (stmt->u.V018.pool); - break; - - case FFESTD_stmtidV019_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_V019_start (stmt->u.V019.params, stmt->u.V019.format); - for (expr = stmt->u.V019.list; expr != NULL; expr = expr->next) - { - if (okay) - ffeste_V019_item (expr->expr); - } - if (okay) - ffeste_V019_finish (); - malloc_pool_kill (stmt->u.V019.pool); - break; -#endif - - 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; - -#if FFESTR_VXT - case FFESTD_stmtidV021_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_V021 (stmt->u.V021.params); - malloc_pool_kill (stmt->u.V021.pool); - break; - - case FFESTD_stmtidV023_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_V023_start (stmt->u.V023.params); - for (expr = stmt->u.V023.list; expr != NULL; expr = expr->next) - { - if (okay) - ffeste_V023_item (expr->expr); - } - if (okay) - ffeste_V023_finish (); - malloc_pool_kill (stmt->u.V023.pool); - break; - - case FFESTD_stmtidV024_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_V024_start (stmt->u.V024.params); - for (expr = stmt->u.V024.list; expr != NULL; expr = expr->next) - { - if (okay) - ffeste_V024_item (expr->expr); - } - if (okay) - ffeste_V024_finish (); - malloc_pool_kill (stmt->u.V024.pool); - break; - - case FFESTD_stmtidV025start_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_V025_start (); - break; - - case FFESTD_stmtidV025item_: - if (okay) - ffeste_V025_item (stmt->u.V025item.u, stmt->u.V025item.m, - stmt->u.V025item.n, stmt->u.V025item.asv); - break; - - case FFESTD_stmtidV025finish_: - if (okay) - ffeste_V025_finish (); - malloc_pool_kill (stmt->u.V025finish.pool); - break; - - case FFESTD_stmtidV026_: - ffestd_subr_line_restore_ (stmt); - if (okay) - ffeste_V026 (stmt->u.V026.params); - malloc_pool_kill (stmt->u.V026.pool); - break; -#endif - - default: - assert ("bad stmt->id" == NULL); - break; - } - } -} - -#endif -/* 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_ && FFECOM_TWOPASS -static ffestpInquireStmt * -ffestd_subr_copy_easy_ (ffestpInquireIx max) -{ - ffestpInquireStmt *stmt; - ffestpInquireIx ix; - - stmt = (ffestpInquireStmt *) 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_f90_ -- Report error about lack of full F90 support - - ffestd_subr_f90_(); */ - -#if FFESTR_F90 -static void -ffestd_subr_f90_ () -{ - ffebad_start (FFEBAD_F90); - ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), - ffelex_token_where_column (ffesta_tokens[0])); - ffebad_finish (); -} - -#endif -/* ffestd_subr_vxt_ -- Report error about lack of full VXT support - - ffestd_subr_vxt_(); */ - -#if FFECOM_targetCURRENT == FFECOM_targetGCC -static void -ffestd_subr_vxt_ () -{ - ffebad_start (FFEBAD_VXT_UNSUPPORTED); - ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), - ffelex_token_where_column (ffesta_tokens[0])); - ffebad_finish (); -} - -#endif -/* 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 () -{ -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fputs ("; begin_uses\n", dmpout); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* 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) -{ -#if FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_do (ffestw_stack_top ()); -#else - { - ffestdStmt_ stmt; - - stmt = ffestd_stmt_new_ (FFESTD_stmtidENDDOLOOP_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.enddoloop.block = ffestw_stack_top (); - } -#endif - - --ffestd_block_level_; - assert (ffestd_block_level_ >= 0); -} - -/* ffestd_end_uses -- End a bunch of USE statements - - ffestd_end_uses(TRUE); - - ok==TRUE means simply not popping due to ffestd_eof_() - being called, because there is no formal END USES statement in Fortran. */ - -#if FFESTR_F90 -void -ffestd_end_uses (bool ok) -{ -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fputs ("; end_uses\n", dmpout); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* ffestd_end_R740 -- End a WHERE(-THEN) - - ffestd_end_R740(TRUE); */ - -void -ffestd_end_R740 (bool ok) -{ - return; /* F90. */ -} - -#endif -/* 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) -{ -#if FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_end_R807 (); -#else - { - ffestdStmt_ stmt; - - stmt = ffestd_stmt_new_ (FFESTD_stmtidENDLOGIF_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - } -#endif - - --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 () -{ - ffecom_exec_transition (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fputs ("{ begin_exec\n", dmpout); -#endif - -#if FFECOM_targetCURRENT == FFECOM_targetGCC - 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); - } -#endif -} - -/* ffestd_exec_end -- Executable statements can no longer come in now - - ffestd_exec_end(); */ - -void -ffestd_exec_end () -{ -#if FFECOM_targetCURRENT == FFECOM_targetGCC - int old_lineno = lineno; - char *old_input_filename = input_filename; -#endif - - ffecom_end_transition (); - -#if FFECOM_TWOPASS - ffestd_stmt_pass_ (); -#endif - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fputs ("} end_exec\n", dmpout); - fputs ("> end_unit\n", dmpout); -#endif - -#if FFECOM_targetCURRENT == FFECOM_targetGCC - 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; - - lineno = old_lineno; - input_filename = old_input_filename; -#endif -} - -/* ffestd_init_3 -- Initialize for any program unit - - ffestd_init_3(); */ - -void -ffestd_init_3 () -{ -#if FFECOM_TWOPASS - ffestd_stmt_list_.first = (ffestdStmt_) &ffestd_stmt_list_.first; - ffestd_stmt_list_.last = (ffestdStmt_) &ffestd_stmt_list_.first; -#endif -} - -/* Generate "code" for "any" label def. */ - -void -ffestd_labeldef_any (ffelab label UNUSED) -{ -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fprintf (dmpout, "; any_label_def %lu\n", ffelab_value (label)); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* ffestd_labeldef_branch -- Generate "code" for branch label def - - ffestd_labeldef_branch(label); */ - -void -ffestd_labeldef_branch (ffelab label) -{ -#if FFECOM_ONEPASS - ffeste_labeldef_branch (label); -#else - { - ffestdStmt_ stmt; - - stmt = ffestd_stmt_new_ (FFESTD_stmtidEXECLABEL_); - ffestd_stmt_append_ (stmt); - stmt->u.execlabel.label = label; - } -#endif - - ffestd_is_reachable_ = TRUE; -} - -/* ffestd_labeldef_format -- Generate "code" for FORMAT label def - - ffestd_labeldef_format(label); */ - -void -ffestd_labeldef_format (ffelab label) -{ - ffestd_label_formatdef_ = label; - -#if FFECOM_ONEPASS - ffeste_labeldef_format (label); -#else - { - ffestdStmt_ stmt; - - stmt = ffestd_stmt_new_ (FFESTD_stmtidFORMATLABEL_); -#if 0 - /* Don't bother with this. See FORMAT statement. */ - /* Prepend FORMAT label instead of appending it, so all the - FORMAT label/statement pairs end up at the top of the list. - This helps ensure all decls for a block (in the GBE) are - known before any executable statements are generated. */ - stmt->previous = (ffestdStmt_) &ffestd_stmt_list_.first; - stmt->next = ffestd_stmt_list_.first; - stmt->next->previous = stmt; - stmt->previous->next = stmt; -#else - ffestd_stmt_append_ (stmt); -#endif - stmt->u.formatlabel.label = label; - } -#endif -} - -/* ffestd_labeldef_useless -- Generate "code" for useless label def - - ffestd_labeldef_useless(label); */ - -void -ffestd_labeldef_useless (ffelab label UNUSED) -{ -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fprintf (dmpout, "; useless_label_def %lu\n", ffelab_value (label)); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* ffestd_R423A -- PRIVATE statement (in R422 derived-type statement) - - ffestd_R423A(); */ - -#if FFESTR_F90 -void -ffestd_R423A () -{ - ffestd_check_simple_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fputs ("* PRIVATE_derived_type\n", dmpout); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* ffestd_R423B -- SEQUENCE statement (in R422 derived-type-stmt) - - ffestd_R423B(); */ - -void -ffestd_R423B () -{ - ffestd_check_simple_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fputs ("* SEQUENCE_derived_type\n", dmpout); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* ffestd_R424 -- derived-TYPE-def statement - - ffestd_R424(access_token,access_kw,name_token); - - Handle a derived-type definition. */ - -void -ffestd_R424 (ffelexToken access, ffestrOther access_kw, ffelexToken name) -{ - ffestd_check_simple_ (); - - ffestd_subr_f90_ (); - return; - -#ifdef FFESTD_F90 - char *a; - - if (access == NULL) - fprintf (dmpout, "* TYPE %s\n", ffelex_token_text (name)); - else - { - switch (access_kw) - { - case FFESTR_otherPUBLIC: - a = "PUBLIC"; - break; - - case FFESTR_otherPRIVATE: - a = "PRIVATE"; - break; - - default: - assert (FALSE); - } - fprintf (dmpout, "* TYPE,%s: %s\n", a, ffelex_token_text (name)); - } -#endif -} - -/* ffestd_R425 -- End a TYPE - - ffestd_R425(TRUE); */ - -void -ffestd_R425 (bool ok) -{ -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fprintf (dmpout, "* END_TYPE %s\n", ffelex_token_text (ffestw_name (ffestw_stack_top ()))); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* ffestd_R519_start -- INTENT statement list begin - - ffestd_R519_start(); - - Verify that INTENT is valid here, and begin accepting items in the list. */ - -void -ffestd_R519_start (ffestrOther intent_kw) -{ - ffestd_check_start_ (); - - ffestd_subr_f90_ (); - return; - -#ifdef FFESTD_F90 - char *a; - - switch (intent_kw) - { - case FFESTR_otherIN: - a = "IN"; - break; - - case FFESTR_otherOUT: - a = "OUT"; - break; - - case FFESTR_otherINOUT: - a = "INOUT"; - break; - - default: - assert (FALSE); - } - fprintf (dmpout, "* INTENT (%s) ", a); -#endif -} - -/* ffestd_R519_item -- INTENT statement for name - - ffestd_R519_item(name_token); - - Make sure name_token identifies a valid object to be INTENTed. */ - -void -ffestd_R519_item (ffelexToken name) -{ - ffestd_check_item_ (); - - return; /* F90. */ - -#ifdef FFESTD_F90 - fprintf (dmpout, "%s,", ffelex_token_text (name)); -#endif -} - -/* ffestd_R519_finish -- INTENT statement list complete - - ffestd_R519_finish(); - - Just wrap up any local activities. */ - -void -ffestd_R519_finish () -{ - ffestd_check_finish_ (); - - return; /* F90. */ - -#ifdef FFESTD_F90 - fputc ('\n', dmpout); -#endif -} - -/* ffestd_R520_start -- OPTIONAL statement list begin - - ffestd_R520_start(); - - Verify that OPTIONAL is valid here, and begin accepting items in the list. */ - -void -ffestd_R520_start () -{ - ffestd_check_start_ (); - - ffestd_subr_f90_ (); - return; - -#ifdef FFESTD_F90 - fputs ("* OPTIONAL ", dmpout); -#endif -} - -/* ffestd_R520_item -- OPTIONAL statement for name - - ffestd_R520_item(name_token); - - Make sure name_token identifies a valid object to be OPTIONALed. */ - -void -ffestd_R520_item (ffelexToken name) -{ - ffestd_check_item_ (); - - return; /* F90. */ - -#ifdef FFESTD_F90 - fprintf (dmpout, "%s,", ffelex_token_text (name)); -#endif -} - -/* ffestd_R520_finish -- OPTIONAL statement list complete - - ffestd_R520_finish(); - - Just wrap up any local activities. */ - -void -ffestd_R520_finish () -{ - ffestd_check_finish_ (); - - return; /* F90. */ - -#ifdef FFESTD_F90 - fputc ('\n', dmpout); -#endif -} - -/* ffestd_R521A -- PUBLIC statement - - ffestd_R521A(); - - Verify that PUBLIC is valid here. */ - -void -ffestd_R521A () -{ - ffestd_check_simple_ (); - - ffestd_subr_f90_ (); - return; - -#ifdef FFESTD_F90 - fputs ("* PUBLIC\n", dmpout); -#endif -} - -/* ffestd_R521Astart -- PUBLIC statement list begin - - ffestd_R521Astart(); - - Verify that PUBLIC is valid here, and begin accepting items in the list. */ - -void -ffestd_R521Astart () -{ - ffestd_check_start_ (); - - ffestd_subr_f90_ (); - return; - -#ifdef FFESTD_F90 - fputs ("* PUBLIC ", dmpout); -#endif -} - -/* ffestd_R521Aitem -- PUBLIC statement for name - - ffestd_R521Aitem(name_token); - - Make sure name_token identifies a valid object to be PUBLICed. */ - -void -ffestd_R521Aitem (ffelexToken name) -{ - ffestd_check_item_ (); - - return; /* F90. */ - -#ifdef FFESTD_F90 - fprintf (dmpout, "%s,", ffelex_token_text (name)); -#endif -} - -/* ffestd_R521Afinish -- PUBLIC statement list complete - - ffestd_R521Afinish(); - - Just wrap up any local activities. */ - -void -ffestd_R521Afinish () -{ - ffestd_check_finish_ (); - - return; /* F90. */ - -#ifdef FFESTD_F90 - fputc ('\n', dmpout); -#endif -} - -/* ffestd_R521B -- PRIVATE statement - - ffestd_R521B(); - - Verify that PRIVATE is valid here (outside a derived-type statement). */ - -void -ffestd_R521B () -{ - ffestd_check_simple_ (); - - ffestd_subr_f90_ (); - return; - -#ifdef FFESTD_F90 - fputs ("* PRIVATE_outside_of_R422_derived_type_def\n", dmpout); -#endif -} - -/* ffestd_R521Bstart -- PRIVATE statement list begin - - ffestd_R521Bstart(); - - Verify that PRIVATE is valid here, and begin accepting items in the list. */ - -void -ffestd_R521Bstart () -{ - ffestd_check_start_ (); - - ffestd_subr_f90_ (); - return; - -#ifdef FFESTD_F90 - fputs ("* PRIVATE ", dmpout); -#endif -} - -/* ffestd_R521Bitem -- PRIVATE statement for name - - ffestd_R521Bitem(name_token); - - Make sure name_token identifies a valid object to be PRIVATEed. */ - -void -ffestd_R521Bitem (ffelexToken name) -{ - ffestd_check_item_ (); - - return; /* F90. */ - -#ifdef FFESTD_F90 - fprintf (dmpout, "%s,", ffelex_token_text (name)); -#endif -} - -/* ffestd_R521Bfinish -- PRIVATE statement list complete - - ffestd_R521Bfinish(); - - Just wrap up any local activities. */ - -void -ffestd_R521Bfinish () -{ - ffestd_check_finish_ (); - - return; /* F90. */ - -#ifdef FFESTD_F90 - fputc ('\n', dmpout); -#endif -} - -#endif -/* ffestd_R522 -- SAVE statement with no list - - ffestd_R522(); - - Verify that SAVE is valid here, and flag everything as SAVEd. */ - -void -ffestd_R522 () -{ - ffestd_check_simple_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fputs ("* SAVE_all\n", dmpout); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* ffestd_R522start -- SAVE statement list begin - - ffestd_R522start(); - - Verify that SAVE is valid here, and begin accepting items in the list. */ - -void -ffestd_R522start () -{ - ffestd_check_start_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fputs ("* SAVE ", dmpout); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* 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_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fprintf (dmpout, "%s,", ffelex_token_text (name)); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* 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_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fprintf (dmpout, "/%s/,", ffelex_token_text (name)); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* ffestd_R522finish -- SAVE statement list complete - - ffestd_R522finish(); - - Just wrap up any local activities. */ - -void -ffestd_R522finish () -{ - ffestd_check_finish_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fputc ('\n', dmpout); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* 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_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - if (virtual) - fputs ("* VIRTUAL ", dmpout); /* V028. */ - else - fputs ("* DIMENSION ", dmpout); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* 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_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fputs (ffelex_token_text (name), dmpout); - fputc ('(', dmpout); - ffestt_dimlist_dump (dims); - fputs ("),", dmpout); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* ffestd_R524_finish -- DIMENSION statement list complete - - ffestd_R524_finish(); - - Just wrap up any local activities. */ - -void -ffestd_R524_finish () -{ - ffestd_check_finish_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fputc ('\n', dmpout); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* ffestd_R525_start -- ALLOCATABLE statement list begin - - ffestd_R525_start(); - - Verify that ALLOCATABLE is valid here, and begin accepting items in the - list. */ - -#if FFESTR_F90 -void -ffestd_R525_start () -{ - ffestd_check_start_ (); - - ffestd_subr_f90_ (); - return; - -#ifdef FFESTD_F90 - fputs ("* ALLOCATABLE ", dmpout); -#endif -} - -/* ffestd_R525_item -- ALLOCATABLE statement for object-name - - ffestd_R525_item(name_token,dim_list); - - Make sure name_token identifies a valid object to be ALLOCATABLEd. */ - -void -ffestd_R525_item (ffelexToken name, ffesttDimList dims) -{ - ffestd_check_item_ (); - - return; /* F90. */ - -#ifdef FFESTD_F90 - fputs (ffelex_token_text (name), dmpout); - if (dims != NULL) - { - fputc ('(', dmpout); - ffestt_dimlist_dump (dims); - fputc (')', dmpout); - } - fputc (',', dmpout); -#endif -} - -/* ffestd_R525_finish -- ALLOCATABLE statement list complete - - ffestd_R525_finish(); - - Just wrap up any local activities. */ - -void -ffestd_R525_finish () -{ - ffestd_check_finish_ (); - - return; /* F90. */ - -#ifdef FFESTD_F90 - fputc ('\n', dmpout); -#endif -} - -/* ffestd_R526_start -- POINTER statement list begin - - ffestd_R526_start(); - - Verify that POINTER is valid here, and begin accepting items in the - list. */ - -void -ffestd_R526_start () -{ - ffestd_check_start_ (); - - ffestd_subr_f90_ (); - return; - -#ifdef FFESTD_F90 - fputs ("* POINTER ", dmpout); -#endif -} - -/* ffestd_R526_item -- POINTER statement for object-name - - ffestd_R526_item(name_token,dim_list); - - Make sure name_token identifies a valid object to be POINTERd. */ - -void -ffestd_R526_item (ffelexToken name, ffesttDimList dims) -{ - ffestd_check_item_ (); - - return; /* F90. */ - -#ifdef FFESTD_F90 - fputs (ffelex_token_text (name), dmpout); - if (dims != NULL) - { - fputc ('(', dmpout); - ffestt_dimlist_dump (dims); - fputc (')', dmpout); - } - fputc (',', dmpout); -#endif -} - -/* ffestd_R526_finish -- POINTER statement list complete - - ffestd_R526_finish(); - - Just wrap up any local activities. */ - -void -ffestd_R526_finish () -{ - ffestd_check_finish_ (); - - return; /* F90. */ - -#ifdef FFESTD_F90 - fputc ('\n', dmpout); -#endif -} - -/* ffestd_R527_start -- TARGET statement list begin - - ffestd_R527_start(); - - Verify that TARGET is valid here, and begin accepting items in the - list. */ - -void -ffestd_R527_start () -{ - ffestd_check_start_ (); - - ffestd_subr_f90_ (); - return; - -#ifdef FFESTD_F90 - fputs ("* TARGET ", dmpout); -#endif -} - -/* ffestd_R527_item -- TARGET statement for object-name - - ffestd_R527_item(name_token,dim_list); - - Make sure name_token identifies a valid object to be TARGETd. */ - -void -ffestd_R527_item (ffelexToken name, ffesttDimList dims) -{ - ffestd_check_item_ (); - - return; /* F90. */ - -#ifdef FFESTD_F90 - fputs (ffelex_token_text (name), dmpout); - if (dims != NULL) - { - fputc ('(', dmpout); - ffestt_dimlist_dump (dims); - fputc (')', dmpout); - } - fputc (',', dmpout); -#endif -} - -/* ffestd_R527_finish -- TARGET statement list complete - - ffestd_R527_finish(); - - Just wrap up any local activities. */ - -void -ffestd_R527_finish () -{ - ffestd_check_finish_ (); - - return; /* F90. */ - -#ifdef FFESTD_F90 - fputc ('\n', dmpout); -#endif -} - -#endif -/* 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 () -{ - ffestd_check_start_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fputs ("* PARAMETER (", dmpout); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* 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_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - ffebld_dump (dest); - fputc ('=', dmpout); - ffebld_dump (source); - fputc (',', dmpout); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* ffestd_R537_finish -- PARAMETER statement list complete - - ffestd_R537_finish(); - - Just wrap up any local activities. */ - -void -ffestd_R537_finish () -{ - ffestd_check_finish_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fputs (")\n", dmpout); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* ffestd_R539 -- IMPLICIT NONE statement - - ffestd_R539(); - - Verify that the IMPLICIT NONE statement is ok here and implement. */ - -void -ffestd_R539 () -{ - ffestd_check_simple_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fputs ("* IMPLICIT_NONE\n", dmpout); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* ffestd_R539start -- IMPLICIT statement - - ffestd_R539start(); - - Verify that the IMPLICIT statement is ok here and implement. */ - -void -ffestd_R539start () -{ - ffestd_check_start_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fputs ("* IMPLICIT ", dmpout); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* 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) -{ -#if FFECOM_targetCURRENT == FFECOM_targetFFE - char *a; -#endif - - ffestd_check_item_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - switch (type) - { - case FFESTP_typeINTEGER: - a = "INTEGER"; - break; - - case FFESTP_typeBYTE: - a = "BYTE"; - break; - - case FFESTP_typeWORD: - a = "WORD"; - break; - - case FFESTP_typeREAL: - a = "REAL"; - break; - - case FFESTP_typeCOMPLEX: - a = "COMPLEX"; - break; - - case FFESTP_typeLOGICAL: - a = "LOGICAL"; - break; - - case FFESTP_typeCHARACTER: - a = "CHARACTER"; - break; - - case FFESTP_typeDBLPRCSN: - a = "DOUBLE PRECISION"; - break; - - case FFESTP_typeDBLCMPLX: - a = "DOUBLE COMPLEX"; - break; - -#if FFESTR_F90 - case FFESTP_typeTYPE: - a = "TYPE"; - break; -#endif - - default: - assert (FALSE); - a = "?"; - break; - } - fprintf (dmpout, "%s(", a); - if (kindt != NULL) - { - fputs ("kind=", dmpout); - if (kind == NULL) - fputs (ffelex_token_text (kindt), dmpout); - else - ffebld_dump (kind); - if (lent != NULL) - fputc (',', dmpout); - } - if (lent != NULL) - { - fputs ("len=", dmpout); - if (len == NULL) - fputs (ffelex_token_text (lent), dmpout); - else - ffebld_dump (len); - } - fputs (")(", dmpout); - ffestt_implist_dump (letters); - fputs ("),", dmpout); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* ffestd_R539finish -- IMPLICIT statement - - ffestd_R539finish(); - - Finish up any local activities. */ - -void -ffestd_R539finish () -{ - ffestd_check_finish_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fputc ('\n', dmpout); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* 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 () -{ - ffestd_check_start_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fputs ("* NAMELIST ", dmpout); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* 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_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fprintf (dmpout, "/%s/", ffelex_token_text (name)); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* 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_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fprintf (dmpout, "%s,", ffelex_token_text (name)); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* ffestd_R542_finish -- NAMELIST statement list complete - - ffestd_R542_finish(); - - Just wrap up any local activities. */ - -void -ffestd_R542_finish () -{ - ffestd_check_finish_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fputc ('\n', dmpout); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* ffestd_R544_start -- EQUIVALENCE statement list begin - - ffestd_R544_start(); - - Verify that EQUIVALENCE is valid here, and begin accepting items in the - list. */ - -#if 0 -void -ffestd_R544_start () -{ - ffestd_check_start_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fputs ("* EQUIVALENCE (", dmpout); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -#endif -/* ffestd_R544_item -- EQUIVALENCE statement assignment - - ffestd_R544_item(exprlist); - - Make sure the equivalence is valid, then implement it. */ - -#if 0 -void -ffestd_R544_item (ffesttExprList exprlist) -{ - ffestd_check_item_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - ffestt_exprlist_dump (exprlist); - fputs ("),", dmpout); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -#endif -/* ffestd_R544_finish -- EQUIVALENCE statement list complete - - ffestd_R544_finish(); - - Just wrap up any local activities. */ - -#if 0 -void -ffestd_R544_finish () -{ - ffestd_check_finish_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fputs (")\n", dmpout); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -#endif -/* 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 () -{ - ffestd_check_start_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fputs ("* COMMON ", dmpout); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* 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_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fputs (ffelex_token_text (name), dmpout); - if (dims != NULL) - { - fputc ('(', dmpout); - ffestt_dimlist_dump (dims); - fputc (')', dmpout); - } - fputc (',', dmpout); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* 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_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - if (name == NULL) - fputs ("//,", dmpout); - else - fprintf (dmpout, "/%s/,", ffelex_token_text (name)); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* ffestd_R547_finish -- COMMON statement list complete - - ffestd_R547_finish(); - - Just wrap up any local activities. */ - -void -ffestd_R547_finish () -{ - ffestd_check_finish_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fputc ('\n', dmpout); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* ffestd_R620 -- ALLOCATE statement - - ffestd_R620(exprlist,stat,stat_token); - - Make sure the expression list is valid, then implement it. */ - -#if FFESTR_F90 -void -ffestd_R620 (ffesttExprList exprlist, ffebld stat) -{ - ffestd_check_simple_ (); - - ffestd_subr_f90_ (); - return; - -#ifdef FFESTD_F90 - fputs ("+ ALLOCATE (", dmpout); - ffestt_exprlist_dump (exprlist); - if (stat != NULL) - { - fputs (",stat=", dmpout); - ffebld_dump (stat); - } - fputs (")\n", dmpout); -#endif -} - -/* ffestd_R624 -- NULLIFY statement - - ffestd_R624(pointer_name_list); - - Make sure pointer_name_list identifies valid pointers for a NULLIFY. */ - -void -ffestd_R624 (ffesttExprList pointers) -{ - ffestd_check_simple_ (); - - ffestd_subr_f90_ (); - return; - -#ifdef FFESTD_F90 - fputs ("+ NULLIFY (", dmpout); - assert (pointers != NULL); - ffestt_exprlist_dump (pointers); - fputs (")\n", dmpout); -#endif -} - -/* ffestd_R625 -- DEALLOCATE statement - - ffestd_R625(exprlist,stat,stat_token); - - Make sure the equivalence is valid, then implement it. */ - -void -ffestd_R625 (ffesttExprList exprlist, ffebld stat) -{ - ffestd_check_simple_ (); - - ffestd_subr_f90_ (); - return; - -#ifdef FFESTD_F90 - fputs ("+ DEALLOCATE (", dmpout); - ffestt_exprlist_dump (exprlist); - if (stat != NULL) - { - fputs (",stat=", dmpout); - ffebld_dump (stat); - } - fputs (")\n", dmpout); -#endif -} - -#endif -/* ffestd_R737A -- Assignment statement outside of WHERE - - ffestd_R737A(dest_expr,source_expr); */ - -void -ffestd_R737A (ffebld dest, ffebld source) -{ - ffestd_check_simple_ (); - -#if FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_R737A (dest, source); -#else - { - ffestdStmt_ stmt; - - 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); - } -#endif -} - -/* ffestd_R737B -- Assignment statement inside of WHERE - - ffestd_R737B(dest_expr,source_expr); */ - -#if FFESTR_F90 -void -ffestd_R737B (ffebld dest, ffebld source) -{ - ffestd_check_simple_ (); - - return; /* F90. */ - -#ifdef FFESTD_F90 - fputs ("+ let_inside_where ", dmpout); - ffebld_dump (dest); - fputs ("=", dmpout); - ffebld_dump (source); - fputc ('\n', dmpout); -#endif -} - -/* ffestd_R738 -- Pointer assignment statement - - ffestd_R738(dest_expr,source_expr,source_token); - - Make sure the assignment is valid. */ - -void -ffestd_R738 (ffebld dest, ffebld source) -{ - ffestd_check_simple_ (); - - ffestd_subr_f90_ (); - return; - -#ifdef FFESTD_F90 - fputs ("+ let_pointer ", dmpout); - ffebld_dump (dest); - fputs ("=>", dmpout); - ffebld_dump (source); - fputc ('\n', dmpout); -#endif -} - -/* ffestd_R740 -- WHERE statement - - ffestd_R740(expr,expr_token); - - Make sure statement is valid here; implement. */ - -void -ffestd_R740 (ffebld expr) -{ - ffestd_check_simple_ (); - - ffestd_subr_f90_ (); - return; - -#ifdef FFESTD_F90 - fputs ("+ WHERE (", dmpout); - ffebld_dump (expr); - fputs (")\n", dmpout); - - ++ffestd_block_level_; - assert (ffestd_block_level_ > 0); -#endif -} - -/* ffestd_R742 -- WHERE-construct statement - - ffestd_R742(expr,expr_token); - - Make sure statement is valid here; implement. */ - -void -ffestd_R742 (ffebld expr) -{ - ffestd_check_simple_ (); - - ffestd_subr_f90_ (); - return; - -#ifdef FFESTD_F90 - fputs ("+ WHERE_construct (", dmpout); - ffebld_dump (expr); - fputs (")\n", dmpout); - - ++ffestd_block_level_; - assert (ffestd_block_level_ > 0); -#endif -} - -/* ffestd_R744 -- ELSE WHERE statement - - ffestd_R744(); - - Make sure ffestd_kind_ identifies a WHERE block. - Implement the ELSE of the current WHERE block. */ - -void -ffestd_R744 () -{ - ffestd_check_simple_ (); - - return; /* F90. */ - -#ifdef FFESTD_F90 - fputs ("+ ELSE_WHERE\n", dmpout); -#endif -} - -/* ffestd_R745 -- Implicit END WHERE statement. */ - -void -ffestd_R745 (bool ok) -{ - return; /* F90. */ - -#ifdef FFESTD_F90 - fputs ("+ END_WHERE\n", dmpout); /* Also see ffestd_R745. */ - - --ffestd_block_level_; - assert (ffestd_block_level_ >= 0); -#endif -} - -#endif - -/* Block IF (IF-THEN) statement. */ - -void -ffestd_R803 (ffelexToken construct_name UNUSED, ffebld expr) -{ - ffestd_check_simple_ (); - -#if FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_R803 (expr); /* Don't bother with name. */ -#else - { - ffestdStmt_ stmt; - - 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); - } -#endif - - ++ffestd_block_level_; - assert (ffestd_block_level_ > 0); -} - -/* ELSE IF statement. */ - -void -ffestd_R804 (ffebld expr, ffelexToken name UNUSED) -{ - ffestd_check_simple_ (); - -#if FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_R804 (expr); /* Don't bother with name. */ -#else - { - ffestdStmt_ stmt; - - 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); - } -#endif -} - -/* ELSE statement. */ - -void -ffestd_R805 (ffelexToken name UNUSED) -{ - ffestd_check_simple_ (); - -#if FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_R805 (); /* Don't bother with name. */ -#else - { - ffestdStmt_ stmt; - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR805_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R805.block = ffestw_use (ffestw_stack_top ()); - } -#endif -} - -/* END IF statement. */ - -void -ffestd_R806 (bool ok UNUSED) -{ -#if FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_R806 (); -#else - { - 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 ()); - } -#endif - - --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) -{ - ffestd_check_simple_ (); - -#if FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_R807 (expr); -#else - { - ffestdStmt_ stmt; - - 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); - } -#endif - - ++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) -{ - ffestd_check_simple_ (); - -#if FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_R809 (ffestw_stack_top (), expr); -#else - { - ffestdStmt_ stmt; - - 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); - } -#endif - - ++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) -{ - ffestd_check_simple_ (); - -#if FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_R810 (ffestw_stack_top (), casenum); -#else - { - ffestdStmt_ stmt; - - 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); - } -#endif -} - -/* ffestd_R811 -- End a SELECT - - ffestd_R811(TRUE); */ - -void -ffestd_R811 (bool ok UNUSED) -{ -#if FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_R811 (ffestw_stack_top ()); -#else - { - ffestdStmt_ stmt; - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR811_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R811.block = ffestw_stack_top (); - } -#endif - - --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) -{ - ffestd_check_simple_ (); - -#if FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_R819A (ffestw_stack_top (), label, var, start, end, incr, - incr_token); -#else - { - ffestdStmt_ stmt; - - 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); - } -#endif - - ++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) -{ - ffestd_check_simple_ (); - -#if FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_R819B (ffestw_stack_top (), label, expr); -#else - { - ffestdStmt_ stmt; - - 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); - } -#endif - - ++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) -{ - ffestd_check_simple_ (); - -#if FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_R825 (); -#else - { - ffestdStmt_ stmt; - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR825_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - } -#endif -} - -/* ffestd_R834 -- CYCLE statement - - ffestd_R834(name_token); - - Handle a CYCLE within a loop. */ - -void -ffestd_R834 (ffestw block) -{ - ffestd_check_simple_ (); - -#if FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_R834 (block); -#else - { - ffestdStmt_ stmt; - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR834_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R834.block = block; - } -#endif -} - -/* ffestd_R835 -- EXIT statement - - ffestd_R835(name_token); - - Handle a EXIT within a loop. */ - -void -ffestd_R835 (ffestw block) -{ - ffestd_check_simple_ (); - -#if FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_R835 (block); -#else - { - ffestdStmt_ stmt; - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR835_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R835.block = block; - } -#endif -} - -/* 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) -{ - ffestd_check_simple_ (); - -#if FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_R836 (label); -#else - { - ffestdStmt_ stmt; - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR836_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.R836.label = label; - } -#endif - - 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) -{ - ffestd_check_simple_ (); - -#if FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_R837 (labels, count, expr); -#else - { - ffestdStmt_ stmt; - - 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); - } -#endif -} - -/* 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) -{ - ffestd_check_simple_ (); - -#if FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_R838 (label, target); -#else - { - ffestdStmt_ stmt; - - 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); - } -#endif -} - -/* 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) -{ - ffestd_check_simple_ (); - -#if FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_R839 (target); -#else - { - ffestdStmt_ stmt; - - 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); - } -#endif - - 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) -{ - ffestd_check_simple_ (); - -#if FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_R840 (expr, neg, zero, pos); -#else - { - ffestdStmt_ stmt; - - 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); - } -#endif - - if (ffestd_block_level_ == 0) - ffestd_is_reachable_ = FALSE; -} - -/* ffestd_R841 -- CONTINUE statement - - ffestd_R841(); */ - -void -ffestd_R841 (bool in_where UNUSED) -{ - ffestd_check_simple_ (); - -#if FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_R841 (); -#else - { - ffestdStmt_ stmt; - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR841_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - } -#endif -} - -/* ffestd_R842 -- STOP statement - - ffestd_R842(expr); */ - -void -ffestd_R842 (ffebld expr) -{ - ffestd_check_simple_ (); - -#if FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_R842 (expr); -#else - { - ffestdStmt_ stmt; - - 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); - } - } -#endif - - 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) -{ - ffestd_check_simple_ (); - -#if FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_R843 (expr); -#else - { - ffestdStmt_ stmt; - - 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); - } -#endif -} - -/* ffestd_R904 -- OPEN statement - - ffestd_R904(); - - Make sure an OPEN is valid in the current context, and implement it. */ - -void -ffestd_R904 () -{ - ffestd_check_simple_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetGCC -#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 -#endif - -#if FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_R904 (&ffestp_file.open); -#else - { - ffestdStmt_ stmt; - - 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); - } -#endif -} - -/* ffestd_R907 -- CLOSE statement - - ffestd_R907(); - - Make sure a CLOSE is valid in the current context, and implement it. */ - -void -ffestd_R907 () -{ - ffestd_check_simple_ (); - -#if FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_R907 (&ffestp_file.close); -#else - { - ffestdStmt_ stmt; - - 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); - } -#endif -} - -/* 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) -{ - ffestd_check_start_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetGCC -#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 -#endif - -#if FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_R909_start (&ffestp_file.read, only_format, unit, format, rec, key); -#else - { - ffestdStmt_ stmt; - - 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); - } -#endif -} - -/* 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) -{ - ffestd_check_item_ (); - -#if FFECOM_ONEPASS - ffeste_R909_item (expr); -#else - { - ffestdExprItem_ item - = (ffestdExprItem_) 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; - } -#endif -} - -/* ffestd_R909_finish -- READ statement list complete - - ffestd_R909_finish(); - - Just wrap up any local activities. */ - -void -ffestd_R909_finish () -{ - ffestd_check_finish_ (); - -#if FFECOM_ONEPASS - ffeste_R909_finish (); -#else - /* Nothing to do, it's implicit. */ -#endif -} - -/* 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) -{ - ffestd_check_start_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetGCC -#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 -#endif - -#if FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_R910_start (&ffestp_file.write, unit, format, rec); -#else - { - ffestdStmt_ stmt; - - 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); - } -#endif -} - -/* 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) -{ - ffestd_check_item_ (); - -#if FFECOM_ONEPASS - ffeste_R910_item (expr); -#else - { - ffestdExprItem_ item - = (ffestdExprItem_) 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; - } -#endif -} - -/* ffestd_R910_finish -- WRITE statement list complete - - ffestd_R910_finish(); - - Just wrap up any local activities. */ - -void -ffestd_R910_finish () -{ - ffestd_check_finish_ (); - -#if FFECOM_ONEPASS - ffeste_R910_finish (); -#else - /* Nothing to do, it's implicit. */ -#endif -} - -/* 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) -{ - ffestd_check_start_ (); - -#if FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_R911_start (&ffestp_file.print, format); -#else - { - ffestdStmt_ stmt; - - 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); - } -#endif -} - -/* 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) -{ - ffestd_check_item_ (); - -#if FFECOM_ONEPASS - ffeste_R911_item (expr); -#else - { - ffestdExprItem_ item - = (ffestdExprItem_) 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; - } -#endif -} - -/* ffestd_R911_finish -- PRINT statement list complete - - ffestd_R911_finish(); - - Just wrap up any local activities. */ - -void -ffestd_R911_finish () -{ - ffestd_check_finish_ (); - -#if FFECOM_ONEPASS - ffeste_R911_finish (); -#else - /* Nothing to do, it's implicit. */ -#endif -} - -/* ffestd_R919 -- BACKSPACE statement - - ffestd_R919(); - - Make sure a BACKSPACE is valid in the current context, and implement it. */ - -void -ffestd_R919 () -{ - ffestd_check_simple_ (); - -#if FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_R919 (&ffestp_file.beru); -#else - { - ffestdStmt_ stmt; - - 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); - } -#endif -} - -/* ffestd_R920 -- ENDFILE statement - - ffestd_R920(); - - Make sure a ENDFILE is valid in the current context, and implement it. */ - -void -ffestd_R920 () -{ - ffestd_check_simple_ (); - -#if FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_R920 (&ffestp_file.beru); -#else - { - ffestdStmt_ stmt; - - 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); - } -#endif -} - -/* ffestd_R921 -- REWIND statement - - ffestd_R921(); - - Make sure a REWIND is valid in the current context, and implement it. */ - -void -ffestd_R921 () -{ - ffestd_check_simple_ (); - -#if FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_R921 (&ffestp_file.beru); -#else - { - ffestdStmt_ stmt; - - 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); - } -#endif -} - -/* 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) -{ - ffestd_check_simple_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetGCC -#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 -#endif - -#if FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_R923A (&ffestp_file.inquire, by_file); -#else - { - ffestdStmt_ stmt; - - 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); - } -#endif -} - -/* 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 () -{ - ffestd_check_start_ (); - -#if FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_R923B_start (&ffestp_file.inquire); -#else - { - ffestdStmt_ stmt; - - 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); - } -#endif -} - -/* ffestd_R923B_item -- INQUIRE statement i/o item - - ffestd_R923B_item(expr,expr_token); - - Implement output-list expression. */ - -void -ffestd_R923B_item (ffebld expr) -{ - ffestd_check_item_ (); - -#if FFECOM_ONEPASS - ffeste_R923B_item (expr); -#else - { - ffestdExprItem_ item - = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, "ffestdExprItem_", - sizeof (*item)); - - item->next = NULL; - item->expr = expr; - *ffestd_expr_list_ = item; - ffestd_expr_list_ = &item->next; - } -#endif -} - -/* ffestd_R923B_finish -- INQUIRE statement list complete - - ffestd_R923B_finish(); - - Just wrap up any local activities. */ - -void -ffestd_R923B_finish () -{ - ffestd_check_finish_ (); - -#if FFECOM_ONEPASS - ffeste_R923B_finish (); -#else - /* Nothing to do, it's implicit. */ -#endif -} - -/* ffestd_R1001 -- FORMAT statement - - ffestd_R1001(format_list); */ - -void -ffestd_R1001 (ffesttFormatList f) -{ - ffestsHolder str; - ffests s = &str; - - 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, ')'); - -#if FFECOM_ONEPASS - ffeste_R1001 (s); - ffests_kill (s); /* Kill the string in s. */ -#else - { - ffestdStmt_ stmt; - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR1001_); -#if 0 - /* Don't bother with this. After all, things like cilists also are - declared midway through code-generation. Perhaps the only problems - the gcc back end has with midway declarations are with stack vars, - maybe only with vars that can be put in registers. Unless/until the - need is established, handle FORMAT just like cilists and others; at - that point, they'd likely *all* have to be fixed, which would be - very painful anyway. */ - /* Insert FORMAT statement just after the first item on the - statement list, which must be a FORMAT label, which see. */ - assert (ffestd_stmt_list_.first->id == FFESTD_stmtidFORMATLABEL_); - stmt->previous = ffestd_stmt_list_.first; - stmt->next = ffestd_stmt_list_.first->next; - stmt->next->previous = stmt; - stmt->previous->next = stmt; -#else - ffestd_stmt_append_ (stmt); -#endif - stmt->u.R1001.str = str; - } -#endif - - 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: -#if FFECOM_targetCURRENT == FFECOM_targetFFE - ffestd_R1001dump_1005_3_ (s, next, "B"); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC - ffestd_R1001error_ (next); -#else -#error -#endif - 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: -#if FFECOM_targetCURRENT == FFECOM_targetFFE - ffestd_R1001dump_1005_5_ (s, next, "EN"); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC - ffestd_R1001error_ (next); -#else -#error -#endif - 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: -#if FFECOM_targetCURRENT == FFECOM_targetFFE - ffestd_R1001dump_1010_1_ (s, next, "Q"); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC - ffestd_R1001error_ (next); -#else -#error -#endif - 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_3_ (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_1U (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_1U (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_1U (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_1U (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_1U (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_1U (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_1U (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_1U (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_1U (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_1U (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_1U (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_1U (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_1U (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_1U (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_1U (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_1U (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_1U (s, "%lu", f->u.R1010.val.u.unsigned_val); - } - - ffests_puts (s, string); -} - -/* ffestd_R1001dump_1010_3_ -- Dump a particular format - - ffesttFormatList f; - ffestd_R1001dump_1010_3_(f,"I"); - - The format is dumped with form nX. */ - -static void -ffestd_R1001dump_1010_3_ (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_1U (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_1D (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_1U (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_1D (s, "%ld", 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); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - if (name == NULL) - fputs ("< PROGRAM_unnamed\n", dmpout); - else - fprintf (dmpout, "< PROGRAM %s\n", ffelex_token_text (name)); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* ffestd_R1103 -- End a PROGRAM - - ffestd_R1103(); */ - -void -ffestd_R1103 (bool ok UNUSED) -{ - 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. */ - -#if FFECOM_ONEPASS - ffeste_R1103 (); -#else - { - ffestdStmt_ stmt; - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR1103_); - ffestd_stmt_append_ (stmt); - } -#endif -} - -/* ffestd_R1105 -- MODULE statement - - ffestd_R1105(name_token); - - Make sure ffestd_kind_ identifies an empty block. Make sure name_token - gives a valid name. Implement the beginning of a module. */ - -#if FFESTR_F90 -void -ffestd_R1105 (ffelexToken name) -{ - assert (ffestd_block_level_ == 0); - - ffestd_check_simple_ (); - - ffestd_subr_f90_ (); - return; - -#ifdef FFESTD_F90 - fprintf (dmpout, "* MODULE %s\n", ffelex_token_text (name)); -#endif -} - -/* ffestd_R1106 -- End a MODULE - - ffestd_R1106(TRUE); */ - -void -ffestd_R1106 (bool ok) -{ - assert (ffestd_block_level_ == 0); - - /* Generate any wrap-up code here (unlikely in MODULE!). */ - - if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateMODULE5) - ffestd_subr_labels_ (TRUE); /* Handle any undefined labels (unlikely). */ - - return; /* F90. */ - -#ifdef FFESTD_F90 - fprintf (dmpout, "< END_MODULE %s\n", - ffelex_token_text (ffestw_name (ffestw_stack_top ()))); -#endif -} - -/* ffestd_R1107_start -- USE statement list begin - - ffestd_R1107_start(); - - Verify that USE is valid here, and begin accepting items in the list. */ - -void -ffestd_R1107_start (ffelexToken name, bool only) -{ - ffestd_check_start_ (); - - ffestd_subr_f90_ (); - return; - -#ifdef FFESTD_F90 - fprintf (dmpout, "* USE %s,", ffelex_token_text (name)); /* NB - _shriek_begin_uses_. */ - if (only) - fputs ("only: ", dmpout); -#endif -} - -/* ffestd_R1107_item -- USE statement for name - - ffestd_R1107_item(local_token,use_token); - - Make sure name_token identifies a valid object to be USEed. local_token - may be NULL if _start_ was called with only==TRUE. */ - -void -ffestd_R1107_item (ffelexToken local, ffelexToken use) -{ - ffestd_check_item_ (); - assert (use != NULL); - - return; /* F90. */ - -#ifdef FFESTD_F90 - if (local != NULL) - fprintf (dmpout, "%s=>", ffelex_token_text (local)); - fprintf (dmpout, "%s,", ffelex_token_text (use)); -#endif -} - -/* ffestd_R1107_finish -- USE statement list complete - - ffestd_R1107_finish(); - - Just wrap up any local activities. */ - -void -ffestd_R1107_finish () -{ - ffestd_check_finish_ (); - - return; /* F90. */ - -#ifdef FFESTD_F90 - fputc ('\n', dmpout); -#endif -} - -#endif -/* 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); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - if (name == NULL) - fputs ("< BLOCK_DATA_unnamed\n", dmpout); - else - fprintf (dmpout, "< BLOCK_DATA %s\n", ffelex_token_text (name)); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* ffestd_R1112 -- End a BLOCK DATA - - ffestd_R1112(TRUE); */ - -void -ffestd_R1112 (bool ok UNUSED) -{ - 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. */ - -#if FFECOM_ONEPASS - ffeste_R1112 (); -#else - { - ffestdStmt_ stmt; - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR1112_); - ffestd_stmt_append_ (stmt); - } -#endif -} - -/* ffestd_R1202 -- INTERFACE statement - - ffestd_R1202(operator,defined_name); - - Make sure ffestd_kind_ identifies an INTERFACE block. - Implement the end of the current interface. - - 06-Jun-90 JCB 1.1 - Allow no operator or name to mean INTERFACE by itself; missed this - valid form when originally doing syntactic analysis code. */ - -#if FFESTR_F90 -void -ffestd_R1202 (ffestpDefinedOperator operator, ffelexToken name) -{ - ffestd_check_simple_ (); - - ffestd_subr_f90_ (); - return; - -#ifdef FFESTD_F90 - switch (operator) - { - case FFESTP_definedoperatorNone: - if (name == NULL) - fputs ("* INTERFACE_unnamed\n", dmpout); - else - fprintf (dmpout, "* INTERFACE %s\n", ffelex_token_text (name)); - break; - - case FFESTP_definedoperatorOPERATOR: - fprintf (dmpout, "* INTERFACE_OPERATOR (.%s.)\n", ffelex_token_text (name)); - break; - - case FFESTP_definedoperatorASSIGNMENT: - fputs ("* INTERFACE_ASSIGNMENT (=)\n", dmpout); - break; - - case FFESTP_definedoperatorPOWER: - fputs ("* INTERFACE_OPERATOR (**)\n", dmpout); - break; - - case FFESTP_definedoperatorMULT: - fputs ("* INTERFACE_OPERATOR (*)\n", dmpout); - break; - - case FFESTP_definedoperatorADD: - fputs ("* INTERFACE_OPERATOR (+)\n", dmpout); - break; - - case FFESTP_definedoperatorCONCAT: - fputs ("* INTERFACE_OPERATOR (//)\n", dmpout); - break; - - case FFESTP_definedoperatorDIVIDE: - fputs ("* INTERFACE_OPERATOR (/)\n", dmpout); - break; - - case FFESTP_definedoperatorSUBTRACT: - fputs ("* INTERFACE_OPERATOR (-)\n", dmpout); - break; - - case FFESTP_definedoperatorNOT: - fputs ("* INTERFACE_OPERATOR (.not.)\n", dmpout); - break; - - case FFESTP_definedoperatorAND: - fputs ("* INTERFACE_OPERATOR (.and.)\n", dmpout); - break; - - case FFESTP_definedoperatorOR: - fputs ("* INTERFACE_OPERATOR (.or.)\n", dmpout); - break; - - case FFESTP_definedoperatorEQV: - fputs ("* INTERFACE_OPERATOR (.eqv.)\n", dmpout); - break; - - case FFESTP_definedoperatorNEQV: - fputs ("* INTERFACE_OPERATOR (.neqv.)\n", dmpout); - break; - - case FFESTP_definedoperatorEQ: - fputs ("* INTERFACE_OPERATOR (==)\n", dmpout); - break; - - case FFESTP_definedoperatorNE: - fputs ("* INTERFACE_OPERATOR (/=)\n", dmpout); - break; - - case FFESTP_definedoperatorLT: - fputs ("* INTERFACE_OPERATOR (<)\n", dmpout); - break; - - case FFESTP_definedoperatorLE: - fputs ("* INTERFACE_OPERATOR (<=)\n", dmpout); - break; - - case FFESTP_definedoperatorGT: - fputs ("* INTERFACE_OPERATOR (>)\n", dmpout); - break; - - case FFESTP_definedoperatorGE: - fputs ("* INTERFACE_OPERATOR (>=)\n", dmpout); - break; - - default: - assert (FALSE); - break; - } -#endif -} - -/* ffestd_R1203 -- End an INTERFACE - - ffestd_R1203(TRUE); */ - -void -ffestd_R1203 (bool ok) -{ - return; /* F90. */ - -#ifdef FFESTD_F90 - fputs ("* END_INTERFACE\n", dmpout); -#endif -} - -/* ffestd_R1205_start -- MODULE PROCEDURE statement list begin - - ffestd_R1205_start(); - - Verify that MODULE PROCEDURE is valid here, and begin accepting items in - the list. */ - -void -ffestd_R1205_start () -{ - ffestd_check_start_ (); - - return; /* F90. */ - -#ifdef FFESTD_F90 - fputs ("* MODULE_PROCEDURE ", dmpout); -#endif -} - -/* ffestd_R1205_item -- MODULE PROCEDURE statement for name - - ffestd_R1205_item(name_token); - - Make sure name_token identifies a valid object to be MODULE PROCEDUREed. */ - -void -ffestd_R1205_item (ffelexToken name) -{ - ffestd_check_item_ (); - assert (name != NULL); - - return; /* F90. */ - -#ifdef FFESTD_F90 - fprintf (dmpout, "%s,", ffelex_token_text (name)); -#endif -} - -/* ffestd_R1205_finish -- MODULE PROCEDURE statement list complete - - ffestd_R1205_finish(); - - Just wrap up any local activities. */ - -void -ffestd_R1205_finish () -{ - ffestd_check_finish_ (); - - return; /* F90. */ - -#ifdef FFESTD_F90 - fputc ('\n', dmpout); -#endif -} - -#endif -/* 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 () -{ - ffestd_check_start_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fputs ("* EXTERNAL (", dmpout); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* 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); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fprintf (dmpout, "%s,", ffelex_token_text (name)); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* ffestd_R1207_finish -- EXTERNAL statement list complete - - ffestd_R1207_finish(); - - Just wrap up any local activities. */ - -void -ffestd_R1207_finish () -{ - ffestd_check_finish_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fputs (")\n", dmpout); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* 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 () -{ - ffestd_check_start_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fputs ("* INTRINSIC (", dmpout); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* 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); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fprintf (dmpout, "%s,", ffelex_token_text (name)); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* ffestd_R1208_finish -- INTRINSIC statement list complete - - ffestd_R1208_finish(); - - Just wrap up any local activities. */ - -void -ffestd_R1208_finish () -{ - ffestd_check_finish_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fputs (")\n", dmpout); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* ffestd_R1212 -- CALL statement - - ffestd_R1212(expr,expr_token); - - Make sure statement is valid here; implement. */ - -void -ffestd_R1212 (ffebld expr) -{ - ffestd_check_simple_ (); - -#if FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_R1212 (expr); -#else - { - ffestdStmt_ stmt; - - 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); - } -#endif -} - -/* ffestd_R1213 -- Defined assignment statement - - ffestd_R1213(dest_expr,source_expr,source_token); - - Make sure the assignment is valid. */ - -#if FFESTR_F90 -void -ffestd_R1213 (ffebld dest, ffebld source) -{ - ffestd_check_simple_ (); - - ffestd_subr_f90_ (); - return; - -#ifdef FFESTD_F90 - fputs ("+ let_defined ", dmpout); - ffebld_dump (dest); - fputs ("=", dmpout); - ffebld_dump (source); - fputc ('\n', dmpout); -#endif -} - -#endif -/* 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) -{ -#if FFECOM_targetCURRENT == FFECOM_targetFFE - char *a; -#endif - - assert (ffestd_block_level_ == 0); - ffestd_is_reachable_ = TRUE; - - ffestd_check_simple_ (); - - ffecom_notify_primary_entry (s); - ffestw_set_sym (ffestw_stack_top (), s); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - switch (type) - { - case FFESTP_typeINTEGER: - a = "INTEGER"; - break; - - case FFESTP_typeBYTE: - a = "BYTE"; - break; - - case FFESTP_typeWORD: - a = "WORD"; - break; - - case FFESTP_typeREAL: - a = "REAL"; - break; - - case FFESTP_typeCOMPLEX: - a = "COMPLEX"; - break; - - case FFESTP_typeLOGICAL: - a = "LOGICAL"; - break; - - case FFESTP_typeCHARACTER: - a = "CHARACTER"; - break; - - case FFESTP_typeDBLPRCSN: - a = "DOUBLE PRECISION"; - break; - - case FFESTP_typeDBLCMPLX: - a = "DOUBLE COMPLEX"; - break; - -#if FFESTR_F90 - case FFESTP_typeTYPE: - a = "TYPE"; - break; -#endif - - case FFESTP_typeNone: - a = ""; - break; - - default: - assert (FALSE); - a = "?"; - break; - } - fprintf (dmpout, "< FUNCTION %s ", ffelex_token_text (funcname)); - if (recursive) - fputs ("RECURSIVE ", dmpout); - fprintf (dmpout, "%s(", a); - if (kindt != NULL) - { - fputs ("kind=", dmpout); - if (kind == NULL) - fputs (ffelex_token_text (kindt), dmpout); - else - ffebld_dump (kind); - if (lent != NULL) - fputc (',', dmpout); - } - if (lent != NULL) - { - fputs ("len=", dmpout); - if (len == NULL) - fputs (ffelex_token_text (lent), dmpout); - else - ffebld_dump (len); - } - fprintf (dmpout, ")"); - if (args != NULL) - { - fputs (" (", dmpout); - ffestt_tokenlist_dump (args); - fputc (')', dmpout); - } - if (result != NULL) - fprintf (dmpout, " result(%s)", ffelex_token_text (result)); - fputc ('\n', dmpout); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* ffestd_R1221 -- End a FUNCTION - - ffestd_R1221(TRUE); */ - -void -ffestd_R1221 (bool ok UNUSED) -{ - 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. */ - -#if FFECOM_ONEPASS - ffeste_R1221 (); -#else - { - ffestdStmt_ stmt; - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR1221_); - ffestd_stmt_append_ (stmt); - } -#endif -} - -/* 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); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fprintf (dmpout, "< SUBROUTINE %s ", ffelex_token_text (subrname)); - if (recursive) - fputs ("recursive ", dmpout); - if (args != NULL) - { - fputc ('(', dmpout); - ffestt_tokenlist_dump (args); - fputc (')', dmpout); - } - fputc ('\n', dmpout); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* ffestd_R1225 -- End a SUBROUTINE - - ffestd_R1225(TRUE); */ - -void -ffestd_R1225 (bool ok UNUSED) -{ - 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. */ - -#if FFECOM_ONEPASS - ffeste_R1225 (); -#else - { - ffestdStmt_ stmt; - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR1225_); - ffestd_stmt_append_ (stmt); - } -#endif -} - -/* 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 (FFECOM_targetCURRENT == FFECOM_targetFFE) || FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_R1226 (entry); -#else - 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_; - } -#endif - - 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) -{ - ffestd_check_simple_ (); - -#if FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_R1227 (ffestw_stack_top (), expr); -#else - { - ffestdStmt_ stmt; - - 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); - } -#endif - - if (ffestd_block_level_ == 0) - ffestd_is_reachable_ = FALSE; -} - -/* ffestd_R1228 -- CONTAINS statement - - ffestd_R1228(); */ - -#if FFESTR_F90 -void -ffestd_R1228 () -{ - assert (ffestd_block_level_ == 0); - - ffestd_check_simple_ (); - - /* Generate RETURN/STOP code here */ - - ffestd_subr_labels_ (ffestw_state (ffestw_stack_top ()) - == FFESTV_stateMODULE5); /* Handle any undefined - labels. */ - - ffestd_subr_f90_ (); - return; - -#ifdef FFESTD_F90 - fputs ("- CONTAINS\n", dmpout); -#endif -} - -#endif -/* 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_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* 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) -{ -#if FFECOM_targetCURRENT == FFECOM_targetFFE - ffebld args = ffesymbol_dummyargs (s); -#endif - ffebld expr = ffesymbol_sfexpr (s); - - ffestd_check_finish_ (); - - if (expr == NULL) - return; /* Nothing to do, definition didn't work. */ - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fprintf (dmpout, "* stmtfunction %s(", ffesymbol_text (s)); - for (; args != NULL; args = ffebld_trail (args)) - fprintf (dmpout, "%s,", ffesymbol_text (ffebld_symter (ffebld_head (args)))); - fputs (")=", dmpout); - ffebld_dump (expr); - fputc ('\n', dmpout); -#if 0 /* Normally no need to preserve the - expression. */ - ffesymbol_set_sfexpr (s, NULL); /* Except expr.c sees NULL - as recursive reference! - So until we can use something - convenient, like a "permanent" - expression, don't worry about - wasting some memory in the - stand-alone FFE. */ -#else - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); -#endif -#elif FFECOM_targetCURRENT == FFECOM_targetGCC - /* With gcc, cannot do anything here, because the backend hasn't even - (necessarily) been notified that we're compiling a program unit! */ - -#if 0 /* Must preserve the expression for gcc. */ - ffesymbol_set_sfexpr (s, NULL); -#else - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); -#endif -#else -#error -#endif -} - -/* 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) - ffewhere_file_kill (wf); - else - ffelex_set_include (wf, (ffelex_token_type (ffesta_tokens[0]) - == FFELEX_typeNAME), fi); - } -} - -/* ffestd_V003_start -- STRUCTURE statement list begin - - ffestd_V003_start(structure_name); - - Verify that STRUCTURE is valid here, and begin accepting items in the list. */ - -#if FFESTR_VXT -void -ffestd_V003_start (ffelexToken structure_name) -{ - ffestd_check_start_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - if (structure_name == NULL) - fputs ("* STRUCTURE_unnamed ", dmpout); - else - fprintf (dmpout, "* STRUCTURE %s ", ffelex_token_text (structure_name)); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC - ffestd_subr_vxt_ (); -#else -#error -#endif -} - -/* ffestd_V003_item -- STRUCTURE statement for object-name - - ffestd_V003_item(name_token,dim_list); - - Make sure name_token identifies a valid object to be STRUCTUREd. */ - -void -ffestd_V003_item (ffelexToken name, ffesttDimList dims) -{ - ffestd_check_item_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fputs (ffelex_token_text (name), dmpout); - if (dims != NULL) - { - fputc ('(', dmpout); - ffestt_dimlist_dump (dims); - fputc (')', dmpout); - } - fputc (',', dmpout); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* ffestd_V003_finish -- STRUCTURE statement list complete - - ffestd_V003_finish(); - - Just wrap up any local activities. */ - -void -ffestd_V003_finish () -{ - ffestd_check_finish_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fputc ('\n', dmpout); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* ffestd_V004 -- End a STRUCTURE - - ffestd_V004(TRUE); */ - -void -ffestd_V004 (bool ok) -{ -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fputs ("* END_STRUCTURE\n", dmpout); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* ffestd_V009 -- UNION statement - - ffestd_V009(); */ - -void -ffestd_V009 () -{ - ffestd_check_simple_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fputs ("* UNION\n", dmpout); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* ffestd_V010 -- End a UNION - - ffestd_V010(TRUE); */ - -void -ffestd_V010 (bool ok) -{ -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fputs ("* END_UNION\n", dmpout); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* ffestd_V012 -- MAP statement - - ffestd_V012(); */ - -void -ffestd_V012 () -{ - ffestd_check_simple_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fputs ("* MAP\n", dmpout); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* ffestd_V013 -- End a MAP - - ffestd_V013(TRUE); */ - -void -ffestd_V013 (bool ok) -{ -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fputs ("* END_MAP\n", dmpout); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -#endif -/* 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 () -{ - ffestd_check_start_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fputs ("* VOLATILE (", dmpout); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC - ffestd_subr_vxt_ (); -#else -#error -#endif -} - -/* 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_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fprintf (dmpout, "%s,", ffelex_token_text (name)); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* 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_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fprintf (dmpout, "/%s/,", ffelex_token_text (name)); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* ffestd_V014_finish -- VOLATILE statement list complete - - ffestd_V014_finish(); - - Just wrap up any local activities. */ - -void -ffestd_V014_finish () -{ - ffestd_check_finish_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fputs (")\n", dmpout); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* ffestd_V016_start -- RECORD statement list begin - - ffestd_V016_start(); - - Verify that RECORD is valid here, and begin accepting items in the list. */ - -#if FFESTR_VXT -void -ffestd_V016_start () -{ - ffestd_check_start_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fputs ("* RECORD ", dmpout); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC - ffestd_subr_vxt_ (); -#else -#error -#endif -} - -/* ffestd_V016_item_structure -- RECORD statement for common-block-name - - ffestd_V016_item_structure(name_token); - - Make sure name_token identifies a valid structure to be RECORDed. */ - -void -ffestd_V016_item_structure (ffelexToken name) -{ - ffestd_check_item_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fprintf (dmpout, "/%s/,", ffelex_token_text (name)); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* ffestd_V016_item_object -- RECORD statement for object-name - - ffestd_V016_item_object(name_token,dim_list); - - Make sure name_token identifies a valid object to be RECORDd. */ - -void -ffestd_V016_item_object (ffelexToken name, ffesttDimList dims) -{ - ffestd_check_item_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fputs (ffelex_token_text (name), dmpout); - if (dims != NULL) - { - fputc ('(', dmpout); - ffestt_dimlist_dump (dims); - fputc (')', dmpout); - } - fputc (',', dmpout); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* ffestd_V016_finish -- RECORD statement list complete - - ffestd_V016_finish(); - - Just wrap up any local activities. */ - -void -ffestd_V016_finish () -{ - ffestd_check_finish_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fputc ('\n', dmpout); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* ffestd_V018_start -- REWRITE(...) statement list begin - - ffestd_V018_start(); - - Verify that REWRITE is valid here, and begin accepting items in the - list. */ - -void -ffestd_V018_start (ffestvFormat format) -{ - ffestd_check_start_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - -#if FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_V018_start (&ffestp_file.rewrite, format); -#else - { - ffestdStmt_ stmt; - - stmt = ffestd_stmt_new_ (FFESTD_stmtidV018_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.V018.pool = ffesta_output_pool; - stmt->u.V018.params = ffestd_subr_copy_rewrite_ (); - stmt->u.V018.format = format; - stmt->u.V018.list = NULL; - ffestd_expr_list_ = &stmt->u.V018.list; - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); - } -#endif - -#endif -#if FFECOM_targetCURRENT == FFECOM_targetGCC - ffestd_subr_vxt_ (); -#endif -} - -/* ffestd_V018_item -- REWRITE statement i/o item - - ffestd_V018_item(expr,expr_token); - - Implement output-list expression. */ - -void -ffestd_V018_item (ffebld expr) -{ - ffestd_check_item_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - -#if FFECOM_ONEPASS - ffeste_V018_item (expr); -#else - { - ffestdExprItem_ item - = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, "ffestdExprItem_", - sizeof (*item)); - - item->next = NULL; - item->expr = expr; - *ffestd_expr_list_ = item; - ffestd_expr_list_ = &item->next; - } -#endif - -#endif -#if FFECOM_targetCURRENT == FFECOM_targetGCC -#endif -} - -/* ffestd_V018_finish -- REWRITE statement list complete - - ffestd_V018_finish(); - - Just wrap up any local activities. */ - -void -ffestd_V018_finish () -{ - ffestd_check_finish_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - -#if FFECOM_ONEPASS - ffeste_V018_finish (); -#else - /* Nothing to do, it's implicit. */ -#endif - -#endif -#if FFECOM_targetCURRENT == FFECOM_targetGCC -#endif -} - -/* ffestd_V019_start -- ACCEPT statement list begin - - ffestd_V019_start(); - - Verify that ACCEPT is valid here, and begin accepting items in the - list. */ - -void -ffestd_V019_start (ffestvFormat format) -{ - ffestd_check_start_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - -#if FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_V019_start (&ffestp_file.accept, format); -#else - { - ffestdStmt_ stmt; - - stmt = ffestd_stmt_new_ (FFESTD_stmtidV019_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.V019.pool = ffesta_output_pool; - stmt->u.V019.params = ffestd_subr_copy_accept_ (); - stmt->u.V019.format = format; - stmt->u.V019.list = NULL; - ffestd_expr_list_ = &stmt->u.V019.list; - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); - } -#endif - -#endif -#if FFECOM_targetCURRENT == FFECOM_targetGCC - ffestd_subr_vxt_ (); -#endif -} - -/* ffestd_V019_item -- ACCEPT statement i/o item - - ffestd_V019_item(expr,expr_token); - - Implement output-list expression. */ - -void -ffestd_V019_item (ffebld expr) -{ - ffestd_check_item_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - -#if FFECOM_ONEPASS - ffeste_V019_item (expr); -#else - { - ffestdExprItem_ item - = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, "ffestdExprItem_", - sizeof (*item)); - - item->next = NULL; - item->expr = expr; - *ffestd_expr_list_ = item; - ffestd_expr_list_ = &item->next; - } -#endif - -#endif -#if FFECOM_targetCURRENT == FFECOM_targetGCC -#endif -} - -/* ffestd_V019_finish -- ACCEPT statement list complete - - ffestd_V019_finish(); - - Just wrap up any local activities. */ - -void -ffestd_V019_finish () -{ - ffestd_check_finish_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - -#if FFECOM_ONEPASS - ffeste_V019_finish (); -#else - /* Nothing to do, it's implicit. */ -#endif - -#endif -#if FFECOM_targetCURRENT == FFECOM_targetGCC -#endif -} - -#endif -/* 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_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - -#if FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_V020_start (&ffestp_file.type, format); -#else - { - ffestdStmt_ stmt; - - stmt = ffestd_stmt_new_ (FFESTD_stmtidV020_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.V020.pool = ffesta_output_pool; - stmt->u.V020.params = ffestd_subr_copy_type_ (); - stmt->u.V020.format = format; - stmt->u.V020.list = NULL; - ffestd_expr_list_ = &stmt->u.V020.list; - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); - } -#endif - -#endif -#if FFECOM_targetCURRENT == FFECOM_targetGCC - ffestd_subr_vxt_ (); -#endif -} - -/* 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_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - -#if FFECOM_ONEPASS - ffeste_V020_item (expr); -#else - { - ffestdExprItem_ item - = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, "ffestdExprItem_", - sizeof (*item)); - - item->next = NULL; - item->expr = expr; - *ffestd_expr_list_ = item; - ffestd_expr_list_ = &item->next; - } -#endif - -#endif -#if FFECOM_targetCURRENT == FFECOM_targetGCC -#endif -} - -/* ffestd_V020_finish -- TYPE statement list complete - - ffestd_V020_finish(); - - Just wrap up any local activities. */ - -void -ffestd_V020_finish () -{ - ffestd_check_finish_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - -#if FFECOM_ONEPASS - ffeste_V020_finish (); -#else - /* Nothing to do, it's implicit. */ -#endif - -#endif -#if FFECOM_targetCURRENT == FFECOM_targetGCC -#endif -} - -/* ffestd_V021 -- DELETE statement - - ffestd_V021(); - - Make sure a DELETE is valid in the current context, and implement it. */ - -#if FFESTR_VXT -void -ffestd_V021 () -{ - ffestd_check_simple_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - -#if FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_V021 (&ffestp_file.delete); -#else - { - ffestdStmt_ stmt; - - stmt = ffestd_stmt_new_ (FFESTD_stmtidV021_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.V021.pool = ffesta_output_pool; - stmt->u.V021.params = ffestd_subr_copy_delete_ (); - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); - } -#endif - -#endif -#if FFECOM_targetCURRENT == FFECOM_targetGCC - ffestd_subr_vxt_ (); -#endif -} - -/* ffestd_V022 -- UNLOCK statement - - ffestd_V022(); - - Make sure a UNLOCK is valid in the current context, and implement it. */ - -void -ffestd_V022 () -{ - ffestd_check_simple_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - -#if FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_V022 (&ffestp_file.beru); -#else - { - ffestdStmt_ stmt; - - stmt = ffestd_stmt_new_ (FFESTD_stmtidV022_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.V022.pool = ffesta_output_pool; - stmt->u.V022.params = ffestd_subr_copy_beru_ (); - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); - } -#endif - -#endif -#if FFECOM_targetCURRENT == FFECOM_targetGCC - ffestd_subr_vxt_ (); -#endif -} - -/* ffestd_V023_start -- ENCODE(...) statement list begin - - ffestd_V023_start(); - - Verify that ENCODE is valid here, and begin accepting items in the - list. */ - -void -ffestd_V023_start () -{ - ffestd_check_start_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - -#if FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_V023_start (&ffestp_file.vxtcode); -#else - { - ffestdStmt_ stmt; - - stmt = ffestd_stmt_new_ (FFESTD_stmtidV023_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.V023.pool = ffesta_output_pool; - stmt->u.V023.params = ffestd_subr_copy_vxtcode_ (); - stmt->u.V023.list = NULL; - ffestd_expr_list_ = &stmt->u.V023.list; - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); - } -#endif - -#endif -#if FFECOM_targetCURRENT == FFECOM_targetGCC - ffestd_subr_vxt_ (); -#endif -} - -/* ffestd_V023_item -- ENCODE statement i/o item - - ffestd_V023_item(expr,expr_token); - - Implement output-list expression. */ - -void -ffestd_V023_item (ffebld expr) -{ - ffestd_check_item_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - -#if FFECOM_ONEPASS - ffeste_V023_item (expr); -#else - { - ffestdExprItem_ item - = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, "ffestdExprItem_", - sizeof (*item)); - - item->next = NULL; - item->expr = expr; - *ffestd_expr_list_ = item; - ffestd_expr_list_ = &item->next; - } -#endif - -#endif -#if FFECOM_targetCURRENT == FFECOM_targetGCC -#endif -} - -/* ffestd_V023_finish -- ENCODE statement list complete - - ffestd_V023_finish(); - - Just wrap up any local activities. */ - -void -ffestd_V023_finish () -{ - ffestd_check_finish_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - -#if FFECOM_ONEPASS - ffeste_V023_finish (); -#else - /* Nothing to do, it's implicit. */ -#endif - -#endif -#if FFECOM_targetCURRENT == FFECOM_targetGCC -#endif -} - -/* ffestd_V024_start -- DECODE(...) statement list begin - - ffestd_V024_start(); - - Verify that DECODE is valid here, and begin accepting items in the - list. */ - -void -ffestd_V024_start () -{ - ffestd_check_start_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - -#if FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_V024_start (&ffestp_file.vxtcode); -#else - { - ffestdStmt_ stmt; - - stmt = ffestd_stmt_new_ (FFESTD_stmtidV024_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.V024.pool = ffesta_output_pool; - stmt->u.V024.params = ffestd_subr_copy_vxtcode_ (); - stmt->u.V024.list = NULL; - ffestd_expr_list_ = &stmt->u.V024.list; - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); - } -#endif - -#endif -#if FFECOM_targetCURRENT == FFECOM_targetGCC - ffestd_subr_vxt_ (); -#endif -} - -/* ffestd_V024_item -- DECODE statement i/o item - - ffestd_V024_item(expr,expr_token); - - Implement output-list expression. */ - -void -ffestd_V024_item (ffebld expr) -{ - ffestd_check_item_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - -#if FFECOM_ONEPASS - ffeste_V024_item (expr); -#else - { - ffestdExprItem_ item - = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, "ffestdExprItem_", - sizeof (*item)); - - item->next = NULL; - item->expr = expr; - *ffestd_expr_list_ = item; - ffestd_expr_list_ = &item->next; - } -#endif - -#endif -#if FFECOM_targetCURRENT == FFECOM_targetGCC -#endif -} - -/* ffestd_V024_finish -- DECODE statement list complete - - ffestd_V024_finish(); - - Just wrap up any local activities. */ - -void -ffestd_V024_finish () -{ - ffestd_check_finish_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - -#if FFECOM_ONEPASS - ffeste_V024_finish (); -#else - /* Nothing to do, it's implicit. */ -#endif - -#endif -#if FFECOM_targetCURRENT == FFECOM_targetGCC -#endif -} - -/* ffestd_V025_start -- DEFINEFILE statement list begin - - ffestd_V025_start(); - - Verify that DEFINEFILE is valid here, and begin accepting items in the - list. */ - -void -ffestd_V025_start () -{ - ffestd_check_start_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - -#if FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_V025_start (); -#else - { - ffestdStmt_ stmt; - - stmt = ffestd_stmt_new_ (FFESTD_stmtidV025start_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); - } -#endif - -#endif -#if FFECOM_targetCURRENT == FFECOM_targetGCC - ffestd_subr_vxt_ (); -#endif -} - -/* ffestd_V025_item -- DEFINE FILE statement item - - ffestd_V025_item(u,ut,m,mt,n,nt,asv,asvt); - - Implement item. Treat each item kind of like a separate statement, - since there's really no need to treat them as an aggregate. */ - -void -ffestd_V025_item (ffebld u, ffebld m, ffebld n, ffebld asv) -{ - ffestd_check_item_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - -#if FFECOM_ONEPASS - ffeste_V025_item (u, m, n, asv); -#else - { - ffestdStmt_ stmt; - - stmt = ffestd_stmt_new_ (FFESTD_stmtidV025item_); - ffestd_stmt_append_ (stmt); - stmt->u.V025item.u = u; - stmt->u.V025item.m = m; - stmt->u.V025item.n = n; - stmt->u.V025item.asv = asv; - } -#endif - -#endif -#if FFECOM_targetCURRENT == FFECOM_targetGCC -#endif -} - -/* ffestd_V025_finish -- DEFINE FILE statement list complete - - ffestd_V025_finish(); - - Just wrap up any local activities. */ - -void -ffestd_V025_finish () -{ - ffestd_check_finish_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - -#if FFECOM_ONEPASS - ffeste_V025_finish (); -#else - { - ffestdStmt_ stmt; - - stmt = ffestd_stmt_new_ (FFESTD_stmtidV025finish_); - stmt->u.V025finish.pool = ffesta_output_pool; - ffestd_stmt_append_ (stmt); - } -#endif - -#endif -#if FFECOM_targetCURRENT == FFECOM_targetGCC -#endif -} - -/* ffestd_V026 -- FIND statement - - ffestd_V026(); - - Make sure a FIND is valid in the current context, and implement it. */ - -void -ffestd_V026 () -{ - ffestd_check_simple_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - -#if FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_V026 (&ffestp_file.find); -#else - { - ffestdStmt_ stmt; - - stmt = ffestd_stmt_new_ (FFESTD_stmtidV026_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - stmt->u.V026.pool = ffesta_output_pool; - stmt->u.V026.params = ffestd_subr_copy_find_ (); - ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); - } -#endif - -#endif -#if FFECOM_targetCURRENT == FFECOM_targetGCC - ffestd_subr_vxt_ (); -#endif -} - -#endif -/* 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 () -{ - ffestd_check_start_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fputs ("* PARAMETER_vxt ", dmpout); -#else -#if FFECOM_targetCURRENT == FFECOM_targetGCC - ffestd_subr_vxt_ (); -#endif -#endif -} - -/* 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_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fputs (ffelex_token_text (dest_token), dmpout); - fputc ('=', dmpout); - ffebld_dump (source); - fputc (',', dmpout); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* ffestd_V027_finish -- VXT PARAMETER statement list complete - - ffestd_V027_finish(); - - Just wrap up any local activities. */ - -void -ffestd_V027_finish () -{ - ffestd_check_finish_ (); - -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fputc ('\n', dmpout); -#elif FFECOM_targetCURRENT == FFECOM_targetGCC -#else -#error -#endif -} - -/* Any executable statement. */ - -void -ffestd_any () -{ - ffestd_check_simple_ (); - -#if FFECOM_ONEPASS - ffestd_subr_line_now_ (); - ffeste_R841 (); -#else - { - ffestdStmt_ stmt; - - stmt = ffestd_stmt_new_ (FFESTD_stmtidR841_); - ffestd_stmt_append_ (stmt); - ffestd_subr_line_save_ (stmt); - } -#endif -} |