/* std.c -- Implementation File (module.c template V1.0)
- Copyright (C) 1995, 1996 Free Software Foundation, Inc.
+ Copyright (C) 1995, 1996, 2000, 2002, 2003 Free Software Foundation, Inc.
Contributed by James Craig Burley.
This file is part of GNU Fortran.
FFESTD_
} ffestdStatelet_;
-#if FFECOM_TWOPASS
typedef enum
{
FFESTD_stmtidENDDOLOOP_,
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. */
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
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;
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_
-=
+ffestd_stmt_list_ =
{
NULL, NULL
};
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static int ffestd_2pass_entrypoints_ = 0; /* # ENTRY statements
- pending. */
-#endif
+
+/* # ENTRY statements pending. */
+static int ffestd_2pass_entrypoints_ = 0;
/* 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
+#if FFESTD_COPY_EASY_
static ffestpInquireStmt *ffestd_subr_copy_easy_ (ffestpInquireIx max);
#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static void ffestd_subr_vxt_ (void);
-#endif
-#if FFESTR_F90
-static void ffestd_subr_f90_ (void);
-#endif
static void ffestd_subr_labels_ (bool unexpected);
static void ffestd_R1001dump_ (ffests s, ffesttFormatList list);
static void ffestd_R1001dump_1005_1_ (ffests s, ffesttFormatList f,
const char *string);
static void ffestd_R1001dump_1010_2_ (ffests s, ffesttFormatList f,
const char *string);
-static void ffestd_R1001dump_1010_3_ (ffests s, ffesttFormatList f,
- const char *string);
static void ffestd_R1001dump_1010_4_ (ffests s, ffesttFormatList f,
const char *string);
static void ffestd_R1001dump_1010_5_ (ffests s, ffesttFormatList f,
/* 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_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_() \
|| ffestd_statelet_ == FFESTD_stateletITEM_); \
ffestd_statelet_ = FFESTD_stateletSIMPLE_
-#if FFESTD_COPY_EASY_ && FFECOM_TWOPASS
+#if FFESTD_COPY_EASY_
#define ffestd_subr_copy_accept_() (ffestpAcceptStmt *) \
ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_acceptix)
#define ffestd_subr_copy_beru_() (ffestpBeruStmt *) \
ffestd_stmt_append_(ffestd_stmt_new_(FFESTD_stmtidR737A_)); */
-#if FFECOM_TWOPASS
static void
ffestd_stmt_append_ (ffestdStmt_ 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)
{
return stmt;
}
-#endif
/* ffestd_stmt_pass_ -- Pass all statements on list to ffeste
ffestd_stmt_pass_(); */
-#if FFECOM_TWOPASS
static void
ffestd_stmt_pass_ ()
{
ffestdExprItem_ expr; /* For traversing lists. */
bool okay = (TREE_CODE (current_function_decl) != ERROR_MARK);
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
if ((ffestd_2pass_entrypoints_ != 0) && okay)
{
tree which = ffecom_which_entrypoint_decl ();
tree duplicate;
expand_start_case (0, which, TREE_TYPE (which), "entrypoint dispatch");
- push_momentary ();
stmt = ffestd_stmt_list_.first;
do
label = ffecom_temp_label ();
TREE_USED (label) = 1;
expand_goto (label);
- clear_momentary ();
ffesymbol_hook (stmt->u.R1226.entry).length_tree = label;
}
}
while (--ents != 0);
- pop_momentary ();
expand_end_case (which);
- clear_momentary ();
}
-#endif
for (stmt = ffestd_stmt_list_.first;
stmt != (ffestdStmt_) &ffestd_stmt_list_.first;
malloc_pool_kill (stmt->u.R1227.pool);
break;
-#if FFESTR_VXT
- case FFESTD_stmtidV018_:
- ffestd_subr_line_restore_ (stmt);
- if (okay)
- ffeste_V018_start (stmt->u.V018.params, stmt->u.V018.format);
- for (expr = stmt->u.V018.list; expr != NULL; expr = expr->next)
- {
- if (okay)
- ffeste_V018_item (expr->expr);
- }
- if (okay)
- ffeste_V018_finish ();
- malloc_pool_kill (stmt->u.V018.pool);
- break;
-
- case FFESTD_stmtidV019_:
- ffestd_subr_line_restore_ (stmt);
- if (okay)
- ffeste_V019_start (stmt->u.V019.params, stmt->u.V019.format);
- for (expr = stmt->u.V019.list; expr != NULL; expr = expr->next)
- {
- if (okay)
- ffeste_V019_item (expr->expr);
- }
- if (okay)
- ffeste_V019_finish ();
- malloc_pool_kill (stmt->u.V019.pool);
- break;
-#endif
-
case FFESTD_stmtidV020_:
ffestd_subr_line_restore_ (stmt);
if (okay)
malloc_pool_kill (stmt->u.V020.pool);
break;
-#if FFESTR_VXT
- case FFESTD_stmtidV021_:
- ffestd_subr_line_restore_ (stmt);
- if (okay)
- ffeste_V021 (stmt->u.V021.params);
- malloc_pool_kill (stmt->u.V021.pool);
- break;
-
- case FFESTD_stmtidV023_:
- ffestd_subr_line_restore_ (stmt);
- if (okay)
- ffeste_V023_start (stmt->u.V023.params);
- for (expr = stmt->u.V023.list; expr != NULL; expr = expr->next)
- {
- if (okay)
- ffeste_V023_item (expr->expr);
- }
- if (okay)
- ffeste_V023_finish ();
- malloc_pool_kill (stmt->u.V023.pool);
- break;
-
- case FFESTD_stmtidV024_:
- ffestd_subr_line_restore_ (stmt);
- if (okay)
- ffeste_V024_start (stmt->u.V024.params);
- for (expr = stmt->u.V024.list; expr != NULL; expr = expr->next)
- {
- if (okay)
- ffeste_V024_item (expr->expr);
- }
- if (okay)
- ffeste_V024_finish ();
- malloc_pool_kill (stmt->u.V024.pool);
- break;
-
- case FFESTD_stmtidV025start_:
- ffestd_subr_line_restore_ (stmt);
- if (okay)
- ffeste_V025_start ();
- break;
-
- case FFESTD_stmtidV025item_:
- if (okay)
- ffeste_V025_item (stmt->u.V025item.u, stmt->u.V025item.m,
- stmt->u.V025item.n, stmt->u.V025item.asv);
- break;
-
- case FFESTD_stmtidV025finish_:
- if (okay)
- ffeste_V025_finish ();
- malloc_pool_kill (stmt->u.V025finish.pool);
- break;
-
- case FFESTD_stmtidV026_:
- ffestd_subr_line_restore_ (stmt);
- if (okay)
- ffeste_V026 (stmt->u.V026.params);
- malloc_pool_kill (stmt->u.V026.pool);
- break;
-#endif
-
default:
assert ("bad stmt->id" == NULL);
break;
}
}
-#endif
/* ffestd_subr_copy_easy_ -- Copy I/O statement data structure
ffestd_subr_copy_easy_();
and structure references assume (though not necessarily dangerous if
FALSE) that INQUIRE has the most file elements. */
-#if FFESTD_COPY_EASY_ && FFECOM_TWOPASS
+#if FFESTD_COPY_EASY_
static ffestpInquireStmt *
ffestd_subr_copy_easy_ (ffestpInquireIx max)
{
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_finish ();
}
-#endif
/* ffestd_begin_uses -- Start a bunch of USE statements
ffestd_begin_uses();
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
void
ffestd_do (bool ok UNUSED)
{
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_do (ffestw_stack_top ());
-#else
- {
- ffestdStmt_ stmt;
+ 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
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidENDDOLOOP_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.enddoloop.block = ffestw_stack_top ();
--ffestd_block_level_;
assert (ffestd_block_level_ >= 0);
}
-/* ffestd_end_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);
void
ffestd_end_R807 (bool ok UNUSED)
{
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_end_R807 ();
-#else
- {
- ffestdStmt_ stmt;
+ ffestdStmt_ stmt;
- stmt = ffestd_stmt_new_ (FFESTD_stmtidENDLOGIF_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- }
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidENDLOGIF_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
--ffestd_block_level_;
assert (ffestd_block_level_ >= 0);
{
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. */
}
while (--ents != 0);
}
-#endif
}
/* ffestd_exec_end -- Executable statements can no longer come in now
void
ffestd_exec_end ()
{
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
- int old_lineno = lineno;
- const char *old_input_filename = input_filename;
-#endif
+ location_t old_loc = input_location;
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)
ffestd_stmt_list_.last = NULL;
ffestd_2pass_entrypoints_ = 0;
- lineno = old_lineno;
- input_filename = old_input_filename;
-#endif
+ input_location = old_loc;
}
/* ffestd_init_3 -- Initialize for any program unit
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
void
ffestd_labeldef_branch (ffelab label)
{
-#if FFECOM_ONEPASS
- ffeste_labeldef_branch (label);
-#else
- {
- ffestdStmt_ stmt;
+ ffestdStmt_ stmt;
- stmt = ffestd_stmt_new_ (FFESTD_stmtidEXECLABEL_);
- ffestd_stmt_append_ (stmt);
- stmt->u.execlabel.label = label;
- }
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidEXECLABEL_);
+ ffestd_stmt_append_ (stmt);
+ stmt->u.execlabel.label = label;
ffestd_is_reachable_ = TRUE;
}
void
ffestd_labeldef_format (ffelab label)
{
+ ffestdStmt_ stmt;
+
ffestd_label_formatdef_ = label;
-#if FFECOM_ONEPASS
- ffeste_labeldef_format (label);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidFORMATLABEL_);
-#if 0
- /* Don't bother with this. See FORMAT statement. */
- /* Prepend FORMAT label instead of appending it, so all the
- FORMAT label/statement pairs end up at the top of the list.
- This helps ensure all decls for a block (in the GBE) are
- known before any executable statements are generated. */
- stmt->previous = (ffestdStmt_) &ffestd_stmt_list_.first;
- stmt->next = ffestd_stmt_list_.first;
- stmt->next->previous = stmt;
- stmt->previous->next = stmt;
-#else
- ffestd_stmt_append_ (stmt);
-#endif
- stmt->u.formatlabel.label = label;
- }
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidFORMATLABEL_);
+ ffestd_stmt_append_ (stmt);
+ stmt->u.formatlabel.label = label;
}
/* ffestd_labeldef_useless -- Generate "code" for useless label def
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_R522 -- SAVE statement with no list
+
+ ffestd_R522();
- ffestd_R423A(); */
+ Verify that SAVE is valid here, and flag everything as SAVEd. */
-#if FFESTR_F90
void
-ffestd_R423A ()
+ffestd_R522 ()
{
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_R522start -- SAVE statement list begin
+
+ ffestd_R522start();
- ffestd_R423B(); */
+ Verify that SAVE is valid here, and begin accepting items in the list. */
void
-ffestd_R423B ()
+ffestd_R522start ()
{
- ffestd_check_simple_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("* SEQUENCE_derived_type\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
+ ffestd_check_start_ ();
}
-/* ffestd_R424 -- derived-TYPE-def statement
+/* ffestd_R522item_object -- SAVE statement for object-name
- ffestd_R424(access_token,access_kw,name_token);
+ ffestd_R522item_object(name_token);
- Handle a derived-type definition. */
+ Make sure name_token identifies a valid object to be SAVEd. */
void
-ffestd_R424 (ffelexToken access, ffestrOther access_kw, ffelexToken name)
+ffestd_R522item_object (ffelexToken name UNUSED)
{
- ffestd_check_simple_ ();
-
- ffestd_subr_f90_ ();
- return;
+ ffestd_check_item_ ();
+}
-#ifdef FFESTD_F90
- char *a;
+/* ffestd_R522item_cblock -- SAVE statement for common-block-name
- if (access == NULL)
- fprintf (dmpout, "* TYPE %s\n", ffelex_token_text (name));
- else
- {
- switch (access_kw)
- {
- case FFESTR_otherPUBLIC:
- a = "PUBLIC";
- break;
+ ffestd_R522item_cblock(name_token);
- case FFESTR_otherPRIVATE:
- a = "PRIVATE";
- break;
+ Make sure name_token identifies a valid common block to be SAVEd. */
- default:
- assert (FALSE);
- }
- fprintf (dmpout, "* TYPE,%s: %s\n", a, ffelex_token_text (name));
- }
-#endif
+void
+ffestd_R522item_cblock (ffelexToken name UNUSED)
+{
+ ffestd_check_item_ ();
}
-/* ffestd_R425 -- End a TYPE
+/* ffestd_R522finish -- SAVE statement list complete
+
+ ffestd_R522finish();
- ffestd_R425(TRUE); */
+ Just wrap up any local activities. */
void
-ffestd_R425 (bool ok)
+ffestd_R522finish ()
{
-#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_check_finish_ ();
}
-/* ffestd_R519_start -- INTENT statement list begin
+/* ffestd_R524_start -- DIMENSION statement list begin
- ffestd_R519_start();
+ ffestd_R524_start(bool virtual);
- Verify that INTENT is valid here, and begin accepting items in the list. */
+ Verify that DIMENSION is valid here, and begin accepting items in the list. */
void
-ffestd_R519_start (ffestrOther intent_kw)
+ffestd_R524_start (bool virtual UNUSED)
{
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_R524_item -- DIMENSION statement for object-name
- ffestd_R519_item(name_token);
+ ffestd_R524_item(name_token,dim_list);
- Make sure name_token identifies a valid object to be INTENTed. */
+ Make sure name_token identifies a valid object to be DIMENSIONd. */
void
-ffestd_R519_item (ffelexToken name)
+ffestd_R524_item (ffelexToken name UNUSED, ffesttDimList dims UNUSED)
{
ffestd_check_item_ ();
-
- return; /* F90. */
-
-#ifdef FFESTD_F90
- fprintf (dmpout, "%s,", ffelex_token_text (name));
-#endif
}
-/* ffestd_R519_finish -- INTENT statement list complete
+/* ffestd_R524_finish -- DIMENSION statement list complete
- ffestd_R519_finish();
+ ffestd_R524_finish();
Just wrap up any local activities. */
void
-ffestd_R519_finish ()
+ffestd_R524_finish ()
{
ffestd_check_finish_ ();
-
- return; /* F90. */
-
-#ifdef FFESTD_F90
- fputc ('\n', dmpout);
-#endif
}
-/* ffestd_R520_start -- OPTIONAL statement list begin
+/* ffestd_R537_start -- PARAMETER statement list begin
- ffestd_R520_start();
+ ffestd_R537_start();
- Verify that OPTIONAL is valid here, and begin accepting items in the list. */
+ Verify that PARAMETER is valid here, and begin accepting items in the list. */
void
-ffestd_R520_start ()
+ffestd_R537_start ()
{
ffestd_check_start_ ();
-
- ffestd_subr_f90_ ();
- return;
-
-#ifdef FFESTD_F90
- fputs ("* OPTIONAL ", dmpout);
-#endif
}
-/* ffestd_R520_item -- OPTIONAL statement for name
+/* ffestd_R537_item -- PARAMETER statement assignment
- ffestd_R520_item(name_token);
+ ffestd_R537_item(dest,dest_token,source,source_token);
- Make sure name_token identifies a valid object to be OPTIONALed. */
+ Make sure the source is a valid source for the destination; make the
+ assignment. */
void
-ffestd_R520_item (ffelexToken name)
+ffestd_R537_item (ffebld dest UNUSED, ffebld source UNUSED)
{
ffestd_check_item_ ();
-
- return; /* F90. */
-
-#ifdef FFESTD_F90
- fprintf (dmpout, "%s,", ffelex_token_text (name));
-#endif
}
-/* ffestd_R520_finish -- OPTIONAL statement list complete
+/* ffestd_R537_finish -- PARAMETER statement list complete
- ffestd_R520_finish();
+ ffestd_R537_finish();
Just wrap up any local activities. */
void
-ffestd_R520_finish ()
+ffestd_R537_finish ()
{
ffestd_check_finish_ ();
-
- return; /* F90. */
-
-#ifdef FFESTD_F90
- fputc ('\n', dmpout);
-#endif
}
-/* ffestd_R521A -- PUBLIC statement
+/* ffestd_R539 -- IMPLICIT NONE statement
- ffestd_R521A();
+ ffestd_R539();
- Verify that PUBLIC is valid here. */
+ Verify that the IMPLICIT NONE statement is ok here and implement. */
void
-ffestd_R521A ()
+ffestd_R539 ()
{
ffestd_check_simple_ ();
-
- ffestd_subr_f90_ ();
- return;
-
-#ifdef FFESTD_F90
- fputs ("* PUBLIC\n", dmpout);
-#endif
}
-/* ffestd_R521Astart -- PUBLIC statement list begin
+/* ffestd_R539start -- IMPLICIT statement
- ffestd_R521Astart();
+ ffestd_R539start();
- Verify that PUBLIC is valid here, and begin accepting items in the list. */
+ Verify that the IMPLICIT statement is ok here and implement. */
void
-ffestd_R521Astart ()
+ffestd_R539start ()
{
ffestd_check_start_ ();
-
- ffestd_subr_f90_ ();
- return;
-
-#ifdef FFESTD_F90
- fputs ("* PUBLIC ", dmpout);
-#endif
}
-/* ffestd_R521Aitem -- PUBLIC statement for name
+/* ffestd_R539item -- IMPLICIT statement specification (R540)
- ffestd_R521Aitem(name_token);
+ ffestd_R539item(...);
- Make sure name_token identifies a valid object to be PUBLICed. */
+ Verify that the type and letter list are all ok and implement. */
void
-ffestd_R521Aitem (ffelexToken name)
+ffestd_R539item (ffestpType type UNUSED, ffebld kind UNUSED,
+ ffelexToken kindt UNUSED, ffebld len UNUSED,
+ ffelexToken lent UNUSED, ffesttImpList letters UNUSED)
{
ffestd_check_item_ ();
-
- return; /* F90. */
-
-#ifdef FFESTD_F90
- fprintf (dmpout, "%s,", ffelex_token_text (name));
-#endif
}
-/* ffestd_R521Afinish -- PUBLIC statement list complete
+/* ffestd_R539finish -- IMPLICIT statement
- ffestd_R521Afinish();
+ ffestd_R539finish();
- Just wrap up any local activities. */
+ Finish up any local activities. */
void
-ffestd_R521Afinish ()
+ffestd_R539finish ()
{
ffestd_check_finish_ ();
-
- return; /* F90. */
-
-#ifdef FFESTD_F90
- fputc ('\n', dmpout);
-#endif
}
-/* ffestd_R521B -- PRIVATE statement
+/* ffestd_R542_start -- NAMELIST statement list begin
- ffestd_R521B();
+ ffestd_R542_start();
- Verify that PRIVATE is valid here (outside a derived-type statement). */
+ Verify that NAMELIST is valid here, and begin accepting items in the list. */
void
-ffestd_R521B ()
+ffestd_R542_start ()
{
- ffestd_check_simple_ ();
-
- ffestd_subr_f90_ ();
- return;
-
-#ifdef FFESTD_F90
- fputs ("* PRIVATE_outside_of_R422_derived_type_def\n", dmpout);
-#endif
+ ffestd_check_start_ ();
}
-/* ffestd_R521Bstart -- PRIVATE statement list begin
+/* ffestd_R542_item_nlist -- NAMELIST statement for group-name
- ffestd_R521Bstart();
+ ffestd_R542_item_nlist(groupname_token);
- Verify that PRIVATE is valid here, and begin accepting items in the list. */
+ Make sure name_token identifies a valid object to be NAMELISTd. */
void
-ffestd_R521Bstart ()
+ffestd_R542_item_nlist (ffelexToken name UNUSED)
{
- ffestd_check_start_ ();
-
- ffestd_subr_f90_ ();
- return;
-
-#ifdef FFESTD_F90
- fputs ("* PRIVATE ", dmpout);
-#endif
+ ffestd_check_item_ ();
}
-/* ffestd_R521Bitem -- PRIVATE statement for name
+/* ffestd_R542_item_nitem -- NAMELIST statement for variable-name
- ffestd_R521Bitem(name_token);
+ ffestd_R542_item_nitem(name_token);
- Make sure name_token identifies a valid object to be PRIVATEed. */
+ Make sure name_token identifies a valid object to be NAMELISTd. */
void
-ffestd_R521Bitem (ffelexToken name)
+ffestd_R542_item_nitem (ffelexToken name UNUSED)
{
ffestd_check_item_ ();
-
- return; /* F90. */
-
-#ifdef FFESTD_F90
- fprintf (dmpout, "%s,", ffelex_token_text (name));
-#endif
}
-/* ffestd_R521Bfinish -- PRIVATE statement list complete
+/* ffestd_R542_finish -- NAMELIST statement list complete
- ffestd_R521Bfinish();
+ ffestd_R542_finish();
Just wrap up any local activities. */
void
-ffestd_R521Bfinish ()
+ffestd_R542_finish ()
{
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_R547_start -- COMMON statement list begin
- ffestd_R522start();
+ ffestd_R547_start();
- Verify that SAVE is valid here, and begin accepting items in the list. */
+ Verify that COMMON is valid here, and begin accepting items in the list. */
void
-ffestd_R522start ()
+ffestd_R547_start ()
{
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_R547_item_object -- COMMON statement for object-name
- ffestd_R522item_object(name_token);
+ ffestd_R547_item_object(name_token,dim_list);
- Make sure name_token identifies a valid object to be SAVEd. */
+ Make sure name_token identifies a valid object to be COMMONd. */
void
-ffestd_R522item_object (ffelexToken name UNUSED)
+ffestd_R547_item_object (ffelexToken name UNUSED,
+ ffesttDimList dims 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_R547_item_cblock -- COMMON statement for common-block-name
- ffestd_R522item_cblock(name_token);
+ ffestd_R547_item_cblock(name_token);
- Make sure name_token identifies a valid common block to be SAVEd. */
+ Make sure name_token identifies a valid common block to be COMMONd. */
void
-ffestd_R522item_cblock (ffelexToken name UNUSED)
+ffestd_R547_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_R522finish -- SAVE statement list complete
+/* ffestd_R547_finish -- COMMON statement list complete
- ffestd_R522finish();
+ ffestd_R547_finish();
Just wrap up any local activities. */
void
-ffestd_R522finish ()
+ffestd_R547_finish ()
{
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);
+/* ffestd_R737A -- Assignment statement outside of WHERE
- Verify that DIMENSION is valid here, and begin accepting items in the list. */
+ ffestd_R737A(dest_expr,source_expr); */
void
-ffestd_R524_start (bool virtual UNUSED)
+ffestd_R737A (ffebld dest, ffebld source)
{
- ffestd_check_start_ ();
+ ffestdStmt_ stmt;
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- if (virtual)
- fputs ("* VIRTUAL ", dmpout); /* V028. */
- else
- fputs ("* DIMENSION ", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
-}
+ ffestd_check_simple_ ();
-/* ffestd_R524_item -- DIMENSION statement for object-name
+ 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);
+}
- ffestd_R524_item(name_token,dim_list);
- Make sure name_token identifies a valid object to be DIMENSIONd. */
+/* Block IF (IF-THEN) statement. */
void
-ffestd_R524_item (ffelexToken name UNUSED, ffesttDimList dims UNUSED)
+ffestd_R803 (ffelexToken construct_name UNUSED, ffebld expr)
{
- ffestd_check_item_ ();
+ ffestdStmt_ stmt;
-#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_check_simple_ ();
-/* ffestd_R524_finish -- DIMENSION statement list complete
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR803_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R803.pool = ffesta_output_pool;
+ stmt->u.R803.block = ffestw_use (ffestw_stack_top ());
+ stmt->u.R803.expr = expr;
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- ffestd_R524_finish();
+ ++ffestd_block_level_;
+ assert (ffestd_block_level_ > 0);
+}
- Just wrap up any local activities. */
+/* ELSE IF statement. */
void
-ffestd_R524_finish ()
+ffestd_R804 (ffebld expr, ffelexToken name UNUSED)
{
- ffestd_check_finish_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputc ('\n', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
-}
+ ffestdStmt_ stmt;
-/* ffestd_R525_start -- ALLOCATABLE statement list begin
+ ffestd_check_simple_ ();
- ffestd_R525_start();
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR804_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R804.pool = ffesta_output_pool;
+ stmt->u.R804.block = ffestw_use (ffestw_stack_top ());
+ stmt->u.R804.expr = expr;
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
+}
- Verify that ALLOCATABLE is valid here, and begin accepting items in the
- list. */
+/* ELSE statement. */
-#if FFESTR_F90
void
-ffestd_R525_start ()
+ffestd_R805 (ffelexToken name UNUSED)
{
- ffestd_check_start_ ();
+ ffestdStmt_ stmt;
- ffestd_subr_f90_ ();
- return;
+ ffestd_check_simple_ ();
-#ifdef FFESTD_F90
- fputs ("* ALLOCATABLE ", dmpout);
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR805_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R805.block = ffestw_use (ffestw_stack_top ());
}
-/* 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. */
+/* END IF statement. */
void
-ffestd_R525_item (ffelexToken name, ffesttDimList dims)
+ffestd_R806 (bool ok UNUSED)
{
- ffestd_check_item_ ();
+ ffestdStmt_ stmt;
- return; /* F90. */
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR806_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R806.block = ffestw_use (ffestw_stack_top ());
-#ifdef FFESTD_F90
- fputs (ffelex_token_text (name), dmpout);
- if (dims != NULL)
- {
- fputc ('(', dmpout);
- ffestt_dimlist_dump (dims);
- fputc (')', dmpout);
- }
- fputc (',', dmpout);
-#endif
+ --ffestd_block_level_;
+ assert (ffestd_block_level_ >= 0);
}
-/* ffestd_R525_finish -- ALLOCATABLE statement list complete
+/* ffestd_R807 -- Logical IF statement
- ffestd_R525_finish();
+ ffestd_R807(expr,expr_token);
- Just wrap up any local activities. */
+ Make sure statement is valid here; implement. */
void
-ffestd_R525_finish ()
+ffestd_R807 (ffebld expr)
{
- ffestd_check_finish_ ();
+ ffestdStmt_ stmt;
- return; /* F90. */
+ ffestd_check_simple_ ();
-#ifdef FFESTD_F90
- fputc ('\n', dmpout);
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR807_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R807.pool = ffesta_output_pool;
+ stmt->u.R807.expr = expr;
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
+
+ ++ffestd_block_level_;
+ assert (ffestd_block_level_ > 0);
}
-/* ffestd_R526_start -- POINTER statement list begin
+/* ffestd_R809 -- SELECT CASE statement
- ffestd_R526_start();
+ ffestd_R809(construct_name,expr,expr_token);
- Verify that POINTER is valid here, and begin accepting items in the
- list. */
+ Make sure statement is valid here; implement. */
void
-ffestd_R526_start ()
+ffestd_R809 (ffelexToken construct_name UNUSED, ffebld expr)
{
- ffestd_check_start_ ();
+ ffestdStmt_ stmt;
- ffestd_subr_f90_ ();
- return;
+ ffestd_check_simple_ ();
-#ifdef FFESTD_F90
- fputs ("* POINTER ", dmpout);
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR809_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R809.pool = ffesta_output_pool;
+ stmt->u.R809.block = ffestw_use (ffestw_stack_top ());
+ stmt->u.R809.expr = expr;
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
+ malloc_pool_use (ffestw_select (ffestw_stack_top ())->pool);
+
+ ++ffestd_block_level_;
+ assert (ffestd_block_level_ > 0);
}
-/* ffestd_R526_item -- POINTER statement for object-name
+/* ffestd_R810 -- CASE statement
- ffestd_R526_item(name_token,dim_list);
+ ffestd_R810(case_value_range_list,name);
- Make sure name_token identifies a valid object to be POINTERd. */
+ 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_R526_item (ffelexToken name, ffesttDimList dims)
+ffestd_R810 (unsigned long casenum)
{
- ffestd_check_item_ ();
+ ffestdStmt_ stmt;
- return; /* F90. */
+ ffestd_check_simple_ ();
-#ifdef FFESTD_F90
- fputs (ffelex_token_text (name), dmpout);
- if (dims != NULL)
- {
- fputc ('(', dmpout);
- ffestt_dimlist_dump (dims);
- fputc (')', dmpout);
- }
- fputc (',', dmpout);
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR810_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R810.pool = ffesta_output_pool;
+ stmt->u.R810.block = ffestw_stack_top ();
+ stmt->u.R810.casenum = casenum;
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
}
-/* ffestd_R526_finish -- POINTER statement list complete
-
- ffestd_R526_finish();
+/* ffestd_R811 -- End a SELECT
- Just wrap up any local activities. */
+ ffestd_R811(TRUE); */
void
-ffestd_R526_finish ()
+ffestd_R811 (bool ok UNUSED)
{
- ffestd_check_finish_ ();
+ ffestdStmt_ stmt;
- return; /* F90. */
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR811_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R811.block = ffestw_stack_top ();
-#ifdef FFESTD_F90
- fputc ('\n', dmpout);
-#endif
+ --ffestd_block_level_;
+ assert (ffestd_block_level_ >= 0);
}
-/* ffestd_R527_start -- TARGET statement list begin
+/* ffestd_R819A -- Iterative DO statement
- ffestd_R527_start();
+ ffestd_R819A(construct_name,label_token,expr,expr_token);
- Verify that TARGET is valid here, and begin accepting items in the
- list. */
+ Make sure statement is valid here; implement. */
void
-ffestd_R527_start ()
+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_start_ ();
+ ffestdStmt_ stmt;
- ffestd_subr_f90_ ();
- return;
+ ffestd_check_simple_ ();
-#ifdef FFESTD_F90
- fputs ("* TARGET ", dmpout);
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR819A_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R819A.pool = ffesta_output_pool;
+ stmt->u.R819A.block = ffestw_use (ffestw_stack_top ());
+ stmt->u.R819A.label = label;
+ stmt->u.R819A.var = var;
+ stmt->u.R819A.start = start;
+ stmt->u.R819A.start_token = ffelex_token_use (start_token);
+ stmt->u.R819A.end = end;
+ stmt->u.R819A.end_token = ffelex_token_use (end_token);
+ stmt->u.R819A.incr = incr;
+ stmt->u.R819A.incr_token = (incr_token == NULL) ? NULL
+ : ffelex_token_use (incr_token);
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
+
+ ++ffestd_block_level_;
+ assert (ffestd_block_level_ > 0);
}
-/* ffestd_R527_item -- TARGET statement for object-name
+/* ffestd_R819B -- DO WHILE statement
- ffestd_R527_item(name_token,dim_list);
+ ffestd_R819B(construct_name,label_token,expr,expr_token);
- Make sure name_token identifies a valid object to be TARGETd. */
+ Make sure statement is valid here; implement. */
void
-ffestd_R527_item (ffelexToken name, ffesttDimList dims)
+ffestd_R819B (ffelexToken construct_name UNUSED, ffelab label,
+ ffebld expr)
{
- ffestd_check_item_ ();
+ ffestdStmt_ stmt;
- return; /* F90. */
+ ffestd_check_simple_ ();
-#ifdef FFESTD_F90
- fputs (ffelex_token_text (name), dmpout);
- if (dims != NULL)
- {
- fputc ('(', dmpout);
- ffestt_dimlist_dump (dims);
- fputc (')', dmpout);
- }
- fputc (',', dmpout);
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR819B_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R819B.pool = ffesta_output_pool;
+ stmt->u.R819B.block = ffestw_use (ffestw_stack_top ());
+ stmt->u.R819B.label = label;
+ stmt->u.R819B.expr = expr;
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
+
+ ++ffestd_block_level_;
+ assert (ffestd_block_level_ > 0);
}
-/* ffestd_R527_finish -- TARGET statement list complete
+/* ffestd_R825 -- END DO statement
- ffestd_R527_finish();
+ ffestd_R825(name_token);
- Just wrap up any local activities. */
+ 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_R527_finish ()
+ffestd_R825 (ffelexToken name UNUSED)
{
- ffestd_check_finish_ ();
+ ffestdStmt_ stmt;
- return; /* F90. */
+ ffestd_check_simple_ ();
-#ifdef FFESTD_F90
- fputc ('\n', dmpout);
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR825_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
}
-#endif
-/* ffestd_R537_start -- PARAMETER statement list begin
+/* ffestd_R834 -- CYCLE statement
- ffestd_R537_start();
+ ffestd_R834(name_token);
- Verify that PARAMETER is valid here, and begin accepting items in the list. */
+ Handle a CYCLE within a loop. */
void
-ffestd_R537_start ()
+ffestd_R834 (ffestw block)
{
- ffestd_check_start_ ();
+ ffestdStmt_ stmt;
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("* PARAMETER (", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
+ ffestd_check_simple_ ();
+
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR834_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R834.block = block;
}
-/* ffestd_R537_item -- PARAMETER statement assignment
+/* ffestd_R835 -- EXIT statement
- ffestd_R537_item(dest,dest_token,source,source_token);
+ ffestd_R835(name_token);
- Make sure the source is a valid source for the destination; make the
- assignment. */
+ Handle a EXIT within a loop. */
void
-ffestd_R537_item (ffebld dest UNUSED, ffebld source UNUSED)
+ffestd_R835 (ffestw block)
{
- ffestd_check_item_ ();
+ ffestdStmt_ stmt;
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- ffebld_dump (dest);
- fputc ('=', dmpout);
- ffebld_dump (source);
- fputc (',', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
+ ffestd_check_simple_ ();
+
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR835_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R835.block = block;
}
-/* ffestd_R537_finish -- PARAMETER statement list complete
+/* ffestd_R836 -- GOTO statement
- ffestd_R537_finish();
+ ffestd_R836(label);
- Just wrap up any local activities. */
+ 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_R537_finish ()
+ffestd_R836 (ffelab label)
{
- ffestd_check_finish_ ();
+ ffestdStmt_ stmt;
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs (")\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
+ ffestd_check_simple_ ();
+
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR836_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R836.label = label;
+
+ if (ffestd_block_level_ == 0)
+ ffestd_is_reachable_ = FALSE;
}
-/* ffestd_R539 -- IMPLICIT NONE statement
+/* ffestd_R837 -- Computed GOTO statement
- ffestd_R539();
+ ffestd_R837(labels,expr);
- Verify that the IMPLICIT NONE statement is ok here and implement. */
+ 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_R539 ()
+ffestd_R837 (ffelab *labels, int count, ffebld expr)
{
+ ffestdStmt_ stmt;
+
ffestd_check_simple_ ();
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("* IMPLICIT_NONE\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR837_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R837.pool = ffesta_output_pool;
+ stmt->u.R837.labels = labels;
+ stmt->u.R837.count = count;
+ stmt->u.R837.expr = expr;
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
}
-/* ffestd_R539start -- IMPLICIT statement
+/* ffestd_R838 -- ASSIGN statement
- ffestd_R539start();
+ ffestd_R838(label_token,target_variable,target_token);
- Verify that the IMPLICIT statement is ok here and implement. */
+ 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_R539start ()
+ffestd_R838 (ffelab label, ffebld target)
{
- ffestd_check_start_ ();
+ ffestdStmt_ stmt;
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("* IMPLICIT ", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
+ ffestd_check_simple_ ();
+
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR838_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R838.pool = ffesta_output_pool;
+ stmt->u.R838.label = label;
+ stmt->u.R838.target = target;
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
}
-/* ffestd_R539item -- IMPLICIT statement specification (R540)
+/* ffestd_R839 -- Assigned GOTO statement
- ffestd_R539item(...);
+ ffestd_R839(target,labels);
- Verify that the type and letter list are all ok and implement. */
+ 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_R539item (ffestpType type UNUSED, ffebld kind UNUSED,
- ffelexToken kindt UNUSED, ffebld len UNUSED,
- ffelexToken lent UNUSED, ffesttImpList letters UNUSED)
+ffestd_R839 (ffebld target, ffelab *labels UNUSED, int count UNUSED)
{
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- char *a;
-#endif
+ ffestdStmt_ stmt;
- ffestd_check_item_ ();
+ ffestd_check_simple_ ();
-#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
+ 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);
- 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
+ if (ffestd_block_level_ == 0)
+ ffestd_is_reachable_ = FALSE;
}
-/* ffestd_R539finish -- IMPLICIT statement
+/* ffestd_R840 -- Arithmetic IF statement
- ffestd_R539finish();
+ ffestd_R840(expr,expr_token,neg,zero,pos);
- Finish up any local activities. */
+ Make sure the labels are valid; implement. */
void
-ffestd_R539finish ()
+ffestd_R840 (ffebld expr, ffelab neg, ffelab zero, ffelab pos)
{
- ffestd_check_finish_ ();
+ ffestdStmt_ stmt;
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputc ('\n', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
-}
+ ffestd_check_simple_ ();
-/* ffestd_R542_start -- NAMELIST statement list begin
+ 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);
- ffestd_R542_start();
+ if (ffestd_block_level_ == 0)
+ ffestd_is_reachable_ = FALSE;
+}
- Verify that NAMELIST is valid here, and begin accepting items in the list. */
+/* ffestd_R841 -- CONTINUE statement
+
+ ffestd_R841(); */
void
-ffestd_R542_start ()
+ffestd_R841 (bool in_where UNUSED)
{
- ffestd_check_start_ ();
+ ffestdStmt_ stmt;
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("* NAMELIST ", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
-}
+ ffestd_check_simple_ ();
-/* ffestd_R542_item_nlist -- NAMELIST statement for group-name
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR841_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+}
- ffestd_R542_item_nlist(groupname_token);
+/* ffestd_R842 -- STOP statement
- Make sure name_token identifies a valid object to be NAMELISTd. */
+ ffestd_R842(expr); */
void
-ffestd_R542_item_nlist (ffelexToken name UNUSED)
+ffestd_R842 (ffebld expr)
{
- ffestd_check_item_ ();
+ ffestdStmt_ stmt;
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fprintf (dmpout, "/%s/", ffelex_token_text (name));
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
+ ffestd_check_simple_ ();
+
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR842_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ if (ffesta_outpooldisp () == FFESTA_pooldispPRESERVE)
+ {
+ /* This is a "spurious" (automatically-generated) STOP
+ that follows a previous STOP or other statement.
+ Make sure we don't have an expression in the pool,
+ and then mark that the pool has already been killed. */
+ assert (expr == NULL);
+ stmt->u.R842.pool = NULL;
+ stmt->u.R842.expr = NULL;
+ }
+ else
+ {
+ stmt->u.R842.pool = ffesta_output_pool;
+ stmt->u.R842.expr = expr;
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
+ }
+
+ if (ffestd_block_level_ == 0)
+ ffestd_is_reachable_ = FALSE;
}
-/* ffestd_R542_item_nitem -- NAMELIST statement for variable-name
+/* ffestd_R843 -- PAUSE statement
- ffestd_R542_item_nitem(name_token);
+ ffestd_R843(expr,expr_token);
- Make sure name_token identifies a valid object to be NAMELISTd. */
+ Make sure statement is valid here; implement. expr and expr_token are
+ both NULL if there was no expression. */
void
-ffestd_R542_item_nitem (ffelexToken name UNUSED)
+ffestd_R843 (ffebld expr)
{
- ffestd_check_item_ ();
+ ffestdStmt_ stmt;
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fprintf (dmpout, "%s,", ffelex_token_text (name));
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
+ ffestd_check_simple_ ();
+
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR843_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R843.pool = ffesta_output_pool;
+ stmt->u.R843.expr = expr;
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
}
-/* ffestd_R542_finish -- NAMELIST statement list complete
+/* ffestd_R904 -- OPEN statement
- ffestd_R542_finish();
+ ffestd_R904();
- Just wrap up any local activities. */
+ Make sure an OPEN is valid in the current context, and implement it. */
void
-ffestd_R542_finish ()
+ffestd_R904 ()
{
- ffestd_check_finish_ ();
+ ffestdStmt_ stmt;
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputc ('\n', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
-}
+ ffestd_check_simple_ ();
-/* ffestd_R544_start -- EQUIVALENCE statement list begin
+#define specified(something) \
+ (ffestp_file.open.open_spec[something].kw_or_val_present)
- ffestd_R544_start();
+ /* Warn if there are any thing we don't handle via f2c libraries. */
- Verify that EQUIVALENCE is valid here, and begin accepting items in the
- list. */
+ 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 ();
+ }
-#if 0
-void
-ffestd_R544_start ()
-{
- ffestd_check_start_ ();
+#undef specified
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("* EQUIVALENCE (", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
+ 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_R544_item -- EQUIVALENCE statement assignment
+/* ffestd_R907 -- CLOSE statement
- ffestd_R544_item(exprlist);
+ ffestd_R907();
- Make sure the equivalence is valid, then implement it. */
+ Make sure a CLOSE is valid in the current context, and implement it. */
-#if 0
void
-ffestd_R544_item (ffesttExprList exprlist)
+ffestd_R907 ()
{
- ffestd_check_item_ ();
+ ffestdStmt_ stmt;
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- ffestt_exprlist_dump (exprlist);
- fputs ("),", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
+ ffestd_check_simple_ ();
+
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR907_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R907.pool = ffesta_output_pool;
+ stmt->u.R907.params = ffestd_subr_copy_close_ ();
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
}
-#endif
-/* ffestd_R544_finish -- EQUIVALENCE statement list complete
+/* ffestd_R909_start -- READ(...) statement list begin
- ffestd_R544_finish();
+ ffestd_R909_start(FALSE);
- Just wrap up any local activities. */
+ Verify that READ is valid here, and begin accepting items in the
+ list. */
-#if 0
void
-ffestd_R544_finish ()
+ffestd_R909_start (bool only_format, ffestvUnit unit,
+ ffestvFormat format, bool rec, bool key)
{
- ffestd_check_finish_ ();
+ ffestdStmt_ stmt;
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs (")\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
+ ffestd_check_start_ ();
+
+#define specified(something) \
+ (ffestp_file.read.read_spec[something].kw_or_val_present)
+
+ /* Warn if there are any thing we don't handle via f2c libraries. */
+ if (specified (FFESTP_readixADVANCE)
+ || specified (FFESTP_readixEOR)
+ || specified (FFESTP_readixKEYEQ)
+ || specified (FFESTP_readixKEYGE)
+ || specified (FFESTP_readixKEYGT)
+ || specified (FFESTP_readixKEYID)
+ || specified (FFESTP_readixNULLS)
+ || specified (FFESTP_readixSIZE))
+ {
+ ffebad_start (FFEBAD_READ_UNSUPPORTED);
+ ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
+ ffelex_token_where_column (ffesta_tokens[0]));
+ ffebad_finish ();
+ }
+
+#undef specified
+
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR909_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R909.pool = ffesta_output_pool;
+ stmt->u.R909.params = ffestd_subr_copy_read_ ();
+ stmt->u.R909.only_format = only_format;
+ stmt->u.R909.unit = unit;
+ stmt->u.R909.format = format;
+ stmt->u.R909.rec = rec;
+ stmt->u.R909.key = key;
+ stmt->u.R909.list = NULL;
+ ffestd_expr_list_ = &stmt->u.R909.list;
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
}
-#endif
-/* ffestd_R547_start -- COMMON statement list begin
+/* ffestd_R909_item -- READ statement i/o item
- ffestd_R547_start();
+ ffestd_R909_item(expr,expr_token);
- Verify that COMMON is valid here, and begin accepting items in the list. */
+ Implement output-list expression. */
void
-ffestd_R547_start ()
+ffestd_R909_item (ffebld expr, ffelexToken expr_token)
{
- ffestd_check_start_ ();
+ ffestdExprItem_ item;
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("* COMMON ", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
+ ffestd_check_item_ ();
+
+ 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;
}
-/* ffestd_R547_item_object -- COMMON statement for object-name
+/* ffestd_R909_finish -- READ statement list complete
- ffestd_R547_item_object(name_token,dim_list);
+ ffestd_R909_finish();
- Make sure name_token identifies a valid object to be COMMONd. */
+ Just wrap up any local activities. */
void
-ffestd_R547_item_object (ffelexToken name UNUSED,
- ffesttDimList dims UNUSED)
+ffestd_R909_finish ()
{
- ffestd_check_item_ ();
+ ffestd_check_finish_ ();
+}
+
+/* ffestd_R910_start -- WRITE(...) statement list begin
+
+ ffestd_R910_start();
+
+ Verify that WRITE is valid here, and begin accepting items in the
+ list. */
+
+void
+ffestd_R910_start (ffestvUnit unit, ffestvFormat format, bool rec)
+{
+ ffestdStmt_ stmt;
+
+ ffestd_check_start_ ();
+
+#define specified(something) \
+ (ffestp_file.write.write_spec[something].kw_or_val_present)
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs (ffelex_token_text (name), dmpout);
- if (dims != NULL)
+ /* Warn if there are any thing we don't handle via f2c libraries. */
+ if (specified (FFESTP_writeixADVANCE)
+ || specified (FFESTP_writeixEOR))
{
- fputc ('(', dmpout);
- ffestt_dimlist_dump (dims);
- fputc (')', dmpout);
+ ffebad_start (FFEBAD_WRITE_UNSUPPORTED);
+ ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
+ ffelex_token_where_column (ffesta_tokens[0]));
+ ffebad_finish ();
}
- fputc (',', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
+
+#undef specified
+
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR910_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R910.pool = ffesta_output_pool;
+ stmt->u.R910.params = ffestd_subr_copy_write_ ();
+ stmt->u.R910.unit = unit;
+ stmt->u.R910.format = format;
+ stmt->u.R910.rec = rec;
+ stmt->u.R910.list = NULL;
+ ffestd_expr_list_ = &stmt->u.R910.list;
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
}
-/* ffestd_R547_item_cblock -- COMMON statement for common-block-name
+/* ffestd_R910_item -- WRITE statement i/o item
- ffestd_R547_item_cblock(name_token);
+ ffestd_R910_item(expr,expr_token);
- Make sure name_token identifies a valid common block to be COMMONd. */
+ Implement output-list expression. */
void
-ffestd_R547_item_cblock (ffelexToken name UNUSED)
+ffestd_R910_item (ffebld expr, ffelexToken expr_token)
{
+ ffestdExprItem_ item;
+
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
+ 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;
}
-/* ffestd_R547_finish -- COMMON statement list complete
+/* ffestd_R910_finish -- WRITE statement list complete
- ffestd_R547_finish();
+ ffestd_R910_finish();
Just wrap up any local activities. */
void
-ffestd_R547_finish ()
+ffestd_R910_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_R911_start -- PRINT statement list begin
- ffestd_R620(exprlist,stat,stat_token);
+ ffestd_R911_start();
- Make sure the expression list is valid, then implement it. */
+ Verify that PRINT is valid here, and begin accepting items in the
+ list. */
-#if FFESTR_F90
void
-ffestd_R620 (ffesttExprList exprlist, ffebld stat)
+ffestd_R911_start (ffestvFormat format)
{
- ffestd_check_simple_ ();
+ ffestdStmt_ stmt;
- ffestd_subr_f90_ ();
- return;
+ ffestd_check_start_ ();
-#ifdef FFESTD_F90
- fputs ("+ ALLOCATE (", dmpout);
- ffestt_exprlist_dump (exprlist);
- if (stat != NULL)
- {
- fputs (",stat=", dmpout);
- ffebld_dump (stat);
- }
- fputs (")\n", dmpout);
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR911_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R911.pool = ffesta_output_pool;
+ stmt->u.R911.params = ffestd_subr_copy_print_ ();
+ stmt->u.R911.format = format;
+ stmt->u.R911.list = NULL;
+ ffestd_expr_list_ = &stmt->u.R911.list;
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
}
-/* ffestd_R624 -- NULLIFY statement
+/* ffestd_R911_item -- PRINT statement i/o item
- ffestd_R624(pointer_name_list);
+ ffestd_R911_item(expr,expr_token);
- Make sure pointer_name_list identifies valid pointers for a NULLIFY. */
+ Implement output-list expression. */
void
-ffestd_R624 (ffesttExprList pointers)
+ffestd_R911_item (ffebld expr, ffelexToken expr_token)
{
- ffestd_check_simple_ ();
+ ffestdExprItem_ item;
+
+ ffestd_check_item_ ();
- ffestd_subr_f90_ ();
- return;
+ item = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool,
+ "ffestdExprItem_", sizeof (*item));
-#ifdef FFESTD_F90
- fputs ("+ NULLIFY (", dmpout);
- assert (pointers != NULL);
- ffestt_exprlist_dump (pointers);
- fputs (")\n", dmpout);
-#endif
+ item->next = NULL;
+ item->expr = expr;
+ item->token = ffelex_token_use (expr_token);
+ *ffestd_expr_list_ = item;
+ ffestd_expr_list_ = &item->next;
}
-/* ffestd_R625 -- DEALLOCATE statement
+/* ffestd_R911_finish -- PRINT statement list complete
- ffestd_R625(exprlist,stat,stat_token);
+ ffestd_R911_finish();
- Make sure the equivalence is valid, then implement it. */
+ Just wrap up any local activities. */
void
-ffestd_R625 (ffesttExprList exprlist, ffebld stat)
+ffestd_R911_finish ()
{
- 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
+ ffestd_check_finish_ ();
}
-#endif
-/* ffestd_R737A -- Assignment statement outside of WHERE
+/* ffestd_R919 -- BACKSPACE statement
- ffestd_R737A(dest_expr,source_expr); */
+ ffestd_R919();
+
+ Make sure a BACKSPACE is valid in the current context, and implement it. */
void
-ffestd_R737A (ffebld dest, ffebld source)
+ffestd_R919 ()
{
+ ffestdStmt_ stmt;
+
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
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR919_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R919.pool = ffesta_output_pool;
+ stmt->u.R919.params = ffestd_subr_copy_beru_ ();
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
}
-/* ffestd_R737B -- Assignment statement inside of WHERE
+/* ffestd_R920 -- ENDFILE statement
+
+ ffestd_R920();
- ffestd_R737B(dest_expr,source_expr); */
+ Make sure a ENDFILE is valid in the current context, and implement it. */
-#if FFESTR_F90
void
-ffestd_R737B (ffebld dest, ffebld source)
+ffestd_R920 ()
{
- ffestd_check_simple_ ();
+ ffestdStmt_ stmt;
- return; /* F90. */
+ ffestd_check_simple_ ();
-#ifdef FFESTD_F90
- fputs ("+ let_inside_where ", dmpout);
- ffebld_dump (dest);
- fputs ("=", dmpout);
- ffebld_dump (source);
- fputc ('\n', dmpout);
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR920_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R920.pool = ffesta_output_pool;
+ stmt->u.R920.params = ffestd_subr_copy_beru_ ();
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
}
-/* ffestd_R738 -- Pointer assignment statement
+/* ffestd_R921 -- REWIND statement
- ffestd_R738(dest_expr,source_expr,source_token);
+ ffestd_R921();
- Make sure the assignment is valid. */
+ Make sure a REWIND is valid in the current context, and implement it. */
void
-ffestd_R738 (ffebld dest, ffebld source)
+ffestd_R921 ()
{
- ffestd_check_simple_ ();
+ ffestdStmt_ stmt;
- ffestd_subr_f90_ ();
- return;
+ ffestd_check_simple_ ();
-#ifdef FFESTD_F90
- fputs ("+ let_pointer ", dmpout);
- ffebld_dump (dest);
- fputs ("=>", dmpout);
- ffebld_dump (source);
- fputc ('\n', dmpout);
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR921_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R921.pool = ffesta_output_pool;
+ stmt->u.R921.params = ffestd_subr_copy_beru_ ();
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
}
-/* ffestd_R740 -- WHERE statement
+/* ffestd_R923A -- INQUIRE statement (non-IOLENGTH version)
- ffestd_R740(expr,expr_token);
+ ffestd_R923A(bool by_file);
- Make sure statement is valid here; implement. */
+ Make sure an INQUIRE is valid in the current context, and implement it. */
void
-ffestd_R740 (ffebld expr)
+ffestd_R923A (bool by_file)
{
+ ffestdStmt_ stmt;
+
ffestd_check_simple_ ();
- ffestd_subr_f90_ ();
- return;
+#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 ();
+ }
-#ifdef FFESTD_F90
- fputs ("+ WHERE (", dmpout);
- ffebld_dump (expr);
- fputs (")\n", dmpout);
+#undef specified
- ++ffestd_block_level_;
- assert (ffestd_block_level_ > 0);
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR923A_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R923A.pool = ffesta_output_pool;
+ stmt->u.R923A.params = ffestd_subr_copy_inquire_ ();
+ stmt->u.R923A.by_file = by_file;
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
}
-/* ffestd_R742 -- WHERE-construct statement
+/* ffestd_R923B_start -- INQUIRE(IOLENGTH=expr) statement list begin
- ffestd_R742(expr,expr_token);
+ ffestd_R923B_start();
- Make sure statement is valid here; implement. */
+ Verify that INQUIRE is valid here, and begin accepting items in the
+ list. */
void
-ffestd_R742 (ffebld expr)
+ffestd_R923B_start ()
{
- ffestd_check_simple_ ();
-
- ffestd_subr_f90_ ();
- return;
+ ffestdStmt_ stmt;
-#ifdef FFESTD_F90
- fputs ("+ WHERE_construct (", dmpout);
- ffebld_dump (expr);
- fputs (")\n", dmpout);
+ ffestd_check_start_ ();
- ++ffestd_block_level_;
- assert (ffestd_block_level_ > 0);
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR923B_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R923B.pool = ffesta_output_pool;
+ stmt->u.R923B.params = ffestd_subr_copy_inquire_ ();
+ stmt->u.R923B.list = NULL;
+ ffestd_expr_list_ = &stmt->u.R923B.list;
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
}
-/* ffestd_R744 -- ELSE WHERE statement
+/* ffestd_R923B_item -- INQUIRE statement i/o item
- ffestd_R744();
+ ffestd_R923B_item(expr,expr_token);
- Make sure ffestd_kind_ identifies a WHERE block.
- Implement the ELSE of the current WHERE block. */
+ Implement output-list expression. */
void
-ffestd_R744 ()
+ffestd_R923B_item (ffebld expr)
{
- ffestd_check_simple_ ();
+ ffestdExprItem_ item;
- return; /* F90. */
+ ffestd_check_item_ ();
-#ifdef FFESTD_F90
- fputs ("+ ELSE_WHERE\n", dmpout);
-#endif
+ 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;
}
-/* ffestd_R745 -- Implicit END WHERE statement. */
+/* ffestd_R923B_finish -- INQUIRE statement list complete
-void
-ffestd_R745 (bool ok)
-{
- return; /* F90. */
+ ffestd_R923B_finish();
-#ifdef FFESTD_F90
- fputs ("+ END_WHERE\n", dmpout); /* Also see ffestd_R745. */
+ Just wrap up any local activities. */
- --ffestd_block_level_;
- assert (ffestd_block_level_ >= 0);
-#endif
+void
+ffestd_R923B_finish ()
+{
+ ffestd_check_finish_ ();
}
-#endif
+/* ffestd_R1001 -- FORMAT statement
-/* Block IF (IF-THEN) statement. */
+ ffestd_R1001(format_list); */
void
-ffestd_R803 (ffelexToken construct_name UNUSED, ffebld expr)
+ffestd_R1001 (ffesttFormatList f)
{
+ ffestsHolder str;
+ ffests s = &str;
+ ffestdStmt_ stmt;
+
ffestd_check_simple_ ();
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R803 (expr); /* Don't bother with name. */
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR803_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R803.pool = ffesta_output_pool;
- stmt->u.R803.block = ffestw_use (ffestw_stack_top ());
- stmt->u.R803.expr = expr;
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
-
- ++ffestd_block_level_;
- assert (ffestd_block_level_ > 0);
-}
-
-/* ELSE IF statement. */
-
-void
-ffestd_R804 (ffebld expr, ffelexToken name UNUSED)
-{
- ffestd_check_simple_ ();
-
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R804 (expr); /* Don't bother with name. */
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR804_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R804.pool = ffesta_output_pool;
- stmt->u.R804.block = ffestw_use (ffestw_stack_top ());
- stmt->u.R804.expr = expr;
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
-}
-
-/* ELSE statement. */
-
-void
-ffestd_R805 (ffelexToken name UNUSED)
-{
- ffestd_check_simple_ ();
-
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R805 (); /* Don't bother with name. */
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR805_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R805.block = ffestw_use (ffestw_stack_top ());
- }
-#endif
-}
-
-/* END IF statement. */
-
-void
-ffestd_R806 (bool ok UNUSED)
-{
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R806 ();
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR806_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R806.block = ffestw_use (ffestw_stack_top ());
- }
-#endif
-
- --ffestd_block_level_;
- assert (ffestd_block_level_ >= 0);
-}
-
-/* ffestd_R807 -- Logical IF statement
-
- ffestd_R807(expr,expr_token);
-
- Make sure statement is valid here; implement. */
-
-void
-ffestd_R807 (ffebld expr)
-{
- ffestd_check_simple_ ();
-
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R807 (expr);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR807_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R807.pool = ffesta_output_pool;
- stmt->u.R807.expr = expr;
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
-
- ++ffestd_block_level_;
- assert (ffestd_block_level_ > 0);
-}
-
-/* ffestd_R809 -- SELECT CASE statement
-
- ffestd_R809(construct_name,expr,expr_token);
-
- Make sure statement is valid here; implement. */
-
-void
-ffestd_R809 (ffelexToken construct_name UNUSED, ffebld expr)
-{
- ffestd_check_simple_ ();
-
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R809 (ffestw_stack_top (), expr);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR809_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R809.pool = ffesta_output_pool;
- stmt->u.R809.block = ffestw_use (ffestw_stack_top ());
- stmt->u.R809.expr = expr;
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- malloc_pool_use (ffestw_select (ffestw_stack_top ())->pool);
- }
-#endif
-
- ++ffestd_block_level_;
- assert (ffestd_block_level_ > 0);
-}
-
-/* ffestd_R810 -- CASE statement
-
- ffestd_R810(case_value_range_list,name);
-
- If casenum is 0, it's CASE DEFAULT. Else it's the case ranges at
- the start of the first_stmt list in the select object at the top of
- the stack that match casenum. */
-
-void
-ffestd_R810 (unsigned long casenum)
-{
- ffestd_check_simple_ ();
-
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R810 (ffestw_stack_top (), casenum);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR810_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R810.pool = ffesta_output_pool;
- stmt->u.R810.block = ffestw_stack_top ();
- stmt->u.R810.casenum = casenum;
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
-}
-
-/* ffestd_R811 -- End a SELECT
-
- ffestd_R811(TRUE); */
-
-void
-ffestd_R811 (bool ok UNUSED)
-{
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R811 (ffestw_stack_top ());
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR811_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R811.block = ffestw_stack_top ();
- }
-#endif
-
- --ffestd_block_level_;
- assert (ffestd_block_level_ >= 0);
-}
-
-/* ffestd_R819A -- Iterative DO statement
-
- ffestd_R819A(construct_name,label_token,expr,expr_token);
-
- Make sure statement is valid here; implement. */
-
-void
-ffestd_R819A (ffelexToken construct_name UNUSED, ffelab label,
- ffebld var, ffebld start, ffelexToken start_token,
- ffebld end, ffelexToken end_token,
- ffebld incr, ffelexToken incr_token)
-{
- ffestd_check_simple_ ();
-
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R819A (ffestw_stack_top (), label, var, start, end, incr,
- incr_token);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR819A_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R819A.pool = ffesta_output_pool;
- stmt->u.R819A.block = ffestw_use (ffestw_stack_top ());
- stmt->u.R819A.label = label;
- stmt->u.R819A.var = var;
- stmt->u.R819A.start = start;
- stmt->u.R819A.start_token = ffelex_token_use (start_token);
- stmt->u.R819A.end = end;
- stmt->u.R819A.end_token = ffelex_token_use (end_token);
- stmt->u.R819A.incr = incr;
- stmt->u.R819A.incr_token = (incr_token == NULL) ? NULL
- : ffelex_token_use (incr_token);
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
-
- ++ffestd_block_level_;
- assert (ffestd_block_level_ > 0);
-}
-
-/* ffestd_R819B -- DO WHILE statement
-
- ffestd_R819B(construct_name,label_token,expr,expr_token);
-
- Make sure statement is valid here; implement. */
-
-void
-ffestd_R819B (ffelexToken construct_name UNUSED, ffelab label,
- ffebld expr)
-{
- ffestd_check_simple_ ();
-
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R819B (ffestw_stack_top (), label, expr);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR819B_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R819B.pool = ffesta_output_pool;
- stmt->u.R819B.block = ffestw_use (ffestw_stack_top ());
- stmt->u.R819B.label = label;
- stmt->u.R819B.expr = expr;
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
-
- ++ffestd_block_level_;
- assert (ffestd_block_level_ > 0);
-}
-
-/* ffestd_R825 -- END DO statement
-
- ffestd_R825(name_token);
-
- Make sure ffestd_kind_ identifies a DO block. If not
- NULL, make sure name_token gives the correct name. Do whatever
- is specific to seeing END DO with a DO-target label definition on it,
- where the END DO is really treated as a CONTINUE (i.e. generate th
- same code you would for CONTINUE). ffestd_do handles the actual
- generation of end-loop code. */
-
-void
-ffestd_R825 (ffelexToken name UNUSED)
-{
- ffestd_check_simple_ ();
-
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R825 ();
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR825_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- }
-#endif
-}
-
-/* ffestd_R834 -- CYCLE statement
-
- ffestd_R834(name_token);
-
- Handle a CYCLE within a loop. */
-
-void
-ffestd_R834 (ffestw block)
-{
- ffestd_check_simple_ ();
-
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R834 (block);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR834_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R834.block = block;
- }
-#endif
-}
-
-/* ffestd_R835 -- EXIT statement
-
- ffestd_R835(name_token);
-
- Handle a EXIT within a loop. */
-
-void
-ffestd_R835 (ffestw block)
-{
- ffestd_check_simple_ ();
-
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R835 (block);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR835_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R835.block = block;
- }
-#endif
-}
-
-/* ffestd_R836 -- GOTO statement
-
- ffestd_R836(label);
-
- Make sure label_token identifies a valid label for a GOTO. Update
- that label's info to indicate it is the target of a GOTO. */
-
-void
-ffestd_R836 (ffelab label)
-{
- ffestd_check_simple_ ();
-
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R836 (label);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR836_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R836.label = label;
- }
-#endif
-
- if (ffestd_block_level_ == 0)
- ffestd_is_reachable_ = FALSE;
-}
-
-/* ffestd_R837 -- Computed GOTO statement
-
- ffestd_R837(labels,expr);
-
- Make sure label_list identifies valid labels for a GOTO. Update
- each label's info to indicate it is the target of a GOTO. */
-
-void
-ffestd_R837 (ffelab *labels, int count, ffebld expr)
-{
- ffestd_check_simple_ ();
-
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R837 (labels, count, expr);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR837_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R837.pool = ffesta_output_pool;
- stmt->u.R837.labels = labels;
- stmt->u.R837.count = count;
- stmt->u.R837.expr = expr;
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
-}
-
-/* ffestd_R838 -- ASSIGN statement
-
- ffestd_R838(label_token,target_variable,target_token);
-
- Make sure label_token identifies a valid label for an assignment. Update
- that label's info to indicate it is the source of an assignment. Update
- target_variable's info to indicate it is the target the assignment of that
- label. */
-
-void
-ffestd_R838 (ffelab label, ffebld target)
-{
- ffestd_check_simple_ ();
-
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R838 (label, target);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR838_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R838.pool = ffesta_output_pool;
- stmt->u.R838.label = label;
- stmt->u.R838.target = target;
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
-}
-
-/* ffestd_R839 -- Assigned GOTO statement
-
- ffestd_R839(target,labels);
-
- Make sure label_list identifies valid labels for a GOTO. Update
- each label's info to indicate it is the target of a GOTO. */
-
-void
-ffestd_R839 (ffebld target, ffelab *labels UNUSED, int count UNUSED)
-{
- ffestd_check_simple_ ();
-
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R839 (target);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR839_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R839.pool = ffesta_output_pool;
- stmt->u.R839.target = target;
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
-
- if (ffestd_block_level_ == 0)
- ffestd_is_reachable_ = FALSE;
-}
-
-/* ffestd_R840 -- Arithmetic IF statement
-
- ffestd_R840(expr,expr_token,neg,zero,pos);
-
- Make sure the labels are valid; implement. */
-
-void
-ffestd_R840 (ffebld expr, ffelab neg, ffelab zero, ffelab pos)
-{
- ffestd_check_simple_ ();
-
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R840 (expr, neg, zero, pos);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR840_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R840.pool = ffesta_output_pool;
- stmt->u.R840.expr = expr;
- stmt->u.R840.neg = neg;
- stmt->u.R840.zero = zero;
- stmt->u.R840.pos = pos;
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
-
- if (ffestd_block_level_ == 0)
- ffestd_is_reachable_ = FALSE;
-}
-
-/* ffestd_R841 -- CONTINUE statement
-
- ffestd_R841(); */
-
-void
-ffestd_R841 (bool in_where UNUSED)
-{
- ffestd_check_simple_ ();
-
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R841 ();
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR841_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- }
-#endif
-}
-
-/* ffestd_R842 -- STOP statement
-
- ffestd_R842(expr); */
-
-void
-ffestd_R842 (ffebld expr)
-{
- ffestd_check_simple_ ();
-
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R842 (expr);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR842_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- if (ffesta_outpooldisp () == FFESTA_pooldispPRESERVE)
- {
- /* This is a "spurious" (automatically-generated) STOP
- that follows a previous STOP or other statement.
- Make sure we don't have an expression in the pool,
- and then mark that the pool has already been killed. */
- assert (expr == NULL);
- stmt->u.R842.pool = NULL;
- stmt->u.R842.expr = NULL;
- }
- else
- {
- stmt->u.R842.pool = ffesta_output_pool;
- stmt->u.R842.expr = expr;
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
- }
-#endif
-
- if (ffestd_block_level_ == 0)
- ffestd_is_reachable_ = FALSE;
-}
-
-/* ffestd_R843 -- PAUSE statement
-
- ffestd_R843(expr,expr_token);
-
- Make sure statement is valid here; implement. expr and expr_token are
- both NULL if there was no expression. */
-
-void
-ffestd_R843 (ffebld expr)
-{
- ffestd_check_simple_ ();
-
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R843 (expr);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR843_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R843.pool = ffesta_output_pool;
- stmt->u.R843.expr = expr;
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
-}
-
-/* ffestd_R904 -- OPEN statement
-
- ffestd_R904();
-
- Make sure an OPEN is valid in the current context, and implement it. */
-
-void
-ffestd_R904 ()
-{
- ffestd_check_simple_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-#define specified(something) \
- (ffestp_file.open.open_spec[something].kw_or_val_present)
-
- /* Warn if there are any thing we don't handle via f2c libraries. */
-
- if (specified (FFESTP_openixACTION)
- || specified (FFESTP_openixASSOCIATEVARIABLE)
- || specified (FFESTP_openixBLOCKSIZE)
- || specified (FFESTP_openixBUFFERCOUNT)
- || specified (FFESTP_openixCARRIAGECONTROL)
- || specified (FFESTP_openixDEFAULTFILE)
- || specified (FFESTP_openixDELIM)
- || specified (FFESTP_openixDISPOSE)
- || specified (FFESTP_openixEXTENDSIZE)
- || specified (FFESTP_openixINITIALSIZE)
- || specified (FFESTP_openixKEY)
- || specified (FFESTP_openixMAXREC)
- || specified (FFESTP_openixNOSPANBLOCKS)
- || specified (FFESTP_openixORGANIZATION)
- || specified (FFESTP_openixPAD)
- || specified (FFESTP_openixPOSITION)
- || specified (FFESTP_openixREADONLY)
- || specified (FFESTP_openixRECORDTYPE)
- || specified (FFESTP_openixSHARED)
- || specified (FFESTP_openixUSEROPEN))
- {
- ffebad_start (FFEBAD_OPEN_UNSUPPORTED);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_finish ();
- }
-
-#undef specified
-#endif
-
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R904 (&ffestp_file.open);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR904_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R904.pool = ffesta_output_pool;
- stmt->u.R904.params = ffestd_subr_copy_open_ ();
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
-}
-
-/* ffestd_R907 -- CLOSE statement
-
- ffestd_R907();
-
- Make sure a CLOSE is valid in the current context, and implement it. */
-
-void
-ffestd_R907 ()
-{
- ffestd_check_simple_ ();
-
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R907 (&ffestp_file.close);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR907_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R907.pool = ffesta_output_pool;
- stmt->u.R907.params = ffestd_subr_copy_close_ ();
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
-}
-
-/* ffestd_R909_start -- READ(...) statement list begin
-
- ffestd_R909_start(FALSE);
-
- Verify that READ is valid here, and begin accepting items in the
- list. */
-
-void
-ffestd_R909_start (bool only_format, ffestvUnit unit,
- ffestvFormat format, bool rec, bool key)
-{
- ffestd_check_start_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-#define specified(something) \
- (ffestp_file.read.read_spec[something].kw_or_val_present)
-
- /* Warn if there are any thing we don't handle via f2c libraries. */
- if (specified (FFESTP_readixADVANCE)
- || specified (FFESTP_readixEOR)
- || specified (FFESTP_readixKEYEQ)
- || specified (FFESTP_readixKEYGE)
- || specified (FFESTP_readixKEYGT)
- || specified (FFESTP_readixKEYID)
- || specified (FFESTP_readixNULLS)
- || specified (FFESTP_readixSIZE))
- {
- ffebad_start (FFEBAD_READ_UNSUPPORTED);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_finish ();
- }
-
-#undef specified
-#endif
-
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R909_start (&ffestp_file.read, only_format, unit, format, rec, key);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR909_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R909.pool = ffesta_output_pool;
- stmt->u.R909.params = ffestd_subr_copy_read_ ();
- stmt->u.R909.only_format = only_format;
- stmt->u.R909.unit = unit;
- stmt->u.R909.format = format;
- stmt->u.R909.rec = rec;
- stmt->u.R909.key = key;
- stmt->u.R909.list = NULL;
- ffestd_expr_list_ = &stmt->u.R909.list;
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
-}
-
-/* ffestd_R909_item -- READ statement i/o item
-
- ffestd_R909_item(expr,expr_token);
-
- Implement output-list expression. */
-
-void
-ffestd_R909_item (ffebld expr, ffelexToken expr_token)
-{
- ffestd_check_item_ ();
-
-#if FFECOM_ONEPASS
- ffeste_R909_item (expr);
-#else
- {
- ffestdExprItem_ item
- = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, "ffestdExprItem_",
- sizeof (*item));
-
- item->next = NULL;
- item->expr = expr;
- item->token = ffelex_token_use (expr_token);
- *ffestd_expr_list_ = item;
- ffestd_expr_list_ = &item->next;
- }
-#endif
-}
-
-/* ffestd_R909_finish -- READ statement list complete
-
- ffestd_R909_finish();
-
- Just wrap up any local activities. */
-
-void
-ffestd_R909_finish ()
-{
- ffestd_check_finish_ ();
-
-#if FFECOM_ONEPASS
- ffeste_R909_finish ();
-#else
- /* Nothing to do, it's implicit. */
-#endif
-}
-
-/* ffestd_R910_start -- WRITE(...) statement list begin
-
- ffestd_R910_start();
-
- Verify that WRITE is valid here, and begin accepting items in the
- list. */
-
-void
-ffestd_R910_start (ffestvUnit unit, ffestvFormat format, bool rec)
-{
- ffestd_check_start_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-#define specified(something) \
- (ffestp_file.write.write_spec[something].kw_or_val_present)
-
- /* Warn if there are any thing we don't handle via f2c libraries. */
- if (specified (FFESTP_writeixADVANCE)
- || specified (FFESTP_writeixEOR))
- {
- ffebad_start (FFEBAD_WRITE_UNSUPPORTED);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_finish ();
- }
-
-#undef specified
-#endif
-
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R910_start (&ffestp_file.write, unit, format, rec);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR910_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R910.pool = ffesta_output_pool;
- stmt->u.R910.params = ffestd_subr_copy_write_ ();
- stmt->u.R910.unit = unit;
- stmt->u.R910.format = format;
- stmt->u.R910.rec = rec;
- stmt->u.R910.list = NULL;
- ffestd_expr_list_ = &stmt->u.R910.list;
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
-}
-
-/* ffestd_R910_item -- WRITE statement i/o item
-
- ffestd_R910_item(expr,expr_token);
-
- Implement output-list expression. */
-
-void
-ffestd_R910_item (ffebld expr, ffelexToken expr_token)
-{
- ffestd_check_item_ ();
-
-#if FFECOM_ONEPASS
- ffeste_R910_item (expr);
-#else
- {
- ffestdExprItem_ item
- = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, "ffestdExprItem_",
- sizeof (*item));
-
- item->next = NULL;
- item->expr = expr;
- item->token = ffelex_token_use (expr_token);
- *ffestd_expr_list_ = item;
- ffestd_expr_list_ = &item->next;
- }
-#endif
-}
-
-/* ffestd_R910_finish -- WRITE statement list complete
-
- ffestd_R910_finish();
-
- Just wrap up any local activities. */
-
-void
-ffestd_R910_finish ()
-{
- ffestd_check_finish_ ();
-
-#if FFECOM_ONEPASS
- ffeste_R910_finish ();
-#else
- /* Nothing to do, it's implicit. */
-#endif
-}
-
-/* ffestd_R911_start -- PRINT statement list begin
-
- ffestd_R911_start();
-
- Verify that PRINT is valid here, and begin accepting items in the
- list. */
-
-void
-ffestd_R911_start (ffestvFormat format)
-{
- ffestd_check_start_ ();
-
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R911_start (&ffestp_file.print, format);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR911_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R911.pool = ffesta_output_pool;
- stmt->u.R911.params = ffestd_subr_copy_print_ ();
- stmt->u.R911.format = format;
- stmt->u.R911.list = NULL;
- ffestd_expr_list_ = &stmt->u.R911.list;
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
-}
-
-/* ffestd_R911_item -- PRINT statement i/o item
-
- ffestd_R911_item(expr,expr_token);
-
- Implement output-list expression. */
-
-void
-ffestd_R911_item (ffebld expr, ffelexToken expr_token)
-{
- ffestd_check_item_ ();
-
-#if FFECOM_ONEPASS
- ffeste_R911_item (expr);
-#else
- {
- ffestdExprItem_ item
- = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, "ffestdExprItem_",
- sizeof (*item));
-
- item->next = NULL;
- item->expr = expr;
- item->token = ffelex_token_use (expr_token);
- *ffestd_expr_list_ = item;
- ffestd_expr_list_ = &item->next;
- }
-#endif
-}
-
-/* ffestd_R911_finish -- PRINT statement list complete
-
- ffestd_R911_finish();
-
- Just wrap up any local activities. */
-
-void
-ffestd_R911_finish ()
-{
- ffestd_check_finish_ ();
-
-#if FFECOM_ONEPASS
- ffeste_R911_finish ();
-#else
- /* Nothing to do, it's implicit. */
-#endif
-}
-
-/* ffestd_R919 -- BACKSPACE statement
-
- ffestd_R919();
-
- Make sure a BACKSPACE is valid in the current context, and implement it. */
-
-void
-ffestd_R919 ()
-{
- ffestd_check_simple_ ();
-
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R919 (&ffestp_file.beru);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR919_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R919.pool = ffesta_output_pool;
- stmt->u.R919.params = ffestd_subr_copy_beru_ ();
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
-}
-
-/* ffestd_R920 -- ENDFILE statement
-
- ffestd_R920();
-
- Make sure a ENDFILE is valid in the current context, and implement it. */
-
-void
-ffestd_R920 ()
-{
- ffestd_check_simple_ ();
-
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R920 (&ffestp_file.beru);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR920_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R920.pool = ffesta_output_pool;
- stmt->u.R920.params = ffestd_subr_copy_beru_ ();
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
-}
-
-/* ffestd_R921 -- REWIND statement
-
- ffestd_R921();
-
- Make sure a REWIND is valid in the current context, and implement it. */
-
-void
-ffestd_R921 ()
-{
- ffestd_check_simple_ ();
-
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R921 (&ffestp_file.beru);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR921_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R921.pool = ffesta_output_pool;
- stmt->u.R921.params = ffestd_subr_copy_beru_ ();
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
-}
-
-/* ffestd_R923A -- INQUIRE statement (non-IOLENGTH version)
-
- ffestd_R923A(bool by_file);
-
- Make sure an INQUIRE is valid in the current context, and implement it. */
-
-void
-ffestd_R923A (bool by_file)
-{
- ffestd_check_simple_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-#define specified(something) \
- (ffestp_file.inquire.inquire_spec[something].kw_or_val_present)
-
- /* Warn if there are any thing we don't handle via f2c libraries. */
- if (specified (FFESTP_inquireixACTION)
- || specified (FFESTP_inquireixCARRIAGECONTROL)
- || specified (FFESTP_inquireixDEFAULTFILE)
- || specified (FFESTP_inquireixDELIM)
- || specified (FFESTP_inquireixKEYED)
- || specified (FFESTP_inquireixORGANIZATION)
- || specified (FFESTP_inquireixPAD)
- || specified (FFESTP_inquireixPOSITION)
- || specified (FFESTP_inquireixREAD)
- || specified (FFESTP_inquireixREADWRITE)
- || specified (FFESTP_inquireixRECORDTYPE)
- || specified (FFESTP_inquireixWRITE))
- {
- ffebad_start (FFEBAD_INQUIRE_UNSUPPORTED);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_finish ();
- }
-
-#undef specified
-#endif
-
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R923A (&ffestp_file.inquire, by_file);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR923A_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R923A.pool = ffesta_output_pool;
- stmt->u.R923A.params = ffestd_subr_copy_inquire_ ();
- stmt->u.R923A.by_file = by_file;
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
-}
-
-/* ffestd_R923B_start -- INQUIRE(IOLENGTH=expr) statement list begin
-
- ffestd_R923B_start();
-
- Verify that INQUIRE is valid here, and begin accepting items in the
- list. */
-
-void
-ffestd_R923B_start ()
-{
- ffestd_check_start_ ();
-
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R923B_start (&ffestp_file.inquire);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR923B_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R923B.pool = ffesta_output_pool;
- stmt->u.R923B.params = ffestd_subr_copy_inquire_ ();
- stmt->u.R923B.list = NULL;
- ffestd_expr_list_ = &stmt->u.R923B.list;
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
-}
-
-/* ffestd_R923B_item -- INQUIRE statement i/o item
-
- ffestd_R923B_item(expr,expr_token);
-
- Implement output-list expression. */
-
-void
-ffestd_R923B_item (ffebld expr)
-{
- ffestd_check_item_ ();
-
-#if FFECOM_ONEPASS
- ffeste_R923B_item (expr);
-#else
- {
- ffestdExprItem_ item
- = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, "ffestdExprItem_",
- sizeof (*item));
-
- item->next = NULL;
- item->expr = expr;
- *ffestd_expr_list_ = item;
- ffestd_expr_list_ = &item->next;
- }
-#endif
-}
-
-/* ffestd_R923B_finish -- INQUIRE statement list complete
-
- ffestd_R923B_finish();
-
- Just wrap up any local activities. */
-
-void
-ffestd_R923B_finish ()
-{
- ffestd_check_finish_ ();
-
-#if FFECOM_ONEPASS
- ffeste_R923B_finish ();
-#else
- /* Nothing to do, it's implicit. */
-#endif
-}
-
-/* ffestd_R1001 -- FORMAT statement
-
- ffestd_R1001(format_list); */
-
-void
-ffestd_R1001 (ffesttFormatList f)
-{
- ffestsHolder str;
- ffests s = &str;
-
- ffestd_check_simple_ ();
-
- if (ffestd_label_formatdef_ == NULL)
- return; /* Nothing to hook it up to (no label def). */
-
- ffests_new (s, malloc_pool_image (), 80);
- ffests_putc (s, '(');
- ffestd_R1001dump_ (s, f); /* Build the string in s. */
- ffests_putc (s, ')');
-
-#if FFECOM_ONEPASS
- ffeste_R1001 (s);
- ffests_kill (s); /* Kill the string in s. */
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR1001_);
-#if 0
- /* Don't bother with this. After all, things like cilists also are
- declared midway through code-generation. Perhaps the only problems
- the gcc back end has with midway declarations are with stack vars,
- maybe only with vars that can be put in registers. Unless/until the
- need is established, handle FORMAT just like cilists and others; at
- that point, they'd likely *all* have to be fixed, which would be
- very painful anyway. */
- /* Insert FORMAT statement just after the first item on the
- statement list, which must be a FORMAT label, which see. */
- assert (ffestd_stmt_list_.first->id == FFESTD_stmtidFORMATLABEL_);
- stmt->previous = ffestd_stmt_list_.first;
- stmt->next = ffestd_stmt_list_.first->next;
- stmt->next->previous = stmt;
- stmt->previous->next = stmt;
-#else
- ffestd_stmt_append_ (stmt);
-#endif
- stmt->u.R1001.str = str;
- }
-#endif
-
- ffestd_label_formatdef_ = NULL;
-}
-
-/* ffestd_R1001dump_ -- Dump list of formats
-
- ffesttFormatList list;
- ffestd_R1001dump_(list,0);
-
- The formats in the list are dumped. */
-
-static void
-ffestd_R1001dump_ (ffests s, ffesttFormatList list)
-{
- ffesttFormatList next;
-
- for (next = list->next; next != list; next = next->next)
- {
- if (next != list->next)
- ffests_putc (s, ',');
- switch (next->type)
- {
- case FFESTP_formattypeI:
- ffestd_R1001dump_1005_3_ (s, next, "I");
- break;
-
- case FFESTP_formattypeB:
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- ffestd_R1001dump_1005_3_ (s, next, "B");
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
- ffestd_R1001error_ (next);
-#else
-#error
-#endif
- break;
-
- case FFESTP_formattypeO:
- ffestd_R1001dump_1005_3_ (s, next, "O");
- break;
-
- case FFESTP_formattypeZ:
- ffestd_R1001dump_1005_3_ (s, next, "Z");
- break;
-
- case FFESTP_formattypeF:
- ffestd_R1001dump_1005_4_ (s, next, "F");
- break;
-
- case FFESTP_formattypeE:
- ffestd_R1001dump_1005_5_ (s, next, "E");
- break;
-
- case FFESTP_formattypeEN:
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- ffestd_R1001dump_1005_5_ (s, next, "EN");
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
- ffestd_R1001error_ (next);
-#else
-#error
-#endif
- break;
-
- case FFESTP_formattypeG:
- ffestd_R1001dump_1005_5_ (s, next, "G");
- break;
-
- case FFESTP_formattypeL:
- ffestd_R1001dump_1005_2_ (s, next, "L");
- break;
-
- case FFESTP_formattypeA:
- ffestd_R1001dump_1005_1_ (s, next, "A");
- break;
-
- case FFESTP_formattypeD:
- ffestd_R1001dump_1005_4_ (s, next, "D");
- break;
-
- case FFESTP_formattypeQ:
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- ffestd_R1001dump_1010_1_ (s, next, "Q");
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
- ffestd_R1001error_ (next);
-#else
-#error
-#endif
- break;
-
- case FFESTP_formattypeDOLLAR:
- ffestd_R1001dump_1010_1_ (s, next, "$");
- break;
-
- case FFESTP_formattypeP:
- ffestd_R1001dump_1010_4_ (s, next, "P");
- break;
-
- case FFESTP_formattypeT:
- ffestd_R1001dump_1010_5_ (s, next, "T");
- break;
-
- case FFESTP_formattypeTL:
- ffestd_R1001dump_1010_5_ (s, next, "TL");
- break;
-
- case FFESTP_formattypeTR:
- ffestd_R1001dump_1010_5_ (s, next, "TR");
- break;
-
- case FFESTP_formattypeX:
- ffestd_R1001dump_1010_3_ (s, next, "X");
- break;
-
- case FFESTP_formattypeS:
- ffestd_R1001dump_1010_1_ (s, next, "S");
- break;
-
- case FFESTP_formattypeSP:
- ffestd_R1001dump_1010_1_ (s, next, "SP");
- break;
-
- case FFESTP_formattypeSS:
- ffestd_R1001dump_1010_1_ (s, next, "SS");
- break;
-
- case FFESTP_formattypeBN:
- ffestd_R1001dump_1010_1_ (s, next, "BN");
- break;
-
- case FFESTP_formattypeBZ:
- ffestd_R1001dump_1010_1_ (s, next, "BZ");
- break;
-
- case FFESTP_formattypeSLASH:
- ffestd_R1001dump_1010_2_ (s, next, "/");
- break;
-
- case FFESTP_formattypeCOLON:
- ffestd_R1001dump_1010_1_ (s, next, ":");
- break;
-
- case FFESTP_formattypeR1016:
- switch (ffelex_token_type (next->t))
- {
- case FFELEX_typeCHARACTER:
- {
- char *p = ffelex_token_text (next->t);
- ffeTokenLength i = ffelex_token_length (next->t);
-
- ffests_putc (s, '\002');
- while (i-- != 0)
- {
- if (*p == '\002')
- ffests_putc (s, '\002');
- ffests_putc (s, *p);
- ++p;
- }
- ffests_putc (s, '\002');
- }
- break;
-
- case FFELEX_typeHOLLERITH:
- {
- char *p = ffelex_token_text (next->t);
- ffeTokenLength i = ffelex_token_length (next->t);
-
- ffests_printf (s, "%" ffeTokenLength_f "uH", i);
- while (i-- != 0)
- {
- ffests_putc (s, *p);
- ++p;
- }
- }
- break;
-
- default:
- assert (FALSE);
- }
- break;
-
- case FFESTP_formattypeFORMAT:
- if (next->u.R1003D.R1004.present)
- {
- if (next->u.R1003D.R1004.rtexpr)
- ffestd_R1001rtexpr_ (s, next, next->u.R1003D.R1004.u.expr);
- else
- ffests_printf (s, "%lu", next->u.R1003D.R1004.u.unsigned_val);
- }
-
- ffests_putc (s, '(');
- ffestd_R1001dump_ (s, next->u.R1003D.format);
- ffests_putc (s, ')');
- break;
-
- default:
- assert (FALSE);
- }
- }
-}
-
-/* ffestd_R1001dump_1005_1_ -- Dump a particular format
-
- ffesttFormatList f;
- ffestd_R1001dump_1005_1_(f,"I");
-
- The format is dumped with form [r]X[w]. */
-
-static void
-ffestd_R1001dump_1005_1_ (ffests s, ffesttFormatList f, const char *string)
-{
- assert (!f->u.R1005.R1007_or_R1008.present);
- assert (!f->u.R1005.R1009.present);
-
- if (f->u.R1005.R1004.present)
- {
- if (f->u.R1005.R1004.rtexpr)
- ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr);
- else
- ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
- }
-
- ffests_puts (s, string);
-
- if (f->u.R1005.R1006.present)
- {
- if (f->u.R1005.R1006.rtexpr)
- ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr);
- else
- ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
- }
-}
-
-/* ffestd_R1001dump_1005_2_ -- Dump a particular format
-
- ffesttFormatList f;
- ffestd_R1001dump_1005_2_(f,"I");
-
- The format is dumped with form [r]Xw. */
-
-static void
-ffestd_R1001dump_1005_2_ (ffests s, ffesttFormatList f, const char *string)
-{
- assert (!f->u.R1005.R1007_or_R1008.present);
- assert (!f->u.R1005.R1009.present);
- assert (f->u.R1005.R1006.present);
-
- if (f->u.R1005.R1004.present)
- {
- if (f->u.R1005.R1004.rtexpr)
- ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr);
- else
- ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
- }
-
- ffests_puts (s, string);
-
- if (f->u.R1005.R1006.rtexpr)
- ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr);
- else
- ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
-}
-
-/* ffestd_R1001dump_1005_3_ -- Dump a particular format
-
- ffesttFormatList f;
- ffestd_R1001dump_1005_3_(f,"I");
-
- The format is dumped with form [r]Xw[.m]. */
-
-static void
-ffestd_R1001dump_1005_3_ (ffests s, ffesttFormatList f, const char *string)
-{
- assert (!f->u.R1005.R1009.present);
- assert (f->u.R1005.R1006.present);
-
- if (f->u.R1005.R1004.present)
- {
- if (f->u.R1005.R1004.rtexpr)
- ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr);
- else
- ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
- }
-
- ffests_puts (s, string);
-
- if (f->u.R1005.R1006.rtexpr)
- ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr);
- else
- ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
-
- if (f->u.R1005.R1007_or_R1008.present)
- {
- ffests_putc (s, '.');
- if (f->u.R1005.R1007_or_R1008.rtexpr)
- ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1007_or_R1008.u.expr);
- else
- ffests_printf (s, "%lu", f->u.R1005.R1007_or_R1008.u.unsigned_val);
- }
-}
-
-/* ffestd_R1001dump_1005_4_ -- Dump a particular format
-
- ffesttFormatList f;
- ffestd_R1001dump_1005_4_(f,"I");
-
- The format is dumped with form [r]Xw.d. */
-
-static void
-ffestd_R1001dump_1005_4_ (ffests s, ffesttFormatList f, const char *string)
-{
- assert (!f->u.R1005.R1009.present);
- assert (f->u.R1005.R1007_or_R1008.present);
- assert (f->u.R1005.R1006.present);
-
- if (f->u.R1005.R1004.present)
- {
- if (f->u.R1005.R1004.rtexpr)
- ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr);
- else
- ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
- }
-
- ffests_puts (s, string);
-
- if (f->u.R1005.R1006.rtexpr)
- ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr);
- else
- ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
-
- ffests_putc (s, '.');
- if (f->u.R1005.R1007_or_R1008.rtexpr)
- ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1007_or_R1008.u.expr);
- else
- ffests_printf (s, "%lu", f->u.R1005.R1007_or_R1008.u.unsigned_val);
-}
-
-/* ffestd_R1001dump_1005_5_ -- Dump a particular format
-
- ffesttFormatList f;
- ffestd_R1001dump_1005_5_(f,"I");
-
- The format is dumped with form [r]Xw.d[Ee]. */
-
-static void
-ffestd_R1001dump_1005_5_ (ffests s, ffesttFormatList f, const char *string)
-{
- assert (f->u.R1005.R1007_or_R1008.present);
- assert (f->u.R1005.R1006.present);
-
- if (f->u.R1005.R1004.present)
- {
- if (f->u.R1005.R1004.rtexpr)
- ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr);
- else
- ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
- }
-
- ffests_puts (s, string);
-
- if (f->u.R1005.R1006.rtexpr)
- ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr);
- else
- ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
-
- ffests_putc (s, '.');
- if (f->u.R1005.R1007_or_R1008.rtexpr)
- ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1007_or_R1008.u.expr);
- else
- ffests_printf (s, "%lu", f->u.R1005.R1007_or_R1008.u.unsigned_val);
-
- if (f->u.R1005.R1009.present)
- {
- ffests_putc (s, 'E');
- if (f->u.R1005.R1009.rtexpr)
- ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1009.u.expr);
- else
- ffests_printf (s, "%lu", f->u.R1005.R1009.u.unsigned_val);
- }
-}
-
-/* ffestd_R1001dump_1010_1_ -- Dump a particular format
-
- ffesttFormatList f;
- ffestd_R1001dump_1010_1_(f,"I");
-
- The format is dumped with form X. */
-
-static void
-ffestd_R1001dump_1010_1_ (ffests s, ffesttFormatList f, const char *string)
-{
- assert (!f->u.R1010.val.present);
-
- ffests_puts (s, string);
-}
-
-/* ffestd_R1001dump_1010_2_ -- Dump a particular format
-
- ffesttFormatList f;
- ffestd_R1001dump_1010_2_(f,"I");
-
- The format is dumped with form [r]X. */
-
-static void
-ffestd_R1001dump_1010_2_ (ffests s, ffesttFormatList f, const char *string)
-{
- if (f->u.R1010.val.present)
- {
- if (f->u.R1010.val.rtexpr)
- ffestd_R1001rtexpr_ (s, f, f->u.R1010.val.u.expr);
- else
- ffests_printf (s, "%lu", f->u.R1010.val.u.unsigned_val);
- }
-
- ffests_puts (s, string);
-}
-
-/* ffestd_R1001dump_1010_3_ -- Dump a particular format
-
- ffesttFormatList f;
- ffestd_R1001dump_1010_3_(f,"I");
-
- The format is dumped with form nX. */
-
-static void
-ffestd_R1001dump_1010_3_ (ffests s, ffesttFormatList f, const char *string)
-{
- assert (f->u.R1010.val.present);
-
- if (f->u.R1010.val.rtexpr)
- ffestd_R1001rtexpr_ (s, f, f->u.R1010.val.u.expr);
- else
- ffests_printf (s, "%lu", f->u.R1010.val.u.unsigned_val);
-
- ffests_puts (s, string);
-}
-
-/* ffestd_R1001dump_1010_4_ -- Dump a particular format
-
- ffesttFormatList f;
- ffestd_R1001dump_1010_4_(f,"I");
-
- The format is dumped with form kX. Note that k is signed. */
-
-static void
-ffestd_R1001dump_1010_4_ (ffests s, ffesttFormatList f, const char *string)
-{
- assert (f->u.R1010.val.present);
-
- if (f->u.R1010.val.rtexpr)
- ffestd_R1001rtexpr_ (s, f, f->u.R1010.val.u.expr);
- else
- ffests_printf (s, "%ld", f->u.R1010.val.u.signed_val);
-
- ffests_puts (s, string);
-}
-
-/* ffestd_R1001dump_1010_5_ -- Dump a particular format
-
- ffesttFormatList f;
- ffestd_R1001dump_1010_5_(f,"I");
-
- The format is dumped with form Xn. */
-
-static void
-ffestd_R1001dump_1010_5_ (ffests s, ffesttFormatList f, const char *string)
-{
- assert (f->u.R1010.val.present);
-
- ffests_puts (s, string);
-
- if (f->u.R1010.val.rtexpr)
- ffestd_R1001rtexpr_ (s, f, f->u.R1010.val.u.expr);
- else
- ffests_printf (s, "%lu", f->u.R1010.val.u.unsigned_val);
-}
-
-/* ffestd_R1001error_ -- Complain about FORMAT specification not supported
-
- ffesttFormatList f;
- ffestd_R1001error_(f);
-
- An error message is produced. */
-
-static void
-ffestd_R1001error_ (ffesttFormatList f)
-{
- ffebad_start (FFEBAD_FORMAT_UNSUPPORTED);
- ffebad_here (0, ffelex_token_where_line (f->t), ffelex_token_where_column (f->t));
- ffebad_finish ();
-}
-
-static void
-ffestd_R1001rtexpr_ (ffests s, ffesttFormatList f, ffebld expr)
-{
- if ((expr == NULL)
- || (ffebld_op (expr) != FFEBLD_opCONTER)
- || (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeINTEGER)
- || (ffeinfo_kindtype (ffebld_info (expr)) == FFEINFO_kindtypeINTEGER4))
- {
- ffebad_start (FFEBAD_FORMAT_VARIABLE);
- ffebad_here (0, ffelex_token_where_line (f->t), ffelex_token_where_column (f->t));
- ffebad_finish ();
- }
- else
- {
- int val;
-
- switch (ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- val = ffebld_constant_integer1 (ffebld_conter (expr));
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- val = ffebld_constant_integer2 (ffebld_conter (expr));
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- val = ffebld_constant_integer3 (ffebld_conter (expr));
- break;
-#endif
-
- default:
- assert ("bad INTEGER constant kind type" == NULL);
- /* Fall through. */
- case FFEINFO_kindtypeANY:
- return;
- }
- ffests_printf (s, "%ld", (long) val);
- }
-}
-
-/* ffestd_R1102 -- PROGRAM statement
-
- ffestd_R1102(name_token);
-
- Make sure ffestd_kind_ identifies an empty block. Make sure name_token
- gives a valid name. Implement the beginning of a main program. */
-
-void
-ffestd_R1102 (ffesymbol s, ffelexToken name UNUSED)
-{
- ffestd_check_simple_ ();
-
- assert (ffestd_block_level_ == 0);
- ffestd_is_reachable_ = TRUE;
-
- ffecom_notify_primary_entry (s);
- ffe_set_is_mainprog (TRUE); /* Is a main program. */
- ffe_set_is_saveall (TRUE); /* Main program always has implicit SAVE. */
-
- ffestw_set_sym (ffestw_stack_top (), s);
-
-#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 (ffestd_label_formatdef_ == NULL)
+ return; /* Nothing to hook it up to (no label def). */
- if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateBLOCKDATA5)
- ffestd_subr_labels_ (TRUE); /* Handle any undefined labels. */
+ 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_R1112 ();
-#else
- {
- ffestdStmt_ stmt;
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR1001_);
+ ffestd_stmt_append_ (stmt);
+ stmt->u.R1001.str = str;
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR1112_);
- ffestd_stmt_append_ (stmt);
- }
-#endif
+ ffestd_label_formatdef_ = NULL;
}
-/* ffestd_R1202 -- INTERFACE statement
-
- ffestd_R1202(operator,defined_name);
+/* ffestd_R1001dump_ -- Dump list of formats
- Make sure ffestd_kind_ identifies an INTERFACE block.
- Implement the end of the current interface.
+ ffesttFormatList list;
+ ffestd_R1001dump_(list,0);
- 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. */
+ The formats in the list are dumped. */
-#if FFESTR_F90
-void
-ffestd_R1202 (ffestpDefinedOperator operator, ffelexToken name)
+static void
+ffestd_R1001dump_ (ffests s, ffesttFormatList list)
{
- ffestd_check_simple_ ();
-
- ffestd_subr_f90_ ();
- return;
+ ffesttFormatList next;
-#ifdef FFESTD_F90
- switch (operator)
+ for (next = list->next; next != list; next = next->next)
{
- 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
-}
+ if (next != list->next)
+ ffests_putc (s, ',');
+ switch (next->type)
+ {
+ case FFESTP_formattypeI:
+ ffestd_R1001dump_1005_3_ (s, next, "I");
+ break;
-/* ffestd_R1213 -- Defined assignment statement
+ case FFESTP_formattypeB:
+ ffestd_R1001error_ (next);
+ break;
- ffestd_R1213(dest_expr,source_expr,source_token);
+ case FFESTP_formattypeO:
+ ffestd_R1001dump_1005_3_ (s, next, "O");
+ break;
- Make sure the assignment is valid. */
+ case FFESTP_formattypeZ:
+ ffestd_R1001dump_1005_3_ (s, next, "Z");
+ break;
-#if FFESTR_F90
-void
-ffestd_R1213 (ffebld dest, ffebld source)
-{
- ffestd_check_simple_ ();
+ case FFESTP_formattypeF:
+ ffestd_R1001dump_1005_4_ (s, next, "F");
+ break;
- ffestd_subr_f90_ ();
- return;
+ case FFESTP_formattypeE:
+ ffestd_R1001dump_1005_5_ (s, next, "E");
+ break;
-#ifdef FFESTD_F90
- fputs ("+ let_defined ", dmpout);
- ffebld_dump (dest);
- fputs ("=", dmpout);
- ffebld_dump (source);
- fputc ('\n', dmpout);
-#endif
-}
+ case FFESTP_formattypeEN:
+ ffestd_R1001error_ (next);
+ break;
-#endif
-/* ffestd_R1219 -- FUNCTION statement
+ case FFESTP_formattypeG:
+ ffestd_R1001dump_1005_5_ (s, next, "G");
+ break;
- ffestd_R1219(funcname,arglist,ending_token,kind,kindt,len,lent,
- recursive);
+ case FFESTP_formattypeL:
+ ffestd_R1001dump_1005_2_ (s, next, "L");
+ break;
- Make sure statement is valid here, register arguments for the
- function name, and so on.
+ case FFESTP_formattypeA:
+ ffestd_R1001dump_1005_1_ (s, next, "A");
+ break;
- 06-Jun-90 JCB 2.0
- Added the kind, len, and recursive arguments. */
+ case FFESTP_formattypeD:
+ ffestd_R1001dump_1005_4_ (s, next, "D");
+ break;
-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
+ case FFESTP_formattypeQ:
+ ffestd_R1001error_ (next);
+ break;
- assert (ffestd_block_level_ == 0);
- ffestd_is_reachable_ = TRUE;
+ case FFESTP_formattypeDOLLAR:
+ ffestd_R1001dump_1010_1_ (s, next, "$");
+ break;
- ffestd_check_simple_ ();
+ case FFESTP_formattypeP:
+ ffestd_R1001dump_1010_4_ (s, next, "P");
+ break;
- ffecom_notify_primary_entry (s);
- ffestw_set_sym (ffestw_stack_top (), s);
+ case FFESTP_formattypeT:
+ ffestd_R1001dump_1010_5_ (s, next, "T");
+ break;
-#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_formattypeTL:
+ ffestd_R1001dump_1010_5_ (s, next, "TL");
+ break;
- case FFESTP_typeNone:
- a = "";
- break;
+ case FFESTP_formattypeTR:
+ ffestd_R1001dump_1010_5_ (s, next, "TR");
+ 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
-}
+ case FFESTP_formattypeX:
+ ffestd_R1001dump_1010_2_ (s, next, "X");
+ break;
-/* ffestd_R1221 -- End a FUNCTION
+ case FFESTP_formattypeS:
+ ffestd_R1001dump_1010_1_ (s, next, "S");
+ break;
- ffestd_R1221(TRUE); */
+ case FFESTP_formattypeSP:
+ ffestd_R1001dump_1010_1_ (s, next, "SP");
+ break;
-void
-ffestd_R1221 (bool ok UNUSED)
-{
- assert (ffestd_block_level_ == 0);
+ case FFESTP_formattypeSS:
+ ffestd_R1001dump_1010_1_ (s, next, "SS");
+ break;
- if (FFESTD_IS_END_OPTIMIZED_ && ffestd_is_reachable_)
- ffestd_R1227 (NULL); /* Generate RETURN. */
+ case FFESTP_formattypeBN:
+ ffestd_R1001dump_1010_1_ (s, next, "BN");
+ break;
- if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateFUNCTION5)
- ffestd_subr_labels_ (FALSE);/* Handle any undefined labels. */
+ case FFESTP_formattypeBZ:
+ ffestd_R1001dump_1010_1_ (s, next, "BZ");
+ break;
-#if FFECOM_ONEPASS
- ffeste_R1221 ();
-#else
- {
- ffestdStmt_ stmt;
+ case FFESTP_formattypeSLASH:
+ ffestd_R1001dump_1010_2_ (s, next, "/");
+ break;
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR1221_);
- ffestd_stmt_append_ (stmt);
- }
-#endif
-}
+ case FFESTP_formattypeCOLON:
+ ffestd_R1001dump_1010_1_ (s, next, ":");
+ break;
-/* ffestd_R1223 -- SUBROUTINE statement
+ 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);
- ffestd_R1223(subrname,arglist,ending_token,recursive_token);
+ ffests_putc (s, '\002');
+ while (i-- != 0)
+ {
+ if (*p == '\002')
+ ffests_putc (s, '\002');
+ ffests_putc (s, *p);
+ ++p;
+ }
+ ffests_putc (s, '\002');
+ }
+ break;
- Make sure statement is valid here, register arguments for the
- subroutine name, and so on.
+ case FFELEX_typeHOLLERITH:
+ {
+ char *p = ffelex_token_text (next->t);
+ ffeTokenLength i = ffelex_token_length (next->t);
- 06-Jun-90 JCB 2.0
- Added the recursive argument. */
+ ffests_printf (s, "%" ffeTokenLength_f "uH", i);
+ while (i-- != 0)
+ {
+ ffests_putc (s, *p);
+ ++p;
+ }
+ }
+ break;
-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;
+ default:
+ assert (FALSE);
+ }
+ break;
- ffestd_check_simple_ ();
+ case FFESTP_formattypeFORMAT:
+ if (next->u.R1003D.R1004.present)
+ {
+ if (next->u.R1003D.R1004.rtexpr)
+ ffestd_R1001rtexpr_ (s, next, next->u.R1003D.R1004.u.expr);
+ else
+ ffests_printf (s, "%lu", next->u.R1003D.R1004.u.unsigned_val);
+ }
- ffecom_notify_primary_entry (s);
- ffestw_set_sym (ffestw_stack_top (), s);
+ ffests_putc (s, '(');
+ ffestd_R1001dump_ (s, next->u.R1003D.format);
+ ffests_putc (s, ')');
+ break;
-#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);
+ default:
+ assert (FALSE);
+ }
}
- fputc ('\n', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
-/* ffestd_R1225 -- End a SUBROUTINE
+/* ffestd_R1001dump_1005_1_ -- Dump a particular format
- ffestd_R1225(TRUE); */
+ ffesttFormatList f;
+ ffestd_R1001dump_1005_1_(f,"I");
-void
-ffestd_R1225 (bool ok UNUSED)
-{
- assert (ffestd_block_level_ == 0);
+ The format is dumped with form [r]X[w]. */
- if (FFESTD_IS_END_OPTIMIZED_ && ffestd_is_reachable_)
- ffestd_R1227 (NULL); /* Generate RETURN. */
+static void
+ffestd_R1001dump_1005_1_ (ffests s, ffesttFormatList f, const char *string)
+{
+ assert (!f->u.R1005.R1007_or_R1008.present);
+ assert (!f->u.R1005.R1009.present);
- if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateSUBROUTINE5)
- ffestd_subr_labels_ (FALSE);/* Handle any undefined labels. */
+ if (f->u.R1005.R1004.present)
+ {
+ if (f->u.R1005.R1004.rtexpr)
+ ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr);
+ else
+ ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
+ }
-#if FFECOM_ONEPASS
- ffeste_R1225 ();
-#else
- {
- ffestdStmt_ stmt;
+ ffests_puts (s, string);
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR1225_);
- ffestd_stmt_append_ (stmt);
- }
-#endif
+ if (f->u.R1005.R1006.present)
+ {
+ if (f->u.R1005.R1006.rtexpr)
+ ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr);
+ else
+ ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
+ }
}
-/* ffestd_R1226 -- ENTRY statement
+/* ffestd_R1001dump_1005_2_ -- Dump a particular format
- ffestd_R1226(entryname,arglist,ending_token);
+ ffesttFormatList f;
+ ffestd_R1001dump_1005_2_(f,"I");
- Make sure we're in a SUBROUTINE or FUNCTION, register arguments for the
- entry point name, and so on. */
+ The format is dumped with form [r]Xw. */
-void
-ffestd_R1226 (ffesymbol entry)
+static void
+ffestd_R1001dump_1005_2_ (ffests s, ffesttFormatList f, const char *string)
{
- ffestd_check_simple_ ();
+ assert (!f->u.R1005.R1007_or_R1008.present);
+ assert (!f->u.R1005.R1009.present);
+ assert (f->u.R1005.R1006.present);
-#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))
+ if (f->u.R1005.R1004.present)
{
- 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_;
+ if (f->u.R1005.R1004.rtexpr)
+ ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr);
+ else
+ ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
}
-#endif
- ffestd_is_reachable_ = TRUE;
+ ffests_puts (s, string);
+
+ if (f->u.R1005.R1006.rtexpr)
+ ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr);
+ else
+ ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
}
-/* ffestd_R1227 -- RETURN statement
+/* ffestd_R1001dump_1005_3_ -- Dump a particular format
- ffestd_R1227(expr);
+ ffesttFormatList f;
+ ffestd_R1001dump_1005_3_(f,"I");
- Make sure statement is valid here; implement. expr and expr_token are
- both NULL if there was no expression. */
+ The format is dumped with form [r]Xw[.m]. */
-void
-ffestd_R1227 (ffebld expr)
+static void
+ffestd_R1001dump_1005_3_ (ffests s, ffesttFormatList f, const char *string)
{
- ffestd_check_simple_ ();
+ assert (!f->u.R1005.R1009.present);
+ assert (f->u.R1005.R1006.present);
-#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 (f->u.R1005.R1004.present)
+ {
+ if (f->u.R1005.R1004.rtexpr)
+ ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr);
+ else
+ ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
+ }
- if (ffestd_block_level_ == 0)
- ffestd_is_reachable_ = FALSE;
+ ffests_puts (s, string);
+
+ if (f->u.R1005.R1006.rtexpr)
+ ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr);
+ else
+ ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
+
+ if (f->u.R1005.R1007_or_R1008.present)
+ {
+ ffests_putc (s, '.');
+ if (f->u.R1005.R1007_or_R1008.rtexpr)
+ ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1007_or_R1008.u.expr);
+ else
+ ffests_printf (s, "%lu", f->u.R1005.R1007_or_R1008.u.unsigned_val);
+ }
}
-/* ffestd_R1228 -- CONTAINS statement
+/* ffestd_R1001dump_1005_4_ -- Dump a particular format
- ffestd_R1228(); */
+ ffesttFormatList f;
+ ffestd_R1001dump_1005_4_(f,"I");
-#if FFESTR_F90
-void
-ffestd_R1228 ()
-{
- assert (ffestd_block_level_ == 0);
+ The format is dumped with form [r]Xw.d. */
- ffestd_check_simple_ ();
+static void
+ffestd_R1001dump_1005_4_ (ffests s, ffesttFormatList f, const char *string)
+{
+ assert (!f->u.R1005.R1009.present);
+ assert (f->u.R1005.R1007_or_R1008.present);
+ assert (f->u.R1005.R1006.present);
- /* Generate RETURN/STOP code here */
+ if (f->u.R1005.R1004.present)
+ {
+ if (f->u.R1005.R1004.rtexpr)
+ ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr);
+ else
+ ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
+ }
- ffestd_subr_labels_ (ffestw_state (ffestw_stack_top ())
- == FFESTV_stateMODULE5); /* Handle any undefined
- labels. */
+ ffests_puts (s, string);
- ffestd_subr_f90_ ();
- return;
+ if (f->u.R1005.R1006.rtexpr)
+ ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr);
+ else
+ ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
-#ifdef FFESTD_F90
- fputs ("- CONTAINS\n", dmpout);
-#endif
+ ffests_putc (s, '.');
+ if (f->u.R1005.R1007_or_R1008.rtexpr)
+ ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1007_or_R1008.u.expr);
+ else
+ ffests_printf (s, "%lu", f->u.R1005.R1007_or_R1008.u.unsigned_val);
}
-#endif
-/* ffestd_R1229_start -- STMTFUNCTION statement begin
-
- ffestd_R1229_start(func_name,func_arg_list,close_paren);
+/* ffestd_R1001dump_1005_5_ -- Dump a particular format
- 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.
+ ffesttFormatList f;
+ ffestd_R1001dump_1005_5_(f,"I");
- 03-Jan-91 JCB 2.0
- Do nothing, now that _finish_ does everything. */
+ The format is dumped with form [r]Xw.d[Ee]. */
-void
-ffestd_R1229_start (ffelexToken name UNUSED, ffesttTokenList args UNUSED)
+static void
+ffestd_R1001dump_1005_5_ (ffests s, ffesttFormatList f, const char *string)
{
- ffestd_check_start_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
-}
+ assert (f->u.R1005.R1007_or_R1008.present);
+ assert (f->u.R1005.R1006.present);
-/* ffestd_R1229_finish -- STMTFUNCTION statement list complete
+ if (f->u.R1005.R1004.present)
+ {
+ if (f->u.R1005.R1004.rtexpr)
+ ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr);
+ else
+ ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
+ }
- ffestd_R1229_finish(s);
+ ffests_puts (s, string);
- 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 (f->u.R1005.R1006.rtexpr)
+ ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr);
+ else
+ ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
- If 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.
+ ffests_putc (s, '.');
+ if (f->u.R1005.R1007_or_R1008.rtexpr)
+ ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1007_or_R1008.u.expr);
+ else
+ ffests_printf (s, "%lu", f->u.R1005.R1007_or_R1008.u.unsigned_val);
- 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. */
+ if (f->u.R1005.R1009.present)
+ {
+ ffests_putc (s, 'E');
+ if (f->u.R1005.R1009.rtexpr)
+ ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1009.u.expr);
+ else
+ ffests_printf (s, "%lu", f->u.R1005.R1009.u.unsigned_val);
+ }
+}
-void
-ffestd_R1229_finish (ffesymbol s)
-{
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- ffebld args = ffesymbol_dummyargs (s);
-#endif
- ffebld expr = ffesymbol_sfexpr (s);
+/* ffestd_R1001dump_1010_1_ -- Dump a particular format
- ffestd_check_finish_ ();
+ ffesttFormatList f;
+ ffestd_R1001dump_1010_1_(f,"I");
- if (expr == NULL)
- return; /* Nothing to do, definition didn't work. */
+ The format is dumped with form X. */
-#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! */
+static void
+ffestd_R1001dump_1010_1_ (ffests s, ffesttFormatList f, const char *string)
+{
+ assert (!f->u.R1010.val.present);
-#if 0 /* Must preserve the expression for gcc. */
- ffesymbol_set_sfexpr (s, NULL);
-#else
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
-#endif
-#else
-#error
-#endif
+ ffests_puts (s, string);
}
-/* ffestd_S3P4 -- INCLUDE line
+/* ffestd_R1001dump_1010_2_ -- Dump a particular format
- ffestd_S3P4(filename,filename_token);
+ ffesttFormatList f;
+ ffestd_R1001dump_1010_2_(f,"I");
- Make sure INCLUDE not preceded by any semicolons or a label def; implement. */
+ The format is dumped with form [r]X. */
-void
-ffestd_S3P4 (ffebld filename)
+static void
+ffestd_R1001dump_1010_2_ (ffests s, ffesttFormatList f, const char *string)
{
- FILE *fi;
- ffetargetCharacterDefault buildname;
- ffewhereFile wf;
-
- ffestd_check_simple_ ();
-
- assert (filename != NULL);
- if (ffebld_op (filename) != FFEBLD_opANY)
+ if (f->u.R1010.val.present)
{
- 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);
+ if (f->u.R1010.val.rtexpr)
+ ffestd_R1001rtexpr_ (s, f, f->u.R1010.val.u.expr);
else
- ffelex_set_include (wf, (ffelex_token_type (ffesta_tokens[0])
- == FFELEX_typeNAME), fi);
+ ffests_printf (s, "%lu", f->u.R1010.val.u.unsigned_val);
}
+
+ ffests_puts (s, string);
}
-/* ffestd_V003_start -- STRUCTURE statement list begin
+/* ffestd_R1001dump_1010_4_ -- Dump a particular format
- ffestd_V003_start(structure_name);
+ ffesttFormatList f;
+ ffestd_R1001dump_1010_4_(f,"I");
- Verify that STRUCTURE is valid here, and begin accepting items in the list. */
+ The format is dumped with form kX. Note that k is signed. */
-#if FFESTR_VXT
-void
-ffestd_V003_start (ffelexToken structure_name)
+static void
+ffestd_R1001dump_1010_4_ (ffests s, ffesttFormatList f, const char *string)
{
- ffestd_check_start_ ();
+ assert (f->u.R1010.val.present);
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- if (structure_name == NULL)
- fputs ("* STRUCTURE_unnamed ", dmpout);
+ if (f->u.R1010.val.rtexpr)
+ ffestd_R1001rtexpr_ (s, f, f->u.R1010.val.u.expr);
else
- fprintf (dmpout, "* STRUCTURE %s ", ffelex_token_text (structure_name));
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
- ffestd_subr_vxt_ ();
-#else
-#error
-#endif
+ ffests_printf (s, "%ld", f->u.R1010.val.u.signed_val);
+
+ ffests_puts (s, string);
}
-/* ffestd_V003_item -- STRUCTURE statement for object-name
+/* ffestd_R1001dump_1010_5_ -- Dump a particular format
- ffestd_V003_item(name_token,dim_list);
+ ffesttFormatList f;
+ ffestd_R1001dump_1010_5_(f,"I");
- Make sure name_token identifies a valid object to be STRUCTUREd. */
+ The format is dumped with form Xn. */
-void
-ffestd_V003_item (ffelexToken name, ffesttDimList dims)
+static void
+ffestd_R1001dump_1010_5_ (ffests s, ffesttFormatList f, const char *string)
{
- ffestd_check_item_ ();
+ assert (f->u.R1010.val.present);
-#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
+ ffests_puts (s, string);
+
+ if (f->u.R1010.val.rtexpr)
+ ffestd_R1001rtexpr_ (s, f, f->u.R1010.val.u.expr);
+ else
+ ffests_printf (s, "%lu", f->u.R1010.val.u.unsigned_val);
}
-/* ffestd_V003_finish -- STRUCTURE statement list complete
+/* ffestd_R1001error_ -- Complain about FORMAT specification not supported
- ffestd_V003_finish();
+ ffesttFormatList f;
+ ffestd_R1001error_(f);
- Just wrap up any local activities. */
+ An error message is produced. */
-void
-ffestd_V003_finish ()
+static void
+ffestd_R1001error_ (ffesttFormatList f)
{
- ffestd_check_finish_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputc ('\n', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
+ ffebad_start (FFEBAD_FORMAT_UNSUPPORTED);
+ ffebad_here (0, ffelex_token_where_line (f->t), ffelex_token_where_column (f->t));
+ ffebad_finish ();
}
-/* ffestd_V004 -- End a STRUCTURE
+static void
+ffestd_R1001rtexpr_ (ffests s, ffesttFormatList f, ffebld expr)
+{
+ if ((expr == NULL)
+ || (ffebld_op (expr) != FFEBLD_opCONTER)
+ || (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeINTEGER)
+ || (ffeinfo_kindtype (ffebld_info (expr)) == FFEINFO_kindtypeINTEGER4))
+ {
+ ffebad_start (FFEBAD_FORMAT_VARIABLE);
+ ffebad_here (0, ffelex_token_where_line (f->t), ffelex_token_where_column (f->t));
+ ffebad_finish ();
+ }
+ else
+ {
+ int val;
+
+ switch (ffeinfo_kindtype (ffebld_info (expr)))
+ {
+#if FFETARGET_okINTEGER1
+ case FFEINFO_kindtypeINTEGER1:
+ val = ffebld_constant_integer1 (ffebld_conter (expr));
+ break;
+#endif
- ffestd_V004(TRUE); */
+#if FFETARGET_okINTEGER2
+ case FFEINFO_kindtypeINTEGER2:
+ val = ffebld_constant_integer2 (ffebld_conter (expr));
+ break;
+#endif
-void
-ffestd_V004 (bool ok)
-{
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("* END_STRUCTURE\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
+#if FFETARGET_okINTEGER3
+ case FFEINFO_kindtypeINTEGER3:
+ val = ffebld_constant_integer3 (ffebld_conter (expr));
+ break;
#endif
+
+ default:
+ assert ("bad INTEGER constant kind type" == NULL);
+ /* Fall through. */
+ case FFEINFO_kindtypeANY:
+ return;
+ }
+ ffests_printf (s, "%ld", (long) val);
+ }
}
-/* ffestd_V009 -- UNION statement
+/* ffestd_R1102 -- PROGRAM statement
+
+ ffestd_R1102(name_token);
- ffestd_V009(); */
+ 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_V009 ()
+ffestd_R1102 (ffesymbol s, ffelexToken name UNUSED)
{
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
+ assert (ffestd_block_level_ == 0);
+ ffestd_is_reachable_ = TRUE;
- ffestd_V010(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. */
-void
-ffestd_V010 (bool ok)
-{
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("* END_UNION\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
+ ffestw_set_sym (ffestw_stack_top (), s);
}
-/* ffestd_V012 -- MAP statement
+/* ffestd_R1103 -- End a PROGRAM
- ffestd_V012(); */
+ ffestd_R1103(); */
void
-ffestd_V012 ()
+ffestd_R1103 (bool ok UNUSED)
{
- ffestd_check_simple_ ();
+ ffestdStmt_ stmt;
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("* MAP\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
-}
+ assert (ffestd_block_level_ == 0);
-/* ffestd_V013 -- End a MAP
+ if (FFESTD_IS_END_OPTIMIZED_ && ffestd_is_reachable_)
+ ffestd_R842 (NULL); /* Generate STOP. */
- ffestd_V013(TRUE); */
+ if (ffestw_state (ffestw_stack_top ()) != FFESTV_statePROGRAM5)
+ ffestd_subr_labels_ (FALSE);/* Handle any undefined labels. */
-void
-ffestd_V013 (bool ok)
-{
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("* END_MAP\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR1103_);
+ ffestd_stmt_append_ (stmt);
}
-#endif
-/* ffestd_V014_start -- VOLATILE statement list begin
+/* ffestd_R1111 -- BLOCK DATA statement
- ffestd_V014_start();
+ ffestd_R1111(name_token);
- Verify that VOLATILE is valid here, and begin accepting items in the list. */
+ 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_V014_start ()
+ffestd_R1111 (ffesymbol s, ffelexToken name UNUSED)
{
- 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. */
+ assert (ffestd_block_level_ == 0);
+ ffestd_is_reachable_ = TRUE;
-void
-ffestd_V014_item_object (ffelexToken name UNUSED)
-{
- ffestd_check_item_ ();
+ ffestd_check_simple_ ();
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fprintf (dmpout, "%s,", ffelex_token_text (name));
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
+ ffecom_notify_primary_entry (s);
+ ffestw_set_sym (ffestw_stack_top (), s);
}
-/* ffestd_V014_item_cblock -- VOLATILE statement for common-block-name
-
- ffestd_V014_item_cblock(name_token);
+/* ffestd_R1112 -- End a BLOCK DATA
- Make sure name_token identifies a valid common block to be VOLATILEd. */
+ ffestd_R1112(TRUE); */
void
-ffestd_V014_item_cblock (ffelexToken name UNUSED)
+ffestd_R1112 (bool ok 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
+ ffestdStmt_ stmt;
- ffestd_V014_finish();
+ assert (ffestd_block_level_ == 0);
- Just wrap up any local activities. */
+ /* Generate any return-like code here (not likely for BLOCK DATA!). */
-void
-ffestd_V014_finish ()
-{
- ffestd_check_finish_ ();
+ if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateBLOCKDATA5)
+ ffestd_subr_labels_ (TRUE); /* Handle any undefined labels. */
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs (")\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR1112_);
+ ffestd_stmt_append_ (stmt);
}
-/* ffestd_V016_start -- RECORD statement list begin
+/* ffestd_R1207_start -- EXTERNAL statement list begin
- ffestd_V016_start();
+ ffestd_R1207_start();
- Verify that RECORD is valid here, and begin accepting items in the list. */
+ Verify that EXTERNAL is valid here, and begin accepting items in the list. */
-#if FFESTR_VXT
void
-ffestd_V016_start ()
+ffestd_R1207_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_R1207_item -- EXTERNAL statement for name
- ffestd_V016_item_object(name_token,dim_list);
+ ffestd_R1207_item(name_token);
- Make sure name_token identifies a valid object to be RECORDd. */
+ Make sure name_token identifies a valid object to be EXTERNALd. */
void
-ffestd_V016_item_object (ffelexToken name, ffesttDimList dims)
+ffestd_R1207_item (ffelexToken name)
{
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
+ assert (name != NULL);
}
-/* ffestd_V016_finish -- RECORD statement list complete
+/* ffestd_R1207_finish -- EXTERNAL statement list complete
- ffestd_V016_finish();
+ ffestd_R1207_finish();
Just wrap up any local activities. */
void
-ffestd_V016_finish ()
+ffestd_R1207_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_R1208_start -- INTRINSIC statement list begin
- ffestd_V018_start();
+ ffestd_R1208_start();
- Verify that REWRITE is valid here, and begin accepting items in the
- list. */
+ Verify that INTRINSIC is valid here, and begin accepting items in the list. */
void
-ffestd_V018_start (ffestvFormat format)
+ffestd_R1208_start ()
{
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_R1208_item -- INTRINSIC statement for name
- ffestd_V018_item(expr,expr_token);
+ ffestd_R1208_item(name_token);
- Implement output-list expression. */
+ Make sure name_token identifies a valid object to be INTRINSICd. */
void
-ffestd_V018_item (ffebld expr)
+ffestd_R1208_item (ffelexToken name)
{
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
+ assert (name != NULL);
}
-/* ffestd_V018_finish -- REWRITE statement list complete
+/* ffestd_R1208_finish -- INTRINSIC statement list complete
- ffestd_V018_finish();
+ ffestd_R1208_finish();
Just wrap up any local activities. */
void
-ffestd_V018_finish ()
+ffestd_R1208_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_R1212 -- CALL statement
- ffestd_V019_start();
+ ffestd_R1212(expr,expr_token);
- Verify that ACCEPT is valid here, and begin accepting items in the
- list. */
+ Make sure statement is valid here; implement. */
void
-ffestd_V019_start (ffestvFormat format)
+ffestd_R1212 (ffebld expr)
{
- ffestd_check_start_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
+ ffestdStmt_ stmt;
-#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
+ ffestd_check_simple_ ();
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
- ffestd_subr_vxt_ ();
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR1212_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R1212.pool = ffesta_output_pool;
+ stmt->u.R1212.expr = expr;
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
}
-/* ffestd_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_R1219 -- FUNCTION statement
-/* ffestd_V019_finish -- ACCEPT statement list complete
+ ffestd_R1219(funcname,arglist,ending_token,kind,kindt,len,lent,
+ recursive);
- ffestd_V019_finish();
+ Make sure statement is valid here, register arguments for the
+ function name, and so on.
- Just wrap up any local activities. */
+ 06-Jun-90 JCB 2.0
+ Added the kind, len, and recursive arguments. */
void
-ffestd_V019_finish ()
+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)
{
- ffestd_check_finish_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
+ assert (ffestd_block_level_ == 0);
+ ffestd_is_reachable_ = TRUE;
-#if FFECOM_ONEPASS
- ffeste_V019_finish ();
-#else
- /* Nothing to do, it's implicit. */
-#endif
+ ffestd_check_simple_ ();
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-#endif
+ ffecom_notify_primary_entry (s);
+ ffestw_set_sym (ffestw_stack_top (), s);
}
-#endif
-/* ffestd_V020_start -- TYPE statement list begin
-
- ffestd_V020_start();
+/* ffestd_R1221 -- End a FUNCTION
- Verify that TYPE is valid here, and begin accepting items in the
- list. */
+ ffestd_R1221(TRUE); */
void
-ffestd_V020_start (ffestvFormat format UNUSED)
+ffestd_R1221 (bool ok UNUSED)
{
- ffestd_check_start_ ();
+ ffestdStmt_ stmt;
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
+ assert (ffestd_block_level_ == 0);
-#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
+ if (FFESTD_IS_END_OPTIMIZED_ && ffestd_is_reachable_)
+ ffestd_R1227 (NULL); /* Generate RETURN. */
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
- ffestd_subr_vxt_ ();
-#endif
+ if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateFUNCTION5)
+ ffestd_subr_labels_ (FALSE);/* Handle any undefined labels. */
+
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR1221_);
+ ffestd_stmt_append_ (stmt);
}
-/* ffestd_V020_item -- TYPE statement i/o item
+/* ffestd_R1223 -- SUBROUTINE statement
- ffestd_V020_item(expr,expr_token);
+ ffestd_R1223(subrname,arglist,ending_token,recursive_token);
- Implement output-list expression. */
+ 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_V020_item (ffebld expr UNUSED)
+ffestd_R1223 (ffesymbol s, ffelexToken subrname UNUSED,
+ ffesttTokenList args UNUSED, ffelexToken final UNUSED,
+ bool recursive UNUSED)
{
- ffestd_check_item_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
+ assert (ffestd_block_level_ == 0);
+ ffestd_is_reachable_ = TRUE;
-#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
+ ffestd_check_simple_ ();
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-#endif
+ ffecom_notify_primary_entry (s);
+ ffestw_set_sym (ffestw_stack_top (), s);
}
-/* ffestd_V020_finish -- TYPE statement list complete
-
- ffestd_V020_finish();
+/* ffestd_R1225 -- End a SUBROUTINE
- Just wrap up any local activities. */
+ ffestd_R1225(TRUE); */
void
-ffestd_V020_finish ()
+ffestd_R1225 (bool ok UNUSED)
{
- ffestd_check_finish_ ();
+ ffestdStmt_ stmt;
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
+ assert (ffestd_block_level_ == 0);
-#if FFECOM_ONEPASS
- ffeste_V020_finish ();
-#else
- /* Nothing to do, it's implicit. */
-#endif
+ if (FFESTD_IS_END_OPTIMIZED_ && ffestd_is_reachable_)
+ ffestd_R1227 (NULL); /* Generate RETURN. */
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-#endif
+ if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateSUBROUTINE5)
+ ffestd_subr_labels_ (FALSE);/* Handle any undefined labels. */
+
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR1225_);
+ ffestd_stmt_append_ (stmt);
}
-/* ffestd_V021 -- DELETE statement
+/* ffestd_R1226 -- ENTRY statement
- ffestd_V021();
+ ffestd_R1226(entryname,arglist,ending_token);
- Make sure a DELETE is valid in the current context, and implement it. */
+ Make sure we're in a SUBROUTINE or FUNCTION, register arguments for the
+ entry point name, and so on. */
-#if FFESTR_VXT
void
-ffestd_V021 ()
+ffestd_R1226 (ffesymbol entry)
{
ffestd_check_simple_ ();
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
+ if (!ffesta_seen_first_exec || ffecom_2pass_advise_entrypoint (entry))
+ {
+ ffestdStmt_ stmt;
-#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
+ 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
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
- ffestd_subr_vxt_ ();
-#endif
+ ffestd_is_reachable_ = TRUE;
}
-/* ffestd_V022 -- UNLOCK statement
+/* ffestd_R1227 -- RETURN statement
- ffestd_V022();
+ ffestd_R1227(expr);
- Make sure a UNLOCK is valid in the current context, and implement it. */
+ Make sure statement is valid here; implement. expr and expr_token are
+ both NULL if there was no expression. */
void
-ffestd_V022 ()
+ffestd_R1227 (ffebld expr)
{
- ffestd_check_simple_ ();
+ ffestdStmt_ stmt;
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
+ ffestd_check_simple_ ();
-#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
+ 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 FFECOM_targetCURRENT == FFECOM_targetGCC
- ffestd_subr_vxt_ ();
-#endif
+ if (ffestd_block_level_ == 0)
+ ffestd_is_reachable_ = FALSE;
}
-/* ffestd_V023_start -- ENCODE(...) statement list begin
+/* ffestd_R1229_start -- STMTFUNCTION statement begin
- ffestd_V023_start();
+ ffestd_R1229_start(func_name,func_arg_list,close_paren);
- Verify that ENCODE is valid here, and begin accepting items in the
- list. */
+ 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_V023_start ()
+ffestd_R1229_start (ffelexToken name UNUSED, ffesttTokenList args UNUSED)
{
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
+/* ffestd_R1229_finish -- STMTFUNCTION statement list complete
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
- ffestd_subr_vxt_ ();
-#endif
-}
+ ffestd_R1229_finish(s);
-/* ffestd_V023_item -- ENCODE statement i/o item
+ 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.
- ffestd_V023_item(expr,expr_token);
+ 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.
- Implement output-list expression. */
+ 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_V023_item (ffebld expr)
+ffestd_R1229_finish (ffesymbol s)
{
- ffestd_check_item_ ();
+ ffebld expr = ffesymbol_sfexpr (s);
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
+ ffestd_check_finish_ ();
-#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
+ if (expr == NULL)
+ return; /* Nothing to do, definition didn't work. */
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-#endif
+ /* With gcc, cannot do anything here, because the backend hasn't even
+ (necessarily) been notified that we're compiling a program unit! */
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
}
-/* ffestd_V023_finish -- ENCODE statement list complete
+/* ffestd_S3P4 -- INCLUDE line
- ffestd_V023_finish();
+ ffestd_S3P4(filename,filename_token);
- Just wrap up any local activities. */
+ Make sure INCLUDE not preceded by any semicolons or a label def; implement. */
void
-ffestd_V023_finish ()
+ffestd_S3P4 (ffebld filename)
{
- ffestd_check_finish_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
+ FILE *fi;
+ ffetargetCharacterDefault buildname;
+ ffewhereFile wf;
-#if FFECOM_ONEPASS
- ffeste_V023_finish ();
-#else
- /* Nothing to do, it's implicit. */
-#endif
+ ffestd_check_simple_ ();
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-#endif
+ assert (filename != NULL);
+ if (ffebld_op (filename) != FFEBLD_opANY)
+ {
+ assert (ffebld_op (filename) == FFEBLD_opCONTER);
+ assert (ffeinfo_basictype (ffebld_info (filename))
+ == FFEINFO_basictypeCHARACTER);
+ assert (ffeinfo_kindtype (ffebld_info (filename))
+ == FFEINFO_kindtypeCHARACTERDEFAULT);
+ buildname = ffebld_constant_characterdefault (ffebld_conter (filename));
+ wf = ffewhere_file_new (ffetarget_text_characterdefault (buildname),
+ ffetarget_length_characterdefault (buildname));
+ fi = ffecom_open_include (ffewhere_file_name (wf),
+ ffelex_token_where_line (ffesta_tokens[0]),
+ ffelex_token_where_column (ffesta_tokens[0]));
+ if (fi != NULL)
+ ffelex_set_include (wf, (ffelex_token_type (ffesta_tokens[0])
+ == FFELEX_typeNAME), fi);
+ }
}
-/* ffestd_V024_start -- DECODE(...) statement list begin
+/* ffestd_V014_start -- VOLATILE statement list begin
- ffestd_V024_start();
+ ffestd_V014_start();
- Verify that DECODE is valid here, and begin accepting items in the
- list. */
+ Verify that VOLATILE is valid here, and begin accepting items in the list. */
void
-ffestd_V024_start ()
+ffestd_V014_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_V014_item_object -- VOLATILE statement for object-name
- ffestd_V024_item(expr,expr_token);
+ ffestd_V014_item_object(name_token);
- Implement output-list expression. */
+ Make sure name_token identifies a valid object to be VOLATILEd. */
void
-ffestd_V024_item (ffebld expr)
+ffestd_V014_item_object (ffelexToken name UNUSED)
{
ffestd_check_item_ ();
+}
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
+/* ffestd_V014_item_cblock -- VOLATILE statement for common-block-name
-#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
+ ffestd_V014_item_cblock(name_token);
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-#endif
+ Make sure name_token identifies a valid common block to be VOLATILEd. */
+
+void
+ffestd_V014_item_cblock (ffelexToken name UNUSED)
+{
+ ffestd_check_item_ ();
}
-/* ffestd_V024_finish -- DECODE statement list complete
+/* ffestd_V014_finish -- VOLATILE statement list complete
- ffestd_V024_finish();
+ ffestd_V014_finish();
Just wrap up any local activities. */
void
-ffestd_V024_finish ()
+ffestd_V014_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_V020_start -- TYPE statement list begin
- ffestd_V025_start();
+ ffestd_V020_start();
- Verify that DEFINEFILE is valid here, and begin accepting items in the
+ Verify that TYPE is valid here, and begin accepting items in the
list. */
void
-ffestd_V025_start ()
+ffestd_V020_start (ffestvFormat format UNUSED)
{
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_V020_item -- TYPE statement i/o item
- ffestd_V025_item(u,ut,m,mt,n,nt,asv,asvt);
+ ffestd_V020_item(expr,expr_token);
- Implement item. Treat each item kind of like a separate statement,
- since there's really no need to treat them as an aggregate. */
+ Implement output-list expression. */
void
-ffestd_V025_item (ffebld u, ffebld m, ffebld n, ffebld asv)
+ffestd_V020_item (ffebld expr UNUSED)
{
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_V020_finish -- TYPE statement list complete
- ffestd_V025_finish();
+ ffestd_V020_finish();
Just wrap up any local activities. */
void
-ffestd_V025_finish ()
+ffestd_V020_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();
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 (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 ()
{
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_ ();
+ ffestdStmt_ stmt;
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R841 ();
-#else
- {
- ffestdStmt_ stmt;
+ ffestd_check_simple_ ();
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR841_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- }
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR841_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
}
OSDN Git Service
