/* stb.c -- Implementation File (module.c template V1.0)
- Copyright (C) 1995, 1996, 2002 Free Software Foundation, Inc.
+ Copyright (C) 1995, 1996, 2002, 2003
+ Free Software Foundation, Inc.
Contributed by James Craig Burley.
This file is part of GNU Fortran.
ffestrOther kw;
}
varlist;
-#if FFESTR_F90
- struct
- {
- ffestrOther kw;
- }
- type;
-#endif
struct
{
ffelexHandler next;
bool complained; /* If run-time expr seen in nonexec context. */
}
format;
-#if FFESTR_F90
- struct
- {
- bool started;
- }
- moduleprocedure;
-#endif
struct
{
ffebld expr;
ffesttCaseList cases;
}
case_stmt;
-#if FFESTR_F90
- struct
- {
- ffesttExprList exprs;
- ffebld expr;
- }
- heap;
-#endif
-#if FFESTR_F90
- struct
- {
- ffesttExprList exprs;
- }
- R624;
-#endif
-#if FFESTR_F90
- struct
- {
- ffestpDefinedOperator operator;
- bool assignment; /* TRUE for INTERFACE ASSIGNMENT, FALSE for
- ...OPERATOR. */
- bool slash; /* TRUE if OPEN_ARRAY, FALSE if OPEN_PAREN. */
- }
- interface;
-#endif
struct
{
bool is_cblock;
}
V014;
-#if FFESTR_VXT
- struct
- {
- bool started;
- ffebld u;
- ffebld m;
- ffebld n;
- ffebld asv;
- }
- V025;
-#endif
struct
{
ffestpBeruIx ix;
ffeexprContext context;
}
write;
-#if FFESTR_F90
- struct
- {
- bool started;
- }
- structure;
-#endif
struct
{
bool started;
ffelexToken t);
static ffelexHandler ffestb_decl_typeparams_3_ (ffelexToken ft, ffebld expr,
ffelexToken t);
-#if FFESTR_F90
-static ffelexHandler ffestb_decl_typetype1_ (ffelexToken t);
-static ffelexHandler ffestb_decl_typetype2_ (ffelexToken t);
-#endif
static ffelexHandler ffestb_subr_label_list_ (ffelexToken t);
static ffelexHandler ffestb_subr_label_list_1_ (ffelexToken t);
static ffelexHandler ffestb_do1_ (ffelexToken t);
ffelexToken t);
static ffelexHandler ffestb_let2_ (ffelexToken ft, ffebld expr,
ffelexToken t);
-#if FFESTR_F90
-static ffelexHandler ffestb_type1_ (ffelexToken t);
-static ffelexHandler ffestb_type2_ (ffelexToken t);
-static ffelexHandler ffestb_type3_ (ffelexToken t);
-static ffelexHandler ffestb_type4_ (ffelexToken t);
-#endif
-#if FFESTR_F90
-static ffelexHandler ffestb_varlist1_ (ffelexToken t);
-static ffelexHandler ffestb_varlist2_ (ffelexToken t);
-static ffelexHandler ffestb_varlist3_ (ffelexToken t);
-static ffelexHandler ffestb_varlist4_ (ffelexToken t);
-#endif
static ffelexHandler ffestb_varlist5_ (ffelexToken t);
static ffelexHandler ffestb_varlist6_ (ffelexToken t);
-#if FFESTR_F90
-static ffelexHandler ffestb_where1_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffestb_where2_ (ffelexToken t);
-static ffelexHandler ffestb_where3_ (ffelexToken t);
-#endif
static ffelexHandler ffestb_R5221_ (ffelexToken t);
static ffelexHandler ffestb_R5222_ (ffelexToken t);
static ffelexHandler ffestb_R5223_ (ffelexToken t);
ffelexToken t);
static ffelexHandler ffestb_construct1_ (ffelexToken t);
static ffelexHandler ffestb_construct2_ (ffelexToken t);
-#if FFESTR_F90
-static ffelexHandler ffestb_heap1_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffestb_heap2_ (ffelexToken t);
-static ffelexHandler ffestb_heap3_ (ffelexToken t);
-static ffelexHandler ffestb_heap4_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffestb_heap5_ (ffelexToken t);
-#endif
-#if FFESTR_F90
-static ffelexHandler ffestb_module1_ (ffelexToken t);
-static ffelexHandler ffestb_module2_ (ffelexToken t);
-static ffelexHandler ffestb_module3_ (ffelexToken t);
-#endif
static ffelexHandler ffestb_R8091_ (ffelexToken t);
static ffelexHandler ffestb_R8092_ (ffelexToken ft, ffebld expr,
ffelexToken t);
ffelexToken t);
static ffelexHandler ffestb_R100118_ (ffelexToken ft, ffebld expr,
ffelexToken t);
-#if FFESTR_F90
-static ffelexHandler ffestb_R11071_ (ffelexToken t);
-static ffelexHandler ffestb_R11072_ (ffelexToken t);
-static ffelexHandler ffestb_R11073_ (ffelexToken t);
-static ffelexHandler ffestb_R11074_ (ffelexToken t);
-static ffelexHandler ffestb_R11075_ (ffelexToken t);
-static ffelexHandler ffestb_R11076_ (ffelexToken t);
-static ffelexHandler ffestb_R11077_ (ffelexToken t);
-static ffelexHandler ffestb_R11078_ (ffelexToken t);
-static ffelexHandler ffestb_R11079_ (ffelexToken t);
-static ffelexHandler ffestb_R110710_ (ffelexToken t);
-static ffelexHandler ffestb_R110711_ (ffelexToken t);
-static ffelexHandler ffestb_R110712_ (ffelexToken t);
-#endif
-#if FFESTR_F90
-static ffelexHandler ffestb_R12021_ (ffelexToken t);
-static ffelexHandler ffestb_R12022_ (ffelexToken t);
-static ffelexHandler ffestb_R12023_ (ffelexToken t);
-static ffelexHandler ffestb_R12024_ (ffelexToken t);
-static ffelexHandler ffestb_R12025_ (ffelexToken t);
-static ffelexHandler ffestb_R12026_ (ffelexToken t);
-#endif
static ffelexHandler ffestb_S3P41_ (ffelexToken ft, ffebld expr,
ffelexToken t);
static ffelexHandler ffestb_V0141_ (ffelexToken t);
static ffelexHandler ffestb_V0142_ (ffelexToken t);
static ffelexHandler ffestb_V0143_ (ffelexToken t);
static ffelexHandler ffestb_V0144_ (ffelexToken t);
-#if FFESTR_VXT
-static ffelexHandler ffestb_V0251_ (ffelexToken t);
-static ffelexHandler ffestb_V0252_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffestb_V0253_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffestb_V0254_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffestb_V0255_ (ffelexToken t);
-static ffelexHandler ffestb_V0256_ (ffelexToken t);
-static ffelexHandler ffestb_V0257_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffestb_V0258_ (ffelexToken t);
-#endif
#if FFESTB_KILL_EASY_
static void ffestb_subr_kill_easy_ (ffestpInquireIx max);
#else
static ffelexHandler ffestb_beru8_ (ffelexToken t);
static ffelexHandler ffestb_beru9_ (ffelexToken t);
static ffelexHandler ffestb_beru10_ (ffelexToken t);
-#if FFESTR_VXT
-static ffelexHandler ffestb_vxtcode1_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffestb_vxtcode2_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffestb_vxtcode3_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffestb_vxtcode4_ (ffelexToken t);
-static ffelexHandler ffestb_vxtcode5_ (ffelexToken t);
-static ffelexHandler ffestb_vxtcode6_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffestb_vxtcode7_ (ffelexToken t);
-static ffelexHandler ffestb_vxtcode8_ (ffelexToken t);
-static ffelexHandler ffestb_vxtcode9_ (ffelexToken t);
-static ffelexHandler ffestb_vxtcode10_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-#endif
static ffelexHandler ffestb_R9041_ (ffelexToken t);
static ffelexHandler ffestb_R9042_ (ffelexToken t);
static ffelexHandler ffestb_R9043_ (ffelexToken ft, ffebld expr,
static ffelexHandler ffestb_R92310_ (ffelexToken t);
static ffelexHandler ffestb_R92311_ (ffelexToken ft, ffebld expr,
ffelexToken t);
-#if FFESTR_VXT
-static ffelexHandler ffestb_V0181_ (ffelexToken t);
-static ffelexHandler ffestb_V0182_ (ffelexToken t);
-static ffelexHandler ffestb_V0183_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffestb_V0184_ (ffelexToken t);
-static ffelexHandler ffestb_V0185_ (ffelexToken t);
-static ffelexHandler ffestb_V0186_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffestb_V0187_ (ffelexToken t);
-static ffelexHandler ffestb_V0188_ (ffelexToken t);
-static ffelexHandler ffestb_V0189_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffestb_V01810_ (ffelexToken t);
-static ffelexHandler ffestb_V01811_ (ffelexToken t);
-static ffelexHandler ffestb_V01812_ (ffelexToken t);
-static ffelexHandler ffestb_V01813_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffestb_V0191_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffestb_V0192_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-#endif
static ffelexHandler ffestb_V0201_ (ffelexToken ft, ffebld expr,
ffelexToken t);
static ffelexHandler ffestb_V0202_ (ffelexToken ft, ffebld expr,
ffelexToken t);
-#if FFESTR_VXT
-static ffelexHandler ffestb_V0211_ (ffelexToken t);
-static ffelexHandler ffestb_V0212_ (ffelexToken t);
-static ffelexHandler ffestb_V0213_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffestb_V0214_ (ffelexToken t);
-static ffelexHandler ffestb_V0215_ (ffelexToken t);
-static ffelexHandler ffestb_V0216_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffestb_V0217_ (ffelexToken t);
-static ffelexHandler ffestb_V0218_ (ffelexToken t);
-static ffelexHandler ffestb_V0219_ (ffelexToken t);
-static ffelexHandler ffestb_V0261_ (ffelexToken t);
-static ffelexHandler ffestb_V0262_ (ffelexToken t);
-static ffelexHandler ffestb_V0263_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffestb_V0264_ (ffelexToken t);
-static ffelexHandler ffestb_V0265_ (ffelexToken t);
-static ffelexHandler ffestb_V0266_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffestb_V0267_ (ffelexToken t);
-static ffelexHandler ffestb_V0268_ (ffelexToken t);
-static ffelexHandler ffestb_V0269_ (ffelexToken t);
-#endif
-#if FFESTR_F90
-static ffelexHandler ffestb_dimlist1_ (ffelexToken t);
-static ffelexHandler ffestb_dimlist2_ (ffelexToken t);
-static ffelexHandler ffestb_dimlist3_ (ffelexToken t);
-static ffelexHandler ffestb_dimlist4_ (ffelexToken t);
-#endif
static ffelexHandler ffestb_dummy1_ (ffelexToken t);
static ffelexHandler ffestb_dummy2_ (ffelexToken t);
static ffelexHandler ffestb_R5241_ (ffelexToken t);
static ffelexHandler ffestb_R5475_ (ffelexToken t);
static ffelexHandler ffestb_R5476_ (ffelexToken t);
static ffelexHandler ffestb_R5477_ (ffelexToken t);
-#if FFESTR_F90
-static ffelexHandler ffestb_R6241_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffestb_R6242_ (ffelexToken t);
-#endif
static ffelexHandler ffestb_R12291_ (ffelexToken t);
static ffelexHandler ffestb_R12292_ (ffelexToken ft, ffebld expr,
ffelexToken t);
static ffelexHandler ffestb_decl_chartype1_ (ffelexToken t);
-#if FFESTR_F90
-static ffelexHandler ffestb_decl_recursive1_ (ffelexToken t);
-static ffelexHandler ffestb_decl_recursive2_ (ffelexToken t);
-static ffelexHandler ffestb_decl_recursive3_ (ffelexToken t);
-static ffelexHandler ffestb_decl_recursive4_ (ffelexToken t);
-#endif
static ffelexHandler ffestb_decl_attrs_ (ffelexToken t);
static ffelexHandler ffestb_decl_attrs_1_ (ffelexToken t);
static ffelexHandler ffestb_decl_attrs_2_ (ffelexToken t);
-#if FFESTR_F90
-static ffelexHandler ffestb_decl_attrs_3_ (ffelexToken t);
-static ffelexHandler ffestb_decl_attrs_4_ (ffelexToken t);
-static ffelexHandler ffestb_decl_attrs_5_ (ffelexToken t);
-static ffelexHandler ffestb_decl_attrs_6_ (ffelexToken t);
-#endif
static ffelexHandler ffestb_decl_attrs_7_ (ffelexToken t);
static ffelexHandler ffestb_decl_attrsp_ (ffelexToken t);
static ffelexHandler ffestb_decl_ents_ (ffelexToken t);
static ffelexHandler ffestb_decl_entsp_6_ (ffelexToken t);
static ffelexHandler ffestb_decl_entsp_7_ (ffelexToken t);
static ffelexHandler ffestb_decl_entsp_8_ (ffelexToken t);
-#if FFESTR_F90
-static ffelexHandler ffestb_decl_func_ (ffelexToken t);
-#endif
static ffelexHandler ffestb_decl_funcname_ (ffelexToken t);
static ffelexHandler ffestb_decl_funcname_1_ (ffelexToken t);
static ffelexHandler ffestb_decl_funcname_2_ (ffelexToken t);
static ffelexHandler ffestb_decl_funcname_7_ (ffelexToken t);
static ffelexHandler ffestb_decl_funcname_8_ (ffelexToken t);
static ffelexHandler ffestb_decl_funcname_9_ (ffelexToken t);
-#if FFESTR_VXT
-static ffelexHandler ffestb_V0031_ (ffelexToken t);
-static ffelexHandler ffestb_V0032_ (ffelexToken t);
-static ffelexHandler ffestb_V0033_ (ffelexToken t);
-static ffelexHandler ffestb_V0034_ (ffelexToken t);
-static ffelexHandler ffestb_V0035_ (ffelexToken t);
-static ffelexHandler ffestb_V0036_ (ffelexToken t);
-static ffelexHandler ffestb_V0161_ (ffelexToken t);
-static ffelexHandler ffestb_V0162_ (ffelexToken t);
-static ffelexHandler ffestb_V0163_ (ffelexToken t);
-static ffelexHandler ffestb_V0164_ (ffelexToken t);
-static ffelexHandler ffestb_V0165_ (ffelexToken t);
-static ffelexHandler ffestb_V0166_ (ffelexToken t);
-#endif
static ffelexHandler ffestb_V0271_ (ffelexToken t);
static ffelexHandler ffestb_V0272_ (ffelexToken ft, ffebld expr,
ffelexToken t);
static ffelexHandler ffestb_V0273_ (ffelexToken t);
static ffelexHandler ffestb_decl_R5391_ (ffelexToken t);
static ffelexHandler ffestb_decl_R5392_ (ffelexToken t);
-#if FFESTR_F90
-static ffelexHandler ffestb_decl_R5393_ (ffelexToken t);
-#endif
static ffelexHandler ffestb_decl_R5394_ (ffelexToken t);
static ffelexHandler ffestb_decl_R5395_ (ffelexToken t);
static ffelexHandler ffestb_decl_R539letters_ (ffelexToken t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_decl_typetype1_ -- "TYPE" OPEN_PAREN
-
- return ffestb_decl_typetype1_; // to lexer
-
- Handle NAME. */
-
-#if FFESTR_F90
-static ffelexHandler
-ffestb_decl_typetype1_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- ffestb_local_.decl.kindt = ffelex_token_use (t);
- return (ffelexHandler) ffestb_decl_typetype2_;
-
- default:
- break;
- }
-
- if (ffestb_local_.decl.recursive != NULL)
- ffelex_token_kill (ffestb_local_.decl.recursive);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM,
- ffestb_local_.decl.badname,
- t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_decl_typetype2_ -- "TYPE" OPEN_PAREN NAME
-
- return ffestb_decl_typetype2_; // to lexer
-
- Handle CLOSE_PAREN. */
-
-static ffelexHandler
-ffestb_decl_typetype2_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCLOSE_PAREN:
- ffestb_local_.decl.type = FFESTP_typeTYPE;
- ffestb_local_.decl.kind = NULL;
- ffestb_local_.decl.len = NULL;
- ffestb_local_.decl.lent = NULL;
- ffelex_set_names (TRUE);
- return (ffelexHandler) ffestb_local_.decl.handler;
-
- default:
- break;
- }
-
- if (ffestb_local_.decl.recursive != NULL)
- ffelex_token_kill (ffestb_local_.decl.recursive);
- ffelex_token_kill (ffestb_local_.decl.kindt);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM,
- ffestb_local_.decl.badname,
- t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-#endif
/* ffestb_subr_label_list_ -- Collect a tokenlist of labels and close-paren
return ffestb_subr_label_list_; // to lexer after seeing OPEN_PAREN
p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlELSE);
ffesta_tokens[1]
= ffelex_token_name_from_names (ffesta_tokens[0], i, 0);
-#if FFESTR_F90
- if ((ffestb_args.elsexyz.second == FFESTR_secondWHERE)
- && (ffelex_token_length (ffesta_tokens[1]) != FFESTR_secondlWHERE))
- ffestb_args.elsexyz.second = FFESTR_secondNone;
-#endif
return (ffelexHandler) ffestb_else1_ (t);
default:
switch (ffestb_args.elsexyz.second)
{
-#if FFESTR_F90
- case FFESTR_secondWHERE:
- if (!ffesta_is_inhibited ())
- if ((ffesta_first_kw == FFESTR_firstELSEWHERE)
- && (ffelex_token_type (ffesta_tokens[0]) == FFELEX_typeNAME))
- ffestc_R744 ();
- else
- ffestc_elsewhere (ffesta_tokens[1]); /* R744 or R805. */
- break;
-#endif
default:
if (!ffesta_is_inhibited ())
case FFESTR_secondBLOCK:
return (ffelexHandler) ffestb_end1_;
-#if FFESTR_F90
- case FFESTR_secondINTERFACE:
-#endif
-#if FFESTR_VXT
- case FFESTR_secondMAP:
- case FFESTR_secondSTRUCTURE:
- case FFESTR_secondUNION:
-#endif
-#if FFESTR_F90
- case FFESTR_secondWHERE:
- ffesta_tokens[1] = NULL;
- return (ffelexHandler) ffestb_end3_;
-#endif
-
case FFESTR_secondNone:
goto bad_1; /* :::::::::::::::::::: */
ffesta_confirmed ();
switch (ffestb_args.endxyz.second)
{
-#if FFESTR_F90
- case FFESTR_secondINTERFACE:
-#endif
-#if FFESTR_VXT
- case FFESTR_secondMAP:
- case FFESTR_secondSTRUCTURE:
- case FFESTR_secondUNION:
-#endif
-#if FFESTR_F90
- case FFESTR_secondWHERE:
- goto bad_1; /* :::::::::::::::::::: */
-#endif
-
case FFESTR_secondBLOCK:
if (ffesta_second_kw != FFESTR_secondDATA)
goto bad_1; /* :::::::::::::::::::: */
{
p = ffelex_token_text (ffesta_tokens[0])
+ (i = ffestb_args.endxyz.len);
- switch (ffestb_args.endxyz.second)
- {
-#if FFESTR_F90
- case FFESTR_secondINTERFACE:
-#endif
-#if FFESTR_VXT
- case FFESTR_secondMAP:
- case FFESTR_secondSTRUCTURE:
- case FFESTR_secondUNION:
-#endif
-#if FFESTR_F90
- case FFESTR_secondWHERE:
- goto bad_i; /* :::::::::::::::::::: */
-#endif
-
- default:
- break;
- }
if (!ffesrc_is_name_init (*p))
goto bad_i; /* :::::::::::::::::::: */
ffesta_tokens[1]
switch (ffestb_args.endxyz.second)
{
-#if FFESTR_F90
- case FFESTR_secondTYPE:
- if (!ffesta_is_inhibited ())
- ffestc_R425 (ffesta_tokens[1]);
- break;
-#endif
-
-#if FFESTR_F90
- case FFESTR_secondWHERE:
- if (!ffesta_is_inhibited ())
- ffestc_R745 ();
- break;
-#endif
-
case FFESTR_secondIF:
if (!ffesta_is_inhibited ())
ffestc_R806 (ffesta_tokens[1]);
ffestc_R1103 (ffesta_tokens[1]);
break;
-#if FFESTR_F90
- case FFESTR_secondMODULE:
- if (!ffesta_is_inhibited ())
- ffestc_R1106 (ffesta_tokens[1]);
- break;
-#endif
case FFESTR_secondBLOCK:
case FFESTR_secondBLOCKDATA:
if (!ffesta_is_inhibited ())
ffestc_R1112 (ffesta_tokens[1]);
break;
-#if FFESTR_F90
- case FFESTR_secondINTERFACE:
- if (!ffesta_is_inhibited ())
- ffestc_R1203 ();
- break;
-#endif
-
case FFESTR_secondFUNCTION:
if (!ffesta_is_inhibited ())
ffestc_R1221 (ffesta_tokens[1]);
ffestc_R1225 (ffesta_tokens[1]);
break;
-#if FFESTR_VXT
- case FFESTR_secondSTRUCTURE:
- if (!ffesta_is_inhibited ())
- ffestc_V004 ();
- break;
-#endif
-
-#if FFESTR_VXT
- case FFESTR_secondUNION:
- if (!ffesta_is_inhibited ())
- ffestc_V010 ();
- break;
-#endif
-
-#if FFESTR_VXT
- case FFESTR_secondMAP:
- if (!ffesta_is_inhibited ())
- ffestc_V013 ();
- break;
-#endif
-
default:
ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "END", ffesta_tokens[0]);
if (ffesta_tokens[1] != NULL)
return (ffelexHandler) next;
}
-/* ffestb_where -- Parse a WHERE statement
+/* ffestb_let -- Parse an assignment statement
- return ffestb_where; // to lexer
+ return ffestb_let; // to lexer
- Make sure the statement has a valid form for a WHERE statement.
- If it does, implement the statement. */
+ Make sure the statement has a valid form for an assignment statement. If
+ it does, implement the statement. */
-#if FFESTR_F90
ffelexHandler
-ffestb_where (ffelexToken t)
+ffestb_let (ffelexToken t)
{
+ ffelexHandler next;
+ bool vxtparam; /* TRUE if it might really be a VXT PARAMETER
+ stmt. */
+ unsigned const char *p;
+
switch (ffelex_token_type (ffesta_tokens[0]))
{
case FFELEX_typeNAME:
- if (ffesta_first_kw != FFESTR_firstWHERE)
- goto bad_0; /* :::::::::::::::::::: */
+ vxtparam = FALSE;
break;
case FFELEX_typeNAMES:
- if (ffesta_first_kw != FFESTR_firstWHERE)
- goto bad_0; /* :::::::::::::::::::: */
- if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlWHERE)
- goto bad_0; /* :::::::::::::::::::: */
+ vxtparam = TRUE;
break;
default:
switch (ffelex_token_type (t))
{
case FFELEX_typeOPEN_PAREN:
+ case FFELEX_typePERCENT:
+ case FFELEX_typePOINTS:
+ ffestb_local_.let.vxtparam = FALSE;
break;
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
+ case FFELEX_typeEQUALS:
+ if (!vxtparam || (ffesta_first_kw != FFESTR_firstPARAMETER))
+ {
+ ffestb_local_.let.vxtparam = FALSE;
+ break;
+ }
+ p = ffelex_token_text (ffesta_tokens[0]) + FFESTR_firstlPARAMETER;
+ ffestb_local_.let.vxtparam = ffesrc_is_name_init (*p);
+ break;
default:
goto bad_1; /* :::::::::::::::::::: */
}
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, FFEEXPR_contextWHERE,
- (ffeexprCallback) ffestb_where1_);
+ next = (ffelexHandler) (*((ffelexHandler)
+ ffeexpr_lhs (ffesta_output_pool,
+ FFEEXPR_contextLET,
+ (ffeexprCallback) ffestb_let1_)))
+ (ffesta_tokens[0]);
+ return (ffelexHandler) (*next) (t);
bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "WHERE", ffesta_tokens[0]);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "assignment", ffesta_tokens[0]);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "WHERE", t);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "assignment", t);
return (ffelexHandler) ffelex_swallow_tokens (t,
(ffelexHandler) ffesta_zero); /* Invalid second token. */
}
-#endif
-/* ffestb_where1_ -- "WHERE" OPEN_PAREN expr
+/* ffestb_let1_ -- expr
- (ffestb_where1_) // to expression handler
+ (ffestb_let1_) // to expression handler
- Make sure the next token is CLOSE_PAREN. */
+ Make sure the next token is EQUALS or POINTS. */
-#if FFESTR_F90
static ffelexHandler
-ffestb_where1_ (ffelexToken ft, ffebld expr, ffelexToken t)
+ffestb_let1_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
{
- ffestb_local_.if_stmt.expr = expr;
+ ffestb_local_.let.dest = expr;
switch (ffelex_token_type (t))
{
- case FFELEX_typeCLOSE_PAREN:
+ case FFELEX_typeEQUALS:
if (expr == NULL)
break;
- ffesta_tokens[1] = ffelex_token_use (ft);
- ffelex_set_names (TRUE);
- return (ffelexHandler) ffestb_where2_;
+ ffesta_tokens[1] = ffelex_token_use (t);
+ return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ FFEEXPR_contextLET, (ffeexprCallback) ffestb_let2_);
default:
break;
}
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "WHERE", t);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "assignment", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-#endif
-/* ffestb_where2_ -- "WHERE" OPEN_PAREN expr CLOSE_PAREN
+/* ffestb_let2_ -- expr EQUALS/POINTS expr
- return ffestb_where2_; // to lexer
+ (ffestb_end2_) // to expression handler
- Make sure the next token is NAME. */
+ Make sure the next token is EOS or SEMICOLON; implement the statement. */
-#if FFESTR_F90
static ffelexHandler
-ffestb_where2_ (ffelexToken t)
+ffestb_let2_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
- ffelex_set_names (FALSE);
-
switch (ffelex_token_type (t))
{
- case FFELEX_typeNAME:
- case FFELEX_typeNAMES:
- ffesta_confirmed ();
- ffesta_tokens[2] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_where3_;
-
case FFELEX_typeEOS:
case FFELEX_typeSEMICOLON:
+ if (expr == NULL)
+ break;
+ if (ffestb_local_.let.vxtparam && !ffestc_is_let_not_V027 ())
+ break;
ffesta_confirmed ();
if (!ffesta_is_inhibited ())
- ffestc_R742 (ffestb_local_.if_stmt.expr, ffesta_tokens[1]);
+ ffestc_let (ffestb_local_.let.dest, expr, ft);
ffelex_token_kill (ffesta_tokens[1]);
return (ffelexHandler) ffesta_zero (t);
break;
}
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "WHERE", t);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM,
+ (ffelex_token_type (ffesta_tokens[1]) == FFELEX_typeEQUALS)
+ ? "assignment" : "pointer-assignment",
+ t);
ffelex_token_kill (ffesta_tokens[1]);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-#endif
-/* ffestb_where3_ -- "WHERE" OPEN_PAREN expr CLOSE_PAREN NAME
+/* ffestb_varlist -- Parse EXTERNAL/INTENT/INTRINSIC/OPTIONAL/PUBLIC/PRIVATE
+ statement
- return ffestb_where3_; // to lexer
+ return ffestb_varlist; // to lexer
- Implement R742. */
+ Make sure the statement has a valid form. If it
+ does, implement the statement. */
-#if FFESTR_F90
-static ffelexHandler
-ffestb_where3_ (ffelexToken t)
+ffelexHandler
+ffestb_varlist (ffelexToken t)
{
+ ffeTokenLength i;
+ unsigned const char *p;
+ ffelexToken nt;
ffelexHandler next;
- ffelexToken my_2 = ffesta_tokens[2];
- if (!ffesta_is_inhibited ())
- ffestc_R740 (ffestb_local_.if_stmt.expr, ffesta_tokens[1]);
- ffelex_token_kill (ffesta_tokens[1]);
- next = (ffelexHandler) ffesta_two (my_2, t);
- ffelex_token_kill (my_2);
- return (ffelexHandler) next;
-}
+ switch (ffelex_token_type (ffesta_tokens[0]))
+ {
+ case FFELEX_typeNAME:
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ ffesta_confirmed ();
+ goto bad_1; /* :::::::::::::::::::: */
-#endif
-/* ffestb_let -- Parse an assignment statement
+ case FFELEX_typeCOMMA:
+ ffesta_confirmed (); /* Error, but clearly intended. */
+ goto bad_1; /* :::::::::::::::::::: */
- return ffestb_let; // to lexer
+ case FFELEX_typeCOLONCOLON:
+ ffesta_confirmed ();
+ ffesta_confirmed (); /* Error, but clearly intended. */
+ goto bad_1; /* :::::::::::::::::::: */
- Make sure the statement has a valid form for an assignment statement. If
- it does, implement the statement. */
+ default:
+ goto bad_1; /* :::::::::::::::::::: */
-ffelexHandler
-ffestb_let (ffelexToken t)
-{
- ffelexHandler next;
- bool vxtparam; /* TRUE if it might really be a VXT PARAMETER
- stmt. */
- unsigned const char *p;
+ case FFELEX_typeOPEN_PAREN:
+ goto bad_1; /* :::::::::::::::::::: */
- switch (ffelex_token_type (ffesta_tokens[0]))
- {
- case FFELEX_typeNAME:
- vxtparam = FALSE;
- break;
+ case FFELEX_typeNAME:
+ ffesta_confirmed ();
+ switch (ffesta_first_kw)
+ {
+ case FFESTR_firstEXTERNAL:
+ if (!ffesta_is_inhibited ())
+ ffestc_R1207_start ();
+ break;
+
+ case FFESTR_firstINTRINSIC:
+ if (!ffesta_is_inhibited ())
+ ffestc_R1208_start ();
+ break;
+
+ default:
+ break;
+ }
+ return (ffelexHandler) ffestb_varlist5_ (t);
+ }
case FFELEX_typeNAMES:
- vxtparam = TRUE;
- break;
+ p = ffelex_token_text (ffesta_tokens[0]) + (i = ffestb_args.varlist.len);
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ ffesta_confirmed ();
+ if (*p != '\0')
+ break;
+ goto bad_1; /* :::::::::::::::::::: */
- default:
- goto bad_0; /* :::::::::::::::::::: */
- }
+ case FFELEX_typeCOMMA:
+ ffesta_confirmed (); /* Error, but clearly intended. */
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeOPEN_PAREN:
- case FFELEX_typePERCENT:
- case FFELEX_typePOINTS:
- ffestb_local_.let.vxtparam = FALSE;
- break;
+ if (*p != '\0')
+ break;
+ goto bad_1; /* :::::::::::::::::::: */
- case FFELEX_typeEQUALS:
- if (!vxtparam || (ffesta_first_kw != FFESTR_firstPARAMETER))
+ case FFELEX_typeCOLONCOLON:
+ ffesta_confirmed ();
+ goto bad_1; /* :::::::::::::::::::: */
+
+ case FFELEX_typeOPEN_PAREN:
+ goto bad_1; /* :::::::::::::::::::: */
+
+ case FFELEX_typeNAME:
+ ffesta_confirmed ();
+ switch (ffesta_first_kw)
+ {
+ case FFESTR_firstEXTERNAL:
+ if (!ffesta_is_inhibited ())
+ ffestc_R1207_start ();
+ break;
+
+ case FFESTR_firstINTRINSIC:
+ if (!ffesta_is_inhibited ())
+ ffestc_R1208_start ();
+ break;
+
+ default:
+ break;
+ }
+ return (ffelexHandler) ffestb_varlist5_ (t);
+
+ default:
+ goto bad_1; /* :::::::::::::::::::: */
+ }
+
+ /* Here, we have at least one char after the first keyword and t is
+ COMMA or EOS/SEMICOLON. Also we know that this form is valid for
+ only the statements reaching here (specifically, INTENT won't reach
+ here). */
+
+ if (!ffesrc_is_name_init (*p))
+ goto bad_i; /* :::::::::::::::::::: */
+ nt = ffelex_token_name_from_names (ffesta_tokens[0], i, 0);
+ if (!ffesta_is_inhibited ())
{
- ffestb_local_.let.vxtparam = FALSE;
- break;
+ switch (ffesta_first_kw)
+ {
+ case FFESTR_firstEXTERNAL:
+ ffestc_R1207_start ();
+ break;
+
+ case FFESTR_firstINTRINSIC:
+ ffestc_R1208_start ();
+ break;
+
+ default:
+ assert (FALSE);
+ }
}
- p = ffelex_token_text (ffesta_tokens[0]) + FFESTR_firstlPARAMETER;
- ffestb_local_.let.vxtparam = ffesrc_is_name_init (*p);
- break;
+ next = (ffelexHandler) ffestb_varlist5_ (nt);
+ ffelex_token_kill (nt);
+ return (ffelexHandler) (*next) (t);
default:
- goto bad_1; /* :::::::::::::::::::: */
+ goto bad_0; /* :::::::::::::::::::: */
}
- next = (ffelexHandler) (*((ffelexHandler)
- ffeexpr_lhs (ffesta_output_pool,
- FFEEXPR_contextLET,
- (ffeexprCallback) ffestb_let1_)))
- (ffesta_tokens[0]);
- return (ffelexHandler) (*next) (t);
-
bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "assignment", ffesta_tokens[0]);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.varlist.badname, ffesta_tokens[0]);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "assignment", t);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.varlist.badname, t);
return (ffelexHandler) ffelex_swallow_tokens (t,
(ffelexHandler) ffesta_zero); /* Invalid second token. */
+
+bad_i: /* :::::::::::::::::::: */
+ ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, ffestb_args.varlist.badname, ffesta_tokens[0], i, t);
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_let1_ -- expr
+/* ffestb_varlist5_ -- Handles the list of variable names
- (ffestb_let1_) // to expression handler
+ return ffestb_varlist5_; // to lexer
- Make sure the next token is EQUALS or POINTS. */
+ Handle NAME. */
static ffelexHandler
-ffestb_let1_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
+ffestb_varlist5_ (ffelexToken t)
{
- ffestb_local_.let.dest = expr;
-
switch (ffelex_token_type (t))
{
-#if FFESTR_F90
- case FFELEX_typePOINTS:
-#endif
- case FFELEX_typeEQUALS:
- if (expr == NULL)
- break;
+ case FFELEX_typeNAME:
ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextLET, (ffeexprCallback) ffestb_let2_);
+ return (ffelexHandler) ffestb_varlist6_;
default:
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.varlist.badname, t);
break;
}
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "assignment", t);
+ if (!ffesta_is_inhibited ())
+ {
+ switch (ffesta_first_kw)
+ {
+ case FFESTR_firstEXTERNAL:
+ ffestc_R1207_finish ();
+ break;
+
+ case FFESTR_firstINTRINSIC:
+ ffestc_R1208_finish ();
+ break;
+
+ default:
+ assert (FALSE);
+ }
+ }
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_let2_ -- expr EQUALS/POINTS expr
+/* ffestb_varlist6_ -- (whatever) NAME
- (ffestb_end2_) // to expression handler
+ return ffestb_varlist6_; // to lexer
- Make sure the next token is EOS or SEMICOLON; implement the statement. */
+ Handle COMMA or EOS/SEMICOLON. */
static ffelexHandler
-ffestb_let2_ (ffelexToken ft, ffebld expr, ffelexToken t)
+ffestb_varlist6_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
+ case FFELEX_typeCOMMA:
+ if (!ffesta_is_inhibited ())
+ {
+ switch (ffesta_first_kw)
+ {
+ case FFESTR_firstEXTERNAL:
+ ffestc_R1207_item (ffesta_tokens[1]);
+ break;
+
+ case FFESTR_firstINTRINSIC:
+ ffestc_R1208_item (ffesta_tokens[1]);
+ break;
+
+ default:
+ assert (FALSE);
+ }
+ }
+ ffelex_token_kill (ffesta_tokens[1]);
+ return (ffelexHandler) ffestb_varlist5_;
+
case FFELEX_typeEOS:
case FFELEX_typeSEMICOLON:
- if (expr == NULL)
- break;
- if (ffestb_local_.let.vxtparam && !ffestc_is_let_not_V027 ())
- break;
- ffesta_confirmed ();
if (!ffesta_is_inhibited ())
-#if FFESTR_F90
- if (ffelex_token_type (ffesta_tokens[1]) == FFELEX_typeEQUALS)
-#endif
- ffestc_let (ffestb_local_.let.dest, expr, ft);
-#if FFESTR_F90
- else
- ffestc_R738 (ffestb_local_.let.dest, expr, ft);
-#endif
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffesta_zero (t);
+ {
+ switch (ffesta_first_kw)
+ {
+ case FFESTR_firstEXTERNAL:
+ ffestc_R1207_item (ffesta_tokens[1]);
+ ffestc_R1207_finish ();
+ break;
- default:
- break;
- }
+ case FFESTR_firstINTRINSIC:
+ ffestc_R1208_item (ffesta_tokens[1]);
+ ffestc_R1208_finish ();
+ break;
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM,
- (ffelex_token_type (ffesta_tokens[1]) == FFELEX_typeEQUALS)
- ? "assignment" : "pointer-assignment",
- t);
+ default:
+ assert (FALSE);
+ }
+ }
+ ffelex_token_kill (ffesta_tokens[1]);
+ return (ffelexHandler) ffesta_zero (t);
+
+ default:
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.varlist.badname, t);
+ break;
+ }
+
+ if (!ffesta_is_inhibited ())
+ {
+ switch (ffesta_first_kw)
+ {
+ case FFESTR_firstEXTERNAL:
+ ffestc_R1207_finish ();
+ break;
+
+ case FFESTR_firstINTRINSIC:
+ ffestc_R1208_finish ();
+ break;
+
+ default:
+ assert (FALSE);
+ }
+ }
ffelex_token_kill (ffesta_tokens[1]);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_type -- Parse the TYPE statement
+/* ffestb_R522 -- Parse the SAVE statement
- return ffestb_type; // to lexer
+ return ffestb_R522; // to lexer
- Make sure the statement has a valid form for the TYPE statement. If
- it does, implement the statement. */
+ Make sure the statement has a valid form for the SAVE statement. If it
+ does, implement the statement. */
-#if FFESTR_F90
ffelexHandler
-ffestb_type (ffelexToken t)
+ffestb_R522 (ffelexToken t)
{
ffeTokenLength i;
- const char *p;
+ unsigned const char *p;
+ ffelexToken nt;
+ ffelexHandler next;
switch (ffelex_token_type (ffesta_tokens[0]))
{
case FFELEX_typeNAME:
- if (ffesta_first_kw != FFESTR_firstTYPE)
+ if (ffesta_first_kw != FFESTR_firstSAVE)
goto bad_0; /* :::::::::::::::::::: */
switch (ffelex_token_type (t))
{
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- case FFELEX_typeCOLONCOLON:
+ case FFELEX_typeCOMMA:
ffesta_confirmed (); /* Error, but clearly intended. */
goto bad_1; /* :::::::::::::::::::: */
default:
goto bad_1; /* :::::::::::::::::::: */
- case FFELEX_typeCOMMA:
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
ffesta_confirmed ();
- return (ffelexHandler) ffestb_type1_;
+ if (!ffesta_is_inhibited ())
+ ffestc_R522 ();
+ return (ffelexHandler) ffesta_zero (t);
- case FFELEX_typeNAME: /* No confirm here, because ambig w/V020 VXT
- TYPE. */
- ffesta_tokens[1] = NULL;
- ffesta_tokens[2] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_type4_;
+ case FFELEX_typeNAME:
+ case FFELEX_typeSLASH:
+ ffesta_confirmed ();
+ if (!ffesta_is_inhibited ())
+ ffestc_R522start ();
+ return (ffelexHandler) ffestb_R5221_ (t);
+
+ case FFELEX_typeCOLONCOLON:
+ ffesta_confirmed ();
+ if (!ffesta_is_inhibited ())
+ ffestc_R522start ();
+ return (ffelexHandler) ffestb_R5221_;
}
case FFELEX_typeNAMES:
- if (ffesta_first_kw != FFESTR_firstTYPE)
+ if (ffesta_first_kw != FFESTR_firstSAVE)
goto bad_0; /* :::::::::::::::::::: */
- p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlTYPE);
+ p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlSAVE);
switch (ffelex_token_type (t))
{
default:
goto bad_1; /* :::::::::::::::::::: */
case FFELEX_typeCOMMA:
- if (*p != '\0')
- goto bad_i; /* :::::::::::::::::::: */
ffesta_confirmed ();
- ffelex_set_names (TRUE);
- return (ffelexHandler) ffestb_type1_;
+ break;
case FFELEX_typeEOS:
case FFELEX_typeSEMICOLON:
- break;
+ ffesta_confirmed ();
+ if (*p != '\0')
+ break;
+ if (!ffesta_is_inhibited ())
+ ffestc_R522 ();
+ return (ffelexHandler) ffesta_zero (t);
+
+ case FFELEX_typeSLASH:
+ ffesta_confirmed ();
+ if (*p != '\0')
+ goto bad_i; /* :::::::::::::::::::: */
+ if (!ffesta_is_inhibited ())
+ ffestc_R522start ();
+ return (ffelexHandler) ffestb_R5221_ (t);
+
+ case FFELEX_typeCOLONCOLON:
+ ffesta_confirmed ();
+ if (*p != '\0')
+ goto bad_i; /* :::::::::::::::::::: */
+ if (!ffesta_is_inhibited ())
+ ffestc_R522start ();
+ return (ffelexHandler) ffestb_R5221_;
}
+
+ /* Here, we have at least one char after "SAVE" and t is COMMA or
+ EOS/SEMICOLON. */
+
if (!ffesrc_is_name_init (*p))
goto bad_i; /* :::::::::::::::::::: */
- ffesta_tokens[1] = NULL;
- ffesta_tokens[2]
- = ffelex_token_name_from_names (ffesta_tokens[0], i, 0);
- return (ffelexHandler) ffestb_type4_ (t);
+ nt = ffelex_token_name_from_names (ffesta_tokens[0], i, 0);
+ if (!ffesta_is_inhibited ())
+ ffestc_R522start ();
+ next = (ffelexHandler) ffestb_R5221_ (nt);
+ ffelex_token_kill (nt);
+ return (ffelexHandler) (*next) (t);
default:
goto bad_0; /* :::::::::::::::::::: */
}
bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "TYPE", ffesta_tokens[0]);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "SAVE", ffesta_tokens[0]);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "TYPE", t);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "SAVE", t);
return (ffelexHandler) ffelex_swallow_tokens (t,
(ffelexHandler) ffesta_zero); /* Invalid second token. */
bad_i: /* :::::::::::::::::::: */
- ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "TYPE", ffesta_tokens[0], i, t);
+ ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "SAVE", ffesta_tokens[0], i, t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_type1_ -- "TYPE" COMMA
+/* ffestb_R5221_ -- "SAVE" [COLONCOLON]
- return ffestb_type1_; // to lexer
+ return ffestb_R5221_; // to lexer
- Make sure the next token is a NAME. */
+ Handle NAME or SLASH. */
static ffelexHandler
-ffestb_type1_ (ffelexToken t)
+ffestb_R5221_ (ffelexToken t)
{
- ffeTokenLength i;
- const char *p;
-
- ffelex_set_names (FALSE);
-
switch (ffelex_token_type (t))
{
case FFELEX_typeNAME:
+ ffestb_local_.R522.is_cblock = FALSE;
ffesta_tokens[1] = ffelex_token_use (t);
- ffestb_local_.type.kw = ffestr_other (t);
- switch (ffestb_local_.varlist.kw)
- {
- case FFESTR_otherPUBLIC:
- case FFESTR_otherPRIVATE:
- return (ffelexHandler) ffestb_type2_;
-
- default:
- ffelex_token_kill (ffesta_tokens[1]);
- break;
- }
- break;
-
- case FFELEX_typeNAMES:
- ffesta_tokens[1] = ffelex_token_use (t);
- ffestb_local_.type.kw = ffestr_other (t);
- switch (ffestb_local_.varlist.kw)
- {
- case FFESTR_otherPUBLIC:
- p = ffelex_token_text (t) + (i = FFESTR_otherlPUBLIC);
- if (*p == '\0')
- return (ffelexHandler) ffestb_type2_;
- if (!ffesrc_is_name_init (*p))
- goto bad_i1; /* :::::::::::::::::::: */
- ffesta_tokens[2] = ffelex_token_name_from_names (t, i, 0);
- return (ffelexHandler) ffestb_type4_;
-
- case FFESTR_otherPRIVATE:
- p = ffelex_token_text (t) + (i = FFESTR_otherlPRIVATE);
- if (*p == '\0')
- return (ffelexHandler) ffestb_type2_;
- if (!ffesrc_is_name_init (*p))
- goto bad_i1; /* :::::::::::::::::::: */
- ffesta_tokens[2] = ffelex_token_name_from_names (t, i, 0);
- return (ffelexHandler) ffestb_type4_;
+ return (ffelexHandler) ffestb_R5224_;
- default:
- ffelex_token_kill (ffesta_tokens[1]);
- break;
- }
- break;
+ case FFELEX_typeSLASH:
+ ffestb_local_.R522.is_cblock = TRUE;
+ return (ffelexHandler) ffestb_R5222_;
default:
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "SAVE", t);
break;
}
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "TYPE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-
-bad_i1: /* :::::::::::::::::::: */
- ffelex_token_kill (ffesta_tokens[1]);
- ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "TYPE", t, i, NULL);
+ if (!ffesta_is_inhibited ())
+ ffestc_R522finish ();
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_type2_ -- "TYPE" COMMA NAME
+/* ffestb_R5222_ -- "SAVE" [COLONCOLON] SLASH
- return ffestb_type2_; // to lexer
+ return ffestb_R5222_; // to lexer
- Handle COLONCOLON or NAME. */
+ Handle NAME. */
static ffelexHandler
-ffestb_type2_ (ffelexToken t)
+ffestb_R5222_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeCOLONCOLON:
- return (ffelexHandler) ffestb_type3_;
-
case FFELEX_typeNAME:
- return (ffelexHandler) ffestb_type3_ (t);
+ ffesta_tokens[1] = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_R5223_;
default:
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "SAVE", t);
break;
}
- if (ffesta_tokens[1] != NULL)
- ffelex_token_kill (ffesta_tokens[1]);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "TYPE", t);
+ if (!ffesta_is_inhibited ())
+ ffestc_R522finish ();
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_type3_ -- "TYPE" [COMMA NAME [COLONCOLON]]
+/* ffestb_R5223_ -- "SAVE" [COLONCOLON] SLASH NAME
- return ffestb_type3_; // to lexer
+ return ffestb_R5223_; // to lexer
- Make sure the next token is a NAME. */
+ Handle SLASH. */
static ffelexHandler
-ffestb_type3_ (ffelexToken t)
+ffestb_R5223_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeNAME:
- ffesta_tokens[2] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_type4_;
+ case FFELEX_typeSLASH:
+ return (ffelexHandler) ffestb_R5224_;
default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "TYPE", t);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "SAVE", t);
break;
}
- if (ffesta_tokens[1] != NULL)
- ffelex_token_kill (ffesta_tokens[1]);
+ if (!ffesta_is_inhibited ())
+ ffestc_R522finish ();
+ ffelex_token_kill (ffesta_tokens[1]);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_type4_ -- "TYPE" [COMMA NAME [COLONCOLON]] NAME
+/* ffestb_R5224_ -- "SAVE" [COLONCOLON] R523
- return ffestb_type4_; // to lexer
+ return ffestb_R5224_; // to lexer
- Make sure the next token is an EOS or SEMICOLON. */
+ Handle COMMA or EOS/SEMICOLON. */
static ffelexHandler
-ffestb_type4_ (ffelexToken t)
+ffestb_R5224_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
+ case FFELEX_typeCOMMA:
+ if (!ffesta_is_inhibited ())
+ {
+ if (ffestb_local_.R522.is_cblock)
+ ffestc_R522item_cblock (ffesta_tokens[1]);
+ else
+ ffestc_R522item_object (ffesta_tokens[1]);
+ }
+ ffelex_token_kill (ffesta_tokens[1]);
+ return (ffelexHandler) ffestb_R5221_;
+
case FFELEX_typeEOS:
case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
if (!ffesta_is_inhibited ())
- ffestc_R424 (ffesta_tokens[1], ffestb_local_.type.kw,
- ffesta_tokens[2]);
- if (ffesta_tokens[1] != NULL)
- ffelex_token_kill (ffesta_tokens[1]);
- ffelex_token_kill (ffesta_tokens[2]);
+ {
+ if (ffestb_local_.R522.is_cblock)
+ ffestc_R522item_cblock (ffesta_tokens[1]);
+ else
+ ffestc_R522item_object (ffesta_tokens[1]);
+ ffestc_R522finish ();
+ }
+ ffelex_token_kill (ffesta_tokens[1]);
return (ffelexHandler) ffesta_zero (t);
default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "TYPE", t);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "SAVE", t);
break;
}
- if (ffesta_tokens[1] != NULL)
- ffelex_token_kill (ffesta_tokens[1]);
- ffelex_token_kill (ffesta_tokens[2]);
+ if (!ffesta_is_inhibited ())
+ ffestc_R522finish ();
+ ffelex_token_kill (ffesta_tokens[1]);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-#endif
-/* ffestb_varlist -- Parse EXTERNAL/INTENT/INTRINSIC/OPTIONAL/PUBLIC/PRIVATE
- statement
+/* ffestb_R528 -- Parse the DATA statement
- return ffestb_varlist; // to lexer
+ return ffestb_R528; // to lexer
- Make sure the statement has a valid form. If it
+ Make sure the statement has a valid form for the DATA statement. If it
does, implement the statement. */
ffelexHandler
-ffestb_varlist (ffelexToken t)
+ffestb_R528 (ffelexToken t)
{
- ffeTokenLength i;
unsigned const char *p;
+ ffeTokenLength i;
ffelexToken nt;
ffelexHandler next;
switch (ffelex_token_type (ffesta_tokens[0]))
{
case FFELEX_typeNAME:
+ if (ffesta_first_kw != FFESTR_firstDATA)
+ goto bad_0; /* :::::::::::::::::::: */
switch (ffelex_token_type (t))
{
+ case FFELEX_typeCOMMA:
case FFELEX_typeEOS:
case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- switch (ffesta_first_kw)
- {
-#if FFESTR_F90
- case FFESTR_firstPUBLIC:
- if (!ffesta_is_inhibited ())
- ffestc_R521A ();
- return (ffelexHandler) ffesta_zero (t);
-
- case FFESTR_firstPRIVATE:
- if (!ffesta_is_inhibited ())
- ffestc_private (); /* Either R523A or R521B. */
- return (ffelexHandler) ffesta_zero (t);
-#endif
-
- default:
- goto bad_1; /* :::::::::::::::::::: */
- }
-
- case FFELEX_typeCOMMA:
+ case FFELEX_typeSLASH:
+ case FFELEX_typeCOLONCOLON:
ffesta_confirmed (); /* Error, but clearly intended. */
goto bad_1; /* :::::::::::::::::::: */
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed ();
- switch (ffesta_first_kw)
- {
-#if FFESTR_F90
- case FFESTR_firstOPTIONAL:
- if (!ffesta_is_inhibited ())
- ffestc_R520_start ();
- break;
-
- case FFESTR_firstPUBLIC:
- if (!ffesta_is_inhibited ())
- ffestc_R521Astart ();
- break;
-
- case FFESTR_firstPRIVATE:
- if (!ffesta_is_inhibited ())
- ffestc_R521Bstart ();
- break;
-#endif
-
- default:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
- }
- return (ffelexHandler) ffestb_varlist5_;
-
default:
goto bad_1; /* :::::::::::::::::::: */
- case FFELEX_typeOPEN_PAREN:
- switch (ffesta_first_kw)
- {
-#if FFESTR_F90
- case FFESTR_firstINTENT:
- return (ffelexHandler) ffestb_varlist1_;
-#endif
-
- default:
- goto bad_1; /* :::::::::::::::::::: */
- }
-
case FFELEX_typeNAME:
ffesta_confirmed ();
- switch (ffesta_first_kw)
- {
- case FFESTR_firstEXTERNAL:
- if (!ffesta_is_inhibited ())
- ffestc_R1207_start ();
- break;
-
-#if FFESTR_F90
- case FFESTR_firstINTENT:
- goto bad_1; /* :::::::::::::::::::: */
-#endif
-
- case FFESTR_firstINTRINSIC:
- if (!ffesta_is_inhibited ())
- ffestc_R1208_start ();
- break;
-
-#if FFESTR_F90
- case FFESTR_firstOPTIONAL:
- if (!ffesta_is_inhibited ())
- ffestc_R520_start ();
- break;
-#endif
-
-#if FFESTR_F90
- case FFESTR_firstPUBLIC:
- if (!ffesta_is_inhibited ())
- ffestc_R521Astart ();
- break;
-
- case FFESTR_firstPRIVATE:
- if (!ffesta_is_inhibited ())
- ffestc_R521Bstart ();
- break;
-#endif
+ break;
- default:
- break;
- }
- return (ffelexHandler) ffestb_varlist5_ (t);
+ case FFELEX_typeOPEN_PAREN:
+ break;
}
+ ffestb_local_.data.started = FALSE;
+ return (ffelexHandler) (*((ffelexHandler)
+ ffeexpr_lhs (ffesta_output_pool,
+ FFEEXPR_contextDATA,
+ (ffeexprCallback) ffestb_R5281_)))
+ (t);
case FFELEX_typeNAMES:
- p = ffelex_token_text (ffesta_tokens[0]) + (i = ffestb_args.varlist.len);
+ if (ffesta_first_kw != FFESTR_firstDATA)
+ goto bad_0; /* :::::::::::::::::::: */
+ p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlDATA);
switch (ffelex_token_type (t))
{
case FFELEX_typeEOS:
case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- switch (ffesta_first_kw)
- {
-#if FFESTR_F90
- case FFESTR_firstINTENT:
- goto bad_1; /* :::::::::::::::::::: */
-#endif
-
- default:
- break;
- }
- if (*p != '\0')
- break;
- switch (ffesta_first_kw)
- {
-#if FFESTR_F90
- case FFESTR_firstPUBLIC:
- if (!ffesta_is_inhibited ())
- ffestc_R521A ();
- return (ffelexHandler) ffesta_zero (t);
-
- case FFESTR_firstPRIVATE:
- if (!ffesta_is_inhibited ())
- ffestc_private (); /* Either R423A or R521B. */
- return (ffelexHandler) ffesta_zero (t);
-#endif
-
- default:
- goto bad_1; /* :::::::::::::::::::: */
- }
-
- case FFELEX_typeCOMMA:
+ case FFELEX_typeCOLONCOLON:
ffesta_confirmed (); /* Error, but clearly intended. */
- switch (ffesta_first_kw)
- {
-#if FFESTR_F90
- case FFESTR_firstINTENT:
- goto bad_1; /* :::::::::::::::::::: */
-#endif
-
- default:
- break;
- }
- if (*p != '\0')
- break;
goto bad_1; /* :::::::::::::::::::: */
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed ();
- switch (ffesta_first_kw)
- {
-#if FFESTR_F90
- case FFESTR_firstOPTIONAL:
- if (!ffesta_is_inhibited ())
- ffestc_R520_start ();
- break;
-#endif
-
-#if FFESTR_F90
- case FFESTR_firstPUBLIC:
- if (!ffesta_is_inhibited ())
- ffestc_R521Astart ();
- break;
-
- case FFESTR_firstPRIVATE:
- if (!ffesta_is_inhibited ())
- ffestc_R521Bstart ();
- break;
-#endif
-
- default:
- goto bad_1; /* :::::::::::::::::::: */
- }
- return (ffelexHandler) ffestb_varlist5_;
+ default:
+ goto bad_1; /* :::::::::::::::::::: */
case FFELEX_typeOPEN_PAREN:
- switch (ffesta_first_kw)
+ if (*p == '\0')
{
-#if FFESTR_F90
- case FFESTR_firstINTENT:
- if (*p != '\0')
- goto bad_1; /* :::::::::::::::::::: */
- return (ffelexHandler) ffestb_varlist1_;
-#endif
-
- default:
- goto bad_1; /* :::::::::::::::::::: */
+ ffestb_local_.data.started = FALSE;
+ return (ffelexHandler) (*((ffelexHandler)
+ ffeexpr_lhs (ffesta_output_pool,
+ FFEEXPR_contextDATA,
+ (ffeexprCallback)
+ ffestb_R5281_)))
+ (t);
}
+ break;
- case FFELEX_typeNAME:
+ case FFELEX_typeCOMMA:
+ case FFELEX_typeSLASH:
ffesta_confirmed ();
- switch (ffesta_first_kw)
- {
- case FFESTR_firstEXTERNAL:
- if (!ffesta_is_inhibited ())
- ffestc_R1207_start ();
- break;
-
-#if FFESTR_F90
- case FFESTR_firstINTENT:
- goto bad_1; /* :::::::::::::::::::: */
-#endif
-
- case FFESTR_firstINTRINSIC:
- if (!ffesta_is_inhibited ())
- ffestc_R1208_start ();
- break;
-
-#if FFESTR_F90
- case FFESTR_firstOPTIONAL:
- if (!ffesta_is_inhibited ())
- ffestc_R520_start ();
- break;
-#endif
-
-#if FFESTR_F90
- case FFESTR_firstPUBLIC:
- if (!ffesta_is_inhibited ())
- ffestc_R521Astart ();
- break;
-
- case FFESTR_firstPRIVATE:
- if (!ffesta_is_inhibited ())
- ffestc_R521Bstart ();
- break;
-#endif
-
- default:
- break;
- }
- return (ffelexHandler) ffestb_varlist5_ (t);
-
- default:
- goto bad_1; /* :::::::::::::::::::: */
+ break;
}
-
- /* Here, we have at least one char after the first keyword and t is
- COMMA or EOS/SEMICOLON. Also we know that this form is valid for
- only the statements reaching here (specifically, INTENT won't reach
- here). */
-
if (!ffesrc_is_name_init (*p))
goto bad_i; /* :::::::::::::::::::: */
+ ffestb_local_.data.started = FALSE;
nt = ffelex_token_name_from_names (ffesta_tokens[0], i, 0);
- if (!ffesta_is_inhibited ())
- {
- switch (ffesta_first_kw)
- {
- case FFESTR_firstEXTERNAL:
- ffestc_R1207_start ();
- break;
-
- case FFESTR_firstINTRINSIC:
- ffestc_R1208_start ();
- break;
-
-#if FFESTR_F90
- case FFESTR_firstOPTIONAL:
- ffestc_R520_start ();
- break;
-#endif
-
-#if FFESTR_F90
- case FFESTR_firstPUBLIC:
- ffestc_R521Astart ();
- break;
-
- case FFESTR_firstPRIVATE:
- ffestc_R521Bstart ();
- break;
-#endif
-
- default:
- assert (FALSE);
- }
- }
- next = (ffelexHandler) ffestb_varlist5_ (nt);
+ next = (ffelexHandler) (*((ffelexHandler)
+ ffeexpr_lhs (ffesta_output_pool,
+ FFEEXPR_contextDATA,
+ (ffeexprCallback) ffestb_R5281_)))
+ (nt);
ffelex_token_kill (nt);
return (ffelexHandler) (*next) (t);
}
bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.varlist.badname, ffesta_tokens[0]);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DATA", ffesta_tokens[0]);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.varlist.badname, t);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DATA", t);
return (ffelexHandler) ffelex_swallow_tokens (t,
(ffelexHandler) ffesta_zero); /* Invalid second token. */
bad_i: /* :::::::::::::::::::: */
- ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, ffestb_args.varlist.badname, ffesta_tokens[0], i, t);
+ ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "DATA", ffesta_tokens[0], i, t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_varlist1_ -- "INTENT" OPEN_PAREN
+/* ffestb_R5281_ -- "DATA" expr-list
- return ffestb_varlist1_; // to lexer
+ (ffestb_R5281_) // to expression handler
- Handle NAME. */
+ Handle COMMA or SLASH. */
-#if FFESTR_F90
static ffelexHandler
-ffestb_varlist1_ (ffelexToken t)
+ffestb_R5281_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeNAME:
- ffesta_tokens[1] = ffelex_token_use (t);
- ffestb_local_.varlist.kw = ffestr_other (t);
- switch (ffestb_local_.varlist.kw)
+ case FFELEX_typeCOMMA:
+ ffesta_confirmed ();
+ if (expr == NULL)
+ break;
+ if (!ffesta_is_inhibited ())
{
- case FFESTR_otherIN:
- return (ffelexHandler) ffestb_varlist2_;
-
- case FFESTR_otherINOUT:
- return (ffelexHandler) ffestb_varlist3_;
-
- case FFESTR_otherOUT:
- return (ffelexHandler) ffestb_varlist3_;
-
- default:
- ffelex_token_kill (ffesta_tokens[1]);
- break;
+ if (!ffestb_local_.data.started)
+ {
+ ffestc_R528_start ();
+ ffestb_local_.data.started = TRUE;
+ }
+ ffestc_R528_item_object (expr, ft);
}
- break;
-
- default:
- break;
- }
-
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.varlist.badname, t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_varlist2_ -- "INTENT" OPEN_PAREN "IN"
-
- return ffestb_varlist2_; // to lexer
-
- Handle NAME. */
+ return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool,
+ FFEEXPR_contextDATA,
+ (ffeexprCallback) ffestb_R5281_);
-static ffelexHandler
-ffestb_varlist2_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- switch (ffestr_other (t))
+ case FFELEX_typeSLASH:
+ ffesta_confirmed ();
+ if (expr == NULL)
+ break;
+ if (!ffesta_is_inhibited ())
{
- case FFESTR_otherOUT:
- ffestb_local_.varlist.kw = FFESTR_otherINOUT;
- return (ffelexHandler) ffestb_varlist3_;
-
- default:
- break;
+ if (!ffestb_local_.data.started)
+ {
+ ffestc_R528_start ();
+ ffestb_local_.data.started = TRUE;
+ }
+ ffestc_R528_item_object (expr, ft);
+ ffestc_R528_item_startvals ();
}
- break;
-
- case FFELEX_typeCLOSE_PAREN:
- return (ffelexHandler) ffestb_varlist4_;
+ return (ffelexHandler) ffeexpr_rhs
+ (ffesta_output_pool, FFEEXPR_contextDATA,
+ (ffeexprCallback) ffestb_R5282_);
default:
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DATA", t);
break;
}
- ffelex_token_kill (ffesta_tokens[1]);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.varlist.badname, t);
+ if (ffestb_local_.data.started && !ffesta_is_inhibited ())
+ ffestc_R528_finish ();
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_varlist3_ -- "INTENT" OPEN_PAREN NAME ["OUT"]
+/* ffestb_R5282_ -- "DATA" expr-list SLASH expr-list
- return ffestb_varlist3_; // to lexer
+ (ffestb_R5282_) // to expression handler
- Handle CLOSE_PAREN. */
+ Handle ASTERISK, COMMA, or SLASH. */
static ffelexHandler
-ffestb_varlist3_ (ffelexToken t)
+ffestb_R5282_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeCLOSE_PAREN:
- return (ffelexHandler) ffestb_varlist4_;
+ case FFELEX_typeCOMMA:
+ if (expr == NULL)
+ break;
+ if (!ffesta_is_inhibited ())
+ ffestc_R528_item_value (NULL, NULL, expr, ft);
+ return (ffelexHandler) ffeexpr_rhs
+ (ffesta_output_pool, FFEEXPR_contextDATA,
+ (ffeexprCallback) ffestb_R5282_);
+
+ case FFELEX_typeASTERISK:
+ if (expr == NULL)
+ break;
+ ffestb_local_.data.expr = ffeexpr_convert (expr, ft, t,
+ FFEINFO_basictypeINTEGER,
+ FFEINFO_kindtypeINTEGER1,
+ 0,
+ FFETARGET_charactersizeNONE,
+ FFEEXPR_contextLET);
+ ffesta_tokens[1] = ffelex_token_use (ft);
+ return (ffelexHandler) ffeexpr_rhs
+ (ffesta_output_pool, FFEEXPR_contextDATA,
+ (ffeexprCallback) ffestb_R5283_);
+
+ case FFELEX_typeSLASH:
+ if (expr == NULL)
+ break;
+ if (!ffesta_is_inhibited ())
+ {
+ ffestc_R528_item_value (NULL, NULL, expr, ft);
+ ffestc_R528_item_endvals (t);
+ }
+ return (ffelexHandler) ffestb_R5284_;
default:
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DATA", t);
break;
}
- ffelex_token_kill (ffesta_tokens[1]);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.varlist.badname, t);
+ if (!ffesta_is_inhibited ())
+ {
+ ffestc_R528_item_endvals (t);
+ ffestc_R528_finish ();
+ }
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_varlist4_ -- "INTENT" OPEN_PAREN NAME ["OUT"] CLOSE_PAREN
+/* ffestb_R5283_ -- "DATA" expr-list SLASH expr ASTERISK expr
- return ffestb_varlist4_; // to lexer
+ (ffestb_R5283_) // to expression handler
- Handle COLONCOLON or NAME. */
+ Handle COMMA or SLASH. */
static ffelexHandler
-ffestb_varlist4_ (ffelexToken t)
+ffestb_R5283_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed ();
+ case FFELEX_typeCOMMA:
+ if (expr == NULL)
+ break;
if (!ffesta_is_inhibited ())
- ffestc_R519_start (ffesta_tokens[1], ffestb_local_.varlist.kw);
+ ffestc_R528_item_value (ffestb_local_.data.expr, ffesta_tokens[1],
+ expr, ft);
ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffestb_varlist5_;
+ return (ffelexHandler) ffeexpr_rhs
+ (ffesta_output_pool, FFEEXPR_contextDATA,
+ (ffeexprCallback) ffestb_R5282_);
- case FFELEX_typeNAME:
- ffesta_confirmed ();
+ case FFELEX_typeSLASH:
+ if (expr == NULL)
+ break;
if (!ffesta_is_inhibited ())
- ffestc_R519_start (ffesta_tokens[1], ffestb_local_.varlist.kw);
+ {
+ ffestc_R528_item_value (ffestb_local_.data.expr, ffesta_tokens[1],
+ expr, ft);
+ ffestc_R528_item_endvals (t);
+ }
ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffestb_varlist5_ (t);
+ return (ffelexHandler) ffestb_R5284_;
default:
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DATA", t);
break;
}
+ if (!ffesta_is_inhibited ())
+ {
+ ffestc_R528_item_endvals (t);
+ ffestc_R528_finish ();
+ }
ffelex_token_kill (ffesta_tokens[1]);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.varlist.badname, t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-#endif
-/* ffestb_varlist5_ -- Handles the list of variable names
+/* ffestb_R5284_ -- "DATA" expr-list SLASH expr-list SLASH
- return ffestb_varlist5_; // to lexer
+ return ffestb_R5284_; // to lexer
- Handle NAME. */
+ Handle [COMMA] NAME or EOS/SEMICOLON. */
static ffelexHandler
-ffestb_varlist5_ (ffelexToken t)
+ffestb_R5284_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
+ case FFELEX_typeCOMMA:
+ return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool,
+ FFEEXPR_contextDATA,
+ (ffeexprCallback) ffestb_R5281_);
+
case FFELEX_typeNAME:
- ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_varlist6_;
+ case FFELEX_typeOPEN_PAREN:
+ return (ffelexHandler) (*((ffelexHandler)
+ ffeexpr_lhs (ffesta_output_pool,
+ FFEEXPR_contextDATA,
+ (ffeexprCallback) ffestb_R5281_)))
+ (t);
+
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ if (!ffesta_is_inhibited ())
+ ffestc_R528_finish ();
+ return (ffelexHandler) ffesta_zero (t);
default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.varlist.badname, t);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DATA", t);
break;
}
if (!ffesta_is_inhibited ())
- {
- switch (ffesta_first_kw)
- {
- case FFESTR_firstEXTERNAL:
- ffestc_R1207_finish ();
- break;
+ ffestc_R528_finish ();
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+}
-#if FFESTR_F90
- case FFESTR_firstINTENT:
- ffestc_R519_finish ();
- break;
-#endif
+/* ffestb_R537 -- Parse a PARAMETER statement
- case FFESTR_firstINTRINSIC:
- ffestc_R1208_finish ();
- break;
+ return ffestb_R537; // to lexer
-#if FFESTR_F90
- case FFESTR_firstOPTIONAL:
- ffestc_R520_finish ();
- break;
-#endif
+ Make sure the statement has a valid form for an PARAMETER statement.
+ If it does, implement the statement. */
-#if FFESTR_F90
- case FFESTR_firstPUBLIC:
- ffestc_R521Afinish ();
- break;
+ffelexHandler
+ffestb_R537 (ffelexToken t)
+{
+ switch (ffelex_token_type (ffesta_tokens[0]))
+ {
+ case FFELEX_typeNAME:
+ if (ffesta_first_kw != FFESTR_firstPARAMETER)
+ goto bad_0; /* :::::::::::::::::::: */
+ break;
- case FFESTR_firstPRIVATE:
- ffestc_R521Bfinish ();
- break;
-#endif
+ case FFELEX_typeNAMES:
+ if (ffesta_first_kw != FFESTR_firstPARAMETER)
+ goto bad_0; /* :::::::::::::::::::: */
+ if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlPARAMETER)
+ goto bad_0; /* :::::::::::::::::::: */
+ break;
- default:
- assert (FALSE);
- }
+ default:
+ goto bad_0; /* :::::::::::::::::::: */
+ }
+
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeOPEN_PAREN:
+ break;
+
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ case FFELEX_typeCOMMA:
+ case FFELEX_typeCOLONCOLON:
+ ffesta_confirmed (); /* Error, but clearly intended. */
+ goto bad_1; /* :::::::::::::::::::: */
+
+ default:
+ goto bad_1; /* :::::::::::::::::::: */
}
+
+ ffestb_local_.parameter.started = FALSE;
+ return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool,
+ FFEEXPR_contextPARAMETER,
+ (ffeexprCallback) ffestb_R5371_);
+
+bad_0: /* :::::::::::::::::::: */
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "PARAMETER", ffesta_tokens[0]);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+
+bad_1: /* :::::::::::::::::::: */
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "PARAMETER", t);
+ return (ffelexHandler) ffelex_swallow_tokens (t,
+ (ffelexHandler) ffesta_zero); /* Invalid second token. */
}
-/* ffestb_varlist6_ -- (whatever) NAME
+/* ffestb_R5371_ -- "PARAMETER" OPEN_PAREN expr
- return ffestb_varlist6_; // to lexer
+ (ffestb_R5371_) // to expression handler
- Handle COMMA or EOS/SEMICOLON. */
+ Make sure the next token is EQUALS. */
static ffelexHandler
-ffestb_varlist6_ (ffelexToken t)
+ffestb_R5371_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
+ ffestb_local_.parameter.expr = expr;
+
switch (ffelex_token_type (t))
{
- case FFELEX_typeCOMMA:
- if (!ffesta_is_inhibited ())
- {
- switch (ffesta_first_kw)
- {
- case FFESTR_firstEXTERNAL:
- ffestc_R1207_item (ffesta_tokens[1]);
- break;
+ case FFELEX_typeEQUALS:
+ ffesta_confirmed ();
+ if (expr == NULL)
+ break;
+ ffesta_tokens[1] = ffelex_token_use (ft);
+ return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ FFEEXPR_contextPARAMETER, (ffeexprCallback) ffestb_R5372_);
-#if FFESTR_F90
- case FFESTR_firstINTENT:
- ffestc_R519_item (ffesta_tokens[1]);
- break;
-#endif
+ default:
+ break;
+ }
- case FFESTR_firstINTRINSIC:
- ffestc_R1208_item (ffesta_tokens[1]);
- break;
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "PARAMETER", t);
+ if (ffestb_local_.parameter.started)
+ ffestc_R537_finish ();
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+}
-#if FFESTR_F90
- case FFESTR_firstOPTIONAL:
- ffestc_R520_item (ffesta_tokens[1]);
- break;
-#endif
+/* ffestb_R5372_ -- "PARAMETER" OPEN_PAREN expr EQUALS expr
-#if FFESTR_F90
- case FFESTR_firstPUBLIC:
- ffestc_R521Aitem (ffesta_tokens[1]);
- break;
+ (ffestb_R5372_) // to expression handler
- case FFESTR_firstPRIVATE:
- ffestc_R521Bitem (ffesta_tokens[1]);
- break;
-#endif
+ Make sure the next token is COMMA or CLOSE_PAREN. */
- default:
- assert (FALSE);
+static ffelexHandler
+ffestb_R5372_ (ffelexToken ft, ffebld expr, ffelexToken t)
+{
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeCOMMA:
+ if (expr == NULL)
+ break;
+ if (!ffesta_is_inhibited ())
+ {
+ if (!ffestb_local_.parameter.started)
+ {
+ ffestc_R537_start ();
+ ffestb_local_.parameter.started = TRUE;
}
+ ffestc_R537_item (ffestb_local_.parameter.expr, ffesta_tokens[1],
+ expr, ft);
}
ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffestb_varlist5_;
+ return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool,
+ FFEEXPR_contextPARAMETER,
+ (ffeexprCallback) ffestb_R5371_);
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
+ case FFELEX_typeCLOSE_PAREN:
+ if (expr == NULL)
+ break;
if (!ffesta_is_inhibited ())
{
- switch (ffesta_first_kw)
+ if (!ffestb_local_.parameter.started)
{
- case FFESTR_firstEXTERNAL:
- ffestc_R1207_item (ffesta_tokens[1]);
- ffestc_R1207_finish ();
- break;
-
-#if FFESTR_F90
- case FFESTR_firstINTENT:
- ffestc_R519_item (ffesta_tokens[1]);
- ffestc_R519_finish ();
- break;
-#endif
-
- case FFESTR_firstINTRINSIC:
- ffestc_R1208_item (ffesta_tokens[1]);
- ffestc_R1208_finish ();
- break;
-
-#if FFESTR_F90
- case FFESTR_firstOPTIONAL:
- ffestc_R520_item (ffesta_tokens[1]);
- ffestc_R520_finish ();
- break;
-#endif
-
-#if FFESTR_F90
- case FFESTR_firstPUBLIC:
- ffestc_R521Aitem (ffesta_tokens[1]);
- ffestc_R521Afinish ();
- break;
-
- case FFESTR_firstPRIVATE:
- ffestc_R521Bitem (ffesta_tokens[1]);
- ffestc_R521Bfinish ();
- break;
-#endif
-
- default:
- assert (FALSE);
+ ffestc_R537_start ();
+ ffestb_local_.parameter.started = TRUE;
}
+ ffestc_R537_item (ffestb_local_.parameter.expr, ffesta_tokens[1],
+ expr, ft);
+ ffestc_R537_finish ();
}
ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffesta_zero (t);
+ return (ffelexHandler) ffestb_R5373_;
default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.varlist.badname, t);
break;
}
- if (!ffesta_is_inhibited ())
- {
- switch (ffesta_first_kw)
- {
- case FFESTR_firstEXTERNAL:
- ffestc_R1207_finish ();
- break;
-
-#if FFESTR_F90
- case FFESTR_firstINTENT:
- ffestc_R519_finish ();
- break;
-#endif
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "PARAMETER", t);
+ if (ffestb_local_.parameter.started)
+ ffestc_R537_finish ();
+ ffelex_token_kill (ffesta_tokens[1]);
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+}
- case FFESTR_firstINTRINSIC:
- ffestc_R1208_finish ();
- break;
+/* ffestb_R5373_ -- "PARAMETER" OPEN_PAREN expr EQUALS expr CLOSE_PAREN
-#if FFESTR_F90
- case FFESTR_firstOPTIONAL:
- ffestc_R520_finish ();
- break;
-#endif
+ return ffestb_R5373_; // to lexer
-#if FFESTR_F90
- case FFESTR_firstPUBLIC:
- ffestc_R521Afinish ();
- break;
+ Make sure the next token is EOS or SEMICOLON, or generate an error. All
+ cleanup has already been done, by the way. */
- case FFESTR_firstPRIVATE:
- ffestc_R521Bfinish ();
- break;
-#endif
+static ffelexHandler
+ffestb_R5373_ (ffelexToken t)
+{
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ return (ffelexHandler) ffesta_zero (t);
- default:
- assert (FALSE);
- }
+ default:
+ break;
}
- ffelex_token_kill (ffesta_tokens[1]);
+
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "PARAMETER", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R423B -- Parse the SEQUENCE statement
+/* ffestb_R542 -- Parse the NAMELIST statement
- return ffestb_R423B; // to lexer
+ return ffestb_R542; // to lexer
- Make sure the statement has a valid form for the SEQUENCE statement. If
- it does, implement the statement. */
+ Make sure the statement has a valid form for the NAMELIST statement. If it
+ does, implement the statement. */
-#if FFESTR_F90
ffelexHandler
-ffestb_R423B (ffelexToken t)
+ffestb_R542 (ffelexToken t)
{
const char *p;
ffeTokenLength i;
switch (ffelex_token_type (ffesta_tokens[0]))
{
case FFELEX_typeNAME:
- if (ffesta_first_kw != FFESTR_firstSEQUENCE)
+ if (ffesta_first_kw != FFESTR_firstNAMELIST)
goto bad_0; /* :::::::::::::::::::: */
break;
case FFELEX_typeNAMES:
- if (ffesta_first_kw != FFESTR_firstSEQUENCE)
+ if (ffesta_first_kw != FFESTR_firstNAMELIST)
goto bad_0; /* :::::::::::::::::::: */
- if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlSEQUENCE)
- {
- p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlSEQUENCE);
- goto bad_i; /* :::::::::::::::::::: */
- }
+ p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlNAMELIST);
+ if (*p != '\0')
+ goto bad_i; /* :::::::::::::::::::: */
break;
default:
switch (ffelex_token_type (t))
{
+ case FFELEX_typeCOMMA:
case FFELEX_typeEOS:
case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- ffestc_R423B ();
- return (ffelexHandler) ffesta_zero (t);
-
- case FFELEX_typeCOMMA:
case FFELEX_typeCOLONCOLON:
ffesta_confirmed (); /* Error, but clearly intended. */
goto bad_1; /* :::::::::::::::::::: */
default:
goto bad_1; /* :::::::::::::::::::: */
+
+ case FFELEX_typeSLASH:
+ break;
}
+ ffesta_confirmed ();
+ if (!ffesta_is_inhibited ())
+ ffestc_R542_start ();
+ return (ffelexHandler) ffestb_R5421_;
+
bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "SEQUENCE", ffesta_tokens[0]);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero); /* Invalid first token. */
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "NAMELIST", ffesta_tokens[0]);
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "SEQUENCE", t);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "NAMELIST", t);
return (ffelexHandler) ffelex_swallow_tokens (t,
(ffelexHandler) ffesta_zero); /* Invalid second token. */
bad_i: /* :::::::::::::::::::: */
- ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "SEQUENCE", ffesta_tokens[0], i, t);
+ ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "NAMELIST", ffesta_tokens[0], i, t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-#endif
-/* ffestb_R522 -- Parse the SAVE statement
+/* ffestb_R5421_ -- "NAMELIST" SLASH
- return ffestb_R522; // to lexer
+ return ffestb_R5421_; // to lexer
- Make sure the statement has a valid form for the SAVE statement. If it
- does, implement the statement. */
+ Handle NAME. */
-ffelexHandler
-ffestb_R522 (ffelexToken t)
+static ffelexHandler
+ffestb_R5421_ (ffelexToken t)
{
- ffeTokenLength i;
- unsigned const char *p;
- ffelexToken nt;
- ffelexHandler next;
-
- switch (ffelex_token_type (ffesta_tokens[0]))
+ switch (ffelex_token_type (t))
{
case FFELEX_typeNAME:
- if (ffesta_first_kw != FFESTR_firstSAVE)
- goto bad_0; /* :::::::::::::::::::: */
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
+ if (!ffesta_is_inhibited ())
+ ffestc_R542_item_nlist (t);
+ return (ffelexHandler) ffestb_R5422_;
- default:
- goto bad_1; /* :::::::::::::::::::: */
+ default:
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "NAMELIST", t);
+ break;
+ }
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- ffestc_R522 ();
- return (ffelexHandler) ffesta_zero (t);
+ if (!ffesta_is_inhibited ())
+ ffestc_R542_finish ();
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+}
- case FFELEX_typeNAME:
- case FFELEX_typeSLASH:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- ffestc_R522start ();
- return (ffelexHandler) ffestb_R5221_ (t);
+/* ffestb_R5422_ -- "NAMELIST" SLASH NAME
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- ffestc_R522start ();
- return (ffelexHandler) ffestb_R5221_;
- }
+ return ffestb_R5422_; // to lexer
- case FFELEX_typeNAMES:
- if (ffesta_first_kw != FFESTR_firstSAVE)
- goto bad_0; /* :::::::::::::::::::: */
- p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlSAVE);
- switch (ffelex_token_type (t))
- {
- default:
- goto bad_1; /* :::::::::::::::::::: */
+ Handle SLASH. */
- case FFELEX_typeCOMMA:
- ffesta_confirmed ();
- break;
+static ffelexHandler
+ffestb_R5422_ (ffelexToken t)
+{
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeSLASH:
+ return (ffelexHandler) ffestb_R5423_;
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- if (*p != '\0')
- break;
- if (!ffesta_is_inhibited ())
- ffestc_R522 ();
- return (ffelexHandler) ffesta_zero (t);
+ default:
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "NAMELIST", t);
+ break;
+ }
- case FFELEX_typeSLASH:
- ffesta_confirmed ();
- if (*p != '\0')
- goto bad_i; /* :::::::::::::::::::: */
- if (!ffesta_is_inhibited ())
- ffestc_R522start ();
- return (ffelexHandler) ffestb_R5221_ (t);
+ if (!ffesta_is_inhibited ())
+ ffestc_R542_finish ();
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+}
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed ();
- if (*p != '\0')
- goto bad_i; /* :::::::::::::::::::: */
- if (!ffesta_is_inhibited ())
- ffestc_R522start ();
- return (ffelexHandler) ffestb_R5221_;
- }
+/* ffestb_R5423_ -- "NAMELIST" SLASH NAME SLASH
- /* Here, we have at least one char after "SAVE" and t is COMMA or
- EOS/SEMICOLON. */
+ return ffestb_R5423_; // to lexer
- if (!ffesrc_is_name_init (*p))
- goto bad_i; /* :::::::::::::::::::: */
- nt = ffelex_token_name_from_names (ffesta_tokens[0], i, 0);
+ Handle NAME. */
+
+static ffelexHandler
+ffestb_R5423_ (ffelexToken t)
+{
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeNAME:
if (!ffesta_is_inhibited ())
- ffestc_R522start ();
- next = (ffelexHandler) ffestb_R5221_ (nt);
- ffelex_token_kill (nt);
- return (ffelexHandler) (*next) (t);
+ ffestc_R542_item_nitem (t);
+ return (ffelexHandler) ffestb_R5424_;
default:
- goto bad_0; /* :::::::::::::::::::: */
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "NAMELIST", t);
+ break;
}
-bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "SAVE", ffesta_tokens[0]);
+ if (!ffesta_is_inhibited ())
+ ffestc_R542_finish ();
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+}
-bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "SAVE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero); /* Invalid second token. */
+/* ffestb_R5424_ -- "NAMELIST" SLASH NAME SLASH NAME
-bad_i: /* :::::::::::::::::::: */
- ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "SAVE", ffesta_tokens[0], i, t);
+ return ffestb_R5424_; // to lexer
+
+ Handle COMMA, EOS/SEMICOLON, or SLASH. */
+
+static ffelexHandler
+ffestb_R5424_ (ffelexToken t)
+{
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeCOMMA:
+ return (ffelexHandler) ffestb_R5425_;
+
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ if (!ffesta_is_inhibited ())
+ ffestc_R542_finish ();
+ return (ffelexHandler) ffesta_zero (t);
+
+ case FFELEX_typeSLASH:
+ return (ffelexHandler) ffestb_R5421_;
+
+ default:
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "NAMELIST", t);
+ break;
+ }
+
+ if (!ffesta_is_inhibited ())
+ ffestc_R542_finish ();
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R5221_ -- "SAVE" [COLONCOLON]
+/* ffestb_R5425_ -- "NAMELIST" SLASH NAME SLASH NAME COMMA
- return ffestb_R5221_; // to lexer
+ return ffestb_R5425_; // to lexer
Handle NAME or SLASH. */
static ffelexHandler
-ffestb_R5221_ (ffelexToken t)
+ffestb_R5425_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
case FFELEX_typeNAME:
- ffestb_local_.R522.is_cblock = FALSE;
- ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_R5224_;
+ if (!ffesta_is_inhibited ())
+ ffestc_R542_item_nitem (t);
+ return (ffelexHandler) ffestb_R5424_;
case FFELEX_typeSLASH:
- ffestb_local_.R522.is_cblock = TRUE;
- return (ffelexHandler) ffestb_R5222_;
+ return (ffelexHandler) ffestb_R5421_;
default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "SAVE", t);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "NAMELIST", t);
break;
}
if (!ffesta_is_inhibited ())
- ffestc_R522finish ();
+ ffestc_R542_finish ();
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R5222_ -- "SAVE" [COLONCOLON] SLASH
+/* ffestb_R544 -- Parse an EQUIVALENCE statement
- return ffestb_R5222_; // to lexer
+ return ffestb_R544; // to lexer
- Handle NAME. */
+ Make sure the statement has a valid form for an EQUIVALENCE statement.
+ If it does, implement the statement. */
+
+ffelexHandler
+ffestb_R544 (ffelexToken t)
+{
+ switch (ffelex_token_type (ffesta_tokens[0]))
+ {
+ case FFELEX_typeNAME:
+ if (ffesta_first_kw != FFESTR_firstEQUIVALENCE)
+ goto bad_0; /* :::::::::::::::::::: */
+ break;
+
+ case FFELEX_typeNAMES:
+ if (ffesta_first_kw != FFESTR_firstEQUIVALENCE)
+ goto bad_0; /* :::::::::::::::::::: */
+ if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlEQUIVALENCE)
+ goto bad_0; /* :::::::::::::::::::: */
+ break;
+
+ default:
+ goto bad_0; /* :::::::::::::::::::: */
+ }
+
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeOPEN_PAREN:
+ break;
+
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ case FFELEX_typeCOMMA:
+ case FFELEX_typeCOLONCOLON:
+ ffesta_confirmed (); /* Error, but clearly intended. */
+ goto bad_1; /* :::::::::::::::::::: */
+
+ default:
+ goto bad_1; /* :::::::::::::::::::: */
+ }
+
+ ffestb_local_.equivalence.started = FALSE;
+ return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool,
+ FFEEXPR_contextEQUIVALENCE,
+ (ffeexprCallback) ffestb_R5441_);
+
+bad_0: /* :::::::::::::::::::: */
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "EQUIVALENCE", ffesta_tokens[0]);
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+
+bad_1: /* :::::::::::::::::::: */
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "EQUIVALENCE", t);
+ return (ffelexHandler) ffelex_swallow_tokens (t,
+ (ffelexHandler) ffesta_zero); /* Invalid second token. */
+}
+
+/* ffestb_R5441_ -- "EQUIVALENCE" OPEN_PAREN expr
+
+ (ffestb_R5441_) // to expression handler
+
+ Make sure the next token is COMMA. */
static ffelexHandler
-ffestb_R5222_ (ffelexToken t)
+ffestb_R5441_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeNAME:
- ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_R5223_;
+ case FFELEX_typeCOMMA:
+ if (expr == NULL)
+ break;
+ ffestb_local_.equivalence.exprs = ffestt_exprlist_create ();
+ ffestt_exprlist_append (ffestb_local_.equivalence.exprs, expr,
+ ffelex_token_use (ft));
+ return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool,
+ FFEEXPR_contextEQUIVALENCE,
+ (ffeexprCallback) ffestb_R5442_);
default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "SAVE", t);
break;
}
- if (!ffesta_is_inhibited ())
- ffestc_R522finish ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "EQUIVALENCE", t);
+ if (ffestb_local_.equivalence.started)
+ ffestc_R544_finish ();
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R5223_ -- "SAVE" [COLONCOLON] SLASH NAME
+/* ffestb_R5442_ -- "EQUIVALENCE" OPEN_PAREN expr COMMA expr
- return ffestb_R5223_; // to lexer
+ (ffestb_R5442_) // to expression handler
- Handle SLASH. */
+ Make sure the next token is COMMA or CLOSE_PAREN. For COMMA, we just
+ append the expression to our list and continue; for CLOSE_PAREN, we
+ append the expression and move to _3_. */
static ffelexHandler
-ffestb_R5223_ (ffelexToken t)
+ffestb_R5442_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeSLASH:
- return (ffelexHandler) ffestb_R5224_;
+ case FFELEX_typeCOMMA:
+ if (expr == NULL)
+ break;
+ ffestt_exprlist_append (ffestb_local_.equivalence.exprs, expr,
+ ffelex_token_use (ft));
+ return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool,
+ FFEEXPR_contextEQUIVALENCE,
+ (ffeexprCallback) ffestb_R5442_);
+
+ case FFELEX_typeCLOSE_PAREN:
+ if (expr == NULL)
+ break;
+ ffestt_exprlist_append (ffestb_local_.equivalence.exprs, expr,
+ ffelex_token_use (ft));
+ return (ffelexHandler) ffestb_R5443_;
default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "SAVE", t);
break;
}
- if (!ffesta_is_inhibited ())
- ffestc_R522finish ();
- ffelex_token_kill (ffesta_tokens[1]);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "EQUIVALENCE", t);
+ if (ffestb_local_.equivalence.started)
+ ffestc_R544_finish ();
+ ffestt_exprlist_kill (ffestb_local_.equivalence.exprs);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R5224_ -- "SAVE" [COLONCOLON] R523
+/* ffestb_R5443_ -- "EQUIVALENCE" OPEN_PAREN expr COMMA expr CLOSE_PAREN
- return ffestb_R5224_; // to lexer
+ return ffestb_R5443_; // to lexer
- Handle COMMA or EOS/SEMICOLON. */
+ Make sure the next token is COMMA or EOS/SEMICOLON. */
static ffelexHandler
-ffestb_R5224_ (ffelexToken t)
+ffestb_R5443_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
case FFELEX_typeCOMMA:
+ ffesta_confirmed ();
if (!ffesta_is_inhibited ())
{
- if (ffestb_local_.R522.is_cblock)
- ffestc_R522item_cblock (ffesta_tokens[1]);
- else
- ffestc_R522item_object (ffesta_tokens[1]);
+ if (!ffestb_local_.equivalence.started)
+ {
+ ffestc_R544_start ();
+ ffestb_local_.equivalence.started = TRUE;
+ }
+ ffestc_R544_item (ffestb_local_.equivalence.exprs);
}
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffestb_R5221_;
+ ffestt_exprlist_kill (ffestb_local_.equivalence.exprs);
+ return (ffelexHandler) ffestb_R5444_;
case FFELEX_typeEOS:
case FFELEX_typeSEMICOLON:
+ ffesta_confirmed ();
if (!ffesta_is_inhibited ())
{
- if (ffestb_local_.R522.is_cblock)
- ffestc_R522item_cblock (ffesta_tokens[1]);
- else
- ffestc_R522item_object (ffesta_tokens[1]);
- ffestc_R522finish ();
+ if (!ffestb_local_.equivalence.started)
+ {
+ ffestc_R544_start ();
+ ffestb_local_.equivalence.started = TRUE;
+ }
+ ffestc_R544_item (ffestb_local_.equivalence.exprs);
+ ffestc_R544_finish ();
}
- ffelex_token_kill (ffesta_tokens[1]);
+ ffestt_exprlist_kill (ffestb_local_.equivalence.exprs);
return (ffelexHandler) ffesta_zero (t);
default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "SAVE", t);
break;
}
- if (!ffesta_is_inhibited ())
- ffestc_R522finish ();
- ffelex_token_kill (ffesta_tokens[1]);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "EQUIVALENCE", t);
+ if (ffestb_local_.equivalence.started)
+ ffestc_R544_finish ();
+ ffestt_exprlist_kill (ffestb_local_.equivalence.exprs);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R528 -- Parse the DATA statement
+/* ffestb_R5444_ -- "EQUIVALENCE" OPEN_PAREN expr COMMA expr CLOSE_PAREN COMMA
- return ffestb_R528; // to lexer
+ return ffestb_R5444_; // to lexer
- Make sure the statement has a valid form for the DATA statement. If it
- does, implement the statement. */
+ Make sure the next token is OPEN_PAREN, or generate an error. */
-ffelexHandler
-ffestb_R528 (ffelexToken t)
+static ffelexHandler
+ffestb_R5444_ (ffelexToken t)
{
- unsigned const char *p;
- ffeTokenLength i;
- ffelexToken nt;
- ffelexHandler next;
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeOPEN_PAREN:
+ return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool,
+ FFEEXPR_contextEQUIVALENCE,
+ (ffeexprCallback) ffestb_R5441_);
+
+ default:
+ break;
+ }
+
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "EQUIVALENCE", t);
+ if (ffestb_local_.equivalence.started)
+ ffestc_R544_finish ();
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+}
+
+/* ffestb_R834 -- Parse the CYCLE statement
+
+ return ffestb_R834; // to lexer
+
+ Make sure the statement has a valid form for the CYCLE statement. If
+ it does, implement the statement. */
+
+ffelexHandler
+ffestb_R834 (ffelexToken t)
+{
+ ffeTokenLength i;
+ unsigned const char *p;
switch (ffelex_token_type (ffesta_tokens[0]))
{
case FFELEX_typeNAME:
- if (ffesta_first_kw != FFESTR_firstDATA)
+ if (ffesta_first_kw != FFESTR_firstCYCLE)
goto bad_0; /* :::::::::::::::::::: */
switch (ffelex_token_type (t))
{
case FFELEX_typeCOMMA:
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- case FFELEX_typeSLASH:
case FFELEX_typeCOLONCOLON:
ffesta_confirmed (); /* Error, but clearly intended. */
goto bad_1; /* :::::::::::::::::::: */
case FFELEX_typeNAME:
ffesta_confirmed ();
- break;
+ ffesta_tokens[1] = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_R8341_;
- case FFELEX_typeOPEN_PAREN:
- break;
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ ffesta_confirmed ();
+ ffesta_tokens[1] = NULL;
+ return (ffelexHandler) ffestb_R8341_ (t);
}
- ffestb_local_.data.started = FALSE;
- return (ffelexHandler) (*((ffelexHandler)
- ffeexpr_lhs (ffesta_output_pool,
- FFEEXPR_contextDATA,
- (ffeexprCallback) ffestb_R5281_)))
- (t);
case FFELEX_typeNAMES:
- if (ffesta_first_kw != FFESTR_firstDATA)
+ if (ffesta_first_kw != FFESTR_firstCYCLE)
goto bad_0; /* :::::::::::::::::::: */
- p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlDATA);
switch (ffelex_token_type (t))
{
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
-
default:
goto bad_1; /* :::::::::::::::::::: */
- case FFELEX_typeOPEN_PAREN:
- if (*p == '\0')
- {
- ffestb_local_.data.started = FALSE;
- return (ffelexHandler) (*((ffelexHandler)
- ffeexpr_lhs (ffesta_output_pool,
- FFEEXPR_contextDATA,
- (ffeexprCallback)
- ffestb_R5281_)))
- (t);
- }
- break;
-
- case FFELEX_typeCOMMA:
- case FFELEX_typeSLASH:
- ffesta_confirmed ();
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
break;
}
- if (!ffesrc_is_name_init (*p))
- goto bad_i; /* :::::::::::::::::::: */
- ffestb_local_.data.started = FALSE;
- nt = ffelex_token_name_from_names (ffesta_tokens[0], i, 0);
- next = (ffelexHandler) (*((ffelexHandler)
- ffeexpr_lhs (ffesta_output_pool,
- FFEEXPR_contextDATA,
- (ffeexprCallback) ffestb_R5281_)))
- (nt);
- ffelex_token_kill (nt);
- return (ffelexHandler) (*next) (t);
+ ffesta_confirmed ();
+ p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlCYCLE);
+ if (*p == '\0')
+ {
+ ffesta_tokens[1] = NULL;
+ }
+ else
+ {
+ if (!ffesrc_is_name_init (*p))
+ goto bad_i; /* :::::::::::::::::::: */
+ ffesta_tokens[1]
+ = ffelex_token_name_from_names (ffesta_tokens[0], i, 0);
+ }
+ return (ffelexHandler) ffestb_R8341_ (t);
default:
goto bad_0; /* :::::::::::::::::::: */
}
bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DATA", ffesta_tokens[0]);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CYCLE", ffesta_tokens[0]);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DATA", t);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CYCLE", t);
return (ffelexHandler) ffelex_swallow_tokens (t,
(ffelexHandler) ffesta_zero); /* Invalid second token. */
bad_i: /* :::::::::::::::::::: */
- ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "DATA", ffesta_tokens[0], i, t);
+ ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "CYCLE", ffesta_tokens[0], i, t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R5281_ -- "DATA" expr-list
+/* ffestb_R8341_ -- "CYCLE" [NAME]
- (ffestb_R5281_) // to expression handler
+ return ffestb_R8341_; // to lexer
- Handle COMMA or SLASH. */
+ Make sure the next token is an EOS or SEMICOLON. */
static ffelexHandler
-ffestb_R5281_ (ffelexToken ft, ffebld expr, ffelexToken t)
+ffestb_R8341_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeCOMMA:
- ffesta_confirmed ();
- if (expr == NULL)
- break;
- if (!ffesta_is_inhibited ())
- {
- if (!ffestb_local_.data.started)
- {
- ffestc_R528_start ();
- ffestb_local_.data.started = TRUE;
- }
- ffestc_R528_item_object (expr, ft);
- }
- return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool,
- FFEEXPR_contextDATA,
- (ffeexprCallback) ffestb_R5281_);
-
- case FFELEX_typeSLASH:
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
ffesta_confirmed ();
- if (expr == NULL)
- break;
if (!ffesta_is_inhibited ())
- {
- if (!ffestb_local_.data.started)
- {
- ffestc_R528_start ();
- ffestb_local_.data.started = TRUE;
- }
- ffestc_R528_item_object (expr, ft);
- ffestc_R528_item_startvals ();
- }
- return (ffelexHandler) ffeexpr_rhs
- (ffesta_output_pool, FFEEXPR_contextDATA,
- (ffeexprCallback) ffestb_R5282_);
+ ffestc_R834 (ffesta_tokens[1]);
+ if (ffesta_tokens[1] != NULL)
+ ffelex_token_kill (ffesta_tokens[1]);
+ return (ffelexHandler) ffesta_zero (t);
default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DATA", t);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CYCLE", t);
break;
}
- if (ffestb_local_.data.started && !ffesta_is_inhibited ())
- ffestc_R528_finish ();
+ if (ffesta_tokens[1] != NULL)
+ ffelex_token_kill (ffesta_tokens[1]);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R5282_ -- "DATA" expr-list SLASH expr-list
+/* ffestb_R835 -- Parse the EXIT statement
- (ffestb_R5282_) // to expression handler
+ return ffestb_R835; // to lexer
- Handle ASTERISK, COMMA, or SLASH. */
+ Make sure the statement has a valid form for the EXIT statement. If
+ it does, implement the statement. */
-static ffelexHandler
-ffestb_R5282_ (ffelexToken ft, ffebld expr, ffelexToken t)
+ffelexHandler
+ffestb_R835 (ffelexToken t)
{
- switch (ffelex_token_type (t))
+ ffeTokenLength i;
+ unsigned const char *p;
+
+ switch (ffelex_token_type (ffesta_tokens[0]))
{
- case FFELEX_typeCOMMA:
- if (expr == NULL)
- break;
- if (!ffesta_is_inhibited ())
- ffestc_R528_item_value (NULL, NULL, expr, ft);
- return (ffelexHandler) ffeexpr_rhs
- (ffesta_output_pool, FFEEXPR_contextDATA,
- (ffeexprCallback) ffestb_R5282_);
+ case FFELEX_typeNAME:
+ if (ffesta_first_kw != FFESTR_firstEXIT)
+ goto bad_0; /* :::::::::::::::::::: */
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeCOMMA:
+ case FFELEX_typeCOLONCOLON:
+ ffesta_confirmed (); /* Error, but clearly intended. */
+ goto bad_1; /* :::::::::::::::::::: */
- case FFELEX_typeASTERISK:
- if (expr == NULL)
- break;
- ffestb_local_.data.expr = ffeexpr_convert (expr, ft, t,
- FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGER1,
- 0,
- FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- ffesta_tokens[1] = ffelex_token_use (ft);
- return (ffelexHandler) ffeexpr_rhs
- (ffesta_output_pool, FFEEXPR_contextDATA,
- (ffeexprCallback) ffestb_R5283_);
+ default:
+ goto bad_1; /* :::::::::::::::::::: */
- case FFELEX_typeSLASH:
- if (expr == NULL)
- break;
- if (!ffesta_is_inhibited ())
+ case FFELEX_typeNAME:
+ ffesta_confirmed ();
+ ffesta_tokens[1] = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_R8351_;
+
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ ffesta_confirmed ();
+ ffesta_tokens[1] = NULL;
+ return (ffelexHandler) ffestb_R8351_ (t);
+ }
+
+ case FFELEX_typeNAMES:
+ if (ffesta_first_kw != FFESTR_firstEXIT)
+ goto bad_0; /* :::::::::::::::::::: */
+ switch (ffelex_token_type (t))
{
- ffestc_R528_item_value (NULL, NULL, expr, ft);
- ffestc_R528_item_endvals (t);
+ default:
+ goto bad_1; /* :::::::::::::::::::: */
+
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ break;
}
- return (ffelexHandler) ffestb_R5284_;
+ ffesta_confirmed ();
+ p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlEXIT);
+ if (*p == '\0')
+ {
+ ffesta_tokens[1] = NULL;
+ }
+ else
+ {
+ if (!ffesrc_is_name_init (*p))
+ goto bad_i; /* :::::::::::::::::::: */
+ ffesta_tokens[1]
+ = ffelex_token_name_from_names (ffesta_tokens[0], i, 0);
+ }
+ return (ffelexHandler) ffestb_R8351_ (t);
default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DATA", t);
- break;
+ goto bad_0; /* :::::::::::::::::::: */
}
- if (!ffesta_is_inhibited ())
- {
- ffestc_R528_item_endvals (t);
- ffestc_R528_finish ();
- }
+bad_0: /* :::::::::::::::::::: */
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "EXIT", ffesta_tokens[0]);
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+
+bad_1: /* :::::::::::::::::::: */
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "EXIT", t);
+ return (ffelexHandler) ffelex_swallow_tokens (t,
+ (ffelexHandler) ffesta_zero); /* Invalid second token. */
+
+bad_i: /* :::::::::::::::::::: */
+ ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "EXIT", ffesta_tokens[0], i, t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R5283_ -- "DATA" expr-list SLASH expr ASTERISK expr
+/* ffestb_R8351_ -- "EXIT" [NAME]
- (ffestb_R5283_) // to expression handler
+ return ffestb_R8351_; // to lexer
- Handle COMMA or SLASH. */
+ Make sure the next token is an EOS or SEMICOLON. */
static ffelexHandler
-ffestb_R5283_ (ffelexToken ft, ffebld expr, ffelexToken t)
+ffestb_R8351_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeCOMMA:
- if (expr == NULL)
- break;
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ ffesta_confirmed ();
if (!ffesta_is_inhibited ())
- ffestc_R528_item_value (ffestb_local_.data.expr, ffesta_tokens[1],
- expr, ft);
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffeexpr_rhs
- (ffesta_output_pool, FFEEXPR_contextDATA,
- (ffeexprCallback) ffestb_R5282_);
+ ffestc_R835 (ffesta_tokens[1]);
+ if (ffesta_tokens[1] != NULL)
+ ffelex_token_kill (ffesta_tokens[1]);
+ return (ffelexHandler) ffesta_zero (t);
- case FFELEX_typeSLASH:
- if (expr == NULL)
- break;
- if (!ffesta_is_inhibited ())
+ default:
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "EXIT", t);
+ break;
+ }
+
+ if (ffesta_tokens[1] != NULL)
+ ffelex_token_kill (ffesta_tokens[1]);
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+}
+
+/* ffestb_R838 -- Parse the ASSIGN statement
+
+ return ffestb_R838; // to lexer
+
+ Make sure the statement has a valid form for the ASSIGN statement. If it
+ does, implement the statement. */
+
+ffelexHandler
+ffestb_R838 (ffelexToken t)
+{
+ unsigned const char *p;
+ ffeTokenLength i;
+ ffelexHandler next;
+ ffelexToken et; /* First token in target. */
+
+ switch (ffelex_token_type (ffesta_tokens[0]))
+ {
+ case FFELEX_typeNAME:
+ if (ffesta_first_kw != FFESTR_firstASSIGN)
+ goto bad_0; /* :::::::::::::::::::: */
+ switch (ffelex_token_type (t))
{
- ffestc_R528_item_value (ffestb_local_.data.expr, ffesta_tokens[1],
- expr, ft);
- ffestc_R528_item_endvals (t);
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ case FFELEX_typeCOMMA:
+ case FFELEX_typeCOLONCOLON:
+ ffesta_confirmed (); /* Error, but clearly intended. */
+ goto bad_1; /* :::::::::::::::::::: */
+
+ default:
+ goto bad_1; /* :::::::::::::::::::: */
+
+ case FFELEX_typeNUMBER:
+ break;
+ }
+ ffesta_tokens[1] = ffelex_token_use (t);
+ ffesta_confirmed ();
+ return (ffelexHandler) ffestb_R8381_;
+
+ case FFELEX_typeNAMES:
+ if (ffesta_first_kw != FFESTR_firstASSIGN)
+ goto bad_0; /* :::::::::::::::::::: */
+
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ ffesta_confirmed ();
+ /* Fall through. */
+ case FFELEX_typePERCENT:
+ case FFELEX_typeOPEN_PAREN:
+ p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlASSIGN);
+ if (! ISDIGIT (*p))
+ goto bad_i; /* :::::::::::::::::::: */
+ ffesta_tokens[1]
+ = ffelex_token_number_from_names (ffesta_tokens[0], i);
+ p += ffelex_token_length (ffesta_tokens[1]); /* Skip to "TO". */
+ i += ffelex_token_length (ffesta_tokens[1]);
+ if (!ffesrc_char_match_init (*p, 'T', 't') /* "TO". */
+ || (++i, !ffesrc_char_match_noninit (*++p, 'O', 'o')))
+ {
+ bad_i_1: /* :::::::::::::::::::: */
+ ffelex_token_kill (ffesta_tokens[1]);
+ goto bad_i; /* :::::::::::::::::::: */
+ }
+ ++p, ++i;
+ if (!ffesrc_is_name_init (*p))
+ goto bad_i_1; /* :::::::::::::::::::: */
+ et = ffelex_token_name_from_names (ffesta_tokens[0], i, 0);
+ next = (ffelexHandler)
+ (*((ffelexHandler)
+ ffeexpr_lhs (ffesta_output_pool,
+ FFEEXPR_contextASSIGN,
+ (ffeexprCallback)
+ ffestb_R8383_)))
+ (et);
+ ffelex_token_kill (et);
+ return (ffelexHandler) (*next) (t);
+
+ case FFELEX_typeCOMMA:
+ case FFELEX_typeCOLONCOLON:
+ ffesta_confirmed (); /* Error, but clearly intended. */
+ goto bad_1; /* :::::::::::::::::::: */
+
+ default:
+ goto bad_1; /* :::::::::::::::::::: */
}
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffestb_R5284_;
default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DATA", t);
- break;
+ goto bad_0; /* :::::::::::::::::::: */
}
- if (!ffesta_is_inhibited ())
+bad_0: /* :::::::::::::::::::: */
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "ASSIGN", ffesta_tokens[0]);
+ return (ffelexHandler) ffelex_swallow_tokens (t,
+ (ffelexHandler) ffesta_zero); /* Invalid first token. */
+
+bad_1: /* :::::::::::::::::::: */
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "ASSIGN", t);
+ return (ffelexHandler) ffelex_swallow_tokens (t,
+ (ffelexHandler) ffesta_zero); /* Invalid second token. */
+
+bad_i: /* :::::::::::::::::::: */
+ ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "ASSIGN", ffesta_tokens[0], i, t);
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+}
+
+/* ffestb_R8381_ -- "ASSIGN" NUMBER
+
+ return ffestb_R8381_; // to lexer
+
+ Make sure the next token is "TO". */
+
+static ffelexHandler
+ffestb_R8381_ (ffelexToken t)
+{
+ if ((ffelex_token_type (t) == FFELEX_typeNAME)
+ && (ffesrc_strcmp_2c (ffe_case_match (), ffelex_token_text (t), "TO", "to",
+ "To") == 0))
{
- ffestc_R528_item_endvals (t);
- ffestc_R528_finish ();
+ return (ffelexHandler) ffestb_R8382_;
}
+
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "ASSIGN", t);
+ if (ffelex_token_type (t) == FFELEX_typeNAME)
+ return (ffelexHandler) ffestb_R8382_ (t); /* Maybe user forgot "TO". */
+
ffelex_token_kill (ffesta_tokens[1]);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R5284_ -- "DATA" expr-list SLASH expr-list SLASH
+/* ffestb_R8382_ -- "ASSIGN" NUMBER ("TO")
- return ffestb_R5284_; // to lexer
+ return ffestb_R8382_; // to lexer
- Handle [COMMA] NAME or EOS/SEMICOLON. */
+ Make sure the next token is a name, then pass it along to the expression
+ evaluator as an LHS expression. The callback function is _3_. */
static ffelexHandler
-ffestb_R5284_ (ffelexToken t)
+ffestb_R8382_ (ffelexToken t)
{
- switch (ffelex_token_type (t))
+ if (ffelex_token_type (t) == FFELEX_typeNAME)
{
- case FFELEX_typeCOMMA:
- return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool,
- FFEEXPR_contextDATA,
- (ffeexprCallback) ffestb_R5281_);
+ return (ffelexHandler)
+ (*((ffelexHandler)
+ ffeexpr_lhs (ffesta_output_pool, FFEEXPR_contextASSIGN,
+ (ffeexprCallback) ffestb_R8383_)))
+ (t);
+ }
- case FFELEX_typeNAME:
- case FFELEX_typeOPEN_PAREN:
- return (ffelexHandler) (*((ffelexHandler)
- ffeexpr_lhs (ffesta_output_pool,
- FFEEXPR_contextDATA,
- (ffeexprCallback) ffestb_R5281_)))
- (t);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "ASSIGN", t);
+ ffelex_token_kill (ffesta_tokens[1]);
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+}
+
+/* ffestb_R8383_ -- "ASSIGN" NUMBER ("TO") expression
+ (ffestb_R8383_) // to expression handler
+
+ Make sure the next token is an EOS or SEMICOLON. */
+
+static ffelexHandler
+ffestb_R8383_ (ffelexToken ft, ffebld expr, ffelexToken t)
+{
+ switch (ffelex_token_type (t))
+ {
case FFELEX_typeEOS:
case FFELEX_typeSEMICOLON:
+ ffesta_confirmed ();
+ if (expr == NULL)
+ break;
if (!ffesta_is_inhibited ())
- ffestc_R528_finish ();
+ ffestc_R838 (ffesta_tokens[1], expr, ft);
+ ffelex_token_kill (ffesta_tokens[1]);
return (ffelexHandler) ffesta_zero (t);
default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DATA", t);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "ASSIGN", t);
break;
}
- if (!ffesta_is_inhibited ())
- ffestc_R528_finish ();
+ ffelex_token_kill (ffesta_tokens[1]);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R537 -- Parse a PARAMETER statement
+/* ffestb_R840 -- Parse an arithmetic-IF statement
- return ffestb_R537; // to lexer
+ return ffestb_R840; // to lexer
- Make sure the statement has a valid form for an PARAMETER statement.
+ Make sure the statement has a valid form for an arithmetic-IF statement.
If it does, implement the statement. */
ffelexHandler
-ffestb_R537 (ffelexToken t)
+ffestb_R840 (ffelexToken t)
{
switch (ffelex_token_type (ffesta_tokens[0]))
{
case FFELEX_typeNAME:
- if (ffesta_first_kw != FFESTR_firstPARAMETER)
+ if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlIF)
+ goto bad_0; /* :::::::::::::::::::: */
+ if (ffesta_first_kw != FFESTR_firstIF)
goto bad_0; /* :::::::::::::::::::: */
break;
case FFELEX_typeNAMES:
- if (ffesta_first_kw != FFESTR_firstPARAMETER)
- goto bad_0; /* :::::::::::::::::::: */
- if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlPARAMETER)
+ if (ffesta_first_kw != FFESTR_firstIF)
goto bad_0; /* :::::::::::::::::::: */
break;
case FFELEX_typeOPEN_PAREN:
break;
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
-
default:
goto bad_1; /* :::::::::::::::::::: */
}
- ffestb_local_.parameter.started = FALSE;
- return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool,
- FFEEXPR_contextPARAMETER,
- (ffeexprCallback) ffestb_R5371_);
+ return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, FFEEXPR_contextARITHIF,
+ (ffeexprCallback) ffestb_R8401_);
bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "PARAMETER", ffesta_tokens[0]);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "arithmetic-IF", ffesta_tokens[0]);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "PARAMETER", t);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "arithmetic-IF", t);
return (ffelexHandler) ffelex_swallow_tokens (t,
(ffelexHandler) ffesta_zero); /* Invalid second token. */
}
-/* ffestb_R5371_ -- "PARAMETER" OPEN_PAREN expr
+/* ffestb_R8401_ -- "IF" OPEN_PAREN expr
- (ffestb_R5371_) // to expression handler
+ (ffestb_R8401_) // to expression handler
- Make sure the next token is EQUALS. */
+ Make sure the next token is CLOSE_PAREN. */
static ffelexHandler
-ffestb_R5371_ (ffelexToken ft, ffebld expr, ffelexToken t)
+ffestb_R8401_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
- ffestb_local_.parameter.expr = expr;
+ ffestb_local_.if_stmt.expr = expr;
switch (ffelex_token_type (t))
{
- case FFELEX_typeEQUALS:
- ffesta_confirmed ();
+ case FFELEX_typeCLOSE_PAREN:
if (expr == NULL)
break;
ffesta_tokens[1] = ffelex_token_use (ft);
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextPARAMETER, (ffeexprCallback) ffestb_R5372_);
+ ffelex_set_names (TRUE); /* In case it's a logical IF instead. */
+ return (ffelexHandler) ffestb_R8402_;
default:
break;
}
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "PARAMETER", t);
- if (ffestb_local_.parameter.started)
- ffestc_R537_finish ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "arithmetic-IF", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R5372_ -- "PARAMETER" OPEN_PAREN expr EQUALS expr
+/* ffestb_R8402_ -- "IF" OPEN_PAREN expr CLOSE_PAREN
- (ffestb_R5372_) // to expression handler
+ return ffestb_R8402_; // to lexer
- Make sure the next token is COMMA or CLOSE_PAREN. */
+ Make sure the next token is NUMBER. */
static ffelexHandler
-ffestb_R5372_ (ffelexToken ft, ffebld expr, ffelexToken t)
+ffestb_R8402_ (ffelexToken t)
{
+ ffelex_set_names (FALSE);
+
switch (ffelex_token_type (t))
{
- case FFELEX_typeCOMMA:
- if (expr == NULL)
- break;
- if (!ffesta_is_inhibited ())
- {
- if (!ffestb_local_.parameter.started)
- {
- ffestc_R537_start ();
- ffestb_local_.parameter.started = TRUE;
- }
- ffestc_R537_item (ffestb_local_.parameter.expr, ffesta_tokens[1],
- expr, ft);
- }
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool,
- FFEEXPR_contextPARAMETER,
- (ffeexprCallback) ffestb_R5371_);
-
- case FFELEX_typeCLOSE_PAREN:
- if (expr == NULL)
- break;
- if (!ffesta_is_inhibited ())
- {
- if (!ffestb_local_.parameter.started)
- {
- ffestc_R537_start ();
- ffestb_local_.parameter.started = TRUE;
- }
- ffestc_R537_item (ffestb_local_.parameter.expr, ffesta_tokens[1],
- expr, ft);
- ffestc_R537_finish ();
- }
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffestb_R5373_;
+ case FFELEX_typeNUMBER:
+ ffesta_confirmed ();
+ ffesta_tokens[2] = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_R8403_;
default:
break;
}
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "PARAMETER", t);
- if (ffestb_local_.parameter.started)
- ffestc_R537_finish ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "arithmetic-IF", t);
ffelex_token_kill (ffesta_tokens[1]);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R5373_ -- "PARAMETER" OPEN_PAREN expr EQUALS expr CLOSE_PAREN
+/* ffestb_R8403_ -- "IF" OPEN_PAREN expr CLOSE_PAREN NUMBER
- return ffestb_R5373_; // to lexer
+ return ffestb_R8403_; // to lexer
- Make sure the next token is EOS or SEMICOLON, or generate an error. All
- cleanup has already been done, by the way. */
+ Make sure the next token is COMMA. */
static ffelexHandler
-ffestb_R5373_ (ffelexToken t)
+ffestb_R8403_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- return (ffelexHandler) ffesta_zero (t);
+ case FFELEX_typeCOMMA:
+ return (ffelexHandler) ffestb_R8404_;
default:
break;
}
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "PARAMETER", t);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "arithmetic-IF", t);
+ ffelex_token_kill (ffesta_tokens[1]);
+ ffelex_token_kill (ffesta_tokens[2]);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R542 -- Parse the NAMELIST statement
+/* ffestb_R8404_ -- "IF" OPEN_PAREN expr CLOSE_PAREN NUMBER COMMA
- return ffestb_R542; // to lexer
+ return ffestb_R8404_; // to lexer
- Make sure the statement has a valid form for the NAMELIST statement. If it
- does, implement the statement. */
+ Make sure the next token is NUMBER. */
-ffelexHandler
-ffestb_R542 (ffelexToken t)
+static ffelexHandler
+ffestb_R8404_ (ffelexToken t)
{
- const char *p;
- ffeTokenLength i;
-
- switch (ffelex_token_type (ffesta_tokens[0]))
- {
- case FFELEX_typeNAME:
- if (ffesta_first_kw != FFESTR_firstNAMELIST)
- goto bad_0; /* :::::::::::::::::::: */
- break;
-
- case FFELEX_typeNAMES:
- if (ffesta_first_kw != FFESTR_firstNAMELIST)
- goto bad_0; /* :::::::::::::::::::: */
- p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlNAMELIST);
- if (*p != '\0')
- goto bad_i; /* :::::::::::::::::::: */
- break;
-
- default:
- goto bad_0; /* :::::::::::::::::::: */
- }
-
switch (ffelex_token_type (t))
{
- case FFELEX_typeCOMMA:
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
+ case FFELEX_typeNUMBER:
+ ffesta_tokens[3] = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_R8405_;
default:
- goto bad_1; /* :::::::::::::::::::: */
-
- case FFELEX_typeSLASH:
break;
}
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- ffestc_R542_start ();
- return (ffelexHandler) ffestb_R5421_;
-
-bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "NAMELIST", ffesta_tokens[0]);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-
-bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "NAMELIST", t);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero); /* Invalid second token. */
-
-bad_i: /* :::::::::::::::::::: */
- ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "NAMELIST", ffesta_tokens[0], i, t);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "arithmetic-IF", t);
+ ffelex_token_kill (ffesta_tokens[1]);
+ ffelex_token_kill (ffesta_tokens[2]);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R5421_ -- "NAMELIST" SLASH
+/* ffestb_R8405_ -- "IF" OPEN_PAREN expr CLOSE_PAREN NUMBER COMMA NUMBER
- return ffestb_R5421_; // to lexer
+ return ffestb_R8405_; // to lexer
- Handle NAME. */
+ Make sure the next token is COMMA. */
static ffelexHandler
-ffestb_R5421_ (ffelexToken t)
+ffestb_R8405_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeNAME:
- if (!ffesta_is_inhibited ())
- ffestc_R542_item_nlist (t);
- return (ffelexHandler) ffestb_R5422_;
+ case FFELEX_typeCOMMA:
+ return (ffelexHandler) ffestb_R8406_;
default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "NAMELIST", t);
break;
}
- if (!ffesta_is_inhibited ())
- ffestc_R542_finish ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "arithmetic-IF", t);
+ ffelex_token_kill (ffesta_tokens[1]);
+ ffelex_token_kill (ffesta_tokens[2]);
+ ffelex_token_kill (ffesta_tokens[3]);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R5422_ -- "NAMELIST" SLASH NAME
+/* ffestb_R8406_ -- "IF" OPEN_PAREN expr CLOSE_PAREN NUMBER COMMA NUMBER COMMA
- return ffestb_R5422_; // to lexer
+ return ffestb_R8406_; // to lexer
- Handle SLASH. */
+ Make sure the next token is NUMBER. */
static ffelexHandler
-ffestb_R5422_ (ffelexToken t)
+ffestb_R8406_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeSLASH:
- return (ffelexHandler) ffestb_R5423_;
+ case FFELEX_typeNUMBER:
+ ffesta_tokens[4] = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_R8407_;
default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "NAMELIST", t);
break;
}
- if (!ffesta_is_inhibited ())
- ffestc_R542_finish ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "arithmetic-IF", t);
+ ffelex_token_kill (ffesta_tokens[1]);
+ ffelex_token_kill (ffesta_tokens[2]);
+ ffelex_token_kill (ffesta_tokens[3]);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R5423_ -- "NAMELIST" SLASH NAME SLASH
+/* ffestb_R8407_ -- "IF" OPEN_PAREN expr CLOSE_PAREN NUMBER COMMA NUMBER COMMA
+ NUMBER
- return ffestb_R5423_; // to lexer
+ return ffestb_R8407_; // to lexer
- Handle NAME. */
+ Make sure the next token is EOS or SEMICOLON. */
static ffelexHandler
-ffestb_R5423_ (ffelexToken t)
+ffestb_R8407_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeNAME:
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
if (!ffesta_is_inhibited ())
- ffestc_R542_item_nitem (t);
- return (ffelexHandler) ffestb_R5424_;
+ ffestc_R840 (ffestb_local_.if_stmt.expr, ffesta_tokens[1],
+ ffesta_tokens[2], ffesta_tokens[3], ffesta_tokens[4]);
+ ffelex_token_kill (ffesta_tokens[1]);
+ ffelex_token_kill (ffesta_tokens[2]);
+ ffelex_token_kill (ffesta_tokens[3]);
+ ffelex_token_kill (ffesta_tokens[4]);
+ return (ffelexHandler) ffesta_zero (t);
default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "NAMELIST", t);
break;
}
- if (!ffesta_is_inhibited ())
- ffestc_R542_finish ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "arithmetic-IF", t);
+ ffelex_token_kill (ffesta_tokens[1]);
+ ffelex_token_kill (ffesta_tokens[2]);
+ ffelex_token_kill (ffesta_tokens[3]);
+ ffelex_token_kill (ffesta_tokens[4]);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R5424_ -- "NAMELIST" SLASH NAME SLASH NAME
+/* ffestb_R841 -- Parse the CONTINUE statement
- return ffestb_R5424_; // to lexer
+ return ffestb_R841; // to lexer
- Handle COMMA, EOS/SEMICOLON, or SLASH. */
+ Make sure the statement has a valid form for the CONTINUE statement. If
+ it does, implement the statement. */
-static ffelexHandler
-ffestb_R5424_ (ffelexToken t)
+ffelexHandler
+ffestb_R841 (ffelexToken t)
{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- return (ffelexHandler) ffestb_R5425_;
+ const char *p;
+ ffeTokenLength i;
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- if (!ffesta_is_inhibited ())
- ffestc_R542_finish ();
- return (ffelexHandler) ffesta_zero (t);
-
- case FFELEX_typeSLASH:
- return (ffelexHandler) ffestb_R5421_;
-
- default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "NAMELIST", t);
- break;
- }
-
- if (!ffesta_is_inhibited ())
- ffestc_R542_finish ();
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R5425_ -- "NAMELIST" SLASH NAME SLASH NAME COMMA
-
- return ffestb_R5425_; // to lexer
-
- Handle NAME or SLASH. */
-
-static ffelexHandler
-ffestb_R5425_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- if (!ffesta_is_inhibited ())
- ffestc_R542_item_nitem (t);
- return (ffelexHandler) ffestb_R5424_;
-
- case FFELEX_typeSLASH:
- return (ffelexHandler) ffestb_R5421_;
-
- default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "NAMELIST", t);
- break;
- }
-
- if (!ffesta_is_inhibited ())
- ffestc_R542_finish ();
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R544 -- Parse an EQUIVALENCE statement
-
- return ffestb_R544; // to lexer
-
- Make sure the statement has a valid form for an EQUIVALENCE statement.
- If it does, implement the statement. */
-
-ffelexHandler
-ffestb_R544 (ffelexToken t)
-{
switch (ffelex_token_type (ffesta_tokens[0]))
{
case FFELEX_typeNAME:
- if (ffesta_first_kw != FFESTR_firstEQUIVALENCE)
+ if (ffesta_first_kw != FFESTR_firstCONTINUE)
goto bad_0; /* :::::::::::::::::::: */
break;
case FFELEX_typeNAMES:
- if (ffesta_first_kw != FFESTR_firstEQUIVALENCE)
- goto bad_0; /* :::::::::::::::::::: */
- if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlEQUIVALENCE)
+ if (ffesta_first_kw != FFESTR_firstCONTINUE)
goto bad_0; /* :::::::::::::::::::: */
+ if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlCONTINUE)
+ {
+ p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlCONTINUE);
+ goto bad_i; /* :::::::::::::::::::: */
+ }
break;
default:
switch (ffelex_token_type (t))
{
- case FFELEX_typeOPEN_PAREN:
- break;
-
case FFELEX_typeEOS:
case FFELEX_typeSEMICOLON:
+ ffesta_confirmed ();
+ if (!ffesta_is_inhibited ())
+ ffestc_R841 ();
+ return (ffelexHandler) ffesta_zero (t);
+
case FFELEX_typeCOMMA:
case FFELEX_typeCOLONCOLON:
ffesta_confirmed (); /* Error, but clearly intended. */
goto bad_1; /* :::::::::::::::::::: */
}
- ffestb_local_.equivalence.started = FALSE;
- return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool,
- FFEEXPR_contextEQUIVALENCE,
- (ffeexprCallback) ffestb_R5441_);
-
bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "EQUIVALENCE", ffesta_tokens[0]);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CONTINUE", ffesta_tokens[0]);
+ return (ffelexHandler) ffelex_swallow_tokens (t,
+ (ffelexHandler) ffesta_zero); /* Invalid first token. */
bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "EQUIVALENCE", t);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CONTINUE", t);
return (ffelexHandler) ffelex_swallow_tokens (t,
(ffelexHandler) ffesta_zero); /* Invalid second token. */
+
+bad_i: /* :::::::::::::::::::: */
+ ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "CONTINUE", ffesta_tokens[0], i, t);
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R5441_ -- "EQUIVALENCE" OPEN_PAREN expr
+/* ffestb_R1102 -- Parse the PROGRAM statement
- (ffestb_R5441_) // to expression handler
+ return ffestb_R1102; // to lexer
- Make sure the next token is COMMA. */
+ Make sure the statement has a valid form for the PROGRAM statement. If it
+ does, implement the statement. */
-static ffelexHandler
-ffestb_R5441_ (ffelexToken ft, ffebld expr, ffelexToken t)
+ffelexHandler
+ffestb_R1102 (ffelexToken t)
{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- if (expr == NULL)
- break;
- ffestb_local_.equivalence.exprs = ffestt_exprlist_create ();
- ffestt_exprlist_append (ffestb_local_.equivalence.exprs, expr,
- ffelex_token_use (ft));
- return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool,
- FFEEXPR_contextEQUIVALENCE,
- (ffeexprCallback) ffestb_R5442_);
+ ffeTokenLength i;
+ unsigned const char *p;
- default:
- break;
- }
+ switch (ffelex_token_type (ffesta_tokens[0]))
+ {
+ case FFELEX_typeNAME:
+ if (ffesta_first_kw != FFESTR_firstPROGRAM)
+ goto bad_0; /* :::::::::::::::::::: */
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ case FFELEX_typeCOMMA:
+ case FFELEX_typeCOLONCOLON:
+ ffesta_confirmed (); /* Error, but clearly intended. */
+ goto bad_1; /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "EQUIVALENCE", t);
- if (ffestb_local_.equivalence.started)
- ffestc_R544_finish ();
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
+ default:
+ goto bad_1; /* :::::::::::::::::::: */
-/* ffestb_R5442_ -- "EQUIVALENCE" OPEN_PAREN expr COMMA expr
+ case FFELEX_typeNAME:
+ break;
+ }
- (ffestb_R5442_) // to expression handler
+ ffesta_confirmed ();
+ ffesta_tokens[1] = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_R11021_;
- Make sure the next token is COMMA or CLOSE_PAREN. For COMMA, we just
- append the expression to our list and continue; for CLOSE_PAREN, we
- append the expression and move to _3_. */
+ case FFELEX_typeNAMES:
+ if (ffesta_first_kw != FFESTR_firstPROGRAM)
+ goto bad_0; /* :::::::::::::::::::: */
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeCOMMA:
+ case FFELEX_typeCOLONCOLON:
+ ffesta_confirmed (); /* Error, but clearly intended. */
+ goto bad_1; /* :::::::::::::::::::: */
-static ffelexHandler
-ffestb_R5442_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- if (expr == NULL)
- break;
- ffestt_exprlist_append (ffestb_local_.equivalence.exprs, expr,
- ffelex_token_use (ft));
- return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool,
- FFEEXPR_contextEQUIVALENCE,
- (ffeexprCallback) ffestb_R5442_);
+ default:
+ goto bad_1; /* :::::::::::::::::::: */
- case FFELEX_typeCLOSE_PAREN:
- if (expr == NULL)
- break;
- ffestt_exprlist_append (ffestb_local_.equivalence.exprs, expr,
- ffelex_token_use (ft));
- return (ffelexHandler) ffestb_R5443_;
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ break;
+ }
+ ffesta_confirmed ();
+ p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlPROGRAM);
+ if (!ffesrc_is_name_init (*p))
+ goto bad_i; /* :::::::::::::::::::: */
+ ffesta_tokens[1]
+ = ffelex_token_name_from_names (ffesta_tokens[0], i, 0);
+ return (ffelexHandler) ffestb_R11021_ (t);
default:
- break;
+ goto bad_0; /* :::::::::::::::::::: */
}
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "EQUIVALENCE", t);
- if (ffestb_local_.equivalence.started)
- ffestc_R544_finish ();
- ffestt_exprlist_kill (ffestb_local_.equivalence.exprs);
+bad_0: /* :::::::::::::::::::: */
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "PROGRAM", ffesta_tokens[0]);
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+
+bad_1: /* :::::::::::::::::::: */
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "PROGRAM", t);
+ return (ffelexHandler) ffelex_swallow_tokens (t,
+ (ffelexHandler) ffesta_zero); /* Invalid second token. */
+
+bad_i: /* :::::::::::::::::::: */
+ ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "PROGRAM", ffesta_tokens[0], i, t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R5443_ -- "EQUIVALENCE" OPEN_PAREN expr COMMA expr CLOSE_PAREN
+/* ffestb_R11021_ -- "PROGRAM" NAME
- return ffestb_R5443_; // to lexer
+ return ffestb_R11021_; // to lexer
- Make sure the next token is COMMA or EOS/SEMICOLON. */
+ Make sure the next token is an EOS or SEMICOLON. */
static ffelexHandler
-ffestb_R5443_ (ffelexToken t)
+ffestb_R11021_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeCOMMA:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- {
- if (!ffestb_local_.equivalence.started)
- {
- ffestc_R544_start ();
- ffestb_local_.equivalence.started = TRUE;
- }
- ffestc_R544_item (ffestb_local_.equivalence.exprs);
- }
- ffestt_exprlist_kill (ffestb_local_.equivalence.exprs);
- return (ffelexHandler) ffestb_R5444_;
-
case FFELEX_typeEOS:
case FFELEX_typeSEMICOLON:
ffesta_confirmed ();
if (!ffesta_is_inhibited ())
- {
- if (!ffestb_local_.equivalence.started)
- {
- ffestc_R544_start ();
- ffestb_local_.equivalence.started = TRUE;
- }
- ffestc_R544_item (ffestb_local_.equivalence.exprs);
- ffestc_R544_finish ();
- }
- ffestt_exprlist_kill (ffestb_local_.equivalence.exprs);
+ ffestc_R1102 (ffesta_tokens[1]);
+ ffelex_token_kill (ffesta_tokens[1]);
return (ffelexHandler) ffesta_zero (t);
default:
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "PROGRAM", t);
break;
}
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "EQUIVALENCE", t);
- if (ffestb_local_.equivalence.started)
- ffestc_R544_finish ();
- ffestt_exprlist_kill (ffestb_local_.equivalence.exprs);
+ ffelex_token_kill (ffesta_tokens[1]);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R5444_ -- "EQUIVALENCE" OPEN_PAREN expr COMMA expr CLOSE_PAREN COMMA
+/* ffestb_block -- Parse the BLOCK DATA statement
- return ffestb_R5444_; // to lexer
+ return ffestb_block; // to lexer
- Make sure the next token is OPEN_PAREN, or generate an error. */
+ Make sure the statement has a valid form for the BLOCK DATA statement. If
+ it does, implement the statement. */
-static ffelexHandler
-ffestb_R5444_ (ffelexToken t)
+ffelexHandler
+ffestb_block (ffelexToken t)
{
- switch (ffelex_token_type (t))
+ switch (ffelex_token_type (ffesta_tokens[0]))
{
- case FFELEX_typeOPEN_PAREN:
- return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool,
- FFEEXPR_contextEQUIVALENCE,
- (ffeexprCallback) ffestb_R5441_);
+ case FFELEX_typeNAME:
+ if (ffesta_first_kw != FFESTR_firstBLOCK)
+ goto bad_0; /* :::::::::::::::::::: */
+ switch (ffelex_token_type (t))
+ {
+ default:
+ goto bad_1; /* :::::::::::::::::::: */
+
+ case FFELEX_typeNAME:
+ if (ffesta_second_kw != FFESTR_secondDATA)
+ goto bad_1; /* :::::::::::::::::::: */
+ break;
+ }
+
+ ffesta_confirmed ();
+ return (ffelexHandler) ffestb_R1111_1_;
default:
- break;
+ goto bad_0; /* :::::::::::::::::::: */
}
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "EQUIVALENCE", t);
- if (ffestb_local_.equivalence.started)
- ffestc_R544_finish ();
+bad_0: /* :::::::::::::::::::: */
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "BLOCK DATA", ffesta_tokens[0]);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+
+bad_1: /* :::::::::::::::::::: */
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "BLOCK DATA", t);
+ return (ffelexHandler) ffelex_swallow_tokens (t,
+ (ffelexHandler) ffesta_zero); /* Invalid second token. */
}
-/* ffestb_R834 -- Parse the CYCLE statement
+/* ffestb_blockdata -- Parse the BLOCKDATA statement
- return ffestb_R834; // to lexer
+ return ffestb_blockdata; // to lexer
- Make sure the statement has a valid form for the CYCLE statement. If
+ Make sure the statement has a valid form for the BLOCKDATA statement. If
it does, implement the statement. */
ffelexHandler
-ffestb_R834 (ffelexToken t)
+ffestb_blockdata (ffelexToken t)
{
ffeTokenLength i;
unsigned const char *p;
switch (ffelex_token_type (ffesta_tokens[0]))
{
case FFELEX_typeNAME:
- if (ffesta_first_kw != FFESTR_firstCYCLE)
+ if (ffesta_first_kw != FFESTR_firstBLOCKDATA)
goto bad_0; /* :::::::::::::::::::: */
switch (ffelex_token_type (t))
{
case FFELEX_typeNAME:
ffesta_confirmed ();
ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_R8341_;
+ return (ffelexHandler) ffestb_R1111_2_;
case FFELEX_typeEOS:
case FFELEX_typeSEMICOLON:
ffesta_confirmed ();
ffesta_tokens[1] = NULL;
- return (ffelexHandler) ffestb_R8341_ (t);
+ return (ffelexHandler) ffestb_R1111_2_ (t);
}
case FFELEX_typeNAMES:
- if (ffesta_first_kw != FFESTR_firstCYCLE)
+ if (ffesta_first_kw != FFESTR_firstBLOCKDATA)
goto bad_0; /* :::::::::::::::::::: */
switch (ffelex_token_type (t))
{
break;
}
ffesta_confirmed ();
- p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlCYCLE);
+ p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlBLOCKDATA);
if (*p == '\0')
{
ffesta_tokens[1] = NULL;
ffesta_tokens[1]
= ffelex_token_name_from_names (ffesta_tokens[0], i, 0);
}
- return (ffelexHandler) ffestb_R8341_ (t);
+ return (ffelexHandler) ffestb_R1111_2_ (t);
default:
goto bad_0; /* :::::::::::::::::::: */
}
bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CYCLE", ffesta_tokens[0]);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "BLOCK DATA", ffesta_tokens[0]);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CYCLE", t);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "BLOCK DATA", t);
return (ffelexHandler) ffelex_swallow_tokens (t,
(ffelexHandler) ffesta_zero); /* Invalid second token. */
bad_i: /* :::::::::::::::::::: */
- ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "CYCLE", ffesta_tokens[0], i, t);
+ ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "BLOCK DATA", ffesta_tokens[0], i, t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R8341_ -- "CYCLE" [NAME]
+/* ffestb_R1111_1_ -- "BLOCK" "DATA"
- return ffestb_R8341_; // to lexer
+ return ffestb_R1111_1_; // to lexer
+
+ Make sure the next token is a NAME, EOS, or SEMICOLON token. */
+
+static ffelexHandler
+ffestb_R1111_1_ (ffelexToken t)
+{
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeNAME:
+ ffesta_tokens[1] = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_R1111_2_;
+
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ ffesta_tokens[1] = NULL;
+ return (ffelexHandler) ffestb_R1111_2_ (t);
+
+ default:
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "BLOCK DATA", t);
+ break;
+ }
+
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+}
+
+/* ffestb_R1111_2_ -- "BLOCK/DATA" NAME
+
+ return ffestb_R1111_2_; // to lexer
Make sure the next token is an EOS or SEMICOLON. */
static ffelexHandler
-ffestb_R8341_ (ffelexToken t)
+ffestb_R1111_2_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
case FFELEX_typeSEMICOLON:
ffesta_confirmed ();
if (!ffesta_is_inhibited ())
- ffestc_R834 (ffesta_tokens[1]);
+ ffestc_R1111 (ffesta_tokens[1]);
if (ffesta_tokens[1] != NULL)
ffelex_token_kill (ffesta_tokens[1]);
return (ffelexHandler) ffesta_zero (t);
default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CYCLE", t);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "BLOCK DATA", t);
break;
}
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R835 -- Parse the EXIT statement
+/* ffestb_R1212 -- Parse the CALL statement
- return ffestb_R835; // to lexer
+ return ffestb_R1212; // to lexer
- Make sure the statement has a valid form for the EXIT statement. If
- it does, implement the statement. */
+ Make sure the statement has a valid form for the CALL statement. If it
+ does, implement the statement. */
ffelexHandler
-ffestb_R835 (ffelexToken t)
+ffestb_R1212 (ffelexToken t)
{
ffeTokenLength i;
unsigned const char *p;
+ ffelexHandler next;
+ ffelexToken nt;
switch (ffelex_token_type (ffesta_tokens[0]))
{
case FFELEX_typeNAME:
- if (ffesta_first_kw != FFESTR_firstEXIT)
+ if (ffesta_first_kw != FFESTR_firstCALL)
goto bad_0; /* :::::::::::::::::::: */
switch (ffelex_token_type (t))
{
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
case FFELEX_typeCOMMA:
case FFELEX_typeCOLONCOLON:
ffesta_confirmed (); /* Error, but clearly intended. */
goto bad_1; /* :::::::::::::::::::: */
case FFELEX_typeNAME:
- ffesta_confirmed ();
- ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_R8351_;
-
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- ffesta_tokens[1] = NULL;
- return (ffelexHandler) ffestb_R8351_ (t);
+ break;
}
+ ffesta_confirmed ();
+ return (ffelexHandler)
+ (*((ffelexHandler)
+ ffeexpr_lhs (ffesta_output_pool, FFEEXPR_contextSUBROUTINEREF,
+ (ffeexprCallback) ffestb_R12121_)))
+ (t);
case FFELEX_typeNAMES:
- if (ffesta_first_kw != FFESTR_firstEXIT)
+ if (ffesta_first_kw != FFESTR_firstCALL)
goto bad_0; /* :::::::::::::::::::: */
switch (ffelex_token_type (t))
{
+ case FFELEX_typeCOLONCOLON:
+ case FFELEX_typeCOMMA:
+ ffesta_confirmed (); /* Error, but clearly intended. */
+ goto bad_1; /* :::::::::::::::::::: */
+
default:
goto bad_1; /* :::::::::::::::::::: */
+ case FFELEX_typeOPEN_PAREN:
+ break;
+
case FFELEX_typeEOS:
case FFELEX_typeSEMICOLON:
+ ffesta_confirmed ();
break;
}
- ffesta_confirmed ();
- p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlEXIT);
- if (*p == '\0')
- {
- ffesta_tokens[1] = NULL;
- }
- else
- {
- if (!ffesrc_is_name_init (*p))
- goto bad_i; /* :::::::::::::::::::: */
- ffesta_tokens[1]
- = ffelex_token_name_from_names (ffesta_tokens[0], i, 0);
- }
- return (ffelexHandler) ffestb_R8351_ (t);
+ p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlCALL);
+ if (!ffesrc_is_name_init (*p))
+ goto bad_i; /* :::::::::::::::::::: */
+ nt = ffelex_token_name_from_names (ffesta_tokens[0], i, 0);
+ next = (ffelexHandler)
+ (*((ffelexHandler)
+ ffeexpr_lhs (ffesta_output_pool, FFEEXPR_contextSUBROUTINEREF,
+ (ffeexprCallback) ffestb_R12121_)))
+ (nt);
+ ffelex_token_kill (nt);
+ return (ffelexHandler) (*next) (t);
default:
goto bad_0; /* :::::::::::::::::::: */
}
bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "EXIT", ffesta_tokens[0]);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CALL", ffesta_tokens[0]);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "EXIT", t);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CALL", t);
return (ffelexHandler) ffelex_swallow_tokens (t,
(ffelexHandler) ffesta_zero); /* Invalid second token. */
bad_i: /* :::::::::::::::::::: */
- ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "EXIT", ffesta_tokens[0], i, t);
+ ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "CALL", ffesta_tokens[0], i, t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R8351_ -- "EXIT" [NAME]
+/* ffestb_R12121_ -- "CALL" expr
- return ffestb_R8351_; // to lexer
+ (ffestb_R12121_) // to expression handler
- Make sure the next token is an EOS or SEMICOLON. */
+ Make sure the statement has a valid form for the CALL statement. If it
+ does, implement the statement. */
static ffelexHandler
-ffestb_R8351_ (ffelexToken t)
+ffestb_R12121_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
switch (ffelex_token_type (t))
{
case FFELEX_typeEOS:
case FFELEX_typeSEMICOLON:
ffesta_confirmed ();
+ if (expr == NULL)
+ break;
if (!ffesta_is_inhibited ())
- ffestc_R835 (ffesta_tokens[1]);
- if (ffesta_tokens[1] != NULL)
- ffelex_token_kill (ffesta_tokens[1]);
+ ffestc_R1212 (expr, ft);
return (ffelexHandler) ffesta_zero (t);
default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "EXIT", t);
break;
}
- if (ffesta_tokens[1] != NULL)
- ffelex_token_kill (ffesta_tokens[1]);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CALL", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R838 -- Parse the ASSIGN statement
+/* ffestb_R1227 -- Parse the RETURN statement
- return ffestb_R838; // to lexer
+ return ffestb_R1227; // to lexer
- Make sure the statement has a valid form for the ASSIGN statement. If it
+ Make sure the statement has a valid form for the RETURN statement. If it
does, implement the statement. */
ffelexHandler
-ffestb_R838 (ffelexToken t)
+ffestb_R1227 (ffelexToken t)
{
- unsigned const char *p;
- ffeTokenLength i;
ffelexHandler next;
- ffelexToken et; /* First token in target. */
switch (ffelex_token_type (ffesta_tokens[0]))
{
case FFELEX_typeNAME:
- if (ffesta_first_kw != FFESTR_firstASSIGN)
+ if (ffesta_first_kw != FFESTR_firstRETURN)
goto bad_0; /* :::::::::::::::::::: */
switch (ffelex_token_type (t))
{
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
case FFELEX_typeCOMMA:
case FFELEX_typeCOLONCOLON:
ffesta_confirmed (); /* Error, but clearly intended. */
goto bad_1; /* :::::::::::::::::::: */
- default:
+ case FFELEX_typeEQUALS:
+ case FFELEX_typePOINTS:
+ case FFELEX_typeCOLON:
goto bad_1; /* :::::::::::::::::::: */
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ case FFELEX_typeNAME:
case FFELEX_typeNUMBER:
+ ffesta_confirmed ();
+ break;
+
+ default:
break;
}
- ffesta_tokens[1] = ffelex_token_use (t);
- ffesta_confirmed ();
- return (ffelexHandler) ffestb_R8381_;
+
+ return (ffelexHandler) (*((ffelexHandler)
+ ffeexpr_rhs (ffesta_output_pool, FFEEXPR_contextRETURN,
+ (ffeexprCallback) ffestb_R12271_)))
+ (t);
case FFELEX_typeNAMES:
- if (ffesta_first_kw != FFESTR_firstASSIGN)
+ if (ffesta_first_kw != FFESTR_firstRETURN)
goto bad_0; /* :::::::::::::::::::: */
-
switch (ffelex_token_type (t))
{
+ case FFELEX_typeCOMMA:
+ case FFELEX_typeCOLONCOLON:
+ ffesta_confirmed (); /* Error, but clearly intended. */
+ goto bad_1; /* :::::::::::::::::::: */
+
+ case FFELEX_typeEQUALS:
+ case FFELEX_typePOINTS:
+ case FFELEX_typeCOLON:
+ goto bad_1; /* :::::::::::::::::::: */
+
case FFELEX_typeEOS:
case FFELEX_typeSEMICOLON:
ffesta_confirmed ();
- /* Fall through. */
- case FFELEX_typePERCENT:
- case FFELEX_typeOPEN_PAREN:
- p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlASSIGN);
- if (! ISDIGIT (*p))
- goto bad_i; /* :::::::::::::::::::: */
- ffesta_tokens[1]
- = ffelex_token_number_from_names (ffesta_tokens[0], i);
- p += ffelex_token_length (ffesta_tokens[1]); /* Skip to "TO". */
- i += ffelex_token_length (ffesta_tokens[1]);
- if (!ffesrc_char_match_init (*p, 'T', 't') /* "TO". */
- || (++i, !ffesrc_char_match_noninit (*++p, 'O', 'o')))
- {
- bad_i_1: /* :::::::::::::::::::: */
- ffelex_token_kill (ffesta_tokens[1]);
- goto bad_i; /* :::::::::::::::::::: */
- }
- ++p, ++i;
- if (!ffesrc_is_name_init (*p))
- goto bad_i_1; /* :::::::::::::::::::: */
- et = ffelex_token_name_from_names (ffesta_tokens[0], i, 0);
- next = (ffelexHandler)
- (*((ffelexHandler)
- ffeexpr_lhs (ffesta_output_pool,
- FFEEXPR_contextASSIGN,
- (ffeexprCallback)
- ffestb_R8383_)))
- (et);
- ffelex_token_kill (et);
- return (ffelexHandler) (*next) (t);
-
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
+ break;
default:
- goto bad_1; /* :::::::::::::::::::: */
+ break;
}
+ next = (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ FFEEXPR_contextRETURN, (ffeexprCallback) ffestb_R12271_);
+ next = (ffelexHandler) ffelex_splice_tokens (next, ffesta_tokens[0],
+ FFESTR_firstlRETURN);
+ if (next == NULL)
+ return (ffelexHandler) ffelex_swallow_tokens (t,
+ (ffelexHandler) ffesta_zero);
+ return (ffelexHandler) (*next) (t);
default:
goto bad_0; /* :::::::::::::::::::: */
}
bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "ASSIGN", ffesta_tokens[0]);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero); /* Invalid first token. */
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "RETURN", ffesta_tokens[0]);
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "ASSIGN", t);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "RETURN", t);
return (ffelexHandler) ffelex_swallow_tokens (t,
(ffelexHandler) ffesta_zero); /* Invalid second token. */
-
-bad_i: /* :::::::::::::::::::: */
- ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "ASSIGN", ffesta_tokens[0], i, t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R8381_ -- "ASSIGN" NUMBER
-
- return ffestb_R8381_; // to lexer
-
- Make sure the next token is "TO". */
-
-static ffelexHandler
-ffestb_R8381_ (ffelexToken t)
-{
- if ((ffelex_token_type (t) == FFELEX_typeNAME)
- && (ffesrc_strcmp_2c (ffe_case_match (), ffelex_token_text (t), "TO", "to",
- "To") == 0))
- {
- return (ffelexHandler) ffestb_R8382_;
- }
-
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "ASSIGN", t);
- if (ffelex_token_type (t) == FFELEX_typeNAME)
- return (ffelexHandler) ffestb_R8382_ (t); /* Maybe user forgot "TO". */
-
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R8382_ -- "ASSIGN" NUMBER ("TO")
-
- return ffestb_R8382_; // to lexer
-
- Make sure the next token is a name, then pass it along to the expression
- evaluator as an LHS expression. The callback function is _3_. */
-
-static ffelexHandler
-ffestb_R8382_ (ffelexToken t)
-{
- if (ffelex_token_type (t) == FFELEX_typeNAME)
- {
- return (ffelexHandler)
- (*((ffelexHandler)
- ffeexpr_lhs (ffesta_output_pool, FFEEXPR_contextASSIGN,
- (ffeexprCallback) ffestb_R8383_)))
- (t);
- }
-
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "ASSIGN", t);
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R8383_ -- "ASSIGN" NUMBER ("TO") expression
+/* ffestb_R12271_ -- "RETURN" expr
- (ffestb_R8383_) // to expression handler
+ (ffestb_R12271_) // to expression handler
Make sure the next token is an EOS or SEMICOLON. */
static ffelexHandler
-ffestb_R8383_ (ffelexToken ft, ffebld expr, ffelexToken t)
+ffestb_R12271_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
switch (ffelex_token_type (t))
{
case FFELEX_typeEOS:
case FFELEX_typeSEMICOLON:
ffesta_confirmed ();
- if (expr == NULL)
- break;
if (!ffesta_is_inhibited ())
- ffestc_R838 (ffesta_tokens[1], expr, ft);
- ffelex_token_kill (ffesta_tokens[1]);
+ ffestc_R1227 (expr, ft);
return (ffelexHandler) ffesta_zero (t);
default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "ASSIGN", t);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "RETURN", t);
break;
}
- ffelex_token_kill (ffesta_tokens[1]);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R840 -- Parse an arithmetic-IF statement
+/* ffestb_construct -- Parse a construct name
- return ffestb_R840; // to lexer
+ return ffestb_construct; // to lexer
- Make sure the statement has a valid form for an arithmetic-IF statement.
- If it does, implement the statement. */
+ Make sure the statement can have a construct name (if-then-stmt, do-stmt,
+ select-case-stmt). */
ffelexHandler
-ffestb_R840 (ffelexToken t)
+ffestb_construct (ffelexToken t UNUSED)
{
- switch (ffelex_token_type (ffesta_tokens[0]))
- {
- case FFELEX_typeNAME:
- if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlIF)
- goto bad_0; /* :::::::::::::::::::: */
- if (ffesta_first_kw != FFESTR_firstIF)
- goto bad_0; /* :::::::::::::::::::: */
- break;
-
- case FFELEX_typeNAMES:
- if (ffesta_first_kw != FFESTR_firstIF)
- goto bad_0; /* :::::::::::::::::::: */
- break;
-
- default:
- goto bad_0; /* :::::::::::::::::::: */
- }
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeOPEN_PAREN:
- break;
-
- default:
- goto bad_1; /* :::::::::::::::::::: */
- }
-
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, FFEEXPR_contextARITHIF,
- (ffeexprCallback) ffestb_R8401_);
-
-bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "arithmetic-IF", ffesta_tokens[0]);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+ /* This handler gets invoked only when token 0 is NAME/NAMES and token 1 is
+ COLON. */
-bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "arithmetic-IF", t);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero); /* Invalid second token. */
+ ffesta_confirmed ();
+ ffelex_set_names (TRUE);
+ return (ffelexHandler) ffestb_construct1_;
}
-/* ffestb_R8401_ -- "IF" OPEN_PAREN expr
+/* ffestb_construct1_ -- NAME COLON
- (ffestb_R8401_) // to expression handler
+ return ffestb_construct1_; // to lexer
- Make sure the next token is CLOSE_PAREN. */
+ Make sure we've got a NAME that is DO, DOWHILE, IF, SELECT, or SELECTCASE. */
static ffelexHandler
-ffestb_R8401_ (ffelexToken ft, ffebld expr, ffelexToken t)
+ffestb_construct1_ (ffelexToken t)
{
- ffestb_local_.if_stmt.expr = expr;
+ ffelex_set_names (FALSE);
switch (ffelex_token_type (t))
{
- case FFELEX_typeCLOSE_PAREN:
- if (expr == NULL)
- break;
- ffesta_tokens[1] = ffelex_token_use (ft);
- ffelex_set_names (TRUE); /* In case it's a logical IF instead. */
- return (ffelexHandler) ffestb_R8402_;
+ case FFELEX_typeNAME:
+ ffesta_first_kw = ffestr_first (t);
+ switch (ffesta_first_kw)
+ {
+ case FFESTR_firstIF:
+ ffestb_local_.construct.next = (ffelexHandler) ffestb_if;
+ break;
- default:
- break;
- }
+ case FFESTR_firstDO:
+ ffestb_local_.construct.next = (ffelexHandler) ffestb_do;
+ break;
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "arithmetic-IF", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
+ case FFESTR_firstDOWHILE:
+ ffestb_local_.construct.next = (ffelexHandler) ffestb_dowhile;
+ break;
-/* ffestb_R8402_ -- "IF" OPEN_PAREN expr CLOSE_PAREN
+ case FFESTR_firstSELECT:
+ case FFESTR_firstSELECTCASE:
+ ffestb_local_.construct.next = (ffelexHandler) ffestb_R809;
+ break;
- return ffestb_R8402_; // to lexer
+ default:
+ goto bad; /* :::::::::::::::::::: */
+ }
+ ffesta_construct_name = ffesta_tokens[0];
+ ffesta_tokens[0] = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_construct2_;
- Make sure the next token is NUMBER. */
+ case FFELEX_typeNAMES:
+ ffesta_first_kw = ffestr_first (t);
+ switch (ffesta_first_kw)
+ {
+ case FFESTR_firstIF:
+ if (ffelex_token_length (t) != FFESTR_firstlIF)
+ goto bad; /* :::::::::::::::::::: */
+ ffestb_local_.construct.next = (ffelexHandler) ffestb_if;
+ break;
-static ffelexHandler
-ffestb_R8402_ (ffelexToken t)
-{
- ffelex_set_names (FALSE);
+ case FFESTR_firstDO:
+ ffestb_local_.construct.next = (ffelexHandler) ffestb_do;
+ break;
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNUMBER:
- ffesta_confirmed ();
- ffesta_tokens[2] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_R8403_;
+ case FFESTR_firstDOWHILE:
+ if (ffelex_token_length (t) != FFESTR_firstlDOWHILE)
+ goto bad; /* :::::::::::::::::::: */
+ ffestb_local_.construct.next = (ffelexHandler) ffestb_dowhile;
+ break;
+
+ case FFESTR_firstSELECTCASE:
+ if (ffelex_token_length (t) != FFESTR_firstlSELECTCASE)
+ goto bad; /* :::::::::::::::::::: */
+ ffestb_local_.construct.next = (ffelexHandler) ffestb_R809;
+ break;
+
+ default:
+ goto bad; /* :::::::::::::::::::: */
+ }
+ ffesta_construct_name = ffesta_tokens[0];
+ ffesta_tokens[0] = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_construct2_;
default:
break;
}
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "arithmetic-IF", t);
- ffelex_token_kill (ffesta_tokens[1]);
+bad: /* :::::::::::::::::::: */
+ ffesta_ffebad_2st (FFEBAD_INVALID_STMT_FORM, "CONSTRUCT",
+ ffesta_tokens[0], t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R8403_ -- "IF" OPEN_PAREN expr CLOSE_PAREN NUMBER
+/* ffestb_construct2_ -- NAME COLON "DO/DOWHILE/IF/SELECT/SELECTCASE"
- return ffestb_R8403_; // to lexer
+ return ffestb_construct2_; // to lexer
- Make sure the next token is COMMA. */
+ This extra step is needed to set ffesta_second_kw if the second token
+ (here) is a NAME, so DO and SELECT can continue to expect it. */
static ffelexHandler
-ffestb_R8403_ (ffelexToken t)
+ffestb_construct2_ (ffelexToken t)
{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- return (ffelexHandler) ffestb_R8404_;
-
- default:
- break;
- }
-
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "arithmetic-IF", t);
- ffelex_token_kill (ffesta_tokens[1]);
- ffelex_token_kill (ffesta_tokens[2]);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+ if (ffelex_token_type (t) == FFELEX_typeNAME)
+ ffesta_second_kw = ffestr_second (t);
+ return (ffelexHandler) (*ffestb_local_.construct.next) (t);
}
-/* ffestb_R8404_ -- "IF" OPEN_PAREN expr CLOSE_PAREN NUMBER COMMA
+/* ffestb_R809 -- Parse the SELECTCASE statement
- return ffestb_R8404_; // to lexer
+ return ffestb_R809; // to lexer
- Make sure the next token is NUMBER. */
+ Make sure the statement has a valid form for the SELECTCASE statement.
+ If it does, implement the statement. */
-static ffelexHandler
-ffestb_R8404_ (ffelexToken t)
+ffelexHandler
+ffestb_R809 (ffelexToken t)
{
- switch (ffelex_token_type (t))
+ ffeTokenLength i;
+ const char *p;
+
+ switch (ffelex_token_type (ffesta_tokens[0]))
{
- case FFELEX_typeNUMBER:
- ffesta_tokens[3] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_R8405_;
+ case FFELEX_typeNAME:
+ switch (ffesta_first_kw)
+ {
+ case FFESTR_firstSELECT:
+ if ((ffelex_token_type (t) != FFELEX_typeNAME)
+ || (ffesta_second_kw != FFESTR_secondCASE))
+ goto bad_1; /* :::::::::::::::::::: */
+ ffesta_confirmed ();
+ return (ffelexHandler) ffestb_R8091_;
+
+ case FFESTR_firstSELECTCASE:
+ return (ffelexHandler) ffestb_R8091_ (t);
+
+ default:
+ goto bad_0; /* :::::::::::::::::::: */
+ }
+
+ case FFELEX_typeNAMES:
+ if (ffesta_first_kw != FFESTR_firstSELECTCASE)
+ goto bad_0; /* :::::::::::::::::::: */
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeCOMMA:
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ case FFELEX_typeCOLONCOLON:
+ ffesta_confirmed (); /* Error, but clearly intended. */
+ goto bad_1; /* :::::::::::::::::::: */
+
+ default:
+ goto bad_1; /* :::::::::::::::::::: */
+
+ case FFELEX_typeOPEN_PAREN:
+ break;
+ }
+ p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlSELECTCASE);
+ if (*p != '\0')
+ goto bad_i; /* :::::::::::::::::::: */
+ return (ffelexHandler) ffestb_R8091_ (t);
default:
- break;
+ goto bad_0; /* :::::::::::::::::::: */
}
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "arithmetic-IF", t);
- ffelex_token_kill (ffesta_tokens[1]);
- ffelex_token_kill (ffesta_tokens[2]);
+bad_0: /* :::::::::::::::::::: */
+ if (ffesta_construct_name != NULL)
+ {
+ ffelex_token_kill (ffesta_construct_name);
+ ffesta_construct_name = NULL;
+ }
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "SELECT CASE", ffesta_tokens[0]);
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+
+bad_1: /* :::::::::::::::::::: */
+ if (ffesta_construct_name != NULL)
+ {
+ ffelex_token_kill (ffesta_construct_name);
+ ffesta_construct_name = NULL;
+ }
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "SELECT CASE", t);
+ return (ffelexHandler) ffelex_swallow_tokens (t,
+ (ffelexHandler) ffesta_zero); /* Invalid second token. */
+
+bad_i: /* :::::::::::::::::::: */
+ if (ffesta_construct_name != NULL)
+ {
+ ffelex_token_kill (ffesta_construct_name);
+ ffesta_construct_name = NULL;
+ }
+ ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "SELECT CASE", ffesta_tokens[0], i, t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R8405_ -- "IF" OPEN_PAREN expr CLOSE_PAREN NUMBER COMMA NUMBER
+/* ffestb_R8091_ -- "SELECTCASE" or "SELECT" "CASE"
- return ffestb_R8405_; // to lexer
+ return ffestb_R8091_; // to lexer
- Make sure the next token is COMMA. */
+ Make sure the statement has a valid form for the SELECTCASE statement. If it
+ does, implement the statement. */
static ffelexHandler
-ffestb_R8405_ (ffelexToken t)
+ffestb_R8091_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
+ case FFELEX_typeOPEN_PAREN:
+ return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ FFEEXPR_contextSELECTCASE, (ffeexprCallback) ffestb_R8092_);
+
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
case FFELEX_typeCOMMA:
- return (ffelexHandler) ffestb_R8406_;
+ case FFELEX_typeCOLONCOLON:
+ ffesta_confirmed (); /* Error, but clearly intended. */
+ break;
default:
break;
}
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "arithmetic-IF", t);
- ffelex_token_kill (ffesta_tokens[1]);
- ffelex_token_kill (ffesta_tokens[2]);
- ffelex_token_kill (ffesta_tokens[3]);
+ if (ffesta_construct_name != NULL)
+ {
+ ffelex_token_kill (ffesta_construct_name);
+ ffesta_construct_name = NULL;
+ }
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "SELECT CASE", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R8406_ -- "IF" OPEN_PAREN expr CLOSE_PAREN NUMBER COMMA NUMBER COMMA
+/* ffestb_R8092_ -- "SELECT/CASE" OPEN_PAREN expr
- return ffestb_R8406_; // to lexer
+ (ffestb_R8092_) // to expression handler
- Make sure the next token is NUMBER. */
+ Make sure the statement has a valid form for the SELECTCASE statement. If it
+ does, implement the statement. */
static ffelexHandler
-ffestb_R8406_ (ffelexToken t)
+ffestb_R8092_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeNUMBER:
- ffesta_tokens[4] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_R8407_;
+ case FFELEX_typeCLOSE_PAREN:
+ if (expr == NULL)
+ break;
+ ffesta_tokens[1] = ffelex_token_use (ft);
+ ffestb_local_.selectcase.expr = expr;
+ return (ffelexHandler) ffestb_R8093_;
default:
break;
}
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "arithmetic-IF", t);
- ffelex_token_kill (ffesta_tokens[1]);
- ffelex_token_kill (ffesta_tokens[2]);
- ffelex_token_kill (ffesta_tokens[3]);
+ if (ffesta_construct_name != NULL)
+ {
+ ffelex_token_kill (ffesta_construct_name);
+ ffesta_construct_name = NULL;
+ }
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "SELECT CASE", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R8407_ -- "IF" OPEN_PAREN expr CLOSE_PAREN NUMBER COMMA NUMBER COMMA
- NUMBER
+/* ffestb_R8093_ -- "SELECT/CASE" OPEN_PAREN expr CLOSE_PAREN
- return ffestb_R8407_; // to lexer
+ return ffestb_R8093_; // to lexer
- Make sure the next token is EOS or SEMICOLON. */
+ Make sure the statement has a valid form for the SELECTCASE statement. If it
+ does, implement the statement. */
static ffelexHandler
-ffestb_R8407_ (ffelexToken t)
+ffestb_R8093_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
case FFELEX_typeEOS:
case FFELEX_typeSEMICOLON:
+ ffesta_confirmed ();
if (!ffesta_is_inhibited ())
- ffestc_R840 (ffestb_local_.if_stmt.expr, ffesta_tokens[1],
- ffesta_tokens[2], ffesta_tokens[3], ffesta_tokens[4]);
+ ffestc_R809 (ffesta_construct_name, ffestb_local_.selectcase.expr,
+ ffesta_tokens[1]);
ffelex_token_kill (ffesta_tokens[1]);
- ffelex_token_kill (ffesta_tokens[2]);
- ffelex_token_kill (ffesta_tokens[3]);
- ffelex_token_kill (ffesta_tokens[4]);
- return (ffelexHandler) ffesta_zero (t);
+ if (ffesta_construct_name != NULL)
+ {
+ ffelex_token_kill (ffesta_construct_name);
+ ffesta_construct_name = NULL;
+ }
+ return ffesta_zero (t);
+
+ case FFELEX_typeCOMMA:
+ case FFELEX_typeCOLONCOLON:
+ ffesta_confirmed (); /* Error, but clearly intended. */
+ break;
default:
break;
}
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "arithmetic-IF", t);
ffelex_token_kill (ffesta_tokens[1]);
- ffelex_token_kill (ffesta_tokens[2]);
- ffelex_token_kill (ffesta_tokens[3]);
- ffelex_token_kill (ffesta_tokens[4]);
+ if (ffesta_construct_name != NULL)
+ {
+ ffelex_token_kill (ffesta_construct_name);
+ ffesta_construct_name = NULL;
+ }
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "SELECT CASE", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R841 -- Parse the CONTINUE statement
+/* ffestb_R810 -- Parse the CASE statement
- return ffestb_R841; // to lexer
+ return ffestb_R810; // to lexer
- Make sure the statement has a valid form for the CONTINUE statement. If
- it does, implement the statement. */
+ Make sure the statement has a valid form for the CASE statement.
+ If it does, implement the statement. */
ffelexHandler
-ffestb_R841 (ffelexToken t)
+ffestb_R810 (ffelexToken t)
{
- const char *p;
ffeTokenLength i;
+ unsigned const char *p;
switch (ffelex_token_type (ffesta_tokens[0]))
{
case FFELEX_typeNAME:
- if (ffesta_first_kw != FFESTR_firstCONTINUE)
- goto bad_0; /* :::::::::::::::::::: */
- break;
-
- case FFELEX_typeNAMES:
- if (ffesta_first_kw != FFESTR_firstCONTINUE)
+ if (ffesta_first_kw != FFESTR_firstCASE)
goto bad_0; /* :::::::::::::::::::: */
- if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlCONTINUE)
+ switch (ffelex_token_type (t))
{
- p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlCONTINUE);
- goto bad_i; /* :::::::::::::::::::: */
- }
- break;
+ case FFELEX_typeCOMMA:
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ case FFELEX_typeCOLONCOLON:
+ ffesta_confirmed (); /* Error, but clearly intended. */
+ goto bad_1; /* :::::::::::::::::::: */
- default:
- goto bad_0; /* :::::::::::::::::::: */
- }
+ default:
+ goto bad_1; /* :::::::::::::::::::: */
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- ffestc_R841 ();
- return (ffelexHandler) ffesta_zero (t);
+ case FFELEX_typeNAME:
+ ffesta_confirmed ();
+ if (ffesta_second_kw != FFESTR_secondDEFAULT)
+ goto bad_1; /* :::::::::::::::::::: */
+ ffestb_local_.case_stmt.cases = NULL;
+ return (ffelexHandler) ffestb_R8101_;
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
-
- default:
- goto bad_1; /* :::::::::::::::::::: */
- }
-
-bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CONTINUE", ffesta_tokens[0]);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero); /* Invalid first token. */
-
-bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CONTINUE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero); /* Invalid second token. */
-
-bad_i: /* :::::::::::::::::::: */
- ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "CONTINUE", ffesta_tokens[0], i, t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R1102 -- Parse the PROGRAM statement
+ case FFELEX_typeOPEN_PAREN:
+ ffestb_local_.case_stmt.cases = ffestt_caselist_create ();
+ return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ FFEEXPR_contextCASE, (ffeexprCallback) ffestb_R8103_);
+ }
- return ffestb_R1102; // to lexer
+ case FFELEX_typeNAMES:
+ switch (ffesta_first_kw)
+ {
+ case FFESTR_firstCASEDEFAULT:
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeCOMMA:
+ case FFELEX_typeCOLONCOLON:
+ ffesta_confirmed (); /* Error, but clearly intended. */
+ goto bad_1; /* :::::::::::::::::::: */
- Make sure the statement has a valid form for the PROGRAM statement. If it
- does, implement the statement. */
+ default:
+ goto bad_1; /* :::::::::::::::::::: */
-ffelexHandler
-ffestb_R1102 (ffelexToken t)
-{
- ffeTokenLength i;
- unsigned const char *p;
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ ffesta_confirmed ();
+ break;
+ }
+ ffestb_local_.case_stmt.cases = NULL;
+ p = ffelex_token_text (ffesta_tokens[0])
+ + (i = FFESTR_firstlCASEDEFAULT);
+ if (*p == '\0')
+ return (ffelexHandler) ffestb_R8101_ (t);
+ if (!ffesrc_is_name_init (*p))
+ goto bad_i; /* :::::::::::::::::::: */
+ ffesta_tokens[1] = ffelex_token_name_from_names (ffesta_tokens[0], i,
+ 0);
+ return (ffelexHandler) ffestb_R8102_ (t);
- switch (ffelex_token_type (ffesta_tokens[0]))
- {
- case FFELEX_typeNAME:
- if (ffesta_first_kw != FFESTR_firstPROGRAM)
- goto bad_0; /* :::::::::::::::::::: */
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
+ case FFESTR_firstCASE:
+ break;
default:
- goto bad_1; /* :::::::::::::::::::: */
-
- case FFELEX_typeNAME:
- break;
+ goto bad_0; /* :::::::::::::::::::: */
}
- ffesta_confirmed ();
- ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_R11021_;
-
- case FFELEX_typeNAMES:
- if (ffesta_first_kw != FFESTR_firstPROGRAM)
- goto bad_0; /* :::::::::::::::::::: */
switch (ffelex_token_type (t))
{
case FFELEX_typeCOMMA:
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
case FFELEX_typeCOLONCOLON:
ffesta_confirmed (); /* Error, but clearly intended. */
goto bad_1; /* :::::::::::::::::::: */
default:
goto bad_1; /* :::::::::::::::::::: */
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
+ case FFELEX_typeOPEN_PAREN:
break;
}
- ffesta_confirmed ();
- p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlPROGRAM);
- if (!ffesrc_is_name_init (*p))
+ p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlCASE);
+ if (*p != '\0')
goto bad_i; /* :::::::::::::::::::: */
- ffesta_tokens[1]
- = ffelex_token_name_from_names (ffesta_tokens[0], i, 0);
- return (ffelexHandler) ffestb_R11021_ (t);
+ ffestb_local_.case_stmt.cases = ffestt_caselist_create ();
+ return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ FFEEXPR_contextCASE, (ffeexprCallback) ffestb_R8103_);
default:
goto bad_0; /* :::::::::::::::::::: */
}
bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "PROGRAM", ffesta_tokens[0]);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CASE", ffesta_tokens[0]);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "PROGRAM", t);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CASE", t);
return (ffelexHandler) ffelex_swallow_tokens (t,
(ffelexHandler) ffesta_zero); /* Invalid second token. */
bad_i: /* :::::::::::::::::::: */
- ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "PROGRAM", ffesta_tokens[0], i, t);
+ ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "CASE", ffesta_tokens[0], i, t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R11021_ -- "PROGRAM" NAME
+/* ffestb_R8101_ -- "CASE" case-selector
- return ffestb_R11021_; // to lexer
+ return ffestb_R8101_; // to lexer
- Make sure the next token is an EOS or SEMICOLON. */
+ Make sure the statement has a valid form for the CASE statement. If it
+ does, implement the statement. */
static ffelexHandler
-ffestb_R11021_ (ffelexToken t)
+ffestb_R8101_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
+ case FFELEX_typeNAME:
+ ffesta_tokens[1] = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_R8102_;
+
case FFELEX_typeEOS:
case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- ffestc_R1102 (ffesta_tokens[1]);
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffesta_zero (t);
+ ffesta_tokens[1] = NULL;
+ return (ffelexHandler) ffestb_R8102_ (t);
+
+ case FFELEX_typeCOMMA:
+ case FFELEX_typeCOLONCOLON:
+ ffesta_confirmed (); /* Error, but clearly intended. */
+ break;
default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "PROGRAM", t);
break;
}
- ffelex_token_kill (ffesta_tokens[1]);
+ if (ffestb_local_.case_stmt.cases != NULL)
+ ffestt_caselist_kill (ffestb_local_.case_stmt.cases);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CASE", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_block -- Parse the BLOCK DATA statement
+/* ffestb_R8102_ -- "CASE" case-selector [NAME]
- return ffestb_block; // to lexer
+ return ffestb_R8102_; // to lexer
- Make sure the statement has a valid form for the BLOCK DATA statement. If
- it does, implement the statement. */
+ Make sure the statement has a valid form for the CASE statement. If it
+ does, implement the statement. */
-ffelexHandler
-ffestb_block (ffelexToken t)
+static ffelexHandler
+ffestb_R8102_ (ffelexToken t)
{
- switch (ffelex_token_type (ffesta_tokens[0]))
+ switch (ffelex_token_type (t))
{
- case FFELEX_typeNAME:
- if (ffesta_first_kw != FFESTR_firstBLOCK)
- goto bad_0; /* :::::::::::::::::::: */
- switch (ffelex_token_type (t))
- {
- default:
- goto bad_1; /* :::::::::::::::::::: */
-
- case FFELEX_typeNAME:
- if (ffesta_second_kw != FFESTR_secondDATA)
- goto bad_1; /* :::::::::::::::::::: */
- break;
- }
-
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
ffesta_confirmed ();
- return (ffelexHandler) ffestb_R1111_1_;
+ if (!ffesta_is_inhibited ())
+ ffestc_R810 (ffestb_local_.case_stmt.cases, ffesta_tokens[1]);
+ if (ffestb_local_.case_stmt.cases != NULL)
+ ffestt_caselist_kill (ffestb_local_.case_stmt.cases);
+ if (ffesta_tokens[1] != NULL)
+ ffelex_token_kill (ffesta_tokens[1]);
+ return (ffelexHandler) ffesta_zero (t);
+
+ case FFELEX_typeCOMMA:
+ case FFELEX_typeCOLONCOLON:
+ ffesta_confirmed (); /* Error, but clearly intended. */
+ break;
default:
- goto bad_0; /* :::::::::::::::::::: */
+ break;
}
-bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "BLOCK DATA", ffesta_tokens[0]);
+ if (ffestb_local_.case_stmt.cases != NULL)
+ ffestt_caselist_kill (ffestb_local_.case_stmt.cases);
+ if (ffesta_tokens[1] != NULL)
+ ffelex_token_kill (ffesta_tokens[1]);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CASE", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-
-bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "BLOCK DATA", t);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero); /* Invalid second token. */
}
-/* ffestb_blockdata -- Parse the BLOCKDATA statement
+/* ffestb_R8103_ -- "CASE" OPEN_PAREN expr
- return ffestb_blockdata; // to lexer
+ (ffestb_R8103_) // to expression handler
- Make sure the statement has a valid form for the BLOCKDATA statement. If
- it does, implement the statement. */
+ Make sure the statement has a valid form for the CASE statement. If it
+ does, implement the statement. */
-ffelexHandler
-ffestb_blockdata (ffelexToken t)
+static ffelexHandler
+ffestb_R8103_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
- ffeTokenLength i;
- unsigned const char *p;
-
- switch (ffelex_token_type (ffesta_tokens[0]))
+ switch (ffelex_token_type (t))
{
- case FFELEX_typeNAME:
- if (ffesta_first_kw != FFESTR_firstBLOCKDATA)
- goto bad_0; /* :::::::::::::::::::: */
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
+ case FFELEX_typeCLOSE_PAREN:
+ ffestt_caselist_append (ffestb_local_.case_stmt.cases, FALSE, expr, NULL,
+ ffelex_token_use (ft));
+ return (ffelexHandler) ffestb_R8101_;
- default:
- goto bad_1; /* :::::::::::::::::::: */
+ case FFELEX_typeCOMMA:
+ ffestt_caselist_append (ffestb_local_.case_stmt.cases, FALSE, expr, NULL,
+ ffelex_token_use (ft));
+ return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ FFEEXPR_contextCASE, (ffeexprCallback) ffestb_R8103_);
- case FFELEX_typeNAME:
- ffesta_confirmed ();
- ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_R1111_2_;
+ case FFELEX_typeCOLON:
+ ffestt_caselist_append (ffestb_local_.case_stmt.cases, TRUE, expr, NULL,
+ ffelex_token_use (ft)); /* NULL second expr for
+ now, just plug in. */
+ return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ FFEEXPR_contextCASE, (ffeexprCallback) ffestb_R8104_);
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- ffesta_tokens[1] = NULL;
- return (ffelexHandler) ffestb_R1111_2_ (t);
- }
+ default:
+ break;
+ }
- case FFELEX_typeNAMES:
- if (ffesta_first_kw != FFESTR_firstBLOCKDATA)
- goto bad_0; /* :::::::::::::::::::: */
- switch (ffelex_token_type (t))
- {
- default:
- goto bad_1; /* :::::::::::::::::::: */
-
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- break;
- }
- ffesta_confirmed ();
- p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlBLOCKDATA);
- if (*p == '\0')
- {
- ffesta_tokens[1] = NULL;
- }
- else
- {
- if (!ffesrc_is_name_init (*p))
- goto bad_i; /* :::::::::::::::::::: */
- ffesta_tokens[1]
- = ffelex_token_name_from_names (ffesta_tokens[0], i, 0);
- }
- return (ffelexHandler) ffestb_R1111_2_ (t);
-
- default:
- goto bad_0; /* :::::::::::::::::::: */
- }
-
-bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "BLOCK DATA", ffesta_tokens[0]);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-
-bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "BLOCK DATA", t);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero); /* Invalid second token. */
-
-bad_i: /* :::::::::::::::::::: */
- ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "BLOCK DATA", ffesta_tokens[0], i, t);
+ ffestt_caselist_kill (ffestb_local_.case_stmt.cases);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CASE", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R1111_1_ -- "BLOCK" "DATA"
+/* ffestb_R8104_ -- "CASE" OPEN_PAREN expr COLON expr
- return ffestb_R1111_1_; // to lexer
+ (ffestb_R8104_) // to expression handler
- Make sure the next token is a NAME, EOS, or SEMICOLON token. */
+ Make sure the statement has a valid form for the CASE statement. If it
+ does, implement the statement. */
static ffelexHandler
-ffestb_R1111_1_ (ffelexToken t)
+ffestb_R8104_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeNAME:
- ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_R1111_2_;
-
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_tokens[1] = NULL;
- return (ffelexHandler) ffestb_R1111_2_ (t);
-
- default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "BLOCK DATA", t);
- break;
- }
-
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R1111_2_ -- "BLOCK/DATA" NAME
-
- return ffestb_R1111_2_; // to lexer
-
- Make sure the next token is an EOS or SEMICOLON. */
+ case FFELEX_typeCLOSE_PAREN:
+ ffestb_local_.case_stmt.cases->previous->expr2 = expr;
+ return (ffelexHandler) ffestb_R8101_;
-static ffelexHandler
-ffestb_R1111_2_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- ffestc_R1111 (ffesta_tokens[1]);
- if (ffesta_tokens[1] != NULL)
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffesta_zero (t);
+ case FFELEX_typeCOMMA:
+ ffestb_local_.case_stmt.cases->previous->expr2 = expr;
+ return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ FFEEXPR_contextCASE, (ffeexprCallback) ffestb_R8103_);
default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "BLOCK DATA", t);
break;
}
- if (ffesta_tokens[1] != NULL)
- ffelex_token_kill (ffesta_tokens[1]);
+ ffestt_caselist_kill (ffestb_local_.case_stmt.cases);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CASE", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R1212 -- Parse the CALL statement
+/* ffestb_R1001 -- Parse a FORMAT statement
- return ffestb_R1212; // to lexer
+ return ffestb_R1001; // to lexer
- Make sure the statement has a valid form for the CALL statement. If it
- does, implement the statement. */
+ Make sure the statement has a valid form for an FORMAT statement.
+ If it does, implement the statement. */
ffelexHandler
-ffestb_R1212 (ffelexToken t)
+ffestb_R1001 (ffelexToken t)
{
- ffeTokenLength i;
- unsigned const char *p;
- ffelexHandler next;
- ffelexToken nt;
+ ffesttFormatList f;
switch (ffelex_token_type (ffesta_tokens[0]))
{
case FFELEX_typeNAME:
- if (ffesta_first_kw != FFESTR_firstCALL)
+ if (ffesta_first_kw != FFESTR_firstFORMAT)
goto bad_0; /* :::::::::::::::::::: */
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
-
- default:
- goto bad_1; /* :::::::::::::::::::: */
-
- case FFELEX_typeNAME:
- break;
- }
- ffesta_confirmed ();
- return (ffelexHandler)
- (*((ffelexHandler)
- ffeexpr_lhs (ffesta_output_pool, FFEEXPR_contextSUBROUTINEREF,
- (ffeexprCallback) ffestb_R12121_)))
- (t);
+ break;
case FFELEX_typeNAMES:
- if (ffesta_first_kw != FFESTR_firstCALL)
+ if (ffesta_first_kw != FFESTR_firstFORMAT)
goto bad_0; /* :::::::::::::::::::: */
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOLONCOLON:
- case FFELEX_typeCOMMA:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
+ if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlFORMAT)
+ goto bad_0; /* :::::::::::::::::::: */
+ break;
- default:
- goto bad_1; /* :::::::::::::::::::: */
+ default:
+ goto bad_0; /* :::::::::::::::::::: */
+ }
- case FFELEX_typeOPEN_PAREN:
- break;
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeOPEN_PAREN:
+ ffestb_local_.format.complained = FALSE;
+ ffestb_local_.format.f = NULL; /* No parent yet. */
+ ffestb_local_.format.f = ffestt_formatlist_create (NULL,
+ ffelex_token_use (t));
+ ffelex_set_names_pure (TRUE); /* Have even free-form lexer give us
+ NAMES. */
+ return (ffelexHandler) ffestb_R10011_;
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- break;
- }
- p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlCALL);
- if (!ffesrc_is_name_init (*p))
- goto bad_i; /* :::::::::::::::::::: */
- nt = ffelex_token_name_from_names (ffesta_tokens[0], i, 0);
- next = (ffelexHandler)
- (*((ffelexHandler)
- ffeexpr_lhs (ffesta_output_pool, FFEEXPR_contextSUBROUTINEREF,
- (ffeexprCallback) ffestb_R12121_)))
- (nt);
- ffelex_token_kill (nt);
- return (ffelexHandler) (*next) (t);
+ case FFELEX_typeOPEN_ARRAY:/* "(/". */
+ ffesta_confirmed ();
+ ffestb_local_.format.complained = FALSE;
+ ffestb_local_.format.f = ffestt_formatlist_create (NULL,
+ ffelex_token_use (t));
+ f = ffestt_formatlist_append (ffestb_local_.format.f);
+ f->type = FFESTP_formattypeSLASH;
+ f->t = ffelex_token_use (t);
+ f->u.R1010.val.present = FALSE;
+ f->u.R1010.val.rtexpr = FALSE;
+ f->u.R1010.val.t = NULL;
+ f->u.R1010.val.u.unsigned_val = 1;
+ ffelex_set_names_pure (TRUE); /* Have even free-form lexer give us
+ NAMES. */
+ return (ffelexHandler) ffestb_R100112_;
+
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ case FFELEX_typeCOMMA:
+ case FFELEX_typeCOLONCOLON:
+ ffesta_confirmed (); /* Error, but clearly intended. */
+ goto bad_1; /* :::::::::::::::::::: */
default:
- goto bad_0; /* :::::::::::::::::::: */
+ goto bad_1; /* :::::::::::::::::::: */
}
bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CALL", ffesta_tokens[0]);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FORMAT", ffesta_tokens[0]);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CALL", t);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FORMAT", t);
return (ffelexHandler) ffelex_swallow_tokens (t,
(ffelexHandler) ffesta_zero); /* Invalid second token. */
-
-bad_i: /* :::::::::::::::::::: */
- ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "CALL", ffesta_tokens[0], i, t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R12121_ -- "CALL" expr
+/* ffestb_R10011_ -- "FORMAT" OPEN_PAREN expr
- (ffestb_R12121_) // to expression handler
+ return ffestb_R10011_; // to lexer
- Make sure the statement has a valid form for the CALL statement. If it
- does, implement the statement. */
+ For CLOSE_PAREN, wrap up the format list and if it is the top-level one,
+ exit. For anything else, pass it to _2_. */
static ffelexHandler
-ffestb_R12121_ (ffelexToken ft, ffebld expr, ffelexToken t)
+ffestb_R10011_ (ffelexToken t)
{
+ ffesttFormatList f;
+
switch (ffelex_token_type (t))
{
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- if (expr == NULL)
- break;
- if (!ffesta_is_inhibited ())
- ffestc_R1212 (expr, ft);
- return (ffelexHandler) ffesta_zero (t);
+ case FFELEX_typeCLOSE_PAREN:
+ break;
default:
- break;
+ return (ffelexHandler) ffestb_R10012_ (t);
}
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CALL", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
+ /* If we have a format we're working on, continue working on it. */
-/* ffestb_R1227 -- Parse the RETURN statement
+ f = ffestb_local_.format.f->u.root.parent;
- return ffestb_R1227; // to lexer
+ if (f != NULL)
+ {
+ ffestb_local_.format.f = f->next;
+ return (ffelexHandler) ffestb_R100111_;
+ }
- Make sure the statement has a valid form for the RETURN statement. If it
- does, implement the statement. */
+ return (ffelexHandler) ffestb_R100114_;
+}
-ffelexHandler
-ffestb_R1227 (ffelexToken t)
+/* ffestb_R10012_ -- "FORMAT" OPEN_PAREN [format-item-list]
+
+ return ffestb_R10012_; // to lexer
+
+ The initial state for a format-item. Here, just handle the initial
+ number, sign for number, or run-time expression. Also handle spurious
+ comma, close-paren (indicating spurious comma), close-array (like
+ close-paren but preceded by slash), and quoted strings. */
+
+static ffelexHandler
+ffestb_R10012_ (ffelexToken t)
{
- ffelexHandler next;
+ unsigned long unsigned_val;
+ ffesttFormatList f;
- switch (ffelex_token_type (ffesta_tokens[0]))
+ switch (ffelex_token_type (t))
{
- case FFELEX_typeNAME:
- if (ffesta_first_kw != FFESTR_firstRETURN)
- goto bad_0; /* :::::::::::::::::::: */
- switch (ffelex_token_type (t))
+ case FFELEX_typeOPEN_ANGLE:
+ ffesta_confirmed ();
+ ffestb_local_.format.pre.t = ffelex_token_use (t);
+ ffelex_set_names_pure (FALSE);
+ if (!ffesta_seen_first_exec && !ffestb_local_.format.complained)
{
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
-
- case FFELEX_typeEQUALS:
- case FFELEX_typePOINTS:
- case FFELEX_typeCOLON:
- goto bad_1; /* :::::::::::::::::::: */
+ ffestb_local_.format.complained = TRUE;
+ ffebad_start (FFEBAD_FORMAT_EXPR_SPEC);
+ ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
+ ffebad_finish ();
+ }
+ return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ FFEEXPR_contextFORMAT, (ffeexprCallback) ffestb_R100115_);
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- case FFELEX_typeNAME:
- case FFELEX_typeNUMBER:
- ffesta_confirmed ();
- break;
+ case FFELEX_typeNUMBER:
+ ffestb_local_.format.sign = FALSE; /* No sign present. */
+ ffestb_local_.format.pre.present = TRUE;
+ ffestb_local_.format.pre.rtexpr = FALSE;
+ ffestb_local_.format.pre.t = ffelex_token_use (t);
+ ffestb_local_.format.pre.u.unsigned_val = unsigned_val
+ = strtoul (ffelex_token_text (t), NULL, 10);
+ ffelex_set_expecting_hollerith (unsigned_val, '\0',
+ ffelex_token_where_line (t),
+ ffelex_token_where_column (t));
+ return (ffelexHandler) ffestb_R10014_;
- default:
- break;
- }
+ case FFELEX_typePLUS:
+ ffestb_local_.format.sign = TRUE; /* Positive. */
+ ffestb_local_.format.pre.t = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_R10013_;
- return (ffelexHandler) (*((ffelexHandler)
- ffeexpr_rhs (ffesta_output_pool, FFEEXPR_contextRETURN,
- (ffeexprCallback) ffestb_R12271_)))
- (t);
+ case FFELEX_typeMINUS:
+ ffestb_local_.format.sign = FALSE; /* Negative. */
+ ffestb_local_.format.pre.t = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_R10013_;
+ case FFELEX_typeCOLON:
+ case FFELEX_typeCOLONCOLON:/* "::". */
+ case FFELEX_typeSLASH:
+ case FFELEX_typeCONCAT: /* "//". */
case FFELEX_typeNAMES:
- if (ffesta_first_kw != FFESTR_firstRETURN)
- goto bad_0; /* :::::::::::::::::::: */
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
+ case FFELEX_typeDOLLAR:
+ case FFELEX_typeOPEN_PAREN:
+ case FFELEX_typeOPEN_ARRAY:/* "(/". */
+ ffestb_local_.format.sign = FALSE; /* No sign present. */
+ ffestb_local_.format.pre.present = FALSE;
+ ffestb_local_.format.pre.rtexpr = FALSE;
+ ffestb_local_.format.pre.t = NULL;
+ ffestb_local_.format.pre.u.unsigned_val = 1;
+ return (ffelexHandler) ffestb_R10014_ (t);
- case FFELEX_typeEQUALS:
- case FFELEX_typePOINTS:
- case FFELEX_typeCOLON:
- goto bad_1; /* :::::::::::::::::::: */
+ case FFELEX_typeCOMMA:
+ ffebad_start (FFEBAD_FORMAT_EXTRA_COMMA);
+ ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
+ ffebad_finish ();
+ return (ffelexHandler) ffestb_R10012_;
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- break;
+ case FFELEX_typeCLOSE_PAREN:
+ ffebad_start (FFEBAD_FORMAT_EXTRA_COMMA);
+ ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
+ ffebad_finish ();
+ f = ffestb_local_.format.f->u.root.parent;
+ if (f == NULL)
+ return (ffelexHandler) ffestb_R100114_;
+ ffestb_local_.format.f = f->next;
+ return (ffelexHandler) ffestb_R100111_;
- default:
- break;
- }
- next = (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextRETURN, (ffeexprCallback) ffestb_R12271_);
- next = (ffelexHandler) ffelex_splice_tokens (next, ffesta_tokens[0],
- FFESTR_firstlRETURN);
- if (next == NULL)
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero);
- return (ffelexHandler) (*next) (t);
+ case FFELEX_typeCLOSE_ARRAY: /* "/)". */
+ f = ffestt_formatlist_append (ffestb_local_.format.f);
+ f->type = FFESTP_formattypeSLASH;
+ f->t = ffelex_token_use (t);
+ f->u.R1010.val.present = FALSE;
+ f->u.R1010.val.rtexpr = FALSE;
+ f->u.R1010.val.t = NULL;
+ f->u.R1010.val.u.unsigned_val = 1;
+ f = ffestb_local_.format.f->u.root.parent;
+ if (f == NULL)
+ return (ffelexHandler) ffestb_R100114_;
+ ffestb_local_.format.f = f->next;
+ return (ffelexHandler) ffestb_R100111_;
+
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ ffesta_confirmed ();
+ ffesta_ffebad_1t (FFEBAD_FORMAT_MISSING_PAREN, t);
+ for (f = ffestb_local_.format.f;
+ f->u.root.parent != NULL;
+ f = f->u.root.parent->next)
+ ;
+ ffestb_local_.format.f = f;
+ return (ffelexHandler) ffestb_R100114_ (t);
+
+ case FFELEX_typeQUOTE:
+ if (ffe_is_vxt ())
+ break; /* Error, probably something like FORMAT("17)
+ = X. */
+ ffelex_set_expecting_hollerith (-1, '\"',
+ ffelex_token_where_line (t),
+ ffelex_token_where_column (t)); /* Don't have to unset
+ this one. */
+ return (ffelexHandler) ffestb_R100113_;
+
+ case FFELEX_typeAPOSTROPHE:
+#if 0 /* No apparent need for this, and not killed
+ anywhere. */
+ ffesta_tokens[1] = ffelex_token_use (t);
+#endif
+ ffelex_set_expecting_hollerith (-1, '\'',
+ ffelex_token_where_line (t),
+ ffelex_token_where_column (t)); /* Don't have to unset
+ this one. */
+ return (ffelexHandler) ffestb_R100113_;
default:
- goto bad_0; /* :::::::::::::::::::: */
+ break;
}
-bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "RETURN", ffesta_tokens[0]);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FORMAT", t);
+ ffestt_formatlist_kill (ffestb_local_.format.f);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-
-bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "RETURN", t);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero); /* Invalid second token. */
}
-/* ffestb_R12271_ -- "RETURN" expr
+/* ffestb_R10013_ -- "FORMAT" OPEN_PAREN [format-item-list] PLUS/MINUS
- (ffestb_R12271_) // to expression handler
+ return ffestb_R10013_; // to lexer
- Make sure the next token is an EOS or SEMICOLON. */
+ Expect a NUMBER or complain about and then ignore the PLUS/MINUS. */
static ffelexHandler
-ffestb_R12271_ (ffelexToken ft, ffebld expr, ffelexToken t)
+ffestb_R10013_ (ffelexToken t)
{
+ unsigned long unsigned_val;
+
switch (ffelex_token_type (t))
{
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- ffestc_R1227 (expr, ft);
- return (ffelexHandler) ffesta_zero (t);
+ case FFELEX_typeNUMBER:
+ ffestb_local_.format.pre.present = TRUE;
+ ffestb_local_.format.pre.rtexpr = FALSE;
+ unsigned_val = strtoul (ffelex_token_text (t), NULL, 10);
+ ffestb_local_.format.pre.u.signed_val = ffestb_local_.format.sign
+ ? unsigned_val : -unsigned_val;
+ ffestb_local_.format.sign = TRUE; /* Sign present. */
+ return (ffelexHandler) ffestb_R10014_;
default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "RETURN", t);
- break;
+ ffebad_start (FFEBAD_FORMAT_SPURIOUS_SIGN);
+ ffebad_here (0, ffelex_token_where_line (ffestb_local_.format.pre.t),
+ ffelex_token_where_column (ffestb_local_.format.pre.t));
+ ffebad_finish ();
+ ffelex_token_kill (ffestb_local_.format.pre.t);
+ return (ffelexHandler) ffestb_R10012_ (t);
}
-
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R1228 -- Parse the CONTAINS statement
+/* ffestb_R10014_ -- "FORMAT" OPEN_PAREN [format-item-list] [[+/-] NUMBER]
- return ffestb_R1228; // to lexer
+ return ffestb_R10014_; // to lexer
- Make sure the statement has a valid form for the CONTAINS statement. If
- it does, implement the statement. */
+ Here is where we expect to see the actual NAMES, COLON, SLASH, OPEN_PAREN,
+ OPEN_ARRAY, COLONCOLON, CONCAT, DOLLAR, or HOLLERITH that identifies what
+ kind of format-item we're dealing with. But if we see a NUMBER instead, it
+ means free-form spaces number like "5 6 X", so scale the current number
+ accordingly and reenter this state. (I really wouldn't be surprised if
+ they change this spacing rule in the F90 spec so that you can't embed
+ spaces within numbers or within keywords like BN in a free-source-form
+ program.) */
-#if FFESTR_F90
-ffelexHandler
-ffestb_R1228 (ffelexToken t)
+static ffelexHandler
+ffestb_R10014_ (ffelexToken t)
{
- const char *p;
+ ffesttFormatList f;
ffeTokenLength i;
+ const char *p;
+ ffestrFormat kw;
- switch (ffelex_token_type (ffesta_tokens[0]))
- {
- case FFELEX_typeNAME:
- if (ffesta_first_kw != FFESTR_firstCONTAINS)
- goto bad_0; /* :::::::::::::::::::: */
- break;
-
- case FFELEX_typeNAMES:
- if (ffesta_first_kw != FFESTR_firstCONTAINS)
- goto bad_0; /* :::::::::::::::::::: */
- if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlCONTAINS)
- {
- p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlCONTAINS);
- goto bad_i; /* :::::::::::::::::::: */
- }
- break;
-
- default:
- goto bad_0; /* :::::::::::::::::::: */
- }
+ ffelex_set_expecting_hollerith (0, '\0',
+ ffewhere_line_unknown (),
+ ffewhere_column_unknown ());
switch (ffelex_token_type (t))
{
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- ffestc_R1228 ();
- return (ffelexHandler) ffesta_zero (t);
-
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
-
- default:
- goto bad_1; /* :::::::::::::::::::: */
- }
-
-bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CONTAINS", ffesta_tokens[0]);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero); /* Invalid first token. */
-
-bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CONTAINS", t);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero); /* Invalid second token. */
-
-bad_i: /* :::::::::::::::::::: */
- ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "CONTAINS", ffesta_tokens[0], i, t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-#endif
-/* ffestb_V009 -- Parse the UNION statement
-
- return ffestb_V009; // to lexer
-
- Make sure the statement has a valid form for the UNION statement. If
- it does, implement the statement. */
-
-#if FFESTR_VXT
-ffelexHandler
-ffestb_V009 (ffelexToken t)
-{
- const char *p;
- ffeTokenLength i;
-
- switch (ffelex_token_type (ffesta_tokens[0]))
- {
- case FFELEX_typeNAME:
- if (ffesta_first_kw != FFESTR_firstUNION)
- goto bad_0; /* :::::::::::::::::::: */
- break;
-
- case FFELEX_typeNAMES:
- if (ffesta_first_kw != FFESTR_firstUNION)
- goto bad_0; /* :::::::::::::::::::: */
- if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlUNION)
- {
- p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlUNION);
- goto bad_i; /* :::::::::::::::::::: */
- }
- break;
-
- default:
- goto bad_0; /* :::::::::::::::::::: */
- }
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- ffestc_V009 ();
- return (ffelexHandler) ffesta_zero (t);
-
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
-
- default:
- goto bad_1; /* :::::::::::::::::::: */
- }
-
-bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "UNION", ffesta_tokens[0]);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero); /* Invalid first token. */
-
-bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "UNION", t);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero); /* Invalid second token. */
-
-bad_i: /* :::::::::::::::::::: */
- ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "UNION", ffesta_tokens[0], i, t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-#endif
-/* ffestb_construct -- Parse a construct name
-
- return ffestb_construct; // to lexer
-
- Make sure the statement can have a construct name (if-then-stmt, do-stmt,
- select-case-stmt). */
-
-ffelexHandler
-ffestb_construct (ffelexToken t UNUSED)
-{
- /* This handler gets invoked only when token 0 is NAME/NAMES and token 1 is
- COLON. */
-
- ffesta_confirmed ();
- ffelex_set_names (TRUE);
- return (ffelexHandler) ffestb_construct1_;
-}
-
-/* ffestb_construct1_ -- NAME COLON
-
- return ffestb_construct1_; // to lexer
-
- Make sure we've got a NAME that is DO, DOWHILE, IF, SELECT, or SELECTCASE. */
-
-static ffelexHandler
-ffestb_construct1_ (ffelexToken t)
-{
- ffelex_set_names (FALSE);
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- ffesta_first_kw = ffestr_first (t);
- switch (ffesta_first_kw)
- {
- case FFESTR_firstIF:
- ffestb_local_.construct.next = (ffelexHandler) ffestb_if;
- break;
-
- case FFESTR_firstDO:
- ffestb_local_.construct.next = (ffelexHandler) ffestb_do;
- break;
-
- case FFESTR_firstDOWHILE:
- ffestb_local_.construct.next = (ffelexHandler) ffestb_dowhile;
- break;
-
- case FFESTR_firstSELECT:
- case FFESTR_firstSELECTCASE:
- ffestb_local_.construct.next = (ffelexHandler) ffestb_R809;
- break;
-
- default:
- goto bad; /* :::::::::::::::::::: */
- }
- ffesta_construct_name = ffesta_tokens[0];
- ffesta_tokens[0] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_construct2_;
-
- case FFELEX_typeNAMES:
- ffesta_first_kw = ffestr_first (t);
- switch (ffesta_first_kw)
- {
- case FFESTR_firstIF:
- if (ffelex_token_length (t) != FFESTR_firstlIF)
- goto bad; /* :::::::::::::::::::: */
- ffestb_local_.construct.next = (ffelexHandler) ffestb_if;
- break;
-
- case FFESTR_firstDO:
- ffestb_local_.construct.next = (ffelexHandler) ffestb_do;
- break;
-
- case FFESTR_firstDOWHILE:
- if (ffelex_token_length (t) != FFESTR_firstlDOWHILE)
- goto bad; /* :::::::::::::::::::: */
- ffestb_local_.construct.next = (ffelexHandler) ffestb_dowhile;
- break;
-
- case FFESTR_firstSELECTCASE:
- if (ffelex_token_length (t) != FFESTR_firstlSELECTCASE)
- goto bad; /* :::::::::::::::::::: */
- ffestb_local_.construct.next = (ffelexHandler) ffestb_R809;
- break;
-
- default:
- goto bad; /* :::::::::::::::::::: */
- }
- ffesta_construct_name = ffesta_tokens[0];
- ffesta_tokens[0] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_construct2_;
-
- default:
- break;
- }
-
-bad: /* :::::::::::::::::::: */
- ffesta_ffebad_2st (FFEBAD_INVALID_STMT_FORM, "CONSTRUCT",
- ffesta_tokens[0], t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_construct2_ -- NAME COLON "DO/DOWHILE/IF/SELECT/SELECTCASE"
-
- return ffestb_construct2_; // to lexer
-
- This extra step is needed to set ffesta_second_kw if the second token
- (here) is a NAME, so DO and SELECT can continue to expect it. */
-
-static ffelexHandler
-ffestb_construct2_ (ffelexToken t)
-{
- if (ffelex_token_type (t) == FFELEX_typeNAME)
- ffesta_second_kw = ffestr_second (t);
- return (ffelexHandler) (*ffestb_local_.construct.next) (t);
-}
-
-/* ffestb_heap -- Parse an ALLOCATE/DEALLOCATE statement
-
- return ffestb_heap; // to lexer
-
- Make sure the statement has a valid form for an ALLOCATE/DEALLOCATE
- statement. If it does, implement the statement. */
-
-#if FFESTR_F90
-ffelexHandler
-ffestb_heap (ffelexToken t)
-{
- switch (ffelex_token_type (ffesta_tokens[0]))
- {
- case FFELEX_typeNAME:
- break;
-
- case FFELEX_typeNAMES:
- if (ffelex_token_length (ffesta_tokens[0]) != ffestb_args.heap.len)
- goto bad_0; /* :::::::::::::::::::: */
- break;
-
- default:
- goto bad_0; /* :::::::::::::::::::: */
- }
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeOPEN_PAREN:
- break;
-
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
-
- default:
- goto bad_1; /* :::::::::::::::::::: */
- }
-
- ffestb_local_.heap.exprs = ffestt_exprlist_create ();
- return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool,
- ffestb_args.heap.ctx,
- (ffeexprCallback) ffestb_heap1_);
-
-bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.heap.badname, ffesta_tokens[0]);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-
-bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.heap.badname, t);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero); /* Invalid second token. */
-}
-
-/* ffestb_heap1_ -- "ALLOCATE/DEALLOCATE" OPEN_PAREN expr
-
- (ffestb_heap1_) // to expression handler
-
- Make sure the next token is COMMA. */
-
-static ffelexHandler
-ffestb_heap1_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- if (expr == NULL)
- break;
- ffestt_exprlist_append (ffestb_local_.heap.exprs, expr,
- ffelex_token_use (t));
- return (ffelexHandler) ffestb_heap2_;
-
- case FFELEX_typeCLOSE_PAREN:
- if (expr == NULL)
- break;
- ffestt_exprlist_append (ffestb_local_.heap.exprs, expr,
- ffelex_token_use (t));
- ffesta_tokens[1] = NULL;
- ffestb_local_.heap.expr = NULL;
- return (ffelexHandler) ffestb_heap5_;
-
- default:
- break;
- }
-
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.heap.badname, t);
- ffestt_exprlist_kill (ffestb_local_.heap.exprs);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_heap2_ -- "ALLOCATE/DEALLOCATE" OPEN_PAREN expr COMMA
-
- return ffestb_heap2_; // to lexer
-
- Make sure the next token is NAME. */
-
-static ffelexHandler
-ffestb_heap2_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_heap3_;
-
- default:
- break;
- }
-
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.heap.badname, t);
- ffestt_exprlist_kill (ffestb_local_.heap.exprs);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_heap3_ -- "ALLOCATE/DEALLOCATE" OPEN_PAREN expr COMMA NAME
-
- return ffestb_heap3_; // to lexer
-
- If token is EQUALS, make sure NAME was "STAT" and handle STAT variable;
- else pass NAME and token to expression handler. */
-
-static ffelexHandler
-ffestb_heap3_ (ffelexToken t)
-{
- ffelexHandler next;
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeEQUALS:
- ffesta_confirmed ();
- if (ffestr_other (ffesta_tokens[1]) != FFESTR_otherSTAT)
- break;
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool,
- FFEEXPR_contextHEAPSTAT,
- (ffeexprCallback) ffestb_heap4_);
-
- default:
- next = (ffelexHandler)
- (*((ffelexHandler) ffeexpr_lhs (ffesta_output_pool,
- ffestb_args.heap.ctx,
- (ffeexprCallback) ffestb_heap1_)))
- (ffesta_tokens[1]);
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) (*next) (t);
- }
-
- ffelex_token_kill (ffesta_tokens[1]);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.heap.badname, t);
- ffestt_exprlist_kill (ffestb_local_.heap.exprs);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_heap4_ -- "ALLOCATE/DEALLOCATE" OPEN_PAREN ... COMMA "STAT" EQUALS
- expr
-
- (ffestb_heap4_) // to expression handler
-
- Make sure the next token is CLOSE_PAREN. */
-
-static ffelexHandler
-ffestb_heap4_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCLOSE_PAREN:
- if (expr == NULL)
- break;
- ffesta_tokens[1] = ffelex_token_use (ft);
- ffestb_local_.heap.expr = expr;
- return (ffelexHandler) ffestb_heap5_;
-
- default:
- break;
- }
-
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.heap.badname, t);
- ffestt_exprlist_kill (ffestb_local_.heap.exprs);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_heap5_ -- "ALLOCATE/DEALLOCATE" OPEN_PAREN ... CLOSE_PAREN
-
- return ffestb_heap5_; // to lexer
-
- Make sure the next token is EOS/SEMICOLON. */
-
-static ffelexHandler
-ffestb_heap5_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- if (ffesta_first_kw == FFESTR_firstALLOCATE)
- ffestc_R620 (ffestb_local_.heap.exprs, ffestb_local_.heap.expr,
- ffesta_tokens[1]);
- else
- ffestc_R625 (ffestb_local_.heap.exprs, ffestb_local_.heap.expr,
- ffesta_tokens[1]);
- ffestt_exprlist_kill (ffestb_local_.heap.exprs);
- if (ffesta_tokens[1] != NULL)
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffesta_zero (t);
-
- default:
- break;
- }
-
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.heap.badname, t);
- ffestt_exprlist_kill (ffestb_local_.heap.exprs);
- if (ffesta_tokens[1] != NULL)
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-#endif
-/* ffestb_module -- Parse the MODULEPROCEDURE statement
-
- return ffestb_module; // to lexer
-
- Make sure the statement has a valid form for the MODULEPROCEDURE statement.
- If it does, implement the statement.
-
- 31-May-90 JCB 1.1
- Confirm NAME==MODULE followed by standard four invalid tokens, so we
- get decent message if somebody forgets that MODULE requires a name. */
-
-#if FFESTR_F90
-ffelexHandler
-ffestb_module (ffelexToken t)
-{
- ffeTokenLength i;
- const char *p;
- ffelexToken nt;
- ffelexToken mt; /* Name in MODULE PROCEDUREname, i.e.
- includes "PROCEDURE". */
-
- switch (ffelex_token_type (ffesta_tokens[0]))
- {
- case FFELEX_typeNAME:
- if (ffesta_first_kw != FFESTR_firstMODULE)
- goto bad_0; /* :::::::::::::::::::: */
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- break;
-
- case FFELEX_typeCOLONCOLON:
- case FFELEX_typeCOMMA:
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- goto bad_1m; /* :::::::::::::::::::: */
-
- default:
- goto bad_1m; /* :::::::::::::::::::: */
- }
-
- ffesta_confirmed ();
- if (ffesta_second_kw != FFESTR_secondPROCEDURE)
- {
- ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_module3_;
- }
- ffestb_local_.moduleprocedure.started = FALSE;
- ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_module1_;
-
- case FFELEX_typeNAMES:
- p = ffelex_token_text (ffesta_tokens[0])
- + (i = FFESTR_firstlMODULEPROCEDURE);
- if ((ffesta_first_kw == FFESTR_firstMODULE)
- || ((ffesta_first_kw == FFESTR_firstMODULEPROCEDURE)
- && !ffesrc_is_name_init (*p)))
- { /* Definitely not "MODULE PROCEDURE name". */
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1m; /* :::::::::::::::::::: */
-
- default:
- goto bad_1m; /* :::::::::::::::::::: */
-
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- break;
- }
- p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlMODULE);
- if (!ffesrc_is_name_init (*p))
- goto bad_im; /* :::::::::::::::::::: */
- nt = ffelex_token_name_from_names (ffesta_tokens[0], i, 0);
- if (!ffesta_is_inhibited ())
- ffestc_R1105 (nt);
- ffelex_token_kill (nt);
- return (ffelexHandler) ffesta_zero (t);
- }
-
- /* Here we know that we're indeed looking at a MODULEPROCEDURE
- statement rather than MODULE and that the character following
- MODULEPROCEDURE in the NAMES token is a valid first character for a
- NAME. This means that unless the second token is COMMA, we have an
- ambiguous statement that can be read either as MODULE PROCEDURE name
- or MODULE PROCEDUREname, the former being an R1205, the latter an
- R1105. */
-
- if (ffesta_first_kw != FFESTR_firstMODULEPROCEDURE)
- goto bad_0; /* :::::::::::::::::::: */
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
-
- default:
- goto bad_1; /* :::::::::::::::::::: */
-
- case FFELEX_typeCOMMA: /* Aha, clearly not MODULE PROCEDUREname. */
- ffesta_confirmed ();
- ffestb_local_.moduleprocedure.started = FALSE;
- ffesta_tokens[1]
- = ffelex_token_name_from_names (ffesta_tokens[0], i, 0);
- return (ffelexHandler) ffestb_module2_ (t);
-
- case FFELEX_typeEOS: /* MODULE PROCEDURE name or MODULE
- PROCEDUREname. */
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- break;
- }
- nt = ffelex_token_name_from_names (ffesta_tokens[0], i, 0);
- mt = ffelex_token_name_from_names (ffesta_tokens[0], FFESTR_firstlMODULE,
- 0);
- if (!ffesta_is_inhibited ())
- ffestc_module (mt, nt); /* Implement ambiguous statement. */
- ffelex_token_kill (nt);
- ffelex_token_kill (mt);
- return (ffelexHandler) ffesta_zero (t);
-
- default:
- goto bad_0; /* :::::::::::::::::::: */
- }
-
-bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "MODULE PROCEDURE", ffesta_tokens[0]);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-
-bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "MODULE PROCEDURE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero); /* Invalid second token. */
-
-bad_1m: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "MODULE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero); /* Invalid second token. */
-
-bad_im: /* :::::::::::::::::::: */
- ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "MODULE", ffesta_tokens[0], i, t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_module1_ -- "MODULEPROCEDURE" or "MODULE" "PROCEDURE"
-
- return ffestb_module1_; // to lexer
-
- Make sure the statement has a valid form for the MODULEPROCEDURE statement. If it
- does, implement the statement. */
-
-static ffelexHandler
-ffestb_module1_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- if (!ffestb_local_.moduleprocedure.started
- && (ffelex_token_type (ffesta_tokens[0]) == FFELEX_typeNAME))
- {
- ffesta_confirmed ();
- ffelex_token_kill (ffesta_tokens[1]);
- }
- ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_module2_;
-
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- if (ffestb_local_.moduleprocedure.started)
- break; /* Error if we've already seen NAME COMMA. */
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- ffestc_R1105 (ffesta_tokens[1]);
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffesta_zero (t);
-
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- break;
-
- default:
- break;
- }
-
- if (ffestb_local_.moduleprocedure.started && !ffesta_is_inhibited ())
- ffestc_R1205_finish ();
- else if (!ffestb_local_.moduleprocedure.started)
- ffelex_token_kill (ffesta_tokens[1]);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "MODULE PROCEDURE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_module2_ -- "MODULE/PROCEDURE" NAME
-
- return ffestb_module2_; // to lexer
-
- Make sure the statement has a valid form for the MODULEPROCEDURE statement. If it
- does, implement the statement. */
-
-static ffelexHandler
-ffestb_module2_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- if (!ffestb_local_.moduleprocedure.started)
- {
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- ffestc_R1205_start ();
- }
- if (!ffesta_is_inhibited ())
- {
- ffestc_R1205_item (ffesta_tokens[1]);
- ffestc_R1205_finish ();
- }
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffesta_zero (t);
-
- case FFELEX_typeCOMMA:
- if (!ffestb_local_.moduleprocedure.started)
- {
- ffestb_local_.moduleprocedure.started = TRUE;
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- ffestc_R1205_start ();
- }
- if (!ffesta_is_inhibited ())
- ffestc_R1205_item (ffesta_tokens[1]);
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffestb_module1_;
-
- default:
- break;
- }
-
- if (ffestb_local_.moduleprocedure.started && !ffesta_is_inhibited ())
- ffestc_R1205_finish ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "MODULE PROCEDURE", t);
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_module3_ -- "MODULE" NAME
-
- return ffestb_module3_; // to lexer
-
- Make sure the statement has a valid form for the MODULE statement. If it
- does, implement the statement. */
-
-static ffelexHandler
-ffestb_module3_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- if (!ffesta_is_inhibited ())
- ffestc_R1105 (ffesta_tokens[1]);
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffesta_zero (t);
-
- default:
- break;
- }
-
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "MODULE", t);
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-#endif
-/* ffestb_R809 -- Parse the SELECTCASE statement
-
- return ffestb_R809; // to lexer
-
- Make sure the statement has a valid form for the SELECTCASE statement.
- If it does, implement the statement. */
-
-ffelexHandler
-ffestb_R809 (ffelexToken t)
-{
- ffeTokenLength i;
- const char *p;
-
- switch (ffelex_token_type (ffesta_tokens[0]))
- {
- case FFELEX_typeNAME:
- switch (ffesta_first_kw)
- {
- case FFESTR_firstSELECT:
- if ((ffelex_token_type (t) != FFELEX_typeNAME)
- || (ffesta_second_kw != FFESTR_secondCASE))
- goto bad_1; /* :::::::::::::::::::: */
- ffesta_confirmed ();
- return (ffelexHandler) ffestb_R8091_;
-
- case FFESTR_firstSELECTCASE:
- return (ffelexHandler) ffestb_R8091_ (t);
-
- default:
- goto bad_0; /* :::::::::::::::::::: */
- }
-
- case FFELEX_typeNAMES:
- if (ffesta_first_kw != FFESTR_firstSELECTCASE)
- goto bad_0; /* :::::::::::::::::::: */
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
-
- default:
- goto bad_1; /* :::::::::::::::::::: */
-
- case FFELEX_typeOPEN_PAREN:
- break;
- }
- p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlSELECTCASE);
- if (*p != '\0')
- goto bad_i; /* :::::::::::::::::::: */
- return (ffelexHandler) ffestb_R8091_ (t);
-
- default:
- goto bad_0; /* :::::::::::::::::::: */
- }
-
-bad_0: /* :::::::::::::::::::: */
- if (ffesta_construct_name != NULL)
- {
- ffelex_token_kill (ffesta_construct_name);
- ffesta_construct_name = NULL;
- }
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "SELECT CASE", ffesta_tokens[0]);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-
-bad_1: /* :::::::::::::::::::: */
- if (ffesta_construct_name != NULL)
- {
- ffelex_token_kill (ffesta_construct_name);
- ffesta_construct_name = NULL;
- }
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "SELECT CASE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero); /* Invalid second token. */
-
-bad_i: /* :::::::::::::::::::: */
- if (ffesta_construct_name != NULL)
- {
- ffelex_token_kill (ffesta_construct_name);
- ffesta_construct_name = NULL;
- }
- ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "SELECT CASE", ffesta_tokens[0], i, t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R8091_ -- "SELECTCASE" or "SELECT" "CASE"
-
- return ffestb_R8091_; // to lexer
-
- Make sure the statement has a valid form for the SELECTCASE statement. If it
- does, implement the statement. */
-
-static ffelexHandler
-ffestb_R8091_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeOPEN_PAREN:
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextSELECTCASE, (ffeexprCallback) ffestb_R8092_);
-
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- break;
-
- default:
- break;
- }
-
- if (ffesta_construct_name != NULL)
- {
- ffelex_token_kill (ffesta_construct_name);
- ffesta_construct_name = NULL;
- }
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "SELECT CASE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R8092_ -- "SELECT/CASE" OPEN_PAREN expr
-
- (ffestb_R8092_) // to expression handler
-
- Make sure the statement has a valid form for the SELECTCASE statement. If it
- does, implement the statement. */
-
-static ffelexHandler
-ffestb_R8092_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCLOSE_PAREN:
- if (expr == NULL)
- break;
- ffesta_tokens[1] = ffelex_token_use (ft);
- ffestb_local_.selectcase.expr = expr;
- return (ffelexHandler) ffestb_R8093_;
-
- default:
- break;
- }
-
- if (ffesta_construct_name != NULL)
- {
- ffelex_token_kill (ffesta_construct_name);
- ffesta_construct_name = NULL;
- }
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "SELECT CASE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R8093_ -- "SELECT/CASE" OPEN_PAREN expr CLOSE_PAREN
-
- return ffestb_R8093_; // to lexer
-
- Make sure the statement has a valid form for the SELECTCASE statement. If it
- does, implement the statement. */
-
-static ffelexHandler
-ffestb_R8093_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- ffestc_R809 (ffesta_construct_name, ffestb_local_.selectcase.expr,
- ffesta_tokens[1]);
- ffelex_token_kill (ffesta_tokens[1]);
- if (ffesta_construct_name != NULL)
- {
- ffelex_token_kill (ffesta_construct_name);
- ffesta_construct_name = NULL;
- }
- return ffesta_zero (t);
-
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- break;
-
- default:
- break;
- }
-
- ffelex_token_kill (ffesta_tokens[1]);
- if (ffesta_construct_name != NULL)
- {
- ffelex_token_kill (ffesta_construct_name);
- ffesta_construct_name = NULL;
- }
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "SELECT CASE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R810 -- Parse the CASE statement
-
- return ffestb_R810; // to lexer
-
- Make sure the statement has a valid form for the CASE statement.
- If it does, implement the statement. */
-
-ffelexHandler
-ffestb_R810 (ffelexToken t)
-{
- ffeTokenLength i;
- unsigned const char *p;
-
- switch (ffelex_token_type (ffesta_tokens[0]))
- {
- case FFELEX_typeNAME:
- if (ffesta_first_kw != FFESTR_firstCASE)
- goto bad_0; /* :::::::::::::::::::: */
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
-
- default:
- goto bad_1; /* :::::::::::::::::::: */
-
- case FFELEX_typeNAME:
- ffesta_confirmed ();
- if (ffesta_second_kw != FFESTR_secondDEFAULT)
- goto bad_1; /* :::::::::::::::::::: */
- ffestb_local_.case_stmt.cases = NULL;
- return (ffelexHandler) ffestb_R8101_;
-
- case FFELEX_typeOPEN_PAREN:
- ffestb_local_.case_stmt.cases = ffestt_caselist_create ();
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextCASE, (ffeexprCallback) ffestb_R8103_);
- }
-
- case FFELEX_typeNAMES:
- switch (ffesta_first_kw)
- {
- case FFESTR_firstCASEDEFAULT:
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
-
- default:
- goto bad_1; /* :::::::::::::::::::: */
-
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- break;
- }
- ffestb_local_.case_stmt.cases = NULL;
- p = ffelex_token_text (ffesta_tokens[0])
- + (i = FFESTR_firstlCASEDEFAULT);
- if (*p == '\0')
- return (ffelexHandler) ffestb_R8101_ (t);
- if (!ffesrc_is_name_init (*p))
- goto bad_i; /* :::::::::::::::::::: */
- ffesta_tokens[1] = ffelex_token_name_from_names (ffesta_tokens[0], i,
- 0);
- return (ffelexHandler) ffestb_R8102_ (t);
-
- case FFESTR_firstCASE:
- break;
-
- default:
- goto bad_0; /* :::::::::::::::::::: */
- }
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
-
- default:
- goto bad_1; /* :::::::::::::::::::: */
-
- case FFELEX_typeOPEN_PAREN:
- break;
- }
- p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlCASE);
- if (*p != '\0')
- goto bad_i; /* :::::::::::::::::::: */
- ffestb_local_.case_stmt.cases = ffestt_caselist_create ();
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextCASE, (ffeexprCallback) ffestb_R8103_);
-
- default:
- goto bad_0; /* :::::::::::::::::::: */
- }
-
-bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CASE", ffesta_tokens[0]);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-
-bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CASE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero); /* Invalid second token. */
-
-bad_i: /* :::::::::::::::::::: */
- ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "CASE", ffesta_tokens[0], i, t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R8101_ -- "CASE" case-selector
-
- return ffestb_R8101_; // to lexer
-
- Make sure the statement has a valid form for the CASE statement. If it
- does, implement the statement. */
-
-static ffelexHandler
-ffestb_R8101_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_R8102_;
-
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_tokens[1] = NULL;
- return (ffelexHandler) ffestb_R8102_ (t);
-
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- break;
-
- default:
- break;
- }
-
- if (ffestb_local_.case_stmt.cases != NULL)
- ffestt_caselist_kill (ffestb_local_.case_stmt.cases);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CASE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R8102_ -- "CASE" case-selector [NAME]
-
- return ffestb_R8102_; // to lexer
-
- Make sure the statement has a valid form for the CASE statement. If it
- does, implement the statement. */
-
-static ffelexHandler
-ffestb_R8102_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- ffestc_R810 (ffestb_local_.case_stmt.cases, ffesta_tokens[1]);
- if (ffestb_local_.case_stmt.cases != NULL)
- ffestt_caselist_kill (ffestb_local_.case_stmt.cases);
- if (ffesta_tokens[1] != NULL)
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffesta_zero (t);
-
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- break;
-
- default:
- break;
- }
-
- if (ffestb_local_.case_stmt.cases != NULL)
- ffestt_caselist_kill (ffestb_local_.case_stmt.cases);
- if (ffesta_tokens[1] != NULL)
- ffelex_token_kill (ffesta_tokens[1]);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CASE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R8103_ -- "CASE" OPEN_PAREN expr
-
- (ffestb_R8103_) // to expression handler
-
- Make sure the statement has a valid form for the CASE statement. If it
- does, implement the statement. */
-
-static ffelexHandler
-ffestb_R8103_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCLOSE_PAREN:
- ffestt_caselist_append (ffestb_local_.case_stmt.cases, FALSE, expr, NULL,
- ffelex_token_use (ft));
- return (ffelexHandler) ffestb_R8101_;
-
- case FFELEX_typeCOMMA:
- ffestt_caselist_append (ffestb_local_.case_stmt.cases, FALSE, expr, NULL,
- ffelex_token_use (ft));
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextCASE, (ffeexprCallback) ffestb_R8103_);
-
- case FFELEX_typeCOLON:
- ffestt_caselist_append (ffestb_local_.case_stmt.cases, TRUE, expr, NULL,
- ffelex_token_use (ft)); /* NULL second expr for
- now, just plug in. */
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextCASE, (ffeexprCallback) ffestb_R8104_);
-
- default:
- break;
- }
-
- ffestt_caselist_kill (ffestb_local_.case_stmt.cases);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CASE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R8104_ -- "CASE" OPEN_PAREN expr COLON expr
-
- (ffestb_R8104_) // to expression handler
-
- Make sure the statement has a valid form for the CASE statement. If it
- does, implement the statement. */
-
-static ffelexHandler
-ffestb_R8104_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCLOSE_PAREN:
- ffestb_local_.case_stmt.cases->previous->expr2 = expr;
- return (ffelexHandler) ffestb_R8101_;
-
- case FFELEX_typeCOMMA:
- ffestb_local_.case_stmt.cases->previous->expr2 = expr;
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextCASE, (ffeexprCallback) ffestb_R8103_);
-
- default:
- break;
- }
-
- ffestt_caselist_kill (ffestb_local_.case_stmt.cases);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CASE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R1001 -- Parse a FORMAT statement
-
- return ffestb_R1001; // to lexer
-
- Make sure the statement has a valid form for an FORMAT statement.
- If it does, implement the statement. */
-
-ffelexHandler
-ffestb_R1001 (ffelexToken t)
-{
- ffesttFormatList f;
-
- switch (ffelex_token_type (ffesta_tokens[0]))
- {
- case FFELEX_typeNAME:
- if (ffesta_first_kw != FFESTR_firstFORMAT)
- goto bad_0; /* :::::::::::::::::::: */
- break;
-
- case FFELEX_typeNAMES:
- if (ffesta_first_kw != FFESTR_firstFORMAT)
- goto bad_0; /* :::::::::::::::::::: */
- if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlFORMAT)
- goto bad_0; /* :::::::::::::::::::: */
- break;
-
- default:
- goto bad_0; /* :::::::::::::::::::: */
- }
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeOPEN_PAREN:
- ffestb_local_.format.complained = FALSE;
- ffestb_local_.format.f = NULL; /* No parent yet. */
- ffestb_local_.format.f = ffestt_formatlist_create (NULL,
- ffelex_token_use (t));
- ffelex_set_names_pure (TRUE); /* Have even free-form lexer give us
- NAMES. */
- return (ffelexHandler) ffestb_R10011_;
-
- case FFELEX_typeOPEN_ARRAY:/* "(/". */
- ffesta_confirmed ();
- ffestb_local_.format.complained = FALSE;
- ffestb_local_.format.f = ffestt_formatlist_create (NULL,
- ffelex_token_use (t));
- f = ffestt_formatlist_append (ffestb_local_.format.f);
- f->type = FFESTP_formattypeSLASH;
- f->t = ffelex_token_use (t);
- f->u.R1010.val.present = FALSE;
- f->u.R1010.val.rtexpr = FALSE;
- f->u.R1010.val.t = NULL;
- f->u.R1010.val.u.unsigned_val = 1;
- ffelex_set_names_pure (TRUE); /* Have even free-form lexer give us
- NAMES. */
- return (ffelexHandler) ffestb_R100112_;
-
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
-
- default:
- goto bad_1; /* :::::::::::::::::::: */
- }
-
-bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FORMAT", ffesta_tokens[0]);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-
-bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FORMAT", t);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero); /* Invalid second token. */
-}
-
-/* ffestb_R10011_ -- "FORMAT" OPEN_PAREN expr
-
- return ffestb_R10011_; // to lexer
-
- For CLOSE_PAREN, wrap up the format list and if it is the top-level one,
- exit. For anything else, pass it to _2_. */
-
-static ffelexHandler
-ffestb_R10011_ (ffelexToken t)
-{
- ffesttFormatList f;
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCLOSE_PAREN:
- break;
-
- default:
- return (ffelexHandler) ffestb_R10012_ (t);
- }
-
- /* If we have a format we're working on, continue working on it. */
-
- f = ffestb_local_.format.f->u.root.parent;
-
- if (f != NULL)
- {
- ffestb_local_.format.f = f->next;
- return (ffelexHandler) ffestb_R100111_;
- }
-
- return (ffelexHandler) ffestb_R100114_;
-}
-
-/* ffestb_R10012_ -- "FORMAT" OPEN_PAREN [format-item-list]
-
- return ffestb_R10012_; // to lexer
-
- The initial state for a format-item. Here, just handle the initial
- number, sign for number, or run-time expression. Also handle spurious
- comma, close-paren (indicating spurious comma), close-array (like
- close-paren but preceded by slash), and quoted strings. */
-
-static ffelexHandler
-ffestb_R10012_ (ffelexToken t)
-{
- unsigned long unsigned_val;
- ffesttFormatList f;
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeOPEN_ANGLE:
- ffesta_confirmed ();
- ffestb_local_.format.pre.t = ffelex_token_use (t);
- ffelex_set_names_pure (FALSE);
- if (!ffesta_seen_first_exec && !ffestb_local_.format.complained)
- {
- ffestb_local_.format.complained = TRUE;
- ffebad_start (FFEBAD_FORMAT_EXPR_SPEC);
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextFORMAT, (ffeexprCallback) ffestb_R100115_);
-
- case FFELEX_typeNUMBER:
- ffestb_local_.format.sign = FALSE; /* No sign present. */
- ffestb_local_.format.pre.present = TRUE;
- ffestb_local_.format.pre.rtexpr = FALSE;
- ffestb_local_.format.pre.t = ffelex_token_use (t);
- ffestb_local_.format.pre.u.unsigned_val = unsigned_val
- = strtoul (ffelex_token_text (t), NULL, 10);
- ffelex_set_expecting_hollerith (unsigned_val, '\0',
- ffelex_token_where_line (t),
- ffelex_token_where_column (t));
- return (ffelexHandler) ffestb_R10014_;
-
- case FFELEX_typePLUS:
- ffestb_local_.format.sign = TRUE; /* Positive. */
- ffestb_local_.format.pre.t = ffelex_token_use (t);
- return (ffelexHandler) ffestb_R10013_;
-
- case FFELEX_typeMINUS:
- ffestb_local_.format.sign = FALSE; /* Negative. */
- ffestb_local_.format.pre.t = ffelex_token_use (t);
- return (ffelexHandler) ffestb_R10013_;
-
- case FFELEX_typeCOLON:
- case FFELEX_typeCOLONCOLON:/* "::". */
- case FFELEX_typeSLASH:
- case FFELEX_typeCONCAT: /* "//". */
- case FFELEX_typeNAMES:
- case FFELEX_typeDOLLAR:
- case FFELEX_typeOPEN_PAREN:
- case FFELEX_typeOPEN_ARRAY:/* "(/". */
- ffestb_local_.format.sign = FALSE; /* No sign present. */
- ffestb_local_.format.pre.present = FALSE;
- ffestb_local_.format.pre.rtexpr = FALSE;
- ffestb_local_.format.pre.t = NULL;
- ffestb_local_.format.pre.u.unsigned_val = 1;
- return (ffelexHandler) ffestb_R10014_ (t);
-
- case FFELEX_typeCOMMA:
- ffebad_start (FFEBAD_FORMAT_EXTRA_COMMA);
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- return (ffelexHandler) ffestb_R10012_;
-
- case FFELEX_typeCLOSE_PAREN:
- ffebad_start (FFEBAD_FORMAT_EXTRA_COMMA);
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- f = ffestb_local_.format.f->u.root.parent;
- if (f == NULL)
- return (ffelexHandler) ffestb_R100114_;
- ffestb_local_.format.f = f->next;
- return (ffelexHandler) ffestb_R100111_;
-
- case FFELEX_typeCLOSE_ARRAY: /* "/)". */
- f = ffestt_formatlist_append (ffestb_local_.format.f);
- f->type = FFESTP_formattypeSLASH;
- f->t = ffelex_token_use (t);
- f->u.R1010.val.present = FALSE;
- f->u.R1010.val.rtexpr = FALSE;
- f->u.R1010.val.t = NULL;
- f->u.R1010.val.u.unsigned_val = 1;
- f = ffestb_local_.format.f->u.root.parent;
- if (f == NULL)
- return (ffelexHandler) ffestb_R100114_;
- ffestb_local_.format.f = f->next;
- return (ffelexHandler) ffestb_R100111_;
-
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- ffesta_ffebad_1t (FFEBAD_FORMAT_MISSING_PAREN, t);
- for (f = ffestb_local_.format.f;
- f->u.root.parent != NULL;
- f = f->u.root.parent->next)
- ;
- ffestb_local_.format.f = f;
- return (ffelexHandler) ffestb_R100114_ (t);
-
- case FFELEX_typeQUOTE:
- if (ffe_is_vxt ())
- break; /* Error, probably something like FORMAT("17)
- = X. */
- ffelex_set_expecting_hollerith (-1, '\"',
- ffelex_token_where_line (t),
- ffelex_token_where_column (t)); /* Don't have to unset
- this one. */
- return (ffelexHandler) ffestb_R100113_;
-
- case FFELEX_typeAPOSTROPHE:
-#if 0 /* No apparent need for this, and not killed
- anywhere. */
- ffesta_tokens[1] = ffelex_token_use (t);
-#endif
- ffelex_set_expecting_hollerith (-1, '\'',
- ffelex_token_where_line (t),
- ffelex_token_where_column (t)); /* Don't have to unset
- this one. */
- return (ffelexHandler) ffestb_R100113_;
-
- default:
- break;
- }
-
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FORMAT", t);
- ffestt_formatlist_kill (ffestb_local_.format.f);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R10013_ -- "FORMAT" OPEN_PAREN [format-item-list] PLUS/MINUS
-
- return ffestb_R10013_; // to lexer
-
- Expect a NUMBER or complain about and then ignore the PLUS/MINUS. */
-
-static ffelexHandler
-ffestb_R10013_ (ffelexToken t)
-{
- unsigned long unsigned_val;
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNUMBER:
- ffestb_local_.format.pre.present = TRUE;
- ffestb_local_.format.pre.rtexpr = FALSE;
- unsigned_val = strtoul (ffelex_token_text (t), NULL, 10);
- ffestb_local_.format.pre.u.signed_val = ffestb_local_.format.sign
- ? unsigned_val : -unsigned_val;
- ffestb_local_.format.sign = TRUE; /* Sign present. */
- return (ffelexHandler) ffestb_R10014_;
-
- default:
- ffebad_start (FFEBAD_FORMAT_SPURIOUS_SIGN);
- ffebad_here (0, ffelex_token_where_line (ffestb_local_.format.pre.t),
- ffelex_token_where_column (ffestb_local_.format.pre.t));
- ffebad_finish ();
- ffelex_token_kill (ffestb_local_.format.pre.t);
- return (ffelexHandler) ffestb_R10012_ (t);
- }
-}
-
-/* ffestb_R10014_ -- "FORMAT" OPEN_PAREN [format-item-list] [[+/-] NUMBER]
-
- return ffestb_R10014_; // to lexer
-
- Here is where we expect to see the actual NAMES, COLON, SLASH, OPEN_PAREN,
- OPEN_ARRAY, COLONCOLON, CONCAT, DOLLAR, or HOLLERITH that identifies what
- kind of format-item we're dealing with. But if we see a NUMBER instead, it
- means free-form spaces number like "5 6 X", so scale the current number
- accordingly and reenter this state. (I really wouldn't be surprised if
- they change this spacing rule in the F90 spec so that you can't embed
- spaces within numbers or within keywords like BN in a free-source-form
- program.) */
-
-static ffelexHandler
-ffestb_R10014_ (ffelexToken t)
-{
- ffesttFormatList f;
- ffeTokenLength i;
- const char *p;
- ffestrFormat kw;
-
- ffelex_set_expecting_hollerith (0, '\0',
- ffewhere_line_unknown (),
- ffewhere_column_unknown ());
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeHOLLERITH:
- f = ffestt_formatlist_append (ffestb_local_.format.f);
- f->type = FFESTP_formattypeR1016;
- f->t = ffelex_token_use (t);
- ffelex_token_kill (ffestb_local_.format.pre.t); /* It WAS present! */
- return (ffelexHandler) ffestb_R100111_;
-
- case FFELEX_typeNUMBER:
- assert (ffestb_local_.format.pre.present);
- ffesta_confirmed ();
- if (ffestb_local_.format.pre.rtexpr)
- {
- ffebad_start (FFEBAD_FORMAT_SPURIOUS_NUMBER);
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- return (ffelexHandler) ffestb_R10014_;
- }
- if (ffestb_local_.format.sign)
- {
- for (i = ffelex_token_length (t) + 1; i > 0; --i)
- ffestb_local_.format.pre.u.signed_val *= 10;
- ffestb_local_.format.pre.u.signed_val += strtoul (ffelex_token_text (t),
- NULL, 10);
- }
- else
- {
- for (i = ffelex_token_length (t) + 1; i > 0; --i)
- ffestb_local_.format.pre.u.unsigned_val *= 10;
- ffestb_local_.format.pre.u.unsigned_val += strtoul (ffelex_token_text (t),
- NULL, 10);
- ffelex_set_expecting_hollerith (ffestb_local_.format.pre.u.unsigned_val,
- '\0',
- ffelex_token_where_line (t),
- ffelex_token_where_column (t));
- }
- return (ffelexHandler) ffestb_R10014_;
-
- case FFELEX_typeCOLONCOLON: /* "::". */
- if (ffestb_local_.format.pre.present)
- {
- ffesta_ffebad_1t (FFEBAD_FORMAT_BAD_COLON_SPEC,
- ffestb_local_.format.pre.t);
- ffelex_token_kill (ffestb_local_.format.pre.t);
- ffestb_local_.format.pre.present = FALSE;
- }
- else
- {
- f = ffestt_formatlist_append (ffestb_local_.format.f);
- f->type = FFESTP_formattypeCOLON;
- f->t = ffelex_token_use (t);
- f->u.R1010.val.present = FALSE;
- f->u.R1010.val.rtexpr = FALSE;
- f->u.R1010.val.t = NULL;
- f->u.R1010.val.u.unsigned_val = 1;
- }
- f = ffestt_formatlist_append (ffestb_local_.format.f);
- f->type = FFESTP_formattypeCOLON;
- f->t = ffelex_token_use (t);
- f->u.R1010.val.present = FALSE;
- f->u.R1010.val.rtexpr = FALSE;
- f->u.R1010.val.t = NULL;
- f->u.R1010.val.u.unsigned_val = 1;
- return (ffelexHandler) ffestb_R100112_;
-
- case FFELEX_typeCOLON:
- if (ffestb_local_.format.pre.present)
- {
- ffesta_ffebad_1t (FFEBAD_FORMAT_BAD_COLON_SPEC,
- ffestb_local_.format.pre.t);
- ffelex_token_kill (ffestb_local_.format.pre.t);
- return (ffelexHandler) ffestb_R100112_;
- }
- f = ffestt_formatlist_append (ffestb_local_.format.f);
- f->type = FFESTP_formattypeCOLON;
- f->t = ffelex_token_use (t);
- f->u.R1010.val.present = FALSE;
- f->u.R1010.val.rtexpr = FALSE;
- f->u.R1010.val.t = NULL;
- f->u.R1010.val.u.unsigned_val = 1;
- return (ffelexHandler) ffestb_R100112_;
-
- case FFELEX_typeCONCAT: /* "//". */
- if (ffestb_local_.format.sign)
- {
- ffebad_start (FFEBAD_FORMAT_SPURIOUS_SIGN);
- ffebad_here (0, ffelex_token_where_line (ffestb_local_.format.pre.t),
- ffelex_token_where_column (ffestb_local_.format.pre.t));
- ffebad_finish ();
- ffestb_local_.format.pre.u.unsigned_val
- = (ffestb_local_.format.pre.u.signed_val < 0)
- ? -ffestb_local_.format.pre.u.signed_val
- : ffestb_local_.format.pre.u.signed_val;
- }
- f = ffestt_formatlist_append (ffestb_local_.format.f);
- f->type = FFESTP_formattypeSLASH;
- f->t = ffelex_token_use (t);
- f->u.R1010.val = ffestb_local_.format.pre;
- ffestb_local_.format.pre.present = FALSE;
- ffestb_local_.format.pre.rtexpr = FALSE;
- ffestb_local_.format.pre.t = NULL;
- ffestb_local_.format.pre.u.unsigned_val = 1;
- f = ffestt_formatlist_append (ffestb_local_.format.f);
- f->type = FFESTP_formattypeSLASH;
- f->t = ffelex_token_use (t);
- f->u.R1010.val = ffestb_local_.format.pre;
- return (ffelexHandler) ffestb_R100112_;
-
- case FFELEX_typeSLASH:
- if (ffestb_local_.format.sign)
- {
- ffebad_start (FFEBAD_FORMAT_SPURIOUS_SIGN);
- ffebad_here (0, ffelex_token_where_line (ffestb_local_.format.pre.t),
- ffelex_token_where_column (ffestb_local_.format.pre.t));
- ffebad_finish ();
- ffestb_local_.format.pre.u.unsigned_val
- = (ffestb_local_.format.pre.u.signed_val < 0)
- ? -ffestb_local_.format.pre.u.signed_val
- : ffestb_local_.format.pre.u.signed_val;
- }
- f = ffestt_formatlist_append (ffestb_local_.format.f);
- f->type = FFESTP_formattypeSLASH;
- f->t = ffelex_token_use (t);
- f->u.R1010.val = ffestb_local_.format.pre;
- return (ffelexHandler) ffestb_R100112_;
-
- case FFELEX_typeOPEN_PAREN:
- if (ffestb_local_.format.sign)
- {
- ffebad_start (FFEBAD_FORMAT_SPURIOUS_SIGN);
- ffebad_here (0, ffelex_token_where_line (ffestb_local_.format.pre.t),
- ffelex_token_where_column (ffestb_local_.format.pre.t));
- ffebad_finish ();
- ffestb_local_.format.pre.u.unsigned_val
- = (ffestb_local_.format.pre.u.signed_val < 0)
- ? -ffestb_local_.format.pre.u.signed_val
- : ffestb_local_.format.pre.u.signed_val;
- }
- f = ffestt_formatlist_append (ffestb_local_.format.f);
- f->type = FFESTP_formattypeFORMAT;
- f->t = ffelex_token_use (t);
- f->u.R1003D.R1004 = ffestb_local_.format.pre;
- f->u.R1003D.format = ffestb_local_.format.f
- = ffestt_formatlist_create (f, ffelex_token_use (t));
- return (ffelexHandler) ffestb_R10011_;
-
- case FFELEX_typeOPEN_ARRAY:/* "(/". */
- if (ffestb_local_.format.sign)
- {
- ffebad_start (FFEBAD_FORMAT_SPURIOUS_SIGN);
- ffebad_here (0, ffelex_token_where_line (ffestb_local_.format.pre.t),
- ffelex_token_where_column (ffestb_local_.format.pre.t));
- ffebad_finish ();
- ffestb_local_.format.pre.u.unsigned_val
- = (ffestb_local_.format.pre.u.signed_val < 0)
- ? -ffestb_local_.format.pre.u.signed_val
- : ffestb_local_.format.pre.u.signed_val;
- }
- f = ffestt_formatlist_append (ffestb_local_.format.f);
- f->type = FFESTP_formattypeFORMAT;
- f->t = ffelex_token_use (t);
- f->u.R1003D.R1004 = ffestb_local_.format.pre;
- f->u.R1003D.format = ffestb_local_.format.f
- = ffestt_formatlist_create (f, ffelex_token_use (t));
- f = ffestt_formatlist_append (ffestb_local_.format.f);
- f->type = FFESTP_formattypeSLASH;
- f->t = ffelex_token_use (t);
- f->u.R1010.val.present = FALSE;
- f->u.R1010.val.rtexpr = FALSE;
- f->u.R1010.val.t = NULL;
- f->u.R1010.val.u.unsigned_val = 1;
- return (ffelexHandler) ffestb_R100112_;
-
- case FFELEX_typeCLOSE_ARRAY: /* "/)". */
- f = ffestt_formatlist_append (ffestb_local_.format.f);
- f->type = FFESTP_formattypeSLASH;
- f->t = ffelex_token_use (t);
- f->u.R1010.val = ffestb_local_.format.pre;
- f = ffestb_local_.format.f->u.root.parent;
- if (f == NULL)
- return (ffelexHandler) ffestb_R100114_;
- ffestb_local_.format.f = f->next;
- return (ffelexHandler) ffestb_R100111_;
-
- case FFELEX_typeQUOTE:
- if (ffe_is_vxt ())
- break; /* A totally bad character in a VXT FORMAT. */
- ffebad_start (FFEBAD_FORMAT_SPURIOUS_NUMBER);
- ffebad_here (0, ffelex_token_where_line (ffestb_local_.format.pre.t),
- ffelex_token_where_column (ffestb_local_.format.pre.t));
- ffebad_finish ();
- ffelex_token_kill (ffestb_local_.format.pre.t);
- ffesta_confirmed ();
-#if 0 /* No apparent need for this, and not killed
- anywhere. */
- ffesta_tokens[1] = ffelex_token_use (t);
-#endif
- ffelex_set_expecting_hollerith (-1, '\"',
- ffelex_token_where_line (t),
- ffelex_token_where_column (t)); /* Don't have to unset
- this one. */
- return (ffelexHandler) ffestb_R100113_;
-
- case FFELEX_typeAPOSTROPHE:
- ffesta_confirmed ();
- ffebad_start (FFEBAD_FORMAT_SPURIOUS_NUMBER);
- ffebad_here (0, ffelex_token_where_line (ffestb_local_.format.pre.t),
- ffelex_token_where_column (ffestb_local_.format.pre.t));
- ffebad_finish ();
- ffelex_token_kill (ffestb_local_.format.pre.t);
-#if 0 /* No apparent need for this, and not killed
- anywhere. */
- ffesta_tokens[1] = ffelex_token_use (t);
-#endif
- ffelex_set_expecting_hollerith (-1, '\'', ffelex_token_where_line (t),
- ffelex_token_where_column (t)); /* Don't have to unset
- this one. */
- return (ffelexHandler) ffestb_R100113_;
-
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- ffesta_ffebad_1t (FFEBAD_FORMAT_MISSING_PAREN, t);
- for (f = ffestb_local_.format.f;
- f->u.root.parent != NULL;
- f = f->u.root.parent->next)
- ;
- ffestb_local_.format.f = f;
- ffelex_token_kill (ffestb_local_.format.pre.t);
- return (ffelexHandler) ffestb_R100114_ (t);
-
- case FFELEX_typeDOLLAR:
- ffestb_local_.format.t = ffelex_token_use (t);
- if (ffestb_local_.format.pre.present)
- ffesta_confirmed (); /* Number preceding this invalid elsewhere. */
- ffestb_local_.format.current = FFESTP_formattypeDOLLAR;
- return (ffelexHandler) ffestb_R10015_;
-
- case FFELEX_typeNAMES:
- kw = ffestr_format (t);
- ffestb_local_.format.t = ffelex_token_use (t);
- switch (kw)
- {
- case FFESTR_formatI:
- if (ffestb_local_.format.pre.present)
- ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
- ffestb_local_.format.current = FFESTP_formattypeI;
- i = FFESTR_formatlI;
- break;
-
- case FFESTR_formatB:
- if (ffestb_local_.format.pre.present)
- ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
- ffestb_local_.format.current = FFESTP_formattypeB;
- i = FFESTR_formatlB;
- break;
-
- case FFESTR_formatO:
- if (ffestb_local_.format.pre.present)
- ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
- ffestb_local_.format.current = FFESTP_formattypeO;
- i = FFESTR_formatlO;
- break;
-
- case FFESTR_formatZ:
- if (ffestb_local_.format.pre.present)
- ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
- ffestb_local_.format.current = FFESTP_formattypeZ;
- i = FFESTR_formatlZ;
- break;
-
- case FFESTR_formatF:
- if (ffestb_local_.format.pre.present)
- ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
- ffestb_local_.format.current = FFESTP_formattypeF;
- i = FFESTR_formatlF;
- break;
-
- case FFESTR_formatE:
- ffestb_local_.format.current = FFESTP_formattypeE;
- i = FFESTR_formatlE;
- break;
-
- case FFESTR_formatEN:
- if (ffestb_local_.format.pre.present)
- ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
- ffestb_local_.format.current = FFESTP_formattypeEN;
- i = FFESTR_formatlEN;
- break;
-
- case FFESTR_formatG:
- if (ffestb_local_.format.pre.present)
- ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
- ffestb_local_.format.current = FFESTP_formattypeG;
- i = FFESTR_formatlG;
- break;
-
- case FFESTR_formatL:
- if (ffestb_local_.format.pre.present)
- ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
- ffestb_local_.format.current = FFESTP_formattypeL;
- i = FFESTR_formatlL;
- break;
-
- case FFESTR_formatA:
- if (ffestb_local_.format.pre.present)
- ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
- ffestb_local_.format.current = FFESTP_formattypeA;
- i = FFESTR_formatlA;
- break;
-
- case FFESTR_formatD:
- ffestb_local_.format.current = FFESTP_formattypeD;
- i = FFESTR_formatlD;
- break;
-
- case FFESTR_formatQ:
- ffestb_local_.format.current = FFESTP_formattypeQ;
- i = FFESTR_formatlQ;
- break;
-
- case FFESTR_formatDOLLAR:
- if (ffestb_local_.format.pre.present)
- ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
- ffestb_local_.format.current = FFESTP_formattypeDOLLAR;
- i = FFESTR_formatlDOLLAR;
- break;
-
- case FFESTR_formatP:
- if (ffestb_local_.format.pre.present)
- ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
- ffestb_local_.format.current = FFESTP_formattypeP;
- i = FFESTR_formatlP;
- break;
-
- case FFESTR_formatT:
- if (ffestb_local_.format.pre.present)
- ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
- ffestb_local_.format.current = FFESTP_formattypeT;
- i = FFESTR_formatlT;
- break;
-
- case FFESTR_formatTL:
- if (ffestb_local_.format.pre.present)
- ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
- ffestb_local_.format.current = FFESTP_formattypeTL;
- i = FFESTR_formatlTL;
- break;
-
- case FFESTR_formatTR:
- if (ffestb_local_.format.pre.present)
- ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
- ffestb_local_.format.current = FFESTP_formattypeTR;
- i = FFESTR_formatlTR;
- break;
-
- case FFESTR_formatX:
- if (ffestb_local_.format.pre.present)
- ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
- ffestb_local_.format.current = FFESTP_formattypeX;
- i = FFESTR_formatlX;
- break;
-
- case FFESTR_formatS:
- if (ffestb_local_.format.pre.present)
- ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
- ffestb_local_.format.current = FFESTP_formattypeS;
- i = FFESTR_formatlS;
- break;
-
- case FFESTR_formatSP:
- if (ffestb_local_.format.pre.present)
- ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
- ffestb_local_.format.current = FFESTP_formattypeSP;
- i = FFESTR_formatlSP;
- break;
-
- case FFESTR_formatSS:
- if (ffestb_local_.format.pre.present)
- ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
- ffestb_local_.format.current = FFESTP_formattypeSS;
- i = FFESTR_formatlSS;
- break;
-
- case FFESTR_formatBN:
- if (ffestb_local_.format.pre.present)
- ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
- ffestb_local_.format.current = FFESTP_formattypeBN;
- i = FFESTR_formatlBN;
- break;
-
- case FFESTR_formatBZ:
- if (ffestb_local_.format.pre.present)
- ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
- ffestb_local_.format.current = FFESTP_formattypeBZ;
- i = FFESTR_formatlBZ;
- break;
-
- case FFESTR_formatH: /* Error, either "H" or "<expr>H". */
- if (ffestb_local_.format.pre.present)
- ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
- ffestb_local_.format.current = FFESTP_formattypeH;
- i = FFESTR_formatlH;
- break;
-
- case FFESTR_formatPD:
- if (ffestb_local_.format.pre.present)
- ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
- ffestb_subr_R1001_append_p_ ();
- ffestb_local_.format.t = ffelex_token_name_from_names (t,
- FFESTR_formatlP, 1);
- ffestb_local_.format.sign = FALSE;
- ffestb_local_.format.pre.present = FALSE;
- ffestb_local_.format.pre.rtexpr = FALSE;
- ffestb_local_.format.pre.t = NULL;
- ffestb_local_.format.pre.u.unsigned_val = 1;
- ffestb_local_.format.current = FFESTP_formattypeD;
- i = FFESTR_formatlPD;
- break;
-
- case FFESTR_formatPE:
- if (ffestb_local_.format.pre.present)
- ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
- ffestb_subr_R1001_append_p_ ();
- ffestb_local_.format.t = ffelex_token_name_from_names (t,
- FFESTR_formatlP, 1);
- ffestb_local_.format.sign = FALSE;
- ffestb_local_.format.pre.present = FALSE;
- ffestb_local_.format.pre.rtexpr = FALSE;
- ffestb_local_.format.pre.t = NULL;
- ffestb_local_.format.pre.u.unsigned_val = 1;
- ffestb_local_.format.current = FFESTP_formattypeE;
- i = FFESTR_formatlPE;
- break;
-
- case FFESTR_formatPEN:
- if (ffestb_local_.format.pre.present)
- ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
- ffestb_subr_R1001_append_p_ ();
- ffestb_local_.format.t = ffelex_token_name_from_names (t,
- FFESTR_formatlP, 1);
- ffestb_local_.format.sign = FALSE;
- ffestb_local_.format.pre.present = FALSE;
- ffestb_local_.format.pre.rtexpr = FALSE;
- ffestb_local_.format.pre.t = NULL;
- ffestb_local_.format.pre.u.unsigned_val = 1;
- ffestb_local_.format.current = FFESTP_formattypeEN;
- i = FFESTR_formatlPEN;
- break;
-
- case FFESTR_formatPF:
- if (ffestb_local_.format.pre.present)
- ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
- ffestb_subr_R1001_append_p_ ();
- ffestb_local_.format.t = ffelex_token_name_from_names (t,
- FFESTR_formatlP, 1);
- ffestb_local_.format.sign = FALSE;
- ffestb_local_.format.pre.present = FALSE;
- ffestb_local_.format.pre.rtexpr = FALSE;
- ffestb_local_.format.pre.t = NULL;
- ffestb_local_.format.pre.u.unsigned_val = 1;
- ffestb_local_.format.current = FFESTP_formattypeF;
- i = FFESTR_formatlPF;
- break;
-
- case FFESTR_formatPG:
- if (ffestb_local_.format.pre.present)
- ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
- ffestb_subr_R1001_append_p_ ();
- ffestb_local_.format.t = ffelex_token_name_from_names (t,
- FFESTR_formatlP, 1);
- ffestb_local_.format.sign = FALSE;
- ffestb_local_.format.pre.present = FALSE;
- ffestb_local_.format.pre.rtexpr = FALSE;
- ffestb_local_.format.pre.t = NULL;
- ffestb_local_.format.pre.u.unsigned_val = 1;
- ffestb_local_.format.current = FFESTP_formattypeG;
- i = FFESTR_formatlPG;
- break;
-
- default:
- if (ffestb_local_.format.pre.present)
- ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
- ffestb_local_.format.current = FFESTP_formattypeNone;
- p = strpbrk (ffelex_token_text (t), "0123456789");
- if (p == NULL)
- i = ffelex_token_length (t);
- else
- i = p - ffelex_token_text (t);
- break;
- }
- p = ffelex_token_text (t) + i;
- if (*p == '\0')
- return (ffelexHandler) ffestb_R10015_;
- if (! ISDIGIT (*p))
- {
- if (ffestb_local_.format.current == FFESTP_formattypeH)
- p = strpbrk (p, "0123456789");
- else
- {
- p = NULL;
- ffestb_local_.format.current = FFESTP_formattypeNone;
- }
- if (p == NULL)
- return (ffelexHandler) ffestb_R10015_;
- i = p - ffelex_token_text (t); /* Collect digits. */
- }
- ffestb_local_.format.post.present = TRUE;
- ffestb_local_.format.post.rtexpr = FALSE;
- ffestb_local_.format.post.t = ffelex_token_number_from_names (t, i);
- ffestb_local_.format.post.u.unsigned_val
- = strtoul (ffelex_token_text (ffestb_local_.format.post.t), NULL, 10);
- p += ffelex_token_length (ffestb_local_.format.post.t);
- i += ffelex_token_length (ffestb_local_.format.post.t);
- if (*p == '\0')
- return (ffelexHandler) ffestb_R10016_;
- if ((kw != FFESTR_formatP) ||
- !ffelex_is_firstnamechar ((unsigned char)*p))
- {
- if (ffestb_local_.format.current != FFESTP_formattypeH)
- ffesta_ffebad_1p (FFEBAD_FORMAT_TEXT_IN_NUMBER, t, i, NULL);
- return (ffelexHandler) ffestb_R10016_;
- }
-
- /* Here we have [number]P[number][text]. Treat as
- [number]P,[number][text]. */
-
- ffestb_subr_R1001_append_p_ ();
- t = ffestb_local_.format.t = ffelex_token_names_from_names (t, i, 0);
- ffestb_local_.format.sign = FALSE;
- ffestb_local_.format.pre = ffestb_local_.format.post;
- kw = ffestr_format (t);
- switch (kw)
- { /* Only a few possibilities here. */
- case FFESTR_formatD:
- ffestb_local_.format.current = FFESTP_formattypeD;
- i = FFESTR_formatlD;
- break;
-
- case FFESTR_formatE:
- ffestb_local_.format.current = FFESTP_formattypeE;
- i = FFESTR_formatlE;
- break;
-
- case FFESTR_formatEN:
- ffestb_local_.format.current = FFESTP_formattypeEN;
- i = FFESTR_formatlEN;
- break;
-
- case FFESTR_formatF:
- ffestb_local_.format.current = FFESTP_formattypeF;
- i = FFESTR_formatlF;
- break;
-
- case FFESTR_formatG:
- ffestb_local_.format.current = FFESTP_formattypeG;
- i = FFESTR_formatlG;
- break;
-
- default:
- ffebad_start (FFEBAD_FORMAT_P_NOCOMMA);
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- ffestb_local_.format.current = FFESTP_formattypeNone;
- p = strpbrk (ffelex_token_text (t), "0123456789");
- if (p == NULL)
- i = ffelex_token_length (t);
- else
- i = p - ffelex_token_text (t);
- }
- p = ffelex_token_text (t) + i;
- if (*p == '\0')
- return (ffelexHandler) ffestb_R10015_;
- if (! ISDIGIT (*p))
- {
- ffestb_local_.format.current = FFESTP_formattypeNone;
- p = strpbrk (p, "0123456789");
- if (p == NULL)
- return (ffelexHandler) ffestb_R10015_;
- i = p - ffelex_token_text (t); /* Collect digits anyway. */
- }
- ffestb_local_.format.post.present = TRUE;
- ffestb_local_.format.post.rtexpr = FALSE;
- ffestb_local_.format.post.t = ffelex_token_number_from_names (t, i);
- ffestb_local_.format.post.u.unsigned_val
- = strtoul (ffelex_token_text (ffestb_local_.format.post.t), NULL, 10);
- p += ffelex_token_length (ffestb_local_.format.post.t);
- i += ffelex_token_length (ffestb_local_.format.post.t);
- if (*p == '\0')
- return (ffelexHandler) ffestb_R10016_;
- ffesta_ffebad_1p (FFEBAD_FORMAT_TEXT_IN_NUMBER, t, i, NULL);
- return (ffelexHandler) ffestb_R10016_;
-
- default:
- break;
- }
-
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FORMAT", t);
- if (ffestb_local_.format.pre.present)
- ffelex_token_kill (ffestb_local_.format.pre.t);
- ffestt_formatlist_kill (ffestb_local_.format.f);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R10015_ -- [[+/-] NUMBER] NAMES
-
- return ffestb_R10015_; // to lexer
-
- Here we've gotten at least the initial mnemonic for the edit descriptor.
- We expect either a NUMBER, for the post-mnemonic value, a NAMES, for
- further clarification (in free-form only, sigh) of the mnemonic, or
- anything else. In all cases we go to _6_, with the difference that for
- NUMBER and NAMES we send the next token rather than the current token. */
-
-static ffelexHandler
-ffestb_R10015_ (ffelexToken t)
-{
- bool split_pea; /* New NAMES requires splitting kP from new
- edit desc. */
- ffestrFormat kw;
- const char *p;
- ffeTokenLength i;
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeOPEN_ANGLE:
- ffesta_confirmed ();
- ffestb_local_.format.post.t = ffelex_token_use (t);
- ffelex_set_names_pure (FALSE);
- if (!ffesta_seen_first_exec && !ffestb_local_.format.complained)
- {
- ffestb_local_.format.complained = TRUE;
- ffebad_start (FFEBAD_FORMAT_EXPR_SPEC);
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextFORMAT, (ffeexprCallback) ffestb_R100116_);
-
- case FFELEX_typeNUMBER:
- ffestb_local_.format.post.present = TRUE;
- ffestb_local_.format.post.rtexpr = FALSE;
- ffestb_local_.format.post.t = ffelex_token_use (t);
- ffestb_local_.format.post.u.unsigned_val
- = strtoul (ffelex_token_text (t), NULL, 10);
- return (ffelexHandler) ffestb_R10016_;
-
- case FFELEX_typeNAMES:
- ffesta_confirmed (); /* NAMES " " NAMES invalid elsewhere in
- free-form. */
- kw = ffestr_format (t);
- switch (ffestb_local_.format.current)
- {
- case FFESTP_formattypeP:
- split_pea = TRUE;
- break;
-
- case FFESTP_formattypeH: /* An error, maintain this indicator. */
- kw = FFESTR_formatNone;
- split_pea = FALSE;
- break;
-
- default:
- split_pea = FALSE;
- break;
- }
-
- switch (kw)
- {
- case FFESTR_formatF:
- switch (ffestb_local_.format.current)
- {
- case FFESTP_formattypeP:
- ffestb_local_.format.current = FFESTP_formattypeF;
- break;
-
- default:
- ffestb_local_.format.current = FFESTP_formattypeNone;
- break;
- }
- i = FFESTR_formatlF;
- break;
-
- case FFESTR_formatE:
- switch (ffestb_local_.format.current)
- {
- case FFESTP_formattypeP:
- ffestb_local_.format.current = FFESTP_formattypeE;
- break;
-
- default:
- ffestb_local_.format.current = FFESTP_formattypeNone;
- break;
- }
- i = FFESTR_formatlE;
- break;
-
- case FFESTR_formatEN:
- switch (ffestb_local_.format.current)
- {
- case FFESTP_formattypeP:
- ffestb_local_.format.current = FFESTP_formattypeEN;
- break;
-
- default:
- ffestb_local_.format.current = FFESTP_formattypeNone;
- break;
- }
- i = FFESTR_formatlEN;
- break;
-
- case FFESTR_formatG:
- switch (ffestb_local_.format.current)
- {
- case FFESTP_formattypeP:
- ffestb_local_.format.current = FFESTP_formattypeG;
- break;
-
- default:
- ffestb_local_.format.current = FFESTP_formattypeNone;
- break;
- }
- i = FFESTR_formatlG;
- break;
-
- case FFESTR_formatL:
- switch (ffestb_local_.format.current)
- {
- case FFESTP_formattypeT:
- ffestb_local_.format.current = FFESTP_formattypeTL;
- break;
-
- default:
- ffestb_local_.format.current = FFESTP_formattypeNone;
- break;
- }
- i = FFESTR_formatlL;
- break;
-
- case FFESTR_formatD:
- switch (ffestb_local_.format.current)
- {
- case FFESTP_formattypeP:
- ffestb_local_.format.current = FFESTP_formattypeD;
- break;
-
- default:
- ffestb_local_.format.current = FFESTP_formattypeNone;
- break;
- }
- i = FFESTR_formatlD;
- break;
-
- case FFESTR_formatS:
- switch (ffestb_local_.format.current)
- {
- case FFESTP_formattypeS:
- ffestb_local_.format.current = FFESTP_formattypeSS;
- break;
-
- default:
- ffestb_local_.format.current = FFESTP_formattypeNone;
- break;
- }
- i = FFESTR_formatlS;
- break;
-
- case FFESTR_formatP:
- switch (ffestb_local_.format.current)
- {
- case FFESTP_formattypeS:
- ffestb_local_.format.current = FFESTP_formattypeSP;
- break;
-
- default:
- ffestb_local_.format.current = FFESTP_formattypeNone;
- break;
- }
- i = FFESTR_formatlP;
- break;
-
- case FFESTR_formatR:
- switch (ffestb_local_.format.current)
- {
- case FFESTP_formattypeT:
- ffestb_local_.format.current = FFESTP_formattypeTR;
- break;
-
- default:
- ffestb_local_.format.current = FFESTP_formattypeNone;
- break;
- }
- i = FFESTR_formatlR;
- break;
-
- case FFESTR_formatZ:
- switch (ffestb_local_.format.current)
- {
- case FFESTP_formattypeB:
- ffestb_local_.format.current = FFESTP_formattypeBZ;
- break;
-
- default:
- ffestb_local_.format.current = FFESTP_formattypeNone;
- break;
- }
- i = FFESTR_formatlZ;
- break;
-
- case FFESTR_formatN:
- switch (ffestb_local_.format.current)
- {
- case FFESTP_formattypeE:
- ffestb_local_.format.current = FFESTP_formattypeEN;
- break;
-
- case FFESTP_formattypeB:
- ffestb_local_.format.current = FFESTP_formattypeBN;
- break;
-
- default:
- ffestb_local_.format.current = FFESTP_formattypeNone;
- break;
- }
- i = FFESTR_formatlN;
- break;
-
- default:
- if (ffestb_local_.format.current != FFESTP_formattypeH)
- ffestb_local_.format.current = FFESTP_formattypeNone;
- split_pea = FALSE; /* Go ahead and let the P be in the party. */
- p = strpbrk (ffelex_token_text (t), "0123456789");
- if (p == NULL)
- i = ffelex_token_length (t);
- else
- i = p - ffelex_token_text (t);
- }
-
- if (split_pea)
- {
- ffestb_subr_R1001_append_p_ ();
- ffestb_local_.format.t = ffelex_token_use (t);
- ffestb_local_.format.sign = FALSE;
- ffestb_local_.format.pre.present = FALSE;
- ffestb_local_.format.pre.rtexpr = FALSE;
- ffestb_local_.format.pre.t = NULL;
- ffestb_local_.format.pre.u.unsigned_val = 1;
- }
-
- p = ffelex_token_text (t) + i;
- if (*p == '\0')
- return (ffelexHandler) ffestb_R10015_;
- if (! ISDIGIT (*p))
- {
- ffestb_local_.format.current = FFESTP_formattypeNone;
- p = strpbrk (p, "0123456789");
- if (p == NULL)
- return (ffelexHandler) ffestb_R10015_;
- i = p - ffelex_token_text (t); /* Collect digits anyway. */
- }
- ffestb_local_.format.post.present = TRUE;
- ffestb_local_.format.post.rtexpr = FALSE;
- ffestb_local_.format.post.t = ffelex_token_number_from_names (t, i);
- ffestb_local_.format.post.u.unsigned_val
- = strtoul (ffelex_token_text (ffestb_local_.format.post.t), NULL, 10);
- p += ffelex_token_length (ffestb_local_.format.post.t);
- i += ffelex_token_length (ffestb_local_.format.post.t);
- if (*p == '\0')
- return (ffelexHandler) ffestb_R10016_;
- ffesta_ffebad_1p (FFEBAD_FORMAT_TEXT_IN_NUMBER, t, i, NULL);
- return (ffelexHandler) ffestb_R10016_;
-
- default:
- ffestb_local_.format.post.present = FALSE;
- ffestb_local_.format.post.rtexpr = FALSE;
- ffestb_local_.format.post.t = NULL;
- ffestb_local_.format.post.u.unsigned_val = 1;
- return (ffelexHandler) ffestb_R10016_ (t);
- }
-}
-
-/* ffestb_R10016_ -- [[+/-] NUMBER] NAMES NUMBER
-
- return ffestb_R10016_; // to lexer
-
- Expect a PERIOD here. Maybe find a NUMBER to append to the current
- number, in which case return to this state. Maybe find a NAMES to switch
- from a kP descriptor to a new descriptor (else the NAMES is spurious),
- in which case generator the P item and go to state _4_. Anything
- else, pass token on to state _8_. */
-
-static ffelexHandler
-ffestb_R10016_ (ffelexToken t)
-{
- ffeTokenLength i;
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typePERIOD:
- return (ffelexHandler) ffestb_R10017_;
-
- case FFELEX_typeNUMBER:
- assert (ffestb_local_.format.post.present);
- ffesta_confirmed ();
- if (ffestb_local_.format.post.rtexpr)
- {
- ffebad_start (FFEBAD_FORMAT_SPURIOUS_NUMBER);
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- return (ffelexHandler) ffestb_R10016_;
- }
- for (i = ffelex_token_length (t) + 1; i > 0; --i)
- ffestb_local_.format.post.u.unsigned_val *= 10;
- ffestb_local_.format.post.u.unsigned_val += strtoul (ffelex_token_text (t),
- NULL, 10);
- return (ffelexHandler) ffestb_R10016_;
-
- case FFELEX_typeNAMES:
- ffesta_confirmed (); /* NUMBER " " NAMES invalid elsewhere. */
- if (ffestb_local_.format.current != FFESTP_formattypeP)
- {
- ffesta_ffebad_1t (FFEBAD_FORMAT_TEXT_IN_NUMBER, t);
- return (ffelexHandler) ffestb_R10016_;
- }
- ffestb_subr_R1001_append_p_ ();
- ffestb_local_.format.sign = FALSE;
- ffestb_local_.format.pre = ffestb_local_.format.post;
- return (ffelexHandler) ffestb_R10014_ (t);
-
- default:
- ffestb_local_.format.dot.present = FALSE;
- ffestb_local_.format.dot.rtexpr = FALSE;
- ffestb_local_.format.dot.t = NULL;
- ffestb_local_.format.dot.u.unsigned_val = 1;
- return (ffelexHandler) ffestb_R10018_ (t);
- }
-}
-
-/* ffestb_R10017_ -- [[+/-] NUMBER] NAMES NUMBER PERIOD
-
- return ffestb_R10017_; // to lexer
-
- Here we've gotten the period following the edit descriptor.
- We expect either a NUMBER, for the dot value, or something else, which
- probably means we're not even close to being in a real FORMAT statement. */
-
-static ffelexHandler
-ffestb_R10017_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeOPEN_ANGLE:
- ffestb_local_.format.dot.t = ffelex_token_use (t);
- ffelex_set_names_pure (FALSE);
- if (!ffesta_seen_first_exec && !ffestb_local_.format.complained)
- {
- ffestb_local_.format.complained = TRUE;
- ffebad_start (FFEBAD_FORMAT_EXPR_SPEC);
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextFORMAT, (ffeexprCallback) ffestb_R100117_);
-
- case FFELEX_typeNUMBER:
- ffestb_local_.format.dot.present = TRUE;
- ffestb_local_.format.dot.rtexpr = FALSE;
- ffestb_local_.format.dot.t = ffelex_token_use (t);
- ffestb_local_.format.dot.u.unsigned_val
- = strtoul (ffelex_token_text (t), NULL, 10);
- return (ffelexHandler) ffestb_R10018_;
-
- default:
- ffelex_token_kill (ffestb_local_.format.t);
- if (ffestb_local_.format.pre.present)
- ffelex_token_kill (ffestb_local_.format.pre.t);
- if (ffestb_local_.format.post.present)
- ffelex_token_kill (ffestb_local_.format.post.t);
- ffesta_ffebad_1t (FFEBAD_FORMAT_MISSING_DOT, t);
- ffestt_formatlist_kill (ffestb_local_.format.f);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero);
- }
-}
-
-/* ffestb_R10018_ -- [[+/-] NUMBER] NAMES NUMBER PERIOD NUMBER
-
- return ffestb_R10018_; // to lexer
-
- Expect a NAMES here, which must begin with "E" to be valid. Maybe find a
- NUMBER to append to the current number, in which case return to this state.
- Anything else, pass token on to state _10_. */
-
-static ffelexHandler
-ffestb_R10018_ (ffelexToken t)
-{
- ffeTokenLength i;
- const char *p;
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNUMBER:
- assert (ffestb_local_.format.dot.present);
- ffesta_confirmed ();
- if (ffestb_local_.format.dot.rtexpr)
- {
- ffebad_start (FFEBAD_FORMAT_SPURIOUS_NUMBER);
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- return (ffelexHandler) ffestb_R10018_;
- }
- for (i = ffelex_token_length (t) + 1; i > 0; --i)
- ffestb_local_.format.dot.u.unsigned_val *= 10;
- ffestb_local_.format.dot.u.unsigned_val += strtoul (ffelex_token_text (t),
- NULL, 10);
- return (ffelexHandler) ffestb_R10018_;
-
- case FFELEX_typeNAMES:
- if (!ffesrc_char_match_init (*(p = ffelex_token_text (t)), 'E', 'e'))
- {
- ffesta_ffebad_1t (FFEBAD_FORMAT_TEXT_IN_NUMBER, t);
- return (ffelexHandler) ffestb_R10018_;
- }
- if (*++p == '\0')
- return (ffelexHandler) ffestb_R10019_; /* Go get NUMBER. */
- i = 1;
- if (! ISDIGIT (*p))
- {
- ffesta_ffebad_1p (FFEBAD_FORMAT_TEXT_IN_NUMBER, t, 1, NULL);
- return (ffelexHandler) ffestb_R10018_;
- }
- ffestb_local_.format.exp.present = TRUE;
- ffestb_local_.format.exp.rtexpr = FALSE;
- ffestb_local_.format.exp.t = ffelex_token_number_from_names (t, i);
- ffestb_local_.format.exp.u.unsigned_val
- = strtoul (ffelex_token_text (ffestb_local_.format.exp.t), NULL, 10);
- p += ffelex_token_length (ffestb_local_.format.exp.t);
- i += ffelex_token_length (ffestb_local_.format.exp.t);
- if (*p == '\0')
- return (ffelexHandler) ffestb_R100110_;
- ffesta_ffebad_1p (FFEBAD_FORMAT_TEXT_IN_NUMBER, t, i, NULL);
- return (ffelexHandler) ffestb_R100110_;
-
- default:
- ffestb_local_.format.exp.present = FALSE;
- ffestb_local_.format.exp.rtexpr = FALSE;
- ffestb_local_.format.exp.t = NULL;
- ffestb_local_.format.exp.u.unsigned_val = 1;
- return (ffelexHandler) ffestb_R100110_ (t);
- }
-}
-
-/* ffestb_R10019_ -- [[+/-] NUMBER] NAMES NUMBER PERIOD NUMBER "E"
-
- return ffestb_R10019_; // to lexer
-
- Here we've gotten the "E" following the edit descriptor.
- We expect either a NUMBER, for the exponent value, or something else. */
-
-static ffelexHandler
-ffestb_R10019_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeOPEN_ANGLE:
- ffestb_local_.format.exp.t = ffelex_token_use (t);
- ffelex_set_names_pure (FALSE);
- if (!ffesta_seen_first_exec && !ffestb_local_.format.complained)
- {
- ffestb_local_.format.complained = TRUE;
- ffebad_start (FFEBAD_FORMAT_EXPR_SPEC);
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextFORMAT, (ffeexprCallback) ffestb_R100118_);
-
- case FFELEX_typeNUMBER:
- ffestb_local_.format.exp.present = TRUE;
- ffestb_local_.format.exp.rtexpr = FALSE;
- ffestb_local_.format.exp.t = ffelex_token_use (t);
- ffestb_local_.format.exp.u.unsigned_val
- = strtoul (ffelex_token_text (t), NULL, 10);
- return (ffelexHandler) ffestb_R100110_;
-
- default:
- ffelex_token_kill (ffestb_local_.format.t);
- if (ffestb_local_.format.pre.present)
- ffelex_token_kill (ffestb_local_.format.pre.t);
- if (ffestb_local_.format.post.present)
- ffelex_token_kill (ffestb_local_.format.post.t);
- if (ffestb_local_.format.dot.present)
- ffelex_token_kill (ffestb_local_.format.dot.t);
- ffesta_ffebad_1t (FFEBAD_FORMAT_MISSING_EXP, t);
- ffestt_formatlist_kill (ffestb_local_.format.f);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero);
- }
-}
-
-/* ffestb_R100110_ -- [[+/-] NUMBER] NAMES NUMBER [PERIOD NUMBER ["E" NUMBER]]
-
- return ffestb_R100110_; // to lexer
-
- Maybe find a NUMBER to append to the current number, in which case return
- to this state. Anything else, handle current descriptor, then pass token
- on to state _10_. */
-
-static ffelexHandler
-ffestb_R100110_ (ffelexToken t)
-{
- ffeTokenLength i;
- enum expect
- {
- required,
- optional,
- disallowed
- };
- ffebad err;
- enum expect pre;
- enum expect post;
- enum expect dot;
- enum expect exp;
- bool R1005;
- ffesttFormatList f;
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNUMBER:
- assert (ffestb_local_.format.exp.present);
- ffesta_confirmed ();
- if (ffestb_local_.format.exp.rtexpr)
- {
- ffebad_start (FFEBAD_FORMAT_SPURIOUS_NUMBER);
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- return (ffelexHandler) ffestb_R100110_;
- }
- for (i = ffelex_token_length (t) + 1; i > 0; --i)
- ffestb_local_.format.exp.u.unsigned_val *= 10;
- ffestb_local_.format.exp.u.unsigned_val += strtoul (ffelex_token_text (t),
- NULL, 10);
- return (ffelexHandler) ffestb_R100110_;
-
- default:
- if (ffestb_local_.format.sign
- && (ffestb_local_.format.current != FFESTP_formattypeP)
- && (ffestb_local_.format.current != FFESTP_formattypeH))
- {
- ffebad_start (FFEBAD_FORMAT_SPURIOUS_SIGN);
- ffebad_here (0, ffelex_token_where_line (ffestb_local_.format.pre.t),
- ffelex_token_where_column (ffestb_local_.format.pre.t));
- ffebad_finish ();
- ffestb_local_.format.pre.u.unsigned_val
- = (ffestb_local_.format.pre.u.signed_val < 0)
- ? -ffestb_local_.format.pre.u.signed_val
- : ffestb_local_.format.pre.u.signed_val;
- }
- switch (ffestb_local_.format.current)
- {
- case FFESTP_formattypeI:
- err = FFEBAD_FORMAT_BAD_I_SPEC;
- pre = optional;
- post = required;
- dot = optional;
- exp = disallowed;
- R1005 = TRUE;
- break;
-
- case FFESTP_formattypeB:
- err = FFEBAD_FORMAT_BAD_B_SPEC;
- pre = optional;
- post = required;
- dot = optional;
- exp = disallowed;
- R1005 = TRUE;
- break;
-
- case FFESTP_formattypeO:
- err = FFEBAD_FORMAT_BAD_O_SPEC;
- pre = optional;
- post = required;
- dot = optional;
- exp = disallowed;
- R1005 = TRUE;
- break;
-
- case FFESTP_formattypeZ:
- err = FFEBAD_FORMAT_BAD_Z_SPEC;
- pre = optional;
- post = required;
- dot = optional;
- exp = disallowed;
- R1005 = TRUE;
- break;
-
- case FFESTP_formattypeF:
- err = FFEBAD_FORMAT_BAD_F_SPEC;
- pre = optional;
- post = required;
- dot = required;
- exp = disallowed;
- R1005 = TRUE;
- break;
-
- case FFESTP_formattypeE:
- err = FFEBAD_FORMAT_BAD_E_SPEC;
- pre = optional;
- post = required;
- dot = required;
- exp = optional;
- R1005 = TRUE;
- break;
-
- case FFESTP_formattypeEN:
- err = FFEBAD_FORMAT_BAD_EN_SPEC;
- pre = optional;
- post = required;
- dot = required;
- exp = optional;
- R1005 = TRUE;
- break;
-
- case FFESTP_formattypeG:
- err = FFEBAD_FORMAT_BAD_G_SPEC;
- pre = optional;
- post = required;
- dot = required;
- exp = optional;
- R1005 = TRUE;
- break;
-
- case FFESTP_formattypeL:
- err = FFEBAD_FORMAT_BAD_L_SPEC;
- pre = optional;
- post = required;
- dot = disallowed;
- exp = disallowed;
- R1005 = TRUE;
- break;
-
- case FFESTP_formattypeA:
- err = FFEBAD_FORMAT_BAD_A_SPEC;
- pre = optional;
- post = optional;
- dot = disallowed;
- exp = disallowed;
- R1005 = TRUE;
- break;
-
- case FFESTP_formattypeD:
- err = FFEBAD_FORMAT_BAD_D_SPEC;
- pre = optional;
- post = required;
- dot = required;
- exp = disallowed;
- R1005 = TRUE;
- break;
-
- case FFESTP_formattypeQ:
- err = FFEBAD_FORMAT_BAD_Q_SPEC;
- pre = disallowed;
- post = disallowed;
- dot = disallowed;
- exp = disallowed;
- R1005 = FALSE;
- break;
-
- case FFESTP_formattypeDOLLAR:
- err = FFEBAD_FORMAT_BAD_DOLLAR_SPEC;
- pre = disallowed;
- post = disallowed;
- dot = disallowed;
- exp = disallowed;
- R1005 = FALSE;
- break;
-
- case FFESTP_formattypeP:
- err = FFEBAD_FORMAT_BAD_P_SPEC;
- pre = required;
- post = disallowed;
- dot = disallowed;
- exp = disallowed;
- R1005 = FALSE;
- break;
-
- case FFESTP_formattypeT:
- err = FFEBAD_FORMAT_BAD_T_SPEC;
- pre = disallowed;
- post = required;
- dot = disallowed;
- exp = disallowed;
- R1005 = FALSE;
- break;
-
- case FFESTP_formattypeTL:
- err = FFEBAD_FORMAT_BAD_TL_SPEC;
- pre = disallowed;
- post = required;
- dot = disallowed;
- exp = disallowed;
- R1005 = FALSE;
- break;
-
- case FFESTP_formattypeTR:
- err = FFEBAD_FORMAT_BAD_TR_SPEC;
- pre = disallowed;
- post = required;
- dot = disallowed;
- exp = disallowed;
- R1005 = FALSE;
- break;
-
- case FFESTP_formattypeX:
- err = FFEBAD_FORMAT_BAD_X_SPEC;
- pre = ffe_is_pedantic() ? required : optional;
- post = disallowed;
- dot = disallowed;
- exp = disallowed;
- R1005 = FALSE;
- break;
-
- case FFESTP_formattypeS:
- err = FFEBAD_FORMAT_BAD_S_SPEC;
- pre = disallowed;
- post = disallowed;
- dot = disallowed;
- exp = disallowed;
- R1005 = FALSE;
- break;
-
- case FFESTP_formattypeSP:
- err = FFEBAD_FORMAT_BAD_SP_SPEC;
- pre = disallowed;
- post = disallowed;
- dot = disallowed;
- exp = disallowed;
- R1005 = FALSE;
- break;
-
- case FFESTP_formattypeSS:
- err = FFEBAD_FORMAT_BAD_SS_SPEC;
- pre = disallowed;
- post = disallowed;
- dot = disallowed;
- exp = disallowed;
- R1005 = FALSE;
- break;
-
- case FFESTP_formattypeBN:
- err = FFEBAD_FORMAT_BAD_BN_SPEC;
- pre = disallowed;
- post = disallowed;
- dot = disallowed;
- exp = disallowed;
- R1005 = FALSE;
- break;
-
- case FFESTP_formattypeBZ:
- err = FFEBAD_FORMAT_BAD_BZ_SPEC;
- pre = disallowed;
- post = disallowed;
- dot = disallowed;
- exp = disallowed;
- R1005 = FALSE;
- break;
-
- case FFESTP_formattypeH: /* Definitely an error, make sure of
- it. */
- err = FFEBAD_FORMAT_BAD_H_SPEC;
- pre = ffestb_local_.format.pre.present ? disallowed : required;
- post = disallowed;
- dot = disallowed;
- exp = disallowed;
- R1005 = FALSE;
- break;
-
- case FFESTP_formattypeNone:
- ffesta_ffebad_1t (FFEBAD_FORMAT_BAD_SPEC,
- ffestb_local_.format.t);
-
- clean_up_to_11_: /* :::::::::::::::::::: */
-
- ffelex_token_kill (ffestb_local_.format.t);
- if (ffestb_local_.format.pre.present)
- ffelex_token_kill (ffestb_local_.format.pre.t);
- if (ffestb_local_.format.post.present)
- ffelex_token_kill (ffestb_local_.format.post.t);
- if (ffestb_local_.format.dot.present)
- ffelex_token_kill (ffestb_local_.format.dot.t);
- if (ffestb_local_.format.exp.present)
- ffelex_token_kill (ffestb_local_.format.exp.t);
- return (ffelexHandler) ffestb_R100111_ (t);
-
- default:
- assert ("bad format item" == NULL);
- err = FFEBAD_FORMAT_BAD_H_SPEC;
- pre = disallowed;
- post = disallowed;
- dot = disallowed;
- exp = disallowed;
- R1005 = FALSE;
- break;
- }
- if (((pre == disallowed) && ffestb_local_.format.pre.present)
- || ((pre == required) && !ffestb_local_.format.pre.present))
- {
- ffesta_ffebad_1t (err, (pre == required)
- ? ffestb_local_.format.t : ffestb_local_.format.pre.t);
- goto clean_up_to_11_; /* :::::::::::::::::::: */
- }
- if (((post == disallowed) && ffestb_local_.format.post.present)
- || ((post == required) && !ffestb_local_.format.post.present))
- {
- ffesta_ffebad_1t (err, (post == required)
- ? ffestb_local_.format.t : ffestb_local_.format.post.t);
- goto clean_up_to_11_; /* :::::::::::::::::::: */
- }
- if (((dot == disallowed) && ffestb_local_.format.dot.present)
- || ((dot == required) && !ffestb_local_.format.dot.present))
- {
- ffesta_ffebad_1t (err, (dot == required)
- ? ffestb_local_.format.t : ffestb_local_.format.dot.t);
- goto clean_up_to_11_; /* :::::::::::::::::::: */
- }
- if (((exp == disallowed) && ffestb_local_.format.exp.present)
- || ((exp == required) && !ffestb_local_.format.exp.present))
- {
- ffesta_ffebad_1t (err, (exp == required)
- ? ffestb_local_.format.t : ffestb_local_.format.exp.t);
- goto clean_up_to_11_; /* :::::::::::::::::::: */
- }
- f = ffestt_formatlist_append (ffestb_local_.format.f);
- f->type = ffestb_local_.format.current;
- f->t = ffestb_local_.format.t;
- if (R1005)
- {
- f->u.R1005.R1004 = ffestb_local_.format.pre;
- f->u.R1005.R1006 = ffestb_local_.format.post;
- f->u.R1005.R1007_or_R1008 = ffestb_local_.format.dot;
- f->u.R1005.R1009 = ffestb_local_.format.exp;
- }
- else
- /* Must be R1010. */
- {
- if (pre == disallowed)
- f->u.R1010.val = ffestb_local_.format.post;
- else
- f->u.R1010.val = ffestb_local_.format.pre;
- }
- return (ffelexHandler) ffestb_R100111_ (t);
- }
-}
-
-/* ffestb_R100111_ -- edit-descriptor
-
- return ffestb_R100111_; // to lexer
-
- Expect a COMMA, CLOSE_PAREN, CLOSE_ARRAY, COLON, COLONCOLON, SLASH, or
- CONCAT, or complain about missing comma. */
-
-static ffelexHandler
-ffestb_R100111_ (ffelexToken t)
-{
- ffesttFormatList f;
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- return (ffelexHandler) ffestb_R10012_;
-
- case FFELEX_typeCOLON:
- case FFELEX_typeCOLONCOLON:
- case FFELEX_typeSLASH:
- case FFELEX_typeCONCAT:
- return (ffelexHandler) ffestb_R10012_ (t);
-
- case FFELEX_typeCLOSE_PAREN:
- f = ffestb_local_.format.f->u.root.parent;
- if (f == NULL)
- return (ffelexHandler) ffestb_R100114_;
- ffestb_local_.format.f = f->next;
- return (ffelexHandler) ffestb_R100111_;
-
- case FFELEX_typeCLOSE_ARRAY: /* "/)". */
- f = ffestt_formatlist_append (ffestb_local_.format.f);
- f->type = FFESTP_formattypeSLASH;
- f->t = ffelex_token_use (t);
- f->u.R1010.val.present = FALSE;
- f->u.R1010.val.rtexpr = FALSE;
- f->u.R1010.val.t = NULL;
- f->u.R1010.val.u.unsigned_val = 1;
- f = ffestb_local_.format.f->u.root.parent;
- if (f == NULL)
- return (ffelexHandler) ffestb_R100114_;
- ffestb_local_.format.f = f->next;
- return (ffelexHandler) ffestb_R100111_;
-
- case FFELEX_typeOPEN_ANGLE:
- case FFELEX_typeDOLLAR:
- case FFELEX_typeNUMBER:
- case FFELEX_typeOPEN_PAREN:
- case FFELEX_typeOPEN_ARRAY:
- case FFELEX_typeQUOTE:
- case FFELEX_typeAPOSTROPHE:
- case FFELEX_typeNAMES:
- ffesta_ffebad_1t (FFEBAD_FORMAT_MISSING_COMMA, t);
- return (ffelexHandler) ffestb_R10012_ (t);
-
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- ffesta_ffebad_1t (FFEBAD_FORMAT_MISSING_PAREN, t);
- for (f = ffestb_local_.format.f;
- f->u.root.parent != NULL;
- f = f->u.root.parent->next)
- ;
- ffestb_local_.format.f = f;
- return (ffelexHandler) ffestb_R100114_ (t);
-
- default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FORMAT", t);
- ffestt_formatlist_kill (ffestb_local_.format.f);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero);
- }
-}
-
-/* ffestb_R100112_ -- COLON, COLONCOLON, SLASH, OPEN_ARRAY, or CONCAT
-
- return ffestb_R100112_; // to lexer
-
- Like _11_ except the COMMA is optional. */
-
-static ffelexHandler
-ffestb_R100112_ (ffelexToken t)
-{
- ffesttFormatList f;
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- return (ffelexHandler) ffestb_R10012_;
-
- case FFELEX_typeCOLON:
- case FFELEX_typeCOLONCOLON:
- case FFELEX_typeSLASH:
- case FFELEX_typeCONCAT:
- case FFELEX_typeOPEN_ANGLE:
- case FFELEX_typeNAMES:
- case FFELEX_typeDOLLAR:
- case FFELEX_typeNUMBER:
- case FFELEX_typeOPEN_PAREN:
- case FFELEX_typeOPEN_ARRAY:
- case FFELEX_typeQUOTE:
- case FFELEX_typeAPOSTROPHE:
- case FFELEX_typePLUS:
- case FFELEX_typeMINUS:
- return (ffelexHandler) ffestb_R10012_ (t);
-
- case FFELEX_typeCLOSE_PAREN:
- f = ffestb_local_.format.f->u.root.parent;
- if (f == NULL)
- return (ffelexHandler) ffestb_R100114_;
- ffestb_local_.format.f = f->next;
- return (ffelexHandler) ffestb_R100111_;
-
- case FFELEX_typeCLOSE_ARRAY: /* "/)". */
- f = ffestt_formatlist_append (ffestb_local_.format.f);
- f->type = FFESTP_formattypeSLASH;
- f->t = ffelex_token_use (t);
- f->u.R1010.val.present = FALSE;
- f->u.R1010.val.rtexpr = FALSE;
- f->u.R1010.val.t = NULL;
- f->u.R1010.val.u.unsigned_val = 1;
- f = ffestb_local_.format.f->u.root.parent;
- if (f == NULL)
- return (ffelexHandler) ffestb_R100114_;
- ffestb_local_.format.f = f->next;
- return (ffelexHandler) ffestb_R100111_;
-
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- ffesta_ffebad_1t (FFEBAD_FORMAT_MISSING_PAREN, t);
- for (f = ffestb_local_.format.f;
- f->u.root.parent != NULL;
- f = f->u.root.parent->next)
- ;
- ffestb_local_.format.f = f;
- return (ffelexHandler) ffestb_R100114_ (t);
-
- default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FORMAT", t);
- ffestt_formatlist_kill (ffestb_local_.format.f);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero);
- }
-}
-
-/* ffestb_R100113_ -- Handle CHARACTER token.
-
- return ffestb_R100113_; // to lexer
-
- Append the format item to the list, go to _11_. */
-
-static ffelexHandler
-ffestb_R100113_ (ffelexToken t)
-{
- ffesttFormatList f;
-
- assert (ffelex_token_type (t) == FFELEX_typeCHARACTER);
-
- if (ffe_is_pedantic_not_90 () && (ffelex_token_length (t) == 0))
- {
- ffebad_start (FFEBAD_NULL_CHAR_CONST);
- ffebad_here (0, ffelex_token_where_line (t),
- ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- f = ffestt_formatlist_append (ffestb_local_.format.f);
- f->type = FFESTP_formattypeR1016;
- f->t = ffelex_token_use (t);
- return (ffelexHandler) ffestb_R100111_;
-}
-
-/* ffestb_R100114_ -- "FORMAT" OPEN_PAREN format-item-list CLOSE_PAREN
-
- return ffestb_R100114_; // to lexer
-
- Handle EOS/SEMICOLON or something else. */
-
-static ffelexHandler
-ffestb_R100114_ (ffelexToken t)
-{
- ffelex_set_names_pure (FALSE);
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited () && !ffestb_local_.format.complained)
- ffestc_R1001 (ffestb_local_.format.f);
- ffestt_formatlist_kill (ffestb_local_.format.f);
- return (ffelexHandler) ffesta_zero (t);
-
- default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FORMAT", t);
- ffestt_formatlist_kill (ffestb_local_.format.f);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero);
- }
-}
-
-/* ffestb_R100115_ -- OPEN_ANGLE expr
-
- (ffestb_R100115_) // to expression handler
-
- Handle expression prior to the edit descriptor. */
-
-static ffelexHandler
-ffestb_R100115_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCLOSE_ANGLE:
- ffestb_local_.format.pre.present = TRUE;
- ffestb_local_.format.pre.rtexpr = TRUE;
- ffestb_local_.format.pre.u.expr = expr;
- ffelex_set_names_pure (TRUE);
- return (ffelexHandler) ffestb_R10014_;
-
- default:
- ffelex_token_kill (ffestb_local_.format.pre.t);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FORMAT", t);
- ffestt_formatlist_kill (ffestb_local_.format.f);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero);
- }
-}
-
-/* ffestb_R100116_ -- "[n]X" OPEN_ANGLE expr
-
- (ffestb_R100116_) // to expression handler
-
- Handle expression after the edit descriptor. */
-
-static ffelexHandler
-ffestb_R100116_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCLOSE_ANGLE:
- ffestb_local_.format.post.present = TRUE;
- ffestb_local_.format.post.rtexpr = TRUE;
- ffestb_local_.format.post.u.expr = expr;
- ffelex_set_names_pure (TRUE);
- return (ffelexHandler) ffestb_R10016_;
-
- default:
- ffelex_token_kill (ffestb_local_.format.t);
- ffelex_token_kill (ffestb_local_.format.post.t);
- if (ffestb_local_.format.pre.present)
- ffelex_token_kill (ffestb_local_.format.pre.t);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FORMAT", t);
- ffestt_formatlist_kill (ffestb_local_.format.f);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero);
- }
-}
-
-/* ffestb_R100117_ -- "[n]X[n]." OPEN_ANGLE expr
-
- (ffestb_R100117_) // to expression handler
-
- Handle expression after the PERIOD. */
-
-static ffelexHandler
-ffestb_R100117_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCLOSE_ANGLE:
- ffestb_local_.format.dot.present = TRUE;
- ffestb_local_.format.dot.rtexpr = TRUE;
- ffestb_local_.format.dot.u.expr = expr;
- ffelex_set_names_pure (TRUE);
- return (ffelexHandler) ffestb_R10018_;
-
- default:
- ffelex_token_kill (ffestb_local_.format.t);
- ffelex_token_kill (ffestb_local_.format.dot.t);
- if (ffestb_local_.format.pre.present)
- ffelex_token_kill (ffestb_local_.format.pre.t);
- if (ffestb_local_.format.post.present)
- ffelex_token_kill (ffestb_local_.format.post.t);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FORMAT", t);
- ffestt_formatlist_kill (ffestb_local_.format.f);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero);
- }
-}
-
-/* ffestb_R100118_ -- "[n]X[n].[n]E" OPEN_ANGLE expr
-
- (ffestb_R100118_) // to expression handler
-
- Handle expression after the "E". */
-
-static ffelexHandler
-ffestb_R100118_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCLOSE_ANGLE:
- ffestb_local_.format.exp.present = TRUE;
- ffestb_local_.format.exp.rtexpr = TRUE;
- ffestb_local_.format.exp.u.expr = expr;
- ffelex_set_names_pure (TRUE);
- return (ffelexHandler) ffestb_R100110_;
-
- default:
- ffelex_token_kill (ffestb_local_.format.t);
- ffelex_token_kill (ffestb_local_.format.exp.t);
- if (ffestb_local_.format.pre.present)
- ffelex_token_kill (ffestb_local_.format.pre.t);
- if (ffestb_local_.format.post.present)
- ffelex_token_kill (ffestb_local_.format.post.t);
- if (ffestb_local_.format.dot.present)
- ffelex_token_kill (ffestb_local_.format.dot.t);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FORMAT", t);
- ffestt_formatlist_kill (ffestb_local_.format.f);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero);
- }
-}
-
-/* ffestb_R1107 -- Parse the USE statement
-
- return ffestb_R1107; // to lexer
-
- Make sure the statement has a valid form for the USE statement.
- If it does, implement the statement. */
-
-#if FFESTR_F90
-ffelexHandler
-ffestb_R1107 (ffelexToken t)
-{
- ffeTokenLength i;
- const char *p;
-
- switch (ffelex_token_type (ffesta_tokens[0]))
- {
- case FFELEX_typeNAME:
- if (ffesta_first_kw != FFESTR_firstUSE)
- goto bad_0; /* :::::::::::::::::::: */
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- break;
-
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
-
- default:
- goto bad_0; /* :::::::::::::::::::: */
- }
- ffesta_confirmed ();
- ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_R11071_;
-
- case FFELEX_typeNAMES:
- if (ffesta_first_kw != FFESTR_firstUSE)
- goto bad_0; /* :::::::::::::::::::: */
- p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlUSE);
- if (!ffesrc_is_name_init (*p))
- goto bad_i; /* :::::::::::::::::::: */
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
-
- default:
- goto bad_1; /* :::::::::::::::::::: */
-
- case FFELEX_typeCOMMA:
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- break;
- }
- ffesta_confirmed ();
- ffesta_tokens[1]
- = ffelex_token_name_from_names (ffesta_tokens[0], i, 0);
- return (ffelexHandler) ffestb_R11071_ (t);
-
- default:
- goto bad_0; /* :::::::::::::::::::: */
- }
-
-bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "USE", ffesta_tokens[0]);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-
-bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "USE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero); /* Invalid second token. */
-
-bad_i: /* :::::::::::::::::::: */
- ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "USE", ffesta_tokens[0], i, t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R11071_ -- "USE" NAME
-
- return ffestb_R11071_; // to lexer
-
- Make sure the statement has a valid form for the USE statement. If it
- does, implement the statement. */
-
-static ffelexHandler
-ffestb_R11071_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- if (!ffesta_is_inhibited ())
- {
- ffestc_R1107_start (ffesta_tokens[1], FALSE);
- ffestc_R1107_finish ();
- }
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffesta_zero (t);
-
- case FFELEX_typeCOMMA:
- return (ffelexHandler) ffestb_R11072_;
-
- default:
- break;
- }
-
- ffelex_token_kill (ffesta_tokens[1]);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "USE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R11072_ -- "USE" NAME COMMA
-
- return ffestb_R11072_; // to lexer
-
- Make sure the statement has a valid form for the USE statement. If it
- does, implement the statement. */
-
-static ffelexHandler
-ffestb_R11072_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- ffesta_tokens[2] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_R11073_;
-
- default:
- break;
- }
-
- ffelex_token_kill (ffesta_tokens[1]);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "USE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R11073_ -- "USE" NAME COMMA NAME
-
- return ffestb_R11073_; // to lexer
-
- Make sure the statement has a valid form for the USE statement. If it
- does, implement the statement. */
-
-static ffelexHandler
-ffestb_R11073_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOLON:
- if (ffestr_other (ffesta_tokens[2]) != FFESTR_otherONLY)
- break;
- if (!ffesta_is_inhibited ())
- ffestc_R1107_start (ffesta_tokens[1], TRUE);
- ffelex_token_kill (ffesta_tokens[1]);
- ffelex_token_kill (ffesta_tokens[2]);
- return (ffelexHandler) ffestb_R11074_;
-
- case FFELEX_typePOINTS:
- if (!ffesta_is_inhibited ())
- ffestc_R1107_start (ffesta_tokens[1], FALSE);
- ffelex_token_kill (ffesta_tokens[1]);
- ffesta_tokens[1] = ffesta_tokens[2];
- return (ffelexHandler) ffestb_R110711_;
-
- default:
- break;
- }
-
- ffelex_token_kill (ffesta_tokens[1]);
- ffelex_token_kill (ffesta_tokens[2]);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "USE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R11074_ -- "USE" NAME COMMA "ONLY" COLON
-
- return ffestb_R11074_; // to lexer
-
- Make sure the statement has a valid form for the USE statement. If it
- does, implement the statement. */
-
-static ffelexHandler
-ffestb_R11074_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_R11075_;
-
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- if (!ffesta_is_inhibited ())
- ffestc_R1107_finish ();
- return (ffelexHandler) ffesta_zero (t);
-
- default:
- break;
- }
-
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "USE", t);
- ffestc_R1107_finish ();
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R11075_ -- "USE" NAME COMMA "ONLY" COLON NAME
-
- return ffestb_R11075_; // to lexer
-
- Make sure the statement has a valid form for the USE statement. If it
- does, implement the statement. */
-
-static ffelexHandler
-ffestb_R11075_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- if (!ffesta_is_inhibited ())
- {
- ffestc_R1107_item (NULL, ffesta_tokens[1]);
- ffestc_R1107_finish ();
- }
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffesta_zero (t);
-
- case FFELEX_typeCOMMA:
- if (!ffesta_is_inhibited ())
- ffestc_R1107_item (NULL, ffesta_tokens[1]);
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffestb_R11078_;
-
- case FFELEX_typePOINTS:
- return (ffelexHandler) ffestb_R11076_;
-
- default:
- break;
- }
-
- ffelex_token_kill (ffesta_tokens[1]);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "USE", t);
- ffestc_R1107_finish ();
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R11076_ -- "USE" NAME COMMA "ONLY" COLON NAME POINTS
-
- return ffestb_R11076_; // to lexer
-
- Make sure the statement has a valid form for the USE statement. If it
- does, implement the statement. */
-
-static ffelexHandler
-ffestb_R11076_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- if (!ffesta_is_inhibited ())
- ffestc_R1107_item (ffesta_tokens[1], t);
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffestb_R11077_;
-
- default:
- break;
- }
-
- ffelex_token_kill (ffesta_tokens[1]);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "USE", t);
- ffestc_R1107_finish ();
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R11077_ -- "USE" NAME COMMA "ONLY" COLON NAME POINTS NAME
-
- return ffestb_R11077_; // to lexer
-
- Make sure the statement has a valid form for the USE statement. If it
- does, implement the statement. */
-
-static ffelexHandler
-ffestb_R11077_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- if (!ffesta_is_inhibited ())
- ffestc_R1107_finish ();
- return (ffelexHandler) ffesta_zero (t);
-
- case FFELEX_typeCOMMA:
- return (ffelexHandler) ffestb_R11078_;
-
- default:
- break;
- }
-
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "USE", t);
- ffestc_R1107_finish ();
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R11078_ -- "USE" NAME COMMA "ONLY" COLON NAME POINTS NAME COMMA
-
- return ffestb_R11078_; // to lexer
-
- Make sure the statement has a valid form for the USE statement. If it
- does, implement the statement. */
-
-static ffelexHandler
-ffestb_R11078_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_R11075_;
-
- default:
- break;
- }
-
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "USE", t);
- ffestc_R1107_finish ();
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R11079_ -- "USE" NAME COMMA
-
- return ffestb_R11079_; // to lexer
-
- Make sure the statement has a valid form for the USE statement. If it
- does, implement the statement. */
-
-static ffelexHandler
-ffestb_R11079_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_R110710_;
-
- default:
- break;
- }
-
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "USE", t);
- ffestc_R1107_finish ();
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R110710_ -- "USE" NAME COMMA NAME
-
- return ffestb_R110710_; // to lexer
-
- Make sure the statement has a valid form for the USE statement. If it
- does, implement the statement. */
-
-static ffelexHandler
-ffestb_R110710_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typePOINTS:
- return (ffelexHandler) ffestb_R110711_;
-
- default:
- break;
- }
-
- ffelex_token_kill (ffesta_tokens[1]);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "USE", t);
- ffestc_R1107_finish ();
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R110711_ -- "USE" NAME COMMA NAME POINTS
-
- return ffestb_R110711_; // to lexer
-
- Make sure the statement has a valid form for the USE statement. If it
- does, implement the statement. */
-
-static ffelexHandler
-ffestb_R110711_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- if (!ffesta_is_inhibited ())
- ffestc_R1107_item (ffesta_tokens[1], t);
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffestb_R110712_;
-
- default:
- break;
- }
-
- ffelex_token_kill (ffesta_tokens[1]);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "USE", t);
- ffestc_R1107_finish ();
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R110712_ -- "USE" NAME COMMA NAME POINTS NAME
-
- return ffestb_R110712_; // to lexer
-
- Make sure the statement has a valid form for the USE statement. If it
- does, implement the statement. */
-
-static ffelexHandler
-ffestb_R110712_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- if (!ffesta_is_inhibited ())
- ffestc_R1107_finish ();
- return (ffelexHandler) ffesta_zero (t);
-
- case FFELEX_typeCOMMA:
- return (ffelexHandler) ffestb_R11079_;
-
- default:
- break;
- }
-
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "USE", t);
- ffestc_R1107_finish ();
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-#endif
-/* ffestb_R1202 -- Parse the INTERFACE statement
-
- return ffestb_R1202; // to lexer
-
- Make sure the statement has a valid form for the INTERFACE statement.
- If it does, implement the statement.
-
- 15-May-90 JCB 1.1
- Allow INTERFACE by itself; missed this
- valid form when originally doing syntactic analysis code. */
-
-#if FFESTR_F90
-ffelexHandler
-ffestb_R1202 (ffelexToken t)
-{
- ffeTokenLength i;
- const char *p;
-
- switch (ffelex_token_type (ffesta_tokens[0]))
- {
- case FFELEX_typeNAME:
- if (ffesta_first_kw != FFESTR_firstINTERFACE)
- goto bad_0; /* :::::::::::::::::::: */
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- break;
-
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- ffestc_R1202 (FFESTP_definedoperatorNone, NULL);
- return (ffelexHandler) ffesta_zero (t);
-
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
-
- default:
- goto bad_1; /* :::::::::::::::::::: */
- }
-
- ffesta_confirmed ();
- switch (ffesta_second_kw)
- {
- case FFESTR_secondOPERATOR:
- ffestb_local_.interface.operator = FFESTP_definedoperatorOPERATOR;
- break;
-
- case FFESTR_secondASSIGNMENT:
- ffestb_local_.interface.operator = FFESTP_definedoperatorASSIGNMENT;
- break;
-
- default:
- ffestb_local_.interface.operator = FFESTP_definedoperatorNone;
- break;
- }
- ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_R12021_;
-
- case FFELEX_typeNAMES:
- p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlINTERFACE);
- switch (ffesta_first_kw)
- {
- case FFESTR_firstINTERFACEOPERATOR:
- if (*(ffelex_token_text (ffesta_tokens[0])
- + FFESTR_firstlINTERFACEOPERATOR) == '\0')
- ffestb_local_.interface.operator
- = FFESTP_definedoperatorOPERATOR;
- break;
-
- case FFESTR_firstINTERFACEASSGNMNT:
- if (*(ffelex_token_text (ffesta_tokens[0])
- + FFESTR_firstlINTERFACEASSGNMNT) == '\0')
- ffestb_local_.interface.operator
- = FFESTP_definedoperatorASSIGNMENT;
- break;
-
- case FFESTR_firstINTERFACE:
- ffestb_local_.interface.operator = FFESTP_definedoperatorNone;
- break;
-
- default:
- goto bad_0; /* :::::::::::::::::::: */
- }
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
-
- default:
- goto bad_1; /* :::::::::::::::::::: */
-
- case FFELEX_typeOPEN_PAREN:
- case FFELEX_typeOPEN_ARRAY: /* Sigh. */
- break;
-
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- if (*p == '\0')
- {
- if (!ffesta_is_inhibited ())
- ffestc_R1202 (FFESTP_definedoperatorNone, NULL);
- return (ffelexHandler) ffesta_zero (t);
- }
- break;
- }
- if (!ffesrc_is_name_init (*p))
- goto bad_i; /* :::::::::::::::::::: */
- ffesta_tokens[1] = ffelex_token_name_from_names (ffesta_tokens[0], i, 0);
- return (ffelexHandler) ffestb_R12021_ (t);
-
- default:
- goto bad_0; /* :::::::::::::::::::: */
- }
-
-bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INTERFACE", ffesta_tokens[0]);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-
-bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INTERFACE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero); /* Invalid second token. */
-
-bad_i: /* :::::::::::::::::::: */
- ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "INTERFACE", ffesta_tokens[0], i, t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R12021_ -- "INTERFACE" NAME
-
- return ffestb_R12021_; // to lexer
-
- Make sure the statement has a valid form for the INTERFACE statement. If
- it does, implement the statement. */
-
-static ffelexHandler
-ffestb_R12021_ (ffelexToken t)
-{
- ffestb_local_.interface.slash = TRUE; /* Slash follows open paren. */
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- if (!ffesta_is_inhibited ())
- ffestc_R1202 (FFESTP_definedoperatorNone, ffesta_tokens[1]);
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffesta_zero (t);
-
- case FFELEX_typeOPEN_PAREN:
- ffestb_local_.interface.slash = FALSE; /* Slash doesn't follow. */
- /* Fall through. */
- case FFELEX_typeOPEN_ARRAY:
- switch (ffestb_local_.interface.operator)
- {
- case FFESTP_definedoperatorNone:
- break;
-
- case FFESTP_definedoperatorOPERATOR:
- ffestb_local_.interface.assignment = FALSE;
- return (ffelexHandler) ffestb_R12022_;
-
- case FFESTP_definedoperatorASSIGNMENT:
- ffestb_local_.interface.assignment = TRUE;
- return (ffelexHandler) ffestb_R12022_;
-
- default:
- assert (FALSE);
- }
- break;
-
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- break;
-
- default:
- break;
- }
-
- ffelex_token_kill (ffesta_tokens[1]);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INTERFACE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R12022_ -- "INTERFACE" "OPERATOR/ASSIGNMENT" OPEN_PAREN
-
- return ffestb_R12022_; // to lexer
-
- Make sure the statement has a valid form for the INTERFACE statement. If
- it does, implement the statement. */
-
-static ffelexHandler
-ffestb_R12022_ (ffelexToken t)
-{
- ffesta_tokens[2] = ffelex_token_use (t);
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typePERIOD:
- if (ffestb_local_.interface.slash)
- break;
- return (ffelexHandler) ffestb_R12023_;
-
- case FFELEX_typePOWER:
- if (ffestb_local_.interface.slash)
- break;
- ffestb_local_.interface.operator = FFESTP_definedoperatorPOWER;
- return (ffelexHandler) ffestb_R12025_;
-
- case FFELEX_typeASTERISK:
- if (ffestb_local_.interface.slash)
- break;
- ffestb_local_.interface.operator = FFESTP_definedoperatorMULT;
- return (ffelexHandler) ffestb_R12025_;
-
- case FFELEX_typePLUS:
- if (ffestb_local_.interface.slash)
- break;
- ffestb_local_.interface.operator = FFESTP_definedoperatorADD;
- return (ffelexHandler) ffestb_R12025_;
-
- case FFELEX_typeCONCAT:
- if (ffestb_local_.interface.slash)
- break;
- ffestb_local_.interface.operator = FFESTP_definedoperatorCONCAT;
- return (ffelexHandler) ffestb_R12025_;
-
- case FFELEX_typeSLASH:
- if (ffestb_local_.interface.slash)
- {
- ffestb_local_.interface.operator = FFESTP_definedoperatorCONCAT;
- return (ffelexHandler) ffestb_R12025_;
- }
- ffestb_local_.interface.operator = FFESTP_definedoperatorDIVIDE;
- return (ffelexHandler) ffestb_R12025_;
-
- case FFELEX_typeMINUS:
- if (ffestb_local_.interface.slash)
- break;
- ffestb_local_.interface.operator = FFESTP_definedoperatorSUBTRACT;
- return (ffelexHandler) ffestb_R12025_;
-
- case FFELEX_typeREL_EQ:
- if (ffestb_local_.interface.slash)
- break;
- ffestb_local_.interface.operator = FFESTP_definedoperatorEQ;
- return (ffelexHandler) ffestb_R12025_;
-
- case FFELEX_typeREL_NE:
- if (ffestb_local_.interface.slash)
- break;
- ffestb_local_.interface.operator = FFESTP_definedoperatorNE;
- return (ffelexHandler) ffestb_R12025_;
-
- case FFELEX_typeOPEN_ANGLE:
- if (ffestb_local_.interface.slash)
- break;
- ffestb_local_.interface.operator = FFESTP_definedoperatorLT;
- return (ffelexHandler) ffestb_R12025_;
-
- case FFELEX_typeREL_LE:
- if (ffestb_local_.interface.slash)
- break;
- ffestb_local_.interface.operator = FFESTP_definedoperatorLE;
- return (ffelexHandler) ffestb_R12025_;
-
- case FFELEX_typeCLOSE_ANGLE:
- if (ffestb_local_.interface.slash)
- break;
- ffestb_local_.interface.operator = FFESTP_definedoperatorGT;
- return (ffelexHandler) ffestb_R12025_;
-
- case FFELEX_typeREL_GE:
- if (ffestb_local_.interface.slash)
- break;
- ffestb_local_.interface.operator = FFESTP_definedoperatorGE;
- return (ffelexHandler) ffestb_R12025_;
-
- case FFELEX_typeEQUALS:
- if (ffestb_local_.interface.slash)
- {
- ffestb_local_.interface.operator = FFESTP_definedoperatorNE;
- return (ffelexHandler) ffestb_R12025_;
- }
- ffestb_local_.interface.operator = FFESTP_definedoperatorASSIGNMENT;
- return (ffelexHandler) ffestb_R12025_;
-
- case FFELEX_typeCLOSE_ARRAY:
- if (!ffestb_local_.interface.slash)
- {
- ffestb_local_.interface.operator = FFESTP_definedoperatorDIVIDE;
- return (ffelexHandler) ffestb_R12026_;
- }
- ffestb_local_.interface.operator = FFESTP_definedoperatorCONCAT;
- return (ffelexHandler) ffestb_R12026_;
-
- case FFELEX_typeCLOSE_PAREN:
- if (!ffestb_local_.interface.slash)
- break;
- ffestb_local_.interface.operator = FFESTP_definedoperatorDIVIDE;
- return (ffelexHandler) ffestb_R12026_;
-
- default:
- break;
- }
-
- ffelex_token_kill (ffesta_tokens[1]);
- ffelex_token_kill (ffesta_tokens[2]);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INTERFACE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R12023_ -- "INTERFACE" NAME OPEN_PAREN PERIOD
-
- return ffestb_R12023_; // to lexer
-
- Make sure the statement has a valid form for the INTERFACE statement. If
- it does, implement the statement. */
-
-static ffelexHandler
-ffestb_R12023_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- ffelex_token_kill (ffesta_tokens[2]);
- ffesta_tokens[2] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_R12024_;
-
- default:
- break;
- }
-
- ffelex_token_kill (ffesta_tokens[1]);
- ffelex_token_kill (ffesta_tokens[2]);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INTERFACE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R12024_ -- "INTERFACE" NAME OPEN_PAREN PERIOD NAME
-
- return ffestb_R12024_; // to lexer
-
- Make sure the statement has a valid form for the INTERFACE statement. If
- it does, implement the statement. */
-
-static ffelexHandler
-ffestb_R12024_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typePERIOD:
- return (ffelexHandler) ffestb_R12025_;
-
- default:
- break;
- }
-
- ffelex_token_kill (ffesta_tokens[1]);
- ffelex_token_kill (ffesta_tokens[2]);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INTERFACE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R12025_ -- "INTERFACE" NAME OPEN_PAREN operator
-
- return ffestb_R12025_; // to lexer
-
- Make sure the statement has a valid form for the INTERFACE statement. If
- it does, implement the statement. */
-
-static ffelexHandler
-ffestb_R12025_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCLOSE_PAREN:
- return (ffelexHandler) ffestb_R12026_;
-
- default:
- break;
- }
-
- ffelex_token_kill (ffesta_tokens[1]);
- ffelex_token_kill (ffesta_tokens[2]);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INTERFACE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R12026_ -- "INTERFACE" NAME OPEN_PAREN operator CLOSE_PAREN
-
- return ffestb_R12026_; // to lexer
-
- Make sure the statement has a valid form for the INTERFACE statement. If
- it does, implement the statement. */
-
-static ffelexHandler
-ffestb_R12026_ (ffelexToken t)
-{
- const char *p;
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- if (ffestb_local_.interface.assignment
- && (ffestb_local_.interface.operator
- != FFESTP_definedoperatorASSIGNMENT))
- {
- ffebad_start (FFEBAD_INTERFACE_ASSIGNMENT);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[1]),
- ffelex_token_where_column (ffesta_tokens[1]));
- ffebad_here (1, ffelex_token_where_line (ffesta_tokens[2]),
- ffelex_token_where_column (ffesta_tokens[2]));
- ffebad_finish ();
- }
- switch (ffelex_token_type (ffesta_tokens[2]))
- {
- case FFELEX_typeNAME:
- switch (ffestr_other (ffesta_tokens[2]))
- {
- case FFESTR_otherNOT:
- if (!ffesta_is_inhibited ())
- ffestc_R1202 (FFESTP_definedoperatorNOT, NULL);
- break;
-
- case FFESTR_otherAND:
- if (!ffesta_is_inhibited ())
- ffestc_R1202 (FFESTP_definedoperatorAND, NULL);
- break;
-
- case FFESTR_otherOR:
- if (!ffesta_is_inhibited ())
- ffestc_R1202 (FFESTP_definedoperatorOR, NULL);
- break;
-
- case FFESTR_otherEQV:
- if (!ffesta_is_inhibited ())
- ffestc_R1202 (FFESTP_definedoperatorEQV, NULL);
- break;
-
- case FFESTR_otherNEQV:
- if (!ffesta_is_inhibited ())
- ffestc_R1202 (FFESTP_definedoperatorNEQV, NULL);
- break;
-
- case FFESTR_otherEQ:
- if (!ffesta_is_inhibited ())
- ffestc_R1202 (FFESTP_definedoperatorEQ, NULL);
- break;
-
- case FFESTR_otherNE:
- if (!ffesta_is_inhibited ())
- ffestc_R1202 (FFESTP_definedoperatorNE, NULL);
- break;
-
- case FFESTR_otherLT:
- if (!ffesta_is_inhibited ())
- ffestc_R1202 (FFESTP_definedoperatorLT, NULL);
- break;
-
- case FFESTR_otherLE:
- if (!ffesta_is_inhibited ())
- ffestc_R1202 (FFESTP_definedoperatorLE, NULL);
- break;
-
- case FFESTR_otherGT:
- if (!ffesta_is_inhibited ())
- ffestc_R1202 (FFESTP_definedoperatorGT, NULL);
- break;
-
- case FFESTR_otherGE:
- if (!ffesta_is_inhibited ())
- ffestc_R1202 (FFESTP_definedoperatorGE, NULL);
- break;
-
- default:
- for (p = ffelex_token_text (ffesta_tokens[2]); *p != '\0'; ++p)
- {
- if (! ISALPHA (*p))
- {
- ffelex_token_kill (ffesta_tokens[1]);
- ffelex_token_kill (ffesta_tokens[2]);
- ffesta_ffebad_1t (FFEBAD_INTERFACE_NONLETTER,
- ffesta_tokens[2]);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero);
- }
- }
- if (!ffesta_is_inhibited ())
- ffestc_R1202 (FFESTP_definedoperatorOPERATOR,
- ffesta_tokens[2]);
- }
- break;
-
- case FFELEX_typeEQUALS:
- if (!ffestb_local_.interface.assignment
- && (ffestb_local_.interface.operator
- == FFESTP_definedoperatorASSIGNMENT))
- {
- ffebad_start (FFEBAD_INTERFACE_OPERATOR);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[1]),
- ffelex_token_where_column (ffesta_tokens[1]));
- ffebad_here (1, ffelex_token_where_line (ffesta_tokens[2]),
- ffelex_token_where_column (ffesta_tokens[2]));
- ffebad_finish ();
- }
- if (!ffesta_is_inhibited ())
- ffestc_R1202 (ffestb_local_.interface.operator, NULL);
- break;
-
- default:
- if (!ffesta_is_inhibited ())
- ffestc_R1202 (ffestb_local_.interface.operator, NULL);
- }
- ffelex_token_kill (ffesta_tokens[1]);
- ffelex_token_kill (ffesta_tokens[2]);
- return (ffelexHandler) ffesta_zero (t);
-
- default:
- break;
- }
-
- ffelex_token_kill (ffesta_tokens[1]);
- ffelex_token_kill (ffesta_tokens[2]);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INTERFACE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-#endif
-/* ffestb_S3P4 -- Parse the INCLUDE line
-
- return ffestb_S3P4; // to lexer
-
- Make sure the statement has a valid form for the INCLUDE line. If it
- does, implement the statement. */
-
-ffelexHandler
-ffestb_S3P4 (ffelexToken t)
-{
- ffeTokenLength i;
- const char *p;
- ffelexHandler next;
- ffelexToken nt;
- ffelexToken ut;
-
- switch (ffelex_token_type (ffesta_tokens[0]))
- {
- case FFELEX_typeNAME:
- if (ffesta_first_kw != FFESTR_firstINCLUDE)
- goto bad_0; /* :::::::::::::::::::: */
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNUMBER:
- case FFELEX_typeAPOSTROPHE:
- case FFELEX_typeQUOTE:
- break;
-
- default:
- goto bad_1; /* :::::::::::::::::::: */
- }
- ffesta_confirmed ();
- return (ffelexHandler) (*((ffelexHandler)
- ffeexpr_rhs (ffesta_output_pool, FFEEXPR_contextINCLUDE,
- (ffeexprCallback) ffestb_S3P41_)))
- (t);
-
- case FFELEX_typeNAMES:
- if (ffesta_first_kw != FFESTR_firstINCLUDE)
- goto bad_0; /* :::::::::::::::::::: */
- p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlINCLUDE);
- switch (ffelex_token_type (t))
- {
- default:
- goto bad_1; /* :::::::::::::::::::: */
-
- case FFELEX_typeAPOSTROPHE:
- case FFELEX_typeQUOTE:
- break;
- }
- ffesta_confirmed ();
- if (*p == '\0')
- return (ffelexHandler) (*((ffelexHandler)
- ffeexpr_rhs (ffesta_output_pool, FFEEXPR_contextINCLUDE,
- (ffeexprCallback) ffestb_S3P41_)))
- (t);
- if (! ISDIGIT (*p))
- goto bad_i; /* :::::::::::::::::::: */
- nt = ffelex_token_number_from_names (ffesta_tokens[0], i);
- p += ffelex_token_length (nt);
- i += ffelex_token_length (nt);
- if ((*p != '_') || (++i, *++p != '\0'))
- {
- ffelex_token_kill (nt);
- goto bad_i; /* :::::::::::::::::::: */
- }
- ut = ffelex_token_uscore_from_names (ffesta_tokens[0], i - 1);
- next = (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs
- (ffesta_output_pool, FFEEXPR_contextINCLUDE,
- (ffeexprCallback) ffestb_S3P41_)))
- (nt);
- ffelex_token_kill (nt);
- next = (ffelexHandler) (*next) (ut);
- ffelex_token_kill (ut);
- return (ffelexHandler) (*next) (t);
-
- default:
- goto bad_0; /* :::::::::::::::::::: */
- }
-
-bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INCLUDE", ffesta_tokens[0]);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-
-bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INCLUDE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero); /* Invalid second token. */
-
-bad_i: /* :::::::::::::::::::: */
- ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "INCLUDE", ffesta_tokens[0], i, t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_S3P41_ -- "INCLUDE" [NUMBER "_"] expr
-
- (ffestb_S3P41_) // to expression handler
-
- Make sure the next token is an EOS, but not a SEMICOLON. */
-
-static ffelexHandler
-ffestb_S3P41_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- if (expr == NULL)
- break;
- if (!ffesta_is_inhibited ())
- {
- if (ffe_is_pedantic ()
- && ((ffelex_token_type (t) == FFELEX_typeSEMICOLON)
- || ffesta_line_has_semicolons))
- {
- /* xgettext:no-c-format */
- ffebad_start_msg ("INCLUDE at %0 not the only statement on the source line", FFEBAD_severityWARNING);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_finish ();
- }
- ffestc_S3P4 (expr, ft);
- }
- return (ffelexHandler) ffesta_zero (t);
-
- default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INCLUDE", t);
- break;
- }
-
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_V012 -- Parse the MAP statement
-
- return ffestb_V012; // to lexer
-
- Make sure the statement has a valid form for the MAP statement. If
- it does, implement the statement. */
-
-#if FFESTR_VXT
-ffelexHandler
-ffestb_V012 (ffelexToken t)
-{
- const char *p;
- ffeTokenLength i;
-
- switch (ffelex_token_type (ffesta_tokens[0]))
- {
- case FFELEX_typeNAME:
- if (ffesta_first_kw != FFESTR_firstMAP)
- goto bad_0; /* :::::::::::::::::::: */
- break;
-
- case FFELEX_typeNAMES:
- if (ffesta_first_kw != FFESTR_firstMAP)
- goto bad_0; /* :::::::::::::::::::: */
- if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlMAP)
- {
- p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlMAP);
- goto bad_i; /* :::::::::::::::::::: */
- }
- break;
-
- default:
- goto bad_0; /* :::::::::::::::::::: */
- }
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- ffestc_V012 ();
- return (ffelexHandler) ffesta_zero (t);
-
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
-
- default:
- goto bad_1; /* :::::::::::::::::::: */
- }
-
-bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "MAP", ffesta_tokens[0]);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero); /* Invalid first token. */
-
-bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "MAP", t);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero); /* Invalid second token. */
-
-bad_i: /* :::::::::::::::::::: */
- ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "MAP", ffesta_tokens[0], i, t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-#endif
-/* ffestb_V014 -- Parse the VOLATILE statement
-
- return ffestb_V014; // to lexer
-
- Make sure the statement has a valid form for the VOLATILE statement. If it
- does, implement the statement. */
-
-ffelexHandler
-ffestb_V014 (ffelexToken t)
-{
- ffeTokenLength i;
- unsigned const char *p;
- ffelexToken nt;
- ffelexHandler next;
-
- switch (ffelex_token_type (ffesta_tokens[0]))
- {
- case FFELEX_typeNAME:
- if (ffesta_first_kw != FFESTR_firstVOLATILE)
- goto bad_0; /* :::::::::::::::::::: */
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- case FFELEX_typeCOMMA:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
-
- default:
- goto bad_1; /* :::::::::::::::::::: */
-
- case FFELEX_typeNAME:
- case FFELEX_typeSLASH:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- ffestc_V014_start ();
- return (ffelexHandler) ffestb_V0141_ (t);
-
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- ffestc_V014_start ();
- return (ffelexHandler) ffestb_V0141_;
- }
-
- case FFELEX_typeNAMES:
- if (ffesta_first_kw != FFESTR_firstVOLATILE)
- goto bad_0; /* :::::::::::::::::::: */
- p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlVOLATILE);
- switch (ffelex_token_type (t))
- {
- default:
- goto bad_1; /* :::::::::::::::::::: */
-
- case FFELEX_typeCOMMA:
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- break;
-
- case FFELEX_typeSLASH:
- ffesta_confirmed ();
- if (*p != '\0')
- goto bad_i; /* :::::::::::::::::::: */
- if (!ffesta_is_inhibited ())
- ffestc_V014_start ();
- return (ffelexHandler) ffestb_V0141_ (t);
-
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed ();
- if (*p != '\0')
- goto bad_i; /* :::::::::::::::::::: */
- if (!ffesta_is_inhibited ())
- ffestc_V014_start ();
- return (ffelexHandler) ffestb_V0141_;
- }
-
- /* Here, we have at least one char after "VOLATILE" and t is COMMA or
- EOS/SEMICOLON. */
-
- if (!ffesrc_is_name_init (*p))
- goto bad_i; /* :::::::::::::::::::: */
- nt = ffelex_token_name_from_names (ffesta_tokens[0], i, 0);
- if (!ffesta_is_inhibited ())
- ffestc_V014_start ();
- next = (ffelexHandler) ffestb_V0141_ (nt);
- ffelex_token_kill (nt);
- return (ffelexHandler) (*next) (t);
-
- default:
- goto bad_0; /* :::::::::::::::::::: */
- }
-
-bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "VOLATILE", ffesta_tokens[0]);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-
-bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "VOLATILE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero); /* Invalid second token. */
-
-bad_i: /* :::::::::::::::::::: */
- ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "VOLATILE", ffesta_tokens[0], i, t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_V0141_ -- "VOLATILE" [COLONCOLON]
-
- return ffestb_V0141_; // to lexer
-
- Handle NAME or SLASH. */
-
-static ffelexHandler
-ffestb_V0141_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- ffestb_local_.V014.is_cblock = FALSE;
- ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_V0144_;
-
- case FFELEX_typeSLASH:
- ffestb_local_.V014.is_cblock = TRUE;
- return (ffelexHandler) ffestb_V0142_;
-
- default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "VOLATILE", t);
- break;
- }
-
- if (!ffesta_is_inhibited ())
- ffestc_V014_finish ();
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_V0142_ -- "VOLATILE" [COLONCOLON] SLASH
-
- return ffestb_V0142_; // to lexer
-
- Handle NAME. */
-
-static ffelexHandler
-ffestb_V0142_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_V0143_;
-
- default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "VOLATILE", t);
- break;
- }
-
- if (!ffesta_is_inhibited ())
- ffestc_V014_finish ();
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_V0143_ -- "VOLATILE" [COLONCOLON] SLASH NAME
-
- return ffestb_V0143_; // to lexer
-
- Handle SLASH. */
-
-static ffelexHandler
-ffestb_V0143_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeSLASH:
- return (ffelexHandler) ffestb_V0144_;
-
- default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "VOLATILE", t);
- break;
- }
-
- if (!ffesta_is_inhibited ())
- ffestc_V014_finish ();
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_V0144_ -- "VOLATILE" [COLONCOLON] R523
-
- return ffestb_V0144_; // to lexer
-
- Handle COMMA or EOS/SEMICOLON. */
-
-static ffelexHandler
-ffestb_V0144_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- if (!ffesta_is_inhibited ())
- {
- if (ffestb_local_.V014.is_cblock)
- ffestc_V014_item_cblock (ffesta_tokens[1]);
- else
- ffestc_V014_item_object (ffesta_tokens[1]);
- }
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffestb_V0141_;
-
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- if (!ffesta_is_inhibited ())
- {
- if (ffestb_local_.V014.is_cblock)
- ffestc_V014_item_cblock (ffesta_tokens[1]);
- else
- ffestc_V014_item_object (ffesta_tokens[1]);
- ffestc_V014_finish ();
- }
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffesta_zero (t);
-
- default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "VOLATILE", t);
- break;
- }
-
- if (!ffesta_is_inhibited ())
- ffestc_V014_finish ();
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_V025 -- Parse the DEFINEFILE statement
-
- return ffestb_V025; // to lexer
-
- Make sure the statement has a valid form for the DEFINEFILE statement.
- If it does, implement the statement. */
-
-#if FFESTR_VXT
-ffelexHandler
-ffestb_V025 (ffelexToken t)
-{
- ffeTokenLength i;
- const char *p;
- ffelexToken nt;
- ffelexHandler next;
-
- ffestb_local_.V025.started = FALSE;
- switch (ffelex_token_type (ffesta_tokens[0]))
- {
- case FFELEX_typeNAME:
- switch (ffesta_first_kw)
- {
- case FFESTR_firstDEFINE:
- if ((ffelex_token_type (t) != FFELEX_typeNAME)
- || (ffesta_second_kw != FFESTR_secondFILE))
- goto bad_1; /* :::::::::::::::::::: */
- ffesta_confirmed ();
- return (ffelexHandler) ffestb_V0251_;
-
- case FFESTR_firstDEFINEFILE:
- return (ffelexHandler) ffestb_V0251_ (t);
-
- default:
- goto bad_0; /* :::::::::::::::::::: */
- }
-
- case FFELEX_typeNAMES:
- if (ffesta_first_kw != FFESTR_firstDEFINEFILE)
- goto bad_0; /* :::::::::::::::::::: */
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
-
- default:
- goto bad_1; /* :::::::::::::::::::: */
-
- case FFELEX_typeOPEN_PAREN:
- break;
- }
- p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlDEFINEFILE);
- if (ISDIGIT (*p))
- nt = ffelex_token_number_from_names (ffesta_tokens[0], i);
- else if (ffesrc_is_name_init (*p))
- nt = ffelex_token_name_from_names (ffesta_tokens[0], i, 0);
- else
- goto bad_i; /* :::::::::::::::::::: */
- next = (ffelexHandler) ffestb_V0251_ (nt);
- ffelex_token_kill (nt);
- return (ffelexHandler) (*next) (t);
-
- default:
- goto bad_0; /* :::::::::::::::::::: */
- }
-
-bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DEFINE FILE", ffesta_tokens[0]);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-
-bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DEFINE FILE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero); /* Invalid second token. */
-
-bad_i: /* :::::::::::::::::::: */
- ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "DEFINE FILE", ffesta_tokens[0], i, t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_V0251_ -- "DEFINEFILE" or "DEFINE" "FILE"
-
- return ffestb_V0251_; // to lexer
-
- Make sure the statement has a valid form for the DEFINEFILE statement. If it
- does, implement the statement. */
-
-static ffelexHandler
-ffestb_V0251_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- case FFELEX_typeNUMBER:
- if (ffelex_token_type (ffesta_tokens[0]) == FFELEX_typeNAME)
- ffesta_confirmed ();
- return (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextFILEUNIT_DF, (ffeexprCallback) ffestb_V0252_)))
- (t);
-
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- break;
-
- default:
- break;
- }
-
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DEFINE FILE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_V0252_ -- "DEFINEFILE" expr
-
- (ffestb_V0252_) // to expression handler
-
- Make sure the statement has a valid form for the DEFINEFILE statement. If
- it does, implement the statement. */
-
-static ffelexHandler
-ffestb_V0252_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeOPEN_PAREN:
- ffestb_local_.V025.u = expr;
- ffesta_tokens[1] = ffelex_token_use (ft);
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextFILENUM, (ffeexprCallback) ffestb_V0253_);
-
- default:
- break;
- }
-
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DEFINE FILE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_V0253_ -- "DEFINEFILE" expr OPEN_PAREN expr
-
- (ffestb_V0253_) // to expression handler
-
- Make sure the statement has a valid form for the DEFINEFILE statement. If
- it does, implement the statement. */
-
-static ffelexHandler
-ffestb_V0253_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- ffestb_local_.V025.m = expr;
- ffesta_tokens[2] = ffelex_token_use (ft);
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextFILENUM, (ffeexprCallback) ffestb_V0254_);
-
- default:
- break;
- }
-
- ffelex_token_kill (ffesta_tokens[1]);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DEFINE FILE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_V0254_ -- "DEFINEFILE" expr OPEN_PAREN expr COMMA expr
-
- (ffestb_V0254_) // to expression handler
-
- Make sure the statement has a valid form for the DEFINEFILE statement. If
- it does, implement the statement. */
-
-static ffelexHandler
-ffestb_V0254_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- ffestb_local_.V025.n = expr;
- ffesta_tokens[3] = ffelex_token_use (ft);
- return (ffelexHandler) ffestb_V0255_;
-
- default:
- break;
- }
-
- ffelex_token_kill (ffesta_tokens[1]);
- ffelex_token_kill (ffesta_tokens[2]);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DEFINE FILE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_V0255_ -- "DEFINEFILE" expr OPEN_PAREN expr COMMA expr COMMA
-
- return ffestb_V0255_; // to lexer
-
- Make sure the statement has a valid form for the DEFINEFILE statement. If
- it does, implement the statement. */
-
-static ffelexHandler
-ffestb_V0255_ (ffelexToken t)
-{
- const char *p;
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- p = ffelex_token_text (t);
- if (!ffesrc_char_match_init (*p, 'U', 'u') || (*++p != '\0'))
- break;
- return (ffelexHandler) ffestb_V0256_;
-
- default:
- break;
- }
-
- ffelex_token_kill (ffesta_tokens[1]);
- ffelex_token_kill (ffesta_tokens[2]);
- ffelex_token_kill (ffesta_tokens[3]);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DEFINE FILE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_V0256_ -- "DEFINEFILE" expr OPEN_PAREN expr COMMA expr COMMA "U"
-
- return ffestb_V0256_; // to lexer
-
- Make sure the statement has a valid form for the DEFINEFILE statement. If
- it does, implement the statement. */
-
-static ffelexHandler
-ffestb_V0256_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool,
- FFEEXPR_contextFILEASSOC,
- (ffeexprCallback) ffestb_V0257_);
-
- default:
- break;
- }
-
- ffelex_token_kill (ffesta_tokens[1]);
- ffelex_token_kill (ffesta_tokens[2]);
- ffelex_token_kill (ffesta_tokens[3]);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DEFINE FILE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_V0257_ -- "DEFINEFILE" expr OPEN_PAREN expr COMMA expr COMMA "U"
- COMMA expr
-
- (ffestb_V0257_) // to expression handler
-
- Make sure the statement has a valid form for the DEFINEFILE statement. If
- it does, implement the statement. */
-
-static ffelexHandler
-ffestb_V0257_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCLOSE_PAREN:
- ffestb_local_.V025.asv = expr;
- ffesta_tokens[4] = ffelex_token_use (ft);
- return (ffelexHandler) ffestb_V0258_;
-
- default:
- break;
- }
-
- ffelex_token_kill (ffesta_tokens[1]);
- ffelex_token_kill (ffesta_tokens[2]);
- ffelex_token_kill (ffesta_tokens[3]);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DEFINE FILE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_V0258_ -- "DEFINEFILE" expr OPEN_PAREN expr COMMA expr COMMA "U"
- COMMA expr CLOSE_PAREN
-
- return ffestb_V0258_; // to lexer
-
- Make sure the statement has a valid form for the DEFINEFILE statement. If
- it does, implement the statement. */
-
-static ffelexHandler
-ffestb_V0258_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- if (!ffestb_local_.V025.started)
- {
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- ffestc_V025_start ();
- ffestb_local_.V025.started = TRUE;
- }
- if (!ffesta_is_inhibited ())
- ffestc_V025_item (ffestb_local_.V025.u, ffesta_tokens[1],
- ffestb_local_.V025.m, ffesta_tokens[2],
- ffestb_local_.V025.n, ffesta_tokens[3],
- ffestb_local_.V025.asv, ffesta_tokens[4]);
- ffelex_token_kill (ffesta_tokens[1]);
- ffelex_token_kill (ffesta_tokens[2]);
- ffelex_token_kill (ffesta_tokens[3]);
- ffelex_token_kill (ffesta_tokens[4]);
- if (ffelex_token_type (t) == FFELEX_typeCOMMA)
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextFILEUNIT_DF, (ffeexprCallback) ffestb_V0252_);
- if (!ffesta_is_inhibited ())
- ffestc_V025_finish ();
- return (ffelexHandler) ffesta_zero (t);
-
- default:
- break;
- }
-
- ffelex_token_kill (ffesta_tokens[1]);
- ffelex_token_kill (ffesta_tokens[2]);
- ffelex_token_kill (ffesta_tokens[3]);
- ffelex_token_kill (ffesta_tokens[4]);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DEFINE FILE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-#endif
-/* ffestb_subr_kill_easy_ -- Kill I/O statement data structure
-
- ffestb_subr_kill_easy_();
-
- Kills all tokens in the I/O data structure. Assumes that they are
- overlaid with each other (union) in ffest_private.h and the typing
- and structure references assume (though not necessarily dangerous if
- FALSE) that INQUIRE has the most file elements. */
-
-#if FFESTB_KILL_EASY_
-static void
-ffestb_subr_kill_easy_ (ffestpInquireIx max)
-{
- ffestpInquireIx ix;
-
- for (ix = 0; ix < max; ++ix)
- {
- if (ffestp_file.inquire.inquire_spec[ix].kw_or_val_present)
- {
- if (ffestp_file.inquire.inquire_spec[ix].kw_present)
- ffelex_token_kill (ffestp_file.inquire.inquire_spec[ix].kw);
- if (ffestp_file.inquire.inquire_spec[ix].value_present)
- ffelex_token_kill (ffestp_file.inquire.inquire_spec[ix].value);
- }
- }
-}
-
-#endif
-/* ffestb_subr_kill_accept_ -- Kill ACCEPT statement data structure
-
- ffestb_subr_kill_accept_();
-
- Kills all tokens in the ACCEPT data structure. */
-
-#if !FFESTB_KILL_EASY_
-static void
-ffestb_subr_kill_accept_ ()
-{
- ffestpAcceptIx ix;
-
- for (ix = 0; ix < FFESTP_acceptix; ++ix)
- {
- if (ffestp_file.accept.accept_spec[ix].kw_or_val_present)
- {
- if (ffestp_file.accept.accept_spec[ix].kw_present)
- ffelex_token_kill (ffestp_file.accept.accept_spec[ix].kw);
- if (ffestp_file.accept.accept_spec[ix].value_present)
- ffelex_token_kill (ffestp_file.accept.accept_spec[ix].value);
- }
- }
-}
-
-#endif
-/* ffestb_subr_kill_beru_ -- Kill BACKSPACE/ENDFILE/REWIND/UNLOCK statement
- data structure
-
- ffestb_subr_kill_beru_();
-
- Kills all tokens in the BACKSPACE/ENDFILE/REWIND/UNLOCK data structure. */
-
-#if !FFESTB_KILL_EASY_
-static void
-ffestb_subr_kill_beru_ ()
-{
- ffestpBeruIx ix;
-
- for (ix = 0; ix < FFESTP_beruix; ++ix)
- {
- if (ffestp_file.beru.beru_spec[ix].kw_or_val_present)
- {
- if (ffestp_file.beru.beru_spec[ix].kw_present)
- ffelex_token_kill (ffestp_file.beru.beru_spec[ix].kw);
- if (ffestp_file.beru.beru_spec[ix].value_present)
- ffelex_token_kill (ffestp_file.beru.beru_spec[ix].value);
- }
- }
-}
-
-#endif
-/* ffestb_subr_kill_close_ -- Kill CLOSE statement data structure
-
- ffestb_subr_kill_close_();
-
- Kills all tokens in the CLOSE data structure. */
-
-#if !FFESTB_KILL_EASY_
-static void
-ffestb_subr_kill_close_ ()
-{
- ffestpCloseIx ix;
-
- for (ix = 0; ix < FFESTP_closeix; ++ix)
- {
- if (ffestp_file.close.close_spec[ix].kw_or_val_present)
- {
- if (ffestp_file.close.close_spec[ix].kw_present)
- ffelex_token_kill (ffestp_file.close.close_spec[ix].kw);
- if (ffestp_file.close.close_spec[ix].value_present)
- ffelex_token_kill (ffestp_file.close.close_spec[ix].value);
- }
- }
-}
-
-#endif
-/* ffestb_subr_kill_delete_ -- Kill DELETE statement data structure
-
- ffestb_subr_kill_delete_();
-
- Kills all tokens in the DELETE data structure. */
-
-#if !FFESTB_KILL_EASY_
-static void
-ffestb_subr_kill_delete_ ()
-{
- ffestpDeleteIx ix;
-
- for (ix = 0; ix < FFESTP_deleteix; ++ix)
- {
- if (ffestp_file.delete.delete_spec[ix].kw_or_val_present)
- {
- if (ffestp_file.delete.delete_spec[ix].kw_present)
- ffelex_token_kill (ffestp_file.delete.delete_spec[ix].kw);
- if (ffestp_file.delete.delete_spec[ix].value_present)
- ffelex_token_kill (ffestp_file.delete.delete_spec[ix].value);
- }
- }
-}
-
-#endif
-/* ffestb_subr_kill_inquire_ -- Kill INQUIRE statement data structure
-
- ffestb_subr_kill_inquire_();
-
- Kills all tokens in the INQUIRE data structure. */
-
-#if !FFESTB_KILL_EASY_
-static void
-ffestb_subr_kill_inquire_ ()
-{
- ffestpInquireIx ix;
-
- for (ix = 0; ix < FFESTP_inquireix; ++ix)
- {
- if (ffestp_file.inquire.inquire_spec[ix].kw_or_val_present)
- {
- if (ffestp_file.inquire.inquire_spec[ix].kw_present)
- ffelex_token_kill (ffestp_file.inquire.inquire_spec[ix].kw);
- if (ffestp_file.inquire.inquire_spec[ix].value_present)
- ffelex_token_kill (ffestp_file.inquire.inquire_spec[ix].value);
- }
- }
-}
-
-#endif
-/* ffestb_subr_kill_open_ -- Kill OPEN statement data structure
-
- ffestb_subr_kill_open_();
-
- Kills all tokens in the OPEN data structure. */
-
-#if !FFESTB_KILL_EASY_
-static void
-ffestb_subr_kill_open_ ()
-{
- ffestpOpenIx ix;
-
- for (ix = 0; ix < FFESTP_openix; ++ix)
- {
- if (ffestp_file.open.open_spec[ix].kw_or_val_present)
- {
- if (ffestp_file.open.open_spec[ix].kw_present)
- ffelex_token_kill (ffestp_file.open.open_spec[ix].kw);
- if (ffestp_file.open.open_spec[ix].value_present)
- ffelex_token_kill (ffestp_file.open.open_spec[ix].value);
- }
- }
-}
-
-#endif
-/* ffestb_subr_kill_print_ -- Kill PRINT statement data structure
-
- ffestb_subr_kill_print_();
-
- Kills all tokens in the PRINT data structure. */
-
-#if !FFESTB_KILL_EASY_
-static void
-ffestb_subr_kill_print_ ()
-{
- ffestpPrintIx ix;
-
- for (ix = 0; ix < FFESTP_printix; ++ix)
- {
- if (ffestp_file.print.print_spec[ix].kw_or_val_present)
- {
- if (ffestp_file.print.print_spec[ix].kw_present)
- ffelex_token_kill (ffestp_file.print.print_spec[ix].kw);
- if (ffestp_file.print.print_spec[ix].value_present)
- ffelex_token_kill (ffestp_file.print.print_spec[ix].value);
- }
- }
-}
-
-#endif
-/* ffestb_subr_kill_read_ -- Kill READ statement data structure
-
- ffestb_subr_kill_read_();
-
- Kills all tokens in the READ data structure. */
-
-#if !FFESTB_KILL_EASY_
-static void
-ffestb_subr_kill_read_ ()
-{
- ffestpReadIx ix;
-
- for (ix = 0; ix < FFESTP_readix; ++ix)
- {
- if (ffestp_file.read.read_spec[ix].kw_or_val_present)
- {
- if (ffestp_file.read.read_spec[ix].kw_present)
- ffelex_token_kill (ffestp_file.read.read_spec[ix].kw);
- if (ffestp_file.read.read_spec[ix].value_present)
- ffelex_token_kill (ffestp_file.read.read_spec[ix].value);
- }
- }
-}
-
-#endif
-/* ffestb_subr_kill_rewrite_ -- Kill REWRITE statement data structure
-
- ffestb_subr_kill_rewrite_();
-
- Kills all tokens in the REWRITE data structure. */
-
-#if !FFESTB_KILL_EASY_
-static void
-ffestb_subr_kill_rewrite_ ()
-{
- ffestpRewriteIx ix;
-
- for (ix = 0; ix < FFESTP_rewriteix; ++ix)
- {
- if (ffestp_file.rewrite.rewrite_spec[ix].kw_or_val_present)
- {
- if (ffestp_file.rewrite.rewrite_spec[ix].kw_present)
- ffelex_token_kill (ffestp_file.rewrite.rewrite_spec[ix].kw);
- if (ffestp_file.rewrite.rewrite_spec[ix].value_present)
- ffelex_token_kill (ffestp_file.rewrite.rewrite_spec[ix].value);
- }
- }
-}
-
-#endif
-/* ffestb_subr_kill_type_ -- Kill TYPE statement data structure
-
- ffestb_subr_kill_type_();
-
- Kills all tokens in the TYPE data structure. */
-
-#if !FFESTB_KILL_EASY_
-static void
-ffestb_subr_kill_type_ ()
-{
- ffestpTypeIx ix;
-
- for (ix = 0; ix < FFESTP_typeix; ++ix)
- {
- if (ffestp_file.type.type_spec[ix].kw_or_val_present)
- {
- if (ffestp_file.type.type_spec[ix].kw_present)
- ffelex_token_kill (ffestp_file.type.type_spec[ix].kw);
- if (ffestp_file.type.type_spec[ix].value_present)
- ffelex_token_kill (ffestp_file.type.type_spec[ix].value);
- }
- }
-}
-
-#endif
-/* ffestb_subr_kill_write_ -- Kill WRITE statement data structure
-
- ffestb_subr_kill_write_();
-
- Kills all tokens in the WRITE data structure. */
-
-#if !FFESTB_KILL_EASY_
-static void
-ffestb_subr_kill_write_ ()
-{
- ffestpWriteIx ix;
-
- for (ix = 0; ix < FFESTP_writeix; ++ix)
- {
- if (ffestp_file.write.write_spec[ix].kw_or_val_present)
- {
- if (ffestp_file.write.write_spec[ix].kw_present)
- ffelex_token_kill (ffestp_file.write.write_spec[ix].kw);
- if (ffestp_file.write.write_spec[ix].value_present)
- ffelex_token_kill (ffestp_file.write.write_spec[ix].value);
- }
- }
-}
-
-#endif
-/* ffestb_beru -- Parse the BACKSPACE/ENDFILE/REWIND/UNLOCK statement
-
- return ffestb_beru; // to lexer
-
- Make sure the statement has a valid form for the BACKSPACE/ENDFILE/REWIND/
- UNLOCK statement. If it does, implement the statement. */
-
-ffelexHandler
-ffestb_beru (ffelexToken t)
-{
- ffelexHandler next;
- ffestpBeruIx ix;
-
- switch (ffelex_token_type (ffesta_tokens[0]))
- {
- case FFELEX_typeNAME:
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
-
- case FFELEX_typeEQUALS:
- case FFELEX_typePOINTS:
- case FFELEX_typeCOLON:
- goto bad_1; /* :::::::::::::::::::: */
-
- case FFELEX_typeNAME:
- case FFELEX_typeNUMBER:
- ffesta_confirmed ();
- break;
-
- case FFELEX_typeOPEN_PAREN:
- for (ix = 0; ix < FFESTP_beruix; ++ix)
- ffestp_file.beru.beru_spec[ix].kw_or_val_present = FALSE;
- ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_beru2_;
-
- default:
- break;
- }
-
- for (ix = 0; ix < FFESTP_beruix; ++ix)
- ffestp_file.beru.beru_spec[ix].kw_or_val_present = FALSE;
- return (ffelexHandler) (*((ffelexHandler)
- ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextFILENUM,
- (ffeexprCallback) ffestb_beru1_)))
- (t);
-
- case FFELEX_typeNAMES:
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
-
- case FFELEX_typeEQUALS:
- case FFELEX_typePOINTS:
- case FFELEX_typeCOLON:
- goto bad_1; /* :::::::::::::::::::: */
-
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- break;
-
- case FFELEX_typeOPEN_PAREN:
- if (ffelex_token_length (ffesta_tokens[0])
- != ffestb_args.beru.len)
- break;
-
- for (ix = 0; ix < FFESTP_beruix; ++ix)
- ffestp_file.beru.beru_spec[ix].kw_or_val_present = FALSE;
- ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_beru2_;
-
- default:
- break;
- }
- for (ix = 0; ix < FFESTP_beruix; ++ix)
- ffestp_file.beru.beru_spec[ix].kw_or_val_present = FALSE;
- next = (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextFILENUM, (ffeexprCallback) ffestb_beru1_);
- next = (ffelexHandler) ffelex_splice_tokens (next, ffesta_tokens[0],
- ffestb_args.beru.len);
- if (next == NULL)
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero);
- return (ffelexHandler) (*next) (t);
-
- default:
- goto bad_0; /* :::::::::::::::::::: */
- }
-
-bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.beru.badname, ffesta_tokens[0]);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-
-bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.beru.badname, t);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero); /* Invalid second token. */
-}
-
-/* ffestb_beru1_ -- "BACKSPACE/ENDFILE/REWIND/UNLOCK" expr
-
- (ffestb_beru1_) // to expression handler
-
- Make sure the next token is an EOS or SEMICOLON. */
-
-static ffelexHandler
-ffestb_beru1_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- if (expr == NULL)
- break;
- ffesta_confirmed ();
- ffestp_file.beru.beru_spec[FFESTP_beruixUNIT].kw_or_val_present
- = TRUE;
- ffestp_file.beru.beru_spec[FFESTP_beruixUNIT].kw_present = FALSE;
- ffestp_file.beru.beru_spec[FFESTP_beruixUNIT].value_present = TRUE;
- ffestp_file.beru.beru_spec[FFESTP_beruixUNIT].value_is_label
- = FALSE;
- ffestp_file.beru.beru_spec[FFESTP_beruixUNIT].value
- = ffelex_token_use (ft);
- ffestp_file.beru.beru_spec[FFESTP_beruixUNIT].u.expr = expr;
- if (!ffesta_is_inhibited ())
- {
- switch (ffesta_first_kw)
- {
- case FFESTR_firstBACKSPACE:
- ffestc_R919 ();
- break;
-
- case FFESTR_firstENDFILE:
- case FFESTR_firstEND:
- ffestc_R920 ();
- break;
-
- case FFESTR_firstREWIND:
- ffestc_R921 ();
- break;
-
-#if FFESTR_VXT
- case FFESTR_firstUNLOCK:
- ffestc_V022 ();
- break;
-#endif
-
- default:
- assert (FALSE);
- }
- }
- ffestb_subr_kill_beru_ ();
- return (ffelexHandler) ffesta_zero (t);
-
- default:
- break;
- }
-
- ffestb_subr_kill_beru_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.beru.badname, t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_beru2_ -- "BACKSPACE/ENDFILE/REWIND/UNLOCK" OPEN_PAREN
-
- return ffestb_beru2_; // to lexer
-
- Handle expr construct (not NAME=expr construct) here. */
-
-static ffelexHandler
-ffestb_beru2_ (ffelexToken t)
-{
- ffelexToken nt;
- ffelexHandler next;
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- ffesta_tokens[2] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_beru3_;
-
- default:
- nt = ffesta_tokens[1];
- next = (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextFILENUMAMBIG, (ffeexprCallback) ffestb_beru4_)))
- (nt);
- ffelex_token_kill (nt);
- return (ffelexHandler) (*next) (t);
- }
-}
-
-/* ffestb_beru3_ -- "BACKSPACE/ENDFILE/REWIND/UNLOCK" OPEN_PAREN NAME
-
- return ffestb_beru3_; // to lexer
-
- If EQUALS here, go to states that handle it. Else, send NAME and this
- token thru expression handler. */
-
-static ffelexHandler
-ffestb_beru3_ (ffelexToken t)
-{
- ffelexHandler next;
- ffelexToken nt;
- ffelexToken ot;
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeEQUALS:
- ffelex_token_kill (ffesta_tokens[1]);
- nt = ffesta_tokens[2];
- next = (ffelexHandler) ffestb_beru5_ (nt);
- ffelex_token_kill (nt);
- return (ffelexHandler) (*next) (t);
-
- default:
- nt = ffesta_tokens[1];
- ot = ffesta_tokens[2];
- next = (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextFILENUMAMBIG, (ffeexprCallback) ffestb_beru4_)))
- (nt);
- ffelex_token_kill (nt);
- next = (ffelexHandler) (*next) (ot);
- ffelex_token_kill (ot);
- return (ffelexHandler) (*next) (t);
- }
-}
-
-/* ffestb_beru4_ -- "BACKSPACE/ENDFILE/REWIND/UNLOCK" OPEN_PAREN expr [CLOSE_PAREN]
-
- (ffestb_beru4_) // to expression handler
-
- Handle COMMA or EOS/SEMICOLON here.
-
- 15-Feb-91 JCB 1.2
- Now using new mechanism whereby expr comes back as opITEM if the
- expr is considered part (or all) of an I/O control list (and should
- be stripped of its outer opITEM node) or not if it is considered
- a plain unit number that happens to have been enclosed in parens.
- 26-Mar-90 JCB 1.1
- No longer expecting close-paren here because of constructs like
- BACKSPACE (5)+2, so now expecting either COMMA because it was a
- construct like BACKSPACE (5+2,... or EOS/SEMICOLON because it is like
- the former construct. Ah, the vagaries of Fortran. */
-
-static ffelexHandler
-ffestb_beru4_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- bool inlist;
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- case FFELEX_typeCLOSE_PAREN:
- if (expr == NULL)
- break;
- if (ffebld_op (expr) == FFEBLD_opITEM)
- {
- inlist = TRUE;
- expr = ffebld_head (expr);
- }
- else
- inlist = FALSE;
- ffestp_file.beru.beru_spec[FFESTP_beruixUNIT].kw_or_val_present
- = TRUE;
- ffestp_file.beru.beru_spec[FFESTP_beruixUNIT].kw_present = FALSE;
- ffestp_file.beru.beru_spec[FFESTP_beruixUNIT].value_present = TRUE;
- ffestp_file.beru.beru_spec[FFESTP_beruixUNIT].value_is_label
- = FALSE;
- ffestp_file.beru.beru_spec[FFESTP_beruixUNIT].value
- = ffelex_token_use (ft);
- ffestp_file.beru.beru_spec[FFESTP_beruixUNIT].u.expr = expr;
- if (inlist)
- return (ffelexHandler) ffestb_beru9_ (t);
- return (ffelexHandler) ffestb_beru10_ (t);
-
- default:
- break;
- }
-
- ffestb_subr_kill_beru_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.beru.badname, t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_beru5_ -- "BACKSPACE/ENDFILE/REWIND/UNLOCK" OPEN_PAREN [external-file-unit
- COMMA]
-
- return ffestb_beru5_; // to lexer
-
- Handle expr construct (not NAME=expr construct) here. */
-
-static ffelexHandler
-ffestb_beru5_ (ffelexToken t)
-{
- ffestrGenio kw;
-
- ffestb_local_.beru.label = FALSE;
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- kw = ffestr_genio (t);
- switch (kw)
- {
- case FFESTR_genioERR:
- ffestb_local_.beru.ix = FFESTP_beruixERR;
- ffestb_local_.beru.label = TRUE;
- break;
-
- case FFESTR_genioIOSTAT:
- ffestb_local_.beru.ix = FFESTP_beruixIOSTAT;
- ffestb_local_.beru.left = TRUE;
- ffestb_local_.beru.context = FFEEXPR_contextFILEINT;
- break;
-
- case FFESTR_genioUNIT:
- ffestb_local_.beru.ix = FFESTP_beruixUNIT;
- ffestb_local_.beru.left = FALSE;
- ffestb_local_.beru.context = FFEEXPR_contextFILENUM;
- break;
-
- default:
- goto bad; /* :::::::::::::::::::: */
- }
- if (ffestp_file.beru.beru_spec[ffestb_local_.beru.ix]
- .kw_or_val_present)
- break; /* Can't specify a keyword twice! */
- ffestp_file.beru.beru_spec[ffestb_local_.beru.ix]
- .kw_or_val_present = TRUE;
- ffestp_file.beru.beru_spec[ffestb_local_.beru.ix]
- .kw_present = TRUE;
- ffestp_file.beru.beru_spec[ffestb_local_.beru.ix]
- .value_present = FALSE;
- ffestp_file.beru.beru_spec[ffestb_local_.beru.ix].value_is_label
- = ffestb_local_.beru.label;
- ffestp_file.beru.beru_spec[ffestb_local_.beru.ix].kw
- = ffelex_token_use (t);
- return (ffelexHandler) ffestb_beru6_;
-
- default:
- break;
- }
-
-bad: /* :::::::::::::::::::: */
- ffestb_subr_kill_beru_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.beru.badname, t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_beru6_ -- "BACKSPACE/ENDFILE/REWIND/UNLOCK" OPEN_PAREN [external-file-unit
- COMMA] NAME
-
- return ffestb_beru6_; // to lexer
-
- Make sure EQUALS here, send next token to expression handler. */
-
-static ffelexHandler
-ffestb_beru6_ (ffelexToken t)
-{
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeEQUALS:
- ffesta_confirmed ();
- if (ffestb_local_.beru.label)
- return (ffelexHandler) ffestb_beru8_;
- if (ffestb_local_.beru.left)
- return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool,
- ffestb_local_.beru.context,
- (ffeexprCallback) ffestb_beru7_);
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- ffestb_local_.beru.context,
- (ffeexprCallback) ffestb_beru7_);
-
- default:
- break;
- }
-
- ffestb_subr_kill_beru_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.beru.badname, t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_beru7_ -- "BACKSPACE/ENDFILE/REWIND/UNLOCK" OPEN_PAREN ... NAME EQUALS expr
-
- (ffestb_beru7_) // to expression handler
-
- Handle COMMA or CLOSE_PAREN here. */
-
-static ffelexHandler
-ffestb_beru7_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- case FFELEX_typeCLOSE_PAREN:
- if (expr == NULL)
- break;
- ffestp_file.beru.beru_spec[ffestb_local_.beru.ix].value_present
- = TRUE;
- ffestp_file.beru.beru_spec[ffestb_local_.beru.ix].value
- = ffelex_token_use (ft);
- ffestp_file.beru.beru_spec[ffestb_local_.beru.ix].u.expr = expr;
- if (ffelex_token_type (t) == FFELEX_typeCOMMA)
- return (ffelexHandler) ffestb_beru5_;
- return (ffelexHandler) ffestb_beru10_;
-
- default:
- break;
- }
-
- ffestb_subr_kill_beru_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.beru.badname, t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_beru8_ -- "BACKSPACE/ENDFILE/REWIND/UNLOCK" OPEN_PAREN ... NAME EQUALS
-
- return ffestb_beru8_; // to lexer
-
- Handle NUMBER for label here. */
-
-static ffelexHandler
-ffestb_beru8_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNUMBER:
- ffestp_file.beru.beru_spec[ffestb_local_.beru.ix].value_present
- = TRUE;
- ffestp_file.beru.beru_spec[ffestb_local_.beru.ix].value
- = ffelex_token_use (t);
- return (ffelexHandler) ffestb_beru9_;
-
- default:
- break;
- }
-
- ffestb_subr_kill_beru_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.beru.badname, t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_beru9_ -- "BACKSPACE/ENDFILE/REWIND/UNLOCK" OPEN_PAREN ... NAME EQUALS
- NUMBER
-
- return ffestb_beru9_; // to lexer
-
- Handle COMMA or CLOSE_PAREN here. */
-
-static ffelexHandler
-ffestb_beru9_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- return (ffelexHandler) ffestb_beru5_;
-
- case FFELEX_typeCLOSE_PAREN:
- return (ffelexHandler) ffestb_beru10_;
-
- default:
- break;
- }
-
- ffestb_subr_kill_beru_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.beru.badname, t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_beru10_ -- "BACKSPACE/ENDFILE/REWIND/UNLOCK" OPEN_PAREN ... CLOSE_PAREN
-
- return ffestb_beru10_; // to lexer
-
- Handle EOS or SEMICOLON here. */
-
-static ffelexHandler
-ffestb_beru10_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- {
- switch (ffesta_first_kw)
- {
- case FFESTR_firstBACKSPACE:
- ffestc_R919 ();
- break;
-
- case FFESTR_firstENDFILE:
- case FFESTR_firstEND:
- ffestc_R920 ();
- break;
-
- case FFESTR_firstREWIND:
- ffestc_R921 ();
- break;
-
-#if FFESTR_VXT
- case FFESTR_firstUNLOCK:
- ffestc_V022 ();
- break;
-#endif
-
- default:
- assert (FALSE);
- }
- }
- ffestb_subr_kill_beru_ ();
- return (ffelexHandler) ffesta_zero (t);
-
- default:
- break;
- }
-
- ffestb_subr_kill_beru_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.beru.badname, t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_vxtcode -- Parse the VXT DECODE/ENCODE statement
-
- return ffestb_vxtcode; // to lexer
-
- Make sure the statement has a valid form for the VXT DECODE/ENCODE
- statement. If it does, implement the statement. */
-
-#if FFESTR_VXT
-ffelexHandler
-ffestb_vxtcode (ffelexToken t)
-{
- ffestpVxtcodeIx ix;
-
- switch (ffelex_token_type (ffesta_tokens[0]))
- {
- case FFELEX_typeNAME:
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- case FFELEX_typeNAME:
- case FFELEX_typeNUMBER:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
-
- default:
- goto bad_1; /* :::::::::::::::::::: */
-
- case FFELEX_typeOPEN_PAREN:
- for (ix = 0; ix < FFESTP_vxtcodeix; ++ix)
- ffestp_file.vxtcode.vxtcode_spec[ix].kw_or_val_present = FALSE;
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextFILENUM, (ffeexprCallback) ffestb_vxtcode1_);
- }
-
- case FFELEX_typeNAMES:
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
-
- default:
- goto bad_1; /* :::::::::::::::::::: */
-
- case FFELEX_typeOPEN_PAREN:
- if (ffelex_token_length (ffesta_tokens[0])
- != ffestb_args.vxtcode.len)
- goto bad_0; /* :::::::::::::::::::: */
-
- for (ix = 0; ix < FFESTP_vxtcodeix; ++ix)
- ffestp_file.vxtcode.vxtcode_spec[ix].kw_or_val_present = FALSE;
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextFILENUM, (ffeexprCallback) ffestb_vxtcode1_);
- }
-
- default:
- goto bad_0; /* :::::::::::::::::::: */
- }
-
-bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.vxtcode.badname, ffesta_tokens[0]);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-
-bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.vxtcode.badname, t);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero); /* Invalid second token. */
-}
-
-/* ffestb_vxtcode1_ -- "VXTCODE" OPEN_PAREN expr
-
- (ffestb_vxtcode1_) // to expression handler
-
- Handle COMMA here. */
-
-static ffelexHandler
-ffestb_vxtcode1_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- if (expr == NULL)
- break;
- ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixC].kw_or_val_present
- = TRUE;
- ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixC].kw_present = FALSE;
- ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixC].value_present = TRUE;
- ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixC].value_is_label
- = FALSE;
- ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixC].value
- = ffelex_token_use (ft);
- ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixC].u.expr = expr;
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextFILEFORMAT, (ffeexprCallback) ffestb_vxtcode2_);
-
- default:
- break;
- }
-
- ffestb_subr_kill_vxtcode_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.vxtcode.badname, t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_vxtcode2_ -- "VXTCODE" OPEN_PAREN expr COMMA expr
-
- (ffestb_vxtcode2_) // to expression handler
-
- Handle COMMA here. */
-
-static ffelexHandler
-ffestb_vxtcode2_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixF].kw_or_val_present
- = TRUE;
- ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixF].kw_present = FALSE;
- ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixF].value_present = TRUE;
- ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixF].value_is_label
- = (expr == NULL);
- ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixF].value
- = ffelex_token_use (ft);
- ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixF].u.expr = expr;
- if (ffesta_first_kw == FFESTR_firstENCODE)
- return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool,
- FFEEXPR_contextFILEVXTCODE,
- (ffeexprCallback) ffestb_vxtcode3_);
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextFILEVXTCODE,
- (ffeexprCallback) ffestb_vxtcode3_);
-
- default:
- break;
- }
-
- ffestb_subr_kill_vxtcode_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.vxtcode.badname, t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_vxtcode3_ -- "VXTCODE" OPEN_PAREN expr COMMA expr COMMA expr
-
- (ffestb_vxtcode3_) // to expression handler
-
- Handle COMMA or CLOSE_PAREN here. */
-
-static ffelexHandler
-ffestb_vxtcode3_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- case FFELEX_typeCLOSE_PAREN:
- if (expr == NULL)
- break;
- ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixB].kw_or_val_present
- = TRUE;
- ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixB].kw_present = FALSE;
- ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixB].value_present = TRUE;
- ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixB].value_is_label
- = FALSE;
- ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixB].value
- = ffelex_token_use (ft);
- ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixB].u.expr = expr;
- if (ffelex_token_type (t) == FFELEX_typeCOMMA)
- return (ffelexHandler) ffestb_vxtcode4_;
- return (ffelexHandler) ffestb_vxtcode9_;
-
- default:
- break;
- }
-
- ffestb_subr_kill_vxtcode_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.vxtcode.badname, t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_vxtcode4_ -- "VXTCODE" OPEN_PAREN ...
-
- return ffestb_vxtcode4_; // to lexer
-
- Handle NAME=expr construct here. */
-
-static ffelexHandler
-ffestb_vxtcode4_ (ffelexToken t)
-{
- ffestrGenio kw;
-
- ffestb_local_.vxtcode.label = FALSE;
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- kw = ffestr_genio (t);
- switch (kw)
- {
- case FFESTR_genioERR:
- ffestb_local_.vxtcode.ix = FFESTP_vxtcodeixERR;
- ffestb_local_.vxtcode.label = TRUE;
- break;
-
- case FFESTR_genioIOSTAT:
- ffestb_local_.vxtcode.ix = FFESTP_vxtcodeixIOSTAT;
- ffestb_local_.vxtcode.left = TRUE;
- ffestb_local_.vxtcode.context = FFEEXPR_contextFILEINT;
- break;
-
- default:
- goto bad; /* :::::::::::::::::::: */
- }
- if (ffestp_file.vxtcode.vxtcode_spec[ffestb_local_.vxtcode.ix]
- .kw_or_val_present)
- break; /* Can't specify a keyword twice! */
- ffestp_file.vxtcode.vxtcode_spec[ffestb_local_.vxtcode.ix]
- .kw_or_val_present = TRUE;
- ffestp_file.vxtcode.vxtcode_spec[ffestb_local_.vxtcode.ix]
- .kw_present = TRUE;
- ffestp_file.vxtcode.vxtcode_spec[ffestb_local_.vxtcode.ix]
- .value_present = FALSE;
- ffestp_file.vxtcode.vxtcode_spec[ffestb_local_.vxtcode.ix].value_is_label
- = ffestb_local_.vxtcode.label;
- ffestp_file.vxtcode.vxtcode_spec[ffestb_local_.vxtcode.ix].kw
- = ffelex_token_use (t);
- return (ffelexHandler) ffestb_vxtcode5_;
-
- default:
- break;
- }
-
-bad: /* :::::::::::::::::::: */
- ffestb_subr_kill_vxtcode_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.vxtcode.badname, t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_vxtcode5_ -- "VXTCODE" OPEN_PAREN [external-file-unit COMMA [format
- COMMA]] NAME
-
- return ffestb_vxtcode5_; // to lexer
-
- Make sure EQUALS here, send next token to expression handler. */
-
-static ffelexHandler
-ffestb_vxtcode5_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeEQUALS:
- ffesta_confirmed ();
- if (ffestb_local_.vxtcode.label)
- return (ffelexHandler) ffestb_vxtcode7_;
- if (ffestb_local_.vxtcode.left)
- return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool,
- ffestb_local_.vxtcode.context,
- (ffeexprCallback) ffestb_vxtcode6_);
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- ffestb_local_.vxtcode.context,
- (ffeexprCallback) ffestb_vxtcode6_);
-
- default:
- break;
- }
-
- ffestb_subr_kill_vxtcode_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.vxtcode.badname, t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_vxtcode6_ -- "VXTCODE" OPEN_PAREN ... NAME EQUALS expr
-
- (ffestb_vxtcode6_) // to expression handler
-
- Handle COMMA or CLOSE_PAREN here. */
-
-static ffelexHandler
-ffestb_vxtcode6_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- case FFELEX_typeCLOSE_PAREN:
- if (expr == NULL)
- break;
- ffestp_file.vxtcode.vxtcode_spec[ffestb_local_.vxtcode.ix].value_present
- = TRUE;
- ffestp_file.vxtcode.vxtcode_spec[ffestb_local_.vxtcode.ix].value
- = ffelex_token_use (ft);
- ffestp_file.vxtcode.vxtcode_spec[ffestb_local_.vxtcode.ix].u.expr = expr;
- if (ffelex_token_type (t) == FFELEX_typeCOMMA)
- return (ffelexHandler) ffestb_vxtcode4_;
- return (ffelexHandler) ffestb_vxtcode9_;
-
- default:
- break;
- }
-
- ffestb_subr_kill_vxtcode_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.vxtcode.badname, t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_vxtcode7_ -- "VXTCODE" OPEN_PAREN ... NAME EQUALS
-
- return ffestb_vxtcode7_; // to lexer
-
- Handle NUMBER for label here. */
-
-static ffelexHandler
-ffestb_vxtcode7_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNUMBER:
- ffestp_file.vxtcode.vxtcode_spec[ffestb_local_.vxtcode.ix].value_present
- = TRUE;
- ffestp_file.vxtcode.vxtcode_spec[ffestb_local_.vxtcode.ix].value
- = ffelex_token_use (t);
- return (ffelexHandler) ffestb_vxtcode8_;
-
- default:
- break;
- }
-
- ffestb_subr_kill_vxtcode_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.vxtcode.badname, t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_vxtcode8_ -- "VXTCODE" OPEN_PAREN ... NAME EQUALS NUMBER
-
- return ffestb_vxtcode8_; // to lexer
-
- Handle COMMA or CLOSE_PAREN here. */
-
-static ffelexHandler
-ffestb_vxtcode8_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- return (ffelexHandler) ffestb_vxtcode4_;
-
- case FFELEX_typeCLOSE_PAREN:
- return (ffelexHandler) ffestb_vxtcode9_;
-
- default:
- break;
- }
-
- ffestb_subr_kill_vxtcode_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.vxtcode.badname, t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_vxtcode9_ -- "VXTCODE" OPEN_PAREN ... CLOSE_PAREN
-
- return ffestb_vxtcode9_; // to lexer
-
- Handle EOS or SEMICOLON here.
-
- 07-Jun-90 JCB 1.1
- Context for ENCODE/DECODE expressions is now IOLISTDF instead of IOLIST
- since they apply to internal files. */
-
-static ffelexHandler
-ffestb_vxtcode9_ (ffelexToken t)
-{
- ffelexHandler next;
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- {
- if (ffesta_first_kw == FFESTR_firstENCODE)
- {
- ffestc_V023_start ();
- ffestc_V023_finish ();
- }
- else
- {
- ffestc_V024_start ();
- ffestc_V024_finish ();
- }
- }
- ffestb_subr_kill_vxtcode_ ();
- return (ffelexHandler) ffesta_zero (t);
-
- case FFELEX_typeNAME:
- case FFELEX_typeOPEN_PAREN:
- case FFELEX_typeCOMMA:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- if (ffesta_first_kw == FFESTR_firstENCODE)
- ffestc_V023_start ();
- else
- ffestc_V024_start ();
- ffestb_subr_kill_vxtcode_ ();
- if (ffesta_first_kw == FFESTR_firstDECODE)
- next = (ffelexHandler) ffeexpr_lhs (ffesta_output_pool,
- FFEEXPR_contextIOLISTDF,
- (ffeexprCallback) ffestb_vxtcode10_);
- else
- next = (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextIOLISTDF,
- (ffeexprCallback) ffestb_vxtcode10_);
-
- /* EXTENSION: Allow an optional preceding COMMA here if not pedantic.
- (f2c provides this extension, as do other compilers, supposedly.) */
-
- if (!ffe_is_pedantic () && (ffelex_token_type (t) == FFELEX_typeCOMMA))
- return next;
-
- return (ffelexHandler) (*next) (t);
-
- default:
- break;
- }
-
- ffestb_subr_kill_vxtcode_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.vxtcode.badname, t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_vxtcode10_ -- "VXTCODE(...)" expr
-
- (ffestb_vxtcode10_) // to expression handler
-
- Handle COMMA or EOS/SEMICOLON here.
-
- 07-Jun-90 JCB 1.1
- Context for ENCODE/DECODE expressions is now IOLISTDF instead of IOLIST
- since they apply to internal files. */
-
-static ffelexHandler
-ffestb_vxtcode10_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- if (expr == NULL)
- break;
- if (!ffesta_is_inhibited ())
- if (ffesta_first_kw == FFESTR_firstENCODE)
- ffestc_V023_item (expr, ft);
- else
- ffestc_V024_item (expr, ft);
- if (ffesta_first_kw == FFESTR_firstDECODE)
- return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool,
- FFEEXPR_contextIOLISTDF,
- (ffeexprCallback) ffestb_vxtcode10_);
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextIOLISTDF,
- (ffeexprCallback) ffestb_vxtcode10_);
-
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- if (expr == NULL)
- break;
- if (!ffesta_is_inhibited ())
- {
- if (ffesta_first_kw == FFESTR_firstENCODE)
- {
- ffestc_V023_item (expr, ft);
- ffestc_V023_finish ();
- }
- else
- {
- ffestc_V024_item (expr, ft);
- ffestc_V024_finish ();
- }
- }
- return (ffelexHandler) ffesta_zero (t);
-
- default:
- break;
- }
-
- if (!ffesta_is_inhibited ())
- if (ffesta_first_kw == FFESTR_firstENCODE)
- ffestc_V023_finish ();
- else
- ffestc_V024_finish ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.vxtcode.badname, t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-#endif
-/* ffestb_R904 -- Parse an OPEN statement
-
- return ffestb_R904; // to lexer
-
- Make sure the statement has a valid form for an OPEN statement.
- If it does, implement the statement. */
-
-ffelexHandler
-ffestb_R904 (ffelexToken t)
-{
- ffestpOpenIx ix;
-
- switch (ffelex_token_type (ffesta_tokens[0]))
- {
- case FFELEX_typeNAME:
- if (ffesta_first_kw != FFESTR_firstOPEN)
- goto bad_0; /* :::::::::::::::::::: */
- break;
-
- case FFELEX_typeNAMES:
- if (ffesta_first_kw != FFESTR_firstOPEN)
- goto bad_0; /* :::::::::::::::::::: */
- if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlOPEN)
- goto bad_0; /* :::::::::::::::::::: */
- break;
-
- default:
- goto bad_0; /* :::::::::::::::::::: */
- }
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeOPEN_PAREN:
- break;
-
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
-
- default:
- goto bad_1; /* :::::::::::::::::::: */
- }
-
- for (ix = 0; ix < FFESTP_openix; ++ix)
- ffestp_file.open.open_spec[ix].kw_or_val_present = FALSE;
-
- return (ffelexHandler) ffestb_R9041_;
-
-bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "OPEN", ffesta_tokens[0]);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-
-bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "OPEN", t);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero); /* Invalid second token. */
-}
-
-/* ffestb_R9041_ -- "OPEN" OPEN_PAREN
-
- return ffestb_R9041_; // to lexer
-
- Handle expr construct (not NAME=expr construct) here. */
-
-static ffelexHandler
-ffestb_R9041_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_R9042_;
-
- default:
- return (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextFILENUM, (ffeexprCallback) ffestb_R9043_)))
- (t);
- }
-}
-
-/* ffestb_R9042_ -- "OPEN" OPEN_PAREN NAME
-
- return ffestb_R9042_; // to lexer
-
- If EQUALS here, go to states that handle it. Else, send NAME and this
- token thru expression handler. */
-
-static ffelexHandler
-ffestb_R9042_ (ffelexToken t)
-{
- ffelexHandler next;
- ffelexToken nt;
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeEQUALS:
- nt = ffesta_tokens[1];
- next = (ffelexHandler) ffestb_R9044_ (nt);
- ffelex_token_kill (nt);
- return (ffelexHandler) (*next) (t);
-
- default:
- next = (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextFILENUM, (ffeexprCallback) ffestb_R9043_)))
- (ffesta_tokens[1]);
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) (*next) (t);
- }
-}
-
-/* ffestb_R9043_ -- "OPEN" OPEN_PAREN expr
-
- (ffestb_R9043_) // to expression handler
-
- Handle COMMA or CLOSE_PAREN here. */
-
-static ffelexHandler
-ffestb_R9043_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- case FFELEX_typeCLOSE_PAREN:
- if (expr == NULL)
- break;
- ffestp_file.open.open_spec[FFESTP_openixUNIT].kw_or_val_present
- = TRUE;
- ffestp_file.open.open_spec[FFESTP_openixUNIT].kw_present = FALSE;
- ffestp_file.open.open_spec[FFESTP_openixUNIT].value_present = TRUE;
- ffestp_file.open.open_spec[FFESTP_openixUNIT].value_is_label
- = FALSE;
- ffestp_file.open.open_spec[FFESTP_openixUNIT].value
- = ffelex_token_use (ft);
- ffestp_file.open.open_spec[FFESTP_openixUNIT].u.expr = expr;
- if (ffelex_token_type (t) == FFELEX_typeCOMMA)
- return (ffelexHandler) ffestb_R9044_;
- return (ffelexHandler) ffestb_R9049_;
-
- default:
- break;
- }
-
- ffestb_subr_kill_open_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "OPEN", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R9044_ -- "OPEN" OPEN_PAREN [external-file-unit COMMA]
-
- return ffestb_R9044_; // to lexer
-
- Handle expr construct (not NAME=expr construct) here. */
-
-static ffelexHandler
-ffestb_R9044_ (ffelexToken t)
-{
- ffestrOpen kw;
-
- ffestb_local_.open.label = FALSE;
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- kw = ffestr_open (t);
- switch (kw)
- {
- case FFESTR_openACCESS:
- ffestb_local_.open.ix = FFESTP_openixACCESS;
- ffestb_local_.open.left = FALSE;
- ffestb_local_.open.context = FFEEXPR_contextFILEDFCHAR;
- break;
-
- case FFESTR_openACTION:
- ffestb_local_.open.ix = FFESTP_openixACTION;
- ffestb_local_.open.left = FALSE;
- ffestb_local_.open.context = FFEEXPR_contextFILEDFCHAR;
- break;
-
- case FFESTR_openASSOCIATEVARIABLE:
- ffestb_local_.open.ix = FFESTP_openixASSOCIATEVARIABLE;
- ffestb_local_.open.left = TRUE;
- ffestb_local_.open.context = FFEEXPR_contextFILEASSOC;
- break;
-
- case FFESTR_openBLANK:
- ffestb_local_.open.ix = FFESTP_openixBLANK;
- ffestb_local_.open.left = FALSE;
- ffestb_local_.open.context = FFEEXPR_contextFILEDFCHAR;
- break;
-
- case FFESTR_openBLOCKSIZE:
- ffestb_local_.open.ix = FFESTP_openixBLOCKSIZE;
- ffestb_local_.open.left = FALSE;
- ffestb_local_.open.context = FFEEXPR_contextFILENUM;
- break;
-
- case FFESTR_openBUFFERCOUNT:
- ffestb_local_.open.ix = FFESTP_openixBUFFERCOUNT;
- ffestb_local_.open.left = FALSE;
- ffestb_local_.open.context = FFEEXPR_contextFILENUM;
- break;
-
- case FFESTR_openCARRIAGECONTROL:
- ffestb_local_.open.ix = FFESTP_openixCARRIAGECONTROL;
- ffestb_local_.open.left = FALSE;
- ffestb_local_.open.context = FFEEXPR_contextFILECHAR;
- break;
-
- case FFESTR_openDEFAULTFILE:
- ffestb_local_.open.ix = FFESTP_openixDEFAULTFILE;
- ffestb_local_.open.left = FALSE;
- ffestb_local_.open.context = FFEEXPR_contextFILECHAR;
- break;
-
- case FFESTR_openDELIM:
- ffestb_local_.open.ix = FFESTP_openixDELIM;
- ffestb_local_.open.left = FALSE;
- ffestb_local_.open.context = FFEEXPR_contextFILEDFCHAR;
- break;
-
- case FFESTR_openDISP:
- case FFESTR_openDISPOSE:
- ffestb_local_.open.ix = FFESTP_openixDISPOSE;
- ffestb_local_.open.left = FALSE;
- ffestb_local_.open.context = FFEEXPR_contextFILECHAR;
- break;
-
- case FFESTR_openERR:
- ffestb_local_.open.ix = FFESTP_openixERR;
- ffestb_local_.open.label = TRUE;
- break;
-
- case FFESTR_openEXTENDSIZE:
- ffestb_local_.open.ix = FFESTP_openixEXTENDSIZE;
- ffestb_local_.open.left = FALSE;
- ffestb_local_.open.context = FFEEXPR_contextFILENUM;
- break;
-
- case FFESTR_openFILE:
- case FFESTR_openNAME:
- ffestb_local_.open.ix = FFESTP_openixFILE;
- ffestb_local_.open.left = FALSE;
- ffestb_local_.open.context = FFEEXPR_contextFILECHAR;
- break;
-
- case FFESTR_openFORM:
- ffestb_local_.open.ix = FFESTP_openixFORM;
- ffestb_local_.open.left = FALSE;
- ffestb_local_.open.context = FFEEXPR_contextFILEDFCHAR;
- break;
-
- case FFESTR_openINITIALSIZE:
- ffestb_local_.open.ix = FFESTP_openixINITIALSIZE;
- ffestb_local_.open.left = FALSE;
- ffestb_local_.open.context = FFEEXPR_contextFILENUM;
- break;
-
- case FFESTR_openIOSTAT:
- ffestb_local_.open.ix = FFESTP_openixIOSTAT;
- ffestb_local_.open.left = TRUE;
- ffestb_local_.open.context = FFEEXPR_contextFILEINT;
- break;
-
-#if 0 /* Haven't added support for expression
- context yet (though easy). */
- case FFESTR_openKEY:
- ffestb_local_.open.ix = FFESTP_openixKEY;
- ffestb_local_.open.left = FALSE;
- ffestb_local_.open.context = FFEEXPR_contextFILEKEY;
- break;
-#endif
-
- case FFESTR_openMAXREC:
- ffestb_local_.open.ix = FFESTP_openixMAXREC;
- ffestb_local_.open.left = FALSE;
- ffestb_local_.open.context = FFEEXPR_contextFILENUM;
- break;
-
- case FFESTR_openNOSPANBLOCKS:
- if (ffestp_file.open.open_spec[FFESTP_openixNOSPANBLOCKS]
- .kw_or_val_present)
- goto bad; /* :::::::::::::::::::: */
- ffestp_file.open.open_spec[FFESTP_openixNOSPANBLOCKS]
- .kw_or_val_present = TRUE;
- ffestp_file.open.open_spec[FFESTP_openixNOSPANBLOCKS]
- .kw_present = TRUE;
- ffestp_file.open.open_spec[FFESTP_openixNOSPANBLOCKS]
- .value_present = FALSE;
- ffestp_file.open.open_spec[FFESTP_openixNOSPANBLOCKS].kw
- = ffelex_token_use (t);
- return (ffelexHandler) ffestb_R9048_;
-
- case FFESTR_openORGANIZATION:
- ffestb_local_.open.ix = FFESTP_openixORGANIZATION;
- ffestb_local_.open.left = FALSE;
- ffestb_local_.open.context = FFEEXPR_contextFILECHAR;
- break;
-
- case FFESTR_openPAD:
- ffestb_local_.open.ix = FFESTP_openixPAD;
- ffestb_local_.open.left = FALSE;
- ffestb_local_.open.context = FFEEXPR_contextFILEDFCHAR;
- break;
-
- case FFESTR_openPOSITION:
- ffestb_local_.open.ix = FFESTP_openixPOSITION;
- ffestb_local_.open.left = FALSE;
- ffestb_local_.open.context = FFEEXPR_contextFILEDFCHAR;
- break;
-
- case FFESTR_openREADONLY:
- if (ffestp_file.open.open_spec[FFESTP_openixREADONLY]
- .kw_or_val_present)
- goto bad; /* :::::::::::::::::::: */
- ffestp_file.open.open_spec[FFESTP_openixREADONLY]
- .kw_or_val_present = TRUE;
- ffestp_file.open.open_spec[FFESTP_openixREADONLY]
- .kw_present = TRUE;
- ffestp_file.open.open_spec[FFESTP_openixREADONLY]
- .value_present = FALSE;
- ffestp_file.open.open_spec[FFESTP_openixREADONLY].kw
- = ffelex_token_use (t);
- return (ffelexHandler) ffestb_R9048_;
-
- case FFESTR_openRECL:
- case FFESTR_openRECORDSIZE:
- ffestb_local_.open.ix = FFESTP_openixRECL;
- ffestb_local_.open.left = FALSE;
- ffestb_local_.open.context = FFEEXPR_contextFILENUM;
- break;
-
- case FFESTR_openRECORDTYPE:
- ffestb_local_.open.ix = FFESTP_openixRECORDTYPE;
- ffestb_local_.open.left = FALSE;
- ffestb_local_.open.context = FFEEXPR_contextFILECHAR;
- break;
-
- case FFESTR_openSHARED:
- if (ffestp_file.open.open_spec[FFESTP_openixSHARED]
- .kw_or_val_present)
- goto bad; /* :::::::::::::::::::: */
- ffestp_file.open.open_spec[FFESTP_openixSHARED]
- .kw_or_val_present = TRUE;
- ffestp_file.open.open_spec[FFESTP_openixSHARED]
- .kw_present = TRUE;
- ffestp_file.open.open_spec[FFESTP_openixSHARED]
- .value_present = FALSE;
- ffestp_file.open.open_spec[FFESTP_openixSHARED].kw
- = ffelex_token_use (t);
- return (ffelexHandler) ffestb_R9048_;
-
- case FFESTR_openSTATUS:
- case FFESTR_openTYPE:
- ffestb_local_.open.ix = FFESTP_openixSTATUS;
- ffestb_local_.open.left = FALSE;
- ffestb_local_.open.context = FFEEXPR_contextFILEDFCHAR;
- break;
-
- case FFESTR_openUNIT:
- ffestb_local_.open.ix = FFESTP_openixUNIT;
- ffestb_local_.open.left = FALSE;
- ffestb_local_.open.context = FFEEXPR_contextFILENUM;
- break;
-
- case FFESTR_openUSEROPEN:
- ffestb_local_.open.ix = FFESTP_openixUSEROPEN;
- ffestb_local_.open.left = TRUE;
- ffestb_local_.open.context = FFEEXPR_contextFILEEXTFUNC;
- break;
-
- default:
- goto bad; /* :::::::::::::::::::: */
- }
- if (ffestp_file.open.open_spec[ffestb_local_.open.ix]
- .kw_or_val_present)
- break; /* Can't specify a keyword twice! */
- ffestp_file.open.open_spec[ffestb_local_.open.ix]
- .kw_or_val_present = TRUE;
- ffestp_file.open.open_spec[ffestb_local_.open.ix]
- .kw_present = TRUE;
- ffestp_file.open.open_spec[ffestb_local_.open.ix]
- .value_present = FALSE;
- ffestp_file.open.open_spec[ffestb_local_.open.ix].value_is_label
- = ffestb_local_.open.label;
- ffestp_file.open.open_spec[ffestb_local_.open.ix].kw
- = ffelex_token_use (t);
- return (ffelexHandler) ffestb_R9045_;
-
- default:
- break;
- }
-
-bad: /* :::::::::::::::::::: */
- ffestb_subr_kill_open_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "OPEN", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R9045_ -- "OPEN" OPEN_PAREN [external-file-unit COMMA] NAME
-
- return ffestb_R9045_; // to lexer
-
- Make sure EQUALS here, send next token to expression handler. */
-
-static ffelexHandler
-ffestb_R9045_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeEQUALS:
- ffesta_confirmed ();
- if (ffestb_local_.open.label)
- return (ffelexHandler) ffestb_R9047_;
- if (ffestb_local_.open.left)
- return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool,
- ffestb_local_.open.context,
- (ffeexprCallback) ffestb_R9046_);
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- ffestb_local_.open.context,
- (ffeexprCallback) ffestb_R9046_);
-
- default:
- break;
- }
-
- ffestb_subr_kill_open_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "OPEN", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R9046_ -- "OPEN" OPEN_PAREN ... NAME EQUALS expr
-
- (ffestb_R9046_) // to expression handler
-
- Handle COMMA or CLOSE_PAREN here. */
-
-static ffelexHandler
-ffestb_R9046_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- case FFELEX_typeCLOSE_PAREN:
- if (expr == NULL)
- break;
- ffestp_file.open.open_spec[ffestb_local_.open.ix].value_present
- = TRUE;
- ffestp_file.open.open_spec[ffestb_local_.open.ix].value
- = ffelex_token_use (ft);
- ffestp_file.open.open_spec[ffestb_local_.open.ix].u.expr = expr;
- if (ffelex_token_type (t) == FFELEX_typeCOMMA)
- return (ffelexHandler) ffestb_R9044_;
- return (ffelexHandler) ffestb_R9049_;
-
- default:
- break;
- }
-
- ffestb_subr_kill_open_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "OPEN", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R9047_ -- "OPEN" OPEN_PAREN ... NAME EQUALS
-
- return ffestb_R9047_; // to lexer
-
- Handle NUMBER for label here. */
-
-static ffelexHandler
-ffestb_R9047_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNUMBER:
- ffestp_file.open.open_spec[ffestb_local_.open.ix].value_present
- = TRUE;
- ffestp_file.open.open_spec[ffestb_local_.open.ix].value
- = ffelex_token_use (t);
- return (ffelexHandler) ffestb_R9048_;
-
- default:
- break;
- }
-
- ffestb_subr_kill_open_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "OPEN", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R9048_ -- "OPEN" OPEN_PAREN ... NAME EQUALS NUMBER
-
- return ffestb_R9048_; // to lexer
-
- Handle COMMA or CLOSE_PAREN here. */
-
-static ffelexHandler
-ffestb_R9048_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- return (ffelexHandler) ffestb_R9044_;
-
- case FFELEX_typeCLOSE_PAREN:
- return (ffelexHandler) ffestb_R9049_;
-
- default:
- break;
- }
-
- ffestb_subr_kill_open_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "OPEN", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R9049_ -- "OPEN" OPEN_PAREN ... CLOSE_PAREN
-
- return ffestb_R9049_; // to lexer
-
- Handle EOS or SEMICOLON here. */
-
-static ffelexHandler
-ffestb_R9049_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- ffestc_R904 ();
- ffestb_subr_kill_open_ ();
- return (ffelexHandler) ffesta_zero (t);
-
- default:
- break;
- }
-
- ffestb_subr_kill_open_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "OPEN", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R907 -- Parse a CLOSE statement
-
- return ffestb_R907; // to lexer
-
- Make sure the statement has a valid form for a CLOSE statement.
- If it does, implement the statement. */
-
-ffelexHandler
-ffestb_R907 (ffelexToken t)
-{
- ffestpCloseIx ix;
-
- switch (ffelex_token_type (ffesta_tokens[0]))
- {
- case FFELEX_typeNAME:
- if (ffesta_first_kw != FFESTR_firstCLOSE)
- goto bad_0; /* :::::::::::::::::::: */
- break;
-
- case FFELEX_typeNAMES:
- if (ffesta_first_kw != FFESTR_firstCLOSE)
- goto bad_0; /* :::::::::::::::::::: */
- if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlCLOSE)
- goto bad_0; /* :::::::::::::::::::: */
- break;
-
- default:
- goto bad_0; /* :::::::::::::::::::: */
- }
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeOPEN_PAREN:
- break;
-
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
-
- default:
- goto bad_1; /* :::::::::::::::::::: */
- }
-
- for (ix = 0; ix < FFESTP_closeix; ++ix)
- ffestp_file.close.close_spec[ix].kw_or_val_present = FALSE;
-
- return (ffelexHandler) ffestb_R9071_;
-
-bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CLOSE", ffesta_tokens[0]);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-
-bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CLOSE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero); /* Invalid second token. */
-}
-
-/* ffestb_R9071_ -- "CLOSE" OPEN_PAREN
-
- return ffestb_R9071_; // to lexer
-
- Handle expr construct (not NAME=expr construct) here. */
-
-static ffelexHandler
-ffestb_R9071_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_R9072_;
-
- default:
- return (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextFILENUM, (ffeexprCallback) ffestb_R9073_)))
- (t);
- }
-}
-
-/* ffestb_R9072_ -- "CLOSE" OPEN_PAREN NAME
-
- return ffestb_R9072_; // to lexer
-
- If EQUALS here, go to states that handle it. Else, send NAME and this
- token thru expression handler. */
-
-static ffelexHandler
-ffestb_R9072_ (ffelexToken t)
-{
- ffelexHandler next;
- ffelexToken nt;
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeEQUALS:
- nt = ffesta_tokens[1];
- next = (ffelexHandler) ffestb_R9074_ (nt);
- ffelex_token_kill (nt);
- return (ffelexHandler) (*next) (t);
-
- default:
- next = (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextFILENUM, (ffeexprCallback) ffestb_R9073_)))
- (ffesta_tokens[1]);
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) (*next) (t);
- }
-}
-
-/* ffestb_R9073_ -- "CLOSE" OPEN_PAREN expr
-
- (ffestb_R9073_) // to expression handler
-
- Handle COMMA or CLOSE_PAREN here. */
-
-static ffelexHandler
-ffestb_R9073_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- case FFELEX_typeCLOSE_PAREN:
- if (expr == NULL)
- break;
- ffestp_file.close.close_spec[FFESTP_closeixUNIT].kw_or_val_present
- = TRUE;
- ffestp_file.close.close_spec[FFESTP_closeixUNIT].kw_present = FALSE;
- ffestp_file.close.close_spec[FFESTP_closeixUNIT].value_present = TRUE;
- ffestp_file.close.close_spec[FFESTP_closeixUNIT].value_is_label
- = FALSE;
- ffestp_file.close.close_spec[FFESTP_closeixUNIT].value
- = ffelex_token_use (ft);
- ffestp_file.close.close_spec[FFESTP_closeixUNIT].u.expr = expr;
- if (ffelex_token_type (t) == FFELEX_typeCOMMA)
- return (ffelexHandler) ffestb_R9074_;
- return (ffelexHandler) ffestb_R9079_;
-
- default:
- break;
- }
-
- ffestb_subr_kill_close_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CLOSE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R9074_ -- "CLOSE" OPEN_PAREN [external-file-unit COMMA]
-
- return ffestb_R9074_; // to lexer
-
- Handle expr construct (not NAME=expr construct) here. */
-
-static ffelexHandler
-ffestb_R9074_ (ffelexToken t)
-{
- ffestrGenio kw;
-
- ffestb_local_.close.label = FALSE;
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- kw = ffestr_genio (t);
- switch (kw)
- {
- case FFESTR_genioERR:
- ffestb_local_.close.ix = FFESTP_closeixERR;
- ffestb_local_.close.label = TRUE;
- break;
-
- case FFESTR_genioIOSTAT:
- ffestb_local_.close.ix = FFESTP_closeixIOSTAT;
- ffestb_local_.close.left = TRUE;
- ffestb_local_.close.context = FFEEXPR_contextFILEINT;
- break;
-
- case FFESTR_genioSTATUS:
- case FFESTR_genioDISP:
- case FFESTR_genioDISPOSE:
- ffestb_local_.close.ix = FFESTP_closeixSTATUS;
- ffestb_local_.close.left = FALSE;
- ffestb_local_.close.context = FFEEXPR_contextFILEDFCHAR;
- break;
-
- case FFESTR_genioUNIT:
- ffestb_local_.close.ix = FFESTP_closeixUNIT;
- ffestb_local_.close.left = FALSE;
- ffestb_local_.close.context = FFEEXPR_contextFILENUM;
- break;
-
- default:
- goto bad; /* :::::::::::::::::::: */
- }
- if (ffestp_file.close.close_spec[ffestb_local_.close.ix]
- .kw_or_val_present)
- break; /* Can't specify a keyword twice! */
- ffestp_file.close.close_spec[ffestb_local_.close.ix]
- .kw_or_val_present = TRUE;
- ffestp_file.close.close_spec[ffestb_local_.close.ix]
- .kw_present = TRUE;
- ffestp_file.close.close_spec[ffestb_local_.close.ix]
- .value_present = FALSE;
- ffestp_file.close.close_spec[ffestb_local_.close.ix].value_is_label
- = ffestb_local_.close.label;
- ffestp_file.close.close_spec[ffestb_local_.close.ix].kw
- = ffelex_token_use (t);
- return (ffelexHandler) ffestb_R9075_;
-
- default:
- break;
- }
-
-bad: /* :::::::::::::::::::: */
- ffestb_subr_kill_close_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CLOSE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R9075_ -- "CLOSE" OPEN_PAREN [external-file-unit COMMA] NAME
-
- return ffestb_R9075_; // to lexer
-
- Make sure EQUALS here, send next token to expression handler. */
-
-static ffelexHandler
-ffestb_R9075_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeEQUALS:
- ffesta_confirmed ();
- if (ffestb_local_.close.label)
- return (ffelexHandler) ffestb_R9077_;
- if (ffestb_local_.close.left)
- return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool,
- ffestb_local_.close.context,
- (ffeexprCallback) ffestb_R9076_);
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- ffestb_local_.close.context,
- (ffeexprCallback) ffestb_R9076_);
-
- default:
- break;
- }
-
- ffestb_subr_kill_close_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CLOSE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R9076_ -- "CLOSE" OPEN_PAREN ... NAME EQUALS expr
-
- (ffestb_R9076_) // to expression handler
-
- Handle COMMA or CLOSE_PAREN here. */
-
-static ffelexHandler
-ffestb_R9076_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- case FFELEX_typeCLOSE_PAREN:
- if (expr == NULL)
- break;
- ffestp_file.close.close_spec[ffestb_local_.close.ix].value_present
- = TRUE;
- ffestp_file.close.close_spec[ffestb_local_.close.ix].value
- = ffelex_token_use (ft);
- ffestp_file.close.close_spec[ffestb_local_.close.ix].u.expr = expr;
- if (ffelex_token_type (t) == FFELEX_typeCOMMA)
- return (ffelexHandler) ffestb_R9074_;
- return (ffelexHandler) ffestb_R9079_;
-
- default:
- break;
- }
-
- ffestb_subr_kill_close_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CLOSE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R9077_ -- "CLOSE" OPEN_PAREN ... NAME EQUALS
-
- return ffestb_R9077_; // to lexer
-
- Handle NUMBER for label here. */
-
-static ffelexHandler
-ffestb_R9077_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNUMBER:
- ffestp_file.close.close_spec[ffestb_local_.close.ix].value_present
- = TRUE;
- ffestp_file.close.close_spec[ffestb_local_.close.ix].value
- = ffelex_token_use (t);
- return (ffelexHandler) ffestb_R9078_;
-
- default:
- break;
- }
-
- ffestb_subr_kill_close_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CLOSE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R9078_ -- "CLOSE" OPEN_PAREN ... NAME EQUALS NUMBER
-
- return ffestb_R9078_; // to lexer
-
- Handle COMMA or CLOSE_PAREN here. */
-
-static ffelexHandler
-ffestb_R9078_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- return (ffelexHandler) ffestb_R9074_;
-
- case FFELEX_typeCLOSE_PAREN:
- return (ffelexHandler) ffestb_R9079_;
-
- default:
- break;
- }
-
- ffestb_subr_kill_close_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CLOSE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R9079_ -- "CLOSE" OPEN_PAREN ... CLOSE_PAREN
-
- return ffestb_R9079_; // to lexer
-
- Handle EOS or SEMICOLON here. */
+ case FFELEX_typeHOLLERITH:
+ f = ffestt_formatlist_append (ffestb_local_.format.f);
+ f->type = FFESTP_formattypeR1016;
+ f->t = ffelex_token_use (t);
+ ffelex_token_kill (ffestb_local_.format.pre.t); /* It WAS present! */
+ return (ffelexHandler) ffestb_R100111_;
-static ffelexHandler
-ffestb_R9079_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
+ case FFELEX_typeNUMBER:
+ assert (ffestb_local_.format.pre.present);
ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- ffestc_R907 ();
- ffestb_subr_kill_close_ ();
- return (ffelexHandler) ffesta_zero (t);
-
- default:
- break;
- }
-
- ffestb_subr_kill_close_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CLOSE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R909 -- Parse the READ statement
-
- return ffestb_R909; // to lexer
-
- Make sure the statement has a valid form for the READ
- statement. If it does, implement the statement. */
-
-ffelexHandler
-ffestb_R909 (ffelexToken t)
-{
- ffelexHandler next;
- ffestpReadIx ix;
-
- switch (ffelex_token_type (ffesta_tokens[0]))
- {
- case FFELEX_typeNAME:
- if (ffesta_first_kw != FFESTR_firstREAD)
- goto bad_0; /* :::::::::::::::::::: */
- switch (ffelex_token_type (t))
+ if (ffestb_local_.format.pre.rtexpr)
{
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
-
- case FFELEX_typeEQUALS:
- case FFELEX_typePOINTS:
- case FFELEX_typeCOLON:
- goto bad_1; /* :::::::::::::::::::: */
-
- case FFELEX_typeNAME:
- case FFELEX_typeNUMBER:
- ffesta_confirmed ();
- break;
-
- case FFELEX_typeOPEN_PAREN:
- for (ix = 0; ix < FFESTP_readix; ++ix)
- ffestp_file.read.read_spec[ix].kw_or_val_present = FALSE;
- ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_R9092_;
-
- default:
- break;
+ ffebad_start (FFEBAD_FORMAT_SPURIOUS_NUMBER);
+ ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
+ ffebad_finish ();
+ return (ffelexHandler) ffestb_R10014_;
}
-
- for (ix = 0; ix < FFESTP_readix; ++ix)
- ffestp_file.read.read_spec[ix].kw_or_val_present = FALSE;
- return (ffelexHandler) (*((ffelexHandler)
- ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextFILEFORMATNML, (ffeexprCallback) ffestb_R9091_)))
- (t);
-
- case FFELEX_typeNAMES:
- if (ffesta_first_kw != FFESTR_firstREAD)
- goto bad_0; /* :::::::::::::::::::: */
- switch (ffelex_token_type (t))
+ if (ffestb_local_.format.sign)
{
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- case FFELEX_typeCOMMA:
- ffesta_confirmed ();
- if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlREAD)
- break;
- goto bad_1; /* :::::::::::::::::::: */
-
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
-
- case FFELEX_typeEQUALS:
- case FFELEX_typePOINTS:
- case FFELEX_typeCOLON:
- goto bad_1; /* :::::::::::::::::::: */
+ for (i = ffelex_token_length (t) + 1; i > 0; --i)
+ ffestb_local_.format.pre.u.signed_val *= 10;
+ ffestb_local_.format.pre.u.signed_val += strtoul (ffelex_token_text (t),
+ NULL, 10);
+ }
+ else
+ {
+ for (i = ffelex_token_length (t) + 1; i > 0; --i)
+ ffestb_local_.format.pre.u.unsigned_val *= 10;
+ ffestb_local_.format.pre.u.unsigned_val += strtoul (ffelex_token_text (t),
+ NULL, 10);
+ ffelex_set_expecting_hollerith (ffestb_local_.format.pre.u.unsigned_val,
+ '\0',
+ ffelex_token_where_line (t),
+ ffelex_token_where_column (t));
+ }
+ return (ffelexHandler) ffestb_R10014_;
- case FFELEX_typeOPEN_PAREN:
- if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlREAD)
- break;
+ case FFELEX_typeCOLONCOLON: /* "::". */
+ if (ffestb_local_.format.pre.present)
+ {
+ ffesta_ffebad_1t (FFEBAD_FORMAT_BAD_COLON_SPEC,
+ ffestb_local_.format.pre.t);
+ ffelex_token_kill (ffestb_local_.format.pre.t);
+ ffestb_local_.format.pre.present = FALSE;
+ }
+ else
+ {
+ f = ffestt_formatlist_append (ffestb_local_.format.f);
+ f->type = FFESTP_formattypeCOLON;
+ f->t = ffelex_token_use (t);
+ f->u.R1010.val.present = FALSE;
+ f->u.R1010.val.rtexpr = FALSE;
+ f->u.R1010.val.t = NULL;
+ f->u.R1010.val.u.unsigned_val = 1;
+ }
+ f = ffestt_formatlist_append (ffestb_local_.format.f);
+ f->type = FFESTP_formattypeCOLON;
+ f->t = ffelex_token_use (t);
+ f->u.R1010.val.present = FALSE;
+ f->u.R1010.val.rtexpr = FALSE;
+ f->u.R1010.val.t = NULL;
+ f->u.R1010.val.u.unsigned_val = 1;
+ return (ffelexHandler) ffestb_R100112_;
- for (ix = 0; ix < FFESTP_readix; ++ix)
- ffestp_file.read.read_spec[ix].kw_or_val_present = FALSE;
- ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_R9092_;
+ case FFELEX_typeCOLON:
+ if (ffestb_local_.format.pre.present)
+ {
+ ffesta_ffebad_1t (FFEBAD_FORMAT_BAD_COLON_SPEC,
+ ffestb_local_.format.pre.t);
+ ffelex_token_kill (ffestb_local_.format.pre.t);
+ return (ffelexHandler) ffestb_R100112_;
+ }
+ f = ffestt_formatlist_append (ffestb_local_.format.f);
+ f->type = FFESTP_formattypeCOLON;
+ f->t = ffelex_token_use (t);
+ f->u.R1010.val.present = FALSE;
+ f->u.R1010.val.rtexpr = FALSE;
+ f->u.R1010.val.t = NULL;
+ f->u.R1010.val.u.unsigned_val = 1;
+ return (ffelexHandler) ffestb_R100112_;
- default:
- break;
+ case FFELEX_typeCONCAT: /* "//". */
+ if (ffestb_local_.format.sign)
+ {
+ ffebad_start (FFEBAD_FORMAT_SPURIOUS_SIGN);
+ ffebad_here (0, ffelex_token_where_line (ffestb_local_.format.pre.t),
+ ffelex_token_where_column (ffestb_local_.format.pre.t));
+ ffebad_finish ();
+ ffestb_local_.format.pre.u.unsigned_val
+ = (ffestb_local_.format.pre.u.signed_val < 0)
+ ? -ffestb_local_.format.pre.u.signed_val
+ : ffestb_local_.format.pre.u.signed_val;
}
- for (ix = 0; ix < FFESTP_readix; ++ix)
- ffestp_file.read.read_spec[ix].kw_or_val_present = FALSE;
- next = (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextFILEFORMATNML, (ffeexprCallback) ffestb_R9091_);
- next = (ffelexHandler) ffelex_splice_tokens (next, ffesta_tokens[0],
- FFESTR_firstlREAD);
- if (next == NULL)
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero);
- return (ffelexHandler) (*next) (t);
+ f = ffestt_formatlist_append (ffestb_local_.format.f);
+ f->type = FFESTP_formattypeSLASH;
+ f->t = ffelex_token_use (t);
+ f->u.R1010.val = ffestb_local_.format.pre;
+ ffestb_local_.format.pre.present = FALSE;
+ ffestb_local_.format.pre.rtexpr = FALSE;
+ ffestb_local_.format.pre.t = NULL;
+ ffestb_local_.format.pre.u.unsigned_val = 1;
+ f = ffestt_formatlist_append (ffestb_local_.format.f);
+ f->type = FFESTP_formattypeSLASH;
+ f->t = ffelex_token_use (t);
+ f->u.R1010.val = ffestb_local_.format.pre;
+ return (ffelexHandler) ffestb_R100112_;
- default:
- goto bad_0; /* :::::::::::::::::::: */
- }
+ case FFELEX_typeSLASH:
+ if (ffestb_local_.format.sign)
+ {
+ ffebad_start (FFEBAD_FORMAT_SPURIOUS_SIGN);
+ ffebad_here (0, ffelex_token_where_line (ffestb_local_.format.pre.t),
+ ffelex_token_where_column (ffestb_local_.format.pre.t));
+ ffebad_finish ();
+ ffestb_local_.format.pre.u.unsigned_val
+ = (ffestb_local_.format.pre.u.signed_val < 0)
+ ? -ffestb_local_.format.pre.u.signed_val
+ : ffestb_local_.format.pre.u.signed_val;
+ }
+ f = ffestt_formatlist_append (ffestb_local_.format.f);
+ f->type = FFESTP_formattypeSLASH;
+ f->t = ffelex_token_use (t);
+ f->u.R1010.val = ffestb_local_.format.pre;
+ return (ffelexHandler) ffestb_R100112_;
-bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "READ", ffesta_tokens[0]);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+ case FFELEX_typeOPEN_PAREN:
+ if (ffestb_local_.format.sign)
+ {
+ ffebad_start (FFEBAD_FORMAT_SPURIOUS_SIGN);
+ ffebad_here (0, ffelex_token_where_line (ffestb_local_.format.pre.t),
+ ffelex_token_where_column (ffestb_local_.format.pre.t));
+ ffebad_finish ();
+ ffestb_local_.format.pre.u.unsigned_val
+ = (ffestb_local_.format.pre.u.signed_val < 0)
+ ? -ffestb_local_.format.pre.u.signed_val
+ : ffestb_local_.format.pre.u.signed_val;
+ }
+ f = ffestt_formatlist_append (ffestb_local_.format.f);
+ f->type = FFESTP_formattypeFORMAT;
+ f->t = ffelex_token_use (t);
+ f->u.R1003D.R1004 = ffestb_local_.format.pre;
+ f->u.R1003D.format = ffestb_local_.format.f
+ = ffestt_formatlist_create (f, ffelex_token_use (t));
+ return (ffelexHandler) ffestb_R10011_;
-bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "READ", t);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero); /* Invalid second token. */
-}
+ case FFELEX_typeOPEN_ARRAY:/* "(/". */
+ if (ffestb_local_.format.sign)
+ {
+ ffebad_start (FFEBAD_FORMAT_SPURIOUS_SIGN);
+ ffebad_here (0, ffelex_token_where_line (ffestb_local_.format.pre.t),
+ ffelex_token_where_column (ffestb_local_.format.pre.t));
+ ffebad_finish ();
+ ffestb_local_.format.pre.u.unsigned_val
+ = (ffestb_local_.format.pre.u.signed_val < 0)
+ ? -ffestb_local_.format.pre.u.signed_val
+ : ffestb_local_.format.pre.u.signed_val;
+ }
+ f = ffestt_formatlist_append (ffestb_local_.format.f);
+ f->type = FFESTP_formattypeFORMAT;
+ f->t = ffelex_token_use (t);
+ f->u.R1003D.R1004 = ffestb_local_.format.pre;
+ f->u.R1003D.format = ffestb_local_.format.f
+ = ffestt_formatlist_create (f, ffelex_token_use (t));
+ f = ffestt_formatlist_append (ffestb_local_.format.f);
+ f->type = FFESTP_formattypeSLASH;
+ f->t = ffelex_token_use (t);
+ f->u.R1010.val.present = FALSE;
+ f->u.R1010.val.rtexpr = FALSE;
+ f->u.R1010.val.t = NULL;
+ f->u.R1010.val.u.unsigned_val = 1;
+ return (ffelexHandler) ffestb_R100112_;
-/* ffestb_R9091_ -- "READ" expr
+ case FFELEX_typeCLOSE_ARRAY: /* "/)". */
+ f = ffestt_formatlist_append (ffestb_local_.format.f);
+ f->type = FFESTP_formattypeSLASH;
+ f->t = ffelex_token_use (t);
+ f->u.R1010.val = ffestb_local_.format.pre;
+ f = ffestb_local_.format.f->u.root.parent;
+ if (f == NULL)
+ return (ffelexHandler) ffestb_R100114_;
+ ffestb_local_.format.f = f->next;
+ return (ffelexHandler) ffestb_R100111_;
- (ffestb_R9091_) // to expression handler
+ case FFELEX_typeQUOTE:
+ if (ffe_is_vxt ())
+ break; /* A totally bad character in a VXT FORMAT. */
+ ffebad_start (FFEBAD_FORMAT_SPURIOUS_NUMBER);
+ ffebad_here (0, ffelex_token_where_line (ffestb_local_.format.pre.t),
+ ffelex_token_where_column (ffestb_local_.format.pre.t));
+ ffebad_finish ();
+ ffelex_token_kill (ffestb_local_.format.pre.t);
+ ffesta_confirmed ();
+#if 0 /* No apparent need for this, and not killed
+ anywhere. */
+ ffesta_tokens[1] = ffelex_token_use (t);
+#endif
+ ffelex_set_expecting_hollerith (-1, '\"',
+ ffelex_token_where_line (t),
+ ffelex_token_where_column (t)); /* Don't have to unset
+ this one. */
+ return (ffelexHandler) ffestb_R100113_;
- Make sure the next token is a COMMA or EOS/SEMICOLON. */
+ case FFELEX_typeAPOSTROPHE:
+ ffesta_confirmed ();
+ ffebad_start (FFEBAD_FORMAT_SPURIOUS_NUMBER);
+ ffebad_here (0, ffelex_token_where_line (ffestb_local_.format.pre.t),
+ ffelex_token_where_column (ffestb_local_.format.pre.t));
+ ffebad_finish ();
+ ffelex_token_kill (ffestb_local_.format.pre.t);
+#if 0 /* No apparent need for this, and not killed
+ anywhere. */
+ ffesta_tokens[1] = ffelex_token_use (t);
+#endif
+ ffelex_set_expecting_hollerith (-1, '\'', ffelex_token_where_line (t),
+ ffelex_token_where_column (t)); /* Don't have to unset
+ this one. */
+ return (ffelexHandler) ffestb_R100113_;
-static ffelexHandler
-ffestb_R9091_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
case FFELEX_typeEOS:
case FFELEX_typeSEMICOLON:
- case FFELEX_typeCOMMA:
ffesta_confirmed ();
- ffestp_file.read.read_spec[FFESTP_readixFORMAT].kw_or_val_present
- = TRUE;
- ffestp_file.read.read_spec[FFESTP_readixFORMAT].kw_present = FALSE;
- ffestp_file.read.read_spec[FFESTP_readixFORMAT].value_present = TRUE;
- ffestp_file.read.read_spec[FFESTP_readixFORMAT].value_is_label
- = (expr == NULL);
- ffestp_file.read.read_spec[FFESTP_readixFORMAT].value
- = ffelex_token_use (ft);
- ffestp_file.read.read_spec[FFESTP_readixFORMAT].u.expr = expr;
- if (!ffesta_is_inhibited ())
- ffestc_R909_start (TRUE);
- ffestb_subr_kill_read_ ();
- if (ffelex_token_type (t) == FFELEX_typeCOMMA)
- return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool,
- ffestc_context_iolist (),
- (ffeexprCallback) ffestb_R90915_);
- if (!ffesta_is_inhibited ())
- ffestc_R909_finish ();
- return (ffelexHandler) ffesta_zero (t);
-
- default:
- break;
- }
-
- ffestb_subr_kill_read_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "READ", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R9092_ -- "READ" OPEN_PAREN
+ ffesta_ffebad_1t (FFEBAD_FORMAT_MISSING_PAREN, t);
+ for (f = ffestb_local_.format.f;
+ f->u.root.parent != NULL;
+ f = f->u.root.parent->next)
+ ;
+ ffestb_local_.format.f = f;
+ ffelex_token_kill (ffestb_local_.format.pre.t);
+ return (ffelexHandler) ffestb_R100114_ (t);
- return ffestb_R9092_; // to lexer
+ case FFELEX_typeDOLLAR:
+ ffestb_local_.format.t = ffelex_token_use (t);
+ if (ffestb_local_.format.pre.present)
+ ffesta_confirmed (); /* Number preceding this invalid elsewhere. */
+ ffestb_local_.format.current = FFESTP_formattypeDOLLAR;
+ return (ffelexHandler) ffestb_R10015_;
- Handle expr construct (not NAME=expr construct) here. */
+ case FFELEX_typeNAMES:
+ kw = ffestr_format (t);
+ ffestb_local_.format.t = ffelex_token_use (t);
+ switch (kw)
+ {
+ case FFESTR_formatI:
+ if (ffestb_local_.format.pre.present)
+ ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
+ ffestb_local_.format.current = FFESTP_formattypeI;
+ i = FFESTR_formatlI;
+ break;
-static ffelexHandler
-ffestb_R9092_ (ffelexToken t)
-{
- ffelexToken nt;
- ffelexHandler next;
+ case FFESTR_formatB:
+ if (ffestb_local_.format.pre.present)
+ ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
+ ffestb_local_.format.current = FFESTP_formattypeB;
+ i = FFESTR_formatlB;
+ break;
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- ffesta_tokens[2] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_R9093_;
+ case FFESTR_formatO:
+ if (ffestb_local_.format.pre.present)
+ ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
+ ffestb_local_.format.current = FFESTP_formattypeO;
+ i = FFESTR_formatlO;
+ break;
- default:
- nt = ffesta_tokens[1];
- next = (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextFILEUNITAMBIG, (ffeexprCallback) ffestb_R9094_)))
- (nt);
- ffelex_token_kill (nt);
- return (ffelexHandler) (*next) (t);
- }
-}
+ case FFESTR_formatZ:
+ if (ffestb_local_.format.pre.present)
+ ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
+ ffestb_local_.format.current = FFESTP_formattypeZ;
+ i = FFESTR_formatlZ;
+ break;
-/* ffestb_R9093_ -- "READ" OPEN_PAREN NAME
+ case FFESTR_formatF:
+ if (ffestb_local_.format.pre.present)
+ ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
+ ffestb_local_.format.current = FFESTP_formattypeF;
+ i = FFESTR_formatlF;
+ break;
- return ffestb_R9093_; // to lexer
+ case FFESTR_formatE:
+ ffestb_local_.format.current = FFESTP_formattypeE;
+ i = FFESTR_formatlE;
+ break;
- If EQUALS here, go to states that handle it. Else, send NAME and this
- token thru expression handler. */
+ case FFESTR_formatEN:
+ if (ffestb_local_.format.pre.present)
+ ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
+ ffestb_local_.format.current = FFESTP_formattypeEN;
+ i = FFESTR_formatlEN;
+ break;
-static ffelexHandler
-ffestb_R9093_ (ffelexToken t)
-{
- ffelexHandler next;
- ffelexToken nt;
- ffelexToken ot;
+ case FFESTR_formatG:
+ if (ffestb_local_.format.pre.present)
+ ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
+ ffestb_local_.format.current = FFESTP_formattypeG;
+ i = FFESTR_formatlG;
+ break;
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeEQUALS:
- ffelex_token_kill (ffesta_tokens[1]);
- nt = ffesta_tokens[2];
- next = (ffelexHandler) ffestb_R9098_ (nt);
- ffelex_token_kill (nt);
- return (ffelexHandler) (*next) (t);
+ case FFESTR_formatL:
+ if (ffestb_local_.format.pre.present)
+ ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
+ ffestb_local_.format.current = FFESTP_formattypeL;
+ i = FFESTR_formatlL;
+ break;
- default:
- nt = ffesta_tokens[1];
- ot = ffesta_tokens[2];
- next = (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextFILEUNITAMBIG, (ffeexprCallback) ffestb_R9094_)))
- (nt);
- ffelex_token_kill (nt);
- next = (ffelexHandler) (*next) (ot);
- ffelex_token_kill (ot);
- return (ffelexHandler) (*next) (t);
- }
-}
+ case FFESTR_formatA:
+ if (ffestb_local_.format.pre.present)
+ ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
+ ffestb_local_.format.current = FFESTP_formattypeA;
+ i = FFESTR_formatlA;
+ break;
-/* ffestb_R9094_ -- "READ" OPEN_PAREN expr [CLOSE_PAREN]
+ case FFESTR_formatD:
+ ffestb_local_.format.current = FFESTP_formattypeD;
+ i = FFESTR_formatlD;
+ break;
- (ffestb_R9094_) // to expression handler
+ case FFESTR_formatQ:
+ ffestb_local_.format.current = FFESTP_formattypeQ;
+ i = FFESTR_formatlQ;
+ break;
- Handle COMMA or EOS/SEMICOLON here.
+ case FFESTR_formatDOLLAR:
+ if (ffestb_local_.format.pre.present)
+ ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
+ ffestb_local_.format.current = FFESTP_formattypeDOLLAR;
+ i = FFESTR_formatlDOLLAR;
+ break;
- 15-Feb-91 JCB 1.1
- Use new ffeexpr mechanism whereby the expr is encased in an opITEM if
- ffeexpr decided it was an item in a control list (hence a unit
- specifier), or a format specifier otherwise. */
+ case FFESTR_formatP:
+ if (ffestb_local_.format.pre.present)
+ ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
+ ffestb_local_.format.current = FFESTP_formattypeP;
+ i = FFESTR_formatlP;
+ break;
-static ffelexHandler
-ffestb_R9094_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- if (expr == NULL)
- goto bad; /* :::::::::::::::::::: */
+ case FFESTR_formatT:
+ if (ffestb_local_.format.pre.present)
+ ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
+ ffestb_local_.format.current = FFESTP_formattypeT;
+ i = FFESTR_formatlT;
+ break;
- if (ffebld_op (expr) != FFEBLD_opITEM)
- {
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- ffestp_file.read.read_spec[FFESTP_readixFORMAT].kw_or_val_present
- = TRUE;
- ffestp_file.read.read_spec[FFESTP_readixFORMAT].kw_present = FALSE;
- ffestp_file.read.read_spec[FFESTP_readixFORMAT].value_present = TRUE;
- ffestp_file.read.read_spec[FFESTP_readixFORMAT].value_is_label
- = FALSE;
- ffestp_file.read.read_spec[FFESTP_readixFORMAT].value
- = ffelex_token_use (ft);
- ffestp_file.read.read_spec[FFESTP_readixFORMAT].u.expr = expr;
- if (!ffesta_is_inhibited ())
- ffestc_R909_start (TRUE);
- ffestb_subr_kill_read_ ();
- if (ffelex_token_type (t) == FFELEX_typeCOMMA)
- return (ffelexHandler)
- ffeexpr_lhs (ffesta_output_pool,
- ffestc_context_iolist (),
- (ffeexprCallback) ffestb_R90915_);
- if (!ffesta_is_inhibited ())
- ffestc_R909_finish ();
- return (ffelexHandler) ffesta_zero (t);
+ case FFESTR_formatTL:
+ if (ffestb_local_.format.pre.present)
+ ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
+ ffestb_local_.format.current = FFESTP_formattypeTL;
+ i = FFESTR_formatlTL;
+ break;
- default:
- goto bad; /* :::::::::::::::::::: */
- }
- }
+ case FFESTR_formatTR:
+ if (ffestb_local_.format.pre.present)
+ ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
+ ffestb_local_.format.current = FFESTP_formattypeTR;
+ i = FFESTR_formatlTR;
+ break;
- expr = ffebld_head (expr);
+ case FFESTR_formatX:
+ if (ffestb_local_.format.pre.present)
+ ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
+ ffestb_local_.format.current = FFESTP_formattypeX;
+ i = FFESTR_formatlX;
+ break;
- if (expr == NULL)
- goto bad; /* :::::::::::::::::::: */
+ case FFESTR_formatS:
+ if (ffestb_local_.format.pre.present)
+ ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
+ ffestb_local_.format.current = FFESTP_formattypeS;
+ i = FFESTR_formatlS;
+ break;
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- case FFELEX_typeCLOSE_PAREN:
- ffestp_file.read.read_spec[FFESTP_readixUNIT].kw_or_val_present
- = TRUE;
- ffestp_file.read.read_spec[FFESTP_readixUNIT].kw_present = FALSE;
- ffestp_file.read.read_spec[FFESTP_readixUNIT].value_present = TRUE;
- ffestp_file.read.read_spec[FFESTP_readixUNIT].value_is_label
- = FALSE;
- ffestp_file.read.read_spec[FFESTP_readixUNIT].value
- = ffelex_token_use (ft);
- ffestp_file.read.read_spec[FFESTP_readixUNIT].u.expr = expr;
- if (ffelex_token_type (t) == FFELEX_typeCOMMA)
- return (ffelexHandler) ffestb_R9095_;
- return (ffelexHandler) ffestb_R90913_;
+ case FFESTR_formatSP:
+ if (ffestb_local_.format.pre.present)
+ ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
+ ffestb_local_.format.current = FFESTP_formattypeSP;
+ i = FFESTR_formatlSP;
+ break;
- default:
- break;
- }
+ case FFESTR_formatSS:
+ if (ffestb_local_.format.pre.present)
+ ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
+ ffestb_local_.format.current = FFESTP_formattypeSS;
+ i = FFESTR_formatlSS;
+ break;
-bad: /* :::::::::::::::::::: */
- ffestb_subr_kill_read_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "READ", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
+ case FFESTR_formatBN:
+ if (ffestb_local_.format.pre.present)
+ ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
+ ffestb_local_.format.current = FFESTP_formattypeBN;
+ i = FFESTR_formatlBN;
+ break;
-/* ffestb_R9095_ -- "READ" OPEN_PAREN expr COMMA
+ case FFESTR_formatBZ:
+ if (ffestb_local_.format.pre.present)
+ ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
+ ffestb_local_.format.current = FFESTP_formattypeBZ;
+ i = FFESTR_formatlBZ;
+ break;
- return ffestb_R9095_; // to lexer
+ case FFESTR_formatH: /* Error, either "H" or "<expr>H". */
+ if (ffestb_local_.format.pre.present)
+ ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
+ ffestb_local_.format.current = FFESTP_formattypeH;
+ i = FFESTR_formatlH;
+ break;
- Handle expr construct (not NAME=expr construct) here. */
+ case FFESTR_formatPD:
+ if (ffestb_local_.format.pre.present)
+ ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
+ ffestb_subr_R1001_append_p_ ();
+ ffestb_local_.format.t = ffelex_token_name_from_names (t,
+ FFESTR_formatlP, 1);
+ ffestb_local_.format.sign = FALSE;
+ ffestb_local_.format.pre.present = FALSE;
+ ffestb_local_.format.pre.rtexpr = FALSE;
+ ffestb_local_.format.pre.t = NULL;
+ ffestb_local_.format.pre.u.unsigned_val = 1;
+ ffestb_local_.format.current = FFESTP_formattypeD;
+ i = FFESTR_formatlPD;
+ break;
-static ffelexHandler
-ffestb_R9095_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_R9096_;
+ case FFESTR_formatPE:
+ if (ffestb_local_.format.pre.present)
+ ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
+ ffestb_subr_R1001_append_p_ ();
+ ffestb_local_.format.t = ffelex_token_name_from_names (t,
+ FFESTR_formatlP, 1);
+ ffestb_local_.format.sign = FALSE;
+ ffestb_local_.format.pre.present = FALSE;
+ ffestb_local_.format.pre.rtexpr = FALSE;
+ ffestb_local_.format.pre.t = NULL;
+ ffestb_local_.format.pre.u.unsigned_val = 1;
+ ffestb_local_.format.current = FFESTP_formattypeE;
+ i = FFESTR_formatlPE;
+ break;
- default:
- return (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextFILEFORMATNML, (ffeexprCallback) ffestb_R9097_)))
- (t);
- }
-}
+ case FFESTR_formatPEN:
+ if (ffestb_local_.format.pre.present)
+ ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
+ ffestb_subr_R1001_append_p_ ();
+ ffestb_local_.format.t = ffelex_token_name_from_names (t,
+ FFESTR_formatlP, 1);
+ ffestb_local_.format.sign = FALSE;
+ ffestb_local_.format.pre.present = FALSE;
+ ffestb_local_.format.pre.rtexpr = FALSE;
+ ffestb_local_.format.pre.t = NULL;
+ ffestb_local_.format.pre.u.unsigned_val = 1;
+ ffestb_local_.format.current = FFESTP_formattypeEN;
+ i = FFESTR_formatlPEN;
+ break;
-/* ffestb_R9096_ -- "READ" OPEN_PAREN expr COMMA NAME
+ case FFESTR_formatPF:
+ if (ffestb_local_.format.pre.present)
+ ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
+ ffestb_subr_R1001_append_p_ ();
+ ffestb_local_.format.t = ffelex_token_name_from_names (t,
+ FFESTR_formatlP, 1);
+ ffestb_local_.format.sign = FALSE;
+ ffestb_local_.format.pre.present = FALSE;
+ ffestb_local_.format.pre.rtexpr = FALSE;
+ ffestb_local_.format.pre.t = NULL;
+ ffestb_local_.format.pre.u.unsigned_val = 1;
+ ffestb_local_.format.current = FFESTP_formattypeF;
+ i = FFESTR_formatlPF;
+ break;
- return ffestb_R9096_; // to lexer
+ case FFESTR_formatPG:
+ if (ffestb_local_.format.pre.present)
+ ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
+ ffestb_subr_R1001_append_p_ ();
+ ffestb_local_.format.t = ffelex_token_name_from_names (t,
+ FFESTR_formatlP, 1);
+ ffestb_local_.format.sign = FALSE;
+ ffestb_local_.format.pre.present = FALSE;
+ ffestb_local_.format.pre.rtexpr = FALSE;
+ ffestb_local_.format.pre.t = NULL;
+ ffestb_local_.format.pre.u.unsigned_val = 1;
+ ffestb_local_.format.current = FFESTP_formattypeG;
+ i = FFESTR_formatlPG;
+ break;
- If EQUALS here, go to states that handle it. Else, send NAME and this
- token thru expression handler. */
+ default:
+ if (ffestb_local_.format.pre.present)
+ ffesta_confirmed ();/* Number preceding this invalid elsewhere. */
+ ffestb_local_.format.current = FFESTP_formattypeNone;
+ p = strpbrk (ffelex_token_text (t), "0123456789");
+ if (p == NULL)
+ i = ffelex_token_length (t);
+ else
+ i = p - ffelex_token_text (t);
+ break;
+ }
+ p = ffelex_token_text (t) + i;
+ if (*p == '\0')
+ return (ffelexHandler) ffestb_R10015_;
+ if (! ISDIGIT (*p))
+ {
+ if (ffestb_local_.format.current == FFESTP_formattypeH)
+ p = strpbrk (p, "0123456789");
+ else
+ {
+ p = NULL;
+ ffestb_local_.format.current = FFESTP_formattypeNone;
+ }
+ if (p == NULL)
+ return (ffelexHandler) ffestb_R10015_;
+ i = p - ffelex_token_text (t); /* Collect digits. */
+ }
+ ffestb_local_.format.post.present = TRUE;
+ ffestb_local_.format.post.rtexpr = FALSE;
+ ffestb_local_.format.post.t = ffelex_token_number_from_names (t, i);
+ ffestb_local_.format.post.u.unsigned_val
+ = strtoul (ffelex_token_text (ffestb_local_.format.post.t), NULL, 10);
+ p += ffelex_token_length (ffestb_local_.format.post.t);
+ i += ffelex_token_length (ffestb_local_.format.post.t);
+ if (*p == '\0')
+ return (ffelexHandler) ffestb_R10016_;
+ if ((kw != FFESTR_formatP) ||
+ !ffelex_is_firstnamechar ((unsigned char)*p))
+ {
+ if (ffestb_local_.format.current != FFESTP_formattypeH)
+ ffesta_ffebad_1p (FFEBAD_FORMAT_TEXT_IN_NUMBER, t, i, NULL);
+ return (ffelexHandler) ffestb_R10016_;
+ }
-static ffelexHandler
-ffestb_R9096_ (ffelexToken t)
-{
- ffelexHandler next;
- ffelexToken nt;
+ /* Here we have [number]P[number][text]. Treat as
+ [number]P,[number][text]. */
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeEQUALS:
- nt = ffesta_tokens[1];
- next = (ffelexHandler) ffestb_R9098_ (nt);
- ffelex_token_kill (nt);
- return (ffelexHandler) (*next) (t);
+ ffestb_subr_R1001_append_p_ ();
+ t = ffestb_local_.format.t = ffelex_token_names_from_names (t, i, 0);
+ ffestb_local_.format.sign = FALSE;
+ ffestb_local_.format.pre = ffestb_local_.format.post;
+ kw = ffestr_format (t);
+ switch (kw)
+ { /* Only a few possibilities here. */
+ case FFESTR_formatD:
+ ffestb_local_.format.current = FFESTP_formattypeD;
+ i = FFESTR_formatlD;
+ break;
- default:
- nt = ffesta_tokens[1];
- next = (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextFILEFORMATNML, (ffeexprCallback) ffestb_R9097_)))
- (nt);
- ffelex_token_kill (nt);
- return (ffelexHandler) (*next) (t);
- }
-}
+ case FFESTR_formatE:
+ ffestb_local_.format.current = FFESTP_formattypeE;
+ i = FFESTR_formatlE;
+ break;
-/* ffestb_R9097_ -- "READ" OPEN_PAREN expr COMMA expr
+ case FFESTR_formatEN:
+ ffestb_local_.format.current = FFESTP_formattypeEN;
+ i = FFESTR_formatlEN;
+ break;
- (ffestb_R9097_) // to expression handler
+ case FFESTR_formatF:
+ ffestb_local_.format.current = FFESTP_formattypeF;
+ i = FFESTR_formatlF;
+ break;
- Handle COMMA or CLOSE_PAREN here. */
+ case FFESTR_formatG:
+ ffestb_local_.format.current = FFESTP_formattypeG;
+ i = FFESTR_formatlG;
+ break;
-static ffelexHandler
-ffestb_R9097_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- case FFELEX_typeCLOSE_PAREN:
- ffestp_file.read.read_spec[FFESTP_readixFORMAT].kw_or_val_present
- = TRUE;
- ffestp_file.read.read_spec[FFESTP_readixFORMAT].kw_present = FALSE;
- ffestp_file.read.read_spec[FFESTP_readixFORMAT].value_present = TRUE;
- ffestp_file.read.read_spec[FFESTP_readixFORMAT].value_is_label
- = (expr == NULL);
- ffestp_file.read.read_spec[FFESTP_readixFORMAT].value
- = ffelex_token_use (ft);
- ffestp_file.read.read_spec[FFESTP_readixFORMAT].u.expr = expr;
- if (ffelex_token_type (t) == FFELEX_typeCOMMA)
- return (ffelexHandler) ffestb_R9098_;
- return (ffelexHandler) ffestb_R90913_;
+ default:
+ ffebad_start (FFEBAD_FORMAT_P_NOCOMMA);
+ ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
+ ffebad_finish ();
+ ffestb_local_.format.current = FFESTP_formattypeNone;
+ p = strpbrk (ffelex_token_text (t), "0123456789");
+ if (p == NULL)
+ i = ffelex_token_length (t);
+ else
+ i = p - ffelex_token_text (t);
+ }
+ p = ffelex_token_text (t) + i;
+ if (*p == '\0')
+ return (ffelexHandler) ffestb_R10015_;
+ if (! ISDIGIT (*p))
+ {
+ ffestb_local_.format.current = FFESTP_formattypeNone;
+ p = strpbrk (p, "0123456789");
+ if (p == NULL)
+ return (ffelexHandler) ffestb_R10015_;
+ i = p - ffelex_token_text (t); /* Collect digits anyway. */
+ }
+ ffestb_local_.format.post.present = TRUE;
+ ffestb_local_.format.post.rtexpr = FALSE;
+ ffestb_local_.format.post.t = ffelex_token_number_from_names (t, i);
+ ffestb_local_.format.post.u.unsigned_val
+ = strtoul (ffelex_token_text (ffestb_local_.format.post.t), NULL, 10);
+ p += ffelex_token_length (ffestb_local_.format.post.t);
+ i += ffelex_token_length (ffestb_local_.format.post.t);
+ if (*p == '\0')
+ return (ffelexHandler) ffestb_R10016_;
+ ffesta_ffebad_1p (FFEBAD_FORMAT_TEXT_IN_NUMBER, t, i, NULL);
+ return (ffelexHandler) ffestb_R10016_;
default:
break;
}
- ffestb_subr_kill_read_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "READ", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FORMAT", t);
+ if (ffestb_local_.format.pre.present)
+ ffelex_token_kill (ffestb_local_.format.pre.t);
+ ffestt_formatlist_kill (ffestb_local_.format.f);
+ return (ffelexHandler) ffelex_swallow_tokens (t,
+ (ffelexHandler) ffesta_zero);
}
-/* ffestb_R9098_ -- "READ" OPEN_PAREN [external-file-unit COMMA [format
- COMMA]]
+/* ffestb_R10015_ -- [[+/-] NUMBER] NAMES
- return ffestb_R9098_; // to lexer
+ return ffestb_R10015_; // to lexer
- Handle expr construct (not NAME=expr construct) here. */
+ Here we've gotten at least the initial mnemonic for the edit descriptor.
+ We expect either a NUMBER, for the post-mnemonic value, a NAMES, for
+ further clarification (in free-form only, sigh) of the mnemonic, or
+ anything else. In all cases we go to _6_, with the difference that for
+ NUMBER and NAMES we send the next token rather than the current token. */
static ffelexHandler
-ffestb_R9098_ (ffelexToken t)
+ffestb_R10015_ (ffelexToken t)
{
- ffestrGenio kw;
-
- ffestb_local_.read.label = FALSE;
+ bool split_pea; /* New NAMES requires splitting kP from new
+ edit desc. */
+ ffestrFormat kw;
+ const char *p;
+ ffeTokenLength i;
switch (ffelex_token_type (t))
{
- case FFELEX_typeNAME:
- kw = ffestr_genio (t);
- switch (kw)
+ case FFELEX_typeOPEN_ANGLE:
+ ffesta_confirmed ();
+ ffestb_local_.format.post.t = ffelex_token_use (t);
+ ffelex_set_names_pure (FALSE);
+ if (!ffesta_seen_first_exec && !ffestb_local_.format.complained)
{
- case FFESTR_genioADVANCE:
- ffestb_local_.read.ix = FFESTP_readixADVANCE;
- ffestb_local_.read.left = FALSE;
- ffestb_local_.read.context = FFEEXPR_contextFILEDFCHAR;
- break;
+ ffestb_local_.format.complained = TRUE;
+ ffebad_start (FFEBAD_FORMAT_EXPR_SPEC);
+ ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
+ ffebad_finish ();
+ }
+ return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ FFEEXPR_contextFORMAT, (ffeexprCallback) ffestb_R100116_);
- case FFESTR_genioEOR:
- ffestb_local_.read.ix = FFESTP_readixEOR;
- ffestb_local_.read.label = TRUE;
- break;
+ case FFELEX_typeNUMBER:
+ ffestb_local_.format.post.present = TRUE;
+ ffestb_local_.format.post.rtexpr = FALSE;
+ ffestb_local_.format.post.t = ffelex_token_use (t);
+ ffestb_local_.format.post.u.unsigned_val
+ = strtoul (ffelex_token_text (t), NULL, 10);
+ return (ffelexHandler) ffestb_R10016_;
- case FFESTR_genioERR:
- ffestb_local_.read.ix = FFESTP_readixERR;
- ffestb_local_.read.label = TRUE;
+ case FFELEX_typeNAMES:
+ ffesta_confirmed (); /* NAMES " " NAMES invalid elsewhere in
+ free-form. */
+ kw = ffestr_format (t);
+ switch (ffestb_local_.format.current)
+ {
+ case FFESTP_formattypeP:
+ split_pea = TRUE;
break;
- case FFESTR_genioEND:
- ffestb_local_.read.ix = FFESTP_readixEND;
- ffestb_local_.read.label = TRUE;
+ case FFESTP_formattypeH: /* An error, maintain this indicator. */
+ kw = FFESTR_formatNone;
+ split_pea = FALSE;
break;
- case FFESTR_genioFMT:
- ffestb_local_.read.ix = FFESTP_readixFORMAT;
- ffestb_local_.read.left = FALSE;
- ffestb_local_.read.context = FFEEXPR_contextFILEFORMAT;
+ default:
+ split_pea = FALSE;
break;
+ }
- case FFESTR_genioIOSTAT:
- ffestb_local_.read.ix = FFESTP_readixIOSTAT;
- ffestb_local_.read.left = TRUE;
- ffestb_local_.read.context = FFEEXPR_contextFILEINT;
- break;
+ switch (kw)
+ {
+ case FFESTR_formatF:
+ switch (ffestb_local_.format.current)
+ {
+ case FFESTP_formattypeP:
+ ffestb_local_.format.current = FFESTP_formattypeF;
+ break;
- case FFESTR_genioKEY:
- case FFESTR_genioKEYEQ:
- ffestb_local_.read.ix = FFESTP_readixKEYEQ;
- ffestb_local_.read.left = FALSE;
- ffestb_local_.read.context = FFEEXPR_contextFILENUMCHAR;
+ default:
+ ffestb_local_.format.current = FFESTP_formattypeNone;
+ break;
+ }
+ i = FFESTR_formatlF;
break;
- case FFESTR_genioKEYGE:
- ffestb_local_.read.ix = FFESTP_readixKEYGE;
- ffestb_local_.read.left = FALSE;
- ffestb_local_.read.context = FFEEXPR_contextFILENUMCHAR;
+ case FFESTR_formatE:
+ switch (ffestb_local_.format.current)
+ {
+ case FFESTP_formattypeP:
+ ffestb_local_.format.current = FFESTP_formattypeE;
+ break;
+
+ default:
+ ffestb_local_.format.current = FFESTP_formattypeNone;
+ break;
+ }
+ i = FFESTR_formatlE;
break;
- case FFESTR_genioKEYGT:
- ffestb_local_.read.ix = FFESTP_readixKEYGT;
- ffestb_local_.read.left = FALSE;
- ffestb_local_.read.context = FFEEXPR_contextFILENUMCHAR;
+ case FFESTR_formatEN:
+ switch (ffestb_local_.format.current)
+ {
+ case FFESTP_formattypeP:
+ ffestb_local_.format.current = FFESTP_formattypeEN;
+ break;
+
+ default:
+ ffestb_local_.format.current = FFESTP_formattypeNone;
+ break;
+ }
+ i = FFESTR_formatlEN;
break;
- case FFESTR_genioKEYID:
- ffestb_local_.read.ix = FFESTP_readixKEYID;
- ffestb_local_.read.left = FALSE;
- ffestb_local_.read.context = FFEEXPR_contextFILENUM;
- break;
+ case FFESTR_formatG:
+ switch (ffestb_local_.format.current)
+ {
+ case FFESTP_formattypeP:
+ ffestb_local_.format.current = FFESTP_formattypeG;
+ break;
- case FFESTR_genioNML:
- ffestb_local_.read.ix = FFESTP_readixFORMAT;
- ffestb_local_.read.left = TRUE;
- ffestb_local_.read.context = FFEEXPR_contextFILENAMELIST;
+ default:
+ ffestb_local_.format.current = FFESTP_formattypeNone;
+ break;
+ }
+ i = FFESTR_formatlG;
break;
- case FFESTR_genioNULLS:
- ffestb_local_.read.ix = FFESTP_readixNULLS;
- ffestb_local_.read.left = TRUE;
- ffestb_local_.read.context = FFEEXPR_contextFILEINT;
- break;
+ case FFESTR_formatL:
+ switch (ffestb_local_.format.current)
+ {
+ case FFESTP_formattypeT:
+ ffestb_local_.format.current = FFESTP_formattypeTL;
+ break;
- case FFESTR_genioREC:
- ffestb_local_.read.ix = FFESTP_readixREC;
- ffestb_local_.read.left = FALSE;
- ffestb_local_.read.context = FFEEXPR_contextFILENUM;
+ default:
+ ffestb_local_.format.current = FFESTP_formattypeNone;
+ break;
+ }
+ i = FFESTR_formatlL;
break;
- case FFESTR_genioSIZE:
- ffestb_local_.read.ix = FFESTP_readixSIZE;
- ffestb_local_.read.left = TRUE;
- ffestb_local_.read.context = FFEEXPR_contextFILEINT;
- break;
+ case FFESTR_formatD:
+ switch (ffestb_local_.format.current)
+ {
+ case FFESTP_formattypeP:
+ ffestb_local_.format.current = FFESTP_formattypeD;
+ break;
- case FFESTR_genioUNIT:
- ffestb_local_.read.ix = FFESTP_readixUNIT;
- ffestb_local_.read.left = FALSE;
- ffestb_local_.read.context = FFEEXPR_contextFILEUNIT;
+ default:
+ ffestb_local_.format.current = FFESTP_formattypeNone;
+ break;
+ }
+ i = FFESTR_formatlD;
break;
- default:
- goto bad; /* :::::::::::::::::::: */
- }
- if (ffestp_file.read.read_spec[ffestb_local_.read.ix]
- .kw_or_val_present)
- break; /* Can't specify a keyword twice! */
- ffestp_file.read.read_spec[ffestb_local_.read.ix]
- .kw_or_val_present = TRUE;
- ffestp_file.read.read_spec[ffestb_local_.read.ix]
- .kw_present = TRUE;
- ffestp_file.read.read_spec[ffestb_local_.read.ix]
- .value_present = FALSE;
- ffestp_file.read.read_spec[ffestb_local_.read.ix].value_is_label
- = ffestb_local_.read.label;
- ffestp_file.read.read_spec[ffestb_local_.read.ix].kw
- = ffelex_token_use (t);
- return (ffelexHandler) ffestb_R9099_;
-
- default:
- break;
- }
+ case FFESTR_formatS:
+ switch (ffestb_local_.format.current)
+ {
+ case FFESTP_formattypeS:
+ ffestb_local_.format.current = FFESTP_formattypeSS;
+ break;
-bad: /* :::::::::::::::::::: */
- ffestb_subr_kill_read_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "READ", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
+ default:
+ ffestb_local_.format.current = FFESTP_formattypeNone;
+ break;
+ }
+ i = FFESTR_formatlS;
+ break;
-/* ffestb_R9099_ -- "READ" OPEN_PAREN [external-file-unit COMMA [format
- COMMA]] NAME
+ case FFESTR_formatP:
+ switch (ffestb_local_.format.current)
+ {
+ case FFESTP_formattypeS:
+ ffestb_local_.format.current = FFESTP_formattypeSP;
+ break;
- return ffestb_R9099_; // to lexer
+ default:
+ ffestb_local_.format.current = FFESTP_formattypeNone;
+ break;
+ }
+ i = FFESTR_formatlP;
+ break;
- Make sure EQUALS here, send next token to expression handler. */
+ case FFESTR_formatR:
+ switch (ffestb_local_.format.current)
+ {
+ case FFESTP_formattypeT:
+ ffestb_local_.format.current = FFESTP_formattypeTR;
+ break;
-static ffelexHandler
-ffestb_R9099_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeEQUALS:
- ffesta_confirmed ();
- if (ffestb_local_.read.label)
- return (ffelexHandler) ffestb_R90911_;
- if (ffestb_local_.read.left)
- return (ffelexHandler)
- ffeexpr_lhs (ffesta_output_pool,
- ffestb_local_.read.context,
- (ffeexprCallback) ffestb_R90910_);
- return (ffelexHandler)
- ffeexpr_rhs (ffesta_output_pool,
- ffestb_local_.read.context,
- (ffeexprCallback) ffestb_R90910_);
+ default:
+ ffestb_local_.format.current = FFESTP_formattypeNone;
+ break;
+ }
+ i = FFESTR_formatlR;
+ break;
- default:
- break;
- }
+ case FFESTR_formatZ:
+ switch (ffestb_local_.format.current)
+ {
+ case FFESTP_formattypeB:
+ ffestb_local_.format.current = FFESTP_formattypeBZ;
+ break;
- ffestb_subr_kill_read_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "READ", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
+ default:
+ ffestb_local_.format.current = FFESTP_formattypeNone;
+ break;
+ }
+ i = FFESTR_formatlZ;
+ break;
-/* ffestb_R90910_ -- "READ" OPEN_PAREN ... NAME EQUALS expr
+ case FFESTR_formatN:
+ switch (ffestb_local_.format.current)
+ {
+ case FFESTP_formattypeE:
+ ffestb_local_.format.current = FFESTP_formattypeEN;
+ break;
- (ffestb_R90910_) // to expression handler
+ case FFESTP_formattypeB:
+ ffestb_local_.format.current = FFESTP_formattypeBN;
+ break;
- Handle COMMA or CLOSE_PAREN here. */
+ default:
+ ffestb_local_.format.current = FFESTP_formattypeNone;
+ break;
+ }
+ i = FFESTR_formatlN;
+ break;
-static ffelexHandler
-ffestb_R90910_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- case FFELEX_typeCLOSE_PAREN:
- if (expr == NULL)
- {
- if (ffestb_local_.read.context == FFEEXPR_contextFILEFORMAT)
- ffestp_file.read.read_spec[ffestb_local_.read.ix]
- .value_is_label = TRUE;
+ default:
+ if (ffestb_local_.format.current != FFESTP_formattypeH)
+ ffestb_local_.format.current = FFESTP_formattypeNone;
+ split_pea = FALSE; /* Go ahead and let the P be in the party. */
+ p = strpbrk (ffelex_token_text (t), "0123456789");
+ if (p == NULL)
+ i = ffelex_token_length (t);
else
- break;
+ i = p - ffelex_token_text (t);
}
- ffestp_file.read.read_spec[ffestb_local_.read.ix].value_present
- = TRUE;
- ffestp_file.read.read_spec[ffestb_local_.read.ix].value
- = ffelex_token_use (ft);
- ffestp_file.read.read_spec[ffestb_local_.read.ix].u.expr = expr;
- if (ffelex_token_type (t) == FFELEX_typeCOMMA)
- return (ffelexHandler) ffestb_R9098_;
- return (ffelexHandler) ffestb_R90913_;
-
- default:
- break;
- }
-
- ffestb_subr_kill_read_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "READ", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R90911_ -- "READ" OPEN_PAREN ... NAME EQUALS
- return ffestb_R90911_; // to lexer
-
- Handle NUMBER for label here. */
+ if (split_pea)
+ {
+ ffestb_subr_R1001_append_p_ ();
+ ffestb_local_.format.t = ffelex_token_use (t);
+ ffestb_local_.format.sign = FALSE;
+ ffestb_local_.format.pre.present = FALSE;
+ ffestb_local_.format.pre.rtexpr = FALSE;
+ ffestb_local_.format.pre.t = NULL;
+ ffestb_local_.format.pre.u.unsigned_val = 1;
+ }
-static ffelexHandler
-ffestb_R90911_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNUMBER:
- ffestp_file.read.read_spec[ffestb_local_.read.ix].value_present
- = TRUE;
- ffestp_file.read.read_spec[ffestb_local_.read.ix].value
- = ffelex_token_use (t);
- return (ffelexHandler) ffestb_R90912_;
+ p = ffelex_token_text (t) + i;
+ if (*p == '\0')
+ return (ffelexHandler) ffestb_R10015_;
+ if (! ISDIGIT (*p))
+ {
+ ffestb_local_.format.current = FFESTP_formattypeNone;
+ p = strpbrk (p, "0123456789");
+ if (p == NULL)
+ return (ffelexHandler) ffestb_R10015_;
+ i = p - ffelex_token_text (t); /* Collect digits anyway. */
+ }
+ ffestb_local_.format.post.present = TRUE;
+ ffestb_local_.format.post.rtexpr = FALSE;
+ ffestb_local_.format.post.t = ffelex_token_number_from_names (t, i);
+ ffestb_local_.format.post.u.unsigned_val
+ = strtoul (ffelex_token_text (ffestb_local_.format.post.t), NULL, 10);
+ p += ffelex_token_length (ffestb_local_.format.post.t);
+ i += ffelex_token_length (ffestb_local_.format.post.t);
+ if (*p == '\0')
+ return (ffelexHandler) ffestb_R10016_;
+ ffesta_ffebad_1p (FFEBAD_FORMAT_TEXT_IN_NUMBER, t, i, NULL);
+ return (ffelexHandler) ffestb_R10016_;
default:
- break;
+ ffestb_local_.format.post.present = FALSE;
+ ffestb_local_.format.post.rtexpr = FALSE;
+ ffestb_local_.format.post.t = NULL;
+ ffestb_local_.format.post.u.unsigned_val = 1;
+ return (ffelexHandler) ffestb_R10016_ (t);
}
-
- ffestb_subr_kill_read_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "READ", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R90912_ -- "READ" OPEN_PAREN ... NAME EQUALS NUMBER
+/* ffestb_R10016_ -- [[+/-] NUMBER] NAMES NUMBER
- return ffestb_R90912_; // to lexer
+ return ffestb_R10016_; // to lexer
- Handle COMMA or CLOSE_PAREN here. */
+ Expect a PERIOD here. Maybe find a NUMBER to append to the current
+ number, in which case return to this state. Maybe find a NAMES to switch
+ from a kP descriptor to a new descriptor (else the NAMES is spurious),
+ in which case generator the P item and go to state _4_. Anything
+ else, pass token on to state _8_. */
static ffelexHandler
-ffestb_R90912_ (ffelexToken t)
+ffestb_R10016_ (ffelexToken t)
{
+ ffeTokenLength i;
+
switch (ffelex_token_type (t))
{
- case FFELEX_typeCOMMA:
- return (ffelexHandler) ffestb_R9098_;
+ case FFELEX_typePERIOD:
+ return (ffelexHandler) ffestb_R10017_;
- case FFELEX_typeCLOSE_PAREN:
- return (ffelexHandler) ffestb_R90913_;
+ case FFELEX_typeNUMBER:
+ assert (ffestb_local_.format.post.present);
+ ffesta_confirmed ();
+ if (ffestb_local_.format.post.rtexpr)
+ {
+ ffebad_start (FFEBAD_FORMAT_SPURIOUS_NUMBER);
+ ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
+ ffebad_finish ();
+ return (ffelexHandler) ffestb_R10016_;
+ }
+ for (i = ffelex_token_length (t) + 1; i > 0; --i)
+ ffestb_local_.format.post.u.unsigned_val *= 10;
+ ffestb_local_.format.post.u.unsigned_val += strtoul (ffelex_token_text (t),
+ NULL, 10);
+ return (ffelexHandler) ffestb_R10016_;
+
+ case FFELEX_typeNAMES:
+ ffesta_confirmed (); /* NUMBER " " NAMES invalid elsewhere. */
+ if (ffestb_local_.format.current != FFESTP_formattypeP)
+ {
+ ffesta_ffebad_1t (FFEBAD_FORMAT_TEXT_IN_NUMBER, t);
+ return (ffelexHandler) ffestb_R10016_;
+ }
+ ffestb_subr_R1001_append_p_ ();
+ ffestb_local_.format.sign = FALSE;
+ ffestb_local_.format.pre = ffestb_local_.format.post;
+ return (ffelexHandler) ffestb_R10014_ (t);
default:
- break;
+ ffestb_local_.format.dot.present = FALSE;
+ ffestb_local_.format.dot.rtexpr = FALSE;
+ ffestb_local_.format.dot.t = NULL;
+ ffestb_local_.format.dot.u.unsigned_val = 1;
+ return (ffelexHandler) ffestb_R10018_ (t);
}
-
- ffestb_subr_kill_read_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "READ", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R90913_ -- "READ" OPEN_PAREN ... CLOSE_PAREN
-
- return ffestb_R90913_; // to lexer
+/* ffestb_R10017_ -- [[+/-] NUMBER] NAMES NUMBER PERIOD
- Handle EOS or SEMICOLON here.
+ return ffestb_R10017_; // to lexer
- 15-Feb-91 JCB 1.1
- Fix to allow implied-DO construct here (OPEN_PAREN) -- actually,
- don't presume knowledge of what an initial token in an lhs context
- is going to be, let ffeexpr_lhs handle that as much as possible. */
+ Here we've gotten the period following the edit descriptor.
+ We expect either a NUMBER, for the dot value, or something else, which
+ probably means we're not even close to being in a real FORMAT statement. */
static ffelexHandler
-ffestb_R90913_ (ffelexToken t)
+ffestb_R10017_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
+ case FFELEX_typeOPEN_ANGLE:
+ ffestb_local_.format.dot.t = ffelex_token_use (t);
+ ffelex_set_names_pure (FALSE);
+ if (!ffesta_seen_first_exec && !ffestb_local_.format.complained)
{
- ffestc_R909_start (FALSE);
- ffestc_R909_finish ();
+ ffestb_local_.format.complained = TRUE;
+ ffebad_start (FFEBAD_FORMAT_EXPR_SPEC);
+ ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
+ ffebad_finish ();
}
- ffestb_subr_kill_read_ ();
- return (ffelexHandler) ffesta_zero (t);
+ return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ FFEEXPR_contextFORMAT, (ffeexprCallback) ffestb_R100117_);
+
+ case FFELEX_typeNUMBER:
+ ffestb_local_.format.dot.present = TRUE;
+ ffestb_local_.format.dot.rtexpr = FALSE;
+ ffestb_local_.format.dot.t = ffelex_token_use (t);
+ ffestb_local_.format.dot.u.unsigned_val
+ = strtoul (ffelex_token_text (t), NULL, 10);
+ return (ffelexHandler) ffestb_R10018_;
default:
- ffesta_confirmed ();
- /* Fall through. */
- case FFELEX_typeOPEN_PAREN: /* Could still be assignment!! */
- break;
+ ffelex_token_kill (ffestb_local_.format.t);
+ if (ffestb_local_.format.pre.present)
+ ffelex_token_kill (ffestb_local_.format.pre.t);
+ if (ffestb_local_.format.post.present)
+ ffelex_token_kill (ffestb_local_.format.post.t);
+ ffesta_ffebad_1t (FFEBAD_FORMAT_MISSING_DOT, t);
+ ffestt_formatlist_kill (ffestb_local_.format.f);
+ return (ffelexHandler) ffelex_swallow_tokens (t,
+ (ffelexHandler) ffesta_zero);
}
-
- /* If token isn't NAME or OPEN_PAREN, ffeexpr_lhs will ultimately whine
- about it, so leave it up to that code. */
-
- /* EXTENSION: Allow an optional preceding COMMA here if not pedantic. (f2c
- provides this extension, as do other compilers, supposedly.) */
-
- if (!ffe_is_pedantic () && (ffelex_token_type (t) == FFELEX_typeCOMMA))
- return (ffelexHandler)
- ffeexpr_lhs (ffesta_output_pool,
- ffestc_context_iolist (),
- (ffeexprCallback) ffestb_R90914_);
-
- return (ffelexHandler) (*((ffelexHandler)
- ffeexpr_lhs (ffesta_output_pool,
- ffestc_context_iolist (),
- (ffeexprCallback) ffestb_R90914_)))
- (t);
}
-/* ffestb_R90914_ -- "READ(...)" expr
+/* ffestb_R10018_ -- [[+/-] NUMBER] NAMES NUMBER PERIOD NUMBER
- (ffestb_R90914_) // to expression handler
+ return ffestb_R10018_; // to lexer
- Handle COMMA or EOS/SEMICOLON here. */
+ Expect a NAMES here, which must begin with "E" to be valid. Maybe find a
+ NUMBER to append to the current number, in which case return to this state.
+ Anything else, pass token on to state _10_. */
static ffelexHandler
-ffestb_R90914_ (ffelexToken ft, ffebld expr, ffelexToken t)
+ffestb_R10018_ (ffelexToken t)
{
+ ffeTokenLength i;
+ const char *p;
+
switch (ffelex_token_type (t))
{
- case FFELEX_typeCOMMA:
- if (expr == NULL)
- break;
-
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- ffestc_R909_start (FALSE);
- ffestb_subr_kill_read_ ();
-
- if (!ffesta_is_inhibited ())
- ffestc_R909_item (expr, ft);
- return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool,
- ffestc_context_iolist (),
- (ffeexprCallback) ffestb_R90915_);
-
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- if (expr == NULL)
- break;
-
+ case FFELEX_typeNUMBER:
+ assert (ffestb_local_.format.dot.present);
ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- ffestc_R909_start (FALSE);
- ffestb_subr_kill_read_ ();
+ if (ffestb_local_.format.dot.rtexpr)
+ {
+ ffebad_start (FFEBAD_FORMAT_SPURIOUS_NUMBER);
+ ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
+ ffebad_finish ();
+ return (ffelexHandler) ffestb_R10018_;
+ }
+ for (i = ffelex_token_length (t) + 1; i > 0; --i)
+ ffestb_local_.format.dot.u.unsigned_val *= 10;
+ ffestb_local_.format.dot.u.unsigned_val += strtoul (ffelex_token_text (t),
+ NULL, 10);
+ return (ffelexHandler) ffestb_R10018_;
- if (!ffesta_is_inhibited ())
+ case FFELEX_typeNAMES:
+ if (!ffesrc_char_match_init (*(p = ffelex_token_text (t)), 'E', 'e'))
{
- ffestc_R909_item (expr, ft);
- ffestc_R909_finish ();
+ ffesta_ffebad_1t (FFEBAD_FORMAT_TEXT_IN_NUMBER, t);
+ return (ffelexHandler) ffestb_R10018_;
}
- return (ffelexHandler) ffesta_zero (t);
+ if (*++p == '\0')
+ return (ffelexHandler) ffestb_R10019_; /* Go get NUMBER. */
+ i = 1;
+ if (! ISDIGIT (*p))
+ {
+ ffesta_ffebad_1p (FFEBAD_FORMAT_TEXT_IN_NUMBER, t, 1, NULL);
+ return (ffelexHandler) ffestb_R10018_;
+ }
+ ffestb_local_.format.exp.present = TRUE;
+ ffestb_local_.format.exp.rtexpr = FALSE;
+ ffestb_local_.format.exp.t = ffelex_token_number_from_names (t, i);
+ ffestb_local_.format.exp.u.unsigned_val
+ = strtoul (ffelex_token_text (ffestb_local_.format.exp.t), NULL, 10);
+ p += ffelex_token_length (ffestb_local_.format.exp.t);
+ i += ffelex_token_length (ffestb_local_.format.exp.t);
+ if (*p == '\0')
+ return (ffelexHandler) ffestb_R100110_;
+ ffesta_ffebad_1p (FFEBAD_FORMAT_TEXT_IN_NUMBER, t, i, NULL);
+ return (ffelexHandler) ffestb_R100110_;
default:
- break;
+ ffestb_local_.format.exp.present = FALSE;
+ ffestb_local_.format.exp.rtexpr = FALSE;
+ ffestb_local_.format.exp.t = NULL;
+ ffestb_local_.format.exp.u.unsigned_val = 1;
+ return (ffelexHandler) ffestb_R100110_ (t);
}
-
- ffestb_subr_kill_read_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "READ", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R90915_ -- "READ(...)" expr COMMA expr
+/* ffestb_R10019_ -- [[+/-] NUMBER] NAMES NUMBER PERIOD NUMBER "E"
- (ffestb_R90915_) // to expression handler
+ return ffestb_R10019_; // to lexer
- Handle COMMA or EOS/SEMICOLON here. */
+ Here we've gotten the "E" following the edit descriptor.
+ We expect either a NUMBER, for the exponent value, or something else. */
static ffelexHandler
-ffestb_R90915_ (ffelexToken ft, ffebld expr, ffelexToken t)
+ffestb_R10019_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeCOMMA:
- if (expr == NULL)
- break;
- if (!ffesta_is_inhibited ())
- ffestc_R909_item (expr, ft);
- return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool,
- ffestc_context_iolist (),
- (ffeexprCallback) ffestb_R90915_);
-
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- if (expr == NULL)
- break;
- if (!ffesta_is_inhibited ())
+ case FFELEX_typeOPEN_ANGLE:
+ ffestb_local_.format.exp.t = ffelex_token_use (t);
+ ffelex_set_names_pure (FALSE);
+ if (!ffesta_seen_first_exec && !ffestb_local_.format.complained)
{
- ffestc_R909_item (expr, ft);
- ffestc_R909_finish ();
+ ffestb_local_.format.complained = TRUE;
+ ffebad_start (FFEBAD_FORMAT_EXPR_SPEC);
+ ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
+ ffebad_finish ();
}
- return (ffelexHandler) ffesta_zero (t);
+ return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ FFEEXPR_contextFORMAT, (ffeexprCallback) ffestb_R100118_);
+
+ case FFELEX_typeNUMBER:
+ ffestb_local_.format.exp.present = TRUE;
+ ffestb_local_.format.exp.rtexpr = FALSE;
+ ffestb_local_.format.exp.t = ffelex_token_use (t);
+ ffestb_local_.format.exp.u.unsigned_val
+ = strtoul (ffelex_token_text (t), NULL, 10);
+ return (ffelexHandler) ffestb_R100110_;
default:
- break;
+ ffelex_token_kill (ffestb_local_.format.t);
+ if (ffestb_local_.format.pre.present)
+ ffelex_token_kill (ffestb_local_.format.pre.t);
+ if (ffestb_local_.format.post.present)
+ ffelex_token_kill (ffestb_local_.format.post.t);
+ if (ffestb_local_.format.dot.present)
+ ffelex_token_kill (ffestb_local_.format.dot.t);
+ ffesta_ffebad_1t (FFEBAD_FORMAT_MISSING_EXP, t);
+ ffestt_formatlist_kill (ffestb_local_.format.f);
+ return (ffelexHandler) ffelex_swallow_tokens (t,
+ (ffelexHandler) ffesta_zero);
}
-
- if (!ffesta_is_inhibited ())
- ffestc_R909_finish ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "READ", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R910 -- Parse the WRITE statement
+/* ffestb_R100110_ -- [[+/-] NUMBER] NAMES NUMBER [PERIOD NUMBER ["E" NUMBER]]
- return ffestb_R910; // to lexer
+ return ffestb_R100110_; // to lexer
- Make sure the statement has a valid form for the WRITE
- statement. If it does, implement the statement. */
+ Maybe find a NUMBER to append to the current number, in which case return
+ to this state. Anything else, handle current descriptor, then pass token
+ on to state _10_. */
-ffelexHandler
-ffestb_R910 (ffelexToken t)
+static ffelexHandler
+ffestb_R100110_ (ffelexToken t)
{
- ffestpWriteIx ix;
+ ffeTokenLength i;
+ enum expect
+ {
+ required,
+ optional,
+ disallowed
+ };
+ ffebad err;
+ enum expect pre;
+ enum expect post;
+ enum expect dot;
+ enum expect exp;
+ bool R1005;
+ ffesttFormatList f;
- switch (ffelex_token_type (ffesta_tokens[0]))
+ switch (ffelex_token_type (t))
{
- case FFELEX_typeNAME:
- if (ffesta_first_kw != FFESTR_firstWRITE)
- goto bad_0; /* :::::::::::::::::::: */
- switch (ffelex_token_type (t))
+ case FFELEX_typeNUMBER:
+ assert (ffestb_local_.format.exp.present);
+ ffesta_confirmed ();
+ if (ffestb_local_.format.exp.rtexpr)
{
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- case FFELEX_typeNAME:
- case FFELEX_typeNUMBER:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
-
- default:
- goto bad_1; /* :::::::::::::::::::: */
-
- case FFELEX_typeOPEN_PAREN:
- for (ix = 0; ix < FFESTP_writeix; ++ix)
- ffestp_file.write.write_spec[ix].kw_or_val_present = FALSE;
- return (ffelexHandler) ffestb_R9101_;
+ ffebad_start (FFEBAD_FORMAT_SPURIOUS_NUMBER);
+ ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
+ ffebad_finish ();
+ return (ffelexHandler) ffestb_R100110_;
}
+ for (i = ffelex_token_length (t) + 1; i > 0; --i)
+ ffestb_local_.format.exp.u.unsigned_val *= 10;
+ ffestb_local_.format.exp.u.unsigned_val += strtoul (ffelex_token_text (t),
+ NULL, 10);
+ return (ffelexHandler) ffestb_R100110_;
- case FFELEX_typeNAMES:
- if (ffesta_first_kw != FFESTR_firstWRITE)
- goto bad_0; /* :::::::::::::::::::: */
- switch (ffelex_token_type (t))
+ default:
+ if (ffestb_local_.format.sign
+ && (ffestb_local_.format.current != FFESTP_formattypeP)
+ && (ffestb_local_.format.current != FFESTP_formattypeH))
{
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
-
- default:
- goto bad_1; /* :::::::::::::::::::: */
-
- case FFELEX_typeOPEN_PAREN:
- if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlWRITE)
- goto bad_0; /* :::::::::::::::::::: */
-
- for (ix = 0; ix < FFESTP_writeix; ++ix)
- ffestp_file.write.write_spec[ix].kw_or_val_present = FALSE;
- return (ffelexHandler) ffestb_R9101_;
+ ffebad_start (FFEBAD_FORMAT_SPURIOUS_SIGN);
+ ffebad_here (0, ffelex_token_where_line (ffestb_local_.format.pre.t),
+ ffelex_token_where_column (ffestb_local_.format.pre.t));
+ ffebad_finish ();
+ ffestb_local_.format.pre.u.unsigned_val
+ = (ffestb_local_.format.pre.u.signed_val < 0)
+ ? -ffestb_local_.format.pre.u.signed_val
+ : ffestb_local_.format.pre.u.signed_val;
}
+ switch (ffestb_local_.format.current)
+ {
+ case FFESTP_formattypeI:
+ err = FFEBAD_FORMAT_BAD_I_SPEC;
+ pre = optional;
+ post = required;
+ dot = optional;
+ exp = disallowed;
+ R1005 = TRUE;
+ break;
- default:
- goto bad_0; /* :::::::::::::::::::: */
- }
+ case FFESTP_formattypeB:
+ err = FFEBAD_FORMAT_BAD_B_SPEC;
+ pre = optional;
+ post = required;
+ dot = optional;
+ exp = disallowed;
+ R1005 = TRUE;
+ break;
-bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "WRITE", ffesta_tokens[0]);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+ case FFESTP_formattypeO:
+ err = FFEBAD_FORMAT_BAD_O_SPEC;
+ pre = optional;
+ post = required;
+ dot = optional;
+ exp = disallowed;
+ R1005 = TRUE;
+ break;
-bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "WRITE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero); /* Invalid second token. */
-}
+ case FFESTP_formattypeZ:
+ err = FFEBAD_FORMAT_BAD_Z_SPEC;
+ pre = optional;
+ post = required;
+ dot = optional;
+ exp = disallowed;
+ R1005 = TRUE;
+ break;
-/* ffestb_R9101_ -- "WRITE" OPEN_PAREN
+ case FFESTP_formattypeF:
+ err = FFEBAD_FORMAT_BAD_F_SPEC;
+ pre = optional;
+ post = required;
+ dot = required;
+ exp = disallowed;
+ R1005 = TRUE;
+ break;
- return ffestb_R9101_; // to lexer
+ case FFESTP_formattypeE:
+ err = FFEBAD_FORMAT_BAD_E_SPEC;
+ pre = optional;
+ post = required;
+ dot = required;
+ exp = optional;
+ R1005 = TRUE;
+ break;
- Handle expr construct (not NAME=expr construct) here. */
+ case FFESTP_formattypeEN:
+ err = FFEBAD_FORMAT_BAD_EN_SPEC;
+ pre = optional;
+ post = required;
+ dot = required;
+ exp = optional;
+ R1005 = TRUE;
+ break;
-static ffelexHandler
-ffestb_R9101_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_R9102_;
+ case FFESTP_formattypeG:
+ err = FFEBAD_FORMAT_BAD_G_SPEC;
+ pre = optional;
+ post = required;
+ dot = required;
+ exp = optional;
+ R1005 = TRUE;
+ break;
- default:
- return (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextFILEUNIT, (ffeexprCallback) ffestb_R9103_)))
- (t);
- }
-}
+ case FFESTP_formattypeL:
+ err = FFEBAD_FORMAT_BAD_L_SPEC;
+ pre = optional;
+ post = required;
+ dot = disallowed;
+ exp = disallowed;
+ R1005 = TRUE;
+ break;
+
+ case FFESTP_formattypeA:
+ err = FFEBAD_FORMAT_BAD_A_SPEC;
+ pre = optional;
+ post = optional;
+ dot = disallowed;
+ exp = disallowed;
+ R1005 = TRUE;
+ break;
-/* ffestb_R9102_ -- "WRITE" OPEN_PAREN NAME
+ case FFESTP_formattypeD:
+ err = FFEBAD_FORMAT_BAD_D_SPEC;
+ pre = optional;
+ post = required;
+ dot = required;
+ exp = disallowed;
+ R1005 = TRUE;
+ break;
- return ffestb_R9102_; // to lexer
+ case FFESTP_formattypeQ:
+ err = FFEBAD_FORMAT_BAD_Q_SPEC;
+ pre = disallowed;
+ post = disallowed;
+ dot = disallowed;
+ exp = disallowed;
+ R1005 = FALSE;
+ break;
- If EQUALS here, go to states that handle it. Else, send NAME and this
- token thru expression handler. */
+ case FFESTP_formattypeDOLLAR:
+ err = FFEBAD_FORMAT_BAD_DOLLAR_SPEC;
+ pre = disallowed;
+ post = disallowed;
+ dot = disallowed;
+ exp = disallowed;
+ R1005 = FALSE;
+ break;
-static ffelexHandler
-ffestb_R9102_ (ffelexToken t)
-{
- ffelexHandler next;
- ffelexToken nt;
+ case FFESTP_formattypeP:
+ err = FFEBAD_FORMAT_BAD_P_SPEC;
+ pre = required;
+ post = disallowed;
+ dot = disallowed;
+ exp = disallowed;
+ R1005 = FALSE;
+ break;
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeEQUALS:
- nt = ffesta_tokens[1];
- next = (ffelexHandler) ffestb_R9107_ (nt);
- ffelex_token_kill (nt);
- return (ffelexHandler) (*next) (t);
+ case FFESTP_formattypeT:
+ err = FFEBAD_FORMAT_BAD_T_SPEC;
+ pre = disallowed;
+ post = required;
+ dot = disallowed;
+ exp = disallowed;
+ R1005 = FALSE;
+ break;
- default:
- nt = ffesta_tokens[1];
- next = (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextFILEUNIT, (ffeexprCallback) ffestb_R9103_)))
- (nt);
- ffelex_token_kill (nt);
- return (ffelexHandler) (*next) (t);
- }
-}
+ case FFESTP_formattypeTL:
+ err = FFEBAD_FORMAT_BAD_TL_SPEC;
+ pre = disallowed;
+ post = required;
+ dot = disallowed;
+ exp = disallowed;
+ R1005 = FALSE;
+ break;
-/* ffestb_R9103_ -- "WRITE" OPEN_PAREN expr [CLOSE_PAREN]
+ case FFESTP_formattypeTR:
+ err = FFEBAD_FORMAT_BAD_TR_SPEC;
+ pre = disallowed;
+ post = required;
+ dot = disallowed;
+ exp = disallowed;
+ R1005 = FALSE;
+ break;
- (ffestb_R9103_) // to expression handler
+ case FFESTP_formattypeX:
+ err = FFEBAD_FORMAT_BAD_X_SPEC;
+ pre = ffe_is_pedantic() ? required : optional;
+ post = disallowed;
+ dot = disallowed;
+ exp = disallowed;
+ R1005 = FALSE;
+ break;
- Handle COMMA or EOS/SEMICOLON here. */
+ case FFESTP_formattypeS:
+ err = FFEBAD_FORMAT_BAD_S_SPEC;
+ pre = disallowed;
+ post = disallowed;
+ dot = disallowed;
+ exp = disallowed;
+ R1005 = FALSE;
+ break;
-static ffelexHandler
-ffestb_R9103_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- case FFELEX_typeCLOSE_PAREN:
- if (expr == NULL)
- break;
- ffestp_file.write.write_spec[FFESTP_writeixUNIT].kw_or_val_present
- = TRUE;
- ffestp_file.write.write_spec[FFESTP_writeixUNIT].kw_present = FALSE;
- ffestp_file.write.write_spec[FFESTP_writeixUNIT].value_present = TRUE;
- ffestp_file.write.write_spec[FFESTP_writeixUNIT].value_is_label
- = FALSE;
- ffestp_file.write.write_spec[FFESTP_writeixUNIT].value
- = ffelex_token_use (ft);
- ffestp_file.write.write_spec[FFESTP_writeixUNIT].u.expr = expr;
- if (ffelex_token_type (t) == FFELEX_typeCOMMA)
- return (ffelexHandler) ffestb_R9104_;
- return (ffelexHandler) ffestb_R91012_;
+ case FFESTP_formattypeSP:
+ err = FFEBAD_FORMAT_BAD_SP_SPEC;
+ pre = disallowed;
+ post = disallowed;
+ dot = disallowed;
+ exp = disallowed;
+ R1005 = FALSE;
+ break;
- default:
- break;
- }
+ case FFESTP_formattypeSS:
+ err = FFEBAD_FORMAT_BAD_SS_SPEC;
+ pre = disallowed;
+ post = disallowed;
+ dot = disallowed;
+ exp = disallowed;
+ R1005 = FALSE;
+ break;
- ffestb_subr_kill_write_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "WRITE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
+ case FFESTP_formattypeBN:
+ err = FFEBAD_FORMAT_BAD_BN_SPEC;
+ pre = disallowed;
+ post = disallowed;
+ dot = disallowed;
+ exp = disallowed;
+ R1005 = FALSE;
+ break;
-/* ffestb_R9104_ -- "WRITE" OPEN_PAREN expr COMMA
+ case FFESTP_formattypeBZ:
+ err = FFEBAD_FORMAT_BAD_BZ_SPEC;
+ pre = disallowed;
+ post = disallowed;
+ dot = disallowed;
+ exp = disallowed;
+ R1005 = FALSE;
+ break;
- return ffestb_R9104_; // to lexer
+ case FFESTP_formattypeH: /* Definitely an error, make sure of
+ it. */
+ err = FFEBAD_FORMAT_BAD_H_SPEC;
+ pre = ffestb_local_.format.pre.present ? disallowed : required;
+ post = disallowed;
+ dot = disallowed;
+ exp = disallowed;
+ R1005 = FALSE;
+ break;
- Handle expr construct (not NAME=expr construct) here. */
+ case FFESTP_formattypeNone:
+ ffesta_ffebad_1t (FFEBAD_FORMAT_BAD_SPEC,
+ ffestb_local_.format.t);
-static ffelexHandler
-ffestb_R9104_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_R9105_;
+ clean_up_to_11_: /* :::::::::::::::::::: */
- default:
- return (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextFILEFORMATNML, (ffeexprCallback) ffestb_R9106_)))
- (t);
+ ffelex_token_kill (ffestb_local_.format.t);
+ if (ffestb_local_.format.pre.present)
+ ffelex_token_kill (ffestb_local_.format.pre.t);
+ if (ffestb_local_.format.post.present)
+ ffelex_token_kill (ffestb_local_.format.post.t);
+ if (ffestb_local_.format.dot.present)
+ ffelex_token_kill (ffestb_local_.format.dot.t);
+ if (ffestb_local_.format.exp.present)
+ ffelex_token_kill (ffestb_local_.format.exp.t);
+ return (ffelexHandler) ffestb_R100111_ (t);
+
+ default:
+ assert ("bad format item" == NULL);
+ err = FFEBAD_FORMAT_BAD_H_SPEC;
+ pre = disallowed;
+ post = disallowed;
+ dot = disallowed;
+ exp = disallowed;
+ R1005 = FALSE;
+ break;
+ }
+ if (((pre == disallowed) && ffestb_local_.format.pre.present)
+ || ((pre == required) && !ffestb_local_.format.pre.present))
+ {
+ ffesta_ffebad_1t (err, (pre == required)
+ ? ffestb_local_.format.t : ffestb_local_.format.pre.t);
+ goto clean_up_to_11_; /* :::::::::::::::::::: */
+ }
+ if (((post == disallowed) && ffestb_local_.format.post.present)
+ || ((post == required) && !ffestb_local_.format.post.present))
+ {
+ ffesta_ffebad_1t (err, (post == required)
+ ? ffestb_local_.format.t : ffestb_local_.format.post.t);
+ goto clean_up_to_11_; /* :::::::::::::::::::: */
+ }
+ if (((dot == disallowed) && ffestb_local_.format.dot.present)
+ || ((dot == required) && !ffestb_local_.format.dot.present))
+ {
+ ffesta_ffebad_1t (err, (dot == required)
+ ? ffestb_local_.format.t : ffestb_local_.format.dot.t);
+ goto clean_up_to_11_; /* :::::::::::::::::::: */
+ }
+ if (((exp == disallowed) && ffestb_local_.format.exp.present)
+ || ((exp == required) && !ffestb_local_.format.exp.present))
+ {
+ ffesta_ffebad_1t (err, (exp == required)
+ ? ffestb_local_.format.t : ffestb_local_.format.exp.t);
+ goto clean_up_to_11_; /* :::::::::::::::::::: */
+ }
+ f = ffestt_formatlist_append (ffestb_local_.format.f);
+ f->type = ffestb_local_.format.current;
+ f->t = ffestb_local_.format.t;
+ if (R1005)
+ {
+ f->u.R1005.R1004 = ffestb_local_.format.pre;
+ f->u.R1005.R1006 = ffestb_local_.format.post;
+ f->u.R1005.R1007_or_R1008 = ffestb_local_.format.dot;
+ f->u.R1005.R1009 = ffestb_local_.format.exp;
+ }
+ else
+ /* Must be R1010. */
+ {
+ if (pre == disallowed)
+ f->u.R1010.val = ffestb_local_.format.post;
+ else
+ f->u.R1010.val = ffestb_local_.format.pre;
+ }
+ return (ffelexHandler) ffestb_R100111_ (t);
}
}
-/* ffestb_R9105_ -- "WRITE" OPEN_PAREN expr COMMA NAME
+/* ffestb_R100111_ -- edit-descriptor
- return ffestb_R9105_; // to lexer
+ return ffestb_R100111_; // to lexer
- If EQUALS here, go to states that handle it. Else, send NAME and this
- token thru expression handler. */
+ Expect a COMMA, CLOSE_PAREN, CLOSE_ARRAY, COLON, COLONCOLON, SLASH, or
+ CONCAT, or complain about missing comma. */
static ffelexHandler
-ffestb_R9105_ (ffelexToken t)
+ffestb_R100111_ (ffelexToken t)
{
- ffelexHandler next;
- ffelexToken nt;
+ ffesttFormatList f;
switch (ffelex_token_type (t))
{
- case FFELEX_typeEQUALS:
- nt = ffesta_tokens[1];
- next = (ffelexHandler) ffestb_R9107_ (nt);
- ffelex_token_kill (nt);
- return (ffelexHandler) (*next) (t);
+ case FFELEX_typeCOMMA:
+ return (ffelexHandler) ffestb_R10012_;
- default:
- nt = ffesta_tokens[1];
- next = (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextFILEFORMATNML, (ffeexprCallback) ffestb_R9106_)))
- (nt);
- ffelex_token_kill (nt);
- return (ffelexHandler) (*next) (t);
- }
-}
+ case FFELEX_typeCOLON:
+ case FFELEX_typeCOLONCOLON:
+ case FFELEX_typeSLASH:
+ case FFELEX_typeCONCAT:
+ return (ffelexHandler) ffestb_R10012_ (t);
-/* ffestb_R9106_ -- "WRITE" OPEN_PAREN expr COMMA expr
+ case FFELEX_typeCLOSE_PAREN:
+ f = ffestb_local_.format.f->u.root.parent;
+ if (f == NULL)
+ return (ffelexHandler) ffestb_R100114_;
+ ffestb_local_.format.f = f->next;
+ return (ffelexHandler) ffestb_R100111_;
- (ffestb_R9106_) // to expression handler
+ case FFELEX_typeCLOSE_ARRAY: /* "/)". */
+ f = ffestt_formatlist_append (ffestb_local_.format.f);
+ f->type = FFESTP_formattypeSLASH;
+ f->t = ffelex_token_use (t);
+ f->u.R1010.val.present = FALSE;
+ f->u.R1010.val.rtexpr = FALSE;
+ f->u.R1010.val.t = NULL;
+ f->u.R1010.val.u.unsigned_val = 1;
+ f = ffestb_local_.format.f->u.root.parent;
+ if (f == NULL)
+ return (ffelexHandler) ffestb_R100114_;
+ ffestb_local_.format.f = f->next;
+ return (ffelexHandler) ffestb_R100111_;
- Handle COMMA or CLOSE_PAREN here. */
+ case FFELEX_typeOPEN_ANGLE:
+ case FFELEX_typeDOLLAR:
+ case FFELEX_typeNUMBER:
+ case FFELEX_typeOPEN_PAREN:
+ case FFELEX_typeOPEN_ARRAY:
+ case FFELEX_typeQUOTE:
+ case FFELEX_typeAPOSTROPHE:
+ case FFELEX_typeNAMES:
+ ffesta_ffebad_1t (FFEBAD_FORMAT_MISSING_COMMA, t);
+ return (ffelexHandler) ffestb_R10012_ (t);
-static ffelexHandler
-ffestb_R9106_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- case FFELEX_typeCLOSE_PAREN:
- ffestp_file.write.write_spec[FFESTP_writeixFORMAT].kw_or_val_present
- = TRUE;
- ffestp_file.write.write_spec[FFESTP_writeixFORMAT].kw_present = FALSE;
- ffestp_file.write.write_spec[FFESTP_writeixFORMAT].value_present = TRUE;
- ffestp_file.write.write_spec[FFESTP_writeixFORMAT].value_is_label
- = (expr == NULL);
- ffestp_file.write.write_spec[FFESTP_writeixFORMAT].value
- = ffelex_token_use (ft);
- ffestp_file.write.write_spec[FFESTP_writeixFORMAT].u.expr = expr;
- if (ffelex_token_type (t) == FFELEX_typeCOMMA)
- return (ffelexHandler) ffestb_R9107_;
- return (ffelexHandler) ffestb_R91012_;
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ ffesta_confirmed ();
+ ffesta_ffebad_1t (FFEBAD_FORMAT_MISSING_PAREN, t);
+ for (f = ffestb_local_.format.f;
+ f->u.root.parent != NULL;
+ f = f->u.root.parent->next)
+ ;
+ ffestb_local_.format.f = f;
+ return (ffelexHandler) ffestb_R100114_ (t);
default:
- break;
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FORMAT", t);
+ ffestt_formatlist_kill (ffestb_local_.format.f);
+ return (ffelexHandler) ffelex_swallow_tokens (t,
+ (ffelexHandler) ffesta_zero);
}
-
- ffestb_subr_kill_write_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "WRITE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R9107_ -- "WRITE" OPEN_PAREN [external-file-unit COMMA [format
- COMMA]]
+/* ffestb_R100112_ -- COLON, COLONCOLON, SLASH, OPEN_ARRAY, or CONCAT
- return ffestb_R9107_; // to lexer
+ return ffestb_R100112_; // to lexer
- Handle expr construct (not NAME=expr construct) here. */
+ Like _11_ except the COMMA is optional. */
static ffelexHandler
-ffestb_R9107_ (ffelexToken t)
+ffestb_R100112_ (ffelexToken t)
{
- ffestrGenio kw;
-
- ffestb_local_.write.label = FALSE;
+ ffesttFormatList f;
switch (ffelex_token_type (t))
{
- case FFELEX_typeNAME:
- kw = ffestr_genio (t);
- switch (kw)
- {
- case FFESTR_genioADVANCE:
- ffestb_local_.write.ix = FFESTP_writeixADVANCE;
- ffestb_local_.write.left = FALSE;
- ffestb_local_.write.context = FFEEXPR_contextFILEDFCHAR;
- break;
+ case FFELEX_typeCOMMA:
+ return (ffelexHandler) ffestb_R10012_;
- case FFESTR_genioEOR:
- ffestb_local_.write.ix = FFESTP_writeixEOR;
- ffestb_local_.write.label = TRUE;
- break;
+ case FFELEX_typeCOLON:
+ case FFELEX_typeCOLONCOLON:
+ case FFELEX_typeSLASH:
+ case FFELEX_typeCONCAT:
+ case FFELEX_typeOPEN_ANGLE:
+ case FFELEX_typeNAMES:
+ case FFELEX_typeDOLLAR:
+ case FFELEX_typeNUMBER:
+ case FFELEX_typeOPEN_PAREN:
+ case FFELEX_typeOPEN_ARRAY:
+ case FFELEX_typeQUOTE:
+ case FFELEX_typeAPOSTROPHE:
+ case FFELEX_typePLUS:
+ case FFELEX_typeMINUS:
+ return (ffelexHandler) ffestb_R10012_ (t);
- case FFESTR_genioERR:
- ffestb_local_.write.ix = FFESTP_writeixERR;
- ffestb_local_.write.label = TRUE;
- break;
+ case FFELEX_typeCLOSE_PAREN:
+ f = ffestb_local_.format.f->u.root.parent;
+ if (f == NULL)
+ return (ffelexHandler) ffestb_R100114_;
+ ffestb_local_.format.f = f->next;
+ return (ffelexHandler) ffestb_R100111_;
- case FFESTR_genioFMT:
- ffestb_local_.write.ix = FFESTP_writeixFORMAT;
- ffestb_local_.write.left = FALSE;
- ffestb_local_.write.context = FFEEXPR_contextFILEFORMAT;
- break;
+ case FFELEX_typeCLOSE_ARRAY: /* "/)". */
+ f = ffestt_formatlist_append (ffestb_local_.format.f);
+ f->type = FFESTP_formattypeSLASH;
+ f->t = ffelex_token_use (t);
+ f->u.R1010.val.present = FALSE;
+ f->u.R1010.val.rtexpr = FALSE;
+ f->u.R1010.val.t = NULL;
+ f->u.R1010.val.u.unsigned_val = 1;
+ f = ffestb_local_.format.f->u.root.parent;
+ if (f == NULL)
+ return (ffelexHandler) ffestb_R100114_;
+ ffestb_local_.format.f = f->next;
+ return (ffelexHandler) ffestb_R100111_;
- case FFESTR_genioIOSTAT:
- ffestb_local_.write.ix = FFESTP_writeixIOSTAT;
- ffestb_local_.write.left = TRUE;
- ffestb_local_.write.context = FFEEXPR_contextFILEINT;
- break;
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ ffesta_confirmed ();
+ ffesta_ffebad_1t (FFEBAD_FORMAT_MISSING_PAREN, t);
+ for (f = ffestb_local_.format.f;
+ f->u.root.parent != NULL;
+ f = f->u.root.parent->next)
+ ;
+ ffestb_local_.format.f = f;
+ return (ffelexHandler) ffestb_R100114_ (t);
- case FFESTR_genioNML:
- ffestb_local_.write.ix = FFESTP_writeixFORMAT;
- ffestb_local_.write.left = TRUE;
- ffestb_local_.write.context = FFEEXPR_contextFILENAMELIST;
- break;
+ default:
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FORMAT", t);
+ ffestt_formatlist_kill (ffestb_local_.format.f);
+ return (ffelexHandler) ffelex_swallow_tokens (t,
+ (ffelexHandler) ffesta_zero);
+ }
+}
- case FFESTR_genioREC:
- ffestb_local_.write.ix = FFESTP_writeixREC;
- ffestb_local_.write.left = FALSE;
- ffestb_local_.write.context = FFEEXPR_contextFILENUM;
- break;
+/* ffestb_R100113_ -- Handle CHARACTER token.
- case FFESTR_genioUNIT:
- ffestb_local_.write.ix = FFESTP_writeixUNIT;
- ffestb_local_.write.left = FALSE;
- ffestb_local_.write.context = FFEEXPR_contextFILEUNIT;
- break;
+ return ffestb_R100113_; // to lexer
- default:
- goto bad; /* :::::::::::::::::::: */
- }
- if (ffestp_file.write.write_spec[ffestb_local_.write.ix]
- .kw_or_val_present)
- break; /* Can't specify a keyword twice! */
- ffestp_file.write.write_spec[ffestb_local_.write.ix]
- .kw_or_val_present = TRUE;
- ffestp_file.write.write_spec[ffestb_local_.write.ix]
- .kw_present = TRUE;
- ffestp_file.write.write_spec[ffestb_local_.write.ix]
- .value_present = FALSE;
- ffestp_file.write.write_spec[ffestb_local_.write.ix].value_is_label
- = ffestb_local_.write.label;
- ffestp_file.write.write_spec[ffestb_local_.write.ix].kw
- = ffelex_token_use (t);
- return (ffelexHandler) ffestb_R9108_;
+ Append the format item to the list, go to _11_. */
- default:
- break;
+static ffelexHandler
+ffestb_R100113_ (ffelexToken t)
+{
+ ffesttFormatList f;
+
+ assert (ffelex_token_type (t) == FFELEX_typeCHARACTER);
+
+ if (ffe_is_pedantic_not_90 () && (ffelex_token_length (t) == 0))
+ {
+ ffebad_start (FFEBAD_NULL_CHAR_CONST);
+ ffebad_here (0, ffelex_token_where_line (t),
+ ffelex_token_where_column (t));
+ ffebad_finish ();
}
-bad: /* :::::::::::::::::::: */
- ffestb_subr_kill_write_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "WRITE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+ f = ffestt_formatlist_append (ffestb_local_.format.f);
+ f->type = FFESTP_formattypeR1016;
+ f->t = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_R100111_;
}
-/* ffestb_R9108_ -- "WRITE" OPEN_PAREN [external-file-unit COMMA [format
- COMMA]] NAME
+/* ffestb_R100114_ -- "FORMAT" OPEN_PAREN format-item-list CLOSE_PAREN
- return ffestb_R9108_; // to lexer
+ return ffestb_R100114_; // to lexer
- Make sure EQUALS here, send next token to expression handler. */
+ Handle EOS/SEMICOLON or something else. */
static ffelexHandler
-ffestb_R9108_ (ffelexToken t)
+ffestb_R100114_ (ffelexToken t)
{
+ ffelex_set_names_pure (FALSE);
+
switch (ffelex_token_type (t))
{
- case FFELEX_typeEQUALS:
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
ffesta_confirmed ();
- if (ffestb_local_.write.label)
- return (ffelexHandler) ffestb_R91010_;
- if (ffestb_local_.write.left)
- return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool,
- ffestb_local_.write.context,
- (ffeexprCallback) ffestb_R9109_);
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- ffestb_local_.write.context,
- (ffeexprCallback) ffestb_R9109_);
+ if (!ffesta_is_inhibited () && !ffestb_local_.format.complained)
+ ffestc_R1001 (ffestb_local_.format.f);
+ ffestt_formatlist_kill (ffestb_local_.format.f);
+ return (ffelexHandler) ffesta_zero (t);
default:
- break;
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FORMAT", t);
+ ffestt_formatlist_kill (ffestb_local_.format.f);
+ return (ffelexHandler) ffelex_swallow_tokens (t,
+ (ffelexHandler) ffesta_zero);
}
-
- ffestb_subr_kill_write_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "WRITE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R9109_ -- "WRITE" OPEN_PAREN ... NAME EQUALS expr
+/* ffestb_R100115_ -- OPEN_ANGLE expr
- (ffestb_R9109_) // to expression handler
+ (ffestb_R100115_) // to expression handler
- Handle COMMA or CLOSE_PAREN here. */
+ Handle expression prior to the edit descriptor. */
static ffelexHandler
-ffestb_R9109_ (ffelexToken ft, ffebld expr, ffelexToken t)
+ffestb_R100115_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeCOMMA:
- case FFELEX_typeCLOSE_PAREN:
- if (expr == NULL)
- {
- if (ffestb_local_.write.context == FFEEXPR_contextFILEFORMAT)
- ffestp_file.write.write_spec[ffestb_local_.write.ix]
- .value_is_label = TRUE;
- else
- break;
- }
- ffestp_file.write.write_spec[ffestb_local_.write.ix].value_present
- = TRUE;
- ffestp_file.write.write_spec[ffestb_local_.write.ix].value
- = ffelex_token_use (ft);
- ffestp_file.write.write_spec[ffestb_local_.write.ix].u.expr = expr;
- if (ffelex_token_type (t) == FFELEX_typeCOMMA)
- return (ffelexHandler) ffestb_R9107_;
- return (ffelexHandler) ffestb_R91012_;
+ case FFELEX_typeCLOSE_ANGLE:
+ ffestb_local_.format.pre.present = TRUE;
+ ffestb_local_.format.pre.rtexpr = TRUE;
+ ffestb_local_.format.pre.u.expr = expr;
+ ffelex_set_names_pure (TRUE);
+ return (ffelexHandler) ffestb_R10014_;
default:
- break;
+ ffelex_token_kill (ffestb_local_.format.pre.t);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FORMAT", t);
+ ffestt_formatlist_kill (ffestb_local_.format.f);
+ return (ffelexHandler) ffelex_swallow_tokens (t,
+ (ffelexHandler) ffesta_zero);
}
-
- ffestb_subr_kill_write_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "WRITE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R91010_ -- "WRITE" OPEN_PAREN ... NAME EQUALS
+/* ffestb_R100116_ -- "[n]X" OPEN_ANGLE expr
- return ffestb_R91010_; // to lexer
+ (ffestb_R100116_) // to expression handler
- Handle NUMBER for label here. */
+ Handle expression after the edit descriptor. */
static ffelexHandler
-ffestb_R91010_ (ffelexToken t)
+ffestb_R100116_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeNUMBER:
- ffestp_file.write.write_spec[ffestb_local_.write.ix].value_present
- = TRUE;
- ffestp_file.write.write_spec[ffestb_local_.write.ix].value
- = ffelex_token_use (t);
- return (ffelexHandler) ffestb_R91011_;
+ case FFELEX_typeCLOSE_ANGLE:
+ ffestb_local_.format.post.present = TRUE;
+ ffestb_local_.format.post.rtexpr = TRUE;
+ ffestb_local_.format.post.u.expr = expr;
+ ffelex_set_names_pure (TRUE);
+ return (ffelexHandler) ffestb_R10016_;
default:
- break;
+ ffelex_token_kill (ffestb_local_.format.t);
+ ffelex_token_kill (ffestb_local_.format.post.t);
+ if (ffestb_local_.format.pre.present)
+ ffelex_token_kill (ffestb_local_.format.pre.t);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FORMAT", t);
+ ffestt_formatlist_kill (ffestb_local_.format.f);
+ return (ffelexHandler) ffelex_swallow_tokens (t,
+ (ffelexHandler) ffesta_zero);
}
-
- ffestb_subr_kill_write_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "WRITE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R91011_ -- "WRITE" OPEN_PAREN ... NAME EQUALS NUMBER
+/* ffestb_R100117_ -- "[n]X[n]." OPEN_ANGLE expr
- return ffestb_R91011_; // to lexer
+ (ffestb_R100117_) // to expression handler
- Handle COMMA or CLOSE_PAREN here. */
+ Handle expression after the PERIOD. */
static ffelexHandler
-ffestb_R91011_ (ffelexToken t)
+ffestb_R100117_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeCOMMA:
- return (ffelexHandler) ffestb_R9107_;
-
- case FFELEX_typeCLOSE_PAREN:
- return (ffelexHandler) ffestb_R91012_;
+ case FFELEX_typeCLOSE_ANGLE:
+ ffestb_local_.format.dot.present = TRUE;
+ ffestb_local_.format.dot.rtexpr = TRUE;
+ ffestb_local_.format.dot.u.expr = expr;
+ ffelex_set_names_pure (TRUE);
+ return (ffelexHandler) ffestb_R10018_;
default:
- break;
+ ffelex_token_kill (ffestb_local_.format.t);
+ ffelex_token_kill (ffestb_local_.format.dot.t);
+ if (ffestb_local_.format.pre.present)
+ ffelex_token_kill (ffestb_local_.format.pre.t);
+ if (ffestb_local_.format.post.present)
+ ffelex_token_kill (ffestb_local_.format.post.t);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FORMAT", t);
+ ffestt_formatlist_kill (ffestb_local_.format.f);
+ return (ffelexHandler) ffelex_swallow_tokens (t,
+ (ffelexHandler) ffesta_zero);
}
-
- ffestb_subr_kill_write_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "WRITE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R91012_ -- "WRITE" OPEN_PAREN ... CLOSE_PAREN
+/* ffestb_R100118_ -- "[n]X[n].[n]E" OPEN_ANGLE expr
- return ffestb_R91012_; // to lexer
+ (ffestb_R100118_) // to expression handler
- Handle EOS or SEMICOLON here. */
+ Handle expression after the "E". */
static ffelexHandler
-ffestb_R91012_ (ffelexToken t)
+ffestb_R100118_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- {
- ffestc_R910_start ();
- ffestc_R910_finish ();
- }
- ffestb_subr_kill_write_ ();
- return (ffelexHandler) ffesta_zero (t);
+ case FFELEX_typeCLOSE_ANGLE:
+ ffestb_local_.format.exp.present = TRUE;
+ ffestb_local_.format.exp.rtexpr = TRUE;
+ ffestb_local_.format.exp.u.expr = expr;
+ ffelex_set_names_pure (TRUE);
+ return (ffelexHandler) ffestb_R100110_;
default:
- ffesta_confirmed ();
- /* Fall through. */
- case FFELEX_typeOPEN_PAREN: /* Could still be assignment!! */
-
- /* EXTENSION: Allow an optional preceding COMMA here if not pedantic.
- (f2c provides this extension, as do other compilers, supposedly.) */
-
- if (!ffe_is_pedantic () && (ffelex_token_type (t) == FFELEX_typeCOMMA))
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- ffestc_context_iolist (), (ffeexprCallback) ffestb_R91013_);
-
- return (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- ffestc_context_iolist (), (ffeexprCallback) ffestb_R91013_)))
- (t);
-
- case FFELEX_typeEQUALS:
- case FFELEX_typePOINTS:
- break;
+ ffelex_token_kill (ffestb_local_.format.t);
+ ffelex_token_kill (ffestb_local_.format.exp.t);
+ if (ffestb_local_.format.pre.present)
+ ffelex_token_kill (ffestb_local_.format.pre.t);
+ if (ffestb_local_.format.post.present)
+ ffelex_token_kill (ffestb_local_.format.post.t);
+ if (ffestb_local_.format.dot.present)
+ ffelex_token_kill (ffestb_local_.format.dot.t);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FORMAT", t);
+ ffestt_formatlist_kill (ffestb_local_.format.f);
+ return (ffelexHandler) ffelex_swallow_tokens (t,
+ (ffelexHandler) ffesta_zero);
}
-
- ffestb_subr_kill_write_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "WRITE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R91013_ -- "WRITE(...)" expr
+/* ffestb_S3P4 -- Parse the INCLUDE line
- (ffestb_R91013_) // to expression handler
+ return ffestb_S3P4; // to lexer
- Handle COMMA or EOS/SEMICOLON here. */
+ Make sure the statement has a valid form for the INCLUDE line. If it
+ does, implement the statement. */
-static ffelexHandler
-ffestb_R91013_ (ffelexToken ft, ffebld expr, ffelexToken t)
+ffelexHandler
+ffestb_S3P4 (ffelexToken t)
{
- switch (ffelex_token_type (t))
+ ffeTokenLength i;
+ const char *p;
+ ffelexHandler next;
+ ffelexToken nt;
+ ffelexToken ut;
+
+ switch (ffelex_token_type (ffesta_tokens[0]))
{
- case FFELEX_typeCOMMA:
- if (expr == NULL)
- break;
+ case FFELEX_typeNAME:
+ if (ffesta_first_kw != FFESTR_firstINCLUDE)
+ goto bad_0; /* :::::::::::::::::::: */
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeNUMBER:
+ case FFELEX_typeAPOSTROPHE:
+ case FFELEX_typeQUOTE:
+ break;
+ default:
+ goto bad_1; /* :::::::::::::::::::: */
+ }
ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- ffestc_R910_start ();
- ffestb_subr_kill_write_ ();
-
- if (!ffesta_is_inhibited ())
- ffestc_R910_item (expr, ft);
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- ffestc_context_iolist (), (ffeexprCallback) ffestb_R91014_);
-
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- if (expr == NULL)
- break;
+ return (ffelexHandler) (*((ffelexHandler)
+ ffeexpr_rhs (ffesta_output_pool, FFEEXPR_contextINCLUDE,
+ (ffeexprCallback) ffestb_S3P41_)))
+ (t);
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- ffestc_R910_start ();
- ffestb_subr_kill_write_ ();
+ case FFELEX_typeNAMES:
+ if (ffesta_first_kw != FFESTR_firstINCLUDE)
+ goto bad_0; /* :::::::::::::::::::: */
+ p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlINCLUDE);
+ switch (ffelex_token_type (t))
+ {
+ default:
+ goto bad_1; /* :::::::::::::::::::: */
- if (!ffesta_is_inhibited ())
+ case FFELEX_typeAPOSTROPHE:
+ case FFELEX_typeQUOTE:
+ break;
+ }
+ ffesta_confirmed ();
+ if (*p == '\0')
+ return (ffelexHandler) (*((ffelexHandler)
+ ffeexpr_rhs (ffesta_output_pool, FFEEXPR_contextINCLUDE,
+ (ffeexprCallback) ffestb_S3P41_)))
+ (t);
+ if (! ISDIGIT (*p))
+ goto bad_i; /* :::::::::::::::::::: */
+ nt = ffelex_token_number_from_names (ffesta_tokens[0], i);
+ p += ffelex_token_length (nt);
+ i += ffelex_token_length (nt);
+ if ((*p != '_') || (++i, *++p != '\0'))
{
- ffestc_R910_item (expr, ft);
- ffestc_R910_finish ();
+ ffelex_token_kill (nt);
+ goto bad_i; /* :::::::::::::::::::: */
}
- return (ffelexHandler) ffesta_zero (t);
+ ut = ffelex_token_uscore_from_names (ffesta_tokens[0], i - 1);
+ next = (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs
+ (ffesta_output_pool, FFEEXPR_contextINCLUDE,
+ (ffeexprCallback) ffestb_S3P41_)))
+ (nt);
+ ffelex_token_kill (nt);
+ next = (ffelexHandler) (*next) (ut);
+ ffelex_token_kill (ut);
+ return (ffelexHandler) (*next) (t);
default:
- break;
+ goto bad_0; /* :::::::::::::::::::: */
}
- ffestb_subr_kill_write_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "WRITE", t);
+bad_0: /* :::::::::::::::::::: */
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INCLUDE", ffesta_tokens[0]);
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+
+bad_1: /* :::::::::::::::::::: */
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INCLUDE", t);
+ return (ffelexHandler) ffelex_swallow_tokens (t,
+ (ffelexHandler) ffesta_zero); /* Invalid second token. */
+
+bad_i: /* :::::::::::::::::::: */
+ ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "INCLUDE", ffesta_tokens[0], i, t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R91014_ -- "WRITE(...)" expr COMMA expr
+/* ffestb_S3P41_ -- "INCLUDE" [NUMBER "_"] expr
- (ffestb_R91014_) // to expression handler
+ (ffestb_S3P41_) // to expression handler
- Handle COMMA or EOS/SEMICOLON here. */
+ Make sure the next token is an EOS, but not a SEMICOLON. */
static ffelexHandler
-ffestb_R91014_ (ffelexToken ft, ffebld expr, ffelexToken t)
+ffestb_S3P41_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeCOMMA:
- if (expr == NULL)
- break;
- if (!ffesta_is_inhibited ())
- ffestc_R910_item (expr, ft);
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- ffestc_context_iolist (), (ffeexprCallback) ffestb_R91014_);
-
case FFELEX_typeEOS:
case FFELEX_typeSEMICOLON:
if (expr == NULL)
break;
if (!ffesta_is_inhibited ())
{
- ffestc_R910_item (expr, ft);
- ffestc_R910_finish ();
+ if (ffe_is_pedantic ()
+ && ((ffelex_token_type (t) == FFELEX_typeSEMICOLON)
+ || ffesta_line_has_semicolons))
+ {
+ /* xgettext:no-c-format */
+ ffebad_start_msg ("INCLUDE at %0 not the only statement on the source line", FFEBAD_severityWARNING);
+ ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
+ ffelex_token_where_column (ffesta_tokens[0]));
+ ffebad_finish ();
+ }
+ ffestc_S3P4 (expr, ft);
}
return (ffelexHandler) ffesta_zero (t);
default:
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INCLUDE", t);
break;
}
- if (!ffesta_is_inhibited ())
- ffestc_R910_finish ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "WRITE", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R911 -- Parse the PRINT statement
+/* ffestb_V014 -- Parse the VOLATILE statement
- return ffestb_R911; // to lexer
+ return ffestb_V014; // to lexer
- Make sure the statement has a valid form for the PRINT
- statement. If it does, implement the statement. */
+ Make sure the statement has a valid form for the VOLATILE statement. If it
+ does, implement the statement. */
ffelexHandler
-ffestb_R911 (ffelexToken t)
+ffestb_V014 (ffelexToken t)
{
+ ffeTokenLength i;
+ unsigned const char *p;
+ ffelexToken nt;
ffelexHandler next;
- ffestpPrintIx ix;
switch (ffelex_token_type (ffesta_tokens[0]))
{
case FFELEX_typeNAME:
- if (ffesta_first_kw != FFESTR_firstPRINT)
+ if (ffesta_first_kw != FFESTR_firstVOLATILE)
goto bad_0; /* :::::::::::::::::::: */
switch (ffelex_token_type (t))
{
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
case FFELEX_typeEOS:
case FFELEX_typeSEMICOLON:
+ case FFELEX_typeCOMMA:
ffesta_confirmed (); /* Error, but clearly intended. */
goto bad_1; /* :::::::::::::::::::: */
- case FFELEX_typeEQUALS:
- case FFELEX_typePOINTS:
- case FFELEX_typeCOLON:
+ default:
goto bad_1; /* :::::::::::::::::::: */
case FFELEX_typeNAME:
- case FFELEX_typeNUMBER:
+ case FFELEX_typeSLASH:
ffesta_confirmed ();
- break;
+ if (!ffesta_is_inhibited ())
+ ffestc_V014_start ();
+ return (ffelexHandler) ffestb_V0141_ (t);
- default:
- break;
+ case FFELEX_typeCOLONCOLON:
+ ffesta_confirmed ();
+ if (!ffesta_is_inhibited ())
+ ffestc_V014_start ();
+ return (ffelexHandler) ffestb_V0141_;
}
- for (ix = 0; ix < FFESTP_printix; ++ix)
- ffestp_file.print.print_spec[ix].kw_or_val_present = FALSE;
- return (ffelexHandler) (*((ffelexHandler)
- ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextFILEFORMATNML, (ffeexprCallback) ffestb_R9111_)))
- (t);
-
case FFELEX_typeNAMES:
- if (ffesta_first_kw != FFESTR_firstPRINT)
+ if (ffesta_first_kw != FFESTR_firstVOLATILE)
goto bad_0; /* :::::::::::::::::::: */
+ p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlVOLATILE);
switch (ffelex_token_type (t))
{
+ default:
+ goto bad_1; /* :::::::::::::::::::: */
+
+ case FFELEX_typeCOMMA:
case FFELEX_typeEOS:
case FFELEX_typeSEMICOLON:
- case FFELEX_typeCOMMA:
ffesta_confirmed ();
- if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlPRINT)
- break;
- goto bad_1; /* :::::::::::::::::::: */
+ break;
+
+ case FFELEX_typeSLASH:
+ ffesta_confirmed ();
+ if (*p != '\0')
+ goto bad_i; /* :::::::::::::::::::: */
+ if (!ffesta_is_inhibited ())
+ ffestc_V014_start ();
+ return (ffelexHandler) ffestb_V0141_ (t);
case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
+ ffesta_confirmed ();
+ if (*p != '\0')
+ goto bad_i; /* :::::::::::::::::::: */
+ if (!ffesta_is_inhibited ())
+ ffestc_V014_start ();
+ return (ffelexHandler) ffestb_V0141_;
+ }
- case FFELEX_typeEQUALS:
- case FFELEX_typePOINTS:
- case FFELEX_typeCOLON:
- goto bad_1; /* :::::::::::::::::::: */
+ /* Here, we have at least one char after "VOLATILE" and t is COMMA or
+ EOS/SEMICOLON. */
- default:
- break;
- }
- for (ix = 0; ix < FFESTP_printix; ++ix)
- ffestp_file.print.print_spec[ix].kw_or_val_present = FALSE;
- next = (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextFILEFORMATNML, (ffeexprCallback) ffestb_R9111_);
- next = (ffelexHandler) ffelex_splice_tokens (next, ffesta_tokens[0],
- FFESTR_firstlPRINT);
- if (next == NULL)
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero);
+ if (!ffesrc_is_name_init (*p))
+ goto bad_i; /* :::::::::::::::::::: */
+ nt = ffelex_token_name_from_names (ffesta_tokens[0], i, 0);
+ if (!ffesta_is_inhibited ())
+ ffestc_V014_start ();
+ next = (ffelexHandler) ffestb_V0141_ (nt);
+ ffelex_token_kill (nt);
return (ffelexHandler) (*next) (t);
default:
}
bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "PRINT", ffesta_tokens[0]);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "VOLATILE", ffesta_tokens[0]);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "PRINT", t);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "VOLATILE", t);
return (ffelexHandler) ffelex_swallow_tokens (t,
(ffelexHandler) ffesta_zero); /* Invalid second token. */
+
+bad_i: /* :::::::::::::::::::: */
+ ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "VOLATILE", ffesta_tokens[0], i, t);
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R9111_ -- "PRINT" expr
+/* ffestb_V0141_ -- "VOLATILE" [COLONCOLON]
- (ffestb_R9111_) // to expression handler
+ return ffestb_V0141_; // to lexer
+
+ Handle NAME or SLASH. */
+
+static ffelexHandler
+ffestb_V0141_ (ffelexToken t)
+{
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeNAME:
+ ffestb_local_.V014.is_cblock = FALSE;
+ ffesta_tokens[1] = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_V0144_;
+
+ case FFELEX_typeSLASH:
+ ffestb_local_.V014.is_cblock = TRUE;
+ return (ffelexHandler) ffestb_V0142_;
+
+ default:
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "VOLATILE", t);
+ break;
+ }
+
+ if (!ffesta_is_inhibited ())
+ ffestc_V014_finish ();
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+}
+
+/* ffestb_V0142_ -- "VOLATILE" [COLONCOLON] SLASH
+
+ return ffestb_V0142_; // to lexer
+
+ Handle NAME. */
+
+static ffelexHandler
+ffestb_V0142_ (ffelexToken t)
+{
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeNAME:
+ ffesta_tokens[1] = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_V0143_;
+
+ default:
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "VOLATILE", t);
+ break;
+ }
+
+ if (!ffesta_is_inhibited ())
+ ffestc_V014_finish ();
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+}
+
+/* ffestb_V0143_ -- "VOLATILE" [COLONCOLON] SLASH NAME
+
+ return ffestb_V0143_; // to lexer
- Make sure the next token is a COMMA or EOS/SEMICOLON. */
+ Handle SLASH. */
static ffelexHandler
-ffestb_R9111_ (ffelexToken ft, ffebld expr, ffelexToken t)
+ffestb_V0143_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- case FFELEX_typeCOMMA:
- ffesta_confirmed ();
- ffestp_file.print.print_spec[FFESTP_printixFORMAT].kw_or_val_present
- = TRUE;
- ffestp_file.print.print_spec[FFESTP_printixFORMAT].kw_present = FALSE;
- ffestp_file.print.print_spec[FFESTP_printixFORMAT].value_present = TRUE;
- ffestp_file.print.print_spec[FFESTP_printixFORMAT].value_is_label
- = (expr == NULL);
- ffestp_file.print.print_spec[FFESTP_printixFORMAT].value
- = ffelex_token_use (ft);
- ffestp_file.print.print_spec[FFESTP_printixFORMAT].u.expr = expr;
- if (!ffesta_is_inhibited ())
- ffestc_R911_start ();
- ffestb_subr_kill_print_ ();
- if (ffelex_token_type (t) == FFELEX_typeCOMMA)
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextIOLIST, (ffeexprCallback) ffestb_R9112_);
- if (!ffesta_is_inhibited ())
- ffestc_R911_finish ();
- return (ffelexHandler) ffesta_zero (t);
+ case FFELEX_typeSLASH:
+ return (ffelexHandler) ffestb_V0144_;
default:
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "VOLATILE", t);
break;
}
- ffestb_subr_kill_print_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "PRINT", t);
+ if (!ffesta_is_inhibited ())
+ ffestc_V014_finish ();
+ ffelex_token_kill (ffesta_tokens[1]);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R9112_ -- "PRINT" expr COMMA expr
+/* ffestb_V0144_ -- "VOLATILE" [COLONCOLON] R523
- (ffestb_R9112_) // to expression handler
+ return ffestb_V0144_; // to lexer
- Handle COMMA or EOS/SEMICOLON here. */
+ Handle COMMA or EOS/SEMICOLON. */
static ffelexHandler
-ffestb_R9112_ (ffelexToken ft, ffebld expr, ffelexToken t)
+ffestb_V0144_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
case FFELEX_typeCOMMA:
- if (expr == NULL)
- break;
if (!ffesta_is_inhibited ())
- ffestc_R911_item (expr, ft);
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextIOLIST, (ffeexprCallback) ffestb_R9112_);
+ {
+ if (ffestb_local_.V014.is_cblock)
+ ffestc_V014_item_cblock (ffesta_tokens[1]);
+ else
+ ffestc_V014_item_object (ffesta_tokens[1]);
+ }
+ ffelex_token_kill (ffesta_tokens[1]);
+ return (ffelexHandler) ffestb_V0141_;
case FFELEX_typeEOS:
case FFELEX_typeSEMICOLON:
- if (expr == NULL)
- break;
if (!ffesta_is_inhibited ())
{
- ffestc_R911_item (expr, ft);
- ffestc_R911_finish ();
+ if (ffestb_local_.V014.is_cblock)
+ ffestc_V014_item_cblock (ffesta_tokens[1]);
+ else
+ ffestc_V014_item_object (ffesta_tokens[1]);
+ ffestc_V014_finish ();
}
+ ffelex_token_kill (ffesta_tokens[1]);
return (ffelexHandler) ffesta_zero (t);
default:
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "VOLATILE", t);
break;
}
if (!ffesta_is_inhibited ())
- ffestc_R911_finish ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "PRINT", t);
+ ffestc_V014_finish ();
+ ffelex_token_kill (ffesta_tokens[1]);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R923 -- Parse an INQUIRE statement
+/* ffestb_subr_kill_easy_ -- Kill I/O statement data structure
- return ffestb_R923; // to lexer
+ ffestb_subr_kill_easy_();
- Make sure the statement has a valid form for an INQUIRE statement.
- If it does, implement the statement. */
+ Kills all tokens in the I/O data structure. Assumes that they are
+ overlaid with each other (union) in ffest_private.h and the typing
+ and structure references assume (though not necessarily dangerous if
+ FALSE) that INQUIRE has the most file elements. */
-ffelexHandler
-ffestb_R923 (ffelexToken t)
+#if FFESTB_KILL_EASY_
+static void
+ffestb_subr_kill_easy_ (ffestpInquireIx max)
{
ffestpInquireIx ix;
- switch (ffelex_token_type (ffesta_tokens[0]))
- {
- case FFELEX_typeNAME:
- if (ffesta_first_kw != FFESTR_firstINQUIRE)
- goto bad_0; /* :::::::::::::::::::: */
- break;
-
- case FFELEX_typeNAMES:
- if (ffesta_first_kw != FFESTR_firstINQUIRE)
- goto bad_0; /* :::::::::::::::::::: */
- if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlINQUIRE)
- goto bad_0; /* :::::::::::::::::::: */
- break;
-
- default:
- goto bad_0; /* :::::::::::::::::::: */
- }
-
- switch (ffelex_token_type (t))
+ for (ix = 0; ix < max; ++ix)
{
- case FFELEX_typeOPEN_PAREN:
- break;
-
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
-
- default:
- goto bad_1; /* :::::::::::::::::::: */
+ if (ffestp_file.inquire.inquire_spec[ix].kw_or_val_present)
+ {
+ if (ffestp_file.inquire.inquire_spec[ix].kw_present)
+ ffelex_token_kill (ffestp_file.inquire.inquire_spec[ix].kw);
+ if (ffestp_file.inquire.inquire_spec[ix].value_present)
+ ffelex_token_kill (ffestp_file.inquire.inquire_spec[ix].value);
+ }
}
-
- for (ix = 0; ix < FFESTP_inquireix; ++ix)
- ffestp_file.inquire.inquire_spec[ix].kw_or_val_present = FALSE;
-
- ffestb_local_.inquire.may_be_iolength = TRUE;
- return (ffelexHandler) ffestb_R9231_;
-
-bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INQUIRE", ffesta_tokens[0]);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-
-bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INQUIRE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero); /* Invalid second token. */
}
-/* ffestb_R9231_ -- "INQUIRE" OPEN_PAREN
+#endif
+/* ffestb_subr_kill_accept_ -- Kill ACCEPT statement data structure
- return ffestb_R9231_; // to lexer
+ ffestb_subr_kill_accept_();
- Handle expr construct (not NAME=expr construct) here. */
+ Kills all tokens in the ACCEPT data structure. */
-static ffelexHandler
-ffestb_R9231_ (ffelexToken t)
+#if !FFESTB_KILL_EASY_
+static void
+ffestb_subr_kill_accept_ ()
{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_R9232_;
+ ffestpAcceptIx ix;
- default:
- ffestb_local_.inquire.may_be_iolength = FALSE;
- return (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextFILENUM, (ffeexprCallback) ffestb_R9233_)))
- (t);
+ for (ix = 0; ix < FFESTP_acceptix; ++ix)
+ {
+ if (ffestp_file.accept.accept_spec[ix].kw_or_val_present)
+ {
+ if (ffestp_file.accept.accept_spec[ix].kw_present)
+ ffelex_token_kill (ffestp_file.accept.accept_spec[ix].kw);
+ if (ffestp_file.accept.accept_spec[ix].value_present)
+ ffelex_token_kill (ffestp_file.accept.accept_spec[ix].value);
+ }
}
}
-/* ffestb_R9232_ -- "INQUIRE" OPEN_PAREN NAME
+#endif
+/* ffestb_subr_kill_beru_ -- Kill BACKSPACE/ENDFILE/REWIND/UNLOCK statement
+ data structure
- return ffestb_R9232_; // to lexer
+ ffestb_subr_kill_beru_();
- If EQUALS here, go to states that handle it. Else, send NAME and this
- token thru expression handler. */
+ Kills all tokens in the BACKSPACE/ENDFILE/REWIND/UNLOCK data structure. */
-static ffelexHandler
-ffestb_R9232_ (ffelexToken t)
+#if !FFESTB_KILL_EASY_
+static void
+ffestb_subr_kill_beru_ ()
{
- ffelexHandler next;
- ffelexToken nt;
+ ffestpBeruIx ix;
- switch (ffelex_token_type (t))
+ for (ix = 0; ix < FFESTP_beruix; ++ix)
{
- case FFELEX_typeEQUALS:
- nt = ffesta_tokens[1];
- next = (ffelexHandler) ffestb_R9234_ (nt);
- ffelex_token_kill (nt);
- return (ffelexHandler) (*next) (t);
-
- default:
- ffestb_local_.inquire.may_be_iolength = FALSE;
- next = (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextFILENUM, (ffeexprCallback) ffestb_R9233_)))
- (ffesta_tokens[1]);
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) (*next) (t);
+ if (ffestp_file.beru.beru_spec[ix].kw_or_val_present)
+ {
+ if (ffestp_file.beru.beru_spec[ix].kw_present)
+ ffelex_token_kill (ffestp_file.beru.beru_spec[ix].kw);
+ if (ffestp_file.beru.beru_spec[ix].value_present)
+ ffelex_token_kill (ffestp_file.beru.beru_spec[ix].value);
+ }
}
}
-/* ffestb_R9233_ -- "INQUIRE" OPEN_PAREN expr
+#endif
+/* ffestb_subr_kill_close_ -- Kill CLOSE statement data structure
- (ffestb_R9233_) // to expression handler
+ ffestb_subr_kill_close_();
- Handle COMMA or CLOSE_PAREN here. */
+ Kills all tokens in the CLOSE data structure. */
-static ffelexHandler
-ffestb_R9233_ (ffelexToken ft, ffebld expr, ffelexToken t)
+#if !FFESTB_KILL_EASY_
+static void
+ffestb_subr_kill_close_ ()
{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- case FFELEX_typeCLOSE_PAREN:
- if (expr == NULL)
- break;
- ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw_or_val_present
- = TRUE;
- ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw_present = FALSE;
- ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].value_present = TRUE;
- ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].value_is_label
- = FALSE;
- ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].value
- = ffelex_token_use (ft);
- ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].u.expr = expr;
- if (ffelex_token_type (t) == FFELEX_typeCOMMA)
- return (ffelexHandler) ffestb_R9234_;
- return (ffelexHandler) ffestb_R9239_;
-
- default:
- break;
- }
+ ffestpCloseIx ix;
- ffestb_subr_kill_inquire_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INQUIRE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+ for (ix = 0; ix < FFESTP_closeix; ++ix)
+ {
+ if (ffestp_file.close.close_spec[ix].kw_or_val_present)
+ {
+ if (ffestp_file.close.close_spec[ix].kw_present)
+ ffelex_token_kill (ffestp_file.close.close_spec[ix].kw);
+ if (ffestp_file.close.close_spec[ix].value_present)
+ ffelex_token_kill (ffestp_file.close.close_spec[ix].value);
+ }
+ }
}
-/* ffestb_R9234_ -- "INQUIRE" OPEN_PAREN [external-file-unit COMMA]
+#endif
+/* ffestb_subr_kill_delete_ -- Kill DELETE statement data structure
- return ffestb_R9234_; // to lexer
+ ffestb_subr_kill_delete_();
- Handle expr construct (not NAME=expr construct) here. */
+ Kills all tokens in the DELETE data structure. */
-static ffelexHandler
-ffestb_R9234_ (ffelexToken t)
+#if !FFESTB_KILL_EASY_
+static void
+ffestb_subr_kill_delete_ ()
{
- ffestrInquire kw;
-
- ffestb_local_.inquire.label = FALSE;
+ ffestpDeleteIx ix;
- switch (ffelex_token_type (t))
+ for (ix = 0; ix < FFESTP_deleteix; ++ix)
{
- case FFELEX_typeNAME:
- kw = ffestr_inquire (t);
- if (kw != FFESTR_inquireIOLENGTH)
- ffestb_local_.inquire.may_be_iolength = FALSE;
- switch (kw)
+ if (ffestp_file.delete.delete_spec[ix].kw_or_val_present)
{
- case FFESTR_inquireACCESS:
- ffestb_local_.inquire.ix = FFESTP_inquireixACCESS;
- ffestb_local_.inquire.left = TRUE;
- ffestb_local_.inquire.context = FFEEXPR_contextFILEDFCHAR;
- break;
-
- case FFESTR_inquireACTION:
- ffestb_local_.inquire.ix = FFESTP_inquireixACTION;
- ffestb_local_.inquire.left = TRUE;
- ffestb_local_.inquire.context = FFEEXPR_contextFILEDFCHAR;
- break;
-
- case FFESTR_inquireBLANK:
- ffestb_local_.inquire.ix = FFESTP_inquireixBLANK;
- ffestb_local_.inquire.left = TRUE;
- ffestb_local_.inquire.context = FFEEXPR_contextFILEDFCHAR;
- break;
-
- case FFESTR_inquireCARRIAGECONTROL:
- ffestb_local_.inquire.ix = FFESTP_inquireixCARRIAGECONTROL;
- ffestb_local_.inquire.left = TRUE;
- ffestb_local_.inquire.context = FFEEXPR_contextFILECHAR;
- break;
-
- case FFESTR_inquireDEFAULTFILE:
- ffestb_local_.inquire.ix = FFESTP_inquireixDEFAULTFILE;
- ffestb_local_.inquire.left = FALSE;
- ffestb_local_.inquire.context = FFEEXPR_contextFILECHAR;
- break;
-
- case FFESTR_inquireDELIM:
- ffestb_local_.inquire.ix = FFESTP_inquireixDELIM;
- ffestb_local_.inquire.left = TRUE;
- ffestb_local_.inquire.context = FFEEXPR_contextFILEDFCHAR;
- break;
+ if (ffestp_file.delete.delete_spec[ix].kw_present)
+ ffelex_token_kill (ffestp_file.delete.delete_spec[ix].kw);
+ if (ffestp_file.delete.delete_spec[ix].value_present)
+ ffelex_token_kill (ffestp_file.delete.delete_spec[ix].value);
+ }
+ }
+}
- case FFESTR_inquireDIRECT:
- ffestb_local_.inquire.ix = FFESTP_inquireixDIRECT;
- ffestb_local_.inquire.left = TRUE;
- ffestb_local_.inquire.context = FFEEXPR_contextFILEDFCHAR;
- break;
+#endif
+/* ffestb_subr_kill_inquire_ -- Kill INQUIRE statement data structure
- case FFESTR_inquireERR:
- ffestb_local_.inquire.ix = FFESTP_inquireixERR;
- ffestb_local_.inquire.label = TRUE;
- break;
+ ffestb_subr_kill_inquire_();
- case FFESTR_inquireEXIST:
- ffestb_local_.inquire.ix = FFESTP_inquireixEXIST;
- ffestb_local_.inquire.left = TRUE;
- ffestb_local_.inquire.context = FFEEXPR_contextFILELOG;
- break;
+ Kills all tokens in the INQUIRE data structure. */
- case FFESTR_inquireFILE:
- ffestb_local_.inquire.ix = FFESTP_inquireixFILE;
- ffestb_local_.inquire.left = FALSE;
- ffestb_local_.inquire.context = FFEEXPR_contextFILECHAR;
- break;
+#if !FFESTB_KILL_EASY_
+static void
+ffestb_subr_kill_inquire_ ()
+{
+ ffestpInquireIx ix;
- case FFESTR_inquireFORM:
- ffestb_local_.inquire.ix = FFESTP_inquireixFORM;
- ffestb_local_.inquire.left = TRUE;
- ffestb_local_.inquire.context = FFEEXPR_contextFILEDFCHAR;
- break;
+ for (ix = 0; ix < FFESTP_inquireix; ++ix)
+ {
+ if (ffestp_file.inquire.inquire_spec[ix].kw_or_val_present)
+ {
+ if (ffestp_file.inquire.inquire_spec[ix].kw_present)
+ ffelex_token_kill (ffestp_file.inquire.inquire_spec[ix].kw);
+ if (ffestp_file.inquire.inquire_spec[ix].value_present)
+ ffelex_token_kill (ffestp_file.inquire.inquire_spec[ix].value);
+ }
+ }
+}
- case FFESTR_inquireFORMATTED:
- ffestb_local_.inquire.ix = FFESTP_inquireixFORMATTED;
- ffestb_local_.inquire.left = TRUE;
- ffestb_local_.inquire.context = FFEEXPR_contextFILEDFCHAR;
- break;
+#endif
+/* ffestb_subr_kill_open_ -- Kill OPEN statement data structure
- case FFESTR_inquireIOLENGTH:
- if (!ffestb_local_.inquire.may_be_iolength)
- goto bad; /* :::::::::::::::::::: */
- ffestb_local_.inquire.ix = FFESTP_inquireixIOLENGTH;
- ffestb_local_.inquire.left = TRUE;
- ffestb_local_.inquire.context = FFEEXPR_contextFILEINT;
- break;
+ ffestb_subr_kill_open_();
- case FFESTR_inquireIOSTAT:
- ffestb_local_.inquire.ix = FFESTP_inquireixIOSTAT;
- ffestb_local_.inquire.left = TRUE;
- ffestb_local_.inquire.context = FFEEXPR_contextFILEINT;
- break;
+ Kills all tokens in the OPEN data structure. */
- case FFESTR_inquireKEYED:
- ffestb_local_.inquire.ix = FFESTP_inquireixKEYED;
- ffestb_local_.inquire.left = TRUE;
- ffestb_local_.inquire.context = FFEEXPR_contextFILECHAR;
- break;
+#if !FFESTB_KILL_EASY_
+static void
+ffestb_subr_kill_open_ ()
+{
+ ffestpOpenIx ix;
- case FFESTR_inquireNAME:
- ffestb_local_.inquire.ix = FFESTP_inquireixNAME;
- ffestb_local_.inquire.left = TRUE;
- ffestb_local_.inquire.context = FFEEXPR_contextFILECHAR;
- break;
+ for (ix = 0; ix < FFESTP_openix; ++ix)
+ {
+ if (ffestp_file.open.open_spec[ix].kw_or_val_present)
+ {
+ if (ffestp_file.open.open_spec[ix].kw_present)
+ ffelex_token_kill (ffestp_file.open.open_spec[ix].kw);
+ if (ffestp_file.open.open_spec[ix].value_present)
+ ffelex_token_kill (ffestp_file.open.open_spec[ix].value);
+ }
+ }
+}
- case FFESTR_inquireNAMED:
- ffestb_local_.inquire.ix = FFESTP_inquireixNAMED;
- ffestb_local_.inquire.left = TRUE;
- ffestb_local_.inquire.context = FFEEXPR_contextFILELOG;
- break;
+#endif
+/* ffestb_subr_kill_print_ -- Kill PRINT statement data structure
- case FFESTR_inquireNEXTREC:
- ffestb_local_.inquire.ix = FFESTP_inquireixNEXTREC;
- ffestb_local_.inquire.left = TRUE;
- ffestb_local_.inquire.context = FFEEXPR_contextFILEDFINT;
- break;
+ ffestb_subr_kill_print_();
- case FFESTR_inquireNUMBER:
- ffestb_local_.inquire.ix = FFESTP_inquireixNUMBER;
- ffestb_local_.inquire.left = TRUE;
- ffestb_local_.inquire.context = FFEEXPR_contextFILEINT;
- break;
+ Kills all tokens in the PRINT data structure. */
- case FFESTR_inquireOPENED:
- ffestb_local_.inquire.ix = FFESTP_inquireixOPENED;
- ffestb_local_.inquire.left = TRUE;
- ffestb_local_.inquire.context = FFEEXPR_contextFILELOG;
- break;
+#if !FFESTB_KILL_EASY_
+static void
+ffestb_subr_kill_print_ ()
+{
+ ffestpPrintIx ix;
- case FFESTR_inquireORGANIZATION:
- ffestb_local_.inquire.ix = FFESTP_inquireixORGANIZATION;
- ffestb_local_.inquire.left = TRUE;
- ffestb_local_.inquire.context = FFEEXPR_contextFILECHAR;
- break;
+ for (ix = 0; ix < FFESTP_printix; ++ix)
+ {
+ if (ffestp_file.print.print_spec[ix].kw_or_val_present)
+ {
+ if (ffestp_file.print.print_spec[ix].kw_present)
+ ffelex_token_kill (ffestp_file.print.print_spec[ix].kw);
+ if (ffestp_file.print.print_spec[ix].value_present)
+ ffelex_token_kill (ffestp_file.print.print_spec[ix].value);
+ }
+ }
+}
- case FFESTR_inquirePAD:
- ffestb_local_.inquire.ix = FFESTP_inquireixPAD;
- ffestb_local_.inquire.left = TRUE;
- ffestb_local_.inquire.context = FFEEXPR_contextFILEDFCHAR;
- break;
+#endif
+/* ffestb_subr_kill_read_ -- Kill READ statement data structure
- case FFESTR_inquirePOSITION:
- ffestb_local_.inquire.ix = FFESTP_inquireixPOSITION;
- ffestb_local_.inquire.left = TRUE;
- ffestb_local_.inquire.context = FFEEXPR_contextFILEDFCHAR;
- break;
+ ffestb_subr_kill_read_();
- case FFESTR_inquireREAD:
- ffestb_local_.inquire.ix = FFESTP_inquireixREAD;
- ffestb_local_.inquire.left = TRUE;
- ffestb_local_.inquire.context = FFEEXPR_contextFILEDFCHAR;
- break;
+ Kills all tokens in the READ data structure. */
- case FFESTR_inquireREADWRITE:
- ffestb_local_.inquire.ix = FFESTP_inquireixREADWRITE;
- ffestb_local_.inquire.left = TRUE;
- ffestb_local_.inquire.context = FFEEXPR_contextFILEDFCHAR;
- break;
+#if !FFESTB_KILL_EASY_
+static void
+ffestb_subr_kill_read_ ()
+{
+ ffestpReadIx ix;
- case FFESTR_inquireRECL:
- ffestb_local_.inquire.ix = FFESTP_inquireixRECL;
- ffestb_local_.inquire.left = TRUE;
- ffestb_local_.inquire.context = FFEEXPR_contextFILEINT;
- break;
+ for (ix = 0; ix < FFESTP_readix; ++ix)
+ {
+ if (ffestp_file.read.read_spec[ix].kw_or_val_present)
+ {
+ if (ffestp_file.read.read_spec[ix].kw_present)
+ ffelex_token_kill (ffestp_file.read.read_spec[ix].kw);
+ if (ffestp_file.read.read_spec[ix].value_present)
+ ffelex_token_kill (ffestp_file.read.read_spec[ix].value);
+ }
+ }
+}
- case FFESTR_inquireRECORDTYPE:
- ffestb_local_.inquire.ix = FFESTP_inquireixRECORDTYPE;
- ffestb_local_.inquire.left = TRUE;
- ffestb_local_.inquire.context = FFEEXPR_contextFILECHAR;
- break;
+#endif
+/* ffestb_subr_kill_rewrite_ -- Kill REWRITE statement data structure
- case FFESTR_inquireSEQUENTIAL:
- ffestb_local_.inquire.ix = FFESTP_inquireixSEQUENTIAL;
- ffestb_local_.inquire.left = TRUE;
- ffestb_local_.inquire.context = FFEEXPR_contextFILEDFCHAR;
- break;
+ ffestb_subr_kill_rewrite_();
- case FFESTR_inquireUNFORMATTED:
- ffestb_local_.inquire.ix = FFESTP_inquireixUNFORMATTED;
- ffestb_local_.inquire.left = TRUE;
- ffestb_local_.inquire.context = FFEEXPR_contextFILEDFCHAR;
- break;
+ Kills all tokens in the REWRITE data structure. */
- case FFESTR_inquireUNIT:
- ffestb_local_.inquire.ix = FFESTP_inquireixUNIT;
- ffestb_local_.inquire.left = FALSE;
- ffestb_local_.inquire.context = FFEEXPR_contextFILENUM;
- break;
+#if !FFESTB_KILL_EASY_
+static void
+ffestb_subr_kill_rewrite_ ()
+{
+ ffestpRewriteIx ix;
- default:
- goto bad; /* :::::::::::::::::::: */
+ for (ix = 0; ix < FFESTP_rewriteix; ++ix)
+ {
+ if (ffestp_file.rewrite.rewrite_spec[ix].kw_or_val_present)
+ {
+ if (ffestp_file.rewrite.rewrite_spec[ix].kw_present)
+ ffelex_token_kill (ffestp_file.rewrite.rewrite_spec[ix].kw);
+ if (ffestp_file.rewrite.rewrite_spec[ix].value_present)
+ ffelex_token_kill (ffestp_file.rewrite.rewrite_spec[ix].value);
}
- if (ffestp_file.inquire.inquire_spec[ffestb_local_.inquire.ix]
- .kw_or_val_present)
- break; /* Can't specify a keyword twice! */
- ffestp_file.inquire.inquire_spec[ffestb_local_.inquire.ix]
- .kw_or_val_present = TRUE;
- ffestp_file.inquire.inquire_spec[ffestb_local_.inquire.ix]
- .kw_present = TRUE;
- ffestp_file.inquire.inquire_spec[ffestb_local_.inquire.ix]
- .value_present = FALSE;
- ffestp_file.inquire.inquire_spec[ffestb_local_.inquire.ix].value_is_label
- = ffestb_local_.inquire.label;
- ffestp_file.inquire.inquire_spec[ffestb_local_.inquire.ix].kw
- = ffelex_token_use (t);
- return (ffelexHandler) ffestb_R9235_;
-
- default:
- break;
}
-
-bad: /* :::::::::::::::::::: */
- ffestb_subr_kill_inquire_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INQUIRE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R9235_ -- "INQUIRE" OPEN_PAREN [external-file-unit COMMA] NAME
+#endif
+/* ffestb_subr_kill_type_ -- Kill TYPE statement data structure
- return ffestb_R9235_; // to lexer
+ ffestb_subr_kill_type_();
- Make sure EQUALS here, send next token to expression handler. */
+ Kills all tokens in the TYPE data structure. */
-static ffelexHandler
-ffestb_R9235_ (ffelexToken t)
+#if !FFESTB_KILL_EASY_
+static void
+ffestb_subr_kill_type_ ()
{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeEQUALS:
- ffesta_confirmed ();
- if (ffestb_local_.inquire.label)
- return (ffelexHandler) ffestb_R9237_;
- if (ffestb_local_.inquire.left)
- return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool,
- ffestb_local_.inquire.context,
- (ffeexprCallback) ffestb_R9236_);
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- ffestb_local_.inquire.context,
- (ffeexprCallback) ffestb_R9236_);
+ ffestpTypeIx ix;
- default:
- break;
+ for (ix = 0; ix < FFESTP_typeix; ++ix)
+ {
+ if (ffestp_file.type.type_spec[ix].kw_or_val_present)
+ {
+ if (ffestp_file.type.type_spec[ix].kw_present)
+ ffelex_token_kill (ffestp_file.type.type_spec[ix].kw);
+ if (ffestp_file.type.type_spec[ix].value_present)
+ ffelex_token_kill (ffestp_file.type.type_spec[ix].value);
+ }
}
-
- ffestb_subr_kill_inquire_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INQUIRE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R9236_ -- "INQUIRE" OPEN_PAREN ... NAME EQUALS expr
+#endif
+/* ffestb_subr_kill_write_ -- Kill WRITE statement data structure
- (ffestb_R9236_) // to expression handler
+ ffestb_subr_kill_write_();
- Handle COMMA or CLOSE_PAREN here. */
+ Kills all tokens in the WRITE data structure. */
-static ffelexHandler
-ffestb_R9236_ (ffelexToken ft, ffebld expr, ffelexToken t)
+#if !FFESTB_KILL_EASY_
+static void
+ffestb_subr_kill_write_ ()
{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- if (ffestb_local_.inquire.ix == FFESTP_inquireixIOLENGTH)
- break; /* IOLENGTH=expr must be followed by
- CLOSE_PAREN. */
- /* Fall through. */
- case FFELEX_typeCLOSE_PAREN:
- if (expr == NULL)
- break;
- ffestp_file.inquire.inquire_spec[ffestb_local_.inquire.ix].value_present
- = TRUE;
- ffestp_file.inquire.inquire_spec[ffestb_local_.inquire.ix].value
- = ffelex_token_use (ft);
- ffestp_file.inquire.inquire_spec[ffestb_local_.inquire.ix].u.expr = expr;
- if (ffelex_token_type (t) == FFELEX_typeCOMMA)
- return (ffelexHandler) ffestb_R9234_;
- if (ffestb_local_.inquire.ix == FFESTP_inquireixIOLENGTH)
- return (ffelexHandler) ffestb_R92310_;
- return (ffelexHandler) ffestb_R9239_;
+ ffestpWriteIx ix;
- default:
- break;
+ for (ix = 0; ix < FFESTP_writeix; ++ix)
+ {
+ if (ffestp_file.write.write_spec[ix].kw_or_val_present)
+ {
+ if (ffestp_file.write.write_spec[ix].kw_present)
+ ffelex_token_kill (ffestp_file.write.write_spec[ix].kw);
+ if (ffestp_file.write.write_spec[ix].value_present)
+ ffelex_token_kill (ffestp_file.write.write_spec[ix].value);
+ }
}
-
- ffestb_subr_kill_inquire_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INQUIRE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R9237_ -- "INQUIRE" OPEN_PAREN ... NAME EQUALS
+#endif
+/* ffestb_beru -- Parse the BACKSPACE/ENDFILE/REWIND/UNLOCK statement
- return ffestb_R9237_; // to lexer
+ return ffestb_beru; // to lexer
- Handle NUMBER for label here. */
+ Make sure the statement has a valid form for the BACKSPACE/ENDFILE/REWIND/
+ UNLOCK statement. If it does, implement the statement. */
-static ffelexHandler
-ffestb_R9237_ (ffelexToken t)
+ffelexHandler
+ffestb_beru (ffelexToken t)
{
- switch (ffelex_token_type (t))
+ ffelexHandler next;
+ ffestpBeruIx ix;
+
+ switch (ffelex_token_type (ffesta_tokens[0]))
{
- case FFELEX_typeNUMBER:
- ffestp_file.inquire.inquire_spec[ffestb_local_.inquire.ix].value_present
- = TRUE;
- ffestp_file.inquire.inquire_spec[ffestb_local_.inquire.ix].value
- = ffelex_token_use (t);
- return (ffelexHandler) ffestb_R9238_;
+ case FFELEX_typeNAME:
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeCOMMA:
+ case FFELEX_typeCOLONCOLON:
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ ffesta_confirmed (); /* Error, but clearly intended. */
+ goto bad_1; /* :::::::::::::::::::: */
+
+ case FFELEX_typeEQUALS:
+ case FFELEX_typePOINTS:
+ case FFELEX_typeCOLON:
+ goto bad_1; /* :::::::::::::::::::: */
+
+ case FFELEX_typeNAME:
+ case FFELEX_typeNUMBER:
+ ffesta_confirmed ();
+ break;
+
+ case FFELEX_typeOPEN_PAREN:
+ for (ix = 0; ix < FFESTP_beruix; ++ix)
+ ffestp_file.beru.beru_spec[ix].kw_or_val_present = FALSE;
+ ffesta_tokens[1] = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_beru2_;
+
+ default:
+ break;
+ }
+
+ for (ix = 0; ix < FFESTP_beruix; ++ix)
+ ffestp_file.beru.beru_spec[ix].kw_or_val_present = FALSE;
+ return (ffelexHandler) (*((ffelexHandler)
+ ffeexpr_rhs (ffesta_output_pool,
+ FFEEXPR_contextFILENUM,
+ (ffeexprCallback) ffestb_beru1_)))
+ (t);
+
+ case FFELEX_typeNAMES:
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeCOMMA:
+ case FFELEX_typeCOLONCOLON:
+ ffesta_confirmed (); /* Error, but clearly intended. */
+ goto bad_1; /* :::::::::::::::::::: */
+
+ case FFELEX_typeEQUALS:
+ case FFELEX_typePOINTS:
+ case FFELEX_typeCOLON:
+ goto bad_1; /* :::::::::::::::::::: */
+
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ ffesta_confirmed ();
+ break;
+
+ case FFELEX_typeOPEN_PAREN:
+ if (ffelex_token_length (ffesta_tokens[0])
+ != ffestb_args.beru.len)
+ break;
+
+ for (ix = 0; ix < FFESTP_beruix; ++ix)
+ ffestp_file.beru.beru_spec[ix].kw_or_val_present = FALSE;
+ ffesta_tokens[1] = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_beru2_;
+
+ default:
+ break;
+ }
+ for (ix = 0; ix < FFESTP_beruix; ++ix)
+ ffestp_file.beru.beru_spec[ix].kw_or_val_present = FALSE;
+ next = (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ FFEEXPR_contextFILENUM, (ffeexprCallback) ffestb_beru1_);
+ next = (ffelexHandler) ffelex_splice_tokens (next, ffesta_tokens[0],
+ ffestb_args.beru.len);
+ if (next == NULL)
+ return (ffelexHandler) ffelex_swallow_tokens (t,
+ (ffelexHandler) ffesta_zero);
+ return (ffelexHandler) (*next) (t);
default:
- break;
+ goto bad_0; /* :::::::::::::::::::: */
}
- ffestb_subr_kill_inquire_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INQUIRE", t);
+bad_0: /* :::::::::::::::::::: */
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.beru.badname, ffesta_tokens[0]);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+
+bad_1: /* :::::::::::::::::::: */
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.beru.badname, t);
+ return (ffelexHandler) ffelex_swallow_tokens (t,
+ (ffelexHandler) ffesta_zero); /* Invalid second token. */
}
-/* ffestb_R9238_ -- "INQUIRE" OPEN_PAREN ... NAME EQUALS NUMBER
+/* ffestb_beru1_ -- "BACKSPACE/ENDFILE/REWIND/UNLOCK" expr
- return ffestb_R9238_; // to lexer
+ (ffestb_beru1_) // to expression handler
- Handle COMMA or CLOSE_PAREN here. */
+ Make sure the next token is an EOS or SEMICOLON. */
static ffelexHandler
-ffestb_R9238_ (ffelexToken t)
+ffestb_beru1_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeCOMMA:
- return (ffelexHandler) ffestb_R9234_;
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ if (expr == NULL)
+ break;
+ ffesta_confirmed ();
+ ffestp_file.beru.beru_spec[FFESTP_beruixUNIT].kw_or_val_present
+ = TRUE;
+ ffestp_file.beru.beru_spec[FFESTP_beruixUNIT].kw_present = FALSE;
+ ffestp_file.beru.beru_spec[FFESTP_beruixUNIT].value_present = TRUE;
+ ffestp_file.beru.beru_spec[FFESTP_beruixUNIT].value_is_label
+ = FALSE;
+ ffestp_file.beru.beru_spec[FFESTP_beruixUNIT].value
+ = ffelex_token_use (ft);
+ ffestp_file.beru.beru_spec[FFESTP_beruixUNIT].u.expr = expr;
+ if (!ffesta_is_inhibited ())
+ {
+ switch (ffesta_first_kw)
+ {
+ case FFESTR_firstBACKSPACE:
+ ffestc_R919 ();
+ break;
- case FFELEX_typeCLOSE_PAREN:
- return (ffelexHandler) ffestb_R9239_;
+ case FFESTR_firstENDFILE:
+ case FFESTR_firstEND:
+ ffestc_R920 ();
+ break;
+
+ case FFESTR_firstREWIND:
+ ffestc_R921 ();
+ break;
+
+ default:
+ assert (FALSE);
+ }
+ }
+ ffestb_subr_kill_beru_ ();
+ return (ffelexHandler) ffesta_zero (t);
default:
break;
}
- ffestb_subr_kill_inquire_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INQUIRE", t);
+ ffestb_subr_kill_beru_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.beru.badname, t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R9239_ -- "INQUIRE" OPEN_PAREN ... CLOSE_PAREN
+/* ffestb_beru2_ -- "BACKSPACE/ENDFILE/REWIND/UNLOCK" OPEN_PAREN
- return ffestb_R9239_; // to lexer
+ return ffestb_beru2_; // to lexer
- Handle EOS or SEMICOLON here. */
+ Handle expr construct (not NAME=expr construct) here. */
static ffelexHandler
-ffestb_R9239_ (ffelexToken t)
+ffestb_beru2_ (ffelexToken t)
{
+ ffelexToken nt;
+ ffelexHandler next;
+
switch (ffelex_token_type (t))
{
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- ffestc_R923A ();
- ffestb_subr_kill_inquire_ ();
- return (ffelexHandler) ffesta_zero (t);
+ case FFELEX_typeNAME:
+ ffesta_tokens[2] = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_beru3_;
default:
- break;
+ nt = ffesta_tokens[1];
+ next = (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ FFEEXPR_contextFILENUMAMBIG, (ffeexprCallback) ffestb_beru4_)))
+ (nt);
+ ffelex_token_kill (nt);
+ return (ffelexHandler) (*next) (t);
}
-
- ffestb_subr_kill_inquire_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INQUIRE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R92310_ -- "INQUIRE(IOLENGTH=expr)"
+/* ffestb_beru3_ -- "BACKSPACE/ENDFILE/REWIND/UNLOCK" OPEN_PAREN NAME
- return ffestb_R92310_; // to lexer
+ return ffestb_beru3_; // to lexer
- Make sure EOS or SEMICOLON not here; begin R923B processing and expect
- output IO list. */
+ If EQUALS here, go to states that handle it. Else, send NAME and this
+ token thru expression handler. */
static ffelexHandler
-ffestb_R92310_ (ffelexToken t)
+ffestb_beru3_ (ffelexToken t)
{
+ ffelexHandler next;
+ ffelexToken nt;
+ ffelexToken ot;
+
switch (ffelex_token_type (t))
{
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- break;
+ case FFELEX_typeEQUALS:
+ ffelex_token_kill (ffesta_tokens[1]);
+ nt = ffesta_tokens[2];
+ next = (ffelexHandler) ffestb_beru5_ (nt);
+ ffelex_token_kill (nt);
+ return (ffelexHandler) (*next) (t);
default:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- ffestc_R923B_start ();
- ffestb_subr_kill_inquire_ ();
- return (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextIOLIST, (ffeexprCallback) ffestb_R92311_)))
- (t);
+ nt = ffesta_tokens[1];
+ ot = ffesta_tokens[2];
+ next = (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ FFEEXPR_contextFILENUMAMBIG, (ffeexprCallback) ffestb_beru4_)))
+ (nt);
+ ffelex_token_kill (nt);
+ next = (ffelexHandler) (*next) (ot);
+ ffelex_token_kill (ot);
+ return (ffelexHandler) (*next) (t);
}
-
- ffestb_subr_kill_inquire_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INQUIRE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R92311_ -- "INQUIRE(IOLENGTH=expr)" expr
+/* ffestb_beru4_ -- "BACKSPACE/ENDFILE/REWIND/UNLOCK" OPEN_PAREN expr [CLOSE_PAREN]
- (ffestb_R92311_) // to expression handler
+ (ffestb_beru4_) // to expression handler
- Handle COMMA or EOS/SEMICOLON here. */
+ Handle COMMA or EOS/SEMICOLON here.
+
+ 15-Feb-91 JCB 1.2
+ Now using new mechanism whereby expr comes back as opITEM if the
+ expr is considered part (or all) of an I/O control list (and should
+ be stripped of its outer opITEM node) or not if it is considered
+ a plain unit number that happens to have been enclosed in parens.
+ 26-Mar-90 JCB 1.1
+ No longer expecting close-paren here because of constructs like
+ BACKSPACE (5)+2, so now expecting either COMMA because it was a
+ construct like BACKSPACE (5+2,... or EOS/SEMICOLON because it is like
+ the former construct. Ah, the vagaries of Fortran. */
static ffelexHandler
-ffestb_R92311_ (ffelexToken ft, ffebld expr, ffelexToken t)
+ffestb_beru4_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
+ bool inlist;
+
switch (ffelex_token_type (t))
{
case FFELEX_typeCOMMA:
- if (expr == NULL)
- break;
- if (!ffesta_is_inhibited ())
- ffestc_R923B_item (expr, ft);
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextIOLIST, (ffeexprCallback) ffestb_R92311_);
-
case FFELEX_typeEOS:
case FFELEX_typeSEMICOLON:
+ case FFELEX_typeCLOSE_PAREN:
if (expr == NULL)
break;
- if (!ffesta_is_inhibited ())
+ if (ffebld_op (expr) == FFEBLD_opITEM)
{
- ffestc_R923B_item (expr, ft);
- ffestc_R923B_finish ();
+ inlist = TRUE;
+ expr = ffebld_head (expr);
}
- return (ffelexHandler) ffesta_zero (t);
+ else
+ inlist = FALSE;
+ ffestp_file.beru.beru_spec[FFESTP_beruixUNIT].kw_or_val_present
+ = TRUE;
+ ffestp_file.beru.beru_spec[FFESTP_beruixUNIT].kw_present = FALSE;
+ ffestp_file.beru.beru_spec[FFESTP_beruixUNIT].value_present = TRUE;
+ ffestp_file.beru.beru_spec[FFESTP_beruixUNIT].value_is_label
+ = FALSE;
+ ffestp_file.beru.beru_spec[FFESTP_beruixUNIT].value
+ = ffelex_token_use (ft);
+ ffestp_file.beru.beru_spec[FFESTP_beruixUNIT].u.expr = expr;
+ if (inlist)
+ return (ffelexHandler) ffestb_beru9_ (t);
+ return (ffelexHandler) ffestb_beru10_ (t);
default:
break;
}
- if (!ffesta_is_inhibited ())
- ffestc_R923B_finish ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INQUIRE", t);
+ ffestb_subr_kill_beru_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.beru.badname, t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_V018 -- Parse the REWRITE statement
+/* ffestb_beru5_ -- "BACKSPACE/ENDFILE/REWIND/UNLOCK" OPEN_PAREN [external-file-unit
+ COMMA]
- return ffestb_V018; // to lexer
+ return ffestb_beru5_; // to lexer
- Make sure the statement has a valid form for the REWRITE
- statement. If it does, implement the statement. */
+ Handle expr construct (not NAME=expr construct) here. */
-#if FFESTR_VXT
-ffelexHandler
-ffestb_V018 (ffelexToken t)
+static ffelexHandler
+ffestb_beru5_ (ffelexToken t)
{
- ffestpRewriteIx ix;
+ ffestrGenio kw;
- switch (ffelex_token_type (ffesta_tokens[0]))
+ ffestb_local_.beru.label = FALSE;
+
+ switch (ffelex_token_type (t))
{
case FFELEX_typeNAME:
- if (ffesta_first_kw != FFESTR_firstREWRITE)
- goto bad_0; /* :::::::::::::::::::: */
- switch (ffelex_token_type (t))
+ kw = ffestr_genio (t);
+ switch (kw)
{
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- case FFELEX_typeNAME:
- case FFELEX_typeNUMBER:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
-
- default:
- goto bad_1; /* :::::::::::::::::::: */
+ case FFESTR_genioERR:
+ ffestb_local_.beru.ix = FFESTP_beruixERR;
+ ffestb_local_.beru.label = TRUE;
+ break;
- case FFELEX_typeOPEN_PAREN:
- for (ix = 0; ix < FFESTP_rewriteix; ++ix)
- ffestp_file.rewrite.rewrite_spec[ix].kw_or_val_present = FALSE;
- return (ffelexHandler) ffestb_V0181_;
- }
+ case FFESTR_genioIOSTAT:
+ ffestb_local_.beru.ix = FFESTP_beruixIOSTAT;
+ ffestb_local_.beru.left = TRUE;
+ ffestb_local_.beru.context = FFEEXPR_contextFILEINT;
+ break;
- case FFELEX_typeNAMES:
- if (ffesta_first_kw != FFESTR_firstREWRITE)
- goto bad_0; /* :::::::::::::::::::: */
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
+ case FFESTR_genioUNIT:
+ ffestb_local_.beru.ix = FFESTP_beruixUNIT;
+ ffestb_local_.beru.left = FALSE;
+ ffestb_local_.beru.context = FFEEXPR_contextFILENUM;
+ break;
default:
- goto bad_1; /* :::::::::::::::::::: */
-
- case FFELEX_typeOPEN_PAREN:
- if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlREWRITE)
- goto bad_0; /* :::::::::::::::::::: */
-
- for (ix = 0; ix < FFESTP_rewriteix; ++ix)
- ffestp_file.rewrite.rewrite_spec[ix].kw_or_val_present = FALSE;
- return (ffelexHandler) ffestb_V0181_;
+ goto bad; /* :::::::::::::::::::: */
}
+ if (ffestp_file.beru.beru_spec[ffestb_local_.beru.ix]
+ .kw_or_val_present)
+ break; /* Can't specify a keyword twice! */
+ ffestp_file.beru.beru_spec[ffestb_local_.beru.ix]
+ .kw_or_val_present = TRUE;
+ ffestp_file.beru.beru_spec[ffestb_local_.beru.ix]
+ .kw_present = TRUE;
+ ffestp_file.beru.beru_spec[ffestb_local_.beru.ix]
+ .value_present = FALSE;
+ ffestp_file.beru.beru_spec[ffestb_local_.beru.ix].value_is_label
+ = ffestb_local_.beru.label;
+ ffestp_file.beru.beru_spec[ffestb_local_.beru.ix].kw
+ = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_beru6_;
default:
- goto bad_0; /* :::::::::::::::::::: */
+ break;
}
-bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "REWRITE", ffesta_tokens[0]);
+bad: /* :::::::::::::::::::: */
+ ffestb_subr_kill_beru_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.beru.badname, t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-
-bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "REWRITE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero); /* Invalid second token. */
-}
-
-/* ffestb_V0181_ -- "REWRITE" OPEN_PAREN
-
- return ffestb_V0181_; // to lexer
-
- Handle expr construct (not NAME=expr construct) here. */
-
-static ffelexHandler
-ffestb_V0181_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_V0182_;
-
- default:
- return (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextFILENUM, (ffeexprCallback) ffestb_V0183_)))
- (t);
- }
}
-/* ffestb_V0182_ -- "REWRITE" OPEN_PAREN NAME
+/* ffestb_beru6_ -- "BACKSPACE/ENDFILE/REWIND/UNLOCK" OPEN_PAREN [external-file-unit
+ COMMA] NAME
- return ffestb_V0182_; // to lexer
+ return ffestb_beru6_; // to lexer
- If EQUALS here, go to states that handle it. Else, send NAME and this
- token thru expression handler. */
+ Make sure EQUALS here, send next token to expression handler. */
static ffelexHandler
-ffestb_V0182_ (ffelexToken t)
+ffestb_beru6_ (ffelexToken t)
{
- ffelexHandler next;
- ffelexToken nt;
switch (ffelex_token_type (t))
{
case FFELEX_typeEQUALS:
- nt = ffesta_tokens[1];
- next = (ffelexHandler) ffestb_V0187_ (nt);
- ffelex_token_kill (nt);
- return (ffelexHandler) (*next) (t);
+ ffesta_confirmed ();
+ if (ffestb_local_.beru.label)
+ return (ffelexHandler) ffestb_beru8_;
+ if (ffestb_local_.beru.left)
+ return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool,
+ ffestb_local_.beru.context,
+ (ffeexprCallback) ffestb_beru7_);
+ return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ ffestb_local_.beru.context,
+ (ffeexprCallback) ffestb_beru7_);
default:
- nt = ffesta_tokens[1];
- next = (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextFILENUM, (ffeexprCallback) ffestb_V0183_)))
- (nt);
- ffelex_token_kill (nt);
- return (ffelexHandler) (*next) (t);
+ break;
}
+
+ ffestb_subr_kill_beru_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.beru.badname, t);
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_V0183_ -- "REWRITE" OPEN_PAREN expr [CLOSE_PAREN]
+/* ffestb_beru7_ -- "BACKSPACE/ENDFILE/REWIND/UNLOCK" OPEN_PAREN ... NAME EQUALS expr
- (ffestb_V0183_) // to expression handler
+ (ffestb_beru7_) // to expression handler
- Handle COMMA or EOS/SEMICOLON here. */
+ Handle COMMA or CLOSE_PAREN here. */
static ffelexHandler
-ffestb_V0183_ (ffelexToken ft, ffebld expr, ffelexToken t)
+ffestb_beru7_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
switch (ffelex_token_type (t))
{
case FFELEX_typeCLOSE_PAREN:
if (expr == NULL)
break;
- ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixUNIT].kw_or_val_present
+ ffestp_file.beru.beru_spec[ffestb_local_.beru.ix].value_present
= TRUE;
- ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixUNIT].kw_present = FALSE;
- ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixUNIT].value_present = TRUE;
- ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixUNIT].value_is_label
- = FALSE;
- ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixUNIT].value
+ ffestp_file.beru.beru_spec[ffestb_local_.beru.ix].value
= ffelex_token_use (ft);
- ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixUNIT].u.expr = expr;
+ ffestp_file.beru.beru_spec[ffestb_local_.beru.ix].u.expr = expr;
if (ffelex_token_type (t) == FFELEX_typeCOMMA)
- return (ffelexHandler) ffestb_V0184_;
- return (ffelexHandler) ffestb_V01812_;
+ return (ffelexHandler) ffestb_beru5_;
+ return (ffelexHandler) ffestb_beru10_;
default:
break;
}
- ffestb_subr_kill_rewrite_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "REWRITE", t);
+ ffestb_subr_kill_beru_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.beru.badname, t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_V0184_ -- "REWRITE" OPEN_PAREN expr COMMA
+/* ffestb_beru8_ -- "BACKSPACE/ENDFILE/REWIND/UNLOCK" OPEN_PAREN ... NAME EQUALS
- return ffestb_V0184_; // to lexer
+ return ffestb_beru8_; // to lexer
- Handle expr construct (not NAME=expr construct) here. */
+ Handle NUMBER for label here. */
static ffelexHandler
-ffestb_V0184_ (ffelexToken t)
+ffestb_beru8_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeNAME:
- ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_V0185_;
+ case FFELEX_typeNUMBER:
+ ffestp_file.beru.beru_spec[ffestb_local_.beru.ix].value_present
+ = TRUE;
+ ffestp_file.beru.beru_spec[ffestb_local_.beru.ix].value
+ = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_beru9_;
default:
- return (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextFILEFORMAT, (ffeexprCallback) ffestb_V0186_)))
- (t);
+ break;
}
-}
-
-/* ffestb_V0185_ -- "REWRITE" OPEN_PAREN expr COMMA NAME
-
- return ffestb_V0185_; // to lexer
-
- If EQUALS here, go to states that handle it. Else, send NAME and this
- token thru expression handler. */
-
-static ffelexHandler
-ffestb_V0185_ (ffelexToken t)
-{
- ffelexHandler next;
- ffelexToken nt;
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeEQUALS:
- nt = ffesta_tokens[1];
- next = (ffelexHandler) ffestb_V0187_ (nt);
- ffelex_token_kill (nt);
- return (ffelexHandler) (*next) (t);
- default:
- nt = ffesta_tokens[1];
- next = (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextFILEFORMAT, (ffeexprCallback) ffestb_V0186_)))
- (nt);
- ffelex_token_kill (nt);
- return (ffelexHandler) (*next) (t);
- }
+ ffestb_subr_kill_beru_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.beru.badname, t);
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_V0186_ -- "REWRITE" OPEN_PAREN expr COMMA expr
+/* ffestb_beru9_ -- "BACKSPACE/ENDFILE/REWIND/UNLOCK" OPEN_PAREN ... NAME EQUALS
+ NUMBER
- (ffestb_V0186_) // to expression handler
+ return ffestb_beru9_; // to lexer
Handle COMMA or CLOSE_PAREN here. */
static ffelexHandler
-ffestb_V0186_ (ffelexToken ft, ffebld expr, ffelexToken t)
+ffestb_beru9_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
case FFELEX_typeCOMMA:
+ return (ffelexHandler) ffestb_beru5_;
+
case FFELEX_typeCLOSE_PAREN:
- ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].kw_or_val_present
- = TRUE;
- ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].kw_present = FALSE;
- ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].value_present = TRUE;
- ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].value_is_label
- = (expr == NULL);
- ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].value
- = ffelex_token_use (ft);
- ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].u.expr = expr;
- if (ffelex_token_type (t) == FFELEX_typeCOMMA)
- return (ffelexHandler) ffestb_V0187_;
- return (ffelexHandler) ffestb_V01812_;
+ return (ffelexHandler) ffestb_beru10_;
default:
break;
}
- ffestb_subr_kill_rewrite_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "REWRITE", t);
+ ffestb_subr_kill_beru_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.beru.badname, t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_V0187_ -- "REWRITE" OPEN_PAREN [external-file-unit COMMA [format
- COMMA]]
+/* ffestb_beru10_ -- "BACKSPACE/ENDFILE/REWIND/UNLOCK" OPEN_PAREN ... CLOSE_PAREN
- return ffestb_V0187_; // to lexer
+ return ffestb_beru10_; // to lexer
- Handle expr construct (not NAME=expr construct) here. */
+ Handle EOS or SEMICOLON here. */
static ffelexHandler
-ffestb_V0187_ (ffelexToken t)
+ffestb_beru10_ (ffelexToken t)
{
- ffestrGenio kw;
-
- ffestb_local_.rewrite.label = FALSE;
-
switch (ffelex_token_type (t))
{
- case FFELEX_typeNAME:
- kw = ffestr_genio (t);
- switch (kw)
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ ffesta_confirmed ();
+ if (!ffesta_is_inhibited ())
{
- case FFESTR_genioERR:
- ffestb_local_.rewrite.ix = FFESTP_rewriteixERR;
- ffestb_local_.rewrite.label = TRUE;
- break;
-
- case FFESTR_genioFMT:
- ffestb_local_.rewrite.ix = FFESTP_rewriteixFMT;
- ffestb_local_.rewrite.left = FALSE;
- ffestb_local_.rewrite.context = FFEEXPR_contextFILEFORMAT;
- break;
+ switch (ffesta_first_kw)
+ {
+ case FFESTR_firstBACKSPACE:
+ ffestc_R919 ();
+ break;
- case FFESTR_genioIOSTAT:
- ffestb_local_.rewrite.ix = FFESTP_rewriteixIOSTAT;
- ffestb_local_.rewrite.left = TRUE;
- ffestb_local_.rewrite.context = FFEEXPR_contextFILEINT;
- break;
+ case FFESTR_firstENDFILE:
+ case FFESTR_firstEND:
+ ffestc_R920 ();
+ break;
- case FFESTR_genioUNIT:
- ffestb_local_.rewrite.ix = FFESTP_rewriteixUNIT;
- ffestb_local_.rewrite.left = FALSE;
- ffestb_local_.rewrite.context = FFEEXPR_contextFILENUM;
- break;
+ case FFESTR_firstREWIND:
+ ffestc_R921 ();
+ break;
- default:
- goto bad; /* :::::::::::::::::::: */
+ default:
+ assert (FALSE);
+ }
}
- if (ffestp_file.rewrite.rewrite_spec[ffestb_local_.rewrite.ix]
- .kw_or_val_present)
- break; /* Can't specify a keyword twice! */
- ffestp_file.rewrite.rewrite_spec[ffestb_local_.rewrite.ix]
- .kw_or_val_present = TRUE;
- ffestp_file.rewrite.rewrite_spec[ffestb_local_.rewrite.ix]
- .kw_present = TRUE;
- ffestp_file.rewrite.rewrite_spec[ffestb_local_.rewrite.ix]
- .value_present = FALSE;
- ffestp_file.rewrite.rewrite_spec[ffestb_local_.rewrite.ix].value_is_label
- = ffestb_local_.rewrite.label;
- ffestp_file.rewrite.rewrite_spec[ffestb_local_.rewrite.ix].kw
- = ffelex_token_use (t);
- return (ffelexHandler) ffestb_V0188_;
+ ffestb_subr_kill_beru_ ();
+ return (ffelexHandler) ffesta_zero (t);
default:
break;
}
-bad: /* :::::::::::::::::::: */
- ffestb_subr_kill_rewrite_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "REWRITE", t);
+ ffestb_subr_kill_beru_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.beru.badname, t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_V0188_ -- "REWRITE" OPEN_PAREN [external-file-unit COMMA [format
- COMMA]] NAME
+/* ffestb_R904 -- Parse an OPEN statement
- return ffestb_V0188_; // to lexer
+ return ffestb_R904; // to lexer
- Make sure EQUALS here, send next token to expression handler. */
+ Make sure the statement has a valid form for an OPEN statement.
+ If it does, implement the statement. */
-static ffelexHandler
-ffestb_V0188_ (ffelexToken t)
+ffelexHandler
+ffestb_R904 (ffelexToken t)
{
- switch (ffelex_token_type (t))
+ ffestpOpenIx ix;
+
+ switch (ffelex_token_type (ffesta_tokens[0]))
{
- case FFELEX_typeEQUALS:
- ffesta_confirmed ();
- if (ffestb_local_.rewrite.label)
- return (ffelexHandler) ffestb_V01810_;
- if (ffestb_local_.rewrite.left)
- return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool,
- ffestb_local_.rewrite.context,
- (ffeexprCallback) ffestb_V0189_);
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- ffestb_local_.rewrite.context,
- (ffeexprCallback) ffestb_V0189_);
+ case FFELEX_typeNAME:
+ if (ffesta_first_kw != FFESTR_firstOPEN)
+ goto bad_0; /* :::::::::::::::::::: */
+ break;
+
+ case FFELEX_typeNAMES:
+ if (ffesta_first_kw != FFESTR_firstOPEN)
+ goto bad_0; /* :::::::::::::::::::: */
+ if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlOPEN)
+ goto bad_0; /* :::::::::::::::::::: */
+ break;
default:
+ goto bad_0; /* :::::::::::::::::::: */
+ }
+
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeOPEN_PAREN:
break;
+
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ case FFELEX_typeCOMMA:
+ case FFELEX_typeCOLONCOLON:
+ ffesta_confirmed (); /* Error, but clearly intended. */
+ goto bad_1; /* :::::::::::::::::::: */
+
+ default:
+ goto bad_1; /* :::::::::::::::::::: */
}
- ffestb_subr_kill_rewrite_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "REWRITE", t);
+ for (ix = 0; ix < FFESTP_openix; ++ix)
+ ffestp_file.open.open_spec[ix].kw_or_val_present = FALSE;
+
+ return (ffelexHandler) ffestb_R9041_;
+
+bad_0: /* :::::::::::::::::::: */
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "OPEN", ffesta_tokens[0]);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+
+bad_1: /* :::::::::::::::::::: */
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "OPEN", t);
+ return (ffelexHandler) ffelex_swallow_tokens (t,
+ (ffelexHandler) ffesta_zero); /* Invalid second token. */
}
-/* ffestb_V0189_ -- "REWRITE" OPEN_PAREN ... NAME EQUALS expr
+/* ffestb_R9041_ -- "OPEN" OPEN_PAREN
- (ffestb_V0189_) // to expression handler
+ return ffestb_R9041_; // to lexer
- Handle COMMA or CLOSE_PAREN here. */
+ Handle expr construct (not NAME=expr construct) here. */
static ffelexHandler
-ffestb_V0189_ (ffelexToken ft, ffebld expr, ffelexToken t)
+ffestb_R9041_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeCOMMA:
- case FFELEX_typeCLOSE_PAREN:
- if (expr == NULL)
- if (ffestb_local_.rewrite.context == FFEEXPR_contextFILEFORMAT)
- ffestp_file.rewrite.rewrite_spec[ffestb_local_.rewrite.ix]
- .value_is_label = TRUE;
- else
- break;
- ffestp_file.rewrite.rewrite_spec[ffestb_local_.rewrite.ix].value_present
- = TRUE;
- ffestp_file.rewrite.rewrite_spec[ffestb_local_.rewrite.ix].value
- = ffelex_token_use (ft);
- ffestp_file.rewrite.rewrite_spec[ffestb_local_.rewrite.ix].u.expr = expr;
- if (ffelex_token_type (t) == FFELEX_typeCOMMA)
- return (ffelexHandler) ffestb_V0187_;
- return (ffelexHandler) ffestb_V01812_;
+ case FFELEX_typeNAME:
+ ffesta_tokens[1] = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_R9042_;
default:
- break;
+ return (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ FFEEXPR_contextFILENUM, (ffeexprCallback) ffestb_R9043_)))
+ (t);
}
-
- ffestb_subr_kill_rewrite_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "REWRITE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_V01810_ -- "REWRITE" OPEN_PAREN ... NAME EQUALS
+/* ffestb_R9042_ -- "OPEN" OPEN_PAREN NAME
- return ffestb_V01810_; // to lexer
+ return ffestb_R9042_; // to lexer
- Handle NUMBER for label here. */
+ If EQUALS here, go to states that handle it. Else, send NAME and this
+ token thru expression handler. */
static ffelexHandler
-ffestb_V01810_ (ffelexToken t)
+ffestb_R9042_ (ffelexToken t)
{
+ ffelexHandler next;
+ ffelexToken nt;
+
switch (ffelex_token_type (t))
{
- case FFELEX_typeNUMBER:
- ffestp_file.rewrite.rewrite_spec[ffestb_local_.rewrite.ix].value_present
- = TRUE;
- ffestp_file.rewrite.rewrite_spec[ffestb_local_.rewrite.ix].value
- = ffelex_token_use (t);
- return (ffelexHandler) ffestb_V01811_;
+ case FFELEX_typeEQUALS:
+ nt = ffesta_tokens[1];
+ next = (ffelexHandler) ffestb_R9044_ (nt);
+ ffelex_token_kill (nt);
+ return (ffelexHandler) (*next) (t);
default:
- break;
+ next = (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ FFEEXPR_contextFILENUM, (ffeexprCallback) ffestb_R9043_)))
+ (ffesta_tokens[1]);
+ ffelex_token_kill (ffesta_tokens[1]);
+ return (ffelexHandler) (*next) (t);
}
-
- ffestb_subr_kill_rewrite_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "REWRITE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_V01811_ -- "REWRITE" OPEN_PAREN ... NAME EQUALS NUMBER
+/* ffestb_R9043_ -- "OPEN" OPEN_PAREN expr
- return ffestb_V01811_; // to lexer
+ (ffestb_R9043_) // to expression handler
Handle COMMA or CLOSE_PAREN here. */
static ffelexHandler
-ffestb_V01811_ (ffelexToken t)
+ffestb_R9043_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
switch (ffelex_token_type (t))
{
case FFELEX_typeCOMMA:
- return (ffelexHandler) ffestb_V0187_;
-
case FFELEX_typeCLOSE_PAREN:
- return (ffelexHandler) ffestb_V01812_;
+ if (expr == NULL)
+ break;
+ ffestp_file.open.open_spec[FFESTP_openixUNIT].kw_or_val_present
+ = TRUE;
+ ffestp_file.open.open_spec[FFESTP_openixUNIT].kw_present = FALSE;
+ ffestp_file.open.open_spec[FFESTP_openixUNIT].value_present = TRUE;
+ ffestp_file.open.open_spec[FFESTP_openixUNIT].value_is_label
+ = FALSE;
+ ffestp_file.open.open_spec[FFESTP_openixUNIT].value
+ = ffelex_token_use (ft);
+ ffestp_file.open.open_spec[FFESTP_openixUNIT].u.expr = expr;
+ if (ffelex_token_type (t) == FFELEX_typeCOMMA)
+ return (ffelexHandler) ffestb_R9044_;
+ return (ffelexHandler) ffestb_R9049_;
default:
break;
}
- ffestb_subr_kill_rewrite_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "REWRITE", t);
+ ffestb_subr_kill_open_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "OPEN", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_V01812_ -- "REWRITE" OPEN_PAREN ... CLOSE_PAREN
+/* ffestb_R9044_ -- "OPEN" OPEN_PAREN [external-file-unit COMMA]
- return ffestb_V01812_; // to lexer
+ return ffestb_R9044_; // to lexer
- Handle EOS or SEMICOLON here. */
+ Handle expr construct (not NAME=expr construct) here. */
static ffelexHandler
-ffestb_V01812_ (ffelexToken t)
+ffestb_R9044_ (ffelexToken t)
{
+ ffestrOpen kw;
+
+ ffestb_local_.open.label = FALSE;
+
switch (ffelex_token_type (t))
{
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
+ case FFELEX_typeNAME:
+ kw = ffestr_open (t);
+ switch (kw)
{
- ffestc_V018_start ();
- ffestc_V018_finish ();
- }
- ffestb_subr_kill_rewrite_ ();
- return (ffelexHandler) ffesta_zero (t);
+ case FFESTR_openACCESS:
+ ffestb_local_.open.ix = FFESTP_openixACCESS;
+ ffestb_local_.open.left = FALSE;
+ ffestb_local_.open.context = FFEEXPR_contextFILEDFCHAR;
+ break;
- case FFELEX_typeNAME:
- case FFELEX_typeOPEN_PAREN:
- case FFELEX_typeCOMMA:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- ffestc_V018_start ();
- ffestb_subr_kill_rewrite_ ();
+ case FFESTR_openACTION:
+ ffestb_local_.open.ix = FFESTP_openixACTION;
+ ffestb_local_.open.left = FALSE;
+ ffestb_local_.open.context = FFEEXPR_contextFILEDFCHAR;
+ break;
- /* EXTENSION: Allow an optional preceding COMMA here if not pedantic.
- (f2c provides this extension, as do other compilers, supposedly.) */
+ case FFESTR_openASSOCIATEVARIABLE:
+ ffestb_local_.open.ix = FFESTP_openixASSOCIATEVARIABLE;
+ ffestb_local_.open.left = TRUE;
+ ffestb_local_.open.context = FFEEXPR_contextFILEASSOC;
+ break;
- if (!ffe_is_pedantic () && (ffelex_token_type (t) == FFELEX_typeCOMMA))
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextIOLIST, (ffeexprCallback) ffestb_V01813_);
+ case FFESTR_openBLANK:
+ ffestb_local_.open.ix = FFESTP_openixBLANK;
+ ffestb_local_.open.left = FALSE;
+ ffestb_local_.open.context = FFEEXPR_contextFILEDFCHAR;
+ break;
- return (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextIOLIST, (ffeexprCallback) ffestb_V01813_)))
- (t);
+ case FFESTR_openBLOCKSIZE:
+ ffestb_local_.open.ix = FFESTP_openixBLOCKSIZE;
+ ffestb_local_.open.left = FALSE;
+ ffestb_local_.open.context = FFEEXPR_contextFILENUM;
+ break;
- default:
- break;
- }
+ case FFESTR_openBUFFERCOUNT:
+ ffestb_local_.open.ix = FFESTP_openixBUFFERCOUNT;
+ ffestb_local_.open.left = FALSE;
+ ffestb_local_.open.context = FFEEXPR_contextFILENUM;
+ break;
- ffestb_subr_kill_rewrite_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "REWRITE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
+ case FFESTR_openCARRIAGECONTROL:
+ ffestb_local_.open.ix = FFESTP_openixCARRIAGECONTROL;
+ ffestb_local_.open.left = FALSE;
+ ffestb_local_.open.context = FFEEXPR_contextFILECHAR;
+ break;
+
+ case FFESTR_openDEFAULTFILE:
+ ffestb_local_.open.ix = FFESTP_openixDEFAULTFILE;
+ ffestb_local_.open.left = FALSE;
+ ffestb_local_.open.context = FFEEXPR_contextFILECHAR;
+ break;
+
+ case FFESTR_openDELIM:
+ ffestb_local_.open.ix = FFESTP_openixDELIM;
+ ffestb_local_.open.left = FALSE;
+ ffestb_local_.open.context = FFEEXPR_contextFILEDFCHAR;
+ break;
-/* ffestb_V01813_ -- "REWRITE(...)" expr
+ case FFESTR_openDISP:
+ case FFESTR_openDISPOSE:
+ ffestb_local_.open.ix = FFESTP_openixDISPOSE;
+ ffestb_local_.open.left = FALSE;
+ ffestb_local_.open.context = FFEEXPR_contextFILECHAR;
+ break;
- (ffestb_V01813_) // to expression handler
+ case FFESTR_openERR:
+ ffestb_local_.open.ix = FFESTP_openixERR;
+ ffestb_local_.open.label = TRUE;
+ break;
- Handle COMMA or EOS/SEMICOLON here. */
+ case FFESTR_openEXTENDSIZE:
+ ffestb_local_.open.ix = FFESTP_openixEXTENDSIZE;
+ ffestb_local_.open.left = FALSE;
+ ffestb_local_.open.context = FFEEXPR_contextFILENUM;
+ break;
-static ffelexHandler
-ffestb_V01813_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- if (expr == NULL)
- break;
- if (!ffesta_is_inhibited ())
- ffestc_V018_item (expr, ft);
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextIOLIST, (ffeexprCallback) ffestb_V01813_);
+ case FFESTR_openFILE:
+ case FFESTR_openNAME:
+ ffestb_local_.open.ix = FFESTP_openixFILE;
+ ffestb_local_.open.left = FALSE;
+ ffestb_local_.open.context = FFEEXPR_contextFILECHAR;
+ break;
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- if (expr == NULL)
- break;
- if (!ffesta_is_inhibited ())
- {
- ffestc_V018_item (expr, ft);
- ffestc_V018_finish ();
- }
- return (ffelexHandler) ffesta_zero (t);
+ case FFESTR_openFORM:
+ ffestb_local_.open.ix = FFESTP_openixFORM;
+ ffestb_local_.open.left = FALSE;
+ ffestb_local_.open.context = FFEEXPR_contextFILEDFCHAR;
+ break;
- default:
- break;
- }
+ case FFESTR_openINITIALSIZE:
+ ffestb_local_.open.ix = FFESTP_openixINITIALSIZE;
+ ffestb_local_.open.left = FALSE;
+ ffestb_local_.open.context = FFEEXPR_contextFILENUM;
+ break;
- if (!ffesta_is_inhibited ())
- ffestc_V018_finish ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "REWRITE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
+ case FFESTR_openIOSTAT:
+ ffestb_local_.open.ix = FFESTP_openixIOSTAT;
+ ffestb_local_.open.left = TRUE;
+ ffestb_local_.open.context = FFEEXPR_contextFILEINT;
+ break;
+
+#if 0 /* Haven't added support for expression
+ context yet (though easy). */
+ case FFESTR_openKEY:
+ ffestb_local_.open.ix = FFESTP_openixKEY;
+ ffestb_local_.open.left = FALSE;
+ ffestb_local_.open.context = FFEEXPR_contextFILEKEY;
+ break;
+#endif
-/* ffestb_V019 -- Parse the ACCEPT statement
+ case FFESTR_openMAXREC:
+ ffestb_local_.open.ix = FFESTP_openixMAXREC;
+ ffestb_local_.open.left = FALSE;
+ ffestb_local_.open.context = FFEEXPR_contextFILENUM;
+ break;
- return ffestb_V019; // to lexer
+ case FFESTR_openNOSPANBLOCKS:
+ if (ffestp_file.open.open_spec[FFESTP_openixNOSPANBLOCKS]
+ .kw_or_val_present)
+ goto bad; /* :::::::::::::::::::: */
+ ffestp_file.open.open_spec[FFESTP_openixNOSPANBLOCKS]
+ .kw_or_val_present = TRUE;
+ ffestp_file.open.open_spec[FFESTP_openixNOSPANBLOCKS]
+ .kw_present = TRUE;
+ ffestp_file.open.open_spec[FFESTP_openixNOSPANBLOCKS]
+ .value_present = FALSE;
+ ffestp_file.open.open_spec[FFESTP_openixNOSPANBLOCKS].kw
+ = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_R9048_;
- Make sure the statement has a valid form for the ACCEPT
- statement. If it does, implement the statement. */
+ case FFESTR_openORGANIZATION:
+ ffestb_local_.open.ix = FFESTP_openixORGANIZATION;
+ ffestb_local_.open.left = FALSE;
+ ffestb_local_.open.context = FFEEXPR_contextFILECHAR;
+ break;
-ffelexHandler
-ffestb_V019 (ffelexToken t)
-{
- ffelexHandler next;
- ffestpAcceptIx ix;
+ case FFESTR_openPAD:
+ ffestb_local_.open.ix = FFESTP_openixPAD;
+ ffestb_local_.open.left = FALSE;
+ ffestb_local_.open.context = FFEEXPR_contextFILEDFCHAR;
+ break;
- switch (ffelex_token_type (ffesta_tokens[0]))
- {
- case FFELEX_typeNAME:
- if (ffesta_first_kw != FFESTR_firstACCEPT)
- goto bad_0; /* :::::::::::::::::::: */
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
+ case FFESTR_openPOSITION:
+ ffestb_local_.open.ix = FFESTP_openixPOSITION;
+ ffestb_local_.open.left = FALSE;
+ ffestb_local_.open.context = FFEEXPR_contextFILEDFCHAR;
+ break;
- case FFELEX_typeEQUALS:
- case FFELEX_typePOINTS:
- case FFELEX_typeCOLON:
- goto bad_1; /* :::::::::::::::::::: */
+ case FFESTR_openREADONLY:
+ if (ffestp_file.open.open_spec[FFESTP_openixREADONLY]
+ .kw_or_val_present)
+ goto bad; /* :::::::::::::::::::: */
+ ffestp_file.open.open_spec[FFESTP_openixREADONLY]
+ .kw_or_val_present = TRUE;
+ ffestp_file.open.open_spec[FFESTP_openixREADONLY]
+ .kw_present = TRUE;
+ ffestp_file.open.open_spec[FFESTP_openixREADONLY]
+ .value_present = FALSE;
+ ffestp_file.open.open_spec[FFESTP_openixREADONLY].kw
+ = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_R9048_;
- case FFELEX_typeNAME:
- case FFELEX_typeNUMBER:
- ffesta_confirmed ();
+ case FFESTR_openRECL:
+ case FFESTR_openRECORDSIZE:
+ ffestb_local_.open.ix = FFESTP_openixRECL;
+ ffestb_local_.open.left = FALSE;
+ ffestb_local_.open.context = FFEEXPR_contextFILENUM;
break;
- default:
+ case FFESTR_openRECORDTYPE:
+ ffestb_local_.open.ix = FFESTP_openixRECORDTYPE;
+ ffestb_local_.open.left = FALSE;
+ ffestb_local_.open.context = FFEEXPR_contextFILECHAR;
break;
- }
- for (ix = 0; ix < FFESTP_acceptix; ++ix)
- ffestp_file.accept.accept_spec[ix].kw_or_val_present = FALSE;
- return (ffelexHandler) (*((ffelexHandler)
- ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextFILEFORMATNML, (ffeexprCallback) ffestb_V0191_)))
- (t);
+ case FFESTR_openSHARED:
+ if (ffestp_file.open.open_spec[FFESTP_openixSHARED]
+ .kw_or_val_present)
+ goto bad; /* :::::::::::::::::::: */
+ ffestp_file.open.open_spec[FFESTP_openixSHARED]
+ .kw_or_val_present = TRUE;
+ ffestp_file.open.open_spec[FFESTP_openixSHARED]
+ .kw_present = TRUE;
+ ffestp_file.open.open_spec[FFESTP_openixSHARED]
+ .value_present = FALSE;
+ ffestp_file.open.open_spec[FFESTP_openixSHARED].kw
+ = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_R9048_;
- case FFELEX_typeNAMES:
- if (ffesta_first_kw != FFESTR_firstACCEPT)
- goto bad_0; /* :::::::::::::::::::: */
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- case FFELEX_typeCOMMA:
- ffesta_confirmed ();
- if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlACCEPT)
- break;
- goto bad_1; /* :::::::::::::::::::: */
+ case FFESTR_openSTATUS:
+ case FFESTR_openTYPE:
+ ffestb_local_.open.ix = FFESTP_openixSTATUS;
+ ffestb_local_.open.left = FALSE;
+ ffestb_local_.open.context = FFEEXPR_contextFILEDFCHAR;
+ break;
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
+ case FFESTR_openUNIT:
+ ffestb_local_.open.ix = FFESTP_openixUNIT;
+ ffestb_local_.open.left = FALSE;
+ ffestb_local_.open.context = FFEEXPR_contextFILENUM;
+ break;
- case FFELEX_typeEQUALS:
- case FFELEX_typePOINTS:
- case FFELEX_typeCOLON:
- goto bad_1; /* :::::::::::::::::::: */
+ case FFESTR_openUSEROPEN:
+ ffestb_local_.open.ix = FFESTP_openixUSEROPEN;
+ ffestb_local_.open.left = TRUE;
+ ffestb_local_.open.context = FFEEXPR_contextFILEEXTFUNC;
+ break;
default:
- break;
+ goto bad; /* :::::::::::::::::::: */
}
- for (ix = 0; ix < FFESTP_acceptix; ++ix)
- ffestp_file.accept.accept_spec[ix].kw_or_val_present = FALSE;
- next = (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextFILEFORMATNML, (ffeexprCallback) ffestb_V0191_);
- next = (ffelexHandler) ffelex_splice_tokens (next, ffesta_tokens[0],
- FFESTR_firstlACCEPT);
- if (next == NULL)
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero);
- return (ffelexHandler) (*next) (t);
+ if (ffestp_file.open.open_spec[ffestb_local_.open.ix]
+ .kw_or_val_present)
+ break; /* Can't specify a keyword twice! */
+ ffestp_file.open.open_spec[ffestb_local_.open.ix]
+ .kw_or_val_present = TRUE;
+ ffestp_file.open.open_spec[ffestb_local_.open.ix]
+ .kw_present = TRUE;
+ ffestp_file.open.open_spec[ffestb_local_.open.ix]
+ .value_present = FALSE;
+ ffestp_file.open.open_spec[ffestb_local_.open.ix].value_is_label
+ = ffestb_local_.open.label;
+ ffestp_file.open.open_spec[ffestb_local_.open.ix].kw
+ = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_R9045_;
default:
- goto bad_0; /* :::::::::::::::::::: */
+ break;
}
-bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "ACCEPT", ffesta_tokens[0]);
+bad: /* :::::::::::::::::::: */
+ ffestb_subr_kill_open_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "OPEN", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-
-bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "ACCEPT", t);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero); /* Invalid second token. */
}
-/* ffestb_V0191_ -- "ACCEPT" expr
+/* ffestb_R9045_ -- "OPEN" OPEN_PAREN [external-file-unit COMMA] NAME
- (ffestb_V0191_) // to expression handler
+ return ffestb_R9045_; // to lexer
- Make sure the next token is a COMMA or EOS/SEMICOLON. */
+ Make sure EQUALS here, send next token to expression handler. */
static ffelexHandler
-ffestb_V0191_ (ffelexToken ft, ffebld expr, ffelexToken t)
+ffestb_R9045_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- case FFELEX_typeCOMMA:
+ case FFELEX_typeEQUALS:
ffesta_confirmed ();
- ffestp_file.accept.accept_spec[FFESTP_acceptixFORMAT].kw_or_val_present
- = TRUE;
- ffestp_file.accept.accept_spec[FFESTP_acceptixFORMAT].kw_present = FALSE;
- ffestp_file.accept.accept_spec[FFESTP_acceptixFORMAT].value_present = TRUE;
- ffestp_file.accept.accept_spec[FFESTP_acceptixFORMAT].value_is_label
- = (expr == NULL);
- ffestp_file.accept.accept_spec[FFESTP_acceptixFORMAT].value
- = ffelex_token_use (ft);
- ffestp_file.accept.accept_spec[FFESTP_acceptixFORMAT].u.expr = expr;
- if (!ffesta_is_inhibited ())
- ffestc_V019_start ();
- ffestb_subr_kill_accept_ ();
- if (ffelex_token_type (t) == FFELEX_typeCOMMA)
+ if (ffestb_local_.open.label)
+ return (ffelexHandler) ffestb_R9047_;
+ if (ffestb_local_.open.left)
return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool,
- FFEEXPR_contextIOLIST,
- (ffeexprCallback) ffestb_V0192_);
- if (!ffesta_is_inhibited ())
- ffestc_V019_finish ();
- return (ffelexHandler) ffesta_zero (t);
+ ffestb_local_.open.context,
+ (ffeexprCallback) ffestb_R9046_);
+ return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ ffestb_local_.open.context,
+ (ffeexprCallback) ffestb_R9046_);
default:
break;
}
- ffestb_subr_kill_accept_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "ACCEPT", t);
+ ffestb_subr_kill_open_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "OPEN", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_V0192_ -- "ACCEPT" expr COMMA expr
+/* ffestb_R9046_ -- "OPEN" OPEN_PAREN ... NAME EQUALS expr
- (ffestb_V0192_) // to expression handler
+ (ffestb_R9046_) // to expression handler
- Handle COMMA or EOS/SEMICOLON here. */
+ Handle COMMA or CLOSE_PAREN here. */
static ffelexHandler
-ffestb_V0192_ (ffelexToken ft, ffebld expr, ffelexToken t)
+ffestb_R9046_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
switch (ffelex_token_type (t))
{
case FFELEX_typeCOMMA:
+ case FFELEX_typeCLOSE_PAREN:
if (expr == NULL)
break;
- if (!ffesta_is_inhibited ())
- ffestc_V019_item (expr, ft);
- return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool,
- FFEEXPR_contextIOLIST,
- (ffeexprCallback) ffestb_V0192_);
-
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- if (expr == NULL)
- break;
- if (!ffesta_is_inhibited ())
- {
- ffestc_V019_item (expr, ft);
- ffestc_V019_finish ();
- }
- return (ffelexHandler) ffesta_zero (t);
+ ffestp_file.open.open_spec[ffestb_local_.open.ix].value_present
+ = TRUE;
+ ffestp_file.open.open_spec[ffestb_local_.open.ix].value
+ = ffelex_token_use (ft);
+ ffestp_file.open.open_spec[ffestb_local_.open.ix].u.expr = expr;
+ if (ffelex_token_type (t) == FFELEX_typeCOMMA)
+ return (ffelexHandler) ffestb_R9044_;
+ return (ffelexHandler) ffestb_R9049_;
default:
break;
}
- if (!ffesta_is_inhibited ())
- ffestc_V019_finish ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "ACCEPT", t);
+ ffestb_subr_kill_open_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "OPEN", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-#endif
-/* ffestb_V020 -- Parse the TYPE statement
+/* ffestb_R9047_ -- "OPEN" OPEN_PAREN ... NAME EQUALS
- return ffestb_V020; // to lexer
+ return ffestb_R9047_; // to lexer
- Make sure the statement has a valid form for the TYPE
- statement. If it does, implement the statement. */
+ Handle NUMBER for label here. */
-ffelexHandler
-ffestb_V020 (ffelexToken t)
+static ffelexHandler
+ffestb_R9047_ (ffelexToken t)
{
- ffeTokenLength i;
- const char *p;
- ffelexHandler next;
- ffestpTypeIx ix;
-
- switch (ffelex_token_type (ffesta_tokens[0]))
+ switch (ffelex_token_type (t))
{
- case FFELEX_typeNAME:
- if (ffesta_first_kw != FFESTR_firstTYPE)
- goto bad_0; /* :::::::::::::::::::: */
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOLONCOLON:
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
-
- case FFELEX_typeEQUALS:
- case FFELEX_typePOINTS:
- case FFELEX_typeCOLON:
- case FFELEX_typeCOMMA: /* Because "TYPE,PUBLIC::A" is ambiguous with
- '90. */
- goto bad_1; /* :::::::::::::::::::: */
-
- case FFELEX_typeNUMBER:
- ffesta_confirmed ();
- break;
-
- case FFELEX_typeNAME: /* Because TYPE A is ambiguous with '90. */
- default:
- break;
- }
-
- for (ix = 0; ix < FFESTP_typeix; ++ix)
- ffestp_file.type.type_spec[ix].kw_or_val_present = FALSE;
- return (ffelexHandler) (*((ffelexHandler)
- ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextFILEFORMATNML, (ffeexprCallback) ffestb_V0201_)))
- (t);
-
- case FFELEX_typeNAMES:
- if (ffesta_first_kw != FFESTR_firstTYPE)
- goto bad_0; /* :::::::::::::::::::: */
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- case FFELEX_typeCOMMA:
- if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlTYPE)
- break;
- goto bad_1; /* :::::::::::::::::::: */
-
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
-
- case FFELEX_typeOPEN_PAREN:
- if (ffelex_token_length (ffesta_tokens[0]) == FFESTR_firstlTYPE)
- break; /* Else might be assignment/stmtfuncdef. */
- goto bad_1; /* :::::::::::::::::::: */
-
- case FFELEX_typeEQUALS:
- case FFELEX_typePOINTS:
- case FFELEX_typeCOLON:
- goto bad_1; /* :::::::::::::::::::: */
-
- default:
- break;
- }
- p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlTYPE);
- if (ISDIGIT (*p))
- ffesta_confirmed (); /* Else might be '90 TYPE statement. */
- for (ix = 0; ix < FFESTP_typeix; ++ix)
- ffestp_file.type.type_spec[ix].kw_or_val_present = FALSE;
- next = (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextFILEFORMATNML, (ffeexprCallback) ffestb_V0201_);
- next = (ffelexHandler) ffelex_splice_tokens (next, ffesta_tokens[0],
- FFESTR_firstlTYPE);
- if (next == NULL)
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero);
- return (ffelexHandler) (*next) (t);
+ case FFELEX_typeNUMBER:
+ ffestp_file.open.open_spec[ffestb_local_.open.ix].value_present
+ = TRUE;
+ ffestp_file.open.open_spec[ffestb_local_.open.ix].value
+ = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_R9048_;
default:
- goto bad_0; /* :::::::::::::::::::: */
+ break;
}
-bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "TYPE I/O", ffesta_tokens[0]);
+ ffestb_subr_kill_open_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "OPEN", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-
-bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "TYPE I/O", t);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero); /* Invalid second token. */
}
-/* ffestb_V0201_ -- "TYPE" expr
+/* ffestb_R9048_ -- "OPEN" OPEN_PAREN ... NAME EQUALS NUMBER
- (ffestb_V0201_) // to expression handler
+ return ffestb_R9048_; // to lexer
- Make sure the next token is a COMMA or EOS/SEMICOLON. */
+ Handle COMMA or CLOSE_PAREN here. */
static ffelexHandler
-ffestb_V0201_ (ffelexToken ft, ffebld expr, ffelexToken t)
+ffestb_R9048_ (ffelexToken t)
{
- bool comma = TRUE;
-
switch (ffelex_token_type (t))
{
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- if (!ffe_is_vxt () && (expr != NULL)
- && (ffebld_op (expr) == FFEBLD_opSYMTER))
- break;
- comma = FALSE;
- /* Fall through. */
case FFELEX_typeCOMMA:
- if (!ffe_is_vxt () && comma && (expr != NULL)
- && (ffebld_op (expr) == FFEBLD_opPAREN)
- && (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER))
- break;
- ffesta_confirmed ();
- ffestp_file.type.type_spec[FFESTP_typeixFORMAT].kw_or_val_present
- = TRUE;
- ffestp_file.type.type_spec[FFESTP_typeixFORMAT].kw_present = FALSE;
- ffestp_file.type.type_spec[FFESTP_typeixFORMAT].value_present = TRUE;
- ffestp_file.type.type_spec[FFESTP_typeixFORMAT].value_is_label
- = (expr == NULL);
- ffestp_file.type.type_spec[FFESTP_typeixFORMAT].value
- = ffelex_token_use (ft);
- ffestp_file.type.type_spec[FFESTP_typeixFORMAT].u.expr = expr;
- if (!ffesta_is_inhibited ())
- ffestc_V020_start ();
- ffestb_subr_kill_type_ ();
- if (ffelex_token_type (t) == FFELEX_typeCOMMA)
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextIOLIST, (ffeexprCallback) ffestb_V0202_);
- if (!ffesta_is_inhibited ())
- ffestc_V020_finish ();
- return (ffelexHandler) ffesta_zero (t);
+ return (ffelexHandler) ffestb_R9044_;
+
+ case FFELEX_typeCLOSE_PAREN:
+ return (ffelexHandler) ffestb_R9049_;
default:
break;
}
- ffestb_subr_kill_type_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "TYPE I/O", t);
+ ffestb_subr_kill_open_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "OPEN", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_V0202_ -- "TYPE" expr COMMA expr
+/* ffestb_R9049_ -- "OPEN" OPEN_PAREN ... CLOSE_PAREN
- (ffestb_V0202_) // to expression handler
+ return ffestb_R9049_; // to lexer
- Handle COMMA or EOS/SEMICOLON here. */
+ Handle EOS or SEMICOLON here. */
static ffelexHandler
-ffestb_V0202_ (ffelexToken ft, ffebld expr, ffelexToken t)
+ffestb_R9049_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeCOMMA:
- if (expr == NULL)
- break;
- if (!ffesta_is_inhibited ())
- ffestc_V020_item (expr, ft);
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextIOLIST, (ffeexprCallback) ffestb_V0202_);
-
case FFELEX_typeEOS:
case FFELEX_typeSEMICOLON:
- if (expr == NULL)
- break;
+ ffesta_confirmed ();
if (!ffesta_is_inhibited ())
- {
- ffestc_V020_item (expr, ft);
- ffestc_V020_finish ();
- }
+ ffestc_R904 ();
+ ffestb_subr_kill_open_ ();
return (ffelexHandler) ffesta_zero (t);
default:
break;
}
- if (!ffesta_is_inhibited ())
- ffestc_V020_finish ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "TYPE I/O", t);
+ ffestb_subr_kill_open_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "OPEN", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_V021 -- Parse a DELETE statement
+/* ffestb_R907 -- Parse a CLOSE statement
- return ffestb_V021; // to lexer
+ return ffestb_R907; // to lexer
- Make sure the statement has a valid form for a DELETE statement.
+ Make sure the statement has a valid form for a CLOSE statement.
If it does, implement the statement. */
-#if FFESTR_VXT
ffelexHandler
-ffestb_V021 (ffelexToken t)
+ffestb_R907 (ffelexToken t)
{
- ffestpDeleteIx ix;
+ ffestpCloseIx ix;
switch (ffelex_token_type (ffesta_tokens[0]))
{
case FFELEX_typeNAME:
- if (ffesta_first_kw != FFESTR_firstDELETE)
+ if (ffesta_first_kw != FFESTR_firstCLOSE)
goto bad_0; /* :::::::::::::::::::: */
break;
case FFELEX_typeNAMES:
- if (ffesta_first_kw != FFESTR_firstDELETE)
+ if (ffesta_first_kw != FFESTR_firstCLOSE)
goto bad_0; /* :::::::::::::::::::: */
- if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlDELETE)
+ if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlCLOSE)
goto bad_0; /* :::::::::::::::::::: */
break;
goto bad_1; /* :::::::::::::::::::: */
}
- for (ix = 0; ix < FFESTP_deleteix; ++ix)
- ffestp_file.delete.delete_spec[ix].kw_or_val_present = FALSE;
+ for (ix = 0; ix < FFESTP_closeix; ++ix)
+ ffestp_file.close.close_spec[ix].kw_or_val_present = FALSE;
- return (ffelexHandler) ffestb_V0211_;
+ return (ffelexHandler) ffestb_R9071_;
bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DELETE", ffesta_tokens[0]);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CLOSE", ffesta_tokens[0]);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DELETE", t);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CLOSE", t);
return (ffelexHandler) ffelex_swallow_tokens (t,
(ffelexHandler) ffesta_zero); /* Invalid second token. */
}
-/* ffestb_V0211_ -- "DELETE" OPEN_PAREN
+/* ffestb_R9071_ -- "CLOSE" OPEN_PAREN
- return ffestb_V0211_; // to lexer
+ return ffestb_R9071_; // to lexer
Handle expr construct (not NAME=expr construct) here. */
static ffelexHandler
-ffestb_V0211_ (ffelexToken t)
+ffestb_R9071_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
case FFELEX_typeNAME:
ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_V0212_;
+ return (ffelexHandler) ffestb_R9072_;
default:
return (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextFILENUM, (ffeexprCallback) ffestb_V0213_)))
+ FFEEXPR_contextFILENUM, (ffeexprCallback) ffestb_R9073_)))
(t);
}
}
-/* ffestb_V0212_ -- "DELETE" OPEN_PAREN NAME
+/* ffestb_R9072_ -- "CLOSE" OPEN_PAREN NAME
- return ffestb_V0212_; // to lexer
+ return ffestb_R9072_; // to lexer
If EQUALS here, go to states that handle it. Else, send NAME and this
token thru expression handler. */
static ffelexHandler
-ffestb_V0212_ (ffelexToken t)
+ffestb_R9072_ (ffelexToken t)
{
ffelexHandler next;
ffelexToken nt;
{
case FFELEX_typeEQUALS:
nt = ffesta_tokens[1];
- next = (ffelexHandler) ffestb_V0214_ (nt);
+ next = (ffelexHandler) ffestb_R9074_ (nt);
ffelex_token_kill (nt);
return (ffelexHandler) (*next) (t);
default:
- next = (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextFILENUM, (ffeexprCallback) ffestb_V0213_)))
- (ffesta_tokens[1]);
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) (*next) (t);
+ next = (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ FFEEXPR_contextFILENUM, (ffeexprCallback) ffestb_R9073_)))
+ (ffesta_tokens[1]);
+ ffelex_token_kill (ffesta_tokens[1]);
+ return (ffelexHandler) (*next) (t);
+ }
+}
+
+/* ffestb_R9073_ -- "CLOSE" OPEN_PAREN expr
+
+ (ffestb_R9073_) // to expression handler
+
+ Handle COMMA or CLOSE_PAREN here. */
+
+static ffelexHandler
+ffestb_R9073_ (ffelexToken ft, ffebld expr, ffelexToken t)
+{
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeCOMMA:
+ case FFELEX_typeCLOSE_PAREN:
+ if (expr == NULL)
+ break;
+ ffestp_file.close.close_spec[FFESTP_closeixUNIT].kw_or_val_present
+ = TRUE;
+ ffestp_file.close.close_spec[FFESTP_closeixUNIT].kw_present = FALSE;
+ ffestp_file.close.close_spec[FFESTP_closeixUNIT].value_present = TRUE;
+ ffestp_file.close.close_spec[FFESTP_closeixUNIT].value_is_label
+ = FALSE;
+ ffestp_file.close.close_spec[FFESTP_closeixUNIT].value
+ = ffelex_token_use (ft);
+ ffestp_file.close.close_spec[FFESTP_closeixUNIT].u.expr = expr;
+ if (ffelex_token_type (t) == FFELEX_typeCOMMA)
+ return (ffelexHandler) ffestb_R9074_;
+ return (ffelexHandler) ffestb_R9079_;
+
+ default:
+ break;
+ }
+
+ ffestb_subr_kill_close_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CLOSE", t);
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+}
+
+/* ffestb_R9074_ -- "CLOSE" OPEN_PAREN [external-file-unit COMMA]
+
+ return ffestb_R9074_; // to lexer
+
+ Handle expr construct (not NAME=expr construct) here. */
+
+static ffelexHandler
+ffestb_R9074_ (ffelexToken t)
+{
+ ffestrGenio kw;
+
+ ffestb_local_.close.label = FALSE;
+
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeNAME:
+ kw = ffestr_genio (t);
+ switch (kw)
+ {
+ case FFESTR_genioERR:
+ ffestb_local_.close.ix = FFESTP_closeixERR;
+ ffestb_local_.close.label = TRUE;
+ break;
+
+ case FFESTR_genioIOSTAT:
+ ffestb_local_.close.ix = FFESTP_closeixIOSTAT;
+ ffestb_local_.close.left = TRUE;
+ ffestb_local_.close.context = FFEEXPR_contextFILEINT;
+ break;
+
+ case FFESTR_genioSTATUS:
+ case FFESTR_genioDISP:
+ case FFESTR_genioDISPOSE:
+ ffestb_local_.close.ix = FFESTP_closeixSTATUS;
+ ffestb_local_.close.left = FALSE;
+ ffestb_local_.close.context = FFEEXPR_contextFILEDFCHAR;
+ break;
+
+ case FFESTR_genioUNIT:
+ ffestb_local_.close.ix = FFESTP_closeixUNIT;
+ ffestb_local_.close.left = FALSE;
+ ffestb_local_.close.context = FFEEXPR_contextFILENUM;
+ break;
+
+ default:
+ goto bad; /* :::::::::::::::::::: */
+ }
+ if (ffestp_file.close.close_spec[ffestb_local_.close.ix]
+ .kw_or_val_present)
+ break; /* Can't specify a keyword twice! */
+ ffestp_file.close.close_spec[ffestb_local_.close.ix]
+ .kw_or_val_present = TRUE;
+ ffestp_file.close.close_spec[ffestb_local_.close.ix]
+ .kw_present = TRUE;
+ ffestp_file.close.close_spec[ffestb_local_.close.ix]
+ .value_present = FALSE;
+ ffestp_file.close.close_spec[ffestb_local_.close.ix].value_is_label
+ = ffestb_local_.close.label;
+ ffestp_file.close.close_spec[ffestb_local_.close.ix].kw
+ = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_R9075_;
+
+ default:
+ break;
+ }
+
+bad: /* :::::::::::::::::::: */
+ ffestb_subr_kill_close_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CLOSE", t);
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+}
+
+/* ffestb_R9075_ -- "CLOSE" OPEN_PAREN [external-file-unit COMMA] NAME
+
+ return ffestb_R9075_; // to lexer
+
+ Make sure EQUALS here, send next token to expression handler. */
+
+static ffelexHandler
+ffestb_R9075_ (ffelexToken t)
+{
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeEQUALS:
+ ffesta_confirmed ();
+ if (ffestb_local_.close.label)
+ return (ffelexHandler) ffestb_R9077_;
+ if (ffestb_local_.close.left)
+ return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool,
+ ffestb_local_.close.context,
+ (ffeexprCallback) ffestb_R9076_);
+ return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ ffestb_local_.close.context,
+ (ffeexprCallback) ffestb_R9076_);
+
+ default:
+ break;
}
+
+ ffestb_subr_kill_close_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CLOSE", t);
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_V0213_ -- "DELETE" OPEN_PAREN expr
+/* ffestb_R9076_ -- "CLOSE" OPEN_PAREN ... NAME EQUALS expr
- (ffestb_V0213_) // to expression handler
+ (ffestb_R9076_) // to expression handler
- Handle COMMA or DELETE_PAREN here. */
+ Handle COMMA or CLOSE_PAREN here. */
static ffelexHandler
-ffestb_V0213_ (ffelexToken ft, ffebld expr, ffelexToken t)
+ffestb_R9076_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
switch (ffelex_token_type (t))
{
case FFELEX_typeCLOSE_PAREN:
if (expr == NULL)
break;
- ffestp_file.delete.delete_spec[FFESTP_deleteixUNIT].kw_or_val_present
+ ffestp_file.close.close_spec[ffestb_local_.close.ix].value_present
= TRUE;
- ffestp_file.delete.delete_spec[FFESTP_deleteixUNIT].kw_present = FALSE;
- ffestp_file.delete.delete_spec[FFESTP_deleteixUNIT].value_present = TRUE;
- ffestp_file.delete.delete_spec[FFESTP_deleteixUNIT].value_is_label
- = FALSE;
- ffestp_file.delete.delete_spec[FFESTP_deleteixUNIT].value
+ ffestp_file.close.close_spec[ffestb_local_.close.ix].value
= ffelex_token_use (ft);
- ffestp_file.delete.delete_spec[FFESTP_deleteixUNIT].u.expr = expr;
+ ffestp_file.close.close_spec[ffestb_local_.close.ix].u.expr = expr;
if (ffelex_token_type (t) == FFELEX_typeCOMMA)
- return (ffelexHandler) ffestb_V0214_;
- return (ffelexHandler) ffestb_V0219_;
+ return (ffelexHandler) ffestb_R9074_;
+ return (ffelexHandler) ffestb_R9079_;
default:
break;
}
- ffestb_subr_kill_delete_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DELETE", t);
+ ffestb_subr_kill_close_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CLOSE", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_V0214_ -- "DELETE" OPEN_PAREN [external-file-unit COMMA]
+/* ffestb_R9077_ -- "CLOSE" OPEN_PAREN ... NAME EQUALS
- return ffestb_V0214_; // to lexer
+ return ffestb_R9077_; // to lexer
- Handle expr construct (not NAME=expr construct) here. */
+ Handle NUMBER for label here. */
static ffelexHandler
-ffestb_V0214_ (ffelexToken t)
+ffestb_R9077_ (ffelexToken t)
{
- ffestrGenio kw;
-
- ffestb_local_.delete.label = FALSE;
-
switch (ffelex_token_type (t))
{
- case FFELEX_typeNAME:
- kw = ffestr_genio (t);
- switch (kw)
- {
- case FFESTR_genioERR:
- ffestb_local_.delete.ix = FFESTP_deleteixERR;
- ffestb_local_.delete.label = TRUE;
- break;
+ case FFELEX_typeNUMBER:
+ ffestp_file.close.close_spec[ffestb_local_.close.ix].value_present
+ = TRUE;
+ ffestp_file.close.close_spec[ffestb_local_.close.ix].value
+ = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_R9078_;
- case FFESTR_genioIOSTAT:
- ffestb_local_.delete.ix = FFESTP_deleteixIOSTAT;
- ffestb_local_.delete.left = TRUE;
- ffestb_local_.delete.context = FFEEXPR_contextFILEINT;
- break;
+ default:
+ break;
+ }
- case FFESTR_genioREC:
- ffestb_local_.delete.ix = FFESTP_deleteixREC;
- ffestb_local_.delete.left = FALSE;
- ffestb_local_.delete.context = FFEEXPR_contextFILENUM;
- break;
+ ffestb_subr_kill_close_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CLOSE", t);
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+}
- case FFESTR_genioUNIT:
- ffestb_local_.delete.ix = FFESTP_deleteixUNIT;
- ffestb_local_.delete.left = FALSE;
- ffestb_local_.delete.context = FFEEXPR_contextFILENUM;
- break;
+/* ffestb_R9078_ -- "CLOSE" OPEN_PAREN ... NAME EQUALS NUMBER
- default:
- goto bad; /* :::::::::::::::::::: */
- }
- if (ffestp_file.delete.delete_spec[ffestb_local_.delete.ix]
- .kw_or_val_present)
- break; /* Can't specify a keyword twice! */
- ffestp_file.delete.delete_spec[ffestb_local_.delete.ix]
- .kw_or_val_present = TRUE;
- ffestp_file.delete.delete_spec[ffestb_local_.delete.ix]
- .kw_present = TRUE;
- ffestp_file.delete.delete_spec[ffestb_local_.delete.ix]
- .value_present = FALSE;
- ffestp_file.delete.delete_spec[ffestb_local_.delete.ix].value_is_label
- = ffestb_local_.delete.label;
- ffestp_file.delete.delete_spec[ffestb_local_.delete.ix].kw
- = ffelex_token_use (t);
- return (ffelexHandler) ffestb_V0215_;
+ return ffestb_R9078_; // to lexer
+
+ Handle COMMA or CLOSE_PAREN here. */
+
+static ffelexHandler
+ffestb_R9078_ (ffelexToken t)
+{
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeCOMMA:
+ return (ffelexHandler) ffestb_R9074_;
+
+ case FFELEX_typeCLOSE_PAREN:
+ return (ffelexHandler) ffestb_R9079_;
default:
break;
}
-bad: /* :::::::::::::::::::: */
- ffestb_subr_kill_delete_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DELETE", t);
+ ffestb_subr_kill_close_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CLOSE", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_V0215_ -- "DELETE" OPEN_PAREN [external-file-unit COMMA] NAME
+/* ffestb_R9079_ -- "CLOSE" OPEN_PAREN ... CLOSE_PAREN
- return ffestb_V0215_; // to lexer
+ return ffestb_R9079_; // to lexer
- Make sure EQUALS here, send next token to expression handler. */
+ Handle EOS or SEMICOLON here. */
static ffelexHandler
-ffestb_V0215_ (ffelexToken t)
+ffestb_R9079_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeEQUALS:
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
ffesta_confirmed ();
- if (ffestb_local_.delete.label)
- return (ffelexHandler) ffestb_V0217_;
- if (ffestb_local_.delete.left)
- return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool,
- ffestb_local_.delete.context,
- (ffeexprCallback) ffestb_V0216_);
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- ffestb_local_.delete.context, (ffeexprCallback) ffestb_V0216_);
+ if (!ffesta_is_inhibited ())
+ ffestc_R907 ();
+ ffestb_subr_kill_close_ ();
+ return (ffelexHandler) ffesta_zero (t);
default:
break;
}
- ffestb_subr_kill_delete_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DELETE", t);
+ ffestb_subr_kill_close_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CLOSE", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_V0216_ -- "DELETE" OPEN_PAREN ... NAME EQUALS expr
+/* ffestb_R909 -- Parse the READ statement
- (ffestb_V0216_) // to expression handler
+ return ffestb_R909; // to lexer
- Handle COMMA or CLOSE_PAREN here. */
+ Make sure the statement has a valid form for the READ
+ statement. If it does, implement the statement. */
-static ffelexHandler
-ffestb_V0216_ (ffelexToken ft, ffebld expr, ffelexToken t)
+ffelexHandler
+ffestb_R909 (ffelexToken t)
{
- switch (ffelex_token_type (t))
+ ffelexHandler next;
+ ffestpReadIx ix;
+
+ switch (ffelex_token_type (ffesta_tokens[0]))
{
- case FFELEX_typeCOMMA:
- case FFELEX_typeCLOSE_PAREN:
- if (expr == NULL)
- break;
- ffestp_file.delete.delete_spec[ffestb_local_.delete.ix].value_present
- = TRUE;
- ffestp_file.delete.delete_spec[ffestb_local_.delete.ix].value
- = ffelex_token_use (ft);
- ffestp_file.delete.delete_spec[ffestb_local_.delete.ix].u.expr = expr;
- if (ffelex_token_type (t) == FFELEX_typeCOMMA)
- return (ffelexHandler) ffestb_V0214_;
- return (ffelexHandler) ffestb_V0219_;
+ case FFELEX_typeNAME:
+ if (ffesta_first_kw != FFESTR_firstREAD)
+ goto bad_0; /* :::::::::::::::::::: */
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeCOMMA:
+ case FFELEX_typeCOLONCOLON:
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ ffesta_confirmed (); /* Error, but clearly intended. */
+ goto bad_1; /* :::::::::::::::::::: */
+
+ case FFELEX_typeEQUALS:
+ case FFELEX_typePOINTS:
+ case FFELEX_typeCOLON:
+ goto bad_1; /* :::::::::::::::::::: */
+
+ case FFELEX_typeNAME:
+ case FFELEX_typeNUMBER:
+ ffesta_confirmed ();
+ break;
+
+ case FFELEX_typeOPEN_PAREN:
+ for (ix = 0; ix < FFESTP_readix; ++ix)
+ ffestp_file.read.read_spec[ix].kw_or_val_present = FALSE;
+ ffesta_tokens[1] = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_R9092_;
+
+ default:
+ break;
+ }
+
+ for (ix = 0; ix < FFESTP_readix; ++ix)
+ ffestp_file.read.read_spec[ix].kw_or_val_present = FALSE;
+ return (ffelexHandler) (*((ffelexHandler)
+ ffeexpr_rhs (ffesta_output_pool,
+ FFEEXPR_contextFILEFORMATNML, (ffeexprCallback) ffestb_R9091_)))
+ (t);
+
+ case FFELEX_typeNAMES:
+ if (ffesta_first_kw != FFESTR_firstREAD)
+ goto bad_0; /* :::::::::::::::::::: */
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ case FFELEX_typeCOMMA:
+ ffesta_confirmed ();
+ if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlREAD)
+ break;
+ goto bad_1; /* :::::::::::::::::::: */
+
+ case FFELEX_typeCOLONCOLON:
+ ffesta_confirmed (); /* Error, but clearly intended. */
+ goto bad_1; /* :::::::::::::::::::: */
+
+ case FFELEX_typeEQUALS:
+ case FFELEX_typePOINTS:
+ case FFELEX_typeCOLON:
+ goto bad_1; /* :::::::::::::::::::: */
+
+ case FFELEX_typeOPEN_PAREN:
+ if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlREAD)
+ break;
+
+ for (ix = 0; ix < FFESTP_readix; ++ix)
+ ffestp_file.read.read_spec[ix].kw_or_val_present = FALSE;
+ ffesta_tokens[1] = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_R9092_;
+
+ default:
+ break;
+ }
+ for (ix = 0; ix < FFESTP_readix; ++ix)
+ ffestp_file.read.read_spec[ix].kw_or_val_present = FALSE;
+ next = (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ FFEEXPR_contextFILEFORMATNML, (ffeexprCallback) ffestb_R9091_);
+ next = (ffelexHandler) ffelex_splice_tokens (next, ffesta_tokens[0],
+ FFESTR_firstlREAD);
+ if (next == NULL)
+ return (ffelexHandler) ffelex_swallow_tokens (t,
+ (ffelexHandler) ffesta_zero);
+ return (ffelexHandler) (*next) (t);
default:
- break;
+ goto bad_0; /* :::::::::::::::::::: */
}
- ffestb_subr_kill_delete_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DELETE", t);
+bad_0: /* :::::::::::::::::::: */
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "READ", ffesta_tokens[0]);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+
+bad_1: /* :::::::::::::::::::: */
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "READ", t);
+ return (ffelexHandler) ffelex_swallow_tokens (t,
+ (ffelexHandler) ffesta_zero); /* Invalid second token. */
}
-/* ffestb_V0217_ -- "DELETE" OPEN_PAREN ... NAME EQUALS
+/* ffestb_R9091_ -- "READ" expr
- return ffestb_V0217_; // to lexer
+ (ffestb_R9091_) // to expression handler
- Handle NUMBER for label here. */
+ Make sure the next token is a COMMA or EOS/SEMICOLON. */
static ffelexHandler
-ffestb_V0217_ (ffelexToken t)
+ffestb_R9091_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeNUMBER:
- ffestp_file.delete.delete_spec[ffestb_local_.delete.ix].value_present
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ case FFELEX_typeCOMMA:
+ ffesta_confirmed ();
+ ffestp_file.read.read_spec[FFESTP_readixFORMAT].kw_or_val_present
= TRUE;
- ffestp_file.delete.delete_spec[ffestb_local_.delete.ix].value
- = ffelex_token_use (t);
- return (ffelexHandler) ffestb_V0218_;
+ ffestp_file.read.read_spec[FFESTP_readixFORMAT].kw_present = FALSE;
+ ffestp_file.read.read_spec[FFESTP_readixFORMAT].value_present = TRUE;
+ ffestp_file.read.read_spec[FFESTP_readixFORMAT].value_is_label
+ = (expr == NULL);
+ ffestp_file.read.read_spec[FFESTP_readixFORMAT].value
+ = ffelex_token_use (ft);
+ ffestp_file.read.read_spec[FFESTP_readixFORMAT].u.expr = expr;
+ if (!ffesta_is_inhibited ())
+ ffestc_R909_start (TRUE);
+ ffestb_subr_kill_read_ ();
+ if (ffelex_token_type (t) == FFELEX_typeCOMMA)
+ return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool,
+ ffestc_context_iolist (),
+ (ffeexprCallback) ffestb_R90915_);
+ if (!ffesta_is_inhibited ())
+ ffestc_R909_finish ();
+ return (ffelexHandler) ffesta_zero (t);
default:
break;
}
- ffestb_subr_kill_delete_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DELETE", t);
+ ffestb_subr_kill_read_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "READ", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_V0218_ -- "DELETE" OPEN_PAREN ... NAME EQUALS NUMBER
+/* ffestb_R9092_ -- "READ" OPEN_PAREN
- return ffestb_V0218_; // to lexer
+ return ffestb_R9092_; // to lexer
- Handle COMMA or CLOSE_PAREN here. */
+ Handle expr construct (not NAME=expr construct) here. */
static ffelexHandler
-ffestb_V0218_ (ffelexToken t)
+ffestb_R9092_ (ffelexToken t)
{
+ ffelexToken nt;
+ ffelexHandler next;
+
switch (ffelex_token_type (t))
{
- case FFELEX_typeCOMMA:
- return (ffelexHandler) ffestb_V0214_;
-
- case FFELEX_typeCLOSE_PAREN:
- return (ffelexHandler) ffestb_V0219_;
+ case FFELEX_typeNAME:
+ ffesta_tokens[2] = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_R9093_;
default:
- break;
+ nt = ffesta_tokens[1];
+ next = (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ FFEEXPR_contextFILEUNITAMBIG, (ffeexprCallback) ffestb_R9094_)))
+ (nt);
+ ffelex_token_kill (nt);
+ return (ffelexHandler) (*next) (t);
}
-
- ffestb_subr_kill_delete_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DELETE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_V0219_ -- "DELETE" OPEN_PAREN ... CLOSE_PAREN
+/* ffestb_R9093_ -- "READ" OPEN_PAREN NAME
- return ffestb_V0219_; // to lexer
+ return ffestb_R9093_; // to lexer
- Handle EOS or SEMICOLON here. */
+ If EQUALS here, go to states that handle it. Else, send NAME and this
+ token thru expression handler. */
static ffelexHandler
-ffestb_V0219_ (ffelexToken t)
+ffestb_R9093_ (ffelexToken t)
{
+ ffelexHandler next;
+ ffelexToken nt;
+ ffelexToken ot;
+
switch (ffelex_token_type (t))
{
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- ffestc_V021 ();
- ffestb_subr_kill_delete_ ();
- return (ffelexHandler) ffesta_zero (t);
+ case FFELEX_typeEQUALS:
+ ffelex_token_kill (ffesta_tokens[1]);
+ nt = ffesta_tokens[2];
+ next = (ffelexHandler) ffestb_R9098_ (nt);
+ ffelex_token_kill (nt);
+ return (ffelexHandler) (*next) (t);
default:
- break;
+ nt = ffesta_tokens[1];
+ ot = ffesta_tokens[2];
+ next = (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ FFEEXPR_contextFILEUNITAMBIG, (ffeexprCallback) ffestb_R9094_)))
+ (nt);
+ ffelex_token_kill (nt);
+ next = (ffelexHandler) (*next) (ot);
+ ffelex_token_kill (ot);
+ return (ffelexHandler) (*next) (t);
}
-
- ffestb_subr_kill_delete_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DELETE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_V026 -- Parse a FIND statement
+/* ffestb_R9094_ -- "READ" OPEN_PAREN expr [CLOSE_PAREN]
- return ffestb_V026; // to lexer
+ (ffestb_R9094_) // to expression handler
- Make sure the statement has a valid form for a FIND statement.
- If it does, implement the statement. */
+ Handle COMMA or EOS/SEMICOLON here.
-ffelexHandler
-ffestb_V026 (ffelexToken t)
+ 15-Feb-91 JCB 1.1
+ Use new ffeexpr mechanism whereby the expr is encased in an opITEM if
+ ffeexpr decided it was an item in a control list (hence a unit
+ specifier), or a format specifier otherwise. */
+
+static ffelexHandler
+ffestb_R9094_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
- ffestpFindIx ix;
+ if (expr == NULL)
+ goto bad; /* :::::::::::::::::::: */
- switch (ffelex_token_type (ffesta_tokens[0]))
+ if (ffebld_op (expr) != FFEBLD_opITEM)
{
- case FFELEX_typeNAME:
- if (ffesta_first_kw != FFESTR_firstFIND)
- goto bad_0; /* :::::::::::::::::::: */
- break;
-
- case FFELEX_typeNAMES:
- if (ffesta_first_kw != FFESTR_firstFIND)
- goto bad_0; /* :::::::::::::::::::: */
- if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlFIND)
- goto bad_0; /* :::::::::::::::::::: */
- break;
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeCOMMA:
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ ffesta_confirmed ();
+ ffestp_file.read.read_spec[FFESTP_readixFORMAT].kw_or_val_present
+ = TRUE;
+ ffestp_file.read.read_spec[FFESTP_readixFORMAT].kw_present = FALSE;
+ ffestp_file.read.read_spec[FFESTP_readixFORMAT].value_present = TRUE;
+ ffestp_file.read.read_spec[FFESTP_readixFORMAT].value_is_label
+ = FALSE;
+ ffestp_file.read.read_spec[FFESTP_readixFORMAT].value
+ = ffelex_token_use (ft);
+ ffestp_file.read.read_spec[FFESTP_readixFORMAT].u.expr = expr;
+ if (!ffesta_is_inhibited ())
+ ffestc_R909_start (TRUE);
+ ffestb_subr_kill_read_ ();
+ if (ffelex_token_type (t) == FFELEX_typeCOMMA)
+ return (ffelexHandler)
+ ffeexpr_lhs (ffesta_output_pool,
+ ffestc_context_iolist (),
+ (ffeexprCallback) ffestb_R90915_);
+ if (!ffesta_is_inhibited ())
+ ffestc_R909_finish ();
+ return (ffelexHandler) ffesta_zero (t);
- default:
- goto bad_0; /* :::::::::::::::::::: */
+ default:
+ goto bad; /* :::::::::::::::::::: */
+ }
}
+ expr = ffebld_head (expr);
+
+ if (expr == NULL)
+ goto bad; /* :::::::::::::::::::: */
+
switch (ffelex_token_type (t))
{
- case FFELEX_typeOPEN_PAREN:
- break;
-
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
+ case FFELEX_typeCLOSE_PAREN:
+ ffestp_file.read.read_spec[FFESTP_readixUNIT].kw_or_val_present
+ = TRUE;
+ ffestp_file.read.read_spec[FFESTP_readixUNIT].kw_present = FALSE;
+ ffestp_file.read.read_spec[FFESTP_readixUNIT].value_present = TRUE;
+ ffestp_file.read.read_spec[FFESTP_readixUNIT].value_is_label
+ = FALSE;
+ ffestp_file.read.read_spec[FFESTP_readixUNIT].value
+ = ffelex_token_use (ft);
+ ffestp_file.read.read_spec[FFESTP_readixUNIT].u.expr = expr;
+ if (ffelex_token_type (t) == FFELEX_typeCOMMA)
+ return (ffelexHandler) ffestb_R9095_;
+ return (ffelexHandler) ffestb_R90913_;
default:
- goto bad_1; /* :::::::::::::::::::: */
+ break;
}
- for (ix = 0; ix < FFESTP_findix; ++ix)
- ffestp_file.find.find_spec[ix].kw_or_val_present = FALSE;
-
- return (ffelexHandler) ffestb_V0261_;
-
-bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FIND", ffesta_tokens[0]);
+bad: /* :::::::::::::::::::: */
+ ffestb_subr_kill_read_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "READ", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-
-bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FIND", t);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero); /* Invalid second token. */
}
-/* ffestb_V0261_ -- "FIND" OPEN_PAREN
+/* ffestb_R9095_ -- "READ" OPEN_PAREN expr COMMA
- return ffestb_V0261_; // to lexer
+ return ffestb_R9095_; // to lexer
Handle expr construct (not NAME=expr construct) here. */
static ffelexHandler
-ffestb_V0261_ (ffelexToken t)
+ffestb_R9095_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
case FFELEX_typeNAME:
ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_V0262_;
+ return (ffelexHandler) ffestb_R9096_;
default:
return (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextFILENUM, (ffeexprCallback) ffestb_V0263_)))
+ FFEEXPR_contextFILEFORMATNML, (ffeexprCallback) ffestb_R9097_)))
(t);
}
}
-/* ffestb_V0262_ -- "FIND" OPEN_PAREN NAME
+/* ffestb_R9096_ -- "READ" OPEN_PAREN expr COMMA NAME
- return ffestb_V0262_; // to lexer
+ return ffestb_R9096_; // to lexer
If EQUALS here, go to states that handle it. Else, send NAME and this
token thru expression handler. */
static ffelexHandler
-ffestb_V0262_ (ffelexToken t)
+ffestb_R9096_ (ffelexToken t)
{
ffelexHandler next;
ffelexToken nt;
{
case FFELEX_typeEQUALS:
nt = ffesta_tokens[1];
- next = (ffelexHandler) ffestb_V0264_ (nt);
+ next = (ffelexHandler) ffestb_R9098_ (nt);
ffelex_token_kill (nt);
return (ffelexHandler) (*next) (t);
default:
+ nt = ffesta_tokens[1];
next = (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextFILENUM, (ffeexprCallback) ffestb_V0263_)))
- (ffesta_tokens[1]);
- ffelex_token_kill (ffesta_tokens[1]);
+ FFEEXPR_contextFILEFORMATNML, (ffeexprCallback) ffestb_R9097_)))
+ (nt);
+ ffelex_token_kill (nt);
return (ffelexHandler) (*next) (t);
}
}
-/* ffestb_V0263_ -- "FIND" OPEN_PAREN expr
+/* ffestb_R9097_ -- "READ" OPEN_PAREN expr COMMA expr
- (ffestb_V0263_) // to expression handler
+ (ffestb_R9097_) // to expression handler
- Handle COMMA or FIND_PAREN here. */
+ Handle COMMA or CLOSE_PAREN here. */
static ffelexHandler
-ffestb_V0263_ (ffelexToken ft, ffebld expr, ffelexToken t)
+ffestb_R9097_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
switch (ffelex_token_type (t))
{
case FFELEX_typeCOMMA:
case FFELEX_typeCLOSE_PAREN:
- if (expr == NULL)
- break;
- ffestp_file.find.find_spec[FFESTP_findixUNIT].kw_or_val_present
+ ffestp_file.read.read_spec[FFESTP_readixFORMAT].kw_or_val_present
= TRUE;
- ffestp_file.find.find_spec[FFESTP_findixUNIT].kw_present = FALSE;
- ffestp_file.find.find_spec[FFESTP_findixUNIT].value_present = TRUE;
- ffestp_file.find.find_spec[FFESTP_findixUNIT].value_is_label
- = FALSE;
- ffestp_file.find.find_spec[FFESTP_findixUNIT].value
+ ffestp_file.read.read_spec[FFESTP_readixFORMAT].kw_present = FALSE;
+ ffestp_file.read.read_spec[FFESTP_readixFORMAT].value_present = TRUE;
+ ffestp_file.read.read_spec[FFESTP_readixFORMAT].value_is_label
+ = (expr == NULL);
+ ffestp_file.read.read_spec[FFESTP_readixFORMAT].value
= ffelex_token_use (ft);
- ffestp_file.find.find_spec[FFESTP_findixUNIT].u.expr = expr;
+ ffestp_file.read.read_spec[FFESTP_readixFORMAT].u.expr = expr;
if (ffelex_token_type (t) == FFELEX_typeCOMMA)
- return (ffelexHandler) ffestb_V0264_;
- return (ffelexHandler) ffestb_V0269_;
+ return (ffelexHandler) ffestb_R9098_;
+ return (ffelexHandler) ffestb_R90913_;
default:
break;
}
- ffestb_subr_kill_find_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FIND", t);
+ ffestb_subr_kill_read_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "READ", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_V0264_ -- "FIND" OPEN_PAREN [external-file-unit COMMA]
+/* ffestb_R9098_ -- "READ" OPEN_PAREN [external-file-unit COMMA [format
+ COMMA]]
- return ffestb_V0264_; // to lexer
+ return ffestb_R9098_; // to lexer
Handle expr construct (not NAME=expr construct) here. */
static ffelexHandler
-ffestb_V0264_ (ffelexToken t)
+ffestb_R9098_ (ffelexToken t)
{
ffestrGenio kw;
- ffestb_local_.find.label = FALSE;
+ ffestb_local_.read.label = FALSE;
switch (ffelex_token_type (t))
{
kw = ffestr_genio (t);
switch (kw)
{
+ case FFESTR_genioADVANCE:
+ ffestb_local_.read.ix = FFESTP_readixADVANCE;
+ ffestb_local_.read.left = FALSE;
+ ffestb_local_.read.context = FFEEXPR_contextFILEDFCHAR;
+ break;
+
+ case FFESTR_genioEOR:
+ ffestb_local_.read.ix = FFESTP_readixEOR;
+ ffestb_local_.read.label = TRUE;
+ break;
+
case FFESTR_genioERR:
- ffestb_local_.find.ix = FFESTP_findixERR;
- ffestb_local_.find.label = TRUE;
+ ffestb_local_.read.ix = FFESTP_readixERR;
+ ffestb_local_.read.label = TRUE;
+ break;
+
+ case FFESTR_genioEND:
+ ffestb_local_.read.ix = FFESTP_readixEND;
+ ffestb_local_.read.label = TRUE;
+ break;
+
+ case FFESTR_genioFMT:
+ ffestb_local_.read.ix = FFESTP_readixFORMAT;
+ ffestb_local_.read.left = FALSE;
+ ffestb_local_.read.context = FFEEXPR_contextFILEFORMAT;
break;
case FFESTR_genioIOSTAT:
- ffestb_local_.find.ix = FFESTP_findixIOSTAT;
- ffestb_local_.find.left = TRUE;
- ffestb_local_.find.context = FFEEXPR_contextFILEINT;
+ ffestb_local_.read.ix = FFESTP_readixIOSTAT;
+ ffestb_local_.read.left = TRUE;
+ ffestb_local_.read.context = FFEEXPR_contextFILEINT;
+ break;
+
+ case FFESTR_genioKEY:
+ case FFESTR_genioKEYEQ:
+ ffestb_local_.read.ix = FFESTP_readixKEYEQ;
+ ffestb_local_.read.left = FALSE;
+ ffestb_local_.read.context = FFEEXPR_contextFILENUMCHAR;
+ break;
+
+ case FFESTR_genioKEYGE:
+ ffestb_local_.read.ix = FFESTP_readixKEYGE;
+ ffestb_local_.read.left = FALSE;
+ ffestb_local_.read.context = FFEEXPR_contextFILENUMCHAR;
+ break;
+
+ case FFESTR_genioKEYGT:
+ ffestb_local_.read.ix = FFESTP_readixKEYGT;
+ ffestb_local_.read.left = FALSE;
+ ffestb_local_.read.context = FFEEXPR_contextFILENUMCHAR;
+ break;
+
+ case FFESTR_genioKEYID:
+ ffestb_local_.read.ix = FFESTP_readixKEYID;
+ ffestb_local_.read.left = FALSE;
+ ffestb_local_.read.context = FFEEXPR_contextFILENUM;
+ break;
+
+ case FFESTR_genioNML:
+ ffestb_local_.read.ix = FFESTP_readixFORMAT;
+ ffestb_local_.read.left = TRUE;
+ ffestb_local_.read.context = FFEEXPR_contextFILENAMELIST;
+ break;
+
+ case FFESTR_genioNULLS:
+ ffestb_local_.read.ix = FFESTP_readixNULLS;
+ ffestb_local_.read.left = TRUE;
+ ffestb_local_.read.context = FFEEXPR_contextFILEINT;
break;
case FFESTR_genioREC:
- ffestb_local_.find.ix = FFESTP_findixREC;
- ffestb_local_.find.left = FALSE;
- ffestb_local_.find.context = FFEEXPR_contextFILENUM;
+ ffestb_local_.read.ix = FFESTP_readixREC;
+ ffestb_local_.read.left = FALSE;
+ ffestb_local_.read.context = FFEEXPR_contextFILENUM;
+ break;
+
+ case FFESTR_genioSIZE:
+ ffestb_local_.read.ix = FFESTP_readixSIZE;
+ ffestb_local_.read.left = TRUE;
+ ffestb_local_.read.context = FFEEXPR_contextFILEINT;
break;
case FFESTR_genioUNIT:
- ffestb_local_.find.ix = FFESTP_findixUNIT;
- ffestb_local_.find.left = FALSE;
- ffestb_local_.find.context = FFEEXPR_contextFILENUM;
+ ffestb_local_.read.ix = FFESTP_readixUNIT;
+ ffestb_local_.read.left = FALSE;
+ ffestb_local_.read.context = FFEEXPR_contextFILEUNIT;
break;
default:
goto bad; /* :::::::::::::::::::: */
}
- if (ffestp_file.find.find_spec[ffestb_local_.find.ix]
+ if (ffestp_file.read.read_spec[ffestb_local_.read.ix]
.kw_or_val_present)
break; /* Can't specify a keyword twice! */
- ffestp_file.find.find_spec[ffestb_local_.find.ix]
+ ffestp_file.read.read_spec[ffestb_local_.read.ix]
.kw_or_val_present = TRUE;
- ffestp_file.find.find_spec[ffestb_local_.find.ix]
+ ffestp_file.read.read_spec[ffestb_local_.read.ix]
.kw_present = TRUE;
- ffestp_file.find.find_spec[ffestb_local_.find.ix]
+ ffestp_file.read.read_spec[ffestb_local_.read.ix]
.value_present = FALSE;
- ffestp_file.find.find_spec[ffestb_local_.find.ix].value_is_label
- = ffestb_local_.find.label;
- ffestp_file.find.find_spec[ffestb_local_.find.ix].kw
+ ffestp_file.read.read_spec[ffestb_local_.read.ix].value_is_label
+ = ffestb_local_.read.label;
+ ffestp_file.read.read_spec[ffestb_local_.read.ix].kw
= ffelex_token_use (t);
- return (ffelexHandler) ffestb_V0265_;
+ return (ffelexHandler) ffestb_R9099_;
default:
break;
}
bad: /* :::::::::::::::::::: */
- ffestb_subr_kill_find_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FIND", t);
+ ffestb_subr_kill_read_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "READ", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_V0265_ -- "FIND" OPEN_PAREN [external-file-unit COMMA] NAME
+/* ffestb_R9099_ -- "READ" OPEN_PAREN [external-file-unit COMMA [format
+ COMMA]] NAME
- return ffestb_V0265_; // to lexer
+ return ffestb_R9099_; // to lexer
Make sure EQUALS here, send next token to expression handler. */
static ffelexHandler
-ffestb_V0265_ (ffelexToken t)
+ffestb_R9099_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
case FFELEX_typeEQUALS:
ffesta_confirmed ();
- if (ffestb_local_.find.label)
- return (ffelexHandler) ffestb_V0267_;
- if (ffestb_local_.find.left)
- return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool,
- ffestb_local_.find.context,
- (ffeexprCallback) ffestb_V0266_);
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- ffestb_local_.find.context,
- (ffeexprCallback) ffestb_V0266_);
+ if (ffestb_local_.read.label)
+ return (ffelexHandler) ffestb_R90911_;
+ if (ffestb_local_.read.left)
+ return (ffelexHandler)
+ ffeexpr_lhs (ffesta_output_pool,
+ ffestb_local_.read.context,
+ (ffeexprCallback) ffestb_R90910_);
+ return (ffelexHandler)
+ ffeexpr_rhs (ffesta_output_pool,
+ ffestb_local_.read.context,
+ (ffeexprCallback) ffestb_R90910_);
default:
break;
}
- ffestb_subr_kill_find_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FIND", t);
+ ffestb_subr_kill_read_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "READ", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_V0266_ -- "FIND" OPEN_PAREN ... NAME EQUALS expr
+/* ffestb_R90910_ -- "READ" OPEN_PAREN ... NAME EQUALS expr
- (ffestb_V0266_) // to expression handler
+ (ffestb_R90910_) // to expression handler
Handle COMMA or CLOSE_PAREN here. */
static ffelexHandler
-ffestb_V0266_ (ffelexToken ft, ffebld expr, ffelexToken t)
+ffestb_R90910_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
switch (ffelex_token_type (t))
{
case FFELEX_typeCOMMA:
case FFELEX_typeCLOSE_PAREN:
if (expr == NULL)
- break;
- ffestp_file.find.find_spec[ffestb_local_.find.ix].value_present
+ {
+ if (ffestb_local_.read.context == FFEEXPR_contextFILEFORMAT)
+ ffestp_file.read.read_spec[ffestb_local_.read.ix]
+ .value_is_label = TRUE;
+ else
+ break;
+ }
+ ffestp_file.read.read_spec[ffestb_local_.read.ix].value_present
= TRUE;
- ffestp_file.find.find_spec[ffestb_local_.find.ix].value
+ ffestp_file.read.read_spec[ffestb_local_.read.ix].value
= ffelex_token_use (ft);
- ffestp_file.find.find_spec[ffestb_local_.find.ix].u.expr = expr;
+ ffestp_file.read.read_spec[ffestb_local_.read.ix].u.expr = expr;
if (ffelex_token_type (t) == FFELEX_typeCOMMA)
- return (ffelexHandler) ffestb_V0264_;
- return (ffelexHandler) ffestb_V0269_;
+ return (ffelexHandler) ffestb_R9098_;
+ return (ffelexHandler) ffestb_R90913_;
default:
break;
}
- ffestb_subr_kill_find_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FIND", t);
+ ffestb_subr_kill_read_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "READ", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_V0267_ -- "FIND" OPEN_PAREN ... NAME EQUALS
+/* ffestb_R90911_ -- "READ" OPEN_PAREN ... NAME EQUALS
- return ffestb_V0267_; // to lexer
+ return ffestb_R90911_; // to lexer
Handle NUMBER for label here. */
static ffelexHandler
-ffestb_V0267_ (ffelexToken t)
+ffestb_R90911_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
case FFELEX_typeNUMBER:
- ffestp_file.find.find_spec[ffestb_local_.find.ix].value_present
+ ffestp_file.read.read_spec[ffestb_local_.read.ix].value_present
= TRUE;
- ffestp_file.find.find_spec[ffestb_local_.find.ix].value
+ ffestp_file.read.read_spec[ffestb_local_.read.ix].value
= ffelex_token_use (t);
- return (ffelexHandler) ffestb_V0268_;
+ return (ffelexHandler) ffestb_R90912_;
default:
break;
}
- ffestb_subr_kill_find_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FIND", t);
+ ffestb_subr_kill_read_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "READ", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_V0268_ -- "FIND" OPEN_PAREN ... NAME EQUALS NUMBER
+/* ffestb_R90912_ -- "READ" OPEN_PAREN ... NAME EQUALS NUMBER
- return ffestb_V0268_; // to lexer
+ return ffestb_R90912_; // to lexer
Handle COMMA or CLOSE_PAREN here. */
static ffelexHandler
-ffestb_V0268_ (ffelexToken t)
+ffestb_R90912_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
case FFELEX_typeCOMMA:
- return (ffelexHandler) ffestb_V0264_;
+ return (ffelexHandler) ffestb_R9098_;
case FFELEX_typeCLOSE_PAREN:
- return (ffelexHandler) ffestb_V0269_;
+ return (ffelexHandler) ffestb_R90913_;
default:
break;
}
- ffestb_subr_kill_find_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FIND", t);
+ ffestb_subr_kill_read_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "READ", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_V0269_ -- "FIND" OPEN_PAREN ... CLOSE_PAREN
+/* ffestb_R90913_ -- "READ" OPEN_PAREN ... CLOSE_PAREN
+
+ return ffestb_R90913_; // to lexer
- return ffestb_V0269_; // to lexer
+ Handle EOS or SEMICOLON here.
- Handle EOS or SEMICOLON here. */
+ 15-Feb-91 JCB 1.1
+ Fix to allow implied-DO construct here (OPEN_PAREN) -- actually,
+ don't presume knowledge of what an initial token in an lhs context
+ is going to be, let ffeexpr_lhs handle that as much as possible. */
static ffelexHandler
-ffestb_V0269_ (ffelexToken t)
+ffestb_R90913_ (ffelexToken t)
+{
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ ffesta_confirmed ();
+ if (!ffesta_is_inhibited ())
+ {
+ ffestc_R909_start (FALSE);
+ ffestc_R909_finish ();
+ }
+ ffestb_subr_kill_read_ ();
+ return (ffelexHandler) ffesta_zero (t);
+
+ default:
+ ffesta_confirmed ();
+ /* Fall through. */
+ case FFELEX_typeOPEN_PAREN: /* Could still be assignment!! */
+ break;
+ }
+
+ /* If token isn't NAME or OPEN_PAREN, ffeexpr_lhs will ultimately whine
+ about it, so leave it up to that code. */
+
+ /* EXTENSION: Allow an optional preceding COMMA here if not pedantic. (f2c
+ provides this extension, as do other compilers, supposedly.) */
+
+ if (!ffe_is_pedantic () && (ffelex_token_type (t) == FFELEX_typeCOMMA))
+ return (ffelexHandler)
+ ffeexpr_lhs (ffesta_output_pool,
+ ffestc_context_iolist (),
+ (ffeexprCallback) ffestb_R90914_);
+
+ return (ffelexHandler) (*((ffelexHandler)
+ ffeexpr_lhs (ffesta_output_pool,
+ ffestc_context_iolist (),
+ (ffeexprCallback) ffestb_R90914_)))
+ (t);
+}
+
+/* ffestb_R90914_ -- "READ(...)" expr
+
+ (ffestb_R90914_) // to expression handler
+
+ Handle COMMA or EOS/SEMICOLON here. */
+
+static ffelexHandler
+ffestb_R90914_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
switch (ffelex_token_type (t))
{
+ case FFELEX_typeCOMMA:
+ if (expr == NULL)
+ break;
+
+ ffesta_confirmed ();
+ if (!ffesta_is_inhibited ())
+ ffestc_R909_start (FALSE);
+ ffestb_subr_kill_read_ ();
+
+ if (!ffesta_is_inhibited ())
+ ffestc_R909_item (expr, ft);
+ return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool,
+ ffestc_context_iolist (),
+ (ffeexprCallback) ffestb_R90915_);
+
case FFELEX_typeEOS:
case FFELEX_typeSEMICOLON:
+ if (expr == NULL)
+ break;
+
ffesta_confirmed ();
if (!ffesta_is_inhibited ())
- ffestc_V026 ();
- ffestb_subr_kill_find_ ();
+ ffestc_R909_start (FALSE);
+ ffestb_subr_kill_read_ ();
+
+ if (!ffesta_is_inhibited ())
+ {
+ ffestc_R909_item (expr, ft);
+ ffestc_R909_finish ();
+ }
return (ffelexHandler) ffesta_zero (t);
default:
break;
}
- ffestb_subr_kill_find_ ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FIND", t);
+ ffestb_subr_kill_read_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "READ", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-#endif
-/* ffestb_dimlist -- Parse the ALLOCATABLE/POINTER/TARGET statement
+/* ffestb_R90915_ -- "READ(...)" expr COMMA expr
+
+ (ffestb_R90915_) // to expression handler
+
+ Handle COMMA or EOS/SEMICOLON here. */
+
+static ffelexHandler
+ffestb_R90915_ (ffelexToken ft, ffebld expr, ffelexToken t)
+{
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeCOMMA:
+ if (expr == NULL)
+ break;
+ if (!ffesta_is_inhibited ())
+ ffestc_R909_item (expr, ft);
+ return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool,
+ ffestc_context_iolist (),
+ (ffeexprCallback) ffestb_R90915_);
+
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ if (expr == NULL)
+ break;
+ if (!ffesta_is_inhibited ())
+ {
+ ffestc_R909_item (expr, ft);
+ ffestc_R909_finish ();
+ }
+ return (ffelexHandler) ffesta_zero (t);
+
+ default:
+ break;
+ }
- return ffestb_dimlist; // to lexer
+ if (!ffesta_is_inhibited ())
+ ffestc_R909_finish ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "READ", t);
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+}
+
+/* ffestb_R910 -- Parse the WRITE statement
+
+ return ffestb_R910; // to lexer
- Make sure the statement has a valid form for the ALLOCATABLE/POINTER/
- TARGET statement. If it does, implement the statement. */
+ Make sure the statement has a valid form for the WRITE
+ statement. If it does, implement the statement. */
-#if FFESTR_F90
ffelexHandler
-ffestb_dimlist (ffelexToken t)
+ffestb_R910 (ffelexToken t)
{
- ffeTokenLength i;
- const char *p;
- ffelexToken nt;
- ffelexHandler next;
+ ffestpWriteIx ix;
switch (ffelex_token_type (ffesta_tokens[0]))
{
case FFELEX_typeNAME:
+ if (ffesta_first_kw != FFESTR_firstWRITE)
+ goto bad_0; /* :::::::::::::::::::: */
switch (ffelex_token_type (t))
{
case FFELEX_typeCOMMA:
+ case FFELEX_typeCOLONCOLON:
case FFELEX_typeEOS:
case FFELEX_typeSEMICOLON:
+ case FFELEX_typeNAME:
+ case FFELEX_typeNUMBER:
ffesta_confirmed (); /* Error, but clearly intended. */
goto bad_1; /* :::::::::::::::::::: */
default:
goto bad_1; /* :::::::::::::::::::: */
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- {
- switch (ffesta_first_kw)
- {
- case FFESTR_firstALLOCATABLE:
- ffestc_R525_start ();
- break;
-
- case FFESTR_firstPOINTER:
- ffestc_R526_start ();
- break;
-
- case FFESTR_firstTARGET:
- ffestc_R527_start ();
- break;
-
- default:
- assert (FALSE);
- }
- }
- ffestb_local_.dimlist.started = TRUE;
- return (ffelexHandler) ffestb_dimlist1_;
-
- case FFELEX_typeNAME:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- {
- switch (ffesta_first_kw)
- {
- case FFESTR_firstALLOCATABLE:
- ffestc_R525_start ();
- break;
-
- case FFESTR_firstPOINTER:
- ffestc_R526_start ();
- break;
-
- case FFESTR_firstTARGET:
- ffestc_R527_start ();
- break;
-
- default:
- assert (FALSE);
- }
- }
- ffestb_local_.dimlist.started = TRUE;
- return (ffelexHandler) ffestb_dimlist1_ (t);
+ case FFELEX_typeOPEN_PAREN:
+ for (ix = 0; ix < FFESTP_writeix; ++ix)
+ ffestp_file.write.write_spec[ix].kw_or_val_present = FALSE;
+ return (ffelexHandler) ffestb_R9101_;
}
case FFELEX_typeNAMES:
- p = ffelex_token_text (ffesta_tokens[0]) + (i = ffestb_args.dimlist.len);
+ if (ffesta_first_kw != FFESTR_firstWRITE)
+ goto bad_0; /* :::::::::::::::::::: */
switch (ffelex_token_type (t))
{
- default:
- goto bad_1; /* :::::::::::::::::::: */
-
case FFELEX_typeEOS:
case FFELEX_typeSEMICOLON:
case FFELEX_typeCOMMA:
- ffesta_confirmed ();
- if (!ffesrc_is_name_init (*p))
- goto bad_i; /* :::::::::::::::::::: */
- nt = ffelex_token_name_from_names (ffesta_tokens[0], i, 0);
- if (!ffesta_is_inhibited ())
- {
- switch (ffesta_first_kw)
- {
- case FFESTR_firstALLOCATABLE:
- ffestc_R525_start ();
- break;
-
- case FFESTR_firstPOINTER:
- ffestc_R526_start ();
- break;
-
- case FFESTR_firstTARGET:
- ffestc_R527_start ();
- break;
-
- default:
- assert (FALSE);
- }
- }
- ffestb_local_.dimlist.started = TRUE;
- next = (ffelexHandler) ffestb_dimlist1_ (nt);
- ffelex_token_kill (nt);
- return (ffelexHandler) (*next) (t);
-
case FFELEX_typeCOLONCOLON:
- ffesta_confirmed ();
- if (*p != '\0')
- goto bad_i; /* :::::::::::::::::::: */
- if (!ffesta_is_inhibited ())
- {
- switch (ffesta_first_kw)
- {
- case FFESTR_firstALLOCATABLE:
- ffestc_R525_start ();
- break;
-
- case FFESTR_firstPOINTER:
- ffestc_R526_start ();
- break;
-
- case FFESTR_firstTARGET:
- ffestc_R527_start ();
- break;
-
- default:
- assert (FALSE);
- }
- }
- ffestb_local_.dimlist.started = TRUE;
- return (ffelexHandler) ffestb_dimlist1_;
+ ffesta_confirmed (); /* Error, but clearly intended. */
+ goto bad_1; /* :::::::::::::::::::: */
+
+ default:
+ goto bad_1; /* :::::::::::::::::::: */
case FFELEX_typeOPEN_PAREN:
- if (!ffesrc_is_name_init (*p))
- goto bad_i; /* :::::::::::::::::::: */
- nt = ffelex_token_name_from_names (ffesta_tokens[0], i, 0);
- ffestb_local_.dimlist.started = FALSE;
- next = (ffelexHandler) ffestb_dimlist1_ (nt);
- ffelex_token_kill (nt);
- return (ffelexHandler) (*next) (t);
+ if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlWRITE)
+ goto bad_0; /* :::::::::::::::::::: */
+
+ for (ix = 0; ix < FFESTP_writeix; ++ix)
+ ffestp_file.write.write_spec[ix].kw_or_val_present = FALSE;
+ return (ffelexHandler) ffestb_R9101_;
}
default:
}
bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.dimlist.badname, ffesta_tokens[0]);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "WRITE", ffesta_tokens[0]);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.dimlist.badname, t);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "WRITE", t);
return (ffelexHandler) ffelex_swallow_tokens (t,
(ffelexHandler) ffesta_zero); /* Invalid second token. */
-
-bad_i: /* :::::::::::::::::::: */
- ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, ffestb_args.dimlist.badname, ffesta_tokens[0], i, t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_dimlist1_ -- "ALLOCATABLE/POINTER/TARGET" [COLONCOLON]
+/* ffestb_R9101_ -- "WRITE" OPEN_PAREN
- return ffestb_dimlist1_; // to lexer
+ return ffestb_R9101_; // to lexer
- Handle NAME. */
+ Handle expr construct (not NAME=expr construct) here. */
static ffelexHandler
-ffestb_dimlist1_ (ffelexToken t)
+ffestb_R9101_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
case FFELEX_typeNAME:
ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_dimlist2_;
+ return (ffelexHandler) ffestb_R9102_;
default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.dimlist.badname, t);
- break;
+ return (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ FFEEXPR_contextFILEUNIT, (ffeexprCallback) ffestb_R9103_)))
+ (t);
}
+}
- if (!ffesta_is_inhibited ())
- {
- switch (ffesta_first_kw)
- {
- case FFESTR_firstALLOCATABLE:
- ffestc_R525_finish ();
- break;
+/* ffestb_R9102_ -- "WRITE" OPEN_PAREN NAME
- case FFESTR_firstPOINTER:
- ffestc_R526_finish ();
- break;
+ return ffestb_R9102_; // to lexer
- case FFESTR_firstTARGET:
- ffestc_R527_finish ();
- break;
+ If EQUALS here, go to states that handle it. Else, send NAME and this
+ token thru expression handler. */
- default:
- assert (FALSE);
- }
+static ffelexHandler
+ffestb_R9102_ (ffelexToken t)
+{
+ ffelexHandler next;
+ ffelexToken nt;
+
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeEQUALS:
+ nt = ffesta_tokens[1];
+ next = (ffelexHandler) ffestb_R9107_ (nt);
+ ffelex_token_kill (nt);
+ return (ffelexHandler) (*next) (t);
+
+ default:
+ nt = ffesta_tokens[1];
+ next = (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ FFEEXPR_contextFILEUNIT, (ffeexprCallback) ffestb_R9103_)))
+ (nt);
+ ffelex_token_kill (nt);
+ return (ffelexHandler) (*next) (t);
}
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_dimlist2_ -- "ALLOCATABLE/POINTER/TARGET" ... NAME
+/* ffestb_R9103_ -- "WRITE" OPEN_PAREN expr [CLOSE_PAREN]
- return ffestb_dimlist2_; // to lexer
+ (ffestb_R9103_) // to expression handler
- Handle OPEN_PAREN. */
+ Handle COMMA or EOS/SEMICOLON here. */
static ffelexHandler
-ffestb_dimlist2_ (ffelexToken t)
+ffestb_R9103_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeOPEN_PAREN:
- ffestb_subrargs_.dim_list.dims = ffestt_dimlist_create ();
- ffestb_subrargs_.dim_list.handler = (ffelexHandler) ffestb_dimlist3_;
- ffestb_subrargs_.dim_list.pool = ffesta_output_pool;
- ffestb_subrargs_.dim_list.ctx = FFEEXPR_contextDIMLIST;
-#ifdef FFECOM_dimensionsMAX
- ffestb_subrargs_.dim_list.ndims = 0;
-#endif
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextDIMLIST, (ffeexprCallback) ffestb_subr_dimlist_);
-
case FFELEX_typeCOMMA:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- {
- if (!ffestb_local_.dimlist.started)
- {
- switch (ffesta_first_kw)
- {
- case FFESTR_firstALLOCATABLE:
- ffestc_R525_start ();
- break;
+ case FFELEX_typeCLOSE_PAREN:
+ if (expr == NULL)
+ break;
+ ffestp_file.write.write_spec[FFESTP_writeixUNIT].kw_or_val_present
+ = TRUE;
+ ffestp_file.write.write_spec[FFESTP_writeixUNIT].kw_present = FALSE;
+ ffestp_file.write.write_spec[FFESTP_writeixUNIT].value_present = TRUE;
+ ffestp_file.write.write_spec[FFESTP_writeixUNIT].value_is_label
+ = FALSE;
+ ffestp_file.write.write_spec[FFESTP_writeixUNIT].value
+ = ffelex_token_use (ft);
+ ffestp_file.write.write_spec[FFESTP_writeixUNIT].u.expr = expr;
+ if (ffelex_token_type (t) == FFELEX_typeCOMMA)
+ return (ffelexHandler) ffestb_R9104_;
+ return (ffelexHandler) ffestb_R91012_;
- case FFESTR_firstPOINTER:
- ffestc_R526_start ();
- break;
+ default:
+ break;
+ }
- case FFESTR_firstTARGET:
- ffestc_R527_start ();
- break;
+ ffestb_subr_kill_write_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "WRITE", t);
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+}
- default:
- assert (FALSE);
- }
- ffestb_local_.dimlist.started = TRUE;
- }
- switch (ffesta_first_kw)
- {
- case FFESTR_firstALLOCATABLE:
- ffestc_R525_item (ffesta_tokens[1], NULL);
- break;
+/* ffestb_R9104_ -- "WRITE" OPEN_PAREN expr COMMA
- case FFESTR_firstPOINTER:
- ffestc_R526_item (ffesta_tokens[1], NULL);
- break;
+ return ffestb_R9104_; // to lexer
- case FFESTR_firstTARGET:
- ffestc_R527_item (ffesta_tokens[1], NULL);
- break;
+ Handle expr construct (not NAME=expr construct) here. */
- default:
- assert (FALSE);
- }
- }
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffestb_dimlist4_;
+static ffelexHandler
+ffestb_R9104_ (ffelexToken t)
+{
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeNAME:
+ ffesta_tokens[1] = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_R9105_;
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- {
- if (!ffestb_local_.dimlist.started)
- {
- switch (ffesta_first_kw)
- {
- case FFESTR_firstALLOCATABLE:
- ffestc_R525_start ();
- break;
+ default:
+ return (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ FFEEXPR_contextFILEFORMATNML, (ffeexprCallback) ffestb_R9106_)))
+ (t);
+ }
+}
- case FFESTR_firstPOINTER:
- ffestc_R526_start ();
- break;
+/* ffestb_R9105_ -- "WRITE" OPEN_PAREN expr COMMA NAME
- case FFESTR_firstTARGET:
- ffestc_R527_start ();
- break;
+ return ffestb_R9105_; // to lexer
- default:
- assert (FALSE);
- }
- }
- switch (ffesta_first_kw)
- {
- case FFESTR_firstALLOCATABLE:
- ffestc_R525_item (ffesta_tokens[1], NULL);
- ffestc_R525_finish ();
- break;
+ If EQUALS here, go to states that handle it. Else, send NAME and this
+ token thru expression handler. */
- case FFESTR_firstPOINTER:
- ffestc_R526_item (ffesta_tokens[1], NULL);
- ffestc_R526_finish ();
- break;
+static ffelexHandler
+ffestb_R9105_ (ffelexToken t)
+{
+ ffelexHandler next;
+ ffelexToken nt;
- case FFESTR_firstTARGET:
- ffestc_R527_item (ffesta_tokens[1], NULL);
- ffestc_R527_finish ();
- break;
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeEQUALS:
+ nt = ffesta_tokens[1];
+ next = (ffelexHandler) ffestb_R9107_ (nt);
+ ffelex_token_kill (nt);
+ return (ffelexHandler) (*next) (t);
- default:
- assert (FALSE);
- }
- }
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffesta_zero (t);
+ default:
+ nt = ffesta_tokens[1];
+ next = (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ FFEEXPR_contextFILEFORMATNML, (ffeexprCallback) ffestb_R9106_)))
+ (nt);
+ ffelex_token_kill (nt);
+ return (ffelexHandler) (*next) (t);
+ }
+}
+
+/* ffestb_R9106_ -- "WRITE" OPEN_PAREN expr COMMA expr
+
+ (ffestb_R9106_) // to expression handler
+
+ Handle COMMA or CLOSE_PAREN here. */
+
+static ffelexHandler
+ffestb_R9106_ (ffelexToken ft, ffebld expr, ffelexToken t)
+{
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeCOMMA:
+ case FFELEX_typeCLOSE_PAREN:
+ ffestp_file.write.write_spec[FFESTP_writeixFORMAT].kw_or_val_present
+ = TRUE;
+ ffestp_file.write.write_spec[FFESTP_writeixFORMAT].kw_present = FALSE;
+ ffestp_file.write.write_spec[FFESTP_writeixFORMAT].value_present = TRUE;
+ ffestp_file.write.write_spec[FFESTP_writeixFORMAT].value_is_label
+ = (expr == NULL);
+ ffestp_file.write.write_spec[FFESTP_writeixFORMAT].value
+ = ffelex_token_use (ft);
+ ffestp_file.write.write_spec[FFESTP_writeixFORMAT].u.expr = expr;
+ if (ffelex_token_type (t) == FFELEX_typeCOMMA)
+ return (ffelexHandler) ffestb_R9107_;
+ return (ffelexHandler) ffestb_R91012_;
default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.dimlist.badname, t);
break;
}
- if (!ffesta_is_inhibited ())
+ ffestb_subr_kill_write_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "WRITE", t);
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+}
+
+/* ffestb_R9107_ -- "WRITE" OPEN_PAREN [external-file-unit COMMA [format
+ COMMA]]
+
+ return ffestb_R9107_; // to lexer
+
+ Handle expr construct (not NAME=expr construct) here. */
+
+static ffelexHandler
+ffestb_R9107_ (ffelexToken t)
+{
+ ffestrGenio kw;
+
+ ffestb_local_.write.label = FALSE;
+
+ switch (ffelex_token_type (t))
{
- switch (ffesta_first_kw)
+ case FFELEX_typeNAME:
+ kw = ffestr_genio (t);
+ switch (kw)
{
- case FFESTR_firstALLOCATABLE:
- ffestc_R525_finish ();
+ case FFESTR_genioADVANCE:
+ ffestb_local_.write.ix = FFESTP_writeixADVANCE;
+ ffestb_local_.write.left = FALSE;
+ ffestb_local_.write.context = FFEEXPR_contextFILEDFCHAR;
+ break;
+
+ case FFESTR_genioEOR:
+ ffestb_local_.write.ix = FFESTP_writeixEOR;
+ ffestb_local_.write.label = TRUE;
+ break;
+
+ case FFESTR_genioERR:
+ ffestb_local_.write.ix = FFESTP_writeixERR;
+ ffestb_local_.write.label = TRUE;
+ break;
+
+ case FFESTR_genioFMT:
+ ffestb_local_.write.ix = FFESTP_writeixFORMAT;
+ ffestb_local_.write.left = FALSE;
+ ffestb_local_.write.context = FFEEXPR_contextFILEFORMAT;
+ break;
+
+ case FFESTR_genioIOSTAT:
+ ffestb_local_.write.ix = FFESTP_writeixIOSTAT;
+ ffestb_local_.write.left = TRUE;
+ ffestb_local_.write.context = FFEEXPR_contextFILEINT;
+ break;
+
+ case FFESTR_genioNML:
+ ffestb_local_.write.ix = FFESTP_writeixFORMAT;
+ ffestb_local_.write.left = TRUE;
+ ffestb_local_.write.context = FFEEXPR_contextFILENAMELIST;
break;
- case FFESTR_firstPOINTER:
- ffestc_R526_finish ();
+ case FFESTR_genioREC:
+ ffestb_local_.write.ix = FFESTP_writeixREC;
+ ffestb_local_.write.left = FALSE;
+ ffestb_local_.write.context = FFEEXPR_contextFILENUM;
break;
- case FFESTR_firstTARGET:
- ffestc_R527_finish ();
+ case FFESTR_genioUNIT:
+ ffestb_local_.write.ix = FFESTP_writeixUNIT;
+ ffestb_local_.write.left = FALSE;
+ ffestb_local_.write.context = FFEEXPR_contextFILEUNIT;
break;
default:
- assert (FALSE);
+ goto bad; /* :::::::::::::::::::: */
}
+ if (ffestp_file.write.write_spec[ffestb_local_.write.ix]
+ .kw_or_val_present)
+ break; /* Can't specify a keyword twice! */
+ ffestp_file.write.write_spec[ffestb_local_.write.ix]
+ .kw_or_val_present = TRUE;
+ ffestp_file.write.write_spec[ffestb_local_.write.ix]
+ .kw_present = TRUE;
+ ffestp_file.write.write_spec[ffestb_local_.write.ix]
+ .value_present = FALSE;
+ ffestp_file.write.write_spec[ffestb_local_.write.ix].value_is_label
+ = ffestb_local_.write.label;
+ ffestp_file.write.write_spec[ffestb_local_.write.ix].kw
+ = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_R9108_;
+
+ default:
+ break;
}
- ffelex_token_kill (ffesta_tokens[1]);
+
+bad: /* :::::::::::::::::::: */
+ ffestb_subr_kill_write_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "WRITE", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_dimlist3_ -- "ALLOCATABLE/POINTER/TARGET" ... NAME OPEN_PAREN
- dimlist CLOSE_PAREN
+/* ffestb_R9108_ -- "WRITE" OPEN_PAREN [external-file-unit COMMA [format
+ COMMA]] NAME
- return ffestb_dimlist3_; // to lexer
+ return ffestb_R9108_; // to lexer
- Handle COMMA or EOS/SEMICOLON. */
+ Make sure EQUALS here, send next token to expression handler. */
static ffelexHandler
-ffestb_dimlist3_ (ffelexToken t)
+ffestb_R9108_ (ffelexToken t)
{
- if (!ffestb_subrargs_.dim_list.ok)
- goto bad; /* :::::::::::::::::::: */
-
switch (ffelex_token_type (t))
{
- case FFELEX_typeCOMMA:
+ case FFELEX_typeEQUALS:
ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- {
- if (!ffestb_local_.dimlist.started)
- {
- switch (ffesta_first_kw)
- {
- case FFESTR_firstALLOCATABLE:
- ffestc_R525_start ();
- break;
-
- case FFESTR_firstPOINTER:
- ffestc_R526_start ();
- break;
+ if (ffestb_local_.write.label)
+ return (ffelexHandler) ffestb_R91010_;
+ if (ffestb_local_.write.left)
+ return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool,
+ ffestb_local_.write.context,
+ (ffeexprCallback) ffestb_R9109_);
+ return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ ffestb_local_.write.context,
+ (ffeexprCallback) ffestb_R9109_);
- case FFESTR_firstTARGET:
- ffestc_R527_start ();
- break;
+ default:
+ break;
+ }
- default:
- assert (FALSE);
- }
- ffestb_local_.dimlist.started = TRUE;
- }
- switch (ffesta_first_kw)
- {
- case FFESTR_firstALLOCATABLE:
- ffestc_R525_item (ffesta_tokens[1],
- ffestb_subrargs_.dim_list.dims);
- break;
+ ffestb_subr_kill_write_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "WRITE", t);
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+}
- case FFESTR_firstPOINTER:
- ffestc_R526_item (ffesta_tokens[1],
- ffestb_subrargs_.dim_list.dims);
- break;
+/* ffestb_R9109_ -- "WRITE" OPEN_PAREN ... NAME EQUALS expr
- case FFESTR_firstTARGET:
- ffestc_R527_item (ffesta_tokens[1],
- ffestb_subrargs_.dim_list.dims);
- break;
+ (ffestb_R9109_) // to expression handler
- default:
- assert (FALSE);
- }
- }
- ffelex_token_kill (ffesta_tokens[1]);
- ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
- return (ffelexHandler) ffestb_dimlist4_;
+ Handle COMMA or CLOSE_PAREN here. */
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
+static ffelexHandler
+ffestb_R9109_ (ffelexToken ft, ffebld expr, ffelexToken t)
+{
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeCOMMA:
+ case FFELEX_typeCLOSE_PAREN:
+ if (expr == NULL)
{
- if (!ffestb_local_.dimlist.started)
- {
- switch (ffesta_first_kw)
- {
- case FFESTR_firstALLOCATABLE:
- ffestc_R525_start ();
- break;
-
- case FFESTR_firstPOINTER:
- ffestc_R526_start ();
- break;
-
- case FFESTR_firstTARGET:
- ffestc_R527_start ();
- break;
-
- default:
- assert (FALSE);
- }
- }
- switch (ffesta_first_kw)
- {
- case FFESTR_firstALLOCATABLE:
- ffestc_R525_item (ffesta_tokens[1],
- ffestb_subrargs_.dim_list.dims);
- ffestc_R525_finish ();
- break;
-
- case FFESTR_firstPOINTER:
- ffestc_R526_item (ffesta_tokens[1],
- ffestb_subrargs_.dim_list.dims);
- ffestc_R526_finish ();
- break;
-
- case FFESTR_firstTARGET:
- ffestc_R527_item (ffesta_tokens[1],
- ffestb_subrargs_.dim_list.dims);
- ffestc_R527_finish ();
- break;
-
- default:
- assert (FALSE);
- }
+ if (ffestb_local_.write.context == FFEEXPR_contextFILEFORMAT)
+ ffestp_file.write.write_spec[ffestb_local_.write.ix]
+ .value_is_label = TRUE;
+ else
+ break;
}
- ffelex_token_kill (ffesta_tokens[1]);
- ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
- return (ffelexHandler) ffesta_zero (t);
+ ffestp_file.write.write_spec[ffestb_local_.write.ix].value_present
+ = TRUE;
+ ffestp_file.write.write_spec[ffestb_local_.write.ix].value
+ = ffelex_token_use (ft);
+ ffestp_file.write.write_spec[ffestb_local_.write.ix].u.expr = expr;
+ if (ffelex_token_type (t) == FFELEX_typeCOMMA)
+ return (ffelexHandler) ffestb_R9107_;
+ return (ffelexHandler) ffestb_R91012_;
default:
break;
}
-bad: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.dimlist.badname, t);
- if (ffestb_local_.dimlist.started && !ffesta_is_inhibited ())
- {
- switch (ffesta_first_kw)
- {
- case FFESTR_firstALLOCATABLE:
- ffestc_R525_finish ();
- break;
-
- case FFESTR_firstPOINTER:
- ffestc_R526_finish ();
- break;
-
- case FFESTR_firstTARGET:
- ffestc_R527_finish ();
- break;
-
- default:
- assert (FALSE);
- }
- }
- ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
- ffelex_token_kill (ffesta_tokens[1]);
+ ffestb_subr_kill_write_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "WRITE", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_dimlist4_ -- "ALLOCATABLE/POINTER/TARGET" ... COMMA
+/* ffestb_R91010_ -- "WRITE" OPEN_PAREN ... NAME EQUALS
- return ffestb_dimlist4_; // to lexer
+ return ffestb_R91010_; // to lexer
- Make sure we don't have EOS or SEMICOLON. */
+ Handle NUMBER for label here. */
static ffelexHandler
-ffestb_dimlist4_ (ffelexToken t)
+ffestb_R91010_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- if (!ffesta_is_inhibited ())
- {
- switch (ffesta_first_kw)
- {
- case FFESTR_firstALLOCATABLE:
- ffestc_R525_finish ();
- break;
-
- case FFESTR_firstPOINTER:
- ffestc_R526_finish ();
- break;
-
- case FFESTR_firstTARGET:
- ffestc_R527_finish ();
- break;
-
- default:
- assert (FALSE);
- }
- }
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.dimlist.badname, t);
- return (ffelexHandler) ffesta_zero (t);
+ case FFELEX_typeNUMBER:
+ ffestp_file.write.write_spec[ffestb_local_.write.ix].value_present
+ = TRUE;
+ ffestp_file.write.write_spec[ffestb_local_.write.ix].value
+ = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_R91011_;
default:
- return (ffelexHandler) ffestb_dimlist1_ (t);
+ break;
}
+
+ ffestb_subr_kill_write_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "WRITE", t);
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-#endif
-/* ffestb_dummy -- Parse an ENTRY/FUNCTION/SUBROUTINE statement
+/* ffestb_R91011_ -- "WRITE" OPEN_PAREN ... NAME EQUALS NUMBER
- return ffestb_dummy; // to lexer
+ return ffestb_R91011_; // to lexer
- Make sure the statement has a valid form for an ENTRY/FUNCTION/SUBROUTINE
- statement. If it does, implement the statement. */
+ Handle COMMA or CLOSE_PAREN here. */
-ffelexHandler
-ffestb_dummy (ffelexToken t)
+static ffelexHandler
+ffestb_R91011_ (ffelexToken t)
{
- ffeTokenLength i;
- unsigned const char *p;
-
- switch (ffelex_token_type (ffesta_tokens[0]))
+ switch (ffelex_token_type (t))
{
- case FFELEX_typeNAME:
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
+ case FFELEX_typeCOMMA:
+ return (ffelexHandler) ffestb_R9107_;
- default:
- goto bad_1; /* :::::::::::::::::::: */
+ case FFELEX_typeCLOSE_PAREN:
+ return (ffelexHandler) ffestb_R91012_;
- case FFELEX_typeNAME:
- break;
- }
+ default:
+ break;
+ }
- ffesta_confirmed ();
- ffesta_tokens[1] = ffelex_token_use (t);
- ffestb_local_.decl.recursive = NULL;
- ffestb_local_.dummy.badname = ffestb_args.dummy.badname;
- ffestb_local_.dummy.is_subr = ffestb_args.dummy.is_subr;
- ffestb_local_.dummy.first_kw = ffesta_first_kw;
- return (ffelexHandler) ffestb_dummy1_;
+ ffestb_subr_kill_write_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "WRITE", t);
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+}
- case FFELEX_typeNAMES:
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
+/* ffestb_R91012_ -- "WRITE" OPEN_PAREN ... CLOSE_PAREN
- default:
- goto bad_1; /* :::::::::::::::::::: */
+ return ffestb_R91012_; // to lexer
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- break;
+ Handle EOS or SEMICOLON here. */
- case FFELEX_typeOPEN_PAREN:
- break;
+static ffelexHandler
+ffestb_R91012_ (ffelexToken t)
+{
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ ffesta_confirmed ();
+ if (!ffesta_is_inhibited ())
+ {
+ ffestc_R910_start ();
+ ffestc_R910_finish ();
}
- p = ffelex_token_text (ffesta_tokens[0]) + (i = ffestb_args.dummy.len);
- if (!ffesrc_is_name_init (*p))
- goto bad_i; /* :::::::::::::::::::: */
- ffesta_tokens[1]
- = ffelex_token_name_from_names (ffesta_tokens[0], i, 0);
- ffestb_local_.decl.recursive = NULL;
- ffestb_local_.dummy.badname = ffestb_args.dummy.badname;
- ffestb_local_.dummy.is_subr = ffestb_args.dummy.is_subr;
- ffestb_local_.dummy.first_kw = ffesta_first_kw;
- return (ffelexHandler) ffestb_dummy1_ (t);
+ ffestb_subr_kill_write_ ();
+ return (ffelexHandler) ffesta_zero (t);
default:
- goto bad_0; /* :::::::::::::::::::: */
- }
+ ffesta_confirmed ();
+ /* Fall through. */
+ case FFELEX_typeOPEN_PAREN: /* Could still be assignment!! */
-bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.dummy.badname, ffesta_tokens[0]);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+ /* EXTENSION: Allow an optional preceding COMMA here if not pedantic.
+ (f2c provides this extension, as do other compilers, supposedly.) */
-bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.dummy.badname, t);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero); /* Invalid second token. */
+ if (!ffe_is_pedantic () && (ffelex_token_type (t) == FFELEX_typeCOMMA))
+ return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ ffestc_context_iolist (), (ffeexprCallback) ffestb_R91013_);
-bad_i: /* :::::::::::::::::::: */
- ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, ffestb_args.dummy.badname, ffesta_tokens[0], i, t);
+ return (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ ffestc_context_iolist (), (ffeexprCallback) ffestb_R91013_)))
+ (t);
+
+ case FFELEX_typeEQUALS:
+ case FFELEX_typePOINTS:
+ break;
+ }
+
+ ffestb_subr_kill_write_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "WRITE", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_dummy1_ -- "ENTRY/FUNCTION/SUBROUTINE" NAME
+/* ffestb_R91013_ -- "WRITE(...)" expr
- return ffestb_dummy1_; // to lexer
+ (ffestb_R91013_) // to expression handler
- Make sure the next token is an EOS, SEMICOLON, or OPEN_PAREN. In the
- former case, just implement a null arg list, else get the arg list and
- then implement. */
+ Handle COMMA or EOS/SEMICOLON here. */
static ffelexHandler
-ffestb_dummy1_ (ffelexToken t)
+ffestb_R91013_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
switch (ffelex_token_type (t))
{
+ case FFELEX_typeCOMMA:
+ if (expr == NULL)
+ break;
+
+ ffesta_confirmed ();
+ if (!ffesta_is_inhibited ())
+ ffestc_R910_start ();
+ ffestb_subr_kill_write_ ();
+
+ if (!ffesta_is_inhibited ())
+ ffestc_R910_item (expr, ft);
+ return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ ffestc_context_iolist (), (ffeexprCallback) ffestb_R91014_);
+
case FFELEX_typeEOS:
case FFELEX_typeSEMICOLON:
- if (ffestb_local_.dummy.first_kw == FFESTR_firstFUNCTION)
- {
- ffesta_confirmed (); /* Later, not if typename w/o RECURSIVE. */
- break; /* Produce an error message, need that open
- paren. */
- }
+ if (expr == NULL)
+ break;
+
ffesta_confirmed ();
if (!ffesta_is_inhibited ())
- { /* Pretend as though we got a truly NULL
- list. */
- ffestb_subrargs_.name_list.args = NULL;
- ffestb_subrargs_.name_list.ok = TRUE;
- ffestb_subrargs_.name_list.close_paren = ffelex_token_use (t);
- return (ffelexHandler) ffestb_dummy2_ (t);
+ ffestc_R910_start ();
+ ffestb_subr_kill_write_ ();
+
+ if (!ffesta_is_inhibited ())
+ {
+ ffestc_R910_item (expr, ft);
+ ffestc_R910_finish ();
}
- if (ffestb_local_.decl.recursive != NULL)
- ffelex_token_kill (ffestb_local_.decl.recursive);
- ffelex_token_kill (ffesta_tokens[1]);
return (ffelexHandler) ffesta_zero (t);
- case FFELEX_typeOPEN_PAREN:
- ffestb_subrargs_.name_list.args = ffestt_tokenlist_create ();
- ffestb_subrargs_.name_list.handler = (ffelexHandler) ffestb_dummy2_;
- ffestb_subrargs_.name_list.is_subr = ffestb_local_.dummy.is_subr;
- ffestb_subrargs_.name_list.names = FALSE;
- return (ffelexHandler) ffestb_subr_name_list_;
-
default:
break;
}
- if (ffestb_local_.decl.recursive != NULL)
- ffelex_token_kill (ffestb_local_.decl.recursive);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_local_.dummy.badname, t);
- ffelex_token_kill (ffesta_tokens[1]);
+ ffestb_subr_kill_write_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "WRITE", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_dummy2_ -- <dummy-keyword> NAME OPEN_PAREN arg-list CLOSE_PAREN
+/* ffestb_R91014_ -- "WRITE(...)" expr COMMA expr
- return ffestb_dummy2_; // to lexer
+ (ffestb_R91014_) // to expression handler
- Make sure the statement has a valid form for a dummy-def statement. If it
- does, implement the statement. */
+ Handle COMMA or EOS/SEMICOLON here. */
static ffelexHandler
-ffestb_dummy2_ (ffelexToken t)
+ffestb_R91014_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
- if (!ffestb_subrargs_.name_list.ok)
- goto bad; /* :::::::::::::::::::: */
-
switch (ffelex_token_type (t))
{
+ case FFELEX_typeCOMMA:
+ if (expr == NULL)
+ break;
+ if (!ffesta_is_inhibited ())
+ ffestc_R910_item (expr, ft);
+ return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ ffestc_context_iolist (), (ffeexprCallback) ffestb_R91014_);
+
case FFELEX_typeEOS:
case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
+ if (expr == NULL)
+ break;
if (!ffesta_is_inhibited ())
{
- switch (ffestb_local_.dummy.first_kw)
- {
- case FFESTR_firstFUNCTION:
- ffestc_R1219 (ffesta_tokens[1], ffestb_subrargs_.name_list.args,
- ffestb_subrargs_.name_list.close_paren, FFESTP_typeNone,
- NULL, NULL, NULL, NULL, ffestb_local_.decl.recursive, NULL);
- break;
-
- case FFESTR_firstSUBROUTINE:
- ffestc_R1223 (ffesta_tokens[1], ffestb_subrargs_.name_list.args,
- ffestb_subrargs_.name_list.close_paren,
- ffestb_local_.decl.recursive);
- break;
-
- case FFESTR_firstENTRY:
- ffestc_R1226 (ffesta_tokens[1], ffestb_subrargs_.name_list.args,
- ffestb_subrargs_.name_list.close_paren);
- break;
-
- default:
- assert (FALSE);
- }
+ ffestc_R910_item (expr, ft);
+ ffestc_R910_finish ();
}
- ffelex_token_kill (ffesta_tokens[1]);
- if (ffestb_local_.decl.recursive != NULL)
- ffelex_token_kill (ffestb_local_.decl.recursive);
- ffelex_token_kill (ffestb_subrargs_.name_list.close_paren);
- if (ffestb_subrargs_.name_list.args != NULL)
- ffestt_tokenlist_kill (ffestb_subrargs_.name_list.args);
return (ffelexHandler) ffesta_zero (t);
- case FFELEX_typeNAME:
- ffesta_confirmed ();
- if ((ffestb_local_.dummy.first_kw != FFESTR_firstFUNCTION)
- || (ffestr_other (t) != FFESTR_otherRESULT))
- break;
- ffestb_local_.decl.type = FFESTP_typeNone;
- ffestb_local_.decl.kind = NULL;
- ffestb_local_.decl.kindt = NULL;
- ffestb_local_.decl.len = NULL;
- ffestb_local_.decl.lent = NULL;
- return (ffelexHandler) ffestb_decl_funcname_6_;
-
default:
break;
}
-bad: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_local_.dummy.badname, t);
- ffelex_token_kill (ffesta_tokens[1]);
- if (ffestb_local_.decl.recursive != NULL)
- ffelex_token_kill (ffestb_local_.decl.recursive);
- ffelex_token_kill (ffestb_subrargs_.name_list.close_paren);
- if (ffestb_subrargs_.name_list.args != NULL)
- ffestt_tokenlist_kill (ffestb_subrargs_.name_list.args);
+ if (!ffesta_is_inhibited ())
+ ffestc_R910_finish ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "WRITE", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R524 -- Parse the DIMENSION statement
+/* ffestb_R911 -- Parse the PRINT statement
- return ffestb_R524; // to lexer
+ return ffestb_R911; // to lexer
- Make sure the statement has a valid form for the DIMENSION statement. If
- it does, implement the statement. */
+ Make sure the statement has a valid form for the PRINT
+ statement. If it does, implement the statement. */
ffelexHandler
-ffestb_R524 (ffelexToken t)
+ffestb_R911 (ffelexToken t)
{
- ffeTokenLength i;
- unsigned const char *p;
- ffelexToken nt;
ffelexHandler next;
+ ffestpPrintIx ix;
switch (ffelex_token_type (ffesta_tokens[0]))
{
case FFELEX_typeNAME:
+ if (ffesta_first_kw != FFESTR_firstPRINT)
+ goto bad_0; /* :::::::::::::::::::: */
switch (ffelex_token_type (t))
{
case FFELEX_typeCOMMA:
ffesta_confirmed (); /* Error, but clearly intended. */
goto bad_1; /* :::::::::::::::::::: */
- default:
+ case FFELEX_typeEQUALS:
+ case FFELEX_typePOINTS:
+ case FFELEX_typeCOLON:
goto bad_1; /* :::::::::::::::::::: */
case FFELEX_typeNAME:
+ case FFELEX_typeNUMBER:
ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- ffestc_R524_start (ffesta_first_kw == FFESTR_firstVIRTUAL);
- ffestb_local_.dimension.started = TRUE;
- return (ffelexHandler) ffestb_R5241_ (t);
+ break;
+
+ default:
+ break;
}
+ for (ix = 0; ix < FFESTP_printix; ++ix)
+ ffestp_file.print.print_spec[ix].kw_or_val_present = FALSE;
+ return (ffelexHandler) (*((ffelexHandler)
+ ffeexpr_rhs (ffesta_output_pool,
+ FFEEXPR_contextFILEFORMATNML, (ffeexprCallback) ffestb_R9111_)))
+ (t);
+
case FFELEX_typeNAMES:
- p = ffelex_token_text (ffesta_tokens[0]) + (i = ffestb_args.R524.len);
+ if (ffesta_first_kw != FFESTR_firstPRINT)
+ goto bad_0; /* :::::::::::::::::::: */
switch (ffelex_token_type (t))
{
- default:
- goto bad_1; /* :::::::::::::::::::: */
-
case FFELEX_typeEOS:
case FFELEX_typeSEMICOLON:
case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
ffesta_confirmed ();
+ if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlPRINT)
+ break;
goto bad_1; /* :::::::::::::::::::: */
- case FFELEX_typeOPEN_PAREN:
- break;
- }
+ case FFELEX_typeCOLONCOLON:
+ ffesta_confirmed (); /* Error, but clearly intended. */
+ goto bad_1; /* :::::::::::::::::::: */
- /* Here, we have at least one char after "DIMENSION" and t is
- OPEN_PAREN. */
+ case FFELEX_typeEQUALS:
+ case FFELEX_typePOINTS:
+ case FFELEX_typeCOLON:
+ goto bad_1; /* :::::::::::::::::::: */
- if (!ffesrc_is_name_init (*p))
- goto bad_i; /* :::::::::::::::::::: */
- nt = ffelex_token_name_from_names (ffesta_tokens[0], i, 0);
- ffestb_local_.dimension.started = FALSE;
- next = (ffelexHandler) ffestb_R5241_ (nt);
- ffelex_token_kill (nt);
+ default:
+ break;
+ }
+ for (ix = 0; ix < FFESTP_printix; ++ix)
+ ffestp_file.print.print_spec[ix].kw_or_val_present = FALSE;
+ next = (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ FFEEXPR_contextFILEFORMATNML, (ffeexprCallback) ffestb_R9111_);
+ next = (ffelexHandler) ffelex_splice_tokens (next, ffesta_tokens[0],
+ FFESTR_firstlPRINT);
+ if (next == NULL)
+ return (ffelexHandler) ffelex_swallow_tokens (t,
+ (ffelexHandler) ffesta_zero);
return (ffelexHandler) (*next) (t);
default:
}
bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.R524.badname, ffesta_tokens[0]);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "PRINT", ffesta_tokens[0]);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.R524.badname, t);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "PRINT", t);
return (ffelexHandler) ffelex_swallow_tokens (t,
(ffelexHandler) ffesta_zero); /* Invalid second token. */
-
-bad_i: /* :::::::::::::::::::: */
- ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, ffestb_args.R524.badname, ffesta_tokens[0], i, t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_R5241_ -- "DIMENSION"
-
- return ffestb_R5241_; // to lexer
-
- Handle NAME. */
-
-static ffelexHandler
-ffestb_R5241_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_R5242_;
-
- default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.R524.badname, t);
- break;
- }
-
- if (!ffesta_is_inhibited ())
- ffestc_R524_finish ();
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R5242_ -- "DIMENSION" ... NAME
+/* ffestb_R9111_ -- "PRINT" expr
- return ffestb_R5242_; // to lexer
+ (ffestb_R9111_) // to expression handler
- Handle OPEN_PAREN. */
+ Make sure the next token is a COMMA or EOS/SEMICOLON. */
static ffelexHandler
-ffestb_R5242_ (ffelexToken t)
+ffestb_R9111_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeOPEN_PAREN:
- ffestb_subrargs_.dim_list.dims = ffestt_dimlist_create ();
- ffestb_subrargs_.dim_list.handler = (ffelexHandler) ffestb_R5243_;
- ffestb_subrargs_.dim_list.pool = ffesta_output_pool;
- ffestb_subrargs_.dim_list.ctx = ffesta_is_entry_valid
- ? FFEEXPR_contextDIMLIST : FFEEXPR_contextDIMLISTCOMMON;
-#ifdef FFECOM_dimensionsMAX
- ffestb_subrargs_.dim_list.ndims = 0;
-#endif
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- ffestb_subrargs_.dim_list.ctx,
- (ffeexprCallback) ffestb_subr_dimlist_);
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ case FFELEX_typeCOMMA:
+ ffesta_confirmed ();
+ ffestp_file.print.print_spec[FFESTP_printixFORMAT].kw_or_val_present
+ = TRUE;
+ ffestp_file.print.print_spec[FFESTP_printixFORMAT].kw_present = FALSE;
+ ffestp_file.print.print_spec[FFESTP_printixFORMAT].value_present = TRUE;
+ ffestp_file.print.print_spec[FFESTP_printixFORMAT].value_is_label
+ = (expr == NULL);
+ ffestp_file.print.print_spec[FFESTP_printixFORMAT].value
+ = ffelex_token_use (ft);
+ ffestp_file.print.print_spec[FFESTP_printixFORMAT].u.expr = expr;
+ if (!ffesta_is_inhibited ())
+ ffestc_R911_start ();
+ ffestb_subr_kill_print_ ();
+ if (ffelex_token_type (t) == FFELEX_typeCOMMA)
+ return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ FFEEXPR_contextIOLIST, (ffeexprCallback) ffestb_R9112_);
+ if (!ffesta_is_inhibited ())
+ ffestc_R911_finish ();
+ return (ffelexHandler) ffesta_zero (t);
default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.R524.badname, t);
break;
}
- if (!ffesta_is_inhibited ())
- ffestc_R524_finish ();
- ffelex_token_kill (ffesta_tokens[1]);
+ ffestb_subr_kill_print_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "PRINT", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R5243_ -- "DIMENSION" ... NAME OPEN_PAREN dimlist CLOSE_PAREN
+/* ffestb_R9112_ -- "PRINT" expr COMMA expr
- return ffestb_R5243_; // to lexer
+ (ffestb_R9112_) // to expression handler
- Handle COMMA or EOS/SEMICOLON. */
+ Handle COMMA or EOS/SEMICOLON here. */
static ffelexHandler
-ffestb_R5243_ (ffelexToken t)
+ffestb_R9112_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
- if (!ffestb_subrargs_.dim_list.ok)
- goto bad; /* :::::::::::::::::::: */
-
switch (ffelex_token_type (t))
{
case FFELEX_typeCOMMA:
- ffesta_confirmed ();
+ if (expr == NULL)
+ break;
if (!ffesta_is_inhibited ())
- {
- if (!ffestb_local_.dimension.started)
- {
- ffestc_R524_start (ffesta_first_kw == FFESTR_firstVIRTUAL);
- ffestb_local_.dimension.started = TRUE;
- }
- ffestc_R524_item (ffesta_tokens[1],
- ffestb_subrargs_.dim_list.dims);
- }
- ffelex_token_kill (ffesta_tokens[1]);
- ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
- return (ffelexHandler) ffestb_R5244_;
+ ffestc_R911_item (expr, ft);
+ return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ FFEEXPR_contextIOLIST, (ffeexprCallback) ffestb_R9112_);
case FFELEX_typeEOS:
case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
+ if (expr == NULL)
+ break;
if (!ffesta_is_inhibited ())
{
- if (!ffestb_local_.dimension.started)
- {
- ffestc_R524_start (ffesta_first_kw == FFESTR_firstVIRTUAL);
- ffestb_local_.dimension.started = TRUE;
- }
- ffestc_R524_item (ffesta_tokens[1],
- ffestb_subrargs_.dim_list.dims);
- ffestc_R524_finish ();
+ ffestc_R911_item (expr, ft);
+ ffestc_R911_finish ();
}
- ffelex_token_kill (ffesta_tokens[1]);
- ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
return (ffelexHandler) ffesta_zero (t);
default:
break;
}
-bad: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.R524.badname, t);
- if (ffestb_local_.dimension.started && !ffesta_is_inhibited ())
- ffestc_R524_finish ();
- ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
- ffelex_token_kill (ffesta_tokens[1]);
+ if (!ffesta_is_inhibited ())
+ ffestc_R911_finish ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "PRINT", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R5244_ -- "DIMENSION" ... COMMA
-
- return ffestb_R5244_; // to lexer
-
- Make sure we don't have EOS or SEMICOLON. */
-
-static ffelexHandler
-ffestb_R5244_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- if (!ffesta_is_inhibited ())
- ffestc_R524_finish ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.R524.badname, t);
- return (ffelexHandler) ffesta_zero (t);
-
- default:
- return (ffelexHandler) ffestb_R5241_ (t);
- }
-}
-
-/* ffestb_R547 -- Parse the COMMON statement
+/* ffestb_R923 -- Parse an INQUIRE statement
- return ffestb_R547; // to lexer
+ return ffestb_R923; // to lexer
- Make sure the statement has a valid form for the COMMON statement. If it
- does, implement the statement. */
+ Make sure the statement has a valid form for an INQUIRE statement.
+ If it does, implement the statement. */
ffelexHandler
-ffestb_R547 (ffelexToken t)
+ffestb_R923 (ffelexToken t)
{
- ffeTokenLength i;
- unsigned const char *p;
- ffelexToken nt;
- ffelexHandler next;
+ ffestpInquireIx ix;
switch (ffelex_token_type (ffesta_tokens[0]))
{
case FFELEX_typeNAME:
- if (ffesta_first_kw != FFESTR_firstCOMMON)
+ if (ffesta_first_kw != FFESTR_firstINQUIRE)
goto bad_0; /* :::::::::::::::::::: */
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
-
- default:
- goto bad_1; /* :::::::::::::::::::: */
-
- case FFELEX_typeNAME:
- case FFELEX_typeSLASH:
- case FFELEX_typeCONCAT:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- ffestc_R547_start ();
- ffestb_local_.common.started = TRUE;
- return (ffelexHandler) ffestb_R5471_ (t);
- }
+ break;
case FFELEX_typeNAMES:
- if (ffesta_first_kw != FFESTR_firstCOMMON)
+ if (ffesta_first_kw != FFESTR_firstINQUIRE)
goto bad_0; /* :::::::::::::::::::: */
- p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlCOMMON);
- switch (ffelex_token_type (t))
- {
- default:
- goto bad_1; /* :::::::::::::::::::: */
-
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed ();
- break;
-
- case FFELEX_typeSLASH:
- case FFELEX_typeCONCAT:
- ffesta_confirmed ();
- if (*p != '\0')
- break;
- if (!ffesta_is_inhibited ())
- ffestc_R547_start ();
- ffestb_local_.common.started = TRUE;
- return (ffelexHandler) ffestb_R5471_ (t);
-
- case FFELEX_typeOPEN_PAREN:
- break;
- }
+ if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlINQUIRE)
+ goto bad_0; /* :::::::::::::::::::: */
+ break;
- /* Here, we have at least one char after "COMMON" and t is COMMA,
- EOS/SEMICOLON, OPEN_PAREN, SLASH, or CONCAT. */
+ default:
+ goto bad_0; /* :::::::::::::::::::: */
+ }
- if (!ffesrc_is_name_init (*p))
- goto bad_i; /* :::::::::::::::::::: */
- nt = ffelex_token_name_from_names (ffesta_tokens[0], i, 0);
- if (ffelex_token_type (t) == FFELEX_typeOPEN_PAREN)
- ffestb_local_.common.started = FALSE;
- else
- {
- if (!ffesta_is_inhibited ())
- ffestc_R547_start ();
- ffestb_local_.common.started = TRUE;
- }
- next = (ffelexHandler) ffestb_R5471_ (nt);
- ffelex_token_kill (nt);
- return (ffelexHandler) (*next) (t);
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeOPEN_PAREN:
+ break;
+
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ case FFELEX_typeCOMMA:
+ case FFELEX_typeCOLONCOLON:
+ ffesta_confirmed (); /* Error, but clearly intended. */
+ goto bad_1; /* :::::::::::::::::::: */
default:
- goto bad_0; /* :::::::::::::::::::: */
+ goto bad_1; /* :::::::::::::::::::: */
}
+ for (ix = 0; ix < FFESTP_inquireix; ++ix)
+ ffestp_file.inquire.inquire_spec[ix].kw_or_val_present = FALSE;
+
+ ffestb_local_.inquire.may_be_iolength = TRUE;
+ return (ffelexHandler) ffestb_R9231_;
+
bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "COMMON", ffesta_tokens[0]);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INQUIRE", ffesta_tokens[0]);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "COMMON", t);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INQUIRE", t);
return (ffelexHandler) ffelex_swallow_tokens (t,
(ffelexHandler) ffesta_zero); /* Invalid second token. */
-
-bad_i: /* :::::::::::::::::::: */
- ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "COMMON", ffesta_tokens[0], i, t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R5471_ -- "COMMON"
+/* ffestb_R9231_ -- "INQUIRE" OPEN_PAREN
- return ffestb_R5471_; // to lexer
+ return ffestb_R9231_; // to lexer
- Handle NAME, SLASH, or CONCAT. */
+ Handle expr construct (not NAME=expr construct) here. */
static ffelexHandler
-ffestb_R5471_ (ffelexToken t)
+ffestb_R9231_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
case FFELEX_typeNAME:
- return (ffelexHandler) ffestb_R5474_ (t);
-
- case FFELEX_typeSLASH:
- return (ffelexHandler) ffestb_R5472_;
-
- case FFELEX_typeCONCAT:
- if (!ffesta_is_inhibited ())
- ffestc_R547_item_cblock (NULL);
- return (ffelexHandler) ffestb_R5474_;
+ ffesta_tokens[1] = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_R9232_;
default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "COMMON", t);
- break;
+ ffestb_local_.inquire.may_be_iolength = FALSE;
+ return (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ FFEEXPR_contextFILENUM, (ffeexprCallback) ffestb_R9233_)))
+ (t);
}
-
- if (!ffesta_is_inhibited ())
- ffestc_R547_finish ();
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R5472_ -- "COMMON" SLASH
+/* ffestb_R9232_ -- "INQUIRE" OPEN_PAREN NAME
- return ffestb_R5472_; // to lexer
+ return ffestb_R9232_; // to lexer
- Handle NAME. */
+ If EQUALS here, go to states that handle it. Else, send NAME and this
+ token thru expression handler. */
static ffelexHandler
-ffestb_R5472_ (ffelexToken t)
+ffestb_R9232_ (ffelexToken t)
{
+ ffelexHandler next;
+ ffelexToken nt;
+
switch (ffelex_token_type (t))
{
- case FFELEX_typeNAME:
- ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_R5473_;
-
- case FFELEX_typeSLASH:
- if (!ffesta_is_inhibited ())
- ffestc_R547_item_cblock (NULL);
- return (ffelexHandler) ffestb_R5474_;
+ case FFELEX_typeEQUALS:
+ nt = ffesta_tokens[1];
+ next = (ffelexHandler) ffestb_R9234_ (nt);
+ ffelex_token_kill (nt);
+ return (ffelexHandler) (*next) (t);
default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "COMMON", t);
- break;
+ ffestb_local_.inquire.may_be_iolength = FALSE;
+ next = (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ FFEEXPR_contextFILENUM, (ffeexprCallback) ffestb_R9233_)))
+ (ffesta_tokens[1]);
+ ffelex_token_kill (ffesta_tokens[1]);
+ return (ffelexHandler) (*next) (t);
}
-
- if (!ffesta_is_inhibited ())
- ffestc_R547_finish ();
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R5473_ -- "COMMON" SLASH NAME
+/* ffestb_R9233_ -- "INQUIRE" OPEN_PAREN expr
- return ffestb_R5473_; // to lexer
+ (ffestb_R9233_) // to expression handler
- Handle SLASH. */
+ Handle COMMA or CLOSE_PAREN here. */
static ffelexHandler
-ffestb_R5473_ (ffelexToken t)
+ffestb_R9233_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeSLASH:
- if (!ffesta_is_inhibited ())
- ffestc_R547_item_cblock (ffesta_tokens[1]);
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffestb_R5474_;
+ case FFELEX_typeCOMMA:
+ case FFELEX_typeCLOSE_PAREN:
+ if (expr == NULL)
+ break;
+ ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw_or_val_present
+ = TRUE;
+ ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw_present = FALSE;
+ ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].value_present = TRUE;
+ ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].value_is_label
+ = FALSE;
+ ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].value
+ = ffelex_token_use (ft);
+ ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].u.expr = expr;
+ if (ffelex_token_type (t) == FFELEX_typeCOMMA)
+ return (ffelexHandler) ffestb_R9234_;
+ return (ffelexHandler) ffestb_R9239_;
default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "COMMON", t);
break;
}
- if (!ffesta_is_inhibited ())
- ffestc_R547_finish ();
- ffelex_token_kill (ffesta_tokens[1]);
+ ffestb_subr_kill_inquire_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INQUIRE", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R5474_ -- "COMMON" [SLASH NAME SLASH] or "COMMON" CONCAT
+/* ffestb_R9234_ -- "INQUIRE" OPEN_PAREN [external-file-unit COMMA]
- return ffestb_R5474_; // to lexer
+ return ffestb_R9234_; // to lexer
- Handle NAME. */
+ Handle expr construct (not NAME=expr construct) here. */
static ffelexHandler
-ffestb_R5474_ (ffelexToken t)
+ffestb_R9234_ (ffelexToken t)
{
+ ffestrInquire kw;
+
+ ffestb_local_.inquire.label = FALSE;
+
switch (ffelex_token_type (t))
{
case FFELEX_typeNAME:
- ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_R5475_;
+ kw = ffestr_inquire (t);
+ if (kw != FFESTR_inquireIOLENGTH)
+ ffestb_local_.inquire.may_be_iolength = FALSE;
+ switch (kw)
+ {
+ case FFESTR_inquireACCESS:
+ ffestb_local_.inquire.ix = FFESTP_inquireixACCESS;
+ ffestb_local_.inquire.left = TRUE;
+ ffestb_local_.inquire.context = FFEEXPR_contextFILEDFCHAR;
+ break;
- default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "COMMON", t);
- break;
- }
+ case FFESTR_inquireACTION:
+ ffestb_local_.inquire.ix = FFESTP_inquireixACTION;
+ ffestb_local_.inquire.left = TRUE;
+ ffestb_local_.inquire.context = FFEEXPR_contextFILEDFCHAR;
+ break;
- if (!ffesta_is_inhibited ())
- ffestc_R547_finish ();
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
+ case FFESTR_inquireBLANK:
+ ffestb_local_.inquire.ix = FFESTP_inquireixBLANK;
+ ffestb_local_.inquire.left = TRUE;
+ ffestb_local_.inquire.context = FFEEXPR_contextFILEDFCHAR;
+ break;
-/* ffestb_R5475_ -- "COMMON" ... NAME
+ case FFESTR_inquireCARRIAGECONTROL:
+ ffestb_local_.inquire.ix = FFESTP_inquireixCARRIAGECONTROL;
+ ffestb_local_.inquire.left = TRUE;
+ ffestb_local_.inquire.context = FFEEXPR_contextFILECHAR;
+ break;
- return ffestb_R5475_; // to lexer
+ case FFESTR_inquireDEFAULTFILE:
+ ffestb_local_.inquire.ix = FFESTP_inquireixDEFAULTFILE;
+ ffestb_local_.inquire.left = FALSE;
+ ffestb_local_.inquire.context = FFEEXPR_contextFILECHAR;
+ break;
- Handle OPEN_PAREN. */
+ case FFESTR_inquireDELIM:
+ ffestb_local_.inquire.ix = FFESTP_inquireixDELIM;
+ ffestb_local_.inquire.left = TRUE;
+ ffestb_local_.inquire.context = FFEEXPR_contextFILEDFCHAR;
+ break;
+
+ case FFESTR_inquireDIRECT:
+ ffestb_local_.inquire.ix = FFESTP_inquireixDIRECT;
+ ffestb_local_.inquire.left = TRUE;
+ ffestb_local_.inquire.context = FFEEXPR_contextFILEDFCHAR;
+ break;
+
+ case FFESTR_inquireERR:
+ ffestb_local_.inquire.ix = FFESTP_inquireixERR;
+ ffestb_local_.inquire.label = TRUE;
+ break;
+
+ case FFESTR_inquireEXIST:
+ ffestb_local_.inquire.ix = FFESTP_inquireixEXIST;
+ ffestb_local_.inquire.left = TRUE;
+ ffestb_local_.inquire.context = FFEEXPR_contextFILELOG;
+ break;
+
+ case FFESTR_inquireFILE:
+ ffestb_local_.inquire.ix = FFESTP_inquireixFILE;
+ ffestb_local_.inquire.left = FALSE;
+ ffestb_local_.inquire.context = FFEEXPR_contextFILECHAR;
+ break;
+
+ case FFESTR_inquireFORM:
+ ffestb_local_.inquire.ix = FFESTP_inquireixFORM;
+ ffestb_local_.inquire.left = TRUE;
+ ffestb_local_.inquire.context = FFEEXPR_contextFILEDFCHAR;
+ break;
+
+ case FFESTR_inquireFORMATTED:
+ ffestb_local_.inquire.ix = FFESTP_inquireixFORMATTED;
+ ffestb_local_.inquire.left = TRUE;
+ ffestb_local_.inquire.context = FFEEXPR_contextFILEDFCHAR;
+ break;
+
+ case FFESTR_inquireIOLENGTH:
+ if (!ffestb_local_.inquire.may_be_iolength)
+ goto bad; /* :::::::::::::::::::: */
+ ffestb_local_.inquire.ix = FFESTP_inquireixIOLENGTH;
+ ffestb_local_.inquire.left = TRUE;
+ ffestb_local_.inquire.context = FFEEXPR_contextFILEINT;
+ break;
+
+ case FFESTR_inquireIOSTAT:
+ ffestb_local_.inquire.ix = FFESTP_inquireixIOSTAT;
+ ffestb_local_.inquire.left = TRUE;
+ ffestb_local_.inquire.context = FFEEXPR_contextFILEINT;
+ break;
+
+ case FFESTR_inquireKEYED:
+ ffestb_local_.inquire.ix = FFESTP_inquireixKEYED;
+ ffestb_local_.inquire.left = TRUE;
+ ffestb_local_.inquire.context = FFEEXPR_contextFILECHAR;
+ break;
+
+ case FFESTR_inquireNAME:
+ ffestb_local_.inquire.ix = FFESTP_inquireixNAME;
+ ffestb_local_.inquire.left = TRUE;
+ ffestb_local_.inquire.context = FFEEXPR_contextFILECHAR;
+ break;
+
+ case FFESTR_inquireNAMED:
+ ffestb_local_.inquire.ix = FFESTP_inquireixNAMED;
+ ffestb_local_.inquire.left = TRUE;
+ ffestb_local_.inquire.context = FFEEXPR_contextFILELOG;
+ break;
+
+ case FFESTR_inquireNEXTREC:
+ ffestb_local_.inquire.ix = FFESTP_inquireixNEXTREC;
+ ffestb_local_.inquire.left = TRUE;
+ ffestb_local_.inquire.context = FFEEXPR_contextFILEDFINT;
+ break;
-static ffelexHandler
-ffestb_R5475_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeOPEN_PAREN:
- ffestb_subrargs_.dim_list.dims = ffestt_dimlist_create ();
- ffestb_subrargs_.dim_list.handler = (ffelexHandler) ffestb_R5476_;
- ffestb_subrargs_.dim_list.pool = ffesta_output_pool;
- ffestb_subrargs_.dim_list.ctx = FFEEXPR_contextDIMLISTCOMMON;
-#ifdef FFECOM_dimensionsMAX
- ffestb_subrargs_.dim_list.ndims = 0;
-#endif
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextDIMLISTCOMMON, (ffeexprCallback) ffestb_subr_dimlist_);
+ case FFESTR_inquireNUMBER:
+ ffestb_local_.inquire.ix = FFESTP_inquireixNUMBER;
+ ffestb_local_.inquire.left = TRUE;
+ ffestb_local_.inquire.context = FFEEXPR_contextFILEINT;
+ break;
- case FFELEX_typeCOMMA:
- if (!ffesta_is_inhibited ())
- ffestc_R547_item_object (ffesta_tokens[1], NULL);
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffestb_R5477_;
+ case FFESTR_inquireOPENED:
+ ffestb_local_.inquire.ix = FFESTP_inquireixOPENED;
+ ffestb_local_.inquire.left = TRUE;
+ ffestb_local_.inquire.context = FFEEXPR_contextFILELOG;
+ break;
- case FFELEX_typeSLASH:
- case FFELEX_typeCONCAT:
- if (!ffesta_is_inhibited ())
- ffestc_R547_item_object (ffesta_tokens[1], NULL);
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffestb_R5471_ (t);
+ case FFESTR_inquireORGANIZATION:
+ ffestb_local_.inquire.ix = FFESTP_inquireixORGANIZATION;
+ ffestb_local_.inquire.left = TRUE;
+ ffestb_local_.inquire.context = FFEEXPR_contextFILECHAR;
+ break;
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- if (!ffesta_is_inhibited ())
- {
- ffestc_R547_item_object (ffesta_tokens[1], NULL);
- ffestc_R547_finish ();
- }
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffesta_zero (t);
+ case FFESTR_inquirePAD:
+ ffestb_local_.inquire.ix = FFESTP_inquireixPAD;
+ ffestb_local_.inquire.left = TRUE;
+ ffestb_local_.inquire.context = FFEEXPR_contextFILEDFCHAR;
+ break;
- default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "COMMON", t);
- break;
- }
+ case FFESTR_inquirePOSITION:
+ ffestb_local_.inquire.ix = FFESTP_inquireixPOSITION;
+ ffestb_local_.inquire.left = TRUE;
+ ffestb_local_.inquire.context = FFEEXPR_contextFILEDFCHAR;
+ break;
- if (!ffesta_is_inhibited ())
- ffestc_R547_finish ();
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
+ case FFESTR_inquireREAD:
+ ffestb_local_.inquire.ix = FFESTP_inquireixREAD;
+ ffestb_local_.inquire.left = TRUE;
+ ffestb_local_.inquire.context = FFEEXPR_contextFILEDFCHAR;
+ break;
-/* ffestb_R5476_ -- "COMMON" ... NAME OPEN_PAREN dimlist CLOSE_PAREN
+ case FFESTR_inquireREADWRITE:
+ ffestb_local_.inquire.ix = FFESTP_inquireixREADWRITE;
+ ffestb_local_.inquire.left = TRUE;
+ ffestb_local_.inquire.context = FFEEXPR_contextFILEDFCHAR;
+ break;
- return ffestb_R5476_; // to lexer
+ case FFESTR_inquireRECL:
+ ffestb_local_.inquire.ix = FFESTP_inquireixRECL;
+ ffestb_local_.inquire.left = TRUE;
+ ffestb_local_.inquire.context = FFEEXPR_contextFILEINT;
+ break;
- Handle COMMA, SLASH, CONCAT, EOS/SEMICOLON. */
+ case FFESTR_inquireRECORDTYPE:
+ ffestb_local_.inquire.ix = FFESTP_inquireixRECORDTYPE;
+ ffestb_local_.inquire.left = TRUE;
+ ffestb_local_.inquire.context = FFEEXPR_contextFILECHAR;
+ break;
-static ffelexHandler
-ffestb_R5476_ (ffelexToken t)
-{
- if (!ffestb_subrargs_.dim_list.ok)
- goto bad; /* :::::::::::::::::::: */
+ case FFESTR_inquireSEQUENTIAL:
+ ffestb_local_.inquire.ix = FFESTP_inquireixSEQUENTIAL;
+ ffestb_local_.inquire.left = TRUE;
+ ffestb_local_.inquire.context = FFEEXPR_contextFILEDFCHAR;
+ break;
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- {
- if (!ffestb_local_.common.started)
- {
- ffestc_R547_start ();
- ffestb_local_.common.started = TRUE;
- }
- ffestc_R547_item_object (ffesta_tokens[1],
- ffestb_subrargs_.dim_list.dims);
- }
- ffelex_token_kill (ffesta_tokens[1]);
- ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
- return (ffelexHandler) ffestb_R5477_;
+ case FFESTR_inquireUNFORMATTED:
+ ffestb_local_.inquire.ix = FFESTP_inquireixUNFORMATTED;
+ ffestb_local_.inquire.left = TRUE;
+ ffestb_local_.inquire.context = FFEEXPR_contextFILEDFCHAR;
+ break;
- case FFELEX_typeSLASH:
- case FFELEX_typeCONCAT:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- {
- if (!ffestb_local_.common.started)
- {
- ffestc_R547_start ();
- ffestb_local_.common.started = TRUE;
- }
- ffestc_R547_item_object (ffesta_tokens[1],
- ffestb_subrargs_.dim_list.dims);
- }
- ffelex_token_kill (ffesta_tokens[1]);
- ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
- return (ffelexHandler) ffestb_R5471_ (t);
+ case FFESTR_inquireUNIT:
+ ffestb_local_.inquire.ix = FFESTP_inquireixUNIT;
+ ffestb_local_.inquire.left = FALSE;
+ ffestb_local_.inquire.context = FFEEXPR_contextFILENUM;
+ break;
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- {
- if (!ffestb_local_.common.started)
- ffestc_R547_start ();
- ffestc_R547_item_object (ffesta_tokens[1],
- ffestb_subrargs_.dim_list.dims);
- ffestc_R547_finish ();
+ default:
+ goto bad; /* :::::::::::::::::::: */
}
- ffelex_token_kill (ffesta_tokens[1]);
- ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
- return (ffelexHandler) ffesta_zero (t);
+ if (ffestp_file.inquire.inquire_spec[ffestb_local_.inquire.ix]
+ .kw_or_val_present)
+ break; /* Can't specify a keyword twice! */
+ ffestp_file.inquire.inquire_spec[ffestb_local_.inquire.ix]
+ .kw_or_val_present = TRUE;
+ ffestp_file.inquire.inquire_spec[ffestb_local_.inquire.ix]
+ .kw_present = TRUE;
+ ffestp_file.inquire.inquire_spec[ffestb_local_.inquire.ix]
+ .value_present = FALSE;
+ ffestp_file.inquire.inquire_spec[ffestb_local_.inquire.ix].value_is_label
+ = ffestb_local_.inquire.label;
+ ffestp_file.inquire.inquire_spec[ffestb_local_.inquire.ix].kw
+ = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_R9235_;
default:
break;
}
bad: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "COMMON", t);
- if (ffestb_local_.common.started && !ffesta_is_inhibited ())
- ffestc_R547_finish ();
- ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
- ffelex_token_kill (ffesta_tokens[1]);
+ ffestb_subr_kill_inquire_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INQUIRE", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R5477_ -- "COMMON" ... COMMA
+/* ffestb_R9235_ -- "INQUIRE" OPEN_PAREN [external-file-unit COMMA] NAME
- return ffestb_R5477_; // to lexer
+ return ffestb_R9235_; // to lexer
- Make sure we don't have EOS or SEMICOLON. */
+ Make sure EQUALS here, send next token to expression handler. */
static ffelexHandler
-ffestb_R5477_ (ffelexToken t)
+ffestb_R9235_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- if (!ffesta_is_inhibited ())
- ffestc_R547_finish ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "COMMON", t);
- return (ffelexHandler) ffesta_zero (t);
-
- default:
- return (ffelexHandler) ffestb_R5471_ (t);
- }
-}
-
-/* ffestb_R624 -- Parse a NULLIFY statement
-
- return ffestb_R624; // to lexer
-
- Make sure the statement has a valid form for a NULLIFY
- statement. If it does, implement the statement.
-
- 31-May-90 JCB 2.0
- Rewrite to produce a list of expressions rather than just names; this
- eases semantic checking, putting it in expression handling where that
- kind of thing gets done anyway, and makes it easier to support more
- flexible extensions to Fortran 90 like NULLIFY(FOO%BAR). */
-
-#if FFESTR_F90
-ffelexHandler
-ffestb_R624 (ffelexToken t)
-{
- switch (ffelex_token_type (ffesta_tokens[0]))
- {
- case FFELEX_typeNAME:
- if (ffesta_first_kw != FFESTR_firstNULLIFY)
- goto bad_0; /* :::::::::::::::::::: */
- break;
-
- case FFELEX_typeNAMES:
- if (ffesta_first_kw != FFESTR_firstNULLIFY)
- goto bad_0; /* :::::::::::::::::::: */
- if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlNULLIFY)
- goto bad_0; /* :::::::::::::::::::: */
- break;
+ case FFELEX_typeEQUALS:
+ ffesta_confirmed ();
+ if (ffestb_local_.inquire.label)
+ return (ffelexHandler) ffestb_R9237_;
+ if (ffestb_local_.inquire.left)
+ return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool,
+ ffestb_local_.inquire.context,
+ (ffeexprCallback) ffestb_R9236_);
+ return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ ffestb_local_.inquire.context,
+ (ffeexprCallback) ffestb_R9236_);
default:
- goto bad_0; /* :::::::::::::::::::: */
- }
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeOPEN_PAREN:
break;
-
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- case FFELEX_typeNAME:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
-
- default:
- goto bad_1; /* :::::::::::::::::::: */
}
- ffestb_local_.R624.exprs = ffestt_exprlist_create ();
- return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool,
- FFEEXPR_contextNULLIFY,
- (ffeexprCallback) ffestb_R6241_);
-
-bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "NULLIFY", ffesta_tokens[0]);
+ ffestb_subr_kill_inquire_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INQUIRE", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-
-bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "NULLIFY", t);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero); /* Invalid second token. */
}
-/* ffestb_R6241_ -- "NULLIFY" OPEN_PAREN expr
-
- return ffestb_R6241_; // to lexer
+/* ffestb_R9236_ -- "INQUIRE" OPEN_PAREN ... NAME EQUALS expr
- Make sure the statement has a valid form for a NULLIFY statement. If it
- does, implement the statement.
+ (ffestb_R9236_) // to expression handler
- 31-May-90 JCB 2.0
- Rewrite to produce a list of expressions rather than just names; this
- eases semantic checking, putting it in expression handling where that
- kind of thing gets done anyway, and makes it easier to support more
- flexible extensions to Fortran 90 like NULLIFY(FOO%BAR). */
+ Handle COMMA or CLOSE_PAREN here. */
static ffelexHandler
-ffestb_R6241_ (ffelexToken ft, ffebld expr, ffelexToken t)
+ffestb_R9236_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeCLOSE_PAREN:
- if (expr == NULL)
- break;
- ffestt_exprlist_append (ffestb_local_.R624.exprs, expr,
- ffelex_token_use (t));
- return (ffelexHandler) ffestb_R6242_;
-
case FFELEX_typeCOMMA:
+ if (ffestb_local_.inquire.ix == FFESTP_inquireixIOLENGTH)
+ break; /* IOLENGTH=expr must be followed by
+ CLOSE_PAREN. */
+ /* Fall through. */
+ case FFELEX_typeCLOSE_PAREN:
if (expr == NULL)
break;
- ffestt_exprlist_append (ffestb_local_.R624.exprs, expr,
- ffelex_token_use (t));
- return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool,
- FFEEXPR_contextNULLIFY,
- (ffeexprCallback) ffestb_R6241_);
+ ffestp_file.inquire.inquire_spec[ffestb_local_.inquire.ix].value_present
+ = TRUE;
+ ffestp_file.inquire.inquire_spec[ffestb_local_.inquire.ix].value
+ = ffelex_token_use (ft);
+ ffestp_file.inquire.inquire_spec[ffestb_local_.inquire.ix].u.expr = expr;
+ if (ffelex_token_type (t) == FFELEX_typeCOMMA)
+ return (ffelexHandler) ffestb_R9234_;
+ if (ffestb_local_.inquire.ix == FFESTP_inquireixIOLENGTH)
+ return (ffelexHandler) ffestb_R92310_;
+ return (ffelexHandler) ffestb_R9239_;
default:
break;
}
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "NULLIFY", t);
- ffestt_exprlist_kill (ffestb_local_.R624.exprs);
+ ffestb_subr_kill_inquire_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INQUIRE", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R6242_ -- "NULLIFY" OPEN_PAREN expr-list CLOSE_PAREN
+/* ffestb_R9237_ -- "INQUIRE" OPEN_PAREN ... NAME EQUALS
- return ffestb_R6242_; // to lexer
+ return ffestb_R9237_; // to lexer
- Make sure the statement has a valid form for a NULLIFY statement. If it
- does, implement the statement. */
+ Handle NUMBER for label here. */
static ffelexHandler
-ffestb_R6242_ (ffelexToken t)
+ffestb_R9237_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- ffestc_R624 (ffestb_local_.R624.exprs);
- ffestt_exprlist_kill (ffestb_local_.R624.exprs);
- return (ffelexHandler) ffesta_zero (t);
+ case FFELEX_typeNUMBER:
+ ffestp_file.inquire.inquire_spec[ffestb_local_.inquire.ix].value_present
+ = TRUE;
+ ffestp_file.inquire.inquire_spec[ffestb_local_.inquire.ix].value
+ = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_R9238_;
default:
break;
}
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "NULLIFY", t);
- ffestt_exprlist_kill (ffestb_local_.R624.exprs);
+ ffestb_subr_kill_inquire_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INQUIRE", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-#endif
-/* ffestb_R1229 -- Parse a STMTFUNCTION statement
+/* ffestb_R9238_ -- "INQUIRE" OPEN_PAREN ... NAME EQUALS NUMBER
- return ffestb_R1229; // to lexer
+ return ffestb_R9238_; // to lexer
- Make sure the statement has a valid form for a STMTFUNCTION
- statement. If it does, implement the statement. */
+ Handle COMMA or CLOSE_PAREN here. */
-ffelexHandler
-ffestb_R1229 (ffelexToken t)
+static ffelexHandler
+ffestb_R9238_ (ffelexToken t)
{
- switch (ffelex_token_type (ffesta_tokens[0]))
+ switch (ffelex_token_type (t))
{
- case FFELEX_typeNAME:
- case FFELEX_typeNAMES:
- break;
+ case FFELEX_typeCOMMA:
+ return (ffelexHandler) ffestb_R9234_;
+
+ case FFELEX_typeCLOSE_PAREN:
+ return (ffelexHandler) ffestb_R9239_;
default:
- goto bad_0; /* :::::::::::::::::::: */
+ break;
}
+ ffestb_subr_kill_inquire_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INQUIRE", t);
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+}
+
+/* ffestb_R9239_ -- "INQUIRE" OPEN_PAREN ... CLOSE_PAREN
+
+ return ffestb_R9239_; // to lexer
+
+ Handle EOS or SEMICOLON here. */
+
+static ffelexHandler
+ffestb_R9239_ (ffelexToken t)
+{
switch (ffelex_token_type (t))
{
- case FFELEX_typeOPEN_PAREN:
- break;
-
case FFELEX_typeEOS:
case FFELEX_typeSEMICOLON:
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- case FFELEX_typeNAME:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
+ ffesta_confirmed ();
+ if (!ffesta_is_inhibited ())
+ ffestc_R923A ();
+ ffestb_subr_kill_inquire_ ();
+ return (ffelexHandler) ffesta_zero (t);
default:
- goto bad_1; /* :::::::::::::::::::: */
+ break;
}
- ffestb_subrargs_.name_list.args = ffestt_tokenlist_create ();
- ffestb_subrargs_.name_list.handler = (ffelexHandler) ffestb_R12291_;
- ffestb_subrargs_.name_list.is_subr = FALSE; /* No "*" items in list! */
- ffestb_subrargs_.name_list.names = TRUE; /* In case "IF(FOO)CALL
- FOO...". */
- return (ffelexHandler) ffestb_subr_name_list_;
-
-bad_0: /* :::::::::::::::::::: */
-bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_2t (FFEBAD_UNREC_STMT, ffesta_tokens[0], t);
+ ffestb_subr_kill_inquire_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INQUIRE", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R12291_ -- "STMTFUNCTION" OPEN_PAREN dummy-name-list CLOSE_PAREN
+/* ffestb_R92310_ -- "INQUIRE(IOLENGTH=expr)"
- return ffestb_R12291_; // to lexer
+ return ffestb_R92310_; // to lexer
- Make sure the statement has a valid form for a STMTFUNCTION statement. If
- it does, implement the statement. */
+ Make sure EOS or SEMICOLON not here; begin R923B processing and expect
+ output IO list. */
static ffelexHandler
-ffestb_R12291_ (ffelexToken t)
+ffestb_R92310_ (ffelexToken t)
{
- ffelex_set_names (FALSE);
-
- if (!ffestb_subrargs_.name_list.ok)
- goto bad; /* :::::::::::::::::::: */
-
switch (ffelex_token_type (t))
{
- case FFELEX_typeEQUALS:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- ffestc_R1229_start (ffesta_tokens[0],
- ffestb_subrargs_.name_list.args,
- ffestb_subrargs_.name_list.close_paren);
- ffelex_token_kill (ffestb_subrargs_.name_list.close_paren);
- ffestt_tokenlist_kill (ffestb_subrargs_.name_list.args);
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextSFUNCDEF, (ffeexprCallback) ffestb_R12292_);
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ break;
default:
- break;
+ ffesta_confirmed ();
+ if (!ffesta_is_inhibited ())
+ ffestc_R923B_start ();
+ ffestb_subr_kill_inquire_ ();
+ return (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ FFEEXPR_contextIOLIST, (ffeexprCallback) ffestb_R92311_)))
+ (t);
}
-bad: /* :::::::::::::::::::: */
- ffesta_ffebad_2t (FFEBAD_UNREC_STMT, ffesta_tokens[0], t);
- ffelex_token_kill (ffestb_subrargs_.name_list.close_paren);
- ffestt_tokenlist_kill (ffestb_subrargs_.name_list.args);
+ ffestb_subr_kill_inquire_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INQUIRE", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_R12292_ -- "STMTFUNCTION" OPEN_PAREN dummy-name-list CLOSE_PAREN
- EQUALS expr
+/* ffestb_R92311_ -- "INQUIRE(IOLENGTH=expr)" expr
- (ffestb_R12292_) // to expression handler
+ (ffestb_R92311_) // to expression handler
- Make sure the statement has a valid form for a STMTFUNCTION statement. If
- it does, implement the statement. */
+ Handle COMMA or EOS/SEMICOLON here. */
static ffelexHandler
-ffestb_R12292_ (ffelexToken ft, ffebld expr, ffelexToken t)
+ffestb_R92311_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
- if (expr == NULL)
- goto bad; /* :::::::::::::::::::: */
-
switch (ffelex_token_type (t))
{
+ case FFELEX_typeCOMMA:
+ if (expr == NULL)
+ break;
+ if (!ffesta_is_inhibited ())
+ ffestc_R923B_item (expr, ft);
+ return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ FFEEXPR_contextIOLIST, (ffeexprCallback) ffestb_R92311_);
+
case FFELEX_typeEOS:
case FFELEX_typeSEMICOLON:
+ if (expr == NULL)
+ break;
if (!ffesta_is_inhibited ())
- ffestc_R1229_finish (expr, ft);
+ {
+ ffestc_R923B_item (expr, ft);
+ ffestc_R923B_finish ();
+ }
return (ffelexHandler) ffesta_zero (t);
default:
break;
}
-bad: /* :::::::::::::::::::: */
- ffestc_R1229_finish (NULL, NULL);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "statement-function-definition", t);
+ if (!ffesta_is_inhibited ())
+ ffestc_R923B_finish ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INQUIRE", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_decl_chartype -- Parse the CHARACTER statement
+/* ffestb_V020 -- Parse the TYPE statement
- return ffestb_decl_chartype; // to lexer
+ return ffestb_V020; // to lexer
- Make sure the statement has a valid form for the CHARACTER statement. If
- it does, implement the statement. */
+ Make sure the statement has a valid form for the TYPE
+ statement. If it does, implement the statement. */
ffelexHandler
-ffestb_decl_chartype (ffelexToken t)
+ffestb_V020 (ffelexToken t)
{
ffeTokenLength i;
- unsigned const char *p;
-
- ffestb_local_.decl.type = FFESTP_typeCHARACTER;
- ffestb_local_.decl.recursive = NULL;
- ffestb_local_.decl.parameter = FALSE; /* No PARAMETER attribute seen. */
- ffestb_local_.decl.coloncolon = FALSE; /* No COLONCOLON seen. */
+ const char *p;
+ ffelexHandler next;
+ ffestpTypeIx ix;
switch (ffelex_token_type (ffesta_tokens[0]))
{
case FFELEX_typeNAME:
- if (ffesta_first_kw != FFESTR_firstCHRCTR)
+ if (ffesta_first_kw != FFESTR_firstTYPE)
goto bad_0; /* :::::::::::::::::::: */
switch (ffelex_token_type (t))
{
+ case FFELEX_typeCOLONCOLON:
case FFELEX_typeEOS:
case FFELEX_typeSEMICOLON:
ffesta_confirmed (); /* Error, but clearly intended. */
goto bad_1; /* :::::::::::::::::::: */
- default:
+ case FFELEX_typeEQUALS:
+ case FFELEX_typePOINTS:
+ case FFELEX_typeCOLON:
+ case FFELEX_typeCOMMA: /* Because "TYPE,PUBLIC::A" is ambiguous with
+ '90. */
goto bad_1; /* :::::::::::::::::::: */
- case FFELEX_typeCOMMA:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0],
- NULL, NULL, NULL, NULL);
- return (ffelexHandler) ffestb_decl_attrs_;
-
- case FFELEX_typeCOLONCOLON:
- ffestb_local_.decl.coloncolon = TRUE;
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0],
- NULL, NULL, NULL, NULL);
- return (ffelexHandler) ffestb_decl_ents_;
-
- case FFELEX_typeASTERISK:
+ case FFELEX_typeNUMBER:
ffesta_confirmed ();
- ffestb_local_.decl.handler = (ffelexHandler) ffestb_decl_chartype1_;
- ffestb_local_.decl.badname = "TYPEDECL";
- return (ffelexHandler) ffestb_decl_starlen_;
-
- case FFELEX_typeOPEN_PAREN:
- ffestb_local_.decl.kind = NULL;
- ffestb_local_.decl.kindt = NULL;
- ffestb_local_.decl.len = NULL;
- ffestb_local_.decl.lent = NULL;
- ffestb_local_.decl.handler = (ffelexHandler) ffestb_decl_attrsp_;
- ffestb_local_.decl.badname = "_TYPEDECL";
- return (ffelexHandler) ffestb_decl_typeparams_;
+ break;
- case FFELEX_typeNAME:
- ffesta_confirmed ();
- ffestb_local_.decl.kind = NULL;
- ffestb_local_.decl.kindt = NULL;
- ffestb_local_.decl.len = NULL;
- ffestb_local_.decl.lent = NULL;
- return (ffelexHandler) ffestb_decl_entsp_ (t);
+ case FFELEX_typeNAME: /* Because TYPE A is ambiguous with '90. */
+ default:
+ break;
}
+ for (ix = 0; ix < FFESTP_typeix; ++ix)
+ ffestp_file.type.type_spec[ix].kw_or_val_present = FALSE;
+ return (ffelexHandler) (*((ffelexHandler)
+ ffeexpr_rhs (ffesta_output_pool,
+ FFEEXPR_contextFILEFORMATNML, (ffeexprCallback) ffestb_V0201_)))
+ (t);
+
case FFELEX_typeNAMES:
- if (ffesta_first_kw != FFESTR_firstCHRCTR)
+ if (ffesta_first_kw != FFESTR_firstTYPE)
goto bad_0; /* :::::::::::::::::::: */
- p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlCHRCTR);
switch (ffelex_token_type (t))
{
- default:
- goto bad_1; /* :::::::::::::::::::: */
-
case FFELEX_typeEOS:
case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- break;
-
case FFELEX_typeCOMMA:
- ffesta_confirmed ();
- if (*p != '\0')
+ if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlTYPE)
break;
- if (!ffesta_is_inhibited ())
- ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0],
- NULL, NULL, NULL, NULL);
- return (ffelexHandler) ffestb_decl_attrs_;
+ goto bad_1; /* :::::::::::::::::::: */
case FFELEX_typeCOLONCOLON:
- ffestb_local_.decl.coloncolon = TRUE;
- ffesta_confirmed ();
- if (*p != '\0')
- goto bad_i; /* :::::::::::::::::::: */
- if (!ffesta_is_inhibited ())
- ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0],
- NULL, NULL, NULL, NULL);
- return (ffelexHandler) ffestb_decl_ents_;
+ ffesta_confirmed (); /* Error, but clearly intended. */
+ goto bad_1; /* :::::::::::::::::::: */
- case FFELEX_typeASTERISK:
- ffesta_confirmed ();
- if (*p != '\0')
- break;
- ffestb_local_.decl.handler = (ffelexHandler) ffestb_decl_chartype1_;
- ffestb_local_.decl.badname = "TYPEDECL";
- return (ffelexHandler) ffestb_decl_starlen_;
+ case FFELEX_typeOPEN_PAREN:
+ if (ffelex_token_length (ffesta_tokens[0]) == FFESTR_firstlTYPE)
+ break; /* Else might be assignment/stmtfuncdef. */
+ goto bad_1; /* :::::::::::::::::::: */
- case FFELEX_typeSLASH:
- ffesta_confirmed ();
- if (*p != '\0')
- break;
+ case FFELEX_typeEQUALS:
+ case FFELEX_typePOINTS:
+ case FFELEX_typeCOLON:
goto bad_1; /* :::::::::::::::::::: */
- case FFELEX_typeOPEN_PAREN:
- if (*p != '\0')
- break;
- ffestb_local_.decl.kind = NULL;
- ffestb_local_.decl.kindt = NULL;
- ffestb_local_.decl.len = NULL;
- ffestb_local_.decl.lent = NULL;
- ffestb_local_.decl.handler = (ffelexHandler) ffestb_decl_attrsp_;
- ffestb_local_.decl.badname = "TYPEDECL";
- return (ffelexHandler) ffestb_decl_typeparams_;
+ default:
+ break;
}
- if (!ffesrc_is_name_init (*p))
- goto bad_i; /* :::::::::::::::::::: */
- ffestb_local_.decl.kind = NULL;
- ffestb_local_.decl.kindt = NULL;
- ffestb_local_.decl.len = NULL;
- ffestb_local_.decl.lent = NULL;
- ffesta_tokens[1] = ffelex_token_names_from_names (ffesta_tokens[0], i, 0);
- return (ffelexHandler) ffestb_decl_entsp_2_ (t);
+ p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlTYPE);
+ if (ISDIGIT (*p))
+ ffesta_confirmed (); /* Else might be '90 TYPE statement. */
+ for (ix = 0; ix < FFESTP_typeix; ++ix)
+ ffestp_file.type.type_spec[ix].kw_or_val_present = FALSE;
+ next = (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ FFEEXPR_contextFILEFORMATNML, (ffeexprCallback) ffestb_V0201_);
+ next = (ffelexHandler) ffelex_splice_tokens (next, ffesta_tokens[0],
+ FFESTR_firstlTYPE);
+ if (next == NULL)
+ return (ffelexHandler) ffelex_swallow_tokens (t,
+ (ffelexHandler) ffesta_zero);
+ return (ffelexHandler) (*next) (t);
default:
goto bad_0; /* :::::::::::::::::::: */
}
bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", ffesta_tokens[0]);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "TYPE I/O", ffesta_tokens[0]);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "TYPE I/O", t);
return (ffelexHandler) ffelex_swallow_tokens (t,
(ffelexHandler) ffesta_zero); /* Invalid second token. */
-
-bad_i: /* :::::::::::::::::::: */
- ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "type-declaration", ffesta_tokens[0], i, t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_decl_chartype1_ -- "CHARACTER" ASTERISK char-length
+/* ffestb_V0201_ -- "TYPE" expr
- return ffestb_decl_chartype1_; // to lexer
+ (ffestb_V0201_) // to expression handler
- Handle COMMA, COLONCOLON, or anything else. */
+ Make sure the next token is a COMMA or EOS/SEMICOLON. */
static ffelexHandler
-ffestb_decl_chartype1_ (ffelexToken t)
+ffestb_V0201_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
- ffelex_set_names (FALSE);
+ bool comma = TRUE;
switch (ffelex_token_type (t))
{
- case FFELEX_typeCOLONCOLON:
- ffestb_local_.decl.coloncolon = TRUE;
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ if (!ffe_is_vxt () && (expr != NULL)
+ && (ffebld_op (expr) == FFEBLD_opSYMTER))
+ break;
+ comma = FALSE;
/* Fall through. */
case FFELEX_typeCOMMA:
+ if (!ffe_is_vxt () && comma && (expr != NULL)
+ && (ffebld_op (expr) == FFEBLD_opPAREN)
+ && (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER))
+ break;
ffesta_confirmed ();
+ ffestp_file.type.type_spec[FFESTP_typeixFORMAT].kw_or_val_present
+ = TRUE;
+ ffestp_file.type.type_spec[FFESTP_typeixFORMAT].kw_present = FALSE;
+ ffestp_file.type.type_spec[FFESTP_typeixFORMAT].value_present = TRUE;
+ ffestp_file.type.type_spec[FFESTP_typeixFORMAT].value_is_label
+ = (expr == NULL);
+ ffestp_file.type.type_spec[FFESTP_typeixFORMAT].value
+ = ffelex_token_use (ft);
+ ffestp_file.type.type_spec[FFESTP_typeixFORMAT].u.expr = expr;
if (!ffesta_is_inhibited ())
- ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0],
- NULL, NULL, ffestb_local_.decl.len, ffestb_local_.decl.lent);
- if (ffestb_local_.decl.lent != NULL)
- ffelex_token_kill (ffestb_local_.decl.lent);
- return (ffelexHandler) ffestb_decl_ents_;
+ ffestc_V020_start ();
+ ffestb_subr_kill_type_ ();
+ if (ffelex_token_type (t) == FFELEX_typeCOMMA)
+ return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ FFEEXPR_contextIOLIST, (ffeexprCallback) ffestb_V0202_);
+ if (!ffesta_is_inhibited ())
+ ffestc_V020_finish ();
+ return (ffelexHandler) ffesta_zero (t);
default:
- return (ffelexHandler) ffestb_decl_entsp_ (t);
+ break;
}
+
+ ffestb_subr_kill_type_ ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "TYPE I/O", t);
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_decl_dbltype -- Parse the DOUBLEPRECISION/DOUBLECOMPLEX statement
+/* ffestb_V0202_ -- "TYPE" expr COMMA expr
- return ffestb_decl_dbltype; // to lexer
+ (ffestb_V0202_) // to expression handler
- Make sure the statement has a valid form for the DOUBLEPRECISION/
- DOUBLECOMPLEX statement. If it does, implement the statement. */
+ Handle COMMA or EOS/SEMICOLON here. */
-ffelexHandler
-ffestb_decl_dbltype (ffelexToken t)
+static ffelexHandler
+ffestb_V0202_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
- ffeTokenLength i;
- unsigned const char *p;
-
- ffestb_local_.decl.type = ffestb_args.decl.type;
- ffestb_local_.decl.recursive = NULL;
- ffestb_local_.decl.parameter = FALSE; /* No PARAMETER attribute seen. */
- ffestb_local_.decl.coloncolon = FALSE; /* No COLONCOLON seen. */
-
- switch (ffelex_token_type (ffesta_tokens[0]))
+ switch (ffelex_token_type (t))
{
- case FFELEX_typeNAME:
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
-
- default:
- goto bad_1; /* :::::::::::::::::::: */
-
- case FFELEX_typeCOMMA:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0],
- NULL, NULL, NULL, NULL);
- return (ffelexHandler) ffestb_decl_attrs_;
-
- case FFELEX_typeCOLONCOLON:
- ffestb_local_.decl.coloncolon = TRUE;
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0],
- NULL, NULL, NULL, NULL);
- return (ffelexHandler) ffestb_decl_ents_;
-
- case FFELEX_typeNAME:
- ffesta_confirmed ();
- ffestb_local_.decl.kind = NULL;
- ffestb_local_.decl.kindt = NULL;
- ffestb_local_.decl.len = NULL;
- ffestb_local_.decl.lent = NULL;
- return (ffelexHandler) ffestb_decl_entsp_ (t);
- }
+ case FFELEX_typeCOMMA:
+ if (expr == NULL)
+ break;
+ if (!ffesta_is_inhibited ())
+ ffestc_V020_item (expr, ft);
+ return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ FFEEXPR_contextIOLIST, (ffeexprCallback) ffestb_V0202_);
- case FFELEX_typeNAMES:
- p = ffelex_token_text (ffesta_tokens[0]) + (i = ffestb_args.decl.len);
- switch (ffelex_token_type (t))
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ if (expr == NULL)
+ break;
+ if (!ffesta_is_inhibited ())
{
- default:
- goto bad_1; /* :::::::::::::::::::: */
-
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- break;
-
- case FFELEX_typeCOMMA:
- ffesta_confirmed ();
- if (*p != '\0')
- break;
- if (!ffesta_is_inhibited ())
- ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0],
- NULL, NULL, NULL, NULL);
- return (ffelexHandler) ffestb_decl_attrs_;
-
- case FFELEX_typeCOLONCOLON:
- ffestb_local_.decl.coloncolon = TRUE;
- ffesta_confirmed ();
- if (*p != '\0')
- goto bad_i; /* :::::::::::::::::::: */
- if (!ffesta_is_inhibited ())
- ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0],
- NULL, NULL, NULL, NULL);
- return (ffelexHandler) ffestb_decl_ents_;
-
- case FFELEX_typeSLASH:
- ffesta_confirmed ();
- if (*p != '\0')
- break;
- goto bad_1; /* :::::::::::::::::::: */
-
- case FFELEX_typeOPEN_PAREN:
- if (*p != '\0')
- break;
- goto bad_1; /* :::::::::::::::::::: */
- }
- if (!ffesrc_is_name_init (*p))
- goto bad_i; /* :::::::::::::::::::: */
- ffestb_local_.decl.kind = NULL;
- ffestb_local_.decl.kindt = NULL;
- ffestb_local_.decl.len = NULL;
- ffestb_local_.decl.lent = NULL;
- ffesta_tokens[1] = ffelex_token_names_from_names (ffesta_tokens[0], i, 0);
- return (ffelexHandler) ffestb_decl_entsp_2_ (t);
+ ffestc_V020_item (expr, ft);
+ ffestc_V020_finish ();
+ }
+ return (ffelexHandler) ffesta_zero (t);
default:
- goto bad_0; /* :::::::::::::::::::: */
+ break;
}
-bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", ffesta_tokens[0]);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-
-bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero); /* Invalid second token. */
-
-bad_i: /* :::::::::::::::::::: */
- ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "type-declaration", ffesta_tokens[0], i, t);
+ if (!ffesta_is_inhibited ())
+ ffestc_V020_finish ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "TYPE I/O", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_decl_double -- Parse the DOUBLE PRECISION/DOUBLE COMPLEX statement
+/* ffestb_dummy -- Parse an ENTRY/FUNCTION/SUBROUTINE statement
- return ffestb_decl_double; // to lexer
+ return ffestb_dummy; // to lexer
- Make sure the statement has a valid form for the DOUBLE PRECISION/
- DOUBLE COMPLEX statement. If it does, implement the statement. */
+ Make sure the statement has a valid form for an ENTRY/FUNCTION/SUBROUTINE
+ statement. If it does, implement the statement. */
ffelexHandler
-ffestb_decl_double (ffelexToken t)
+ffestb_dummy (ffelexToken t)
{
- ffestb_local_.decl.recursive = NULL;
- ffestb_local_.decl.parameter = FALSE; /* No PARAMETER attribute seen. */
- ffestb_local_.decl.coloncolon = FALSE; /* No COLONCOLON seen. */
+ ffeTokenLength i;
+ unsigned const char *p;
switch (ffelex_token_type (ffesta_tokens[0]))
{
case FFELEX_typeNAME:
- if (ffesta_first_kw != FFESTR_firstDBL)
- goto bad_0; /* :::::::::::::::::::: */
switch (ffelex_token_type (t))
{
case FFELEX_typeEOS:
goto bad_1; /* :::::::::::::::::::: */
case FFELEX_typeNAME:
- ffesta_confirmed ();
- switch (ffestr_second (t))
- {
- case FFESTR_secondCOMPLEX:
- ffestb_local_.decl.type = FFESTP_typeDBLCMPLX;
- break;
+ break;
+ }
- case FFESTR_secondPRECISION:
- ffestb_local_.decl.type = FFESTP_typeDBLPRCSN;
- break;
+ ffesta_confirmed ();
+ ffesta_tokens[1] = ffelex_token_use (t);
+ ffestb_local_.decl.recursive = NULL;
+ ffestb_local_.dummy.badname = ffestb_args.dummy.badname;
+ ffestb_local_.dummy.is_subr = ffestb_args.dummy.is_subr;
+ ffestb_local_.dummy.first_kw = ffesta_first_kw;
+ return (ffelexHandler) ffestb_dummy1_;
- default:
- goto bad_1; /* :::::::::::::::::::: */
- }
- ffestb_local_.decl.kind = NULL;
- ffestb_local_.decl.kindt = NULL;
- ffestb_local_.decl.len = NULL;
- ffestb_local_.decl.lent = NULL;
- return (ffelexHandler) ffestb_decl_attrsp_;
+ case FFELEX_typeNAMES:
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeCOMMA:
+ case FFELEX_typeCOLONCOLON:
+ ffesta_confirmed (); /* Error, but clearly intended. */
+ goto bad_1; /* :::::::::::::::::::: */
+
+ default:
+ goto bad_1; /* :::::::::::::::::::: */
+
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ ffesta_confirmed ();
+ break;
+
+ case FFELEX_typeOPEN_PAREN:
+ break;
}
+ p = ffelex_token_text (ffesta_tokens[0]) + (i = ffestb_args.dummy.len);
+ if (!ffesrc_is_name_init (*p))
+ goto bad_i; /* :::::::::::::::::::: */
+ ffesta_tokens[1]
+ = ffelex_token_name_from_names (ffesta_tokens[0], i, 0);
+ ffestb_local_.decl.recursive = NULL;
+ ffestb_local_.dummy.badname = ffestb_args.dummy.badname;
+ ffestb_local_.dummy.is_subr = ffestb_args.dummy.is_subr;
+ ffestb_local_.dummy.first_kw = ffesta_first_kw;
+ return (ffelexHandler) ffestb_dummy1_ (t);
default:
goto bad_0; /* :::::::::::::::::::: */
}
bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", ffesta_tokens[0]);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.dummy.badname, ffesta_tokens[0]);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.dummy.badname, t);
return (ffelexHandler) ffelex_swallow_tokens (t,
(ffelexHandler) ffesta_zero); /* Invalid second token. */
+
+bad_i: /* :::::::::::::::::::: */
+ ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, ffestb_args.dummy.badname, ffesta_tokens[0], i, t);
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_decl_gentype -- Parse the INTEGER/REAL/COMPLEX/LOGICAL statement
+/* ffestb_dummy1_ -- "ENTRY/FUNCTION/SUBROUTINE" NAME
- return ffestb_decl_gentype; // to lexer
+ return ffestb_dummy1_; // to lexer
- Make sure the statement has a valid form for the INTEGER/REAL/COMPLEX/
- LOGICAL statement. If it does, implement the statement. */
+ Make sure the next token is an EOS, SEMICOLON, or OPEN_PAREN. In the
+ former case, just implement a null arg list, else get the arg list and
+ then implement. */
-ffelexHandler
-ffestb_decl_gentype (ffelexToken t)
+static ffelexHandler
+ffestb_dummy1_ (ffelexToken t)
{
- ffeTokenLength i;
- unsigned const char *p;
-
- ffestb_local_.decl.type = ffestb_args.decl.type;
- ffestb_local_.decl.recursive = NULL;
- ffestb_local_.decl.parameter = FALSE; /* No PARAMETER attribute seen. */
- ffestb_local_.decl.coloncolon = FALSE; /* No COLONCOLON seen. */
-
- switch (ffelex_token_type (ffesta_tokens[0]))
+ switch (ffelex_token_type (t))
{
- case FFELEX_typeNAME:
- switch (ffelex_token_type (t))
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ if (ffestb_local_.dummy.first_kw == FFESTR_firstFUNCTION)
{
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
-
- default:
- goto bad_1; /* :::::::::::::::::::: */
-
- case FFELEX_typeCOMMA:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0],
- NULL, NULL, NULL, NULL);
- return (ffelexHandler) ffestb_decl_attrs_;
+ ffesta_confirmed (); /* Later, not if typename w/o RECURSIVE. */
+ break; /* Produce an error message, need that open
+ paren. */
+ }
+ ffesta_confirmed ();
+ if (!ffesta_is_inhibited ())
+ { /* Pretend as though we got a truly NULL
+ list. */
+ ffestb_subrargs_.name_list.args = NULL;
+ ffestb_subrargs_.name_list.ok = TRUE;
+ ffestb_subrargs_.name_list.close_paren = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_dummy2_ (t);
+ }
+ if (ffestb_local_.decl.recursive != NULL)
+ ffelex_token_kill (ffestb_local_.decl.recursive);
+ ffelex_token_kill (ffesta_tokens[1]);
+ return (ffelexHandler) ffesta_zero (t);
- case FFELEX_typeCOLONCOLON:
- ffestb_local_.decl.coloncolon = TRUE;
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0],
- NULL, NULL, NULL, NULL);
- return (ffelexHandler) ffestb_decl_ents_;
+ case FFELEX_typeOPEN_PAREN:
+ ffestb_subrargs_.name_list.args = ffestt_tokenlist_create ();
+ ffestb_subrargs_.name_list.handler = (ffelexHandler) ffestb_dummy2_;
+ ffestb_subrargs_.name_list.is_subr = ffestb_local_.dummy.is_subr;
+ ffestb_subrargs_.name_list.names = FALSE;
+ return (ffelexHandler) ffestb_subr_name_list_;
- case FFELEX_typeASTERISK:
- ffesta_confirmed ();
- ffestb_local_.decl.handler = (ffelexHandler) ffestb_decl_attrsp_;
- ffestb_local_.decl.badname = "TYPEDECL";
- return (ffelexHandler) ffestb_decl_starkind_;
+ default:
+ break;
+ }
- case FFELEX_typeOPEN_PAREN:
- ffestb_local_.decl.handler = (ffelexHandler) ffestb_decl_attrsp_;
- ffestb_local_.decl.badname = "TYPEDECL";
- return (ffelexHandler) ffestb_decl_kindparam_;
+ if (ffestb_local_.decl.recursive != NULL)
+ ffelex_token_kill (ffestb_local_.decl.recursive);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_local_.dummy.badname, t);
+ ffelex_token_kill (ffesta_tokens[1]);
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+}
- case FFELEX_typeNAME:
- ffesta_confirmed ();
- ffestb_local_.decl.kind = NULL;
- ffestb_local_.decl.kindt = NULL;
- ffestb_local_.decl.len = NULL;
- ffestb_local_.decl.lent = NULL;
- return (ffelexHandler) ffestb_decl_entsp_ (t);
- }
+/* ffestb_dummy2_ -- <dummy-keyword> NAME OPEN_PAREN arg-list CLOSE_PAREN
- case FFELEX_typeNAMES:
- p = ffelex_token_text (ffesta_tokens[0]) + (i = ffestb_args.decl.len);
- switch (ffelex_token_type (t))
- {
- default:
- goto bad_1; /* :::::::::::::::::::: */
+ return ffestb_dummy2_; // to lexer
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- break;
+ Make sure the statement has a valid form for a dummy-def statement. If it
+ does, implement the statement. */
- case FFELEX_typeCOMMA:
- ffesta_confirmed ();
- if (*p != '\0')
- break;
- if (!ffesta_is_inhibited ())
- ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0],
- NULL, NULL, NULL, NULL);
- return (ffelexHandler) ffestb_decl_attrs_;
+static ffelexHandler
+ffestb_dummy2_ (ffelexToken t)
+{
+ if (!ffestb_subrargs_.name_list.ok)
+ goto bad; /* :::::::::::::::::::: */
- case FFELEX_typeCOLONCOLON:
- ffestb_local_.decl.coloncolon = TRUE;
- ffesta_confirmed ();
- if (*p != '\0')
- goto bad_i; /* :::::::::::::::::::: */
- if (!ffesta_is_inhibited ())
- ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0],
- NULL, NULL, NULL, NULL);
- return (ffelexHandler) ffestb_decl_ents_;
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ ffesta_confirmed ();
+ if (!ffesta_is_inhibited ())
+ {
+ switch (ffestb_local_.dummy.first_kw)
+ {
+ case FFESTR_firstFUNCTION:
+ ffestc_R1219 (ffesta_tokens[1], ffestb_subrargs_.name_list.args,
+ ffestb_subrargs_.name_list.close_paren, FFESTP_typeNone,
+ NULL, NULL, NULL, NULL, ffestb_local_.decl.recursive, NULL);
+ break;
- case FFELEX_typeSLASH:
- ffesta_confirmed ();
- if (*p != '\0')
- break;
- goto bad_1; /* :::::::::::::::::::: */
+ case FFESTR_firstSUBROUTINE:
+ ffestc_R1223 (ffesta_tokens[1], ffestb_subrargs_.name_list.args,
+ ffestb_subrargs_.name_list.close_paren,
+ ffestb_local_.decl.recursive);
+ break;
- case FFELEX_typeASTERISK:
- ffesta_confirmed ();
- if (*p != '\0')
- break;
- ffestb_local_.decl.handler = (ffelexHandler) ffestb_decl_attrsp_;
- ffestb_local_.decl.badname = "TYPEDECL";
- return (ffelexHandler) ffestb_decl_starkind_;
+ case FFESTR_firstENTRY:
+ ffestc_R1226 (ffesta_tokens[1], ffestb_subrargs_.name_list.args,
+ ffestb_subrargs_.name_list.close_paren);
+ break;
- case FFELEX_typeOPEN_PAREN:
- if (*p != '\0')
- break;
- ffestb_local_.decl.handler = (ffelexHandler) ffestb_decl_attrsp_;
- ffestb_local_.decl.badname = "TYPEDECL";
- return (ffelexHandler) ffestb_decl_kindparam_;
+ default:
+ assert (FALSE);
+ }
}
- if (!ffesrc_is_name_init (*p))
- goto bad_i; /* :::::::::::::::::::: */
+ ffelex_token_kill (ffesta_tokens[1]);
+ if (ffestb_local_.decl.recursive != NULL)
+ ffelex_token_kill (ffestb_local_.decl.recursive);
+ ffelex_token_kill (ffestb_subrargs_.name_list.close_paren);
+ if (ffestb_subrargs_.name_list.args != NULL)
+ ffestt_tokenlist_kill (ffestb_subrargs_.name_list.args);
+ return (ffelexHandler) ffesta_zero (t);
+
+ case FFELEX_typeNAME:
+ ffesta_confirmed ();
+ if ((ffestb_local_.dummy.first_kw != FFESTR_firstFUNCTION)
+ || (ffestr_other (t) != FFESTR_otherRESULT))
+ break;
+ ffestb_local_.decl.type = FFESTP_typeNone;
ffestb_local_.decl.kind = NULL;
ffestb_local_.decl.kindt = NULL;
ffestb_local_.decl.len = NULL;
ffestb_local_.decl.lent = NULL;
- ffesta_tokens[1] = ffelex_token_names_from_names (ffesta_tokens[0], i, 0);
- return (ffelexHandler) ffestb_decl_entsp_2_ (t);
+ return (ffelexHandler) ffestb_decl_funcname_6_;
default:
- goto bad_0; /* :::::::::::::::::::: */
+ break;
}
-bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", ffesta_tokens[0]);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-
-bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero); /* Invalid second token. */
-
-bad_i: /* :::::::::::::::::::: */
- ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "type-declaration", ffesta_tokens[0], i, t);
+bad: /* :::::::::::::::::::: */
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_local_.dummy.badname, t);
+ ffelex_token_kill (ffesta_tokens[1]);
+ if (ffestb_local_.decl.recursive != NULL)
+ ffelex_token_kill (ffestb_local_.decl.recursive);
+ ffelex_token_kill (ffestb_subrargs_.name_list.close_paren);
+ if (ffestb_subrargs_.name_list.args != NULL)
+ ffestt_tokenlist_kill (ffestb_subrargs_.name_list.args);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_decl_recursive -- Parse the RECURSIVE FUNCTION statement
+/* ffestb_R524 -- Parse the DIMENSION statement
- return ffestb_decl_recursive; // to lexer
+ return ffestb_R524; // to lexer
- Make sure the statement has a valid form for the RECURSIVE FUNCTION
- statement. If it does, implement the statement. */
+ Make sure the statement has a valid form for the DIMENSION statement. If
+ it does, implement the statement. */
-#if FFESTR_F90
ffelexHandler
-ffestb_decl_recursive (ffelexToken t)
+ffestb_R524 (ffelexToken t)
{
ffeTokenLength i;
- const char *p;
+ unsigned const char *p;
ffelexToken nt;
- ffelexToken ot;
ffelexHandler next;
- bool needfunc;
switch (ffelex_token_type (ffesta_tokens[0]))
{
case FFELEX_typeNAME:
- if (ffesta_first_kw != FFESTR_firstRECURSIVE)
- goto bad_0; /* :::::::::::::::::::: */
switch (ffelex_token_type (t))
{
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
case FFELEX_typeCOMMA:
case FFELEX_typeCOLONCOLON:
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
ffesta_confirmed (); /* Error, but clearly intended. */
goto bad_1; /* :::::::::::::::::::: */
goto bad_1; /* :::::::::::::::::::: */
case FFELEX_typeNAME:
- break;
- }
- ffesta_confirmed ();
- ffestb_local_.decl.recursive = ffelex_token_use (ffesta_tokens[0]);
- switch (ffesta_second_kw)
- {
- case FFESTR_secondINTEGER:
- ffestb_local_.decl.type = FFESTP_typeINTEGER;
- return (ffelexHandler) ffestb_decl_recursive1_;
-
- case FFESTR_secondBYTE:
- ffestb_local_.decl.type = FFESTP_typeBYTE;
- return (ffelexHandler) ffestb_decl_recursive1_;
-
- case FFESTR_secondWORD:
- ffestb_local_.decl.type = FFESTP_typeWORD;
- return (ffelexHandler) ffestb_decl_recursive1_;
-
- case FFESTR_secondREAL:
- ffestb_local_.decl.type = FFESTP_typeREAL;
- return (ffelexHandler) ffestb_decl_recursive1_;
-
- case FFESTR_secondCOMPLEX:
- ffestb_local_.decl.type = FFESTP_typeCOMPLEX;
- return (ffelexHandler) ffestb_decl_recursive1_;
-
- case FFESTR_secondLOGICAL:
- ffestb_local_.decl.type = FFESTP_typeLOGICAL;
- return (ffelexHandler) ffestb_decl_recursive1_;
-
- case FFESTR_secondCHARACTER:
- ffestb_local_.decl.type = FFESTP_typeCHARACTER;
- return (ffelexHandler) ffestb_decl_recursive1_;
-
- case FFESTR_secondDOUBLE:
- return (ffelexHandler) ffestb_decl_recursive2_;
-
- case FFESTR_secondDOUBLEPRECISION:
- ffestb_local_.decl.type = FFESTP_typeDBLPRCSN;
- ffestb_local_.decl.kind = NULL;
- ffestb_local_.decl.kindt = NULL;
- ffestb_local_.decl.len = NULL;
- ffestb_local_.decl.lent = NULL;
- return (ffelexHandler) ffestb_decl_func_;
-
- case FFESTR_secondDOUBLECOMPLEX:
- ffestb_local_.decl.type = FFESTP_typeDBLCMPLX;
- ffestb_local_.decl.kind = NULL;
- ffestb_local_.decl.kindt = NULL;
- ffestb_local_.decl.len = NULL;
- ffestb_local_.decl.lent = NULL;
- return (ffelexHandler) ffestb_decl_func_;
-
- case FFESTR_secondTYPE:
- ffestb_local_.decl.type = FFESTP_typeTYPE;
- return (ffelexHandler) ffestb_decl_recursive3_;
-
- case FFESTR_secondFUNCTION:
- ffestb_local_.dummy.first_kw = FFESTR_firstFUNCTION;
- ffestb_local_.dummy.badname = "FUNCTION";
- ffestb_local_.dummy.is_subr = FALSE;
- return (ffelexHandler) ffestb_decl_recursive4_;
-
- case FFESTR_secondSUBROUTINE:
- ffestb_local_.dummy.first_kw = FFESTR_firstSUBROUTINE;
- ffestb_local_.dummy.badname = "SUBROUTINE";
- ffestb_local_.dummy.is_subr = TRUE;
- return (ffelexHandler) ffestb_decl_recursive4_;
-
- default:
- ffelex_token_kill (ffestb_local_.decl.recursive);
- goto bad_1; /* :::::::::::::::::::: */
+ ffesta_confirmed ();
+ if (!ffesta_is_inhibited ())
+ ffestc_R524_start (ffesta_first_kw == FFESTR_firstVIRTUAL);
+ ffestb_local_.dimension.started = TRUE;
+ return (ffelexHandler) ffestb_R5241_ (t);
}
case FFELEX_typeNAMES:
- if (ffesta_first_kw != FFESTR_firstRECURSIVE)
- goto bad_0; /* :::::::::::::::::::: */
+ p = ffelex_token_text (ffesta_tokens[0]) + (i = ffestb_args.R524.len);
switch (ffelex_token_type (t))
{
+ default:
+ goto bad_1; /* :::::::::::::::::::: */
+
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
case FFELEX_typeCOMMA:
case FFELEX_typeCOLONCOLON:
- case FFELEX_typeASTERISK:
- case FFELEX_typeSEMICOLON:
- case FFELEX_typeEOS:
ffesta_confirmed ();
- break;
+ goto bad_1; /* :::::::::::::::::::: */
- default:
+ case FFELEX_typeOPEN_PAREN:
break;
}
- p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlRECURSIVE);
- if (!ffesrc_is_name_init (*p))
- goto bad_0; /* :::::::::::::::::::: */
- ffestb_local_.decl.recursive
- = ffelex_token_name_from_names (ffesta_tokens[0], 0,
- FFESTR_firstlRECURSIVE);
- nt = ffelex_token_names_from_names (ffesta_tokens[0],
- FFESTR_firstlRECURSIVE, 0);
- switch (ffestr_first (nt))
- {
- case FFESTR_firstINTGR:
- p = ffelex_token_text (nt) + (i = FFESTR_firstlINTGR);
- ffestb_local_.decl.type = FFESTP_typeINTEGER;
- needfunc = FALSE;
- goto typefunc; /* :::::::::::::::::::: */
-
- case FFESTR_firstBYTE:
- p = ffelex_token_text (nt) + (i = FFESTR_firstlBYTE);
- ffestb_local_.decl.type = FFESTP_typeBYTE;
- needfunc = FALSE;
- goto typefunc; /* :::::::::::::::::::: */
-
- case FFESTR_firstWORD:
- p = ffelex_token_text (nt) + (i = FFESTR_firstlWORD);
- ffestb_local_.decl.type = FFESTP_typeWORD;
- needfunc = FALSE;
- goto typefunc; /* :::::::::::::::::::: */
-
- case FFESTR_firstREAL:
- p = ffelex_token_text (nt) + (i = FFESTR_firstlREAL);
- ffestb_local_.decl.type = FFESTP_typeREAL;
- needfunc = FALSE;
- goto typefunc; /* :::::::::::::::::::: */
-
- case FFESTR_firstCMPLX:
- p = ffelex_token_text (nt) + (i = FFESTR_firstlCMPLX);
- ffestb_local_.decl.type = FFESTP_typeCOMPLEX;
- needfunc = FALSE;
- goto typefunc; /* :::::::::::::::::::: */
-
- case FFESTR_firstLGCL:
- p = ffelex_token_text (nt) + (i = FFESTR_firstlLGCL);
- ffestb_local_.decl.type = FFESTP_typeLOGICAL;
- needfunc = FALSE;
- goto typefunc; /* :::::::::::::::::::: */
-
- case FFESTR_firstCHRCTR:
- p = ffelex_token_text (nt) + (i = FFESTR_firstlCHRCTR);
- ffestb_local_.decl.type = FFESTP_typeCHARACTER;
- needfunc = FALSE;
- goto typefunc; /* :::::::::::::::::::: */
-
- case FFESTR_firstDBLPRCSN:
- p = ffelex_token_text (nt) + (i = FFESTR_firstlDBLPRCSN);
- ffestb_local_.decl.type = FFESTP_typeDBLPRCSN;
- needfunc = TRUE;
- goto typefunc; /* :::::::::::::::::::: */
-
- case FFESTR_firstDBLCMPLX:
- p = ffelex_token_text (nt) + (i = FFESTR_firstlDBLCMPLX);
- ffestb_local_.decl.type = FFESTP_typeDBLCMPLX;
- needfunc = TRUE;
- goto typefunc; /* :::::::::::::::::::: */
-
- case FFESTR_firstTYPE:
- p = ffelex_token_text (nt) + (i = FFESTR_firstlTYPE);
- ffestb_local_.decl.type = FFESTP_typeTYPE;
- next = (ffelexHandler) ffestb_decl_recursive3_;
- break;
-
- case FFESTR_firstFUNCTION:
- p = ffelex_token_text (nt) + (i = FFESTR_firstlFUNCTION);
- ffestb_local_.dummy.first_kw = FFESTR_firstFUNCTION;
- ffestb_local_.dummy.badname = "FUNCTION";
- ffestb_local_.dummy.is_subr = FALSE;
- next = (ffelexHandler) ffestb_decl_recursive4_;
- break;
- case FFESTR_firstSUBROUTINE:
- p = ffelex_token_text (nt) + (i = FFESTR_firstlSUBROUTINE);
- ffestb_local_.dummy.first_kw = FFESTR_firstSUBROUTINE;
- ffestb_local_.dummy.badname = "SUBROUTINE";
- ffestb_local_.dummy.is_subr = TRUE;
- next = (ffelexHandler) ffestb_decl_recursive4_;
- break;
+ /* Here, we have at least one char after "DIMENSION" and t is
+ OPEN_PAREN. */
- default:
- ffelex_token_kill (ffestb_local_.decl.recursive);
- ffelex_token_kill (nt);
- goto bad_1; /* :::::::::::::::::::: */
- }
- if (*p == '\0')
- {
- ffelex_token_kill (nt);
- return (ffelexHandler) (*next) (t);
- }
if (!ffesrc_is_name_init (*p))
goto bad_i; /* :::::::::::::::::::: */
- ot = ffelex_token_name_from_names (nt, i, 0);
+ nt = ffelex_token_name_from_names (ffesta_tokens[0], i, 0);
+ ffestb_local_.dimension.started = FALSE;
+ next = (ffelexHandler) ffestb_R5241_ (nt);
ffelex_token_kill (nt);
- next = (ffelexHandler) (*next) (ot);
- ffelex_token_kill (ot);
return (ffelexHandler) (*next) (t);
default:
goto bad_0; /* :::::::::::::::::::: */
}
-typefunc: /* :::::::::::::::::::: */
- if (*p == '\0')
- {
- ffelex_token_kill (nt);
- if (needfunc) /* DOUBLE PRECISION or DOUBLE COMPLEX? */
- {
- ffelex_token_kill (ffestb_local_.decl.recursive);
- goto bad_1; /* :::::::::::::::::::: */
- }
- return (ffelexHandler) ffestb_decl_recursive1_ (t);
- }
- if (!ffesrc_is_name_init (*p))
- goto bad_i; /* :::::::::::::::::::: */
- ot = ffelex_token_names_from_names (nt, i, 0);
- ffelex_token_kill (nt);
- if (ffestr_first (ot) != FFESTR_firstFUNCTION)
- goto bad_o; /* :::::::::::::::::::: */
- p = ffelex_token_text (ot) + (i = FFESTR_firstlFUNCTION);
- if (!ffesrc_is_name_init (*p))
- goto bad_i; /* :::::::::::::::::::: */
- ffesta_tokens[1] = ffelex_token_name_from_names (ot, i, 0);
- ffelex_token_kill (ot);
- ffestb_local_.decl.kind = NULL;
- ffestb_local_.decl.kindt = NULL;
- ffestb_local_.decl.len = NULL;
- ffestb_local_.decl.lent = NULL;
- return (ffelexHandler) ffestb_decl_funcname_1_ (t);
-
bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", ffesta_tokens[0]);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.R524.badname, ffesta_tokens[0]);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.R524.badname, t);
return (ffelexHandler) ffelex_swallow_tokens (t,
(ffelexHandler) ffesta_zero); /* Invalid second token. */
bad_i: /* :::::::::::::::::::: */
- ffelex_token_kill (ffestb_local_.decl.recursive);
- ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "type-declaration", nt, i, t);
- ffelex_token_kill (nt);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-
-bad_o: /* :::::::::::::::::::: */
- ffelex_token_kill (ffestb_local_.decl.recursive);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", ot);
- ffelex_token_kill (ot);
+ ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, ffestb_args.R524.badname, ffesta_tokens[0], i, t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_decl_recursive1_ -- "RECURSIVE" generic-type
+/* ffestb_R5241_ -- "DIMENSION"
- return ffestb_decl_recursive1_; // to lexer
+ return ffestb_R5241_; // to lexer
- Handle ASTERISK, OPEN_PAREN, or NAME. */
+ Handle NAME. */
static ffelexHandler
-ffestb_decl_recursive1_ (ffelexToken t)
+ffestb_R5241_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeASTERISK:
- ffesta_confirmed ();
- ffestb_local_.decl.handler = (ffelexHandler) ffestb_decl_func_;
- ffestb_local_.decl.badname = "TYPEFUNC";
- if (ffestb_local_.decl.type == FFESTP_typeCHARACTER)
- return (ffelexHandler) ffestb_decl_starlen_;
- return (ffelexHandler) ffestb_decl_starkind_;
-
- case FFELEX_typeOPEN_PAREN:
- ffestb_local_.decl.handler = (ffelexHandler) ffestb_decl_func_;
- ffestb_local_.decl.badname = "TYPEFUNC";
- if (ffestb_local_.decl.type == FFESTP_typeCHARACTER)
- {
- ffestb_local_.decl.kind = NULL;
- ffestb_local_.decl.kindt = NULL;
- ffestb_local_.decl.len = NULL;
- ffestb_local_.decl.lent = NULL;
- return (ffelexHandler) ffestb_decl_typeparams_;
- }
- return (ffelexHandler) ffestb_decl_kindparam_;
-
case FFELEX_typeNAME:
- ffestb_local_.decl.kind = NULL;
- ffestb_local_.decl.kindt = NULL;
- ffestb_local_.decl.len = NULL;
- ffestb_local_.decl.lent = NULL;
- return (ffelexHandler) ffestb_decl_func_ (t);
+ ffesta_tokens[1] = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_R5242_;
default:
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.R524.badname, t);
break;
}
- if (ffestb_local_.decl.recursive != NULL)
- ffelex_token_kill (ffestb_local_.decl.recursive);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t);
+ if (!ffesta_is_inhibited ())
+ ffestc_R524_finish ();
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_decl_recursive2_ -- "RECURSIVE" "DOUBLE"
+/* ffestb_R5242_ -- "DIMENSION" ... NAME
- return ffestb_decl_recursive2_; // to lexer
+ return ffestb_R5242_; // to lexer
- Handle NAME. */
+ Handle OPEN_PAREN. */
static ffelexHandler
-ffestb_decl_recursive2_ (ffelexToken t)
+ffestb_R5242_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeNAME:
- switch (ffestr_second (t))
- {
- case FFESTR_secondPRECISION:
- ffestb_local_.decl.type = FFESTP_typeDBLPRCSN;
- break;
-
- case FFESTR_secondCOMPLEX:
- ffestb_local_.decl.type = FFESTP_typeDBLCMPLX;
- break;
-
- default:
- goto bad; /* :::::::::::::::::::: */
- }
- ffestb_local_.decl.kind = NULL;
- ffestb_local_.decl.kindt = NULL;
- ffestb_local_.decl.len = NULL;
- ffestb_local_.decl.lent = NULL;
- return (ffelexHandler) ffestb_decl_func_;
+ case FFELEX_typeOPEN_PAREN:
+ ffestb_subrargs_.dim_list.dims = ffestt_dimlist_create ();
+ ffestb_subrargs_.dim_list.handler = (ffelexHandler) ffestb_R5243_;
+ ffestb_subrargs_.dim_list.pool = ffesta_output_pool;
+ ffestb_subrargs_.dim_list.ctx = ffesta_is_entry_valid
+ ? FFEEXPR_contextDIMLIST : FFEEXPR_contextDIMLISTCOMMON;
+#ifdef FFECOM_dimensionsMAX
+ ffestb_subrargs_.dim_list.ndims = 0;
+#endif
+ return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ ffestb_subrargs_.dim_list.ctx,
+ (ffeexprCallback) ffestb_subr_dimlist_);
default:
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.R524.badname, t);
break;
}
-bad: /* :::::::::::::::::::: */
- if (ffestb_local_.decl.recursive != NULL)
- ffelex_token_kill (ffestb_local_.decl.recursive);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t);
+ if (!ffesta_is_inhibited ())
+ ffestc_R524_finish ();
+ ffelex_token_kill (ffesta_tokens[1]);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_decl_recursive3_ -- "RECURSIVE" "TYPE"
+/* ffestb_R5243_ -- "DIMENSION" ... NAME OPEN_PAREN dimlist CLOSE_PAREN
- return ffestb_decl_recursive3_; // to lexer
+ return ffestb_R5243_; // to lexer
- Handle OPEN_PAREN. */
+ Handle COMMA or EOS/SEMICOLON. */
static ffelexHandler
-ffestb_decl_recursive3_ (ffelexToken t)
+ffestb_R5243_ (ffelexToken t)
{
+ if (!ffestb_subrargs_.dim_list.ok)
+ goto bad; /* :::::::::::::::::::: */
+
switch (ffelex_token_type (t))
{
- case FFELEX_typeOPEN_PAREN:
- ffestb_local_.decl.handler = (ffelexHandler) ffestb_decl_func_;
- ffestb_local_.decl.badname = "TYPEFUNC";
- return (ffelexHandler) ffestb_decl_typetype1_;
+ case FFELEX_typeCOMMA:
+ ffesta_confirmed ();
+ if (!ffesta_is_inhibited ())
+ {
+ if (!ffestb_local_.dimension.started)
+ {
+ ffestc_R524_start (ffesta_first_kw == FFESTR_firstVIRTUAL);
+ ffestb_local_.dimension.started = TRUE;
+ }
+ ffestc_R524_item (ffesta_tokens[1],
+ ffestb_subrargs_.dim_list.dims);
+ }
+ ffelex_token_kill (ffesta_tokens[1]);
+ ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
+ return (ffelexHandler) ffestb_R5244_;
+
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ ffesta_confirmed ();
+ if (!ffesta_is_inhibited ())
+ {
+ if (!ffestb_local_.dimension.started)
+ {
+ ffestc_R524_start (ffesta_first_kw == FFESTR_firstVIRTUAL);
+ ffestb_local_.dimension.started = TRUE;
+ }
+ ffestc_R524_item (ffesta_tokens[1],
+ ffestb_subrargs_.dim_list.dims);
+ ffestc_R524_finish ();
+ }
+ ffelex_token_kill (ffesta_tokens[1]);
+ ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
+ return (ffelexHandler) ffesta_zero (t);
default:
break;
}
- if (ffestb_local_.decl.recursive != NULL)
- ffelex_token_kill (ffestb_local_.decl.recursive);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t);
+bad: /* :::::::::::::::::::: */
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.R524.badname, t);
+ if (ffestb_local_.dimension.started && !ffesta_is_inhibited ())
+ ffestc_R524_finish ();
+ ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
+ ffelex_token_kill (ffesta_tokens[1]);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_decl_recursive4_ -- "RECURSIVE" "FUNCTION/SUBROUTINE"
+/* ffestb_R5244_ -- "DIMENSION" ... COMMA
- return ffestb_decl_recursive4_; // to lexer
+ return ffestb_R5244_; // to lexer
- Handle OPEN_PAREN. */
+ Make sure we don't have EOS or SEMICOLON. */
static ffelexHandler
-ffestb_decl_recursive4_ (ffelexToken t)
+ffestb_R5244_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeNAME:
- ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_dummy1_;
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ if (!ffesta_is_inhibited ())
+ ffestc_R524_finish ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.R524.badname, t);
+ return (ffelexHandler) ffesta_zero (t);
default:
- break;
+ return (ffelexHandler) ffestb_R5241_ (t);
}
-
- if (ffestb_local_.decl.recursive != NULL)
- ffelex_token_kill (ffestb_local_.decl.recursive);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-#endif
-/* ffestb_decl_typetype -- Parse the R426/R501/R1219 TYPE statement
+/* ffestb_R547 -- Parse the COMMON statement
- return ffestb_decl_typetype; // to lexer
+ return ffestb_R547; // to lexer
- Make sure the statement has a valid form for the TYPE statement. If it
+ Make sure the statement has a valid form for the COMMON statement. If it
does, implement the statement. */
-#if FFESTR_F90
ffelexHandler
-ffestb_decl_typetype (ffelexToken t)
+ffestb_R547 (ffelexToken t)
{
+ ffeTokenLength i;
+ unsigned const char *p;
+ ffelexToken nt;
+ ffelexHandler next;
+
switch (ffelex_token_type (ffesta_tokens[0]))
{
case FFELEX_typeNAME:
- if (ffesta_first_kw != FFESTR_firstTYPE)
+ if (ffesta_first_kw != FFESTR_firstCOMMON)
goto bad_0; /* :::::::::::::::::::: */
- break;
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeCOMMA:
+ case FFELEX_typeCOLONCOLON:
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ ffesta_confirmed (); /* Error, but clearly intended. */
+ goto bad_1; /* :::::::::::::::::::: */
+
+ default:
+ goto bad_1; /* :::::::::::::::::::: */
+
+ case FFELEX_typeNAME:
+ case FFELEX_typeSLASH:
+ case FFELEX_typeCONCAT:
+ ffesta_confirmed ();
+ if (!ffesta_is_inhibited ())
+ ffestc_R547_start ();
+ ffestb_local_.common.started = TRUE;
+ return (ffelexHandler) ffestb_R5471_ (t);
+ }
case FFELEX_typeNAMES:
- if (ffesta_first_kw != FFESTR_firstTYPE)
- goto bad_0; /* :::::::::::::::::::: */
- if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlTYPE)
+ if (ffesta_first_kw != FFESTR_firstCOMMON)
goto bad_0; /* :::::::::::::::::::: */
- break;
+ p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlCOMMON);
+ switch (ffelex_token_type (t))
+ {
+ default:
+ goto bad_1; /* :::::::::::::::::::: */
- default:
- goto bad_0; /* :::::::::::::::::::: */
- }
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ case FFELEX_typeCOMMA:
+ case FFELEX_typeCOLONCOLON:
+ ffesta_confirmed ();
+ break;
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeOPEN_PAREN:
- break;
+ case FFELEX_typeSLASH:
+ case FFELEX_typeCONCAT:
+ ffesta_confirmed ();
+ if (*p != '\0')
+ break;
+ if (!ffesta_is_inhibited ())
+ ffestc_R547_start ();
+ ffestb_local_.common.started = TRUE;
+ return (ffelexHandler) ffestb_R5471_ (t);
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- case FFELEX_typeCOLONCOLON:/* Not COMMA: R424 "TYPE,PUBLIC::A". */
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
+ case FFELEX_typeOPEN_PAREN:
+ break;
+ }
- default:
- goto bad_1; /* :::::::::::::::::::: */
- }
+ /* Here, we have at least one char after "COMMON" and t is COMMA,
+ EOS/SEMICOLON, OPEN_PAREN, SLASH, or CONCAT. */
- ffestb_local_.decl.recursive = NULL;
- ffestb_local_.decl.parameter = FALSE; /* No PARAMETER attribute seen. */
- ffestb_local_.decl.coloncolon = FALSE; /* No COLONCOLON seen. */
+ if (!ffesrc_is_name_init (*p))
+ goto bad_i; /* :::::::::::::::::::: */
+ nt = ffelex_token_name_from_names (ffesta_tokens[0], i, 0);
+ if (ffelex_token_type (t) == FFELEX_typeOPEN_PAREN)
+ ffestb_local_.common.started = FALSE;
+ else
+ {
+ if (!ffesta_is_inhibited ())
+ ffestc_R547_start ();
+ ffestb_local_.common.started = TRUE;
+ }
+ next = (ffelexHandler) ffestb_R5471_ (nt);
+ ffelex_token_kill (nt);
+ return (ffelexHandler) (*next) (t);
- ffestb_local_.decl.handler = (ffelexHandler) ffestb_decl_attrsp_;
- ffestb_local_.decl.badname = "type-declaration";
- return (ffelexHandler) ffestb_decl_typetype1_;
+ default:
+ goto bad_0; /* :::::::::::::::::::: */
+ }
bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", ffesta_tokens[0]);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "COMMON", ffesta_tokens[0]);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "COMMON", t);
return (ffelexHandler) ffelex_swallow_tokens (t,
(ffelexHandler) ffesta_zero); /* Invalid second token. */
+
+bad_i: /* :::::::::::::::::::: */
+ ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "COMMON", ffesta_tokens[0], i, t);
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-#endif
-/* ffestb_decl_attrs_ -- "type" [type parameters] COMMA
+/* ffestb_R5471_ -- "COMMON"
- return ffestb_decl_attrs_; // to lexer
+ return ffestb_R5471_; // to lexer
- Handle NAME of an attribute. */
+ Handle NAME, SLASH, or CONCAT. */
static ffelexHandler
-ffestb_decl_attrs_ (ffelexToken t)
+ffestb_R5471_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
case FFELEX_typeNAME:
- switch (ffestr_first (t))
- {
-#if FFESTR_F90
- case FFESTR_firstALLOCATABLE:
- if (!ffesta_is_inhibited ())
- ffestc_decl_attrib (FFESTP_attribALLOCATABLE, t,
- FFESTR_otherNone, NULL);
- return (ffelexHandler) ffestb_decl_attrs_7_;
-#endif
+ return (ffelexHandler) ffestb_R5474_ (t);
- case FFESTR_firstDIMENSION:
- ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_decl_attrs_1_;
+ case FFELEX_typeSLASH:
+ return (ffelexHandler) ffestb_R5472_;
- case FFESTR_firstEXTERNAL:
- if (!ffesta_is_inhibited ())
- ffestc_decl_attrib (FFESTP_attribEXTERNAL, t,
- FFESTR_otherNone, NULL);
- return (ffelexHandler) ffestb_decl_attrs_7_;
+ case FFELEX_typeCONCAT:
+ if (!ffesta_is_inhibited ())
+ ffestc_R547_item_cblock (NULL);
+ return (ffelexHandler) ffestb_R5474_;
+
+ default:
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "COMMON", t);
+ break;
+ }
+
+ if (!ffesta_is_inhibited ())
+ ffestc_R547_finish ();
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+}
+
+/* ffestb_R5472_ -- "COMMON" SLASH
+
+ return ffestb_R5472_; // to lexer
+
+ Handle NAME. */
+
+static ffelexHandler
+ffestb_R5472_ (ffelexToken t)
+{
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeNAME:
+ ffesta_tokens[1] = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_R5473_;
+
+ case FFELEX_typeSLASH:
+ if (!ffesta_is_inhibited ())
+ ffestc_R547_item_cblock (NULL);
+ return (ffelexHandler) ffestb_R5474_;
+
+ default:
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "COMMON", t);
+ break;
+ }
-#if FFESTR_F90
- case FFESTR_firstINTENT:
- ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_decl_attrs_3_;
-#endif
+ if (!ffesta_is_inhibited ())
+ ffestc_R547_finish ();
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+}
- case FFESTR_firstINTRINSIC:
- if (!ffesta_is_inhibited ())
- ffestc_decl_attrib (FFESTP_attribINTRINSIC, t,
- FFESTR_otherNone, NULL);
- return (ffelexHandler) ffestb_decl_attrs_7_;
+/* ffestb_R5473_ -- "COMMON" SLASH NAME
-#if FFESTR_F90
- case FFESTR_firstOPTIONAL:
- if (!ffesta_is_inhibited ())
- ffestc_decl_attrib (FFESTP_attribOPTIONAL, t,
- FFESTR_otherNone, NULL);
- return (ffelexHandler) ffestb_decl_attrs_7_;
-#endif
+ return ffestb_R5473_; // to lexer
- case FFESTR_firstPARAMETER:
- ffestb_local_.decl.parameter = TRUE;
- if (!ffesta_is_inhibited ())
- ffestc_decl_attrib (FFESTP_attribPARAMETER, t,
- FFESTR_otherNone, NULL);
- return (ffelexHandler) ffestb_decl_attrs_7_;
+ Handle SLASH. */
-#if FFESTR_F90
- case FFESTR_firstPOINTER:
- if (!ffesta_is_inhibited ())
- ffestc_decl_attrib (FFESTP_attribPOINTER, t,
- FFESTR_otherNone, NULL);
- return (ffelexHandler) ffestb_decl_attrs_7_;
-#endif
+static ffelexHandler
+ffestb_R5473_ (ffelexToken t)
+{
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeSLASH:
+ if (!ffesta_is_inhibited ())
+ ffestc_R547_item_cblock (ffesta_tokens[1]);
+ ffelex_token_kill (ffesta_tokens[1]);
+ return (ffelexHandler) ffestb_R5474_;
-#if FFESTR_F90
- case FFESTR_firstPRIVATE:
- if (!ffesta_is_inhibited ())
- ffestc_decl_attrib (FFESTP_attribPRIVATE, t,
- FFESTR_otherNone, NULL);
- return (ffelexHandler) ffestb_decl_attrs_7_;
+ default:
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "COMMON", t);
+ break;
+ }
- case FFESTR_firstPUBLIC:
- if (!ffesta_is_inhibited ())
- ffestc_decl_attrib (FFESTP_attribPUBLIC, t,
- FFESTR_otherNone, NULL);
- return (ffelexHandler) ffestb_decl_attrs_7_;
-#endif
+ if (!ffesta_is_inhibited ())
+ ffestc_R547_finish ();
+ ffelex_token_kill (ffesta_tokens[1]);
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+}
- case FFESTR_firstSAVE:
- if (!ffesta_is_inhibited ())
- ffestc_decl_attrib (FFESTP_attribSAVE, t,
- FFESTR_otherNone, NULL);
- return (ffelexHandler) ffestb_decl_attrs_7_;
+/* ffestb_R5474_ -- "COMMON" [SLASH NAME SLASH] or "COMMON" CONCAT
-#if FFESTR_F90
- case FFESTR_firstTARGET:
- if (!ffesta_is_inhibited ())
- ffestc_decl_attrib (FFESTP_attribTARGET, t,
- FFESTR_otherNone, NULL);
- return (ffelexHandler) ffestb_decl_attrs_7_;
-#endif
+ return ffestb_R5474_; // to lexer
- default:
- ffesta_ffebad_1t (FFEBAD_INVALID_TYPEDECL_ATTR, t);
- return (ffelexHandler) ffestb_decl_attrs_7_;
- }
- break;
+ Handle NAME. */
+
+static ffelexHandler
+ffestb_R5474_ (ffelexToken t)
+{
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeNAME:
+ ffesta_tokens[1] = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_R5475_;
default:
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "COMMON", t);
break;
}
if (!ffesta_is_inhibited ())
- ffestc_decl_finish ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t);
+ ffestc_R547_finish ();
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_decl_attrs_1_ -- "type" [type parameters] ",DIMENSION"
+/* ffestb_R5475_ -- "COMMON" ... NAME
- return ffestb_decl_attrs_1_; // to lexer
+ return ffestb_R5475_; // to lexer
Handle OPEN_PAREN. */
static ffelexHandler
-ffestb_decl_attrs_1_ (ffelexToken t)
+ffestb_R5475_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
case FFELEX_typeOPEN_PAREN:
ffestb_subrargs_.dim_list.dims = ffestt_dimlist_create ();
- ffestb_subrargs_.dim_list.handler = (ffelexHandler) ffestb_decl_attrs_2_;
- ffestb_subrargs_.dim_list.pool = ffesta_scratch_pool;
- ffestb_subrargs_.dim_list.ctx = ffesta_is_entry_valid
- ? FFEEXPR_contextDIMLIST : FFEEXPR_contextDIMLISTCOMMON;
+ ffestb_subrargs_.dim_list.handler = (ffelexHandler) ffestb_R5476_;
+ ffestb_subrargs_.dim_list.pool = ffesta_output_pool;
+ ffestb_subrargs_.dim_list.ctx = FFEEXPR_contextDIMLISTCOMMON;
#ifdef FFECOM_dimensionsMAX
ffestb_subrargs_.dim_list.ndims = 0;
#endif
- return (ffelexHandler) ffeexpr_rhs (ffesta_scratch_pool,
- ffestb_subrargs_.dim_list.ctx,
- (ffeexprCallback) ffestb_subr_dimlist_);
+ return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ FFEEXPR_contextDIMLISTCOMMON, (ffeexprCallback) ffestb_subr_dimlist_);
case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- ffesta_ffebad_1t (FFEBAD_INVALID_TYPEDECL_ATTR, ffesta_tokens[1]);
+ if (!ffesta_is_inhibited ())
+ ffestc_R547_item_object (ffesta_tokens[1], NULL);
ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffestb_decl_attrs_7_ (t);
+ return (ffelexHandler) ffestb_R5477_;
+
+ case FFELEX_typeSLASH:
+ case FFELEX_typeCONCAT:
+ if (!ffesta_is_inhibited ())
+ ffestc_R547_item_object (ffesta_tokens[1], NULL);
+ ffelex_token_kill (ffesta_tokens[1]);
+ return (ffelexHandler) ffestb_R5471_ (t);
+
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ if (!ffesta_is_inhibited ())
+ {
+ ffestc_R547_item_object (ffesta_tokens[1], NULL);
+ ffestc_R547_finish ();
+ }
+ ffelex_token_kill (ffesta_tokens[1]);
+ return (ffelexHandler) ffesta_zero (t);
default:
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "COMMON", t);
break;
}
if (!ffesta_is_inhibited ())
- ffestc_decl_finish ();
+ ffestc_R547_finish ();
ffelex_token_kill (ffesta_tokens[1]);
- ffesta_ffebad_1t (FFEBAD_INVALID_TYPEDECL_ATTR, t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_decl_attrs_2_ -- "type" [type parameters] ",DIMENSION" OPEN_PAREN
- dimlist CLOSE_PAREN
+/* ffestb_R5476_ -- "COMMON" ... NAME OPEN_PAREN dimlist CLOSE_PAREN
- return ffestb_decl_attrs_2_; // to lexer
+ return ffestb_R5476_; // to lexer
- Handle COMMA or COLONCOLON. */
+ Handle COMMA, SLASH, CONCAT, EOS/SEMICOLON. */
static ffelexHandler
-ffestb_decl_attrs_2_ (ffelexToken t)
+ffestb_R5476_ (ffelexToken t)
{
if (!ffestb_subrargs_.dim_list.ok)
goto bad; /* :::::::::::::::::::: */
switch (ffelex_token_type (t))
{
case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
+ ffesta_confirmed ();
if (!ffesta_is_inhibited ())
- ffestc_decl_attrib (FFESTP_attribDIMENSION, ffesta_tokens[1],
- FFESTR_otherNone, ffestb_subrargs_.dim_list.dims);
+ {
+ if (!ffestb_local_.common.started)
+ {
+ ffestc_R547_start ();
+ ffestb_local_.common.started = TRUE;
+ }
+ ffestc_R547_item_object (ffesta_tokens[1],
+ ffestb_subrargs_.dim_list.dims);
+ }
ffelex_token_kill (ffesta_tokens[1]);
ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
- return (ffelexHandler) ffestb_decl_attrs_7_ (t);
+ return (ffelexHandler) ffestb_R5477_;
+
+ case FFELEX_typeSLASH:
+ case FFELEX_typeCONCAT:
+ ffesta_confirmed ();
+ if (!ffesta_is_inhibited ())
+ {
+ if (!ffestb_local_.common.started)
+ {
+ ffestc_R547_start ();
+ ffestb_local_.common.started = TRUE;
+ }
+ ffestc_R547_item_object (ffesta_tokens[1],
+ ffestb_subrargs_.dim_list.dims);
+ }
+ ffelex_token_kill (ffesta_tokens[1]);
+ ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
+ return (ffelexHandler) ffestb_R5471_ (t);
+
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ ffesta_confirmed ();
+ if (!ffesta_is_inhibited ())
+ {
+ if (!ffestb_local_.common.started)
+ ffestc_R547_start ();
+ ffestc_R547_item_object (ffesta_tokens[1],
+ ffestb_subrargs_.dim_list.dims);
+ ffestc_R547_finish ();
+ }
+ ffelex_token_kill (ffesta_tokens[1]);
+ ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
+ return (ffelexHandler) ffesta_zero (t);
default:
break;
}
bad: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t);
- if (!ffesta_is_inhibited ())
- ffestc_decl_finish ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "COMMON", t);
+ if (ffestb_local_.common.started && !ffesta_is_inhibited ())
+ ffestc_R547_finish ();
ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
ffelex_token_kill (ffesta_tokens[1]);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_decl_attrs_3_ -- "type" [type parameters] ",INTENT"
+/* ffestb_R5477_ -- "COMMON" ... COMMA
- return ffestb_decl_attrs_3_; // to lexer
+ return ffestb_R5477_; // to lexer
- Handle OPEN_PAREN. */
+ Make sure we don't have EOS or SEMICOLON. */
-#if FFESTR_F90
static ffelexHandler
-ffestb_decl_attrs_3_ (ffelexToken t)
+ffestb_R5477_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeOPEN_PAREN:
- return (ffelexHandler) ffestb_decl_attrs_4_;
-
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- ffesta_ffebad_1t (FFEBAD_INVALID_TYPEDECL_ATTR, ffesta_tokens[1]);
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffestb_decl_attrs_7_ (t);
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ if (!ffesta_is_inhibited ())
+ ffestc_R547_finish ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "COMMON", t);
+ return (ffelexHandler) ffesta_zero (t);
default:
- break;
+ return (ffelexHandler) ffestb_R5471_ (t);
}
-
- if (!ffesta_is_inhibited ())
- ffestc_decl_finish ();
- ffelex_token_kill (ffesta_tokens[1]);
- ffesta_ffebad_1t (FFEBAD_INVALID_TYPEDECL_ATTR, t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_decl_attrs_4_ -- "type" [type parameters] ",INTENT" OPEN_PAREN
+/* ffestb_R1229 -- Parse a STMTFUNCTION statement
- return ffestb_decl_attrs_4_; // to lexer
+ return ffestb_R1229; // to lexer
- Handle NAME. */
+ Make sure the statement has a valid form for a STMTFUNCTION
+ statement. If it does, implement the statement. */
-static ffelexHandler
-ffestb_decl_attrs_4_ (ffelexToken t)
+ffelexHandler
+ffestb_R1229 (ffelexToken t)
{
- switch (ffelex_token_type (t))
+ switch (ffelex_token_type (ffesta_tokens[0]))
{
case FFELEX_typeNAME:
- ffestb_local_.decl.kw = ffestr_other (t);
- switch (ffestb_local_.decl.kw)
- {
- case FFESTR_otherIN:
- return (ffelexHandler) ffestb_decl_attrs_5_;
-
- case FFESTR_otherINOUT:
- return (ffelexHandler) ffestb_decl_attrs_6_;
+ case FFELEX_typeNAMES:
+ break;
- case FFESTR_otherOUT:
- return (ffelexHandler) ffestb_decl_attrs_6_;
+ default:
+ goto bad_0; /* :::::::::::::::::::: */
+ }
- default:
- ffestb_local_.decl.kw = FFESTR_otherNone;
- ffesta_ffebad_1t (FFEBAD_INVALID_TYPEDECL_ATTR, t);
- return (ffelexHandler) ffestb_decl_attrs_5_;
- }
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeOPEN_PAREN:
break;
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ case FFELEX_typeCOMMA:
+ case FFELEX_typeCOLONCOLON:
+ case FFELEX_typeNAME:
+ ffesta_confirmed (); /* Error, but clearly intended. */
+ goto bad_1; /* :::::::::::::::::::: */
+
default:
- break;
+ goto bad_1; /* :::::::::::::::::::: */
}
- if (!ffesta_is_inhibited ())
- ffestc_decl_finish ();
- ffelex_token_kill (ffesta_tokens[1]);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t);
+ ffestb_subrargs_.name_list.args = ffestt_tokenlist_create ();
+ ffestb_subrargs_.name_list.handler = (ffelexHandler) ffestb_R12291_;
+ ffestb_subrargs_.name_list.is_subr = FALSE; /* No "*" items in list! */
+ ffestb_subrargs_.name_list.names = TRUE; /* In case "IF(FOO)CALL
+ FOO...". */
+ return (ffelexHandler) ffestb_subr_name_list_;
+
+bad_0: /* :::::::::::::::::::: */
+bad_1: /* :::::::::::::::::::: */
+ ffesta_ffebad_2t (FFEBAD_UNREC_STMT, ffesta_tokens[0], t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_decl_attrs_5_ -- "type" [type parameters] ",INTENT" OPEN_PAREN "IN"
+/* ffestb_R12291_ -- "STMTFUNCTION" OPEN_PAREN dummy-name-list CLOSE_PAREN
- return ffestb_decl_attrs_5_; // to lexer
+ return ffestb_R12291_; // to lexer
- Handle NAME or CLOSE_PAREN. */
+ Make sure the statement has a valid form for a STMTFUNCTION statement. If
+ it does, implement the statement. */
static ffelexHandler
-ffestb_decl_attrs_5_ (ffelexToken t)
+ffestb_R12291_ (ffelexToken t)
{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- switch (ffestr_other (t))
- {
- case FFESTR_otherOUT:
- if (ffestb_local_.decl.kw != FFESTR_otherNone)
- ffestb_local_.decl.kw = FFESTR_otherINOUT;
- return (ffelexHandler) ffestb_decl_attrs_6_;
+ ffelex_set_names (FALSE);
- default:
- if (ffestb_local_.decl.kw != FFESTR_otherNone)
- {
- ffestb_local_.decl.kw = FFESTR_otherNone;
- ffesta_ffebad_1t (FFEBAD_INVALID_TYPEDECL_ATTR, t);
- }
- return (ffelexHandler) ffestb_decl_attrs_5_;
- }
- break;
+ if (!ffestb_subrargs_.name_list.ok)
+ goto bad; /* :::::::::::::::::::: */
- case FFELEX_typeCLOSE_PAREN:
- return (ffelexHandler) ffestb_decl_attrs_6_ (t);
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeEQUALS:
+ ffesta_confirmed ();
+ if (!ffesta_is_inhibited ())
+ ffestc_R1229_start (ffesta_tokens[0],
+ ffestb_subrargs_.name_list.args,
+ ffestb_subrargs_.name_list.close_paren);
+ ffelex_token_kill (ffestb_subrargs_.name_list.close_paren);
+ ffestt_tokenlist_kill (ffestb_subrargs_.name_list.args);
+ return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ FFEEXPR_contextSFUNCDEF, (ffeexprCallback) ffestb_R12292_);
default:
break;
}
- if (!ffesta_is_inhibited ())
- ffestc_decl_finish ();
- ffelex_token_kill (ffesta_tokens[1]);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t);
+bad: /* :::::::::::::::::::: */
+ ffesta_ffebad_2t (FFEBAD_UNREC_STMT, ffesta_tokens[0], t);
+ ffelex_token_kill (ffestb_subrargs_.name_list.close_paren);
+ ffestt_tokenlist_kill (ffestb_subrargs_.name_list.args);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_decl_attrs_6_ -- "type" [type parameters] ",INTENT" OPEN_PAREN "IN"
- ["OUT"]
+/* ffestb_R12292_ -- "STMTFUNCTION" OPEN_PAREN dummy-name-list CLOSE_PAREN
+ EQUALS expr
- return ffestb_decl_attrs_6_; // to lexer
+ (ffestb_R12292_) // to expression handler
- Handle CLOSE_PAREN. */
+ Make sure the statement has a valid form for a STMTFUNCTION statement. If
+ it does, implement the statement. */
static ffelexHandler
-ffestb_decl_attrs_6_ (ffelexToken t)
+ffestb_R12292_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
+ if (expr == NULL)
+ goto bad; /* :::::::::::::::::::: */
+
switch (ffelex_token_type (t))
{
- case FFELEX_typeCLOSE_PAREN:
- if ((ffestb_local_.decl.kw != FFESTR_otherNone)
- && !ffesta_is_inhibited ())
- ffestc_decl_attrib (FFESTP_attribINTENT, ffesta_tokens[1],
- ffestb_local_.decl.kw, NULL);
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffestb_decl_attrs_7_;
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ if (!ffesta_is_inhibited ())
+ ffestc_R1229_finish (expr, ft);
+ return (ffelexHandler) ffesta_zero (t);
default:
break;
}
- if (!ffesta_is_inhibited ())
- ffestc_decl_finish ();
- ffelex_token_kill (ffesta_tokens[1]);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t);
+bad: /* :::::::::::::::::::: */
+ ffestc_R1229_finish (NULL, NULL);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "statement-function-definition", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-#endif
-/* ffestb_decl_attrs_7_ -- "type" [type parameters] attribute
+/* ffestb_decl_chartype -- Parse the CHARACTER statement
- return ffestb_decl_attrs_7_; // to lexer
+ return ffestb_decl_chartype; // to lexer
- Handle COMMA (another attribute) or COLONCOLON (entities). */
+ Make sure the statement has a valid form for the CHARACTER statement. If
+ it does, implement the statement. */
-static ffelexHandler
-ffestb_decl_attrs_7_ (ffelexToken t)
+ffelexHandler
+ffestb_decl_chartype (ffelexToken t)
{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- return (ffelexHandler) ffestb_decl_attrs_;
+ ffeTokenLength i;
+ unsigned const char *p;
- case FFELEX_typeCOLONCOLON:
- ffestb_local_.decl.coloncolon = TRUE;
- return (ffelexHandler) ffestb_decl_ents_;
+ ffestb_local_.decl.type = FFESTP_typeCHARACTER;
+ ffestb_local_.decl.recursive = NULL;
+ ffestb_local_.decl.parameter = FALSE; /* No PARAMETER attribute seen. */
+ ffestb_local_.decl.coloncolon = FALSE; /* No COLONCOLON seen. */
- default:
- break;
- }
+ switch (ffelex_token_type (ffesta_tokens[0]))
+ {
+ case FFELEX_typeNAME:
+ if (ffesta_first_kw != FFESTR_firstCHRCTR)
+ goto bad_0; /* :::::::::::::::::::: */
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ ffesta_confirmed (); /* Error, but clearly intended. */
+ goto bad_1; /* :::::::::::::::::::: */
- if (!ffesta_is_inhibited ())
- ffestc_decl_finish ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
+ default:
+ goto bad_1; /* :::::::::::::::::::: */
-/* ffestb_decl_attrsp_ -- "type" [type parameters]
+ case FFELEX_typeCOMMA:
+ ffesta_confirmed ();
+ if (!ffesta_is_inhibited ())
+ ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0],
+ NULL, NULL, NULL, NULL);
+ return (ffelexHandler) ffestb_decl_attrs_;
- return ffestb_decl_attrsp_; // to lexer
+ case FFELEX_typeCOLONCOLON:
+ ffestb_local_.decl.coloncolon = TRUE;
+ ffesta_confirmed ();
+ if (!ffesta_is_inhibited ())
+ ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0],
+ NULL, NULL, NULL, NULL);
+ return (ffelexHandler) ffestb_decl_ents_;
- Handle COMMA (meaning we have attributes), COLONCOLON (meaning we have
- no attributes but entities), or go to entsp to see about functions or
- entities. */
+ case FFELEX_typeASTERISK:
+ ffesta_confirmed ();
+ ffestb_local_.decl.handler = (ffelexHandler) ffestb_decl_chartype1_;
+ ffestb_local_.decl.badname = "TYPEDECL";
+ return (ffelexHandler) ffestb_decl_starlen_;
-static ffelexHandler
-ffestb_decl_attrsp_ (ffelexToken t)
-{
- ffelex_set_names (FALSE);
+ case FFELEX_typeOPEN_PAREN:
+ ffestb_local_.decl.kind = NULL;
+ ffestb_local_.decl.kindt = NULL;
+ ffestb_local_.decl.len = NULL;
+ ffestb_local_.decl.lent = NULL;
+ ffestb_local_.decl.handler = (ffelexHandler) ffestb_decl_attrsp_;
+ ffestb_local_.decl.badname = "_TYPEDECL";
+ return (ffelexHandler) ffestb_decl_typeparams_;
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0],
- ffestb_local_.decl.kind, ffestb_local_.decl.kindt,
- ffestb_local_.decl.len, ffestb_local_.decl.lent);
- if (ffestb_local_.decl.kindt != NULL)
- ffelex_token_kill (ffestb_local_.decl.kindt);
- if (ffestb_local_.decl.lent != NULL)
- ffelex_token_kill (ffestb_local_.decl.lent);
- return (ffelexHandler) ffestb_decl_attrs_;
+ case FFELEX_typeNAME:
+ ffesta_confirmed ();
+ ffestb_local_.decl.kind = NULL;
+ ffestb_local_.decl.kindt = NULL;
+ ffestb_local_.decl.len = NULL;
+ ffestb_local_.decl.lent = NULL;
+ return (ffelexHandler) ffestb_decl_entsp_ (t);
+ }
- case FFELEX_typeCOLONCOLON:
- ffestb_local_.decl.coloncolon = TRUE;
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0],
- ffestb_local_.decl.kind, ffestb_local_.decl.kindt,
- ffestb_local_.decl.len, ffestb_local_.decl.lent);
- if (ffestb_local_.decl.kindt != NULL)
- ffelex_token_kill (ffestb_local_.decl.kindt);
- if (ffestb_local_.decl.lent != NULL)
- ffelex_token_kill (ffestb_local_.decl.lent);
- return (ffelexHandler) ffestb_decl_ents_;
+ case FFELEX_typeNAMES:
+ if (ffesta_first_kw != FFESTR_firstCHRCTR)
+ goto bad_0; /* :::::::::::::::::::: */
+ p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlCHRCTR);
+ switch (ffelex_token_type (t))
+ {
+ default:
+ goto bad_1; /* :::::::::::::::::::: */
- default:
- return (ffelexHandler) ffestb_decl_entsp_ (t);
- }
-}
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ ffesta_confirmed ();
+ break;
-/* ffestb_decl_ents_ -- "type" [type parameters] [attributes "::"]
+ case FFELEX_typeCOMMA:
+ ffesta_confirmed ();
+ if (*p != '\0')
+ break;
+ if (!ffesta_is_inhibited ())
+ ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0],
+ NULL, NULL, NULL, NULL);
+ return (ffelexHandler) ffestb_decl_attrs_;
- return ffestb_decl_ents_; // to lexer
+ case FFELEX_typeCOLONCOLON:
+ ffestb_local_.decl.coloncolon = TRUE;
+ ffesta_confirmed ();
+ if (*p != '\0')
+ goto bad_i; /* :::::::::::::::::::: */
+ if (!ffesta_is_inhibited ())
+ ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0],
+ NULL, NULL, NULL, NULL);
+ return (ffelexHandler) ffestb_decl_ents_;
- Handle NAME of an entity. */
+ case FFELEX_typeASTERISK:
+ ffesta_confirmed ();
+ if (*p != '\0')
+ break;
+ ffestb_local_.decl.handler = (ffelexHandler) ffestb_decl_chartype1_;
+ ffestb_local_.decl.badname = "TYPEDECL";
+ return (ffelexHandler) ffestb_decl_starlen_;
-static ffelexHandler
-ffestb_decl_ents_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_decl_ents_1_;
+ case FFELEX_typeSLASH:
+ ffesta_confirmed ();
+ if (*p != '\0')
+ break;
+ goto bad_1; /* :::::::::::::::::::: */
+
+ case FFELEX_typeOPEN_PAREN:
+ if (*p != '\0')
+ break;
+ ffestb_local_.decl.kind = NULL;
+ ffestb_local_.decl.kindt = NULL;
+ ffestb_local_.decl.len = NULL;
+ ffestb_local_.decl.lent = NULL;
+ ffestb_local_.decl.handler = (ffelexHandler) ffestb_decl_attrsp_;
+ ffestb_local_.decl.badname = "TYPEDECL";
+ return (ffelexHandler) ffestb_decl_typeparams_;
+ }
+ if (!ffesrc_is_name_init (*p))
+ goto bad_i; /* :::::::::::::::::::: */
+ ffestb_local_.decl.kind = NULL;
+ ffestb_local_.decl.kindt = NULL;
+ ffestb_local_.decl.len = NULL;
+ ffestb_local_.decl.lent = NULL;
+ ffesta_tokens[1] = ffelex_token_names_from_names (ffesta_tokens[0], i, 0);
+ return (ffelexHandler) ffestb_decl_entsp_2_ (t);
default:
- break;
+ goto bad_0; /* :::::::::::::::::::: */
}
- if (!ffesta_is_inhibited ())
- ffestc_decl_finish ();
+bad_0: /* :::::::::::::::::::: */
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", ffesta_tokens[0]);
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+
+bad_1: /* :::::::::::::::::::: */
ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t);
+ return (ffelexHandler) ffelex_swallow_tokens (t,
+ (ffelexHandler) ffesta_zero); /* Invalid second token. */
+
+bad_i: /* :::::::::::::::::::: */
+ ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "type-declaration", ffesta_tokens[0], i, t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_decl_ents_1_ -- "type" [type parameters] [attributes "::"] NAME
+/* ffestb_decl_chartype1_ -- "CHARACTER" ASTERISK char-length
- return ffestb_decl_ents_1_; // to lexer
+ return ffestb_decl_chartype1_; // to lexer
- Handle ASTERISK, OPEN_PAREN, EQUALS, SLASH, COMMA, or EOS/SEMICOLON. */
+ Handle COMMA, COLONCOLON, or anything else. */
static ffelexHandler
-ffestb_decl_ents_1_ (ffelexToken t)
+ffestb_decl_chartype1_ (ffelexToken t)
{
+ ffelex_set_names (FALSE);
+
switch (ffelex_token_type (t))
{
+ case FFELEX_typeCOLONCOLON:
+ ffestb_local_.decl.coloncolon = TRUE;
+ /* Fall through. */
case FFELEX_typeCOMMA:
+ ffesta_confirmed ();
if (!ffesta_is_inhibited ())
- ffestc_decl_item (ffesta_tokens[1], NULL, NULL, NULL, NULL, NULL, NULL,
- NULL, FALSE);
- ffelex_token_kill (ffesta_tokens[1]);
+ ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0],
+ NULL, NULL, ffestb_local_.decl.len, ffestb_local_.decl.lent);
+ if (ffestb_local_.decl.lent != NULL)
+ ffelex_token_kill (ffestb_local_.decl.lent);
return (ffelexHandler) ffestb_decl_ents_;
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- if (!ffesta_is_inhibited ())
- {
- ffestc_decl_item (ffesta_tokens[1], NULL, NULL, NULL, NULL, NULL, NULL,
- NULL, FALSE);
- ffestc_decl_finish ();
- }
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffesta_zero (t);
-
- case FFELEX_typeASTERISK:
- ffestb_local_.decl.len = NULL;
- ffestb_local_.decl.lent = NULL;
- return (ffelexHandler) ffestb_decl_ents_2_;
-
- case FFELEX_typeOPEN_PAREN:
- ffestb_local_.decl.kind = NULL;
- ffestb_local_.decl.kindt = NULL;
- ffestb_local_.decl.len = NULL;
- ffestb_local_.decl.lent = NULL;
- return (ffelexHandler) ffestb_decl_ents_3_ (t);
-
- case FFELEX_typeEQUALS:
- case FFELEX_typeSLASH:
- ffestb_local_.decl.kind = NULL;
- ffestb_local_.decl.kindt = NULL;
- ffestb_subrargs_.dim_list.dims = NULL;
- ffestb_local_.decl.len = NULL;
- ffestb_local_.decl.lent = NULL;
- return (ffelexHandler) ffestb_decl_ents_7_ (t);
-
default:
- break;
+ return (ffelexHandler) ffestb_decl_entsp_ (t);
}
-
- if (!ffesta_is_inhibited ())
- ffestc_decl_finish ();
- ffelex_token_kill (ffesta_tokens[1]);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_decl_ents_2_ -- "type" [type parameters] [attributes "::"] NAME
- ASTERISK
+/* ffestb_decl_dbltype -- Parse the DOUBLEPRECISION/DOUBLECOMPLEX statement
- return ffestb_decl_ents_2_; // to lexer
+ return ffestb_decl_dbltype; // to lexer
- Handle NUMBER or OPEN_PAREN. */
+ Make sure the statement has a valid form for the DOUBLEPRECISION/
+ DOUBLECOMPLEX statement. If it does, implement the statement. */
-static ffelexHandler
-ffestb_decl_ents_2_ (ffelexToken t)
+ffelexHandler
+ffestb_decl_dbltype (ffelexToken t)
{
- switch (ffelex_token_type (t))
+ ffeTokenLength i;
+ unsigned const char *p;
+
+ ffestb_local_.decl.type = ffestb_args.decl.type;
+ ffestb_local_.decl.recursive = NULL;
+ ffestb_local_.decl.parameter = FALSE; /* No PARAMETER attribute seen. */
+ ffestb_local_.decl.coloncolon = FALSE; /* No COLONCOLON seen. */
+
+ switch (ffelex_token_type (ffesta_tokens[0]))
{
- case FFELEX_typeNUMBER:
- if (ffestb_local_.decl.type != FFESTP_typeCHARACTER)
+ case FFELEX_typeNAME:
+ switch (ffelex_token_type (t))
{
- ffestb_local_.decl.kind = NULL;
- ffestb_local_.decl.kindt = ffelex_token_use (t);
- return (ffelexHandler) ffestb_decl_ents_3_;
- }
- /* Fall through. *//* (CHARACTER's *n is always a len spec. */
- case FFELEX_typeOPEN_PAREN:/* "*(" is after the (omitted)
- "(array-spec)". */
- ffestb_local_.decl.kind = NULL;
- ffestb_local_.decl.kindt = NULL;
- ffestb_subrargs_.dim_list.dims = NULL;
- return (ffelexHandler) ffestb_decl_ents_5_ (t);
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ ffesta_confirmed (); /* Error, but clearly intended. */
+ goto bad_1; /* :::::::::::::::::::: */
- default:
- break;
- }
+ default:
+ goto bad_1; /* :::::::::::::::::::: */
- if (!ffesta_is_inhibited ())
- ffestc_decl_finish ();
- ffelex_token_kill (ffesta_tokens[1]);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
+ case FFELEX_typeCOMMA:
+ ffesta_confirmed ();
+ if (!ffesta_is_inhibited ())
+ ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0],
+ NULL, NULL, NULL, NULL);
+ return (ffelexHandler) ffestb_decl_attrs_;
-/* ffestb_decl_ents_3_ -- "type" [type parameters] [attributes "::"] NAME
- [ASTERISK NUMBER]
+ case FFELEX_typeCOLONCOLON:
+ ffestb_local_.decl.coloncolon = TRUE;
+ ffesta_confirmed ();
+ if (!ffesta_is_inhibited ())
+ ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0],
+ NULL, NULL, NULL, NULL);
+ return (ffelexHandler) ffestb_decl_ents_;
- return ffestb_decl_ents_3_; // to lexer
+ case FFELEX_typeNAME:
+ ffesta_confirmed ();
+ ffestb_local_.decl.kind = NULL;
+ ffestb_local_.decl.kindt = NULL;
+ ffestb_local_.decl.len = NULL;
+ ffestb_local_.decl.lent = NULL;
+ return (ffelexHandler) ffestb_decl_entsp_ (t);
+ }
- Handle ASTERISK, OPEN_PAREN, EQUALS, SLASH, COMMA, or EOS/SEMICOLON. */
+ case FFELEX_typeNAMES:
+ p = ffelex_token_text (ffesta_tokens[0]) + (i = ffestb_args.decl.len);
+ switch (ffelex_token_type (t))
+ {
+ default:
+ goto bad_1; /* :::::::::::::::::::: */
-static ffelexHandler
-ffestb_decl_ents_3_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- if (!ffesta_is_inhibited ())
- ffestc_decl_item (ffesta_tokens[1], ffestb_local_.decl.kind,
- ffestb_local_.decl.kindt, NULL, NULL, NULL, NULL, NULL, FALSE);
- ffelex_token_kill (ffesta_tokens[1]);
- if (ffestb_local_.decl.kindt != NULL)
- ffelex_token_kill (ffestb_local_.decl.kindt);
- return (ffelexHandler) ffestb_decl_ents_;
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ ffesta_confirmed ();
+ break;
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- if (!ffesta_is_inhibited ())
- {
- ffestc_decl_item (ffesta_tokens[1], ffestb_local_.decl.kind,
- ffestb_local_.decl.kindt, NULL, NULL, NULL, NULL, NULL, FALSE);
- ffestc_decl_finish ();
- }
- ffelex_token_kill (ffesta_tokens[1]);
- if (ffestb_local_.decl.kindt != NULL)
- ffelex_token_kill (ffestb_local_.decl.kindt);
- return (ffelexHandler) ffesta_zero (t);
+ case FFELEX_typeCOMMA:
+ ffesta_confirmed ();
+ if (*p != '\0')
+ break;
+ if (!ffesta_is_inhibited ())
+ ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0],
+ NULL, NULL, NULL, NULL);
+ return (ffelexHandler) ffestb_decl_attrs_;
- case FFELEX_typeASTERISK:
- ffestb_subrargs_.dim_list.dims = NULL;
- return (ffelexHandler) ffestb_decl_ents_5_;
+ case FFELEX_typeCOLONCOLON:
+ ffestb_local_.decl.coloncolon = TRUE;
+ ffesta_confirmed ();
+ if (*p != '\0')
+ goto bad_i; /* :::::::::::::::::::: */
+ if (!ffesta_is_inhibited ())
+ ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0],
+ NULL, NULL, NULL, NULL);
+ return (ffelexHandler) ffestb_decl_ents_;
- case FFELEX_typeOPEN_PAREN:
- ffestb_subrargs_.dim_list.dims = ffestt_dimlist_create ();
- ffestb_subrargs_.dim_list.handler = (ffelexHandler) ffestb_decl_ents_4_;
- ffestb_subrargs_.dim_list.pool = ffesta_output_pool;
- ffestb_subrargs_.dim_list.ctx = ffesta_is_entry_valid
- ? FFEEXPR_contextDIMLIST : FFEEXPR_contextDIMLISTCOMMON;
-#ifdef FFECOM_dimensionsMAX
- ffestb_subrargs_.dim_list.ndims = 0;
-#endif
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- ffestb_subrargs_.dim_list.ctx,
- (ffeexprCallback) ffestb_subr_dimlist_);
+ case FFELEX_typeSLASH:
+ ffesta_confirmed ();
+ if (*p != '\0')
+ break;
+ goto bad_1; /* :::::::::::::::::::: */
- case FFELEX_typeEQUALS:
- case FFELEX_typeSLASH:
+ case FFELEX_typeOPEN_PAREN:
+ if (*p != '\0')
+ break;
+ goto bad_1; /* :::::::::::::::::::: */
+ }
+ if (!ffesrc_is_name_init (*p))
+ goto bad_i; /* :::::::::::::::::::: */
ffestb_local_.decl.kind = NULL;
ffestb_local_.decl.kindt = NULL;
- ffestb_subrargs_.dim_list.dims = NULL;
ffestb_local_.decl.len = NULL;
ffestb_local_.decl.lent = NULL;
- return (ffelexHandler) ffestb_decl_ents_7_ (t);
+ ffesta_tokens[1] = ffelex_token_names_from_names (ffesta_tokens[0], i, 0);
+ return (ffelexHandler) ffestb_decl_entsp_2_ (t);
default:
- break;
+ goto bad_0; /* :::::::::::::::::::: */
}
- if (!ffesta_is_inhibited ())
- ffestc_decl_finish ();
- ffelex_token_kill (ffesta_tokens[1]);
- if (ffestb_local_.decl.kindt != NULL)
- ffelex_token_kill (ffestb_local_.decl.kindt);
+bad_0: /* :::::::::::::::::::: */
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", ffesta_tokens[0]);
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+
+bad_1: /* :::::::::::::::::::: */
ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t);
+ return (ffelexHandler) ffelex_swallow_tokens (t,
+ (ffelexHandler) ffesta_zero); /* Invalid second token. */
+
+bad_i: /* :::::::::::::::::::: */
+ ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "type-declaration", ffesta_tokens[0], i, t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_decl_ents_4_ -- "type" [type parameters] [attributes "::"] NAME
- [ASTERISK NUMBER] [OPEN_PAREN dimlist CLOSE_PAREN]
+/* ffestb_decl_double -- Parse the DOUBLE PRECISION/DOUBLE COMPLEX statement
- return ffestb_decl_ents_4_; // to lexer
+ return ffestb_decl_double; // to lexer
- Handle ASTERISK, EQUALS, SLASH, COMMA, or EOS/SEMICOLON. */
+ Make sure the statement has a valid form for the DOUBLE PRECISION/
+ DOUBLE COMPLEX statement. If it does, implement the statement. */
-static ffelexHandler
-ffestb_decl_ents_4_ (ffelexToken t)
+ffelexHandler
+ffestb_decl_double (ffelexToken t)
{
- ffelexToken nt;
-
- if (!ffestb_subrargs_.dim_list.ok)
- goto bad; /* :::::::::::::::::::: */
+ ffestb_local_.decl.recursive = NULL;
+ ffestb_local_.decl.parameter = FALSE; /* No PARAMETER attribute seen. */
+ ffestb_local_.decl.coloncolon = FALSE; /* No COLONCOLON seen. */
- if (ffelex_token_type (ffesta_tokens[1]) == FFELEX_typeNAMES)
+ switch (ffelex_token_type (ffesta_tokens[0]))
{
+ case FFELEX_typeNAME:
+ if (ffesta_first_kw != FFESTR_firstDBL)
+ goto bad_0; /* :::::::::::::::::::: */
switch (ffelex_token_type (t))
{
- case FFELEX_typeCOMMA:
case FFELEX_typeEOS:
case FFELEX_typeSEMICOLON:
- case FFELEX_typeASTERISK:
- case FFELEX_typeSLASH: /* But NOT FFELEX_typeEQUALS. */
- case FFELEX_typeCOLONCOLON: /* Actually an error. */
- break; /* Confirm and handle. */
-
- default: /* Perhaps EQUALS, as in
- INTEGERFUNCTIONX(A)=B. */
- goto bad; /* :::::::::::::::::::: */
- }
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- {
- nt = ffelex_token_name_from_names (ffesta_tokens[1], 0, 0);
- ffelex_token_kill (ffesta_tokens[1]);
- ffesta_tokens[1] = nt;
- ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0],
- NULL, NULL, NULL, NULL);
- }
- }
+ case FFELEX_typeCOMMA:
+ case FFELEX_typeCOLONCOLON:
+ ffesta_confirmed (); /* Error, but clearly intended. */
+ goto bad_1; /* :::::::::::::::::::: */
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- if (!ffesta_is_inhibited ())
- ffestc_decl_item (ffesta_tokens[1], ffestb_local_.decl.kind,
- ffestb_local_.decl.kindt, ffestb_subrargs_.dim_list.dims,
- ffestb_local_.decl.len, ffestb_local_.decl.lent, NULL, NULL,
- FALSE);
- ffelex_token_kill (ffesta_tokens[1]);
- if (ffestb_local_.decl.kindt != NULL)
- ffelex_token_kill (ffestb_local_.decl.kindt);
- if (ffestb_local_.decl.lent != NULL)
- ffelex_token_kill (ffestb_local_.decl.lent);
- ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
- return (ffelexHandler) ffestb_decl_ents_;
+ default:
+ goto bad_1; /* :::::::::::::::::::: */
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- if (!ffesta_is_inhibited ())
- {
- ffestc_decl_item (ffesta_tokens[1], ffestb_local_.decl.kind,
- ffestb_local_.decl.kindt, ffestb_subrargs_.dim_list.dims,
- ffestb_local_.decl.len, ffestb_local_.decl.lent, NULL, NULL,
- FALSE);
- ffestc_decl_finish ();
- }
- ffelex_token_kill (ffesta_tokens[1]);
- if (ffestb_local_.decl.kindt != NULL)
- ffelex_token_kill (ffestb_local_.decl.kindt);
- if (ffestb_local_.decl.lent != NULL)
- ffelex_token_kill (ffestb_local_.decl.lent);
- ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
- return (ffelexHandler) ffesta_zero (t);
+ case FFELEX_typeNAME:
+ ffesta_confirmed ();
+ switch (ffestr_second (t))
+ {
+ case FFESTR_secondCOMPLEX:
+ ffestb_local_.decl.type = FFESTP_typeDBLCMPLX;
+ break;
- case FFELEX_typeASTERISK:
- if (ffestb_local_.decl.lent != NULL)
- break; /* Can't specify "*length" twice. */
- return (ffelexHandler) ffestb_decl_ents_5_;
+ case FFESTR_secondPRECISION:
+ ffestb_local_.decl.type = FFESTP_typeDBLPRCSN;
+ break;
- case FFELEX_typeEQUALS:
- case FFELEX_typeSLASH:
- return (ffelexHandler) ffestb_decl_ents_7_ (t);
+ default:
+ goto bad_1; /* :::::::::::::::::::: */
+ }
+ ffestb_local_.decl.kind = NULL;
+ ffestb_local_.decl.kindt = NULL;
+ ffestb_local_.decl.len = NULL;
+ ffestb_local_.decl.lent = NULL;
+ return (ffelexHandler) ffestb_decl_attrsp_;
+ }
default:
- break;
+ goto bad_0; /* :::::::::::::::::::: */
}
-bad: /* :::::::::::::::::::: */
- if ((ffelex_token_type (ffesta_tokens[1]) != FFELEX_typeNAMES)
- && !ffesta_is_inhibited ())
- ffestc_decl_finish ();
- ffelex_token_kill (ffesta_tokens[1]);
- if (ffestb_local_.decl.kindt != NULL)
- ffelex_token_kill (ffestb_local_.decl.kindt);
- if (ffestb_local_.decl.lent != NULL)
- ffelex_token_kill (ffestb_local_.decl.lent);
- ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t);
+bad_0: /* :::::::::::::::::::: */
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", ffesta_tokens[0]);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+
+bad_1: /* :::::::::::::::::::: */
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t);
+ return (ffelexHandler) ffelex_swallow_tokens (t,
+ (ffelexHandler) ffesta_zero); /* Invalid second token. */
}
-/* ffestb_decl_ents_5_ -- "type" [type parameters] [attributes "::"] NAME
- [ASTERISK NUMBER] [OPEN_PAREN dimlist CLOSE_PAREN]
- ASTERISK
+/* ffestb_decl_gentype -- Parse the INTEGER/REAL/COMPLEX/LOGICAL statement
- return ffestb_decl_ents_5_; // to lexer
+ return ffestb_decl_gentype; // to lexer
- Handle NUMBER or OPEN_PAREN. */
+ Make sure the statement has a valid form for the INTEGER/REAL/COMPLEX/
+ LOGICAL statement. If it does, implement the statement. */
-static ffelexHandler
-ffestb_decl_ents_5_ (ffelexToken t)
+ffelexHandler
+ffestb_decl_gentype (ffelexToken t)
{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNUMBER:
- ffestb_local_.decl.len = NULL;
- ffestb_local_.decl.lent = ffelex_token_use (t);
- return (ffelexHandler) ffestb_decl_ents_7_;
-
- case FFELEX_typeOPEN_PAREN:
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextCHARACTERSIZE, (ffeexprCallback) ffestb_decl_ents_6_);
+ ffeTokenLength i;
+ unsigned const char *p;
- default:
- break;
- }
+ ffestb_local_.decl.type = ffestb_args.decl.type;
+ ffestb_local_.decl.recursive = NULL;
+ ffestb_local_.decl.parameter = FALSE; /* No PARAMETER attribute seen. */
+ ffestb_local_.decl.coloncolon = FALSE; /* No COLONCOLON seen. */
- if (!ffesta_is_inhibited ())
- ffestc_decl_finish ();
- ffelex_token_kill (ffesta_tokens[1]);
- if (ffestb_local_.decl.kindt != NULL)
- ffelex_token_kill (ffestb_local_.decl.kindt);
- if (ffestb_subrargs_.dim_list.dims != NULL)
- ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
+ switch (ffelex_token_type (ffesta_tokens[0]))
+ {
+ case FFELEX_typeNAME:
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ ffesta_confirmed (); /* Error, but clearly intended. */
+ goto bad_1; /* :::::::::::::::::::: */
-/* ffestb_decl_ents_6_ -- "type" [type parameters] [attributes "::"] NAME
- [ASTERISK NUMBER] [OPEN_PAREN dimlist CLOSE_PAREN]
- ASTERISK OPEN_PAREN expr
+ default:
+ goto bad_1; /* :::::::::::::::::::: */
- (ffestb_decl_ents_6_) // to expression handler
+ case FFELEX_typeCOMMA:
+ ffesta_confirmed ();
+ if (!ffesta_is_inhibited ())
+ ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0],
+ NULL, NULL, NULL, NULL);
+ return (ffelexHandler) ffestb_decl_attrs_;
- Handle CLOSE_PAREN. */
+ case FFELEX_typeCOLONCOLON:
+ ffestb_local_.decl.coloncolon = TRUE;
+ ffesta_confirmed ();
+ if (!ffesta_is_inhibited ())
+ ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0],
+ NULL, NULL, NULL, NULL);
+ return (ffelexHandler) ffestb_decl_ents_;
-static ffelexHandler
-ffestb_decl_ents_6_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCLOSE_PAREN:
- if (expr == NULL)
- break;
- ffestb_local_.decl.len = expr;
- ffestb_local_.decl.lent = ffelex_token_use (ft);
- return (ffelexHandler) ffestb_decl_ents_7_;
+ case FFELEX_typeASTERISK:
+ ffesta_confirmed ();
+ ffestb_local_.decl.handler = (ffelexHandler) ffestb_decl_attrsp_;
+ ffestb_local_.decl.badname = "TYPEDECL";
+ return (ffelexHandler) ffestb_decl_starkind_;
- default:
- break;
- }
+ case FFELEX_typeOPEN_PAREN:
+ ffestb_local_.decl.handler = (ffelexHandler) ffestb_decl_attrsp_;
+ ffestb_local_.decl.badname = "TYPEDECL";
+ return (ffelexHandler) ffestb_decl_kindparam_;
- if (!ffesta_is_inhibited ())
- ffestc_decl_finish ();
- ffelex_token_kill (ffesta_tokens[1]);
- if (ffestb_local_.decl.kindt != NULL)
- ffelex_token_kill (ffestb_local_.decl.kindt);
- if (ffestb_subrargs_.dim_list.dims != NULL)
- ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
+ case FFELEX_typeNAME:
+ ffesta_confirmed ();
+ ffestb_local_.decl.kind = NULL;
+ ffestb_local_.decl.kindt = NULL;
+ ffestb_local_.decl.len = NULL;
+ ffestb_local_.decl.lent = NULL;
+ return (ffelexHandler) ffestb_decl_entsp_ (t);
+ }
-/* ffestb_decl_ents_7_ -- "type" [type parameters] [attributes "::"] NAME
- [ASTERISK NUMBER] [OPEN_PAREN dimlist CLOSE_PAREN]
- [ASTERISK charlength]
+ case FFELEX_typeNAMES:
+ p = ffelex_token_text (ffesta_tokens[0]) + (i = ffestb_args.decl.len);
+ switch (ffelex_token_type (t))
+ {
+ default:
+ goto bad_1; /* :::::::::::::::::::: */
- return ffestb_decl_ents_7_; // to lexer
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ ffesta_confirmed ();
+ break;
- Handle EQUALS, SLASH, COMMA, or EOS/SEMICOLON. */
+ case FFELEX_typeCOMMA:
+ ffesta_confirmed ();
+ if (*p != '\0')
+ break;
+ if (!ffesta_is_inhibited ())
+ ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0],
+ NULL, NULL, NULL, NULL);
+ return (ffelexHandler) ffestb_decl_attrs_;
-static ffelexHandler
-ffestb_decl_ents_7_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- if (!ffesta_is_inhibited ())
- ffestc_decl_item (ffesta_tokens[1], ffestb_local_.decl.kind,
- ffestb_local_.decl.kindt, ffestb_subrargs_.dim_list.dims,
- ffestb_local_.decl.len, ffestb_local_.decl.lent, NULL, NULL,
- FALSE);
- ffelex_token_kill (ffesta_tokens[1]);
- if (ffestb_local_.decl.kindt != NULL)
- ffelex_token_kill (ffestb_local_.decl.kindt);
- if (ffestb_subrargs_.dim_list.dims != NULL)
- ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
- if (ffestb_local_.decl.lent != NULL)
- ffelex_token_kill (ffestb_local_.decl.lent);
- return (ffelexHandler) ffestb_decl_ents_;
+ case FFELEX_typeCOLONCOLON:
+ ffestb_local_.decl.coloncolon = TRUE;
+ ffesta_confirmed ();
+ if (*p != '\0')
+ goto bad_i; /* :::::::::::::::::::: */
+ if (!ffesta_is_inhibited ())
+ ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0],
+ NULL, NULL, NULL, NULL);
+ return (ffelexHandler) ffestb_decl_ents_;
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- if (!ffesta_is_inhibited ())
- {
- ffestc_decl_item (ffesta_tokens[1], ffestb_local_.decl.kind,
- ffestb_local_.decl.kindt, ffestb_subrargs_.dim_list.dims,
- ffestb_local_.decl.len, ffestb_local_.decl.lent, NULL, NULL,
- FALSE);
- ffestc_decl_finish ();
- }
- ffelex_token_kill (ffesta_tokens[1]);
- if (ffestb_local_.decl.kindt != NULL)
- ffelex_token_kill (ffestb_local_.decl.kindt);
- if (ffestb_subrargs_.dim_list.dims != NULL)
- ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
- if (ffestb_local_.decl.lent != NULL)
- ffelex_token_kill (ffestb_local_.decl.lent);
- return (ffelexHandler) ffesta_zero (t);
+ case FFELEX_typeSLASH:
+ ffesta_confirmed ();
+ if (*p != '\0')
+ break;
+ goto bad_1; /* :::::::::::::::::::: */
- case FFELEX_typeEQUALS:
- if (!ffestb_local_.decl.coloncolon)
- ffesta_ffebad_1t (FFEBAD_INVALID_TYPEDECL_INIT, t);
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- ffestb_local_.decl.parameter ? FFEEXPR_contextPARAMETER
- : FFEEXPR_contextINITVAL, (ffeexprCallback) ffestb_decl_ents_8_);
+ case FFELEX_typeASTERISK:
+ ffesta_confirmed ();
+ if (*p != '\0')
+ break;
+ ffestb_local_.decl.handler = (ffelexHandler) ffestb_decl_attrsp_;
+ ffestb_local_.decl.badname = "TYPEDECL";
+ return (ffelexHandler) ffestb_decl_starkind_;
- case FFELEX_typeSLASH:
- if (!ffesta_is_inhibited ())
- {
- ffestc_decl_item (ffesta_tokens[1], ffestb_local_.decl.kind,
- ffestb_local_.decl.kindt, ffestb_subrargs_.dim_list.dims,
- ffestb_local_.decl.len, ffestb_local_.decl.lent, NULL, NULL,
- TRUE);
- ffestc_decl_itemstartvals ();
+ case FFELEX_typeOPEN_PAREN:
+ if (*p != '\0')
+ break;
+ ffestb_local_.decl.handler = (ffelexHandler) ffestb_decl_attrsp_;
+ ffestb_local_.decl.badname = "TYPEDECL";
+ return (ffelexHandler) ffestb_decl_kindparam_;
}
- ffelex_token_kill (ffesta_tokens[1]);
- if (ffestb_local_.decl.kindt != NULL)
- ffelex_token_kill (ffestb_local_.decl.kindt);
- if (ffestb_subrargs_.dim_list.dims != NULL)
- ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
- if (ffestb_local_.decl.lent != NULL)
- ffelex_token_kill (ffestb_local_.decl.lent);
- return (ffelexHandler) ffeexpr_rhs
- (ffesta_output_pool, FFEEXPR_contextDATA,
- (ffeexprCallback) ffestb_decl_ents_9_);
+ if (!ffesrc_is_name_init (*p))
+ goto bad_i; /* :::::::::::::::::::: */
+ ffestb_local_.decl.kind = NULL;
+ ffestb_local_.decl.kindt = NULL;
+ ffestb_local_.decl.len = NULL;
+ ffestb_local_.decl.lent = NULL;
+ ffesta_tokens[1] = ffelex_token_names_from_names (ffesta_tokens[0], i, 0);
+ return (ffelexHandler) ffestb_decl_entsp_2_ (t);
default:
- break;
+ goto bad_0; /* :::::::::::::::::::: */
}
- if (!ffesta_is_inhibited ())
- ffestc_decl_finish ();
- ffelex_token_kill (ffesta_tokens[1]);
- if (ffestb_local_.decl.kindt != NULL)
- ffelex_token_kill (ffestb_local_.decl.kindt);
- if (ffestb_subrargs_.dim_list.dims != NULL)
- ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
- if (ffestb_local_.decl.lent != NULL)
- ffelex_token_kill (ffestb_local_.decl.lent);
+bad_0: /* :::::::::::::::::::: */
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", ffesta_tokens[0]);
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+
+bad_1: /* :::::::::::::::::::: */
ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t);
+ return (ffelexHandler) ffelex_swallow_tokens (t,
+ (ffelexHandler) ffesta_zero); /* Invalid second token. */
+
+bad_i: /* :::::::::::::::::::: */
+ ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "type-declaration", ffesta_tokens[0], i, t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_decl_ents_8_ -- "type" [type parameters] [attributes "::"] NAME
- [ASTERISK NUMBER] [OPEN_PAREN dimlist CLOSE_PAREN]
- [ASTERISK charlength] EQUALS expr
+/* ffestb_decl_attrs_ -- "type" [type parameters] COMMA
- (ffestb_decl_ents_8_) // to expression handler
+ return ffestb_decl_attrs_; // to lexer
- Handle COMMA or EOS/SEMICOLON. */
+ Handle NAME of an attribute. */
static ffelexHandler
-ffestb_decl_ents_8_ (ffelexToken ft, ffebld expr, ffelexToken t)
+ffestb_decl_attrs_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeCOMMA:
- if (expr == NULL)
- break;
- if (!ffesta_is_inhibited ())
- ffestc_decl_item (ffesta_tokens[1], ffestb_local_.decl.kind,
- ffestb_local_.decl.kindt, ffestb_subrargs_.dim_list.dims,
- ffestb_local_.decl.len, ffestb_local_.decl.lent, expr, ft,
- FALSE);
- ffelex_token_kill (ffesta_tokens[1]);
- if (ffestb_local_.decl.kindt != NULL)
- ffelex_token_kill (ffestb_local_.decl.kindt);
- if (ffestb_subrargs_.dim_list.dims != NULL)
- ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
- if (ffestb_local_.decl.lent != NULL)
- ffelex_token_kill (ffestb_local_.decl.lent);
- return (ffelexHandler) ffestb_decl_ents_;
-
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- if (!ffesta_is_inhibited ())
+ case FFELEX_typeNAME:
+ switch (ffestr_first (t))
{
- ffestc_decl_item (ffesta_tokens[1], ffestb_local_.decl.kind,
- ffestb_local_.decl.kindt, ffestb_subrargs_.dim_list.dims,
- ffestb_local_.decl.len, ffestb_local_.decl.lent, expr, ft,
- FALSE);
- ffestc_decl_finish ();
+ case FFESTR_firstDIMENSION:
+ ffesta_tokens[1] = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_decl_attrs_1_;
+
+ case FFESTR_firstEXTERNAL:
+ if (!ffesta_is_inhibited ())
+ ffestc_decl_attrib (FFESTP_attribEXTERNAL, t,
+ FFESTR_otherNone, NULL);
+ return (ffelexHandler) ffestb_decl_attrs_7_;
+
+ case FFESTR_firstINTRINSIC:
+ if (!ffesta_is_inhibited ())
+ ffestc_decl_attrib (FFESTP_attribINTRINSIC, t,
+ FFESTR_otherNone, NULL);
+ return (ffelexHandler) ffestb_decl_attrs_7_;
+
+ case FFESTR_firstPARAMETER:
+ ffestb_local_.decl.parameter = TRUE;
+ if (!ffesta_is_inhibited ())
+ ffestc_decl_attrib (FFESTP_attribPARAMETER, t,
+ FFESTR_otherNone, NULL);
+ return (ffelexHandler) ffestb_decl_attrs_7_;
+
+ case FFESTR_firstSAVE:
+ if (!ffesta_is_inhibited ())
+ ffestc_decl_attrib (FFESTP_attribSAVE, t,
+ FFESTR_otherNone, NULL);
+ return (ffelexHandler) ffestb_decl_attrs_7_;
+
+ default:
+ ffesta_ffebad_1t (FFEBAD_INVALID_TYPEDECL_ATTR, t);
+ return (ffelexHandler) ffestb_decl_attrs_7_;
}
- ffelex_token_kill (ffesta_tokens[1]);
- if (ffestb_local_.decl.kindt != NULL)
- ffelex_token_kill (ffestb_local_.decl.kindt);
- if (ffestb_subrargs_.dim_list.dims != NULL)
- ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
- if (ffestb_local_.decl.lent != NULL)
- ffelex_token_kill (ffestb_local_.decl.lent);
- return (ffelexHandler) ffesta_zero (t);
+ break;
default:
break;
if (!ffesta_is_inhibited ())
ffestc_decl_finish ();
- ffelex_token_kill (ffesta_tokens[1]);
- if (ffestb_local_.decl.kindt != NULL)
- ffelex_token_kill (ffestb_local_.decl.kindt);
- if (ffestb_subrargs_.dim_list.dims != NULL)
- ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
- if (ffestb_local_.decl.lent != NULL)
- ffelex_token_kill (ffestb_local_.decl.lent);
ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_decl_ents_9_ -- "type" ... SLASH expr
+/* ffestb_decl_attrs_1_ -- "type" [type parameters] ",DIMENSION"
- (ffestb_decl_ents_9_) // to expression handler
+ return ffestb_decl_attrs_1_; // to lexer
- Handle ASTERISK, COMMA, or SLASH. */
+ Handle OPEN_PAREN. */
static ffelexHandler
-ffestb_decl_ents_9_ (ffelexToken ft, ffebld expr, ffelexToken t)
+ffestb_decl_attrs_1_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeCOMMA:
- if (expr == NULL)
- break;
- if (!ffesta_is_inhibited ())
- ffestc_decl_itemvalue (NULL, NULL, expr, ft);
- return (ffelexHandler) ffeexpr_rhs
- (ffesta_output_pool, FFEEXPR_contextDATA,
- (ffeexprCallback) ffestb_decl_ents_9_);
-
- case FFELEX_typeASTERISK:
- if (expr == NULL)
- break;
- ffestb_local_.decl.expr = expr;
- ffesta_tokens[1] = ffelex_token_use (ft);
- return (ffelexHandler) ffeexpr_rhs
- (ffesta_output_pool, FFEEXPR_contextDATA,
- (ffeexprCallback) ffestb_decl_ents_10_);
-
- case FFELEX_typeSLASH:
- if (expr == NULL)
- break;
- if (!ffesta_is_inhibited ())
- {
- ffestc_decl_itemvalue (NULL, NULL, expr, ft);
- ffestc_decl_itemendvals (t);
- }
- return (ffelexHandler) ffestb_decl_ents_11_;
+ case FFELEX_typeOPEN_PAREN:
+ ffestb_subrargs_.dim_list.dims = ffestt_dimlist_create ();
+ ffestb_subrargs_.dim_list.handler = (ffelexHandler) ffestb_decl_attrs_2_;
+ ffestb_subrargs_.dim_list.pool = ffesta_scratch_pool;
+ ffestb_subrargs_.dim_list.ctx = ffesta_is_entry_valid
+ ? FFEEXPR_contextDIMLIST : FFEEXPR_contextDIMLISTCOMMON;
+#ifdef FFECOM_dimensionsMAX
+ ffestb_subrargs_.dim_list.ndims = 0;
+#endif
+ return (ffelexHandler) ffeexpr_rhs (ffesta_scratch_pool,
+ ffestb_subrargs_.dim_list.ctx,
+ (ffeexprCallback) ffestb_subr_dimlist_);
+
+ case FFELEX_typeCOMMA:
+ case FFELEX_typeCOLONCOLON:
+ ffesta_ffebad_1t (FFEBAD_INVALID_TYPEDECL_ATTR, ffesta_tokens[1]);
+ ffelex_token_kill (ffesta_tokens[1]);
+ return (ffelexHandler) ffestb_decl_attrs_7_ (t);
default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t);
break;
}
if (!ffesta_is_inhibited ())
- {
- ffestc_decl_itemendvals (t);
- ffestc_decl_finish ();
- }
+ ffestc_decl_finish ();
+ ffelex_token_kill (ffesta_tokens[1]);
+ ffesta_ffebad_1t (FFEBAD_INVALID_TYPEDECL_ATTR, t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_decl_ents_10_ -- "type" ... SLASH expr ASTERISK expr
+/* ffestb_decl_attrs_2_ -- "type" [type parameters] ",DIMENSION" OPEN_PAREN
+ dimlist CLOSE_PAREN
- (ffestb_decl_ents_10_) // to expression handler
+ return ffestb_decl_attrs_2_; // to lexer
- Handle COMMA or SLASH. */
+ Handle COMMA or COLONCOLON. */
static ffelexHandler
-ffestb_decl_ents_10_ (ffelexToken ft, ffebld expr, ffelexToken t)
+ffestb_decl_attrs_2_ (ffelexToken t)
{
+ if (!ffestb_subrargs_.dim_list.ok)
+ goto bad; /* :::::::::::::::::::: */
+
switch (ffelex_token_type (t))
{
case FFELEX_typeCOMMA:
- if (expr == NULL)
- break;
- if (!ffesta_is_inhibited ())
- ffestc_decl_itemvalue (ffestb_local_.decl.expr, ffesta_tokens[1],
- expr, ft);
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffeexpr_rhs
- (ffesta_output_pool, FFEEXPR_contextDATA,
- (ffeexprCallback) ffestb_decl_ents_9_);
-
- case FFELEX_typeSLASH:
- if (expr == NULL)
- break;
+ case FFELEX_typeCOLONCOLON:
if (!ffesta_is_inhibited ())
- {
- ffestc_decl_itemvalue (ffestb_local_.decl.expr, ffesta_tokens[1],
- expr, ft);
- ffestc_decl_itemendvals (t);
- }
+ ffestc_decl_attrib (FFESTP_attribDIMENSION, ffesta_tokens[1],
+ FFESTR_otherNone, ffestb_subrargs_.dim_list.dims);
ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffestb_decl_ents_11_;
+ ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
+ return (ffelexHandler) ffestb_decl_attrs_7_ (t);
default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t);
break;
}
+bad: /* :::::::::::::::::::: */
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t);
if (!ffesta_is_inhibited ())
- {
- ffestc_decl_itemendvals (t);
- ffestc_decl_finish ();
- }
+ ffestc_decl_finish ();
+ ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
ffelex_token_kill (ffesta_tokens[1]);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_decl_ents_11_ -- "type" [type parameters] [attributes "::"] NAME
- [ASTERISK NUMBER] [OPEN_PAREN dimlist CLOSE_PAREN]
- [ASTERISK charlength] SLASH initvals SLASH
+/* ffestb_decl_attrs_7_ -- "type" [type parameters] attribute
- return ffestb_decl_ents_11_; // to lexer
+ return ffestb_decl_attrs_7_; // to lexer
- Handle COMMA or EOS/SEMICOLON. */
+ Handle COMMA (another attribute) or COLONCOLON (entities). */
static ffelexHandler
-ffestb_decl_ents_11_ (ffelexToken t)
+ffestb_decl_attrs_7_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
case FFELEX_typeCOMMA:
- return (ffelexHandler) ffestb_decl_ents_;
+ return (ffelexHandler) ffestb_decl_attrs_;
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- if (!ffesta_is_inhibited ())
- ffestc_decl_finish ();
- return (ffelexHandler) ffesta_zero (t);
+ case FFELEX_typeCOLONCOLON:
+ ffestb_local_.decl.coloncolon = TRUE;
+ return (ffelexHandler) ffestb_decl_ents_;
default:
break;
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_decl_entsp_ -- "type" [type parameters]
+/* ffestb_decl_attrsp_ -- "type" [type parameters]
- return ffestb_decl_entsp_; // to lexer
+ return ffestb_decl_attrsp_; // to lexer
- Handle NAME or NAMES beginning either an entity (object) declaration or
- a function definition.. */
+ Handle COMMA (meaning we have attributes), COLONCOLON (meaning we have
+ no attributes but entities), or go to entsp to see about functions or
+ entities. */
static ffelexHandler
-ffestb_decl_entsp_ (ffelexToken t)
+ffestb_decl_attrsp_ (ffelexToken t)
{
+ ffelex_set_names (FALSE);
+
switch (ffelex_token_type (t))
{
- case FFELEX_typeNAME:
+ case FFELEX_typeCOMMA:
ffesta_confirmed ();
- ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_decl_entsp_1_;
+ if (!ffesta_is_inhibited ())
+ ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0],
+ ffestb_local_.decl.kind, ffestb_local_.decl.kindt,
+ ffestb_local_.decl.len, ffestb_local_.decl.lent);
+ if (ffestb_local_.decl.kindt != NULL)
+ ffelex_token_kill (ffestb_local_.decl.kindt);
+ if (ffestb_local_.decl.lent != NULL)
+ ffelex_token_kill (ffestb_local_.decl.lent);
+ return (ffelexHandler) ffestb_decl_attrs_;
- case FFELEX_typeNAMES:
+ case FFELEX_typeCOLONCOLON:
+ ffestb_local_.decl.coloncolon = TRUE;
ffesta_confirmed ();
- ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_decl_entsp_2_;
+ if (!ffesta_is_inhibited ())
+ ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0],
+ ffestb_local_.decl.kind, ffestb_local_.decl.kindt,
+ ffestb_local_.decl.len, ffestb_local_.decl.lent);
+ if (ffestb_local_.decl.kindt != NULL)
+ ffelex_token_kill (ffestb_local_.decl.kindt);
+ if (ffestb_local_.decl.lent != NULL)
+ ffelex_token_kill (ffestb_local_.decl.lent);
+ return (ffelexHandler) ffestb_decl_ents_;
default:
- break;
+ return (ffelexHandler) ffestb_decl_entsp_ (t);
}
-
- if (ffestb_local_.decl.kindt != NULL)
- ffelex_token_kill (ffestb_local_.decl.kindt);
- if (ffestb_local_.decl.lent != NULL)
- ffelex_token_kill (ffestb_local_.decl.lent);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_decl_entsp_1_ -- "type" [type parameters] NAME
+/* ffestb_decl_ents_ -- "type" [type parameters] [attributes "::"]
- return ffestb_decl_entsp_1_; // to lexer
+ return ffestb_decl_ents_; // to lexer
- If we get another NAME token here, then the previous one must be
- "RECURSIVE" or "FUNCTION" and we handle it accordingly. Otherwise,
- we send the previous and current token through to _ents_. */
+ Handle NAME of an entity. */
static ffelexHandler
-ffestb_decl_entsp_1_ (ffelexToken t)
+ffestb_decl_ents_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
case FFELEX_typeNAME:
- switch (ffestr_first (ffesta_tokens[1]))
- {
-#if FFESTR_F90
- case FFESTR_firstRECURSIVE:
- if (ffestr_first (t) != FFESTR_firstFUNCTION)
- {
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t);
- break;
- }
- ffestb_local_.decl.recursive = ffesta_tokens[1];
- return (ffelexHandler) ffestb_decl_funcname_;
-#endif
-
- case FFESTR_firstFUNCTION:
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffestb_decl_funcname_ (t);
-
- default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", ffesta_tokens[1]);
- break;
- }
- break;
+ ffesta_tokens[1] = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_decl_ents_1_;
default:
- if ((ffelex_token_type (ffesta_tokens[1]) != FFELEX_typeNAMES)
- && !ffesta_is_inhibited ())
- ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0],
- ffestb_local_.decl.kind, ffestb_local_.decl.kindt,
- ffestb_local_.decl.len, ffestb_local_.decl.lent);
- if (ffestb_local_.decl.kindt != NULL)
- ffelex_token_kill (ffestb_local_.decl.kindt);
- if (ffestb_local_.decl.lent != NULL)
- ffelex_token_kill (ffestb_local_.decl.lent);
- /* NAME/NAMES token already in ffesta_tokens[1]. */
- return (ffelexHandler) ffestb_decl_ents_1_ (t);
+ break;
}
- if (ffestb_local_.decl.kindt != NULL)
- ffelex_token_kill (ffestb_local_.decl.kindt);
- if (ffestb_local_.decl.lent != NULL)
- ffelex_token_kill (ffestb_local_.decl.lent);
- ffelex_token_kill (ffesta_tokens[1]);
+ if (!ffesta_is_inhibited ())
+ ffestc_decl_finish ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_decl_entsp_2_ -- "type" [type parameters] NAMES
+/* ffestb_decl_ents_1_ -- "type" [type parameters] [attributes "::"] NAME
- return ffestb_decl_entsp_2_; // to lexer
+ return ffestb_decl_ents_1_; // to lexer
- If we get an ASTERISK or OPEN_PAREN here, then if the previous NAMES
- begins with "FUNCTION" or "RECURSIVEFUNCTION" and is followed by a
- first-name-char, we have a possible syntactically ambiguous situation.
- Otherwise, we have a straightforward situation just as if we went
- through _entsp_1_ instead of here. */
+ Handle ASTERISK, OPEN_PAREN, EQUALS, SLASH, COMMA, or EOS/SEMICOLON. */
static ffelexHandler
-ffestb_decl_entsp_2_ (ffelexToken t)
+ffestb_decl_ents_1_ (ffelexToken t)
{
- ffelexToken nt;
- bool asterisk_ok;
- unsigned const char *p;
- ffeTokenLength i;
-
switch (ffelex_token_type (t))
{
- case FFELEX_typeASTERISK:
- ffesta_confirmed ();
- switch (ffestb_local_.decl.type)
- {
- case FFESTP_typeINTEGER:
- case FFESTP_typeREAL:
- case FFESTP_typeCOMPLEX:
- case FFESTP_typeLOGICAL:
- asterisk_ok = (ffestb_local_.decl.kindt == NULL);
- break;
-
- case FFESTP_typeCHARACTER:
- asterisk_ok = (ffestb_local_.decl.lent == NULL);
- break;
+ case FFELEX_typeCOMMA:
+ if (!ffesta_is_inhibited ())
+ ffestc_decl_item (ffesta_tokens[1], NULL, NULL, NULL, NULL, NULL, NULL,
+ NULL, FALSE);
+ ffelex_token_kill (ffesta_tokens[1]);
+ return (ffelexHandler) ffestb_decl_ents_;
- case FFESTP_typeBYTE:
- case FFESTP_typeWORD:
- default:
- asterisk_ok = FALSE;
- break;
- }
- switch (ffestr_first (ffesta_tokens[1]))
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ if (!ffesta_is_inhibited ())
{
-#if FFESTR_F90
- case FFESTR_firstRECURSIVEFNCTN:
- if (!asterisk_ok)
- break; /* For our own convenience, treat as non-FN
- stmt. */
- p = ffelex_token_text (ffesta_tokens[1])
- + (i = FFESTR_firstlRECURSIVEFNCTN);
- if (!ffesrc_is_name_init (*p))
- break;
- ffestb_local_.decl.recursive
- = ffelex_token_name_from_names (ffesta_tokens[1], 0,
- FFESTR_firstlRECURSIVEFNCTN);
- ffesta_tokens[2] = ffelex_token_name_from_names (ffesta_tokens[1],
- FFESTR_firstlRECURSIVEFNCTN, 0);
- return (ffelexHandler) ffestb_decl_entsp_3_;
-#endif
-
- case FFESTR_firstFUNCTION:
- if (!asterisk_ok)
- break; /* For our own convenience, treat as non-FN
- stmt. */
- p = ffelex_token_text (ffesta_tokens[1])
- + (i = FFESTR_firstlFUNCTION);
- if (!ffesrc_is_name_init (*p))
- break;
- ffestb_local_.decl.recursive = NULL;
- ffesta_tokens[2] = ffelex_token_name_from_names (ffesta_tokens[1],
- FFESTR_firstlFUNCTION, 0);
- return (ffelexHandler) ffestb_decl_entsp_3_;
-
- default:
- break;
+ ffestc_decl_item (ffesta_tokens[1], NULL, NULL, NULL, NULL, NULL, NULL,
+ NULL, FALSE);
+ ffestc_decl_finish ();
}
- break;
+ ffelex_token_kill (ffesta_tokens[1]);
+ return (ffelexHandler) ffesta_zero (t);
- case FFELEX_typeOPEN_PAREN:
- ffestb_local_.decl.aster_after = FALSE;
- switch (ffestr_first (ffesta_tokens[1]))
- {
-#if FFESTR_F90
- case FFESTR_firstRECURSIVEFNCTN:
- p = ffelex_token_text (ffesta_tokens[1])
- + (i = FFESTR_firstlRECURSIVEFNCTN);
- if (!ffesrc_is_name_init (*p))
- break;
- ffestb_local_.decl.recursive
- = ffelex_token_name_from_names (ffesta_tokens[1], 0,
- FFESTR_firstlRECURSIVEFNCTN);
- ffesta_tokens[2] = ffelex_token_name_from_names (ffesta_tokens[1],
- FFESTR_firstlRECURSIVEFNCTN, 0);
- return (ffelexHandler) ffestb_decl_entsp_5_ (t);
-#endif
+ case FFELEX_typeASTERISK:
+ ffestb_local_.decl.len = NULL;
+ ffestb_local_.decl.lent = NULL;
+ return (ffelexHandler) ffestb_decl_ents_2_;
- case FFESTR_firstFUNCTION:
- p = ffelex_token_text (ffesta_tokens[1])
- + (i = FFESTR_firstlFUNCTION);
- if (!ffesrc_is_name_init (*p))
- break;
- ffestb_local_.decl.recursive = NULL;
- ffesta_tokens[2] = ffelex_token_name_from_names (ffesta_tokens[1],
- FFESTR_firstlFUNCTION, 0);
- return (ffelexHandler) ffestb_decl_entsp_5_ (t);
+ case FFELEX_typeOPEN_PAREN:
+ ffestb_local_.decl.kind = NULL;
+ ffestb_local_.decl.kindt = NULL;
+ ffestb_local_.decl.len = NULL;
+ ffestb_local_.decl.lent = NULL;
+ return (ffelexHandler) ffestb_decl_ents_3_ (t);
- default:
- break;
- }
- if ((ffestb_local_.decl.kindt != NULL)
- || (ffestb_local_.decl.lent != NULL))
- break; /* Have kind/len type param, definitely not
- assignment stmt. */
- return (ffelexHandler) ffestb_decl_entsp_1_ (t);
+ case FFELEX_typeEQUALS:
+ case FFELEX_typeSLASH:
+ ffestb_local_.decl.kind = NULL;
+ ffestb_local_.decl.kindt = NULL;
+ ffestb_subrargs_.dim_list.dims = NULL;
+ ffestb_local_.decl.len = NULL;
+ ffestb_local_.decl.lent = NULL;
+ return (ffelexHandler) ffestb_decl_ents_7_ (t);
default:
break;
}
- nt = ffelex_token_name_from_names (ffesta_tokens[1], 0, 0);
+ if (!ffesta_is_inhibited ())
+ ffestc_decl_finish ();
ffelex_token_kill (ffesta_tokens[1]);
- ffesta_tokens[1] = nt; /* Change NAMES to NAME. */
- return (ffelexHandler) ffestb_decl_entsp_1_ (t);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t);
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_decl_entsp_3_ -- "type" [type parameters] [RECURSIVE] FUNCTION
- NAME ASTERISK
+/* ffestb_decl_ents_2_ -- "type" [type parameters] [attributes "::"] NAME
+ ASTERISK
- return ffestb_decl_entsp_3_; // to lexer
+ return ffestb_decl_ents_2_; // to lexer
Handle NUMBER or OPEN_PAREN. */
static ffelexHandler
-ffestb_decl_entsp_3_ (ffelexToken t)
+ffestb_decl_ents_2_ (ffelexToken t)
{
- ffestb_local_.decl.aster_after = TRUE;
-
switch (ffelex_token_type (t))
{
case FFELEX_typeNUMBER:
- switch (ffestb_local_.decl.type)
+ if (ffestb_local_.decl.type != FFESTP_typeCHARACTER)
{
- case FFESTP_typeINTEGER:
- case FFESTP_typeREAL:
- case FFESTP_typeCOMPLEX:
- case FFESTP_typeLOGICAL:
+ ffestb_local_.decl.kind = NULL;
ffestb_local_.decl.kindt = ffelex_token_use (t);
- break;
+ return (ffelexHandler) ffestb_decl_ents_3_;
+ }
+ /* Fall through. *//* (CHARACTER's *n is always a len spec. */
+ case FFELEX_typeOPEN_PAREN:/* "*(" is after the (omitted)
+ "(array-spec)". */
+ ffestb_local_.decl.kind = NULL;
+ ffestb_local_.decl.kindt = NULL;
+ ffestb_subrargs_.dim_list.dims = NULL;
+ return (ffelexHandler) ffestb_decl_ents_5_ (t);
- case FFESTP_typeCHARACTER:
- ffestb_local_.decl.lent = ffelex_token_use (t);
- break;
+ default:
+ break;
+ }
- case FFESTP_typeBYTE:
- case FFESTP_typeWORD:
- default:
- assert (FALSE);
+ if (!ffesta_is_inhibited ())
+ ffestc_decl_finish ();
+ ffelex_token_kill (ffesta_tokens[1]);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t);
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+}
+
+/* ffestb_decl_ents_3_ -- "type" [type parameters] [attributes "::"] NAME
+ [ASTERISK NUMBER]
+
+ return ffestb_decl_ents_3_; // to lexer
+
+ Handle ASTERISK, OPEN_PAREN, EQUALS, SLASH, COMMA, or EOS/SEMICOLON. */
+
+static ffelexHandler
+ffestb_decl_ents_3_ (ffelexToken t)
+{
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeCOMMA:
+ if (!ffesta_is_inhibited ())
+ ffestc_decl_item (ffesta_tokens[1], ffestb_local_.decl.kind,
+ ffestb_local_.decl.kindt, NULL, NULL, NULL, NULL, NULL, FALSE);
+ ffelex_token_kill (ffesta_tokens[1]);
+ if (ffestb_local_.decl.kindt != NULL)
+ ffelex_token_kill (ffestb_local_.decl.kindt);
+ return (ffelexHandler) ffestb_decl_ents_;
+
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ if (!ffesta_is_inhibited ())
+ {
+ ffestc_decl_item (ffesta_tokens[1], ffestb_local_.decl.kind,
+ ffestb_local_.decl.kindt, NULL, NULL, NULL, NULL, NULL, FALSE);
+ ffestc_decl_finish ();
}
- return (ffelexHandler) ffestb_decl_entsp_5_;
+ ffelex_token_kill (ffesta_tokens[1]);
+ if (ffestb_local_.decl.kindt != NULL)
+ ffelex_token_kill (ffestb_local_.decl.kindt);
+ return (ffelexHandler) ffesta_zero (t);
+
+ case FFELEX_typeASTERISK:
+ ffestb_subrargs_.dim_list.dims = NULL;
+ return (ffelexHandler) ffestb_decl_ents_5_;
case FFELEX_typeOPEN_PAREN:
+ ffestb_subrargs_.dim_list.dims = ffestt_dimlist_create ();
+ ffestb_subrargs_.dim_list.handler = (ffelexHandler) ffestb_decl_ents_4_;
+ ffestb_subrargs_.dim_list.pool = ffesta_output_pool;
+ ffestb_subrargs_.dim_list.ctx = ffesta_is_entry_valid
+ ? FFEEXPR_contextDIMLIST : FFEEXPR_contextDIMLISTCOMMON;
+#ifdef FFECOM_dimensionsMAX
+ ffestb_subrargs_.dim_list.ndims = 0;
+#endif
return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextCHARACTERSIZE,
- (ffeexprCallback) ffestb_decl_entsp_4_);
+ ffestb_subrargs_.dim_list.ctx,
+ (ffeexprCallback) ffestb_subr_dimlist_);
+
+ case FFELEX_typeEQUALS:
+ case FFELEX_typeSLASH:
+ ffestb_local_.decl.kind = NULL;
+ ffestb_local_.decl.kindt = NULL;
+ ffestb_subrargs_.dim_list.dims = NULL;
+ ffestb_local_.decl.len = NULL;
+ ffestb_local_.decl.lent = NULL;
+ return (ffelexHandler) ffestb_decl_ents_7_ (t);
default:
break;
}
- if (ffestb_local_.decl.recursive != NULL)
- ffelex_token_kill (ffestb_local_.decl.recursive);
+ if (!ffesta_is_inhibited ())
+ ffestc_decl_finish ();
+ ffelex_token_kill (ffesta_tokens[1]);
if (ffestb_local_.decl.kindt != NULL)
ffelex_token_kill (ffestb_local_.decl.kindt);
- if (ffestb_local_.decl.lent != NULL)
- ffelex_token_kill (ffestb_local_.decl.lent);
- ffelex_token_kill (ffesta_tokens[1]);
- ffelex_token_kill (ffesta_tokens[2]);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_decl_entsp_4_ -- "type" [type parameters] [RECURSIVE] FUNCTION
- NAME ASTERISK OPEN_PAREN expr
+/* ffestb_decl_ents_4_ -- "type" [type parameters] [attributes "::"] NAME
+ [ASTERISK NUMBER] [OPEN_PAREN dimlist CLOSE_PAREN]
- (ffestb_decl_entsp_4_) // to expression handler
+ return ffestb_decl_ents_4_; // to lexer
- Allow only CLOSE_PAREN; and deal with character-length expression. */
+ Handle ASTERISK, EQUALS, SLASH, COMMA, or EOS/SEMICOLON. */
static ffelexHandler
-ffestb_decl_entsp_4_ (ffelexToken ft, ffebld expr, ffelexToken t)
+ffestb_decl_ents_4_ (ffelexToken t)
{
- switch (ffelex_token_type (t))
+ ffelexToken nt;
+
+ if (!ffestb_subrargs_.dim_list.ok)
+ goto bad; /* :::::::::::::::::::: */
+
+ if (ffelex_token_type (ffesta_tokens[1]) == FFELEX_typeNAMES)
{
- case FFELEX_typeCLOSE_PAREN:
- if (expr == NULL)
- break;
- switch (ffestb_local_.decl.type)
+ switch (ffelex_token_type (t))
{
- case FFESTP_typeCHARACTER:
- ffestb_local_.decl.len = expr;
- ffestb_local_.decl.lent = ffelex_token_use (ft);
- break;
+ case FFELEX_typeCOMMA:
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ case FFELEX_typeASTERISK:
+ case FFELEX_typeSLASH: /* But NOT FFELEX_typeEQUALS. */
+ case FFELEX_typeCOLONCOLON: /* Actually an error. */
+ break; /* Confirm and handle. */
- default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t);
- break;
+ default: /* Perhaps EQUALS, as in
+ INTEGERFUNCTIONX(A)=B. */
+ goto bad; /* :::::::::::::::::::: */
}
- return (ffelexHandler) ffestb_decl_entsp_5_;
+ ffesta_confirmed ();
+ if (!ffesta_is_inhibited ())
+ {
+ nt = ffelex_token_name_from_names (ffesta_tokens[1], 0, 0);
+ ffelex_token_kill (ffesta_tokens[1]);
+ ffesta_tokens[1] = nt;
+ ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0],
+ NULL, NULL, NULL, NULL);
+ }
+ }
+
+ switch (ffelex_token_type (t))
+ {
+ case FFELEX_typeCOMMA:
+ if (!ffesta_is_inhibited ())
+ ffestc_decl_item (ffesta_tokens[1], ffestb_local_.decl.kind,
+ ffestb_local_.decl.kindt, ffestb_subrargs_.dim_list.dims,
+ ffestb_local_.decl.len, ffestb_local_.decl.lent, NULL, NULL,
+ FALSE);
+ ffelex_token_kill (ffesta_tokens[1]);
+ if (ffestb_local_.decl.kindt != NULL)
+ ffelex_token_kill (ffestb_local_.decl.kindt);
+ if (ffestb_local_.decl.lent != NULL)
+ ffelex_token_kill (ffestb_local_.decl.lent);
+ ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
+ return (ffelexHandler) ffestb_decl_ents_;
+
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ if (!ffesta_is_inhibited ())
+ {
+ ffestc_decl_item (ffesta_tokens[1], ffestb_local_.decl.kind,
+ ffestb_local_.decl.kindt, ffestb_subrargs_.dim_list.dims,
+ ffestb_local_.decl.len, ffestb_local_.decl.lent, NULL, NULL,
+ FALSE);
+ ffestc_decl_finish ();
+ }
+ ffelex_token_kill (ffesta_tokens[1]);
+ if (ffestb_local_.decl.kindt != NULL)
+ ffelex_token_kill (ffestb_local_.decl.kindt);
+ if (ffestb_local_.decl.lent != NULL)
+ ffelex_token_kill (ffestb_local_.decl.lent);
+ ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
+ return (ffelexHandler) ffesta_zero (t);
+
+ case FFELEX_typeASTERISK:
+ if (ffestb_local_.decl.lent != NULL)
+ break; /* Can't specify "*length" twice. */
+ return (ffelexHandler) ffestb_decl_ents_5_;
+
+ case FFELEX_typeEQUALS:
+ case FFELEX_typeSLASH:
+ return (ffelexHandler) ffestb_decl_ents_7_ (t);
default:
break;
}
- if (ffestb_local_.decl.recursive != NULL)
- ffelex_token_kill (ffestb_local_.decl.recursive);
+bad: /* :::::::::::::::::::: */
+ if ((ffelex_token_type (ffesta_tokens[1]) != FFELEX_typeNAMES)
+ && !ffesta_is_inhibited ())
+ ffestc_decl_finish ();
+ ffelex_token_kill (ffesta_tokens[1]);
if (ffestb_local_.decl.kindt != NULL)
ffelex_token_kill (ffestb_local_.decl.kindt);
if (ffestb_local_.decl.lent != NULL)
ffelex_token_kill (ffestb_local_.decl.lent);
- ffelex_token_kill (ffesta_tokens[1]);
- ffelex_token_kill (ffesta_tokens[2]);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t);
+ ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_decl_entsp_5_ -- "type" [type parameters] [RECURSIVE] FUNCTION
- NAME [type parameter]
+/* ffestb_decl_ents_5_ -- "type" [type parameters] [attributes "::"] NAME
+ [ASTERISK NUMBER] [OPEN_PAREN dimlist CLOSE_PAREN]
+ ASTERISK
- return ffestb_decl_entsp_5_; // to lexer
+ return ffestb_decl_ents_5_; // to lexer
- Make sure the next token is an OPEN_PAREN. Get the arg list or dimension
- list. If it can't be an arg list, or if the CLOSE_PAREN is followed by
- something other than EOS/SEMICOLON or NAME, then treat as dimension list
- and handle statement as an R426/R501. If it can't be a dimension list, or
- if the CLOSE_PAREN is followed by NAME, treat as an arg list and handle
- statement as an R1219. If it can be either an arg list or a dimension
- list and if the CLOSE_PAREN is followed by EOS/SEMICOLON, ask FFESTC
- whether to treat the statement as an R426/R501 or an R1219 and act
- accordingly. */
+ Handle NUMBER or OPEN_PAREN. */
static ffelexHandler
-ffestb_decl_entsp_5_ (ffelexToken t)
+ffestb_decl_ents_5_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
+ case FFELEX_typeNUMBER:
+ ffestb_local_.decl.len = NULL;
+ ffestb_local_.decl.lent = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_decl_ents_7_;
+
case FFELEX_typeOPEN_PAREN:
- if (ffestb_local_.decl.aster_after && (ffestb_local_.decl.len != NULL))
- { /* "CHARACTER[RECURSIVE]FUNCTIONxyz*(len-expr)
- (..." must be a function-stmt, since the
- (len-expr) cannot precede (array-spec) in
- an object declaration but can precede
- (name-list) in a function stmt. */
- ffelex_token_kill (ffesta_tokens[1]);
- ffesta_tokens[1] = ffesta_tokens[2];
- return (ffelexHandler) ffestb_decl_funcname_4_ (t);
- }
- ffestb_local_.decl.toklist = ffestt_tokenlist_create ();
- ffestb_local_.decl.empty = TRUE;
- ffestt_tokenlist_append (ffestb_local_.decl.toklist, ffelex_token_use (t));
- return (ffelexHandler) ffestb_decl_entsp_6_;
+ return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ FFEEXPR_contextCHARACTERSIZE, (ffeexprCallback) ffestb_decl_ents_6_);
default:
break;
}
- assert (ffestb_local_.decl.aster_after);
- ffesta_confirmed (); /* We've seen an ASTERISK, so even EQUALS
- confirmed. */
- ffestb_subr_ambig_to_ents_ ();
- ffestb_subrargs_.dim_list.dims = NULL;
- return (ffelexHandler) ffestb_decl_ents_7_ (t);
+ if (!ffesta_is_inhibited ())
+ ffestc_decl_finish ();
+ ffelex_token_kill (ffesta_tokens[1]);
+ if (ffestb_local_.decl.kindt != NULL)
+ ffelex_token_kill (ffestb_local_.decl.kindt);
+ if (ffestb_subrargs_.dim_list.dims != NULL)
+ ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t);
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_decl_entsp_6_ -- "type" [type parameters] [RECURSIVE] FUNCTION
- NAME [type parameter] OPEN_PAREN
+/* ffestb_decl_ents_6_ -- "type" [type parameters] [attributes "::"] NAME
+ [ASTERISK NUMBER] [OPEN_PAREN dimlist CLOSE_PAREN]
+ ASTERISK OPEN_PAREN expr
- return ffestb_decl_entsp_6_; // to lexer
+ (ffestb_decl_ents_6_) // to expression handler
- If CLOSE_PAREN, we definitely have an R1219 function-stmt, since
- the notation "name()" is invalid for a declaration. */
+ Handle CLOSE_PAREN. */
static ffelexHandler
-ffestb_decl_entsp_6_ (ffelexToken t)
+ffestb_decl_ents_6_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
- ffelexHandler next;
-
switch (ffelex_token_type (t))
{
case FFELEX_typeCLOSE_PAREN:
- if (!ffestb_local_.decl.empty)
- { /* Trailing comma, just a warning for
- stmt func def, so allow ambiguity. */
- ffestt_tokenlist_append (ffestb_local_.decl.toklist,
- ffelex_token_use (t));
- return (ffelexHandler) ffestb_decl_entsp_8_;
- }
- ffelex_token_kill (ffesta_tokens[1]);
- ffesta_tokens[1] = ffesta_tokens[2];
- next = (ffelexHandler) ffestt_tokenlist_handle
- (ffestb_local_.decl.toklist, (ffelexHandler) ffestb_decl_funcname_4_);
- ffestt_tokenlist_kill (ffestb_local_.decl.toklist);
- return (ffelexHandler) (*next) (t);
-
- case FFELEX_typeNAME:
- ffestb_local_.decl.empty = FALSE;
- ffestt_tokenlist_append (ffestb_local_.decl.toklist, ffelex_token_use (t));
- return (ffelexHandler) ffestb_decl_entsp_7_;
-
- case FFELEX_typeEQUALS:
- case FFELEX_typePOINTS:
- case FFELEX_typePERCENT:
- case FFELEX_typePERIOD:
- case FFELEX_typeOPEN_PAREN:
- if ((ffestb_local_.decl.kindt != NULL)
- || (ffestb_local_.decl.lent != NULL))
- break; /* type(params)name or type*val name, either
- way confirmed. */
- return (ffelexHandler) ffestb_subr_ambig_nope_ (t);
+ if (expr == NULL)
+ break;
+ ffestb_local_.decl.len = expr;
+ ffestb_local_.decl.lent = ffelex_token_use (ft);
+ return (ffelexHandler) ffestb_decl_ents_7_;
default:
break;
}
- ffesta_confirmed ();
- ffestb_subr_ambig_to_ents_ ();
- next = (ffelexHandler) ffestt_tokenlist_handle (ffestb_local_.decl.toklist,
- (ffelexHandler) ffestb_decl_ents_3_);
- ffestt_tokenlist_kill (ffestb_local_.decl.toklist);
- return (ffelexHandler) (*next) (t);
+ if (!ffesta_is_inhibited ())
+ ffestc_decl_finish ();
+ ffelex_token_kill (ffesta_tokens[1]);
+ if (ffestb_local_.decl.kindt != NULL)
+ ffelex_token_kill (ffestb_local_.decl.kindt);
+ if (ffestb_subrargs_.dim_list.dims != NULL)
+ ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t);
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_decl_entsp_7_ -- "type" [type parameters] [RECURSIVE] FUNCTION
- NAME [type parameter] OPEN_PAREN NAME
+/* ffestb_decl_ents_7_ -- "type" [type parameters] [attributes "::"] NAME
+ [ASTERISK NUMBER] [OPEN_PAREN dimlist CLOSE_PAREN]
+ [ASTERISK charlength]
- return ffestb_decl_entsp_7_; // to lexer
+ return ffestb_decl_ents_7_; // to lexer
- Expect COMMA or CLOSE_PAREN to remain ambiguous, else not an R1219
- function-stmt. */
+ Handle EQUALS, SLASH, COMMA, or EOS/SEMICOLON. */
static ffelexHandler
-ffestb_decl_entsp_7_ (ffelexToken t)
+ffestb_decl_ents_7_ (ffelexToken t)
{
- ffelexHandler next;
-
switch (ffelex_token_type (t))
{
- case FFELEX_typeCLOSE_PAREN:
- ffestt_tokenlist_append (ffestb_local_.decl.toklist, ffelex_token_use (t));
- return (ffelexHandler) ffestb_decl_entsp_8_;
-
case FFELEX_typeCOMMA:
- ffestt_tokenlist_append (ffestb_local_.decl.toklist, ffelex_token_use (t));
- return (ffelexHandler) ffestb_decl_entsp_6_;
-
- case FFELEX_typeEQUALS:
- case FFELEX_typePOINTS:
- case FFELEX_typePERCENT:
- case FFELEX_typePERIOD:
- case FFELEX_typeOPEN_PAREN:
- if ((ffestb_local_.decl.kindt != NULL)
- || (ffestb_local_.decl.lent != NULL))
- break; /* type(params)name or type*val name, either
- way confirmed. */
- return (ffelexHandler) ffestb_subr_ambig_nope_ (t);
-
- default:
- break;
- }
-
- ffesta_confirmed ();
- ffestb_subr_ambig_to_ents_ ();
- next = (ffelexHandler) ffestt_tokenlist_handle (ffestb_local_.decl.toklist,
- (ffelexHandler) ffestb_decl_ents_3_);
- ffestt_tokenlist_kill (ffestb_local_.decl.toklist);
- return (ffelexHandler) (*next) (t);
-}
-
-/* ffestb_decl_entsp_8_ -- "type" [type parameters] [RECURSIVE] FUNCTION
- NAME [type parameter] OPEN_PAREN name-list
- CLOSE_PAREN
-
- return ffestb_decl_entsp_8_; // to lexer
-
- If EOS/SEMICOLON, situation remains ambiguous, ask FFESTC to resolve
- it. If NAME (must be "RESULT", but that is checked later on),
- definitely an R1219 function-stmt. Anything else, handle as entity decl. */
-
-static ffelexHandler
-ffestb_decl_entsp_8_ (ffelexToken t)
-{
- ffelexHandler next;
+ if (!ffesta_is_inhibited ())
+ ffestc_decl_item (ffesta_tokens[1], ffestb_local_.decl.kind,
+ ffestb_local_.decl.kindt, ffestb_subrargs_.dim_list.dims,
+ ffestb_local_.decl.len, ffestb_local_.decl.lent, NULL, NULL,
+ FALSE);
+ ffelex_token_kill (ffesta_tokens[1]);
+ if (ffestb_local_.decl.kindt != NULL)
+ ffelex_token_kill (ffestb_local_.decl.kindt);
+ if (ffestb_subrargs_.dim_list.dims != NULL)
+ ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
+ if (ffestb_local_.decl.lent != NULL)
+ ffelex_token_kill (ffestb_local_.decl.lent);
+ return (ffelexHandler) ffestb_decl_ents_;
- switch (ffelex_token_type (t))
- {
case FFELEX_typeEOS:
case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- if (ffestc_is_decl_not_R1219 ())
- break;
- /* Fall through. */
- case FFELEX_typeNAME:
- ffesta_confirmed ();
+ if (!ffesta_is_inhibited ())
+ {
+ ffestc_decl_item (ffesta_tokens[1], ffestb_local_.decl.kind,
+ ffestb_local_.decl.kindt, ffestb_subrargs_.dim_list.dims,
+ ffestb_local_.decl.len, ffestb_local_.decl.lent, NULL, NULL,
+ FALSE);
+ ffestc_decl_finish ();
+ }
ffelex_token_kill (ffesta_tokens[1]);
- ffesta_tokens[1] = ffesta_tokens[2];
- next = (ffelexHandler) ffestt_tokenlist_handle
- (ffestb_local_.decl.toklist, (ffelexHandler) ffestb_decl_funcname_4_);
- ffestt_tokenlist_kill (ffestb_local_.decl.toklist);
- return (ffelexHandler) (*next) (t);
+ if (ffestb_local_.decl.kindt != NULL)
+ ffelex_token_kill (ffestb_local_.decl.kindt);
+ if (ffestb_subrargs_.dim_list.dims != NULL)
+ ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
+ if (ffestb_local_.decl.lent != NULL)
+ ffelex_token_kill (ffestb_local_.decl.lent);
+ return (ffelexHandler) ffesta_zero (t);
case FFELEX_typeEQUALS:
- case FFELEX_typePOINTS:
- case FFELEX_typePERCENT:
- case FFELEX_typePERIOD:
- case FFELEX_typeOPEN_PAREN:
- if ((ffestb_local_.decl.kindt != NULL)
- || (ffestb_local_.decl.lent != NULL))
- break; /* type(params)name or type*val name, either
- way confirmed. */
- return (ffelexHandler) ffestb_subr_ambig_nope_ (t);
+ if (!ffestb_local_.decl.coloncolon)
+ ffesta_ffebad_1t (FFEBAD_INVALID_TYPEDECL_INIT, t);
+ return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ ffestb_local_.decl.parameter ? FFEEXPR_contextPARAMETER
+ : FFEEXPR_contextINITVAL, (ffeexprCallback) ffestb_decl_ents_8_);
+
+ case FFELEX_typeSLASH:
+ if (!ffesta_is_inhibited ())
+ {
+ ffestc_decl_item (ffesta_tokens[1], ffestb_local_.decl.kind,
+ ffestb_local_.decl.kindt, ffestb_subrargs_.dim_list.dims,
+ ffestb_local_.decl.len, ffestb_local_.decl.lent, NULL, NULL,
+ TRUE);
+ ffestc_decl_itemstartvals ();
+ }
+ ffelex_token_kill (ffesta_tokens[1]);
+ if (ffestb_local_.decl.kindt != NULL)
+ ffelex_token_kill (ffestb_local_.decl.kindt);
+ if (ffestb_subrargs_.dim_list.dims != NULL)
+ ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
+ if (ffestb_local_.decl.lent != NULL)
+ ffelex_token_kill (ffestb_local_.decl.lent);
+ return (ffelexHandler) ffeexpr_rhs
+ (ffesta_output_pool, FFEEXPR_contextDATA,
+ (ffeexprCallback) ffestb_decl_ents_9_);
default:
break;
}
- ffesta_confirmed ();
- ffestb_subr_ambig_to_ents_ ();
- next = (ffelexHandler) ffestt_tokenlist_handle (ffestb_local_.decl.toklist,
- (ffelexHandler) ffestb_decl_ents_3_);
- ffestt_tokenlist_kill (ffestb_local_.decl.toklist);
- return (ffelexHandler) (*next) (t);
+ if (!ffesta_is_inhibited ())
+ ffestc_decl_finish ();
+ ffelex_token_kill (ffesta_tokens[1]);
+ if (ffestb_local_.decl.kindt != NULL)
+ ffelex_token_kill (ffestb_local_.decl.kindt);
+ if (ffestb_subrargs_.dim_list.dims != NULL)
+ ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
+ if (ffestb_local_.decl.lent != NULL)
+ ffelex_token_kill (ffestb_local_.decl.lent);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t);
+ return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_decl_func_ -- ["type" [type parameters]] RECURSIVE
+/* ffestb_decl_ents_8_ -- "type" [type parameters] [attributes "::"] NAME
+ [ASTERISK NUMBER] [OPEN_PAREN dimlist CLOSE_PAREN]
+ [ASTERISK charlength] EQUALS expr
- return ffestb_decl_func_; // to lexer
+ (ffestb_decl_ents_8_) // to expression handler
- Handle "FUNCTION". */
+ Handle COMMA or EOS/SEMICOLON. */
-#if FFESTR_F90
static ffelexHandler
-ffestb_decl_func_ (ffelexToken t)
+ffestb_decl_ents_8_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
- const char *p;
- ffeTokenLength i;
-
- ffelex_set_names (FALSE);
-
switch (ffelex_token_type (t))
{
- case FFELEX_typeNAME:
- if (ffestr_first (t) != FFESTR_firstFUNCTION)
+ case FFELEX_typeCOMMA:
+ if (expr == NULL)
break;
- return (ffelexHandler) ffestb_decl_funcname_;
+ if (!ffesta_is_inhibited ())
+ ffestc_decl_item (ffesta_tokens[1], ffestb_local_.decl.kind,
+ ffestb_local_.decl.kindt, ffestb_subrargs_.dim_list.dims,
+ ffestb_local_.decl.len, ffestb_local_.decl.lent, expr, ft,
+ FALSE);
+ ffelex_token_kill (ffesta_tokens[1]);
+ if (ffestb_local_.decl.kindt != NULL)
+ ffelex_token_kill (ffestb_local_.decl.kindt);
+ if (ffestb_subrargs_.dim_list.dims != NULL)
+ ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
+ if (ffestb_local_.decl.lent != NULL)
+ ffelex_token_kill (ffestb_local_.decl.lent);
+ return (ffelexHandler) ffestb_decl_ents_;
- case FFELEX_typeNAMES:
- ffesta_confirmed ();
- if (ffestr_first (t) != FFESTR_firstFUNCTION)
- break;
- p = ffelex_token_text (t) + (i = FFESTR_firstlFUNCTION);
- if (*p == '\0')
- break;
- if (!ffesrc_is_name_init (*p))
- goto bad_i; /* :::::::::::::::::::: */
- ffesta_tokens[1] = ffelex_token_name_from_names (t, i, 0);
- return (ffelexHandler) ffestb_decl_funcname_1_;
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ if (!ffesta_is_inhibited ())
+ {
+ ffestc_decl_item (ffesta_tokens[1], ffestb_local_.decl.kind,
+ ffestb_local_.decl.kindt, ffestb_subrargs_.dim_list.dims,
+ ffestb_local_.decl.len, ffestb_local_.decl.lent, expr, ft,
+ FALSE);
+ ffestc_decl_finish ();
+ }
+ ffelex_token_kill (ffesta_tokens[1]);
+ if (ffestb_local_.decl.kindt != NULL)
+ ffelex_token_kill (ffestb_local_.decl.kindt);
+ if (ffestb_subrargs_.dim_list.dims != NULL)
+ ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
+ if (ffestb_local_.decl.lent != NULL)
+ ffelex_token_kill (ffestb_local_.decl.lent);
+ return (ffelexHandler) ffesta_zero (t);
default:
break;
}
- if (ffestb_local_.decl.recursive != NULL)
- ffelex_token_kill (ffestb_local_.decl.recursive);
- if (ffestb_local_.decl.kindt != NULL)
- ffelex_token_kill (ffestb_local_.decl.kindt);
- if (ffestb_local_.decl.lent != NULL)
- ffelex_token_kill (ffestb_local_.decl.lent);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-
-bad_i: /* :::::::::::::::::::: */
- if (ffestb_local_.decl.recursive != NULL)
- ffelex_token_kill (ffestb_local_.decl.recursive);
+ if (!ffesta_is_inhibited ())
+ ffestc_decl_finish ();
+ ffelex_token_kill (ffesta_tokens[1]);
if (ffestb_local_.decl.kindt != NULL)
ffelex_token_kill (ffestb_local_.decl.kindt);
+ if (ffestb_subrargs_.dim_list.dims != NULL)
+ ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
if (ffestb_local_.decl.lent != NULL)
ffelex_token_kill (ffestb_local_.decl.lent);
- ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t, i, NULL);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-#endif
-/* ffestb_decl_funcname_ -- "type" [type parameters] [RECURSIVE] FUNCTION
+/* ffestb_decl_ents_9_ -- "type" ... SLASH expr
- return ffestb_decl_funcname_; // to lexer
+ (ffestb_decl_ents_9_) // to expression handler
- Handle NAME of a function. */
+ Handle ASTERISK, COMMA, or SLASH. */
static ffelexHandler
-ffestb_decl_funcname_ (ffelexToken t)
+ffestb_decl_ents_9_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeNAME:
- ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_decl_funcname_1_;
+ case FFELEX_typeCOMMA:
+ if (expr == NULL)
+ break;
+ if (!ffesta_is_inhibited ())
+ ffestc_decl_itemvalue (NULL, NULL, expr, ft);
+ return (ffelexHandler) ffeexpr_rhs
+ (ffesta_output_pool, FFEEXPR_contextDATA,
+ (ffeexprCallback) ffestb_decl_ents_9_);
+
+ case FFELEX_typeASTERISK:
+ if (expr == NULL)
+ break;
+ ffestb_local_.decl.expr = expr;
+ ffesta_tokens[1] = ffelex_token_use (ft);
+ return (ffelexHandler) ffeexpr_rhs
+ (ffesta_output_pool, FFEEXPR_contextDATA,
+ (ffeexprCallback) ffestb_decl_ents_10_);
+
+ case FFELEX_typeSLASH:
+ if (expr == NULL)
+ break;
+ if (!ffesta_is_inhibited ())
+ {
+ ffestc_decl_itemvalue (NULL, NULL, expr, ft);
+ ffestc_decl_itemendvals (t);
+ }
+ return (ffelexHandler) ffestb_decl_ents_11_;
default:
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t);
break;
}
- if (ffestb_local_.decl.recursive != NULL)
- ffelex_token_kill (ffestb_local_.decl.recursive);
- if (ffestb_local_.decl.kindt != NULL)
- ffelex_token_kill (ffestb_local_.decl.kindt);
- if (ffestb_local_.decl.lent != NULL)
- ffelex_token_kill (ffestb_local_.decl.lent);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t);
+ if (!ffesta_is_inhibited ())
+ {
+ ffestc_decl_itemendvals (t);
+ ffestc_decl_finish ();
+ }
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_decl_funcname_1_ -- "type" [type parameters] [RECURSIVE] FUNCTION
- NAME
+/* ffestb_decl_ents_10_ -- "type" ... SLASH expr ASTERISK expr
- return ffestb_decl_funcname_1_; // to lexer
+ (ffestb_decl_ents_10_) // to expression handler
- Handle ASTERISK or OPEN_PAREN. */
+ Handle COMMA or SLASH. */
static ffelexHandler
-ffestb_decl_funcname_1_ (ffelexToken t)
+ffestb_decl_ents_10_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeASTERISK:
- return (ffelexHandler) ffestb_decl_funcname_2_;
+ case FFELEX_typeCOMMA:
+ if (expr == NULL)
+ break;
+ if (!ffesta_is_inhibited ())
+ ffestc_decl_itemvalue (ffestb_local_.decl.expr, ffesta_tokens[1],
+ expr, ft);
+ ffelex_token_kill (ffesta_tokens[1]);
+ return (ffelexHandler) ffeexpr_rhs
+ (ffesta_output_pool, FFEEXPR_contextDATA,
+ (ffeexprCallback) ffestb_decl_ents_9_);
- case FFELEX_typeOPEN_PAREN:
- return (ffelexHandler) ffestb_decl_funcname_4_ (t);
+ case FFELEX_typeSLASH:
+ if (expr == NULL)
+ break;
+ if (!ffesta_is_inhibited ())
+ {
+ ffestc_decl_itemvalue (ffestb_local_.decl.expr, ffesta_tokens[1],
+ expr, ft);
+ ffestc_decl_itemendvals (t);
+ }
+ ffelex_token_kill (ffesta_tokens[1]);
+ return (ffelexHandler) ffestb_decl_ents_11_;
default:
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t);
break;
}
- if (ffestb_local_.decl.recursive != NULL)
- ffelex_token_kill (ffestb_local_.decl.recursive);
- if (ffestb_local_.decl.kindt != NULL)
- ffelex_token_kill (ffestb_local_.decl.kindt);
- if (ffestb_local_.decl.lent != NULL)
- ffelex_token_kill (ffestb_local_.decl.lent);
+ if (!ffesta_is_inhibited ())
+ {
+ ffestc_decl_itemendvals (t);
+ ffestc_decl_finish ();
+ }
ffelex_token_kill (ffesta_tokens[1]);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_decl_funcname_2_ -- "type" [type parameters] [RECURSIVE] FUNCTION
- NAME ASTERISK
+/* ffestb_decl_ents_11_ -- "type" [type parameters] [attributes "::"] NAME
+ [ASTERISK NUMBER] [OPEN_PAREN dimlist CLOSE_PAREN]
+ [ASTERISK charlength] SLASH initvals SLASH
- return ffestb_decl_funcname_2_; // to lexer
+ return ffestb_decl_ents_11_; // to lexer
- Handle NUMBER or OPEN_PAREN. */
+ Handle COMMA or EOS/SEMICOLON. */
static ffelexHandler
-ffestb_decl_funcname_2_ (ffelexToken t)
+ffestb_decl_ents_11_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeNUMBER:
- switch (ffestb_local_.decl.type)
- {
- case FFESTP_typeINTEGER:
- case FFESTP_typeREAL:
- case FFESTP_typeCOMPLEX:
- case FFESTP_typeLOGICAL:
- if (ffestb_local_.decl.kindt == NULL)
- ffestb_local_.decl.kindt = ffelex_token_use (t);
- else
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t);
- break;
-
- case FFESTP_typeCHARACTER:
- if (ffestb_local_.decl.lent == NULL)
- ffestb_local_.decl.lent = ffelex_token_use (t);
- else
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t);
- break;
-
- case FFESTP_typeBYTE:
- case FFESTP_typeWORD:
- default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t);
- break;
- }
- return (ffelexHandler) ffestb_decl_funcname_4_;
+ case FFELEX_typeCOMMA:
+ return (ffelexHandler) ffestb_decl_ents_;
- case FFELEX_typeOPEN_PAREN:
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextCHARACTERSIZE,
- (ffeexprCallback) ffestb_decl_funcname_3_);
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ if (!ffesta_is_inhibited ())
+ ffestc_decl_finish ();
+ return (ffelexHandler) ffesta_zero (t);
default:
break;
}
- if (ffestb_local_.decl.recursive != NULL)
- ffelex_token_kill (ffestb_local_.decl.recursive);
- if (ffestb_local_.decl.kindt != NULL)
- ffelex_token_kill (ffestb_local_.decl.kindt);
- if (ffestb_local_.decl.lent != NULL)
- ffelex_token_kill (ffestb_local_.decl.lent);
- ffelex_token_kill (ffesta_tokens[1]);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t);
+ if (!ffesta_is_inhibited ())
+ ffestc_decl_finish ();
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_decl_funcname_3_ -- "type" [type parameters] [RECURSIVE] FUNCTION
- NAME ASTERISK OPEN_PAREN expr
+/* ffestb_decl_entsp_ -- "type" [type parameters]
- (ffestb_decl_funcname_3_) // to expression handler
+ return ffestb_decl_entsp_; // to lexer
- Allow only CLOSE_PAREN; and deal with character-length expression. */
+ Handle NAME or NAMES beginning either an entity (object) declaration or
+ a function definition.. */
static ffelexHandler
-ffestb_decl_funcname_3_ (ffelexToken ft, ffebld expr, ffelexToken t)
+ffestb_decl_entsp_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeCLOSE_PAREN:
- if (expr == NULL)
- break;
- switch (ffestb_local_.decl.type)
- {
- case FFESTP_typeCHARACTER:
- if (ffestb_local_.decl.lent == NULL)
- {
- ffestb_local_.decl.len = expr;
- ffestb_local_.decl.lent = ffelex_token_use (ft);
- }
- else
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t);
- break;
+ case FFELEX_typeNAME:
+ ffesta_confirmed ();
+ ffesta_tokens[1] = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_decl_entsp_1_;
- default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t);
- break;
- }
- return (ffelexHandler) ffestb_decl_funcname_4_;
+ case FFELEX_typeNAMES:
+ ffesta_confirmed ();
+ ffesta_tokens[1] = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_decl_entsp_2_;
default:
break;
}
- if (ffestb_local_.decl.recursive != NULL)
- ffelex_token_kill (ffestb_local_.decl.recursive);
if (ffestb_local_.decl.kindt != NULL)
ffelex_token_kill (ffestb_local_.decl.kindt);
if (ffestb_local_.decl.lent != NULL)
ffelex_token_kill (ffestb_local_.decl.lent);
- ffelex_token_kill (ffesta_tokens[1]);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_decl_funcname_4_ -- "type" [type parameters] [RECURSIVE] FUNCTION
- NAME [type parameter]
+/* ffestb_decl_entsp_1_ -- "type" [type parameters] NAME
- return ffestb_decl_funcname_4_; // to lexer
+ return ffestb_decl_entsp_1_; // to lexer
- Make sure the next token is an OPEN_PAREN. Get the arg list and
- then implement. */
+ If we get another NAME token here, then the previous one must be
+ "RECURSIVE" or "FUNCTION" and we handle it accordingly. Otherwise,
+ we send the previous and current token through to _ents_. */
static ffelexHandler
-ffestb_decl_funcname_4_ (ffelexToken t)
+ffestb_decl_entsp_1_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeOPEN_PAREN:
- ffestb_subrargs_.name_list.args = ffestt_tokenlist_create ();
- ffestb_subrargs_.name_list.handler
- = (ffelexHandler) ffestb_decl_funcname_5_;
- ffestb_subrargs_.name_list.is_subr = FALSE;
- ffestb_subrargs_.name_list.names = FALSE;
- return (ffelexHandler) ffestb_subr_name_list_;
+ case FFELEX_typeNAME:
+ switch (ffestr_first (ffesta_tokens[1]))
+ {
+ case FFESTR_firstFUNCTION:
+ ffelex_token_kill (ffesta_tokens[1]);
+ return (ffelexHandler) ffestb_decl_funcname_ (t);
- default:
+ default:
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", ffesta_tokens[1]);
+ break;
+ }
break;
+
+ default:
+ if ((ffelex_token_type (ffesta_tokens[1]) != FFELEX_typeNAMES)
+ && !ffesta_is_inhibited ())
+ ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0],
+ ffestb_local_.decl.kind, ffestb_local_.decl.kindt,
+ ffestb_local_.decl.len, ffestb_local_.decl.lent);
+ if (ffestb_local_.decl.kindt != NULL)
+ ffelex_token_kill (ffestb_local_.decl.kindt);
+ if (ffestb_local_.decl.lent != NULL)
+ ffelex_token_kill (ffestb_local_.decl.lent);
+ /* NAME/NAMES token already in ffesta_tokens[1]. */
+ return (ffelexHandler) ffestb_decl_ents_1_ (t);
}
- if (ffestb_local_.decl.recursive != NULL)
- ffelex_token_kill (ffestb_local_.decl.recursive);
if (ffestb_local_.decl.kindt != NULL)
ffelex_token_kill (ffestb_local_.decl.kindt);
if (ffestb_local_.decl.lent != NULL)
ffelex_token_kill (ffestb_local_.decl.lent);
ffelex_token_kill (ffesta_tokens[1]);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_decl_funcname_5_ -- "type" [type parameters] [RECURSIVE] FUNCTION
- NAME [type parameter] OPEN_PAREN arg-list
- CLOSE_PAREN
+/* ffestb_decl_entsp_2_ -- "type" [type parameters] NAMES
- return ffestb_decl_funcname_5_; // to lexer
+ return ffestb_decl_entsp_2_; // to lexer
- Must have EOS/SEMICOLON or "RESULT" here. */
+ If we get an ASTERISK or OPEN_PAREN here, then if the previous NAMES
+ begins with "FUNCTION" or "RECURSIVEFUNCTION" and is followed by a
+ first-name-char, we have a possible syntactically ambiguous situation.
+ Otherwise, we have a straightforward situation just as if we went
+ through _entsp_1_ instead of here. */
static ffelexHandler
-ffestb_decl_funcname_5_ (ffelexToken t)
+ffestb_decl_entsp_2_ (ffelexToken t)
{
- if (!ffestb_subrargs_.name_list.ok)
- goto bad; /* :::::::::::::::::::: */
+ ffelexToken nt;
+ bool asterisk_ok;
+ unsigned const char *p;
+ ffeTokenLength i;
switch (ffelex_token_type (t))
{
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
+ case FFELEX_typeASTERISK:
ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- ffestc_R1219 (ffesta_tokens[1], ffestb_subrargs_.name_list.args,
- ffestb_subrargs_.name_list.close_paren, ffestb_local_.decl.type,
- ffestb_local_.decl.kind, ffestb_local_.decl.kindt,
- ffestb_local_.decl.len, ffestb_local_.decl.lent,
- ffestb_local_.decl.recursive, NULL);
- if (ffestb_local_.decl.recursive != NULL)
- ffelex_token_kill (ffestb_local_.decl.recursive);
- if (ffestb_local_.decl.kindt != NULL)
- ffelex_token_kill (ffestb_local_.decl.kindt);
- if (ffestb_local_.decl.lent != NULL)
- ffelex_token_kill (ffestb_local_.decl.lent);
- ffelex_token_kill (ffesta_tokens[1]);
- ffelex_token_kill (ffestb_subrargs_.name_list.close_paren);
- ffestt_tokenlist_kill (ffestb_subrargs_.name_list.args);
- return (ffelexHandler) ffesta_zero (t);
+ switch (ffestb_local_.decl.type)
+ {
+ case FFESTP_typeINTEGER:
+ case FFESTP_typeREAL:
+ case FFESTP_typeCOMPLEX:
+ case FFESTP_typeLOGICAL:
+ asterisk_ok = (ffestb_local_.decl.kindt == NULL);
+ break;
- case FFELEX_typeNAME:
- if (ffestr_other (t) != FFESTR_otherRESULT)
- break;
- return (ffelexHandler) ffestb_decl_funcname_6_;
+ case FFESTP_typeCHARACTER:
+ asterisk_ok = (ffestb_local_.decl.lent == NULL);
+ break;
+
+ case FFESTP_typeBYTE:
+ case FFESTP_typeWORD:
+ default:
+ asterisk_ok = FALSE;
+ break;
+ }
+ switch (ffestr_first (ffesta_tokens[1]))
+ {
+ case FFESTR_firstFUNCTION:
+ if (!asterisk_ok)
+ break; /* For our own convenience, treat as non-FN
+ stmt. */
+ p = ffelex_token_text (ffesta_tokens[1])
+ + (i = FFESTR_firstlFUNCTION);
+ if (!ffesrc_is_name_init (*p))
+ break;
+ ffestb_local_.decl.recursive = NULL;
+ ffesta_tokens[2] = ffelex_token_name_from_names (ffesta_tokens[1],
+ FFESTR_firstlFUNCTION, 0);
+ return (ffelexHandler) ffestb_decl_entsp_3_;
+
+ default:
+ break;
+ }
+ break;
+
+ case FFELEX_typeOPEN_PAREN:
+ ffestb_local_.decl.aster_after = FALSE;
+ switch (ffestr_first (ffesta_tokens[1]))
+ {
+ case FFESTR_firstFUNCTION:
+ p = ffelex_token_text (ffesta_tokens[1])
+ + (i = FFESTR_firstlFUNCTION);
+ if (!ffesrc_is_name_init (*p))
+ break;
+ ffestb_local_.decl.recursive = NULL;
+ ffesta_tokens[2] = ffelex_token_name_from_names (ffesta_tokens[1],
+ FFESTR_firstlFUNCTION, 0);
+ return (ffelexHandler) ffestb_decl_entsp_5_ (t);
+
+ default:
+ break;
+ }
+ if ((ffestb_local_.decl.kindt != NULL)
+ || (ffestb_local_.decl.lent != NULL))
+ break; /* Have kind/len type param, definitely not
+ assignment stmt. */
+ return (ffelexHandler) ffestb_decl_entsp_1_ (t);
default:
break;
}
-bad: /* :::::::::::::::::::: */
- if (ffestb_local_.decl.recursive != NULL)
- ffelex_token_kill (ffestb_local_.decl.recursive);
- if (ffestb_local_.decl.kindt != NULL)
- ffelex_token_kill (ffestb_local_.decl.kindt);
- if (ffestb_local_.decl.lent != NULL)
- ffelex_token_kill (ffestb_local_.decl.lent);
+ nt = ffelex_token_name_from_names (ffesta_tokens[1], 0, 0);
ffelex_token_kill (ffesta_tokens[1]);
- ffelex_token_kill (ffestb_subrargs_.name_list.close_paren);
- ffestt_tokenlist_kill (ffestb_subrargs_.name_list.args);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+ ffesta_tokens[1] = nt; /* Change NAMES to NAME. */
+ return (ffelexHandler) ffestb_decl_entsp_1_ (t);
}
-/* ffestb_decl_funcname_6_ -- "type" [type parameters] [RECURSIVE] FUNCTION
- NAME [type parameter] OPEN_PAREN arglist
- CLOSE_PAREN "RESULT"
+/* ffestb_decl_entsp_3_ -- "type" [type parameters] [RECURSIVE] FUNCTION
+ NAME ASTERISK
- return ffestb_decl_funcname_6_; // to lexer
+ return ffestb_decl_entsp_3_; // to lexer
- Make sure the next token is an OPEN_PAREN. */
+ Handle NUMBER or OPEN_PAREN. */
static ffelexHandler
-ffestb_decl_funcname_6_ (ffelexToken t)
+ffestb_decl_entsp_3_ (ffelexToken t)
{
+ ffestb_local_.decl.aster_after = TRUE;
+
switch (ffelex_token_type (t))
{
- case FFELEX_typeOPEN_PAREN:
- return (ffelexHandler) ffestb_decl_funcname_7_;
-
- default:
- break;
- }
-
- if (ffestb_local_.decl.recursive != NULL)
- ffelex_token_kill (ffestb_local_.decl.recursive);
- if (ffestb_local_.decl.kindt != NULL)
- ffelex_token_kill (ffestb_local_.decl.kindt);
- if (ffestb_local_.decl.lent != NULL)
- ffelex_token_kill (ffestb_local_.decl.lent);
- ffelex_token_kill (ffesta_tokens[1]);
- ffelex_token_kill (ffestb_subrargs_.name_list.close_paren);
- ffestt_tokenlist_kill (ffestb_subrargs_.name_list.args);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_decl_funcname_7_ -- "type" [type parameters] [RECURSIVE] FUNCTION
- NAME [type parameter] OPEN_PAREN arglist
- CLOSE_PAREN "RESULT" OPEN_PAREN
+ case FFELEX_typeNUMBER:
+ switch (ffestb_local_.decl.type)
+ {
+ case FFESTP_typeINTEGER:
+ case FFESTP_typeREAL:
+ case FFESTP_typeCOMPLEX:
+ case FFESTP_typeLOGICAL:
+ ffestb_local_.decl.kindt = ffelex_token_use (t);
+ break;
- return ffestb_decl_funcname_7_; // to lexer
+ case FFESTP_typeCHARACTER:
+ ffestb_local_.decl.lent = ffelex_token_use (t);
+ break;
- Make sure the next token is a NAME. */
+ case FFESTP_typeBYTE:
+ case FFESTP_typeWORD:
+ default:
+ assert (FALSE);
+ }
+ return (ffelexHandler) ffestb_decl_entsp_5_;
-static ffelexHandler
-ffestb_decl_funcname_7_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- ffesta_tokens[2] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_decl_funcname_8_;
+ case FFELEX_typeOPEN_PAREN:
+ return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ FFEEXPR_contextCHARACTERSIZE,
+ (ffeexprCallback) ffestb_decl_entsp_4_);
default:
break;
if (ffestb_local_.decl.lent != NULL)
ffelex_token_kill (ffestb_local_.decl.lent);
ffelex_token_kill (ffesta_tokens[1]);
- ffelex_token_kill (ffestb_subrargs_.name_list.close_paren);
- ffestt_tokenlist_kill (ffestb_subrargs_.name_list.args);
+ ffelex_token_kill (ffesta_tokens[2]);
ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_decl_funcname_8_ -- "type" [type parameters] [RECURSIVE] FUNCTION
- NAME [type parameter] OPEN_PAREN arglist
- CLOSE_PAREN "RESULT" OPEN_PAREN NAME
+/* ffestb_decl_entsp_4_ -- "type" [type parameters] [RECURSIVE] FUNCTION
+ NAME ASTERISK OPEN_PAREN expr
- return ffestb_decl_funcname_8_; // to lexer
+ (ffestb_decl_entsp_4_) // to expression handler
- Make sure the next token is a CLOSE_PAREN. */
+ Allow only CLOSE_PAREN; and deal with character-length expression. */
static ffelexHandler
-ffestb_decl_funcname_8_ (ffelexToken t)
+ffestb_decl_entsp_4_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
switch (ffelex_token_type (t))
{
case FFELEX_typeCLOSE_PAREN:
- return (ffelexHandler) ffestb_decl_funcname_9_;
+ if (expr == NULL)
+ break;
+ switch (ffestb_local_.decl.type)
+ {
+ case FFESTP_typeCHARACTER:
+ ffestb_local_.decl.len = expr;
+ ffestb_local_.decl.lent = ffelex_token_use (ft);
+ break;
+
+ default:
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t);
+ break;
+ }
+ return (ffelexHandler) ffestb_decl_entsp_5_;
default:
break;
ffelex_token_kill (ffestb_local_.decl.lent);
ffelex_token_kill (ffesta_tokens[1]);
ffelex_token_kill (ffesta_tokens[2]);
- ffelex_token_kill (ffestb_subrargs_.name_list.close_paren);
- ffestt_tokenlist_kill (ffestb_subrargs_.name_list.args);
ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_decl_funcname_9_ -- "type" [type parameters] [RECURSIVE] FUNCTION
- NAME [type parameter] OPEN_PAREN arg-list
- CLOSE_PAREN "RESULT" OPEN_PAREN NAME CLOSE_PAREN
+/* ffestb_decl_entsp_5_ -- "type" [type parameters] [RECURSIVE] FUNCTION
+ NAME [type parameter]
- return ffestb_decl_funcname_9_; // to lexer
+ return ffestb_decl_entsp_5_; // to lexer
- Must have EOS/SEMICOLON here. */
+ Make sure the next token is an OPEN_PAREN. Get the arg list or dimension
+ list. If it can't be an arg list, or if the CLOSE_PAREN is followed by
+ something other than EOS/SEMICOLON or NAME, then treat as dimension list
+ and handle statement as an R426/R501. If it can't be a dimension list, or
+ if the CLOSE_PAREN is followed by NAME, treat as an arg list and handle
+ statement as an R1219. If it can be either an arg list or a dimension
+ list and if the CLOSE_PAREN is followed by EOS/SEMICOLON, ask FFESTC
+ whether to treat the statement as an R426/R501 or an R1219 and act
+ accordingly. */
static ffelexHandler
-ffestb_decl_funcname_9_ (ffelexToken t)
+ffestb_decl_entsp_5_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- if (!ffesta_is_inhibited ())
- ffestc_R1219 (ffesta_tokens[1], ffestb_subrargs_.name_list.args,
- ffestb_subrargs_.name_list.close_paren, ffestb_local_.decl.type,
- ffestb_local_.decl.kind, ffestb_local_.decl.kindt,
- ffestb_local_.decl.len, ffestb_local_.decl.lent,
- ffestb_local_.decl.recursive, ffesta_tokens[2]);
- if (ffestb_local_.decl.recursive != NULL)
- ffelex_token_kill (ffestb_local_.decl.recursive);
- if (ffestb_local_.decl.kindt != NULL)
- ffelex_token_kill (ffestb_local_.decl.kindt);
- if (ffestb_local_.decl.lent != NULL)
- ffelex_token_kill (ffestb_local_.decl.lent);
- ffelex_token_kill (ffesta_tokens[1]);
- ffelex_token_kill (ffesta_tokens[2]);
- ffelex_token_kill (ffestb_subrargs_.name_list.close_paren);
- ffestt_tokenlist_kill (ffestb_subrargs_.name_list.args);
- return (ffelexHandler) ffesta_zero (t);
+ case FFELEX_typeOPEN_PAREN:
+ if (ffestb_local_.decl.aster_after && (ffestb_local_.decl.len != NULL))
+ { /* "CHARACTER[RECURSIVE]FUNCTIONxyz*(len-expr)
+ (..." must be a function-stmt, since the
+ (len-expr) cannot precede (array-spec) in
+ an object declaration but can precede
+ (name-list) in a function stmt. */
+ ffelex_token_kill (ffesta_tokens[1]);
+ ffesta_tokens[1] = ffesta_tokens[2];
+ return (ffelexHandler) ffestb_decl_funcname_4_ (t);
+ }
+ ffestb_local_.decl.toklist = ffestt_tokenlist_create ();
+ ffestb_local_.decl.empty = TRUE;
+ ffestt_tokenlist_append (ffestb_local_.decl.toklist, ffelex_token_use (t));
+ return (ffelexHandler) ffestb_decl_entsp_6_;
default:
break;
}
- if (ffestb_local_.decl.recursive != NULL)
- ffelex_token_kill (ffestb_local_.decl.recursive);
- if (ffestb_local_.decl.kindt != NULL)
- ffelex_token_kill (ffestb_local_.decl.kindt);
- if (ffestb_local_.decl.lent != NULL)
- ffelex_token_kill (ffestb_local_.decl.lent);
- ffelex_token_kill (ffesta_tokens[1]);
- ffelex_token_kill (ffesta_tokens[2]);
- ffelex_token_kill (ffestb_subrargs_.name_list.close_paren);
- ffestt_tokenlist_kill (ffestb_subrargs_.name_list.args);
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+ assert (ffestb_local_.decl.aster_after);
+ ffesta_confirmed (); /* We've seen an ASTERISK, so even EQUALS
+ confirmed. */
+ ffestb_subr_ambig_to_ents_ ();
+ ffestb_subrargs_.dim_list.dims = NULL;
+ return (ffelexHandler) ffestb_decl_ents_7_ (t);
}
-/* ffestb_V003 -- Parse the STRUCTURE statement
+/* ffestb_decl_entsp_6_ -- "type" [type parameters] [RECURSIVE] FUNCTION
+ NAME [type parameter] OPEN_PAREN
- return ffestb_V003; // to lexer
+ return ffestb_decl_entsp_6_; // to lexer
- Make sure the statement has a valid form for the STRUCTURE statement.
- If it does, implement the statement. */
+ If CLOSE_PAREN, we definitely have an R1219 function-stmt, since
+ the notation "name()" is invalid for a declaration. */
-#if FFESTR_VXT
-ffelexHandler
-ffestb_V003 (ffelexToken t)
+static ffelexHandler
+ffestb_decl_entsp_6_ (ffelexToken t)
{
- ffeTokenLength i;
- const char *p;
- ffelexToken nt;
ffelexHandler next;
- switch (ffelex_token_type (ffesta_tokens[0]))
+ switch (ffelex_token_type (t))
{
- case FFELEX_typeNAME:
- if (ffesta_first_kw != FFESTR_firstSTRUCTURE)
- goto bad_0; /* :::::::::::::::::::: */
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
-
- default:
- goto bad_1; /* :::::::::::::::::::: */
-
- case FFELEX_typeNAME:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- ffestc_V003_start (NULL);
- ffestb_local_.structure.started = TRUE;
- return (ffelexHandler) ffestb_V0034_ (t);
-
- case FFELEX_typeSLASH:
- ffesta_confirmed ();
- return (ffelexHandler) ffestb_V0031_;
- }
-
- case FFELEX_typeNAMES:
- if (ffesta_first_kw != FFESTR_firstSTRUCTURE)
- goto bad_0; /* :::::::::::::::::::: */
- p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlSTRUCTURE);
- switch (ffelex_token_type (t))
- {
- default:
- goto bad_1; /* :::::::::::::::::::: */
-
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed ();
- break;
-
- case FFELEX_typeSLASH:
- ffesta_confirmed ();
- if (*p != '\0')
- goto bad_1; /* :::::::::::::::::::: */
- return (ffelexHandler) ffestb_V0031_;
-
- case FFELEX_typeOPEN_PAREN:
- break;
+ case FFELEX_typeCLOSE_PAREN:
+ if (!ffestb_local_.decl.empty)
+ { /* Trailing comma, just a warning for
+ stmt func def, so allow ambiguity. */
+ ffestt_tokenlist_append (ffestb_local_.decl.toklist,
+ ffelex_token_use (t));
+ return (ffelexHandler) ffestb_decl_entsp_8_;
}
+ ffelex_token_kill (ffesta_tokens[1]);
+ ffesta_tokens[1] = ffesta_tokens[2];
+ next = (ffelexHandler) ffestt_tokenlist_handle
+ (ffestb_local_.decl.toklist, (ffelexHandler) ffestb_decl_funcname_4_);
+ ffestt_tokenlist_kill (ffestb_local_.decl.toklist);
+ return (ffelexHandler) (*next) (t);
- /* Here, we have at least one char after "STRUCTURE" and t is COMMA,
- EOS/SEMICOLON, or OPEN_PAREN. */
+ case FFELEX_typeNAME:
+ ffestb_local_.decl.empty = FALSE;
+ ffestt_tokenlist_append (ffestb_local_.decl.toklist, ffelex_token_use (t));
+ return (ffelexHandler) ffestb_decl_entsp_7_;
- if (!ffesrc_is_name_init (*p))
- goto bad_i; /* :::::::::::::::::::: */
- nt = ffelex_token_name_from_names (ffesta_tokens[0], i, 0);
- if (ffelex_token_type (t) == FFELEX_typeOPEN_PAREN)
- ffestb_local_.structure.started = FALSE;
- else
- {
- if (!ffesta_is_inhibited ())
- ffestc_V003_start (NULL);
- ffestb_local_.structure.started = TRUE;
- }
- next = (ffelexHandler) ffestb_V0034_ (nt);
- ffelex_token_kill (nt);
- return (ffelexHandler) (*next) (t);
+ case FFELEX_typeEQUALS:
+ case FFELEX_typePOINTS:
+ case FFELEX_typePERCENT:
+ case FFELEX_typePERIOD:
+ case FFELEX_typeOPEN_PAREN:
+ if ((ffestb_local_.decl.kindt != NULL)
+ || (ffestb_local_.decl.lent != NULL))
+ break; /* type(params)name or type*val name, either
+ way confirmed. */
+ return (ffelexHandler) ffestb_subr_ambig_nope_ (t);
default:
- goto bad_0; /* :::::::::::::::::::: */
+ break;
}
-bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "STRUCTURE", ffesta_tokens[0]);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-
-bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "STRUCTURE", t);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero); /* Invalid second token. */
-
-bad_i: /* :::::::::::::::::::: */
- ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "STRUCTURE", ffesta_tokens[0], i, t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+ ffesta_confirmed ();
+ ffestb_subr_ambig_to_ents_ ();
+ next = (ffelexHandler) ffestt_tokenlist_handle (ffestb_local_.decl.toklist,
+ (ffelexHandler) ffestb_decl_ents_3_);
+ ffestt_tokenlist_kill (ffestb_local_.decl.toklist);
+ return (ffelexHandler) (*next) (t);
}
-/* ffestb_V0031_ -- "STRUCTURE" SLASH
+/* ffestb_decl_entsp_7_ -- "type" [type parameters] [RECURSIVE] FUNCTION
+ NAME [type parameter] OPEN_PAREN NAME
- return ffestb_V0031_; // to lexer
+ return ffestb_decl_entsp_7_; // to lexer
- Handle NAME. */
+ Expect COMMA or CLOSE_PAREN to remain ambiguous, else not an R1219
+ function-stmt. */
static ffelexHandler
-ffestb_V0031_ (ffelexToken t)
+ffestb_decl_entsp_7_ (ffelexToken t)
{
+ ffelexHandler next;
+
switch (ffelex_token_type (t))
{
- case FFELEX_typeNAME:
- ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_V0032_;
+ case FFELEX_typeCLOSE_PAREN:
+ ffestt_tokenlist_append (ffestb_local_.decl.toklist, ffelex_token_use (t));
+ return (ffelexHandler) ffestb_decl_entsp_8_;
+
+ case FFELEX_typeCOMMA:
+ ffestt_tokenlist_append (ffestb_local_.decl.toklist, ffelex_token_use (t));
+ return (ffelexHandler) ffestb_decl_entsp_6_;
+
+ case FFELEX_typeEQUALS:
+ case FFELEX_typePOINTS:
+ case FFELEX_typePERCENT:
+ case FFELEX_typePERIOD:
+ case FFELEX_typeOPEN_PAREN:
+ if ((ffestb_local_.decl.kindt != NULL)
+ || (ffestb_local_.decl.lent != NULL))
+ break; /* type(params)name or type*val name, either
+ way confirmed. */
+ return (ffelexHandler) ffestb_subr_ambig_nope_ (t);
default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "STRUCTURE", t);
break;
}
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+ ffesta_confirmed ();
+ ffestb_subr_ambig_to_ents_ ();
+ next = (ffelexHandler) ffestt_tokenlist_handle (ffestb_local_.decl.toklist,
+ (ffelexHandler) ffestb_decl_ents_3_);
+ ffestt_tokenlist_kill (ffestb_local_.decl.toklist);
+ return (ffelexHandler) (*next) (t);
}
-/* ffestb_V0032_ -- "STRUCTURE" SLASH NAME
+/* ffestb_decl_entsp_8_ -- "type" [type parameters] [RECURSIVE] FUNCTION
+ NAME [type parameter] OPEN_PAREN name-list
+ CLOSE_PAREN
- return ffestb_V0032_; // to lexer
+ return ffestb_decl_entsp_8_; // to lexer
- Handle SLASH. */
+ If EOS/SEMICOLON, situation remains ambiguous, ask FFESTC to resolve
+ it. If NAME (must be "RESULT", but that is checked later on),
+ definitely an R1219 function-stmt. Anything else, handle as entity decl. */
static ffelexHandler
-ffestb_V0032_ (ffelexToken t)
+ffestb_decl_entsp_8_ (ffelexToken t)
{
+ ffelexHandler next;
+
switch (ffelex_token_type (t))
{
- case FFELEX_typeSLASH:
- if (!ffesta_is_inhibited ())
- ffestc_V003_start (ffesta_tokens[1]);
- ffestb_local_.structure.started = TRUE;
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ ffesta_confirmed ();
+ if (ffestc_is_decl_not_R1219 ())
+ break;
+ /* Fall through. */
+ case FFELEX_typeNAME:
+ ffesta_confirmed ();
ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffestb_V0033_;
+ ffesta_tokens[1] = ffesta_tokens[2];
+ next = (ffelexHandler) ffestt_tokenlist_handle
+ (ffestb_local_.decl.toklist, (ffelexHandler) ffestb_decl_funcname_4_);
+ ffestt_tokenlist_kill (ffestb_local_.decl.toklist);
+ return (ffelexHandler) (*next) (t);
+
+ case FFELEX_typeEQUALS:
+ case FFELEX_typePOINTS:
+ case FFELEX_typePERCENT:
+ case FFELEX_typePERIOD:
+ case FFELEX_typeOPEN_PAREN:
+ if ((ffestb_local_.decl.kindt != NULL)
+ || (ffestb_local_.decl.lent != NULL))
+ break; /* type(params)name or type*val name, either
+ way confirmed. */
+ return (ffelexHandler) ffestb_subr_ambig_nope_ (t);
default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "STRUCTURE", t);
break;
}
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
+ ffesta_confirmed ();
+ ffestb_subr_ambig_to_ents_ ();
+ next = (ffelexHandler) ffestt_tokenlist_handle (ffestb_local_.decl.toklist,
+ (ffelexHandler) ffestb_decl_ents_3_);
+ ffestt_tokenlist_kill (ffestb_local_.decl.toklist);
+ return (ffelexHandler) (*next) (t);
}
-/* ffestb_V0033_ -- "STRUCTURE" SLASH NAME SLASH
+/* ffestb_decl_funcname_ -- "type" [type parameters] [RECURSIVE] FUNCTION
- return ffestb_V0033_; // to lexer
+ return ffestb_decl_funcname_; // to lexer
- Handle NAME or EOS/SEMICOLON. */
+ Handle NAME of a function. */
static ffelexHandler
-ffestb_V0033_ (ffelexToken t)
+ffestb_decl_funcname_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
case FFELEX_typeNAME:
- return (ffelexHandler) ffestb_V0034_ (t);
-
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- if (!ffesta_is_inhibited ())
- ffestc_V003_finish ();
- return (ffelexHandler) ffesta_zero (t);
+ ffesta_tokens[1] = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_decl_funcname_1_;
default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "STRUCTURE", t);
break;
}
- ffelex_token_kill (ffesta_tokens[1]);
+ if (ffestb_local_.decl.recursive != NULL)
+ ffelex_token_kill (ffestb_local_.decl.recursive);
+ if (ffestb_local_.decl.kindt != NULL)
+ ffelex_token_kill (ffestb_local_.decl.kindt);
+ if (ffestb_local_.decl.lent != NULL)
+ ffelex_token_kill (ffestb_local_.decl.lent);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_V0034_ -- "STRUCTURE" [SLASH NAME SLASH]
+/* ffestb_decl_funcname_1_ -- "type" [type parameters] [RECURSIVE] FUNCTION
+ NAME
- return ffestb_V0034_; // to lexer
+ return ffestb_decl_funcname_1_; // to lexer
- Handle NAME. */
+ Handle ASTERISK or OPEN_PAREN. */
static ffelexHandler
-ffestb_V0034_ (ffelexToken t)
+ffestb_decl_funcname_1_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeNAME:
- ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_V0035_;
+ case FFELEX_typeASTERISK:
+ return (ffelexHandler) ffestb_decl_funcname_2_;
+
+ case FFELEX_typeOPEN_PAREN:
+ return (ffelexHandler) ffestb_decl_funcname_4_ (t);
default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "STRUCTURE", t);
break;
}
- if (!ffesta_is_inhibited ())
- ffestc_V003_finish ();
+ if (ffestb_local_.decl.recursive != NULL)
+ ffelex_token_kill (ffestb_local_.decl.recursive);
+ if (ffestb_local_.decl.kindt != NULL)
+ ffelex_token_kill (ffestb_local_.decl.kindt);
+ if (ffestb_local_.decl.lent != NULL)
+ ffelex_token_kill (ffestb_local_.decl.lent);
+ ffelex_token_kill (ffesta_tokens[1]);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_V0035_ -- "STRUCTURE" ... NAME
+/* ffestb_decl_funcname_2_ -- "type" [type parameters] [RECURSIVE] FUNCTION
+ NAME ASTERISK
- return ffestb_V0035_; // to lexer
+ return ffestb_decl_funcname_2_; // to lexer
- Handle OPEN_PAREN. */
+ Handle NUMBER or OPEN_PAREN. */
static ffelexHandler
-ffestb_V0035_ (ffelexToken t)
+ffestb_decl_funcname_2_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeOPEN_PAREN:
- ffestb_subrargs_.dim_list.dims = ffestt_dimlist_create ();
- ffestb_subrargs_.dim_list.handler = (ffelexHandler) ffestb_V0036_;
- ffestb_subrargs_.dim_list.pool = ffesta_output_pool;
- ffestb_subrargs_.dim_list.ctx = FFEEXPR_contextDIMLISTCOMMON;
-#ifdef FFECOM_dimensionsMAX
- ffestb_subrargs_.dim_list.ndims = 0;
-#endif
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextDIMLISTCOMMON, (ffeexprCallback) ffestb_subr_dimlist_);
+ case FFELEX_typeNUMBER:
+ switch (ffestb_local_.decl.type)
+ {
+ case FFESTP_typeINTEGER:
+ case FFESTP_typeREAL:
+ case FFESTP_typeCOMPLEX:
+ case FFESTP_typeLOGICAL:
+ if (ffestb_local_.decl.kindt == NULL)
+ ffestb_local_.decl.kindt = ffelex_token_use (t);
+ else
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t);
+ break;
- case FFELEX_typeCOMMA:
- if (!ffesta_is_inhibited ())
- ffestc_V003_item (ffesta_tokens[1], NULL);
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffestb_V0034_;
+ case FFESTP_typeCHARACTER:
+ if (ffestb_local_.decl.lent == NULL)
+ ffestb_local_.decl.lent = ffelex_token_use (t);
+ else
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t);
+ break;
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- if (!ffesta_is_inhibited ())
- {
- ffestc_V003_item (ffesta_tokens[1], NULL);
- ffestc_V003_finish ();
+ case FFESTP_typeBYTE:
+ case FFESTP_typeWORD:
+ default:
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t);
+ break;
}
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffesta_zero (t);
+ return (ffelexHandler) ffestb_decl_funcname_4_;
+
+ case FFELEX_typeOPEN_PAREN:
+ return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
+ FFEEXPR_contextCHARACTERSIZE,
+ (ffeexprCallback) ffestb_decl_funcname_3_);
default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "STRUCTURE", t);
break;
}
- if (!ffesta_is_inhibited ())
- ffestc_V003_finish ();
+ if (ffestb_local_.decl.recursive != NULL)
+ ffelex_token_kill (ffestb_local_.decl.recursive);
+ if (ffestb_local_.decl.kindt != NULL)
+ ffelex_token_kill (ffestb_local_.decl.kindt);
+ if (ffestb_local_.decl.lent != NULL)
+ ffelex_token_kill (ffestb_local_.decl.lent);
ffelex_token_kill (ffesta_tokens[1]);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_V0036_ -- "STRUCTURE" ... NAME OPEN_PAREN dimlist CLOSE_PAREN
+/* ffestb_decl_funcname_3_ -- "type" [type parameters] [RECURSIVE] FUNCTION
+ NAME ASTERISK OPEN_PAREN expr
- return ffestb_V0036_; // to lexer
+ (ffestb_decl_funcname_3_) // to expression handler
- Handle COMMA or EOS/SEMICOLON. */
+ Allow only CLOSE_PAREN; and deal with character-length expression. */
static ffelexHandler
-ffestb_V0036_ (ffelexToken t)
+ffestb_decl_funcname_3_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
- if (!ffestb_subrargs_.dim_list.ok)
- goto bad; /* :::::::::::::::::::: */
-
switch (ffelex_token_type (t))
{
- case FFELEX_typeCOMMA:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
+ case FFELEX_typeCLOSE_PAREN:
+ if (expr == NULL)
+ break;
+ switch (ffestb_local_.decl.type)
{
- if (!ffestb_local_.structure.started)
+ case FFESTP_typeCHARACTER:
+ if (ffestb_local_.decl.lent == NULL)
{
- ffestc_V003_start (NULL);
- ffestb_local_.structure.started = TRUE;
+ ffestb_local_.decl.len = expr;
+ ffestb_local_.decl.lent = ffelex_token_use (ft);
}
- ffestc_V003_item (ffesta_tokens[1],
- ffestb_subrargs_.dim_list.dims);
- }
- ffelex_token_kill (ffesta_tokens[1]);
- ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
- return (ffelexHandler) ffestb_V0034_;
+ else
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t);
+ break;
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- {
- if (!ffestb_local_.structure.started)
- ffestc_V003_start (NULL);
- ffestc_V003_item (ffesta_tokens[1],
- ffestb_subrargs_.dim_list.dims);
- ffestc_V003_finish ();
+ default:
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t);
+ break;
}
- ffelex_token_kill (ffesta_tokens[1]);
- ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
- return (ffelexHandler) ffesta_zero (t);
-
- default:
- break;
- }
-
-bad: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "STRUCTURE", t);
- if (ffestb_local_.structure.started && !ffesta_is_inhibited ())
- ffestc_V003_finish ();
- ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-/* ffestb_V016 -- Parse the RECORD statement
-
- return ffestb_V016; // to lexer
-
- Make sure the statement has a valid form for the RECORD statement. If it
- does, implement the statement. */
-
-ffelexHandler
-ffestb_V016 (ffelexToken t)
-{
- const char *p;
- ffeTokenLength i;
-
- switch (ffelex_token_type (ffesta_tokens[0]))
- {
- case FFELEX_typeNAME:
- if (ffesta_first_kw != FFESTR_firstRECORD)
- goto bad_0; /* :::::::::::::::::::: */
- break;
-
- case FFELEX_typeNAMES:
- if (ffesta_first_kw != FFESTR_firstRECORD)
- goto bad_0; /* :::::::::::::::::::: */
- p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlRECORD);
- if (*p != '\0')
- goto bad_i; /* :::::::::::::::::::: */
- break;
-
- default:
- goto bad_0; /* :::::::::::::::::::: */
- }
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- case FFELEX_typeCOLONCOLON:
- ffesta_confirmed (); /* Error, but clearly intended. */
- goto bad_1; /* :::::::::::::::::::: */
+ return (ffelexHandler) ffestb_decl_funcname_4_;
default:
- goto bad_1; /* :::::::::::::::::::: */
-
- case FFELEX_typeSLASH:
break;
- }
-
- ffesta_confirmed ();
- if (!ffesta_is_inhibited ())
- ffestc_V016_start ();
- return (ffelexHandler) ffestb_V0161_;
-
-bad_0: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "RECORD", ffesta_tokens[0]);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-
-bad_1: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "RECORD", t);
- return (ffelexHandler) ffelex_swallow_tokens (t,
- (ffelexHandler) ffesta_zero); /* Invalid second token. */
+ }
-bad_i: /* :::::::::::::::::::: */
- ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "RECORD", ffesta_tokens[0], i, t);
+ if (ffestb_local_.decl.recursive != NULL)
+ ffelex_token_kill (ffestb_local_.decl.recursive);
+ if (ffestb_local_.decl.kindt != NULL)
+ ffelex_token_kill (ffestb_local_.decl.kindt);
+ if (ffestb_local_.decl.lent != NULL)
+ ffelex_token_kill (ffestb_local_.decl.lent);
+ ffelex_token_kill (ffesta_tokens[1]);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_V0161_ -- "RECORD" SLASH
+/* ffestb_decl_funcname_4_ -- "type" [type parameters] [RECURSIVE] FUNCTION
+ NAME [type parameter]
- return ffestb_V0161_; // to lexer
+ return ffestb_decl_funcname_4_; // to lexer
- Handle NAME. */
+ Make sure the next token is an OPEN_PAREN. Get the arg list and
+ then implement. */
static ffelexHandler
-ffestb_V0161_ (ffelexToken t)
+ffestb_decl_funcname_4_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeNAME:
- if (!ffesta_is_inhibited ())
- ffestc_V016_item_structure (t);
- return (ffelexHandler) ffestb_V0162_;
+ case FFELEX_typeOPEN_PAREN:
+ ffestb_subrargs_.name_list.args = ffestt_tokenlist_create ();
+ ffestb_subrargs_.name_list.handler
+ = (ffelexHandler) ffestb_decl_funcname_5_;
+ ffestb_subrargs_.name_list.is_subr = FALSE;
+ ffestb_subrargs_.name_list.names = FALSE;
+ return (ffelexHandler) ffestb_subr_name_list_;
default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "RECORD", t);
break;
}
- if (!ffesta_is_inhibited ())
- ffestc_V016_finish ();
+ if (ffestb_local_.decl.recursive != NULL)
+ ffelex_token_kill (ffestb_local_.decl.recursive);
+ if (ffestb_local_.decl.kindt != NULL)
+ ffelex_token_kill (ffestb_local_.decl.kindt);
+ if (ffestb_local_.decl.lent != NULL)
+ ffelex_token_kill (ffestb_local_.decl.lent);
+ ffelex_token_kill (ffesta_tokens[1]);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_V0162_ -- "RECORD" SLASH NAME
+/* ffestb_decl_funcname_5_ -- "type" [type parameters] [RECURSIVE] FUNCTION
+ NAME [type parameter] OPEN_PAREN arg-list
+ CLOSE_PAREN
- return ffestb_V0162_; // to lexer
+ return ffestb_decl_funcname_5_; // to lexer
- Handle SLASH. */
+ Must have EOS/SEMICOLON or "RESULT" here. */
static ffelexHandler
-ffestb_V0162_ (ffelexToken t)
+ffestb_decl_funcname_5_ (ffelexToken t)
{
+ if (!ffestb_subrargs_.name_list.ok)
+ goto bad; /* :::::::::::::::::::: */
+
switch (ffelex_token_type (t))
{
- case FFELEX_typeSLASH:
- return (ffelexHandler) ffestb_V0163_;
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ ffesta_confirmed ();
+ if (!ffesta_is_inhibited ())
+ ffestc_R1219 (ffesta_tokens[1], ffestb_subrargs_.name_list.args,
+ ffestb_subrargs_.name_list.close_paren, ffestb_local_.decl.type,
+ ffestb_local_.decl.kind, ffestb_local_.decl.kindt,
+ ffestb_local_.decl.len, ffestb_local_.decl.lent,
+ ffestb_local_.decl.recursive, NULL);
+ if (ffestb_local_.decl.recursive != NULL)
+ ffelex_token_kill (ffestb_local_.decl.recursive);
+ if (ffestb_local_.decl.kindt != NULL)
+ ffelex_token_kill (ffestb_local_.decl.kindt);
+ if (ffestb_local_.decl.lent != NULL)
+ ffelex_token_kill (ffestb_local_.decl.lent);
+ ffelex_token_kill (ffesta_tokens[1]);
+ ffelex_token_kill (ffestb_subrargs_.name_list.close_paren);
+ ffestt_tokenlist_kill (ffestb_subrargs_.name_list.args);
+ return (ffelexHandler) ffesta_zero (t);
+
+ case FFELEX_typeNAME:
+ if (ffestr_other (t) != FFESTR_otherRESULT)
+ break;
+ return (ffelexHandler) ffestb_decl_funcname_6_;
default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "RECORD", t);
break;
}
- if (!ffesta_is_inhibited ())
- ffestc_V016_finish ();
+bad: /* :::::::::::::::::::: */
+ if (ffestb_local_.decl.recursive != NULL)
+ ffelex_token_kill (ffestb_local_.decl.recursive);
+ if (ffestb_local_.decl.kindt != NULL)
+ ffelex_token_kill (ffestb_local_.decl.kindt);
+ if (ffestb_local_.decl.lent != NULL)
+ ffelex_token_kill (ffestb_local_.decl.lent);
+ ffelex_token_kill (ffesta_tokens[1]);
+ ffelex_token_kill (ffestb_subrargs_.name_list.close_paren);
+ ffestt_tokenlist_kill (ffestb_subrargs_.name_list.args);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_V0163_ -- "RECORD" SLASH NAME SLASH
+/* ffestb_decl_funcname_6_ -- "type" [type parameters] [RECURSIVE] FUNCTION
+ NAME [type parameter] OPEN_PAREN arglist
+ CLOSE_PAREN "RESULT"
- return ffestb_V0163_; // to lexer
+ return ffestb_decl_funcname_6_; // to lexer
- Handle NAME. */
+ Make sure the next token is an OPEN_PAREN. */
static ffelexHandler
-ffestb_V0163_ (ffelexToken t)
+ffestb_decl_funcname_6_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeNAME:
- ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_V0164_;
+ case FFELEX_typeOPEN_PAREN:
+ return (ffelexHandler) ffestb_decl_funcname_7_;
default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "RECORD", t);
break;
}
- if (!ffesta_is_inhibited ())
- ffestc_V016_finish ();
+ if (ffestb_local_.decl.recursive != NULL)
+ ffelex_token_kill (ffestb_local_.decl.recursive);
+ if (ffestb_local_.decl.kindt != NULL)
+ ffelex_token_kill (ffestb_local_.decl.kindt);
+ if (ffestb_local_.decl.lent != NULL)
+ ffelex_token_kill (ffestb_local_.decl.lent);
+ ffelex_token_kill (ffesta_tokens[1]);
+ ffelex_token_kill (ffestb_subrargs_.name_list.close_paren);
+ ffestt_tokenlist_kill (ffestb_subrargs_.name_list.args);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_V0164_ -- "RECORD" ... NAME
+/* ffestb_decl_funcname_7_ -- "type" [type parameters] [RECURSIVE] FUNCTION
+ NAME [type parameter] OPEN_PAREN arglist
+ CLOSE_PAREN "RESULT" OPEN_PAREN
- return ffestb_V0164_; // to lexer
+ return ffestb_decl_funcname_7_; // to lexer
- Handle OPEN_PAREN. */
+ Make sure the next token is a NAME. */
static ffelexHandler
-ffestb_V0164_ (ffelexToken t)
+ffestb_decl_funcname_7_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeOPEN_PAREN:
- ffestb_subrargs_.dim_list.dims = ffestt_dimlist_create ();
- ffestb_subrargs_.dim_list.handler = (ffelexHandler) ffestb_V0165_;
- ffestb_subrargs_.dim_list.pool = ffesta_output_pool;
- ffestb_subrargs_.dim_list.ctx = FFEEXPR_contextDIMLISTCOMMON;
-#ifdef FFECOM_dimensionsMAX
- ffestb_subrargs_.dim_list.ndims = 0;
-#endif
- return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool,
- FFEEXPR_contextDIMLISTCOMMON, (ffeexprCallback) ffestb_subr_dimlist_);
-
- case FFELEX_typeCOMMA:
- if (!ffesta_is_inhibited ())
- ffestc_V016_item_object (ffesta_tokens[1], NULL);
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffestb_V0166_;
-
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- if (!ffesta_is_inhibited ())
- {
- ffestc_V016_item_object (ffesta_tokens[1], NULL);
- ffestc_V016_finish ();
- }
- ffelex_token_kill (ffesta_tokens[1]);
- return (ffelexHandler) ffesta_zero (t);
+ case FFELEX_typeNAME:
+ ffesta_tokens[2] = ffelex_token_use (t);
+ return (ffelexHandler) ffestb_decl_funcname_8_;
default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "RECORD", t);
break;
}
- if (!ffesta_is_inhibited ())
- ffestc_V016_finish ();
+ if (ffestb_local_.decl.recursive != NULL)
+ ffelex_token_kill (ffestb_local_.decl.recursive);
+ if (ffestb_local_.decl.kindt != NULL)
+ ffelex_token_kill (ffestb_local_.decl.kindt);
+ if (ffestb_local_.decl.lent != NULL)
+ ffelex_token_kill (ffestb_local_.decl.lent);
ffelex_token_kill (ffesta_tokens[1]);
+ ffelex_token_kill (ffestb_subrargs_.name_list.close_paren);
+ ffestt_tokenlist_kill (ffestb_subrargs_.name_list.args);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_V0165_ -- "RECORD" ... NAME OPEN_PAREN dimlist CLOSE_PAREN
+/* ffestb_decl_funcname_8_ -- "type" [type parameters] [RECURSIVE] FUNCTION
+ NAME [type parameter] OPEN_PAREN arglist
+ CLOSE_PAREN "RESULT" OPEN_PAREN NAME
- return ffestb_V0165_; // to lexer
+ return ffestb_decl_funcname_8_; // to lexer
- Handle COMMA or EOS/SEMICOLON. */
+ Make sure the next token is a CLOSE_PAREN. */
static ffelexHandler
-ffestb_V0165_ (ffelexToken t)
+ffestb_decl_funcname_8_ (ffelexToken t)
{
- if (!ffestb_subrargs_.dim_list.ok)
- goto bad; /* :::::::::::::::::::: */
-
switch (ffelex_token_type (t))
{
- case FFELEX_typeCOMMA:
- if (!ffesta_is_inhibited ())
- ffestc_V016_item_object (ffesta_tokens[1],
- ffestb_subrargs_.dim_list.dims);
- ffelex_token_kill (ffesta_tokens[1]);
- ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
- return (ffelexHandler) ffestb_V0166_;
-
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- if (!ffesta_is_inhibited ())
- {
- ffestc_V016_item_object (ffesta_tokens[1],
- ffestb_subrargs_.dim_list.dims);
- ffestc_V016_finish ();
- }
- ffelex_token_kill (ffesta_tokens[1]);
- ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
- return (ffelexHandler) ffesta_zero (t);
+ case FFELEX_typeCLOSE_PAREN:
+ return (ffelexHandler) ffestb_decl_funcname_9_;
default:
break;
}
-bad: /* :::::::::::::::::::: */
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "RECORD", t);
- if (ffestb_local_.structure.started && !ffesta_is_inhibited ())
- ffestc_V016_finish ();
- ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims);
+ if (ffestb_local_.decl.recursive != NULL)
+ ffelex_token_kill (ffestb_local_.decl.recursive);
+ if (ffestb_local_.decl.kindt != NULL)
+ ffelex_token_kill (ffestb_local_.decl.kindt);
+ if (ffestb_local_.decl.lent != NULL)
+ ffelex_token_kill (ffestb_local_.decl.lent);
ffelex_token_kill (ffesta_tokens[1]);
+ ffelex_token_kill (ffesta_tokens[2]);
+ ffelex_token_kill (ffestb_subrargs_.name_list.close_paren);
+ ffestt_tokenlist_kill (ffestb_subrargs_.name_list.args);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_V0166_ -- "RECORD" SLASH NAME SLASH NAME [OPEN_PAREN dimlist
- CLOSE_PAREN] COMMA
+/* ffestb_decl_funcname_9_ -- "type" [type parameters] [RECURSIVE] FUNCTION
+ NAME [type parameter] OPEN_PAREN arg-list
+ CLOSE_PAREN "RESULT" OPEN_PAREN NAME CLOSE_PAREN
- return ffestb_V0166_; // to lexer
+ return ffestb_decl_funcname_9_; // to lexer
- Handle NAME or SLASH. */
+ Must have EOS/SEMICOLON here. */
static ffelexHandler
-ffestb_V0166_ (ffelexToken t)
+ffestb_decl_funcname_9_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
- case FFELEX_typeNAME:
- ffesta_tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffestb_V0164_;
-
- case FFELEX_typeSLASH:
- return (ffelexHandler) ffestb_V0161_;
+ case FFELEX_typeEOS:
+ case FFELEX_typeSEMICOLON:
+ if (!ffesta_is_inhibited ())
+ ffestc_R1219 (ffesta_tokens[1], ffestb_subrargs_.name_list.args,
+ ffestb_subrargs_.name_list.close_paren, ffestb_local_.decl.type,
+ ffestb_local_.decl.kind, ffestb_local_.decl.kindt,
+ ffestb_local_.decl.len, ffestb_local_.decl.lent,
+ ffestb_local_.decl.recursive, ffesta_tokens[2]);
+ if (ffestb_local_.decl.recursive != NULL)
+ ffelex_token_kill (ffestb_local_.decl.recursive);
+ if (ffestb_local_.decl.kindt != NULL)
+ ffelex_token_kill (ffestb_local_.decl.kindt);
+ if (ffestb_local_.decl.lent != NULL)
+ ffelex_token_kill (ffestb_local_.decl.lent);
+ ffelex_token_kill (ffesta_tokens[1]);
+ ffelex_token_kill (ffesta_tokens[2]);
+ ffelex_token_kill (ffestb_subrargs_.name_list.close_paren);
+ ffestt_tokenlist_kill (ffestb_subrargs_.name_list.args);
+ return (ffelexHandler) ffesta_zero (t);
default:
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "RECORD", t);
break;
}
- if (!ffesta_is_inhibited ())
- ffestc_V016_finish ();
+ if (ffestb_local_.decl.recursive != NULL)
+ ffelex_token_kill (ffestb_local_.decl.recursive);
+ if (ffestb_local_.decl.kindt != NULL)
+ ffelex_token_kill (ffestb_local_.decl.kindt);
+ if (ffestb_local_.decl.lent != NULL)
+ ffelex_token_kill (ffestb_local_.decl.lent);
+ ffelex_token_kill (ffesta_tokens[1]);
+ ffelex_token_kill (ffesta_tokens[2]);
+ ffelex_token_kill (ffestb_subrargs_.name_list.close_paren);
+ ffestt_tokenlist_kill (ffestb_subrargs_.name_list.args);
+ ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t);
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-
-#endif
/* ffestb_V027 -- Parse the VXT PARAMETER statement
return ffestb_V027; // to lexer
case FFESTR_secondNONE:
return (ffelexHandler) ffestb_decl_R5394_;
-#if FFESTR_F90
- case FFESTR_secondTYPE:
- ffestb_local_.decl.type = FFESTP_typeTYPE;
- return (ffelexHandler) ffestb_decl_R5393_;
-#endif
-
default:
goto bad_1; /* :::::::::::::::::::: */
}
case FFESTR_secondNONE:
return (ffelexHandler) ffestb_decl_R5394_ (t);
-#if FFESTR_F90
- case FFESTR_secondTYPE:
- ffestb_local_.decl.type = FFESTP_typeTYPE;
- return (ffelexHandler) ffestb_decl_R5393_ (t);
-#endif
-
default:
goto bad_1; /* :::::::::::::::::::: */
}
return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
}
-/* ffestb_decl_R5393_ -- "IMPLICIT" "TYPE"
-
- return ffestb_decl_R5393_; // to lexer
-
- Handle OPEN_PAREN. */
-
-#if FFESTR_F90
-static ffelexHandler
-ffestb_decl_R5393_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeOPEN_PAREN:
- ffestb_local_.decl.handler = (ffelexHandler) ffestb_decl_R539letters_;
- ffestb_local_.decl.badname = "IMPLICIT";
- return (ffelexHandler) ffestb_decl_typetype1_;
-
- default:
- break;
- }
-
- if (ffestb_local_.decl.imp_started && !ffesta_is_inhibited ())
- ffestc_R539finish ();
- ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "IMPLICIT", t);
- return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero);
-}
-
-#endif
/* ffestb_decl_R5394_ -- "IMPLICIT" "NONE"
return ffestb_decl_R5394_; // to lexer
ffestb_local_.decl.lent = NULL;
return (ffelexHandler) ffestb_decl_R539letters_;
-#if FFESTR_F90
- case FFESTR_secondTYPE:
- ffestb_local_.decl.type = FFESTP_typeTYPE;
- return (ffelexHandler) ffestb_decl_R5393_;
-#endif
-
default:
break;
}
ffesymbol symbol; /* SFN symbol. */
}
sfunc;
-#if FFESTR_VXT
- struct
- {
- char list_state; /* 0=>no field names allowed, 1=>error
- reported already, 2=>field names req'd,
- 3=>have a field name. */
- }
- V003;
-#endif
}; /* Merge with the one in ffestc later. */
/* Static objects accessed by functions in this module. */
ffelab *label);
static bool ffestc_labelref_is_loopend_ (ffelexToken label_token,
ffelab *label);
-#if FFESTR_F90
-static ffestcOrder_ ffestc_order_access_ (void);
-#endif
static ffestcOrder_ ffestc_order_actiondo_ (void);
static ffestcOrder_ ffestc_order_actionif_ (void);
static ffestcOrder_ ffestc_order_actionwhere_ (void);
static void ffestc_order_bad_ (void);
static ffestcOrder_ ffestc_order_blockdata_ (void);
static ffestcOrder_ ffestc_order_blockspec_ (void);
-#if FFESTR_F90
-static ffestcOrder_ ffestc_order_component_ (void);
-#endif
-#if FFESTR_F90
-static ffestcOrder_ ffestc_order_contains_ (void);
-#endif
static ffestcOrder_ ffestc_order_data_ (void);
static ffestcOrder_ ffestc_order_data77_ (void);
-#if FFESTR_F90
-static ffestcOrder_ ffestc_order_derivedtype_ (void);
-#endif
static ffestcOrder_ ffestc_order_do_ (void);
static ffestcOrder_ ffestc_order_entry_ (void);
static ffestcOrder_ ffestc_order_exec_ (void);
static ffestcOrder_ ffestc_order_ifthen_ (void);
static ffestcOrder_ ffestc_order_implicit_ (void);
static ffestcOrder_ ffestc_order_implicitnone_ (void);
-#if FFESTR_F90
-static ffestcOrder_ ffestc_order_interface_ (void);
-#endif
-#if FFESTR_F90
-static ffestcOrder_ ffestc_order_map_ (void);
-#endif
-#if FFESTR_F90
-static ffestcOrder_ ffestc_order_module_ (void);
-#endif
static ffestcOrder_ ffestc_order_parameter_ (void);
static ffestcOrder_ ffestc_order_program_ (void);
static ffestcOrder_ ffestc_order_progspec_ (void);
-#if FFESTR_F90
-static ffestcOrder_ ffestc_order_record_ (void);
-#endif
static ffestcOrder_ ffestc_order_selectcase_ (void);
static ffestcOrder_ ffestc_order_sfunc_ (void);
-#if FFESTR_F90
-static ffestcOrder_ ffestc_order_spec_ (void);
-#endif
-#if FFESTR_VXT
-static ffestcOrder_ ffestc_order_structure_ (void);
-#endif
static ffestcOrder_ ffestc_order_subroutine_ (void);
-#if FFESTR_F90
-static ffestcOrder_ ffestc_order_type_ (void);
-#endif
static ffestcOrder_ ffestc_order_typedecl_ (void);
-#if FFESTR_VXT
-static ffestcOrder_ ffestc_order_union_ (void);
-#endif
static ffestcOrder_ ffestc_order_unit_ (void);
-#if FFESTR_F90
-static ffestcOrder_ ffestc_order_use_ (void);
-#endif
-#if FFESTR_VXT
-static ffestcOrder_ ffestc_order_vxtstructure_ (void);
-#endif
-#if FFESTR_F90
-static ffestcOrder_ ffestc_order_where_ (void);
-#endif
static void ffestc_promote_dummy_ (ffelexToken t);
static void ffestc_promote_execdummy_ (ffelexToken t);
static void ffestc_promote_sfdummy_ (ffelexToken t);
static void ffestc_shriek_begin_program_ (void);
-#if FFESTR_F90
-static void ffestc_shriek_begin_uses_ (void);
-#endif
static void ffestc_shriek_blockdata_ (bool ok);
static void ffestc_shriek_do_ (bool ok);
static void ffestc_shriek_end_program_ (bool ok);
-#if FFESTR_F90
-static void ffestc_shriek_end_uses_ (bool ok);
-#endif
static void ffestc_shriek_function_ (bool ok);
static void ffestc_shriek_if_ (bool ok);
static void ffestc_shriek_ifthen_ (bool ok);
-#if FFESTR_F90
-static void ffestc_shriek_interface_ (bool ok);
-#endif
-#if FFESTR_F90
-static void ffestc_shriek_map_ (bool ok);
-#endif
-#if FFESTR_F90
-static void ffestc_shriek_module_ (bool ok);
-#endif
static void ffestc_shriek_select_ (bool ok);
-#if FFESTR_VXT
-static void ffestc_shriek_structure_ (bool ok);
-#endif
static void ffestc_shriek_subroutine_ (bool ok);
-#if FFESTR_F90
-static void ffestc_shriek_type_ (bool ok);
-#endif
-#if FFESTR_VXT
-static void ffestc_shriek_union_ (bool ok);
-#endif
-#if FFESTR_F90
-static void ffestc_shriek_where_ (bool ok);
-#endif
-#if FFESTR_F90
-static void ffestc_shriek_wherethen_ (bool ok);
-#endif
static int ffestc_subr_binsrch_ (const char *const *list, int size,
ffestpFile *spec, const char *whine);
static ffestvFormat ffestc_subr_format_ (ffestpFile *spec);
|| ffestc_statelet_ == FFESTC_stateletITEM_); \
ffestc_statelet_ = FFESTC_stateletSIMPLE_
#define ffestc_order_action_() ffestc_order_exec_()
-#if FFESTR_F90
-#define ffestc_order_interfacespec_() ffestc_order_derivedtype_()
-#endif
#define ffestc_shriek_if_lost_ ffestc_shriek_if_
-#if FFESTR_F90
-#define ffestc_shriek_where_lost_ ffestc_shriek_where_
-#endif
\f
/* ffestc_establish_declinfo_ -- Determine specific type/params info for entity
return TRUE;
}
-/* ffestc_order_access_ -- Check ordering on <access> statement
-
- if (ffestc_order_access_() != FFESTC_orderOK_)
- return; */
-
-#if FFESTR_F90
-static ffestcOrder_
-ffestc_order_access_ ()
-{
- recurse:
-
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateNIL:
- ffestc_shriek_begin_program_ ();
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_stateMODULE0:
- case FFESTV_stateMODULE1:
- case FFESTV_stateMODULE2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
- return FFESTC_orderOK_;
-
- case FFESTV_stateMODULE3:
- return FFESTC_orderOK_;
-
- case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
- return FFESTC_orderBAD_;
-
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
-
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
-}
-
-#endif
/* ffestc_order_actiondo_ -- Check ordering on <actiondo> statement
if (ffestc_order_actiondo_() != FFESTC_orderOK_)
return FFESTC_orderOK_;
case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
goto recurse; /* :::::::::::::::::::: */
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
return FFESTC_orderBAD_;
default:
return FFESTC_orderOK_;
case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
goto recurse; /* :::::::::::::::::::: */
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
return FFESTC_orderBAD_;
default:
return FFESTC_orderOK_;
case FFESTV_stateWHERE:
-#if FFESTR_F90
- ffestc_shriek_after1_ = ffestc_shriek_where_;
-#endif
return FFESTC_orderOK_;
case FFESTV_stateIF:
return FFESTC_orderOK_;
case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
goto recurse; /* :::::::::::::::::::: */
default:
return;
case FFESTV_stateWHERE:
-#if FFESTR_F90
- ffestc_shriek_after1_ = ffestc_shriek_where_;
-#endif
return;
case FFESTV_stateIF:
return;
case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
goto recurse; /* :::::::::::::::::::: */
default:
return FFESTC_orderOK_;
case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
goto recurse; /* :::::::::::::::::::: */
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
return FFESTC_orderBAD_;
case FFESTV_stateIF:
return FFESTC_orderOK_;
case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
- return FFESTC_orderBAD_;
-
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
-
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
-}
-
-/* ffestc_order_component_ -- Check ordering on <component-decl> statement
-
- if (ffestc_order_component_() != FFESTC_orderOK_)
- return; */
-
-#if FFESTR_F90
-static ffestcOrder_
-ffestc_order_component_ ()
-{
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateTYPE:
- case FFESTV_stateSTRUCTURE:
- case FFESTV_stateMAP:
- return FFESTC_orderOK_;
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
- ffestc_shriek_where_ (FALSE);
- return FFESTC_orderBAD_;
-
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
-
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
-}
-
-#endif
-/* ffestc_order_contains_ -- Check ordering on CONTAINS statement
-
- if (ffestc_order_contains_() != FFESTC_orderOK_)
- return; */
-
-#if FFESTR_F90
-static ffestcOrder_
-ffestc_order_contains_ ()
-{
- recurse:
-
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateNIL:
- ffestc_shriek_begin_program_ ();
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_statePROGRAM0:
- case FFESTV_statePROGRAM1:
- case FFESTV_statePROGRAM2:
- case FFESTV_statePROGRAM3:
- case FFESTV_statePROGRAM4:
- ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM5);
- break;
-
- case FFESTV_stateSUBROUTINE0:
- case FFESTV_stateSUBROUTINE1:
- case FFESTV_stateSUBROUTINE2:
- case FFESTV_stateSUBROUTINE3:
- case FFESTV_stateSUBROUTINE4:
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE5);
- break;
-
- case FFESTV_stateFUNCTION0:
- case FFESTV_stateFUNCTION1:
- case FFESTV_stateFUNCTION2:
- case FFESTV_stateFUNCTION3:
- case FFESTV_stateFUNCTION4:
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION5);
- break;
-
- case FFESTV_stateMODULE0:
- case FFESTV_stateMODULE1:
- case FFESTV_stateMODULE2:
- case FFESTV_stateMODULE3:
- case FFESTV_stateMODULE4:
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE5);
- break;
-
- case FFESTV_stateUSE:
- ffestc_shriek_end_uses_ (TRUE);
goto recurse; /* :::::::::::::::::::: */
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
- ffestc_shriek_where_ (FALSE);
return FFESTC_orderBAD_;
case FFESTV_stateIF:
ffestc_order_bad_ ();
return FFESTC_orderBAD_;
}
-
- switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
- {
- case FFESTV_stateNIL:
- ffestw_update (NULL);
- return FFESTC_orderOK_;
-
- default:
- ffestc_order_bad_ ();
- ffestw_update (NULL);
- return FFESTC_orderBAD_;
- }
}
-
-#endif
/* ffestc_order_data_ -- Check ordering on DATA statement
if (ffestc_order_data_() != FFESTC_orderOK_)
return FFESTC_orderOK_;
case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
goto recurse; /* :::::::::::::::::::: */
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
return FFESTC_orderBAD_;
case FFESTV_stateIF:
return FFESTC_orderOK_;
case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
goto recurse; /* :::::::::::::::::::: */
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
return FFESTC_orderBAD_;
case FFESTV_stateIF:
return FFESTC_orderBAD_;
}
}
+/* ffestc_order_do_ -- Check ordering on <do> statement
-/* ffestc_order_derivedtype_ -- Check ordering on derived TYPE statement
-
- if (ffestc_order_derivedtype_() != FFESTC_orderOK_)
+ if (ffestc_order_do_() != FFESTC_orderOK_)
return; */
-#if FFESTR_F90
static ffestcOrder_
-ffestc_order_derivedtype_ ()
+ffestc_order_do_ ()
{
- recurse:
-
switch (ffestw_state (ffestw_stack_top ()))
{
- case FFESTV_stateNIL:
- ffestc_shriek_begin_program_ ();
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_statePROGRAM0:
- case FFESTV_statePROGRAM1:
- case FFESTV_statePROGRAM2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
- return FFESTC_orderOK_;
-
- case FFESTV_stateSUBROUTINE0:
- case FFESTV_stateSUBROUTINE1:
- case FFESTV_stateSUBROUTINE2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
- return FFESTC_orderOK_;
-
- case FFESTV_stateFUNCTION0:
- case FFESTV_stateFUNCTION1:
- case FFESTV_stateFUNCTION2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
- return FFESTC_orderOK_;
-
- case FFESTV_stateMODULE0:
- case FFESTV_stateMODULE1:
- case FFESTV_stateMODULE2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
- return FFESTC_orderOK_;
-
- case FFESTV_statePROGRAM3:
- case FFESTV_stateSUBROUTINE3:
- case FFESTV_stateFUNCTION3:
- case FFESTV_stateMODULE3:
+ case FFESTV_stateDO:
return FFESTC_orderOK_;
- case FFESTV_stateUSE:
- ffestc_shriek_end_uses_ (TRUE);
- goto recurse; /* :::::::::::::::::::: */
-
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
- ffestc_shriek_where_ (FALSE);
return FFESTC_orderBAD_;
case FFESTV_stateIF:
}
}
-#endif
-/* ffestc_order_do_ -- Check ordering on <do> statement
+/* ffestc_order_entry_ -- Check ordering on ENTRY statement
- if (ffestc_order_do_() != FFESTC_orderOK_)
+ if (ffestc_order_entry_() != FFESTC_orderOK_)
return; */
static ffestcOrder_
-ffestc_order_do_ ()
+ffestc_order_entry_ ()
{
+ recurse:
+
switch (ffestw_state (ffestw_stack_top ()))
{
- case FFESTV_stateDO:
- return FFESTC_orderOK_;
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
- return FFESTC_orderBAD_;
-
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
-
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
-}
-
-/* ffestc_order_entry_ -- Check ordering on ENTRY statement
-
- if (ffestc_order_entry_() != FFESTC_orderOK_)
- return; */
-
-static ffestcOrder_
-ffestc_order_entry_ ()
-{
- recurse:
-
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateNIL:
- ffestc_shriek_begin_program_ ();
- goto recurse; /* :::::::::::::::::::: */
+ case FFESTV_stateNIL:
+ ffestc_shriek_begin_program_ ();
+ goto recurse; /* :::::::::::::::::::: */
case FFESTV_stateSUBROUTINE0:
ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE1);
break;
case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
goto recurse; /* :::::::::::::::::::: */
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
return FFESTC_orderBAD_;
case FFESTV_stateIF:
return FFESTC_orderOK_;
case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
goto recurse; /* :::::::::::::::::::: */
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
return FFESTC_orderBAD_;
case FFESTV_stateIF:
return FFESTC_orderOK_;
case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
goto recurse; /* :::::::::::::::::::: */
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
return FFESTC_orderBAD_;
case FFESTV_stateIF:
return FFESTC_orderOK_;
case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
goto recurse; /* :::::::::::::::::::: */
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
return FFESTC_orderBAD_;
case FFESTV_stateIF:
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
return FFESTC_orderBAD_;
case FFESTV_stateIF:
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
return FFESTC_orderBAD_;
case FFESTV_stateIF:
return FFESTC_orderOK_;
case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
goto recurse; /* :::::::::::::::::::: */
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
return FFESTC_orderBAD_;
case FFESTV_stateIF:
return FFESTC_orderOK_;
case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
- return FFESTC_orderBAD_;
-
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
-
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
-}
-
-/* ffestc_order_interface_ -- Check ordering on <interface> statement
-
- if (ffestc_order_interface_() != FFESTC_orderOK_)
- return; */
-
-#if FFESTR_F90
-static ffestcOrder_
-ffestc_order_interface_ ()
-{
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateINTERFACE0:
- case FFESTV_stateINTERFACE1:
- return FFESTC_orderOK_;
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
- ffestc_shriek_where_ (FALSE);
- return FFESTC_orderBAD_;
-
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
-
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
-}
-
-#endif
-/* ffestc_order_map_ -- Check ordering on <map> statement
-
- if (ffestc_order_map_() != FFESTC_orderOK_)
- return; */
-
-#if FFESTR_VXT
-static ffestcOrder_
-ffestc_order_map_ ()
-{
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateMAP:
- return FFESTC_orderOK_;
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
- ffestc_shriek_where_ (FALSE);
- return FFESTC_orderBAD_;
-
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
-
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
-}
-
-#endif
-/* ffestc_order_module_ -- Check ordering on <module> statement
-
- if (ffestc_order_module_() != FFESTC_orderOK_)
- return; */
-
-#if FFESTR_F90
-static ffestcOrder_
-ffestc_order_module_ ()
-{
- recurse:
-
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateMODULE0:
- case FFESTV_stateMODULE1:
- case FFESTV_stateMODULE2:
- case FFESTV_stateMODULE3:
- case FFESTV_stateMODULE4:
- case FFESTV_stateMODULE5:
- return FFESTC_orderOK_;
-
- case FFESTV_stateUSE:
- ffestc_shriek_end_uses_ (TRUE);
goto recurse; /* :::::::::::::::::::: */
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
- ffestc_shriek_where_ (FALSE);
return FFESTC_orderBAD_;
case FFESTV_stateIF:
}
}
-#endif
/* ffestc_order_parameter_ -- Check ordering on <parameter> statement
if (ffestc_order_parameter_() != FFESTC_orderOK_)
return FFESTC_orderOK_;
case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
goto recurse; /* :::::::::::::::::::: */
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
return FFESTC_orderBAD_;
case FFESTV_stateIF:
return FFESTC_orderOK_;
case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
goto recurse; /* :::::::::::::::::::: */
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
return FFESTC_orderBAD_;
case FFESTV_stateIF:
return FFESTC_orderOK_;
case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
goto recurse; /* :::::::::::::::::::: */
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
+ return FFESTC_orderBAD_;
+
+ case FFESTV_stateIF:
+ ffestc_order_bad_ ();
+ ffestc_shriek_if_ (FALSE);
+ return FFESTC_orderBAD_;
+
+ default:
+ ffestc_order_bad_ ();
+ return FFESTC_orderBAD_;
+ }
+}
+/* ffestc_order_selectcase_ -- Check ordering on <selectcase> statement
+
+ if (ffestc_order_selectcase_() != FFESTC_orderOK_)
+ return; */
+
+static ffestcOrder_
+ffestc_order_selectcase_ ()
+{
+ switch (ffestw_state (ffestw_stack_top ()))
+ {
+ case FFESTV_stateSELECT0:
+ case FFESTV_stateSELECT1:
+ return FFESTC_orderOK_;
+
+ case FFESTV_stateWHERE:
+ ffestc_order_bad_ ();
return FFESTC_orderBAD_;
case FFESTV_stateIF:
}
}
-/* ffestc_order_record_ -- Check ordering on RECORD statement
+/* ffestc_order_sfunc_ -- Check ordering on statement-function definition
- if (ffestc_order_record_() != FFESTC_orderOK_)
+ if (ffestc_order_sfunc_() != FFESTC_orderOK_)
return; */
-#if FFESTR_VXT
static ffestcOrder_
-ffestc_order_record_ ()
+ffestc_order_sfunc_ ()
{
recurse:
ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
return FFESTC_orderOK_;
- case FFESTV_stateMODULE0:
- case FFESTV_stateMODULE1:
- case FFESTV_stateMODULE2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
- return FFESTC_orderOK_;
-
- case FFESTV_stateBLOCKDATA0:
- case FFESTV_stateBLOCKDATA1:
- case FFESTV_stateBLOCKDATA2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA3);
- return FFESTC_orderOK_;
-
case FFESTV_statePROGRAM3:
case FFESTV_stateSUBROUTINE3:
case FFESTV_stateFUNCTION3:
- case FFESTV_stateMODULE3:
- case FFESTV_stateBLOCKDATA3:
- case FFESTV_stateSTRUCTURE:
- case FFESTV_stateMAP:
return FFESTC_orderOK_;
case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
goto recurse; /* :::::::::::::::::::: */
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
return FFESTC_orderBAD_;
case FFESTV_stateIF:
return FFESTC_orderBAD_;
}
}
+/* ffestc_order_subroutine_ -- Check ordering on <subroutine> statement
-#endif
-/* ffestc_order_selectcase_ -- Check ordering on <selectcase> statement
-
- if (ffestc_order_selectcase_() != FFESTC_orderOK_)
+ if (ffestc_order_subroutine_() != FFESTC_orderOK_)
return; */
static ffestcOrder_
-ffestc_order_selectcase_ ()
+ffestc_order_subroutine_ ()
{
+ recurse:
+
switch (ffestw_state (ffestw_stack_top ()))
{
- case FFESTV_stateSELECT0:
- case FFESTV_stateSELECT1:
+ case FFESTV_stateSUBROUTINE0:
+ case FFESTV_stateSUBROUTINE1:
+ case FFESTV_stateSUBROUTINE2:
+ case FFESTV_stateSUBROUTINE3:
+ case FFESTV_stateSUBROUTINE4:
+ case FFESTV_stateSUBROUTINE5:
return FFESTC_orderOK_;
+ case FFESTV_stateUSE:
+ goto recurse; /* :::::::::::::::::::: */
+
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
return FFESTC_orderBAD_;
case FFESTV_stateIF:
}
}
-/* ffestc_order_sfunc_ -- Check ordering on statement-function definition
+/* ffestc_order_typedecl_ -- Check ordering on <typedecl> statement
- if (ffestc_order_sfunc_() != FFESTC_orderOK_)
+ if (ffestc_order_typedecl_() != FFESTC_orderOK_)
return; */
static ffestcOrder_
-ffestc_order_sfunc_ ()
+ffestc_order_typedecl_ ()
{
recurse:
ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
return FFESTC_orderOK_;
+ case FFESTV_stateMODULE0:
+ case FFESTV_stateMODULE1:
+ case FFESTV_stateMODULE2:
+ ffestw_update (NULL);
+ ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
+ return FFESTC_orderOK_;
+
+ case FFESTV_stateBLOCKDATA0:
+ case FFESTV_stateBLOCKDATA1:
+ case FFESTV_stateBLOCKDATA2:
+ ffestw_update (NULL);
+ ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA3);
+ return FFESTC_orderOK_;
+
case FFESTV_statePROGRAM3:
case FFESTV_stateSUBROUTINE3:
case FFESTV_stateFUNCTION3:
+ case FFESTV_stateMODULE3:
+ case FFESTV_stateBLOCKDATA3:
return FFESTC_orderOK_;
case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
goto recurse; /* :::::::::::::::::::: */
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
return FFESTC_orderBAD_;
case FFESTV_stateIF:
return FFESTC_orderBAD_;
}
}
+/* ffestc_order_unit_ -- Check ordering on <unit> statement
-/* ffestc_order_spec_ -- Check ordering on <spec> statement
-
- if (ffestc_order_spec_() != FFESTC_orderOK_)
+ if (ffestc_order_unit_() != FFESTC_orderOK_)
return; */
-#if FFESTR_F90
static ffestcOrder_
-ffestc_order_spec_ ()
+ffestc_order_unit_ ()
{
- recurse:
-
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateNIL:
- ffestc_shriek_begin_program_ ();
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_stateSUBROUTINE0:
- case FFESTV_stateSUBROUTINE1:
- case FFESTV_stateSUBROUTINE2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
return FFESTC_orderOK_;
- case FFESTV_stateFUNCTION0:
- case FFESTV_stateFUNCTION1:
- case FFESTV_stateFUNCTION2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
- return FFESTC_orderOK_;
-
- case FFESTV_stateMODULE0:
- case FFESTV_stateMODULE1:
- case FFESTV_stateMODULE2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
- return FFESTC_orderOK_;
-
- case FFESTV_stateSUBROUTINE3:
- case FFESTV_stateFUNCTION3:
- case FFESTV_stateMODULE3:
- return FFESTC_orderOK_;
-
- case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
- return FFESTC_orderBAD_;
+ case FFESTV_stateWHERE:
+ ffestc_order_bad_ ();
+ return FFESTC_orderBAD_;
case FFESTV_stateIF:
ffestc_order_bad_ ();
return FFESTC_orderBAD_;
}
}
+/* Invoked for each token in dummy arg list of FUNCTION, SUBROUTINE, and
+ ENTRY (prior to the first executable statement). */
-#endif
-/* ffestc_order_structure_ -- Check ordering on <structure> statement
+static void
+ffestc_promote_dummy_ (ffelexToken t)
+{
+ ffesymbol s;
+ ffesymbolAttrs sa;
+ ffesymbolAttrs na;
+ ffebld e;
+ bool sfref_ok;
- if (ffestc_order_structure_() != FFESTC_orderOK_)
- return; */
+ assert (t != NULL);
-#if FFESTR_VXT
-static ffestcOrder_
-ffestc_order_structure_ ()
-{
- switch (ffestw_state (ffestw_stack_top ()))
+ if (ffelex_token_type (t) == FFELEX_typeASTERISK)
{
- case FFESTV_stateSTRUCTURE:
- return FFESTC_orderOK_;
+ ffebld_append_item (&ffestc_local_.dummy.list_bottom,
+ ffebld_new_star ());
+ return; /* Don't bother with alternate returns! */
+ }
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
- return FFESTC_orderBAD_;
+ s = ffesymbol_declare_local (t, FALSE);
+ sa = ffesymbol_attrs (s);
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
+ /* Figure out what kind of object we've got based on previous declarations
+ of or references to the object. */
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
+ sfref_ok = FALSE;
+
+ if (sa & FFESYMBOL_attrsANY)
+ na = sa;
+ else if (sa & FFESYMBOL_attrsDUMMY)
+ {
+ if (ffestc_entry_num_ == ffesymbol_maxentrynum (s))
+ { /* Seen this one twice in this list! */
+ na = FFESYMBOL_attrsetNONE;
+ }
+ else
+ na = sa;
+ sfref_ok = TRUE; /* Ok for sym to be ref'd in sfuncdef
+ previously, since already declared as a
+ dummy arg. */
+ }
+ else if (!(sa & ~(FFESYMBOL_attrsADJUSTABLE
+ | FFESYMBOL_attrsADJUSTS
+ | FFESYMBOL_attrsANY
+ | FFESYMBOL_attrsANYLEN
+ | FFESYMBOL_attrsANYSIZE
+ | FFESYMBOL_attrsARRAY
+ | FFESYMBOL_attrsDUMMY
+ | FFESYMBOL_attrsEXTERNAL
+ | FFESYMBOL_attrsSFARG
+ | FFESYMBOL_attrsTYPE)))
+ na = sa | FFESYMBOL_attrsDUMMY;
+ else
+ na = FFESYMBOL_attrsetNONE;
+
+ if (!ffesymbol_is_specable (s)
+ && (!sfref_ok
+ || (ffesymbol_where (s) != FFEINFO_whereDUMMY)))
+ na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
+
+ /* Now see what we've got for a new object: NONE means a new error cropped
+ up; ANY means an old error to be ignored; otherwise, everything's ok,
+ update the object (symbol) and continue on. */
+
+ if (na == FFESYMBOL_attrsetNONE)
+ ffesymbol_error (s, t);
+ else if (!(na & FFESYMBOL_attrsANY))
+ {
+ ffesymbol_set_attrs (s, na);
+ if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
+ ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
+ ffesymbol_set_maxentrynum (s, ffestc_entry_num_);
+ ffesymbol_set_numentries (s, ffesymbol_numentries (s) + 1);
+ e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
+ FFEINTRIN_impNONE);
+ ffebld_set_info (e,
+ ffeinfo_new (FFEINFO_basictypeNONE,
+ FFEINFO_kindtypeNONE,
+ 0,
+ FFEINFO_kindNONE,
+ FFEINFO_whereNONE,
+ FFETARGET_charactersizeNONE));
+ ffebld_append_item (&ffestc_local_.dummy.list_bottom, e);
+ ffesymbol_signal_unreported (s);
}
}
-#endif
-/* ffestc_order_subroutine_ -- Check ordering on <subroutine> statement
+/* ffestc_promote_execdummy_ -- Declare token as dummy variable in exec context
- if (ffestc_order_subroutine_() != FFESTC_orderOK_)
- return; */
+ ffestc_promote_execdummy_(t);
-static ffestcOrder_
-ffestc_order_subroutine_ ()
-{
- recurse:
+ Invoked for each token in dummy arg list of ENTRY when the statement
+ follows the first executable statement. */
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateSUBROUTINE0:
- case FFESTV_stateSUBROUTINE1:
- case FFESTV_stateSUBROUTINE2:
- case FFESTV_stateSUBROUTINE3:
- case FFESTV_stateSUBROUTINE4:
- case FFESTV_stateSUBROUTINE5:
- return FFESTC_orderOK_;
+static void
+ffestc_promote_execdummy_ (ffelexToken t)
+{
+ ffesymbol s;
+ ffesymbolAttrs sa;
+ ffesymbolAttrs na;
+ ffesymbolState ss;
+ ffesymbolState ns;
+ ffeinfoKind kind;
+ ffeinfoWhere where;
+ ffebld e;
- case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
- goto recurse; /* :::::::::::::::::::: */
+ assert (t != NULL);
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
- return FFESTC_orderBAD_;
+ if (ffelex_token_type (t) == FFELEX_typeASTERISK)
+ {
+ ffebld_append_item (&ffestc_local_.dummy.list_bottom,
+ ffebld_new_star ());
+ return; /* Don't bother with alternate returns! */
+ }
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
+ s = ffesymbol_declare_local (t, FALSE);
+ na = sa = ffesymbol_attrs (s);
+ ss = ffesymbol_state (s);
+ kind = ffesymbol_kind (s);
+ where = ffesymbol_where (s);
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
+ if (ffestc_entry_num_ == ffesymbol_maxentrynum (s))
+ { /* Seen this one twice in this list! */
+ na = FFESYMBOL_attrsetNONE;
}
-}
-/* ffestc_order_type_ -- Check ordering on <type> statement
+ /* Figure out what kind of object we've got based on previous declarations
+ of or references to the object. */
- if (ffestc_order_type_() != FFESTC_orderOK_)
- return; */
+ ns = FFESYMBOL_stateUNDERSTOOD; /* Assume we know it all know. */
-#if FFESTR_F90
-static ffestcOrder_
-ffestc_order_type_ ()
-{
- switch (ffestw_state (ffestw_stack_top ()))
+ switch (kind)
{
- case FFESTV_stateTYPE:
- return FFESTC_orderOK_;
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
- ffestc_shriek_where_ (FALSE);
- return FFESTC_orderBAD_;
+ case FFEINFO_kindENTITY:
+ case FFEINFO_kindFUNCTION:
+ case FFEINFO_kindSUBROUTINE:
+ break; /* These are fine, as far as we know. */
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
+ case FFEINFO_kindNONE:
+ if (sa & FFESYMBOL_attrsDUMMY)
+ ns = FFESYMBOL_stateUNCERTAIN; /* Learned nothing new. */
+ else if (sa & FFESYMBOL_attrsANYLEN)
+ {
+ kind = FFEINFO_kindENTITY;
+ where = FFEINFO_whereDUMMY;
+ }
+ else if (sa & FFESYMBOL_attrsACTUALARG)
+ na = FFESYMBOL_attrsetNONE;
+ else
+ {
+ na = sa | FFESYMBOL_attrsDUMMY;
+ ns = FFESYMBOL_stateUNCERTAIN;
+ }
+ break;
default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
+ na = FFESYMBOL_attrsetNONE; /* Error. */
+ break;
}
-}
-#endif
-/* ffestc_order_typedecl_ -- Check ordering on <typedecl> statement
+ switch (where)
+ {
+ case FFEINFO_whereDUMMY:
+ break; /* This is fine. */
- if (ffestc_order_typedecl_() != FFESTC_orderOK_)
- return; */
+ case FFEINFO_whereNONE:
+ where = FFEINFO_whereDUMMY;
+ break;
-static ffestcOrder_
-ffestc_order_typedecl_ ()
-{
- recurse:
+ default:
+ na = FFESYMBOL_attrsetNONE; /* Error. */
+ break;
+ }
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateNIL:
- ffestc_shriek_begin_program_ ();
- goto recurse; /* :::::::::::::::::::: */
+ /* Now see what we've got for a new object: NONE means a new error cropped
+ up; ANY means an old error to be ignored; otherwise, everything's ok,
+ update the object (symbol) and continue on. */
- case FFESTV_statePROGRAM0:
- case FFESTV_statePROGRAM1:
- case FFESTV_statePROGRAM2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
- return FFESTC_orderOK_;
+ if (na == FFESYMBOL_attrsetNONE)
+ ffesymbol_error (s, t);
+ else if (!(na & FFESYMBOL_attrsANY))
+ {
+ ffesymbol_set_attrs (s, na);
+ ffesymbol_set_state (s, ns);
+ ffesymbol_set_maxentrynum (s, ffestc_entry_num_);
+ ffesymbol_set_numentries (s, ffesymbol_numentries (s) + 1);
+ if ((ns == FFESYMBOL_stateUNDERSTOOD)
+ && (kind != FFEINFO_kindSUBROUTINE)
+ && !ffeimplic_establish_symbol (s))
+ {
+ ffesymbol_error (s, t);
+ return;
+ }
+ ffesymbol_set_info (s,
+ ffeinfo_new (ffesymbol_basictype (s),
+ ffesymbol_kindtype (s),
+ ffesymbol_rank (s),
+ kind,
+ where,
+ ffesymbol_size (s)));
+ e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
+ FFEINTRIN_impNONE);
+ ffebld_set_info (e, ffeinfo_use (ffesymbol_info (s)));
+ ffebld_append_item (&ffestc_local_.dummy.list_bottom, e);
+ s = ffecom_sym_learned (s);
+ ffesymbol_signal_unreported (s);
+ }
+}
- case FFESTV_stateSUBROUTINE0:
- case FFESTV_stateSUBROUTINE1:
- case FFESTV_stateSUBROUTINE2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
- return FFESTC_orderOK_;
+/* ffestc_promote_sfdummy_ -- Declare token as stmt-func dummy variable
- case FFESTV_stateFUNCTION0:
- case FFESTV_stateFUNCTION1:
- case FFESTV_stateFUNCTION2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
- return FFESTC_orderOK_;
+ ffestc_promote_sfdummy_(t);
- case FFESTV_stateMODULE0:
- case FFESTV_stateMODULE1:
- case FFESTV_stateMODULE2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
- return FFESTC_orderOK_;
+ Invoked for each token in dummy arg list of statement function.
- case FFESTV_stateBLOCKDATA0:
- case FFESTV_stateBLOCKDATA1:
- case FFESTV_stateBLOCKDATA2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA3);
- return FFESTC_orderOK_;
+ 22-Oct-91 JCB 1.1
+ Reject arg if CHARACTER*(*). */
- case FFESTV_statePROGRAM3:
- case FFESTV_stateSUBROUTINE3:
- case FFESTV_stateFUNCTION3:
- case FFESTV_stateMODULE3:
- case FFESTV_stateBLOCKDATA3:
- return FFESTC_orderOK_;
+static void
+ffestc_promote_sfdummy_ (ffelexToken t)
+{
+ ffesymbol s;
+ ffesymbol sp; /* Parent symbol. */
+ ffesymbolAttrs sa;
+ ffesymbolAttrs na;
+ ffebld e;
- case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
- goto recurse; /* :::::::::::::::::::: */
+ assert (t != NULL);
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
- return FFESTC_orderBAD_;
+ s = ffesymbol_declare_sfdummy (t); /* Sets maxentrynum to 0 for new obj;
+ also sets sfa_dummy_parent to
+ parent symbol. */
+ if (ffesymbol_state (s) != FFESYMBOL_stateNONE)
+ {
+ ffesymbol_error (s, t); /* Dummy already in list. */
+ return;
+ }
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
+ sp = ffesymbol_sfdummyparent (s); /* Now flag dummy's parent as used
+ for dummy. */
+ sa = ffesymbol_attrs (sp);
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
+ /* Figure out what kind of object we've got based on previous declarations
+ of or references to the object. */
+
+ if (!ffesymbol_is_specable (sp)
+ && ((ffesymbol_kind (sp) != FFEINFO_kindENTITY)
+ || ((ffesymbol_where (sp) != FFEINFO_whereLOCAL)
+ && (ffesymbol_where (sp) != FFEINFO_whereCOMMON)
+ && (ffesymbol_where (sp) != FFEINFO_whereDUMMY)
+ && (ffesymbol_where (sp) != FFEINFO_whereNONE))))
+ na = FFESYMBOL_attrsetNONE; /* Can't be PARAMETER etc., must be a var. */
+ else if (sa & FFESYMBOL_attrsANY)
+ na = sa;
+ else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
+ | FFESYMBOL_attrsCOMMON
+ | FFESYMBOL_attrsDUMMY
+ | FFESYMBOL_attrsEQUIV
+ | FFESYMBOL_attrsINIT
+ | FFESYMBOL_attrsNAMELIST
+ | FFESYMBOL_attrsRESULT
+ | FFESYMBOL_attrsSAVE
+ | FFESYMBOL_attrsSFARG
+ | FFESYMBOL_attrsTYPE)))
+ na = sa | FFESYMBOL_attrsSFARG;
+ else
+ na = FFESYMBOL_attrsetNONE;
+
+ /* Now see what we've got for a new object: NONE means a new error cropped
+ up; ANY means an old error to be ignored; otherwise, everything's ok,
+ update the object (symbol) and continue on. */
+
+ if (na == FFESYMBOL_attrsetNONE)
+ {
+ ffesymbol_error (sp, t);
+ ffesymbol_set_info (s, ffeinfo_new_any ());
+ }
+ else if (!(na & FFESYMBOL_attrsANY))
+ {
+ ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
+ ffesymbol_set_attrs (sp, na);
+ if (!ffeimplic_establish_symbol (sp)
+ || ((ffesymbol_basictype (sp) == FFEINFO_basictypeCHARACTER)
+ && (ffesymbol_size (sp) == FFETARGET_charactersizeNONE)))
+ ffesymbol_error (sp, t);
+ else
+ ffesymbol_set_info (s,
+ ffeinfo_new (ffesymbol_basictype (sp),
+ ffesymbol_kindtype (sp),
+ 0,
+ FFEINFO_kindENTITY,
+ FFEINFO_whereDUMMY,
+ ffesymbol_size (sp)));
+
+ ffesymbol_signal_unreported (sp);
}
+
+ ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
+ ffesymbol_set_maxentrynum (s, ffestc_sfdummy_argno_++);
+ ffesymbol_signal_unreported (s);
+ e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
+ FFEINTRIN_impNONE);
+ ffebld_set_info (e, ffeinfo_use (ffesymbol_info (s)));
+ ffebld_append_item (&ffestc_local_.dummy.list_bottom, e);
}
-/* ffestc_order_union_ -- Check ordering on <union> statement
+/* ffestc_shriek_begin_program_ -- Implicit PROGRAM statement
- if (ffestc_order_union_() != FFESTC_orderOK_)
- return; */
+ ffestc_shriek_begin_program_();
-#if FFESTR_VXT
-static ffestcOrder_
-ffestc_order_union_ ()
+ Invoked only when a PROGRAM statement is NOT present at the beginning
+ of a main program unit. */
+
+static void
+ffestc_shriek_begin_program_ ()
{
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateUNION:
- return FFESTC_orderOK_;
+ ffestw b;
+ ffesymbol s;
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
- return FFESTC_orderBAD_;
+ ffestc_blocknum_ = 0;
+ b = ffestw_update (ffestw_push (NULL));
+ ffestw_set_top_do (b, NULL);
+ ffestw_set_state (b, FFESTV_statePROGRAM0);
+ ffestw_set_blocknum (b, ffestc_blocknum_++);
+ ffestw_set_shriek (b, ffestc_shriek_end_program_);
+ ffestw_set_name (b, NULL);
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
+ s = ffesymbol_declare_programunit (NULL,
+ ffelex_token_where_line (ffesta_tokens[0]),
+ ffelex_token_where_column (ffesta_tokens[0]));
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
+ /* Special case: this is one symbol that won't go through
+ ffestu_exec_transition_ when the first statement in a main program is
+ executable, because the transition happens in ffest before ffestc is
+ reached and triggers the implicit generation of a main program. So we
+ do the exec transition for the implicit main program right here, just
+ for cleanliness' sake (at the very least). */
+
+ ffesymbol_set_info (s,
+ ffeinfo_new (FFEINFO_basictypeNONE,
+ FFEINFO_kindtypeNONE,
+ 0,
+ FFEINFO_kindPROGRAM,
+ FFEINFO_whereLOCAL,
+ FFETARGET_charactersizeNONE));
+ ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
+
+ ffesymbol_signal_unreported (s);
+
+ ffestd_R1102 (s, NULL);
}
-#endif
-/* ffestc_order_unit_ -- Check ordering on <unit> statement
+/* ffestc_shriek_blockdata_ -- End a BLOCK DATA
- if (ffestc_order_unit_() != FFESTC_orderOK_)
- return; */
+ ffestc_shriek_blockdata_(TRUE); */
-static ffestcOrder_
-ffestc_order_unit_ ()
+static void
+ffestc_shriek_blockdata_ (bool ok)
{
- switch (ffestw_state (ffestw_stack_top ()))
+ if (!ffesta_seen_first_exec)
{
- case FFESTV_stateNIL:
- return FFESTC_orderOK_;
+ ffesta_seen_first_exec = TRUE;
+ ffestd_exec_begin ();
+ }
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
- return FFESTC_orderBAD_;
+ ffestd_R1112 (ok);
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
+ ffestd_exec_end ();
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
+ if (ffestw_name (ffestw_stack_top ()) != NULL)
+ ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
+ ffestw_kill (ffestw_pop ());
+
+ ffe_terminate_2 ();
+ ffe_init_2 ();
}
-/* ffestc_order_use_ -- Check ordering on USE statement
+/* ffestc_shriek_do_ -- End of statement following DO-term-stmt etc
- if (ffestc_order_use_() != FFESTC_orderOK_)
- return; */
+ ffestc_shriek_do_(TRUE);
-#if FFESTR_F90
-static ffestcOrder_
-ffestc_order_use_ ()
+ Also invoked by _labeldef_branch_end_ (or, in cases
+ of errors, other _labeldef_ functions) when the label definition is
+ for a DO-target (LOOPEND) label, once per matching/outstanding DO
+ block on the stack. These cases invoke this function with ok==TRUE, so
+ only forced stack popping (via ffestc_eof()) invokes it with ok==FALSE. */
+
+static void
+ffestc_shriek_do_ (bool ok)
{
- recurse:
+ ffelab l;
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateNIL:
- ffestc_shriek_begin_program_ ();
- goto recurse; /* :::::::::::::::::::: */
+ if (((l = ffestw_label (ffestw_stack_top ())) != NULL)
+ && (ffewhere_line_is_unknown (ffelab_definition_line (l))))
+ { /* DO target is label that is still
+ undefined. */
+ assert ((ffelab_type (l) == FFELAB_typeLOOPEND)
+ || (ffelab_type (l) == FFELAB_typeANY));
+ if (ffelab_type (l) != FFELAB_typeANY)
+ {
+ ffelab_set_definition_line (l,
+ ffewhere_line_use (ffelab_doref_line (l)));
+ ffelab_set_definition_column (l,
+ ffewhere_column_use (ffelab_doref_column (l)));
+ ffestv_num_label_defines_++;
+ }
+ ffestd_labeldef_branch (l);
+ }
- case FFESTV_statePROGRAM0:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM1);
- ffestc_shriek_begin_uses_ ();
- goto recurse; /* :::::::::::::::::::: */
+ ffestd_do (ok);
- case FFESTV_stateSUBROUTINE0:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE1);
- ffestc_shriek_begin_uses_ ();
- goto recurse; /* :::::::::::::::::::: */
+ if (ffestw_name (ffestw_stack_top ()) != NULL)
+ ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
+ if (ffestw_do_iter_var_t (ffestw_stack_top ()) != NULL)
+ ffelex_token_kill (ffestw_do_iter_var_t (ffestw_stack_top ()));
+ if (ffestw_do_iter_var (ffestw_stack_top ()) != NULL)
+ ffesymbol_set_is_doiter (ffestw_do_iter_var (ffestw_stack_top ()), FALSE);
+ ffestw_kill (ffestw_pop ());
+}
- case FFESTV_stateFUNCTION0:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION1);
- ffestc_shriek_begin_uses_ ();
- goto recurse; /* :::::::::::::::::::: */
+/* ffestc_shriek_end_program_ -- End a PROGRAM
- case FFESTV_stateMODULE0:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE1);
- ffestc_shriek_begin_uses_ ();
- goto recurse; /* :::::::::::::::::::: */
+ ffestc_shriek_end_program_(); */
- case FFESTV_stateUSE:
- return FFESTC_orderOK_;
+static void
+ffestc_shriek_end_program_ (bool ok)
+{
+ if (!ffesta_seen_first_exec)
+ {
+ ffesta_seen_first_exec = TRUE;
+ ffestd_exec_begin ();
+ }
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
- ffestc_shriek_where_ (FALSE);
- return FFESTC_orderBAD_;
+ ffestd_R1103 (ok);
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
+ ffestd_exec_end ();
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
+ if (ffestw_name (ffestw_stack_top ()) != NULL)
+ ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
+ ffestw_kill (ffestw_pop ());
+
+ ffe_terminate_2 ();
+ ffe_init_2 ();
}
-#endif
-/* ffestc_order_vxtstructure_ -- Check ordering on STRUCTURE statement
+/* ffestc_shriek_function_ -- End a FUNCTION
- if (ffestc_order_vxtstructure_() != FFESTC_orderOK_)
- return; */
+ ffestc_shriek_function_(TRUE); */
-#if FFESTR_VXT
-static ffestcOrder_
-ffestc_order_vxtstructure_ ()
+static void
+ffestc_shriek_function_ (bool ok)
{
- recurse:
+ if (!ffesta_seen_first_exec)
+ {
+ ffesta_seen_first_exec = TRUE;
+ ffestd_exec_begin ();
+ }
+
+ ffestd_R1221 (ok);
+
+ ffestd_exec_end ();
+
+ ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
+ ffestw_kill (ffestw_pop ());
+ ffesta_is_entry_valid = FALSE;
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateNIL:
- ffestc_shriek_begin_program_ ();
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_statePROGRAM0:
- case FFESTV_statePROGRAM1:
- case FFESTV_statePROGRAM2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
- return FFESTC_orderOK_;
-
- case FFESTV_stateSUBROUTINE0:
- case FFESTV_stateSUBROUTINE1:
- case FFESTV_stateSUBROUTINE2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
- return FFESTC_orderOK_;
+ ffe_terminate_2 ();
+ ffe_init_2 ();
+ break;
- case FFESTV_stateFUNCTION0:
- case FFESTV_stateFUNCTION1:
- case FFESTV_stateFUNCTION2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
- return FFESTC_orderOK_;
+ default:
+ ffe_terminate_3 ();
+ ffe_init_3 ();
+ break;
- case FFESTV_stateMODULE0:
- case FFESTV_stateMODULE1:
- case FFESTV_stateMODULE2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
- return FFESTC_orderOK_;
+ case FFESTV_stateINTERFACE0:
+ ffe_terminate_4 ();
+ ffe_init_4 ();
+ break;
+ }
+}
- case FFESTV_stateBLOCKDATA0:
- case FFESTV_stateBLOCKDATA1:
- case FFESTV_stateBLOCKDATA2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA3);
- return FFESTC_orderOK_;
+/* ffestc_shriek_if_ -- End of statement following logical IF
- case FFESTV_statePROGRAM3:
- case FFESTV_stateSUBROUTINE3:
- case FFESTV_stateFUNCTION3:
- case FFESTV_stateMODULE3:
- case FFESTV_stateBLOCKDATA3:
- case FFESTV_stateSTRUCTURE:
- case FFESTV_stateMAP:
- return FFESTC_orderOK_;
+ ffestc_shriek_if_(TRUE);
- case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
- goto recurse; /* :::::::::::::::::::: */
+ Applies ONLY to logical IF, not to IF-THEN. For example, does not
+ ffelex_token_kill the construct name for an IF-THEN block (the name
+ field is invalid for logical IF). ok==TRUE iff statement following
+ logical IF (substatement) is valid; else, statement is invalid or
+ stack forcibly popped due to ffestc_eof(). */
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
- return FFESTC_orderBAD_;
+static void
+ffestc_shriek_if_ (bool ok)
+{
+ ffestd_end_R807 (ok);
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
+ ffestw_kill (ffestw_pop ());
+ ffestc_shriek_after1_ = NULL;
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
+ ffestc_try_shriek_do_ ();
}
-#endif
-/* ffestc_order_where_ -- Check ordering on <where> statement
+/* ffestc_shriek_ifthen_ -- End an IF-THEN
- if (ffestc_order_where_() != FFESTC_orderOK_)
- return; */
+ ffestc_shriek_ifthen_(TRUE); */
-#if FFESTR_F90
-static ffestcOrder_
-ffestc_order_where_ ()
+static void
+ffestc_shriek_ifthen_ (bool ok)
{
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateWHERETHEN:
- return FFESTC_orderOK_;
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
- ffestc_shriek_where_ (FALSE);
- return FFESTC_orderBAD_;
+ ffestd_R806 (ok);
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
+ if (ffestw_name (ffestw_stack_top ()) != NULL)
+ ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
+ ffestw_kill (ffestw_pop ());
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
+ ffestc_try_shriek_do_ ();
}
-#endif
-/* Invoked for each token in dummy arg list of FUNCTION, SUBROUTINE, and
- ENTRY (prior to the first executable statement). */
+/* ffestc_shriek_select_ -- End a SELECT
+
+ ffestc_shriek_select_(TRUE); */
static void
-ffestc_promote_dummy_ (ffelexToken t)
+ffestc_shriek_select_ (bool ok)
{
- ffesymbol s;
- ffesymbolAttrs sa;
- ffesymbolAttrs na;
- ffebld e;
- bool sfref_ok;
-
- assert (t != NULL);
+ ffestwSelect s;
+ ffestwCase c;
- if (ffelex_token_type (t) == FFELEX_typeASTERISK)
- {
- ffebld_append_item (&ffestc_local_.dummy.list_bottom,
- ffebld_new_star ());
- return; /* Don't bother with alternate returns! */
- }
+ ffestd_R811 (ok);
- s = ffesymbol_declare_local (t, FALSE);
- sa = ffesymbol_attrs (s);
+ if (ffestw_name (ffestw_stack_top ()) != NULL)
+ ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
+ s = ffestw_select (ffestw_stack_top ());
+ ffelex_token_kill (s->t);
+ for (c = s->first_rel; c != (ffestwCase) &s->first_rel; c = c->next_rel)
+ ffelex_token_kill (c->t);
+ malloc_pool_kill (s->pool);
- /* Figure out what kind of object we've got based on previous declarations
- of or references to the object. */
+ ffestw_kill (ffestw_pop ());
- sfref_ok = FALSE;
+ ffestc_try_shriek_do_ ();
+}
- if (sa & FFESYMBOL_attrsANY)
- na = sa;
- else if (sa & FFESYMBOL_attrsDUMMY)
+/* ffestc_shriek_subroutine_ -- End a SUBROUTINE
+
+ ffestc_shriek_subroutine_(TRUE); */
+
+static void
+ffestc_shriek_subroutine_ (bool ok)
+{
+ if (!ffesta_seen_first_exec)
{
- if (ffestc_entry_num_ == ffesymbol_maxentrynum (s))
- { /* Seen this one twice in this list! */
- na = FFESYMBOL_attrsetNONE;
- }
- else
- na = sa;
- sfref_ok = TRUE; /* Ok for sym to be ref'd in sfuncdef
- previously, since already declared as a
- dummy arg. */
+ ffesta_seen_first_exec = TRUE;
+ ffestd_exec_begin ();
}
- else if (!(sa & ~(FFESYMBOL_attrsADJUSTABLE
- | FFESYMBOL_attrsADJUSTS
- | FFESYMBOL_attrsANY
- | FFESYMBOL_attrsANYLEN
- | FFESYMBOL_attrsANYSIZE
- | FFESYMBOL_attrsARRAY
- | FFESYMBOL_attrsDUMMY
- | FFESYMBOL_attrsEXTERNAL
- | FFESYMBOL_attrsSFARG
- | FFESYMBOL_attrsTYPE)))
- na = sa | FFESYMBOL_attrsDUMMY;
- else
- na = FFESYMBOL_attrsetNONE;
- if (!ffesymbol_is_specable (s)
- && (!sfref_ok
- || (ffesymbol_where (s) != FFEINFO_whereDUMMY)))
- na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
+ ffestd_R1225 (ok);
- /* Now see what we've got for a new object: NONE means a new error cropped
- up; ANY means an old error to be ignored; otherwise, everything's ok,
- update the object (symbol) and continue on. */
+ ffestd_exec_end ();
- if (na == FFESYMBOL_attrsetNONE)
- ffesymbol_error (s, t);
- else if (!(na & FFESYMBOL_attrsANY))
+ ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
+ ffestw_kill (ffestw_pop ());
+ ffesta_is_entry_valid = FALSE;
+
+ switch (ffestw_state (ffestw_stack_top ()))
{
- ffesymbol_set_attrs (s, na);
- if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
- ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
- ffesymbol_set_maxentrynum (s, ffestc_entry_num_);
- ffesymbol_set_numentries (s, ffesymbol_numentries (s) + 1);
- e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
- FFEINTRIN_impNONE);
- ffebld_set_info (e,
- ffeinfo_new (FFEINFO_basictypeNONE,
- FFEINFO_kindtypeNONE,
- 0,
- FFEINFO_kindNONE,
- FFEINFO_whereNONE,
- FFETARGET_charactersizeNONE));
- ffebld_append_item (&ffestc_local_.dummy.list_bottom, e);
- ffesymbol_signal_unreported (s);
+ case FFESTV_stateNIL:
+ ffe_terminate_2 ();
+ ffe_init_2 ();
+ break;
+
+ default:
+ ffe_terminate_3 ();
+ ffe_init_3 ();
+ break;
+
+ case FFESTV_stateINTERFACE0:
+ ffe_terminate_4 ();
+ ffe_init_4 ();
+ break;
}
}
-/* ffestc_promote_execdummy_ -- Declare token as dummy variable in exec context
+/* ffestc_subr_binsrch_ -- Binary search of char const in list of strings
- ffestc_promote_execdummy_(t);
+ i = ffestc_subr_binsrch_(search_list,search_list_size,&spec,"etc");
- Invoked for each token in dummy arg list of ENTRY when the statement
- follows the first executable statement. */
+ search_list contains search_list_size char *'s, spec is checked to see
+ if it is a char constant and, if so, is binary-searched against the list.
+ 0 is returned if not found, else the "classic" index (beginning with 1)
+ is returned. Before returning 0 where the search was performed but
+ fruitless, if "etc" is a non-NULL char *, an error message is displayed
+ using "etc" as the pick-one-of-these string. */
-static void
-ffestc_promote_execdummy_ (ffelexToken t)
+static int
+ffestc_subr_binsrch_ (const char *const *list, int size, ffestpFile *spec,
+ const char *whine)
{
- ffesymbol s;
- ffesymbolAttrs sa;
- ffesymbolAttrs na;
- ffesymbolState ss;
- ffesymbolState ns;
- ffeinfoKind kind;
- ffeinfoWhere where;
- ffebld e;
-
- assert (t != NULL);
-
- if (ffelex_token_type (t) == FFELEX_typeASTERISK)
- {
- ffebld_append_item (&ffestc_local_.dummy.list_bottom,
- ffebld_new_star ());
- return; /* Don't bother with alternate returns! */
- }
+ int lowest_tested;
+ int highest_tested;
+ int halfway;
+ int offset;
+ int c;
+ const char *str;
+ int len;
- s = ffesymbol_declare_local (t, FALSE);
- na = sa = ffesymbol_attrs (s);
- ss = ffesymbol_state (s);
- kind = ffesymbol_kind (s);
- where = ffesymbol_where (s);
+ if (size == 0)
+ return 0; /* Nobody should pass size == 0, but for
+ elegance.... */
- if (ffestc_entry_num_ == ffesymbol_maxentrynum (s))
- { /* Seen this one twice in this list! */
- na = FFESYMBOL_attrsetNONE;
- }
+ lowest_tested = -1;
+ highest_tested = size;
+ halfway = size >> 1;
- /* Figure out what kind of object we've got based on previous declarations
- of or references to the object. */
+ list += halfway;
- ns = FFESYMBOL_stateUNDERSTOOD; /* Assume we know it all know. */
+ c = ffestc_subr_speccmp_ (*list, spec, &str, &len);
+ if (c == 2)
+ return 0;
+ c = -c; /* Sigh. */
- switch (kind)
+next: /* :::::::::::::::::::: */
+ switch (c)
{
- case FFEINFO_kindENTITY:
- case FFEINFO_kindFUNCTION:
- case FFEINFO_kindSUBROUTINE:
- break; /* These are fine, as far as we know. */
+ case -1:
+ offset = (halfway - lowest_tested) >> 1;
+ if (offset == 0)
+ goto nope; /* :::::::::::::::::::: */
+ highest_tested = halfway;
+ list -= offset;
+ halfway -= offset;
+ c = ffesrc_strcmp_1ns2i (ffe_case_match (), str, len, *list);
+ goto next; /* :::::::::::::::::::: */
- case FFEINFO_kindNONE:
- if (sa & FFESYMBOL_attrsDUMMY)
- ns = FFESYMBOL_stateUNCERTAIN; /* Learned nothing new. */
- else if (sa & FFESYMBOL_attrsANYLEN)
- {
- kind = FFEINFO_kindENTITY;
- where = FFEINFO_whereDUMMY;
- }
- else if (sa & FFESYMBOL_attrsACTUALARG)
- na = FFESYMBOL_attrsetNONE;
- else
- {
- na = sa | FFESYMBOL_attrsDUMMY;
- ns = FFESYMBOL_stateUNCERTAIN;
- }
- break;
+ case 0:
+ return halfway + 1;
+
+ case 1:
+ offset = (highest_tested - halfway) >> 1;
+ if (offset == 0)
+ goto nope; /* :::::::::::::::::::: */
+ lowest_tested = halfway;
+ list += offset;
+ halfway += offset;
+ c = ffesrc_strcmp_1ns2i (ffe_case_match (), str, len, *list);
+ goto next; /* :::::::::::::::::::: */
default:
- na = FFESYMBOL_attrsetNONE; /* Error. */
+ assert ("unexpected return from ffesrc_strcmp_1ns2i" == NULL);
break;
}
- switch (where)
+nope: /* :::::::::::::::::::: */
+ ffebad_start (FFEBAD_SPEC_VALUE);
+ ffebad_here (0, ffelex_token_where_line (spec->value),
+ ffelex_token_where_column (spec->value));
+ ffebad_string (whine);
+ ffebad_finish ();
+ return 0;
+}
+
+/* ffestc_subr_format_ -- Return summary of format specifier
+
+ ffestc_subr_format_(&specifier); */
+
+static ffestvFormat
+ffestc_subr_format_ (ffestpFile *spec)
+{
+ if (!spec->kw_or_val_present)
+ return FFESTV_formatNONE;
+ assert (spec->value_present);
+ if (spec->value_is_label)
+ return FFESTV_formatLABEL; /* Ok if not a label. */
+
+ assert (spec->value != NULL);
+ if (ffebld_op (spec->u.expr) == FFEBLD_opSTAR)
+ return FFESTV_formatASTERISK;
+
+ if (ffeinfo_kind (ffebld_info (spec->u.expr)) == FFEINFO_kindNAMELIST)
+ return FFESTV_formatNAMELIST;
+
+ if (ffeinfo_rank (ffebld_info (spec->u.expr)) != 0)
+ return FFESTV_formatCHAREXPR; /* F77 C5. */
+
+ switch (ffeinfo_basictype (ffebld_info (spec->u.expr)))
{
- case FFEINFO_whereDUMMY:
- break; /* This is fine. */
+ case FFEINFO_basictypeINTEGER:
+ return FFESTV_formatINTEXPR;
- case FFEINFO_whereNONE:
- where = FFEINFO_whereDUMMY;
- break;
+ case FFEINFO_basictypeCHARACTER:
+ return FFESTV_formatCHAREXPR;
+
+ case FFEINFO_basictypeANY:
+ return FFESTV_formatASTERISK;
default:
- na = FFESYMBOL_attrsetNONE; /* Error. */
- break;
+ assert ("bad basictype" == NULL);
+ return FFESTV_formatINTEXPR;
}
+}
- /* Now see what we've got for a new object: NONE means a new error cropped
- up; ANY means an old error to be ignored; otherwise, everything's ok,
- update the object (symbol) and continue on. */
+/* ffestc_subr_is_branch_ -- Handle specifier as branch target label
- if (na == FFESYMBOL_attrsetNONE)
- ffesymbol_error (s, t);
- else if (!(na & FFESYMBOL_attrsANY))
- {
- ffesymbol_set_attrs (s, na);
- ffesymbol_set_state (s, ns);
- ffesymbol_set_maxentrynum (s, ffestc_entry_num_);
- ffesymbol_set_numentries (s, ffesymbol_numentries (s) + 1);
- if ((ns == FFESYMBOL_stateUNDERSTOOD)
- && (kind != FFEINFO_kindSUBROUTINE)
- && !ffeimplic_establish_symbol (s))
- {
- ffesymbol_error (s, t);
- return;
- }
- ffesymbol_set_info (s,
- ffeinfo_new (ffesymbol_basictype (s),
- ffesymbol_kindtype (s),
- ffesymbol_rank (s),
- kind,
- where,
- ffesymbol_size (s)));
- e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
- FFEINTRIN_impNONE);
- ffebld_set_info (e, ffeinfo_use (ffesymbol_info (s)));
- ffebld_append_item (&ffestc_local_.dummy.list_bottom, e);
- s = ffecom_sym_learned (s);
- ffesymbol_signal_unreported (s);
- }
+ ffestc_subr_is_branch_(&specifier); */
+
+static bool
+ffestc_subr_is_branch_ (ffestpFile *spec)
+{
+ if (!spec->kw_or_val_present)
+ return TRUE;
+ assert (spec->value_present);
+ assert (spec->value_is_label);
+ spec->value_is_label++; /* For checking purposes only; 1=>2. */
+ return ffestc_labelref_is_branch_ (spec->value, &spec->u.label);
}
-/* ffestc_promote_sfdummy_ -- Declare token as stmt-func dummy variable
+/* ffestc_subr_is_format_ -- Handle specifier as format target label
- ffestc_promote_sfdummy_(t);
+ ffestc_subr_is_format_(&specifier); */
- Invoked for each token in dummy arg list of statement function.
+static bool
+ffestc_subr_is_format_ (ffestpFile *spec)
+{
+ if (!spec->kw_or_val_present)
+ return TRUE;
+ assert (spec->value_present);
+ if (!spec->value_is_label)
+ return TRUE; /* Ok if not a label. */
- 22-Oct-91 JCB 1.1
- Reject arg if CHARACTER*(*). */
+ spec->value_is_label++; /* For checking purposes only; 1=>2. */
+ return ffestc_labelref_is_format_ (spec->value, &spec->u.label);
+}
-static void
-ffestc_promote_sfdummy_ (ffelexToken t)
-{
- ffesymbol s;
- ffesymbol sp; /* Parent symbol. */
- ffesymbolAttrs sa;
- ffesymbolAttrs na;
- ffebld e;
+/* ffestc_subr_is_present_ -- Ensure specifier is present, else error
- assert (t != NULL);
+ ffestc_subr_is_present_("SPECIFIER",&specifier); */
- s = ffesymbol_declare_sfdummy (t); /* Sets maxentrynum to 0 for new obj;
- also sets sfa_dummy_parent to
- parent symbol. */
- if (ffesymbol_state (s) != FFESYMBOL_stateNONE)
+static bool
+ffestc_subr_is_present_ (const char *name, ffestpFile *spec)
+{
+ if (spec->kw_or_val_present)
{
- ffesymbol_error (s, t); /* Dummy already in list. */
- return;
+ assert (spec->value_present);
+ return TRUE;
}
- sp = ffesymbol_sfdummyparent (s); /* Now flag dummy's parent as used
- for dummy. */
- sa = ffesymbol_attrs (sp);
+ ffebad_start (FFEBAD_MISSING_SPECIFIER);
+ ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
+ ffelex_token_where_column (ffesta_tokens[0]));
+ ffebad_string (name);
+ ffebad_finish ();
+ return FALSE;
+}
- /* Figure out what kind of object we've got based on previous declarations
- of or references to the object. */
+/* ffestc_subr_speccmp_ -- Compare string to constant expression, if present
- if (!ffesymbol_is_specable (sp)
- && ((ffesymbol_kind (sp) != FFEINFO_kindENTITY)
- || ((ffesymbol_where (sp) != FFEINFO_whereLOCAL)
- && (ffesymbol_where (sp) != FFEINFO_whereCOMMON)
- && (ffesymbol_where (sp) != FFEINFO_whereDUMMY)
- && (ffesymbol_where (sp) != FFEINFO_whereNONE))))
- na = FFESYMBOL_attrsetNONE; /* Can't be PARAMETER etc., must be a var. */
- else if (sa & FFESYMBOL_attrsANY)
- na = sa;
- else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
- | FFESYMBOL_attrsCOMMON
- | FFESYMBOL_attrsDUMMY
- | FFESYMBOL_attrsEQUIV
- | FFESYMBOL_attrsINIT
- | FFESYMBOL_attrsNAMELIST
- | FFESYMBOL_attrsRESULT
- | FFESYMBOL_attrsSAVE
- | FFESYMBOL_attrsSFARG
- | FFESYMBOL_attrsTYPE)))
- na = sa | FFESYMBOL_attrsSFARG;
- else
- na = FFESYMBOL_attrsetNONE;
+ if (ffestc_subr_speccmp_("Constant",&specifier,NULL,NULL) == 0)
+ // specifier value is present and is a char constant "CONSTANT"
- /* Now see what we've got for a new object: NONE means a new error cropped
- up; ANY means an old error to be ignored; otherwise, everything's ok,
- update the object (symbol) and continue on. */
+ Like strcmp, except the return values are defined as: -1 returned in place
+ of strcmp's generic negative value, 1 in place of it's generic positive
+ value, and 2 when there is no character constant string to compare. Also,
+ a case-insensitive comparison is performed, where string is assumed to
+ already be in InitialCaps form.
- if (na == FFESYMBOL_attrsetNONE)
+ If a non-NULL pointer is provided as the char **target, then *target is
+ written with NULL if 2 is returned, a pointer to the constant string
+ value of the specifier otherwise. Similarly, length is written with
+ 0 if 2 is returned, the length of the constant string value otherwise. */
+
+static int
+ffestc_subr_speccmp_ (const char *string, ffestpFile *spec, const char **target,
+ int *length)
+{
+ ffebldConstant c;
+ int i;
+
+ if (!spec->kw_or_val_present || !spec->value_present
+ || (spec->u.expr == NULL)
+ || (ffebld_op (spec->u.expr) != FFEBLD_opCONTER))
{
- ffesymbol_error (sp, t);
- ffesymbol_set_info (s, ffeinfo_new_any ());
+ if (target != NULL)
+ *target = NULL;
+ if (length != NULL)
+ *length = 0;
+ return 2;
}
- else if (!(na & FFESYMBOL_attrsANY))
- {
- ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
- ffesymbol_set_attrs (sp, na);
- if (!ffeimplic_establish_symbol (sp)
- || ((ffesymbol_basictype (sp) == FFEINFO_basictypeCHARACTER)
- && (ffesymbol_size (sp) == FFETARGET_charactersizeNONE)))
- ffesymbol_error (sp, t);
- else
- ffesymbol_set_info (s,
- ffeinfo_new (ffesymbol_basictype (sp),
- ffesymbol_kindtype (sp),
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereDUMMY,
- ffesymbol_size (sp)));
- ffesymbol_signal_unreported (sp);
+ if (ffebld_constant_type (c = ffebld_conter (spec->u.expr))
+ != FFEBLD_constCHARACTERDEFAULT)
+ {
+ if (target != NULL)
+ *target = NULL;
+ if (length != NULL)
+ *length = 0;
+ return 2;
}
- ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
- ffesymbol_set_maxentrynum (s, ffestc_sfdummy_argno_++);
- ffesymbol_signal_unreported (s);
- e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
- FFEINTRIN_impNONE);
- ffebld_set_info (e, ffeinfo_use (ffesymbol_info (s)));
- ffebld_append_item (&ffestc_local_.dummy.list_bottom, e);
-}
+ if (target != NULL)
+ *target = ffebld_constant_characterdefault (c).text;
+ if (length != NULL)
+ *length = ffebld_constant_characterdefault (c).length;
-/* ffestc_shriek_begin_program_ -- Implicit PROGRAM statement
+ i = ffesrc_strcmp_1ns2i (ffe_case_match (),
+ ffebld_constant_characterdefault (c).text,
+ ffebld_constant_characterdefault (c).length,
+ string);
+ if (i == 0)
+ return 0;
+ if (i > 0)
+ return -1; /* Yes indeed, we reverse the strings to
+ _strcmpin_. */
+ return 1;
+}
- ffestc_shriek_begin_program_();
+/* ffestc_subr_unit_ -- Return summary of unit specifier
- Invoked only when a PROGRAM statement is NOT present at the beginning
- of a main program unit. */
+ ffestc_subr_unit_(&specifier); */
-static void
-ffestc_shriek_begin_program_ ()
+static ffestvUnit
+ffestc_subr_unit_ (ffestpFile *spec)
{
- ffestw b;
- ffesymbol s;
-
- ffestc_blocknum_ = 0;
- b = ffestw_update (ffestw_push (NULL));
- ffestw_set_top_do (b, NULL);
- ffestw_set_state (b, FFESTV_statePROGRAM0);
- ffestw_set_blocknum (b, ffestc_blocknum_++);
- ffestw_set_shriek (b, ffestc_shriek_end_program_);
- ffestw_set_name (b, NULL);
+ if (!spec->kw_or_val_present)
+ return FFESTV_unitNONE;
+ assert (spec->value_present);
+ assert (spec->value != NULL);
- s = ffesymbol_declare_programunit (NULL,
- ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
+ if (ffebld_op (spec->u.expr) == FFEBLD_opSTAR)
+ return FFESTV_unitASTERISK;
- /* Special case: this is one symbol that won't go through
- ffestu_exec_transition_ when the first statement in a main program is
- executable, because the transition happens in ffest before ffestc is
- reached and triggers the implicit generation of a main program. So we
- do the exec transition for the implicit main program right here, just
- for cleanliness' sake (at the very least). */
+ switch (ffeinfo_basictype (ffebld_info (spec->u.expr)))
+ {
+ case FFEINFO_basictypeINTEGER:
+ return FFESTV_unitINTEXPR;
- ffesymbol_set_info (s,
- ffeinfo_new (FFEINFO_basictypeNONE,
- FFEINFO_kindtypeNONE,
- 0,
- FFEINFO_kindPROGRAM,
- FFEINFO_whereLOCAL,
- FFETARGET_charactersizeNONE));
- ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
+ case FFEINFO_basictypeCHARACTER:
+ return FFESTV_unitCHAREXPR;
- ffesymbol_signal_unreported (s);
+ case FFEINFO_basictypeANY:
+ return FFESTV_unitASTERISK;
- ffestd_R1102 (s, NULL);
+ default:
+ assert ("bad basictype" == NULL);
+ return FFESTV_unitINTEXPR;
+ }
}
-/* ffestc_shriek_begin_uses_ -- Start a bunch of USE statements
-
- ffestc_shriek_begin_uses_();
-
- Invoked before handling the first USE statement in a block of one or
- more USE statements. _end_uses_(bool ok) is invoked before handling
- the first statement after the block (there are no BEGIN USE and END USE
- statements, but the semantics of USE statements effectively requires
- handling them as a single block rather than one statement at a time). */
+/* Call this function whenever it's possible that one or more top
+ stack items are label-targeting DO blocks that have had their
+ labels defined, but at a time when they weren't at the top of the
+ stack. This prevents uninformative diagnostics for programs
+ like "DO 10", "IF (...) THEN", "10 ELSE", "END IF", "END". */
-#if FFESTR_F90
static void
-ffestc_shriek_begin_uses_ ()
+ffestc_try_shriek_do_ ()
{
- ffestw b;
-
- b = ffestw_update (ffestw_push (NULL));
- ffestw_set_top_do (b, NULL);
- ffestw_set_state (b, FFESTV_stateUSE);
- ffestw_set_blocknum (b, 0);
- ffestw_set_shriek (b, ffestc_shriek_end_uses_);
+ ffelab lab;
+ ffelabType ty;
- ffestd_begin_uses ();
+ while ((ffestw_state (ffestw_stack_top ()) == FFESTV_stateDO)
+ && ((lab = (ffestw_label (ffestw_stack_top ()))) != NULL)
+ && (((ty = (ffelab_type (lab)))
+ == FFELAB_typeANY)
+ || (ty == FFELAB_typeUSELESS)
+ || (ty == FFELAB_typeFORMAT)
+ || (ty == FFELAB_typeNOTLOOP)
+ || (ty == FFELAB_typeENDIF)))
+ ffestc_shriek_do_ (FALSE);
}
-#endif
-/* ffestc_shriek_blockdata_ -- End a BLOCK DATA
+/* ffestc_decl_start -- R426 or R501
- ffestc_shriek_blockdata_(TRUE); */
+ ffestc_decl_start(...);
-static void
-ffestc_shriek_blockdata_ (bool ok)
+ Verify that R426 component-def-stmt or R501 type-declaration-stmt are
+ valid here, figure out which one, and implement. */
+
+void
+ffestc_decl_start (ffestpType type, ffelexToken typet, ffebld kind,
+ ffelexToken kindt, ffebld len, ffelexToken lent)
{
- if (!ffesta_seen_first_exec)
+ switch (ffestw_state (ffestw_stack_top ()))
{
- ffesta_seen_first_exec = TRUE;
- ffestd_exec_begin ();
- }
+ case FFESTV_stateNIL:
+ case FFESTV_statePROGRAM0:
+ case FFESTV_stateSUBROUTINE0:
+ case FFESTV_stateFUNCTION0:
+ case FFESTV_stateMODULE0:
+ case FFESTV_stateBLOCKDATA0:
+ case FFESTV_statePROGRAM1:
+ case FFESTV_stateSUBROUTINE1:
+ case FFESTV_stateFUNCTION1:
+ case FFESTV_stateMODULE1:
+ case FFESTV_stateBLOCKDATA1:
+ case FFESTV_statePROGRAM2:
+ case FFESTV_stateSUBROUTINE2:
+ case FFESTV_stateFUNCTION2:
+ case FFESTV_stateMODULE2:
+ case FFESTV_stateBLOCKDATA2:
+ case FFESTV_statePROGRAM3:
+ case FFESTV_stateSUBROUTINE3:
+ case FFESTV_stateFUNCTION3:
+ case FFESTV_stateMODULE3:
+ case FFESTV_stateBLOCKDATA3:
+ case FFESTV_stateUSE:
+ ffestc_local_.decl.is_R426 = 2;
+ break;
- ffestd_R1112 (ok);
+ case FFESTV_stateTYPE:
+ case FFESTV_stateSTRUCTURE:
+ case FFESTV_stateMAP:
+ ffestc_local_.decl.is_R426 = 1;
+ break;
- ffestd_exec_end ();
+ default:
+ ffestc_order_bad_ ();
+ ffestc_labeldef_useless_ ();
+ ffestc_local_.decl.is_R426 = 0;
+ return;
+ }
- if (ffestw_name (ffestw_stack_top ()) != NULL)
- ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
- ffestw_kill (ffestw_pop ());
+ switch (ffestc_local_.decl.is_R426)
+ {
+ case 2:
+ ffestc_R501_start (type, typet, kind, kindt, len, lent);
+ break;
- ffe_terminate_2 ();
- ffe_init_2 ();
+ default:
+ ffestc_labeldef_useless_ ();
+ break;
+ }
}
-/* ffestc_shriek_do_ -- End of statement following DO-term-stmt etc
+/* ffestc_decl_attrib -- R426 or R501 type attribute
- ffestc_shriek_do_(TRUE);
+ ffestc_decl_attrib(...);
- Also invoked by _labeldef_branch_end_ (or, in cases
- of errors, other _labeldef_ functions) when the label definition is
- for a DO-target (LOOPEND) label, once per matching/outstanding DO
- block on the stack. These cases invoke this function with ok==TRUE, so
- only forced stack popping (via ffestc_eof()) invokes it with ok==FALSE. */
+ Verify that R426 component-def-stmt or R501 type-declaration-stmt attribute
+ is valid here and implement. */
-static void
-ffestc_shriek_do_ (bool ok)
+void
+ffestc_decl_attrib (ffestpAttrib attrib UNUSED,
+ ffelexToken attribt UNUSED,
+ ffestrOther intent_kw UNUSED,
+ ffesttDimList dims UNUSED)
{
- ffelab l;
-
- if (((l = ffestw_label (ffestw_stack_top ())) != NULL)
- && (ffewhere_line_is_unknown (ffelab_definition_line (l))))
- { /* DO target is label that is still
- undefined. */
- assert ((ffelab_type (l) == FFELAB_typeLOOPEND)
- || (ffelab_type (l) == FFELAB_typeANY));
- if (ffelab_type (l) != FFELAB_typeANY)
- {
- ffelab_set_definition_line (l,
- ffewhere_line_use (ffelab_doref_line (l)));
- ffelab_set_definition_column (l,
- ffewhere_column_use (ffelab_doref_column (l)));
- ffestv_num_label_defines_++;
- }
- ffestd_labeldef_branch (l);
- }
-
- ffestd_do (ok);
-
- if (ffestw_name (ffestw_stack_top ()) != NULL)
- ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
- if (ffestw_do_iter_var_t (ffestw_stack_top ()) != NULL)
- ffelex_token_kill (ffestw_do_iter_var_t (ffestw_stack_top ()));
- if (ffestw_do_iter_var (ffestw_stack_top ()) != NULL)
- ffesymbol_set_is_doiter (ffestw_do_iter_var (ffestw_stack_top ()), FALSE);
- ffestw_kill (ffestw_pop ());
+ ffebad_start (FFEBAD_F90);
+ ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
+ ffelex_token_where_column (ffesta_tokens[0]));
+ ffebad_finish ();
+ return;
}
-/* ffestc_shriek_end_program_ -- End a PROGRAM
+/* ffestc_decl_item -- R426 or R501
- ffestc_shriek_end_program_(); */
+ ffestc_decl_item(...);
-static void
-ffestc_shriek_end_program_ (bool ok)
+ Establish type for a particular object. */
+
+void
+ffestc_decl_item (ffelexToken name, ffebld kind, ffelexToken kindt,
+ ffesttDimList dims, ffebld len, ffelexToken lent, ffebld init,
+ ffelexToken initt, bool clist)
{
- if (!ffesta_seen_first_exec)
+ switch (ffestc_local_.decl.is_R426)
{
- ffesta_seen_first_exec = TRUE;
- ffestd_exec_begin ();
+ case 2:
+ ffestc_R501_item (name, kind, kindt, dims, len, lent, init, initt,
+ clist);
+ break;
+
+ default:
+ break;
}
+}
- ffestd_R1103 (ok);
+/* ffestc_decl_itemstartvals -- R426 or R501 start list of values
- ffestd_exec_end ();
+ ffestc_decl_itemstartvals();
- if (ffestw_name (ffestw_stack_top ()) != NULL)
- ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
- ffestw_kill (ffestw_pop ());
+ Gonna specify values for the object now. */
- ffe_terminate_2 ();
- ffe_init_2 ();
+void
+ffestc_decl_itemstartvals ()
+{
+ switch (ffestc_local_.decl.is_R426)
+ {
+ case 2:
+ ffestc_R501_itemstartvals ();
+ break;
+
+ default:
+ break;
+ }
}
-/* ffestc_shriek_end_uses_ -- End a bunch of USE statements
+/* ffestc_decl_itemvalue -- R426 or R501 source value
- ffestc_shriek_end_uses_(TRUE);
+ ffestc_decl_itemvalue(repeat,repeat_token,value,value_token);
- ok==TRUE means simply not popping due to ffestc_eof()
- being called, because there is no formal END USES statement in Fortran. */
+ Make sure repeat and value are valid for the object being initialized. */
-#if FFESTR_F90
-static void
-ffestc_shriek_end_uses_ (bool ok)
+void
+ffestc_decl_itemvalue (ffebld repeat, ffelexToken repeat_token,
+ ffebld value, ffelexToken value_token)
{
- ffestd_end_uses (ok);
+ switch (ffestc_local_.decl.is_R426)
+ {
+ case 2:
+ ffestc_R501_itemvalue (repeat, repeat_token, value, value_token);
+ break;
- ffestw_kill (ffestw_pop ());
+ default:
+ break;
+ }
}
-#endif
-/* ffestc_shriek_function_ -- End a FUNCTION
+/* ffestc_decl_itemendvals -- R426 or R501 end list of values
- ffestc_shriek_function_(TRUE); */
+ ffelexToken t; // the SLASH token that ends the list.
+ ffestc_decl_itemendvals(t);
-static void
-ffestc_shriek_function_ (bool ok)
+ No more values, might specify more objects now. */
+
+void
+ffestc_decl_itemendvals (ffelexToken t)
{
- if (!ffesta_seen_first_exec)
+ switch (ffestc_local_.decl.is_R426)
{
- ffesta_seen_first_exec = TRUE;
- ffestd_exec_begin ();
+ case 2:
+ ffestc_R501_itemendvals (t);
+ break;
+
+ default:
+ break;
}
+}
- ffestd_R1221 (ok);
+/* ffestc_decl_finish -- R426 or R501
- ffestd_exec_end ();
+ ffestc_decl_finish();
- ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
- ffestw_kill (ffestw_pop ());
- ffesta_is_entry_valid = FALSE;
+ Just wrap up any local activities. */
- switch (ffestw_state (ffestw_stack_top ()))
+void
+ffestc_decl_finish ()
+{
+ switch (ffestc_local_.decl.is_R426)
{
- case FFESTV_stateNIL:
- ffe_terminate_2 ();
- ffe_init_2 ();
+ case 2:
+ ffestc_R501_finish ();
break;
default:
- ffe_terminate_3 ();
- ffe_init_3 ();
- break;
-
- case FFESTV_stateINTERFACE0:
- ffe_terminate_4 ();
- ffe_init_4 ();
break;
}
}
-/* ffestc_shriek_if_ -- End of statement following logical IF
+/* ffestc_elsewhere -- Generic ELSE WHERE statement
- ffestc_shriek_if_(TRUE);
+ ffestc_end();
- Applies ONLY to logical IF, not to IF-THEN. For example, does not
- ffelex_token_kill the construct name for an IF-THEN block (the name
- field is invalid for logical IF). ok==TRUE iff statement following
- logical IF (substatement) is valid; else, statement is invalid or
- stack forcibly popped due to ffestc_eof(). */
+ Decide whether ELSEWHERE or ELSE w/if-construct-name=="WHERE" is meant. */
-static void
-ffestc_shriek_if_ (bool ok)
+void
+ffestc_elsewhere (ffelexToken where)
{
- ffestd_end_R807 (ok);
-
- ffestw_kill (ffestw_pop ());
- ffestc_shriek_after1_ = NULL;
+ switch (ffestw_state (ffestw_stack_top ()))
+ {
+ case FFESTV_stateIFTHEN:
+ ffestc_R805 (where);
+ break;
- ffestc_try_shriek_do_ ();
+ default:
+ break;
+ }
}
-/* ffestc_shriek_ifthen_ -- End an IF-THEN
+/* ffestc_end -- Generic END statement
- ffestc_shriek_ifthen_(TRUE); */
+ ffestc_end();
-static void
-ffestc_shriek_ifthen_ (bool ok)
+ Make sure a generic END is valid in the current context, and implement
+ it. */
+
+void
+ffestc_end ()
{
- ffestd_R806 (ok);
+ ffestw b;
- if (ffestw_name (ffestw_stack_top ()) != NULL)
- ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
- ffestw_kill (ffestw_pop ());
+ b = ffestw_stack_top ();
- ffestc_try_shriek_do_ ();
-}
+recurse:
+
+ switch (ffestw_state (b))
+ {
+ case FFESTV_stateBLOCKDATA0:
+ case FFESTV_stateBLOCKDATA1:
+ case FFESTV_stateBLOCKDATA2:
+ case FFESTV_stateBLOCKDATA3:
+ case FFESTV_stateBLOCKDATA4:
+ case FFESTV_stateBLOCKDATA5:
+ ffestc_R1112 (NULL);
+ break;
-/* ffestc_shriek_interface_ -- End an INTERFACE
+ case FFESTV_stateFUNCTION0:
+ case FFESTV_stateFUNCTION1:
+ case FFESTV_stateFUNCTION2:
+ case FFESTV_stateFUNCTION3:
+ case FFESTV_stateFUNCTION4:
+ case FFESTV_stateFUNCTION5:
+ if ((ffestw_state (ffestw_previous (b)) != FFESTV_stateNIL)
+ && (ffestw_state (ffestw_previous (b)) != FFESTV_stateINTERFACE0))
+ {
+ ffebad_start (FFEBAD_END_WO);
+ ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
+ ffelex_token_where_column (ffesta_tokens[0]));
+ ffebad_here (1, ffestw_line (ffestw_previous (b)), ffestw_col (ffestw_previous (b)));
+ ffebad_string ("FUNCTION");
+ ffebad_finish ();
+ }
+ ffestc_R1221 (NULL);
+ break;
- ffestc_shriek_interface_(TRUE); */
+ case FFESTV_stateMODULE0:
+ case FFESTV_stateMODULE1:
+ case FFESTV_stateMODULE2:
+ case FFESTV_stateMODULE3:
+ case FFESTV_stateMODULE4:
+ case FFESTV_stateMODULE5:
+ break;
-#if FFESTR_F90
-static void
-ffestc_shriek_interface_ (bool ok)
-{
- ffestd_R1203 (ok);
+ case FFESTV_stateSUBROUTINE0:
+ case FFESTV_stateSUBROUTINE1:
+ case FFESTV_stateSUBROUTINE2:
+ case FFESTV_stateSUBROUTINE3:
+ case FFESTV_stateSUBROUTINE4:
+ case FFESTV_stateSUBROUTINE5:
+ if ((ffestw_state (ffestw_previous (b)) != FFESTV_stateNIL)
+ && (ffestw_state (ffestw_previous (b)) != FFESTV_stateINTERFACE0))
+ {
+ ffebad_start (FFEBAD_END_WO);
+ ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
+ ffelex_token_where_column (ffesta_tokens[0]));
+ ffebad_here (1, ffestw_line (ffestw_previous (b)), ffestw_col (ffestw_previous (b)));
+ ffebad_string ("SUBROUTINE");
+ ffebad_finish ();
+ }
+ ffestc_R1225 (NULL);
+ break;
- ffestw_kill (ffestw_pop ());
+ case FFESTV_stateUSE:
+ b = ffestw_previous (ffestw_stack_top ());
+ goto recurse; /* :::::::::::::::::::: */
- ffestc_try_shriek_do_ ();
+ default:
+ ffestc_R1103 (NULL);
+ break;
+ }
}
-#endif
-/* ffestc_shriek_map_ -- End a MAP
+/* ffestc_eof -- Generic EOF
+
+ ffestc_eof();
- ffestc_shriek_map_(TRUE); */
+ Make sure we're at state NIL, or issue an error message and use each
+ block's shriek function to clean up to state NIL. */
-#if FFESTR_VXT
-static void
-ffestc_shriek_map_ (bool ok)
+void
+ffestc_eof ()
{
- ffestd_V013 (ok);
+ if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateNIL)
+ {
+ ffebad_start (FFEBAD_EOF_BEFORE_BLOCK_END);
+ ffebad_here (0, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
+ ffebad_finish ();
+ do
+ (*ffestw_shriek (ffestw_stack_top ()))(FALSE);
+ while (ffestw_state (ffestw_stack_top ()) != FFESTV_stateNIL);
+ }
+}
- ffestw_kill (ffestw_pop ());
+/* ffestc_exec_transition -- Check if ok and move stmt state to executable
- ffestc_try_shriek_do_ ();
-}
+ if (ffestc_exec_transition())
+ // Transition successful (kind of like a CONTINUE stmt was seen).
-#endif
-/* ffestc_shriek_module_ -- End a MODULE
+ If the current statement state is a non-nested specification state in
+ which, say, a CONTINUE statement would be valid, then enter the state
+ we'd be in after seeing CONTINUE (without, of course, generating any
+ CONTINUE code), call ffestd_exec_begin, and return TRUE. Otherwise
+ return FALSE.
- ffestc_shriek_module_(TRUE); */
+ This function cannot be invoked once the first executable statement
+ is seen. This function may choose to always return TRUE by shrieking
+ away any interceding state stack entries to reach the base level of
+ specification state, but right now it doesn't, and it is (or should
+ be) purely an issue of how one wishes errors to be handled (for example,
+ an unrecognized statement in the middle of a STRUCTURE construct: after
+ the error message, should subsequent statements still be interpreted as
+ being within the construct, or should the construct be terminated upon
+ seeing the unrecognized statement? we do the former at the moment). */
-#if FFESTR_F90
-static void
-ffestc_shriek_module_ (bool ok)
+bool
+ffestc_exec_transition ()
{
- if (!ffesta_seen_first_exec)
- {
- ffesta_seen_first_exec = TRUE;
- ffestd_exec_begin ();
- }
+ bool update;
- ffestd_R1106 (ok);
+recurse:
- ffestd_exec_end ();
+ switch (ffestw_state (ffestw_stack_top ()))
+ {
+ case FFESTV_stateNIL:
+ ffestc_shriek_begin_program_ ();
+ goto recurse; /* :::::::::::::::::::: */
- ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
- ffestw_kill (ffestw_pop ());
+ case FFESTV_statePROGRAM0:
+ case FFESTV_stateSUBROUTINE0:
+ case FFESTV_stateFUNCTION0:
+ case FFESTV_stateBLOCKDATA0:
+ ffestw_state (ffestw_stack_top ()) += 4; /* To state UNIT4. */
+ update = TRUE;
+ break;
- ffe_terminate_2 ();
- ffe_init_2 ();
-}
+ case FFESTV_statePROGRAM1:
+ case FFESTV_stateSUBROUTINE1:
+ case FFESTV_stateFUNCTION1:
+ case FFESTV_stateBLOCKDATA1:
+ ffestw_state (ffestw_stack_top ()) += 3; /* To state UNIT4. */
+ update = TRUE;
+ break;
-#endif
-/* ffestc_shriek_select_ -- End a SELECT
+ case FFESTV_statePROGRAM2:
+ case FFESTV_stateSUBROUTINE2:
+ case FFESTV_stateFUNCTION2:
+ case FFESTV_stateBLOCKDATA2:
+ ffestw_state (ffestw_stack_top ()) += 2; /* To state UNIT4. */
+ update = TRUE;
+ break;
- ffestc_shriek_select_(TRUE); */
+ case FFESTV_statePROGRAM3:
+ case FFESTV_stateSUBROUTINE3:
+ case FFESTV_stateFUNCTION3:
+ case FFESTV_stateBLOCKDATA3:
+ ffestw_state (ffestw_stack_top ()) += 1; /* To state UNIT4. */
+ update = TRUE;
+ break;
-static void
-ffestc_shriek_select_ (bool ok)
-{
- ffestwSelect s;
- ffestwCase c;
+ case FFESTV_stateUSE:
+ goto recurse; /* :::::::::::::::::::: */
- ffestd_R811 (ok);
+ default:
+ return FALSE;
+ }
- if (ffestw_name (ffestw_stack_top ()) != NULL)
- ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
- s = ffestw_select (ffestw_stack_top ());
- ffelex_token_kill (s->t);
- for (c = s->first_rel; c != (ffestwCase) &s->first_rel; c = c->next_rel)
- ffelex_token_kill (c->t);
- malloc_pool_kill (s->pool);
+ if (update)
+ ffestw_update (NULL); /* Update state line/col info. */
- ffestw_kill (ffestw_pop ());
+ ffesta_seen_first_exec = TRUE;
+ ffestd_exec_begin ();
- ffestc_try_shriek_do_ ();
+ return TRUE;
}
-/* ffestc_shriek_structure_ -- End a STRUCTURE
+/* ffestc_ffebad_here_doiter -- Calls ffebad_here with ptr to DO iter var
- ffestc_shriek_structure_(TRUE); */
+ ffesymbol s;
+ // call ffebad_start first, of course.
+ ffestc_ffebad_here_doiter(0,s);
+ // call ffebad_finish afterwards, naturally.
-#if FFESTR_VXT
-static void
-ffestc_shriek_structure_ (bool ok)
-{
- ffestd_V004 (ok);
+ Searches the stack of blocks backwards for a DO loop that has s
+ as its iteration variable, then calls ffebad_here with pointers to
+ that particular reference to the variable. Crashes if the DO loop
+ can't be found. */
- ffestw_kill (ffestw_pop ());
+void
+ffestc_ffebad_here_doiter (ffebadIndex i, ffesymbol s)
+{
+ ffestw block;
- ffestc_try_shriek_do_ ();
+ for (block = ffestw_top_do (ffestw_stack_top ());
+ (block != NULL) && (ffestw_blocknum (block) != 0);
+ block = ffestw_top_do (ffestw_previous (block)))
+ {
+ if (ffestw_do_iter_var (block) == s)
+ {
+ ffebad_here (i, ffelex_token_where_line (ffestw_do_iter_var_t (block)),
+ ffelex_token_where_column (ffestw_do_iter_var_t (block)));
+ return;
+ }
+ }
+ assert ("no do block found" == NULL);
}
-#endif
-/* ffestc_shriek_subroutine_ -- End a SUBROUTINE
+/* ffestc_is_decl_not_R1219 -- Context information for FFESTB
- ffestc_shriek_subroutine_(TRUE); */
+ if (ffestc_is_decl_not_R1219()) ...
-static void
-ffestc_shriek_subroutine_ (bool ok)
-{
- if (!ffesta_seen_first_exec)
- {
- ffesta_seen_first_exec = TRUE;
- ffestd_exec_begin ();
- }
-
- ffestd_R1225 (ok);
-
- ffestd_exec_end ();
-
- ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
- ffestw_kill (ffestw_pop ());
- ffesta_is_entry_valid = FALSE;
+ When a statement with the form "type[RECURSIVE]FUNCTIONname(name-list)"
+ is seen, call this function. It returns TRUE if the statement's context
+ is such that it is a declaration of an object named
+ "[RECURSIVE]FUNCTIONname" with an array-decl spec of "name-list", FALSE
+ if the statement's context is such that it begins the definition of a
+ function named "name" havin the dummy argument list "name-list" (this
+ is the R1219 function-stmt case). */
+bool
+ffestc_is_decl_not_R1219 ()
+{
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateNIL:
- ffe_terminate_2 ();
- ffe_init_2 ();
- break;
+ case FFESTV_statePROGRAM5:
+ case FFESTV_stateSUBROUTINE5:
+ case FFESTV_stateFUNCTION5:
+ case FFESTV_stateMODULE5:
+ case FFESTV_stateINTERFACE0:
+ return FALSE;
default:
- ffe_terminate_3 ();
- ffe_init_3 ();
- break;
-
- case FFESTV_stateINTERFACE0:
- ffe_terminate_4 ();
- ffe_init_4 ();
- break;
+ return TRUE;
}
}
-/* ffestc_shriek_type_ -- End a TYPE
+/* ffestc_is_entry_in_subr -- Context information for FFESTB
- ffestc_shriek_type_(TRUE); */
+ if (ffestc_is_entry_in_subr()) ...
-#if FFESTR_F90
-static void
-ffestc_shriek_type_ (bool ok)
+ When a statement with the form "ENTRY name(name-list)"
+ is seen, call this function. It returns TRUE if the statement's context
+ is such that it may have "*", meaning alternate return, in place of
+ names in the name list (i.e. if the ENTRY is in a subroutine context).
+ It also returns TRUE if the ENTRY is not in a function context (invalid
+ but prevents extra complaints about "*", if present). It returns FALSE
+ if the ENTRY is in a function context. */
+
+bool
+ffestc_is_entry_in_subr ()
{
- ffestd_R425 (ok);
+ ffestvState s;
- ffe_terminate_4 ();
+ s = ffestw_state (ffestw_stack_top ());
- ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
- ffestw_kill (ffestw_pop ());
+recurse:
- ffestc_try_shriek_do_ ();
+ switch (s)
+ {
+ case FFESTV_stateFUNCTION0:
+ case FFESTV_stateFUNCTION1:
+ case FFESTV_stateFUNCTION2:
+ case FFESTV_stateFUNCTION3:
+ case FFESTV_stateFUNCTION4:
+ return FALSE;
+
+ case FFESTV_stateUSE:
+ s = ffestw_state (ffestw_previous (ffestw_stack_top ()));
+ goto recurse; /* :::::::::::::::::::: */
+
+ default:
+ return TRUE;
+ }
}
-#endif
-/* ffestc_shriek_union_ -- End a UNION
+/* ffestc_is_let_not_V027 -- Context information for FFESTB
- ffestc_shriek_union_(TRUE); */
+ if (ffestc_is_let_not_V027()) ...
-#if FFESTR_VXT
-static void
-ffestc_shriek_union_ (bool ok)
-{
- ffestd_V010 (ok);
+ When a statement with the form "PARAMETERname=expr"
+ is seen, call this function. It returns TRUE if the statement's context
+ is such that it is an assignment to an object named "PARAMETERname", FALSE
+ if the statement's context is such that it is a V-extension PARAMETER
+ statement that is like a PARAMETER(name=expr) statement except that the
+ type of name is determined by the type of expr, not the implicit or
+ explicit typing of name. */
- ffestw_kill (ffestw_pop ());
+bool
+ffestc_is_let_not_V027 ()
+{
+ switch (ffestw_state (ffestw_stack_top ()))
+ {
+ case FFESTV_statePROGRAM4:
+ case FFESTV_stateSUBROUTINE4:
+ case FFESTV_stateFUNCTION4:
+ case FFESTV_stateWHERETHEN:
+ case FFESTV_stateIFTHEN:
+ case FFESTV_stateDO:
+ case FFESTV_stateSELECT0:
+ case FFESTV_stateSELECT1:
+ case FFESTV_stateWHERE:
+ case FFESTV_stateIF:
+ return TRUE;
- ffestc_try_shriek_do_ ();
+ default:
+ return FALSE;
+ }
}
-#endif
-/* ffestc_shriek_where_ -- Implicit END WHERE statement
+/* ffestc_terminate_4 -- Terminate ffestc after scoping unit
- ffestc_shriek_where_(TRUE);
+ ffestc_terminate_4();
- Implement the end of the current WHERE "block". ok==TRUE iff statement
- following WHERE (substatement) is valid; else, statement is invalid
- or stack forcibly popped due to ffestc_eof(). */
+ For SUBROUTINEs/FUNCTIONs within INTERFACE/END INTERFACE, derived-TYPE-
+ defs, and statement function defs. */
-#if FFESTR_F90
-static void
-ffestc_shriek_where_ (bool ok)
+void
+ffestc_terminate_4 ()
{
- ffestd_R745 (ok);
-
- ffestw_kill (ffestw_pop ());
- ffestc_shriek_after1_ = NULL;
- if (ffestw_state (ffestw_stack_top ()) == FFESTV_stateIF)
- ffestc_shriek_if_ (TRUE); /* "IF (x) WHERE (y) stmt" is only valid
- case. */
-
- ffestc_try_shriek_do_ ();
+ ffestc_entry_num_ = ffestc_saved_entry_num_;
}
-#endif
-/* ffestc_shriek_wherethen_ -- End a WHERE(-THEN)
+/* ffestc_R501_start -- type-declaration-stmt
- ffestc_shriek_wherethen_(TRUE); */
+ ffestc_R501_start(...);
-#if FFESTR_F90
-static void
-ffestc_shriek_wherethen_ (bool ok)
-{
- ffestd_end_R740 (ok);
+ Verify that R501 type-declaration-stmt is
+ valid here and implement. */
- ffestw_kill (ffestw_pop ());
+void
+ffestc_R501_start (ffestpType type, ffelexToken typet, ffebld kind,
+ ffelexToken kindt, ffebld len, ffelexToken lent)
+{
+ ffestc_check_start_ ();
+ if (ffestc_order_typedecl_ () != FFESTC_orderOK_)
+ {
+ ffestc_local_.decl.is_R426 = 0;
+ return;
+ }
+ ffestc_labeldef_useless_ ();
- ffestc_try_shriek_do_ ();
+ ffestc_establish_declstmt_ (type, typet, kind, kindt, len, lent);
}
-#endif
-/* ffestc_subr_binsrch_ -- Binary search of char const in list of strings
+/* ffestc_R501_attrib -- type attribute
- i = ffestc_subr_binsrch_(search_list,search_list_size,&spec,"etc");
+ ffestc_R501_attrib(...);
- search_list contains search_list_size char *'s, spec is checked to see
- if it is a char constant and, if so, is binary-searched against the list.
- 0 is returned if not found, else the "classic" index (beginning with 1)
- is returned. Before returning 0 where the search was performed but
- fruitless, if "etc" is a non-NULL char *, an error message is displayed
- using "etc" as the pick-one-of-these string. */
+ Verify that R501 type-declaration-stmt attribute
+ is valid here and implement. */
-static int
-ffestc_subr_binsrch_ (const char *const *list, int size, ffestpFile *spec,
- const char *whine)
+void
+ffestc_R501_attrib (ffestpAttrib attrib, ffelexToken attribt,
+ ffestrOther intent_kw UNUSED,
+ ffesttDimList dims UNUSED)
{
- int lowest_tested;
- int highest_tested;
- int halfway;
- int offset;
- int c;
- const char *str;
- int len;
+ ffestc_check_attrib_ ();
- if (size == 0)
- return 0; /* Nobody should pass size == 0, but for
- elegance.... */
+ switch (attrib)
+ {
+ case FFESTP_attribDIMENSION:
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
+ break;
- lowest_tested = -1;
- highest_tested = size;
- halfway = size >> 1;
+ case FFESTP_attribEXTERNAL:
+ break;
- list += halfway;
+ case FFESTP_attribINTRINSIC:
+ break;
- c = ffestc_subr_speccmp_ (*list, spec, &str, &len);
- if (c == 2)
- return 0;
- c = -c; /* Sigh. */
+ case FFESTP_attribPARAMETER:
+ break;
-next: /* :::::::::::::::::::: */
- switch (c)
- {
- case -1:
- offset = (halfway - lowest_tested) >> 1;
- if (offset == 0)
- goto nope; /* :::::::::::::::::::: */
- highest_tested = halfway;
- list -= offset;
- halfway -= offset;
- c = ffesrc_strcmp_1ns2i (ffe_case_match (), str, len, *list);
- goto next; /* :::::::::::::::::::: */
+ case FFESTP_attribSAVE:
+ switch (ffestv_save_state_)
+ {
+ case FFESTV_savestateNONE:
+ ffestv_save_state_ = FFESTV_savestateSPECIFIC;
+ ffestv_save_line_
+ = ffewhere_line_use (ffelex_token_where_line (attribt));
+ ffestv_save_col_
+ = ffewhere_column_use (ffelex_token_where_column (attribt));
+ break;
- case 0:
- return halfway + 1;
+ case FFESTV_savestateSPECIFIC:
+ case FFESTV_savestateANY:
+ break;
- case 1:
- offset = (highest_tested - halfway) >> 1;
- if (offset == 0)
- goto nope; /* :::::::::::::::::::: */
- lowest_tested = halfway;
- list += offset;
- halfway += offset;
- c = ffesrc_strcmp_1ns2i (ffe_case_match (), str, len, *list);
- goto next; /* :::::::::::::::::::: */
+ case FFESTV_savestateALL:
+ if (ffe_is_pedantic ())
+ {
+ ffebad_start (FFEBAD_CONFLICTING_SAVES);
+ ffebad_here (0, ffestv_save_line_, ffestv_save_col_);
+ ffebad_here (1, ffelex_token_where_line (attribt),
+ ffelex_token_where_column (attribt));
+ ffebad_finish ();
+ }
+ ffestv_save_state_ = FFESTV_savestateANY;
+ break;
+
+ default:
+ assert ("unexpected save state" == NULL);
+ break;
+ }
+ break;
default:
- assert ("unexpected return from ffesrc_strcmp_1ns2i" == NULL);
+ assert ("unexpected attribute" == NULL);
break;
}
+}
-nope: /* :::::::::::::::::::: */
- ffebad_start (FFEBAD_SPEC_VALUE);
- ffebad_here (0, ffelex_token_where_line (spec->value),
- ffelex_token_where_column (spec->value));
- ffebad_string (whine);
- ffebad_finish ();
- return 0;
-}
+/* ffestc_R501_item -- declared object
-/* ffestc_subr_format_ -- Return summary of format specifier
+ ffestc_R501_item(...);
- ffestc_subr_format_(&specifier); */
+ Establish type for a particular object. */
-static ffestvFormat
-ffestc_subr_format_ (ffestpFile *spec)
+void
+ffestc_R501_item (ffelexToken name, ffebld kind, ffelexToken kindt,
+ ffesttDimList dims, ffebld len, ffelexToken lent,
+ ffebld init, ffelexToken initt, bool clist)
{
- if (!spec->kw_or_val_present)
- return FFESTV_formatNONE;
- assert (spec->value_present);
- if (spec->value_is_label)
- return FFESTV_formatLABEL; /* Ok if not a label. */
+ ffesymbol s;
+ ffesymbol sfn; /* FUNCTION symbol. */
+ ffebld array_size;
+ ffebld extents;
+ ffesymbolAttrs sa;
+ ffesymbolAttrs na;
+ ffestpDimtype nd;
+ bool is_init = (init != NULL) || clist;
+ bool is_assumed;
+ bool is_ugly_assumed;
+ ffeinfoRank rank;
- assert (spec->value != NULL);
- if (ffebld_op (spec->u.expr) == FFEBLD_opSTAR)
- return FFESTV_formatASTERISK;
+ ffestc_check_item_ ();
+ assert (name != NULL);
+ assert (ffelex_token_type (name) == FFELEX_typeNAME); /* Not NAMES. */
+ assert (kind == NULL); /* No way an expression should get here. */
- if (ffeinfo_kind (ffebld_info (spec->u.expr)) == FFEINFO_kindNAMELIST)
- return FFESTV_formatNAMELIST;
+ ffestc_establish_declinfo_ (kind, kindt, len, lent);
- if (ffeinfo_rank (ffebld_info (spec->u.expr)) != 0)
- return FFESTV_formatCHAREXPR; /* F77 C5. */
+ is_assumed = (ffestc_local_.decl.basic_type == FFEINFO_basictypeCHARACTER)
+ && (ffestc_local_.decl.size == FFETARGET_charactersizeNONE);
- switch (ffeinfo_basictype (ffebld_info (spec->u.expr)))
- {
- case FFEINFO_basictypeINTEGER:
- return FFESTV_formatINTEXPR;
+ if ((dims != NULL) || is_init)
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- case FFEINFO_basictypeCHARACTER:
- return FFESTV_formatCHAREXPR;
+ s = ffesymbol_declare_local (name, TRUE);
+ sa = ffesymbol_attrs (s);
- case FFEINFO_basictypeANY:
- return FFESTV_formatASTERISK;
+ /* First figure out what kind of object this is based solely on the current
+ object situation (type params, dimension list, and initialization). */
- default:
- assert ("bad basictype" == NULL);
- return FFESTV_formatINTEXPR;
- }
-}
+ na = FFESYMBOL_attrsTYPE;
-/* ffestc_subr_is_branch_ -- Handle specifier as branch target label
+ if (is_assumed)
+ na |= FFESYMBOL_attrsANYLEN;
- ffestc_subr_is_branch_(&specifier); */
+ is_ugly_assumed = (ffe_is_ugly_assumed ()
+ && ((sa & FFESYMBOL_attrsDUMMY)
+ || (ffesymbol_where (s) == FFEINFO_whereDUMMY)));
-static bool
-ffestc_subr_is_branch_ (ffestpFile *spec)
-{
- if (!spec->kw_or_val_present)
- return TRUE;
- assert (spec->value_present);
- assert (spec->value_is_label);
- spec->value_is_label++; /* For checking purposes only; 1=>2. */
- return ffestc_labelref_is_branch_ (spec->value, &spec->u.label);
-}
+ nd = ffestt_dimlist_type (dims, is_ugly_assumed);
+ switch (nd)
+ {
+ case FFESTP_dimtypeNONE:
+ break;
-/* ffestc_subr_is_format_ -- Handle specifier as format target label
+ case FFESTP_dimtypeKNOWN:
+ na |= FFESYMBOL_attrsARRAY;
+ break;
- ffestc_subr_is_format_(&specifier); */
+ case FFESTP_dimtypeADJUSTABLE:
+ na |= FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE;
+ break;
-static bool
-ffestc_subr_is_format_ (ffestpFile *spec)
-{
- if (!spec->kw_or_val_present)
- return TRUE;
- assert (spec->value_present);
- if (!spec->value_is_label)
- return TRUE; /* Ok if not a label. */
+ case FFESTP_dimtypeASSUMED:
+ na |= FFESYMBOL_attrsARRAY | FFESYMBOL_attrsANYSIZE;
+ break;
- spec->value_is_label++; /* For checking purposes only; 1=>2. */
- return ffestc_labelref_is_format_ (spec->value, &spec->u.label);
-}
+ case FFESTP_dimtypeADJUSTABLEASSUMED:
+ na |= FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE
+ | FFESYMBOL_attrsANYSIZE;
+ break;
-/* ffestc_subr_is_present_ -- Ensure specifier is present, else error
+ default:
+ assert ("unexpected dimtype" == NULL);
+ na = FFESYMBOL_attrsetNONE;
+ break;
+ }
- ffestc_subr_is_present_("SPECIFIER",&specifier); */
+ if (!ffesta_is_entry_valid
+ && (((na & (FFESYMBOL_attrsANYLEN | FFESYMBOL_attrsARRAY))
+ == (FFESYMBOL_attrsANYLEN | FFESYMBOL_attrsARRAY))))
+ na = FFESYMBOL_attrsetNONE;
-static bool
-ffestc_subr_is_present_ (const char *name, ffestpFile *spec)
-{
- if (spec->kw_or_val_present)
+ if (is_init)
{
- assert (spec->value_present);
- return TRUE;
+ if (na == FFESYMBOL_attrsetNONE)
+ ;
+ else if (na & (FFESYMBOL_attrsANYLEN
+ | FFESYMBOL_attrsADJUSTABLE
+ | FFESYMBOL_attrsANYSIZE))
+ na = FFESYMBOL_attrsetNONE;
+ else
+ na |= FFESYMBOL_attrsINIT;
}
- ffebad_start (FFEBAD_MISSING_SPECIFIER);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_string (name);
- ffebad_finish ();
- return FALSE;
-}
-
-/* ffestc_subr_speccmp_ -- Compare string to constant expression, if present
-
- if (ffestc_subr_speccmp_("Constant",&specifier,NULL,NULL) == 0)
- // specifier value is present and is a char constant "CONSTANT"
-
- Like strcmp, except the return values are defined as: -1 returned in place
- of strcmp's generic negative value, 1 in place of it's generic positive
- value, and 2 when there is no character constant string to compare. Also,
- a case-insensitive comparison is performed, where string is assumed to
- already be in InitialCaps form.
+ /* Now figure out what kind of object we've got based on previous
+ declarations of or references to the object. */
- If a non-NULL pointer is provided as the char **target, then *target is
- written with NULL if 2 is returned, a pointer to the constant string
- value of the specifier otherwise. Similarly, length is written with
- 0 if 2 is returned, the length of the constant string value otherwise. */
+ if (na == FFESYMBOL_attrsetNONE)
+ ;
+ else if (!ffesymbol_is_specable (s)
+ && (((ffesymbol_where (s) != FFEINFO_whereCONSTANT)
+ && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))
+ || (na & (FFESYMBOL_attrsARRAY | FFESYMBOL_attrsINIT))))
+ na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef, and can't
+ dimension/init UNDERSTOODs. */
+ else if (sa & FFESYMBOL_attrsANY)
+ na = sa;
+ else if ((sa & na)
+ || ((sa & (FFESYMBOL_attrsSFARG
+ | FFESYMBOL_attrsADJUSTS))
+ && (na & (FFESYMBOL_attrsARRAY
+ | FFESYMBOL_attrsANYLEN)))
+ || ((sa & FFESYMBOL_attrsRESULT)
+ && (na & (FFESYMBOL_attrsARRAY
+ | FFESYMBOL_attrsINIT)))
+ || ((sa & (FFESYMBOL_attrsSFUNC
+ | FFESYMBOL_attrsEXTERNAL
+ | FFESYMBOL_attrsINTRINSIC
+ | FFESYMBOL_attrsINIT))
+ && (na & (FFESYMBOL_attrsARRAY
+ | FFESYMBOL_attrsANYLEN
+ | FFESYMBOL_attrsINIT)))
+ || ((sa & FFESYMBOL_attrsARRAY)
+ && !ffesta_is_entry_valid
+ && (na & FFESYMBOL_attrsANYLEN))
+ || ((sa & (FFESYMBOL_attrsADJUSTABLE
+ | FFESYMBOL_attrsANYLEN
+ | FFESYMBOL_attrsANYSIZE
+ | FFESYMBOL_attrsDUMMY))
+ && (na & FFESYMBOL_attrsINIT))
+ || ((sa & (FFESYMBOL_attrsSAVE
+ | FFESYMBOL_attrsNAMELIST
+ | FFESYMBOL_attrsCOMMON
+ | FFESYMBOL_attrsEQUIV))
+ && (na & (FFESYMBOL_attrsADJUSTABLE
+ | FFESYMBOL_attrsANYLEN
+ | FFESYMBOL_attrsANYSIZE))))
+ na = FFESYMBOL_attrsetNONE;
+ else if ((ffesymbol_kind (s) == FFEINFO_kindENTITY)
+ && (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
+ && (na & FFESYMBOL_attrsANYLEN))
+ { /* If CHARACTER*(*) FOO after PARAMETER FOO. */
+ na |= FFESYMBOL_attrsTYPE;
+ ffestc_local_.decl.size = ffebld_size (ffesymbol_init (s));
+ }
+ else
+ na |= sa;
-static int
-ffestc_subr_speccmp_ (const char *string, ffestpFile *spec, const char **target,
- int *length)
-{
- ffebldConstant c;
- int i;
+ /* Now see what we've got for a new object: NONE means a new error cropped
+ up; ANY means an old error to be ignored; otherwise, everything's ok,
+ update the object (symbol) and continue on. */
- if (!spec->kw_or_val_present || !spec->value_present
- || (spec->u.expr == NULL)
- || (ffebld_op (spec->u.expr) != FFEBLD_opCONTER))
+ if (na == FFESYMBOL_attrsetNONE)
{
- if (target != NULL)
- *target = NULL;
- if (length != NULL)
- *length = 0;
- return 2;
+ ffesymbol_error (s, name);
+ ffestc_parent_ok_ = FALSE;
}
-
- if (ffebld_constant_type (c = ffebld_conter (spec->u.expr))
- != FFEBLD_constCHARACTERDEFAULT)
+ else if (na & FFESYMBOL_attrsANY)
+ ffestc_parent_ok_ = FALSE;
+ else
{
- if (target != NULL)
- *target = NULL;
- if (length != NULL)
- *length = 0;
- return 2;
- }
-
- if (target != NULL)
- *target = ffebld_constant_characterdefault (c).text;
- if (length != NULL)
- *length = ffebld_constant_characterdefault (c).length;
-
- i = ffesrc_strcmp_1ns2i (ffe_case_match (),
- ffebld_constant_characterdefault (c).text,
- ffebld_constant_characterdefault (c).length,
- string);
- if (i == 0)
- return 0;
- if (i > 0)
- return -1; /* Yes indeed, we reverse the strings to
- _strcmpin_. */
- return 1;
-}
-
-/* ffestc_subr_unit_ -- Return summary of unit specifier
-
- ffestc_subr_unit_(&specifier); */
-
-static ffestvUnit
-ffestc_subr_unit_ (ffestpFile *spec)
-{
- if (!spec->kw_or_val_present)
- return FFESTV_unitNONE;
- assert (spec->value_present);
- assert (spec->value != NULL);
-
- if (ffebld_op (spec->u.expr) == FFEBLD_opSTAR)
- return FFESTV_unitASTERISK;
+ ffesymbol_set_attrs (s, na);
+ if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
+ ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
+ rank = ffesymbol_rank (s);
+ if (dims != NULL)
+ {
+ ffesymbol_set_dims (s, ffestt_dimlist_as_expr (dims, &rank,
+ &array_size,
+ &extents,
+ is_ugly_assumed));
+ ffesymbol_set_arraysize (s, array_size);
+ ffesymbol_set_extents (s, extents);
+ if (!(0 && ffe_is_90 ())
+ && (ffebld_op (array_size) == FFEBLD_opCONTER)
+ && (ffebld_constant_integerdefault (ffebld_conter (array_size))
+ == 0))
+ {
+ ffebad_start (FFEBAD_ZERO_ARRAY);
+ ffebad_here (0, ffelex_token_where_line (name),
+ ffelex_token_where_column (name));
+ ffebad_finish ();
+ }
+ }
+ if (init != NULL)
+ {
+ ffesymbol_set_init (s,
+ ffeexpr_convert (init, initt, name,
+ ffestc_local_.decl.basic_type,
+ ffestc_local_.decl.kind_type,
+ rank,
+ ffestc_local_.decl.size,
+ FFEEXPR_contextDATA));
+ ffecom_notify_init_symbol (s);
+ ffesymbol_update_init (s);
+#if FFEGLOBAL_ENABLED
+ if (ffesymbol_common (s) != NULL)
+ ffeglobal_init_common (ffesymbol_common (s), initt);
+#endif
+ }
+ else if (clist)
+ {
+ ffebld symter;
- switch (ffeinfo_basictype (ffebld_info (spec->u.expr)))
- {
- case FFEINFO_basictypeINTEGER:
- return FFESTV_unitINTEXPR;
+ symter = ffebld_new_symter (s, FFEINTRIN_genNONE,
+ FFEINTRIN_specNONE,
+ FFEINTRIN_impNONE);
- case FFEINFO_basictypeCHARACTER:
- return FFESTV_unitCHAREXPR;
+ ffebld_set_info (symter,
+ ffeinfo_new (ffestc_local_.decl.basic_type,
+ ffestc_local_.decl.kind_type,
+ rank,
+ FFEINFO_kindNONE,
+ FFEINFO_whereNONE,
+ ffestc_local_.decl.size));
+ ffestc_local_.decl.initlist = ffebld_new_item (symter, NULL);
+ }
+ if (ffesymbol_basictype (s) == FFEINFO_basictypeNONE)
+ {
+ ffesymbol_set_info (s,
+ ffeinfo_new (ffestc_local_.decl.basic_type,
+ ffestc_local_.decl.kind_type,
+ rank,
+ ffesymbol_kind (s),
+ ffesymbol_where (s),
+ ffestc_local_.decl.size));
+ if ((na & FFESYMBOL_attrsRESULT)
+ && ((sfn = ffesymbol_funcresult (s)) != NULL))
+ {
+ ffesymbol_set_info (sfn,
+ ffeinfo_new (ffestc_local_.decl.basic_type,
+ ffestc_local_.decl.kind_type,
+ rank,
+ ffesymbol_kind (sfn),
+ ffesymbol_where (sfn),
+ ffestc_local_.decl.size));
+ ffesymbol_signal_unreported (sfn);
+ }
+ }
+ else if ((ffestc_local_.decl.basic_type != ffesymbol_basictype (s))
+ || (ffestc_local_.decl.kind_type != ffesymbol_kindtype (s))
+ || ((ffestc_local_.decl.basic_type
+ == FFEINFO_basictypeCHARACTER)
+ && (ffestc_local_.decl.size != ffesymbol_size (s))))
+ { /* Explicit type disagrees with established
+ implicit type. */
+ ffesymbol_error (s, name);
+ }
- case FFEINFO_basictypeANY:
- return FFESTV_unitASTERISK;
+ if ((na & FFESYMBOL_attrsADJUSTS)
+ && ((ffestc_local_.decl.basic_type != FFEINFO_basictypeINTEGER)
+ || (ffestc_local_.decl.kind_type != FFEINFO_kindtypeINTEGER1)))
+ ffesymbol_error (s, name);
- default:
- assert ("bad basictype" == NULL);
- return FFESTV_unitINTEXPR;
+ ffesymbol_signal_unreported (s);
+ ffestc_parent_ok_ = TRUE;
}
}
-/* Call this function whenever it's possible that one or more top
- stack items are label-targeting DO blocks that have had their
- labels defined, but at a time when they weren't at the top of the
- stack. This prevents uninformative diagnostics for programs
- like "DO 10", "IF (...) THEN", "10 ELSE", "END IF", "END". */
+/* ffestc_R501_itemstartvals -- Start list of values
-static void
-ffestc_try_shriek_do_ ()
+ ffestc_R501_itemstartvals();
+
+ Gonna specify values for the object now. */
+
+void
+ffestc_R501_itemstartvals ()
{
- ffelab lab;
- ffelabType ty;
+ ffestc_check_item_startvals_ ();
- while ((ffestw_state (ffestw_stack_top ()) == FFESTV_stateDO)
- && ((lab = (ffestw_label (ffestw_stack_top ()))) != NULL)
- && (((ty = (ffelab_type (lab)))
- == FFELAB_typeANY)
- || (ty == FFELAB_typeUSELESS)
- || (ty == FFELAB_typeFORMAT)
- || (ty == FFELAB_typeNOTLOOP)
- || (ty == FFELAB_typeENDIF)))
- ffestc_shriek_do_ (FALSE);
+ if (ffestc_parent_ok_)
+ ffedata_begin (ffestc_local_.decl.initlist);
}
-/* ffestc_decl_start -- R426 or R501
+/* ffestc_R501_itemvalue -- Source value
- ffestc_decl_start(...);
+ ffestc_R501_itemvalue(repeat,repeat_token,value,value_token);
- Verify that R426 component-def-stmt or R501 type-declaration-stmt are
- valid here, figure out which one, and implement. */
+ Make sure repeat and value are valid for the object being initialized. */
void
-ffestc_decl_start (ffestpType type, ffelexToken typet, ffebld kind,
- ffelexToken kindt, ffebld len, ffelexToken lent)
+ffestc_R501_itemvalue (ffebld repeat, ffelexToken repeat_token,
+ ffebld value, ffelexToken value_token)
{
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateNIL:
- case FFESTV_statePROGRAM0:
- case FFESTV_stateSUBROUTINE0:
- case FFESTV_stateFUNCTION0:
- case FFESTV_stateMODULE0:
- case FFESTV_stateBLOCKDATA0:
- case FFESTV_statePROGRAM1:
- case FFESTV_stateSUBROUTINE1:
- case FFESTV_stateFUNCTION1:
- case FFESTV_stateMODULE1:
- case FFESTV_stateBLOCKDATA1:
- case FFESTV_statePROGRAM2:
- case FFESTV_stateSUBROUTINE2:
- case FFESTV_stateFUNCTION2:
- case FFESTV_stateMODULE2:
- case FFESTV_stateBLOCKDATA2:
- case FFESTV_statePROGRAM3:
- case FFESTV_stateSUBROUTINE3:
- case FFESTV_stateFUNCTION3:
- case FFESTV_stateMODULE3:
- case FFESTV_stateBLOCKDATA3:
- case FFESTV_stateUSE:
- ffestc_local_.decl.is_R426 = 2;
- break;
+ ffetargetIntegerDefault rpt;
- case FFESTV_stateTYPE:
- case FFESTV_stateSTRUCTURE:
- case FFESTV_stateMAP:
- ffestc_local_.decl.is_R426 = 1;
- break;
+ ffestc_check_item_value_ ();
- default:
- ffestc_order_bad_ ();
- ffestc_labeldef_useless_ ();
- ffestc_local_.decl.is_R426 = 0;
- return;
- }
+ if (!ffestc_parent_ok_)
+ return;
- switch (ffestc_local_.decl.is_R426)
+ if (repeat == NULL)
+ rpt = 1;
+ else if (ffebld_op (repeat) == FFEBLD_opCONTER)
+ rpt = ffebld_constant_integerdefault (ffebld_conter (repeat));
+ else
{
-#if FFESTR_F90
- case 1:
- ffestc_R426_start (type, typet, kind, kindt, len, lent);
- break;
-#endif
-
- case 2:
- ffestc_R501_start (type, typet, kind, kindt, len, lent);
- break;
-
- default:
- ffestc_labeldef_useless_ ();
- break;
+ ffestc_parent_ok_ = FALSE;
+ ffedata_end (TRUE, NULL);
+ return;
}
+
+ if (!(ffestc_parent_ok_ = ffedata_value (rpt, value,
+ (repeat_token == NULL) ? value_token : repeat_token)))
+ ffedata_end (TRUE, NULL);
}
-/* ffestc_decl_attrib -- R426 or R501 type attribute
+/* ffestc_R501_itemendvals -- End list of values
- ffestc_decl_attrib(...);
+ ffelexToken t; // the SLASH token that ends the list.
+ ffestc_R501_itemendvals(t);
- Verify that R426 component-def-stmt or R501 type-declaration-stmt attribute
- is valid here and implement. */
+ No more values, might specify more objects now. */
void
-ffestc_decl_attrib (ffestpAttrib attrib UNUSED,
- ffelexToken attribt UNUSED,
- ffestrOther intent_kw UNUSED,
- ffesttDimList dims UNUSED)
+ffestc_R501_itemendvals (ffelexToken t)
{
-#if FFESTR_F90
- switch (ffestc_local_.decl.is_R426)
- {
- case 1:
- ffestc_R426_attrib (attrib, attribt, intent_kw, dims);
- break;
+ ffestc_check_item_endvals_ ();
- case 2:
- ffestc_R501_attrib (attrib, attribt, intent_kw, dims);
- break;
+ if (ffestc_parent_ok_)
+ ffestc_parent_ok_ = ffedata_end (FALSE, t);
- default:
- break;
- }
-#else
- ffebad_start (FFEBAD_F90);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_finish ();
- return;
-#endif
+ if (ffestc_parent_ok_)
+ ffesymbol_signal_unreported (ffebld_symter (ffebld_head
+ (ffestc_local_.decl.initlist)));
}
-/* ffestc_decl_item -- R426 or R501
+/* ffestc_R501_finish -- Done
- ffestc_decl_item(...);
+ ffestc_R501_finish();
- Establish type for a particular object. */
+ Just wrap up any local activities. */
void
-ffestc_decl_item (ffelexToken name, ffebld kind, ffelexToken kindt,
- ffesttDimList dims, ffebld len, ffelexToken lent, ffebld init,
- ffelexToken initt, bool clist)
+ffestc_R501_finish ()
{
- switch (ffestc_local_.decl.is_R426)
- {
-#if FFESTR_F90
- case 1:
- ffestc_R426_item (name, kind, kindt, dims, len, lent, init, initt,
- clist);
- break;
-#endif
-
- case 2:
- ffestc_R501_item (name, kind, kindt, dims, len, lent, init, initt,
- clist);
- break;
-
- default:
- break;
- }
+ ffestc_check_finish_ ();
}
-/* ffestc_decl_itemstartvals -- R426 or R501 start list of values
+/* ffestc_R522 -- SAVE statement with no list
- ffestc_decl_itemstartvals();
+ ffestc_R522();
- Gonna specify values for the object now. */
+ Verify that SAVE is valid here, and flag everything as SAVEd. */
void
-ffestc_decl_itemstartvals ()
+ffestc_R522 ()
{
- switch (ffestc_local_.decl.is_R426)
+ ffestc_check_simple_ ();
+ if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
+ return;
+ ffestc_labeldef_useless_ ();
+
+ switch (ffestv_save_state_)
{
-#if FFESTR_F90
- case 1:
- ffestc_R426_itemstartvals ();
+ case FFESTV_savestateNONE:
+ ffestv_save_state_ = FFESTV_savestateALL;
+ ffestv_save_line_
+ = ffewhere_line_use (ffelex_token_where_line (ffesta_tokens[0]));
+ ffestv_save_col_
+ = ffewhere_column_use (ffelex_token_where_column (ffesta_tokens[0]));
break;
-#endif
- case 2:
- ffestc_R501_itemstartvals ();
+ case FFESTV_savestateANY:
+ break;
+
+ case FFESTV_savestateSPECIFIC:
+ case FFESTV_savestateALL:
+ if (ffe_is_pedantic ())
+ {
+ ffebad_start (FFEBAD_CONFLICTING_SAVES);
+ ffebad_here (0, ffestv_save_line_, ffestv_save_col_);
+ ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]),
+ ffelex_token_where_column (ffesta_tokens[0]));
+ ffebad_finish ();
+ }
+ ffestv_save_state_ = FFESTV_savestateALL;
break;
default:
+ assert ("unexpected save state" == NULL);
break;
}
+
+ ffe_set_is_saveall (TRUE);
+
+ ffestd_R522 ();
}
-/* ffestc_decl_itemvalue -- R426 or R501 source value
+/* ffestc_R522start -- SAVE statement list begin
- ffestc_decl_itemvalue(repeat,repeat_token,value,value_token);
+ ffestc_R522start();
- Make sure repeat and value are valid for the object being initialized. */
+ Verify that SAVE is valid here, and begin accepting items in the list. */
void
-ffestc_decl_itemvalue (ffebld repeat, ffelexToken repeat_token,
- ffebld value, ffelexToken value_token)
+ffestc_R522start ()
{
- switch (ffestc_local_.decl.is_R426)
+ ffestc_check_start_ ();
+ if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
{
-#if FFESTR_F90
- case 1:
- ffestc_R426_itemvalue (repeat, repeat_token, value, value_token);
- break;
-#endif
-
- case 2:
- ffestc_R501_itemvalue (repeat, repeat_token, value, value_token);
- break;
-
- default:
- break;
+ ffestc_ok_ = FALSE;
+ return;
}
-}
-
-/* ffestc_decl_itemendvals -- R426 or R501 end list of values
-
- ffelexToken t; // the SLASH token that ends the list.
- ffestc_decl_itemendvals(t);
-
- No more values, might specify more objects now. */
+ ffestc_labeldef_useless_ ();
-void
-ffestc_decl_itemendvals (ffelexToken t)
-{
- switch (ffestc_local_.decl.is_R426)
+ switch (ffestv_save_state_)
{
-#if FFESTR_F90
- case 1:
- ffestc_R426_itemendvals (t);
+ case FFESTV_savestateNONE:
+ ffestv_save_state_ = FFESTV_savestateSPECIFIC;
+ ffestv_save_line_
+ = ffewhere_line_use (ffelex_token_where_line (ffesta_tokens[0]));
+ ffestv_save_col_
+ = ffewhere_column_use (ffelex_token_where_column (ffesta_tokens[0]));
break;
-#endif
- case 2:
- ffestc_R501_itemendvals (t);
+ case FFESTV_savestateSPECIFIC:
+ case FFESTV_savestateANY:
+ break;
+
+ case FFESTV_savestateALL:
+ if (ffe_is_pedantic ())
+ {
+ ffebad_start (FFEBAD_CONFLICTING_SAVES);
+ ffebad_here (0, ffestv_save_line_, ffestv_save_col_);
+ ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]),
+ ffelex_token_where_column (ffesta_tokens[0]));
+ ffebad_finish ();
+ }
+ ffestv_save_state_ = FFESTV_savestateANY;
break;
default:
+ assert ("unexpected save state" == NULL);
break;
}
+
+ ffestd_R522start ();
+
+ ffestc_ok_ = TRUE;
}
-/* ffestc_decl_finish -- R426 or R501
+/* ffestc_R522item_object -- SAVE statement for object-name
- ffestc_decl_finish();
+ ffestc_R522item_object(name_token);
- Just wrap up any local activities. */
+ Make sure name_token identifies a valid object to be SAVEd. */
void
-ffestc_decl_finish ()
+ffestc_R522item_object (ffelexToken name)
{
- switch (ffestc_local_.decl.is_R426)
- {
-#if FFESTR_F90
- case 1:
- ffestc_R426_finish ();
- break;
-#endif
+ ffesymbol s;
+ ffesymbolAttrs sa;
+ ffesymbolAttrs na;
- case 2:
- ffestc_R501_finish ();
- break;
+ ffestc_check_item_ ();
+ assert (name != NULL);
+ if (!ffestc_ok_)
+ return;
- default:
- break;
- }
-}
+ s = ffesymbol_declare_local (name, FALSE);
+ sa = ffesymbol_attrs (s);
-/* ffestc_elsewhere -- Generic ELSE WHERE statement
+ /* Figure out what kind of object we've got based on previous declarations
+ of or references to the object. */
- ffestc_end();
+ if (!ffesymbol_is_specable (s)
+ && ((ffesymbol_kind (s) != FFEINFO_kindENTITY)
+ || (ffesymbol_where (s) != FFEINFO_whereLOCAL)))
+ na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
+ else if (sa & FFESYMBOL_attrsANY)
+ na = sa;
+ else if (!(sa & ~(FFESYMBOL_attrsARRAY
+ | FFESYMBOL_attrsEQUIV
+ | FFESYMBOL_attrsINIT
+ | FFESYMBOL_attrsNAMELIST
+ | FFESYMBOL_attrsSFARG
+ | FFESYMBOL_attrsTYPE)))
+ na = sa | FFESYMBOL_attrsSAVE;
+ else
+ na = FFESYMBOL_attrsetNONE;
- Decide whether ELSEWHERE or ELSE w/if-construct-name=="WHERE" is meant. */
+ /* Now see what we've got for a new object: NONE means a new error cropped
+ up; ANY means an old error to be ignored; otherwise, everything's ok,
+ update the object (symbol) and continue on. */
-void
-ffestc_elsewhere (ffelexToken where)
-{
- switch (ffestw_state (ffestw_stack_top ()))
+ if (na == FFESYMBOL_attrsetNONE)
+ ffesymbol_error (s, name);
+ else if (!(na & FFESYMBOL_attrsANY))
{
- case FFESTV_stateIFTHEN:
- ffestc_R805 (where);
- break;
-
- default:
-#if FFESTR_F90
- ffestc_R744 ();
-#endif
- break;
+ ffesymbol_set_attrs (s, na);
+ if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
+ ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
+ ffesymbol_update_save (s);
+ ffesymbol_signal_unreported (s);
}
+
+ ffestd_R522item_object (name);
}
-/* ffestc_end -- Generic END statement
+/* ffestc_R522item_cblock -- SAVE statement for common-block-name
- ffestc_end();
+ ffestc_R522item_cblock(name_token);
- Make sure a generic END is valid in the current context, and implement
- it. */
+ Make sure name_token identifies a valid common block to be SAVEd. */
void
-ffestc_end ()
+ffestc_R522item_cblock (ffelexToken name)
{
- ffestw b;
+ ffesymbol s;
+ ffesymbolAttrs sa;
+ ffesymbolAttrs na;
- b = ffestw_stack_top ();
+ ffestc_check_item_ ();
+ assert (name != NULL);
+ if (!ffestc_ok_)
+ return;
-recurse:
+ s = ffesymbol_declare_cblock (name, ffelex_token_where_line (ffesta_tokens[0]),
+ ffelex_token_where_column (ffesta_tokens[0]));
+ sa = ffesymbol_attrs (s);
- switch (ffestw_state (b))
- {
- case FFESTV_stateBLOCKDATA0:
- case FFESTV_stateBLOCKDATA1:
- case FFESTV_stateBLOCKDATA2:
- case FFESTV_stateBLOCKDATA3:
- case FFESTV_stateBLOCKDATA4:
- case FFESTV_stateBLOCKDATA5:
- ffestc_R1112 (NULL);
- break;
+ /* Figure out what kind of object we've got based on previous declarations
+ of or references to the object. */
- case FFESTV_stateFUNCTION0:
- case FFESTV_stateFUNCTION1:
- case FFESTV_stateFUNCTION2:
- case FFESTV_stateFUNCTION3:
- case FFESTV_stateFUNCTION4:
- case FFESTV_stateFUNCTION5:
- if ((ffestw_state (ffestw_previous (b)) != FFESTV_stateNIL)
- && (ffestw_state (ffestw_previous (b)) != FFESTV_stateINTERFACE0))
- {
- ffebad_start (FFEBAD_END_WO);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_here (1, ffestw_line (ffestw_previous (b)), ffestw_col (ffestw_previous (b)));
- ffebad_string ("FUNCTION");
- ffebad_finish ();
- }
- ffestc_R1221 (NULL);
- break;
+ if (!ffesymbol_is_specable (s))
+ na = FFESYMBOL_attrsetNONE;
+ else if (sa & FFESYMBOL_attrsANY)
+ na = sa; /* Already have an error here, say nothing. */
+ else if (!(sa & ~(FFESYMBOL_attrsCBLOCK)))
+ na = sa | FFESYMBOL_attrsSAVECBLOCK;
+ else
+ na = FFESYMBOL_attrsetNONE;
- case FFESTV_stateMODULE0:
- case FFESTV_stateMODULE1:
- case FFESTV_stateMODULE2:
- case FFESTV_stateMODULE3:
- case FFESTV_stateMODULE4:
- case FFESTV_stateMODULE5:
-#if FFESTR_F90
- ffestc_R1106 (NULL);
-#endif
- break;
+ /* Now see what we've got for a new object: NONE means a new error cropped
+ up; ANY means an old error to be ignored; otherwise, everything's ok,
+ update the object (symbol) and continue on. */
- case FFESTV_stateSUBROUTINE0:
- case FFESTV_stateSUBROUTINE1:
- case FFESTV_stateSUBROUTINE2:
- case FFESTV_stateSUBROUTINE3:
- case FFESTV_stateSUBROUTINE4:
- case FFESTV_stateSUBROUTINE5:
- if ((ffestw_state (ffestw_previous (b)) != FFESTV_stateNIL)
- && (ffestw_state (ffestw_previous (b)) != FFESTV_stateINTERFACE0))
- {
- ffebad_start (FFEBAD_END_WO);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_here (1, ffestw_line (ffestw_previous (b)), ffestw_col (ffestw_previous (b)));
- ffebad_string ("SUBROUTINE");
- ffebad_finish ();
- }
- ffestc_R1225 (NULL);
- break;
+ if (na == FFESYMBOL_attrsetNONE)
+ ffesymbol_error (s, (name == NULL) ? ffesta_tokens[0] : name);
+ else if (!(na & FFESYMBOL_attrsANY))
+ {
+ ffesymbol_set_attrs (s, na);
+ ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
+ ffesymbol_update_save (s);
+ ffesymbol_signal_unreported (s);
+ }
- case FFESTV_stateUSE:
- b = ffestw_previous (ffestw_stack_top ());
- goto recurse; /* :::::::::::::::::::: */
+ ffestd_R522item_cblock (name);
+}
- default:
- ffestc_R1103 (NULL);
- break;
- }
+/* ffestc_R522finish -- SAVE statement list complete
+
+ ffestc_R522finish();
+
+ Just wrap up any local activities. */
+
+void
+ffestc_R522finish ()
+{
+ ffestc_check_finish_ ();
+ if (!ffestc_ok_)
+ return;
+
+ ffestd_R522finish ();
}
-/* ffestc_eof -- Generic EOF
+/* ffestc_R524_start -- DIMENSION statement list begin
- ffestc_eof();
+ ffestc_R524_start(bool virtual);
- Make sure we're at state NIL, or issue an error message and use each
- block's shriek function to clean up to state NIL. */
+ Verify that DIMENSION is valid here, and begin accepting items in the
+ list. */
void
-ffestc_eof ()
+ffestc_R524_start (bool virtual)
{
- if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateNIL)
+ ffestc_check_start_ ();
+ if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
{
- ffebad_start (FFEBAD_EOF_BEFORE_BLOCK_END);
- ffebad_here (0, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
- do
- (*ffestw_shriek (ffestw_stack_top ()))(FALSE);
- while (ffestw_state (ffestw_stack_top ()) != FFESTV_stateNIL);
+ ffestc_ok_ = FALSE;
+ return;
}
-}
+ ffestc_labeldef_useless_ ();
-/* ffestc_exec_transition -- Check if ok and move stmt state to executable
+ ffestd_R524_start (virtual);
- if (ffestc_exec_transition())
- // Transition successful (kind of like a CONTINUE stmt was seen).
+ ffestc_ok_ = TRUE;
+}
- If the current statement state is a non-nested specification state in
- which, say, a CONTINUE statement would be valid, then enter the state
- we'd be in after seeing CONTINUE (without, of course, generating any
- CONTINUE code), call ffestd_exec_begin, and return TRUE. Otherwise
- return FALSE.
+/* ffestc_R524_item -- DIMENSION statement for object-name
- This function cannot be invoked once the first executable statement
- is seen. This function may choose to always return TRUE by shrieking
- away any interceding state stack entries to reach the base level of
- specification state, but right now it doesn't, and it is (or should
- be) purely an issue of how one wishes errors to be handled (for example,
- an unrecognized statement in the middle of a STRUCTURE construct: after
- the error message, should subsequent statements still be interpreted as
- being within the construct, or should the construct be terminated upon
- seeing the unrecognized statement? we do the former at the moment). */
+ ffestc_R524_item(name_token,dim_list);
-bool
-ffestc_exec_transition ()
+ Make sure name_token identifies a valid object to be DIMENSIONd. */
+
+void
+ffestc_R524_item (ffelexToken name, ffesttDimList dims)
{
- bool update;
+ ffesymbol s;
+ ffebld array_size;
+ ffebld extents;
+ ffesymbolAttrs sa;
+ ffesymbolAttrs na;
+ ffestpDimtype nd;
+ ffeinfoRank rank;
+ bool is_ugly_assumed;
-recurse:
+ ffestc_check_item_ ();
+ assert (name != NULL);
+ assert (dims != NULL);
+ if (!ffestc_ok_)
+ return;
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateNIL:
- ffestc_shriek_begin_program_ ();
- goto recurse; /* :::::::::::::::::::: */
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- case FFESTV_statePROGRAM0:
- case FFESTV_stateSUBROUTINE0:
- case FFESTV_stateFUNCTION0:
- case FFESTV_stateBLOCKDATA0:
- ffestw_state (ffestw_stack_top ()) += 4; /* To state UNIT4. */
- update = TRUE;
- break;
+ s = ffesymbol_declare_local (name, FALSE);
+ sa = ffesymbol_attrs (s);
- case FFESTV_statePROGRAM1:
- case FFESTV_stateSUBROUTINE1:
- case FFESTV_stateFUNCTION1:
- case FFESTV_stateBLOCKDATA1:
- ffestw_state (ffestw_stack_top ()) += 3; /* To state UNIT4. */
- update = TRUE;
+ /* First figure out what kind of object this is based solely on the current
+ object situation (dimension list). */
+
+ is_ugly_assumed = (ffe_is_ugly_assumed ()
+ && ((sa & FFESYMBOL_attrsDUMMY)
+ || (ffesymbol_where (s) == FFEINFO_whereDUMMY)));
+
+ nd = ffestt_dimlist_type (dims, is_ugly_assumed);
+ switch (nd)
+ {
+ case FFESTP_dimtypeKNOWN:
+ na = FFESYMBOL_attrsARRAY;
break;
- case FFESTV_statePROGRAM2:
- case FFESTV_stateSUBROUTINE2:
- case FFESTV_stateFUNCTION2:
- case FFESTV_stateBLOCKDATA2:
- ffestw_state (ffestw_stack_top ()) += 2; /* To state UNIT4. */
- update = TRUE;
+ case FFESTP_dimtypeADJUSTABLE:
+ na = FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE;
break;
- case FFESTV_statePROGRAM3:
- case FFESTV_stateSUBROUTINE3:
- case FFESTV_stateFUNCTION3:
- case FFESTV_stateBLOCKDATA3:
- ffestw_state (ffestw_stack_top ()) += 1; /* To state UNIT4. */
- update = TRUE;
+ case FFESTP_dimtypeASSUMED:
+ na = FFESYMBOL_attrsARRAY | FFESYMBOL_attrsANYSIZE;
break;
- case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
- goto recurse; /* :::::::::::::::::::: */
+ case FFESTP_dimtypeADJUSTABLEASSUMED:
+ na = FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE
+ | FFESYMBOL_attrsANYSIZE;
+ break;
default:
- return FALSE;
+ assert ("Unexpected dims type" == NULL);
+ na = FFESYMBOL_attrsetNONE;
+ break;
}
- if (update)
- ffestw_update (NULL); /* Update state line/col info. */
-
- ffesta_seen_first_exec = TRUE;
- ffestd_exec_begin ();
-
- return TRUE;
-}
-
-/* ffestc_ffebad_here_doiter -- Calls ffebad_here with ptr to DO iter var
+ /* Now figure out what kind of object we've got based on previous
+ declarations of or references to the object. */
- ffesymbol s;
- // call ffebad_start first, of course.
- ffestc_ffebad_here_doiter(0,s);
- // call ffebad_finish afterwards, naturally.
+ if (!ffesymbol_is_specable (s))
+ na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
+ else if (sa & FFESYMBOL_attrsANY)
+ na = FFESYMBOL_attrsANY;
+ else if (!ffesta_is_entry_valid
+ && (sa & FFESYMBOL_attrsANYLEN))
+ na = FFESYMBOL_attrsetNONE;
+ else if ((sa & FFESYMBOL_attrsARRAY)
+ || ((sa & (FFESYMBOL_attrsCOMMON
+ | FFESYMBOL_attrsEQUIV
+ | FFESYMBOL_attrsNAMELIST
+ | FFESYMBOL_attrsSAVE))
+ && (na & (FFESYMBOL_attrsADJUSTABLE
+ | FFESYMBOL_attrsANYSIZE))))
+ na = FFESYMBOL_attrsetNONE;
+ else if (!(sa & ~(FFESYMBOL_attrsADJUSTABLE
+ | FFESYMBOL_attrsANYLEN
+ | FFESYMBOL_attrsANYSIZE
+ | FFESYMBOL_attrsCOMMON
+ | FFESYMBOL_attrsDUMMY
+ | FFESYMBOL_attrsEQUIV
+ | FFESYMBOL_attrsNAMELIST
+ | FFESYMBOL_attrsSAVE
+ | FFESYMBOL_attrsTYPE)))
+ na |= sa;
+ else
+ na = FFESYMBOL_attrsetNONE;
- Searches the stack of blocks backwards for a DO loop that has s
- as its iteration variable, then calls ffebad_here with pointers to
- that particular reference to the variable. Crashes if the DO loop
- can't be found. */
+ /* Now see what we've got for a new object: NONE means a new error cropped
+ up; ANY means an old error to be ignored; otherwise, everything's ok,
+ update the object (symbol) and continue on. */
-void
-ffestc_ffebad_here_doiter (ffebadIndex i, ffesymbol s)
-{
- ffestw block;
-
- for (block = ffestw_top_do (ffestw_stack_top ());
- (block != NULL) && (ffestw_blocknum (block) != 0);
- block = ffestw_top_do (ffestw_previous (block)))
+ if (na == FFESYMBOL_attrsetNONE)
+ ffesymbol_error (s, name);
+ else if (!(na & FFESYMBOL_attrsANY))
{
- if (ffestw_do_iter_var (block) == s)
+ ffesymbol_set_attrs (s, na);
+ ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
+ ffesymbol_set_dims (s, ffestt_dimlist_as_expr (dims, &rank,
+ &array_size,
+ &extents,
+ is_ugly_assumed));
+ ffesymbol_set_arraysize (s, array_size);
+ ffesymbol_set_extents (s, extents);
+ if (!(0 && ffe_is_90 ())
+ && (ffebld_op (array_size) == FFEBLD_opCONTER)
+ && (ffebld_constant_integerdefault (ffebld_conter (array_size))
+ == 0))
{
- ffebad_here (i, ffelex_token_where_line (ffestw_do_iter_var_t (block)),
- ffelex_token_where_column (ffestw_do_iter_var_t (block)));
- return;
+ ffebad_start (FFEBAD_ZERO_ARRAY);
+ ffebad_here (0, ffelex_token_where_line (name),
+ ffelex_token_where_column (name));
+ ffebad_finish ();
}
+ ffesymbol_set_info (s,
+ ffeinfo_new (ffesymbol_basictype (s),
+ ffesymbol_kindtype (s),
+ rank,
+ ffesymbol_kind (s),
+ ffesymbol_where (s),
+ ffesymbol_size (s)));
}
- assert ("no do block found" == NULL);
+
+ ffesymbol_signal_unreported (s);
+
+ ffestd_R524_item (name, dims);
}
-/* ffestc_is_decl_not_R1219 -- Context information for FFESTB
+/* ffestc_R524_finish -- DIMENSION statement list complete
- if (ffestc_is_decl_not_R1219()) ...
+ ffestc_R524_finish();
- When a statement with the form "type[RECURSIVE]FUNCTIONname(name-list)"
- is seen, call this function. It returns TRUE if the statement's context
- is such that it is a declaration of an object named
- "[RECURSIVE]FUNCTIONname" with an array-decl spec of "name-list", FALSE
- if the statement's context is such that it begins the definition of a
- function named "name" havin the dummy argument list "name-list" (this
- is the R1219 function-stmt case). */
+ Just wrap up any local activities. */
-bool
-ffestc_is_decl_not_R1219 ()
+void
+ffestc_R524_finish ()
{
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateNIL:
- case FFESTV_statePROGRAM5:
- case FFESTV_stateSUBROUTINE5:
- case FFESTV_stateFUNCTION5:
- case FFESTV_stateMODULE5:
- case FFESTV_stateINTERFACE0:
- return FALSE;
+ ffestc_check_finish_ ();
+ if (!ffestc_ok_)
+ return;
- default:
- return TRUE;
- }
+ ffestd_R524_finish ();
}
-/* ffestc_is_entry_in_subr -- Context information for FFESTB
+/* ffestc_R528_start -- DATA statement list begin
- if (ffestc_is_entry_in_subr()) ...
+ ffestc_R528_start();
- When a statement with the form "ENTRY name(name-list)"
- is seen, call this function. It returns TRUE if the statement's context
- is such that it may have "*", meaning alternate return, in place of
- names in the name list (i.e. if the ENTRY is in a subroutine context).
- It also returns TRUE if the ENTRY is not in a function context (invalid
- but prevents extra complaints about "*", if present). It returns FALSE
- if the ENTRY is in a function context. */
+ Verify that DATA is valid here, and begin accepting items in the list. */
-bool
-ffestc_is_entry_in_subr ()
+void
+ffestc_R528_start ()
{
- ffestvState s;
-
- s = ffestw_state (ffestw_stack_top ());
-
-recurse:
+ ffestcOrder_ order;
- switch (s)
+ ffestc_check_start_ ();
+ if (ffe_is_pedantic_not_90 ())
+ order = ffestc_order_data77_ ();
+ else
+ order = ffestc_order_data_ ();
+ if (order != FFESTC_orderOK_)
{
- case FFESTV_stateFUNCTION0:
- case FFESTV_stateFUNCTION1:
- case FFESTV_stateFUNCTION2:
- case FFESTV_stateFUNCTION3:
- case FFESTV_stateFUNCTION4:
- return FALSE;
-
- case FFESTV_stateUSE:
- s = ffestw_state (ffestw_previous (ffestw_stack_top ()));
- goto recurse; /* :::::::::::::::::::: */
-
- default:
- return TRUE;
+ ffestc_ok_ = FALSE;
+ return;
}
-}
-
-/* ffestc_is_let_not_V027 -- Context information for FFESTB
-
- if (ffestc_is_let_not_V027()) ...
+ ffestc_labeldef_useless_ ();
- When a statement with the form "PARAMETERname=expr"
- is seen, call this function. It returns TRUE if the statement's context
- is such that it is an assignment to an object named "PARAMETERname", FALSE
- if the statement's context is such that it is a V-extension PARAMETER
- statement that is like a PARAMETER(name=expr) statement except that the
- type of name is determined by the type of expr, not the implicit or
- explicit typing of name. */
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
-bool
-ffestc_is_let_not_V027 ()
-{
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_statePROGRAM4:
- case FFESTV_stateSUBROUTINE4:
- case FFESTV_stateFUNCTION4:
- case FFESTV_stateWHERETHEN:
- case FFESTV_stateIFTHEN:
- case FFESTV_stateDO:
- case FFESTV_stateSELECT0:
- case FFESTV_stateSELECT1:
- case FFESTV_stateWHERE:
- case FFESTV_stateIF:
- return TRUE;
+#if 1
+ ffestc_local_.data.objlist = NULL;
+#else
+ ffestd_R528_start_ ();
+#endif
- default:
- return FALSE;
- }
+ ffestc_ok_ = TRUE;
}
-/* ffestc_module -- MODULE or MODULE PROCEDURE statement
+/* ffestc_R528_item_object -- DATA statement target object
- ffestc_module(module_name_token,procedure_name_token);
+ ffestc_R528_item_object(object,object_token);
- Decide which is intended, and implement it by calling _R1105_ or
- _R1205_. */
+ Make sure object is valid to be DATAd. */
-#if FFESTR_F90
void
-ffestc_module (ffelexToken module, ffelexToken procedure)
+ffestc_R528_item_object (ffebld expr, ffelexToken expr_token UNUSED)
{
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateINTERFACE0:
- case FFESTV_stateINTERFACE1:
- ffestc_R1205_start ();
- ffestc_R1205_item (procedure);
- ffestc_R1205_finish ();
- break;
+ ffestc_check_item_ ();
+ if (!ffestc_ok_)
+ return;
- default:
- ffestc_R1105 (module);
- break;
- }
-}
+#if 1
+ if (ffestc_local_.data.objlist == NULL)
+ ffebld_init_list (&ffestc_local_.data.objlist,
+ &ffestc_local_.data.list_bottom);
+ ffebld_append_item (&ffestc_local_.data.list_bottom, expr);
+#else
+ ffestd_R528_item_object_ (expr, expr_token);
#endif
-/* ffestc_private -- Generic PRIVATE statement
+}
- ffestc_end();
+/* ffestc_R528_item_startvals -- DATA statement start list of values
+
+ ffestc_R528_item_startvals();
- This is either a PRIVATE within R422 derived-type statement or an
- R521 PRIVATE statement. Figure it out based on context and implement
- it, or produce an error. */
+ No more objects, gonna specify values for the list of objects now. */
-#if FFESTR_F90
void
-ffestc_private ()
+ffestc_R528_item_startvals ()
{
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateTYPE:
- ffestc_R423A ();
- break;
+ ffestc_check_item_startvals_ ();
+ if (!ffestc_ok_)
+ return;
- default:
- ffestc_R521B ();
- break;
- }
+#if 1
+ assert (ffestc_local_.data.objlist != NULL);
+ ffebld_end_list (&ffestc_local_.data.list_bottom);
+ ffedata_begin (ffestc_local_.data.objlist);
+#else
+ ffestd_R528_item_startvals_ ();
+#endif
}
-#endif
-/* ffestc_terminate_4 -- Terminate ffestc after scoping unit
+/* ffestc_R528_item_value -- DATA statement source value
- ffestc_terminate_4();
+ ffestc_R528_item_value(repeat,repeat_token,value,value_token);
- For SUBROUTINEs/FUNCTIONs within INTERFACE/END INTERFACE, derived-TYPE-
- defs, and statement function defs. */
+ Make sure repeat and value are valid for the objects being initialized. */
void
-ffestc_terminate_4 ()
+ffestc_R528_item_value (ffebld repeat, ffelexToken repeat_token,
+ ffebld value, ffelexToken value_token)
{
- ffestc_entry_num_ = ffestc_saved_entry_num_;
-}
-
-/* ffestc_R423A -- PRIVATE statement (in R422 derived-type statement)
-
- ffestc_R423A(); */
+ ffetargetIntegerDefault rpt;
-#if FFESTR_F90
-void
-ffestc_R423A ()
-{
- ffestc_check_simple_ ();
- if (ffestc_order_type_ () != FFESTC_orderOK_)
+ ffestc_check_item_value_ ();
+ if (!ffestc_ok_)
return;
- ffestc_labeldef_useless_ ();
-
- if (ffestw_substate (ffestw_stack_top ()) != 0)
- {
- ffebad_start (FFEBAD_DERIVTYP_ACCESS_FIRST);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
- return;
- }
- if (ffestw_state (ffestw_previous (ffestw_stack_top ())) != FFESTV_stateMODULE3)
+#if 1
+ if (repeat == NULL)
+ rpt = 1;
+ else if (ffebld_op (repeat) == FFEBLD_opCONTER)
+ rpt = ffebld_constant_integerdefault (ffebld_conter (repeat));
+ else
{
- ffebad_start (FFEBAD_DERIVTYP_ACCESS);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_finish ();
+ ffestc_ok_ = FALSE;
+ ffedata_end (TRUE, NULL);
return;
}
- ffestw_set_substate (ffestw_stack_top (), 1); /* Seen
- private-sequence-stmt. */
+ if (!(ffestc_ok_ = ffedata_value (rpt, value,
+ (repeat_token == NULL)
+ ? value_token
+ : repeat_token)))
+ ffedata_end (TRUE, NULL);
- ffestd_R423A ();
+#else
+ ffestd_R528_item_value_ (repeat, value);
+#endif
}
-/* ffestc_R423B -- SEQUENCE statement (in R422 derived-type-stmt)
-
- ffestc_R423B(); */
+/* ffestc_R528_item_endvals -- DATA statement start list of values
+
+ ffelexToken t; // the SLASH token that ends the list.
+ ffestc_R528_item_endvals(t);
+
+ No more values, might specify more objects now. */
void
-ffestc_R423B ()
+ffestc_R528_item_endvals (ffelexToken t)
{
- ffestc_check_simple_ ();
- if (ffestc_order_type_ () != FFESTC_orderOK_)
+ ffestc_check_item_endvals_ ();
+ if (!ffestc_ok_)
return;
- ffestc_labeldef_useless_ ();
-
- if (ffestw_substate (ffestw_stack_top ()) != 0)
- {
- ffebad_start (FFEBAD_DERIVTYP_ACCESS_FIRST);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
- return;
- }
-
- ffestw_set_substate (ffestw_stack_top (), 1); /* Seen
- private-sequence-stmt. */
- ffestd_R423B ();
+#if 1
+ ffedata_end (!ffestc_ok_, t);
+ ffestc_local_.data.objlist = NULL;
+#else
+ ffestd_R528_item_endvals_ (t);
+#endif
}
-/* ffestc_R424 -- derived-TYPE-def statement
+/* ffestc_R528_finish -- DATA statement list complete
- ffestc_R424(access_token,access_kw,name_token);
+ ffestc_R528_finish();
- Handle a derived-type definition. */
+ Just wrap up any local activities. */
void
-ffestc_R424 (ffelexToken access, ffestrOther access_kw, ffelexToken name)
+ffestc_R528_finish ()
{
- ffestw b;
-
- assert (name != NULL);
-
- ffestc_check_simple_ ();
- if (ffestc_order_derivedtype_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
-
- if ((access != NULL)
- && (ffestw_state (ffestw_stack_top ()) != FFESTV_stateMODULE3))
- {
- ffebad_start (FFEBAD_DERIVTYP_ACCESS);
- ffebad_here (0, ffelex_token_where_line (access),
- ffelex_token_where_column (access));
- ffebad_finish ();
- access = NULL;
- }
-
- b = ffestw_update (ffestw_push (NULL));
- ffestw_set_top_do (b, NULL);
- ffestw_set_state (b, FFESTV_stateTYPE);
- ffestw_set_blocknum (b, 0);
- ffestw_set_shriek (b, ffestc_shriek_type_);
- ffestw_set_name (b, ffelex_token_use (name));
- ffestw_set_substate (b, 0); /* Awaiting private-sequence-stmt and one
- component-def-stmt. */
-
- ffestd_R424 (access, access_kw, name);
+ ffestc_check_finish_ ();
- ffe_init_4 ();
+#if 1
+#else
+ ffestd_R528_finish_ ();
+#endif
}
-/* ffestc_R425 -- END TYPE statement
+/* ffestc_R537_start -- PARAMETER statement list begin
- ffestc_R425(name_token);
+ ffestc_R537_start();
- Make sure ffestc_kind_ identifies a TYPE definition. If not
- NULL, make sure name_token gives the correct name. Implement the end
- of the type definition. */
+ Verify that PARAMETER is valid here, and begin accepting items in the
+ list. */
void
-ffestc_R425 (ffelexToken name)
+ffestc_R537_start ()
{
- ffestc_check_simple_ ();
- if (ffestc_order_type_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
-
- if (ffestw_substate (ffestw_stack_top ()) != 2)
+ ffestc_check_start_ ();
+ if (ffestc_order_parameter_ () != FFESTC_orderOK_)
{
- ffebad_start (FFEBAD_DERIVTYP_NO_COMPONENTS);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
+ ffestc_ok_ = FALSE;
+ return;
}
+ ffestc_labeldef_useless_ ();
- if ((name != NULL)
- && (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0))
- {
- ffebad_start (FFEBAD_TYPE_WRONG_NAME);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
- ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
- ffebad_finish ();
- }
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
+
+ ffestd_R537_start ();
- ffestc_shriek_type_ (TRUE);
+ ffestc_ok_ = TRUE;
}
-/* ffestc_R426_start -- component-declaration-stmt
+/* ffestc_R537_item -- PARAMETER statement assignment
- ffestc_R426_start(...);
+ ffestc_R537_item(dest,dest_token,source,source_token);
- Verify that R426 component-declaration-stmt is
- valid here and implement. */
+ Make sure the source is a valid source for the destination; make the
+ assignment. */
void
-ffestc_R426_start (ffestpType type, ffelexToken typet, ffebld kind,
- ffelexToken kindt, ffebld len, ffelexToken lent)
+ffestc_R537_item (ffebld dest, ffelexToken dest_token, ffebld source,
+ ffelexToken source_token)
{
- ffestc_check_start_ ();
- if (ffestc_order_component_ () != FFESTC_orderOK_)
+ ffesymbol s;
+
+ ffestc_check_item_ ();
+ if (!ffestc_ok_)
+ return;
+
+ if ((ffebld_op (dest) == FFEBLD_opANY)
+ || (ffebld_op (source) == FFEBLD_opANY))
{
- ffestc_local_.decl.is_R426 = 0;
+ if (ffebld_op (dest) == FFEBLD_opSYMTER)
+ {
+ s = ffebld_symter (dest);
+ ffesymbol_set_init (s, ffebld_new_any ());
+ ffebld_set_info (ffesymbol_init (s), ffeinfo_new_any ());
+ ffesymbol_signal_unreported (s);
+ }
+ ffestd_R537_item (dest, source);
return;
}
- ffestc_labeldef_useless_ ();
-
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateSTRUCTURE:
- case FFESTV_stateMAP:
- ffestw_set_substate (ffestw_stack_top (), 1); /* Seen at least one
- member. */
- break;
- case FFESTV_stateTYPE:
- ffestw_set_substate (ffestw_stack_top (), 2);
- break;
+ assert (ffebld_op (dest) == FFEBLD_opSYMTER);
+ assert (ffebld_op (source) == FFEBLD_opCONTER);
- default:
- assert ("Component parent state invalid" == NULL);
- break;
+ s = ffebld_symter (dest);
+ if ((ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
+ && (ffesymbol_size (s) == FFETARGET_charactersizeNONE))
+ { /* Destination has explicit/implicit
+ CHARACTER*(*) type; set length. */
+ ffesymbol_set_info (s,
+ ffeinfo_new (ffesymbol_basictype (s),
+ ffesymbol_kindtype (s),
+ 0,
+ ffesymbol_kind (s),
+ ffesymbol_where (s),
+ ffebld_size (source)));
+ ffebld_set_info (dest, ffeinfo_use (ffesymbol_info (s)));
}
-}
-/* ffestc_R426_attrib -- type attribute
+ source = ffeexpr_convert_expr (source, source_token, dest, dest_token,
+ FFEEXPR_contextDATA);
- ffestc_R426_attrib(...);
+ ffesymbol_set_init (s, source);
- Verify that R426 component-declaration-stmt attribute
- is valid here and implement. */
+ ffesymbol_signal_unreported (s);
-void
-ffestc_R426_attrib (ffestpAttrib attrib, ffelexToken attribt,
- ffestrOther intent_kw, ffesttDimList dims)
-{
- ffestc_check_attrib_ ();
+ ffestd_R537_item (dest, source);
}
-/* ffestc_R426_item -- declared object
+/* ffestc_R537_finish -- PARAMETER statement list complete
- ffestc_R426_item(...);
+ ffestc_R537_finish();
- Establish type for a particular object. */
+ Just wrap up any local activities. */
void
-ffestc_R426_item (ffelexToken name, ffebld kind, ffelexToken kindt,
- ffesttDimList dims, ffebld len, ffelexToken lent, ffebld init,
- ffelexToken initt, bool clist)
+ffestc_R537_finish ()
{
- ffestc_check_item_ ();
- assert (name != NULL);
- assert (ffelex_token_type (name) == FFELEX_typeNAME); /* Not NAMES. */
- assert (kind == NULL); /* No way an expression should get here. */
+ ffestc_check_finish_ ();
+ if (!ffestc_ok_)
+ return;
- if ((dims != NULL) || (init != NULL) || clist)
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
+ ffestd_R537_finish ();
}
-/* ffestc_R426_itemstartvals -- Start list of values
+/* ffestc_R539 -- IMPLICIT NONE statement
- ffestc_R426_itemstartvals();
+ ffestc_R539();
- Gonna specify values for the object now. */
+ Verify that the IMPLICIT NONE statement is ok here and implement. */
void
-ffestc_R426_itemstartvals ()
+ffestc_R539 ()
{
- ffestc_check_item_startvals_ ();
+ ffestc_check_simple_ ();
+ if (ffestc_order_implicitnone_ () != FFESTC_orderOK_)
+ return;
+ ffestc_labeldef_useless_ ();
+
+ ffeimplic_none ();
+
+ ffestd_R539 ();
}
-/* ffestc_R426_itemvalue -- Source value
+/* ffestc_R539start -- IMPLICIT statement
- ffestc_R426_itemvalue(repeat,repeat_token,value,value_token);
+ ffestc_R539start();
- Make sure repeat and value are valid for the object being initialized. */
+ Verify that the IMPLICIT statement is ok here and implement. */
void
-ffestc_R426_itemvalue (ffebld repeat, ffelexToken repeat_token,
- ffebld value, ffelexToken value_token)
+ffestc_R539start ()
{
- ffestc_check_item_value_ ();
+ ffestc_check_start_ ();
+ if (ffestc_order_implicit_ () != FFESTC_orderOK_)
+ {
+ ffestc_ok_ = FALSE;
+ return;
+ }
+ ffestc_labeldef_useless_ ();
+
+ ffestd_R539start ();
+
+ ffestc_ok_ = TRUE;
}
-/* ffestc_R426_itemendvals -- End list of values
+/* ffestc_R539item -- IMPLICIT statement specification (R540)
- ffelexToken t; // the SLASH token that ends the list.
- ffestc_R426_itemendvals(t);
+ ffestc_R539item(...);
- No more values, might specify more objects now. */
+ Verify that the type and letter list are all ok and implement. */
void
-ffestc_R426_itemendvals (ffelexToken t)
+ffestc_R539item (ffestpType type, ffebld kind, ffelexToken kindt,
+ ffebld len, ffelexToken lent, ffesttImpList letters)
{
- ffestc_check_item_endvals_ ();
+ ffestc_check_item_ ();
+ if (!ffestc_ok_)
+ return;
+
+ if ((type == FFESTP_typeCHARACTER) && (len != NULL)
+ && (ffebld_op (len) == FFEBLD_opSTAR))
+ { /* Complain and pretend they're CHARACTER
+ [*1]. */
+ ffebad_start (FFEBAD_IMPLICIT_ADJLEN);
+ ffebad_here (0, ffelex_token_where_line (lent),
+ ffelex_token_where_column (lent));
+ ffebad_finish ();
+ len = NULL;
+ lent = NULL;
+ }
+ ffestc_establish_declstmt_ (type, ffesta_tokens[0], kind, kindt, len, lent);
+ ffestc_establish_declinfo_ (NULL, NULL, NULL, NULL);
+
+ ffestt_implist_drive (letters, ffestc_establish_impletter_);
+
+ ffestd_R539item (type, kind, kindt, len, lent, letters);
}
-/* ffestc_R426_finish -- Done
+/* ffestc_R539finish -- IMPLICIT statement
- ffestc_R426_finish();
+ ffestc_R539finish();
- Just wrap up any local activities. */
+ Finish up any local activities. */
void
-ffestc_R426_finish ()
+ffestc_R539finish ()
{
ffestc_check_finish_ ();
+ if (!ffestc_ok_)
+ return;
+
+ ffestd_R539finish ();
}
-#endif
-/* ffestc_R501_start -- type-declaration-stmt
+/* ffestc_R542_start -- NAMELIST statement list begin
- ffestc_R501_start(...);
+ ffestc_R542_start();
- Verify that R501 type-declaration-stmt is
- valid here and implement. */
+ Verify that NAMELIST is valid here, and begin accepting items in the
+ list. */
void
-ffestc_R501_start (ffestpType type, ffelexToken typet, ffebld kind,
- ffelexToken kindt, ffebld len, ffelexToken lent)
+ffestc_R542_start ()
{
ffestc_check_start_ ();
- if (ffestc_order_typedecl_ () != FFESTC_orderOK_)
+ if (ffestc_order_progspec_ () != FFESTC_orderOK_)
{
- ffestc_local_.decl.is_R426 = 0;
+ ffestc_ok_ = FALSE;
return;
}
ffestc_labeldef_useless_ ();
- ffestc_establish_declstmt_ (type, typet, kind, kindt, len, lent);
-}
-
-/* ffestc_R501_attrib -- type attribute
-
- ffestc_R501_attrib(...);
-
- Verify that R501 type-declaration-stmt attribute
- is valid here and implement. */
-
-void
-ffestc_R501_attrib (ffestpAttrib attrib, ffelexToken attribt,
- ffestrOther intent_kw UNUSED,
- ffesttDimList dims UNUSED)
-{
- ffestc_check_attrib_ ();
-
- switch (attrib)
+ if (ffe_is_f2c_library ()
+ && (ffe_case_source () == FFE_caseNONE))
{
-#if FFESTR_F90
- case FFESTP_attribALLOCATABLE:
- break;
-#endif
-
- case FFESTP_attribDIMENSION:
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- break;
-
- case FFESTP_attribEXTERNAL:
- break;
+ ffebad_start (FFEBAD_NAMELIST_CASE);
+ ffesta_ffebad_here_current_stmt (0);
+ ffebad_finish ();
+ }
-#if FFESTR_F90
- case FFESTP_attribINTENT:
- break;
-#endif
+ ffestd_R542_start ();
- case FFESTP_attribINTRINSIC:
- break;
+ ffestc_local_.namelist.symbol = NULL;
-#if FFESTR_F90
- case FFESTP_attribOPTIONAL:
- break;
-#endif
+ ffestc_ok_ = TRUE;
+}
- case FFESTP_attribPARAMETER:
- break;
+/* ffestc_R542_item_nlist -- NAMELIST statement for group-name
-#if FFESTR_F90
- case FFESTP_attribPOINTER:
- break;
-#endif
+ ffestc_R542_item_nlist(groupname_token);
-#if FFESTR_F90
- case FFESTP_attribPRIVATE:
- break;
+ Make sure name_token identifies a valid object to be NAMELISTd. */
- case FFESTP_attribPUBLIC:
- break;
-#endif
+void
+ffestc_R542_item_nlist (ffelexToken name)
+{
+ ffesymbol s;
- case FFESTP_attribSAVE:
- switch (ffestv_save_state_)
- {
- case FFESTV_savestateNONE:
- ffestv_save_state_ = FFESTV_savestateSPECIFIC;
- ffestv_save_line_
- = ffewhere_line_use (ffelex_token_where_line (attribt));
- ffestv_save_col_
- = ffewhere_column_use (ffelex_token_where_column (attribt));
- break;
+ ffestc_check_item_ ();
+ assert (name != NULL);
+ if (!ffestc_ok_)
+ return;
- case FFESTV_savestateSPECIFIC:
- case FFESTV_savestateANY:
- break;
+ if (ffestc_local_.namelist.symbol != NULL)
+ ffesymbol_signal_unreported (ffestc_local_.namelist.symbol);
- case FFESTV_savestateALL:
- if (ffe_is_pedantic ())
- {
- ffebad_start (FFEBAD_CONFLICTING_SAVES);
- ffebad_here (0, ffestv_save_line_, ffestv_save_col_);
- ffebad_here (1, ffelex_token_where_line (attribt),
- ffelex_token_where_column (attribt));
- ffebad_finish ();
- }
- ffestv_save_state_ = FFESTV_savestateANY;
- break;
+ s = ffesymbol_declare_local (name, FALSE);
- default:
- assert ("unexpected save state" == NULL);
- break;
+ if ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
+ || ((ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
+ && (ffesymbol_kind (s) == FFEINFO_kindNAMELIST)))
+ {
+ ffestc_parent_ok_ = TRUE;
+ if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
+ {
+ ffebld_init_list (ffesymbol_ptr_to_namelist (s),
+ ffesymbol_ptr_to_listbottom (s));
+ ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
+ ffesymbol_set_info (s,
+ ffeinfo_new (FFEINFO_basictypeNONE,
+ FFEINFO_kindtypeNONE,
+ 0,
+ FFEINFO_kindNAMELIST,
+ FFEINFO_whereLOCAL,
+ FFETARGET_charactersizeNONE));
}
- break;
+ }
+ else
+ {
+ if (ffesymbol_kind (s) != FFEINFO_kindANY)
+ ffesymbol_error (s, name);
+ ffestc_parent_ok_ = FALSE;
+ }
-#if FFESTR_F90
- case FFESTP_attribTARGET:
- break;
-#endif
+ ffestc_local_.namelist.symbol = s;
- default:
- assert ("unexpected attribute" == NULL);
- break;
- }
+ ffestd_R542_item_nlist (name);
}
-/* ffestc_R501_item -- declared object
+/* ffestc_R542_item_nitem -- NAMELIST statement for variable-name
- ffestc_R501_item(...);
+ ffestc_R542_item_nitem(name_token);
- Establish type for a particular object. */
+ Make sure name_token identifies a valid object to be NAMELISTd. */
void
-ffestc_R501_item (ffelexToken name, ffebld kind, ffelexToken kindt,
- ffesttDimList dims, ffebld len, ffelexToken lent,
- ffebld init, ffelexToken initt, bool clist)
+ffestc_R542_item_nitem (ffelexToken name)
{
ffesymbol s;
- ffesymbol sfn; /* FUNCTION symbol. */
- ffebld array_size;
- ffebld extents;
ffesymbolAttrs sa;
ffesymbolAttrs na;
- ffestpDimtype nd;
- bool is_init = (init != NULL) || clist;
- bool is_assumed;
- bool is_ugly_assumed;
- ffeinfoRank rank;
+ ffebld e;
ffestc_check_item_ ();
assert (name != NULL);
- assert (ffelex_token_type (name) == FFELEX_typeNAME); /* Not NAMES. */
- assert (kind == NULL); /* No way an expression should get here. */
+ if (!ffestc_ok_)
+ return;
- ffestc_establish_declinfo_ (kind, kindt, len, lent);
+ s = ffesymbol_declare_local (name, FALSE);
+ sa = ffesymbol_attrs (s);
- is_assumed = (ffestc_local_.decl.basic_type == FFEINFO_basictypeCHARACTER)
- && (ffestc_local_.decl.size == FFETARGET_charactersizeNONE);
+ /* Figure out what kind of object we've got based on previous declarations
+ of or references to the object. */
- if ((dims != NULL) || is_init)
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
+ if (!ffesymbol_is_specable (s)
+ && ((ffesymbol_kind (s) != FFEINFO_kindENTITY)
+ || ((ffesymbol_where (s) != FFEINFO_whereLOCAL)
+ && (ffesymbol_where (s) != FFEINFO_whereCOMMON))))
+ na = FFESYMBOL_attrsetNONE;
+ else if (sa & FFESYMBOL_attrsANY)
+ na = FFESYMBOL_attrsANY;
+ else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
+ | FFESYMBOL_attrsARRAY
+ | FFESYMBOL_attrsCOMMON
+ | FFESYMBOL_attrsEQUIV
+ | FFESYMBOL_attrsINIT
+ | FFESYMBOL_attrsNAMELIST
+ | FFESYMBOL_attrsSAVE
+ | FFESYMBOL_attrsSFARG
+ | FFESYMBOL_attrsTYPE)))
+ na = sa | FFESYMBOL_attrsNAMELIST;
+ else
+ na = FFESYMBOL_attrsetNONE;
- s = ffesymbol_declare_local (name, TRUE);
- sa = ffesymbol_attrs (s);
+ /* Now see what we've got for a new object: NONE means a new error cropped
+ up; ANY means an old error to be ignored; otherwise, everything's ok,
+ update the object (symbol) and continue on. */
- /* First figure out what kind of object this is based solely on the current
- object situation (type params, dimension list, and initialization). */
+ if (na == FFESYMBOL_attrsetNONE)
+ ffesymbol_error (s, name);
+ else if (!(na & FFESYMBOL_attrsANY))
+ {
+ ffesymbol_set_attrs (s, na);
+ if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
+ ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
+ ffesymbol_set_namelisted (s, TRUE);
+ ffesymbol_signal_unreported (s);
+#if 0 /* No need to establish type yet! */
+ if (!ffeimplic_establish_symbol (s))
+ ffesymbol_error (s, name);
+#endif
+ }
- na = FFESYMBOL_attrsTYPE;
+ if (ffestc_parent_ok_)
+ {
+ e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
+ FFEINTRIN_impNONE);
+ ffebld_set_info (e,
+ ffeinfo_new (FFEINFO_basictypeNONE,
+ FFEINFO_kindtypeNONE, 0,
+ FFEINFO_kindNONE,
+ FFEINFO_whereNONE,
+ FFETARGET_charactersizeNONE));
+ ffebld_append_item
+ (ffesymbol_ptr_to_listbottom (ffestc_local_.namelist.symbol), e);
+ }
- if (is_assumed)
- na |= FFESYMBOL_attrsANYLEN;
+ ffestd_R542_item_nitem (name);
+}
- is_ugly_assumed = (ffe_is_ugly_assumed ()
- && ((sa & FFESYMBOL_attrsDUMMY)
- || (ffesymbol_where (s) == FFEINFO_whereDUMMY)));
+/* ffestc_R542_finish -- NAMELIST statement list complete
- nd = ffestt_dimlist_type (dims, is_ugly_assumed);
- switch (nd)
- {
- case FFESTP_dimtypeNONE:
- break;
+ ffestc_R542_finish();
- case FFESTP_dimtypeKNOWN:
- na |= FFESYMBOL_attrsARRAY;
- break;
+ Just wrap up any local activities. */
- case FFESTP_dimtypeADJUSTABLE:
- na |= FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE;
- break;
+void
+ffestc_R542_finish ()
+{
+ ffestc_check_finish_ ();
+ if (!ffestc_ok_)
+ return;
- case FFESTP_dimtypeASSUMED:
- na |= FFESYMBOL_attrsARRAY | FFESYMBOL_attrsANYSIZE;
- break;
+ ffesymbol_signal_unreported (ffestc_local_.namelist.symbol);
- case FFESTP_dimtypeADJUSTABLEASSUMED:
- na |= FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE
- | FFESYMBOL_attrsANYSIZE;
- break;
+ ffestd_R542_finish ();
+}
- default:
- assert ("unexpected dimtype" == NULL);
- na = FFESYMBOL_attrsetNONE;
- break;
- }
+/* ffestc_R544_start -- EQUIVALENCE statement list begin
- if (!ffesta_is_entry_valid
- && (((na & (FFESYMBOL_attrsANYLEN | FFESYMBOL_attrsARRAY))
- == (FFESYMBOL_attrsANYLEN | FFESYMBOL_attrsARRAY))))
- na = FFESYMBOL_attrsetNONE;
+ ffestc_R544_start();
- if (is_init)
- {
- if (na == FFESYMBOL_attrsetNONE)
- ;
- else if (na & (FFESYMBOL_attrsANYLEN
- | FFESYMBOL_attrsADJUSTABLE
- | FFESYMBOL_attrsANYSIZE))
- na = FFESYMBOL_attrsetNONE;
- else
- na |= FFESYMBOL_attrsINIT;
- }
-
- /* Now figure out what kind of object we've got based on previous
- declarations of or references to the object. */
-
- if (na == FFESYMBOL_attrsetNONE)
- ;
- else if (!ffesymbol_is_specable (s)
- && (((ffesymbol_where (s) != FFEINFO_whereCONSTANT)
- && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))
- || (na & (FFESYMBOL_attrsARRAY | FFESYMBOL_attrsINIT))))
- na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef, and can't
- dimension/init UNDERSTOODs. */
- else if (sa & FFESYMBOL_attrsANY)
- na = sa;
- else if ((sa & na)
- || ((sa & (FFESYMBOL_attrsSFARG
- | FFESYMBOL_attrsADJUSTS))
- && (na & (FFESYMBOL_attrsARRAY
- | FFESYMBOL_attrsANYLEN)))
- || ((sa & FFESYMBOL_attrsRESULT)
- && (na & (FFESYMBOL_attrsARRAY
- | FFESYMBOL_attrsINIT)))
- || ((sa & (FFESYMBOL_attrsSFUNC
- | FFESYMBOL_attrsEXTERNAL
- | FFESYMBOL_attrsINTRINSIC
- | FFESYMBOL_attrsINIT))
- && (na & (FFESYMBOL_attrsARRAY
- | FFESYMBOL_attrsANYLEN
- | FFESYMBOL_attrsINIT)))
- || ((sa & FFESYMBOL_attrsARRAY)
- && !ffesta_is_entry_valid
- && (na & FFESYMBOL_attrsANYLEN))
- || ((sa & (FFESYMBOL_attrsADJUSTABLE
- | FFESYMBOL_attrsANYLEN
- | FFESYMBOL_attrsANYSIZE
- | FFESYMBOL_attrsDUMMY))
- && (na & FFESYMBOL_attrsINIT))
- || ((sa & (FFESYMBOL_attrsSAVE
- | FFESYMBOL_attrsNAMELIST
- | FFESYMBOL_attrsCOMMON
- | FFESYMBOL_attrsEQUIV))
- && (na & (FFESYMBOL_attrsADJUSTABLE
- | FFESYMBOL_attrsANYLEN
- | FFESYMBOL_attrsANYSIZE))))
- na = FFESYMBOL_attrsetNONE;
- else if ((ffesymbol_kind (s) == FFEINFO_kindENTITY)
- && (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
- && (na & FFESYMBOL_attrsANYLEN))
- { /* If CHARACTER*(*) FOO after PARAMETER FOO. */
- na |= FFESYMBOL_attrsTYPE;
- ffestc_local_.decl.size = ffebld_size (ffesymbol_init (s));
- }
- else
- na |= sa;
-
- /* Now see what we've got for a new object: NONE means a new error cropped
- up; ANY means an old error to be ignored; otherwise, everything's ok,
- update the object (symbol) and continue on. */
+ Verify that EQUIVALENCE is valid here, and begin accepting items in the
+ list. */
- if (na == FFESYMBOL_attrsetNONE)
+void
+ffestc_R544_start ()
+{
+ ffestc_check_start_ ();
+ if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
{
- ffesymbol_error (s, name);
- ffestc_parent_ok_ = FALSE;
+ ffestc_ok_ = FALSE;
+ return;
}
- else if (na & FFESYMBOL_attrsANY)
- ffestc_parent_ok_ = FALSE;
- else
- {
- ffesymbol_set_attrs (s, na);
- if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
- ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
- rank = ffesymbol_rank (s);
- if (dims != NULL)
- {
- ffesymbol_set_dims (s, ffestt_dimlist_as_expr (dims, &rank,
- &array_size,
- &extents,
- is_ugly_assumed));
- ffesymbol_set_arraysize (s, array_size);
- ffesymbol_set_extents (s, extents);
- if (!(0 && ffe_is_90 ())
- && (ffebld_op (array_size) == FFEBLD_opCONTER)
- && (ffebld_constant_integerdefault (ffebld_conter (array_size))
- == 0))
- {
- ffebad_start (FFEBAD_ZERO_ARRAY);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_finish ();
- }
- }
- if (init != NULL)
- {
- ffesymbol_set_init (s,
- ffeexpr_convert (init, initt, name,
- ffestc_local_.decl.basic_type,
- ffestc_local_.decl.kind_type,
- rank,
- ffestc_local_.decl.size,
- FFEEXPR_contextDATA));
- ffecom_notify_init_symbol (s);
- ffesymbol_update_init (s);
-#if FFEGLOBAL_ENABLED
- if (ffesymbol_common (s) != NULL)
- ffeglobal_init_common (ffesymbol_common (s), initt);
-#endif
- }
- else if (clist)
- {
- ffebld symter;
-
- symter = ffebld_new_symter (s, FFEINTRIN_genNONE,
- FFEINTRIN_specNONE,
- FFEINTRIN_impNONE);
-
- ffebld_set_info (symter,
- ffeinfo_new (ffestc_local_.decl.basic_type,
- ffestc_local_.decl.kind_type,
- rank,
- FFEINFO_kindNONE,
- FFEINFO_whereNONE,
- ffestc_local_.decl.size));
- ffestc_local_.decl.initlist = ffebld_new_item (symter, NULL);
- }
- if (ffesymbol_basictype (s) == FFEINFO_basictypeNONE)
- {
- ffesymbol_set_info (s,
- ffeinfo_new (ffestc_local_.decl.basic_type,
- ffestc_local_.decl.kind_type,
- rank,
- ffesymbol_kind (s),
- ffesymbol_where (s),
- ffestc_local_.decl.size));
- if ((na & FFESYMBOL_attrsRESULT)
- && ((sfn = ffesymbol_funcresult (s)) != NULL))
- {
- ffesymbol_set_info (sfn,
- ffeinfo_new (ffestc_local_.decl.basic_type,
- ffestc_local_.decl.kind_type,
- rank,
- ffesymbol_kind (sfn),
- ffesymbol_where (sfn),
- ffestc_local_.decl.size));
- ffesymbol_signal_unreported (sfn);
- }
- }
- else if ((ffestc_local_.decl.basic_type != ffesymbol_basictype (s))
- || (ffestc_local_.decl.kind_type != ffesymbol_kindtype (s))
- || ((ffestc_local_.decl.basic_type
- == FFEINFO_basictypeCHARACTER)
- && (ffestc_local_.decl.size != ffesymbol_size (s))))
- { /* Explicit type disagrees with established
- implicit type. */
- ffesymbol_error (s, name);
- }
+ ffestc_labeldef_useless_ ();
- if ((na & FFESYMBOL_attrsADJUSTS)
- && ((ffestc_local_.decl.basic_type != FFEINFO_basictypeINTEGER)
- || (ffestc_local_.decl.kind_type != FFEINFO_kindtypeINTEGER1)))
- ffesymbol_error (s, name);
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- ffesymbol_signal_unreported (s);
- ffestc_parent_ok_ = TRUE;
- }
+ ffestc_ok_ = TRUE;
}
-/* ffestc_R501_itemstartvals -- Start list of values
+/* ffestc_R544_item -- EQUIVALENCE statement assignment
- ffestc_R501_itemstartvals();
+ ffestc_R544_item(exprlist);
- Gonna specify values for the object now. */
+ Make sure the equivalence is valid, then implement it. */
void
-ffestc_R501_itemstartvals ()
+ffestc_R544_item (ffesttExprList exprlist)
{
- ffestc_check_item_startvals_ ();
-
- if (ffestc_parent_ok_)
- ffedata_begin (ffestc_local_.decl.initlist);
-}
-
-/* ffestc_R501_itemvalue -- Source value
+ ffestc_check_item_ ();
+ if (!ffestc_ok_)
+ return;
- ffestc_R501_itemvalue(repeat,repeat_token,value,value_token);
+ /* First we go through the list and come up with one ffeequiv object that
+ will describe all items in the list. When an ffeequiv object is first
+ found, it is used (else we create one as a "local equiv" for the time
+ being). If subsequent ffeequiv objects are found, they are merged with
+ the first so we end up with one. However, if more than one COMMON
+ variable is involved, then an error condition occurs. */
- Make sure repeat and value are valid for the object being initialized. */
+ ffestc_local_.equiv.ok = TRUE;
+ ffestc_local_.equiv.t = NULL; /* No token yet. */
+ ffestc_local_.equiv.eq = NULL;/* No equiv yet. */
+ ffestc_local_.equiv.save = FALSE; /* No SAVEd variables yet. */
-void
-ffestc_R501_itemvalue (ffebld repeat, ffelexToken repeat_token,
- ffebld value, ffelexToken value_token)
-{
- ffetargetIntegerDefault rpt;
+ ffebld_init_list (&ffestc_local_.equiv.list, &ffestc_local_.equiv.bottom);
+ ffestt_exprlist_drive (exprlist, ffestc_R544_equiv_); /* Get one equiv. */
+ ffebld_end_list (&ffestc_local_.equiv.bottom);
- ffestc_check_item_value_ ();
+ if (!ffestc_local_.equiv.ok)
+ return; /* Something went wrong, stop bothering with
+ this stuff. */
- if (!ffestc_parent_ok_)
- return;
+ if (ffestc_local_.equiv.eq == NULL)
+ ffestc_local_.equiv.eq = ffeequiv_new (); /* Make local equivalence. */
- if (repeat == NULL)
- rpt = 1;
- else if (ffebld_op (repeat) == FFEBLD_opCONTER)
- rpt = ffebld_constant_integerdefault (ffebld_conter (repeat));
- else
- {
- ffestc_parent_ok_ = FALSE;
- ffedata_end (TRUE, NULL);
- return;
- }
+ /* Append this list of equivalences to list of such lists for this
+ equivalence. */
- if (!(ffestc_parent_ok_ = ffedata_value (rpt, value,
- (repeat_token == NULL) ? value_token : repeat_token)))
- ffedata_end (TRUE, NULL);
+ ffeequiv_add (ffestc_local_.equiv.eq, ffestc_local_.equiv.list,
+ ffestc_local_.equiv.t);
+ if (ffestc_local_.equiv.save)
+ ffeequiv_update_save (ffestc_local_.equiv.eq);
}
-/* ffestc_R501_itemendvals -- End list of values
+/* ffestc_R544_equiv_ -- EQUIVALENCE statement handler for item in list
- ffelexToken t; // the SLASH token that ends the list.
- ffestc_R501_itemendvals(t);
+ ffebld expr;
+ ffelexToken t;
+ ffestc_R544_equiv_(expr,t);
- No more values, might specify more objects now. */
+ Record information, if any, on symbol in expr; if symbol has equivalence
+ object already, merge with outstanding object if present or make it
+ the outstanding object. */
-void
-ffestc_R501_itemendvals (ffelexToken t)
+static void
+ffestc_R544_equiv_ (ffebld expr, ffelexToken t)
{
- ffestc_check_item_endvals_ ();
-
- if (ffestc_parent_ok_)
- ffestc_parent_ok_ = ffedata_end (FALSE, t);
-
- if (ffestc_parent_ok_)
- ffesymbol_signal_unreported (ffebld_symter (ffebld_head
- (ffestc_local_.decl.initlist)));
-}
-
-/* ffestc_R501_finish -- Done
-
- ffestc_R501_finish();
-
- Just wrap up any local activities. */
+ ffesymbol s;
-void
-ffestc_R501_finish ()
-{
- ffestc_check_finish_ ();
-}
+ if (!ffestc_local_.equiv.ok)
+ return;
-/* ffestc_R519_start -- INTENT statement list begin
+ if (ffestc_local_.equiv.t == NULL)
+ ffestc_local_.equiv.t = t;
- ffestc_R519_start();
+ switch (ffebld_op (expr))
+ {
+ case FFEBLD_opANY:
+ return; /* Don't put this on the list. */
- Verify that INTENT is valid here, and begin accepting items in the list. */
+ case FFEBLD_opSYMTER:
+ case FFEBLD_opARRAYREF:
+ case FFEBLD_opSUBSTR:
+ break; /* All of these are ok. */
-#if FFESTR_F90
-void
-ffestc_R519_start (ffelexToken intent, ffestrOther intent_kw)
-{
- ffestc_check_start_ ();
- if (ffestc_order_spec_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
+ default:
+ assert ("ffestc_R544_equiv_ bad op" == NULL);
return;
}
- ffestc_labeldef_useless_ ();
-
- ffestd_R519_start (intent_kw);
-
- ffestc_ok_ = TRUE;
-}
-/* ffestc_R519_item -- INTENT statement for name
+ ffebld_append_item (&ffestc_local_.equiv.bottom, expr);
- ffestc_R519_item(name_token);
+ s = ffeequiv_symbol (expr);
- Make sure name_token identifies a valid object to be INTENTed. */
+ /* See if symbol has an equivalence object already. */
-void
-ffestc_R519_item (ffelexToken name)
-{
- ffestc_check_item_ ();
- assert (name != NULL);
- if (!ffestc_ok_)
- return;
+ if (ffesymbol_equiv (s) != NULL)
+ {
+ if (ffestc_local_.equiv.eq == NULL)
+ ffestc_local_.equiv.eq = ffesymbol_equiv (s); /* New equiv obj. */
+ else if (ffestc_local_.equiv.eq != ffesymbol_equiv (s))
+ {
+ ffestc_local_.equiv.eq = ffeequiv_merge (ffesymbol_equiv (s),
+ ffestc_local_.equiv.eq,
+ t);
+ if (ffestc_local_.equiv.eq == NULL)
+ ffestc_local_.equiv.ok = FALSE; /* Couldn't merge. */
+ }
+ }
- ffestd_R519_item (name);
+ if (ffesymbol_is_save (s))
+ ffestc_local_.equiv.save = TRUE;
}
-/* ffestc_R519_finish -- INTENT statement list complete
+/* ffestc_R544_finish -- EQUIVALENCE statement list complete
- ffestc_R519_finish();
+ ffestc_R544_finish();
Just wrap up any local activities. */
void
-ffestc_R519_finish ()
+ffestc_R544_finish ()
{
ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_R519_finish ();
}
-/* ffestc_R520_start -- OPTIONAL statement list begin
+/* ffestc_R547_start -- COMMON statement list begin
- ffestc_R520_start();
+ ffestc_R547_start();
- Verify that OPTIONAL is valid here, and begin accepting items in the list. */
+ Verify that COMMON is valid here, and begin accepting items in the list. */
void
-ffestc_R520_start ()
+ffestc_R547_start ()
{
ffestc_check_start_ ();
- if (ffestc_order_spec_ () != FFESTC_orderOK_)
+ if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
{
ffestc_ok_ = FALSE;
return;
}
ffestc_labeldef_useless_ ();
- ffestd_R520_start ();
+ ffestc_local_.common.symbol = NULL; /* Blank common is the default. */
+ ffestc_parent_ok_ = TRUE;
+
+ ffestd_R547_start ();
ffestc_ok_ = TRUE;
}
-/* ffestc_R520_item -- OPTIONAL statement for name
+/* ffestc_R547_item_object -- COMMON statement for object-name
- ffestc_R520_item(name_token);
+ ffestc_R547_item_object(name_token,dim_list);
- Make sure name_token identifies a valid object to be OPTIONALed. */
+ Make sure name_token identifies a valid object to be COMMONd. */
void
-ffestc_R520_item (ffelexToken name)
+ffestc_R547_item_object (ffelexToken name, ffesttDimList dims)
{
- ffestc_check_item_ ();
- assert (name != NULL);
- if (!ffestc_ok_)
- return;
-
- ffestd_R520_item (name);
-}
-
-/* ffestc_R520_finish -- OPTIONAL statement list complete
-
- ffestc_R520_finish();
+ ffesymbol s;
+ ffebld array_size;
+ ffebld extents;
+ ffesymbolAttrs sa;
+ ffesymbolAttrs na;
+ ffestpDimtype nd;
+ ffebld e;
+ ffeinfoRank rank;
+ bool is_ugly_assumed;
- Just wrap up any local activities. */
+ if (ffestc_parent_ok_ && (ffestc_local_.common.symbol == NULL))
+ ffestc_R547_item_cblock (NULL); /* As if "COMMON [//] ...". */
-void
-ffestc_R520_finish ()
-{
- ffestc_check_finish_ ();
+ ffestc_check_item_ ();
+ assert (name != NULL);
if (!ffestc_ok_)
return;
- ffestd_R520_finish ();
-}
-
-/* ffestc_R521A -- PUBLIC statement
+ if (dims != NULL)
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- ffestc_R521A();
+ s = ffesymbol_declare_local (name, FALSE);
+ sa = ffesymbol_attrs (s);
- Verify that PUBLIC is valid here. */
+ /* First figure out what kind of object this is based solely on the current
+ object situation (dimension list). */
-void
-ffestc_R521A ()
-{
- ffestc_check_simple_ ();
- if (ffestc_order_access_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
+ is_ugly_assumed = (ffe_is_ugly_assumed ()
+ && ((sa & FFESYMBOL_attrsDUMMY)
+ || (ffesymbol_where (s) == FFEINFO_whereDUMMY)));
- switch (ffestv_access_state_)
+ nd = ffestt_dimlist_type (dims, is_ugly_assumed);
+ switch (nd)
{
- case FFESTV_accessstateNONE:
- ffestv_access_state_ = FFESTV_accessstatePUBLIC;
- ffestv_access_line_
- = ffewhere_line_use (ffelex_token_where_line (ffesta_tokens[0]));
- ffestv_access_col_
- = ffewhere_column_use (ffelex_token_where_column (ffesta_tokens[0]));
- break;
-
- case FFESTV_accessstateANY:
+ case FFESTP_dimtypeNONE:
+ na = FFESYMBOL_attrsCOMMON;
break;
- case FFESTV_accessstatePUBLIC:
- case FFESTV_accessstatePRIVATE:
- ffebad_start (FFEBAD_CONFLICTING_ACCESSES);
- ffebad_here (0, ffestv_access_line_, ffestv_access_col_);
- ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_finish ();
- ffestv_access_state_ = FFESTV_accessstateANY;
+ case FFESTP_dimtypeKNOWN:
+ na = FFESYMBOL_attrsCOMMON | FFESYMBOL_attrsARRAY;
break;
default:
- assert ("unexpected access state" == NULL);
+ na = FFESYMBOL_attrsetNONE;
break;
}
- ffestd_R521A ();
-}
-
-/* ffestc_R521Astart -- PUBLIC statement list begin
-
- ffestc_R521Astart();
-
- Verify that PUBLIC is valid here, and begin accepting items in the list. */
-
-void
-ffestc_R521Astart ()
-{
- ffestc_check_start_ ();
- if (ffestc_order_access_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_useless_ ();
-
- ffestd_R521Astart ();
-
- ffestc_ok_ = TRUE;
-}
-
-/* ffestc_R521Aitem -- PUBLIC statement for name
-
- ffestc_R521Aitem(name_token);
-
- Make sure name_token identifies a valid object to be PUBLICed. */
-
-void
-ffestc_R521Aitem (ffelexToken name)
-{
- ffestc_check_item_ ();
- assert (name != NULL);
- if (!ffestc_ok_)
- return;
-
- ffestd_R521Aitem (name);
-}
-
-/* ffestc_R521Afinish -- PUBLIC statement list complete
-
- ffestc_R521Afinish();
-
- Just wrap up any local activities. */
-
-void
-ffestc_R521Afinish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_R521Afinish ();
-}
-
-/* ffestc_R521B -- PRIVATE statement
-
- ffestc_R521B();
+ /* Figure out what kind of object we've got based on previous declarations
+ of or references to the object. */
- Verify that PRIVATE is valid here (outside a derived-type statement). */
+ if (na == FFESYMBOL_attrsetNONE)
+ ;
+ else if (!ffesymbol_is_specable (s))
+ na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
+ else if (sa & FFESYMBOL_attrsANY)
+ na = FFESYMBOL_attrsANY;
+ else if ((sa & (FFESYMBOL_attrsADJUSTS
+ | FFESYMBOL_attrsARRAY
+ | FFESYMBOL_attrsINIT
+ | FFESYMBOL_attrsSFARG))
+ && (na & FFESYMBOL_attrsARRAY))
+ na = FFESYMBOL_attrsetNONE;
+ else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
+ | FFESYMBOL_attrsARRAY
+ | FFESYMBOL_attrsEQUIV
+ | FFESYMBOL_attrsINIT
+ | FFESYMBOL_attrsNAMELIST
+ | FFESYMBOL_attrsSFARG
+ | FFESYMBOL_attrsTYPE)))
+ na |= sa;
+ else
+ na = FFESYMBOL_attrsetNONE;
-void
-ffestc_R521B ()
-{
- ffestc_check_simple_ ();
- if (ffestc_order_access_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
+ /* Now see what we've got for a new object: NONE means a new error cropped
+ up; ANY means an old error to be ignored; otherwise, everything's ok,
+ update the object (symbol) and continue on. */
- switch (ffestv_access_state_)
+ if (na == FFESYMBOL_attrsetNONE)
+ ffesymbol_error (s, name);
+ else if ((ffesymbol_equiv (s) != NULL)
+ && (ffeequiv_common (ffesymbol_equiv (s)) != NULL)
+ && (ffeequiv_common (ffesymbol_equiv (s))
+ != ffestc_local_.common.symbol))
{
- case FFESTV_accessstateNONE:
- ffestv_access_state_ = FFESTV_accessstatePRIVATE;
- ffestv_access_line_
- = ffewhere_line_use (ffelex_token_where_line (ffesta_tokens[0]));
- ffestv_access_col_
- = ffewhere_column_use (ffelex_token_where_column (ffesta_tokens[0]));
- break;
-
- case FFESTV_accessstateANY:
- break;
-
- case FFESTV_accessstatePUBLIC:
- case FFESTV_accessstatePRIVATE:
- ffebad_start (FFEBAD_CONFLICTING_ACCESSES);
- ffebad_here (0, ffestv_access_line_, ffestv_access_col_);
- ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
+ /* Oops, just COMMONed a symbol to a different area (via equiv). */
+ ffebad_start (FFEBAD_EQUIV_COMMON);
+ ffebad_here (0, ffelex_token_where_line (name),
+ ffelex_token_where_column (name));
+ ffebad_string (ffesymbol_text (ffestc_local_.common.symbol));
+ ffebad_string (ffesymbol_text (ffeequiv_common (ffesymbol_equiv (s))));
ffebad_finish ();
- ffestv_access_state_ = FFESTV_accessstateANY;
- break;
-
- default:
- assert ("unexpected access state" == NULL);
- break;
+ ffesymbol_set_attr (s, na | FFESYMBOL_attrANY);
+ ffesymbol_set_info (s, ffeinfo_new_any ());
+ ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
+ ffesymbol_signal_unreported (s);
}
-
- ffestd_R521B ();
-}
-
-/* ffestc_R521Bstart -- PRIVATE statement list begin
-
- ffestc_R521Bstart();
-
- Verify that PRIVATE is valid here, and begin accepting items in the list. */
-
-void
-ffestc_R521Bstart ()
-{
- ffestc_check_start_ ();
- if (ffestc_order_access_ () != FFESTC_orderOK_)
+ else if (!(na & FFESYMBOL_attrsANY))
{
- ffestc_ok_ = FALSE;
- return;
+ ffesymbol_set_attrs (s, na);
+ ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
+ ffesymbol_set_common (s, ffestc_local_.common.symbol);
+#if FFEGLOBAL_ENABLED
+ if (ffesymbol_is_init (s))
+ ffeglobal_init_common (ffestc_local_.common.symbol, name);
+#endif
+ if (ffesymbol_is_save (ffestc_local_.common.symbol))
+ ffesymbol_update_save (s);
+ if (ffesymbol_equiv (s) != NULL)
+ { /* Is this newly COMMONed symbol involved in
+ an equivalence? */
+ if (ffeequiv_common (ffesymbol_equiv (s)) == NULL)
+ ffeequiv_set_common (ffesymbol_equiv (s), /* Yes, tell equiv obj. */
+ ffestc_local_.common.symbol);
+#if FFEGLOBAL_ENABLED
+ if (ffeequiv_is_init (ffesymbol_equiv (s)))
+ ffeglobal_init_common (ffestc_local_.common.symbol, name);
+#endif
+ if (ffesymbol_is_save (ffestc_local_.common.symbol))
+ ffeequiv_update_save (ffesymbol_equiv (s));
+ }
+ if (dims != NULL)
+ {
+ ffesymbol_set_dims (s, ffestt_dimlist_as_expr (dims, &rank,
+ &array_size,
+ &extents,
+ is_ugly_assumed));
+ ffesymbol_set_arraysize (s, array_size);
+ ffesymbol_set_extents (s, extents);
+ if (!(0 && ffe_is_90 ())
+ && (ffebld_op (array_size) == FFEBLD_opCONTER)
+ && (ffebld_constant_integerdefault (ffebld_conter (array_size))
+ == 0))
+ {
+ ffebad_start (FFEBAD_ZERO_ARRAY);
+ ffebad_here (0, ffelex_token_where_line (name),
+ ffelex_token_where_column (name));
+ ffebad_finish ();
+ }
+ ffesymbol_set_info (s,
+ ffeinfo_new (ffesymbol_basictype (s),
+ ffesymbol_kindtype (s),
+ rank,
+ ffesymbol_kind (s),
+ ffesymbol_where (s),
+ ffesymbol_size (s)));
+ }
+ ffesymbol_signal_unreported (s);
}
- ffestc_labeldef_useless_ ();
- ffestd_R521Bstart ();
+ if (ffestc_parent_ok_)
+ {
+ e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
+ FFEINTRIN_impNONE);
+ ffebld_set_info (e,
+ ffeinfo_new (FFEINFO_basictypeNONE,
+ FFEINFO_kindtypeNONE,
+ 0,
+ FFEINFO_kindNONE,
+ FFEINFO_whereNONE,
+ FFETARGET_charactersizeNONE));
+ ffebld_append_item
+ (ffesymbol_ptr_to_listbottom (ffestc_local_.common.symbol), e);
+ }
- ffestc_ok_ = TRUE;
+ ffestd_R547_item_object (name, dims);
}
-/* ffestc_R521Bitem -- PRIVATE statement for name
+/* ffestc_R547_item_cblock -- COMMON statement for common-block-name
- ffestc_R521Bitem(name_token);
+ ffestc_R547_item_cblock(name_token);
- Make sure name_token identifies a valid object to be PRIVATEed. */
+ Make sure name_token identifies a valid common block to be COMMONd. */
void
-ffestc_R521Bitem (ffelexToken name)
+ffestc_R547_item_cblock (ffelexToken name)
{
+ ffesymbol s;
+ ffesymbolAttrs sa;
+ ffesymbolAttrs na;
+
ffestc_check_item_ ();
- assert (name != NULL);
if (!ffestc_ok_)
return;
- ffestd_R521Bitem (name);
+ if (ffestc_local_.common.symbol != NULL)
+ ffesymbol_signal_unreported (ffestc_local_.common.symbol);
+
+ s = ffesymbol_declare_cblock (name,
+ ffelex_token_where_line (ffesta_tokens[0]),
+ ffelex_token_where_column (ffesta_tokens[0]));
+ sa = ffesymbol_attrs (s);
+
+ /* Figure out what kind of object we've got based on previous declarations
+ of or references to the object. */
+
+ if (!ffesymbol_is_specable (s))
+ na = FFESYMBOL_attrsetNONE;
+ else if (sa & FFESYMBOL_attrsANY)
+ na = FFESYMBOL_attrsANY; /* Already have an error here, say nothing. */
+ else if (!(sa & ~(FFESYMBOL_attrsCBLOCK
+ | FFESYMBOL_attrsSAVECBLOCK)))
+ {
+ if (!(sa & FFESYMBOL_attrsCBLOCK))
+ ffebld_init_list (ffesymbol_ptr_to_commonlist (s),
+ ffesymbol_ptr_to_listbottom (s));
+ na = sa | FFESYMBOL_attrsCBLOCK;
+ }
+ else
+ na = FFESYMBOL_attrsetNONE;
+
+ /* Now see what we've got for a new object: NONE means a new error cropped
+ up; ANY means an old error to be ignored; otherwise, everything's ok,
+ update the object (symbol) and continue on. */
+
+ if (na == FFESYMBOL_attrsetNONE)
+ {
+ ffesymbol_error (s, name == NULL ? ffesta_tokens[0] : name);
+ ffestc_parent_ok_ = FALSE;
+ }
+ else if (na & FFESYMBOL_attrsANY)
+ ffestc_parent_ok_ = FALSE;
+ else
+ {
+ ffesymbol_set_attrs (s, na);
+ ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
+ if (name == NULL)
+ ffesymbol_update_save (s);
+ ffestc_parent_ok_ = TRUE;
+ }
+
+ ffestc_local_.common.symbol = s;
+
+ ffestd_R547_item_cblock (name);
}
-/* ffestc_R521Bfinish -- PRIVATE statement list complete
+/* ffestc_R547_finish -- COMMON statement list complete
- ffestc_R521Bfinish();
+ ffestc_R547_finish();
Just wrap up any local activities. */
void
-ffestc_R521Bfinish ()
+ffestc_R547_finish ()
{
ffestc_check_finish_ ();
if (!ffestc_ok_)
return;
- ffestd_R521Bfinish ();
+ if (ffestc_local_.common.symbol != NULL)
+ ffesymbol_signal_unreported (ffestc_local_.common.symbol);
+
+ ffestd_R547_finish ();
}
-#endif
-/* ffestc_R522 -- SAVE statement with no list
+/* ffestc_R737 -- Assignment statement
- ffestc_R522();
+ ffestc_R737(dest_expr,source_expr,source_token);
- Verify that SAVE is valid here, and flag everything as SAVEd. */
+ Make sure the assignment is valid. */
void
-ffestc_R522 ()
+ffestc_R737 (ffebld dest, ffebld source, ffelexToken source_token)
{
ffestc_check_simple_ ();
- if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
+
+ if (ffestc_order_actionwhere_ () != FFESTC_orderOK_)
return;
- ffestc_labeldef_useless_ ();
+ ffestc_labeldef_branch_begin_ ();
- switch (ffestv_save_state_)
+ source = ffeexpr_convert_expr (source, source_token, dest, ffesta_tokens[0],
+ FFEEXPR_contextLET);
+
+ ffestd_R737A (dest, source);
+
+ if (ffestc_shriek_after1_ != NULL)
+ (*ffestc_shriek_after1_) (TRUE);
+ ffestc_labeldef_branch_end_ ();
+}
+
+/* ffestc_R803 -- Block IF (IF-THEN) statement
+
+ ffestc_R803(construct_name,expr,expr_token);
+
+ Make sure statement is valid here; implement. */
+
+void
+ffestc_R803 (ffelexToken construct_name, ffebld expr,
+ ffelexToken expr_token UNUSED)
+{
+ ffestw b;
+ ffesymbol s;
+
+ ffestc_check_simple_ ();
+ if (ffestc_order_exec_ () != FFESTC_orderOK_)
+ return;
+ ffestc_labeldef_notloop_ ();
+
+ b = ffestw_update (ffestw_push (NULL));
+ ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b)));
+ ffestw_set_state (b, FFESTV_stateIFTHEN);
+ ffestw_set_blocknum (b, ffestc_blocknum_++);
+ ffestw_set_shriek (b, ffestc_shriek_ifthen_);
+ ffestw_set_substate (b, 0); /* Haven't seen ELSE yet. */
+
+ if (construct_name == NULL)
+ ffestw_set_name (b, NULL);
+ else
{
- case FFESTV_savestateNONE:
- ffestv_save_state_ = FFESTV_savestateALL;
- ffestv_save_line_
- = ffewhere_line_use (ffelex_token_where_line (ffesta_tokens[0]));
- ffestv_save_col_
- = ffewhere_column_use (ffelex_token_where_column (ffesta_tokens[0]));
- break;
+ ffestw_set_name (b, ffelex_token_use (construct_name));
- case FFESTV_savestateANY:
- break;
+ s = ffesymbol_declare_local (construct_name, FALSE);
- case FFESTV_savestateSPECIFIC:
- case FFESTV_savestateALL:
- if (ffe_is_pedantic ())
+ if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
{
- ffebad_start (FFEBAD_CONFLICTING_SAVES);
- ffebad_here (0, ffestv_save_line_, ffestv_save_col_);
- ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_finish ();
+ ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
+ ffesymbol_set_info (s,
+ ffeinfo_new (FFEINFO_basictypeNONE,
+ FFEINFO_kindtypeNONE,
+ 0,
+ FFEINFO_kindCONSTRUCT,
+ FFEINFO_whereLOCAL,
+ FFETARGET_charactersizeNONE));
+ s = ffecom_sym_learned (s);
+ ffesymbol_signal_unreported (s);
}
- ffestv_save_state_ = FFESTV_savestateALL;
- break;
-
- default:
- assert ("unexpected save state" == NULL);
- break;
+ else
+ ffesymbol_error (s, construct_name);
}
- ffe_set_is_saveall (TRUE);
-
- ffestd_R522 ();
+ ffestd_R803 (construct_name, expr);
}
-/* ffestc_R522start -- SAVE statement list begin
+/* ffestc_R804 -- ELSE IF statement
- ffestc_R522start();
+ ffestc_R804(expr,expr_token,name_token);
- Verify that SAVE is valid here, and begin accepting items in the list. */
+ Make sure ffestc_kind_ identifies an IF block. If not
+ NULL, make sure name_token gives the correct name. Implement the else
+ of the IF block. */
void
-ffestc_R522start ()
+ffestc_R804 (ffebld expr, ffelexToken expr_token UNUSED,
+ ffelexToken name)
{
- ffestc_check_start_ ();
- if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
+ ffestc_check_simple_ ();
+ if (ffestc_order_ifthen_ () != FFESTC_orderOK_)
+ return;
ffestc_labeldef_useless_ ();
- switch (ffestv_save_state_)
+ if (name != NULL)
{
- case FFESTV_savestateNONE:
- ffestv_save_state_ = FFESTV_savestateSPECIFIC;
- ffestv_save_line_
- = ffewhere_line_use (ffelex_token_where_line (ffesta_tokens[0]));
- ffestv_save_col_
- = ffewhere_column_use (ffelex_token_where_column (ffesta_tokens[0]));
- break;
-
- case FFESTV_savestateSPECIFIC:
- case FFESTV_savestateANY:
- break;
-
- case FFESTV_savestateALL:
- if (ffe_is_pedantic ())
+ if (ffestw_name (ffestw_stack_top ()) == NULL)
{
- ffebad_start (FFEBAD_CONFLICTING_SAVES);
- ffebad_here (0, ffestv_save_line_, ffestv_save_col_);
- ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
+ ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
+ ffebad_here (0, ffelex_token_where_line (name),
+ ffelex_token_where_column (name));
+ ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
+ ffebad_finish ();
+ }
+ else if (ffelex_token_strcmp (name,
+ ffestw_name (ffestw_stack_top ()))
+ != 0)
+ {
+ ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
+ ffebad_here (0, ffelex_token_where_line (name),
+ ffelex_token_where_column (name));
+ ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
+ ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
ffebad_finish ();
}
- ffestv_save_state_ = FFESTV_savestateANY;
- break;
-
- default:
- assert ("unexpected save state" == NULL);
- break;
}
- ffestd_R522start ();
+ if (ffestw_substate (ffestw_stack_top ()) != 0)
+ {
+ ffebad_start (FFEBAD_AFTER_ELSE);
+ ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
+ ffelex_token_where_column (ffesta_tokens[0]));
+ ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
+ ffebad_finish ();
+ return; /* Don't upset back end with ELSEIF
+ after ELSE. */
+ }
- ffestc_ok_ = TRUE;
+ ffestd_R804 (expr, name);
}
-/* ffestc_R522item_object -- SAVE statement for object-name
+/* ffestc_R805 -- ELSE statement
- ffestc_R522item_object(name_token);
+ ffestc_R805(name_token);
- Make sure name_token identifies a valid object to be SAVEd. */
+ Make sure ffestc_kind_ identifies an IF block. If not
+ NULL, make sure name_token gives the correct name. Implement the ELSE
+ of the IF block. */
void
-ffestc_R522item_object (ffelexToken name)
+ffestc_R805 (ffelexToken name)
{
- ffesymbol s;
- ffesymbolAttrs sa;
- ffesymbolAttrs na;
-
- ffestc_check_item_ ();
- assert (name != NULL);
- if (!ffestc_ok_)
+ ffestc_check_simple_ ();
+ if (ffestc_order_ifthen_ () != FFESTC_orderOK_)
return;
+ ffestc_labeldef_useless_ ();
- s = ffesymbol_declare_local (name, FALSE);
- sa = ffesymbol_attrs (s);
-
- /* Figure out what kind of object we've got based on previous declarations
- of or references to the object. */
-
- if (!ffesymbol_is_specable (s)
- && ((ffesymbol_kind (s) != FFEINFO_kindENTITY)
- || (ffesymbol_where (s) != FFEINFO_whereLOCAL)))
- na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
- else if (sa & FFESYMBOL_attrsANY)
- na = sa;
- else if (!(sa & ~(FFESYMBOL_attrsARRAY
- | FFESYMBOL_attrsEQUIV
- | FFESYMBOL_attrsINIT
- | FFESYMBOL_attrsNAMELIST
- | FFESYMBOL_attrsSFARG
- | FFESYMBOL_attrsTYPE)))
- na = sa | FFESYMBOL_attrsSAVE;
- else
- na = FFESYMBOL_attrsetNONE;
-
- /* Now see what we've got for a new object: NONE means a new error cropped
- up; ANY means an old error to be ignored; otherwise, everything's ok,
- update the object (symbol) and continue on. */
+ if (name != NULL)
+ {
+ if (ffestw_name (ffestw_stack_top ()) == NULL)
+ {
+ ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
+ ffebad_here (0, ffelex_token_where_line (name),
+ ffelex_token_where_column (name));
+ ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
+ ffebad_finish ();
+ }
+ else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)
+ {
+ ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
+ ffebad_here (0, ffelex_token_where_line (name),
+ ffelex_token_where_column (name));
+ ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
+ ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
+ ffebad_finish ();
+ }
+ }
- if (na == FFESYMBOL_attrsetNONE)
- ffesymbol_error (s, name);
- else if (!(na & FFESYMBOL_attrsANY))
+ if (ffestw_substate (ffestw_stack_top ()) != 0)
{
- ffesymbol_set_attrs (s, na);
- if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
- ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
- ffesymbol_update_save (s);
- ffesymbol_signal_unreported (s);
+ ffebad_start (FFEBAD_AFTER_ELSE);
+ ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
+ ffelex_token_where_column (ffesta_tokens[0]));
+ ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
+ ffebad_finish ();
+ return; /* Tell back end about only one ELSE. */
}
- ffestd_R522item_object (name);
+ ffestw_set_substate (ffestw_stack_top (), 1); /* Saw ELSE. */
+
+ ffestd_R805 (name);
}
-/* ffestc_R522item_cblock -- SAVE statement for common-block-name
+/* ffestc_R806 -- END IF statement
- ffestc_R522item_cblock(name_token);
+ ffestc_R806(name_token);
- Make sure name_token identifies a valid common block to be SAVEd. */
+ Make sure ffestc_kind_ identifies an IF block. If not
+ NULL, make sure name_token gives the correct name. Implement the end
+ of the IF block. */
void
-ffestc_R522item_cblock (ffelexToken name)
+ffestc_R806 (ffelexToken name)
{
- ffesymbol s;
- ffesymbolAttrs sa;
- ffesymbolAttrs na;
-
- ffestc_check_item_ ();
- assert (name != NULL);
- if (!ffestc_ok_)
+ ffestc_check_simple_ ();
+ if (ffestc_order_ifthen_ () != FFESTC_orderOK_)
return;
+ ffestc_labeldef_endif_ ();
- s = ffesymbol_declare_cblock (name, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- sa = ffesymbol_attrs (s);
-
- /* Figure out what kind of object we've got based on previous declarations
- of or references to the object. */
-
- if (!ffesymbol_is_specable (s))
- na = FFESYMBOL_attrsetNONE;
- else if (sa & FFESYMBOL_attrsANY)
- na = sa; /* Already have an error here, say nothing. */
- else if (!(sa & ~(FFESYMBOL_attrsCBLOCK)))
- na = sa | FFESYMBOL_attrsSAVECBLOCK;
+ if (name == NULL)
+ {
+ if (ffestw_name (ffestw_stack_top ()) != NULL)
+ {
+ ffebad_start (FFEBAD_CONSTRUCT_NAMED);
+ ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
+ ffelex_token_where_column (ffesta_tokens[0]));
+ ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
+ ffebad_finish ();
+ }
+ }
else
- na = FFESYMBOL_attrsetNONE;
-
- /* Now see what we've got for a new object: NONE means a new error cropped
- up; ANY means an old error to be ignored; otherwise, everything's ok,
- update the object (symbol) and continue on. */
-
- if (na == FFESYMBOL_attrsetNONE)
- ffesymbol_error (s, (name == NULL) ? ffesta_tokens[0] : name);
- else if (!(na & FFESYMBOL_attrsANY))
{
- ffesymbol_set_attrs (s, na);
- ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
- ffesymbol_update_save (s);
- ffesymbol_signal_unreported (s);
+ if (ffestw_name (ffestw_stack_top ()) == NULL)
+ {
+ ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
+ ffebad_here (0, ffelex_token_where_line (name),
+ ffelex_token_where_column (name));
+ ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
+ ffebad_finish ();
+ }
+ else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)
+ {
+ ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
+ ffebad_here (0, ffelex_token_where_line (name),
+ ffelex_token_where_column (name));
+ ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
+ ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
+ ffebad_finish ();
+ }
}
- ffestd_R522item_cblock (name);
+ ffestc_shriek_ifthen_ (TRUE);
}
-/* ffestc_R522finish -- SAVE statement list complete
+/* ffestc_R807 -- Logical IF statement
- ffestc_R522finish();
+ ffestc_R807(expr,expr_token);
- Just wrap up any local activities. */
+ Make sure statement is valid here; implement. */
void
-ffestc_R522finish ()
+ffestc_R807 (ffebld expr, ffelexToken expr_token UNUSED)
{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_R522finish ();
-}
-
-/* ffestc_R524_start -- DIMENSION statement list begin
+ ffestw b;
- ffestc_R524_start(bool virtual);
+ ffestc_check_simple_ ();
+ if (ffestc_order_action_ () != FFESTC_orderOK_)
+ return;
+ ffestc_labeldef_branch_begin_ ();
- Verify that DIMENSION is valid here, and begin accepting items in the
- list. */
+ b = ffestw_update (ffestw_push (NULL));
+ ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b)));
+ ffestw_set_state (b, FFESTV_stateIF);
+ ffestw_set_blocknum (b, ffestc_blocknum_++);
+ ffestw_set_shriek (b, ffestc_shriek_if_lost_);
-void
-ffestc_R524_start (bool virtual)
-{
- ffestc_check_start_ ();
- if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_useless_ ();
+ ffestd_R807 (expr);
- ffestd_R524_start (virtual);
+ /* Do the label finishing in the next statement. */
- ffestc_ok_ = TRUE;
}
-/* ffestc_R524_item -- DIMENSION statement for object-name
+/* ffestc_R809 -- SELECT CASE statement
- ffestc_R524_item(name_token,dim_list);
+ ffestc_R809(construct_name,expr,expr_token);
- Make sure name_token identifies a valid object to be DIMENSIONd. */
+ Make sure statement is valid here; implement. */
void
-ffestc_R524_item (ffelexToken name, ffesttDimList dims)
+ffestc_R809 (ffelexToken construct_name, ffebld expr, ffelexToken expr_token)
{
- ffesymbol s;
- ffebld array_size;
- ffebld extents;
- ffesymbolAttrs sa;
- ffesymbolAttrs na;
- ffestpDimtype nd;
- ffeinfoRank rank;
- bool is_ugly_assumed;
+ ffestw b;
+ mallocPool pool;
+ ffestwSelect s;
+ ffesymbol sym;
- ffestc_check_item_ ();
- assert (name != NULL);
- assert (dims != NULL);
- if (!ffestc_ok_)
+ ffestc_check_simple_ ();
+ if (ffestc_order_exec_ () != FFESTC_orderOK_)
return;
+ ffestc_labeldef_notloop_ ();
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
-
- s = ffesymbol_declare_local (name, FALSE);
- sa = ffesymbol_attrs (s);
-
- /* First figure out what kind of object this is based solely on the current
- object situation (dimension list). */
-
- is_ugly_assumed = (ffe_is_ugly_assumed ()
- && ((sa & FFESYMBOL_attrsDUMMY)
- || (ffesymbol_where (s) == FFEINFO_whereDUMMY)));
-
- nd = ffestt_dimlist_type (dims, is_ugly_assumed);
- switch (nd)
- {
- case FFESTP_dimtypeKNOWN:
- na = FFESYMBOL_attrsARRAY;
- break;
-
- case FFESTP_dimtypeADJUSTABLE:
- na = FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE;
- break;
-
- case FFESTP_dimtypeASSUMED:
- na = FFESYMBOL_attrsARRAY | FFESYMBOL_attrsANYSIZE;
- break;
-
- case FFESTP_dimtypeADJUSTABLEASSUMED:
- na = FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE
- | FFESYMBOL_attrsANYSIZE;
- break;
+ b = ffestw_update (ffestw_push (NULL));
+ ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b)));
+ ffestw_set_state (b, FFESTV_stateSELECT0);
+ ffestw_set_blocknum (b, ffestc_blocknum_++);
+ ffestw_set_shriek (b, ffestc_shriek_select_);
+ ffestw_set_substate (b, 0); /* Haven't seen CASE DEFAULT yet. */
- default:
- assert ("Unexpected dims type" == NULL);
- na = FFESYMBOL_attrsetNONE;
- break;
- }
+ /* Init block to manage CASE list. */
- /* Now figure out what kind of object we've got based on previous
- declarations of or references to the object. */
+ pool = malloc_pool_new ("Select", ffe_pool_any_unit (), 1024);
+ s = (ffestwSelect) malloc_new_kp (pool, "Select", sizeof (*s));
+ s->first_rel = (ffestwCase) &s->first_rel;
+ s->last_rel = (ffestwCase) &s->first_rel;
+ s->first_stmt = (ffestwCase) &s->first_rel;
+ s->last_stmt = (ffestwCase) &s->first_rel;
+ s->pool = pool;
+ s->cases = 1;
+ s->t = ffelex_token_use (expr_token);
+ s->type = ffeinfo_basictype (ffebld_info (expr));
+ s->kindtype = ffeinfo_kindtype (ffebld_info (expr));
+ ffestw_set_select (b, s);
- if (!ffesymbol_is_specable (s))
- na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
- else if (sa & FFESYMBOL_attrsANY)
- na = FFESYMBOL_attrsANY;
- else if (!ffesta_is_entry_valid
- && (sa & FFESYMBOL_attrsANYLEN))
- na = FFESYMBOL_attrsetNONE;
- else if ((sa & FFESYMBOL_attrsARRAY)
- || ((sa & (FFESYMBOL_attrsCOMMON
- | FFESYMBOL_attrsEQUIV
- | FFESYMBOL_attrsNAMELIST
- | FFESYMBOL_attrsSAVE))
- && (na & (FFESYMBOL_attrsADJUSTABLE
- | FFESYMBOL_attrsANYSIZE))))
- na = FFESYMBOL_attrsetNONE;
- else if (!(sa & ~(FFESYMBOL_attrsADJUSTABLE
- | FFESYMBOL_attrsANYLEN
- | FFESYMBOL_attrsANYSIZE
- | FFESYMBOL_attrsCOMMON
- | FFESYMBOL_attrsDUMMY
- | FFESYMBOL_attrsEQUIV
- | FFESYMBOL_attrsNAMELIST
- | FFESYMBOL_attrsSAVE
- | FFESYMBOL_attrsTYPE)))
- na |= sa;
+ if (construct_name == NULL)
+ ffestw_set_name (b, NULL);
else
- na = FFESYMBOL_attrsetNONE;
+ {
+ ffestw_set_name (b, ffelex_token_use (construct_name));
- /* Now see what we've got for a new object: NONE means a new error cropped
- up; ANY means an old error to be ignored; otherwise, everything's ok,
- update the object (symbol) and continue on. */
+ sym = ffesymbol_declare_local (construct_name, FALSE);
- if (na == FFESYMBOL_attrsetNONE)
- ffesymbol_error (s, name);
- else if (!(na & FFESYMBOL_attrsANY))
- {
- ffesymbol_set_attrs (s, na);
- ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
- ffesymbol_set_dims (s, ffestt_dimlist_as_expr (dims, &rank,
- &array_size,
- &extents,
- is_ugly_assumed));
- ffesymbol_set_arraysize (s, array_size);
- ffesymbol_set_extents (s, extents);
- if (!(0 && ffe_is_90 ())
- && (ffebld_op (array_size) == FFEBLD_opCONTER)
- && (ffebld_constant_integerdefault (ffebld_conter (array_size))
- == 0))
+ if (ffesymbol_state (sym) == FFESYMBOL_stateNONE)
{
- ffebad_start (FFEBAD_ZERO_ARRAY);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_finish ();
+ ffesymbol_set_state (sym, FFESYMBOL_stateUNDERSTOOD);
+ ffesymbol_set_info (sym,
+ ffeinfo_new (FFEINFO_basictypeNONE,
+ FFEINFO_kindtypeNONE, 0,
+ FFEINFO_kindCONSTRUCT,
+ FFEINFO_whereLOCAL,
+ FFETARGET_charactersizeNONE));
+ sym = ffecom_sym_learned (sym);
+ ffesymbol_signal_unreported (sym);
}
- ffesymbol_set_info (s,
- ffeinfo_new (ffesymbol_basictype (s),
- ffesymbol_kindtype (s),
- rank,
- ffesymbol_kind (s),
- ffesymbol_where (s),
- ffesymbol_size (s)));
+ else
+ ffesymbol_error (sym, construct_name);
}
- ffesymbol_signal_unreported (s);
-
- ffestd_R524_item (name, dims);
+ ffestd_R809 (construct_name, expr);
}
-/* ffestc_R524_finish -- DIMENSION statement list complete
+/* ffestc_R810 -- CASE statement
- ffestc_R524_finish();
+ ffestc_R810(case_value_range_list,name);
- Just wrap up any local activities. */
+ If case_value_range_list is NULL, it's CASE DEFAULT. name is the case-
+ construct-name. Make sure no more than one CASE DEFAULT is present for
+ a given case-construct and that there aren't any overlapping ranges or
+ duplicate case values. */
void
-ffestc_R524_finish ()
+ffestc_R810 (ffesttCaseList cases, ffelexToken name)
{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_R524_finish ();
-}
-
-/* ffestc_R525_start -- ALLOCATABLE statement list begin
+ ffesttCaseList caseobj;
+ ffestwSelect s;
+ ffestwCase c, nc;
+ ffebldConstant expr1c, expr2c;
- ffestc_R525_start();
+ ffestc_check_simple_ ();
+ if (ffestc_order_selectcase_ () != FFESTC_orderOK_)
+ return;
+ ffestc_labeldef_useless_ ();
- Verify that ALLOCATABLE is valid here, and begin accepting items in the
- list. */
+ s = ffestw_select (ffestw_stack_top ());
-#if FFESTR_F90
-void
-ffestc_R525_start ()
-{
- ffestc_check_start_ ();
- if (ffestc_order_progspec_ () != FFESTC_orderOK_)
+ if (ffestw_state (ffestw_stack_top ()) == FFESTV_stateSELECT0)
{
- ffestc_ok_ = FALSE;
- return;
+#if 0 /* Not sure we want to have msgs point here
+ instead of SELECT CASE. */
+ ffestw_update (NULL); /* Update state line/col info. */
+#endif
+ ffestw_set_state (ffestw_stack_top (), FFESTV_stateSELECT1);
}
- ffestc_labeldef_useless_ ();
-
- ffestd_R525_start ();
-
- ffestc_ok_ = TRUE;
-}
-
-/* ffestc_R525_item -- ALLOCATABLE statement for object-name
-
- ffestc_R525_item(name_token,dim_list);
-
- Make sure name_token identifies a valid object to be ALLOCATABLEd. */
-
-void
-ffestc_R525_item (ffelexToken name, ffesttDimList dims)
-{
- ffestc_check_item_ ();
- assert (name != NULL);
- if (!ffestc_ok_)
- return;
-
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
-
- ffestd_R525_item (name, dims);
-}
-
-/* ffestc_R525_finish -- ALLOCATABLE statement list complete
-
- ffestc_R525_finish();
-
- Just wrap up any local activities. */
-
-void
-ffestc_R525_finish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
- ffestd_R525_finish ();
-}
-
-/* ffestc_R526_start -- POINTER statement list begin
-
- ffestc_R526_start();
-
- Verify that POINTER is valid here, and begin accepting items in the
- list. */
-
-void
-ffestc_R526_start ()
-{
- ffestc_check_start_ ();
- if (ffestc_order_progspec_ () != FFESTC_orderOK_)
+ if (name != NULL)
{
- ffestc_ok_ = FALSE;
- return;
+ if (ffestw_name (ffestw_stack_top ()) == NULL)
+ {
+ ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
+ ffebad_here (0, ffelex_token_where_line (name),
+ ffelex_token_where_column (name));
+ ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
+ ffebad_finish ();
+ }
+ else if (ffelex_token_strcmp (name,
+ ffestw_name (ffestw_stack_top ()))
+ != 0)
+ {
+ ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
+ ffebad_here (0, ffelex_token_where_line (name),
+ ffelex_token_where_column (name));
+ ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
+ ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
+ ffebad_finish ();
+ }
}
- ffestc_labeldef_useless_ ();
-
- ffestd_R526_start ();
-
- ffestc_ok_ = TRUE;
-}
-
-/* ffestc_R526_item -- POINTER statement for object-name
-
- ffestc_R526_item(name_token,dim_list);
-
- Make sure name_token identifies a valid object to be POINTERd. */
-
-void
-ffestc_R526_item (ffelexToken name, ffesttDimList dims)
-{
- ffestc_check_item_ ();
- assert (name != NULL);
- if (!ffestc_ok_)
- return;
-
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- ffestd_R526_item (name, dims);
-}
+ if (cases == NULL)
+ {
+ if (ffestw_substate (ffestw_stack_top ()) != 0)
+ {
+ ffebad_start (FFEBAD_CASE_SECOND_DEFAULT);
+ ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
+ ffelex_token_where_column (ffesta_tokens[0]));
+ ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
+ ffebad_finish ();
+ }
-/* ffestc_R526_finish -- POINTER statement list complete
+ ffestw_set_substate (ffestw_stack_top (), 1); /* Saw ELSE. */
+ }
+ else
+ { /* For each case, try to fit into sorted list
+ of ranges. */
+ for (caseobj = cases->next; caseobj != cases; caseobj = caseobj->next)
+ {
+ if ((caseobj->expr1 == NULL)
+ && (!caseobj->range
+ || (caseobj->expr2 == NULL)))
+ { /* "CASE (:)". */
+ ffebad_start (FFEBAD_CASE_BAD_RANGE);
+ ffebad_here (0, ffelex_token_where_line (caseobj->t),
+ ffelex_token_where_column (caseobj->t));
+ ffebad_finish ();
+ continue;
+ }
+ if (((caseobj->expr1 != NULL)
+ && ((ffeinfo_basictype (ffebld_info (caseobj->expr1))
+ != s->type)
+ || ((ffeinfo_kindtype (ffebld_info (caseobj->expr1))
+ != s->kindtype)
+ && (ffeinfo_kindtype (ffebld_info (caseobj->expr1)) != FFEINFO_kindtypeINTEGER1 ))
+ || ((caseobj->range)
+ && (caseobj->expr2 != NULL)
+ && ((ffeinfo_basictype (ffebld_info (caseobj->expr2))
+ != s->type)
+ || ((ffeinfo_kindtype (ffebld_info (caseobj->expr2))
+ != s->kindtype)
+ && (ffeinfo_kindtype (ffebld_info (caseobj->expr2)) != FFEINFO_kindtypeINTEGER1)))))))
+ {
+ ffebad_start (FFEBAD_CASE_TYPE_DISAGREE);
+ ffebad_here (0, ffelex_token_where_line (caseobj->t),
+ ffelex_token_where_column (caseobj->t));
+ ffebad_here (1, ffelex_token_where_line (s->t),
+ ffelex_token_where_column (s->t));
+ ffebad_finish ();
+ continue;
+ }
- ffestc_R526_finish();
- Just wrap up any local activities. */
-void
-ffestc_R526_finish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
+ if ((s->type == FFEINFO_basictypeLOGICAL) && (caseobj->range))
+ {
+ ffebad_start (FFEBAD_CASE_LOGICAL_RANGE);
+ ffebad_here (0, ffelex_token_where_line (caseobj->t),
+ ffelex_token_where_column (caseobj->t));
+ ffebad_finish ();
+ continue;
+ }
- ffestd_R526_finish ();
-}
+ if (caseobj->expr1 == NULL)
+ expr1c = NULL;
+ else if (ffebld_op (caseobj->expr1) != FFEBLD_opCONTER)
+ continue; /* opANY. */
+ else
+ expr1c = ffebld_conter (caseobj->expr1);
-/* ffestc_R527_start -- TARGET statement list begin
+ if (!caseobj->range)
+ expr2c = expr1c; /* expr1c and expr2c are NOT NULL in this
+ case. */
+ else if (caseobj->expr2 == NULL)
+ expr2c = NULL;
+ else if (ffebld_op (caseobj->expr2) != FFEBLD_opCONTER)
+ continue; /* opANY. */
+ else
+ expr2c = ffebld_conter (caseobj->expr2);
- ffestc_R527_start();
+ if (expr1c == NULL)
+ { /* "CASE (:high)", must be first in list. */
+ c = s->first_rel;
+ if ((c != (ffestwCase) &s->first_rel)
+ && ((c->low == NULL)
+ || (ffebld_constant_cmp (expr2c, c->low) >= 0)))
+ { /* Other "CASE (:high)" or lowest "CASE
+ (low[:high])" low. */
+ ffebad_start (FFEBAD_CASE_DUPLICATE);
+ ffebad_here (0, ffelex_token_where_line (caseobj->t),
+ ffelex_token_where_column (caseobj->t));
+ ffebad_here (1, ffelex_token_where_line (c->t),
+ ffelex_token_where_column (c->t));
+ ffebad_finish ();
+ continue;
+ }
+ }
+ else if (expr2c == NULL)
+ { /* "CASE (low:)", must be last in list. */
+ c = s->last_rel;
+ if ((c != (ffestwCase) &s->first_rel)
+ && ((c->high == NULL)
+ || (ffebld_constant_cmp (expr1c, c->high) <= 0)))
+ { /* Other "CASE (low:)" or lowest "CASE
+ ([low:]high)" high. */
+ ffebad_start (FFEBAD_CASE_DUPLICATE);
+ ffebad_here (0, ffelex_token_where_line (caseobj->t),
+ ffelex_token_where_column (caseobj->t));
+ ffebad_here (1, ffelex_token_where_line (c->t),
+ ffelex_token_where_column (c->t));
+ ffebad_finish ();
+ continue;
+ }
+ c = c->next_rel; /* Same as c = (ffestwCase) &s->first;. */
+ }
+ else
+ { /* (expr1c != NULL) && (expr2c != NULL). */
+ if (ffebld_constant_cmp (expr1c, expr2c) > 0)
+ { /* Such as "CASE (3:1)" or "CASE ('B':'A')". */
+ ffebad_start (FFEBAD_CASE_RANGE_USELESS); /* Warn/inform only. */
+ ffebad_here (0, ffelex_token_where_line (caseobj->t),
+ ffelex_token_where_column (caseobj->t));
+ ffebad_finish ();
+ continue;
+ }
+ for (c = s->first_rel;
+ (c != (ffestwCase) &s->first_rel)
+ && ((c->low == NULL)
+ || (ffebld_constant_cmp (expr1c, c->low) > 0));
+ c = c->next_rel)
+ ;
+ nc = c; /* Which one to report? */
+ if (((c != (ffestwCase) &s->first_rel)
+ && (ffebld_constant_cmp (expr2c, c->low) >= 0))
+ || (((nc = c->previous_rel) != (ffestwCase) &s->first_rel)
+ && (ffebld_constant_cmp (expr1c, nc->high) <= 0)))
+ { /* Interference with range in case nc. */
+ ffebad_start (FFEBAD_CASE_DUPLICATE);
+ ffebad_here (0, ffelex_token_where_line (caseobj->t),
+ ffelex_token_where_column (caseobj->t));
+ ffebad_here (1, ffelex_token_where_line (nc->t),
+ ffelex_token_where_column (nc->t));
+ ffebad_finish ();
+ continue;
+ }
+ }
- Verify that TARGET is valid here, and begin accepting items in the
- list. */
+ /* If we reach here for this case range/value, it's ok (sorts into
+ the list of ranges/values) so we give it its own case object
+ sorted into the list of case statements. */
-void
-ffestc_R527_start ()
-{
- ffestc_check_start_ ();
- if (ffestc_order_progspec_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
+ nc = malloc_new_kp (s->pool, "Case range", sizeof (*nc));
+ nc->next_rel = c;
+ nc->previous_rel = c->previous_rel;
+ nc->next_stmt = (ffestwCase) &s->first_rel;
+ nc->previous_stmt = s->last_stmt;
+ nc->low = expr1c;
+ nc->high = expr2c;
+ nc->casenum = s->cases;
+ nc->t = ffelex_token_use (caseobj->t);
+ nc->next_rel->previous_rel = nc;
+ nc->previous_rel->next_rel = nc;
+ nc->next_stmt->previous_stmt = nc;
+ nc->previous_stmt->next_stmt = nc;
+ }
}
- ffestc_labeldef_useless_ ();
- ffestd_R527_start ();
+ ffestd_R810 ((cases == NULL) ? 0 : s->cases);
- ffestc_ok_ = TRUE;
+ s->cases++; /* Increment # of cases. */
}
-/* ffestc_R527_item -- TARGET statement for object-name
+/* ffestc_R811 -- END SELECT statement
- ffestc_R527_item(name_token,dim_list);
+ ffestc_R811(name_token);
- Make sure name_token identifies a valid object to be TARGETd. */
+ Make sure ffestc_kind_ identifies a SELECT block. If not
+ NULL, make sure name_token gives the correct name. Implement the end
+ of the SELECT block. */
void
-ffestc_R527_item (ffelexToken name, ffesttDimList dims)
+ffestc_R811 (ffelexToken name)
{
- ffestc_check_item_ ();
- assert (name != NULL);
- if (!ffestc_ok_)
+ ffestc_check_simple_ ();
+ if (ffestc_order_selectcase_ () != FFESTC_orderOK_)
return;
+ ffestc_labeldef_notloop_ ();
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
+ if (name == NULL)
+ {
+ if (ffestw_name (ffestw_stack_top ()) != NULL)
+ {
+ ffebad_start (FFEBAD_CONSTRUCT_NAMED);
+ ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
+ ffelex_token_where_column (ffesta_tokens[0]));
+ ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
+ ffebad_finish ();
+ }
+ }
+ else
+ {
+ if (ffestw_name (ffestw_stack_top ()) == NULL)
+ {
+ ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
+ ffebad_here (0, ffelex_token_where_line (name),
+ ffelex_token_where_column (name));
+ ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
+ ffebad_finish ();
+ }
+ else if (ffelex_token_strcmp (name,
+ ffestw_name (ffestw_stack_top ()))
+ != 0)
+ {
+ ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
+ ffebad_here (0, ffelex_token_where_line (name),
+ ffelex_token_where_column (name));
+ ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
+ ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
+ ffebad_finish ();
+ }
+ }
- ffestd_R527_item (name, dims);
+ ffestc_shriek_select_ (TRUE);
}
-/* ffestc_R527_finish -- TARGET statement list complete
+/* ffestc_R819A -- Iterative labeled DO statement
- ffestc_R527_finish();
+ ffestc_R819A(construct_name,label_token,expr,expr_token);
- Just wrap up any local activities. */
+ Make sure statement is valid here; implement. */
void
-ffestc_R527_finish ()
+ffestc_R819A (ffelexToken construct_name, ffelexToken label_token, ffebld var,
+ ffelexToken var_token, ffebld start, ffelexToken start_token, ffebld end,
+ ffelexToken end_token, ffebld incr, ffelexToken incr_token)
{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
+ ffestw b;
+ ffelab label;
+ ffesymbol s;
+ ffesymbol varsym;
+
+ ffestc_check_simple_ ();
+ if (ffestc_order_exec_ () != FFESTC_orderOK_)
return;
+ ffestc_labeldef_notloop_ ();
- ffestd_R527_finish ();
-}
-
-#endif
-/* ffestc_R528_start -- DATA statement list begin
-
- ffestc_R528_start();
+ if (!ffestc_labelref_is_loopend_ (label_token, &label))
+ return;
- Verify that DATA is valid here, and begin accepting items in the list. */
+ b = ffestw_update (ffestw_push (NULL));
+ ffestw_set_top_do (b, b);
+ ffestw_set_state (b, FFESTV_stateDO);
+ ffestw_set_blocknum (b, ffestc_blocknum_++);
+ ffestw_set_shriek (b, ffestc_shriek_do_);
+ ffestw_set_label (b, label);
+ switch (ffebld_op (var))
+ {
+ case FFEBLD_opSYMTER:
+ if ((ffeinfo_basictype (ffebld_info (var)) == FFEINFO_basictypeREAL)
+ && ffe_is_warn_surprising ())
+ {
+ ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */
+ ffebad_here (0, ffelex_token_where_line (var_token),
+ ffelex_token_where_column (var_token));
+ ffebad_string (ffesymbol_text (ffebld_symter (var)));
+ ffebad_finish ();
+ }
+ if (!ffesymbol_is_doiter (varsym = ffebld_symter (var)))
+ { /* Presumably already complained about by
+ ffeexpr_lhs_. */
+ ffesymbol_set_is_doiter (varsym, TRUE);
+ ffestw_set_do_iter_var (b, varsym);
+ ffestw_set_do_iter_var_t (b, ffelex_token_use (var_token));
+ break;
+ }
+ /* Fall through. */
+ case FFEBLD_opANY:
+ ffestw_set_do_iter_var (b, NULL);
+ ffestw_set_do_iter_var_t (b, NULL);
+ break;
-void
-ffestc_R528_start ()
-{
- ffestcOrder_ order;
+ default:
+ assert ("bad iter var" == NULL);
+ break;
+ }
- ffestc_check_start_ ();
- if (ffe_is_pedantic_not_90 ())
- order = ffestc_order_data77_ ();
+ if (construct_name == NULL)
+ ffestw_set_name (b, NULL);
else
- order = ffestc_order_data_ ();
- if (order != FFESTC_orderOK_)
{
- ffestc_ok_ = FALSE;
- return;
+ ffestw_set_name (b, ffelex_token_use (construct_name));
+
+ s = ffesymbol_declare_local (construct_name, FALSE);
+
+ if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
+ {
+ ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
+ ffesymbol_set_info (s,
+ ffeinfo_new (FFEINFO_basictypeNONE,
+ FFEINFO_kindtypeNONE,
+ 0,
+ FFEINFO_kindCONSTRUCT,
+ FFEINFO_whereLOCAL,
+ FFETARGET_charactersizeNONE));
+ s = ffecom_sym_learned (s);
+ ffesymbol_signal_unreported (s);
+ }
+ else
+ ffesymbol_error (s, construct_name);
}
- ffestc_labeldef_useless_ ();
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
+ if (incr == NULL)
+ {
+ incr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
+ ffebld_set_info (incr, ffeinfo_new
+ (FFEINFO_basictypeINTEGER,
+ FFEINFO_kindtypeINTEGERDEFAULT,
+ 0,
+ FFEINFO_kindENTITY,
+ FFEINFO_whereCONSTANT,
+ FFETARGET_charactersizeNONE));
+ }
-#if 1
- ffestc_local_.data.objlist = NULL;
-#else
- ffestd_R528_start_ ();
-#endif
+ start = ffeexpr_convert_expr (start, start_token, var, var_token,
+ FFEEXPR_contextLET);
+ end = ffeexpr_convert_expr (end, end_token, var, var_token,
+ FFEEXPR_contextLET);
+ incr = ffeexpr_convert_expr (incr, incr_token, var, var_token,
+ FFEEXPR_contextLET);
- ffestc_ok_ = TRUE;
+ ffestd_R819A (construct_name, label, var,
+ start, start_token,
+ end, end_token,
+ incr, incr_token);
}
-/* ffestc_R528_item_object -- DATA statement target object
+/* ffestc_R819B -- Labeled DO WHILE statement
- ffestc_R528_item_object(object,object_token);
+ ffestc_R819B(construct_name,label_token,expr,expr_token);
- Make sure object is valid to be DATAd. */
+ Make sure statement is valid here; implement. */
void
-ffestc_R528_item_object (ffebld expr, ffelexToken expr_token UNUSED)
+ffestc_R819B (ffelexToken construct_name, ffelexToken label_token,
+ ffebld expr, ffelexToken expr_token UNUSED)
{
- ffestc_check_item_ ();
- if (!ffestc_ok_)
- return;
+ ffestw b;
+ ffelab label;
+ ffesymbol s;
-#if 1
- if (ffestc_local_.data.objlist == NULL)
- ffebld_init_list (&ffestc_local_.data.objlist,
- &ffestc_local_.data.list_bottom);
+ ffestc_check_simple_ ();
+ if (ffestc_order_exec_ () != FFESTC_orderOK_)
+ return;
+ ffestc_labeldef_notloop_ ();
- ffebld_append_item (&ffestc_local_.data.list_bottom, expr);
-#else
- ffestd_R528_item_object_ (expr, expr_token);
-#endif
-}
+ if (!ffestc_labelref_is_loopend_ (label_token, &label))
+ return;
-/* ffestc_R528_item_startvals -- DATA statement start list of values
+ b = ffestw_update (ffestw_push (NULL));
+ ffestw_set_top_do (b, b);
+ ffestw_set_state (b, FFESTV_stateDO);
+ ffestw_set_blocknum (b, ffestc_blocknum_++);
+ ffestw_set_shriek (b, ffestc_shriek_do_);
+ ffestw_set_label (b, label);
+ ffestw_set_do_iter_var (b, NULL);
+ ffestw_set_do_iter_var_t (b, NULL);
- ffestc_R528_item_startvals();
+ if (construct_name == NULL)
+ ffestw_set_name (b, NULL);
+ else
+ {
+ ffestw_set_name (b, ffelex_token_use (construct_name));
- No more objects, gonna specify values for the list of objects now. */
+ s = ffesymbol_declare_local (construct_name, FALSE);
-void
-ffestc_R528_item_startvals ()
-{
- ffestc_check_item_startvals_ ();
- if (!ffestc_ok_)
- return;
+ if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
+ {
+ ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
+ ffesymbol_set_info (s,
+ ffeinfo_new (FFEINFO_basictypeNONE,
+ FFEINFO_kindtypeNONE,
+ 0,
+ FFEINFO_kindCONSTRUCT,
+ FFEINFO_whereLOCAL,
+ FFETARGET_charactersizeNONE));
+ s = ffecom_sym_learned (s);
+ ffesymbol_signal_unreported (s);
+ }
+ else
+ ffesymbol_error (s, construct_name);
+ }
-#if 1
- assert (ffestc_local_.data.objlist != NULL);
- ffebld_end_list (&ffestc_local_.data.list_bottom);
- ffedata_begin (ffestc_local_.data.objlist);
-#else
- ffestd_R528_item_startvals_ ();
-#endif
+ ffestd_R819B (construct_name, label, expr);
}
-/* ffestc_R528_item_value -- DATA statement source value
+/* ffestc_R820A -- Iterative nonlabeled DO statement
- ffestc_R528_item_value(repeat,repeat_token,value,value_token);
+ ffestc_R820A(construct_name,expr,expr_token);
- Make sure repeat and value are valid for the objects being initialized. */
+ Make sure statement is valid here; implement. */
void
-ffestc_R528_item_value (ffebld repeat, ffelexToken repeat_token,
- ffebld value, ffelexToken value_token)
+ffestc_R820A (ffelexToken construct_name, ffebld var, ffelexToken var_token,
+ ffebld start, ffelexToken start_token, ffebld end, ffelexToken end_token,
+ ffebld incr, ffelexToken incr_token)
{
- ffetargetIntegerDefault rpt;
+ ffestw b;
+ ffesymbol s;
+ ffesymbol varsym;
- ffestc_check_item_value_ ();
- if (!ffestc_ok_)
+ ffestc_check_simple_ ();
+ if (ffestc_order_exec_ () != FFESTC_orderOK_)
return;
+ ffestc_labeldef_notloop_ ();
-#if 1
- if (repeat == NULL)
- rpt = 1;
- else if (ffebld_op (repeat) == FFEBLD_opCONTER)
- rpt = ffebld_constant_integerdefault (ffebld_conter (repeat));
- else
+ b = ffestw_update (ffestw_push (NULL));
+ ffestw_set_top_do (b, b);
+ ffestw_set_state (b, FFESTV_stateDO);
+ ffestw_set_blocknum (b, ffestc_blocknum_++);
+ ffestw_set_shriek (b, ffestc_shriek_do_);
+ ffestw_set_label (b, NULL);
+ switch (ffebld_op (var))
{
- ffestc_ok_ = FALSE;
- ffedata_end (TRUE, NULL);
- return;
+ case FFEBLD_opSYMTER:
+ if ((ffeinfo_basictype (ffebld_info (var)) == FFEINFO_basictypeREAL)
+ && ffe_is_warn_surprising ())
+ {
+ ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */
+ ffebad_here (0, ffelex_token_where_line (var_token),
+ ffelex_token_where_column (var_token));
+ ffebad_string (ffesymbol_text (ffebld_symter (var)));
+ ffebad_finish ();
+ }
+ if (!ffesymbol_is_doiter (varsym = ffebld_symter (var)))
+ { /* Presumably already complained about by
+ ffeexpr_lhs_. */
+ ffesymbol_set_is_doiter (varsym, TRUE);
+ ffestw_set_do_iter_var (b, varsym);
+ ffestw_set_do_iter_var_t (b, ffelex_token_use (var_token));
+ break;
+ }
+ /* Fall through. */
+ case FFEBLD_opANY:
+ ffestw_set_do_iter_var (b, NULL);
+ ffestw_set_do_iter_var_t (b, NULL);
+ break;
+
+ default:
+ assert ("bad iter var" == NULL);
+ break;
}
- if (!(ffestc_ok_ = ffedata_value (rpt, value,
- (repeat_token == NULL)
- ? value_token
- : repeat_token)))
- ffedata_end (TRUE, NULL);
+ if (construct_name == NULL)
+ ffestw_set_name (b, NULL);
+ else
+ {
+ ffestw_set_name (b, ffelex_token_use (construct_name));
-#else
- ffestd_R528_item_value_ (repeat, value);
-#endif
-}
-
-/* ffestc_R528_item_endvals -- DATA statement start list of values
+ s = ffesymbol_declare_local (construct_name, FALSE);
- ffelexToken t; // the SLASH token that ends the list.
- ffestc_R528_item_endvals(t);
+ if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
+ {
+ ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
+ ffesymbol_set_info (s,
+ ffeinfo_new (FFEINFO_basictypeNONE,
+ FFEINFO_kindtypeNONE,
+ 0,
+ FFEINFO_kindCONSTRUCT,
+ FFEINFO_whereLOCAL,
+ FFETARGET_charactersizeNONE));
+ s = ffecom_sym_learned (s);
+ ffesymbol_signal_unreported (s);
+ }
+ else
+ ffesymbol_error (s, construct_name);
+ }
- No more values, might specify more objects now. */
+ if (incr == NULL)
+ {
+ incr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
+ ffebld_set_info (incr, ffeinfo_new
+ (FFEINFO_basictypeINTEGER,
+ FFEINFO_kindtypeINTEGERDEFAULT,
+ 0,
+ FFEINFO_kindENTITY,
+ FFEINFO_whereCONSTANT,
+ FFETARGET_charactersizeNONE));
+ }
-void
-ffestc_R528_item_endvals (ffelexToken t)
-{
- ffestc_check_item_endvals_ ();
- if (!ffestc_ok_)
- return;
+ start = ffeexpr_convert_expr (start, start_token, var, var_token,
+ FFEEXPR_contextLET);
+ end = ffeexpr_convert_expr (end, end_token, var, var_token,
+ FFEEXPR_contextLET);
+ incr = ffeexpr_convert_expr (incr, incr_token, var, var_token,
+ FFEEXPR_contextLET);
-#if 1
- ffedata_end (!ffestc_ok_, t);
- ffestc_local_.data.objlist = NULL;
-#else
- ffestd_R528_item_endvals_ (t);
+#if 0
+ if ((ffebld_op (incr) == FFEBLD_opCONTER)
+ && (ffebld_constant_is_zero (ffebld_conter (incr))))
+ {
+ ffebad_start (FFEBAD_DO_STEP_ZERO);
+ ffebad_here (0, ffelex_token_where_line (incr_token),
+ ffelex_token_where_column (incr_token));
+ ffebad_string ("Iterative DO loop");
+ ffebad_finish ();
+ }
#endif
+
+ ffestd_R819A (construct_name, NULL, var,
+ start, start_token,
+ end, end_token,
+ incr, incr_token);
}
-/* ffestc_R528_finish -- DATA statement list complete
+/* ffestc_R820B -- Nonlabeled DO WHILE statement
- ffestc_R528_finish();
+ ffestc_R820B(construct_name,expr,expr_token);
- Just wrap up any local activities. */
+ Make sure statement is valid here; implement. */
void
-ffestc_R528_finish ()
+ffestc_R820B (ffelexToken construct_name, ffebld expr,
+ ffelexToken expr_token UNUSED)
{
- ffestc_check_finish_ ();
-
-#if 1
-#else
- ffestd_R528_finish_ ();
-#endif
-}
-
-/* ffestc_R537_start -- PARAMETER statement list begin
+ ffestw b;
+ ffesymbol s;
- ffestc_R537_start();
+ ffestc_check_simple_ ();
+ if (ffestc_order_exec_ () != FFESTC_orderOK_)
+ return;
+ ffestc_labeldef_notloop_ ();
- Verify that PARAMETER is valid here, and begin accepting items in the
- list. */
+ b = ffestw_update (ffestw_push (NULL));
+ ffestw_set_top_do (b, b);
+ ffestw_set_state (b, FFESTV_stateDO);
+ ffestw_set_blocknum (b, ffestc_blocknum_++);
+ ffestw_set_shriek (b, ffestc_shriek_do_);
+ ffestw_set_label (b, NULL);
+ ffestw_set_do_iter_var (b, NULL);
+ ffestw_set_do_iter_var_t (b, NULL);
-void
-ffestc_R537_start ()
-{
- ffestc_check_start_ ();
- if (ffestc_order_parameter_ () != FFESTC_orderOK_)
+ if (construct_name == NULL)
+ ffestw_set_name (b, NULL);
+ else
{
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_useless_ ();
+ ffestw_set_name (b, ffelex_token_use (construct_name));
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
+ s = ffesymbol_declare_local (construct_name, FALSE);
- ffestd_R537_start ();
+ if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
+ {
+ ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
+ ffesymbol_set_info (s,
+ ffeinfo_new (FFEINFO_basictypeNONE,
+ FFEINFO_kindtypeNONE,
+ 0,
+ FFEINFO_kindCONSTRUCT,
+ FFEINFO_whereLOCAL,
+ FFETARGET_charactersizeNONE));
+ s = ffecom_sym_learned (s);
+ ffesymbol_signal_unreported (s);
+ }
+ else
+ ffesymbol_error (s, construct_name);
+ }
- ffestc_ok_ = TRUE;
+ ffestd_R819B (construct_name, NULL, expr);
}
-/* ffestc_R537_item -- PARAMETER statement assignment
+/* ffestc_R825 -- END DO statement
- ffestc_R537_item(dest,dest_token,source,source_token);
+ ffestc_R825(name_token);
- Make sure the source is a valid source for the destination; make the
- assignment. */
+ Make sure ffestc_kind_ identifies a DO block. If not
+ NULL, make sure name_token gives the correct name. Implement the end
+ of the DO block. */
void
-ffestc_R537_item (ffebld dest, ffelexToken dest_token, ffebld source,
- ffelexToken source_token)
+ffestc_R825 (ffelexToken name)
{
- ffesymbol s;
-
- ffestc_check_item_ ();
- if (!ffestc_ok_)
+ ffestc_check_simple_ ();
+ if (ffestc_order_do_ () != FFESTC_orderOK_)
return;
+ ffestc_labeldef_branch_begin_ ();
- if ((ffebld_op (dest) == FFEBLD_opANY)
- || (ffebld_op (source) == FFEBLD_opANY))
+ if (name == NULL)
{
- if (ffebld_op (dest) == FFEBLD_opSYMTER)
+ if (ffestw_name (ffestw_stack_top ()) != NULL)
{
- s = ffebld_symter (dest);
- ffesymbol_set_init (s, ffebld_new_any ());
- ffebld_set_info (ffesymbol_init (s), ffeinfo_new_any ());
- ffesymbol_signal_unreported (s);
+ ffebad_start (FFEBAD_CONSTRUCT_NAMED);
+ ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
+ ffelex_token_where_column (ffesta_tokens[0]));
+ ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
+ ffebad_finish ();
}
- ffestd_R537_item (dest, source);
- return;
}
-
- assert (ffebld_op (dest) == FFEBLD_opSYMTER);
- assert (ffebld_op (source) == FFEBLD_opCONTER);
-
- s = ffebld_symter (dest);
- if ((ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
- && (ffesymbol_size (s) == FFETARGET_charactersizeNONE))
- { /* Destination has explicit/implicit
- CHARACTER*(*) type; set length. */
- ffesymbol_set_info (s,
- ffeinfo_new (ffesymbol_basictype (s),
- ffesymbol_kindtype (s),
- 0,
- ffesymbol_kind (s),
- ffesymbol_where (s),
- ffebld_size (source)));
- ffebld_set_info (dest, ffeinfo_use (ffesymbol_info (s)));
+ else
+ {
+ if (ffestw_name (ffestw_stack_top ()) == NULL)
+ {
+ ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
+ ffebad_here (0, ffelex_token_where_line (name),
+ ffelex_token_where_column (name));
+ ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
+ ffebad_finish ();
+ }
+ else if (ffelex_token_strcmp (name,
+ ffestw_name (ffestw_stack_top ()))
+ != 0)
+ {
+ ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
+ ffebad_here (0, ffelex_token_where_line (name),
+ ffelex_token_where_column (name));
+ ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
+ ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
+ ffebad_finish ();
+ }
}
- source = ffeexpr_convert_expr (source, source_token, dest, dest_token,
- FFEEXPR_contextDATA);
-
- ffesymbol_set_init (s, source);
-
- ffesymbol_signal_unreported (s);
-
- ffestd_R537_item (dest, source);
-}
+ if (ffesta_label_token == NULL)
+ { /* If top of stack has label, its an error! */
+ if (ffestw_label (ffestw_stack_top ()) != NULL)
+ {
+ ffebad_start (FFEBAD_DO_HAD_LABEL);
+ ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
+ ffelex_token_where_column (ffesta_tokens[0]));
+ ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
+ ffebad_finish ();
+ }
-/* ffestc_R537_finish -- PARAMETER statement list complete
+ ffestc_shriek_do_ (TRUE);
- ffestc_R537_finish();
+ ffestc_try_shriek_do_ ();
- Just wrap up any local activities. */
+ return;
+ }
-void
-ffestc_R537_finish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
+ ffestd_R825 (name);
- ffestd_R537_finish ();
+ ffestc_labeldef_branch_end_ ();
}
-/* ffestc_R539 -- IMPLICIT NONE statement
+/* ffestc_R834 -- CYCLE statement
- ffestc_R539();
+ ffestc_R834(name_token);
- Verify that the IMPLICIT NONE statement is ok here and implement. */
+ Handle a CYCLE within a loop. */
void
-ffestc_R539 ()
+ffestc_R834 (ffelexToken name)
{
+ ffestw block;
+
ffestc_check_simple_ ();
- if (ffestc_order_implicitnone_ () != FFESTC_orderOK_)
+ if (ffestc_order_actiondo_ () != FFESTC_orderOK_)
return;
- ffestc_labeldef_useless_ ();
-
- ffeimplic_none ();
-
- ffestd_R539 ();
-}
-
-/* ffestc_R539start -- IMPLICIT statement
+ ffestc_labeldef_notloop_begin_ ();
- ffestc_R539start();
+ if (name == NULL)
+ block = ffestw_top_do (ffestw_stack_top ());
+ else
+ { /* Search for name. */
+ for (block = ffestw_top_do (ffestw_stack_top ());
+ (block != NULL) && (ffestw_blocknum (block) != 0);
+ block = ffestw_top_do (ffestw_previous (block)))
+ {
+ if ((ffestw_name (block) != NULL)
+ && (ffelex_token_strcmp (name, ffestw_name (block)) == 0))
+ break;
+ }
+ if ((block == NULL) || (ffestw_blocknum (block) == 0))
+ {
+ block = ffestw_top_do (ffestw_stack_top ());
+ ffebad_start (FFEBAD_CONSTRUCT_NO_DO_NAME);
+ ffebad_here (0, ffelex_token_where_line (name),
+ ffelex_token_where_column (name));
+ ffebad_finish ();
+ }
+ }
- Verify that the IMPLICIT statement is ok here and implement. */
+ ffestd_R834 (block);
-void
-ffestc_R539start ()
-{
- ffestc_check_start_ ();
- if (ffestc_order_implicit_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_useless_ ();
+ if (ffestc_shriek_after1_ != NULL)
+ (*ffestc_shriek_after1_) (TRUE);
- ffestd_R539start ();
+ /* notloop's that are actionif's can be the target of a loop-end
+ statement if they're in the "then" part of a logical IF, as
+ in "DO 10", "10 IF (...) CYCLE". */
- ffestc_ok_ = TRUE;
+ ffestc_labeldef_branch_end_ ();
}
-/* ffestc_R539item -- IMPLICIT statement specification (R540)
+/* ffestc_R835 -- EXIT statement
- ffestc_R539item(...);
+ ffestc_R835(name_token);
- Verify that the type and letter list are all ok and implement. */
+ Handle a EXIT within a loop. */
void
-ffestc_R539item (ffestpType type, ffebld kind, ffelexToken kindt,
- ffebld len, ffelexToken lent, ffesttImpList letters)
+ffestc_R835 (ffelexToken name)
{
- ffestc_check_item_ ();
- if (!ffestc_ok_)
+ ffestw block;
+
+ ffestc_check_simple_ ();
+ if (ffestc_order_actiondo_ () != FFESTC_orderOK_)
return;
+ ffestc_labeldef_notloop_begin_ ();
- if ((type == FFESTP_typeCHARACTER) && (len != NULL)
- && (ffebld_op (len) == FFEBLD_opSTAR))
- { /* Complain and pretend they're CHARACTER
- [*1]. */
- ffebad_start (FFEBAD_IMPLICIT_ADJLEN);
- ffebad_here (0, ffelex_token_where_line (lent),
- ffelex_token_where_column (lent));
- ffebad_finish ();
- len = NULL;
- lent = NULL;
+ if (name == NULL)
+ block = ffestw_top_do (ffestw_stack_top ());
+ else
+ { /* Search for name. */
+ for (block = ffestw_top_do (ffestw_stack_top ());
+ (block != NULL) && (ffestw_blocknum (block) != 0);
+ block = ffestw_top_do (ffestw_previous (block)))
+ {
+ if ((ffestw_name (block) != NULL)
+ && (ffelex_token_strcmp (name, ffestw_name (block)) == 0))
+ break;
+ }
+ if ((block == NULL) || (ffestw_blocknum (block) == 0))
+ {
+ block = ffestw_top_do (ffestw_stack_top ());
+ ffebad_start (FFEBAD_CONSTRUCT_NO_DO_NAME);
+ ffebad_here (0, ffelex_token_where_line (name),
+ ffelex_token_where_column (name));
+ ffebad_finish ();
+ }
}
- ffestc_establish_declstmt_ (type, ffesta_tokens[0], kind, kindt, len, lent);
- ffestc_establish_declinfo_ (NULL, NULL, NULL, NULL);
-
- ffestt_implist_drive (letters, ffestc_establish_impletter_);
-
- ffestd_R539item (type, kind, kindt, len, lent, letters);
-}
-
-/* ffestc_R539finish -- IMPLICIT statement
- ffestc_R539finish();
+ ffestd_R835 (block);
- Finish up any local activities. */
+ if (ffestc_shriek_after1_ != NULL)
+ (*ffestc_shriek_after1_) (TRUE);
-void
-ffestc_R539finish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
+ /* notloop's that are actionif's can be the target of a loop-end
+ statement if they're in the "then" part of a logical IF, as
+ in "DO 10", "10 IF (...) EXIT". */
- ffestd_R539finish ();
+ ffestc_labeldef_branch_end_ ();
}
-/* ffestc_R542_start -- NAMELIST statement list begin
+/* ffestc_R836 -- GOTO statement
- ffestc_R542_start();
+ ffestc_R836(label_token);
- Verify that NAMELIST is valid here, and begin accepting items in the
- list. */
+ 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
-ffestc_R542_start ()
+ffestc_R836 (ffelexToken label_token)
{
- ffestc_check_start_ ();
- if (ffestc_order_progspec_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_useless_ ();
+ ffelab label;
- if (ffe_is_f2c_library ()
- && (ffe_case_source () == FFE_caseNONE))
- {
- ffebad_start (FFEBAD_NAMELIST_CASE);
- ffesta_ffebad_here_current_stmt (0);
- ffebad_finish ();
- }
+ ffestc_check_simple_ ();
+ if (ffestc_order_actionif_ () != FFESTC_orderOK_)
+ return;
+ ffestc_labeldef_notloop_begin_ ();
- ffestd_R542_start ();
+ if (ffestc_labelref_is_branch_ (label_token, &label))
+ ffestd_R836 (label);
- ffestc_local_.namelist.symbol = NULL;
+ if (ffestc_shriek_after1_ != NULL)
+ (*ffestc_shriek_after1_) (TRUE);
- ffestc_ok_ = TRUE;
+ /* notloop's that are actionif's can be the target of a loop-end
+ statement if they're in the "then" part of a logical IF, as
+ in "DO 10", "10 IF (...) GOTO 100". */
+
+ ffestc_labeldef_branch_end_ ();
}
-/* ffestc_R542_item_nlist -- NAMELIST statement for group-name
+/* ffestc_R837 -- Computed GOTO statement
- ffestc_R542_item_nlist(groupname_token);
+ ffestc_R837(label_list,expr,expr_token);
- Make sure name_token identifies a valid object to be NAMELISTd. */
+ 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
-ffestc_R542_item_nlist (ffelexToken name)
+ffestc_R837 (ffesttTokenList label_toks, ffebld expr,
+ ffelexToken expr_token UNUSED)
{
- ffesymbol s;
+ ffesttTokenItem ti;
+ bool ok = TRUE;
+ int i;
+ ffelab *labels;
- ffestc_check_item_ ();
- assert (name != NULL);
- if (!ffestc_ok_)
- return;
+ assert (label_toks != NULL);
- if (ffestc_local_.namelist.symbol != NULL)
- ffesymbol_signal_unreported (ffestc_local_.namelist.symbol);
+ ffestc_check_simple_ ();
+ if (ffestc_order_actionif_ () != FFESTC_orderOK_)
+ return;
+ ffestc_labeldef_branch_begin_ ();
- s = ffesymbol_declare_local (name, FALSE);
+ labels = malloc_new_kp (ffesta_output_pool, "FFESTC labels",
+ sizeof (*labels)
+ * ffestt_tokenlist_count (label_toks));
- if ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
- || ((ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
- && (ffesymbol_kind (s) == FFEINFO_kindNAMELIST)))
+ for (ti = label_toks->first, i = 0;
+ ti != (ffesttTokenItem) &label_toks->first;
+ ti = ti->next, ++i)
{
- ffestc_parent_ok_ = TRUE;
- if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
+ if (!ffestc_labelref_is_branch_ (ti->t, &labels[i]))
{
- ffebld_init_list (ffesymbol_ptr_to_namelist (s),
- ffesymbol_ptr_to_listbottom (s));
- ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
- ffesymbol_set_info (s,
- ffeinfo_new (FFEINFO_basictypeNONE,
- FFEINFO_kindtypeNONE,
- 0,
- FFEINFO_kindNAMELIST,
- FFEINFO_whereLOCAL,
- FFETARGET_charactersizeNONE));
+ ok = FALSE;
+ break;
}
}
- else
- {
- if (ffesymbol_kind (s) != FFEINFO_kindANY)
- ffesymbol_error (s, name);
- ffestc_parent_ok_ = FALSE;
- }
- ffestc_local_.namelist.symbol = s;
+ if (ok)
+ ffestd_R837 (labels, ffestt_tokenlist_count (label_toks), expr);
- ffestd_R542_item_nlist (name);
+ if (ffestc_shriek_after1_ != NULL)
+ (*ffestc_shriek_after1_) (TRUE);
+ ffestc_labeldef_branch_end_ ();
}
-/* ffestc_R542_item_nitem -- NAMELIST statement for variable-name
+/* ffestc_R838 -- ASSIGN statement
- ffestc_R542_item_nitem(name_token);
+ ffestc_R838(label_token,target_variable,target_token);
- Make sure name_token identifies a valid object to be NAMELISTd. */
+ 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
-ffestc_R542_item_nitem (ffelexToken name)
+ffestc_R838 (ffelexToken label_token, ffebld target,
+ ffelexToken target_token UNUSED)
{
- ffesymbol s;
- ffesymbolAttrs sa;
- ffesymbolAttrs na;
- ffebld e;
+ ffelab label;
- ffestc_check_item_ ();
- assert (name != NULL);
- if (!ffestc_ok_)
+ ffestc_check_simple_ ();
+ if (ffestc_order_actionif_ () != FFESTC_orderOK_)
return;
+ ffestc_labeldef_branch_begin_ ();
- s = ffesymbol_declare_local (name, FALSE);
- sa = ffesymbol_attrs (s);
+ /* Mark target symbol as target of an ASSIGN. */
+ if (ffebld_op (target) == FFEBLD_opSYMTER)
+ ffesymbol_set_assigned (ffebld_symter (target), TRUE);
- /* Figure out what kind of object we've got based on previous declarations
- of or references to the object. */
+ if (ffestc_labelref_is_assignable_ (label_token, &label))
+ ffestd_R838 (label, target);
- if (!ffesymbol_is_specable (s)
- && ((ffesymbol_kind (s) != FFEINFO_kindENTITY)
- || ((ffesymbol_where (s) != FFEINFO_whereLOCAL)
- && (ffesymbol_where (s) != FFEINFO_whereCOMMON))))
- na = FFESYMBOL_attrsetNONE;
- else if (sa & FFESYMBOL_attrsANY)
- na = FFESYMBOL_attrsANY;
- else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
- | FFESYMBOL_attrsARRAY
- | FFESYMBOL_attrsCOMMON
- | FFESYMBOL_attrsEQUIV
- | FFESYMBOL_attrsINIT
- | FFESYMBOL_attrsNAMELIST
- | FFESYMBOL_attrsSAVE
- | FFESYMBOL_attrsSFARG
- | FFESYMBOL_attrsTYPE)))
- na = sa | FFESYMBOL_attrsNAMELIST;
- else
- na = FFESYMBOL_attrsetNONE;
+ if (ffestc_shriek_after1_ != NULL)
+ (*ffestc_shriek_after1_) (TRUE);
+ ffestc_labeldef_branch_end_ ();
+}
- /* Now see what we've got for a new object: NONE means a new error cropped
- up; ANY means an old error to be ignored; otherwise, everything's ok,
- update the object (symbol) and continue on. */
+/* ffestc_R839 -- Assigned GOTO statement
- if (na == FFESYMBOL_attrsetNONE)
- ffesymbol_error (s, name);
- else if (!(na & FFESYMBOL_attrsANY))
+ ffestc_R839(target,target_token,label_list);
+
+ 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
+ffestc_R839 (ffebld target, ffelexToken target_token UNUSED,
+ ffesttTokenList label_toks)
+{
+ ffesttTokenItem ti;
+ bool ok = TRUE;
+ int i;
+ ffelab *labels;
+
+ ffestc_check_simple_ ();
+ if (ffestc_order_actionif_ () != FFESTC_orderOK_)
+ return;
+ ffestc_labeldef_notloop_begin_ ();
+
+ if (label_toks == NULL)
{
- ffesymbol_set_attrs (s, na);
- if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
- ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
- ffesymbol_set_namelisted (s, TRUE);
- ffesymbol_signal_unreported (s);
-#if 0 /* No need to establish type yet! */
- if (!ffeimplic_establish_symbol (s))
- ffesymbol_error (s, name);
-#endif
+ labels = NULL;
+ i = 0;
}
-
- if (ffestc_parent_ok_)
+ else
{
- e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
- FFEINTRIN_impNONE);
- ffebld_set_info (e,
- ffeinfo_new (FFEINFO_basictypeNONE,
- FFEINFO_kindtypeNONE, 0,
- FFEINFO_kindNONE,
- FFEINFO_whereNONE,
- FFETARGET_charactersizeNONE));
- ffebld_append_item
- (ffesymbol_ptr_to_listbottom (ffestc_local_.namelist.symbol), e);
+ labels = malloc_new_kp (ffesta_output_pool, "FFESTC labels",
+ sizeof (*labels) * ffestt_tokenlist_count (label_toks));
+
+ for (ti = label_toks->first, i = 0;
+ ti != (ffesttTokenItem) &label_toks->first;
+ ti = ti->next, ++i)
+ {
+ if (!ffestc_labelref_is_branch_ (ti->t, &labels[i]))
+ {
+ ok = FALSE;
+ break;
+ }
+ }
}
- ffestd_R542_item_nitem (name);
+ if (ok)
+ ffestd_R839 (target, labels, i);
+
+ if (ffestc_shriek_after1_ != NULL)
+ (*ffestc_shriek_after1_) (TRUE);
+
+ /* notloop's that are actionif's can be the target of a loop-end
+ statement if they're in the "then" part of a logical IF, as
+ in "DO 10", "10 IF (...) GOTO I". */
+
+ ffestc_labeldef_branch_end_ ();
}
-/* ffestc_R542_finish -- NAMELIST statement list complete
+/* ffestc_R840 -- Arithmetic IF statement
- ffestc_R542_finish();
+ ffestc_R840(expr,expr_token,neg,zero,pos);
- Just wrap up any local activities. */
+ Make sure the labels are valid; implement. */
void
-ffestc_R542_finish ()
+ffestc_R840 (ffebld expr, ffelexToken expr_token UNUSED,
+ ffelexToken neg_token, ffelexToken zero_token,
+ ffelexToken pos_token)
{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
+ ffelab neg;
+ ffelab zero;
+ ffelab pos;
+
+ ffestc_check_simple_ ();
+ if (ffestc_order_actionif_ () != FFESTC_orderOK_)
return;
+ ffestc_labeldef_notloop_begin_ ();
- ffesymbol_signal_unreported (ffestc_local_.namelist.symbol);
+ if (ffestc_labelref_is_branch_ (neg_token, &neg)
+ && ffestc_labelref_is_branch_ (zero_token, &zero)
+ && ffestc_labelref_is_branch_ (pos_token, &pos))
+ ffestd_R840 (expr, neg, zero, pos);
- ffestd_R542_finish ();
-}
+ if (ffestc_shriek_after1_ != NULL)
+ (*ffestc_shriek_after1_) (TRUE);
-/* ffestc_R544_start -- EQUIVALENCE statement list begin
+ /* notloop's that are actionif's can be the target of a loop-end
+ statement if they're in the "then" part of a logical IF, as
+ in "DO 10", "10 IF (...) GOTO (100,200,300), I". */
- ffestc_R544_start();
+ ffestc_labeldef_branch_end_ ();
+}
- Verify that EQUIVALENCE is valid here, and begin accepting items in the
- list. */
+/* ffestc_R841 -- CONTINUE statement
+
+ ffestc_R841(); */
void
-ffestc_R544_start ()
+ffestc_R841 ()
{
- ffestc_check_start_ ();
- if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_useless_ ();
+ ffestc_check_simple_ ();
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
+ if (ffestc_order_actionwhere_ () != FFESTC_orderOK_)
+ return;
- ffestc_ok_ = TRUE;
+ ffestc_labeldef_branch_begin_ ();
+
+ ffestd_R841 (FALSE);
+
+ if (ffestc_shriek_after1_ != NULL)
+ (*ffestc_shriek_after1_) (TRUE);
+ ffestc_labeldef_branch_end_ ();
}
-/* ffestc_R544_item -- EQUIVALENCE statement assignment
+/* ffestc_R842 -- STOP statement
- ffestc_R544_item(exprlist);
+ ffestc_R842(expr,expr_token);
- Make sure the equivalence is valid, then implement it. */
+ Make sure statement is valid here; implement. expr and expr_token are
+ both NULL if there was no expression. */
void
-ffestc_R544_item (ffesttExprList exprlist)
+ffestc_R842 (ffebld expr, ffelexToken expr_token UNUSED)
{
- ffestc_check_item_ ();
- if (!ffestc_ok_)
+ ffestc_check_simple_ ();
+ if (ffestc_order_actionif_ () != FFESTC_orderOK_)
return;
+ ffestc_labeldef_notloop_begin_ ();
- /* First we go through the list and come up with one ffeequiv object that
- will describe all items in the list. When an ffeequiv object is first
- found, it is used (else we create one as a "local equiv" for the time
- being). If subsequent ffeequiv objects are found, they are merged with
- the first so we end up with one. However, if more than one COMMON
- variable is involved, then an error condition occurs. */
-
- ffestc_local_.equiv.ok = TRUE;
- ffestc_local_.equiv.t = NULL; /* No token yet. */
- ffestc_local_.equiv.eq = NULL;/* No equiv yet. */
- ffestc_local_.equiv.save = FALSE; /* No SAVEd variables yet. */
-
- ffebld_init_list (&ffestc_local_.equiv.list, &ffestc_local_.equiv.bottom);
- ffestt_exprlist_drive (exprlist, ffestc_R544_equiv_); /* Get one equiv. */
- ffebld_end_list (&ffestc_local_.equiv.bottom);
-
- if (!ffestc_local_.equiv.ok)
- return; /* Something went wrong, stop bothering with
- this stuff. */
+ ffestd_R842 (expr);
- if (ffestc_local_.equiv.eq == NULL)
- ffestc_local_.equiv.eq = ffeequiv_new (); /* Make local equivalence. */
+ if (ffestc_shriek_after1_ != NULL)
+ (*ffestc_shriek_after1_) (TRUE);
- /* Append this list of equivalences to list of such lists for this
- equivalence. */
+ /* notloop's that are actionif's can be the target of a loop-end
+ statement if they're in the "then" part of a logical IF, as
+ in "DO 10", "10 IF (...) STOP". */
- ffeequiv_add (ffestc_local_.equiv.eq, ffestc_local_.equiv.list,
- ffestc_local_.equiv.t);
- if (ffestc_local_.equiv.save)
- ffeequiv_update_save (ffestc_local_.equiv.eq);
+ ffestc_labeldef_branch_end_ ();
}
-/* ffestc_R544_equiv_ -- EQUIVALENCE statement handler for item in list
+/* ffestc_R843 -- PAUSE statement
- ffebld expr;
- ffelexToken t;
- ffestc_R544_equiv_(expr,t);
+ ffestc_R843(expr,expr_token);
- Record information, if any, on symbol in expr; if symbol has equivalence
- object already, merge with outstanding object if present or make it
- the outstanding object. */
+ Make sure statement is valid here; implement. expr and expr_token are
+ both NULL if there was no expression. */
-static void
-ffestc_R544_equiv_ (ffebld expr, ffelexToken t)
+void
+ffestc_R843 (ffebld expr, ffelexToken expr_token UNUSED)
{
- ffesymbol s;
-
- if (!ffestc_local_.equiv.ok)
+ ffestc_check_simple_ ();
+ if (ffestc_order_actionif_ () != FFESTC_orderOK_)
return;
+ ffestc_labeldef_branch_begin_ ();
- if (ffestc_local_.equiv.t == NULL)
- ffestc_local_.equiv.t = t;
+ ffestd_R843 (expr);
- switch (ffebld_op (expr))
- {
- case FFEBLD_opANY:
- return; /* Don't put this on the list. */
+ if (ffestc_shriek_after1_ != NULL)
+ (*ffestc_shriek_after1_) (TRUE);
+ ffestc_labeldef_branch_end_ ();
+}
- case FFEBLD_opSYMTER:
- case FFEBLD_opARRAYREF:
- case FFEBLD_opSUBSTR:
- break; /* All of these are ok. */
+/* ffestc_R904 -- OPEN statement
- default:
- assert ("ffestc_R544_equiv_ bad op" == NULL);
- return;
- }
+ ffestc_R904();
- ffebld_append_item (&ffestc_local_.equiv.bottom, expr);
+ Make sure an OPEN is valid in the current context, and implement it. */
- s = ffeequiv_symbol (expr);
+void
+ffestc_R904 ()
+{
+ int i;
+ int expect_file;
+ static const char *const status_strs[] =
+ {
+ "New",
+ "Old",
+ "Replace",
+ "Scratch",
+ "Unknown"
+ };
+ static const char *const access_strs[] =
+ {
+ "Append",
+ "Direct",
+ "Keyed",
+ "Sequential"
+ };
+ static const char *const blank_strs[] =
+ {
+ "Null",
+ "Zero"
+ };
+ static const char *const carriagecontrol_strs[] =
+ {
+ "Fortran",
+ "List",
+ "None"
+ };
+ static const char *const dispose_strs[] =
+ {
+ "Delete",
+ "Keep",
+ "Print",
+ "Print/Delete",
+ "Save",
+ "Submit",
+ "Submit/Delete"
+ };
+ static const char *const form_strs[] =
+ {
+ "Formatted",
+ "Unformatted"
+ };
+ static const char *const organization_strs[] =
+ {
+ "Indexed",
+ "Relative",
+ "Sequential"
+ };
+ static const char *const position_strs[] =
+ {
+ "Append",
+ "AsIs",
+ "Rewind"
+ };
+ static const char *const action_strs[] =
+ {
+ "Read",
+ "ReadWrite",
+ "Write"
+ };
+ static const char *const delim_strs[] =
+ {
+ "Apostrophe",
+ "None",
+ "Quote"
+ };
+ static const char *const recordtype_strs[] =
+ {
+ "Fixed",
+ "Segmented",
+ "Stream",
+ "Stream_CR",
+ "Stream_LF",
+ "Variable"
+ };
+ static const char *const pad_strs[] =
+ {
+ "No",
+ "Yes"
+ };
- /* See if symbol has an equivalence object already. */
+ ffestc_check_simple_ ();
+ if (ffestc_order_actionif_ () != FFESTC_orderOK_)
+ return;
+ ffestc_labeldef_branch_begin_ ();
- if (ffesymbol_equiv (s) != NULL)
+ if (ffestc_subr_is_branch_
+ (&ffestp_file.open.open_spec[FFESTP_openixERR])
+ && ffestc_subr_is_present_ ("UNIT",
+ &ffestp_file.open.open_spec[FFESTP_openixUNIT]))
{
- if (ffestc_local_.equiv.eq == NULL)
- ffestc_local_.equiv.eq = ffesymbol_equiv (s); /* New equiv obj. */
- else if (ffestc_local_.equiv.eq != ffesymbol_equiv (s))
+ i = ffestc_subr_binsrch_ (status_strs,
+ ARRAY_SIZE (status_strs),
+ &ffestp_file.open.open_spec[FFESTP_openixSTATUS],
+ "NEW, OLD, REPLACE, SCRATCH, or UNKNOWN");
+ switch (i)
{
- ffestc_local_.equiv.eq = ffeequiv_merge (ffesymbol_equiv (s),
- ffestc_local_.equiv.eq,
- t);
- if (ffestc_local_.equiv.eq == NULL)
- ffestc_local_.equiv.ok = FALSE; /* Couldn't merge. */
- }
- }
+ case 0: /* Unknown. */
+ case 5: /* UNKNOWN. */
+ expect_file = 2; /* Unknown, don't care about FILE=. */
+ break;
- if (ffesymbol_is_save (s))
- ffestc_local_.equiv.save = TRUE;
-}
+ case 1: /* NEW. */
+ case 2: /* OLD. */
+ if (ffe_is_pedantic ())
+ expect_file = 1; /* Yes, need FILE=. */
+ else
+ expect_file = 2; /* f2clib doesn't care about FILE=. */
+ break;
-/* ffestc_R544_finish -- EQUIVALENCE statement list complete
+ case 3: /* REPLACE. */
+ expect_file = 1; /* Yes, need FILE=. */
+ break;
- ffestc_R544_finish();
+ case 4: /* SCRATCH. */
+ expect_file = 0; /* No, disallow FILE=. */
+ break;
- Just wrap up any local activities. */
+ default:
+ assert ("invalid _binsrch_ result" == NULL);
+ expect_file = 0;
+ break;
+ }
+ if ((expect_file == 0)
+ && ffestp_file.open.open_spec[FFESTP_openixFILE].kw_or_val_present)
+ {
+ ffebad_start (FFEBAD_CONFLICTING_SPECS);
+ assert (ffestp_file.open.open_spec[FFESTP_openixFILE].kw_or_val_present);
+ if (ffestp_file.open.open_spec[FFESTP_openixFILE].kw_present)
+ {
+ ffebad_here (0, ffelex_token_where_line
+ (ffestp_file.open.open_spec[FFESTP_openixFILE].kw),
+ ffelex_token_where_column
+ (ffestp_file.open.open_spec[FFESTP_openixFILE].kw));
+ }
+ else
+ {
+ ffebad_here (0, ffelex_token_where_line
+ (ffestp_file.open.open_spec[FFESTP_openixFILE].value),
+ ffelex_token_where_column
+ (ffestp_file.open.open_spec[FFESTP_openixFILE].value));
+ }
+ assert (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_or_val_present);
+ if (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_present)
+ {
+ ffebad_here (1, ffelex_token_where_line
+ (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw),
+ ffelex_token_where_column
+ (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw));
+ }
+ else
+ {
+ ffebad_here (1, ffelex_token_where_line
+ (ffestp_file.open.open_spec[FFESTP_openixSTATUS].value),
+ ffelex_token_where_column
+ (ffestp_file.open.open_spec[FFESTP_openixSTATUS].value));
+ }
+ ffebad_finish ();
+ }
+ else if ((expect_file == 1)
+ && !ffestp_file.open.open_spec[FFESTP_openixFILE].kw_or_val_present)
+ {
+ ffebad_start (FFEBAD_MISSING_SPECIFIER);
+ assert (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_or_val_present);
+ if (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_present)
+ {
+ ffebad_here (0, ffelex_token_where_line
+ (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw),
+ ffelex_token_where_column
+ (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw));
+ }
+ else
+ {
+ ffebad_here (0, ffelex_token_where_line
+ (ffestp_file.open.open_spec[FFESTP_openixSTATUS].value),
+ ffelex_token_where_column
+ (ffestp_file.open.open_spec[FFESTP_openixSTATUS].value));
+ }
+ ffebad_string ("FILE=");
+ ffebad_finish ();
+ }
-void
-ffestc_R544_finish ()
-{
- ffestc_check_finish_ ();
-}
+ ffestc_subr_binsrch_ (access_strs, ARRAY_SIZE (access_strs),
+ &ffestp_file.open.open_spec[FFESTP_openixACCESS],
+ "APPEND, DIRECT, KEYED, or SEQUENTIAL");
-/* ffestc_R547_start -- COMMON statement list begin
+ ffestc_subr_binsrch_ (blank_strs, ARRAY_SIZE (blank_strs),
+ &ffestp_file.open.open_spec[FFESTP_openixBLANK],
+ "NULL or ZERO");
- ffestc_R547_start();
+ ffestc_subr_binsrch_ (carriagecontrol_strs,
+ ARRAY_SIZE (carriagecontrol_strs),
+ &ffestp_file.open.open_spec[FFESTP_openixCARRIAGECONTROL],
+ "FORTRAN, LIST, or NONE");
- Verify that COMMON is valid here, and begin accepting items in the list. */
+ ffestc_subr_binsrch_ (dispose_strs, ARRAY_SIZE (dispose_strs),
+ &ffestp_file.open.open_spec[FFESTP_openixDISPOSE],
+ "DELETE, KEEP, PRINT, PRINT/DELETE, SAVE, SUBMIT, or SUBMIT/DELETE");
-void
-ffestc_R547_start ()
-{
- ffestc_check_start_ ();
- if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_useless_ ();
+ ffestc_subr_binsrch_ (form_strs, ARRAY_SIZE (form_strs),
+ &ffestp_file.open.open_spec[FFESTP_openixFORM],
+ "FORMATTED or UNFORMATTED");
- ffestc_local_.common.symbol = NULL; /* Blank common is the default. */
- ffestc_parent_ok_ = TRUE;
+ ffestc_subr_binsrch_ (organization_strs, ARRAY_SIZE (organization_strs),
+ &ffestp_file.open.open_spec[FFESTP_openixORGANIZATION],
+ "INDEXED, RELATIVE, or SEQUENTIAL");
- ffestd_R547_start ();
+ ffestc_subr_binsrch_ (position_strs, ARRAY_SIZE (position_strs),
+ &ffestp_file.open.open_spec[FFESTP_openixPOSITION],
+ "APPEND, ASIS, or REWIND");
- ffestc_ok_ = TRUE;
-}
+ ffestc_subr_binsrch_ (action_strs, ARRAY_SIZE (action_strs),
+ &ffestp_file.open.open_spec[FFESTP_openixACTION],
+ "READ, READWRITE, or WRITE");
-/* ffestc_R547_item_object -- COMMON statement for object-name
+ ffestc_subr_binsrch_ (delim_strs, ARRAY_SIZE (delim_strs),
+ &ffestp_file.open.open_spec[FFESTP_openixDELIM],
+ "APOSTROPHE, NONE, or QUOTE");
- ffestc_R547_item_object(name_token,dim_list);
+ ffestc_subr_binsrch_ (recordtype_strs, ARRAY_SIZE (recordtype_strs),
+ &ffestp_file.open.open_spec[FFESTP_openixRECORDTYPE],
+ "FIXED, SEGMENTED, STREAM, STREAM_CR, STREAM_LF, or VARIABLE");
- Make sure name_token identifies a valid object to be COMMONd. */
+ ffestc_subr_binsrch_ (pad_strs, ARRAY_SIZE (pad_strs),
+ &ffestp_file.open.open_spec[FFESTP_openixPAD],
+ "NO or YES");
-void
-ffestc_R547_item_object (ffelexToken name, ffesttDimList dims)
-{
- ffesymbol s;
- ffebld array_size;
- ffebld extents;
- ffesymbolAttrs sa;
- ffesymbolAttrs na;
- ffestpDimtype nd;
- ffebld e;
- ffeinfoRank rank;
- bool is_ugly_assumed;
+ ffestd_R904 ();
+ }
- if (ffestc_parent_ok_ && (ffestc_local_.common.symbol == NULL))
- ffestc_R547_item_cblock (NULL); /* As if "COMMON [//] ...". */
+ if (ffestc_shriek_after1_ != NULL)
+ (*ffestc_shriek_after1_) (TRUE);
+ ffestc_labeldef_branch_end_ ();
+}
- ffestc_check_item_ ();
- assert (name != NULL);
- if (!ffestc_ok_)
- return;
+/* ffestc_R907 -- CLOSE statement
- if (dims != NULL)
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
+ ffestc_R907();
- s = ffesymbol_declare_local (name, FALSE);
- sa = ffesymbol_attrs (s);
+ Make sure a CLOSE is valid in the current context, and implement it. */
- /* First figure out what kind of object this is based solely on the current
- object situation (dimension list). */
+void
+ffestc_R907 ()
+{
+ static const char *const status_strs[] =
+ {
+ "Delete",
+ "Keep",
+ "Print",
+ "Print/Delete",
+ "Save",
+ "Submit",
+ "Submit/Delete"
+ };
- is_ugly_assumed = (ffe_is_ugly_assumed ()
- && ((sa & FFESYMBOL_attrsDUMMY)
- || (ffesymbol_where (s) == FFEINFO_whereDUMMY)));
+ ffestc_check_simple_ ();
+ if (ffestc_order_actionif_ () != FFESTC_orderOK_)
+ return;
+ ffestc_labeldef_branch_begin_ ();
- nd = ffestt_dimlist_type (dims, is_ugly_assumed);
- switch (nd)
+ if (ffestc_subr_is_branch_
+ (&ffestp_file.close.close_spec[FFESTP_closeixERR])
+ && ffestc_subr_is_present_ ("UNIT",
+ &ffestp_file.close.close_spec[FFESTP_closeixUNIT]))
{
- case FFESTP_dimtypeNONE:
- na = FFESYMBOL_attrsCOMMON;
- break;
-
- case FFESTP_dimtypeKNOWN:
- na = FFESYMBOL_attrsCOMMON | FFESYMBOL_attrsARRAY;
- break;
+ ffestc_subr_binsrch_ (status_strs, ARRAY_SIZE (status_strs),
+ &ffestp_file.close.close_spec[FFESTP_closeixSTATUS],
+ "DELETE, KEEP, PRINT, PRINT/DELETE, SAVE, SUBMIT, or SUBMIT/DELETE");
- default:
- na = FFESYMBOL_attrsetNONE;
- break;
+ ffestd_R907 ();
}
- /* Figure out what kind of object we've got based on previous declarations
- of or references to the object. */
+ if (ffestc_shriek_after1_ != NULL)
+ (*ffestc_shriek_after1_) (TRUE);
+ ffestc_labeldef_branch_end_ ();
+}
- if (na == FFESYMBOL_attrsetNONE)
- ;
- else if (!ffesymbol_is_specable (s))
- na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
- else if (sa & FFESYMBOL_attrsANY)
- na = FFESYMBOL_attrsANY;
- else if ((sa & (FFESYMBOL_attrsADJUSTS
- | FFESYMBOL_attrsARRAY
- | FFESYMBOL_attrsINIT
- | FFESYMBOL_attrsSFARG))
- && (na & FFESYMBOL_attrsARRAY))
- na = FFESYMBOL_attrsetNONE;
- else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
- | FFESYMBOL_attrsARRAY
- | FFESYMBOL_attrsEQUIV
- | FFESYMBOL_attrsINIT
- | FFESYMBOL_attrsNAMELIST
- | FFESYMBOL_attrsSFARG
- | FFESYMBOL_attrsTYPE)))
- na |= sa;
- else
- na = FFESYMBOL_attrsetNONE;
+/* ffestc_R909_start -- READ(...) statement list begin
- /* Now see what we've got for a new object: NONE means a new error cropped
- up; ANY means an old error to be ignored; otherwise, everything's ok,
- update the object (symbol) and continue on. */
+ ffestc_R909_start(FALSE);
- if (na == FFESYMBOL_attrsetNONE)
- ffesymbol_error (s, name);
- else if ((ffesymbol_equiv (s) != NULL)
- && (ffeequiv_common (ffesymbol_equiv (s)) != NULL)
- && (ffeequiv_common (ffesymbol_equiv (s))
- != ffestc_local_.common.symbol))
- {
- /* Oops, just COMMONed a symbol to a different area (via equiv). */
- ffebad_start (FFEBAD_EQUIV_COMMON);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_string (ffesymbol_text (ffestc_local_.common.symbol));
- ffebad_string (ffesymbol_text (ffeequiv_common (ffesymbol_equiv (s))));
- ffebad_finish ();
- ffesymbol_set_attr (s, na | FFESYMBOL_attrANY);
- ffesymbol_set_info (s, ffeinfo_new_any ());
- ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
- ffesymbol_signal_unreported (s);
- }
- else if (!(na & FFESYMBOL_attrsANY))
+ Verify that READ is valid here, and begin accepting items in the
+ list. */
+
+void
+ffestc_R909_start (bool only_format)
+{
+ ffestvUnit unit;
+ ffestvFormat format;
+ bool rec;
+ bool key;
+ ffestpReadIx keyn;
+ ffestpReadIx spec1;
+ ffestpReadIx spec2;
+
+ ffestc_check_start_ ();
+ if (ffestc_order_actionif_ () != FFESTC_orderOK_)
{
- ffesymbol_set_attrs (s, na);
- ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
- ffesymbol_set_common (s, ffestc_local_.common.symbol);
-#if FFEGLOBAL_ENABLED
- if (ffesymbol_is_init (s))
- ffeglobal_init_common (ffestc_local_.common.symbol, name);
-#endif
- if (ffesymbol_is_save (ffestc_local_.common.symbol))
- ffesymbol_update_save (s);
- if (ffesymbol_equiv (s) != NULL)
- { /* Is this newly COMMONed symbol involved in
- an equivalence? */
- if (ffeequiv_common (ffesymbol_equiv (s)) == NULL)
- ffeequiv_set_common (ffesymbol_equiv (s), /* Yes, tell equiv obj. */
- ffestc_local_.common.symbol);
-#if FFEGLOBAL_ENABLED
- if (ffeequiv_is_init (ffesymbol_equiv (s)))
- ffeglobal_init_common (ffestc_local_.common.symbol, name);
-#endif
- if (ffesymbol_is_save (ffestc_local_.common.symbol))
- ffeequiv_update_save (ffesymbol_equiv (s));
- }
- if (dims != NULL)
- {
- ffesymbol_set_dims (s, ffestt_dimlist_as_expr (dims, &rank,
- &array_size,
- &extents,
- is_ugly_assumed));
- ffesymbol_set_arraysize (s, array_size);
- ffesymbol_set_extents (s, extents);
- if (!(0 && ffe_is_90 ())
- && (ffebld_op (array_size) == FFEBLD_opCONTER)
- && (ffebld_constant_integerdefault (ffebld_conter (array_size))
- == 0))
- {
- ffebad_start (FFEBAD_ZERO_ARRAY);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_finish ();
- }
- ffesymbol_set_info (s,
- ffeinfo_new (ffesymbol_basictype (s),
- ffesymbol_kindtype (s),
- rank,
- ffesymbol_kind (s),
- ffesymbol_where (s),
- ffesymbol_size (s)));
- }
- ffesymbol_signal_unreported (s);
+ ffestc_ok_ = FALSE;
+ return;
}
+ ffestc_labeldef_branch_begin_ ();
- if (ffestc_parent_ok_)
+ if (!ffestc_subr_is_format_
+ (&ffestp_file.read.read_spec[FFESTP_readixFORMAT]))
{
- e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
- FFEINTRIN_impNONE);
- ffebld_set_info (e,
- ffeinfo_new (FFEINFO_basictypeNONE,
- FFEINFO_kindtypeNONE,
- 0,
- FFEINFO_kindNONE,
- FFEINFO_whereNONE,
- FFETARGET_charactersizeNONE));
- ffebld_append_item
- (ffesymbol_ptr_to_listbottom (ffestc_local_.common.symbol), e);
+ ffestc_ok_ = FALSE;
+ return;
}
- ffestd_R547_item_object (name, dims);
-}
+ format = ffestc_subr_format_
+ (&ffestp_file.read.read_spec[FFESTP_readixFORMAT]);
+ ffestc_namelist_ = (format == FFESTV_formatNAMELIST);
-/* ffestc_R547_item_cblock -- COMMON statement for common-block-name
+ if (only_format)
+ {
+ ffestd_R909_start (TRUE, FFESTV_unitNONE, format, FALSE, FALSE);
- ffestc_R547_item_cblock(name_token);
+ ffestc_ok_ = TRUE;
+ return;
+ }
- Make sure name_token identifies a valid common block to be COMMONd. */
+ if (!ffestc_subr_is_branch_
+ (&ffestp_file.read.read_spec[FFESTP_readixEOR])
+ || !ffestc_subr_is_branch_
+ (&ffestp_file.read.read_spec[FFESTP_readixERR])
+ || !ffestc_subr_is_branch_
+ (&ffestp_file.read.read_spec[FFESTP_readixEND]))
+ {
+ ffestc_ok_ = FALSE;
+ return;
+ }
-void
-ffestc_R547_item_cblock (ffelexToken name)
-{
- ffesymbol s;
- ffesymbolAttrs sa;
- ffesymbolAttrs na;
+ unit = ffestc_subr_unit_
+ (&ffestp_file.read.read_spec[FFESTP_readixUNIT]);
+ if (unit == FFESTV_unitNONE)
+ {
+ ffebad_start (FFEBAD_NO_UNIT_SPEC);
+ ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
+ ffelex_token_where_column (ffesta_tokens[0]));
+ ffebad_finish ();
+ ffestc_ok_ = FALSE;
+ return;
+ }
- ffestc_check_item_ ();
- if (!ffestc_ok_)
- return;
+ rec = ffestp_file.read.read_spec[FFESTP_readixREC].kw_or_val_present;
- if (ffestc_local_.common.symbol != NULL)
- ffesymbol_signal_unreported (ffestc_local_.common.symbol);
-
- s = ffesymbol_declare_cblock (name,
- ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- sa = ffesymbol_attrs (s);
-
- /* Figure out what kind of object we've got based on previous declarations
- of or references to the object. */
-
- if (!ffesymbol_is_specable (s))
- na = FFESYMBOL_attrsetNONE;
- else if (sa & FFESYMBOL_attrsANY)
- na = FFESYMBOL_attrsANY; /* Already have an error here, say nothing. */
- else if (!(sa & ~(FFESYMBOL_attrsCBLOCK
- | FFESYMBOL_attrsSAVECBLOCK)))
+ if (ffestp_file.read.read_spec[FFESTP_readixKEYEQ].kw_or_val_present)
{
- if (!(sa & FFESYMBOL_attrsCBLOCK))
- ffebld_init_list (ffesymbol_ptr_to_commonlist (s),
- ffesymbol_ptr_to_listbottom (s));
- na = sa | FFESYMBOL_attrsCBLOCK;
+ key = TRUE;
+ keyn = spec1 = FFESTP_readixKEYEQ;
}
else
- na = FFESYMBOL_attrsetNONE;
-
- /* Now see what we've got for a new object: NONE means a new error cropped
- up; ANY means an old error to be ignored; otherwise, everything's ok,
- update the object (symbol) and continue on. */
-
- if (na == FFESYMBOL_attrsetNONE)
{
- ffesymbol_error (s, name == NULL ? ffesta_tokens[0] : name);
- ffestc_parent_ok_ = FALSE;
+ key = FALSE;
+ keyn = spec1 = FFESTP_readix;
}
- else if (na & FFESYMBOL_attrsANY)
- ffestc_parent_ok_ = FALSE;
- else
+
+ if (ffestp_file.read.read_spec[FFESTP_readixKEYGT].kw_or_val_present)
{
- ffesymbol_set_attrs (s, na);
- ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
- if (name == NULL)
- ffesymbol_update_save (s);
- ffestc_parent_ok_ = TRUE;
+ if (key)
+ {
+ spec2 = FFESTP_readixKEYGT;
+ whine: /* :::::::::::::::::::: */
+ ffebad_start (FFEBAD_CONFLICTING_SPECS);
+ assert (ffestp_file.read.read_spec[spec1].kw_or_val_present);
+ if (ffestp_file.read.read_spec[spec1].kw_present)
+ {
+ ffebad_here (0, ffelex_token_where_line
+ (ffestp_file.read.read_spec[spec1].kw),
+ ffelex_token_where_column
+ (ffestp_file.read.read_spec[spec1].kw));
+ }
+ else
+ {
+ ffebad_here (0, ffelex_token_where_line
+ (ffestp_file.read.read_spec[spec1].value),
+ ffelex_token_where_column
+ (ffestp_file.read.read_spec[spec1].value));
+ }
+ assert (ffestp_file.read.read_spec[spec2].kw_or_val_present);
+ if (ffestp_file.read.read_spec[spec2].kw_present)
+ {
+ ffebad_here (1, ffelex_token_where_line
+ (ffestp_file.read.read_spec[spec2].kw),
+ ffelex_token_where_column
+ (ffestp_file.read.read_spec[spec2].kw));
+ }
+ else
+ {
+ ffebad_here (1, ffelex_token_where_line
+ (ffestp_file.read.read_spec[spec2].value),
+ ffelex_token_where_column
+ (ffestp_file.read.read_spec[spec2].value));
+ }
+ ffebad_finish ();
+ ffestc_ok_ = FALSE;
+ return;
+ }
+ key = TRUE;
+ keyn = spec1 = FFESTP_readixKEYGT;
}
- ffestc_local_.common.symbol = s;
-
- ffestd_R547_item_cblock (name);
-}
-
-/* ffestc_R547_finish -- COMMON statement list complete
-
- ffestc_R547_finish();
-
- Just wrap up any local activities. */
-
-void
-ffestc_R547_finish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
-
- if (ffestc_local_.common.symbol != NULL)
- ffesymbol_signal_unreported (ffestc_local_.common.symbol);
-
- ffestd_R547_finish ();
-}
-
-/* ffestc_R620 -- ALLOCATE statement
-
- ffestc_R620(exprlist,stat,stat_token);
-
- Make sure the expression list is valid, then implement it. */
-
-#if FFESTR_F90
-void
-ffestc_R620 (ffesttExprList exprlist, ffebld stat, ffelexToken stat_token)
-{
- ffestc_check_simple_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_branch_begin_ ();
-
- ffestd_R620 (exprlist, stat);
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R624 -- NULLIFY statement
-
- ffestc_R624(pointer_name_list);
-
- Make sure pointer_name_list identifies valid pointers for a NULLIFY. */
-
-void
-ffestc_R624 (ffesttExprList pointers)
-{
- ffestc_check_simple_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_branch_begin_ ();
-
- ffestd_R624 (pointers);
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R625 -- DEALLOCATE statement
-
- ffestc_R625(exprlist,stat,stat_token);
-
- Make sure the equivalence is valid, then implement it. */
-
-void
-ffestc_R625 (ffesttExprList exprlist, ffebld stat, ffelexToken stat_token)
-{
- ffestc_check_simple_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_branch_begin_ ();
-
- ffestd_R625 (exprlist, stat);
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-#endif
-/* ffestc_let -- R1213 or R737
-
- ffestc_let(...);
-
- Verify that R1213 defined-assignment or R737 assignment-stmt are
- valid here, figure out which one, and implement. */
-
-#if FFESTR_F90
-void
-ffestc_let (ffebld dest, ffebld source, ffelexToken source_token)
-{
- ffestc_R737 (dest, source, source_token);
-}
-
-#endif
-/* ffestc_R737 -- Assignment statement
-
- ffestc_R737(dest_expr,source_expr,source_token);
-
- Make sure the assignment is valid. */
-
-void
-ffestc_R737 (ffebld dest, ffebld source, ffelexToken source_token)
-{
- ffestc_check_simple_ ();
-
- switch (ffestw_state (ffestw_stack_top ()))
+ if (ffestp_file.read.read_spec[FFESTP_readixKEYGE].kw_or_val_present)
{
-#if FFESTR_F90
- case FFESTV_stateWHERE:
- case FFESTV_stateWHERETHEN:
- if (ffestc_order_actionwhere_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
-
- ffestd_R737B (dest, source);
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- return;
-#endif
-
- default:
- break;
+ if (key)
+ {
+ spec2 = FFESTP_readixKEYGT;
+ goto whine; /* :::::::::::::::::::: */
+ }
+ key = TRUE;
+ keyn = FFESTP_readixKEYGT;
}
- if (ffestc_order_actionwhere_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_branch_begin_ ();
-
- source = ffeexpr_convert_expr (source, source_token, dest, ffesta_tokens[0],
- FFEEXPR_contextLET);
-
- ffestd_R737A (dest, source);
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R738 -- Pointer assignment statement
-
- ffestc_R738(dest_expr,source_expr,source_token);
-
- Make sure the assignment is valid. */
-
-#if FFESTR_F90
-void
-ffestc_R738 (ffebld dest, ffebld source, ffelexToken source_token)
-{
- ffestc_check_simple_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_branch_begin_ ();
-
- ffestd_R738 (dest, source);
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R740 -- WHERE statement
-
- ffestc_R740(expr,expr_token);
-
- Make sure statement is valid here; implement. */
-
-void
-ffestc_R740 (ffebld expr, ffelexToken expr_token)
-{
- ffestw b;
-
- ffestc_check_simple_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_branch_begin_ ();
-
- b = ffestw_update (ffestw_push (NULL));
- ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b)));
- ffestw_set_state (b, FFESTV_stateWHERE);
- ffestw_set_blocknum (b, ffestc_blocknum_++);
- ffestw_set_shriek (b, ffestc_shriek_where_lost_);
-
- ffestd_R740 (expr);
-
- /* Leave label finishing to next statement. */
-
-}
-
-/* ffestc_R742 -- WHERE-construct statement
-
- ffestc_R742(expr,expr_token);
-
- Make sure statement is valid here; implement. */
-
-void
-ffestc_R742 (ffebld expr, ffelexToken expr_token)
-{
- ffestw b;
-
- ffestc_check_simple_ ();
- if (ffestc_order_exec_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_notloop_probably_this_wont_work_ ();
-
- b = ffestw_update (ffestw_push (NULL));
- ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b)));
- ffestw_set_state (b, FFESTV_stateWHERETHEN);
- ffestw_set_blocknum (b, ffestc_blocknum_++);
- ffestw_set_shriek (b, ffestc_shriek_wherethen_);
- ffestw_set_substate (b, 0); /* Haven't seen ELSEWHERE yet. */
-
- ffestd_R742 (expr);
-}
-
-/* ffestc_R744 -- ELSE WHERE statement
-
- ffestc_R744();
-
- Make sure ffestc_kind_ identifies a WHERE block.
- Implement the ELSE of the current WHERE block. */
-
-void
-ffestc_R744 ()
-{
- ffestc_check_simple_ ();
- if (ffestc_order_where_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
-
- if (ffestw_substate (ffestw_stack_top ()) != 0)
- {
- ffebad_start (FFEBAD_SECOND_ELSE_WHERE);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
- }
-
- ffestw_set_substate (ffestw_stack_top (), 1); /* Saw ELSEWHERE. */
-
- ffestd_R744 ();
-}
-
-/* ffestc_R745 -- END WHERE statement
-
- ffestc_R745();
-
- Make sure ffestc_kind_ identifies a WHERE block.
- Implement the end of the current WHERE block. */
-
-void
-ffestc_R745 ()
-{
- ffestc_check_simple_ ();
- if (ffestc_order_where_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
-
- ffestc_shriek_wherethen_ (TRUE);
-}
-
-#endif
-/* ffestc_R803 -- Block IF (IF-THEN) statement
-
- ffestc_R803(construct_name,expr,expr_token);
-
- Make sure statement is valid here; implement. */
-
-void
-ffestc_R803 (ffelexToken construct_name, ffebld expr,
- ffelexToken expr_token UNUSED)
-{
- ffestw b;
- ffesymbol s;
-
- ffestc_check_simple_ ();
- if (ffestc_order_exec_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_notloop_ ();
-
- b = ffestw_update (ffestw_push (NULL));
- ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b)));
- ffestw_set_state (b, FFESTV_stateIFTHEN);
- ffestw_set_blocknum (b, ffestc_blocknum_++);
- ffestw_set_shriek (b, ffestc_shriek_ifthen_);
- ffestw_set_substate (b, 0); /* Haven't seen ELSE yet. */
-
- if (construct_name == NULL)
- ffestw_set_name (b, NULL);
- else
+ if (rec)
{
- ffestw_set_name (b, ffelex_token_use (construct_name));
-
- s = ffesymbol_declare_local (construct_name, FALSE);
-
- if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
+ spec1 = FFESTP_readixREC;
+ if (key)
{
- ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
- ffesymbol_set_info (s,
- ffeinfo_new (FFEINFO_basictypeNONE,
- FFEINFO_kindtypeNONE,
- 0,
- FFEINFO_kindCONSTRUCT,
- FFEINFO_whereLOCAL,
- FFETARGET_charactersizeNONE));
- s = ffecom_sym_learned (s);
- ffesymbol_signal_unreported (s);
+ spec2 = keyn;
+ goto whine; /* :::::::::::::::::::: */
}
- else
- ffesymbol_error (s, construct_name);
- }
-
- ffestd_R803 (construct_name, expr);
-}
-
-/* ffestc_R804 -- ELSE IF statement
-
- ffestc_R804(expr,expr_token,name_token);
-
- Make sure ffestc_kind_ identifies an IF block. If not
- NULL, make sure name_token gives the correct name. Implement the else
- of the IF block. */
-
-void
-ffestc_R804 (ffebld expr, ffelexToken expr_token UNUSED,
- ffelexToken name)
-{
- ffestc_check_simple_ ();
- if (ffestc_order_ifthen_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
-
- if (name != NULL)
- {
- if (ffestw_name (ffestw_stack_top ()) == NULL)
+ if (unit == FFESTV_unitCHAREXPR)
{
- ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
+ spec2 = FFESTP_readixUNIT;
+ goto whine; /* :::::::::::::::::::: */
}
- else if (ffelex_token_strcmp (name,
- ffestw_name (ffestw_stack_top ()))
- != 0)
+ if ((format == FFESTV_formatASTERISK)
+ || (format == FFESTV_formatNAMELIST))
{
- ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
- ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
- ffebad_finish ();
+ spec2 = FFESTP_readixFORMAT;
+ goto whine; /* :::::::::::::::::::: */
}
- }
-
- if (ffestw_substate (ffestw_stack_top ()) != 0)
- {
- ffebad_start (FFEBAD_AFTER_ELSE);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
- return; /* Don't upset back end with ELSEIF
- after ELSE. */
- }
-
- ffestd_R804 (expr, name);
-}
-
-/* ffestc_R805 -- ELSE statement
-
- ffestc_R805(name_token);
-
- Make sure ffestc_kind_ identifies an IF block. If not
- NULL, make sure name_token gives the correct name. Implement the ELSE
- of the IF block. */
-
-void
-ffestc_R805 (ffelexToken name)
-{
- ffestc_check_simple_ ();
- if (ffestc_order_ifthen_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
-
- if (name != NULL)
- {
- if (ffestw_name (ffestw_stack_top ()) == NULL)
+ if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present)
{
- ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
+ spec2 = FFESTP_readixADVANCE;
+ goto whine; /* :::::::::::::::::::: */
}
- else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)
+ if (ffestp_file.read.read_spec[FFESTP_readixEND].kw_or_val_present)
{
- ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
- ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
- ffebad_finish ();
+ spec2 = FFESTP_readixEND;
+ goto whine; /* :::::::::::::::::::: */
}
- }
-
- if (ffestw_substate (ffestw_stack_top ()) != 0)
- {
- ffebad_start (FFEBAD_AFTER_ELSE);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
- return; /* Tell back end about only one ELSE. */
- }
-
- ffestw_set_substate (ffestw_stack_top (), 1); /* Saw ELSE. */
-
- ffestd_R805 (name);
-}
-
-/* ffestc_R806 -- END IF statement
-
- ffestc_R806(name_token);
-
- Make sure ffestc_kind_ identifies an IF block. If not
- NULL, make sure name_token gives the correct name. Implement the end
- of the IF block. */
-
-void
-ffestc_R806 (ffelexToken name)
-{
- ffestc_check_simple_ ();
- if (ffestc_order_ifthen_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_endif_ ();
-
- if (name == NULL)
- {
- if (ffestw_name (ffestw_stack_top ()) != NULL)
+ if (ffestp_file.read.read_spec[FFESTP_readixNULLS].kw_or_val_present)
{
- ffebad_start (FFEBAD_CONSTRUCT_NAMED);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
+ spec2 = FFESTP_readixNULLS;
+ goto whine; /* :::::::::::::::::::: */
}
}
- else
+ else if (key)
{
- if (ffestw_name (ffestw_stack_top ()) == NULL)
+ spec1 = keyn;
+ if (unit == FFESTV_unitCHAREXPR)
{
- ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
+ spec2 = FFESTP_readixUNIT;
+ goto whine; /* :::::::::::::::::::: */
}
- else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)
+ if ((format == FFESTV_formatASTERISK)
+ || (format == FFESTV_formatNAMELIST))
{
- ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
- ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
- ffebad_finish ();
+ spec2 = FFESTP_readixFORMAT;
+ goto whine; /* :::::::::::::::::::: */
}
- }
-
- ffestc_shriek_ifthen_ (TRUE);
-}
-
-/* ffestc_R807 -- Logical IF statement
-
- ffestc_R807(expr,expr_token);
-
- Make sure statement is valid here; implement. */
-
-void
-ffestc_R807 (ffebld expr, ffelexToken expr_token UNUSED)
-{
- ffestw b;
-
- ffestc_check_simple_ ();
- if (ffestc_order_action_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_branch_begin_ ();
-
- b = ffestw_update (ffestw_push (NULL));
- ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b)));
- ffestw_set_state (b, FFESTV_stateIF);
- ffestw_set_blocknum (b, ffestc_blocknum_++);
- ffestw_set_shriek (b, ffestc_shriek_if_lost_);
-
- ffestd_R807 (expr);
-
- /* Do the label finishing in the next statement. */
-
-}
-
-/* ffestc_R809 -- SELECT CASE statement
-
- ffestc_R809(construct_name,expr,expr_token);
-
- Make sure statement is valid here; implement. */
-
-void
-ffestc_R809 (ffelexToken construct_name, ffebld expr, ffelexToken expr_token)
-{
- ffestw b;
- mallocPool pool;
- ffestwSelect s;
- ffesymbol sym;
-
- ffestc_check_simple_ ();
- if (ffestc_order_exec_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_notloop_ ();
-
- b = ffestw_update (ffestw_push (NULL));
- ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b)));
- ffestw_set_state (b, FFESTV_stateSELECT0);
- ffestw_set_blocknum (b, ffestc_blocknum_++);
- ffestw_set_shriek (b, ffestc_shriek_select_);
- ffestw_set_substate (b, 0); /* Haven't seen CASE DEFAULT yet. */
-
- /* Init block to manage CASE list. */
-
- pool = malloc_pool_new ("Select", ffe_pool_any_unit (), 1024);
- s = (ffestwSelect) malloc_new_kp (pool, "Select", sizeof (*s));
- s->first_rel = (ffestwCase) &s->first_rel;
- s->last_rel = (ffestwCase) &s->first_rel;
- s->first_stmt = (ffestwCase) &s->first_rel;
- s->last_stmt = (ffestwCase) &s->first_rel;
- s->pool = pool;
- s->cases = 1;
- s->t = ffelex_token_use (expr_token);
- s->type = ffeinfo_basictype (ffebld_info (expr));
- s->kindtype = ffeinfo_kindtype (ffebld_info (expr));
- ffestw_set_select (b, s);
-
- if (construct_name == NULL)
- ffestw_set_name (b, NULL);
- else
- {
- ffestw_set_name (b, ffelex_token_use (construct_name));
-
- sym = ffesymbol_declare_local (construct_name, FALSE);
-
- if (ffesymbol_state (sym) == FFESYMBOL_stateNONE)
+ if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present)
{
- ffesymbol_set_state (sym, FFESYMBOL_stateUNDERSTOOD);
- ffesymbol_set_info (sym,
- ffeinfo_new (FFEINFO_basictypeNONE,
- FFEINFO_kindtypeNONE, 0,
- FFEINFO_kindCONSTRUCT,
- FFEINFO_whereLOCAL,
- FFETARGET_charactersizeNONE));
- sym = ffecom_sym_learned (sym);
- ffesymbol_signal_unreported (sym);
+ spec2 = FFESTP_readixADVANCE;
+ goto whine; /* :::::::::::::::::::: */
}
- else
- ffesymbol_error (sym, construct_name);
- }
-
- ffestd_R809 (construct_name, expr);
-}
-
-/* ffestc_R810 -- CASE statement
-
- ffestc_R810(case_value_range_list,name);
-
- If case_value_range_list is NULL, it's CASE DEFAULT. name is the case-
- construct-name. Make sure no more than one CASE DEFAULT is present for
- a given case-construct and that there aren't any overlapping ranges or
- duplicate case values. */
-
-void
-ffestc_R810 (ffesttCaseList cases, ffelexToken name)
-{
- ffesttCaseList caseobj;
- ffestwSelect s;
- ffestwCase c, nc;
- ffebldConstant expr1c, expr2c;
-
- ffestc_check_simple_ ();
- if (ffestc_order_selectcase_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
-
- s = ffestw_select (ffestw_stack_top ());
-
- if (ffestw_state (ffestw_stack_top ()) == FFESTV_stateSELECT0)
- {
-#if 0 /* Not sure we want to have msgs point here
- instead of SELECT CASE. */
- ffestw_update (NULL); /* Update state line/col info. */
-#endif
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateSELECT1);
- }
-
- if (name != NULL)
- {
- if (ffestw_name (ffestw_stack_top ()) == NULL)
+ if (ffestp_file.read.read_spec[FFESTP_readixEND].kw_or_val_present)
{
- ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
+ spec2 = FFESTP_readixEND;
+ goto whine; /* :::::::::::::::::::: */
}
- else if (ffelex_token_strcmp (name,
- ffestw_name (ffestw_stack_top ()))
- != 0)
+ if (ffestp_file.read.read_spec[FFESTP_readixEOR].kw_or_val_present)
{
- ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
- ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
- ffebad_finish ();
+ spec2 = FFESTP_readixEOR;
+ goto whine; /* :::::::::::::::::::: */
}
- }
-
- if (cases == NULL)
- {
- if (ffestw_substate (ffestw_stack_top ()) != 0)
+ if (ffestp_file.read.read_spec[FFESTP_readixNULLS].kw_or_val_present)
{
- ffebad_start (FFEBAD_CASE_SECOND_DEFAULT);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
+ spec2 = FFESTP_readixNULLS;
+ goto whine; /* :::::::::::::::::::: */
+ }
+ if (ffestp_file.read.read_spec[FFESTP_readixREC].kw_or_val_present)
+ {
+ spec2 = FFESTP_readixREC;
+ goto whine; /* :::::::::::::::::::: */
+ }
+ if (ffestp_file.read.read_spec[FFESTP_readixSIZE].kw_or_val_present)
+ {
+ spec2 = FFESTP_readixSIZE;
+ goto whine; /* :::::::::::::::::::: */
}
-
- ffestw_set_substate (ffestw_stack_top (), 1); /* Saw ELSE. */
}
else
- { /* For each case, try to fit into sorted list
- of ranges. */
- for (caseobj = cases->next; caseobj != cases; caseobj = caseobj->next)
- {
- if ((caseobj->expr1 == NULL)
- && (!caseobj->range
- || (caseobj->expr2 == NULL)))
- { /* "CASE (:)". */
- ffebad_start (FFEBAD_CASE_BAD_RANGE);
- ffebad_here (0, ffelex_token_where_line (caseobj->t),
- ffelex_token_where_column (caseobj->t));
- ffebad_finish ();
- continue;
+ { /* Sequential/Internal. */
+ if (unit == FFESTV_unitCHAREXPR)
+ { /* Internal file. */
+ spec1 = FFESTP_readixUNIT;
+ if (format == FFESTV_formatNAMELIST)
+ {
+ spec2 = FFESTP_readixFORMAT;
+ goto whine; /* :::::::::::::::::::: */
}
- if (((caseobj->expr1 != NULL)
- && ((ffeinfo_basictype (ffebld_info (caseobj->expr1))
- != s->type)
- || ((ffeinfo_kindtype (ffebld_info (caseobj->expr1))
- != s->kindtype)
- && (ffeinfo_kindtype (ffebld_info (caseobj->expr1)) != FFEINFO_kindtypeINTEGER1 ))
- || ((caseobj->range)
- && (caseobj->expr2 != NULL)
- && ((ffeinfo_basictype (ffebld_info (caseobj->expr2))
- != s->type)
- || ((ffeinfo_kindtype (ffebld_info (caseobj->expr2))
- != s->kindtype)
- && (ffeinfo_kindtype (ffebld_info (caseobj->expr2)) != FFEINFO_kindtypeINTEGER1)))))))
+ if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present)
{
- ffebad_start (FFEBAD_CASE_TYPE_DISAGREE);
- ffebad_here (0, ffelex_token_where_line (caseobj->t),
- ffelex_token_where_column (caseobj->t));
- ffebad_here (1, ffelex_token_where_line (s->t),
- ffelex_token_where_column (s->t));
- ffebad_finish ();
- continue;
+ spec2 = FFESTP_readixADVANCE;
+ goto whine; /* :::::::::::::::::::: */
}
-
-
-
- if ((s->type == FFEINFO_basictypeLOGICAL) && (caseobj->range))
+ }
+ if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present)
+ { /* ADVANCE= specified. */
+ spec1 = FFESTP_readixADVANCE;
+ if (format == FFESTV_formatNONE)
{
- ffebad_start (FFEBAD_CASE_LOGICAL_RANGE);
- ffebad_here (0, ffelex_token_where_line (caseobj->t),
- ffelex_token_where_column (caseobj->t));
+ ffebad_start (FFEBAD_MISSING_FORMAT_SPEC);
+ ffebad_here (0, ffelex_token_where_line
+ (ffestp_file.read.read_spec[spec1].kw),
+ ffelex_token_where_column
+ (ffestp_file.read.read_spec[spec1].kw));
ffebad_finish ();
- continue;
- }
-
- if (caseobj->expr1 == NULL)
- expr1c = NULL;
- else if (ffebld_op (caseobj->expr1) != FFEBLD_opCONTER)
- continue; /* opANY. */
- else
- expr1c = ffebld_conter (caseobj->expr1);
- if (!caseobj->range)
- expr2c = expr1c; /* expr1c and expr2c are NOT NULL in this
- case. */
- else if (caseobj->expr2 == NULL)
- expr2c = NULL;
- else if (ffebld_op (caseobj->expr2) != FFEBLD_opCONTER)
- continue; /* opANY. */
- else
- expr2c = ffebld_conter (caseobj->expr2);
-
- if (expr1c == NULL)
- { /* "CASE (:high)", must be first in list. */
- c = s->first_rel;
- if ((c != (ffestwCase) &s->first_rel)
- && ((c->low == NULL)
- || (ffebld_constant_cmp (expr2c, c->low) >= 0)))
- { /* Other "CASE (:high)" or lowest "CASE
- (low[:high])" low. */
- ffebad_start (FFEBAD_CASE_DUPLICATE);
- ffebad_here (0, ffelex_token_where_line (caseobj->t),
- ffelex_token_where_column (caseobj->t));
- ffebad_here (1, ffelex_token_where_line (c->t),
- ffelex_token_where_column (c->t));
- ffebad_finish ();
- continue;
- }
- }
- else if (expr2c == NULL)
- { /* "CASE (low:)", must be last in list. */
- c = s->last_rel;
- if ((c != (ffestwCase) &s->first_rel)
- && ((c->high == NULL)
- || (ffebld_constant_cmp (expr1c, c->high) <= 0)))
- { /* Other "CASE (low:)" or lowest "CASE
- ([low:]high)" high. */
- ffebad_start (FFEBAD_CASE_DUPLICATE);
- ffebad_here (0, ffelex_token_where_line (caseobj->t),
- ffelex_token_where_column (caseobj->t));
- ffebad_here (1, ffelex_token_where_line (c->t),
- ffelex_token_where_column (c->t));
- ffebad_finish ();
- continue;
- }
- c = c->next_rel; /* Same as c = (ffestwCase) &s->first;. */
+ ffestc_ok_ = FALSE;
+ return;
}
- else
- { /* (expr1c != NULL) && (expr2c != NULL). */
- if (ffebld_constant_cmp (expr1c, expr2c) > 0)
- { /* Such as "CASE (3:1)" or "CASE ('B':'A')". */
- ffebad_start (FFEBAD_CASE_RANGE_USELESS); /* Warn/inform only. */
- ffebad_here (0, ffelex_token_where_line (caseobj->t),
- ffelex_token_where_column (caseobj->t));
- ffebad_finish ();
- continue;
- }
- for (c = s->first_rel;
- (c != (ffestwCase) &s->first_rel)
- && ((c->low == NULL)
- || (ffebld_constant_cmp (expr1c, c->low) > 0));
- c = c->next_rel)
- ;
- nc = c; /* Which one to report? */
- if (((c != (ffestwCase) &s->first_rel)
- && (ffebld_constant_cmp (expr2c, c->low) >= 0))
- || (((nc = c->previous_rel) != (ffestwCase) &s->first_rel)
- && (ffebld_constant_cmp (expr1c, nc->high) <= 0)))
- { /* Interference with range in case nc. */
- ffebad_start (FFEBAD_CASE_DUPLICATE);
- ffebad_here (0, ffelex_token_where_line (caseobj->t),
- ffelex_token_where_column (caseobj->t));
- ffebad_here (1, ffelex_token_where_line (nc->t),
- ffelex_token_where_column (nc->t));
- ffebad_finish ();
- continue;
- }
+ if (format == FFESTV_formatNAMELIST)
+ {
+ spec2 = FFESTP_readixFORMAT;
+ goto whine; /* :::::::::::::::::::: */
}
-
- /* If we reach here for this case range/value, it's ok (sorts into
- the list of ranges/values) so we give it its own case object
- sorted into the list of case statements. */
-
- nc = malloc_new_kp (s->pool, "Case range", sizeof (*nc));
- nc->next_rel = c;
- nc->previous_rel = c->previous_rel;
- nc->next_stmt = (ffestwCase) &s->first_rel;
- nc->previous_stmt = s->last_stmt;
- nc->low = expr1c;
- nc->high = expr2c;
- nc->casenum = s->cases;
- nc->t = ffelex_token_use (caseobj->t);
- nc->next_rel->previous_rel = nc;
- nc->previous_rel->next_rel = nc;
- nc->next_stmt->previous_stmt = nc;
- nc->previous_stmt->next_stmt = nc;
- }
- }
-
- ffestd_R810 ((cases == NULL) ? 0 : s->cases);
-
- s->cases++; /* Increment # of cases. */
-}
-
-/* ffestc_R811 -- END SELECT statement
-
- ffestc_R811(name_token);
-
- Make sure ffestc_kind_ identifies a SELECT block. If not
- NULL, make sure name_token gives the correct name. Implement the end
- of the SELECT block. */
-
-void
-ffestc_R811 (ffelexToken name)
-{
- ffestc_check_simple_ ();
- if (ffestc_order_selectcase_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_notloop_ ();
-
- if (name == NULL)
- {
- if (ffestw_name (ffestw_stack_top ()) != NULL)
- {
- ffebad_start (FFEBAD_CONSTRUCT_NAMED);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
- }
- }
- else
- {
- if (ffestw_name (ffestw_stack_top ()) == NULL)
- {
- ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
- }
- else if (ffelex_token_strcmp (name,
- ffestw_name (ffestw_stack_top ()))
- != 0)
- {
- ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
- ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
- ffebad_finish ();
- }
- }
-
- ffestc_shriek_select_ (TRUE);
-}
-
-/* ffestc_R819A -- Iterative labeled DO statement
-
- ffestc_R819A(construct_name,label_token,expr,expr_token);
-
- Make sure statement is valid here; implement. */
-
-void
-ffestc_R819A (ffelexToken construct_name, ffelexToken label_token, ffebld var,
- ffelexToken var_token, ffebld start, ffelexToken start_token, ffebld end,
- ffelexToken end_token, ffebld incr, ffelexToken incr_token)
-{
- ffestw b;
- ffelab label;
- ffesymbol s;
- ffesymbol varsym;
-
- ffestc_check_simple_ ();
- if (ffestc_order_exec_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_notloop_ ();
-
- if (!ffestc_labelref_is_loopend_ (label_token, &label))
- return;
-
- b = ffestw_update (ffestw_push (NULL));
- ffestw_set_top_do (b, b);
- ffestw_set_state (b, FFESTV_stateDO);
- ffestw_set_blocknum (b, ffestc_blocknum_++);
- ffestw_set_shriek (b, ffestc_shriek_do_);
- ffestw_set_label (b, label);
- switch (ffebld_op (var))
- {
- case FFEBLD_opSYMTER:
- if ((ffeinfo_basictype (ffebld_info (var)) == FFEINFO_basictypeREAL)
- && ffe_is_warn_surprising ())
- {
- ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */
- ffebad_here (0, ffelex_token_where_line (var_token),
- ffelex_token_where_column (var_token));
- ffebad_string (ffesymbol_text (ffebld_symter (var)));
- ffebad_finish ();
}
- if (!ffesymbol_is_doiter (varsym = ffebld_symter (var)))
- { /* Presumably already complained about by
- ffeexpr_lhs_. */
- ffesymbol_set_is_doiter (varsym, TRUE);
- ffestw_set_do_iter_var (b, varsym);
- ffestw_set_do_iter_var_t (b, ffelex_token_use (var_token));
- break;
+ if (ffestp_file.read.read_spec[FFESTP_readixEOR].kw_or_val_present)
+ { /* EOR= specified. */
+ spec1 = FFESTP_readixEOR;
+ if (ffestc_subr_speccmp_ ("No",
+ &ffestp_file.read.read_spec[FFESTP_readixADVANCE],
+ NULL, NULL) != 0)
+ {
+ goto whine_advance; /* :::::::::::::::::::: */
+ }
}
- /* Fall through. */
- case FFEBLD_opANY:
- ffestw_set_do_iter_var (b, NULL);
- ffestw_set_do_iter_var_t (b, NULL);
- break;
-
- default:
- assert ("bad iter var" == NULL);
- break;
- }
-
- if (construct_name == NULL)
- ffestw_set_name (b, NULL);
- else
- {
- ffestw_set_name (b, ffelex_token_use (construct_name));
-
- s = ffesymbol_declare_local (construct_name, FALSE);
-
- if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
- {
- ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
- ffesymbol_set_info (s,
- ffeinfo_new (FFEINFO_basictypeNONE,
- FFEINFO_kindtypeNONE,
- 0,
- FFEINFO_kindCONSTRUCT,
- FFEINFO_whereLOCAL,
- FFETARGET_charactersizeNONE));
- s = ffecom_sym_learned (s);
- ffesymbol_signal_unreported (s);
+ if (ffestp_file.read.read_spec[FFESTP_readixNULLS].kw_or_val_present)
+ { /* NULLS= specified. */
+ spec1 = FFESTP_readixNULLS;
+ if (format != FFESTV_formatASTERISK)
+ {
+ spec2 = FFESTP_readixFORMAT;
+ goto whine; /* :::::::::::::::::::: */
+ }
}
- else
- ffesymbol_error (s, construct_name);
- }
-
- if (incr == NULL)
- {
- incr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
- ffebld_set_info (incr, ffeinfo_new
- (FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
- }
-
- start = ffeexpr_convert_expr (start, start_token, var, var_token,
- FFEEXPR_contextLET);
- end = ffeexpr_convert_expr (end, end_token, var, var_token,
- FFEEXPR_contextLET);
- incr = ffeexpr_convert_expr (incr, incr_token, var, var_token,
- FFEEXPR_contextLET);
-
- ffestd_R819A (construct_name, label, var,
- start, start_token,
- end, end_token,
- incr, incr_token);
-}
-
-/* ffestc_R819B -- Labeled DO WHILE statement
-
- ffestc_R819B(construct_name,label_token,expr,expr_token);
-
- Make sure statement is valid here; implement. */
-
-void
-ffestc_R819B (ffelexToken construct_name, ffelexToken label_token,
- ffebld expr, ffelexToken expr_token UNUSED)
-{
- ffestw b;
- ffelab label;
- ffesymbol s;
-
- ffestc_check_simple_ ();
- if (ffestc_order_exec_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_notloop_ ();
-
- if (!ffestc_labelref_is_loopend_ (label_token, &label))
- return;
-
- b = ffestw_update (ffestw_push (NULL));
- ffestw_set_top_do (b, b);
- ffestw_set_state (b, FFESTV_stateDO);
- ffestw_set_blocknum (b, ffestc_blocknum_++);
- ffestw_set_shriek (b, ffestc_shriek_do_);
- ffestw_set_label (b, label);
- ffestw_set_do_iter_var (b, NULL);
- ffestw_set_do_iter_var_t (b, NULL);
-
- if (construct_name == NULL)
- ffestw_set_name (b, NULL);
- else
- {
- ffestw_set_name (b, ffelex_token_use (construct_name));
-
- s = ffesymbol_declare_local (construct_name, FALSE);
-
- if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
- {
- ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
- ffesymbol_set_info (s,
- ffeinfo_new (FFEINFO_basictypeNONE,
- FFEINFO_kindtypeNONE,
- 0,
- FFEINFO_kindCONSTRUCT,
- FFEINFO_whereLOCAL,
- FFETARGET_charactersizeNONE));
- s = ffecom_sym_learned (s);
- ffesymbol_signal_unreported (s);
- }
- else
- ffesymbol_error (s, construct_name);
- }
-
- ffestd_R819B (construct_name, label, expr);
-}
-
-/* ffestc_R820A -- Iterative nonlabeled DO statement
-
- ffestc_R820A(construct_name,expr,expr_token);
-
- Make sure statement is valid here; implement. */
-
-void
-ffestc_R820A (ffelexToken construct_name, ffebld var, ffelexToken var_token,
- ffebld start, ffelexToken start_token, ffebld end, ffelexToken end_token,
- ffebld incr, ffelexToken incr_token)
-{
- ffestw b;
- ffesymbol s;
- ffesymbol varsym;
-
- ffestc_check_simple_ ();
- if (ffestc_order_exec_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_notloop_ ();
-
- b = ffestw_update (ffestw_push (NULL));
- ffestw_set_top_do (b, b);
- ffestw_set_state (b, FFESTV_stateDO);
- ffestw_set_blocknum (b, ffestc_blocknum_++);
- ffestw_set_shriek (b, ffestc_shriek_do_);
- ffestw_set_label (b, NULL);
- switch (ffebld_op (var))
- {
- case FFEBLD_opSYMTER:
- if ((ffeinfo_basictype (ffebld_info (var)) == FFEINFO_basictypeREAL)
- && ffe_is_warn_surprising ())
- {
- ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */
- ffebad_here (0, ffelex_token_where_line (var_token),
- ffelex_token_where_column (var_token));
- ffebad_string (ffesymbol_text (ffebld_symter (var)));
- ffebad_finish ();
- }
- if (!ffesymbol_is_doiter (varsym = ffebld_symter (var)))
- { /* Presumably already complained about by
- ffeexpr_lhs_. */
- ffesymbol_set_is_doiter (varsym, TRUE);
- ffestw_set_do_iter_var (b, varsym);
- ffestw_set_do_iter_var_t (b, ffelex_token_use (var_token));
- break;
- }
- /* Fall through. */
- case FFEBLD_opANY:
- ffestw_set_do_iter_var (b, NULL);
- ffestw_set_do_iter_var_t (b, NULL);
- break;
-
- default:
- assert ("bad iter var" == NULL);
- break;
- }
-
- if (construct_name == NULL)
- ffestw_set_name (b, NULL);
- else
- {
- ffestw_set_name (b, ffelex_token_use (construct_name));
-
- s = ffesymbol_declare_local (construct_name, FALSE);
-
- if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
- {
- ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
- ffesymbol_set_info (s,
- ffeinfo_new (FFEINFO_basictypeNONE,
- FFEINFO_kindtypeNONE,
- 0,
- FFEINFO_kindCONSTRUCT,
- FFEINFO_whereLOCAL,
- FFETARGET_charactersizeNONE));
- s = ffecom_sym_learned (s);
- ffesymbol_signal_unreported (s);
- }
- else
- ffesymbol_error (s, construct_name);
- }
-
- if (incr == NULL)
- {
- incr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
- ffebld_set_info (incr, ffeinfo_new
- (FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
- }
-
- start = ffeexpr_convert_expr (start, start_token, var, var_token,
- FFEEXPR_contextLET);
- end = ffeexpr_convert_expr (end, end_token, var, var_token,
- FFEEXPR_contextLET);
- incr = ffeexpr_convert_expr (incr, incr_token, var, var_token,
- FFEEXPR_contextLET);
-
-#if 0
- if ((ffebld_op (incr) == FFEBLD_opCONTER)
- && (ffebld_constant_is_zero (ffebld_conter (incr))))
- {
- ffebad_start (FFEBAD_DO_STEP_ZERO);
- ffebad_here (0, ffelex_token_where_line (incr_token),
- ffelex_token_where_column (incr_token));
- ffebad_string ("Iterative DO loop");
- ffebad_finish ();
- }
-#endif
-
- ffestd_R819A (construct_name, NULL, var,
- start, start_token,
- end, end_token,
- incr, incr_token);
-}
-
-/* ffestc_R820B -- Nonlabeled DO WHILE statement
-
- ffestc_R820B(construct_name,expr,expr_token);
-
- Make sure statement is valid here; implement. */
-
-void
-ffestc_R820B (ffelexToken construct_name, ffebld expr,
- ffelexToken expr_token UNUSED)
-{
- ffestw b;
- ffesymbol s;
-
- ffestc_check_simple_ ();
- if (ffestc_order_exec_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_notloop_ ();
-
- b = ffestw_update (ffestw_push (NULL));
- ffestw_set_top_do (b, b);
- ffestw_set_state (b, FFESTV_stateDO);
- ffestw_set_blocknum (b, ffestc_blocknum_++);
- ffestw_set_shriek (b, ffestc_shriek_do_);
- ffestw_set_label (b, NULL);
- ffestw_set_do_iter_var (b, NULL);
- ffestw_set_do_iter_var_t (b, NULL);
-
- if (construct_name == NULL)
- ffestw_set_name (b, NULL);
- else
- {
- ffestw_set_name (b, ffelex_token_use (construct_name));
-
- s = ffesymbol_declare_local (construct_name, FALSE);
-
- if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
- {
- ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
- ffesymbol_set_info (s,
- ffeinfo_new (FFEINFO_basictypeNONE,
- FFEINFO_kindtypeNONE,
- 0,
- FFEINFO_kindCONSTRUCT,
- FFEINFO_whereLOCAL,
- FFETARGET_charactersizeNONE));
- s = ffecom_sym_learned (s);
- ffesymbol_signal_unreported (s);
- }
- else
- ffesymbol_error (s, construct_name);
- }
-
- ffestd_R819B (construct_name, NULL, expr);
-}
-
-/* ffestc_R825 -- END DO statement
-
- ffestc_R825(name_token);
-
- Make sure ffestc_kind_ identifies a DO block. If not
- NULL, make sure name_token gives the correct name. Implement the end
- of the DO block. */
-
-void
-ffestc_R825 (ffelexToken name)
-{
- ffestc_check_simple_ ();
- if (ffestc_order_do_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_branch_begin_ ();
-
- if (name == NULL)
- {
- if (ffestw_name (ffestw_stack_top ()) != NULL)
- {
- ffebad_start (FFEBAD_CONSTRUCT_NAMED);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
- }
- }
- else
- {
- if (ffestw_name (ffestw_stack_top ()) == NULL)
- {
- ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
- }
- else if (ffelex_token_strcmp (name,
- ffestw_name (ffestw_stack_top ()))
- != 0)
- {
- ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
- ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
- ffebad_finish ();
- }
- }
-
- if (ffesta_label_token == NULL)
- { /* If top of stack has label, its an error! */
- if (ffestw_label (ffestw_stack_top ()) != NULL)
- {
- ffebad_start (FFEBAD_DO_HAD_LABEL);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
- }
-
- ffestc_shriek_do_ (TRUE);
-
- ffestc_try_shriek_do_ ();
-
- return;
- }
-
- ffestd_R825 (name);
-
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R834 -- CYCLE statement
-
- ffestc_R834(name_token);
-
- Handle a CYCLE within a loop. */
-
-void
-ffestc_R834 (ffelexToken name)
-{
- ffestw block;
-
- ffestc_check_simple_ ();
- if (ffestc_order_actiondo_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_notloop_begin_ ();
-
- if (name == NULL)
- block = ffestw_top_do (ffestw_stack_top ());
- else
- { /* Search for name. */
- for (block = ffestw_top_do (ffestw_stack_top ());
- (block != NULL) && (ffestw_blocknum (block) != 0);
- block = ffestw_top_do (ffestw_previous (block)))
- {
- if ((ffestw_name (block) != NULL)
- && (ffelex_token_strcmp (name, ffestw_name (block)) == 0))
- break;
- }
- if ((block == NULL) || (ffestw_blocknum (block) == 0))
- {
- block = ffestw_top_do (ffestw_stack_top ());
- ffebad_start (FFEBAD_CONSTRUCT_NO_DO_NAME);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_finish ();
- }
- }
-
- ffestd_R834 (block);
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
-
- /* notloop's that are actionif's can be the target of a loop-end
- statement if they're in the "then" part of a logical IF, as
- in "DO 10", "10 IF (...) CYCLE". */
-
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R835 -- EXIT statement
-
- ffestc_R835(name_token);
-
- Handle a EXIT within a loop. */
-
-void
-ffestc_R835 (ffelexToken name)
-{
- ffestw block;
-
- ffestc_check_simple_ ();
- if (ffestc_order_actiondo_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_notloop_begin_ ();
-
- if (name == NULL)
- block = ffestw_top_do (ffestw_stack_top ());
- else
- { /* Search for name. */
- for (block = ffestw_top_do (ffestw_stack_top ());
- (block != NULL) && (ffestw_blocknum (block) != 0);
- block = ffestw_top_do (ffestw_previous (block)))
- {
- if ((ffestw_name (block) != NULL)
- && (ffelex_token_strcmp (name, ffestw_name (block)) == 0))
- break;
- }
- if ((block == NULL) || (ffestw_blocknum (block) == 0))
- {
- block = ffestw_top_do (ffestw_stack_top ());
- ffebad_start (FFEBAD_CONSTRUCT_NO_DO_NAME);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_finish ();
- }
- }
-
- ffestd_R835 (block);
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
-
- /* notloop's that are actionif's can be the target of a loop-end
- statement if they're in the "then" part of a logical IF, as
- in "DO 10", "10 IF (...) EXIT". */
-
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R836 -- GOTO statement
-
- ffestc_R836(label_token);
-
- 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
-ffestc_R836 (ffelexToken label_token)
-{
- ffelab label;
-
- ffestc_check_simple_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_notloop_begin_ ();
-
- if (ffestc_labelref_is_branch_ (label_token, &label))
- ffestd_R836 (label);
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
-
- /* notloop's that are actionif's can be the target of a loop-end
- statement if they're in the "then" part of a logical IF, as
- in "DO 10", "10 IF (...) GOTO 100". */
-
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R837 -- Computed GOTO statement
-
- ffestc_R837(label_list,expr,expr_token);
-
- 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
-ffestc_R837 (ffesttTokenList label_toks, ffebld expr,
- ffelexToken expr_token UNUSED)
-{
- ffesttTokenItem ti;
- bool ok = TRUE;
- int i;
- ffelab *labels;
-
- assert (label_toks != NULL);
-
- ffestc_check_simple_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_branch_begin_ ();
-
- labels = malloc_new_kp (ffesta_output_pool, "FFESTC labels",
- sizeof (*labels)
- * ffestt_tokenlist_count (label_toks));
-
- for (ti = label_toks->first, i = 0;
- ti != (ffesttTokenItem) &label_toks->first;
- ti = ti->next, ++i)
- {
- if (!ffestc_labelref_is_branch_ (ti->t, &labels[i]))
- {
- ok = FALSE;
- break;
- }
- }
-
- if (ok)
- ffestd_R837 (labels, ffestt_tokenlist_count (label_toks), expr);
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R838 -- ASSIGN statement
-
- ffestc_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
-ffestc_R838 (ffelexToken label_token, ffebld target,
- ffelexToken target_token UNUSED)
-{
- ffelab label;
-
- ffestc_check_simple_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_branch_begin_ ();
-
- /* Mark target symbol as target of an ASSIGN. */
- if (ffebld_op (target) == FFEBLD_opSYMTER)
- ffesymbol_set_assigned (ffebld_symter (target), TRUE);
-
- if (ffestc_labelref_is_assignable_ (label_token, &label))
- ffestd_R838 (label, target);
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R839 -- Assigned GOTO statement
-
- ffestc_R839(target,target_token,label_list);
-
- 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
-ffestc_R839 (ffebld target, ffelexToken target_token UNUSED,
- ffesttTokenList label_toks)
-{
- ffesttTokenItem ti;
- bool ok = TRUE;
- int i;
- ffelab *labels;
-
- ffestc_check_simple_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_notloop_begin_ ();
-
- if (label_toks == NULL)
- {
- labels = NULL;
- i = 0;
- }
- else
- {
- labels = malloc_new_kp (ffesta_output_pool, "FFESTC labels",
- sizeof (*labels) * ffestt_tokenlist_count (label_toks));
-
- for (ti = label_toks->first, i = 0;
- ti != (ffesttTokenItem) &label_toks->first;
- ti = ti->next, ++i)
- {
- if (!ffestc_labelref_is_branch_ (ti->t, &labels[i]))
- {
- ok = FALSE;
- break;
- }
- }
- }
-
- if (ok)
- ffestd_R839 (target, labels, i);
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
-
- /* notloop's that are actionif's can be the target of a loop-end
- statement if they're in the "then" part of a logical IF, as
- in "DO 10", "10 IF (...) GOTO I". */
-
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R840 -- Arithmetic IF statement
-
- ffestc_R840(expr,expr_token,neg,zero,pos);
-
- Make sure the labels are valid; implement. */
-
-void
-ffestc_R840 (ffebld expr, ffelexToken expr_token UNUSED,
- ffelexToken neg_token, ffelexToken zero_token,
- ffelexToken pos_token)
-{
- ffelab neg;
- ffelab zero;
- ffelab pos;
-
- ffestc_check_simple_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_notloop_begin_ ();
-
- if (ffestc_labelref_is_branch_ (neg_token, &neg)
- && ffestc_labelref_is_branch_ (zero_token, &zero)
- && ffestc_labelref_is_branch_ (pos_token, &pos))
- ffestd_R840 (expr, neg, zero, pos);
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
-
- /* notloop's that are actionif's can be the target of a loop-end
- statement if they're in the "then" part of a logical IF, as
- in "DO 10", "10 IF (...) GOTO (100,200,300), I". */
-
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R841 -- CONTINUE statement
-
- ffestc_R841(); */
-
-void
-ffestc_R841 ()
-{
- ffestc_check_simple_ ();
-
- if (ffestc_order_actionwhere_ () != FFESTC_orderOK_)
- return;
-
- switch (ffestw_state (ffestw_stack_top ()))
- {
-#if FFESTR_F90
- case FFESTV_stateWHERE:
- case FFESTV_stateWHERETHEN:
- ffestc_labeldef_useless_ ();
-
- ffestd_R841 (TRUE);
-
- /* It's okay that we call ffestc_labeldef_branch_end_ () below,
- since that will be a no-op after calling _useless_ () above. */
- break;
-#endif
-
- default:
- ffestc_labeldef_branch_begin_ ();
-
- ffestd_R841 (FALSE);
-
- break;
- }
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R842 -- STOP statement
-
- ffestc_R842(expr,expr_token);
-
- Make sure statement is valid here; implement. expr and expr_token are
- both NULL if there was no expression. */
-
-void
-ffestc_R842 (ffebld expr, ffelexToken expr_token UNUSED)
-{
- ffestc_check_simple_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_notloop_begin_ ();
-
- ffestd_R842 (expr);
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
-
- /* notloop's that are actionif's can be the target of a loop-end
- statement if they're in the "then" part of a logical IF, as
- in "DO 10", "10 IF (...) STOP". */
-
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R843 -- PAUSE statement
-
- ffestc_R843(expr,expr_token);
-
- Make sure statement is valid here; implement. expr and expr_token are
- both NULL if there was no expression. */
-
-void
-ffestc_R843 (ffebld expr, ffelexToken expr_token UNUSED)
-{
- ffestc_check_simple_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_branch_begin_ ();
-
- ffestd_R843 (expr);
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R904 -- OPEN statement
-
- ffestc_R904();
-
- Make sure an OPEN is valid in the current context, and implement it. */
-
-void
-ffestc_R904 ()
-{
- int i;
- int expect_file;
- static const char *const status_strs[] =
- {
- "New",
- "Old",
- "Replace",
- "Scratch",
- "Unknown"
- };
- static const char *const access_strs[] =
- {
- "Append",
- "Direct",
- "Keyed",
- "Sequential"
- };
- static const char *const blank_strs[] =
- {
- "Null",
- "Zero"
- };
- static const char *const carriagecontrol_strs[] =
- {
- "Fortran",
- "List",
- "None"
- };
- static const char *const dispose_strs[] =
- {
- "Delete",
- "Keep",
- "Print",
- "Print/Delete",
- "Save",
- "Submit",
- "Submit/Delete"
- };
- static const char *const form_strs[] =
- {
- "Formatted",
- "Unformatted"
- };
- static const char *const organization_strs[] =
- {
- "Indexed",
- "Relative",
- "Sequential"
- };
- static const char *const position_strs[] =
- {
- "Append",
- "AsIs",
- "Rewind"
- };
- static const char *const action_strs[] =
- {
- "Read",
- "ReadWrite",
- "Write"
- };
- static const char *const delim_strs[] =
- {
- "Apostrophe",
- "None",
- "Quote"
- };
- static const char *const recordtype_strs[] =
- {
- "Fixed",
- "Segmented",
- "Stream",
- "Stream_CR",
- "Stream_LF",
- "Variable"
- };
- static const char *const pad_strs[] =
- {
- "No",
- "Yes"
- };
-
- ffestc_check_simple_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_branch_begin_ ();
-
- if (ffestc_subr_is_branch_
- (&ffestp_file.open.open_spec[FFESTP_openixERR])
- && ffestc_subr_is_present_ ("UNIT",
- &ffestp_file.open.open_spec[FFESTP_openixUNIT]))
- {
- i = ffestc_subr_binsrch_ (status_strs,
- ARRAY_SIZE (status_strs),
- &ffestp_file.open.open_spec[FFESTP_openixSTATUS],
- "NEW, OLD, REPLACE, SCRATCH, or UNKNOWN");
- switch (i)
- {
- case 0: /* Unknown. */
- case 5: /* UNKNOWN. */
- expect_file = 2; /* Unknown, don't care about FILE=. */
- break;
-
- case 1: /* NEW. */
- case 2: /* OLD. */
- if (ffe_is_pedantic ())
- expect_file = 1; /* Yes, need FILE=. */
- else
- expect_file = 2; /* f2clib doesn't care about FILE=. */
- break;
-
- case 3: /* REPLACE. */
- expect_file = 1; /* Yes, need FILE=. */
- break;
-
- case 4: /* SCRATCH. */
- expect_file = 0; /* No, disallow FILE=. */
- break;
-
- default:
- assert ("invalid _binsrch_ result" == NULL);
- expect_file = 0;
- break;
- }
- if ((expect_file == 0)
- && ffestp_file.open.open_spec[FFESTP_openixFILE].kw_or_val_present)
- {
- ffebad_start (FFEBAD_CONFLICTING_SPECS);
- assert (ffestp_file.open.open_spec[FFESTP_openixFILE].kw_or_val_present);
- if (ffestp_file.open.open_spec[FFESTP_openixFILE].kw_present)
- {
- ffebad_here (0, ffelex_token_where_line
- (ffestp_file.open.open_spec[FFESTP_openixFILE].kw),
- ffelex_token_where_column
- (ffestp_file.open.open_spec[FFESTP_openixFILE].kw));
- }
- else
- {
- ffebad_here (0, ffelex_token_where_line
- (ffestp_file.open.open_spec[FFESTP_openixFILE].value),
- ffelex_token_where_column
- (ffestp_file.open.open_spec[FFESTP_openixFILE].value));
- }
- assert (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_or_val_present);
- if (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_present)
- {
- ffebad_here (1, ffelex_token_where_line
- (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw),
- ffelex_token_where_column
- (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw));
- }
- else
- {
- ffebad_here (1, ffelex_token_where_line
- (ffestp_file.open.open_spec[FFESTP_openixSTATUS].value),
- ffelex_token_where_column
- (ffestp_file.open.open_spec[FFESTP_openixSTATUS].value));
- }
- ffebad_finish ();
- }
- else if ((expect_file == 1)
- && !ffestp_file.open.open_spec[FFESTP_openixFILE].kw_or_val_present)
- {
- ffebad_start (FFEBAD_MISSING_SPECIFIER);
- assert (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_or_val_present);
- if (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_present)
- {
- ffebad_here (0, ffelex_token_where_line
- (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw),
- ffelex_token_where_column
- (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw));
- }
- else
- {
- ffebad_here (0, ffelex_token_where_line
- (ffestp_file.open.open_spec[FFESTP_openixSTATUS].value),
- ffelex_token_where_column
- (ffestp_file.open.open_spec[FFESTP_openixSTATUS].value));
- }
- ffebad_string ("FILE=");
- ffebad_finish ();
- }
-
- ffestc_subr_binsrch_ (access_strs, ARRAY_SIZE (access_strs),
- &ffestp_file.open.open_spec[FFESTP_openixACCESS],
- "APPEND, DIRECT, KEYED, or SEQUENTIAL");
-
- ffestc_subr_binsrch_ (blank_strs, ARRAY_SIZE (blank_strs),
- &ffestp_file.open.open_spec[FFESTP_openixBLANK],
- "NULL or ZERO");
-
- ffestc_subr_binsrch_ (carriagecontrol_strs,
- ARRAY_SIZE (carriagecontrol_strs),
- &ffestp_file.open.open_spec[FFESTP_openixCARRIAGECONTROL],
- "FORTRAN, LIST, or NONE");
-
- ffestc_subr_binsrch_ (dispose_strs, ARRAY_SIZE (dispose_strs),
- &ffestp_file.open.open_spec[FFESTP_openixDISPOSE],
- "DELETE, KEEP, PRINT, PRINT/DELETE, SAVE, SUBMIT, or SUBMIT/DELETE");
-
- ffestc_subr_binsrch_ (form_strs, ARRAY_SIZE (form_strs),
- &ffestp_file.open.open_spec[FFESTP_openixFORM],
- "FORMATTED or UNFORMATTED");
-
- ffestc_subr_binsrch_ (organization_strs, ARRAY_SIZE (organization_strs),
- &ffestp_file.open.open_spec[FFESTP_openixORGANIZATION],
- "INDEXED, RELATIVE, or SEQUENTIAL");
-
- ffestc_subr_binsrch_ (position_strs, ARRAY_SIZE (position_strs),
- &ffestp_file.open.open_spec[FFESTP_openixPOSITION],
- "APPEND, ASIS, or REWIND");
-
- ffestc_subr_binsrch_ (action_strs, ARRAY_SIZE (action_strs),
- &ffestp_file.open.open_spec[FFESTP_openixACTION],
- "READ, READWRITE, or WRITE");
-
- ffestc_subr_binsrch_ (delim_strs, ARRAY_SIZE (delim_strs),
- &ffestp_file.open.open_spec[FFESTP_openixDELIM],
- "APOSTROPHE, NONE, or QUOTE");
-
- ffestc_subr_binsrch_ (recordtype_strs, ARRAY_SIZE (recordtype_strs),
- &ffestp_file.open.open_spec[FFESTP_openixRECORDTYPE],
- "FIXED, SEGMENTED, STREAM, STREAM_CR, STREAM_LF, or VARIABLE");
-
- ffestc_subr_binsrch_ (pad_strs, ARRAY_SIZE (pad_strs),
- &ffestp_file.open.open_spec[FFESTP_openixPAD],
- "NO or YES");
-
- ffestd_R904 ();
- }
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R907 -- CLOSE statement
-
- ffestc_R907();
-
- Make sure a CLOSE is valid in the current context, and implement it. */
-
-void
-ffestc_R907 ()
-{
- static const char *const status_strs[] =
- {
- "Delete",
- "Keep",
- "Print",
- "Print/Delete",
- "Save",
- "Submit",
- "Submit/Delete"
- };
-
- ffestc_check_simple_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_branch_begin_ ();
-
- if (ffestc_subr_is_branch_
- (&ffestp_file.close.close_spec[FFESTP_closeixERR])
- && ffestc_subr_is_present_ ("UNIT",
- &ffestp_file.close.close_spec[FFESTP_closeixUNIT]))
- {
- ffestc_subr_binsrch_ (status_strs, ARRAY_SIZE (status_strs),
- &ffestp_file.close.close_spec[FFESTP_closeixSTATUS],
- "DELETE, KEEP, PRINT, PRINT/DELETE, SAVE, SUBMIT, or SUBMIT/DELETE");
-
- ffestd_R907 ();
- }
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R909_start -- READ(...) statement list begin
-
- ffestc_R909_start(FALSE);
-
- Verify that READ is valid here, and begin accepting items in the
- list. */
-
-void
-ffestc_R909_start (bool only_format)
-{
- ffestvUnit unit;
- ffestvFormat format;
- bool rec;
- bool key;
- ffestpReadIx keyn;
- ffestpReadIx spec1;
- ffestpReadIx spec2;
-
- ffestc_check_start_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_branch_begin_ ();
-
- if (!ffestc_subr_is_format_
- (&ffestp_file.read.read_spec[FFESTP_readixFORMAT]))
- {
- ffestc_ok_ = FALSE;
- return;
- }
-
- format = ffestc_subr_format_
- (&ffestp_file.read.read_spec[FFESTP_readixFORMAT]);
- ffestc_namelist_ = (format == FFESTV_formatNAMELIST);
-
- if (only_format)
- {
- ffestd_R909_start (TRUE, FFESTV_unitNONE, format, FALSE, FALSE);
-
- ffestc_ok_ = TRUE;
- return;
- }
-
- if (!ffestc_subr_is_branch_
- (&ffestp_file.read.read_spec[FFESTP_readixEOR])
- || !ffestc_subr_is_branch_
- (&ffestp_file.read.read_spec[FFESTP_readixERR])
- || !ffestc_subr_is_branch_
- (&ffestp_file.read.read_spec[FFESTP_readixEND]))
- {
- ffestc_ok_ = FALSE;
- return;
- }
-
- unit = ffestc_subr_unit_
- (&ffestp_file.read.read_spec[FFESTP_readixUNIT]);
- if (unit == FFESTV_unitNONE)
- {
- ffebad_start (FFEBAD_NO_UNIT_SPEC);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_finish ();
- ffestc_ok_ = FALSE;
- return;
- }
-
- rec = ffestp_file.read.read_spec[FFESTP_readixREC].kw_or_val_present;
-
- if (ffestp_file.read.read_spec[FFESTP_readixKEYEQ].kw_or_val_present)
- {
- key = TRUE;
- keyn = spec1 = FFESTP_readixKEYEQ;
- }
- else
- {
- key = FALSE;
- keyn = spec1 = FFESTP_readix;
- }
-
- if (ffestp_file.read.read_spec[FFESTP_readixKEYGT].kw_or_val_present)
- {
- if (key)
- {
- spec2 = FFESTP_readixKEYGT;
- whine: /* :::::::::::::::::::: */
- ffebad_start (FFEBAD_CONFLICTING_SPECS);
- assert (ffestp_file.read.read_spec[spec1].kw_or_val_present);
- if (ffestp_file.read.read_spec[spec1].kw_present)
- {
- ffebad_here (0, ffelex_token_where_line
- (ffestp_file.read.read_spec[spec1].kw),
- ffelex_token_where_column
- (ffestp_file.read.read_spec[spec1].kw));
- }
- else
- {
- ffebad_here (0, ffelex_token_where_line
- (ffestp_file.read.read_spec[spec1].value),
- ffelex_token_where_column
- (ffestp_file.read.read_spec[spec1].value));
- }
- assert (ffestp_file.read.read_spec[spec2].kw_or_val_present);
- if (ffestp_file.read.read_spec[spec2].kw_present)
- {
- ffebad_here (1, ffelex_token_where_line
- (ffestp_file.read.read_spec[spec2].kw),
- ffelex_token_where_column
- (ffestp_file.read.read_spec[spec2].kw));
- }
- else
- {
- ffebad_here (1, ffelex_token_where_line
- (ffestp_file.read.read_spec[spec2].value),
- ffelex_token_where_column
- (ffestp_file.read.read_spec[spec2].value));
- }
- ffebad_finish ();
- ffestc_ok_ = FALSE;
- return;
- }
- key = TRUE;
- keyn = spec1 = FFESTP_readixKEYGT;
- }
-
- if (ffestp_file.read.read_spec[FFESTP_readixKEYGE].kw_or_val_present)
- {
- if (key)
- {
- spec2 = FFESTP_readixKEYGT;
- goto whine; /* :::::::::::::::::::: */
- }
- key = TRUE;
- keyn = FFESTP_readixKEYGT;
- }
-
- if (rec)
- {
- spec1 = FFESTP_readixREC;
- if (key)
- {
- spec2 = keyn;
- goto whine; /* :::::::::::::::::::: */
- }
- if (unit == FFESTV_unitCHAREXPR)
- {
- spec2 = FFESTP_readixUNIT;
- goto whine; /* :::::::::::::::::::: */
- }
- if ((format == FFESTV_formatASTERISK)
- || (format == FFESTV_formatNAMELIST))
- {
- spec2 = FFESTP_readixFORMAT;
- goto whine; /* :::::::::::::::::::: */
- }
- if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present)
- {
- spec2 = FFESTP_readixADVANCE;
- goto whine; /* :::::::::::::::::::: */
- }
- if (ffestp_file.read.read_spec[FFESTP_readixEND].kw_or_val_present)
- {
- spec2 = FFESTP_readixEND;
- goto whine; /* :::::::::::::::::::: */
- }
- if (ffestp_file.read.read_spec[FFESTP_readixNULLS].kw_or_val_present)
- {
- spec2 = FFESTP_readixNULLS;
- goto whine; /* :::::::::::::::::::: */
- }
- }
- else if (key)
- {
- spec1 = keyn;
- if (unit == FFESTV_unitCHAREXPR)
- {
- spec2 = FFESTP_readixUNIT;
- goto whine; /* :::::::::::::::::::: */
- }
- if ((format == FFESTV_formatASTERISK)
- || (format == FFESTV_formatNAMELIST))
- {
- spec2 = FFESTP_readixFORMAT;
- goto whine; /* :::::::::::::::::::: */
- }
- if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present)
- {
- spec2 = FFESTP_readixADVANCE;
- goto whine; /* :::::::::::::::::::: */
- }
- if (ffestp_file.read.read_spec[FFESTP_readixEND].kw_or_val_present)
- {
- spec2 = FFESTP_readixEND;
- goto whine; /* :::::::::::::::::::: */
- }
- if (ffestp_file.read.read_spec[FFESTP_readixEOR].kw_or_val_present)
- {
- spec2 = FFESTP_readixEOR;
- goto whine; /* :::::::::::::::::::: */
- }
- if (ffestp_file.read.read_spec[FFESTP_readixNULLS].kw_or_val_present)
- {
- spec2 = FFESTP_readixNULLS;
- goto whine; /* :::::::::::::::::::: */
- }
- if (ffestp_file.read.read_spec[FFESTP_readixREC].kw_or_val_present)
- {
- spec2 = FFESTP_readixREC;
- goto whine; /* :::::::::::::::::::: */
- }
- if (ffestp_file.read.read_spec[FFESTP_readixSIZE].kw_or_val_present)
- {
- spec2 = FFESTP_readixSIZE;
- goto whine; /* :::::::::::::::::::: */
- }
- }
- else
- { /* Sequential/Internal. */
- if (unit == FFESTV_unitCHAREXPR)
- { /* Internal file. */
- spec1 = FFESTP_readixUNIT;
- if (format == FFESTV_formatNAMELIST)
- {
- spec2 = FFESTP_readixFORMAT;
- goto whine; /* :::::::::::::::::::: */
- }
- if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present)
- {
- spec2 = FFESTP_readixADVANCE;
- goto whine; /* :::::::::::::::::::: */
- }
- }
- if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present)
- { /* ADVANCE= specified. */
- spec1 = FFESTP_readixADVANCE;
- if (format == FFESTV_formatNONE)
- {
- ffebad_start (FFEBAD_MISSING_FORMAT_SPEC);
- ffebad_here (0, ffelex_token_where_line
- (ffestp_file.read.read_spec[spec1].kw),
- ffelex_token_where_column
- (ffestp_file.read.read_spec[spec1].kw));
- ffebad_finish ();
-
- ffestc_ok_ = FALSE;
- return;
- }
- if (format == FFESTV_formatNAMELIST)
- {
- spec2 = FFESTP_readixFORMAT;
- goto whine; /* :::::::::::::::::::: */
- }
- }
- if (ffestp_file.read.read_spec[FFESTP_readixEOR].kw_or_val_present)
- { /* EOR= specified. */
- spec1 = FFESTP_readixEOR;
- if (ffestc_subr_speccmp_ ("No",
- &ffestp_file.read.read_spec[FFESTP_readixADVANCE],
- NULL, NULL) != 0)
- {
- goto whine_advance; /* :::::::::::::::::::: */
- }
- }
- if (ffestp_file.read.read_spec[FFESTP_readixNULLS].kw_or_val_present)
- { /* NULLS= specified. */
- spec1 = FFESTP_readixNULLS;
- if (format != FFESTV_formatASTERISK)
- {
- spec2 = FFESTP_readixFORMAT;
- goto whine; /* :::::::::::::::::::: */
- }
- }
- if (ffestp_file.read.read_spec[FFESTP_readixSIZE].kw_or_val_present)
- { /* SIZE= specified. */
- spec1 = FFESTP_readixSIZE;
- if (ffestc_subr_speccmp_ ("No",
- &ffestp_file.read.read_spec[FFESTP_readixADVANCE],
- NULL, NULL) != 0)
- {
- whine_advance: /* :::::::::::::::::::: */
- if (ffestp_file.read.read_spec[FFESTP_readixADVANCE]
- .kw_or_val_present)
- {
- ffebad_start (FFEBAD_CONFLICTING_SPECS);
- ffebad_here (0, ffelex_token_where_line
- (ffestp_file.read.read_spec[spec1].kw),
- ffelex_token_where_column
- (ffestp_file.read.read_spec[spec1].kw));
- ffebad_here (1, ffelex_token_where_line
- (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw),
- ffelex_token_where_column
- (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw));
- ffebad_finish ();
- }
- else
- {
- ffebad_start (FFEBAD_MISSING_ADVANCE_SPEC);
- ffebad_here (0, ffelex_token_where_line
- (ffestp_file.read.read_spec[spec1].kw),
- ffelex_token_where_column
- (ffestp_file.read.read_spec[spec1].kw));
- ffebad_finish ();
- }
-
- ffestc_ok_ = FALSE;
- return;
- }
- }
- }
-
- if (unit == FFESTV_unitCHAREXPR)
- ffestc_iolist_context_ = FFEEXPR_contextIOLISTDF;
- else
- ffestc_iolist_context_ = FFEEXPR_contextIOLIST;
-
- ffestd_R909_start (FALSE, unit, format, rec, key);
-
- ffestc_ok_ = TRUE;
-}
-
-/* ffestc_R909_item -- READ statement i/o item
-
- ffestc_R909_item(expr,expr_token);
-
- Implement output-list expression. */
-
-void
-ffestc_R909_item (ffebld expr, ffelexToken expr_token)
-{
- ffestc_check_item_ ();
- if (!ffestc_ok_)
- return;
-
- if (ffestc_namelist_ != 0)
- {
- if (ffestc_namelist_ == 1)
- {
- ffestc_namelist_ = 2;
- ffebad_start (FFEBAD_NAMELIST_ITEMS);
- ffebad_here (0, ffelex_token_where_line (expr_token),
- ffelex_token_where_column (expr_token));
- ffebad_finish ();
- }
- return;
- }
-
- ffestd_R909_item (expr, expr_token);
-}
-
-/* ffestc_R909_finish -- READ statement list complete
-
- ffestc_R909_finish();
-
- Just wrap up any local activities. */
-
-void
-ffestc_R909_finish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_R909_finish ();
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R910_start -- WRITE(...) statement list begin
-
- ffestc_R910_start();
-
- Verify that WRITE is valid here, and begin accepting items in the
- list. */
-
-void
-ffestc_R910_start ()
-{
- ffestvUnit unit;
- ffestvFormat format;
- bool rec;
- ffestpWriteIx spec1;
- ffestpWriteIx spec2;
-
- ffestc_check_start_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_branch_begin_ ();
-
- if (!ffestc_subr_is_branch_
- (&ffestp_file.write.write_spec[FFESTP_writeixEOR])
- || !ffestc_subr_is_branch_
- (&ffestp_file.write.write_spec[FFESTP_writeixERR])
- || !ffestc_subr_is_format_
- (&ffestp_file.write.write_spec[FFESTP_writeixFORMAT]))
- {
- ffestc_ok_ = FALSE;
- return;
- }
-
- format = ffestc_subr_format_
- (&ffestp_file.write.write_spec[FFESTP_writeixFORMAT]);
- ffestc_namelist_ = (format == FFESTV_formatNAMELIST);
-
- unit = ffestc_subr_unit_
- (&ffestp_file.write.write_spec[FFESTP_writeixUNIT]);
- if (unit == FFESTV_unitNONE)
- {
- ffebad_start (FFEBAD_NO_UNIT_SPEC);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_finish ();
- ffestc_ok_ = FALSE;
- return;
- }
-
- rec = ffestp_file.write.write_spec[FFESTP_writeixREC].kw_or_val_present;
-
- if (rec)
- {
- spec1 = FFESTP_writeixREC;
- if (unit == FFESTV_unitCHAREXPR)
- {
- spec2 = FFESTP_writeixUNIT;
- whine: /* :::::::::::::::::::: */
- ffebad_start (FFEBAD_CONFLICTING_SPECS);
- assert (ffestp_file.write.write_spec[spec1].kw_or_val_present);
- if (ffestp_file.write.write_spec[spec1].kw_present)
- {
- ffebad_here (0, ffelex_token_where_line
- (ffestp_file.write.write_spec[spec1].kw),
- ffelex_token_where_column
- (ffestp_file.write.write_spec[spec1].kw));
- }
- else
- {
- ffebad_here (0, ffelex_token_where_line
- (ffestp_file.write.write_spec[spec1].value),
- ffelex_token_where_column
- (ffestp_file.write.write_spec[spec1].value));
- }
- assert (ffestp_file.write.write_spec[spec2].kw_or_val_present);
- if (ffestp_file.write.write_spec[spec2].kw_present)
- {
- ffebad_here (1, ffelex_token_where_line
- (ffestp_file.write.write_spec[spec2].kw),
- ffelex_token_where_column
- (ffestp_file.write.write_spec[spec2].kw));
- }
- else
- {
- ffebad_here (1, ffelex_token_where_line
- (ffestp_file.write.write_spec[spec2].value),
- ffelex_token_where_column
- (ffestp_file.write.write_spec[spec2].value));
- }
- ffebad_finish ();
- ffestc_ok_ = FALSE;
- return;
- }
- if ((format == FFESTV_formatASTERISK)
- || (format == FFESTV_formatNAMELIST))
- {
- spec2 = FFESTP_writeixFORMAT;
- goto whine; /* :::::::::::::::::::: */
- }
- if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw_or_val_present)
- {
- spec2 = FFESTP_writeixADVANCE;
- goto whine; /* :::::::::::::::::::: */
- }
- }
- else
- { /* Sequential/Indexed/Internal. */
- if (unit == FFESTV_unitCHAREXPR)
- { /* Internal file. */
- spec1 = FFESTP_writeixUNIT;
- if (format == FFESTV_formatNAMELIST)
- {
- spec2 = FFESTP_writeixFORMAT;
- goto whine; /* :::::::::::::::::::: */
- }
- if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw_or_val_present)
- {
- spec2 = FFESTP_writeixADVANCE;
- goto whine; /* :::::::::::::::::::: */
- }
- }
- if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw_or_val_present)
- { /* ADVANCE= specified. */
- spec1 = FFESTP_writeixADVANCE;
- if (format == FFESTV_formatNONE)
- {
- ffebad_start (FFEBAD_MISSING_FORMAT_SPEC);
- ffebad_here (0, ffelex_token_where_line
- (ffestp_file.write.write_spec[spec1].kw),
- ffelex_token_where_column
- (ffestp_file.write.write_spec[spec1].kw));
- ffebad_finish ();
-
- ffestc_ok_ = FALSE;
- return;
- }
- if (format == FFESTV_formatNAMELIST)
- {
- spec2 = FFESTP_writeixFORMAT;
- goto whine; /* :::::::::::::::::::: */
- }
- }
- if (ffestp_file.write.write_spec[FFESTP_writeixEOR].kw_or_val_present)
- { /* EOR= specified. */
- spec1 = FFESTP_writeixEOR;
- if (ffestc_subr_speccmp_ ("No",
- &ffestp_file.write.write_spec[FFESTP_writeixADVANCE],
- NULL, NULL) != 0)
- {
- if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE]
- .kw_or_val_present)
- {
- ffebad_start (FFEBAD_CONFLICTING_SPECS);
- ffebad_here (0, ffelex_token_where_line
- (ffestp_file.write.write_spec[spec1].kw),
- ffelex_token_where_column
- (ffestp_file.write.write_spec[spec1].kw));
- ffebad_here (1, ffelex_token_where_line
- (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw),
- ffelex_token_where_column
- (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw));
- ffebad_finish ();
- }
- else
- {
- ffebad_start (FFEBAD_MISSING_ADVANCE_SPEC);
- ffebad_here (0, ffelex_token_where_line
- (ffestp_file.write.write_spec[spec1].kw),
- ffelex_token_where_column
- (ffestp_file.write.write_spec[spec1].kw));
- ffebad_finish ();
- }
-
- ffestc_ok_ = FALSE;
- return;
- }
- }
- }
-
- if (unit == FFESTV_unitCHAREXPR)
- ffestc_iolist_context_ = FFEEXPR_contextIOLISTDF;
- else
- ffestc_iolist_context_ = FFEEXPR_contextIOLIST;
-
- ffestd_R910_start (unit, format, rec);
-
- ffestc_ok_ = TRUE;
-}
-
-/* ffestc_R910_item -- WRITE statement i/o item
-
- ffestc_R910_item(expr,expr_token);
-
- Implement output-list expression. */
-
-void
-ffestc_R910_item (ffebld expr, ffelexToken expr_token)
-{
- ffestc_check_item_ ();
- if (!ffestc_ok_)
- return;
-
- if (ffestc_namelist_ != 0)
- {
- if (ffestc_namelist_ == 1)
- {
- ffestc_namelist_ = 2;
- ffebad_start (FFEBAD_NAMELIST_ITEMS);
- ffebad_here (0, ffelex_token_where_line (expr_token),
- ffelex_token_where_column (expr_token));
- ffebad_finish ();
- }
- return;
- }
-
- ffestd_R910_item (expr, expr_token);
-}
-
-/* ffestc_R910_finish -- WRITE statement list complete
-
- ffestc_R910_finish();
-
- Just wrap up any local activities. */
-
-void
-ffestc_R910_finish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_R910_finish ();
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R911_start -- PRINT(...) statement list begin
-
- ffestc_R911_start();
-
- Verify that PRINT is valid here, and begin accepting items in the
- list. */
-
-void
-ffestc_R911_start ()
-{
- ffestvFormat format;
-
- ffestc_check_start_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_branch_begin_ ();
-
- if (!ffestc_subr_is_format_
- (&ffestp_file.print.print_spec[FFESTP_printixFORMAT]))
- {
- ffestc_ok_ = FALSE;
- return;
- }
-
- format = ffestc_subr_format_
- (&ffestp_file.print.print_spec[FFESTP_printixFORMAT]);
- ffestc_namelist_ = (format == FFESTV_formatNAMELIST);
-
- ffestd_R911_start (format);
-
- ffestc_ok_ = TRUE;
-}
-
-/* ffestc_R911_item -- PRINT statement i/o item
-
- ffestc_R911_item(expr,expr_token);
-
- Implement output-list expression. */
-
-void
-ffestc_R911_item (ffebld expr, ffelexToken expr_token)
-{
- ffestc_check_item_ ();
- if (!ffestc_ok_)
- return;
-
- if (ffestc_namelist_ != 0)
- {
- if (ffestc_namelist_ == 1)
- {
- ffestc_namelist_ = 2;
- ffebad_start (FFEBAD_NAMELIST_ITEMS);
- ffebad_here (0, ffelex_token_where_line (expr_token),
- ffelex_token_where_column (expr_token));
- ffebad_finish ();
- }
- return;
- }
-
- ffestd_R911_item (expr, expr_token);
-}
-
-/* ffestc_R911_finish -- PRINT statement list complete
-
- ffestc_R911_finish();
-
- Just wrap up any local activities. */
-
-void
-ffestc_R911_finish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_R911_finish ();
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R919 -- BACKSPACE statement
-
- ffestc_R919();
-
- Make sure a BACKSPACE is valid in the current context, and implement it. */
-
-void
-ffestc_R919 ()
-{
- ffestc_check_simple_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_branch_begin_ ();
-
- if (ffestc_subr_is_branch_
- (&ffestp_file.beru.beru_spec[FFESTP_beruixERR])
- && ffestc_subr_is_present_ ("UNIT",
- &ffestp_file.beru.beru_spec[FFESTP_beruixUNIT]))
- ffestd_R919 ();
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R920 -- ENDFILE statement
-
- ffestc_R920();
-
- Make sure a ENDFILE is valid in the current context, and implement it. */
-
-void
-ffestc_R920 ()
-{
- ffestc_check_simple_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_branch_begin_ ();
-
- if (ffestc_subr_is_branch_
- (&ffestp_file.beru.beru_spec[FFESTP_beruixERR])
- && ffestc_subr_is_present_ ("UNIT",
- &ffestp_file.beru.beru_spec[FFESTP_beruixUNIT]))
- ffestd_R920 ();
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R921 -- REWIND statement
-
- ffestc_R921();
-
- Make sure a REWIND is valid in the current context, and implement it. */
-
-void
-ffestc_R921 ()
-{
- ffestc_check_simple_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_branch_begin_ ();
-
- if (ffestc_subr_is_branch_
- (&ffestp_file.beru.beru_spec[FFESTP_beruixERR])
- && ffestc_subr_is_present_ ("UNIT",
- &ffestp_file.beru.beru_spec[FFESTP_beruixUNIT]))
- ffestd_R921 ();
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R923A -- INQUIRE statement (non-IOLENGTH version)
-
- ffestc_R923A();
-
- Make sure an INQUIRE is valid in the current context, and implement it. */
-
-void
-ffestc_R923A ()
-{
- bool by_file;
- bool by_unit;
-
- ffestc_check_simple_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_branch_begin_ ();
-
- if (ffestc_subr_is_branch_
- (&ffestp_file.inquire.inquire_spec[FFESTP_inquireixERR]))
- {
- by_file = ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE]
- .kw_or_val_present;
- by_unit = ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT]
- .kw_or_val_present;
- if (by_file && by_unit)
- {
- ffebad_start (FFEBAD_CONFLICTING_SPECS);
- assert (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw_or_val_present);
- if (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw_present)
- {
- ffebad_here (0, ffelex_token_where_line
- (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw),
- ffelex_token_where_column
- (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw));
- }
- else
- {
- ffebad_here (0, ffelex_token_where_line
- (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].value),
- ffelex_token_where_column
- (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].value));
- }
- assert (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw_or_val_present);
- if (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw_present)
- {
- ffebad_here (1, ffelex_token_where_line
- (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw),
- ffelex_token_where_column
- (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw));
- }
- else
- {
- ffebad_here (1, ffelex_token_where_line
- (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].value),
- ffelex_token_where_column
- (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].value));
- }
- ffebad_finish ();
- }
- else if (!by_file && !by_unit)
- {
- ffebad_start (FFEBAD_MISSING_SPECIFIER);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_string ("UNIT= or FILE=");
- ffebad_finish ();
- }
- else
- ffestd_R923A (by_file);
- }
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R923B_start -- INQUIRE(IOLENGTH=expr) statement list begin
-
- ffestc_R923B_start();
-
- Verify that INQUIRE is valid here, and begin accepting items in the
- list. */
-
-void
-ffestc_R923B_start ()
-{
- ffestc_check_start_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_branch_begin_ ();
-
- ffestd_R923B_start ();
-
- ffestc_ok_ = TRUE;
-}
-
-/* ffestc_R923B_item -- INQUIRE statement i/o item
-
- ffestc_R923B_item(expr,expr_token);
-
- Implement output-list expression. */
-
-void
-ffestc_R923B_item (ffebld expr, ffelexToken expr_token UNUSED)
-{
- ffestc_check_item_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_R923B_item (expr);
-}
-
-/* ffestc_R923B_finish -- INQUIRE statement list complete
-
- ffestc_R923B_finish();
-
- Just wrap up any local activities. */
-
-void
-ffestc_R923B_finish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_R923B_finish ();
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R1001 -- FORMAT statement
-
- ffestc_R1001(format_list);
-
- Make sure format_list is valid. Update label's info to indicate it is a
- FORMAT label, and (perhaps) warn if there is no label! */
-
-void
-ffestc_R1001 (ffesttFormatList f)
-{
- ffestc_check_simple_ ();
- if (ffestc_order_format_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_format_ ();
-
- ffestd_R1001 (f);
-}
-
-/* ffestc_R1102 -- PROGRAM statement
-
- ffestc_R1102(name_token);
-
- Make sure ffestc_kind_ identifies an empty block. Make sure name_token
- gives a valid name. Implement the beginning of a main program. */
-
-void
-ffestc_R1102 (ffelexToken name)
-{
- ffestw b;
- ffesymbol s;
-
- assert (name != NULL);
-
- ffestc_check_simple_ ();
- if (ffestc_order_unit_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
-
- ffestc_blocknum_ = 0;
- b = ffestw_update (ffestw_push (NULL));
- ffestw_set_top_do (b, NULL);
- ffestw_set_state (b, FFESTV_statePROGRAM0);
- ffestw_set_blocknum (b, ffestc_blocknum_++);
- ffestw_set_shriek (b, ffestc_shriek_end_program_);
-
- ffestw_set_name (b, ffelex_token_use (name));
-
- s = ffesymbol_declare_programunit (name,
- ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
-
- if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
- {
- ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
- ffesymbol_set_info (s,
- ffeinfo_new (FFEINFO_basictypeNONE,
- FFEINFO_kindtypeNONE,
- 0,
- FFEINFO_kindPROGRAM,
- FFEINFO_whereLOCAL,
- FFETARGET_charactersizeNONE));
- ffesymbol_signal_unreported (s);
- }
- else
- ffesymbol_error (s, name);
-
- ffestd_R1102 (s, name);
-}
-
-/* ffestc_R1103 -- END PROGRAM statement
-
- ffestc_R1103(name_token);
-
- Make sure ffestc_kind_ identifies the current kind of program unit. If not
- NULL, make sure name_token gives the correct name. Implement the end
- of the current program unit. */
-
-void
-ffestc_R1103 (ffelexToken name)
-{
- ffestc_check_simple_ ();
- if (ffestc_order_program_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_notloop_ ();
-
- if (name != NULL)
- {
- if (ffestw_name (ffestw_stack_top ()) == NULL)
- {
- ffebad_start (FFEBAD_PROGRAM_NOT_NAMED);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
- }
- else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)
- {
- ffebad_start (FFEBAD_UNIT_WRONG_NAME);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
- ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
- ffebad_finish ();
- }
- }
-
- ffestc_shriek_end_program_ (TRUE);
-}
-
-/* ffestc_R1105 -- MODULE statement
-
- ffestc_R1105(name_token);
-
- Make sure ffestc_kind_ identifies an empty block. Make sure name_token
- gives a valid name. Implement the beginning of a module. */
-
-#if FFESTR_F90
-void
-ffestc_R1105 (ffelexToken name)
-{
- ffestw b;
-
- assert (name != NULL);
-
- ffestc_check_simple_ ();
- if (ffestc_order_unit_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
-
- ffestc_blocknum_ = 0;
- b = ffestw_update (ffestw_push (NULL));
- ffestw_set_top_do (b, NULL);
- ffestw_set_state (b, FFESTV_stateMODULE0);
- ffestw_set_blocknum (b, ffestc_blocknum_++);
- ffestw_set_shriek (b, ffestc_shriek_module_);
- ffestw_set_name (b, ffelex_token_use (name));
-
- ffestd_R1105 (name);
-}
-
-/* ffestc_R1106 -- END MODULE statement
-
- ffestc_R1106(name_token);
-
- Make sure ffestc_kind_ identifies the current kind of program unit. If not
- NULL, make sure name_token gives the correct name. Implement the end
- of the current program unit. */
-
-void
-ffestc_R1106 (ffelexToken name)
-{
- ffestc_check_simple_ ();
- if (ffestc_order_module_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
-
- if ((name != NULL)
- && (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0))
- {
- ffebad_start (FFEBAD_UNIT_WRONG_NAME);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
- ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
- ffebad_finish ();
- }
-
- ffestc_shriek_module_ (TRUE);
-}
-
-/* ffestc_R1107_start -- USE statement list begin
-
- ffestc_R1107_start();
-
- Verify that USE is valid here, and begin accepting items in the list. */
-
-void
-ffestc_R1107_start (ffelexToken name, bool only)
-{
- ffestc_check_start_ ();
- if (ffestc_order_use_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_useless_ ();
-
- ffestd_R1107_start (name, only);
-
- ffestc_ok_ = TRUE;
-}
-
-/* ffestc_R1107_item -- USE statement for name
-
- ffestc_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
-ffestc_R1107_item (ffelexToken local, ffelexToken use)
-{
- ffestc_check_item_ ();
- assert (use != NULL);
- if (!ffestc_ok_)
- return;
-
- ffestd_R1107_item (local, use);
-}
-
-/* ffestc_R1107_finish -- USE statement list complete
-
- ffestc_R1107_finish();
-
- Just wrap up any local activities. */
-
-void
-ffestc_R1107_finish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_R1107_finish ();
-}
-
-#endif
-/* ffestc_R1111 -- BLOCK DATA statement
-
- ffestc_R1111(name_token);
-
- Make sure ffestc_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
-ffestc_R1111 (ffelexToken name)
-{
- ffestw b;
- ffesymbol s;
-
- ffestc_check_simple_ ();
- if (ffestc_order_unit_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
+ if (ffestp_file.read.read_spec[FFESTP_readixSIZE].kw_or_val_present)
+ { /* SIZE= specified. */
+ spec1 = FFESTP_readixSIZE;
+ if (ffestc_subr_speccmp_ ("No",
+ &ffestp_file.read.read_spec[FFESTP_readixADVANCE],
+ NULL, NULL) != 0)
+ {
+ whine_advance: /* :::::::::::::::::::: */
+ if (ffestp_file.read.read_spec[FFESTP_readixADVANCE]
+ .kw_or_val_present)
+ {
+ ffebad_start (FFEBAD_CONFLICTING_SPECS);
+ ffebad_here (0, ffelex_token_where_line
+ (ffestp_file.read.read_spec[spec1].kw),
+ ffelex_token_where_column
+ (ffestp_file.read.read_spec[spec1].kw));
+ ffebad_here (1, ffelex_token_where_line
+ (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw),
+ ffelex_token_where_column
+ (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw));
+ ffebad_finish ();
+ }
+ else
+ {
+ ffebad_start (FFEBAD_MISSING_ADVANCE_SPEC);
+ ffebad_here (0, ffelex_token_where_line
+ (ffestp_file.read.read_spec[spec1].kw),
+ ffelex_token_where_column
+ (ffestp_file.read.read_spec[spec1].kw));
+ ffebad_finish ();
+ }
- ffestc_blocknum_ = 0;
- b = ffestw_update (ffestw_push (NULL));
- ffestw_set_top_do (b, NULL);
- ffestw_set_state (b, FFESTV_stateBLOCKDATA0);
- ffestw_set_blocknum (b, ffestc_blocknum_++);
- ffestw_set_shriek (b, ffestc_shriek_blockdata_);
+ ffestc_ok_ = FALSE;
+ return;
+ }
+ }
+ }
- if (name == NULL)
- ffestw_set_name (b, NULL);
+ if (unit == FFESTV_unitCHAREXPR)
+ ffestc_iolist_context_ = FFEEXPR_contextIOLISTDF;
else
- ffestw_set_name (b, ffelex_token_use (name));
-
- s = ffesymbol_declare_blockdataunit (name,
- ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
+ ffestc_iolist_context_ = FFEEXPR_contextIOLIST;
- if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
- {
- ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
- ffesymbol_set_info (s,
- ffeinfo_new (FFEINFO_basictypeNONE,
- FFEINFO_kindtypeNONE,
- 0,
- FFEINFO_kindBLOCKDATA,
- FFEINFO_whereLOCAL,
- FFETARGET_charactersizeNONE));
- ffesymbol_signal_unreported (s);
- }
- else
- ffesymbol_error (s, name);
+ ffestd_R909_start (FALSE, unit, format, rec, key);
- ffestd_R1111 (s, name);
+ ffestc_ok_ = TRUE;
}
-/* ffestc_R1112 -- END BLOCK DATA statement
+/* ffestc_R909_item -- READ statement i/o item
- ffestc_R1112(name_token);
+ ffestc_R909_item(expr,expr_token);
- Make sure ffestc_kind_ identifies the current kind of program unit. If not
- NULL, make sure name_token gives the correct name. Implement the end
- of the current program unit. */
+ Implement output-list expression. */
void
-ffestc_R1112 (ffelexToken name)
+ffestc_R909_item (ffebld expr, ffelexToken expr_token)
{
- ffestc_check_simple_ ();
- if (ffestc_order_blockdata_ () != FFESTC_orderOK_)
+ ffestc_check_item_ ();
+ if (!ffestc_ok_)
return;
- ffestc_labeldef_useless_ ();
- if (name != NULL)
+ if (ffestc_namelist_ != 0)
{
- if (ffestw_name (ffestw_stack_top ()) == NULL)
- {
- ffebad_start (FFEBAD_BLOCKDATA_NOT_NAMED);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
- }
- else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)
+ if (ffestc_namelist_ == 1)
{
- ffebad_start (FFEBAD_UNIT_WRONG_NAME);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
- ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
+ ffestc_namelist_ = 2;
+ ffebad_start (FFEBAD_NAMELIST_ITEMS);
+ ffebad_here (0, ffelex_token_where_line (expr_token),
+ ffelex_token_where_column (expr_token));
ffebad_finish ();
}
+ return;
}
- ffestc_shriek_blockdata_ (TRUE);
+ ffestd_R909_item (expr, expr_token);
}
-/* ffestc_R1202 -- INTERFACE statement
-
- ffestc_R1202(operator,defined_name);
+/* ffestc_R909_finish -- READ statement list complete
- Make sure ffestc_kind_ identifies an INTERFACE block.
- Implement the end of the current interface.
+ ffestc_R909_finish();
- 15-May-90 JCB 1.1
- Allow no operator or name to mean INTERFACE by itself; missed this
- valid form when originally doing syntactic analysis code. */
+ Just wrap up any local activities. */
-#if FFESTR_F90
void
-ffestc_R1202 (ffestpDefinedOperator operator, ffelexToken name)
+ffestc_R909_finish ()
{
- ffestw b;
-
- ffestc_check_simple_ ();
- if (ffestc_order_interfacespec_ () != FFESTC_orderOK_)
+ ffestc_check_finish_ ();
+ if (!ffestc_ok_)
return;
- ffestc_labeldef_useless_ ();
-
- b = ffestw_update (ffestw_push (NULL));
- ffestw_set_top_do (b, NULL);
- ffestw_set_state (b, FFESTV_stateINTERFACE0);
- ffestw_set_blocknum (b, 0);
- ffestw_set_shriek (b, ffestc_shriek_interface_);
-
- if ((operator == FFESTP_definedoperatorNone) && (name == NULL))
- ffestw_set_substate (b, 0); /* No generic-spec, so disallow MODULE
- PROCEDURE. */
- else
- ffestw_set_substate (b, 1); /* MODULE PROCEDURE ok. */
- ffestd_R1202 (operator, name);
+ ffestd_R909_finish ();
- ffe_init_4 ();
+ if (ffestc_shriek_after1_ != NULL)
+ (*ffestc_shriek_after1_) (TRUE);
+ ffestc_labeldef_branch_end_ ();
}
-/* ffestc_R1203 -- END INTERFACE statement
+/* ffestc_R910_start -- WRITE(...) statement list begin
- ffestc_R1203();
+ ffestc_R910_start();
- Make sure ffestc_kind_ identifies an INTERFACE block.
- Implement the end of the current interface. */
+ Verify that WRITE is valid here, and begin accepting items in the
+ list. */
void
-ffestc_R1203 ()
+ffestc_R910_start ()
{
- ffestc_check_simple_ ();
- if (ffestc_order_interface_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
-
- ffestc_shriek_interface_ (TRUE);
-
- ffe_terminate_4 ();
-}
+ ffestvUnit unit;
+ ffestvFormat format;
+ bool rec;
+ ffestpWriteIx spec1;
+ ffestpWriteIx spec2;
-/* ffestc_R1205_start -- MODULE PROCEDURE statement list begin
+ ffestc_check_start_ ();
+ if (ffestc_order_actionif_ () != FFESTC_orderOK_)
+ {
+ ffestc_ok_ = FALSE;
+ return;
+ }
+ ffestc_labeldef_branch_begin_ ();
- ffestc_R1205_start();
+ if (!ffestc_subr_is_branch_
+ (&ffestp_file.write.write_spec[FFESTP_writeixEOR])
+ || !ffestc_subr_is_branch_
+ (&ffestp_file.write.write_spec[FFESTP_writeixERR])
+ || !ffestc_subr_is_format_
+ (&ffestp_file.write.write_spec[FFESTP_writeixFORMAT]))
+ {
+ ffestc_ok_ = FALSE;
+ return;
+ }
- Verify that MODULE PROCEDURE is valid here, and begin accepting items in
- the list. */
+ format = ffestc_subr_format_
+ (&ffestp_file.write.write_spec[FFESTP_writeixFORMAT]);
+ ffestc_namelist_ = (format == FFESTV_formatNAMELIST);
-void
-ffestc_R1205_start ()
-{
- ffestc_check_start_ ();
- if (ffestc_order_interface_ () != FFESTC_orderOK_)
+ unit = ffestc_subr_unit_
+ (&ffestp_file.write.write_spec[FFESTP_writeixUNIT]);
+ if (unit == FFESTV_unitNONE)
{
+ ffebad_start (FFEBAD_NO_UNIT_SPEC);
+ ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
+ ffelex_token_where_column (ffesta_tokens[0]));
+ ffebad_finish ();
ffestc_ok_ = FALSE;
return;
}
- ffestc_labeldef_useless_ ();
- if (ffestw_substate (ffestw_stack_top ()) == 0)
- {
- ffebad_start (FFEBAD_INVALID_MODULE_PROCEDURE);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
- ffestc_ok_ = FALSE;
- return;
+ rec = ffestp_file.write.write_spec[FFESTP_writeixREC].kw_or_val_present;
+
+ if (rec)
+ {
+ spec1 = FFESTP_writeixREC;
+ if (unit == FFESTV_unitCHAREXPR)
+ {
+ spec2 = FFESTP_writeixUNIT;
+ whine: /* :::::::::::::::::::: */
+ ffebad_start (FFEBAD_CONFLICTING_SPECS);
+ assert (ffestp_file.write.write_spec[spec1].kw_or_val_present);
+ if (ffestp_file.write.write_spec[spec1].kw_present)
+ {
+ ffebad_here (0, ffelex_token_where_line
+ (ffestp_file.write.write_spec[spec1].kw),
+ ffelex_token_where_column
+ (ffestp_file.write.write_spec[spec1].kw));
+ }
+ else
+ {
+ ffebad_here (0, ffelex_token_where_line
+ (ffestp_file.write.write_spec[spec1].value),
+ ffelex_token_where_column
+ (ffestp_file.write.write_spec[spec1].value));
+ }
+ assert (ffestp_file.write.write_spec[spec2].kw_or_val_present);
+ if (ffestp_file.write.write_spec[spec2].kw_present)
+ {
+ ffebad_here (1, ffelex_token_where_line
+ (ffestp_file.write.write_spec[spec2].kw),
+ ffelex_token_where_column
+ (ffestp_file.write.write_spec[spec2].kw));
+ }
+ else
+ {
+ ffebad_here (1, ffelex_token_where_line
+ (ffestp_file.write.write_spec[spec2].value),
+ ffelex_token_where_column
+ (ffestp_file.write.write_spec[spec2].value));
+ }
+ ffebad_finish ();
+ ffestc_ok_ = FALSE;
+ return;
+ }
+ if ((format == FFESTV_formatASTERISK)
+ || (format == FFESTV_formatNAMELIST))
+ {
+ spec2 = FFESTP_writeixFORMAT;
+ goto whine; /* :::::::::::::::::::: */
+ }
+ if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw_or_val_present)
+ {
+ spec2 = FFESTP_writeixADVANCE;
+ goto whine; /* :::::::::::::::::::: */
+ }
+ }
+ else
+ { /* Sequential/Indexed/Internal. */
+ if (unit == FFESTV_unitCHAREXPR)
+ { /* Internal file. */
+ spec1 = FFESTP_writeixUNIT;
+ if (format == FFESTV_formatNAMELIST)
+ {
+ spec2 = FFESTP_writeixFORMAT;
+ goto whine; /* :::::::::::::::::::: */
+ }
+ if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw_or_val_present)
+ {
+ spec2 = FFESTP_writeixADVANCE;
+ goto whine; /* :::::::::::::::::::: */
+ }
+ }
+ if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw_or_val_present)
+ { /* ADVANCE= specified. */
+ spec1 = FFESTP_writeixADVANCE;
+ if (format == FFESTV_formatNONE)
+ {
+ ffebad_start (FFEBAD_MISSING_FORMAT_SPEC);
+ ffebad_here (0, ffelex_token_where_line
+ (ffestp_file.write.write_spec[spec1].kw),
+ ffelex_token_where_column
+ (ffestp_file.write.write_spec[spec1].kw));
+ ffebad_finish ();
+
+ ffestc_ok_ = FALSE;
+ return;
+ }
+ if (format == FFESTV_formatNAMELIST)
+ {
+ spec2 = FFESTP_writeixFORMAT;
+ goto whine; /* :::::::::::::::::::: */
+ }
+ }
+ if (ffestp_file.write.write_spec[FFESTP_writeixEOR].kw_or_val_present)
+ { /* EOR= specified. */
+ spec1 = FFESTP_writeixEOR;
+ if (ffestc_subr_speccmp_ ("No",
+ &ffestp_file.write.write_spec[FFESTP_writeixADVANCE],
+ NULL, NULL) != 0)
+ {
+ if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE]
+ .kw_or_val_present)
+ {
+ ffebad_start (FFEBAD_CONFLICTING_SPECS);
+ ffebad_here (0, ffelex_token_where_line
+ (ffestp_file.write.write_spec[spec1].kw),
+ ffelex_token_where_column
+ (ffestp_file.write.write_spec[spec1].kw));
+ ffebad_here (1, ffelex_token_where_line
+ (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw),
+ ffelex_token_where_column
+ (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw));
+ ffebad_finish ();
+ }
+ else
+ {
+ ffebad_start (FFEBAD_MISSING_ADVANCE_SPEC);
+ ffebad_here (0, ffelex_token_where_line
+ (ffestp_file.write.write_spec[spec1].kw),
+ ffelex_token_where_column
+ (ffestp_file.write.write_spec[spec1].kw));
+ ffebad_finish ();
+ }
+
+ ffestc_ok_ = FALSE;
+ return;
+ }
+ }
}
- if (ffestw_state (ffestw_stack_top ()) == FFESTV_stateINTERFACE0)
- {
- ffestw_update (NULL); /* Update state line/col info. */
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateINTERFACE1);
- }
+ if (unit == FFESTV_unitCHAREXPR)
+ ffestc_iolist_context_ = FFEEXPR_contextIOLISTDF;
+ else
+ ffestc_iolist_context_ = FFEEXPR_contextIOLIST;
- ffestd_R1205_start ();
+ ffestd_R910_start (unit, format, rec);
ffestc_ok_ = TRUE;
}
-/* ffestc_R1205_item -- MODULE PROCEDURE statement for name
+/* ffestc_R910_item -- WRITE statement i/o item
- ffestc_R1205_item(name_token);
+ ffestc_R910_item(expr,expr_token);
- Make sure name_token identifies a valid object to be MODULE PROCEDUREed. */
+ Implement output-list expression. */
void
-ffestc_R1205_item (ffelexToken name)
+ffestc_R910_item (ffebld expr, ffelexToken expr_token)
{
ffestc_check_item_ ();
- assert (name != NULL);
if (!ffestc_ok_)
return;
- ffestd_R1205_item (name);
+ if (ffestc_namelist_ != 0)
+ {
+ if (ffestc_namelist_ == 1)
+ {
+ ffestc_namelist_ = 2;
+ ffebad_start (FFEBAD_NAMELIST_ITEMS);
+ ffebad_here (0, ffelex_token_where_line (expr_token),
+ ffelex_token_where_column (expr_token));
+ ffebad_finish ();
+ }
+ return;
+ }
+
+ ffestd_R910_item (expr, expr_token);
}
-/* ffestc_R1205_finish -- MODULE PROCEDURE statement list complete
+/* ffestc_R910_finish -- WRITE statement list complete
- ffestc_R1205_finish();
+ ffestc_R910_finish();
Just wrap up any local activities. */
void
-ffestc_R1205_finish ()
+ffestc_R910_finish ()
{
ffestc_check_finish_ ();
if (!ffestc_ok_)
return;
- ffestd_R1205_finish ();
+ ffestd_R910_finish ();
+
+ if (ffestc_shriek_after1_ != NULL)
+ (*ffestc_shriek_after1_) (TRUE);
+ ffestc_labeldef_branch_end_ ();
}
-#endif
-/* ffestc_R1207_start -- EXTERNAL statement list begin
+/* ffestc_R911_start -- PRINT(...) statement list begin
- ffestc_R1207_start();
+ ffestc_R911_start();
- Verify that EXTERNAL is valid here, and begin accepting items in the list. */
+ Verify that PRINT is valid here, and begin accepting items in the
+ list. */
void
-ffestc_R1207_start ()
+ffestc_R911_start ()
{
+ ffestvFormat format;
+
ffestc_check_start_ ();
- if (ffestc_order_progspec_ () != FFESTC_orderOK_)
+ if (ffestc_order_actionif_ () != FFESTC_orderOK_)
{
ffestc_ok_ = FALSE;
return;
}
- ffestc_labeldef_useless_ ();
-
- ffestd_R1207_start ();
-
- ffestc_ok_ = TRUE;
-}
-
-/* ffestc_R1207_item -- EXTERNAL statement for name
-
- ffestc_R1207_item(name_token);
-
- Make sure name_token identifies a valid object to be EXTERNALd. */
-
-void
-ffestc_R1207_item (ffelexToken name)
-{
- ffesymbol s;
- ffesymbolAttrs sa;
- ffesymbolAttrs na;
-
- ffestc_check_item_ ();
- assert (name != NULL);
- if (!ffestc_ok_)
- return;
-
- s = ffesymbol_declare_local (name, FALSE);
- sa = ffesymbol_attrs (s);
-
- /* Figure out what kind of object we've got based on previous declarations
- of or references to the object. */
-
- if (!ffesymbol_is_specable (s))
- na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
- else if (sa & FFESYMBOL_attrsANY)
- na = FFESYMBOL_attrsANY;
- else if (!(sa & ~(FFESYMBOL_attrsDUMMY
- | FFESYMBOL_attrsTYPE)))
- na = sa | FFESYMBOL_attrsEXTERNAL;
- else
- na = FFESYMBOL_attrsetNONE;
-
- /* Now see what we've got for a new object: NONE means a new error cropped
- up; ANY means an old error to be ignored; otherwise, everything's ok,
- update the object (symbol) and continue on. */
-
- if (na == FFESYMBOL_attrsetNONE)
- ffesymbol_error (s, name);
- else if (!(na & FFESYMBOL_attrsANY))
- {
- ffesymbol_set_attrs (s, na);
- ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
- ffesymbol_set_explicitwhere (s, TRUE);
- ffesymbol_reference (s, name, FALSE);
- ffesymbol_signal_unreported (s);
- }
-
- ffestd_R1207_item (name);
-}
-
-/* ffestc_R1207_finish -- EXTERNAL statement list complete
-
- ffestc_R1207_finish();
-
- Just wrap up any local activities. */
-
-void
-ffestc_R1207_finish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_R1207_finish ();
-}
-
-/* ffestc_R1208_start -- INTRINSIC statement list begin
-
- ffestc_R1208_start();
-
- Verify that INTRINSIC is valid here, and begin accepting items in the list. */
+ ffestc_labeldef_branch_begin_ ();
-void
-ffestc_R1208_start ()
-{
- ffestc_check_start_ ();
- if (ffestc_order_progspec_ () != FFESTC_orderOK_)
+ if (!ffestc_subr_is_format_
+ (&ffestp_file.print.print_spec[FFESTP_printixFORMAT]))
{
ffestc_ok_ = FALSE;
return;
}
- ffestc_labeldef_useless_ ();
- ffestd_R1208_start ();
+ format = ffestc_subr_format_
+ (&ffestp_file.print.print_spec[FFESTP_printixFORMAT]);
+ ffestc_namelist_ = (format == FFESTV_formatNAMELIST);
+
+ ffestd_R911_start (format);
ffestc_ok_ = TRUE;
}
-/* ffestc_R1208_item -- INTRINSIC statement for name
-
- ffestc_R1208_item(name_token);
-
- Make sure name_token identifies a valid object to be INTRINSICd. */
-
-void
-ffestc_R1208_item (ffelexToken name)
-{
- ffesymbol s;
- ffesymbolAttrs sa;
- ffesymbolAttrs na;
- ffeintrinGen gen;
- ffeintrinSpec spec;
- ffeintrinImp imp;
-
- ffestc_check_item_ ();
- assert (name != NULL);
- if (!ffestc_ok_)
- return;
-
- s = ffesymbol_declare_local (name, TRUE);
- sa = ffesymbol_attrs (s);
-
- /* Figure out what kind of object we've got based on previous declarations
- of or references to the object. */
-
- if (!ffesymbol_is_specable (s))
- na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
- else if (sa & FFESYMBOL_attrsANY)
- na = sa;
- else if (!(sa & ~FFESYMBOL_attrsTYPE))
- {
- if (ffeintrin_is_intrinsic (ffelex_token_text (name), name, TRUE,
- &gen, &spec, &imp)
- && ((imp == FFEINTRIN_impNONE)
-#if 0 /* Don't bother with this for now. */
- || ((ffeintrin_basictype (spec)
- == ffesymbol_basictype (s))
- && (ffeintrin_kindtype (spec)
- == ffesymbol_kindtype (s)))
-#else
- || 1
-#endif
- || !(sa & FFESYMBOL_attrsTYPE)))
- na = sa | FFESYMBOL_attrsINTRINSIC;
- else
- na = FFESYMBOL_attrsetNONE;
- }
- else
- na = FFESYMBOL_attrsetNONE;
-
- /* Now see what we've got for a new object: NONE means a new error cropped
- up; ANY means an old error to be ignored; otherwise, everything's ok,
- update the object (symbol) and continue on. */
+/* ffestc_R911_item -- PRINT statement i/o item
- if (na == FFESYMBOL_attrsetNONE)
- ffesymbol_error (s, name);
- else if (!(na & FFESYMBOL_attrsANY))
- {
- ffesymbol_set_attrs (s, na);
- ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
- ffesymbol_set_generic (s, gen);
- ffesymbol_set_specific (s, spec);
- ffesymbol_set_implementation (s, imp);
- ffesymbol_set_info (s,
- ffeinfo_new (ffesymbol_basictype (s),
- ffesymbol_kindtype (s),
- 0,
- FFEINFO_kindNONE,
- FFEINFO_whereINTRINSIC,
- ffesymbol_size (s)));
- ffesymbol_set_explicitwhere (s, TRUE);
- ffesymbol_reference (s, name, TRUE);
- }
+ ffestc_R911_item(expr,expr_token);
- ffesymbol_signal_unreported (s);
+ Implement output-list expression. */
- ffestd_R1208_item (name);
+void
+ffestc_R911_item (ffebld expr, ffelexToken expr_token)
+{
+ ffestc_check_item_ ();
+ if (!ffestc_ok_)
+ return;
+
+ if (ffestc_namelist_ != 0)
+ {
+ if (ffestc_namelist_ == 1)
+ {
+ ffestc_namelist_ = 2;
+ ffebad_start (FFEBAD_NAMELIST_ITEMS);
+ ffebad_here (0, ffelex_token_where_line (expr_token),
+ ffelex_token_where_column (expr_token));
+ ffebad_finish ();
+ }
+ return;
+ }
+
+ ffestd_R911_item (expr, expr_token);
}
-/* ffestc_R1208_finish -- INTRINSIC statement list complete
+/* ffestc_R911_finish -- PRINT statement list complete
- ffestc_R1208_finish();
+ ffestc_R911_finish();
Just wrap up any local activities. */
void
-ffestc_R1208_finish ()
+ffestc_R911_finish ()
{
ffestc_check_finish_ ();
if (!ffestc_ok_)
return;
- ffestd_R1208_finish ();
+ ffestd_R911_finish ();
+
+ if (ffestc_shriek_after1_ != NULL)
+ (*ffestc_shriek_after1_) (TRUE);
+ ffestc_labeldef_branch_end_ ();
}
-/* ffestc_R1212 -- CALL statement
+/* ffestc_R919 -- BACKSPACE statement
- ffestc_R1212(expr,expr_token);
+ ffestc_R919();
- Make sure statement is valid here; implement. */
+ Make sure a BACKSPACE is valid in the current context, and implement it. */
void
-ffestc_R1212 (ffebld expr, ffelexToken expr_token UNUSED)
+ffestc_R919 ()
{
- ffebld item; /* ITEM. */
- ffebld labexpr; /* LABTOK=>LABTER. */
- ffelab label;
- bool ok; /* TRUE if all LABTOKs were ok. */
- bool ok1; /* TRUE if a particular LABTOK is ok. */
-
ffestc_check_simple_ ();
if (ffestc_order_actionif_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_branch_begin_ ();
- if (ffebld_op (expr) != FFEBLD_opSUBRREF)
- ffestd_R841 (FALSE); /* CONTINUE. */
- else
- {
- ok = TRUE;
-
- for (item = ffebld_right (expr);
- item != NULL;
- item = ffebld_trail (item))
- {
- if (((labexpr = ffebld_head (item)) != NULL)
- && (ffebld_op (labexpr) == FFEBLD_opLABTOK))
- {
- ok1 = ffestc_labelref_is_branch_ (ffebld_labtok (labexpr),
- &label);
- ffelex_token_kill (ffebld_labtok (labexpr));
- if (!ok1)
- {
- label = NULL;
- ok = FALSE;
- }
- ffebld_set_op (labexpr, FFEBLD_opLABTER);
- ffebld_set_labter (labexpr, label);
- }
- }
-
- if (ok)
- ffestd_R1212 (expr);
- }
+ if (ffestc_subr_is_branch_
+ (&ffestp_file.beru.beru_spec[FFESTP_beruixERR])
+ && ffestc_subr_is_present_ ("UNIT",
+ &ffestp_file.beru.beru_spec[FFESTP_beruixUNIT]))
+ ffestd_R919 ();
if (ffestc_shriek_after1_ != NULL)
(*ffestc_shriek_after1_) (TRUE);
ffestc_labeldef_branch_end_ ();
}
-/* ffestc_R1213 -- Defined assignment statement
+/* ffestc_R920 -- ENDFILE statement
- ffestc_R1213(dest_expr,source_expr,source_token);
+ ffestc_R920();
- Make sure the assignment is valid. */
+ Make sure a ENDFILE is valid in the current context, and implement it. */
-#if FFESTR_F90
void
-ffestc_R1213 (ffebld dest, ffebld source, ffelexToken source_token)
+ffestc_R920 ()
{
ffestc_check_simple_ ();
if (ffestc_order_actionif_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_branch_begin_ ();
- ffestd_R1213 (dest, source);
+ if (ffestc_subr_is_branch_
+ (&ffestp_file.beru.beru_spec[FFESTP_beruixERR])
+ && ffestc_subr_is_present_ ("UNIT",
+ &ffestp_file.beru.beru_spec[FFESTP_beruixUNIT]))
+ ffestd_R920 ();
if (ffestc_shriek_after1_ != NULL)
(*ffestc_shriek_after1_) (TRUE);
ffestc_labeldef_branch_end_ ();
}
-#endif
-/* ffestc_R1219 -- FUNCTION statement
-
- ffestc_R1219(funcname,arglist,ending_token,kind,kindt,len,lent,
- recursive);
+/* ffestc_R921 -- REWIND statement
- Make sure statement is valid here, register arguments for the
- function name, and so on.
+ ffestc_R921();
- 06-Apr-90 JCB 2.0
- Added the kind, len, and recursive arguments. */
+ Make sure a REWIND is valid in the current context, and implement it. */
void
-ffestc_R1219 (ffelexToken funcname, ffesttTokenList args,
- ffelexToken final UNUSED, ffestpType type, ffebld kind,
- ffelexToken kindt, ffebld len, ffelexToken lent,
- ffelexToken recursive, ffelexToken result)
+ffestc_R921 ()
{
- ffestw b;
- ffesymbol s;
- ffesymbol fs; /* FUNCTION symbol when dealing with RESULT
- symbol. */
- ffesymbolAttrs sa;
- ffesymbolAttrs na;
- ffelexToken res;
- bool separate_result;
-
- assert ((funcname != NULL)
- && (ffelex_token_type (funcname) == FFELEX_typeNAME));
-
ffestc_check_simple_ ();
- if (ffestc_order_iface_ () != FFESTC_orderOK_)
+ if (ffestc_order_actionif_ () != FFESTC_orderOK_)
return;
- ffestc_labeldef_useless_ ();
-
- ffestc_blocknum_ = 0;
- ffesta_is_entry_valid =
- (ffestw_state (ffestw_stack_top ()) == FFESTV_stateNIL);
- b = ffestw_update (ffestw_push (NULL));
- ffestw_set_top_do (b, NULL);
- ffestw_set_state (b, FFESTV_stateFUNCTION0);
- ffestw_set_blocknum (b, ffestc_blocknum_++);
- ffestw_set_shriek (b, ffestc_shriek_function_);
- ffestw_set_name (b, ffelex_token_use (funcname));
-
- if (type == FFESTP_typeNone)
- {
- ffestc_local_.decl.basic_type = FFEINFO_basictypeNONE;
- ffestc_local_.decl.kind_type = FFEINFO_kindtypeNONE;
- ffestc_local_.decl.size = FFETARGET_charactersizeNONE;
- }
- else
- {
- ffestc_establish_declstmt_ (type, ffesta_tokens[0],
- kind, kindt, len, lent);
- ffestc_establish_declinfo_ (NULL, NULL, NULL, NULL);
- }
-
- separate_result = (result != NULL)
- && (ffelex_token_strcmp (funcname, result) != 0);
-
- if (separate_result)
- fs = ffesymbol_declare_funcnotresunit (funcname); /* Global/local. */
- else
- fs = ffesymbol_declare_funcunit (funcname); /* Global only. */
-
- if (ffesymbol_state (fs) == FFESYMBOL_stateNONE)
- {
- ffesymbol_set_state (fs, FFESYMBOL_stateUNDERSTOOD);
- ffesymbol_signal_unreported (fs);
-
- /* Note that .basic_type and .kind_type might be NONE here. */
+ ffestc_labeldef_branch_begin_ ();
- ffesymbol_set_info (fs,
- ffeinfo_new (ffestc_local_.decl.basic_type,
- ffestc_local_.decl.kind_type,
- 0,
- FFEINFO_kindFUNCTION,
- FFEINFO_whereLOCAL,
- ffestc_local_.decl.size));
+ if (ffestc_subr_is_branch_
+ (&ffestp_file.beru.beru_spec[FFESTP_beruixERR])
+ && ffestc_subr_is_present_ ("UNIT",
+ &ffestp_file.beru.beru_spec[FFESTP_beruixUNIT]))
+ ffestd_R921 ();
- /* Check whether the type info fits the filewide expectations;
- set ok flag accordingly. */
+ if (ffestc_shriek_after1_ != NULL)
+ (*ffestc_shriek_after1_) (TRUE);
+ ffestc_labeldef_branch_end_ ();
+}
- ffesymbol_reference (fs, funcname, FALSE);
- if (ffesymbol_attrs (fs) & FFESYMBOL_attrsANY)
- ffestc_parent_ok_ = FALSE;
- else
- ffestc_parent_ok_ = TRUE;
- }
- else
- {
- if (ffesymbol_kind (fs) != FFEINFO_kindANY)
- ffesymbol_error (fs, funcname);
- ffestc_parent_ok_ = FALSE;
- }
+/* ffestc_R923A -- INQUIRE statement (non-IOLENGTH version)
- if (ffestc_parent_ok_)
- {
- ffebld_init_list (&fs->dummy_args, &ffestc_local_.dummy.list_bottom);
- ffestt_tokenlist_drive (args, ffestc_promote_dummy_);
- ffebld_end_list (&ffestc_local_.dummy.list_bottom);
- }
+ ffestc_R923A();
- if (result == NULL)
- res = funcname;
- else
- res = result;
+ Make sure an INQUIRE is valid in the current context, and implement it. */
- s = ffesymbol_declare_funcresult (res);
- sa = ffesymbol_attrs (s);
+void
+ffestc_R923A ()
+{
+ bool by_file;
+ bool by_unit;
- /* Figure out what kind of object we've got based on previous declarations
- of or references to the object. */
+ ffestc_check_simple_ ();
+ if (ffestc_order_actionif_ () != FFESTC_orderOK_)
+ return;
+ ffestc_labeldef_branch_begin_ ();
- if (sa & FFESYMBOL_attrsANY)
- na = FFESYMBOL_attrsANY;
- else if (ffesymbol_state (s) != FFESYMBOL_stateNONE)
- na = FFESYMBOL_attrsetNONE;
- else
+ if (ffestc_subr_is_branch_
+ (&ffestp_file.inquire.inquire_spec[FFESTP_inquireixERR]))
{
- na = FFESYMBOL_attrsRESULT;
- if (ffestc_local_.decl.basic_type != FFEINFO_basictypeNONE)
+ by_file = ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE]
+ .kw_or_val_present;
+ by_unit = ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT]
+ .kw_or_val_present;
+ if (by_file && by_unit)
{
- na |= FFESYMBOL_attrsTYPE;
- if ((ffestc_local_.decl.basic_type == FFEINFO_basictypeCHARACTER)
- && (ffestc_local_.decl.size == FFETARGET_charactersizeNONE))
- na |= FFESYMBOL_attrsANYLEN;
+ ffebad_start (FFEBAD_CONFLICTING_SPECS);
+ assert (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw_or_val_present);
+ if (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw_present)
+ {
+ ffebad_here (0, ffelex_token_where_line
+ (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw),
+ ffelex_token_where_column
+ (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw));
+ }
+ else
+ {
+ ffebad_here (0, ffelex_token_where_line
+ (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].value),
+ ffelex_token_where_column
+ (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].value));
+ }
+ assert (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw_or_val_present);
+ if (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw_present)
+ {
+ ffebad_here (1, ffelex_token_where_line
+ (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw),
+ ffelex_token_where_column
+ (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw));
+ }
+ else
+ {
+ ffebad_here (1, ffelex_token_where_line
+ (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].value),
+ ffelex_token_where_column
+ (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].value));
+ }
+ ffebad_finish ();
}
- }
-
- /* Now see what we've got for a new object: NONE means a new error cropped
- up; ANY means an old error to be ignored; otherwise, everything's ok,
- update the object (symbol) and continue on. */
-
- if ((na & ~FFESYMBOL_attrsANY) == FFESYMBOL_attrsetNONE)
- {
- if (!(na & FFESYMBOL_attrsANY))
- ffesymbol_error (s, res);
- ffesymbol_set_funcresult (fs, NULL);
- ffesymbol_set_funcresult (s, NULL);
- ffestc_parent_ok_ = FALSE;
- }
- else
- {
- ffesymbol_set_attrs (s, na);
- ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
- ffesymbol_set_funcresult (fs, s);
- ffesymbol_set_funcresult (s, fs);
- if (ffestc_local_.decl.basic_type != FFEINFO_basictypeNONE)
+ else if (!by_file && !by_unit)
{
- ffesymbol_set_info (s,
- ffeinfo_new (ffestc_local_.decl.basic_type,
- ffestc_local_.decl.kind_type,
- 0,
- FFEINFO_kindNONE,
- FFEINFO_whereNONE,
- ffestc_local_.decl.size));
+ ffebad_start (FFEBAD_MISSING_SPECIFIER);
+ ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
+ ffelex_token_where_column (ffesta_tokens[0]));
+ ffebad_string ("UNIT= or FILE=");
+ ffebad_finish ();
}
+ else
+ ffestd_R923A (by_file);
}
- ffesymbol_signal_unreported (fs);
-
- ffestd_R1219 (fs, funcname, args, type, kind, kindt, len, lent,
- (recursive != NULL), result, separate_result);
+ if (ffestc_shriek_after1_ != NULL)
+ (*ffestc_shriek_after1_) (TRUE);
+ ffestc_labeldef_branch_end_ ();
}
-/* ffestc_R1221 -- END FUNCTION statement
+/* ffestc_R923B_start -- INQUIRE(IOLENGTH=expr) statement list begin
- ffestc_R1221(name_token);
+ ffestc_R923B_start();
- Make sure ffestc_kind_ identifies the current kind of program unit. If
- not NULL, make sure name_token gives the correct name. Implement the end
- of the current program unit. */
+ Verify that INQUIRE is valid here, and begin accepting items in the
+ list. */
void
-ffestc_R1221 (ffelexToken name)
+ffestc_R923B_start ()
{
- ffestc_check_simple_ ();
- if (ffestc_order_function_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_notloop_ ();
-
- if ((name != NULL)
- && (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0))
+ ffestc_check_start_ ();
+ if (ffestc_order_actionif_ () != FFESTC_orderOK_)
{
- ffebad_start (FFEBAD_UNIT_WRONG_NAME);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
- ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
- ffebad_finish ();
+ ffestc_ok_ = FALSE;
+ return;
}
+ ffestc_labeldef_branch_begin_ ();
- ffestc_shriek_function_ (TRUE);
-}
+ ffestd_R923B_start ();
-/* ffestc_R1223 -- SUBROUTINE statement
+ ffestc_ok_ = TRUE;
+}
- ffestc_R1223(subrname,arglist,ending_token,recursive_token);
+/* ffestc_R923B_item -- INQUIRE statement i/o item
- Make sure statement is valid here, register arguments for the
- subroutine name, and so on.
+ ffestc_R923B_item(expr,expr_token);
- 06-Apr-90 JCB 2.0
- Added the recursive argument. */
+ Implement output-list expression. */
void
-ffestc_R1223 (ffelexToken subrname, ffesttTokenList args,
- ffelexToken final, ffelexToken recursive)
+ffestc_R923B_item (ffebld expr, ffelexToken expr_token UNUSED)
{
- ffestw b;
- ffesymbol s;
+ ffestc_check_item_ ();
+ if (!ffestc_ok_)
+ return;
- assert ((subrname != NULL)
- && (ffelex_token_type (subrname) == FFELEX_typeNAME));
+ ffestd_R923B_item (expr);
+}
- ffestc_check_simple_ ();
- if (ffestc_order_iface_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
+/* ffestc_R923B_finish -- INQUIRE statement list complete
- ffestc_blocknum_ = 0;
- ffesta_is_entry_valid
- = (ffestw_state (ffestw_stack_top ()) == FFESTV_stateNIL);
- b = ffestw_update (ffestw_push (NULL));
- ffestw_set_top_do (b, NULL);
- ffestw_set_state (b, FFESTV_stateSUBROUTINE0);
- ffestw_set_blocknum (b, ffestc_blocknum_++);
- ffestw_set_shriek (b, ffestc_shriek_subroutine_);
- ffestw_set_name (b, ffelex_token_use (subrname));
+ ffestc_R923B_finish();
- s = ffesymbol_declare_subrunit (subrname);
- if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
- {
- ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
- ffesymbol_set_info (s,
- ffeinfo_new (FFEINFO_basictypeNONE,
- FFEINFO_kindtypeNONE,
- 0,
- FFEINFO_kindSUBROUTINE,
- FFEINFO_whereLOCAL,
- FFETARGET_charactersizeNONE));
- ffestc_parent_ok_ = TRUE;
- }
- else
- {
- if (ffesymbol_kind (s) != FFEINFO_kindANY)
- ffesymbol_error (s, subrname);
- ffestc_parent_ok_ = FALSE;
- }
+ Just wrap up any local activities. */
- if (ffestc_parent_ok_)
- {
- ffebld_init_list (&s->dummy_args, &ffestc_local_.dummy.list_bottom);
- ffestt_tokenlist_drive (args, ffestc_promote_dummy_);
- ffebld_end_list (&ffestc_local_.dummy.list_bottom);
- }
+void
+ffestc_R923B_finish ()
+{
+ ffestc_check_finish_ ();
+ if (!ffestc_ok_)
+ return;
- ffesymbol_signal_unreported (s);
+ ffestd_R923B_finish ();
- ffestd_R1223 (s, subrname, args, final, (recursive != NULL));
+ if (ffestc_shriek_after1_ != NULL)
+ (*ffestc_shriek_after1_) (TRUE);
+ ffestc_labeldef_branch_end_ ();
}
-/* ffestc_R1225 -- END SUBROUTINE statement
+/* ffestc_R1001 -- FORMAT statement
- ffestc_R1225(name_token);
+ ffestc_R1001(format_list);
- Make sure ffestc_kind_ identifies the current kind of program unit. If
- not NULL, make sure name_token gives the correct name. Implement the end
- of the current program unit. */
+ Make sure format_list is valid. Update label's info to indicate it is a
+ FORMAT label, and (perhaps) warn if there is no label! */
void
-ffestc_R1225 (ffelexToken name)
+ffestc_R1001 (ffesttFormatList f)
{
ffestc_check_simple_ ();
- if (ffestc_order_subroutine_ () != FFESTC_orderOK_)
+ if (ffestc_order_format_ () != FFESTC_orderOK_)
return;
- ffestc_labeldef_notloop_ ();
-
- if ((name != NULL)
- && (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0))
- {
- ffebad_start (FFEBAD_UNIT_WRONG_NAME);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
- ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
- ffebad_finish ();
- }
+ ffestc_labeldef_format_ ();
- ffestc_shriek_subroutine_ (TRUE);
+ ffestd_R1001 (f);
}
-/* ffestc_R1226 -- ENTRY statement
+/* ffestc_R1102 -- PROGRAM statement
- ffestc_R1226(entryname,arglist,ending_token);
+ ffestc_R1102(name_token);
- Make sure we're in a SUBROUTINE or FUNCTION, register arguments for the
- entry point name, and so on. */
+ Make sure ffestc_kind_ identifies an empty block. Make sure name_token
+ gives a valid name. Implement the beginning of a main program. */
void
-ffestc_R1226 (ffelexToken entryname, ffesttTokenList args,
- ffelexToken final UNUSED)
+ffestc_R1102 (ffelexToken name)
{
+ ffestw b;
ffesymbol s;
- ffesymbol fs;
- ffesymbolAttrs sa;
- ffesymbolAttrs na;
- bool in_spec; /* TRUE if further specification statements
- may follow, FALSE if executable stmts. */
- bool in_func; /* TRUE if ENTRY is a FUNCTION, not
- SUBROUTINE. */
- assert ((entryname != NULL)
- && (ffelex_token_type (entryname) == FFELEX_typeNAME));
+ assert (name != NULL);
ffestc_check_simple_ ();
- if (ffestc_order_entry_ () != FFESTC_orderOK_)
+ if (ffestc_order_unit_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_useless_ ();
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateFUNCTION1:
- case FFESTV_stateFUNCTION2:
- case FFESTV_stateFUNCTION3:
- in_func = TRUE;
- in_spec = TRUE;
- break;
-
- case FFESTV_stateFUNCTION4:
- in_func = TRUE;
- in_spec = FALSE;
- break;
-
- case FFESTV_stateSUBROUTINE1:
- case FFESTV_stateSUBROUTINE2:
- case FFESTV_stateSUBROUTINE3:
- in_func = FALSE;
- in_spec = TRUE;
- break;
-
- case FFESTV_stateSUBROUTINE4:
- in_func = FALSE;
- in_spec = FALSE;
- break;
+ ffestc_blocknum_ = 0;
+ b = ffestw_update (ffestw_push (NULL));
+ ffestw_set_top_do (b, NULL);
+ ffestw_set_state (b, FFESTV_statePROGRAM0);
+ ffestw_set_blocknum (b, ffestc_blocknum_++);
+ ffestw_set_shriek (b, ffestc_shriek_end_program_);
- default:
- assert ("ENTRY not in FUNCTION or SUBROUTINE?" == NULL);
- in_func = FALSE;
- in_spec = FALSE;
- break;
- }
+ ffestw_set_name (b, ffelex_token_use (name));
- if (in_func)
- fs = ffesymbol_declare_funcunit (entryname);
- else
- fs = ffesymbol_declare_subrunit (entryname);
+ s = ffesymbol_declare_programunit (name,
+ ffelex_token_where_line (ffesta_tokens[0]),
+ ffelex_token_where_column (ffesta_tokens[0]));
- if (ffesymbol_state (fs) == FFESYMBOL_stateNONE)
- ffesymbol_set_state (fs, FFESYMBOL_stateUNDERSTOOD);
- else
+ if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
{
- if (ffesymbol_kind (fs) != FFEINFO_kindANY)
- ffesymbol_error (fs, entryname);
+ ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
+ ffesymbol_set_info (s,
+ ffeinfo_new (FFEINFO_basictypeNONE,
+ FFEINFO_kindtypeNONE,
+ 0,
+ FFEINFO_kindPROGRAM,
+ FFEINFO_whereLOCAL,
+ FFETARGET_charactersizeNONE));
+ ffesymbol_signal_unreported (s);
}
-
- ++ffestc_entry_num_;
-
- ffebld_init_list (&fs->dummy_args, &ffestc_local_.dummy.list_bottom);
- if (in_spec)
- ffestt_tokenlist_drive (args, ffestc_promote_dummy_);
else
- ffestt_tokenlist_drive (args, ffestc_promote_execdummy_);
- ffebld_end_list (&ffestc_local_.dummy.list_bottom);
+ ffesymbol_error (s, name);
- if (in_func)
- {
- s = ffesymbol_declare_funcresult (entryname);
- ffesymbol_set_funcresult (fs, s);
- ffesymbol_set_funcresult (s, fs);
- sa = ffesymbol_attrs (s);
+ ffestd_R1102 (s, name);
+}
- /* Figure out what kind of object we've got based on previous
- declarations of or references to the object. */
+/* ffestc_R1103 -- END PROGRAM statement
- if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
- na = FFESYMBOL_attrsetNONE;
- else if (sa & FFESYMBOL_attrsANY)
- na = FFESYMBOL_attrsANY;
- else if (!(sa & ~(FFESYMBOL_attrsANYLEN
- | FFESYMBOL_attrsTYPE)))
- na = sa | FFESYMBOL_attrsRESULT;
- else
- na = FFESYMBOL_attrsetNONE;
+ ffestc_R1103(name_token);
- /* Now see what we've got for a new object: NONE means a new error
- cropped up; ANY means an old error to be ignored; otherwise,
- everything's ok, update the object (symbol) and continue on. */
+ Make sure ffestc_kind_ identifies the current kind of program unit. If not
+ NULL, make sure name_token gives the correct name. Implement the end
+ of the current program unit. */
- if (na == FFESYMBOL_attrsetNONE)
- {
- ffesymbol_error (s, entryname);
- ffestc_parent_ok_ = FALSE;
- }
- else if (na & FFESYMBOL_attrsANY)
+void
+ffestc_R1103 (ffelexToken name)
+{
+ ffestc_check_simple_ ();
+ if (ffestc_order_program_ () != FFESTC_orderOK_)
+ return;
+ ffestc_labeldef_notloop_ ();
+
+ if (name != NULL)
+ {
+ if (ffestw_name (ffestw_stack_top ()) == NULL)
{
- ffestc_parent_ok_ = FALSE;
+ ffebad_start (FFEBAD_PROGRAM_NOT_NAMED);
+ ffebad_here (0, ffelex_token_where_line (name),
+ ffelex_token_where_column (name));
+ ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
+ ffebad_finish ();
}
- else
+ else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)
{
- ffesymbol_set_attrs (s, na);
- if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
- ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
- else if (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN)
- {
- ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
- ffesymbol_set_info (s,
- ffeinfo_new (ffesymbol_basictype (s),
- ffesymbol_kindtype (s),
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereRESULT,
- ffesymbol_size (s)));
- ffesymbol_resolve_intrin (s);
- ffestorag_exec_layout (s);
- }
+ ffebad_start (FFEBAD_UNIT_WRONG_NAME);
+ ffebad_here (0, ffelex_token_where_line (name),
+ ffelex_token_where_column (name));
+ ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
+ ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
+ ffebad_finish ();
}
+ }
- /* Since ENTRY might appear after executable stmts, do what would have
- been done if it hadn't -- give symbol implicit type and
- exec-transition it. */
-
- if (!in_spec && ffesymbol_is_specable (s))
- {
- if (!ffeimplic_establish_symbol (s)) /* Do implicit typing. */
- ffesymbol_error (s, entryname);
- s = ffecom_sym_exec_transition (s);
- }
+ ffestc_shriek_end_program_ (TRUE);
+}
- /* Use whatever type info is available for ENTRY to set up type for its
- global-name-space function symbol relative. */
+/* ffestc_R1111 -- BLOCK DATA statement
- ffesymbol_set_info (fs,
- ffeinfo_new (ffesymbol_basictype (s),
- ffesymbol_kindtype (s),
- 0,
- FFEINFO_kindFUNCTION,
- FFEINFO_whereLOCAL,
- ffesymbol_size (s)));
+ ffestc_R1111(name_token);
+ Make sure ffestc_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. */
- /* Check whether the type info fits the filewide expectations;
- set ok flag accordingly. */
+void
+ffestc_R1111 (ffelexToken name)
+{
+ ffestw b;
+ ffesymbol s;
- ffesymbol_reference (fs, entryname, FALSE);
+ ffestc_check_simple_ ();
+ if (ffestc_order_unit_ () != FFESTC_orderOK_)
+ return;
+ ffestc_labeldef_useless_ ();
- /* ~~Question??:
- When ENTRY FOO() RESULT(IBAR) is supported, what will the typing be
- if FOO and IBAR would normally end up with different types? I think
- the answer is that FOO is always given whatever type would be chosen
- for IBAR, rather than the other way around, and I think it ends up
- working that way for FUNCTION FOO() RESULT(IBAR), but this should be
- checked out in all its different combos. Related question is, is
- there any way that FOO in either case ends up without type info
- filled in? Does anyone care? */
+ ffestc_blocknum_ = 0;
+ b = ffestw_update (ffestw_push (NULL));
+ ffestw_set_top_do (b, NULL);
+ ffestw_set_state (b, FFESTV_stateBLOCKDATA0);
+ ffestw_set_blocknum (b, ffestc_blocknum_++);
+ ffestw_set_shriek (b, ffestc_shriek_blockdata_);
- ffesymbol_signal_unreported (s);
- }
+ if (name == NULL)
+ ffestw_set_name (b, NULL);
else
+ ffestw_set_name (b, ffelex_token_use (name));
+
+ s = ffesymbol_declare_blockdataunit (name,
+ ffelex_token_where_line (ffesta_tokens[0]),
+ ffelex_token_where_column (ffesta_tokens[0]));
+
+ if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
{
- ffesymbol_set_info (fs,
+ ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
+ ffesymbol_set_info (s,
ffeinfo_new (FFEINFO_basictypeNONE,
FFEINFO_kindtypeNONE,
0,
- FFEINFO_kindSUBROUTINE,
+ FFEINFO_kindBLOCKDATA,
FFEINFO_whereLOCAL,
FFETARGET_charactersizeNONE));
+ ffesymbol_signal_unreported (s);
}
+ else
+ ffesymbol_error (s, name);
- if (!in_spec)
- fs = ffecom_sym_exec_transition (fs);
-
- ffesymbol_signal_unreported (fs);
-
- ffestd_R1226 (fs);
+ ffestd_R1111 (s, name);
}
-/* ffestc_R1227 -- RETURN statement
+/* ffestc_R1112 -- END BLOCK DATA statement
- ffestc_R1227(expr,expr_token);
+ ffestc_R1112(name_token);
- Make sure statement is valid here; implement. expr and expr_token are
- both NULL if there was no expression. */
+ Make sure ffestc_kind_ identifies the current kind of program unit. If not
+ NULL, make sure name_token gives the correct name. Implement the end
+ of the current program unit. */
void
-ffestc_R1227 (ffebld expr, ffelexToken expr_token)
+ffestc_R1112 (ffelexToken name)
{
- ffestw b;
-
ffestc_check_simple_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
+ if (ffestc_order_blockdata_ () != FFESTC_orderOK_)
return;
- ffestc_labeldef_notloop_begin_ ();
-
- for (b = ffestw_stack_top (); ; b = ffestw_previous (b))
- {
- switch (ffestw_state (b))
- {
- case FFESTV_statePROGRAM4:
- case FFESTV_stateSUBROUTINE4:
- case FFESTV_stateFUNCTION4:
- goto base; /* :::::::::::::::::::: */
-
- case FFESTV_stateNIL:
- assert ("bad state" == NULL);
- break;
-
- default:
- break;
- }
- }
+ ffestc_labeldef_useless_ ();
- base:
- switch (ffestw_state (b))
+ if (name != NULL)
{
- case FFESTV_statePROGRAM4:
- if (ffe_is_pedantic ())
- {
- ffebad_start (FFEBAD_RETURN_IN_MAIN);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_finish ();
- }
- if (expr != NULL)
+ if (ffestw_name (ffestw_stack_top ()) == NULL)
{
- ffebad_start (FFEBAD_ALTRETURN_IN_PROGRAM);
- ffebad_here (0, ffelex_token_where_line (expr_token),
- ffelex_token_where_column (expr_token));
+ ffebad_start (FFEBAD_BLOCKDATA_NOT_NAMED);
+ ffebad_here (0, ffelex_token_where_line (name),
+ ffelex_token_where_column (name));
+ ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
ffebad_finish ();
- expr = NULL;
}
- break;
-
- case FFESTV_stateSUBROUTINE4:
- break;
-
- case FFESTV_stateFUNCTION4:
- if (expr != NULL)
+ else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)
{
- ffebad_start (FFEBAD_ALTRETURN_IN_FUNCTION);
- ffebad_here (0, ffelex_token_where_line (expr_token),
- ffelex_token_where_column (expr_token));
+ ffebad_start (FFEBAD_UNIT_WRONG_NAME);
+ ffebad_here (0, ffelex_token_where_line (name),
+ ffelex_token_where_column (name));
+ ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
+ ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
ffebad_finish ();
- expr = NULL;
}
- break;
-
- default:
- assert ("bad state #2" == NULL);
- break;
}
- ffestd_R1227 (expr);
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
-
- /* notloop's that are actionif's can be the target of a loop-end
- statement if they're in the "then" part of a logical IF, as
- in "DO 10", "10 IF (...) RETURN". */
-
- ffestc_labeldef_branch_end_ ();
+ ffestc_shriek_blockdata_ (TRUE);
}
-/* ffestc_R1228 -- CONTAINS statement
+/* ffestc_R1207_start -- EXTERNAL statement list begin
+
+ ffestc_R1207_start();
- ffestc_R1228(); */
+ Verify that EXTERNAL is valid here, and begin accepting items in the list. */
-#if FFESTR_F90
void
-ffestc_R1228 ()
+ffestc_R1207_start ()
{
- ffestc_check_simple_ ();
- if (ffestc_order_contains_ () != FFESTC_orderOK_)
- return;
+ ffestc_check_start_ ();
+ if (ffestc_order_progspec_ () != FFESTC_orderOK_)
+ {
+ ffestc_ok_ = FALSE;
+ return;
+ }
ffestc_labeldef_useless_ ();
- ffestd_R1228 ();
+ ffestd_R1207_start ();
- ffe_terminate_3 ();
- ffe_init_3 ();
+ ffestc_ok_ = TRUE;
}
-#endif
-/* ffestc_R1229_start -- STMTFUNCTION statement begin
+/* ffestc_R1207_item -- EXTERNAL statement for name
- ffestc_R1229_start(func_name,func_arg_list,close_paren);
+ ffestc_R1207_item(name_token);
- Verify that STMTFUNCTION is valid here, establish func_arg_list in a new
- "live" scope within the current scope, and expect the actual expression
- (or NULL) in ffestc_R1229_finish. The reason there are two ffestc
- functions to handle this is so the scope can be established, allowing
- ffeexpr to assign proper characteristics to references to the dummy
- arguments. */
+ Make sure name_token identifies a valid object to be EXTERNALd. */
void
-ffestc_R1229_start (ffelexToken name, ffesttTokenList args,
- ffelexToken final UNUSED)
+ffestc_R1207_item (ffelexToken name)
{
ffesymbol s;
ffesymbolAttrs sa;
ffesymbolAttrs na;
- ffestc_check_start_ ();
- if (ffestc_order_sfunc_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_useless_ ();
-
+ ffestc_check_item_ ();
assert (name != NULL);
- assert (args != NULL);
+ if (!ffestc_ok_)
+ return;
s = ffesymbol_declare_local (name, FALSE);
sa = ffesymbol_attrs (s);
na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
else if (sa & FFESYMBOL_attrsANY)
na = FFESYMBOL_attrsANY;
- else if (!(sa & ~FFESYMBOL_attrsTYPE))
- na = sa | FFESYMBOL_attrsSFUNC;
+ else if (!(sa & ~(FFESYMBOL_attrsDUMMY
+ | FFESYMBOL_attrsTYPE)))
+ na = sa | FFESYMBOL_attrsEXTERNAL;
else
na = FFESYMBOL_attrsetNONE;
update the object (symbol) and continue on. */
if (na == FFESYMBOL_attrsetNONE)
- {
- ffesymbol_error (s, name);
- ffestc_parent_ok_ = FALSE;
- }
- else if (na & FFESYMBOL_attrsANY)
- ffestc_parent_ok_ = FALSE;
- else
+ ffesymbol_error (s, name);
+ else if (!(na & FFESYMBOL_attrsANY))
{
ffesymbol_set_attrs (s, na);
ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
- if (!ffeimplic_establish_symbol (s)
- || ((ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
- && (ffesymbol_size (s) == FFETARGET_charactersizeNONE)))
- {
- ffesymbol_error (s, ffesta_tokens[0]);
- ffestc_parent_ok_ = FALSE;
- }
- else
- {
- /* Tell ffeexpr that sfunc def is in progress. */
- ffesymbol_set_sfexpr (s, ffebld_new_any ());
- ffebld_set_info (ffesymbol_sfexpr (s), ffeinfo_new_any ());
- ffestc_parent_ok_ = TRUE;
- }
- }
-
- ffe_init_4 ();
-
- if (ffestc_parent_ok_)
- {
- ffebld_init_list (&s->dummy_args, &ffestc_local_.dummy.list_bottom);
- ffestc_sfdummy_argno_ = 0;
- ffestt_tokenlist_drive (args, ffestc_promote_sfdummy_);
- ffebld_end_list (&ffestc_local_.dummy.list_bottom);
+ ffesymbol_set_explicitwhere (s, TRUE);
+ ffesymbol_reference (s, name, FALSE);
+ ffesymbol_signal_unreported (s);
}
- ffestc_local_.sfunc.symbol = s;
-
- ffestd_R1229_start (name, args);
-
- ffestc_ok_ = TRUE;
+ ffestd_R1207_item (name);
}
-/* ffestc_R1229_finish -- STMTFUNCTION statement list complete
+/* ffestc_R1207_finish -- EXTERNAL statement list complete
- ffestc_R1229_finish(expr,expr_token);
+ ffestc_R1207_finish();
- If expr is NULL, an error occurred parsing the expansion expression, so
- just cancel the effects of ffestc_R1229_start and pretend nothing
- happened. Otherwise, install the expression as the expansion for the
- statement function named in _start_, then clean up. */
+ Just wrap up any local activities. */
void
-ffestc_R1229_finish (ffebld expr, ffelexToken expr_token)
+ffestc_R1207_finish ()
{
ffestc_check_finish_ ();
if (!ffestc_ok_)
return;
- if (ffestc_parent_ok_ && (expr != NULL))
- ffesymbol_set_sfexpr (ffestc_local_.sfunc.symbol,
- ffeexpr_convert_to_sym (expr,
- expr_token,
- ffestc_local_.sfunc.symbol,
- ffesta_tokens[0]));
-
- ffestd_R1229_finish (ffestc_local_.sfunc.symbol);
-
- ffesymbol_signal_unreported (ffestc_local_.sfunc.symbol);
-
- ffe_terminate_4 ();
-}
-
-/* ffestc_S3P4 -- INCLUDE line
-
- ffestc_S3P4(filename,filename_token);
-
- Make sure INCLUDE not preceded by any semicolons or a label def; implement. */
-
-void
-ffestc_S3P4 (ffebld filename, ffelexToken filename_token UNUSED)
-{
- ffestc_check_simple_ ();
- ffestc_labeldef_invalid_ ();
-
- ffestd_S3P4 (filename);
+ ffestd_R1207_finish ();
}
-/* ffestc_V003_start -- STRUCTURE statement list begin
+/* ffestc_R1208_start -- INTRINSIC statement list begin
- ffestc_V003_start(structure_name);
+ ffestc_R1208_start();
- Verify that STRUCTURE is valid here, and begin accepting items in the list. */
+ Verify that INTRINSIC is valid here, and begin accepting items in the list. */
-#if FFESTR_VXT
void
-ffestc_V003_start (ffelexToken structure_name)
+ffestc_R1208_start ()
{
- ffestw b;
-
ffestc_check_start_ ();
- if (ffestc_order_vxtstructure_ () != FFESTC_orderOK_)
+ if (ffestc_order_progspec_ () != FFESTC_orderOK_)
{
ffestc_ok_ = FALSE;
return;
}
ffestc_labeldef_useless_ ();
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateSTRUCTURE:
- case FFESTV_stateMAP:
- ffestc_local_.V003.list_state = 2; /* Require at least one field
- name. */
- ffestw_set_substate (ffestw_stack_top (), 1); /* Seen at least one
- member. */
- break;
-
- default:
- ffestc_local_.V003.list_state = 0; /* No field names required. */
- if (structure_name == NULL)
- {
- ffebad_start (FFEBAD_STRUCT_MISSING_NAME);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_finish ();
- }
- break;
- }
-
- b = ffestw_update (ffestw_push (NULL));
- ffestw_set_top_do (b, NULL);
- ffestw_set_state (b, FFESTV_stateSTRUCTURE);
- ffestw_set_blocknum (b, 0);
- ffestw_set_shriek (b, ffestc_shriek_structure_);
- ffestw_set_substate (b, 0); /* No field-declarations seen yet. */
-
- ffestd_V003_start (structure_name);
+ ffestd_R1208_start ();
ffestc_ok_ = TRUE;
}
-/* ffestc_V003_item -- STRUCTURE statement for object-name
+/* ffestc_R1208_item -- INTRINSIC statement for name
- ffestc_V003_item(name_token,dim_list);
+ ffestc_R1208_item(name_token);
- Make sure name_token identifies a valid object to be STRUCTUREd. */
+ Make sure name_token identifies a valid object to be INTRINSICd. */
void
-ffestc_V003_item (ffelexToken name, ffesttDimList dims)
+ffestc_R1208_item (ffelexToken name)
{
+ ffesymbol s;
+ ffesymbolAttrs sa;
+ ffesymbolAttrs na;
+ ffeintrinGen gen;
+ ffeintrinSpec spec;
+ ffeintrinImp imp;
+
ffestc_check_item_ ();
assert (name != NULL);
if (!ffestc_ok_)
return;
- if (ffestc_local_.V003.list_state < 2)
- {
- if (ffestc_local_.V003.list_state == 0)
- {
- ffestc_local_.V003.list_state = 1;
- ffebad_start (FFEBAD_STRUCT_IGNORING_FIELD);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_finish ();
- }
- return;
- }
- ffestc_local_.V003.list_state = 3; /* Have at least one field name. */
-
- if (dims != NULL)
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
-
- ffestd_V003_item (name, dims);
-}
-
-/* ffestc_V003_finish -- STRUCTURE statement list complete
+ s = ffesymbol_declare_local (name, TRUE);
+ sa = ffesymbol_attrs (s);
- ffestc_V003_finish();
+ /* Figure out what kind of object we've got based on previous declarations
+ of or references to the object. */
- Just wrap up any local activities. */
+ if (!ffesymbol_is_specable (s))
+ na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
+ else if (sa & FFESYMBOL_attrsANY)
+ na = sa;
+ else if (!(sa & ~FFESYMBOL_attrsTYPE))
+ {
+ if (ffeintrin_is_intrinsic (ffelex_token_text (name), name, TRUE,
+ &gen, &spec, &imp)
+ && ((imp == FFEINTRIN_impNONE)
+#if 0 /* Don't bother with this for now. */
+ || ((ffeintrin_basictype (spec)
+ == ffesymbol_basictype (s))
+ && (ffeintrin_kindtype (spec)
+ == ffesymbol_kindtype (s)))
+#else
+ || 1
+#endif
+ || !(sa & FFESYMBOL_attrsTYPE)))
+ na = sa | FFESYMBOL_attrsINTRINSIC;
+ else
+ na = FFESYMBOL_attrsetNONE;
+ }
+ else
+ na = FFESYMBOL_attrsetNONE;
-void
-ffestc_V003_finish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
+ /* Now see what we've got for a new object: NONE means a new error cropped
+ up; ANY means an old error to be ignored; otherwise, everything's ok,
+ update the object (symbol) and continue on. */
- if (ffestc_local_.V003.list_state == 2)
+ if (na == FFESYMBOL_attrsetNONE)
+ ffesymbol_error (s, name);
+ else if (!(na & FFESYMBOL_attrsANY))
{
- ffebad_start (FFEBAD_STRUCT_MISSING_FIELD);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_here (1, ffestw_line (ffestw_previous (ffestw_stack_top ())),
- ffestw_col (ffestw_previous (ffestw_stack_top ())));
- ffebad_finish ();
+ ffesymbol_set_attrs (s, na);
+ ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
+ ffesymbol_set_generic (s, gen);
+ ffesymbol_set_specific (s, spec);
+ ffesymbol_set_implementation (s, imp);
+ ffesymbol_set_info (s,
+ ffeinfo_new (ffesymbol_basictype (s),
+ ffesymbol_kindtype (s),
+ 0,
+ FFEINFO_kindNONE,
+ FFEINFO_whereINTRINSIC,
+ ffesymbol_size (s)));
+ ffesymbol_set_explicitwhere (s, TRUE);
+ ffesymbol_reference (s, name, TRUE);
}
- ffestd_V003_finish ();
+ ffesymbol_signal_unreported (s);
+
+ ffestd_R1208_item (name);
}
-/* ffestc_V004 -- END STRUCTURE statement
+/* ffestc_R1208_finish -- INTRINSIC statement list complete
- ffestc_V004();
+ ffestc_R1208_finish();
- Make sure ffestc_kind_ identifies a STRUCTURE block.
- Implement the end of the current STRUCTURE block. */
+ Just wrap up any local activities. */
void
-ffestc_V004 ()
+ffestc_R1208_finish ()
{
- ffestc_check_simple_ ();
- if (ffestc_order_structure_ () != FFESTC_orderOK_)
+ ffestc_check_finish_ ();
+ if (!ffestc_ok_)
return;
- ffestc_labeldef_useless_ ();
-
- if (ffestw_substate (ffestw_stack_top ()) != 1)
- {
- ffebad_start (FFEBAD_STRUCT_NO_COMPONENTS);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
- }
- ffestc_shriek_structure_ (TRUE);
+ ffestd_R1208_finish ();
}
-/* ffestc_V009 -- UNION statement
+/* ffestc_R1212 -- CALL statement
+
+ ffestc_R1212(expr,expr_token);
- ffestc_V009(); */
+ Make sure statement is valid here; implement. */
void
-ffestc_V009 ()
+ffestc_R1212 (ffebld expr, ffelexToken expr_token UNUSED)
{
- ffestw b;
+ ffebld item; /* ITEM. */
+ ffebld labexpr; /* LABTOK=>LABTER. */
+ ffelab label;
+ bool ok; /* TRUE if all LABTOKs were ok. */
+ bool ok1; /* TRUE if a particular LABTOK is ok. */
ffestc_check_simple_ ();
- if (ffestc_order_structure_ () != FFESTC_orderOK_)
+ if (ffestc_order_actionif_ () != FFESTC_orderOK_)
return;
- ffestc_labeldef_useless_ ();
-
- ffestw_set_substate (ffestw_stack_top (), 1); /* Seen at least one member. */
-
- b = ffestw_update (ffestw_push (NULL));
- ffestw_set_top_do (b, NULL);
- ffestw_set_state (b, FFESTV_stateUNION);
- ffestw_set_blocknum (b, 0);
- ffestw_set_shriek (b, ffestc_shriek_union_);
- ffestw_set_substate (b, 0); /* No map decls seen yet. */
-
- ffestd_V009 ();
-}
-
-/* ffestc_V010 -- END UNION statement
-
- ffestc_V010();
+ ffestc_labeldef_branch_begin_ ();
- Make sure ffestc_kind_ identifies a UNION block.
- Implement the end of the current UNION block. */
+ if (ffebld_op (expr) != FFEBLD_opSUBRREF)
+ ffestd_R841 (FALSE); /* CONTINUE. */
+ else
+ {
+ ok = TRUE;
-void
-ffestc_V010 ()
-{
- ffestc_check_simple_ ();
- if (ffestc_order_union_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
+ for (item = ffebld_right (expr);
+ item != NULL;
+ item = ffebld_trail (item))
+ {
+ if (((labexpr = ffebld_head (item)) != NULL)
+ && (ffebld_op (labexpr) == FFEBLD_opLABTOK))
+ {
+ ok1 = ffestc_labelref_is_branch_ (ffebld_labtok (labexpr),
+ &label);
+ ffelex_token_kill (ffebld_labtok (labexpr));
+ if (!ok1)
+ {
+ label = NULL;
+ ok = FALSE;
+ }
+ ffebld_set_op (labexpr, FFEBLD_opLABTER);
+ ffebld_set_labter (labexpr, label);
+ }
+ }
- if (ffestw_substate (ffestw_stack_top ()) != 2)
- {
- ffebad_start (FFEBAD_UNION_NO_TWO_MAPS);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
+ if (ok)
+ ffestd_R1212 (expr);
}
- ffestc_shriek_union_ (TRUE);
+ if (ffestc_shriek_after1_ != NULL)
+ (*ffestc_shriek_after1_) (TRUE);
+ ffestc_labeldef_branch_end_ ();
}
-/* ffestc_V012 -- MAP statement
+/* ffestc_R1219 -- FUNCTION statement
+
+ ffestc_R1219(funcname,arglist,ending_token,kind,kindt,len,lent,
+ recursive);
+
+ Make sure statement is valid here, register arguments for the
+ function name, and so on.
- ffestc_V012(); */
+ 06-Apr-90 JCB 2.0
+ Added the kind, len, and recursive arguments. */
void
-ffestc_V012 ()
+ffestc_R1219 (ffelexToken funcname, ffesttTokenList args,
+ ffelexToken final UNUSED, ffestpType type, ffebld kind,
+ ffelexToken kindt, ffebld len, ffelexToken lent,
+ ffelexToken recursive, ffelexToken result)
{
ffestw b;
+ ffesymbol s;
+ ffesymbol fs; /* FUNCTION symbol when dealing with RESULT
+ symbol. */
+ ffesymbolAttrs sa;
+ ffesymbolAttrs na;
+ ffelexToken res;
+ bool separate_result;
+
+ assert ((funcname != NULL)
+ && (ffelex_token_type (funcname) == FFELEX_typeNAME));
ffestc_check_simple_ ();
- if (ffestc_order_union_ () != FFESTC_orderOK_)
+ if (ffestc_order_iface_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_useless_ ();
- if (ffestw_substate (ffestw_stack_top ()) != 2)
- ffestw_substate (ffestw_stack_top ())++; /* 0=>1, 1=>2. */
-
+ ffestc_blocknum_ = 0;
+ ffesta_is_entry_valid =
+ (ffestw_state (ffestw_stack_top ()) == FFESTV_stateNIL);
b = ffestw_update (ffestw_push (NULL));
ffestw_set_top_do (b, NULL);
- ffestw_set_state (b, FFESTV_stateMAP);
- ffestw_set_blocknum (b, 0);
- ffestw_set_shriek (b, ffestc_shriek_map_);
- ffestw_set_substate (b, 0); /* No field-declarations seen yet. */
-
- ffestd_V012 ();
-}
-
-/* ffestc_V013 -- END MAP statement
-
- ffestc_V013();
-
- Make sure ffestc_kind_ identifies a MAP block.
- Implement the end of the current MAP block. */
-
-void
-ffestc_V013 ()
-{
- ffestc_check_simple_ ();
- if (ffestc_order_map_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
+ ffestw_set_state (b, FFESTV_stateFUNCTION0);
+ ffestw_set_blocknum (b, ffestc_blocknum_++);
+ ffestw_set_shriek (b, ffestc_shriek_function_);
+ ffestw_set_name (b, ffelex_token_use (funcname));
- if (ffestw_substate (ffestw_stack_top ()) != 1)
+ if (type == FFESTP_typeNone)
{
- ffebad_start (FFEBAD_MAP_NO_COMPONENTS);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
+ ffestc_local_.decl.basic_type = FFEINFO_basictypeNONE;
+ ffestc_local_.decl.kind_type = FFEINFO_kindtypeNONE;
+ ffestc_local_.decl.size = FFETARGET_charactersizeNONE;
}
-
- ffestc_shriek_map_ (TRUE);
-}
-
-#endif
-/* ffestc_V014_start -- VOLATILE statement list begin
-
- ffestc_V014_start();
-
- Verify that VOLATILE is valid here, and begin accepting items in the
- list. */
-
-void
-ffestc_V014_start ()
-{
- ffestc_check_start_ ();
- if (ffestc_order_progspec_ () != FFESTC_orderOK_)
+ else
{
- ffestc_ok_ = FALSE;
- return;
+ ffestc_establish_declstmt_ (type, ffesta_tokens[0],
+ kind, kindt, len, lent);
+ ffestc_establish_declinfo_ (NULL, NULL, NULL, NULL);
}
- ffestc_labeldef_useless_ ();
-
- ffestd_V014_start ();
-
- ffestc_ok_ = TRUE;
-}
-
-/* ffestc_V014_item_object -- VOLATILE statement for object-name
-
- ffestc_V014_item_object(name_token);
-
- Make sure name_token identifies a valid object to be VOLATILEd. */
-
-void
-ffestc_V014_item_object (ffelexToken name)
-{
- ffestc_check_item_ ();
- assert (name != NULL);
- if (!ffestc_ok_)
- return;
-
- ffestd_V014_item_object (name);
-}
-/* ffestc_V014_item_cblock -- VOLATILE statement for common-block-name
+ separate_result = (result != NULL)
+ && (ffelex_token_strcmp (funcname, result) != 0);
- ffestc_V014_item_cblock(name_token);
+ if (separate_result)
+ fs = ffesymbol_declare_funcnotresunit (funcname); /* Global/local. */
+ else
+ fs = ffesymbol_declare_funcunit (funcname); /* Global only. */
- Make sure name_token identifies a valid common block to be VOLATILEd. */
+ if (ffesymbol_state (fs) == FFESYMBOL_stateNONE)
+ {
+ ffesymbol_set_state (fs, FFESYMBOL_stateUNDERSTOOD);
+ ffesymbol_signal_unreported (fs);
-void
-ffestc_V014_item_cblock (ffelexToken name)
-{
- ffestc_check_item_ ();
- assert (name != NULL);
- if (!ffestc_ok_)
- return;
+ /* Note that .basic_type and .kind_type might be NONE here. */
- ffestd_V014_item_cblock (name);
-}
+ ffesymbol_set_info (fs,
+ ffeinfo_new (ffestc_local_.decl.basic_type,
+ ffestc_local_.decl.kind_type,
+ 0,
+ FFEINFO_kindFUNCTION,
+ FFEINFO_whereLOCAL,
+ ffestc_local_.decl.size));
-/* ffestc_V014_finish -- VOLATILE statement list complete
+ /* Check whether the type info fits the filewide expectations;
+ set ok flag accordingly. */
- ffestc_V014_finish();
+ ffesymbol_reference (fs, funcname, FALSE);
+ if (ffesymbol_attrs (fs) & FFESYMBOL_attrsANY)
+ ffestc_parent_ok_ = FALSE;
+ else
+ ffestc_parent_ok_ = TRUE;
+ }
+ else
+ {
+ if (ffesymbol_kind (fs) != FFEINFO_kindANY)
+ ffesymbol_error (fs, funcname);
+ ffestc_parent_ok_ = FALSE;
+ }
- Just wrap up any local activities. */
+ if (ffestc_parent_ok_)
+ {
+ ffebld_init_list (&fs->dummy_args, &ffestc_local_.dummy.list_bottom);
+ ffestt_tokenlist_drive (args, ffestc_promote_dummy_);
+ ffebld_end_list (&ffestc_local_.dummy.list_bottom);
+ }
-void
-ffestc_V014_finish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
+ if (result == NULL)
+ res = funcname;
+ else
+ res = result;
- ffestd_V014_finish ();
-}
+ s = ffesymbol_declare_funcresult (res);
+ sa = ffesymbol_attrs (s);
-/* ffestc_V016_start -- RECORD statement list begin
+ /* Figure out what kind of object we've got based on previous declarations
+ of or references to the object. */
- ffestc_V016_start();
+ if (sa & FFESYMBOL_attrsANY)
+ na = FFESYMBOL_attrsANY;
+ else if (ffesymbol_state (s) != FFESYMBOL_stateNONE)
+ na = FFESYMBOL_attrsetNONE;
+ else
+ {
+ na = FFESYMBOL_attrsRESULT;
+ if (ffestc_local_.decl.basic_type != FFEINFO_basictypeNONE)
+ {
+ na |= FFESYMBOL_attrsTYPE;
+ if ((ffestc_local_.decl.basic_type == FFEINFO_basictypeCHARACTER)
+ && (ffestc_local_.decl.size == FFETARGET_charactersizeNONE))
+ na |= FFESYMBOL_attrsANYLEN;
+ }
+ }
- Verify that RECORD is valid here, and begin accepting items in the list. */
+ /* Now see what we've got for a new object: NONE means a new error cropped
+ up; ANY means an old error to be ignored; otherwise, everything's ok,
+ update the object (symbol) and continue on. */
-#if FFESTR_VXT
-void
-ffestc_V016_start ()
-{
- ffestc_check_start_ ();
- if (ffestc_order_record_ () != FFESTC_orderOK_)
+ if ((na & ~FFESYMBOL_attrsANY) == FFESYMBOL_attrsetNONE)
{
- ffestc_ok_ = FALSE;
- return;
+ if (!(na & FFESYMBOL_attrsANY))
+ ffesymbol_error (s, res);
+ ffesymbol_set_funcresult (fs, NULL);
+ ffesymbol_set_funcresult (s, NULL);
+ ffestc_parent_ok_ = FALSE;
}
- ffestc_labeldef_useless_ ();
-
- switch (ffestw_state (ffestw_stack_top ()))
+ else
{
- case FFESTV_stateSTRUCTURE:
- case FFESTV_stateMAP:
- ffestw_set_substate (ffestw_stack_top (), 1); /* Seen at least one
- member. */
- break;
-
- default:
- break;
+ ffesymbol_set_attrs (s, na);
+ ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
+ ffesymbol_set_funcresult (fs, s);
+ ffesymbol_set_funcresult (s, fs);
+ if (ffestc_local_.decl.basic_type != FFEINFO_basictypeNONE)
+ {
+ ffesymbol_set_info (s,
+ ffeinfo_new (ffestc_local_.decl.basic_type,
+ ffestc_local_.decl.kind_type,
+ 0,
+ FFEINFO_kindNONE,
+ FFEINFO_whereNONE,
+ ffestc_local_.decl.size));
+ }
}
- ffestd_V016_start ();
-
- ffestc_ok_ = TRUE;
-}
-
-/* ffestc_V016_item_structure -- RECORD statement for common-block-name
-
- ffestc_V016_item_structure(name_token);
-
- Make sure name_token identifies a valid structure to be RECORDed. */
-
-void
-ffestc_V016_item_structure (ffelexToken name)
-{
- ffestc_check_item_ ();
- assert (name != NULL);
- if (!ffestc_ok_)
- return;
+ ffesymbol_signal_unreported (fs);
- ffestd_V016_item_structure (name);
+ ffestd_R1219 (fs, funcname, args, type, kind, kindt, len, lent,
+ (recursive != NULL), result, separate_result);
}
-/* ffestc_V016_item_object -- RECORD statement for object-name
+/* ffestc_R1221 -- END FUNCTION statement
- ffestc_V016_item_object(name_token,dim_list);
+ ffestc_R1221(name_token);
- Make sure name_token identifies a valid object to be RECORDd. */
+ Make sure ffestc_kind_ identifies the current kind of program unit. If
+ not NULL, make sure name_token gives the correct name. Implement the end
+ of the current program unit. */
void
-ffestc_V016_item_object (ffelexToken name, ffesttDimList dims)
+ffestc_R1221 (ffelexToken name)
{
- ffestc_check_item_ ();
- assert (name != NULL);
- if (!ffestc_ok_)
+ ffestc_check_simple_ ();
+ if (ffestc_order_function_ () != FFESTC_orderOK_)
return;
+ ffestc_labeldef_notloop_ ();
- if (dims != NULL)
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
+ if ((name != NULL)
+ && (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0))
+ {
+ ffebad_start (FFEBAD_UNIT_WRONG_NAME);
+ ffebad_here (0, ffelex_token_where_line (name),
+ ffelex_token_where_column (name));
+ ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
+ ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
+ ffebad_finish ();
+ }
- ffestd_V016_item_object (name, dims);
+ ffestc_shriek_function_ (TRUE);
}
-/* ffestc_V016_finish -- RECORD statement list complete
+/* ffestc_R1223 -- SUBROUTINE statement
- ffestc_V016_finish();
+ ffestc_R1223(subrname,arglist,ending_token,recursive_token);
- Just wrap up any local activities. */
+ Make sure statement is valid here, register arguments for the
+ subroutine name, and so on.
+
+ 06-Apr-90 JCB 2.0
+ Added the recursive argument. */
void
-ffestc_V016_finish ()
+ffestc_R1223 (ffelexToken subrname, ffesttTokenList args,
+ ffelexToken final, ffelexToken recursive)
{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_V016_finish ();
-}
-
-/* ffestc_V018_start -- REWRITE(...) statement list begin
+ ffestw b;
+ ffesymbol s;
- ffestc_V018_start();
+ assert ((subrname != NULL)
+ && (ffelex_token_type (subrname) == FFELEX_typeNAME));
- Verify that REWRITE is valid here, and begin accepting items in the
- list. */
+ ffestc_check_simple_ ();
+ if (ffestc_order_iface_ () != FFESTC_orderOK_)
+ return;
+ ffestc_labeldef_useless_ ();
-void
-ffestc_V018_start ()
-{
- ffestvFormat format;
+ ffestc_blocknum_ = 0;
+ ffesta_is_entry_valid
+ = (ffestw_state (ffestw_stack_top ()) == FFESTV_stateNIL);
+ b = ffestw_update (ffestw_push (NULL));
+ ffestw_set_top_do (b, NULL);
+ ffestw_set_state (b, FFESTV_stateSUBROUTINE0);
+ ffestw_set_blocknum (b, ffestc_blocknum_++);
+ ffestw_set_shriek (b, ffestc_shriek_subroutine_);
+ ffestw_set_name (b, ffelex_token_use (subrname));
- ffestc_check_start_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
+ s = ffesymbol_declare_subrunit (subrname);
+ if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
{
- ffestc_ok_ = FALSE;
- return;
+ ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
+ ffesymbol_set_info (s,
+ ffeinfo_new (FFEINFO_basictypeNONE,
+ FFEINFO_kindtypeNONE,
+ 0,
+ FFEINFO_kindSUBROUTINE,
+ FFEINFO_whereLOCAL,
+ FFETARGET_charactersizeNONE));
+ ffestc_parent_ok_ = TRUE;
}
- ffestc_labeldef_branch_begin_ ();
-
- if (!ffestc_subr_is_branch_
- (&ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixERR])
- || !ffestc_subr_is_format_
- (&ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT])
- || !ffestc_subr_is_present_ ("UNIT",
- &ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixUNIT]))
+ else
{
- ffestc_ok_ = FALSE;
- return;
+ if (ffesymbol_kind (s) != FFEINFO_kindANY)
+ ffesymbol_error (s, subrname);
+ ffestc_parent_ok_ = FALSE;
}
- format = ffestc_subr_format_
- (&ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT]);
- switch (format)
+ if (ffestc_parent_ok_)
{
- case FFESTV_formatNAMELIST:
- case FFESTV_formatASTERISK:
- ffebad_start (FFEBAD_CONFLICTING_SPECS);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- assert (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].kw_or_val_present);
- if (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].kw_present)
- {
- ffebad_here (0, ffelex_token_where_line
- (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].kw),
- ffelex_token_where_column
- (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].kw));
- }
- else
- {
- ffebad_here (1, ffelex_token_where_line
- (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].value),
- ffelex_token_where_column
- (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].value));
- }
- ffebad_finish ();
- ffestc_ok_ = FALSE;
- return;
-
- default:
- break;
+ ffebld_init_list (&s->dummy_args, &ffestc_local_.dummy.list_bottom);
+ ffestt_tokenlist_drive (args, ffestc_promote_dummy_);
+ ffebld_end_list (&ffestc_local_.dummy.list_bottom);
}
- ffestd_V018_start (format);
+ ffesymbol_signal_unreported (s);
- ffestc_ok_ = TRUE;
+ ffestd_R1223 (s, subrname, args, final, (recursive != NULL));
}
-/* ffestc_V018_item -- REWRITE statement i/o item
+/* ffestc_R1225 -- END SUBROUTINE statement
- ffestc_V018_item(expr,expr_token);
+ ffestc_R1225(name_token);
- Implement output-list expression. */
+ Make sure ffestc_kind_ identifies the current kind of program unit. If
+ not NULL, make sure name_token gives the correct name. Implement the end
+ of the current program unit. */
void
-ffestc_V018_item (ffebld expr, ffelexToken expr_token)
+ffestc_R1225 (ffelexToken name)
{
- ffestc_check_item_ ();
- if (!ffestc_ok_)
+ ffestc_check_simple_ ();
+ if (ffestc_order_subroutine_ () != FFESTC_orderOK_)
return;
+ ffestc_labeldef_notloop_ ();
- ffestd_V018_item (expr);
+ if ((name != NULL)
+ && (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0))
+ {
+ ffebad_start (FFEBAD_UNIT_WRONG_NAME);
+ ffebad_here (0, ffelex_token_where_line (name),
+ ffelex_token_where_column (name));
+ ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
+ ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
+ ffebad_finish ();
+ }
+
+ ffestc_shriek_subroutine_ (TRUE);
}
-/* ffestc_V018_finish -- REWRITE statement list complete
+/* ffestc_R1226 -- ENTRY statement
- ffestc_V018_finish();
+ ffestc_R1226(entryname,arglist,ending_token);
- Just wrap up any local activities. */
+ Make sure we're in a SUBROUTINE or FUNCTION, register arguments for the
+ entry point name, and so on. */
void
-ffestc_V018_finish ()
+ffestc_R1226 (ffelexToken entryname, ffesttTokenList args,
+ ffelexToken final UNUSED)
{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
+ ffesymbol s;
+ ffesymbol fs;
+ ffesymbolAttrs sa;
+ ffesymbolAttrs na;
+ bool in_spec; /* TRUE if further specification statements
+ may follow, FALSE if executable stmts. */
+ bool in_func; /* TRUE if ENTRY is a FUNCTION, not
+ SUBROUTINE. */
- ffestd_V018_finish ();
+ assert ((entryname != NULL)
+ && (ffelex_token_type (entryname) == FFELEX_typeNAME));
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
+ ffestc_check_simple_ ();
+ if (ffestc_order_entry_ () != FFESTC_orderOK_)
+ return;
+ ffestc_labeldef_useless_ ();
-/* ffestc_V019_start -- ACCEPT statement list begin
+ switch (ffestw_state (ffestw_stack_top ()))
+ {
+ case FFESTV_stateFUNCTION1:
+ case FFESTV_stateFUNCTION2:
+ case FFESTV_stateFUNCTION3:
+ in_func = TRUE;
+ in_spec = TRUE;
+ break;
- ffestc_V019_start();
+ case FFESTV_stateFUNCTION4:
+ in_func = TRUE;
+ in_spec = FALSE;
+ break;
- Verify that ACCEPT is valid here, and begin accepting items in the
- list. */
+ case FFESTV_stateSUBROUTINE1:
+ case FFESTV_stateSUBROUTINE2:
+ case FFESTV_stateSUBROUTINE3:
+ in_func = FALSE;
+ in_spec = TRUE;
+ break;
-void
-ffestc_V019_start ()
-{
- ffestvFormat format;
+ case FFESTV_stateSUBROUTINE4:
+ in_func = FALSE;
+ in_spec = FALSE;
+ break;
- ffestc_check_start_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
+ default:
+ assert ("ENTRY not in FUNCTION or SUBROUTINE?" == NULL);
+ in_func = FALSE;
+ in_spec = FALSE;
+ break;
}
- ffestc_labeldef_branch_begin_ ();
- if (!ffestc_subr_is_format_
- (&ffestp_file.accept.accept_spec[FFESTP_acceptixFORMAT]))
+ if (in_func)
+ fs = ffesymbol_declare_funcunit (entryname);
+ else
+ fs = ffesymbol_declare_subrunit (entryname);
+
+ if (ffesymbol_state (fs) == FFESYMBOL_stateNONE)
+ ffesymbol_set_state (fs, FFESYMBOL_stateUNDERSTOOD);
+ else
{
- ffestc_ok_ = FALSE;
- return;
+ if (ffesymbol_kind (fs) != FFEINFO_kindANY)
+ ffesymbol_error (fs, entryname);
}
- format = ffestc_subr_format_
- (&ffestp_file.accept.accept_spec[FFESTP_acceptixFORMAT]);
- ffestc_namelist_ = (format == FFESTV_formatNAMELIST);
-
- ffestd_V019_start (format);
+ ++ffestc_entry_num_;
- ffestc_ok_ = TRUE;
-}
+ ffebld_init_list (&fs->dummy_args, &ffestc_local_.dummy.list_bottom);
+ if (in_spec)
+ ffestt_tokenlist_drive (args, ffestc_promote_dummy_);
+ else
+ ffestt_tokenlist_drive (args, ffestc_promote_execdummy_);
+ ffebld_end_list (&ffestc_local_.dummy.list_bottom);
-/* ffestc_V019_item -- ACCEPT statement i/o item
+ if (in_func)
+ {
+ s = ffesymbol_declare_funcresult (entryname);
+ ffesymbol_set_funcresult (fs, s);
+ ffesymbol_set_funcresult (s, fs);
+ sa = ffesymbol_attrs (s);
- ffestc_V019_item(expr,expr_token);
+ /* Figure out what kind of object we've got based on previous
+ declarations of or references to the object. */
- Implement output-list expression. */
+ if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
+ na = FFESYMBOL_attrsetNONE;
+ else if (sa & FFESYMBOL_attrsANY)
+ na = FFESYMBOL_attrsANY;
+ else if (!(sa & ~(FFESYMBOL_attrsANYLEN
+ | FFESYMBOL_attrsTYPE)))
+ na = sa | FFESYMBOL_attrsRESULT;
+ else
+ na = FFESYMBOL_attrsetNONE;
-void
-ffestc_V019_item (ffebld expr, ffelexToken expr_token)
-{
- ffestc_check_item_ ();
- if (!ffestc_ok_)
- return;
+ /* Now see what we've got for a new object: NONE means a new error
+ cropped up; ANY means an old error to be ignored; otherwise,
+ everything's ok, update the object (symbol) and continue on. */
- if (ffestc_namelist_ != 0)
- {
- if (ffestc_namelist_ == 1)
+ if (na == FFESYMBOL_attrsetNONE)
{
- ffestc_namelist_ = 2;
- ffebad_start (FFEBAD_NAMELIST_ITEMS);
- ffebad_here (0, ffelex_token_where_line (expr_token),
- ffelex_token_where_column (expr_token));
- ffebad_finish ();
+ ffesymbol_error (s, entryname);
+ ffestc_parent_ok_ = FALSE;
+ }
+ else if (na & FFESYMBOL_attrsANY)
+ {
+ ffestc_parent_ok_ = FALSE;
+ }
+ else
+ {
+ ffesymbol_set_attrs (s, na);
+ if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
+ ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
+ else if (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN)
+ {
+ ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
+ ffesymbol_set_info (s,
+ ffeinfo_new (ffesymbol_basictype (s),
+ ffesymbol_kindtype (s),
+ 0,
+ FFEINFO_kindENTITY,
+ FFEINFO_whereRESULT,
+ ffesymbol_size (s)));
+ ffesymbol_resolve_intrin (s);
+ ffestorag_exec_layout (s);
+ }
}
- return;
- }
-
- ffestd_V019_item (expr);
-}
-
-/* ffestc_V019_finish -- ACCEPT statement list complete
-
- ffestc_V019_finish();
- Just wrap up any local activities. */
+ /* Since ENTRY might appear after executable stmts, do what would have
+ been done if it hadn't -- give symbol implicit type and
+ exec-transition it. */
-void
-ffestc_V019_finish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
+ if (!in_spec && ffesymbol_is_specable (s))
+ {
+ if (!ffeimplic_establish_symbol (s)) /* Do implicit typing. */
+ ffesymbol_error (s, entryname);
+ s = ffecom_sym_exec_transition (s);
+ }
- ffestd_V019_finish ();
+ /* Use whatever type info is available for ENTRY to set up type for its
+ global-name-space function symbol relative. */
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
+ ffesymbol_set_info (fs,
+ ffeinfo_new (ffesymbol_basictype (s),
+ ffesymbol_kindtype (s),
+ 0,
+ FFEINFO_kindFUNCTION,
+ FFEINFO_whereLOCAL,
+ ffesymbol_size (s)));
-#endif
-/* ffestc_V020_start -- TYPE statement list begin
- ffestc_V020_start();
+ /* Check whether the type info fits the filewide expectations;
+ set ok flag accordingly. */
- Verify that TYPE is valid here, and begin accepting items in the
- list. */
+ ffesymbol_reference (fs, entryname, FALSE);
-void
-ffestc_V020_start ()
-{
- ffestvFormat format;
+ /* ~~Question??:
+ When ENTRY FOO() RESULT(IBAR) is supported, what will the typing be
+ if FOO and IBAR would normally end up with different types? I think
+ the answer is that FOO is always given whatever type would be chosen
+ for IBAR, rather than the other way around, and I think it ends up
+ working that way for FUNCTION FOO() RESULT(IBAR), but this should be
+ checked out in all its different combos. Related question is, is
+ there any way that FOO in either case ends up without type info
+ filled in? Does anyone care? */
- ffestc_check_start_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
+ ffesymbol_signal_unreported (s);
}
- ffestc_labeldef_branch_begin_ ();
-
- if (!ffestc_subr_is_format_
- (&ffestp_file.type.type_spec[FFESTP_typeixFORMAT]))
+ else
{
- ffestc_ok_ = FALSE;
- return;
+ ffesymbol_set_info (fs,
+ ffeinfo_new (FFEINFO_basictypeNONE,
+ FFEINFO_kindtypeNONE,
+ 0,
+ FFEINFO_kindSUBROUTINE,
+ FFEINFO_whereLOCAL,
+ FFETARGET_charactersizeNONE));
}
- format = ffestc_subr_format_
- (&ffestp_file.type.type_spec[FFESTP_typeixFORMAT]);
- ffestc_namelist_ = (format == FFESTV_formatNAMELIST);
+ if (!in_spec)
+ fs = ffecom_sym_exec_transition (fs);
- ffestd_V020_start (format);
+ ffesymbol_signal_unreported (fs);
- ffestc_ok_ = TRUE;
+ ffestd_R1226 (fs);
}
-/* ffestc_V020_item -- TYPE statement i/o item
+/* ffestc_R1227 -- RETURN statement
- ffestc_V020_item(expr,expr_token);
+ ffestc_R1227(expr,expr_token);
- Implement output-list expression. */
+ Make sure statement is valid here; implement. expr and expr_token are
+ both NULL if there was no expression. */
void
-ffestc_V020_item (ffebld expr, ffelexToken expr_token)
+ffestc_R1227 (ffebld expr, ffelexToken expr_token)
{
- ffestc_check_item_ ();
- if (!ffestc_ok_)
+ ffestw b;
+
+ ffestc_check_simple_ ();
+ if (ffestc_order_actionif_ () != FFESTC_orderOK_)
return;
+ ffestc_labeldef_notloop_begin_ ();
- if (ffestc_namelist_ != 0)
+ for (b = ffestw_stack_top (); ; b = ffestw_previous (b))
{
- if (ffestc_namelist_ == 1)
+ switch (ffestw_state (b))
{
- ffestc_namelist_ = 2;
- ffebad_start (FFEBAD_NAMELIST_ITEMS);
+ case FFESTV_statePROGRAM4:
+ case FFESTV_stateSUBROUTINE4:
+ case FFESTV_stateFUNCTION4:
+ goto base; /* :::::::::::::::::::: */
+
+ case FFESTV_stateNIL:
+ assert ("bad state" == NULL);
+ break;
+
+ default:
+ break;
+ }
+ }
+
+ base:
+ switch (ffestw_state (b))
+ {
+ case FFESTV_statePROGRAM4:
+ if (ffe_is_pedantic ())
+ {
+ ffebad_start (FFEBAD_RETURN_IN_MAIN);
+ ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
+ ffelex_token_where_column (ffesta_tokens[0]));
+ ffebad_finish ();
+ }
+ if (expr != NULL)
+ {
+ ffebad_start (FFEBAD_ALTRETURN_IN_PROGRAM);
ffebad_here (0, ffelex_token_where_line (expr_token),
ffelex_token_where_column (expr_token));
ffebad_finish ();
+ expr = NULL;
}
- return;
- }
-
- ffestd_V020_item (expr);
-}
-
-/* ffestc_V020_finish -- TYPE statement list complete
-
- ffestc_V020_finish();
-
- Just wrap up any local activities. */
-
-void
-ffestc_V020_finish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_V020_finish ();
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_V021 -- DELETE statement
+ break;
- ffestc_V021();
+ case FFESTV_stateSUBROUTINE4:
+ break;
- Make sure a DELETE is valid in the current context, and implement it. */
+ case FFESTV_stateFUNCTION4:
+ if (expr != NULL)
+ {
+ ffebad_start (FFEBAD_ALTRETURN_IN_FUNCTION);
+ ffebad_here (0, ffelex_token_where_line (expr_token),
+ ffelex_token_where_column (expr_token));
+ ffebad_finish ();
+ expr = NULL;
+ }
+ break;
-#if FFESTR_VXT
-void
-ffestc_V021 ()
-{
- ffestc_check_simple_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_branch_begin_ ();
+ default:
+ assert ("bad state #2" == NULL);
+ break;
+ }
- if (ffestc_subr_is_branch_
- (&ffestp_file.delete.delete_spec[FFESTP_deleteixERR])
- && ffestc_subr_is_present_ ("UNIT",
- &ffestp_file.delete.delete_spec[FFESTP_deleteixUNIT]))
- ffestd_V021 ();
+ ffestd_R1227 (expr);
if (ffestc_shriek_after1_ != NULL)
(*ffestc_shriek_after1_) (TRUE);
+
+ /* notloop's that are actionif's can be the target of a loop-end
+ statement if they're in the "then" part of a logical IF, as
+ in "DO 10", "10 IF (...) RETURN". */
+
ffestc_labeldef_branch_end_ ();
}
-/* ffestc_V022 -- UNLOCK statement
+/* ffestc_R1229_start -- STMTFUNCTION statement begin
- ffestc_V022();
+ ffestc_R1229_start(func_name,func_arg_list,close_paren);
- Make sure a UNLOCK is valid in the current context, and implement it. */
+ Verify that STMTFUNCTION is valid here, establish func_arg_list in a new
+ "live" scope within the current scope, and expect the actual expression
+ (or NULL) in ffestc_R1229_finish. The reason there are two ffestc
+ functions to handle this is so the scope can be established, allowing
+ ffeexpr to assign proper characteristics to references to the dummy
+ arguments. */
void
-ffestc_V022 ()
+ffestc_R1229_start (ffelexToken name, ffesttTokenList args,
+ ffelexToken final UNUSED)
{
- ffestc_check_simple_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_branch_begin_ ();
+ ffesymbol s;
+ ffesymbolAttrs sa;
+ ffesymbolAttrs na;
- if (ffestc_subr_is_branch_
- (&ffestp_file.beru.beru_spec[FFESTP_beruixERR])
- && ffestc_subr_is_present_ ("UNIT",
- &ffestp_file.beru.beru_spec[FFESTP_beruixUNIT]))
- ffestd_V022 ();
+ ffestc_check_start_ ();
+ if (ffestc_order_sfunc_ () != FFESTC_orderOK_)
+ {
+ ffestc_ok_ = FALSE;
+ return;
+ }
+ ffestc_labeldef_useless_ ();
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
+ assert (name != NULL);
+ assert (args != NULL);
-/* ffestc_V023_start -- ENCODE(...) statement list begin
+ s = ffesymbol_declare_local (name, FALSE);
+ sa = ffesymbol_attrs (s);
- ffestc_V023_start();
+ /* Figure out what kind of object we've got based on previous declarations
+ of or references to the object. */
- Verify that ENCODE is valid here, and begin accepting items in the
- list. */
+ if (!ffesymbol_is_specable (s))
+ na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
+ else if (sa & FFESYMBOL_attrsANY)
+ na = FFESYMBOL_attrsANY;
+ else if (!(sa & ~FFESYMBOL_attrsTYPE))
+ na = sa | FFESYMBOL_attrsSFUNC;
+ else
+ na = FFESYMBOL_attrsetNONE;
-void
-ffestc_V023_start ()
-{
- ffestc_check_start_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
+ /* Now see what we've got for a new object: NONE means a new error cropped
+ up; ANY means an old error to be ignored; otherwise, everything's ok,
+ update the object (symbol) and continue on. */
+
+ if (na == FFESYMBOL_attrsetNONE)
{
- ffestc_ok_ = FALSE;
- return;
+ ffesymbol_error (s, name);
+ ffestc_parent_ok_ = FALSE;
+ }
+ else if (na & FFESYMBOL_attrsANY)
+ ffestc_parent_ok_ = FALSE;
+ else
+ {
+ ffesymbol_set_attrs (s, na);
+ ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
+ if (!ffeimplic_establish_symbol (s)
+ || ((ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
+ && (ffesymbol_size (s) == FFETARGET_charactersizeNONE)))
+ {
+ ffesymbol_error (s, ffesta_tokens[0]);
+ ffestc_parent_ok_ = FALSE;
+ }
+ else
+ {
+ /* Tell ffeexpr that sfunc def is in progress. */
+ ffesymbol_set_sfexpr (s, ffebld_new_any ());
+ ffebld_set_info (ffesymbol_sfexpr (s), ffeinfo_new_any ());
+ ffestc_parent_ok_ = TRUE;
+ }
}
- ffestc_labeldef_branch_begin_ ();
- if (!ffestc_subr_is_branch_
- (&ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixERR]))
+ ffe_init_4 ();
+
+ if (ffestc_parent_ok_)
{
- ffestc_ok_ = FALSE;
- return;
+ ffebld_init_list (&s->dummy_args, &ffestc_local_.dummy.list_bottom);
+ ffestc_sfdummy_argno_ = 0;
+ ffestt_tokenlist_drive (args, ffestc_promote_sfdummy_);
+ ffebld_end_list (&ffestc_local_.dummy.list_bottom);
}
- ffestd_V023_start ();
+ ffestc_local_.sfunc.symbol = s;
+
+ ffestd_R1229_start (name, args);
ffestc_ok_ = TRUE;
}
-/* ffestc_V023_item -- ENCODE statement i/o item
+/* ffestc_R1229_finish -- STMTFUNCTION statement list complete
- ffestc_V023_item(expr,expr_token);
+ ffestc_R1229_finish(expr,expr_token);
- Implement output-list expression. */
+ If expr is NULL, an error occurred parsing the expansion expression, so
+ just cancel the effects of ffestc_R1229_start and pretend nothing
+ happened. Otherwise, install the expression as the expansion for the
+ statement function named in _start_, then clean up. */
void
-ffestc_V023_item (ffebld expr, ffelexToken expr_token)
+ffestc_R1229_finish (ffebld expr, ffelexToken expr_token)
{
- ffestc_check_item_ ();
+ ffestc_check_finish_ ();
if (!ffestc_ok_)
return;
- ffestd_V023_item (expr);
+ if (ffestc_parent_ok_ && (expr != NULL))
+ ffesymbol_set_sfexpr (ffestc_local_.sfunc.symbol,
+ ffeexpr_convert_to_sym (expr,
+ expr_token,
+ ffestc_local_.sfunc.symbol,
+ ffesta_tokens[0]));
+
+ ffestd_R1229_finish (ffestc_local_.sfunc.symbol);
+
+ ffesymbol_signal_unreported (ffestc_local_.sfunc.symbol);
+
+ ffe_terminate_4 ();
}
-/* ffestc_V023_finish -- ENCODE statement list complete
+/* ffestc_S3P4 -- INCLUDE line
- ffestc_V023_finish();
+ ffestc_S3P4(filename,filename_token);
- Just wrap up any local activities. */
+ Make sure INCLUDE not preceded by any semicolons or a label def; implement. */
void
-ffestc_V023_finish ()
+ffestc_S3P4 (ffebld filename, ffelexToken filename_token UNUSED)
{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_V023_finish ();
+ ffestc_check_simple_ ();
+ ffestc_labeldef_invalid_ ();
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
+ ffestd_S3P4 (filename);
}
-/* ffestc_V024_start -- DECODE(...) statement list begin
+/* ffestc_V014_start -- VOLATILE statement list begin
- ffestc_V024_start();
+ ffestc_V014_start();
- Verify that DECODE is valid here, and begin accepting items in the
+ Verify that VOLATILE is valid here, and begin accepting items in the
list. */
void
-ffestc_V024_start ()
+ffestc_V014_start ()
{
ffestc_check_start_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_branch_begin_ ();
-
- if (!ffestc_subr_is_branch_
- (&ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixERR]))
+ if (ffestc_order_progspec_ () != FFESTC_orderOK_)
{
ffestc_ok_ = FALSE;
return;
}
+ ffestc_labeldef_useless_ ();
- ffestd_V024_start ();
+ ffestd_V014_start ();
ffestc_ok_ = TRUE;
}
-/* ffestc_V024_item -- DECODE statement i/o item
+/* ffestc_V014_item_object -- VOLATILE statement for object-name
- ffestc_V024_item(expr,expr_token);
+ ffestc_V014_item_object(name_token);
- Implement output-list expression. */
+ Make sure name_token identifies a valid object to be VOLATILEd. */
+
+void
+ffestc_V014_item_object (ffelexToken name)
+{
+ ffestc_check_item_ ();
+ assert (name != NULL);
+ if (!ffestc_ok_)
+ return;
+
+ ffestd_V014_item_object (name);
+}
+
+/* ffestc_V014_item_cblock -- VOLATILE statement for common-block-name
+
+ ffestc_V014_item_cblock(name_token);
+
+ Make sure name_token identifies a valid common block to be VOLATILEd. */
void
-ffestc_V024_item (ffebld expr, ffelexToken expr_token)
+ffestc_V014_item_cblock (ffelexToken name)
{
ffestc_check_item_ ();
+ assert (name != NULL);
if (!ffestc_ok_)
return;
- ffestd_V024_item (expr);
+ ffestd_V014_item_cblock (name);
}
-/* ffestc_V024_finish -- DECODE statement list complete
+/* ffestc_V014_finish -- VOLATILE statement list complete
- ffestc_V024_finish();
+ ffestc_V014_finish();
Just wrap up any local activities. */
void
-ffestc_V024_finish ()
+ffestc_V014_finish ()
{
ffestc_check_finish_ ();
if (!ffestc_ok_)
return;
- ffestd_V024_finish ();
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
+ ffestd_V014_finish ();
}
-/* ffestc_V025_start -- DEFINEFILE statement list begin
+/* ffestc_V020_start -- TYPE statement list begin
- ffestc_V025_start();
+ ffestc_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
-ffestc_V025_start ()
+ffestc_V020_start ()
{
+ ffestvFormat format;
+
ffestc_check_start_ ();
if (ffestc_order_actionif_ () != FFESTC_orderOK_)
{
}
ffestc_labeldef_branch_begin_ ();
- ffestd_V025_start ();
+ if (!ffestc_subr_is_format_
+ (&ffestp_file.type.type_spec[FFESTP_typeixFORMAT]))
+ {
+ ffestc_ok_ = FALSE;
+ return;
+ }
+
+ format = ffestc_subr_format_
+ (&ffestp_file.type.type_spec[FFESTP_typeixFORMAT]);
+ ffestc_namelist_ = (format == FFESTV_formatNAMELIST);
+
+ ffestd_V020_start (format);
ffestc_ok_ = TRUE;
}
-/* ffestc_V025_item -- DEFINE FILE statement item
+/* ffestc_V020_item -- TYPE statement i/o item
- ffestc_V025_item(u,ut,m,mt,n,nt,asv,asvt);
+ ffestc_V020_item(expr,expr_token);
- Implement item. */
+ Implement output-list expression. */
void
-ffestc_V025_item (ffebld u, ffelexToken ut, ffebld m, ffelexToken mt,
- ffebld n, ffelexToken nt, ffebld asv, ffelexToken asvt)
+ffestc_V020_item (ffebld expr, ffelexToken expr_token)
{
ffestc_check_item_ ();
if (!ffestc_ok_)
return;
- ffestd_V025_item (u, m, n, asv);
+ if (ffestc_namelist_ != 0)
+ {
+ if (ffestc_namelist_ == 1)
+ {
+ ffestc_namelist_ = 2;
+ ffebad_start (FFEBAD_NAMELIST_ITEMS);
+ ffebad_here (0, ffelex_token_where_line (expr_token),
+ ffelex_token_where_column (expr_token));
+ ffebad_finish ();
+ }
+ return;
+ }
+
+ ffestd_V020_item (expr);
}
-/* ffestc_V025_finish -- DEFINE FILE statement list complete
+/* ffestc_V020_finish -- TYPE statement list complete
- ffestc_V025_finish();
+ ffestc_V020_finish();
Just wrap up any local activities. */
void
-ffestc_V025_finish ()
+ffestc_V020_finish ()
{
ffestc_check_finish_ ();
if (!ffestc_ok_)
return;
- ffestd_V025_finish ();
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_V026 -- FIND statement
-
- ffestc_V026();
-
- Make sure a FIND is valid in the current context, and implement it. */
-
-void
-ffestc_V026 ()
-{
- ffestc_check_simple_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_branch_begin_ ();
-
- if (ffestc_subr_is_branch_
- (&ffestp_file.find.find_spec[FFESTP_findixERR])
- && ffestc_subr_is_present_ ("UNIT",
- &ffestp_file.find.find_spec[FFESTP_findixUNIT])
- && ffestc_subr_is_present_ ("REC",
- &ffestp_file.find.find_spec[FFESTP_findixREC]))
- ffestd_V026 ();
+ ffestd_V020_finish ();
if (ffestc_shriek_after1_ != NULL)
(*ffestc_shriek_after1_) (TRUE);
ffestc_labeldef_branch_end_ ();
}
-#endif
/* ffestc_V027_start -- VXT PARAMETER statement list begin
ffestc_V027_start();
OSDN Git Service
