diff options
Diffstat (limited to 'gcc/f/std.c')
| -rw-r--r-- | gcc/f/std.c | 6739 |
1 files changed, 6739 insertions, 0 deletions
diff --git a/gcc/f/std.c b/gcc/f/std.c new file mode 100644 index 00000000000..ea497425d9c --- /dev/null +++ b/gcc/f/std.c @@ -0,0 +1,6739 @@ +/* std.c -- Implementation File (module.c template V1.0) + Copyright (C) 1995, 1996 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +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; + ffebld expr; + } + R803; + struct + { + mallocPool pool; + ffebld expr; + } + R804; + 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, + char *string); +static void ffestd_R1001dump_1005_2_ (ffests s, ffesttFormatList f, + char *string); +static void ffestd_R1001dump_1005_3_ (ffests s, ffesttFormatList f, + char *string); +static void ffestd_R1001dump_1005_4_ (ffests s, ffesttFormatList f, + char *string); +static void ffestd_R1001dump_1005_5_ (ffests s, ffesttFormatList f, + char *string); +static void ffestd_R1001dump_1010_1_ (ffests s, ffesttFormatList f, + char *string); +static void ffestd_R1001dump_1010_2_ (ffests s, ffesttFormatList f, + char *string); +static void ffestd_R1001dump_1010_3_ (ffests s, ffesttFormatList f, + char *string); +static void ffestd_R1001dump_1010_4_ (ffests s, ffesttFormatList f, + char *string); +static void ffestd_R1001dump_1010_5_ (ffests s, ffesttFormatList f, + char *string); +static void ffestd_R1001error_ (ffesttFormatList f); + +/* 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. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC + if (ffestd_2pass_entrypoints_ != 0) + { + 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); + ffeste_do (stmt->u.enddoloop.block); + ffestw_kill (stmt->u.enddoloop.block); + break; + + case FFESTD_stmtidENDLOGIF_: + ffestd_subr_line_restore_ (stmt); + ffeste_end_R807 (); + break; + + case FFESTD_stmtidEXECLABEL_: + ffeste_labeldef_branch (stmt->u.execlabel.label); + break; + + case FFESTD_stmtidFORMATLABEL_: + ffeste_labeldef_format (stmt->u.formatlabel.label); + break; + + case FFESTD_stmtidR737A_: + ffestd_subr_line_restore_ (stmt); + 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); + ffeste_R803 (stmt->u.R803.expr); + malloc_pool_kill (stmt->u.R803.pool); + break; + + case FFESTD_stmtidR804_: + ffestd_subr_line_restore_ (stmt); + ffeste_R804 (stmt->u.R804.expr); + malloc_pool_kill (stmt->u.R804.pool); + break; + + case FFESTD_stmtidR805_: + ffestd_subr_line_restore_ (stmt); + ffeste_R805 (); + break; + + case FFESTD_stmtidR806_: + ffestd_subr_line_restore_ (stmt); + ffeste_R806 (); + break; + + case FFESTD_stmtidR807_: + ffestd_subr_line_restore_ (stmt); + ffeste_R807 (stmt->u.R807.expr); + malloc_pool_kill (stmt->u.R807.pool); + break; + + case FFESTD_stmtidR809_: + ffestd_subr_line_restore_ (stmt); + 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); + 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); + 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); + 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); + 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); + ffeste_R825 (); + break; + + case FFESTD_stmtidR834_: + ffestd_subr_line_restore_ (stmt); + ffeste_R834 (stmt->u.R834.block); + break; + + case FFESTD_stmtidR835_: + ffestd_subr_line_restore_ (stmt); + ffeste_R835 (stmt->u.R835.block); + break; + + case FFESTD_stmtidR836_: + ffestd_subr_line_restore_ (stmt); + ffeste_R836 (stmt->u.R836.label); + break; + + case FFESTD_stmtidR837_: + ffestd_subr_line_restore_ (stmt); + 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); + 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); + ffeste_R839 (stmt->u.R839.target); + malloc_pool_kill (stmt->u.R839.pool); + break; + + case FFESTD_stmtidR840_: + ffestd_subr_line_restore_ (stmt); + 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); + ffeste_R841 (); + break; + + case FFESTD_stmtidR842_: + ffestd_subr_line_restore_ (stmt); + ffeste_R842 (stmt->u.R842.expr); + malloc_pool_kill (stmt->u.R842.pool); + break; + + case FFESTD_stmtidR843_: + ffestd_subr_line_restore_ (stmt); + ffeste_R843 (stmt->u.R843.expr); + malloc_pool_kill (stmt->u.R843.pool); + break; + + case FFESTD_stmtidR904_: + ffestd_subr_line_restore_ (stmt); + ffeste_R904 (stmt->u.R904.params); + malloc_pool_kill (stmt->u.R904.pool); + break; + + case FFESTD_stmtidR907_: + ffestd_subr_line_restore_ (stmt); + ffeste_R907 (stmt->u.R907.params); + malloc_pool_kill (stmt->u.R907.pool); + break; + + case FFESTD_stmtidR909_: + ffestd_subr_line_restore_ (stmt); + 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) + { + ffeste_R909_item (expr->expr, expr->token); + ffelex_token_kill (expr->token); + } + ffeste_R909_finish (); + malloc_pool_kill (stmt->u.R909.pool); + break; + + case FFESTD_stmtidR910_: + ffestd_subr_line_restore_ (stmt); + 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) + { + ffeste_R910_item (expr->expr, expr->token); + ffelex_token_kill (expr->token); + } + ffeste_R910_finish (); + malloc_pool_kill (stmt->u.R910.pool); + break; + + case FFESTD_stmtidR911_: + ffestd_subr_line_restore_ (stmt); + ffeste_R911_start (stmt->u.R911.params, stmt->u.R911.format); + for (expr = stmt->u.R911.list; expr != NULL; expr = expr->next) + { + ffeste_R911_item (expr->expr, expr->token); + ffelex_token_kill (expr->token); + } + ffeste_R911_finish (); + malloc_pool_kill (stmt->u.R911.pool); + break; + + case FFESTD_stmtidR919_: + ffestd_subr_line_restore_ (stmt); + ffeste_R919 (stmt->u.R919.params); + malloc_pool_kill (stmt->u.R919.pool); + break; + + case FFESTD_stmtidR920_: + ffestd_subr_line_restore_ (stmt); + ffeste_R920 (stmt->u.R920.params); + malloc_pool_kill (stmt->u.R920.pool); + break; + + case FFESTD_stmtidR921_: + ffestd_subr_line_restore_ (stmt); + ffeste_R921 (stmt->u.R921.params); + malloc_pool_kill (stmt->u.R921.pool); + break; + + case FFESTD_stmtidR923A_: + ffestd_subr_line_restore_ (stmt); + 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); + ffeste_R923B_start (stmt->u.R923B.params); + for (expr = stmt->u.R923B.list; expr != NULL; expr = expr->next) + ffeste_R923B_item (expr->expr); + ffeste_R923B_finish (); + malloc_pool_kill (stmt->u.R923B.pool); + break; + + case FFESTD_stmtidR1001_: + ffeste_R1001 (&stmt->u.R1001.str); + ffests_kill (&stmt->u.R1001.str); + break; + + case FFESTD_stmtidR1103_: + ffeste_R1103 (); + break; + + case FFESTD_stmtidR1112_: + ffeste_R1112 (); + break; + + case FFESTD_stmtidR1212_: + ffestd_subr_line_restore_ (stmt); + ffeste_R1212 (stmt->u.R1212.expr); + malloc_pool_kill (stmt->u.R1212.pool); + break; + + case FFESTD_stmtidR1221_: + ffeste_R1221 (); + break; + + case FFESTD_stmtidR1225_: + ffeste_R1225 (); + break; + + case FFESTD_stmtidR1226_: + ffestd_subr_line_restore_ (stmt); + if (stmt->u.R1226.entry != NULL) + ffeste_R1226 (stmt->u.R1226.entry); + break; + + case FFESTD_stmtidR1227_: + ffestd_subr_line_restore_ (stmt); + 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); + ffeste_V018_start (stmt->u.V018.params, stmt->u.V018.format); + for (expr = stmt->u.V018.list; expr != NULL; expr = expr->next) + ffeste_V018_item (expr->expr); + ffeste_V018_finish (); + malloc_pool_kill (stmt->u.V018.pool); + break; + + case FFESTD_stmtidV019_: + ffestd_subr_line_restore_ (stmt); + ffeste_V019_start (stmt->u.V019.params, stmt->u.V019.format); + for (expr = stmt->u.V019.list; expr != NULL; expr = expr->next) + ffeste_V019_item (expr->expr); + ffeste_V019_finish (); + malloc_pool_kill (stmt->u.V019.pool); + break; +#endif + + case FFESTD_stmtidV020_: + ffestd_subr_line_restore_ (stmt); + ffeste_V020_start (stmt->u.V020.params, stmt->u.V020.format); + for (expr = stmt->u.V020.list; expr != NULL; expr = expr->next) + ffeste_V020_item (expr->expr); + ffeste_V020_finish (); + malloc_pool_kill (stmt->u.V020.pool); + break; + +#if FFESTR_VXT + case FFESTD_stmtidV021_: + ffestd_subr_line_restore_ (stmt); + ffeste_V021 (stmt->u.V021.params); + malloc_pool_kill (stmt->u.V021.pool); + break; + + case FFESTD_stmtidV023_: + ffestd_subr_line_restore_ (stmt); + ffeste_V023_start (stmt->u.V023.params); + for (expr = stmt->u.V023.list; expr != NULL; expr = expr->next) + ffeste_V023_item (expr->expr); + ffeste_V023_finish (); + malloc_pool_kill (stmt->u.V023.pool); + break; + + case FFESTD_stmtidV024_: + ffestd_subr_line_restore_ (stmt); + ffeste_V024_start (stmt->u.V024.params); + for (expr = stmt->u.V024.list; expr != NULL; expr = expr->next) + ffeste_V024_item (expr->expr); + ffeste_V024_finish (); + malloc_pool_kill (stmt->u.V024.pool); + break; + + case FFESTD_stmtidV025start_: + ffestd_subr_line_restore_ (stmt); + ffeste_V025_start (); + break; + + case FFESTD_stmtidV025item_: + ffeste_V025_item (stmt->u.V025item.u, stmt->u.V025item.m, + stmt->u.V025item.n, stmt->u.V025item.asv); + break; + + case FFESTD_stmtidV025finish_: + ffeste_V025_finish (); + malloc_pool_kill (stmt->u.V025finish.pool); + break; + + case FFESTD_stmtidV026_: + ffestd_subr_line_restore_ (stmt); + 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_); + ffestd_stmt_append_ (stmt); + 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 + + ffestd_R745(TRUE); + + Implement the end of the current WHERE "block". ok==TRUE iff statement + following WHERE (substatement) is valid; else, statement is invalid + or stack forcibly popped due to ffestd_eof_(). */ + +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 +/* ffestd_R803 -- Block IF (IF-THEN) statement + + ffestd_R803(construct_name,expr,expr_token); + + Make sure statement is valid here; implement. */ + +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.expr = expr; + ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); + } +#endif + + ++ffestd_block_level_; + assert (ffestd_block_level_ > 0); +} + +/* ffestd_R804 -- ELSE IF statement + + ffestd_R804(expr,expr_token,name_token); + + Make sure ffestd_kind_ identifies an IF block. If not + NULL, make sure name_token gives the correct name. Implement the else + of the IF block. */ + +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.expr = expr; + ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); + } +#endif +} + +/* ffestd_R805 -- ELSE statement + + ffestd_R805(name_token); + + Make sure ffestd_kind_ identifies an IF block. If not + NULL, make sure name_token gives the correct name. Implement the ELSE + of the IF block. */ + +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); + } +#endif +} + +/* ffestd_R806 -- End an IF-THEN + + ffestd_R806(TRUE); */ + +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); + } +#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); + 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_); + ffestd_stmt_append_ (stmt); + 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_R1001error_ (next); + 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, 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_R1001error_ (f); + 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_R1001error_ (f); + 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, 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_R1001error_ (f); + else + ffests_printf_1U (s, "%lu", f->u.R1005.R1004.u.unsigned_val); + + ffests_puts (s, string); + + if (f->u.R1005.R1006.rtexpr) + ffestd_R1001error_ (f); + 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, 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_R1001error_ (f); + else + ffests_printf_1U (s, "%lu", f->u.R1005.R1004.u.unsigned_val); + + ffests_puts (s, string); + + if (f->u.R1005.R1006.rtexpr) + ffestd_R1001error_ (f); + 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_R1001error_ (f); + 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, 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_R1001error_ (f); + else + ffests_printf_1U (s, "%lu", f->u.R1005.R1004.u.unsigned_val); + + ffests_puts (s, string); + + if (f->u.R1005.R1006.rtexpr) + ffestd_R1001error_ (f); + 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_R1001error_ (f); + 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, 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_R1001error_ (f); + else + ffests_printf_1U (s, "%lu", f->u.R1005.R1004.u.unsigned_val); + + ffests_puts (s, string); + + if (f->u.R1005.R1006.rtexpr) + ffestd_R1001error_ (f); + 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_R1001error_ (f); + 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_R1001error_ (f); + 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, 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, char *string) +{ + if (f->u.R1010.val.present) + if (f->u.R1010.val.rtexpr) + ffestd_R1001error_ (f); + 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, char *string) +{ + assert (f->u.R1010.val.present); + + if (f->u.R1010.val.rtexpr) + ffestd_R1001error_ (f); + 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, char *string) +{ + assert (f->u.R1010.val.present); + + if (f->u.R1010.val.rtexpr) + ffestd_R1001error_ (f); + 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, char *string) +{ + assert (f->u.R1010.val.present); + + ffests_puts (s, string); + + if (f->u.R1010.val.rtexpr) + ffestd_R1001error_ (f); + 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 (); +} + +/* 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 +} |